diff --git a/Bytecodes.h b/Bytecodes.h --- a/Bytecodes.h +++ b/Bytecodes.h @@ -112,6 +112,109 @@ #define bci_PRIMCALL 87 +#define bci_BCO_NAME 88 + +#define bci_OP_ADD_64 90 +#define bci_OP_SUB_64 91 +#define bci_OP_AND_64 92 +#define bci_OP_XOR_64 93 +#define bci_OP_NOT_64 94 +#define bci_OP_NEG_64 95 +#define bci_OP_MUL_64 96 +#define bci_OP_SHL_64 97 +#define bci_OP_ASR_64 98 +#define bci_OP_LSR_64 99 +#define bci_OP_OR_64 100 + +#define bci_OP_NEQ_64 110 +#define bci_OP_EQ_64 111 +#define bci_OP_U_GE_64 112 +#define bci_OP_U_GT_64 113 +#define bci_OP_U_LT_64 114 +#define bci_OP_U_LE_64 115 +#define bci_OP_S_GE_64 116 +#define bci_OP_S_GT_64 117 +#define bci_OP_S_LT_64 118 +#define bci_OP_S_LE_64 119 + + +#define bci_OP_ADD_32 130 +#define bci_OP_SUB_32 131 +#define bci_OP_AND_32 132 +#define bci_OP_XOR_32 133 +#define bci_OP_NOT_32 134 +#define bci_OP_NEG_32 135 +#define bci_OP_MUL_32 136 +#define bci_OP_SHL_32 137 +#define bci_OP_ASR_32 138 +#define bci_OP_LSR_32 139 +#define bci_OP_OR_32 140 + +#define bci_OP_NEQ_32 150 +#define bci_OP_EQ_32 151 +#define bci_OP_U_GE_32 152 +#define bci_OP_U_GT_32 153 +#define bci_OP_U_LT_32 154 +#define bci_OP_U_LE_32 155 +#define bci_OP_S_GE_32 156 +#define bci_OP_S_GT_32 157 +#define bci_OP_S_LT_32 158 +#define bci_OP_S_LE_32 159 + + +#define bci_OP_ADD_16 170 +#define bci_OP_SUB_16 171 +#define bci_OP_AND_16 172 +#define bci_OP_XOR_16 173 +#define bci_OP_NOT_16 174 +#define bci_OP_NEG_16 175 +#define bci_OP_MUL_16 176 +#define bci_OP_SHL_16 177 +#define bci_OP_ASR_16 178 +#define bci_OP_LSR_16 179 +#define bci_OP_OR_16 180 + +#define bci_OP_NEQ_16 190 +#define bci_OP_EQ_16 191 +#define bci_OP_U_GE_16 192 +#define bci_OP_U_GT_16 193 +#define bci_OP_U_LT_16 194 +#define bci_OP_U_LE_16 195 +#define bci_OP_S_GE_16 196 +#define bci_OP_S_GT_16 197 +#define bci_OP_S_LT_16 198 +#define bci_OP_S_LE_16 199 + + +#define bci_OP_ADD_08 200 +#define bci_OP_SUB_08 201 +#define bci_OP_AND_08 202 +#define bci_OP_XOR_08 203 +#define bci_OP_NOT_08 204 +#define bci_OP_NEG_08 205 +#define bci_OP_MUL_08 206 +#define bci_OP_SHL_08 207 +#define bci_OP_ASR_08 208 +#define bci_OP_LSR_08 209 +#define bci_OP_OR_08 210 + +#define bci_OP_NEQ_08 220 +#define bci_OP_EQ_08 221 +#define bci_OP_U_GE_08 222 +#define bci_OP_U_GT_08 223 +#define bci_OP_U_LT_08 224 +#define bci_OP_U_LE_08 225 +#define bci_OP_S_GE_08 226 +#define bci_OP_S_GT_08 227 +#define bci_OP_S_LT_08 228 +#define bci_OP_S_LE_08 229 + +#define bci_OP_INDEX_ADDR_08 240 +#define bci_OP_INDEX_ADDR_16 241 +#define bci_OP_INDEX_ADDR_32 242 +#define bci_OP_INDEX_ADDR_64 243 + + /* If you need to go past 255 then you will run into the flags */ /* If you need to go below 0x0100 then you will run into the instructions */ diff --git a/ClosureTypes.h b/ClosureTypes.h --- a/ClosureTypes.h +++ b/ClosureTypes.h @@ -16,6 +16,7 @@ * - the closure flags table in rts/ClosureFlags.c * - isRetainer in rts/RetainerProfile.c * - the closure_type_names list in rts/Printer.c + * - the ClosureType sum type in libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs */ /* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B @@ -88,4 +89,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA 63 #define CONTINUATION 64 -#define N_CLOSURE_TYPES 65 +#define ANN_FRAME 65 +#define N_CLOSURE_TYPES 66 diff --git a/CodeGen.Platform.h b/CodeGen.Platform.h --- a/CodeGen.Platform.h +++ b/CodeGen.Platform.h @@ -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) || defined(MACHREGS_loongarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg @@ -480,6 +481,7 @@ #endif +-- See also Note [Caller saves and callee-saves regs.] callerSaves :: GlobalReg -> Bool #if defined(CALLER_SAVES_Base) callerSaves BaseReg = True @@ -1030,13 +1032,214 @@ -- ip0 -- used for spill offset computations freeReg 16 = False -#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) +-- Note [Aarch64 Register x18 at Darwin and Windows] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- x18 is reserved by the platform on Darwin/iOS, and can not be used -- More about ARM64 ABI that Apple platforms support: -- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms -- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md +-- It is a reserved at Windows as well. Acts like TEB register in user mode at Windows. +-- https://learn.microsoft.com/en-us/cpp/build/arm64-windows-abi-conventions +#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) || defined(mingw32_HOST_OS) freeReg 18 = False #endif + +# 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 +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif + +# if defined(REG_R1) +freeReg REG_R1 = False +# endif +# if defined(REG_R2) +freeReg REG_R2 = False +# endif +# if defined(REG_R3) +freeReg REG_R3 = False +# endif +# if defined(REG_R4) +freeReg REG_R4 = False +# endif +# if defined(REG_R5) +freeReg REG_R5 = False +# endif +# if defined(REG_R6) +freeReg REG_R6 = False +# endif +# if defined(REG_R7) +freeReg REG_R7 = False +# endif +# if defined(REG_R8) +freeReg REG_R8 = False +# endif + +# if defined(REG_F1) +freeReg REG_F1 = False +# endif +# if defined(REG_F2) +freeReg REG_F2 = False +# endif +# if defined(REG_F3) +freeReg REG_F3 = False +# endif +# if defined(REG_F4) +freeReg REG_F4 = False +# endif +# if defined(REG_F5) +freeReg REG_F5 = False +# endif +# if defined(REG_F6) +freeReg REG_F6 = False +# endif + +# if defined(REG_D1) +freeReg REG_D1 = False +# endif +# if defined(REG_D2) +freeReg REG_D2 = False +# endif +# if defined(REG_D3) +freeReg REG_D3 = False +# endif +# if defined(REG_D4) +freeReg REG_D4 = False +# endif +# if defined(REG_D5) +freeReg REG_D5 = False +# endif +# if defined(REG_D6) +freeReg REG_D6 = False +# endif + +freeReg _ = True + +#elif defined(MACHREGS_loongarch64) + +-- zero register +freeReg 0 = False +-- linker regster +freeReg 1 = False +-- thread register +freeReg 2 = False +-- stack pointer +freeReg 3 = False +-- made-up inter-procedural (ip) register for spilling offset computations +freeReg 20 = False +-- reserved +freeReg 21 = False +-- frame pointer +freeReg 22 = False # if defined(REG_Base) freeReg REG_Base = False diff --git a/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/GHC.hs @@ -3,6 +3,8 @@ {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} -- ----------------------------------------------------------------------------- -- @@ -36,7 +38,9 @@ setSessionDynFlags, setUnitDynFlags, getProgramDynFlags, setProgramDynFlags, + setProgramHUG, setProgramHUG_, getInteractiveDynFlags, setInteractiveDynFlags, + normaliseInteractiveDynFlags, initialiseInteractiveDynFlags, interpretPackageEnv, -- * Logging @@ -53,6 +57,7 @@ addTarget, removeTarget, guessTarget, + guessTargetId, -- * Loading\/compiling the program depanal, depanalE, @@ -76,29 +81,61 @@ ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgLookupModule, ModSummary(..), ms_mod_name, ModLocation(..), + pattern ModLocation, getModSummary, getModuleGraph, isLoaded, isLoadedModule, + isLoadedHomeModule, topSortModuleGraph, -- * Inspecting modules ModuleInfo, getModuleInfo, modInfoTyThings, - modInfoTopLevelScope, modInfoExports, modInfoExportsWithSelectors, modInfoInstances, modInfoIsExportedName, modInfoLookupName, modInfoIface, - modInfoRdrEnv, modInfoSafe, lookupGlobalName, findGlobalAnns, mkNamePprCtxForModule, - ModIface, ModIface_(..), + ModIface, + ModIface_( mi_mod_info + , mi_module + , mi_sig_of + , mi_hsc_src + , mi_iface_hash + , mi_deps + , mi_public + , mi_exports + , mi_fixities + , mi_warns + , mi_anns + , mi_decls + , mi_defaults + , mi_simplified_core + , mi_top_env + , mi_insts + , mi_fam_insts + , mi_rules + , mi_trust + , mi_trust_pkg + , mi_complete_matches + , mi_docs + , mi_abi_hashes + , mi_ext_fields + , mi_hi_bytes + , mi_self_recomp_info + , mi_fix_fn + , mi_decl_warn_fn + , mi_export_warn_fn + , mi_hash_fn + ), + pattern ModIface, SafeHaskellMode(..), -- * Printing @@ -122,6 +159,7 @@ getBindings, getInsts, getNamePprCtx, findModule, lookupModule, findQualifiedModule, lookupQualifiedModule, + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames, renamePkgQualM, renameRawPkgQualM, isModuleTrusted, moduleTrustReqs, getNamesInScope, @@ -157,14 +195,14 @@ -- ** The debugger SingleStep(..), Resume(..), - History(historyBreakInfo, historyEnclosingDecls), + History(historyBreakpointId, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, abandon, abandonAll, getResumeContext, GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType, modInfoModBreaks, - ModBreaks(..), BreakIndex, - BreakInfo(..), + ModBreaks(..), BreakTickIndex, + BreakpointId(..), InternalBreakpointId(..), GHC.Runtime.Eval.back, GHC.Runtime.Eval.forward, GHC.Runtime.Eval.setupBreakpoint, @@ -287,11 +325,7 @@ parser, -- * API Annotations - AnnKeywordId(..),EpaComment(..), - - -- * Miscellaneous - --sessionHscEnv, - cyclicModuleErr, + EpaComment(..) ) where {- @@ -312,6 +346,7 @@ import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session +import GHC.Driver.Session.Inspect import GHC.Driver.Backend import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Config.Parser (initParserOpts) @@ -337,13 +372,14 @@ import GHC.Parser.Annotation import GHC.Parser.Utils +import GHC.Iface.Env ( trace_if ) import GHC.Iface.Load ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails) +import GHC.Rename.Names (renamePkgQual, renameRawPkgQual) import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types @@ -359,9 +395,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -#if !defined(javascript_HOST_ARCH) -import GHC.Utils.Panic.Plain -#endif import GHC.Utils.Logger import GHC.Utils.Fingerprint @@ -393,15 +426,11 @@ import GHC.Types.Basic import GHC.Types.TyThing import GHC.Types.Name.Env -import GHC.Types.Name.Ppr import GHC.Types.TypeEnv -import GHC.Types.BreakInfo import GHC.Types.PkgQual -import GHC.Types.Unique.FM import GHC.Unit -import GHC.Unit.Env -import GHC.Unit.External +import GHC.Unit.Env as UnitEnv import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts @@ -409,12 +438,15 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Settings import Control.Applicative ((<|>)) import Control.Concurrent import Control.Monad import Control.Monad.Catch as MC import Data.Foldable +import Data.Function ((&)) import Data.IORef import Data.List (isPrefixOf) import Data.Typeable ( Typeable ) @@ -431,6 +463,7 @@ import System.FilePath import System.IO.Error ( isDoesNotExistError ) + -- %************************************************************************ -- %* * -- Initialisation: exception handlers @@ -459,6 +492,8 @@ liftIO $ throwIO UserInterrupt Just StackOverflow -> fm "stack overflow: use +RTS -K to increase it" + Just HeapOverflow -> + fm "heap overflow: use +RTS -M to increase maximum heap size" _ -> case fromException exception of Just (ex :: ExitCode) -> liftIO $ throwIO ex _ -> @@ -641,7 +676,7 @@ , homeUnitEnv_home_unit = Just home_unit } - let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) + let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env) let dflags = updated_dflags @@ -659,7 +694,7 @@ let !unit_env1 = if homeUnitId_ dflags /= uid then - ue_renameUnitId + UnitEnv.renameUnitId uid (homeUnitId_ dflags) unit_env0 @@ -677,10 +712,60 @@ setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger - lookup_cache <- liftIO $ newMVar emptyUFM + lookup_cache <- liftIO $ mkInterpSymbolCache - -- Interpreter + -- see Note [Target code interpreter] interp <- if + -- Wasm dynamic linker + | ArchWasm32 <- platformArch $ targetPlatform dflags + -> 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 $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" +#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, + wasmInterpBrowser = gopt Opt_GhciBrowser dflags, + wasmInterpBrowserHost = ghciBrowserHost dflags, + wasmInterpBrowserPort = ghciBrowserPort dflags, + wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags, + wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags, + wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags, + wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags, + wasmInterpTargetPlatform = targetPlatform dflags, + wasmInterpProfiled = profiled, + wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags), + wasmInterpUnitState = ue_homeUnitState $ 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 @@ -689,7 +774,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 @@ -709,24 +795,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 -> @@ -770,7 +838,7 @@ let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv dflags = homeUnitEnv_dflags homeUnitEnv old_hpt = homeUnitEnv_hpt homeUnitEnv - home_units = unitEnv_keys (ue_home_unit_graph old_unit_env) + home_units = HUG.allUnits (ue_home_unit_graph old_unit_env) (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units @@ -783,12 +851,13 @@ , homeUnitEnv_home_unit = Just home_unit } - let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph + let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph let unit_env = UnitEnv { ue_platform = targetPlatform dflags1 , ue_namever = ghcNameVersion dflags1 , ue_home_unit_graph = home_unit_graph , ue_current_unit = ue_currentUnit old_unit_env + , ue_module_graph = ue_module_graph old_unit_env , ue_eps = ue_eps old_unit_env } modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env } @@ -797,7 +866,115 @@ when invalidate_needed $ invalidateModSummaryCache return changed +-- | Sets the program 'HomeUnitGraph'. +-- +-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current +-- session. If the package flags change, we reinitialise the 'UnitState' +-- of all 'HomeUnitEnv's in the current session. +-- +-- This function unconditionally invalidates the module graph cache. +-- +-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph' +-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called +-- 'new_hug', then: +-- +-- @ +-- do +-- hug <- hsc_HUG \<$\> getSession +-- pure $ unitEnv_keys new_hug == unitEnv_keys hug +-- @ +-- +-- If this precondition is violated, the function will crash. +-- +-- Conceptually, similar to 'setProgramDynFlags', but performs the same check +-- for all 'HomeUnitEnv's. +setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool +setProgramHUG = + setProgramHUG_ True +-- | Same as 'setProgramHUG', but gives you control over whether you want to +-- invalidate the module graph cache. +setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool +setProgramHUG_ invalidate_needed new_hug0 = do + logger <- getLogger + + hug0 <- hsc_HUG <$> getSession + (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0 + + if changed + then do + unit_env0 <- hsc_unit_env <$> getSession + home_unit_graph <- HUG.unitEnv_traverseWithKey + (updateHomeUnit logger unit_env0 new_hug1) + (ue_home_unit_graph unit_env0) + + let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) home_unit_graph + let unit_env = UnitEnv + { ue_platform = targetPlatform dflags1 + , ue_namever = ghcNameVersion dflags1 + , ue_home_unit_graph = home_unit_graph + , ue_current_unit = ue_currentUnit unit_env0 + , ue_eps = ue_eps unit_env0 + , ue_module_graph = ue_module_graph unit_env0 + } + modifySession $ \h -> + -- hscSetFlags takes care of updating the logger as well. + hscSetFlags dflags1 h{ hsc_unit_env = unit_env } + else do + modifySession (\env -> + env + -- Set the new 'HomeUnitGraph'. + & hscUpdateHUG (const new_hug1) + -- hscSetActiveUnitId makes sure that the 'hsc_dflags' + -- are up-to-date. + & hscSetActiveUnitId (hscActiveUnitId env) + -- Make sure the logger is also updated. + & hscUpdateLoggerFlags) + + when invalidate_needed $ invalidateModSummaryCache + pure changed + where + checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph) + checkNewHugDynFlags logger old_hug new_hug = do + -- Traverse the new HUG and check its 'DynFlags'. + -- The old 'HUG' is used to check whether package flags have changed. + hugWithCheck <- HUG.unitEnv_traverseWithKey + (\unitId homeUnit -> do + let newFlags = homeUnitEnv_dflags homeUnit + oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug) + checkedFlags <- checkNewDynFlags logger newFlags + pure + ( packageFlagsChanged oldFlags checkedFlags + , homeUnit { homeUnitEnv_dflags = checkedFlags } + ) + ) + new_hug + let + -- Did any of the package flags change? + changed = or $ fmap fst hugWithCheck + hug = fmap snd hugWithCheck + pure (changed, hug) + + updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv) + updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + dflags = case HUG.unitEnv_lookup_maybe uid updates of + Nothing -> homeUnitEnv_dflags homeUnitEnv + Just env -> homeUnitEnv_dflags env + old_hpt = homeUnitEnv_hpt homeUnitEnv + home_units = HUG.allUnits (ue_home_unit_graph unit_env) + + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + pure HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = old_hpt + , homeUnitEnv_home_unit = Just home_unit + } + -- When changing the DynFlags, we want the changes to apply to future -- loads, but without completely discarding the program. But the -- DynFlags are cached in each ModSummary in the hsc_mod_graph, so @@ -819,7 +996,7 @@ -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache = - modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) } + modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env where inval ms = ms { ms_hs_hash = fingerprint0 } @@ -836,24 +1013,8 @@ setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do logger <- getLogger - dflags' <- checkNewDynFlags logger dflags - dflags'' <- checkNewInteractiveDynFlags logger dflags' - modifySessionM $ \hsc_env0 -> do - let ic0 = hsc_IC hsc_env0 - - -- Initialise (load) plugins in the interactive environment with the new - -- DynFlags - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ - hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} - - -- Update both plugins cache and DynFlags in the interactive context. - return $ hsc_env0 - { hsc_IC = ic0 - { ic_plugins = hsc_plugins plugin_env - , ic_dflags = hsc_dflags plugin_env - } - } - + icdflags <- normaliseInteractiveDynFlags logger dflags + modifySessionM (initialiseInteractiveDynFlags icdflags) -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags @@ -867,7 +1028,7 @@ -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) parseDynamicFlags logger dflags cmdline = do - (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline + (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine logger dflags cmdline -- flags that have just been read are used by the logger when loading package -- env (this is checked by T16318) let logger1 = setLogFlags logger (initLogFlags dflags1) @@ -958,17 +1119,49 @@ ----------------------------------------------------------------------------- +-- | Normalise the 'DynFlags' for us in an interactive context. +-- +-- Makes sure unsupported Flags and other incosistencies are reported and removed. +normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +normaliseInteractiveDynFlags logger dflags = do + dflags' <- checkNewDynFlags logger dflags + checkNewInteractiveDynFlags logger dflags' + +-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags') +-- for the interactive context, initialize the 'InteractiveContext'. +-- +-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the +-- 'InteractiveContext'. +initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv +initialiseInteractiveDynFlags dflags hsc_env0 = do + let ic0 = hsc_IC hsc_env0 + + -- Initialise (load) plugins in the interactive environment with the new + -- DynFlags + plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }} + + -- Update both plugins cache and DynFlags in the interactive context. + return $ hsc_env0 + { hsc_IC = ic0 + { ic_plugins = hsc_plugins plugin_env + , ic_dflags = hsc_dflags plugin_env + } + } + -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] - let (dflags', warnings) = makeDynFlagsConsistent dflags + let (dflags', warnings, infoverb) = makeDynFlagsConsistent dflags let diag_opts = initDiagOpts dflags print_config = initPrintConfig dflags liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings + when (logVerbAtLeast logger 3) $ + mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags @@ -1018,7 +1211,7 @@ where filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ] --- | Attempts to guess what Target a string refers to. This function +-- | Attempts to guess what 'Target' a string refers to. This function -- implements the @--make@/GHCi command-line syntax for filenames: -- -- - if the string looks like a Haskell source filename, then interpret it @@ -1027,27 +1220,52 @@ -- - if adding a .hs or .lhs suffix yields the name of an existing file, -- then use that -- --- - otherwise interpret the string as a module name +-- - If it looks like a module name, interpret it as such -- +-- - otherwise, this function throws a 'GhcException'. guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target guessTarget str mUnitId (Just phase) = do tuid <- unitIdOrHomeUnit mUnitId return (Target (TargetFile str (Just phase)) True tuid Nothing) -guessTarget str mUnitId Nothing +guessTarget str mUnitId Nothing = do + targetId <- guessTargetId str + toTarget targetId + where + obj_allowed + | '*':_ <- str = False + | otherwise = True + toTarget tid = do + tuid <- unitIdOrHomeUnit mUnitId + pure $ Target tid obj_allowed tuid Nothing + +-- | Attempts to guess what 'TargetId' a string refers to. This function +-- implements the @--make@/GHCi command-line syntax for filenames: +-- +-- - if the string looks like a Haskell source filename, then interpret it +-- as such +-- +-- - if adding a .hs or .lhs suffix yields the name of an existing file, +-- then use that +-- +-- - If it looks like a module name, interpret it as such +-- +-- - otherwise, this function throws a 'GhcException'. +guessTargetId :: GhcMonad m => String -> m TargetId +guessTargetId str | isHaskellSrcFilename file - = target (TargetFile file Nothing) + = pure (TargetFile file Nothing) | otherwise = do exists <- liftIO $ doesFileExist hs_file if exists - then target (TargetFile hs_file Nothing) + then pure (TargetFile hs_file Nothing) else do exists <- liftIO $ doesFileExist lhs_file if exists - then target (TargetFile lhs_file Nothing) + then pure (TargetFile lhs_file Nothing) else do if looksLikeModuleName file - then target (TargetModule (mkModuleName file)) + then pure (TargetModule (mkModuleName file)) else do dflags <- getDynFlags liftIO $ throwGhcExceptionIO @@ -1055,16 +1273,12 @@ text "target" <+> quotes (text file) <+> text "is not a module name or a source file")) where - (file,obj_allowed) - | '*':rest <- str = (rest, False) - | otherwise = (str, True) - - hs_file = file <.> "hs" - lhs_file = file <.> "lhs" + file + | '*':rest <- str = rest + | otherwise = str - target tid = do - tuid <- unitIdOrHomeUnit mUnitId - pure $ Target tid obj_allowed tuid Nothing + hs_file = file <.> "hs" + lhs_file = file <.> "lhs" -- | Unwrap 'UnitId' or retrieve the 'UnitId' -- of the current 'HomeUnit'. @@ -1162,7 +1376,7 @@ type ParsedSource = Located (HsModule GhcPs) type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe (LHsDoc GhcRn)) + Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)) type TypecheckedSource = LHsBinds GhcTc -- NOTE: @@ -1185,11 +1399,11 @@ -- -- This function ignores boot modules and requires that there is only one -- non-boot module with the given name. -getModSummary :: GhcMonad m => ModuleName -> m ModSummary +getModSummary :: GhcMonad m => Module -> m ModSummary getModSummary mod = do mg <- liftM hsc_mod_graph getSession let mods_by_name = [ ms | ms <- mgModSummaries mg - , ms_mod_name ms == mod + , ms_mod ms == mod , isBootSummary ms == NotBoot ] case mods_by_name of [] -> do dflags <- getDynFlags @@ -1220,7 +1434,9 @@ liftIO $ do let ms = modSummary pmod let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.) - let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env + let lcl_hsc_env = + hscSetFlags lcl_dflags $ + hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) hsc_env let lcl_logger = hsc_logger lcl_hsc_env (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $ HsParsedModule { hpm_module = parsedSource pmod, @@ -1228,9 +1444,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), @@ -1241,11 +1454,10 @@ 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, - minf_modBreaks = emptyModBreaks + minf_modBreaks = Nothing }} -- | Desugar a typechecked module. @@ -1356,169 +1568,6 @@ cm_safe = safe_mode } --- %************************************************************************ --- %* * --- Inspecting the session --- %* * --- %************************************************************************ - --- | Get the module dependency graph. -getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary -getModuleGraph = liftM hsc_mod_graph getSession - --- | Return @True@ \<==> module is loaded. -isLoaded :: GhcMonad m => ModuleName -> m Bool -isLoaded m = withSession $ \hsc_env -> - return $! isJust (lookupHpt (hsc_HPT hsc_env) m) - -isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool -isLoadedModule uid m = withSession $ \hsc_env -> - return $! isJust (lookupHug (hsc_HUG hsc_env) uid m) - --- | Return the bindings for the current interactive session. -getBindings :: GhcMonad m => m [TyThing] -getBindings = withSession $ \hsc_env -> - return $ icInScopeTTs $ hsc_IC hsc_env - --- | Return the instances for the current interactive session. -getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) -getInsts = withSession $ \hsc_env -> - let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) - in return (instEnvElts inst_env, fam_env) - -getNamePprCtx :: GhcMonad m => m NamePprCtx -getNamePprCtx = withSession $ \hsc_env -> do - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) - --- | Container for information about a 'Module'. -data ModuleInfo = ModuleInfo { - minf_type_env :: TypeEnv, - minf_exports :: [AvailInfo], - minf_rdr_env :: Maybe IfGlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface, - minf_safe :: SafeHaskellMode, - minf_modBreaks :: ModBreaks - } - -- We don't want HomeModInfo here, because a ModuleInfo applies - -- to package modules too. - - --- | Request information about a loaded 'Module' -getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X -getModuleInfo mdl = withSession $ \hsc_env -> do - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env - then liftIO $ getHomeModuleInfo hsc_env mdl - else liftIO $ getPackageModuleInfo hsc_env mdl - -getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl - = do eps <- hscEPS hsc_env - iface <- hscGetModuleInterface hsc_env mdl - let - avails = mi_exports iface - pte = eps_PTE eps - tys = [ ty | name <- concatMap availNames avails, - Just ty <- [lookupTypeEnv pte name] ] - - 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, - minf_modBreaks = emptyModBreaks - })) - -availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv -availsToGlobalRdrEnv hsc_env mod avails - = forceGlobalRdrEnv rdr_env - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. - where - rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) - -- We're building a GlobalRdrEnv as if the user imported - -- all the specified modules into the global interactive module - imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} - decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, - is_qual = False, - is_dloc = srcLocSpan interactiveSrcLoc } - -getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getHomeModuleInfo hsc_env mdl = - case lookupHugByModule mdl (hsc_HUG hsc_env) of - Nothing -> return Nothing - Just hmi -> do - let details = hm_details hmi - iface = hm_iface hmi - return (Just (ModuleInfo { - minf_type_env = md_types details, - minf_exports = md_exports details, - 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, - minf_safe = getSafeMode $ mi_trust iface - ,minf_modBreaks = getModBreaks hmi - })) - --- | The list of top-level entities defined in a module -modInfoTyThings :: ModuleInfo -> [TyThing] -modInfoTyThings minf = typeEnvElts (minf_type_env minf) - -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 - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf - --- | Returns the instances defined by the specified module. --- Warning: currently unimplemented for package modules. -modInfoInstances :: ModuleInfo -> [ClsInst] -modInfoInstances = minf_instances - -modInfoIsExportedName :: ModuleInfo -> Name -> Bool -modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) - -mkNamePprCtxForModule :: - GhcMonad m => - 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) - ptc = initPromotionTickContext (hsc_dflags hsc_env) - return (fmap mk_name_ppr_ctx (minf_rdr_env minf)) - -modInfoLookupName :: GhcMonad m => - ModuleInfo -> Name - -> m (Maybe TyThing) -- XXX: returns a Maybe X -modInfoLookupName minf name = withSession $ \hsc_env -> do - case lookupTypeEnv (minf_type_env minf) name of - Just tyThing -> return (Just tyThing) - Nothing -> liftIO (lookupType hsc_env name) - -modInfoIface :: ModuleInfo -> Maybe ModIface -modInfoIface = minf_iface - -modInfoRdrEnv :: ModuleInfo -> Maybe IfGlobalRdrEnv -modInfoRdrEnv = minf_rdr_env - --- | Retrieve module safe haskell mode -modInfoSafe :: ModuleInfo -> SafeHaskellMode -modInfoSafe = minf_safe - -modInfoModBreaks :: ModuleInfo -> ModBreaks -modInfoModBreaks = minf_modBreaks - isDictonaryId :: Id -> Bool isDictonaryId id = isDictTy (idType id) @@ -1706,6 +1755,7 @@ findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do + liftIO $ trace_if (hsc_logger hsc_env) (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual) let mhome_unit = hsc_home_unit_maybe hsc_env let dflags = hsc_dflags hsc_env case pkgqual of @@ -1731,7 +1781,7 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $ text "module is not loaded:" <+> quotes (ppr (moduleName m)) <+> - parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) + parens (text (expectJust (ml_hs_file loc))) renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p) @@ -1768,11 +1818,56 @@ lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module) -lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> - case lookupHug (hsc_HUG hsc_env) uid mod_name of +lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do + trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid) + HUG.lookupHug (hsc_HUG hsc_env) uid mod_name >>= \case Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing +-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'. +-- +-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'. +-- Otherwise, returns all 'Module's that have the given 'ModuleName'. +-- +-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since +-- there can be multiple units exposing the same 'ModuleName' in the case of +-- multiple home units. +-- Thus, this function may return more than one possible 'Module'. +-- We leave it up to the caller to decide how to handle the ambiguity. +-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one. +-- +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module]) +lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do + trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name) + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case + [] -> return Nothing + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos)) + +-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria. +-- +-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one +-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'. +-- +-- The result is guaranteed to be non-empty, if no 'Module' can be found, +-- this function throws an error. +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module] +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModuleByModuleName mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + res <- findExposedPackageModule fc fopts units mod_name NoPkgQual + case res of + Found _ m -> return [m] + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err +lookupAllQualifiedModuleNames pkgqual mod_name = do + m <- findQualifiedModule pkgqual mod_name + pure [m] + -- | Check that a module is safe to import (according to Safe Haskell). -- -- We return True to indicate the import is safe and False otherwise @@ -1803,14 +1898,17 @@ getGHCiMonad = fmap (ic_monad . hsc_IC) getSession getHistorySpan :: GhcMonad m => History -> m SrcSpan -getHistorySpan h = withSession $ \hsc_env -> - return $ GHC.Runtime.Eval.getHistorySpan hsc_env h +getHistorySpan h = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG hsc_env) h obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term obtainTermFromVal bound force ty a = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a -obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term +obtainTermFromId :: GhcMonad m + => Int -- ^ How many times to recurse for subterms + -> Bool -- ^ Whether to force the expression + -> Id + -> m Term obtainTermFromId bound force id = withSession $ \hsc_env -> liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id diff --git a/GHC/Builtin/Names.hs b/GHC/Builtin/Names.hs --- a/GHC/Builtin/Names.hs +++ b/GHC/Builtin/Names.hs @@ -54,2779 +54,2724 @@ 1. When parsing source code, the RdrName-decorated AST has some RdrNames which are Exact. These are wired-in RdrNames where we could directly tell from the parsed syntax what Name to - use. For example, when we parse a [] in a type we can just insert - an Exact RdrName Name with the listTyConKey. - - Currently, I believe this is just an optimisation: it would be - equally valid to just output Orig RdrNames that correctly record - the module etc we expect the final Name to come from. However, - were we to eliminate isBuiltInOcc_maybe it would become essential - (see point 3). - - 2. The knownKeyNames (which consist of the basicKnownKeyNames from - the module, and those names reachable via the wired-in stuff from - GHC.Builtin.Types) are used to initialise the "OrigNameCache" in - GHC.Iface.Env. This initialization ensures that when the type checker - or renamer (both of which use GHC.Iface.Env) look up an original name - (i.e. a pair of a Module and an OccName) for a known-key name - they get the correct Unique. - - This is the most important mechanism for ensuring that known-key - stuff gets the right Unique, and is why it is so important to - place your known-key names in the appropriate lists. - - 3. For "infinite families" of known-key names (i.e. tuples and sums), we - have to be extra careful. Because there are an infinite number of - these things, we cannot add them to the list of known-key names - used to initialise the OrigNameCache. Instead, we have to - rely on never having to look them up in that cache. See - Note [Infinite families of known-key names] for details. - - -Note [Infinite families of known-key names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Infinite families of known-key things (e.g. tuples and sums) pose a tricky -problem: we can't add them to the knownKeyNames finite map which we use to -ensure that, e.g., a reference to (,) gets assigned the right unique (if this -doesn't sound familiar see Note [Known-key names] above). - -We instead handle tuples and sums separately from the "vanilla" known-key -things, - - a) The parser recognises them specially and generates an Exact Name (hence not - looked up in the orig-name cache) - - b) The known infinite families of names are specially serialised by - GHC.Iface.Binary.putName, with that special treatment detected when we read - back to ensure that we get back to the correct uniques. See Note [Symbol - table representation of names] in GHC.Iface.Binary and Note [How tuples - work] in GHC.Builtin.Types. - -Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) -suffice to ensure that they always have the right Unique. In particular, -implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned -by the user. For those things that *can* appear in source programs, - - c) GHC.Iface.Env.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax - directly onto the corresponding name, rather than trying to find it in the - original-name cache. - - See also Note [Built-in syntax and the OrigNameCache] - -Note that one-tuples are an exception to the rule, as they do get assigned -known keys. See -Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) -in GHC.Builtin.Types. - --} - -{-# LANGUAGE CPP #-} - -module GHC.Builtin.Names - ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience - - ----------------------------------------------------------- - module GHC.Builtin.Names, -- A huge bunch of (a) Names, e.g. intTyConName - -- (b) Uniques e.g. intTyConKey - -- (c) Groups of classes and types - -- (d) miscellaneous things - -- So many that we export them all - ) -where - -import GHC.Prelude - -import GHC.Unit.Types -import GHC.Types.Name.Occurrence -import GHC.Types.Name.Reader -import GHC.Types.Unique -import GHC.Builtin.Uniques -import GHC.Types.Name -import GHC.Types.SrcLoc -import GHC.Data.FastString -import GHC.Data.List.Infinite (Infinite (..)) -import qualified GHC.Data.List.Infinite as Inf - -import Language.Haskell.Syntax.Module.Name - -{- -************************************************************************ -* * - allNameStrings -* * -************************************************************************ --} - -allNameStrings :: Infinite String --- Infinite list of a,b,c...z, aa, ab, ac, ... etc -allNameStrings = Inf.allListsOf ['a'..'z'] - -allNameStringList :: [String] --- Infinite list of a,b,c...z, aa, ab, ac, ... etc -allNameStringList = Inf.toList allNameStrings - -{- -************************************************************************ -* * -\subsection{Local Names} -* * -************************************************************************ - -This *local* name is used by the interactive stuff --} - -itName :: Unique -> SrcSpan -> Name -itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc - --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: OccName -> Name -mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan - -isUnboundName :: Name -> Bool -isUnboundName name = name `hasKey` unboundKey - -{- -************************************************************************ -* * -\subsection{Known key Names} -* * -************************************************************************ - -This section tells what the compiler knows about the association of -names with uniques. These ones are the *non* wired-in ones. The -wired in ones are defined in GHC.Builtin.Types etc. --} - -basicKnownKeyNames :: [Name] -- See Note [Known-key names] -basicKnownKeyNames - = genericTyConNames - ++ [ -- Classes. *Must* include: - -- classes that are grabbed by key (e.g., eqClassKey) - -- classes in "Class.standardClassKeys" (quite a few) - eqClassName, -- mentioned, derivable - ordClassName, -- derivable - boundedClassName, -- derivable - numClassName, -- mentioned, numeric - enumClassName, -- derivable - monadClassName, - functorClassName, - realClassName, -- numeric - integralClassName, -- numeric - fractionalClassName, -- numeric - floatingClassName, -- numeric - realFracClassName, -- numeric - realFloatClassName, -- numeric - dataClassName, - isStringClassName, - applicativeClassName, - alternativeClassName, - foldableClassName, - traversableClassName, - semigroupClassName, sappendName, - monoidClassName, memptyName, mappendName, mconcatName, - - -- The IO type - ioTyConName, ioDataConName, - runMainIOName, - runRWName, - - -- Type representation types - trModuleTyConName, trModuleDataConName, - trNameTyConName, trNameSDataConName, trNameDDataConName, - trTyConTyConName, trTyConDataConName, - - -- Typeable - typeableClassName, - typeRepTyConName, - someTypeRepTyConName, - someTypeRepDataConName, - kindRepTyConName, - kindRepTyConAppDataConName, - kindRepVarDataConName, - kindRepAppDataConName, - kindRepFunDataConName, - kindRepTYPEDataConName, - kindRepTypeLitSDataConName, - kindRepTypeLitDDataConName, - typeLitSortTyConName, - typeLitSymbolDataConName, - typeLitNatDataConName, - typeLitCharDataConName, - typeRepIdName, - mkTrTypeName, - mkTrConName, - mkTrAppName, - mkTrFunName, - typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName, - trGhcPrimModuleName, - - -- KindReps for common cases - starKindRepName, - starArrStarKindRepName, - starArrStarArrStarKindRepName, - constraintKindRepName, - - -- WithDict - withDictClassName, - - -- Dynamic - toDynName, - - -- Numeric stuff - negateName, minusName, geName, eqName, - mkRationalBase2Name, mkRationalBase10Name, - - -- Conversion functions - rationalTyConName, - ratioTyConName, ratioDataConName, - fromRationalName, fromIntegerName, - toIntegerName, toRationalName, - fromIntegralName, realToFracName, - - -- Int# stuff - divIntName, modIntName, - - -- String stuff - fromStringName, - - -- Enum stuff - enumFromName, enumFromThenName, - enumFromThenToName, enumFromToName, - - -- Applicative stuff - pureAName, apAName, thenAName, - - -- Functor stuff - fmapName, - - -- Monad stuff - thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, - returnMName, joinMName, - - -- MonadFail - monadFailClassName, failMName, - - -- MonadFix - monadFixClassName, mfixName, - - -- Arrow stuff - arrAName, composeAName, firstAName, - appAName, choiceAName, loopAName, - - -- Ix stuff - ixClassName, - - -- Show stuff - showClassName, - - -- Read stuff - readClassName, - - -- Stable pointers - newStablePtrName, - - -- GHC Extensions - considerAccessibleName, - - -- Strings and lists - unpackCStringName, unpackCStringUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - unpackCStringFoldrName, unpackCStringFoldrUtf8Name, - cstringLengthName, - - -- Overloaded lists - isListClassName, - fromListName, - fromListNName, - toListName, - - -- Non-empty lists - nonEmptyTyConName, - - -- Overloaded record dot, record update - getFieldName, setFieldName, - - -- List operations - concatName, filterName, mapName, - zipName, foldrName, buildName, augmentName, appendName, - - -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, - int8TyConName, int16TyConName, int32TyConName, int64TyConName, - word8TyConName, word16TyConName, word32TyConName, word64TyConName, - - -- Others - otherwiseIdName, inlineIdName, - eqStringName, assertName, - assertErrorName, traceName, - printName, - dollarName, - - -- ghc-bignum - integerFromNaturalName, - integerToNaturalClampName, - integerToNaturalThrowName, - integerToNaturalName, - integerToWordName, - integerToIntName, - integerToWord64Name, - integerToInt64Name, - integerFromWordName, - integerFromWord64Name, - integerFromInt64Name, - integerAddName, - integerMulName, - integerSubName, - integerNegateName, - integerAbsName, - integerPopCountName, - integerQuotName, - integerRemName, - integerDivName, - integerModName, - integerDivModName, - integerQuotRemName, - integerEncodeFloatName, - integerEncodeDoubleName, - integerGcdName, - integerLcmName, - integerAndName, - integerOrName, - integerXorName, - integerComplementName, - integerBitName, - integerTestBitName, - integerShiftLName, - integerShiftRName, - - naturalToWordName, - naturalPopCountName, - naturalShiftRName, - naturalShiftLName, - naturalAddName, - naturalSubName, - naturalSubThrowName, - naturalSubUnsafeName, - naturalMulName, - naturalQuotRemName, - naturalQuotName, - naturalRemName, - naturalAndName, - naturalAndNotName, - naturalOrName, - naturalXorName, - naturalTestBitName, - naturalBitName, - naturalGcdName, - naturalLcmName, - naturalLog2Name, - naturalLogBaseWordName, - naturalLogBaseName, - naturalPowModName, - naturalSizeInBaseName, - - bignatFromWordListName, - bignatEqName, - - -- Float/Double - integerToFloatName, - integerToDoubleName, - naturalToFloatName, - naturalToDoubleName, - rationalToFloatName, - rationalToDoubleName, - - -- Other classes - monadPlusClassName, - - -- Type-level naturals - knownNatClassName, knownSymbolClassName, knownCharClassName, - - -- Overloaded labels - fromLabelClassOpName, - - -- Implicit Parameters - ipClassName, - - -- Overloaded record fields - hasFieldClassName, - - -- Call Stacks - callStackTyConName, - emptyCallStackName, pushCallStackName, - - -- Source Locations - srcLocDataConName, - - -- Annotation type checking - toAnnotationWrapperName - - -- The SPEC type for SpecConstr - , specTyConName - - -- The Either type - , eitherTyConName, leftDataConName, rightDataConName - - -- The Void type - , voidTyConName - - -- Plugins - , pluginTyConName - , frontendPluginTyConName - - -- Generics - , genClassName, gen1ClassName - , datatypeClassName, constructorClassName, selectorClassName - - -- Monad comprehensions - , guardMName - , liftMName - , mzipName - - -- GHCi Sandbox - , ghciIoClassName, ghciStepIoMName - - -- StaticPtr - , makeStaticName - , staticPtrTyConName - , staticPtrDataConName, staticPtrInfoDataConName - , fromStaticPtrName - - -- Fingerprint - , fingerprintDataConName - - -- Custom type errors - , errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - - -- "Unsatisfiable" constraint - , unsatisfiableClassName - , unsatisfiableIdName - - -- Unsafe coercion proofs - , unsafeEqualityProofName - , unsafeEqualityTyConName - , unsafeReflDataConName - , unsafeCoercePrimName - ] - -genericTyConNames :: [Name] -genericTyConNames = [ - v1TyConName, u1TyConName, par1TyConName, rec1TyConName, - k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, - d1TyConName, c1TyConName, s1TyConName, - repTyConName, rep1TyConName, uRecTyConName, - uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName, - prefixIDataConName, infixIDataConName, leftAssociativeDataConName, - rightAssociativeDataConName, notAssociativeDataConName, - sourceUnpackDataConName, sourceNoUnpackDataConName, - noSourceUnpackednessDataConName, sourceLazyDataConName, - sourceStrictDataConName, noSourceStrictnessDataConName, - decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, - metaDataDataConName, metaConsDataConName, metaSelDataConName - ] - -{- -************************************************************************ -* * -\subsection{Module names} -* * -************************************************************************ - - ---MetaHaskell Extension Add a new module here --} - -pRELUDE :: Module -pRELUDE = mkBaseModule_ pRELUDE_NAME - -gHC_PRIM, gHC_PRIM_PANIC, - gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT, - gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM, - gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, - gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT, - gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_LIST, dATA_STRING, - dATA_FOLDABLE, dATA_TRAVERSABLE, - gHC_CONC, gHC_IO, gHC_IO_Exception, - gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, - gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, - tYPEABLE, tYPEABLE_INTERNAL, gENERICS, - rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, - aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST, - cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL, - gHC_TYPENATS, gHC_TYPENATS_INTERNAL, - dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module - -gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values -gHC_PRIM_PANIC = mkPrimModule (fsLit "GHC.Prim.Panic") -gHC_TYPES = mkPrimModule (fsLit "GHC.Types") -gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") -gHC_MAGIC_DICT = mkPrimModule (fsLit "GHC.Magic.Dict") -gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") -gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") -gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers") - -gHC_BASE = mkBaseModule (fsLit "GHC.Base") -gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") -gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") -gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers") -gHC_SHOW = mkBaseModule (fsLit "GHC.Show") -gHC_READ = mkBaseModule (fsLit "GHC.Read") -gHC_NUM = mkBaseModule (fsLit "GHC.Num") -gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe") -gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer") -gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural") -gHC_NUM_BIGNAT = mkBignumModule (fsLit "GHC.Num.BigNat") -gHC_LIST = mkBaseModule (fsLit "GHC.List") -gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") -gHC_TUPLE_PRIM = mkPrimModule (fsLit "GHC.Tuple.Prim") -dATA_EITHER = mkBaseModule (fsLit "Data.Either") -dATA_LIST = mkBaseModule (fsLit "Data.List") -dATA_STRING = mkBaseModule (fsLit "Data.String") -dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") -dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") -gHC_CONC = mkBaseModule (fsLit "GHC.Conc") -gHC_IO = mkBaseModule (fsLit "GHC.IO") -gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") -gHC_ST = mkBaseModule (fsLit "GHC.ST") -gHC_IX = mkBaseModule (fsLit "GHC.Ix") -gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") -gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") -gHC_ERR = mkBaseModule (fsLit "GHC.Err") -gHC_REAL = mkBaseModule (fsLit "GHC.Real") -gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") -gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") -sYSTEM_IO = mkBaseModule (fsLit "System.IO") -dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") -tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") -gENERICS = mkBaseModule (fsLit "Data.Data") -rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") -lEX = mkBaseModule (fsLit "Text.Read.Lex") -gHC_INT = mkBaseModule (fsLit "GHC.Int") -gHC_WORD = mkBaseModule (fsLit "GHC.Word") -mONAD = mkBaseModule (fsLit "Control.Monad") -mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") -mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") -mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail") -aRROW = mkBaseModule (fsLit "Control.Arrow") -gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") -rANDOM = mkBaseModule (fsLit "System.Random") -gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") -gHC_IS_LIST = mkBaseModule (fsLit "GHC.IsList") -cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") -gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") -gHC_TYPEERROR = mkBaseModule (fsLit "GHC.TypeError") -gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") -gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal") -gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats") -gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal") -dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") -dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") -uNSAFE_COERCE = mkBaseModule (fsLit "Unsafe.Coerce") -fOREIGN_C_CONSTPTR = mkBaseModule (fsLit "Foreign.C.ConstPtr") - -gHC_SRCLOC :: Module -gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") - -gHC_STACK, gHC_STACK_TYPES :: Module -gHC_STACK = mkBaseModule (fsLit "GHC.Stack") -gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types") - -gHC_STATICPTR :: Module -gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") - -gHC_STATICPTR_INTERNAL :: Module -gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal") - -gHC_FINGERPRINT_TYPE :: Module -gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") - -gHC_OVER_LABELS :: Module -gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") - -gHC_RECORDS :: Module -gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") - -rOOT_MAIN :: Module -rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation - -mkInteractiveModule :: String -> Module --- (mkInteractiveMoudule "9") makes module 'interactive:Ghci9' -mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n)) - -pRELUDE_NAME, mAIN_NAME :: ModuleName -pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") -mAIN_NAME = mkModuleNameFS (fsLit "Main") - -mkPrimModule :: FastString -> Module -mkPrimModule m = mkModule primUnit (mkModuleNameFS m) - -mkBignumModule :: FastString -> Module -mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m) - -mkBaseModule :: FastString -> Module -mkBaseModule m = mkBaseModule_ (mkModuleNameFS m) - -mkBaseModule_ :: ModuleName -> Module -mkBaseModule_ m = mkModule baseUnit m - -mkThisGhcModule :: FastString -> Module -mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m) - -mkThisGhcModule_ :: ModuleName -> Module -mkThisGhcModule_ m = mkModule thisGhcUnit m - -mkMainModule :: FastString -> Module -mkMainModule m = mkModule mainUnit (mkModuleNameFS m) - -mkMainModule_ :: ModuleName -> Module -mkMainModule_ m = mkModule mainUnit m - -{- -************************************************************************ -* * - RdrNames -* * -************************************************************************ --} - -main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName (fsLit "main") - -- We definitely don't want an Orig RdrName, because - -- main might, in principle, be imported into module Main - -eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, - ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName -eq_RDR = nameRdrName eqName -ge_RDR = nameRdrName geName -le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") -lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") -gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") -compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") -ltTag_RDR = nameRdrName ordLTDataConName -eqTag_RDR = nameRdrName ordEQDataConName -gtTag_RDR = nameRdrName ordGTDataConName - -eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR - :: RdrName -eqClass_RDR = nameRdrName eqClassName -numClass_RDR = nameRdrName numClassName -ordClass_RDR = nameRdrName ordClassName -enumClass_RDR = nameRdrName enumClassName -monadClass_RDR = nameRdrName monadClassName - -map_RDR, append_RDR :: RdrName -map_RDR = nameRdrName mapName -append_RDR = nameRdrName appendName - -foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR - :: RdrName -foldr_RDR = nameRdrName foldrName -build_RDR = nameRdrName buildName -returnM_RDR = nameRdrName returnMName -bindM_RDR = nameRdrName bindMName -failM_RDR = nameRdrName failMName - -left_RDR, right_RDR :: RdrName -left_RDR = nameRdrName leftDataConName -right_RDR = nameRdrName rightDataConName - -fromEnum_RDR, toEnum_RDR :: RdrName -fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") -toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") - -enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName -enumFrom_RDR = nameRdrName enumFromName -enumFromTo_RDR = nameRdrName enumFromToName -enumFromThen_RDR = nameRdrName enumFromThenName -enumFromThenTo_RDR = nameRdrName enumFromThenToName - -ratioDataCon_RDR, integerAdd_RDR, integerMul_RDR :: RdrName -ratioDataCon_RDR = nameRdrName ratioDataConName -integerAdd_RDR = nameRdrName integerAddName -integerMul_RDR = nameRdrName integerMulName - -ioDataCon_RDR :: RdrName -ioDataCon_RDR = nameRdrName ioDataConName - -newStablePtr_RDR :: RdrName -newStablePtr_RDR = nameRdrName newStablePtrName - -bindIO_RDR, returnIO_RDR :: RdrName -bindIO_RDR = nameRdrName bindIOName -returnIO_RDR = nameRdrName returnIOName - -fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName -fromInteger_RDR = nameRdrName fromIntegerName -fromRational_RDR = nameRdrName fromRationalName -minus_RDR = nameRdrName minusName -times_RDR = varQual_RDR gHC_NUM (fsLit "*") -plus_RDR = varQual_RDR gHC_NUM (fsLit "+") - -toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName -toInteger_RDR = nameRdrName toIntegerName -toRational_RDR = nameRdrName toRationalName -fromIntegral_RDR = nameRdrName fromIntegralName - -fromString_RDR :: RdrName -fromString_RDR = nameRdrName fromStringName - -fromList_RDR, fromListN_RDR, toList_RDR :: RdrName -fromList_RDR = nameRdrName fromListName -fromListN_RDR = nameRdrName fromListNName -toList_RDR = nameRdrName toListName - -compose_RDR :: RdrName -compose_RDR = varQual_RDR gHC_BASE (fsLit ".") - -not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, - and_RDR, range_RDR, inRange_RDR, index_RDR, - unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName -and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") -not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") -dataToTag_RDR = varQual_RDR gHC_PRIM (fsLit "dataToTag#") -succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") -pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") -minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") -maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") -range_RDR = varQual_RDR gHC_IX (fsLit "range") -inRange_RDR = varQual_RDR gHC_IX (fsLit "inRange") -index_RDR = varQual_RDR gHC_IX (fsLit "index") -unsafeIndex_RDR = varQual_RDR gHC_IX (fsLit "unsafeIndex") -unsafeRangeSize_RDR = varQual_RDR gHC_IX (fsLit "unsafeRangeSize") - -readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, - readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName -readList_RDR = varQual_RDR gHC_READ (fsLit "readList") -readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") -readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") -readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") -readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") -parens_RDR = varQual_RDR gHC_READ (fsLit "parens") -choose_RDR = varQual_RDR gHC_READ (fsLit "choose") -lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") -expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") - -readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName -readField_RDR = varQual_RDR gHC_READ (fsLit "readField") -readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash") -readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField") - -punc_RDR, ident_RDR, symbol_RDR :: RdrName -punc_RDR = dataQual_RDR lEX (fsLit "Punc") -ident_RDR = dataQual_RDR lEX (fsLit "Ident") -symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") - -step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName -step_RDR = varQual_RDR rEAD_PREC (fsLit "step") -alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") -reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") -prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") -pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") - -showsPrec_RDR, shows_RDR, showString_RDR, - showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName -showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") -shows_RDR = varQual_RDR gHC_SHOW (fsLit "shows") -showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") -showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") -showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") -showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") - -error_RDR :: RdrName -error_RDR = varQual_RDR gHC_ERR (fsLit "error") - --- Generics (constructors and functions) -u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, - k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, - prodDataCon_RDR, comp1DataCon_RDR, - unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, - from_RDR, from1_RDR, to_RDR, to1_RDR, - datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, - conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, - prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, - rightAssocDataCon_RDR, notAssocDataCon_RDR, - uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, - uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, - uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, - uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName - -u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") -par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") -rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") -k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") -m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") - -l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") -r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") - -prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") -comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") - -unPar1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Par1") (fsLit "unPar1") -unRec1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Rec1") (fsLit "unRec1") -unK1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "K1") (fsLit "unK1") -unComp1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Comp1") (fsLit "unComp1") - -from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") -from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") -to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") -to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") - -datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") -moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") -packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName") -isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") -selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") -conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") -conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") -conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") - -prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") -infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") -leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName -rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName -notAssocDataCon_RDR = nameRdrName notAssociativeDataConName - -uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr") -uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar") -uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble") -uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") -uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") -uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") - -uAddrHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UAddr") (fsLit "uAddr#") -uCharHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UChar") (fsLit "uChar#") -uDoubleHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UDouble") (fsLit "uDouble#") -uFloatHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UFloat") (fsLit "uFloat#") -uIntHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UInt") (fsLit "uInt#") -uWordHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UWord") (fsLit "uWord#") - -fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, - foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, - mappend_RDR :: RdrName -fmap_RDR = nameRdrName fmapName -replace_RDR = varQual_RDR gHC_BASE (fsLit "<$") -pure_RDR = nameRdrName pureAName -ap_RDR = nameRdrName apAName -liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2") -foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") -foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") -null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null") -all_RDR = varQual_RDR dATA_FOLDABLE (fsLit "all") -traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") -mempty_RDR = nameRdrName memptyName -mappend_RDR = nameRdrName mappendName - ----------------------- -varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR - :: Module -> FastString -> RdrName -varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) -tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) -clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) -dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) - -fieldQual_RDR :: Module -> FastString -> FastString -> RdrName -fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str) - -{- -************************************************************************ -* * -\subsection{Known-key names} -* * -************************************************************************ - -Many of these Names are not really "built in", but some parts of the -compiler (notably the deriving mechanism) need to mention their names, -and it's convenient to write them all down in one place. --} - -wildCardName :: Name -wildCardName = mkSystemVarName wildCardKey (fsLit "wild") - -runMainIOName, runRWName :: Name -runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey -runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey - -orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name -orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey -ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey -ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey -ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey - -specTyConName :: Name -specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey - -eitherTyConName, leftDataConName, rightDataConName :: Name -eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey -leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey -rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey - -voidTyConName :: Name -voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey - --- Generics (types) -v1TyConName, u1TyConName, par1TyConName, rec1TyConName, - k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, dTyConName, - cTyConName, sTyConName, rec0TyConName, - d1TyConName, c1TyConName, s1TyConName, - repTyConName, rep1TyConName, uRecTyConName, - uAddrTyConName, uCharTyConName, uDoubleTyConName, - uFloatTyConName, uIntTyConName, uWordTyConName, - prefixIDataConName, infixIDataConName, leftAssociativeDataConName, - rightAssociativeDataConName, notAssociativeDataConName, - sourceUnpackDataConName, sourceNoUnpackDataConName, - noSourceUnpackednessDataConName, sourceLazyDataConName, - sourceStrictDataConName, noSourceStrictnessDataConName, - decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, - metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name - -v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey -u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey -par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey -rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey -k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey -m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey - -sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey -prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey -compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey - -rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey -dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey -cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey -sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey - -rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey -d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey -c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey -s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey - -repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey -rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey - -uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey -uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey -uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey -uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey -uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey -uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey -uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey - -prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey -infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey -leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey -rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey -notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey - -sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey -sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey -noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey -sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey -sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey -noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey -decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey -decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey -decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey - -metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey -metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey -metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey - --- Primitive Int -divIntName, modIntName :: Name -divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey -modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey - --- Base strings Strings -unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, - unpackCStringAppendName, unpackCStringAppendUtf8Name, - eqStringName, cstringLengthName :: Name -cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey -eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey - -unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey - -unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey -unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey - - --- The 'inline' function -inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey - --- Base classes (Eq, Ord, Functor) -fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name -eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey -eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey -ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey -geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey -functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey -fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey - --- Class Monad -monadClassName, thenMName, bindMName, returnMName :: Name -monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey -thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey -bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey -returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey - --- Class MonadFail -monadFailClassName, failMName :: Name -monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey -failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey - --- Class Applicative -applicativeClassName, pureAName, apAName, thenAName :: Name -applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey -apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey -pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey -thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey - --- Classes (Foldable, Traversable) -foldableClassName, traversableClassName :: Name -foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey -traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey - --- Classes (Semigroup, Monoid) -semigroupClassName, sappendName :: Name -semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey -sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey -monoidClassName, memptyName, mappendName, mconcatName :: Name -monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey -memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey -mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey -mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey - - - --- AMP additions - -joinMName, alternativeClassName :: Name -joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey -alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey - --- -joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, - alternativeClassKey :: Unique -joinMIdKey = mkPreludeMiscIdUnique 750 -apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> -pureAClassOpKey = mkPreludeMiscIdUnique 752 -thenAClassOpKey = mkPreludeMiscIdUnique 753 -alternativeClassKey = mkPreludeMiscIdUnique 754 - - --- Functions for GHC extensions -considerAccessibleName :: Name -considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey - --- Random GHC.Base functions -fromStringName, otherwiseIdName, foldrName, buildName, augmentName, - mapName, appendName, assertName, - dollarName :: Name -dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey -otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey -foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey -buildName = varQual gHC_BASE (fsLit "build") buildIdKey -augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey -mapName = varQual gHC_BASE (fsLit "map") mapIdKey -appendName = varQual gHC_BASE (fsLit "++") appendIdKey -assertName = varQual gHC_BASE (fsLit "assert") assertIdKey -fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey - --- Module GHC.Num -numClassName, fromIntegerName, minusName, negateName :: Name -numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey -fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey -minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey -negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey - ---------------------------------- --- ghc-bignum ---------------------------------- -integerFromNaturalName - , integerToNaturalClampName - , integerToNaturalThrowName - , integerToNaturalName - , integerToWordName - , integerToIntName - , integerToWord64Name - , integerToInt64Name - , integerFromWordName - , integerFromWord64Name - , integerFromInt64Name - , integerAddName - , integerMulName - , integerSubName - , integerNegateName - , integerAbsName - , integerPopCountName - , integerQuotName - , integerRemName - , integerDivName - , integerModName - , integerDivModName - , integerQuotRemName - , integerEncodeFloatName - , integerEncodeDoubleName - , integerGcdName - , integerLcmName - , integerAndName - , integerOrName - , integerXorName - , integerComplementName - , integerBitName - , integerTestBitName - , integerShiftLName - , integerShiftRName - , naturalToWordName - , naturalPopCountName - , naturalShiftRName - , naturalShiftLName - , naturalAddName - , naturalSubName - , naturalSubThrowName - , naturalSubUnsafeName - , naturalMulName - , naturalQuotRemName - , naturalQuotName - , naturalRemName - , naturalAndName - , naturalAndNotName - , naturalOrName - , naturalXorName - , naturalTestBitName - , naturalBitName - , naturalGcdName - , naturalLcmName - , naturalLog2Name - , naturalLogBaseWordName - , naturalLogBaseName - , naturalPowModName - , naturalSizeInBaseName - , bignatFromWordListName - , bignatEqName - , bignatCompareName - , bignatCompareWordName - :: Name - -bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name -bnbVarQual str key = varQual gHC_NUM_BIGNAT (fsLit str) key -bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key -bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key - --- Types and DataCons -bignatFromWordListName = bnbVarQual "bigNatFromWordList#" bignatFromWordListIdKey -bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey -bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey -bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey - -naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey -naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey -naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey -naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey -naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey -naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey -naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey -naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey -naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey -naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey -naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey -naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey -naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey -naturalAndNotName = bnnVarQual "naturalAndNot" naturalAndNotIdKey -naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey -naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey -naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey -naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey -naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey -naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey -naturalLog2Name = bnnVarQual "naturalLog2#" naturalLog2IdKey -naturalLogBaseWordName = bnnVarQual "naturalLogBaseWord#" naturalLogBaseWordIdKey -naturalLogBaseName = bnnVarQual "naturalLogBase#" naturalLogBaseIdKey -naturalPowModName = bnnVarQual "naturalPowMod" naturalPowModIdKey -naturalSizeInBaseName = bnnVarQual "naturalSizeInBase#" naturalSizeInBaseIdKey - -integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey -integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey -integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey -integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey -integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey -integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey -integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey -integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey -integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey -integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey -integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey -integerAddName = bniVarQual "integerAdd" integerAddIdKey -integerMulName = bniVarQual "integerMul" integerMulIdKey -integerSubName = bniVarQual "integerSub" integerSubIdKey -integerNegateName = bniVarQual "integerNegate" integerNegateIdKey -integerAbsName = bniVarQual "integerAbs" integerAbsIdKey -integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey -integerQuotName = bniVarQual "integerQuot" integerQuotIdKey -integerRemName = bniVarQual "integerRem" integerRemIdKey -integerDivName = bniVarQual "integerDiv" integerDivIdKey -integerModName = bniVarQual "integerMod" integerModIdKey -integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey -integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey -integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey -integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey -integerGcdName = bniVarQual "integerGcd" integerGcdIdKey -integerLcmName = bniVarQual "integerLcm" integerLcmIdKey -integerAndName = bniVarQual "integerAnd" integerAndIdKey -integerOrName = bniVarQual "integerOr" integerOrIdKey -integerXorName = bniVarQual "integerXor" integerXorIdKey -integerComplementName = bniVarQual "integerComplement" integerComplementIdKey -integerBitName = bniVarQual "integerBit#" integerBitIdKey -integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey -integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey -integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey - - - ---------------------------------- --- End of ghc-bignum ---------------------------------- - --- GHC.Real types and classes -rationalTyConName, ratioTyConName, ratioDataConName, realClassName, - integralClassName, realFracClassName, fractionalClassName, - fromRationalName, toIntegerName, toRationalName, fromIntegralName, - realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name -rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey -ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey -realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey -integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey -realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey -fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey -toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey -toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey -fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey -realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey -mkRationalBase2Name = varQual gHC_REAL (fsLit "mkRationalBase2") mkRationalBase2IdKey -mkRationalBase10Name = varQual gHC_REAL (fsLit "mkRationalBase10") mkRationalBase10IdKey --- GHC.Float classes -floatingClassName, realFloatClassName :: Name -floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey -realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey - --- other GHC.Float functions -integerToFloatName, integerToDoubleName, - naturalToFloatName, naturalToDoubleName, - rationalToFloatName, rationalToDoubleName :: Name -integerToFloatName = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey -integerToDoubleName = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey -naturalToFloatName = varQual gHC_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey -naturalToDoubleName = varQual gHC_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey -rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey -rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey - --- Class Ix -ixClassName :: Name -ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey - --- Typeable representation types -trModuleTyConName - , trModuleDataConName - , trNameTyConName - , trNameSDataConName - , trNameDDataConName - , trTyConTyConName - , trTyConDataConName - :: Name -trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey -trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey -trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey -trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey -trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey -trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey -trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey - -kindRepTyConName - , kindRepTyConAppDataConName - , kindRepVarDataConName - , kindRepAppDataConName - , kindRepFunDataConName - , kindRepTYPEDataConName - , kindRepTypeLitSDataConName - , kindRepTypeLitDDataConName - :: Name -kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey -kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey -kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey -kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey -kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey -kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey -kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey -kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey - -typeLitSortTyConName - , typeLitSymbolDataConName - , typeLitNatDataConName - , typeLitCharDataConName - :: Name -typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey -typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey -typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey -typeLitCharDataConName = dcQual gHC_TYPES (fsLit "TypeLitChar") typeLitCharDataConKey - --- Class Typeable, and functions for constructing `Typeable` dictionaries -typeableClassName - , typeRepTyConName - , someTypeRepTyConName - , someTypeRepDataConName - , mkTrTypeName - , mkTrConName - , mkTrAppName - , mkTrFunName - , typeRepIdName - , typeNatTypeRepName - , typeSymbolTypeRepName - , typeCharTypeRepName - , trGhcPrimModuleName - :: Name -typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey -typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey -someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey -someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey -typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey -mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey -mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey -mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey -mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey -typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey -typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey -typeCharTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey --- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) --- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. -trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey - --- Typeable KindReps for some common cases -starKindRepName, starArrStarKindRepName, - starArrStarArrStarKindRepName, constraintKindRepName :: Name -starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey -starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey -starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey -constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") constraintKindRepKey - --- WithDict -withDictClassName :: Name -withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey - -nonEmptyTyConName :: Name -nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey - --- Custom type errors -errorMessageTypeErrorFamName - , typeErrorTextDataConName - , typeErrorAppendDataConName - , typeErrorVAppendDataConName - , typeErrorShowTypeDataConName - :: Name - -errorMessageTypeErrorFamName = - tcQual gHC_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey - -typeErrorTextDataConName = - dcQual gHC_TYPEERROR (fsLit "Text") typeErrorTextDataConKey - -typeErrorAppendDataConName = - dcQual gHC_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey - -typeErrorVAppendDataConName = - dcQual gHC_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey - -typeErrorShowTypeDataConName = - dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey - --- "Unsatisfiable" constraint -unsatisfiableClassName, unsatisfiableIdName :: Name -unsatisfiableClassName = - clsQual gHC_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey -unsatisfiableIdName = - varQual gHC_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey - --- Unsafe coercion proofs -unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, - unsafeReflDataConName :: Name -unsafeEqualityProofName = varQual uNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey -unsafeEqualityTyConName = tcQual uNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey -unsafeReflDataConName = dcQual uNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey -unsafeCoercePrimName = varQual uNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey - --- Dynamic -toDynName :: Name -toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey - --- Class Data -dataClassName :: Name -dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey - --- Error module -assertErrorName :: Name -assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey - --- Debug.Trace -traceName :: Name -traceName = varQual dEBUG_TRACE (fsLit "trace") traceKey - --- Enum module (Enum, Bounded) -enumClassName, enumFromName, enumFromToName, enumFromThenName, - enumFromThenToName, boundedClassName :: Name -enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey -enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey -enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey -enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey -enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey -boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey - --- List functions -concatName, filterName, zipName :: Name -concatName = varQual gHC_LIST (fsLit "concat") concatIdKey -filterName = varQual gHC_LIST (fsLit "filter") filterIdKey -zipName = varQual gHC_LIST (fsLit "zip") zipIdKey - --- Overloaded lists -isListClassName, fromListName, fromListNName, toListName :: Name -isListClassName = clsQual gHC_IS_LIST (fsLit "IsList") isListClassKey -fromListName = varQual gHC_IS_LIST (fsLit "fromList") fromListClassOpKey -fromListNName = varQual gHC_IS_LIST (fsLit "fromListN") fromListNClassOpKey -toListName = varQual gHC_IS_LIST (fsLit "toList") toListClassOpKey - --- HasField class ops -getFieldName, setFieldName :: Name -getFieldName = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey -setFieldName = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey - --- Class Show -showClassName :: Name -showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey - --- Class Read -readClassName :: Name -readClassName = clsQual gHC_READ (fsLit "Read") readClassKey - --- Classes Generic and Generic1, Datatype, Constructor and Selector -genClassName, gen1ClassName, datatypeClassName, constructorClassName, - selectorClassName :: Name -genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey -gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey - -datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey -constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey -selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey - -genericClassNames :: [Name] -genericClassNames = [genClassName, gen1ClassName] - --- GHCi things -ghciIoClassName, ghciStepIoMName :: Name -ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey -ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey - --- IO things -ioTyConName, ioDataConName, - thenIOName, bindIOName, returnIOName, failIOName :: Name -ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey -ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey -thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey -bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey -returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey -failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey - --- IO things -printName :: Name -printName = varQual sYSTEM_IO (fsLit "print") printIdKey - --- Int, Word, and Addr things -int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name -int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey -int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey -int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey -int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey - --- Word module -word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name -word8TyConName = tcQual gHC_WORD (fsLit "Word8") word8TyConKey -word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey -word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey -word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey - --- PrelPtr module -ptrTyConName, funPtrTyConName :: Name -ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey -funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey - --- Foreign objects and weak pointers -stablePtrTyConName, newStablePtrName :: Name -stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey -newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey - --- Recursive-do notation -monadFixClassName, mfixName :: Name -monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey -mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey - --- Arrow notation -arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name -arrAName = varQual aRROW (fsLit "arr") arrAIdKey -composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey -firstAName = varQual aRROW (fsLit "first") firstAIdKey -appAName = varQual aRROW (fsLit "app") appAIdKey -choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey -loopAName = varQual aRROW (fsLit "loop") loopAIdKey - --- Monad comprehensions -guardMName, liftMName, mzipName :: Name -guardMName = varQual mONAD (fsLit "guard") guardMIdKey -liftMName = varQual mONAD (fsLit "liftM") liftMIdKey -mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey - - --- Annotation type checking -toAnnotationWrapperName :: Name -toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey - --- Other classes, needed for type defaulting -monadPlusClassName, isStringClassName :: Name -monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey - --- Type-level naturals -knownNatClassName :: Name -knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey -knownSymbolClassName :: Name -knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey -knownCharClassName :: Name -knownCharClassName = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey - --- Overloaded labels -fromLabelClassOpName :: Name -fromLabelClassOpName - = varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey - --- Implicit Parameters -ipClassName :: Name -ipClassName - = clsQual gHC_CLASSES (fsLit "IP") ipClassKey - --- Overloaded record fields -hasFieldClassName :: Name -hasFieldClassName - = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey - --- Source Locations -callStackTyConName, emptyCallStackName, pushCallStackName, - srcLocDataConName :: Name -callStackTyConName - = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey -emptyCallStackName - = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey -pushCallStackName - = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey -srcLocDataConName - = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey - --- plugins -pLUGINS :: Module -pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins") -pluginTyConName :: Name -pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey -frontendPluginTyConName :: Name -frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey - --- Static pointers -makeStaticName :: Name -makeStaticName = - varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey - -staticPtrInfoTyConName :: Name -staticPtrInfoTyConName = - tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey - -staticPtrInfoDataConName :: Name -staticPtrInfoDataConName = - dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey - -staticPtrTyConName :: Name -staticPtrTyConName = - tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey - -staticPtrDataConName :: Name -staticPtrDataConName = - dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey - -fromStaticPtrName :: Name -fromStaticPtrName = - varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey - -fingerprintDataConName :: Name -fingerprintDataConName = - dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey - -constPtrConName :: Name -constPtrConName = - tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey - -{- -************************************************************************ -* * -\subsection{Local helpers} -* * -************************************************************************ - -All these are original names; hence mkOrig --} - -{-# INLINE varQual #-} -{-# INLINE tcQual #-} -{-# INLINE clsQual #-} -{-# INLINE dcQual #-} -varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name -varQual modu str unique = mk_known_key_name varName modu str unique -tcQual modu str unique = mk_known_key_name tcName modu str unique -clsQual modu str unique = mk_known_key_name clsName modu str unique -dcQual modu str unique = mk_known_key_name dataName modu str unique - -mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name -{-# INLINE mk_known_key_name #-} -mk_known_key_name space modu str unique - = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan - - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} -* * -************************************************************************ ---MetaHaskell extension hand allocate keys here --} - -boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, - fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, - functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, - realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique -boundedClassKey = mkPreludeClassUnique 1 -enumClassKey = mkPreludeClassUnique 2 -eqClassKey = mkPreludeClassUnique 3 -floatingClassKey = mkPreludeClassUnique 5 -fractionalClassKey = mkPreludeClassUnique 6 -integralClassKey = mkPreludeClassUnique 7 -monadClassKey = mkPreludeClassUnique 8 -dataClassKey = mkPreludeClassUnique 9 -functorClassKey = mkPreludeClassUnique 10 -numClassKey = mkPreludeClassUnique 11 -ordClassKey = mkPreludeClassUnique 12 -readClassKey = mkPreludeClassUnique 13 -realClassKey = mkPreludeClassUnique 14 -realFloatClassKey = mkPreludeClassUnique 15 -realFracClassKey = mkPreludeClassUnique 16 -showClassKey = mkPreludeClassUnique 17 -ixClassKey = mkPreludeClassUnique 18 - -typeableClassKey :: Unique -typeableClassKey = mkPreludeClassUnique 20 - -withDictClassKey :: Unique -withDictClassKey = mkPreludeClassUnique 21 - -monadFixClassKey :: Unique -monadFixClassKey = mkPreludeClassUnique 28 - -monadFailClassKey :: Unique -monadFailClassKey = mkPreludeClassUnique 29 - -monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique -monadPlusClassKey = mkPreludeClassUnique 30 -randomClassKey = mkPreludeClassUnique 31 -randomGenClassKey = mkPreludeClassUnique 32 - -isStringClassKey :: Unique -isStringClassKey = mkPreludeClassUnique 33 - -applicativeClassKey, foldableClassKey, traversableClassKey :: Unique -applicativeClassKey = mkPreludeClassUnique 34 -foldableClassKey = mkPreludeClassUnique 35 -traversableClassKey = mkPreludeClassUnique 36 - -genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, - selectorClassKey :: Unique -genClassKey = mkPreludeClassUnique 37 -gen1ClassKey = mkPreludeClassUnique 38 - -datatypeClassKey = mkPreludeClassUnique 39 -constructorClassKey = mkPreludeClassUnique 40 -selectorClassKey = mkPreludeClassUnique 41 - --- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence -knownNatClassNameKey :: Unique -knownNatClassNameKey = mkPreludeClassUnique 42 - --- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence -knownSymbolClassNameKey :: Unique -knownSymbolClassNameKey = mkPreludeClassUnique 43 - -knownCharClassNameKey :: Unique -knownCharClassNameKey = mkPreludeClassUnique 44 - -ghciIoClassKey :: Unique -ghciIoClassKey = mkPreludeClassUnique 45 - -semigroupClassKey, monoidClassKey :: Unique -semigroupClassKey = mkPreludeClassUnique 47 -monoidClassKey = mkPreludeClassUnique 48 - --- Implicit Parameters -ipClassKey :: Unique -ipClassKey = mkPreludeClassUnique 49 - --- Overloaded record fields -hasFieldClassNameKey :: Unique -hasFieldClassNameKey = mkPreludeClassUnique 50 - - ----------------- Template Haskell ------------------- --- GHC.Builtin.Names.TH: USES ClassUniques 200-299 ------------------------------------------------------ - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} -* * -************************************************************************ --} - -addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, - byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, - doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey, - intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, - int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, - int64PrimTyConKey, int64TyConKey, - integerTyConKey, naturalTyConKey, - listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, - weakPrimTyConKey, mutableArrayPrimTyConKey, - mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, - ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, - stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey, - smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, - stringTyConKey, - ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique -addrPrimTyConKey = mkPreludeTyConUnique 1 -arrayPrimTyConKey = mkPreludeTyConUnique 3 -boolTyConKey = mkPreludeTyConUnique 4 -byteArrayPrimTyConKey = mkPreludeTyConUnique 5 -stringTyConKey = mkPreludeTyConUnique 6 -charPrimTyConKey = mkPreludeTyConUnique 7 -charTyConKey = mkPreludeTyConUnique 8 -doublePrimTyConKey = mkPreludeTyConUnique 9 -doubleTyConKey = mkPreludeTyConUnique 10 -floatPrimTyConKey = mkPreludeTyConUnique 11 -floatTyConKey = mkPreludeTyConUnique 12 -fUNTyConKey = mkPreludeTyConUnique 13 -intPrimTyConKey = mkPreludeTyConUnique 14 -intTyConKey = mkPreludeTyConUnique 15 -int8PrimTyConKey = mkPreludeTyConUnique 16 -int8TyConKey = mkPreludeTyConUnique 17 -int16PrimTyConKey = mkPreludeTyConUnique 18 -int16TyConKey = mkPreludeTyConUnique 19 -int32PrimTyConKey = mkPreludeTyConUnique 20 -int32TyConKey = mkPreludeTyConUnique 21 -int64PrimTyConKey = mkPreludeTyConUnique 22 -int64TyConKey = mkPreludeTyConUnique 23 -integerTyConKey = mkPreludeTyConUnique 24 -naturalTyConKey = mkPreludeTyConUnique 25 - -listTyConKey = mkPreludeTyConUnique 26 -foreignObjPrimTyConKey = mkPreludeTyConUnique 27 -maybeTyConKey = mkPreludeTyConUnique 28 -weakPrimTyConKey = mkPreludeTyConUnique 29 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 -orderingTyConKey = mkPreludeTyConUnique 32 -mVarPrimTyConKey = mkPreludeTyConUnique 33 -ioPortPrimTyConKey = mkPreludeTyConUnique 34 -ratioTyConKey = mkPreludeTyConUnique 35 -rationalTyConKey = mkPreludeTyConUnique 36 -realWorldTyConKey = mkPreludeTyConUnique 37 -stablePtrPrimTyConKey = mkPreludeTyConUnique 38 -stablePtrTyConKey = mkPreludeTyConUnique 39 -eqTyConKey = mkPreludeTyConUnique 40 -heqTyConKey = mkPreludeTyConUnique 41 - -ctArrowTyConKey = mkPreludeTyConUnique 42 -ccArrowTyConKey = mkPreludeTyConUnique 43 -tcArrowTyConKey = mkPreludeTyConUnique 44 - -statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, - mutVarPrimTyConKey, ioTyConKey, - wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, - word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, - word64PrimTyConKey, word64TyConKey, - kindConKey, boxityConKey, - typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, - eqReprPrimTyConKey, eqPhantPrimTyConKey, - compactPrimTyConKey, stackSnapshotPrimTyConKey, - promptTagPrimTyConKey, constPtrTyConKey :: Unique -statePrimTyConKey = mkPreludeTyConUnique 50 -stableNamePrimTyConKey = mkPreludeTyConUnique 51 -stableNameTyConKey = mkPreludeTyConUnique 52 -eqPrimTyConKey = mkPreludeTyConUnique 53 -eqReprPrimTyConKey = mkPreludeTyConUnique 54 -eqPhantPrimTyConKey = mkPreludeTyConUnique 55 -mutVarPrimTyConKey = mkPreludeTyConUnique 56 -ioTyConKey = mkPreludeTyConUnique 57 -wordPrimTyConKey = mkPreludeTyConUnique 59 -wordTyConKey = mkPreludeTyConUnique 60 -word8PrimTyConKey = mkPreludeTyConUnique 61 -word8TyConKey = mkPreludeTyConUnique 62 -word16PrimTyConKey = mkPreludeTyConUnique 63 -word16TyConKey = mkPreludeTyConUnique 64 -word32PrimTyConKey = mkPreludeTyConUnique 65 -word32TyConKey = mkPreludeTyConUnique 66 -word64PrimTyConKey = mkPreludeTyConUnique 67 -word64TyConKey = mkPreludeTyConUnique 68 -kindConKey = mkPreludeTyConUnique 72 -boxityConKey = mkPreludeTyConUnique 73 -typeConKey = mkPreludeTyConUnique 74 -threadIdPrimTyConKey = mkPreludeTyConUnique 75 -bcoPrimTyConKey = mkPreludeTyConUnique 76 -ptrTyConKey = mkPreludeTyConUnique 77 -funPtrTyConKey = mkPreludeTyConUnique 78 -tVarPrimTyConKey = mkPreludeTyConUnique 79 -compactPrimTyConKey = mkPreludeTyConUnique 80 -stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81 -promptTagPrimTyConKey = mkPreludeTyConUnique 82 - -eitherTyConKey :: Unique -eitherTyConKey = mkPreludeTyConUnique 84 - -voidTyConKey :: Unique -voidTyConKey = mkPreludeTyConUnique 85 - -nonEmptyTyConKey :: Unique -nonEmptyTyConKey = mkPreludeTyConUnique 86 - -dictTyConKey :: Unique -dictTyConKey = mkPreludeTyConUnique 87 - --- Kind constructors -liftedTypeKindTyConKey, unliftedTypeKindTyConKey, - tYPETyConKey, cONSTRAINTTyConKey, - liftedRepTyConKey, unliftedRepTyConKey, - constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, - vecCountTyConKey, vecElemTyConKey, - zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique -liftedTypeKindTyConKey = mkPreludeTyConUnique 88 -unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 -tYPETyConKey = mkPreludeTyConUnique 91 -cONSTRAINTTyConKey = mkPreludeTyConUnique 92 -constraintKindTyConKey = mkPreludeTyConUnique 93 -levityTyConKey = mkPreludeTyConUnique 94 -runtimeRepTyConKey = mkPreludeTyConUnique 95 -vecCountTyConKey = mkPreludeTyConUnique 96 -vecElemTyConKey = mkPreludeTyConUnique 97 -liftedRepTyConKey = mkPreludeTyConUnique 98 -unliftedRepTyConKey = mkPreludeTyConUnique 99 -zeroBitRepTyConKey = mkPreludeTyConUnique 100 -zeroBitTypeTyConKey = mkPreludeTyConUnique 101 - -pluginTyConKey, frontendPluginTyConKey :: Unique -pluginTyConKey = mkPreludeTyConUnique 102 -frontendPluginTyConKey = mkPreludeTyConUnique 103 - -trTyConTyConKey, trModuleTyConKey, trNameTyConKey, - kindRepTyConKey, typeLitSortTyConKey :: Unique -trTyConTyConKey = mkPreludeTyConUnique 104 -trModuleTyConKey = mkPreludeTyConUnique 105 -trNameTyConKey = mkPreludeTyConUnique 106 -kindRepTyConKey = mkPreludeTyConUnique 107 -typeLitSortTyConKey = mkPreludeTyConUnique 108 - --- Generics (Unique keys) -v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, - k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, - compTyConKey, rTyConKey, dTyConKey, - cTyConKey, sTyConKey, rec0TyConKey, - d1TyConKey, c1TyConKey, s1TyConKey, - repTyConKey, rep1TyConKey, uRecTyConKey, - uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, - uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique - -v1TyConKey = mkPreludeTyConUnique 135 -u1TyConKey = mkPreludeTyConUnique 136 -par1TyConKey = mkPreludeTyConUnique 137 -rec1TyConKey = mkPreludeTyConUnique 138 -k1TyConKey = mkPreludeTyConUnique 139 -m1TyConKey = mkPreludeTyConUnique 140 - -sumTyConKey = mkPreludeTyConUnique 141 -prodTyConKey = mkPreludeTyConUnique 142 -compTyConKey = mkPreludeTyConUnique 143 - -rTyConKey = mkPreludeTyConUnique 144 -dTyConKey = mkPreludeTyConUnique 146 -cTyConKey = mkPreludeTyConUnique 147 -sTyConKey = mkPreludeTyConUnique 148 - -rec0TyConKey = mkPreludeTyConUnique 149 -d1TyConKey = mkPreludeTyConUnique 151 -c1TyConKey = mkPreludeTyConUnique 152 -s1TyConKey = mkPreludeTyConUnique 153 - -repTyConKey = mkPreludeTyConUnique 155 -rep1TyConKey = mkPreludeTyConUnique 156 - -uRecTyConKey = mkPreludeTyConUnique 157 -uAddrTyConKey = mkPreludeTyConUnique 158 -uCharTyConKey = mkPreludeTyConUnique 159 -uDoubleTyConKey = mkPreludeTyConUnique 160 -uFloatTyConKey = mkPreludeTyConUnique 161 -uIntTyConKey = mkPreludeTyConUnique 162 -uWordTyConKey = mkPreludeTyConUnique 163 - --- "Unsatisfiable" constraint -unsatisfiableClassNameKey :: Unique -unsatisfiableClassNameKey = mkPreludeTyConUnique 170 - --- Custom user type-errors -errorMessageTypeErrorFamKey :: Unique -errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181 - -coercibleTyConKey :: Unique -coercibleTyConKey = mkPreludeTyConUnique 183 - -proxyPrimTyConKey :: Unique -proxyPrimTyConKey = mkPreludeTyConUnique 184 - -specTyConKey :: Unique -specTyConKey = mkPreludeTyConUnique 185 - -anyTyConKey :: Unique -anyTyConKey = mkPreludeTyConUnique 186 - -smallArrayPrimTyConKey = mkPreludeTyConUnique 187 -smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 - -staticPtrTyConKey :: Unique -staticPtrTyConKey = mkPreludeTyConUnique 189 - -staticPtrInfoTyConKey :: Unique -staticPtrInfoTyConKey = mkPreludeTyConUnique 190 - -callStackTyConKey :: Unique -callStackTyConKey = mkPreludeTyConUnique 191 - --- Typeables -typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique -typeRepTyConKey = mkPreludeTyConUnique 192 -someTypeRepTyConKey = mkPreludeTyConUnique 193 -someTypeRepDataConKey = mkPreludeTyConUnique 194 - - -typeSymbolAppendFamNameKey :: Unique -typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195 - --- Unsafe equality -unsafeEqualityTyConKey :: Unique -unsafeEqualityTyConKey = mkPreludeTyConUnique 196 - --- Linear types -multiplicityTyConKey :: Unique -multiplicityTyConKey = mkPreludeTyConUnique 197 - -unrestrictedFunTyConKey :: Unique -unrestrictedFunTyConKey = mkPreludeTyConUnique 198 - -multMulTyConKey :: Unique -multMulTyConKey = mkPreludeTyConUnique 199 - ----------------- Template Haskell ------------------- --- GHC.Builtin.Names.TH: USES TyConUniques 200-299 ------------------------------------------------------ - ------------------------ SIMD ------------------------ --- USES TyConUniques 300-399 ------------------------------------------------------ - -#include "primop-vector-uniques.hs-incl" - -------------- Type-level Symbol, Nat, Char ---------- --- USES TyConUniques 400-499 ------------------------------------------------------ -typeSymbolKindConNameKey, typeCharKindConNameKey, - typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, - typeNatSubTyFamNameKey - , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey - , typeLeqCharTyFamNameKey - , typeNatDivTyFamNameKey - , typeNatModTyFamNameKey - , typeNatLogTyFamNameKey - , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey - , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey - :: Unique -typeSymbolKindConNameKey = mkPreludeTyConUnique 400 -typeCharKindConNameKey = mkPreludeTyConUnique 401 -typeNatAddTyFamNameKey = mkPreludeTyConUnique 402 -typeNatMulTyFamNameKey = mkPreludeTyConUnique 403 -typeNatExpTyFamNameKey = mkPreludeTyConUnique 404 -typeNatSubTyFamNameKey = mkPreludeTyConUnique 405 -typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406 -typeNatCmpTyFamNameKey = mkPreludeTyConUnique 407 -typeCharCmpTyFamNameKey = mkPreludeTyConUnique 408 -typeLeqCharTyFamNameKey = mkPreludeTyConUnique 409 -typeNatDivTyFamNameKey = mkPreludeTyConUnique 410 -typeNatModTyFamNameKey = mkPreludeTyConUnique 411 -typeNatLogTyFamNameKey = mkPreludeTyConUnique 412 -typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413 -typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 -typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 -typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 -constPtrTyConKey = mkPreludeTyConUnique 417 - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} -* * -************************************************************************ --} - -charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, - floatDataConKey, intDataConKey, nilDataConKey, - ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, - word8DataConKey, ioDataConKey, heqDataConKey, - eqDataConKey, nothingDataConKey, justDataConKey :: Unique - -charDataConKey = mkPreludeDataConUnique 1 -consDataConKey = mkPreludeDataConUnique 2 -doubleDataConKey = mkPreludeDataConUnique 3 -falseDataConKey = mkPreludeDataConUnique 4 -floatDataConKey = mkPreludeDataConUnique 5 -intDataConKey = mkPreludeDataConUnique 6 -nothingDataConKey = mkPreludeDataConUnique 7 -justDataConKey = mkPreludeDataConUnique 8 -eqDataConKey = mkPreludeDataConUnique 9 -nilDataConKey = mkPreludeDataConUnique 10 -ratioDataConKey = mkPreludeDataConUnique 11 -word8DataConKey = mkPreludeDataConUnique 12 -stableNameDataConKey = mkPreludeDataConUnique 13 -trueDataConKey = mkPreludeDataConUnique 14 -wordDataConKey = mkPreludeDataConUnique 15 -ioDataConKey = mkPreludeDataConUnique 16 -heqDataConKey = mkPreludeDataConUnique 18 - --- Generic data constructors -crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique -crossDataConKey = mkPreludeDataConUnique 20 -inlDataConKey = mkPreludeDataConUnique 21 -inrDataConKey = mkPreludeDataConUnique 22 -genUnitDataConKey = mkPreludeDataConUnique 23 - -leftDataConKey, rightDataConKey :: Unique -leftDataConKey = mkPreludeDataConUnique 25 -rightDataConKey = mkPreludeDataConUnique 26 - -ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique -ordLTDataConKey = mkPreludeDataConUnique 27 -ordEQDataConKey = mkPreludeDataConUnique 28 -ordGTDataConKey = mkPreludeDataConUnique 29 - -mkDictDataConKey :: Unique -mkDictDataConKey = mkPreludeDataConUnique 30 - -coercibleDataConKey :: Unique -coercibleDataConKey = mkPreludeDataConUnique 32 - -staticPtrDataConKey :: Unique -staticPtrDataConKey = mkPreludeDataConUnique 33 - -staticPtrInfoDataConKey :: Unique -staticPtrInfoDataConKey = mkPreludeDataConUnique 34 - -fingerprintDataConKey :: Unique -fingerprintDataConKey = mkPreludeDataConUnique 35 - -srcLocDataConKey :: Unique -srcLocDataConKey = mkPreludeDataConUnique 37 - -trTyConDataConKey, trModuleDataConKey, - trNameSDataConKey, trNameDDataConKey, - trGhcPrimModuleKey :: Unique -trTyConDataConKey = mkPreludeDataConUnique 41 -trModuleDataConKey = mkPreludeDataConUnique 43 -trNameSDataConKey = mkPreludeDataConUnique 45 -trNameDDataConKey = mkPreludeDataConUnique 46 -trGhcPrimModuleKey = mkPreludeDataConUnique 47 - -typeErrorTextDataConKey, - typeErrorAppendDataConKey, - typeErrorVAppendDataConKey, - typeErrorShowTypeDataConKey - :: Unique -typeErrorTextDataConKey = mkPreludeDataConUnique 50 -typeErrorAppendDataConKey = mkPreludeDataConUnique 51 -typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 -typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 - -prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, - rightAssociativeDataConKey, notAssociativeDataConKey, - sourceUnpackDataConKey, sourceNoUnpackDataConKey, - noSourceUnpackednessDataConKey, sourceLazyDataConKey, - sourceStrictDataConKey, noSourceStrictnessDataConKey, - decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, - metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique -prefixIDataConKey = mkPreludeDataConUnique 54 -infixIDataConKey = mkPreludeDataConUnique 55 -leftAssociativeDataConKey = mkPreludeDataConUnique 56 -rightAssociativeDataConKey = mkPreludeDataConUnique 57 -notAssociativeDataConKey = mkPreludeDataConUnique 58 -sourceUnpackDataConKey = mkPreludeDataConUnique 59 -sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 -noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 -sourceLazyDataConKey = mkPreludeDataConUnique 62 -sourceStrictDataConKey = mkPreludeDataConUnique 63 -noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 -decidedLazyDataConKey = mkPreludeDataConUnique 65 -decidedStrictDataConKey = mkPreludeDataConUnique 66 -decidedUnpackDataConKey = mkPreludeDataConUnique 67 -metaDataDataConKey = mkPreludeDataConUnique 68 -metaConsDataConKey = mkPreludeDataConUnique 69 -metaSelDataConKey = mkPreludeDataConUnique 70 - -vecRepDataConKey, sumRepDataConKey, - tupleRepDataConKey, boxedRepDataConKey :: Unique -vecRepDataConKey = mkPreludeDataConUnique 71 -tupleRepDataConKey = mkPreludeDataConUnique 72 -sumRepDataConKey = mkPreludeDataConUnique 73 -boxedRepDataConKey = mkPreludeDataConUnique 74 - -boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique --- A promoted data constructors (i.e. a TyCon) has --- the same key as the data constructor itself -boxedRepDataConTyConKey = boxedRepDataConKey -tupleRepDataConTyConKey = tupleRepDataConKey - --- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types --- Includes all nullary-data-constructor reps. Does not --- include BoxedRep, VecRep, SumRep, TupleRep. -runtimeRepSimpleDataConKeys :: [Unique] -runtimeRepSimpleDataConKeys - = map mkPreludeDataConUnique [75..87] - -liftedDataConKey,unliftedDataConKey :: Unique -liftedDataConKey = mkPreludeDataConUnique 88 -unliftedDataConKey = mkPreludeDataConUnique 89 - --- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types --- VecCount -vecCountDataConKeys :: [Unique] -vecCountDataConKeys = map mkPreludeDataConUnique [90..95] - --- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types --- VecElem -vecElemDataConKeys :: [Unique] -vecElemDataConKeys = map mkPreludeDataConUnique [96..105] - --- Typeable things -kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, - kindRepFunDataConKey, kindRepTYPEDataConKey, - kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey - :: Unique -kindRepTyConAppDataConKey = mkPreludeDataConUnique 106 -kindRepVarDataConKey = mkPreludeDataConUnique 107 -kindRepAppDataConKey = mkPreludeDataConUnique 108 -kindRepFunDataConKey = mkPreludeDataConUnique 109 -kindRepTYPEDataConKey = mkPreludeDataConUnique 110 -kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111 -kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112 - -typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique -typeLitSymbolDataConKey = mkPreludeDataConUnique 113 -typeLitNatDataConKey = mkPreludeDataConUnique 114 -typeLitCharDataConKey = mkPreludeDataConUnique 115 - --- Unsafe equality -unsafeReflDataConKey :: Unique -unsafeReflDataConKey = mkPreludeDataConUnique 116 - --- Multiplicity - -oneDataConKey, manyDataConKey :: Unique -oneDataConKey = mkPreludeDataConUnique 117 -manyDataConKey = mkPreludeDataConUnique 118 - --- ghc-bignum -integerISDataConKey, integerINDataConKey, integerIPDataConKey, - naturalNSDataConKey, naturalNBDataConKey :: Unique -integerISDataConKey = mkPreludeDataConUnique 120 -integerINDataConKey = mkPreludeDataConUnique 121 -integerIPDataConKey = mkPreludeDataConUnique 122 -naturalNSDataConKey = mkPreludeDataConUnique 123 -naturalNBDataConKey = mkPreludeDataConUnique 124 - - ----------------- Template Haskell ------------------- --- GHC.Builtin.Names.TH: USES DataUniques 200-250 ------------------------------------------------------ - - -{- -************************************************************************ -* * -\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} -* * -************************************************************************ --} - -wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey, - buildIdKey, foldrIdKey, recSelErrorIdKey, - seqIdKey, eqStringIdKey, - noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - impossibleErrorIdKey, impossibleConstraintErrorIdKey, - patErrorIdKey, voidPrimIdKey, - realWorldPrimIdKey, recConErrorIdKey, - unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, - unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, - typeErrorIdKey, divIntIdKey, modIntIdKey, - absentSumFieldErrorIdKey, cstringLengthIdKey - :: Unique - -wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] -absentErrorIdKey = mkPreludeMiscIdUnique 1 -absentConstraintErrorIdKey = mkPreludeMiscIdUnique 2 -augmentIdKey = mkPreludeMiscIdUnique 3 -appendIdKey = mkPreludeMiscIdUnique 4 -buildIdKey = mkPreludeMiscIdUnique 5 -foldrIdKey = mkPreludeMiscIdUnique 6 -recSelErrorIdKey = mkPreludeMiscIdUnique 7 -seqIdKey = mkPreludeMiscIdUnique 8 -absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 -eqStringIdKey = mkPreludeMiscIdUnique 10 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 -impossibleErrorIdKey = mkPreludeMiscIdUnique 13 -impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14 -patErrorIdKey = mkPreludeMiscIdUnique 15 -realWorldPrimIdKey = mkPreludeMiscIdUnique 16 -recConErrorIdKey = mkPreludeMiscIdUnique 17 - -unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 18 -unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 19 -unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 20 - -unpackCStringIdKey = mkPreludeMiscIdUnique 21 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 22 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 23 - -voidPrimIdKey = mkPreludeMiscIdUnique 24 -typeErrorIdKey = mkPreludeMiscIdUnique 25 -divIntIdKey = mkPreludeMiscIdUnique 26 -modIntIdKey = mkPreludeMiscIdUnique 27 -cstringLengthIdKey = mkPreludeMiscIdUnique 28 - -concatIdKey, filterIdKey, zipIdKey, - bindIOIdKey, returnIOIdKey, newStablePtrIdKey, - printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, - otherwiseIdKey, assertIdKey :: Unique -concatIdKey = mkPreludeMiscIdUnique 31 -filterIdKey = mkPreludeMiscIdUnique 32 -zipIdKey = mkPreludeMiscIdUnique 33 -bindIOIdKey = mkPreludeMiscIdUnique 34 -returnIOIdKey = mkPreludeMiscIdUnique 35 -newStablePtrIdKey = mkPreludeMiscIdUnique 36 -printIdKey = mkPreludeMiscIdUnique 37 -failIOIdKey = mkPreludeMiscIdUnique 38 -nullAddrIdKey = mkPreludeMiscIdUnique 39 -voidArgIdKey = mkPreludeMiscIdUnique 40 -otherwiseIdKey = mkPreludeMiscIdUnique 43 -assertIdKey = mkPreludeMiscIdUnique 44 - -leftSectionKey, rightSectionKey :: Unique -leftSectionKey = mkPreludeMiscIdUnique 45 -rightSectionKey = mkPreludeMiscIdUnique 46 - -rootMainKey, runMainKey :: Unique -rootMainKey = mkPreludeMiscIdUnique 101 -runMainKey = mkPreludeMiscIdUnique 102 - -thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique -thenIOIdKey = mkPreludeMiscIdUnique 103 -lazyIdKey = mkPreludeMiscIdUnique 104 -assertErrorIdKey = mkPreludeMiscIdUnique 105 -oneShotKey = mkPreludeMiscIdUnique 106 -runRWKey = mkPreludeMiscIdUnique 107 - -traceKey :: Unique -traceKey = mkPreludeMiscIdUnique 108 - -nospecIdKey :: Unique -nospecIdKey = mkPreludeMiscIdUnique 109 - -inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique -inlineIdKey = mkPreludeMiscIdUnique 120 --- see below - -mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique -mapIdKey = mkPreludeMiscIdUnique 121 -dollarIdKey = mkPreludeMiscIdUnique 123 -coercionTokenIdKey = mkPreludeMiscIdUnique 124 -considerAccessibleIdKey = mkPreludeMiscIdUnique 125 -noinlineIdKey = mkPreludeMiscIdUnique 126 -noinlineConstraintIdKey = mkPreludeMiscIdUnique 127 - -integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique -integerToFloatIdKey = mkPreludeMiscIdUnique 128 -integerToDoubleIdKey = mkPreludeMiscIdUnique 129 -naturalToFloatIdKey = mkPreludeMiscIdUnique 130 -naturalToDoubleIdKey = mkPreludeMiscIdUnique 131 - -rationalToFloatIdKey, rationalToDoubleIdKey :: Unique -rationalToFloatIdKey = mkPreludeMiscIdUnique 132 -rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 - -coerceKey :: Unique -coerceKey = mkPreludeMiscIdUnique 157 - -{- -Certain class operations from Prelude classes. They get their own -uniques so we can look them up easily when we want to conjure them up -during type checking. --} - --- Just a placeholder for unbound variables produced by the renamer: -unboundKey :: Unique -unboundKey = mkPreludeMiscIdUnique 158 - -fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, - enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, - enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey - :: Unique -fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 -minusClassOpKey = mkPreludeMiscIdUnique 161 -fromRationalClassOpKey = mkPreludeMiscIdUnique 162 -enumFromClassOpKey = mkPreludeMiscIdUnique 163 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 -enumFromToClassOpKey = mkPreludeMiscIdUnique 165 -enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 -eqClassOpKey = mkPreludeMiscIdUnique 167 -geClassOpKey = mkPreludeMiscIdUnique 168 -negateClassOpKey = mkPreludeMiscIdUnique 169 -bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) -thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) -fmapClassOpKey = mkPreludeMiscIdUnique 173 -returnMClassOpKey = mkPreludeMiscIdUnique 174 - --- Recursive do notation -mfixIdKey :: Unique -mfixIdKey = mkPreludeMiscIdUnique 175 - --- MonadFail operations -failMClassOpKey :: Unique -failMClassOpKey = mkPreludeMiscIdUnique 176 - --- fromLabel -fromLabelClassOpKey :: Unique -fromLabelClassOpKey = mkPreludeMiscIdUnique 177 - --- Arrow notation -arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, - loopAIdKey :: Unique -arrAIdKey = mkPreludeMiscIdUnique 180 -composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> -firstAIdKey = mkPreludeMiscIdUnique 182 -appAIdKey = mkPreludeMiscIdUnique 183 -choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| -loopAIdKey = mkPreludeMiscIdUnique 185 - -fromStringClassOpKey :: Unique -fromStringClassOpKey = mkPreludeMiscIdUnique 186 - --- Annotation type checking -toAnnotationWrapperIdKey :: Unique -toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 - --- Conversion functions -fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique -fromIntegralIdKey = mkPreludeMiscIdUnique 190 -realToFracIdKey = mkPreludeMiscIdUnique 191 -toIntegerClassOpKey = mkPreludeMiscIdUnique 192 -toRationalClassOpKey = mkPreludeMiscIdUnique 193 - --- Monad comprehensions -guardMIdKey, liftMIdKey, mzipIdKey :: Unique -guardMIdKey = mkPreludeMiscIdUnique 194 -liftMIdKey = mkPreludeMiscIdUnique 195 -mzipIdKey = mkPreludeMiscIdUnique 196 - --- GHCi -ghciStepIoMClassOpKey :: Unique -ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 - --- Overloaded lists -isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique -isListClassKey = mkPreludeMiscIdUnique 198 -fromListClassOpKey = mkPreludeMiscIdUnique 199 -fromListNClassOpKey = mkPreludeMiscIdUnique 500 -toListClassOpKey = mkPreludeMiscIdUnique 501 - -proxyHashKey :: Unique -proxyHashKey = mkPreludeMiscIdUnique 502 - ----------------- Template Haskell ------------------- --- GHC.Builtin.Names.TH: USES IdUniques 200-499 ------------------------------------------------------ - --- Used to make `Typeable` dictionaries -mkTyConKey - , mkTrTypeKey - , mkTrConKey - , mkTrAppKey - , mkTrFunKey - , typeNatTypeRepKey - , typeSymbolTypeRepKey - , typeCharTypeRepKey - , typeRepIdKey - :: Unique -mkTyConKey = mkPreludeMiscIdUnique 503 -mkTrTypeKey = mkPreludeMiscIdUnique 504 -mkTrConKey = mkPreludeMiscIdUnique 505 -mkTrAppKey = mkPreludeMiscIdUnique 506 -typeNatTypeRepKey = mkPreludeMiscIdUnique 507 -typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 -typeCharTypeRepKey = mkPreludeMiscIdUnique 509 -typeRepIdKey = mkPreludeMiscIdUnique 510 -mkTrFunKey = mkPreludeMiscIdUnique 511 - --- KindReps for common cases -starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique -starKindRepKey = mkPreludeMiscIdUnique 520 -starArrStarKindRepKey = mkPreludeMiscIdUnique 521 -starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 -constraintKindRepKey = mkPreludeMiscIdUnique 523 - --- Dynamic -toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 530 - - -heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique -eqSCSelIdKey = mkPreludeMiscIdUnique 551 -heqSCSelIdKey = mkPreludeMiscIdUnique 552 -coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 - -sappendClassOpKey :: Unique -sappendClassOpKey = mkPreludeMiscIdUnique 554 - -memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique -memptyClassOpKey = mkPreludeMiscIdUnique 555 -mappendClassOpKey = mkPreludeMiscIdUnique 556 -mconcatClassOpKey = mkPreludeMiscIdUnique 557 - -emptyCallStackKey, pushCallStackKey :: Unique -emptyCallStackKey = mkPreludeMiscIdUnique 558 -pushCallStackKey = mkPreludeMiscIdUnique 559 - -fromStaticPtrClassOpKey :: Unique -fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 - -makeStaticKey :: Unique -makeStaticKey = mkPreludeMiscIdUnique 561 - --- Unsafe coercion proofs -unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique -unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 -unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 - --- HasField class ops -getFieldClassOpKey, setFieldClassOpKey :: Unique -getFieldClassOpKey = mkPreludeMiscIdUnique 572 -setFieldClassOpKey = mkPreludeMiscIdUnique 573 - --- "Unsatisfiable" constraints -unsatisfiableIdNameKey :: Unique -unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580 - ------------------------------------------------------- --- ghc-bignum uses 600-699 uniques ------------------------------------------------------- - -integerFromNaturalIdKey - , integerToNaturalClampIdKey - , integerToNaturalThrowIdKey - , integerToNaturalIdKey - , integerToWordIdKey - , integerToIntIdKey - , integerToWord64IdKey - , integerToInt64IdKey - , integerAddIdKey - , integerMulIdKey - , integerSubIdKey - , integerNegateIdKey - , integerAbsIdKey - , integerPopCountIdKey - , integerQuotIdKey - , integerRemIdKey - , integerDivIdKey - , integerModIdKey - , integerDivModIdKey - , integerQuotRemIdKey - , integerEncodeFloatIdKey - , integerEncodeDoubleIdKey - , integerGcdIdKey - , integerLcmIdKey - , integerAndIdKey - , integerOrIdKey - , integerXorIdKey - , integerComplementIdKey - , integerBitIdKey - , integerTestBitIdKey - , integerShiftLIdKey - , integerShiftRIdKey - , integerFromWordIdKey - , integerFromWord64IdKey - , integerFromInt64IdKey - , naturalToWordIdKey - , naturalPopCountIdKey - , naturalShiftRIdKey - , naturalShiftLIdKey - , naturalAddIdKey - , naturalSubIdKey - , naturalSubThrowIdKey - , naturalSubUnsafeIdKey - , naturalMulIdKey - , naturalQuotRemIdKey - , naturalQuotIdKey - , naturalRemIdKey - , naturalAndIdKey - , naturalAndNotIdKey - , naturalOrIdKey - , naturalXorIdKey - , naturalTestBitIdKey - , naturalBitIdKey - , naturalGcdIdKey - , naturalLcmIdKey - , naturalLog2IdKey - , naturalLogBaseWordIdKey - , naturalLogBaseIdKey - , naturalPowModIdKey - , naturalSizeInBaseIdKey - , bignatFromWordListIdKey - , bignatEqIdKey - , bignatCompareIdKey - , bignatCompareWordIdKey - :: Unique - -integerFromNaturalIdKey = mkPreludeMiscIdUnique 600 -integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601 -integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602 -integerToNaturalIdKey = mkPreludeMiscIdUnique 603 -integerToWordIdKey = mkPreludeMiscIdUnique 604 -integerToIntIdKey = mkPreludeMiscIdUnique 605 -integerToWord64IdKey = mkPreludeMiscIdUnique 606 -integerToInt64IdKey = mkPreludeMiscIdUnique 607 -integerAddIdKey = mkPreludeMiscIdUnique 608 -integerMulIdKey = mkPreludeMiscIdUnique 609 -integerSubIdKey = mkPreludeMiscIdUnique 610 -integerNegateIdKey = mkPreludeMiscIdUnique 611 -integerAbsIdKey = mkPreludeMiscIdUnique 618 -integerPopCountIdKey = mkPreludeMiscIdUnique 621 -integerQuotIdKey = mkPreludeMiscIdUnique 622 -integerRemIdKey = mkPreludeMiscIdUnique 623 -integerDivIdKey = mkPreludeMiscIdUnique 624 -integerModIdKey = mkPreludeMiscIdUnique 625 -integerDivModIdKey = mkPreludeMiscIdUnique 626 -integerQuotRemIdKey = mkPreludeMiscIdUnique 627 -integerEncodeFloatIdKey = mkPreludeMiscIdUnique 630 -integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 631 -integerGcdIdKey = mkPreludeMiscIdUnique 632 -integerLcmIdKey = mkPreludeMiscIdUnique 633 -integerAndIdKey = mkPreludeMiscIdUnique 634 -integerOrIdKey = mkPreludeMiscIdUnique 635 -integerXorIdKey = mkPreludeMiscIdUnique 636 -integerComplementIdKey = mkPreludeMiscIdUnique 637 -integerBitIdKey = mkPreludeMiscIdUnique 638 -integerTestBitIdKey = mkPreludeMiscIdUnique 639 -integerShiftLIdKey = mkPreludeMiscIdUnique 640 -integerShiftRIdKey = mkPreludeMiscIdUnique 641 -integerFromWordIdKey = mkPreludeMiscIdUnique 642 -integerFromWord64IdKey = mkPreludeMiscIdUnique 643 -integerFromInt64IdKey = mkPreludeMiscIdUnique 644 - -naturalToWordIdKey = mkPreludeMiscIdUnique 650 -naturalPopCountIdKey = mkPreludeMiscIdUnique 659 -naturalShiftRIdKey = mkPreludeMiscIdUnique 660 -naturalShiftLIdKey = mkPreludeMiscIdUnique 661 -naturalAddIdKey = mkPreludeMiscIdUnique 662 -naturalSubIdKey = mkPreludeMiscIdUnique 663 -naturalSubThrowIdKey = mkPreludeMiscIdUnique 664 -naturalSubUnsafeIdKey = mkPreludeMiscIdUnique 665 -naturalMulIdKey = mkPreludeMiscIdUnique 666 -naturalQuotRemIdKey = mkPreludeMiscIdUnique 669 -naturalQuotIdKey = mkPreludeMiscIdUnique 670 -naturalRemIdKey = mkPreludeMiscIdUnique 671 -naturalAndIdKey = mkPreludeMiscIdUnique 672 -naturalAndNotIdKey = mkPreludeMiscIdUnique 673 -naturalOrIdKey = mkPreludeMiscIdUnique 674 -naturalXorIdKey = mkPreludeMiscIdUnique 675 -naturalTestBitIdKey = mkPreludeMiscIdUnique 676 -naturalBitIdKey = mkPreludeMiscIdUnique 677 -naturalGcdIdKey = mkPreludeMiscIdUnique 678 -naturalLcmIdKey = mkPreludeMiscIdUnique 679 -naturalLog2IdKey = mkPreludeMiscIdUnique 680 -naturalLogBaseWordIdKey = mkPreludeMiscIdUnique 681 -naturalLogBaseIdKey = mkPreludeMiscIdUnique 682 -naturalPowModIdKey = mkPreludeMiscIdUnique 683 -naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 - -bignatFromWordListIdKey = mkPreludeMiscIdUnique 690 -bignatEqIdKey = mkPreludeMiscIdUnique 691 -bignatCompareIdKey = mkPreludeMiscIdUnique 692 -bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 - - ------------------------------------------------------- --- ghci optimization for big rationals 700-749 uniques ------------------------------------------------------- - --- Creating rationals at runtime. -mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique -mkRationalBase2IdKey = mkPreludeMiscIdUnique 700 -mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique - -{- -************************************************************************ -* * -\subsection[Class-std-groups]{Standard groups of Prelude classes} -* * -************************************************************************ - -NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ -even though every numeric class has these two as a superclass, -because the list of ambiguous dictionaries hasn't been simplified. --} - -numericClassKeys :: [Unique] -numericClassKeys = - [ numClassKey - , realClassKey - , integralClassKey - ] - ++ fractionalClassKeys - -fractionalClassKeys :: [Unique] -fractionalClassKeys = - [ fractionalClassKey - , floatingClassKey - , realFracClassKey - , realFloatClassKey - ] - --- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), --- and are: "classes defined in the Prelude or a standard library" -standardClassKeys :: [Unique] -standardClassKeys = derivableClassKeys ++ numericClassKeys - ++ [randomClassKey, randomGenClassKey, - functorClassKey, - monadClassKey, monadPlusClassKey, monadFailClassKey, - semigroupClassKey, monoidClassKey, - isStringClassKey, - applicativeClassKey, foldableClassKey, - traversableClassKey, alternativeClassKey - ] - -{- -@derivableClassKeys@ is also used in checking \tr{deriving} constructs -(@GHC.Tc.Deriv@). --} - -derivableClassKeys :: [Unique] -derivableClassKeys - = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, - boundedClassKey, showClassKey, readClassKey ] - - --- These are the "interactive classes" that are consulted when doing --- defaulting. Does not include Num or IsString, which have special --- handling. -interactiveClassNames :: [Name] -interactiveClassNames - = [ showClassName, eqClassName, ordClassName, foldableClassName - , traversableClassName ] - -interactiveClassKeys :: [Unique] -interactiveClassKeys = map getUnique interactiveClassNames - -{- -************************************************************************ -* * - Semi-builtin names -* * -************************************************************************ - -Note [pretendNameIsInScope] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, we filter out instances that mention types whose names are -not in scope. However, in the situations listed below, we make an exception -for some commonly used names, such as Data.Kind.Type, which may not actually -be in scope but should be treated as though they were in scope. -This includes built-in names, as well as a few extra names such as -'Type', 'TYPE', 'BoxedRep', etc. - -Situations in which we apply this special logic: - - - GHCi's :info command, see GHC.Runtime.Eval.getInfo. - This fixes #1581. - - - When reporting instance overlap errors. Not doing so could mean - that we would omit instances for typeclasses like - - type Cls :: k -> Constraint - class Cls a - - because BoxedRep/Lifted were not in scope. - See GHC.Tc.Errors.potentialInstancesErrMsg. - This fixes one of the issues reported in #20465. --} - --- | Should this name be considered in-scope, even though it technically isn't? --- --- This ensures that we don't filter out information because, e.g., --- Data.Kind.Type isn't imported. --- --- See Note [pretendNameIsInScope]. -pretendNameIsInScope :: Name -> Bool -pretendNameIsInScope n - = isBuiltInSyntax n - || isTupleTyConName n - || any (n `hasKey`) - [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey - , liftedDataConKey, unliftedDataConKey - , tYPETyConKey - , cONSTRAINTTyConKey - , runtimeRepTyConKey, boxedRepDataConKey - , eqTyConKey - , listTyConKey - , oneDataConKey - , manyDataConKey - , fUNTyConKey, unrestrictedFunTyConKey ] + use. For example, when we parse a [] in a type and ListTuplePuns + are enabled, we can just insert (Exact listTyConName :: RdrName). + + This is just an optimisation: it would be equally valid to output + Orig RdrNames that correctly record the module (and package) that + we expect the final Name to come from. The name would be looked up + in the OrigNameCache (see point 3). + + 2. The knownKeyNames (which consist of the basicKnownKeyNames from + the module, and those names reachable via the wired-in stuff from + GHC.Builtin.Types) are used to initialise the "OrigNameCache" in + GHC.Iface.Env. This initialization ensures that when the type checker + or renamer (both of which use GHC.Iface.Env) look up an original name + (i.e. a pair of a Module and an OccName) for a known-key name + they get the correct Unique. + + This is the most important mechanism for ensuring that known-key + stuff gets the right Unique, and is why it is so important to + place your known-key names in the appropriate lists. + + 3. For "infinite families" of known-key names (i.e. tuples and sums), we + have to be extra careful. Because there are an infinite number of + these things, we cannot add them to the list of known-key names + used to initialise the OrigNameCache. Instead, lookupOrigNameCache pretends + that these names are in the cache by using isInfiniteFamilyOrigName_maybe + before the actual lookup. + See Note [Infinite families of known-key names] for details. + + +Note [Infinite families of known-key names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Infinite families of known-key things (e.g. tuples and sums) pose a tricky +problem: we can't add them to the knownKeyNames finite map which we use to +ensure that, e.g., a reference to (,) gets assigned the right unique (if this +doesn't sound familiar see Note [Known-key names] above). + +We instead handle tuples and sums separately from the "vanilla" known-key +things, + + a) The parser recognises them specially and generates an Exact Name (hence not + looked up in the orig-name cache) + + b) The known infinite families of names are specially serialised by + GHC.Iface.Binary.putName, with that special treatment detected when we read + back to ensure that we get back to the correct uniques. + See Note [Symbol table representation of names] in GHC.Iface.Binary and + Note [How tuples work] in GHC.Builtin.Types. + + c) GHC.Iface.Env.lookupOrigNameCache uses isInfiniteFamilyOrigName_maybe to + map tuples and sums onto their exact names, rather than trying to find them + in the original-name cache. + See also Note [Built-in syntax and the OrigNameCache] + +-} + +{-# LANGUAGE CPP #-} + +module GHC.Builtin.Names + ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module GHC.Builtin.Names, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all + ) +where + +import GHC.Prelude + +import GHC.Unit.Types +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Types.Unique +import GHC.Builtin.Uniques +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Data.FastString +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import Language.Haskell.Syntax.Module.Name + +{- +************************************************************************ +* * + allNameStrings +* * +************************************************************************ +-} + +allNameStrings :: Infinite String +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = Inf.allListsOf ['a'..'z'] + +allNameStringList :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStringList = Inf.toList allNameStrings + +{- +************************************************************************ +* * +\subsection{Local Names} +* * +************************************************************************ + +This *local* name is used by the interactive stuff +-} + +itName :: Unique -> SrcSpan -> Name +itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: OccName -> Name +mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey + +{- +************************************************************************ +* * +\subsection{Known key Names} +* * +************************************************************************ + +This section tells what the compiler knows about the association of +names with uniques. These ones are the *non* wired-in ones. The +wired in ones are defined in GHC.Builtin.Types etc. +-} + +basicKnownKeyNames :: [Name] -- See Note [Known-key names] +basicKnownKeyNames + = genericTyConNames + ++ [ -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + isStringClassName, + applicativeClassName, + alternativeClassName, + foldableClassName, + traversableClassName, + semigroupClassName, sappendName, + monoidClassName, memptyName, mappendName, mconcatName, + + -- The IO type + ioTyConName, ioDataConName, + runMainIOName, + runRWName, + + -- Type representation types + trModuleTyConName, trModuleDataConName, + trNameTyConName, trNameSDataConName, trNameDDataConName, + trTyConTyConName, trTyConDataConName, + + -- Typeable + typeableClassName, + typeRepTyConName, + someTypeRepTyConName, + someTypeRepDataConName, + kindRepTyConName, + kindRepTyConAppDataConName, + kindRepVarDataConName, + kindRepAppDataConName, + kindRepFunDataConName, + kindRepTYPEDataConName, + kindRepTypeLitSDataConName, + kindRepTypeLitDDataConName, + typeLitSortTyConName, + typeLitSymbolDataConName, + typeLitNatDataConName, + typeLitCharDataConName, + typeRepIdName, + mkTrTypeName, + mkTrConName, + mkTrAppCheckedName, + mkTrFunName, + typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName, + trGhcPrimModuleName, + + -- KindReps for common cases + starKindRepName, + starArrStarKindRepName, + starArrStarArrStarKindRepName, + constraintKindRepName, + + -- WithDict + withDictClassName, + + -- DataToTag + dataToTagClassName, + + -- seq# + seqHashName, + + -- Dynamic + toDynName, + + -- Numeric stuff + negateName, minusName, geName, eqName, + mkRationalBase2Name, mkRationalBase10Name, + + -- Conversion functions + rationalTyConName, + ratioTyConName, ratioDataConName, + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, + + -- Int# stuff + divIntName, modIntName, + + -- String stuff + fromStringName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + + -- Applicative stuff + pureAName, apAName, thenAName, + + -- Functor stuff + fmapName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, + returnMName, joinMName, + + -- MonadFail + monadFailClassName, failMName, + + -- MonadFix + monadFixClassName, mfixName, + + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers + newStablePtrName, + + -- GHC Extensions + considerAccessibleName, + + -- Strings and lists + unpackCStringName, unpackCStringUtf8Name, + unpackCStringAppendName, unpackCStringAppendUtf8Name, + unpackCStringFoldrName, unpackCStringFoldrUtf8Name, + cstringLengthName, + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + + -- Non-empty lists + nonEmptyTyConName, + + -- Overloaded record dot, record update + getFieldName, setFieldName, + + -- List operations + concatName, filterName, mapName, + zipName, foldrName, buildName, augmentName, appendName, + + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + word8TyConName, word16TyConName, word32TyConName, word64TyConName, + jsvalTyConName, + + -- Others + otherwiseIdName, inlineIdName, + eqStringName, assertName, + assertErrorName, traceName, + printName, + dollarName, + + -- ghc-bignum + integerFromNaturalName, + integerToNaturalClampName, + integerToNaturalThrowName, + integerToNaturalName, + integerToWordName, + integerToIntName, + integerToWord64Name, + integerToInt64Name, + integerFromWordName, + integerFromWord64Name, + integerFromInt64Name, + integerAddName, + integerMulName, + integerSubName, + integerNegateName, + integerAbsName, + integerPopCountName, + integerQuotName, + integerRemName, + integerDivName, + integerModName, + integerDivModName, + integerQuotRemName, + integerEncodeFloatName, + integerEncodeDoubleName, + integerGcdName, + integerLcmName, + integerAndName, + integerOrName, + integerXorName, + integerComplementName, + integerBitName, + integerTestBitName, + integerShiftLName, + integerShiftRName, + + naturalToWordName, + naturalPopCountName, + naturalShiftRName, + naturalShiftLName, + naturalAddName, + naturalSubName, + naturalSubThrowName, + naturalSubUnsafeName, + naturalMulName, + naturalQuotRemName, + naturalQuotName, + naturalRemName, + naturalAndName, + naturalAndNotName, + naturalOrName, + naturalXorName, + naturalTestBitName, + naturalBitName, + naturalGcdName, + naturalLcmName, + naturalLog2Name, + naturalLogBaseWordName, + naturalLogBaseName, + naturalPowModName, + naturalSizeInBaseName, + + bignatEqName, + + -- Float/Double + integerToFloatName, + integerToDoubleName, + naturalToFloatName, + naturalToDoubleName, + rationalToFloatName, + rationalToDoubleName, + + -- Other classes + monadPlusClassName, + + -- Type-level naturals + knownNatClassName, knownSymbolClassName, knownCharClassName, + + -- Overloaded labels + fromLabelClassOpName, + + -- Implicit Parameters + ipClassName, + + -- Overloaded record fields + hasFieldClassName, + + -- ExceptionContext + exceptionContextTyConName, + emptyExceptionContextName, + + -- Call Stacks + callStackTyConName, + emptyCallStackName, pushCallStackName, + + -- Source Locations + srcLocDataConName, + + -- Annotation type checking + toAnnotationWrapperName + + -- The SPEC type for SpecConstr + , specTyConName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName + + -- The Void type + , voidTyConName + + -- Plugins + , pluginTyConName + , frontendPluginTyConName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName + + -- StaticPtr + , makeStaticName + , staticPtrTyConName + , staticPtrDataConName, staticPtrInfoDataConName + , fromStaticPtrName + + -- Fingerprint + , fingerprintDataConName + + -- Custom type errors + , errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + + -- "Unsatisfiable" constraint + , unsatisfiableClassName + , unsatisfiableIdName + + -- Unsafe coercion proofs + , unsafeEqualityProofName + , unsafeEqualityTyConName + , unsafeReflDataConName + , unsafeCoercePrimName + + , unsafeUnpackJSStringUtf8ShShName + ] + +genericTyConNames :: [Name] +genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName + ] + +{- +************************************************************************ +* * +\subsection{Module names} +* * +************************************************************************ + + +--MetaHaskell Extension Add a new module here +-} + +gHC_PRIM, gHC_PRIM_PANIC, + gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT, + gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module +gHC_PRIM = mkGhcInternalModule (fsLit "GHC.Internal.Prim") -- Primitive types and values +gHC_PRIM_PANIC = mkGhcInternalModule (fsLit "GHC.Internal.Prim.Panic") +gHC_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Types") +gHC_MAGIC = mkGhcInternalModule (fsLit "GHC.Internal.Magic") +gHC_MAGIC_DICT = mkGhcInternalModule (fsLit "GHC.Internal.Magic.Dict") +gHC_CSTRING = mkGhcInternalModule (fsLit "GHC.Internal.CString") +gHC_CLASSES = mkGhcInternalModule (fsLit "GHC.Internal.Classes") +gHC_PRIMOPWRAPPERS = mkGhcInternalModule (fsLit "GHC.Internal.PrimopWrappers") +gHC_INTERNAL_TUPLE = mkGhcInternalModule (fsLit "GHC.Internal.Tuple") + +gHC_INTERNAL_CONTROL_MONAD_ZIP :: Module +gHC_INTERNAL_CONTROL_MONAD_ZIP = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Zip") + +gHC_INTERNAL_NUM_INTEGER, gHC_INTERNAL_NUM_NATURAL, gHC_INTERNAL_NUM_BIGNAT :: Module +gHC_INTERNAL_NUM_INTEGER = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Integer") +gHC_INTERNAL_NUM_NATURAL = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Natural") +gHC_INTERNAL_NUM_BIGNAT = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.BigNat") + +gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM, + gHC_INTERNAL_GHCI, gHC_INTERNAL_GHCI_HELPERS, gHC_CSTRING, gHC_INTERNAL_DATA_STRING, + gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE, + gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER, + gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE, + gHC_INTERNAL_EXCEPTION_CONTEXT, + gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception, + gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL, + gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC, + gHC_INTERNAL_TYPEABLE, gHC_INTERNAL_TYPEABLE_INTERNAL, gHC_INTERNAL_GENERICS, + gHC_INTERNAL_READ_PREC, gHC_INTERNAL_LEX, gHC_INTERNAL_INT, gHC_INTERNAL_WORD, gHC_INTERNAL_MONAD, gHC_INTERNAL_MONAD_FIX, gHC_INTERNAL_MONAD_FAIL, + gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST, + gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL, + gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL, + gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR, + gHC_INTERNAL_JS_PRIM, gHC_INTERNAL_WASM_PRIM_TYPES :: Module +gHC_INTERNAL_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Base") +gHC_INTERNAL_ENUM = mkGhcInternalModule (fsLit "GHC.Internal.Enum") +gHC_INTERNAL_GHCI = mkGhcInternalModule (fsLit "GHC.Internal.GHCi") +gHC_INTERNAL_GHCI_HELPERS = mkGhcInternalModule (fsLit "GHC.Internal.GHCi.Helpers") +gHC_INTERNAL_SHOW = mkGhcInternalModule (fsLit "GHC.Internal.Show") +gHC_INTERNAL_READ = mkGhcInternalModule (fsLit "GHC.Internal.Read") +gHC_INTERNAL_NUM = mkGhcInternalModule (fsLit "GHC.Internal.Num") +gHC_INTERNAL_MAYBE = mkGhcInternalModule (fsLit "GHC.Internal.Maybe") +gHC_INTERNAL_LIST = mkGhcInternalModule (fsLit "GHC.Internal.List") +gHC_INTERNAL_DATA_EITHER = mkGhcInternalModule (fsLit "GHC.Internal.Data.Either") +gHC_INTERNAL_DATA_STRING = mkGhcInternalModule (fsLit "GHC.Internal.Data.String") +gHC_INTERNAL_DATA_FOLDABLE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Foldable") +gHC_INTERNAL_DATA_TRAVERSABLE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Traversable") +gHC_INTERNAL_CONC = mkGhcInternalModule (fsLit "GHC.Internal.GHC.Conc") +gHC_INTERNAL_IO = mkGhcInternalModule (fsLit "GHC.Internal.IO") +gHC_INTERNAL_IO_Exception = mkGhcInternalModule (fsLit "GHC.Internal.IO.Exception") +gHC_INTERNAL_ST = mkGhcInternalModule (fsLit "GHC.Internal.ST") +gHC_INTERNAL_IX = mkGhcInternalModule (fsLit "GHC.Internal.Ix") +gHC_INTERNAL_STABLE = mkGhcInternalModule (fsLit "GHC.Internal.Stable") +gHC_INTERNAL_PTR = mkGhcInternalModule (fsLit "GHC.Internal.Ptr") +gHC_INTERNAL_ERR = mkGhcInternalModule (fsLit "GHC.Internal.Err") +gHC_INTERNAL_REAL = mkGhcInternalModule (fsLit "GHC.Internal.Real") +gHC_INTERNAL_FLOAT = mkGhcInternalModule (fsLit "GHC.Internal.Float") +gHC_INTERNAL_TOP_HANDLER = mkGhcInternalModule (fsLit "GHC.Internal.TopHandler") +gHC_INTERNAL_SYSTEM_IO = mkGhcInternalModule (fsLit "GHC.Internal.System.IO") +gHC_INTERNAL_DYNAMIC = mkGhcInternalModule (fsLit "GHC.Internal.Data.Dynamic") +gHC_INTERNAL_TYPEABLE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable") +gHC_INTERNAL_TYPEABLE_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable.Internal") +gHC_INTERNAL_DATA_DATA = mkGhcInternalModule (fsLit "GHC.Internal.Data.Data") +gHC_INTERNAL_READ_PREC = mkGhcInternalModule (fsLit "GHC.Internal.Text.ParserCombinators.ReadPrec") +gHC_INTERNAL_LEX = mkGhcInternalModule (fsLit "GHC.Internal.Text.Read.Lex") +gHC_INTERNAL_INT = mkGhcInternalModule (fsLit "GHC.Internal.Int") +gHC_INTERNAL_WORD = mkGhcInternalModule (fsLit "GHC.Internal.Word") +gHC_INTERNAL_MONAD = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad") +gHC_INTERNAL_MONAD_FIX = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fix") +gHC_INTERNAL_MONAD_FAIL = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fail") +gHC_INTERNAL_ARROW = mkGhcInternalModule (fsLit "GHC.Internal.Control.Arrow") +gHC_INTERNAL_DESUGAR = mkGhcInternalModule (fsLit "GHC.Internal.Desugar") +gHC_INTERNAL_RANDOM = mkGhcInternalModule (fsLit "GHC.Internal.System.Random") +gHC_INTERNAL_EXTS = mkGhcInternalModule (fsLit "GHC.Internal.Exts") +gHC_INTERNAL_IS_LIST = mkGhcInternalModule (fsLit "GHC.Internal.IsList") +gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base") +gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context") +gHC_INTERNAL_GENERICS = mkGhcInternalModule (fsLit "GHC.Internal.Generics") +gHC_INTERNAL_TYPEERROR = mkGhcInternalModule (fsLit "GHC.Internal.TypeError") +gHC_INTERNAL_TYPELITS = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits") +gHC_INTERNAL_TYPELITS_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits.Internal") +gHC_INTERNAL_TYPENATS = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats") +gHC_INTERNAL_TYPENATS_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats.Internal") +gHC_INTERNAL_DATA_COERCE = mkGhcInternalModule (fsLit "GHC.Internal.Data.Coerce") +gHC_INTERNAL_DEBUG_TRACE = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace") +gHC_INTERNAL_UNSAFE_COERCE = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce") +gHC_INTERNAL_FOREIGN_C_CONSTPTR = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr") +gHC_INTERNAL_JS_PRIM = mkGhcInternalModule (fsLit "GHC.Internal.JS.Prim") +gHC_INTERNAL_WASM_PRIM_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types") + +gHC_INTERNAL_SRCLOC :: Module +gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc") + +gHC_INTERNAL_STACK, gHC_INTERNAL_STACK_TYPES :: Module +gHC_INTERNAL_STACK = mkGhcInternalModule (fsLit "GHC.Internal.Stack") +gHC_INTERNAL_STACK_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Stack.Types") + +gHC_INTERNAL_STATICPTR :: Module +gHC_INTERNAL_STATICPTR = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr") + +gHC_INTERNAL_STATICPTR_INTERNAL :: Module +gHC_INTERNAL_STATICPTR_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr.Internal") + +gHC_INTERNAL_FINGERPRINT_TYPE :: Module +gHC_INTERNAL_FINGERPRINT_TYPE = mkGhcInternalModule (fsLit "GHC.Internal.Fingerprint.Type") + +gHC_INTERNAL_OVER_LABELS :: Module +gHC_INTERNAL_OVER_LABELS = mkGhcInternalModule (fsLit "GHC.Internal.OverloadedLabels") + +gHC_INTERNAL_RECORDS :: Module +gHC_INTERNAL_RECORDS = mkGhcInternalModule (fsLit "GHC.Internal.Records") + +rOOT_MAIN :: Module +rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation + +mkInteractiveModule :: String -> Module +-- (mkInteractiveMoudule "9") makes module 'interactive:Ghci9' +mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n)) + +pRELUDE_NAME, mAIN_NAME :: ModuleName +pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") +mAIN_NAME = mkModuleNameFS (fsLit "Main") + +mkGhcInternalModule :: FastString -> Module +mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m) + +mkGhcInternalModule_ :: ModuleName -> Module +mkGhcInternalModule_ m = mkModule ghcInternalUnit m + +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcUnit m + +mkMainModule :: FastString -> Module +mkMainModule m = mkModule mainUnit (mkModuleNameFS m) + +mkMainModule_ :: ModuleName -> Module +mkMainModule_ m = mkModule mainUnit m + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +main_RDR_Unqual :: RdrName +main_RDR_Unqual = mkUnqual varName (fsLit "main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + +eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") +lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") +gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") +compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") +ltTag_RDR = nameRdrName ordLTDataConName +eqTag_RDR = nameRdrName ordEQDataConName +gtTag_RDR = nameRdrName ordGTDataConName + +map_RDR, append_RDR :: RdrName +map_RDR = nameRdrName mapName +append_RDR = nameRdrName appendName + +foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR + :: RdrName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +left_RDR, right_RDR :: RdrName +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName + +fromEnum_RDR, toEnum_RDR, toEnumError_RDR, succError_RDR, predError_RDR, enumIntToWord_RDR :: RdrName +fromEnum_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "fromEnum") +toEnum_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnum") +toEnumError_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnumError") +succError_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succError") +predError_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "predError") +enumIntToWord_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "enumIntToWord") + +enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +times_RDR, plus_RDR :: RdrName +times_RDR = varQual_RDR gHC_INTERNAL_NUM (fsLit "*") +plus_RDR = varQual_RDR gHC_INTERNAL_NUM (fsLit "+") + +compose_RDR :: RdrName +compose_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit ".") + +not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, + and_RDR, range_RDR, inRange_RDR, index_RDR, + unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName +and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") +not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") +dataToTag_RDR = varQual_RDR gHC_MAGIC (fsLit "dataToTag#") +succ_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succ") +pred_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "pred") +minBound_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "minBound") +maxBound_RDR = varQual_RDR gHC_INTERNAL_ENUM (fsLit "maxBound") +range_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "range") +inRange_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "inRange") +index_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "index") +unsafeIndex_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeRangeSize") + +readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, + readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName +readList_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readList") +readListDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListDefault") +readListPrec_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrec") +readListPrecDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrecDefault") +readPrec_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readPrec") +parens_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "parens") +choose_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "choose") +lexP_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "lexP") +expectP_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "expectP") + +readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName +readField_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readField") +readFieldHash_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readFieldHash") +readSymField_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readSymField") + +punc_RDR, ident_RDR, symbol_RDR :: RdrName +punc_RDR = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Punc") +ident_RDR = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Ident") +symbol_RDR = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Symbol") + +step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName +step_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "step") +alt_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "+++") +reset_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "reset") +prec_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "prec") +pfail_RDR = varQual_RDR gHC_INTERNAL_READ_PREC (fsLit "pfail") + +showsPrec_RDR, shows_RDR, showString_RDR, + showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName +showsPrec_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showsPrec") +shows_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "shows") +showString_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showString") +showSpace_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showSpace") +showCommaSpace_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showCommaSpace") +showParen_RDR = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showParen") + +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_INTERNAL_ERR (fsLit "error") + +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, + conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR, + uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, + uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, + uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, + uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName + +u1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") + +unPar1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1") (fsLit "unPar1") +unRec1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1") (fsLit "unRec1") +unK1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1") (fsLit "unK1") +unComp1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") (fsLit "unComp1") + +from_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from") +from1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from1") +to_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to") +to1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "moduleName") +packageName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "packageName") +isNewtypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "isNewtype") +selName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conIsRecord") + +prefixDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Infix") +leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName +rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName +notAssocDataCon_RDR = nameRdrName notAssociativeDataConName + +uAddrDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr") +uCharDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar") +uDoubleDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") +uFloatDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat") +uIntDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt") +uWordDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") + +uAddrHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr") (fsLit "uAddr#") +uCharHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar") (fsLit "uChar#") +uDoubleHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") (fsLit "uDouble#") +uFloatHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat") (fsLit "uFloat#") +uIntHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt") (fsLit "uInt#") +uWordHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") (fsLit "uWord#") + +fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, + foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, + mappend_RDR :: RdrName +fmap_RDR = nameRdrName fmapName +replace_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$") +pure_RDR = nameRdrName pureAName +ap_RDR = nameRdrName apAName +liftA2_RDR = varQual_RDR gHC_INTERNAL_BASE (fsLit "liftA2") +foldable_foldr_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "foldr") +foldMap_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "foldMap") +null_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "null") +all_RDR = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE (fsLit "all") +traverse_RDR = varQual_RDR gHC_INTERNAL_DATA_TRAVERSABLE (fsLit "traverse") +mempty_RDR = nameRdrName memptyName +mappend_RDR = nameRdrName mappendName + +---------------------- +varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR + :: Module -> FastString -> RdrName +varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) + +fieldQual_RDR :: Module -> FastString -> FastString -> RdrName +fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str) + +{- +************************************************************************ +* * +\subsection{Known-key names} +* * +************************************************************************ + +Many of these Names are not really "built in", but some parts of the +compiler (notably the deriving mechanism) need to mention their names, +and it's convenient to write them all down in one place. +-} + +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + +runMainIOName, runRWName :: Name +runMainIOName = varQual gHC_INTERNAL_TOP_HANDLER (fsLit "runMainIO") runMainKey +runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey + +orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name +orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey +ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey +ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey +ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey + +specTyConName :: Name +specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey + +eitherTyConName, leftDataConName, rightDataConName :: Name +eitherTyConName = tcQual gHC_INTERNAL_DATA_EITHER (fsLit "Either") eitherTyConKey +leftDataConName = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Left") leftDataConKey +rightDataConName = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Right") rightDataConKey + +voidTyConName :: Name +voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey + +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name + +v1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey +u1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey +par1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey +rec1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey +k1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey +m1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey + +sumTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey +prodTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey +compTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey + +rTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey +dTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey +cTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey +sTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey + +rec0TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey +d1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey + +repTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep") repTyConKey +rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey + +uRecTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey +uAddrTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey +uCharTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey +uDoubleTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey +uFloatTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UFloat") uFloatTyConKey +uIntTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UInt") uIntTyConKey +uWordTyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "UWord") uWordTyConKey + +prefixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +sourceUnpackDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey +sourceNoUnpackDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey +noSourceUnpackednessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey +sourceLazyDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey +sourceStrictDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey +noSourceStrictnessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey +decidedLazyDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey +decidedStrictDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey +decidedUnpackDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey + +metaDataDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel") metaSelDataConKey + +-- Primitive Int +divIntName, modIntName :: Name +divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey +modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey + +-- Base strings Strings +unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, unpackCStringFoldrUtf8Name, + unpackCStringAppendName, unpackCStringAppendUtf8Name, + eqStringName, cstringLengthName :: Name +cstringLengthName = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey +eqStringName = varQual gHC_INTERNAL_BASE (fsLit "eqString") eqStringIdKey + +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey + +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey +unpackCStringFoldrUtf8Name = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey + + +-- The 'inline' function +inlineIdName :: Name +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey + +-- Base classes (Eq, Ord, Functor) +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_INTERNAL_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_INTERNAL_BASE (fsLit "fmap") fmapClassOpKey + +-- Class Monad +monadClassName, thenMName, bindMName, returnMName :: Name +monadClassName = clsQual gHC_INTERNAL_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_INTERNAL_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_INTERNAL_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_INTERNAL_BASE (fsLit "return") returnMClassOpKey + +-- Class MonadFail +monadFailClassName, failMName :: Name +monadFailClassName = clsQual gHC_INTERNAL_MONAD_FAIL (fsLit "MonadFail") monadFailClassKey +failMName = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail") failMClassOpKey + +-- Class Applicative +applicativeClassName, pureAName, apAName, thenAName :: Name +applicativeClassName = clsQual gHC_INTERNAL_BASE (fsLit "Applicative") applicativeClassKey +apAName = varQual gHC_INTERNAL_BASE (fsLit "<*>") apAClassOpKey +pureAName = varQual gHC_INTERNAL_BASE (fsLit "pure") pureAClassOpKey +thenAName = varQual gHC_INTERNAL_BASE (fsLit "*>") thenAClassOpKey + +-- Classes (Foldable, Traversable) +foldableClassName, traversableClassName :: Name +foldableClassName = clsQual gHC_INTERNAL_DATA_FOLDABLE (fsLit "Foldable") foldableClassKey +traversableClassName = clsQual gHC_INTERNAL_DATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey + +-- Classes (Semigroup, Monoid) +semigroupClassName, sappendName :: Name +semigroupClassName = clsQual gHC_INTERNAL_BASE (fsLit "Semigroup") semigroupClassKey +sappendName = varQual gHC_INTERNAL_BASE (fsLit "<>") sappendClassOpKey +monoidClassName, memptyName, mappendName, mconcatName :: Name +monoidClassName = clsQual gHC_INTERNAL_BASE (fsLit "Monoid") monoidClassKey +memptyName = varQual gHC_INTERNAL_BASE (fsLit "mempty") memptyClassOpKey +mappendName = varQual gHC_INTERNAL_BASE (fsLit "mappend") mappendClassOpKey +mconcatName = varQual gHC_INTERNAL_BASE (fsLit "mconcat") mconcatClassOpKey + + + +-- AMP additions + +joinMName, alternativeClassName :: Name +joinMName = varQual gHC_INTERNAL_BASE (fsLit "join") joinMIdKey +alternativeClassName = clsQual gHC_INTERNAL_MONAD (fsLit "Alternative") alternativeClassKey + +-- +joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, + alternativeClassKey :: Unique +joinMIdKey = mkPreludeMiscIdUnique 750 +apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> +pureAClassOpKey = mkPreludeMiscIdUnique 752 +thenAClassOpKey = mkPreludeMiscIdUnique 753 +alternativeClassKey = mkPreludeMiscIdUnique 754 + + +-- Functions for GHC extensions +considerAccessibleName :: Name +considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey + +-- Random GHC.Internal.Base functions +fromStringName, otherwiseIdName, foldrName, buildName, augmentName, + mapName, appendName, assertName, + dollarName :: Name +dollarName = varQual gHC_INTERNAL_BASE (fsLit "$") dollarIdKey +otherwiseIdName = varQual gHC_INTERNAL_BASE (fsLit "otherwise") otherwiseIdKey +foldrName = varQual gHC_INTERNAL_BASE (fsLit "foldr") foldrIdKey +buildName = varQual gHC_INTERNAL_BASE (fsLit "build") buildIdKey +augmentName = varQual gHC_INTERNAL_BASE (fsLit "augment") augmentIdKey +mapName = varQual gHC_INTERNAL_BASE (fsLit "map") mapIdKey +appendName = varQual gHC_INTERNAL_BASE (fsLit "++") appendIdKey +assertName = varQual gHC_INTERNAL_BASE (fsLit "assert") assertIdKey +fromStringName = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey + +-- Module GHC.Internal.Num +numClassName, fromIntegerName, minusName, negateName :: Name +numClassName = clsQual gHC_INTERNAL_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_INTERNAL_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_INTERNAL_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_INTERNAL_NUM (fsLit "negate") negateClassOpKey + +--------------------------------- +-- ghc-bignum +--------------------------------- +integerFromNaturalName + , integerToNaturalClampName + , integerToNaturalThrowName + , integerToNaturalName + , integerToWordName + , integerToIntName + , integerToWord64Name + , integerToInt64Name + , integerFromWordName + , integerFromWord64Name + , integerFromInt64Name + , integerAddName + , integerMulName + , integerSubName + , integerNegateName + , integerAbsName + , integerPopCountName + , integerQuotName + , integerRemName + , integerDivName + , integerModName + , integerDivModName + , integerQuotRemName + , integerEncodeFloatName + , integerEncodeDoubleName + , integerGcdName + , integerLcmName + , integerAndName + , integerOrName + , integerXorName + , integerComplementName + , integerBitName + , integerTestBitName + , integerShiftLName + , integerShiftRName + , naturalToWordName + , naturalPopCountName + , naturalShiftRName + , naturalShiftLName + , naturalAddName + , naturalSubName + , naturalSubThrowName + , naturalSubUnsafeName + , naturalMulName + , naturalQuotRemName + , naturalQuotName + , naturalRemName + , naturalAndName + , naturalAndNotName + , naturalOrName + , naturalXorName + , naturalTestBitName + , naturalBitName + , naturalGcdName + , naturalLcmName + , naturalLog2Name + , naturalLogBaseWordName + , naturalLogBaseName + , naturalPowModName + , naturalSizeInBaseName + , bignatEqName + , bignatCompareName + , bignatCompareWordName + :: Name + +bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name +bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT (fsLit str) key +bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key +bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key + +-- Types and DataCons +bignatEqName = bnbVarQual "bigNatEq#" bignatEqIdKey +bignatCompareName = bnbVarQual "bigNatCompare" bignatCompareIdKey +bignatCompareWordName = bnbVarQual "bigNatCompareWord#" bignatCompareWordIdKey + +naturalToWordName = bnnVarQual "naturalToWord#" naturalToWordIdKey +naturalPopCountName = bnnVarQual "naturalPopCount#" naturalPopCountIdKey +naturalShiftRName = bnnVarQual "naturalShiftR#" naturalShiftRIdKey +naturalShiftLName = bnnVarQual "naturalShiftL#" naturalShiftLIdKey +naturalAddName = bnnVarQual "naturalAdd" naturalAddIdKey +naturalSubName = bnnVarQual "naturalSub" naturalSubIdKey +naturalSubThrowName = bnnVarQual "naturalSubThrow" naturalSubThrowIdKey +naturalSubUnsafeName = bnnVarQual "naturalSubUnsafe" naturalSubUnsafeIdKey +naturalMulName = bnnVarQual "naturalMul" naturalMulIdKey +naturalQuotRemName = bnnVarQual "naturalQuotRem#" naturalQuotRemIdKey +naturalQuotName = bnnVarQual "naturalQuot" naturalQuotIdKey +naturalRemName = bnnVarQual "naturalRem" naturalRemIdKey +naturalAndName = bnnVarQual "naturalAnd" naturalAndIdKey +naturalAndNotName = bnnVarQual "naturalAndNot" naturalAndNotIdKey +naturalOrName = bnnVarQual "naturalOr" naturalOrIdKey +naturalXorName = bnnVarQual "naturalXor" naturalXorIdKey +naturalTestBitName = bnnVarQual "naturalTestBit#" naturalTestBitIdKey +naturalBitName = bnnVarQual "naturalBit#" naturalBitIdKey +naturalGcdName = bnnVarQual "naturalGcd" naturalGcdIdKey +naturalLcmName = bnnVarQual "naturalLcm" naturalLcmIdKey +naturalLog2Name = bnnVarQual "naturalLog2#" naturalLog2IdKey +naturalLogBaseWordName = bnnVarQual "naturalLogBaseWord#" naturalLogBaseWordIdKey +naturalLogBaseName = bnnVarQual "naturalLogBase#" naturalLogBaseIdKey +naturalPowModName = bnnVarQual "naturalPowMod" naturalPowModIdKey +naturalSizeInBaseName = bnnVarQual "naturalSizeInBase#" naturalSizeInBaseIdKey + +integerFromNaturalName = bniVarQual "integerFromNatural" integerFromNaturalIdKey +integerToNaturalClampName = bniVarQual "integerToNaturalClamp" integerToNaturalClampIdKey +integerToNaturalThrowName = bniVarQual "integerToNaturalThrow" integerToNaturalThrowIdKey +integerToNaturalName = bniVarQual "integerToNatural" integerToNaturalIdKey +integerToWordName = bniVarQual "integerToWord#" integerToWordIdKey +integerToIntName = bniVarQual "integerToInt#" integerToIntIdKey +integerToWord64Name = bniVarQual "integerToWord64#" integerToWord64IdKey +integerToInt64Name = bniVarQual "integerToInt64#" integerToInt64IdKey +integerFromWordName = bniVarQual "integerFromWord#" integerFromWordIdKey +integerFromWord64Name = bniVarQual "integerFromWord64#" integerFromWord64IdKey +integerFromInt64Name = bniVarQual "integerFromInt64#" integerFromInt64IdKey +integerAddName = bniVarQual "integerAdd" integerAddIdKey +integerMulName = bniVarQual "integerMul" integerMulIdKey +integerSubName = bniVarQual "integerSub" integerSubIdKey +integerNegateName = bniVarQual "integerNegate" integerNegateIdKey +integerAbsName = bniVarQual "integerAbs" integerAbsIdKey +integerPopCountName = bniVarQual "integerPopCount#" integerPopCountIdKey +integerQuotName = bniVarQual "integerQuot" integerQuotIdKey +integerRemName = bniVarQual "integerRem" integerRemIdKey +integerDivName = bniVarQual "integerDiv" integerDivIdKey +integerModName = bniVarQual "integerMod" integerModIdKey +integerDivModName = bniVarQual "integerDivMod#" integerDivModIdKey +integerQuotRemName = bniVarQual "integerQuotRem#" integerQuotRemIdKey +integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey +integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey +integerGcdName = bniVarQual "integerGcd" integerGcdIdKey +integerLcmName = bniVarQual "integerLcm" integerLcmIdKey +integerAndName = bniVarQual "integerAnd" integerAndIdKey +integerOrName = bniVarQual "integerOr" integerOrIdKey +integerXorName = bniVarQual "integerXor" integerXorIdKey +integerComplementName = bniVarQual "integerComplement" integerComplementIdKey +integerBitName = bniVarQual "integerBit#" integerBitIdKey +integerTestBitName = bniVarQual "integerTestBit#" integerTestBitIdKey +integerShiftLName = bniVarQual "integerShiftL#" integerShiftLIdKey +integerShiftRName = bniVarQual "integerShiftR#" integerShiftRIdKey + + + +--------------------------------- +-- End of ghc-bignum +--------------------------------- + +-- GHC.Internal.Real types and classes +rationalTyConName, ratioTyConName, ratioDataConName, realClassName, + integralClassName, realFracClassName, fractionalClassName, + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name +rationalTyConName = tcQual gHC_INTERNAL_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_INTERNAL_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = dcQual gHC_INTERNAL_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_INTERNAL_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_INTERNAL_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_INTERNAL_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_INTERNAL_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_INTERNAL_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_INTERNAL_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_INTERNAL_REAL (fsLit "realToFrac") realToFracIdKey +mkRationalBase2Name = varQual gHC_INTERNAL_REAL (fsLit "mkRationalBase2") mkRationalBase2IdKey +mkRationalBase10Name = varQual gHC_INTERNAL_REAL (fsLit "mkRationalBase10") mkRationalBase10IdKey + +-- GHC.Internal.Float classes +floatingClassName, realFloatClassName :: Name +floatingClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatClassKey + +-- other GHC.Internal.Float functions +integerToFloatName, integerToDoubleName, + naturalToFloatName, naturalToDoubleName, + rationalToFloatName, rationalToDoubleName :: Name +integerToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey +integerToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey +naturalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey +naturalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey +rationalToFloatName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey +rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey + +-- Class Ix +ixClassName :: Name +ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey + +-- Typeable representation types +trModuleTyConName + , trModuleDataConName + , trNameTyConName + , trNameSDataConName + , trNameDDataConName + , trTyConTyConName + , trTyConDataConName + :: Name +trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey +trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey +trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey +trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey +trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey +trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey +trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey + +kindRepTyConName + , kindRepTyConAppDataConName + , kindRepVarDataConName + , kindRepAppDataConName + , kindRepFunDataConName + , kindRepTYPEDataConName + , kindRepTypeLitSDataConName + , kindRepTypeLitDDataConName + :: Name +kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey +kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey +kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey +kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey +kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey +kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey +kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey +kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey + +typeLitSortTyConName + , typeLitSymbolDataConName + , typeLitNatDataConName + , typeLitCharDataConName + :: Name +typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey +typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey +typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey +typeLitCharDataConName = dcQual gHC_TYPES (fsLit "TypeLitChar") typeLitCharDataConKey + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +typeableClassName + , typeRepTyConName + , someTypeRepTyConName + , someTypeRepDataConName + , mkTrTypeName + , mkTrConName + , mkTrAppCheckedName + , mkTrFunName + , typeRepIdName + , typeNatTypeRepName + , typeSymbolTypeRepName + , typeCharTypeRepName + , trGhcPrimModuleName + :: Name +typeableClassName = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeRepTyConName = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey +someTypeRepTyConName = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey +someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey +typeRepIdName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey +mkTrTypeName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey +mkTrConName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey +mkTrAppCheckedName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey +mkTrFunName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey +typeNatTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey +typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey +typeCharTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey +-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) +-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. +trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey + +-- Typeable KindReps for some common cases +starKindRepName, starArrStarKindRepName, + starArrStarArrStarKindRepName, constraintKindRepName :: Name +starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey +starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey +starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey +constraintKindRepName = varQual gHC_TYPES (fsLit "krep$Constraint") constraintKindRepKey + +-- WithDict +withDictClassName :: Name +withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey + +nonEmptyTyConName :: Name +nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey + +-- DataToTag +dataToTagClassName :: Name +dataToTagClassName = clsQual gHC_MAGIC (fsLit "DataToTag") dataToTagClassKey + +-- seq# +seqHashName :: Name +seqHashName = varQual gHC_INTERNAL_IO (fsLit "seq#") seqHashKey + +-- Custom type errors +errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + :: Name + +errorMessageTypeErrorFamName = + tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey + +typeErrorTextDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey + +typeErrorAppendDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey + +typeErrorVAppendDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey + +typeErrorShowTypeDataConName = + dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey + +-- "Unsatisfiable" constraint +unsatisfiableClassName, unsatisfiableIdName :: Name +unsatisfiableClassName = + clsQual gHC_INTERNAL_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey +unsatisfiableIdName = + varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey + +-- Unsafe coercion proofs +unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName, + unsafeReflDataConName :: Name +unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey +unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey +unsafeReflDataConName = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl") unsafeReflDataConKey +unsafeCoercePrimName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey + +-- Dynamic +toDynName :: Name +toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey + +-- Class Data +dataClassName :: Name +dataClassName = clsQual gHC_INTERNAL_DATA_DATA (fsLit "Data") dataClassKey + +-- Error module +assertErrorName :: Name +assertErrorName = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey + +-- GHC.Internal.Debug.Trace +traceName :: Name +traceName = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey + +-- Enum module (Enum, Bounded) +enumClassName, enumFromName, enumFromToName, enumFromThenName, + enumFromThenToName, boundedClassName :: Name +enumClassName = clsQual gHC_INTERNAL_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_INTERNAL_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_INTERNAL_ENUM (fsLit "Bounded") boundedClassKey + +-- List functions +concatName, filterName, zipName :: Name +concatName = varQual gHC_INTERNAL_LIST (fsLit "concat") concatIdKey +filterName = varQual gHC_INTERNAL_LIST (fsLit "filter") filterIdKey +zipName = varQual gHC_INTERNAL_LIST (fsLit "zip") zipIdKey + +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_INTERNAL_IS_LIST (fsLit "IsList") isListClassKey +fromListName = varQual gHC_INTERNAL_IS_LIST (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_INTERNAL_IS_LIST (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_INTERNAL_IS_LIST (fsLit "toList") toListClassOpKey + +-- HasField class ops +getFieldName, setFieldName :: Name +getFieldName = varQual gHC_INTERNAL_RECORDS (fsLit "getField") getFieldClassOpKey +setFieldName = varQual gHC_INTERNAL_RECORDS (fsLit "setField") setFieldClassOpKey + +-- Class Show +showClassName :: Name +showClassName = clsQual gHC_INTERNAL_SHOW (fsLit "Show") showClassKey + +-- Class Read +readClassName :: Name +readClassName = clsQual gHC_INTERNAL_READ (fsLit "Read") readClassKey + +-- Classes Generic and Generic1, Datatype, Constructor and Selector +genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +genClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic") genClassKey +gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey + +datatypeClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] + +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_INTERNAL_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + +-- IO things +ioTyConName, ioDataConName, + thenIOName, bindIOName, returnIOName, failIOName :: Name +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_INTERNAL_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_INTERNAL_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_INTERNAL_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_INTERNAL_IO (fsLit "failIO") failIOIdKey + +-- IO things +printName :: Name +printName = varQual gHC_INTERNAL_SYSTEM_IO (fsLit "print") printIdKey + +-- Int, Word, and Addr things +int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name +int8TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int8") int8TyConKey +int16TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int16") int16TyConKey +int32TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int32") int32TyConKey +int64TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int64") int64TyConKey + +-- Word module +word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name +word8TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word8") word8TyConKey +word16TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey +word32TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey +word64TyConName = tcQual gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey + +-- PrelPtr module +ptrTyConName, funPtrTyConName :: Name +ptrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey + +-- Foreign objects and weak pointers +stablePtrTyConName, newStablePtrName :: Name +stablePtrTyConName = tcQual gHC_INTERNAL_STABLE (fsLit "StablePtr") stablePtrTyConKey +newStablePtrName = varQual gHC_INTERNAL_STABLE (fsLit "newStablePtr") newStablePtrIdKey + +-- Recursive-do notation +monadFixClassName, mfixName :: Name +monadFixClassName = clsQual gHC_INTERNAL_MONAD_FIX (fsLit "MonadFix") monadFixClassKey +mfixName = varQual gHC_INTERNAL_MONAD_FIX (fsLit "mfix") mfixIdKey + +-- Arrow notation +arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name +arrAName = varQual gHC_INTERNAL_ARROW (fsLit "arr") arrAIdKey +composeAName = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey +firstAName = varQual gHC_INTERNAL_ARROW (fsLit "first") firstAIdKey +appAName = varQual gHC_INTERNAL_ARROW (fsLit "app") appAIdKey +choiceAName = varQual gHC_INTERNAL_ARROW (fsLit "|||") choiceAIdKey +loopAName = varQual gHC_INTERNAL_ARROW (fsLit "loop") loopAIdKey + +-- Monad comprehensions +guardMName, liftMName, mzipName :: Name +guardMName = varQual gHC_INTERNAL_MONAD (fsLit "guard") guardMIdKey +liftMName = varQual gHC_INTERNAL_MONAD (fsLit "liftM") liftMIdKey +mzipName = varQual gHC_INTERNAL_CONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey + + +-- Annotation type checking +toAnnotationWrapperName :: Name +toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey + +-- Other classes, needed for type defaulting +monadPlusClassName, isStringClassName :: Name +monadPlusClassName = clsQual gHC_INTERNAL_MONAD (fsLit "MonadPlus") monadPlusClassKey +isStringClassName = clsQual gHC_INTERNAL_DATA_STRING (fsLit "IsString") isStringClassKey + +-- Type-level naturals +knownNatClassName :: Name +knownNatClassName = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassNameKey +knownSymbolClassName :: Name +knownSymbolClassName = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey +knownCharClassName :: Name +knownCharClassName = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassNameKey + +-- Overloaded labels +fromLabelClassOpName :: Name +fromLabelClassOpName + = varQual gHC_INTERNAL_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey + +-- Implicit Parameters +ipClassName :: Name +ipClassName + = clsQual gHC_CLASSES (fsLit "IP") ipClassKey + +-- Overloaded record fields +hasFieldClassName :: Name +hasFieldClassName + = clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey + +-- ExceptionContext +exceptionContextTyConName, emptyExceptionContextName :: Name +exceptionContextTyConName = + tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey +emptyExceptionContextName + = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey + +-- Source Locations +callStackTyConName, emptyCallStackName, pushCallStackName, + srcLocDataConName :: Name +callStackTyConName + = tcQual gHC_INTERNAL_STACK_TYPES (fsLit "CallStack") callStackTyConKey +emptyCallStackName + = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey +pushCallStackName + = varQual gHC_INTERNAL_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey +srcLocDataConName + = dcQual gHC_INTERNAL_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey + +-- plugins +pLUGINS :: Module +pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins") +pluginTyConName :: Name +pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey +frontendPluginTyConName :: Name +frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey + +-- Static pointers +makeStaticName :: Name +makeStaticName = + varQual gHC_INTERNAL_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey + +staticPtrInfoTyConName :: Name +staticPtrInfoTyConName = + tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey + +staticPtrInfoDataConName :: Name +staticPtrInfoDataConName = + dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey + +staticPtrTyConName :: Name +staticPtrTyConName = + tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey + +staticPtrDataConName :: Name +staticPtrDataConName = + dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey + +fromStaticPtrName :: Name +fromStaticPtrName = + varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey + +fingerprintDataConName :: Name +fingerprintDataConName = + dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey + +constPtrConName :: Name +constPtrConName = + tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey + +jsvalTyConName :: Name +jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey + +unsafeUnpackJSStringUtf8ShShName :: Name +unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey + +{- +************************************************************************ +* * +\subsection{Local helpers} +* * +************************************************************************ + +All these are original names; hence mkOrig +-} + +{-# INLINE varQual #-} +{-# INLINE tcQual #-} +{-# INLINE clsQual #-} +{-# INLINE dcQual #-} +varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name +varQual modu str unique = mk_known_key_name varName modu str unique +tcQual modu str unique = mk_known_key_name tcName modu str unique +clsQual modu str unique = mk_known_key_name clsName modu str unique +dcQual modu str unique = mk_known_key_name dataName modu str unique + +mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name +{-# INLINE mk_known_key_name #-} +mk_known_key_name space modu str unique + = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +* * +************************************************************************ +--MetaHaskell extension hand allocate keys here +-} + +boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, + fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, + functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, + realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 + +typeableClassKey :: Unique +typeableClassKey = mkPreludeClassUnique 20 + +withDictClassKey :: Unique +withDictClassKey = mkPreludeClassUnique 21 + +dataToTagClassKey :: Unique +dataToTagClassKey = mkPreludeClassUnique 23 + +monadFixClassKey :: Unique +monadFixClassKey = mkPreludeClassUnique 28 + +monadFailClassKey :: Unique +monadFailClassKey = mkPreludeClassUnique 29 + +monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 + +isStringClassKey :: Unique +isStringClassKey = mkPreludeClassUnique 33 + +applicativeClassKey, foldableClassKey, traversableClassKey :: Unique +applicativeClassKey = mkPreludeClassUnique 34 +foldableClassKey = mkPreludeClassUnique 35 +traversableClassKey = mkPreludeClassUnique 36 + +genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +genClassKey = mkPreludeClassUnique 37 +gen1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 + +-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class +knownNatClassNameKey :: Unique +knownNatClassNameKey = mkPreludeClassUnique 42 + +-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class +knownSymbolClassNameKey :: Unique +knownSymbolClassNameKey = mkPreludeClassUnique 43 + +knownCharClassNameKey :: Unique +knownCharClassNameKey = mkPreludeClassUnique 44 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 45 + +semigroupClassKey, monoidClassKey :: Unique +semigroupClassKey = mkPreludeClassUnique 47 +monoidClassKey = mkPreludeClassUnique 48 + +-- Implicit Parameters +ipClassKey :: Unique +ipClassKey = mkPreludeClassUnique 49 + +-- Overloaded record fields +hasFieldClassNameKey :: Unique +hasFieldClassNameKey = mkPreludeClassUnique 50 + + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES ClassUniques 200-299 +----------------------------------------------------- + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +* * +************************************************************************ +-} + +addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, + byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey, + intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, + int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, + int64PrimTyConKey, int64TyConKey, + integerTyConKey, naturalTyConKey, + listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, + weakPrimTyConKey, mutableArrayPrimTyConKey, + mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, + ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, + stablePtrTyConKey, eqTyConKey, heqTyConKey, + smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, + stringTyConKey, + ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique +addrPrimTyConKey = mkPreludeTyConUnique 1 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +stringTyConKey = mkPreludeTyConUnique 6 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +fUNTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8PrimTyConKey = mkPreludeTyConUnique 16 +int8TyConKey = mkPreludeTyConUnique 17 +int16PrimTyConKey = mkPreludeTyConUnique 18 +int16TyConKey = mkPreludeTyConUnique 19 +int32PrimTyConKey = mkPreludeTyConUnique 20 +int32TyConKey = mkPreludeTyConUnique 21 +int64PrimTyConKey = mkPreludeTyConUnique 22 +int64TyConKey = mkPreludeTyConUnique 23 +integerTyConKey = mkPreludeTyConUnique 24 +naturalTyConKey = mkPreludeTyConUnique 25 + +listTyConKey = mkPreludeTyConUnique 26 +foreignObjPrimTyConKey = mkPreludeTyConUnique 27 +maybeTyConKey = mkPreludeTyConUnique 28 +weakPrimTyConKey = mkPreludeTyConUnique 29 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 +orderingTyConKey = mkPreludeTyConUnique 32 +mVarPrimTyConKey = mkPreludeTyConUnique 33 +-- ioPortPrimTyConKey (34) was killed +ratioTyConKey = mkPreludeTyConUnique 35 +rationalTyConKey = mkPreludeTyConUnique 36 +realWorldTyConKey = mkPreludeTyConUnique 37 +stablePtrPrimTyConKey = mkPreludeTyConUnique 38 +stablePtrTyConKey = mkPreludeTyConUnique 39 +eqTyConKey = mkPreludeTyConUnique 40 +heqTyConKey = mkPreludeTyConUnique 41 + +ctArrowTyConKey = mkPreludeTyConUnique 42 +ccArrowTyConKey = mkPreludeTyConUnique 43 +tcArrowTyConKey = mkPreludeTyConUnique 44 + +statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, + mutVarPrimTyConKey, ioTyConKey, + wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, + word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, + word64PrimTyConKey, word64TyConKey, + kindConKey, boxityConKey, + typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, + eqReprPrimTyConKey, eqPhantPrimTyConKey, + compactPrimTyConKey, stackSnapshotPrimTyConKey, + promptTagPrimTyConKey, constPtrTyConKey, jsvalTyConKey :: Unique +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPrimTyConKey = mkPreludeTyConUnique 53 +eqReprPrimTyConKey = mkPreludeTyConUnique 54 +eqPhantPrimTyConKey = mkPreludeTyConUnique 55 +mutVarPrimTyConKey = mkPreludeTyConUnique 56 +ioTyConKey = mkPreludeTyConUnique 57 +wordPrimTyConKey = mkPreludeTyConUnique 59 +wordTyConKey = mkPreludeTyConUnique 60 +word8PrimTyConKey = mkPreludeTyConUnique 61 +word8TyConKey = mkPreludeTyConUnique 62 +word16PrimTyConKey = mkPreludeTyConUnique 63 +word16TyConKey = mkPreludeTyConUnique 64 +word32PrimTyConKey = mkPreludeTyConUnique 65 +word32TyConKey = mkPreludeTyConUnique 66 +word64PrimTyConKey = mkPreludeTyConUnique 67 +word64TyConKey = mkPreludeTyConUnique 68 +kindConKey = mkPreludeTyConUnique 72 +boxityConKey = mkPreludeTyConUnique 73 +typeConKey = mkPreludeTyConUnique 74 +threadIdPrimTyConKey = mkPreludeTyConUnique 75 +bcoPrimTyConKey = mkPreludeTyConUnique 76 +ptrTyConKey = mkPreludeTyConUnique 77 +funPtrTyConKey = mkPreludeTyConUnique 78 +tVarPrimTyConKey = mkPreludeTyConUnique 79 +compactPrimTyConKey = mkPreludeTyConUnique 80 +stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81 +promptTagPrimTyConKey = mkPreludeTyConUnique 82 + +eitherTyConKey :: Unique +eitherTyConKey = mkPreludeTyConUnique 84 + +voidTyConKey :: Unique +voidTyConKey = mkPreludeTyConUnique 85 + +nonEmptyTyConKey :: Unique +nonEmptyTyConKey = mkPreludeTyConUnique 86 + +dictTyConKey :: Unique +dictTyConKey = mkPreludeTyConUnique 87 + +-- Kind constructors +liftedTypeKindTyConKey, unliftedTypeKindTyConKey, + tYPETyConKey, cONSTRAINTTyConKey, + liftedRepTyConKey, unliftedRepTyConKey, + constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, + vecCountTyConKey, vecElemTyConKey, + zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique +liftedTypeKindTyConKey = mkPreludeTyConUnique 88 +unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 +tYPETyConKey = mkPreludeTyConUnique 91 +cONSTRAINTTyConKey = mkPreludeTyConUnique 92 +constraintKindTyConKey = mkPreludeTyConUnique 93 +levityTyConKey = mkPreludeTyConUnique 94 +runtimeRepTyConKey = mkPreludeTyConUnique 95 +vecCountTyConKey = mkPreludeTyConUnique 96 +vecElemTyConKey = mkPreludeTyConUnique 97 +liftedRepTyConKey = mkPreludeTyConUnique 98 +unliftedRepTyConKey = mkPreludeTyConUnique 99 +zeroBitRepTyConKey = mkPreludeTyConUnique 100 +zeroBitTypeTyConKey = mkPreludeTyConUnique 101 + +pluginTyConKey, frontendPluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 +frontendPluginTyConKey = mkPreludeTyConUnique 103 + +trTyConTyConKey, trModuleTyConKey, trNameTyConKey, + kindRepTyConKey, typeLitSortTyConKey :: Unique +trTyConTyConKey = mkPreludeTyConUnique 104 +trModuleTyConKey = mkPreludeTyConUnique 105 +trNameTyConKey = mkPreludeTyConUnique 106 +kindRepTyConKey = mkPreludeTyConUnique 107 +typeLitSortTyConKey = mkPreludeTyConUnique 108 + +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, + repTyConKey, rep1TyConKey, uRecTyConKey, + uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, + uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 + +repTyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + +uRecTyConKey = mkPreludeTyConUnique 157 +uAddrTyConKey = mkPreludeTyConUnique 158 +uCharTyConKey = mkPreludeTyConUnique 159 +uDoubleTyConKey = mkPreludeTyConUnique 160 +uFloatTyConKey = mkPreludeTyConUnique 161 +uIntTyConKey = mkPreludeTyConUnique 162 +uWordTyConKey = mkPreludeTyConUnique 163 + +-- "Unsatisfiable" constraint +unsatisfiableClassNameKey :: Unique +unsatisfiableClassNameKey = mkPreludeTyConUnique 170 + +anyTyConKey :: Unique +anyTyConKey = mkPreludeTyConUnique 171 + +zonkAnyTyConKey :: Unique +zonkAnyTyConKey = mkPreludeTyConUnique 172 + +-- Custom user type-errors +errorMessageTypeErrorFamKey :: Unique +errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181 + +coercibleTyConKey :: Unique +coercibleTyConKey = mkPreludeTyConUnique 183 + +proxyPrimTyConKey :: Unique +proxyPrimTyConKey = mkPreludeTyConUnique 184 + +specTyConKey :: Unique +specTyConKey = mkPreludeTyConUnique 185 + +smallArrayPrimTyConKey = mkPreludeTyConUnique 187 +smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 + +staticPtrTyConKey :: Unique +staticPtrTyConKey = mkPreludeTyConUnique 189 + +staticPtrInfoTyConKey :: Unique +staticPtrInfoTyConKey = mkPreludeTyConUnique 190 + +callStackTyConKey :: Unique +callStackTyConKey = mkPreludeTyConUnique 191 + +-- Typeables +typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique +typeRepTyConKey = mkPreludeTyConUnique 192 +someTypeRepTyConKey = mkPreludeTyConUnique 193 +someTypeRepDataConKey = mkPreludeTyConUnique 194 + + +typeSymbolAppendFamNameKey :: Unique +typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195 + +-- Unsafe equality +unsafeEqualityTyConKey :: Unique +unsafeEqualityTyConKey = mkPreludeTyConUnique 196 + +-- Linear types +multiplicityTyConKey :: Unique +multiplicityTyConKey = mkPreludeTyConUnique 197 + +unrestrictedFunTyConKey :: Unique +unrestrictedFunTyConKey = mkPreludeTyConUnique 198 + +multMulTyConKey :: Unique +multMulTyConKey = mkPreludeTyConUnique 199 + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES TyConUniques 200-299 +----------------------------------------------------- + +----------------------- SIMD ------------------------ +-- USES TyConUniques 300-399 +----------------------------------------------------- + +#include "primop-vector-uniques.hs-incl" + +------------- Type-level Symbol, Nat, Char ---------- +-- USES TyConUniques 400-499 +----------------------------------------------------- +typeSymbolKindConNameKey, typeCharKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, + typeNatSubTyFamNameKey + , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey + , typeLeqCharTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey + , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey + , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey + :: Unique +typeSymbolKindConNameKey = mkPreludeTyConUnique 400 +typeCharKindConNameKey = mkPreludeTyConUnique 401 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 402 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 403 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 404 +typeNatSubTyFamNameKey = mkPreludeTyConUnique 405 +typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406 +typeNatCmpTyFamNameKey = mkPreludeTyConUnique 407 +typeCharCmpTyFamNameKey = mkPreludeTyConUnique 408 +typeLeqCharTyFamNameKey = mkPreludeTyConUnique 409 +typeNatDivTyFamNameKey = mkPreludeTyConUnique 410 +typeNatModTyFamNameKey = mkPreludeTyConUnique 411 +typeNatLogTyFamNameKey = mkPreludeTyConUnique 412 +typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413 +typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 +typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 +typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 +constPtrTyConKey = mkPreludeTyConUnique 417 + +jsvalTyConKey = mkPreludeTyConUnique 418 + +exceptionContextTyConKey = mkPreludeTyConUnique 420 + +unsafeUnpackJSStringUtf8ShShKey = mkPreludeMiscIdUnique 805 + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +* * +************************************************************************ +-} + +charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, + floatDataConKey, intDataConKey, nilDataConKey, + ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, + word8DataConKey, ioDataConKey, heqDataConKey, + eqDataConKey, nothingDataConKey, justDataConKey :: Unique + +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +nothingDataConKey = mkPreludeDataConUnique 7 +justDataConKey = mkPreludeDataConUnique 8 +eqDataConKey = mkPreludeDataConUnique 9 +nilDataConKey = mkPreludeDataConUnique 10 +ratioDataConKey = mkPreludeDataConUnique 11 +word8DataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 13 +trueDataConKey = mkPreludeDataConUnique 14 +wordDataConKey = mkPreludeDataConUnique 15 +ioDataConKey = mkPreludeDataConUnique 16 +heqDataConKey = mkPreludeDataConUnique 18 + +-- Generic data constructors +crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 + +leftDataConKey, rightDataConKey :: Unique +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 + +ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique +ordLTDataConKey = mkPreludeDataConUnique 27 +ordEQDataConKey = mkPreludeDataConUnique 28 +ordGTDataConKey = mkPreludeDataConUnique 29 + +mkDictDataConKey :: Unique +mkDictDataConKey = mkPreludeDataConUnique 30 + +coercibleDataConKey :: Unique +coercibleDataConKey = mkPreludeDataConUnique 32 + +staticPtrDataConKey :: Unique +staticPtrDataConKey = mkPreludeDataConUnique 33 + +staticPtrInfoDataConKey :: Unique +staticPtrInfoDataConKey = mkPreludeDataConUnique 34 + +fingerprintDataConKey :: Unique +fingerprintDataConKey = mkPreludeDataConUnique 35 + +srcLocDataConKey :: Unique +srcLocDataConKey = mkPreludeDataConUnique 37 + +trTyConDataConKey, trModuleDataConKey, + trNameSDataConKey, trNameDDataConKey, + trGhcPrimModuleKey :: Unique +trTyConDataConKey = mkPreludeDataConUnique 41 +trModuleDataConKey = mkPreludeDataConUnique 43 +trNameSDataConKey = mkPreludeDataConUnique 45 +trNameDDataConKey = mkPreludeDataConUnique 46 +trGhcPrimModuleKey = mkPreludeDataConUnique 47 + +typeErrorTextDataConKey, + typeErrorAppendDataConKey, + typeErrorVAppendDataConKey, + typeErrorShowTypeDataConKey + :: Unique +typeErrorTextDataConKey = mkPreludeDataConUnique 50 +typeErrorAppendDataConKey = mkPreludeDataConUnique 51 +typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 +typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 + +prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + sourceUnpackDataConKey, sourceNoUnpackDataConKey, + noSourceUnpackednessDataConKey, sourceLazyDataConKey, + sourceStrictDataConKey, noSourceStrictnessDataConKey, + decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, + metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique +prefixIDataConKey = mkPreludeDataConUnique 54 +infixIDataConKey = mkPreludeDataConUnique 55 +leftAssociativeDataConKey = mkPreludeDataConUnique 56 +rightAssociativeDataConKey = mkPreludeDataConUnique 57 +notAssociativeDataConKey = mkPreludeDataConUnique 58 +sourceUnpackDataConKey = mkPreludeDataConUnique 59 +sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 +noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 +sourceLazyDataConKey = mkPreludeDataConUnique 62 +sourceStrictDataConKey = mkPreludeDataConUnique 63 +noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 +decidedLazyDataConKey = mkPreludeDataConUnique 65 +decidedStrictDataConKey = mkPreludeDataConUnique 66 +decidedUnpackDataConKey = mkPreludeDataConUnique 67 +metaDataDataConKey = mkPreludeDataConUnique 68 +metaConsDataConKey = mkPreludeDataConUnique 69 +metaSelDataConKey = mkPreludeDataConUnique 70 + +vecRepDataConKey, sumRepDataConKey, + tupleRepDataConKey, boxedRepDataConKey :: Unique +vecRepDataConKey = mkPreludeDataConUnique 71 +tupleRepDataConKey = mkPreludeDataConUnique 72 +sumRepDataConKey = mkPreludeDataConUnique 73 +boxedRepDataConKey = mkPreludeDataConUnique 74 + +boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique +-- A promoted data constructors (i.e. a TyCon) has +-- the same key as the data constructor itself +boxedRepDataConTyConKey = boxedRepDataConKey +tupleRepDataConTyConKey = tupleRepDataConKey + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- Includes all nullary-data-constructor reps. Does not +-- include BoxedRep, VecRep, SumRep, TupleRep. +runtimeRepSimpleDataConKeys :: [Unique] +runtimeRepSimpleDataConKeys + = map mkPreludeDataConUnique [75..87] + +liftedDataConKey,unliftedDataConKey :: Unique +liftedDataConKey = mkPreludeDataConUnique 88 +unliftedDataConKey = mkPreludeDataConUnique 89 + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- VecCount +vecCountDataConKeys :: [Unique] +vecCountDataConKeys = map mkPreludeDataConUnique [90..95] + +-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types +-- VecElem +vecElemDataConKeys :: [Unique] +vecElemDataConKeys = map mkPreludeDataConUnique [96..105] + +-- Typeable things +kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, + kindRepFunDataConKey, kindRepTYPEDataConKey, + kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey + :: Unique +kindRepTyConAppDataConKey = mkPreludeDataConUnique 106 +kindRepVarDataConKey = mkPreludeDataConUnique 107 +kindRepAppDataConKey = mkPreludeDataConUnique 108 +kindRepFunDataConKey = mkPreludeDataConUnique 109 +kindRepTYPEDataConKey = mkPreludeDataConUnique 110 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112 + +typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique +typeLitSymbolDataConKey = mkPreludeDataConUnique 113 +typeLitNatDataConKey = mkPreludeDataConUnique 114 +typeLitCharDataConKey = mkPreludeDataConUnique 115 + +-- Unsafe equality +unsafeReflDataConKey :: Unique +unsafeReflDataConKey = mkPreludeDataConUnique 116 + +-- Multiplicity + +oneDataConKey, manyDataConKey :: Unique +oneDataConKey = mkPreludeDataConUnique 117 +manyDataConKey = mkPreludeDataConUnique 118 + +-- ghc-bignum +integerISDataConKey, integerINDataConKey, integerIPDataConKey, + naturalNSDataConKey, naturalNBDataConKey :: Unique +integerISDataConKey = mkPreludeDataConUnique 120 +integerINDataConKey = mkPreludeDataConUnique 121 +integerIPDataConKey = mkPreludeDataConUnique 122 +naturalNSDataConKey = mkPreludeDataConUnique 123 +naturalNBDataConKey = mkPreludeDataConUnique 124 + + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES DataUniques 200-250 +----------------------------------------------------- + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +* * +************************************************************************ +-} + +wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey, + buildIdKey, foldrIdKey, recSelErrorIdKey, + seqIdKey, eqStringIdKey, + noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, + impossibleErrorIdKey, impossibleConstraintErrorIdKey, + patErrorIdKey, voidPrimIdKey, + realWorldPrimIdKey, recConErrorIdKey, + unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, + unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, + typeErrorIdKey, divIntIdKey, modIntIdKey, + absentSumFieldErrorIdKey, cstringLengthIdKey + :: Unique + +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] +absentErrorIdKey = mkPreludeMiscIdUnique 1 +absentConstraintErrorIdKey = mkPreludeMiscIdUnique 2 +augmentIdKey = mkPreludeMiscIdUnique 3 +appendIdKey = mkPreludeMiscIdUnique 4 +buildIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +impossibleErrorIdKey = mkPreludeMiscIdUnique 13 +impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14 +patErrorIdKey = mkPreludeMiscIdUnique 15 +realWorldPrimIdKey = mkPreludeMiscIdUnique 16 +recConErrorIdKey = mkPreludeMiscIdUnique 17 + +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 18 +unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 19 +unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 20 + +unpackCStringIdKey = mkPreludeMiscIdUnique 21 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 22 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 23 + +voidPrimIdKey = mkPreludeMiscIdUnique 24 +typeErrorIdKey = mkPreludeMiscIdUnique 25 +divIntIdKey = mkPreludeMiscIdUnique 26 +modIntIdKey = mkPreludeMiscIdUnique 27 +cstringLengthIdKey = mkPreludeMiscIdUnique 28 + +concatIdKey, filterIdKey, zipIdKey, + bindIOIdKey, returnIOIdKey, newStablePtrIdKey, + printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, + otherwiseIdKey, assertIdKey :: Unique +concatIdKey = mkPreludeMiscIdUnique 31 +filterIdKey = mkPreludeMiscIdUnique 32 +zipIdKey = mkPreludeMiscIdUnique 33 +bindIOIdKey = mkPreludeMiscIdUnique 34 +returnIOIdKey = mkPreludeMiscIdUnique 35 +newStablePtrIdKey = mkPreludeMiscIdUnique 36 +printIdKey = mkPreludeMiscIdUnique 37 +failIOIdKey = mkPreludeMiscIdUnique 38 +nullAddrIdKey = mkPreludeMiscIdUnique 39 +voidArgIdKey = mkPreludeMiscIdUnique 40 +otherwiseIdKey = mkPreludeMiscIdUnique 43 +assertIdKey = mkPreludeMiscIdUnique 44 + +leftSectionKey, rightSectionKey :: Unique +leftSectionKey = mkPreludeMiscIdUnique 45 +rightSectionKey = mkPreludeMiscIdUnique 46 + +rootMainKey, runMainKey :: Unique +rootMainKey = mkPreludeMiscIdUnique 101 +runMainKey = mkPreludeMiscIdUnique 102 + +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: Unique +thenIOIdKey = mkPreludeMiscIdUnique 103 +lazyIdKey = mkPreludeMiscIdUnique 104 +assertErrorIdKey = mkPreludeMiscIdUnique 105 +oneShotKey = mkPreludeMiscIdUnique 106 +runRWKey = mkPreludeMiscIdUnique 107 + +traceKey :: Unique +traceKey = mkPreludeMiscIdUnique 108 + +nospecIdKey :: Unique +nospecIdKey = mkPreludeMiscIdUnique 109 + +inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique +inlineIdKey = mkPreludeMiscIdUnique 120 +-- see below + +mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique +mapIdKey = mkPreludeMiscIdUnique 121 +dollarIdKey = mkPreludeMiscIdUnique 123 +coercionTokenIdKey = mkPreludeMiscIdUnique 124 +considerAccessibleIdKey = mkPreludeMiscIdUnique 125 +noinlineIdKey = mkPreludeMiscIdUnique 126 +noinlineConstraintIdKey = mkPreludeMiscIdUnique 127 + +integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique +integerToFloatIdKey = mkPreludeMiscIdUnique 128 +integerToDoubleIdKey = mkPreludeMiscIdUnique 129 +naturalToFloatIdKey = mkPreludeMiscIdUnique 130 +naturalToDoubleIdKey = mkPreludeMiscIdUnique 131 + +rationalToFloatIdKey, rationalToDoubleIdKey :: Unique +rationalToFloatIdKey = mkPreludeMiscIdUnique 132 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 133 + +seqHashKey = mkPreludeMiscIdUnique 134 + +coerceKey :: Unique +coerceKey = mkPreludeMiscIdUnique 157 + +{- +Certain class operations from Prelude classes. They get their own +uniques so we can look them up easily when we want to conjure them up +during type checking. +-} + +-- Just a placeholder for unbound variables produced by the renamer: +unboundKey :: Unique +unboundKey = mkPreludeMiscIdUnique 158 + +fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, + enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, + enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, + bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey + :: Unique +fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 +minusClassOpKey = mkPreludeMiscIdUnique 161 +fromRationalClassOpKey = mkPreludeMiscIdUnique 162 +enumFromClassOpKey = mkPreludeMiscIdUnique 163 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 +enumFromToClassOpKey = mkPreludeMiscIdUnique 165 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 +eqClassOpKey = mkPreludeMiscIdUnique 167 +geClassOpKey = mkPreludeMiscIdUnique 168 +negateClassOpKey = mkPreludeMiscIdUnique 169 +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 173 +returnMClassOpKey = mkPreludeMiscIdUnique 174 + +-- Recursive do notation +mfixIdKey :: Unique +mfixIdKey = mkPreludeMiscIdUnique 175 + +-- MonadFail operations +failMClassOpKey :: Unique +failMClassOpKey = mkPreludeMiscIdUnique 176 + +-- fromLabel +fromLabelClassOpKey :: Unique +fromLabelClassOpKey = mkPreludeMiscIdUnique 177 + +-- Arrow notation +arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, + loopAIdKey :: Unique +arrAIdKey = mkPreludeMiscIdUnique 180 +composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 182 +appAIdKey = mkPreludeMiscIdUnique 183 +choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 185 + +fromStringClassOpKey :: Unique +fromStringClassOpKey = mkPreludeMiscIdUnique 186 + +-- Annotation type checking +toAnnotationWrapperIdKey :: Unique +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 + +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 190 +realToFracIdKey = mkPreludeMiscIdUnique 191 +toIntegerClassOpKey = mkPreludeMiscIdUnique 192 +toRationalClassOpKey = mkPreludeMiscIdUnique 193 + +-- Monad comprehensions +guardMIdKey, liftMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 194 +liftMIdKey = mkPreludeMiscIdUnique 195 +mzipIdKey = mkPreludeMiscIdUnique 196 + +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 + +proxyHashKey :: Unique +proxyHashKey = mkPreludeMiscIdUnique 502 + +---------------- Template Haskell ------------------- +-- GHC.Builtin.Names.TH: USES IdUniques 200-499 +----------------------------------------------------- + +-- Used to make `Typeable` dictionaries +mkTyConKey + , mkTrTypeKey + , mkTrConKey + , mkTrAppCheckedKey + , mkTrFunKey + , typeNatTypeRepKey + , typeSymbolTypeRepKey + , typeCharTypeRepKey + , typeRepIdKey + :: Unique +mkTyConKey = mkPreludeMiscIdUnique 503 +mkTrTypeKey = mkPreludeMiscIdUnique 504 +mkTrConKey = mkPreludeMiscIdUnique 505 +mkTrAppCheckedKey = mkPreludeMiscIdUnique 506 +typeNatTypeRepKey = mkPreludeMiscIdUnique 507 +typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 +typeCharTypeRepKey = mkPreludeMiscIdUnique 509 +typeRepIdKey = mkPreludeMiscIdUnique 510 +mkTrFunKey = mkPreludeMiscIdUnique 511 + +-- KindReps for common cases +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 +constraintKindRepKey = mkPreludeMiscIdUnique 523 + +-- Dynamic +toDynIdKey :: Unique +toDynIdKey = mkPreludeMiscIdUnique 530 + + +heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique +eqSCSelIdKey = mkPreludeMiscIdUnique 551 +heqSCSelIdKey = mkPreludeMiscIdUnique 552 +coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 + +sappendClassOpKey :: Unique +sappendClassOpKey = mkPreludeMiscIdUnique 554 + +memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique +memptyClassOpKey = mkPreludeMiscIdUnique 555 +mappendClassOpKey = mkPreludeMiscIdUnique 556 +mconcatClassOpKey = mkPreludeMiscIdUnique 557 + +emptyCallStackKey, pushCallStackKey :: Unique +emptyCallStackKey = mkPreludeMiscIdUnique 558 +pushCallStackKey = mkPreludeMiscIdUnique 559 + +fromStaticPtrClassOpKey :: Unique +fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 + +makeStaticKey :: Unique +makeStaticKey = mkPreludeMiscIdUnique 561 + +emptyExceptionContextKey :: Unique +emptyExceptionContextKey = mkPreludeMiscIdUnique 562 + +-- Unsafe coercion proofs +unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique +unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 +unsafeCoercePrimIdKey = mkPreludeMiscIdUnique 571 + +-- HasField class ops +getFieldClassOpKey, setFieldClassOpKey :: Unique +getFieldClassOpKey = mkPreludeMiscIdUnique 572 +setFieldClassOpKey = mkPreludeMiscIdUnique 573 + +-- "Unsatisfiable" constraints +unsatisfiableIdNameKey :: Unique +unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580 + +------------------------------------------------------ +-- ghc-bignum uses 600-699 uniques +------------------------------------------------------ + +integerFromNaturalIdKey + , integerToNaturalClampIdKey + , integerToNaturalThrowIdKey + , integerToNaturalIdKey + , integerToWordIdKey + , integerToIntIdKey + , integerToWord64IdKey + , integerToInt64IdKey + , integerAddIdKey + , integerMulIdKey + , integerSubIdKey + , integerNegateIdKey + , integerAbsIdKey + , integerPopCountIdKey + , integerQuotIdKey + , integerRemIdKey + , integerDivIdKey + , integerModIdKey + , integerDivModIdKey + , integerQuotRemIdKey + , integerEncodeFloatIdKey + , integerEncodeDoubleIdKey + , integerGcdIdKey + , integerLcmIdKey + , integerAndIdKey + , integerOrIdKey + , integerXorIdKey + , integerComplementIdKey + , integerBitIdKey + , integerTestBitIdKey + , integerShiftLIdKey + , integerShiftRIdKey + , integerFromWordIdKey + , integerFromWord64IdKey + , integerFromInt64IdKey + , naturalToWordIdKey + , naturalPopCountIdKey + , naturalShiftRIdKey + , naturalShiftLIdKey + , naturalAddIdKey + , naturalSubIdKey + , naturalSubThrowIdKey + , naturalSubUnsafeIdKey + , naturalMulIdKey + , naturalQuotRemIdKey + , naturalQuotIdKey + , naturalRemIdKey + , naturalAndIdKey + , naturalAndNotIdKey + , naturalOrIdKey + , naturalXorIdKey + , naturalTestBitIdKey + , naturalBitIdKey + , naturalGcdIdKey + , naturalLcmIdKey + , naturalLog2IdKey + , naturalLogBaseWordIdKey + , naturalLogBaseIdKey + , naturalPowModIdKey + , naturalSizeInBaseIdKey + , bignatEqIdKey + , bignatCompareIdKey + , bignatCompareWordIdKey + :: Unique + +integerFromNaturalIdKey = mkPreludeMiscIdUnique 600 +integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601 +integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602 +integerToNaturalIdKey = mkPreludeMiscIdUnique 603 +integerToWordIdKey = mkPreludeMiscIdUnique 604 +integerToIntIdKey = mkPreludeMiscIdUnique 605 +integerToWord64IdKey = mkPreludeMiscIdUnique 606 +integerToInt64IdKey = mkPreludeMiscIdUnique 607 +integerAddIdKey = mkPreludeMiscIdUnique 608 +integerMulIdKey = mkPreludeMiscIdUnique 609 +integerSubIdKey = mkPreludeMiscIdUnique 610 +integerNegateIdKey = mkPreludeMiscIdUnique 611 +integerAbsIdKey = mkPreludeMiscIdUnique 618 +integerPopCountIdKey = mkPreludeMiscIdUnique 621 +integerQuotIdKey = mkPreludeMiscIdUnique 622 +integerRemIdKey = mkPreludeMiscIdUnique 623 +integerDivIdKey = mkPreludeMiscIdUnique 624 +integerModIdKey = mkPreludeMiscIdUnique 625 +integerDivModIdKey = mkPreludeMiscIdUnique 626 +integerQuotRemIdKey = mkPreludeMiscIdUnique 627 +integerEncodeFloatIdKey = mkPreludeMiscIdUnique 630 +integerEncodeDoubleIdKey = mkPreludeMiscIdUnique 631 +integerGcdIdKey = mkPreludeMiscIdUnique 632 +integerLcmIdKey = mkPreludeMiscIdUnique 633 +integerAndIdKey = mkPreludeMiscIdUnique 634 +integerOrIdKey = mkPreludeMiscIdUnique 635 +integerXorIdKey = mkPreludeMiscIdUnique 636 +integerComplementIdKey = mkPreludeMiscIdUnique 637 +integerBitIdKey = mkPreludeMiscIdUnique 638 +integerTestBitIdKey = mkPreludeMiscIdUnique 639 +integerShiftLIdKey = mkPreludeMiscIdUnique 640 +integerShiftRIdKey = mkPreludeMiscIdUnique 641 +integerFromWordIdKey = mkPreludeMiscIdUnique 642 +integerFromWord64IdKey = mkPreludeMiscIdUnique 643 +integerFromInt64IdKey = mkPreludeMiscIdUnique 644 + +naturalToWordIdKey = mkPreludeMiscIdUnique 650 +naturalPopCountIdKey = mkPreludeMiscIdUnique 659 +naturalShiftRIdKey = mkPreludeMiscIdUnique 660 +naturalShiftLIdKey = mkPreludeMiscIdUnique 661 +naturalAddIdKey = mkPreludeMiscIdUnique 662 +naturalSubIdKey = mkPreludeMiscIdUnique 663 +naturalSubThrowIdKey = mkPreludeMiscIdUnique 664 +naturalSubUnsafeIdKey = mkPreludeMiscIdUnique 665 +naturalMulIdKey = mkPreludeMiscIdUnique 666 +naturalQuotRemIdKey = mkPreludeMiscIdUnique 669 +naturalQuotIdKey = mkPreludeMiscIdUnique 670 +naturalRemIdKey = mkPreludeMiscIdUnique 671 +naturalAndIdKey = mkPreludeMiscIdUnique 672 +naturalAndNotIdKey = mkPreludeMiscIdUnique 673 +naturalOrIdKey = mkPreludeMiscIdUnique 674 +naturalXorIdKey = mkPreludeMiscIdUnique 675 +naturalTestBitIdKey = mkPreludeMiscIdUnique 676 +naturalBitIdKey = mkPreludeMiscIdUnique 677 +naturalGcdIdKey = mkPreludeMiscIdUnique 678 +naturalLcmIdKey = mkPreludeMiscIdUnique 679 +naturalLog2IdKey = mkPreludeMiscIdUnique 680 +naturalLogBaseWordIdKey = mkPreludeMiscIdUnique 681 +naturalLogBaseIdKey = mkPreludeMiscIdUnique 682 +naturalPowModIdKey = mkPreludeMiscIdUnique 683 +naturalSizeInBaseIdKey = mkPreludeMiscIdUnique 684 + +bignatEqIdKey = mkPreludeMiscIdUnique 691 +bignatCompareIdKey = mkPreludeMiscIdUnique 692 +bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 + + +------------------------------------------------------ +-- ghci optimization for big rationals 700-749 uniques +------------------------------------------------------ + +-- Creating rationals at runtime. +mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique +mkRationalBase2IdKey = mkPreludeMiscIdUnique 700 +mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique + +{- +************************************************************************ +* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +* * +************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. +-} + +numericClassKeys :: [Unique] +numericClassKeys = + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys :: [Unique] +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys :: [Unique] +standardClassKeys = derivableClassKeys ++ numericClassKeys + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey, monadFailClassKey, + semigroupClassKey, monoidClassKey, + isStringClassKey, + applicativeClassKey, foldableClassKey, + traversableClassKey, alternativeClassKey + ] + +{- +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@GHC.Tc.Deriv@). +-} + +derivableClassKeys :: [Unique] +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] + + +-- These are the "interactive classes" that are consulted when doing +-- defaulting. Does not include Num or IsString, which have special +-- handling. +interactiveClassNames :: [Name] +interactiveClassNames + = [ showClassName, eqClassName, ordClassName, foldableClassName + , traversableClassName ] + +interactiveClassKeys :: [Unique] +interactiveClassKeys = map getUnique interactiveClassNames diff --git a/GHC/Builtin/Names/TH.hs b/GHC/Builtin/Names/TH.hs --- a/GHC/Builtin/Names/TH.hs +++ b/GHC/Builtin/Names/TH.hs @@ -47,6 +47,7 @@ litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, tildePName, bangPName, infixPName, asPName, wildPName, recPName, listPName, sigPName, viewPName, + typePName, invisPName, orPName, -- FieldPat fieldPatName, -- Match @@ -61,6 +62,7 @@ fromEName, fromThenEName, fromToEName, fromThenToEName, listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, labelEName, implicitParamVarEName, getFieldEName, projectionEName, + typeEName, forallEName, forallVisEName, constrainedEName, -- FieldExp fieldExpName, -- Body @@ -73,11 +75,14 @@ funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, instanceWithOverlapDName, standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, - pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, - pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName, + pragInlDName, pragOpaqueDName, + pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName, + pragSpecInstDName, + pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName, + defaultSigDName, defaultDName, dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName, dataInstDName, newtypeInstDName, tySynInstDName, - infixLDName, infixRDName, infixNDName, + infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName, patSynSigDName, implicitParamBindDName, -- Cxt @@ -138,6 +143,9 @@ -- Overlap overlappableDataConName, overlappingDataConName, overlapsDataConName, incoherentDataConName, + -- NamespaceSpecifier + noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName, + dataNamespaceSpecifierDataConName, -- DerivStrategy stockStrategyName, anyclassStrategyName, newtypeStrategyName, viaStrategyName, @@ -156,7 +164,8 @@ liftClassName, quoteClassName, -- And the tycons - qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName, + qTyConName, nameTyConName, patTyConName, + fieldPatTyConName, matchTyConName, expQTyConName, fieldExpTyConName, predTyConName, stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, @@ -170,23 +179,25 @@ modNameTyConName, -- Quasiquoting - quoteDecName, quoteTypeName, quoteExpName, quotePatName] + quasiQuoterTyConName, 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 @@ -196,7 +207,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 @@ -205,7 +216,7 @@ fieldPatTyConName, expTyConName, decTyConName, typeTyConName, matchTyConName, clauseTyConName, funDepTyConName, predTyConName, codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName, - modNameTyConName :: Name + modNameTyConName, quasiQuoterTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey @@ -223,6 +234,7 @@ injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey modNameTyConName = thTc (fsLit "ModName") modNameTyConKey +quasiQuoterTyConName = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName, @@ -232,8 +244,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 @@ -246,7 +256,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 ----------------------- @@ -268,7 +280,7 @@ -- data Pat = ... litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, - sigPName, viewPName :: Name + sigPName, viewPName, typePName, invisPName, orPName :: Name litPName = libFun (fsLit "litP") litPIdKey varPName = libFun (fsLit "varP") varPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey @@ -284,6 +296,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 -- type FieldPat = ... fieldPatName :: Name @@ -302,7 +317,8 @@ sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName, - labelEName, implicitParamVarEName, getFieldEName, projectionEName :: 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 @@ -343,6 +359,10 @@ implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey getFieldEName = libFun (fsLit "getFieldE") getFieldEIdKey projectionEName = libFun (fsLit "projectionE") projectionEIdKey +typeEName = libFun (fsLit "typeE") typeEIdKey +forallEName = libFun (fsLit "forallE") forallEIdKey +forallVisEName = libFun (fsLit "forallVisE") forallVisEIdKey +constrainedEName = libFun (fsLit "constrainedE") constrainedEIdKey -- type FieldExp = ... fieldExpName :: Name @@ -369,12 +389,14 @@ -- data Dec = ... funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, - pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, - pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName, + pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName, + pragSpecInstDName, pragRuleDName, + pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName, + standaloneDerivWithStrategyDName, defaultSigDName, defaultDName, dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName, - openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName, - infixNDName, roleAnnotDName, patSynDName, patSynSigDName, - pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name + openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName, + infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName, + patSynSigDName, pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -393,19 +415,23 @@ pragOpaqueDName = libFun (fsLit "pragOpaqueD") pragOpaqueDIdKey pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey +pragSpecEDName = libFun (fsLit "pragSpecED") pragSpecEDIdKey +pragSpecInlEDName = libFun (fsLit "pragSpecInlED") pragSpecInlEDIdKey pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey pragCompleteDName = libFun (fsLit "pragCompleteD") pragCompleteDIdKey pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey +pragSCCFunDName = libFun (fsLit "pragSCCFunD") pragSCCFunDKey +pragSCCFunNamedDName = libFun (fsLit "pragSCCFunNamedD") pragSCCFunNamedDKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey openTypeFamilyDName = libFun (fsLit "openTypeFamilyD") openTypeFamilyDIdKey closedTypeFamilyDName = libFun (fsLit "closedTypeFamilyD") closedTypeFamilyDIdKey dataFamilyDName = libFun (fsLit "dataFamilyD") dataFamilyDIdKey -infixLDName = libFun (fsLit "infixLD") infixLDIdKey -infixRDName = libFun (fsLit "infixRD") infixRDIdKey -infixNDName = libFun (fsLit "infixND") infixNDIdKey +infixLWithSpecDName = libFun (fsLit "infixLWithSpecD") infixLWithSpecDIdKey +infixRWithSpecDName = libFun (fsLit "infixRWithSpecD") infixRWithSpecDIdKey +infixNWithSpecDName = libFun (fsLit "infixNWithSpecD") infixNWithSpecDIdKey roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey patSynDName = libFun (fsLit "patSynD") patSynDIdKey patSynSigDName = libFun (fsLit "patSynSigD") patSynSigDIdKey @@ -647,6 +673,17 @@ overlapsDataConName = thCon (fsLit "Overlaps") overlapsDataConKey incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey +-- data NamespaceSpecifier = ... +noNamespaceSpecifierDataConName, + typeNamespaceSpecifierDataConName, + dataNamespaceSpecifierDataConName :: Name +noNamespaceSpecifierDataConName = + thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey +typeNamespaceSpecifierDataConName = + thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey +dataNamespaceSpecifierDataConName = + thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey + {- ********************************************************************* * * Class keys @@ -681,7 +718,7 @@ predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey, overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey, - modNameTyConKey :: Unique + modNameTyConKey, quasiQuoterTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 matchTyConKey = mkPreludeTyConUnique 201 clauseTyConKey = mkPreludeTyConUnique 202 @@ -717,6 +754,7 @@ codeTyConKey = mkPreludeTyConUnique 238 modNameTyConKey = mkPreludeTyConUnique 239 tyVarBndrVisTyConKey = mkPreludeTyConUnique 240 +quasiQuoterTyConKey = mkPreludeTyConUnique 241 {- ********************************************************************* * * @@ -754,6 +792,13 @@ overlapsDataConKey = mkPreludeDataConUnique 211 incoherentDataConKey = mkPreludeDataConUnique 212 +-- data NamespaceSpecifier = ... +noNamespaceSpecifierDataConKey, + typeNamespaceSpecifierDataConKey, + dataNamespaceSpecifierDataConKey :: Unique +noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213 +typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214 +dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215 {- ********************************************************************* * * Id keys @@ -808,7 +853,7 @@ -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, - listPIdKey, sigPIdKey, viewPIdKey :: Unique + listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique litPIdKey = mkPreludeMiscIdUnique 240 varPIdKey = mkPreludeMiscIdUnique 241 tupPIdKey = mkPreludeMiscIdUnique 242 @@ -824,6 +869,9 @@ listPIdKey = mkPreludeMiscIdUnique 252 sigPIdKey = mkPreludeMiscIdUnique 253 viewPIdKey = mkPreludeMiscIdUnique 254 +typePIdKey = mkPreludeMiscIdUnique 255 +invisPIdKey = mkPreludeMiscIdUnique 256 +orPIdKey = mkPreludeMiscIdUnique 257 -- type FieldPat = ... fieldPatIdKey :: Unique @@ -846,7 +894,8 @@ fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey, unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey, - getFieldEIdKey, projectionEIdKey :: Unique + getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey, + forallVisEIdKey, constrainedEIdKey :: Unique varEIdKey = mkPreludeMiscIdUnique 270 conEIdKey = mkPreludeMiscIdUnique 271 litEIdKey = mkPreludeMiscIdUnique 272 @@ -883,28 +932,32 @@ mdoEIdKey = mkPreludeMiscIdUnique 303 getFieldEIdKey = mkPreludeMiscIdUnique 304 projectionEIdKey = mkPreludeMiscIdUnique 305 +typeEIdKey = mkPreludeMiscIdUnique 306 +forallEIdKey = mkPreludeMiscIdUnique 802 +forallVisEIdKey = mkPreludeMiscIdUnique 803 +constrainedEIdKey = mkPreludeMiscIdUnique 804 -- type FieldExp = ... fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 306 +fieldExpIdKey = mkPreludeMiscIdUnique 307 -- data Body = ... guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 307 -normalBIdKey = mkPreludeMiscIdUnique 308 +guardedBIdKey = mkPreludeMiscIdUnique 308 +normalBIdKey = mkPreludeMiscIdUnique 309 -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 309 -patGEIdKey = mkPreludeMiscIdUnique 310 +normalGEIdKey = mkPreludeMiscIdUnique 310 +patGEIdKey = mkPreludeMiscIdUnique 311 -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 311 -letSIdKey = mkPreludeMiscIdUnique 312 -noBindSIdKey = mkPreludeMiscIdUnique 313 -parSIdKey = mkPreludeMiscIdUnique 314 -recSIdKey = mkPreludeMiscIdUnique 315 +bindSIdKey = mkPreludeMiscIdUnique 312 +letSIdKey = mkPreludeMiscIdUnique 313 +noBindSIdKey = mkPreludeMiscIdUnique 314 +parSIdKey = mkPreludeMiscIdUnique 315 +recSIdKey = mkPreludeMiscIdUnique 316 -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, @@ -913,9 +966,11 @@ pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey, openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, - infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, - patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique + infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey, + roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey, + implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, + typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey, + pragSpecEDIdKey, pragSpecInlEDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 320 valDIdKey = mkPreludeMiscIdUnique 321 dataDIdKey = mkPreludeMiscIdUnique 322 @@ -938,9 +993,9 @@ newtypeInstDIdKey = mkPreludeMiscIdUnique 339 tySynInstDIdKey = mkPreludeMiscIdUnique 340 closedTypeFamilyDIdKey = mkPreludeMiscIdUnique 341 -infixLDIdKey = mkPreludeMiscIdUnique 342 -infixRDIdKey = mkPreludeMiscIdUnique 343 -infixNDIdKey = mkPreludeMiscIdUnique 344 +infixLWithSpecDIdKey = mkPreludeMiscIdUnique 342 +infixRWithSpecDIdKey = mkPreludeMiscIdUnique 343 +infixNWithSpecDIdKey = mkPreludeMiscIdUnique 344 roleAnnotDIdKey = mkPreludeMiscIdUnique 345 standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 defaultSigDIdKey = mkPreludeMiscIdUnique 347 @@ -952,6 +1007,10 @@ defaultDIdKey = mkPreludeMiscIdUnique 353 pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 typeDataDIdKey = mkPreludeMiscIdUnique 355 +pragSCCFunDKey = mkPreludeMiscIdUnique 356 +pragSCCFunNamedDKey = mkPreludeMiscIdUnique 357 +pragSpecEDIdKey = mkPreludeMiscIdUnique 358 +pragSpecInlEDIdKey = mkPreludeMiscIdUnique 359 -- type Cxt = ... cxtIdKey :: Unique @@ -1147,29 +1206,7 @@ ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, mkNameG_fldRDR, - unsafeCodeCoerce_RDR :: RdrName +lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName lift_RDR = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName -mkNameG_dRDR = nameRdrName mkNameG_dName -mkNameG_vRDR = nameRdrName mkNameG_vName -mkNameG_fldRDR = nameRdrName mkNameG_fldName - --- data Exp = ... -conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName -conE_RDR = nameRdrName conEName -litE_RDR = nameRdrName litEName -appE_RDR = nameRdrName appEName -infixApp_RDR = nameRdrName infixAppName - --- data Lit = ... -stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR, - doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName -stringL_RDR = nameRdrName stringLName -intPrimL_RDR = nameRdrName intPrimLName -wordPrimL_RDR = nameRdrName wordPrimLName -floatPrimL_RDR = nameRdrName floatPrimLName -doublePrimL_RDR = nameRdrName doublePrimLName -stringPrimL_RDR = nameRdrName stringPrimLName -charPrimL_RDR = nameRdrName charPrimLName diff --git a/GHC/Builtin/PrimOps.hs b/GHC/Builtin/PrimOps.hs --- a/GHC/Builtin/PrimOps.hs +++ b/GHC/Builtin/PrimOps.hs @@ -17,10 +17,12 @@ tagToEnumKey, primOpOutOfLine, primOpCodeSize, - primOpOkForSpeculation, primOpOkForSideEffects, - primOpIsCheap, primOpFixity, primOpDocs, + primOpOkForSpeculation, primOpOkToDiscard, + primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs, primOpDeprecations, primOpIsDiv, primOpIsReallyInline, + PrimOpEffect(..), primOpEffect, + getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), PrimCall(..) @@ -33,7 +35,7 @@ import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) -import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) +import GHC.Core.TyCon ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) ) import GHC.Core.Type import GHC.Cmm.Type @@ -42,17 +44,17 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name -import GHC.Types.RepType ( tyConPrimRep1 ) +import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) -import GHC.Types.SourceText ( SourceText(..) ) -import GHC.Types.Unique ( Unique) +import GHC.Types.Unique ( Unique ) import GHC.Unit.Types ( Unit ) import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Data.FastString @@ -160,12 +162,15 @@ * * ************************************************************************ -See Note [GHC.Prim Docs] +See Note [GHC.Prim Docs] in GHC.Builtin.Utils -} -primOpDocs :: [(String, String)] +primOpDocs :: [(FastString, String)] #include "primop-docs.hs-incl" +primOpDeprecations :: [(OccName, FastString)] +#include "primop-deprecations.hs-incl" + {- ************************************************************************ * * @@ -311,221 +316,316 @@ * * ************************************************************************ -Note [Checking versus non-checking primops] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - In GHC primops break down into two classes: +Note [Exceptions: asynchronous, synchronous, and unchecked] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are three very different sorts of things in GHC-Haskell that are +sometimes called exceptions: - a. Checking primops behave, for instance, like division. In this - case the primop may throw an exception (e.g. division-by-zero) - and is consequently is marked with the can_fail flag described below. - The ability to fail comes at the expense of precluding some optimizations. +* Haskell exceptions: - b. Non-checking primops behavior, for instance, like addition. While - addition can overflow it does not produce an exception. So can_fail is - set to False, and we get more optimisation opportunities. But we must - never throw an exception, so we cannot rewrite to a call to error. + These are ordinary exceptions that users can raise with the likes + of 'throw' and handle with the likes of 'catch'. They come in two + very different flavors: - It is important that a non-checking primop never be transformed in a way that - would cause it to bottom. Doing so would violate Core's let-can-float invariant - (see Note [Core let-can-float invariant] in GHC.Core) which is critical to - the simplifier's ability to float without fear of changing program meaning. + * Asynchronous exceptions: + * These can arise at nearly any time, and may have nothing to do + with the code being executed. + * The compiler itself mostly doesn't need to care about them. + * Examples: a signal from another process, running out of heap or stack + * Even pure code can receive asynchronous exceptions; in this + case, executing the same code again may lead to different + results, because the exception may not happen next time. + * See rts/RaiseAsync.c for the gory details of how they work. + * Synchronous exceptions: + * These are produced by the code being executed, most commonly via + a call to the `raise#` or `raiseIO#` primops. + * At run-time, if a piece of pure code raises a synchronous + exception, it will always raise the same synchronous exception + if it is run again (and not interrupted by an asynchronous + exception). + * In particular, if an updatable thunk does some work and then + raises a synchronous exception, it is safe to overwrite it with + a thunk that /immediately/ raises the same exception. + * Although we are careful not to discard synchronous exceptions, we + are very liberal about re-ordering them with respect to most other + operations. See the paper "A semantics for imprecise exceptions" + as well as Note [Precise exceptions and strictness analysis] in + GHC.Types.Demand. -Note [PrimOp can_fail and has_side_effects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both can_fail and has_side_effects mean that the primop has -some effect that is not captured entirely by its result value. +* Unchecked exceptions: ----------- has_side_effects --------------------- -A primop "has_side_effects" if it has some side effect, visible -elsewhere, apart from the result it returns - - reading or writing to the world (I/O) - - reading or writing to a mutable data structure (writeIORef) - - throwing a synchronous Haskell exception + * These are nasty failures like seg-faults or primitive Int# division + by zero. They differ from Haskell exceptions in that they are + un-recoverable and typically bring execution to an immediate halt. + * We generally treat unchecked exceptions as undefined behavior, on + the assumption that the programmer never intends to crash the + program in this way. Thus we have no qualms about replacing a + division-by-zero with a recoverable Haskell exception or + discarding an indexArray# operation whose result is unused. -Often such primops have a type like - State -> input -> (State, output) -so the state token guarantees ordering. In general we rely on -data dependencies of the state token to enforce write-effect ordering, -but as the notes below make clear, the matter is a bit more complicated -than that. - * NB1: if you inline unsafePerformIO, you may end up with - side-effecting ops whose 'state' output is discarded. - And programmers may do that by hand; see #9390. - That is why we (conservatively) do not discard write-effecting - primops even if both their state and result is discarded. +Note [Classifying primop effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each primop has an associated 'PrimOpEffect', based on what that +primop can or cannot do at runtime. This classification is - * NB2: We consider primops, such as raiseIO#, that can raise a - (Haskell) synchronous exception to "have_side_effects" but not - "can_fail". We must be careful about not discarding such things; - see the paper "A semantics for imprecise exceptions". +* Recorded in the 'effect' field in primops.txt.pp, and +* Exposed to the compiler via the 'primOpEffect' function in this module. - * NB3: *Read* effects on *mutable* cells (like reading an IORef or a - MutableArray#) /are/ included. You may find this surprising because it - doesn't matter if we don't do them, or do them more than once. *Sequencing* - is maintained by the data dependency of the state token. But see - "Duplication" below under - Note [Transformations affected by can_fail and has_side_effects] +See Note [Transformations affected by primop effects] for how we make +use of this categorisation. - Note that read operations on *immutable* values (like indexArray#) do not - have has_side_effects. (They might be marked can_fail, however, because - you might index out of bounds.) +The meanings of the four constructors of 'PrimOpEffect' are as +follows, in decreasing order of permissiveness: - Using has_side_effects in this way is a bit of a blunt instrument. We could - be more refined by splitting read and write effects (see comments with #3207 - and #20195) +* ReadWriteEffect + A primop is marked ReadWriteEffect if it can + - read or write to the world (I/O), or + - read or write to a mutable data structure (e.g. readMutVar#). ----------- can_fail ---------------------------- -A primop "can_fail" if it can fail with an *unchecked* exception on -some elements of its input domain. Main examples: - division (fails on zero denominator) - array indexing (fails if the index is out of bounds) + Every such primop uses State# tokens for sequencing, with a type like: + Inputs -> State# s -> (# State# s, Outputs #) + The state token threading expresses ordering, but duplicating even + a read-only effect would defeat this. (See "duplication" under + Note [Transformations affected by primop effects] for details.) -An "unchecked exception" is one that is an outright error, (not -turned into a Haskell exception,) such as seg-fault or -divide-by-zero error. Such can_fail primops are ALWAYS surrounded -with a test that checks for the bad cases, but we need to be -very careful about code motion that might move it out of -the scope of the test. + Note that operations like `indexArray#` that read *immutable* + data structures do not need such special sequencing-related care, + and are therefore not marked ReadWriteEffect. -Note [Transformations affected by can_fail and has_side_effects] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The can_fail and has_side_effects properties have the following effect -on program transformations. Summary table is followed by details. +* ThrowsException + A primop is marked ThrowsException if + - it is not marked ReadWriteEffect, and + - it may diverge or throw a synchronous Haskell exception + even when used in a "correct" and well-specified way. - can_fail has_side_effects -Discard YES NO -Float in YES YES -Float out NO NO -Duplicate YES NO + See also Note [Exceptions: asynchronous, synchronous, and unchecked]. + Examples include raise#, raiseIO#, dataToTagLarge#, and seq#. -* Discarding. case (a `op` b) of _ -> rhs ===> rhs - You should not discard a has_side_effects primop; e.g. - case (writeIntArray# a i v s of (# _, _ #) -> True - Arguably you should be able to discard this, since the - returned stat token is not used, but that relies on NEVER - inlining unsafePerformIO, and programmers sometimes write - this kind of stuff by hand (#9390). So we (conservatively) - never discard a has_side_effects primop. + Note that whether an exception is considered precise or imprecise + does not matter for the purposes of the PrimOpEffect flag. - However, it's fine to discard a can_fail primop. For example - case (indexIntArray# a i) of _ -> True - We can discard indexIntArray#; it has can_fail, but not - has_side_effects; see #5658 which was all about this. - Notice that indexIntArray# is (in a more general handling of - effects) read effect, but we don't care about that here, and - treat read effects as *not* has_side_effects. +* CanFail + A primop is marked CanFail if + - it is not marked ReadWriteEffect or ThrowsException, and + - it can trigger a (potentially-unchecked) exception when used incorrectly. - Similarly (a `/#` b) can be discarded. It can seg-fault or - cause a hardware exception, but not a synchronous Haskell - exception. + See Note [Exceptions: asynchronous, synchronous, and unchecked]. + Examples include quotWord# and indexIntArray#, which can fail with + division-by-zero and a segfault respectively. + A correct use of a CanFail primop is usually surrounded by a test + that screens out the bad cases such as a zero divisor or an + out-of-bounds array index. We must take care never to move a + CanFail primop outside the scope of such a test. +* NoEffect + A primop is marked NoEffect if it does not belong to any of the + other three categories. We can very aggressively shuffle these + operations around without fear of changing a program's meaning. - Synchronous Haskell exceptions, e.g. from raiseIO#, are treated - as has_side_effects and hence are not discarded. + Perhaps surprisingly, this aggressive shuffling imposes another + restriction: The tricky NoEffect primop uncheckedShiftLWord32# has + an undefined result when the provided shift amount is not between + 0 and 31. Thus, a call like `uncheckedShiftLWord32# x 95#` is + obviously invalid. But since uncheckedShiftLWord32# is marked + NoEffect, we may float such an invalid call out of a dead branch + and speculatively evaluate it. -* Float in. You can float a can_fail or has_side_effects primop - *inwards*, but not inside a lambda (see Duplication below). + In particular, we cannot safely rewrite such an invalid call to a + runtime error; we must emit code that produces a valid Word32#. + (If we're lucky, Core Lint may complain that the result of such a + rewrite violates the let-can-float invariant (#16742), but the + rewrite is always wrong!) See also Note [Guarding against silly shifts] + in GHC.Core.Opt.ConstantFold. -* Float out. You must not float a can_fail primop *outwards* lest - you escape the dynamic scope of the test. Example: + Marking uncheckedShiftLWord32# as CanFail instead of NoEffect + would give us the freedom to rewrite such invalid calls to runtime + errors, but would get in the way of optimization: When speculatively + executing a bit-shift prevents the allocation of a thunk, that's a + big win. + + +Note [Transformations affected by primop effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The PrimOpEffect properties have the following effect on program +transformations. The summary table is followed by details. See also +Note [Classifying primop effects] for exactly what each column means. + + NoEffect CanFail ThrowsException ReadWriteEffect +Discard YES YES NO NO +Defer (float in) YES YES SAFE SAFE +Speculate (float out) YES NO NO NO +Duplicate YES YES YES NO + +(SAFE means we could perform the transformation but do not.) + +* Discarding: case (a `op` b) of _ -> rhs ===> rhs + You should not discard a ReadWriteEffect primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + One could argue in favor of discarding this, since the returned + State# token is not used. But in practice unsafePerformIO can + easily produce similar code, and programmers sometimes write this + kind of stuff by hand (#9390). So we (conservatively) never discard + a ReadWriteEffect primop. + + Digression: We could try to track read-only effects separately + from write effects to allow the former to be discarded. But in + fact we want a more general rewrite for read-only operations: + case readOp# state# of (# newState#, _unused_result #) -> body + ==> case state# of newState# -> body + Such a rewrite is not yet implemented, but would have to be done + in a different place anyway. + + Discarding a ThrowsException primop would also discard any exception + it might have thrown. For `raise#` or `raiseIO#` this would defeat + the whole point of the primop, while for `dataToTagLarge#` or `seq#` + this would make programs unexpectly lazier. + + However, it's fine to discard a CanFail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray# here; this came up in #5658. Notice + that CanFail primops like indexIntArray# can only trigger an + exception when used incorrectly, i.e. a call that might not succeed + is undefined behavior anyway. + +* Deferring (float-in): + See Note [Floating primops] in GHC.Core.Opt.FloatIn. + + In the absence of data dependencies (including state token threading), + we reserve the right to re-order the following things arbitrarily: + * Side effects + * Imprecise exceptions + * Divergent computations (infinite loops) + This lets us safely float almost any primop *inwards*, but not + inside a (multi-shot) lambda. (See "Duplication" below.) + + However, the main reason to float-in a primop application would be + to discard it (by floating it into some but not all branches of a + case), so we actually only float-in NoEffect and CanFail operations. + See also Note [Floating primops] in GHC.Core.Opt.FloatIn. + + (This automatically side-steps the question of precise exceptions, which + mustn't be re-ordered arbitrarily but need at least ThrowsException.) + +* Speculation (strict float-out): + You must not float a CanFail primop *outwards* lest it escape the + dynamic scope of a run-time validity test. Example: case d ># 0# of True -> case x /# d of r -> r +# 1 False -> 0 - Here we must not float the case outwards to give + Here we must not float the case outwards to give case x/# d of r -> case d ># 0# of True -> r +# 1 False -> 0 + Otherwise, if this block is reached when d is zero, it will crash. + Exactly the same reasoning applies to ThrowsException primops. - Nor can you float out a has_side_effects primop. For example: + Nor can you float out a ReadWriteEffect primop. For example: if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 else s0 - Notice that s0 is mentioned in both branches of the 'if', but - only one of these two will actually be consumed. But if we - float out to + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to case writeMutVar# v True s0 of (# s1 #) -> if blah then s1 else s0 - the writeMutVar will be performed in both branches, which is - utterly wrong. + the writeMutVar will be performed in both branches, which is + utterly wrong. -* Duplication. You cannot duplicate a has_side_effect primop. You - might wonder how this can occur given the state token threading, but - just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get - something like this + What about a read-only operation that cannot fail, like + readMutVar#? In principle we could safely float these out. But + there are not very many such operations and it's not clear if + there are real-world programs that would benefit from this. + +* Duplication: + You cannot duplicate a ReadWriteEffect primop. You might wonder + how this can occur given the state token threading, but just look + at Control.Monad.ST.Lazy.Imp.strictToLazy! We get something like this p = case readMutVar# s v of (# s', r #) -> (State# s', r) s' = case p of (s', r) -> s' r = case p of (s', r) -> r - (All these bindings are boxed.) If we inline p at its two call - sites, we get a catastrophe: because the read is performed once when - s' is demanded, and once when 'r' is demanded, which may be much - later. Utterly wrong. #3207 is real example of this happening. + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. #3207 is real example of this happening. + Floating p into a multi-shot lambda would be wrong for the same reason. - However, it's fine to duplicate a can_fail primop. That is really - the only difference between can_fail and has_side_effects. + However, it's fine to duplicate a CanFail or ThrowsException primop. -Note [Implementation: how can_fail/has_side_effects affect transformations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +Note [Implementation: how PrimOpEffect affects transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How do we ensure that floating/duplication/discarding are done right in the simplifier? -Two main predicates on primops test these flags: - primOpOkForSideEffects <=> not has_side_effects - primOpOkForSpeculation <=> not (has_side_effects || can_fail) +Several predicates on primops test this flag: + primOpOkToDiscard <=> effect < ThrowsException + primOpOkForSpeculation <=> effect == NoEffect && not (out_of_line) + primOpIsCheap <=> cheap -- ...defaults to primOpOkForSpeculation + [[But note that the raise# family and seq# are also considered cheap in + GHC.Core.Utils.exprIsCheap by way of being work-free]] + * The discarding mentioned above happens in + GHC.Core.Opt.Simplify.Iteration, specifically in rebuildCase, + where it is guarded by exprOkToDiscard, which in turn checks + primOpOkToDiscard. + * The "no-float-out" thing is achieved by ensuring that we never - let-bind a can_fail or has_side_effects primop. The RHS of a - let-binding (which can float in and out freely) satisfies - exprOkForSpeculation; this is the let-can-float invariant. And - exprOkForSpeculation is false of can_fail and has_side_effects. + let-bind a saturated primop application unless it has NoEffect. + The RHS of a let-binding (which can float in and out freely) + satisfies exprOkForSpeculation; this is the let-can-float + invariant. And exprOkForSpeculation is false of a saturated + primop application unless it has NoEffect. - * So can_fail and has_side_effects primops will appear only as the + * So primops that aren't NoEffect will appear only as the scrutinees of cases, and that's why the FloatIn pass is capable of floating case bindings inwards. - * The no-duplicate thing is done via primOpIsCheap, by making - has_side_effects things (very very very) not-cheap! + * Duplication via inlining and float-in of (lifted) let-binders is + controlled via primOpIsWorkFree and primOpIsCheap, by making + ReadWriteEffect things (among others) not-cheap! (The test + PrimOpEffect_Sanity will complain if any ReadWriteEffect primop + is considered either work-free or cheap.) Additionally, a + case binding is only floated inwards if its scrutinee is ok-to-discard. -} -primOpHasSideEffects :: PrimOp -> Bool -#include "primop-has-side-effects.hs-incl" +primOpEffect :: PrimOp -> PrimOpEffect +#include "primop-effects.hs-incl" -primOpCanFail :: PrimOp -> Bool -#include "primop-can-fail.hs-incl" +data PrimOpEffect + -- See Note [Classifying primop effects] + = NoEffect + | CanFail + | ThrowsException + | ReadWriteEffect + deriving (Eq, Ord) primOpOkForSpeculation :: PrimOp -> Bool - -- See Note [PrimOp can_fail and has_side_effects] + -- See Note [Classifying primop effects] -- See comments with GHC.Core.Utils.exprOkForSpeculation - -- primOpOkForSpeculation => primOpOkForSideEffects + -- primOpOkForSpeculation => primOpOkToDiscard primOpOkForSpeculation op - = primOpOkForSideEffects op - && not (primOpOutOfLine op || primOpCanFail op) + = primOpEffect op == NoEffect && not (primOpOutOfLine op) -- I think the "out of line" test is because out of line things can -- be expensive (eg sine, cosine), and so we may not want to speculate them -primOpOkForSideEffects :: PrimOp -> Bool -primOpOkForSideEffects op - = not (primOpHasSideEffects op) - -{- -Note [primOpIsCheap] -~~~~~~~~~~~~~~~~~~~~ +primOpOkToDiscard :: PrimOp -> Bool +primOpOkToDiscard op + = primOpEffect op < ThrowsException -@primOpIsCheap@, as used in GHC.Core.Opt.Simplify.Utils. For now (HACK -WARNING), we just borrow some other predicates for a -what-should-be-good-enough test. "Cheap" means willing to call it more -than once, and/or push it inside a lambda. The latter could change the -behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. --} +primOpIsWorkFree :: PrimOp -> Bool +#include "primop-is-work-free.hs-incl" primOpIsCheap :: PrimOp -> Bool --- See Note [PrimOp can_fail and has_side_effects] -primOpIsCheap op = primOpOkForSpeculation op +-- See Note [Classifying primop effects] +#include "primop-is-cheap.hs-incl" -- In March 2001, we changed this to -- primOpIsCheap op = False -- thereby making *no* primops seem cheap. But this killed eta @@ -540,7 +640,7 @@ -- The problem that originally gave rise to the change was -- let x = a +# b *# c in x +# x -- were we don't want to inline x. But primopIsCheap doesn't control --- that (it's exprIsDupable that does) so the problem doesn't occur +-- that (it's primOpIsWorkFree that does) so the problem doesn't occur -- even if primOpIsCheap sometimes says 'True'. @@ -759,8 +859,9 @@ GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) data PrimOpResultInfo - = ReturnsPrim PrimRep - | ReturnsAlg TyCon + = ReturnsVoid + | ReturnsPrim PrimRep + | ReturnsTuple -- Some PrimOps need not return a manifest primitive or algebraic value -- (i.e. they might return a polymorphic value). These PrimOps *must* @@ -769,9 +870,13 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op = case (primOpInfo op) of - Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) - GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) - | otherwise -> ReturnsAlg tc + Compare _ _ -> ReturnsPrim IntRep + GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of + [] -> ReturnsVoid + [rep] -> ReturnsPrim rep + _ -> pprPanic "getPrimOpResultInfo" (ppr op) + | isUnboxedTupleTyCon tc -> ReturnsTuple + | otherwise -> pprPanic "getPrimOpResultInfo" (ppr op) where tc = tyConAppTyCon ty -- All primops return a tycon-app result @@ -817,10 +922,10 @@ = text "__primcall" <+> ppr pkgId <+> ppr lbl -- | Indicate if a primop is really inline: that is, it isn't out-of-line and it --- isn't SeqOp/DataToTagOp which are two primops that evaluate their argument +-- isn't DataToTagOp which are two primops that evaluate their argument -- hence induce thread/stack/heap changes. primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case - SeqOp -> False - DataToTagOp -> False - p -> not (primOpOutOfLine p) + DataToTagSmallOp -> False + DataToTagLargeOp -> False + p -> not (primOpOutOfLine p) diff --git a/GHC/Builtin/PrimOps.hs-boot b/GHC/Builtin/PrimOps.hs-boot --- a/GHC/Builtin/PrimOps.hs-boot +++ b/GHC/Builtin/PrimOps.hs-boot @@ -1,5 +1,6 @@ module GHC.Builtin.PrimOps where -import GHC.Prelude () +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () data PrimOp diff --git a/GHC/Builtin/PrimOps/Casts.hs b/GHC/Builtin/PrimOps/Casts.hs --- a/GHC/Builtin/PrimOps/Casts.hs +++ b/GHC/Builtin/PrimOps/Casts.hs @@ -13,7 +13,6 @@ import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Core.Type import GHC.Builtin.Types.Prim diff --git a/GHC/Builtin/PrimOps/Ids.hs b/GHC/Builtin/PrimOps/Ids.hs --- a/GHC/Builtin/PrimOps/Ids.hs +++ b/GHC/Builtin/PrimOps/Ids.hs @@ -1,3 +1,8 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + -- | PrimOp's Ids module GHC.Builtin.PrimOps.Ids ( primOpId @@ -9,12 +14,15 @@ -- primop rules are attached to primop ids import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules) -import GHC.Core.Type (mkForAllTys, mkVisFunTysMany, argsHaveFixedRuntimeRep ) +import GHC.Core.TyCo.Rep ( scaledThing ) +import GHC.Core.Type +import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) import GHC.Core.FVs (mkRuleInfo) import GHC.Builtin.PrimOps import GHC.Builtin.Uniques import GHC.Builtin.Names +import GHC.Builtin.Types.Prim import GHC.Types.Basic import GHC.Types.Cpr @@ -23,11 +31,18 @@ import GHC.Types.Id.Info import GHC.Types.TyThing import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType ( ConcreteTvOrigin(..), ConcreteTyVars, TcType ) + import GHC.Data.SmallArray -import Data.Maybe ( maybeToList ) +import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList ) + -- | Build a PrimOp Id mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op @@ -38,9 +53,10 @@ name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op lev_poly) name ty info - lev_poly = not (argsHaveFixedRuntimeRep ty) + id = mkGlobalId (PrimOpId prim_op conc_tvs) name ty info + conc_tvs = computePrimOpConcTyVarsFromType name tyvars arg_tys res_ty + -- PrimOps don't ever construct a product, but we want to preserve bottoms cpr | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr @@ -57,6 +73,85 @@ -- test) about a RULE conflicting with a possible inlining -- cf #7287 +-- | Analyse the type of a primop to determine which of its outermost forall'd +-- type variables must be instantiated to concrete types when the primop is +-- instantiated. +-- +-- These are the Levity and RuntimeRep kinded type-variables which appear in +-- negative position in the type of the primop. +computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars +computePrimOpConcTyVarsFromType nm tyvars arg_tys _res_ty = mkNameEnv concs + where + concs = [ (tyVarName kind_tv, ConcreteFRR frr_orig) + | Bndr tv _af <- tyvars + , kind_tv <- tyCoVarsOfTypeWellScoped $ tyVarKind tv + , neg_pos <- maybeToList $ frr_tyvar_maybe kind_tv + , let frr_orig = FixedRuntimeRepOrigin + { frr_type = mkTyVarTy tv + , frr_context = FRRRepPolyId nm RepPolyPrimOp neg_pos + } + ] + + -- As per Note [Levity and representation polymorphic primops] + -- in GHC.Builtin.Primops.txt.pp, we compute the ConcreteTyVars associated + -- to a primop by inspecting the type variable names. + frr_tyvar_maybe tv + | tv `elem` [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar + , levity1TyVar, levity2TyVar ] + = listToMaybe $ + mapMaybe (\ (i,arg) -> mkArgPos i <$> positiveKindPos_maybe tv arg) + (zip [1..] arg_tys) + | otherwise + = Nothing + -- Compute whether the type variable occurs in the kind of a type variable + -- in positive position in one of the argument types of the primop. + +-- | Does this type variable appear in a kind in a negative position in the +-- type? +-- +-- Returns the first such position if so. +-- +-- NB: assumes the type is of a simple form, e.g. no foralls, no function +-- arrows nested in a TyCon other than a function arrow. +-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting +-- its type, see 'computePrimOpConcTyVarsFromType'. +negativeKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Neg) +negativeKindPos_maybe tv ty + | (args, res) <- splitFunTys ty + = listToMaybe $ catMaybes $ + ( (if null args then Nothing else Result <$> negativeKindPos_maybe tv res) + : map recur (zip [1..] args) + ) + where + recur (pos, scaled_ty) + = mkArgPos pos <$> positiveKindPos_maybe tv (scaledThing scaled_ty) + -- (assumes we don't have any function types nested inside other types) + +-- | Does this type variable appear in a kind in a positive position in the +-- type? +-- +-- Returns the first such position if so. +-- +-- NB: assumes the type is of a simple form, e.g. no foralls, no function +-- arrows nested in a TyCon other than a function arrow. +-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting +-- its type, see 'computePrimOpConcTyVarsFromType'. +positiveKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Pos) +positiveKindPos_maybe tv ty + | (args, res) <- splitFunTys ty + = listToMaybe $ catMaybes $ + ( (if null args then finish res else Result <$> positiveKindPos_maybe tv res) + : map recur (zip [1..] args) + ) + where + recur (pos, scaled_ty) + = mkArgPos pos <$> negativeKindPos_maybe tv (scaledThing scaled_ty) + -- (assumes we don't have any function types nested inside other types) + finish ty + | tv `elemVarSet` tyCoVarsOfType (typeKind ty) + = Just Top + | otherwise + = Nothing ------------------------------------------------------------- -- Cache of PrimOp's Ids diff --git a/GHC/Builtin/Types.hs b/GHC/Builtin/Types.hs --- a/GHC/Builtin/Types.hs +++ b/GHC/Builtin/Types.hs @@ -5,2471 +5,2944 @@ -} {-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | This module is about types that can be defined in Haskell, but which --- must be wired into the compiler nonetheless. C.f module "GHC.Builtin.Types.Prim" -module GHC.Builtin.Types ( - -- * Helper functions defined here - mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the - -- built-in functions for evaluation. - - mkWiredInIdName, -- used in GHC.Types.Id.Make - - -- * All wired in things - wiredInTyCons, isBuiltInOcc_maybe, isTupleTyOcc_maybe, isPunOcc_maybe, - - -- * Bool - boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, - trueDataCon, trueDataConId, true_RDR, - falseDataCon, falseDataConId, false_RDR, - promotedFalseDataCon, promotedTrueDataCon, - - -- * Ordering - orderingTyCon, - ordLTDataCon, ordLTDataConId, - ordEQDataCon, ordEQDataConId, - ordGTDataCon, ordGTDataConId, - promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, - - -- * Boxing primitive types - boxingDataCon, BoxingInfo(..), - - -- * Char - charTyCon, charDataCon, charTyCon_RDR, - charTy, stringTy, charTyConName, stringTyCon_RDR, - - -- * Double - doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, - - -- * Float - floatTyCon, floatDataCon, floatTy, floatTyConName, - - -- * Int - intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, - intTy, - - -- * Word - wordTyCon, wordDataCon, wordTyConName, wordTy, - - -- * Word8 - word8TyCon, word8DataCon, word8Ty, - - -- * List - listTyCon, listTyCon_RDR, listTyConName, listTyConKey, - nilDataCon, nilDataConName, nilDataConKey, - consDataCon_RDR, consDataCon, consDataConName, - promotedNilDataCon, promotedConsDataCon, - mkListTy, mkPromotedListTy, - - -- * Maybe - maybeTyCon, maybeTyConName, - nothingDataCon, nothingDataConName, promotedNothingDataCon, - justDataCon, justDataConName, promotedJustDataCon, - mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy, - - -- * Tuples - mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, - tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, - promotedTupleDataCon, - unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, - soloTyCon, - pairTyCon, mkPromotedPairTy, isPromotedPairType, - unboxedUnitTy, - unboxedUnitTyCon, unboxedUnitDataCon, - unboxedTupleKind, unboxedSumKind, - filterCTuple, mkConstraintTupleTy, - - -- ** Constraint tuples - cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, - cTupleTyConNameArity_maybe, - cTupleDataCon, cTupleDataConName, cTupleDataConNames, - cTupleSelId, cTupleSelIdName, - - -- * Any - anyTyCon, anyTy, anyTypeOfKind, - - -- * Recovery TyCon - makeRecoveryTyCon, - - -- * Sums - mkSumTy, sumTyCon, sumDataCon, - - -- * Kinds - typeSymbolKindCon, typeSymbolKind, - isLiftedTypeKindTyConName, - typeToTypeKind, - liftedRepTyCon, unliftedRepTyCon, - tYPETyCon, tYPETyConName, tYPEKind, - cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, - constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, - constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, - constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, - liftedRepTyConName, unliftedRepTyConName, - - -- * Equality predicates - heqTyCon, heqTyConName, heqClass, heqDataCon, - eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, - coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, - - -- * RuntimeRep and friends - runtimeRepTyCon, vecCountTyCon, vecElemTyCon, - - boxedRepDataConTyCon, - runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, - - vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, - - -- * Levity - levityTyCon, levityTy, - liftedDataConTyCon, unliftedDataConTyCon, - liftedDataConTy, unliftedDataConTy, - - intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy, - - vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy, - - int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - - doubleElemRepDataConTy, - - -- * Multiplicity and friends - multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy, - multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy, - oneDataConTyCon, manyDataConTyCon, - multMulTyCon, - - unrestrictedFunTyCon, unrestrictedFunTyConName, - - -- * Bignum - integerTy, integerTyCon, integerTyConName, - integerISDataCon, integerISDataConName, - integerIPDataCon, integerIPDataConName, - integerINDataCon, integerINDataConName, - naturalTy, naturalTyCon, naturalTyConName, - naturalNSDataCon, naturalNSDataConName, - naturalNBDataCon, naturalNBDataConName - ) where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) - --- friends: -import GHC.Builtin.Names -import GHC.Builtin.Types.Prim -import GHC.Builtin.Uniques - --- others: -import GHC.Core( Expr(Type), mkConApp ) -import GHC.Core.Coercion.Axiom -import GHC.Core.Type -import GHC.Types.Id -import GHC.Core.DataCon -import GHC.Core.ConLike -import GHC.Core.TyCon -import GHC.Core.Class ( Class, mkClass ) -import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap ) -import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) - -import GHC.Types.TyThing -import GHC.Types.SourceText -import GHC.Types.Var ( VarBndr (Bndr) ) -import GHC.Types.RepType -import GHC.Types.Name.Reader -import GHC.Types.Name as Name -import GHC.Types.Name.Env ( lookupNameEnv_NF ) -import GHC.Types.Basic -import GHC.Types.ForeignCall -import GHC.Types.Unique.Set - - -import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import GHC.Unit.Module ( Module ) - -import Data.Array -import GHC.Data.FastString -import GHC.Data.BooleanFormula ( mkAnd ) - -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import qualified Data.ByteString.Char8 as BS - -import Data.Foldable -import Data.List ( elemIndex, intersperse ) -import Numeric ( showInt ) - -import Text.Read (readMaybe) -import Data.Char (ord, isDigit) - -alpha_tyvar :: [TyVar] -alpha_tyvar = [alphaTyVar] - -alpha_ty :: [Type] -alpha_ty = [alphaTy] - -{- -Note [Wired-in Types and Type Constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This module include a lot of wired-in types and type constructors. Here, -these are presented in a tabular format to make it easier to find the -wired-in type identifier corresponding to a known Haskell type. Data -constructors are nested under their corresponding types with two spaces -of indentation. - -Identifier Type Haskell name Notes ----------------------------------------------------------------------------- -liftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE LiftedRep -unliftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE UnliftedRep -liftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Lifted -unliftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Unlifted -levityTyCon TyCon GHC.Types.Levity Data type - liftedDataConTyCon TyCon GHC.Types.Lifted Data constructor - unliftedDataConTyCon TyCon GHC.Types.Unlifted Data constructor -vecCountTyCon TyCon GHC.Types.VecCount Data type - vec2DataConTy Type GHC.Types.Vec2 Data constructor - vec4DataConTy Type GHC.Types.Vec4 Data constructor - vec8DataConTy Type GHC.Types.Vec8 Data constructor - vec16DataConTy Type GHC.Types.Vec16 Data constructor - vec32DataConTy Type GHC.Types.Vec32 Data constructor - vec64DataConTy Type GHC.Types.Vec64 Data constructor -runtimeRepTyCon TyCon GHC.Types.RuntimeRep Data type - boxedRepDataConTyCon TyCon GHC.Types.BoxedRep Data constructor - intRepDataConTy Type GHC.Types.IntRep Data constructor - doubleRepDataConTy Type GHC.Types.DoubleRep Data constructor - floatRepDataConTy Type GHC.Types.FloatRep Data constructor -boolTyCon TyCon GHC.Types.Bool Data type - trueDataCon DataCon GHC.Types.True Data constructor - falseDataCon DataCon GHC.Types.False Data constructor - promotedTrueDataCon TyCon GHC.Types.True Data constructor - promotedFalseDataCon TyCon GHC.Types.False Data constructor - -************************************************************************ -* * -\subsection{Wired in type constructors} -* * -************************************************************************ - -If you change which things are wired in, make sure you change their -names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc - --} - - --- This list is used only to define GHC.Builtin.Utils.wiredInThings. That in turn --- is used to initialise the name environment carried around by the renamer. --- This means that if we look up the name of a TyCon (or its implicit binders) --- that occurs in this list that name will be assigned the wired-in key we --- define here. --- --- Because of their infinite nature, this list excludes --- * tuples, including boxed, unboxed and constraint tuples ---- (mkTupleTyCon, unitTyCon, pairTyCon) --- * unboxed sums (sumTyCon) --- See Note [Infinite families of known-key names] in GHC.Builtin.Names --- --- See also Note [Known-key names] -wiredInTyCons :: [TyCon] - -wiredInTyCons = map (dataConTyCon . snd) boxingDataCons - ++ [ -- Units are not treated like other tuples, because they - -- are defined in GHC.Base, and there's only a few of them. We - -- put them in wiredInTyCons so that they will pre-populate - -- the name cache, so the parser in isBuiltInOcc_maybe doesn't - -- need to look out for them. - unitTyCon - , unboxedUnitTyCon - - -- Solo (i.e., the boxed 1-tuple) is also not treated - -- like other tuples (i.e. we /do/ include it here), - -- since it does not use special syntax like other tuples - -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names - -- have known keys) in GHC.Builtin.Types. - , soloTyCon - - , anyTyCon - , boolTyCon - , charTyCon - , stringTyCon - , doubleTyCon - , floatTyCon - , intTyCon - , wordTyCon - , listTyCon - , orderingTyCon - , maybeTyCon - , heqTyCon - , eqTyCon - , coercibleTyCon - , typeSymbolKindCon - , runtimeRepTyCon - , levityTyCon - , vecCountTyCon - , vecElemTyCon - , constraintKindTyCon - , liftedTypeKindTyCon - , unliftedTypeKindTyCon - , multiplicityTyCon - , naturalTyCon - , integerTyCon - , liftedRepTyCon - , unliftedRepTyCon - , zeroBitRepTyCon - , zeroBitTypeTyCon - ] - -mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name -mkWiredInTyConName built_in modu fs unique tycon - = mkWiredInName modu (mkTcOccFS fs) unique - (ATyCon tycon) -- Relevant TyCon - built_in - -mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name -mkWiredInDataConName built_in modu fs unique datacon - = mkWiredInName modu (mkDataOccFS fs) unique - (AConLike (RealDataCon datacon)) -- Relevant DataCon - built_in - -mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name -mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax - --- See Note [Kind-changing of (~) and Coercible] --- in libraries/ghc-prim/GHC/Types.hs -eqTyConName, eqDataConName, eqSCSelIdName :: Name -eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon -eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon -eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId - -eqTyCon_RDR :: RdrName -eqTyCon_RDR = nameRdrName eqTyConName - --- See Note [Kind-changing of (~) and Coercible] --- in libraries/ghc-prim/GHC/Types.hs -heqTyConName, heqDataConName, heqSCSelIdName :: Name -heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon -heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon -heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId - --- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs -coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name -coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon -coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon -coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId - -charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name -charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon -charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon -stringTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "String") stringTyConKey stringTyCon -intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon -intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon - -boolTyConName, falseDataConName, trueDataConName :: Name -boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon -trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon - -listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List") listTyConKey listTyCon -nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon -consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon - -maybeTyConName, nothingDataConName, justDataConName :: Name -maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe") - maybeTyConKey maybeTyCon -nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing") - nothingDataConKey nothingDataCon -justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just") - justDataConKey justDataCon - -wordTyConName, wordDataConName, word8DataConName :: Name -wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon -wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon -word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon - -floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name -floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon -floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon -doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon -doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon - --- Any - -{- -Note [Any types] -~~~~~~~~~~~~~~~~ -The type constructor Any, - - type family Any :: k where { } - -It has these properties: - - * Note that 'Any' is kind polymorphic since in some program we may - need to use Any to fill in a type variable of some kind other than * - (see #959 for examples). Its kind is thus `forall k. k``. - - * It is defined in module GHC.Types, and exported so that it is - available to users. For this reason it's treated like any other - wired-in type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache - - * It is a *closed* type family, with no instances. This means that - if ty :: '(k1, k2) we add a given coercion - g :: ty ~ (Fst ty, Snd ty) - If Any was a *data* type, then we'd get inconsistency because 'ty' - could be (Any '(k1,k2)) and then we'd have an equality with Any on - one side and '(,) on the other. See also #9097 and #9636. - - * When instantiated at a lifted type it is inhabited by at least one value, - namely bottom - - * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. - - * It is wired-in so we can easily refer to it where we don't have a name - environment (e.g. see Rules.matchRule for one example) - -It's used to instantiate un-constrained type variables after type checking. For -example, 'length' has type - - length :: forall a. [a] -> Int - -and the list datacon for the empty list has type - - [] :: forall a. [a] - -In order to compose these two terms as @length []@ a type -application is required, but there is no constraint on the -choice. In this situation GHC uses 'Any', - -> length (Any *) ([] (Any *)) - -Above, we print kinds explicitly, as if with --fprint-explicit-kinds. - -The Any tycon used to be quite magic, but we have since been able to -implement it merely with an empty kind polymorphic type family. See #10886 for a -bit of history. --} - - -anyTyConName :: Name -anyTyConName = - mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon - -anyTyCon :: TyCon -anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing - (ClosedSynFamilyTyCon Nothing) - Nothing - NotInjective - where - binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] - res_kind = mkTyVarTy (binderVar kv) - -anyTy :: Type -anyTy = mkTyConTy anyTyCon - -anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp anyTyCon [kind] - --- | Make a fake, recovery 'TyCon' from an existing one. --- Used when recovering from errors in type declarations -makeRecoveryTyCon :: TyCon -> TyCon -makeRecoveryTyCon tc - = mkTcTyCon (tyConName tc) - bndrs res_kind - noTcTyConScopedTyVars - True -- Fully generalised - flavour -- Keep old flavour - where - flavour = tyConFlavour tc - [kv] = mkTemplateKindVars [liftedTypeKind] - (bndrs, res_kind) - = case flavour of - PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) - _ -> (tyConBinders tc, tyConResKind tc) - -- For data types we have already validated their kind, so it - -- makes sense to keep it. For promoted data constructors we haven't, - -- so we recover with kind (forall k. k). Otherwise consider - -- data T a where { MkT :: Show a => T a } - -- If T is for some reason invalid, we don't want to fall over - -- at (promoted) use-sites of MkT. - --- Kinds -typeSymbolKindConName :: Name -typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon - - -boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName -boolTyCon_RDR = nameRdrName boolTyConName -false_RDR = nameRdrName falseDataConName -true_RDR = nameRdrName trueDataConName -intTyCon_RDR = nameRdrName intTyConName -charTyCon_RDR = nameRdrName charTyConName -stringTyCon_RDR = nameRdrName stringTyConName -intDataCon_RDR = nameRdrName intDataConName -listTyCon_RDR = nameRdrName listTyConName -consDataCon_RDR = nameRdrName consDataConName - -{- -************************************************************************ -* * -\subsection{mkWiredInTyCon} -* * -************************************************************************ --} - --- This function assumes that the types it creates have all parameters at --- Representational role, and that there is no kind polymorphism. -pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon -pcTyCon name cType tyvars cons - = mkAlgTyCon name - (mkAnonTyConBinders tyvars) - liftedTypeKind - (map (const Representational) tyvars) - cType - [] -- No stupid theta - (mkDataTyConRhs cons) - (VanillaAlgTyCon (mkPrelTyConRepName name)) - False -- Not in GADT syntax - -pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon n univs tys - = pcDataConWithFixity False n univs - [] -- no ex_tvs - univs -- the univs are precisely the user-written tyvars - [] -- No theta - (map linear tys) - -pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon --- Used for data constructors whose arguments are all constraints. --- Notably constraint tuples, Eq# etc. -pcDataConConstraint n univs theta - = pcDataConWithFixity False n univs - [] -- No ex_tvs - univs -- The univs are precisely the user-written tyvars - theta -- All constraint arguments - [] -- No value arguments - --- Used for RuntimeRep and friends; things with PromDataConInfo -pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon -pcSpecialDataCon dc_name arg_tys tycon rri - = pcDataConWithFixity' False dc_name - (dataConWorkerUnique (nameUnique dc_name)) rri - [] [] [] [] (map linear arg_tys) tycon - -pcDataConWithFixity :: Bool -- ^ declared infix? - -> Name -- ^ datacon name - -> [TyVar] -- ^ univ tyvars - -> [TyCoVar] -- ^ ex tycovars - -> [TyCoVar] -- ^ user-written tycovars - -> ThetaType - -> [Scaled Type] -- ^ args - -> TyCon - -> DataCon -pcDataConWithFixity infx n = pcDataConWithFixity' infx n - (dataConWorkerUnique (nameUnique n)) NoPromInfo --- The Name's unique is the first of two free uniques; --- the first is used for the datacon itself, --- the second is used for the "worker name" --- --- To support this the mkPreludeDataConUnique function "allocates" --- one DataCon unique per pair of Ints. - -pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo - -> [TyVar] -> [TyCoVar] -> [TyCoVar] - -> ThetaType -> [Scaled Type] -> TyCon -> DataCon --- The Name should be in the DataName name space; it's the name --- of the DataCon itself. --- --- IMPORTANT NOTE: --- if you try to wire-in a /GADT/ data constructor you will --- find it hard (we did). You will need wrapper and worker --- Names, a DataConBoxer, DataConRep, EqSpec, etc. --- Try hard not to wire-in GADT data types. You will live --- to regret doing so (we do). - -pcDataConWithFixity' declared_infix dc_name wrk_key rri - tyvars ex_tyvars user_tyvars theta arg_tys tycon - = data_con - where - tag_map = mkTyConTagMap tycon - -- This constructs the constructor Name to ConTag map once per - -- constructor, which is quadratic. It's OK here, because it's - -- only called for wired in data types that don't have a lot of - -- constructors. It's also likely that GHC will lift tag_map, since - -- we call pcDataConWithFixity' with static TyCons in the same module. - -- See Note [Constructor tag allocation] and #14657 - data_con = mkDataCon dc_name declared_infix prom_info - (map (const no_bang) arg_tys) - [] -- No labelled fields - tyvars ex_tyvars - (mkTyVarBinders SpecifiedSpec user_tyvars) - [] -- No equality spec - theta - arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) - rri - tycon - (lookupNameEnv_NF tag_map dc_name) - [] -- No stupid theta - (mkDataConWorkId wrk_name data_con) - NoDataConRep -- Wired-in types are too simple to need wrappers - - no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict - - wrk_name = mkDataConWorkerName data_con wrk_key - - prom_info = mkPrelTyConRepName dc_name - -mkDataConWorkerName :: DataCon -> Unique -> Name -mkDataConWorkerName data_con wrk_key = - mkWiredInName modu wrk_occ wrk_key - (AnId (dataConWorkId data_con)) UserSyntax - where - modu = assert (isExternalName dc_name) $ - nameModule dc_name - dc_name = dataConName data_con - dc_occ = nameOccName dc_name - wrk_occ = mkDataConWorkerOcc dc_occ - - -{- -************************************************************************ -* * - Symbol -* * -************************************************************************ --} - -typeSymbolKindCon :: TyCon --- data Symbol -typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] - -typeSymbolKind :: Kind -typeSymbolKind = mkTyConTy typeSymbolKindCon - - -{- -************************************************************************ -* * - Stuff for dealing with tuples -* * -************************************************************************ - -Note [How tuples work] -~~~~~~~~~~~~~~~~~~~~~~ -* There are three families of tuple TyCons and corresponding - DataCons, expressed by the type BasicTypes.TupleSort: - data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple - -* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon - -* BoxedTuples - - A wired-in type - - Data type declarations in GHC.Tuple - - The data constructors really have an info table - -* UnboxedTuples - - A wired-in type - - Have a pretend DataCon, defined in GHC.Prim, - but no actual declaration and no info table - -* ConstraintTuples - - A wired-in type. - - Declared as classes in GHC.Classes, e.g. - class (c1,c2) => (c1,c2) - - Given constraints: the superclasses automatically become available - - Wanted constraints: there is a built-in instance - instance (c1,c2) => (c1,c2) - See GHC.Tc.Instance.Class.matchCTuple - - Currently just go up to 64; beyond that - you have to use manual nesting - - Their OccNames look like (%,,,%), so they can easily be - distinguished from term tuples. But (following Haskell) we - pretty-print saturated constraint tuples with round parens; - see BasicTypes.tupleParens. - - Unlike BoxedTuples and UnboxedTuples, which only wire - in type constructors and data constructors, ConstraintTuples also wire in - superclass selector functions. For instance, $p1(%,%) and $p2(%,%) are - the selectors for the binary constraint tuple. - -* In quite a lot of places things are restricted just to - BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish - E.g. tupleTyCon has a Boxity argument - -* When looking up an OccName in the original-name cache - (GHC.Iface.Env.lookupOrigNameCache), we spot the tuple OccName to make sure - we get the right wired-in name. This guy can't tell the difference - between BoxedTuple and ConstraintTuple (same OccName!), so tuples - are not serialised into interface files using OccNames at all. - -* Serialization to interface files works via the usual mechanism for known-key - things: instead of serializing the OccName we just serialize the key. During - deserialization we lookup the Name associated with the unique with the logic - in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details. - -See also Note [Known-key names] in GHC.Builtin.Names. - -Note [One-tuples] -~~~~~~~~~~~~~~~~~ -GHC supports both boxed and unboxed one-tuples: - - Unboxed one-tuples are sometimes useful when returning a - single value after CPR analysis - - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when - there is just one binder -Basically it keeps everything uniform. - -However the /naming/ of the type/data constructors for one-tuples is a -bit odd: - 3-tuples: Tuple3 (,,)# - 2-tuples: Tuple2 (,)# - 1-tuples: ?? - 0-tuples: Unit ()# - -Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#' -for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: - data Unit = () - data Solo a = MkSolo a - data Tuple2 a b = (a,b) - -There is no way to write a boxed one-tuple in Haskell using tuple syntax. -They can, however, be written using other methods: - -1. They can be written directly by importing them from GHC.Tuple. -2. They can be generated by way of Template Haskell or in `deriving` code. - -There is nothing special about one-tuples in Core; in particular, they have no -custom pretty-printing, just using `Solo`. - -Note that there is *not* a unary constraint tuple, unlike for other forms of -tuples. See [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType for more -details. - -See also Note [Flattening one-tuples] in GHC.Core.Make and -Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. - ------ --- Wrinkle: Make boxed one-tuple names have known keys ------ - -We make boxed one-tuple names have known keys so that `data Solo a = MkSolo a`, -defined in GHC.Tuple, will be used when one-tuples are spliced in through -Template Haskell. This program (from #18097) crucially relies on this: - - case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x - -Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an -ExplicitTuple of length 1) will not match the type of Solo (an ordinary -data constructor used in a pattern). Making Solo known-key allows GHC to make -this connection. - -Unlike Solo, every other tuple is /not/ known-key -(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The -main reason for this exception is that other tuples are written with special -syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe` -function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache). -In contrast, Solo is just an ordinary data type with no special syntax, so it -doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Solo -known-key is the next-best way to teach the internals of the compiler about it. --} - --- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names --- with BuiltInSyntax. However, this should only be necessary while resolving --- names produced by Template Haskell splices since we take care to encode --- built-in syntax names specially in interface files. See --- Note [Symbol table representation of names]. --- --- Moreover, there is no need to include names of things that the user can't --- write (e.g. type representation bindings like $tc(,,,)). -isBuiltInOcc_maybe :: OccName -> Maybe Name -isBuiltInOcc_maybe occ = - case name of - "[]" -> Just $ choose_ns listTyConName nilDataConName - ":" -> Just consDataConName - - -- function tycon - "FUN" -> Just fUNTyConName - "->" -> Just unrestrictedFunTyConName - - -- boxed tuple data/tycon - -- We deliberately exclude Solo (the boxed 1-tuple). - -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys) - "()" -> Just $ tup_name Boxed 0 - _ | Just rest <- "(" `BS.stripPrefix` name - , (commas, rest') <- BS.span (==',') rest - , ")" <- rest' - -> Just $ tup_name Boxed (1+BS.length commas) - - -- unboxed tuple data/tycon - "(##)" -> Just $ tup_name Unboxed 0 - "Solo#" -> Just $ tup_name Unboxed 1 - _ | Just rest <- "(#" `BS.stripPrefix` name - , (commas, rest') <- BS.span (==',') rest - , "#)" <- rest' - -> Just $ tup_name Unboxed (1+BS.length commas) - - -- unboxed sum tycon - _ | Just rest <- "(#" `BS.stripPrefix` name - , (nb_pipes, rest') <- span_pipes rest - , "#)" <- rest' - -> Just $ tyConName $ sumTyCon (1+nb_pipes) - - -- unboxed sum datacon - _ | Just rest <- "(#" `BS.stripPrefix` name - , (nb_pipes1, rest') <- span_pipes rest - , Just rest'' <- "_" `BS.stripPrefix` rest' - , (nb_pipes2, rest''') <- span_pipes rest'' - , "#)" <- rest''' - -> let arity = nb_pipes1 + nb_pipes2 + 1 - alt = nb_pipes1 + 1 - in Just $ dataConName $ sumDataCon alt arity - _ -> Nothing - where - name = bytesFS $ occNameFS occ - - span_pipes :: BS.ByteString -> (Int, BS.ByteString) - span_pipes = go 0 - where - go nb_pipes bs = case BS.uncons bs of - Just ('|',rest) -> go (nb_pipes + 1) rest - Just (' ',rest) -> go nb_pipes rest - _ -> (nb_pipes, bs) - - choose_ns :: Name -> Name -> Name - choose_ns tc dc - | isTcClsNameSpace ns = tc - | isDataConNameSpace ns = dc - | otherwise = pprPanic "tup_name" (ppr occ <+> parens (pprNameSpace ns)) - where ns = occNameSpace occ - - tup_name boxity arity - = choose_ns (getName (tupleTyCon boxity arity)) - (getName (tupleDataCon boxity arity)) - -isTupleTyOcc_maybe :: Module -> OccName -> Maybe Name -isTupleTyOcc_maybe mod occ - | mod == gHC_TUPLE_PRIM - = match_occ - where - match_occ - | occ == occName unitTyConName = Just unitTyConName - | occ == occName soloTyConName = Just soloTyConName - | otherwise = isTupleNTyOcc_maybe occ -isTupleTyOcc_maybe _ _ = Nothing - - --- | This is only for Tuple, not for Unit or Solo -isTupleNTyOcc_maybe :: OccName -> Maybe Name -isTupleNTyOcc_maybe occ = - case occNameString occ of - 'T':'u':'p':'l':'e':str | Just n <- readInt str, n > 1 - -> Just (tupleTyConName BoxedTuple n) - _ -> Nothing - --- | See Note [Small Ints parsing] -readInt :: String -> Maybe Int -readInt s = case s of - [c] | isDigit c -> Just (digit_to_int c) - [c1, c2] | isDigit c1, isDigit c2 - -> Just (digit_to_int c1 * 10 + digit_to_int c2) - _ -> readMaybe s - where - digit_to_int :: Char -> Int - digit_to_int c = ord c - ord '0' - -{- -Note [Small Ints parsing] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, tuples in Haskell have a maximum arity of 64. -To parse strings of length 1 and 2 more efficiently, we -can utilize an ad-hoc solution that matches their characters. -This results in a speedup of up to 40 times compared to using -`readMaybe @Int` on my machine. --} - --- When resolving names produced by Template Haskell (see thOrigRdrName --- in GHC.ThToHs), we want ghc-prim:GHC.Types.List to yield an Exact name, not --- an Orig name. --- --- This matters for pretty-printing under ListTuplePuns. If we don't do it, --- then -ddump-splices will print ''[] as ''GHC.Types.List. --- --- Test case: th/T13776 --- -isPunOcc_maybe :: Module -> OccName -> Maybe Name -isPunOcc_maybe mod occ - | mod == gHC_TYPES, occ == occName listTyConName - = Just listTyConName - | mod == gHC_TUPLE_PRIM, occ == occName unitTyConName - = Just unitTyConName - | mod == gHC_TUPLE_PRIM - = isTupleNTyOcc_maybe occ -isPunOcc_maybe _ _ = Nothing - -mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName --- No need to cache these, the caching is done in mk_tuple -mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ns ar) -mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) - -mkCTupleOcc :: NameSpace -> Arity -> OccName -mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) - -mkTupleStr :: Boxity -> NameSpace -> Arity -> String -mkTupleStr Boxed = mkBoxedTupleStr -mkTupleStr Unboxed = const mkUnboxedTupleStr - -mkBoxedTupleStr :: NameSpace -> Arity -> String -mkBoxedTupleStr ns 0 - | isDataConNameSpace ns = "()" - | otherwise = "Unit" -mkBoxedTupleStr ns 1 - | isDataConNameSpace ns = "MkSolo" -- See Note [One-tuples] - | otherwise = "Solo" -mkBoxedTupleStr ns ar - | isDataConNameSpace ns = '(' : commas ar ++ ")" - | otherwise = "Tuple" ++ showInt ar "" - -mkUnboxedTupleStr :: Arity -> String -mkUnboxedTupleStr 0 = "(##)" -mkUnboxedTupleStr 1 = "Solo#" -- See Note [One-tuples] -mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" - -mkConstraintTupleStr :: Arity -> String -mkConstraintTupleStr 0 = "(%%)" -mkConstraintTupleStr 1 = "Solo%" -- See Note [One-tuples] -mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)" - -commas :: Arity -> String -commas ar = replicate (ar-1) ',' - -cTupleTyCon :: Arity -> TyCon -cTupleTyCon i - | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially - | otherwise = fstOf3 (cTupleArr ! i) - -cTupleTyConName :: Arity -> Name -cTupleTyConName a = tyConName (cTupleTyCon a) - -cTupleTyConNames :: [Name] -cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) - -cTupleTyConKeys :: UniqSet Unique -cTupleTyConKeys = mkUniqSet $ map getUnique cTupleTyConNames - -isCTupleTyConName :: Name -> Bool -isCTupleTyConName n - = assertPpr (isExternalName n) (ppr n) $ - getUnique n `elementOfUniqSet` cTupleTyConKeys - --- | If the given name is that of a constraint tuple, return its arity. -cTupleTyConNameArity_maybe :: Name -> Maybe Arity -cTupleTyConNameArity_maybe n - | not (isCTupleTyConName n) = Nothing - | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames) - where - -- Since `cTupleTyConNames` jumps straight from the `0` to the `2` - -- case, we have to adjust accordingly our calculated arity. - adjustArity a = if a > 0 then a + 1 else a - -cTupleDataCon :: Arity -> DataCon -cTupleDataCon i - | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially - | otherwise = sndOf3 (cTupleArr ! i) - -cTupleDataConName :: Arity -> Name -cTupleDataConName i = dataConName (cTupleDataCon i) - -cTupleDataConNames :: [Name] -cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) - -cTupleSelId :: ConTag -- Superclass position - -> Arity -- Arity - -> Id -cTupleSelId sc_pos arity - | sc_pos > arity - = panic ("cTupleSelId: index out of bounds: superclass position: " - ++ show sc_pos ++ " > arity " ++ show arity) - - | sc_pos <= 0 - = panic ("cTupleSelId: Superclass positions start from 1. " - ++ "(superclass position: " ++ show sc_pos - ++ ", arity: " ++ show arity ++ ")") - - | arity < 2 - = panic ("cTupleSelId: Arity starts from 2. " - ++ "(superclass position: " ++ show sc_pos - ++ ", arity: " ++ show arity ++ ")") - - | arity > mAX_CTUPLE_SIZE - = thdOf3 (mk_ctuple arity) ! (sc_pos - 1) -- Build one specially - - | otherwise - = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1) - -cTupleSelIdName :: ConTag -- Superclass position - -> Arity -- Arity - -> Name -cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity) - -tupleTyCon :: Boxity -> Arity -> TyCon -tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially -tupleTyCon Boxed i = fst (boxedTupleArr ! i) -tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) - -tupleTyConName :: TupleSort -> Arity -> Name -tupleTyConName ConstraintTuple a = cTupleTyConName a -tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) -tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) - -promotedTupleDataCon :: Boxity -> Arity -> TyCon -promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) - -tupleDataCon :: Boxity -> Arity -> DataCon -tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially -tupleDataCon Boxed i = snd (boxedTupleArr ! i) -tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) - -tupleDataConName :: Boxity -> Arity -> Name -tupleDataConName sort i = dataConName (tupleDataCon sort i) - -mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type -mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2] - -isPromotedPairType :: Type -> Maybe (Type, Type) -isPromotedPairType t - | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t - , tc == promotedTupleDataCon Boxed 2 - = Just (x, y) - | otherwise = Nothing - -boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) -boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] -unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] - --- | Cached type constructors, data constructors, and superclass selectors for --- constraint tuples. The outer array is indexed by the arity of the constraint --- tuple and the inner array is indexed by the superclass position. -cTupleArr :: Array Int (TyCon, DataCon, Array Int Id) -cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]] - -- Although GHC does not make use of unary constraint tuples - -- (see Note [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType), - -- this array creates one anyway. This is primarily motivated by the fact - -- that (1) the indices of an Array must be contiguous, and (2) we would like - -- the index of a constraint tuple in this Array to correspond to its Arity. - -- We could envision skipping over the unary constraint tuple and having index - -- 1 correspond to a 2-constraint tuple (and so on), but that's more - -- complicated than it's worth. - --- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed --- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type --- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep --- [IntRep, LiftedRep])@ -unboxedTupleSumKind :: TyCon -> [Type] -> Kind -unboxedTupleSumKind tc rr_tys - = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) - --- | Specialization of 'unboxedTupleSumKind' for tuples -unboxedTupleKind :: [Type] -> Kind -unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon - -mk_tuple :: Boxity -> Int -> (TyCon,DataCon) -mk_tuple Boxed arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con - BoxedTuple flavour - - tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) - tc_res_kind = liftedTypeKind - flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) - - dc_tvs = binderVars tc_binders - dc_arg_tys = mkTyVarTys dc_tvs - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon - - boxity = Boxed - modu = gHC_TUPLE_PRIM - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) UserSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity - -mk_tuple Unboxed arity = (tycon, tuple_con) - where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con - UnboxedTuple flavour - - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2]) - tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) - (\ks -> map mkTYPEapp ks) - - tc_res_kind = unboxedTupleKind rr_tys - flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) - - dc_tvs = binderVars tc_binders - (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) - tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon - - boxity = Unboxed - modu = gHC_PRIM - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity - -mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id) -mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr) - where - tycon = mkClassTyCon tc_name binders roles - rhs klass - (mkPrelTyConRepName tc_name) - - klass = mk_ctuple_class tycon sc_theta sc_sel_ids - tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon - - binders = mkTemplateAnonTyConBinders (replicate arity constraintKind) - roles = replicate arity Nominal - rhs = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple} - - modu = gHC_CLASSES - tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkCTupleTyConUnique arity - dc_uniq = mkCTupleDataConUnique arity - - tvs = binderVars binders - sc_theta = map mkTyVarTy tvs - sc_sel_ids = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]] - sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids - - mk_sc_sel_id sc_pos = - let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity - sc_sel_id_occ = mkCTupleOcc tcName arity - sc_sel_id_name = mkWiredInIdName - gHC_CLASSES - (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ)) - sc_sel_id_uniq - sc_sel_id - sc_sel_id = mkDictSelId sc_sel_id_name klass - - in sc_sel_id - -unitTyCon :: TyCon -unitTyCon = tupleTyCon Boxed 0 - -unitTyConName :: Name -unitTyConName = tyConName unitTyCon - -unitTyConKey :: Unique -unitTyConKey = getUnique unitTyCon - -unitDataCon :: DataCon -unitDataCon = head (tyConDataCons unitTyCon) - -unitDataConId :: Id -unitDataConId = dataConWorkId unitDataCon - -soloTyCon :: TyCon -soloTyCon = tupleTyCon Boxed 1 - -soloTyConName :: Name -soloTyConName = tyConName soloTyCon - -pairTyCon :: TyCon -pairTyCon = tupleTyCon Boxed 2 - -unboxedUnitTy :: Type -unboxedUnitTy = mkTyConTy unboxedUnitTyCon - -unboxedUnitTyCon :: TyCon -unboxedUnitTyCon = tupleTyCon Unboxed 0 - -unboxedUnitDataCon :: DataCon -unboxedUnitDataCon = tupleDataCon Unboxed 0 - -{- ********************************************************************* -* * - Unboxed sums -* * -********************************************************************* -} - --- | OccName for n-ary unboxed sum type constructor. -mkSumTyConOcc :: Arity -> OccName -mkSumTyConOcc n = mkOccName tcName str - where - -- No need to cache these, the caching is done in mk_sum - str = '(' : '#' : ' ' : bars ++ " #)" - bars = intersperse ' ' $ replicate (n-1) '|' - --- | OccName for i-th alternative of n-ary unboxed sum data constructor. -mkSumDataConOcc :: ConTag -> Arity -> OccName -mkSumDataConOcc alt n = mkOccName dataName str - where - -- No need to cache these, the caching is done in mk_sum - str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)" - bars i = intersperse ' ' $ replicate i '|' - --- | Type constructor for n-ary unboxed sum. -sumTyCon :: Arity -> TyCon -sumTyCon arity - | arity > mAX_SUM_SIZE - = fst (mk_sum arity) -- Build one specially - - | arity < 2 - = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") - - | otherwise - = fst (unboxedSumArr ! arity) - --- | Data constructor for i-th alternative of a n-ary unboxed sum. -sumDataCon :: ConTag -- Alternative - -> Arity -- Arity - -> DataCon -sumDataCon alt arity - | alt > arity - = panic ("sumDataCon: index out of bounds: alt: " - ++ show alt ++ " > arity " ++ show arity) - - | alt <= 0 - = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt - ++ ", arity: " ++ show arity ++ ")") - - | arity < 2 - = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt - ++ ", arity: " ++ show arity ++ ")") - - | arity > mAX_SUM_SIZE - = snd (mk_sum arity) ! (alt - 1) -- Build one specially - - | otherwise - = snd (unboxedSumArr ! arity) ! (alt - 1) - --- | Cached type and data constructors for sums. The outer array is --- indexed by the arity of the sum and the inner array is indexed by --- the alternative. -unboxedSumArr :: Array Int (TyCon, Array Int DataCon) -unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] - --- | Specialization of 'unboxedTupleSumKind' for sums -unboxedSumKind :: [Type] -> Kind -unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon - --- | Create type constructor and data constructors for n-ary unboxed sum. -mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) -mk_sum arity = (tycon, sum_cons) - where - tycon = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons) - UnboxedSumTyCon - - tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) - (\ks -> map mkTYPEapp ks) - - tyvars = binderVars tc_binders - - tc_res_kind = unboxedSumKind rr_tys - - (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) - - tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - - sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] - sum_con i = let dc = pcDataCon dc_name - tyvars -- univ tyvars - [tyvar_tys !! i] -- arg types - tycon - - dc_name = mkWiredInName gHC_PRIM - (mkSumDataConOcc i arity) - (dc_uniq i) - (AConLike (RealDataCon dc)) - BuiltInSyntax - in dc - - tc_uniq = mkSumTyConUnique arity - dc_uniq i = mkSumDataConUnique i arity - -{- -************************************************************************ -* * - Equality types and classes -* * -********************************************************************* -} - --- See Note [The equality types story] in GHC.Builtin.Types.Prim --- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) --- --- It's tempting to put functional dependencies on (~~), but it's not --- necessary because the functional-dependency coverage check looks --- through superclasses, and (~#) is handled in that check. - -eqTyCon, heqTyCon, coercibleTyCon :: TyCon -eqClass, heqClass, coercibleClass :: Class -eqDataCon, heqDataCon, coercibleDataCon :: DataCon -eqSCSelId, heqSCSelId, coercibleSCSelId :: Id - -(eqTyCon, eqClass, eqDataCon, eqSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon eqTyConName binders roles - rhs klass - (mkPrelTyConRepName eqTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConConstraint eqDataConName tvs [sc_pred] tycon - - -- Kind: forall k. k -> k -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) - roles = [Nominal, Nominal, Nominal] - rhs = mkDataTyConRhs [datacon] - - tvs@[k,a,b] = binderVars binders - sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) - sc_sel_id = mkDictSelId eqSCSelIdName klass - -(heqTyCon, heqClass, heqDataCon, heqSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon heqTyConName binders roles - rhs klass - (mkPrelTyConRepName heqTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConConstraint heqDataConName tvs [sc_pred] tycon - - -- Kind: forall k1 k2. k1 -> k2 -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - roles = [Nominal, Nominal, Nominal, Nominal] - rhs = mkDataTyConRhs [datacon] - - tvs = binderVars binders - sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) - sc_sel_id = mkDictSelId heqSCSelIdName klass - -(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) - = (tycon, klass, datacon, sc_sel_id) - where - tycon = mkClassTyCon coercibleTyConName binders roles - rhs klass - (mkPrelTyConRepName coercibleTyConName) - klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon - - -- Kind: forall k. k -> k -> Constraint - binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) - roles = [Nominal, Representational, Representational] - rhs = mkDataTyConRhs [datacon] - - tvs@[k,a,b] = binderVars binders - sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) - sc_sel_id = mkDictSelId coercibleSCSelIdName klass - -mk_class :: TyCon -> PredType -> Id -> Class -mk_class tycon sc_pred sc_sel_id - = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] - [] [] (mkAnd []) tycon - -mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class -mk_ctuple_class tycon sc_theta sc_sel_ids - = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids - [] [] (mkAnd []) tycon - -{- ********************************************************************* -* * - Multiplicity Polymorphism -* * -********************************************************************* -} - -{- Multiplicity polymorphism is implemented very similarly to representation - polymorphism. We write in the multiplicity kind and the One and Many - types which can appear in user programs. These are defined properly in GHC.Types. - -data Multiplicity = One | Many --} - -multiplicityTyConName :: Name -multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") - multiplicityTyConKey multiplicityTyCon - -oneDataConName, manyDataConName :: Name -oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon -manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon - -multiplicityTy :: Type -multiplicityTy = mkTyConTy multiplicityTyCon - -multiplicityTyCon :: TyCon -multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] - [oneDataCon, manyDataCon] - -oneDataCon, manyDataCon :: DataCon -oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon -manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon - -oneDataConTy, manyDataConTy :: Type -oneDataConTy = mkTyConTy oneDataConTyCon -manyDataConTy = mkTyConTy manyDataConTyCon - -oneDataConTyCon, manyDataConTyCon :: TyCon -oneDataConTyCon = promoteDataCon oneDataCon -manyDataConTyCon = promoteDataCon manyDataCon - -multMulTyConName :: Name -multMulTyConName = - mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon - -multMulTyCon :: TyCon -multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing - (BuiltInSynFamTyCon trivialBuiltInFamily) - Nothing - NotInjective - where - binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] - ------------------------- --- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). --- TYPE rep1 -> TYPE rep2 -> Type --- type (->) = FUN 'Many -unrestrictedFunTyCon :: TyCon -unrestrictedFunTyCon - = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] - (TyCoRep.TyConApp fUNTyCon [manyDataConTy]) - where - arrowKind = mkTyConKind binders liftedTypeKind - -- See also funTyCon - binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) - , Bndr runtimeRep2TyVar (NamedTCB Inferred) ] - ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty - , mkTYPEapp runtimeRep2Ty ] - -unrestrictedFunTyConName :: Name -unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") - unrestrictedFunTyConKey unrestrictedFunTyCon - - -{- ********************************************************************* -* * - Type synonyms (all declared in ghc-prim:GHC.Types) - - type CONSTRAINT :: RuntimeRep -> Type -- primitive; cONSTRAINTKind - type Constraint = CONSTRAINT LiftedRep :: Type -- constraintKind - - type TYPE :: RuntimeRep -> Type -- primitive; tYPEKind - type Type = TYPE LiftedRep :: Type -- liftedTypeKind - type UnliftedType = TYPE UnliftedRep :: Type -- unliftedTypeKind - - type LiftedRep = BoxedRep Lifted :: RuntimeRep -- liftedRepTy - type UnliftedRep = BoxedRep Unlifted :: RuntimeRep -- unliftedRepTy - -* * -********************************************************************* -} - --- For these synonyms, see --- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and --- Note [Using synonyms to compress types] in GHC.Core.Type - -{- Note [Naked FunTy] -~~~~~~~~~~~~~~~~~~~~~ -GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument -flag and arg/res types. But when constructing the kinds of tYPETyCon and -cONSTRAINTTyCon we don't want to make these checks because - TYPE :: RuntimeRep -> Type -i.e. TYPE :: RuntimeRep -> TYPE LiftedRep - -so the check will loop infinitely. Hence the use of a naked FunTy -constructor in tTYPETyCon and cONSTRAINTTyCon. --} - - ----------------------- --- type Constraint = CONSTRAINT LiftedRep -constraintKindTyCon :: TyCon -constraintKindTyCon - = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs - where - rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy] - -constraintKindTyConName :: Name -constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") - constraintKindTyConKey constraintKindTyCon - -constraintKind :: Kind -constraintKind = mkTyConTy constraintKindTyCon - ----------------------- --- type Type = TYPE LiftedRep -liftedTypeKindTyCon :: TyCon -liftedTypeKindTyCon - = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs - where - rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] - -liftedTypeKindTyConName :: Name -liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") - liftedTypeKindTyConKey liftedTypeKindTyCon - -liftedTypeKind, typeToTypeKind :: Type -liftedTypeKind = mkTyConTy liftedTypeKindTyCon -typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind - ----------------------- --- type UnliftedType = TYPE ('BoxedRep 'Unlifted) -unliftedTypeKindTyCon :: TyCon -unliftedTypeKindTyCon - = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs - where - rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] - -unliftedTypeKindTyConName :: Name -unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") - unliftedTypeKindTyConKey unliftedTypeKindTyCon - -unliftedTypeKind :: Type -unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon - - -{- ********************************************************************* -* * - data Levity = Lifted | Unlifted -* * -********************************************************************* -} - -levityTyConName, liftedDataConName, unliftedDataConName :: Name -levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon -liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon -unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon - -levityTyCon :: TyCon -levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] - -levityTy :: Type -levityTy = mkTyConTy levityTyCon - -liftedDataCon, unliftedDataCon :: DataCon -liftedDataCon = pcSpecialDataCon liftedDataConName - [] levityTyCon (Levity Lifted) -unliftedDataCon = pcSpecialDataCon unliftedDataConName - [] levityTyCon (Levity Unlifted) - -liftedDataConTyCon :: TyCon -liftedDataConTyCon = promoteDataCon liftedDataCon - -unliftedDataConTyCon :: TyCon -unliftedDataConTyCon = promoteDataCon unliftedDataCon - -liftedDataConTy :: Type -liftedDataConTy = mkTyConTy liftedDataConTyCon - -unliftedDataConTy :: Type -unliftedDataConTy = mkTyConTy unliftedDataConTyCon - - -{- ********************************************************************* -* * - See Note [Wiring in RuntimeRep] - data RuntimeRep = VecRep VecCount VecElem - | TupleRep [RuntimeRep] - | SumRep [RuntimeRep] - | BoxedRep Levity - | IntRep | Int8Rep | ...etc... -* * -********************************************************************* -} - -{- Note [Wiring in RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, -making it a pain to wire in. To ease the pain somewhat, we use lists of -the different bits, like Uniques, Names, DataCons. These lists must be -kept in sync with each other. The rule is this: use the order as declared -in GHC.Types. All places where such lists exist should contain a reference -to this Note, so a search for this Note's name should find all the lists. - -See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. --} - -runtimeRepTyCon :: TyCon -runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] - -- Here we list all the data constructors - -- of the RuntimeRep data type - (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : boxedRepDataCon : - runtimeRepSimpleDataCons) - -runtimeRepTy :: Type -runtimeRepTy = mkTyConTy runtimeRepTyCon - -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name -runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon - -vecRepDataConName = mk_runtime_rep_dc_name (fsLit "VecRep") vecRepDataConKey vecRepDataCon -tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon -sumRepDataConName = mk_runtime_rep_dc_name (fsLit "SumRep") sumRepDataConKey sumRepDataCon -boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon - -mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name -mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc - -boxedRepDataCon :: DataCon -boxedRepDataCon = pcSpecialDataCon boxedRepDataConName - [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in RepType - prim_rep_fun [lev] - = case tyConAppTyCon_maybe lev of - Just tc -> case tyConPromDataConInfo tc of - Levity l -> [BoxedRep (Just l)] - _ -> [BoxedRep Nothing] - Nothing -> [BoxedRep Nothing] - prim_rep_fun args - = pprPanic "boxedRepDataCon" (ppr args) - - -boxedRepDataConTyCon :: TyCon -boxedRepDataConTyCon = promoteDataCon boxedRepDataCon - -tupleRepDataCon :: DataCon -tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType - prim_rep_fun [rr_ty_list] - = concatMap (runtimeRepPrimRep doc) rr_tys - where - rr_tys = extractPromotedList rr_ty_list - doc = text "tupleRepDataCon" <+> ppr rr_tys - prim_rep_fun args - = pprPanic "tupleRepDataCon" (ppr args) - -tupleRepDataConTyCon :: TyCon -tupleRepDataConTyCon = promoteDataCon tupleRepDataCon - -sumRepDataCon :: DataCon -sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] - runtimeRepTyCon (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType - prim_rep_fun [rr_ty_list] - = map slotPrimRep (toList (ubxSumRepType prim_repss)) - where - rr_tys = extractPromotedList rr_ty_list - doc = text "sumRepDataCon" <+> ppr rr_tys - prim_repss = map (runtimeRepPrimRep doc) rr_tys - prim_rep_fun args - = pprPanic "sumRepDataCon" (ppr args) - -sumRepDataConTyCon :: TyCon -sumRepDataConTyCon = promoteDataCon sumRepDataCon - --- See Note [Wiring in RuntimeRep] --- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType -runtimeRepSimpleDataCons :: [DataCon] -runtimeRepSimpleDataCons - = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys - [ (fsLit "IntRep", IntRep) - , (fsLit "Int8Rep", Int8Rep) - , (fsLit "Int16Rep", Int16Rep) - , (fsLit "Int32Rep", Int32Rep) - , (fsLit "Int64Rep", Int64Rep) - , (fsLit "WordRep", WordRep) - , (fsLit "Word8Rep", Word8Rep) - , (fsLit "Word16Rep", Word16Rep) - , (fsLit "Word32Rep", Word32Rep) - , (fsLit "Word64Rep", Word64Rep) - , (fsLit "AddrRep", AddrRep) - , (fsLit "FloatRep", FloatRep) - , (fsLit "DoubleRep", DoubleRep) ] - where - mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon - mk_runtime_rep_dc uniq (fs, primrep) - = data_con - where - data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) - dc_name = mk_runtime_rep_dc_name fs uniq data_con - --- See Note [Wiring in RuntimeRep] -intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType -[intRepDataConTy, - int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, - wordRepDataConTy, - word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, - addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy - ] - = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons - ----------------------- --- | @type ZeroBitRep = 'Tuple '[] -zeroBitRepTyCon :: TyCon -zeroBitRepTyCon - = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] - -zeroBitRepTyConName :: Name -zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") - zeroBitRepTyConKey zeroBitRepTyCon - -zeroBitRepTy :: RuntimeRepType -zeroBitRepTy = mkTyConTy zeroBitRepTyCon - ----------------------- --- @type ZeroBitType = TYPE ZeroBitRep -zeroBitTypeTyCon :: TyCon -zeroBitTypeTyCon - = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs - where - rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] - -zeroBitTypeTyConName :: Name -zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") - zeroBitTypeTyConKey zeroBitTypeTyCon - -zeroBitTypeKind :: Type -zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon - ----------------------- --- | @type LiftedRep = 'BoxedRep 'Lifted@ -liftedRepTyCon :: TyCon -liftedRepTyCon - = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] - -liftedRepTyConName :: Name -liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") - liftedRepTyConKey liftedRepTyCon - -liftedRepTy :: RuntimeRepType -liftedRepTy = mkTyConTy liftedRepTyCon - ----------------------- --- | @type UnliftedRep = 'BoxedRep 'Unlifted@ -unliftedRepTyCon :: TyCon -unliftedRepTyCon - = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] - -unliftedRepTyConName :: Name -unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") - unliftedRepTyConKey unliftedRepTyCon - -unliftedRepTy :: RuntimeRepType -unliftedRepTy = mkTyConTy unliftedRepTyCon - - -{- ********************************************************************* -* * - VecCount, VecElem -* * -********************************************************************* -} - -vecCountTyConName :: Name -vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon - -vecElemTyConName :: Name -vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon - -vecRepDataCon :: DataCon -vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon - , mkTyConTy vecElemTyCon ] - runtimeRepTyCon - (RuntimeRep prim_rep_fun) - where - -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType - prim_rep_fun [count, elem] - | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count) - , VecElem e <- tyConPromDataConInfo (tyConAppTyCon elem) - = [VecRep n e] - prim_rep_fun args - = pprPanic "vecRepDataCon" (ppr args) - -vecRepDataConTyCon :: TyCon -vecRepDataConTyCon = promoteDataCon vecRepDataCon - -vecCountTyCon :: TyCon -vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons - --- See Note [Wiring in RuntimeRep] -vecCountDataCons :: [DataCon] -vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys - where - mk_vec_count_dc logN key = con - where - n = 2^(logN :: Int) - name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con - con = pcSpecialDataCon name [] vecCountTyCon (VecCount n) - --- See Note [Wiring in RuntimeRep] -vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy :: Type -[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, - vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons - -vecElemTyCon :: TyCon -vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons - --- See Note [Wiring in RuntimeRep] -vecElemDataCons :: [DataCon] -vecElemDataCons = zipWith3 mk_vec_elem_dc - [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep" - , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep" - , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] - [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep - , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep - , FloatElemRep, DoubleElemRep ] - vecElemDataConKeys - where - mk_vec_elem_dc nameFs elemRep key = con - where - name = mk_runtime_rep_dc_name nameFs key con - con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep) - --- See Note [Wiring in RuntimeRep] -int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy :: Type -[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, - int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, - word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, - doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) - vecElemDataCons - -{- ********************************************************************* -* * - The boxed primitive types: Char, Int, etc -* * -********************************************************************* -} - -charTy :: Type -charTy = mkTyConTy charTyCon - -charTyCon :: TyCon -charTyCon = pcTyCon charTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsChar"))) - [] [charDataCon] -charDataCon :: DataCon -charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon - -stringTy :: Type -stringTy = mkTyConTy stringTyCon - -stringTyCon :: TyCon --- We have this wired-in so that Haskell literal strings --- get type String (in hsLitType), which in turn influences --- inferred types and error messages -stringTyCon = buildSynTyCon stringTyConName - [] liftedTypeKind [] - (mkListTy charTy) - -intTy :: Type -intTy = mkTyConTy intTyCon - -intTyCon :: TyCon -intTyCon = pcTyCon intTyConName - (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) - [] [intDataCon] -intDataCon :: DataCon -intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon - -wordTy :: Type -wordTy = mkTyConTy wordTyCon - -wordTyCon :: TyCon -wordTyCon = pcTyCon wordTyConName - (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) - [] [wordDataCon] -wordDataCon :: DataCon -wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon - -word8Ty :: Type -word8Ty = mkTyConTy word8TyCon - -word8TyCon :: TyCon -word8TyCon = pcTyCon word8TyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsWord8"))) [] - [word8DataCon] -word8DataCon :: DataCon -word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon - -floatTy :: Type -floatTy = mkTyConTy floatTyCon - -floatTyCon :: TyCon -floatTyCon = pcTyCon floatTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsFloat"))) [] - [floatDataCon] -floatDataCon :: DataCon -floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon - -doubleTy :: Type -doubleTy = mkTyConTy doubleTyCon - -doubleTyCon :: TyCon -doubleTyCon = pcTyCon doubleTyConName - (Just (CType NoSourceText Nothing - (NoSourceText,fsLit "HsDouble"))) [] - [doubleDataCon] - -doubleDataCon :: DataCon -doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon - -{- ********************************************************************* -* * - Boxing data constructors -* * -********************************************************************* -} - -{- Note [Boxing constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep -that "box" unlifted values into a (boxed, lifted) value of kind Type. For example - - type Int8Box :: TYPE Int8Rep -> Type - data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a - -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a - -Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`. We can also -package up a (lifted) Constraint as a value of kind Type. - -There are a fixed number of RuntimeReps, so we only need a fixed number -of boxing types. (For TupleRep we need to box recursively; not yet done, -see #22336.) - -This is used: - -* In desugaring, when we need to package up a bunch of values into a tuple, - for example when desugaring arrows. See Note [Big tuples] in GHC.Core.Make. - -* In let-floating when we want to float an unlifted sub-expression. - See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels - -In this module we make wired-in data type declarations for all of -these boxing functions. The goal is to define boxingDataCon_maybe. - -Wrinkles -(W1) The runtime system has special treatment (e.g. commoning up during GC) - for Int and Char values. See Note [CHARLIKE and INTLIKE closures] and - Note [Precomputed static closures] in the RTS. - - So we treat Int# and Char# specially, in specialBoxingDataCon_maybe --} - -data BoxingInfo b - = BI_NoBoxNeeded -- The type has kind Type, so there is nothing to do - - | BI_NoBoxAvailable -- The type does not have kind Type, but sadly we - -- don't have a boxing data constructor either - - | BI_Box -- The type does not have kind Type, and we do have a - -- boxing data constructor; here it is - { bi_data_con :: DataCon - , bi_inst_con :: Expr b - , bi_boxed_type :: Type } - -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int } - -- recall: data Int = I# Int# - -- - -- BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty - -- , bi_boxed_type = Int8Box ty } - -- recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a - -boxingDataCon :: Type -> BoxingInfo b --- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that --- will box it, and the type of the boxed thing, which /does/ now have kind Type. --- See Note [Boxing constructors] -boxingDataCon ty - | tcIsLiftedTypeKind kind - = BI_NoBoxNeeded -- Fast path for Type - - | Just box_con <- specialBoxingDataCon_maybe ty - = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [] - , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) } - - | Just box_con <- lookupTypeMap boxingDataConMap kind - = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty] - , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] } - - | otherwise - = BI_NoBoxAvailable - - where - kind = typeKind ty - -specialBoxingDataCon_maybe :: Type -> Maybe DataCon --- ^ See Note [Boxing constructors] wrinkle (W1) -specialBoxingDataCon_maybe ty - = case splitTyConApp_maybe ty of - Just (tc, _) | tc `hasKey` intPrimTyConKey -> Just intDataCon - | tc `hasKey` charPrimTyConKey -> Just charDataCon - _ -> Nothing - -boxingDataConMap :: TypeMap DataCon --- See Note [Boxing constructors] -boxingDataConMap = foldl add emptyTypeMap boxingDataCons - where - add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con - -boxingDataCons :: [(Kind, DataCon)] --- The Kind is the kind of types for which the DataCon is the right boxing -boxingDataCons = zipWith mkBoxingDataCon - (map mkBoxingTyConUnique [1..]) - [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox") - , (mkTYPEapp intRepDataConTy, fsLit "IntBox", fsLit "MkIntBox") - - , (mkTYPEapp floatRepDataConTy, fsLit "FloatBox", fsLit "MkFloatBox") - , (mkTYPEapp doubleRepDataConTy, fsLit "DoubleBox", fsLit "MkDoubleBox") - - , (mkTYPEapp int8RepDataConTy, fsLit "Int8Box", fsLit "MkInt8Box") - , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box") - , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box") - , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box") - - , (mkTYPEapp word8RepDataConTy, fsLit "Word8Box", fsLit "MkWord8Box") - , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box", fsLit "MkWord16Box") - , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box", fsLit "MkWord32Box") - , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box", fsLit "MkWord64Box") - - , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox") - , (constraintKind, fsLit "DictBox", fsLit "MkDictBox") ] - -mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon) -mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc) - = (kind, dc) - where - uniq_dc = boxingDataConUnique uniq_tc - - (tv:_) = mkTemplateTyVars (repeat kind) - tc = pcTyCon tc_name Nothing [tv] [dc] - tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc - - dc | isConstraintKind kind - = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc - | otherwise - = pcDataCon dc_name [tv] [mkTyVarTy tv] tc - dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc - -{- -************************************************************************ -* * - The Bool type -* * -************************************************************************ - -An ordinary enumeration type, but deeply wired in. There are no -magical operations on @Bool@ (just the regular Prelude code). - -{\em BEGIN IDLE SPECULATION BY SIMON} - -This is not the only way to encode @Bool@. A more obvious coding makes -@Bool@ just a boxed up version of @Bool#@, like this: -\begin{verbatim} -type Bool# = Int# -data Bool = MkBool Bool# -\end{verbatim} - -Unfortunately, this doesn't correspond to what the Report says @Bool@ -looks like! Furthermore, we get slightly less efficient code (I -think) with this coding. @gtInt@ would look like this: - -\begin{verbatim} -gtInt :: Int -> Int -> Bool -gtInt x y = case x of I# x# -> - case y of I# y# -> - case (gtIntPrim x# y#) of - b# -> MkBool b# -\end{verbatim} - -Notice that the result of the @gtIntPrim@ comparison has to be turned -into an integer (here called @b#@), and returned in a @MkBool@ box. - -The @if@ expression would compile to this: -\begin{verbatim} -case (gtInt x y) of - MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } -\end{verbatim} - -I think this code is a little less efficient than the previous code, -but I'm not certain. At all events, corresponding with the Report is -important. The interesting thing is that the language is expressive -enough to describe more than one alternative; and that a type doesn't -necessarily need to be a straightforwardly boxed version of its -primitive counterpart. - -{\em END IDLE SPECULATION BY SIMON} --} - -boolTy :: Type -boolTy = mkTyConTy boolTyCon - -boolTyCon :: TyCon -boolTyCon = pcTyCon boolTyConName - (Just (CType NoSourceText Nothing - (NoSourceText, fsLit "HsBool"))) - [] [falseDataCon, trueDataCon] - -falseDataCon, trueDataCon :: DataCon -falseDataCon = pcDataCon falseDataConName [] [] boolTyCon -trueDataCon = pcDataCon trueDataConName [] [] boolTyCon - -falseDataConId, trueDataConId :: Id -falseDataConId = dataConWorkId falseDataCon -trueDataConId = dataConWorkId trueDataCon - -orderingTyCon :: TyCon -orderingTyCon = pcTyCon orderingTyConName Nothing - [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] - -ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon -ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon -ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon -ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon - -ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id -ordLTDataConId = dataConWorkId ordLTDataCon -ordEQDataConId = dataConWorkId ordEQDataCon -ordGTDataConId = dataConWorkId ordGTDataCon - -{- -************************************************************************ -* * - The List type - Special syntax, deeply wired in, - but otherwise an ordinary algebraic data type -* * -************************************************************************ - - data [] a = [] | a : (List a) --} - -mkListTy :: Type -> Type -mkListTy ty = mkTyConApp listTyCon [ty] - -listTyCon :: TyCon -listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon] - --- See also Note [Empty lists] in GHC.Hs.Expr. -nilDataCon :: DataCon -nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon - -consDataCon :: DataCon -consDataCon = pcDataConWithFixity True {- Declared infix -} - consDataConName - alpha_tyvar [] alpha_tyvar [] - (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) - listTyCon - --- Interesting: polymorphic recursion would help here. --- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy --- gets the over-specific type (Type -> Type) - --- Wired-in type Maybe - -maybeTyCon :: TyCon -maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar - [nothingDataCon, justDataCon] - -nothingDataCon :: DataCon -nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon - -justDataCon :: DataCon -justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon - -mkPromotedMaybeTy :: Kind -> Maybe Type -> Type -mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x] -mkPromotedMaybeTy k Nothing = mkTyConApp promotedNothingDataCon [k] - -mkMaybeTy :: Type -> Kind -mkMaybeTy t = mkTyConApp maybeTyCon [t] - -isPromotedMaybeTy :: Type -> Maybe (Maybe Type) -isPromotedMaybeTy t - | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x - | Just (tc,[_]) <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing - | otherwise = Nothing - - -{- -** ********************************************************************* -* * - The tuple types -* * -************************************************************************ - -The tuple types are definitely magic, because they form an infinite -family. - -\begin{itemize} -\item -They have a special family of type constructors, of type @TyCon@ -These contain the tycon arity, but don't require a Unique. - -\item -They have a special family of constructors, of type -@Id@. Again these contain their arity but don't need a Unique. - -\item -There should be a magic way of generating the info tables and -entry code for all tuples. - -But at the moment we just compile a Haskell source -file\srcloc{lib/prelude/...} containing declarations like: -\begin{verbatim} -data Tuple0 = Tup0 -data Tuple2 a b = Tup2 a b -data Tuple3 a b c = Tup3 a b c -data Tuple4 a b c d = Tup4 a b c d -... -\end{verbatim} -The print-names associated with the magic @Id@s for tuple constructors -``just happen'' to be the same as those generated by these -declarations. - -\item -The instance environment should have a magic way to know -that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and -so on. \ToDo{Not implemented yet.} - -\item -There should also be a way to generate the appropriate code for each -of these instances, but (like the info tables and entry code) it is -done by enumeration\srcloc{lib/prelude/InTup?.hs}. -\end{itemize} --} - --- | Make a tuple type. The list of types should /not/ include any --- RuntimeRep specifications. Boxed 1-tuples are flattened. --- See Note [One-tuples] -mkTupleTy :: Boxity -> [Type] -> Type --- Special case for *boxed* 1-tuples, which are represented by the type itself -mkTupleTy Boxed [ty] = ty -mkTupleTy boxity tys = mkTupleTy1 boxity tys - --- | Make a tuple type. The list of types should /not/ include any --- RuntimeRep specifications. Boxed 1-tuples are *not* flattened. --- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn] --- in "GHC.Core.Make" -mkTupleTy1 :: Boxity -> [Type] -> Type -mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys -mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) - (map getRuntimeRep tys ++ tys) - --- | Build the type of a small tuple that holds the specified type of thing --- Flattens 1-tuples. See Note [One-tuples]. -mkBoxedTupleTy :: [Type] -> Type -mkBoxedTupleTy tys = mkTupleTy Boxed tys - -unitTy :: Type -unitTy = mkTupleTy Boxed [] - --- Make a constraint tuple, flattening a 1-tuple as usual --- If we get a constraint tuple that is bigger than the pre-built --- ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't --- have an info table in the RTS, so we can't use it at runtime. But --- this is used only in filling in extra-constraint wildcards, so it --- never is used at runtime anyway --- See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures] -mkConstraintTupleTy :: [Type] -> Type -mkConstraintTupleTy [ty] = ty -mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys - - -{- ********************************************************************* -* * - The sum types -* * -************************************************************************ --} - -mkSumTy :: [Type] -> Type -mkSumTy tys = mkTyConApp (sumTyCon (length tys)) - (map getRuntimeRep tys ++ tys) - --- Promoted Booleans - -promotedFalseDataCon, promotedTrueDataCon :: TyCon -promotedTrueDataCon = promoteDataCon trueDataCon -promotedFalseDataCon = promoteDataCon falseDataCon - --- Promoted Maybe -promotedNothingDataCon, promotedJustDataCon :: TyCon -promotedNothingDataCon = promoteDataCon nothingDataCon -promotedJustDataCon = promoteDataCon justDataCon - --- Promoted Ordering - -promotedLTDataCon - , promotedEQDataCon - , promotedGTDataCon - :: TyCon -promotedLTDataCon = promoteDataCon ordLTDataCon -promotedEQDataCon = promoteDataCon ordEQDataCon -promotedGTDataCon = promoteDataCon ordGTDataCon - --- Promoted List -promotedConsDataCon, promotedNilDataCon :: TyCon -promotedConsDataCon = promoteDataCon consDataCon -promotedNilDataCon = promoteDataCon nilDataCon - --- | Make a *promoted* list. -mkPromotedListTy :: Kind -- ^ of the elements of the list - -> [Type] -- ^ elements - -> Type -mkPromotedListTy k tys - = foldr cons nil tys - where - cons :: Type -- element - -> Type -- list - -> Type - cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] - - nil :: Type - nil = mkTyConApp promotedNilDataCon [k] - --- | Extract the elements of a promoted list. Panics if the type is not a --- promoted list -extractPromotedList :: Type -- ^ The promoted list - -> [Type] -extractPromotedList tys = go tys - where - go list_ty - | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty - = assert (tc `hasKey` consDataConKey) $ - t : go ts - - | Just (tc, [_k]) <- splitTyConApp_maybe list_ty - = assert (tc `hasKey` nilDataConKey) - [] - - | otherwise - = pprPanic "extractPromotedList" (ppr tys) - ---------------------------------------- --- ghc-bignum ---------------------------------------- - -integerTyConName - , integerISDataConName - , integerIPDataConName - , integerINDataConName - :: Name -integerTyConName - = mkWiredInTyConName - UserSyntax - gHC_NUM_INTEGER - (fsLit "Integer") - integerTyConKey - integerTyCon -integerISDataConName - = mkWiredInDataConName - UserSyntax - gHC_NUM_INTEGER - (fsLit "IS") - integerISDataConKey - integerISDataCon -integerIPDataConName - = mkWiredInDataConName - UserSyntax - gHC_NUM_INTEGER - (fsLit "IP") - integerIPDataConKey - integerIPDataCon -integerINDataConName - = mkWiredInDataConName - UserSyntax - gHC_NUM_INTEGER - (fsLit "IN") - integerINDataConKey - integerINDataCon - -integerTy :: Type -integerTy = mkTyConTy integerTyCon - -integerTyCon :: TyCon -integerTyCon = pcTyCon integerTyConName Nothing [] - [integerISDataCon, integerIPDataCon, integerINDataCon] - -integerISDataCon :: DataCon -integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon - -integerIPDataCon :: DataCon -integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon - -integerINDataCon :: DataCon -integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon - -naturalTyConName - , naturalNSDataConName - , naturalNBDataConName - :: Name -naturalTyConName - = mkWiredInTyConName - UserSyntax - gHC_NUM_NATURAL - (fsLit "Natural") - naturalTyConKey - naturalTyCon -naturalNSDataConName - = mkWiredInDataConName - UserSyntax - gHC_NUM_NATURAL - (fsLit "NS") - naturalNSDataConKey - naturalNSDataCon -naturalNBDataConName - = mkWiredInDataConName - UserSyntax - gHC_NUM_NATURAL - (fsLit "NB") - naturalNBDataConKey - naturalNBDataCon - -naturalTy :: Type -naturalTy = mkTyConTy naturalTyCon - -naturalTyCon :: TyCon -naturalTyCon = pcTyCon naturalTyConName Nothing [] - [naturalNSDataCon, naturalNBDataCon] - -naturalNSDataCon :: DataCon -naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon - -naturalNBDataCon :: DataCon -naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon - - --- | Replaces constraint tuple names with corresponding boxed ones. -filterCTuple :: RdrName -> RdrName -filterCTuple (Exact n) - | Just arity <- cTupleTyConNameArity_maybe n - = Exact $ tupleTyConName BoxedTuple arity -filterCTuple rdr = rdr +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | This module is about types that can be defined in Haskell, but which +-- must be wired into the compiler nonetheless. C.f module "GHC.Builtin.Types.Prim" +module GHC.Builtin.Types ( + -- * Helper functions defined here + mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the + -- built-in functions for evaluation. + + mkWiredInIdName, -- used in GHC.Types.Id.Make + + -- * All wired in things + wiredInTyCons, isBuiltInOcc, isBuiltInOcc_maybe, + isTupleTyOrigName_maybe, isSumTyOrigName_maybe, + isInfiniteFamilyOrigName_maybe, + + -- * Bool + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + promotedFalseDataCon, promotedTrueDataCon, + + -- * Ordering + orderingTyCon, + ordLTDataCon, ordLTDataConId, + ordEQDataCon, ordEQDataConId, + ordGTDataCon, ordGTDataConId, + promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, + + -- * Boxing primitive types + boxingDataCon, BoxingInfo(..), + + -- * Char + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, stringTyCon_RDR, + + -- * Double + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, + + -- * Float + floatTyCon, floatDataCon, floatTy, floatTyConName, + + -- * Int + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + + -- * Word + wordTyCon, wordDataCon, wordTyConName, wordTy, + + -- * Word8 + word8TyCon, word8DataCon, word8Ty, + + -- * List + listTyCon, listTyCon_RDR, listTyConName, listTyConKey, + nilDataCon, nilDataConName, nilDataConKey, + consDataCon_RDR, consDataCon, consDataConName, + promotedNilDataCon, promotedConsDataCon, + mkListTy, mkPromotedListTy, extractPromotedList, + + -- * Maybe + maybeTyCon, maybeTyConName, + nothingDataCon, nothingDataConName, promotedNothingDataCon, + justDataCon, justDataConName, promotedJustDataCon, + mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy, + + -- * Tuples + mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, + tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, + promotedTupleDataCon, + unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, + soloTyCon, + soloDataConName, + pairTyCon, mkPromotedPairTy, isPromotedPairType, + unboxedUnitTy, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedSoloTyCon, unboxedSoloTyConName, unboxedSoloDataConName, + unboxedTupleKind, unboxedSumKind, + mkConstraintTupleTy, + + -- ** Constraint tuples + cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, + cTupleDataCon, cTupleDataConName, cTupleDataConNames, + cTupleSelId, cTupleSelIdName, + + -- * Any + anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon, + + -- * Recovery TyCon + makeRecoveryTyCon, + + -- * Sums + mkSumTy, sumTyCon, sumDataCon, + unboxedSumTyConName, unboxedSumDataConName, + + -- * Kinds + typeSymbolKindCon, typeSymbolKind, + isLiftedTypeKindTyConName, + typeToTypeKind, + liftedRepTyCon, unliftedRepTyCon, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, + constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, + constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, + constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, + liftedRepTyConName, unliftedRepTyConName, + + -- * Equality predicates + heqTyCon, heqTyConName, heqClass, heqDataCon, + eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, + coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, + + -- * RuntimeRep and friends + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + + boxedRepDataConTyCon, + runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, + + vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, + + -- * Levity + levityTyCon, levityTy, + liftedDataConTyCon, unliftedDataConTyCon, + liftedDataConTy, unliftedDataConTy, + + intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, + + vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy, + + int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + + doubleElemRepDataConTy, + + -- * Multiplicity and friends + multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy, + multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy, + oneDataConTyCon, manyDataConTyCon, + multMulTyCon, + + unrestrictedFunTyCon, unrestrictedFunTyConName, + + -- * Bignum + integerTy, integerTyCon, integerTyConName, + integerISDataCon, integerISDataConName, + integerIPDataCon, integerIPDataConName, + integerINDataCon, integerINDataConName, + naturalTy, naturalTyCon, naturalTyConName, + naturalNSDataCon, naturalNSDataConName, + naturalNBDataCon, naturalNBDataConName, + + pretendNameIsInScope, + ) where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId ) + +-- friends: +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Builtin.Uniques + +-- others: +import GHC.Core( Expr(Type), mkConApp ) +import GHC.Core.Coercion.Axiom +import GHC.Core.Type +import GHC.Types.Id +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Class ( Class, mkClass ) +import GHC.Core.Map.Type ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap ) +import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) ) + +import GHC.Types.TyThing +import GHC.Types.SourceText +import GHC.Types.Var ( VarBndr (Bndr), tyVarName ) +import GHC.Types.RepType +import GHC.Types.Name.Reader +import GHC.Types.Name as Name +import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Unique.Set + +import {-# SOURCE #-} GHC.Tc.Types.Origin + ( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType + ( ConcreteTvOrigin(..), ConcreteTyVars, noConcreteTyVars ) + +import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) +import GHC.Unit.Module ( Module ) + +import Data.Maybe +import Data.Array +import GHC.Data.FastString +import GHC.Data.BooleanFormula ( mkAnd ) + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Short.Internal as SBS (unsafeIndex) + +import Data.Foldable +import Data.List ( intersperse ) +import Numeric ( showInt ) + +import Data.Word (Word8) +import Control.Applicative ((<|>)) + +alpha_tyvar :: [TyVar] +alpha_tyvar = [alphaTyVar] + +alpha_ty :: [Type] +alpha_ty = [alphaTy] + +{- +Note [Wired-in Types and Type Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This module include a lot of wired-in types and type constructors. Here, +these are presented in a tabular format to make it easier to find the +wired-in type identifier corresponding to a known Haskell type. Data +constructors are nested under their corresponding types with two spaces +of indentation. + +Identifier Type Haskell name Notes +---------------------------------------------------------------------------- +liftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE LiftedRep +unliftedTypeKindTyCon TyCon GHC.Types.Type Synonym for: TYPE UnliftedRep +liftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Lifted +unliftedRepTyCon TyCon GHC.Types.LiftedRep Synonym for: 'BoxedRep 'Unlifted +levityTyCon TyCon GHC.Types.Levity Data type + liftedDataConTyCon TyCon GHC.Types.Lifted Data constructor + unliftedDataConTyCon TyCon GHC.Types.Unlifted Data constructor +vecCountTyCon TyCon GHC.Types.VecCount Data type + vec2DataConTy Type GHC.Types.Vec2 Data constructor + vec4DataConTy Type GHC.Types.Vec4 Data constructor + vec8DataConTy Type GHC.Types.Vec8 Data constructor + vec16DataConTy Type GHC.Types.Vec16 Data constructor + vec32DataConTy Type GHC.Types.Vec32 Data constructor + vec64DataConTy Type GHC.Types.Vec64 Data constructor +runtimeRepTyCon TyCon GHC.Types.RuntimeRep Data type + boxedRepDataConTyCon TyCon GHC.Types.BoxedRep Data constructor + intRepDataConTy Type GHC.Types.IntRep Data constructor + doubleRepDataConTy Type GHC.Types.DoubleRep Data constructor + floatRepDataConTy Type GHC.Types.FloatRep Data constructor +boolTyCon TyCon GHC.Types.Bool Data type + trueDataCon DataCon GHC.Types.True Data constructor + falseDataCon DataCon GHC.Types.False Data constructor + promotedTrueDataCon TyCon GHC.Types.True Data constructor + promotedFalseDataCon TyCon GHC.Types.False Data constructor + +************************************************************************ +* * +\subsection{Wired in type constructors} +* * +************************************************************************ + +If you change which things are wired in, make sure you change their +names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc + +-} + + +-- This list is used only to define GHC.Builtin.Utils.knownKeyNames. That in turn +-- is used to initialise the name environment carried around by the renamer. +-- This means that if we look up the name of a TyCon (or its implicit binders) +-- that occurs in this list that name will be assigned the wired-in key we +-- define here. +-- +-- Because of their infinite nature, this list excludes +-- * Tuples of all sorts (boxed, unboxed, constraint) (mkTupleTyCon) +-- * Unboxed sums (sumTyCon) +-- See Note [Infinite families of known-key names] in GHC.Builtin.Names +-- +-- See also Note [Known-key names] +wiredInTyCons :: [TyCon] + +wiredInTyCons = map (dataConTyCon . snd) boxingDataCons + ++ [ anyTyCon + , zonkAnyTyCon + , boolTyCon + , charTyCon + , stringTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , wordTyCon + , listTyCon + , orderingTyCon + , maybeTyCon + , heqTyCon + , eqTyCon + , coercibleTyCon + , typeSymbolKindCon + , runtimeRepTyCon + , levityTyCon + , vecCountTyCon + , vecElemTyCon + , constraintKindTyCon + , liftedTypeKindTyCon + , unliftedTypeKindTyCon + , unrestrictedFunTyCon + , multiplicityTyCon + , naturalTyCon + , integerTyCon + , liftedRepTyCon + , unliftedRepTyCon + , zeroBitRepTyCon + , zeroBitTypeTyCon + ] + +mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName built_in modu fs unique tycon + = mkWiredInName modu (mkTcOccFS fs) unique + (ATyCon tycon) -- Relevant TyCon + built_in + +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name +mkWiredInDataConName built_in modu fs unique datacon + = mkWiredInName modu (mkDataOccFS fs) unique + (AConLike (RealDataCon datacon)) -- Relevant DataCon + built_in + +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +eqTyConName, eqDataConName, eqSCSelIdName :: Name +eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon +eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon +eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId + +eqTyCon_RDR :: RdrName +eqTyCon_RDR = nameRdrName eqTyConName + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +heqTyConName, heqDataConName, heqSCSelIdName :: Name +heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon +heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon +heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId + +-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs +coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name +coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon +coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon +coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId + +charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name +charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon +stringTyConName = mkWiredInTyConName UserSyntax gHC_INTERNAL_BASE (fsLit "String") stringTyConKey stringTyCon +intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon + +boolTyConName, falseDataConName, trueDataConName :: Name +boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon + +listTyConName, nilDataConName, consDataConName :: Name +listTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "List") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + +maybeTyConName, nothingDataConName, justDataConName :: Name +maybeTyConName = mkWiredInTyConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Maybe") + maybeTyConKey maybeTyCon +nothingDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Nothing") + nothingDataConKey nothingDataCon +justDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Just") + justDataConKey justDataCon + +wordTyConName, wordDataConName, word8DataConName :: Name +wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon +wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon +word8DataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_WORD (fsLit "W8#") word8DataConKey word8DataCon + +floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name +floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon +doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon + +-- Any + +{- +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructors `Any` and `ZonkAny` are closed type families declared thus: + + type family Any :: forall k. k where { } + type family ZonkAny :: forall k. Nat -> k where { } + +They are used when we want a type of a particular kind, but we don't really care +what that type is. The leading example is this: `ZonkAny` is used to instantiate +un-constrained type variables after type checking. For example, consider the +term (length [] :: Int), where + + length :: forall a. [a] -> Int + [] :: forall a. [a] + +We must type-apply `length` and `[]`, but to what type? It doesn't matter! +The typechecker will end up with + + length @alpha ([] @alpha) + +where `alpha` is an un-constrained unification variable. The "zonking" process zaps +that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is +arbitrary (see wrinkle (Any5) below). This is done in `GHC.Tc.Zonk.Type.commitFlexi`. +So we end up with + + length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3)) + +`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see +wrinkle (Any4). + +Wrinkles: + +(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may + need to use `ZonkAny` to fill in a type variable of some kind other than * + (see #959 for examples). + +(Any2) They are /closed/ type families, with no instances. For example, suppose that + with alpha :: '(k1, k2) we add a given coercion + g :: alpha ~ (Fst alpha, Snd alpha) + and we zonked alpha = ZonkAny @(k1,k2) n. Then, if `ZonkAny` was a /data/ type, + we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one + side and '(,) on the other. See also #9097 and #9636. + + See #25244 for a suggestion that we instead use an /open/ type family for which + you cannot provide instances. Probably the difference is not very important. + +(Any3) They do not claim to be /data/ types, and that's important for + the code generator, because the code gen may /enter/ a data value + but never enters a function value. + +(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/ + types (#24817). Consider + + data SBool a where { STrue :: SBool True; SFalse :: SBool False } + + foo :: forall a b. (SBool a, SBool b) + + bar :: Bool + bar = case foo @alpha @beta of + (STrue, SFalse) -> True -- This branch is not inaccessible! + _ -> False + + Now, what are `alpha` and `beta`? If we zonk both of them to the same type + `Any @Type`, the pattern-match checker will (wrongly) report that the first + branch is inaccessible. So we zonk them to two /different/ types: + alpha := ZonkAny @Type 4 and beta := ZonkAny @Type k 5 + (The actual numbers are arbitrary; they just need to differ.) + + The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and + `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to + make up a fresh type. + + If this example seems unconvincing (e.g. in this case foo must be bottom) + see #24817 for larger but more compelling examples. + +(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we + don't have a name environment (e.g. see Rules.matchRule for one example) + +(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that + it is available to users. For this reason it's treated like any other + wired-in type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + Currently `ZonkAny` is not available to users; but it could easily be. + +(Any7) Properties of `Any`: + * When `Any` is instantiated at a lifted type it is inhabited by at least one value, + namely bottom. + + * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`. + + * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`. + + * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when + the kinds of both the type and `Any` match. + + * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over + `unsafeCoerce#` as they prevent accidentally coercing between types with kinds + that don't match. + + See examples in ghc-prim:GHC.Types + +(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed, + following the same rationale of supressing warning about the unit type. + + For example, consider (#25895): + + do { forever (return ()); blah } + + where forever :: forall a b. IO a -> IO b + Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`. + But we certainly don't want to complain about a discarded do-binding. + +The Any tycon used to be quite magic, but we have since been able to +implement it merely with an empty kind polymorphic type family. See #10886 for a +bit of history. +-} + + +anyTyConName :: Name +anyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +-- See Note [Any types] +anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] + res_kind = mkTyVarTy (binderVar kv) + +anyTy :: Type +anyTy = mkTyConTy anyTyCon + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = mkTyConApp anyTyCon [kind] + +zonkAnyTyConName :: Name +zonkAnyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon + +zonkAnyTyCon :: TyCon +-- ZonkAnyTyCon :: forall k. Nat -> k +-- See Note [Any types] +zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName + [ mkNamedTyConBinder Specified kv + , mkAnonTyConBinder nat_kv ] + (mkTyVarTy kv) + Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy] + +-- | Make a fake, recovery 'TyCon' from an existing one. +-- Used when recovering from errors in type declarations +makeRecoveryTyCon :: TyCon -> TyCon +makeRecoveryTyCon tc + = mkTcTyCon (tyConName tc) + bndrs res_kind + noTcTyConScopedTyVars + True -- Fully generalised + flavour -- Keep old flavour + where + flavour = tyConFlavour tc + [kv] = mkTemplateKindVars [liftedTypeKind] + (bndrs, res_kind) + = case flavour of + PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) + _ -> (tyConBinders tc, tyConResKind tc) + -- For data types we have already validated their kind, so it + -- makes sense to keep it. For promoted data constructors we haven't, + -- so we recover with kind (forall k. k). Otherwise consider + -- data T a where { MkT :: Show a => T a } + -- If T is for some reason invalid, we don't want to fall over + -- at (promoted) use-sites of MkT. + +-- Kinds +typeSymbolKindConName :: Name +typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon + + +boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +stringTyCon_RDR = nameRdrName stringTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName + +{- +************************************************************************ +* * +\subsection{mkWiredInTyCon} +* * +************************************************************************ +-} + +-- This function assumes that the types it creates have all parameters at +-- Representational role, and that there is no kind polymorphism. +pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon name cType tyvars cons + = mkAlgTyCon name + (mkAnonTyConBinders tyvars) + liftedTypeKind + (map (const Representational) tyvars) + cType + [] -- No stupid theta + (mkDataTyConRhs cons) + (VanillaAlgTyCon (mkPrelTyConRepName name)) + False -- Not in GADT syntax + +pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon n univs tys + = pcRepPolyDataCon n univs noConcreteTyVars tys + +pcRepPolyDataCon :: Name -> [TyVar] -> ConcreteTyVars + -> [Type] -> TyCon -> DataCon +pcRepPolyDataCon n univs conc_tvs tys + = pcDataConWithFixity False n + univs + [] -- no ex_tvs + conc_tvs + univs -- the univs are precisely the user-written tyvars + [] -- No theta + (map linear tys) + +pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon +-- Used for data constructors whose arguments are all constraints. +-- Notably constraint tuples, Eq# etc. +pcDataConConstraint n univs theta + = pcDataConWithFixity False n + univs + [] -- No ex_tvs + noConcreteTyVars + univs -- The univs are precisely the user-written tyvars + theta -- All constraint arguments + [] -- No value arguments + +-- Used for RuntimeRep and friends; things with PromDataConInfo +pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon +pcSpecialDataCon dc_name arg_tys tycon rri + = pcDataConWithFixity' False dc_name + (dataConWorkerUnique (nameUnique dc_name)) rri + [] [] noConcreteTyVars [] [] (map linear arg_tys) tycon + +pcDataConWithFixity :: Bool -- ^ declared infix? + -> Name -- ^ datacon name + -> [TyVar] -- ^ univ tyvars + -> [TyCoVar] -- ^ ex tycovars + -> ConcreteTyVars + -- ^ concrete tyvars + -> [TyCoVar] -- ^ user-written tycovars + -> ThetaType + -> [Scaled Type] -- ^ args + -> TyCon + -> DataCon +pcDataConWithFixity infx n = pcDataConWithFixity' infx n + (dataConWorkerUnique (nameUnique n)) NoPromInfo +-- The Name's unique is the first of two free uniques; +-- the first is used for the datacon itself, +-- the second is used for the "worker name" +-- +-- To support this the mkPreludeDataConUnique function "allocates" +-- one DataCon unique per pair of Ints. + +pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo + -> [TyVar] -> [TyCoVar] + -> ConcreteTyVars + -> [TyCoVar] + -> ThetaType -> [Scaled Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. +-- +-- IMPORTANT NOTE: +-- if you try to wire-in a /GADT/ data constructor you will +-- find it hard (we did). You will need wrapper and worker +-- Names, a DataConBoxer, DataConRep, EqSpec, etc. +-- Try hard not to wire-in GADT data types. You will live +-- to regret doing so (we do). + +pcDataConWithFixity' declared_infix dc_name wrk_key rri + tyvars ex_tyvars conc_tyvars user_tyvars theta arg_tys tycon + = data_con + where + tag_map = mkTyConTagMap tycon + -- This constructs the constructor Name to ConTag map once per + -- constructor, which is quadratic. It's OK here, because it's + -- only called for wired in data types that don't have a lot of + -- constructors. It's also likely that GHC will lift tag_map, since + -- we call pcDataConWithFixity' with static TyCons in the same module. + -- See Note [Constructor tag allocation] and #14657 + data_con = mkDataCon dc_name declared_infix prom_info + (map (const no_bang) arg_tys) + (map (const HsLazy) arg_tys) + (map (const NotMarkedStrict) arg_tys) + [] -- No labelled fields + tyvars ex_tyvars + conc_tyvars + (mkTyVarBinders Specified user_tyvars) + [] -- No equality spec + theta + arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) + rri + tycon + (lookupNameEnv_NF tag_map dc_name) + [] -- No stupid theta + (mkDataConWorkId wrk_name data_con) + NoDataConRep -- Wired-in types are too simple to need wrappers + + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + wrk_name = mkDataConWorkerName data_con wrk_key + + prom_info = mkPrelTyConRepName dc_name + +mkDataConWorkerName :: DataCon -> Unique -> Name +mkDataConWorkerName data_con wrk_key = + mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + where + modu = assert (isExternalName dc_name) $ + nameModule dc_name + dc_name = dataConName data_con + dc_occ = nameOccName dc_name + wrk_occ = mkDataConWorkerOcc dc_occ + + +{- +************************************************************************ +* * + Symbol +* * +************************************************************************ +-} + +typeSymbolKindCon :: TyCon +-- data Symbol +typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] + +typeSymbolKind :: Kind +typeSymbolKind = mkTyConTy typeSymbolKindCon + + +{- +************************************************************************ +* * + Stuff for dealing with tuples +* * +************************************************************************ + +Note [How tuples work] +~~~~~~~~~~~~~~~~~~~~~~ +* There are three families of tuple TyCons and corresponding + DataCons, expressed by the type BasicTypes.TupleSort: + data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple + +* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon + +* BoxedTuples + - A wired-in type + - Data type declarations in GHC.Tuple + - The data constructors really have an info table + +* UnboxedTuples + - A wired-in type + - Data type declarations in GHC.Types + but no actual declaration and no info table + +* ConstraintTuples + - A wired-in type. + - Declared as classes in GHC.Classes, e.g. + class (c1,c2) => CTuple2 c1 c2 + - Given constraints: the superclasses automatically become available + - Wanted constraints: there is a built-in instance + instance (c1,c2) => CTuple2 c1 c2 + See GHC.Tc.Instance.Class.matchCTuple + - Currently just go up to 64; beyond that + you have to use manual nesting + - Unlike BoxedTuples and UnboxedTuples, which only wire + in type constructors and data constructors, ConstraintTuples also wire in + superclass selector functions. For instance, $p1CTuple2 and $p2CTuple2 are + the selectors for the binary constraint tuple. + - The parenthesis syntax for grouping constraints in contexts is not treated + as a constraint tuple. The parser starts with a tuple type, then a + postprocessing action extracts the individual constraints as a list and + stores them in the context field of types like HsQualTy. + +* In quite a lot of places things are restricted just to + BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish + E.g. tupleTyCon has a Boxity argument + +* When looking up an OccName in the original-name cache + (GHC.Types.Name.Cache.lookupOrigNameCache), we spot the tuple OccName to make + sure we get the right wired-in name. + +* Serialization to interface files works via the usual mechanism for known-key + things: instead of serializing the OccName we just serialize the key. During + deserialization we lookup the Name associated with the unique with the logic + in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details. + +See also Note [Known-key names] in GHC.Builtin.Names. + +Note [One-tuples] +~~~~~~~~~~~~~~~~~ +GHC supports both boxed and unboxed one-tuples: + - Unboxed one-tuples are sometimes useful when returning a + single value after CPR analysis + - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when + there is just one binder +Basically it keeps everything uniform. + +However the /naming/ of the type/data constructors for one-tuples is a +bit odd: + 3-tuples: Tuple3 (,,)# + 2-tuples: Tuple2 (,)# + 1-tuples: ?? + 0-tuples: Unit ()# + +Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#' +for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: + data Unit = () + data Solo a = MkSolo a + data Tuple2 a b = (a,b) + +There is no way to write a boxed one-tuple in Haskell using tuple syntax. +They can, however, be written using other methods: + +1. They can be written directly by importing them from GHC.Tuple. +2. They can be generated by way of Template Haskell or in `deriving` code. + +There is nothing special about one-tuples in Core; in particular, they have no +custom pretty-printing, just using `Solo`. + +See also Note [Flattening one-tuples] in GHC.Core.Make and +Note [Don't flatten tuples from HsSyn] in GHC.Core.Make. + +Note [isBuiltInOcc_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +`isBuiltInOcc_maybe` matches and resolves names that are occurrences of built-in +syntax, i.e. unqualified names that can be unambiguously resolved even without +knowing what's currently in scope (such names also can't be imported, exported, +or redefined in another module). +More on that in Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache. + +In GHC, there are two use cases for `isBuiltInOcc_maybe`: + +1. Making TH's `mkName` work with built-in syntax, + e.g. $(conT (mkName "[]")) is the same as [] + +2. Detecting bulit-in syntax in `infix` declarations, + e.g. users can't write `infixl 6 :` (#15233) + +The parser takes a shortcut and produces Exact RdrNames directly, +so it doesn't need to match on an OccName with isBuiltInOcc_maybe. + +And here are the properties of `isBuiltInOcc_maybe`: + +* The set of names recognized by `isBuiltInOcc_maybe` is essentialy the + same as the set of names that the parser resolves to Exact RdrNames, + e.g. "[]", "(,)", or "->". + + We could leave it at that, but we also recognize unboxed sum syntax + "(#|#)" even though the parser can't handle it. This makes TH's `mkName` + more permissive than the parser. + +* The namespace of the input OccName is treated as a hint, not a + requirement. For example, + + mkOccName dataName ":" maps to consDataConName + mkOccName tcClsName ":" /also/ maps to consDataConName + + The rationale behind this is that with DataKind or RequiredTypeArguments + we may get an OccName with the wrong namespace and need to fallback to the + other one. + +* There is a `listTuplePuns :: Bool` parameter to account for the + ListTuplePuns extension. It has /no/ effect on whether the predicate + matches (i.e. if the result is Just or Nothing), but it can influence + which name is returned (TyCon name or DataCon name). For example, + + isBuiltInOcc_maybe False (mkOccName dataName "[]") == Just nilDataConName + isBuiltInOcc_maybe False (mkOccName tcClsName "[]") == Just nilDataConName + isBuiltInOcc_maybe True (mkOccName dataName "[]") == Just nilDataConName + isBuiltInOcc_maybe True (mkOccName tcClsName "[]") == Just listTyConName + +* There is no `Module` parameter because we are matching unqualified + occurrences of built-in names. It is illegal to qualify built-in syntax, + e.g. GHC.Types.(,) is a parse error. + +* The /input/ to `isBuiltInOcc_maybe` needs to be built-in syntax for the + predicate to match, but the /output/ is not necessarily built-in syntax. + For example, + + 1) input: mkTcOcc "[]" -- built-in syntax + output: Just listTyConName -- user syntax (GHC.Types.List) + + 2) input: mkDataOcc "[]" -- built-in syntax + output: Just nilDataConName -- built-in syntax [] + + 3) input: mkTcOcc "List" -- user syntax + output: Nothing -- no match + + 4) input: mkTcOcc "(,)" -- built-in syntax + output: Just (tupleTyConName BoxedTuple 2) -- user syntax (GHC.Types.Tuple2) + + 5) input: mkTcOcc "(#|#)" -- built-in syntax + output: Just (unboxedSumTyConName 2) -- user syntax (GHC.Types.Sum2#) + + Therefore, `GHC.Types.Name.isBuiltInSyntax` may or may not hold for the name + returned by `isBuiltInOcc_maybe`. +-} + +-- | Match on built-in syntax as it occurs at use sites. +-- See Note [isBuiltInOcc_maybe] +isBuiltInOcc_maybe :: Bool -> OccName -> Maybe Name +isBuiltInOcc_maybe listTuplePuns occ + | fs == "->" = Just unrestrictedFunTyConName + | fs == "[]" = Just (pun listTyConName nilDataConName) + | fs == ":" = Just consDataConName + | Just n <- (is_boxed_tup_syntax fs) = Just (tup_name Boxed n) + | Just n <- (is_unboxed_tup_syntax fs) = Just (tup_name Unboxed n) + | Just n <- (is_unboxed_sum_type_syntax fs) = Just (unboxedSumTyConName n) + | Just (k, n) <- (is_unboxed_sum_data_syntax fs) = Just (unboxedSumDataConName k n) + | otherwise = Nothing + where + fs = occNameFS occ + ns = occNameSpace occ + + pun :: Name -> Name -> Name + pun p n + | listTuplePuns, isTcClsNameSpace ns = p + | otherwise = n + + tup_name :: Boxity -> Arity -> Name + tup_name boxity arity + = pun (tyConName (tupleTyCon boxity arity)) + (dataConName (tupleDataCon boxity arity)) + +-- | Check if the OccName is an occurrence of built-in syntax. +-- +-- This is a variant of `isBuiltInOcc_maybe` that returns a `Bool`. +-- See Note [isBuiltInOcc_maybe] +-- +-- `isBuiltInOcc` holds for: +-- * function arrow `->` +-- * list syntax `[]`, `:` +-- * boxed tuple syntax `()`, `(,)`, `(,,)`, `(,,,)`, ... +-- * unboxed tuple syntax `(##)`, `(#,#)`, `(#,,#)`, ... +-- * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ... +-- * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ... +isBuiltInOcc :: OccName -> Bool +isBuiltInOcc = isJust . isBuiltInOcc_maybe listTuplePuns + where + listTuplePuns = False + -- True/False here is inconsequential because ListTuplePuns doesn't affect + -- whether isBuiltInOcc_maybe matches. See Note [isBuiltInOcc_maybe] + +-- Match on original names of infinite families (tuples and sums). +-- See Note [Infinite families of known-key names] in GHC.Builtin.Names +isInfiniteFamilyOrigName_maybe :: Module -> OccName -> Maybe Name +isInfiniteFamilyOrigName_maybe mod occ = + + -- Tuples, boxed and unboxed + isTupleTyOrigName_maybe mod occ + <|> isTupleDataOrigName_maybe mod occ + + -- Constraint tuples + <|> isCTupleOrigName_maybe mod occ + + -- Unboxed sums + <|> isSumTyOrigName_maybe mod occ + <|> isSumDataOrigName_maybe mod occ + +-- Check if the string has form "()", "(,)", "(,,)", etc, +-- and return the corresponding tuple arity. +is_boxed_tup_syntax :: FastString -> Maybe Arity +is_boxed_tup_syntax fs + | fs == "()" = Just 0 + | n >= 2 + , SBS.unsafeIndex sbs 0 == 40 -- ord '(' + , SBS.unsafeIndex sbs (n-1) == 41 -- ord ')' + , sbs_all sbs 1 (n-1) 44 -- ord ',' + = Just (n-1) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_boxed_tup_syntax _ = Nothing + +-- Check if the string has form "(##)", "(# #)", (#,#)", "(#,,#)", etc, +-- and return the corresponding tuple arity. +is_unboxed_tup_syntax :: FastString -> Maybe Arity +is_unboxed_tup_syntax fs + | fs == "(##)" = Just 0 + | fs == "(# #)" = Just 1 + | sbs_unboxed sbs + , sbs_all sbs 2 (n-2) 44 -- ord ',' + = Just (n-3) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_unboxed_tup_syntax _ = Nothing + +-- Check if the string has form "(#|#)", "(#||#)", (#|||#)", etc, +-- and return the corresponding sum arity. +is_unboxed_sum_type_syntax :: FastString -> Maybe Arity +is_unboxed_sum_type_syntax fs + | sbs_unboxed sbs + , Just k <- sbs_pipes sbs 2 (n-2) + , k > 0 + = Just (k+1) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_unboxed_sum_type_syntax _ = Nothing + +-- Check if the string has form "(#_|#)", "(#_||#)", (#|_|#)", etc, +-- and return the corresponding sum tag and sum arity. +is_unboxed_sum_data_syntax :: FastString -> Maybe (ConTag, Arity) +is_unboxed_sum_data_syntax fs + | sbs_unboxed sbs + , Just u <- SBS.elemIndex 95 sbs -- ord '_' + , Just k1 <- sbs_pipes sbs 2 u -- pipes to the left of '_' + , Just k2 <- sbs_pipes sbs (u+1) (n-2) -- pipes to the right of '_' + = Just (k1+1, k1+k2+1) + where + n = SBS.length sbs -- O(1) + sbs = fastStringToShortByteString fs -- O(1) field access +is_unboxed_sum_data_syntax _ = Nothing + +-- (sbs_all sbs i n x) checks if all bytes in the slice [i..n) are equal to x. +sbs_all :: SBS.ShortByteString -> Int -> Int -> Word8 -> Bool +sbs_all !sbs !i !n !x + | i < n = SBS.unsafeIndex sbs i == x && sbs_all sbs (i+1) n x + | otherwise = True + +-- (sbs_pipes sbs i n) checks if all bytes in the slice [i..n) are equal to '|' +-- or ' ', and returns the number of encountered '|'. +sbs_pipes :: SBS.ShortByteString -> Int -> Int -> Maybe Int +sbs_pipes !sbs = go 0 + where + go :: Int -> Int -> Int -> Maybe Int + go !k !i !n + | i < n = + if | SBS.unsafeIndex sbs i == 124 -> go (k+1) (i+1) n -- ord '|' + | SBS.unsafeIndex sbs i == 32 -> go k (i+1) n -- ord ' ' + | otherwise -> Nothing + | otherwise = Just k + +-- (sbs_unboxed sbs) checks if the string starts with "(#" and ends with "#)". +sbs_unboxed :: SBS.ShortByteString -> Bool +sbs_unboxed !sbs = + n >= 4 && SBS.unsafeIndex sbs 0 == 40 -- ord '(' + && SBS.unsafeIndex sbs 1 == 35 -- ord '#' + && SBS.unsafeIndex sbs (n-2) == 35 -- ord '#' + && SBS.unsafeIndex sbs (n-1) == 41 -- ord ')' + where + n = SBS.length sbs -- O(1) + +-- (sbs_Sum sbs) checks if the string has form "SumN#" or "SumNM#", +-- where "N" or "NM" is a decimal numeral in the [2..mAX_SUM_SIZE] range. +sbs_Sum :: SBS.ShortByteString -> Maybe Arity +sbs_Sum !sbs + | n >= 3 && SBS.unsafeIndex sbs 0 == 83 -- ord 'S' + && SBS.unsafeIndex sbs 1 == 117 -- ord 'u' + && SBS.unsafeIndex sbs 2 == 109 -- ord 'm' + , Just (Unboxed, arity) <- sbs_arity_boxity sbs 3 + , arity >= 2, arity <= mAX_SUM_SIZE + = Just arity + | otherwise = Nothing + where + n = SBS.length sbs -- O(1) + +-- (sbs_Tuple sbs) checks if the string has form "TupleN", "TupleNM", "TupleN#" or "TupleNM#", +-- where "N" or "NM" is a decimal numeral in the [2..mAX_TUPLE_SIZE] range. +sbs_Tuple :: SBS.ShortByteString -> Maybe (Boxity, Arity) +sbs_Tuple !sbs + | n >= 5 && SBS.unsafeIndex sbs 0 == 84 -- ord 'T' + && SBS.unsafeIndex sbs 1 == 117 -- ord 'u' + && SBS.unsafeIndex sbs 2 == 112 -- ord 'p' + && SBS.unsafeIndex sbs 3 == 108 -- ord 'l' + && SBS.unsafeIndex sbs 4 == 101 -- ord 'e' + , Just r@(_, arity) <- sbs_arity_boxity sbs 5 + , arity >= 2, arity <= mAX_TUPLE_SIZE + = Just r + | otherwise = Nothing + where + n = SBS.length sbs -- O(1) + +-- (sbs_CTuple sbs) checks if the string has form "CTupleN" or "CTupleNM", +-- where "N" or "NM" is a decimal numeral in the [2..mAX_CTUPLE_SIZE] range. +sbs_CTuple :: SBS.ShortByteString -> Maybe Arity +sbs_CTuple !sbs + | n >= 6 && SBS.unsafeIndex sbs 0 == 67 -- ord 'C' + && SBS.unsafeIndex sbs 1 == 84 -- ord 'T' + && SBS.unsafeIndex sbs 2 == 117 -- ord 'u' + && SBS.unsafeIndex sbs 3 == 112 -- ord 'p' + && SBS.unsafeIndex sbs 4 == 108 -- ord 'l' + && SBS.unsafeIndex sbs 5 == 101 -- ord 'e' + , Just (Boxed, arity) <- sbs_arity_boxity sbs 6 + , arity >= 2, arity <= mAX_CTUPLE_SIZE + = Just arity + | otherwise = Nothing + where + n = SBS.length sbs -- O(1) + +-- (sbs_arity_boxity sbs i) parses bytes from position `i` to the end, +-- matching single- and double-digit decimals numerals (i.e. from 0 to 99) +-- possibly followed by '#'. See Note [Small Ints parsing] +sbs_arity_boxity :: SBS.ShortByteString -> Int -> Maybe (Boxity, Arity) +sbs_arity_boxity !sbs !i = + case n - i of -- bytes to parse + 1 -> parse1 (SBS.unsafeIndex sbs i) + 2 -> parse2 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) + 3 -> parse3 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) (SBS.unsafeIndex sbs (i+2)) + _ -> Nothing + where + n = SBS.length sbs -- O(1) + + is_digit :: Word8 -> Bool + is_digit x = x >= 48 && x <= 57 -- between (ord '0') and (ord '9') + + from_digit :: Word8 -> Int + from_digit x = fromIntegral (x - 48) + + -- single-digit number + parse1 :: Word8 -> Maybe (Boxity, Arity) + parse1 x1 | is_digit x1 = Just (Boxed, from_digit x1) + parse1 _ = Nothing + + -- double-digit number, or a single-digit number followed by '#' + parse2 :: Word8 -> Word8 -> Maybe (Boxity, Arity) + parse2 x1 35 -- ord '#' + | is_digit x1 = Just (Unboxed, from_digit x1) + parse2 x1 x2 + | is_digit x1, is_digit x2 + = Just (Boxed, from_digit x1 * 10 + from_digit x2) + parse2 _ _ = Nothing + + -- double-digit number followed by '#' + parse3 :: Word8 -> Word8 -> Word8 -> Maybe (Boxity, Arity) + parse3 x1 x2 35 -- ord '#' + | is_digit x1, is_digit x2 + = Just (Unboxed, from_digit x1 * 10 + from_digit x2) + parse3 _ _ _ = Nothing + +-- Identify original names of boxed and unboxed tuple type constructors. +-- Examples: +-- 0b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Unit") = Just +-- 1b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Solo") = Just +-- 2b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple2") = Just +-- 0u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Unit#") = Just +-- 1u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Solo#") = Just +-- 2u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple2#") = Just +-- ... +-- 64b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple64") = Just +-- 64u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple64#") = Just +-- +-- Non-examples: "()", "(##)", "(,)", "(#,#)", "(,,)", "(#,,#)", etc. +-- As far as tuple /types/ are concerned, these are not the original names +-- but rather punned names under ListTuplePuns. +-- +-- Also non-examples: "Tuple0", "Tuple0#", "Tuple1", and "Tuple1#". +-- These are merely type synonyms for "Unit", "Unit#", "Solo", and "Solo#". +isTupleTyOrigName_maybe :: Module -> OccName -> Maybe Name +isTupleTyOrigName_maybe mod occ + | mod == gHC_INTERNAL_TUPLE = match_occ_boxed + | mod == gHC_TYPES = match_occ_unboxed + where + fs = occNameFS occ + ns = occNameSpace occ + sbs = fastStringToShortByteString fs -- O(1) field access + + match_occ_boxed + | occ == occName unitTyConName = Just unitTyConName + | occ == occName soloTyConName = Just soloTyConName + | isTcClsNameSpace ns, Just (boxity@Boxed, n) <- sbs_Tuple sbs, n >= 2 + = Just (tyConName (tupleTyCon boxity n)) + | otherwise = Nothing + + match_occ_unboxed + | occ == occName unboxedUnitTyConName = Just unboxedUnitTyConName + | occ == occName unboxedSoloTyConName = Just unboxedSoloTyConName + | isTcClsNameSpace ns, Just (boxity@Unboxed, n) <- sbs_Tuple sbs, n >= 2 + = Just (tyConName (tupleTyCon boxity n)) + | otherwise = Nothing + +isTupleTyOrigName_maybe _ _ = Nothing + +-- Identify original names of boxed and unboxed tuple data constructors. +-- Examples: +-- 0b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "()") = Just +-- 1b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "MkSolo") = Just +-- 2b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "(,)") = Just +-- ... +-- 0u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(##)") = Just +-- 1u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "MkSolo#") = Just +-- 2u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(#,#)") = Just +-- ... +-- +-- Non-examples: Tuple or Tuple#, as this is the name format of tuple /type/ constructors. +isTupleDataOrigName_maybe :: Module -> OccName -> Maybe Name +isTupleDataOrigName_maybe mod occ + | mod == gHC_INTERNAL_TUPLE = match_occ_boxed + | mod == gHC_TYPES = match_occ_unboxed + where + match_occ_boxed + | occ == occName soloDataConName = Just soloDataConName + | isDataConNameSpace ns, Just n <- (is_boxed_tup_syntax fs) + = Just (tupleDataConName Boxed n) + | otherwise = Nothing + match_occ_unboxed + | occ == occName unboxedSoloDataConName = Just unboxedSoloDataConName + | isDataConNameSpace ns, Just n <- (is_unboxed_tup_syntax fs) + = Just (tupleDataConName Unboxed n) + | otherwise = Nothing + fs = occNameFS occ + ns = occNameSpace occ +isTupleDataOrigName_maybe _ _ = Nothing + +-- Identify original names of constraint tuples. +-- Examples: +-- 0) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CUnit") = Just +-- 1) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CSolo") = Just +-- 2) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple2") = Just +-- ... +-- 64) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple64") = Just +-- +-- Non-examples: "()", "(,)", "(,,)", etc. +-- As far as constraint tuples are concerned, these are not the original names +-- but rather punned names under ListTuplePuns. +-- +-- Also non-examples: "CTuple0" and "CTuple1". +-- These are merely type synonyms for "CUnit" and "CSolo". +isCTupleOrigName_maybe :: Module -> OccName -> Maybe Name +isCTupleOrigName_maybe mod occ + | mod == gHC_CLASSES + = match_occ + where + fs = occNameFS occ + sbs = fastStringToShortByteString fs -- O(1) field access + match_occ + | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0) -- CUnit + | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1) -- CSolo + + | Just num <- sbs_CTuple sbs, num >= 2 + = Just $ cTupleTyConName num + + | otherwise = Nothing + +isCTupleOrigName_maybe _ _ = Nothing + +-- Identify original names of unboxed sum type constructors. +-- Examples: +-- 2) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum2#") = Just +-- 3) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum3#") = Just +-- 4) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum4#") = Just +-- ... +-- 64) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum64#") = Just +-- +-- Non-examples: "(#|#)", "(#||#)", "(#|||#)", etc. These are not valid syntax. +-- Also non-examples: "Sum0#", "Sum1#". These do not exist. +isSumTyOrigName_maybe :: Module -> OccName -> Maybe Name +isSumTyOrigName_maybe mod occ + | mod == gHC_TYPES + , isTcClsNameSpace ns + , Just n <- sbs_Sum sbs + , n >= 2 + = Just (tyConName (sumTyCon n)) + where + fs = occNameFS occ + ns = occNameSpace occ + sbs = fastStringToShortByteString fs -- O(1) field access +isSumTyOrigName_maybe _ _ = Nothing + +-- Identify original names of unboxed sum data constructors. +-- "(#_|#)", "(#_||#)", (#|_|#)" +-- +-- Examples: +-- 1/2) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_|#)") = Just +-- 1/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_||#)") = Just +-- 2/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#|_|#)") = Just +-- ... +-- +-- Non-examples: Sum#, as this is the name format of unboxed sum /type/ constructors. +isSumDataOrigName_maybe :: Module -> OccName -> Maybe Name +isSumDataOrigName_maybe mod occ + | mod == gHC_TYPES + , isDataConNameSpace ns + , Just (k,n) <- (is_unboxed_sum_data_syntax fs) + = Just (unboxedSumDataConName k n) + where fs = occNameFS occ + ns = occNameSpace occ +isSumDataOrigName_maybe _ _ = Nothing + +{- +Note [Small Ints parsing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, tuples in Haskell have a maximum arity of 64. +To parse strings of length 1 and 2 more efficiently, we +can utilize an ad-hoc solution that matches their characters. +This results in a speedup of up to 40 times compared to using +`readMaybe @Int` on my machine. +-} + +mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax) +mkTupleOcc ns b ar = (mkOccName ns str, built_in) + where (str, built_in) = mkTupleStr' ns b ar + +mkCTupleOcc :: NameSpace -> Arity -> OccName +mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) + +mkTupleStr :: Boxity -> NameSpace -> Arity -> String +mkTupleStr b ns ar = str + where (str, _) = mkTupleStr' ns b ar + +mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax) +mkTupleStr' ns Boxed 0 + | isDataConNameSpace ns = ("()", BuiltInSyntax) + | otherwise = ("Unit", UserSyntax) +mkTupleStr' ns Boxed 1 + | isDataConNameSpace ns = ("MkSolo", UserSyntax) -- See Note [One-tuples] + | otherwise = ("Solo", UserSyntax) +mkTupleStr' ns Boxed ar + | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax) + | otherwise = ("Tuple" ++ showInt ar "", UserSyntax) +mkTupleStr' ns Unboxed 0 + | isDataConNameSpace ns = ("(##)", BuiltInSyntax) + | otherwise = ("Unit#", UserSyntax) +mkTupleStr' ns Unboxed 1 + | isDataConNameSpace ns = ("MkSolo#", UserSyntax) -- See Note [One-tuples] + | otherwise = ("Solo#", UserSyntax) +mkTupleStr' ns Unboxed ar + | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax) + | otherwise = ("Tuple" ++ show ar ++ "#", UserSyntax) + +mkConstraintTupleStr :: Arity -> String +mkConstraintTupleStr 0 = "CUnit" +mkConstraintTupleStr 1 = "CSolo" +mkConstraintTupleStr ar = "CTuple" ++ show ar + +commas :: Arity -> String +commas ar = replicate (ar-1) ',' + +cTupleTyCon :: Arity -> TyCon +cTupleTyCon i + | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially + | otherwise = fstOf3 (cTupleArr ! i) + +cTupleTyConName :: Arity -> Name +cTupleTyConName a = tyConName (cTupleTyCon a) + +cTupleTyConNames :: [Name] +cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleTyConKeys :: UniqueSet +cTupleTyConKeys = fromListUniqueSet $ map getUnique cTupleTyConNames + +isCTupleTyConName :: Name -> Bool +isCTupleTyConName n + = assertPpr (isExternalName n) (ppr n) $ + getUnique n `memberUniqueSet` cTupleTyConKeys + +cTupleDataCon :: Arity -> DataCon +cTupleDataCon i + | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially + | otherwise = sndOf3 (cTupleArr ! i) + +cTupleDataConName :: Arity -> Name +cTupleDataConName i = dataConName (cTupleDataCon i) + +cTupleDataConNames :: [Name] +cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleSelId :: ConTag -- Superclass position + -> Arity -- Arity + -> Id +cTupleSelId sc_pos arity + | sc_pos > arity + = panic ("cTupleSelId: index out of bounds: superclass position: " + ++ show sc_pos ++ " > arity " ++ show arity) + + | sc_pos <= 0 + = panic ("cTupleSelId: Superclass positions start from 1. " + ++ "(superclass position: " ++ show sc_pos + ++ ", arity: " ++ show arity ++ ")") + + | arity < 1 + = panic ("cTupleSelId: Arity starts from 1. " + ++ "(superclass position: " ++ show sc_pos + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_CTUPLE_SIZE + = thdOf3 (mk_ctuple arity) ! (sc_pos - 1) -- Build one specially + + | otherwise + = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1) + +cTupleSelIdName :: ConTag -- Superclass position + -> Arity -- Arity + -> Name +cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity) + +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleTyConName :: TupleSort -> Arity -> Name +tupleTyConName ConstraintTuple a = cTupleTyConName a +tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) +tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) + +promotedTupleDataCon :: Boxity -> Arity -> TyCon +promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) + +tupleDataCon :: Boxity -> Arity -> DataCon +tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleDataCon Boxed i = snd (boxedTupleArr ! i) +tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) + +tupleDataConName :: Boxity -> Arity -> Name +tupleDataConName sort i = dataConName (tupleDataCon sort i) + +mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type +mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2] + +isPromotedPairType :: Type -> Maybe (Type, Type) +isPromotedPairType t + | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t + , tc == promotedTupleDataCon Boxed 2 + = Just (x, y) + | otherwise = Nothing + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] + +-- | Cached type constructors, data constructors, and superclass selectors for +-- constraint tuples. The outer array is indexed by the arity of the constraint +-- tuple and the inner array is indexed by the superclass position. +cTupleArr :: Array Int (TyCon, DataCon, Array Int Id) +cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]] + +-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed +-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type +-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep +-- [IntRep, LiftedRep])@ +unboxedTupleSumKind :: TyCon -> [Type] -> Kind +unboxedTupleSumKind tc rr_tys + = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + +-- | Specialization of 'unboxedTupleSumKind' for tuples +unboxedTupleKind :: [Type] -> Kind +unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple Boxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con + BoxedTuple flavour + + tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) + tc_res_kind = liftedTypeKind + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + dc_arg_tys = mkTyVarTys dc_tvs + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Boxed + modu = gHC_INTERNAL_TUPLE + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_tuple Unboxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con + UnboxedTuple flavour + + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2]) + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map mkTYPEapp ks) + + tc_res_kind = unboxedTupleKind rr_tys + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + (rr_tvs, dc_arg_tvs) = splitAt arity dc_tvs + rr_tys = mkTyVarTys rr_tvs + dc_arg_tys = mkTyVarTys dc_arg_tvs + tuple_con = pcRepPolyDataCon dc_name dc_tvs conc_tvs dc_arg_tys tycon + conc_tvs = + mkNameEnv + [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedTuple pos) + | rr_tv <- rr_tvs + | ty <- dc_arg_tys + | pos <- [1..arity] ] + + boxity = Unboxed + modu = gHC_TYPES + tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in + where (occ, built_in) = mkTupleOcc tcName boxity arity + dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in + where (occ, built_in) = mkTupleOcc dataName boxity arity + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id) +mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr) + where + tycon = mkClassTyCon tc_name binders roles + rhs klass + (mkPrelTyConRepName tc_name) + + klass = mk_ctuple_class tycon sc_theta sc_sel_ids + tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon + + binders = mkTemplateAnonTyConBinders (replicate arity constraintKind) + roles = replicate arity Nominal + rhs = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple} + + modu = gHC_CLASSES + tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq + (ATyCon tycon) UserSyntax + dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkCTupleTyConUnique arity + dc_uniq = mkCTupleDataConUnique arity + + tvs = binderVars binders + sc_theta = map mkTyVarTy tvs + sc_sel_ids = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]] + sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids + + mk_sc_sel_id sc_pos = + let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity + sc_sel_id_occ = mkCTupleOcc tcName arity + sc_sel_id_name = mkWiredInIdName + gHC_CLASSES + (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ)) + sc_sel_id_uniq + sc_sel_id + sc_sel_id = mkDictSelId sc_sel_id_name klass + + in sc_sel_id + +unitTyCon :: TyCon +unitTyCon = tupleTyCon Boxed 0 + +unitTyConName :: Name +unitTyConName = tyConName unitTyCon + +unitTyConKey :: Unique +unitTyConKey = getUnique unitTyCon + +unitDataCon :: DataCon +unitDataCon = head (tyConDataCons unitTyCon) + +unitDataConId :: Id +unitDataConId = dataConWorkId unitDataCon + +soloTyCon :: TyCon +soloTyCon = tupleTyCon Boxed 1 + +soloTyConName :: Name +soloTyConName = tyConName soloTyCon + +soloDataConName :: Name +soloDataConName = tupleDataConName Boxed 1 + +pairTyCon :: TyCon +pairTyCon = tupleTyCon Boxed 2 + +unboxedUnitTy :: Type +unboxedUnitTy = mkTyConTy unboxedUnitTyCon + +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon Unboxed 0 + +unboxedUnitTyConName :: Name +unboxedUnitTyConName = tyConName unboxedUnitTyCon + +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleDataCon Unboxed 0 + +unboxedSoloTyCon :: TyCon +unboxedSoloTyCon = tupleTyCon Unboxed 1 + +unboxedSoloTyConName :: Name +unboxedSoloTyConName = tyConName unboxedSoloTyCon + +unboxedSoloDataConName :: Name +unboxedSoloDataConName = tupleDataConName Unboxed 1 + +{- ********************************************************************* +* * + Unboxed sums +* * +********************************************************************* -} + +-- | OccName for n-ary unboxed sum type constructor. +mkSumTyConOcc :: Arity -> OccName +mkSumTyConOcc n = mkOccName tcName str + where + -- No need to cache these, the caching is done in mk_sum + str = "Sum" ++ show n ++ "#" + +-- | OccName for i-th alternative of n-ary unboxed sum data constructor. +mkSumDataConOcc :: ConTag -> Arity -> OccName +mkSumDataConOcc alt n = mkOccName dataName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)" + bars i = intersperse ' ' $ replicate i '|' + +-- | Type constructor for n-ary unboxed sum. +sumTyCon :: Arity -> TyCon +sumTyCon arity + | arity > mAX_SUM_SIZE + = fst (mk_sum arity) -- Build one specially + + | arity < 2 + = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") + + | otherwise + = fst (unboxedSumArr ! arity) + +unboxedSumTyConName :: Arity -> Name +unboxedSumTyConName arity = tyConName (sumTyCon arity) + +-- | Data constructor for i-th alternative of a n-ary unboxed sum. +sumDataCon :: ConTag -- Alternative + -> Arity -- Arity + -> DataCon +sumDataCon alt arity + | alt > arity + = panic ("sumDataCon: index out of bounds: alt: " + ++ show alt ++ " > arity " ++ show arity) + + | alt <= 0 + = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity < 2 + = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_SUM_SIZE + = snd (mk_sum arity) ! (alt - 1) -- Build one specially + + | otherwise + = snd (unboxedSumArr ! arity) ! (alt - 1) + +unboxedSumDataConName :: ConTag -> Arity -> Name +unboxedSumDataConName alt arity = dataConName (sumDataCon alt arity) + +-- | Cached type and data constructors for sums. The outer array is +-- indexed by the arity of the sum and the inner array is indexed by +-- the alternative. +unboxedSumArr :: Array Int (TyCon, Array Int DataCon) +unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] + +-- | Specialization of 'unboxedTupleSumKind' for sums +unboxedSumKind :: [Type] -> Kind +unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon + +-- | Create type constructor and data constructors for n-ary unboxed sum. +mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) +mk_sum arity = (tycon, sum_cons) + where + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons) + UnboxedSumTyCon + + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map mkTYPEapp ks) + + tyvars = binderVars tc_binders + + tc_res_kind = unboxedSumKind rr_tys + + (rr_tvs, dc_arg_tvs) = splitAt arity tyvars + rr_tys = mkTyVarTys rr_tvs + dc_arg_tys = mkTyVarTys dc_arg_tvs + + conc_tvs = + mkNameEnv + [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedSum (Just pos)) + | rr_tv <- rr_tvs + | ty <- dc_arg_tys + | pos <- [1..arity] ] + + tc_name = mkWiredInName gHC_TYPES (mkSumTyConOcc arity) tc_uniq + (ATyCon tycon) UserSyntax + + sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] + sum_con i = + let dc = pcRepPolyDataCon dc_name + tyvars -- univ tyvars + conc_tvs + [dc_arg_tys !! i] -- arg types + tycon + + dc_name = mkWiredInName gHC_TYPES + (mkSumDataConOcc i arity) + (dc_uniq i) + (AConLike (RealDataCon dc)) + BuiltInSyntax + in dc + + tc_uniq = mkSumTyConUnique arity + dc_uniq i = mkSumDataConUnique i arity + +{- +************************************************************************ +* * + Equality types and classes +* * +********************************************************************* -} + +-- See Note [The equality types story] in GHC.Builtin.Types.Prim +-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) +-- +-- It's tempting to put functional dependencies on (~~), but it's not +-- necessary because the functional-dependency coverage check looks +-- through superclasses, and (~#) is handled in that check. + +eqTyCon, heqTyCon, coercibleTyCon :: TyCon +eqClass, heqClass, coercibleClass :: Class +eqDataCon, heqDataCon, coercibleDataCon :: DataCon +eqSCSelId, heqSCSelId, coercibleSCSelId :: Id + +(eqTyCon, eqClass, eqDataCon, eqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon eqTyConName binders roles + rhs klass + (mkPrelTyConRepName eqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConConstraint eqDataConName tvs [sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + -- rhs: a DataTyCon, not a UnaryClassTyCon! Yes it has one + -- field, but it has unboxed type (a ~# b), + -- so the class must provide the box. + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) + sc_sel_id = mkDictSelId eqSCSelIdName klass + +(heqTyCon, heqClass, heqDataCon, heqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon heqTyConName binders roles + rhs klass + (mkPrelTyConRepName heqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConConstraint heqDataConName tvs [sc_pred] tycon + + -- Kind: forall k1 k2. k1 -> k2 -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + roles = [Nominal, Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + + tvs = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) + sc_sel_id = mkDictSelId heqSCSelIdName klass + +(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon coercibleTyConName binders roles + rhs klass + (mkPrelTyConRepName coercibleTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Representational, Representational] + rhs = mkDataTyConRhs [datacon] + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) + sc_sel_id = mkDictSelId coercibleSCSelIdName klass + +mk_class :: TyCon -> PredType -> Id -> Class +mk_class tycon sc_pred sc_sel_id + = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] + [] [] (mkAnd []) tycon + +mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class +mk_ctuple_class tycon sc_theta sc_sel_ids + = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids + [] [] (mkAnd []) tycon + +{- ********************************************************************* +* * + Multiplicity Polymorphism +* * +********************************************************************* -} + +{- Multiplicity polymorphism is implemented very similarly to representation + polymorphism. We write in the multiplicity kind and the One and Many + types which can appear in user programs. These are defined properly in GHC.Types. + +data Multiplicity = One | Many +-} + +multiplicityTyConName :: Name +multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity") + multiplicityTyConKey multiplicityTyCon + +oneDataConName, manyDataConName :: Name +oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon +manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon + +multiplicityTy :: Type +multiplicityTy = mkTyConTy multiplicityTyCon + +multiplicityTyCon :: TyCon +multiplicityTyCon = pcTyCon multiplicityTyConName Nothing [] + [oneDataCon, manyDataCon] + +oneDataCon, manyDataCon :: DataCon +oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon +manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon + +oneDataConTy, manyDataConTy :: Type +oneDataConTy = mkTyConTy oneDataConTyCon +manyDataConTy = mkTyConTy manyDataConTyCon + +oneDataConTyCon, manyDataConTyCon :: TyCon +oneDataConTyCon = promoteDataCon oneDataCon +manyDataConTyCon = promoteDataCon manyDataCon + +multMulTyConName :: Name +multMulTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon + +multMulTyCon :: TyCon +multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing + (BuiltInSynFamTyCon trivialBuiltInFamily) + Nothing + NotInjective + where + binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] + +------------------------ +-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). +-- TYPE rep1 -> TYPE rep2 -> Type +-- type (->) = FUN 'Many +unrestrictedFunTyCon :: TyCon +unrestrictedFunTyCon + = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] + (TyCoRep.TyConApp fUNTyCon [manyDataConTy]) + where + arrowKind = mkTyConKind binders liftedTypeKind + -- See also funTyCon + binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) + , Bndr runtimeRep2TyVar (NamedTCB Inferred) ] + ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty + , mkTYPEapp runtimeRep2Ty ] + +unrestrictedFunTyConName :: Name +unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->") + unrestrictedFunTyConKey unrestrictedFunTyCon + + +{- ********************************************************************* +* * + Type synonyms (all declared in ghc-prim:GHC.Types) + + type CONSTRAINT :: RuntimeRep -> Type -- primitive; cONSTRAINTKind + type Constraint = CONSTRAINT LiftedRep :: Type -- constraintKind + + type TYPE :: RuntimeRep -> Type -- primitive; tYPEKind + type Type = TYPE LiftedRep :: Type -- liftedTypeKind + type UnliftedType = TYPE UnliftedRep :: Type -- unliftedTypeKind + + type LiftedRep = BoxedRep Lifted :: RuntimeRep -- liftedRepTy + type UnliftedRep = BoxedRep Unlifted :: RuntimeRep -- unliftedRepTy + +* * +********************************************************************* -} + +-- For these synonyms, see +-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and +-- Note [Using synonyms to compress types] in GHC.Core.Type + +{- Note [Naked FunTy] +~~~~~~~~~~~~~~~~~~~~~ +GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument +flag and arg/res types. But when constructing the kinds of tYPETyCon and +cONSTRAINTTyCon we don't want to make these checks because + TYPE :: RuntimeRep -> Type +i.e. TYPE :: RuntimeRep -> TYPE LiftedRep + +so the check will loop infinitely. Hence the use of a naked FunTy +constructor in tTYPETyCon and cONSTRAINTTyCon. +-} + + +---------------------- +-- type Constraint = CONSTRAINT LiftedRep +constraintKindTyCon :: TyCon +constraintKindTyCon + = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy] + +constraintKindTyConName :: Name +constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") + constraintKindTyConKey constraintKindTyCon + +constraintKind :: Kind +constraintKind = mkTyConTy constraintKindTyCon + +---------------------- +-- type Type = TYPE LiftedRep +liftedTypeKindTyCon :: TyCon +liftedTypeKindTyCon + = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy] + +liftedTypeKindTyConName :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") + liftedTypeKindTyConKey liftedTypeKindTyCon + +liftedTypeKind, typeToTypeKind :: Type +liftedTypeKind = mkTyConTy liftedTypeKindTyCon +typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind + +---------------------- +-- type UnliftedType = TYPE ('BoxedRep 'Unlifted) +unliftedTypeKindTyCon :: TyCon +unliftedTypeKindTyCon + = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy] + +unliftedTypeKindTyConName :: Name +unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") + unliftedTypeKindTyConKey unliftedTypeKindTyCon + +unliftedTypeKind :: Type +unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon + + +{- ********************************************************************* +* * + data Levity = Lifted | Unlifted +* * +********************************************************************* -} + +levityTyConName, liftedDataConName, unliftedDataConName :: Name +levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon +liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon +unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon + +levityTyCon :: TyCon +levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon] + +levityTy :: Type +levityTy = mkTyConTy levityTyCon + +liftedDataCon, unliftedDataCon :: DataCon +liftedDataCon = pcSpecialDataCon liftedDataConName + [] levityTyCon (Levity Lifted) +unliftedDataCon = pcSpecialDataCon unliftedDataConName + [] levityTyCon (Levity Unlifted) + +liftedDataConTyCon :: TyCon +liftedDataConTyCon = promoteDataCon liftedDataCon + +unliftedDataConTyCon :: TyCon +unliftedDataConTyCon = promoteDataCon unliftedDataCon + +liftedDataConTy :: Type +liftedDataConTy = mkTyConTy liftedDataConTyCon + +unliftedDataConTy :: Type +unliftedDataConTy = mkTyConTy unliftedDataConTyCon + + +{- ********************************************************************* +* * + See Note [Wiring in RuntimeRep] + data RuntimeRep = VecRep VecCount VecElem + | TupleRep [RuntimeRep] + | SumRep [RuntimeRep] + | BoxedRep Levity + | IntRep | Int8Rep | ...etc... +* * +********************************************************************* -} + +{- Note [Wiring in RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, +making it a pain to wire in. To ease the pain somewhat, we use lists of +the different bits, like Uniques, Names, DataCons. These lists must be +kept in sync with each other. The rule is this: use the order as declared +in GHC.Types. All places where such lists exist should contain a reference +to this Note, so a search for this Note's name should find all the lists. + +See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. +-} + +runtimeRepTyCon :: TyCon +runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + -- Here we list all the data constructors + -- of the RuntimeRep data type + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : boxedRepDataCon : + runtimeRepSimpleDataCons) + +runtimeRepTy :: Type +runtimeRepTy = mkTyConTy runtimeRepTyCon + +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name +runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon + +vecRepDataConName = mk_runtime_rep_dc_name (fsLit "VecRep") vecRepDataConKey vecRepDataCon +tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon +sumRepDataConName = mk_runtime_rep_dc_name (fsLit "SumRep") sumRepDataConKey sumRepDataCon +boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon + +mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name +mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc + +boxedRepDataCon :: DataCon +boxedRepDataCon = pcSpecialDataCon boxedRepDataConName + [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in RepType + prim_rep_fun [lev] + = case tyConAppTyCon_maybe lev of + Just tc -> case tyConPromDataConInfo tc of + Levity l -> [BoxedRep (Just l)] + _ -> [BoxedRep Nothing] + Nothing -> [BoxedRep Nothing] + prim_rep_fun args + = pprPanic "boxedRepDataCon" (ppr args) + + +boxedRepDataConTyCon :: TyCon +boxedRepDataConTyCon = promoteDataCon boxedRepDataCon + +tupleRepDataCon :: DataCon +tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [rr_ty_list] + = concatMap (runtimeRepPrimRep doc) rr_tys + where + rr_tys = extractPromotedList rr_ty_list + doc = text "tupleRepDataCon" <+> ppr rr_tys + prim_rep_fun args + = pprPanic "tupleRepDataCon" (ppr args) + +tupleRepDataConTyCon :: TyCon +tupleRepDataConTyCon = promoteDataCon tupleRepDataCon + +sumRepDataCon :: DataCon +sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [rr_ty_list] + = map slotPrimRep (toList (ubxSumRepType prim_repss)) + where + rr_tys = extractPromotedList rr_ty_list + doc = text "sumRepDataCon" <+> ppr rr_tys + prim_repss = map (runtimeRepPrimRep doc) rr_tys + prim_rep_fun args + = pprPanic "sumRepDataCon" (ppr args) + +sumRepDataConTyCon :: TyCon +sumRepDataConTyCon = promoteDataCon sumRepDataCon + +-- See Note [Wiring in RuntimeRep] +-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType +runtimeRepSimpleDataCons :: [DataCon] +runtimeRepSimpleDataCons + = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys + [ (fsLit "IntRep", IntRep) + , (fsLit "Int8Rep", Int8Rep) + , (fsLit "Int16Rep", Int16Rep) + , (fsLit "Int32Rep", Int32Rep) + , (fsLit "Int64Rep", Int64Rep) + , (fsLit "WordRep", WordRep) + , (fsLit "Word8Rep", Word8Rep) + , (fsLit "Word16Rep", Word16Rep) + , (fsLit "Word32Rep", Word32Rep) + , (fsLit "Word64Rep", Word64Rep) + , (fsLit "AddrRep", AddrRep) + , (fsLit "FloatRep", FloatRep) + , (fsLit "DoubleRep", DoubleRep) ] + where + mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon + mk_runtime_rep_dc uniq (fs, primrep) + = data_con + where + data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + dc_name = mk_runtime_rep_dc_name fs uniq data_con + +-- See Note [Wiring in RuntimeRep] +intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType +[intRepDataConTy, + int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, + wordRepDataConTy, + word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy + ] + = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons + +---------------------- +-- | @type ZeroBitRep = 'Tuple '[] +zeroBitRepTyCon :: TyCon +zeroBitRepTyCon + = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + +zeroBitRepTyConName :: Name +zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") + zeroBitRepTyConKey zeroBitRepTyCon + +zeroBitRepTy :: RuntimeRepType +zeroBitRepTy = mkTyConTy zeroBitRepTyCon + +---------------------- +-- @type ZeroBitType = TYPE ZeroBitRep +zeroBitTypeTyCon :: TyCon +zeroBitTypeTyCon + = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs + where + rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] + +zeroBitTypeTyConName :: Name +zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") + zeroBitTypeTyConKey zeroBitTypeTyCon + +zeroBitTypeKind :: Type +zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon + +---------------------- +-- | @type LiftedRep = 'BoxedRep 'Lifted@ +liftedRepTyCon :: TyCon +liftedRepTyCon + = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] + +liftedRepTyConName :: Name +liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") + liftedRepTyConKey liftedRepTyCon + +liftedRepTy :: RuntimeRepType +liftedRepTy = mkTyConTy liftedRepTyCon + +---------------------- +-- | @type UnliftedRep = 'BoxedRep 'Unlifted@ +unliftedRepTyCon :: TyCon +unliftedRepTyCon + = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs + where + rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] + +unliftedRepTyConName :: Name +unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") + unliftedRepTyConKey unliftedRepTyCon + +unliftedRepTy :: RuntimeRepType +unliftedRepTy = mkTyConTy unliftedRepTyCon + + +{- ********************************************************************* +* * + VecCount, VecElem +* * +********************************************************************* -} + +vecCountTyConName :: Name +vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon + +vecElemTyConName :: Name +vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon + +vecRepDataCon :: DataCon +vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon + , mkTyConTy vecElemTyCon ] + runtimeRepTyCon + (RuntimeRep prim_rep_fun) + where + -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType + prim_rep_fun [count, elem] + | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count) + , VecElem e <- tyConPromDataConInfo (tyConAppTyCon elem) + = [VecRep n e] + prim_rep_fun args + = pprPanic "vecRepDataCon" (ppr args) + +vecRepDataConTyCon :: TyCon +vecRepDataConTyCon = promoteDataCon vecRepDataCon + +vecCountTyCon :: TyCon +vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons + +-- See Note [Wiring in RuntimeRep] +vecCountDataCons :: [DataCon] +vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys + where + mk_vec_count_dc logN key = con + where + n = 2^(logN :: Int) + name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con + con = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + +-- See Note [Wiring in RuntimeRep] +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type +[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons + +vecElemTyCon :: TyCon +vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons + +-- See Note [Wiring in RuntimeRep] +vecElemDataCons :: [DataCon] +vecElemDataCons = zipWith3 mk_vec_elem_dc + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep" + , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConKeys + where + mk_vec_elem_dc nameFs elemRep key = con + where + name = mk_runtime_rep_dc_name nameFs key con + con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep) + +-- See Note [Wiring in RuntimeRep] +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type +[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) + vecElemDataCons + +{- ********************************************************************* +* * + The boxed primitive types: Char, Int, etc +* * +********************************************************************* -} + +charTy :: Type +charTy = mkTyConTy charTyCon + +charTyCon :: TyCon +charTyCon = pcTyCon charTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsChar"))) + [] [charDataCon] +charDataCon :: DataCon +charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon + +stringTy :: Type +stringTy = mkTyConTy stringTyCon + +stringTyCon :: TyCon +-- We have this wired-in so that Haskell literal strings +-- get type String (in hsLitType), which in turn influences +-- inferred types and error messages +stringTyCon = buildSynTyCon stringTyConName + [] liftedTypeKind [] + (mkListTy charTy) + +intTy :: Type +intTy = mkTyConTy intTyCon + +intTyCon :: TyCon +intTyCon = pcTyCon intTyConName + (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) + [] [intDataCon] +intDataCon :: DataCon +intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon + +wordTy :: Type +wordTy = mkTyConTy wordTyCon + +wordTyCon :: TyCon +wordTyCon = pcTyCon wordTyConName + (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) + [] [wordDataCon] +wordDataCon :: DataCon +wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon + +word8Ty :: Type +word8Ty = mkTyConTy word8TyCon + +word8TyCon :: TyCon +word8TyCon = pcTyCon word8TyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsWord8"))) [] + [word8DataCon] +word8DataCon :: DataCon +word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon + +floatTy :: Type +floatTy = mkTyConTy floatTyCon + +floatTyCon :: TyCon +floatTyCon = pcTyCon floatTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsFloat"))) [] + [floatDataCon] +floatDataCon :: DataCon +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon + +doubleTy :: Type +doubleTy = mkTyConTy doubleTyCon + +doubleTyCon :: TyCon +doubleTyCon = pcTyCon doubleTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsDouble"))) [] + [doubleDataCon] + +doubleDataCon :: DataCon +doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon + +{- ********************************************************************* +* * + Boxing data constructors +* * +********************************************************************* -} + +{- Note [Boxing constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep +that "box" unlifted values into a (boxed, lifted) value of kind Type. For example + + type Int8Box :: TYPE Int8Rep -> Type + data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a + -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a + +Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`. We can also +package up a (lifted) Constraint as a value of kind Type. + +There are a fixed number of RuntimeReps, so we only need a fixed number +of boxing types. (For TupleRep we need to box recursively; not yet done, +see #22336.) + +This is used: + +* In desugaring, when we need to package up a bunch of values into a tuple, + for example when desugaring arrows. See Note [Big tuples] in GHC.Core.Make. + +* In let-floating when we want to float an unlifted sub-expression. + See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels + +In this module we make wired-in data type declarations for all of +these boxing functions. The goal is to define boxingDataCon_maybe. + +Wrinkles +(W1) The runtime system has special treatment (e.g. commoning up during GC) + for Int and Char values. See Note [CHARLIKE and INTLIKE closures] and + Note [Precomputed static closures] in the RTS. + + So we treat Int# and Char# specially, in specialBoxingDataCon_maybe +-} + +data BoxingInfo b + = BI_NoBoxNeeded -- The type has kind Type, so there is nothing to do + + | BI_NoBoxAvailable -- The type does not have kind Type, but sadly we + -- don't have a boxing data constructor either + + | BI_Box -- The type does not have kind Type, and we do have a + -- boxing data constructor; here it is + { bi_data_con :: DataCon + , bi_inst_con :: Expr b + , bi_boxed_type :: Type } + -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int } + -- recall: data Int = I# Int# + -- + -- BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty + -- , bi_boxed_type = Int8Box ty } + -- recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a + +boxingDataCon :: Type -> BoxingInfo b +-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that +-- will box it, and the type of the boxed thing, which /does/ now have kind Type. +-- See Note [Boxing constructors] +boxingDataCon ty + | tcIsLiftedTypeKind kind + = BI_NoBoxNeeded -- Fast path for Type + + | Just box_con <- specialBoxingDataCon_maybe ty + = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [] + , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) } + + | Just box_con <- lookupTypeMap boxingDataConMap kind + = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty] + , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] } + + | otherwise + = BI_NoBoxAvailable + + where + kind = typeKind ty + +specialBoxingDataCon_maybe :: Type -> Maybe DataCon +-- ^ See Note [Boxing constructors] wrinkle (W1) +specialBoxingDataCon_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, _) | tc `hasKey` intPrimTyConKey -> Just intDataCon + | tc `hasKey` charPrimTyConKey -> Just charDataCon + _ -> Nothing + +boxingDataConMap :: TypeMap DataCon +-- See Note [Boxing constructors] +boxingDataConMap = foldl add emptyTypeMap boxingDataCons + where + add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con + +boxingDataCons :: [(Kind, DataCon)] +-- The Kind is the kind of types for which the DataCon is the right boxing +boxingDataCons = zipWith mkBoxingDataCon + (map mkBoxingTyConUnique [1..]) + [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox") + , (mkTYPEapp intRepDataConTy, fsLit "IntBox", fsLit "MkIntBox") + + , (mkTYPEapp floatRepDataConTy, fsLit "FloatBox", fsLit "MkFloatBox") + , (mkTYPEapp doubleRepDataConTy, fsLit "DoubleBox", fsLit "MkDoubleBox") + + , (mkTYPEapp int8RepDataConTy, fsLit "Int8Box", fsLit "MkInt8Box") + , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box") + , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box") + , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box") + + , (mkTYPEapp word8RepDataConTy, fsLit "Word8Box", fsLit "MkWord8Box") + , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box", fsLit "MkWord16Box") + , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box", fsLit "MkWord32Box") + , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box", fsLit "MkWord64Box") + + , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox") + , (constraintKind, fsLit "DictBox", fsLit "MkDictBox") ] + +mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon) +mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc) + = (kind, dc) + where + uniq_dc = boxingDataConUnique uniq_tc + + (tv:_) = mkTemplateTyVars (repeat kind) + tc = pcTyCon tc_name Nothing [tv] [dc] + tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc + + dc | isConstraintKind kind + = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc + | otherwise + = pcDataCon dc_name [tv] [mkTyVarTy tv] tc + dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc + +{- +************************************************************************ +* * + The Bool type +* * +************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} +-} + +boolTy :: Type +boolTy = mkTyConTy boolTyCon + +boolTyCon :: TyCon +boolTyCon = pcTyCon boolTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] + +falseDataCon, trueDataCon :: DataCon +falseDataCon = pcDataCon falseDataConName [] [] boolTyCon +trueDataCon = pcDataCon trueDataConName [] [] boolTyCon + +falseDataConId, trueDataConId :: Id +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon + +orderingTyCon :: TyCon +orderingTyCon = pcTyCon orderingTyConName Nothing + [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] + +ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon +ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon +ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon +ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon + +ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id +ordLTDataConId = dataConWorkId ordLTDataCon +ordEQDataConId = dataConWorkId ordEQDataCon +ordGTDataConId = dataConWorkId ordGTDataCon + +{- +************************************************************************ +* * + The List type + Special syntax, deeply wired in, + but otherwise an ordinary algebraic data type +* * +************************************************************************ + + data [] a = [] | a : (List a) +-} + +mkListTy :: Type -> Type +mkListTy ty = mkTyConApp listTyCon [ty] + +listTyCon :: TyCon +listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon] + +-- See also Note [Empty lists] in GHC.Hs.Expr. +nilDataCon :: DataCon +nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon + +consDataCon :: DataCon +consDataCon = pcDataConWithFixity True {- Declared infix -} + consDataConName + alpha_tyvar [] noConcreteTyVars alpha_tyvar [] + (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) + listTyCon + +-- Interesting: polymorphic recursion would help here. +-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy +-- gets the over-specific type (Type -> Type) + +-- Wired-in type Maybe + +maybeTyCon :: TyCon +maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar + [nothingDataCon, justDataCon] + +nothingDataCon :: DataCon +nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon + +justDataCon :: DataCon +justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon + +mkPromotedMaybeTy :: Kind -> Maybe Type -> Type +mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x] +mkPromotedMaybeTy k Nothing = mkTyConApp promotedNothingDataCon [k] + +mkMaybeTy :: Type -> Kind +mkMaybeTy t = mkTyConApp maybeTyCon [t] + +isPromotedMaybeTy :: Type -> Maybe (Maybe Type) +isPromotedMaybeTy t + | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x + | Just (tc,[_]) <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing + | otherwise = Nothing + + +{- +** ********************************************************************* +* * + The tuple types +* * +************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type @TyCon@ +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@. Again these contain their arity but don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} +-} + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. Boxed 1-tuples are flattened. +-- See Note [One-tuples] +mkTupleTy :: Boxity -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy Boxed [ty] = ty +mkTupleTy boxity tys = mkTupleTy1 boxity tys + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened. +-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn] +-- in "GHC.Core.Make" +mkTupleTy1 :: Boxity -> [Type] -> Type +mkTupleTy1 Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys +mkTupleTy1 Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) + (map getRuntimeRep tys ++ tys) + +-- | Build the type of a small tuple that holds the specified type of thing +-- Flattens 1-tuples. See Note [One-tuples]. +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy Boxed tys + +unitTy :: Type +unitTy = mkTupleTy Boxed [] + +-- Make a constraint tuple, flattening a 1-tuple as usual +-- If we get a constraint tuple that is bigger than the pre-built +-- ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't +-- have an info table in the RTS, so we can't use it at runtime. But +-- this is used only in filling in extra-constraint wildcards, so it +-- never is used at runtime anyway +-- See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures] +mkConstraintTupleTy :: [Type] -> Type +mkConstraintTupleTy [ty] = ty +mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys + + +{- ********************************************************************* +* * + The sum types +* * +************************************************************************ +-} + +mkSumTy :: [Type] -> Type +mkSumTy tys = mkTyConApp (sumTyCon (length tys)) + (map getRuntimeRep tys ++ tys) + +-- Promoted Booleans + +promotedFalseDataCon, promotedTrueDataCon :: TyCon +promotedTrueDataCon = promoteDataCon trueDataCon +promotedFalseDataCon = promoteDataCon falseDataCon + +-- Promoted Maybe +promotedNothingDataCon, promotedJustDataCon :: TyCon +promotedNothingDataCon = promoteDataCon nothingDataCon +promotedJustDataCon = promoteDataCon justDataCon + +-- Promoted Ordering + +promotedLTDataCon + , promotedEQDataCon + , promotedGTDataCon + :: TyCon +promotedLTDataCon = promoteDataCon ordLTDataCon +promotedEQDataCon = promoteDataCon ordEQDataCon +promotedGTDataCon = promoteDataCon ordGTDataCon + +-- Promoted List +promotedConsDataCon, promotedNilDataCon :: TyCon +promotedConsDataCon = promoteDataCon consDataCon +promotedNilDataCon = promoteDataCon nilDataCon + +-- | Make a *promoted* list. +mkPromotedListTy :: Kind -- ^ of the elements of the list + -> [Type] -- ^ elements + -> Type +mkPromotedListTy k tys + = foldr cons nil tys + where + cons :: Type -- element + -> Type -- list + -> Type + cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] + + nil :: Type + nil = mkTyConApp promotedNilDataCon [k] + +-- | Extract the elements of a promoted list. Panics if the type is not a +-- promoted list +extractPromotedList :: Type -- ^ The promoted list + -> [Type] +extractPromotedList tys = go tys + where + go list_ty + | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty + = assert (tc `hasKey` consDataConKey) $ + t : go ts + + | Just (tc, [_k]) <- splitTyConApp_maybe list_ty + = assert (tc `hasKey` nilDataConKey) + [] + + | otherwise + = pprPanic "extractPromotedList" (ppr tys) + +--------------------------------------- +-- ghc-bignum +--------------------------------------- + +integerTyConName + , integerISDataConName + , integerIPDataConName + , integerINDataConName + :: Name +integerTyConName + = mkWiredInTyConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "Integer") + integerTyConKey + integerTyCon +integerISDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "IS") + integerISDataConKey + integerISDataCon +integerIPDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "IP") + integerIPDataConKey + integerIPDataCon +integerINDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_INTEGER + (fsLit "IN") + integerINDataConKey + integerINDataCon + +integerTy :: Type +integerTy = mkTyConTy integerTyCon + +integerTyCon :: TyCon +integerTyCon = pcTyCon integerTyConName Nothing [] + [integerISDataCon, integerIPDataCon, integerINDataCon] + +integerISDataCon :: DataCon +integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon + +integerIPDataCon :: DataCon +integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon + +integerINDataCon :: DataCon +integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon + +naturalTyConName + , naturalNSDataConName + , naturalNBDataConName + :: Name +naturalTyConName + = mkWiredInTyConName + UserSyntax + gHC_INTERNAL_NUM_NATURAL + (fsLit "Natural") + naturalTyConKey + naturalTyCon +naturalNSDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_NATURAL + (fsLit "NS") + naturalNSDataConKey + naturalNSDataCon +naturalNBDataConName + = mkWiredInDataConName + UserSyntax + gHC_INTERNAL_NUM_NATURAL + (fsLit "NB") + naturalNBDataConKey + naturalNBDataCon + +naturalTy :: Type +naturalTy = mkTyConTy naturalTyCon + +naturalTyCon :: TyCon +naturalTyCon = pcTyCon naturalTyConName Nothing [] + [naturalNSDataCon, naturalNBDataCon] + +naturalNSDataCon :: DataCon +naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon + +naturalNBDataCon :: DataCon +naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon + + +{- +************************************************************************ +* * + Semi-builtin names +* * +************************************************************************ + +Note [pretendNameIsInScope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we filter out instances that mention types whose names are +not in scope. However, in the situations listed below, we make an exception +for some commonly used names, such as Data.Kind.Type, which may not actually +be in scope but should be treated as though they were in scope. +This includes built-in names, as well as a few extra names such as +'Type', 'TYPE', 'BoxedRep', etc. + +Situations in which we apply this special logic: + + - GHCi's :info command, see GHC.Runtime.Eval.getInfo. + This fixes #1581. + + - When reporting instance overlap errors. Not doing so could mean + that we would omit instances for typeclasses like + + type Cls :: k -> Constraint + class Cls a + + because BoxedRep/Lifted were not in scope. + See GHC.Tc.Errors.potentialInstancesErrMsg. + This fixes one of the issues reported in #20465. +-} + +-- | Should this name be considered in-scope, even though it technically isn't? +-- +-- This ensures that we don't filter out information because, e.g., +-- Data.Kind.Type isn't imported. +-- +-- See Note [pretendNameIsInScope]. +pretendNameIsInScope :: Name -> Bool +pretendNameIsInScope n + = isBuiltInSyntax n + || isTupleTyConName n + || isSumTyConName n + || isCTupleTyConName n + || any (n `hasKey`) + [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey + , liftedDataConKey, unliftedDataConKey + , tYPETyConKey + , cONSTRAINTTyConKey + , runtimeRepTyConKey, boxedRepDataConKey + , eqTyConKey + , listTyConKey + , oneDataConKey + , manyDataConKey + , fUNTyConKey, unrestrictedFunTyConKey ] diff --git a/GHC/Builtin/Types.hs-boot b/GHC/Builtin/Types.hs-boot --- a/GHC/Builtin/Types.hs-boot +++ b/GHC/Builtin/Types.hs-boot @@ -15,6 +15,7 @@ coercibleTyCon, heqTyCon :: TyCon unitTy :: Type +unitTyCon :: TyCon liftedTypeKindTyConName :: Name constraintKindTyConName :: Name diff --git a/GHC/Builtin/Types/Literals.hs b/GHC/Builtin/Types/Literals.hs --- a/GHC/Builtin/Types/Literals.hs +++ b/GHC/Builtin/Types/Literals.hs @@ -1,1163 +1,1176 @@ {-# 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_TYPELITS - , gHC_TYPELITS_INTERNAL - , gHC_TYPENATS - , gHC_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_TYPENATS (fsLit "+") - typeNatAddTyFamNameKey typeNatAddTyCon - -typeNatSubTyCon :: TyCon -typeNatSubTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamSub - , sfInteractTop = interactTopSub - , sfInteractInert = interactInertSub - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-") - typeNatSubTyFamNameKey typeNatSubTyCon - -typeNatMulTyCon :: TyCon -typeNatMulTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMul - , sfInteractTop = interactTopMul - , sfInteractInert = interactInertMul - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*") - typeNatMulTyFamNameKey typeNatMulTyCon - -typeNatDivTyCon :: TyCon -typeNatDivTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamDiv - , sfInteractTop = interactTopDiv - , sfInteractInert = interactInertDiv - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div") - typeNatDivTyFamNameKey typeNatDivTyCon - -typeNatModTyCon :: TyCon -typeNatModTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamMod - , sfInteractTop = interactTopMod - , sfInteractInert = interactInertMod - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") - typeNatModTyFamNameKey typeNatModTyCon - -typeNatExpTyCon :: TyCon -typeNatExpTyCon = mkTypeNatFunTyCon2 name - BuiltInSynFamily - { sfMatchFam = matchFamExp - , sfInteractTop = interactTopExp - , sfInteractInert = interactInertExp - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^") - typeNatExpTyFamNameKey typeNatExpTyCon - -typeNatLogTyCon :: TyCon -typeNatLogTyCon = mkTypeNatFunTyCon1 name - BuiltInSynFamily - { sfMatchFam = matchFamLog - , sfInteractTop = interactTopLog - , sfInteractInert = interactInertLog - } - where - name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") - typeNatLogTyFamNameKey typeNatLogTyCon - - - -typeNatCmpTyCon :: TyCon -typeNatCmpTyCon = - mkFamilyTyCon name - (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ]) - orderingKind - Nothing - (BuiltInSynFamTyCon ops) - Nothing - NotInjective - - where - name = mkWiredInTyConName UserSyntax gHC_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_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_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_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_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_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_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_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 +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- See calls to mkTemplateTyVars + +module GHC.Builtin.Types.Literals + ( tryInteractInertFam, tryInteractTopFam, tryMatchFam + + , 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.Core.Unify ( tcMatchTys ) +import GHC.Data.Pair +import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon, tyConArity + , Injectivity(..), isBuiltInSynFamTyCon_maybe ) +import GHC.Core.Coercion.Axiom +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, mkTemplateTyVars ) +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 GHC.Utils.Panic +import GHC.Utils.Outputable + +import Control.Monad ( guard ) +import Data.List ( isPrefixOf, isSuffixOf ) +import Data.Maybe ( listToMaybe ) +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. + +* 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. + +Note [Inlining axiom constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have a number of constructor functions with types like + mkUnaryConstFoldAxiom :: TyCon -> String + -> (Type -> Maybe a) + -> (a -> Maybe Type) + -> BuiltInFamRewrite + +For very type-family-heavy code, these higher order argument are inefficient; +e.g. the fourth argument might always return (Just ty) in the above. Inlining +them is a bit brutal, but not bad, makes a few-percent difference in, say +perf test T13386. + +These functions aren't exported, so the effect is very local. + +-} + +------------------------------------------------------------------------------- +-- Key utility functions +------------------------------------------------------------------------------- + +tryInteractTopFam :: BuiltInSynFamily -> TyCon -> [Type] -> Type + -> [(CoAxiomRule, TypeEqn)] +-- The returned CoAxiomRule is always unary +tryInteractTopFam fam fam_tc tys r + = [(bifinj_axr bif, eqn_out) | bif <- sfInteract fam + , Just eqn_out <- [bifinj_proves bif eqn_in] ] + where + eqn_in :: TypeEqn + eqn_in = Pair (mkTyConApp fam_tc tys) r + +tryInteractInertFam :: BuiltInSynFamily -> TyCon + -> [Type] -> [Type] -- F tys1 ~ F tys2 + -> [(CoAxiomRule, TypeEqn)] +tryInteractInertFam builtin_fam fam_tc tys1 tys2 + = [(bifinj_axr bif, eqn_out) | bif <- sfInteract builtin_fam + , Just eqn_out <- [bifinj_proves bif eqn_in] ] + where + eqn_in = Pair (mkTyConApp fam_tc tys1) (mkTyConApp fam_tc tys2) + +tryMatchFam :: BuiltInSynFamily -> [Type] + -> Maybe (CoAxiomRule, [Type], Type) +-- Does this reduce on the given arguments? +-- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type) +-- That is: mkAxiomCo (BuiltInFamRew ax) (map mkNomReflCo ts) +-- :: F tys ~r rhs, +tryMatchFam builtin_fam arg_tys + = listToMaybe $ -- Pick first rule to match + [ (bifrw_axr rw_ax, inst_tys, res_ty) + | rw_ax <- sfMatchFam builtin_fam + , Just (inst_tys,res_ty) <- [bifrw_match rw_ax arg_tys] ] + +------------------------------------------------------------------------------- +-- Constructing BuiltInFamInjectivity, BuiltInFamRewrite +------------------------------------------------------------------------------- + +mkUnaryConstFoldAxiom :: TyCon -> String + -> (Type -> Maybe a) + -> (a -> Maybe Type) + -> BuiltInFamRewrite +-- For the definitional axioms, like (3+4 --> 7) +{-# INLINE mkUnaryConstFoldAxiom #-} -- See Note [Inlining axiom constructors] +mkUnaryConstFoldAxiom fam_tc str isReqTy f + = bif + where + bif = BIF_Rewrite + { bifrw_name = fsLit str + , bifrw_axr = BuiltInFamRew bif + , bifrw_fam_tc = fam_tc + , bifrw_arity = 1 + , bifrw_match = \ts -> do { [t1] <- return ts + ; t1' <- isReqTy t1 + ; res <- f t1' + ; return ([t1], res) } + , bifrw_proves = \cs -> do { [Pair s1 s2] <- return cs + ; s2' <- isReqTy s2 + ; z <- f s2' + ; return (mkTyConApp fam_tc [s1] === z) } + } + +mkBinConstFoldAxiom :: TyCon -> String + -> (Type -> Maybe a) + -> (Type -> Maybe b) + -> (a -> b -> Maybe Type) + -> BuiltInFamRewrite +-- For the definitional axioms, like (3+4 --> 7) +{-# INLINE mkBinConstFoldAxiom #-} -- See Note [Inlining axiom constructors] +mkBinConstFoldAxiom fam_tc str isReqTy1 isReqTy2 f + = bif + where + bif = BIF_Rewrite + { bifrw_name = fsLit str + , bifrw_axr = BuiltInFamRew bif + , bifrw_fam_tc = fam_tc + , bifrw_arity = 2 + , bifrw_match = \ts -> do { [t1,t2] <- return ts + ; t1' <- isReqTy1 t1 + ; t2' <- isReqTy2 t2 + ; res <- f t1' t2' + ; return ([t1,t2], res) } + , bifrw_proves = \cs -> do { [Pair s1 s2, Pair t1 t2] <- return cs + ; s2' <- isReqTy1 s2 + ; t2' <- isReqTy2 t2 + ; z <- f s2' t2' + ; return (mkTyConApp fam_tc [s1,t1] === z) } + } + +mkRewriteAxiom :: TyCon -> String + -> [TyVar] -> [Type] -- LHS of axiom + -> Type -- RHS of axiom + -> BuiltInFamRewrite +-- Not higher order, no benefit in inlining +-- See Note [Inlining axiom constructors] +mkRewriteAxiom fam_tc str tpl_tvs lhs_tys rhs_ty + = assertPpr (tyConArity fam_tc == length lhs_tys) (text str <+> ppr lhs_tys) $ + bif + where + bif = BIF_Rewrite + { bifrw_name = fsLit str + , bifrw_axr = BuiltInFamRew bif + , bifrw_fam_tc = fam_tc + , bifrw_arity = bif_arity + , bifrw_match = match_fn + , bifrw_proves = inst_fn } + + bif_arity = length tpl_tvs + + match_fn :: [Type] -> Maybe ([Type],Type) + match_fn arg_tys + = assertPpr (tyConArity fam_tc == length arg_tys) (text str <+> ppr arg_tys) $ + case tcMatchTys lhs_tys arg_tys of + Nothing -> Nothing + Just subst -> Just (substTyVars subst tpl_tvs, substTy subst rhs_ty) + + inst_fn :: [TypeEqn] -> Maybe TypeEqn + inst_fn inst_eqns + = assertPpr (length inst_eqns == bif_arity) (text str $$ ppr inst_eqns) $ + Just (mkTyConApp fam_tc (substTys (zipTCvSubst tpl_tvs tys1) lhs_tys) + === + substTy (zipTCvSubst tpl_tvs tys2) rhs_ty) + where + (tys1, tys2) = unzipPairs inst_eqns + +mkTopUnaryFamDeduction :: String -> TyCon + -> (Type -> Type -> Maybe TypeEqn) + -> BuiltInFamInjectivity +-- Deduction from (F s ~ r) where `F` is a unary type function +{-# INLINE mkTopUnaryFamDeduction #-} -- See Note [Inlining axiom constructors] +mkTopUnaryFamDeduction str fam_tc f + = bif + where + bif = BIF_Interact + { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = \(Pair lhs rhs) + -> do { (tc, [a]) <- splitTyConApp_maybe lhs + ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc) + ; f a rhs } } + +mkTopBinFamDeduction :: String -> TyCon + -> (Type -> Type -> Type -> Maybe TypeEqn) + -> BuiltInFamInjectivity +-- Deduction from (F s t ~ r) where `F` is a binary type function +{-# INLINE mkTopBinFamDeduction #-} -- See Note [Inlining axiom constructors] +mkTopBinFamDeduction str fam_tc f + = bif + where + bif = BIF_Interact + { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = \(Pair lhs rhs) -> + do { (tc, [a,b]) <- splitTyConApp_maybe lhs + ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc) + ; f a b rhs } } + +mkUnaryBIF :: String -> TyCon -> BuiltInFamInjectivity +-- Not higher order, no benefit in inlining +-- See Note [Inlining axiom constructors] +mkUnaryBIF str fam_tc + = bif + where + bif = BIF_Interact { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = proves } + proves (Pair lhs rhs) + = do { (tc2, [x2]) <- splitTyConApp_maybe rhs + ; guard (tc2 == fam_tc) + ; (tc1, [x1]) <- splitTyConApp_maybe lhs + ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc) + ; return (Pair x1 x2) } + +mkBinBIF :: String -> TyCon + -> WhichArg -> WhichArg + -> (Type -> Bool) -- The guard on the equal args, if any + -> BuiltInFamInjectivity +{-# INLINE mkBinBIF #-} -- See Note [Inlining axiom constructors] +mkBinBIF str fam_tc eq1 eq2 check_me + = bif + where + bif = BIF_Interact { bifinj_name = fsLit str + , bifinj_axr = BuiltInFamInj bif + , bifinj_proves = proves } + proves (Pair lhs rhs) + = do { (tc2, [x2,y2]) <- splitTyConApp_maybe rhs + ; guard (tc2 == fam_tc) + ; (tc1, [x1,y1]) <- splitTyConApp_maybe lhs + ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc) + ; case (eq1, eq2) of + (ArgX,ArgX) -> do_it x1 x2 y1 y2 + (ArgX,ArgY) -> do_it x1 y2 x2 y1 + (ArgY,ArgX) -> do_it y1 x2 y2 x1 + (ArgY,ArgY) -> do_it y1 y2 x1 x2 } + + do_it a1 a2 b1 b2 = do { same a1 a2; guard (check_me a1); return (Pair b1 b2) } + +noGuard :: Type -> Bool +noGuard _ = True + +numGuard :: (Integer -> Bool) -> Type -> Bool +numGuard pred ty = case isNumLitTy ty of + Just n -> pred n + Nothing -> False + +data WhichArg = ArgX | ArgY + + +------------------------------------------------------------------------------- +-- 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 + ] + + +-- 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 $ + [ pr | tc <- typeNatTyCons + , Just ops <- [isBuiltInSynFamTyCon_maybe tc] + , pr <- [ (bifinj_name bif, bifinj_axr bif) | bif <- sfInteract ops ] + ++ [ (bifrw_name bif, bifrw_axr bif) | bif <- sfMatchFam ops ] ] + +------------------------------------------------------------------------------- +-- Addition (+) +------------------------------------------------------------------------------- + +typeNatAddTyCon :: TyCon +typeNatAddTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = axAddRewrites + , sfInteract = axAddInjectivity + } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+") + typeNatAddTyFamNameKey typeNatAddTyCon + + +sn,tn :: TyVar -- Of kind Natural +(sn: tn: _) = mkTemplateTyVars (repeat typeSymbolKind) + +axAddRewrites :: [BuiltInFamRewrite] +axAddRewrites + = [ mkRewriteAxiom tc "Add0L" [tn] [num 0, var tn] (var tn) -- 0 + t --> t + , mkRewriteAxiom tc "Add0R" [sn] [var sn, num 0] (var sn) -- s + 0 --> s + , mkBinConstFoldAxiom tc "AddDef" isNumLitTy isNumLitTy $ -- 3 + 4 --> 7 + \x y -> Just $ num (x + y) ] + where + tc = typeNatAddTyCon + +axAddInjectivity :: [BuiltInFamInjectivity] +axAddInjectivity + = [ -- (s + t ~ 0) => (s ~ 0) + mkTopBinFamDeduction "AddT-0L" tc $ \ a _b r -> + do { _ <- known r (== 0); return (Pair a (num 0)) } + + , -- (s + t ~ 0) => (t ~ 0) + mkTopBinFamDeduction "AddT-0R" tc $ \ _a b r -> + do { _ <- known r (== 0); return (Pair b (num 0)) } + + , -- (5 + t ~ 8) => (t ~ 3) + mkTopBinFamDeduction "AddT-KKL" tc $ \ a b r -> + do { na <- isNumLitTy a; nr <- known r (>= na); return (Pair b (num (nr-na))) } + + , -- (s + 5 ~ 8) => (s ~ 3) + mkTopBinFamDeduction "AddT-KKR" tc $ \ a b r -> + do { nb <- isNumLitTy b; nr <- known r (>= nb); return (Pair a (num (nr-nb))) } + + , mkBinBIF "AddI-xx" tc ArgX ArgX noGuard -- x1+y1~x2+y2 {x1=x2}=> (y1 ~ y2) + , mkBinBIF "AddI-xy" tc ArgX ArgY noGuard -- x1+y1~x2+y2 {x1=y2}=> (x2 ~ y1) + , mkBinBIF "AddI-yx" tc ArgY ArgX noGuard -- x1+y1~x2+y2 {y1=x2}=> (x1 ~ y2) + , mkBinBIF "AddI-yy" tc ArgY ArgY noGuard -- x1+y1~x2+y2 {y1=y2}=> (x1 ~ x2) + ] + where + tc = typeNatAddTyCon + +------------------------------------------------------------------------------- +-- Subtraction (-) +------------------------------------------------------------------------------- + +typeNatSubTyCon :: TyCon +typeNatSubTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily + { sfMatchFam = axSubRewrites + , sfInteract = axSubInjectivity + } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-") + typeNatSubTyFamNameKey typeNatSubTyCon + +axSubRewrites :: [BuiltInFamRewrite] +axSubRewrites + = [ mkRewriteAxiom tc "Sub0R" [sn] [var sn, num 0] (var sn) -- s - 0 --> s + , mkBinConstFoldAxiom tc "SubDef" isNumLitTy isNumLitTy $ -- 4 - 3 --> 1 if x>=y + \x y -> fmap num (minus x y) ] + where + tc = typeNatSubTyCon + +axSubInjectivity :: [BuiltInFamInjectivity] +axSubInjectivity + = [ -- (a - b ~ 5) => (5 + b ~ a) + mkTopBinFamDeduction "SubT" tc $ \ a b r -> + do { _ <- isNumLitTy r; return (Pair (r .+. b) a) } + + , mkBinBIF "SubI-xx" tc ArgX ArgX noGuard -- (x-y1 ~ x-y2) => (y1 ~ y2) + , mkBinBIF "SubI-yy" tc ArgY ArgY noGuard -- (x1-y ~ x2-y) => (x1 ~ x2) + ] + where + tc = typeNatSubTyCon + +{- +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. +-} + + +------------------------------------------------------------------------------- +-- Multiplication (*) +------------------------------------------------------------------------------- + +typeNatMulTyCon :: TyCon +typeNatMulTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axMulRewrites + , sfInteract = axMulInjectivity } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*") + typeNatMulTyFamNameKey typeNatMulTyCon + +axMulRewrites :: [BuiltInFamRewrite] +axMulRewrites + = [ mkRewriteAxiom tc "Mul0L" [tn] [num 0, var tn] (num 0) -- 0 * t --> 0 + , mkRewriteAxiom tc "Mul0R" [sn] [var sn, num 0] (num 0) -- s * 0 --> 0 + , mkRewriteAxiom tc "Mul1L" [tn] [num 1, var tn] (var tn) -- 1 * t --> t + , mkRewriteAxiom tc "Mul1R" [sn] [var sn, num 1] (var sn) -- s * 1 --> s + , mkBinConstFoldAxiom tc "MulDef" isNumLitTy isNumLitTy $ -- 3 + 4 --> 12 + \x y -> Just $ num (x * y) ] + where + tc = typeNatMulTyCon + +axMulInjectivity :: [BuiltInFamInjectivity] +axMulInjectivity + = [ -- (s * t ~ 1) => (s ~ 1) + mkTopBinFamDeduction "MulT1" tc $ \ s _t r -> + do { _ <- known r (== 1); return (Pair s r) } + + , -- (s * t ~ 1) => (t ~ 1) + mkTopBinFamDeduction "MulT2" tc $ \ _s t r -> + do { _ <- known r (== 1); return (Pair t r) } + + , -- (3 * t ~ 15) => (t ~ 5) + mkTopBinFamDeduction "MulT3" tc $ \ s t r -> + do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- divide nr ns; return (Pair t (num y)) } + + , -- (s * 3 ~ 15) => (s ~ 5) + mkTopBinFamDeduction "MulT4" tc $ \ s t r -> + do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- divide nr nt; return (Pair s (num y)) } + + , mkBinBIF "MulI-xx" tc ArgX ArgX (numGuard (/= 0)) -- (x*y1 ~ x*y2) {x/=0}=> (y1 ~ y2) + , mkBinBIF "MulI-yy" tc ArgY ArgY (numGuard (/= 0)) -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2) + ] + where + tc = typeNatMulTyCon + + +------------------------------------------------------------------------------- +-- Division: Div and Mod +------------------------------------------------------------------------------- + +typeNatDivTyCon :: TyCon +typeNatDivTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axDivRewrites + , sfInteract = [] } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div") + typeNatDivTyFamNameKey typeNatDivTyCon + +typeNatModTyCon :: TyCon +typeNatModTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axModRewrites + , sfInteract = [] } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod") + typeNatModTyFamNameKey typeNatModTyCon + +axDivRewrites :: [BuiltInFamRewrite] +axDivRewrites + = [ mkRewriteAxiom tc "Div1" [sn] [var sn, num 1] (var sn) -- s `div` 1 --> s + , mkBinConstFoldAxiom tc "DivDef" isNumLitTy isNumLitTy $ -- 8 `div` 4 --> 2 + \x y -> do { guard (y /= 0); return (num (div x y)) } ] + where + tc = typeNatDivTyCon + +axModRewrites :: [BuiltInFamRewrite] +axModRewrites + = [ mkRewriteAxiom tc "Mod1" [sn] [var sn, num 1] (num 0) -- s `mod` 1 --> 0 + , mkBinConstFoldAxiom tc "ModDef" isNumLitTy isNumLitTy $ -- 8 `mod` 3 --> 2 + \x y -> do { guard (y /= 0); return (num (mod x y)) } ] + where + tc = typeNatModTyCon + +------------------------------------------------------------------------------- +-- Exponentiation: Exp +------------------------------------------------------------------------------- + +typeNatExpTyCon :: TyCon -- Exponentiation +typeNatExpTyCon = mkTypeNatFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axExpRewrites + , sfInteract = axExpInjectivity } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^") + typeNatExpTyFamNameKey typeNatExpTyCon + +axExpRewrites :: [BuiltInFamRewrite] +axExpRewrites + = [ mkRewriteAxiom tc "Exp0R" [sn] [var sn, num 0] (num 1) -- s ^ 0 --> 1 + , mkRewriteAxiom tc "Exp1L" [tn] [num 1, var tn] (num 1) -- 1 ^ t --> 1 + , mkRewriteAxiom tc "Exp1R" [sn] [var sn, num 1] (var sn) -- s ^ 1 --> s + , mkBinConstFoldAxiom tc "ExpDef" isNumLitTy isNumLitTy $ -- 2 ^ 3 --> 8 + \x y -> Just (num (x ^ y)) ] + where + tc = typeNatExpTyCon + +axExpInjectivity :: [BuiltInFamInjectivity] +axExpInjectivity + = [ -- (s ^ t ~ 0) => (s ~ 0) + mkTopBinFamDeduction "ExpT1" tc $ \ s _t r -> + do { 0 <- isNumLitTy r; return (Pair s r) } + + , -- (2 ^ t ~ 8) => (t ~ 3) + mkTopBinFamDeduction "ExpT2" tc $ \ s t r -> + do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- logExact nr ns; return (Pair t (num y)) } + + , -- (s ^ 2 ~ 9) => (s ~ 3) + mkTopBinFamDeduction "ExpT3" tc $ \ s t r -> + do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- rootExact nr nt; return (Pair s (num y)) } + + , mkBinBIF "ExpI-xx" tc ArgX ArgX (numGuard (> 1)) -- (x^y1 ~ x^y2) {x>1}=> (y1 ~ y2) + , mkBinBIF "ExpI-yy" tc ArgY ArgY (numGuard (/= 0)) -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2) + ] + where + tc = typeNatExpTyCon + +------------------------------------------------------------------------------- +-- Logarithm: Log2 +------------------------------------------------------------------------------- + +typeNatLogTyCon :: TyCon +typeNatLogTyCon = mkTypeNatFunTyCon1 name + BuiltInSynFamily { sfMatchFam = axLogRewrites + , sfInteract = [] } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2") + typeNatLogTyFamNameKey typeNatLogTyCon + +axLogRewrites :: [BuiltInFamRewrite] +axLogRewrites + = [ mkUnaryConstFoldAxiom tc "LogDef" isNumLitTy $ -- log 8 --> 3 + \x -> do { (a,_) <- genLog x 2; return (num a) } ] + where + tc = typeNatLogTyCon + +------------------------------------------------------------------------------- +-- Comparision of Nats: CmpNat +------------------------------------------------------------------------------- + +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 = axCmpNatRewrites + , sfInteract = axCmpNatInjectivity } + +axCmpNatRewrites :: [BuiltInFamRewrite] +axCmpNatRewrites + = [ mkRewriteAxiom tc "CmpNatRefl" [sn] [var sn, var sn] (ordering EQ) -- s `cmp` s --> EQ + , mkBinConstFoldAxiom tc "CmpNatDef" isNumLitTy isNumLitTy $ -- 2 `cmp` 3 --> LT + \x y -> Just (ordering (compare x y)) ] + where + tc = typeNatCmpTyCon + +axCmpNatInjectivity :: [BuiltInFamInjectivity] +axCmpNatInjectivity + = [ -- s `cmp` t ~ EQ ==> s ~ t + mkTopBinFamDeduction "CmpNatT3" typeNatCmpTyCon $ \ s t r -> + do { EQ <- isOrderingLitTy r; return (Pair s t) } ] + +------------------------------------------------------------------------------- +-- Comparsion of Symbols: CmpSymbol +------------------------------------------------------------------------------- + +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 = axSymbolCmpRewrites + , sfInteract = axSymbolCmpInjectivity } + +ss,ts :: TyVar -- Of kind Symbol +(ss: ts: _) = mkTemplateTyVars (repeat typeSymbolKind) + +axSymbolCmpRewrites :: [BuiltInFamRewrite] +axSymbolCmpRewrites + = [ mkRewriteAxiom tc "CmpSymbolRefl" [ss] [var ss, var ss] (ordering EQ) -- s `cmp` s --> EQ + , mkBinConstFoldAxiom tc "CmpSymbolDef" isStrLitTy isStrLitTy $ -- "a" `cmp` "b" --> LT + \x y -> Just (ordering (lexicalCompareFS x y)) ] + where + tc = typeSymbolCmpTyCon + +axSymbolCmpInjectivity :: [BuiltInFamInjectivity] +axSymbolCmpInjectivity + = [ mkTopBinFamDeduction "CmpSymbolT" typeSymbolCmpTyCon $ \ s t r -> + do { EQ <- isOrderingLitTy r; return (Pair s t) } ] + + +------------------------------------------------------------------------------- +-- AppendSymbol +------------------------------------------------------------------------------- + +typeSymbolAppendTyCon :: TyCon +typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name + BuiltInSynFamily { sfMatchFam = axAppendRewrites + , sfInteract = axAppendInjectivity } + where + name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol") + typeSymbolAppendFamNameKey typeSymbolAppendTyCon + +axAppendRewrites :: [BuiltInFamRewrite] +axAppendRewrites + = [ mkRewriteAxiom tc "Concat0R" [ts] [nullStrLitTy, var ts] (var ts) -- "" ++ t --> t + , mkRewriteAxiom tc "Concat0L" [ss] [var ss, nullStrLitTy] (var ss) -- s ++ "" --> s + , mkBinConstFoldAxiom tc "AppendSymbolDef" isStrLitTy isStrLitTy $ -- "a" ++ "b" --> "ab" + \x y -> Just (mkStrLitTy (appendFS x y)) ] + where + tc = typeSymbolAppendTyCon + +axAppendInjectivity :: [BuiltInFamInjectivity] +axAppendInjectivity + = [ -- (AppendSymbol a b ~ "") => (a ~ "") + mkTopBinFamDeduction "AppendSymbolT1" tc $ \ a _b r -> + do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair a nullStrLitTy) } + + , -- (AppendSymbol a b ~ "") => (b ~ "") + mkTopBinFamDeduction "AppendSymbolT2" tc $ \ _a b r -> + do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair b nullStrLitTy) } + + , -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar") + mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r -> + do { as <- isStrLitTyS a; rs <- isStrLitTyS r; guard (as `isPrefixOf` rs) + ; return (Pair b (mkStrLitTyS (drop (length as) rs))) } + + , -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo") + mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r -> + do { bs <- isStrLitTyS b; rs <- isStrLitTyS r; guard (bs `isSuffixOf` rs) + ; return (Pair a (mkStrLitTyS (take (length rs - length bs) rs))) } + + , mkBinBIF "AppI-xx" tc ArgX ArgX noGuard -- (x++y1 ~ x++y2) => (y1 ~ y2) + , mkBinBIF "AppI-yy" tc ArgY ArgY noGuard -- (x1++y ~ x2++y) => (x1 ~ x2) + ] + where + tc = typeSymbolAppendTyCon + +------------------------------------------------------------------------------- +-- ConsSymbol +------------------------------------------------------------------------------- + +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 = axConsRewrites + , sfInteract = axConsInjectivity } + +axConsRewrites :: [BuiltInFamRewrite] +axConsRewrites + = [ mkBinConstFoldAxiom tc "ConsSymbolDef" isCharLitTy isStrLitTy $ -- 'a' : "bc" --> "abc" + \x y -> Just $ mkStrLitTy (consFS x y) ] + where + tc = typeConsSymbolTyCon + +axConsInjectivity :: [BuiltInFamInjectivity] +axConsInjectivity + = [ -- ConsSymbol a b ~ "blah" => (a ~ 'b') + mkTopBinFamDeduction "ConsSymbolT1" tc $ \ a _b r -> + do { rs <- isStrLitTy r; (x,_) <- unconsFS rs; return (Pair a (mkCharLitTy x)) } + + , -- ConsSymbol a b ~ "blah" => (b ~ "lah") + mkTopBinFamDeduction "ConsSymbolT2" tc $ \ _a b r -> + do { rs <- isStrLitTy r; (_,xs) <- unconsFS rs; return (Pair b (mkStrLitTy xs)) } + + + , mkBinBIF "ConsI-xx" tc ArgX ArgX noGuard -- (x:y1 ~ x:y2) => (y1 ~ y2) + , mkBinBIF "ConsI-yy" tc ArgY ArgY noGuard -- (x1:y ~ x2:y) => (x1 ~ x2) + ] + where + tc = typeConsSymbolTyCon + +------------------------------------------------------------------------------- +-- UnconsSymbol +------------------------------------------------------------------------------- + +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 = axUnconsRewrites + , sfInteract = axUnconsInjectivity } + +computeUncons :: FastString -> Type +computeUncons str + = mkPromotedMaybeTy charSymbolPairKind (fmap reify (unconsFS str)) + where + reify :: (Char, FastString) -> Type + reify (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s) + +axUnconsRewrites :: [BuiltInFamRewrite] +axUnconsRewrites + = [ mkUnaryConstFoldAxiom tc "ConsSymbolDef" isStrLitTy $ -- 'a' : "bc" --> "abc" + \x -> Just $ computeUncons x ] + where + tc = typeUnconsSymbolTyCon + +axUnconsInjectivity :: [BuiltInFamInjectivity] +axUnconsInjectivity + = [ -- (UnconsSymbol b ~ Nothing) => (b ~ "") + mkTopUnaryFamDeduction "UnconsSymbolT1" tc $ \b r -> + do { Nothing <- isPromotedMaybeTy r; return (Pair b nullStrLitTy) } + + , -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar") + mkTopUnaryFamDeduction "UnconsSymbolT2" tc $ \b r -> + do { Just pr <- isPromotedMaybeTy r + ; (c,s) <- isPromotedPairType pr + ; chr <- isCharLitTy c + ; str <- isStrLitTy s + ; return (Pair b (mkStrLitTy (consFS chr str))) } + + , mkUnaryBIF "UnconsI1" tc -- (UnconsSymbol x1 ~ z, UnconsSymbol x2 ~ z) => (x1 ~ x2) + ] + where + tc = typeUnconsSymbolTyCon + +------------------------------------------------------------------------------- +-- CharToNat +------------------------------------------------------------------------------- + +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 = axCharToNatRewrites + , sfInteract = axCharToNatInjectivity } + +axCharToNatRewrites :: [BuiltInFamRewrite] +axCharToNatRewrites + = [ mkUnaryConstFoldAxiom tc "CharToNatDef" isCharLitTy $ -- CharToNat 'a' --> 97 + \x -> Just $ num (charToInteger x) ] + where + tc = typeCharToNatTyCon + +axCharToNatInjectivity :: [BuiltInFamInjectivity] +axCharToNatInjectivity + = [ -- (CharToNat c ~ 122) => (c ~ 'z') + mkTopUnaryFamDeduction "CharToNatT1" typeCharToNatTyCon $ \c r -> + do { nr <- isNumLitTy r; chr <- integerToChar nr; return (Pair c (mkCharLitTy chr)) } ] + +------------------------------------------------------------------------------- +-- NatToChar +------------------------------------------------------------------------------- + +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 = axNatToCharRewrites + , sfInteract = axNatToCharInjectivity } + +axNatToCharRewrites :: [BuiltInFamRewrite] +axNatToCharRewrites + = [ mkUnaryConstFoldAxiom tc "NatToCharDef" isNumLitTy $ -- NatToChar 97 --> 'a' + \n -> fmap mkCharLitTy (integerToChar n) ] + where + tc = typeNatToCharTyCon + +axNatToCharInjectivity :: [BuiltInFamInjectivity] +axNatToCharInjectivity + = [ -- (NatToChar n ~ 'z') => (n ~ 122) + mkTopUnaryFamDeduction "CharToNatT1" typeNatToCharTyCon $ \n r -> + do { c <- isCharLitTy r; return (Pair n (mkNumLitTy (charToInteger c))) } ] + + +----------------------------------------------------------------------------- +-- CmpChar +----------------------------------------------------------------------------- + +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 = axCharCmpRewrites + , sfInteract = axCharCmpInjectivity } + +sc :: TyVar -- Of kind Char +(sc: _) = mkTemplateTyVars (repeat charTy) + +axCharCmpRewrites :: [BuiltInFamRewrite] +axCharCmpRewrites + = [ mkRewriteAxiom tc "CmpCharRefl" [sc] [var sc, var sc] (ordering EQ) -- s `cmp` s --> EQ + , mkBinConstFoldAxiom tc "CmpCharDef" isCharLitTy isCharLitTy $ -- 'a' `cmp` 'b' --> LT + \chr1 chr2 -> Just $ ordering $ compare chr1 chr2 ] + where + tc = typeCharCmpTyCon + +axCharCmpInjectivity :: [BuiltInFamInjectivity] +axCharCmpInjectivity + = [ -- (CmpChar s t ~ EQ) => s ~ t + mkTopBinFamDeduction "CmpCharT" typeCharCmpTyCon $ \ s t r -> + do { EQ <- isOrderingLitTy r; return (Pair s t) } ] + + +{------------------------------------------------------------------------------- +Various utilities for making axioms and types +-------------------------------------------------------------------------------} + +(===) :: Type -> Type -> Pair Type +x === y = Pair x y + +num :: Integer -> Type +num = mkNumLitTy + +var :: TyVar -> Type +var = mkTyVarTy + +(.+.) :: 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] +-} + + +nullStrLitTy :: Type -- The type "" +nullStrLitTy = mkStrLitTy nilFS + +isStrLitTyS :: Type -> Maybe String +isStrLitTyS ty = do { fs <- isStrLitTy ty; return (unpackFS fs) } + +mkStrLitTyS :: String -> Type +mkStrLitTyS s = mkStrLitTy (mkFastString s) + +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 + +-- 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 + +same :: Type -> Type -> Maybe () +same ty1 ty2 = guard (ty1 `tcEqType` ty2) + +known :: Type -> (Integer -> Bool) -> Maybe Integer +known x p = do { nx <- isNumLitTy x; guard (p nx); return nx } + +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 + + +{- ----------------------------------------------------------------------------- +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) + diff --git a/GHC/Builtin/Types/Prim.hs b/GHC/Builtin/Types/Prim.hs --- a/GHC/Builtin/Types/Prim.hs +++ b/GHC/Builtin/Types/Prim.hs @@ -63,7 +63,8 @@ doublePrimTyCon, doublePrimTy, doublePrimTyConName, statePrimTyCon, mkStatePrimTy, - realWorldTyCon, realWorldTy, realWorldStatePrimTy, + realWorldTyCon, realWorldTy, + realWorldStatePrimTy, realWorldMutableByteArrayPrimTy, proxyPrimTyCon, mkProxyPrimTy, @@ -76,7 +77,6 @@ mutVarPrimTyCon, mkMutVarPrimTy, mVarPrimTyCon, mkMVarPrimTy, - ioPortPrimTyCon, mkIOPortPrimTy, tVarPrimTyCon, mkTVarPrimTy, stablePtrPrimTyCon, mkStablePtrPrimTy, stableNamePrimTyCon, mkStableNamePrimTy, @@ -277,7 +277,6 @@ , mutableByteArrayPrimTyCon , smallMutableArrayPrimTyCon , mVarPrimTyCon - , ioPortPrimTyCon , tVarPrimTyCon , mutVarPrimTyCon , realWorldTyCon @@ -309,7 +308,7 @@ arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, - ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, + tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, @@ -341,7 +340,6 @@ mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon -ioPortPrimTyConName = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon @@ -420,8 +418,8 @@ -- Result is anon arg kinds [ak1, .., akm] -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for --- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah --- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *]) +-- forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah +-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, Type]) mkTemplateKiTyVars kind_var_kinds mk_arg_kinds = kv_bndrs ++ tv_bndrs where @@ -435,8 +433,8 @@ -- Result is anon arg kinds [ak1, .., akm] -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for --- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah --- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *]) +-- forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah +-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, Type]) mkTemplateKiTyVar kind mk_arg_kinds = kv_bndr : tv_bndrs where @@ -758,8 +756,10 @@ are not /apart/: see Note [Type and Constraint are not apart] (W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and - aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint. Ditto noInlineId - vs noInlineConstraintId in GHC.Types.Id.Make; see Note [inlineId magic]. + aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint. + See Note [Type vs Constraint for error ids] in GHC.Core.Make. + Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make; + see Note [inlineId magic]. (W3) We need a TypeOrConstraint flag in LitRubbish. @@ -824,7 +824,7 @@ are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty. (W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart? In truth yes, - they are. But it's easier to say that htey are not apart, by + they are. But it's easier to say that they are not apart, by reporting "maybeApart" (which is always safe), rather than recurse into the arguments (whose kinds may be utterly different) to look for apartness inside them. Again this is in @@ -844,8 +844,8 @@ Note [RuntimeRep polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking, you can't be polymorphic in `RuntimeRep`. E.g - f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a] - f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... + f :: forall (rr::RuntimeRep) (a::TYPE rr). a -> [a] + f = /\(rr::RuntimeRep) (a::rr) \(a::rr). ... This is no good: we could not generate code for 'f', because the calling convention for 'f' varies depending on whether the argument is a a Int, Int#, or Float#. (You could imagine generating specialised @@ -854,7 +854,7 @@ Certain functions CAN be runtime-rep-polymorphic, because the code generator never has to manipulate a value of type 'a :: TYPE rr'. -* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a +* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a Code generator never has to manipulate the return value. * unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair: @@ -1014,7 +1014,7 @@ -------------------------- This is The Type Of Equality in GHC. It classifies nominal coercions. This type is used in the solver for recording equality constraints. -It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in +It responds "yes" to Type.isEqPred and classifies as an EqPred in Type.classifyPredType. All wanted constraints of this type are built with coercion holes. @@ -1176,7 +1176,9 @@ realWorldTy = mkTyConTy realWorldTyCon realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld - +realWorldMutableByteArrayPrimTy :: Type +realWorldMutableByteArrayPrimTy + = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] @@ -1274,20 +1276,6 @@ mkMutVarPrimTy :: Type -> Type -> Type mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [getLevity elt, s, elt] - -{- -************************************************************************ -* * -\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type} -* * -************************************************************************ --} - -ioPortPrimTyCon :: TyCon -ioPortPrimTyCon = pcPrimTyCon_LevPolyLastArg ioPortPrimTyConName [Nominal, Representational] unliftedRepTy - -mkIOPortPrimTy :: Type -> Type -> Type -mkIOPortPrimTy s elt = TyConApp ioPortPrimTyCon [getLevity elt, s, elt] {- ************************************************************************ diff --git a/GHC/Builtin/Uniques.hs b/GHC/Builtin/Uniques.hs --- a/GHC/Builtin/Uniques.hs +++ b/GHC/Builtin/Uniques.hs @@ -14,16 +14,19 @@ -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums , mkSumTyConUnique, mkSumDataConUnique + , isSumTyConUnique -- ** Tuples -- *** Vanilla , mkTupleTyConUnique , mkTupleDataConUnique , isTupleTyConUnique + , isTupleDataConLikeUnique -- *** Constraint , mkCTupleTyConUnique , mkCTupleDataConUnique , mkCTupleSelIdUnique + , isCTupleTyConUnique -- ** Making built-in uniques , mkAlphaTyVarUnique @@ -66,7 +69,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain (assert) import Data.Maybe import GHC.Utils.Word64 (word64ToInt) @@ -121,6 +123,15 @@ -- alternative mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc) +-- | Inverse of 'mkSumTyConUnique' +isSumTyConUnique :: Unique -> Maybe Arity +isSumTyConUnique u = + case (tag, n .&. 0xfc) of + ('z', 0xfc) -> Just (word64ToInt n `shiftR` 8) + _ -> Nothing + where + (tag, n) = unpkUnique u + mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkSumDataConUnique alt arity | alt >= arity @@ -225,6 +236,17 @@ | otherwise = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos) +-- | Inverse of 'mkCTupleTyConUnique' +isCTupleTyConUnique :: Unique -> Maybe Arity +isCTupleTyConUnique u = + case (tag, i) of + ('k', 0) -> Just arity + _ -> Nothing + where + (tag, n) = unpkUnique u + (arity', i) = quotRem n 2 + arity = word64ToInt arity' + getCTupleTyConName :: Int -> Name getCTupleTyConName n = case n `divMod` 2 of @@ -273,7 +295,7 @@ mkTupleTyConUnique Boxed a = mkUniqueInt '4' (2*a) mkTupleTyConUnique Unboxed a = mkUniqueInt '5' (2*a) --- | This function is an inverse of `mkTupleTyConUnique` +-- | Inverse of 'mkTupleTyConUnique' isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity) isTupleTyConUnique u = case (tag, i) of @@ -283,6 +305,18 @@ where (tag, n) = unpkUnique u (arity', i) = quotRem n 2 + arity = word64ToInt arity' + +-- | Inverse of 'mkTupleTyDataUnique' that also matches the worker and promoted tycon. +isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity) +isTupleDataConLikeUnique u = + case tag of + '7' -> Just (Boxed, arity) + '8' -> Just (Unboxed, arity) + _ -> Nothing + where + (tag, n) = unpkUnique u + (arity', _) = quotRem n 3 arity = word64ToInt arity' getTupleTyConName :: Boxity -> Int -> Name diff --git a/GHC/Builtin/Utils.hs b/GHC/Builtin/Utils.hs --- a/GHC/Builtin/Utils.hs +++ b/GHC/Builtin/Utils.hs @@ -34,6 +34,8 @@ ghcPrimExports, ghcPrimDeclDocs, + ghcPrimWarns, + ghcPrimFixities, -- * Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -61,25 +63,28 @@ import GHC.Types.Avail import GHC.Types.Id +import GHC.Types.Fixity import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make +import GHC.Types.SourceText import GHC.Types.Unique.FM import GHC.Types.Unique.Map import GHC.Types.TyThing -import GHC.Types.Unique ( isValidKnownKeyUnique ) +import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways ) import GHC.Utils.Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) +import GHC.Parser.Annotation import GHC.Hs.Doc import GHC.Unit.Module.ModIface (IfaceExport) +import GHC.Unit.Module.Warnings import GHC.Data.List.SetOps import Control.Applicative ((<|>)) -import Data.List ( intercalate , find ) import Data.Maybe {- @@ -116,12 +121,8 @@ knownKeyNames :: [Name] knownKeyNames | debugIsOn - , Just badNamesStr <- knownKeyNamesOkay all_names - = panic ("badAllKnownKeyNames:\n" ++ badNamesStr) - -- NB: We can't use ppr here, because this is sometimes evaluated in a - -- context where there are no DynFlags available, leading to a cryptic - -- "<
>" error. (This seems to happen only in the - -- stage 2 compiler, for reasons I [Richard] have no clue of.) + , Just badNamesDoc <- knownKeyNamesOkay all_names + = pprPanic "badAllKnownKeyNames" badNamesDoc | otherwise = all_names where @@ -161,16 +162,15 @@ Nothing -> [] -- | Check the known-key names list of consistency. -knownKeyNamesOkay :: [Name] -> Maybe String +knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names - = Just $ " Out-of-range known-key uniques: [" - ++ intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" + = Just $ text " Out-of-range known-key uniques: " <> + brackets (pprWithCommas (ppr . nameOccName) ns) | null badNamesPairs = Nothing | otherwise - = Just badNamesStr + = Just badNamesDoc where namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) emptyUFM all_names @@ -178,14 +178,14 @@ badNamesPairs = nonDetUFMToList badNamesEnv -- It's OK to use nonDetUFMToList here because the ordering only affects -- the message when we get a panic - badNamesStrs = map pairToStr badNamesPairs - badNamesStr = unlines badNamesStrs + badNamesDoc :: SDoc + badNamesDoc = vcat $ map pairToDoc badNamesPairs - pairToStr (uniq, ns) = " " ++ - show uniq ++ - ": [" ++ - intercalate ", " (map (occNameString . nameOccName) ns) ++ - "]" + pairToDoc :: (Unique, [Name]) -> SDoc + pairToDoc (uniq, ns) = text " " <> + pprUniqueAlways uniq <> + text ": " <> + brackets (pprWithCommas (ppr . nameOccName) ns) -- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a -- known-key thing. @@ -247,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. +-} + {- ************************************************************************ diff --git a/GHC/Builtin/primops.txt.pp b/GHC/Builtin/primops.txt.pp --- a/GHC/Builtin/primops.txt.pp +++ b/GHC/Builtin/primops.txt.pp @@ -74,4141 +74,4383 @@ -- 2. The dummy Prim.hs file, which is used for Haddock and -- contains descriptions taken from primops.txt.pp. -- All definitions are replaced by placeholders. --- See Note [GHC.Prim Docs] in genprimopcode. --- --- 3. The module PrimopWrappers.hs, which wraps every call for GHCi; --- see Note [Primop wrappers] in GHC.Builtin.Primops for details. --- --- * This file does not list internal-only equality types --- (GHC.Builtin.Types.Prim.unexposedPrimTyCons and coercionToken# --- in GHC.Types.Id.Make) which are defined but not exported from GHC.Prim. --- Every export of GHC.Prim should be in listed in this file. --- --- * The primitive types should be listed in primTyCons in Builtin.Types.Prim --- in addition to primops.txt.pp. --- (This task should be delegated to genprimopcode in the future.) --- --- --- --- Information on how PrimOps are implemented and the steps necessary to --- add a new one can be found in the Commentary: --- --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops --- --- This file is divided into named sections, each containing or more --- primop entries. Section headers have the format: --- --- section "section-name" {haddock-description} --- --- This information is used solely when producing documentation; it is --- otherwise ignored. The haddock-description is optional. --- --- The format of each primop entry is as follows: --- --- primop internal-name "name-in-program-text" category type {haddock-description} attributes - --- The default attribute values which apply if you don't specify --- other ones. Attribute values can be True, False, or arbitrary --- text between curly brackets. This is a kludge to enable --- processors of this file to easily get hold of simple info --- (eg, out_of_line), whilst avoiding parsing complex expressions --- needed for strictness info. --- --- type refers to the general category of the primop. There are only two: --- --- * Compare: A comparison operation of the shape a -> a -> Int# --- * GenPrimOp: Any other sort of primop --- - --- The vector attribute is rather special. It takes a list of 3-tuples, each of --- which is of the form . ELEM_TYPE is the type of --- the elements in the vector; LENGTH is the length of the vector; and --- SCALAR_TYPE is the scalar type used to inject to/project from vector --- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example, --- to broadcast a scalar value to a vector whose elements are of type Int8, we --- use an Int#. - --- When a primtype or primop has a vector attribute, it is instantiated at each --- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to --- define a family of types or primops. Vector support also adds three new --- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types --- derived from the 3-tuple. For the 3-tuple , VECTOR expands to --- Int64X2#, SCALAR expands to Int64#, and VECTUPLE expands to (# Int64#, Int64# #). - -defaults - has_side_effects = False - out_of_line = False -- See Note [When do out-of-line primops go in primops.txt.pp] - can_fail = False -- See Note [PrimOp can_fail and has_side_effects] in PrimOp - commutable = False - code_size = { primOpCodeSizeDefault } - strictness = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv } - fixity = Nothing - llvm_only = False - vector = [] - deprecated_msg = {} -- A non-empty message indicates deprecation - --- Note [When do out-of-line primops go in primops.txt.pp] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Out of line primops are those with a C-- implementation. But that --- doesn't mean they *just* have an C-- implementation. As mentioned in --- Note [Inlining out-of-line primops and heap checks], some out-of-line --- primops also have additional internal implementations under certain --- conditions. Now that `foreign import prim` exists, only those primops --- which have both internal and external implementations ought to be --- this file. The rest aren't really primops, since they don't need --- bespoke compiler support but just a general way to interface with --- C--. They are just foreign calls. --- --- Unfortunately, for the time being most of the primops which should be --- moved according to the previous paragraph can't yet. There are some --- superficial restrictions in `foreign import prim` which must be fixed --- first. Specifically, `foreign import prim` always requires: --- --- - No polymorphism in type --- - `strictness = ` --- - `can_fail = False` --- - `has_side_effects = True` --- --- https://gitlab.haskell.org/ghc/ghc/issues/16929 tracks this issue, --- and has a table of which external-only primops are blocked by which --- of these. Hopefully those restrictions are relaxed so the rest of --- those can be moved over. --- --- 'module GHC.Prim.Ext is a temporarily "holding ground" for primops --- that were formally in here, until they can be given a better home. --- Likewise, their underlying C-- implementation need not live in the --- RTS either. Best case (in my view), both the C-- and `foreign import --- prim` can be moved to a small library tailured to the features being --- implemented and dependencies of those features. - --- Note [Levity and representation polymorphic primops] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In the types of primops in this module, --- --- * The names `a,b,c,s` stand for type variables of kind Type --- --- * The names `v` and `w` stand for levity-polymorphic --- type variables. --- For example: --- op :: v -> w -> Int --- really means --- op :: forall {l :: Levity} (a :: TYPE (BoxedRep l)) --- {k :: Levity} (b :: TYPE (BoxedRep k)). --- a -> b -> Int --- Two important things to note: --- - `v` and `w` have independent levities `l` and `k` (respectively), and --- these are inferred (not specified), as seen from the curly brackets. --- - `v` and `w` end up written as `a` and `b` (respectively) in types, --- which means that one shouldn't write a primop type involving both --- `a` and `v`, nor `b` and `w`. --- --- * The names `o` and `p` stand for representation-polymorphic --- type variables, similarly to `v` and `w` above. For example: --- op :: o -> p -> Int --- really means --- op :: forall {q :: RuntimeRep} (a :: TYPE q) --- {r :: RuntimeRep} (b :: TYPE r) --- a -> b -> Int --- We note: --- - `o` and `p` have independent `RuntimeRep`s `q` and `r`, which are --- inferred type variables (like for `v` and `w` above). --- - `o` and `p` share textual names with `a` and `b` (respectively). --- This means one shouldn't write a type involving both `a` and `o`, --- nor `b` and `p`, nor `o` and `v`, etc. - -section "The word size story." - {Haskell98 specifies that signed integers (type 'Int') - must contain at least 30 bits. GHC always implements - 'Int' using the primitive type 'Int#', whose size equals - the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@. - This is normally set based on the @config.h@ parameter - @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64 - bits on 64-bit machines. - - GHC also implements a primitive unsigned integer type - 'Word#' which always has the same number of bits as 'Int#'. - - In addition, GHC supports families of explicit-sized integers - and words at 8, 16, 32, and 64 bits, with the usual - arithmetic operations, comparisons, and a range of - conversions. - - Finally, there are strongly deprecated primops for coercing - between 'Addr#', the primitive type of machine - addresses, and 'Int#'. These are pretty bogus anyway, - but will work on existing 32-bit and 64-bit GHC targets; they - are completely bogus when tag bits are used in 'Int#', - so are not available in this case.} - ------------------------------------------------------------------------- -section "Char#" - {Operations on 31-bit characters.} ------------------------------------------------------------------------- - -primtype Char# - -primop CharGtOp "gtChar#" Compare Char# -> Char# -> Int# -primop CharGeOp "geChar#" Compare Char# -> Char# -> Int# - -primop CharEqOp "eqChar#" Compare - Char# -> Char# -> Int# - with commutable = True - -primop CharNeOp "neChar#" Compare - Char# -> Char# -> Int# - with commutable = True - -primop CharLtOp "ltChar#" Compare Char# -> Char# -> Int# -primop CharLeOp "leChar#" Compare Char# -> Char# -> Int# - -primop OrdOp "ord#" GenPrimOp Char# -> Int# - with code_size = 0 - ------------------------------------------------------------------------- -section "Int8#" - {Operations on 8-bit integers.} ------------------------------------------------------------------------- - -primtype Int8# - -primop Int8ToIntOp "int8ToInt#" GenPrimOp Int8# -> Int# -primop IntToInt8Op "intToInt8#" GenPrimOp Int# -> Int8# - -primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8# - -primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8# - with - commutable = True - -primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8# - -primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8# - with - commutable = True - -primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8# - with - can_fail = True - -primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8# - with - can_fail = True - -primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #) - with - can_fail = True - -primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# -primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# -primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8# - -primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8# - with code_size = 0 - -primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int# -primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int# -primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int# -primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int# -primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int# -primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int# - ------------------------------------------------------------------------- -section "Word8#" - {Operations on 8-bit unsigned words.} ------------------------------------------------------------------------- - -primtype Word8# - -primop Word8ToWordOp "word8ToWord#" GenPrimOp Word8# -> Word# -primop WordToWord8Op "wordToWord8#" GenPrimOp Word# -> Word8# - -primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with - commutable = True - -primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8# - -primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with - commutable = True - -primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with - can_fail = True - -primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with - can_fail = True - -primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #) - with - can_fail = True - -primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with commutable = True - -primop Word8OrOp "orWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with commutable = True - -primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8# - with commutable = True - -primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8# - -primop Word8SllOp "uncheckedShiftLWord8#" GenPrimOp Word8# -> Int# -> Word8# -primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8# - -primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8# - with code_size = 0 - -primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int# -primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int# -primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int# -primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int# -primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int# -primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int# - ------------------------------------------------------------------------- -section "Int16#" - {Operations on 16-bit integers.} ------------------------------------------------------------------------- - -primtype Int16# - -primop Int16ToIntOp "int16ToInt#" GenPrimOp Int16# -> Int# -primop IntToInt16Op "intToInt16#" GenPrimOp Int# -> Int16# - -primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16# - -primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16# - with - commutable = True - -primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16# - -primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16# - with - commutable = True - -primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16# - with - can_fail = True - -primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16# - with - can_fail = True - -primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #) - with - can_fail = True - -primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# -primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# -primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16# - -primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16# - with code_size = 0 - -primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int# -primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int# -primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int# -primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int# -primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int# -primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int# - ------------------------------------------------------------------------- -section "Word16#" - {Operations on 16-bit unsigned words.} ------------------------------------------------------------------------- - -primtype Word16# - -primop Word16ToWordOp "word16ToWord#" GenPrimOp Word16# -> Word# -primop WordToWord16Op "wordToWord16#" GenPrimOp Word# -> Word16# - -primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with - commutable = True - -primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16# - -primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with - commutable = True - -primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with - can_fail = True - -primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with - can_fail = True - -primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #) - with - can_fail = True - -primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with commutable = True - -primop Word16OrOp "orWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with commutable = True - -primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16# - with commutable = True - -primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16# - -primop Word16SllOp "uncheckedShiftLWord16#" GenPrimOp Word16# -> Int# -> Word16# -primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16# - -primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16# - with code_size = 0 - -primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int# -primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int# -primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int# -primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int# -primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int# -primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int# - ------------------------------------------------------------------------- -section "Int32#" - {Operations on 32-bit integers.} ------------------------------------------------------------------------- - -primtype Int32# - -primop Int32ToIntOp "int32ToInt#" GenPrimOp Int32# -> Int# -primop IntToInt32Op "intToInt32#" GenPrimOp Int# -> Int32# - -primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32# - -primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32# - with - commutable = True - -primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32# - -primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32# - with - commutable = True - -primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32# - with - can_fail = True - -primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32# - with - can_fail = True - -primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #) - with - can_fail = True - -primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# -primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# -primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# - -primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# - with code_size = 0 - -primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int# -primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int# -primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int# -primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int# -primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int# -primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int# - ------------------------------------------------------------------------- -section "Word32#" - {Operations on 32-bit unsigned words.} ------------------------------------------------------------------------- - -primtype Word32# - -primop Word32ToWordOp "word32ToWord#" GenPrimOp Word32# -> Word# -primop WordToWord32Op "wordToWord32#" GenPrimOp Word# -> Word32# - -primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with - commutable = True - -primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32# - -primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with - commutable = True - -primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with - can_fail = True - -primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with - can_fail = True - -primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #) - with - can_fail = True - -primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with commutable = True - -primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with commutable = True - -primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32# - with commutable = True - -primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32# - -primop Word32SllOp "uncheckedShiftLWord32#" GenPrimOp Word32# -> Int# -> Word32# -primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32# - -primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# - with code_size = 0 - -primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int# -primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int# -primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int# -primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int# -primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int# -primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int# - ------------------------------------------------------------------------- -section "Int64#" - {Operations on 64-bit signed words.} ------------------------------------------------------------------------- - -primtype Int64# - -primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int# -primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64# - -primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64# - -primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64# - with - commutable = True - -primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64# - -primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64# - with - commutable = True - -primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64# - with - can_fail = True - -primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# - with - can_fail = True - -primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# -primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# -primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64# - -primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# - with code_size = 0 - -primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int# -primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int# -primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int# -primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int# -primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int# -primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int# - ------------------------------------------------------------------------- -section "Word64#" - {Operations on 64-bit unsigned words.} ------------------------------------------------------------------------- - -primtype Word64# - -primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word# -primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64# - -primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64# - with - commutable = True - -primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64# - -primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64# - with - commutable = True - -primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64# - with - can_fail = True - -primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64# - with - can_fail = True - -primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64# - with commutable = True - -primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64# - with commutable = True - -primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64# - with commutable = True - -primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64# - -primop Word64SllOp "uncheckedShiftL64#" GenPrimOp Word64# -> Int# -> Word64# -primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# - -primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# - with code_size = 0 - -primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int# -primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int# -primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int# -primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int# -primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int# -primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int# - ------------------------------------------------------------------------- -section "Int#" - {Operations on native-size integers (32+ bits).} ------------------------------------------------------------------------- - -primtype Int# - -primop IntAddOp "+#" GenPrimOp - Int# -> Int# -> Int# - with commutable = True - fixity = infixl 6 - -primop IntSubOp "-#" GenPrimOp Int# -> Int# -> Int# - with fixity = infixl 6 - -primop IntMulOp "*#" - GenPrimOp Int# -> Int# -> Int# - {Low word of signed integer multiply.} - with commutable = True - fixity = infixl 7 - -primop IntMul2Op "timesInt2#" GenPrimOp - Int# -> Int# -> (# Int#, Int#, Int# #) - {Return a triple (isHighNeeded,high,low) where high and low are respectively - the high and low bits of the double-word result. isHighNeeded is a cheap way - to test if the high word is a sign-extension of the low word (isHighNeeded = - 0#) or not (isHighNeeded = 1#).} - -primop IntMulMayOfloOp "mulIntMayOflo#" - GenPrimOp Int# -> Int# -> Int# - {Return non-zero if there is any possibility that the upper word of a - signed integer multiply might contain useful information. Return - zero only if you are completely sure that no overflow can occur. - On a 32-bit platform, the recommended implementation is to do a - 32 x 32 -> 64 signed multiply, and subtract result[63:32] from - (result[31] >>signed 31). If this is zero, meaning that the - upper word is merely a sign extension of the lower one, no - overflow can occur. - - On a 64-bit platform it is not always possible to - acquire the top 64 bits of the result. Therefore, a recommended - implementation is to take the absolute value of both operands, and - return 0 iff bits[63:31] of them are zero, since that means that their - magnitudes fit within 31 bits, so the magnitude of the product must fit - into 62 bits. - - If in doubt, return non-zero, but do make an effort to create the - correct answer for small args, since otherwise the performance of - @(*) :: Integer -> Integer -> Integer@ will be poor. - } - with commutable = True - -primop IntQuotOp "quotInt#" GenPrimOp - Int# -> Int# -> Int# - {Rounds towards zero. The behavior is undefined if the second argument is - zero. - } - with can_fail = True - -primop IntRemOp "remInt#" GenPrimOp - Int# -> Int# -> Int# - {Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The - behavior is undefined if the second argument is zero. - } - with can_fail = True - -primop IntQuotRemOp "quotRemInt#" GenPrimOp - Int# -> Int# -> (# Int#, Int# #) - {Rounds towards zero.} - with can_fail = True - -primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int# - {Bitwise "and".} - with commutable = True - -primop IntOrOp "orI#" GenPrimOp Int# -> Int# -> Int# - {Bitwise "or".} - with commutable = True - -primop IntXorOp "xorI#" GenPrimOp Int# -> Int# -> Int# - {Bitwise "xor".} - with commutable = True - -primop IntNotOp "notI#" GenPrimOp Int# -> Int# - {Bitwise "not", also known as the binary complement.} - -primop IntNegOp "negateInt#" GenPrimOp Int# -> Int# - {Unary negation. - Since the negative 'Int#' range extends one further than the - positive range, 'negateInt#' of the most negative number is an - identity operation. This way, 'negateInt#' is always its own inverse.} - -primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) - {Add signed integers reporting overflow. - First member of result is the sum truncated to an 'Int#'; - second member is zero if the true sum fits in an 'Int#', - nonzero if overflow occurred (the sum is either too large - or too small to fit in an 'Int#').} - with code_size = 2 - commutable = True - -primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) - {Subtract signed integers reporting overflow. - First member of result is the difference truncated to an 'Int#'; - second member is zero if the true difference fits in an 'Int#', - nonzero if overflow occurred (the difference is either too large - or too small to fit in an 'Int#').} - with code_size = 2 - -primop IntGtOp ">#" Compare Int# -> Int# -> Int# - with fixity = infix 4 - -primop IntGeOp ">=#" Compare Int# -> Int# -> Int# - with fixity = infix 4 - -primop IntEqOp "==#" Compare - Int# -> Int# -> Int# - with commutable = True - fixity = infix 4 - -primop IntNeOp "/=#" Compare - Int# -> Int# -> Int# - with commutable = True - fixity = infix 4 - -primop IntLtOp "<#" Compare Int# -> Int# -> Int# - with fixity = infix 4 - -primop IntLeOp "<=#" Compare Int# -> Int# -> Int# - with fixity = infix 4 - -primop ChrOp "chr#" GenPrimOp Int# -> Char# - with code_size = 0 - -primop IntToWordOp "int2Word#" GenPrimOp Int# -> Word# - with code_size = 0 - -primop IntToFloatOp "int2Float#" GenPrimOp Int# -> Float# - {Convert an 'Int#' to the corresponding 'Float#' with the same - integral value (up to truncation due to floating-point precision). e.g. - @'int2Float#' 1# == 1.0#@} -primop IntToDoubleOp "int2Double#" GenPrimOp Int# -> Double# - {Convert an 'Int#' to the corresponding 'Double#' with the same - integral value (up to truncation due to floating-point precision). e.g. - @'int2Double#' 1# == 1.0##@} - -primop WordToFloatOp "word2Float#" GenPrimOp Word# -> Float# - {Convert an 'Word#' to the corresponding 'Float#' with the same - integral value (up to truncation due to floating-point precision). e.g. - @'word2Float#' 1## == 1.0#@} -primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double# - {Convert an 'Word#' to the corresponding 'Double#' with the same - integral value (up to truncation due to floating-point precision). e.g. - @'word2Double#' 1## == 1.0##@} - -primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# - {Shift left. Result undefined if shift amount is not - in the range 0 to word size - 1 inclusive.} -primop IntSraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# - {Shift right arithmetic. Result undefined if shift amount is not - in the range 0 to word size - 1 inclusive.} -primop IntSrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# - {Shift right logical. Result undefined if shift amount is not - in the range 0 to word size - 1 inclusive.} - ------------------------------------------------------------------------- -section "Word#" - {Operations on native-sized unsigned words (32+ bits).} ------------------------------------------------------------------------- - -primtype Word# - -primop WordAddOp "plusWord#" GenPrimOp Word# -> Word# -> Word# - with commutable = True - -primop WordAddCOp "addWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #) - {Add unsigned integers reporting overflow. - The first element of the pair is the result. The second element is - the carry flag, which is nonzero on overflow. See also 'plusWord2#'.} - with code_size = 2 - commutable = True - -primop WordSubCOp "subWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #) - {Subtract unsigned integers reporting overflow. - The first element of the pair is the result. The second element is - the carry flag, which is nonzero on overflow.} - with code_size = 2 - -primop WordAdd2Op "plusWord2#" GenPrimOp Word# -> Word# -> (# Word#, Word# #) - {Add unsigned integers, with the high part (carry) in the first - component of the returned pair and the low part in the second - component of the pair. See also 'addWordC#'.} - with code_size = 2 - commutable = True - -primop WordSubOp "minusWord#" GenPrimOp Word# -> Word# -> Word# - -primop WordMulOp "timesWord#" GenPrimOp Word# -> Word# -> Word# - with commutable = True - --- Returns (# high, low #) -primop WordMul2Op "timesWord2#" GenPrimOp - Word# -> Word# -> (# Word#, Word# #) - with commutable = True - -primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word# - with can_fail = True - -primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word# - with can_fail = True - -primop WordQuotRemOp "quotRemWord#" GenPrimOp - Word# -> Word# -> (# Word#, Word# #) - with can_fail = True - -primop WordQuotRem2Op "quotRemWord2#" GenPrimOp - Word# -> Word# -> Word# -> (# Word#, Word# #) - { Takes high word of dividend, then low word of dividend, then divisor. - Requires that high word < divisor.} - with can_fail = True - -primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word# - with commutable = True - -primop WordOrOp "or#" GenPrimOp Word# -> Word# -> Word# - with commutable = True - -primop WordXorOp "xor#" GenPrimOp Word# -> Word# -> Word# - with commutable = True - -primop WordNotOp "not#" GenPrimOp Word# -> Word# - -primop WordSllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# - {Shift left logical. Result undefined if shift amount is not - in the range 0 to word size - 1 inclusive.} -primop WordSrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# - {Shift right logical. Result undefined if shift amount is not - in the range 0 to word size - 1 inclusive.} - -primop WordToIntOp "word2Int#" GenPrimOp Word# -> Int# - with code_size = 0 - -primop WordGtOp "gtWord#" Compare Word# -> Word# -> Int# -primop WordGeOp "geWord#" Compare Word# -> Word# -> Int# -primop WordEqOp "eqWord#" Compare Word# -> Word# -> Int# -primop WordNeOp "neWord#" Compare Word# -> Word# -> Int# -primop WordLtOp "ltWord#" Compare Word# -> Word# -> Int# -primop WordLeOp "leWord#" Compare Word# -> Word# -> Int# - -primop PopCnt8Op "popCnt8#" GenPrimOp Word# -> Word# - {Count the number of set bits in the lower 8 bits of a word.} -primop PopCnt16Op "popCnt16#" GenPrimOp Word# -> Word# - {Count the number of set bits in the lower 16 bits of a word.} -primop PopCnt32Op "popCnt32#" GenPrimOp Word# -> Word# - {Count the number of set bits in the lower 32 bits of a word.} -primop PopCnt64Op "popCnt64#" GenPrimOp Word64# -> Word# - {Count the number of set bits in a 64-bit word.} -primop PopCntOp "popCnt#" GenPrimOp Word# -> Word# - {Count the number of set bits in a word.} - -primop Pdep8Op "pdep8#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to lower 8 bits of a word at locations specified by a mask. - - @since 0.5.2.0} -primop Pdep16Op "pdep16#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to lower 16 bits of a word at locations specified by a mask. - - @since 0.5.2.0} -primop Pdep32Op "pdep32#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to lower 32 bits of a word at locations specified by a mask. - - @since 0.5.2.0} -primop Pdep64Op "pdep64#" GenPrimOp Word64# -> Word64# -> Word64# - {Deposit bits to a word at locations specified by a mask. - - @since 0.5.2.0} -primop PdepOp "pdep#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to a word at locations specified by a mask, aka - [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract). - - Software emulation: - - > pdep :: Word -> Word -> Word - > pdep src mask = go 0 src mask - > where - > go :: Word -> Word -> Word -> Word - > go result _ 0 = result - > go result src mask = go newResult newSrc newMask - > where - > maskCtz = countTrailingZeros mask - > newResult = if testBit src 0 then setBit result maskCtz else result - > newSrc = src `shiftR` 1 - > newMask = clearBit mask maskCtz - - @since 0.5.2.0} - -primop Pext8Op "pext8#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from lower 8 bits of a word at locations specified by a mask. - - @since 0.5.2.0} -primop Pext16Op "pext16#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from lower 16 bits of a word at locations specified by a mask. - - @since 0.5.2.0} -primop Pext32Op "pext32#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from lower 32 bits of a word at locations specified by a mask. - - @since 0.5.2.0} -primop Pext64Op "pext64#" GenPrimOp Word64# -> Word64# -> Word64# - {Extract bits from a word at locations specified by a mask. - - @since 0.5.2.0} -primop PextOp "pext#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from a word at locations specified by a mask, aka - [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract). - - Software emulation: - - > pext :: Word -> Word -> Word - > pext src mask = loop 0 0 0 - > where - > loop i count result - > | i >= finiteBitSize (0 :: Word) - > = result - > | testBit mask i - > = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result) - > | otherwise - > = loop (i + 1) count result - - @since 0.5.2.0} - -primop Clz8Op "clz8#" GenPrimOp Word# -> Word# - {Count leading zeros in the lower 8 bits of a word.} -primop Clz16Op "clz16#" GenPrimOp Word# -> Word# - {Count leading zeros in the lower 16 bits of a word.} -primop Clz32Op "clz32#" GenPrimOp Word# -> Word# - {Count leading zeros in the lower 32 bits of a word.} -primop Clz64Op "clz64#" GenPrimOp Word64# -> Word# - {Count leading zeros in a 64-bit word.} -primop ClzOp "clz#" GenPrimOp Word# -> Word# - {Count leading zeros in a word.} - -primop Ctz8Op "ctz8#" GenPrimOp Word# -> Word# - {Count trailing zeros in the lower 8 bits of a word.} -primop Ctz16Op "ctz16#" GenPrimOp Word# -> Word# - {Count trailing zeros in the lower 16 bits of a word.} -primop Ctz32Op "ctz32#" GenPrimOp Word# -> Word# - {Count trailing zeros in the lower 32 bits of a word.} -primop Ctz64Op "ctz64#" GenPrimOp Word64# -> Word# - {Count trailing zeros in a 64-bit word.} -primop CtzOp "ctz#" GenPrimOp Word# -> Word# - {Count trailing zeros in a word.} - -primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word# - {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } -primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word# - {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } -primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64# - {Swap bytes in a 64 bits of a word.} -primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# - {Swap bytes in a word.} - -primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word# - {Reverse the order of the bits in a 8-bit word.} -primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word# - {Reverse the order of the bits in a 16-bit word.} -primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word# - {Reverse the order of the bits in a 32-bit word.} -primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64# - {Reverse the order of the bits in a 64-bit word.} -primop BRevOp "bitReverse#" GenPrimOp Word# -> Word# - {Reverse the order of the bits in a word.} - ------------------------------------------------------------------------- -section "Narrowings" - {Explicit narrowing of native-sized ints or words.} ------------------------------------------------------------------------- - -primop Narrow8IntOp "narrow8Int#" GenPrimOp Int# -> Int# -primop Narrow16IntOp "narrow16Int#" GenPrimOp Int# -> Int# -primop Narrow32IntOp "narrow32Int#" GenPrimOp Int# -> Int# -primop Narrow8WordOp "narrow8Word#" GenPrimOp Word# -> Word# -primop Narrow16WordOp "narrow16Word#" GenPrimOp Word# -> Word# -primop Narrow32WordOp "narrow32Word#" GenPrimOp Word# -> Word# - ------------------------------------------------------------------------- -section "Double#" - {Operations on double-precision (64 bit) floating-point numbers.} ------------------------------------------------------------------------- - -primtype Double# - -primop DoubleGtOp ">##" Compare Double# -> Double# -> Int# - with fixity = infix 4 - -primop DoubleGeOp ">=##" Compare Double# -> Double# -> Int# - with fixity = infix 4 - -primop DoubleEqOp "==##" Compare - Double# -> Double# -> Int# - with commutable = True - fixity = infix 4 - -primop DoubleNeOp "/=##" Compare - Double# -> Double# -> Int# - with commutable = True - fixity = infix 4 - -primop DoubleLtOp "<##" Compare Double# -> Double# -> Int# - with fixity = infix 4 - -primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int# - with fixity = infix 4 - -primop DoubleAddOp "+##" GenPrimOp - Double# -> Double# -> Double# - with commutable = True - fixity = infixl 6 - -primop DoubleSubOp "-##" GenPrimOp Double# -> Double# -> Double# - with fixity = infixl 6 - -primop DoubleMulOp "*##" GenPrimOp - Double# -> Double# -> Double# - with commutable = True - fixity = infixl 7 - -primop DoubleDivOp "/##" GenPrimOp - Double# -> Double# -> Double# - with can_fail = True - fixity = infixl 7 - -primop DoubleNegOp "negateDouble#" GenPrimOp Double# -> Double# - -primop DoubleFabsOp "fabsDouble#" GenPrimOp Double# -> Double# - -primop DoubleToIntOp "double2Int#" GenPrimOp Double# -> Int# - {Truncates a 'Double#' value to the nearest 'Int#'. - Results are undefined if the truncation if truncation yields - a value outside the range of 'Int#'.} - -primop DoubleToFloatOp "double2Float#" GenPrimOp Double# -> Float# - -primop DoubleExpOp "expDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleExpM1Op "expm1Double#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleLogOp "logDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop DoubleLog1POp "log1pDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop DoubleSqrtOp "sqrtDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleSinOp "sinDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleCosOp "cosDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleTanOp "tanDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleAsinOp "asinDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop DoubleAcosOp "acosDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop DoubleAtanOp "atanDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleSinhOp "sinhDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleCoshOp "coshDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleTanhOp "tanhDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleAsinhOp "asinhDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleAcoshOp "acoshDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleAtanhOp "atanhDouble#" GenPrimOp - Double# -> Double# - with - code_size = { primOpCodeSizeForeignCall } - -primop DoublePowerOp "**##" GenPrimOp - Double# -> Double# -> Double# - {Exponentiation.} - with - code_size = { primOpCodeSizeForeignCall } - -primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp - Double# -> (# Int#, Word#, Word#, Int# #) - {Convert to integer. - First component of the result is -1 or 1, indicating the sign of the - mantissa. The next two are the high and low 32 bits of the mantissa - respectively, and the last is the exponent.} - with out_of_line = True - -primop DoubleDecode_Int64Op "decodeDouble_Int64#" GenPrimOp - Double# -> (# Int64#, Int# #) - {Decode 'Double#' into mantissa and base-2 exponent.} - with out_of_line = True - ------------------------------------------------------------------------- -section "Float#" - {Operations on single-precision (32-bit) floating-point numbers.} ------------------------------------------------------------------------- - -primtype Float# - -primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Int# -primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Int# - -primop FloatEqOp "eqFloat#" Compare - Float# -> Float# -> Int# - with commutable = True - -primop FloatNeOp "neFloat#" Compare - Float# -> Float# -> Int# - with commutable = True - -primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Int# -primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int# - -primop FloatAddOp "plusFloat#" GenPrimOp - Float# -> Float# -> Float# - with commutable = True - -primop FloatSubOp "minusFloat#" GenPrimOp Float# -> Float# -> Float# - -primop FloatMulOp "timesFloat#" GenPrimOp - Float# -> Float# -> Float# - with commutable = True - -primop FloatDivOp "divideFloat#" GenPrimOp - Float# -> Float# -> Float# - with can_fail = True - -primop FloatNegOp "negateFloat#" GenPrimOp Float# -> Float# - -primop FloatFabsOp "fabsFloat#" GenPrimOp Float# -> Float# - -primop FloatToIntOp "float2Int#" GenPrimOp Float# -> Int# - {Truncates a 'Float#' value to the nearest 'Int#'. - Results are undefined if the truncation if truncation yields - a value outside the range of 'Int#'.} - -primop FloatExpOp "expFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatExpM1Op "expm1Float#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatLogOp "logFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop FloatLog1POp "log1pFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop FloatSqrtOp "sqrtFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatSinOp "sinFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatCosOp "cosFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatTanOp "tanFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatAsinOp "asinFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop FloatAcosOp "acosFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop FloatAtanOp "atanFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatSinhOp "sinhFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatCoshOp "coshFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatTanhOp "tanhFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatAsinhOp "asinhFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatAcoshOp "acoshFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatAtanhOp "atanhFloat#" GenPrimOp - Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatPowerOp "powerFloat#" GenPrimOp - Float# -> Float# -> Float# - with - code_size = { primOpCodeSizeForeignCall } - -primop FloatToDoubleOp "float2Double#" GenPrimOp Float# -> Double# - -primop FloatDecode_IntOp "decodeFloat_Int#" GenPrimOp - Float# -> (# Int#, Int# #) - {Convert to integers. - First 'Int#' in result is the mantissa; second is the exponent.} - with out_of_line = True - ------------------------------------------------------------------------- -section "Fused multiply-add operations" - { #fma# - - The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#' - implement the operation - - \[ - \lambda\ x\ y\ z \rightarrow x * y + z - \] - - with a single floating-point rounding operation at the end, as opposed to - rounding twice (which can accumulate rounding errors). - - These primops can be compiled directly to a single machine instruction on - architectures that support them. Currently, these are: - - 1. x86 with CPUs that support the FMA3 extended instruction set (which - includes most processors since 2013). - 2. PowerPC. - 3. AArch64. - - This requires users pass the '-mfma' flag to GHC. Otherwise, the primop - is implemented by falling back to the C standard library, which might - perform software emulation (this may yield results that are not IEEE - compliant on some platforms). - - The additional operations 'fmsubFloat#'/'fmsubDouble#', - 'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide - variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed: - - \[ - \begin{aligned} - \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt] - \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt] - \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt] - \mathrm{fnmsub}\ x\ y\ z &= - x * y - z - \end{aligned} - \] - - } ------------------------------------------------------------------------- - -primop FloatFMAdd "fmaddFloat#" GenPrimOp - Float# -> Float# -> Float# -> Float# - {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} -primop FloatFMSub "fmsubFloat#" GenPrimOp - Float# -> Float# -> Float# -> Float# - {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} -primop FloatFNMAdd "fnmaddFloat#" GenPrimOp - Float# -> Float# -> Float# -> Float# - {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} -primop FloatFNMSub "fnmsubFloat#" GenPrimOp - Float# -> Float# -> Float# -> Float# - {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} - -primop DoubleFMAdd "fmaddDouble#" GenPrimOp - Double# -> Double# -> Double# -> Double# - {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} -primop DoubleFMSub "fmsubDouble#" GenPrimOp - Double# -> Double# -> Double# -> Double# - {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} -primop DoubleFNMAdd "fnmaddDouble#" GenPrimOp - Double# -> Double# -> Double# -> Double# - {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} -primop DoubleFNMSub "fnmsubDouble#" GenPrimOp - Double# -> Double# -> Double# -> Double# - {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} - ------------------------------------------------------------------------- -section "Arrays" - {Operations on 'Array#'.} ------------------------------------------------------------------------- - -primtype Array# a - -primtype MutableArray# s a - -primop NewArrayOp "newArray#" GenPrimOp - Int# -> v -> State# s -> (# State# s, MutableArray# s v #) - {Create a new mutable array with the specified number of elements, - in the specified state thread, - with each element containing the specified initial value.} - with - out_of_line = True - has_side_effects = True - -primop ReadArrayOp "readArray#" GenPrimOp - MutableArray# s v -> Int# -> State# s -> (# State# s, v #) - {Read from specified index of mutable array. Result is not yet evaluated.} - with - has_side_effects = True - can_fail = True - -primop WriteArrayOp "writeArray#" GenPrimOp - MutableArray# s v -> Int# -> v -> State# s -> State# s - {Write to specified index of mutable array.} - with - has_side_effects = True - can_fail = True - code_size = 2 -- card update too - -primop SizeofArrayOp "sizeofArray#" GenPrimOp - Array# v -> Int# - {Return the number of elements in the array.} - -primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp - MutableArray# s v -> Int# - {Return the number of elements in the array.} - -primop IndexArrayOp "indexArray#" GenPrimOp - Array# v -> Int# -> (# v #) - {Read from the specified index of an immutable array. The result is packaged - into an unboxed unary tuple; the result itself is not yet - evaluated. Pattern matching on the tuple forces the indexing of the - array to happen but does not evaluate the element itself. Evaluating - the thunk prevents additional thunks from building up on the - heap. Avoiding these thunks, in turn, reduces references to the - argument array, allowing it to be garbage collected more promptly.} - with - can_fail = True - -primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp - MutableArray# s v -> State# s -> (# State# s, Array# v #) - {Make a mutable array immutable, without copying.} - with - has_side_effects = True - -primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp - Array# v -> State# s -> (# State# s, MutableArray# s v #) - {Make an immutable array mutable, without copying.} - with - out_of_line = True - has_side_effects = True - -primop CopyArrayOp "copyArray#" GenPrimOp - Array# v -> Int# -> MutableArray# s v -> Int# -> Int# -> State# s -> State# s - {Given a source array, an offset into the source array, a - destination array, an offset into the destination array, and a - number of elements to copy, copy the elements from the source array - to the destination array. Both arrays must fully contain the - specified ranges, but this is not checked. The two arrays must not - be the same array in different states, but this is not checked - either.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp - MutableArray# s v -> Int# -> MutableArray# s v -> Int# -> Int# -> State# s -> State# s - {Given a source array, an offset into the source array, a - destination array, an offset into the destination array, and a - number of elements to copy, copy the elements from the source array - to the destination array. Both arrays must fully contain the - specified ranges, but this is not checked. In the case where - the source and destination are the same array the source and - destination regions may overlap.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CloneArrayOp "cloneArray#" GenPrimOp - Array# v -> Int# -> Int# -> Array# v - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp - MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #) - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop FreezeArrayOp "freezeArray#" GenPrimOp - MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, Array# v #) - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop ThawArrayOp "thawArray#" GenPrimOp - Array# v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #) - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CasArrayOp "casArray#" GenPrimOp - MutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #) - {Given an array, an offset, the expected old value, and - the new value, perform an atomic compare and swap (i.e. write the new - value if the current value and the old value are the same pointer). - Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns - the element at the offset after the operation completes. This means that - on a success the new value is returned, and on a failure the actual old - value (not the expected one) is returned. Implies a full memory barrier. - The use of a pointer equality on a boxed value makes this function harder - to use correctly than 'casIntArray#'. All of the difficulties - of using 'reallyUnsafePtrEquality#' correctly apply to - 'casArray#' as well. - } - with - out_of_line = True - has_side_effects = True - can_fail = True -- Might index out of bounds - - ------------------------------------------------------------------------- -section "Small Arrays" - - {Operations on 'SmallArray#'. A 'SmallArray#' works - just like an 'Array#', but with different space use and - performance characteristics (that are often useful with small - arrays). The 'SmallArray#' and 'SmallMutableArray#' - lack a `card table'. The purpose of a card table is to avoid - having to scan every element of the array on each GC by - keeping track of which elements have changed since the last GC - and only scanning those that have changed. So the consequence - of there being no card table is that the representation is - somewhat smaller and the writes are somewhat faster (because - the card table does not need to be updated). The disadvantage - of course is that for a 'SmallMutableArray#' the whole - array has to be scanned on each GC. Thus it is best suited for - use cases where the mutable array is not long lived, e.g. - where a mutable array is initialised quickly and then frozen - to become an immutable 'SmallArray#'. - } - ------------------------------------------------------------------------- - -primtype SmallArray# a - -primtype SmallMutableArray# s a - -primop NewSmallArrayOp "newSmallArray#" GenPrimOp - Int# -> v -> State# s -> (# State# s, SmallMutableArray# s v #) - {Create a new mutable array with the specified number of elements, - in the specified state thread, - with each element containing the specified initial value.} - with - out_of_line = True - has_side_effects = True - -primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> State# s -> State# s - {Shrink mutable array to new specified size, in - the specified state thread. The new size argument must be less than or - equal to the current size as reported by 'getSizeofSmallMutableArray#'. - - Assuming the non-profiling RTS, for the copying garbage collector - (default) this primitive compiles to an O(1) operation in C--, modifying - the array in-place. For the non-moving garbage collector, however, the - time is proportional to the number of elements shrinked out. Backends - bypassing C-- representation (such as JavaScript) might behave - differently. - - @since 0.6.1} - with out_of_line = True - has_side_effects = True - -primop ReadSmallArrayOp "readSmallArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> State# s -> (# State# s, v #) - {Read from specified index of mutable array. Result is not yet evaluated.} - with - has_side_effects = True - can_fail = True - -primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> v -> State# s -> State# s - {Write to specified index of mutable array.} - with - has_side_effects = True - can_fail = True - -primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp - SmallArray# v -> Int# - {Return the number of elements in the array.} - -primop SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp - SmallMutableArray# s v -> Int# - {Return the number of elements in the array. __Deprecated__, it is - unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@ - operations on the same small mutable array.} - with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead } - -primop GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp - SmallMutableArray# s v -> State# s -> (# State# s, Int# #) - {Return the number of elements in the array, correctly accounting for - the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@. - - @since 0.6.1} - -primop IndexSmallArrayOp "indexSmallArray#" GenPrimOp - SmallArray# v -> Int# -> (# v #) - {Read from specified index of immutable array. Result is packaged into - an unboxed singleton; the result itself is not yet evaluated.} - with - can_fail = True - -primop UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp - SmallMutableArray# s v -> State# s -> (# State# s, SmallArray# v #) - {Make a mutable array immutable, without copying.} - with - has_side_effects = True - -primop UnsafeThawSmallArrayOp "unsafeThawSmallArray#" GenPrimOp - SmallArray# v -> State# s -> (# State# s, SmallMutableArray# s v #) - {Make an immutable array mutable, without copying.} - with - out_of_line = True - has_side_effects = True - --- The code_size is only correct for the case when the copy family of --- primops aren't inlined. It would be nice to keep track of both. - -primop CopySmallArrayOp "copySmallArray#" GenPrimOp - SmallArray# v -> Int# -> SmallMutableArray# s v -> Int# -> Int# -> State# s -> State# s - {Given a source array, an offset into the source array, a - destination array, an offset into the destination array, and a - number of elements to copy, copy the elements from the source array - to the destination array. Both arrays must fully contain the - specified ranges, but this is not checked. The two arrays must not - be the same array in different states, but this is not checked - either.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> SmallMutableArray# s v -> Int# -> Int# -> State# s -> State# s - {Given a source array, an offset into the source array, a - destination array, an offset into the destination array, and a - number of elements to copy, copy the elements from the source array - to the destination array. The source and destination arrays can - refer to the same array. Both arrays must fully contain the - specified ranges, but this is not checked. - The regions are allowed to overlap, although this is only possible when the same - array is provided as both the source and the destination. } - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CloneSmallArrayOp "cloneSmallArray#" GenPrimOp - SmallArray# v -> Int# -> Int# -> SmallArray# v - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #) - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallArray# v #) - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp - SmallArray# v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #) - {Given a source array, an offset into the source array, and a number - of elements to copy, create a new array with the elements from the - source array. The provided array must fully contain the specified - range, but this is not checked.} - with - out_of_line = True - has_side_effects = True - can_fail = True - -primop CasSmallArrayOp "casSmallArray#" GenPrimOp - SmallMutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #) - {Unsafe, machine-level atomic compare and swap on an element within an array. - See the documentation of 'casArray#'.} - with - out_of_line = True - has_side_effects = True - can_fail = True -- Might index out of bounds - ------------------------------------------------------------------------- -section "Byte Arrays" - {A 'ByteArray#' is a region of - raw memory in the garbage-collected heap, which is not - scanned for pointers. - There are three sets of operations for accessing byte array contents: - index for reading from immutable byte arrays, and read/write - for mutable byte arrays. Each set contains operations for a - range of useful primitive data types. Each operation takes - an offset measured in terms of the size of the primitive type - being read or written. - - } - ------------------------------------------------------------------------- - -primtype ByteArray# -{ - A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap, - which is not scanned for pointers during garbage collection. - - It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'. - Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood. - - The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures, - like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@. - - Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'. - - The representation on the heap of a Byte Array is: - - > +------------+-----------------+-----------------------+ - > | | | | - > | HEADER | SIZE (in bytes) | PAYLOAD | - > | | | | - > +------------+-----------------+-----------------------+ - - To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'. - - Alternatively, enabling the @UnliftedFFITypes@ extension - allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly. -} - -primtype MutableByteArray# s -{ A mutable 'ByteAray#'. It can be created in three ways: - - * 'newByteArray#': Create an unpinned array. - * 'newPinnedByteArray#': This will create a pinned array, - * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment. - - Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values - if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls, - because no garbage collection happens during these unsafe calls - (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety) - in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function - for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether). -} - -primop NewByteArrayOp_Char "newByteArray#" GenPrimOp - Int# -> State# s -> (# State# s, MutableByteArray# s #) - {Create a new mutable byte array of specified size (in bytes), in - the specified state thread. The size of the memory underlying the - array will be rounded up to the platform's word size.} - with out_of_line = True - has_side_effects = True - -primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp - Int# -> State# s -> (# State# s, MutableByteArray# s #) - {Like 'newByteArray#' but GC guarantees not to move it.} - with out_of_line = True - has_side_effects = True - -primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp - Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #) - {Like 'newPinnedByteArray#' but allow specifying an arbitrary - alignment, which must be a power of two.} - with out_of_line = True - has_side_effects = True - -primop MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp - MutableByteArray# s -> Int# - {Determine whether a 'MutableByteArray#' is guaranteed not to move - during GC.} - with out_of_line = True - -primop ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp - ByteArray# -> Int# - {Determine whether a 'ByteArray#' is guaranteed not to move during GC.} - with out_of_line = True - -primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp - ByteArray# -> Addr# - {Intended for use with pinned arrays; otherwise very unsafe!} - -primop MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp - MutableByteArray# s -> Addr# - {Intended for use with pinned arrays; otherwise very unsafe!} - -primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> State# s - {Shrink mutable byte array to new specified size (in bytes), in - the specified state thread. The new size argument must be less than or - equal to the current size as reported by 'getSizeofMutableByteArray#'. - - Assuming the non-profiling RTS, this primitive compiles to an O(1) - operation in C--, modifying the array in-place. Backends bypassing C-- - representation (such as JavaScript) might behave differently. - - @since 0.4.0.0} - with out_of_line = True - has_side_effects = True - -primop ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) - {Resize mutable byte array to new specified size (in bytes), shrinking or growing it. - The returned 'MutableByteArray#' is either the original - 'MutableByteArray#' resized in-place or, if not possible, a newly - allocated (unpinned) 'MutableByteArray#' (with the original content - copied over). - - To avoid undefined behaviour, the original 'MutableByteArray#' shall - not be accessed anymore after a 'resizeMutableByteArray#' has been - performed. Moreover, no reference to the old one should be kept in order - to allow garbage collection of the original 'MutableByteArray#' in - case a new 'MutableByteArray#' had to be allocated. - - @since 0.4.0.0} - with out_of_line = True - has_side_effects = True - -primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp - MutableByteArray# s -> State# s -> (# State# s, ByteArray# #) - {Make a mutable byte array immutable, without copying.} - with - has_side_effects = True - -primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp - ByteArray# -> Int# - {Return the size of the array in bytes.} - -primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp - MutableByteArray# s -> Int# - {Return the size of the array in bytes. __Deprecated__, it is - unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#' - operations on the same mutable byte - array.} - with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead } - -primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp - MutableByteArray# s -> State# s -> (# State# s, Int# #) - {Return the number of elements in the array, correctly accounting for - the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'. - - @since 0.5.0.0} - - -bytearray_access_ops --- This generates a whole bunch of primops; --- see utils/genprimopcode/AccessOps.hs - - -primop CompareByteArraysOp "compareByteArrays#" GenPrimOp - ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# - {@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares - @n@ bytes starting at offset @src1_ofs@ in the first - 'ByteArray#' @src1@ to the range of @n@ bytes - (i.e. same length) starting at offset @src2_ofs@ of the second - 'ByteArray#' @src2@. Both arrays must fully contain the - specified ranges, but this is not checked. Returns an 'Int#' - less than, equal to, or greater than zero if the range is found, - respectively, to be byte-wise lexicographically less than, to - match, or be greater than the second range.} - with - can_fail = True - -primop CopyByteArrayOp "copyByteArray#" GenPrimOp - ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - { @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range - starting at offset @src_ofs@ of length @len@ from the - 'ByteArray#' @src@ to the 'MutableByteArray#' @dst@ - starting at offset @dst_ofs@. Both arrays must fully contain - the specified ranges, but this is not checked. The two arrays must - not be the same array in different states, but this is not checked - either. - } - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4} - can_fail = True - -primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp - MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - { @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the - range starting at offset @src_ofs@ of length @len@ from the - 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@ - starting at offset @dst_ofs@. Both arrays must fully contain the - specified ranges, but this is not checked. The regions are - allowed to overlap, although this is only possible when the same - array is provided as both the source and the destination. - } - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4 } - can_fail = True - -primop CopyMutableByteArrayNonOverlappingOp "copyMutableByteArrayNonOverlapping#" GenPrimOp - MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - { @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@ - copies the range starting at offset @src_ofs@ of length @len@ from - the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@ - starting at offset @dst_ofs@. Both arrays must fully contain the - specified ranges, but this is not checked. The regions are /not/ - allowed to overlap, but this is also not checked. - - @since 0.11.0 - } - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4 } - can_fail = True - -primop CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp - ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s - {Copy a range of the ByteArray\# to the memory range starting at the Addr\#. - The ByteArray\# and the memory region at Addr\# must fully contain the - specified ranges, but this is not checked. The Addr\# must not point into the - ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked - either.} - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4 } - can_fail = True - -primop CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp - MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s - {Copy a range of the MutableByteArray\# to the memory range starting at the - Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully - contain the specified ranges, but this is not checked. The Addr\# must not - point into the MutableByteArray\# (e.g. if the MutableByteArray\# were - pinned), but this is not checked either.} - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4 } - can_fail = True - -primop CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp - Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - {Copy a memory range starting at the Addr\# to the specified range in the - MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully - contain the specified ranges, but this is not checked. The Addr\# must not - point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned), - but this is not checked either.} - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4 } - can_fail = True - -primop CopyAddrToAddrOp "copyAddrToAddr#" GenPrimOp - Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld - { @'copyAddrToAddr#' src dest len@ copies @len@ bytes - from @src@ to @dest@. These two memory ranges are allowed to overlap. - - Analogous to the standard C function @memmove@, but with a different - argument order. - - @since 0.11.0 - } - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop CopyAddrToAddrNonOverlappingOp "copyAddrToAddrNonOverlapping#" GenPrimOp - Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld - { @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes - from @src@ to @dest@. As the name suggests, these two memory ranges - /must not overlap/, although this pre-condition is not checked. - - Analogous to the standard C function @memcpy@, but with a different - argument order. - - @since 0.11.0 - } - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall } - can_fail = True - -primop SetByteArrayOp "setByteArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s - {@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of - the 'MutableByteArray#' to the byte @c@.} - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall + 4 } - can_fail = True - -primop SetAddrRangeOp "setAddrRange#" GenPrimOp - Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld - { @'setAddrRange#' dest len c@ sets all of the bytes in - @[dest, dest+len)@ to the value @c@. - - Analogous to the standard C function @memset@, but with a different - argument order. - - @since 0.11.0 - } - with - has_side_effects = True - code_size = { primOpCodeSizeForeignCall } - can_fail = True - --- Atomic operations - -primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) - {Given an array and an offset in machine words, read an element. The - index is assumed to be in bounds. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - {Given an array and an offset in machine words, write an element. The - index is assumed to be in bounds. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop CasByteArrayOp_Int "casIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, an offset in machine words, the expected old value, and - the new value, perform an atomic compare and swap i.e. write the new - value if the current value matches the provided old value. Returns - the value of the element before the operation. Implies a full memory - barrier.} - with has_side_effects = True - can_fail = True - -primop CasByteArrayOp_Int8 "casInt8Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s, Int8# #) - {Given an array, an offset in bytes, the expected old value, and - the new value, perform an atomic compare and swap i.e. write the new - value if the current value matches the provided old value. Returns - the value of the element before the operation. Implies a full memory - barrier.} - with has_side_effects = True - can_fail = True - -primop CasByteArrayOp_Int16 "casInt16Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s, Int16# #) - {Given an array, an offset in 16 bit units, the expected old value, and - the new value, perform an atomic compare and swap i.e. write the new - value if the current value matches the provided old value. Returns - the value of the element before the operation. Implies a full memory - barrier.} - with has_side_effects = True - can_fail = True - -primop CasByteArrayOp_Int32 "casInt32Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s, Int32# #) - {Given an array, an offset in 32 bit units, the expected old value, and - the new value, perform an atomic compare and swap i.e. write the new - value if the current value matches the provided old value. Returns - the value of the element before the operation. Implies a full memory - barrier.} - with has_side_effects = True - can_fail = True - -primop CasByteArrayOp_Int64 "casInt64Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s, Int64# #) - {Given an array, an offset in 64 bit units, the expected old value, and - the new value, perform an atomic compare and swap i.e. write the new - value if the current value matches the provided old value. Returns - the value of the element before the operation. Implies a full memory - barrier.} - with has_side_effects = True - can_fail = True - -primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, and offset in machine words, and a value to add, - atomically add the value to the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, and offset in machine words, and a value to subtract, - atomically subtract the value from the element. Returns the value of - the element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, and offset in machine words, and a value to AND, - atomically AND the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, and offset in machine words, and a value to NAND, - atomically NAND the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, and offset in machine words, and a value to OR, - atomically OR the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) - {Given an array, and offset in machine words, and a value to XOR, - atomically XOR the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - ------------------------------------------------------------------------- -section "Addr#" ------------------------------------------------------------------------- - -primtype Addr# - { An arbitrary machine address assumed to point outside - the garbage-collected heap. } - -pseudoop "nullAddr#" Addr# - { The null address. } - -primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# -primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# - {Result is meaningless if two 'Addr#'s are so far apart that their - difference doesn't fit in an 'Int#'.} -primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# - {Return the remainder when the 'Addr#' arg, treated like an 'Int#', - is divided by the 'Int#' arg.} -primop AddrToIntOp "addr2Int#" GenPrimOp Addr# -> Int# - {Coerce directly from address to int.} - with code_size = 0 - deprecated_msg = { This operation is strongly deprecated. } -primop IntToAddrOp "int2Addr#" GenPrimOp Int# -> Addr# - {Coerce directly from int to address.} - with code_size = 0 - deprecated_msg = { This operation is strongly deprecated. } - -primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Int# -primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Int# -primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Int# -primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Int# -primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Int# -primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Int# - - -addr_access_ops --- This generates a whole bunch of primops; --- see utils/genprimopcode/AccessOps.hs - - -primop InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp - Addr# -> Addr# -> State# s -> (# State# s, Addr# #) - {The atomic exchange operation. Atomically exchanges the value at the first address - with the Addr# given as second argument. Implies a read barrier.} - with has_side_effects = True - can_fail = True - -primop InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {The atomic exchange operation. Atomically exchanges the value at the address - with the given value. Returns the old value. Implies a read barrier.} - with has_side_effects = True - can_fail = True - -primop CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp - Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #) - { Compare and swap on a word-sized memory location. - - Use as: \s -> atomicCasAddrAddr# location expected desired s - - This version always returns the old value read. This follows the normal - protocol for CAS operations (and matches the underlying instruction on - most architectures). - - Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp - Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #) - { Compare and swap on a word-sized and aligned memory location. - - Use as: \s -> atomicCasWordAddr# location expected desired s - - This version always returns the old value read. This follows the normal - protocol for CAS operations (and matches the underlying instruction on - most architectures). - - Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop CasAddrOp_Word8 "atomicCasWord8Addr#" GenPrimOp - Addr# -> Word8# -> Word8# -> State# s -> (# State# s, Word8# #) - { Compare and swap on a 8 bit-sized and aligned memory location. - - Use as: \s -> atomicCasWordAddr8# location expected desired s - - This version always returns the old value read. This follows the normal - protocol for CAS operations (and matches the underlying instruction on - most architectures). - - Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop CasAddrOp_Word16 "atomicCasWord16Addr#" GenPrimOp - Addr# -> Word16# -> Word16# -> State# s -> (# State# s, Word16# #) - { Compare and swap on a 16 bit-sized and aligned memory location. - - Use as: \s -> atomicCasWordAddr16# location expected desired s - - This version always returns the old value read. This follows the normal - protocol for CAS operations (and matches the underlying instruction on - most architectures). - - Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop CasAddrOp_Word32 "atomicCasWord32Addr#" GenPrimOp - Addr# -> Word32# -> Word32# -> State# s -> (# State# s, Word32# #) - { Compare and swap on a 32 bit-sized and aligned memory location. - - Use as: \s -> atomicCasWordAddr32# location expected desired s - - This version always returns the old value read. This follows the normal - protocol for CAS operations (and matches the underlying instruction on - most architectures). - - Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop CasAddrOp_Word64 "atomicCasWord64Addr#" GenPrimOp - Addr# -> Word64# -> Word64# -> State# s -> (# State# s, Word64# #) - { Compare and swap on a 64 bit-sized and aligned memory location. - - Use as: \s -> atomicCasWordAddr64# location expected desired s - - This version always returns the old value read. This follows the normal - protocol for CAS operations (and matches the underlying instruction on - most architectures). - - Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {Given an address, and a value to add, - atomically add the value to the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {Given an address, and a value to subtract, - atomically subtract the value from the element. Returns the value of - the element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchAndAddrOp_Word "fetchAndWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {Given an address, and a value to AND, - atomically AND the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchNandAddrOp_Word "fetchNandWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {Given an address, and a value to NAND, - atomically NAND the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchOrAddrOp_Word "fetchOrWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {Given an address, and a value to OR, - atomically OR the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop FetchXorAddrOp_Word "fetchXorWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> (# State# s, Word# #) - {Given an address, and a value to XOR, - atomically XOR the value into the element. Returns the value of the - element before the operation. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp - Addr# -> State# s -> (# State# s, Word# #) - {Given an address, read a machine word. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - -primop AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp - Addr# -> Word# -> State# s -> State# s - {Given an address, write a machine word. Implies a full memory barrier.} - with has_side_effects = True - can_fail = True - - ------------------------------------------------------------------------- -section "Mutable variables" - {Operations on MutVar\#s.} ------------------------------------------------------------------------- - -primtype MutVar# s a - {A 'MutVar#' behaves like a single-element mutable array.} - -primop NewMutVarOp "newMutVar#" GenPrimOp - v -> State# s -> (# State# s, MutVar# s v #) - {Create 'MutVar#' with specified initial value in specified state thread.} - with - out_of_line = True - has_side_effects = True - --- Note [Why MutVar# ops can't fail] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- We don't label readMutVar# or writeMutVar# as can_fail. --- This may seem a bit peculiar, because they surely *could* --- fail spectacularly if passed a pointer to unallocated memory. --- But MutVar#s are always correct by construction; we never --- test if a pointer is valid before using it with these operations. --- So we never have to worry about floating the pointer reference --- outside a validity test. At the moment, has_side_effects blocks --- up the relevant optimizations anyway, but we hope to draw finer --- distinctions soon, which should improve matters for readMutVar# --- at least. - -primop ReadMutVarOp "readMutVar#" GenPrimOp - MutVar# s v -> State# s -> (# State# s, v #) - {Read contents of 'MutVar#'. Result is not yet evaluated.} - with - -- See Note [Why MutVar# ops can't fail] - has_side_effects = True - -primop WriteMutVarOp "writeMutVar#" GenPrimOp - MutVar# s v -> v -> State# s -> State# s - {Write contents of 'MutVar#'.} - with - -- See Note [Why MutVar# ops can't fail] - has_side_effects = True - code_size = { primOpCodeSizeForeignCall } -- for the write barrier - -primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp - MutVar# s v -> v -> State# s -> (# State# s, v #) - {Atomically exchange the value of a 'MutVar#'.} - with - has_side_effects = True - --- Note [Why not an unboxed tuple in atomicModifyMutVar2#?] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Looking at the type of atomicModifyMutVar2#, one might wonder why --- it doesn't return an unboxed tuple. e.g., --- --- MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #) --- --- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity. --- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces --- its contents with a thunk of the form (fst (f x)). This can be done using an --- atomic compare-and-swap as it is merely replacing a pointer. - -primop AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp - MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #) - { Modify the contents of a 'MutVar#', returning the previous - contents @x :: a@ and the result of applying the given function to the - previous contents @f x :: c@. - - The @data@ type @c@ (not a @newtype@!) must be a record whose first field - is of lifted type @a :: Type@ and is not unpacked. For example, product - types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both - monomorphic and strict in its first field, it's recommended to mark the - latter @{-# NOUNPACK #-}@ explicitly. - - Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an - old @x :: a@ with a pointer to a selector thunk @fst r@, where - @fst@ is a selector for the first field of the record and @r@ is a - function application thunk @r = f x@. - - @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an - effort to reflect restrictions on @c@ faithfully, providing a - well-typed high-level wrapper.} - with - out_of_line = True - has_side_effects = True - can_fail = True - strictness = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv } - -primop AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp - MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #) - { Modify the contents of a 'MutVar#', returning the previous - contents and the result of applying the given function to the - previous contents. } - with - out_of_line = True - has_side_effects = True - can_fail = True - strictness = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv } - -primop CasMutVarOp "casMutVar#" GenPrimOp - MutVar# s v -> v -> v -> State# s -> (# State# s, Int#, v #) - { Compare-and-swap: perform a pointer equality test between - the first value passed to this function and the value - stored inside the 'MutVar#'. If the pointers are equal, - replace the stored value with the second value passed to this - function, otherwise do nothing. - Returns the final value stored inside the 'MutVar#'. - The 'Int#' indicates whether a swap took place, - with @1#@ meaning that we didn't swap, and @0#@ - that we did. - Implies a full memory barrier. - Because the comparison is done on the level of pointers, - all of the difficulties of using - 'reallyUnsafePtrEquality#' correctly apply to - 'casMutVar#' as well. - } - with - out_of_line = True - has_side_effects = True - ------------------------------------------------------------------------- -section "Exceptions" ------------------------------------------------------------------------- - --- Note [Strict IO wrappers] --- ~~~~~~~~~~~~~~~~~~~~~~~~~ --- Consider this example, which comes from GHC.IO.Handle.Internals: --- wantReadableHandle3 f mv b st --- = case ... of --- DEFAULT -> case mv of MVar a -> ... --- 0# -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...) --- The outer case just decides whether to mask exceptions, but we don't want --- thereby to hide the strictness in `mv`! Hence the use of strictOnceApply1Dmd --- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect --- that it potentially calls its action multiple times). --- --- Note [Strictness for catch-style primops] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The catch#-style primops always call their action, just like outlined --- in Note [Strict IO wrappers]. --- However, it is important that we give their first arg lazyApply1Dmd and not --- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call --- --- catch# act handler s --- --- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that --- the call forwards the dead-end flag from `act` (see Note [Dead ends] and --- Note [Precise exceptions and strictness analysis]). --- This would cause dead code elimination to discard the continuation of the --- catch# call, among other things. This first came up in #11555. --- --- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag --- from `act`. (This is a bit brutal, but the language of strictness types is --- not expressive enough to give it a more precise semantics that is still --- sound.) --- For perf reasons we often (but not always) choose to use a wrapper around --- catch# that is head-strict in `act`: GHC.IO.catchException. --- --- A similar caveat applies to prompt#, which can be seen as a --- generalisation of catch# as explained in GHC.Prim#continuations#. --- The reason is that even if `act` appears dead-ending (e.g., looping) --- `prompt# tag ma s` might return alright due to a (higher-order) use of --- `control0#` in `act`. This came up in #25439. - -primop CatchOp "catch#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, o #) ) - -> (w -> State# RealWorld -> (# State# RealWorld, o #) ) - -> State# RealWorld - -> (# State# RealWorld, o #) - { @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions - thrown. - - Note that the result type here isn't quite as unrestricted as the - polymorphic type might suggest; see the section \"RuntimeRep polymorphism - in continuation-style primops\" for details. } - with - strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd - , lazyApply2Dmd - , topDmd] topDiv } - -- See Note [Strictness for catch-style primops] - out_of_line = True - has_side_effects = True - -primop RaiseOp "raise#" GenPrimOp - v -> p - -- NB: "v" is the same as "a" except levity-polymorphic, - -- and "p" is the same as "b" except representation-polymorphic - -- See Note [Levity and representation polymorphic primops] - with - -- In contrast to 'raiseIO#', which throws a *precise* exception, - -- exceptions thrown by 'raise#' are considered *imprecise*. - -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand. - -- Hence, it has 'botDiv', not 'exnDiv'. - -- For the same reasons, 'raise#' is marked as "can_fail" (which 'raiseIO#' - -- is not), but not as "has_side_effects" (which 'raiseIO#' is). - -- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps". - strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } - out_of_line = True - can_fail = True - -primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp - (# #) -> p - with - strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } - out_of_line = True - can_fail = True - code_size = { primOpCodeSizeForeignCall } - -primop RaiseOverflowOp "raiseOverflow#" GenPrimOp - (# #) -> p - with - strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } - out_of_line = True - can_fail = True - code_size = { primOpCodeSizeForeignCall } - -primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp - (# #) -> p - with - strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } - out_of_line = True - can_fail = True - code_size = { primOpCodeSizeForeignCall } - -primop RaiseIOOp "raiseIO#" GenPrimOp - v -> State# RealWorld -> (# State# RealWorld, p #) - with - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - -- for why this is the *only* primop that has 'exnDiv' - strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv } - out_of_line = True - has_side_effects = True - -primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, o #)) - -> (State# RealWorld -> (# State# RealWorld, o #)) - { @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous - exceptions are deferred until after evaluation has finished. - - Note that the result type here isn't quite as unrestricted as the - polymorphic type might suggest; see the section \"RuntimeRep polymorphism - in continuation-style primops\" for details. } - with - strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } - -- See Note [Strict IO wrappers] - out_of_line = True - has_side_effects = True - -primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, o #)) - -> (State# RealWorld -> (# State# RealWorld, o #)) - { @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous - exceptions are deferred until after evaluation has finished. - - Note that the result type here isn't quite as unrestricted as the - polymorphic type might suggest; see the section \"RuntimeRep polymorphism - in continuation-style primops\" for details. } - with - strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } - -- See Note [Strict IO wrappers] - out_of_line = True - has_side_effects = True - -primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, o #)) - -> (State# RealWorld -> (# State# RealWorld, o #)) - { @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous - exceptions are unmasked. - - Note that the result type here isn't quite as unrestricted as the - polymorphic type might suggest; see the section \"RuntimeRep polymorphism - in continuation-style primops\" for details. } - with - strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } - -- See Note [Strict IO wrappers] - out_of_line = True - has_side_effects = True - -primop MaskStatus "getMaskingState#" GenPrimOp - State# RealWorld -> (# State# RealWorld, Int# #) - with - out_of_line = True - has_side_effects = True - ------------------------------------------------------------------------- -section "Continuations" - { #continuations# - - These operations provide access to first-class delimited continuations, - which allow a computation to access and manipulate portions of its - /current continuation/. Operationally, they are implemented by direct - manipulation of the RTS call stack, which may provide significant - performance gains relative to manual continuation-passing style (CPS) for - some programs. - - Intuitively, the delimited control operators 'prompt#' and - 'control0#' can be understood by analogy to 'catch#' and 'raiseIO#', - respectively: - - * Like 'catch#', 'prompt#' does not do anything on its own, it - just /delimits/ a subcomputation (the source of the name "delimited - continuations"). - - * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing - 'prompt#' before resuming execution. - - However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard - the aborted computation: instead, it /captures/ it in a form that allows - it to be resumed later. In other words, 'control0#' does not - irreversibly abort the local computation before returning to the enclosing - 'prompt#', it merely suspends it. All local context of the suspended - computation is packaged up and returned as an ordinary function that can be - invoked at a later point in time to /continue/ execution, which is why - the suspended computation is known as a /first-class continuation/. - - In GHC, every continuation prompt is associated with exactly one - 'PromptTag#'. Prompt tags are unique, opaque values created by - 'newPromptTag#' that may only be compared for equality. Both 'prompt#' - and 'control0#' accept a 'PromptTag#' argument, and 'control0#' - captures the continuation up to the nearest enclosing use of 'prompt#' - /with the same tag/. This allows a program to control exactly which - prompt it will abort to by using different tags, similar to how a program - can control which 'catch' it will abort to by throwing different types - of exceptions. Additionally, 'PromptTag#' accepts a single type parameter, - which is used to relate the expected result type at the point of the - 'prompt#' to the type of the continuation produced by 'control0#'. - - == The gory details - - The high-level explanation provided above should hopefully provide some - intuition for what these operations do, but it is not very precise; this - section provides a more thorough explanation. - - The 'prompt#' operation morally has the following type: - -@ -'prompt#' :: 'PromptTag#' a -> IO a -> IO a -@ - - If a computation @/m/@ never calls 'control0#', then - @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is - a no-op. This implies the following law: - - \[ - \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x - \] - - The 'control0#' operation morally has the following type: - -@ -'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b -@ - - @'control0#' /tag/ /f/@ captures the current continuation up to the nearest - enclosing @'prompt#' /tag/@ and resumes execution from the point of the call - to 'prompt#', passing the captured continuation to @/f/@. To make that - somewhat more precise, we can say 'control0#' obeys the following law: - - \[ - \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k) - \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k) - \] - - However, this law does not fully describe the behavior of 'control0#', - as it does not account for situations where 'control0#' does not appear - immediately inside 'prompt#'. Capturing the semantics more precisely - requires some additional notational machinery; a common approach is to - use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics). - Assuming an appropriate definition of evaluation contexts \(E\), the - semantics of 'prompt#' and 'control0#' can be given as follows: - - \[ - \begin{aligned} - E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)] - &\longrightarrow E[\mathtt{pure}\ v] \\[8pt] - E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]] - &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt] - \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2 - \end{aligned} - \] - - A full treatment of the semantics and metatheory of delimited control is - well outside the scope of this documentation, but a good, thorough - overview (in Haskell) is provided in [A Monadic Framework for Delimited - Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by - Dybvig et al. - - == Safety and invariants - - Correct uses of 'control0#' must obey the following restrictions: - - 1. The behavior of 'control0#' is only well-defined within a /strict - 'State#' thread/, such as those associated with @IO@ and strict @ST@ - computations. - - 2. Furthermore, 'control0#' may only be called within the dynamic extent - of a 'prompt#' with a matching tag somewhere in the /current/ strict - 'State#' thread. Effectively, this means that a matching prompt must - exist somewhere, and the captured continuation must /not/ contain any - uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For - example, the following program is ill-defined: - - @ - 'prompt#' /tag/ $ - evaluate (unsafePerformIO $ 'control0#' /tag/ /f/) - @ - - In this example, the use of 'prompt#' appears in a different 'State#' - thread from the use of 'control0#', so there is no valid prompt in - scope to capture up to. - - 3. Finally, 'control0#' may not be used within 'State#' threads associated - with an STM transaction (i.e. those introduced by 'atomically#'). - - If the runtime is able to detect that any of these invariants have been - violated in a way that would compromise internal invariants of the runtime, - 'control0#' will fail by raising an exception. However, such violations - are only detected on a best-effort basis, as the bookkeeping necessary for - detecting /all/ illegal uses of 'control0#' would have significant overhead. - Therefore, although the operations are “safe” from the runtime’s point of - view (e.g. they will not compromise memory safety or clobber internal runtime - state), it is still ultimately the programmer’s responsibility to ensure - these invariants hold to guarantee predictable program behavior. - - In a similar vein, since each captured continuation includes the full local - context of the suspended computation, it can safely be resumed arbitrarily - many times without violating any invariants of the runtime system. However, - use of these operations in an arbitrary 'IO' computation may be unsafe for - other reasons, as most 'IO' code is not written with reentrancy in mind. For - example, a computation suspended in the middle of reading a file will likely - finish reading it when it is resumed; further attempts to resume from the - same place would then fail because the file handle was already closed. - - In other words, although the RTS ensures that a computation’s control state - and local variables are properly restored for each distinct resumption of - a continuation, it makes no attempt to duplicate any local state the - computation may have been using (and could not possibly do so in general). - Furthermore, it provides no mechanism for an arbitrary computation to - protect itself against unwanted reentrancy (i.e. there is no analogue to - Scheme’s @dynamic-wind@). For those reasons, manipulating the continuation - is only safe if the caller can be certain that doing so will not violate any - expectations or invariants of the enclosing computation. } ------------------------------------------------------------------------- - -primtype PromptTag# a - { See "GHC.Prim#continuations". } - -primop NewPromptTagOp "newPromptTag#" GenPrimOp - State# RealWorld -> (# State# RealWorld, PromptTag# a #) - { See "GHC.Prim#continuations". } - with - out_of_line = True - has_side_effects = True - -primop PromptOp "prompt#" GenPrimOp - PromptTag# a - -> (State# RealWorld -> (# State# RealWorld, a #)) - -> State# RealWorld -> (# State# RealWorld, a #) - { See "GHC.Prim#continuations". } - with - strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv } - -- See Note [Strictness for catch-style primops] - out_of_line = True - has_side_effects = True - -primop Control0Op "control0#" GenPrimOp - PromptTag# a - -> (((State# RealWorld -> (# State# RealWorld, p #)) - -> State# RealWorld -> (# State# RealWorld, a #)) - -> State# RealWorld -> (# State# RealWorld, a #)) - -> State# RealWorld -> (# State# RealWorld, p #) - { See "GHC.Prim#continuations". } - with - strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv } - out_of_line = True - has_side_effects = True - ------------------------------------------------------------------------- -section "STM-accessible Mutable Variables" ------------------------------------------------------------------------- - -primtype TVar# s a - -primop AtomicallyOp "atomically#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, v #) ) - -> State# RealWorld -> (# State# RealWorld, v #) - with - strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv } - -- See Note [Strict IO wrappers] - out_of_line = True - has_side_effects = True - --- NB: retry#'s strictness information specifies it to diverge. --- This lets the compiler perform some extra simplifications, since retry# --- will technically never return. --- --- This allows the simplifier to replace things like: --- case retry# s1 --- (# s2, a #) -> e --- with: --- retry# s1 --- where 'e' would be unreachable anyway. See #8091. -primop RetryOp "retry#" GenPrimOp - State# RealWorld -> (# State# RealWorld, v #) - with - strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } - out_of_line = True - has_side_effects = True - -primop CatchRetryOp "catchRetry#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, v #) ) - -> (State# RealWorld -> (# State# RealWorld, v #) ) - -> (State# RealWorld -> (# State# RealWorld, v #) ) - with - strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd - , lazyApply1Dmd - , topDmd ] topDiv } - -- See Note [Strictness for catch-style primops] - out_of_line = True - has_side_effects = True - -primop CatchSTMOp "catchSTM#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, v #) ) - -> (b -> State# RealWorld -> (# State# RealWorld, v #) ) - -> (State# RealWorld -> (# State# RealWorld, v #) ) - with - strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd - , lazyApply2Dmd - , topDmd ] topDiv } - -- See Note [Strictness for catch-style primops] - out_of_line = True - has_side_effects = True - -primop NewTVarOp "newTVar#" GenPrimOp - v - -> State# s -> (# State# s, TVar# s v #) - {Create a new 'TVar#' holding a specified initial value.} - with - out_of_line = True - has_side_effects = True - -primop ReadTVarOp "readTVar#" GenPrimOp - TVar# s v - -> State# s -> (# State# s, v #) - {Read contents of 'TVar#' inside an STM transaction, - i.e. within a call to 'atomically#'. - Does not force evaluation of the result.} - with - out_of_line = True - has_side_effects = True - -primop ReadTVarIOOp "readTVarIO#" GenPrimOp - TVar# s v - -> State# s -> (# State# s, v #) - {Read contents of 'TVar#' outside an STM transaction. - Does not force evaluation of the result.} - with - out_of_line = True - has_side_effects = True - -primop WriteTVarOp "writeTVar#" GenPrimOp - TVar# s v - -> v - -> State# s -> State# s - {Write contents of 'TVar#'.} - with - out_of_line = True - has_side_effects = True - - ------------------------------------------------------------------------- -section "Synchronized Mutable Variables" - {Operations on 'MVar#'s. } ------------------------------------------------------------------------- - -primtype MVar# s a - { A shared mutable variable (/not/ the same as a 'MutVar#'!). - (Note: in a non-concurrent implementation, @('MVar#' a)@ can be - represented by @('MutVar#' (Maybe a))@.) } - -primop NewMVarOp "newMVar#" GenPrimOp - State# s -> (# State# s, MVar# s v #) - {Create new 'MVar#'; initially empty.} - with - out_of_line = True - has_side_effects = True - -primop TakeMVarOp "takeMVar#" GenPrimOp - MVar# s v -> State# s -> (# State# s, v #) - {If 'MVar#' is empty, block until it becomes full. - Then remove and return its contents, and set it empty.} - with - out_of_line = True - has_side_effects = True - -primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp - MVar# s v -> State# s -> (# State# s, Int#, v #) - {If 'MVar#' is empty, immediately return with integer 0 and value undefined. - Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.} - with - out_of_line = True - has_side_effects = True - -primop PutMVarOp "putMVar#" GenPrimOp - MVar# s v -> v -> State# s -> State# s - {If 'MVar#' is full, block until it becomes empty. - Then store value arg as its new contents.} - with - out_of_line = True - has_side_effects = True - -primop TryPutMVarOp "tryPutMVar#" GenPrimOp - MVar# s v -> v -> State# s -> (# State# s, Int# #) - {If 'MVar#' is full, immediately return with integer 0. - Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.} - with - out_of_line = True - has_side_effects = True - -primop ReadMVarOp "readMVar#" GenPrimOp - MVar# s v -> State# s -> (# State# s, v #) - {If 'MVar#' is empty, block until it becomes full. - Then read its contents without modifying the MVar, without possibility - of intervention from other threads.} - with - out_of_line = True - has_side_effects = True - -primop TryReadMVarOp "tryReadMVar#" GenPrimOp - MVar# s v -> State# s -> (# State# s, Int#, v #) - {If 'MVar#' is empty, immediately return with integer 0 and value undefined. - Otherwise, return with integer 1 and contents of 'MVar#'.} - with - out_of_line = True - has_side_effects = True - -primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp - MVar# s v -> State# s -> (# State# s, Int# #) - {Return 1 if 'MVar#' is empty; 0 otherwise.} - with - out_of_line = True - has_side_effects = True - - ------------------------------------------------------------------------- -section "Synchronized I/O Ports" - {Operations on 'IOPort#'s. } ------------------------------------------------------------------------- - -primtype IOPort# s a - { A shared I/O port is almost the same as an 'MVar#'. - The main difference is that IOPort has no deadlock detection or - deadlock breaking code that forcibly releases the lock. } - -primop NewIOPortOp "newIOPort#" GenPrimOp - State# s -> (# State# s, IOPort# s v #) - {Create new 'IOPort#'; initially empty.} - with - out_of_line = True - has_side_effects = True - -primop ReadIOPortOp "readIOPort#" GenPrimOp - IOPort# s v -> State# s -> (# State# s, v #) - {If 'IOPort#' is empty, block until it becomes full. - Then remove and return its contents, and set it empty. - Throws an 'IOPortException' if another thread is already - waiting to read this 'IOPort#'.} - with - out_of_line = True - has_side_effects = True - -primop WriteIOPortOp "writeIOPort#" GenPrimOp - IOPort# s v -> v -> State# s -> (# State# s, Int# #) - {If 'IOPort#' is full, immediately return with integer 0, - throwing an 'IOPortException'. - Otherwise, store value arg as 'IOPort#''s new contents, - and return with integer 1. } - with - out_of_line = True - has_side_effects = True - ------------------------------------------------------------------------- -section "Delay/wait operations" ------------------------------------------------------------------------- - -primop DelayOp "delay#" GenPrimOp - Int# -> State# s -> State# s - {Sleep specified number of microseconds.} - with - has_side_effects = True - out_of_line = True - -primop WaitReadOp "waitRead#" GenPrimOp - Int# -> State# s -> State# s - {Block until input is available on specified file descriptor.} - with - has_side_effects = True - out_of_line = True - -primop WaitWriteOp "waitWrite#" GenPrimOp - Int# -> State# s -> State# s - {Block until output is possible on specified file descriptor.} - with - has_side_effects = True - out_of_line = True - ------------------------------------------------------------------------- -section "Concurrency primitives" ------------------------------------------------------------------------- - -primtype State# s - { 'State#' is the primitive, unlifted type of states. It has - one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@, - where s is a type variable. The only purpose of the type parameter - is to keep different state threads separate. It is represented by - nothing at all. } - -primtype RealWorld - { 'RealWorld' is deeply magical. It is /primitive/, but it is not - /unlifted/ (hence @ptrArg@). We never manipulate values of type - 'RealWorld'; it's only used in the type system, to parameterise 'State#'. } - -primtype ThreadId# - {(In a non-concurrent implementation, this can be a singleton - type, whose (unique) value is returned by 'myThreadId#'. The - other operations can be omitted.)} - -primop ForkOp "fork#" GenPrimOp - (State# RealWorld -> (# State# RealWorld, o #)) - -> State# RealWorld -> (# State# RealWorld, ThreadId# #) - with - has_side_effects = True - out_of_line = True - strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd - , topDmd ] topDiv } - -primop ForkOnOp "forkOn#" GenPrimOp - Int# -> (State# RealWorld -> (# State# RealWorld, o #)) - -> State# RealWorld -> (# State# RealWorld, ThreadId# #) - with - has_side_effects = True - out_of_line = True - strictness = { \ _arity -> mkClosedDmdSig [ topDmd - , lazyApply1Dmd - , topDmd ] topDiv } - -primop KillThreadOp "killThread#" GenPrimOp - ThreadId# -> a -> State# RealWorld -> State# RealWorld - with - has_side_effects = True - out_of_line = True - -primop YieldOp "yield#" GenPrimOp - State# RealWorld -> State# RealWorld - with - has_side_effects = True - out_of_line = True - -primop MyThreadIdOp "myThreadId#" GenPrimOp - State# RealWorld -> (# State# RealWorld, ThreadId# #) - with - has_side_effects = True - -primop LabelThreadOp "labelThread#" GenPrimOp - ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld - {Set the label of the given thread. The @ByteArray#@ should contain - a UTF-8-encoded string.} - with - has_side_effects = True - out_of_line = True - -primop IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp - State# RealWorld -> (# State# RealWorld, Int# #) - with - out_of_line = True - has_side_effects = True - -primop NoDuplicateOp "noDuplicate#" GenPrimOp - State# s -> State# s - with - out_of_line = True - has_side_effects = True - -primop GetThreadLabelOp "threadLabel#" GenPrimOp - ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, ByteArray# #) - {Get the label of the given thread. - Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag - denoting @Just@. - - @since 0.10} - with - out_of_line = True - -primop ThreadStatusOp "threadStatus#" GenPrimOp - ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #) - {Get the status of the given thread. Result is - @(ThreadStatus, Capability, Locked)@ where - @ThreadStatus@ is one of the status constants defined in - @rts/Constants.h@, @Capability@ is the number of - the capability which currently owns the thread, and - @Locked@ is a boolean indicating whether the - thread is bound to that capability. - - @since 0.9} - with - out_of_line = True - has_side_effects = True - -primop ListThreadsOp "listThreads#" GenPrimOp - State# RealWorld -> (# State# RealWorld, Array# ThreadId# #) - { Returns an array of the threads started by the program. Note that this - threads which have finished execution may or may not be present in this - list, depending upon whether they have been collected by the garbage collector. - - @since 0.10} - with - out_of_line = True - has_side_effects = True - ------------------------------------------------------------------------- -section "Weak pointers" ------------------------------------------------------------------------- - -primtype Weak# b - --- N.B. "v" and "w" denote levity-polymorphic type variables. --- See Note [Levity and representation polymorphic primops] - -primop MkWeakOp "mkWeak#" GenPrimOp - v -> w -> (State# RealWorld -> (# State# RealWorld, c #)) - -> State# RealWorld -> (# State# RealWorld, Weak# w #) - { @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@, - with an associated reference to some value @v@. If @k@ is still - alive then @v@ can be retrieved using 'deRefWeak#'. Note that - the type of @k@ must be represented by a pointer (i.e. of kind - @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). } - with - has_side_effects = True - out_of_line = True - -primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp - v -> w -> State# RealWorld -> (# State# RealWorld, Weak# w #) - with - has_side_effects = True - out_of_line = True - -primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp - Addr# -> Addr# -> Int# -> Addr# -> Weak# w - -> State# RealWorld -> (# State# RealWorld, Int# #) - { @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C - function pointer @fptr@ to a weak pointer @w@ as a finalizer. If - @flag@ is zero, @fptr@ will be called with one argument, - @ptr@. Otherwise, it will be called with two arguments, - @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns - 1 on success, or 0 if @w@ is already dead. } - with - has_side_effects = True - out_of_line = True - -primop DeRefWeakOp "deRefWeak#" GenPrimOp - Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, v #) - with - has_side_effects = True - out_of_line = True - -primop FinalizeWeakOp "finalizeWeak#" GenPrimOp - Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, - (State# RealWorld -> (# State# RealWorld, b #) ) #) - { Finalize a weak pointer. The return value is an unboxed tuple - containing the new state of the world and an "unboxed Maybe", - represented by an 'Int#' and a (possibly invalid) finalization - action. An 'Int#' of @1@ indicates that the finalizer is valid. The - return value @b@ from the finalizer should be ignored. } - with - has_side_effects = True - out_of_line = True - -primop TouchOp "touch#" GenPrimOp - v -> State# s -> State# s - with - code_size = { 0 } - has_side_effects = True - ------------------------------------------------------------------------- -section "Stable pointers and names" ------------------------------------------------------------------------- - -primtype StablePtr# a - -primtype StableName# a - -primop MakeStablePtrOp "makeStablePtr#" GenPrimOp - v -> State# RealWorld -> (# State# RealWorld, StablePtr# v #) - with - has_side_effects = True - out_of_line = True - -primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp - StablePtr# v -> State# RealWorld -> (# State# RealWorld, v #) - with - has_side_effects = True - out_of_line = True - -primop EqStablePtrOp "eqStablePtr#" GenPrimOp - StablePtr# v -> StablePtr# v -> Int# - with - has_side_effects = True - -primop MakeStableNameOp "makeStableName#" GenPrimOp - v -> State# RealWorld -> (# State# RealWorld, StableName# v #) - with - has_side_effects = True - out_of_line = True - -primop StableNameToIntOp "stableNameToInt#" GenPrimOp - StableName# v -> Int# - ------------------------------------------------------------------------- -section "Compact normal form" - - {Primitives for working with compact regions. The @ghc-compact@ - library and the @compact@ library demonstrate how to use these - primitives. The documentation below draws a distinction between - a CNF and a compact block. A CNF contains one or more compact - blocks. The source file @rts\/sm\/CNF.c@ - diagrams this relationship. When discussing a compact - block, an additional distinction is drawn between capacity and - utilized bytes. The capacity is the maximum number of bytes that - the compact block can hold. The utilized bytes is the number of - bytes that are actually used by the compact block. - } - ------------------------------------------------------------------------- - -primtype Compact# - -primop CompactNewOp "compactNew#" GenPrimOp - Word# -> State# RealWorld -> (# State# RealWorld, Compact# #) - { Create a new CNF with a single compact block. The argument is - the capacity of the compact block (in bytes, not words). - The capacity is rounded up to a multiple of the allocator block size - and is capped to one mega block. } - with - has_side_effects = True - out_of_line = True - -primop CompactResizeOp "compactResize#" GenPrimOp - Compact# -> Word# -> State# RealWorld -> - State# RealWorld - { Set the new allocation size of the CNF. This value (in bytes) - determines the capacity of each compact block in the CNF. It - does not retroactively affect existing compact blocks in the CNF. } - with - has_side_effects = True - out_of_line = True - -primop CompactContainsOp "compactContains#" GenPrimOp - Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #) - { Returns 1\# if the object is contained in the CNF, 0\# otherwise. } - with - out_of_line = True - -primop CompactContainsAnyOp "compactContainsAny#" GenPrimOp - a -> State# RealWorld -> (# State# RealWorld, Int# #) - { Returns 1\# if the object is in any CNF at all, 0\# otherwise. } - with - out_of_line = True - -primop CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp - Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) - { Returns the address and the utilized size (in bytes) of the - first compact block of a CNF.} - with - out_of_line = True - -primop CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp - Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) - { Given a CNF and the address of one its compact blocks, returns the - next compact block and its utilized size, or 'nullAddr#' if the - argument was the last compact block in the CNF. } - with - out_of_line = True - -primop CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp - Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #) - { Attempt to allocate a compact block with the capacity (in - bytes) given by the first argument. The 'Addr#' is a pointer - to previous compact block of the CNF or 'nullAddr#' to create a - new CNF with a single compact block. - - The resulting block is not known to the GC until - 'compactFixupPointers#' is called on it, and care must be taken - so that the address does not escape or memory will be leaked. - } - with - has_side_effects = True - out_of_line = True - -primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp - Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #) - { Given the pointer to the first block of a CNF and the - address of the root object in the old address space, fix up - the internal pointers inside the CNF to account for - a different position in memory than when it was serialized. - This method must be called exactly once after importing - a serialized CNF. It returns the new CNF and the new adjusted - root address. } - with - has_side_effects = True - out_of_line = True - -primop CompactAdd "compactAdd#" GenPrimOp - Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) - { Recursively add a closure and its transitive closure to a - 'Compact#' (a CNF), evaluating any unevaluated components - at the same time. Note: 'compactAdd#' is not thread-safe, so - only one thread may call 'compactAdd#' with a particular - 'Compact#' at any given time. The primop does not - enforce any mutual exclusion; the caller is expected to - arrange this. } - with - has_side_effects = True - out_of_line = True - -primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp - Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) - { Like 'compactAdd#', but retains sharing and cycles - during compaction. } - with - has_side_effects = True - out_of_line = True - -primop CompactSize "compactSize#" GenPrimOp - Compact# -> State# RealWorld -> (# State# RealWorld, Word# #) - { Return the total capacity (in bytes) of all the compact blocks - in the CNF. } - with - has_side_effects = True - out_of_line = True - ------------------------------------------------------------------------- -section "Unsafe pointer equality" --- (#1 Bad Guy: Alastair Reid :) ------------------------------------------------------------------------- - --- `v` and `w` are levity-polymorphic type variables with independent levities. --- See Note [Levity and representation polymorphic primops] -primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp - v -> w -> Int# - { Returns @1#@ if the given pointers are equal and @0#@ otherwise. } - with - can_fail = True -- See Note [reallyUnsafePtrEquality# can_fail] - --- Note [Pointer comparison operations] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The primop `reallyUnsafePtrEquality#` does a direct pointer --- equality between two (boxed) values. Several things to note: --- --- (PE1) It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and --- TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example. --- This levity-polymorphism comes from the use of the type variables --- "v" and "w". See Note [Levity and representation polymorphic primops] --- --- (PE2) It is hetero-typed; you can compare pointers of different types. --- This is used in various packages such as containers & unordered-containers. --- --- (PE3) It does not evaluate its arguments. The user of the primop is responsible --- for doing so. Consider --- let { x = p+q; y = q+p } in reallyUnsafePtrEquality# x y --- Here `x` and `y` point to different closures, so the expression will --- probably return False; but if `x` and/or `y` were evaluated for some --- other reason, then it might return True. --- --- (PE4) It is obviously very dangerous, because replacing equals with equals --- in the program can change the result. For example --- let x = f y in reallyUnsafePtrEquality# x x --- will probably return True, whereas --- reallyUnsafePtrEquality# (f y) (f y) --- will probably return False. ("probably", because it's affected --- by CSE and inlining). --- --- (PE5) reallyUnsafePtrEquality# can't fail, but it is marked as such --- to prevent it from floating out. --- See Note [reallyUnsafePtrEquality# can_fail] --- --- The library GHC.Prim.PtrEq (and GHC.Exts) provides --- --- unsafePtrEquality# :: --- forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int# --- --- It is still heterotyped (like (PE2)), but it's restricted to unlifted types --- (unlike (PE1)). That means that (PE3) doesn't apply: unlifted types are --- always evaluated, which makes it a bit less unsafe. --- --- However unsafePtrEquality# is /implemented/ by a call to --- reallyUnsafePtrEquality#, so using the former is really just a documentation --- hint to the reader of the code. GHC behaves no differently. --- --- The same library provides less Wild-West functions --- for use in specific cases, namely: --- --- reallyUnsafePtrEquality :: a -> a -> Int# -- not levity-polymorphic, nor hetero-typed --- sameArray# :: Array# a -> Array# a -> Int# --- sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int# --- sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# --- sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int# --- sameByteArray# :: ByteArray# -> ByteArray# -> Int# --- sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int# --- sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# --- sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# --- sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# --- sameTVar# :: TVar# s a -> TVar# s a -> Int# --- sameMVar# :: MVar# s a -> MVar# s a -> Int# --- sameIOPort# :: IOPort# s a -> IOPort# s a -> Int# --- eqStableName# :: StableName# a -> StableName# b -> Int# --- --- These operations are all specialisations of unsafePtrEquality#. - --- Note [reallyUnsafePtrEquality# can_fail] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it --- can_fail anyway. Until 5a9a1738023a, GHC considered primops okay for --- speculation only when their arguments were known to be forced. This was --- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from --- floating out of places where its arguments were known to be forced. --- Unfortunately, GHC could sometimes lose track of whether those arguments --- were forced, leading to let-can-float invariant failures (see #13027 and the --- discussion in #11444). Now that ok_for_speculation skips over lifted --- arguments, we need to explicitly prevent reallyUnsafePtrEquality# --- from floating out. Imagine if we had --- --- \x y . case x of x' --- DEFAULT -> --- case y of y' --- DEFAULT -> --- let eq = reallyUnsafePtrEquality# x' y' --- in ... --- --- If the let floats out, we'll get --- --- \x y . let eq = reallyUnsafePtrEquality# x y --- in case x of ... --- --- The trouble is that pointer equality between thunks is very different --- from pointer equality between the values those thunks reduce to, and the latter --- is typically much more precise. - ------------------------------------------------------------------------- -section "Parallelism" ------------------------------------------------------------------------- - -primop ParOp "par#" GenPrimOp - a -> Int# - with - -- Note that Par is lazy to avoid that the sparked thing - -- gets evaluated strictly, which it should *not* be - has_side_effects = True - code_size = { primOpCodeSizeForeignCall } - deprecated_msg = { Use 'spark#' instead } - -primop SparkOp "spark#" GenPrimOp - a -> State# s -> (# State# s, a #) - with has_side_effects = True - code_size = { primOpCodeSizeForeignCall } - -primop SeqOp "seq#" GenPrimOp - a -> State# s -> (# State# s, a #) - -- See Note [seq# magic] in GHC.Core.Op.ConstantFold - -primop GetSparkOp "getSpark#" GenPrimOp - State# s -> (# State# s, Int#, a #) - with - has_side_effects = True - out_of_line = True - -primop NumSparks "numSparks#" GenPrimOp - State# s -> (# State# s, Int# #) - { Returns the number of sparks in the local spark pool. } - with - has_side_effects = True - out_of_line = True - - - ------------------------------------------------------------------------- -section "Controlling object lifetime" - {Ensuring that objects don't die a premature death.} ------------------------------------------------------------------------- - --- See Note [keepAlive# magic] in GHC.CoreToStg.Prep. --- NB: "v" is the same as "a" except levity-polymorphic, --- and "p" is the same as "b" except representation-polymorphic. --- See Note [Levity and representation polymorphic primops] -primop KeepAliveOp "keepAlive#" GenPrimOp - v -> State# s -> (State# s -> p) -> p - { @'keepAlive#' x s k@ keeps the value @x@ alive during the execution - of the computation @k@. - - Note that the result type here isn't quite as unrestricted as the - polymorphic type might suggest; see the section \"RuntimeRep polymorphism - in continuation-style primops\" for details. } - with - out_of_line = True - strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } - -- See Note [Strict IO wrappers] - - ------------------------------------------------------------------------- -section "Tag to enum stuff" - {Convert back and forth between values of enumerated types - and small integers.} ------------------------------------------------------------------------- - -primop DataToTagOp "dataToTag#" GenPrimOp - a -> Int# -- Zero-indexed; the first constructor has tag zero - { Evaluates the argument and returns the tag of the result. - Tags are Zero-indexed; the first constructor has tag zero. } - with - strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } - -- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold - -primop TagToEnumOp "tagToEnum#" GenPrimOp - Int# -> a - ------------------------------------------------------------------------- -section "Bytecode operations" - {Support for manipulating bytecode objects used by the interpreter and - linker. - - Bytecode objects are heap objects which represent top-level bindings and - contain a list of instructions and data needed by these instructions.} ------------------------------------------------------------------------- - -primtype BCO - { Primitive bytecode type. } - -primop AddrToAnyOp "addrToAny#" GenPrimOp - Addr# -> (# v #) - { Convert an 'Addr#' to a followable Any type. } - with - code_size = 0 - -primop AnyToAddrOp "anyToAddr#" GenPrimOp - a -> State# RealWorld -> (# State# RealWorld, Addr# #) - { Retrieve the address of any Haskell value. This is - essentially an 'unsafeCoerce#', but if implemented as such - the core lint pass complains and fails to compile. - As a primop, it is opaque to core/stg, and only appears - in cmm (where the copy propagation pass will get rid of it). - Note that "a" must be a value, not a thunk! It's too late - for strictness analysis to enforce this, so you're on your - own to guarantee this. Also note that 'Addr#' is not a GC - pointer - up to you to guarantee that it does not become - a dangling pointer immediately after you get it.} - with - code_size = 0 - -primop MkApUpd0_Op "mkApUpd0#" GenPrimOp - BCO -> (# a #) - { Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of - the BCO when evaluated. } - with - out_of_line = True - -primop NewBCOOp "newBCO#" GenPrimOp - ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) - { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The - resulting object encodes a function of the given arity with the instructions - encoded in @instrs@, and a static reference table usage bitmap given by - @bitmap@. } - with - has_side_effects = True - out_of_line = True - -primop UnpackClosureOp "unpackClosure#" GenPrimOp - a -> (# Addr#, ByteArray#, Array# b #) - { @'unpackClosure#' closure@ copies the closure and pointers in the - payload of the given closure into two new arrays, and returns a pointer to - the first word of the closure's info table, a non-pointer array for the raw - bytes of the closure, and a pointer array for the pointers in the payload. } - with - out_of_line = True - -primop ClosureSizeOp "closureSize#" GenPrimOp - a -> Int# - { @'closureSize#' closure@ returns the size of the given closure in - machine words. } - with - out_of_line = True - -primop GetApStackValOp "getApStackVal#" GenPrimOp - a -> Int# -> (# Int#, b #) - with - out_of_line = True - ------------------------------------------------------------------------- -section "Misc" - {These aren't nearly as wired in as Etc...} ------------------------------------------------------------------------- - -primop GetCCSOfOp "getCCSOf#" GenPrimOp - a -> State# s -> (# State# s, Addr# #) - -primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp - a -> State# s -> (# State# s, Addr# #) - { Returns the current 'CostCentreStack' (value is @NULL@ if - not profiling). Takes a dummy argument which can be used to - avoid the call to 'getCurrentCCS#' being floated out by the - simplifier, which would result in an uninformative stack - ("CAF"). } - -primop ClearCCSOp "clearCCS#" GenPrimOp - (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #) - { Run the supplied IO action with an empty CCS. For example, this - is used by the interpreter to run an interpreted computation - without the call stack showing that it was invoked from GHC. } - with - out_of_line = True - ------------------------------------------------------------------------- -section "Info Table Origin" ------------------------------------------------------------------------- -primop WhereFromOp "whereFrom#" GenPrimOp - a -> State# s -> (# State# s, Addr# #) - { Returns the @InfoProvEnt @ for the info table of the given object - (value is @NULL@ if the table does not exist or there is no information - about the closure).} - with - out_of_line = True - ------------------------------------------------------------------------- -section "Etc" - {Miscellaneous built-ins} ------------------------------------------------------------------------- - -primtype FUN m a b - {The builtin function type, written in infix form as @a % m -> b@. - Values of this type are functions taking inputs of type @a@ and - producing outputs of type @b@. The multiplicity of the input is - @m@. - - Note that @'FUN' m a b@ permits representation polymorphism in both - @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be - well-kinded. - } - -pseudoop "realWorld#" - State# RealWorld - { The token used in the implementation of the IO monad as a state monad. - It does not pass any information at runtime. - See also 'GHC.Magic.runRW#'. } - -pseudoop "void#" - (# #) - { This is an alias for the unboxed unit tuple constructor. - In earlier versions of GHC, 'void#' was a value - of the primitive type 'Void#', which is now defined to be @(# #)@. - } - with deprecated_msg = { Use an unboxed unit tuple instead } - -primtype Proxy# a - { The type constructor 'Proxy#' is used to bear witness to some - type variable. It's used when you want to pass around proxy values - for doing things like modelling type applications. A 'Proxy#' - is not only unboxed, it also has a polymorphic kind, and has no - runtime representation, being totally free. } - -pseudoop "proxy#" - Proxy# a - { Witness for an unboxed 'Proxy#' value, which has no runtime - representation. } - -pseudoop "seq" - a -> p -> p - { The value of @'seq' a b@ is bottom if @a@ is bottom, and - otherwise equal to @b@. In other words, it evaluates the first - argument @a@ to weak head normal form (WHNF). 'seq' is usually - introduced to improve performance by avoiding unneeded laziness. - - A note on evaluation order: the expression @'seq' a b@ does - /not/ guarantee that @a@ will be evaluated before @b@. - The only guarantee given by 'seq' is that the both @a@ - and @b@ will be evaluated before 'seq' returns a value. - In particular, this means that @b@ may be evaluated before - @a@. If you need to guarantee a specific order of evaluation, - you must use the function 'pseq' from the "parallel" package. } - with fixity = infixr 0 - -- This fixity is only the one picked up by Haddock. If you - -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'. - -primop TraceEventOp "traceEvent#" GenPrimOp - Addr# -> State# s -> State# s - { Emits an event via the RTS tracing framework. The contents - of the event is the zero-terminated byte string passed as the first - argument. The event will be emitted either to the @.eventlog@ file, - or to stderr, depending on the runtime RTS flags. } - with - has_side_effects = True - out_of_line = True - -primop TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp - Addr# -> Int# -> State# s -> State# s - { Emits an event via the RTS tracing framework. The contents - of the event is the binary object passed as the first argument with - the given length passed as the second argument. The event will be - emitted to the @.eventlog@ file. } - with - has_side_effects = True - out_of_line = True - -primop TraceMarkerOp "traceMarker#" GenPrimOp - Addr# -> State# s -> State# s - { Emits a marker event via the RTS tracing framework. The contents - of the event is the zero-terminated byte string passed as the first - argument. The event will be emitted either to the @.eventlog@ file, - or to stderr, depending on the runtime RTS flags. } - with - has_side_effects = True - out_of_line = True - -primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp - Int64# -> State# RealWorld -> State# RealWorld - { Sets the allocation counter for the current thread to the given value. } - with - has_side_effects = True - out_of_line = True - -primtype StackSnapshot# - { Haskell representation of a @StgStack*@ that was created (cloned) - with a function in "GHC.Stack.CloneStack". Please check the - documentation in that module for more detailed explanations. } - ------------------------------------------------------------------------- -section "Safe coercions" ------------------------------------------------------------------------- - -pseudoop "coerce" - Coercible a b => a -> b - { The function 'coerce' allows you to safely convert between values of - types that have the same representation with no run-time overhead. In the - simplest case you can use it instead of a newtype constructor, to go from - the newtype's concrete type to the abstract type. But it also works in - more complicated settings, e.g. converting a list of newtypes to a list of - concrete types. - - When used in conversions involving a newtype wrapper, - make sure the newtype constructor is in scope. - - This function is representation-polymorphic, but the - 'RuntimeRep' type argument is marked as 'Inferred', meaning - that it is not available for visible type application. This means - the typechecker will accept @'coerce' \@'Int' \@Age 42@. - - === __Examples__ - - >>> newtype TTL = TTL Int deriving (Eq, Ord, Show) - >>> newtype Age = Age Int deriving (Eq, Ord, Show) - >>> coerce (Age 42) :: TTL - TTL 42 - >>> coerce (+ (1 :: Int)) (Age 42) :: TTL - TTL 43 - >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL] - [TTL 43,TTL 25] - - } - ------------------------------------------------------------------------- -section "SIMD Vectors" - {Operations on SIMD vectors.} ------------------------------------------------------------------------- - -#define ALL_VECTOR_TYPES \ - [,,, \ - ,,,, \ - ,,,, \ - ,,,, \ - ,,,, \ - ,,,, \ - ,, \ - ,, \ - ,,] - -#define SIGNED_VECTOR_TYPES \ - [,,, \ - ,,,, \ - ,,,, \ - ,, \ - ,, \ - ,,] - -#define FLOAT_VECTOR_TYPES \ - [, \ - ,, \ - ,,] - -#define INT_VECTOR_TYPES \ - [,,, \ - ,,,, \ - ,,,, \ - ,,,, \ - ,,,, \ - ,,,,] - -primtype VECTOR - with llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecBroadcastOp "broadcast#" GenPrimOp - SCALAR -> VECTOR - { Broadcast a scalar to all elements of a vector. } - with llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecPackOp "pack#" GenPrimOp - VECTUPLE -> VECTOR - { Pack the elements of an unboxed tuple into a vector. } - with llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecUnpackOp "unpack#" GenPrimOp - VECTOR -> VECTUPLE - { Unpack the elements of a vector into an unboxed tuple. #} - with llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecInsertOp "insert#" GenPrimOp - VECTOR -> SCALAR -> Int# -> VECTOR - { Insert a scalar at the given position in a vector. } - with can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecAddOp "plus#" GenPrimOp - VECTOR -> VECTOR -> VECTOR - { Add two vectors element-wise. } - with commutable = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecSubOp "minus#" GenPrimOp - VECTOR -> VECTOR -> VECTOR - { Subtract two vectors element-wise. } - with llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecMulOp "times#" GenPrimOp - VECTOR -> VECTOR -> VECTOR - { Multiply two vectors element-wise. } - with commutable = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecDivOp "divide#" GenPrimOp - VECTOR -> VECTOR -> VECTOR - { Divide two vectors element-wise. } - with can_fail = True - llvm_only = True - vector = FLOAT_VECTOR_TYPES - -primop VecQuotOp "quot#" GenPrimOp - VECTOR -> VECTOR -> VECTOR - { Rounds towards zero element-wise. } - with can_fail = True - llvm_only = True - vector = INT_VECTOR_TYPES - -primop VecRemOp "rem#" GenPrimOp - VECTOR -> VECTOR -> VECTOR - { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. } - with can_fail = True - llvm_only = True - vector = INT_VECTOR_TYPES - -primop VecNegOp "negate#" GenPrimOp - VECTOR -> VECTOR - { Negate element-wise. } - with llvm_only = True - vector = SIGNED_VECTOR_TYPES - -primop VecIndexByteArrayOp "indexArray#" GenPrimOp - ByteArray# -> Int# -> VECTOR - { Read a vector from specified index of immutable array. } - with can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecReadByteArrayOp "readArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) - { Read a vector from specified index of mutable array. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecWriteByteArrayOp "writeArray#" GenPrimOp - MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s - { Write a vector to specified index of mutable array. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp - Addr# -> Int# -> VECTOR - { Reads vector; offset in bytes. } - with can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecReadOffAddrOp "readOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, VECTOR #) - { Reads vector; offset in bytes. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp - Addr# -> Int# -> VECTOR -> State# s -> State# s - { Write vector; offset in bytes. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - - -primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp - ByteArray# -> Int# -> VECTOR - { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. } - with can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) - { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp - MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s - { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp - Addr# -> Int# -> VECTOR - { Reads vector; offset in scalar elements. } - with can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, VECTOR #) - { Reads vector; offset in scalar elements. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - -primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp - Addr# -> Int# -> VECTOR -> State# s -> State# s - { Write vector; offset in scalar elements. } - with has_side_effects = True - can_fail = True - llvm_only = True - vector = ALL_VECTOR_TYPES - ------------------------------------------------------------------------- - -section "Prefetch" - {Prefetch operations: Note how every prefetch operation has a name - with the pattern prefetch*N#, where N is either 0,1,2, or 3. - - This suffix number, N, is the "locality level" of the prefetch, following the - convention in GCC and other compilers. - Higher locality numbers correspond to the memory being loaded in more - levels of the cpu cache, and being retained after initial use. The naming - convention follows the naming convention of the prefetch intrinsic found - in the GCC and Clang C compilers. - - On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic - with locality level N. The code generated by LLVM is target architecture - dependent, but should agree with the GHC NCG on x86 systems. - - On the PPC native backend, prefetch*N is a No-Op. - - On the x86 NCG, N=0 will generate prefetchNTA, - N=1 generates prefetcht2, N=2 generates prefetcht1, and - N=3 generates prefetcht0. - - For streaming workloads, the prefetch*0 operations are recommended. - For workloads which do many reads or writes to a memory location in a short period of time, - prefetch*3 operations are recommended. - - For further reading about prefetch and associated systems performance optimization, - the instruction set and optimization manuals by Intel and other CPU vendors are - excellent starting place. - - - The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is - especially a helpful read, even if your software is meant for other CPU - architectures or vendor hardware. The manual can be found at - http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html . - - The @prefetch*@ family of operations has the order of operations - determined by passing around the 'State#' token. - - To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context. - - It is important to note that while the prefetch operations will never change the - answer to a pure computation, They CAN change the memory locations resident - in a CPU cache and that may change the performance and timing characteristics - of an application. The prefetch operations are marked has_side_effects=True - to reflect that these operations have side effects with respect to the runtime - performance characteristics of the resulting code. Additionally, if the prefetchValue - operations did not have this attribute, GHC does a float out transformation that - results in a let-can-float invariant violation, at least with the current design. - } - - - ------------------------------------------------------------------------- - - ---- the Int# argument for prefetch is the byte offset on the byteArray or Addr# - ---- -primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp - ByteArray# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp - Addr# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp - a -> State# s -> State# s - with has_side_effects = True ----- - -primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp - ByteArray# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp - Addr# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp - a -> State# s -> State# s - with has_side_effects = True ----- - -primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp - ByteArray# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp - Addr# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp - a -> State# s -> State# s - with has_side_effects = True ----- - -primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp - ByteArray# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp - Addr# -> Int# -> State# s -> State# s - with has_side_effects = True - -primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp - a -> State# s -> State# s - with has_side_effects = True +-- See Note [GHC.Prim Docs] in GHC.Builtin.Utils. +-- +-- 3. The module PrimopWrappers.hs, which wraps every call for GHCi; +-- see Note [Primop wrappers] in GHC.Builtin.Primops for details. +-- +-- * This file does not list internal-only equality types +-- (GHC.Builtin.Types.Prim.unexposedPrimTyCons and coercionToken# +-- in GHC.Types.Id.Make) which are defined but not exported from GHC.Prim. +-- Every export of GHC.Prim should be in listed in this file. +-- +-- * The primitive types should be listed in primTyCons in Builtin.Types.Prim +-- in addition to primops.txt.pp. +-- (This task should be delegated to genprimopcode in the future.) +-- +-- +-- +-- Information on how PrimOps are implemented and the steps necessary to +-- add a new one can be found in the Commentary: +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops +-- +-- This file is divided into named sections, each containing or more +-- primop entries. Section headers have the format: +-- +-- section "section-name" {haddock-description} +-- +-- This information is used solely when producing documentation; it is +-- otherwise ignored. The haddock-description is optional. +-- +-- The format of each primop entry is as follows: +-- +-- primop internal-name "name-in-program-text" category type {haddock-description} attributes + +-- The default attribute values which apply if you don't specify +-- other ones. Attribute values can be True, False, or arbitrary +-- text between curly brackets. This is a kludge to enable +-- processors of this file to easily get hold of simple info +-- (eg, out_of_line), whilst avoiding parsing complex expressions +-- needed for strictness info. +-- +-- type refers to the general category of the primop. There are only two: +-- +-- * Compare: A comparison operation of the shape a -> a -> Int# +-- * GenPrimOp: Any other sort of primop +-- + +-- The vector attribute is rather special. It takes a list of 3-tuples, each of +-- which is of the form . ELEM_TYPE is the type of +-- the elements in the vector; LENGTH is the length of the vector; and +-- SCALAR_TYPE is the scalar type used to inject to/project from vector +-- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example, +-- to broadcast a scalar value to a vector whose elements are of type Int8, we +-- use an Int#. + +-- When a primtype or primop has a vector attribute, it is instantiated at each +-- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to +-- define a family of types or primops. Vector support also adds three new +-- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types +-- derived from the 3-tuple. For the 3-tuple , VECTOR expands to +-- Int64X2#, SCALAR expands to Int64#, and VECTUPLE expands to (# Int64#, Int64# #). + +defaults + effect = NoEffect -- See Note [Classifying primop effects] in GHC.Builtin.PrimOps + can_fail_warning = WarnIfEffectIsCanFail + out_of_line = False -- See Note [When do out-of-line primops go in primops.txt.pp] + commutable = False + code_size = { primOpCodeSizeDefault } + work_free = { primOpCodeSize _thisOp == 0 } + cheap = { primOpOkForSpeculation _thisOp } + strictness = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv } + fixity = Nothing + vector = [] + deprecated_msg = {} -- A non-empty message indicates deprecation + div_like = False -- Second argument expected to be non zero - used for tests + defined_bits = Nothing -- The number of bits the operation is defined for (if not all bits) + +-- Note [When do out-of-line primops go in primops.txt.pp] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Out of line primops are those with a C-- implementation. But that +-- doesn't mean they *just* have an C-- implementation. As mentioned in +-- Note [Inlining out-of-line primops and heap checks], some out-of-line +-- primops also have additional internal implementations under certain +-- conditions. Now that `foreign import prim` exists, only those primops +-- which have both internal and external implementations ought to be +-- this file. The rest aren't really primops, since they don't need +-- bespoke compiler support but just a general way to interface with +-- C--. They are just foreign calls. +-- +-- Unfortunately, for the time being most of the primops which should be +-- moved according to the previous paragraph can't yet. There are some +-- superficial restrictions in `foreign import prim` which must be fixed +-- first. Specifically, `foreign import prim` always requires: +-- +-- - No polymorphism in type +-- - `strictness = ` +-- - `effect = ReadWriteEffect` +-- +-- https://gitlab.haskell.org/ghc/ghc/issues/16929 tracks this issue, +-- and has a table of which external-only primops are blocked by which +-- of these. Hopefully those restrictions are relaxed so the rest of +-- those can be moved over. +-- +-- 'module GHC.Prim.Ext is a temporarily "holding ground" for primops +-- that were formally in here, until they can be given a better home. +-- Likewise, their underlying C-- implementation need not live in the +-- RTS either. Best case (in my view), both the C-- and `foreign import +-- prim` can be moved to a small library tailured to the features being +-- implemented and dependencies of those features. + +-- Note [Levity and representation polymorphic primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In the types of primops in this module, +-- +-- * The names `a,b,c,s` stand for type variables of kind Type +-- +-- * The names `a_reppoly` and `b_reppoly` stand for representation-polymorphic +-- type variables. For example: +-- op :: a_reppoly -> b_reppoly -> Int +-- really means +-- op :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep} +-- (a :: TYPE rep1) (b :: TYPE rep2). +-- a -> b -> Int +-- +-- Note: +-- - `a_reppoly` and `b_reppoly` have independent `RuntimeRep`s, which +-- are *inferred* type variables. +-- - any use-site of a primop in which the kind of a type appearing in +-- negative position is `a_reppoly` and `b_reppoly` +-- must instantiate the representation to a concrete RuntimeRep. +-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head. +-- - `a_reppoly` and `b_reppoly` share textual names with `a` and `b` (respectively). +-- This means one shouldn't write a type involving both `a` and `a_reppoly`. +-- +-- * The names `a_levpoly` and `b_levpoly` stand for levity-polymorphic +-- type variables, similar to `a_reppoly` and `b_reppoly`. +-- For example: +-- op :: a_levpoly -> b_levpoly -> Int +-- really means +-- op :: forall {l :: Levity} {k :: Levity} +-- (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)). +-- a -> b -> Int +-- Note: +-- - `a_levpoly` and `b_levpoly` have independent levities `l` and `k` (respectively), and +-- these are inferred (not specified), as seen from the curly brackets. +-- - any use site of a primop in which `a_levpoly` or `b_levpoly` appear as +-- the kind of a type appearing in negative position in the type of the +-- primop, we require the Levity to be instantiated to a concrete Levity. +-- - `a_levpoly` and `b_levpoly` share textual names with `a` and `b` (respectively). +-- This means one shouldn't write a type involving both `a` and `a_levpoly`, +-- nor `a_levpoly` and `a_reppoly`, etc. + +section "The word size story." + {Haskell98 specifies that signed integers (type 'Int') + must contain at least 30 bits. GHC always implements + 'Int' using the primitive type 'Int#', whose size equals + the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@. + This is normally set based on the RTS @ghcautoconf.h@ parameter + @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64 + bits on 64-bit machines. + + GHC also implements a primitive unsigned integer type + 'Word#' which always has the same number of bits as 'Int#'. + + In addition, GHC supports families of explicit-sized integers + and words at 8, 16, 32, and 64 bits, with the usual + arithmetic operations, comparisons, and a range of + conversions. + + Finally, there are strongly deprecated primops for coercing + between 'Addr#', the primitive type of machine + addresses, and 'Int#'. These are pretty bogus anyway, + but will work on existing 32-bit and 64-bit GHC targets; they + are completely bogus when tag bits are used in 'Int#', + so are not available in this case.} + +------------------------------------------------------------------------ +section "Char#" + {Operations on 31-bit characters.} +------------------------------------------------------------------------ + +primtype Char# + +primop CharGtOp "gtChar#" Compare Char# -> Char# -> Int# +primop CharGeOp "geChar#" Compare Char# -> Char# -> Int# + +primop CharEqOp "eqChar#" Compare + Char# -> Char# -> Int# + with commutable = True + +primop CharNeOp "neChar#" Compare + Char# -> Char# -> Int# + with commutable = True + +primop CharLtOp "ltChar#" Compare Char# -> Char# -> Int# +primop CharLeOp "leChar#" Compare Char# -> Char# -> Int# + +primop OrdOp "ord#" GenPrimOp Char# -> Int# + with code_size = 0 + +------------------------------------------------------------------------ +section "Int8#" + {Operations on 8-bit integers.} +------------------------------------------------------------------------ + +primtype Int8# + +primop Int8ToIntOp "int8ToInt#" GenPrimOp Int8# -> Int# +primop IntToInt8Op "intToInt8#" GenPrimOp Int# -> Int8# + +primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8# + +primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + commutable = True + +primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8# + +primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + commutable = True + +primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + effect = CanFail + div_like = True + +primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8# + with + effect = CanFail + div_like = True + + +primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #) + with + effect = CanFail + div_like = True + +primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8# +primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8# +primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8# + +primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8# + with code_size = 0 + +primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int# +primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int# +primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int# +primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int# +primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int# +primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int# + +------------------------------------------------------------------------ +section "Word8#" + {Operations on 8-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word8# + +primop Word8ToWordOp "word8ToWord#" GenPrimOp Word8# -> Word# +primop WordToWord8Op "wordToWord8#" GenPrimOp Word# -> Word8# + +primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + commutable = True + +primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8# + +primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + commutable = True + +primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + effect = CanFail + div_like = True + +primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with + effect = CanFail + div_like = True + +primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #) + with + effect = CanFail + div_like = True + +primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with commutable = True + +primop Word8OrOp "orWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with commutable = True + +primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8# + with commutable = True + +primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8# + +primop Word8SllOp "uncheckedShiftLWord8#" GenPrimOp Word8# -> Int# -> Word8# +primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8# + +primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8# + with code_size = 0 + +primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int# +primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int# +primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int# +primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int# +primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int# +primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int# + +------------------------------------------------------------------------ +section "Int16#" + {Operations on 16-bit integers.} +------------------------------------------------------------------------ + +primtype Int16# + +primop Int16ToIntOp "int16ToInt#" GenPrimOp Int16# -> Int# +primop IntToInt16Op "intToInt16#" GenPrimOp Int# -> Int16# + +primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16# + +primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + commutable = True + +primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16# + +primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + commutable = True + +primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + effect = CanFail + div_like = True + +primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16# + with + effect = CanFail + div_like = True + +primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #) + with + effect = CanFail + div_like = True + +primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16# +primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16# +primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16# + +primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16# + with code_size = 0 + +primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int# +primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int# +primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int# +primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int# +primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int# + +------------------------------------------------------------------------ +section "Word16#" + {Operations on 16-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word16# + +primop Word16ToWordOp "word16ToWord#" GenPrimOp Word16# -> Word# +primop WordToWord16Op "wordToWord16#" GenPrimOp Word# -> Word16# + +primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + commutable = True + +primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16# + +primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + commutable = True + +primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + effect = CanFail + div_like = True + +primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with + effect = CanFail + div_like = True + +primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #) + with + effect = CanFail + div_like = True + +primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with commutable = True + +primop Word16OrOp "orWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with commutable = True + +primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16# + with commutable = True + +primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16# + +primop Word16SllOp "uncheckedShiftLWord16#" GenPrimOp Word16# -> Int# -> Word16# +primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16# + +primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16# + with code_size = 0 + +primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int# +primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int# +primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int# +primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int# +primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int# + +------------------------------------------------------------------------ +section "Int32#" + {Operations on 32-bit integers.} +------------------------------------------------------------------------ + +primtype Int32# + +primop Int32ToIntOp "int32ToInt#" GenPrimOp Int32# -> Int# +primop IntToInt32Op "intToInt32#" GenPrimOp Int# -> Int32# + +primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32# + +primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + commutable = True + +primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32# + +primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + commutable = True + +primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + effect = CanFail + div_like = True + +primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32# + with + effect = CanFail + div_like = True + +primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #) + with + effect = CanFail + div_like = True + +primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32# +primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32# +primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32# + +primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32# + with code_size = 0 + +primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int# +primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int# +primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int# +primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int# +primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int# + +------------------------------------------------------------------------ +section "Word32#" + {Operations on 32-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word32# + +primop Word32ToWordOp "word32ToWord#" GenPrimOp Word32# -> Word# +primop WordToWord32Op "wordToWord32#" GenPrimOp Word# -> Word32# + +primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + commutable = True + +primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32# + +primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + commutable = True + +primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + effect = CanFail + div_like = True + +primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with + effect = CanFail + div_like = True + +primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #) + with + effect = CanFail + div_like = True + +primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32# + with commutable = True + +primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32# + +primop Word32SllOp "uncheckedShiftLWord32#" GenPrimOp Word32# -> Int# -> Word32# +primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32# + +primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32# + with code_size = 0 + +primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int# +primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int# +primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int# +primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int# +primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int# + +------------------------------------------------------------------------ +section "Int64#" + {Operations on 64-bit signed words.} +------------------------------------------------------------------------ + +primtype Int64# + +primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int# +primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64# + +primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64# + +primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + commutable = True + +primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64# + +primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + commutable = True + +primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + effect = CanFail + div_like = True + +primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64# + with + effect = CanFail + div_like = True + +primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64# +primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64# +primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64# + +primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64# + with code_size = 0 + +primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int# +primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int# +primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int# +primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int# +primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int# + +------------------------------------------------------------------------ +section "Word64#" + {Operations on 64-bit unsigned words.} +------------------------------------------------------------------------ + +primtype Word64# + +primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word# +primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64# + +primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + commutable = True + +primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64# + +primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + commutable = True + +primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + effect = CanFail + div_like = True + +primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64# + with + effect = CanFail + div_like = True + +primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64# + with commutable = True + +primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64# + +primop Word64SllOp "uncheckedShiftL64#" GenPrimOp Word64# -> Int# -> Word64# +primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64# + +primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64# + with code_size = 0 + +primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int# +primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int# +primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int# +primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int# +primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int# + +------------------------------------------------------------------------ +section "Int#" + {Operations on native-size integers (32+ bits).} +------------------------------------------------------------------------ + +primtype Int# + +primop IntAddOp "+#" GenPrimOp + Int# -> Int# -> Int# + with commutable = True + fixity = infixl 6 + +primop IntSubOp "-#" GenPrimOp Int# -> Int# -> Int# + with fixity = infixl 6 + +primop IntMulOp "*#" + GenPrimOp Int# -> Int# -> Int# + {Low word of signed integer multiply.} + with commutable = True + fixity = infixl 7 + +primop IntMul2Op "timesInt2#" GenPrimOp + Int# -> Int# -> (# Int#, Int#, Int# #) + {Return a triple (isHighNeeded,high,low) where high and low are respectively + the high and low bits of the double-word result. isHighNeeded is a cheap way + to test if the high word is a sign-extension of the low word (isHighNeeded = + 0#) or not (isHighNeeded = 1#).} + +primop IntMulMayOfloOp "mulIntMayOflo#" + GenPrimOp Int# -> Int# -> Int# + {Return non-zero if there is any possibility that the upper word of a + signed integer multiply might contain useful information. Return + zero only if you are completely sure that no overflow can occur. + On a 32-bit platform, the recommended implementation is to do a + 32 x 32 -> 64 signed multiply, and subtract result[63:32] from + (result[31] >>signed 31). If this is zero, meaning that the + upper word is merely a sign extension of the lower one, no + overflow can occur. + + On a 64-bit platform it is not always possible to + acquire the top 64 bits of the result. Therefore, a recommended + implementation is to take the absolute value of both operands, and + return 0 iff bits[63:31] of them are zero, since that means that their + magnitudes fit within 31 bits, so the magnitude of the product must fit + into 62 bits. + + If in doubt, return non-zero, but do make an effort to create the + correct answer for small args, since otherwise the performance of + @(*) :: Integer -> Integer -> Integer@ will be poor. + } + with commutable = True + +primop IntQuotOp "quotInt#" GenPrimOp + Int# -> Int# -> Int# + {Rounds towards zero. The behavior is undefined if the second argument is + zero. + } + with effect = CanFail + div_like = True + +primop IntRemOp "remInt#" GenPrimOp + Int# -> Int# -> Int# + {Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The + behavior is undefined if the second argument is zero. + } + with effect = CanFail + div_like = True + +primop IntQuotRemOp "quotRemInt#" GenPrimOp + Int# -> Int# -> (# Int#, Int# #) + {Rounds towards zero.} + with effect = CanFail + div_like = True + +primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int# + {Bitwise "and".} + with commutable = True + +primop IntOrOp "orI#" GenPrimOp Int# -> Int# -> Int# + {Bitwise "or".} + with commutable = True + +primop IntXorOp "xorI#" GenPrimOp Int# -> Int# -> Int# + {Bitwise "xor".} + with commutable = True + +primop IntNotOp "notI#" GenPrimOp Int# -> Int# + {Bitwise "not", also known as the binary complement.} + +primop IntNegOp "negateInt#" GenPrimOp Int# -> Int# + {Unary negation. + Since the negative 'Int#' range extends one further than the + positive range, 'negateInt#' of the most negative number is an + identity operation. This way, 'negateInt#' is always its own inverse.} + +primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Add signed integers reporting overflow. + First member of result is the sum truncated to an 'Int#'; + second member is zero if the true sum fits in an 'Int#', + nonzero if overflow occurred (the sum is either too large + or too small to fit in an 'Int#').} + with code_size = 2 + commutable = True + +primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) + {Subtract signed integers reporting overflow. + First member of result is the difference truncated to an 'Int#'; + second member is zero if the true difference fits in an 'Int#', + nonzero if overflow occurred (the difference is either too large + or too small to fit in an 'Int#').} + with code_size = 2 + +primop IntGtOp ">#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntGeOp ">=#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntEqOp "==#" Compare + Int# -> Int# -> Int# + with commutable = True + fixity = infix 4 + +primop IntNeOp "/=#" Compare + Int# -> Int# -> Int# + with commutable = True + fixity = infix 4 + +primop IntLtOp "<#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop IntLeOp "<=#" Compare Int# -> Int# -> Int# + with fixity = infix 4 + +primop ChrOp "chr#" GenPrimOp Int# -> Char# + with code_size = 0 + +primop IntToWordOp "int2Word#" GenPrimOp Int# -> Word# + with code_size = 0 + +primop IntToFloatOp "int2Float#" GenPrimOp Int# -> Float# + {Convert an 'Int#' to the corresponding 'Float#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'int2Float#' 1# == 1.0#@} +primop IntToDoubleOp "int2Double#" GenPrimOp Int# -> Double# + {Convert an 'Int#' to the corresponding 'Double#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'int2Double#' 1# == 1.0##@} + +primop WordToFloatOp "word2Float#" GenPrimOp Word# -> Float# + {Convert an 'Word#' to the corresponding 'Float#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'word2Float#' 1## == 1.0#@} +primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double# + {Convert an 'Word#' to the corresponding 'Double#' with the same + integral value (up to truncation due to floating-point precision). e.g. + @'word2Double#' 1## == 1.0##@} + +primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop IntSraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithmetic. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop IntSrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +------------------------------------------------------------------------ +section "Word#" + {Operations on native-sized unsigned words (32+ bits).} +------------------------------------------------------------------------ + +primtype Word# + +primop WordAddOp "plusWord#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordAddCOp "addWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #) + {Add unsigned integers reporting overflow. + The first element of the pair is the result. The second element is + the carry flag, which is nonzero on overflow. See also 'plusWord2#'.} + with code_size = 2 + commutable = True + +primop WordSubCOp "subWordC#" GenPrimOp Word# -> Word# -> (# Word#, Int# #) + {Subtract unsigned integers reporting overflow. + The first element of the pair is the result. The second element is + the carry flag, which is nonzero on overflow.} + with code_size = 2 + +primop WordAdd2Op "plusWord2#" GenPrimOp Word# -> Word# -> (# Word#, Word# #) + {Add unsigned integers, with the high part (carry) in the first + component of the returned pair and the low part in the second + component of the pair. See also 'addWordC#'.} + with code_size = 2 + commutable = True + +primop WordSubOp "minusWord#" GenPrimOp Word# -> Word# -> Word# + +primop WordMulOp "timesWord#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +-- Returns (# high, low #) +primop WordMul2Op "timesWord2#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with commutable = True + +primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word# + with effect = CanFail + div_like = True + +primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word# + with effect = CanFail + div_like = True + +primop WordQuotRemOp "quotRemWord#" GenPrimOp + Word# -> Word# -> (# Word#, Word# #) + with effect = CanFail + div_like = True + +primop WordQuotRem2Op "quotRemWord2#" GenPrimOp + Word# -> Word# -> Word# -> (# Word#, Word# #) + { Takes high word of dividend, then low word of dividend, then divisor. + Requires that high word < divisor.} + with effect = CanFail + div_like = True + +primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordOrOp "or#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordXorOp "xor#" GenPrimOp Word# -> Word# -> Word# + with commutable = True + +primop WordNotOp "not#" GenPrimOp Word# -> Word# + +primop WordSllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} +primop WordSrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Result undefined if shift amount is not + in the range 0 to word size - 1 inclusive.} + +primop WordToIntOp "word2Int#" GenPrimOp Word# -> Int# + with code_size = 0 + +primop WordGtOp "gtWord#" Compare Word# -> Word# -> Int# +primop WordGeOp "geWord#" Compare Word# -> Word# -> Int# +primop WordEqOp "eqWord#" Compare Word# -> Word# -> Int# +primop WordNeOp "neWord#" Compare Word# -> Word# -> Int# +primop WordLtOp "ltWord#" Compare Word# -> Word# -> Int# +primop WordLeOp "leWord#" Compare Word# -> Word# -> Int# + +primop PopCnt8Op "popCnt8#" GenPrimOp Word# -> Word# + {Count the number of set bits in the lower 8 bits of a word.} +primop PopCnt16Op "popCnt16#" GenPrimOp Word# -> Word# + {Count the number of set bits in the lower 16 bits of a word.} +primop PopCnt32Op "popCnt32#" GenPrimOp Word# -> Word# + {Count the number of set bits in the lower 32 bits of a word.} +primop PopCnt64Op "popCnt64#" GenPrimOp Word64# -> Word# + {Count the number of set bits in a 64-bit word.} +primop PopCntOp "popCnt#" GenPrimOp Word# -> Word# + {Count the number of set bits in a word.} + +primop Pdep8Op "pdep8#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to lower 8 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pdep16Op "pdep16#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to lower 16 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pdep32Op "pdep32#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to lower 32 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pdep64Op "pdep64#" GenPrimOp Word64# -> Word64# -> Word64# + {Deposit bits to a word at locations specified by a mask. + + @since 0.5.2.0} +primop PdepOp "pdep#" GenPrimOp Word# -> Word# -> Word# + {Deposit bits to a word at locations specified by a mask, aka + [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract). + + Software emulation: + + > pdep :: Word -> Word -> Word + > pdep src mask = go 0 src mask + > where + > go :: Word -> Word -> Word -> Word + > go result _ 0 = result + > go result src mask = go newResult newSrc newMask + > where + > maskCtz = countTrailingZeros mask + > newResult = if testBit src 0 then setBit result maskCtz else result + > newSrc = src `shiftR` 1 + > newMask = clearBit mask maskCtz + + @since 0.5.2.0} + +primop Pext8Op "pext8#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from lower 8 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pext16Op "pext16#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from lower 16 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pext32Op "pext32#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from lower 32 bits of a word at locations specified by a mask. + + @since 0.5.2.0} +primop Pext64Op "pext64#" GenPrimOp Word64# -> Word64# -> Word64# + {Extract bits from a word at locations specified by a mask. + + @since 0.5.2.0} +primop PextOp "pext#" GenPrimOp Word# -> Word# -> Word# + {Extract bits from a word at locations specified by a mask, aka + [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract). + + Software emulation: + + > pext :: Word -> Word -> Word + > pext src mask = loop 0 0 0 + > where + > loop i count result + > | i >= finiteBitSize (0 :: Word) + > = result + > | testBit mask i + > = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result) + > | otherwise + > = loop (i + 1) count result + + @since 0.5.2.0} + +primop Clz8Op "clz8#" GenPrimOp Word# -> Word# + {Count leading zeros in the lower 8 bits of a word.} +primop Clz16Op "clz16#" GenPrimOp Word# -> Word# + {Count leading zeros in the lower 16 bits of a word.} +primop Clz32Op "clz32#" GenPrimOp Word# -> Word# + {Count leading zeros in the lower 32 bits of a word.} +primop Clz64Op "clz64#" GenPrimOp Word64# -> Word# + {Count leading zeros in a 64-bit word.} +primop ClzOp "clz#" GenPrimOp Word# -> Word# + {Count leading zeros in a word.} + +primop Ctz8Op "ctz8#" GenPrimOp Word# -> Word# + {Count trailing zeros in the lower 8 bits of a word.} +primop Ctz16Op "ctz16#" GenPrimOp Word# -> Word# + {Count trailing zeros in the lower 16 bits of a word.} +primop Ctz32Op "ctz32#" GenPrimOp Word# -> Word# + {Count trailing zeros in the lower 32 bits of a word.} +primop Ctz64Op "ctz64#" GenPrimOp Word64# -> Word# + {Count trailing zeros in a 64-bit word.} +primop CtzOp "ctz#" GenPrimOp Word# -> Word# + {Count trailing zeros in a word.} + +primop BSwap16Op "byteSwap16#" GenPrimOp Word# -> Word# + {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. } + with defined_bits = 16 +primop BSwap32Op "byteSwap32#" GenPrimOp Word# -> Word# + {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. } + with defined_bits = 32 +primop BSwap64Op "byteSwap64#" GenPrimOp Word64# -> Word64# + {Swap bytes in a 64 bits of a word.} +primop BSwapOp "byteSwap#" GenPrimOp Word# -> Word# + {Swap bytes in a word.} + +primop BRev8Op "bitReverse8#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a 8-bit word.} + with defined_bits = 8 +primop BRev16Op "bitReverse16#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a 16-bit word.} + with defined_bits = 16 +primop BRev32Op "bitReverse32#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a 32-bit word.} + with defined_bits = 32 +primop BRev64Op "bitReverse64#" GenPrimOp Word64# -> Word64# + {Reverse the order of the bits in a 64-bit word.} +primop BRevOp "bitReverse#" GenPrimOp Word# -> Word# + {Reverse the order of the bits in a word.} + +------------------------------------------------------------------------ +section "Narrowings" + {Explicit narrowing of native-sized ints or words.} +------------------------------------------------------------------------ + +primop Narrow8IntOp "narrow8Int#" GenPrimOp Int# -> Int# +primop Narrow16IntOp "narrow16Int#" GenPrimOp Int# -> Int# +primop Narrow32IntOp "narrow32Int#" GenPrimOp Int# -> Int# +primop Narrow8WordOp "narrow8Word#" GenPrimOp Word# -> Word# +primop Narrow16WordOp "narrow16Word#" GenPrimOp Word# -> Word# +primop Narrow32WordOp "narrow32Word#" GenPrimOp Word# -> Word# + +------------------------------------------------------------------------ +section "Double#" + {Operations on double-precision (64 bit) floating-point numbers.} +------------------------------------------------------------------------ + +primtype Double# + +primop DoubleGtOp ">##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleGeOp ">=##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleEqOp "==##" Compare + Double# -> Double# -> Int# + with commutable = True + fixity = infix 4 + +primop DoubleNeOp "/=##" Compare + Double# -> Double# -> Int# + with commutable = True + fixity = infix 4 + +primop DoubleLtOp "<##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleLeOp "<=##" Compare Double# -> Double# -> Int# + with fixity = infix 4 + +primop DoubleMinOp "minDouble#" GenPrimOp + Double# -> Double# -> Double# + {Return the minimum of the arguments. + When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop DoubleMaxOp "maxDouble#" GenPrimOp + Double# -> Double# -> Double# + {Return the maximum of the arguments. + When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop DoubleAddOp "+##" GenPrimOp + Double# -> Double# -> Double# + with commutable = True + fixity = infixl 6 + +primop DoubleSubOp "-##" GenPrimOp Double# -> Double# -> Double# + with fixity = infixl 6 + +primop DoubleMulOp "*##" GenPrimOp + Double# -> Double# -> Double# + with commutable = True + fixity = infixl 7 + +primop DoubleDivOp "/##" GenPrimOp + Double# -> Double# -> Double# + with effect = CanFail -- Can this one really fail? + fixity = infixl 7 + +primop DoubleNegOp "negateDouble#" GenPrimOp Double# -> Double# + +primop DoubleFabsOp "fabsDouble#" GenPrimOp Double# -> Double# + +primop DoubleToIntOp "double2Int#" GenPrimOp Double# -> Int# + {Truncates a 'Double#' value to the nearest 'Int#'. + Results are undefined if the truncation if truncation yields + a value outside the range of 'Int#'.} + +primop DoubleToFloatOp "double2Float#" GenPrimOp Double# -> Float# + +primop DoubleExpOp "expDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleExpM1Op "expm1Double#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleLogOp "logDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleLog1POp "log1pDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleSqrtOp "sqrtDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleSinOp "sinDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleCosOp "cosDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleTanOp "tanDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAsinOp "asinDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleAcosOp "acosDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop DoubleAtanOp "atanDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleSinhOp "sinhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleCoshOp "coshDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleTanhOp "tanhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAsinhOp "asinhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAcoshOp "acoshDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleAtanhOp "atanhDouble#" GenPrimOp + Double# -> Double# + with + code_size = { primOpCodeSizeForeignCall } + +primop DoublePowerOp "**##" GenPrimOp + Double# -> Double# -> Double# + {Exponentiation.} + with + code_size = { primOpCodeSizeForeignCall } + +primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp + Double# -> (# Int#, Word#, Word#, Int# #) + {Convert to integer. + First component of the result is -1 or 1, indicating the sign of the + mantissa. The next two are the high and low 32 bits of the mantissa + respectively, and the last is the exponent.} + with out_of_line = True + +primop DoubleDecode_Int64Op "decodeDouble_Int64#" GenPrimOp + Double# -> (# Int64#, Int# #) + {Decode 'Double#' into mantissa and base-2 exponent.} + with out_of_line = True + +primop CastDoubleToWord64Op "castDoubleToWord64#" GenPrimOp + Double# -> Word64# + {Bitcast a 'Double#' into a 'Word64#'} + +primop CastWord64ToDoubleOp "castWord64ToDouble#" GenPrimOp + Word64# -> Double# + {Bitcast a 'Word64#' into a 'Double#'} + +------------------------------------------------------------------------ +section "Float#" + {Operations on single-precision (32-bit) floating-point numbers.} +------------------------------------------------------------------------ + +primtype Float# + +primop FloatGtOp "gtFloat#" Compare Float# -> Float# -> Int# +primop FloatGeOp "geFloat#" Compare Float# -> Float# -> Int# + +primop FloatEqOp "eqFloat#" Compare + Float# -> Float# -> Int# + with commutable = True + +primop FloatNeOp "neFloat#" Compare + Float# -> Float# -> Int# + with commutable = True + +primop FloatLtOp "ltFloat#" Compare Float# -> Float# -> Int# +primop FloatLeOp "leFloat#" Compare Float# -> Float# -> Int# + +primop FloatMinOp "minFloat#" GenPrimOp + Float# -> Float# -> Float# + {Return the minimum of the arguments. + When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop FloatMaxOp "maxFloat#" GenPrimOp + Float# -> Float# -> Float# + {Return the maximum of the arguments. + When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@) + or one of the arguments is not-a-number (NaN), + it is unspecified which one is returned.} + with commutable = True + +primop FloatAddOp "plusFloat#" GenPrimOp + Float# -> Float# -> Float# + with commutable = True + +primop FloatSubOp "minusFloat#" GenPrimOp Float# -> Float# -> Float# + +primop FloatMulOp "timesFloat#" GenPrimOp + Float# -> Float# -> Float# + with commutable = True + +primop FloatDivOp "divideFloat#" GenPrimOp + Float# -> Float# -> Float# + with effect = CanFail + +primop FloatNegOp "negateFloat#" GenPrimOp Float# -> Float# + +primop FloatFabsOp "fabsFloat#" GenPrimOp Float# -> Float# + +primop FloatToIntOp "float2Int#" GenPrimOp Float# -> Int# + {Truncates a 'Float#' value to the nearest 'Int#'. + Results are undefined if the truncation if truncation yields + a value outside the range of 'Int#'.} + +primop FloatExpOp "expFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatExpM1Op "expm1Float#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatLogOp "logFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatLog1POp "log1pFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatSqrtOp "sqrtFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatSinOp "sinFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatCosOp "cosFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatTanOp "tanFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAsinOp "asinFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatAcosOp "acosFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + effect = CanFail + +primop FloatAtanOp "atanFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatSinhOp "sinhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatCoshOp "coshFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatTanhOp "tanhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAsinhOp "asinhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAcoshOp "acoshFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatAtanhOp "atanhFloat#" GenPrimOp + Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatPowerOp "powerFloat#" GenPrimOp + Float# -> Float# -> Float# + with + code_size = { primOpCodeSizeForeignCall } + +primop FloatToDoubleOp "float2Double#" GenPrimOp Float# -> Double# + +primop FloatDecode_IntOp "decodeFloat_Int#" GenPrimOp + Float# -> (# Int#, Int# #) + {Convert to integers. + First 'Int#' in result is the mantissa; second is the exponent.} + with out_of_line = True + +primop CastFloatToWord32Op "castFloatToWord32#" GenPrimOp + Float# -> Word32# + {Bitcast a 'Float#' into a 'Word32#'} + +primop CastWord32ToFloatOp "castWord32ToFloat#" GenPrimOp + Word32# -> Float# + {Bitcast a 'Word32#' into a 'Float#'} + +------------------------------------------------------------------------ +section "Fused multiply-add operations" + { #fma# + + The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#' + implement the operation + + \[ + \lambda\ x\ y\ z \rightarrow x * y + z + \] + + with a single floating-point rounding operation at the end, as opposed to + rounding twice (which can accumulate rounding errors). + + These primops can be compiled directly to a single machine instruction on + architectures that support them. Currently, these are: + + 1. x86 with CPUs that support the FMA3 extended instruction set (which + includes most processors since 2013). + 2. PowerPC. + 3. AArch64. + + This requires users pass the '-mfma' flag to GHC. Otherwise, the primop + is implemented by falling back to the C standard library, which might + perform software emulation (this may yield results that are not IEEE + compliant on some platforms). + + The additional operations 'fmsubFloat#'/'fmsubDouble#', + 'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide + variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed: + + \[ + \begin{aligned} + \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt] + \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt] + \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt] + \mathrm{fnmsub}\ x\ y\ z &= - x * y - z + \end{aligned} + \] + + } +------------------------------------------------------------------------ + +primop FloatFMAdd "fmaddFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} +primop FloatFMSub "fmsubFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} +primop FloatFNMAdd "fnmaddFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} +primop FloatFNMSub "fnmsubFloat#" GenPrimOp + Float# -> Float# -> Float# -> Float# + {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} + +primop DoubleFMAdd "fmaddDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} +primop DoubleFMSub "fmsubDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} +primop DoubleFNMAdd "fnmaddDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} +primop DoubleFNMSub "fnmsubDouble#" GenPrimOp + Double# -> Double# -> Double# -> Double# + {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} + +------------------------------------------------------------------------ +section "Arrays" + {Operations on 'Array#'.} +------------------------------------------------------------------------ + +primtype Array# a + +primtype MutableArray# s a + +primop NewArrayOp "newArray#" GenPrimOp + Int# -> a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Create a new mutable array with the specified number of elements, + in the specified state thread, + with each element containing the specified initial value.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadArrayOp "readArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop WriteArrayOp "writeArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s + {Write to specified index of mutable array.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = 2 -- card update too + +primop SizeofArrayOp "sizeofArray#" GenPrimOp + Array# a_levpoly -> Int# + {Return the number of elements in the array.} + +primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# + {Return the number of elements in the array.} + +primop IndexArrayOp "indexArray#" GenPrimOp + Array# a_levpoly -> Int# -> (# a_levpoly #) + {Read from the specified index of an immutable array. The result is packaged + into an unboxed unary tuple; the result itself is not yet + evaluated. Pattern matching on the tuple forces the indexing of the + array to happen but does not evaluate the element itself. Evaluating + the thunk prevents additional thunks from building up on the + heap. Avoiding these thunks, in turn, reduces references to the + argument array, allowing it to be garbage collected more promptly.} + with + effect = CanFail + +-- Note [primOpEffect of unsafe freezes and thaws] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Mutable and immutable pointer arrays have different info table +-- pointers; this is for the benefit of the garbage collector. +-- Consequently, unsafe freeze/thaw operations on pointer arrays are +-- NOT no-ops: They at least have to update the info table pointer. (For +-- thaw, they also add the array to the mutable set.) +-- +-- We don't want to duplicate this, so these operations are considered +-- to have effect = ReadWriteEffect. +-- +-- (Actually, these operations /are/ no-ops in the JS backend, where +-- mutable and immutable arrays are the same because JS. But we don't +-- have target-dependent primOpEffect yet.) +-- +-- This reasoning does not apply to byte arrays, which the garbage +-- collector can always ignore the contents of. Their unsafe freeze +-- and thaw operations really are no-ops; their underlying heap +-- objects are always ARR_WORDS. + +primop UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp + MutableArray# s a_levpoly -> State# s -> (# State# s, Array# a_levpoly #) + {Make a mutable array immutable, without copying.} + with + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop UnsafeThawArrayOp "unsafeThawArray#" GenPrimOp + Array# a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Make an immutable array mutable, without copying.} + with + out_of_line = True + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop CopyArrayOp "copyArray#" GenPrimOp + Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. The two arrays must not + be the same array in different states, but this is not checked + either.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. In the case where + the source and destination are the same array the source and + destination regions may overlap.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CloneArrayOp "cloneArray#" GenPrimOp + Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect -- assumed too expensive to duplicate? + can_fail_warning = YesWarnCanFail + +primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FreezeArrayOp "freezeArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, Array# a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop ThawArrayOp "thawArray#" GenPrimOp + Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasArrayOp "casArray#" GenPrimOp + MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {Given an array, an offset, the expected old value, and + the new value, perform an atomic compare and swap (i.e. write the new + value if the current value and the old value are the same pointer). + Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns + the element at the offset after the operation completes. This means that + on a success the new value is returned, and on a failure the actual old + value (not the expected one) is returned. Implies a full memory barrier. + The use of a pointer equality on a boxed value makes this function harder + to use correctly than 'casIntArray#'. All of the difficulties + of using 'reallyUnsafePtrEquality#' correctly apply to + 'casArray#' as well. + } + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + + +------------------------------------------------------------------------ +section "Small Arrays" + + {Operations on 'SmallArray#'. A 'SmallArray#' works + just like an 'Array#', but with different space use and + performance characteristics (that are often useful with small + arrays). The 'SmallArray#' and 'SmallMutableArray#' + lack a `card table'. The purpose of a card table is to avoid + having to scan every element of the array on each GC by + keeping track of which elements have changed since the last GC + and only scanning those that have changed. So the consequence + of there being no card table is that the representation is + somewhat smaller and the writes are somewhat faster (because + the card table does not need to be updated). The disadvantage + of course is that for a 'SmallMutableArray#' the whole + array has to be scanned on each GC. Thus it is best suited for + use cases where the mutable array is not long lived, e.g. + where a mutable array is initialised quickly and then frozen + to become an immutable 'SmallArray#'. + } + +------------------------------------------------------------------------ + +primtype SmallArray# a + +primtype SmallMutableArray# s a + +primop NewSmallArrayOp "newSmallArray#" GenPrimOp + Int# -> a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Create a new mutable array with the specified number of elements, + in the specified state thread, + with each element containing the specified initial value.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s + {Shrink mutable array to new specified size, in + the specified state thread. The new size argument must be less than or + equal to the current size as reported by 'getSizeofSmallMutableArray#'. + + Assuming the non-profiling RTS, for the copying garbage collector + (default) this primitive compiles to an O(1) operation in C--, modifying + the array in-place. For the non-moving garbage collector, however, the + time is proportional to the number of elements shrinked out. Backends + bypassing C-- representation (such as JavaScript) might behave + differently. + + @since 0.6.1} + with out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + -- can fail because of the "newSize <= oldSize" requirement + +primop ReadSmallArrayOp "readSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #) + {Read from specified index of mutable array. Result is not yet evaluated.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop WriteSmallArrayOp "writeSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s + {Write to specified index of mutable array.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# + {Return the number of elements in the array.} + +primop SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# + {Return the number of elements in the array. __Deprecated__, it is + unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@ + operations on the same small mutable array.} + with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead } + +primop GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> State# s -> (# State# s, Int# #) + {Return the number of elements in the array, correctly accounting for + the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@. + + @since 0.6.1} + +primop IndexSmallArrayOp "indexSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> (# a_levpoly #) + {Read from specified index of immutable array. Result is packaged into + an unboxed singleton; the result itself is not yet evaluated.} + with + effect = CanFail + +primop UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> State# s -> (# State# s, SmallArray# a_levpoly #) + {Make a mutable array immutable, without copying.} + with + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop UnsafeThawSmallArrayOp "unsafeThawSmallArray#" GenPrimOp + SmallArray# a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Make an immutable array mutable, without copying.} + with + out_of_line = True + effect = ReadWriteEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +-- The code_size is only correct for the case when the copy family of +-- primops aren't inlined. It would be nice to keep track of both. + +primop CopySmallArrayOp "copySmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. Both arrays must fully contain the + specified ranges, but this is not checked. The two arrays must not + be the same array in different states, but this is not checked + either.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s + {Given a source array, an offset into the source array, a + destination array, an offset into the destination array, and a + number of elements to copy, copy the elements from the source array + to the destination array. The source and destination arrays can + refer to the same array. Both arrays must fully contain the + specified ranges, but this is not checked. + The regions are allowed to overlap, although this is only possible when the same + array is provided as both the source and the destination. } + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CloneSmallArrayOp "cloneSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect -- assumed too expensive to duplicate? + can_fail_warning = YesWarnCanFail + +primop CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop ThawSmallArrayOp "thawSmallArray#" GenPrimOp + SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #) + {Given a source array, an offset into the source array, and a number + of elements to copy, create a new array with the elements from the + source array. The provided array must fully contain the specified + range, but this is not checked.} + with + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasSmallArrayOp "casSmallArray#" GenPrimOp + SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {Unsafe, machine-level atomic compare and swap on an element within an array. + See the documentation of 'casArray#'.} + with + out_of_line = True + effect = ReadWriteEffect -- Might index out of bounds + can_fail_warning = YesWarnCanFail + +------------------------------------------------------------------------ +section "Byte Arrays" + {A 'ByteArray#' is a region of + raw memory in the garbage-collected heap, which is not + scanned for pointers. + There are three sets of operations for accessing byte array contents: + index for reading from immutable byte arrays, and read/write + for mutable byte arrays. Each set contains operations for a + range of useful primitive data types. Each operation takes + an offset measured in terms of the size of the primitive type + being read or written. + + } + +------------------------------------------------------------------------ + +primtype ByteArray# +{ + A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap, + which is not scanned for pointers during garbage collection. + + It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'. + Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood. + + The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures, + like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@. + + Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'. + + The representation on the heap of a Byte Array is: + + > +------------+-----------------+-----------------------+ + > | | | | + > | HEADER | SIZE (in bytes) | PAYLOAD | + > | | | | + > +------------+-----------------+-----------------------+ + + To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'. + + Alternatively, enabling the @UnliftedFFITypes@ extension + allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly. +} + +primtype MutableByteArray# s +{ A mutable 'ByteAray#'. It can be created in three ways: + + * 'newByteArray#': Create an unpinned array. + * 'newPinnedByteArray#': This will create a pinned array, + * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment. + + Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values + if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls, + because no garbage collection happens during these unsafe calls + (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety) + in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function + for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether). +} + +primop NewByteArrayOp_Char "newByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Create a new mutable byte array of specified size (in bytes), in + the specified state thread. The size of the memory underlying the + array will be rounded up to the platform's word size.} + with out_of_line = True + effect = ReadWriteEffect + +primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Like 'newByteArray#' but GC guarantees not to move it.} + with out_of_line = True + effect = ReadWriteEffect + +primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp + Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #) + {Like 'newPinnedByteArray#' but allow specifying an arbitrary + alignment, which must be a power of two.} + with out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + -- can fail warning for the "power of two" requirement + +primop MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp + MutableByteArray# s -> Int# + {Determine whether a 'MutableByteArray#' is guaranteed not to move + during GC.} + with out_of_line = True + +primop ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp + ByteArray# -> Int# + {Determine whether a 'ByteArray#' is guaranteed not to move.} + with out_of_line = True + +primop ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp + ByteArray# -> Int# + {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed + to be copied into compact regions by the user, potentially invalidating + the results of earlier calls to 'byteArrayContents#'. + + See the section `Pinned Byte Arrays` in the user guide for more information. + + This function also returns true for regular pinned bytearrays. + } + with out_of_line = True + +primop MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp + MutableByteArray# s -> Int# + { 'isByteArrayWeaklyPinned#' but for mutable arrays. + } + with out_of_line = True + +primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp + ByteArray# -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp + MutableByteArray# s -> Addr# + {Intended for use with pinned arrays; otherwise very unsafe!} + +primop ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + {Shrink mutable byte array to new specified size (in bytes), in + the specified state thread. The new size argument must be less than or + equal to the current size as reported by 'getSizeofMutableByteArray#'. + + Assuming the non-profiling RTS, this primitive compiles to an O(1) + operation in C--, modifying the array in-place. Backends bypassing C-- + representation (such as JavaScript) might behave differently. + + @since 0.4.0.0} + with out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + -- can fail for the "newSize <= oldSize" requirement + +primop ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) + {Resize mutable byte array to new specified size (in bytes), shrinking or growing it. + The returned 'MutableByteArray#' is either the original + 'MutableByteArray#' resized in-place or, if not possible, a newly + allocated (unpinned) 'MutableByteArray#' (with the original content + copied over). + + To avoid undefined behaviour, the original 'MutableByteArray#' shall + not be accessed anymore after a 'resizeMutableByteArray#' has been + performed. Moreover, no reference to the old one should be kept in order + to allow garbage collection of the original 'MutableByteArray#' in + case a new 'MutableByteArray#' had to be allocated. + + @since 0.4.0.0} + with out_of_line = True + effect = ReadWriteEffect + +primop UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp + MutableByteArray# s -> State# s -> (# State# s, ByteArray# #) + {Make a mutable byte array immutable, without copying.} + with + code_size = 0 + effect = NoEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop UnsafeThawByteArrayOp "unsafeThawByteArray#" GenPrimOp + ByteArray# -> State# s -> (# State# s, MutableByteArray# s #) + {Make an immutable byte array mutable, without copying. + + @since 0.12.0.0} + with + code_size = 0 + effect = NoEffect + -- see Note [primOpEffect of unsafe freezes and thaws] + +primop SizeofByteArrayOp "sizeofByteArray#" GenPrimOp + ByteArray# -> Int# + {Return the size of the array in bytes.} + +primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# + {Return the size of the array in bytes. __Deprecated__, it is + unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#' + operations on the same mutable byte + array.} + with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead } + +primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp + MutableByteArray# s -> State# s -> (# State# s, Int# #) + {Return the number of elements in the array, correctly accounting for + the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'. + + @since 0.5.0.0} + + +bytearray_access_ops +-- This generates a whole bunch of primops; +-- see utils/genprimopcode/AccessOps.hs + + +primop CompareByteArraysOp "compareByteArrays#" GenPrimOp + ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# + {@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares + @n@ bytes starting at offset @src1_ofs@ in the first + 'ByteArray#' @src1@ to the range of @n@ bytes + (i.e. same length) starting at offset @src2_ofs@ of the second + 'ByteArray#' @src2@. Both arrays must fully contain the + specified ranges, but this is not checked. Returns an 'Int#' + less than, equal to, or greater than zero if the range is found, + respectively, to be byte-wise lexicographically less than, to + match, or be greater than the second range. + + @since 0.5.2.0} + with + effect = CanFail + +primop CopyByteArrayOp "copyByteArray#" GenPrimOp + ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + { @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range + starting at offset @src_ofs@ of length @len@ from the + 'ByteArray#' @src@ to the 'MutableByteArray#' @dst@ + starting at offset @dst_ofs@. Both arrays must fully contain + the specified ranges, but this is not checked. The two arrays must + not be the same array in different states, but this is not checked + either. + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4} + +primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + { @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the + range starting at offset @src_ofs@ of length @len@ from the + 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@ + starting at offset @dst_ofs@. Both arrays must fully contain the + specified ranges, but this is not checked. The regions are + allowed to overlap, although this is only possible when the same + array is provided as both the source and the destination. + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyMutableByteArrayNonOverlappingOp "copyMutableByteArrayNonOverlapping#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + { @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@ + copies the range starting at offset @src_ofs@ of length @len@ from + the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@ + starting at offset @dst_ofs@. Both arrays must fully contain the + specified ranges, but this is not checked. The regions are /not/ + allowed to overlap, but this is also not checked. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp + ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s + {Copy a range of the ByteArray\# to the memory range starting at the Addr\#. + The ByteArray\# and the memory region at Addr\# must fully contain the + specified ranges, but this is not checked. The Addr\# must not point into the + ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked + either.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp + MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s + {Copy a range of the MutableByteArray\# to the memory range starting at the + Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully + contain the specified ranges, but this is not checked. The Addr\# must not + point into the MutableByteArray\# (e.g. if the MutableByteArray\# were + pinned), but this is not checked either.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp + Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a memory range starting at the Addr\# to the specified range in the + MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully + contain the specified ranges, but this is not checked. The Addr\# must not + point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned), + but this is not checked either.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyAddrToAddrOp "copyAddrToAddr#" GenPrimOp + Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld + { @'copyAddrToAddr#' src dest len@ copies @len@ bytes + from @src@ to @dest@. These two memory ranges are allowed to overlap. + + Analogous to the standard C function @memmove@, but with a different + argument order. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall } + +primop CopyAddrToAddrNonOverlappingOp "copyAddrToAddrNonOverlapping#" GenPrimOp + Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld + { @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes + from @src@ to @dest@. As the name suggests, these two memory ranges + /must not overlap/, although this pre-condition is not checked. + + Analogous to the standard C function @memcpy@, but with a different + argument order. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall } + +primop SetByteArrayOp "setByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s + {@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of + the 'MutableByteArray#' to the byte @c@.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall + 4 } + +primop SetAddrRangeOp "setAddrRange#" GenPrimOp + Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld + { @'setAddrRange#' dest len c@ sets all of the bytes in + @[dest, dest+len)@ to the value @c@. + + Analogous to the standard C function @memset@, but with a different + argument order. + + @since 0.11.0 + } + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + code_size = { primOpCodeSizeForeignCall } + +-- Atomic operations + +primop AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) + {Given an array and an offset in machine words, read an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Given an array and an offset in machine words, write an element. The + index is assumed to be in bounds. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int "casIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, an offset in machine words, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int8 "casInt8Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s, Int8# #) + {Given an array, an offset in bytes, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int16 "casInt16Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s, Int16# #) + {Given an array, an offset in 16 bit units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int32 "casInt32Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s, Int32# #) + {Given an array, an offset in 32 bit units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasByteArrayOp_Int64 "casInt64Array#" GenPrimOp + MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s, Int64# #) + {Given an array, an offset in 64 bit units, the expected old value, and + the new value, perform an atomic compare and swap i.e. write the new + value if the current value matches the provided old value. Returns + the value of the element before the operation. Implies a full memory + barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to subtract, + atomically subtract the value from the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to AND, + atomically AND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to NAND, + atomically NAND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to OR, + atomically OR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp + MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) + {Given an array, and offset in machine words, and a value to XOR, + atomically XOR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +------------------------------------------------------------------------ +section "Addr#" +------------------------------------------------------------------------ + +primtype Addr# + { An arbitrary machine address assumed to point outside + the garbage-collected heap. } + +pseudoop "nullAddr#" Addr# + { The null address. } + +primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# +primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# + {Result is meaningless if two 'Addr#'s are so far apart that their + difference doesn't fit in an 'Int#'.} +primop AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int# + {Return the remainder when the 'Addr#' arg, treated like an 'Int#', + is divided by the 'Int#' arg.} +primop AddrToIntOp "addr2Int#" GenPrimOp Addr# -> Int# + {Coerce directly from address to int. Users are discouraged from using + this operation as it makes little sense on platforms with tagged pointers.} + with code_size = 0 +primop IntToAddrOp "int2Addr#" GenPrimOp Int# -> Addr# + {Coerce directly from int to address. Users are discouraged from using + this operation as it makes little sense on platforms with tagged pointers.} + with code_size = 0 + +primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Int# +primop AddrGeOp "geAddr#" Compare Addr# -> Addr# -> Int# +primop AddrEqOp "eqAddr#" Compare Addr# -> Addr# -> Int# +primop AddrNeOp "neAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLtOp "ltAddr#" Compare Addr# -> Addr# -> Int# +primop AddrLeOp "leAddr#" Compare Addr# -> Addr# -> Int# + + +addr_access_ops +-- This generates a whole bunch of primops; +-- see utils/genprimopcode/AccessOps.hs + + +primop InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp + Addr# -> Addr# -> State# s -> (# State# s, Addr# #) + {The atomic exchange operation. Atomically exchanges the value at the first address + with the Addr# given as second argument. Implies a read barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {The atomic exchange operation. Atomically exchanges the value at the address + with the given value. Returns the old value. Implies a read barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp + Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #) + { Compare and swap on a word-sized memory location. + + Use as: \s -> atomicCasAddrAddr# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp + Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #) + { Compare and swap on a word-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word8 "atomicCasWord8Addr#" GenPrimOp + Addr# -> Word8# -> Word8# -> State# s -> (# State# s, Word8# #) + { Compare and swap on a 8 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr8# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word16 "atomicCasWord16Addr#" GenPrimOp + Addr# -> Word16# -> Word16# -> State# s -> (# State# s, Word16# #) + { Compare and swap on a 16 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr16# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word32 "atomicCasWord32Addr#" GenPrimOp + Addr# -> Word32# -> Word32# -> State# s -> (# State# s, Word32# #) + { Compare and swap on a 32 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr32# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop CasAddrOp_Word64 "atomicCasWord64Addr#" GenPrimOp + Addr# -> Word64# -> Word64# -> State# s -> (# State# s, Word64# #) + { Compare and swap on a 64 bit-sized and aligned memory location. + + Use as: \s -> atomicCasWordAddr64# location expected desired s + + This version always returns the old value read. This follows the normal + protocol for CAS operations (and matches the underlying instruction on + most architectures). + + Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to add, + atomically add the value to the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to subtract, + atomically subtract the value from the element. Returns the value of + the element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchAndAddrOp_Word "fetchAndWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to AND, + atomically AND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchNandAddrOp_Word "fetchNandWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to NAND, + atomically NAND the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchOrAddrOp_Word "fetchOrWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to OR, + atomically OR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop FetchXorAddrOp_Word "fetchXorWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> (# State# s, Word# #) + {Given an address, and a value to XOR, + atomically XOR the value into the element. Returns the value of the + element before the operation. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp + Addr# -> State# s -> (# State# s, Word# #) + {Given an address, read a machine word. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +primop AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp + Addr# -> Word# -> State# s -> State# s + {Given an address, write a machine word. Implies a full memory barrier.} + with + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + + +------------------------------------------------------------------------ +section "Mutable variables" + {Operations on MutVar\#s.} +------------------------------------------------------------------------ + +primtype MutVar# s a + {A 'MutVar#' behaves like a single-element mutable array.} + +primop NewMutVarOp "newMutVar#" GenPrimOp + a_levpoly -> State# s -> (# State# s, MutVar# s a_levpoly #) + {Create 'MutVar#' with specified initial value in specified state thread.} + with + out_of_line = True + effect = ReadWriteEffect + +-- Note [Why MutVar# ops can't fail] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We don't label readMutVar# or writeMutVar# as CanFail. +-- This may seem a bit peculiar, because they surely *could* +-- fail spectacularly if passed a pointer to unallocated memory. +-- But MutVar#s are always correct by construction; we never +-- test if a pointer is valid before using it with these operations. +-- So we never have to worry about floating the pointer reference +-- outside a validity test. At the moment, ReadWriteEffect blocks +-- up the relevant optimizations anyway, but we hope to draw finer +-- distinctions soon, which should improve matters for readMutVar# +-- at least. + +primop ReadMutVarOp "readMutVar#" GenPrimOp + MutVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #) + {Read contents of 'MutVar#'. Result is not yet evaluated.} + with + -- See Note [Why MutVar# ops can't fail] + effect = ReadWriteEffect + +primop WriteMutVarOp "writeMutVar#" GenPrimOp + MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s + {Write contents of 'MutVar#'.} + with + -- See Note [Why MutVar# ops can't fail] + effect = ReadWriteEffect + code_size = { primOpCodeSizeForeignCall } -- for the write barrier + +primop AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp + MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, a_levpoly #) + {Atomically exchange the value of a 'MutVar#'.} + with + effect = ReadWriteEffect + +-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Looking at the type of atomicModifyMutVar2#, one might wonder why +-- it doesn't return an unboxed tuple. e.g., +-- +-- MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #) +-- +-- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity. +-- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces +-- its contents with a thunk of the form (fst (f x)). This can be done using an +-- atomic compare-and-swap as it is merely replacing a pointer. + +primop AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp + MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #) + { Modify the contents of a 'MutVar#', returning the previous + contents @x :: a@ and the result of applying the given function to the + previous contents @f x :: c@. + + The @data@ type @c@ (not a @newtype@!) must be a record whose first field + is of lifted type @a :: Type@ and is not unpacked. For example, product + types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both + monomorphic and strict in its first field, it's recommended to mark the + latter @{-# NOUNPACK #-}@ explicitly. + + Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an + old @x :: a@ with a pointer to a selector thunk @fst r@, where + @fst@ is a selector for the first field of the record and @r@ is a + function application thunk @r = f x@. + + @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an + effort to reflect restrictions on @c@ faithfully, providing a + well-typed high-level wrapper.} + with + out_of_line = True + effect = ReadWriteEffect + strictness = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv } + +primop AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp + MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #) + { Modify the contents of a 'MutVar#', returning the previous + contents and the result of applying the given function to the + previous contents. } + with + out_of_line = True + effect = ReadWriteEffect + strictness = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv } + +primop CasMutVarOp "casMutVar#" GenPrimOp + MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + { Compare-and-swap: perform a pointer equality test between + the first value passed to this function and the value + stored inside the 'MutVar#'. If the pointers are equal, + replace the stored value with the second value passed to this + function, otherwise do nothing. + Returns the final value stored inside the 'MutVar#'. + The 'Int#' indicates whether a swap took place, + with @1#@ meaning that we didn't swap, and @0#@ + that we did. + Implies a full memory barrier. + Because the comparison is done on the level of pointers, + all of the difficulties of using + 'reallyUnsafePtrEquality#' correctly apply to + 'casMutVar#' as well. + } + with + out_of_line = True + effect = ReadWriteEffect + +------------------------------------------------------------------------ +section "Exceptions" +------------------------------------------------------------------------ + +-- Note [Strict IO wrappers] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Consider this example, which comes from GHC.IO.Handle.Internals: +-- wantReadableHandle3 f mv b st +-- = case ... of +-- DEFAULT -> case mv of MVar a -> ... +-- 0# -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...) +-- The outer case just decides whether to mask exceptions, but we don't want +-- thereby to hide the strictness in `mv`! Hence the use of strictOnceApply1Dmd +-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect +-- that it potentially calls its action multiple times). +-- +-- Note [Strictness for catch-style primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The catch#-style primops always call their action, just like outlined +-- in Note [Strict IO wrappers]. +-- However, it is important that we give their first arg lazyApply1Dmd and not +-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call +-- +-- catch# act handler s +-- +-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that +-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and +-- Note [Precise exceptions and strictness analysis]). +-- This would cause dead code elimination to discard the continuation of the +-- catch# call, among other things. This first came up in #11555. +-- +-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag +-- from `act`. (This is a bit brutal, but the language of strictness types is +-- not expressive enough to give it a more precise semantics that is still +-- sound.) +-- For perf reasons we often (but not always) choose to use a wrapper around +-- catch# that is head-strict in `act`: GHC.IO.catchException. +-- +-- A similar caveat applies to prompt#, which can be seen as a +-- generalisation of catch# as explained in GHC.Prim#continuations#. +-- The reason is that even if `act` appears dead-ending (e.g., looping) +-- `prompt# tag ma s` might return alright due to a (higher-order) use of +-- `control0#` in `act`. This came up in #25439. + +primop CatchOp "catch#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #) ) + -> (b_levpoly -> State# RealWorld -> (# State# RealWorld, a_reppoly #) ) + -> State# RealWorld + -> (# State# RealWorld, a_reppoly #) + { @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions + thrown. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , lazyApply2Dmd + , topDmd] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + -- Either inner computation might potentially raise an unchecked exception, + -- but it doesn't seem worth putting a WARNING in the haddocks over + +primop RaiseOp "raise#" GenPrimOp + a_levpoly -> b_reppoly + with + -- In contrast to 'raiseIO#', which throws a *precise* exception, + -- exceptions thrown by 'raise#' are considered *imprecise*. + -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand. + -- Hence, it has 'botDiv', not 'exnDiv'. + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + work_free = True + +primop RaiseUnderflowOp "raiseUnderflow#" GenPrimOp + (# #) -> b_reppoly + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + code_size = { primOpCodeSizeForeignCall } + work_free = True + +primop RaiseOverflowOp "raiseOverflow#" GenPrimOp + (# #) -> b_reppoly + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + code_size = { primOpCodeSizeForeignCall } + work_free = True + +primop RaiseDivZeroOp "raiseDivZero#" GenPrimOp + (# #) -> b_reppoly + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ThrowsException + code_size = { primOpCodeSizeForeignCall } + work_free = True + +primop RaiseIOOp "raiseIO#" GenPrimOp + a_levpoly -> State# RealWorld -> (# State# RealWorld, b_reppoly #) + with + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + -- for why this is the *only* primop that has 'exnDiv' + strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv } + out_of_line = True + effect = ThrowsException + work_free = True + +primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + { @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous + exceptions are deferred until after evaluation has finished. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + { @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous + exceptions are deferred until after evaluation has finished. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + { @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous + exceptions are unmasked. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +primop MaskStatus "getMaskingState#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + effect = ReadWriteEffect + +------------------------------------------------------------------------ +section "Continuations" + { #continuations# + + These operations provide access to first-class delimited continuations, + which allow a computation to access and manipulate portions of its + /current continuation/. Operationally, they are implemented by direct + manipulation of the RTS call stack, which may provide significant + performance gains relative to manual continuation-passing style (CPS) for + some programs. + + Intuitively, the delimited control operators 'prompt#' and + 'control0#' can be understood by analogy to 'catch#' and 'raiseIO#', + respectively: + + * Like 'catch#', 'prompt#' does not do anything on its own, it + just /delimits/ a subcomputation (the source of the name "delimited + continuations"). + + * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing + 'prompt#' before resuming execution. + + However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard + the aborted computation: instead, it /captures/ it in a form that allows + it to be resumed later. In other words, 'control0#' does not + irreversibly abort the local computation before returning to the enclosing + 'prompt#', it merely suspends it. All local context of the suspended + computation is packaged up and returned as an ordinary function that can be + invoked at a later point in time to /continue/ execution, which is why + the suspended computation is known as a /first-class continuation/. + + In GHC, every continuation prompt is associated with exactly one + 'PromptTag#'. Prompt tags are unique, opaque values created by + 'newPromptTag#' that may only be compared for equality. Both 'prompt#' + and 'control0#' accept a 'PromptTag#' argument, and 'control0#' + captures the continuation up to the nearest enclosing use of 'prompt#' + /with the same tag/. This allows a program to control exactly which + prompt it will abort to by using different tags, similar to how a program + can control which 'catch' it will abort to by throwing different types + of exceptions. Additionally, 'PromptTag#' accepts a single type parameter, + which is used to relate the expected result type at the point of the + 'prompt#' to the type of the continuation produced by 'control0#'. + + == The gory details + + The high-level explanation provided above should hopefully provide some + intuition for what these operations do, but it is not very precise; this + section provides a more thorough explanation. + + The 'prompt#' operation morally has the following type: + +@ +'prompt#' :: 'PromptTag#' a -> IO a -> IO a +@ + + If a computation @/m/@ never calls 'control0#', then + @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is + a no-op. This implies the following law: + + \[ + \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x + \] + + The 'control0#' operation morally has the following type: + +@ +'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b +@ + + @'control0#' /tag/ /f/@ captures the current continuation up to the nearest + enclosing @'prompt#' /tag/@ and resumes execution from the point of the call + to 'prompt#', passing the captured continuation to @/f/@. To make that + somewhat more precise, we can say 'control0#' obeys the following law: + + \[ + \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k) + \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k) + \] + + However, this law does not fully describe the behavior of 'control0#', + as it does not account for situations where 'control0#' does not appear + immediately inside 'prompt#'. Capturing the semantics more precisely + requires some additional notational machinery; a common approach is to + use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics). + Assuming an appropriate definition of evaluation contexts \(E\), the + semantics of 'prompt#' and 'control0#' can be given as follows: + + \[ + \begin{aligned} + E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)] + &\longrightarrow E[\mathtt{pure}\ v] \\[8pt] + E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]] + &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt] + \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2 + \end{aligned} + \] + + A full treatment of the semantics and metatheory of delimited control is + well outside the scope of this documentation, but a good, thorough + overview (in Haskell) is provided in [A Monadic Framework for Delimited + Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by + Dybvig et al. + + == Safety and invariants + + Correct uses of 'control0#' must obey the following restrictions: + + 1. The behavior of 'control0#' is only well-defined within a /strict + 'State#' thread/, such as those associated with @IO@ and strict @ST@ + computations. + + 2. Furthermore, 'control0#' may only be called within the dynamic extent + of a 'prompt#' with a matching tag somewhere in the /current/ strict + 'State#' thread. Effectively, this means that a matching prompt must + exist somewhere, and the captured continuation must /not/ contain any + uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For + example, the following program is ill-defined: + + @ + 'prompt#' /tag/ $ + evaluate (unsafePerformIO $ 'control0#' /tag/ /f/) + @ + + In this example, the use of 'prompt#' appears in a different 'State#' + thread from the use of 'control0#', so there is no valid prompt in + scope to capture up to. + + 3. Finally, 'control0#' may not be used within 'State#' threads associated + with an STM transaction (i.e. those introduced by 'atomically#'). + + If the runtime is able to detect that any of these invariants have been + violated in a way that would compromise internal invariants of the runtime, + 'control0#' will fail by raising an exception. However, such violations + are only detected on a best-effort basis, as the bookkeeping necessary for + detecting /all/ illegal uses of 'control0#' would have significant overhead. + Therefore, although the operations are "safe" from the runtime's point of + view (e.g. they will not compromise memory safety or clobber internal runtime + state), it is still ultimately the programmer's responsibility to ensure + these invariants hold to guarantee predictable program behavior. + + In a similar vein, since each captured continuation includes the full local + context of the suspended computation, it can safely be resumed arbitrarily + many times without violating any invariants of the runtime system. However, + use of these operations in an arbitrary 'IO' computation may be unsafe for + other reasons, as most 'IO' code is not written with reentrancy in mind. For + example, a computation suspended in the middle of reading a file will likely + finish reading it when it is resumed; further attempts to resume from the + same place would then fail because the file handle was already closed. + + In other words, although the RTS ensures that a computation's control state + and local variables are properly restored for each distinct resumption of + a continuation, it makes no attempt to duplicate any local state the + computation may have been using (and could not possibly do so in general). + Furthermore, it provides no mechanism for an arbitrary computation to + protect itself against unwanted reentrancy (i.e. there is no analogue to + Scheme's @dynamic-wind@). For those reasons, manipulating the continuation + is only safe if the caller can be certain that doing so will not violate any + expectations or invariants of the enclosing computation. } +------------------------------------------------------------------------ + +primtype PromptTag# a + { See "GHC.Prim#continuations". } + +primop NewPromptTagOp "newPromptTag#" GenPrimOp + State# RealWorld -> (# State# RealWorld, PromptTag# a #) + { See "GHC.Prim#continuations". } + with + out_of_line = True + effect = ReadWriteEffect + +primop PromptOp "prompt#" GenPrimOp + PromptTag# a + -> (State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld -> (# State# RealWorld, a #) + { See "GHC.Prim#continuations". } + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + +primop Control0Op "control0#" GenPrimOp + PromptTag# a + -> (((State# RealWorld -> (# State# RealWorld, b_reppoly #)) + -> State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld -> (# State# RealWorld, b_reppoly #) + { See "GHC.Prim#continuations". } + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv } + out_of_line = True + effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + +------------------------------------------------------------------------ +section "STM-accessible Mutable Variables" +------------------------------------------------------------------------ + +primtype TVar# s a + +primop AtomicallyOp "atomically#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> State# RealWorld -> (# State# RealWorld, a_levpoly #) + with + strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv } + -- See Note [Strict IO wrappers] + out_of_line = True + effect = ReadWriteEffect + +-- NB: retry#'s strictness information specifies it to diverge. +-- This lets the compiler perform some extra simplifications, since retry# +-- will technically never return. +-- +-- This allows the simplifier to replace things like: +-- case retry# s1 +-- (# s2, a #) -> e +-- with: +-- retry# s1 +-- where 'e' would be unreachable anyway. See #8091. +primop RetryOp "retry#" GenPrimOp + State# RealWorld -> (# State# RealWorld, a_levpoly #) + with + strictness = { \ _arity -> mkClosedDmdSig [topDmd] botDiv } + out_of_line = True + effect = ReadWriteEffect + +primop CatchRetryOp "catchRetry#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + with + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , lazyApply1Dmd + , topDmd ] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + +primop CatchSTMOp "catchSTM#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (b -> State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) ) + with + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , lazyApply2Dmd + , topDmd ] topDiv } + -- See Note [Strictness for catch-style primops] + out_of_line = True + effect = ReadWriteEffect + +primop NewTVarOp "newTVar#" GenPrimOp + a_levpoly + -> State# s -> (# State# s, TVar# s a_levpoly #) + {Create a new 'TVar#' holding a specified initial value.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadTVarOp "readTVar#" GenPrimOp + TVar# s a_levpoly + -> State# s -> (# State# s, a_levpoly #) + {Read contents of 'TVar#' inside an STM transaction, + i.e. within a call to 'atomically#'. + Does not force evaluation of the result.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadTVarIOOp "readTVarIO#" GenPrimOp + TVar# s a_levpoly + -> State# s -> (# State# s, a_levpoly #) + {Read contents of 'TVar#' outside an STM transaction. + Does not force evaluation of the result.} + with + out_of_line = True + effect = ReadWriteEffect + +primop WriteTVarOp "writeTVar#" GenPrimOp + TVar# s a_levpoly + -> a_levpoly + -> State# s -> State# s + {Write contents of 'TVar#'.} + with + out_of_line = True + effect = ReadWriteEffect + + +------------------------------------------------------------------------ +section "Synchronized Mutable Variables" + {Operations on 'MVar#'s. } +------------------------------------------------------------------------ + +primtype MVar# s a + { A shared mutable variable (/not/ the same as a 'MutVar#'!). + (Note: in a non-concurrent implementation, @('MVar#' a)@ can be + represented by @('MutVar#' (Maybe a))@.) } + +primop NewMVarOp "newMVar#" GenPrimOp + State# s -> (# State# s, MVar# s a_levpoly #) + {Create new 'MVar#'; initially empty.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TakeMVarOp "takeMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #) + {If 'MVar#' is empty, block until it becomes full. + Then remove and return its contents, and set it empty.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {If 'MVar#' is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.} + with + out_of_line = True + effect = ReadWriteEffect + +primop PutMVarOp "putMVar#" GenPrimOp + MVar# s a_levpoly -> a_levpoly -> State# s -> State# s + {If 'MVar#' is full, block until it becomes empty. + Then store value arg as its new contents.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TryPutMVarOp "tryPutMVar#" GenPrimOp + MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, Int# #) + {If 'MVar#' is full, immediately return with integer 0. + Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.} + with + out_of_line = True + effect = ReadWriteEffect + +primop ReadMVarOp "readMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #) + {If 'MVar#' is empty, block until it becomes full. + Then read its contents without modifying the MVar, without possibility + of intervention from other threads.} + with + out_of_line = True + effect = ReadWriteEffect + +primop TryReadMVarOp "tryReadMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #) + {If 'MVar#' is empty, immediately return with integer 0 and value undefined. + Otherwise, return with integer 1 and contents of 'MVar#'.} + with + out_of_line = True + effect = ReadWriteEffect + +primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp + MVar# s a_levpoly -> State# s -> (# State# s, Int# #) + {Return 1 if 'MVar#' is empty; 0 otherwise.} + with + out_of_line = True + effect = ReadWriteEffect + + +------------------------------------------------------------------------ +section "Delay/wait operations" +------------------------------------------------------------------------ + +primop DelayOp "delay#" GenPrimOp + Int# -> State# s -> State# s + {Sleep specified number of microseconds.} + with + effect = ReadWriteEffect + out_of_line = True + +primop WaitReadOp "waitRead#" GenPrimOp + Int# -> State# s -> State# s + {Block until input is available on specified file descriptor.} + with + effect = ReadWriteEffect + out_of_line = True + +primop WaitWriteOp "waitWrite#" GenPrimOp + Int# -> State# s -> State# s + {Block until output is possible on specified file descriptor.} + with + effect = ReadWriteEffect + out_of_line = True + +------------------------------------------------------------------------ +section "Concurrency primitives" +------------------------------------------------------------------------ + +primtype State# s + { 'State#' is the primitive, unlifted type of states. It has + one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@, + where s is a type variable. The only purpose of the type parameter + is to keep different state threads separate. It is represented by + nothing at all. } + +primtype RealWorld + { 'RealWorld' is deeply magical. It is /primitive/, but it is not + /unlifted/ (hence @ptrArg@). We never manipulate values of type + 'RealWorld'; it's only used in the type system, to parameterise 'State#'. } + +primtype ThreadId# + {(In a non-concurrent implementation, this can be a singleton + type, whose (unique) value is returned by 'myThreadId#'. The + other operations can be omitted.)} + +primop ForkOp "fork#" GenPrimOp + (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + effect = ReadWriteEffect + out_of_line = True + strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd + , topDmd ] topDiv } + +primop ForkOnOp "forkOn#" GenPrimOp + Int# -> (State# RealWorld -> (# State# RealWorld, a_reppoly #)) + -> State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + effect = ReadWriteEffect + out_of_line = True + strictness = { \ _arity -> mkClosedDmdSig [ topDmd + , lazyApply1Dmd + , topDmd ] topDiv } + +primop KillThreadOp "killThread#" GenPrimOp + ThreadId# -> a -> State# RealWorld -> State# RealWorld + with + effect = ReadWriteEffect + out_of_line = True + +primop YieldOp "yield#" GenPrimOp + State# RealWorld -> State# RealWorld + with + effect = ReadWriteEffect + out_of_line = True + +primop MyThreadIdOp "myThreadId#" GenPrimOp + State# RealWorld -> (# State# RealWorld, ThreadId# #) + with + effect = ReadWriteEffect + +primop LabelThreadOp "labelThread#" GenPrimOp + ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld + {Set the label of the given thread. The @ByteArray#@ should contain + a UTF-8-encoded string.} + with + effect = ReadWriteEffect + out_of_line = True + +primop IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Int# #) + with + out_of_line = True + effect = ReadWriteEffect + +primop NoDuplicateOp "noDuplicate#" GenPrimOp + State# s -> State# s + with + out_of_line = True + effect = ReadWriteEffect + +primop GetThreadLabelOp "threadLabel#" GenPrimOp + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, ByteArray# #) + {Get the label of the given thread. + Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag + denoting @Just@. + + @since 0.10} + with + out_of_line = True + +primop ThreadStatusOp "threadStatus#" GenPrimOp + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #) + {Get the status of the given thread. Result is + @(ThreadStatus, Capability, Locked)@ where + @ThreadStatus@ is one of the status constants defined in + @rts/Constants.h@, @Capability@ is the number of + the capability which currently owns the thread, and + @Locked@ is a boolean indicating whether the + thread is bound to that capability. + + @since 0.9} + with + out_of_line = True + effect = ReadWriteEffect + +primop ListThreadsOp "listThreads#" GenPrimOp + State# RealWorld -> (# State# RealWorld, Array# ThreadId# #) + { Returns an array of the threads started by the program. Note that this + threads which have finished execution may or may not be present in this + list, depending upon whether they have been collected by the garbage collector. + + @since 0.10} + with + out_of_line = True + effect = ReadWriteEffect + +------------------------------------------------------------------------ +section "Weak pointers" +------------------------------------------------------------------------ + +primtype Weak# b + +primop MkWeakOp "mkWeak#" GenPrimOp + a_levpoly -> b_levpoly -> (State# RealWorld -> (# State# RealWorld, c #)) + -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #) + { @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@, + with an associated reference to some value @v@. If @k@ is still + alive then @v@ can be retrieved using 'deRefWeak#'. Note that + the type of @k@ must be represented by a pointer (i.e. of kind + @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). } + with + effect = ReadWriteEffect + out_of_line = True + +primop MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp + a_levpoly -> b_levpoly -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp + Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly + -> State# RealWorld -> (# State# RealWorld, Int# #) + { @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C + function pointer @fptr@ to a weak pointer @w@ as a finalizer. If + @flag@ is zero, @fptr@ will be called with one argument, + @ptr@. Otherwise, it will be called with two arguments, + @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns + 1 on success, or 0 if @w@ is already dead. } + with + effect = ReadWriteEffect + out_of_line = True + +primop DeRefWeakOp "deRefWeak#" GenPrimOp + Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#, a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop FinalizeWeakOp "finalizeWeak#" GenPrimOp + Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#, + (State# RealWorld -> (# State# RealWorld, b #) ) #) + { Finalize a weak pointer. The return value is an unboxed tuple + containing the new state of the world and an "unboxed Maybe", + represented by an 'Int#' and a (possibly invalid) finalization + action. An 'Int#' of @1@ indicates that the finalizer is valid. The + return value @b@ from the finalizer should be ignored. } + with + effect = ReadWriteEffect + out_of_line = True + +primop TouchOp "touch#" GenPrimOp + a_levpoly -> State# s -> State# s + with + code_size = 0 + effect = ReadWriteEffect -- see Note [touch# has ReadWriteEffect] + work_free = False + + +-- Note [touch# has ReadWriteEffect] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Although touch# emits no code, it is marked as ReadWriteEffect to +-- prevent it from being defeated by the optimizer: +-- * Discarding a touch# call would defeat its whole purpose. +-- * Strictly floating a touch# call out would shorten the lifetime +-- of the touched object, again defeating its purpose. +-- * Duplicating a touch# call might unpredictably extend the lifetime +-- of the touched object. Although this would not defeat the purpose +-- of touch#, it seems undesirable. +-- +-- In practice, this designation probably doesn't matter in most cases, +-- as touch# is usually tightly coupled with a "real" read or write effect. + +------------------------------------------------------------------------ +section "Stable pointers and names" +------------------------------------------------------------------------ + +primtype StablePtr# a + +primtype StableName# a + +primop MakeStablePtrOp "makeStablePtr#" GenPrimOp + a_levpoly -> State# RealWorld -> (# State# RealWorld, StablePtr# a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp + StablePtr# a_levpoly -> State# RealWorld -> (# State# RealWorld, a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop EqStablePtrOp "eqStablePtr#" GenPrimOp + StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int# + with + effect = ReadWriteEffect + +primop MakeStableNameOp "makeStableName#" GenPrimOp + a_levpoly -> State# RealWorld -> (# State# RealWorld, StableName# a_levpoly #) + with + effect = ReadWriteEffect + out_of_line = True + +primop StableNameToIntOp "stableNameToInt#" GenPrimOp + StableName# a_levpoly -> Int# + +------------------------------------------------------------------------ +section "Compact normal form" + + {Primitives for working with compact regions. The @ghc-compact@ + library and the @compact@ library demonstrate how to use these + primitives. The documentation below draws a distinction between + a CNF and a compact block. A CNF contains one or more compact + blocks. The source file @rts\/sm\/CNF.c@ + diagrams this relationship. When discussing a compact + block, an additional distinction is drawn between capacity and + utilized bytes. The capacity is the maximum number of bytes that + the compact block can hold. The utilized bytes is the number of + bytes that are actually used by the compact block. + } + +------------------------------------------------------------------------ + +primtype Compact# + +primop CompactNewOp "compactNew#" GenPrimOp + Word# -> State# RealWorld -> (# State# RealWorld, Compact# #) + { Create a new CNF with a single compact block. The argument is + the capacity of the compact block (in bytes, not words). + The capacity is rounded up to a multiple of the allocator block size + and is capped to one mega block. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactResizeOp "compactResize#" GenPrimOp + Compact# -> Word# -> State# RealWorld -> + State# RealWorld + { Set the new allocation size of the CNF. This value (in bytes) + determines the capacity of each compact block in the CNF. It + does not retroactively affect existing compact blocks in the CNF. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactContainsOp "compactContains#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #) + { Returns 1\# if the object is contained in the CNF, 0\# otherwise. } + with + out_of_line = True + +primop CompactContainsAnyOp "compactContainsAny#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, Int# #) + { Returns 1\# if the object is in any CNF at all, 0\# otherwise. } + with + out_of_line = True + +primop CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp + Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) + { Returns the address and the utilized size (in bytes) of the + first compact block of a CNF.} + with + out_of_line = True + +primop CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp + Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #) + { Given a CNF and the address of one its compact blocks, returns the + next compact block and its utilized size, or 'nullAddr#' if the + argument was the last compact block in the CNF. } + with + out_of_line = True + +primop CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp + Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #) + { Attempt to allocate a compact block with the capacity (in + bytes) given by the first argument. The 'Addr#' is a pointer + to previous compact block of the CNF or 'nullAddr#' to create a + new CNF with a single compact block. + + The resulting block is not known to the GC until + 'compactFixupPointers#' is called on it, and care must be taken + so that the address does not escape or memory will be leaked. + } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactFixupPointersOp "compactFixupPointers#" GenPrimOp + Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #) + { Given the pointer to the first block of a CNF and the + address of the root object in the old address space, fix up + the internal pointers inside the CNF to account for + a different position in memory than when it was serialized. + This method must be called exactly once after importing + a serialized CNF. It returns the new CNF and the new adjusted + root address. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactAdd "compactAdd#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) + { Recursively add a closure and its transitive closure to a + 'Compact#' (a CNF), evaluating any unevaluated components + at the same time. Note: 'compactAdd#' is not thread-safe, so + only one thread may call 'compactAdd#' with a particular + 'Compact#' at any given time. The primop does not + enforce any mutual exclusion; the caller is expected to + arrange this. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp + Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) + { Like 'compactAdd#', but retains sharing and cycles + during compaction. } + with + effect = ReadWriteEffect + out_of_line = True + +primop CompactSize "compactSize#" GenPrimOp + Compact# -> State# RealWorld -> (# State# RealWorld, Word# #) + { Return the total capacity (in bytes) of all the compact blocks + in the CNF. } + with + effect = ReadWriteEffect + out_of_line = True + +------------------------------------------------------------------------ +section "Unsafe pointer equality" +-- (#1 Bad Guy: Alastair Reid :) +------------------------------------------------------------------------ + +primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp + a_levpoly -> b_levpoly -> Int# + { Returns @1#@ if the given pointers are equal and @0#@ otherwise. } + with + effect = CanFail -- See Note [reallyUnsafePtrEquality# CanFail] + can_fail_warning = DoNotWarnCanFail + +-- Note [Pointer comparison operations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The primop `reallyUnsafePtrEquality#` does a direct pointer +-- equality between two (boxed) values. Several things to note: +-- +-- (PE1) It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and +-- TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example. +-- This levity-polymorphism comes from the use of the type variables +-- "a_levpoly" and "b_levpoly". See Note [Levity and representation polymorphic primops] +-- +-- (PE2) It is hetero-typed; you can compare pointers of different types. +-- This is used in various packages such as containers & unordered-containers. +-- +-- (PE3) It does not evaluate its arguments. The user of the primop is responsible +-- for doing so. Consider +-- let { x = p+q; y = q+p } in reallyUnsafePtrEquality# x y +-- Here `x` and `y` point to different closures, so the expression will +-- probably return False; but if `x` and/or `y` were evaluated for some +-- other reason, then it might return True. +-- +-- (PE4) It is obviously very dangerous, because replacing equals with equals +-- in the program can change the result. For example +-- let x = f y in reallyUnsafePtrEquality# x x +-- will probably return True, whereas +-- reallyUnsafePtrEquality# (f y) (f y) +-- will probably return False. ("probably", because it's affected +-- by CSE and inlining). +-- +-- (PE5) reallyUnsafePtrEquality# can't fail, but it is marked as such +-- to prevent it from floating out. +-- See Note [reallyUnsafePtrEquality# CanFail] +-- +-- The library GHC.Prim.PtrEq (and GHC.Exts) provides +-- +-- unsafePtrEquality# :: +-- forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int# +-- +-- It is still heterotyped (like (PE2)), but it's restricted to unlifted types +-- (unlike (PE1)). That means that (PE3) doesn't apply: unlifted types are +-- always evaluated, which makes it a bit less unsafe. +-- +-- However unsafePtrEquality# is /implemented/ by a call to +-- reallyUnsafePtrEquality#, so using the former is really just a documentation +-- hint to the reader of the code. GHC behaves no differently. +-- +-- The same library provides less Wild-West functions +-- for use in specific cases, namely: +-- +-- reallyUnsafePtrEquality :: a -> a -> Int# -- not levity-polymorphic, nor hetero-typed +-- sameArray# :: Array# a -> Array# a -> Int# +-- sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int# +-- sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int# +-- sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int# +-- sameByteArray# :: ByteArray# -> ByteArray# -> Int# +-- sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int# +-- sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int# +-- sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int# +-- sameMutVar# :: MutVar# s a -> MutVar# s a -> Int# +-- sameTVar# :: TVar# s a -> TVar# s a -> Int# +-- sameMVar# :: MVar# s a -> MVar# s a -> Int# +-- eqStableName# :: StableName# a -> StableName# b -> Int# +-- +-- These operations are all specialisations of unsafePtrEquality#. + +-- Note [reallyUnsafePtrEquality# CanFail] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it +-- CanFail anyway. Until 5a9a1738023a, GHC considered primops okay for +-- speculation only when their arguments were known to be forced. This was +-- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from +-- floating out of places where its arguments were known to be forced. +-- Unfortunately, GHC could sometimes lose track of whether those arguments +-- were forced, leading to let-can-float invariant failures (see #13027 and the +-- discussion in #11444). Now that ok_for_speculation skips over lifted +-- arguments, we need to explicitly prevent reallyUnsafePtrEquality# +-- from floating out. Imagine if we had +-- +-- \x y . case x of x' +-- DEFAULT -> +-- case y of y' +-- DEFAULT -> +-- let eq = reallyUnsafePtrEquality# x' y' +-- in ... +-- +-- If the let floats out, we'll get +-- +-- \x y . let eq = reallyUnsafePtrEquality# x y +-- in case x of ... +-- +-- The trouble is that pointer equality between thunks is very different +-- from pointer equality between the values those thunks reduce to, and the latter +-- is typically much more precise. + +------------------------------------------------------------------------ +section "Parallelism" +------------------------------------------------------------------------ + +primop ParOp "par#" GenPrimOp a -> Int# + {Create a new spark evaluating the given argument. + The return value should always be 1. + Users are encouraged to use spark# instead.} + with + -- Note that Par is lazy to avoid that the sparked thing + -- gets evaluated strictly, which it should *not* be + effect = ReadWriteEffect + code_size = { primOpCodeSizeForeignCall } + -- `par#` was suppose to be deprecated in favor of `spark#` [1], however it + -- wasn't clear how to replace it with `spark#` [2] and `par#` is still used + -- to implement `GHC.Internal.Conc.Sync.par`. So we undeprecated it until + -- everything is sorted out (see #24825). + -- + -- [1] https://gitlab.haskell.org/ghc/ghc/-/issues/15227#note_154293 + -- [2] https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5548#note_347791 + -- + -- deprecated_msg = { Use 'spark#' instead } + +primop SparkOp "spark#" GenPrimOp + a -> State# s -> (# State# s, a #) + with effect = ReadWriteEffect + code_size = { primOpCodeSizeForeignCall } + +primop GetSparkOp "getSpark#" GenPrimOp + State# s -> (# State# s, Int#, a #) + with + effect = ReadWriteEffect + out_of_line = True + +primop NumSparks "numSparks#" GenPrimOp + State# s -> (# State# s, Int# #) + { Returns the number of sparks in the local spark pool. } + with + effect = ReadWriteEffect + out_of_line = True + + + +------------------------------------------------------------------------ +section "Controlling object lifetime" + {Ensuring that objects don't die a premature death.} +------------------------------------------------------------------------ + +-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep. +primop KeepAliveOp "keepAlive#" GenPrimOp + a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly + { @'keepAlive#' x s k@ keeps the value @x@ alive during the execution + of the computation @k@. + + Note that the result type here isn't quite as unrestricted as the + polymorphic type might suggest; see the section \"RuntimeRep polymorphism + in continuation-style primops\" for details. } + with + out_of_line = True + strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } + -- See Note [Strict IO wrappers] + effect = ReadWriteEffect + -- The invoked computation may have side effects + + +------------------------------------------------------------------------ +section "Tag to enum stuff" + {Convert back and forth between values of enumerated types + and small integers.} +------------------------------------------------------------------------ + +primop DataToTagSmallOp "dataToTagSmall#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one normally offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop DataToTagLargeOp "dataToTagLarge#" GenPrimOp + a_levpoly -> Int# + { Used internally to implement @dataToTag#@: Use that function instead! + This one offers /no advantage/ and comes with no stability + guarantees: it may change its type, its name, or its behavior + with /no warning/ between compiler releases. + + It is expected that this function will be un-exposed in a future + release of ghc. + + For more details, look at @Note [DataToTag overview]@ + in GHC.Tc.Instance.Class in the source code for + /the specific compiler version you are using./ + } + with + deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. } + strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv } + effect = ThrowsException + cheap = True + +primop TagToEnumOp "tagToEnum#" GenPrimOp + Int# -> a + with + effect = CanFail + +------------------------------------------------------------------------ +section "Bytecode operations" + {Support for manipulating bytecode objects used by the interpreter and + linker. + + Bytecode objects are heap objects which represent top-level bindings and + contain a list of instructions and data needed by these instructions.} +------------------------------------------------------------------------ + +primtype BCO + { Primitive bytecode type. } + +primop AddrToAnyOp "addrToAny#" GenPrimOp + Addr# -> (# a_levpoly #) + { Convert an 'Addr#' to a followable Any type. } + with + code_size = 0 + +primop AnyToAddrOp "anyToAddr#" GenPrimOp + a -> State# RealWorld -> (# State# RealWorld, Addr# #) + { Retrieve the address of any Haskell value. This is + essentially an 'unsafeCoerce#', but if implemented as such + the core lint pass complains and fails to compile. + As a primop, it is opaque to core/stg, and only appears + in cmm (where the copy propagation pass will get rid of it). + Note that "a" must be a value, not a thunk! It's too late + for strictness analysis to enforce this, so you're on your + own to guarantee this. Also note that 'Addr#' is not a GC + pointer - up to you to guarantee that it does not become + a dangling pointer immediately after you get it.} + with + code_size = 0 + +primop MkApUpd0_Op "mkApUpd0#" GenPrimOp + BCO -> (# a #) + { Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of + the BCO when evaluated. } + with + out_of_line = True + +primop NewBCOOp "newBCO#" GenPrimOp + ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #) + { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The + resulting object encodes a function of the given arity with the instructions + encoded in @instrs@, and a static reference table usage bitmap given by + @bitmap@. } + with + effect = ReadWriteEffect + out_of_line = True + +primop UnpackClosureOp "unpackClosure#" GenPrimOp + a -> (# Addr#, ByteArray#, Array# b #) + { @'unpackClosure#' closure@ copies the closure and pointers in the + payload of the given closure into two new arrays, and returns a pointer to + the first word of the closure's info table, a non-pointer array for the raw + bytes of the closure, and a pointer array for the pointers in the payload. } + with + out_of_line = True + +primop ClosureSizeOp "closureSize#" GenPrimOp + a -> Int# + { @'closureSize#' closure@ returns the size of the given closure in + machine words. } + with + out_of_line = True + +primop GetApStackValOp "getApStackVal#" GenPrimOp + a -> Int# -> (# Int#, b #) + with + out_of_line = True + +------------------------------------------------------------------------ +section "Misc" + {These aren't nearly as wired in as Etc...} +------------------------------------------------------------------------ + +primop GetCCSOfOp "getCCSOf#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + +primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp + a -> State# s -> (# State# s, Addr# #) + { Returns the current 'CostCentreStack' (value is @NULL@ if + not profiling). Takes a dummy argument which can be used to + avoid the call to 'getCurrentCCS#' being floated out by the + simplifier, which would result in an uninformative stack + ("CAF"). } + +primop ClearCCSOp "clearCCS#" GenPrimOp + (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #) + { Run the supplied IO action with an empty CCS. For example, this + is used by the interpreter to run an interpreted computation + without the call stack showing that it was invoked from GHC. } + with + out_of_line = True + +------------------------------------------------------------------------ +section "Annotating call stacks" +------------------------------------------------------------------------ + +primop AnnotateStackOp "annotateStack#" GenPrimOp + b -> (State# s -> (# State# s, a_reppoly #)) -> State# s -> (# State# s, a_reppoly #) + { Pushes an annotation frame to the stack which can be reported by backtraces. } + with + out_of_line = True + +------------------------------------------------------------------------ +section "Info Table Origin" +------------------------------------------------------------------------ +primop WhereFromOp "whereFrom#" GenPrimOp + a -> Addr# -> State# s -> (# State# s, Int# #) + { Fills the given buffer with the @InfoProvEnt@ for the info table of the + given object. Returns @1#@ on success and @0#@ otherwise.} + with + out_of_line = True + +------------------------------------------------------------------------ +section "Etc" + {Miscellaneous built-ins} +------------------------------------------------------------------------ + +primtype FUN m a b + {The builtin function type, written in infix form as @a % m -> b@. + Values of this type are functions taking inputs of type @a@ and + producing outputs of type @b@. The multiplicity of the input is + @m@. + + Note that @'FUN' m a b@ permits representation polymorphism in both + @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be + well-kinded. + } + +pseudoop "realWorld#" + State# RealWorld + { The token used in the implementation of the IO monad as a state monad. + It does not pass any information at runtime. + See also 'GHC.Magic.runRW#'. } + +pseudoop "void#" + (# #) + { This is an alias for the unboxed unit tuple constructor. + In earlier versions of GHC, 'void#' was a value + of the primitive type 'Void#', which is now defined to be @(# #)@. + } + with deprecated_msg = { Use an unboxed unit tuple instead } + +primtype Proxy# a + { The type constructor 'Proxy#' is used to bear witness to some + type variable. It's used when you want to pass around proxy values + for doing things like modelling type applications. A 'Proxy#' + is not only unboxed, it also has a polymorphic kind, and has no + runtime representation, being totally free. } + +pseudoop "proxy#" + Proxy# a + { Witness for an unboxed 'Proxy#' value, which has no runtime + representation. } + +pseudoop "seq" + a -> b_reppoly -> b_reppoly + { The value of @'seq' a b@ is bottom if @a@ is bottom, and + otherwise equal to @b@. In other words, it evaluates the first + argument @a@ to weak head normal form (WHNF). 'seq' is usually + introduced to improve performance by avoiding unneeded laziness. + + A note on evaluation order: the expression @'seq' a b@ does + /not/ guarantee that @a@ will be evaluated before @b@. + The only guarantee given by 'seq' is that the both @a@ + and @b@ will be evaluated before 'seq' returns a value. + In particular, this means that @b@ may be evaluated before + @a@. If you need to guarantee a specific order of evaluation, + you must use the function 'pseq' from the "parallel" package. } + with fixity = infixr 0 + -- This fixity is only the one picked up by Haddock. If you + -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'. + +primop TraceEventOp "traceEvent#" GenPrimOp + Addr# -> State# s -> State# s + { Emits an event via the RTS tracing framework. The contents + of the event is the zero-terminated byte string passed as the first + argument. The event will be emitted either to the @.eventlog@ file, + or to stderr, depending on the runtime RTS flags. } + with + effect = ReadWriteEffect + out_of_line = True + +primop TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + { Emits an event via the RTS tracing framework. The contents + of the event is the binary object passed as the first argument with + the given length passed as the second argument. The event will be + emitted to the @.eventlog@ file. } + with + effect = ReadWriteEffect + out_of_line = True + +primop TraceMarkerOp "traceMarker#" GenPrimOp + Addr# -> State# s -> State# s + { Emits a marker event via the RTS tracing framework. The contents + of the event is the zero-terminated byte string passed as the first + argument. The event will be emitted either to the @.eventlog@ file, + or to stderr, depending on the runtime RTS flags. } + with + effect = ReadWriteEffect + out_of_line = True + +primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp + Int64# -> State# RealWorld -> State# RealWorld + { Sets the allocation counter for the current thread to the given value. } + with + effect = ReadWriteEffect + out_of_line = True + +primop SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp + Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld + { Sets the allocation counter for the another thread to the given value. + This doesn't take allocations into the current nursery chunk into account. + Therefore it is only accurate if the other thread is not currently running. } + with + effect = ReadWriteEffect + out_of_line = True + +primtype StackSnapshot# + { Haskell representation of a @StgStack*@ that was created (cloned) + with a function in "GHC.Stack.CloneStack". Please check the + documentation in that module for more detailed explanations. } + +------------------------------------------------------------------------ +section "Safe coercions" +------------------------------------------------------------------------ + +pseudoop "coerce" + Coercible a b => a -> b + { The function 'coerce' allows you to safely convert between values of + types that have the same representation with no run-time overhead. In the + simplest case you can use it instead of a newtype constructor, to go from + the newtype's concrete type to the abstract type. But it also works in + more complicated settings, e.g. converting a list of newtypes to a list of + concrete types. + + When used in conversions involving a newtype wrapper, + make sure the newtype constructor is in scope. + + This function is representation-polymorphic, but the + 'RuntimeRep' type argument is marked as 'Inferred', meaning + that it is not available for visible type application. This means + the typechecker will accept @'coerce' \@'Int' \@Age 42@. + + === __Examples__ + + >>> newtype TTL = TTL Int deriving (Eq, Ord, Show) + >>> newtype Age = Age Int deriving (Eq, Ord, Show) + >>> coerce (Age 42) :: TTL + TTL 42 + >>> coerce (+ (1 :: Int)) (Age 42) :: TTL + TTL 43 + >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL] + [TTL 43,TTL 25] + + } + +------------------------------------------------------------------------ +section "SIMD Vectors" + {Operations on SIMD vectors.} +------------------------------------------------------------------------ + +#define ALL_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,, \ + ,, \ + ,,] + +#define SIGNED_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,, \ + ,, \ + ,,] + +#define FLOAT_VECTOR_TYPES \ + [, \ + ,, \ + ,,] + +#define INT_VECTOR_TYPES \ + [,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,, \ + ,,,,] + +primtype VECTOR + with vector = ALL_VECTOR_TYPES + +primop VecBroadcastOp "broadcast#" GenPrimOp + SCALAR -> VECTOR + { Broadcast a scalar to all elements of a vector. } + with vector = ALL_VECTOR_TYPES + +primop VecPackOp "pack#" GenPrimOp + VECTUPLE -> VECTOR + { Pack the elements of an unboxed tuple into a vector. } + with vector = ALL_VECTOR_TYPES + +primop VecUnpackOp "unpack#" GenPrimOp + VECTOR -> VECTUPLE + { Unpack the elements of a vector into an unboxed tuple. } + with vector = ALL_VECTOR_TYPES + +primop VecInsertOp "insert#" GenPrimOp + VECTOR -> SCALAR -> Int# -> VECTOR + { Insert a scalar at the given position in a vector. + The position must be a compile-time constant. } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecAddOp "plus#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Add two vectors element-wise. } + with commutable = True + vector = ALL_VECTOR_TYPES + +primop VecSubOp "minus#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Subtract two vectors element-wise. } + with vector = ALL_VECTOR_TYPES + +primop VecMulOp "times#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Multiply two vectors element-wise. } + with commutable = True + vector = ALL_VECTOR_TYPES + +primop VecDivOp "divide#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Divide two vectors element-wise. } + with effect = CanFail + vector = FLOAT_VECTOR_TYPES + +primop VecQuotOp "quot#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Rounds towards zero element-wise. + + Note: Most CPU ISAs do not contain any SIMD integer division instructions. + Do not expect high performance. } + with effect = CanFail + vector = INT_VECTOR_TYPES + div_like = True + +primop VecRemOp "rem#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. + + Note: Most CPU ISAs do not contain any SIMD integer division instructions. + Do not expect high performance. } + with effect = CanFail + vector = INT_VECTOR_TYPES + div_like = True + + +primop VecNegOp "negate#" GenPrimOp + VECTOR -> VECTOR + { Negate element-wise. } + with vector = SIGNED_VECTOR_TYPES + +primop VecIndexByteArrayOp "indexArray#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from the specified index of an immutable array. + The index is counted in units of SIMD vectors (not scalar elements). } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadByteArrayOp "readArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from the specified index of a mutable array. + The index is counted in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteByteArrayOp "writeArray#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to the specified index of a mutable array. + The index is counted in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in units of SIMD vectors (not scalar elements). } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadOffAddrOp "readOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in units of SIMD vectors (not scalar elements). } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + + +primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in scalar elements. } + with effect = CanFail + vector = ALL_VECTOR_TYPES + +primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in scalar elements. } + with effect = ReadWriteEffect + can_fail_warning = YesWarnCanFail + vector = ALL_VECTOR_TYPES + +primop VecFMAdd "fmadd#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES +primop VecFMSub "fmsub#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES +primop VecFNMAdd "fnmadd#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES +primop VecFNMSub "fnmsub#" GenPrimOp + VECTOR -> VECTOR -> VECTOR -> VECTOR + {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".} + with + vector = FLOAT_VECTOR_TYPES + +primop VecShuffleOp "shuffle#" GenPrimOp + VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR + {Shuffle elements of the concatenation of the input two vectors + into the result vector. The indices must be compile-time constants.} + with vector = ALL_VECTOR_TYPES + +primop VecMinOp "min#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + {Component-wise minimum of two vectors.} + with + vector = ALL_VECTOR_TYPES + +primop VecMaxOp "max#" GenPrimOp + VECTOR -> VECTOR -> VECTOR + {Component-wise maximum of two vectors.} + with + vector = ALL_VECTOR_TYPES + +------------------------------------------------------------------------ + +section "Prefetch" + {Prefetch operations: Note how every prefetch operation has a name + with the pattern prefetch*N#, where N is either 0,1,2, or 3. + + This suffix number, N, is the "locality level" of the prefetch, following the + convention in GCC and other compilers. + Higher locality numbers correspond to the memory being loaded in more + levels of the cpu cache, and being retained after initial use. The naming + convention follows the naming convention of the prefetch intrinsic found + in the GCC and Clang C compilers. + + On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic + with locality level N. The code generated by LLVM is target architecture + dependent, but should agree with the GHC NCG on x86 systems. + + On the PPC native backend, prefetch*N is a No-Op. + + On the x86 NCG, N=0 will generate prefetchNTA, + N=1 generates prefetcht2, N=2 generates prefetcht1, and + N=3 generates prefetcht0. + + For streaming workloads, the prefetch*0 operations are recommended. + For workloads which do many reads or writes to a memory location in a short period of time, + prefetch*3 operations are recommended. + + For further reading about prefetch and associated systems performance optimization, + the instruction set and optimization manuals by Intel and other CPU vendors are + excellent starting place. + + + The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is + especially a helpful read, even if your software is meant for other CPU + architectures or vendor hardware. The manual can be found at + http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html . + + The @prefetch*@ family of operations has the order of operations + determined by passing around the 'State#' token. + + To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context. + + It is important to note that while the prefetch operations will never change the + answer to a pure computation, They CAN change the memory locations resident + in a CPU cache and that may change the performance and timing characteristics + of an application. The prefetch operations are marked as ReadWriteEffect + to reflect that these operations have side effects with respect to the runtime + performance characteristics of the resulting code. Additionally, if the prefetchValue + operations did not have this attribute, GHC does a float out transformation that + results in a let-can-float invariant violation, at least with the current design. + } + + + +------------------------------------------------------------------------ + + +--- the Int# argument for prefetch is the byte offset on the byteArray or Addr# + +--- +primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect +---- + +primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect +---- + +primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect +---- + +primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp + ByteArray# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp + Addr# -> Int# -> State# s -> State# s + with effect = ReadWriteEffect + +primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp + a -> State# s -> State# s + with effect = ReadWriteEffect -- Note [RuntimeRep polymorphism in continuation-style primops] diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs --- a/GHC/ByteCode/Asm.hs +++ b/GHC/ByteCode/Asm.hs @@ -1,721 +1,1044 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --- --- (c) The University of Glasgow 2002-2006 --- - --- | Bytecode assembler and linker -module GHC.ByteCode.Asm ( - assembleBCOs, assembleOneBCO, - bcoFreeNames, - SizedSeq, sizeSS, ssElts, - iNTERP_STACK_CHECK_THRESH, - mkNativeCallInfoLit - ) where - -import GHC.Prelude - -import GHC.ByteCode.Instr -import GHC.ByteCode.InfoTable -import GHC.ByteCode.Types -import GHCi.RemoteTypes -import GHC.Runtime.Interpreter -import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord ) - -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Literal -import GHC.Types.Unique.DSet - -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import GHC.Core.TyCon -import GHC.Data.FastString -import GHC.Data.SizedSeq - -import GHC.StgToCmm.Layout ( ArgRep(..) ) -import GHC.Cmm.Expr -import GHC.Cmm.CallConv ( allArgRegsCover ) -import GHC.Platform -import GHC.Platform.Profile - -import Control.Monad -import Control.Monad.ST ( runST ) -import Control.Monad.Trans.Class -import Control.Monad.Trans.State.Strict - -import Data.Array.MArray - -import qualified Data.Array.Unboxed as Array -import Data.Array.Base ( UArray(..) ) - -import Data.Array.Unsafe( castSTUArray ) - -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 - --- ----------------------------------------------------------------------------- --- Unlinked BCOs - --- CompiledByteCode represents the result of byte-code --- compiling a bunch of functions and data types - --- | Finds external references. Remember to remove the names --- defined by this group of BCOs themselves -bcoFreeNames :: UnlinkedBCO -> UniqDSet Name -bcoFreeNames bco - = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] - where - bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) - = unionManyUniqDSets ( - mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] : - mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] : - map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ] - ) - --- ----------------------------------------------------------------------------- --- The bytecode assembler - --- The object format for bytecodes is: 16 bits for the opcode, and 16 --- for each field -- so the code can be considered a sequence of --- 16-bit ints. Each field denotes either a stack offset or number of --- items on the stack (eg SLIDE), and index into the pointer table (eg --- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a --- bytecode address in this BCO. - --- Top level assembler fn. -assembleBCOs - :: Interp - -> Profile - -> [ProtoBCO Name] - -> [TyCon] - -> AddrEnv - -> Maybe ModBreaks - -> IO CompiledByteCode -assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do - -- TODO: the profile should be bundled with the interpreter: the rts ways are - -- fixed for an interpreter - itblenv <- mkITbls interp profile tycons - bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos - bcos' <- mallocStrings interp bcos - return CompiledByteCode - { bc_bcos = bcos' - , bc_itbls = itblenv - , bc_ffis = concatMap protoBCOFFIs proto_bcos - , bc_strs = top_strs - , bc_breaks = modbreaks - } - --- Note [Allocating string literals] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Our strategy for handling top-level string literal bindings is described in --- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode, --- but not all Addr# literals in a program are guaranteed to be lifted to the --- top level. Our strategy for handling local Addr# literals is somewhat simpler: --- after assembling, we find all the BCONPtrStr arguments in the program, malloc --- memory for them, and bake the resulting addresses into the instruction stream --- in the form of BCONPtrWord arguments. --- --- Since we do this when assembling, we only allocate the memory when we compile --- the module, not each time we relink it. However, we do want to take care to --- malloc the memory all in one go, since that is more efficient with --- -fexternal-interpreter, especially when compiling in parallel. --- --- Note that, as with top-level string literal bindings, this memory is never --- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for --- top-level string literal bindings] in GHC.StgToByteCode for some discussion --- about why. --- -mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO] -mallocStrings interp ulbcos = do - let bytestrings = reverse (execState (mapM_ collect ulbcos) []) - ptrs <- interpCmd interp (MallocStrings bytestrings) - return (evalState (mapM splice ulbcos) ptrs) - where - splice bco@UnlinkedBCO{..} = do - lits <- mapM spliceLit unlinkedBCOLits - ptrs <- mapM splicePtr unlinkedBCOPtrs - return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs } - - spliceLit (BCONPtrStr _) = do - rptrs <- get - case rptrs of - (RemotePtr p : rest) -> do - put rest - return (BCONPtrWord (fromIntegral p)) - _ -> panic "mallocStrings:spliceLit" - spliceLit other = return other - - splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco - splicePtr other = return other - - collect UnlinkedBCO{..} = do - mapM_ collectLit unlinkedBCOLits - mapM_ collectPtr unlinkedBCOPtrs - - collectLit (BCONPtrStr bs) = do - strs <- get - put (bs:strs) - collectLit _ = return () - - collectPtr (BCOPtrBCO bco) = collect bco - collectPtr _ = return () - - -assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO -assembleOneBCO interp profile pbco = do - -- TODO: the profile should be bundled with the interpreter: the rts ways are - -- fixed for an interpreter - ubco <- assembleBCO (profilePlatform profile) pbco - [ubco'] <- mallocStrings interp [ubco] - return ubco' - -assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO -assembleBCO platform (ProtoBCO { protoBCOName = nm - , protoBCOInstrs = instrs - , protoBCOBitmap = bitmap - , protoBCOBitmapSize = bsize - , protoBCOArity = arity }) = do - -- pass 1: collect up the offsets of the local labels. - let asm = mapM_ (assembleI platform) instrs - - initial_offset = 0 - - -- Jump instructions are variable-sized, there are long and short variants - -- depending on the magnitude of the offset. However, we can't tell what - -- size instructions we will need until we have calculated the offsets of - -- the labels, which depends on the size of the instructions... So we - -- first create the label environment assuming that all jumps are short, - -- and if the final size is indeed small enough for short jumps, we are - -- done. Otherwise, we repeat the calculation, and we force all jumps in - -- this BCO to be long. - (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm - ((n_insns, lbl_map), long_jumps) - | isLargeW (fromIntegral $ Map.size lbl_map0) - || isLargeW n_insns0 - = (inspectAsm platform True initial_offset asm, True) - | otherwise = ((n_insns0, lbl_map0), False) - - env :: LocalLabel -> Word - env lbl = fromMaybe - (pprPanic "assembleBCO.findLabel" (ppr lbl)) - (Map.lookup lbl lbl_map) - - -- pass 2: run assembler and generate instructions, literals and pointers - let initial_state = (emptySS, emptySS, emptySS) - (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm - - -- precomputed size should be equal to final size - massertPpr (n_insns == sizeSS final_insns) - (text "bytecode instruction count mismatch") - - let asm_insns = ssElts final_insns - insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns - bitmap_arr = mkBitmapArray bsize bitmap - ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs - - -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive - -- objects, since they might get run too early. Disable this until - -- we figure out what to do. - -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) - - return ul_bco - -mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64 --- Here the return type must be an array of Words, not StgWords, --- because the underlying ByteArray# will end up as a component --- of a BCO object. -mkBitmapArray bsize bitmap - = Array.listArray (0, length bitmap) $ - fromIntegral bsize : map (fromInteger . fromStgWord) bitmap - --- instrs nonptrs ptrs -type AsmState = (SizedSeq Word16, - SizedSeq BCONPtr, - SizedSeq BCOPtr) - -data Operand - = Op Word - | IOp Int - | SmallOp Word16 - | LabelOp LocalLabel - -wOp :: WordOff -> Operand -wOp = Op . fromIntegral - -bOp :: ByteOff -> Operand -bOp = Op . fromIntegral - -truncHalfWord :: Platform -> HalfWord -> Operand -truncHalfWord platform w = case platformWordSize platform of - PW4 | w <= 65535 -> Op (fromIntegral w) - PW8 | w <= 4294967295 -> Op (fromIntegral w) - _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w) - -data Assembler a - = AllocPtr (IO BCOPtr) (Word -> Assembler a) - | AllocLit [BCONPtr] (Word -> Assembler a) - | AllocLabel LocalLabel (Assembler a) - | Emit Word16 [Operand] (Assembler a) - | NullAsm a - deriving (Functor) - -instance Applicative Assembler where - pure = NullAsm - (<*>) = ap - -instance Monad Assembler where - NullAsm x >>= f = f x - AllocPtr p k >>= f = AllocPtr p (k >=> f) - AllocLit l k >>= f = AllocLit l (k >=> f) - AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) - Emit w ops k >>= f = Emit w ops (k >>= f) - -ioptr :: IO BCOPtr -> Assembler Word -ioptr p = AllocPtr p return - -ptr :: BCOPtr -> Assembler Word -ptr = ioptr . return - -lit :: [BCONPtr] -> Assembler Word -lit l = AllocLit l return - -label :: LocalLabel -> Assembler () -label w = AllocLabel w (return ()) - -emit :: Word16 -> [Operand] -> Assembler () -emit w ops = Emit w ops (return ()) - -type LabelEnv = LocalLabel -> Word - -largeOp :: Bool -> Operand -> Bool -largeOp long_jumps op = case op of - SmallOp _ -> False - Op w -> isLargeW w - IOp i -> isLargeI i - LabelOp _ -> long_jumps - -runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a -runAsm platform long_jumps e = go - where - go (NullAsm x) = return x - go (AllocPtr p_io k) = do - p <- lift p_io - w <- state $ \(st_i0,st_l0,st_p0) -> - let st_p1 = addToSS st_p0 p - in (sizeSS st_p0, (st_i0,st_l0,st_p1)) - go $ k w - go (AllocLit lits k) = do - w <- state $ \(st_i0,st_l0,st_p0) -> - let st_l1 = addListToSS st_l0 lits - in (sizeSS st_l0, (st_i0,st_l1,st_p0)) - go $ k w - go (AllocLabel _ k) = go k - go (Emit w ops k) = do - let largeArgs = any (largeOp long_jumps) ops - opcode - | largeArgs = largeArgInstr w - | otherwise = w - words = concatMap expand ops - expand (SmallOp w) = [w] - expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeArgs then largeArg platform (fromIntegral w) else [fromIntegral w] - expand (IOp i) = if largeArgs then largeArg platform (fromIntegral i) else [fromIntegral i] - state $ \(st_i0,st_l0,st_p0) -> - let st_i1 = addListToSS st_i0 (opcode : words) - in ((), (st_i1,st_l0,st_p0)) - go k - -type LabelEnvMap = Map LocalLabel Word - -data InspectState = InspectState - { instrCount :: !Word - , ptrCount :: !Word - , litCount :: !Word - , lblEnv :: LabelEnvMap - } - -inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap) -inspectAsm platform long_jumps initial_offset - = go (InspectState initial_offset 0 0 Map.empty) - where - go s (NullAsm _) = (instrCount s, lblEnv s) - go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) - where n = ptrCount s - go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) - where n = litCount s - go s (AllocLabel lbl k) = go s' k - where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } - go s (Emit _ ops k) = go s' k - where - s' = s { instrCount = instrCount s + size } - size = sum (map count ops) + 1 - largeOps = any (largeOp long_jumps) ops - count (SmallOp _) = 1 - count (LabelOp _) = count (Op 0) - count (Op _) = if largeOps then largeArg16s platform else 1 - count (IOp _) = if largeOps then largeArg16s platform else 1 - --- Bring in all the bci_ bytecode constants. -#include "Bytecodes.h" - -largeArgInstr :: Word16 -> Word16 -largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci - -largeArg :: Platform -> Word64 -> [Word16] -largeArg platform w = case platformWordSize platform of - PW8 -> [fromIntegral (w `shiftR` 48), - fromIntegral (w `shiftR` 32), - fromIntegral (w `shiftR` 16), - fromIntegral w] - PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32)) - (text "largeArg too big:" <+> ppr w) $ - [fromIntegral (w `shiftR` 16), - fromIntegral w] - -largeArg16s :: Platform -> Word -largeArg16s platform = case platformWordSize platform of - PW8 -> 4 - PW4 -> 2 - -assembleI :: Platform - -> BCInstr - -> Assembler () -assembleI platform i = case i of - STKCHECK n -> emit bci_STKCHECK [Op n] - PUSH_L o1 -> emit bci_PUSH_L [wOp o1] - PUSH_LL o1 o2 -> emit bci_PUSH_LL [wOp o1, wOp o2] - PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [wOp o1, wOp o2, wOp o3] - PUSH8 o1 -> emit bci_PUSH8 [bOp o1] - PUSH16 o1 -> emit bci_PUSH16 [bOp o1] - PUSH32 o1 -> emit bci_PUSH32 [bOp o1] - PUSH8_W o1 -> emit bci_PUSH8_W [bOp o1] - PUSH16_W o1 -> emit bci_PUSH16_W [bOp o1] - PUSH32_W o1 -> emit bci_PUSH32_W [bOp o1] - PUSH_G nm -> do p <- ptr (BCOPtrName nm) - emit bci_PUSH_G [Op p] - PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) - emit bci_PUSH_G [Op p] - PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit bci_PUSH_G [Op p] - PUSH_ALTS proto pk - -> do let ul_bco = assembleBCO platform proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - emit (push_alts pk) [Op p] - PUSH_ALTS_TUPLE proto call_info tuple_proto - -> do let ul_bco = assembleBCO platform proto - ul_tuple_bco = assembleBCO platform - tuple_proto - p <- ioptr (liftM BCOPtrBCO ul_bco) - p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco) - info <- int (fromIntegral $ - mkNativeCallInfoSig platform call_info) - emit bci_PUSH_ALTS_T - [Op p, Op info, Op p_tup] - PUSH_PAD8 -> emit bci_PUSH_PAD8 [] - PUSH_PAD16 -> emit bci_PUSH_PAD16 [] - PUSH_PAD32 -> emit bci_PUSH_PAD32 [] - PUSH_UBX8 lit -> do np <- literal lit - emit bci_PUSH_UBX8 [Op np] - PUSH_UBX16 lit -> do np <- literal lit - emit bci_PUSH_UBX16 [Op np] - PUSH_UBX32 lit -> do np <- literal lit - emit bci_PUSH_UBX32 [Op np] - PUSH_UBX lit nws -> do np <- literal lit - emit bci_PUSH_UBX [Op np, wOp nws] - - -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode - PUSH_ADDR nm -> do np <- lit [BCONPtrAddr nm] - emit bci_PUSH_UBX [Op np, SmallOp 1] - - PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] - PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] - PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] - PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] - PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] - PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] - PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] - PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] - PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] - PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] - PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] - - SLIDE n by -> emit bci_SLIDE [wOp n, wOp by] - ALLOC_AP n -> emit bci_ALLOC_AP [truncHalfWord platform n] - ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [truncHalfWord platform n] - ALLOC_PAP arity n -> emit bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n] - MKAP off sz -> emit bci_MKAP [wOp off, truncHalfWord platform sz] - MKPAP off sz -> emit bci_MKPAP [wOp off, truncHalfWord platform sz] - UNPACK n -> emit bci_UNPACK [wOp n] - PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] - emit bci_PACK [Op itbl_no, wOp sz] - LABEL lbl -> label lbl - TESTLT_I i l -> do np <- int i - emit bci_TESTLT_I [Op np, LabelOp l] - TESTEQ_I i l -> do np <- int i - emit bci_TESTEQ_I [Op np, LabelOp l] - TESTLT_W w l -> do np <- word w - emit bci_TESTLT_W [Op np, LabelOp l] - TESTEQ_W w l -> do np <- word w - emit bci_TESTEQ_W [Op np, LabelOp l] - TESTLT_I64 i l -> do np <- int64 i - emit bci_TESTLT_I64 [Op np, LabelOp l] - TESTEQ_I64 i l -> do np <- int64 i - emit bci_TESTEQ_I64 [Op np, LabelOp l] - TESTLT_I32 i l -> do np <- int (fromIntegral i) - emit bci_TESTLT_I32 [Op np, LabelOp l] - TESTEQ_I32 i l -> do np <- int (fromIntegral i) - emit bci_TESTEQ_I32 [Op np, LabelOp l] - TESTLT_I16 i l -> do np <- int (fromIntegral i) - emit bci_TESTLT_I16 [Op np, LabelOp l] - TESTEQ_I16 i l -> do np <- int (fromIntegral i) - emit bci_TESTEQ_I16 [Op np, LabelOp l] - TESTLT_I8 i l -> do np <- int (fromIntegral i) - emit bci_TESTLT_I8 [Op np, LabelOp l] - TESTEQ_I8 i l -> do np <- int (fromIntegral i) - emit bci_TESTEQ_I8 [Op np, LabelOp l] - TESTLT_W64 w l -> do np <- word64 w - emit bci_TESTLT_W64 [Op np, LabelOp l] - TESTEQ_W64 w l -> do np <- word64 w - emit bci_TESTEQ_W64 [Op np, LabelOp l] - TESTLT_W32 w l -> do np <- word (fromIntegral w) - emit bci_TESTLT_W32 [Op np, LabelOp l] - TESTEQ_W32 w l -> do np <- word (fromIntegral w) - emit bci_TESTEQ_W32 [Op np, LabelOp l] - TESTLT_W16 w l -> do np <- word (fromIntegral w) - emit bci_TESTLT_W16 [Op np, LabelOp l] - TESTEQ_W16 w l -> do np <- word (fromIntegral w) - emit bci_TESTEQ_W16 [Op np, LabelOp l] - TESTLT_W8 w l -> do np <- word (fromIntegral w) - emit bci_TESTLT_W8 [Op np, LabelOp l] - TESTEQ_W8 w l -> do np <- word (fromIntegral w) - emit bci_TESTEQ_W8 [Op np, LabelOp l] - TESTLT_F f l -> do np <- float f - emit bci_TESTLT_F [Op np, LabelOp l] - TESTEQ_F f l -> do np <- float f - emit bci_TESTEQ_F [Op np, LabelOp l] - TESTLT_D d l -> do np <- double d - emit bci_TESTLT_D [Op np, LabelOp l] - TESTEQ_D d l -> do np <- double d - emit bci_TESTEQ_D [Op np, LabelOp l] - TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] - TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] - CASEFAIL -> emit bci_CASEFAIL [] - SWIZZLE stkoff n -> emit bci_SWIZZLE [wOp stkoff, IOp n] - JMP l -> emit bci_JMP [LabelOp l] - ENTER -> emit bci_ENTER [] - RETURN rep -> emit (return_non_tuple rep) [] - RETURN_TUPLE -> emit bci_RETURN_T [] - CCALL off m_addr i -> do np <- addr m_addr - emit bci_CCALL [wOp off, Op np, SmallOp i] - PRIMCALL -> emit bci_PRIMCALL [] - BRK_FUN index mod cc -> do p1 <- ptr BCOPtrBreakArray - m <- addr mod - np <- addr cc - emit bci_BRK_FUN [Op p1, SmallOp index, - Op m, Op np] - - 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 LitNullAddr = int 0 - literal (LitFloat r) = float (fromRational r) - literal (LitDouble r) = double (fromRational r) - literal (LitChar c) = int (ord c) - literal (LitString bs) = lit [BCONPtrStr bs] - -- LitString requires a zero-terminator when emitted - literal (LitNumber nt i) = case nt of - LitNumInt -> int (fromIntegral i) - LitNumWord -> int (fromIntegral i) - LitNumInt8 -> int8 (fromIntegral i) - LitNumWord8 -> int8 (fromIntegral i) - LitNumInt16 -> int16 (fromIntegral i) - LitNumWord16 -> int16 (fromIntegral i) - LitNumInt32 -> int32 (fromIntegral i) - LitNumWord32 -> int32 (fromIntegral i) - LitNumInt64 -> int64 (fromIntegral i) - LitNumWord64 -> int64 (fromIntegral i) - LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat" - - -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most - -- likely to elicit a crash (rather than corrupt memory) in case absence - -- analysis messed up. - literal (LitRubbish {}) = int 0 - - litlabel fs = lit [BCONPtrLbl fs] - addr (RemotePtr a) = words [fromIntegral a] - float = words . mkLitF platform - double = words . mkLitD platform - int = words . mkLitI - int8 = words . mkLitI64 platform - int16 = words . mkLitI64 platform - int32 = words . mkLitI64 platform - int64 = words . mkLitI64 platform - word64 = words . mkLitW64 platform - words ws = lit (map BCONPtrWord ws) - word w = words [w] - -isLargeW :: Word -> Bool -isLargeW n = n > 65535 - -isLargeI :: Int -> Bool -isLargeI n = n > 32767 || n < -32768 - -push_alts :: ArgRep -> Word16 -push_alts V = bci_PUSH_ALTS_V -push_alts P = bci_PUSH_ALTS_P -push_alts N = bci_PUSH_ALTS_N -push_alts L = bci_PUSH_ALTS_L -push_alts F = bci_PUSH_ALTS_F -push_alts D = bci_PUSH_ALTS_D -push_alts V16 = error "push_alts: vector" -push_alts V32 = error "push_alts: vector" -push_alts V64 = error "push_alts: vector" - -return_non_tuple :: ArgRep -> Word16 -return_non_tuple V = bci_RETURN_V -return_non_tuple P = bci_RETURN_P -return_non_tuple N = bci_RETURN_N -return_non_tuple L = bci_RETURN_L -return_non_tuple F = bci_RETURN_F -return_non_tuple D = bci_RETURN_D -return_non_tuple V16 = error "return_non_tuple: vector" -return_non_tuple V32 = error "return_non_tuple: vector" -return_non_tuple V64 = error "return_non_tuple: vector" - -{- - we can only handle up to a fixed number of words on the stack, - because we need a stg_ctoi_tN stack frame for each size N. See - 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 - raising this limit. - - Note that the limit is the number of words passed on the stack. - If the calling convention passes part of the tuple in registers, the - maximum number of tuple elements may be larger. Elements can also - take multiple words on the stack (for example Double# on a 32 bit - platform). - -} -maxTupleReturnNativeStackSize :: WordOff -maxTupleReturnNativeStackSize = 62 - -{- - Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall - use to convert arguments between the native calling convention and the - interpreter. - - See Note [GHCi and native call registers] for more information. - -} -mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32 -mkNativeCallInfoSig platform NativeCallInfo{..} - | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize - = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler" - (ppr nativeCallStackSpillSize <+> text "stack words." <+> - 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) - where - cont_offset :: Word32 - cont_offset - | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize - | otherwise = 0 -- there is no continuation for primcalls - - reg_bit :: Word32 -> (GlobalReg, Int) -> Word32 - reg_bit x (r, n) - | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n - | otherwise = x - regs = allArgRegsCover platform - -mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal -mkNativeCallInfoLit platform call_info = - mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info - --- Make lists of host-sized words for literals, so that when the --- words are placed in memory at increasing addresses, the --- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Platform -> Float -> [Word] -mkLitD :: Platform -> Double -> [Word] -mkLitI64 :: Platform -> Int64 -> [Word] -mkLitW64 :: Platform -> Word64 -> [Word] - -mkLitF platform f = case platformWordSize platform of - PW4 -> runST $ do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 f - f_arr <- castSTUArray arr - w0 <- readArray f_arr 0 - return [w0 :: Word] - - PW8 -> runST $ do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 f - -- on 64-bit architectures we read two (32-bit) Float cells when we read - -- a (64-bit) Word: so we write a dummy value in the second cell to - -- avoid an out-of-bound read. - writeArray arr 1 0.0 - f_arr <- castSTUArray arr - w0 <- readArray f_arr 0 - return [w0 :: Word] - -mkLitD platform d = case platformWordSize platform of - PW4 -> runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word, w1] - ) - PW8 -> runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - -mkLitI64 platform ii = case platformWordSize platform of - PW4 -> runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word,w1] - ) - PW8 -> [fromIntegral ii :: Word] - -mkLitW64 platform ww = case platformWordSize platform of - PW4 -> runST (do - arr <- newArray_ ((0::Word),1) - writeArray arr 0 ww - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word,w1] - ) - PW8 -> [fromIntegral ww :: Word] - -mkLitI i = [fromIntegral i :: Word] +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} +-- +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler and linker +module GHC.ByteCode.Asm ( + assembleBCOs, + bcoFreeNames, + SizedSeq, sizeSS, ssElts, + iNTERP_STACK_CHECK_THRESH, + mkNativeCallInfoLit, + + -- * For testing + assembleBCO + ) where + +import GHC.Prelude hiding ( any ) + + +import GHC.ByteCode.Instr +import GHC.ByteCode.InfoTable +import GHC.ByteCode.Types +import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord ) + +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Literal +import GHC.Types.Unique.DSet +import GHC.Types.SptEntry +import GHC.Types.Unique.FM +import GHC.Unit.Types + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Core.TyCon +import GHC.Data.SizedSeq +import GHC.Data.SmallArray + +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 +import Language.Haskell.Syntax.Module.Name + +import Control.Monad +import qualified Control.Monad.Trans.State.Strict as MTL + +import qualified Data.Array.Unboxed as Array +import qualified Data.Array.IO as Array +import Data.Array.Base ( UArray(..), numElements, unsafeFreeze ) + +#if ! defined(DEBUG) +import Data.Array.Base ( unsafeWrite ) +#endif + +import Foreign hiding (shiftL, shiftR) +import Data.ByteString (ByteString) +import Data.Char (ord) +import Data.Maybe (fromMaybe) +import GHC.Float (castFloatToWord32, castDoubleToWord64) + +import qualified Data.List as List ( any ) +import GHC.Exts + + +-- ----------------------------------------------------------------------------- +-- Unlinked BCOs + +-- CompiledByteCode represents the result of byte-code +-- compiling a bunch of functions and data types + +-- | Finds external references. Remember to remove the names +-- defined by this group of BCOs themselves +bcoFreeNames :: UnlinkedBCO -> UniqDSet Name +bcoFreeNames bco + = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco] + where + bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs) + = unionManyUniqDSets ( + mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] : + mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] : + map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ] + ) + +-- ----------------------------------------------------------------------------- +-- The bytecode assembler + +-- The object format for bytecodes is: 16 bits for the opcode, and 16 +-- for each field -- so the code can be considered a sequence of +-- 16-bit ints. Each field denotes either a stack offset or number of +-- items on the stack (eg SLIDE), and index into the pointer table (eg +-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a +-- bytecode address in this BCO. + +-- Top level assembler fn. +assembleBCOs + :: Profile + -> FlatBag (ProtoBCO Name) + -> [TyCon] + -> [(Name, ByteString)] + -> Maybe InternalModBreaks + -> [SptEntry] + -> IO CompiledByteCode +assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do + -- TODO: the profile should be bundled with the interpreter: the rts ways are + -- fixed for an interpreter + let itbls = mkITbls profile tycons + bcos <- mapM (assembleBCO (profilePlatform profile)) proto_bcos + return CompiledByteCode + { bc_bcos = bcos + , bc_itbls = itbls + , bc_strs = top_strs + , bc_breaks = modbreaks + , bc_spt_entries = spt_entries + } + +-- Note [Allocating string literals] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Our strategy for handling top-level string literal bindings is described in +-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode, +-- but not all Addr# literals in a program are guaranteed to be lifted to the +-- top level. Our strategy for handling local Addr# literals is somewhat simpler: +-- after assembling, we find all the BCONPtrStr arguments in the program, malloc +-- memory for them, and bake the resulting addresses into the instruction stream +-- in the form of BCONPtrWord arguments. +-- +-- We used to allocate remote buffers for BCONPtrStr ByteStrings when +-- assembling, but this gets in the way of bytecode serialization: we +-- want the ability to serialize and reload assembled bytecode, so +-- it's better to preserve BCONPtrStr as-is, and only perform the +-- actual allocation at link-time. +-- +-- Note that, as with top-level string literal bindings, this memory is never +-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for +-- top-level string literal bindings] in GHC.StgToByteCode for some discussion +-- about why. +-- + +data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16) + , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr) + , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr ) + } + +data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16) + , final_ptr_array :: !(SmallArray BCOPtr) + , final_lit_array :: !(SmallArray BCONPtr) } + +-- How many words we have written so far. +data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int } + + +{-# NOINLINE inspectInstrs #-} +-- | Perform analysis of the bytecode to determine +-- 1. How many instructions we will produce +-- 2. If we are going to need long jumps. +-- 3. The offsets that labels refer to +inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState +inspectInstrs platform long_jump e instrs = + inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs) + +{-# NOINLINE runInstrs #-} +-- | Assemble the bytecode from the instructions. +runInstrs :: Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult +runInstrs platform long_jumps is_state instrs = do + -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs. + isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1) + ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined + lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined + let env :: LocalLabel -> Word + env lbl = fromMaybe + (pprPanic "assembleBCO.findLabel" (ppr lbl)) + (lookupUFM (lblEnv is_state) lbl) + let initial_state = AsmState 0 0 0 + let initial_reader = RunAsmReader{..} + runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs) + final_isn_array <- unsafeFreeze isn_array + final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array + final_lit_array <- unsafeFreezeSmallArrayIO lit_array + return $ RunAsmResult {..} + +assembleRunAsm :: Platform -> BCInstr -> RunAsm () +assembleRunAsm p i = assembleI @RunAsm p i + +assembleInspectAsm :: Platform -> BCInstr -> InspectAsm () +assembleInspectAsm p i = assembleI @InspectAsm p i + +assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO platform + (ProtoBCO { protoBCOName = nm + , protoBCOInstrs = instrs + , protoBCOBitmap = bitmap + , protoBCOBitmapSize = bsize + , protoBCOArity = arity }) = do + -- pass 1: collect up the offsets of the local labels. + let initial_offset = 0 + + -- Jump instructions are variable-sized, there are long and short variants + -- depending on the magnitude of the offset. However, we can't tell what + -- size instructions we will need until we have calculated the offsets of + -- the labels, which depends on the size of the instructions... So we + -- first create the label environment assuming that all jumps are short, + -- and if the final size is indeed small enough for short jumps, we are + -- done. Otherwise, we repeat the calculation, and we force all jumps in + -- this BCO to be long. + is0 = inspectInstrs platform False initial_offset instrs + (is1, long_jumps) + | isLargeInspectState is0 + = (inspectInstrs platform True initial_offset instrs, True) + | otherwise = (is0, False) + + + -- pass 2: run assembler and generate instructions, literals and pointers + RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs + + -- precomputed size should be equal to final size + massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array + && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array + && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array) + (text "bytecode instruction count mismatch") + + let !insns_arr = mkBCOByteArray $ final_isn_array + !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap + ul_bco = UnlinkedBCO { unlinkedBCOName = nm + , unlinkedBCOArity = arity + , unlinkedBCOInstrs = insns_arr + , unlinkedBCOBitmap = bitmap_arr + , unlinkedBCOLits = fromSmallArray final_lit_array + , unlinkedBCOPtrs = fromSmallArray final_ptr_array + } + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco + +-- | Construct a word-array containing an @StgLargeBitmap@. +mkBitmapArray :: Word -> [StgWord] -> UArray Int Word +-- Here the return type must be an array of Words, not StgWords, +-- because the underlying ByteArray# will end up as a component +-- of a BCO object. +mkBitmapArray bsize bitmap + = Array.listArray (0, length bitmap) $ + fromIntegral bsize : map (fromInteger . fromStgWord) bitmap + + +data Operand + = Op Word + | IOp Int + | SmallOp Word16 + | LabelOp LocalLabel + +wOp :: WordOff -> Operand +wOp = Op . fromIntegral + +bOp :: ByteOff -> Operand +bOp = Op . fromIntegral + +truncHalfWord :: Platform -> HalfWord -> Operand +truncHalfWord platform w = case platformWordSize platform of + PW4 | w <= 65535 -> Op (fromIntegral w) + PW8 | w <= 4294967295 -> Op (fromIntegral w) + _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w) + + +ptr :: MonadAssembler m => BCOPtr -> m Word +ptr = ioptr . return + +type LabelEnv = LocalLabel -> Word + +largeOp :: Bool -> Operand -> Bool +largeOp long_jumps op = case op of + SmallOp _ -> False + Op w -> isLargeW w + IOp i -> isLargeI i + LabelOp _ -> long_jumps + +newtype RunAsm a = RunAsm' { runRunAsm :: Bool + -> LabelEnv + -> RunAsmReader + -> AsmState + -> IO (AsmState, a) } + +pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a)) + -> RunAsm a +pattern RunAsm m <- RunAsm' m + where + RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d) +{-# COMPLETE RunAsm #-} + +instance Functor RunAsm where + fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s)) + +instance Applicative RunAsm where + pure x = RunAsm $ \_ _ _ !s -> pure (s, x) + (RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do + (!s', f') <- f a b c s + (!s'', x') <- x a b c s' + return (s'', f' x') + {-# INLINE (<*>) #-} + + +instance Monad RunAsm where + return = pure + (RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s' + {-# INLINE (>>=) #-} + +runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a +runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s + +expand :: PlatformWordSize -> Bool -> Operand -> RunAsm () +expand word_size largeArgs o = do + e <- askEnv + case o of + (SmallOp w) -> writeIsn w + (LabelOp w) -> let !r = e w in handleLargeArg r + (Op w) -> handleLargeArg w + (IOp i) -> handleLargeArg i + + where + handleLargeArg :: Integral a => a -> RunAsm () + handleLargeArg w = + if largeArgs + then largeArg word_size (fromIntegral w) + else writeIsn (fromIntegral w) + +lift :: IO a -> RunAsm a +lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a) + +askLongJumps :: RunAsm Bool +askLongJumps = RunAsm $ \a _ _ s -> pure (s, a) + +askEnv :: RunAsm LabelEnv +askEnv = RunAsm $ \_ b _ s -> pure (s, b) + +writePtr :: BCOPtr -> RunAsm Word +writePtr w + = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do + writeSmallArrayIO ptr_array (nptr asm) w + let !n' = nptr asm + 1 + let !asm' = asm { nptr = n' } + return (asm', fromIntegral (nptr asm)) + +writeLit :: BCONPtr -> RunAsm Word +writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do + writeSmallArrayIO lit_array (nlit asm) w + let !n' = nlit asm + 1 + let !asm' = asm { nlit = n' } + return (asm', fromIntegral (nlit asm)) + +writeLits :: OneOrTwo BCONPtr -> RunAsm Word +writeLits (OnlyOne l) = writeLit l +writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2 + +writeIsn :: Word16 -> RunAsm () +writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do +#if defined(DEBUG) + Array.writeArray isn_array (nisn asm) w +#else + unsafeWrite isn_array (nisn asm) w +#endif + let !n' = nisn asm + 1 + let !asm' = asm { nisn = n' } + return (asm', ()) + +{-# INLINE any #-} +-- Any is unrolled manually so that the call in `emit` can be eliminated without +-- relying on SpecConstr (which does not work across modules). +any :: (a -> Bool) -> [a] -> Bool +any _ [] = False +any f [x] = f x +any f [x,y] = f x || f y +any f [x,y,z] = f x || f y || f z +any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4 +any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5 +any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6 +any f xs = List.any f xs + +{-# INLINE mapM6_ #-} +mapM6_ :: Monad m => (a -> m b) -> [a] -> m () +mapM6_ _ [] = return () +mapM6_ f [x] = () <$ f x +mapM6_ f [x,y] = () <$ f x <* f y +mapM6_ f [x,y,z] = () <$ f x <* f y <* f z +mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4 +mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 +mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6 +mapM6_ f xs = mapM_ f xs + +instance MonadAssembler RunAsm where + ioptr p_io = do + p <- lift p_io + writePtr p + lit lits = writeLits lits + + label _ = return () + + emit pwordsize w ops = do + long_jumps <- askLongJumps + -- See the definition of `any` above + let largeArgs = any (largeOp long_jumps) ops + let opcode + | largeArgs = largeArgInstr w + | otherwise = w + writeIsn opcode + mapM6_ (expand pwordsize largeArgs) ops + + {-# INLINE emit #-} + {-# INLINE label #-} + {-# INLINE lit #-} + {-# INLINE ioptr #-} + +type LabelEnvMap = UniqFM LocalLabel Word + +data InspectState = InspectState + { instrCount :: !Word + , ptrCount :: !Word + , litCount :: !Word + , lblEnv :: LabelEnvMap + } + +instance Outputable InspectState where + ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)] + +isLargeInspectState :: InspectState -> Bool +isLargeInspectState InspectState{..} = + isLargeW (fromIntegral $ sizeUFM lblEnv) + || isLargeW instrCount + +newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool + } + +newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState, a #) } + +pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #)) + -> InspectAsm a +pattern InspectAsm m <- InspectAsm' m + where + InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b) +{-# COMPLETE InspectAsm #-} + +instance Functor InspectAsm where + fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of + (# b', c #) -> (# b', f c #) + +instance Applicative InspectAsm where + pure x = InspectAsm $ \_ s -> (# s, x #) + (InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of + (# s', f' #) -> + case x a s' of + (# s'', x' #) -> (# s'', f' x' #) + +instance Monad InspectAsm where + return = pure + (InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of + (# s', a' #) -> runInspectAsm (f a') a s' + +get_ :: InspectAsm InspectState +get_ = InspectAsm $ \_ b -> (# b, b #) + +put_ :: InspectState -> InspectAsm () +put_ !s = InspectAsm $ \_ _ -> (# s, () #) + +modify_ :: (InspectState -> InspectState) -> InspectAsm () +modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #) + +ask_ :: InspectAsm InspectEnv +ask_ = InspectAsm $ \a b -> (# b, a #) + +inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState +inspectAsm long_jumps initial_offset (InspectAsm s) = + case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of + (# res, () #) -> res +{-# INLINE inspectAsm #-} + + + +instance MonadAssembler InspectAsm where + ioptr _ = do + s <- get_ + let n = ptrCount s + put_ (s { ptrCount = n + 1 }) + return n + + lit ls = do + s <- get_ + let n = litCount s + put_ (s { litCount = n + oneTwoLength ls }) + return n + + label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' }) + + emit pwordsize _ ops = do + InspectEnv long_jumps <- ask_ + -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed + -- to unroll for arguments up to size 6. + let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1 + largeOps = any (largeOp long_jumps) ops + bigSize = largeArg16s pwordsize + count' = if largeOps then countLarge bigSize else countSmall bigSize + + s <- get_ + put_ (s { instrCount = instrCount s + size }) + + {-# INLINE emit #-} + {-# INLINE label #-} + {-# INLINE lit #-} + {-# INLINE ioptr #-} + +count :: Word -> Bool -> Operand -> Word +count _ _ (SmallOp _) = 1 +count big largeOps (LabelOp _) = if largeOps then big else 1 +count big largeOps (Op _) = if largeOps then big else 1 +count big largeOps (IOp _) = if largeOps then big else 1 +{-# INLINE count #-} + +countSmall, countLarge :: Word -> Operand -> Word +countLarge big x = count big True x +countSmall big x = count big False x + + +-- Bring in all the bci_ bytecode constants. +#include "Bytecodes.h" + +largeArgInstr :: Word16 -> Word16 +largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci + +{-# INLINE largeArg #-} +largeArg :: PlatformWordSize -> Word64 -> RunAsm () +largeArg wsize w = case wsize of + PW8 -> do writeIsn (fromIntegral (w `shiftR` 48)) + writeIsn (fromIntegral (w `shiftR` 32)) + writeIsn (fromIntegral (w `shiftR` 16)) + writeIsn (fromIntegral w) + PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32)) + (text "largeArg too big:" <+> ppr w) $ do + writeIsn (fromIntegral (w `shiftR` 16)) + writeIsn (fromIntegral w) + +largeArg16s :: PlatformWordSize -> Word +largeArg16s pwordsize = case pwordsize of + PW8 -> 4 + PW4 -> 2 + +data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor) + +oneTwoLength :: OneOrTwo a -> Word +oneTwoLength (OnlyOne {}) = 1 +oneTwoLength (OnlyTwo {}) = 2 + +class Monad m => MonadAssembler m where + ioptr :: IO BCOPtr -> m Word + lit :: OneOrTwo BCONPtr -> m Word + label :: LocalLabel -> m () + emit :: PlatformWordSize -> Word16 -> [Operand] -> m () + +lit1 :: MonadAssembler m => BCONPtr -> m Word +lit1 p = lit (OnlyOne p) + +{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-} +{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-} + +assembleI :: forall m . MonadAssembler m + => Platform + -> BCInstr + -> m () +assembleI platform i = case i of + STKCHECK n -> emit_ bci_STKCHECK [Op n] + PUSH_L o1 -> emit_ bci_PUSH_L [wOp o1] + PUSH_LL o1 o2 -> emit_ bci_PUSH_LL [wOp o1, wOp o2] + PUSH_LLL o1 o2 o3 -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3] + PUSH8 o1 -> emit_ bci_PUSH8 [bOp o1] + PUSH16 o1 -> emit_ bci_PUSH16 [bOp o1] + PUSH32 o1 -> emit_ bci_PUSH32 [bOp o1] + PUSH8_W o1 -> emit_ bci_PUSH8_W [bOp o1] + PUSH16_W o1 -> emit_ bci_PUSH16_W [bOp o1] + PUSH32_W o1 -> emit_ bci_PUSH32_W [bOp o1] + PUSH_G nm -> do p <- ptr (BCOPtrName nm) + emit_ bci_PUSH_G [Op p] + PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) + emit_ bci_PUSH_G [Op p] + PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit_ bci_PUSH_G [Op p] + PUSH_ALTS proto pk + -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit_ (push_alts pk) [Op p] + PUSH_ALTS_TUPLE proto call_info tuple_proto + -> do let ul_bco = assembleBCO platform proto + ul_tuple_bco = assembleBCO platform + tuple_proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco) + info <- word (fromIntegral $ + mkNativeCallInfoSig platform call_info) + emit_ bci_PUSH_ALTS_T + [Op p, Op info, Op p_tup] + PUSH_PAD8 -> emit_ bci_PUSH_PAD8 [] + PUSH_PAD16 -> emit_ bci_PUSH_PAD16 [] + PUSH_PAD32 -> emit_ bci_PUSH_PAD32 [] + PUSH_UBX8 lit -> do np <- literal lit + emit_ bci_PUSH_UBX8 [Op np] + PUSH_UBX16 lit -> do np <- literal lit + emit_ bci_PUSH_UBX16 [Op np] + PUSH_UBX32 lit -> do np <- literal lit + emit_ bci_PUSH_UBX32 [Op np] + PUSH_UBX lit nws -> do np <- literal lit + emit_ bci_PUSH_UBX [Op np, wOp nws] + -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode + PUSH_ADDR nm -> do np <- lit1 (BCONPtrAddr nm) + emit_ bci_PUSH_UBX [Op np, SmallOp 1] + + PUSH_APPLY_N -> emit_ bci_PUSH_APPLY_N [] + PUSH_APPLY_V -> emit_ bci_PUSH_APPLY_V [] + PUSH_APPLY_F -> emit_ bci_PUSH_APPLY_F [] + PUSH_APPLY_D -> emit_ bci_PUSH_APPLY_D [] + PUSH_APPLY_L -> emit_ bci_PUSH_APPLY_L [] + PUSH_APPLY_P -> emit_ bci_PUSH_APPLY_P [] + PUSH_APPLY_PP -> emit_ bci_PUSH_APPLY_PP [] + PUSH_APPLY_PPP -> emit_ bci_PUSH_APPLY_PPP [] + PUSH_APPLY_PPPP -> emit_ bci_PUSH_APPLY_PPPP [] + PUSH_APPLY_PPPPP -> emit_ bci_PUSH_APPLY_PPPPP [] + PUSH_APPLY_PPPPPP -> emit_ bci_PUSH_APPLY_PPPPPP [] + + SLIDE n by -> emit_ bci_SLIDE [wOp n, wOp by] + ALLOC_AP n -> emit_ bci_ALLOC_AP [truncHalfWord platform n] + ALLOC_AP_NOUPD n -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n] + ALLOC_PAP arity n -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n] + MKAP off sz -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz] + MKPAP off sz -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz] + UNPACK n -> emit_ bci_UNPACK [wOp n] + PACK dcon sz -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon)) + emit_ bci_PACK [Op itbl_no, wOp sz] + LABEL lbl -> label lbl + TESTLT_I i l -> do np <- int i + emit_ bci_TESTLT_I [Op np, LabelOp l] + TESTEQ_I i l -> do np <- int i + emit_ bci_TESTEQ_I [Op np, LabelOp l] + TESTLT_W w l -> do np <- word w + emit_ bci_TESTLT_W [Op np, LabelOp l] + TESTEQ_W w l -> do np <- word w + emit_ bci_TESTEQ_W [Op np, LabelOp l] + TESTLT_I64 i l -> do np <- word64 (fromIntegral i) + emit_ bci_TESTLT_I64 [Op np, LabelOp l] + TESTEQ_I64 i l -> do np <- word64 (fromIntegral i) + emit_ bci_TESTEQ_I64 [Op np, LabelOp l] + TESTLT_I32 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTLT_I32 [Op np, LabelOp l] + TESTEQ_I32 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTEQ_I32 [Op np, LabelOp l] + TESTLT_I16 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTLT_I16 [Op np, LabelOp l] + TESTEQ_I16 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTEQ_I16 [Op np, LabelOp l] + TESTLT_I8 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTLT_I8 [Op np, LabelOp l] + TESTEQ_I8 i l -> do np <- word (fromIntegral i) + emit_ bci_TESTEQ_I8 [Op np, LabelOp l] + TESTLT_W64 w l -> do np <- word64 w + emit_ bci_TESTLT_W64 [Op np, LabelOp l] + TESTEQ_W64 w l -> do np <- word64 w + emit_ bci_TESTEQ_W64 [Op np, LabelOp l] + TESTLT_W32 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTLT_W32 [Op np, LabelOp l] + TESTEQ_W32 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTEQ_W32 [Op np, LabelOp l] + TESTLT_W16 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTLT_W16 [Op np, LabelOp l] + TESTEQ_W16 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTEQ_W16 [Op np, LabelOp l] + TESTLT_W8 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTLT_W8 [Op np, LabelOp l] + TESTEQ_W8 w l -> do np <- word (fromIntegral w) + emit_ bci_TESTEQ_W8 [Op np, LabelOp l] + TESTLT_F f l -> do np <- float f + emit_ bci_TESTLT_F [Op np, LabelOp l] + TESTEQ_F f l -> do np <- float f + emit_ bci_TESTEQ_F [Op np, LabelOp l] + TESTLT_D d l -> do np <- double d + emit_ bci_TESTLT_D [Op np, LabelOp l] + TESTEQ_D d l -> do np <- double d + emit_ bci_TESTEQ_D [Op np, LabelOp l] + TESTLT_P i l -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l] + TESTEQ_P i l -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l] + CASEFAIL -> emit_ bci_CASEFAIL [] + SWIZZLE stkoff n -> emit_ bci_SWIZZLE [wOp stkoff, IOp n] + JMP l -> emit_ bci_JMP [LabelOp l] + ENTER -> emit_ bci_ENTER [] + RETURN rep -> emit_ (return_non_tuple rep) [] + RETURN_TUPLE -> emit_ bci_RETURN_T [] + CCALL off ffi i -> do np <- lit1 $ BCONPtrFFIInfo ffi + emit_ bci_CCALL [wOp off, Op np, SmallOp i] + PRIMCALL -> emit_ bci_PRIMCALL [] + + OP_ADD w -> case w of + W64 -> emit_ bci_OP_ADD_64 [] + W32 -> emit_ bci_OP_ADD_32 [] + W16 -> emit_ bci_OP_ADD_16 [] + W8 -> emit_ bci_OP_ADD_08 [] + _ -> unsupported_width + OP_SUB w -> case w of + W64 -> emit_ bci_OP_SUB_64 [] + W32 -> emit_ bci_OP_SUB_32 [] + W16 -> emit_ bci_OP_SUB_16 [] + W8 -> emit_ bci_OP_SUB_08 [] + _ -> unsupported_width + OP_AND w -> case w of + W64 -> emit_ bci_OP_AND_64 [] + W32 -> emit_ bci_OP_AND_32 [] + W16 -> emit_ bci_OP_AND_16 [] + W8 -> emit_ bci_OP_AND_08 [] + _ -> unsupported_width + OP_XOR w -> case w of + W64 -> emit_ bci_OP_XOR_64 [] + W32 -> emit_ bci_OP_XOR_32 [] + W16 -> emit_ bci_OP_XOR_16 [] + W8 -> emit_ bci_OP_XOR_08 [] + _ -> unsupported_width + OP_OR w -> case w of + W64 -> emit_ bci_OP_OR_64 [] + W32 -> emit_ bci_OP_OR_32 [] + W16 -> emit_ bci_OP_OR_16 [] + W8 -> emit_ bci_OP_OR_08 [] + _ -> unsupported_width + OP_NOT w -> case w of + W64 -> emit_ bci_OP_NOT_64 [] + W32 -> emit_ bci_OP_NOT_32 [] + W16 -> emit_ bci_OP_NOT_16 [] + W8 -> emit_ bci_OP_NOT_08 [] + _ -> unsupported_width + OP_NEG w -> case w of + W64 -> emit_ bci_OP_NEG_64 [] + W32 -> emit_ bci_OP_NEG_32 [] + W16 -> emit_ bci_OP_NEG_16 [] + W8 -> emit_ bci_OP_NEG_08 [] + _ -> unsupported_width + OP_MUL w -> case w of + W64 -> emit_ bci_OP_MUL_64 [] + W32 -> emit_ bci_OP_MUL_32 [] + W16 -> emit_ bci_OP_MUL_16 [] + W8 -> emit_ bci_OP_MUL_08 [] + _ -> unsupported_width + OP_SHL w -> case w of + W64 -> emit_ bci_OP_SHL_64 [] + W32 -> emit_ bci_OP_SHL_32 [] + W16 -> emit_ bci_OP_SHL_16 [] + W8 -> emit_ bci_OP_SHL_08 [] + _ -> unsupported_width + OP_ASR w -> case w of + W64 -> emit_ bci_OP_ASR_64 [] + W32 -> emit_ bci_OP_ASR_32 [] + W16 -> emit_ bci_OP_ASR_16 [] + W8 -> emit_ bci_OP_ASR_08 [] + _ -> unsupported_width + OP_LSR w -> case w of + W64 -> emit_ bci_OP_LSR_64 [] + W32 -> emit_ bci_OP_LSR_32 [] + W16 -> emit_ bci_OP_LSR_16 [] + W8 -> emit_ bci_OP_LSR_08 [] + _ -> unsupported_width + + OP_NEQ w -> case w of + W64 -> emit_ bci_OP_NEQ_64 [] + W32 -> emit_ bci_OP_NEQ_32 [] + W16 -> emit_ bci_OP_NEQ_16 [] + W8 -> emit_ bci_OP_NEQ_08 [] + _ -> unsupported_width + OP_EQ w -> case w of + W64 -> emit_ bci_OP_EQ_64 [] + W32 -> emit_ bci_OP_EQ_32 [] + W16 -> emit_ bci_OP_EQ_16 [] + W8 -> emit_ bci_OP_EQ_08 [] + _ -> unsupported_width + + OP_U_LT w -> case w of + W64 -> emit_ bci_OP_U_LT_64 [] + W32 -> emit_ bci_OP_U_LT_32 [] + W16 -> emit_ bci_OP_U_LT_16 [] + W8 -> emit_ bci_OP_U_LT_08 [] + _ -> unsupported_width + OP_S_LT w -> case w of + W64 -> emit_ bci_OP_S_LT_64 [] + W32 -> emit_ bci_OP_S_LT_32 [] + W16 -> emit_ bci_OP_S_LT_16 [] + W8 -> emit_ bci_OP_S_LT_08 [] + _ -> unsupported_width + OP_U_GE w -> case w of + W64 -> emit_ bci_OP_U_GE_64 [] + W32 -> emit_ bci_OP_U_GE_32 [] + W16 -> emit_ bci_OP_U_GE_16 [] + W8 -> emit_ bci_OP_U_GE_08 [] + _ -> unsupported_width + OP_S_GE w -> case w of + W64 -> emit_ bci_OP_S_GE_64 [] + W32 -> emit_ bci_OP_S_GE_32 [] + W16 -> emit_ bci_OP_S_GE_16 [] + W8 -> emit_ bci_OP_S_GE_08 [] + _ -> unsupported_width + OP_U_GT w -> case w of + W64 -> emit_ bci_OP_U_GT_64 [] + W32 -> emit_ bci_OP_U_GT_32 [] + W16 -> emit_ bci_OP_U_GT_16 [] + W8 -> emit_ bci_OP_U_GT_08 [] + _ -> unsupported_width + OP_S_GT w -> case w of + W64 -> emit_ bci_OP_S_GT_64 [] + W32 -> emit_ bci_OP_S_GT_32 [] + W16 -> emit_ bci_OP_S_GT_16 [] + W8 -> emit_ bci_OP_S_GT_08 [] + _ -> unsupported_width + OP_U_LE w -> case w of + W64 -> emit_ bci_OP_U_LE_64 [] + W32 -> emit_ bci_OP_U_LE_32 [] + W16 -> emit_ bci_OP_U_LE_16 [] + W8 -> emit_ bci_OP_U_LE_08 [] + _ -> unsupported_width + OP_S_LE w -> case w of + W64 -> emit_ bci_OP_S_LE_64 [] + W32 -> emit_ bci_OP_S_LE_32 [] + W16 -> emit_ bci_OP_S_LE_16 [] + W8 -> emit_ bci_OP_S_LE_08 [] + _ -> unsupported_width + + OP_INDEX_ADDR w -> case w of + W64 -> emit_ bci_OP_INDEX_ADDR_64 [] + W32 -> emit_ bci_OP_INDEX_ADDR_32 [] + W16 -> emit_ bci_OP_INDEX_ADDR_16 [] + W8 -> emit_ bci_OP_INDEX_ADDR_08 [] + _ -> unsupported_width + + BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do + p1 <- ptr $ BCOPtrBreakArray info_mod + let -- cast that checks that round-tripping through Word32 doesn't change the value + infoW32 = let r = fromIntegral infox :: Word32 + in if fromIntegral r == infox + then r + else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox) + ix_hi = fromIntegral (infoW32 `shiftR` 16) + ix_lo = fromIntegral (infoW32 .&. 0xffff) + info_addr <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod + info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS $ moduleUnitId info_mod + np <- lit1 $ BCONPtrCostCentre ibi + emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr + , SmallOp ix_hi, SmallOp ix_lo, Op np ] + +#if MIN_VERSION_rts(1,0,3) + BCO_NAME name -> do np <- lit1 (BCONPtrStr name) + emit_ bci_BCO_NAME [Op np] +#endif + + + + where + unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width" + emit_ = emit word_size + + literal :: Literal -> m Word + literal (LitLabel fs _) = litlabel fs + literal LitNullAddr = word 0 + literal (LitFloat r) = float (fromRational r) + literal (LitDouble r) = double (fromRational r) + literal (LitChar c) = int (ord c) + literal (LitString bs) = lit1 (BCONPtrStr bs) + -- LitString requires a zero-terminator when emitted + literal (LitNumber nt i) = case nt of + LitNumInt -> word (fromIntegral i) + LitNumWord -> word (fromIntegral i) + LitNumInt8 -> word8 (fromIntegral i) + LitNumWord8 -> word8 (fromIntegral i) + LitNumInt16 -> word16 (fromIntegral i) + LitNumWord16 -> word16 (fromIntegral i) + LitNumInt32 -> word32 (fromIntegral i) + LitNumWord32 -> word32 (fromIntegral i) + LitNumInt64 -> word64 (fromIntegral i) + LitNumWord64 -> word64 (fromIntegral i) + LitNumBigNat -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat" + + -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most + -- likely to elicit a crash (rather than corrupt memory) in case absence + -- analysis messed up. + literal (LitRubbish {}) = word 0 + + litlabel fs = lit1 (BCONPtrLbl fs) + words ws = lit (fmap BCONPtrWord ws) + word w = words (OnlyOne w) + word2 w1 w2 = words (OnlyTwo w1 w2) + word_size = platformWordSize platform + word_size_bits = platformWordSizeInBits platform + + -- Make lists of host-sized words for literals, so that when the + -- words are placed in memory at increasing addresses, the + -- bit pattern is correct for the host's word size and endianness. + -- + -- Note that we only support host endianness == target endianness for now, + -- even with the external interpreter. This would need to be fixed to + -- support host endianness /= target endianness + int :: Int -> m Word + int i = word (fromIntegral i) + + float :: Float -> m Word + float f = word32 (castFloatToWord32 f) + + double :: Double -> m Word + double d = word64 (castDoubleToWord64 d) + + word64 :: Word64 -> m Word + word64 ww = case word_size of + PW4 -> + let !wl = fromIntegral ww + !wh = fromIntegral (ww `unsafeShiftR` 32) + in case platformByteOrder platform of + LittleEndian -> word2 wl wh + BigEndian -> word2 wh wl + PW8 -> word (fromIntegral ww) + + word8 :: Word8 -> m Word + word8 x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8)) + + word16 :: Word16 -> m Word + word16 x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16)) + + word32 :: Word32 -> m Word + word32 x = case platformByteOrder platform of + LittleEndian -> word (fromIntegral x) + BigEndian -> case word_size of + PW4 -> word (fromIntegral x) + PW8 -> word (fromIntegral x `unsafeShiftL` 32) + + +isLargeW :: Word -> Bool +isLargeW n = n > 65535 + +isLargeI :: Int -> Bool +isLargeI n = n > 32767 || n < -32768 + +push_alts :: ArgRep -> Word16 +push_alts V = bci_PUSH_ALTS_V +push_alts P = bci_PUSH_ALTS_P +push_alts N = bci_PUSH_ALTS_N +push_alts L = bci_PUSH_ALTS_L +push_alts F = bci_PUSH_ALTS_F +push_alts D = bci_PUSH_ALTS_D +push_alts V16 = error "push_alts: vector" +push_alts V32 = error "push_alts: vector" +push_alts V64 = error "push_alts: vector" + +return_non_tuple :: ArgRep -> Word16 +return_non_tuple V = bci_RETURN_V +return_non_tuple P = bci_RETURN_P +return_non_tuple N = bci_RETURN_N +return_non_tuple L = bci_RETURN_L +return_non_tuple F = bci_RETURN_F +return_non_tuple D = bci_RETURN_D +return_non_tuple V16 = error "return_non_tuple: vector" +return_non_tuple V32 = error "return_non_tuple: vector" +return_non_tuple V64 = error "return_non_tuple: vector" + +{- + we can only handle up to a fixed number of words on the stack, + because we need a stg_ctoi_tN stack frame for each size N. See + Note [unboxed tuple bytecodes and tuple_BCO]. + + If needed, you can support larger tuples by adding more in + 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. + If the calling convention passes part of the tuple in registers, the + maximum number of tuple elements may be larger. Elements can also + take multiple words on the stack (for example Double# on a 32 bit + platform). + -} +maxTupleReturnNativeStackSize :: WordOff +maxTupleReturnNativeStackSize = 62 + +{- + Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall + use to convert arguments between the native calling convention and the + interpreter. + + See Note [GHCi and native call registers] for more information. + -} +mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32 +mkNativeCallInfoSig platform NativeCallInfo{..} + | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize + = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler" + (ppr nativeCallStackSpillSize <+> text "stack words." <+> + text "Use -fobject-code to get around this limit" + ) + | otherwise + = -- 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 + | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize + | otherwise = 0 -- there is no continuation for primcalls + + reg_bit :: Word32 -> (GlobalReg, Int) -> Word32 + reg_bit x (r, n) + | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n + | otherwise = x + 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 = + mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info iNTERP_STACK_CHECK_THRESH :: Int iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH diff --git a/GHC/ByteCode/Breakpoints.hs b/GHC/ByteCode/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/GHC/ByteCode/Breakpoints.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Breakpoint information constructed during ByteCode generation. +-- +-- Specifically, code-generation breakpoints are referred to as "internal +-- breakpoints", the internal breakpoint data for a module is stored in +-- 'InternalModBreaks', and is uniquely identified at runtime by an +-- 'InternalBreakpointId'. +-- +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] +module GHC.ByteCode.Breakpoints + ( -- * Internal Mod Breaks + InternalModBreaks(..), CgBreakInfo(..) + , mkInternalModBreaks, imodBreaks_module + + -- ** Internal breakpoint identifier + , InternalBreakpointId(..), BreakInfoIndex + , InternalBreakLoc(..) + + -- * Operations + + -- ** Internal-level operations + , getInternalBreak + + -- ** Source-level information operations + , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS + , getBreakSourceId, getBreakSourceMod + + -- * Utils + , seqInternalModBreaks + + ) + where + +import GHC.Prelude +import GHC.Types.SrcLoc +import GHC.Types.Name.Occurrence +import Control.DeepSeq +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IM + +import GHC.HsToCore.Breakpoints +import GHC.Iface.Syntax + +import GHC.Unit.Module (Module) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import Data.Array + +{- +Note [ModBreaks vs InternalModBreaks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'ModBreaks' and 'BreakpointId's must not to be confused with +'InternalModBreaks' and 'InternalBreakId's. + +'ModBreaks' is constructed once during HsToCore from the information attached +to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks' +can be queried using 'BreakpointId's, which uniquely identifies a breakpoint +within the list of breakpoint information for a given module's 'ModBreaks'. + +'InternalModBreaks' are constructed during bytecode generation and are indexed +by a 'InternalBreakpointId'. They contain all the information relevant to a +breakpoint for code generation that can be accessed during runtime execution +(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's +are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN' +instruction receives 'InternalBreakpointId' as an argument. + +We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used +to get source-level information about a breakpoint via the corresponding 'ModBreaks'. + +Notably, 'InternalModBreaks' can contain entries for so-called internal +breakpoints, which do not necessarily have a source-level location attached to +it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to +introduce breakpoints during code generation for features such as stepping-out. + +Note [Breakpoint identifiers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before optimization a breakpoint is identified uniquely with a tick module +and a tick index. See 'BreakpointId'. A tick module contains an array, indexed +with the tick indexes, which indicates breakpoint status. + +When we generate ByteCode, we collect information for every breakpoint at +their *occurrence sites* (see CgBreakInfo) and these info +are stored in the ModIface of the occurrence module. Because of inlining, we +can't reuse the tick index to uniquely identify an occurrence; because of +cross-module inlining, we can't assume that the occurrence module is the same +as the tick module (#24712). + +So every breakpoint occurrence gets assigned a module-unique *info index* and +we store it alongside the occurrence module (*info module*) in the +'InternalBreakpointId' datatype. This is the index that we use at runtime to +identify a breakpoint. + +When the internal breakpoint has a matching tick-level breakpoint we can fetch +the related tick-level information by first looking up a mapping +@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@. +-} + +-------------------------------------------------------------------------------- +-- * Internal breakpoint identifiers +-------------------------------------------------------------------------------- + +-- | Internal breakpoint info index +type BreakInfoIndex = Int + +-- | Internal breakpoint identifier +-- +-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation. +-- See Note [Breakpoint identifiers] +data InternalBreakpointId = InternalBreakpointId + { ibi_info_mod :: !Module -- ^ Breakpoint info module + , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index + } + deriving (Eq, Ord) + +-------------------------------------------------------------------------------- +-- * Internal Mod Breaks +-------------------------------------------------------------------------------- + +-- | Internal mod breaks store the runtime-relevant information of breakpoints. +-- +-- Importantly, it maps 'InternalBreakpointId's to 'CgBreakInfo'. +-- +-- 'InternalModBreaks' are constructed during bytecode generation and stored in +-- 'CompiledByteCode' afterwards. +data InternalModBreaks = InternalModBreaks + { imodBreaks_breakInfo :: !(IntMap CgBreakInfo) + -- ^ Access code-gen time information about a breakpoint, indexed by + -- 'InternalBreakpointId'. + + , imodBreaks_modBreaks :: !ModBreaks + -- ^ Store the ModBreaks for this module + -- + -- Recall Note [Breakpoint identifiers]: for some module A, an + -- *occurrence* of a breakpoint in A may have been inlined from some + -- breakpoint *defined* in module B. + -- + -- This 'ModBreaks' contains information regarding all the breakpoints + -- defined in the module this 'InternalModBreaks' corresponds to. It + -- /does not/ necessarily have information regarding all the breakpoint + -- occurrences registered in 'imodBreaks_breakInfo'. Some of those + -- occurrences may refer breakpoints inlined from other modules. + } + +-- | Construct an 'InternalModBreaks'. +-- +-- INVARIANT: The given 'ModBreaks' correspond to the same module as this +-- 'InternalModBreaks' module (the first argument) and its breakpoint infos +-- (the @IntMap CgBreakInfo@ argument) +mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks +mkInternalModBreaks mod im mbs = + assertPpr (mod == modBreaks_module mbs) + (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $ + InternalModBreaks im mbs + +-- | Get the module to which these 'InternalModBreaks' correspond +imodBreaks_module :: InternalModBreaks -> Module +imodBreaks_module = modBreaks_module . imodBreaks_modBreaks + +-- | Information about a breakpoint that we know at code-generation time +-- In order to be used, this needs to be hydrated relative to the current HscEnv by +-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for +-- preventing space leaks (see #22530) +data CgBreakInfo + = CgBreakInfo + { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint + , cgb_vars :: ![Maybe (IfaceIdBndr, Word)] + , cgb_resty :: !IfaceType + , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId) + -- ^ This field records the original breakpoint tick identifier for this + -- internal breakpoint info. It is used to convert a breakpoint + -- *occurrence* index ('InternalBreakpointId') into a *definition* index + -- ('BreakpointId'). + -- + -- The modules of breakpoint occurrence and breakpoint definition are not + -- necessarily the same: See Note [Breakpoint identifiers]. + -- + -- If there is no original tick identifier (that is, the breakpoint was + -- created during code generation), we re-use the BreakpointId of something else. + -- It would also be reasonable to have an @Either something BreakpointId@ + -- for @cgb_tick_id@, but currently we can always re-use a source-level BreakpointId. + -- In the case of step-out, see Note [Debugger: Stepout internal break locs] + } +-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval + +-- | Breakpoints created during code generation don't have a source-level tick +-- location. Instead, we re-use an existing one. +newtype InternalBreakLoc = InternalBreakLoc { internalBreakLoc :: BreakpointId } + deriving newtype (Eq, NFData, Outputable) + +-- | Get an internal breakpoint info by 'InternalBreakpointId' +getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo +getInternalBreak (InternalBreakpointId mod ix) imbs = + assert_modules_match mod (imodBreaks_module imbs) $ + imodBreaks_breakInfo imbs IM.! ix + +-- | Assert that the module in the 'InternalBreakpointId' and in +-- 'InternalModBreaks' match. +assert_modules_match :: Module -> Module -> a -> a +assert_modules_match ibi_mod imbs_mod = + assertPpr (ibi_mod == imbs_mod) + (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod + <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod) + +-------------------------------------------------------------------------------- +-- Tick-level Breakpoint information +-------------------------------------------------------------------------------- + +-- | Get the source module and tick index for this breakpoint +-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId') +getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId +getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in either internalBreakLoc id (cgb_tick_id cgb) + +-- | Get the source module for this breakpoint (where the breakpoint is defined) +getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module +getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + in either (bi_tick_mod . internalBreakLoc) bi_tick_mod (cgb_tick_id cgb) + +-- | Get the source span for this breakpoint +getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan +getBreakLoc = getBreakXXX modBreaks_locs + +-- | Get the vars for this breakpoint +getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName] +getBreakVars = getBreakXXX modBreaks_vars + +-- | Get the decls for this breakpoint +getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] +getBreakDecls = getBreakXXX modBreaks_decls + +-- | Get the decls for this breakpoint +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String)) +getBreakCCS = getBreakXXX modBreaks_ccs + +-- | Internal utility to access a ModBreaks field at a particular breakpoint index +-- +-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the +-- *occurrence* module) doesn't necessarily match the module where the +-- tick breakpoint was defined with the relevant 'ModBreaks'. +-- +-- When the tick module is the same as the internal module, we use the stored +-- 'ModBreaks'. When the tick module is different, we need to look up the +-- 'ModBreaks' in the HUG for that other module. +-- +-- When there is no tick module (the breakpoint was generated at codegen), use +-- the function on internal mod breaks. +-- +-- To avoid cyclic dependencies, we instead receive a function that looks up +-- the 'ModBreaks' given a 'Module' +getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a +getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs = + assert_modules_match ibi_mod (imodBreaks_module imbs) $ do + let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix + case either internalBreakLoc id (cgb_tick_id cgb) of + BreakpointId{bi_tick_mod, bi_tick_index} + | bi_tick_mod == ibi_mod + -> do + let these_mbs = imodBreaks_modBreaks imbs + return $ view these_mbs ! bi_tick_index + | otherwise + -> do + other_mbs <- lookupModule bi_tick_mod + return $ view other_mbs ! bi_tick_index + +-------------------------------------------------------------------------------- +-- Instances +-------------------------------------------------------------------------------- + +-- | Fully force an 'InternalModBreaks' value +seqInternalModBreaks :: InternalModBreaks -> () +seqInternalModBreaks InternalModBreaks{..} = + rnf (fmap seqCgBreakInfo imodBreaks_breakInfo) + where + seqCgBreakInfo :: CgBreakInfo -> () + seqCgBreakInfo CgBreakInfo{..} = + rnf cgb_tyvars `seq` + rnf cgb_vars `seq` + rnf cgb_resty `seq` + rnf cgb_tick_id + +instance Outputable InternalBreakpointId where + ppr InternalBreakpointId{..} = + text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index + +instance NFData InternalBreakpointId where + rnf InternalBreakpointId{..} = + rnf ibi_info_mod `seq` rnf ibi_info_index + +instance Outputable CgBreakInfo where + ppr info = text "CgBreakInfo" <+> + parens (ppr (cgb_vars info) <+> + ppr (cgb_resty info) <+> + ppr (cgb_tick_id info)) diff --git a/GHC/ByteCode/InfoTable.hs b/GHC/ByteCode/InfoTable.hs --- a/GHC/ByteCode/InfoTable.hs +++ b/GHC/ByteCode/InfoTable.hs @@ -13,19 +13,17 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.ByteCode.Types -import GHC.Runtime.Interpreter +import GHCi.Message import GHC.Types.Name ( Name, getName ) -import GHC.Types.Name.Env import GHC.Types.RepType import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) -import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) +import GHC.Core.TyCon ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDataCons ) import GHC.Core.Multiplicity ( scaledThing ) import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) -import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) +import GHC.StgToCmm.Closure ( tagForCon ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -35,33 +33,38 @@ -} -- Make info tables for the data decls in this module -mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv -mkITbls interp profile tcs = - foldr plusNameEnv emptyNameEnv <$> - mapM mkITbl (filter isDataTyCon tcs) +mkITbls :: Profile -> [TyCon] -> [(Name, ConInfoTable)] +mkITbls profile tcs = concatMap mkITbl (filter isBoxedDataTyCon tcs) where - mkITbl :: TyCon -> IO ItblEnv + mkITbl :: TyCon -> [(Name, ConInfoTable)] mkITbl tc | dcs `lengthIs` n -- paranoia; this is an assertion. - = make_constr_itbls interp profile dcs + = make_constr_itbls profile dcs where dcs = tyConDataCons tc n = tyConFamilySize tc mkITbl _ = panic "mkITbl" -mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv -mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] - -- Assumes constructors are numbered from zero, not one -make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv -make_constr_itbls interp profile cons = +make_constr_itbls :: Profile -> [DataCon] -> [(Name, ConInfoTable)] +make_constr_itbls profile cons = -- TODO: the profile should be bundled with the interpreter: the rts ways are -- fixed for an interpreter - mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) - where - mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) - mk_itbl dcon conNo = do - let rep_args = [ NonVoid prim_rep + map (uncurry mk_itbl) (zip cons [0..]) + where + mk_itbl :: DataCon -> Int -> (Name, ConInfoTable) + mk_itbl dcon conNo = + ( getName dcon, + ConInfoTable + tables_next_to_code + ptrs' + nptrs_really + conNo + (tagForCon platform dcon) + descr + ) + where + rep_args = [ prim_rep | arg <- dataConRepArgTys dcon , prim_rep <- typePrimRep (scaledThing arg) ] @@ -79,7 +82,3 @@ platform = profilePlatform profile constants = platformConstants platform tables_next_to_code = platformTablesNextToCode platform - - r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really - conNo (tagForCon platform dcon) descr) - return (getName dcon, ItblPtr r) diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs --- a/GHC/ByteCode/Instr.hs +++ b/GHC/ByteCode/Instr.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -14,12 +14,12 @@ import GHC.Prelude import GHC.ByteCode.Types -import GHCi.RemoteTypes -import GHCi.FFI (C_ffi_cif) +import GHC.Cmm.Type (Width) import GHC.StgToCmm.Layout ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Literal +import GHC.Types.Unique import GHC.Core.DataCon import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout ( StgWord ) @@ -27,10 +27,12 @@ import Data.Int import Data.Word -import GHC.Stack.CCS (CostCentre) +#if MIN_VERSION_rts(1,0,3) +import Data.ByteString (ByteString) +#endif + import GHC.Stg.Syntax -import Language.Haskell.Syntax.Module.Name (ModuleName) -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -44,15 +46,17 @@ protoBCOBitmapSize :: Word, protoBCOArity :: Int, -- what the BCO came from, for debugging only - protoBCOExpr :: Either [CgStgAlt] CgStgRhs, - -- malloc'd pointers - protoBCOFFIs :: [FFIInfo] + protoBCOExpr :: Either [CgStgAlt] CgStgRhs } -- | A local block label (e.g. identifying a case alternative). newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 } deriving (Eq, Ord) +-- Just so we can easily juse UniqFM. +instance Uniquable LocalLabel where + getUnique (LocalLabel w) = mkUniqueGrimily $ fromIntegral w + instance Outputable LocalLabel where ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl @@ -129,7 +133,18 @@ | PUSH_APPLY_PPPPP | PUSH_APPLY_PPPPPP - | SLIDE !WordOff{-this many-} !WordOff{-down by this much-} + -- | Drop entries @(n, n+by]@ entries from the stack. Graphically: + -- @ + -- a_1 ← top + -- ... + -- a_n + -- b_1 => a_1 ← top + -- ... ... + -- b_by a_n + -- k k + -- @ + | SLIDE !WordOff -- ^ n = this many + !WordOff -- ^ by = down by this much -- To do with the heap | ALLOC_AP !HalfWord {- make an AP with this many payload words. @@ -174,7 +189,12 @@ -- The Word16 value is a constructor number and therefore -- stored in the insn stream rather than as an offset into -- the literal pool. + + -- | Test whether the tag of a closure pointer is less than the given value. + -- If not, jump to the given label. | TESTLT_P !Word16 LocalLabel + -- | Test whether the tag of a closure pointer is equal to the given value. + -- If not, jump to the given label. | TESTEQ_P !Word16 LocalLabel | CASEFAIL @@ -182,7 +202,7 @@ -- For doing calls to C (via glue code generated by libffi) | CCALL !WordOff -- stack frame size - (RemotePtr C_ffi_cif) -- addr of the glue code + !FFIInfo -- libffi ffi_cif function prototype !Word16 -- flags. -- -- 0x1: call is interruptible @@ -193,6 +213,39 @@ | PRIMCALL + -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide + -- instructions. But for generating code it's handy to have the width as argument + -- to avoid duplication. + | OP_ADD !Width + | OP_SUB !Width + | OP_AND !Width + | OP_XOR !Width + | OP_MUL !Width + | OP_SHL !Width + | OP_ASR !Width + | OP_LSR !Width + | OP_OR !Width + + | OP_NOT !Width + | OP_NEG !Width + + | OP_NEQ !Width + | OP_EQ !Width + + | OP_U_LT !Width + | OP_U_GE !Width + | OP_U_GT !Width + | OP_U_LE !Width + + | OP_S_LT !Width + | OP_S_GE !Width + | OP_S_GT !Width + | OP_S_LE !Width + + -- Always puts at least a machine word on the stack. + -- We zero extend the result we put on the stack according to host byte order. + | OP_INDEX_ADDR !Width + -- For doing magic ByteArray passing to foreign calls | SWIZZLE !WordOff -- to the ptr N words down the stack, !Int -- add M @@ -205,8 +258,24 @@ -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode -- Breakpoints - | BRK_FUN !Word16 (RemotePtr ModuleName) (RemotePtr CostCentre) + | BRK_FUN !InternalBreakpointId +#if MIN_VERSION_rts(1,0,3) + -- | A "meta"-instruction for recording the name of a BCO for debugging purposes. + -- These are ignored by the interpreter but helpfully printed by the disassmbler. + | BCO_NAME !ByteString +#endif + + +{- Note [BCO_NAME] + ~~~~~~~~~~~~~~~ + The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag. + When enabled the bytecode assembler will prepend a BCO_NAME instruction to every + generated bytecode object capturing the STG name of the binding the BCO implements. + This is then printed by the bytecode disassembler, allowing bytecode objects to be + readily correlated with their STG and Core source. + -} + -- ----------------------------------------------------------------------------- -- Printing bytecode instructions @@ -216,10 +285,9 @@ , protoBCOBitmap = bitmap , protoBCOBitmapSize = bsize , protoBCOArity = arity - , protoBCOExpr = origin - , protoBCOFFIs = ffis }) + , protoBCOExpr = origin }) = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity - <+> text (show ffis) <> colon) + <> colon) $$ nest 3 (case origin of Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';')) @@ -343,22 +411,55 @@ ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab ppr CASEFAIL = text "CASEFAIL" ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshal_addr flags) = text "CCALL " <+> ppr off + ppr (CCALL off ffi flags) = text "CCALL " <+> ppr off <+> text "marshal code at" - <+> text (show marshal_addr) + <+> text (show ffi) <+> (case flags of 0x1 -> text "(interruptible)" 0x2 -> text "(unsafe)" _ -> empty) ppr PRIMCALL = text "PRIMCALL" + + ppr (OP_ADD w) = text "OP_ADD_" <> ppr w + ppr (OP_SUB w) = text "OP_SUB_" <> ppr w + ppr (OP_AND w) = text "OP_AND_" <> ppr w + ppr (OP_XOR w) = text "OP_XOR_" <> ppr w + ppr (OP_OR w) = text "OP_OR_" <> ppr w + ppr (OP_NOT w) = text "OP_NOT_" <> ppr w + ppr (OP_NEG w) = text "OP_NEG_" <> ppr w + ppr (OP_MUL w) = text "OP_MUL_" <> ppr w + ppr (OP_SHL w) = text "OP_SHL_" <> ppr w + ppr (OP_ASR w) = text "OP_ASR_" <> ppr w + ppr (OP_LSR w) = text "OP_LSR_" <> ppr w + + ppr (OP_EQ w) = text "OP_EQ_" <> ppr w + ppr (OP_NEQ w) = text "OP_NEQ_" <> ppr w + ppr (OP_S_LT w) = text "OP_S_LT_" <> ppr w + ppr (OP_S_GE w) = text "OP_S_GE_" <> ppr w + ppr (OP_S_GT w) = text "OP_S_GT_" <> ppr w + ppr (OP_S_LE w) = text "OP_S_LE_" <> ppr w + ppr (OP_U_LT w) = text "OP_U_LT_" <> ppr w + ppr (OP_U_GE w) = text "OP_U_GE_" <> ppr w + ppr (OP_U_GT w) = text "OP_U_GT_" <> ppr w + ppr (OP_U_LE w) = text "OP_U_LE_" <> ppr w + + ppr (OP_INDEX_ADDR w) = text "OP_INDEX_ADDR_" <> ppr w + ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN index _mod_name _cc) = text "BRK_FUN" <+> ppr index <+> text "" <+> text "" + ppr (BRK_FUN (InternalBreakpointId info_mod infox)) + = text "BRK_FUN" <+> text "" + <+> ppr info_mod <+> ppr infox + <+> text "" +#if MIN_VERSION_rts(1,0,3) + ppr (BCO_NAME nm) = text "BCO_NAME" <+> text (show nm) +#endif + -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn. These _must_ be -- correct, or overestimates of reality, to be safe. @@ -451,6 +552,31 @@ bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall +bciStackUse OP_ADD{} = 0 -- We overestimate, it's -1 actually ... +bciStackUse OP_SUB{} = 0 +bciStackUse OP_AND{} = 0 +bciStackUse OP_XOR{} = 0 +bciStackUse OP_OR{} = 0 +bciStackUse OP_NOT{} = 0 +bciStackUse OP_NEG{} = 0 +bciStackUse OP_MUL{} = 0 +bciStackUse OP_SHL{} = 0 +bciStackUse OP_ASR{} = 0 +bciStackUse OP_LSR{} = 0 + +bciStackUse OP_NEQ{} = 0 +bciStackUse OP_EQ{} = 0 +bciStackUse OP_S_LT{} = 0 +bciStackUse OP_S_GT{} = 0 +bciStackUse OP_S_LE{} = 0 +bciStackUse OP_S_GE{} = 0 +bciStackUse OP_U_LT{} = 0 +bciStackUse OP_U_GT{} = 0 +bciStackUse OP_U_LE{} = 0 +bciStackUse OP_U_GE{} = 0 + +bciStackUse OP_INDEX_ADDR{} = 0 + bciStackUse SWIZZLE{} = 0 bciStackUse BRK_FUN{} = 0 @@ -460,3 +586,6 @@ bciStackUse MKAP{} = 0 bciStackUse MKPAP{} = 0 bciStackUse PACK{} = 1 -- worst case is PACK 0 words +#if MIN_VERSION_rts(1,0,3) +bciStackUse BCO_NAME{} = 0 +#endif diff --git a/GHC/ByteCode/Linker.hs b/GHC/ByteCode/Linker.hs --- a/GHC/ByteCode/Linker.hs +++ b/GHC/ByteCode/Linker.hs @@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- -- (c) The University of Glasgow 2002-2006 @@ -11,7 +14,6 @@ ( linkBCO , lookupStaticPtr , lookupIE - , nameToCLabel , linkFail ) where @@ -22,21 +24,20 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO -import GHCi.BreakArray import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids -import GHC.Builtin.Names +import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Data.FastString +import GHC.Data.Maybe import GHC.Data.SizedSeq import GHC.Linker.Types import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Outputable import GHC.Types.Name @@ -44,8 +45,6 @@ import qualified GHC.Types.Id as Id import GHC.Types.Unique.DFM -import Language.Haskell.Syntax.Module.Name - -- Standard libraries import Data.Array.Unboxed import Foreign.Ptr @@ -59,22 +58,27 @@ :: Interp -> PkgsLoaded -> LinkerEnv + -> LinkedBreaks -> NameEnv Int - -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp pkgs_loaded le bco_ix breakarray +linkBCO interp pkgs_loaded le lb bco_ix (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do -- fromIntegral Word -> Word64 should be a no op if Word is Word64 -- otherwise it will result in a cast to longlong on 32bit systems. - lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0) - ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix breakarray) (ssElts ptrs0) - return (ResolvedBCO isLittleEndian arity insns bitmap - (listArray (0, fromIntegral (sizeSS lits0)-1) lits) - (addListToSS emptySS ptrs)) + (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0) + let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits + return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian + , resolvedBCOArity = arity + , resolvedBCOInstrs = insns + , resolvedBCOBitmap = bitmap + , resolvedBCOLits = mkBCOByteArray lits' + , resolvedBCOPtrs = addListToSS emptySS ptrs + } -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word -lookupLiteral interp pkgs_loaded le ptr = case ptr of +lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word +lookupLiteral interp pkgs_loaded le lb ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym @@ -85,36 +89,49 @@ BCONPtrAddr nm -> do Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm return (W# (int2Word# (addr2Int# a#))) - BCONPtrStr _ -> - -- should be eliminated during assembleBCOs - panic "lookupLiteral: BCONPtrStr" + BCONPtrStr bs -> do + RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs] + pure $ fromIntegral p + BCONPtrFS fs -> do + RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs] + pure $ fromIntegral p + BCONPtrFFIInfo (FFIInfo {..}) -> do + RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet + pure $ fromIntegral p + BCONPtrCostCentre InternalBreakpointId{..} + | interpreterProfiled interp -> do + case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of + RemotePtr p -> pure $ fromIntegral p + | otherwise -> + case toRemotePtr nullPtr of + RemotePtr p -> pure $ fromIntegral p lookupStaticPtr :: Interp -> FastString -> IO (Ptr ()) lookupStaticPtr interp addr_of_label_string = do - m <- lookupSymbol interp addr_of_label_string + m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string) case m of Just ptr -> return ptr Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" - (unpackFS addr_of_label_string) + (ppr addr_of_label_string) lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) lookupIE interp pkgs_loaded ie con_nm = case lookupNameEnv ie con_nm of Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. - let sym_to_find1 = nameToCLabel con_nm "con_info" - m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info" + let sym_to_find1 = IConInfoSymbol con_nm + m <- lookupHsSymbol interp pkgs_loaded sym_to_find1 case m of Just addr -> return addr Nothing -> do -- perhaps a nullary constructor? - let sym_to_find2 = nameToCLabel con_nm "static_info" - n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info" + let sym_to_find2 = IStaticInfoSymbol con_nm + n <- lookupHsSymbol interp pkgs_loaded sym_to_find2 case n of Just addr -> return addr Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" - (unpackFS sym_to_find1 ++ " or " ++ - unpackFS sym_to_find2) + (ppr sym_to_find1 <> " or " <> + ppr sym_to_find2) -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) @@ -122,31 +139,31 @@ case lookupNameEnv ae addr_nm of Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) Nothing -> do -- try looking up in the object files. - let sym_to_find = nameToCLabel addr_nm "bytes" + let sym_to_find = IBytesSymbol addr_nm -- see Note [Bytes label] in GHC.Cmm.CLabel - m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes" + m <- lookupHsSymbol interp pkgs_loaded sym_to_find case m of Just ptr -> return ptr Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" - (unpackFS sym_to_find) + (ppr sym_to_find) lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) lookupPrimOp interp pkgs_loaded primop = do let sym_to_find = primopToCLabel primop "closure" - m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure" + m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop)) case m of Just p -> return (toRemotePtr p) - Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find) resolvePtr :: Interp -> PkgsLoaded -> LinkerEnv + -> LinkedBreaks -> NameEnv Int - -> RemoteRef BreakArray -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp pkgs_loaded le bco_ix breakarray ptr = case ptr of +resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group @@ -157,30 +174,30 @@ | otherwise -> assertPpr (isExternalName nm) (ppr nm) $ do - let sym_to_find = nameToCLabel nm "closure" - m <- lookupHsSymbol interp pkgs_loaded nm "closure" + let sym_to_find = IClosureSymbol nm + m <- lookupHsSymbol interp pkgs_loaded sym_to_find case m of Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) - Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) + Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find) BCOPtrPrimOp op -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix breakarray bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco - BCOPtrBreakArray - -> return (ResolvedBCOPtrBreakArray breakarray) + BCOPtrBreakArray tick_mod -> + withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $ + \ba -> pure $ ResolvedBCOPtrBreakArray ba -- | Look up the address of a Haskell symbol in the currently -- loaded units. -- -- See Note [Looking up symbols in the relevant objects]. -lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ())) -lookupHsSymbol interp pkgs_loaded nm sym_suffix = do - massertPpr (isExternalName nm) (ppr nm) - let sym_to_find = nameToCLabel nm sym_suffix - pkg_id = moduleUnitId $ nameModule nm +lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ())) +lookupHsSymbol interp pkgs_loaded sym_to_find = do + massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find) + let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find) loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id go (dll:dlls) = do @@ -194,12 +211,12 @@ go loaded_dlls -linkFail :: String -> String -> IO a +linkFail :: String -> SDoc -> IO a linkFail who what = throwGhcExceptionIO (ProgramError $ unlines [ "",who , "During interactive linking, GHCi couldn't find the following symbol:" - , ' ' : ' ' : what + , ' ' : ' ' : showSDocUnsafe what , "This may be due to you not asking GHCi to load extra object files," , "archives or DLLs needed by your current session. Restart GHCi, specifying" , "the missing library using the -L/path/to/object/dir and -lmissinglibname" @@ -210,31 +227,14 @@ ]) -nameToCLabel :: Name -> String -> FastString -nameToCLabel n suffix = mkFastString label - where - encodeZ = zString . zEncodeFS - (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of - -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers - -- See Note [Primop wrappers] in GHC.Builtin.PrimOps. - mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS - mod -> mod - packagePart = encodeZ (unitFS pkgKey) - modulePart = encodeZ (moduleNameFS modName) - occPart = encodeZ $ occNameMangledFS (nameOccName n) - label = concat - [ if pkgKey == mainUnit then "" else packagePart ++ "_" - , modulePart - , '_':occPart - , '_':suffix - ] + -- See Note [Primop wrappers] in GHC.Builtin.PrimOps primopToCLabel :: PrimOp -> String -> String primopToCLabel primop suffix = concat - [ "ghczmprim_GHCziPrimopWrappers_" + [ "ghczminternal_GHCziInternalziPrimopWrappers_" , zString (zEncodeFS (occNameFS (primOpOcc primop))) , '_':suffix ] diff --git a/GHC/ByteCode/Types.hs b/GHC/ByteCode/Types.hs --- a/GHC/ByteCode/Types.hs +++ b/GHC/ByteCode/Types.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedNewtypes #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -8,6 +11,7 @@ -- | Bytecode assembler types module GHC.ByteCode.Types ( CompiledByteCode(..), seqCompiledByteCode + , BCOByteArray(..), mkBCOByteArray , FFIInfo(..) , RegBitmap(..) , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo @@ -15,64 +19,83 @@ , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) , ItblEnv, ItblPtr(..) , AddrEnv, AddrPtr(..) - , CgBreakInfo(..) - , ModBreaks (..), BreakIndex, emptyModBreaks - , CCostCentre + , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag + + -- * Mod Breaks + , ModBreaks (..), BreakpointId(..), BreakTickIndex + + -- * Internal Mod Breaks + , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks + -- ** Internal breakpoint identifier + , InternalBreakpointId(..), BreakInfoIndex ) where import GHC.Prelude import GHC.Data.FastString -import GHC.Data.SizedSeq +import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps -import GHC.Types.SrcLoc -import GHCi.BreakArray +import GHC.Types.SptEntry +import GHC.HsToCore.Breakpoints +import GHC.ByteCode.Breakpoints +import GHCi.Message import GHCi.RemoteTypes import GHCi.FFI import Control.DeepSeq +import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray ) import Foreign -import Data.Array -import Data.Array.Base ( UArray(..) ) import Data.ByteString (ByteString) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import qualified GHC.Exts.Heap as Heap -import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList ) -import GHC.Iface.Syntax -import Language.Haskell.Syntax.Module.Name (ModuleName) +import GHC.Unit.Module -- ----------------------------------------------------------------------------- -- Compiled Byte Code data CompiledByteCode = CompiledByteCode - { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings - , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls - , bc_ffis :: [FFIInfo] -- ffi blocks we allocated - , bc_strs :: AddrEnv -- malloc'd top-level strings - , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not - -- creating breakpoints, for some reason) + { bc_bcos :: FlatBag UnlinkedBCO + -- ^ Bunch of interpretable bindings + + , bc_itbls :: [(Name, ConInfoTable)] + -- ^ Mapping from DataCons to their info tables + + , bc_strs :: [(Name, ByteString)] + -- ^ top-level strings (heap allocated) + + , bc_breaks :: Maybe InternalModBreaks + -- ^ All breakpoint information (no information if breakpoints are disabled). + -- + -- This information is used when loading a bytecode object: we will + -- construct the arrays to be used at runtime to trigger breakpoints at load time + -- from it (in 'allocateBreakArrays' and 'allocateCCS' in 'GHC.ByteCode.Loader'). + + , bc_spt_entries :: ![SptEntry] + -- ^ Static pointer table entries which should be loaded along with the + -- BCOs. See Note [Grand plan for static forms] in + -- "GHC.Iface.Tidy.StaticPtrTable". } - -- ToDo: we're not tracking strings that we malloc'd -newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) - deriving (Show, NFData) +-- | A libffi ffi_cif function prototype. +data FFIInfo = FFIInfo { ffiInfoArgs :: ![FFIType], ffiInfoRet :: !FFIType } + deriving (Show) + instance Outputable CompiledByteCode where - ppr CompiledByteCode{..} = ppr bc_bcos + ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos -- Not a real NFData instance, because ModBreaks contains some things -- we can't rnf seqCompiledByteCode :: CompiledByteCode -> () seqCompiledByteCode CompiledByteCode{..} = rnf bc_bcos `seq` - seqEltsNameEnv rnf bc_itbls `seq` - rnf bc_ffis `seq` - seqEltsNameEnv rnf bc_strs `seq` - rnf (fmap seqModBreaks bc_breaks) + rnf bc_itbls `seq` + rnf bc_strs `seq` + case bc_breaks of + Nothing -> () + Just ibks -> seqInternalModBreaks ibks newtype ByteOff = ByteOff Int deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) @@ -148,14 +171,88 @@ newtype AddrPtr = AddrPtr (RemotePtr ()) deriving (NFData) +{- +-------------------------------------------------------------------------------- +-- * Byte Code Objects (BCOs) +-------------------------------------------------------------------------------- + +Note [Case continuation BCOs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A stack with a BCO stack frame at the top looks like: + + (an StgBCO) + | ... | +---> +---------[1]--+ + +------------------+ | | info_tbl_ptr | ------+ + | OTHER FRAME | | +--------------+ | + +------------------+ | | StgArrBytes* | <--- the byte code + | ... | | +--------------+ | + +------------------+ | | ... | | + | fvs1 | | | + +------------------+ | | + | ... | | (StgInfoTable) | + +------------------+ | +----------+ <---+ + | args1 | | | ... | + +------------------+ | +----------+ + | some StgBCO* | -----+ | type=BCO | + +------------------+ +----------+ + Sp | stg_apply_interp | -----+ | ... | + +------------------+ | + | + | (StgInfoTable) + +----> +--------------+ + | ... | + +--------------+ + | type=RET_BCO | + +--------------+ + | ... | + + +In the case of bytecode objects found on the heap (e.g. thunks and functions), +the bytecode may refer to free variables recorded in the BCO closure itself. +By contrast, in /case continuation/ BCOs the code may additionally refer to free +variables in their stack frame. These are references by way of statically known +stack offsets (tracked using `BCEnv` in `StgToByteCode`). + +For instance, consider the function: + + f x y = case y of ... -> g x + +Here the RHS of the alternative refers to `x`, which will be recorded in the +continuation stack frame of the `case`. + +Even less obvious is that case continuation BCOs may also refer to free +variables in *parent* stack frames. For instance, + + f x y = case y of + ... -> case g x of + ... -> x + +Here, the RHS of the first alternative still refers to the `x` in the stack +frame of the `case`. Additionally, the RHS of the second alternative also +refers to `x` but it must traverse to its case's *parent* stack frame to find `x`. + +However, in /case continuation/ BCOs, the code may additionally refer to free +variables that are outside of that BCO's stack frame -- some free variables of a +case continuation BCO may only be found in the stack frame of a parent BCO. + +Yet, references to these out-of-frame variables are also done in terms of stack +offsets. Thus, they rely on the position of /another frame/ to be fixed. (See +Note [PUSH_L underflow] for more information about references to previous +frames and nested BCOs) + +This makes case continuation BCOs special: unlike normal BCOs, case cont BCO +frames cannot be moved on the stack independently from their parent BCOs. +-} + data UnlinkedBCO = UnlinkedBCO { unlinkedBCOName :: !Name, unlinkedBCOArity :: {-# UNPACK #-} !Int, - unlinkedBCOInstrs :: !(UArray Int Word16), -- insns - unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap - unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs - unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs + unlinkedBCOInstrs :: !(BCOByteArray Word16), -- insns + unlinkedBCOBitmap :: !(BCOByteArray Word), -- bitmap + unlinkedBCOLits :: !(FlatBag BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(FlatBag BCOPtr) -- ptrs } instance NFData UnlinkedBCO where @@ -167,7 +264,8 @@ = BCOPtrName !Name | BCOPtrPrimOp !PrimOp | BCOPtrBCO !UnlinkedBCO - | BCOPtrBreakArray -- a pointer to this module's BreakArray + | BCOPtrBreakArray !Module + -- ^ Converted to the actual 'BreakArray' remote pointer at link-time instance NFData BCOPtr where rnf (BCOPtrBCO bco) = rnf bco @@ -180,100 +278,22 @@ -- | A reference to a top-level string literal; see -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. | BCONPtrAddr !Name - -- | Only used internally in the assembler in an intermediate representation; - -- should never appear in a fully-assembled UnlinkedBCO. + -- | A top-level string literal. -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm. | BCONPtrStr !ByteString + -- | Same as 'BCONPtrStr' but with benefits of 'FastString' interning logic. + | BCONPtrFS !FastString + -- | A libffi ffi_cif function prototype. + | BCONPtrFFIInfo !FFIInfo + -- | A 'CostCentre' remote pointer array's respective 'BreakpointId' + | BCONPtrCostCentre !InternalBreakpointId instance NFData BCONPtr where rnf x = x `seq` () --- | Information about a breakpoint that we know at code-generation time --- In order to be used, this needs to be hydrated relative to the current HscEnv by --- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for --- preventing space leaks (see #22530) -data CgBreakInfo - = CgBreakInfo - { cgb_tyvars :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint - , cgb_vars :: ![Maybe (IfaceIdBndr, Word)] - , cgb_resty :: !IfaceType - } --- See Note [Syncing breakpoint info] in GHC.Runtime.Eval - -seqCgBreakInfo :: CgBreakInfo -> () -seqCgBreakInfo CgBreakInfo{..} = - rnf cgb_tyvars `seq` - rnf cgb_vars `seq` - rnf cgb_resty - instance Outputable UnlinkedBCO where ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) = sep [text "BCO", ppr nm, text "with", - ppr (sizeSS lits), text "lits", - ppr (sizeSS ptrs), text "ptrs" ] - -instance Outputable CgBreakInfo where - ppr info = text "CgBreakInfo" <+> - parens (ppr (cgb_vars info) <+> - ppr (cgb_resty info)) - --- ----------------------------------------------------------------------------- --- Breakpoints - --- | Breakpoint index -type BreakIndex = Int - --- | C CostCentre type -data CCostCentre - --- | All the information about the breakpoints for a module -data ModBreaks - = ModBreaks - { modBreaks_flags :: ForeignRef BreakArray - -- ^ The array of flags, one per breakpoint, - -- indicating which breakpoints are enabled. - , modBreaks_locs :: !(Array BreakIndex SrcSpan) - -- ^ An array giving the source span of each breakpoint. - , modBreaks_vars :: !(Array BreakIndex [OccName]) - -- ^ An array giving the names of the free variables at each breakpoint. - , modBreaks_decls :: !(Array BreakIndex [String]) - -- ^ An array giving the names of the declarations enclosing each breakpoint. - -- See Note [Field modBreaks_decls] - , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) - -- ^ Array pointing to cost centre for each breakpoint - , modBreaks_breakInfo :: IntMap CgBreakInfo - -- ^ info about each breakpoint from the bytecode generator - , modBreaks_module :: RemotePtr ModuleName - } - -seqModBreaks :: ModBreaks -> () -seqModBreaks ModBreaks{..} = - rnf modBreaks_flags `seq` - rnf modBreaks_locs `seq` - rnf modBreaks_vars `seq` - rnf modBreaks_decls `seq` - rnf modBreaks_ccs `seq` - rnf (fmap seqCgBreakInfo modBreaks_breakInfo) `seq` - rnf modBreaks_module - --- | Construct an empty ModBreaks -emptyModBreaks :: ModBreaks -emptyModBreaks = ModBreaks - { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" - -- ToDo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] - , modBreaks_decls = array (0,-1) [] - , modBreaks_ccs = array (0,-1) [] - , modBreaks_breakInfo = IntMap.empty - , modBreaks_module = toRemotePtr nullPtr - } + ppr (sizeFlatBag lits), text "lits", + ppr (sizeFlatBag ptrs), text "ptrs" ] -{- -Note [Field modBreaks_decls] -~~~~~~~~~~~~~~~~~~~~~~ -A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means: -The breakpoint is in the function called "baz" that is declared in a `let` -or `where` clause of a declaration called "bar", which itself is declared -in a `let` or `where` clause of the top-level function called "foo". --} diff --git a/GHC/Cmm.hs b/GHC/Cmm.hs --- a/GHC/Cmm.hs +++ b/GHC/Cmm.hs @@ -12,22 +12,28 @@ module GHC.Cmm ( -- * Cmm top-level datatypes + DCmmGroup, CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, - CmmDecl, CmmDeclSRTs, GenCmmDecl(..), - CmmDataDecl, cmmDataDeclCmmDecl, - CmmGraph, GenCmmGraph(..), + CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..), + CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph, + CmmGraph, GenCmmGraph, GenGenCmmGraph(..), toBlockMap, revPostorder, toBlockList, CmmBlock, RawCmmDecl, Section(..), SectionType(..), GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..), SectionProtection(..), sectionProtection, + DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph, + -- ** Blocks containing lists GenBasicBlock(..), blockId, ListGraph(..), pprBBlock, -- * Info Tables - CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable, + GenCmmTopInfo(..) + , DCmmTopInfo + , CmmTopInfo + , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD, ClosureTypeInfo(..), ProfilingInfo(..), ConstrDescription, @@ -50,7 +56,6 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm.Expr import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable @@ -75,6 +80,8 @@ type CmmProgram = [CmmGroup] type GenCmmGroup d h g = [GenCmmDecl d h g] +-- | Cmm group after STG generation +type DCmmGroup = GenCmmGroup CmmStatics DCmmTopInfo DCmmGraph -- | Cmm group before SRT generation type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph -- | Cmm group with SRTs @@ -101,7 +108,7 @@ = CmmProc -- A procedure h -- Extra header such as the info table CLabel -- Entry label - [GlobalReg] -- Registers live on entry. Note that the set of live + [GlobalRegUse] -- Registers live on entry. Note that the set of live -- registers will be correct in generated C-- code, but -- not in hand-written C-- code. However, -- splitAtProcPoints calculates correct liveness @@ -118,6 +125,7 @@ => OutputableP Platform (GenCmmDecl d info i) where pdoc = pprTop +type DCmmDecl = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph type CmmDataDecl = GenCmmDataDecl CmmStatics @@ -140,7 +148,11 @@ ----------------------------------------------------------------------------- type CmmGraph = GenCmmGraph CmmNode -data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +type DCmmGraph = GenGenCmmGraph DWrap CmmNode + +type GenCmmGraph n = GenGenCmmGraph LabelMap n + +data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C } type CmmBlock = Block CmmNode C C instance OutputableP Platform CmmGraph where @@ -172,9 +184,17 @@ -- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains -- the extra info (beyond the executable code) that belongs to that CmmDecl. -data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable - , stack_info :: CmmStackInfo } +data GenCmmTopInfo f = TopInfo { info_tbls :: f CmmInfoTable + , stack_info :: CmmStackInfo } +newtype DWrap a = DWrap [(BlockId, a)] + +unDeterm :: DWrap a -> [(BlockId, a)] +unDeterm (DWrap f) = f + +type DCmmTopInfo = GenCmmTopInfo DWrap +type CmmTopInfo = GenCmmTopInfo LabelMap + instance OutputableP Platform CmmTopInfo where pdoc = pprTopInfo @@ -183,7 +203,12 @@ vcat [text "info_tbls: " <> pdoc platform info_tbl, text "stack_info: " <> ppr stack_info] -topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable +topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable +topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of + DWrap xs -> lookup (g_entry g) xs +topInfoTableD _ = Nothing + +topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable _ = Nothing @@ -238,6 +263,7 @@ = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc deriving (Eq, Ord) + ----------------------------------------------------------------------------- -- Static Data ----------------------------------------------------------------------------- @@ -305,7 +331,7 @@ ppr (CmmString _) = text "CmmString" ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp --- Static data before SRT generation +-- | Static data before or after SRT generation data GenCmmStatics (rawOnly :: Bool) where CmmStatics :: CLabel -- Label of statics @@ -328,6 +354,61 @@ type CmmStatics = GenCmmStatics 'False type RawCmmStatics = GenCmmStatics 'True + +{- +----------------------------------------------------------------------------- +-- Deterministic Cmm / Info Tables +----------------------------------------------------------------------------- + +Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consulting Note [Object determinism] one will learn that in order to produce +deterministic objects just after cmm is produced we perform a renaming pass which +provides fresh uniques for all unique-able things in the input Cmm. + +After this point, we use a deterministic unique supply (an incrementing counter) +so any resulting labels which make their way into object code have a deterministic name. + +A key assumption to this process is that the input is deterministic modulo the uniques +and the order that bindings appear in the definitions is the same. + +CmmGroup uses LabelMap in two places: + +* In CmmProc for info tables +* In CmmGraph for the blocks of the graph + +LabelMap is not a deterministic structure, so traversing a LabelMap can process +elements in different order (depending on the given uniques). + +Therefore before we do the renaming we need to use a deterministic structure, one +which we can traverse in a guaranteed order. A list does the job perfectly. + +Once the renaming happens it is converted back into a LabelMap, which is now deterministic +due to the uniques being generated and assigned in a deterministic manner. + +We prefer using the renamed LabelMap rather than the list in the rest of the +code generation because it is much more efficient than lists for the needs of +the code generator. +-} + +-- Converting out of deterministic Cmm + +removeDeterm :: DCmmGroup -> CmmGroup +removeDeterm = map removeDetermDecl + +removeDetermDecl :: DCmmDecl -> CmmDecl +removeDetermDecl (CmmProc h e r g) = CmmProc (removeDetermTop h) e r (removeDetermGraph g) +removeDetermDecl (CmmData a b) = CmmData a b + +removeDetermTop :: DCmmTopInfo -> CmmTopInfo +removeDetermTop (TopInfo a b) = TopInfo (mapFromList $ unDeterm a) b + +removeDetermGraph :: DCmmGraph -> CmmGraph +removeDetermGraph (CmmGraph x y) = + let y' = case y of + GMany a (DWrap b) c -> GMany a (mapFromList b) c + in CmmGraph x y' -- ----------------------------------------------------------------------------- -- Basic blocks consisting of lists diff --git a/GHC/Cmm/BlockId.hs b/GHC/Cmm/BlockId.hs --- a/GHC/Cmm/BlockId.hs +++ b/GHC/Cmm/BlockId.hs @@ -15,7 +15,7 @@ import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Unique -import GHC.Types.Unique.Supply +import qualified GHC.Types.Unique.DSM as DSM import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) @@ -36,8 +36,12 @@ mkBlockId :: Unique -> BlockId mkBlockId unique = mkHooplLabel $ getKey unique -newBlockId :: MonadUnique m => m BlockId -newBlockId = mkBlockId <$> getUniqueM +-- If the monad unique instance uses a deterministic unique supply, this will +-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm +-- onwards (after deterministic renaming in 'codeGen'), there should only exist +-- deterministic block labels. +newBlockId :: DSM.MonadGetUnique m => m BlockId +newBlockId = mkBlockId <$> DSM.getUniqueM blockLbl :: BlockId -> CLabel blockLbl label = mkLocalBlockLabel (getUnique label) diff --git a/GHC/Cmm/CLabel.hs b/GHC/Cmm/CLabel.hs --- a/GHC/Cmm/CLabel.hs +++ b/GHC/Cmm/CLabel.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- -- Object-file symbols (called CLabel for historical reasons). @@ -6,11 +8,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - - module GHC.Cmm.CLabel ( CLabel, -- abstract type NeedExternDecl (..), @@ -53,6 +50,7 @@ mkDirty_MUT_VAR_Label, mkMUT_VAR_CLEAN_infoLabel, mkNonmovingWriteBarrierEnabledLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, @@ -104,7 +102,7 @@ needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel, - isMathFun, + isLibcFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -127,6 +125,7 @@ toSlowEntryLbl, toEntryLbl, toInfoLbl, + toProcDelimiterLbl, -- * Pretty-printing LabelStyle (..), @@ -137,8 +136,10 @@ -- * Others dynamicLinkerLabelInfo, - addLabelSize, - foreignLabelStdcallInfo + CStubLabel (..), + cStubLabel, + fromCStubLabel, + mapInternalNonDetUniques ) where import GHC.Prelude @@ -153,7 +154,6 @@ import GHC.Types.CostCentre import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set @@ -240,10 +240,6 @@ | ForeignLabel FastString -- ^ name of the imported label. - (Maybe Int) -- ^ possible '@n' suffix for stdcall functions - -- When generating C, the '@n' suffix is omitted, but when - -- generating assembler we must add it to the label. - ForeignLabelSource -- ^ what package the foreign label is in. FunctionOrData @@ -346,29 +342,40 @@ deriving (Ord,Eq) -- This is laborious, but necessary. We can't derive Ord because --- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the --- implementation. See Note [No Ord for Unique] --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] +-- Unique has a special Ord instance that cares for object determinism. +-- Note nonDetCmpUnique and stableNameCmp in the implementation: +-- * If -fobject-determinism, the internal uniques will be renamed, thus the +-- comparison will actually be deterministic +-- * Stable name compare guarantees deterministic ordering of Names despite +-- the non-deterministic uniques underlying external names (which aren't +-- renamed on -fobject-determinism). +-- See Note [Unique Determinism and code generation] and Note [Object determinism] instance Ord CLabel where + compare (IdLabel a1 b1 c1) + (IdLabel a2 b2 c2) + | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2 + | isExternalName a1 = GT + | isExternalName a2 = LT + compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = + -- Comparing names here should deterministic because all unique should have + -- been renamed deterministically, and external names compared above. compare a1 a2 S.<> compare b1 b2 S.<> compare c1 c2 compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) = compare a1 a2 S.<> compare b1 b2 S.<> - -- This non-determinism is "safe" in the sense that it only affects object code, - -- which is currently not covered by GHC's determinism guarantees. See #12935. + -- This is not non-deterministic because the uniques have been deterministically renamed. + -- See Note [Object determinism] uniqCompareFS c1 c2 S.<> compare d1 d2 compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2 compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2 - compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) = + compare (ForeignLabel a1 b1 c1) (ForeignLabel a2 b2 c2) = uniqCompareFS a1 a2 S.<> compare b1 b2 S.<> - compare c1 c2 S.<> - compare d1 d2 + compare c1 c2 compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = compare a1 a2 S.<> @@ -470,8 +477,8 @@ RtsLabel{} -> text "RtsLabel" - ForeignLabel _name mSuffix src funOrData - -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData + ForeignLabel _name src funOrData + -> text "ForeignLabel" <+> ppr src <+> ppr funOrData _ -> text "other CLabel" @@ -641,7 +648,7 @@ -- Constructing Cmm Labels mkDirty_MUT_VAR_Label, mkNonmovingWriteBarrierEnabledLabel, - mkUpdInfoLabel, + mkOrigThunkInfoLabel, mkUpdInfoLabel, mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel, mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel, mkMAP_DIRTY_infoLabel, @@ -652,9 +659,10 @@ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel -mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction +mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData +mkOrigThunkInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame") CmmInfo mkBHUpdInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" ) CmmInfo mkIndStaticInfoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC") CmmInfo @@ -669,8 +677,8 @@ mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry -mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction -mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction +mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") ForeignLabelInExternalPackage IsFunction +mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo mkSRTInfoLabel :: Int -> CLabel @@ -754,21 +762,12 @@ -- | Make a foreign label mkForeignLabel :: FastString -- name - -> Maybe Int -- size prefix -> ForeignLabelSource -- what package it's in -> FunctionOrData -> CLabel mkForeignLabel = ForeignLabel - --- | Update the label size field in a ForeignLabel -addLabelSize :: CLabel -> Int -> CLabel -addLabelSize (ForeignLabel str _ src fod) sz - = ForeignLabel str (Just sz) src fod -addLabelSize label _ - = label - -- | Whether label is a top-level string literal isBytesLabel :: CLabel -> Bool isBytesLabel (IdLabel _ _ Bytes) = True @@ -776,7 +775,7 @@ -- | Whether label is a non-haskell label (defined in C code) isForeignLabel :: CLabel -> Bool -isForeignLabel (ForeignLabel _ _ _ _) = True +isForeignLabel (ForeignLabel _ _ _) = True isForeignLabel _lbl = False -- | Whether label is a static closure label (can come from haskell or cmm) @@ -797,6 +796,7 @@ isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True -- info table defined in cmm (.cmm) isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True +isSomeRODataLabel (CmmLabel _ _ _ CmmRetInfo) = True isSomeRODataLabel _lbl = False -- | Whether label is points to some kind of info table @@ -818,12 +818,6 @@ isConInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True isConInfoTableLabel _ = False --- | Get the label size field from a ForeignLabel -foreignLabelStdcallInfo :: CLabel -> Maybe Int -foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info -foreignLabelStdcallInfo _lbl = Nothing - - -- Constructing Large*Labels mkBitmapLabel :: Unique -> CLabel mkBitmapLabel uniq = LargeBitmapLabel uniq @@ -948,6 +942,16 @@ CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet _ -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl) +-- | Generate a CmmProc delimiter label from the actual entry label. +-- +-- This delimiter label might be the entry label itself, except when the entry +-- label is a LocalBlockLabel. If we reused the entry label to delimit the proc, +-- we would generate redundant labels (see #22792) +toProcDelimiterLbl :: CLabel -> CLabel +toProcDelimiterLbl lbl = case lbl of + LocalBlockLabel {} -> mkAsmTempDerivedLabel lbl (fsLit "_entry") + _ -> lbl + toInfoLbl :: Platform -> CLabel -> CLabel toInfoLbl platform lbl = case lbl of IdLabel n c LocalEntry -> IdLabel n c LocalInfoTable @@ -1024,7 +1028,7 @@ -- For other labels we inline one into the HC file directly. | otherwise = True -needsCDecl l@(ForeignLabel{}) = not (isMathFun l) +needsCDecl l@(ForeignLabel{}) = not (isLibcFun l) needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (IPE_Label {}) = True @@ -1051,15 +1055,19 @@ -- | Check whether a label corresponds to a C function that has --- a prototype in a system header somewhere, or is built-in --- to the C compiler. For these labels we avoid generating our --- own C prototypes. -isMathFun :: CLabel -> Bool -isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs -isMathFun _ = False +-- a prototype in a system header somewhere, or is built-in +-- to the C compiler. For these labels we avoid generating our +-- own C prototypes. +isLibcFun :: CLabel -> Bool +isLibcFun (ForeignLabel fs _ _) = fs `elementOfUniqSet` libc_funs +isLibcFun _ = False -math_funs :: UniqSet FastString -math_funs = mkUniqSet [ +libc_funs :: UniqSet FastString +libc_funs = mkUniqSet [ + --------------------- + -- Math functions + --------------------- + -- _ISOC99_SOURCE (fsLit "acos"), (fsLit "acosf"), (fsLit "acosh"), (fsLit "acoshf"), (fsLit "acoshl"), (fsLit "acosl"), @@ -1220,8 +1228,8 @@ labelType (RtsLabel (RtsSlowFastTickyCtr _)) = DataLabel labelType (LocalBlockLabel _) = CodeLabel labelType (SRTLabel _) = DataLabel -labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel -labelType (ForeignLabel _ _ _ IsData) = DataLabel +labelType (ForeignLabel _ _ IsFunction) = CodeLabel +labelType (ForeignLabel _ _ IsData) = DataLabel labelType (AsmTempLabel _) = panic "labelType(AsmTempLabel)" labelType (AsmTempDerivedLabel _ _) = panic "labelType(AsmTempDerivedLabel)" labelType (StringLitLabel _) = DataLabel @@ -1300,7 +1308,7 @@ LocalBlockLabel _ -> False - ForeignLabel _ _ source _ -> + ForeignLabel _ source _ -> if os == OSMinGW32 then case source of -- Foreign label is in some un-named foreign package (or DLL). @@ -1427,11 +1435,11 @@ -- | Style of label pretty-printing. -- --- When we produce C sources or headers, we have to take into account that C --- compilers transform C labels when they convert them into symbols. For --- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for --- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style --- or Asm style. +-- When we produce C sources or headers, we have to take into account +-- that C compilers transform C labels when they convert them into +-- symbols. For example, they can add prefixes (e.g., "_" on Darwin). +-- So we provide two ways to pretty-print CLabels: C style or Asm +-- style. -- data LabelStyle = CStyle -- ^ C label style (used by C and LLVM backends) @@ -1482,10 +1490,17 @@ -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u AsmTempDerivedLabel l suf - -> asmTempLabelPrefix platform - <> case l of AsmTempLabel u -> pprUniqueAlways u - LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabelStyle platform sty l + -- we print a derived label, so we just print the parent label + -- recursively. However we don't want to print the temp prefix (e.g. + -- ".L") twice, so we must explicitely handle these cases. + -> let skipTempPrefix = \case + AsmTempLabel u -> pprUniqueAlways u + AsmTempDerivedLabel l suf -> skipTempPrefix l <> ftext suf + LocalBlockLabel u -> pprUniqueAlways u + lbl -> pprAsmLabel platform lbl + in + asmTempLabelPrefix platform + <> skipTempPrefix l <> ftext suf DynamicLinkerLabel info lbl @@ -1507,17 +1522,9 @@ StringLitLabel u -> maybe_underscore $ pprUniqueAlways u <> text "_str" - ForeignLabel fs (Just sz) _ _ - | AsmStyle <- sty - , OSMinGW32 <- platformOS platform - -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel. - -- (The C compiler does this itself). - maybe_underscore $ ftext fs <> char '@' <> int sz - - ForeignLabel fs _ _ _ + ForeignLabel fs _ _ -> maybe_underscore $ ftext fs - IdLabel name _cafs flavor -> case sty of AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor where @@ -1692,11 +1699,7 @@ GotSymbolPtr -> ppLbl <> text "@GOTPCREL" GotSymbolOffset -> ppLbl | platformArch platform == ArchAArch64 -> ppLbl - | otherwise -> - case dllInfo of - CodeStub -> char 'L' <> ppLbl <> text "$stub" - SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr" - _ -> panic "pprDynamicLinkerAsmLabel" + | otherwise -> panic "pprDynamicLinkerAsmLabel" OSAIX -> case dllInfo of @@ -1723,7 +1726,12 @@ | platformArch platform == ArchAArch64 = ppLbl + | platformArch platform == ArchRISCV64 + = ppLbl + | platformArch platform == ArchLoongArch64 + = ppLbl + | platformArch platform == ArchX86_64 = case dllInfo of CodeStub -> ppLbl <> text "@plt" @@ -1881,3 +1889,74 @@ T15155.a_closure `mayRedirectTo` a1_rXq_closure+1 returns True. -} + +-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign +-- declarations for the purpose of serializing to interface files. +-- +-- See Note [Foreign stubs and TH bytecode linking] +data CStubLabel = + CStubLabel { + csl_is_initializer :: Bool, + csl_module :: Module, + csl_name :: FastString + } + +instance Outputable CStubLabel where + ppr CStubLabel {csl_is_initializer, csl_module, csl_name} = + text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name) + where + ini = if csl_is_initializer then "initializer" else "finalizer" + +-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an +-- initializer or finalizer. +cStubLabel :: CLabel -> Maybe CStubLabel +cStubLabel = \case + ModuleLabel csl_module label_kind -> do + (csl_is_initializer, csl_name) <- case label_kind of + MLK_Initializer (LexicalFastString s) -> Just (True, s) + MLK_Finalizer (LexicalFastString s) -> Just (False, s) + _ -> Nothing + Just (CStubLabel {csl_is_initializer, csl_module, csl_name}) + _ -> Nothing + +-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'. +fromCStubLabel :: CStubLabel -> CLabel +fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) = + ModuleLabel csl_module (label_kind (LexicalFastString csl_name)) + where + label_kind = + if csl_is_initializer + then MLK_Initializer + else MLK_Finalizer + +-- | A utility for renaming uniques in CLabels to produce deterministic object. +-- Note that not all Uniques are mapped over. Only those that can be safely alpha +-- renamed, e.g. uniques of local symbols, but not of external ones. +-- See Note [Renaming uniques deterministically]. +mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel +-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel? +mapInternalNonDetUniques f x = case x of + IdLabel name cafInfo idLabelInfo + | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo + | otherwise -> pure x + cl@CmmLabel{} -> pure cl + RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo + LocalBlockLabel unique -> LocalBlockLabel <$> f unique + fl@ForeignLabel{} -> pure fl + AsmTempLabel unique -> AsmTempLabel <$> f unique + AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs + StringLitLabel unique -> StringLitLabel <$> f unique + CC_Label cc -> pure $ CC_Label cc + CCS_Label ccs -> pure $ CCS_Label ccs + IPE_Label ipe@InfoProvEnt{infoTablePtr} -> + (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr + ml@ModuleLabel{} -> pure ml + DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl + PicBaseLabel -> pure PicBaseLabel + DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl + HpcTicksLabel mod -> pure $ HpcTicksLabel mod + SRTLabel unique -> SRTLabel <$> f unique + LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique +-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma: +{-# INLINABLE mapInternalNonDetUniques #-} + diff --git a/GHC/Cmm/CallConv.hs b/GHC/Cmm/CallConv.hs --- a/GHC/Cmm/CallConv.hs +++ b/GHC/Cmm/CallConv.hs @@ -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. +-} diff --git a/GHC/Cmm/CommonBlockElim.hs b/GHC/Cmm/CommonBlockElim.hs --- a/GHC/Cmm/CommonBlockElim.hs +++ b/GHC/Cmm/CommonBlockElim.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} module GHC.Cmm.CommonBlockElim ( elimCommonBlocks @@ -17,7 +17,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Collections import Data.Functor.Classes (liftEq) import Data.Maybe (mapMaybe) import qualified Data.List as List diff --git a/GHC/Cmm/ContFlowOpt.hs b/GHC/Cmm/ContFlowOpt.hs --- a/GHC/Cmm/ContFlowOpt.hs +++ b/GHC/Cmm/ContFlowOpt.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} module GHC.Cmm.ContFlowOpt ( cmmCfgOpts , cmmCfgOptsProc @@ -11,7 +10,6 @@ import GHC.Prelude hiding (succ, unzip, zip) import GHC.Cmm.Dataflow.Block hiding (blockConcat) -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId diff --git a/GHC/Cmm/Dataflow.hs b/GHC/Cmm/Dataflow.hs --- a/GHC/Cmm/Dataflow.hs +++ b/GHC/Cmm/Dataflow.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- @@ -14,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 @@ -37,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 @@ -47,7 +43,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label type family Fact (x :: Extensibility) f :: Type @@ -90,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) @@ -172,7 +167,7 @@ -> RewriteFun' node f -> GenCmmGraph node -> FactBase f - -> UniqSM (GenCmmGraph node, FactBase f) + -> UniqDSM (GenCmmGraph node, FactBase f) rewriteCmmBwd = rewriteCmm Bwd rewriteCmm @@ -182,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 @@ -202,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 @@ -221,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. @@ -427,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 diff --git a/GHC/Cmm/Dataflow/Collections.hs b/GHC/Cmm/Dataflow/Collections.hs deleted file mode 100644 --- a/GHC/Cmm/Dataflow/Collections.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - -module GHC.Cmm.Dataflow.Collections - ( IsSet(..) - , setInsertList, setDeleteList, setUnions - , IsMap(..) - , mapInsertList, mapDeleteList, mapUnions - , UniqueMap, UniqueSet - ) where - -import GHC.Prelude - -import qualified GHC.Data.Word64Map.Strict as M -import qualified GHC.Data.Word64Set as S - -import Data.List (foldl1') -import Data.Word (Word64) - -class IsSet set where - type ElemOf set - - setNull :: set -> Bool - setSize :: set -> Int - setMember :: ElemOf set -> set -> Bool - - setEmpty :: set - setSingleton :: ElemOf set -> set - setInsert :: ElemOf set -> set -> set - setDelete :: ElemOf set -> set -> set - - setUnion :: set -> set -> set - setDifference :: set -> set -> set - setIntersection :: set -> set -> set - setIsSubsetOf :: set -> set -> Bool - setFilter :: (ElemOf set -> Bool) -> set -> set - - setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b - setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b - - setElems :: set -> [ElemOf set] - setFromList :: [ElemOf set] -> set - --- Helper functions for IsSet class -setInsertList :: IsSet set => [ElemOf set] -> set -> set -setInsertList keys set = foldl' (flip setInsert) set keys - -setDeleteList :: IsSet set => [ElemOf set] -> set -> set -setDeleteList keys set = foldl' (flip setDelete) set keys - -setUnions :: IsSet set => [set] -> set -setUnions [] = setEmpty -setUnions sets = foldl1' setUnion sets - - -class IsMap map where - type KeyOf map - - mapNull :: map a -> Bool - mapSize :: map a -> Int - mapMember :: KeyOf map -> map a -> Bool - mapLookup :: KeyOf map -> map a -> Maybe a - mapFindWithDefault :: a -> KeyOf map -> map a -> a - - mapEmpty :: map a - mapSingleton :: KeyOf map -> a -> map a - mapInsert :: KeyOf map -> a -> map a -> map a - mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a - mapDelete :: KeyOf map -> map a -> map a - mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a - mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a - - mapUnion :: map a -> map a -> map a - mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a - mapDifference :: map a -> map a -> map a - mapIntersection :: map a -> map a -> map a - mapIsSubmapOf :: Eq a => map a -> map a -> Bool - - mapMap :: (a -> b) -> map a -> map b - mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b - mapFoldl :: (b -> a -> b) -> b -> map a -> b - mapFoldr :: (a -> b -> b) -> b -> map a -> b - mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b - mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m - mapFilter :: (a -> Bool) -> map a -> map a - mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a - - - mapElems :: map a -> [a] - mapKeys :: map a -> [KeyOf map] - mapToList :: map a -> [(KeyOf map, a)] - mapFromList :: [(KeyOf map, a)] -> map a - mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a - --- Helper functions for IsMap class -mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a -mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs - -mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a -mapDeleteList keys map = foldl' (flip mapDelete) map keys - -mapUnions :: IsMap map => [map a] -> map a -mapUnions [] = mapEmpty -mapUnions maps = foldl1' mapUnion maps - ------------------------------------------------------------------------------ --- Basic instances ------------------------------------------------------------------------------ - -newtype UniqueSet = US S.Word64Set deriving (Eq, Ord, Show, Semigroup, Monoid) - -instance IsSet UniqueSet where - type ElemOf UniqueSet = Word64 - - setNull (US s) = S.null s - setSize (US s) = S.size s - setMember k (US s) = S.member k s - - setEmpty = US S.empty - setSingleton k = US (S.singleton k) - setInsert k (US s) = US (S.insert k s) - setDelete k (US s) = US (S.delete k s) - - setUnion (US x) (US y) = US (S.union x y) - setDifference (US x) (US y) = US (S.difference x y) - setIntersection (US x) (US y) = US (S.intersection x y) - setIsSubsetOf (US x) (US y) = S.isSubsetOf x y - setFilter f (US s) = US (S.filter f s) - - setFoldl k z (US s) = S.foldl' k z s - setFoldr k z (US s) = S.foldr k z s - - setElems (US s) = S.elems s - setFromList ks = US (S.fromList ks) - -newtype UniqueMap v = UM (M.Word64Map v) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -instance IsMap UniqueMap where - type KeyOf UniqueMap = Word64 - - mapNull (UM m) = M.null m - mapSize (UM m) = M.size m - mapMember k (UM m) = M.member k m - mapLookup k (UM m) = M.lookup k m - mapFindWithDefault def k (UM m) = M.findWithDefault def k m - - mapEmpty = UM M.empty - mapSingleton k v = UM (M.singleton k v) - mapInsert k v (UM m) = UM (M.insert k v m) - mapInsertWith f k v (UM m) = UM (M.insertWith f k v m) - mapDelete k (UM m) = UM (M.delete k m) - mapAlter f k (UM m) = UM (M.alter f k m) - mapAdjust f k (UM m) = UM (M.adjust f k m) - - mapUnion (UM x) (UM y) = UM (M.union x y) - mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y) - mapDifference (UM x) (UM y) = UM (M.difference x y) - mapIntersection (UM x) (UM y) = UM (M.intersection x y) - mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y - - mapMap f (UM m) = UM (M.map f m) - mapMapWithKey f (UM m) = UM (M.mapWithKey f m) - mapFoldl k z (UM m) = M.foldl' k z m - mapFoldr k z (UM m) = M.foldr k z m - mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m - mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m - {-# INLINEABLE mapFilter #-} - mapFilter f (UM m) = UM (M.filter f m) - {-# INLINEABLE mapFilterWithKey #-} - mapFilterWithKey f (UM m) = UM (M.filterWithKey f m) - - mapElems (UM m) = M.elems m - mapKeys (UM m) = M.keys m - {-# INLINEABLE mapToList #-} - mapToList (UM m) = M.toList m - mapFromList assocs = UM (M.fromList assocs) - mapFromListWith f assocs = UM (M.fromListWith f assocs) diff --git a/GHC/Cmm/Dataflow/Graph.hs b/GHC/Cmm/Dataflow/Graph.hs --- a/GHC/Cmm/Dataflow/Graph.hs +++ b/GHC/Cmm/Dataflow/Graph.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module GHC.Cmm.Dataflow.Graph ( Body @@ -26,15 +22,14 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import Data.Kind -- | A (possibly empty) collection of closed/closed blocks -type Body n = LabelMap (Block n C C) +type Body s n = Body' s Block n -- | @Body@ abstracted over @block@ -type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C) +type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C) ------------------------------- -- | Gives access to the anchor points for @@ -51,13 +46,13 @@ successors (BlockCC _ _ n) = successors n -emptyBody :: Body' block n +emptyBody :: Body' LabelMap block n emptyBody = mapEmpty -bodyList :: Body' block n -> [(Label,block n C C)] +bodyList :: Body' LabelMap block n -> [(Label,block n C C)] bodyList body = mapToList body -bodyToBlockList :: Body n -> [Block n C C] +bodyToBlockList :: Body LabelMap n -> [Block n C C] bodyToBlockList body = mapElems body addBlock @@ -77,18 +72,18 @@ -- O/C, C/O, C/C). A graph open at the entry has a single, -- distinguished, anonymous entry point; if a graph is closed at the -- entry, its entry point(s) are supplied by a context. -type Graph = Graph' Block +type Graph = Graph' LabelMap Block -- | @Graph'@ is abstracted over the block type, so that we can build -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow -- needs this). -data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where - GNil :: Graph' block n O O - GUnit :: block n O O -> Graph' block n O O +data Graph' s block (n :: Extensibility -> Extensibility -> Type) e x where + GNil :: Graph' s block n O O + GUnit :: block n O O -> Graph' s block n O O GMany :: MaybeO e (block n O C) - -> Body' block n + -> Body' s block n -> MaybeO x (block n C O) - -> Graph' block n e x + -> Graph' s block n e x -- ----------------------------------------------------------------------------- @@ -96,31 +91,32 @@ -- | Maps over all nodes in a graph. mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x -mapGraph f = mapGraphBlocks (mapBlock f) +mapGraph f = mapGraphBlocks mapMap (mapBlock f) -- | Function 'mapGraphBlocks' enables a change of representation of blocks, -- nodes, or both. It lifts a polymorphic block transform into a polymorphic -- graph transform. When the block representation stabilizes, a similar -- function should be provided for blocks. -mapGraphBlocks :: forall block n block' n' e x . - (forall e x . block n e x -> block' n' e x) - -> (Graph' block n e x -> Graph' block' n' e x) +mapGraphBlocks :: forall s block n block' n' e x . + (forall a b . (a -> b) -> s a -> s b) + -> (forall e x . block n e x -> block' n' e x) + -> (Graph' s block n e x -> Graph' s block' n' e x) -mapGraphBlocks f = map - where map :: Graph' block n e x -> Graph' block' n' e x +mapGraphBlocks f g = map + where map :: Graph' s block n e x -> Graph' s block' n' e x map GNil = GNil - map (GUnit b) = GUnit (f b) - map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) + map (GUnit b) = GUnit (g b) + map (GMany e b x) = GMany (fmap g e) (f g b) (fmap g x) -- ----------------------------------------------------------------------------- -- Extracting Labels from graphs -labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x +labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap block n e x -> LabelSet labelsDefined GNil = setEmpty labelsDefined (GUnit{}) = setEmpty labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body - where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet + where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet addEntry labels label _ = setInsert label labels exitLabel :: MaybeO x (block n C O) -> LabelSet exitLabel NothingO = setEmpty diff --git a/GHC/Cmm/Dataflow/Label.hs b/GHC/Cmm/Dataflow/Label.hs --- a/GHC/Cmm/Dataflow/Label.hs +++ b/GHC/Cmm/Dataflow/Label.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module GHC.Cmm.Dataflow.Label ( Label @@ -11,17 +13,76 @@ , FactBase , lookupFact , mkHooplLabel + -- * Set + , setEmpty + , setNull + , setSize + , setMember + , setSingleton + , setInsert + , setDelete + , setUnion + , setUnions + , setDifference + , setIntersection + , setIsSubsetOf + , setFilter + , setFoldl + , setFoldr + , setFromList + , setElems + -- * Map + , mapNull + , mapSize + , mapMember + , mapLookup + , mapFindWithDefault + , mapEmpty + , mapSingleton + , mapInsert + , mapInsertWith + , mapDelete + , mapAlter + , mapAdjust + , mapUnion + , mapUnions + , mapUnionWithKey + , mapDifference + , mapIntersection + , mapIsSubmapOf + , mapMap + , mapMapWithKey + , mapFoldl + , mapFoldr + , mapFoldlWithKey + , mapFoldMapWithKey + , mapFilter + , mapFilterWithKey + , mapElems + , mapKeys + , mapToList + , mapFromList + , mapFromListWith + , mapMapMaybe ) where import GHC.Prelude +import GHC.Utils.Misc import GHC.Utils.Outputable --- TODO: This should really just use GHC's Unique and Uniq{Set,FM} -import GHC.Cmm.Dataflow.Collections - import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily) + +-- The code generator will eventually be using all the labels stored in a +-- LabelSet and LabelMap. For these reasons we use the strict variants of these +-- data structures. We inline selectively to enable the RULES in Word64Map/Set +-- to fire. +import GHC.Data.Word64Set (Word64Set) +import qualified GHC.Data.Word64Set as S +import GHC.Data.Word64Map.Strict (Word64Map) +import qualified GHC.Data.Word64Map.Strict as M import GHC.Data.TrieMap + import Data.Word (Word64) @@ -30,7 +91,7 @@ ----------------------------------------------------------------------------- newtype Label = Label { lblToUnique :: Word64 } - deriving (Eq, Ord) + deriving newtype (Eq, Ord) mkHooplLabel :: Word64 -> Label mkHooplLabel = Label @@ -50,79 +111,179 @@ ----------------------------------------------------------------------------- -- LabelSet -newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup) +newtype LabelSet = LS Word64Set + deriving newtype (Eq, Ord, Show, Monoid, Semigroup) -instance IsSet LabelSet where - type ElemOf LabelSet = Label +setNull :: LabelSet -> Bool +setNull (LS s) = S.null s - setNull (LS s) = setNull s - setSize (LS s) = setSize s - setMember (Label k) (LS s) = setMember k s +setSize :: LabelSet -> Int +setSize (LS s) = S.size s - setEmpty = LS setEmpty - setSingleton (Label k) = LS (setSingleton k) - setInsert (Label k) (LS s) = LS (setInsert k s) - setDelete (Label k) (LS s) = LS (setDelete k s) +setMember :: Label -> LabelSet -> Bool +setMember (Label k) (LS s) = S.member k s - setUnion (LS x) (LS y) = LS (setUnion x y) - setDifference (LS x) (LS y) = LS (setDifference x y) - setIntersection (LS x) (LS y) = LS (setIntersection x y) - setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y - setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s) - setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s - setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s +setEmpty :: LabelSet +setEmpty = LS S.empty - setElems (LS s) = map mkHooplLabel (setElems s) - setFromList ks = LS (setFromList (map lblToUnique ks)) +setSingleton :: Label -> LabelSet +setSingleton (Label k) = LS (S.singleton k) +setInsert :: Label -> LabelSet -> LabelSet +setInsert (Label k) (LS s) = LS (S.insert k s) + +setDelete :: Label -> LabelSet -> LabelSet +setDelete (Label k) (LS s) = LS (S.delete k s) + +setUnion :: LabelSet -> LabelSet -> LabelSet +setUnion (LS x) (LS y) = LS (S.union x y) + +{-# INLINE setUnions #-} +setUnions :: [LabelSet] -> LabelSet +setUnions = foldl1WithDefault' setEmpty setUnion + +setDifference :: LabelSet -> LabelSet -> LabelSet +setDifference (LS x) (LS y) = LS (S.difference x y) + +setIntersection :: LabelSet -> LabelSet -> LabelSet +setIntersection (LS x) (LS y) = LS (S.intersection x y) + +setIsSubsetOf :: LabelSet -> LabelSet -> Bool +setIsSubsetOf (LS x) (LS y) = S.isSubsetOf x y + +setFilter :: (Label -> Bool) -> LabelSet -> LabelSet +setFilter f (LS s) = LS (S.filter (f . mkHooplLabel) s) + +{-# INLINE setFoldl #-} +setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t +setFoldl k z (LS s) = S.foldl (\a v -> k a (mkHooplLabel v)) z s + +{-# INLINE setFoldr #-} +setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t +setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s + +{-# INLINE setElems #-} +setElems :: LabelSet -> [Label] +setElems (LS s) = map mkHooplLabel (S.elems s) + +{-# INLINE setFromList #-} +setFromList :: [Label] -> LabelSet +setFromList ks = LS (S.fromList (map lblToUnique ks)) + ----------------------------------------------------------------------------- -- LabelMap -newtype LabelMap v = LM (UniqueMap v) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) +newtype LabelMap v = LM (Word64Map v) + deriving newtype (Eq, Ord, Show, Functor, Foldable) + deriving stock Traversable -instance IsMap LabelMap where - type KeyOf LabelMap = Label +mapNull :: LabelMap a -> Bool +mapNull (LM m) = M.null m - mapNull (LM m) = mapNull m - mapSize (LM m) = mapSize m - mapMember (Label k) (LM m) = mapMember k m - mapLookup (Label k) (LM m) = mapLookup k m - mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m +{-# INLINE mapSize #-} +mapSize :: LabelMap a -> Int +mapSize (LM m) = M.size m - mapEmpty = LM mapEmpty - mapSingleton (Label k) v = LM (mapSingleton k v) - mapInsert (Label k) v (LM m) = LM (mapInsert k v m) - mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m) - mapDelete (Label k) (LM m) = LM (mapDelete k m) - mapAlter f (Label k) (LM m) = LM (mapAlter f k m) - mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m) +mapMember :: Label -> LabelMap a -> Bool +mapMember (Label k) (LM m) = M.member k m - mapUnion (LM x) (LM y) = LM (mapUnion x y) - mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y) - mapDifference (LM x) (LM y) = LM (mapDifference x y) - mapIntersection (LM x) (LM y) = LM (mapIntersection x y) - mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y +mapLookup :: Label -> LabelMap a -> Maybe a +mapLookup (Label k) (LM m) = M.lookup k m - mapMap f (LM m) = LM (mapMap f m) - mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m) - mapFoldl k z (LM m) = mapFoldl k z m - mapFoldr k z (LM m) = mapFoldr k z m - mapFoldlWithKey k z (LM m) = - mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m - mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m - {-# INLINEABLE mapFilter #-} - mapFilter f (LM m) = LM (mapFilter f m) - {-# INLINEABLE mapFilterWithKey #-} - mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m) +mapFindWithDefault :: a -> Label -> LabelMap a -> a +mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m - mapElems (LM m) = mapElems m - mapKeys (LM m) = map mkHooplLabel (mapKeys m) - {-# INLINEABLE mapToList #-} - mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m] - mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) - mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) +mapEmpty :: LabelMap v +mapEmpty = LM M.empty +mapSingleton :: Label -> v -> LabelMap v +mapSingleton (Label k) v = LM (M.singleton k v) + +mapInsert :: Label -> v -> LabelMap v -> LabelMap v +mapInsert (Label k) v (LM m) = LM (M.insert k v m) + +mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v +mapInsertWith f (Label k) v (LM m) = LM (M.insertWith f k v m) + +mapDelete :: Label -> LabelMap v -> LabelMap v +mapDelete (Label k) (LM m) = LM (M.delete k m) + +mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v +mapAlter f (Label k) (LM m) = LM (M.alter f k m) + +mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v +mapAdjust f (Label k) (LM m) = LM (M.adjust f k m) + +mapUnion :: LabelMap v -> LabelMap v -> LabelMap v +mapUnion (LM x) (LM y) = LM (M.union x y) + +{-# INLINE mapUnions #-} +mapUnions :: [LabelMap a] -> LabelMap a +mapUnions = foldl1WithDefault' mapEmpty mapUnion + +mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v +mapUnionWithKey f (LM x) (LM y) = LM (M.unionWithKey (f . mkHooplLabel) x y) + +mapDifference :: LabelMap v -> LabelMap b -> LabelMap v +mapDifference (LM x) (LM y) = LM (M.difference x y) + +mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v +mapIntersection (LM x) (LM y) = LM (M.intersection x y) + +mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool +mapIsSubmapOf (LM x) (LM y) = M.isSubmapOf x y + +mapMap :: (a -> v) -> LabelMap a -> LabelMap v +mapMap f (LM m) = LM (M.map f m) + +mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v +mapMapWithKey f (LM m) = LM (M.mapWithKey (f . mkHooplLabel) m) + +{-# INLINE mapFoldl #-} +mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a +mapFoldl k z (LM m) = M.foldl k z m + +{-# INLINE mapFoldr #-} +mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b +mapFoldr k z (LM m) = M.foldr k z m + +{-# INLINE mapFoldlWithKey #-} +mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t +mapFoldlWithKey k z (LM m) = M.foldlWithKey (\a v -> k a (mkHooplLabel v)) z m + +mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m +mapFoldMapWithKey f (LM m) = M.foldMapWithKey (\k v -> f (mkHooplLabel k) v) m + +{-# INLINEABLE mapFilter #-} +mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v +mapFilter f (LM m) = LM (M.filter f m) + +{-# INLINEABLE mapFilterWithKey #-} +mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v +mapFilterWithKey f (LM m) = LM (M.filterWithKey (f . mkHooplLabel) m) + +{-# INLINE mapElems #-} +mapElems :: LabelMap a -> [a] +mapElems (LM m) = M.elems m + +{-# INLINE mapKeys #-} +mapKeys :: LabelMap a -> [Label] +mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m) + +{-# INLINE mapToList #-} +mapToList :: LabelMap b -> [(Label, b)] +mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m] + +{-# INLINE mapFromList #-} +mapFromList :: [(Label, v)] -> LabelMap v +mapFromList assocs = LM (M.fromList [(lblToUnique k, v) | (k, v) <- assocs]) + +mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v +mapFromListWith f assocs = LM (M.fromListWith f [(lblToUnique k, v) | (k, v) <- assocs]) + +mapMapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b +mapMapMaybe f (LM m) = LM (M.mapMaybe f m) + ----------------------------------------------------------------------------- -- Instances @@ -137,11 +298,12 @@ instance TrieMap LabelMap where type Key LabelMap = Label - emptyTM = mapEmpty - lookupTM k m = mapLookup k m + emptyTM = mapEmpty + lookupTM k m = mapLookup k m alterTM k f m = mapAlter f k m - foldTM k m z = mapFoldr k z m - filterTM f m = mapFilter f m + foldTM k m z = mapFoldr k z m + filterTM f = mapFilter f + mapMaybeTM f = mapMapMaybe f ----------------------------------------------------------------------------- -- FactBase diff --git a/GHC/Cmm/DebugBlock.hs b/GHC/Cmm/DebugBlock.hs --- a/GHC/Cmm/DebugBlock.hs +++ b/GHC/Cmm/DebugBlock.hs @@ -6,9 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE EmptyCase #-} ----------------------------------------------------------------------------- -- @@ -41,7 +39,7 @@ import GHC.Cmm import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) import GHC.Cmm.Utils -import GHC.Data.FastString ( nilFS, mkFastString ) +import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic @@ -50,15 +48,18 @@ import GHC.Utils.Misc ( seqList ) import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import Data.Maybe -import Data.List ( minimumBy, nubBy ) +import Data.List ( nubBy ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) +import qualified Data.List.NonEmpty as NE import Data.Ord ( comparing ) import qualified Data.Map as Map -import Data.Either ( partitionEithers ) +import Data.Foldable ( toList ) +import Data.Either ( partitionEithers ) +import Data.Void -- | Debug information about a block of code. Ticks scope over nested -- blocks. @@ -96,34 +97,40 @@ -- | Intermediate data structure holding debug-relevant context information -- about a block. -type BlockContext = (CmmBlock, RawCmmDecl) +type BlockContext = (CmmBlock, RawCmmDeclNoStatics) +-- Same as `RawCmmDecl`, but statically (in GHC) excludes the possibility of statics (in the CMM +-- code). (The first argument is `Void` rather than `RawCmmStatics`. +type RawCmmDeclNoStatics + = GenCmmDecl + Void + (LabelMap RawCmmStatics) + CmmGraph + -- | Extract debug data from a group of procedures. We will prefer -- source notes that come from the given module (presumably the module -- that we are currently compiling). -cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock] +cmmDebugGen :: ModLocation -> [RawCmmDecl] -> [DebugBlock] cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes where - blockCtxs :: Map.Map CmmTickScope [BlockContext] + blockCtxs :: Map.Map CmmTickScope (NonEmpty BlockContext) blockCtxs = blockContexts decls -- Analyse tick scope structure: Each one is either a top-level -- tick scope, or the child of another. (topScopes, childScopes) - = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs + = partitionEithers $ map (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs + findP tsc GlobalScope = Left tsc -- top scope - findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc) + findP tsc scp | Just x <- Map.lookup scp' blockCtxs = Right (scp', tsc, x) | otherwise = findP tsc scp' where -- Note that we only following the left parent of -- combined scopes. This loses us ticks, which we will -- recover by copying ticks below. scp' | SubScope _ scp' <- scp = scp' | CombinedScope scp' _ <- scp = scp' -#if __GLASGOW_HASKELL__ < 901 - | otherwise = panic "findP impossible" -#endif - scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes + scopeMap = foldl' (\ acc (k, (k', a'), _) -> insertMulti k (k', a') acc) Map.empty childScopes -- This allows us to recover ticks that we lost by flattening -- the graph. Basically, if the parent is A but the child is @@ -142,7 +149,7 @@ | SubScope _ s' <- s = ticks ++ go s' | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2 | otherwise = panic "ticksToCopy impossible" - where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs + where ticks = bCtxsTicks $ maybe [] toList $ Map.lookup s blockCtxs ticksToCopy _ = [] bCtxsTicks = concatMap (blockTicks . fst) @@ -152,41 +159,37 @@ -- (if we generated one, we probably want debug information to -- refer to it). bestSrcTick = minimumBy (comparing rangeRating) - rangeRating (SourceNote span _) + rangeRating (span, _) | srcSpanFile span == thisFile = 1 | otherwise = 2 :: Int - rangeRating note = pprPanic "rangeRating" (ppr note) thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc -- Returns block tree for this scope as well as all nested -- scopes. Note that if there are multiple blocks in the (exact) -- same scope we elect one as the "branch" node and add the rest -- as children. - blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock - blocksForScope cstick scope = mkBlock True (head bctxs) - where bctxs = fromJust $ Map.lookup scope blockCtxs - nested = fromMaybe [] $ Map.lookup scope scopeMap - childs = map (mkBlock False) (tail bctxs) ++ + blocksForScope :: Maybe (RealSrcSpan, LexicalFastString) -> (CmmTickScope, NonEmpty BlockContext) -> DebugBlock + blocksForScope cstick (scope, bctx:|bctxs) = mkBlock True bctx + where nested = fromMaybe [] $ Map.lookup scope scopeMap + childs = map (mkBlock False) bctxs ++ map (blocksForScope stick) nested mkBlock :: Bool -> BlockContext -> DebugBlock 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 , dblPosition = Nothing -- see cmmDebugLink - , dblSourceTick = stick + , dblSourceTick = uncurry SourceNote <$> stick , dblBlocks = blocks , dblUnwind = [] } - where (CmmProc infos entryLbl _ graph) = prc + where (infos, graph) = case prc of + CmmProc infos _ _ graph -> (infos, graph) + CmmData _ v -> case v of label = entryLabel block info = mapLookup label infos blocks | top = seqList childs childs @@ -194,26 +197,26 @@ -- A source tick scopes over all nested blocks. However -- their source ticks might take priority. - isSourceTick SourceNote {} = True - isSourceTick _ = False + isSourceTick (SourceNote span a) = Just (span, a) + isSourceTick _ = Nothing -- Collect ticks from all blocks inside the tick scope. -- We attempt to filter out duplicates while we're at it. ticks = nubBy (flip tickishContains) $ bCtxsTicks bctxs ++ ticksToCopy scope - stick = case filter isSourceTick ticks of - [] -> cstick - sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick) + stick = case nonEmpty $ mapMaybe isSourceTick ticks of + Nothing -> cstick + Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` maybeToList cstick) -- | Build a map of blocks sorted by their tick scopes -- -- This involves a pre-order traversal, as we want blocks in rough -- control flow order (so ticks have a chance to be sorted in the -- right order). -blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext] -blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls - where walkProc :: RawCmmDecl - -> Map.Map CmmTickScope [BlockContext] - -> Map.Map CmmTickScope [BlockContext] +blockContexts :: [GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph] -> Map.Map CmmTickScope (NonEmpty BlockContext) +blockContexts = Map.map NE.reverse . foldr walkProc Map.empty + where walkProc :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph + -> Map.Map CmmTickScope (NonEmpty BlockContext) + -> Map.Map CmmTickScope (NonEmpty BlockContext) walkProc CmmData{} m = m walkProc prc@(CmmProc _ _ _ graph) m | mapNull blocks = m @@ -222,29 +225,30 @@ entry = [mapFind (g_entry graph) blocks] emptyLbls = setEmpty :: LabelSet - walkBlock :: RawCmmDecl -> [Block CmmNode C C] - -> (LabelSet, Map.Map CmmTickScope [BlockContext]) - -> (LabelSet, Map.Map CmmTickScope [BlockContext]) + walkBlock :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph -> [Block CmmNode C C] + -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext)) + -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext)) walkBlock _ [] c = c - walkBlock prc (block:blocks) (visited, m) - | lbl `setMember` visited - = walkBlock prc blocks (visited, m) - | otherwise - = walkBlock prc blocks $ - walkBlock prc succs - (lbl `setInsert` visited, - insertMulti scope (block, prc) m) + walkBlock prc (block:blocks) (visited, m) = case (prc, setMember lbl visited) of + (CmmProc x y z graph, False) -> + let succs = flip mapFind (toBlockMap graph) <$> + successors (lastNode block) in + walkBlock prc blocks $ + walkBlock prc succs + ( lbl `setInsert` visited + , insertMultiNE scope (block, CmmProc x y z graph) m ) + _ -> walkBlock prc blocks (visited, m) where CmmEntry lbl scope = firstNode block - (CmmProc _ _ _ graph) = prc - succs = map (flip mapFind (toBlockMap graph)) - (successors (lastNode block)) mapFind = mapFindWithDefault (error "contextTree: block not found!") insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a] insertMulti k v = Map.insertWith (const (v:)) k [v] -cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] -cmmDebugLabels isMeta nats = seqList lbls lbls +insertMultiNE :: Ord k => k -> a -> Map.Map k (NonEmpty a) -> Map.Map k (NonEmpty a) +insertMultiNE k v = Map.insertWith (const (v NE.<|)) k (NE.singleton v) + +cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label] +cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls where -- Find order in which procedures will be generated by the -- back-end (that actually matters for DWARF generation). -- @@ -252,7 +256,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 @@ -261,14 +265,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 diff --git a/GHC/Cmm/Dominators.hs b/GHC/Cmm/Dominators.hs --- a/GHC/Cmm/Dominators.hs +++ b/GHC/Cmm/Dominators.hs @@ -23,7 +23,6 @@ import GHC.Prelude import Data.Array.IArray -import Data.Foldable() import qualified Data.Tree as Tree import Data.Word @@ -32,7 +31,6 @@ import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm diff --git a/GHC/Cmm/Expr.hs b/GHC/Cmm/Expr.hs --- a/GHC/Cmm/Expr.hs +++ b/GHC/Cmm/Expr.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module GHC.Cmm.Expr @@ -510,6 +506,8 @@ CmmMachOp mop args -> genMachOp platform mop args genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform (MO_RelaxedRead w) [x] = + ppr (cmmBits w) <> text "!" <> brackets (pdoc platform x) genMachOp platform mop args | Just doc <- infixMachOp mop = case args of -- dyadic diff --git a/GHC/Cmm/GenericOpt.hs b/GHC/Cmm/GenericOpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/GenericOpt.hs @@ -0,0 +1,212 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 1993-2004 +-- +-- +-- ----------------------------------------------------------------------------- + +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +module GHC.Cmm.GenericOpt + ( cmmToCmm + ) +where + +import GHC.Prelude hiding (head) +import GHC.Platform +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Opt ( cmmMachOpFold ) +import GHC.Cmm.CLabel +import GHC.Data.FastString +import GHC.Unit +import Control.Monad.Trans.Reader +import GHC.Utils.Monad.State.Strict as Strict + +-- ----------------------------------------------------------------------------- +-- Generic Cmm optimiser + +{- +Here we do: + + (a) Constant folding + (c) Position independent code and dynamic linking + (i) introduce the appropriate indirections + and position independent refs + (ii) compile a list of imported symbols + (d) Some arch-specific optimizations + +(a) will be moving to the new Hoopl pipeline, however, (c) and +(d) are only needed by the native backend and will continue to live +here. + +Ideas for other things we could do (put these in Hoopl please!): + + - shortcut jumps-to-jumps + - simple CSE: if an expr is assigned to a temp, then replace later occs of + that expr with the temp, until the expr is no longer valid (can push through + temp assignments, and certain assigns to mem...) +-} + +cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel]) +cmmToCmm _ top@(CmmData _ _) = (top, []) +cmmToCmm config (CmmProc info lbl live graph) + = runCmmOpt config $ + do blocks' <- mapM cmmBlockConFold (toBlockList graph) + return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') + +type OptMResult a = (# a, [CLabel] #) + +pattern OptMResult :: a -> b -> (# a, b #) +pattern OptMResult x y = (# x, y #) +{-# COMPLETE OptMResult #-} + +newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a) + deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel])) + +instance CmmMakeDynamicReferenceM CmmOptM where + addImport = addImportCmmOpt + +addImportCmmOpt :: CLabel -> CmmOptM () +addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports) + +getCmmOptConfig :: CmmOptM NCGConfig +getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports + +runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel]) +runCmmOpt config (CmmOptM f) = + case f config [] of + OptMResult result imports -> (result, imports) + +cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock +cmmBlockConFold block = do + let (entry, middle, last) = blockSplit block + stmts = blockToList middle + stmts' <- mapM cmmStmtConFold stmts + last' <- cmmStmtConFold last + return $ blockJoin entry (blockFromList stmts') last' + +-- This does three optimizations, but they're very quick to check, so we don't +-- bother turning them off even when the Hoopl code is active. Since +-- this is on the old Cmm representation, we can't reuse the code either: +-- * reg = reg --> nop +-- * if 0 then jump --> nop +-- * if 1 then jump --> jump +-- We might be tempted to skip this step entirely of not Opt_PIC, but +-- there is some PowerPC code for the non-PIC case, which would also +-- have to be separated. +cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) +cmmStmtConFold stmt + = case stmt of + CmmAssign reg src + -> do src' <- cmmExprConFold DataReference src + return $ case src' of + CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") + new_src -> CmmAssign reg new_src + + CmmStore addr src align + -> do addr' <- cmmExprConFold DataReference addr + src' <- cmmExprConFold DataReference src + return $ CmmStore addr' src' align + + CmmCall { cml_target = addr } + -> do addr' <- cmmExprConFold JumpReference addr + return $ stmt { cml_target = addr' } + + CmmUnsafeForeignCall target regs args + -> do target' <- case target of + ForeignTarget e conv -> do + e' <- cmmExprConFold CallReference e + return $ ForeignTarget e' conv + PrimTarget _ -> + return target + args' <- mapM (cmmExprConFold DataReference) args + return $ CmmUnsafeForeignCall target' regs args' + + CmmCondBranch test true false likely + -> do test' <- cmmExprConFold DataReference test + return $ case test' of + CmmLit (CmmInt 0 _) -> CmmBranch false + CmmLit (CmmInt _ _) -> CmmBranch true + _other -> CmmCondBranch test' true false likely + + CmmSwitch expr ids + -> do expr' <- cmmExprConFold DataReference expr + return $ CmmSwitch expr' ids + + other + -> return other + +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprConFold referenceKind expr = do + config <- getCmmOptConfig + + let expr' = if not (ncgDoConstantFolding config) + then expr + else cmmExprCon config expr + + cmmExprNative referenceKind expr' + +cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr +cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align +cmmExprCon config (CmmMachOp mop args) + = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) +cmmExprCon _ other = other + +-- handles both PIC and non-PIC cases... a very strange mixture +-- of things to do. +cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprNative referenceKind expr = do + config <- getCmmOptConfig + let platform = ncgPlatform config + arch = platformArch platform + case expr of + CmmLoad addr rep align + -> do addr' <- cmmExprNative DataReference addr + return $ CmmLoad addr' rep align + + CmmMachOp mop args + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' + + CmmLit (CmmBlock id) + -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) + -- we must convert block Ids to CLabels here, because we + -- might have to do the PIC transformation. Hence we must + -- not modify BlockIds beyond this point. + + CmmLit (CmmLabel lbl) + -> cmmMakeDynamicReference config referenceKind lbl + CmmLit (CmmLabelOff lbl off) + -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl + -- need to optimize here, since it's late + return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ + dynRef, + (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform)) + ] + + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: + CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _)) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) + CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _)) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) + CmmReg (CmmGlobal (GlobalRegUse GCFun _)) + | arch == ArchPPC && not (ncgPIC config) + -> cmmExprNative referenceKind $ + CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) + + other + -> return other diff --git a/GHC/Cmm/Graph.hs b/GHC/Cmm/Graph.hs --- a/GHC/Cmm/Graph.hs +++ b/GHC/Cmm/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, GADTs #-} +{-# LANGUAGE GADTs #-} module GHC.Cmm.Graph ( CmmAGraph, CmmAGraphScoped, CgStmt(..) @@ -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 diff --git a/GHC/Cmm/Info.hs b/GHC/Cmm/Info.hs --- a/GHC/Cmm/Info.hs +++ b/GHC/Cmm/Info.hs @@ -36,23 +36,22 @@ 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.Collections +import GHC.Cmm.Dataflow.Label import GHC.Platform import GHC.Platform.Profile import GHC.Data.Maybe import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Types.Unique.Supply import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable +import GHC.Types.Unique.DSM import Data.ByteString (ByteString) @@ -65,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) } @@ -115,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) @@ -178,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 @@ -219,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) @@ -339,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]) } @@ -413,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) } @@ -450,7 +445,7 @@ -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr closureInfoPtr platform align_check e = - cmmLoadBWord platform (wordAligned platform align_check e) + CmmMachOp (MO_RelaxedRead (wordWidth platform)) [wordAligned platform align_check e] -- | Takes an info pointer (the first word of a closure) and returns its entry -- code diff --git a/GHC/Cmm/Info/Build.hs b/GHC/Cmm/Info/Build.hs --- a/GHC/Cmm/Info/Build.hs +++ b/GHC/Cmm/Info/Build.hs @@ -1,11 +1,7 @@ -{-# LANGUAGE GADTs, BangPatterns, RecordWildCards, - GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, - ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs, RecordWildCards, + NondecreasingIndentation, + OverloadedStrings, LambdaCase #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} @@ -27,7 +23,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Unit.Module import GHC.Data.Graph.Directed @@ -38,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 @@ -52,6 +46,7 @@ import Data.List (unzip4) import GHC.Types.Name.Set +import GHC.Types.Unique.DSM {- Note [SRTs] ~~~~~~~~~~~ @@ -883,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_ $ @@ -941,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) -> @@ -981,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. @@ -991,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 @@ -1046,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 @@ -1113,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 <+> @@ -1237,7 +1234,7 @@ buildSRTChain :: Profile -> [SRTEntry] - -> UniqSM + -> UniqDSM ( [CmmDeclSRTs] -- The SRT object(s) , SRTEntry -- label to use in the info table ) @@ -1255,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 diff --git a/GHC/Cmm/LRegSet.hs b/GHC/Cmm/LRegSet.hs --- a/GHC/Cmm/LRegSet.hs +++ b/GHC/Cmm/LRegSet.hs @@ -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 diff --git a/GHC/Cmm/LayoutStack.hs b/GHC/Cmm/LayoutStack.hs --- a/GHC/Cmm/LayoutStack.hs +++ b/GHC/Cmm/LayoutStack.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-} +{-# LANGUAGE RecordWildCards, GADTs #-} module GHC.Cmm.LayoutStack ( cmmLayoutStack, setInfoTableStackMap ) where @@ -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 @@ -21,14 +21,13 @@ import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow +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 ) @@ -37,6 +36,7 @@ import Control.Monad.Fix import Data.Array as Array import Data.List (nub) +import Data.List.NonEmpty ( NonEmpty (..) ) {- Note [Stack Layout] ~~~~~~~~~~~~~~~~~~~ @@ -236,7 +236,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 @@ -272,7 +272,7 @@ -> [CmmBlock] -- [in] blocks - -> UniqSM + -> UniqDSM ( LabelMap StackMap -- [out] stack maps , ByteOff -- [out] Sp high water mark , [CmmBlock] -- [out] new blocks @@ -283,12 +283,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) @@ -341,7 +347,7 @@ this_sp_hwm | isGcJump last0 = 0 | otherwise = sp0 - sp_off - hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out)) + hwm' = maximum (acc_hwm :| this_sp_hwm : map sm_sp (mapElems out)) go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) @@ -368,7 +374,7 @@ collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) collectContInfo blocks - = (maximum ret_offs, mapFromList (catMaybes mb_argss)) + = (maximum (expectNonEmpty ret_offs), mapFromList (catMaybes mb_argss)) where (mb_argss, ret_offs) = mapAndUnzip get_cont blocks @@ -437,7 +443,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 @@ -503,7 +509,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] @@ -536,7 +542,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. @@ -571,7 +577,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 @@ -1048,7 +1054,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 @@ -1134,7 +1140,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 @@ -1181,7 +1187,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" diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,932 +1,1087 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.8.4-src/ghc-9.8.4/compiler/GHC/Cmm/Lexer.x" #-} -module GHC.Cmm.Lexer ( - CmmToken(..), cmmlex, - ) where - -import GHC.Prelude - -import GHC.Cmm.Expr - -import GHC.Parser.Lexer -import GHC.Cmm.Parser.Monad -import GHC.Types.SrcLoc -import GHC.Types.Unique.FM -import GHC.Data.StringBuffer -import GHC.Data.FastString -import GHC.Parser.CharClass -import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr () -import GHC.Platform -import GHC.Utils.Error -import GHC.Utils.Misc ---import TRACE - -import Data.Word -import Data.Char -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array.Base (unsafeAt) -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x01\x00\x00\x00\xc9\x00\x00\x00\x4e\x00\x00\x00\xb9\x00\x00\x00\x93\xff\xff\xff\x90\xff\xff\xff\xbc\xff\xff\xff\xcf\xff\xff\xff\xdd\xff\xff\xff\x00\x00\x00\x00\xf1\xff\xff\xff\xe1\xff\xff\xff\xdc\xff\xff\xff\xea\xff\xff\xff\xd2\xff\xff\xff\xe7\xff\xff\xff\xec\xff\xff\xff\x00\x00\x00\x00\xe4\xff\xff\xff\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x62\x00\x00\x00\xc2\x00\x00\x00\x65\x00\x00\x00\x68\x00\x00\x00\x6a\x00\x00\x00\x6d\x00\x00\x00\xd3\x00\x00\x00\x6f\x00\x00\x00\xbe\x00\x00\x00\x69\x00\x00\x00\xd6\x01\x00\x00\xa9\x02\x00\x00\x7c\x03\x00\x00\x4f\x04\x00\x00\x6e\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x6b\x00\x00\x00\x0a\x00\x00\x00\x12\x00\x00\x00\x53\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x22\x05\x00\x00\xf5\x05\x00\x00\xc8\x06\x00\x00\x9b\x07\x00\x00\x6e\x08\x00\x00\x41\x09\x00\x00\x14\x0a\x00\x00\xe7\x0a\x00\x00\xba\x0b\x00\x00\x8d\x0c\x00\x00\x60\x0d\x00\x00\x33\x0e\x00\x00\x06\x0f\x00\x00\xd9\x0f\x00\x00\xac\x10\x00\x00\x7f\x11\x00\x00\x52\x12\x00\x00\x25\x13\x00\x00\xf8\x13\x00\x00\xcb\x14\x00\x00\x55\x00\x00\x00\x80\x00\x00\x00\x44\x01\x00\x00\x93\x15\x00\x00\x7c\x00\x00\x00\x77\x00\x00\x00\x84\x00\x00\x00\x73\x15\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x2a\x01\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\xf9\x15\x00\x00\x1a\x16\x00\x00\x18\x16\x00\x00\x08\x02\x00\x00\x15\x02\x00\x00\xdd\x02\x00\x00\x51\x16\x00\x00\x68\x16\x00\x00\x8a\x16\x00\x00\xa2\x16\x00\x00\xdb\x16\x00\x00\x1c\x17\x00\x00\xef\x17\x00\x00\xc2\x18\x00\x00\x95\x19\x00\x00\x68\x1a\x00\x00\x3b\x1b\x00\x00\x0e\x1c\x00\x00\xe1\x1c\x00\x00\xb4\x1d\x00\x00\x87\x1e\x00\x00\x5a\x1f\x00\x00\x2d\x20\x00\x00\x00\x21\x00\x00\xd3\x21\x00\x00\xa6\x22\x00\x00\x79\x23\x00\x00\x4c\x24\x00\x00\x1f\x25\x00\x00\xf2\x25\x00\x00\xc5\x26\x00\x00\x98\x27\x00\x00\x6b\x28\x00\x00\x3e\x29\x00\x00\x11\x2a\x00\x00\xe4\x2a\x00\x00\xb7\x2b\x00\x00\x8a\x2c\x00\x00\x5d\x2d\x00\x00\x30\x2e\x00\x00\x03\x2f\x00\x00\xd6\x2f\x00\x00\xa9\x30\x00\x00\x71\x31\x00\x00\x70\x32\x00\x00\x70\x33\x00\x00\x43\x34\x00\x00\x16\x35\x00\x00\xe9\x35\x00\x00\xbc\x36\x00\x00\x8f\x37\x00\x00\x62\x38\x00\x00\x35\x39\x00\x00\x08\x3a\x00\x00\xdb\x3a\x00\x00\xae\x3b\x00\x00\x81\x3c\x00\x00\x54\x3d\x00\x00\x27\x3e\x00\x00\xfa\x3e\x00\x00\xcd\x3f\x00\x00\xa0\x40\x00\x00\x73\x41\x00\x00\x46\x42\x00\x00\x0e\x43\x00\x00\x0d\x44\x00\x00\x0c\x45\x00\x00\x0b\x46\x00\x00\x0a\x47\x00\x00\x09\x48\x00\x00\x08\x49\x00\x00\x07\x4a\x00\x00\x07\x4b\x00\x00\xda\x4b\x00\x00\xad\x4c\x00\x00\x80\x4d\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x78\x00\x00\x00\x87\x00\x00\x00\x8e\x00\x00\x00\x7e\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x7f\x00\x00\x00\x92\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\xff\xff\x67\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x24\x00\x5c\x00\x5c\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x16\x00\x5f\x00\x39\x00\x07\x00\x0a\x00\x14\x00\xff\xff\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x89\x00\x23\x00\x68\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x20\x00\x23\x00\x1c\x00\x18\x00\x1e\x00\xff\xff\x08\x00\x09\x00\x45\x00\x83\x00\xa2\x00\x0c\x00\x8a\x00\x0d\x00\x9c\x00\x0f\x00\x0e\x00\x10\x00\xa0\x00\x30\x00\xb5\x00\x11\x00\x8b\x00\x5d\x00\xa5\x00\x84\x00\x77\x00\x7f\x00\x5c\x00\x15\x00\x5c\x00\x5c\x00\x5c\x00\x23\x00\xff\xff\x23\x00\x23\x00\x13\x00\x23\x00\x17\x00\x0b\x00\xb1\x00\x19\x00\x1d\x00\x1a\x00\x1b\x00\x1f\x00\x21\x00\x5b\x00\xff\xff\x4d\x00\x5c\x00\xff\xff\x35\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\xff\xff\xff\xff\x52\x00\x3b\x00\x23\x00\x12\x00\x23\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x27\x00\xff\xff\x27\x00\x27\x00\x27\x00\x53\x00\xff\xff\x2a\x00\x37\x00\x27\x00\xff\xff\x27\x00\x27\x00\x27\x00\x34\x00\x2b\x00\x5c\x00\x38\x00\x5c\x00\x5c\x00\x5c\x00\x29\x00\xff\xff\x27\x00\x2c\x00\x2e\x00\x2d\x00\xff\xff\xff\xff\x28\x00\x3d\x00\x56\x00\x27\x00\x57\x00\x58\x00\x5a\x00\x5b\x00\xab\x00\x04\x00\x5c\x00\xad\x00\xac\x00\x39\x00\xae\x00\x5c\x00\xaf\x00\xb0\x00\xb2\x00\xb3\x00\xb4\x00\x00\x00\x00\x00\x36\x00\x00\x00\xff\xff\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x5c\x00\x25\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x37\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x31\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\x63\x00\x00\x00\x32\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x5f\x00\x00\x00\x00\x00\x64\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x65\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x00\x00\x00\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x00\x00\x00\x00\x00\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x54\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x64\x00\x54\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x54\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\xff\xff\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x42\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa6\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\xff\xff\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x9f\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa1\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa1\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa3\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa4\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa4\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xa6\x00\x00\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\x00\x00\x01\x00\x02\x00\x71\x00\x75\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x69\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x72\x00\x65\x00\x42\x00\x43\x00\x44\x00\x65\x00\x46\x00\x6c\x00\x48\x00\x78\x00\x61\x00\x65\x00\x4c\x00\x4d\x00\x65\x00\x64\x00\x50\x00\x61\x00\x52\x00\x53\x00\x54\x00\x55\x00\x09\x00\x26\x00\x0b\x00\x0c\x00\x0d\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x7c\x00\x60\x00\x3d\x00\x72\x00\x73\x00\x3d\x00\x3c\x00\x3d\x00\x3d\x00\x3e\x00\x3a\x00\x0a\x00\x0a\x00\x6c\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x6c\x00\x0a\x00\x0a\x00\x0a\x00\x70\x00\x69\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x6e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x72\x00\x0a\x00\x61\x00\x01\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x6e\x00\x67\x00\x09\x00\x65\x00\x0b\x00\x0c\x00\x0d\x00\x72\x00\xd7\x00\x20\x00\x6d\x00\x6c\x00\x23\x00\x0a\x00\x0a\x00\x70\x00\x65\x00\x61\x00\x20\x00\x67\x00\x6d\x00\x61\x00\x0a\x00\x74\x00\x63\x00\x20\x00\x63\x00\x73\x00\x23\x00\x5f\x00\xa0\x00\x71\x00\x65\x00\x65\x00\x73\x00\x61\x00\xff\xff\xff\xff\x22\x00\xff\xff\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x69\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\x09\x00\x61\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa0\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x2b\x00\x60\x00\x2d\x00\xff\xff\x63\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\x45\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x01\x00\x00\x00\x22\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x45\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x65\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\x6a\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\xff\xff\x25\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x2f\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x2f\x00\x35\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xff\xff\xff\xff\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 181) - [ AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 137 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 136 - , AlexAcc 135 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 134 - , AlexAcc 133 - , AlexAcc 132 - , AlexAcc 131 - , AlexAcc 130 - , AlexAcc 129 - , AlexAcc 128 - , AlexAcc 127 - , AlexAcc 126 - , AlexAcc 125 - , AlexAcc 124 - , AlexAcc 123 - , AlexAcc 122 - , AlexAcc 121 - , AlexAcc 120 - , AlexAcc 119 - , AlexAcc 118 - , AlexAcc 117 - , AlexAcc 116 - , AlexAccSkip - , AlexAcc 115 - , AlexAcc 114 - , AlexAccSkip - , AlexAcc 113 - , AlexAcc 112 - , AlexAcc 111 - , AlexAcc 110 - , AlexAcc 109 - , AlexAccPred 108 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 107) - , AlexAcc 106 - , AlexAcc 105 - , AlexAcc 104 - , AlexAcc 103 - , AlexAcc 102 - , AlexAcc 101 - , AlexAcc 100 - , AlexAccNone - , AlexAcc 99 - , AlexAcc 98 - , AlexAccPred 97 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 96) - , AlexAccPred 95 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 94 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAcc 93 - , AlexAcc 92 - , AlexAcc 91 - , AlexAcc 90 - , AlexAcc 89 - , AlexAcc 88 - , AlexAcc 87 - , AlexAcc 86 - , AlexAcc 85 - , AlexAcc 84 - , AlexAcc 83 - , AlexAcc 82 - , AlexAcc 81 - , AlexAcc 80 - , AlexAcc 79 - , AlexAcc 78 - , AlexAcc 77 - , AlexAcc 76 - , AlexAcc 75 - , AlexAcc 74 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 73 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccSkip - , AlexAccNone - , AlexAcc 72 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 71 - , AlexAccNone - , AlexAccNone - , AlexAcc 70 - , AlexAccNone - , AlexAcc 69 - , AlexAcc 68 - , AlexAcc 67 - , AlexAcc 66 - , AlexAcc 65 - , AlexAcc 64 - , AlexAcc 63 - , AlexAcc 62 - , AlexAcc 61 - , AlexAcc 60 - , AlexAcc 59 - , AlexAcc 58 - , AlexAcc 57 - , AlexAcc 56 - , AlexAcc 55 - , AlexAcc 54 - , AlexAcc 53 - , AlexAcc 52 - , AlexAcc 51 - , AlexAcc 50 - , AlexAcc 49 - , AlexAcc 48 - , AlexAcc 47 - , AlexAcc 46 - , AlexAcc 45 - , AlexAcc 44 - , AlexAcc 43 - , AlexAcc 42 - , AlexAcc 41 - , AlexAcc 40 - , AlexAcc 39 - , AlexAcc 38 - , AlexAcc 37 - , AlexAcc 36 - , AlexAcc 35 - , AlexAcc 34 - , AlexAcc 33 - , AlexAcc 32 - , AlexAcc 31 - , AlexAcc 30 - , AlexAcc 29 - , AlexAcc 28 - , AlexAcc 27 - , AlexAcc 26 - , AlexAcc 25 - , AlexAcc 24 - , AlexAcc 23 - , AlexAcc 22 - , AlexAcc 21 - , AlexAcc 20 - , AlexAcc 19 - , AlexAcc 18 - , AlexAcc 17 - , AlexAcc 16 - , AlexAcc 15 - , AlexAcc 14 - , AlexAcc 13 - , AlexAcc 12 - , AlexAcc 11 - , AlexAcc 10 - , AlexAcc 9 - , AlexAcc 8 - , AlexAcc 7 - , AlexAcc 6 - , AlexAcc 5 - , AlexAcc 4 - , AlexAcc 3 - , AlexAcc 2 - , AlexAcc 1 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 0 - , AlexAccNone - , AlexAccNone - , AlexAccNone - ] - -alex_actions = array (0 :: Int, 138) - [ (137,alex_action_5) - , (136,alex_action_19) - , (135,alex_action_7) - , (134,alex_action_18) - , (133,alex_action_7) - , (132,alex_action_17) - , (131,alex_action_7) - , (130,alex_action_16) - , (129,alex_action_7) - , (128,alex_action_15) - , (127,alex_action_7) - , (126,alex_action_14) - , (125,alex_action_13) - , (124,alex_action_12) - , (123,alex_action_7) - , (122,alex_action_11) - , (121,alex_action_7) - , (120,alex_action_10) - , (119,alex_action_7) - , (118,alex_action_9) - , (117,alex_action_8) - , (116,alex_action_7) - , (115,alex_action_5) - , (114,alex_action_5) - , (113,alex_action_5) - , (112,alex_action_5) - , (111,alex_action_5) - , (110,alex_action_5) - , (109,alex_action_5) - , (108,alex_action_2) - , (107,alex_action_5) - , (106,alex_action_5) - , (105,alex_action_5) - , (104,alex_action_41) - , (103,alex_action_41) - , (102,alex_action_41) - , (101,alex_action_41) - , (100,alex_action_5) - , (99,alex_action_4) - , (98,alex_action_3) - , (97,alex_action_2) - , (96,alex_action_5) - , (95,alex_action_2) - , (94,alex_action_2) - , (93,alex_action_41) - , (92,alex_action_41) - , (91,alex_action_41) - , (90,alex_action_41) - , (89,alex_action_41) - , (88,alex_action_41) - , (87,alex_action_41) - , (86,alex_action_41) - , (85,alex_action_41) - , (84,alex_action_41) - , (83,alex_action_41) - , (82,alex_action_41) - , (81,alex_action_41) - , (80,alex_action_41) - , (79,alex_action_41) - , (78,alex_action_41) - , (77,alex_action_41) - , (76,alex_action_41) - , (75,alex_action_41) - , (74,alex_action_41) - , (73,alex_action_45) - , (72,alex_action_46) - , (71,alex_action_45) - , (70,alex_action_44) - , (69,alex_action_43) - , (68,alex_action_43) - , (67,alex_action_42) - , (66,alex_action_41) - , (65,alex_action_41) - , (64,alex_action_41) - , (63,alex_action_41) - , (62,alex_action_41) - , (61,alex_action_41) - , (60,alex_action_41) - , (59,alex_action_41) - , (58,alex_action_41) - , (57,alex_action_41) - , (56,alex_action_41) - , (55,alex_action_41) - , (54,alex_action_41) - , (53,alex_action_41) - , (52,alex_action_41) - , (51,alex_action_41) - , (50,alex_action_41) - , (49,alex_action_41) - , (48,alex_action_41) - , (47,alex_action_41) - , (46,alex_action_41) - , (45,alex_action_41) - , (44,alex_action_41) - , (43,alex_action_41) - , (42,alex_action_41) - , (41,alex_action_41) - , (40,alex_action_41) - , (39,alex_action_41) - , (38,alex_action_41) - , (37,alex_action_41) - , (36,alex_action_41) - , (35,alex_action_41) - , (34,alex_action_41) - , (33,alex_action_41) - , (32,alex_action_40) - , (31,alex_action_41) - , (30,alex_action_41) - , (29,alex_action_41) - , (28,alex_action_39) - , (27,alex_action_41) - , (26,alex_action_38) - , (25,alex_action_37) - , (24,alex_action_36) - , (23,alex_action_41) - , (22,alex_action_35) - , (21,alex_action_34) - , (20,alex_action_33) - , (19,alex_action_41) - , (18,alex_action_41) - , (17,alex_action_32) - , (16,alex_action_41) - , (15,alex_action_31) - , (14,alex_action_30) - , (13,alex_action_29) - , (12,alex_action_41) - , (11,alex_action_28) - , (10,alex_action_41) - , (9,alex_action_27) - , (8,alex_action_26) - , (7,alex_action_41) - , (6,alex_action_25) - , (5,alex_action_24) - , (4,alex_action_23) - , (3,alex_action_41) - , (2,alex_action_22) - , (1,alex_action_21) - , (0,alex_action_20) - ] - -{-# LINE 134 "_build/source-dist/ghc-9.8.4-src/ghc-9.8.4/compiler/GHC/Cmm/Lexer.x" #-} -data CmmToken - = CmmT_SpecChar Char - | CmmT_DotDot - | CmmT_DoubleColon - | CmmT_Shr - | CmmT_Shl - | CmmT_Ge - | CmmT_Le - | CmmT_Eq - | CmmT_Ne - | CmmT_BoolAnd - | CmmT_BoolOr - | CmmT_CLOSURE - | CmmT_INFO_TABLE - | CmmT_INFO_TABLE_RET - | CmmT_INFO_TABLE_FUN - | CmmT_INFO_TABLE_CONSTR - | CmmT_INFO_TABLE_SELECTOR - | CmmT_else - | CmmT_export - | CmmT_section - | CmmT_goto - | CmmT_if - | CmmT_call - | CmmT_jump - | CmmT_foreign - | CmmT_never - | CmmT_prim - | CmmT_reserve - | CmmT_return - | CmmT_returns - | CmmT_import - | CmmT_switch - | CmmT_case - | CmmT_default - | CmmT_push - | CmmT_unwind - | CmmT_bits8 - | CmmT_bits16 - | CmmT_bits32 - | CmmT_bits64 - | CmmT_bits128 - | CmmT_bits256 - | CmmT_bits512 - | CmmT_float32 - | CmmT_float64 - | CmmT_gcptr - | CmmT_GlobalReg GlobalRegUse - | CmmT_Name FastString - | CmmT_String String - | CmmT_Int Integer - | CmmT_Float Rational - | CmmT_EOF - | CmmT_False - | CmmT_True - | CmmT_likely - | CmmT_Relaxed - | CmmT_Acquire - | CmmT_Release - | CmmT_SeqCst - deriving (Show) - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken) - -begin :: Int -> Action -begin code _span _str _len = do liftP (pushLexState code); lexToken - -pop :: Action -pop _span _buf _len = liftP popLexState >> lexToken - -special_char :: Action -special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) - -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 - = 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 - -global_reg :: GlobalReg -> (Platform -> CmmType) -> Action -global_reg reg ty_fn span _buf _len - = do { platform <- getPlatform - ; let ty = ty_fn platform - ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } - -strtoken :: (String -> CmmToken) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -name :: Action -name span buf len = - case lookupUFM reservedWordsFM fs of - Just tok -> return (L span tok) - Nothing -> return (L span (CmmT_Name fs)) - where - fs = lexemeToFastString buf len - -reservedWordsFM = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "CLOSURE", CmmT_CLOSURE ), - ( "INFO_TABLE", CmmT_INFO_TABLE ), - ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), - ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), - ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), - ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), - ( "else", CmmT_else ), - ( "export", CmmT_export ), - ( "section", CmmT_section ), - ( "goto", CmmT_goto ), - ( "if", CmmT_if ), - ( "call", CmmT_call ), - ( "jump", CmmT_jump ), - ( "foreign", CmmT_foreign ), - ( "never", CmmT_never ), - ( "prim", CmmT_prim ), - ( "reserve", CmmT_reserve ), - ( "return", CmmT_return ), - ( "returns", CmmT_returns ), - ( "import", CmmT_import ), - ( "switch", CmmT_switch ), - ( "case", CmmT_case ), - ( "default", CmmT_default ), - ( "push", CmmT_push ), - ( "unwind", CmmT_unwind ), - ( "bits8", CmmT_bits8 ), - ( "bits16", CmmT_bits16 ), - ( "bits32", CmmT_bits32 ), - ( "bits64", CmmT_bits64 ), - ( "bits128", CmmT_bits128 ), - ( "bits256", CmmT_bits256 ), - ( "bits512", CmmT_bits512 ), - ( "float32", CmmT_float32 ), - ( "float64", CmmT_float64 ), --- New forms - ( "b8", CmmT_bits8 ), - ( "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 ), - ( "likely", CmmT_likely), - ( "True", CmmT_True ), - ( "False", CmmT_False ) - ] - -tok_decimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) - -tok_octal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) - -tok_hexadecimal span buf len - = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) - -tok_float str = CmmT_Float $! readRational str - -tok_string str = CmmT_String (read str) - -- urk, not quite right, but it'll do for now - --- ----------------------------------------------------------------------------- --- Line pragmas - -setLine :: Int -> Action -setLine code (PsSpan span _) buf len = do - let line = parseUnsignedInteger buf len 10 octDecDigit - liftP $ do - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line - -- trace ("setLine " ++ show line) $ do - popLexState >> pushLexState code - lexToken - -setFile :: Int -> Action -setFile code (PsSpan span _) buf len = do - let file = lexemeToFastString (stepOn buf) (len-2) - liftP $ do - setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) - popLexState >> pushLexState code - lexToken - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -cmmlex :: (Located CmmToken -> PD a) -> PD a -cmmlex cont = do - (L span tok) <- lexToken - --trace ("token: " ++ show tok) $ do - cont (L (mkSrcSpanPs span) tok) - -lexToken :: PD (PsLocated CmmToken) -lexToken = do - inp@(loc1,buf) <- getInput - sc <- liftP getLexState - case alexScan inp sc of - AlexEOF -> do let span = mkPsSpan loc1 loc1 - liftP (setLastToken span 0) - return (L span CmmT_EOF) - AlexError (loc2,_) -> - let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer - in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(end,_buf2) len t -> do - setInput inp2 - let span = mkPsSpan loc1 end - span `seq` liftP (setLastToken span len) - t span buf len - --- ----------------------------------------------------------------------------- --- Monad stuff - --- Stuff that Alex needs to know about our input type: -type AlexInput = (PsLoc,StringBuffer) - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (_,s) = prevChar s '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (loc,s) - | atEnd s = Nothing - | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) - where c = currentChar s - b = fromIntegral $ ord $ c - loc' = advancePsLoc loc c - s' = stepOn s - -getInput :: PD AlexInput -getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b) - -setInput :: AlexInput -> PD () -setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } () - -line_prag,line_prag1,line_prag2 :: Int -line_prag = 1 -line_prag1 = 2 -line_prag2 = 3 -alex_action_2 = begin line_prag -alex_action_3 = setLine line_prag1 -alex_action_4 = setFile line_prag2 -alex_action_5 = pop -alex_action_7 = special_char -alex_action_8 = kw CmmT_DotDot -alex_action_9 = kw CmmT_DoubleColon -alex_action_10 = kw CmmT_Shr -alex_action_11 = kw CmmT_Shl -alex_action_12 = kw CmmT_Ge -alex_action_13 = kw CmmT_Le -alex_action_14 = kw CmmT_Eq -alex_action_15 = kw CmmT_Ne -alex_action_16 = kw CmmT_BoolAnd -alex_action_17 = kw CmmT_BoolOr -alex_action_18 = kw CmmT_Relaxed -alex_action_19 = kw CmmT_Acquire -alex_action_20 = kw CmmT_Release -alex_action_21 = kw CmmT_SeqCst -alex_action_22 = kw CmmT_True -alex_action_23 = kw CmmT_False -alex_action_24 = kw CmmT_likely -alex_action_25 = global_regN VanillaReg gcWord -alex_action_26 = global_regN VanillaReg bWord -alex_action_27 = global_regN FloatReg (const $ cmmFloat W32) -alex_action_28 = global_regN DoubleReg (const $ cmmFloat W64) -alex_action_29 = global_regN LongReg (const $ cmmBits W64) -alex_action_30 = global_reg Sp bWord -alex_action_31 = global_reg SpLim bWord -alex_action_32 = global_reg Hp gcWord -alex_action_33 = global_reg HpLim bWord -alex_action_34 = global_reg CCCS bWord -alex_action_35 = global_reg CurrentTSO bWord -alex_action_36 = global_reg CurrentNursery bWord -alex_action_37 = global_reg HpAlloc bWord -alex_action_38 = global_reg BaseReg bWord -alex_action_39 = global_reg MachSp bWord -alex_action_40 = global_reg UnwindReturnReg bWord -alex_action_41 = name -alex_action_42 = tok_octal -alex_action_43 = tok_decimal -alex_action_44 = tok_hexadecimal -alex_action_45 = strtoken tok_float -alex_action_46 = strtoken tok_string - -#define ALEX_GHC 1 -#define ALEX_LATIN1 1 --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -#ifdef ALEX_GHC -# define ILIT(n) n# -# define IBOX(n) (I# (n)) -# define FAST_INT Int# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -# if __GLASGOW_HASKELL__ > 706 -# define GTE(n,m) (tagToEnum# (n >=# m)) -# define EQ(n,m) (tagToEnum# (n ==# m)) -# else -# define GTE(n,m) (n >=# m) -# define EQ(n,m) (n ==# m) -# endif -# define PLUS(n,m) (n +# m) -# define MINUS(n,m) (n -# m) -# define TIMES(n,m) (n *# m) -# define NEGATE(n) (negateInt# (n)) -# define IF_GHC(x) (x) -#else -# define ILIT(n) (n) -# define IBOX(n) (n) -# define FAST_INT Int -# define GTE(n,m) (n >= m) -# define EQ(n,m) (n == m) -# define PLUS(n,m) (n + m) -# define MINUS(n,m) (n - m) -# define TIMES(n,m) (n * m) -# define NEGATE(n) (negate (n)) -# define IF_GHC(x) -#endif - -#ifdef ALEX_GHC -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else -#if __GLASGOW_HASKELL__ >= 901 - int16ToInt# -#endif - (indexInt16OffAddr# arr off) -#endif -#else -alexIndexInt16OffAddr arr off = arr ! off -#endif - -#ifdef ALEX_GHC -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else -#if __GLASGOW_HASKELL__ >= 901 - int32ToInt# -#endif - (indexInt32OffAddr# arr off) -#endif -#else -alexIndexInt32OffAddr arr off = arr ! off -#endif - -#ifdef ALEX_GHC - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif -#else -quickIndex arr i = arr ! i -#endif - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ IBOX(sc) - = alexScanUser undefined input__ IBOX(sc) - -alexScanUser user__ input__ IBOX(sc) - = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> -#ifdef ALEX_DEBUG - trace ("End of input.") $ -#endif - AlexEOF - Just _ -> -#ifdef ALEX_DEBUG - trace ("Error.") $ -#endif - AlexError input__' - - (AlexLastSkip input__'' len, _) -> -#ifdef ALEX_DEBUG - trace ("Skipping.") $ -#endif - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> -#ifdef ALEX_DEBUG - trace ("Accept.") $ -#endif - AlexToken input__''' len (alex_actions ! k) - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> -#ifdef ALEX_DEBUG - trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ -#endif - case fromIntegral c of { IBOX(ord_c) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = PLUS(base,ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,ILIT(0)) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - ILIT(-1) -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input -#ifdef ALEX_LATIN1 - PLUS(len,ILIT(1)) - -- issue 119: in the latin1 encoding, *each* byte is one character -#else - (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) -#endif - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) - check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) -#ifndef ALEX_NOPRED - check_accs (AlexAccPred a predx rest) - | predx user__ orig_input IBOX(len) input__ - = AlexLastAcc a input__ IBOX(len) - | otherwise - = check_accs rest - check_accs (AlexAccSkipPred predx rest) - | predx user__ orig_input IBOX(len) input__ - = AlexLastSkip input__ IBOX(len) - | otherwise - = check_accs rest -#endif - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip -#ifndef ALEX_NOPRED - | AlexAccPred Int (AlexAccPred user) (AlexAcc user) - | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user__ in1 len in2 - = p1 user__ in1 len in2 && p2 user__ in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ - -alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext IBOX(sc) user__ _ _ input__ = - case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. -#endif +{-# LINE 13 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-} +module GHC.Cmm.Lexer ( + CmmToken(..), cmmlex, + ) where + +import GHC.Prelude + +import GHC.Cmm.Expr +import GHC.Cmm.Reg (GlobalArgRegs(..)) + +import GHC.Parser.Lexer +import GHC.Cmm.Parser.Monad +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Parser.CharClass +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () +import GHC.Platform +import GHC.Utils.Error +import GHC.Utils.Misc +--import TRACE + +import Data.Word +import Data.Char +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x01\x00\x00\x00\xc9\x00\x00\x00\x57\x00\x00\x00\xb9\x00\x00\x00\x2a\x01\x00\x00\x29\x02\x00\x00\x28\x03\x00\x00\x27\x04\x00\x00\x26\x05\x00\x00\x25\x06\x00\x00\x25\x07\x00\x00\xf8\x07\x00\x00\xcb\x08\x00\x00\x9e\x09\x00\x00\x93\xff\xff\xff\xa6\xff\xff\xff\xc2\xff\xff\xff\xce\xff\xff\xff\xd2\xff\xff\xff\x00\x00\x00\x00\xe1\xff\xff\xff\xd7\xff\xff\xff\xe6\xff\xff\xff\x00\x00\x00\x00\xe9\xff\xff\xff\xde\xff\xff\xff\xdb\xff\xff\xff\xef\xff\xff\xff\xe0\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x03\x00\x00\x00\xf9\xff\xff\xff\x05\x00\x00\x00\xf1\xff\xff\xff\x06\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xff\xff\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x71\x0a\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x71\x00\x00\x00\xc4\x00\x00\x00\xb7\x00\x00\x00\xbd\x00\x00\x00\xbe\x00\x00\x00\xc2\x00\x00\x00\xc1\x00\x00\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x44\x0b\x00\x00\x17\x0c\x00\x00\xea\x0c\x00\x00\xbd\x0d\x00\x00\x90\x0e\x00\x00\x63\x0f\x00\x00\x36\x10\x00\x00\x09\x11\x00\x00\xdc\x11\x00\x00\xaf\x12\x00\x00\x82\x13\x00\x00\x55\x14\x00\x00\x28\x15\x00\x00\xfb\x15\x00\x00\xce\x16\x00\x00\xa1\x17\x00\x00\x74\x18\x00\x00\x47\x19\x00\x00\x1a\x1a\x00\x00\xd7\x00\x00\x00\xd9\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xd8\x00\x00\x00\x7a\x00\x00\x00\x6a\x00\x00\x00\x72\x00\x00\x00\x82\x00\x00\x00\xed\x1a\x00\x00\xc0\x1b\x00\x00\x93\x1c\x00\x00\x66\x1d\x00\x00\x39\x1e\x00\x00\x0c\x1f\x00\x00\xdf\x1f\x00\x00\xb2\x20\x00\x00\x85\x21\x00\x00\x58\x22\x00\x00\x2b\x23\x00\x00\xfe\x23\x00\x00\xd1\x24\x00\x00\xa4\x25\x00\x00\x77\x26\x00\x00\x4a\x27\x00\x00\x1d\x28\x00\x00\xf0\x28\x00\x00\xc3\x29\x00\x00\x96\x2a\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x8c\x00\x00\x00\x03\x01\x00\x00\x84\x01\x00\x00\x87\x00\x00\x00\x83\x00\x00\x00\x8e\x00\x00\x00\x34\x2b\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x46\x01\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x00\x00\xa3\x03\x00\x00\x7d\x2b\x00\x00\xa4\x01\x00\x00\x00\x02\x00\x00\x81\x04\x00\x00\xa1\x04\x00\x00\x96\x2b\x00\x00\xbc\x2b\x00\x00\xfd\x04\x00\x00\xd5\x2b\x00\x00\x80\x05\x00\x00\x49\x2c\x00\x00\x1c\x2d\x00\x00\xef\x2d\x00\x00\xc2\x2e\x00\x00\x95\x2f\x00\x00\x68\x30\x00\x00\x3b\x31\x00\x00\x0e\x32\x00\x00\xe1\x32\x00\x00\xb4\x33\x00\x00\x87\x34\x00\x00\x5a\x35\x00\x00\x2d\x36\x00\x00\x00\x37\x00\x00\xd3\x37\x00\x00\xa6\x38\x00\x00\x79\x39\x00\x00\x4c\x3a\x00\x00\x1f\x3b\x00\x00\xf2\x3b\x00\x00\xc5\x3c\x00\x00\x98\x3d\x00\x00\x6b\x3e\x00\x00\x3e\x3f\x00\x00\x11\x40\x00\x00\xe4\x40\x00\x00\xb7\x41\x00\x00\x8a\x42\x00\x00\x5d\x43\x00\x00\x30\x44\x00\x00\x03\x45\x00\x00\xd6\x45\x00\x00\x9e\x46\x00\x00\x9d\x47\x00\x00\x9d\x48\x00\x00\x70\x49\x00\x00\x43\x4a\x00\x00\x16\x4b\x00\x00\xe9\x4b\x00\x00\xbc\x4c\x00\x00\x8f\x4d\x00\x00\x62\x4e\x00\x00\x35\x4f\x00\x00\x08\x50\x00\x00\xdb\x50\x00\x00\xae\x51\x00\x00\x81\x52\x00\x00\x54\x53\x00\x00\x27\x54\x00\x00\xfa\x54\x00\x00\xcd\x55\x00\x00\xa0\x56\x00\x00\x73\x57\x00\x00\x46\x58\x00\x00\x19\x59\x00\x00\xec\x59\x00\x00\xbf\x5a\x00\x00\x92\x5b\x00\x00\x65\x5c\x00\x00\x38\x5d\x00\x00\x0b\x5e\x00\x00\xde\x5e\x00\x00\xb1\x5f\x00\x00\x84\x60\x00\x00\x57\x61\x00\x00\x2a\x62\x00\x00\xfd\x62\x00\x00\xd0\x63\x00\x00\xa3\x64\x00\x00\x76\x65\x00\x00\x49\x66\x00\x00\x1c\x67\x00\x00\xef\x67\x00\x00\xc2\x68\x00\x00\x95\x69\x00\x00\x68\x6a\x00\x00\x3b\x6b\x00\x00\x0e\x6c\x00\x00\xe1\x6c\x00\x00\xb4\x6d\x00\x00\x87\x6e\x00\x00\x5a\x6f\x00\x00\x2d\x70\x00\x00\x00\x71\x00\x00\xd3\x71\x00\x00\xa6\x72\x00\x00\x79\x73\x00\x00\x4c\x74\x00\x00\x1f\x75\x00\x00\xf2\x75\x00\x00\xc5\x76\x00\x00\x98\x77\x00\x00\x6b\x78\x00\x00\x3e\x79\x00\x00\x11\x7a\x00\x00\xe4\x7a\x00\x00\xb7\x7b\x00\x00\x8a\x7c\x00\x00\x5d\x7d\x00\x00\x25\x7e\x00\x00\x24\x7f\x00\x00\x24\x80\x00\x00\xf7\x80\x00\x00\xbf\x81\x00\x00\xbe\x82\x00\x00\xbe\x83\x00\x00\x91\x84\x00\x00\x59\x85\x00\x00\x58\x86\x00\x00\x57\x87\x00\x00\x56\x88\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\xff\xff\x8d\x00\xff\xff\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x3a\x00\x81\x00\x81\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x2b\x00\x84\x00\x5e\x00\x11\x00\x1f\x00\x29\x00\xff\xff\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x39\x00\xaf\x00\x38\x00\x8e\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x35\x00\x38\x00\x31\x00\x2d\x00\x33\x00\xff\xff\x12\x00\x15\x00\x69\x00\xa9\x00\xb1\x00\x13\x00\xb0\x00\xb4\x00\xaa\x00\x16\x00\x17\x00\x19\x00\xfe\x00\x45\x00\x1a\x00\x1b\x00\x08\x00\x1d\x00\x06\x00\x4b\x00\x9d\x00\xa5\x00\xb6\x00\x1c\x00\xb3\x00\xfa\x00\xf6\x00\x38\x00\xff\xff\x38\x00\x38\x00\x81\x00\x38\x00\x81\x00\x81\x00\x81\x00\x22\x00\x23\x00\x1e\x00\x21\x00\x24\x00\x14\x00\x25\x00\x26\x00\x71\x00\x28\x00\x2a\x00\x2c\x00\x2e\x00\x32\x00\x2f\x00\x30\x00\x34\x00\x36\x00\x81\x00\x80\x00\x5a\x00\x5e\x00\xff\xff\x38\x00\x27\x00\x38\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\xff\xff\xff\xff\x18\x00\x5c\x00\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\x81\x00\x60\x00\x81\x00\x81\x00\x81\x00\x89\x00\xff\xff\x3d\x00\x20\x00\x82\x00\x43\x00\xff\xff\xff\xff\x59\x00\x61\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x5c\x00\x5f\x00\x76\x00\x78\x00\x81\x00\x77\x00\xff\xff\x5e\x00\x7b\x00\x7c\x00\x7f\x00\x7d\x00\x80\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\xff\xff\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5b\x00\x7a\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x40\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x04\x00\x00\x00\x90\x00\x90\x00\x42\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x3c\x00\x5d\x00\x44\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x81\x00\x00\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x3d\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x3d\x00\x00\x00\x81\x00\x00\x00\x00\x00\x81\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x89\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x88\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x79\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x8b\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x86\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x66\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x04\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x4a\x00\x00\x00\x49\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbb\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdd\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x00\x00\x01\x00\x02\x00\x71\x00\x5f\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x63\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x73\x00\x61\x00\x42\x00\x43\x00\x44\x00\x74\x00\x46\x00\x47\x00\x48\x00\x73\x00\x65\x00\x63\x00\x4c\x00\x4d\x00\x71\x00\x75\x00\x50\x00\x72\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x69\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x09\x00\x60\x00\x0b\x00\x0c\x00\x0d\x00\x6c\x00\x61\x00\x65\x00\x65\x00\x78\x00\x65\x00\x65\x00\x64\x00\x6c\x00\x7c\x00\x26\x00\x3d\x00\x3d\x00\x3c\x00\x3d\x00\x3d\x00\x3e\x00\x3a\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x61\x00\x01\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x69\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\xd7\x00\x20\x00\x72\x00\x73\x00\x23\x00\x0a\x00\x0a\x00\x6e\x00\x6e\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x01\x00\x6c\x00\x65\x00\x72\x00\x20\x00\x70\x00\x0a\x00\x23\x00\x61\x00\x67\x00\x61\x00\x6d\x00\x0a\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x22\x00\x01\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x69\x00\x65\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xa0\x00\xff\xff\x20\x00\xff\xff\xff\xff\xa0\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\xff\xff\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x01\x00\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x78\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\x31\x00\xff\xff\x33\x00\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\x90\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x58\x00\x58\x00\x5a\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x84\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 254) + [ AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 209 + , AlexAcc 208 + , AlexAcc 207 + , AlexAcc 206 + , AlexAcc 205 + , AlexAcc 204 + , AlexAcc 203 + , AlexAcc 202 + , AlexAcc 201 + , AlexAcc 200 + , AlexAcc 199 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 198 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 197 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 196 + , AlexAcc 195 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 194 + , AlexAcc 193 + , AlexAcc 192 + , AlexAcc 191 + , AlexAcc 190 + , AlexAcc 189 + , AlexAcc 188 + , AlexAcc 187 + , AlexAcc 186 + , AlexAcc 185 + , AlexAcc 184 + , AlexAcc 183 + , AlexAcc 182 + , AlexAcc 181 + , AlexAcc 180 + , AlexAcc 179 + , AlexAcc 178 + , AlexAcc 177 + , AlexAcc 176 + , AlexAcc 175 + , AlexAccSkip + , AlexAcc 174 + , AlexAcc 173 + , AlexAccSkip + , AlexAcc 172 + , AlexAcc 171 + , AlexAcc 170 + , AlexAcc 169 + , AlexAcc 168 + , AlexAccPred 167 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 166) + , AlexAcc 165 + , AlexAcc 164 + , AlexAcc 163 + , AlexAcc 162 + , AlexAcc 161 + , AlexAcc 160 + , AlexAcc 159 + , AlexAcc 158 + , AlexAcc 157 + , AlexAcc 156 + , AlexAcc 155 + , AlexAcc 154 + , AlexAcc 153 + , AlexAcc 152 + , AlexAcc 151 + , AlexAcc 150 + , AlexAcc 149 + , AlexAcc 148 + , AlexAcc 147 + , AlexAcc 146 + , AlexAcc 145 + , AlexAcc 144 + , AlexAccNone + , AlexAcc 143 + , AlexAcc 142 + , AlexAccPred 141 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 140) + , AlexAccPred 139 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 138 + , AlexAcc 137 + , AlexAcc 136 + , AlexAcc 135 + , AlexAcc 134 + , AlexAcc 133 + , AlexAcc 132 + , AlexAcc 131 + , AlexAcc 130 + , AlexAcc 129 + , AlexAcc 128 + , AlexAcc 127 + , AlexAcc 126 + , AlexAcc 125 + , AlexAcc 124 + , AlexAcc 123 + , AlexAcc 122 + , AlexAcc 121 + , AlexAcc 120 + , AlexAcc 119 + , AlexAccPred 118 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 117 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkip + , AlexAccNone + , AlexAcc 116 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 115 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 114 + , AlexAccNone + , AlexAcc 113 + , AlexAcc 112 + , AlexAcc 111 + , AlexAcc 110 + , AlexAcc 109 + , AlexAcc 108 + , AlexAcc 107 + , AlexAcc 106 + , AlexAcc 105 + , AlexAcc 104 + , AlexAcc 103 + , AlexAcc 102 + , AlexAcc 101 + , AlexAcc 100 + , AlexAcc 99 + , AlexAcc 98 + , AlexAcc 97 + , AlexAcc 96 + , AlexAcc 95 + , AlexAcc 94 + , AlexAcc 93 + , AlexAcc 92 + , AlexAcc 91 + , AlexAcc 90 + , AlexAcc 89 + , AlexAcc 88 + , AlexAcc 87 + , AlexAcc 86 + , AlexAcc 85 + , AlexAcc 84 + , AlexAcc 83 + , AlexAcc 82 + , AlexAcc 81 + , AlexAcc 80 + , AlexAcc 79 + , AlexAcc 78 + , AlexAcc 77 + , AlexAcc 76 + , AlexAcc 75 + , AlexAcc 74 + , AlexAcc 73 + , AlexAcc 72 + , AlexAcc 71 + , AlexAcc 70 + , AlexAcc 69 + , AlexAcc 68 + , AlexAcc 67 + , AlexAcc 66 + , AlexAcc 65 + , AlexAcc 64 + , AlexAcc 63 + , AlexAcc 62 + , AlexAcc 61 + , AlexAcc 60 + , AlexAcc 59 + , AlexAcc 58 + , AlexAcc 57 + , AlexAcc 56 + , AlexAcc 55 + , AlexAcc 54 + , AlexAcc 53 + , AlexAcc 52 + , AlexAcc 51 + , AlexAcc 50 + , AlexAcc 49 + , AlexAcc 48 + , AlexAcc 47 + , AlexAcc 46 + , AlexAcc 45 + , AlexAcc 44 + , AlexAcc 43 + , AlexAcc 42 + , AlexAcc 41 + , AlexAcc 40 + , AlexAcc 39 + , AlexAcc 38 + , AlexAcc 37 + , AlexAcc 36 + , AlexAcc 35 + , AlexAcc 34 + , AlexAcc 33 + , AlexAcc 32 + , AlexAcc 31 + , AlexAcc 30 + , AlexAcc 29 + , AlexAcc 28 + , AlexAcc 27 + , AlexAcc 26 + , AlexAcc 25 + , AlexAcc 24 + , AlexAcc 23 + , AlexAcc 22 + , AlexAcc 21 + , AlexAcc 20 + , AlexAcc 19 + , AlexAcc 18 + , AlexAcc 17 + , AlexAcc 16 + , AlexAcc 15 + , AlexAcc 14 + , AlexAcc 13 + , AlexAcc 12 + , AlexAcc 11 + , AlexAcc 10 + , AlexAcc 9 + , AlexAcc 8 + , AlexAcc 7 + , AlexAcc 6 + , AlexAcc 5 + , AlexAcc 4 + , AlexAcc 3 + , AlexAcc 2 + , AlexAcc 1 + , AlexAcc 0 + ] + +alex_actions = array (0 :: Int, 210) + [ (209,alex_action_5) + , (208,alex_action_28) + , (207,alex_action_27) + , (206,alex_action_49) + , (205,alex_action_26) + , (204,alex_action_49) + , (203,alex_action_25) + , (202,alex_action_24) + , (201,alex_action_23) + , (200,alex_action_49) + , (199,alex_action_22) + , (198,alex_action_21) + , (197,alex_action_20) + , (196,alex_action_19) + , (195,alex_action_7) + , (194,alex_action_18) + , (193,alex_action_7) + , (192,alex_action_17) + , (191,alex_action_7) + , (190,alex_action_16) + , (189,alex_action_7) + , (188,alex_action_15) + , (187,alex_action_7) + , (186,alex_action_14) + , (185,alex_action_13) + , (184,alex_action_12) + , (183,alex_action_7) + , (182,alex_action_11) + , (181,alex_action_7) + , (180,alex_action_10) + , (179,alex_action_7) + , (178,alex_action_9) + , (177,alex_action_8) + , (176,alex_action_7) + , (175,alex_action_7) + , (174,alex_action_5) + , (173,alex_action_5) + , (172,alex_action_5) + , (171,alex_action_5) + , (170,alex_action_5) + , (169,alex_action_5) + , (168,alex_action_5) + , (167,alex_action_2) + , (166,alex_action_5) + , (165,alex_action_5) + , (164,alex_action_49) + , (163,alex_action_49) + , (162,alex_action_49) + , (161,alex_action_49) + , (160,alex_action_49) + , (159,alex_action_49) + , (158,alex_action_49) + , (157,alex_action_49) + , (156,alex_action_49) + , (155,alex_action_49) + , (154,alex_action_49) + , (153,alex_action_49) + , (152,alex_action_49) + , (151,alex_action_49) + , (150,alex_action_49) + , (149,alex_action_49) + , (148,alex_action_49) + , (147,alex_action_49) + , (146,alex_action_49) + , (145,alex_action_5) + , (144,alex_action_5) + , (143,alex_action_4) + , (142,alex_action_3) + , (141,alex_action_2) + , (140,alex_action_5) + , (139,alex_action_2) + , (138,alex_action_49) + , (137,alex_action_49) + , (136,alex_action_49) + , (135,alex_action_49) + , (134,alex_action_49) + , (133,alex_action_49) + , (132,alex_action_49) + , (131,alex_action_49) + , (130,alex_action_49) + , (129,alex_action_49) + , (128,alex_action_49) + , (127,alex_action_49) + , (126,alex_action_49) + , (125,alex_action_49) + , (124,alex_action_49) + , (123,alex_action_49) + , (122,alex_action_49) + , (121,alex_action_49) + , (120,alex_action_49) + , (119,alex_action_49) + , (118,alex_action_2) + , (117,alex_action_53) + , (116,alex_action_54) + , (115,alex_action_53) + , (114,alex_action_52) + , (113,alex_action_51) + , (112,alex_action_51) + , (111,alex_action_50) + , (110,alex_action_49) + , (109,alex_action_49) + , (108,alex_action_49) + , (107,alex_action_49) + , (106,alex_action_49) + , (105,alex_action_49) + , (104,alex_action_49) + , (103,alex_action_49) + , (102,alex_action_49) + , (101,alex_action_49) + , (100,alex_action_49) + , (99,alex_action_49) + , (98,alex_action_49) + , (97,alex_action_49) + , (96,alex_action_49) + , (95,alex_action_49) + , (94,alex_action_49) + , (93,alex_action_49) + , (92,alex_action_49) + , (91,alex_action_49) + , (90,alex_action_49) + , (89,alex_action_49) + , (88,alex_action_49) + , (87,alex_action_49) + , (86,alex_action_49) + , (85,alex_action_49) + , (84,alex_action_49) + , (83,alex_action_49) + , (82,alex_action_49) + , (81,alex_action_49) + , (80,alex_action_49) + , (79,alex_action_49) + , (78,alex_action_49) + , (77,alex_action_49) + , (76,alex_action_49) + , (75,alex_action_49) + , (74,alex_action_49) + , (73,alex_action_49) + , (72,alex_action_49) + , (71,alex_action_48) + , (70,alex_action_49) + , (69,alex_action_49) + , (68,alex_action_49) + , (67,alex_action_49) + , (66,alex_action_49) + , (65,alex_action_49) + , (64,alex_action_49) + , (63,alex_action_49) + , (62,alex_action_49) + , (61,alex_action_47) + , (60,alex_action_49) + , (59,alex_action_49) + , (58,alex_action_49) + , (57,alex_action_49) + , (56,alex_action_49) + , (55,alex_action_49) + , (54,alex_action_49) + , (53,alex_action_49) + , (52,alex_action_49) + , (51,alex_action_46) + , (50,alex_action_49) + , (49,alex_action_49) + , (48,alex_action_49) + , (47,alex_action_49) + , (46,alex_action_49) + , (45,alex_action_49) + , (44,alex_action_49) + , (43,alex_action_49) + , (42,alex_action_49) + , (41,alex_action_45) + , (40,alex_action_49) + , (39,alex_action_49) + , (38,alex_action_49) + , (37,alex_action_49) + , (36,alex_action_49) + , (35,alex_action_49) + , (34,alex_action_49) + , (33,alex_action_49) + , (32,alex_action_49) + , (31,alex_action_44) + , (30,alex_action_49) + , (29,alex_action_43) + , (28,alex_action_49) + , (27,alex_action_49) + , (26,alex_action_49) + , (25,alex_action_42) + , (24,alex_action_49) + , (23,alex_action_41) + , (22,alex_action_40) + , (21,alex_action_39) + , (20,alex_action_49) + , (19,alex_action_38) + , (18,alex_action_37) + , (17,alex_action_36) + , (16,alex_action_49) + , (15,alex_action_49) + , (14,alex_action_35) + , (13,alex_action_34) + , (12,alex_action_33) + , (11,alex_action_32) + , (10,alex_action_49) + , (9,alex_action_49) + , (8,alex_action_49) + , (7,alex_action_31) + , (6,alex_action_49) + , (5,alex_action_49) + , (4,alex_action_49) + , (3,alex_action_30) + , (2,alex_action_49) + , (1,alex_action_29) + , (0,alex_action_49) + ] + + +line_prag,line_prag1,line_prag2 :: Int +line_prag = 1 +line_prag1 = 2 +line_prag2 = 3 +alex_action_2 = begin line_prag +alex_action_3 = setLine line_prag1 +alex_action_4 = setFile line_prag2 +alex_action_5 = pop +alex_action_7 = special_char +alex_action_8 = kw CmmT_DotDot +alex_action_9 = kw CmmT_DoubleColon +alex_action_10 = kw CmmT_Shr +alex_action_11 = kw CmmT_Shl +alex_action_12 = kw CmmT_Ge +alex_action_13 = kw CmmT_Le +alex_action_14 = kw CmmT_Eq +alex_action_15 = kw CmmT_Ne +alex_action_16 = kw CmmT_BoolAnd +alex_action_17 = kw CmmT_BoolOr +alex_action_18 = kw CmmT_Relaxed +alex_action_19 = kw CmmT_Acquire +alex_action_20 = kw CmmT_Release +alex_action_21 = kw CmmT_SeqCst +alex_action_22 = kw CmmT_True +alex_action_23 = kw CmmT_False +alex_action_24 = kw CmmT_likely +alex_action_25 = global_regN 1 VanillaReg gcWord +alex_action_26 = global_regN 1 VanillaReg bWord +alex_action_27 = global_regN 1 FloatReg (const $ cmmFloat W32) +alex_action_28 = global_regN 1 DoubleReg (const $ cmmFloat W64) +alex_action_29 = global_regN 1 LongReg (const $ cmmBits W64) +alex_action_30 = global_regN 3 XmmReg (const $ cmmVec 2 (cmmFloat W64)) +alex_action_31 = global_regN 3 YmmReg (const $ cmmVec 4 (cmmFloat W64)) +alex_action_32 = global_regN 3 ZmmReg (const $ cmmVec 8 (cmmFloat W64)) +alex_action_33 = global_reg Sp bWord +alex_action_34 = global_reg SpLim bWord +alex_action_35 = global_reg Hp gcWord +alex_action_36 = global_reg HpLim bWord +alex_action_37 = global_reg CCCS bWord +alex_action_38 = global_reg CurrentTSO bWord +alex_action_39 = global_reg CurrentNursery bWord +alex_action_40 = global_reg HpAlloc bWord +alex_action_41 = global_reg BaseReg bWord +alex_action_42 = global_reg MachSp bWord +alex_action_43 = global_reg UnwindReturnReg bWord +alex_action_44 = kw (CmmT_GlobalArgRegs GP_ARG_REGS) +alex_action_45 = kw (CmmT_GlobalArgRegs SCALAR_ARG_REGS) +alex_action_46 = kw (CmmT_GlobalArgRegs V16_ARG_REGS) +alex_action_47 = kw (CmmT_GlobalArgRegs V32_ARG_REGS) +alex_action_48 = kw (CmmT_GlobalArgRegs V64_ARG_REGS) +alex_action_49 = name +alex_action_50 = tok_octal +alex_action_51 = tok_decimal +alex_action_52 = tok_hexadecimal +alex_action_53 = strtoken tok_float +alex_action_54 = strtoken tok_string + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 144 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-} +data CmmToken + = CmmT_SpecChar Char + | CmmT_DotDot + | CmmT_DoubleColon + | CmmT_Shr + | CmmT_Shl + | CmmT_Ge + | CmmT_Le + | CmmT_Eq + | CmmT_Ne + | CmmT_BoolAnd + | CmmT_BoolOr + | CmmT_CLOSURE + | CmmT_INFO_TABLE + | CmmT_INFO_TABLE_RET + | CmmT_INFO_TABLE_FUN + | CmmT_INFO_TABLE_CONSTR + | CmmT_INFO_TABLE_SELECTOR + | CmmT_else + | CmmT_export + | CmmT_section + | CmmT_goto + | CmmT_if + | CmmT_call + | CmmT_jump + | CmmT_foreign + | CmmT_never + | CmmT_prim + | CmmT_reserve + | CmmT_return + | CmmT_returns + | CmmT_import + | CmmT_switch + | CmmT_case + | CmmT_default + | CmmT_push + | CmmT_unwind + | CmmT_bits8 + | CmmT_bits16 + | CmmT_bits32 + | CmmT_bits64 + | CmmT_vec128 + | CmmT_vec256 + | CmmT_vec512 + | CmmT_float32 + | CmmT_float64 + | CmmT_gcptr + | CmmT_GlobalReg GlobalRegUse + | CmmT_GlobalArgRegs GlobalArgRegs + | CmmT_Name FastString + | CmmT_String String + | CmmT_Int Integer + | CmmT_Float Rational + | CmmT_EOF + | CmmT_False + | CmmT_True + | CmmT_likely + | CmmT_Relaxed + | CmmT_Acquire + | CmmT_Release + | CmmT_SeqCst + deriving (Show) + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken) + +begin :: Int -> Action +begin code _span _str _len = do liftP (pushLexState code); lexToken + +pop :: Action +pop _span _buf _len = liftP popLexState >> lexToken + +special_char :: Action +special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) + +kw :: CmmToken -> Action +kw tok span _buf _len = return (L span tok) + +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' = 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 + = do { platform <- getPlatform + ; let ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } + +strtoken :: (String -> CmmToken) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +name :: Action +name span buf len = + case lookupUFM reservedWordsFM fs of + Just tok -> return (L span tok) + Nothing -> return (L span (CmmT_Name fs)) + where + fs = lexemeToFastString buf len + +reservedWordsFM = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "CLOSURE", CmmT_CLOSURE ), + ( "INFO_TABLE", CmmT_INFO_TABLE ), + ( "INFO_TABLE_RET", CmmT_INFO_TABLE_RET ), + ( "INFO_TABLE_FUN", CmmT_INFO_TABLE_FUN ), + ( "INFO_TABLE_CONSTR", CmmT_INFO_TABLE_CONSTR ), + ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ), + ( "else", CmmT_else ), + ( "export", CmmT_export ), + ( "section", CmmT_section ), + ( "goto", CmmT_goto ), + ( "if", CmmT_if ), + ( "call", CmmT_call ), + ( "jump", CmmT_jump ), + ( "foreign", CmmT_foreign ), + ( "never", CmmT_never ), + ( "prim", CmmT_prim ), + ( "reserve", CmmT_reserve ), + ( "return", CmmT_return ), + ( "returns", CmmT_returns ), + ( "import", CmmT_import ), + ( "switch", CmmT_switch ), + ( "case", CmmT_case ), + ( "default", CmmT_default ), + ( "push", CmmT_push ), + ( "unwind", CmmT_unwind ), + ( "bits8", CmmT_bits8 ), + ( "bits16", CmmT_bits16 ), + ( "bits32", CmmT_bits32 ), + ( "bits64", CmmT_bits64 ), + ( "vec128", CmmT_vec128 ), + ( "vec256", CmmT_vec256 ), + ( "vec512", CmmT_vec512 ), + ( "float32", CmmT_float32 ), + ( "float64", CmmT_float64 ), +-- New forms + ( "b8", CmmT_bits8 ), + ( "b16", CmmT_bits16 ), + ( "b32", CmmT_bits32 ), + ( "b64", CmmT_bits64 ), + ( "f32", CmmT_float32 ), + ( "f64", CmmT_float64 ), + ( "gcptr", CmmT_gcptr ), + ( "likely", CmmT_likely), + ( "True", CmmT_True ), + ( "False", CmmT_False ) + ] + +tok_decimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger buf len 10 octDecDigit)) + +tok_octal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit)) + +tok_hexadecimal span buf len + = return (L span (CmmT_Int $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit)) + +tok_float str = CmmT_Float $! readRational str + +tok_string str = CmmT_String (read str) + -- urk, not quite right, but it'll do for now + +-- ----------------------------------------------------------------------------- +-- Line pragmas + +setLine :: Int -> Action +setLine code (PsSpan span _) buf len = do + let line = parseUnsignedInteger buf len 10 octDecDigit + liftP $ do + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line + -- trace ("setLine " ++ show line) $ do + popLexState >> pushLexState code + lexToken + +setFile :: Int -> Action +setFile code (PsSpan span _) buf len = do + let file = lexemeToFastString (stepOn buf) (len-2) + liftP $ do + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + popLexState >> pushLexState code + lexToken + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +cmmlex :: (Located CmmToken -> PD a) -> PD a +cmmlex cont = do + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (mkSrcSpanPs span) tok) + +lexToken :: PD (PsLocated CmmToken) +lexToken = do + inp@(loc1,buf) <- getInput + sc <- liftP getLexState + case alexScan inp sc of + AlexEOF -> do let span = mkPsSpan loc1 loc1 + liftP (setLastToken span 0) + return (L span CmmT_EOF) + AlexError (loc2,_) -> + let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer + in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(end,_buf2) len t -> do + setInput inp2 + let span = mkPsSpan loc1 end + span `seq` liftP (setLastToken span len) + t span buf len + +-- ----------------------------------------------------------------------------- +-- Monad stuff + +-- Stuff that Alex needs to know about our input type: +type AlexInput = (PsLoc,StringBuffer) + +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (_,s) = prevChar s '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (loc,s) + | atEnd s = Nothing + | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s')) + where c = currentChar s + b = fromIntegral $ ord $ c + loc' = advancePsLoc loc c + s' = stepOn s + +getInput :: PD AlexInput +getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b) + +setInput :: AlexInput -> PD () +setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } () diff --git a/GHC/Cmm/Lint.hs b/GHC/Cmm/Lint.hs --- a/GHC/Cmm/Lint.hs +++ b/GHC/Cmm/Lint.hs @@ -18,7 +18,6 @@ import GHC.Platform import GHC.Platform.Regs (callerSaves) import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm @@ -103,9 +102,11 @@ platform <- getPlatform tys <- mapM lintCmmExpr args lintShiftOp op (zip args tys) - if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op - then cmmCheckMachOp op args tys - else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op) + let machop_arg_widths = machOpArgReps platform op + arg_tys = map (cmmExprType platform) args + if map typeWidth arg_tys == machop_arg_widths + then cmmCheckMachOp op args tys + else cmmLintMachOpErr expr arg_tys machop_arg_widths lintCmmExpr (CmmRegOff reg offset) = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) @@ -172,7 +173,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 @@ -181,14 +182,13 @@ return () CmmUnsafeForeignCall target _formals actuals -> do - lintTarget target let lintArg expr = do -- Arguments can't mention caller-saved -- registers. See Note [Register parameter passing]. mayNotMentionCallerSavedRegs (text "foreign call argument") expr lintCmmExpr expr - - mapM_ lintArg actuals + arg_tys <- mapM lintArg actuals + lintTarget arg_tys target lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint () @@ -214,7 +214,6 @@ maybe (return ()) checkTarget cont CmmForeignCall tgt _ args succ _ _ _ -> do - lintTarget tgt let lintArg expr = do -- Arguments can't mention caller-saved -- registers. See Note [Register @@ -224,19 +223,24 @@ -- places in caller-saved registers. mayNotMentionCallerSavedRegs (text "foreign call argument") expr lintCmmExpr expr - mapM_ lintArg args + arg_tys <- mapM lintArg args + lintTarget arg_tys tgt checkTarget succ where checkTarget id | setMember id labels = return () | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id) -lintTarget :: ForeignTarget -> CmmLint () -lintTarget (ForeignTarget e _) = do +lintTarget :: [CmmType] -> ForeignTarget -> CmmLint () +lintTarget _arg_tys (ForeignTarget e _) = do mayNotMentionCallerSavedRegs (text "foreign target") e _ <- lintCmmExpr e return () -lintTarget (PrimTarget {}) = return () +lintTarget arg_tys (PrimTarget mop) = do + platform <- getPlatform + let machop_arg_tys = callishMachOpArgTys platform mop + unless (and $ zipWith cmmCompatType arg_tys machop_arg_tys) $ + cmmLintCallishMachOpErr mop arg_tys machop_arg_tys -- | As noted in Note [Register parameter passing], the arguments and -- 'ForeignTarget' of a foreign call mustn't mention @@ -286,6 +290,13 @@ nest 2 (pdoc platform expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) + +cmmLintCallishMachOpErr :: CallishMachOp -> [CmmType] -> [CmmType] -> CmmLint a +cmmLintCallishMachOpErr mop argTys mopTys + = cmmLintErr (text "in Callish MachOp application: " $$ + nest 2 (text $ show mop) $$ + (text "op is expecting: " <+> ppr mopTys) $$ + (text "arguments provide: " <+> ppr argTys)) cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a cmmLintAssignErr stmt e_ty r_ty diff --git a/GHC/Cmm/Liveness.hs b/GHC/Cmm/Liveness.hs --- a/GHC/Cmm/Liveness.hs +++ b/GHC/Cmm/Liveness.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} module GHC.Cmm.Liveness ( CmmLocalLive @@ -21,7 +18,6 @@ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label import GHC.Cmm.LRegSet @@ -30,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 ----------------------------------------------------------------------------- @@ -63,9 +57,9 @@ where entry = g_entry graph check facts = - noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts + noLiveOnEntry entry (expectJust $ mapLookup entry facts) facts -cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg +cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse cmmGlobalLiveness platform graph = analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty @@ -98,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. @@ -116,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 @@ -126,7 +120,7 @@ where entry = g_entry graph check facts = - noLiveOnEntryL entry (expectJust "check" $ mapLookup entry facts) facts + noLiveOnEntryL entry (expectJust $ mapLookup entry facts) facts -- | On entry to the procedure, there had better not be any LocalReg's live-in. noLiveOnEntryL :: BlockId -> LRegSet -> a -> a @@ -136,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 @@ -160,5 +154,4 @@ let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase !result = foldNodesBwdOO (gen_killL platform) middle joined in mapSingleton (entryLabel eNode) result - diff --git a/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs --- a/GHC/Cmm/MachOp.hs +++ b/GHC/Cmm/MachOp.hs @@ -1,7 +1,5 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.Cmm.MachOp ( MachOp(..) , pprMachOp, isCommutableMachOp, isAssociativeMachOp @@ -24,6 +22,7 @@ , CallishMachOp(..), callishMachOpHints , pprCallishMachOp , machOpMemcpyishAlign + , callishMachOpArgTys -- Atomic read-modify-write , MemoryOrdering(..) @@ -39,7 +38,10 @@ import GHC.Platform import GHC.Cmm.Type import GHC.Utils.Outputable +import GHC.Utils.Misc (expectNonEmpty) +import Data.List.NonEmpty (NonEmpty (..)) + ----------------------------------------------------------------------------- -- MachOp ----------------------------------------------------------------------------- @@ -73,7 +75,7 @@ -- -- (1) has the benefit that its interpretation is completely independent of the -- architecture. So, the mid-term plan is to migrate to this --- interpretation/sematics. +-- interpretation/semantics. data MachOp -- Integer operations (insensitive to signed/unsigned) @@ -115,7 +117,7 @@ -- Floating-point fused multiply-add operations -- | Fused multiply-add, see 'FMASign'. - | MO_FMA FMASign Width + | MO_FMA FMASign Length Width -- Floating point comparison | MO_F_Eq Width @@ -125,6 +127,9 @@ | MO_F_Gt Width | MO_F_Lt Width + | MO_F_Min Width + | MO_F_Max Width + -- Bitwise operations. Not all of these may be supported -- at all sizes, and only integral Widths are valid. | MO_And Width @@ -139,8 +144,8 @@ -- Conversions. Some of these will be NOPs. -- Floating-point conversions use the signed variant. - | MO_SF_Conv Width Width -- Signed int -> Float - | MO_FS_Conv Width Width -- Float -> Signed int + | MO_SF_Round Width Width -- Signed int -> Float + | MO_FS_Truncate Width Width -- Float -> Signed int | MO_SS_Conv Width Width -- Signed int -> Signed int | MO_UU_Conv Width Width -- unsigned int -> unsigned int | MO_XX_Conv Width Width -- int -> int; puts no requirements on the @@ -151,29 +156,30 @@ -- MO_XX_Conv, e.g., -- MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x) -- is equivalent to just x. - | MO_FF_Conv Width Width -- Float -> Float + | MO_FF_Conv Width Width -- Float -> Float + | MO_WF_Bitcast Width -- Word32/Word64 -> Float/Double + | MO_FW_Bitcast Width -- Float/Double -> Word32/Word64 + -- Vector element insertion and extraction operations - | MO_V_Insert Length Width -- Insert scalar into vector - | MO_V_Extract Length Width -- Extract scalar from vector + | MO_V_Broadcast Length Width -- Broadcast a scalar into a vector + | MO_V_Insert Length Width -- Insert scalar into vector + | MO_V_Extract Length Width -- Extract scalar from vector -- Integer vector operations | MO_V_Add Length Width | MO_V_Sub Length Width | MO_V_Mul Length Width - - -- Signed vector multiply/divide - | MO_VS_Quot Length Width - | MO_VS_Rem Length Width | MO_VS_Neg Length Width - -- Unsigned vector multiply/divide - | MO_VU_Quot Length Width - | MO_VU_Rem Length Width + -- Vector shuffles + | MO_V_Shuffle Length Width [Int] + | MO_VF_Shuffle Length Width [Int] -- Floating point vector element insertion and extraction operations - | MO_VF_Insert Length Width -- Insert scalar into vector - | MO_VF_Extract Length Width -- Extract scalar from vector + | MO_VF_Broadcast Length Width -- Broadcast a scalar into a vector + | MO_VF_Insert Length Width -- Insert scalar into vector + | MO_VF_Extract Length Width -- Extract scalar from vector -- Floating point vector operations | MO_VF_Add Length Width @@ -182,6 +188,18 @@ | MO_VF_Mul Length Width | MO_VF_Quot Length Width + -- Min/max operations + | MO_VS_Min Length Width + | MO_VS_Max Length Width + | MO_VU_Min Length Width + | MO_VU_Max Length Width + | MO_VF_Min Length Width + | MO_VF_Max Length Width + + -- | An atomic read with no memory ordering. Address msut + -- be naturally aligned. + | MO_RelaxedRead Width + -- Alignment check (for -falignment-sanitisation) | MO_AlignmentCheck Int Width deriving (Eq, Show) @@ -308,6 +326,8 @@ MO_Xor _ -> True MO_F_Add _ -> True MO_F_Mul _ -> True + MO_F_Min {} -> True + MO_F_Max {} -> True _other -> False -- ---------------------------------------------------------------------------- @@ -402,16 +422,16 @@ maybeInvertComparison :: MachOp -> Maybe MachOp maybeInvertComparison op = case op of -- None of these Just cases include floating point - MO_Eq r -> Just (MO_Ne r) - MO_Ne r -> Just (MO_Eq r) - MO_U_Lt r -> Just (MO_U_Ge r) - MO_U_Gt r -> Just (MO_U_Le r) - MO_U_Le r -> Just (MO_U_Gt r) - MO_U_Ge r -> Just (MO_U_Lt r) - MO_S_Lt r -> Just (MO_S_Ge r) - MO_S_Gt r -> Just (MO_S_Le r) - MO_S_Le r -> Just (MO_S_Gt r) - MO_S_Ge r -> Just (MO_S_Lt r) + MO_Eq w -> Just (MO_Ne w) + MO_Ne w -> Just (MO_Eq w) + MO_U_Lt w -> Just (MO_U_Ge w) + MO_U_Gt w -> Just (MO_U_Le w) + MO_U_Le w -> Just (MO_U_Gt w) + MO_U_Ge w -> Just (MO_U_Lt w) + MO_S_Lt w -> Just (MO_S_Ge w) + MO_S_Gt w -> Just (MO_S_Le w) + MO_S_Le w -> Just (MO_S_Gt w) + MO_S_Ge w -> Just (MO_S_Lt w) _other -> Nothing -- ---------------------------------------------------------------------------- @@ -425,13 +445,13 @@ case mop of MO_Add {} -> ty1 -- Preserve GC-ptr-hood MO_Sub {} -> ty1 -- of first arg - MO_Mul r -> cmmBits r - MO_S_MulMayOflo r -> cmmBits r - MO_S_Quot r -> cmmBits r - MO_S_Rem r -> cmmBits r - MO_S_Neg r -> cmmBits r - MO_U_Quot r -> cmmBits r - MO_U_Rem r -> cmmBits r + MO_Mul w -> cmmBits w + MO_S_MulMayOflo w -> cmmBits w + MO_S_Quot w -> cmmBits w + MO_S_Rem w -> cmmBits w + MO_S_Neg w -> cmmBits w + MO_U_Quot w -> cmmBits w + MO_U_Rem w -> cmmBits w MO_Eq {} -> comparisonResultRep platform MO_Ne {} -> comparisonResultRep platform @@ -445,13 +465,15 @@ MO_U_Gt {} -> comparisonResultRep platform MO_U_Lt {} -> comparisonResultRep platform - MO_F_Add r -> cmmFloat r - MO_F_Sub r -> cmmFloat r - MO_F_Mul r -> cmmFloat r - MO_F_Quot r -> cmmFloat r - MO_F_Neg r -> cmmFloat r + MO_F_Add w -> cmmFloat w + MO_F_Sub w -> cmmFloat w + MO_F_Mul w -> cmmFloat w + MO_F_Quot w -> cmmFloat w + MO_F_Neg w -> cmmFloat w + MO_F_Min w -> cmmFloat w + MO_F_Max w -> cmmFloat w - MO_FMA _ r -> cmmFloat r + MO_FMA _ l w -> if l == 1 then cmmFloat w else cmmVec l (cmmFloat w) MO_F_Eq {} -> comparisonResultRep platform MO_F_Ne {} -> comparisonResultRep platform @@ -463,18 +485,21 @@ MO_And {} -> ty1 -- Used for pointer masking MO_Or {} -> ty1 MO_Xor {} -> ty1 - MO_Not r -> cmmBits r - MO_Shl r -> cmmBits r - MO_U_Shr r -> cmmBits r - MO_S_Shr r -> cmmBits r + MO_Not w -> cmmBits w + MO_Shl w -> cmmBits w + MO_U_Shr w -> cmmBits w + MO_S_Shr w -> cmmBits w MO_SS_Conv _ to -> cmmBits to MO_UU_Conv _ to -> cmmBits to MO_XX_Conv _ to -> cmmBits to - MO_FS_Conv _ to -> cmmBits to - MO_SF_Conv _ to -> cmmFloat to + MO_FS_Truncate _ to -> cmmBits to + MO_SF_Round _ to -> cmmFloat to MO_FF_Conv _ to -> cmmFloat to + MO_WF_Bitcast w -> cmmFloat w + MO_FW_Bitcast w -> cmmBits w + MO_V_Broadcast l w -> cmmVec l (cmmBits w) MO_V_Insert l w -> cmmVec l (cmmBits w) MO_V_Extract _ w -> cmmBits w @@ -482,13 +507,17 @@ MO_V_Sub l w -> cmmVec l (cmmBits w) MO_V_Mul l w -> cmmVec l (cmmBits w) - MO_VS_Quot l w -> cmmVec l (cmmBits w) - MO_VS_Rem l w -> cmmVec l (cmmBits w) MO_VS_Neg l w -> cmmVec l (cmmBits w) + MO_VS_Min l w -> cmmVec l (cmmBits w) + MO_VS_Max l w -> cmmVec l (cmmBits w) - MO_VU_Quot l w -> cmmVec l (cmmBits w) - MO_VU_Rem l w -> cmmVec l (cmmBits w) + MO_VU_Min l w -> cmmVec l (cmmBits w) + MO_VU_Max l w -> cmmVec l (cmmBits w) + MO_V_Shuffle l w _ -> cmmVec l (cmmBits w) + MO_VF_Shuffle l w _ -> cmmVec l (cmmFloat w) + + MO_VF_Broadcast l w -> cmmVec l (cmmFloat w) MO_VF_Insert l w -> cmmVec l (cmmFloat w) MO_VF_Extract _ w -> cmmFloat w @@ -497,10 +526,13 @@ MO_VF_Mul l w -> cmmVec l (cmmFloat w) MO_VF_Quot l w -> cmmVec l (cmmFloat w) MO_VF_Neg l w -> cmmVec l (cmmFloat w) + MO_VF_Min l w -> cmmVec l (cmmFloat w) + MO_VF_Max l w -> cmmVec l (cmmFloat w) + MO_RelaxedRead w -> cmmBits w MO_AlignmentCheck _ _ -> ty1 where - (ty1:_) = tys + ty1:|_ = expectNonEmpty tys comparisonResultRep :: Platform -> CmmType comparisonResultRep = bWord -- is it? @@ -517,82 +549,97 @@ machOpArgReps :: Platform -> MachOp -> [Width] machOpArgReps platform op = case op of - MO_Add r -> [r,r] - MO_Sub r -> [r,r] - MO_Eq r -> [r,r] - MO_Ne r -> [r,r] - MO_Mul r -> [r,r] - MO_S_MulMayOflo r -> [r,r] - MO_S_Quot r -> [r,r] - MO_S_Rem r -> [r,r] - MO_S_Neg r -> [r] - MO_U_Quot r -> [r,r] - MO_U_Rem r -> [r,r] + MO_Add w -> [w,w] + MO_Sub w -> [w,w] + MO_Eq w -> [w,w] + MO_Ne w -> [w,w] + MO_Mul w -> [w,w] + MO_S_MulMayOflo w -> [w,w] + MO_S_Quot w -> [w,w] + MO_S_Rem w -> [w,w] + MO_S_Neg w -> [w] + MO_U_Quot w -> [w,w] + MO_U_Rem w -> [w,w] - MO_S_Ge r -> [r,r] - MO_S_Le r -> [r,r] - MO_S_Gt r -> [r,r] - MO_S_Lt r -> [r,r] + MO_S_Ge w -> [w,w] + MO_S_Le w -> [w,w] + MO_S_Gt w -> [w,w] + MO_S_Lt w -> [w,w] - MO_U_Ge r -> [r,r] - MO_U_Le r -> [r,r] - MO_U_Gt r -> [r,r] - MO_U_Lt r -> [r,r] + MO_U_Ge w -> [w,w] + MO_U_Le w -> [w,w] + MO_U_Gt w -> [w,w] + MO_U_Lt w -> [w,w] - MO_F_Add r -> [r,r] - MO_F_Sub r -> [r,r] - MO_F_Mul r -> [r,r] - MO_F_Quot r -> [r,r] - MO_F_Neg r -> [r] + MO_F_Add w -> [w,w] + MO_F_Sub w -> [w,w] + MO_F_Mul w -> [w,w] + MO_F_Quot w -> [w,w] + MO_F_Neg w -> [w] + MO_F_Min w -> [w,w] + MO_F_Max w -> [w,w] - MO_FMA _ r -> [r,r,r] + MO_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w] - MO_F_Eq r -> [r,r] - MO_F_Ne r -> [r,r] - MO_F_Ge r -> [r,r] - MO_F_Le r -> [r,r] - MO_F_Gt r -> [r,r] - MO_F_Lt r -> [r,r] + MO_F_Eq w -> [w,w] + MO_F_Ne w -> [w,w] + MO_F_Ge w -> [w,w] + MO_F_Le w -> [w,w] + MO_F_Gt w -> [w,w] + MO_F_Lt w -> [w,w] - MO_And r -> [r,r] - MO_Or r -> [r,r] - MO_Xor r -> [r,r] - MO_Not r -> [r] - MO_Shl r -> [r, wordWidth platform] - MO_U_Shr r -> [r, wordWidth platform] - MO_S_Shr r -> [r, wordWidth platform] + MO_And w -> [w,w] + MO_Or w -> [w,w] + MO_Xor w -> [w,w] + MO_Not w -> [w] + MO_Shl w -> [w, wordWidth platform] + MO_U_Shr w -> [w, wordWidth platform] + MO_S_Shr w -> [w, wordWidth platform] - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_XX_Conv from _ -> [from] - MO_SF_Conv from _ -> [from] - MO_FS_Conv from _ -> [from] - MO_FF_Conv from _ -> [from] + MO_SS_Conv from _ -> [from] + MO_UU_Conv from _ -> [from] + MO_XX_Conv from _ -> [from] + MO_SF_Round from _ -> [from] + MO_FS_Truncate from _ -> [from] + MO_FF_Conv from _ -> [from] + MO_WF_Bitcast w -> [w] + MO_FW_Bitcast w -> [w] - MO_V_Insert l r -> [typeWidth (vec l (cmmBits r)),r, W32] - MO_V_Extract l r -> [typeWidth (vec l (cmmBits r)), W32] - MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,W32] - MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),W32] + MO_V_Shuffle l w _ -> [vecwidth l w, vecwidth l w] + MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w] + + MO_V_Broadcast _ w -> [w] + MO_V_Insert l w -> [vecwidth l w, w, W32] + MO_V_Extract l w -> [vecwidth l w, W32] + MO_VF_Broadcast _ w -> [w] + MO_VF_Insert l w -> [vecwidth l w, w, W32] + MO_VF_Extract l w -> [vecwidth l w, W32] -- SIMD vector indices are always 32 bit - MO_V_Add _ r -> [r,r] - MO_V_Sub _ r -> [r,r] - MO_V_Mul _ r -> [r,r] + MO_V_Add l w -> [vecwidth l w, vecwidth l w] + MO_V_Sub l w -> [vecwidth l w, vecwidth l w] + MO_V_Mul l w -> [vecwidth l w, vecwidth l w] - MO_VS_Quot _ r -> [r,r] - MO_VS_Rem _ r -> [r,r] - MO_VS_Neg _ r -> [r] + MO_VS_Neg l w -> [vecwidth l w] + MO_VS_Min l w -> [vecwidth l w, vecwidth l w] + MO_VS_Max l w -> [vecwidth l w, vecwidth l w] - MO_VU_Quot _ r -> [r,r] - MO_VU_Rem _ r -> [r,r] + MO_VU_Min l w -> [vecwidth l w, vecwidth l w] + MO_VU_Max l w -> [vecwidth l w, vecwidth l w] - MO_VF_Add _ r -> [r,r] - MO_VF_Sub _ r -> [r,r] - MO_VF_Mul _ r -> [r,r] - MO_VF_Quot _ r -> [r,r] - MO_VF_Neg _ r -> [r] + -- NOTE: The below is owing to the fact that floats use the SSE registers + MO_VF_Add l w -> [vecwidth l w, vecwidth l w] + MO_VF_Sub l w -> [vecwidth l w, vecwidth l w] + MO_VF_Mul l w -> [vecwidth l w, vecwidth l w] + MO_VF_Quot l w -> [vecwidth l w, vecwidth l w] + MO_VF_Neg l w -> [vecwidth l w] + MO_VF_Min l w -> [vecwidth l w, vecwidth l w] + MO_VF_Max l w -> [vecwidth l w, vecwidth l w] - MO_AlignmentCheck _ r -> [r] + MO_RelaxedRead _ -> [wordWidth platform] + MO_AlignmentCheck _ w -> [w] + where + vecwidth l w = widthFromBytes (l * widthInBytes w) ----------------------------------------------------------------------------- -- CallishMachOp @@ -690,8 +737,20 @@ | MO_SubIntC Width | MO_U_Mul2 Width - | MO_ReadBarrier - | MO_WriteBarrier + -- Signed vector divide + | MO_VS_Quot Length Width + | MO_VS_Rem Length Width + + -- Unsigned vector divide + | MO_VU_Quot Length Width + | MO_VU_Rem Length Width + + -- Int64X2/Word64X2 min/max + | MO_I64X2_Min + | MO_I64X2_Max + | MO_W64X2_Min + | MO_W64X2_Max + | MO_Touch -- Keep variables live (when using interior pointers) -- Prefetch @@ -721,6 +780,10 @@ | MO_BSwap Width | MO_BRev Width + | MO_AcquireFence + | MO_ReleaseFence + | MO_SeqCstFence + -- | Atomic read-modify-write. Arguments are @[dest, n]@. | MO_AtomicRMW Width AtomicMachOp -- | Atomic read. Arguments are @[addr]@. @@ -782,3 +845,144 @@ MO_Memmove align -> Just align MO_Memcmp align -> Just align _ -> Nothing + +-- | Like 'machOpArgReps', but for 'CallishMachOp'. +-- +-- Used only in Cmm lint. +callishMachOpArgTys :: Platform -> CallishMachOp -> [CmmType] +callishMachOpArgTys platform = \case + MO_F64_Pwr -> [f64, f64] + MO_F64_Sin -> [f64] + MO_F64_Cos -> [f64] + MO_F64_Tan -> [f64] + MO_F64_Sinh -> [f64] + MO_F64_Cosh -> [f64] + MO_F64_Tanh -> [f64] + MO_F64_Asin -> [f64] + MO_F64_Acos -> [f64] + MO_F64_Atan -> [f64] + MO_F64_Asinh -> [f64] + MO_F64_Acosh -> [f64] + MO_F64_Atanh -> [f64] + MO_F64_Log -> [f64] + MO_F64_Log1P -> [f64] + MO_F64_Exp -> [f64] + MO_F64_ExpM1 -> [f64] + MO_F64_Fabs -> [f64] + MO_F64_Sqrt -> [f64] + MO_F32_Pwr -> [f32, f32] + MO_F32_Sin -> [f32] + MO_F32_Cos -> [f32] + MO_F32_Tan -> [f32] + MO_F32_Sinh -> [f32] + MO_F32_Cosh -> [f32] + MO_F32_Tanh -> [f32] + MO_F32_Asin -> [f32] + MO_F32_Acos -> [f32] + MO_F32_Atan -> [f32] + MO_F32_Asinh -> [f32] + MO_F32_Acosh -> [f32] + MO_F32_Atanh -> [f32] + MO_F32_Log -> [f32] + MO_F32_Log1P -> [f32] + MO_F32_Exp -> [f32] + MO_F32_ExpM1 -> [f32] + MO_F32_Fabs -> [f32] + MO_F32_Sqrt -> [f32] + MO_I64_ToI -> [b64] + MO_I64_FromI -> [bWord platform] + MO_W64_ToW -> [b64] + MO_W64_FromW -> [bWord platform] + MO_x64_Neg -> [b64] + MO_x64_Add -> [b64] + MO_x64_Sub -> [b64] + MO_x64_Mul -> [b64] + MO_I64_Quot -> [b64,b64] + MO_I64_Rem -> [b64,b64] + MO_W64_Quot -> [b64,b64] + MO_W64_Rem -> [b64,b64] + MO_x64_And -> [b64,b64] + MO_x64_Or -> [b64,b64] + MO_x64_Xor -> [b64,b64] + MO_x64_Not -> [b64] + MO_x64_Shl -> [b64,b64] + MO_I64_Shr -> [b64,b64] + MO_W64_Shr -> [b64,b64] + MO_x64_Eq -> [b64,b64] + MO_x64_Ne -> [b64,b64] + MO_I64_Ge -> [b64,b64] + MO_I64_Gt -> [b64,b64] + MO_I64_Le -> [b64,b64] + MO_I64_Lt -> [b64,b64] + MO_W64_Ge -> [b64,b64] + MO_W64_Gt -> [b64,b64] + MO_W64_Le -> [b64,b64] + MO_W64_Lt -> [b64,b64] + MO_UF_Conv _w -> [bWord platform] -- Word to Float/Double + MO_S_Mul2 w -> [cmmBits w, cmmBits w] + MO_S_QuotRem w -> [cmmBits w, cmmBits w] + MO_U_QuotRem w -> [cmmBits w, cmmBits w] + MO_U_QuotRem2 w -> [cmmBits w, cmmBits w] + MO_Add2 w -> [cmmBits w, cmmBits w] + MO_AddWordC w -> [cmmBits w, cmmBits w] + MO_SubWordC w -> [cmmBits w, cmmBits w] + MO_AddIntC w -> [cmmBits w, cmmBits w] + MO_SubIntC w -> [cmmBits w, cmmBits w] + MO_U_Mul2 w -> [cmmBits w, cmmBits w] + MO_VS_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_VS_Rem l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_VU_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_VU_Rem l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)] + MO_I64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_I64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_W64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_W64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)] + MO_Touch -> [gcWord platform] + MO_Prefetch_Data _n -> [addr] + MO_Memcpy _align -> [addr, addr, bWord platform] + MO_Memset _align -> + [ addr + , bWord platform -- byte to set: supplied as an int, converted to a byte + , bWord platform] + MO_Memmove _align -> [addr, addr, bWord platform] + MO_Memcmp _align -> [addr, addr, bWord platform] + MO_PopCnt w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_Pdep w -> + case w of + W64 -> [cmmBits W64, cmmBits W64] + _ -> [bWord platform, bWord platform] + MO_Pext w -> + case w of + W64 -> [cmmBits W64, cmmBits W64] + _ -> [bWord platform, bWord platform] + MO_Clz w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_Ctz w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_BSwap w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_BRev w -> + case w of + W64 -> [cmmBits W64] + _ -> [bWord platform] + MO_AcquireFence -> [] + MO_ReleaseFence -> [] + MO_SeqCstFence -> [] + MO_AtomicRMW w _op -> [addr, cmmBits w] + MO_AtomicRead _w _mem_ordering -> [addr] + MO_AtomicWrite w _mem_ordering -> [addr, cmmBits w] + MO_Cmpxchg w -> [addr, cmmBits w, cmmBits w] + MO_Xchg w -> [addr, cmmBits w] + MO_SuspendThread -> [] + MO_ResumeThread -> [] + where + addr = bWord platform diff --git a/GHC/Cmm/Node.hs b/GHC/Cmm/Node.hs --- a/GHC/Cmm/Node.hs +++ b/GHC/Cmm/Node.hs @@ -1,11 +1,5 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} @@ -41,7 +35,6 @@ import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import Data.Foldable (toList) import Data.Functor.Classes (liftCompare) @@ -125,7 +118,7 @@ -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or -- (CmmStackSlot (Young b) _). - cml_args_regs :: [GlobalReg], + cml_args_regs :: [GlobalRegUse], -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed -- to the call. This is essential information for the -- native code generator's register allocator; without @@ -509,7 +502,7 @@ = pdoc platform (mkForeignLabel (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction) + ForeignLabelInThisPackage IsFunction) instance Outputable Convention where ppr = pprConvention @@ -551,7 +544,7 @@ => (b -> LocalReg -> b) -> b -> a -> b fold f z n = foldRegsUsed platform f z n -instance UserOfRegs GlobalReg (CmmNode e x) where +instance UserOfRegs GlobalRegUse (CmmNode e x) where {-# INLINEABLE foldRegsUsed #-} foldRegsUsed platform f !z n = case n of CmmAssign _ expr -> fold f z expr @@ -562,8 +555,8 @@ CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args _ -> z - where fold :: forall a b. UserOfRegs GlobalReg a - => (b -> GlobalReg -> b) -> b -> a -> b + where fold :: forall a b. UserOfRegs GlobalRegUse a + => (b -> GlobalRegUse -> b) -> b -> a -> b fold f z n = foldRegsUsed platform f z n instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where -- The (Ord r) in the context is necessary here @@ -583,7 +576,7 @@ => (b -> LocalReg -> b) -> b -> a -> b fold f z n = foldRegsDefd platform f z n -instance DefinerOfRegs GlobalReg (CmmNode e x) where +instance DefinerOfRegs GlobalRegUse (CmmNode e x) where {-# INLINEABLE foldRegsDefd #-} foldRegsDefd platform f !z n = case n of CmmAssign lhs _ -> fold f z lhs @@ -592,12 +585,13 @@ CmmForeignCall {} -> fold f z activeRegs -- See Note [Safe foreign calls clobber STG registers] _ -> z - where fold :: forall a b. DefinerOfRegs GlobalReg a - => (b -> GlobalReg -> b) -> b -> a -> b + where fold :: forall a b. DefinerOfRegs GlobalRegUse a + => (b -> GlobalRegUse -> b) -> b -> a -> b fold f z n = foldRegsDefd platform f z n - activeRegs = activeStgRegs platform - activeCallerSavesRegs = filter (callerSaves platform) activeRegs + activeRegs :: [GlobalRegUse] + activeRegs = map (\ r -> GlobalRegUse r (globalRegSpillType platform r)) $ activeStgRegs platform + activeCallerSavesRegs = filter (callerSaves platform . globalRegUse_reg) activeRegs foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = [] foreignTargetRegs _ = activeCallerSavesRegs diff --git a/GHC/Cmm/Opt.hs b/GHC/Cmm/Opt.hs --- a/GHC/Cmm/Opt.hs +++ b/GHC/Cmm/Opt.hs @@ -5,7 +5,6 @@ -- (c) The University of Glasgow 2006 -- ----------------------------------------------------------------------------- - module GHC.Cmm.Opt ( constantFoldNode, constantFoldExpr, @@ -20,9 +19,11 @@ import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Outputable import GHC.Platform import Data.Maybe +import GHC.Float constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x @@ -55,22 +56,60 @@ -> 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)] + | MO_WF_Bitcast width <- op = case width of + W32 | res <- castWord32ToFloat (fromInteger x) + -- Since we store float literals as Rationals + -- we must check for the usual tricky cases first + , not (isNegativeZero res || isNaN res || isInfinite res) + -- (round-tripping subnormals is not a problem) + , !res_rat <- toRational res + -> Just (CmmLit (CmmFloat res_rat W32)) + + W64 | res <- castWord64ToDouble (fromInteger x) + -- Since we store float literals as Rationals + -- we must check for the usual tricky cases first + , not (isNegativeZero res || isNaN res || isInfinite res) + -- (round-tripping subnormals is not a problem) + , !res_rat <- toRational res + -> Just (CmmLit (CmmFloat res_rat W64)) + + _ -> Nothing + | otherwise = Just $! case op of - MO_S_Neg _ -> CmmLit (CmmInt (-x) rep) + MO_S_Neg _ -> CmmLit (CmmInt (narrowS rep (-x)) rep) MO_Not _ -> CmmLit (CmmInt (complement x) rep) -- these are interesting: we must first narrow to the -- "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) + MO_F_Neg{} -> invalidArgPanic + MO_FS_Truncate{} -> invalidArgPanic + MO_FF_Conv{} -> invalidArgPanic + MO_FW_Bitcast{} -> invalidArgPanic + MO_VS_Neg{} -> invalidArgPanic + MO_VF_Neg{} -> invalidArgPanic + MO_RelaxedRead{} -> invalidArgPanic + MO_AlignmentCheck{} -> invalidArgPanic + _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op + where invalidArgPanic = pprPanic "cmmMachOpFoldM" $ + text "Found" <+> pprMachOp op + <+> text "illegally applied to an int literal" -- Eliminate shifts that are wider than the shiftee cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)] @@ -135,9 +174,9 @@ MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform)) MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform)) - MO_Add r -> Just $! CmmLit (CmmInt (x + y) r) - MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r) - MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r) + MO_Add r -> Just $! CmmLit (CmmInt (narrowU r $ x + y) r) + MO_Sub r -> Just $! CmmLit (CmmInt (narrowS r $ x - y) r) + MO_Mul r -> Just $! CmmLit (CmmInt (narrowU r $ x * y) r) MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r) MO_U_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem` y_u) r) MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r) @@ -147,7 +186,7 @@ MO_Or r -> Just $! CmmLit (CmmInt (x .|. y) r) MO_Xor r -> Just $! CmmLit (CmmInt (x `xor` y) r) - MO_Shl r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r) + MO_Shl r -> Just $! CmmLit (CmmInt (narrowU r $ x `shiftL` fromIntegral y) r) MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r) @@ -436,7 +475,6 @@ That's what the constant-folding operations on comparison operators do above. -} - -- ----------------------------------------------------------------------------- -- Utils diff --git a/GHC/Cmm/Parser.hs b/GHC/Cmm/Parser.hs --- a/GHC/Cmm/Parser.hs +++ b/GHC/Cmm/Parser.hs @@ -34,3456 +34,3531 @@ import GHC.Cmm.Opt import GHC.Cmm.Graph import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch ( mkSwitchTargets ) -import GHC.Cmm.Info -import GHC.Cmm.BlockId -import GHC.Cmm.Lexer -import GHC.Cmm.CLabel -import GHC.Cmm.Parser.Config -import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) -import qualified GHC.Cmm.Parser.Monad as PD -import GHC.Cmm.CallConv -import GHC.Runtime.Heap.Layout -import GHC.Parser.Lexer -import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr - -import GHC.Types.CostCentre -import GHC.Types.ForeignCall -import GHC.Unit.Module -import GHC.Unit.Home -import GHC.Types.Literal -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.SrcLoc -import GHC.Types.Tickish ( GenTickish(SourceNote) ) -import GHC.Utils.Error -import GHC.Data.StringBuffer -import GHC.Data.FastString -import GHC.Utils.Panic -import GHC.Settings.Constants -import GHC.Utils.Outputable -import GHC.Types.Basic -import GHC.Data.Bag ( Bag, emptyBag, unitBag, isEmptyBag ) -import GHC.Types.Var - -import Control.Monad -import Data.Array -import Data.Char ( ord ) -import System.Exit -import Data.Maybe -import qualified Data.Map as M -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Array as Happy_Data_Array -import qualified Data.Bits as Bits -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.20.1.1 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -newtype HappyWrap4 = HappyWrap4 (CmmParse ()) -happyIn4 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn4 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap4 x) -{-# INLINE happyIn4 #-} -happyOut4 :: (HappyAbsSyn ) -> HappyWrap4 -happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut4 #-} -newtype HappyWrap5 = HappyWrap5 (CmmParse ()) -happyIn5 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn5 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap5 x) -{-# INLINE happyIn5 #-} -happyOut5 :: (HappyAbsSyn ) -> HappyWrap5 -happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut5 #-} -newtype HappyWrap6 = HappyWrap6 (CmmParse ()) -happyIn6 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap6 x) -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn ) -> HappyWrap6 -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -newtype HappyWrap7 = HappyWrap7 (CmmParse CLabel) -happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn ) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap7 x) -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> HappyWrap7 -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -newtype HappyWrap8 = HappyWrap8 ([CmmParse [CmmStatic]]) -happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn ) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap8 x) -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> HappyWrap8 -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -newtype HappyWrap9 = HappyWrap9 (CmmParse [CmmStatic]) -happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn ) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap9 x) -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> HappyWrap9 -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -newtype HappyWrap10 = HappyWrap10 ([CmmParse CmmExpr]) -happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap10 x) -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> HappyWrap10 -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -newtype HappyWrap11 = HappyWrap11 (CmmParse ()) -happyIn11 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap11 x) -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> HappyWrap11 -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -newtype HappyWrap12 = HappyWrap12 (Convention) -happyIn12 :: (Convention) -> (HappyAbsSyn ) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap12 x) -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> HappyWrap12 -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -newtype HappyWrap13 = HappyWrap13 (CmmParse ()) -happyIn13 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap13 x) -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn ) -> HappyWrap13 -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -newtype HappyWrap14 = HappyWrap14 (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn ) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap14 x) -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> HappyWrap14 -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -newtype HappyWrap15 = HappyWrap15 (CmmParse ()) -happyIn15 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap15 x) -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> HappyWrap15 -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -newtype HappyWrap16 = HappyWrap16 (CmmParse ()) -happyIn16 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -newtype HappyWrap17 = HappyWrap17 ([(FastString, CLabel)]) -happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -newtype HappyWrap18 = HappyWrap18 ((FastString, CLabel)) -happyIn18 :: ((FastString, CLabel)) -> (HappyAbsSyn ) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -newtype HappyWrap19 = HappyWrap19 ([FastString]) -happyIn19 :: ([FastString]) -> (HappyAbsSyn ) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -newtype HappyWrap20 = HappyWrap20 (CmmParse ()) -happyIn20 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -newtype HappyWrap21 = HappyWrap21 (CmmParse [(GlobalReg, Maybe CmmExpr)]) -happyIn21 :: (CmmParse [(GlobalReg, Maybe CmmExpr)]) -> (HappyAbsSyn ) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -newtype HappyWrap22 = HappyWrap22 (CmmParse MemoryOrdering) -happyIn22 :: (CmmParse MemoryOrdering) -> (HappyAbsSyn ) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -newtype HappyWrap23 = HappyWrap23 (CmmParse (Maybe CmmExpr)) -happyIn23 :: (CmmParse (Maybe CmmExpr)) -> (HappyAbsSyn ) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -newtype HappyWrap24 = HappyWrap24 (CmmParse CmmExpr) -happyIn24 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -newtype HappyWrap25 = HappyWrap25 (CmmReturnInfo) -happyIn25 :: (CmmReturnInfo) -> (HappyAbsSyn ) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -newtype HappyWrap26 = HappyWrap26 (CmmParse BoolExpr) -happyIn26 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -newtype HappyWrap27 = HappyWrap27 (CmmParse BoolExpr) -happyIn27 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -newtype HappyWrap28 = HappyWrap28 (Safety) -happyIn28 :: (Safety) -> (HappyAbsSyn ) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -newtype HappyWrap29 = HappyWrap29 ([GlobalReg]) -happyIn29 :: ([GlobalReg]) -> (HappyAbsSyn ) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -newtype HappyWrap30 = HappyWrap30 ([GlobalRegUse]) -happyIn30 :: ([GlobalRegUse]) -> (HappyAbsSyn ) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -newtype HappyWrap31 = HappyWrap31 (Maybe (Integer,Integer)) -happyIn31 :: (Maybe (Integer,Integer)) -> (HappyAbsSyn ) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -newtype HappyWrap32 = HappyWrap32 ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -happyIn32 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn ) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -newtype HappyWrap33 = HappyWrap33 (CmmParse ([Integer],Either BlockId (CmmParse ()))) -happyIn33 :: (CmmParse ([Integer],Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -newtype HappyWrap34 = HappyWrap34 (CmmParse (Either BlockId (CmmParse ()))) -happyIn34 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -newtype HappyWrap35 = HappyWrap35 ([Integer]) -happyIn35 :: ([Integer]) -> (HappyAbsSyn ) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -newtype HappyWrap36 = HappyWrap36 (Maybe (CmmParse ())) -happyIn36 :: (Maybe (CmmParse ())) -> (HappyAbsSyn ) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -newtype HappyWrap37 = HappyWrap37 (CmmParse ()) -happyIn37 :: (CmmParse ()) -> (HappyAbsSyn ) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -newtype HappyWrap38 = HappyWrap38 (Maybe Bool) -happyIn38 :: (Maybe Bool) -> (HappyAbsSyn ) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -newtype HappyWrap39 = HappyWrap39 (CmmParse CmmExpr) -happyIn39 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -newtype HappyWrap40 = HappyWrap40 (CmmParse CmmExpr) -happyIn40 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -newtype HappyWrap41 = HappyWrap41 (CmmParse (AlignmentSpec, CmmExpr)) -happyIn41 :: (CmmParse (AlignmentSpec, CmmExpr)) -> (HappyAbsSyn ) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -newtype HappyWrap42 = HappyWrap42 (CmmType) -happyIn42 :: (CmmType) -> (HappyAbsSyn ) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -newtype HappyWrap43 = HappyWrap43 ([CmmParse (CmmExpr, ForeignHint)]) -happyIn43 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -newtype HappyWrap44 = HappyWrap44 ([CmmParse (CmmExpr, ForeignHint)]) -happyIn44 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -newtype HappyWrap45 = HappyWrap45 (CmmParse (CmmExpr, ForeignHint)) -happyIn45 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn ) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -newtype HappyWrap46 = HappyWrap46 ([CmmParse CmmExpr]) -happyIn46 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -newtype HappyWrap47 = HappyWrap47 ([CmmParse CmmExpr]) -happyIn47 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -newtype HappyWrap48 = HappyWrap48 (CmmParse CmmExpr) -happyIn48 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -newtype HappyWrap49 = HappyWrap49 ([CmmParse (LocalReg, ForeignHint)]) -happyIn49 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -newtype HappyWrap50 = HappyWrap50 ([CmmParse (LocalReg, ForeignHint)]) -happyIn50 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -newtype HappyWrap51 = HappyWrap51 (CmmParse (LocalReg, ForeignHint)) -happyIn51 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn ) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -newtype HappyWrap52 = HappyWrap52 (CmmParse LocalReg) -happyIn52 :: (CmmParse LocalReg) -> (HappyAbsSyn ) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -newtype HappyWrap53 = HappyWrap53 (CmmParse CmmReg) -happyIn53 :: (CmmParse CmmReg) -> (HappyAbsSyn ) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -newtype HappyWrap54 = HappyWrap54 (Maybe [CmmParse LocalReg]) -happyIn54 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn ) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -newtype HappyWrap55 = HappyWrap55 ([CmmParse LocalReg]) -happyIn55 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -newtype HappyWrap56 = HappyWrap56 ([CmmParse LocalReg]) -happyIn56 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -newtype HappyWrap57 = HappyWrap57 (CmmParse LocalReg) -happyIn57 :: (CmmParse LocalReg) -> (HappyAbsSyn ) -happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 -happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut57 #-} -newtype HappyWrap58 = HappyWrap58 (CmmType) -happyIn58 :: (CmmType) -> (HappyAbsSyn ) -happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 -happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut58 #-} -newtype HappyWrap59 = HappyWrap59 (CmmType) -happyIn59 :: (CmmType) -> (HappyAbsSyn ) -happyIn59 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap59 x) -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> HappyWrap59 -happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyExpList :: HappyAddr -happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x0d\x40\xf0\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xdf\x00\x04\xff\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x02\x00\x00\x80\x07\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x02\x00\x00\x80\x07\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x78\x40\x8f\xcd\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x20\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x21\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x10\xc0\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x80\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xc2\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x20\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x02\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x78\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x10\xc0\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x20\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x02\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xf1\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\xc0\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x10\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x1f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x02\x00\x00\x80\x07\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x3f\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x3f\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x3f\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x1f\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x07\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x0f\x3f\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x01\xfc\x0f\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x78\x40\x8f\xcd\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x02\x00\x00\x80\x07\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x02\x00\x00\x80\x07\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -{-# NOINLINE happyExpListPerState #-} -happyExpListPerState st = - token_strs_expected - where token_strs = ["error","%dummy","%start_cmmParse","cmm","cmmtop","cmmdata","data_label","statics","static","lits","cmmproc","maybe_conv","maybe_body","info","body","decl","importNames","importName","names","stmt","unwind_regs","mem_ordering","expr_or_unknown","foreignLabel","opt_never_returns","bool_expr","bool_op","safety","vols","globals","maybe_range","arms","arm","arm_body","ints","default","else","cond_likely","expr","expr0","dereference","maybe_ty","cmm_hint_exprs0","cmm_hint_exprs","cmm_hint_expr","exprs0","exprs","reg","foreign_results","foreign_formals","foreign_formal","local_lreg","lreg","maybe_formals","formals0","formals","formal","type","typenot8","':'","';'","'{'","'}'","'['","']'","'('","')'","'='","'`'","'~'","'/'","'*'","'%'","'-'","'+'","'&'","'^'","'|'","'>'","'<'","','","'!'","'..'","'::'","'>>'","'<<'","'>='","'<='","'=='","'!='","'&&'","'||'","'True'","'False'","'likely'","'relaxed'","'acquire'","'release'","'seq_cst'","'CLOSURE'","'INFO_TABLE'","'INFO_TABLE_RET'","'INFO_TABLE_FUN'","'INFO_TABLE_CONSTR'","'INFO_TABLE_SELECTOR'","'else'","'export'","'section'","'goto'","'if'","'call'","'jump'","'foreign'","'never'","'prim'","'reserve'","'return'","'returns'","'import'","'switch'","'case'","'default'","'push'","'unwind'","'bits8'","'bits16'","'bits32'","'bits64'","'bits128'","'bits256'","'bits512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","%eof"] - bit_start = st Prelude.* 140 - bit_end = (st Prelude.+ 1) Prelude.* 140 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..139] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x62\x01\x00\x00\xd7\xff\x62\x01\x00\x00\x00\x00\xf0\xff\x00\x00\xdf\xff\x00\x00\x55\x00\x75\x00\x78\x00\x80\x00\x8b\x00\xa8\x00\xf3\xff\x90\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x01\xfa\x00\xc5\x00\x00\x00\xdc\x00\x14\x01\x3a\x01\x17\x01\xe8\x00\xf5\x00\xf7\x00\xfb\x00\x01\x01\x07\x01\x55\x01\x52\x01\x00\x00\x00\x00\x34\x00\xcb\x04\x00\x00\x44\x01\x45\x01\x57\x01\x5b\x01\x5c\x01\x63\x01\x1b\x01\x00\x00\x1e\x01\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x73\x00\x77\x01\x00\x00\x2c\x01\x2e\x01\x2f\x01\x30\x01\x34\x01\x2d\x01\x7d\x01\x00\x00\x72\x01\x4e\x01\x00\x00\x00\x00\x2b\x00\x98\x01\x2b\x00\x2b\x00\xcb\x04\xef\xff\x94\x01\x0a\x00\x00\x00\xbe\x04\x00\x00\x00\x00\x00\x00\x00\x00\x54\x01\x7d\x00\x8c\x00\x8c\x00\x8c\x00\x8a\x01\x9a\x01\xa7\x01\x6a\x01\x00\x00\x13\x00\x00\x00\xcb\x04\x00\x00\xa1\x01\xa2\x01\xfd\xff\xa4\x01\xa5\x01\xa8\x01\x00\x00\xc2\x01\x73\x00\xff\xff\xc4\x01\xc0\x01\xcc\x01\x05\x00\x8f\x01\x91\x01\xe3\x01\xd8\x01\x00\x00\x12\x00\x00\x00\x8c\x00\x8c\x00\x97\x01\x8c\x00\x00\x00\x00\x00\x00\x00\xcd\x01\xcd\x01\x00\x00\x00\x00\xab\x01\xac\x01\xad\x01\x00\x00\xcb\x04\xbf\x01\xdf\x01\x8c\x00\x00\x00\x00\x00\x8c\x00\xe6\x01\x06\x02\x8c\x00\x8c\x00\xc1\x01\x8c\x00\x31\x03\x4e\x02\xe9\x02\x0e\x00\x00\x00\xb6\x04\x7d\x00\x7d\x00\x20\x02\x1b\x02\x0e\x02\x00\x00\x2d\x02\x00\x00\xea\x01\x8c\x00\x5b\x00\xfb\x01\x2a\x02\x45\x02\x00\x00\x00\x00\x00\x00\x8c\x00\xfe\x01\xff\x01\xcb\x04\xf7\x01\x68\x02\x00\x00\x4b\x02\x3c\x00\x4d\x02\x00\x00\x00\x00\x39\x00\x4f\x02\x1a\x03\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x01\x00\x34\x02\x7d\x00\x7d\x00\x8c\x00\x57\x02\x0c\x00\x8c\x00\x49\x00\x8e\x04\x5c\x02\x00\x00\x66\x02\x33\x02\x5d\x02\xa5\x00\x00\x00\x5e\x02\xa2\x04\x65\x02\x69\x02\x78\x02\x6b\x02\x83\x02\x84\x02\x00\x00\xcb\x04\x00\x00\x6d\x00\x91\x02\x00\x00\x1a\x03\x00\x00\x8c\x00\x96\x02\x58\x02\x00\x00\x9d\x02\x8e\x02\x59\x02\xa0\x02\xb0\x02\xb1\x02\xac\x02\xb3\x02\xb4\x02\x8c\x00\x82\x02\x00\x00\x8c\x00\x00\x00\x6f\x02\x70\x02\x71\x02\x00\x00\x72\x02\x00\x00\x00\x00\xca\x02\xb7\x02\xb6\x04\x00\x00\x96\x00\x90\x02\x80\x02\xd5\x02\x8c\x00\x96\x00\x00\x00\xd1\x02\xd2\x02\x00\x00\xd4\x02\xc5\x02\x00\x00\xde\x02\x8d\x00\xc7\x02\xe7\x02\x2b\x00\xa4\x02\xca\x04\xca\x04\xca\x04\xca\x04\x2f\x00\x2f\x00\xca\x04\xca\x04\x88\x01\xde\x04\xe4\x04\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x02\xea\x02\x00\x00\xed\x02\xf8\x02\x00\x00\xf9\x02\x9c\x02\xeb\x02\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x8c\x00\x00\x00\xfd\x02\x8f\x00\x00\x03\xbe\x02\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x05\x03\xcd\x02\xcf\x02\xc9\x02\x00\x00\xce\x02\x00\x00\x03\x03\x0d\x03\x0e\x03\x0f\x03\x13\x03\x00\x00\xb6\x02\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x02\xe3\x02\xe5\x02\xee\x02\x00\x00\x30\x03\x25\x03\x00\x00\x44\x03\x48\x03\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x3f\x03\x42\x03\x24\x03\x02\x03\x0b\x02\xd0\x02\xea\x00\x4c\x03\x00\x00\x45\x03\x55\x03\x8c\x00\x1f\x02\x5a\x03\x8c\x00\x10\x03\x00\x00\x60\x03\x00\x00\x8c\x00\x00\x00\x70\x03\x00\x00\x00\x00\x5b\x03\x71\x03\x00\x00\x19\x03\x06\x00\x5f\x03\x6b\x03\x6c\x03\x6e\x03\x00\x00\x2d\x03\x36\x03\x39\x03\x00\x00\x2b\x00\x47\x03\x00\x00\x2b\x00\x81\x03\x2b\x00\x8a\x03\x00\x00\x5c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x93\x03\x66\x03\x98\x03\xa0\x03\x00\x00\xab\x03\xae\x03\xb3\x03\xb5\x03\xa5\x03\xa8\x03\x52\x03\x74\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x03\xc1\x03\x00\x00\x7c\x03\xc9\x03\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x1f\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\xcf\x03\x00\x00\xca\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x03\x00\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x03\x00\x00\x00\x00\xdc\x03\x3c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x03\x00\x00\xe5\x03\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\x1c\x01\x1f\x01\xaf\x00\x00\x00\x00\x00\xde\x03\x00\x00\xe9\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x99\x01\x8e\x03\x90\x03\x00\x00\xda\x03\x00\x00\xea\x03\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\xed\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x00\x00\x9e\x03\xaa\x03\x00\x00\xac\x03\x00\x00\x00\x00\x00\x00\xdb\x03\xdd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x02\x00\x00\x00\x00\xb8\x03\x00\x00\x00\x00\xb3\x01\x00\x00\x00\x00\x35\x03\xba\x03\x00\x00\x43\x03\x00\x00\xeb\x03\x00\x00\xe7\x03\x00\x00\x00\x00\x9c\x01\x9e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x03\xc6\x03\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x03\x00\x00\xfd\x03\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x03\xd6\x03\xe2\x03\xe4\x03\xf0\x03\xf2\x03\xfe\x03\x00\x04\x0c\x04\x0e\x04\x1a\x04\x1c\x04\x28\x04\x2a\x04\x36\x04\x38\x04\x00\x00\x00\x00\xb5\x01\xb7\x01\x46\x03\x00\x00\xf8\x03\x54\x03\xe6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x01\x00\x00\x00\x00\x17\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x04\x00\x00\x00\x00\x00\x00\x00\x00\x19\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x04\x00\x00\x00\x00\x62\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x04\x16\x01\x00\x00\x00\x00\x5a\x00\x24\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x03\x2e\x03\x52\x04\x54\x04\x60\x04\x00\x00\x00\x00\x00\x00\x00\x00\x06\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x04\x2a\x01\x0f\x04\x00\x00\x2b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x03\x00\x00\x00\x00\x00\x00\x00\x00\x12\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x04\x00\x00\x00\x00\x7f\x03\x21\x04\x00\x00\x00\x00\x00\x00\x82\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x04\x1d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x01\x00\x00\x00\x00\x3f\x01\x00\x00\x53\x01\x00\x00\x00\x00\x2c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# -happyAdjustOffset off = off - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x57\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\xff\x56\xff\x55\xff\x54\xff\x53\xff\x52\xff\x51\xff\x50\xff\x4f\xff\x4e\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xff\xea\xff\xfd\xff\x00\x00\x5e\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\xff\x5b\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\xbb\xff\xb9\xff\xba\xff\xb8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\x00\x00\x61\xff\x62\xff\x59\xff\x5c\xff\x5f\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x57\xff\x00\x00\x58\xff\x00\x00\x00\x00\x00\x00\x00\x00\x82\xff\x7e\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6b\xff\x6c\xff\x7f\xff\x78\xff\x78\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x5e\xff\x00\x00\x00\x00\x00\x00\x5a\xff\xd2\xff\x70\xff\x00\x00\x00\x00\x70\xff\x00\x00\x00\x00\x70\xff\x00\x00\x00\x00\x00\x00\x96\xff\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x68\xff\x65\xff\x00\x00\x63\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xff\x00\x00\x67\xff\x00\x00\xc9\xff\xae\xff\x00\x00\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\xff\x00\x00\x00\x00\x70\xff\x00\x00\x6e\xff\x00\x00\x6f\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xff\x00\x00\x81\xff\x84\xff\x00\x00\x85\xff\x00\x00\x7d\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\xff\x70\xff\x77\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbc\xff\xb6\xff\xb7\xff\x00\x00\xa3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x62\xff\x00\x00\x00\x00\xaa\xff\x00\x00\xa7\xff\xc7\xff\x00\x00\xaf\xff\xb0\xff\x00\x00\xe0\xff\x00\x00\x87\xff\x86\xff\x89\xff\x8b\xff\x8f\xff\x90\xff\x88\xff\x8a\xff\x8c\xff\x8d\xff\x8e\xff\x91\xff\x92\xff\x93\xff\x94\xff\x95\xff\xad\xff\x69\xff\x66\xff\x00\x00\x00\x00\xd1\xff\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\x00\x00\x70\xff\x76\xff\x00\x00\x00\x00\x00\x00\xc2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa9\xff\xa8\xff\x00\x00\xbf\xff\x6d\xff\xc8\xff\x00\x00\x9b\xff\xa3\xff\x00\x00\xc0\xff\x00\x00\xcb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xff\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x83\xff\x7a\xff\x7c\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xff\x00\x00\x9e\xff\xa2\xff\x00\x00\x00\x00\xa5\xff\xc6\xff\x70\xff\xa6\xff\xc4\xff\x00\x00\x00\x00\x9a\xff\x00\x00\x00\x00\x00\x00\x72\xff\x00\x00\x75\xff\x74\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\x71\xff\x00\x00\xce\xff\x70\xff\xc1\xff\x00\x00\x97\xff\x98\xff\x00\x00\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xa1\xff\xe0\xff\x00\x00\x9d\xff\xe0\xff\x00\x00\xe0\xff\x00\x00\xd0\xff\xb4\xff\xab\xff\x73\xff\xcc\xff\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xa0\xff\x9f\xff\x9c\xff\x99\xff\xc3\xff\xb3\xff\xcd\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\xe5\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x04\x00\x05\x00\x03\x00\x08\x00\x07\x00\x04\x00\x05\x00\x03\x00\x0b\x00\x06\x00\x29\x00\x0e\x00\x0f\x00\x05\x00\x24\x00\x02\x00\x06\x00\x16\x00\x01\x00\x07\x00\x07\x00\x05\x00\x2c\x00\x0d\x00\x07\x00\x34\x00\x35\x00\x36\x00\x37\x00\x00\x00\x01\x00\x02\x00\x36\x00\x37\x00\x12\x00\x36\x00\x07\x00\x38\x00\x51\x00\x0a\x00\x3a\x00\x0c\x00\x4d\x00\x02\x00\x20\x00\x21\x00\x4d\x00\x4e\x00\x07\x00\x32\x00\x36\x00\x37\x00\x02\x00\x03\x00\x32\x00\x36\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x25\x00\x26\x00\x27\x00\x28\x00\x4f\x00\x36\x00\x37\x00\x4d\x00\x4c\x00\x20\x00\x21\x00\x30\x00\x07\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x07\x00\x38\x00\x39\x00\x3a\x00\x0b\x00\x3c\x00\x3d\x00\x0e\x00\x0f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x0c\x00\x0d\x00\x0e\x00\x07\x00\x23\x00\x24\x00\x07\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x2b\x00\x2c\x00\x07\x00\x0b\x00\x4d\x00\x4e\x00\x0e\x00\x0f\x00\x2e\x00\x2f\x00\x30\x00\x36\x00\x37\x00\x07\x00\x07\x00\x17\x00\x4c\x00\x4d\x00\x0b\x00\x02\x00\x03\x00\x0e\x00\x0f\x00\x29\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x20\x00\x21\x00\x07\x00\x0b\x00\x22\x00\x23\x00\x0e\x00\x0f\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x4e\x00\x3a\x00\x0d\x00\x0e\x00\x0d\x00\x0e\x00\x0e\x00\x36\x00\x37\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x36\x00\x37\x00\x36\x00\x37\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x02\x00\x0b\x00\x0c\x00\x16\x00\x07\x00\x4d\x00\x10\x00\x0a\x00\x12\x00\x0c\x00\x03\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0b\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x10\x00\x16\x00\x12\x00\x10\x00\x2d\x00\x12\x00\x1c\x00\x1d\x00\x31\x00\x4d\x00\x0b\x00\x0c\x00\x4e\x00\x36\x00\x37\x00\x10\x00\x02\x00\x12\x00\x0b\x00\x0c\x00\x36\x00\x37\x00\x4d\x00\x10\x00\x4d\x00\x12\x00\x1c\x00\x1d\x00\x4d\x00\x2d\x00\x0b\x00\x0c\x00\x2d\x00\x31\x00\x4d\x00\x10\x00\x31\x00\x12\x00\x36\x00\x37\x00\x4d\x00\x36\x00\x37\x00\x02\x00\x2d\x00\x07\x00\x16\x00\x16\x00\x31\x00\x12\x00\x0b\x00\x0c\x00\x2d\x00\x36\x00\x37\x00\x10\x00\x31\x00\x12\x00\x16\x00\x17\x00\x4d\x00\x36\x00\x37\x00\x4d\x00\x2d\x00\x16\x00\x23\x00\x24\x00\x31\x00\x16\x00\x16\x00\x23\x00\x24\x00\x36\x00\x37\x00\x2c\x00\x01\x00\x16\x00\x4d\x00\x4f\x00\x2c\x00\x4f\x00\x4f\x00\x4f\x00\x2d\x00\x36\x00\x37\x00\x4f\x00\x31\x00\x08\x00\x36\x00\x37\x00\x16\x00\x36\x00\x37\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x07\x00\x30\x00\x31\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x4d\x00\x04\x00\x09\x00\x3c\x00\x05\x00\x13\x00\x4d\x00\x1a\x00\x1b\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x07\x00\x4d\x00\x23\x00\x24\x00\x16\x00\x17\x00\x16\x00\x17\x00\x4c\x00\x16\x00\x16\x00\x2c\x00\x16\x00\x16\x00\x23\x00\x24\x00\x16\x00\x23\x00\x24\x00\x23\x00\x24\x00\x36\x00\x37\x00\x2c\x00\x04\x00\x07\x00\x2c\x00\x05\x00\x2c\x00\x16\x00\x17\x00\x16\x00\x17\x00\x36\x00\x37\x00\x05\x00\x36\x00\x37\x00\x36\x00\x37\x00\x23\x00\x24\x00\x23\x00\x24\x00\x23\x00\x24\x00\x4d\x00\x2a\x00\x2b\x00\x2c\x00\x4f\x00\x2c\x00\x0a\x00\x2c\x00\x4d\x00\x02\x00\x19\x00\x08\x00\x02\x00\x36\x00\x37\x00\x36\x00\x37\x00\x36\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x4f\x00\x4f\x00\x4f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x4f\x00\x09\x00\x4f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x02\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x03\x00\x4d\x00\x0e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4e\x00\x05\x00\x4d\x00\x4d\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x05\x00\x09\x00\x07\x00\x09\x00\x08\x00\x24\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x08\x00\x08\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x18\x00\x16\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x07\x00\x16\x00\x16\x00\x05\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x06\x00\x16\x00\x4d\x00\x06\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x02\x00\x08\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4e\x00\x0a\x00\x4f\x00\x4f\x00\x4f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x16\x00\x3e\x00\x4f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x02\x00\x06\x00\x08\x00\x06\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x20\x00\x01\x00\x34\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x4d\x00\x05\x00\x09\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x07\x00\x07\x00\x04\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x4c\x00\x06\x00\x3f\x00\x3e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4f\x00\x16\x00\x4c\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x16\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4e\x00\x01\x00\x4f\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x16\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x04\x00\x01\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x24\x00\x2f\x00\x08\x00\x27\x00\x28\x00\x29\x00\x23\x00\x24\x00\x2c\x00\x16\x00\x02\x00\x08\x00\x4e\x00\x2a\x00\x2b\x00\x2c\x00\x02\x00\x08\x00\x36\x00\x37\x00\x23\x00\x24\x00\x4f\x00\x23\x00\x24\x00\x36\x00\x37\x00\x2a\x00\x2b\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x03\x00\x03\x00\x16\x00\x08\x00\x23\x00\x24\x00\x36\x00\x37\x00\x4e\x00\x36\x00\x37\x00\x2a\x00\x2b\x00\x2c\x00\x16\x00\x16\x00\x02\x00\x4e\x00\x23\x00\x24\x00\x4e\x00\x23\x00\x24\x00\x36\x00\x37\x00\x2a\x00\x2b\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x08\x00\x37\x00\x4d\x00\x02\x00\x23\x00\x24\x00\x36\x00\x37\x00\x02\x00\x36\x00\x37\x00\x2a\x00\x2b\x00\x2c\x00\x4e\x00\x3b\x00\x23\x00\x24\x00\x04\x00\x23\x00\x24\x00\x28\x00\x29\x00\x36\x00\x37\x00\x2c\x00\x2a\x00\x2b\x00\x2c\x00\x04\x00\x02\x00\x23\x00\x24\x00\x23\x00\x24\x00\x36\x00\x37\x00\x04\x00\x36\x00\x37\x00\x2c\x00\x16\x00\x2c\x00\x08\x00\x16\x00\x23\x00\x24\x00\x23\x00\x24\x00\x4f\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x08\x00\x2c\x00\x4f\x00\x16\x00\x23\x00\x24\x00\x23\x00\x24\x00\x08\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x08\x00\x2c\x00\x0f\x00\x0f\x00\x23\x00\x24\x00\x23\x00\x24\x00\x32\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x09\x00\x2c\x00\x0f\x00\x03\x00\x23\x00\x24\x00\x23\x00\x24\x00\x0f\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x06\x00\x2c\x00\x1b\x00\x25\x00\x23\x00\x24\x00\x23\x00\x24\x00\x11\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x26\x00\x2c\x00\x26\x00\x19\x00\x23\x00\x24\x00\x23\x00\x24\x00\x22\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x30\x00\x2c\x00\x14\x00\x1a\x00\x23\x00\x24\x00\x23\x00\x24\x00\x31\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x06\x00\x2c\x00\x06\x00\x1a\x00\x23\x00\x24\x00\x23\x00\x24\x00\x20\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x09\x00\x2c\x00\x09\x00\x1f\x00\x23\x00\x24\x00\x23\x00\x24\x00\x21\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x18\x00\x2c\x00\x1e\x00\x11\x00\x23\x00\x24\x00\x23\x00\x24\x00\x15\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\x1f\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\x36\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\x4d\x00\x4e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x2e\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x81\x00\x73\x00\x74\x00\x23\x01\x90\x00\x82\x00\x8a\x00\x74\x00\x9c\x01\x83\x00\xfb\x00\x21\x00\x84\x00\x85\x00\xad\x00\x63\x01\x72\x01\x1b\x01\x91\x00\x96\x00\xd5\x00\x73\x01\xf5\x00\x7e\x00\x1c\x01\x97\x00\x94\x00\x4c\x00\x4d\x00\x09\x00\x02\x00\x03\x00\x04\x00\x7f\x00\x09\x00\xf6\x00\xaf\x00\x05\x00\xb0\x00\xff\xff\x06\x00\x2f\x00\x07\x00\x26\x00\x59\x00\xd6\x00\xd7\x00\x22\x00\x23\x00\x5a\x00\x24\x01\x75\x00\x76\x00\x50\x00\x51\x00\x9d\x01\x75\x00\x76\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x26\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xfc\x00\x08\x00\x09\x00\x26\x00\x1d\x01\xd6\x00\xd7\x00\x11\x00\x2c\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x6a\xff\x82\x00\x6a\xff\x63\x00\x64\x00\x83\x00\x13\x00\x65\x00\x84\x00\x85\x00\x66\x00\x67\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x68\x00\x69\x00\xc4\x00\xc5\x00\xc6\x00\x2b\x00\xdc\x00\x7d\x00\x2a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa4\x00\x4e\x01\x7e\x00\x29\x00\x83\x00\xab\x00\xac\x00\x84\x00\x85\x00\x36\x01\xa7\x00\xa8\x00\x7f\x00\x09\x00\x28\x00\x82\x00\xa5\x00\x68\x00\x18\x01\x83\x00\x50\x00\x51\x00\x84\x00\x85\x00\x78\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\xd6\x00\xd7\x00\x27\x00\x83\x00\x76\x01\x77\x01\x84\x00\x85\x00\x79\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x24\x00\x11\x01\x1e\x00\x1f\x00\x40\x00\x1f\x00\x84\x00\xb0\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x3a\x01\x09\x00\x05\x01\x09\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x2f\x00\x03\x00\x04\x00\x40\x00\x51\x00\x52\x00\x3f\x00\x05\x00\x3e\x00\x53\x00\x06\x00\x54\x00\x07\x00\x3c\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\xb2\x00\x52\x00\x3d\x00\xb1\x00\x52\x00\x53\x00\x3a\x00\x54\x00\x53\x00\x55\x00\x54\x00\x51\x01\x52\x01\x56\x00\x39\x00\x46\x01\x52\x00\x86\x01\x57\x00\x09\x00\x53\x00\x3b\x00\x54\x00\xaf\x01\x52\x00\x08\x00\x09\x00\x38\x00\x53\x00\x37\x00\x54\x00\x6d\x01\x52\x01\x36\x00\x55\x00\xad\x01\x52\x00\x55\x00\x56\x00\x35\x00\x53\x00\x56\x00\x54\x00\x57\x00\x09\x00\x34\x00\x57\x00\x09\x00\x33\x00\x55\x00\x32\x00\x4a\x00\x49\x00\x56\x00\xb7\x00\xab\x01\x52\x00\x55\x00\x57\x00\x09\x00\x53\x00\x56\x00\x54\x00\xa0\x00\xa1\x00\x26\x00\x57\x00\x09\x00\x43\x00\x55\x00\x48\x00\xb8\x00\x7d\x00\x56\x00\x47\x00\x46\x00\xa2\x00\x7d\x00\x57\x00\x09\x00\x7e\x00\x73\x00\x45\x00\x6d\x00\x72\x00\x7e\x00\x71\x00\x70\x00\x6f\x00\x55\x00\x7f\x00\x09\x00\x6e\x00\x56\x00\x6c\x00\x7f\x00\x09\x00\x6b\x00\x57\x00\x09\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x9d\x00\x11\x00\x12\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x6a\x00\xb4\x00\xae\x00\x13\x00\x9c\x00\x0e\x01\xa6\x00\xce\x00\xcf\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x9a\x00\x1e\x00\x0f\x01\x7d\x00\xc0\x00\xc1\x00\xbf\x00\xa1\x00\x99\x00\x94\x00\x92\x00\x7e\x00\x8f\x00\x8e\x00\x9f\x00\x7d\x00\x8d\x00\xc2\x00\x7d\x00\xa2\x00\x7d\x00\x7f\x00\x09\x00\x7e\x00\x8c\x00\x7b\x00\x7e\x00\x7c\x00\x7e\x00\x20\x01\xa1\x00\x1f\x01\xa1\x00\x7f\x00\x09\x00\x7a\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\xdc\x00\x7d\x00\xa2\x00\x7d\x00\xa2\x00\x7d\x00\xfa\x00\xe4\x00\xde\x00\x7e\x00\xf9\x00\x7e\x00\xf7\x00\x7e\x00\xf1\x00\xf8\x00\xee\x00\xe7\x00\xe4\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x3a\x01\xec\x00\xeb\x00\xea\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x88\x01\xe8\x00\xe3\x00\xe0\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xa8\x01\xbf\x00\xbe\x00\xbd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbc\x00\x13\x01\xab\x00\xb6\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xb7\x00\xb5\x00\x3e\x01\x3d\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xda\x00\x38\x01\xdb\x00\x36\x01\x35\x01\x22\x01\x1e\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x15\x01\x12\x01\x0e\x01\x0c\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x39\x01\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x14\x01\x0b\x01\x0a\x01\x09\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x5d\x01\xe8\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x05\x01\x08\x01\x07\x01\x02\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x40\x01\x00\x01\x94\x00\x01\x01\xfd\x00\xfe\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x63\x01\x62\x01\x61\x01\x60\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x65\x01\x5b\x01\x5f\x01\x5a\x01\x59\x01\x58\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x57\x01\x56\x01\x54\x01\x51\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x87\x01\x50\x01\x4c\x01\x4d\x01\x4b\x01\x4a\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x49\x01\xd6\x00\x48\x01\x45\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd8\x00\x46\x01\x43\x01\x44\x01\x81\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x42\x01\x41\x01\x78\x01\x75\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x89\x01\x1d\x01\x71\x01\x70\x01\x54\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x6d\x01\x6a\x01\x99\x00\x66\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x04\x01\x69\x01\x68\x01\x67\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x96\x01\x92\x01\x95\x01\x94\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xdc\x00\x91\x01\x93\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x8d\x01\x90\x01\x8f\x01\x8c\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x7b\x01\x7d\x00\x8b\x01\x85\x01\x7c\x01\x7d\x01\x7e\x01\xdc\x00\x7d\x00\x7e\x00\x84\x01\xa7\x01\x83\x01\xa5\x01\xe1\x00\xde\x00\x7e\x00\xa3\x01\xa0\x01\x7f\x00\x09\x00\xdc\x00\x7d\x00\x6d\x01\xdc\x00\x7d\x00\x7f\x00\x09\x00\xdd\x00\xde\x00\x7e\x00\x1e\x01\xde\x00\x7e\x00\xa1\x01\x9f\x01\x9a\x01\x97\x01\xdc\x00\x7d\x00\x7f\x00\x09\x00\xb3\x01\x7f\x00\x09\x00\x18\x01\xde\x00\x7e\x00\x99\x01\x98\x01\xad\x01\xb2\x01\xdc\x00\x7d\x00\xb1\x01\xdc\x00\x7d\x00\x7f\x00\x09\x00\x5b\x01\xde\x00\x7e\x00\x7f\x01\xde\x00\x7e\x00\xab\x01\xaa\x01\xaf\x01\xbd\x01\xdc\x00\x7d\x00\x7f\x00\x09\x00\xbb\x01\x7f\x00\x09\x00\x8d\x01\xde\x00\x7e\x00\xbf\x01\xbc\x01\x7b\x01\x7d\x00\xba\x01\xdc\x00\x7d\x00\xa5\x01\x7e\x01\x7f\x00\x09\x00\x7e\x00\xa1\x01\xde\x00\x7e\x00\xb9\x01\xb8\x01\x9e\x00\x7d\x00\x9d\x00\x7d\x00\x7f\x00\x09\x00\xb7\x01\x7f\x00\x09\x00\x7e\x00\xb5\x01\x7e\x00\xb6\x01\xb4\x01\x7c\x00\x7d\x00\xf2\x00\x7d\x00\xbe\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xc0\x01\x7e\x00\xc2\x01\xc1\x01\xf1\x00\x7d\x00\xef\x00\x7d\x00\xc3\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x2d\x00\x7e\x00\x2c\x00\x24\x00\xe5\x00\x7d\x00\xe0\x00\x7d\x00\x30\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x4e\x00\x7e\x00\x43\x00\x41\x00\xb9\x00\x7d\x00\x3e\x01\x7d\x00\x2c\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x92\x00\x7e\x00\x9a\x00\xf3\x00\x33\x01\x7d\x00\x32\x01\x7d\x00\x97\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xee\x00\x7e\x00\xec\x00\xd8\x00\x31\x01\x7d\x00\x30\x01\x7d\x00\xd3\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xba\x00\x7e\x00\x3b\x01\x19\x01\x2f\x01\x7d\x00\x2e\x01\x7d\x00\x16\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x0c\x01\x7e\x00\xfe\x00\x73\x01\x2d\x01\x7d\x00\x2c\x01\x7d\x00\x6e\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x54\x01\x7e\x00\x4d\x01\x6b\x01\x2b\x01\x7d\x00\x2a\x01\x7d\x00\x89\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xa3\x01\x7e\x00\x9a\x01\x6a\x01\x29\x01\x7d\x00\x28\x01\x7d\x00\xa8\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x27\x01\x7d\x00\x26\x01\x7d\x00\x9d\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x25\x01\x7d\x00\x24\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x02\x01\x7d\x00\x5d\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x7a\x01\x7d\x00\x79\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x78\x01\x7d\x00\x81\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x16\x01\x00\x00\x00\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x94\x00\x00\x00\x00\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x00\x00\x00\x00\x00\x00\xce\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xcf\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xab\x00\xac\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa6\x00\xa7\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (1, 177) [ - (1 , happyReduce_1), - (2 , happyReduce_2), - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177) - ] - -happy_n_terms = 82 :: Prelude.Int -happy_n_nonterms = 56 :: Prelude.Int - -happyReduce_1 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_1 = happySpecReduce_0 0# happyReduction_1 -happyReduction_1 = happyIn4 - (return () - ) - -happyReduce_2 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_2 = happySpecReduce_2 0# happyReduction_2 -happyReduction_2 happy_x_2 - happy_x_1 - = case happyOut5 happy_x_1 of { (HappyWrap5 happy_var_1) -> - case happyOut4 happy_x_2 of { (HappyWrap4 happy_var_2) -> - happyIn4 - (do happy_var_1; happy_var_2 - )}} - -happyReduce_3 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_3 = happySpecReduce_1 1# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOut11 happy_x_1 of { (HappyWrap11 happy_var_1) -> - happyIn5 - (happy_var_1 - )} - -happyReduce_4 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_4 = happySpecReduce_1 1# happyReduction_4 -happyReduction_4 happy_x_1 - = case happyOut6 happy_x_1 of { (HappyWrap6 happy_var_1) -> - happyIn5 - (happy_var_1 - )} - -happyReduce_5 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_5 = happySpecReduce_1 1# happyReduction_5 -happyReduction_5 happy_x_1 - = case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> - happyIn5 - (happy_var_1 - )} - -happyReduce_6 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6 -happyReduction_6 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> - case happyOut10 happy_x_6 of { (HappyWrap10 happy_var_6) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - lits <- sequence happy_var_6; - staticClosure home_unit_id happy_var_3 happy_var_5 (map getLit lits))}}}) - ) (\r -> happyReturn (happyIn5 r)) - -happyReduce_7 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_7 = happyReduce 6# 2# happyReduction_7 -happyReduction_7 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> - case happyOut7 happy_x_4 of { (HappyWrap7 happy_var_4) -> - case happyOut8 happy_x_5 of { (HappyWrap8 happy_var_5) -> - happyIn6 - (do lbl <- happy_var_4; - ss <- sequence happy_var_5; - code (emitDecl (CmmData (Section (section happy_var_2) lbl) (CmmStaticsRaw lbl (concat ss)))) - ) `HappyStk` happyRest}}} - -happyReduce_8 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8 -happyReduction_8 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) happy_var_1))}) - ) (\r -> happyReturn (happyIn7 r)) - -happyReduce_9 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_9 = happySpecReduce_0 4# happyReduction_9 -happyReduction_9 = happyIn8 - ([] - ) - -happyReduce_10 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_10 = happySpecReduce_2 4# happyReduction_10 -happyReduction_10 happy_x_2 - happy_x_1 - = case happyOut9 happy_x_1 of { (HappyWrap9 happy_var_1) -> - case happyOut8 happy_x_2 of { (HappyWrap8 happy_var_2) -> - happyIn8 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_11 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_11 = happySpecReduce_3 5# happyReduction_11 -happyReduction_11 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - happyIn9 - (do e <- happy_var_2; - return [CmmStaticLit (getLit e)] - )} - -happyReduce_12 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_12 = happySpecReduce_2 5# happyReduction_12 -happyReduction_12 happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> - happyIn9 - (return [CmmUninitialised - (widthInBytes (typeWidth happy_var_1))] - )} - -happyReduce_13 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_13 = happyReduce 5# 5# happyReduction_13 -happyReduction_13 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_4 of { (L _ (CmmT_String happy_var_4)) -> - happyIn9 - (return [mkString happy_var_4] - ) `HappyStk` happyRest} - -happyReduce_14 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_14 = happyReduce 5# 5# happyReduction_14 -happyReduction_14 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> - happyIn9 - (return [CmmUninitialised - (fromIntegral happy_var_3)] - ) `HappyStk` happyRest} - -happyReduce_15 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_15 = happyReduce 5# 5# happyReduction_15 -happyReduction_15 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> - case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> - happyIn9 - (return [CmmUninitialised - (widthInBytes (typeWidth happy_var_1) * - fromIntegral happy_var_3)] - ) `HappyStk` happyRest}} - -happyReduce_16 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_16 = happyReduce 5# 5# happyReduction_16 -happyReduction_16 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut10 happy_x_4 of { (HappyWrap10 happy_var_4) -> - happyIn9 - (do { lits <- sequence happy_var_4 - ; profile <- getProfile - ; return $ map CmmStaticLit $ - mkStaticClosure profile (mkForeignLabel happy_var_3 Nothing ForeignLabelInExternalPackage IsData) - -- mkForeignLabel because these are only used - -- for CHARLIKE and INTLIKE closures in the RTS. - dontCareCCS (map getLit lits) [] [] [] [] } - ) `HappyStk` happyRest}} - -happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_17 = happySpecReduce_0 6# happyReduction_17 -happyReduction_17 = happyIn10 - ([] - ) - -happyReduce_18 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_18 = happySpecReduce_3 6# happyReduction_18 -happyReduction_18 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - case happyOut10 happy_x_3 of { (HappyWrap10 happy_var_3) -> - happyIn10 - (happy_var_2 : happy_var_3 - )}} - -happyReduce_19 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_19 = happyReduce 4# 7# happyReduction_19 -happyReduction_19 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut14 happy_x_1 of { (HappyWrap14 happy_var_1) -> - case happyOut12 happy_x_2 of { (HappyWrap12 happy_var_2) -> - case happyOut54 happy_x_3 of { (HappyWrap54 happy_var_3) -> - case happyOut13 happy_x_4 of { (HappyWrap13 happy_var_4) -> - happyIn11 - (do ((entry_ret_label, info, stk_formals, formals), agraph) <- - getCodeScoped $ loopDecls $ do { - (entry_ret_label, info, stk_formals) <- happy_var_1; - platform <- getPlatform; - ctx <- getContext; - formals <- sequence (fromMaybe [] happy_var_3); - withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label)) - happy_var_4; - return (entry_ret_label, info, stk_formals, formals) } - let do_layout = isJust happy_var_3 - code (emitProcWithStackFrame happy_var_2 info - entry_ret_label stk_formals formals agraph - do_layout ) - ) `HappyStk` happyRest}}}} - -happyReduce_20 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_20 = happySpecReduce_0 8# happyReduction_20 -happyReduction_20 = happyIn12 - (NativeNodeCall - ) - -happyReduce_21 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_21 = happySpecReduce_1 8# happyReduction_21 -happyReduction_21 happy_x_1 - = happyIn12 - (NativeReturn - ) - -happyReduce_22 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_22 = happySpecReduce_1 9# happyReduction_22 -happyReduction_22 happy_x_1 - = happyIn13 - (return () - ) - -happyReduce_23 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_23 = happySpecReduce_3 9# happyReduction_23 -happyReduction_23 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn13 - (withSourceNote happy_var_1 happy_var_3 happy_var_2 - )}}} - -happyReduce_24 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24 -happyReduction_24 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - newFunctionName happy_var_1 home_unit_id - return (mkCmmCodeLabel home_unit_id happy_var_1, Nothing, []))}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_25 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25 -happyReduction_25 (happy_x_14 `HappyStk` - happy_x_13 `HappyStk` - happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - profile <- getProfile - let prof = profilingInfo profile happy_var_11 happy_var_13 - rep = mkRTSRep (fromIntegral happy_var_9) $ - mkHeapRep profile False (fromIntegral happy_var_5) - (fromIntegral happy_var_7) Thunk - -- not really Thunk, but that makes the info table - -- we want. - return (mkCmmEntryLabel home_unit_id happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []))}}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_26 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_26 = happyMonadReduce 18# 10# happyReduction_26 -happyReduction_26 (happy_x_18 `HappyStk` - happy_x_17 `HappyStk` - happy_x_16 `HappyStk` - happy_x_15 `HappyStk` - happy_x_14 `HappyStk` - happy_x_13 `HappyStk` - happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> - case happyOutTok happy_x_17 of { (L _ (CmmT_Int happy_var_17)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - profile <- getProfile - let prof = profilingInfo profile happy_var_11 happy_var_13 - ty = Fun (fromIntegral happy_var_15) (ArgSpec (fromIntegral happy_var_17)) - rep = mkRTSRep (fromIntegral happy_var_9) $ - mkHeapRep profile False (fromIntegral happy_var_5) - (fromIntegral happy_var_7) ty - return (mkCmmEntryLabel home_unit_id happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []))}}}}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_27 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27 -happyReduction_27 (happy_x_16 `HappyStk` - happy_x_15 `HappyStk` - happy_x_14 `HappyStk` - happy_x_13 `HappyStk` - happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_Int happy_var_11)) -> - case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> - case happyOutTok happy_x_15 of { (L _ (CmmT_String happy_var_15)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - profile <- getProfile - let prof = profilingInfo profile happy_var_13 happy_var_15 - ty = Constr (fromIntegral happy_var_9) -- Tag - (BS8.pack happy_var_13) - rep = mkRTSRep (fromIntegral happy_var_11) $ - mkHeapRep profile False (fromIntegral happy_var_5) - (fromIntegral happy_var_7) ty - return (mkCmmEntryLabel home_unit_id happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing }, - []))}}}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_28 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28 -happyReduction_28 (happy_x_12 `HappyStk` - happy_x_11 `HappyStk` - happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> - case happyOutTok happy_x_9 of { (L _ (CmmT_String happy_var_9)) -> - case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - profile <- getProfile - let prof = profilingInfo profile happy_var_9 happy_var_11 - ty = ThunkSelector (fromIntegral happy_var_5) - rep = mkRTSRep (fromIntegral happy_var_7) $ - mkHeapRep profile False 0 0 ty - return (mkCmmEntryLabel home_unit_id happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []))}}}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_29 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29 -happyReduction_29 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - let prof = NoProfilingInfo - rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep [] - return (mkCmmRetLabel home_unit_id happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - []))}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_30 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30 -happyReduction_30 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOut55 happy_x_7 of { (HappyWrap55 happy_var_7) -> - ( do - home_unit_id <- getHomeUnitId - liftP $ pure $ do - platform <- getPlatform - live <- sequence happy_var_7 - let prof = NoProfilingInfo - -- drop one for the info pointer - bitmap = mkLiveness platform (drop 1 live) - rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap - return (mkCmmRetLabel home_unit_id happy_var_3, - Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3 - , cit_rep = rep - , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, - live))}}}) - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_31 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_31 = happySpecReduce_0 11# happyReduction_31 -happyReduction_31 = happyIn15 - (return () - ) - -happyReduce_32 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_32 = happySpecReduce_2 11# happyReduction_32 -happyReduction_32 happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> - case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> - happyIn15 - (do happy_var_1; happy_var_2 - )}} - -happyReduce_33 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_33 = happySpecReduce_2 11# happyReduction_33 -happyReduction_33 happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> - case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> - happyIn15 - (do happy_var_1; happy_var_2 - )}} - -happyReduce_34 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_34 = happySpecReduce_3 12# happyReduction_34 -happyReduction_34 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> - case happyOut19 happy_x_2 of { (HappyWrap19 happy_var_2) -> - happyIn16 - (mapM_ (newLocal happy_var_1) happy_var_2 - )}} - -happyReduce_35 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_35 = happySpecReduce_3 12# happyReduction_35 -happyReduction_35 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut17 happy_x_2 of { (HappyWrap17 happy_var_2) -> - happyIn16 - (mapM_ newImport happy_var_2 - )} - -happyReduce_36 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_36 = happySpecReduce_3 12# happyReduction_36 -happyReduction_36 happy_x_3 - happy_x_2 - happy_x_1 - = happyIn16 - (return () - ) - -happyReduce_37 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_37 = happySpecReduce_1 13# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> - happyIn17 - ([happy_var_1] - )} - -happyReduce_38 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_38 = happySpecReduce_3 13# happyReduction_38 -happyReduction_38 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> - case happyOut17 happy_x_3 of { (HappyWrap17 happy_var_3) -> - happyIn17 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_39 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_39 = happySpecReduce_1 14# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn18 - ((happy_var_1, mkForeignLabel happy_var_1 Nothing ForeignLabelInExternalPackage IsFunction) - )} - -happyReduce_40 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_40 = happySpecReduce_2 14# happyReduction_40 -happyReduction_40 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn18 - ((happy_var_2, mkForeignLabel happy_var_2 Nothing ForeignLabelInExternalPackage IsData) - )} - -happyReduce_41 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_41 = happySpecReduce_2 14# happyReduction_41 -happyReduction_41 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn18 - ((happy_var_2, mkCmmCodeLabel (UnitId (mkFastString happy_var_1)) happy_var_2) - )}} - -happyReduce_42 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_42 = happySpecReduce_1 15# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn19 - ([happy_var_1] - )} - -happyReduce_43 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_43 = happySpecReduce_3 15# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> - happyIn19 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_44 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_44 = happySpecReduce_1 16# happyReduction_44 -happyReduction_44 happy_x_1 - = happyIn20 - (return () - ) - -happyReduce_45 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_45 = happySpecReduce_2 16# happyReduction_45 -happyReduction_45 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn20 - (do l <- newLabel happy_var_1; emitLabel l - )} - -happyReduce_46 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_46 = happyReduce 4# 16# happyReduction_46 -happyReduction_46 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut53 happy_x_1 of { (HappyWrap53 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn20 - (do reg <- happy_var_1; e <- happy_var_3; withSourceNote happy_var_2 happy_var_4 (emitAssign reg e) - ) `HappyStk` happyRest}}}} - -happyReduce_47 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_47 = happyReduce 8# 16# happyReduction_47 -happyReduction_47 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut53 happy_x_1 of { (HappyWrap53 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> - case happyOut58 happy_x_4 of { (HappyWrap58 happy_var_4) -> - case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> - case happyOutTok happy_x_7 of { happy_var_7 -> - happyIn20 - (do reg <- happy_var_1; - let lreg = case reg of - { CmmLocal r -> r - ; other -> pprPanic "CmmParse:" (ppr reg <> text "not a local register") - } ; - mord <- happy_var_3; - let { ty = happy_var_4; w = typeWidth ty }; - e <- happy_var_6; - let op = MO_AtomicRead w mord; - withSourceNote happy_var_2 happy_var_7 $ code (emitPrimCall [lreg] op [e]) - ) `HappyStk` happyRest}}}}}} - -happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_48 = happyReduce 8# 16# happyReduction_48 -happyReduction_48 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> - case happyOut58 happy_x_2 of { (HappyWrap58 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> - case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> - case happyOutTok happy_x_8 of { happy_var_8 -> - happyIn20 - (do mord <- happy_var_1; withSourceNote happy_var_3 happy_var_8 (doStore (Just mord) happy_var_2 happy_var_4 happy_var_7) - ) `HappyStk` happyRest}}}}}} - -happyReduce_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_49 = happyReduce 7# 16# happyReduction_49 -happyReduction_49 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> - case happyOutTok happy_x_7 of { happy_var_7 -> - happyIn20 - (withSourceNote happy_var_2 happy_var_7 (doStore Nothing happy_var_1 happy_var_3 happy_var_6) - ) `HappyStk` happyRest}}}}} - -happyReduce_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_50 = happyMonadReduce 10# 16# happyReduction_50 -happyReduction_50 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> - case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> - case happyOut24 happy_x_4 of { (HappyWrap24 happy_var_4) -> - case happyOut43 happy_x_6 of { (HappyWrap43 happy_var_6) -> - case happyOut28 happy_x_8 of { (HappyWrap28 happy_var_8) -> - case happyOut25 happy_x_9 of { (HappyWrap25 happy_var_9) -> - ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}}) - ) (\r -> happyReturn (happyIn20 r)) - -happyReduce_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_51 = happyMonadReduce 8# 16# happyReduction_51 -happyReduction_51 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> - case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> - case happyOut46 happy_x_6 of { (HappyWrap46 happy_var_6) -> - ( primCall happy_var_1 happy_var_4 happy_var_6)}}}) - ) (\r -> happyReturn (happyIn20 r)) - -happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_52 = happyMonadReduce 5# 16# happyReduction_52 -happyReduction_52 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> - ( stmtMacro happy_var_1 happy_var_3)}}) - ) (\r -> happyReturn (happyIn20 r)) - -happyReduce_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_53 = happyReduce 7# 16# happyReduction_53 -happyReduction_53 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - case happyOut32 happy_x_5 of { (HappyWrap32 happy_var_5) -> - case happyOut36 happy_x_6 of { (HappyWrap36 happy_var_6) -> - happyIn20 - (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6 - ) `HappyStk` happyRest}}}} - -happyReduce_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_54 = happySpecReduce_3 16# happyReduction_54 -happyReduction_54 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn20 - (do l <- lookupLabel happy_var_2; emit (mkBranch l) - )} - -happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_55 = happyReduce 5# 16# happyReduction_55 -happyReduction_55 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> - happyIn20 - (doReturn happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_56 = happyReduce 4# 16# happyReduction_56 -happyReduction_56 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> - happyIn20 - (doRawJump happy_var_2 happy_var_3 - ) `HappyStk` happyRest}} - -happyReduce_57 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_57 = happyReduce 6# 16# happyReduction_57 -happyReduction_57 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - case happyOut46 happy_x_4 of { (HappyWrap46 happy_var_4) -> - happyIn20 - (doJumpWithStack happy_var_2 [] happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_58 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_58 = happyReduce 9# 16# happyReduction_58 -happyReduction_58 (happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - case happyOut46 happy_x_4 of { (HappyWrap46 happy_var_4) -> - case happyOut46 happy_x_7 of { (HappyWrap46 happy_var_7) -> - happyIn20 - (doJumpWithStack happy_var_2 happy_var_4 happy_var_7 - ) `HappyStk` happyRest}}} - -happyReduce_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_59 = happyReduce 6# 16# happyReduction_59 -happyReduction_59 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - case happyOut46 happy_x_4 of { (HappyWrap46 happy_var_4) -> - happyIn20 - (doCall happy_var_2 [] happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_60 = happyReduce 10# 16# happyReduction_60 -happyReduction_60 (happy_x_10 `HappyStk` - happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut56 happy_x_2 of { (HappyWrap56 happy_var_2) -> - case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> - case happyOut46 happy_x_8 of { (HappyWrap46 happy_var_8) -> - happyIn20 - (doCall happy_var_6 happy_var_2 happy_var_8 - ) `HappyStk` happyRest}}} - -happyReduce_61 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_61 = happyReduce 5# 16# happyReduction_61 -happyReduction_61 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> - happyIn20 - (do l <- lookupLabel happy_var_5; cmmRawIf happy_var_2 l happy_var_3 - ) `HappyStk` happyRest}}} - -happyReduce_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_62 = happyReduce 7# 16# happyReduction_62 -happyReduction_62 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut15 happy_x_5 of { (HappyWrap15 happy_var_5) -> - case happyOutTok happy_x_6 of { happy_var_6 -> - case happyOut37 happy_x_7 of { (HappyWrap37 happy_var_7) -> - happyIn20 - (cmmIfThenElse happy_var_2 (withSourceNote happy_var_4 happy_var_6 happy_var_5) happy_var_7 happy_var_3 - ) `HappyStk` happyRest}}}}}} - -happyReduce_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_63 = happyReduce 5# 16# happyReduction_63 -happyReduction_63 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> - case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> - happyIn20 - (pushStackFrame happy_var_3 happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_64 = happyReduce 5# 16# happyReduction_64 -happyReduction_64 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - case happyOut53 happy_x_4 of { (HappyWrap53 happy_var_4) -> - case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> - happyIn20 - (reserveStackFrame happy_var_2 happy_var_4 happy_var_5 - ) `HappyStk` happyRest}}} - -happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_65 = happySpecReduce_3 16# happyReduction_65 -happyReduction_65 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_2 of { (HappyWrap21 happy_var_2) -> - happyIn20 - (happy_var_2 >>= code . emitUnwind - )} - -happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_66 = happyReduce 5# 17# happyReduction_66 -happyReduction_66 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> - case happyOut21 happy_x_5 of { (HappyWrap21 happy_var_5) -> - happyIn21 - (do e <- happy_var_3; rest <- happy_var_5; return ((globalRegUseGlobalReg happy_var_1, e) : rest) - ) `HappyStk` happyRest}}} - -happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_67 = happySpecReduce_3 17# happyReduction_67 -happyReduction_67 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> - happyIn21 - (do e <- happy_var_3; return [(globalRegUseGlobalReg happy_var_1, e)] - )}} - -happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_68 = happySpecReduce_1 18# happyReduction_68 -happyReduction_68 happy_x_1 - = happyIn22 - (do return MemOrderRelaxed - ) - -happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_69 = happySpecReduce_1 18# happyReduction_69 -happyReduction_69 happy_x_1 - = happyIn22 - (do return MemOrderRelease - ) - -happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_70 = happySpecReduce_1 18# happyReduction_70 -happyReduction_70 happy_x_1 - = happyIn22 - (do return MemOrderAcquire - ) - -happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_71 = happySpecReduce_1 18# happyReduction_71 -happyReduction_71 happy_x_1 - = happyIn22 - (do return MemOrderSeqCst - ) - -happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_72 = happySpecReduce_1 19# happyReduction_72 -happyReduction_72 happy_x_1 - = happyIn23 - (do return Nothing - ) - -happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_73 = happySpecReduce_1 19# happyReduction_73 -happyReduction_73 happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - happyIn23 - (do e <- happy_var_1; return (Just e) - )} - -happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_74 = happySpecReduce_1 20# happyReduction_74 -happyReduction_74 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn24 - (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 Nothing ForeignLabelInThisPackage IsFunction))) - )} - -happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_75 = happySpecReduce_0 21# happyReduction_75 -happyReduction_75 = happyIn25 - (CmmMayReturn - ) - -happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_76 = happySpecReduce_2 21# happyReduction_76 -happyReduction_76 happy_x_2 - happy_x_1 - = happyIn25 - (CmmNeverReturns - ) - -happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_77 = happySpecReduce_1 22# happyReduction_77 -happyReduction_77 happy_x_1 - = case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> - happyIn26 - (happy_var_1 - )} - -happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_78 = happySpecReduce_1 22# happyReduction_78 -happyReduction_78 happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - happyIn26 - (do e <- happy_var_1; return (BoolTest e) - )} - -happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_79 = happySpecReduce_3 23# happyReduction_79 -happyReduction_79 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> - case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> - happyIn27 - (do e1 <- happy_var_1; e2 <- happy_var_3; - return (BoolAnd e1 e2) - )}} - -happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_80 = happySpecReduce_3 23# happyReduction_80 -happyReduction_80 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> - case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> - happyIn27 - (do e1 <- happy_var_1; e2 <- happy_var_3; - return (BoolOr e1 e2) - )}} - -happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_81 = happySpecReduce_2 23# happyReduction_81 -happyReduction_81 happy_x_2 - happy_x_1 - = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> - happyIn27 - (do e <- happy_var_2; return (BoolNot e) - )} - -happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_82 = happySpecReduce_3 23# happyReduction_82 -happyReduction_82 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut27 happy_x_2 of { (HappyWrap27 happy_var_2) -> - happyIn27 - (happy_var_2 - )} - -happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_83 = happySpecReduce_0 24# happyReduction_83 -happyReduction_83 = happyIn28 - (PlayRisky - ) - -happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_84 = happyMonadReduce 1# 24# happyReduction_84 -happyReduction_84 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - ( parseSafety happy_var_1)}) - ) (\r -> happyReturn (happyIn28 r)) - -happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_85 = happySpecReduce_2 25# happyReduction_85 -happyReduction_85 happy_x_2 - happy_x_1 - = happyIn29 - ([] - ) - -happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_86 = happyMonadReduce 3# 25# happyReduction_86 -happyReduction_86 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( do platform <- PD.getPlatform - ; return (realArgRegsCover platform))) - ) (\r -> happyReturn (happyIn29 r)) - -happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_87 = happySpecReduce_3 25# happyReduction_87 -happyReduction_87 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut30 happy_x_2 of { (HappyWrap30 happy_var_2) -> - happyIn29 - (map globalRegUseGlobalReg happy_var_2 - )} - -happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_88 = happySpecReduce_1 26# happyReduction_88 -happyReduction_88 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn30 - ([happy_var_1] - )} - -happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_89 = happySpecReduce_3 26# happyReduction_89 -happyReduction_89 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> - happyIn30 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_90 = happyReduce 5# 27# happyReduction_90 -happyReduction_90 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> - case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> - happyIn31 - (Just (happy_var_2, happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_91 = happySpecReduce_0 27# happyReduction_91 -happyReduction_91 = happyIn31 - (Nothing - ) - -happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_92 = happySpecReduce_0 28# happyReduction_92 -happyReduction_92 = happyIn32 - ([] - ) - -happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_93 = happySpecReduce_2 28# happyReduction_93 -happyReduction_93 happy_x_2 - happy_x_1 - = case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> - case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> - happyIn32 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_94 = happyReduce 4# 29# happyReduction_94 -happyReduction_94 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut35 happy_x_2 of { (HappyWrap35 happy_var_2) -> - case happyOut34 happy_x_4 of { (HappyWrap34 happy_var_4) -> - happyIn33 - (do b <- happy_var_4; return (happy_var_2, b) - ) `HappyStk` happyRest}} - -happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_95 = happySpecReduce_3 30# happyReduction_95 -happyReduction_95 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn34 - (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2)) - )}}} - -happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_96 = happySpecReduce_3 30# happyReduction_96 -happyReduction_96 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn34 - (do l <- lookupLabel happy_var_2; return (Left l) - )} - -happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_97 = happySpecReduce_1 31# happyReduction_97 -happyReduction_97 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - happyIn35 - ([ happy_var_1 ] - )} - -happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_98 = happySpecReduce_3 31# happyReduction_98 -happyReduction_98 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut35 happy_x_3 of { (HappyWrap35 happy_var_3) -> - happyIn35 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_99 = happyReduce 5# 32# happyReduction_99 -happyReduction_99 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut15 happy_x_4 of { (HappyWrap15 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn36 - (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4) - ) `HappyStk` happyRest}}} - -happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_100 = happySpecReduce_0 32# happyReduction_100 -happyReduction_100 = happyIn36 - (Nothing - ) - -happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_101 = happySpecReduce_0 33# happyReduction_101 -happyReduction_101 = happyIn37 - (return () - ) - -happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_102 = happyReduce 4# 33# happyReduction_102 -happyReduction_102 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut15 happy_x_3 of { (HappyWrap15 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn37 - (withSourceNote happy_var_2 happy_var_4 happy_var_3 - ) `HappyStk` happyRest}}} - -happyReduce_103 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_103 = happyReduce 5# 34# happyReduction_103 -happyReduction_103 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = happyIn38 - (Just True - ) `HappyStk` happyRest - -happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_104 = happyReduce 5# 34# happyReduction_104 -happyReduction_104 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = happyIn38 - (Just False - ) `HappyStk` happyRest - -happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_105 = happySpecReduce_0 34# happyReduction_105 -happyReduction_105 = happyIn38 - (Nothing - ) - -happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_106 = happySpecReduce_3 35# happyReduction_106 -happyReduction_106 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] - )}} - -happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_107 = happySpecReduce_3 35# happyReduction_107 -happyReduction_107 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Mul [happy_var_1,happy_var_3] - )}} - -happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_108 = happySpecReduce_3 35# happyReduction_108 -happyReduction_108 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] - )}} - -happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_109 = happySpecReduce_3 35# happyReduction_109 -happyReduction_109 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Sub [happy_var_1,happy_var_3] - )}} - -happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_110 = happySpecReduce_3 35# happyReduction_110 -happyReduction_110 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Add [happy_var_1,happy_var_3] - )}} - -happyReduce_111 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_111 = happySpecReduce_3 35# happyReduction_111 -happyReduction_111 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] - )}} - -happyReduce_112 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_112 = happySpecReduce_3 35# happyReduction_112 -happyReduction_112 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Shl [happy_var_1,happy_var_3] - )}} - -happyReduce_113 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_113 = happySpecReduce_3 35# happyReduction_113 -happyReduction_113 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_And [happy_var_1,happy_var_3] - )}} - -happyReduce_114 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_114 = happySpecReduce_3 35# happyReduction_114 -happyReduction_114 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Xor [happy_var_1,happy_var_3] - )}} - -happyReduce_115 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_115 = happySpecReduce_3 35# happyReduction_115 -happyReduction_115 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Or [happy_var_1,happy_var_3] - )}} - -happyReduce_116 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_116 = happySpecReduce_3 35# happyReduction_116 -happyReduction_116 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] - )}} - -happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_117 = happySpecReduce_3 35# happyReduction_117 -happyReduction_117 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] - )}} - -happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_118 = happySpecReduce_3 35# happyReduction_118 -happyReduction_118 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Le [happy_var_1,happy_var_3] - )}} - -happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_119 = happySpecReduce_3 35# happyReduction_119 -happyReduction_119 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] - )}} - -happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_120 = happySpecReduce_3 35# happyReduction_120 -happyReduction_120 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Ne [happy_var_1,happy_var_3] - )}} - -happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_121 = happySpecReduce_3 35# happyReduction_121 -happyReduction_121 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn39 - (mkMachOp MO_Eq [happy_var_1,happy_var_3] - )}} - -happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_122 = happySpecReduce_2 35# happyReduction_122 -happyReduction_122 happy_x_2 - happy_x_1 - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - happyIn39 - (mkMachOp MO_Not [happy_var_2] - )} - -happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_123 = happySpecReduce_2 35# happyReduction_123 -happyReduction_123 happy_x_2 - happy_x_1 - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - happyIn39 - (mkMachOp MO_S_Neg [happy_var_2] - )} - -happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_124 = happyMonadReduce 5# 35# happyReduction_124 -happyReduction_124 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> - case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut40 happy_x_5 of { (HappyWrap40 happy_var_5) -> - ( do { mo <- nameToMachOp happy_var_3 ; - return (mkMachOp mo [happy_var_1,happy_var_5]) })}}}) - ) (\r -> happyReturn (happyIn39 r)) - -happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_125 = happySpecReduce_1 35# happyReduction_125 -happyReduction_125 happy_x_1 - = case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> - happyIn39 - (happy_var_1 - )} - -happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_126 = happySpecReduce_2 36# happyReduction_126 -happyReduction_126 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut42 happy_x_2 of { (HappyWrap42 happy_var_2) -> - happyIn40 - (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) - )}} - -happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_127 = happySpecReduce_2 36# happyReduction_127 -happyReduction_127 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> - case happyOut42 happy_x_2 of { (HappyWrap42 happy_var_2) -> - happyIn40 - (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) - )}} - -happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_128 = happySpecReduce_1 36# happyReduction_128 -happyReduction_128 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - happyIn40 - (do s <- code (newStringCLit happy_var_1); - return (CmmLit s) - )} - -happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_129 = happySpecReduce_1 36# happyReduction_129 -happyReduction_129 happy_x_1 - = case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> - happyIn40 - (happy_var_1 - )} - -happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_130 = happySpecReduce_2 36# happyReduction_130 -happyReduction_130 happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> - case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> - happyIn40 - (do (align, ptr) <- happy_var_2; return (CmmLoad ptr happy_var_1 align) - )}} - -happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_131 = happyMonadReduce 5# 36# happyReduction_131 -happyReduction_131 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - case happyOut46 happy_x_4 of { (HappyWrap46 happy_var_4) -> - ( exprOp happy_var_2 happy_var_4)}}) - ) (\r -> happyReturn (happyIn40 r)) - -happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_132 = happySpecReduce_3 36# happyReduction_132 -happyReduction_132 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - happyIn40 - (happy_var_2 - )} - -happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_133 = happyReduce 4# 37# happyReduction_133 -happyReduction_133 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> - happyIn41 - (do ptr <- happy_var_3; return (Unaligned, ptr) - ) `HappyStk` happyRest} - -happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_134 = happySpecReduce_3 37# happyReduction_134 -happyReduction_134 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> - happyIn41 - (do ptr <- happy_var_2; return (NaturallyAligned, ptr) - )} - -happyReduce_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_135 = happyMonadReduce 0# 38# happyReduction_135 -happyReduction_135 (happyRest) tk - = happyThen ((( do platform <- PD.getPlatform; return $ bWord platform)) - ) (\r -> happyReturn (happyIn42 r)) - -happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_136 = happySpecReduce_2 38# happyReduction_136 -happyReduction_136 happy_x_2 - happy_x_1 - = case happyOut58 happy_x_2 of { (HappyWrap58 happy_var_2) -> - happyIn42 - (happy_var_2 - )} - -happyReduce_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_137 = happySpecReduce_0 39# happyReduction_137 -happyReduction_137 = happyIn43 - ([] - ) - -happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_138 = happySpecReduce_1 39# happyReduction_138 -happyReduction_138 happy_x_1 - = case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> - happyIn43 - (happy_var_1 - )} - -happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_139 = happySpecReduce_1 40# happyReduction_139 -happyReduction_139 happy_x_1 - = case happyOut45 happy_x_1 of { (HappyWrap45 happy_var_1) -> - happyIn44 - ([happy_var_1] - )} - -happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_140 = happySpecReduce_3 40# happyReduction_140 -happyReduction_140 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut45 happy_x_1 of { (HappyWrap45 happy_var_1) -> - case happyOut44 happy_x_3 of { (HappyWrap44 happy_var_3) -> - happyIn44 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_141 = happySpecReduce_1 41# happyReduction_141 -happyReduction_141 happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - happyIn45 - (do e <- happy_var_1; - return (e, inferCmmHint e) - )} - -happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_142 = happyMonadReduce 2# 41# happyReduction_142 -happyReduction_142 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> - ( do h <- parseCmmHint happy_var_2; - return $ do - e <- happy_var_1; return (e, h))}}) - ) (\r -> happyReturn (happyIn45 r)) - -happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_143 = happySpecReduce_0 42# happyReduction_143 -happyReduction_143 = happyIn46 - ([] - ) - -happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_144 = happySpecReduce_1 42# happyReduction_144 -happyReduction_144 happy_x_1 - = case happyOut47 happy_x_1 of { (HappyWrap47 happy_var_1) -> - happyIn46 - (happy_var_1 - )} - -happyReduce_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_145 = happySpecReduce_1 43# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - happyIn47 - ([ happy_var_1 ] - )} - -happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_146 = happySpecReduce_3 43# happyReduction_146 -happyReduction_146 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> - case happyOut47 happy_x_3 of { (HappyWrap47 happy_var_3) -> - happyIn47 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_147 = happySpecReduce_1 44# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn48 - (lookupName happy_var_1 - )} - -happyReduce_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_148 = happySpecReduce_1 44# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn48 - (return (CmmReg (CmmGlobal happy_var_1)) - )} - -happyReduce_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_149 = happySpecReduce_0 45# happyReduction_149 -happyReduction_149 = happyIn49 - ([] - ) - -happyReduce_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_150 = happyReduce 4# 45# happyReduction_150 -happyReduction_150 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut50 happy_x_2 of { (HappyWrap50 happy_var_2) -> - happyIn49 - (happy_var_2 - ) `HappyStk` happyRest} - -happyReduce_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_151 = happySpecReduce_1 46# happyReduction_151 -happyReduction_151 happy_x_1 - = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> - happyIn50 - ([happy_var_1] - )} - -happyReduce_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_152 = happySpecReduce_2 46# happyReduction_152 -happyReduction_152 happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> - happyIn50 - ([happy_var_1] - )} - -happyReduce_153 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_153 = happySpecReduce_3 46# happyReduction_153 -happyReduction_153 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> - case happyOut50 happy_x_3 of { (HappyWrap50 happy_var_3) -> - happyIn50 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_154 = happySpecReduce_1 47# happyReduction_154 -happyReduction_154 happy_x_1 - = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> - happyIn51 - (do e <- happy_var_1; return (e, inferCmmHint (CmmReg (CmmLocal e))) - )} - -happyReduce_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_155 = happyMonadReduce 2# 47# happyReduction_155 -happyReduction_155 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - case happyOut52 happy_x_2 of { (HappyWrap52 happy_var_2) -> - ( do h <- parseCmmHint happy_var_1; - return $ do - e <- happy_var_2; return (e,h))}}) - ) (\r -> happyReturn (happyIn51 r)) - -happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_156 = happySpecReduce_1 48# happyReduction_156 -happyReduction_156 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn52 - (do e <- lookupName happy_var_1; - return $ - case e of - CmmReg (CmmLocal r) -> r - other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") - )} - -happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_157 = happySpecReduce_1 49# happyReduction_157 -happyReduction_157 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn53 - (do e <- lookupName happy_var_1; - return $ - case e of - CmmReg r -> r - other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") - )} - -happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_158 = happySpecReduce_1 49# happyReduction_158 -happyReduction_158 happy_x_1 - = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn53 - (return (CmmGlobal happy_var_1) - )} - -happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_159 = happySpecReduce_0 50# happyReduction_159 -happyReduction_159 = happyIn54 - (Nothing - ) - -happyReduce_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_160 = happySpecReduce_3 50# happyReduction_160 -happyReduction_160 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut55 happy_x_2 of { (HappyWrap55 happy_var_2) -> - happyIn54 - (Just happy_var_2 - )} - -happyReduce_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_161 = happySpecReduce_0 51# happyReduction_161 -happyReduction_161 = happyIn55 - ([] - ) - -happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_162 = happySpecReduce_1 51# happyReduction_162 -happyReduction_162 happy_x_1 - = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> - happyIn55 - (happy_var_1 - )} - -happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_163 = happySpecReduce_2 52# happyReduction_163 -happyReduction_163 happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> - happyIn56 - ([happy_var_1] - )} - -happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_164 = happySpecReduce_1 52# happyReduction_164 -happyReduction_164 happy_x_1 - = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> - happyIn56 - ([happy_var_1] - )} - -happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_165 = happySpecReduce_3 52# happyReduction_165 -happyReduction_165 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> - case happyOut56 happy_x_3 of { (HappyWrap56 happy_var_3) -> - happyIn56 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_166 = happySpecReduce_2 53# happyReduction_166 -happyReduction_166 happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> - case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn57 - (newLocal happy_var_1 happy_var_2 - )}} - -happyReduce_167 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_167 = happySpecReduce_1 54# happyReduction_167 -happyReduction_167 happy_x_1 - = happyIn58 - (b8 - ) - -happyReduce_168 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_168 = happySpecReduce_1 54# happyReduction_168 -happyReduction_168 happy_x_1 - = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> - happyIn58 - (happy_var_1 - )} - -happyReduce_169 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_169 = happySpecReduce_1 55# happyReduction_169 -happyReduction_169 happy_x_1 - = happyIn59 - (b16 - ) - -happyReduce_170 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_170 = happySpecReduce_1 55# happyReduction_170 -happyReduction_170 happy_x_1 - = happyIn59 - (b32 - ) - -happyReduce_171 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_171 = happySpecReduce_1 55# happyReduction_171 -happyReduction_171 happy_x_1 - = happyIn59 - (b64 - ) - -happyReduce_172 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_172 = happySpecReduce_1 55# happyReduction_172 -happyReduction_172 happy_x_1 - = happyIn59 - (b128 - ) - -happyReduce_173 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_173 = happySpecReduce_1 55# happyReduction_173 -happyReduction_173 happy_x_1 - = happyIn59 - (b256 - ) - -happyReduce_174 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_174 = happySpecReduce_1 55# happyReduction_174 -happyReduction_174 happy_x_1 - = happyIn59 - (b512 - ) - -happyReduce_175 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_175 = happySpecReduce_1 55# happyReduction_175 -happyReduction_175 happy_x_1 - = happyIn59 - (f32 - ) - -happyReduce_176 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_176 = happySpecReduce_1 55# happyReduction_176 -happyReduction_176 happy_x_1 - = happyIn59 - (f64 - ) - -happyReduce_177 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) -happyReduce_177 = happyMonadReduce 1# 55# happyReduction_177 -happyReduction_177 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( do platform <- PD.getPlatform; return $ gcWord platform)) - ) (\r -> happyReturn (happyIn59 r)) - -happyNewToken action sts stk - = cmmlex(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - L _ CmmT_EOF -> happyDoAction 81# tk action sts stk; - L _ (CmmT_SpecChar ':') -> cont 1#; - L _ (CmmT_SpecChar ';') -> cont 2#; - L _ (CmmT_SpecChar '{') -> cont 3#; - L _ (CmmT_SpecChar '}') -> cont 4#; - L _ (CmmT_SpecChar '[') -> cont 5#; - L _ (CmmT_SpecChar ']') -> cont 6#; - L _ (CmmT_SpecChar '(') -> cont 7#; - L _ (CmmT_SpecChar ')') -> cont 8#; - L _ (CmmT_SpecChar '=') -> cont 9#; - L _ (CmmT_SpecChar '`') -> cont 10#; - L _ (CmmT_SpecChar '~') -> cont 11#; - L _ (CmmT_SpecChar '/') -> cont 12#; - L _ (CmmT_SpecChar '*') -> cont 13#; - L _ (CmmT_SpecChar '%') -> cont 14#; - L _ (CmmT_SpecChar '-') -> cont 15#; - L _ (CmmT_SpecChar '+') -> cont 16#; - L _ (CmmT_SpecChar '&') -> cont 17#; - L _ (CmmT_SpecChar '^') -> cont 18#; - L _ (CmmT_SpecChar '|') -> cont 19#; - L _ (CmmT_SpecChar '>') -> cont 20#; - L _ (CmmT_SpecChar '<') -> cont 21#; - L _ (CmmT_SpecChar ',') -> cont 22#; - L _ (CmmT_SpecChar '!') -> cont 23#; - L _ (CmmT_DotDot) -> cont 24#; - L _ (CmmT_DoubleColon) -> cont 25#; - L _ (CmmT_Shr) -> cont 26#; - L _ (CmmT_Shl) -> cont 27#; - L _ (CmmT_Ge) -> cont 28#; - L _ (CmmT_Le) -> cont 29#; - L _ (CmmT_Eq) -> cont 30#; - L _ (CmmT_Ne) -> cont 31#; - L _ (CmmT_BoolAnd) -> cont 32#; - L _ (CmmT_BoolOr) -> cont 33#; - L _ (CmmT_True ) -> cont 34#; - L _ (CmmT_False) -> cont 35#; - L _ (CmmT_likely) -> cont 36#; - L _ (CmmT_Relaxed) -> cont 37#; - L _ (CmmT_Acquire) -> cont 38#; - L _ (CmmT_Release) -> cont 39#; - L _ (CmmT_SeqCst) -> cont 40#; - L _ (CmmT_CLOSURE) -> cont 41#; - L _ (CmmT_INFO_TABLE) -> cont 42#; - L _ (CmmT_INFO_TABLE_RET) -> cont 43#; - L _ (CmmT_INFO_TABLE_FUN) -> cont 44#; - L _ (CmmT_INFO_TABLE_CONSTR) -> cont 45#; - L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 46#; - L _ (CmmT_else) -> cont 47#; - L _ (CmmT_export) -> cont 48#; - L _ (CmmT_section) -> cont 49#; - L _ (CmmT_goto) -> cont 50#; - L _ (CmmT_if) -> cont 51#; - L _ (CmmT_call) -> cont 52#; - L _ (CmmT_jump) -> cont 53#; - L _ (CmmT_foreign) -> cont 54#; - L _ (CmmT_never) -> cont 55#; - L _ (CmmT_prim) -> cont 56#; - L _ (CmmT_reserve) -> cont 57#; - L _ (CmmT_return) -> cont 58#; - L _ (CmmT_returns) -> cont 59#; - L _ (CmmT_import) -> cont 60#; - L _ (CmmT_switch) -> cont 61#; - L _ (CmmT_case) -> cont 62#; - L _ (CmmT_default) -> cont 63#; - L _ (CmmT_push) -> cont 64#; - L _ (CmmT_unwind) -> cont 65#; - L _ (CmmT_bits8) -> cont 66#; - L _ (CmmT_bits16) -> cont 67#; - L _ (CmmT_bits32) -> cont 68#; - L _ (CmmT_bits64) -> cont 69#; - L _ (CmmT_bits128) -> cont 70#; - L _ (CmmT_bits256) -> cont 71#; - L _ (CmmT_bits512) -> cont 72#; - L _ (CmmT_float32) -> cont 73#; - L _ (CmmT_float64) -> cont 74#; - L _ (CmmT_gcptr) -> cont 75#; - L _ (CmmT_GlobalReg happy_dollar_dollar) -> cont 76#; - L _ (CmmT_Name happy_dollar_dollar) -> cont 77#; - L _ (CmmT_String happy_dollar_dollar) -> cont 78#; - L _ (CmmT_Int happy_dollar_dollar) -> cont 79#; - L _ (CmmT_Float happy_dollar_dollar) -> cont 80#; - _ -> happyError' (tk, []) - }) - -happyError_ explist 81# tk = happyError' (tk, explist) -happyError_ explist _ tk = happyError' (tk, explist) - -happyThen :: () => PD a -> (a -> PD b) -> PD b -happyThen = (>>=) -happyReturn :: () => a -> PD a -happyReturn = (return) -happyParse :: () => Happy_GHC_Exts.Int# -> PD (HappyAbsSyn ) - -happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) - -happyDoAction :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) - -happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )) - -happyThen1 :: () => PD a -> (a -> PD b) -> PD b -happyThen1 = happyThen -happyReturn1 :: () => a -> PD a -happyReturn1 = happyReturn -happyError' :: () => ((Located CmmToken), [Prelude.String]) -> PD a -happyError' tk = (\(tokens, explist) -> happyError) tk -cmmParse = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap4 x') = happyOut4 x} in x')) - -happySeq = happyDoSeq - - -section :: String -> SectionType -section "text" = Text -section "data" = Data -section "rodata" = ReadOnlyData -section "relrodata" = RelocatableReadOnlyData -section "bss" = UninitialisedData -section s = OtherSection s - -mkString :: String -> CmmStatic -mkString s = CmmString (BS8.pack s) - --- mkMachOp infers the type of the MachOp from the type of its first --- argument. We assume that this is correct: for MachOps that don't have --- symmetrical args (e.g. shift ops), the first arg determines the type of --- the op. -mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr -mkMachOp fn args = do - platform <- getPlatform - arg_exprs <- sequence args - return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs) - -getLit :: CmmExpr -> CmmLit -getLit (CmmLit l) = l -getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r -getLit _ = panic "invalid literal" -- TODO messy failure - -nameToMachOp :: FastString -> PD (Width -> MachOp) -nameToMachOp name = - case lookupUFM machOps name of - Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) - Just m -> return m - -exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) -exprOp name args_code = do - pdc <- PD.getPDConfig - let profile = PD.pdProfile pdc - let align_check = PD.pdSanitizeAlignment pdc - case lookupUFM (exprMacros profile align_check) name of - Just f -> return $ do - args <- sequence args_code - return (f args) - Nothing -> do - mo <- nameToMachOp name - return $ mkMachOp mo args_code - -exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr) -exprMacros profile align_check = listToUFM [ - ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), - ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr platform align_check x ), - ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), - ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ), - ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr platform align_check x) ), - ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr platform align_check x) ), - ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ), - ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ), - ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ), - ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x ) - ] - where - platform = profilePlatform profile - --- we understand a subset of C-- primitives: -machOps :: UniqFM FastString (Width -> MachOp) -machOps = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - ( "add", MO_Add ), - ( "sub", MO_Sub ), - ( "eq", MO_Eq ), - ( "ne", MO_Ne ), - ( "mul", MO_Mul ), - ( "mulmayoflo", MO_S_MulMayOflo ), - ( "neg", MO_S_Neg ), - ( "quot", MO_S_Quot ), - ( "rem", MO_S_Rem ), - ( "divu", MO_U_Quot ), - ( "modu", MO_U_Rem ), - - ( "ge", MO_S_Ge ), - ( "le", MO_S_Le ), - ( "gt", MO_S_Gt ), - ( "lt", MO_S_Lt ), - - ( "geu", MO_U_Ge ), - ( "leu", MO_U_Le ), - ( "gtu", MO_U_Gt ), - ( "ltu", MO_U_Lt ), - - ( "and", MO_And ), - ( "or", MO_Or ), - ( "xor", MO_Xor ), - ( "com", MO_Not ), - ( "shl", MO_Shl ), - ( "shrl", MO_U_Shr ), - ( "shra", MO_S_Shr ), - - ( "fadd", MO_F_Add ), - ( "fsub", MO_F_Sub ), - ( "fneg", MO_F_Neg ), - ( "fmul", MO_F_Mul ), - ( "fquot", MO_F_Quot ), - - ( "fmadd" , MO_FMA FMAdd ), - ( "fmsub" , MO_FMA FMSub ), - ( "fnmadd", MO_FMA FNMAdd ), - ( "fnmsub", MO_FMA FNMSub ), - - ( "feq", MO_F_Eq ), - ( "fne", MO_F_Ne ), - ( "fge", MO_F_Ge ), - ( "fle", MO_F_Le ), - ( "fgt", MO_F_Gt ), - ( "flt", MO_F_Lt ), - - ( "lobits8", flip MO_UU_Conv W8 ), - ( "lobits16", flip MO_UU_Conv W16 ), - ( "lobits32", flip MO_UU_Conv W32 ), - ( "lobits64", flip MO_UU_Conv W64 ), - - ( "zx16", flip MO_UU_Conv W16 ), - ( "zx32", flip MO_UU_Conv W32 ), - ( "zx64", flip MO_UU_Conv W64 ), - - ( "sx16", flip MO_SS_Conv W16 ), - ( "sx32", flip MO_SS_Conv W32 ), - ( "sx64", flip MO_SS_Conv W64 ), - - ( "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 ) - ] - -callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr])) -callishMachOps platform = listToUFM $ - map (\(x, y) -> (mkFastString x, y)) [ - - ( "pow64f", (MO_F64_Pwr,) ), - ( "sin64f", (MO_F64_Sin,) ), - ( "cos64f", (MO_F64_Cos,) ), - ( "tan64f", (MO_F64_Tan,) ), - ( "sinh64f", (MO_F64_Sinh,) ), - ( "cosh64f", (MO_F64_Cosh,) ), - ( "tanh64f", (MO_F64_Tanh,) ), - ( "asin64f", (MO_F64_Asin,) ), - ( "acos64f", (MO_F64_Acos,) ), - ( "atan64f", (MO_F64_Atan,) ), - ( "asinh64f", (MO_F64_Asinh,) ), - ( "acosh64f", (MO_F64_Acosh,) ), - ( "log64f", (MO_F64_Log,) ), - ( "log1p64f", (MO_F64_Log1P,) ), - ( "exp64f", (MO_F64_Exp,) ), - ( "expM164f", (MO_F64_ExpM1,) ), - ( "fabs64f", (MO_F64_Fabs,) ), - ( "sqrt64f", (MO_F64_Sqrt,) ), - - ( "pow32f", (MO_F32_Pwr,) ), - ( "sin32f", (MO_F32_Sin,) ), - ( "cos32f", (MO_F32_Cos,) ), - ( "tan32f", (MO_F32_Tan,) ), - ( "sinh32f", (MO_F32_Sinh,) ), - ( "cosh32f", (MO_F32_Cosh,) ), - ( "tanh32f", (MO_F32_Tanh,) ), - ( "asin32f", (MO_F32_Asin,) ), - ( "acos32f", (MO_F32_Acos,) ), - ( "atan32f", (MO_F32_Atan,) ), - ( "asinh32f", (MO_F32_Asinh,) ), - ( "acosh32f", (MO_F32_Acosh,) ), - ( "log32f", (MO_F32_Log,) ), - ( "log1p32f", (MO_F32_Log1P,) ), - ( "exp32f", (MO_F32_Exp,) ), - ( "expM132f", (MO_F32_ExpM1,) ), - ( "fabs32f", (MO_F32_Fabs,) ), - ( "sqrt32f", (MO_F32_Sqrt,) ), - - ( "read_barrier", (MO_ReadBarrier,)), - ( "write_barrier", (MO_WriteBarrier,)), - ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), - ( "memset", memcpyLikeTweakArgs MO_Memset ), - ( "memmove", memcpyLikeTweakArgs MO_Memmove ), - ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), - - ( "suspendThread", (MO_SuspendThread,) ), - ( "resumeThread", (MO_ResumeThread,) ), - - ( "prefetch0", (MO_Prefetch_Data 0,)), - ( "prefetch1", (MO_Prefetch_Data 1,)), - ( "prefetch2", (MO_Prefetch_Data 2,)), - ( "prefetch3", (MO_Prefetch_Data 3,)) - ] ++ concat - [ allWidths "popcnt" MO_PopCnt - , allWidths "pdep" MO_Pdep - , allWidths "pext" MO_Pext - , allWidths "cmpxchg" MO_Cmpxchg - , allWidths "xchg" MO_Xchg - , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderAcquire) - , allWidths "load_acquire" (\w -> MO_AtomicRead w MemOrderAcquire) - , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst) - , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease) - , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst) - , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add) - , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub) - , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And) - , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand) - , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or) - , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor) - ] - where - allWidths - :: String - -> (Width -> CallishMachOp) - -> [(FastString, a -> (CallishMachOp, a))] - allWidths name f = - [ (mkFastString $ name ++ show (widthInBits w), (f w,)) - | w <- [W8, W16, W32, W64] - ] - - memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) - memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" - memcpyLikeTweakArgs op args@(_:_) = - (op align, args') - where - args' = init args - align = case last args of - CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger - e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e) - -- The alignment of memcpy-ish operations must be a - -- compile-time constant. We verify this here, passing it around - -- in the MO_* constructor. In order to do this, however, we - -- must intercept the arguments in primCall. - -parseSafety :: String -> PD Safety -parseSafety "safe" = return PlaySafe -parseSafety "unsafe" = return PlayRisky -parseSafety "interruptible" = return PlayInterruptible -parseSafety str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ - PsErrCmmParser (CmmUnrecognisedSafety str) - -parseCmmHint :: String -> PD ForeignHint -parseCmmHint "ptr" = return AddrHint -parseCmmHint "signed" = return SignedHint -parseCmmHint str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ - PsErrCmmParser (CmmUnrecognisedHint str) - --- labels are always pointers, so we might as well infer the hint -inferCmmHint :: CmmExpr -> ForeignHint -inferCmmHint (CmmLit (CmmLabel _)) - = AddrHint -inferCmmHint (CmmReg (CmmGlobal reg)) - | isPtrGlobalRegUse reg - = AddrHint -inferCmmHint _ - = NoHint - -isPtrGlobalRegUse :: GlobalRegUse -> Bool -isPtrGlobalRegUse (GlobalRegUse reg ty) - | VanillaReg {} <- reg - , isGcPtrType ty - = True - | otherwise - = go reg - where - go Sp = True - go SpLim = True - go Hp = True - go HpLim = True - go CCCS = True - go CurrentTSO = True - go CurrentNursery = True - go _ = False - -happyError :: PD a -happyError = PD $ \_ _ s -> unP srcParseFail s - --- ----------------------------------------------------------------------------- --- Statement-level macros - -stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) -stmtMacro fun args_code = do - case lookupUFM stmtMacros fun of - Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun) - Just fcode -> return $ do - args <- sequence args_code - code (fcode args) - -stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ()) -stmtMacros = listToUFM [ - ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), - ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), - - ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), - ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), - - -- completely generic heap and stack checks, for use in high-level cmm. - ( fsLit "HP_CHK_GEN", \[bytes] -> - heapStackCheckGen Nothing (Just bytes) ), - ( fsLit "STK_CHK_GEN", \[] -> - heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), - - -- A stack check for a fixed amount of stack. Sounds a bit strange, but - -- we use the stack for a bit of temporary storage in a couple of primops - ( fsLit "STK_CHK_GEN_N", \[bytes] -> - heapStackCheckGen (Just bytes) Nothing ), - - -- A stack check on entry to a thunk, where the argument is the thunk pointer. - ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), - - ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), - ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), - - ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ), - ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ), - - ( fsLit "PUSH_ARG_REGS", \[live_regs] -> emitPushArgRegs live_regs ), - ( fsLit "POP_ARG_REGS", \[live_regs] -> emitPopArgRegs live_regs ), - - ( fsLit "LDV_ENTER", \[e] -> ldvEnter e ), - ( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ), - - ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), - ( fsLit "SET_HDR", \[ptr,info,ccs] -> - emitSetDynHdr ptr info ccs ), - ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> - tickyAllocPrim hdr goods slop ), - ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> - tickyAllocPAP goods slop ), - ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> - tickyAllocThunk goods slop ), - ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) - ] - -emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () -emitPushUpdateFrame sp e = do - emitUpdateFrame sp mkUpdInfoLabel e - -pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () -pushStackFrame fields body = do - profile <- getProfile - exprs <- sequence fields - updfr_off <- getUpdFrameOff - let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old - [] updfr_off exprs - emit g - withUpdFrameOff new_updfr_off body - -reserveStackFrame - :: CmmParse CmmExpr - -> CmmParse CmmReg - -> CmmParse () - -> CmmParse () -reserveStackFrame psize preg body = do - platform <- getPlatform - old_updfr_off <- getUpdFrameOff - reg <- preg - esize <- psize - let size = case constantFoldExpr platform esize of - CmmLit (CmmInt n _) -> n - _other -> pprPanic "CmmParse: not a compile-time integer: " - (pdoc platform esize) - let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size - emitAssign reg (CmmStackSlot Old frame) - withUpdFrameOff frame body - -profilingInfo profile desc_str ty_str - = if not (profileIsProfiling profile) - then NoProfilingInfo - else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) - -staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () -staticClosure pkg cl_label info payload - = do profile <- getProfile - let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] [] - code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits - -foreignCall - :: String - -> [CmmParse (LocalReg, ForeignHint)] - -> CmmParse CmmExpr - -> [CmmParse (CmmExpr, ForeignHint)] - -> Safety - -> CmmReturnInfo - -> PD (CmmParse ()) -foreignCall conv_string results_code expr_code args_code safety ret - = do conv <- case conv_string of - "C" -> return CCallConv - "stdcall" -> return StdCallConv - _ -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ - PsErrCmmParser (CmmUnknownCConv conv_string) - return $ do - platform <- getPlatform - results <- sequence results_code - 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 - _ <- code $ emitForeignCall safety res_regs target arg_exprs - return () - - -doReturn :: [CmmParse CmmExpr] -> CmmParse () -doReturn exprs_code = do - profile <- getProfile - exprs <- sequence exprs_code - updfr_off <- getUpdFrameOff - emit (mkReturnSimple profile exprs updfr_off) - -mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph -mkReturnSimple profile actuals updfr_off = - mkReturn profile e actuals updfr_off - where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off)) - platform = profilePlatform profile - -doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () -doRawJump expr_code vols = do - profile <- getProfile - expr <- expr_code - updfr_off <- getUpdFrameOff - emit (mkRawJump profile expr updfr_off vols) - -doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] - -> [CmmParse CmmExpr] -> CmmParse () -doJumpWithStack expr_code stk_code args_code = do - profile <- getProfile - expr <- expr_code - stk_args <- sequence stk_code - args <- sequence args_code - updfr_off <- getUpdFrameOff - emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args) - -doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] - -> CmmParse () -doCall expr_code res_code args_code = do - expr <- expr_code - args <- sequence args_code - ress <- sequence res_code - updfr_off <- getUpdFrameOff - 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 - -> [CmmParse CmmExpr] - -> PD (CmmParse ()) -primCall results_code name args_code - = do - platform <- PD.getPlatform - case lookupUFM (callishMachOps platform) name of - Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) - Just f -> return $ do - results <- sequence results_code - args <- sequence args_code - let (p, args') = f args - code (emitPrimCall (map fst results) p args') - -doStore :: Maybe MemoryOrdering - -> CmmType - -> CmmParse CmmExpr -- ^ address - -> CmmParse CmmExpr -- ^ value - -> CmmParse () -doStore mem_ord rep addr_code val_code - = do platform <- getPlatform - addr <- addr_code - val <- val_code - -- if the specified store type does not match the type of the expr - -- on the rhs, then we insert a coercion that will cause the type - -- mismatch to be flagged by cmm-lint. If we don't do this, then - -- the store will happen at the wrong type, and the error will not - -- be noticed. - let val_width = typeWidth (cmmExprType platform val) - rep_width = typeWidth rep - let coerce_val - | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] - | otherwise = val - emitStore mem_ord addr coerce_val - --- ----------------------------------------------------------------------------- --- If-then-else and boolean expressions - -data BoolExpr - = BoolExpr `BoolAnd` BoolExpr - | BoolExpr `BoolOr` BoolExpr - | BoolNot BoolExpr - | BoolTest CmmExpr - --- ToDo: smart constructors which simplify the boolean expression. - -cmmIfThenElse cond then_part else_part likely = do - then_id <- newBlockId - join_id <- newBlockId - c <- cond - emitCond c then_id likely - else_part - emit (mkBranch join_id) - emitLabel then_id - then_part - -- fall through to join - emitLabel join_id - -cmmRawIf cond then_id likely = do - c <- cond - emitCond c then_id likely - --- 'emitCond cond true_id' emits code to test whether the cond is true, --- branching to true_id if so, and falling through otherwise. -emitCond (BoolTest e) then_id likely = do - else_id <- newBlockId - emit (mkCbranch e then_id else_id likely) - emitLabel else_id -emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely - | Just op' <- maybeInvertComparison op - = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely) -emitCond (BoolNot e) then_id likely = do - else_id <- newBlockId - emitCond e else_id likely - emit (mkBranch then_id) - emitLabel else_id -emitCond (e1 `BoolOr` e2) then_id likely = do - emitCond e1 then_id likely - emitCond e2 then_id likely -emitCond (e1 `BoolAnd` e2) then_id likely = do - -- we'd like to invert one of the conditionals here to avoid an - -- extra branch instruction, but we can't use maybeInvertComparison - -- here because we can't look too closely at the expression since - -- we're in a loop. - and_id <- newBlockId - else_id <- newBlockId - emitCond e1 and_id likely - emit (mkBranch else_id) - emitLabel and_id - emitCond e2 then_id likely - emitLabel else_id - --- ----------------------------------------------------------------------------- --- Source code notes - --- | Generate a source note spanning from "a" to "b" (inclusive), then --- proceed with parsing. This allows debugging tools to reason about --- locations in Cmm code. -withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c -withSourceNote a b parse = do - name <- getName - case combineSrcSpans (getLoc a) (getLoc b) of - RealSrcSpan span _ -> code (emitTick (SourceNote span $ LexicalFastString $ mkFastString name)) >> parse - _other -> parse - --- ----------------------------------------------------------------------------- --- Table jumps - --- We use a simplified form of C-- switch statements for now. A --- switch statement always compiles to a table jump. Each arm can --- specify a list of values (not ranges), and there can be a single --- default branch. The range of the table is given either by the --- optional range on the switch (eg. switch [0..7] {...}), or by --- the minimum/maximum values from the branches. - -doSwitch :: Maybe (Integer,Integer) - -> CmmParse CmmExpr - -> [([Integer],Either BlockId (CmmParse ()))] - -> Maybe (CmmParse ()) -> CmmParse () -doSwitch mb_range scrut arms deflt - = do - -- Compile code for the default branch - dflt_entry <- - case deflt of - Nothing -> return Nothing - Just e -> do b <- forkLabelledCode e; return (Just b) - - -- Compile each case branch - table_entries <- mapM emitArm arms - let table = M.fromList (concat table_entries) - - platform <- getPlatform - let range = fromMaybe (0, platformMaxWord platform) mb_range - - expr <- scrut - -- ToDo: check for out of range and jump to default if necessary - emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) - where - emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] - emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] - emitArm (ints,Right code) = do - blockid <- forkLabelledCode code - return [ (i,blockid) | i <- ints ] - -forkLabelledCode :: CmmParse () -> CmmParse BlockId -forkLabelledCode p = do - (_,ag) <- getCodeScoped p - l <- newBlockId - emitOutOfLine l ag - return l - --- ----------------------------------------------------------------------------- --- Putting it all together - --- The initial environment: we define some constants that the compiler --- knows about here. -initEnv :: Profile -> Env -initEnv profile = listToUFM [ - ( fsLit "SIZEOF_StgHeader", - VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )), - ( fsLit "SIZEOF_StgInfoTable", - VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) )) - ] - where platform = profilePlatform profile - -parseCmmFile :: CmmParserConfig - -> Module - -> HomeUnit - -> FilePath - -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt])) -parseCmmFile cmmpConfig this_mod home_unit filename = do - buf <- hGetStringBuffer filename - let - init_loc = mkRealSrcLoc (mkFastString filename) 1 1 - init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] } - -- reset the lex_state: the Lexer monad leaves some stuff - -- in there we don't want. - pdConfig = cmmpPDConfig cmmpConfig - case unPD cmmParse pdConfig home_unit init_state of - PFailed pst -> do - let (warnings,errors) = getPsMessages pst - return (warnings, errors, Nothing) - POk pst code -> do - st <- initC - let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig) - let fcode = do - ((), 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) - | otherwise = [] - where - do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig - ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info +import GHC.Cmm.Reg ( GlobalArgRegs(..) ) +import GHC.Cmm.Utils +import GHC.Cmm.Switch ( mkSwitchTargets ) +import GHC.Cmm.Info +import GHC.Cmm.BlockId +import GHC.Cmm.Lexer +import GHC.Cmm.CLabel +import GHC.Cmm.Parser.Config +import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) +import qualified GHC.Cmm.Parser.Monad as PD +import GHC.Cmm.CallConv +import GHC.Runtime.Heap.Layout +import GHC.Parser.Lexer +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 +import GHC.Unit.Home +import GHC.Types.Literal +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.SrcLoc +import GHC.Types.Tickish ( GenTickish(SourceNote) ) +import GHC.Utils.Error +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Settings.Constants +import GHC.Utils.Outputable +import GHC.Types.Basic +import GHC.Data.Bag ( Bag, emptyBag, unitBag, isEmptyBag ) +import GHC.Types.Var + +import Control.Monad +import Data.Array +import Data.Char ( ord ) +import System.Exit +import Data.Maybe +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.20.1.1 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +newtype HappyWrap4 = HappyWrap4 (CmmParse ()) +happyIn4 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap4 x) +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn ) -> HappyWrap4 +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +newtype HappyWrap5 = HappyWrap5 (CmmParse ()) +happyIn5 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap5 x) +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn ) -> HappyWrap5 +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +newtype HappyWrap6 = HappyWrap6 (CmmParse ()) +happyIn6 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap6 x) +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn ) -> HappyWrap6 +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +newtype HappyWrap7 = HappyWrap7 (CmmParse CLabel) +happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn ) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap7 x) +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn ) -> HappyWrap7 +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +newtype HappyWrap8 = HappyWrap8 ([CmmParse [CmmStatic]]) +happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn ) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap8 x) +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn ) -> HappyWrap8 +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +newtype HappyWrap9 = HappyWrap9 (CmmParse [CmmStatic]) +happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn ) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap9 x) +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn ) -> HappyWrap9 +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +newtype HappyWrap10 = HappyWrap10 ([CmmParse CmmExpr]) +happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap10 x) +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn ) -> HappyWrap10 +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +newtype HappyWrap11 = HappyWrap11 (CmmParse ()) +happyIn11 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap11 x) +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn ) -> HappyWrap11 +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +newtype HappyWrap12 = HappyWrap12 (Convention) +happyIn12 :: (Convention) -> (HappyAbsSyn ) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap12 x) +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn ) -> HappyWrap12 +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +newtype HappyWrap13 = HappyWrap13 (CmmParse ()) +happyIn13 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap13 x) +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn ) -> HappyWrap13 +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +newtype HappyWrap14 = HappyWrap14 (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) +happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn ) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap14 x) +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn ) -> HappyWrap14 +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +newtype HappyWrap15 = HappyWrap15 (CmmParse ()) +happyIn15 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap15 x) +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn ) -> HappyWrap15 +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +newtype HappyWrap16 = HappyWrap16 (CmmParse ()) +happyIn16 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +newtype HappyWrap17 = HappyWrap17 ([(FastString, CLabel)]) +happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +newtype HappyWrap18 = HappyWrap18 ((FastString, CLabel)) +happyIn18 :: ((FastString, CLabel)) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +newtype HappyWrap19 = HappyWrap19 ([FastString]) +happyIn19 :: ([FastString]) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +newtype HappyWrap20 = HappyWrap20 (CmmParse ()) +happyIn20 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +newtype HappyWrap21 = HappyWrap21 (CmmParse [(GlobalReg, Maybe CmmExpr)]) +happyIn21 :: (CmmParse [(GlobalReg, Maybe CmmExpr)]) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +newtype HappyWrap22 = HappyWrap22 (CmmParse MemoryOrdering) +happyIn22 :: (CmmParse MemoryOrdering) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +newtype HappyWrap23 = HappyWrap23 (CmmParse (Maybe CmmExpr)) +happyIn23 :: (CmmParse (Maybe CmmExpr)) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +newtype HappyWrap24 = HappyWrap24 (CmmParse CmmExpr) +happyIn24 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +newtype HappyWrap25 = HappyWrap25 (CmmReturnInfo) +happyIn25 :: (CmmReturnInfo) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +newtype HappyWrap26 = HappyWrap26 (CmmParse BoolExpr) +happyIn26 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +newtype HappyWrap27 = HappyWrap27 (CmmParse BoolExpr) +happyIn27 :: (CmmParse BoolExpr) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +newtype HappyWrap28 = HappyWrap28 (Safety) +happyIn28 :: (Safety) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +newtype HappyWrap29 = HappyWrap29 ([GlobalRegUse]) +happyIn29 :: ([GlobalRegUse]) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +newtype HappyWrap30 = HappyWrap30 ([GlobalRegUse]) +happyIn30 :: ([GlobalRegUse]) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +newtype HappyWrap31 = HappyWrap31 (Maybe (Integer,Integer)) +happyIn31 :: (Maybe (Integer,Integer)) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +newtype HappyWrap32 = HappyWrap32 ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) +happyIn32 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +newtype HappyWrap33 = HappyWrap33 (CmmParse ([Integer],Either BlockId (CmmParse ()))) +happyIn33 :: (CmmParse ([Integer],Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +newtype HappyWrap34 = HappyWrap34 (CmmParse (Either BlockId (CmmParse ()))) +happyIn34 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +newtype HappyWrap35 = HappyWrap35 ([Integer]) +happyIn35 :: ([Integer]) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +newtype HappyWrap36 = HappyWrap36 (Maybe (CmmParse ())) +happyIn36 :: (Maybe (CmmParse ())) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +newtype HappyWrap37 = HappyWrap37 (CmmParse ()) +happyIn37 :: (CmmParse ()) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +newtype HappyWrap38 = HappyWrap38 (Maybe Bool) +happyIn38 :: (Maybe Bool) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +newtype HappyWrap39 = HappyWrap39 (CmmParse CmmExpr) +happyIn39 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +newtype HappyWrap40 = HappyWrap40 (CmmParse CmmExpr) +happyIn40 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +newtype HappyWrap41 = HappyWrap41 (CmmType) +happyIn41 :: (CmmType) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +newtype HappyWrap42 = HappyWrap42 ([CmmParse (CmmExpr, ForeignHint)]) +happyIn42 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +newtype HappyWrap43 = HappyWrap43 ([CmmParse (CmmExpr, ForeignHint)]) +happyIn43 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +newtype HappyWrap44 = HappyWrap44 (CmmParse (CmmExpr, ForeignHint)) +happyIn44 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +newtype HappyWrap45 = HappyWrap45 ([CmmParse CmmExpr]) +happyIn45 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +newtype HappyWrap46 = HappyWrap46 ([CmmParse CmmExpr]) +happyIn46 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +newtype HappyWrap47 = HappyWrap47 (CmmParse CmmExpr) +happyIn47 :: (CmmParse CmmExpr) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +newtype HappyWrap48 = HappyWrap48 ([CmmParse (LocalReg, ForeignHint)]) +happyIn48 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +newtype HappyWrap49 = HappyWrap49 ([CmmParse (LocalReg, ForeignHint)]) +happyIn49 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +newtype HappyWrap50 = HappyWrap50 (CmmParse (LocalReg, ForeignHint)) +happyIn50 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +newtype HappyWrap51 = HappyWrap51 (CmmParse LocalReg) +happyIn51 :: (CmmParse LocalReg) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +newtype HappyWrap52 = HappyWrap52 (CmmParse CmmReg) +happyIn52 :: (CmmParse CmmReg) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +newtype HappyWrap53 = HappyWrap53 (Maybe [CmmParse LocalReg]) +happyIn53 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +newtype HappyWrap54 = HappyWrap54 ([CmmParse LocalReg]) +happyIn54 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +newtype HappyWrap55 = HappyWrap55 ([CmmParse LocalReg]) +happyIn55 :: ([CmmParse LocalReg]) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +newtype HappyWrap56 = HappyWrap56 (CmmParse LocalReg) +happyIn56 :: (CmmParse LocalReg) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +newtype HappyWrap57 = HappyWrap57 (CmmType) +happyIn57 :: (CmmType) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +newtype HappyWrap58 = HappyWrap58 (CmmType) +happyIn58 :: (CmmType) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyExpList :: HappyAddr +happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x06\x20\xf8\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x06\x20\xf8\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\xc0\x03\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x08\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x0f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x07\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_cmmParse","cmm","cmmtop","cmmdata","data_label","statics","static","lits","cmmproc","maybe_conv","maybe_body","info","body","decl","importNames","importName","names","stmt","unwind_regs","mem_ordering","expr_or_unknown","foreignLabel","opt_never_returns","bool_expr","bool_op","safety","vols","globals","maybe_range","arms","arm","arm_body","ints","default","else","cond_likely","expr","expr0","maybe_ty","cmm_hint_exprs0","cmm_hint_exprs","cmm_hint_expr","exprs0","exprs","reg","foreign_results","foreign_formals","foreign_formal","local_lreg","lreg","maybe_formals","formals0","formals","formal","type","typenot8","':'","';'","'{'","'}'","'['","']'","'('","')'","'='","'`'","'~'","'/'","'*'","'%'","'-'","'+'","'&'","'^'","'|'","'>'","'<'","','","'!'","'..'","'::'","'>>'","'<<'","'>='","'<='","'=='","'!='","'&&'","'||'","'True'","'False'","'likely'","'relaxed'","'acquire'","'release'","'seq_cst'","'CLOSURE'","'INFO_TABLE'","'INFO_TABLE_RET'","'INFO_TABLE_FUN'","'INFO_TABLE_CONSTR'","'INFO_TABLE_SELECTOR'","'else'","'export'","'section'","'goto'","'if'","'call'","'jump'","'foreign'","'never'","'prim'","'reserve'","'return'","'returns'","'import'","'switch'","'case'","'default'","'push'","'unwind'","'bits8'","'bits16'","'bits32'","'bits64'","'vec128'","'vec256'","'vec512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","GP_ARG_REGS","SCALAR_ARG_REGS","V16_ARG_REGS","V32_ARG_REGS","V64_ARG_REGS","%eof"] + bit_start = st Prelude.* 144 + bit_end = (st Prelude.+ 1) Prelude.* 144 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..143] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x72\x01\x00\x00\xae\xff\x72\x01\x00\x00\x00\x00\xec\xff\x00\x00\xe7\xff\x00\x00\x3c\x00\x40\x00\x4c\x00\x4f\x00\x64\x00\x73\x00\x31\x00\x33\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xa8\x00\x57\x00\x00\x00\x74\x00\xd3\x00\xd8\x00\xed\x00\xd1\x00\xdb\x00\xdd\x00\xdf\x00\xe4\x00\xe6\x00\x37\x01\x34\x01\x00\x00\x00\x00\xa9\x00\xe6\x04\x00\x00\x39\x01\x3d\x01\x43\x01\x45\x01\x48\x01\x4c\x01\x19\x01\x00\x00\x1d\x01\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x95\x01\x6c\x01\x00\x00\x24\x01\x26\x01\x2d\x01\x31\x01\x33\x01\x40\x01\x69\x01\x00\x00\x74\x01\x46\x01\x00\x00\x00\x00\x50\x00\x93\x01\x50\x00\x50\x00\xe6\x04\x47\x00\x8f\x01\xfd\xff\x00\x00\xd9\x04\x00\x00\x00\x00\x00\x00\x00\x00\x54\x01\xa2\x00\xb1\x00\xb1\x00\xb1\x00\xa3\x01\xa6\x01\xa5\x01\x61\x01\x00\x00\x3f\x00\x00\x00\xe6\x04\x00\x00\x99\x01\x9b\x01\x44\x00\xb1\x01\xb8\x01\xb9\x01\x00\x00\xd2\x01\x95\x01\x1a\x00\xe0\x01\xdf\x01\xe2\x01\x0c\x00\x9e\x01\x9f\x01\x1a\x02\xde\x01\x00\x00\x10\x00\x00\x00\xb1\x00\xb1\x00\xa2\x01\xb1\x00\x00\x00\x00\x00\x00\x00\xd1\x01\xd1\x01\x00\x00\x00\x00\xa7\x01\xa8\x01\xae\x01\x00\x00\xe6\x04\xaf\x01\xed\x01\xb1\x00\x00\x00\x00\x00\xb1\x00\xf0\x01\xf6\x01\xb1\x00\xb1\x00\xb7\x01\xb1\x00\x67\x03\xfc\xff\x1f\x03\x38\x00\x00\x00\xa3\x03\xa2\x00\xa2\x00\xfe\x01\xff\x01\xf4\x01\x00\x00\x07\x02\x00\x00\xc9\x01\xb1\x00\x80\x00\xca\x01\x09\x02\x18\x02\x00\x00\x00\x00\x00\x00\xb1\x00\xd4\x01\xd5\x01\xe6\x04\x2e\x02\x84\x02\x00\x00\x15\x02\x65\x00\x1c\x02\x00\x00\x00\x00\x8e\x00\x29\x02\x50\x03\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x03\x00\x0e\x02\xa2\x00\xa2\x00\xb1\x00\x31\x02\xff\xff\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x7b\x03\x3d\x02\x00\x00\x2f\x02\x6a\x02\x3e\x02\xca\x00\x00\x00\x51\x02\x8f\x03\x58\x02\x45\x02\x64\x02\x6b\x02\x6c\x02\x6d\x02\x00\x00\xe6\x04\x00\x00\x12\x00\x67\x02\x00\x00\x50\x03\xb1\x00\x7b\x02\x95\x02\x22\x02\x00\x00\x96\x02\x85\x02\x4f\x02\x9f\x02\xa4\x02\xa5\x02\xa0\x02\xa7\x02\xaa\x02\xb1\x00\xb1\x00\x9e\x02\x00\x00\xb1\x00\x00\x00\x68\x02\x66\x02\x70\x02\x00\x00\x71\x02\x00\x00\x00\x00\xb5\x02\xab\x02\xa3\x03\x00\x00\xdc\x00\x90\x02\x73\x02\xc1\x02\xb1\x00\xdc\x00\x00\x00\xc7\x02\xca\x02\x00\x00\xbb\x02\x00\x00\xd1\x02\xc2\x00\xba\x02\xda\x02\x50\x00\x8f\x02\xb7\x03\xb7\x03\xb7\x03\xb7\x03\x6b\x01\x6b\x01\xb7\x03\xb7\x03\x61\x00\x98\x01\xb6\x01\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x02\xdf\x02\x00\x00\xe4\x02\xe3\x02\x00\x00\xed\x02\xb8\x02\xe2\x02\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xef\x02\xe3\x00\xf3\x02\xb6\x02\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\xf0\x02\xc4\x02\xb9\x02\xbe\x02\x00\x00\xc2\x02\x00\x00\xee\x02\xf9\x02\xfa\x02\xfb\x02\xfd\x02\x00\x00\xd2\x02\xec\x02\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x02\xcf\x02\xd9\x02\xdb\x02\x00\x00\x1c\x03\x09\x03\x00\x00\x24\x03\x29\x03\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x2d\x03\x2e\x03\x08\x03\x38\x03\x42\x02\x06\x03\x1e\x00\x30\x03\x00\x00\x2a\x03\x39\x03\xb1\x00\x56\x02\x40\x03\xb1\x00\xf5\x02\x00\x00\x4c\x03\x00\x00\xb1\x00\x00\x00\x4d\x03\x00\x00\x00\x00\x47\x03\x4e\x03\x00\x00\x0a\x03\x04\x00\x44\x03\x45\x03\x51\x03\x5e\x03\x00\x00\x1a\x03\x1b\x03\x23\x03\x00\x00\x50\x00\x25\x03\x00\x00\x50\x00\x7c\x03\x50\x00\x75\x03\x00\x00\x48\x03\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x57\x03\x91\x03\x90\x03\x00\x00\xa2\x03\xa5\x03\xa4\x03\xb1\x03\xa6\x03\xb8\x03\x6c\x03\x80\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x03\xb3\x03\x00\x00\x81\x03\xc5\x03\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x1b\x01\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\xda\x03\x00\x00\xdc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x03\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x03\x00\x00\x00\x00\xe5\x03\x97\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x03\x00\x00\xf3\x03\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x22\x01\x2a\x01\xee\x00\x00\x00\x00\x00\xea\x03\x00\x00\x05\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x7f\x00\x1c\x04\x25\x04\x00\x00\xe6\x03\x00\x00\xef\x03\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x2b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x04\x34\x04\x00\x00\x3a\x04\x00\x00\x00\x00\x00\x00\xde\x03\xdf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x02\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\xea\x01\x00\x00\x00\x00\xba\x03\x49\x04\x00\x00\xbd\x03\x00\x00\xec\x03\x00\x00\xee\x03\x00\x00\x00\x00\xcd\x01\xd6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x03\x4e\x04\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x04\x00\x00\xf9\x03\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x04\x63\x04\x66\x04\x6c\x04\x72\x04\x7b\x04\x80\x04\x89\x04\x8f\x04\x95\x04\x98\x04\x9e\x04\xa4\x04\xad\x04\xb2\x04\xbb\x04\x00\x00\x00\x00\xe5\x01\xee\x01\xd1\x03\x00\x00\xfd\x03\xd4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x12\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x04\xca\x04\x00\x00\x00\x00\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x04\x13\x01\x00\x00\x00\x00\x17\x04\x16\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x03\xb4\x03\xd0\x04\xd6\x04\xdf\x04\x00\x00\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x62\x01\x06\x04\x00\x00\x15\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x04\x00\x00\x00\x00\x08\x04\x0f\x04\x00\x00\x00\x00\x00\x00\x0e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x04\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x01\x00\x00\x00\x00\x5c\x01\x00\x00\x64\x01\x00\x00\x00\x00\x21\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# +happyAdjustOffset off = off + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x53\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\xff\x52\xff\x51\xff\x50\xff\x4f\xff\x4e\xff\x4d\xff\x4c\xff\x4b\xff\x4a\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xff\xea\xff\xfd\xff\x00\x00\x5a\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\xff\x57\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\xbb\xff\xb9\xff\xba\xff\xb8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xff\x00\x00\x00\x00\x5d\xff\x5e\xff\x55\xff\x58\xff\x5b\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x53\xff\x00\x00\x54\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7e\xff\x7a\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x67\xff\x68\xff\x7b\xff\x74\xff\x74\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x5a\xff\x00\x00\x00\x00\x00\x00\x56\xff\xd2\xff\x6c\xff\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x00\x00\x92\xff\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x64\xff\x61\xff\x00\x00\x5f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xff\x00\x00\x63\xff\x00\x00\xc9\xff\xae\xff\x00\x00\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x6c\xff\xa9\xff\xa8\xff\xa7\xff\xa6\xff\xa5\xff\x00\x00\x6a\xff\x00\x00\x6b\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\xff\x00\x00\x7d\xff\x80\xff\x00\x00\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\xff\x6c\xff\x73\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbc\xff\xb6\xff\xb7\xff\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x00\x00\xaa\xff\xa3\xff\xc7\xff\x00\x00\xaf\xff\xb0\xff\x00\x00\xe0\xff\x00\x00\x83\xff\x82\xff\x85\xff\x87\xff\x8b\xff\x8c\xff\x84\xff\x86\xff\x88\xff\x89\xff\x8a\xff\x8d\xff\x8e\xff\x8f\xff\x90\xff\x91\xff\xad\xff\x65\xff\x62\xff\x00\x00\x00\x00\xd1\xff\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\x00\x00\x6c\xff\x72\xff\x00\x00\x00\x00\x00\x00\xc2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\xbf\xff\x69\xff\xc8\xff\x00\x00\x97\xff\x9f\xff\x00\x00\xc0\xff\x00\x00\xcb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x7f\xff\x79\xff\x78\xff\x76\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xff\x00\x00\x9a\xff\x9e\xff\x00\x00\x00\x00\xa1\xff\xc6\xff\x6c\xff\xa2\xff\xc4\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x6e\xff\x00\x00\x71\xff\x70\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\x6d\xff\x00\x00\xce\xff\x6c\xff\xc1\xff\x00\x00\x93\xff\x94\xff\x00\x00\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x9d\xff\xe0\xff\x00\x00\x99\xff\xe0\xff\x00\x00\xe0\xff\x00\x00\xd0\xff\xb4\xff\xab\xff\x6f\xff\xcc\xff\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x9c\xff\x9b\xff\x98\xff\x95\xff\xc3\xff\xb3\xff\xcd\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\xe5\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x07\x00\x56\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x06\x00\x04\x00\x05\x00\x05\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x02\x00\x29\x00\x0c\x00\x0d\x00\x0e\x00\x07\x00\x12\x00\x04\x00\x05\x00\x0b\x00\x3a\x00\x17\x00\x0e\x00\x0f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4d\x00\x32\x00\x32\x00\x24\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x2b\x00\x07\x00\x01\x00\x4d\x00\x4e\x00\x07\x00\x35\x00\x36\x00\x07\x00\x07\x00\x35\x00\x36\x00\x4d\x00\x4c\x00\x08\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x02\x00\x07\x00\x35\x00\x36\x00\x07\x00\x07\x00\x20\x00\x21\x00\x16\x00\x4f\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x02\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x07\x00\x1a\x00\x1b\x00\x36\x00\x4d\x00\x38\x00\x30\x00\x4e\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x07\x00\x38\x00\x39\x00\x3a\x00\x0b\x00\x3c\x00\x3d\x00\x0e\x00\x0f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x33\x00\x34\x00\x35\x00\x36\x00\x23\x00\x24\x00\x4d\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x2b\x00\x02\x00\x03\x00\x0b\x00\x20\x00\x21\x00\x0e\x00\x0f\x00\x4d\x00\x4e\x00\x35\x00\x36\x00\x0b\x00\x0c\x00\x07\x00\x17\x00\x02\x00\x10\x00\x0b\x00\x12\x00\x16\x00\x0e\x00\x0f\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x2d\x00\x2e\x00\x2f\x00\x0b\x00\x03\x00\x2c\x00\x0e\x00\x0f\x00\x02\x00\x30\x00\x4c\x00\x4d\x00\x02\x00\x03\x00\x35\x00\x36\x00\x20\x00\x21\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x16\x00\x3a\x00\x22\x00\x23\x00\x0d\x00\x0e\x00\x0e\x00\x0d\x00\x0e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x00\x00\x01\x00\x02\x00\x4d\x00\x00\x00\x01\x00\x02\x00\x07\x00\x35\x00\x36\x00\x0a\x00\x07\x00\x0c\x00\x4d\x00\x0a\x00\x4d\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x1c\x00\x1d\x00\x4d\x00\x10\x00\x4d\x00\x12\x00\x0b\x00\x0c\x00\x35\x00\x36\x00\x02\x00\x10\x00\x07\x00\x12\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x35\x00\x36\x00\x2c\x00\x16\x00\x35\x00\x36\x00\x30\x00\x16\x00\x35\x00\x36\x00\x2c\x00\x35\x00\x36\x00\x16\x00\x30\x00\x16\x00\x0b\x00\x0c\x00\x16\x00\x35\x00\x36\x00\x10\x00\x16\x00\x12\x00\x0b\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x10\x00\x4d\x00\x12\x00\x10\x00\x01\x00\x12\x00\x0b\x00\x0c\x00\x08\x00\x12\x00\x4f\x00\x10\x00\x4f\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x4f\x00\x2c\x00\x1c\x00\x1d\x00\x4f\x00\x30\x00\x4f\x00\x23\x00\x24\x00\x2c\x00\x35\x00\x36\x00\x2c\x00\x30\x00\x16\x00\x2b\x00\x30\x00\x4d\x00\x35\x00\x36\x00\x2c\x00\x35\x00\x36\x00\x4d\x00\x30\x00\x35\x00\x36\x00\x04\x00\x09\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x4d\x00\x30\x00\x31\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x05\x00\x07\x00\x4c\x00\x3c\x00\x16\x00\x13\x00\x16\x00\x1a\x00\x1b\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x29\x00\x4d\x00\x23\x00\x24\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x16\x00\x2b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x35\x00\x36\x00\x16\x00\x17\x00\x04\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x23\x00\x24\x00\x16\x00\x17\x00\x05\x00\x07\x00\x05\x00\x0a\x00\x2b\x00\x19\x00\x4d\x00\x16\x00\x17\x00\x4f\x00\x4d\x00\x23\x00\x24\x00\x02\x00\x35\x00\x36\x00\x08\x00\x4f\x00\x4f\x00\x2b\x00\x23\x00\x24\x00\x16\x00\x17\x00\x4f\x00\x4f\x00\x09\x00\x02\x00\x2b\x00\x35\x00\x36\x00\x16\x00\x17\x00\x4f\x00\x08\x00\x23\x00\x24\x00\x16\x00\x35\x00\x36\x00\x23\x00\x24\x00\x08\x00\x2b\x00\x23\x00\x24\x00\x29\x00\x2a\x00\x2b\x00\x4d\x00\x0e\x00\x4e\x00\x2b\x00\x35\x00\x36\x00\x02\x00\x05\x00\x09\x00\x35\x00\x36\x00\x4d\x00\x4d\x00\x35\x00\x36\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x24\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x08\x00\x18\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x03\x00\x07\x00\x4d\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x06\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x06\x00\x02\x00\x02\x00\x08\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x0a\x00\x4f\x00\x4e\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4f\x00\x4f\x00\x16\x00\x4f\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3e\x00\x08\x00\x06\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x08\x00\x20\x00\x01\x00\x4d\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x05\x00\x07\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x04\x00\x07\x00\x02\x00\x06\x00\x3e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4c\x00\x3f\x00\x16\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4f\x00\x4c\x00\x16\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4e\x00\x01\x00\x4f\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x4e\x00\x04\x00\x4e\x00\x01\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x08\x00\x2f\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x08\x00\x02\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x03\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x4f\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x16\x00\x4e\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x4e\x00\x4d\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x37\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x3b\x00\x02\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x04\x00\x02\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x4e\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x16\x00\x4f\x00\x4f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x24\x00\x16\x00\x26\x00\x27\x00\x28\x00\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\x08\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x35\x00\x36\x00\x0f\x00\x0f\x00\x31\x00\x09\x00\x35\x00\x36\x00\x0f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x03\x00\x23\x00\x24\x00\x0f\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x11\x00\x1b\x00\x06\x00\x25\x00\x25\x00\x19\x00\x35\x00\x36\x00\x2f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x14\x00\x23\x00\x24\x00\x22\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x1a\x00\x06\x00\x30\x00\x06\x00\x1a\x00\x09\x00\x35\x00\x36\x00\x09\x00\x35\x00\x36\x00\x23\x00\x24\x00\x20\x00\x1f\x00\x11\x00\x18\x00\x29\x00\x2a\x00\x2b\x00\x23\x00\x24\x00\x21\x00\x1e\x00\x27\x00\x28\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\x15\x00\x29\x00\x2a\x00\x2b\x00\x23\x00\x24\x00\x1f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x2a\x00\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\x4d\x00\x4e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\xda\x00\xad\x00\xdb\x00\xff\xff\x21\x01\x28\x01\xa2\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x00\x01\x73\x00\x74\x00\xf9\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x81\x00\x21\x00\xc4\x00\xc5\x00\xc6\x00\x82\x00\xfa\x00\x8a\x00\x74\x00\x83\x00\x2f\x00\xfb\x00\x84\x00\x85\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x26\x00\x29\x01\xa3\x01\x68\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x7e\x00\xd5\x00\x96\x00\x22\x00\x23\x00\x2c\x00\x75\x00\x76\x00\x97\x00\x2b\x00\x7f\x00\x09\x00\x26\x00\x22\x01\x90\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\x59\x00\x2a\x00\x75\x00\x76\x00\x29\x00\x5a\x00\xd6\x00\xd7\x00\x91\x00\x01\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x28\x00\x8c\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x78\x01\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x79\x01\x27\x00\xce\x00\xcf\x00\xaf\x00\x26\x00\xb0\x00\x11\x00\x24\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x66\xff\x82\x00\x66\xff\x63\x00\x64\x00\x83\x00\x13\x00\x65\x00\x84\x00\x85\x00\x66\x00\x67\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x68\x00\x69\x00\x94\x00\x4c\x00\x4d\x00\x09\x00\x9f\x00\x7d\x00\x3e\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa4\x00\x7e\x00\x50\x00\x51\x00\x83\x00\xd6\x00\xd7\x00\x84\x00\x85\x00\xab\x00\xac\x00\x7f\x00\x09\x00\x51\x00\x52\x00\x82\x00\xa5\x00\x40\x00\x53\x00\x83\x00\x54\x00\x3f\x00\x84\x00\x85\x00\x3d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x3b\x01\xa7\x00\xa8\x00\x83\x00\x3c\x00\x55\x00\x84\x00\x85\x00\x3b\x00\x56\x00\x68\x00\x1e\x01\x50\x00\x51\x00\x57\x00\x09\x00\xd6\x00\xd7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x3a\x00\x17\x01\x7c\x01\x7d\x01\x1e\x00\x1f\x00\x84\x00\x40\x00\x1f\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x02\x00\x03\x00\x04\x00\x39\x00\x2f\x00\x03\x00\x04\x00\x05\x00\xb0\x00\x09\x00\x06\x00\x05\x00\x07\x00\x38\x00\x06\x00\x37\x00\x07\x00\x36\x00\xb2\x00\x52\x00\x55\x01\x56\x01\x35\x00\x53\x00\x34\x00\x54\x00\xb1\x00\x52\x00\x3f\x01\x09\x00\x33\x00\x53\x00\x32\x00\x54\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x0b\x01\x09\x00\x55\x00\x4a\x00\x08\x00\x09\x00\x56\x00\x49\x00\x08\x00\x09\x00\x55\x00\x57\x00\x09\x00\x48\x00\x56\x00\x47\x00\x4b\x01\x52\x00\x46\x00\x57\x00\x09\x00\x53\x00\x45\x00\x54\x00\xb5\x01\x52\x00\x26\x00\xb3\x01\x52\x00\x53\x00\x43\x00\x54\x00\x53\x00\x73\x00\x54\x00\xb1\x01\x52\x00\x6c\x00\xb7\x00\x72\x00\x53\x00\x71\x00\x54\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x70\x00\x55\x00\x73\x01\x56\x01\x6f\x00\x56\x00\x6e\x00\xb8\x00\x7d\x00\x55\x00\x57\x00\x09\x00\x55\x00\x56\x00\x6b\x00\x7e\x00\x56\x00\x6d\x00\x57\x00\x09\x00\x55\x00\x57\x00\x09\x00\x6a\x00\x56\x00\x7f\x00\x09\x00\xb4\x00\xae\x00\x57\x00\x09\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\xa6\x00\x11\x00\x12\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\x9d\x00\x9c\x00\x9a\x00\x99\x00\x13\x00\x94\x00\x14\x01\x92\x00\xce\x00\xcf\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x78\x00\x1e\x00\x15\x01\x7d\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x8f\x00\x7e\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x8e\x00\x8d\x00\xce\x00\xcf\x00\x7f\x00\x09\x00\xa0\x00\xa1\x00\x8c\x00\x79\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa2\x00\x7d\x00\xc0\x00\xc1\x00\x7c\x00\x7b\x00\x7a\x00\xfc\x00\x7e\x00\xf3\x00\xff\x00\xbf\x00\xa1\x00\xfe\x00\xf6\x00\xc2\x00\x7d\x00\xe9\x00\x7f\x00\x09\x00\xec\x00\xf1\x00\xf0\x00\x7e\x00\xa2\x00\x7d\x00\x25\x01\xa1\x00\xef\x00\xed\x00\xe8\x00\xbf\x00\x7e\x00\x7f\x00\x09\x00\x24\x01\xa1\x00\xe5\x00\xbe\x00\xa2\x00\x7d\x00\xbd\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\xbc\x00\x7e\x00\xa2\x00\x7d\x00\xe9\x00\xe3\x00\x7e\x00\xab\x00\xb6\x00\xb7\x00\x7e\x00\x7f\x00\x09\x00\xfd\x00\xb5\x00\x3d\x01\x7f\x00\x09\x00\x43\x01\x42\x01\x7f\x00\x09\x00\x3b\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x3f\x01\x3a\x01\x27\x01\x23\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x8e\x01\x1b\x01\x18\x01\x1a\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xae\x01\x14\x01\x12\x01\x11\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x10\x01\x19\x01\x0b\x01\x06\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x08\x01\x0f\x01\x0e\x01\x0d\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x3e\x01\xed\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x07\x01\x94\x00\x05\x01\x03\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x61\x01\x02\x01\x68\x01\x67\x01\x66\x01\x65\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x64\x01\x5e\x01\x5f\x01\x5b\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x45\x01\x5d\x01\x5c\x01\x5a\x01\x55\x01\x54\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x58\x01\x51\x01\x50\x01\x4f\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x6b\x01\x4e\x01\xd6\x00\x4d\x01\x4b\x01\x4a\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x49\x01\x48\x01\x47\x01\x87\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x6a\x01\x7e\x01\x46\x01\x7b\x01\x77\x01\x58\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x22\x01\x76\x01\x70\x01\x6c\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x8d\x01\x73\x01\x99\x00\x6f\x01\x6e\x01\x6d\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x9c\x01\x98\x01\x9b\x01\x97\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd8\x00\x9a\x01\x96\x01\x99\x01\x95\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x93\x01\x92\x01\x91\x01\x8b\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x8f\x01\x8a\x01\x89\x01\xad\x01\xab\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xa9\x01\xa6\x01\xa7\x01\xa5\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x0a\x01\x73\x01\xa0\x01\x9f\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x9d\x01\x9e\x01\xb9\x01\xb8\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xe1\x00\xb7\x01\xb5\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xb1\x01\xb3\x01\xb0\x01\xc3\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x1c\x01\xc2\x01\xc1\x01\xc0\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x94\x00\xbf\x01\xbe\x01\xbd\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbc\x01\xc5\x01\xc6\x01\xbb\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x00\x00\x00\x00\xc9\x01\xba\x01\xc4\x01\xc8\x01\xce\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x01\x7d\x00\xc7\x01\x82\x01\x83\x01\x84\x01\xe1\x00\x7d\x00\x7e\x00\xe1\x00\x7d\x00\x2d\x00\xe6\x00\xe3\x00\x7e\x00\xe2\x00\xe3\x00\x7e\x00\x7f\x00\x09\x00\x2c\x00\x24\x00\x30\x00\x4e\x00\x7f\x00\x09\x00\x43\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\x41\x00\xe1\x00\x7d\x00\x2c\x00\x23\x01\xe3\x00\x7e\x00\x1e\x01\xe3\x00\x7e\x00\x97\x00\x9a\x00\x92\x00\xf3\x00\xf1\x00\xd8\x00\x7f\x00\x09\x00\xba\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\x40\x01\xe1\x00\x7d\x00\xd3\x00\x5f\x01\xe3\x00\x7e\x00\x85\x01\xe3\x00\x7e\x00\x1f\x01\x12\x01\x1c\x01\x03\x01\x79\x01\x58\x01\x7f\x00\x09\x00\x51\x01\x7f\x00\x09\x00\xe1\x00\x7d\x00\x74\x01\x71\x01\x70\x01\xa9\x01\x93\x01\xe3\x00\x7e\x00\x81\x01\x7d\x00\x8f\x01\xa0\x01\xab\x01\x84\x01\xe1\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\xae\x01\xa7\x01\xe3\x00\x7e\x00\xe1\x00\x7d\x00\xa3\x01\x7f\x00\x09\x00\x9e\x00\x7d\x00\x52\x01\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x9d\x00\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\xf7\x00\x7d\x00\x7e\x00\xf6\x00\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\xf4\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\xea\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\xe5\x00\x7d\x00\x00\x00\x7f\x00\x09\x00\xb9\x00\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x43\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x38\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x37\x01\x7d\x00\x7e\x00\x36\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x35\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x34\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x33\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x32\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x31\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x30\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x2f\x01\x7d\x00\x7e\x00\x2e\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x2d\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x2c\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x2b\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x2a\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x29\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x08\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x62\x01\x7d\x00\x7e\x00\x61\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x80\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x7e\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x87\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xab\x00\xac\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa6\x00\xa7\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 181) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181) + ] + +happy_n_terms = 87 :: Prelude.Int +happy_n_nonterms = 55 :: Prelude.Int + +happyReduce_1 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_1 = happySpecReduce_0 0# happyReduction_1 +happyReduction_1 = happyIn4 + (return () + ) + +happyReduce_2 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { (HappyWrap5 happy_var_1) -> + case happyOut4 happy_x_2 of { (HappyWrap4 happy_var_2) -> + happyIn4 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_3 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut11 happy_x_1 of { (HappyWrap11 happy_var_1) -> + happyIn5 + (happy_var_1 + )} + +happyReduce_4 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut6 happy_x_1 of { (HappyWrap6 happy_var_1) -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_5 = happySpecReduce_1 1# happyReduction_5 +happyReduction_5 happy_x_1 + = case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> + happyIn5 + (happy_var_1 + )} + +happyReduce_6 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6 +happyReduction_6 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> + case happyOut10 happy_x_6 of { (HappyWrap10 happy_var_6) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + lits <- sequence happy_var_6; + staticClosure home_unit_id happy_var_3 happy_var_5 (map getLit lits))}}}) + ) (\r -> happyReturn (happyIn5 r)) + +happyReduce_7 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_7 = happyReduce 6# 2# happyReduction_7 +happyReduction_7 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> + case happyOut7 happy_x_4 of { (HappyWrap7 happy_var_4) -> + case happyOut8 happy_x_5 of { (HappyWrap8 happy_var_5) -> + happyIn6 + (do lbl <- happy_var_4; + ss <- sequence happy_var_5; + code (emitDecl (CmmData (Section (section happy_var_2) lbl) (CmmStaticsRaw lbl (concat ss)))) + ) `HappyStk` happyRest}}} + +happyReduce_8 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8 +happyReduction_8 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) happy_var_1))}) + ) (\r -> happyReturn (happyIn7 r)) + +happyReduce_9 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_9 = happySpecReduce_0 4# happyReduction_9 +happyReduction_9 = happyIn8 + ([] + ) + +happyReduce_10 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_10 = happySpecReduce_2 4# happyReduction_10 +happyReduction_10 happy_x_2 + happy_x_1 + = case happyOut9 happy_x_1 of { (HappyWrap9 happy_var_1) -> + case happyOut8 happy_x_2 of { (HappyWrap8 happy_var_2) -> + happyIn8 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_11 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_11 = happySpecReduce_3 5# happyReduction_11 +happyReduction_11 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn9 + (do e <- happy_var_2; + return [CmmStaticLit (getLit e)] + )} + +happyReduce_12 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_12 = happySpecReduce_2 5# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + happyIn9 + (return [CmmUninitialised + (widthInBytes (typeWidth happy_var_1))] + )} + +happyReduce_13 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_13 = happyReduce 5# 5# happyReduction_13 +happyReduction_13 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_4 of { (L _ (CmmT_String happy_var_4)) -> + happyIn9 + (return [mkString happy_var_4] + ) `HappyStk` happyRest} + +happyReduce_14 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_14 = happyReduce 5# 5# happyReduction_14 +happyReduction_14 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> + happyIn9 + (return [CmmUninitialised + (fromIntegral happy_var_3)] + ) `HappyStk` happyRest} + +happyReduce_15 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_15 = happyReduce 5# 5# happyReduction_15 +happyReduction_15 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> + case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> + happyIn9 + (return [CmmUninitialised + (widthInBytes (typeWidth happy_var_1) * + fromIntegral happy_var_3)] + ) `HappyStk` happyRest}} + +happyReduce_16 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_16 = happyReduce 5# 5# happyReduction_16 +happyReduction_16 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOut10 happy_x_4 of { (HappyWrap10 happy_var_4) -> + happyIn9 + (do { lits <- sequence happy_var_4 + ; profile <- getProfile + ; return $ map CmmStaticLit $ + mkStaticClosure profile (mkForeignLabel happy_var_3 ForeignLabelInExternalPackage IsData) + -- mkForeignLabel because these are only used + -- for CHARLIKE and INTLIKE closures in the RTS. + dontCareCCS (map getLit lits) [] [] [] [] } + ) `HappyStk` happyRest}} + +happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_17 = happySpecReduce_0 6# happyReduction_17 +happyReduction_17 = happyIn10 + ([] + ) + +happyReduce_18 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_18 = happySpecReduce_3 6# happyReduction_18 +happyReduction_18 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut10 happy_x_3 of { (HappyWrap10 happy_var_3) -> + happyIn10 + (happy_var_2 : happy_var_3 + )}} + +happyReduce_19 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_19 = happyReduce 4# 7# happyReduction_19 +happyReduction_19 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut14 happy_x_1 of { (HappyWrap14 happy_var_1) -> + case happyOut12 happy_x_2 of { (HappyWrap12 happy_var_2) -> + case happyOut53 happy_x_3 of { (HappyWrap53 happy_var_3) -> + case happyOut13 happy_x_4 of { (HappyWrap13 happy_var_4) -> + happyIn11 + (do ((entry_ret_label, info, stk_formals, formals), agraph) <- + getCodeScoped $ loopDecls $ do { + (entry_ret_label, info, stk_formals) <- happy_var_1; + platform <- getPlatform; + ctx <- getContext; + formals <- sequence (fromMaybe [] happy_var_3); + withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label)) + happy_var_4; + return (entry_ret_label, info, stk_formals, formals) } + let do_layout = isJust happy_var_3 + code (emitProcWithStackFrame happy_var_2 info + entry_ret_label stk_formals formals agraph + do_layout ) + ) `HappyStk` happyRest}}}} + +happyReduce_20 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_20 = happySpecReduce_0 8# happyReduction_20 +happyReduction_20 = happyIn12 + (NativeNodeCall + ) + +happyReduce_21 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_21 = happySpecReduce_1 8# happyReduction_21 +happyReduction_21 happy_x_1 + = happyIn12 + (NativeReturn + ) + +happyReduce_22 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_22 = happySpecReduce_1 9# happyReduction_22 +happyReduction_22 happy_x_1 + = happyIn13 + (return () + ) + +happyReduce_23 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_23 = happySpecReduce_3 9# happyReduction_23 +happyReduction_23 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn13 + (withSourceNote happy_var_1 happy_var_3 happy_var_2 + )}}} + +happyReduce_24 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24 +happyReduction_24 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + newFunctionName happy_var_1 home_unit_id + return (mkCmmCodeLabel home_unit_id happy_var_1, Nothing, []))}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_25 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25 +happyReduction_25 (happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_11 happy_var_13 + rep = mkRTSRep (fromIntegral happy_var_9) $ + mkHeapRep profile False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) Thunk + -- not really Thunk, but that makes the info table + -- we want. + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_26 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_26 = happyMonadReduce 18# 10# happyReduction_26 +happyReduction_26 (happy_x_18 `HappyStk` + happy_x_17 `HappyStk` + happy_x_16 `HappyStk` + happy_x_15 `HappyStk` + happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + case happyOutTok happy_x_15 of { (L _ (CmmT_Int happy_var_15)) -> + case happyOutTok happy_x_17 of { (L _ (CmmT_Int happy_var_17)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_11 happy_var_13 + ty = Fun (fromIntegral happy_var_15) (ArgSpec (fromIntegral happy_var_17)) + rep = mkRTSRep (fromIntegral happy_var_9) $ + mkHeapRep profile False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) ty + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}}}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_27 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27 +happyReduction_27 (happy_x_16 `HappyStk` + happy_x_15 `HappyStk` + happy_x_14 `HappyStk` + happy_x_13 `HappyStk` + happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_Int happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_Int happy_var_11)) -> + case happyOutTok happy_x_13 of { (L _ (CmmT_String happy_var_13)) -> + case happyOutTok happy_x_15 of { (L _ (CmmT_String happy_var_15)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_13 happy_var_15 + ty = Constr (fromIntegral happy_var_9) -- Tag + (BS8.pack happy_var_13) + rep = mkRTSRep (fromIntegral happy_var_11) $ + mkHeapRep profile False (fromIntegral happy_var_5) + (fromIntegral happy_var_7) ty + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing }, + []))}}}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_28 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28 +happyReduction_28 (happy_x_12 `HappyStk` + happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOutTok happy_x_7 of { (L _ (CmmT_Int happy_var_7)) -> + case happyOutTok happy_x_9 of { (L _ (CmmT_String happy_var_9)) -> + case happyOutTok happy_x_11 of { (L _ (CmmT_String happy_var_11)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + profile <- getProfile + let prof = profilingInfo profile happy_var_9 happy_var_11 + ty = ThunkSelector (fromIntegral happy_var_5) + rep = mkRTSRep (fromIntegral happy_var_7) $ + mkHeapRep profile False 0 0 ty + return (mkCmmEntryLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_29 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29 +happyReduction_29 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + let prof = NoProfilingInfo + rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep [] + return (mkCmmRetLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + []))}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_30 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30 +happyReduction_30 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> + case happyOut54 happy_x_7 of { (HappyWrap54 happy_var_7) -> + ( do + home_unit_id <- getHomeUnitId + liftP $ pure $ do + platform <- getPlatform + live <- sequence happy_var_7 + let prof = NoProfilingInfo + -- drop one for the info pointer + bitmap = mkLiveness platform (drop 1 live) + rep = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap + return (mkCmmRetLabel home_unit_id happy_var_3, + Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3 + , cit_rep = rep + , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing }, + live))}}}) + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_31 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_31 = happySpecReduce_0 11# happyReduction_31 +happyReduction_31 = happyIn15 + (return () + ) + +happyReduce_32 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_32 = happySpecReduce_2 11# happyReduction_32 +happyReduction_32 happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + happyIn15 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_33 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_33 = happySpecReduce_2 11# happyReduction_33 +happyReduction_33 happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + happyIn15 + (do happy_var_1; happy_var_2 + )}} + +happyReduce_34 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_34 = happySpecReduce_3 12# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut19 happy_x_2 of { (HappyWrap19 happy_var_2) -> + happyIn16 + (mapM_ (newLocal happy_var_1) happy_var_2 + )}} + +happyReduce_35 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_35 = happySpecReduce_3 12# happyReduction_35 +happyReduction_35 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut17 happy_x_2 of { (HappyWrap17 happy_var_2) -> + happyIn16 + (mapM_ newImport happy_var_2 + )} + +happyReduce_36 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_36 = happySpecReduce_3 12# happyReduction_36 +happyReduction_36 happy_x_3 + happy_x_2 + happy_x_1 + = happyIn16 + (return () + ) + +happyReduce_37 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_37 = happySpecReduce_1 13# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + happyIn17 + ([happy_var_1] + )} + +happyReduce_38 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_38 = happySpecReduce_3 13# happyReduction_38 +happyReduction_38 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + case happyOut17 happy_x_3 of { (HappyWrap17 happy_var_3) -> + happyIn17 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_39 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_39 = happySpecReduce_1 14# happyReduction_39 +happyReduction_39 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn18 + ((happy_var_1, mkForeignLabel happy_var_1 ForeignLabelInExternalPackage IsFunction) + )} + +happyReduce_40 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_40 = happySpecReduce_2 14# happyReduction_40 +happyReduction_40 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn18 + ((happy_var_2, mkForeignLabel happy_var_2 ForeignLabelInExternalPackage IsData) + )} + +happyReduce_41 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_41 = happySpecReduce_2 14# happyReduction_41 +happyReduction_41 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn18 + ((happy_var_2, mkCmmCodeLabel (UnitId (mkFastString happy_var_1)) happy_var_2) + )}} + +happyReduce_42 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_42 = happySpecReduce_1 15# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn19 + ([happy_var_1] + )} + +happyReduce_43 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_43 = happySpecReduce_3 15# happyReduction_43 +happyReduction_43 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> + happyIn19 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_44 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_44 = happySpecReduce_1 16# happyReduction_44 +happyReduction_44 happy_x_1 + = happyIn20 + (return () + ) + +happyReduce_45 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_45 = happySpecReduce_2 16# happyReduction_45 +happyReduction_45 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn20 + (do l <- newLabel happy_var_1; emitLabel l + )} + +happyReduce_46 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_46 = happyReduce 4# 16# happyReduction_46 +happyReduction_46 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn20 + (do reg <- happy_var_1; e <- happy_var_3; withSourceNote happy_var_2 happy_var_4 (emitAssign reg e) + ) `HappyStk` happyRest}}}} + +happyReduce_47 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_47 = happyReduce 8# 16# happyReduction_47 +happyReduction_47 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> + case happyOut57 happy_x_4 of { (HappyWrap57 happy_var_4) -> + case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + happyIn20 + (do reg <- happy_var_1; + let lreg = case reg of + { CmmLocal r -> r + ; other -> pprPanic "CmmParse:" (ppr reg <> text "not a local register") + } ; + mord <- happy_var_3; + let { ty = happy_var_4; w = typeWidth ty }; + e <- happy_var_6; + let op = MO_AtomicRead w mord; + withSourceNote happy_var_2 happy_var_7 $ code (emitPrimCall [lreg] op [e]) + ) `HappyStk` happyRest}}}}}} + +happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_48 = happyReduce 8# 16# happyReduction_48 +happyReduction_48 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> + case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> + case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> + case happyOutTok happy_x_8 of { happy_var_8 -> + happyIn20 + (do mord <- happy_var_1; withSourceNote happy_var_3 happy_var_8 (doStore (Just mord) happy_var_2 happy_var_4 happy_var_7) + ) `HappyStk` happyRest}}}}}} + +happyReduce_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_49 = happyReduce 7# 16# happyReduction_49 +happyReduction_49 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + happyIn20 + (withSourceNote happy_var_2 happy_var_7 (doStore Nothing happy_var_1 happy_var_3 happy_var_6) + ) `HappyStk` happyRest}}}}} + +happyReduce_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_50 = happyMonadReduce 10# 16# happyReduction_50 +happyReduction_50 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> + case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> + case happyOut24 happy_x_4 of { (HappyWrap24 happy_var_4) -> + case happyOut42 happy_x_6 of { (HappyWrap42 happy_var_6) -> + case happyOut28 happy_x_8 of { (HappyWrap28 happy_var_8) -> + case happyOut25 happy_x_9 of { (HappyWrap25 happy_var_9) -> + ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}}) + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_51 = happyMonadReduce 8# 16# happyReduction_51 +happyReduction_51 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> + case happyOut45 happy_x_6 of { (HappyWrap45 happy_var_6) -> + ( primCall happy_var_1 happy_var_4 happy_var_6)}}}) + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_52 = happyMonadReduce 5# 16# happyReduction_52 +happyReduction_52 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> + ( stmtMacro happy_var_1 happy_var_3)}}) + ) (\r -> happyReturn (happyIn20 r)) + +happyReduce_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_53 = happyReduce 7# 16# happyReduction_53 +happyReduction_53 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + case happyOut32 happy_x_5 of { (HappyWrap32 happy_var_5) -> + case happyOut36 happy_x_6 of { (HappyWrap36 happy_var_6) -> + happyIn20 + (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6 + ) `HappyStk` happyRest}}}} + +happyReduce_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_54 = happySpecReduce_3 16# happyReduction_54 +happyReduction_54 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn20 + (do l <- lookupLabel happy_var_2; emit (mkBranch l) + )} + +happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_55 = happyReduce 5# 16# happyReduction_55 +happyReduction_55 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> + happyIn20 + (doReturn happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_56 = happyReduce 4# 16# happyReduction_56 +happyReduction_56 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> + happyIn20 + (doRawJump happy_var_2 happy_var_3 + ) `HappyStk` happyRest}} + +happyReduce_57 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_57 = happyReduce 6# 16# happyReduction_57 +happyReduction_57 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + happyIn20 + (doJumpWithStack happy_var_2 [] happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_58 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_58 = happyReduce 9# 16# happyReduction_58 +happyReduction_58 (happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + case happyOut45 happy_x_7 of { (HappyWrap45 happy_var_7) -> + happyIn20 + (doJumpWithStack happy_var_2 happy_var_4 happy_var_7 + ) `HappyStk` happyRest}}} + +happyReduce_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_59 = happyReduce 6# 16# happyReduction_59 +happyReduction_59 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + happyIn20 + (doCall happy_var_2 [] happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_60 = happyReduce 10# 16# happyReduction_60 +happyReduction_60 (happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut55 happy_x_2 of { (HappyWrap55 happy_var_2) -> + case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> + case happyOut45 happy_x_8 of { (HappyWrap45 happy_var_8) -> + happyIn20 + (doCall happy_var_6 happy_var_2 happy_var_8 + ) `HappyStk` happyRest}}} + +happyReduce_61 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_61 = happyReduce 5# 16# happyReduction_61 +happyReduction_61 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> + case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> + case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> + happyIn20 + (do l <- lookupLabel happy_var_5; cmmRawIf happy_var_2 l happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_62 = happyReduce 7# 16# happyReduction_62 +happyReduction_62 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> + case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut15 happy_x_5 of { (HappyWrap15 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + case happyOut37 happy_x_7 of { (HappyWrap37 happy_var_7) -> + happyIn20 + (cmmIfThenElse happy_var_2 (withSourceNote happy_var_4 happy_var_6 happy_var_5) happy_var_7 happy_var_3 + ) `HappyStk` happyRest}}}}}} + +happyReduce_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_63 = happyReduce 5# 16# happyReduction_63 +happyReduction_63 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> + case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> + happyIn20 + (pushStackFrame happy_var_3 happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_64 = happyReduce 5# 16# happyReduction_64 +happyReduction_64 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + case happyOut52 happy_x_4 of { (HappyWrap52 happy_var_4) -> + case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> + happyIn20 + (reserveStackFrame happy_var_2 happy_var_4 happy_var_5 + ) `HappyStk` happyRest}}} + +happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_65 = happySpecReduce_3 16# happyReduction_65 +happyReduction_65 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut21 happy_x_2 of { (HappyWrap21 happy_var_2) -> + happyIn20 + (happy_var_2 >>= code . emitUnwind + )} + +happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_66 = happyReduce 5# 17# happyReduction_66 +happyReduction_66 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> + case happyOut21 happy_x_5 of { (HappyWrap21 happy_var_5) -> + happyIn21 + (do e <- happy_var_3; rest <- happy_var_5; return ((globalRegUse_reg happy_var_1, e) : rest) + ) `HappyStk` happyRest}}} + +happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_67 = happySpecReduce_3 17# happyReduction_67 +happyReduction_67 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> + happyIn21 + (do e <- happy_var_3; return [(globalRegUse_reg happy_var_1, e)] + )}} + +happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_68 = happySpecReduce_1 18# happyReduction_68 +happyReduction_68 happy_x_1 + = happyIn22 + (do return MemOrderRelaxed + ) + +happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_69 = happySpecReduce_1 18# happyReduction_69 +happyReduction_69 happy_x_1 + = happyIn22 + (do return MemOrderRelease + ) + +happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_70 = happySpecReduce_1 18# happyReduction_70 +happyReduction_70 happy_x_1 + = happyIn22 + (do return MemOrderAcquire + ) + +happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_71 = happySpecReduce_1 18# happyReduction_71 +happyReduction_71 happy_x_1 + = happyIn22 + (do return MemOrderSeqCst + ) + +happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_72 = happySpecReduce_1 19# happyReduction_72 +happyReduction_72 happy_x_1 + = happyIn23 + (do return Nothing + ) + +happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_73 = happySpecReduce_1 19# happyReduction_73 +happyReduction_73 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn23 + (do e <- happy_var_1; return (Just e) + )} + +happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_74 = happySpecReduce_1 20# happyReduction_74 +happyReduction_74 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn24 + (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 ForeignLabelInThisPackage IsFunction))) + )} + +happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_75 = happySpecReduce_0 21# happyReduction_75 +happyReduction_75 = happyIn25 + (CmmMayReturn + ) + +happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_76 = happySpecReduce_2 21# happyReduction_76 +happyReduction_76 happy_x_2 + happy_x_1 + = happyIn25 + (CmmNeverReturns + ) + +happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_77 = happySpecReduce_1 22# happyReduction_77 +happyReduction_77 happy_x_1 + = case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> + happyIn26 + (happy_var_1 + )} + +happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_78 = happySpecReduce_1 22# happyReduction_78 +happyReduction_78 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn26 + (do e <- happy_var_1; return (BoolTest e) + )} + +happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_79 = happySpecReduce_3 23# happyReduction_79 +happyReduction_79 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> + case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> + happyIn27 + (do e1 <- happy_var_1; e2 <- happy_var_3; + return (BoolAnd e1 e2) + )}} + +happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_80 = happySpecReduce_3 23# happyReduction_80 +happyReduction_80 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> + case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> + happyIn27 + (do e1 <- happy_var_1; e2 <- happy_var_3; + return (BoolOr e1 e2) + )}} + +happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_81 = happySpecReduce_2 23# happyReduction_81 +happyReduction_81 happy_x_2 + happy_x_1 + = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> + happyIn27 + (do e <- happy_var_2; return (BoolNot e) + )} + +happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_82 = happySpecReduce_3 23# happyReduction_82 +happyReduction_82 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_2 of { (HappyWrap27 happy_var_2) -> + happyIn27 + (happy_var_2 + )} + +happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_83 = happySpecReduce_0 24# happyReduction_83 +happyReduction_83 = happyIn28 + (PlayRisky + ) + +happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_84 = happyMonadReduce 1# 24# happyReduction_84 +happyReduction_84 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + ( parseSafety happy_var_1)}) + ) (\r -> happyReturn (happyIn28 r)) + +happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_85 = happySpecReduce_2 25# happyReduction_85 +happyReduction_85 happy_x_2 + happy_x_1 + = happyIn29 + ([] + ) + +happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_86 = happyMonadReduce 1# 25# happyReduction_86 +happyReduction_86 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform GP_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_87 = happyMonadReduce 1# 25# happyReduction_87 +happyReduction_87 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform SCALAR_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_88 = happyMonadReduce 1# 25# happyReduction_88 +happyReduction_88 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform V16_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_89 = happyMonadReduce 1# 25# happyReduction_89 +happyReduction_89 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform V32_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_90 = happyMonadReduce 1# 25# happyReduction_90 +happyReduction_90 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; + return + [ GlobalRegUse r (globalRegSpillType platform r) + | r <- realArgRegsCover platform V64_ARG_REGS ])) + ) (\r -> happyReturn (happyIn29 r)) + +happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_91 = happySpecReduce_3 25# happyReduction_91 +happyReduction_91 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut30 happy_x_2 of { (HappyWrap30 happy_var_2) -> + happyIn29 + (happy_var_2 + )} + +happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_92 = happySpecReduce_1 26# happyReduction_92 +happyReduction_92 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn30 + ([happy_var_1] + )} + +happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_93 = happySpecReduce_3 26# happyReduction_93 +happyReduction_93 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> + happyIn30 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_94 = happyReduce 5# 27# happyReduction_94 +happyReduction_94 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> + happyIn31 + (Just (happy_var_2, happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_95 = happySpecReduce_0 27# happyReduction_95 +happyReduction_95 = happyIn31 + (Nothing + ) + +happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_96 = happySpecReduce_0 28# happyReduction_96 +happyReduction_96 = happyIn32 + ([] + ) + +happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_97 = happySpecReduce_2 28# happyReduction_97 +happyReduction_97 happy_x_2 + happy_x_1 + = case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> + case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> + happyIn32 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_98 = happyReduce 4# 29# happyReduction_98 +happyReduction_98 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut35 happy_x_2 of { (HappyWrap35 happy_var_2) -> + case happyOut34 happy_x_4 of { (HappyWrap34 happy_var_4) -> + happyIn33 + (do b <- happy_var_4; return (happy_var_2, b) + ) `HappyStk` happyRest}} + +happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_99 = happySpecReduce_3 30# happyReduction_99 +happyReduction_99 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn34 + (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2)) + )}}} + +happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_100 = happySpecReduce_3 30# happyReduction_100 +happyReduction_100 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn34 + (do l <- lookupLabel happy_var_2; return (Left l) + )} + +happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_101 = happySpecReduce_1 31# happyReduction_101 +happyReduction_101 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + happyIn35 + ([ happy_var_1 ] + )} + +happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_102 = happySpecReduce_3 31# happyReduction_102 +happyReduction_102 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + case happyOut35 happy_x_3 of { (HappyWrap35 happy_var_3) -> + happyIn35 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_103 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_103 = happyReduce 5# 32# happyReduction_103 +happyReduction_103 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut15 happy_x_4 of { (HappyWrap15 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + happyIn36 + (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4) + ) `HappyStk` happyRest}}} + +happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_104 = happySpecReduce_0 32# happyReduction_104 +happyReduction_104 = happyIn36 + (Nothing + ) + +happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_105 = happySpecReduce_0 33# happyReduction_105 +happyReduction_105 = happyIn37 + (return () + ) + +happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_106 = happyReduce 4# 33# happyReduction_106 +happyReduction_106 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut15 happy_x_3 of { (HappyWrap15 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn37 + (withSourceNote happy_var_2 happy_var_4 happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_107 = happyReduce 5# 34# happyReduction_107 +happyReduction_107 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn38 + (Just True + ) `HappyStk` happyRest + +happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_108 = happyReduce 5# 34# happyReduction_108 +happyReduction_108 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = happyIn38 + (Just False + ) `HappyStk` happyRest + +happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_109 = happySpecReduce_0 34# happyReduction_109 +happyReduction_109 = happyIn38 + (Nothing + ) + +happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_110 = happySpecReduce_3 35# happyReduction_110 +happyReduction_110 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] + )}} + +happyReduce_111 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_111 = happySpecReduce_3 35# happyReduction_111 +happyReduction_111 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Mul [happy_var_1,happy_var_3] + )}} + +happyReduce_112 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_112 = happySpecReduce_3 35# happyReduction_112 +happyReduction_112 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] + )}} + +happyReduce_113 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_113 = happySpecReduce_3 35# happyReduction_113 +happyReduction_113 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Sub [happy_var_1,happy_var_3] + )}} + +happyReduce_114 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_114 = happySpecReduce_3 35# happyReduction_114 +happyReduction_114 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Add [happy_var_1,happy_var_3] + )}} + +happyReduce_115 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_115 = happySpecReduce_3 35# happyReduction_115 +happyReduction_115 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] + )}} + +happyReduce_116 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_116 = happySpecReduce_3 35# happyReduction_116 +happyReduction_116 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Shl [happy_var_1,happy_var_3] + )}} + +happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_117 = happySpecReduce_3 35# happyReduction_117 +happyReduction_117 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_And [happy_var_1,happy_var_3] + )}} + +happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_118 = happySpecReduce_3 35# happyReduction_118 +happyReduction_118 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Xor [happy_var_1,happy_var_3] + )}} + +happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_119 = happySpecReduce_3 35# happyReduction_119 +happyReduction_119 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Or [happy_var_1,happy_var_3] + )}} + +happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_120 = happySpecReduce_3 35# happyReduction_120 +happyReduction_120 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] + )}} + +happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_121 = happySpecReduce_3 35# happyReduction_121 +happyReduction_121 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] + )}} + +happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_122 = happySpecReduce_3 35# happyReduction_122 +happyReduction_122 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Le [happy_var_1,happy_var_3] + )}} + +happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_123 = happySpecReduce_3 35# happyReduction_123 +happyReduction_123 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] + )}} + +happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_124 = happySpecReduce_3 35# happyReduction_124 +happyReduction_124 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Ne [happy_var_1,happy_var_3] + )}} + +happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_125 = happySpecReduce_3 35# happyReduction_125 +happyReduction_125 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn39 + (mkMachOp MO_Eq [happy_var_1,happy_var_3] + )}} + +happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_126 = happySpecReduce_2 35# happyReduction_126 +happyReduction_126 happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn39 + (mkMachOp MO_Not [happy_var_2] + )} + +happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_127 = happySpecReduce_2 35# happyReduction_127 +happyReduction_127 happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn39 + (mkMachOp MO_S_Neg [happy_var_2] + )} + +happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_128 = happyMonadReduce 5# 35# happyReduction_128 +happyReduction_128 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> + case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> + case happyOut40 happy_x_5 of { (HappyWrap40 happy_var_5) -> + ( do { mo <- nameToMachOp happy_var_3 ; + return (mkMachOp mo [happy_var_1,happy_var_5]) })}}}) + ) (\r -> happyReturn (happyIn39 r)) + +happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_129 = happySpecReduce_1 35# happyReduction_129 +happyReduction_129 happy_x_1 + = case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> + happyIn39 + (happy_var_1 + )} + +happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_130 = happySpecReduce_2 36# happyReduction_130 +happyReduction_130 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> + case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> + happyIn40 + (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) + )}} + +happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_131 = happySpecReduce_2 36# happyReduction_131 +happyReduction_131 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> + case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> + happyIn40 + (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) + )}} + +happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_132 = happySpecReduce_1 36# happyReduction_132 +happyReduction_132 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + happyIn40 + (do s <- code (newStringCLit happy_var_1); + return (CmmLit s) + )} + +happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_133 = happySpecReduce_1 36# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOut47 happy_x_1 of { (HappyWrap47 happy_var_1) -> + happyIn40 + (happy_var_1 + )} + +happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_134 = happyReduce 5# 36# happyReduction_134 +happyReduction_134 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> + happyIn40 + (do ptr <- happy_var_4; return (CmmMachOp (MO_RelaxedRead (typeWidth happy_var_1)) [ptr]) + ) `HappyStk` happyRest}} + +happyReduce_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_135 = happyReduce 5# 36# happyReduction_135 +happyReduction_135 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> + happyIn40 + (do ptr <- happy_var_4; return (CmmLoad ptr happy_var_1 Unaligned) + ) `HappyStk` happyRest}} + +happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_136 = happyReduce 4# 36# happyReduction_136 +happyReduction_136 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> + happyIn40 + (do ptr <- happy_var_3; return (CmmLoad ptr happy_var_1 NaturallyAligned) + ) `HappyStk` happyRest}} + +happyReduce_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_137 = happyMonadReduce 5# 36# happyReduction_137 +happyReduction_137 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> + ( exprOp happy_var_2 happy_var_4)}}) + ) (\r -> happyReturn (happyIn40 r)) + +happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_138 = happySpecReduce_3 36# happyReduction_138 +happyReduction_138 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> + happyIn40 + (happy_var_2 + )} + +happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_139 = happyMonadReduce 0# 37# happyReduction_139 +happyReduction_139 (happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; return $ bWord platform)) + ) (\r -> happyReturn (happyIn41 r)) + +happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_140 = happySpecReduce_2 37# happyReduction_140 +happyReduction_140 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> + happyIn41 + (happy_var_2 + )} + +happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_141 = happySpecReduce_0 38# happyReduction_141 +happyReduction_141 = happyIn42 + ([] + ) + +happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_142 = happySpecReduce_1 38# happyReduction_142 +happyReduction_142 happy_x_1 + = case happyOut43 happy_x_1 of { (HappyWrap43 happy_var_1) -> + happyIn42 + (happy_var_1 + )} + +happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_143 = happySpecReduce_1 39# happyReduction_143 +happyReduction_143 happy_x_1 + = case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> + happyIn43 + ([happy_var_1] + )} + +happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_144 = happySpecReduce_3 39# happyReduction_144 +happyReduction_144 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> + case happyOut43 happy_x_3 of { (HappyWrap43 happy_var_3) -> + happyIn43 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_145 = happySpecReduce_1 40# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn44 + (do e <- happy_var_1; + return (e, inferCmmHint e) + )} + +happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_146 = happyMonadReduce 2# 40# happyReduction_146 +happyReduction_146 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> + ( do h <- parseCmmHint happy_var_2; + return $ do + e <- happy_var_1; return (e, h))}}) + ) (\r -> happyReturn (happyIn44 r)) + +happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_147 = happySpecReduce_0 41# happyReduction_147 +happyReduction_147 = happyIn45 + ([] + ) + +happyReduce_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_148 = happySpecReduce_1 41# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOut46 happy_x_1 of { (HappyWrap46 happy_var_1) -> + happyIn45 + (happy_var_1 + )} + +happyReduce_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_149 = happySpecReduce_1 42# happyReduction_149 +happyReduction_149 happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + happyIn46 + ([ happy_var_1 ] + )} + +happyReduce_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_150 = happySpecReduce_3 42# happyReduction_150 +happyReduction_150 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> + happyIn46 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_151 = happySpecReduce_1 43# happyReduction_151 +happyReduction_151 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn47 + (lookupName happy_var_1 + )} + +happyReduce_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_152 = happySpecReduce_1 43# happyReduction_152 +happyReduction_152 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn47 + (return (CmmReg (CmmGlobal happy_var_1)) + )} + +happyReduce_153 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_153 = happySpecReduce_0 44# happyReduction_153 +happyReduction_153 = happyIn48 + ([] + ) + +happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_154 = happyReduce 4# 44# happyReduction_154 +happyReduction_154 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> + happyIn48 + (happy_var_2 + ) `HappyStk` happyRest} + +happyReduce_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_155 = happySpecReduce_1 45# happyReduction_155 +happyReduction_155 happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + happyIn49 + ([happy_var_1] + )} + +happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_156 = happySpecReduce_2 45# happyReduction_156 +happyReduction_156 happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + happyIn49 + ([happy_var_1] + )} + +happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_157 = happySpecReduce_3 45# happyReduction_157 +happyReduction_157 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + case happyOut49 happy_x_3 of { (HappyWrap49 happy_var_3) -> + happyIn49 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_158 = happySpecReduce_1 46# happyReduction_158 +happyReduction_158 happy_x_1 + = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> + happyIn50 + (do e <- happy_var_1; return (e, inferCmmHint (CmmReg (CmmLocal e))) + )} + +happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_159 = happyMonadReduce 2# 46# happyReduction_159 +happyReduction_159 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> + case happyOut51 happy_x_2 of { (HappyWrap51 happy_var_2) -> + ( do h <- parseCmmHint happy_var_1; + return $ do + e <- happy_var_2; return (e,h))}}) + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_160 = happySpecReduce_1 47# happyReduction_160 +happyReduction_160 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn51 + (do e <- lookupName happy_var_1; + return $ + case e of + CmmReg (CmmLocal r) -> r + other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") + )} + +happyReduce_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_161 = happySpecReduce_1 48# happyReduction_161 +happyReduction_161 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + happyIn52 + (do e <- lookupName happy_var_1; + return $ + case e of + CmmReg r -> r + other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") + )} + +happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_162 = happySpecReduce_1 48# happyReduction_162 +happyReduction_162 happy_x_1 + = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> + happyIn52 + (return (CmmGlobal happy_var_1) + )} + +happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_163 = happySpecReduce_0 49# happyReduction_163 +happyReduction_163 = happyIn53 + (Nothing + ) + +happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_164 = happySpecReduce_3 49# happyReduction_164 +happyReduction_164 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut54 happy_x_2 of { (HappyWrap54 happy_var_2) -> + happyIn53 + (Just happy_var_2 + )} + +happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_165 = happySpecReduce_0 50# happyReduction_165 +happyReduction_165 = happyIn54 + ([] + ) + +happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_166 = happySpecReduce_1 50# happyReduction_166 +happyReduction_166 happy_x_1 + = case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> + happyIn54 + (happy_var_1 + )} + +happyReduce_167 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_167 = happySpecReduce_2 51# happyReduction_167 +happyReduction_167 happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + happyIn55 + ([happy_var_1] + )} + +happyReduce_168 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_168 = happySpecReduce_1 51# happyReduction_168 +happyReduction_168 happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + happyIn55 + ([happy_var_1] + )} + +happyReduce_169 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_169 = happySpecReduce_3 51# happyReduction_169 +happyReduction_169 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> + happyIn55 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_170 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_170 = happySpecReduce_2 52# happyReduction_170 +happyReduction_170 happy_x_2 + happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn56 + (newLocal happy_var_1 happy_var_2 + )}} + +happyReduce_171 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_171 = happySpecReduce_1 53# happyReduction_171 +happyReduction_171 happy_x_1 + = happyIn57 + (b8 + ) + +happyReduce_172 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_172 = happySpecReduce_1 53# happyReduction_172 +happyReduction_172 happy_x_1 + = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> + happyIn57 + (happy_var_1 + )} + +happyReduce_173 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_173 = happySpecReduce_1 54# happyReduction_173 +happyReduction_173 happy_x_1 + = happyIn58 + (b16 + ) + +happyReduce_174 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_174 = happySpecReduce_1 54# happyReduction_174 +happyReduction_174 happy_x_1 + = happyIn58 + (b32 + ) + +happyReduce_175 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_175 = happySpecReduce_1 54# happyReduction_175 +happyReduction_175 happy_x_1 + = happyIn58 + (b64 + ) + +happyReduce_176 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_176 = happySpecReduce_1 54# happyReduction_176 +happyReduction_176 happy_x_1 + = happyIn58 + (cmmVec 2 f64 + ) + +happyReduce_177 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_177 = happySpecReduce_1 54# happyReduction_177 +happyReduction_177 happy_x_1 + = happyIn58 + (cmmVec 4 f64 + ) + +happyReduce_178 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_178 = happySpecReduce_1 54# happyReduction_178 +happyReduction_178 happy_x_1 + = happyIn58 + (cmmVec 8 f64 + ) + +happyReduce_179 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_179 = happySpecReduce_1 54# happyReduction_179 +happyReduction_179 happy_x_1 + = happyIn58 + (f32 + ) + +happyReduce_180 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_180 = happySpecReduce_1 54# happyReduction_180 +happyReduction_180 happy_x_1 + = happyIn58 + (f64 + ) + +happyReduce_181 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) +happyReduce_181 = happyMonadReduce 1# 54# happyReduction_181 +happyReduction_181 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( do platform <- PD.getPlatform; return $ gcWord platform)) + ) (\r -> happyReturn (happyIn58 r)) + +happyNewToken action sts stk + = cmmlex(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ CmmT_EOF -> happyDoAction 86# tk action sts stk; + L _ (CmmT_SpecChar ':') -> cont 1#; + L _ (CmmT_SpecChar ';') -> cont 2#; + L _ (CmmT_SpecChar '{') -> cont 3#; + L _ (CmmT_SpecChar '}') -> cont 4#; + L _ (CmmT_SpecChar '[') -> cont 5#; + L _ (CmmT_SpecChar ']') -> cont 6#; + L _ (CmmT_SpecChar '(') -> cont 7#; + L _ (CmmT_SpecChar ')') -> cont 8#; + L _ (CmmT_SpecChar '=') -> cont 9#; + L _ (CmmT_SpecChar '`') -> cont 10#; + L _ (CmmT_SpecChar '~') -> cont 11#; + L _ (CmmT_SpecChar '/') -> cont 12#; + L _ (CmmT_SpecChar '*') -> cont 13#; + L _ (CmmT_SpecChar '%') -> cont 14#; + L _ (CmmT_SpecChar '-') -> cont 15#; + L _ (CmmT_SpecChar '+') -> cont 16#; + L _ (CmmT_SpecChar '&') -> cont 17#; + L _ (CmmT_SpecChar '^') -> cont 18#; + L _ (CmmT_SpecChar '|') -> cont 19#; + L _ (CmmT_SpecChar '>') -> cont 20#; + L _ (CmmT_SpecChar '<') -> cont 21#; + L _ (CmmT_SpecChar ',') -> cont 22#; + L _ (CmmT_SpecChar '!') -> cont 23#; + L _ (CmmT_DotDot) -> cont 24#; + L _ (CmmT_DoubleColon) -> cont 25#; + L _ (CmmT_Shr) -> cont 26#; + L _ (CmmT_Shl) -> cont 27#; + L _ (CmmT_Ge) -> cont 28#; + L _ (CmmT_Le) -> cont 29#; + L _ (CmmT_Eq) -> cont 30#; + L _ (CmmT_Ne) -> cont 31#; + L _ (CmmT_BoolAnd) -> cont 32#; + L _ (CmmT_BoolOr) -> cont 33#; + L _ (CmmT_True ) -> cont 34#; + L _ (CmmT_False) -> cont 35#; + L _ (CmmT_likely) -> cont 36#; + L _ (CmmT_Relaxed) -> cont 37#; + L _ (CmmT_Acquire) -> cont 38#; + L _ (CmmT_Release) -> cont 39#; + L _ (CmmT_SeqCst) -> cont 40#; + L _ (CmmT_CLOSURE) -> cont 41#; + L _ (CmmT_INFO_TABLE) -> cont 42#; + L _ (CmmT_INFO_TABLE_RET) -> cont 43#; + L _ (CmmT_INFO_TABLE_FUN) -> cont 44#; + L _ (CmmT_INFO_TABLE_CONSTR) -> cont 45#; + L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 46#; + L _ (CmmT_else) -> cont 47#; + L _ (CmmT_export) -> cont 48#; + L _ (CmmT_section) -> cont 49#; + L _ (CmmT_goto) -> cont 50#; + L _ (CmmT_if) -> cont 51#; + L _ (CmmT_call) -> cont 52#; + L _ (CmmT_jump) -> cont 53#; + L _ (CmmT_foreign) -> cont 54#; + L _ (CmmT_never) -> cont 55#; + L _ (CmmT_prim) -> cont 56#; + L _ (CmmT_reserve) -> cont 57#; + L _ (CmmT_return) -> cont 58#; + L _ (CmmT_returns) -> cont 59#; + L _ (CmmT_import) -> cont 60#; + L _ (CmmT_switch) -> cont 61#; + L _ (CmmT_case) -> cont 62#; + L _ (CmmT_default) -> cont 63#; + L _ (CmmT_push) -> cont 64#; + L _ (CmmT_unwind) -> cont 65#; + L _ (CmmT_bits8) -> cont 66#; + L _ (CmmT_bits16) -> cont 67#; + L _ (CmmT_bits32) -> cont 68#; + L _ (CmmT_bits64) -> cont 69#; + L _ (CmmT_vec128) -> cont 70#; + L _ (CmmT_vec256) -> cont 71#; + L _ (CmmT_vec512) -> cont 72#; + L _ (CmmT_float32) -> cont 73#; + L _ (CmmT_float64) -> cont 74#; + L _ (CmmT_gcptr) -> cont 75#; + L _ (CmmT_GlobalReg happy_dollar_dollar) -> cont 76#; + L _ (CmmT_Name happy_dollar_dollar) -> cont 77#; + L _ (CmmT_String happy_dollar_dollar) -> cont 78#; + L _ (CmmT_Int happy_dollar_dollar) -> cont 79#; + L _ (CmmT_Float happy_dollar_dollar) -> cont 80#; + L _ (CmmT_GlobalArgRegs GP_ARG_REGS) -> cont 81#; + L _ (CmmT_GlobalArgRegs SCALAR_ARG_REGS) -> cont 82#; + L _ (CmmT_GlobalArgRegs V16_ARG_REGS) -> cont 83#; + L _ (CmmT_GlobalArgRegs V32_ARG_REGS) -> cont 84#; + L _ (CmmT_GlobalArgRegs V64_ARG_REGS) -> cont 85#; + _ -> happyError' (tk, []) + }) + +happyError_ explist 86# tk = happyError' (tk, explist) +happyError_ explist _ tk = happyError' (tk, explist) + +happyThen :: () => PD a -> (a -> PD b) -> PD b +happyThen = (>>=) +happyReturn :: () => a -> PD a +happyReturn = (return) +happyParse :: () => Happy_GHC_Exts.Int# -> PD (HappyAbsSyn ) + +happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) + +happyDoAction :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) + +happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )) + +happyThen1 :: () => PD a -> (a -> PD b) -> PD b +happyThen1 = happyThen +happyReturn1 :: () => a -> PD a +happyReturn1 = happyReturn +happyError' :: () => ((Located CmmToken), [Prelude.String]) -> PD a +happyError' tk = (\(tokens, explist) -> happyError) tk +cmmParse = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap4 x') = happyOut4 x} in x')) + +happySeq = happyDoSeq + + +section :: String -> SectionType +section "text" = Text +section "data" = Data +section "rodata" = ReadOnlyData +section "relrodata" = RelocatableReadOnlyData +section "bss" = UninitialisedData +section s = OtherSection s + +mkString :: String -> CmmStatic +mkString s = CmmString (BS8.pack s) + +-- mkMachOp infers the type of the MachOp from the type of its first +-- argument. We assume that this is correct: for MachOps that don't have +-- symmetrical args (e.g. shift ops), the first arg determines the type of +-- the op. +mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr +mkMachOp fn args = do + platform <- getPlatform + arg_exprs <- sequence args + return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs) + +getLit :: CmmExpr -> CmmLit +getLit (CmmLit l) = l +getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)]) = CmmInt (negate i) r +getLit _ = panic "invalid literal" -- TODO messy failure + +nameToMachOp :: FastString -> PD (Width -> MachOp) +nameToMachOp name = + case lookupUFM machOps name of + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) + Just m -> return m + +exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) +exprOp name args_code = do + pdc <- PD.getPDConfig + let profile = PD.pdProfile pdc + let align_check = PD.pdSanitizeAlignment pdc + case lookupUFM (exprMacros profile align_check) name of + Just f -> return $ do + args <- sequence args_code + return (f args) + Nothing -> do + mo <- nameToMachOp name + return $ mkMachOp mo args_code + +exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr) +exprMacros profile align_check = listToUFM [ + ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ), + ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr platform align_check x ), + ( fsLit "STD_INFO", \ [x] -> infoTable profile x ), + ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ), + ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr platform align_check x) ), + ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr platform align_check x) ), + ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ), + ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ), + ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ), + ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x ) + ] + where + platform = profilePlatform profile + +-- we understand a subset of C-- primitives: +machOps :: UniqFM FastString (Width -> MachOp) +machOps = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + ( "add", MO_Add ), + ( "sub", MO_Sub ), + ( "eq", MO_Eq ), + ( "ne", MO_Ne ), + ( "mul", MO_Mul ), + ( "mulmayoflo", MO_S_MulMayOflo ), + ( "neg", MO_S_Neg ), + ( "quot", MO_S_Quot ), + ( "rem", MO_S_Rem ), + ( "divu", MO_U_Quot ), + ( "modu", MO_U_Rem ), + + ( "ge", MO_S_Ge ), + ( "le", MO_S_Le ), + ( "gt", MO_S_Gt ), + ( "lt", MO_S_Lt ), + + ( "geu", MO_U_Ge ), + ( "leu", MO_U_Le ), + ( "gtu", MO_U_Gt ), + ( "ltu", MO_U_Lt ), + + ( "and", MO_And ), + ( "or", MO_Or ), + ( "xor", MO_Xor ), + ( "com", MO_Not ), + ( "shl", MO_Shl ), + ( "shrl", MO_U_Shr ), + ( "shra", MO_S_Shr ), + + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + ( "fmin", MO_F_Min ), + ( "fmax", MO_F_Max ), + + ( "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 ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), + ( "lobits16", flip MO_UU_Conv W16 ), + ( "lobits32", flip MO_UU_Conv W32 ), + ( "lobits64", flip MO_UU_Conv W64 ), + + ( "zx16", flip MO_UU_Conv W16 ), + ( "zx32", flip MO_UU_Conv W32 ), + ( "zx64", flip MO_UU_Conv W64 ), + + ( "sx16", flip MO_SS_Conv W16 ), + ( "sx32", flip MO_SS_Conv W32 ), + ( "sx64", flip MO_SS_Conv W64 ), + + ( "f2f32", flip MO_FF_Conv W32 ), -- TODO; rounding mode + ( "f2f64", flip MO_FF_Conv W64 ), -- TODO; rounding mode + ( "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 ), + + ( "w2f_bitcast", MO_WF_Bitcast ), + ( "f2w_bitcast", MO_FW_Bitcast ) + ] + +callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr])) +callishMachOps platform = listToUFM $ + map (\(x, y) -> (mkFastString x, y)) [ + + ( "pow64f", (MO_F64_Pwr,) ), + ( "sin64f", (MO_F64_Sin,) ), + ( "cos64f", (MO_F64_Cos,) ), + ( "tan64f", (MO_F64_Tan,) ), + ( "sinh64f", (MO_F64_Sinh,) ), + ( "cosh64f", (MO_F64_Cosh,) ), + ( "tanh64f", (MO_F64_Tanh,) ), + ( "asin64f", (MO_F64_Asin,) ), + ( "acos64f", (MO_F64_Acos,) ), + ( "atan64f", (MO_F64_Atan,) ), + ( "asinh64f", (MO_F64_Asinh,) ), + ( "acosh64f", (MO_F64_Acosh,) ), + ( "log64f", (MO_F64_Log,) ), + ( "log1p64f", (MO_F64_Log1P,) ), + ( "exp64f", (MO_F64_Exp,) ), + ( "expM164f", (MO_F64_ExpM1,) ), + ( "fabs64f", (MO_F64_Fabs,) ), + ( "sqrt64f", (MO_F64_Sqrt,) ), + + ( "pow32f", (MO_F32_Pwr,) ), + ( "sin32f", (MO_F32_Sin,) ), + ( "cos32f", (MO_F32_Cos,) ), + ( "tan32f", (MO_F32_Tan,) ), + ( "sinh32f", (MO_F32_Sinh,) ), + ( "cosh32f", (MO_F32_Cosh,) ), + ( "tanh32f", (MO_F32_Tanh,) ), + ( "asin32f", (MO_F32_Asin,) ), + ( "acos32f", (MO_F32_Acos,) ), + ( "atan32f", (MO_F32_Atan,) ), + ( "asinh32f", (MO_F32_Asinh,) ), + ( "acosh32f", (MO_F32_Acosh,) ), + ( "log32f", (MO_F32_Log,) ), + ( "log1p32f", (MO_F32_Log1P,) ), + ( "exp32f", (MO_F32_Exp,) ), + ( "expM132f", (MO_F32_ExpM1,) ), + ( "fabs32f", (MO_F32_Fabs,) ), + ( "sqrt32f", (MO_F32_Sqrt,) ), + + -- TODO: It would be nice to rename the following operations to + -- acquire_fence and release_fence. Be aware that there'll be issues + -- with an overlapping token ('acquire') in the lexer. + ( "fence_acquire", (MO_AcquireFence,)), + ( "fence_release", (MO_ReleaseFence,)), + ( "fence_seq_cst", (MO_SeqCstFence,)), + + ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ), + ( "memset", memcpyLikeTweakArgs MO_Memset ), + ( "memmove", memcpyLikeTweakArgs MO_Memmove ), + ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ), + + ( "suspendThread", (MO_SuspendThread,) ), + ( "resumeThread", (MO_ResumeThread,) ), + + ( "prefetch0", (MO_Prefetch_Data 0,)), + ( "prefetch1", (MO_Prefetch_Data 1,)), + ( "prefetch2", (MO_Prefetch_Data 2,)), + ( "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 + , allWidths "pext" MO_Pext + , allWidths "cmpxchg" MO_Cmpxchg + , allWidths "xchg" MO_Xchg + , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_acquire" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst) + , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease) + , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst) + , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add) + , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub) + , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And) + , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand) + , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or) + , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor) + , allWidths "mul2_" (\w -> MO_S_Mul2 w) + , allWidths "mul2u_" (\w -> MO_U_Mul2 w) + ] + where + allWidths + :: String + -> (Width -> CallishMachOp) + -> [(FastString, a -> (CallishMachOp, a))] + allWidths name f = + [ (mkFastString $ name ++ show (widthInBits w), (f w,)) + | w <- [W8, W16, W32, W64] + ] + + memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) + memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" + memcpyLikeTweakArgs op args@(_:_) = + (op align, args') + where + args' = init args + align = case last args of + CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger + e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e) + -- The alignment of memcpy-ish operations must be a + -- compile-time constant. We verify this here, passing it around + -- in the MO_* constructor. In order to do this, however, we + -- must intercept the arguments in primCall. + +parseSafety :: String -> PD Safety +parseSafety "safe" = return PlaySafe +parseSafety "unsafe" = return PlayRisky +parseSafety "interruptible" = return PlayInterruptible +parseSafety str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnrecognisedSafety str) + +parseCmmHint :: String -> PD ForeignHint +parseCmmHint "ptr" = return AddrHint +parseCmmHint "signed" = return SignedHint +parseCmmHint str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnrecognisedHint str) + +-- labels are always pointers, so we might as well infer the hint +inferCmmHint :: CmmExpr -> ForeignHint +inferCmmHint (CmmLit (CmmLabel _)) + = AddrHint +inferCmmHint (CmmReg (CmmGlobal reg)) + | isPtrGlobalRegUse reg + = AddrHint +inferCmmHint _ + = NoHint + +isPtrGlobalRegUse :: GlobalRegUse -> Bool +isPtrGlobalRegUse (GlobalRegUse reg ty) + | VanillaReg {} <- reg + , isGcPtrType ty + = True + | otherwise + = go reg + where + go Sp = True + go SpLim = True + go Hp = True + go HpLim = True + go CCCS = True + go CurrentTSO = True + go CurrentNursery = True + go _ = False + +happyError :: PD a +happyError = PD $ \_ _ s -> unP srcParseFail s + +-- ----------------------------------------------------------------------------- +-- Statement-level macros + +stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) +stmtMacro fun args_code = do + case lookupUFM stmtMacros fun of + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun) + Just fcode -> return $ do + args <- sequence args_code + code (fcode args) + +stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ()) +stmtMacros = listToUFM [ + ( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ), + ( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ), + + ( fsLit "CLOSE_NURSERY", \[] -> emitCloseNursery ), + ( fsLit "OPEN_NURSERY", \[] -> emitOpenNursery ), + + -- completely generic heap and stack checks, for use in high-level cmm. + ( fsLit "HP_CHK_GEN", \[bytes] -> + heapStackCheckGen Nothing (Just bytes) ), + ( fsLit "STK_CHK_GEN", \[] -> + heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ), + + -- A stack check for a fixed amount of stack. Sounds a bit strange, but + -- we use the stack for a bit of temporary storage in a couple of primops + ( fsLit "STK_CHK_GEN_N", \[bytes] -> + heapStackCheckGen (Just bytes) Nothing ), + + -- A stack check on entry to a thunk, where the argument is the thunk pointer. + ( fsLit "STK_CHK_NP" , \[node] -> entryHeapCheck' False node 0 [] (return ())), + + ( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ), + ( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ), + + ( 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_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 ), + + ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "PUSH_BH_UPD_FRAME", \[sp,e] -> emitPushBHUpdateFrame sp e ), + ( fsLit "SET_HDR", \[ptr,info,ccs] -> + emitSetDynHdr ptr info ccs ), + ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> + tickyAllocPrim hdr goods slop ), + ( fsLit "TICK_ALLOC_PAP", \[goods,slop] -> + tickyAllocPAP goods slop ), + ( fsLit "TICK_ALLOC_UP_THK", \[goods,slop] -> + tickyAllocThunk goods slop ), + ( fsLit "UPD_BH_UPDATABLE", \[reg] -> emitBlackHoleCode reg ) + ] + +emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushUpdateFrame sp e = do + emitUpdateFrame sp mkUpdInfoLabel e + +emitPushBHUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushBHUpdateFrame sp e = do + emitUpdateFrame sp mkBHUpdInfoLabel e + +pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () +pushStackFrame fields body = do + profile <- getProfile + exprs <- sequence fields + updfr_off <- getUpdFrameOff + let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old + [] updfr_off exprs + emit g + withUpdFrameOff new_updfr_off body + +reserveStackFrame + :: CmmParse CmmExpr + -> CmmParse CmmReg + -> CmmParse () + -> CmmParse () +reserveStackFrame psize preg body = do + platform <- getPlatform + old_updfr_off <- getUpdFrameOff + reg <- preg + esize <- psize + let size = case constantFoldExpr platform esize of + CmmLit (CmmInt n _) -> n + _other -> pprPanic "CmmParse: not a compile-time integer: " + (pdoc platform esize) + let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size + emitAssign reg (CmmStackSlot Old frame) + withUpdFrameOff frame body + +profilingInfo profile desc_str ty_str + = if not (profileIsProfiling profile) + then NoProfilingInfo + else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str) + +staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () +staticClosure pkg cl_label info payload + = do profile <- getProfile + let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] [] + code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits + +foreignCall + :: String + -> [CmmParse (LocalReg, ForeignHint)] + -> CmmParse CmmExpr + -> [CmmParse (CmmExpr, ForeignHint)] + -> Safety + -> CmmReturnInfo + -> PD (CmmParse ()) +foreignCall conv_string results_code expr_code args_code safety ret + = do conv <- case conv_string of + "C" -> return CCallConv + "stdcall" -> return StdCallConv + _ -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ + PsErrCmmParser (CmmUnknownCConv conv_string) + return $ do + platform <- getPlatform + results <- sequence results_code + expr <- expr_code + args <- sequence args_code + let + (arg_exprs, arg_hints) = unzip args + (res_regs, res_hints) = unzip results + fc = ForeignConvention conv arg_hints res_hints ret + target = ForeignTarget expr fc + _ <- code $ emitForeignCall safety res_regs target arg_exprs + return () + + +doReturn :: [CmmParse CmmExpr] -> CmmParse () +doReturn exprs_code = do + profile <- getProfile + exprs <- sequence exprs_code + updfr_off <- getUpdFrameOff + emit (mkReturnSimple profile exprs updfr_off) + +mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple profile actuals updfr_off = + mkReturn profile e actuals updfr_off + where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off)) + platform = profilePlatform profile + +doRawJump :: CmmParse CmmExpr -> [GlobalRegUse] -> CmmParse () +doRawJump expr_code vols = do + profile <- getProfile + expr <- expr_code + updfr_off <- getUpdFrameOff + emit (mkRawJump profile expr updfr_off vols) + +doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr] + -> [CmmParse CmmExpr] -> CmmParse () +doJumpWithStack expr_code stk_code args_code = do + profile <- getProfile + expr <- expr_code + stk_args <- sequence stk_code + args <- sequence args_code + updfr_off <- getUpdFrameOff + emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args) + +doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr] + -> CmmParse () +doCall expr_code res_code args_code = do + expr <- expr_code + args <- sequence args_code + ress <- sequence res_code + updfr_off <- getUpdFrameOff + c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off [] + emit c + +primCall + :: [CmmParse (CmmFormal, ForeignHint)] + -> FastString + -> [CmmParse CmmExpr] + -> PD (CmmParse ()) +primCall results_code name args_code + = do + platform <- PD.getPlatform + case lookupUFM (callishMachOps platform) name of + Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name) + Just f -> return $ do + results <- sequence results_code + args <- sequence args_code + let (p, args') = f args + code (emitPrimCall (map fst results) p args') + +doStore :: Maybe MemoryOrdering + -> CmmType + -> CmmParse CmmExpr -- ^ address + -> CmmParse CmmExpr -- ^ value + -> CmmParse () +doStore mem_ord rep addr_code val_code + = do platform <- getPlatform + addr <- addr_code + val <- val_code + -- if the specified store type does not match the type of the expr + -- on the rhs, then we insert a coercion that will cause the type + -- mismatch to be flagged by cmm-lint. If we don't do this, then + -- the store will happen at the wrong type, and the error will not + -- be noticed. + let val_width = typeWidth (cmmExprType platform val) + rep_width = typeWidth rep + let coerce_val + | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] + | otherwise = val + emitStore mem_ord addr coerce_val + +-- ----------------------------------------------------------------------------- +-- If-then-else and boolean expressions + +data BoolExpr + = BoolExpr `BoolAnd` BoolExpr + | BoolExpr `BoolOr` BoolExpr + | BoolNot BoolExpr + | BoolTest CmmExpr + +-- ToDo: smart constructors which simplify the boolean expression. + +cmmIfThenElse cond then_part else_part likely = do + then_id <- newBlockId + join_id <- newBlockId + c <- cond + emitCond c then_id likely + else_part + emit (mkBranch join_id) + emitLabel then_id + then_part + -- fall through to join + emitLabel join_id + +cmmRawIf cond then_id likely = do + c <- cond + emitCond c then_id likely + +-- 'emitCond cond true_id' emits code to test whether the cond is true, +-- branching to true_id if so, and falling through otherwise. +emitCond (BoolTest e) then_id likely = do + else_id <- newBlockId + emit (mkCbranch e then_id else_id likely) + emitLabel else_id +emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely + | Just op' <- maybeInvertComparison op + = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely) +emitCond (BoolNot e) then_id likely = do + else_id <- newBlockId + emitCond e else_id likely + emit (mkBranch then_id) + emitLabel else_id +emitCond (e1 `BoolOr` e2) then_id likely = do + emitCond e1 then_id likely + emitCond e2 then_id likely +emitCond (e1 `BoolAnd` e2) then_id likely = do + -- we'd like to invert one of the conditionals here to avoid an + -- extra branch instruction, but we can't use maybeInvertComparison + -- here because we can't look too closely at the expression since + -- we're in a loop. + and_id <- newBlockId + else_id <- newBlockId + emitCond e1 and_id likely + emit (mkBranch else_id) + emitLabel and_id + emitCond e2 then_id likely + emitLabel else_id + +-- ----------------------------------------------------------------------------- +-- Source code notes + +-- | Generate a source note spanning from "a" to "b" (inclusive), then +-- proceed with parsing. This allows debugging tools to reason about +-- locations in Cmm code. +withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c +withSourceNote a b parse = do + name <- getName + case combineSrcSpans (getLoc a) (getLoc b) of + RealSrcSpan span _ -> code (emitTick (SourceNote span $ LexicalFastString $ mkFastString name)) >> parse + _other -> parse + +-- ----------------------------------------------------------------------------- +-- Table jumps + +-- We use a simplified form of C-- switch statements for now. A +-- switch statement always compiles to a table jump. Each arm can +-- specify a list of values (not ranges), and there can be a single +-- default branch. The range of the table is given either by the +-- optional range on the switch (eg. switch [0..7] {...}), or by +-- the minimum/maximum values from the branches. + +doSwitch :: Maybe (Integer,Integer) + -> CmmParse CmmExpr + -> [([Integer],Either BlockId (CmmParse ()))] + -> Maybe (CmmParse ()) -> CmmParse () +doSwitch mb_range scrut arms deflt + = do + -- Compile code for the default branch + dflt_entry <- + case deflt of + Nothing -> return Nothing + Just e -> do b <- forkLabelledCode e; return (Just b) + + -- Compile each case branch + table_entries <- mapM emitArm arms + let table = M.fromList (concat table_entries) + + platform <- getPlatform + let range = fromMaybe (0, platformMaxWord platform) mb_range + + expr <- scrut + -- ToDo: check for out of range and jump to default if necessary + emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table) + where + emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)] + emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ] + emitArm (ints,Right code) = do + blockid <- forkLabelledCode code + return [ (i,blockid) | i <- ints ] + +forkLabelledCode :: CmmParse () -> CmmParse BlockId +forkLabelledCode p = do + (_,ag) <- getCodeScoped p + l <- newBlockId + emitOutOfLine l ag + return l + +-- ----------------------------------------------------------------------------- +-- Putting it all together + +-- The initial environment: we define some constants that the compiler +-- knows about here. +initEnv :: Profile -> Env +initEnv profile = listToUFM [ + ( fsLit "SIZEOF_StgHeader", + VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )), + ( fsLit "SIZEOF_StgInfoTable", + VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) )) + ] + where platform = profilePlatform profile + +parseCmmFile :: CmmParserConfig + -> Module + -> HomeUnit + -> FilePath + -> IO (Messages PsMessage, Messages PsMessage, Maybe (DCmmGroup, [InfoProvEnt])) +parseCmmFile cmmpConfig this_mod home_unit filename = do + buf <- hGetStringBuffer filename + let + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 + init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] } + -- reset the lex_state: the Lexer monad leaves some stuff + -- in there we don't want. + pdConfig = cmmpPDConfig cmmpConfig + case unPD cmmParse pdConfig home_unit init_state of + PFailed pst -> do + let (warnings,errors) = getPsMessages pst + return (warnings, errors, Nothing) + POk pst code -> do + st <- initC + let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig) + let fcode = do + ((), 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 topInfoTableD cmm) + | otherwise = [] + where + do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig + -- 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 diff --git a/GHC/Cmm/Pipeline.hs b/GHC/Cmm/Pipeline.hs --- a/GHC/Cmm/Pipeline.hs +++ b/GHC/Cmm/Pipeline.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} module GHC.Cmm.Pipeline ( cmmPipeline @@ -12,7 +11,7 @@ import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt import GHC.Cmm.CommonBlockElim -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label import GHC.Cmm.Info.Build import GHC.Cmm.Lint import GHC.Cmm.LayoutStack @@ -22,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 ( partitionWith ) import GHC.Platform import Control.Monad -import Data.Either (partitionEithers) +import GHC.Utils.Monad (mapAccumLM) ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline @@ -44,20 +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 - tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog - - let (procs, data_) = partitionEithers tops - (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: -- @@ -67,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 ---------------------------------- @@ -79,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 @@ -93,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 @@ -110,23 +117,23 @@ 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 -------------------------------- @@ -138,21 +145,21 @@ 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" #-} @@ -166,9 +173,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) @@ -351,12 +358,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 diff --git a/GHC/Cmm/ProcPoint.hs b/GHC/Cmm/ProcPoint.hs --- a/GHC/Cmm/ProcPoint.hs +++ b/GHC/Cmm/ProcPoint.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -25,9 +24,8 @@ 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.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label @@ -187,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 @@ -238,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 @@ -264,8 +262,8 @@ let liveness = cmmGlobalLiveness platform g - let ppLiveness pp = filter isArgReg $ regSetToList $ - expectJust "ppLiveness" $ mapLookup pp liveness + let ppLiveness pp = filter (isArgReg . globalRegUse_reg) $ regSetToList $ + expectJust $ mapLookup pp liveness graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g -- Build a map from proc point BlockId to pairs of: @@ -288,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 @@ -319,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 @@ -327,7 +325,7 @@ (jumpEnv, jumpBlocks) <- foldM add_jump_block (mapEmpty, []) needed_jumps -- update the entry block - let b = expectJust "block in env" $ mapLookup ppId blockEnv + let b = expectJust $ mapLookup ppId blockEnv blockEnv' = mapInsert ppId b blockEnv -- replace branches to procpoints with branches to jumps blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' @@ -345,7 +343,7 @@ stack_info = stack_info}) top_l live g' | otherwise - = case expectJust "pp label" $ mapLookup bid procLabels of + = case expectJust $ mapLookup bid procLabels of (lbl, Just info_lbl) -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl) , stack_info=stack_info}) @@ -379,8 +377,8 @@ foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int) (revPostorder g) let sort_fn (bid, _) (bid', _) = - compare (expectJust "block_order" $ mapLookup bid block_order) - (expectJust "block_order" $ mapLookup bid' block_order) + compare (expectJust $ mapLookup bid block_order) + (expectJust $ mapLookup bid' block_order) return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv diff --git a/GHC/Cmm/Reducibility.hs b/GHC/Cmm/Reducibility.hs --- a/GHC/Cmm/Reducibility.hs +++ b/GHC/Cmm/Reducibility.hs @@ -40,7 +40,6 @@ import GHC.Cmm import GHC.Cmm.BlockId import GHC.Cmm.Dataflow -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dominators import GHC.Cmm.Dataflow.Graph hiding (addBlock) @@ -48,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. @@ -82,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 @@ -98,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 @@ -182,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. @@ -213,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) diff --git a/GHC/Cmm/Reg.hs b/GHC/Cmm/Reg.hs --- a/GHC/Cmm/Reg.hs +++ b/GHC/Cmm/Reg.hs @@ -16,6 +16,8 @@ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg , GlobalRegUse(..), pprGlobalRegUse + + , GlobalArgRegs(..) ) where import GHC.Prelude @@ -61,14 +63,14 @@ -- See Note [GlobalReg vs GlobalRegUse] for more information. data GlobalRegUse = GlobalRegUse - { globalRegUseGlobalReg :: !GlobalReg + { globalRegUse_reg :: !GlobalReg -- ^ The underlying 'GlobalReg' - , globalRegUseType :: !CmmType + , globalRegUse_type :: !CmmType -- ^ The 'CmmType' at which we are using the 'GlobalReg'. -- -- Its width must be less than the width of the 'GlobalReg': -- - -- > typeWidth ty <= typeWidth (globalRegSpillType reg) + -- > typeWidth ty <= typeWidth (globalRegSpillType platform reg) } deriving Show @@ -101,7 +103,7 @@ cmmRegType :: CmmReg -> CmmType cmmRegType (CmmLocal reg) = localRegType reg -cmmRegType (CmmGlobal reg) = globalRegUseType reg +cmmRegType (CmmGlobal reg) = globalRegUse_type reg cmmRegWidth :: CmmReg -> Width cmmRegWidth = typeWidth . cmmRegType @@ -202,6 +204,13 @@ | LongReg -- long int registers (64-bit, really) {-# UNPACK #-} !Int -- its number + -- I think we should redesign 'GlobalReg', for example instead of + -- FloatReg/DoubleReg/XmmReg/YmmReg/ZmmReg we could have a single VecReg + -- which also stores the type we are storing in it. + -- + -- We might then be able to get rid of GlobalRegUse, as the type information + -- would already be contained in a 'GlobalReg'. + | XmmReg -- 128-bit SIMD vector register {-# UNPACK #-} !Int -- its number @@ -212,39 +221,40 @@ {-# UNPACK #-} !Int -- its number -- STG registers - | Sp -- Stack ptr; points to last occupied stack location. - | SpLim -- Stack limit - | Hp -- Heap ptr; points to last occupied heap location. - | HpLim -- Heap limit register - | CCCS -- Current cost-centre stack - | CurrentTSO -- pointer to current thread's TSO - | CurrentNursery -- pointer to allocation area - | HpAlloc -- allocation count for heap check failure + | Sp -- ^ Stack ptr; points to last occupied stack location. + | SpLim -- ^ Stack limit + | Hp -- ^ Heap ptr; points to last occupied heap location. + | HpLim -- ^ Heap limit register + | CCCS -- ^ Current cost-centre stack + | CurrentTSO -- ^ pointer to current thread's TSO + | CurrentNursery -- ^ pointer to allocation area + | HpAlloc -- ^ allocation count for heap check failure -- We keep the address of some commonly-called -- functions in the register table, to keep code -- size down: - | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info - | GCEnter1 -- stg_gc_enter_1 - | GCFun -- stg_gc_fun + | EagerBlackholeInfo -- ^ address of stg_EAGER_BLACKHOLE_info + | GCEnter1 -- ^ address of stg_gc_enter_1 + | GCFun -- ^ address of stg_gc_fun - -- Base offset for the register table, used for accessing registers + -- | Base offset for the register table, used for accessing registers -- which do not have real registers assigned to them. This register -- will only appear after we have expanded GlobalReg into memory accesses -- (where necessary) in the native code generator. | BaseReg - -- The register used by the platform for the C stack pointer. This is + -- | The register used by the platform for the C stack pointer. This is -- a break in the STG abstraction used exclusively to setup stack unwinding -- information. | MachSp - -- The is a dummy register used to indicate to the stack unwinder where + -- | A dummy register used to indicate to the stack unwinder where -- a routine would return to. | UnwindReturnReg - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs + -- | Base Register for PIC (position-independent code) calculations. + -- + -- Only used inside the native code generator. Its exact meaning differs -- from platform to platform (see module PositionIndependentCode). | PicBaseReg @@ -331,3 +341,24 @@ isArgReg (YmmReg {}) = True isArgReg (ZmmReg {}) = True isArgReg _ = False + +-- -------------------------------------------------------------------------- + +-- | Global registers used for argument passing. +-- +-- See Note [realArgRegsCover] in GHC.Cmm.CallConv. +data GlobalArgRegs + -- | General-purpose (integer) argument-passing registers. + = GP_ARG_REGS + -- | Scalar (integer & floating-point) argument-passing registers. + | SCALAR_ARG_REGS + -- | 16 byte vector argument-passing registers, together with + -- integer & floating-point argument-passing scalar registers. + | V16_ARG_REGS + -- | 32 byte vector argument-passing registers, together with + -- integer & floating-point argument-passing scalar registers. + | V32_ARG_REGS + -- | 64 byte vector argument-passing registers, together with + -- integer & floating-point argument-passing scalar registers. + | V64_ARG_REGS + deriving ( Show, Eq, Ord ) diff --git a/GHC/Cmm/Sink.hs b/GHC/Cmm/Sink.hs --- a/GHC/Cmm/Sink.hs +++ b/GHC/Cmm/Sink.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Cmm.Sink ( cmmSink @@ -14,14 +15,12 @@ import GHC.Cmm.Utils import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Platform.Regs import GHC.Platform import GHC.Types.Unique.FM -import qualified GHC.Data.Word64Set as Word64Set import Data.List (partition) import Data.Maybe @@ -175,7 +174,7 @@ -- 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) @@ -188,7 +187,7 @@ -- 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. @@ -215,7 +214,7 @@ live_sets' | should_drop = live_sets | otherwise = map upd live_sets - upd set | r `elemLRegSet` set = set `Word64Set.union` live_rhs + upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs | otherwise = set live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs @@ -520,7 +519,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. @@ -593,7 +592,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): -- @@ -704,7 +703,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 diff --git a/GHC/Cmm/Switch.hs b/GHC/Cmm/Switch.hs --- a/GHC/Cmm/Switch.hs +++ b/GHC/Cmm/Switch.hs @@ -4,7 +4,7 @@ SwitchTargets, mkSwitchTargets, switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned, - mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough, + mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough, switchTargetsToList, eqSwitchTargetWith, SwitchPlan(..), @@ -135,6 +135,11 @@ mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets mapSwitchTargets f (SwitchTargets signed range mbdef branches) = SwitchTargets signed range (fmap f mbdef) (fmap f branches) + +-- | Changes all labels mentioned in the SwitchTargets value +mapSwitchTargetsA :: Applicative m => (Label -> m Label) -> SwitchTargets -> m SwitchTargets +mapSwitchTargetsA f (SwitchTargets signed range mbdef branches) + = SwitchTargets signed range <$> traverse f mbdef <*> traverse f branches -- | Returns the list of non-default branches of the SwitchTargets value switchTargetsCases :: SwitchTargets -> [(Integer, Label)] diff --git a/GHC/Cmm/Switch/Implement.hs b/GHC/Cmm/Switch/Implement.hs --- a/GHC/Cmm/Switch/Implement.hs +++ b/GHC/Cmm/Switch/Implement.hs @@ -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) diff --git a/GHC/Cmm/ThreadSanitizer.hs b/GHC/Cmm/ThreadSanitizer.hs --- a/GHC/Cmm/ThreadSanitizer.hs +++ b/GHC/Cmm/ThreadSanitizer.hs @@ -6,7 +6,6 @@ import GHC.Prelude -import GHC.StgToCmm.Utils (get_GlobalReg_addr) import GHC.Platform import GHC.Platform.Regs (activeStgRegs, callerSaves) import GHC.Cmm @@ -20,28 +19,29 @@ import GHC.Types.ForeignCall import GHC.Types.Unique import GHC.Types.Unique.Supply +import GHC.Cmm.Dataflow.Label import Data.Maybe (fromMaybe) data Env = Env { platform :: Platform - , uniques :: [Unique] + , uniques :: UniqSupply } annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph annotateTSAN platform graph = do - env <- Env platform <$> getUniquesM - return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph + env <- Env platform <$> getUniqueSupplyM + 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 mapBlockList f (BlockCO n rest ) = f n `blockAppend` mapBlockList f rest mapBlockList f (BlockCC n rest m) = f n `blockAppend` mapBlockList f rest `blockAppend` f m mapBlockList f (BlockOC rest m) = mapBlockList f rest `blockAppend` f m -mapBlockList _ BNil = BNil -mapBlockList f (BMiddle blk) = f blk -mapBlockList f (BCat a b) = mapBlockList f a `blockAppend` mapBlockList f b -mapBlockList f (BSnoc a n) = mapBlockList f a `blockAppend` f n -mapBlockList f (BCons n a) = f n `blockAppend` mapBlockList f a +mapBlockList _ BNil = BNil +mapBlockList f (BMiddle blk) = f blk +mapBlockList f (BCat a b) = mapBlockList f a `blockAppend` mapBlockList f b +mapBlockList f (BSnoc a n) = mapBlockList f a `blockAppend` f n +mapBlockList f (BCons n a) = f n `blockAppend` mapBlockList f a annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x annotateBlock env = mapBlockList (annotateNode env) @@ -85,6 +85,7 @@ annotateExpr env expr = annotateLoads env (collectExprLoads expr) +-- | A load mentioned in a 'CmmExpr'. data Load = Load CmmType AlignmentSpec CmmExpr annotateLoads :: Env -> [Load] -> Block CmmNode O O @@ -103,6 +104,9 @@ collectExprLoads (CmmLit _) = [] collectExprLoads (CmmLoad e ty align) = [Load ty align e] collectExprLoads (CmmReg _) = [] +-- N.B. we don't bother telling TSAN about MO_RelaxedReads +-- since doing so would be inconvenient and they by +-- definition can neither race nor introduce ordering. collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args collectExprLoads (CmmStackSlot _ _) = [] collectExprLoads (CmmRegOff _ _) = [] @@ -114,10 +118,10 @@ -> [CmmActual] -- ^ arguments -> Maybe (Block CmmNode O O) -- ^ 'Just' a block of instrumentation, if applicable -annotatePrim env (MO_AtomicRMW w aop) [dest] [addr, val] = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest -annotatePrim env (MO_AtomicRead w mord) [dest] [addr] = Just $ tsanAtomicLoad env mord w addr dest -annotatePrim env (MO_AtomicWrite w mord) [] [addr, val] = Just $ tsanAtomicStore env mord w val addr -annotatePrim env (MO_Xchg w) [dest] [addr, val] = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest +annotatePrim env (MO_AtomicRMW w aop) [dest] [addr, val] = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest +annotatePrim env (MO_AtomicRead w mord) [dest] [addr] = Just $ tsanAtomicLoad env mord w addr dest +annotatePrim env (MO_AtomicWrite w mord) [] [addr, val] = Just $ tsanAtomicStore env mord w val addr +annotatePrim env (MO_Xchg w) [dest] [addr, val] = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest annotatePrim env (MO_Cmpxchg w) [dest] [addr, expected, new] = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest annotatePrim _ _ _ _ = Nothing @@ -133,14 +137,15 @@ call `blockAppend` -- perform call restore -- restore global registers where - -- We are rather conservative here and just save/restore all GlobalRegs. - (save, restore) = saveRestoreCallerRegs (platform env) + (save, restore) = saveRestoreCallerRegs gregs_us (platform env) + (arg_us, gregs_us) = splitUniqSupply (uniques env) + -- We also must be careful not to mention caller-saved registers in -- arguments as Cmm-Lint checks this. To accomplish this we instead bind -- the arguments to local registers. arg_regs :: [CmmReg] - arg_regs = zipWith arg_reg (uniques env) args + arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args where arg_reg :: Unique -> CmmExpr -> CmmReg arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr) @@ -150,34 +155,37 @@ call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs) -saveRestoreCallerRegs :: Platform +-- | We save the contents of global registers in locals and allow the +-- register allocator to spill them to the stack around the call. +-- We cannot use the register table for this since we would interface +-- with {SAVE,RESTORE}_THREAD_STATE. +saveRestoreCallerRegs :: UniqSupply -> Platform -> (Block CmmNode O O, Block CmmNode O O) -saveRestoreCallerRegs platform = +saveRestoreCallerRegs us platform = (save, restore) where - regs = filter (callerSaves platform) (activeStgRegs platform) - - save = blockFromList (map saveReg regs) - - saveReg :: GlobalReg -> CmmNode O O - saveReg reg = - CmmStore (get_GlobalReg_addr platform reg) - (CmmReg (CmmGlobal (GlobalRegUse reg ty))) - NaturallyAligned - where ty = globalRegSpillType platform reg + regs_to_save :: [GlobalReg] + regs_to_save = filter (callerSaves platform) (activeStgRegs platform) - restore = blockFromList (map restoreReg regs) + nodes :: [(CmmNode O O, CmmNode O O)] + nodes = + zipWith mk_reg regs_to_save (uniqsFromSupply us) + where + mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O) + mk_reg reg u = + let ty = globalRegSpillType platform reg + greg = CmmGlobal (GlobalRegUse reg ty) + lreg = CmmLocal (LocalReg u ty) + save = CmmAssign lreg (CmmReg greg) + restore = CmmAssign greg (CmmReg lreg) + in (save, restore) - restoreReg :: GlobalReg -> CmmNode O O - restoreReg reg = - CmmAssign (CmmGlobal (GlobalRegUse reg ty)) - (CmmLoad (get_GlobalReg_addr platform reg) - ty - NaturallyAligned) - where ty = globalRegSpillType platform reg + (save_nodes, restore_nodes) = unzip nodes + save = blockFromList save_nodes + restore = blockFromList restore_nodes -- | Mirrors __tsan_memory_order --- +-- memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr memoryOrderToTsanMemoryOrder env mord = mkIntExpr (platform env) n @@ -196,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) @@ -211,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) @@ -287,4 +297,3 @@ AMO_Or -> "fetch_or" AMO_Xor -> "fetch_xor" fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op' - diff --git a/GHC/Cmm/Type.hs b/GHC/Cmm/Type.hs --- a/GHC/Cmm/Type.hs +++ b/GHC/Cmm/Type.hs @@ -4,7 +4,7 @@ , cInt , cmmBits, cmmFloat , typeWidth, setCmmTypeWidth - , cmmEqType, cmmEqType_ignoring_ptrhood + , cmmEqType, cmmCompatType , isFloatType, isGcPtrType, isBitsType , isWordAny, isWord32, isWord64 , isFloat64, isFloat32 @@ -57,12 +57,14 @@ deriving Show data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - | VecCat Length CmmCat -- Vector + = GcPtrCat -- ^ GC pointer + | BitsCat -- ^ Integer (including non-GC pointer addresses) + -- + -- Makes no distinction between signed and unsigned integers, + -- see Note [Signed vs unsigned] in GHC.Cmm.Type. + | FloatCat -- ^ Float + | VecCat Length CmmCat -- ^ Vector deriving( Eq, Show ) - -- See Note [Signed vs unsigned] at the end instance Outputable CmmType where ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) @@ -87,21 +89,27 @@ cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 -cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool - -- This equality is temporary; used in CmmLint - -- but the RTS files are not yet well-typed wrt pointers -cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) - = c1 `weak_eq` c2 && w1==w2 +-- | A weaker notion of equality of 'CmmType's than 'cmmEqType', +-- used (only) in Cmm Lint. +-- +-- Why "weaker"? Because: +-- +-- - we don't distinguish GcPtr vs NonGcPtr, because the the RTS files +-- are not yet well-typed wrt pointers, +-- - for vectors, we only compare the widths, because in practice things like +-- X86 xmm registers support different types of data (e.g. 4xf32, 2xf64, 2xu64 etc). +cmmCompatType :: CmmType -> CmmType -> Bool +cmmCompatType (CmmType c1 w1) (CmmType c2 w2) + = c1 `weak_eq` c2 && w1 == w2 where weak_eq :: CmmCat -> CmmCat -> Bool - FloatCat `weak_eq` FloatCat = True - FloatCat `weak_eq` _other = False - _other `weak_eq` FloatCat = False - (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 - && cat1 `weak_eq` cat2 - (VecCat {}) `weak_eq` _other = False - _other `weak_eq` (VecCat {}) = False - _word1 `weak_eq` _word2 = True -- Ignores GcPtr + FloatCat `weak_eq` FloatCat = True + FloatCat `weak_eq` _other = False + _other `weak_eq` FloatCat = False + (VecCat {}) `weak_eq` (VecCat {}) = True -- only compare overall width + (VecCat {}) `weak_eq` _other = False + _other `weak_eq` (VecCat {}) = False + _word1 `weak_eq` _word2 = True -- Ignores GcPtr --- Simple operations on CmmType ----- typeWidth :: CmmType -> Width diff --git a/GHC/Cmm/UniqueRenamer.hs b/GHC/Cmm/UniqueRenamer.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/UniqueRenamer.hs @@ -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) diff --git a/GHC/Cmm/Utils.hs b/GHC/Cmm/Utils.hs --- a/GHC/Cmm/Utils.hs +++ b/GHC/Cmm/Utils.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE GADTs, RankNTypes #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ----------------------------------------------------------------------------- -- -- Cmm utilities. @@ -70,7 +67,7 @@ import GHC.Prelude import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) ) -import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 ) +import GHC.Types.RepType ( NvUnaryType, SlotTy (..), typePrimRepU ) import GHC.Platform import GHC.Runtime.Heap.Layout @@ -84,10 +81,10 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.Foldable (toList) import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections --------------------------------------------------- -- @@ -97,7 +94,6 @@ primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform @@ -136,11 +132,10 @@ primElemRepCmmType FloatElemRep = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType -typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty) +typeCmmType :: Platform -> NvUnaryType -> CmmType +typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty) primRepForeignHint :: PrimRep -> ForeignHint -primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint @@ -157,8 +152,8 @@ primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- @@ -524,14 +519,12 @@ -- | like 'toBlockList', but the entry block always comes first toBlockListEntryFirst :: CmmGraph -> [CmmBlock] -toBlockListEntryFirst g - | mapNull m = [] - | otherwise = entry_block : others +toBlockListEntryFirst g = do + entry_block <- toList $ mapLookup entry_id m + entry_block : filter ((/= entry_id) . entryLabel) (mapElems m) where m = toBlockMap g entry_id = g_entry g - Just entry_block = mapLookup entry_id m - others = filter ((/= entry_id) . entryLabel) (mapElems m) -- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks -- so that the false case of a conditional jumps to the next block in the output @@ -542,13 +535,10 @@ -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode -- defined in "GHC.Cmm.Node". -GBM toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock] -toBlockListEntryFirstFalseFallthrough g - | mapNull m = [] - | otherwise = dfs setEmpty [entry_block] +toBlockListEntryFirstFalseFallthrough g = dfs setEmpty $ toList $ mapLookup entry_id m where m = toBlockMap g entry_id = g_entry g - Just entry_block = mapLookup entry_id m dfs :: LabelSet -> [CmmBlock] -> [CmmBlock] dfs _ [] = [] diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs --- a/GHC/CmmToAsm.hs +++ b/GHC/CmmToAsm.hs @@ -5,17 +5,8 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UnboxedTuples #-} - --- | Native code generator +-- | Note [Native code generator] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The native-code generator has machine-independent and -- machine-dependent modules. @@ -23,51 +14,45 @@ -- This module ("GHC.CmmToAsm") is the top-level machine-independent -- module. Before entering machine-dependent land, we do some -- machine-independent optimisations (defined below) on the --- 'CmmStmts's. +-- 'CmmStmts's. (Which ideally would be folded into CmmOpt ...) -- -- We convert to the machine-specific 'Instr' datatype with -- 'cmmCodeGen', assuming an infinite supply of registers. We then use --- a machine-independent register allocator ('regAlloc') to rejoin +-- a (mostly) machine-independent register allocator to rejoin -- reality. Obviously, 'regAlloc' has machine-specific helper --- functions (see about "RegAllocInfo" below). +-- functions (see the used register allocator for details). -- -- Finally, we order the basic blocks of the function so as to minimise -- the number of jumps between blocks, by utilising fallthrough wherever -- possible. -- --- The machine-dependent bits break down as follows: +-- The machine-dependent bits are generally contained under +-- GHC/CmmToAsm//* and generally breaks down as follows: -- --- * ["MachRegs"] Everything about the target platform's machine +-- * "Regs": Everything about the target platform's machine -- registers (and immediate operands, and addresses, which tend to -- intermingle/interact with registers). -- --- * ["MachInstrs"] Includes the 'Instr' datatype (possibly should --- have a module of its own), plus a miscellany of other things +-- * "Instr": Includes the 'Instr' datatype plus a miscellany of other things -- (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) -- --- * ["MachCodeGen"] is where 'Cmm' stuff turns into +-- * "CodeGen": is where 'Cmm' stuff turns into -- machine instructions. -- --- * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really +-- * "Ppr": 'pprInstr' turns an 'Instr' into text (well, really -- a 'SDoc'). -- --- * ["RegAllocInfo"] In the register allocator, we manipulate --- 'MRegsState's, which are 'BitSet's, one bit per machine register. --- When we want to say something about a specific machine register --- (e.g., ``it gets clobbered by this instruction''), we set/unset --- its bit. Obviously, we do this 'BitSet' thing for efficiency --- reasons. --- --- The 'RegAllocInfo' module collects together the machine-specific --- info needed to do register allocation. +-- The register allocators lives under GHC.CmmToAsm.Reg.*, there is both a Linear and a Graph +-- based register allocator. Both of which have their own notes describing them. They +-- are mostly platform independent but there are some platform specific files +-- encoding architecture details under Reg// -- --- * ["RegisterAlloc"] The (machine-independent) register allocator. -- -} -- module GHC.CmmToAsm ( nativeCodeGen - -- * Test-only exports: see trac #12744 + -- * Test-only exports: see #12744 -- used by testGraphNoSpills, which needs to access -- the register allocator intermediate data structures -- cmmNativeGen emits @@ -82,6 +67,8 @@ 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 qualified GHC.CmmToAsm.LA64 as LA64 import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear as Linear @@ -110,15 +97,12 @@ import GHC.Cmm.BlockId import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Opt ( cmmMachOpFold ) +import GHC.Cmm.GenericOpt 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 @@ -127,7 +111,6 @@ import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Exception (evaluate) import GHC.Utils.Constants (debugIsOn) @@ -135,7 +118,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 @@ -148,14 +132,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) @@ -167,11 +151,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" - ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64" + ArchRISCV64 -> nCG' (RV64.ncgRV64 config) + ArchLoongArch64 -> nCG' (LA64.ncgLA64 config) ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" - ArchWasm32 -> Wasm32.ncgWasm 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. @@ -222,19 +206,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 @@ -242,23 +224,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 @@ -269,7 +252,7 @@ dump_stats (Color.pprStats stats graphGlobal) - let platform = ncgPlatform config + putDumpFileMaybe logger Opt_D_dump_asm_conflicts "Register conflict graph" FormatText @@ -284,14 +267,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" @@ -303,20 +286,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 @@ -324,35 +305,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. @@ -364,24 +343,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 @@ -409,7 +388,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 [] @@ -422,7 +407,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 @@ -443,18 +428,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 @@ -487,7 +473,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 @@ -505,7 +491,7 @@ else Nothing let (withLiveness, usLive) = {-# SCC "regLiveness" #-} - initUs usGen + runUniqueDSM usGen $ mapM (cmmTopLiveness livenessCfg platform) native putDumpFileMaybe logger @@ -518,7 +504,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 @@ -527,7 +513,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 @@ -537,13 +523,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 @@ -587,7 +573,7 @@ let ((alloced, regAllocStats, stack_updt_blks), usAlloc) = {-# SCC "RegAlloc-linear" #-} - initUs usLive + runUniqueDSM usLive $ liftM unzip3 $ mapM reg_alloc withLiveness @@ -659,7 +645,7 @@ -- sequenced :: [NatCmmDecl statics instr] let (sequenced, us_seq) = {-# SCC "sequenceBlocks" #-} - initUs usAlloc $ mapM (BlockLayout.sequenceTop + runUniqueDSM usAlloc $ mapM (BlockLayout.sequenceTop ncgImpl optimizedCFG) shorted @@ -692,7 +678,9 @@ , lastMinuteImports ++ imports , ppr_raStatsColor , ppr_raStatsLinear - , unwinds ) + , unwinds + , optimizedCFG + ) maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO () maybeDumpCfg _logger Nothing _ _ = return () @@ -929,7 +917,7 @@ -> LabelMap DebugBlock -> RawCmmDecl -> CFG - -> UniqSM + -> UniqDSM ( [NatCmmDecl statics instr] , [CLabel] , DwarfFiles @@ -937,208 +925,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) - } - --- ----------------------------------------------------------------------------- --- Generic Cmm optimiser - -{- -Here we do: - - (a) Constant folding - (c) Position independent code and dynamic linking - (i) introduce the appropriate indirections - and position independent refs - (ii) compile a list of imported symbols - (d) Some arch-specific optimizations - -(a) will be moving to the new Hoopl pipeline, however, (c) and -(d) are only needed by the native backend and will continue to live -here. - -Ideas for other things we could do (put these in Hoopl please!): - - - shortcut jumps-to-jumps - - simple CSE: if an expr is assigned to a temp, then replace later occs of - that expr with the temp, until the expr is no longer valid (can push through - temp assignments, and certain assigns to mem...) --} - -cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel]) -cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm config (CmmProc info lbl live graph) - = runCmmOpt config $ - do blocks' <- mapM cmmBlockConFold (toBlockList graph) - return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') - -type OptMResult a = (# a, [CLabel] #) - -pattern OptMResult :: a -> b -> (# a, b #) -pattern OptMResult x y = (# x, y #) -{-# 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 - -instance CmmMakeDynamicReferenceM CmmOptM where - addImport = addImportCmmOpt - -addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports) - -getCmmOptConfig :: CmmOptM NCGConfig -getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports - -runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel]) -runCmmOpt config (CmmOptM f) = - case f config [] of - OptMResult result imports -> (result, imports) - -cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock -cmmBlockConFold block = do - let (entry, middle, last) = blockSplit block - stmts = blockToList middle - stmts' <- mapM cmmStmtConFold stmts - last' <- cmmStmtConFold last - return $ blockJoin entry (blockFromList stmts') last' - --- This does three optimizations, but they're very quick to check, so we don't --- bother turning them off even when the Hoopl code is active. Since --- this is on the old Cmm representation, we can't reuse the code either: --- * reg = reg --> nop --- * if 0 then jump --> nop --- * if 1 then jump --> jump --- We might be tempted to skip this step entirely of not Opt_PIC, but --- there is some PowerPC code for the non-PIC case, which would also --- have to be separated. -cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x) -cmmStmtConFold stmt - = case stmt of - CmmAssign reg src - -> do src' <- cmmExprConFold DataReference src - return $ case src' of - CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") - new_src -> CmmAssign reg new_src - - CmmStore addr src align - -> do addr' <- cmmExprConFold DataReference addr - src' <- cmmExprConFold DataReference src - return $ CmmStore addr' src' align - - CmmCall { cml_target = addr } - -> do addr' <- cmmExprConFold JumpReference addr - return $ stmt { cml_target = addr' } - - CmmUnsafeForeignCall target regs args - -> do target' <- case target of - ForeignTarget e conv -> do - e' <- cmmExprConFold CallReference e - return $ ForeignTarget e' conv - PrimTarget _ -> - return target - args' <- mapM (cmmExprConFold DataReference) args - return $ CmmUnsafeForeignCall target' regs args' - - CmmCondBranch test true false likely - -> do test' <- cmmExprConFold DataReference test - return $ case test' of - CmmLit (CmmInt 0 _) -> CmmBranch false - CmmLit (CmmInt _ _) -> CmmBranch true - _other -> CmmCondBranch test' true false likely - - CmmSwitch expr ids - -> do expr' <- cmmExprConFold DataReference expr - return $ CmmSwitch expr' ids - - other - -> return other - -cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprConFold referenceKind expr = do - config <- getCmmOptConfig - - let expr' = if not (ncgDoConstantFolding config) - then expr - else cmmExprCon config expr - - cmmExprNative referenceKind expr' - -cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr -cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align -cmmExprCon config (CmmMachOp mop args) - = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) -cmmExprCon _ other = other - --- handles both PIC and non-PIC cases... a very strange mixture --- of things to do. -cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprNative referenceKind expr = do - config <- getCmmOptConfig - let platform = ncgPlatform config - arch = platformArch platform - case expr of - CmmLoad addr rep align - -> do addr' <- cmmExprNative DataReference addr - return $ CmmLoad addr' rep align - - CmmMachOp mop args - -> do args' <- mapM (cmmExprNative DataReference) args - return $ CmmMachOp mop args' - - CmmLit (CmmBlock id) - -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id))) - -- we must convert block Ids to CLabels here, because we - -- might have to do the PIC transformation. Hence we must - -- not modify BlockIds beyond this point. - - CmmLit (CmmLabel lbl) - -> cmmMakeDynamicReference config referenceKind lbl - CmmLit (CmmLabelOff lbl off) - -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl - -- need to optimize here, since it's late - return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [ - dynRef, - (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform)) - ] - - -- On powerpc (non-PIC), it's easier to jump directly to a label than - -- to use the register table, so we replace these registers - -- with the corresponding labels: - CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _)) - | arch == ArchPPC && not (ncgPIC config) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) - CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _)) - | arch == ArchPPC && not (ncgPIC config) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) - CmmReg (CmmGlobal (GlobalRegUse GCFun _)) - | arch == ArchPPC && not (ncgPIC config) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) - - other - -> return other + = 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 + } diff --git a/GHC/CmmToAsm/AArch64.hs b/GHC/CmmToAsm/AArch64.hs --- a/GHC/CmmToAsm/AArch64.hs +++ b/GHC/CmmToAsm/AArch64.hs @@ -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 diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -1,1937 +1,2505 @@ -{-# language GADTs #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NumericUnderscores #-} -module GHC.CmmToAsm.AArch64.CodeGen ( - cmmTopCodeGen - , generateJumpTableForInstr - , makeFarBranches -) - -where - --- NCG stuff: -import GHC.Prelude hiding (EQ) - -import Data.Word - -import GHC.Platform.Regs -import GHC.CmmToAsm.AArch64.Instr -import GHC.CmmToAsm.AArch64.Regs -import GHC.CmmToAsm.AArch64.Cond - -import GHC.CmmToAsm.CPrim -import GHC.Cmm.DebugBlock -import GHC.CmmToAsm.Monad - ( NatM, getNewRegNat - , getPicBaseMaybeNat, getPlatform, getConfig - , getDebugBlock, getFileId - ) --- import GHC.CmmToAsm.Instr -import GHC.CmmToAsm.PIC -import GHC.CmmToAsm.Format -import GHC.CmmToAsm.Config -import GHC.CmmToAsm.Types -import GHC.Platform.Reg -import GHC.Platform - --- Our intermediate code: -import GHC.Cmm.BlockId -import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch -import GHC.Cmm.CLabel -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Label -import GHC.Cmm.Dataflow.Graph -import GHC.Types.Tickish ( GenTickish(..) ) -import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -import GHC.Types.Unique.Supply - --- 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 -import GHC.Types.ForeignCall -import GHC.Data.FastString -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Monad (mapAccumLM) - -import GHC.Cmm.Dataflow.Collections - --- Note [General layout of an NCG] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- @cmmTopCodeGen@ will be our main entry point to code gen. Here we'll get --- @RawCmmDecl@; see GHC.Cmm --- --- RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph --- --- GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g --- | CmmData Section d --- --- As a result we want to transform this to a list of @NatCmmDecl@, which is --- defined @GHC.CmmToAsm.Instr@ as --- --- type NatCmmDecl statics instr --- = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr) --- --- Thus well' turn --- GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph --- into --- [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)] --- --- where @CmmGraph@ is --- --- type CmmGraph = GenCmmGraph CmmNode --- data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } --- type CmmBlock = Block CmmNode C C --- --- and @ListGraph Instr@ is --- --- newtype ListGraph i = ListGraph [GenBasicBlock i] --- data GenBasicBlock i = BasicBlock BlockId [i] - -cmmTopCodeGen - :: RawCmmDecl - -> NatM [NatCmmDecl RawCmmStatics Instr] - --- Thus we'll have to deal with either CmmProc ... -cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do - -- do - -- traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n" - -- ++ showSDocUnsafe (ppr cmm) - - let blocks = toBlockListEntryFirst graph - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks - picBaseMb <- getPicBaseMaybeNat - - let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) - tops = proc : concat statics - - case picBaseMb of - Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented" - Nothing -> return tops - --- ... or CmmData. -cmmTopCodeGen _cmm@(CmmData sec dat) = do - -- do - -- traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n" - -- ++ showSDocUnsafe (ppr cmm) - return [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 - -- do - -- traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n" - -- ++ showSDocUnsafe (ppr block) - 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 - 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 = 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 - -- 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 - - return (BasicBlock id top : other_blocks, statics) - -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 -ann :: SDoc -> Instr -> Instr -ann doc instr {- debugIsOn -} = ANN doc instr --- ann _ instr = instr -{-# INLINE ann #-} - --- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with --- -dppr-debug. The idea is that we can trivially see how a cmm expression --- ended up producing the assembly we see. By having the verbatim AST printed --- we can simply check the patterns that were matched to arrive at the assembly --- we generated. --- --- pprExpr will hide a lot of noise of the underlying data structure and print --- the expression into something that can be easily read by a human. However --- going back to the exact CmmExpr representation can be laborious and adds --- indirections to find the matches that lead to the assembly. --- --- An improvement oculd be to have --- --- (pprExpr genericPlatform e) <> parens (text. show e) --- --- to have the best of both worlds. --- --- Note: debugIsOn is too restrictive, it only works for debug compilers. --- However, we do not only want to inspect this for debug compilers. Ideally --- we'd have a check for -dppr-debug here already, such that we don't even --- generate the ANN expressions. However, as they are lazy, they shouldn't be --- forced until we actually force them, and without -dppr-debug they should --- never end up being forced. -annExpr :: CmmExpr -> Instr -> Instr -annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr --- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr --- annExpr _ instr = instr -{-# INLINE annExpr #-} - --- ----------------------------------------------------------------------------- --- Generating a table-branch - --- TODO jump tables would be a lot faster, but we'll use bare bones for now. --- this is usually done by sticking the jump table ids into an instruction --- and then have the @generateJumpTableForInstr@ callback produce the jump --- table as a static. --- --- See Ticket 19912 --- --- data SwitchTargets = --- SwitchTargets --- Bool -- Signed values --- (Integer, Integer) -- Range --- (Maybe Label) -- Default value --- (M.Map Integer Label) -- The branches --- --- Non Jumptable plan: --- xE <- expr --- -genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock -genSwitch expr targets = do -- pprPanic "genSwitch" (ppr expr) - (reg, format, code) <- getSomeReg expr - let w = formatToWidth format - let mkbranch acc (key, bid) = do - (keyReg, _format, code) <- getSomeReg (CmmLit (CmmInt key w)) - return $ code `appOL` - toOL [ CMP (OpReg w reg) (OpReg w keyReg) - , BCOND EQ (TBlock bid) - ] `appOL` acc - def_code = case switchTargetsDefault targets of - Just bid -> unitOL (B (TBlock bid)) - Nothing -> nilOL - - switch_code <- foldM mkbranch nilOL (switchTargetsCases targets) - return $ code `appOL` switch_code `appOL` def_code - --- We don't do jump tables for now, see Ticket 19912 -generateJumpTableForInstr :: NCGConfig -> Instr - -> Maybe (NatCmmDecl RawCmmStatics Instr) -generateJumpTableForInstr _ _ = Nothing - --- ----------------------------------------------------------------------------- --- 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 - 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 - -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n" - -- ++ showSDocUnsafe (ppr stmt) - platform <- getPlatform - case stmt of - CmmUnsafeForeignCall target result_regs args - -> genCCall target result_regs args bid - - _ -> (,Nothing) <$> case stmt of - CmmComment s -> return (unitOL (COMMENT (ftext s))) - CmmTick {} -> return nilOL - - CmmAssign reg src - | isFloatType ty -> assignReg_FltCode format reg src - | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType reg - format = cmmTypeFormat ty - - CmmStore addr src _alignment - | isFloatType ty -> assignMem_FltCode format addr src - | otherwise -> assignMem_IntCode format addr src - where ty = cmmExprType platform src - format = cmmTypeFormat ty - - CmmBranch id -> genBranch id - - --We try to arrange blocks such that the likely branch is the fallthrough - --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. - CmmCondBranch arg true false _prediction -> - genCondBranch bid true false arg - - CmmSwitch arg ids -> genSwitch arg ids - - CmmCall { cml_target = arg } -> genJump arg - - CmmUnwind _regs -> return nilOL - - _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) - --------------------------------------------------------------------------------- --- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. --- -type InstrBlock - = OrdList Instr - --- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. --- -data Register - = Fixed Format Reg InstrBlock - | Any Format (Reg -> InstrBlock) - --- | Sometimes we need to change the Format of a register. Primarily during --- conversion. -swizzleRegisterRep :: Format -> Register -> Register -swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code -swizzleRegisterRep format (Any _ codefn) = Any format codefn - --- | Grab the Reg for a CmmReg -getRegisterReg :: Platform -> CmmReg -> Reg - -getRegisterReg _ (CmmLocal (LocalReg u pk)) - = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) - -getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) - = case globalRegMaybe platform mid of - Just reg -> RegReal reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) - -- By this stage, the only MagicIds remaining should be the - -- ones which map to a real machine register on this - -- platform. Hence if it's not mapped to a registers something - -- went wrong earlier in the pipeline. --- | Convert a BlockId to some CmmStatic data --- TODO: Add JumpTable Logic, see Ticket 19912 --- jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic --- jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) --- jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) --- where blockLabel = blockLbl blockid - --- ----------------------------------------------------------------------------- --- General things for putting together code sequences - --- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. -getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) -getSomeReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, rep, code tmp) - Fixed rep reg code -> - return (reg, rep, code) - --- TODO OPT: we might be able give getRegister --- a hint, what kind of register we want. -getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) -getFloatReg expr = do - r <- getRegister expr - case r of - Any rep code | isFloatFormat rep -> do - tmp <- getNewRegNat rep - return (tmp, rep, code tmp) - Any II32 code -> do - tmp <- getNewRegNat FF32 - return (tmp, FF32, code tmp) - Any II64 code -> do - tmp <- getNewRegNat FF64 - return (tmp, FF64, code tmp) - Any _w _code -> do - config <- getConfig - pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) - -- can't do much for fixed. - Fixed rep reg code -> - return (reg, rep, code) - --- TODO: TODO, bounds. We can't put any immediate --- value in. They are constrained. --- See Ticket 19911 -litToImm' :: CmmLit -> NatM (Operand, InstrBlock) -litToImm' lit = return (OpImm (litToImm lit), nilOL) - -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 -- x -opRegWidth W32 = W32 -- w -opRegWidth W16 = W32 -- w -opRegWidth W8 = W32 -- w -opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) - --- Note [Signed arithmetic on AArch64] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Handling signed arithmetic on sub-word-size values on AArch64 is a bit --- tricky as Cmm's type system does not capture signedness. While 32-bit values --- are fairly easy to handle due to AArch64'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. --- --- TODO: --- Don't use Width in Operands --- Instructions should rather carry a RegWidth --- --- Note [Handling PIC on AArch64] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- AArch64 does not have a special PIC register, the general approach is to --- simply go through the GOT, and there is assembly support for this: --- --- // Load the address of 'sym' from the GOT using ADRP and LDR (used for --- // position-independent code on AArch64): --- adrp x0, #:got:sym --- ldr x0, [x0, #:got_lo12:sym] --- --- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions --- --- 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 AArch64. 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 _)) - -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg) - CmmLit lit - -> case lit of - - -- TODO handle CmmInt 0 specially, use wzr or xzr. - - CmmInt i W8 | i >= 0 -> do - return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) - CmmInt i W16 | i >= 0 -> do - return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) - - CmmInt i W8 -> do - return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) - CmmInt i W16 -> do - return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) - - -- We need to be careful to not shorten this for negative literals. - -- Those need the upper bits set. We'd either have to explicitly sign - -- or figure out something smarter. Lowered to - -- `MOV dst XZR` - CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do - return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i))))) - CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do - let half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) - return (Any (intFormat w) (\dst -> toOL [ annExpr expr - $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) - , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) - ])) - -- fallback for W32 - CmmInt i W32 -> do - let half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) - return (Any (intFormat W32) (\dst -> toOL [ annExpr expr - $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) - , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) - ])) - -- anything else - CmmInt i W64 -> do - let half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) - half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) - half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) - return (Any (intFormat W64) (\dst -> toOL [ annExpr expr - $ MOV (OpReg W64 dst) (OpImm (ImmInt half0)) - , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16) - , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32) - , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48) - ])) - CmmInt _i rep -> do - (op, imm_code) <- litToImm' lit - return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op))) - - -- floatToBytes (fromRational f) - CmmFloat 0 w -> do - (op, imm_code) <- litToImm' lit - return (Any (floatFormat w) (\dst -> imm_code `snocOL` 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 - half0 = fromIntegral (fromIntegral word :: Word16) - half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) - tmp <- getNewRegNat (intFormat W32) - return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr - $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0)) - , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16) - , MOV (OpReg W32 dst) (OpReg W32 tmp) - ])) - CmmFloat f W64 -> do - let word = castDoubleToWord64 (fromRational f) :: Word64 - half0 = fromIntegral (fromIntegral word :: Word16) - half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) - half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16) - half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16) - tmp <- getNewRegNat (intFormat W64) - return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr - $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0)) - , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16) - , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32) - , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48) - , MOV (OpReg W64 dst) (OpReg W64 tmp) - ])) - CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) - CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) - CmmLabel _lbl -> do - (op, imm_code) <- litToImm' lit - let rep = cmmLitType plat lit - format = cmmTypeFormat rep - return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op))) - - CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do - (op, imm_code) <- litToImm' lit - let rep = cmmLitType plat lit - format = cmmTypeFormat rep - -- width = typeWidth rep - return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op)) - - CmmLabelOff lbl off -> do - (op, imm_code) <- litToImm' (CmmLabel lbl) - let 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 -> imm_code `appOL` 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 - Amode addr addr_code <- getAmode plat (typeWidth rep) mem - let format = cmmTypeFormat rep - return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr))) - 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) - - - - -- 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` - MVN (OpReg w' dst) (OpReg w' reg) `appOL` - truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] - - 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) - - -- 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@ - -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend). - 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)) - - -- Conversions - MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e - - _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr) - where - toImm W8 = (OpImm (ImmInt 7)) - toImm W16 = (OpImm (ImmInt 15)) - toImm W32 = (OpImm (ImmInt 31)) - toImm W64 = (OpImm (ImmInt 63)) - toImm W128 = (OpImm (ImmInt 127)) - toImm W256 = (OpImm (ImmInt 255)) - toImm W512 = (OpImm (ImmInt 511)) - - -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits - -- See Note [Signed arithmetic on AArch64]. - 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 = - let w' = opRegWidth (max from to) - in return $ Any (intFormat to) $ \dst -> - code `snocOL` - SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL` - -- At this point an 8- or 16-bit value would be sign-extended - -- to 32-bits. Truncate back down the final width. - truncateReg w' to dst - - -- Dyadic machops: - -- - -- The general idea is: - -- compute x <- x - -- compute x <- y - -- OP x, x, x - -- - -- 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 _)] - | n > 0 && n < 4096 - , w == W32 || w == W64 -- Work around #23749 - -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) - -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. - where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) - r' = getRegisterReg plat reg - CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)] - | n > 0 && n < 4096 - , w == W32 || w == W64 -- Work around #23749 - -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) - -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. - where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) - r' = getRegisterReg plat reg - - CmmMachOp (MO_U_Quot 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 (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) - CmmMachOp (MO_U_Quot 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 (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (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 (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) - 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 (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) - - 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))))) - 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))) - - 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))))) - 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))) - - CmmMachOp (MO_S_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 (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) - - CmmMachOp (MO_S_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 (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) - - - 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 `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))) - CmmMachOp (MO_U_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 (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) - - 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 `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))) - CmmMachOp (MO_U_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 (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (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 (LSR (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 (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) - - -- 3. Logic &&, || - CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral 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 _)] | isAArch64Bitmask (fromIntegral n) -> - return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (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 - -- alright, so we have an operation, and two expressions. And we want to essentially do - -- ensure we get float regs (TODO(Ben): What?) - let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op - -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op - - -- A "plain" operation. - bitOp w op = do - -- compute x <- x - -- compute x <- y - -- x, x, x - (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 AArch64]. - intOp is_signed w op = do - -- compute x <- x - -- compute x <- y - -- x, x, x - (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)) - - -- Note [CSET] - -- ~~~~~~~~~~~ - -- Setting conditional flags: the architecture internally knows the - -- following flag bits. And based on thsoe comparisons as in the - -- table below. - -- - -- 31 30 29 28 - -- .---+---+---+---+-- - - - -- | N | Z | C | V | - -- '---+---+---+---+-- - - - -- Negative - -- Zero - -- Carry - -- oVerflow - -- - -- .------+-------------------------------------+-----------------+----------. - -- | Code | Meaning | Flags | Encoding | - -- |------+-------------------------------------+-----------------+----------| - -- | EQ | Equal | Z = 1 | 0000 | - -- | NE | Not Equal | Z = 0 | 0001 | - -- | HI | Unsigned Higher | C = 1 && Z = 0 | 1000 | - -- | HS | Unsigned Higher or Same | C = 1 | 0010 | - -- | LS | Unsigned Lower or Same | C = 0 || Z = 1 | 1001 | - -- | LO | Unsigned Lower | C = 0 | 0011 | - -- | GT | Signed Greater Than | Z = 0 && N = V | 1100 | - -- | GE | Signed Greater Than or Equal | N = V | 1010 | - -- | LE | Signed Less Than or Equal | Z = 1 || N /= V | 1101 | - -- | LT | Signed Less Than | N /= V | 1011 | - -- | CS | Carry Set (Unsigned Overflow) | C = 1 | 0010 | - -- | CC | Carry Clear (No Unsigned Overflow) | C = 0 | 0011 | - -- | VS | Signed Overflow | V = 1 | 0110 | - -- | VC | No Signed Overflow | V = 0 | 0111 | - -- | MI | Minus, Negative | N = 1 | 0100 | - -- | PL | Plus, Positive or Zero (!) | N = 0 | 0101 | - -- | AL | Always | Any | 1110 | - -- | NV | Never | Any | 1111 | - --- '-------------------------------------------------------------------------' - - -- 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 -> toOL [ CMP x y, CSET d EQ ]) - MO_Ne w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ]) - - -- Signed multiply/divide - MO_Mul w -> intOp True w (\d x y -> unitOL $ 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 $ SDIV d x y) - - -- No native rem instruction. So we'll compute the following - -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry - -- Rd' <- Rx - Rd * Ry | 1 <- 7 - 2 * 3 -- MSUB Rd' Rd Ry Rx - -- | '---|----------------|---' | - -- | '----------------|-------' - -- '--------------------------' - -- Note the swap in Rx and Ry. - MO_S_Rem w -> withTempIntReg w $ \t -> - intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) - - -- Unsigned multiply/divide - MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) - MO_U_Rem w -> withTempIntReg w $ \t -> - intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) - - -- Signed comparisons -- see Note [CSET] - MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ]) - MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ]) - MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ]) - MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) - - -- Unsigned comparisons - MO_U_Ge w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) - MO_U_Le w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) - MO_U_Gt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) - MO_U_Lt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) - - -- Floating point arithmetic - MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y) - 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) - - -- Floating point comparison - MO_F_Eq w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ]) - MO_F_Ne w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ]) - - -- careful with the floating point operations. - -- SLE is effectively LE or unordered (NaN) - -- SLT is the same. ULE, and ULT will not return true for NaN. - -- This is a bit counter-intuitive. Don't let yourself be fooled by - -- the S/U prefix for floats, it's only meaningful for integers. - MO_F_Ge w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ]) - MO_F_Le w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x - MO_F_Gt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ]) - MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x - - -- Bitwise operations - MO_And w -> bitOp w (\d x y -> unitOL $ AND d x y) - MO_Or w -> bitOp w (\d x y -> unitOL $ ORR d x y) - MO_Xor w -> bitOp w (\d x y -> unitOL $ EOR d x y) - MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y) - 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 - - 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 <=> AArch64 fmadd : d = r1 * r2 + r3 - -- x86 fmsub x * y - z <=> AArch64 fnmsub: d = r1 * r2 - r3 - -- 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) - - _ -> 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" - return $ - 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. - -- These implementations are based on output from GCC 11. - do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register - 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 - lo <- getNewRegNat II64 - hi <- getNewRegNat II64 - return $ Any (intFormat w) (\dst -> - code_x `appOL` - code_y `snocOL` - MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL` - SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL` - CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL` - CSET (OpReg w dst) NE) - - do_mul_may_oflo W32 x y = do - (reg_x, _format_x, code_x) <- getSomeReg x - (reg_y, _format_y, code_y) <- getSomeReg y - tmp1 <- getNewRegNat II64 - tmp2 <- getNewRegNat II64 - return $ Any (intFormat W32) (\dst -> - code_x `appOL` - code_y `snocOL` - SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL` - ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL` - CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL` - CSET (OpReg W32 dst) 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 - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 - let extend dst arg = - case w of - W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg) - W8 -> SXTB (OpReg W32 dst) (OpReg W32 arg) - _ -> panic "unreachable" - cmp_ext_mode = - case w of - W16 -> EUXTH - W8 -> EUXTB - _ -> panic "unreachable" - width = widthInBits w - opInt = OpImm . ImmInt - - return $ Any (intFormat w) (\dst -> - code_x `appOL` - code_y `snocOL` - extend tmp1 reg_x `snocOL` - extend tmp2 reg_y `snocOL` - MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL` - SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (opInt $ width - 1) (opInt 1) `snocOL` - UBFX (OpReg W32 tmp1) (OpReg W32 tmp1) (opInt width) (opInt width) `snocOL` - CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL` - CSET (OpReg w dst) NE) - --- | Is a given number encodable as a bitmask immediate? --- --- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly -isAArch64Bitmask :: Integer -> Bool --- N.B. zero and ~0 are not encodable as bitmask immediates -isAArch64Bitmask 0 = False -isAArch64Bitmask n - | n == bit 64 - 1 = False -isAArch64Bitmask n = - check 64 || check 32 || check 16 || check 8 - where - -- Check whether @n@ can be represented as a subpattern of the given - -- width. - check width - | hasOneRun subpat = - let n' = fromIntegral (mkPat width subpat) - in n == n' - | otherwise = False - where - subpat :: Word64 - subpat = fromIntegral (n .&. (bit width - 1)) - - -- Construct a bit-pattern from a repeated subpatterns the given width. - mkPat :: Int -> Word64 -> Word64 - mkPat width subpat = - foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ] - - -- Does the given number's bit representation match the regular expression - -- @0*1*0*@? - hasOneRun :: Word64 -> Bool - hasOneRun m = - 64 == popCount m + countLeadingZeros m + countTrailingZeros m - --- | 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 = - case w of - W64 -> noop - W32 - | w' == W32 -> noop - | otherwise -> extend SXTH - W16 -> extend SXTH - W8 -> extend SXTB - _ -> panic "intOp" - where - noop = return (r, nilOL) - extend instr = do - r' <- getNewRegNat II64 - return (r', unitOL $ instr (OpReg w' r') (OpReg w' r)) - --- | Instructions to truncate the value in the given register from width @w@ --- down to width @w'@. -truncateReg :: Width -> Width -> Reg -> OrdList Instr -truncateReg w w' r = - case w of - W64 -> nilOL - W32 - | w' == W32 -> nilOL - _ -> unitOL $ UBFM (OpReg w r) - (OpReg w r) - (OpImm (ImmInt 0)) - (OpImm $ ImmInt $ widthInBits w' - 1) - --- ----------------------------------------------------------------------------- --- The 'Amode' type: Memory addressing modes passed up the tree. -data Amode = Amode AddrMode InstrBlock - -getAmode :: Platform - -> Width -- ^ width of loaded value - -> CmmExpr - -> NatM Amode --- TODO: Specialize stuff we can destructure here. - --- OPTIMIZATION WARNING: Addressing modes. --- Addressing options: --- LDUR/STUR: imm9: -256 - 255 -getAmode platform _ (CmmRegOff reg off) | -256 <= off, off <= 255 - = return $ Amode (AddrRegImm reg' off') nilOL - where reg' = getRegisterReg platform reg - off' = ImmInt off --- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4 -getAmode platform W32 (CmmRegOff reg off) - | 0 <= off, off <= 16380, off `mod` 4 == 0 - = return $ Amode (AddrRegImm reg' off') nilOL - where reg' = getRegisterReg platform reg - off' = ImmInt off --- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8 -getAmode platform W64 (CmmRegOff reg off) - | 0 <= off, off <= 32760, off `mod` 8 == 0 - = 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')]) - | -256 <= off, off <= 255 - = do (reg, _format, code) <- getSomeReg expr - return $ Amode (AddrRegImm reg (ImmInteger off)) code - -getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) - | -256 <= -off, -off <= 255 - = 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 - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock -genJump expr@(CmmLit (CmmLabel lbl)) - = return $ unitOL (annExpr expr (J (TLabel lbl))) - -genJump expr = do - (target, _format, code) <- getSomeReg expr - return (code `appOL` unitOL (annExpr expr (J (TReg target)))) - --- ----------------------------------------------------------------------------- --- Unconditional branches -genBranch :: BlockId -> NatM InstrBlock -genBranch = return . toOL . mkJumpInstr - --- ----------------------------------------------------------------------------- --- Conditional branches -genCondJump - :: BlockId - -> CmmExpr - -> NatM InstrBlock -genCondJump bid expr = do - case expr of - -- Optimized == 0 case. - CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do - (reg_x, _format_x, code_x) <- getSomeReg x - return $ code_x `snocOL` (annExpr expr (CBZ (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 (CBNZ (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 - W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (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 - W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] - _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (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 - return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (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 OGT - MO_F_Ge w -> fbcond w OGE - MO_F_Lt w -> fbcond w OLT - MO_F_Le w -> fbcond w OLE - - 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 "AArch64.genCondJump:case mop: " (text $ show expr) - _ -> pprPanic "AArch64.genCondJump: " (text $ show expr) - --- A conditional jump with at least +/-128M jump range -genCondFarJump :: MonadUnique m => Cond -> Target -> m InstrBlock -genCondFarJump cond 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 [ BCOND cond (TBlock jmp_lbl_id) - , B (TBlock skip_lbl_id) - , NEWBLOCK jmp_lbl_id - , B far_target - , NEWBLOCK skip_lbl_id] - -genCondBranch - :: BlockId -- the 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 _ true false expr = do - b1 <- genCondJump true expr - b2 <- genBranch false - return (b1 `appOL` b2) - --- ----------------------------------------------------------------------------- --- 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. --- --- As per *convention*: --- x0-x7: (volatile) argument registers --- x8: (volatile) indirect result register / Linux syscall no --- x9-x15: (volatile) caller saved regs --- x16,x17: (volatile) intra-procedure-call registers --- x18: (volatile) platform register. don't use for portability --- x19-x28: (non-volatile) callee save regs --- x29: (non-volatile) frame pointer --- x30: link register --- x31: stack pointer / zero reg --- --- Thus, this is what a c function will expect. Find the arguments in x0-x7, --- anything above that on the stack. We'll ignore c functions with more than --- 8 arguments for now. Sorry. --- --- We need to make sure we preserve x9-x15, don't want to touch x16, x17. - --- Note [PLT vs GOT relocations] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- When linking objects together, we may need to lookup foreign references. That --- is symbolic references to functions or values in other objects. When --- compiling the object, we can not know where those elements will end up in --- memory (relative to the current location). Thus the use of symbols. There --- are two types of items we are interested, code segments we want to jump to --- and continue execution there (functions, ...), and data items we want to look --- up (strings, numbers, ...). For functions we can use the fact that we can use --- an intermediate jump without visibility to the programs execution. If we --- want to jump to a function that is simply too far away to reach for the B/BL --- instruction, we can create a small piece of code that loads the full target --- address and jumps to that on demand. Say f wants to call g, however g is out --- of range for a direct jump, we can create a function h in range for f, that --- will load the address of g, and jump there. The area where we construct h --- is called the Procedure Linking Table (PLT), we have essentially replaced --- f -> g with f -> h -> g. This is fine for function calls. However if we --- want to lookup values, this trick doesn't work, so we need something else. --- We will instead reserve a slot in memory, and have a symbol pointing to that --- slot. Now what we essentially do is, we reference that slot, and expect that --- slot to hold the final resting address of the data we are interested in. --- Thus what that symbol really points to is the location of the final data. --- The block of memory where we hold all those slots is the Global Offset Table --- (GOT). Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y]. --- --- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only --- have 19bits (+/- 1MB). Symbol lookups are also within +/- 1MB, thus for most --- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within --- 4GB of the PC, and load that. For anything outside of that range, we'd have --- to go through the GOT. --- --- adrp x0, --- add x0, :lo: --- --- will compute the address of int x0 if is within 4GB of the --- PC. --- --- If we want to get the slot in the global offset table (GOT), we can do this: --- --- adrp x0, #:got: --- ldr x0, [x0, #:got_lo12:] --- --- this will compute the address anywhere in the addressable 64bit space into --- x0, by loading the address from the GOT slot. --- --- To actually get the value of , we'd need to ldr x0, x0 still, which --- for the first case can be optimized to use ldr x0, [x0, #:lo12:] --- instead of the add instruction. --- --- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do --- not need to go through the GOT, unless we want to address the full address --- range within 64bit. - -genCCall - :: 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) --- TODO: Specialize where we can. --- Generic impl -genCCall target dest_regs arg_regs bid = do - -- we want to pass arg_regs into allArgRegs - -- pprTraceM "genCCall target" (ppr target) - -- pprTraceM "genCCall formal" (ppr dest_regs) - -- pprTraceM "genCCall actual" (ppr arg_regs) - - case target of - -- The target :: ForeignTarget call can either - -- be a foreign procedure with an address expr - -- and a calling convention. - ForeignTarget expr _cconv -> do - (call_target, call_target_code) <- case expr of - -- if this is a label, let's just directly to it. This will produce the - -- correct CALL relocation for BL... - (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) - -- ... if it's not a label--well--let's compute the expression into a - -- register and jump to that. See Note [PLT vs GOT relocations] - _ -> do (reg, _format, reg_code) <- getSomeReg expr - pure (TReg reg, reg_code) - -- compute the code and register logic for all arg_regs. - -- this will give us the format information to match on. - arg_regs' <- mapM getSomeReg arg_regs - - -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes - -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in - -- STG; this thenn breaks packing of stack arguments, if we need to pack - -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type - -- in Cmm proper. Option two, which we choose here is to use extended Hint - -- information to contain the size information and use that when packing - -- arguments, spilled onto the stack. - let (_res_hints, arg_hints) = foreignTargetHints target - arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints - - platform <- getPlatform - let packStack = platformOS platform == OSDarwin - - (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL - - -- if we pack the stack, we may need to adjust to multiple of 8byte. - -- if we don't pack the stack, it will always be multiple of 8. - let stackSpace = if stackSpace' `mod` 8 /= 0 - then 8 * (stackSpace' `div` 8 + 1) - else stackSpace' - - (returnRegs, 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 (regSingle 31)) (OpReg W64 (regSingle 31)) (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 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i))) - , POP_STACK_FRAME - , DELTA 0 ] - - let code = call_target_code -- compute the label (possibly into a register) - `appOL` moveStackDown (stackSpace `div` 8) - `appOL` passArgumentsCode -- put the arguments into x0, ... - `appOL` (unitOL $ BL call_target passRegs returnRegs) -- branch and link. - `appOL` readResultsCode -- parse the results into registers - `appOL` moveStackUp (stackSpace `div` 8) - return (code, Nothing) - - PrimTarget MO_F32_Fabs - | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> - unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg - PrimTarget MO_F64_Fabs - | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> - unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg - - -- or a possibly side-effecting machine operation - -- mop :: CallishMachOp (see GHC.Cmm.MachOp) - PrimTarget mop -> do - -- We'll need config to construct forien targets - case mop of - -- 64 bit float ops - MO_F64_Pwr -> mkCCall "pow" - - MO_F64_Sin -> mkCCall "sin" - MO_F64_Cos -> mkCCall "cos" - MO_F64_Tan -> mkCCall "tan" - - MO_F64_Sinh -> mkCCall "sinh" - MO_F64_Cosh -> mkCCall "cosh" - MO_F64_Tanh -> mkCCall "tanh" - - MO_F64_Asin -> mkCCall "asin" - MO_F64_Acos -> mkCCall "acos" - MO_F64_Atan -> mkCCall "atan" - - MO_F64_Asinh -> mkCCall "asinh" - MO_F64_Acosh -> mkCCall "acosh" - MO_F64_Atanh -> mkCCall "atanh" - - MO_F64_Log -> mkCCall "log" - MO_F64_Log1P -> mkCCall "log1p" - MO_F64_Exp -> mkCCall "exp" - MO_F64_ExpM1 -> mkCCall "expm1" - 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) - - -- Arithmatic - -- These are not supported on X86, so I doubt they are used much. - 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 - -- TODO DMBSY is probably *way* too much! - MO_ReadBarrier -> return (unitOL DMBSY, Nothing) - MO_WriteBarrier -> return (unitOL DMBSY, Nothing) - MO_Touch -> return (nilOL, Nothing) -- Keep variables live (when using interior pointers) - -- Prefetch - MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint. - - -- Memory copy/set/move/cmp, with alignment for optimization - - -- TODO Optimize and use e.g. quad registers to move memory around instead - -- of offloading this to memcpy. For small memcpys we can utilize - -- the 128bit quad registers in NEON to move block of bytes around. - -- Might also make sense of small memsets? Use xzr? What's the function - -- call overhead? - MO_Memcpy _align -> mkCCall "memcpy" - MO_Memset _align -> mkCCall "memset" - MO_Memmove _align -> mkCCall "memmove" - MO_Memcmp _align -> mkCCall "memcmp" - - MO_SuspendThread -> mkCCall "suspendThread" - MO_ResumeThread -> mkCCall "resumeThread" - - MO_PopCnt w -> mkCCall (popCntLabel w) - MO_Pdep w -> mkCCall (pdepLabel w) - MO_Pext w -> mkCCall (pextLabel w) - MO_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_AtomicRead w ord - | [p_reg] <- arg_regs - , [dst_reg] <- dest_regs -> do - (p, _fmt_p, code_p) <- getSomeReg p_reg - platform <- getPlatform - let instr = case ord of - MemOrderRelaxed -> LDR - _ -> LDAR - dst = getRegisterReg platform (CmmLocal dst_reg) - code = - code_p `snocOL` - instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p) - return (code, Nothing) - | otherwise -> panic "mal-formed AtomicRead" - MO_AtomicWrite w ord - | [p_reg, val_reg] <- arg_regs -> do - (p, _fmt_p, code_p) <- getSomeReg p_reg - (val, fmt_val, code_val) <- getSomeReg val_reg - let instr = case ord of - MemOrderRelaxed -> STR - _ -> STLR - code = - code_p `appOL` - code_val `snocOL` - instr fmt_val (OpReg w val) (OpAddr $ AddrReg p) - return (code, Nothing) - | 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, Maybe BlockId) - mkCCall name = do - config <- getConfig - target <- cmmMakeDynamicReference config CallReference $ - mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction - let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn - genCCall (ForeignTarget target cconv) dest_regs arg_regs bid - - -- TODO: Optimize using paired stores and loads (STP, LDP). It is - -- automatically done by the allocator for us. However it's not optimal, - -- as we'd rather want to have control over - -- all spill/load registers, so we can optimize with instructions like - -- STP xA, xB, [sp, #-16]! - -- and - -- LDP xA, xB, sp, #16 - -- - passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) - passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode) - -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace)) - -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1))) - -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do - -- -- allocate this on the stack - -- (r0, format0, code_r0) <- getSomeReg arg0 - -- (r1, format1, code_r1) <- getSomeReg arg1 - -- let w0 = formatToWidth format0 - -- w1 = formatToWidth format1 - -- stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8))) - -- passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode) - - -- float promotion. - -- According to - -- ISO/IEC 9899:2018 - -- Information technology — Programming languages — C - -- - -- e.g. - -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf - -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf - -- - -- GHC would need to know the prototype. - -- - -- > If the expression that denotes the called function has a type that does not include a - -- > prototype, the integer promotions are performed on each argument, and arguments that - -- > have type float are promoted to double. - -- - -- As we have no way to get prototypes for C yet, we'll *not* promote this - -- which is in line with the x86_64 backend :( - -- - -- See the encode_values.cmm test. - -- - -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg) - -- if w == W32. But *only* if we don't have a prototype m( - -- - -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture - -- - -- Still have GP regs, and we want to pass an GP argument. - - -- AArch64-Darwin: stack packing and alignment - -- - -- According to the "Writing ARM64 Code for Apple Platforms" document form - -- Apple, specifically the section "Handle Data Types and Data Alignment Properly" - -- we need to not only pack, but also align arguments on the stack. - -- - -- Data type Size (in bytes) Natural alignment (in bytes) - -- BOOL, bool 1 1 - -- char 1 1 - -- short 2 2 - -- int 4 4 - -- long 8 8 - -- long long 8 8 - -- pointer 8 8 - -- size_t 8 8 - -- NSInteger 8 8 - -- CFIndex 8 8 - -- fpos_t 8 8 - -- off_t 8 8 - -- - -- We can see that types are aligned by their sizes so the easiest way to - -- guarantee alignment during packing seems to be to pad to a multiple of the - -- size we want to pack. Failure to get this right can result in pretty - -- subtle bugs, e.g. #20137. - - passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do - platform <- getPlatform - let w = formatToWidth format - mov - -- Specifically, Darwin/AArch64's ABI requires that the caller - -- sign-extend arguments which are smaller than 32-bits. - | w < W32 - , platformCConvNeedsExtension platform - , SignedHint <- hint - = case w of - W8 -> SXTB (OpReg W64 gpReg) (OpReg w r) - W16 -> SXTH (OpReg W64 gpReg) (OpReg w r) - _ -> panic "impossible" - | otherwise - = MOV (OpReg w gpReg) (OpReg w r) - accumCode' = accumCode `appOL` - code_r `snocOL` - ann (text "Pass gp argument: " <> ppr r) mov - passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode' - - -- Still have FP regs, and we want to pass an FP argument. - passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace 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 pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode' - - -- No mor regs left to pass. Must pass on stack. - passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do - let w = formatToWidth format - bytes = widthInBits w `div` 8 - space = if pack then bytes else 8 - stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) - | otherwise = stackSpace - str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) - stackCode = code_r `snocOL` - ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str - passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) - - -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. - passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do - let w = formatToWidth format - bytes = widthInBits w `div` 8 - space = if pack then bytes else 8 - stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) - | otherwise = stackSpace - str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) - stackCode = code_r `snocOL` - ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str - passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) - - -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then. - passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do - let w = formatToWidth format - bytes = widthInBits w `div` 8 - space = if pack then bytes else 8 - stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) - | otherwise = stackSpace - str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) - stackCode = code_r `snocOL` - ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str - passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) - - passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") - - readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock) - readResults _ _ [] accumRegs accumCode = return (accumRegs, 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)) - - 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) - return (code, Nothing) - -{- Note [AArch64 far jumps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -AArch conditional jump instructions can only encode an offset of +/-1MB -which is usually enough but can be exceeded in edge cases. In these cases -we will replace: - - b.cond foo - -with the sequence: - - b.cond - b - : - b foo - : - -Note the encoding of the `b` instruction still limits jumps to -+/-128M offsets, but that seems like an acceptable limitation. - -Since AArch64 instructions are all of equal length we can reasonably estimate jumps -in range by counting the instructions between a jump and its target label. - -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 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. - --} - --- See Note [AArch64 far jumps] -data BlockInRange = InRange | NotInRange Target - --- See Note [AArch64 far jumps] -makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr] - -> UniqSM [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. - 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 - -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks - - where - -- 2^18, 19 bit immediate with one bit is reserved for the sign - max_jump_dist = 2^(18::Int) - 1 :: Int - -- Currently all inline info tables fit into 64 bytes. - max_info_size = 16 :: Int - long_bc_jump_size = 3 :: Int - 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 !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 -> UniqSM (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') +{-# language GADTs, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.CmmToAsm.AArch64.CodeGen ( + cmmTopCodeGen + , generateJumpTableForInstr + , makeFarBranches +) + +where + +-- NCG stuff: +import GHC.Prelude hiding (EQ) + +import Data.Word + +import GHC.Platform.Regs +import GHC.CmmToAsm.AArch64.Instr +import GHC.CmmToAsm.AArch64.Regs +import GHC.CmmToAsm.AArch64.Cond + +import GHC.CmmToAsm.CPrim +import GHC.Cmm.DebugBlock +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat + , getPicBaseMaybeNat, getPlatform, getConfig + , getDebugBlock, getFileId, getNewLabelNat, getThisModuleNat + ) +-- import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Types +import GHC.Platform.Reg +import GHC.Platform + +-- Our intermediate code: +import GHC.Cmm.BlockId +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.Dataflow.Graph +import GHC.Types.Tickish ( GenTickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) +import GHC.Types.Unique.DSM + +-- The rest: +import GHC.Data.OrdList +import GHC.Utils.Outputable + +import Control.Monad ( mapAndUnzipM ) +import GHC.Float + +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad (mapAccumLM) + +-- Note [General layout of an NCG] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- @cmmTopCodeGen@ will be our main entry point to code gen. Here we'll get +-- @RawCmmDecl@; see GHC.Cmm +-- +-- RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph +-- +-- GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g +-- | CmmData Section d +-- +-- As a result we want to transform this to a list of @NatCmmDecl@, which is +-- defined @GHC.CmmToAsm.Instr@ as +-- +-- type NatCmmDecl statics instr +-- = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr) +-- +-- Thus well' turn +-- GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph +-- into +-- [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)] +-- +-- where @CmmGraph@ is +-- +-- type CmmGraph = GenCmmGraph CmmNode +-- data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +-- type CmmBlock = Block CmmNode C C +-- +-- and @ListGraph Instr@ is +-- +-- newtype ListGraph i = ListGraph [GenBasicBlock i] +-- data GenBasicBlock i = BasicBlock BlockId [i] + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl RawCmmStatics Instr] + +-- Thus we'll have to deal with either CmmProc ... +cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do + -- do + -- traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n" + -- ++ showSDocUnsafe (ppr cmm) + + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + + case picBaseMb of + Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented" + Nothing -> return tops + +-- ... or CmmData. +cmmTopCodeGen _cmm@(CmmData sec dat) = do + -- do + -- traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n" + -- ++ showSDocUnsafe (ppr cmm) + return [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 + -- do + -- traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + -- ++ showSDocUnsafe (ppr block) + 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 + 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 <- 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 + -- 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 may extract + -- LDATAs here too (if they are implemented by AArch64 again - See + -- PPC how to do that.) + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + return (BasicBlock id top : other_blocks, statics) + +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 instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) +-- ----------------------------------------------------------------------------- +-- | Utilities +ann :: SDoc -> Instr -> Instr +ann doc instr {- debugIsOn -} = ANN doc instr +-- ann _ instr = 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 instr {- debugIsOn -} = ANN (text . show $ e) instr +-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr +-- annExpr _ instr = instr +{-# INLINE annExpr #-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +-- | 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 (LSL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))), + -- calculate table entry address + ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg), + -- load table entry (relative offset from tableReg (first entry) to target label) + LDR II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))), + -- calculate absolute address of the target label + ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg), + -- prepare jump to target label + J_TBL ids (Just lbl) targetReg + ] + return code + where + -- See Note [Sub-word subtlety during jump-table indexing] in + -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen. + indexExpr0 = cmmOffset platform expr offset + -- We widen to a native-width register to sanitize the high bits + indexExpr = + CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + expr_w = cmmExprWidth platform expr + (offset, ids) = switchTargetsToTable targets + platform = ncgPlatform config + +-- | Generate jump table data (if required) +-- +-- The idea is to emit one table entry per case. The entry is the relative +-- address of the block to jump to (relative to the table's first entry / +-- table's own label.) The calculation itself is done by the linker. +generateJumpTableForInstr :: + NCGConfig -> + Instr -> + Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (J_TBL ids (Just lbl) _) = + let jumpTable = + map jumpTableEntryRel ids + where + jumpTableEntryRel Nothing = + CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) = + CmmStaticLit + ( CmmLabelDiffOff + blockLabel + lbl + 0 + (ncgWordWidth config) + ) + where + blockLabel = blockLbl blockid + sectionType = case platformOS (ncgPlatform config) of + -- Aarch64 Windows platform requires LLVM 20 to support .rodata + OSMinGW32 -> Text + _ -> ReadOnlyData + in Just (CmmData (Section sectionType lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector + +stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements + -> NatM InstrBlock -- ^ Resulting instructions +stmtsToInstrs stmts = + go stmts nilOL + where + go [] instrs = return instrs + go (s:stmts) instrs = do + instrs' <- stmtToInstrs s + go stmts (instrs `appOL` instrs') + +stmtToInstrs :: CmmNode e x -- ^ Cmm Statement + -> NatM InstrBlock -- ^ Resulting Instructions +stmtToInstrs stmt = do + -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n" + -- ++ showSDocUnsafe (ppr stmt) + config <- getConfig + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + _ -> case stmt of + CmmComment s -> return (unitOL (COMMENT (ftext s))) + CmmTick {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType reg + format = cmmTypeFormat ty + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _prediction -> + genCondBranch true false arg + + CmmSwitch arg ids -> genSwitch config arg ids + + CmmCall { cml_target = arg } -> genJump arg + + CmmUnwind _regs -> return nilOL + + _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + +-- | Sometimes we need to change the Format of a register. Primarily during +-- conversion. +swizzleRegisterRep :: Format -> Register -> Register +swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code +swizzleRegisterRep format (Any _ codefn) = Any format codefn + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) + = case globalRegMaybe platform mid of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence if it's not mapped to a registers something + -- went wrong earlier in the pipeline. + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Fixed rep reg code -> + return (reg, rep, code) + +{- Note [Aarch64 immediates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Aarch64 with it's fixed width instruction encoding uses leftover space for +immediates. +If you want the full rundown consult the arch reference document: +"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate" + +The gist of it is that different instructions allow for different immediate encodings. +The ones we care about for better code generation are: + +* Simple but potentially repeated bit-patterns for logic instructions. +* 16bit numbers shifted by multiples of 16. +* 12 bit numbers optionally shifted by 12 bits. + +It might seem like the ISA allows for 64bit immediates but this isn't the case. +Rather there are some instruction aliases which allow for large unencoded immediates +which will then be transalted to one of the immediate encodings implicitly. + +For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16 +-} + +-- | Move (wide immediate) +-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits. +-- Used with MOVZ,MOVN, MOVK +-- See Note [Aarch64 immediates] +getMovWideImm :: Integer -> Width -> Maybe Operand +getMovWideImm n w + -- TODO: Handle sign extension/negatives + | n <= 0 + = Nothing + -- Fits in 16 bits + | sized_n < 2^(16 :: Int) + = Just $ OpImm (ImmInteger truncated) + + -- 0x0000 0000 xxxx 0000 + | trailing_zeros >= 16 && sized_n < 2^(32 :: Int) + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 16) SLSL 16 + + -- 0x 0000 xxxx 0000 0000 + | trailing_zeros >= 32 && sized_n < 2^(48 :: Int) + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 32) SLSL 32 + + -- 0x xxxx 0000 0000 0000 + | trailing_zeros >= 48 + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 48) SLSL 48 + + | otherwise + = Nothing + where + truncated = narrowU w n + sized_n = fromIntegral truncated :: Word64 + trailing_zeros = countTrailingZeros sized_n + +-- | Arithmetic(immediate) +-- Allows for 12bit immediates which can be shifted by 0 or 12 bits. +-- Used with ADD, ADDS, SUB, SUBS, CMP +-- See Note [Aarch64 immediates] +getArithImm :: Integer -> Width -> Maybe Operand +getArithImm n w + -- TODO: Handle sign extension + | n <= 0 + = Nothing + -- Fits in 16 bits + -- Fits in 12 bits + | sized_n < 2^(12::Int) + = Just $ OpImm (ImmInteger truncated) + + -- 12 bits shifted by 12 places. + | trailing_zeros >= 12 && sized_n < 2^(24::Int) + = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 12) SLSL 12 + + | otherwise + = Nothing + where + sized_n = fromIntegral truncated :: Word64 + truncated = narrowU w n + trailing_zeros = countTrailingZeros sized_n + +-- | Logical (immediate) +-- Allows encoding of some repeated bitpatterns +-- Used with AND, EOR, ORR +-- and their aliases which includes at least MOV (bitmask immediate) +-- See Note [Aarch64 immediates] +getBitmaskImm :: Integer -> Width -> Maybe Operand +getBitmaskImm n w + | isAArch64Bitmask (opRegWidth w) truncated = Just $ OpImm (ImmInteger truncated) + | otherwise = Nothing + where + truncated = narrowU w n + +-- | Load/store immediate. +-- Depends on the width of the store to some extent. +isOffsetImm :: Int -> Width -> Bool +isOffsetImm off w + -- 8 bits + sign for unscaled offsets + | -256 <= off, off <= 255 = True + -- Offset using 12-bit positive immediate, scaled by width + -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4 + -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8 + -- 16-bit: 0 .. 8188, 8-bit: 0 -- 4095 + | 0 <= off, off < 4096 * byte_width, off `mod` byte_width == 0 = True + | otherwise = False + where + byte_width = widthInBytes w + + + + +-- TODO OPT: we might be able give getRegister +-- a hint, what kind of register we want. +getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg expr = do + r <- getRegister expr + case r of + Any rep code | isFloatFormat rep -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Any II32 code -> do + tmp <- getNewRegNat FF32 + return (tmp, FF32, code tmp) + Any II64 code -> do + tmp <- getNewRegNat FF64 + return (tmp, FF64, code tmp) + Any _w _code -> do + config <- getConfig + pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) + -- can't do much for fixed. + Fixed rep reg code -> + return (reg, rep, code) + +-- TODO: TODO, bounds. We can't put any immediate +-- value in. They are constrained. +-- See Ticket 19911 +litToImm' :: CmmLit -> NatM (Operand, InstrBlock) +litToImm' lit = return (OpImm (litToImm lit), nilOL) + +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 -- x +opRegWidth W32 = W32 -- w +opRegWidth W16 = W32 -- w +opRegWidth W8 = W32 -- w +opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w) + +-- Note [Signed arithmetic on AArch64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Handling signed arithmetic on sub-word-size values on AArch64 is a bit +-- tricky as Cmm's type system does not capture signedness. While 32-bit values +-- are fairly easy to handle due to AArch64'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. +-- +-- TODO: +-- Don't use Width in Operands +-- Instructions should rather carry a RegWidth +-- +-- Note [Handling PIC on AArch64] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- AArch64 does not have a special PIC register, the general approach is to +-- simply go through the GOT, and there is assembly support for this: +-- +-- // Load the address of 'sym' from the GOT using ADRP and LDR (used for +-- // position-independent code on AArch64): +-- adrp x0, #:got:sym +-- ldr x0, [x0, #:got_lo12:sym] +-- +-- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions +-- +-- 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 AArch64. 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 _)) + -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg) + CmmLit lit + -> case lit of + + -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move. + -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed. + -- CmmInt 0 W32 -> do + -- let format = intFormat W32 + -- return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) )) + -- CmmInt 0 W64 -> do + -- let format = intFormat W64 + -- return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) )) + CmmInt i W8 | i >= 0 -> do + return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) + CmmInt i W16 | i >= 0 -> do + return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) + + CmmInt i W8 -> do + return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) + CmmInt i W16 -> do + return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) + + -- We need to be careful to not shorten this for negative literals. + -- Those need the upper bits set. We'd either have to explicitly sign + -- or figure out something smarter. Lowered to + -- `MOV dst XZR` + CmmInt i w | i >= 0 + , Just imm_op <- getMovWideImm i w -> do + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOVZ (OpReg w dst) imm_op))) + + CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i))))) + + CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + return (Any (intFormat w) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) + ])) + -- fallback for W32 + CmmInt i W32 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + return (Any (intFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16) + ])) + -- anything else + CmmInt i W64 -> do + let half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16) + return (Any (intFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 dst) (OpImm (ImmInt half0)) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32) + , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48) + ])) + CmmInt _i rep -> do + (op, imm_code) <- litToImm' lit + return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op))) + + -- floatToBytes (fromRational f) + CmmFloat 0 w -> do + (op, imm_code) <- litToImm' lit + return (Any (floatFormat w) (\dst -> imm_code `snocOL` 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 + half0 = fromIntegral (fromIntegral word :: Word16) + half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) + tmp <- getNewRegNat (intFormat W32) + return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0)) + , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16) + , MOV (OpReg W32 dst) (OpReg W32 tmp) + ])) + CmmFloat f W64 -> do + let word = castDoubleToWord64 (fromRational f) :: Word64 + half0 = fromIntegral (fromIntegral word :: Word16) + half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16) + half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16) + half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16) + tmp <- getNewRegNat (intFormat W64) + return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0)) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32) + , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48) + , MOV (OpReg W64 dst) (OpReg W64 tmp) + ])) + CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) + CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) + CmmLabel _lbl -> do + (op, imm_code) <- litToImm' lit + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op))) + + CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do + (op, imm_code) <- litToImm' lit + let rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op)) + + CmmLabelOff lbl off -> do + (op, imm_code) <- litToImm' (CmmLabel lbl) + let 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 -> imm_code `appOL` 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 + Amode addr addr_code <- getAmode plat (typeWidth rep) mem + let format = cmmTypeFormat rep + return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr))) + CmmStackSlot _ _ + -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) + CmmReg reg + -> return (Fixed (cmmTypeFormat (cmmRegType reg)) + (getRegisterReg plat reg) + nilOL) + CmmRegOff reg off -> + -- If we got here we will load the address into a register either way. So we might as well just expand + -- and re-use the existing code path to handle "reg + off". + let !width = cmmRegWidth reg + in getRegister' config plat (CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]) + + -- for MachOps, see GHC.Cmm.MachOp + -- For CmmMachOp, see GHC.Cmm.Expr + + -- 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) + + 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` + MVN (OpReg w' dst) (OpReg w' reg) `appOL` + truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] + + 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_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@ + -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend). + 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 + + 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_Neg {} -> 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)) + toImm W64 = (OpImm (ImmInt 63)) + toImm W128 = (OpImm (ImmInt 127)) + toImm W256 = (OpImm (ImmInt 255)) + toImm W512 = (OpImm (ImmInt 511)) + + -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits + -- See Note [Signed arithmetic on AArch64]. + 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 = + let w' = opRegWidth (max from to) + in return $ Any (intFormat to) $ \dst -> + code `snocOL` + SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL` + -- At this point an 8- or 16-bit value would be sign-extended + -- to 32-bits. Truncate back down the final width. + truncateReg w' to dst + + -- Dyadic machops: + -- + -- The general idea is: + -- compute x <- x + -- compute x <- y + -- OP x, x, x + -- + -- 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' + -- Immediates are handled via `getArithImm` in the generic code path. + + CmmMachOp (MO_U_Quot 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 (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` + (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + CmmMachOp (MO_U_Quot 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 (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` + (UDIV (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 || w == W64 + , 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + 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] + 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] + + 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] + 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] + + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] + | w == W32 || w == W64 + , 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + 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 `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))) + CmmMachOp (MO_U_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 (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` + (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + 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 `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))) + CmmMachOp (MO_U_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 (UXTH (OpReg w reg_x) (OpReg w reg_x)) + `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) + + CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] + | w == W32 || w == W64 + , 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + -- 3. Logic &&, || + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral 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 _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) -> + return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (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 + -- alright, so we have an operation, and two expressions. And we want to essentially do + -- ensure we get float regs (TODO(Ben): What?) + let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op + -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op + + -- A "plain" operation. + bitOpImm w op encode_imm = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (op_y, format_y, code_y) <- case y of + CmmLit (CmmInt n w) + | Just imm_operand_y <- encode_imm n w + -> return (imm_operand_y, intFormat w, nilOL) + _ -> do + (reg_y, format_y, code_y) <- getSomeReg y + return (OpReg w reg_y, format_y, code_y) + massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: incompatible" + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + op (OpReg w dst) (OpReg w reg_x) op_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 AArch64]. + intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register) + intOpImm {- is signed -} True w op _encode_imm = intOp True w op + intOpImm False w op encode_imm = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (op_y, format_y, code_y) <- case y of + CmmLit (CmmInt n w) + | Just imm_operand_y <- encode_imm n w + -> return (imm_operand_y, intFormat w, nilOL) + _ -> do + (reg_y, format_y, code_y) <- getSomeReg y + return (OpReg w reg_y, format_y, code_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 + return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + + -- 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 AArch64]. + intOp is_signed w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (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 -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) getArithImm + -- TODO: Handle sub-word case + MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) getArithImm + + -- Note [CSET] + -- ~~~~~~~~~~~ + -- Setting conditional flags: the architecture internally knows the + -- following flag bits. And based on thsoe comparisons as in the + -- table below. + -- + -- 31 30 29 28 + -- .---+---+---+---+-- - - + -- | N | Z | C | V | + -- '---+---+---+---+-- - - + -- Negative + -- Zero + -- Carry + -- oVerflow + -- + -- .------+-------------------------------------+-----------------+----------. + -- | Code | Meaning | Flags | Encoding | + -- |------+-------------------------------------+-----------------+----------| + -- | EQ | Equal | Z = 1 | 0000 | + -- | NE | Not Equal | Z = 0 | 0001 | + -- | HI | Unsigned Higher | C = 1 && Z = 0 | 1000 | + -- | HS | Unsigned Higher or Same | C = 1 | 0010 | + -- | LS | Unsigned Lower or Same | C = 0 || Z = 1 | 1001 | + -- | LO | Unsigned Lower | C = 0 | 0011 | + -- | GT | Signed Greater Than | Z = 0 && N = V | 1100 | + -- | GE | Signed Greater Than or Equal | N = V | 1010 | + -- | LE | Signed Less Than or Equal | Z = 1 || N /= V | 1101 | + -- | LT | Signed Less Than | N /= V | 1011 | + -- | CS | Carry Set (Unsigned Overflow) | C = 1 | 0010 | + -- | CC | Carry Clear (No Unsigned Overflow) | C = 0 | 0011 | + -- | VS | Signed Overflow | V = 1 | 0110 | + -- | VC | No Signed Overflow | V = 0 | 0111 | + -- | MI | Minus, Negative | N = 1 | 0100 | + -- | PL | Plus, Positive or Zero (!) | N = 0 | 0101 | + -- | AL | Always | Any | 1110 | + -- | NV | Never | Any | 1111 | + --- '-------------------------------------------------------------------------' + + -- N.B. We needn't sign-extend sub-word size (in)equality comparisons + -- since we don't care about ordering. + MO_Eq w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d EQ ]) getArithImm + MO_Ne w -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm + + -- Signed multiply/divide + MO_Mul w -> intOp True w (\d x y -> unitOL $ 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 $ SDIV d x y) + + -- No native rem instruction. So we'll compute the following + -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry + -- Rd' <- Rx - Rd * Ry | 1 <- 7 - 2 * 3 -- MSUB Rd' Rd Ry Rx + -- | '---|----------------|---' | + -- | '----------------|-------' + -- '--------------------------' + -- Note the swap in Rx and Ry. + MO_S_Rem w -> withTempIntReg w $ \t -> + intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) + + -- Unsigned multiply/divide + MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) + MO_U_Rem w -> withTempIntReg w $ \t -> + intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) + + -- Signed comparisons -- see Note [CSET] + MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ]) + MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ]) + MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ]) + MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) + + -- Unsigned comparisons + MO_U_Ge w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm + MO_U_Le w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm + MO_U_Gt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm + MO_U_Lt w -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm + + -- Floating point arithmetic + MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y) + 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 ]) + MO_F_Ne w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ]) + + -- careful with the floating point operations. + -- SLE is effectively LE or unordered (NaN) + -- SLT is the same. ULE, and ULT will not return true for NaN. + -- This is a bit counter-intuitive. Don't let yourself be fooled by + -- the S/U prefix for floats, it's only meaningful for integers. + MO_F_Ge w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ]) + MO_F_Le w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x + MO_F_Gt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ]) + MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x + + -- Bitwise operations + MO_And w -> bitOpImm w (\d x y -> unitOL $ AND d x y) getBitmaskImm + MO_Or w -> bitOpImm w (\d x y -> unitOL $ ORR d x y) getBitmaskImm + MO_Xor w -> bitOpImm w (\d x y -> unitOL $ EOR d x y) getBitmaskImm + MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y) + 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) + + -- 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 + + -- 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_Neg {} -> 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] -> + + case op of + + -- Floating-point fused multiply-add operations + + -- x86 fmadd x * y + z <=> AArch64 fmadd : d = r1 * r2 + r3 + -- x86 fmsub x * y - z <=> AArch64 fnmsub: d = r1 * r2 - r3 + -- 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 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 + (reg_fz, format_z, code_fz) <- getFloatReg z + massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $ + text "float3Op: non-float" + return $ + 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_bits i = let shift = n_bits - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + + -- N.B. MUL does not set the overflow flag. + -- These implementations are based on output from GCC 11. + do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + 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 + lo <- getNewRegNat II64 + hi <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL` + SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL` + CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL` + CSET (OpReg w dst) NE) + + do_mul_may_oflo W32 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II64 + tmp2 <- getNewRegNat II64 + return $ Any (intFormat W32) (\dst -> + code_x `appOL` + code_y `snocOL` + SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL` + ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL` + CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL` + CSET (OpReg W32 dst) 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 + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + let extend dst arg = + case w of + W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg) + W8 -> SXTB (OpReg W32 dst) (OpReg W32 arg) + _ -> panic "unreachable" + cmp_ext_mode = + case w of + W16 -> EUXTH + W8 -> EUXTB + _ -> panic "unreachable" + width = widthInBits w + opInt = OpImm . ImmInt + + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + extend tmp1 reg_x `snocOL` + extend tmp2 reg_y `snocOL` + MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL` + SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (opInt $ width - 1) (opInt 1) `snocOL` + UBFX (OpReg W32 tmp1) (OpReg W32 tmp1) (opInt width) (opInt width) `snocOL` + CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL` + CSET (OpReg w dst) NE) + +-- | Is a given number encodable as a bitmask immediate? +-- +-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly +isAArch64Bitmask :: Width -> Integer -> Bool +-- N.B. zero and ~0 are not encodable as bitmask immediates +isAArch64Bitmask width n = + assert (width `elem` [W32,W64]) $ + case n of + 0 -> False + _ | n == bit (widthInBits width) - 1 + -> False -- 1111...1111 + | otherwise + -> (width == W64 && check 64) || check 32 || check 16 || check 8 + where + -- Check whether @n@ can be represented as a subpattern of the given + -- width. + check width + | hasOneRun subpat = + let n' = fromIntegral (mkPat width subpat) + in n == n' + | otherwise = False + where + subpat :: Word64 + subpat = fromIntegral (n .&. (bit width - 1)) + + -- Construct a bit-pattern from a repeated subpatterns the given width. + mkPat :: Int -> Word64 -> Word64 + mkPat width subpat = + foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ] + + -- Does the given number's bit representation match the regular expression + -- @0*1*0*@? + hasOneRun :: Word64 -> Bool + hasOneRun m = + 64 == popCount m + countLeadingZeros m + countTrailingZeros m + +-- | 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 = + case w of + W64 -> noop + W32 + | w' == W32 -> noop + | otherwise -> extend SXTH + W16 -> extend SXTH + W8 -> extend SXTB + _ -> panic "intOp" + where + noop = return (r, nilOL) + extend instr = do + r' <- getNewRegNat II64 + return (r', unitOL $ instr (OpReg w' r') (OpReg w' r)) + +-- | Instructions to truncate the value in the given register from width @w@ +-- down to width @w'@. +truncateReg :: Width -> Width -> Reg -> OrdList Instr +truncateReg w w' r = + case w of + W64 -> nilOL + W32 + | w' == W32 -> nilOL + _ -> unitOL $ UBFM (OpReg w r) + (OpReg w r) + (OpImm (ImmInt 0)) + (OpImm $ ImmInt $ widthInBits w' - 1) + +-- ----------------------------------------------------------------------------- +-- The 'Amode' type: Memory addressing modes passed up the tree. +data Amode = Amode AddrMode InstrBlock + +getAmode :: Platform + -> Width -- ^ width of loaded value + -> CmmExpr + -> NatM Amode +-- TODO: Specialize stuff we can destructure here. + +-- OPTIMIZATION WARNING: Addressing modes. +-- Addressing options: +getAmode platform w (CmmRegOff reg off) + | isOffsetImm off w + = 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 w (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) + | isOffsetImm (fromIntegral off) w + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger off)) code + +getAmode _platform w (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) + | isOffsetImm (fromIntegral $ -off) w + = 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 + +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 = do + (target, _format, code) <- getSomeReg expr + return (code `appOL` unitOL (annExpr expr (J (TReg target)))) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump + :: BlockId + -> CmmExpr + -> NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (CBZ (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 (CBNZ (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 + W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (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 + W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ] + _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (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 + return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (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 OGT + MO_F_Ge w -> fbcond w OGE + MO_F_Lt w -> fbcond w OLT + MO_F_Le w -> fbcond w OLE + + 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 "AArch64.genCondJump:case mop: " (text $ show expr) + _ -> pprPanic "AArch64.genCondJump: " (text $ show expr) + +-- A conditional jump with at least +/-128M jump range +genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock +genCondFarJump cond 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 [ BCOND cond (TBlock jmp_lbl_id) + , B (TBlock skip_lbl_id) + , NEWBLOCK jmp_lbl_id + , B far_target + , NEWBLOCK skip_lbl_id] + +genCondBranch :: BlockId -- the true branch target + -> BlockId -- the false branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock -- Instructions + +genCondBranch true false expr = do + b1 <- genCondJump true expr + b2 <- genBranch false + return (b1 `appOL` b2) + +-- ----------------------------------------------------------------------------- +-- 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. +-- +-- As per *convention*: +-- x0-x7: (volatile) argument registers +-- x8: (volatile) indirect result register / Linux syscall no +-- x9-x15: (volatile) caller saved regs +-- x16,x17: (volatile) intra-procedure-call registers +-- x18: (volatile) platform register. don't use for portability +-- x19-x28: (non-volatile) callee save regs +-- x29: (non-volatile) frame pointer +-- x30: link register +-- x31: stack pointer / zero reg +-- +-- Thus, this is what a c function will expect. Find the arguments in x0-x7, +-- anything above that on the stack. We'll ignore c functions with more than +-- 8 arguments for now. Sorry. +-- +-- We need to make sure we preserve x9-x15, don't want to touch x16, x17. + +-- Note [PLT vs GOT relocations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When linking objects together, we may need to lookup foreign references. That +-- is symbolic references to functions or values in other objects. When +-- compiling the object, we can not know where those elements will end up in +-- memory (relative to the current location). Thus the use of symbols. There +-- are two types of items we are interested, code segments we want to jump to +-- and continue execution there (functions, ...), and data items we want to look +-- up (strings, numbers, ...). For functions we can use the fact that we can use +-- an intermediate jump without visibility to the programs execution. If we +-- want to jump to a function that is simply too far away to reach for the B/BL +-- instruction, we can create a small piece of code that loads the full target +-- address and jumps to that on demand. Say f wants to call g, however g is out +-- of range for a direct jump, we can create a function h in range for f, that +-- will load the address of g, and jump there. The area where we construct h +-- is called the Procedure Linking Table (PLT), we have essentially replaced +-- f -> g with f -> h -> g. This is fine for function calls. However if we +-- want to lookup values, this trick doesn't work, so we need something else. +-- We will instead reserve a slot in memory, and have a symbol pointing to that +-- slot. Now what we essentially do is, we reference that slot, and expect that +-- slot to hold the final resting address of the data we are interested in. +-- Thus what that symbol really points to is the location of the final data. +-- The block of memory where we hold all those slots is the Global Offset Table +-- (GOT). Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y]. +-- +-- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only +-- have 19bits (+/- 1MB). Symbol lookups are also within +/- 1MB, thus for most +-- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within +-- 4GB of the PC, and load that. For anything outside of that range, we'd have +-- to go through the GOT. +-- +-- adrp x0, +-- add x0, :lo: +-- +-- will compute the address of int x0 if is within 4GB of the +-- PC. +-- +-- If we want to get the slot in the global offset table (GOT), we can do this: +-- +-- adrp x0, #:got: +-- ldr x0, [x0, #:got_lo12:] +-- +-- this will compute the address anywhere in the addressable 64bit space into +-- x0, by loading the address from the GOT slot. +-- +-- To actually get the value of , we'd need to ldr x0, x0 still, which +-- for the first case can be optimized to use ldr x0, [x0, #:lo12:] +-- instead of the add instruction. +-- +-- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do +-- not need to go through the GOT, unless we want to address the full address +-- range within 64bit. + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +-- TODO: Specialize where we can. +-- Generic impl +genCCall target dest_regs arg_regs = do + -- we want to pass arg_regs into allArgRegs + -- pprTraceM "genCCall target" (ppr target) + -- pprTraceM "genCCall formal" (ppr dest_regs) + -- pprTraceM "genCCall actual" (ppr arg_regs) + platform <- getPlatform + case target of + -- The target :: ForeignTarget call can either + -- be a foreign procedure with an address expr + -- and a calling convention. + ForeignTarget expr _cconv -> do + (call_target, call_target_code) <- case expr of + -- if this is a label, let's just directly to it. This will produce the + -- correct CALL relocation for BL... + (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) + -- ... if it's not a label--well--let's compute the expression into a + -- register and jump to that. See Note [PLT vs GOT relocations] + _ -> do (reg, _format, reg_code) <- getSomeReg expr + pure (TReg reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this thenn breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + let (_res_hints, arg_hints) = foreignTargetHints target + arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints + + let packStack = platformOS platform == OSDarwin + + (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL + + -- if we pack the stack, we may need to adjust to multiple of 8byte. + -- if we don't pack the stack, it will always be multiple of 8. + let stackSpace = if stackSpace' `mod` 8 /= 0 + then 8 * (stackSpace' `div` 8 + 1) + else stackSpace' + + 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 (regSingle 31)) (OpReg W64 (regSingle 31)) (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 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i))) + , POP_STACK_FRAME + , DELTA 0 ] + + let code = call_target_code -- compute the label (possibly into a register) + `appOL` moveStackDown (stackSpace `div` 8) + `appOL` passArgumentsCode -- put the arguments into x0, ... + `appOL` (unitOL $ BL call_target passRegs) -- branch and link. + `appOL` readResultsCode -- parse the results into registers + `appOL` moveStackUp (stackSpace `div` 8) + return code + + PrimTarget MO_F32_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Fabs" + PrimTarget MO_F64_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Fabs" + PrimTarget MO_F32_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Sqrt" + PrimTarget MO_F64_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Sqrt" + + + PrimTarget (MO_S_Mul2 w) + -- Life is easier when we're working with word sized operands, + -- we can use SMULH to compute the high 64 bits, and dst_needed + -- checks if the high half's bits are all the same as the low half's + -- top bit. + | w == W64 + , [src_a, src_b] <- arg_regs + -- dst_needed = did the result fit into just the low half + , [dst_needed, dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + nd = getRegisterReg platform (CmmLocal dst_needed) + return $ + code_x `appOL` + code_y `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL` + -- Are all high bits equal to the sign bit of the low word? + -- 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 + -- 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. + -- Currently this case can't be generated since + -- timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #) + -- TODO: Should this be removed or would other primops be useful? + | w < W64 + , [src_a, src_b] <- arg_regs + , [dst_needed, dst_hi, dst_lo] <- dest_regs + -> do + (reg_a', _format_x, code_a) <- getSomeReg src_a + (reg_b', _format_y, code_b) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + nd = getRegisterReg platform (CmmLocal dst_needed) + -- Do everything in a full 64 bit registers + w' = platformWordWidth platform + + (reg_a, code_a') <- signExtendReg w w' reg_a' + (reg_b, code_b') <- signExtendReg w w' reg_b' + + return $ + code_a `appOL` + code_b `appOL` + code_a' `appOL` + code_b' `snocOL` + -- the low 2w' of lo contains the full multiplication; + -- eg: int8 * int8 -> int16 result + -- so lo is in the last w of the register, and hi is in the second w. + SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL` + -- Make sure we hold onto the sign bits for dst_needed + ASR (OpReg w' hi) (OpReg w' lo) (OpImm (ImmInt $ widthInBits w)) `appOL` + -- lo can now be truncated so we can get at it's top bit easily. + truncateReg w' w lo `snocOL` + -- Note the use of CMN (compare negative), not CMP: we want to + -- test if the top half is negative one and the top + -- bit of the bottom half is positive one. eg: + -- hi = 0b1111_1111 (actually 64 bits) + -- lo = 0b1010_1111 (-81, so the result didn't need the top half) + -- lo' = ASR(lo,7) (second reg of SMN) + -- = 0b0000_0001 (theeshift gives us 1 for negative, + -- and 0 for positive) + -- hi == -lo'? + -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow) + -- Another way to think of this is if hi + lo' == 0, which is what + -- CMN really is under the hood. + CMN (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL` + -- Set dst_needed to 1 if hi and lo' were (negatively) equal + CSET (OpReg w' nd) EQ `appOL` + -- Finally truncate hi to drop any extraneous sign bits. + truncateReg w' w hi + -- Can't handle > 64 bit operands + | otherwise -> unsupported (MO_S_Mul2 w) + PrimTarget (MO_U_Mul2 w) + -- The unsigned case is much simpler than the signed, all we need to + -- do is the multiplication straight into the destination registers. + | w == W64 + , [src_a, src_b] <- arg_regs + , [dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + return ( + code_x `appOL` + 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) + ) + -- 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. + -- Currently this case can't be produced by the compiler since + -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #) + -- TODO: Remove? Or would the extra primop be useful for avoiding the extra + -- steps needed to do this in userland? + | w < W64 + , [src_a, src_b] <- arg_regs + , [dst_hi, dst_lo] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src_a + (reg_b, _format_y, code_y) <- getSomeReg src_b + + let lo = getRegisterReg platform (CmmLocal dst_lo) + hi = getRegisterReg platform (CmmLocal dst_hi) + w' = opRegWidth w + return ( + code_x `appOL` + code_y `snocOL` + -- UMULL: Xd = Wa * Wb with 64 bit result + -- W64 inputs should have been caught by case above + UMULL (OpReg W64 lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL` + -- Extract and truncate high result + -- hi[w:0] = lo[2w:w] + UBFX (OpReg W64 hi) (OpReg W64 lo) + (OpImm (ImmInt $ widthInBits w)) -- lsb + (OpImm (ImmInt $ widthInBits w)) -- width to extract + `appOL` + truncateReg W64 w lo + ) + | otherwise -> unsupported (MO_U_Mul2 w) + PrimTarget (MO_Clz w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return ( + code_x `snocOL` + CLZ (OpReg w dst_reg) (OpReg w reg_a) + ) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(x << 16 | 0x0000_8000) -} + return ( + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 16) + , ORR (r dst') (r dst') (imm 0x00008000) + , CLZ (r dst') (r dst') + ] + ) + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(x << 24 | 0x0080_0000) -} + 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') + ] + | otherwise -> unsupported (MO_Clz w) + PrimTarget (MO_Ctz w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return $ + code_x `snocOL` + RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL` + CLZ (OpReg w dst_reg) (OpReg w dst_reg) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(reverseBits(x) | 0x0000_8000) -} + return $ + code_x `appOL` toOL + [ RBIT (r dst') (r reg_a) + , ORR (r dst') (r dst') (imm 0x00008000) + , CLZ (r dst') (r dst') + ] + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = clz(reverseBits(x) | 0x0080_0000) -} + return $ + code_x `appOL` toOL + [ RBIT (r dst') (r reg_a) + , ORR (r dst') (r dst') (imm 0x00800000) + , CLZ (r dst') (r dst') + ] + | otherwise -> unsupported (MO_Ctz w) + PrimTarget (MO_BRev w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst_reg = getRegisterReg platform (CmmLocal dst) + return $ + code_x `snocOL` + RBIT (OpReg w dst_reg) (OpReg w reg_a) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = reverseBits32(x << 16) -} + return $ + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 16) + , RBIT (r dst') (r dst') + ] + | w == W8 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + r n = OpReg W32 n + imm n = OpImm (ImmInt n) + {- dst = reverseBits32(x << 24) -} + return $ + code_x `appOL` toOL + [ LSL (r dst') (r reg_a) (imm 24) + , RBIT (r dst') (r dst') + ] + | otherwise -> unsupported (MO_BRev w) + PrimTarget (MO_BSwap w) + | w == W64 || w == W32 + , [src] <- arg_regs + , [dst] <- dest_regs + -> 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) + | w == W16 + , [src] <- arg_regs + , [dst] <- dest_regs + -> do + (reg_a, _format_x, code_x) <- getSomeReg src + let dst' = getRegisterReg platform (CmmLocal dst) + 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) + | otherwise -> unsupported (MO_BSwap w) + + -- or a possibly side-effecting machine operation + -- mop :: CallishMachOp (see GHC.Cmm.MachOp) + PrimTarget mop -> do + -- We'll need config to construct forien targets + case mop of + -- 64 bit float ops + MO_F64_Pwr -> mkCCall "pow" + + MO_F64_Sin -> mkCCall "sin" + MO_F64_Cos -> mkCCall "cos" + MO_F64_Tan -> mkCCall "tan" + + MO_F64_Sinh -> mkCCall "sinh" + MO_F64_Cosh -> mkCCall "cosh" + MO_F64_Tanh -> mkCCall "tanh" + + MO_F64_Asin -> mkCCall "asin" + MO_F64_Acos -> mkCCall "acos" + MO_F64_Atan -> mkCCall "atan" + + MO_F64_Asinh -> mkCCall "asinh" + MO_F64_Acosh -> mkCCall "acosh" + MO_F64_Atanh -> mkCCall "atanh" + + MO_F64_Log -> mkCCall "log" + MO_F64_Log1P -> mkCCall "log1p" + MO_F64_Exp -> mkCCall "exp" + MO_F64_ExpM1 -> mkCCall "expm1" + + -- 32 bit float ops + MO_F32_Pwr -> mkCCall "powf" + + MO_F32_Sin -> mkCCall "sinf" + MO_F32_Cos -> mkCCall "cosf" + MO_F32_Tan -> mkCCall "tanf" + MO_F32_Sinh -> mkCCall "sinhf" + MO_F32_Cosh -> mkCCall "coshf" + MO_F32_Tanh -> mkCCall "tanhf" + MO_F32_Asin -> mkCCall "asinf" + MO_F32_Acos -> mkCCall "acosf" + MO_F32_Atan -> mkCCall "atanf" + MO_F32_Asinh -> mkCCall "asinhf" + MO_F32_Acosh -> mkCCall "acoshf" + MO_F32_Atanh -> mkCCall "atanhf" + MO_F32_Log -> mkCCall "logf" + MO_F32_Log1P -> mkCCall "log1pf" + MO_F32_Exp -> mkCCall "expf" + MO_F32_ExpM1 -> mkCCall "expm1f" + + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + + -- Conversion + MO_UF_Conv w -> mkCCall (word2FloatLabel w) + + -- Arithmetic + -- These are not supported on X86, so I doubt they are used much. + MO_S_QuotRem _w -> unsupported mop + MO_U_QuotRem _w -> unsupported mop + 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 + + -- Vector + MO_VS_Quot {} -> unsupported mop + MO_VS_Rem {} -> unsupported mop + MO_VU_Quot {} -> unsupported mop + MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min -> unsupported mop + MO_I64X2_Max -> unsupported mop + MO_W64X2_Min -> unsupported mop + MO_W64X2_Max -> unsupported mop + + -- Memory Ordering + -- Set flags according to their C pendants (stdatomic.h): + -- 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 -- Prefetch hint. + + -- Memory copy/set/move/cmp, with alignment for optimization + + -- TODO Optimize and use e.g. quad registers to move memory around instead + -- of offloading this to memcpy. For small memcpys we can utilize + -- the 128bit quad registers in NEON to move block of bytes around. + -- Might also make sense of small memsets? Use xzr? What's the function + -- call overhead? + MO_Memcpy _align -> mkCCall "memcpy" + MO_Memset _align -> mkCCall "memset" + MO_Memmove _align -> mkCCall "memmove" + MO_Memcmp _align -> mkCCall "memcmp" + + MO_SuspendThread -> mkCCall "suspendThread" + MO_ResumeThread -> mkCCall "resumeThread" + + MO_PopCnt w -> mkCCall (popCntLabel w) + MO_Pdep w -> mkCCall (pdepLabel w) + MO_Pext w -> mkCCall (pextLabel w) + + -- -- Atomic read-modify-write. + MO_AtomicRead w ord + | [p_reg] <- arg_regs + , [dst_reg] <- dest_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + platform <- getPlatform + let instr = case ord of + MemOrderRelaxed -> LDR + _ -> LDAR + dst = getRegisterReg platform (CmmLocal dst_reg) + code = + code_p `snocOL` + instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p) + return code + | otherwise -> panic "mal-formed AtomicRead" + MO_AtomicWrite w ord + | [p_reg, val_reg] <- arg_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + (val, fmt_val, code_val) <- getSomeReg val_reg + let instr = case ord of + MemOrderRelaxed -> STR + _ -> STLR + code = + code_p `appOL` + code_val `snocOL` + instr fmt_val (OpReg w val) (OpAddr $ AddrReg p) + return 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 + + -- TODO: Optimize using paired stores and loads (STP, LDP). It is + -- automatically done by the allocator for us. However it's not optimal, + -- as we'd rather want to have control over + -- all spill/load registers, so we can optimize with instructions like + -- STP xA, xB, [sp, #-16]! + -- and + -- LDP xA, xB, sp, #16 + -- + passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) + passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode) + -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace)) + -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1))) + -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do + -- -- allocate this on the stack + -- (r0, format0, code_r0) <- getSomeReg arg0 + -- (r1, format1, code_r1) <- getSomeReg arg1 + -- let w0 = formatToWidth format0 + -- w1 = formatToWidth format1 + -- stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8))) + -- passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode) + + -- float promotion. + -- According to + -- ISO/IEC 9899:2018 + -- Information technology — Programming languages — C + -- + -- e.g. + -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf + -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf + -- + -- GHC would need to know the prototype. + -- + -- > If the expression that denotes the called function has a type that does not include a + -- > prototype, the integer promotions are performed on each argument, and arguments that + -- > have type float are promoted to double. + -- + -- As we have no way to get prototypes for C yet, we'll *not* promote this + -- which is in line with the x86_64 backend :( + -- + -- See the encode_values.cmm test. + -- + -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg) + -- if w == W32. But *only* if we don't have a prototype m( + -- + -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture + -- + -- Still have GP regs, and we want to pass an GP argument. + + -- AArch64-Darwin: stack packing and alignment + -- + -- According to the "Writing ARM64 Code for Apple Platforms" document form + -- Apple, specifically the section "Handle Data Types and Data Alignment Properly" + -- we need to not only pack, but also align arguments on the stack. + -- + -- Data type Size (in bytes) Natural alignment (in bytes) + -- BOOL, bool 1 1 + -- char 1 1 + -- short 2 2 + -- int 4 4 + -- long 8 8 + -- long long 8 8 + -- pointer 8 8 + -- size_t 8 8 + -- NSInteger 8 8 + -- CFIndex 8 8 + -- fpos_t 8 8 + -- off_t 8 8 + -- + -- We can see that types are aligned by their sizes so the easiest way to + -- guarantee alignment during packing seems to be to pad to a multiple of the + -- size we want to pack. Failure to get this right can result in pretty + -- subtle bugs, e.g. #20137. + + passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do + platform <- getPlatform + let w = formatToWidth format + mov + -- Specifically, Darwin/AArch64's ABI requires that the caller + -- sign-extend arguments which are smaller than 32-bits. + | w < W32 + , platformCConvNeedsExtension platform + , SignedHint <- hint + = case w of + W8 -> SXTB (OpReg W64 gpReg) (OpReg w r) + W16 -> SXTH (OpReg W64 gpReg) (OpReg w r) + _ -> panic "impossible" + | otherwise + = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass gp argument: " <> ppr r) mov + passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode' + + -- Still have FP regs, and we want to pass an FP argument. + passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace 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 pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode' + + -- No mor regs left to pass. Must pass on stack. + passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) + | otherwise = stackSpace + str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) + stackCode = code_r `snocOL` + ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) + + -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. + passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) + | otherwise = stackSpace + str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) + stackCode = code_r `snocOL` + ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode) + + -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then. + passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + bytes = widthInBits w `div` 8 + space = if pack then bytes else 8 + stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space) + | otherwise = stackSpace + str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))) + stackCode = code_r `snocOL` + ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` 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)) + + 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) + return code + +{- Note [AArch64 far jumps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +AArch conditional jump instructions can only encode an offset of +/-1MB +which is usually enough but can be exceeded in edge cases. In these cases +we will replace: + + b.cond foo + +with the sequence: + + b.cond + b + : + b foo + : + +Note the encoding of the `b` instruction still limits jumps to ++/-128M offsets, but that seems like an acceptable limitation. + +Since AArch64 instructions are all of equal length we can reasonably estimate jumps +in range by counting the instructions between a jump and its target label. + +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 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. + +-} + +-- See Note [AArch64 far jumps] +data BlockInRange = InRange | NotInRange Target + +-- See Note [AArch64 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 AArch64 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 + -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks + + where + -- 2^18, 19 bit immediate with one bit is reserved for the sign + max_jump_dist = 2^(18::Int) - 1 :: Int + -- Currently all inline info tables fit into 64 bytes. + max_info_size = 16 :: Int + long_bc_jump_size = 3 :: Int + long_bz_jump_size = 4 :: Int + + -- Replace out of range conditional jumps with unconditional jumps. + replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr]) + replace_blk !m !pos (BasicBlock lbl instrs) = do + -- Account for a potential info table before the label. + let !block_pos = pos + infoTblSize_maybe lbl + (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs + let instrs'' = concat instrs' + -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary. + let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs'' + -- There should be no data in the instruction stream at this point + massert (null no_data) + + let final_blocks = BasicBlock lbl top : split_blocks + pure (pos', final_blocks) + + replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr]) + replace_jump !m !pos instr = do + case instr of + ANN ann instr -> do + replace_jump m pos instr >>= \case + (idx,instr':instrs') -> + pure (idx, ANN ann instr':instrs') + (idx,[]) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx) BCOND cond t -> case target_in_range m t pos of InRange -> pure (pos+long_bc_jump_size,[instr]) diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs --- a/GHC/CmmToAsm/AArch64/Instr.hs +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -14,21 +14,22 @@ 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 -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm 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 -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) import GHC.Stack @@ -79,13 +80,15 @@ -- 1. Arithmetic Instructions ------------------------------------------------ ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - CMN l r -> usage (regOp l ++ regOp r, []) CMP l r -> usage (regOp l ++ regOp r, []) + CMN l r -> usage (regOp l ++ regOp r, []) MSUB dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) NEG dst src -> usage (regOp src, regOp dst) SMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UMULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + UMULL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) UDIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) @@ -99,26 +102,28 @@ UXTB dst src -> usage (regOp src, regOp dst) SXTH dst src -> usage (regOp src, regOp dst) UXTH dst src -> usage (regOp src, regOp dst) + CLZ dst src -> usage (regOp src, regOp dst) + RBIT dst src -> usage (regOp src, regOp dst) + REV dst src -> usage (regOp src, regOp dst) + -- REV32 dst src -> usage (regOp src, regOp dst) + REV16 dst src -> usage (regOp src, regOp dst) -- 3. Logical and Move Instructions ------------------------------------------ AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) ASR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - BIC dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - BICS dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - EON dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) EOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) LSL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) LSR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) MOV dst src -> usage (regOp src, regOp dst) MOVK dst src -> usage (regOp src, regOp dst) + MOVZ dst src -> usage (regOp src, regOp dst) MVN dst src -> usage (regOp src, regOp dst) ORR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - ROR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) - TST src1 src2 -> usage (regOp src1 ++ regOp src2, []) -- 4. Branch Instructions ---------------------------------------------------- J t -> usage (regTarget t, []) + J_TBL _ _ t -> usage ([t], []) B t -> usage (regTarget t, []) BCOND _ t -> usage (regTarget t, []) - BL t ps _rs -> usage (regTarget t ++ ps, callerSavedRegisters) + BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) -- 5. Atomic Instructions ---------------------------------------------------- -- 6. Conditional Instructions ----------------------------------------------- @@ -130,29 +135,38 @@ STLR _ src dst -> usage (regOp src ++ regOp dst, []) LDR _ dst src -> usage (regOp src, regOp dst) LDAR _ dst src -> usage (regOp src, regOp dst) - -- TODO is this right? see STR, which I'm only partial about being right? - STP _ src1 src2 dst -> usage (regOp src1 ++ regOp src2 ++ regOp dst, []) - LDP _ dst1 dst2 src -> usage (regOp src, regOp dst1 ++ regOp dst2) -- 8. Synchronization Instructions ------------------------------------------- - DMBSY -> 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) - _ -> panic $ "regUsageOfInstr: " ++ instrCon instr + LOCATION{} -> panic $ "regUsageOfInstr: " ++ instrCon instr + NEWBLOCK{} -> 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 (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] @@ -173,7 +187,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] @@ -198,7 +211,7 @@ -- | <---- argument passing -------------> | <-- callee saved (lower 64 bits) ---> | <--------------------------------------- caller saved ----------------------> | -- | <------ free registers -------------> | F1 | F2 | F3 | F4 | D1 | D2 | D3 | D4 | <------ free registers -----------------------------------------------------> | -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' --- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer +-- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register (See Note [Aarch64 Register x18 at Darwin and Windows]), FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim -- -- TODO: The zero register is currently mapped to -1 but should get it's own separate number. @@ -221,13 +234,15 @@ DELTA{} -> instr -- 1. Arithmetic Instructions ---------------------------------------------- ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) - CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) CMP o1 o2 -> CMP (patchOp o1) (patchOp o2) + CMN o1 o2 -> CMN (patchOp o1) (patchOp o2) MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2) (patchOp o3) SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2) (patchOp o3) + UMULH o1 o2 o3 -> UMULH (patchOp o1) (patchOp o2) (patchOp o3) + UMULL o1 o2 o3 -> UMULL (patchOp o1) (patchOp o2) (patchOp o3) SDIV o1 o2 o3 -> SDIV (patchOp o1) (patchOp o2) (patchOp o3) SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) UDIV o1 o2 o3 -> UDIV (patchOp o1) (patchOp o2) (patchOp o3) @@ -241,29 +256,31 @@ UXTB o1 o2 -> UXTB (patchOp o1) (patchOp o2) SXTH o1 o2 -> SXTH (patchOp o1) (patchOp o2) UXTH o1 o2 -> UXTH (patchOp o1) (patchOp o2) + CLZ o1 o2 -> CLZ (patchOp o1) (patchOp o2) + RBIT o1 o2 -> RBIT (patchOp o1) (patchOp o2) + REV o1 o2 -> REV (patchOp o1) (patchOp o2) + -- REV32 o1 o2 -> REV32 (patchOp o1) (patchOp o2) + REV16 o1 o2 -> REV16 (patchOp o1) (patchOp o2) + -- 3. Logical and Move Instructions ---------------------------------------- AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) - ANDS o1 o2 o3 -> ANDS (patchOp o1) (patchOp o2) (patchOp o3) ASR o1 o2 o3 -> ASR (patchOp o1) (patchOp o2) (patchOp o3) - BIC o1 o2 o3 -> BIC (patchOp o1) (patchOp o2) (patchOp o3) - BICS o1 o2 o3 -> BICS (patchOp o1) (patchOp o2) (patchOp o3) - EON o1 o2 o3 -> EON (patchOp o1) (patchOp o2) (patchOp o3) EOR o1 o2 o3 -> EOR (patchOp o1) (patchOp o2) (patchOp o3) LSL o1 o2 o3 -> LSL (patchOp o1) (patchOp o2) (patchOp o3) LSR o1 o2 o3 -> LSR (patchOp o1) (patchOp o2) (patchOp o3) MOV o1 o2 -> MOV (patchOp o1) (patchOp o2) MOVK o1 o2 -> MOVK (patchOp o1) (patchOp o2) + MOVZ o1 o2 -> MOVZ (patchOp o1) (patchOp o2) MVN o1 o2 -> MVN (patchOp o1) (patchOp o2) ORR o1 o2 o3 -> ORR (patchOp o1) (patchOp o2) (patchOp o3) - ROR o1 o2 o3 -> ROR (patchOp o1) (patchOp o2) (patchOp o3) - TST o1 o2 -> TST (patchOp o1) (patchOp o2) -- 4. Branch Instructions -------------------------------------------------- - J t -> J (patchTarget t) - B t -> B (patchTarget t) - BL t rs ts -> BL (patchTarget t) rs ts - BCOND c t -> BCOND c (patchTarget t) + J t -> J (patchTarget t) + J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t) + B t -> B (patchTarget t) + BL t rs -> BL (patchTarget t) rs + BCOND c t -> BCOND c (patchTarget t) -- 5. Atomic Instructions -------------------------------------------------- -- 6. Conditional Instructions --------------------------------------------- @@ -275,21 +292,24 @@ STLR f o1 o2 -> STLR f (patchOp o1) (patchOp o2) LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2) LDAR f o1 o2 -> LDAR f (patchOp o1) (patchOp o2) - STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3) - LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3) -- 8. Synchronization Instructions ----------------------------------------- - DMBSY -> DMBSY + 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) - _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr + NEWBLOCK{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr + LOCATION{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand patchOp (OpReg w r) = OpReg w (env r) @@ -314,6 +334,7 @@ CBZ{} -> True CBNZ{} -> True J{} -> True + J_TBL{} -> True B{} -> True BL{} -> True BCOND{} -> True @@ -327,14 +348,20 @@ jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] -jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]] +jumpDestsOfInstr (BL t _) = [ id | TBlock id <- [t]] jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = [] canFallthroughTo :: Instr -> BlockId -> Bool canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid canFallthroughTo (J (TBlock target)) bid = bid == target +canFallthroughTo (J_TBL targets _ _) bid = all isTargetBid targets + where + isTargetBid target = case target of + Nothing -> True + Just target -> target == bid canFallthroughTo (B (TBlock target)) bid = bid == target canFallthroughTo _ _ = False @@ -348,8 +375,9 @@ CBZ r (TBlock bid) -> CBZ r (TBlock (patchF bid)) CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid)) J (TBlock bid) -> J (TBlock (patchF bid)) + J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r B (TBlock bid) -> B (TBlock (patchF bid)) - BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs + BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid)) _ -> panic $ "patchJumpInstr: " ++ instrCon instr @@ -373,12 +401,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 ] @@ -389,9 +417,8 @@ where a .&~. b = a .&. (complement b) - fmt = case reg of - RegReal (RealRegSingle n) | n < 32 -> II64 - _ -> FF64 + -- 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))) @@ -400,12 +427,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 ] @@ -416,10 +442,8 @@ where a .&~. b = a .&. (complement b) - fmt = case reg of - RegReal (RealRegSingle n) | n < 32 -> II64 - _ -> FF64 - + -- 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))) @@ -441,7 +465,6 @@ COMMENT{} -> True MULTILINE_COMMENT{} -> True LOCATION{} -> True - LDATA{} -> True NEWBLOCK{} -> True DELTA{} -> True PUSH_STACK_FRAME -> True @@ -450,13 +473,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 +521,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 +536,6 @@ alloc = mkStackAllocInstr platform delta dealloc = mkStackDeallocInstr platform delta - retargetList = (zip entries (map mkBlockId uniqs)) - new_blockmap :: LabelMap BlockId new_blockmap = mapFromList retargetList @@ -544,11 +579,6 @@ -- location pseudo-op (file, line, col, name) | LOCATION Int Int Int String - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section RawCmmStatics - -- start a new basic block. Useful during -- codegen, removed later. Preceding -- instruction should be a jump, as per the @@ -575,8 +605,8 @@ -- | ADDS Operand Operand Operand -- rd = rn + rm -- | ADR ... -- | ADRP ... - | CMN Operand Operand -- rd + op2 | CMP Operand Operand -- rd - op2 + | CMN Operand Operand -- rd + op2 -- | MADD ... -- | MNEG ... | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm @@ -599,8 +629,8 @@ -- | UMADDL ... -- Xd = Xa + Wn × Wm -- | UMNEGL ... -- Xd = - Wn × Wm -- | UMSUBL ... -- Xd = Xa - Wn × Wm - -- | UMULH ... -- Xd = (Xn × Xm)_127:64 - -- | UMULL ... -- Xd = Wn × Wm + | UMULH Operand Operand Operand -- Xd = (Xn × Xm)_127:64 + | UMULL Operand Operand Operand -- Xd = Wn × Wm -- 2. Bit Manipulation Instructions ---------------------------------------- | SBFM Operand Operand Operand Operand -- rd = rn[i,j] @@ -613,34 +643,33 @@ -- Signed/Unsigned bitfield extract | SBFX Operand Operand Operand Operand -- rd = rn[i,j] | UBFX Operand Operand Operand Operand -- rd = rn[i,j] + | CLZ Operand Operand -- rd = countLeadingZeros(rn) + | RBIT Operand Operand -- rd = reverseBits(rn) + | REV Operand Operand -- rd = reverseBytes(rn): (for 32 & 64 bit operands) + -- 0xAABBCCDD -> 0xDDCCBBAA + | REV16 Operand Operand -- rd = reverseBytes16(rn) + -- 0xAABB_CCDD -> xBBAA_DDCC + -- | REV32 Operand Operand -- rd = reverseBytes32(rn) - 64bit operands only! + -- -- 0xAABBCCDD_EEFFGGHH -> 0XDDCCBBAA_HHGGFFEE -- 3. Logical and Move Instructions ---------------------------------------- | AND Operand Operand Operand -- rd = rn & op2 - | ANDS Operand Operand Operand -- rd = rn & op2 | ASR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits - | BIC Operand Operand Operand -- rd = rn & ~op2 - | BICS Operand Operand Operand -- rd = rn & ~op2 - | EON Operand Operand Operand -- rd = rn ⊕ ~op2 | EOR Operand Operand Operand -- rd = rn ⊕ op2 | LSL Operand Operand Operand -- rd = rn ≪ rm or rd = rn ≪ #i, i is 6 bits | LSR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits | MOV Operand Operand -- rd = rn or rd = #i | MOVK Operand Operand -- | MOVN Operand Operand - -- | MOVZ Operand Operand + | MOVZ Operand Operand | MVN Operand Operand -- rd = ~rn - | ORN Operand Operand Operand -- rd = rn | ~op2 | ORR Operand Operand Operand -- rd = rn | op2 - | ROR Operand Operand Operand -- rd = rn ≫ rm or rd = rn ≫ #i, i is 6 bits - | TST Operand Operand -- rn & op2 -- Load and stores. -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register. | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr | LDAR Format Operand Operand -- ldar Xn, address-mode // Xn <- *addr - | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8) - | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8) -- Conditional instructions | CSET Operand Cond -- if(cond) op <- 1 else op <- 0 @@ -649,13 +678,16 @@ | CBNZ Operand Target -- if op /= 0, then branch. -- Branching. | J Target -- like B, but only generated from genJump. Used to distinguish genJumps from others. + | J_TBL [Maybe BlockId] (Maybe CLabel) Reg -- A jump instruction with data for switch/jump tables | B Target -- unconditional branching b/br. (To a blockid, label or register) - | BL Target [Reg] [Reg] -- branch and link (e.g. set x30 to next pc, and branch) + | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch) | BCOND Cond Target -- branch with condition. b. -- 8. Synchronization Instructions ----------------------------------------- - | DMBSY + | 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 @@ -664,6 +696,12 @@ | 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 -- | Floating-point fused multiply-add instructions -- @@ -673,6 +711,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 @@ -680,7 +721,6 @@ MULTILINE_COMMENT{} -> "COMMENT" ANN{} -> "ANN" LOCATION{} -> "LOCATION" - LDATA{} -> "LDATA" NEWBLOCK{} -> "NEWBLOCK" DELTA{} -> "DELTA" SXTB{} -> "SXTB" @@ -690,54 +730,58 @@ PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME" POP_STACK_FRAME{} -> "POP_STACK_FRAME" ADD{} -> "ADD" - CMN{} -> "CMN" CMP{} -> "CMP" + CMN{} -> "CMN" MSUB{} -> "MSUB" MUL{} -> "MUL" NEG{} -> "NEG" SDIV{} -> "SDIV" SMULH{} -> "SMULH" SMULL{} -> "SMULL" + UMULH{} -> "UMULH" + UMULL{} -> "UMULL" SUB{} -> "SUB" UDIV{} -> "UDIV" SBFM{} -> "SBFM" UBFM{} -> "UBFM" SBFX{} -> "SBFX" UBFX{} -> "UBFX" + CLZ{} -> "CLZ" + RBIT{} -> "RBIT" + REV{} -> "REV" + REV16{} -> "REV16" + -- REV32{} -> "REV32" AND{} -> "AND" - ANDS{} -> "ANDS" ASR{} -> "ASR" - BIC{} -> "BIC" - BICS{} -> "BICS" - EON{} -> "EON" EOR{} -> "EOR" LSL{} -> "LSL" LSR{} -> "LSR" MOV{} -> "MOV" MOVK{} -> "MOVK" + MOVZ{} -> "MOVZ" MVN{} -> "MVN" - ORN{} -> "ORN" ORR{} -> "ORR" - ROR{} -> "ROR" - TST{} -> "TST" STR{} -> "STR" STLR{} -> "STLR" LDR{} -> "LDR" LDAR{} -> "LDAR" - STP{} -> "STP" - LDP{} -> "LDP" CSET{} -> "CSET" CBZ{} -> "CBZ" CBNZ{} -> "CBNZ" J{} -> "J" + J_TBL {} -> "J_TBL" B{} -> "B" BL{} -> "BL" BCOND{} -> "BCOND" - DMBSY{} -> "DMBSY" + 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" @@ -783,9 +827,7 @@ 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)) diff --git a/GHC/CmmToAsm/AArch64/Ppr.hs b/GHC/CmmToAsm/AArch64/Ppr.hs --- a/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/GHC/CmmToAsm/AArch64/Ppr.hs @@ -1,5 +1,4 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where @@ -16,7 +15,6 @@ import GHC.CmmToAsm.Utils import GHC.Cmm hiding (topInfoTable) -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId @@ -44,7 +42,9 @@ pprSectionAlign config (Section Text lbl) $$ -- do not -- pprProcAlignment config $$ - pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + (if lbl /= blockLbl (blockId (head blocks)) -- blocks can have clashed names + then pprLabel platform lbl -- blocks guaranteed not null, so label needed + else empty) $$ vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$ (if ncgDwarfEnabled config then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$ @@ -307,7 +307,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) @@ -333,13 +332,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 @@ -358,7 +357,6 @@ -- in the final instruction stream. But we still want to be able to -- print it for debugging purposes. line (text "BLOCK " <> pprAsmLabel platform (blockLbl blockid)) - LDATA _ _ -> panic "pprInstr: LDATA" -- Pseudo Instructions ------------------------------------------------------- @@ -372,16 +370,18 @@ ADD o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd") o1 o2 o3 | otherwise -> op3 (text "\tadd") o1 o2 o3 - CMN o1 o2 -> op2 (text "\tcmn") o1 o2 CMP o1 o2 | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2 | otherwise -> op2 (text "\tcmp") o1 o2 + CMN o1 o2 -> op2 (text "\tcmn") o1 o2 MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4 MUL o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul") o1 o2 o3 | otherwise -> op3 (text "\tmul") o1 o2 o3 SMULH o1 o2 o3 -> op3 (text "\tsmulh") o1 o2 o3 SMULL o1 o2 o3 -> op3 (text "\tsmull") o1 o2 o3 + UMULH o1 o2 o3 -> op3 (text "\tumulh") o1 o2 o3 + UMULL o1 o2 o3 -> op3 (text "\tumull") o1 o2 o3 NEG o1 o2 | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2 | otherwise -> op2 (text "\tneg") o1 o2 @@ -397,6 +397,11 @@ -- 2. Bit Manipulation Instructions ------------------------------------------ SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4 UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4 + CLZ o1 o2 -> op2 (text "\tclz") o1 o2 + RBIT o1 o2 -> op2 (text "\trbit") o1 o2 + REV o1 o2 -> op2 (text "\trev") o1 o2 + REV16 o1 o2 -> op2 (text "\trev16") o1 o2 + -- REV32 o1 o2 -> op2 (text "\trev32") o1 o2 -- signed and unsigned bitfield extract SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4 UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4 @@ -407,11 +412,7 @@ -- 3. Logical and Move Instructions ------------------------------------------ AND o1 o2 o3 -> op3 (text "\tand") o1 o2 o3 - ANDS o1 o2 o3 -> op3 (text "\tands") o1 o2 o3 ASR o1 o2 o3 -> op3 (text "\tasr") o1 o2 o3 - BIC o1 o2 o3 -> op3 (text "\tbic") o1 o2 o3 - BICS o1 o2 o3 -> op3 (text "\tbics") o1 o2 o3 - EON o1 o2 o3 -> op3 (text "\teon") o1 o2 o3 EOR o1 o2 o3 -> op3 (text "\teor") o1 o2 o3 LSL o1 o2 o3 -> op3 (text "\tlsl") o1 o2 o3 LSR o1 o2 o3 -> op3 (text "\tlsr") o1 o2 o3 @@ -419,21 +420,20 @@ | isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2 | otherwise -> op2 (text "\tmov") o1 o2 MOVK o1 o2 -> op2 (text "\tmovk") o1 o2 + MOVZ o1 o2 -> op2 (text "\tmovz") o1 o2 MVN o1 o2 -> op2 (text "\tmvn") o1 o2 - ORN o1 o2 o3 -> op3 (text "\torn") o1 o2 o3 ORR o1 o2 o3 -> op3 (text "\torr") o1 o2 o3 - ROR o1 o2 o3 -> op3 (text "\tror") o1 o2 o3 - TST o1 o2 -> op2 (text "\ttst") o1 o2 -- 4. Branch Instructions ---------------------------------------------------- J t -> pprInstr platform (B t) + J_TBL _ _ r -> pprInstr platform (B (TReg r)) B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl B (TReg r) -> line $ text "\tbr" <+> pprReg W64 r - BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) - BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl - BL (TReg r) _ _ -> line $ text "\tblr" <+> pprReg W64 r + BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl + BL (TReg r) _ -> line $ text "\tblr" <+> pprReg W64 r BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl @@ -462,63 +462,51 @@ STR _f o1 o2 -> op2 (text "\tstr") o1 o2 STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2 -#if defined(darwin_HOST_OS) LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> - op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$ - op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") $$ - op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits. - - LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> - op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$ - op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") $$ - op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits. - - LDR _f o1 (OpImm (ImmIndex lbl off)) -> - op_adrp o1 (pprAsmLabel platform lbl <> text "@page") $$ - op_add o1 (pprAsmLabel platform lbl <> text "@pageoff") $$ - op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits. - - LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> - op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$ - op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") - - LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> - op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$ - op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") - - LDR _f o1 (OpImm (ImmCLbl lbl)) -> - op_adrp o1 (pprAsmLabel platform lbl <> text "@page") $$ - op_add o1 (pprAsmLabel platform lbl <> text "@pageoff") - -#else - LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> - op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$ - op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) $$ - op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits. + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') $$ + op_add o1 (check_off off) LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> - op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$ - op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) $$ - op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits. + case platformOS platform of + OSMinGW32 -> + let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_add o1 add' $$ + op_add o1 (check_off off) + _ -> + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') $$ + op_add o1 (check_off off) LDR _f o1 (OpImm (ImmIndex lbl off)) -> - op_adrp o1 (pprAsmLabel platform lbl) $$ - op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl) $$ - op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits. + let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_add o1 (add') $$ + op_add o1 (check_off off) LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> - op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$ - op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> - op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$ - op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) + case platformOS platform of + OSMinGW32 -> + let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_add o1 add' + _ -> + let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in + op_adrp o1 (adrp') $$ + op_ldr o1 (ldr') LDR _f o1 (OpImm (ImmCLbl lbl)) -> - op_adrp o1 (pprAsmLabel platform lbl) $$ - op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl) - -#endif + let (adrp', ldr') = op_adrp_reloc_local $ pprAsmLabel platform lbl in + op_adrp o1 adrp' $$ + op_add o1 ldr' LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> op2 (text "\tldrb") o1 o2 @@ -527,16 +515,19 @@ LDR _f o1 o2 -> op2 (text "\tldr") o1 o2 LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2 - STP _f o1 o2 o3 -> op3 (text "\tstp") o1 o2 o3 - LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3 - -- 8. Synchronization Instructions ------------------------------------------- - DMBSY -> line $ text "\tdmb sy" + 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" @@ -550,6 +541,21 @@ op_ldr o1 rest = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]" op_adrp o1 rest = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest op_add o1 rest = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest + + op_adrp_reloc_dynamic asm_lbl = case platformOS platform of + OSDarwin -> (asm_lbl <> text "@gotpage", asm_lbl <> text "@gotpageoff") + OSLinux -> (text ":got:" <> asm_lbl, text ":got_lo12:" <> asm_lbl) + OSMinGW32 -> (text "__imp_" <> asm_lbl, text ":lo12:__imp_" <> asm_lbl) + os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_dynamic : " ++ show os' ++ " is unsuppported by relocations" + + op_adrp_reloc_local asm_lbl = case platformOS platform of + OSDarwin -> (asm_lbl <> text "@page", asm_lbl <> text "@pageoff") + OSLinux -> (asm_lbl, text ":lo12:" <> asm_lbl) + OSMinGW32 -> (asm_lbl, text ":lo12:" <> asm_lbl) + os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_local : " ++ show os' ++ " is unsuppported by relocations" + + check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else + pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit" pprBcond :: IsLine doc => Cond -> doc pprBcond c = text "b." <> pprCond c diff --git a/GHC/CmmToAsm/AArch64/RegInfo.hs b/GHC/CmmToAsm/AArch64/RegInfo.hs --- a/GHC/CmmToAsm/AArch64/RegInfo.hs +++ b/GHC/CmmToAsm/AArch64/RegInfo.hs @@ -14,18 +14,16 @@ instance Outputable JumpDest where ppr (DestBlockId bid) = text "jd:" <> 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 diff --git a/GHC/CmmToAsm/AArch64/Regs.hs b/GHC/CmmToAsm/AArch64/Regs.hs --- a/GHC/CmmToAsm/AArch64/Regs.hs +++ b/GHC/CmmToAsm/AArch64/Regs.hs @@ -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 @@ -78,6 +78,8 @@ -- 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. + -- AK: We do call this with out of range values, however + -- it just truncates as we would expect. litToImm (CmmFloat f W32) = ImmFloat f litToImm (CmmFloat f W64) = ImmDouble f litToImm (CmmLabel l) = ImmCLbl l @@ -107,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 @@ -125,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 @@ -146,11 +144,10 @@ classOfRealReg :: RealReg -> RegClass classOfRealReg (RealRegSingle i) | i < 32 = RcInteger - | otherwise = RcDouble + | otherwise = RcFloatOrVector regDotColor :: RealReg -> SDoc regDotColor reg = case classOfRealReg reg of RcInteger -> text "blue" - RcFloat -> text "red" - RcDouble -> text "green" + RcFloatOrVector -> text "red" diff --git a/GHC/CmmToAsm/BlockLayout.hs b/GHC/CmmToAsm/BlockLayout.hs --- a/GHC/CmmToAsm/BlockLayout.hs +++ b/GHC/CmmToAsm/BlockLayout.hs @@ -26,7 +26,6 @@ import GHC.Cmm import GHC.Cmm.BlockId -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Types.Unique.FM @@ -38,7 +37,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import Data.List (sortOn, sortBy, nub) @@ -50,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] @@ -510,8 +508,8 @@ union cFrom new_point merge edges chains where - cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains - cTo = expectJust "mergeChains:chainMap:to" $ mapLookup to chains + cFrom = expectJust $ mapLookup from chains + cTo = expectJust $ mapLookup to chains -- See Note [Chain based CFG serialization] for the general idea. @@ -739,10 +737,6 @@ = [masterChain] | (rest,entry) <- breakChainAt entry masterChain = [entry,rest] -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = pprPanic "Entry point eliminated" $ - ppr masterChain -#endif blockList = assert (noDups [masterChain]) @@ -763,7 +757,7 @@ --pprTraceIt "placedBlocks" $ -- ++ [] is still kinda expensive if null unplaced then blockList else blockList ++ unplaced - getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap + getBlock bid = expectJust $ mapLookup bid blockMap in --Assert we placed all blocks given as input assert (all (\bid -> mapMember bid blockMap) placedBlocks) $ @@ -799,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 diff --git a/GHC/CmmToAsm/CFG.hs b/GHC/CmmToAsm/CFG.hs --- a/GHC/CmmToAsm/CFG.hs +++ b/GHC/CmmToAsm/CFG.hs @@ -48,7 +48,6 @@ import GHC.Cmm as Cmm import GHC.Cmm.Switch -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import qualified GHC.Cmm.Dataflow.Graph as G @@ -76,7 +75,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList @@ -313,8 +311,8 @@ cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list) let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId)) -- Then unify according to the rewrites in the cuts map - mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map) - `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list + mapM_ (\(from, to) -> expectJust (mapLookup from cuts_map) + `union` expectJust (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list -- Then recover the unique representative, which is the result of following -- the chain to the end. mapM find cuts_map @@ -418,13 +416,10 @@ = Nothing getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight -getEdgeWeight cfg from to = - edgeWeight $ expectJust "Edgeweight for nonexisting block" $ - getEdgeInfo from to cfg +getEdgeWeight cfg from to = edgeWeight $ expectJust $ getEdgeInfo from to cfg getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource -getTransitionSource from to cfg = transitionSource $ expectJust "Source info for nonexisting block" $ - getEdgeInfo from to cfg +getTransitionSource from to cfg = transitionSource $ expectJust $ getEdgeInfo from to cfg reverseEdges :: CFG -> CFG reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg @@ -602,7 +597,7 @@ -} -- | Generate weights for a Cmm proc based on some simple heuristics. -getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG +getCfgProc :: Platform -> Weights -> GenCmmDecl d h CmmGraph -> CFG getCfgProc _ _ (CmmData {}) = mapEmpty getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph @@ -1006,7 +1001,7 @@ blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId -- Map from blockId to indices starting at zero toVertex :: BlockId -> Int - toVertex blockId = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping + toVertex blockId = expectJust $ mapLookup blockId vertexMapping -- Map from indices starting at zero to blockIds fromVertex :: Int -> BlockId fromVertex vertex = blockMapping ! vertex diff --git a/GHC/CmmToAsm/CFG/Dominators.hs b/GHC/CmmToAsm/CFG/Dominators.hs --- a/GHC/CmmToAsm/CFG/Dominators.hs +++ b/GHC/CmmToAsm/CFG/Dominators.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} {- | diff --git a/GHC/CmmToAsm/Config.hs b/GHC/CmmToAsm/Config.hs --- a/GHC/CmmToAsm/Config.hs +++ b/GHC/CmmToAsm/Config.hs @@ -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,6 +47,7 @@ , 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 } diff --git a/GHC/CmmToAsm/Dwarf.hs b/GHC/CmmToAsm/Dwarf.hs --- a/GHC/CmmToAsm/Dwarf.hs +++ b/GHC/CmmToAsm/Dwarf.hs @@ -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 @@ -29,11 +29,9 @@ import System.FilePath import qualified GHC.Cmm.Dataflow.Label as H -import qualified GHC.Cmm.Dataflow.Collections 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 @@ -66,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 @@ -80,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) @@ -91,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 diff --git a/GHC/CmmToAsm/Dwarf/Constants.hs b/GHC/CmmToAsm/Dwarf/Constants.hs --- a/GHC/CmmToAsm/Dwarf/Constants.hs +++ b/GHC/CmmToAsm/Dwarf/Constants.hs @@ -240,6 +240,8 @@ | r == xmm15 -> 32 ArchPPC_64 _ -> fromIntegral $ toRegNo r ArchAArch64 -> fromIntegral $ toRegNo r + ArchRISCV64 -> fromIntegral $ toRegNo r + ArchLoongArch64 -> fromIntegral $ toRegNo r _other -> error "dwarfRegNo: Unsupported platform or unknown register!" -- | Virtual register number to use for return address. @@ -252,5 +254,7 @@ ArchX86 -> 8 -- eip ArchX86_64 -> 16 -- rip ArchPPC_64 ELF_V2 -> 65 -- lr (link register) - ArchAArch64-> 30 + ArchAArch64 -> 30 + ArchRISCV64 -> 1 -- ra (return address) + ArchLoongArch64 -> 1 -- ra (return address) _other -> error "dwarfReturnRegNo: Unsupported platform!" diff --git a/GHC/CmmToAsm/Dwarf/Types.hs b/GHC/CmmToAsm/Dwarf/Types.hs --- a/GHC/CmmToAsm/Dwarf/Types.hs +++ b/GHC/CmmToAsm/Dwarf/Types.hs @@ -150,14 +150,14 @@ pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfo platform haveSrc d = case d of - DwarfCompileUnit {} -> hasChildren - DwarfSubprogram {} -> hasChildren - DwarfBlock {} -> hasChildren - DwarfSrcNote {} -> noChildren + DwarfCompileUnit {dwChildren = kids} -> hasChildren kids + DwarfSubprogram {dwChildren = kids} -> hasChildren kids + DwarfBlock {dwChildren = kids} -> hasChildren kids + DwarfSrcNote {} -> noChildren where - hasChildren = + hasChildren kids = pprDwarfInfoOpen platform haveSrc d $$ - vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$ + vcat (map (pprDwarfInfo platform haveSrc) kids) $$ pprDwarfInfoClose noChildren = pprDwarfInfoOpen platform haveSrc d {-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-} diff --git a/GHC/CmmToAsm/Format.hs b/GHC/CmmToAsm/Format.hs --- a/GHC/CmmToAsm/Format.hs +++ b/GHC/CmmToAsm/Format.hs @@ -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] diff --git a/GHC/CmmToAsm/Instr.hs b/GHC/CmmToAsm/Instr.hs --- a/GHC/CmmToAsm/Instr.hs +++ b/GHC/CmmToAsm/Instr.hs @@ -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. diff --git a/GHC/CmmToAsm/LA64.hs b/GHC/CmmToAsm/LA64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Native code generator for LoongArch64 architectures +module GHC.CmmToAsm.LA64 ( ncgLA64 ) where + +import GHC.Prelude + +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Instr +import GHC.CmmToAsm.Monad +import GHC.CmmToAsm.Types +import GHC.Utils.Outputable (ftext) + +import qualified GHC.CmmToAsm.LA64.CodeGen as LA64 +import qualified GHC.CmmToAsm.LA64.Instr as LA64 +import qualified GHC.CmmToAsm.LA64.Ppr as LA64 +import qualified GHC.CmmToAsm.LA64.RegInfo as LA64 +import qualified GHC.CmmToAsm.LA64.Regs as LA64 + +ncgLA64 :: NCGConfig -> NcgImpl RawCmmStatics LA64.Instr LA64.JumpDest +ncgLA64 config = + NcgImpl + { ncgConfig = config, + cmmTopCodeGen = LA64.cmmTopCodeGen, + generateJumpTableForInstr = LA64.generateJumpTableForInstr config, + getJumpDestBlockId = LA64.getJumpDestBlockId, + canShortcut = LA64.canShortcut, + shortcutStatics = LA64.shortcutStatics, + shortcutJump = LA64.shortcutJump, + pprNatCmmDeclS = LA64.pprNatCmmDecl config, + pprNatCmmDeclH = LA64.pprNatCmmDecl config, + maxSpillSlots = LA64.maxSpillSlots config, + allocatableRegs = LA64.allocatableRegs platform, + ncgAllocMoreStack = LA64.allocMoreStack platform, + ncgMakeFarBranches = LA64.makeFarBranches, + extractUnwindPoints = const [], + invertCondBranches = \_ _ -> id + } + where + platform = ncgPlatform config + +-- | `Instruction` instance for LA64 +instance Instruction LA64.Instr where + regUsageOfInstr = LA64.regUsageOfInstr + patchRegsOfInstr _ = LA64.patchRegsOfInstr + isJumpishInstr = LA64.isJumpishInstr + canFallthroughTo = LA64.canFallthroughTo + jumpDestsOfInstr = LA64.jumpDestsOfInstr + patchJumpInstr = LA64.patchJumpInstr + mkSpillInstr = LA64.mkSpillInstr + mkLoadInstr = LA64.mkLoadInstr + takeDeltaInstr = LA64.takeDeltaInstr + isMetaInstr = LA64.isMetaInstr + mkRegRegMoveInstr _ _ = LA64.mkRegRegMoveInstr + takeRegRegMoveInstr _ = LA64.takeRegRegMoveInstr + mkJumpInstr = LA64.mkJumpInstr + mkStackAllocInstr = LA64.mkStackAllocInstr + mkStackDeallocInstr = LA64.mkStackDeallocInstr + mkComment = pure . LA64.COMMENT . ftext + pprInstr = LA64.pprInstr diff --git a/GHC/CmmToAsm/LA64/CodeGen.hs b/GHC/CmmToAsm/LA64/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/CodeGen.hs @@ -0,0 +1,2236 @@ +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +module GHC.CmmToAsm.LA64.CodeGen ( + cmmTopCodeGen + , generateJumpTableForInstr + , makeFarBranches +) + +where + +import Data.Maybe +import Data.Word +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.DebugBlock +import GHC.Cmm.Switch +import GHC.Cmm.Utils +import GHC.CmmToAsm.CPrim +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Monad + ( NatM, + getConfig, + getDebugBlock, + getFileId, + getNewLabelNat, + getNewRegNat, + getPicBaseMaybeNat, + getPlatform + ) +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.LA64.Cond +import GHC.CmmToAsm.LA64.Instr +import GHC.CmmToAsm.LA64.Regs +import GHC.CmmToAsm.Types +import GHC.Data.FastString +import GHC.Data.OrdList +import GHC.Float +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Regs +import GHC.Prelude hiding (EQ) +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine) +import GHC.Types.Tickish (GenTickish (..)) +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Monad +import Control.Monad +import GHC.Cmm.Dataflow.Label +import GHC.Types.Unique.DSM + +-- [General layout of an NCG] +cmmTopCodeGen :: + RawCmmDecl -> + NatM [NatCmmDecl RawCmmStatics Instr] +-- Thus we'll have to deal with either CmmProc ... +cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do + picBaseMb <- getPicBaseMaybeNat + when (isJust picBaseMb) $ panic "LA64.cmmTopCodeGen: Unexpected PIC base register" + + let blocks = toBlockListEntryFirst graph + (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks + + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + + pure tops + +-- ... or CmmData. +cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic + +basicBlockCodeGen :: + Block CmmNode C C -> + NatM + ( [NatBasicBlock Instr], + [NatCmmDecl RawCmmStatics Instr] + ) +basicBlockCodeGen block = do + config <- getConfig + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + + header_comment_instr + | debugIsOn = + unitOL + $ MULTILINE_COMMENT + ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n" + $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block) + ) + | otherwise = nilOL + + -- Generate location directive `.loc` (DWARF debug location info) + loc_instrs <- genLocInstrs + + -- Generate other instructions + mid_instrs <- stmtsToInstrs stmts + (!tail_instrs) <- stmtToInstrs tail + + let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs + + -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to + -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs + -- work fine without it. + + -- Code generation may introduce new basic block boundaries, which are + -- indicated by the NEWBLOCK instruction. We must split up the instruction + -- stream into basic blocks again. Also, we extract LDATAs here too. + (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs + + return (BasicBlock id top : other_blocks, statics) + where + genLocInstrs :: NatM (OrdList Instr) + genLocInstrs = do + dbg <- getDebugBlock (entryLabel block) + case dblSourceTick =<< dbg of + Just (SourceNote span name) -> + do + fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + pure $ unitOL $ LOCATION fileId line col name + _ -> pure nilOL + +mkBlocks :: + Instr -> + ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) -> + ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) +mkBlocks (NEWBLOCK id) (instrs, blocks, statics) = + ([], BasicBlock id instrs : blocks, statics) +mkBlocks (LDATA sec dat) (instrs, blocks, statics) = + (instrs, blocks, CmmData sec dat : statics) +mkBlocks instr (instrs, blocks, statics) = + (instr : instrs, blocks, statics) + +-- ----------------------------------------------------------------------------- +-- | Utilities + +-- | Annotate an `Instr` with a `SDoc` comment +ann :: SDoc -> Instr -> Instr +ann doc instr {- debugIsOn -} = ANN doc instr +{-# INLINE ann #-} + +-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with +-- -dppr-debug. The idea is that we can trivially see how a cmm expression +-- ended up producing the assembly we see. By having the verbatim AST printed +-- we can simply check the patterns that were matched to arrive at the assembly +-- we generated. +-- +-- pprExpr will hide a lot of noise of the underlying data structure and print +-- the expression into something that can be easily read by a human. However +-- going back to the exact CmmExpr representation can be laborious and adds +-- indirections to find the matches that lead to the assembly. +-- +-- An improvement oculd be to have +-- +-- (pprExpr genericPlatform e) <> parens (text. show e) +-- +-- to have the best of both worlds. +-- +-- Note: debugIsOn is too restrictive, it only works for debug compilers. +-- However, we do not only want to inspect this for debug compilers. Ideally +-- we'd have a check for -dppr-debug here already, such that we don't even +-- generate the ANN expressions. However, as they are lazy, they shouldn't be +-- forced until we actually force them, and without -dppr-debug they should +-- never end up being forced. +annExpr :: CmmExpr -> Instr -> Instr +annExpr e {- debugIsOn -} = ANN (text . show $ e) +-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr +-- annExpr _ instr = instr +{-# INLINE annExpr #-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch +-- The index into the jump table is calulated by evaluating @expr@. The +-- corresponding table entry contains the address to jump to. +genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock +genSwitch config expr targets = do + (reg, fmt1, e_code) <- getSomeReg indexExpr + targetReg <- getNewRegNat II64 + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg, fmt2, t_code) <- getSomeReg $ dynRef + let code = + toOL [ COMMENT (text "indexExpr" <+> (text . show) indexExpr) + , COMMENT (text "dynRef" <+> (text . show) dynRef) + ] + `appOL` e_code + `appOL` t_code + `appOL` toOL + [ + COMMENT (ftext "Jump table for switch"), + -- index to offset into the table (relative to tableReg) + annExpr expr (SLL (OpReg W64 reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))), + -- calculate table entry address + ADD (OpReg W64 targetReg) (OpReg W64 reg) (OpReg (formatToWidth fmt2) tableReg), + -- load table entry (relative offset from tableReg (first entry) to target label) + LDU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))), + -- calculate absolute address of the target label + ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg), + -- prepare jump to target label + J_TBL bids (Just lbl) targetReg + ] + return code + where + platform = ncgPlatform config + expr_w = cmmExprWidth platform expr + indexExpr0 = cmmOffset platform expr offset + -- Widen to a native-width register(addressing modes) + indexExpr = CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + (offset, bids) = switchTargetsToTable targets + + +-- Generate jump table data (if required) +-- +-- Relies on PIC relocations. The idea is to emit one table entry per case. The +-- entry is the label of the block to jump to. This will be relocated to be the +-- address of the jump target. +generateJumpTableForInstr :: + NCGConfig -> + Instr -> + Maybe (NatCmmDecl RawCmmStatics Instr) +generateJumpTableForInstr config (J_TBL ids (Just lbl) _) = + let jumpTable = + map jumpTableEntryRel ids + where + jumpTableEntryRel Nothing = + CmmStaticLit (CmmInt 0 (ncgWordWidth config)) + jumpTableEntryRel (Just blockid) = + CmmStaticLit + ( CmmLabelDiffOff + blockLabel + lbl + 0 + (ncgWordWidth config) + ) + where + blockLabel = blockLbl blockid + in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable)) +generateJumpTableForInstr _ _ = Nothing + +-- ----------------------------------------------------------------------------- +-- Top-level of the instruction selector +stmtsToInstrs :: + -- | Cmm Statements + [CmmNode O O] -> + -- | Resulting instruction + NatM InstrBlock +stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts + +stmtToInstrs :: + CmmNode e x -> + -- | Resulting instructions + NatM InstrBlock + +stmtToInstrs stmt = do + config <- getConfig + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genCCall target result_regs args + + CmmComment s -> return (unitOL (COMMENT (ftext s))) + CmmTick {} -> return nilOL + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode format reg src + | otherwise -> assignReg_IntCode format reg src + where ty = cmmRegType reg + format = cmmTypeFormat ty + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _prediction -> + genCondBranch true false arg + + CmmSwitch arg ids -> genSwitch config arg ids + + CmmCall { cml_target = arg } -> genJump arg + + CmmUnwind _regs -> pure nilOL + + _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt) + +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +type InstrBlock = + OrdList Instr + +-- | Register's passed up the tree. +-- If the stix code forces the register to live in a pre-decided machine +-- register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the +-- parent can decide which register to put it in. +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + +-- | Sometimes we need to change the Format of a register. Primarily during +-- conversion. +swizzleRegisterRep :: Format -> Register -> Register +swizzleRegisterRep format' (Fixed _ reg code) = Fixed format' reg code +swizzleRegisterRep format' (Any _ codefn) = Any format' codefn + +-- | Grab a `Reg` for a `CmmReg` +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal (LocalReg u pk)) + = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform (globalRegUse_reg mid) of + Just reg -> RegReal reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + +-- General things for putting together code sequences + +-- | Compute an expression into any register +getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Fixed rep reg code -> + return (reg, rep, code) + +-- | Compute an expression into any floating-point register + +-- | Compute an expression into floating point register +-- If the initial expression is not a floating-point expression, finally move +-- the result into a floating-point register. +getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) +getFloatReg expr = do + r <- getRegister expr + case r of + Any rep code | isFloatFormat rep -> do + tmp <- getNewRegNat rep + return (tmp, rep, code tmp) + Any II32 code -> do + tmp <- getNewRegNat FF32 + return (tmp, FF32, code tmp) + Any II64 code -> do + tmp <- getNewRegNat FF64 + return (tmp, FF64, code tmp) + Any _w _code -> do + config <- getConfig + pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr) + -- can't do much for fixed. + Fixed rep reg code -> + return (reg, rep, code) + +-- | Map `CmmLit` to `OpImm` +litToImm' :: CmmLit -> Operand +litToImm' = OpImm . litToImm + +-- Handling PIC on LA64 +-- Commonly, `PIC` means of `position independent code`, that to say, the execution +-- of code does not be influenced by Load_address. Through PC-Relative addressing +-- or GOT addressing, both can be used to implement `PIC`. +-- +-- For LoongArch's common compiler(GCC, Clang), they generate PIC code by default +-- without condition. The command option `-fPIC` dicates to generate code for +-- shared-library. If not just specified for shared-library, another option `-fPIE` +-- was be created. +-- +-- Like RV64, LA64 does not have a special PIC register, the general approach is to +-- simply do PC-relative addressing or go through the GOT. There is assembly support +-- for both. +-- +-- LA64 assembly has many `la*` (load address) pseudo-instructions, that allows +-- loading a symbols's address into a register. These instructions is desugared into +-- different addressing modes. See following: +-- +-- la rd, label + addend -> Load global symbol +-- la.global rd, label + addend -> Same as `la` +-- la.local rd, label + addend -> Load local symbol +-- la.pcrel rd, label + addend +-- la.got rd, label +-- la.abs rd, label + addend +-- +-- `la` is alias of `la.global`. Commonly recommended use `la.local` and `la.global`. +-- +-- PC-relative addressing: +-- pcalau12i $a0, %pc_hi20(a) +-- addi.d $a0, $a0, %pc_lo12(a) +-- +-- GOT addressing: +-- pcalau12i $a0, %got_pc_hi20(global_a) +-- ld.d $a0, $a0, %got_pc_lo12(global_a) +-- +-- PIC can be enabled/disabled through: +-- .option pic +-- +-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the +-- @cmmMakePicReference@. This is in turn called from @cmmMakeDynamicReference@ +-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported. There are two +-- callsites for this. One is in this module to produce the @target@ in @genCCall@ +-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@. +-- +-- Conceptually we do not want any special PicBaseReg to be used on LA64. If +-- we want to distinguish between symbol loading, we need to address this through +-- the way we load it, not through a register. + +-- Compute a `CmmExpr` into a `Register` +getRegister :: CmmExpr -> NatM Register +getRegister e = do + config <- getConfig + getRegister' config (ncgPlatform config) e + +-- Signed arithmetic on LoongArch64 +-- +-- Handling signed arithmetic on sub-word-size values on LA64 is a bit tricky +-- as Cmm's type system does not capture signedness. While 32- and 64-bit +-- values are fairly easy to handle due to LA64's 32- and 64-bit instructions +-- with responding register, 8- and 16-bit values require quite some care. +-- +-- For LoongArch64, EXT.W.[B/H] will sign-extend 8- and 16-bit to 64-bit. +-- However, it is best to use EXT instruction only if the input and +-- output data widths are fully determined. +-- +-- We handle 16-and 8-bit values by using the following two steps: +-- 1. Sign- or Zero-extending operands. +-- 2. Truncate results as necessary. +-- +-- For simplicity we maintain the invariant that a register containing a +-- sub-word-size value always contains the zero-extended form of that value +-- in between operations. + +getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register + +-- OPTIMIZATION WARNING: CmmExpr rewrites + +-- Generic case. +getRegister' config plat expr = + case expr of + CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) -> + pprPanic "getRegisterReg-memory" (ppr PicBaseReg) + + CmmLit lit -> + case lit of + CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL + CmmInt i w -> do + -- narrowU is important: Negative immediates may be + -- sign-extended on load! + let imm = OpImm . ImmInteger $ narrowU w i + return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm))) + + CmmFloat 0 w -> do + let op = litToImm' lit + pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op))) + + CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr) + CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr) + + CmmFloat f W32 -> do + let word = castFloatToWord32 (fromRational f) :: Word32 + tmp <- getNewRegNat (intFormat W32) + return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W32 tmp) (OpImm (ImmInteger (fromIntegral word))) + , MOV (OpReg W32 dst) (OpReg W32 tmp) + ])) + CmmFloat f W64 -> do + let word = castDoubleToWord64 (fromRational f) :: Word64 + tmp <- getNewRegNat (intFormat W64) + return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr + $ MOV (OpReg W64 tmp) (OpImm (ImmInteger (fromIntegral word))) + , MOV (OpReg W64 dst) (OpReg W64 tmp) + ])) + + CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr) + CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr) + + CmmLabel lbl -> do + let op = OpImm (ImmCLbl lbl) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> unitOL $ annExpr expr (LD format (OpReg (formatToWidth format) dst) op))) + + CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do + let op = OpImm (ImmIndex lbl off) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + return (Any format (\dst -> unitOL $ LD format (OpReg (formatToWidth format) dst) op)) + + CmmLabelOff lbl off -> do + let op = litToImm' (CmmLabel lbl) + rep = cmmLitType plat lit + format = cmmTypeFormat rep + width = typeWidth rep + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + return (Any format (\dst -> off_code `snocOL` + LD format (OpReg (formatToWidth format) dst) op `snocOL` + ADD (OpReg W64 dst) (OpReg width dst) (OpReg width off_r) + )) + + CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) + + CmmLoad mem rep _ -> do + let format = cmmTypeFormat rep + width = typeWidth rep + Amode addr addr_code <- getAmode plat width mem + case width of + w | w `elem` [W8, W16, W32, W64] -> + -- Load without sign-extension. + pure (Any format (\dst -> + addr_code `snocOL` + LDU format (OpReg width dst) (OpAddr addr)) + ) + _ -> pprPanic ("Unknown width to load: " ++ show width) (pdoc plat expr) + + CmmStackSlot _ _ -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) + + CmmReg reg -> return (Fixed (cmmTypeFormat (cmmRegType reg)) + (getRegisterReg plat reg) + nilOL + ) + + CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do + getRegister' config plat + $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where + width = typeWidth (cmmRegType reg) + CmmRegOff reg off -> do + (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) + (reg, _format, code) <- getSomeReg $ CmmReg reg + return $ Any (intFormat width) ( \dst -> + off_code `appOL` + code `snocOL` + ADD (OpReg W64 dst) (OpReg width reg) (OpReg width off_r) + ) + where + width = typeWidth (cmmRegType reg) + + -- Handle MO_RelaxedRead as a normal CmmLoad, to allow + -- non-trivial addressing modes to be used. + CmmMachOp (MO_RelaxedRead w) [e] -> + getRegister (CmmLoad e (cmmBits w) NaturallyAligned) + + -- for MachOps, see GHC.Cmm.MachOp + -- For CmmMachOp, see GHC.Cmm.Expr + CmmMachOp op [e] -> do + (reg, format, code) <- getSomeReg e + case op of + MO_Not w -> return $ Any (intFormat w) $ \dst -> + code `appOL` + -- pseudo instruction `not dst rd` is `nor dst, r0, rd` + truncateReg (formatToWidth format) W64 reg `snocOL` + -- At this point an 8- or 16-bit value would be zero-extended + -- to 64-bits. Truncate back down the final width. + ann (text "not") (NOR (OpReg W64 dst) (OpReg W64 reg) zero) `appOL` + truncateReg W64 w dst + + MO_S_Neg w -> negate code w reg + MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` FNEG (OpReg w dst) (OpReg w reg)) + + -- Floating convertion oprations + -- Float -> Float + MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg)) + + -- Signed int -> Float + MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) + + -- Float -> Signed int + MO_FS_Truncate from to | from == W32 -> do + tmp <- getNewRegNat FF32 + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg)) + + MO_FS_Truncate from to | from == W64-> do + tmp <- getNewRegNat FF64 + return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg)) + + -- unsigned int -> unsigned int + MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> + code `snocOL` BSTRPICK II64 (OpReg W64 dst) (OpReg W64 reg) (OpImm (ImmInt (widthToInt (min from to) - 1))) (OpImm (ImmInt 0)) + ) + + -- Signed int -> Signed int + MO_SS_Conv from to -> ss_conv from to reg code + + -- int -> int + MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e + + MO_WF_Bitcast w -> return $ Any (floatFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + MO_FW_Bitcast w -> return $ Any (intFormat w) (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg)) + + x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr) + where + -- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits + negate code w reg + | w `elem` [W8, W16] = do + return $ Any (intFormat w) $ \dst -> + code `snocOL` + EXT (OpReg W64 reg) (OpReg w reg) `snocOL` + NEG (OpReg W64 dst) (OpReg W64 reg) `appOL` + truncateReg W64 w dst + | otherwise = do + return $ Any (intFormat w) $ \dst -> + code `snocOL` + NEG (OpReg W64 dst) (OpReg w reg) + + ss_conv from to reg code + | from `elem` [W8, W16] || to `elem` [W8, W16] = do + return $ Any (intFormat to) $ \dst -> + code `snocOL` + EXT (OpReg W64 dst) (OpReg (min from to) reg) `appOL` + -- At this point an 8- or 16-bit value would be sign-extended + -- to 64-bits. Truncate back down the final width. + truncateReg W64 to dst + | from == W32 && to == W64 = do + return $ Any (intFormat to) $ \dst -> + code `snocOL` + SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt 0)) + | from == to = do + return $ Any (intFormat from) $ \dst -> + code `snocOL` MOV (OpReg from dst) (OpReg from reg) + | otherwise = do + return $ Any (intFormat to) $ \dst -> + code `appOL` + signExtend from W64 reg dst `appOL` + truncateReg W64 to dst + + +-- Dyadic machops: + -- + -- The general idea is: + -- compute x <- x + -- compute x <- y + -- OP x, x, x + -- + -- TODO: for now we'll only implement the 64bit versions. And rely on the + -- fallthrough to alert us if things go wrong! + -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring + -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg + CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr' + + CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do + if w `elem` [W8, W16] + then do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + else do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ADD (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do + if w `elem` [W8, W16] + then do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + else do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SUB (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_U_Quot w) [x, y] + | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + -- 2. Shifts. + CmmMachOp (MO_Shl w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + _ | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL` + SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y) + ) + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- MO_S_Shr: signed-shift-right + CmmMachOp (MO_S_Shr w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)) + ) + CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + _ | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL` + EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL` + SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y) + ) + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- MO_U_Shr: unsigned-shift-right + CmmMachOp (MO_U_Shr w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + _ | w `elem` [W8, W16] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- 3. Logic &&, || + -- andi Instr's Imm-operand is zero-extended. + CmmMachOp (MO_And w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + + CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + CmmLit (CmmInt n _) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + _ | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- ori Instr's Imm-operand is zero-extended. + CmmMachOp (MO_Or w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + + CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + CmmLit (CmmInt n _) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + _ | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y)) + ) + + -- xori Instr's Imm-operand is zero-extended. + CmmMachOp (MO_Xor w) [x, y] -> + case y of + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + + CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (XOR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + + CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp) + ) + + CmmLit (CmmInt n _) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + tmp <- getNewRegNat II64 + return $ Any (intFormat w) (\dst -> + code_x `snocOL` + annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL` + XOR (OpReg W64 dst) (OpReg w reg_x) (OpReg W64 tmp) + ) + + _ | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + _ -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) (\dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + -- CSET commands register operand being W64. + CmmMachOp (MO_Eq w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_Ne w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Lt w) [x, CmmLit (CmmInt n _)] + | w `elem` [W8, W16, W32] + , fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + signExtend w W64 reg_x reg_x `snocOL` + annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + | fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_U_Lt w) [x, CmmLit (CmmInt n _)] + | w `elem` [W8, W16, W32] + , fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + truncateReg w W64 reg_x `snocOL` + annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))) + ) + | fitsInNbits 12 (fromIntegral n) -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))) + + CmmMachOp (MO_S_Lt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Le w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Ge w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_S_Gt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + signExtend w W64 reg_x reg_x `appOL` + signExtend w W64 reg_y reg_y `snocOL` + annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Lt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Le w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Ge w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + CmmMachOp (MO_U_Gt w) [x, y] + | w `elem` [W8, W16, W32] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `appOL` + truncateReg w W64 reg_x `appOL` + truncateReg w W64 reg_y `snocOL` + annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + | otherwise -> do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + return $ Any (intFormat w) ( \dst -> + code_x `appOL` + code_y `snocOL` + annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)) + ) + + + -- Generic binary case. + CmmMachOp op [x, y] -> do + let + -- A (potentially signed) integer operation. + -- In the case of 8-, 16- and 32-bit signed arithmetic we must first + -- sign-extend all arguments to 64-bits. + -- TODO: can be simplified. + intOp is_signed w op = do + -- compute x <- x + -- compute x <- y + -- x, x, x + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int" + let w' = W64 + -- This is the width of the registers on which the operation + -- should be performed. + if not is_signed + then return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + -- zero-extend both operands + truncateReg (formatToWidth format_x) w' reg_x `appOL` + truncateReg (formatToWidth format_y) w' reg_y `snocOL` + op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + else return $ Any (intFormat w) $ \dst -> + code_x `appOL` + code_y `appOL` + -- sign-extend both operands + signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL` + signExtend (formatToWidth format_x) W64 reg_y reg_y `snocOL` + op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL` + truncateReg w' w dst -- truncate back to the operand's original width + + floatOp w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float" + return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + -- need a special one for conditionals, as they return ints + floatCond w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float" + return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) + + case op of + -- Integer operations + -- Add/Sub should only be Integer Options. + MO_Add w -> intOp False w (\d x y -> annExpr expr (ADD d x y)) + MO_Sub w -> intOp False w (\d x y -> annExpr expr (SUB d x y)) + + -- Signed multiply/divide/remain + MO_Mul w -> intOp True w (\d x y -> annExpr expr (MUL d x y)) + MO_S_MulMayOflo w -> do_mul_may_oflo w x y + + MO_S_Quot w -> intOp True w (\d x y -> annExpr expr (DIV d x y)) + MO_S_Rem w -> intOp True w (\d x y -> annExpr expr (MOD d x y)) + + -- Unsigned divide/remain + MO_U_Quot w -> intOp False w (\d x y -> annExpr expr (DIVU d x y)) + MO_U_Rem w -> intOp False w (\d x y -> annExpr expr (MODU d x y)) + + -- Floating point arithmetic + MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y)) + MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y)) + MO_F_Mul w -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y)) + MO_F_Quot w -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y)) + MO_F_Min w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y)) + MO_F_Max w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y)) + + -- Floating point comparison + MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET EQ d x y)) + MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET NE d x y)) + MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGE d x y)) + MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLE d x y)) + MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGT d x y)) + MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLT d x y)) + + op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr + + -- Generic ternary case. + CmmMachOp op [x, y, z] -> + case op of + + -- Floating-point fused multiply-add operations + MO_FMA var l w + | l == 1 + -> case var of + FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a) + FMSub -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a) + FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a) + FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a) + | otherwise + -> sorry "The RISCV64 backend does not (yet) support vectors." + + _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr) + + where + float3Op w op = do + (reg_fx, format_x, code_fx) <- getFloatReg x + (reg_fy, format_y, code_fy) <- getFloatReg y + (reg_fz, format_z, code_fz) <- getFloatReg z + massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $ + text "float3Op: non-float" + pure $ + Any (floatFormat w) $ \ dst -> + code_fx `appOL` + code_fy `appOL` + code_fz `appOL` + op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz) + + CmmMachOp _op _xs + -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) + + where + -- N.B. MUL does not set the overflow flag. + -- Return 0 when the operation cannot overflow, /= 0 otherwise + do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + do_mul_may_oflo W64 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + lo <- getNewRegNat II64 + hi <- getNewRegNat II64 + return $ Any (intFormat W64) (\dst -> + code_x `appOL` + code_y `snocOL` + MULH (OpReg W64 hi) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + MUL (OpReg W64 lo) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + SRA (OpReg W64 lo) (OpReg W64 lo) (OpImm (ImmInt 63)) `snocOL` + CSET NE (OpReg W64 dst) (OpReg W64 hi) (OpReg W64 lo) + ) + + do_mul_may_oflo W32 x y = do + (reg_x, _format_x, code_x) <- getSomeReg x + (reg_y, _format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II64 + tmp2 <- getNewRegNat II64 + return $ Any (intFormat W32) (\dst -> + code_x `appOL` + code_y `snocOL` + MULW (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + ADD (OpReg W64 tmp2) (OpReg W32 tmp1) (OpImm (ImmInt 0)) `snocOL` + CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2) + ) + + -- General case + do_mul_may_oflo w x y = do + -- Assert: 8bit * 8bit cannot overflow 16bit, and so on. + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + tmp1 <- getNewRegNat II64 + tmp2 <- getNewRegNat II64 + let width_x = formatToWidth format_x + width_y = formatToWidth format_y + extend dst src = + case w of + W8 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0)) + W16 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0)) + _ -> panic "Must be in [W8, W16, W32]!" + extract width dst src = + case width of + W8 -> EXT (OpReg W64 dst) (OpReg W8 src) + W16 -> EXT (OpReg W64 dst) (OpReg W16 src) + W32 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0)) + _ -> panic "Must be in [W8, W16, W32]!" + + case w of + w | (width_x < w) && (width_y < w) -> + return $ Any (intFormat w) ( \dst -> + unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 0))) + ) + w | w <= W32 && width_x <= W32 && width_y <= W32 -> + return $ Any (intFormat W32) (\dst -> + code_x `appOL` + code_y `appOL` + -- signExtend [W8, W16] register to W64 and then SLL + -- nil for W32 + signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL` + signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL` + extend reg_x reg_x `snocOL` + extend reg_y reg_y `snocOL` + -- 64-bits MUL + MUL (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL` + -- extract valid result via result's width + -- slli.w for W32, otherwise ext.w.[b, h] + extract w tmp2 tmp1 `snocOL` + CSET NE (OpReg W64 dst) (OpReg W64 tmp1) (OpReg W64 tmp2) + ) + + -- Should it be happened? + _ -> + return $ Any (intFormat w) ( \dst -> + unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 1)))) + +-- Sign-extend the value in the given register from width @w@ +-- up to width @w'@. +-- TODO: Is there room for optimization? +signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr +signExtend w w' r r' + | w > w' = pprPanic "Sign-extend Error: not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w' + | w > W64 || w' > W64 = pprPanic "Sign-extend Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w' + | w == W64 && w' == W64 && r == r' = nilOL + | w == W32 && w' == W64 = unitOL $ SLL (OpReg W64 r') (OpReg w r) (OpImm (ImmInt 0)) + -- Sign-extend W8 and W16 to W64. + | w `elem` [W8, W16] = unitOL $ EXT (OpReg W64 r') (OpReg w r) + | w == w' = unitOL $ MOV (OpReg w' r') (OpReg w r) + | otherwise = pprPanic "signExtend: Unexpected width: " $ ppr w <> text "->" <+> ppr w' + +-- | Instructions to truncate the value in the given register from width @w@ +-- down to width @w'@. +truncateReg :: Width -> Width -> Reg -> OrdList Instr +truncateReg w w' r + | w > W64 || w' > W64 = pprPanic "Tructate Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w' + | w == w' = nilOL + | w /= w' = toOL + [ + ann + (text "truncateReg: " <+> ppr r <+> ppr w <> text "->" <> ppr w') + (BSTRPICK II64 (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift)) (OpImm (ImmInt 0))) + ] + | otherwise = pprPanic "truncateReg: Unexpected width: " $ ppr w <> text "->" <+> ppr w' + where + shift = (min (widthInBits w) (widthInBits w')) - 1 + +-- The 'Amode' type: Memory addressing modes passed up the tree. +data Amode = Amode AddrMode InstrBlock + +-- | Provide the value of a `CmmExpr` with an `Amode` +-- N.B. this function should be used to provide operands to load and store +-- instructions with signed 12bit wide immediates (S & I types). For other +-- immediate sizes and formats (e.g. B type uses multiples of 2) this function +-- would need to be adjusted. +getAmode :: Platform + -> Width -- ^ width of loaded value + -> CmmExpr + -> NatM Amode + +-- LD/ST: Immediate can be represented with 12bits +getAmode platform w (CmmRegOff reg off) + | w <= W64, fitsInNbits 12 (fromIntegral off) + = return $ Amode (AddrRegImm reg' off') nilOL + where reg' = getRegisterReg platform reg + off' = ImmInt off + +-- For Stores we often see something like this: +-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) +-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] +-- for `n` in range. +getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) + | fitsInNbits 12 (fromIntegral off) + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger off)) code + +getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) + | fitsInNbits 12 (fromIntegral (-off)) + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrRegImm reg (ImmInteger (-off))) code + +-- Generic case +getAmode _platform _ expr + = do (reg, _format, code) <- getSomeReg expr + return $ Amode (AddrReg reg) code + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_IntCode rep addrE srcE + = do + (src_reg, _format, code) <- getSomeReg srcE + platform <- getPlatform + let w = formatToWidth rep + Amode addr addr_code <- getAmode platform w addrE + return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) + `consOL` (code + `appOL` addr_code + `snocOL` ST rep (OpReg w src_reg) (OpAddr addr) + ) + +assignReg_IntCode _ reg src + = do + platform <- getPlatform + let dst = getRegisterReg platform reg + r <- getRegister src + return $ case r of + Any _ code -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst + Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` + (fcode `snocOL` + MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg) + ) + +-- Let's treat Floating point stuff +-- as integer code for now. Opaque. +assignMem_FltCode = assignMem_IntCode +assignReg_FltCode = assignReg_IntCode + +-- Jumps +genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock +genJump expr = do + case expr of + (CmmLit (CmmLabel lbl)) -> do + return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TLabel lbl))) + (CmmLit (CmmBlock bid)) -> do + return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TBlock bid))) + _ -> do + (target, _format, code) <- getSomeReg expr + -- I'd like to do more. + return $ COMMENT (text "genJump for unknow expr: " <+> (text (show expr))) `consOL` + (code `appOL` + unitOL (annExpr expr (J (TReg target))) + ) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump + :: BlockId + -> CmmExpr + -> NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq W64) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ + code_x `snocOL` + BEQZ (OpReg W64 reg_x) (TBlock bid) + CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] + | w `elem` [W8, W16, W32] -> do + (reg_x, format_x, code_x) <- getSomeReg x + return $ + code_x `appOL` + signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL` + BEQZ (OpReg W64 reg_x) (TBlock bid) + + -- Optimized /= 0 case. + CmmMachOp (MO_Ne W64) [x, CmmLit (CmmInt 0 _)] -> do + (reg_x, _format_x, code_x) <- getSomeReg x + return $ code_x `snocOL` (annExpr expr (BNEZ (OpReg W64 reg_x) (TBlock bid))) + CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] + | w `elem` [W8, W16, W32] -> do + (reg_x, format_x, code_x) <- getSomeReg x + return $ + code_x `appOL` + signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL` + BNEZ (OpReg W64 reg_x) (TBlock bid) + + -- Generic case. + CmmMachOp mop [x, y] -> do + let ubcond w cmp = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + return $ case w of + w | w `elem` [W8, W16, W32] -> + code_x `appOL` + truncateReg (formatToWidth format_x) W64 reg_x `appOL` + code_y `appOL` + truncateReg (formatToWidth format_y) W64 reg_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + _ -> + code_x `appOL` + code_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + + sbcond w cmp = do + (reg_x, format_x, code_x) <- getSomeReg x + (reg_y, format_y, code_y) <- getSomeReg y + return $ case w of + w | w `elem` [W8, W16, W32] -> + code_x `appOL` + signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL` + code_y `appOL` + signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + _ -> + code_x `appOL` + code_y `snocOL` + BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) + + fbcond w cmp = do + (reg_fx, _format_fx, code_fx) <- getFloatReg x + (reg_fy, _format_fy, code_fy) <- getFloatReg y + rst <- OpReg W64 <$> getNewRegNat II64 + oneReg <- OpReg W64 <$> getNewRegNat II64 + return $ + code_fx `appOL` + code_fy `snocOL` + CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` + MOV oneReg (OpImm (ImmInt 1)) `snocOL` + BCOND1 EQ rst oneReg (TBlock bid) + + + case mop of + MO_F_Eq w -> fbcond w EQ + MO_F_Ne w -> fbcond w NE + MO_F_Gt w -> fbcond w FGT + MO_F_Ge w -> fbcond w FGE + MO_F_Lt w -> fbcond w FLT + MO_F_Le w -> fbcond w FLE + MO_Eq w -> sbcond w EQ + MO_Ne w -> sbcond w NE + MO_S_Gt w -> sbcond w SGT + MO_S_Ge w -> sbcond w SGE + MO_S_Lt w -> sbcond w SLT + MO_S_Le w -> sbcond w SLE + MO_U_Gt w -> ubcond w UGT + MO_U_Ge w -> ubcond w UGE + MO_U_Lt w -> ubcond w ULT + MO_U_Le w -> ubcond w ULE + _ -> pprPanic "LA64.genCondJump:case mop: " (text $ show expr) + + _ -> pprPanic "LA64.genCondJump: " (text $ show expr) + +-- | Generate conditional branching instructions +-- This is basically an "if with else" statement. +genCondBranch :: + BlockId -> + BlockId -> + CmmExpr -> + NatM InstrBlock +genCondBranch true false expr = do + b1 <- genCondJump true expr + b2 <- genBranch false + return (b1 `appOL` b2) + +-- ----------------------------------------------------------------------------- +{- +Generating C calls + +Generate a call to a C function: + +GARs: 8 general-purpose registers $a0 - $a7, where $a0 and $a1 are also used for +integral values. +FARs: 8 floating-point registers $fa0 - $fa7, where $fa0 and $fa1 are also used +for returning values. + +An argument is passed using the stack only when no appropriate argument register +is available. + +Subroutines should ensure that the initial values of the general-purpose registers +$s0 - $s9 and floating-point registers $fs0 - $fs7 are preserved across the call. + +At the entry of a procedure call, the return address of the call site is stored +in $ra. A branch jump to this address should be the last instruction executed in +the called procedure. + +The on-stack part of the structure and scalar arguments are aligned to the greater +of the type alignment and GRLEN bits, except when this alignment is larger than + the 16-byte stack alignment. In this case, the part of the argument should be +16-byte-aligned. + +In a procedure call, GARs / FARs are generally only used for passing non-floating +-point / floating-point argument data, respectively. However, the floating-point +member of a structure or union argument, or a vector/floating-point argument +wider than FRLEN may be passed in a GAR. +-} + +genCCall + :: ForeignTarget -- function to call + -> [CmmFormal] -- where to put the result + -> [CmmActual] -- arguments (of mixed type) + -> NatM InstrBlock + +-- TODO: Specialize where we can. +-- Generic impl +genCCall target dest_regs arg_regs = do + case target of + -- The target :: ForeignTarget call can either + -- be a foreign procedure with an address expr + -- and a calling convention. + ForeignTarget expr _cconv -> do + (call_target, call_target_code) <- case expr of + -- if this is a label, let's just directly to it. + (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL) + -- if it's not a label, let's compute the expression into a + -- register and jump to that. + _ -> do + (reg, _format, reg_code) <- getSomeReg expr + pure (TReg reg, reg_code) + -- compute the code and register logic for all arg_regs. + -- this will give us the format information to match on. + arg_regs' <- mapM getSomeReg arg_regs + + -- Now this is stupid. Our Cmm expressions doesn't carry the proper sizes + -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in + -- STG; this thenn breaks packing of stack arguments, if we need to pack + -- for the pcs, e.g. darwinpcs. Option one would be to fix the Int type + -- in Cmm proper. Option two, which we choose here is to use extended Hint + -- information to contain the size information and use that when packing + -- arguments, spilled onto the stack. + let (_res_hints, arg_hints) = foreignTargetHints target + arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints + + (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL + + readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL + + let moveStackDown 0 = toOL [ PUSH_STACK_FRAME + , DELTA (-16) + ] + moveStackDown i | odd i = moveStackDown (i + 1) + moveStackDown i = toOL [ PUSH_STACK_FRAME + , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) + , DELTA (-8 * i - 16) + ] + moveStackUp 0 = toOL [ POP_STACK_FRAME + , DELTA 0 + ] + moveStackUp i | odd i = moveStackUp (i + 1) + moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i))) + , POP_STACK_FRAME + , DELTA 0 + ] + + let code = + call_target_code -- compute the label (possibly into a register) + `appOL` moveStackDown (stackSpaceWords) + `appOL` passArgumentsCode -- put the arguments into x0, ... + `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return) + `appOL` readResultsCode -- parse the results into registers + `appOL` moveStackUp (stackSpaceWords) + return code + + PrimTarget MO_F32_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Fabs" + PrimTarget MO_F64_Fabs + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Fabs" + + PrimTarget MO_F32_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F32_Sqrt" + PrimTarget MO_F64_Sqrt + | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs -> + unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg + | otherwise -> panic "mal-formed MO_F64_Sqrt" + + PrimTarget (MO_Clz w) + | w `elem` [W32, W64], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `snocOL` + CLZ (OpReg w dst_reg) (OpReg w reg_x) + ) + | w `elem` [W8, W16], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `appOL` toOL + [ + MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), + SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))), + SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))), + OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), + CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg) + ] + ) + | otherwise -> unsupported (MO_Clz w) + where + shift = widthToInt w + + PrimTarget (MO_Ctz w) + | w `elem` [W32, W64], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `snocOL` + CTZ (OpReg w dst_reg) (OpReg w reg_x) + ) + | w `elem` [W8, W16], + [arg_reg] <- arg_regs, + [dest_reg] <- dest_regs -> do + platform <- getPlatform + (reg_x, _format_x, code_x) <- getSomeReg arg_reg + let dst_reg = getRegisterReg platform (CmmLocal dest_reg) + return ( code_x `appOL` toOL + [ + MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)), + SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)), + BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)), + OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x), + CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg) + ] + ) + | otherwise -> unsupported (MO_Ctz w) + where + shift = (widthToInt w) + + -- mop :: CallishMachOp (see GHC.Cmm.MachOp) + PrimTarget mop -> do + -- We'll need config to construct forien targets + case mop of + -- 64 bit float ops + MO_F64_Pwr -> mkCCall "pow" + + MO_F64_Sin -> mkCCall "sin" + MO_F64_Cos -> mkCCall "cos" + MO_F64_Tan -> mkCCall "tan" + + MO_F64_Sinh -> mkCCall "sinh" + MO_F64_Cosh -> mkCCall "cosh" + MO_F64_Tanh -> mkCCall "tanh" + + MO_F64_Asin -> mkCCall "asin" + MO_F64_Acos -> mkCCall "acos" + MO_F64_Atan -> mkCCall "atan" + + MO_F64_Asinh -> mkCCall "asinh" + MO_F64_Acosh -> mkCCall "acosh" + MO_F64_Atanh -> mkCCall "atanh" + + MO_F64_Log -> mkCCall "log" + MO_F64_Log1P -> mkCCall "log1p" + MO_F64_Exp -> mkCCall "exp" + MO_F64_ExpM1 -> mkCCall "expm1" + + -- 32 bit float ops + MO_F32_Pwr -> mkCCall "powf" + + MO_F32_Sin -> mkCCall "sinf" + MO_F32_Cos -> mkCCall "cosf" + MO_F32_Tan -> mkCCall "tanf" + MO_F32_Sinh -> mkCCall "sinhf" + MO_F32_Cosh -> mkCCall "coshf" + MO_F32_Tanh -> mkCCall "tanhf" + MO_F32_Asin -> mkCCall "asinf" + MO_F32_Acos -> mkCCall "acosf" + MO_F32_Atan -> mkCCall "atanf" + MO_F32_Asinh -> mkCCall "asinhf" + MO_F32_Acosh -> mkCCall "acoshf" + MO_F32_Atanh -> mkCCall "atanhf" + MO_F32_Log -> mkCCall "logf" + MO_F32_Log1P -> mkCCall "log1pf" + MO_F32_Exp -> mkCCall "expf" + MO_F32_ExpM1 -> mkCCall "expm1f" + + -- 64-bit primops + MO_I64_ToI -> mkCCall "hs_int64ToInt" + MO_I64_FromI -> mkCCall "hs_intToInt64" + MO_W64_ToW -> mkCCall "hs_word64ToWord" + MO_W64_FromW -> mkCCall "hs_wordToWord64" + MO_x64_Neg -> mkCCall "hs_neg64" + MO_x64_Add -> mkCCall "hs_add64" + MO_x64_Sub -> mkCCall "hs_sub64" + MO_x64_Mul -> mkCCall "hs_mul64" + MO_I64_Quot -> mkCCall "hs_quotInt64" + MO_I64_Rem -> mkCCall "hs_remInt64" + MO_W64_Quot -> mkCCall "hs_quotWord64" + MO_W64_Rem -> mkCCall "hs_remWord64" + MO_x64_And -> mkCCall "hs_and64" + MO_x64_Or -> mkCCall "hs_or64" + MO_x64_Xor -> mkCCall "hs_xor64" + MO_x64_Not -> mkCCall "hs_not64" + MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64" + MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64" + MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64" + MO_x64_Eq -> mkCCall "hs_eq64" + MO_x64_Ne -> mkCCall "hs_ne64" + MO_I64_Ge -> mkCCall "hs_geInt64" + MO_I64_Gt -> mkCCall "hs_gtInt64" + MO_I64_Le -> mkCCall "hs_leInt64" + MO_I64_Lt -> mkCCall "hs_ltInt64" + MO_W64_Ge -> mkCCall "hs_geWord64" + MO_W64_Gt -> mkCCall "hs_gtWord64" + MO_W64_Le -> mkCCall "hs_leWord64" + MO_W64_Lt -> mkCCall "hs_ltWord64" + + -- Conversion + MO_UF_Conv w -> mkCCall (word2FloatLabel w) + + -- Optional MachOps + -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config + MO_S_Mul2 _w -> unsupported mop + MO_S_QuotRem _w -> unsupported mop + MO_U_QuotRem _w -> unsupported mop + MO_U_QuotRem2 _w -> unsupported mop + MO_Add2 _w -> unsupported mop + MO_AddWordC _w -> unsupported mop + MO_SubWordC _w -> unsupported mop + MO_AddIntC _w -> unsupported mop + MO_SubIntC _w -> unsupported mop + MO_U_Mul2 _w -> unsupported mop + + MO_VS_Quot {} -> unsupported mop + MO_VS_Rem {} -> unsupported mop + MO_VU_Quot {} -> unsupported mop + MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min -> unsupported mop + MO_I64X2_Max -> unsupported mop + MO_W64X2_Min -> unsupported mop + MO_W64X2_Max -> unsupported mop + + -- Memory Ordering + -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier. + -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed; + -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed. + + MO_AcquireFence -> pure (unitOL (DBAR Hint0)) + MO_ReleaseFence -> pure (unitOL (DBAR Hint0)) + MO_SeqCstFence -> pure (unitOL (DBAR Hint0)) + + MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers) + -- Prefetch + MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint. + + -- Memory copy/set/move/cmp, with alignment for optimization + + -- TODO Optimize and use e.g. quad registers to move memory around instead + -- of offloading this to memcpy. For small memcpys we can utilize + -- the 128bit quad registers in NEON to move block of bytes around. + -- Might also make sense of small memsets? Use xzr? What's the function + -- call overhead? + MO_Memcpy _align -> mkCCall "memcpy" + MO_Memset _align -> mkCCall "memset" + MO_Memmove _align -> mkCCall "memmove" + MO_Memcmp _align -> mkCCall "memcmp" + + MO_SuspendThread -> mkCCall "suspendThread" + MO_ResumeThread -> mkCCall "resumeThread" + + MO_PopCnt w -> mkCCall (popCntLabel w) + MO_Pdep w -> mkCCall (pdepLabel w) + MO_Pext w -> mkCCall (pextLabel w) + MO_BSwap w -> mkCCall (bSwapLabel w) + MO_BRev w -> mkCCall (bRevLabel w) + + -- or a possibly side-effecting machine operation + mo@(MO_AtomicRead w ord) + | [p_reg] <- arg_regs + , [dst_reg] <- dest_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + platform <- getPlatform + let instrs = case ord of + MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)) + + MemOrderAcquire -> toOL [ + ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)), + DBAR Hint0 + ] + MemOrderSeqCst -> toOL [ + ann moDescr (DBAR Hint0), + LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p), + DBAR Hint0 + ] + _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo + dst = getRegisterReg platform (CmmLocal dst_reg) + moDescr = (text . show) mo + code = code_p `appOL` instrs + pure code + | otherwise -> panic "mal-formed AtomicRead" + + mo@(MO_AtomicWrite w ord) + | [p_reg, val_reg] <- arg_regs -> do + (p, _fmt_p, code_p) <- getSomeReg p_reg + (val, fmt_val, code_val) <- getSomeReg val_reg + let instrs = case ord of + MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)) + MemOrderRelease -> toOL [ + ann moDescr (DBAR Hint0), + ST fmt_val (OpReg w val) (OpAddr $ AddrReg p) + ] + MemOrderSeqCst -> toOL [ + ann moDescr (DBAR Hint0), + ST fmt_val (OpReg w val) (OpAddr $ AddrReg p), + DBAR Hint0 + ] + _ -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo + moDescr = (text . show) mo + code = + code_p `appOL` + code_val `appOL` + instrs + pure code + | otherwise -> panic "mal-formed AtomicWrite" + + MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) + MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) + MO_Xchg w -> mkCCall (xchgLabel w) + + where + unsupported :: Show a => a -> b + unsupported mop = panic ("outOfLineCmmOp: " ++ show mop + ++ " not supported here") + + mkCCall :: FastString -> NatM InstrBlock + mkCCall name = do + config <- getConfig + target <- + cmmMakeDynamicReference config CallReference + $ mkForeignLabel name ForeignLabelInThisPackage IsFunction + let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn + genCCall (ForeignTarget target cconv) dest_regs arg_regs + + -- Implementiation of the LoongArch ABI calling convention. + -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-arguments + passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock) + + -- 1. Base case: no more arguments to pass (left) + passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode) + + -- 2. Still have GP regs, and we want to pass an GP argument. + passArguments (gpReg : gpRegs) fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + ext + -- Specifically, LoongArch64's ABI requires that the caller + -- sign-extend arguments which are smaller than 64-bits. + | w `elem` [W8, W16, W32] + = case w of + W8 -> EXT (OpReg W64 gpReg) (OpReg w r) + W16 -> EXT (OpReg W64 gpReg) (OpReg w r) + W32 -> SLL (OpReg W64 gpReg) (OpReg w r) (OpImm (ImmInt 0)) + _ -> panic "Unexpected width(Here w < W64)!" + | otherwise + = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass gp argument: " <> ppr r) ext + + passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode' + + -- 3. Still have FP regs, and we want to pass an FP argument. + passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w fpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass fp argument: " <> ppr r) mov + + passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode' + + -- 4. No mor regs left to pass. Must pass on stack. + passArguments [] [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode = do + let w = formatToWidth format + spOffet = 8 * stackSpaceWords + str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) + stackCode = + code_r + `snocOL` (MOV (OpReg w tmpReg) (OpReg w r)) + `appOL` truncateReg w W64 tmpReg + `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str + + passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode) + + -- 5. Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then. + passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do + let w = formatToWidth format + spOffet = 8 * stackSpaceWords + str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet))) + stackCode = + code_r + `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str + + passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode) + + -- 6. Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then. + passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do + let w = formatToWidth format + mov = MOV (OpReg w gpReg) (OpReg w r) + accumCode' = accumCode `appOL` + code_r `snocOL` + ann (text "Pass fp argument in gpReg: " <> ppr r) mov + + passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode' + + + passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state") + + readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock + readResults _ _ [] _ accumCode = return accumCode + readResults [] _ _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target) + readResults _ [] _ _ _ = do + platform <- getPlatform + pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target) + readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do + -- gp/fp reg -> dst + platform <- getPlatform + let rep = cmmRegType (CmmLocal dst) + format = cmmTypeFormat rep + w = cmmRegWidth (CmmLocal dst) + r_dst = getRegisterReg platform (CmmLocal dst) + if isFloatFormat format + then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) + else + readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs) + $ accumCode + `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg) + `appOL` + -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations + truncateReg W64 w r_dst + + unaryFloatOp w op arg_reg dest_reg = do + platform <- getPlatform + (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg + let dst = getRegisterReg platform (CmmLocal dest_reg) + let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx) + pure code + +data BlockInRange = InRange | NotInRange BlockId + +genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock +genCondFarJump cond op1 op2 far_target = do + return $ toOL [ ann (text "Conditional far jump to: " <> ppr far_target) + $ BCOND cond op1 op2 (TBlock far_target) + ] + +makeFarBranches :: + Platform -> + LabelMap RawCmmStatics -> + [NatBasicBlock Instr] -> + UniqDSM [NatBasicBlock Instr] + +makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do + -- All offsets/positions are counted in multiples of 4 bytes (the size of LoongArch64 instructions) + -- That is an offset of 1 represents a 4-byte/one instruction offset. + let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks + if func_size < max_cond_jump_dist + then pure basic_blocks + else do + (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks + pure $ concat blocks + where + max_cond_jump_dist = 2 ^ (15 :: Int) - 8 :: Int + -- Currently all inline info tables fit into 64 bytes. + max_info_size = 16 :: Int + long_bc_jump_dist = 2 :: Int + + -- Replace out of range conditional jumps with unconditional jumps. + replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr]) + replace_blk !m !pos (BasicBlock lbl instrs) = do + -- Account for a potential info table before the label. + let !block_pos = pos + infoTblSize_maybe lbl + (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs + let instrs'' = concat instrs' + -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary. + let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs'' + -- There should be no data in the instruction stream at this point + massert (null no_data) + + let final_blocks = BasicBlock lbl top : split_blocks + pure (pos', final_blocks) + + replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr]) + replace_jump !m !pos instr = do + case instr of + ANN ann instr -> do + replace_jump m pos instr >>= \case + (idx, instr' : instrs') -> pure (idx, ANN ann instr' : instrs') + (idx, []) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx) + + BCOND1 cond op1 op2 t -> + case target_in_range m t pos of + InRange -> pure (pos + 1, [instr]) + NotInRange far_target -> do + jmp_code <- genCondFarJump cond op1 op2 far_target + pure (pos + long_bc_jump_dist, fromOL jmp_code) + + _ -> pure (pos + instr_size instr, [instr]) + + target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange + target_in_range m target src = + case target of + (TReg{}) -> InRange + (TBlock bid) -> block_in_range m src bid + (TLabel clbl) + | Just bid <- maybeLocalBlockLabel clbl + -> block_in_range m src bid + | otherwise + -> InRange + + block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange + block_in_range m src_pos dest_lbl = + case mapLookup dest_lbl m of + Nothing -> + pprTrace "not in range" (ppr dest_lbl) $ NotInRange dest_lbl + Just dest_pos -> + if abs (dest_pos - src_pos) < max_cond_jump_dist + then InRange + else NotInRange dest_lbl + + calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int) + calc_lbl_positions (pos, m) (BasicBlock lbl instrs) = + let !pos' = pos + infoTblSize_maybe lbl + in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs + + instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int) + instr_pos (pos, m) instr = (pos + instr_size instr, m) + + infoTblSize_maybe bid = + case mapLookup bid statics of + Nothing -> 0 :: Int + Just _info_static -> max_info_size + + instr_size :: Instr -> Int + instr_size i = case i of + COMMENT {} -> 0 + MULTILINE_COMMENT {} -> 0 + ANN _ instr -> instr_size instr + LOCATION {} -> 0 + DELTA {} -> 0 + -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m) + NEWBLOCK {} -> panic "mkFarBranched - Unexpected" + LDATA {} -> panic "mkFarBranched - Unexpected" + PUSH_STACK_FRAME -> 4 + POP_STACK_FRAME -> 4 + CSET {} -> 2 + LD _ _ (OpImm (ImmIndex _ _)) -> 3 + LD _ _ (OpImm (ImmCLbl _)) -> 2 + SCVTF {} -> 2 + FCVTZS {} -> 4 + BCOND {} -> long_bc_jump_dist + CALL (TReg _) _ -> 1 + CALL {} -> 2 + CALL36 {} -> 2 + TAIL36 {} -> 2 + _ -> 1 diff --git a/GHC/CmmToAsm/LA64/Cond.hs b/GHC/CmmToAsm/LA64/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Cond.hs @@ -0,0 +1,33 @@ +module GHC.CmmToAsm.LA64.Cond where + +import GHC.Prelude hiding (EQ) + +-- | Condition codes. +-- Used in conditional branches and bit setters. According to the available +-- instruction set, some conditions are encoded as their negated opposites. I.e. +-- these are logical things that don't necessarily map 1:1 to hardware/ISA. +-- TODO: Maybe need to simplify or expand? +data Cond +-- ISA condition + = EQ -- beq + | NE -- bne + | LT -- blt + | GE -- bge + | LTU -- bltu + | GEU -- bgeu + | EQZ -- beqz + | NEZ -- bnez +-- Extra Logical condition + | SLT -- LT + | SLE + | SGE -- GE + | SGT + | ULT -- LTU + | ULE + | UGE -- GEU + | UGT + | FLT + | FLE + | FGE + | FGT + deriving (Eq, Show) diff --git a/GHC/CmmToAsm/LA64/Instr.hs b/GHC/CmmToAsm/LA64/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Instr.hs @@ -0,0 +1,1012 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.CmmToAsm.LA64.Instr where + +import GHC.Prelude + +import GHC.CmmToAsm.LA64.Cond +import GHC.CmmToAsm.LA64.Regs + +import GHC.CmmToAsm.Instr (RegUsage(..)) +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.CmmToAsm.Config +import GHC.Platform.Reg + +import GHC.Platform.Regs +import GHC.Platform.Reg.Class.Separate +import GHC.Cmm.BlockId +import GHC.Cmm.Dataflow.Label +import GHC.Cmm +import GHC.Cmm.CLabel +import GHC.Utils.Outputable +import GHC.Platform +import GHC.Types.Unique.DSM + +import GHC.Utils.Panic +import Data.Maybe +import GHC.Stack +import GHC.Data.FastString (LexicalFastString) + +-- | Stack frame header size +-- Each stack frame contains ra and fp -- prologue. +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * spillSlotSize + +-- | All registers are 8 byte wide. +spillSlotSize :: Int +spillSlotSize = 8 + +-- | The number of bytes that the stack pointer should be aligned to. +stackAlign :: Int +stackAlign = 16 + +-- | The number of spill slots available without allocating more. +maxSpillSlots :: NCGConfig -> Int +maxSpillSlots config + = ( + (ncgSpillPreallocSize config - stackFrameHeaderSize) + `div` + spillSlotSize + ) - 1 + +-- | Convert a spill slot number to a *byte* offset. +spillSlotToOffset :: Int -> Int +spillSlotToOffset slot + = stackFrameHeaderSize + spillSlotSize * slot + +instance Outputable RegUsage where + ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')' + +-- | Get the registers that are being used by this instruction. +-- regUsage doesn't need to do any trickery for jumps and such. +-- Just state precisely the regs read and written by that insn. +-- The consequences of control flow transfers, as far as register +-- allocation goes, are taken care of by the register allocator. +-- +-- RegUsage = RU [] [] +regUsageOfInstr :: Platform -> Instr -> RegUsage +regUsageOfInstr platform instr = case instr of + -- Pseudo Instructions + ANN _ i -> regUsageOfInstr platform i + COMMENT{} -> usage ([], []) + MULTILINE_COMMENT{} -> usage ([], []) + PUSH_STACK_FRAME -> usage ([], []) + POP_STACK_FRAME -> usage ([], []) + DELTA{} -> usage ([], []) + LOCATION{} -> usage ([], []) + + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ALSL dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + ALSLU dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + LU12I dst src1 -> usage (regOp src1, regOp dst) + LU32I dst src1 -> usage (regOp src1, regOp dst) + LU52I dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SSLT dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SSLTU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + PCADDI dst src1 -> usage (regOp src1, regOp dst) + PCADDU12I dst src1 -> usage (regOp src1, regOp dst) + PCADDU18I dst src1 -> usage (regOp src1, regOp dst) + PCALAU12I dst src1 -> usage (regOp src1, regOp dst) + AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + NOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ANDN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ORN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULW dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULWU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MULHU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MOD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MODU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 2. Bit-shift Instructions ------------------------------------------ + SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + ROTR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 3. Bit Manipulation Instructions ------------------------------------------ + EXT dst src1 -> usage (regOp src1, regOp dst) + CLO dst src1 -> usage (regOp src1, regOp dst) + CLZ dst src1 -> usage (regOp src1, regOp dst) + CTO dst src1 -> usage (regOp src1, regOp dst) + CTZ dst src1 -> usage (regOp src1, regOp dst) + BYTEPICK dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + REVB2H dst src1 -> usage (regOp src1, regOp dst) + REVB4H dst src1 -> usage (regOp src1, regOp dst) + REVB2W dst src1 -> usage (regOp src1, regOp dst) + REVBD dst src1 -> usage (regOp src1, regOp dst) + REVH2W dst src1 -> usage (regOp src1, regOp dst) + REVHD dst src1 -> usage (regOp src1, regOp dst) + BITREV4B dst src1 -> usage (regOp src1, regOp dst) + BITREV8B dst src1 -> usage (regOp src1, regOp dst) + BITREVW dst src1 -> usage (regOp src1, regOp dst) + BITREVD dst src1 -> usage (regOp src1, regOp dst) + BSTRINS _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + BSTRPICK _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + MASKEQZ dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + MASKNEZ dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- + -- Pseudo instructions + NOP -> usage ([], []) + MOV dst src -> usage (regOp src, regOp dst) + NEG dst src -> usage (regOp src, regOp dst) + CSET _cond dst src1 src2 -> usage (regOp src1 ++ regOp src2 , regOp dst) + -- 4. Branch Instructions ---------------------------------------------------- + J t -> usage (regTarget t, []) + J_TBL _ _ t -> usage ([t], []) + B t -> usage (regTarget t, []) + BL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) + CALL t ps -> usage (regTarget t ++ ps, callerSavedRegisters) + CALL36 t -> usage (regTarget t, []) + TAIL36 r t -> usage (regTarget t, regOp r) + -- Here two kinds of BCOND and BCOND1 are implemented, mainly because we want + -- to distinguish between two kinds of conditional jumps with different jump + -- ranges, corresponding to 2 and 1 instruction implementations respectively. + -- + -- BCOND1 is selected by default. + BCOND1 _ j d t -> usage (regTarget t ++ regOp j ++ regOp d, []) + BCOND _ j d t -> usage (regTarget t ++ regOp j ++ regOp d, []) + BEQZ j t -> usage (regTarget t ++ regOp j, []) + BNEZ j t -> usage (regTarget t ++ regOp j, []) + -- 5. Common Memory Access Instructions -------------------------------------- + LD _ dst src -> usage (regOp src, regOp dst) + LDU _ dst src -> usage (regOp src, regOp dst) + ST _ dst src -> usage (regOp src ++ regOp dst, []) + LDX _ dst src -> usage (regOp src, regOp dst) + LDXU _ dst src -> usage (regOp src, regOp dst) + STX _ dst src -> usage (regOp src ++ regOp dst, []) + LDPTR _ dst src -> usage (regOp src, regOp dst) + STPTR _ dst src -> usage (regOp src ++ regOp dst, []) + PRELD _hint src -> usage (regOp src, []) + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- LDCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- STCOND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- 8. Barrier Instructions --------------------------------------------------- + DBAR _hint -> usage ([], []) + IBAR _hint -> usage ([], []) + -- 11. Floating Point Instructions ------------------------------------------- + FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMAXA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FMINA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) + FNEG dst src1 -> usage (regOp src1, regOp dst) + + FCVT dst src -> usage (regOp src, regOp dst) + -- SCVTF dst src -> usage (regOp src, regOp src ++ regOp dst) + SCVTF dst src -> usage (regOp src, regOp dst) + FCVTZS dst src1 src2 -> usage (regOp src2, regOp src1 ++ regOp dst) + FABS dst src -> usage (regOp src, regOp dst) + FSQRT dst src -> usage (regOp src, regOp dst) + FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst) + + _ -> panic $ "regUsageOfInstr: " ++ instrCon instr + + where + -- filtering the usage is necessary, otherwise the register + -- allocator will try to allocate pre-defined fixed stg + -- registers as well, as they show up. + usage :: ([Reg], [Reg]) -> RegUsage + usage (srcRegs, dstRegs) = + RU + (map mkFmt $ filter (interesting platform) srcRegs) + (map mkFmt $ filter (interesting platform) dstRegs) + + mkFmt r = RegWithFormat r fmt + where + fmt = case cls of + RcInteger -> II64 + RcFloat -> FF64 + RcVector -> sorry "The LoongArch64 NCG does not (yet) support vectors; please use -fllvm." + cls = case r of + RegVirtual vr -> classOfVirtualReg (platformArch platform) vr + RegReal rr -> classOfRealReg rr + + regAddr :: AddrMode -> [Reg] + regAddr (AddrRegReg r1 r2) = [r1, r2] + regAddr (AddrRegImm r1 _) = [r1] + regAddr (AddrReg r1) = [r1] + + regOp :: Operand -> [Reg] + regOp (OpReg _ r1) = [r1] + regOp (OpAddr a) = regAddr a + regOp (OpImm _) = [] + + regTarget :: Target -> [Reg] + regTarget (TBlock _) = [] + regTarget (TLabel _) = [] + regTarget (TReg r1) = [r1] + + -- Is this register interesting for the register allocator? + interesting :: Platform -> Reg -> Bool + interesting _ (RegVirtual _) = True + interesting platform (RegReal (RealRegSingle i)) = freeReg platform i + +-- | Caller-saved registers (according to calling convention) +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +-- | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +-- |zero| ra | tp | sp | a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | Rv | fp | s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | s8 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +--f| a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | t9 | t10| t11| t12| t13| t14| t15| s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | +-------------------------------------------------------------------------------------------------------------------------------------------------------------------- +callerSavedRegisters :: [Reg] +callerSavedRegisters = + -- TODO: Not sure. + [regSingle 1] -- ra + ++ map regSingle [4 .. 11] -- a0 - a7 + ++ map regSingle [12 .. 20] -- t0 - t8 + ++ map regSingle [32 .. 39] -- fa0 - fa7 + ++ map regSingle [40 .. 55] -- ft0 - ft15 + +-- | Apply a given mapping to all the register references in this instruction. +patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr +patchRegsOfInstr instr env = case instr of + -- 0. Meta Instructions + ANN d i -> ANN d (patchRegsOfInstr i env) + COMMENT{} -> instr + MULTILINE_COMMENT{} -> instr + PUSH_STACK_FRAME -> instr + POP_STACK_FRAME -> instr + DELTA{} -> instr + LOCATION{} -> instr + -- 1. Arithmetic Instructions ------------------------------------------------ + ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) + SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3) + ALSL o1 o2 o3 o4 -> ALSL (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + ALSLU o1 o2 o3 o4 -> ALSLU (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + LU12I o1 o2 -> LU12I (patchOp o1) (patchOp o2) + LU32I o1 o2 -> LU32I (patchOp o1) (patchOp o2) + LU52I o1 o2 o3 -> LU52I (patchOp o1) (patchOp o2) (patchOp o3) + SSLT o1 o2 o3 -> SSLT (patchOp o1) (patchOp o2) (patchOp o3) + SSLTU o1 o2 o3 -> SSLTU (patchOp o1) (patchOp o2) (patchOp o3) + PCADDI o1 o2 -> PCADDI (patchOp o1) (patchOp o2) + PCADDU12I o1 o2 -> PCADDU12I (patchOp o1) (patchOp o2) + PCADDU18I o1 o2 -> PCADDU18I (patchOp o1) (patchOp o2) + PCALAU12I o1 o2 -> PCALAU12I (patchOp o1) (patchOp o2) + AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3) + OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3) + XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3) + NOR o1 o2 o3 -> NOR (patchOp o1) (patchOp o2) (patchOp o3) + ANDN o1 o2 o3 -> ANDN (patchOp o1) (patchOp o2) (patchOp o3) + ORN o1 o2 o3 -> ORN (patchOp o1) (patchOp o2) (patchOp o3) + MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3) + MULW o1 o2 o3 -> MULW (patchOp o1) (patchOp o2) (patchOp o3) + MULWU o1 o2 o3 -> MULWU (patchOp o1) (patchOp o2) (patchOp o3) + MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3) + MULHU o1 o2 o3 -> MULHU (patchOp o1) (patchOp o2) (patchOp o3) + DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3) + MOD o1 o2 o3 -> MOD (patchOp o1) (patchOp o2) (patchOp o3) + DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3) + MODU o1 o2 o3 -> MODU (patchOp o1) (patchOp o2) (patchOp o3) + -- 2. Bit-shift Instructions ------------------------------------------ + SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3) + SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3) + SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3) + ROTR o1 o2 o3 -> ROTR (patchOp o1) (patchOp o2) (patchOp o3) + -- 3. Bit Manipulation Instructions ------------------------------------------ + EXT o1 o2 -> EXT (patchOp o1) (patchOp o2) + CLO o1 o2 -> CLO (patchOp o1) (patchOp o2) + CLZ o1 o2 -> CLZ (patchOp o1) (patchOp o2) + CTO o1 o2 -> CTO (patchOp o1) (patchOp o2) + CTZ o1 o2 -> CTZ (patchOp o1) (patchOp o2) + BYTEPICK o1 o2 o3 o4 -> BYTEPICK (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + REVB2H o1 o2 -> REVB2H (patchOp o1) (patchOp o2) + REVB4H o1 o2 -> REVB4H (patchOp o1) (patchOp o2) + REVB2W o1 o2 -> REVB2W (patchOp o1) (patchOp o2) + REVBD o1 o2 -> REVBD (patchOp o1) (patchOp o2) + REVH2W o1 o2 -> REVH2W (patchOp o1) (patchOp o2) + REVHD o1 o2 -> REVHD (patchOp o1) (patchOp o2) + BITREV4B o1 o2 -> BITREV4B (patchOp o1) (patchOp o2) + BITREV8B o1 o2 -> BITREV8B (patchOp o1) (patchOp o2) + BITREVW o1 o2 -> BITREVW (patchOp o1) (patchOp o2) + BITREVD o1 o2 -> BITREVD (patchOp o1) (patchOp o2) + BSTRINS f o1 o2 o3 o4 -> BSTRINS f (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + BSTRPICK f o1 o2 o3 o4 -> BSTRPICK f (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + MASKEQZ o1 o2 o3 -> MASKEQZ (patchOp o1) (patchOp o2) (patchOp o3) + MASKNEZ o1 o2 o3 -> MASKNEZ (patchOp o1) (patchOp o2) (patchOp o3) + -- + -- Pseudo instrcutions + NOP -> NOP + MOV o1 o2 -> MOV (patchOp o1) (patchOp o2) + NEG o1 o2 -> NEG (patchOp o1) (patchOp o2) + CSET cond o1 o2 o3 -> CSET cond (patchOp o1) (patchOp o2) (patchOp o3) + -- 4. Branch Instructions ---------------------------------------------------- + -- TODO: + J t -> J (patchTarget t) + J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t) + B t -> B (patchTarget t) + BL t ps -> BL (patchTarget t) ps + CALL t ps -> CALL (patchTarget t) ps + CALL36 t -> CALL36 (patchTarget t) + TAIL36 r t -> TAIL36 (patchOp r) (patchTarget t) + BCOND1 c j d t -> BCOND1 c (patchOp j) (patchOp d) (patchTarget t) + BCOND c j d t -> BCOND c (patchOp j) (patchOp d) (patchTarget t) + BEQZ j t -> BEQZ (patchOp j) (patchTarget t) + BNEZ j t -> BNEZ (patchOp j) (patchTarget t) + -- 5. Common Memory Access Instructions -------------------------------------- + -- TODO: + LD f o1 o2 -> LD f (patchOp o1) (patchOp o2) + LDU f o1 o2 -> LDU f (patchOp o1) (patchOp o2) + ST f o1 o2 -> ST f (patchOp o1) (patchOp o2) + LDX f o1 o2 -> LDX f (patchOp o1) (patchOp o2) + LDXU f o1 o2 -> LDXU f (patchOp o1) (patchOp o2) + STX f o1 o2 -> STX f (patchOp o1) (patchOp o2) + LDPTR f o1 o2 -> LDPTR f (patchOp o1) (patchOp o2) + STPTR f o1 o2 -> STPTR f (patchOp o1) (patchOp o2) + PRELD o1 o2 -> PRELD (patchOp o1) (patchOp o2) + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- LDCOND o1 o2 o3 -> LDCOND (patchOp o1) (patchOp o2) (patchOp o3) + -- STCOND o1 o2 o3 -> STCOND (patchOp o1) (patchOp o2) (patchOp o3) + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- 8. Barrier Instructions --------------------------------------------------- + -- TODO: need fix + DBAR o1 -> DBAR o1 + IBAR o1 -> IBAR o1 + -- 11. Floating Point Instructions ------------------------------------------- + FCVT o1 o2 -> FCVT (patchOp o1) (patchOp o2) + SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) + FCVTZS o1 o2 o3 -> FCVTZS (patchOp o1) (patchOp o2) (patchOp o3) + FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3) + FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3) + FMINA o1 o2 o3 -> FMINA (patchOp o1) (patchOp o2) (patchOp o3) + FMAXA o1 o2 o3 -> FMAXA (patchOp o1) (patchOp o2) (patchOp o3) + FNEG o1 o2 -> FNEG (patchOp o1) (patchOp o2) + FABS o1 o2 -> FABS (patchOp o1) (patchOp o2) + FSQRT o1 o2 -> FSQRT (patchOp o1) (patchOp o2) + FMA s o1 o2 o3 o4 -> FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) + + _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr + where + -- TODO: + patchOp :: Operand -> Operand + patchOp (OpReg w r) = OpReg w (env r) + patchOp (OpAddr a) = OpAddr (patchAddr a) + patchOp opImm = opImm + + patchTarget :: Target -> Target + patchTarget (TReg r) = TReg (env r) + patchTarget t = t + + patchAddr :: AddrMode -> AddrMode + patchAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2) + patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm + patchAddr (AddrReg r) = AddrReg (env r) + +-------------------------------------------------------------------------------- + +-- | Checks whether this instruction is a jump/branch instruction. +-- One that can change the flow of control in a way that the +-- register allocator needs to worry about. +isJumpishInstr :: Instr -> Bool +isJumpishInstr instr = case instr of + ANN _ i -> isJumpishInstr i + J {} -> True + J_TBL {} -> True + B {} -> True + BL {} -> True + CALL {} -> True + CALL36 {} -> True + TAIL36 {} -> True + BCOND1 {} -> True + BCOND {} -> True + BEQZ {} -> True + BNEZ {} -> True + _ -> False + +-- | Get the `BlockId`s of the jump destinations (if any) +jumpDestsOfInstr :: Instr -> [BlockId] +jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i +jumpDestsOfInstr (J t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids +jumpDestsOfInstr (B t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]] +jumpDestsOfInstr (CALL t _) = [id | TBlock id <- [t]] +jumpDestsOfInstr (CALL36 t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (TAIL36 _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BCOND1 _ _ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BEQZ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr (BNEZ _ t) = [id | TBlock id <- [t]] +jumpDestsOfInstr _ = [] + +-- | Change the destination of this (potential) jump instruction. +-- Used in the linear allocator when adding fixup blocks for join +-- points. +patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr +patchJumpInstr instr patchF = + case instr of + ANN d i -> ANN d (patchJumpInstr i patchF) + J (TBlock bid) -> J (TBlock (patchF bid)) + J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r + B (TBlock bid) -> B (TBlock (patchF bid)) + BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps + CALL (TBlock bid) ps -> CALL (TBlock (patchF bid)) ps + CALL36 (TBlock bid) -> CALL36 (TBlock (patchF bid)) + TAIL36 r (TBlock bid) -> TAIL36 r (TBlock (patchF bid)) + BCOND1 c o1 o2 (TBlock bid) -> BCOND1 c o1 o2 (TBlock (patchF bid)) + BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid)) + BEQZ j (TBlock bid) -> BEQZ j (TBlock (patchF bid)) + BNEZ j (TBlock bid) -> BNEZ j (TBlock (patchF bid)) + _ -> panic $ "patchJumpInstr: " ++ instrCon instr + +-- ----------------------------------------------------------------------------- +-- | Make a spill instruction, spill a register into spill slot. +mkSpillInstr + :: HasCallStack + => NCGConfig + -> RegWithFormat -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkSpillInstr _config (RegWithFormat reg _fmt) delta slot = + case off - delta of + imm | fitsInNbits 12 imm -> [mkStrSpImm imm] + imm -> + [ movImmToIp imm, + addSpToIp, + mkStrIp + ] + where + fmt = case reg of + RegReal (RealRegSingle n) | n < 32 -> II64 + _ -> FF64 + mkStrSpImm imm = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm))) + movImmToIp imm = ANN (text "Spill: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm)) + addSpToIp = ANN (text "Spill: TMP <- SP + TMP ") $ ADD tmp tmp sp + mkStrIp = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg)) + off = spillSlotToOffset slot + +-- | Make a reload instruction, reload from spill slot to a register. +mkLoadInstr + :: NCGConfig + -> RegWithFormat + -> Int -- current stack delta + -> Int -- spill slot to use + -> [Instr] + +mkLoadInstr _config (RegWithFormat reg _fmt) delta slot = + case off - delta of + imm | fitsInNbits 12 imm -> [mkLdrSpImm imm] + imm -> + [ movImmToIp imm, + addSpToIp, + mkLdrIp + ] + where + fmt = case reg of + RegReal (RealRegSingle n) | n < 32 -> II64 + _ -> FF64 + mkLdrSpImm imm = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm))) + movImmToIp imm = ANN (text "Reload: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm)) + addSpToIp = ANN (text "Reload: TMP <- SP + TMP ") $ ADD tmp tmp sp + mkLdrIp = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg)) + off = spillSlotToOffset slot + +-- | See if this instruction is telling us the current C stack delta +takeDeltaInstr :: Instr -> Maybe Int +takeDeltaInstr (ANN _ i) = takeDeltaInstr i +takeDeltaInstr (DELTA i) = Just i +takeDeltaInstr _ = Nothing + +-- | Not real instructions. Just meta data +isMetaInstr :: Instr -> Bool +isMetaInstr instr = + case instr of + ANN _ i -> isMetaInstr i + COMMENT {} -> True + MULTILINE_COMMENT {} -> True + LOCATION {} -> True + NEWBLOCK {} -> True + DELTA {} -> True + LDATA {} -> True + PUSH_STACK_FRAME -> True + POP_STACK_FRAME -> True + _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid = + case insn of + J (TBlock target) -> bid == target + J_TBL targets _ _ -> all isTargetBid targets + B (TBlock target) -> bid == target + TAIL36 _ (TBlock target) -> bid == target + BCOND1 _ _ _ (TBlock target) -> bid == target + BCOND _ _ _ (TBlock target) -> bid == target + _ -> False + where + isTargetBid target = case target of + Nothing -> True + Just target -> target == bid + +-- | Copy the value in a register to another one. +-- Must work for all register classes. +mkRegRegMoveInstr :: Reg -> Reg -> Instr +mkRegRegMoveInstr src dst = ANN desc instr + where + desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst + instr = MOV (OpReg W64 dst) (OpReg W64 src) + +-- | Take the source and destination from this (potential) reg -> reg move instruction +-- We have to be a bit careful here: A `MOV` can also mean an implicit +-- conversion. This case is filtered out. +takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg) +takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src)) + | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst) +takeRegRegMoveInstr _ = Nothing + +-- | Make an unconditional jump instruction. +mkJumpInstr :: BlockId -> [Instr] +mkJumpInstr id = [TAIL36 (OpReg W64 tmpReg) (TBlock (id))] + +-- | Decrement @sp@ to allocate stack space. +mkStackAllocInstr :: Platform -> Int -> [Instr] +mkStackAllocInstr _platform n + | n == 0 = [] + | n > 0 && fitsInNbits 12 (fromIntegral n) = + [ ANN (text "Alloc stack") $ SUB sp sp (OpImm (ImmInt n)) ] + | n > 0 = + [ + ANN (text "Alloc more stack") (MOV tmp (OpImm (ImmInt n))), + SUB sp sp tmp + ] +mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n) + +-- | Increment SP to deallocate stack space. +mkStackDeallocInstr :: Platform -> Int -> [Instr] +mkStackDeallocInstr _platform n + | n == 0 = [] + | n > 0 && fitsInNbits 12 (fromIntegral n) = + [ ANN (text "Dealloc stack") $ ADD sp sp (OpImm (ImmInt n)) ] + | n > 0 = + [ + ANN (text "Dealloc more stack") (MOV tmp (OpImm (ImmInt n))), + ADD sp sp tmp + ] +mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n) + +allocMoreStack + :: Platform + -> Int + -> NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr + -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr, [(BlockId,BlockId)]) + +allocMoreStack _ _ top@(CmmData _ _) = return (top, []) +allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do + let entries = entryBlocks proc + + retargetList <- mapM (\e -> (e,) <$> newBlockId) entries + + let + delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up + where x = slots * spillSlotSize -- sp delta + + alloc = mkStackAllocInstr platform delta + dealloc = mkStackDeallocInstr platform delta + + new_blockmap :: LabelMap BlockId + new_blockmap = mapFromList retargetList + + insert_stack_insn (BasicBlock id insns) + | Just new_blockid <- mapLookup id new_blockmap = + [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ], + BasicBlock new_blockid block' ] + | otherwise = + [ BasicBlock id block' ] + where + block' = foldr insert_dealloc [] insns + + insert_dealloc insn r = case insn of + J {} -> dealloc ++ (insn : r) + ANN _ e -> insert_dealloc e r + _other | jumpDestsOfInstr insn /= [] -> + patchJumpInstr insn retarget : r + _other -> insn : r + + where retarget b = fromMaybe b (mapLookup b new_blockmap) + + new_code = concatMap insert_stack_insn code + return (CmmProc info lbl live (ListGraph new_code), retargetList) + +-- ----------------------------------------------------------------------------- +-- Machine's assembly language + +-- We have a few common "instructions" (nearly all the pseudo-ops) but +-- mostly all of 'Instr' is machine-specific. + +data Instr + -- comment pseudo-op + = COMMENT SDoc + | MULTILINE_COMMENT SDoc + + -- Annotated instruction. Should print # + | ANN SDoc Instr + + -- location pseudo-op (file, line, col, name) + | LOCATION Int Int Int LexicalFastString + + -- start a new basic block. Useful during codegen, removed later. + -- Preceding instruction should be a jump, as per the invariants + -- for a BasicBlock (see Cmm). + | NEWBLOCK BlockId + + -- specify current stack offset for benefit of subsequent passes. + -- This carries a BlockId so it can be used in unwinding information. + | DELTA Int + + -- | Static data spat out during code generation. + | LDATA Section RawCmmStatics + + | PUSH_STACK_FRAME + | POP_STACK_FRAME + -- Basic Integer Instructions ------------------------------------------------ + -- 1. Arithmetic Instructions ------------------------------------------------ + | ADD Operand Operand Operand + | SUB Operand Operand Operand + | ALSL Operand Operand Operand Operand + | ALSLU Operand Operand Operand Operand + | LU12I Operand Operand + | LU32I Operand Operand + | LU52I Operand Operand Operand + | SSLT Operand Operand Operand + | SSLTU Operand Operand Operand + | PCADDI Operand Operand + | PCADDU12I Operand Operand + | PCADDU18I Operand Operand + | PCALAU12I Operand Operand + | AND Operand Operand Operand + | OR Operand Operand Operand + | XOR Operand Operand Operand + | NOR Operand Operand Operand + | ANDN Operand Operand Operand + | ORN Operand Operand Operand + | MUL Operand Operand Operand + | MULW Operand Operand Operand + | MULWU Operand Operand Operand + | MULH Operand Operand Operand + | MULHU Operand Operand Operand + | DIV Operand Operand Operand + | DIVU Operand Operand Operand + | MOD Operand Operand Operand + | MODU Operand Operand Operand + -- 2. Bit-shift Instuctions -------------------------------------------------- + | SLL Operand Operand Operand + | SRL Operand Operand Operand + | SRA Operand Operand Operand + | ROTR Operand Operand Operand + -- 3. Bit-manupulation Instructions ------------------------------------------ + | EXT Operand Operand + | CLO Operand Operand + | CTO Operand Operand + | CLZ Operand Operand + | CTZ Operand Operand + | BYTEPICK Operand Operand Operand Operand + | REVB2H Operand Operand + | REVB4H Operand Operand + | REVB2W Operand Operand + | REVBD Operand Operand + | REVH2W Operand Operand + | REVHD Operand Operand + | BITREV4B Operand Operand + | BITREV8B Operand Operand + | BITREVW Operand Operand + | BITREVD Operand Operand + | BSTRINS Format Operand Operand Operand Operand + | BSTRPICK Format Operand Operand Operand Operand + | MASKEQZ Operand Operand Operand + | MASKNEZ Operand Operand Operand + -- Pseudo instructions + | NOP + | MOV Operand Operand + | NEG Operand Operand + | CSET Cond Operand Operand Operand + -- 4. Branch Instructions ---------------------------------------------------- + | J Target + | J_TBL [Maybe BlockId] (Maybe CLabel) Reg + | B Target + | BL Target [Reg] + | CALL Target [Reg] + | CALL36 Target + | TAIL36 Operand Target + | BCOND1 Cond Operand Operand Target + | BCOND Cond Operand Operand Target + | BEQZ Operand Target + | BNEZ Operand Target + -- 5. Common Memory Access Instructions -------------------------------------- + | LD Format Operand Operand + | LDU Format Operand Operand + | ST Format Operand Operand + | LDX Format Operand Operand + | LDXU Format Operand Operand + | STX Format Operand Operand + | LDPTR Format Operand Operand + | STPTR Format Operand Operand + | PRELD Operand Operand + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- 8. Barrier Instructions --------------------------------------------------- + | DBAR BarrierType + | IBAR BarrierType + -- Basic Floating Point Instructions ----------------------------------------- + | FCVT Operand Operand + | SCVTF Operand Operand + | FCVTZS Operand Operand Operand + | FMAX Operand Operand Operand + | FMIN Operand Operand Operand + | FMAXA Operand Operand Operand + | FMINA Operand Operand Operand + | FNEG Operand Operand + | FABS Operand Operand + | FSQRT Operand Operand + -- Floating-point fused multiply-add instructions + -- fmadd : d = r1 * r2 + r3 + -- fnmsub: d = r1 * r2 - r3 + -- fmsub : d = - r1 * r2 + r3 + -- fnmadd: d = - r1 * r2 - r3 + | FMA FMASign Operand Operand Operand Operand + +-- TODO: Not complete. +data BarrierType = Hint0 + +instrCon :: Instr -> String +instrCon i = + case i of + COMMENT{} -> "COMMENT" + MULTILINE_COMMENT{} -> "COMMENT" + ANN{} -> "ANN" + LOCATION{} -> "LOCATION" + NEWBLOCK{} -> "NEWBLOCK" + DELTA{} -> "DELTA" + LDATA {} -> "LDATA" + PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME" + POP_STACK_FRAME{} -> "POP_STACK_FRAME" + + ADD{} -> "ADD" + SUB{} -> "SUB" + ALSL{} -> "ALSL" + ALSLU{} -> "ALSLU" + LU12I{} -> "LU12I" + LU32I{} -> "LU32I" + LU52I{} -> "LU52I" + SSLT{} -> "SSLT" + SSLTU{} -> "SSLTU" + PCADDI{} -> "PCADDI" + PCADDU12I{} -> "PCADDU12I" + PCADDU18I{} -> "PCADDU18I" + PCALAU12I{} -> "PCALAU12I" + AND{} -> "AND" + OR{} -> "OR" + XOR{} -> "XOR" + NOR{} -> "NOR" + ANDN{} -> "ANDN" + ORN{} -> "ORN" + MUL{} -> "MUL" + MULW{} -> "MULW" + MULWU{} -> "MULWU" + MULH{} -> "MULH" + MULHU{} -> "MULHU" + DIV{} -> "DIV" + MOD{} -> "MOD" + DIVU{} -> "DIVU" + MODU{} -> "MODU" + SLL{} -> "SLL" + SRL{} -> "SRL" + SRA{} -> "SRA" + ROTR{} -> "ROTR" + EXT{} -> "EXT" + CLO{} -> "CLO" + CLZ{} -> "CLZ" + CTO{} -> "CTO" + CTZ{} -> "CTZ" + BYTEPICK{} -> "BYTEPICK" + REVB2H{} -> "REVB2H" + REVB4H{} -> "REVB4H" + REVB2W{} -> "REVB2W" + REVBD{} -> "REVBD" + REVH2W{} -> "REVH2W" + REVHD{} -> "REVHD" + BITREV4B{} -> "BITREV4B" + BITREV8B{} -> "BITREV8B" + BITREVW{} -> "BITREVW" + BITREVD{} -> "BITREVD" + BSTRINS{} -> "BSTRINS" + BSTRPICK{} -> "BSTRPICK" + MASKEQZ{} -> "MASKEQZ" + MASKNEZ{} -> "MASKNEZ" + NOP{} -> "NOP" + MOV{} -> "MOV" + NEG{} -> "NEG" + CSET{} -> "CSET" + J{} -> "J" + J_TBL{} -> "J_TBL" + B{} -> "B" + BL{} -> "BL" + CALL{} -> "CALL" + CALL36{} -> "CALL36" + TAIL36{} -> "TAIL36" + BCOND1{} -> "BCOND1" + BCOND{} -> "BCOND" + BEQZ{} -> "BEQZ" + BNEZ{} -> "BNEZ" + LD{} -> "LD" + LDU{} -> "LDU" + ST{} -> "ST" + LDX{} -> "LDX" + LDXU{} -> "LDXU" + STX{} -> "STX" + LDPTR{} -> "LDPTR" + STPTR{} -> "STPTR" + PRELD{} -> "PRELD" + DBAR{} -> "DBAR" + IBAR{} -> "IBAR" + FCVT{} -> "FCVT" + SCVTF{} -> "SCVTF" + FCVTZS{} -> "FCVTZS" + FMAX{} -> "FMAX" + FMIN{} -> "FMIN" + FMAXA{} -> "FMAXA" + FMINA{} -> "FMINA" + FNEG{} -> "FNEG" + FABS{} -> "FABS" + FSQRT{} -> "FSQRT" + FMA variant _ _ _ _ -> + case variant of + FMAdd -> "FMADD" + FMSub -> "FMSUB" + FNMAdd -> "FNMADD" + FNMSub -> "FNMSUB" + +data Target + = TBlock BlockId + | TLabel CLabel + | TReg Reg + +data Operand + = OpReg Width Reg -- register + | OpImm Imm -- immediate + | OpAddr AddrMode -- address + deriving (Eq, Show) + +opReg :: Reg -> Operand +opReg = OpReg W64 + +opRegNo :: RegNo -> Operand +opRegNo = opReg . regSingle + +-- LoongArch64 has no ip register in ABI. Here ip register is for spilling/ +-- reloading register to/from slots. So make t8(r20) non-free for ip. +zero, ra, tp, sp, fp, tmp :: Operand +zero = opReg zeroReg +ra = opReg raReg +sp = opReg spMachReg +tp = opReg tpMachReg +fp = opReg fpMachReg +tmp = opReg tmpReg + +x0, x1, x2, x3, x4, x5, x6, x7 :: Operand +x8, x9, x10, x11, x12, x13, x14, x15 :: Operand +x16, x17, x18, x19, x20, x21, x22, x23 :: Operand +x24, x25, x26, x27, x28, x29, x30, x31 :: Operand +x0 = opRegNo 0 +x1 = opRegNo 1 +x2 = opRegNo 2 +x3 = opRegNo 3 +x4 = opRegNo 4 +x5 = opRegNo 5 +x6 = opRegNo 6 +x7 = opRegNo 7 +x8 = opRegNo 8 +x9 = opRegNo 9 +x10 = opRegNo 10 +x11 = opRegNo 11 +x12 = opRegNo 12 +x13 = opRegNo 13 +x14 = opRegNo 14 +x15 = opRegNo 15 +x16 = opRegNo 16 +x17 = opRegNo 17 +x18 = opRegNo 18 +x19 = opRegNo 19 +x20 = opRegNo 20 +x21 = opRegNo 21 +x22 = opRegNo 22 +x23 = opRegNo 23 +x24 = opRegNo 24 +x25 = opRegNo 25 +x26 = opRegNo 26 +x27 = opRegNo 27 +x28 = opRegNo 18 +x29 = opRegNo 29 +x30 = opRegNo 30 +x31 = opRegNo 31 + +d0, d1, d2, d3, d4, d5, d6, d7 :: Operand +d8, d9, d10, d11, d12, d13, d14, d15 :: Operand +d16, d17, d18, d19, d20, d21, d22, d23 :: Operand +d24, d25, d26, d27, d28, d29, d30, d31 :: Operand +d0 = opRegNo 32 +d1 = opRegNo 33 +d2 = opRegNo 34 +d3 = opRegNo 35 +d4 = opRegNo 36 +d5 = opRegNo 37 +d6 = opRegNo 38 +d7 = opRegNo 39 +d8 = opRegNo 40 +d9 = opRegNo 41 +d10 = opRegNo 42 +d11 = opRegNo 43 +d12 = opRegNo 44 +d13 = opRegNo 45 +d14 = opRegNo 46 +d15 = opRegNo 47 +d16 = opRegNo 48 +d17 = opRegNo 49 +d18 = opRegNo 50 +d19 = opRegNo 51 +d20 = opRegNo 52 +d21 = opRegNo 53 +d22 = opRegNo 54 +d23 = opRegNo 55 +d24 = opRegNo 56 +d25 = opRegNo 57 +d26 = opRegNo 58 +d27 = opRegNo 59 +d28 = opRegNo 60 +d29 = opRegNo 61 +d30 = opRegNo 62 +d31 = opRegNo 63 + +fitsInNbits :: Int -> Int -> Bool +fitsInNbits n i = (-1 `shiftL` (n - 1)) <= i && i <= (1 `shiftL` (n - 1) - 1) + +isUnsignOp :: Int -> Bool +isUnsignOp i = (i >= 0) + +isNbitEncodeable :: Int -> Integer -> Bool +isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + +isEncodeableInWidth :: Width -> Integer -> Bool +isEncodeableInWidth = isNbitEncodeable . widthInBits + +isIntOp :: Operand -> Bool +isIntOp = not . isFloatOp + +isFloatOp :: Operand -> Bool +isFloatOp (OpReg _ reg) | isFloatReg reg = True +isFloatOp _ = False + +isFloatReg :: Reg -> Bool +isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True +isFloatReg (RegVirtual (VirtualRegD _)) = True +isFloatReg _ = False + +widthToInt :: Width -> Int +widthToInt W8 = 8 +widthToInt W16 = 16 +widthToInt W32 = 32 +widthToInt W64 = 64 +widthToInt _ = 64 + +widthFromOpReg :: Operand -> Width +widthFromOpReg (OpReg W8 _) = W8 +widthFromOpReg (OpReg W16 _) = W16 +widthFromOpReg (OpReg W32 _) = W32 +widthFromOpReg (OpReg W64 _) = W64 +widthFromOpReg _ = W64 + +ldFormat :: Format -> Format +ldFormat f + | f `elem` [II8, II16, II32, II64] = II64 + | f `elem` [FF32, FF64] = FF64 + | otherwise = pprPanic "unsupported ldFormat: " (text $ show f) diff --git a/GHC/CmmToAsm/LA64/Ppr.hs b/GHC/CmmToAsm/LA64/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Ppr.hs @@ -0,0 +1,1149 @@ +module GHC.CmmToAsm.LA64.Ppr (pprNatCmmDecl, pprInstr) where + +import GHC.Prelude hiding (EQ) + +import GHC.CmmToAsm.LA64.Regs +import GHC.CmmToAsm.LA64.Instr +import GHC.CmmToAsm.LA64.Cond +import GHC.CmmToAsm.Config +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Types +import GHC.CmmToAsm.Utils +import GHC.Cmm hiding (topInfoTable) +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Label +import GHC.Platform +import GHC.Platform.Reg +import GHC.Types.Unique ( pprUniqueAlways, getUnique ) +import GHC.Utils.Outputable +import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment) +import GHC.Utils.Panic + +pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc + +pprNatCmmDecl config (CmmData section dats) = + pprSectionAlign config section $$ pprDatas config dats + +pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = + let platform = ncgPlatform config + + pprProcAlignment :: doc + pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config) + in pprProcAlignment + $$ case topInfoTable proc of + Nothing -> + -- special case for code without info table: + pprSectionAlign config (Section Text lbl) + $$ + -- do not + -- pprProcAlignment config $$ + pprLabel platform lbl + $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed + $$ ppWhen + (ncgDwarfEnabled config) + (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) + $$ pprSizeDecl platform lbl + Just (CmmStaticsRaw info_lbl _) -> + pprSectionAlign config (Section Text info_lbl) + $$ + -- pprProcAlignment config $$ + ( if platformHasSubsectionsViaSymbols platform + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') + else empty + ) + $$ vcat (map (pprBasicBlock config top_info) blocks) + $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) + $$ + -- above: Even the first block gets a label, because with branch-chain + -- elimination, it might be the target of a goto. + ( if platformHasSubsectionsViaSymbols platform + then -- See Note [Subsections Via Symbols] + + line + $ text "\t.long " + <+> pprAsmLabel platform info_lbl + <+> char '-' + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) + else empty + ) + $$ pprSizeDecl platform info_lbl +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-} +{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure + -> doc +pprProcEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon + +pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name + -> doc +pprBlockEndLabel platform lbl = + pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon + +pprLabel :: IsDoc doc => Platform -> CLabel -> doc +pprLabel platform lbl = + pprGloblDecl platform lbl + $$ pprTypeDecl platform lbl + $$ line (pprAsmLabel platform lbl <> char ':') + +pprAlign :: (IsDoc doc) => Alignment -> doc +pprAlign alignment = + -- .balign is stable, whereas .align is platform dependent. + line $ text "\t.balign " <> int (alignmentBytes alignment) + +-- | Print appropriate alignment for the given section type. +-- +-- Currently, this always aligns to a full machine word (8 byte.) A future +-- improvement could be to really do this per section type (though, it's +-- probably not a big gain.) +pprAlignForSection :: (IsDoc doc) => SectionType -> doc +pprAlignForSection _seg = pprAlign . mkAlignment $ 8 + +-- Print section header and appropriate alignment for that section. +-- This will e.g. emit a header like: +-- +-- .section .text +-- .balign 8 +-- +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc +pprSectionAlign _config (Section (OtherSection _) _) = + panic "LA64.Ppr.pprSectionAlign: unknown section" +pprSectionAlign config sec@(Section seg _) = + line (pprSectionHeader config sec) + $$ pprAlignForSection seg + +-- | Output the ELF .size directive +pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = + line $ text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl +pprSizeDecl _ _ = empty + +pprBasicBlock :: + (IsDoc doc) => + NCGConfig -> + LabelMap RawCmmStatics -> + NatBasicBlock Instr -> + doc + +pprBasicBlock config info_env (BasicBlock blockid instrs) + = maybe_infotable $ + pprLabel platform asmLbl $$ + vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ + ppWhen (ncgDwarfEnabled config) ( + -- Emit both end labels since this may end up being a standalone + -- top-level block + line (pprBlockEndLabel platform asmLbl + <> pprProcEndLabel platform asmLbl) + ) + where + -- Filter out identity moves. E.g. mov x18, x18 will be dropped. + optInstrs = filter f instrs + where f (MOV o1 o2) | o1 == o2 = False + f _ = True + + asmLbl = blockLbl blockid + platform = ncgPlatform config + maybe_infotable c = case mapLookup blockid info_env of + Nothing -> c + Just (CmmStaticsRaw info_lbl info) -> + -- pprAlignForSection platform Text $$ + infoTableLoc $$ + vcat (map (pprData config) info) $$ + pprLabel platform info_lbl $$ + c $$ + ppWhen (ncgDwarfEnabled config) + (line (pprBlockEndLabel platform info_lbl)) + -- Make sure the info table has the right .loc for the block + -- coming right after it. See Note [Info Offset] + infoTableLoc = case instrs of + (l@LOCATION{} : _) -> pprInstr platform l + _other -> empty + +pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc +-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". +pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' + = pprGloblDecl (ncgPlatform config) alias + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') + +pprDatas config (CmmStaticsRaw lbl dats) + = vcat (pprLabel platform lbl : map (pprData config) dats) + where + platform = ncgPlatform config + +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) + +pprData config (CmmUninitialised bytes) + = line $ let platform = ncgPlatform config + in if platformOS platform == OSDarwin + then text ".space " <> int bytes + else text ".skip " <> int bytes + +pprData config (CmmStaticLit lit) = pprDataItem config lit + +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc +pprGloblDecl platform lbl + | not (externallyVisibleCLabel lbl) = empty + | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl) + +-- Always use objects for info tables +-- +-- See discussion in X86.Ppr for why this is necessary. Essentially we need to +-- ensure that we never pass function symbols when we might want to lookup the +-- info table. If we did, we could end up with procedure linking tables +-- (PLT)s, and thus the lookup wouldn't point to the function, but into the +-- jump table. +-- +-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as +-- well. +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc +pprLabelType' platform lbl = + if isCFunctionLabel lbl || functionOkInfoTable + then text "@function" + else text "@object" + where + functionOkInfoTable = platformTablesNextToCode platform && + isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) + +-- this is called pprTypeAndSizeDecl in PPC.Ppr +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc +pprTypeDecl platform lbl + = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) + else empty + +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc +pprDataItem config lit + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + where + platform = ncgPlatform config + + imm = litToImm lit + + ppr_item II8 _ = [text "\t.byte\t" <> pprDataImm platform imm] + ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm] + ppr_item II32 _ = [text "\t.long\t" <> pprDataImm platform imm] + ppr_item II64 _ = [text "\t.quad\t" <> pprDataImm platform imm] + + ppr_item FF32 (CmmFloat r _) + = let bs = floatToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + + ppr_item FF64 (CmmFloat r _) + = let bs = doubleToBytes (fromRational r) + in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs + + ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) + +-- | Pretty print an immediate value in the @data@ section +-- This does not include any checks. We rely on the Assembler to check for +-- errors. Use `pprOpImm` for immediates in instructions (operands.) +pprDataImm :: IsLine doc => Platform -> Imm -> doc +pprDataImm _ (ImmInt i) = int i +pprDataImm _ (ImmInteger i) = integer i +pprDataImm p (ImmCLbl l) = pprAsmLabel p l +pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i +pprDataImm _ (ImmLit s) = ftext s +pprDataImm _ (ImmFloat f) = float (fromRational f) +pprDataImm _ (ImmDouble d) = double (fromRational d) + +pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b +pprDataImm p (ImmConstantDiff a b) = pprDataImm p a <> char '-' + <> lparen <> pprDataImm p b <> rparen + +asmComment :: SDoc -> SDoc +asmComment c = text "#" <+> c + +asmDoubleslashComment :: SDoc -> SDoc +asmDoubleslashComment c = text "//" <+> c + +asmMultilineComment :: SDoc -> SDoc +asmMultilineComment c = text "/*" $+$ c $+$ text "*/" + +-- | Pretty print an immediate operand of an instruction +pprOpImm :: (IsLine doc) => Platform -> Imm -> doc +pprOpImm platform imm = case imm of + ImmInt i -> int i + ImmInteger i -> integer i + ImmCLbl l -> char '=' <> pprAsmLabel platform l + ImmFloat f -> float (fromRational f) + ImmDouble d -> double (fromRational d) + _ -> pprPanic "LA64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands:" <+> (text . show) imm) + +negOp :: Operand -> Operand +negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i)) +negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i)) +negOp op = pprPanic "LA64.negOp" (text $ show op) + +pprOp :: IsLine doc => Platform -> Operand -> doc +pprOp plat op = case op of + OpReg w r -> pprReg w r + OpImm imm -> pprOpImm plat imm + OpAddr (AddrRegReg r1 r2) -> pprReg W64 r1 <> comma <+> pprReg W64 r2 + OpAddr (AddrRegImm r imm) -> pprReg W64 r <> comma <+> pprOpImm plat imm + OpAddr (AddrReg r) -> pprReg W64 r <+> text ", 0" + +pprReg :: forall doc. IsLine doc => Width -> Reg -> doc +pprReg w r = case r of + RegReal (RealRegSingle i) -> ppr_reg_no i + -- virtual regs should not show up, but this is helpful for debugging. + RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u + -- RegVirtual (VirtualRegF u) -> text "%vF_" <> pprUniqueAlways u + RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u + _ -> pprPanic "LA64.pprReg" (text (show r) <+> ppr w) + + where + ppr_reg_no :: Int -> doc + -- LoongArch's registers must be started from `$[fr]` + -- General Purpose Registers + ppr_reg_no 0 = text "$zero" + ppr_reg_no 1 = text "$ra" + ppr_reg_no 2 = text "$tp" + ppr_reg_no 3 = text "$sp" + ppr_reg_no 4 = text "$a0" + ppr_reg_no 5 = text "$a1" + ppr_reg_no 6 = text "$a2" + ppr_reg_no 7 = text "$a3" + ppr_reg_no 8 = text "$a4" + ppr_reg_no 9 = text "$a5" + ppr_reg_no 10 = text "$a6" + ppr_reg_no 11 = text "$a7" + ppr_reg_no 12 = text "$t0" + ppr_reg_no 13 = text "$t1" + ppr_reg_no 14 = text "$t2" + ppr_reg_no 15 = text "$t3" + ppr_reg_no 16 = text "$t4" + ppr_reg_no 17 = text "$t5" + ppr_reg_no 18 = text "$t6" + ppr_reg_no 19 = text "$t7" + ppr_reg_no 20 = text "$t8" + ppr_reg_no 21 = text "$u0" -- Reserverd + ppr_reg_no 22 = text "$fp" + ppr_reg_no 23 = text "$s0" + ppr_reg_no 24 = text "$s1" + ppr_reg_no 25 = text "$s2" + ppr_reg_no 26 = text "$s3" + ppr_reg_no 27 = text "$s4" + ppr_reg_no 28 = text "$s5" + ppr_reg_no 29 = text "$s6" + ppr_reg_no 30 = text "$s7" + ppr_reg_no 31 = text "$s8" + + -- Floating Point Registers + ppr_reg_no 32 = text "$fa0" + ppr_reg_no 33 = text "$fa1" + ppr_reg_no 34 = text "$fa2" + ppr_reg_no 35 = text "$fa3" + ppr_reg_no 36 = text "$fa4" + ppr_reg_no 37 = text "$fa5" + ppr_reg_no 38 = text "$fa6" + ppr_reg_no 39 = text "$fa7" + ppr_reg_no 40 = text "$ft0" + ppr_reg_no 41 = text "$ft1" + ppr_reg_no 42 = text "$ft2" + ppr_reg_no 43 = text "$ft3" + ppr_reg_no 44 = text "$ft4" + ppr_reg_no 45 = text "$ft5" + ppr_reg_no 46 = text "$ft6" + ppr_reg_no 47 = text "$ft7" + ppr_reg_no 48 = text "$ft8" + ppr_reg_no 49 = text "$ft9" + ppr_reg_no 50 = text "$ft10" + ppr_reg_no 51 = text "$ft11" + ppr_reg_no 52 = text "$ft12" + ppr_reg_no 53 = text "$ft13" + ppr_reg_no 54 = text "$ft14" + ppr_reg_no 55 = text "$ft15" + ppr_reg_no 56 = text "$fs0" + ppr_reg_no 57 = text "$fs1" + ppr_reg_no 58 = text "$fs2" + ppr_reg_no 59 = text "$fs3" + ppr_reg_no 60 = text "$fs4" + ppr_reg_no 61 = text "$fs5" + ppr_reg_no 62 = text "$fs6" + ppr_reg_no 63 = text "$fs7" + + ppr_reg_no i + | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i) + | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i) + -- no support for widths > W64. + | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i) + +-- | Single precission `Operand` (floating-point) +isSingleOp :: Operand -> Bool +isSingleOp (OpReg W32 _) = True +isSingleOp _ = False + +-- | Double precission `Operand` (floating-point) +isDoubleOp :: Operand -> Bool +isDoubleOp (OpReg W64 _) = True +isDoubleOp _ = False + +-- | `Operand` is an immediate value +isImmOp :: Operand -> Bool +isImmOp (OpImm _) = True +isImmOp _ = False + +-- | `Operand` is an immediate @0@ value +isImmZero :: Operand -> Bool +isImmZero (OpImm (ImmFloat 0)) = True +isImmZero (OpImm (ImmDouble 0)) = True +isImmZero (OpImm (ImmInt 0)) = True +isImmZero _ = False + +pprInstr :: IsDoc doc => Platform -> Instr -> doc +pprInstr platform instr = case instr of + -- Meta Instructions --------------------------------------------------------- + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + COMMENT s -> dualDoc (asmComment s) empty + MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty + ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i) + + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) + DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty + NEWBLOCK _ -> panic "PprInstr: NEWBLOCK" + LDATA _ _ -> panic "PprInstr: NEWBLOCK" + + -- Pseudo Instructions ------------------------------------------------------- + + PUSH_STACK_FRAME -> lines_ [ text "\taddi.d $sp, $sp, -16" + , text "\tst.d $ra, $sp, 8" + , text "\tst.d $fp, $sp, 0" + , text "\taddi.d $fp, $sp, 16" + ] + + POP_STACK_FRAME -> lines_ [ text "\tld.d $fp, $sp, 0" + , text "\tld.d $ra, $sp, 8" + , text "\taddi.d $sp, $sp, 16" + ] + + + -- =========================================================================== + -- LoongArch64 Instruction Set + -- Basic Integer Instructions ------------------------------------------------ + -- 1. Arithmetic Instructions ------------------------------------------------ + -- ADD.{W/D}, SUB.{W/D} + -- ADDI.{W/D}, ADDU16I.D + ADD o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: ADD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- TODO: Not complete. + -- Here we should add addu16i.d for optimizations of accelerating GOT accession + -- with ldptr.w/d, stptr.w/d + SUB o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3 + | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 (negOp o3) + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 (negOp o3) + | otherwise -> pprPanic "LA64.ppr: SUB error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- ALSL.{W[U]/D} + ALSL o1 o2 o3 o4 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4 + | otherwise -> pprPanic "LA64.ppr: ALSL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + ALSLU o1 o2 o3 o4 -> op4 (text "\talsl.wu") o1 o2 o3 o4 + -- LoongArch-Assembler should implement following pesudo instructions, here we can directly use them. + -- li.w rd, s32 + -- li.w rd, u32 + -- li.d rd, s64 + -- li.d rd, u64 + -- + -- # Load with one instruction + -- ori dst, $zero, imm[11:0] + -- + -- # Load with two instructions + -- lu12i.w dst, imm[31:12] + -- ori dst, dst, imm[11:0] + -- + -- # Load with four instructions + -- lu12i.w dst, imm[31:12] + -- ori dst, dst, imm[11:0] + -- lu32i.d dst, imm[51:32] + -- lu52i.d dst, dst, imm[63:52] + + -- -- LU12I.W, LU32I.D, LU52I.D + LU12I o1 o2 -> op2 (text "\tlu12i.w") o1 o2 + LU32I o1 o2 -> op2 (text "\tlu32i.d") o1 o2 + LU52I o1 o2 o3 -> op3 (text "\tlu52i.d") o1 o2 o3 + -- SSLT[U] + -- SSLT[U]I + SSLT o1 o2 o3 + | isImmOp o3 -> op3 (text "\tslti") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tslt") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: SSLT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + SSLTU o1 o2 o3 + | isImmOp o3 -> op3 (text "\tsltui") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: SSLTU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- PCADDI, PCADDU121, PCADDU18l, PCALAU12I + PCADDI o1 o2 -> op2 (text "\tpcaddi") o1 o2 + PCADDU12I o1 o2 -> op2 (text "\tpcaddu12i") o1 o2 + PCADDU18I o1 (OpImm (ImmCLbl lbl)) -> + lines_ [ + text "\tpcaddu18i" <+> pprOp platform o1 <> comma <+> text "%call36(" <+> pprAsmLabel platform lbl <+> text ")" + ] + PCALAU12I o1 o2 -> op2 (text "\tpcalau12i") o1 o2 + -- AND, OR, NOR, XOR, ANDN, ORN + -- ANDI, ORI, XORI: zero-extention + AND o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tandi") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: AND error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + OR o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tori") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: OR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + XOR o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3 + | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\txori") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: XOR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + NOR o1 o2 o3 -> op3 (text "\tnor") o1 o2 o3 + ANDN o1 o2 o3 -> op3 (text "\tandn") o1 o2 o3 + ORN o1 o2 o3 -> op3 (text "\torn") o1 o2 o3 + + ----------------------------------------------------------------------------- + -- Pseudo instructions + -- NOP, alias for "andi r0, r0, r0" + NOP -> line $ text "\tnop" + -- NEG o1 o2, alias for "sub o1, r0, o2" + NEG o1 o2 + | isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2 + | isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2 + | OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2 + | OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2 + | otherwise -> pprPanic "LA64.ppr: NEG error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + -- Here we can do more simplitcations. + -- To be honest, floating point instructions are too scarce, so maybe + -- we should reimplement some pseudo instructions with others. + MOV o1 o2 + | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> op2 (text "\tfmov.s") o1 o2 + | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> op2 (text "\tfmov.d") o1 o2 + | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 zero + | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 zero + | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 o2 + | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 o2 + | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tmovfr2gr.s") o1 o2 + | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tmovfr2gr.d") o1 o2 + | isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) -> + lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2] + | isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) -> + lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2] + | OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2 + | OpReg _ _ <- o2 -> + lines_ [ + text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt (min (widthFromOpReg o1) (widthFromOpReg o2))) - 1))) <+> text ", 0" + ] + -- TODO: Maybe we can do more. + -- Let the assembler do these concret things. + | isImmOp o2 -> + lines_ [text "\tli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2] + | otherwise -> pprPanic "LA64.ppr: MOV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + -- CSET pesudo instrcutions implementation + CSET cond dst o1 o2 -> case cond of + -- SEQ dst, rd, rs -> [SUB rd, rd, rs; sltui dst, rd, 1] + EQ | isIntOp o1 && isIntOp o2 -> + lines_ [ + subFor o1 o2, + text "\tsltui" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + EQ | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.seq.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + EQ | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.seq.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + -- SNE rd, rs -> [SUB rd, rd, rs; sltu rd, zero, rs] + NE | isIntOp o1 && isIntOp o2 -> + lines_ [ + subFor o1 o2, + text "\tsltu" <+> pprOp platform dst <> comma <+> text "$r0" <+> comma <+> pprOp platform dst + ] + NE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.cune.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + NE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.cune.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + SLT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ] + -- SLE rd, rs -> [SLT rd, rs; xori rd, rs, o1] + SLE -> + lines_ [ + sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- SGE rd, rs -> [SLT rd, rs; xori rd, rs, o1] + SGE -> + lines_ [ + sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- SGT rd, rs -> [SLT rd, rs] + SGT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ] + + ULT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ] + ULE -> + lines_ [ + sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- UGE rd, rs -> [SLTU rd, rs; xori rd, rs, 1] + UGE -> + lines_ [ + sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1)) + ] + -- SGTU rd, rs -> [SLTU rd, rs] + UGT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ] + + -- TODO: + -- LoongArch's floating point instrcutions don't write the compared result to an interger register, instead of cc. + -- Fcond dst o1 o2 -> [fcmp.cond.[s/d] fcc0 o1 o2; movcf2gr dst, fcc0] + FLT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.slt.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FLE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.sle.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.slt.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> + lines_ [ + text "\tfcmp.sle.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + + FLT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.slt.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FLE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.sle.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.slt.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + FGE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> + lines_ [ + text "\tfcmp.sle.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1, + text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0" + ] + + _ -> pprPanic "LA64.ppr: CSET error: " (pprCond cond <+> pprOp platform dst <> comma <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + where + subFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = + text "\taddi.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (negOp o2) + | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = + text "\tsub.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | otherwise = pprPanic "LA64.ppr: unknown subFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + sltFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = text "\tslti" + | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tslt" + | otherwise = pprPanic "LA64.ppr: unknown sltFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2 = text "\tsltui" + | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tsltu" + | otherwise = pprPanic "LA64.ppr: unknown sltuFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + + -- MUL.{W/D}, MULH, {W[U]/D[U]}, 'h' means high 32bit. + -- MULW.D.W[U] + MUL o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfmul.s") o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfmul.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MUL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULW o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULW error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULWU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULWU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULH o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULH error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MULHU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MULHU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- DIV.{W[U]/D[U]}, MOD.{W[U]/D[U]} + DIV o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfdiv.s") o1 o2 o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfdiv.d") o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: DIV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + DIVU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: DIVU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MOD o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MOD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + MODU o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3 + | otherwise -> pprPanic "LA64.ppr: MODU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- 2. Bit-shift Instuctions -------------------------------------------------- + -- SLL.W, SRL.W, SRA.W, ROTR.W + -- SLL.D, SRL.D, SRA.D, ROTR.D + -- SLLI.W, SRLI.W, SRAI.W, ROTRI.W + -- SLLI.D, SRLI.D, SRAI.D, ROTRI.D + SLL o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: SLL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + SRL o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: SRL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + SRA o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: SRA error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + ROTR o1 o2 o3 + | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3 + | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3 + | OpReg W32 _ <- o2, isImmOp o3 -> + lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | OpReg W64 _ <- o2, isImmOp o3 -> + lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3] + | otherwise -> pprPanic "LA64.ppr: ROTR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3) + -- 3. Bit-manupulation Instructions ------------------------------------------ + -- EXT.W{B/H} + EXT o1 o2 + | OpReg W8 _ <- o2 -> op2 (text "\text.w.b") o1 o2 + | OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2 + | otherwise -> pprPanic "LA64.ppr: EXT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2) + -- CL{O/Z}.{W/D}, CT{O/Z}.{W/D} + CLO o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tclo.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tclo.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CLO error" (pprOp platform o1 <+> pprOp platform o2) + CLZ o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tclz.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tclz.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CLZ error" (pprOp platform o1 <+> pprOp platform o2) + CTO o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tcto.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tcto.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CTO error" (pprOp platform o1 <+> pprOp platform o2) + CTZ o1 o2 + | OpReg W32 _ <- o2 -> op2 (text "\tctz.w") o1 o2 + | OpReg W64 _ <- o2 -> op2 (text "\tctz.d") o1 o2 + | otherwise -> pprPanic "LA64.ppr: CTZ error" (pprOp platform o1 <+> pprOp platform o2) + -- BYTEPICK.{W/D} rd, rj, rk, sa2/sa3 + BYTEPICK o1 o2 o3 o4 + | OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4 + | OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4 + | otherwise -> pprPanic "LA64.ppr: BYTEPICK error" (pprOp platform o1 <+> pprOp platform o2 <+> pprOp platform o3 <+> pprOp platform o4) + -- REVB.{2H/4H/2W/D} + REVB2H o1 o2 -> op2 (text "\trevb.2h") o1 o2 + REVB4H o1 o2 -> op2 (text "\trevb.4h") o1 o2 + REVB2W o1 o2 -> op2 (text "\trevb.2w") o1 o2 + REVBD o1 o2 -> op2 (text "\trevb.d") o1 o2 + -- REVH.{2W/D} + REVH2W o1 o2 -> op2 (text "\trevh.2w") o1 o2 + REVHD o1 o2 -> op2 (text "\trevh.d") o1 o2 + -- BITREV.{4B/8B} + -- BITREV.{W/D} + BITREV4B o1 o2 -> op2 (text "\tbitrev.4b") o1 o2 + BITREV8B o1 o2 -> op2 (text "\tbitrev.8b") o1 o2 + BITREVW o1 o2 -> op2 (text "\tbitrev.w") o1 o2 + BITREVD o1 o2 -> op2 (text "\tbitrev.d") o1 o2 + -- BSTRINS.{W/D} + BSTRINS II64 o1 o2 o3 o4 -> op4 (text "\tbstrins.d") o1 o2 o3 o4 + BSTRINS II32 o1 o2 o3 o4 -> op4 (text "\tbstrins.w") o1 o2 o3 o4 + -- BSTRPICK.{W/D} + BSTRPICK II64 o1 o2 o3 o4 -> op4 (text "\tbstrpick.d") o1 o2 o3 o4 + BSTRPICK II32 o1 o2 o3 o4 -> op4 (text "\tbstrpick.w") o1 o2 o3 o4 + -- MASKEQZ rd, rj, rk: if rk == 0 ? rd = 0 : rd = rj + MASKEQZ o1 o2 o3 -> op3 (text "\tmaskeqz") o1 o2 o3 + -- MASKNEZ: if rk == 0 ? rd = 0 : rd = rj + MASKNEZ o1 o2 o3 -> op3 (text "\tmasknez") o1 o2 o3 + -- 4. Branch Instructions ---------------------------------------------------- + -- BEQ, BNE, BLT[U], BGE[U] rj, rd, off16 + -- BEQZ, BNEZ rj, off21 + -- B + -- BL + -- JIRL + -- jr rd = jirl $zero, rd, 0: Commonly used for subroutine return. + J (TReg r) -> line $ text "\tjirl" <+> text "$r0" <> comma <+> pprReg W64 r <> comma <+> text " 0" + J_TBL _ _ r -> pprInstr platform (B (TReg r)) + + B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl + B (TReg r) -> line $ text "\tjr" <+> pprReg W64 r + + BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl + BL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0" + + CALL (TBlock bid) _ -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CALL (TLabel lbl) _ -> line $ text "\tcall36" <+> pprAsmLabel platform lbl + CALL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0" + + CALL36 (TBlock bid) -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CALL36 (TLabel lbl) -> line $ text "\tcall36" <+> pprAsmLabel platform lbl + CALL36 _ -> panic "LA64.ppr: CALL36: Not to registers!" + TAIL36 r (TBlock bid) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + TAIL36 r (TLabel lbl) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform lbl + TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Not to registers!" + + BCOND1 c j d (TBlock bid) -> case c of + SLE -> + line $ text "\tbge" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + SGT -> + line $ text "\tblt" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ULE -> + line $ text "\tbgeu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + UGT -> + line $ text "\tbltu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + + BCOND1 _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND1: No conditional branching to TLabel!" + + BCOND1 _ _ _ (TReg _) -> panic "LA64.ppr: BCOND1: No conditional branching to registers!" + + -- Reuse t8(IP) register + BCOND c j d (TBlock bid) -> case c of + SLE -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + SGT -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + ULE -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + UGT -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform d <> comma <+> pprOp platform j, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + EQ -> + lines_ [ + text "\tsub.d $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + NE -> + lines_ [ + text "\tsub.d $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + SLT -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + SGE -> + lines_ [ + text "\tslt $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + ULT -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + UGE -> + lines_ [ + text "\tsltu $t8, " <+> pprOp platform j <> comma <+> pprOp platform d, + text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + ] + _ -> panic "LA64.ppr: BCOND: Unsupported cond!" + + BCOND _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND: No conditional branching to TLabel!" + + BCOND _ _ _ (TReg _) -> panic "LA64.ppr: BCOND: No conditional branching to registers!" + + BEQZ j (TBlock bid) -> + line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BEQZ j (TLabel lbl) -> + line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl + BEQZ _ (TReg _) -> panic "LA64.ppr: BEQZ: No conditional branching to registers!" + + BNEZ j (TBlock bid) -> + line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + BNEZ j (TLabel lbl) -> + line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl + BNEZ _ (TReg _) -> panic "LA64.ppr: BNEZ: No conditional branching to registers!" + + -- 5. Common Memory Access Instructions -------------------------------------- + -- LD.{B[U]/H[U]/W[U]/D}, ST.{B/H/W/D}: AddrRegImm + -- LD: load, ST: store, x: offset in register, u: load unsigned imm. + -- LD format dst src: 'src' means final address, not single register or immdiate. + -- Load symbol's address + LD _fmt o1 (OpImm (ImmIndex lbl' off)) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + LD _fmt o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + LD _fmt o1 (OpImm (ImmIndex lbl off)) -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off + ] + + LD _fmt o1 (OpImm (ImmCLbl lbl')) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + ] + LD _fmt o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\tld.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + ] + LD _fmt o1 (OpImm (ImmCLbl lbl)) -> + lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")" + , text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")" + ] + + LD II8 o1 o2 -> op2 (text "\tld.b") o1 o2 + LD II16 o1 o2 -> op2 (text "\tld.h") o1 o2 + LD II32 o1 o2 -> op2 (text "\tld.w") o1 o2 + LD II64 o1 o2 -> op2 (text "\tld.d") o1 o2 + LD FF32 o1 o2 -> op2 (text "\tfld.s") o1 o2 + LD FF64 o1 o2 -> op2 (text "\tfld.d") o1 o2 + + LDU II8 o1 o2 -> op2 (text "\tld.bu") o1 o2 + LDU II16 o1 o2 -> op2 (text "\tld.hu") o1 o2 + LDU II32 o1 o2 -> op2 (text "\tld.wu") o1 o2 + LDU II64 o1 o2 -> op2 (text "\tld.d") o1 o2 -- double words (64bit) cannot be sign extended by definition + LDU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld.s") o1 o2 + LDU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld.s") o1 o2 + LDU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld.d") o1 o2 + LDU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld.d") o1 o2 + LDU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text.show) f <+> pprOp platform o1 <+> pprOp platform o2) + + ST II8 o1 o2 -> op2 (text "\tst.b") o1 o2 + ST II16 o1 o2 -> op2 (text "\tst.h") o1 o2 + ST II32 o1 o2 -> op2 (text "\tst.w") o1 o2 + ST II64 o1 o2 -> op2 (text "\tst.d") o1 o2 + ST FF32 o1 o2 -> op2 (text "\tfst.s") o1 o2 + ST FF64 o1 o2 -> op2 (text "\tfst.d") o1 o2 + + -- LDPTR.{W/D}, STPTR.{W/D}: AddrRegImm: AddrRegImm + LDPTR II32 o1 o2 -> op2 (text "\tldptr.w") o1 o2 + LDPTR II64 o1 o2 -> op2 (text "\tldptr.d") o1 o2 + STPTR II32 o1 o2 -> op2 (text "\tstptr.w") o1 o2 + STPTR II64 o1 o2 -> op2 (text "\tstptr.d") o1 o2 + + -- LDX.{B[U]/H[U]/W[U]/D}, STX.{B/H/W/D}: AddrRegReg + LDX II8 o1 o2 -> op2 (text "\tldx.b") o1 o2 + LDX II16 o1 o2 -> op2 (text "\tldx.h") o1 o2 + LDX II32 o1 o2 -> op2 (text "\tldx.w") o1 o2 + LDX II64 o1 o2 -> op2 (text "\tldx.d") o1 o2 + LDX FF32 o1 o2 -> op2 (text "\tfldx.s") o1 o2 + LDX FF64 o1 o2 -> op2 (text "\tfldx.d") o1 o2 + LDXU II8 o1 o2 -> op2 (text "\tldx.bu") o1 o2 + LDXU II16 o1 o2 -> op2 (text "\tldx.hu") o1 o2 + LDXU II32 o1 o2 -> op2 (text "\tldx.wu") o1 o2 + LDXU II64 o1 o2 -> op2 (text "\tldx.d") o1 o2 + STX II8 o1 o2 -> op2 (text "\tstx.b") o1 o2 + STX II16 o1 o2 -> op2 (text "\tstx.h") o1 o2 + STX II32 o1 o2 -> op2 (text "\tstx.w") o1 o2 + STX II64 o1 o2 -> op2 (text "\tstx.d") o1 o2 + STX FF32 o1 o2 -> op2 (text "\tfstx.s") o1 o2 + STX FF64 o1 o2 -> op2 (text "\tfstx.d") o1 o2 + + PRELD h o1@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tpreld") h o1 + -- 6. Bound Check Memory Access Instructions --------------------------------- + -- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D} + -- 7. Atomic Memory Access Instructions -------------------------------------- + -- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU} + -- AM.{SWAP/ADD}[_DB].{B/H} + -- AMCAS[_DB].{B/H/W/D} + -- LL.{W/D}, SC.{W/D} + -- SC.Q + -- LL.ACQ.{W/D}, SC.REL.{W/D} + -- 8. Barrier Instructions --------------------------------------------------- + -- DBAR, IBAR + DBAR h -> line $ text "\tdbar" <+> pprBarrierType h + IBAR h -> line $ text "\tibar" <+> pprBarrierType h + + -- Floating-point convert precision + FCVT o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2 + FCVT o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2 + FCVT o1 o2 -> pprPanic "LA64.pprInstr - impossible float conversion" $ + line (pprOp platform o1 <> text "->" <> pprOp platform o2) + -- Signed fixed-point convert to floating-point + -- For LoongArch, ffint.* instructions's second operand must be float-pointing register, + -- so we need one more operation. + -- Also to tfint.*. + SCVTF o1@(OpReg W32 _) o2@(OpReg W32 _) -> lines_ + [ + text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.s.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> lines_ + [ + text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.s.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> lines_ + [ + text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.d.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1@(OpReg W64 _) o2@(OpReg W64 _) -> lines_ + [ + text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2, + text "\tffint.d.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1 + ] + SCVTF o1 o2 -> pprPanic "LA64.pprInstr - impossible integer to float conversion" $ + line (pprOp platform o1 <> text "->" <> pprOp platform o2) + + -- Floating-point convert to signed integer, rounding toward zero + -- TODO: FCVTZS will destroy src-floating register if the previous opertion + -- includes this reg. So I'm just stupidly saving and restoring by adding + -- an extra register. + FCVTZS o1@(OpReg W32 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_ + [ + text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.w.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1@(OpReg W32 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_ + [ + text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.w.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1@(OpReg W64 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_ + [ + text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.l.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1@(OpReg W64 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_ + [ + text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3, + text "\tftintrz.l.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3, + text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3, + text "\tfmov.d" <+> pprOp platform o3 <> comma <+> pprOp platform o2 + ] + FCVTZS o1 o2 o3 -> pprPanic "LA64.pprInstr - impossible float to integer conversion" $ + line (pprOp platform o3 <> text "->" <+> pprOp platform o1 <+> text "tmpReg:" <+> pprOp platform o2) + + FMIN o1 o2 o3 -> op3 (text "fmin." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FMINA o1 o2 o3 -> op3 (text "fmina." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FMAX o1 o2 o3 -> op3 (text "fmax." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FMAXA o1 o2 o3 -> op3 (text "fmaxa." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3 + FABS o1 o2 -> op2 (text "fabs." <> if isSingleOp o2 then text "s" else text "d") o1 o2 + FNEG o1 o2 -> op2 (text "fneg." <> if isSingleOp o2 then text "s" else text "d") o1 o2 + FSQRT o1 o2 -> op2 (text "fsqrt." <> if isSingleOp o2 then text "s" else text "d") o1 o2 + FMA variant d o1 o2 o3 -> + let fma = case variant of + FMAdd -> text "\tfmadd." <+> floatPrecission d + FMSub -> text "\tfmsub." <+> floatPrecission d + FNMAdd -> text "\tfnmadd." <+> floatPrecission d + FNMSub -> text "\tfnmsub." <+> floatPrecission d + in op4 fma d o1 o2 o3 + + instr -> panic $ "LA64.pprInstr - Unknown instruction: " ++ (instrCon instr) + where op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 +{- + -- TODO: Support dbar with different hints. + On LoongArch uses "dbar 0" (full completion barrier) for everything. + But the full completion barrier has no performance to tell, so + Loongson-3A6000 and newer processors have made finer granularity hints + available: + + Bit4: ordering or completion (0: completion, 1: ordering) + Bit3: barrier for previous read (0: true, 1: false) + Bit2: barrier for previous write (0: true, 1: false) + Bit1: barrier for succeeding read (0: true, 1: false) + Bit0: barrier for succeeding write (0: true, 1: false) +-} + pprBarrierType Hint0 = text "0x0" + floatPrecission o | isSingleOp o = text "s" + | isDoubleOp o = text "d" + | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o) + +-- LoongArch64 Conditional Branch Instructions +pprBcond :: IsLine doc => Cond -> doc +pprBcond c = text "b" <> pprCond c + +pprCond :: IsLine doc => Cond -> doc +pprCond c = case c of + EQ -> text "eq" -- beq rj, rd, off16 + NE -> text "ne" -- bne rj, rd, off16 + SLT -> text "lt" -- blt rj, rd, off16 + SGE -> text "ge" -- bge rj, rd, off16 + ULT -> text "ltu" -- bltu rj, rd, off16 + UGE -> text "geu" -- bgeu rj, rd, off16 + -- Following not real instructions, just mark it. + SLE -> text "sle->ge" -- ble rj, rd, off16 -> bge rd, rj, off16 + SGT -> text "sgt->lt" -- bgt rj, rd, off16 -> blt rd, rj, off16 + ULE -> text "ule->geu" -- bleu rj, rd, off16 -> bgeu rd, rj, off16 + UGT -> text "ugt->ltu" -- bgtu rj, rd, off16 -> bltu rd, rj, off16 + _ -> panic $ "LA64.ppr: non-implemented branch condition: " ++ show c diff --git a/GHC/CmmToAsm/LA64/RegInfo.hs b/GHC/CmmToAsm/LA64/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/RegInfo.hs @@ -0,0 +1,25 @@ +-- Here maybe have something to be optimized in future? +module GHC.CmmToAsm.LA64.RegInfo where + +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.CmmToAsm.LA64.Instr +import GHC.Prelude +import GHC.Utils.Outputable + +newtype JumpDest = DestBlockId BlockId + +instance Outputable JumpDest where + ppr (DestBlockId bid) = text "jd:" <> ppr bid + +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid + +canShortcut :: Instr -> Maybe JumpDest +canShortcut _ = Nothing + +shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics +shortcutStatics _ other_static = other_static + +shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr +shortcutJump _ other = other diff --git a/GHC/CmmToAsm/LA64/Regs.hs b/GHC/CmmToAsm/LA64/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/LA64/Regs.hs @@ -0,0 +1,155 @@ +module GHC.CmmToAsm.LA64.Regs where + +import GHC.Prelude +import GHC.Cmm +import GHC.Cmm.CLabel ( CLabel ) +import GHC.CmmToAsm.Format +import GHC.Data.FastString +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.Platform.Reg.Class.Separate +import GHC.Platform.Regs +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Types.Unique + +-- All machine register numbers. +allMachRegNos :: [RegNo] +allMachRegNos = [0..31] ++ [32..63] + +zeroReg, raReg, tpMachReg, fpMachReg, spMachReg, tmpReg :: Reg +zeroReg = regSingle 0 +raReg = regSingle 1 +tpMachReg = regSingle 2 +-- Not to be confused with the `CmmReg` `spReg` +spMachReg = regSingle 3 +fpMachReg = regSingle 22 +-- Use t8(r20) for LA64 IP register. +tmpReg = regSingle 20 + +-- Registers available to the register allocator. +allocatableRegs :: Platform -> [RealReg] +allocatableRegs platform = + let isFree = freeReg platform + in map RealRegSingle $ filter isFree allMachRegNos + +-- Integer argument registers according to the calling convention +allGpArgRegs :: [Reg] +allGpArgRegs = map regSingle [4..11] + +-- | Floating point argument registers according to the calling convention +allFpArgRegs :: [Reg] +allFpArgRegs = map regSingle [32..39] + +-- Addressing modes +data AddrMode + = AddrRegReg Reg Reg + | AddrRegImm Reg Imm + | AddrReg Reg + deriving (Eq, Show) + +-- Immediates +data Imm + = ImmInt Int + | ImmInteger Integer -- Sigh. + | ImmCLbl CLabel -- AbstractC Label (with baggage) + | ImmLit FastString + | ImmIndex CLabel Int + | ImmFloat Rational + | ImmDouble Rational + | ImmConstantSum Imm Imm + | ImmConstantDiff Imm Imm + deriving (Eq, Show) + +-- Map CmmLit to Imm +litToImm :: CmmLit -> Imm +litToImm (CmmInt i w) = ImmInteger (narrowS w i) +-- narrow to the width: a CmmInt might be out of +-- range, but we assume that ImmInteger only contains +-- in-range values. A signed value should be fine here. +litToImm (CmmFloat f W32) = ImmFloat f +litToImm (CmmFloat f W64) = ImmDouble f +litToImm (CmmLabel l) = ImmCLbl l +litToImm (CmmLabelOff l off) = ImmIndex l off +litToImm (CmmLabelDiffOff l1 l2 off _) = + ImmConstantSum + (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) + (ImmInt off) +litToImm l = panic $ "LA64.Regs.litToImm: no match for " ++ show l + +-- == To satisfy GHC.CmmToAsm.Reg.Target ======================================= + +-- squeese functions for the graph allocator ----------------------------------- +-- | regSqueeze_class reg +-- Calculate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. +-- +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> Int +virtualRegSqueeze cls vr + = case cls of + RcInteger -> + case vr of + VirtualRegI {} -> 1 + VirtualRegHi {} -> 1 + _other -> 0 + RcFloat -> + case vr of + VirtualRegD {} -> 1 + _other -> 0 + RcVector -> + case vr of + VirtualRegV128 {} -> 1 + _other -> 0 + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> Int +realRegSqueeze cls rr = + case cls of + RcInteger -> + case rr of + RealRegSingle regNo + | regNo < 32 + -> 1 + | otherwise + -> 0 + RcFloat -> + case rr of + RealRegSingle regNo + | regNo < 32 + || regNo > 63 + -> 0 + | otherwise + -> 1 + RcVector -> + case rr of + RealRegSingle regNo + | regNo > 63 + -> 1 + | otherwise + -> 0 + +mkVirtualReg :: Unique -> Format -> VirtualReg +mkVirtualReg u format + | not (isFloatFormat format) = VirtualRegI u + | otherwise + = case format of + FF32 -> VirtualRegD u + FF64 -> VirtualRegD u + _ -> panic "LA64.mkVirtualReg" + +{-# INLINE classOfRealReg #-} +classOfRealReg :: RealReg -> RegClass +classOfRealReg (RealRegSingle i) + | i < 32 = RcInteger + | i > 63 = RcVector + | otherwise = RcFloat + +regDotColor :: RealReg -> SDoc +regDotColor reg + = case classOfRealReg reg of + RcInteger -> text "blue" + RcFloat -> text "red" + RcVector -> text "green" diff --git a/GHC/CmmToAsm/Monad.hs b/GHC/CmmToAsm/Monad.hs --- a/GHC/CmmToAsm/Monad.hs +++ b/GHC/CmmToAsm/Monad.hs @@ -55,7 +55,6 @@ import GHC.CmmToAsm.Types import GHC.Cmm.BlockId -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel ( CLabel ) import GHC.Cmm.DebugBlock @@ -63,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 @@ -74,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. @@ -97,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 @@ -166,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, @@ -193,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 -> @@ -211,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) diff --git a/GHC/CmmToAsm/PIC.hs b/GHC/CmmToAsm/PIC.hs --- a/GHC/CmmToAsm/PIC.hs +++ b/GHC/CmmToAsm/PIC.hs @@ -60,7 +60,7 @@ import GHC.CmmToAsm.Types -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Utils (cmmLoadBWord) @@ -132,11 +132,26 @@ addImport symbolPtr return $ cmmMakePicReference config symbolPtr + AccessViaSymbolPtr | ArchRISCV64 <- platformArch platform -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmMakePicReference config symbolPtr + + AccessViaSymbolPtr | ArchLoongArch64 <- platformArch platform -> do + let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl + addImport symbolPtr + return $ cmmMakePicReference config symbolPtr + AccessViaSymbolPtr -> do let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl addImport symbolPtr 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 +179,13 @@ | ArchAArch64 <- platformArch platform = CmmLit $ CmmLabel lbl + -- as on AArch64, there's no pic base register. + | ArchRISCV64 <- platformArch platform + = CmmLit $ CmmLabel lbl + + | ArchLoongArch64 <- platformArch platform + = CmmLit $ CmmLabel lbl + | OSAIX <- platformOS platform = CmmMachOp (MO_Add W32) [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) @@ -303,25 +325,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 +426,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 +540,7 @@ -- HACK: this label isn't really foreign = mkForeignLabel (fsLit ".LCTOC1") - Nothing ForeignLabelInThisPackage IsData + ForeignLabelInThisPackage IsData @@ -534,16 +551,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 +604,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 +688,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 +793,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 +815,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" diff --git a/GHC/CmmToAsm/PPC.hs b/GHC/CmmToAsm/PPC.hs --- a/GHC/CmmToAsm/PPC.hs +++ b/GHC/CmmToAsm/PPC.hs @@ -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 diff --git a/GHC/CmmToAsm/PPC/CodeGen.hs b/GHC/CmmToAsm/PPC/CodeGen.hs --- a/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/GHC/CmmToAsm/PPC/CodeGen.hs @@ -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 @@ -61,7 +61,6 @@ import GHC.Data.OrdList import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad ( mapAndUnzipM, when ) import Data.Word @@ -196,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. @@ -233,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 @@ -396,7 +398,7 @@ platform <- getPlatform pprPanic "iselExpr64(powerpc)" (pdoc platform expr) - +data MinOrMax = Min | Max getRegister :: CmmExpr -> NatM Register getRegister e = do config <- getConfig @@ -450,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 @@ -458,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 @@ -504,6 +512,9 @@ Amode addr addr_code <- getAmode DS mem return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) +getRegister' config platform (CmmMachOp (MO_RelaxedRead w) [e]) = + getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned) + getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps = case mop of MO_Not rep -> triv_ucode_int rep NOT @@ -514,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 @@ -527,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 @@ -573,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 -> @@ -636,9 +656,33 @@ 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_Neg {} -> 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 @@ -649,6 +693,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 @@ -657,13 +726,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 @@ -1052,7 +1130,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) @@ -1062,7 +1140,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 @@ -1126,10 +1204,12 @@ -> [CmmFormal] -- where to put the result -> [CmmActual] -- arguments (of mixed type) -> NatM InstrBlock -genCCall (PrimTarget MO_ReadBarrier) _ _ +genCCall (PrimTarget MO_AcquireFence) _ _ = return $ unitOL LWSYNC -genCCall (PrimTarget MO_WriteBarrier) _ _ +genCCall (PrimTarget MO_ReleaseFence) _ _ = return $ unitOL LWSYNC +genCCall (PrimTarget MO_SeqCstFence) _ _ + = return $ unitOL HWSYNC genCCall (PrimTarget MO_Touch) _ _ = return $ nilOL @@ -1908,8 +1988,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'') @@ -1934,6 +2021,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 @@ -1944,6 +2033,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) @@ -1955,6 +2047,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 @@ -1973,7 +2067,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 @@ -2094,8 +2188,17 @@ MO_AddIntC {} -> unsupported MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported + MO_VS_Quot {} -> unsupported + MO_VS_Rem {} -> unsupported + MO_VU_Quot {} -> unsupported + MO_VU_Rem {} -> unsupported + MO_I64X2_Min -> unsupported + MO_I64X2_Max -> unsupported + MO_W64X2_Min -> unsupported + MO_W64X2_Max -> unsupported + MO_AcquireFence -> unsupported + MO_ReleaseFence -> unsupported + MO_SeqCstFence -> unsupported MO_Touch -> unsupported MO_Prefetch_Data _ -> unsupported unsupported = panic ("outOfLineCmmOp: " ++ show mop diff --git a/GHC/CmmToAsm/PPC/Instr.hs b/GHC/CmmToAsm/PPC/Instr.hs --- a/GHC/CmmToAsm/PPC/Instr.hs +++ b/GHC/CmmToAsm/PPC/Instr.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language @@ -43,12 +41,11 @@ 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 import GHC.Cmm.BlockId -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info @@ -56,12 +53,12 @@ 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 import GHC.Data.FastString (FastString) -import Data.Maybe (fromMaybe) +import GHC.Data.Maybe (expectJust, fromMaybe) -------------------------------------------------------------------------------- @@ -106,7 +103,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 @@ -118,7 +115,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 @@ -127,8 +124,6 @@ alloc = mkStackAllocInstr platform delta dealloc = mkStackDeallocInstr platform delta - retargetList = (zip entries (map mkBlockId uniqs)) - new_blockmap :: LabelMap BlockId new_blockmap = mapFromList retargetList @@ -222,11 +217,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 @@ -334,9 +329,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) @@ -392,8 +387,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] @@ -548,12 +550,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 @@ -562,8 +564,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 @@ -573,12 +574,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 @@ -587,8 +588,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 @@ -666,12 +666,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. @@ -699,7 +701,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 @@ -717,7 +719,7 @@ = BCCFAR cond tgt p | otherwise = BCC cond tgt p - where Just targetAddr = lookupUFM blockAddressMap tgt + where targetAddr = expectJust $ lookupUFM blockAddressMap tgt makeFar _ other = other -- 8192 instructions are allowed; let's keep some distance, as diff --git a/GHC/CmmToAsm/PPC/Ppr.hs b/GHC/CmmToAsm/PPC/Ppr.hs --- a/GHC/CmmToAsm/PPC/Ppr.hs +++ b/GHC/CmmToAsm/PPC/Ppr.hs @@ -22,14 +22,13 @@ 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 import GHC.CmmToAsm.Utils import GHC.Cmm hiding (topInfoTable) -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId @@ -197,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 @@ -221,7 +220,7 @@ II64 -> text "d" FF32 -> text "fs" FF64 -> text "fd" - + VecFormat {} -> panic "PPC pprFormat: VecFormat" pprCond :: IsLine doc => Cond -> doc pprCond c @@ -384,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', @@ -426,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', @@ -509,7 +510,7 @@ char '\t', case targetClassOfReg platform reg1 of RcInteger -> text "mr" - _ -> text "fmr", + RcFloatOrVector -> text "fmr", char '\t', pprReg reg1, text ", ", @@ -587,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", @@ -612,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. diff --git a/GHC/CmmToAsm/PPC/Regs.hs b/GHC/CmmToAsm/PPC/Regs.hs --- a/GHC/CmmToAsm/PPC/Regs.hs +++ b/GHC/CmmToAsm/PPC/Regs.hs @@ -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 diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs --- a/GHC/CmmToAsm/Ppr.hs +++ b/GHC/CmmToAsm/Ppr.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- @@ -40,11 +39,6 @@ import GHC.Exts import GHC.Word -#if !MIN_VERSION_base(4,16,0) -word8ToWord# :: Word# -> Word# -word8ToWord# w = w -{-# INLINE word8ToWord# #-} -#endif -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing diff --git a/GHC/CmmToAsm/RV64.hs b/GHC/CmmToAsm/RV64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64.hs @@ -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 diff --git a/GHC/CmmToAsm/RV64/CodeGen.hs b/GHC/CmmToAsm/RV64/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/CodeGen.hs @@ -0,0 +1,2231 @@ +{-# 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 <- x + -- compute x <- y + -- OP x, x, x + -- + -- 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 <- x + -- compute x <- y + -- x, x, x + (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 <- x + -- compute x <- y + -- x, x, x + (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 (J (TReg target)))) + +-- ----------------------------------------------------------------------------- +-- Unconditional branches +genBranch :: BlockId -> NatM InstrBlock +genBranch = return . toOL . mkJumpInstr + +-- ----------------------------------------------------------------------------- +-- Conditional branches +genCondJump :: + BlockId -> + CmmExpr -> + NatM InstrBlock +genCondJump bid expr = do + case expr of + -- Optimized == 0 case. + CmmMachOp (MO_Eq 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 + MO_VS_Quot {} -> unsupported mop + MO_VS_Rem {} -> unsupported mop + MO_VU_Quot {} -> unsupported mop + MO_VU_Rem {} -> unsupported mop + MO_I64X2_Min -> unsupported mop + MO_I64X2_Max -> unsupported mop + MO_W64X2_Min -> unsupported mop + MO_W64X2_Max -> unsupported mop + -- Memory Ordering + -- The related C functions are: + -- #include + -- 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 + -- __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 + -- __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 foo + +with the sequence: + + b.cond + b + : + la reg foo + b reg + : + +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 + J op -> instr_size (B op) + BL _ _ -> 1 + J_TBL {} -> 1 diff --git a/GHC/CmmToAsm/RV64/Cond.hs b/GHC/CmmToAsm/RV64/Cond.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Cond.hs @@ -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) diff --git a/GHC/CmmToAsm/RV64/Instr.hs b/GHC/CmmToAsm/RV64/Instr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Instr.hs @@ -0,0 +1,868 @@ +-- 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 [] [] +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], []) + J t -> usage (regTarget 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) + J t -> J (patchTarget 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 + J {} -> True + B {} -> True + BL {} -> True + BCOND {} -> True + _ -> False + +canFallthroughTo :: Instr -> BlockId -> Bool +canFallthroughTo insn bid = + case insn of + J (TBlock target) -> bid == target + 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 (J t) = [id | TBlock id <- [t]] +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 + J (TBlock bid) -> J (TBlock (patchF bid)) + 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 {} -> 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 # + 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 + -- | Like B, but only used for non-local jumps. Used to distinguish genJumps from others. + | J Target + | -- | 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" + J {} -> "J" + 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 diff --git a/GHC/CmmToAsm/RV64/Ppr.hs b/GHC/CmmToAsm/RV64/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Ppr.hs @@ -0,0 +1,719 @@ +{-# 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 o1 -> pprInstr platform (B o1) + 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 diff --git a/GHC/CmmToAsm/RV64/RegInfo.hs b/GHC/CmmToAsm/RV64/RegInfo.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/RegInfo.hs @@ -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:" <> 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 diff --git a/GHC/CmmToAsm/RV64/Regs.hs b/GHC/CmmToAsm/RV64/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/RV64/Regs.hs @@ -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" diff --git a/GHC/CmmToAsm/Reg/Graph.hs b/GHC/CmmToAsm/Reg/Graph.hs --- a/GHC/CmmToAsm/Reg/Graph.hs +++ b/GHC/CmmToAsm/Reg/Graph.hs @@ -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,11 +393,8 @@ | RegReal _ <- r1 , RegReal _ <- r2 = graph - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "graphAddCoalesce" -#endif + where + arch = platformArch platform -- | Patch registers in code using the reg -> reg mapping in this graph. @@ -398,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 diff --git a/GHC/CmmToAsm/Reg/Graph/Base.hs b/GHC/CmmToAsm/Reg/Graph/Base.hs --- a/GHC/CmmToAsm/Reg/Graph/Base.hs +++ b/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -30,6 +30,7 @@ import GHC.Builtin.Uniques import GHC.Utils.Monad (concatMapM) +import Data.List.NonEmpty (NonEmpty (..)) -- Some basic register classes. -- These aren't necessarily in 1-to-1 correspondence with the allocatable @@ -113,7 +114,7 @@ regsS_conflict = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS - in maximum $ map sizeUniqSet $ regsS_conflict + in maximum $ 0 :| map sizeUniqSet regsS_conflict -- | For a node N of classN and neighbors of classesC diff --git a/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs --- a/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +++ b/GHC/CmmToAsm/Reg/Graph/Coalesce.hs @@ -12,10 +12,11 @@ import GHC.Cmm import GHC.Data.Bag import GHC.Data.Graph.Directed +import GHC.Platform (Platform) +import GHC.Types.Unique (getUnique) import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Types.Unique.Supply - +import GHC.Types.Unique.Set -- | Do register coalescing on this top level thing -- @@ -25,18 +26,19 @@ -- safely erased. regCoalesce :: Instruction instr - => [LiveCmmDecl statics instr] + => Platform + -> [LiveCmmDecl statics instr] -> UniqSM [LiveCmmDecl statics instr] -regCoalesce code +regCoalesce platform code = do let joins = foldl' unionBags emptyBag - $ map slurpJoinMovs code + $ map (slurpJoinMovs platform) code let alloc = foldl' buildAlloc emptyUFM $ bagToList joins - let patched = map (patchEraseLive (sinkReg alloc)) code + let patched = map (patchEraseLive platform (sinkReg alloc)) code return patched @@ -67,10 +69,11 @@ -- eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmDecl statics instr + => Platform + -> LiveCmmDecl statics instr -> Bag (Reg, Reg) -slurpJoinMovs live +slurpJoinMovs platform live = slurpCmm emptyBag live where slurpCmm rs CmmData{} @@ -84,9 +87,9 @@ slurpLI rs (LiveInstr _ Nothing) = rs slurpLI rs (LiveInstr instr (Just live)) - | Just (r1, r2) <- takeRegRegMoveInstr instr - , elementOfUniqSet r1 $ liveDieRead live - , elementOfUniqSet r2 $ liveBorn live + | Just (r1, r2) <- takeRegRegMoveInstr platform instr + , elemUniqSet_Directly (getUnique r1) $ liveDieRead live + , elemUniqSet_Directly (getUnique r2) $ liveBorn live -- only coalesce movs between two virtuals for now, -- else we end up with allocatable regs in the live diff --git a/GHC/CmmToAsm/Reg/Graph/Spill.hs b/GHC/CmmToAsm/Reg/Graph/Spill.hs --- a/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -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.Collections +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. diff --git a/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/GHC/CmmToAsm/Reg/Graph/SpillClean.hs --- a/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -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 @@ -45,18 +47,19 @@ import GHC.Types.Unique.FM import GHC.Types.Unique import GHC.Builtin.Uniques +import GHC.Utils.Misc import GHC.Utils.Monad.State.Strict import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Platform -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label -import Data.List (nub, foldl1', find) +import Data.List (nub, find) import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet + -- | 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 +69,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 +93,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 +115,7 @@ then return code -- otherwise go around again - else cleanSpin platform (spinCount + 1) code_backward + else cleanSpin config (spinCount + 1) code_backward ------------------------------------------------------------------------------- @@ -120,11 +123,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 +135,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 +148,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 +161,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 +185,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 +212,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 +249,7 @@ $ assoc return ( assoc' - , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) + , Just $ LiveInstr (mkRegRegMoveInstr config fmt reg2 reg) Nothing ) -- Gotta keep this instr. | otherwise @@ -399,13 +401,7 @@ cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs -#if __GLASGOW_HASKELL__ <= 810 - -- some other instruction - | otherwise - = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs -#endif - -- | Combine the associations from all the inward control flow edges. -- collateJoinPoints :: CleanM () @@ -415,8 +411,7 @@ , sJumpValidAcc = emptyUFM } intersects :: [Assoc Store] -> Assoc Store -intersects [] = emptyAssoc -intersects assocs = foldl1' intersectAssoc assocs +intersects = foldl1WithDefault' emptyAssoc intersectAssoc -- | See if we have a reg with the same value as this slot in the association table. diff --git a/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs --- a/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +++ b/GHC/CmmToAsm/Reg/Graph/SpillCost.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module GHC.CmmToAsm.Reg.Graph.SpillCost ( @@ -24,7 +25,6 @@ import GHC.Data.Graph.Base -import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Types.Unique.FM @@ -35,8 +35,10 @@ import GHC.Platform import GHC.Utils.Monad.State.Strict import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Format +import GHC.Utils.Misc -import Data.List (nub, minimumBy) +import Data.List (nub) import Data.Maybe import Control.Monad (join) @@ -100,7 +102,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 @@ -130,13 +132,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 @@ -158,13 +160,6 @@ | 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 :: SpillCostInfo @@ -174,7 +169,7 @@ chooseSpill info graph = let cost = spillCost_length info graph node = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2)) - $ nonDetEltsUFM $ graphMap graph + $ expectNonEmpty $ nonDetEltsUFM $ graphMap graph -- See Note [Unique Determinism and code generation] in nodeId node diff --git a/GHC/CmmToAsm/Reg/Graph/Stats.hs b/GHC/CmmToAsm/Reg/Graph/Stats.hs --- a/GHC/CmmToAsm/Reg/Graph/Stats.hs +++ b/GHC/CmmToAsm/Reg/Graph/Stats.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE BangPatterns, DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Carries interesting info for debugging / profiling of the -- graph coloring register allocator. module GHC.CmmToAsm.Reg.Graph.Stats ( @@ -224,11 +216,10 @@ pprStatsSpills stats = let - finals = [ s | s@RegAllocStatsColored{} <- stats] + finals = [srms | RegAllocStatsColored{ raSRMs = srms } <- stats] -- sum up how many stores\/loads\/reg-reg-moves were left in the code - total = foldl' addSRM (0, 0, 0) - $ map raSRMs finals + total = foldl' addSRM (0, 0, 0) finals in ( text "-- spills-added-total" $$ text "-- (stores, loads, reg_reg_moves_remaining)" @@ -242,8 +233,7 @@ pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo - [ raSpillCosts s - | s@RegAllocStatsStart{} <- stats ] + [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ] lifeBins = binLifetimeCount $ lifeMapFromSpillCostInfo info @@ -292,20 +282,21 @@ pprStatsLifeConflict stats graph = let lifeMap = lifeMapFromSpillCostInfo $ foldl' plusSpillCostInfo zeroSpillCostInfo - $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ] + $ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ] - scatter = map (\r -> let lifetime = case lookupUFM lifeMap r of - Just (_, l) -> l - Nothing -> 0 - Just node = Color.lookupNode graph r - in parens $ hcat $ punctuate (text ", ") - [ doubleQuotes $ ppr $ Color.nodeId node - , ppr $ sizeUniqSet (Color.nodeConflicts node) - , ppr $ lifetime ]) - $ map Color.nodeId - $ nonDetEltsUFM + scatter = + [ let lifetime = case lookupUFM lifeMap r of + Just (_, l) -> l + Nothing -> 0 + in parens $ hcat $ punctuate (text ", ") + [ doubleQuotes $ ppr $ Color.nodeId node + , ppr $ sizeUniqSet (Color.nodeConflicts node) + , ppr $ lifetime ] + | node <- nonDetEltsUFM -- See Note [Unique Determinism and code generation] $ Color.graphMap graph + , let r = Color.nodeId node + ] in ( text "-- vreg-conflict-lifetime" $$ text "-- (vreg, vreg_conflicts, vreg_lifetime)" @@ -317,27 +308,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 @@ -347,7 +340,7 @@ return li | LiveInstr instr _ <- li - , Just _ <- takeRegRegMoveInstr instr + , Just _ <- takeRegRegMoveInstr platform instr = do modify $ \(s, r, m) -> (s, r, m + 1) return li diff --git a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -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,107 +102,59 @@ -> (RegClass -> VirtualReg -> Int) -> (RegClass -> RealReg -> Int) -> Triv VirtualReg RegClass RealReg - -trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions - | 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 - 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 - -- "dont 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 -> case rc of + Separate.RcInteger -> 16 + Separate.RcFloat -> 24 + Separate.RcVector -> 24 + ArchJavaScript-> panic "trivColorable ArchJavaScript" + ArchWasm32 -> panic "trivColorable ArchWasm32" + ArchUnknown -> panic "trivColorable ArchUnknown" -- Specification Code ---------------------------------------------------------- @@ -218,21 +172,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 @@ -241,11 +195,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. @@ -264,15 +218,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 -} diff --git a/GHC/CmmToAsm/Reg/Linear.hs b/GHC/CmmToAsm/Reg/Linear.hs --- a/GHC/CmmToAsm/Reg/Linear.hs +++ b/GHC/CmmToAsm/Reg/Linear.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -{-# LANGUAGE ConstraintKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ----------------------------------------------------------------------------- -- -- The register allocator @@ -114,30 +110,37 @@ 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.Reg.Linear.LA64 as LA64 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.Collections -import GHC.Cmm hiding (RegSet) +import GHC.Cmm.Dataflow.Label +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 (sortOn) import Control.Monad -- ----------------------------------------------------------------------------- @@ -148,11 +151,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 @@ -174,8 +177,7 @@ -- make sure the block that was first in the input list -- stays at the front of the output - let !(!(!first':_), !rest') - = partition ((== first_id) . blockId) final_blocks + let !final_blocks' = sortOn ((/= first_id) . blockId) final_blocks let max_spill_slots = maxSpillSlots config extra_stack @@ -184,7 +186,7 @@ | otherwise = Nothing - return ( CmmProc info lbl live (ListGraph (first' : rest')) + return ( CmmProc info lbl live (ListGraph final_blocks') , extra_stack , Just stats) @@ -205,11 +207,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 @@ -223,14 +225,14 @@ ArchAlpha -> panic "linearRegAlloc ArchAlpha" ArchMipseb -> panic "linearRegAlloc ArchMipseb" ArchMipsel -> panic "linearRegAlloc ArchMipsel" - ArchRISCV64 -> panic "linearRegAlloc ArchRISCV64" - ArchLoongArch64-> panic "linearRegAlloc ArchLoongArch64" + ArchRISCV64 -> go (frInitFreeRegs platform :: RV64.FreeRegs) + ArchLoongArch64 -> go $ (frInitFreeRegs platform :: LA64.FreeRegs) 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 @@ -244,21 +246,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] @@ -293,7 +295,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 = @@ -332,7 +334,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 @@ -349,7 +351,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 @@ -366,7 +368,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 @@ -379,7 +381,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 @@ -404,7 +406,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. @@ -424,6 +426,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 @@ -433,13 +436,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. @@ -458,8 +461,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 @@ -488,7 +491,7 @@ genRaInsn :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr) - => BlockMap RegSet + => BlockMap (UniqSet RegWithFormat) -> [instr] -> BlockId -> instr @@ -501,13 +504,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] @@ -567,13 +571,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 @@ -587,7 +591,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] @@ -640,9 +644,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 @@ -690,16 +694,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 @@ -713,20 +718,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)) @@ -744,12 +749,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 @@ -773,7 +780,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) @@ -801,25 +808,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 @@ -827,14 +834,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 @@ -860,21 +867,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 @@ -885,10 +893,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 @@ -901,7 +910,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 @@ -910,44 +919,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. @@ -962,16 +974,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 @@ -980,15 +995,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 diff --git a/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/GHC/CmmToAsm/Reg/Linear/AArch64.hs --- a/GHC/CmmToAsm/Reg/Linear/AArch64.hs +++ b/GHC/CmmToAsm/Reg/Linear/AArch64.hs @@ -3,7 +3,7 @@ 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 @@ -115,10 +115,11 @@ -} 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 + -- x18 is a platform-reserved register for Win/Mac and free for Linux (See Note [Aarch64 Register x18 at Darwin and Windows]) + RcInteger -> go 0 g 18 where go _ _ i | i < 0 = [] go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1) diff --git a/GHC/CmmToAsm/Reg/Linear/Base.hs b/GHC/CmmToAsm/Reg/Linear/Base.hs --- a/GHC/CmmToAsm/Reg/Linear/Base.hs +++ b/GHC/CmmToAsm/Reg/Linear/Base.hs @@ -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.Collections +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. @@ -184,5 +206,4 @@ , ra_fixups :: [(BlockId,BlockId,BlockId)] } - diff --git a/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs --- a/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +++ b/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs @@ -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,14 @@ 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.Reg.Linear.LA64 as LA64 import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr import qualified GHC.CmmToAsm.X86.Instr as X86.Instr import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr +import qualified GHC.CmmToAsm.RV64.Instr as RV64.Instr +import qualified GHC.CmmToAsm.LA64.Instr as LA64.Instr class Show freeRegs => FR freeRegs where frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs @@ -64,6 +72,27 @@ 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 + +instance FR LA64.FreeRegs where + frAllocateReg = \_ -> LA64.allocateReg + frGetFreeRegs = \_ -> LA64.getFreeRegs + frInitFreeRegs = LA64.initFreeRegs + frReleaseReg = \_ -> LA64.releaseReg + +allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg] +allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses + where + 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,8 +105,8 @@ ArchAlpha -> panic "maxSpillSlots ArchAlpha" ArchMipseb -> panic "maxSpillSlots ArchMipseb" ArchMipsel -> panic "maxSpillSlots ArchMipsel" - ArchRISCV64 -> panic "maxSpillSlots ArchRISCV64" - ArchLoongArch64->panic "maxSpillSlots ArchLoongArch64" + ArchRISCV64 -> RV64.Instr.maxSpillSlots config + ArchLoongArch64 -> LA64.Instr.maxSpillSlots config ArchJavaScript-> panic "maxSpillSlots ArchJavaScript" ArchWasm32 -> panic "maxSpillSlots ArchWasm32" ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs --- a/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +++ b/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Handles joining of a jump instruction to its targets. -- The first time we encounter a jump to a particular basic block, we @@ -23,22 +21,24 @@ import GHC.Platform.Reg import GHC.Cmm.BlockId -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label import GHC.Data.Graph.Directed +import GHC.Data.Maybe import GHC.Utils.Panic import GHC.Utils.Monad (concatMapM) import GHC.Types.Unique 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 +62,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. @@ -89,7 +89,7 @@ -- adjust the current assignment to remove any vregs that are not live -- on entry to the destination block. - let Just live_set = mapLookup dest block_live + let live_set = expectJust $ mapLookup dest block_live let still_live uniq _ = uniq `elemUniqSet_Directly` live_set let adjusted_assig = filterUFM_Directly still_live assig @@ -106,7 +106,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 +116,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 +145,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 +327,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 +360,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 diff --git a/GHC/CmmToAsm/Reg/Linear/LA64.hs b/GHC/CmmToAsm/Reg/Linear/LA64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/LA64.hs @@ -0,0 +1,71 @@ +module GHC.CmmToAsm.Reg.Linear.LA64 where + +import GHC.Prelude + +import Data.Word +import GHC.CmmToAsm.LA64.Regs +import GHC.Platform +import GHC.Platform.Reg +import GHC.Platform.Reg.Class +import GHC.Platform.Reg.Class.Separate +import GHC.Stack +import GHC.Utils.Outputable +import GHC.Utils.Panic + +data FreeRegs = FreeRegs !Word32 !Word32 + +noFreeRegs :: FreeRegs +noFreeRegs = FreeRegs 0 0 + +instance Show FreeRegs where + show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f + +-- | Show bits as a `String` of @1@s and @0@s +showBits :: Word32 -> String +showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31] + +instance Outputable FreeRegs where + ppr (FreeRegs g f) = + text " " <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31] + $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31] + $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31] + where + pad_int i | i < 10 = char ' ' <> int i + pad_int i = int i + -- remember bit = 1 means it's available. + show_bit bits bit | testBit bits bit = text " " + show_bit _ _ = text " x" + +-- | Set bits of all allocatable registers to 1 +initFreeRegs :: Platform -> FreeRegs +initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) + +-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1) +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] +getFreeRegs cls (FreeRegs g f) + | RcInteger <- cls = go 0 g allocatableIntRegs + | RcFloat <- cls = go 32 f allocatableDoubleRegs + | RcVector <- cls = sorry "Linear.LA64.getFreeRegs: vector registers are not supported" + where + go _ _ [] = [] + go off x (i : is) + | testBit x i = RealRegSingle (off + i) : (go off x $! is) + | otherwise = go off x $! is + allocatableIntRegs = [4 .. 11] ++ [12 .. 19] + allocatableDoubleRegs = [0 .. 7] ++ [8 .. 23] + +-- | Set corresponding register bit to 0 +allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs +allocateReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) + | r < 32 && testBit g r = FreeRegs (clearBit g r) f + | r > 31 = panic $ "Linear.LA64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f + | otherwise = pprPanic "Linear.LA64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g) + +-- | Set corresponding register bit to 1 +releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs +releaseReg (RealRegSingle r) (FreeRegs g f) + | r > 31 && testBit f (r - 32) = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) + | r < 32 && testBit g r = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg x" <> int r) + | r > 31 = FreeRegs g (setBit f (r - 32)) + | otherwise = FreeRegs (setBit g r) f diff --git a/GHC/CmmToAsm/Reg/Linear/PPC.hs b/GHC/CmmToAsm/Reg/Linear/PPC.hs --- a/GHC/CmmToAsm/Reg/Linear/PPC.hs +++ b/GHC/CmmToAsm/Reg/Linear/PPC.hs @@ -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) diff --git a/GHC/CmmToAsm/Reg/Linear/RV64.hs b/GHC/CmmToAsm/Reg/Linear/RV64.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Reg/Linear/RV64.hs @@ -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 diff --git a/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/GHC/CmmToAsm/Reg/Linear/StackMap.hs --- a/GHC/CmmToAsm/Reg/Linear/StackMap.hs +++ b/GHC/CmmToAsm/Reg/Linear/StackMap.hs @@ -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 diff --git a/GHC/CmmToAsm/Reg/Linear/State.hs b/GHC/CmmToAsm/Reg/Linear/State.hs --- a/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/GHC/CmmToAsm/Reg/Linear/State.hs @@ -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 diff --git a/GHC/CmmToAsm/Reg/Linear/Stats.hs b/GHC/CmmToAsm/Reg/Linear/Stats.hs --- a/GHC/CmmToAsm/Reg/Linear/Stats.hs +++ b/GHC/CmmToAsm/Reg/Linear/Stats.hs @@ -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)) diff --git a/GHC/CmmToAsm/Reg/Linear/X86.hs b/GHC/CmmToAsm/Reg/Linear/X86.hs --- a/GHC/CmmToAsm/Reg/Linear/X86.hs +++ b/GHC/CmmToAsm/Reg/Linear/X86.hs @@ -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) diff --git a/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/GHC/CmmToAsm/Reg/Linear/X86_64.hs --- a/GHC/CmmToAsm/Reg/Linear/X86_64.hs +++ b/GHC/CmmToAsm/Reg/Linear/X86_64.hs @@ -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) diff --git a/GHC/CmmToAsm/Reg/Liveness.hs b/GHC/CmmToAsm/Reg/Liveness.hs --- a/GHC/CmmToAsm/Reg/Liveness.hs +++ b/GHC/CmmToAsm/Reg/Liveness.hs @@ -1,14 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ----------------------------------------------------------------------------- -- -- The register liveness determinator @@ -18,9 +9,8 @@ ----------------------------------------------------------------------------- module GHC.CmmToAsm.Reg.Liveness ( - RegSet, RegMap, emptyRegMap, - BlockMap, mapEmpty, + BlockMap, LiveCmmDecl, InstrSR (..), LiveInstr (..), @@ -48,31 +38,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.Collections 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.List (mapAccumL, sortOn) import Data.Maybe import Data.IntSet (IntSet) +import GHC.Utils.Misc ----------------------------------------------------------------------------- -type RegSet = UniqSet Reg -- | Map from some kind of register to a. -- @@ -84,9 +76,6 @@ emptyRegMap :: RegMap a emptyRegMap = emptyUFM -emptyRegSet :: RegSet -emptyRegSet = emptyUniqSet - type BlockMap a = LabelMap a type SlotMap a = UniqFM Slot a @@ -105,29 +94,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 @@ -161,12 +153,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) @@ -196,9 +188,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. @@ -207,7 +199,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 @@ -222,7 +214,7 @@ ppr (Instr realInstr) = ppr realInstr - ppr (SPILL reg slot) + ppr (SPILL (RegWithFormat reg _fmt) slot) = hcat [ text "\tSPILL", char ' ', @@ -230,7 +222,7 @@ comma, text "SLOT" <> parens (int slot)] - ppr (RELOAD slot reg) + ppr (RELOAD slot (RegWithFormat reg _fmt)) = hcat [ text "\tRELOAD", char ' ', @@ -253,7 +245,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 <> @@ -267,7 +259,7 @@ = (pdoc env mb_static) $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + $$ text "# liveSlotsOnEntry = " <> ppr liveSlotsOnEntry @@ -335,10 +327,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 @@ -388,7 +381,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 @@ -465,12 +458,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)) @@ -534,11 +527,10 @@ -- make sure the block that was first in the input list -- stays at the front of the output. This is the entry point -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks + final_blocks' = sortOn ((/= first_id) . blockId) final_blocks - in CmmProc info label live - (ListGraph $ map (stripLiveBlock config) $ first' : rest') + in CmmProc info label live $ ListGraph $ + map (stripLiveBlock config) final_blocks' -- If the proc has blocks but we don't know what the first one was, then we're dead. stripCmm proc @@ -616,11 +608,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 @@ -628,9 +621,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 @@ -645,22 +637,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 @@ -669,26 +661,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 @@ -697,7 +689,7 @@ => Maybe CFG -> Platform -> NatCmmDecl statics instr - -> UniqSM (LiveCmmDecl statics instr) + -> UniqDSM (LiveCmmDecl statics instr) cmmTopLiveness cfg platform cmm = regLiveness platform $ natCmmTopToLive cfg cmm @@ -791,7 +783,7 @@ :: Instruction instr => Platform -> LiveCmmDecl statics instr - -> UniqSM (LiveCmmDecl statics instr) + -> UniqDSM (LiveCmmDecl statics instr) regLiveness _ (CmmData i d) = return $ CmmData i d @@ -876,7 +868,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 @@ -891,11 +883,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) @@ -924,8 +916,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) @@ -933,9 +925,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] @@ -945,9 +936,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 @@ -967,7 +958,7 @@ livenessForward :: Instruction instr => Platform - -> RegSet -- regs live on this instr + -> UniqSet RegWithFormat -- regs live on this instr -> [LiveInstr instr] -> [LiveInstr instr] livenessForward _ _ [] = [] @@ -978,7 +969,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) @@ -997,16 +989,16 @@ 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) livenessBack platform liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 platform liveregs blockmap instr + = let !(!liveregs', instr') = liveness1 platform liveregs blockmap instr in livenessBack platform liveregs' blockmap (instr' : acc) instrs @@ -1014,10 +1006,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,15 +1021,15 @@ = (liveregs1, LiveInstr instr (Just $ Liveness { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) + , liveDieRead = r_dying + , liveDieWrite = w_dying })) | otherwise = (liveregs_br, LiveInstr instr (Just $ Liveness { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) + , liveDieRead = r_dying_br + , liveDieWrite = w_dying })) where !(RU read written) = regUsageOfInstr platform instr @@ -1049,11 +1041,16 @@ -- registers that are not live beyond this point, are recorded -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] + r_dying = mkUniqSet + [ reg + | reg@(RegWithFormat r _) <- read + , not $ any (\ w -> getUnique w == getUnique r) written + , not (elementOfUniqSet reg liveregs) ] - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] + w_dying = mkUniqSet + [ reg + | reg <- written + , not (elementOfUniqSet reg liveregs) ] -- union in the live regs from all the jump destinations of this -- instruction. @@ -1063,7 +1060,7 @@ targetLiveRegs target = case mapLookup target blockmap of Just ra -> ra - Nothing -> emptyRegSet + Nothing -> emptyUniqSet live_from_branch = unionManyUniqSets (map targetLiveRegs targets) @@ -1072,6 +1069,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 (mkUniqSet r_dying `unionUniqSets` - live_branch_only) + r_dying_br = (r_dying `unionUniqSets` live_branch_only) -- See Note [Unique Determinism and code generation] diff --git a/GHC/CmmToAsm/Reg/Target.hs b/GHC/CmmToAsm/Reg/Target.hs --- a/GHC/CmmToAsm/Reg/Target.hs +++ b/GHC/CmmToAsm/Reg/Target.hs @@ -14,7 +14,8 @@ targetClassOfRealReg, targetMkVirtualReg, targetRegDotColor, - targetClassOfReg + targetClassOfReg, + mapRegFormatSet, ) where @@ -26,15 +27,18 @@ 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 +import qualified GHC.CmmToAsm.LA64.Regs as LA64 targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int targetVirtualRegSqueeze platform @@ -49,8 +53,8 @@ ArchAlpha -> panic "targetVirtualRegSqueeze ArchAlpha" ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" - ArchRISCV64 -> panic "targetVirtualRegSqueeze ArchRISCV64" - ArchLoongArch64->panic "targetVirtualRegSqueeze ArchLoongArch64" + ArchRISCV64 -> RV64.virtualRegSqueeze + ArchLoongArch64 -> LA64.virtualRegSqueeze ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" ArchWasm32 -> panic "targetVirtualRegSqueeze ArchWasm32" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" @@ -69,8 +73,8 @@ ArchAlpha -> panic "targetRealRegSqueeze ArchAlpha" ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" - ArchRISCV64 -> panic "targetRealRegSqueeze ArchRISCV64" - ArchLoongArch64->panic "targetRealRegSqueeze ArchLoongArch64" + ArchRISCV64 -> RV64.realRegSqueeze + ArchLoongArch64 -> LA64.realRegSqueeze ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" ArchWasm32 -> panic "targetRealRegSqueeze ArchWasm32" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" @@ -88,8 +92,8 @@ ArchAlpha -> panic "targetClassOfRealReg ArchAlpha" ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" - ArchRISCV64 -> panic "targetClassOfRealReg ArchRISCV64" - ArchLoongArch64->panic "targetClassOfRealReg ArchLoongArch64" + ArchRISCV64 -> RV64.classOfRealReg + ArchLoongArch64 -> LA64.classOfRealReg ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" ArchWasm32 -> panic "targetClassOfRealReg ArchWasm32" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" @@ -107,8 +111,8 @@ ArchAlpha -> panic "targetMkVirtualReg ArchAlpha" ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" - ArchRISCV64 -> panic "targetMkVirtualReg ArchRISCV64" - ArchLoongArch64->panic "targetMkVirtualReg ArchLoongArch64" + ArchRISCV64 -> RV64.mkVirtualReg + ArchLoongArch64 -> LA64.mkVirtualReg ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" ArchWasm32 -> panic "targetMkVirtualReg ArchWasm32" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" @@ -126,8 +130,8 @@ ArchAlpha -> panic "targetRegDotColor ArchAlpha" ArchMipseb -> panic "targetRegDotColor ArchMipseb" ArchMipsel -> panic "targetRegDotColor ArchMipsel" - ArchRISCV64 -> panic "targetRegDotColor ArchRISCV64" - ArchLoongArch64->panic "targetRegDotColor ArchLoongArch64" + ArchRISCV64 -> RV64.regDotColor + ArchLoongArch64 -> LA64.regDotColor ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" ArchWasm32 -> panic "targetRegDotColor ArchWasm32" ArchUnknown -> panic "targetRegDotColor ArchUnknown" @@ -136,5 +140,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) diff --git a/GHC/CmmToAsm/Utils.hs b/GHC/CmmToAsm/Utils.hs --- a/GHC/CmmToAsm/Utils.hs +++ b/GHC/CmmToAsm/Utils.hs @@ -7,7 +7,6 @@ import GHC.Prelude import GHC.Cmm.BlockId -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (topInfoTable) diff --git a/GHC/CmmToAsm/Wasm.hs b/GHC/CmmToAsm/Wasm.hs --- a/GHC/CmmToAsm/Wasm.hs +++ b/GHC/CmmToAsm/Wasm.hs @@ -1,54 +1,82 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.CmmToAsm.Wasm (ncgWasm) where import Data.ByteString.Builder +import Data.ByteString.Lazy.Char8 (unpack) import Data.Maybe import Data.Semigroup import GHC.Cmm +import GHC.Cmm.ContFlowOpt +import GHC.Cmm.GenericOpt +import GHC.CmmToAsm.Config 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.CliOption +import GHC.Utils.Logger +import GHC.Utils.Outputable (text) import System.IO ncgWasm :: + NCGConfig -> + Logger -> Platform -> ToolSettings -> - UniqSupply -> ModLocation -> Handle -> - Stream IO RawCmmGroup a -> - IO a -ncgWasm platform ts us loc h cmms = do - (r, s) <- streamCmmGroups platform us cmms - hPutBuilder h $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n" - hPutBuilder h $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s + 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" + -- 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 = liftIO $ do + putDumpFileMaybe + logger + Opt_D_dump_asm + "Asm Code" + FormatASM + (text . unpack $ toLazyByteString builder) + hPutBuilder h builder streamCmmGroups :: + NCGConfig -> Platform -> - UniqSupply -> - Stream IO RawCmmGroup a -> - IO (a, WasmCodeGenState 'I32) -streamCmmGroups 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 (Yield cmm k) = go (wasmExecM (onCmmGroup cmm) s) k + 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 + -- by a late control-flow optimization pass that does shrink + -- the CFG block count in some cases. + opt decl = case decl of + CmmData {} -> decl + CmmProc {} -> CmmProc info lbl live $ cmmCfgOpts False graph + where + (CmmProc info lbl live graph, _) = cmmToCmm ncg_config decl doTailCall :: ToolSettings -> Bool doTailCall ts = Option "-mtail-call" `elem` as_args diff --git a/GHC/CmmToAsm/Wasm/Asm.hs b/GHC/CmmToAsm/Wasm/Asm.hs --- a/GHC/CmmToAsm/Wasm/Asm.hs +++ b/GHC/CmmToAsm/Wasm/Asm.hs @@ -12,9 +12,9 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder +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 @@ -25,21 +25,23 @@ import GHC.Data.FastString import GHC.Float import GHC.Prelude +import GHC.Settings.Config (cProjectVersion) 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 (<>) @@ -47,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 () @@ -111,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 @@ -134,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 @@ -181,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 @@ -243,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 @@ -359,7 +374,10 @@ 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 @@ -396,12 +414,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 $ @@ -420,12 +438,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 @@ -438,19 +456,32 @@ 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 () asmTellCtors _ [] = mempty asmTellCtors ty_word syms = do - asmTellSectionHeader ".init_array" + -- See Note [JSFFI initialization] for details + asmTellSectionHeader ".init_array.101" asmTellAlign $ alignmentFromWordType ty_word for_ syms $ \sym -> asmTellTabLine $ @@ -485,20 +516,20 @@ asmTellVec [ do asmTellBS "ghc" - asmTellBS "9.6" + asmTellBS $ BS8.pack cProjectVersion ] ] 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", diff --git a/GHC/CmmToAsm/Wasm/FromCmm.hs b/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -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 @@ -438,7 +438,7 @@ lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable" -- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to --- @hs_mulIntMayOflo@ function in @ghc-prim/cbits/mulIntMayOflo@, +-- @hs_mulIntMayOflo@ function in @rts/prim/mulIntMayOflo@, -- otherwise it's quite non-trivial to implement as inline assembly. lower_MO_MulMayOflo :: CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w) @@ -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 -> @@ -628,6 +671,7 @@ WasmCodeGenM w (SomeWasmExpr w) +lower_CmmMachOp lbl (MO_RelaxedRead w0) [x] = lower_CmmExpr lbl (CmmLoad x (cmmBits w0) NaturallyAligned) lower_CmmMachOp lbl (MO_Add w0) xs = lower_MO_Bin_Homo_Trunc WasmAdd lbl w0 xs lower_CmmMachOp lbl (MO_Sub w0) xs = lower_MO_Bin_Homo_Trunc WasmSub lbl w0 xs lower_CmmMachOp lbl (MO_Eq w0) xs = lower_MO_Bin_Rel WasmEq lbl (cmmBits w0) xs @@ -777,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 @@ -798,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 @@ -816,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 ] @@ -999,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. @@ -1056,6 +1108,28 @@ 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 -> @@ -1159,8 +1233,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 lbl "fabs" rs xs -lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" 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_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 @@ -1183,11 +1257,12 @@ 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 lbl "fabsf" rs xs -lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" 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_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs -lower_CallishMachOp _ MO_ReadBarrier _ _ = pure $ WasmStatements WasmNop -lower_CallishMachOp _ MO_WriteBarrier _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ MO_SeqCstFence _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ MO_Touch _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do @@ -1531,11 +1606,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 @@ -1553,8 +1626,8 @@ SymDefault -> wasmModifyM $ \s -> s { defaultSyms = - WS.insert - (getKey $ getUnique sym) + insertUniqueSet + (getUnique sym) $ defaultSyms s } _ -> pure () diff --git a/GHC/CmmToAsm/Wasm/Types.hs b/GHC/CmmToAsm/Wasm/Types.hs --- a/GHC/CmmToAsm/Wasm/Types.hs +++ b/GHC/CmmToAsm/Wasm/Types.hs @@ -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,7 +310,10 @@ 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)) @@ -419,15 +427,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, @@ -436,12 +444,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 @@ -465,18 +478,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 diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs --- a/GHC/CmmToAsm/X86/CodeGen.hs +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -1,4482 +1,6718 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TupleSections #-} - -{-# 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.Collections -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.Utils.Panic.Plain -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) - --- we handle addition, but rather badly -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 _ W64) [expr]) = do - code <- getAnyReg expr - Reg64 r_dst_hi r_dst_lo <- getNewReg64 - return $ RegCode64 (code r_dst_lo `snocOL` - MOV II32 (OpImm (ImmInt 0)) (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 expr - = do - platform <- getPlatform - pprPanic "iselExpr64(i386)" (pdoc platform expr) - - --------------------------------------------------------------------------------- -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_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' _ _ (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) - - --- @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 - --- 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. --} - -{- 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 and - perform a single conditional jump based on the - result. - - * Other comparisons: - - We map all other comparisons to the >= operation. - Why? Because it's easy to encode it with a single - conditional jump. - - We do this by first computing [r1_lo - r2_lo] - and use the carry flag to compute - [r1_high - r2_high - CF]. - - At which point if r1 >= r2 then the result will be - positive. Otherwise negative so we can branch on this - condition. - --} - - -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 - --- 64-bit integer comparisons on 32-bit --- See Note [64-bit integer comparisons on 32-bit] -genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2]) - | is32Bit, Just W64 <- maybeIntComparison mop = do - - RegCode64 code1 r1hi r1lo <- iselExpr64 e1 - RegCode64 code2 r2hi r2lo <- iselExpr64 e2 - let cond = machOpToCond mop :: Cond - - -- we mustn't clobber r1/r2 so we use temporaries - tmp1 <- getNewRegNat II32 - tmp2 <- getNewRegNat II32 - - let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2 - return $ code1 `appOL` code2 `appOL` cmpCode - - where - intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 = - case cond of - -- Impossible results of machOpToCond - 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 -> cmpExact - NE -> cmpExact - -- [x >= y] - GE -> cmpGE - GEU -> cmpGE - -- [x > y] <==> ![y >= x] - GTT -> intComparison GE false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2 - GU -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2 - -- [x <= y] <==> [y >= x] - LE -> intComparison GE true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2 - LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2 - -- [x < y] <==> ![x >= x] - LTT -> intComparison GE false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 - LU -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 - 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) - , JXX cond true - , JXX ALWAYS false - ] - cmpGE = toOL - [ MOV II32 (OpReg r1_hi) (OpReg tmp1) - , CMP II32 (OpReg r2_lo) (OpReg r1_lo) - , SBB II32 (OpReg r2_hi) (OpReg tmp1) - , JXX cond true - , JXX ALWAYS false ] - -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: - - _B1: - ... - cmpxchgq ... - jne _B1 - - - _B2: - ... - cmpxchgq ... - jne _B2 - - 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: - - _B1: - ... - cmpxchgq ... - jne _B1 - jmp _B1' - _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_ReadBarrier [] [] = return nilOL -- barriers compile to no code on x86/x86-64; -genSimplePrim _ MO_WriteBarrier [] [] = return nilOL -- we keep it this long in order to prevent earlier optimisations. -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. 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 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 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 treshold (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 treshold (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 #-} + +----------------------------------------------------------------------------- +-- +-- Generating machine code (instruction selection) +-- +-- (c) The University of Glasgow 1996-2004 +-- +----------------------------------------------------------------------------- + +-- This is a big module, but, if you pay attention to +-- (a) the sectioning, and (b) the type signatures, the +-- structure should not be too overwhelming. + +module GHC.CmmToAsm.X86.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + extractUnwindPoints, + invertCondBranches, + InstrBlock +) + +where + +-- NCG stuff: +import GHC.Prelude + +import GHC.CmmToAsm.X86.Instr +import GHC.CmmToAsm.X86.Cond +import GHC.CmmToAsm.X86.Regs +import GHC.CmmToAsm.X86.Ppr +import GHC.CmmToAsm.X86.RegInfo + +import GHC.Platform.Regs +import GHC.CmmToAsm.CPrim +import GHC.CmmToAsm.Types +import GHC.Cmm.DebugBlock + ( DebugBlock(..), UnwindPoint(..), UnwindTable + , UnwindExpr(UwReg), toUnwindExpr + ) +import GHC.CmmToAsm.PIC +import GHC.CmmToAsm.Monad + ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat + , getDeltaNat, getBlockIdNat, getPicBaseNat + , Reg64(..), RegCode64(..), getNewReg64, localReg64 + , getPicBaseMaybeNat, getDebugBlock, getFileId + , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform + , getCfgWeights + ) +import GHC.CmmToAsm.CFG +import GHC.CmmToAsm.Format +import GHC.CmmToAsm.Config +import GHC.Platform.Reg +import GHC.Platform + +-- Our intermediate code: +import GHC.Types.Basic +import GHC.Cmm.BlockId +import GHC.Unit.Types ( ghcInternalUnitId ) +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.CLabel +import GHC.Types.Tickish ( GenTickish(..) ) +import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) + +-- The rest: +import GHC.Data.Maybe ( expectJust ) +import GHC.Types.ForeignCall ( CCallConv(..) ) +import GHC.Data.OrdList +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad ( foldMapM ) +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Utils.Misc +import GHC.Types.Unique.DSM ( getUniqueM ) + +import qualified Data.Semigroup as S + +import Control.Monad +import Control.Monad.Trans.State.Strict + ( StateT, evalStateT, get, put ) +import Control.Monad.Trans.Class (lift) +import Data.Foldable (fold) +import Data.Int +import Data.List (partition, (\\)) +import Data.Maybe +import Data.Word + +import qualified Data.Map as Map + +is32BitPlatform :: NatM Bool +is32BitPlatform = do + platform <- getPlatform + return $ target32Bit platform + +ssse3Enabled :: NatM Bool +ssse3Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSSE3) + +sse4_1Enabled :: NatM Bool +sse4_1Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSE4) + +sse4_2Enabled :: NatM Bool +sse4_2Enabled = do + config <- getConfig + return (ncgSseVersion config >= Just SSE42) + +avxEnabled :: NatM Bool +avxEnabled = do + config <- getConfig + return (ncgAvxEnabled config) + +avx2Enabled :: NatM Bool +avx2Enabled = do + config <- getConfig + return (ncgAvx2Enabled config) + +cmmTopCodeGen + :: RawCmmDecl + -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr] + +cmmTopCodeGen (CmmProc info lab live graph) = do + let blocks = toBlockListEntryFirst graph + (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks + picBaseMb <- getPicBaseMaybeNat + platform <- getPlatform + let proc = CmmProc info lab live (ListGraph $ concat nat_blocks) + tops = proc : concat statics + os = platformOS platform + + case picBaseMb of + Just picBase -> initializePicBase_x86 os picBase tops + Nothing -> return tops + +cmmTopCodeGen (CmmData sec dat) = + return [CmmData sec (mkAlignment 1, dat)] -- no translation, we just use CmmStatic + +{- Note [Verifying basic blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want to guarantee a few things about the results + of instruction selection. + + Namely that each basic blocks consists of: + * A (potentially empty) sequence of straight line instructions + followed by + * A (potentially empty) sequence of jump like instructions. + + We can verify this by going through the instructions and + making sure that any non-jumpish instruction can't appear + after a jumpish instruction. + + There are gotchas however: + * CALLs are strictly speaking control flow but here we care + not about them. Hence we treat them as regular instructions. + + It's safe for them to appear inside a basic block + as (ignoring side effects inside the call) they will result in + straight line code. + + * NEWBLOCK marks the start of a new basic block so can + be followed by any instructions. +-} + +-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally. +verifyBasicBlock :: Platform -> [Instr] -> () +verifyBasicBlock platform instrs + | debugIsOn = go False instrs + | otherwise = () + where + go _ [] = () + go atEnd (i:instr) + = case i of + -- Start a new basic block + NEWBLOCK {} -> go False instr + -- Calls are not viable block terminators + CALL {} | atEnd -> faultyBlockWith i + | not atEnd -> go atEnd instr + -- All instructions ok, check if we reached the end and continue. + _ | not atEnd -> go (isJumpishInstr i) instr + -- Only jumps allowed at the end of basic blocks. + | otherwise -> if isJumpishInstr i + then go True instr + else faultyBlockWith i + faultyBlockWith i + = pprPanic "Non control flow instructions after end of basic block." + (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs)) + +basicBlockCodeGen + :: CmmBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmDecl (Alignment, RawCmmStatics) Instr]) + +basicBlockCodeGen block = do + let (_, nodes, tail) = blockSplit block + id = entryLabel block + stmts = blockToList nodes + -- Generate location directive + dbg <- getDebugBlock (entryLabel block) + loc_instrs <- case dblSourceTick =<< dbg of + Just (SourceNote span (LexicalFastString name)) + -> do fileId <- getFileId (srcSpanFile span) + let line = srcSpanStartLine span; col = srcSpanStartCol span + return $ unitOL $ LOCATION fileId line col (unpackFS name) + _ -> return nilOL + (mid_instrs,mid_bid) <- stmtsToInstrs id stmts + (!tail_instrs,_) <- stmtToInstrs mid_bid tail + let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs + platform <- getPlatform + return $! verifyBasicBlock platform (fromOL instrs) + instrs' <- fold <$> traverse addSpUnwindings instrs + -- code generation may introduce new basic block boundaries, which + -- are indicated by the NEWBLOCK instruction. We must split up the + -- instruction stream into basic blocks again. Also, we extract + -- LDATAs here too. + let + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs' + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) + return (BasicBlock id top : other_blocks, statics) + +-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes +-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock" +-- for details. +addSpUnwindings :: Instr -> NatM (OrdList Instr) +addSpUnwindings instr@(DELTA d) = do + config <- getConfig + let platform = ncgPlatform config + if ncgDwarfUnwindings config + then do lbl <- mkAsmTempLabel <$> getUniqueM + let unwind = Map.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d) + return $ toOL [ instr, UNWIND lbl unwind ] + else return (unitOL instr) +addSpUnwindings instr = return $ unitOL instr + +{- Note [Keeping track of the current block] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating instructions for Cmm we sometimes require +the current block for things like retry loops. + +We also sometimes change the current block, if a MachOP +results in branching control flow. + +Issues arise if we have two statements in the same block, +which both depend on the current block id *and* change the +basic block after them. This happens for atomic primops +in the X86 backend where we want to update the CFG data structure +when introducing new basic blocks. + +For example in #17334 we got this Cmm code: + + c3Bf: // global + (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18); + (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0); + _s3sT::I64 = _s3sV::I64; + goto c3B1; + +This resulted in two new basic blocks being inserted: + + c3Bf: + movl $18,%vI_n3Bo + movq 88(%vI_s3sQ),%rax + jmp _n3Bp + n3Bp: + ... + cmpxchgq %vI_n3Bq,88(%vI_s3sQ) + jne _n3Bp + ... + jmp _n3Bs + n3Bs: + ... + cmpxchgq %vI_n3Bt,88(%vI_s3sQ) + jne _n3Bs + ... + jmp _c3B1 + ... + +Based on the Cmm we called stmtToInstrs we translated both atomic operations under +the assumption they would be placed into their Cmm basic block `c3Bf`. +However for the retry loop we introduce new labels, so this is not the case +for the second statement. +This resulted in a desync between the explicit control flow graph +we construct as a separate data type and the actual control flow graph in the code. + +Instead we now return the new basic block if a statement causes a change +in the current block and use the block for all following statements. + +For this reason genForeignCall is also split into two parts. One for calls which +*won't* change the basic blocks in which successive instructions will be +placed (since they only evaluate CmmExpr, which can only contain MachOps, which +cannot introduce basic blocks in their lowerings). A different one for calls +which *are* known to change the basic block. + +-} + +-- See Note [Keeping track of the current block] for why +-- we pass the BlockId. +stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in. + -> [CmmNode O O] -- ^ Cmm Statement + -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction +stmtsToInstrs bid stmts = + go bid stmts nilOL + where + go bid [] instrs = return (instrs,bid) + go bid (s:stmts) instrs = do + (instrs',bid') <- stmtToInstrs bid s + -- If the statement introduced a new block, we use that one + let !newBid = fromMaybe bid bid' + go newBid stmts (instrs `appOL` instrs') + +-- | `bid` refers to the current block and is used to update the CFG +-- if new blocks are inserted in the control flow. +-- See Note [Keeping track of the current block] for more details. +stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in. + -> CmmNode e x + -> NatM (InstrBlock, Maybe BlockId) + -- ^ Instructions, and bid of new block if successive + -- statements are placed in a different basic block. +stmtToInstrs bid stmt = do + is32Bit <- is32BitPlatform + platform <- getPlatform + case stmt of + CmmUnsafeForeignCall target result_regs args + -> genForeignCall target result_regs args bid + + _ -> (,Nothing) <$> case stmt of + CmmComment s -> return (unitOL (COMMENT s)) + CmmTick {} -> return nilOL + + CmmUnwind regs -> do + let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable + to_unwind_entry (reg, expr) = Map.singleton reg (fmap (toUnwindExpr platform) expr) + case foldMap to_unwind_entry regs of + tbl | Map.null tbl -> return nilOL + | otherwise -> do + lbl <- mkAsmTempLabel <$> getUniqueM + return $ unitOL $ UNWIND lbl tbl + + CmmAssign reg src + | isFloatType ty -> assignReg_FltCode reg src + | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | isVecType ty -> assignReg_VecCode reg src + | otherwise -> assignReg_IntCode reg src + where ty = cmmRegType reg + + CmmStore addr src _alignment + | isFloatType ty -> assignMem_FltCode format addr src + | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | isVecType ty -> assignMem_VecCode format addr src + | otherwise -> assignMem_IntCode format addr src + where ty = cmmExprType platform src + format = cmmTypeFormat ty + + CmmBranch id -> return $ genBranch id + + --We try to arrange blocks such that the likely branch is the fallthrough + --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here. + CmmCondBranch arg true false _ -> genCondBranch bid true false arg + CmmSwitch arg ids -> genSwitch arg ids + CmmCall { cml_target = arg + , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs) + _ -> + panic "stmtToInstrs: statement should have been cps'd away" + + +jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat] +jumpRegs platform gregs = + [ RegWithFormat (RegReal r) (cmmTypeFormat ty) + | GlobalRegUse gr ty <- gregs + , Just r <- [globalRegMaybe platform gr] ] + +-------------------------------------------------------------------------------- +-- | 'InstrBlock's are the insn sequences generated by the insn selectors. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. +-- +type InstrBlock + = OrdList Instr + + +-- | Condition codes passed up the tree. +-- +data CondCode + = CondCode Bool Cond InstrBlock + + +-- | Register's passed up the tree. If the stix code forces the register +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. +-- +data Register + = Fixed Format Reg InstrBlock + | Any Format (Reg -> InstrBlock) + + +swizzleRegisterRep :: Register -> Format -> Register +swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code +swizzleRegisterRep (Any _ codefn) format = Any format codefn + +getLocalRegReg :: LocalReg -> Reg +getLocalRegReg (LocalReg u ty) + = -- by assuming SSE2, Int, Word, Float, Double and vectors all can be register allocated + RegVirtual (mkVirtualReg u (cmmTypeFormat ty)) + +-- | Grab the Reg for a CmmReg +getRegisterReg :: Platform -> CmmReg -> Reg + +getRegisterReg _ (CmmLocal lreg) = getLocalRegReg lreg + +getRegisterReg platform (CmmGlobal mid) + = case globalRegMaybe platform $ globalRegUse_reg mid of + Just reg -> RegReal $ reg + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + -- By this stage, the only MagicIds remaining should be the + -- ones which map to a real machine register on this + -- platform. Hence ... + +-- | Memory addressing modes passed up the tree. +data Amode + = Amode AddrMode InstrBlock + +{- +Now, given a tree (the argument to a CmmLoad) that references memory, +produce a suitable addressing mode. + +A Rule of the Game (tm) for Amodes: use of the addr bit must +immediately follow use of the code part, since the code part puts +values in registers which the addr then refers to. So you can't put +anything in between, lest it overwrite some of those registers. If +you need to do some other computation between the code part and use of +the addr bit, first store the effective address from the amode in a +temporary, then do the other computation, and then use the temporary: + + code + LEA amode, tmp + ... other computation ... + ... (tmp) ... +-} + +{- +Note [%rip-relative addressing on x86-64] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set, +"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of +specification version 0.99). + +In general the small code model would allow us to assume that code is located +between 0 and 2^31 - 1. However, this is not true on Windows which, due to +high-entropy ASLR, may place the executable image anywhere in 64-bit address +space. This is problematic since immediate operands in x86-64 are generally +32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding). +Consequently, to avoid overflowing we use %rip-relative addressing universally. +Since %rip-relative addressing comes essentially for free and makes linking far +easier, we use it even on non-Windows platforms. + +See also: the documentation for GCC's `-mcmodel=small` flag. +-} + + +-- | Check whether an integer will fit in 32 bits. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. +-- +is32BitInteger :: Integer -> Bool +is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 + where i64 = fromIntegral i :: Int64 + + +-- | Convert a BlockId to some CmmStatic data +jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic +jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config)) +jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = blockLbl blockid + + +-- ----------------------------------------------------------------------------- +-- General things for putting together code sequences + +-- Expand CmmRegOff. ToDo: should we do it this way around, or convert +-- CmmExprs into CmmRegOff? +mangleIndexTree :: CmmReg -> Int -> CmmExpr +mangleIndexTree reg off + = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] + where width = typeWidth (cmmRegType reg) + +-- | The dual to getAnyReg: compute an expression into a register, but +-- we don't mind which one it is. +getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) +getSomeReg expr = do + r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) + +assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock +assignMem_I64Code addrTree valueTree = do + Amode addr addr_code <- getAmode addrTree + RegCode64 vcode rhi rlo <- iselExpr64 valueTree + let + -- Little-endian store + mov_lo = MOV II32 (OpReg rlo) (OpAddr addr) + mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4))) + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + + +assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock +assignReg_I64Code (CmmLocal dst) valueTree = do + RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree + let + Reg64 r_dst_hi r_dst_lo = localReg64 dst + mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo) + mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi) + return ( + vcode `snocOL` mov_lo `snocOL` mov_hi + ) + +assignReg_I64Code _ _ + = panic "assignReg_I64Code(i386): invalid lvalue" + +iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock) +iselExpr64 (CmmLit (CmmInt i _)) = do + Reg64 rhi rlo <- getNewReg64 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = toOL [ + MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do + Amode addr addr_code <- getAmode addrTree + Reg64 rhi rlo <- getNewReg64 + let + mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) + mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) + return ( + RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo + ) + +iselExpr64 (CmmReg (CmmLocal local_reg)) = do + let Reg64 hi lo = localReg64 local_reg + return (RegCode64 nilOL hi lo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + Reg64 rhi rlo <- getNewReg64 + let + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpReg r2hi) (OpReg rhi) ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + SUB II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SBB II32 (OpReg r2hi) (OpReg rhi) ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do + code <- getAnyReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code r_dst_lo `snocOL` + XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi)) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do + (rsrc, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo), + XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi) + ]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do + (rsrc, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo), + XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi) + ]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do + code <- getAnyReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code r_dst_lo `snocOL` + MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL` + CLTD II32 `snocOL` + MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL` + MOV II32 (OpReg edx) (OpReg r_dst_hi)) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do + (r, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVSxL II16 (OpReg r) (OpReg eax), + CLTD II32, + MOV II32 (OpReg eax) (OpReg r_dst_lo), + MOV II32 (OpReg edx) (OpReg r_dst_hi)]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do + (r, code) <- getByteReg expr + Reg64 r_dst_hi r_dst_lo <- getNewReg64 + return $ RegCode64 (code `appOL` toOL [ + MOVSxL II8 (OpReg r) (OpReg eax), + CLTD II32, + MOV II32 (OpReg eax) (OpReg r_dst_lo), + MOV II32 (OpReg edx) (OpReg r_dst_hi)]) + r_dst_hi + r_dst_lo + +iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do + RegCode64 code rhi rlo <- iselExpr64 expr + Reg64 rohi rolo <- getNewReg64 + let + ocode = code `appOL` + toOL [ MOV II32 (OpReg rlo) (OpReg rolo), + XOR II32 (OpReg rohi) (OpReg rohi), + NEGI II32 (OpReg rolo), + SBB II32 (OpReg rhi) (OpReg rohi) ] + return (RegCode64 ocode rohi rolo) + +-- To multiply two 64-bit numbers we use the following decomposition (in C notation): +-- +-- ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo) +-- = ((r2lo * r1hi) << 32) +-- + ((r1lo * r2hi) << 32) +-- + r1lo * r2lo +-- +-- Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely. + +iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + tmp <- getNewRegNat II32 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg eax), + MOV II32 (OpReg r2lo) (OpReg tmp), + MOV II32 (OpReg r1hi) (OpReg rhi), + IMUL II32 (OpReg tmp) (OpReg rhi), + MOV II32 (OpReg r2hi) (OpReg rlo), + IMUL II32 (OpReg eax) (OpReg rlo), + ADD II32 (OpReg rlo) (OpReg rhi), + MUL2 II32 (OpReg tmp), + ADD II32 (OpReg edx) (OpReg rhi), + MOV II32 (OpReg eax) (OpReg rlo) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do + -- Performance sensitive users won't use 32 bit so let's keep it simple: + -- We always return a (usually false) positive. + Reg64 rhi rlo <- getNewReg64 + let code = toOL [ + MOV II32 (OpImm (ImmInt 1)) (OpReg rhi), + MOV II32 (OpImm (ImmInt 1)) (OpReg rlo) + ] + return (RegCode64 code rhi rlo) + + +-- To shift a 64-bit number to the left we use the SHLD and SHL instructions. +-- We use SHLD to shift the bits in @rhi@ to the left while copying +-- high bits from @rlo@ to fill the new space in the low bits of @rhi@. +-- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left. +-- However, both these instructions only use the lowest 5 bits from %cl to do +-- their shifting. So if the sixth bit (0x32) is set then we additionally move +-- the contents of @rlo@ to @rhi@ and clear @rlo@. + +iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + code2 <- getAnyReg e2 + Reg64 rhi rlo <- getNewReg64 + lbl1 <- newBlockId + lbl2 <- newBlockId + let + code = code1 `appOL` + code2 ecx `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi), + SHL II32 (OpReg ecx) (OpReg rlo), + TEST II32 (OpImm (ImmInt 32)) (OpReg ecx), + JXX EQQ lbl2, + JXX ALWAYS lbl1, + NEWBLOCK lbl1, + MOV II32 (OpReg rlo) (OpReg rhi), + XOR II32 (OpReg rlo) (OpReg rlo), + JXX ALWAYS lbl2, + NEWBLOCK lbl2 + ] + return (RegCode64 code rhi rlo) + +-- Similar to above, however now we're shifting to the right +-- and we're doing a signed shift which means that @rhi@ needs +-- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise, +-- and if the sixth bit of %cl is set (so the shift amount is more than 32). +-- To accomplish that we shift @rhi@ by 31. + +iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + (r2, code2) <- getSomeReg e2 + Reg64 rhi rlo <- getNewReg64 + lbl1 <- newBlockId + lbl2 <- newBlockId + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + MOV II32 (OpReg r2) (OpReg ecx), + SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo), + SAR II32 (OpReg ecx) (OpReg rhi), + TEST II32 (OpImm (ImmInt 32)) (OpReg ecx), + JXX EQQ lbl2, + JXX ALWAYS lbl1, + NEWBLOCK lbl1, + MOV II32 (OpReg rhi) (OpReg rlo), + SAR II32 (OpImm (ImmInt 31)) (OpReg rhi), + JXX ALWAYS lbl2, + NEWBLOCK lbl2 + ] + return (RegCode64 code rhi rlo) + +-- Similar to the above. + +iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + (r2, code2) <- getSomeReg e2 + Reg64 rhi rlo <- getNewReg64 + lbl1 <- newBlockId + lbl2 <- newBlockId + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + MOV II32 (OpReg r2) (OpReg ecx), + SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo), + SHR II32 (OpReg ecx) (OpReg rhi), + TEST II32 (OpImm (ImmInt 32)) (OpReg ecx), + JXX EQQ lbl2, + JXX ALWAYS lbl1, + NEWBLOCK lbl1, + MOV II32 (OpReg rhi) (OpReg rlo), + XOR II32 (OpReg rhi) (OpReg rhi), + JXX ALWAYS lbl2, + NEWBLOCK lbl2 + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2 +iselExpr64 (CmmMachOp (MO_Or _) [e1,e2]) = iselExpr64ParallelBin OR e1 e2 +iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2 + +iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + NOT II32 (OpReg rlo), + NOT II32 (OpReg rhi) + ] + return (RegCode64 code rhi rlo) + +iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i) + +iselExpr64 expr + = do + platform <- getPlatform + pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr)) + +iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr)) +iselExpr64ParallelBin op e1 e2 = do + RegCode64 code1 r1hi r1lo <- iselExpr64 e1 + RegCode64 code2 r2hi r2lo <- iselExpr64 e2 + Reg64 rhi rlo <- getNewReg64 + let + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + op II32 (OpReg r2lo) (OpReg rlo), + op II32 (OpReg r2hi) (OpReg rhi) + ] + return (RegCode64 code rhi rlo) + +-------------------------------------------------------------------------------- + +getRegister :: HasDebugCallStack => CmmExpr -> NatM Register +getRegister e = do platform <- getPlatform + is32Bit <- is32BitPlatform + getRegister' platform is32Bit e + +getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register + +getRegister' platform is32Bit (CmmReg reg) + = case reg of + CmmGlobal (GlobalRegUse PicBaseReg _) + | is32Bit -> + -- on x86_64, we have %rip for PicBaseReg, but it's not + -- a full-featured register, it can only be used for + -- rip-relative addressing. + do reg' <- getPicBaseNat (archWordFormat is32Bit) + return (Fixed (archWordFormat is32Bit) reg' nilOL) + _ -> + let ty = cmmRegType reg + reg_fmt = cmmTypeFormat ty + in return $ Fixed reg_fmt (getRegisterReg platform reg) nilOL + +getRegister' platform is32Bit (CmmRegOff r n) + = getRegister' platform is32Bit $ mangleIndexTree r n + +getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e]) + = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned) + +getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e]) + = addAlignmentCheck align <$> getRegister' platform is32Bit e + +-- for 32-bit architectures, support some 64 -> 32 bit conversions: +-- TO_W_(x), TO_W_(x >> 32) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + RegCode64 code rhi _rlo <- iselExpr64 x + return $ Fixed II32 rhi code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do + RegCode64 code rhi _rlo <- iselExpr64 x + return $ Fixed II32 rhi code + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + return $ Fixed II32 rlo code + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + ro <- getNewRegNat II8 + return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ]) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x]) + | is32Bit = do + RegCode64 code _rhi rlo <- iselExpr64 x + ro <- getNewRegNat II16 + return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ]) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II32 code) + +getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II32 code) + +-- catch simple cases of zero- or sign-extended load +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II8) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVZxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II16) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _]) + | not is32Bit = do + code <- intLoadCode (MOVSxL II32) addr + return (Any II64 code) + +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), + CmmLit displacement]) + | not is32Bit = + return $ Any II64 (\dst -> unitOL $ + LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) + +getRegister' _ _ (CmmMachOp mop []) = + pprPanic "getRegister(x86): nullary MachOp" (text $ show mop) + +getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps + avx <- avxEnabled + avx2 <- avx2Enabled + case mop of + MO_F_Neg w -> sse2NegCode w x + + + MO_S_Neg w -> triv_ucode NEGI (intFormat w) + MO_Not w -> triv_ucode NOT (intFormat w) + + -- Nop conversions + MO_UU_Conv W32 W8 -> toI8Reg W32 x + MO_SS_Conv W32 W8 -> toI8Reg W32 x + MO_XX_Conv W32 W8 -> toI8Reg W32 x + MO_UU_Conv W16 W8 -> toI8Reg W16 x + MO_SS_Conv W16 W8 -> toI8Reg W16 x + MO_XX_Conv W16 W8 -> toI8Reg W16 x + MO_UU_Conv W32 W16 -> toI16Reg W32 x + MO_SS_Conv W32 W16 -> toI16Reg W32 x + MO_XX_Conv W32 W16 -> toI16Reg W32 x + + MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_XX_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + + MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x + + MO_FW_Bitcast W32 -> bitcast FF32 II32 x + MO_WF_Bitcast W32 -> bitcast II32 FF32 x + MO_FW_Bitcast W64 -> bitcast FF64 II64 x + MO_WF_Bitcast W64 -> bitcast II64 FF64 x + MO_WF_Bitcast {} -> incorrectOperands + MO_FW_Bitcast {} -> incorrectOperands + + -- widenings + MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x + MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x + MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x + + MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x + MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x + + -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we + -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register + -- has 8-bit version). So for 32-bit code, we'll just zero-extend. + MO_XX_Conv W8 W32 + | is32Bit -> integerExtend W8 W32 MOVZxL x + | otherwise -> integerExtend W8 W32 MOV x + MO_XX_Conv W8 W16 + | is32Bit -> integerExtend W8 W16 MOVZxL x + | otherwise -> integerExtend W8 W16 MOV x + MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x + + MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x + MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x + MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x + MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x + MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x + MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x + -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl. + -- However, we don't want the register allocator to throw it + -- away as an unnecessary reg-to-reg move, so we keep it in + -- the form of a movzl and print it as a movl later. + -- This doesn't apply to MO_XX_Conv since in this case we don't care about + -- the upper bits. So we can just use MOV. + MO_XX_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOV x + MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x + MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x + + MO_FF_Conv W32 W64 -> coerceFP2FP W64 x + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x + + MO_FF_Conv from to -> invalidConversion from to + MO_UU_Conv from to -> invalidConversion from to + MO_SS_Conv from to -> invalidConversion from to + MO_XX_Conv from to -> invalidConversion from to + + MO_FS_Truncate from to -> coerceFP2Int from to x + MO_SF_Round from to -> coerceInt2FP from to x + + MO_VF_Neg l w | avx -> vector_float_negate_avx l w x + | otherwise -> vector_float_negate_sse l w x + -- SIMD NCG TODO: Support 256/512-bit integer vectors + MO_VS_Neg l w -> getRegister' platform is32Bit (CmmMachOp (MO_V_Sub l w) [zero_vec, x]) + where zero_vec = CmmLit $ CmmVec $ replicate l $ CmmInt 0 w + + MO_VF_Broadcast l w + | avx + -> vector_float_broadcast_avx l w x + | otherwise + -> vector_float_broadcast_sse l w x + MO_V_Broadcast l w + | avx2, l * widthInBits w `elem` [128, 256] -- AVX-512 is not supported for now + -> vector_int_broadcast_avx2 l w x + MO_V_Broadcast 16 W8 -> vector_int8x16_broadcast x + MO_V_Broadcast 8 W16 -> vector_int16x8_broadcast x + MO_V_Broadcast 4 W32 -> vector_int32x4_broadcast x + MO_V_Broadcast 2 W64 -> vector_int64x2_broadcast x + MO_V_Broadcast {} + -> pprPanic "Unsupported integer vector broadcast operation for: " (pdoc platform x) + + -- Binary MachOps + MO_Add {} -> incorrectOperands + MO_Sub {} -> incorrectOperands + MO_Eq {} -> incorrectOperands + MO_Ne {} -> incorrectOperands + MO_Mul {} -> incorrectOperands + MO_S_MulMayOflo {} -> incorrectOperands + MO_S_Quot {} -> incorrectOperands + MO_S_Rem {} -> incorrectOperands + MO_U_Quot {} -> incorrectOperands + MO_U_Rem {} -> incorrectOperands + MO_S_Ge {} -> incorrectOperands + MO_S_Le {} -> incorrectOperands + MO_S_Gt {} -> incorrectOperands + MO_S_Lt {} -> incorrectOperands + MO_U_Ge {} -> incorrectOperands + MO_U_Le {} -> incorrectOperands + MO_U_Gt {} -> incorrectOperands + MO_U_Lt {} -> incorrectOperands + MO_F_Add {} -> incorrectOperands + MO_F_Sub {} -> incorrectOperands + MO_F_Mul {} -> incorrectOperands + MO_F_Quot {} -> incorrectOperands + MO_F_Eq {} -> incorrectOperands + MO_F_Ne {} -> incorrectOperands + MO_F_Ge {} -> incorrectOperands + MO_F_Le {} -> incorrectOperands + MO_F_Gt {} -> incorrectOperands + MO_F_Lt {} -> incorrectOperands + MO_F_Min {} -> incorrectOperands + MO_F_Max {} -> incorrectOperands + MO_And {} -> incorrectOperands + MO_Or {} -> incorrectOperands + MO_Xor {} -> incorrectOperands + MO_Shl {} -> incorrectOperands + MO_U_Shr {} -> incorrectOperands + MO_S_Shr {} -> incorrectOperands + + MO_V_Extract {} -> incorrectOperands + MO_V_Add {} -> incorrectOperands + MO_V_Sub {} -> incorrectOperands + MO_V_Mul {} -> incorrectOperands + MO_V_Shuffle {} -> incorrectOperands + MO_VF_Shuffle {} -> incorrectOperands + MO_VU_Min {} -> incorrectOperands + MO_VU_Max {} -> incorrectOperands + MO_VS_Min {} -> incorrectOperands + MO_VS_Max {} -> incorrectOperands + MO_VF_Min {} -> incorrectOperands + MO_VF_Max {} -> incorrectOperands + + MO_VF_Extract {} -> incorrectOperands + MO_VF_Add {} -> incorrectOperands + MO_VF_Sub {} -> incorrectOperands + MO_VF_Mul {} -> incorrectOperands + MO_VF_Quot {} -> incorrectOperands + + -- Ternary MachOps + MO_FMA {} -> incorrectOperands + MO_VF_Insert {} -> incorrectOperands + MO_V_Insert {} -> incorrectOperands + + --_other -> pprPanic "getRegister" (pprMachOp mop) + where + triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register + triv_ucode instr format = trivialUCode format (instr format) x + + -- signed or unsigned extension. + integerExtend :: Width -> Width + -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr -> NatM Register + integerExtend from to instr expr = do + (reg,e_code) <- if from == W8 then getByteReg expr + else getSomeReg expr + let + code dst = + e_code `snocOL` + instr (intFormat from) (OpReg reg) (OpReg dst) + return (Any (intFormat to) code) + + bitcast :: Format -> Format -> CmmExpr -> NatM Register + bitcast fmt rfmt expr = + do (src, e_code) <- getSomeReg expr + let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst)) + return (Any rfmt code) + + toI8Reg :: Width -> CmmExpr -> NatM Register + toI8Reg new_rep expr + = do codefn <- getAnyReg expr + return (Any (intFormat new_rep) codefn) + -- HACK: use getAnyReg to get a byte-addressable register. + -- If the source was a Fixed register, this will add the + -- mov instruction to put it into the desired destination. + -- We're assuming that the destination won't be a fixed + -- non-byte-addressable register; it won't be, because all + -- fixed registers are word-sized. + + toI16Reg = toI8Reg -- for now + + conversionNop :: Format -> CmmExpr -> NatM Register + conversionNop new_format expr + = do e_code <- getRegister' platform is32Bit expr + return (swizzleRegisterRep e_code new_format) + + vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register + vector_float_negate_avx l w expr = do + let fmt :: Format + mask :: CmmLit + (fmt, mask) = case w of + W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- TODO: these should be negative 0 floating point literals, + W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- but we don't currently have those in Cmm. + _ -> panic "AVX floating-point negation: elements must be FF32 or FF64" + (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask) + (reg, exp) <- getSomeReg expr + let code dst = maskCode `appOL` + exp `snocOL` + (VMOVU fmt (OpReg reg) (OpReg dst)) `snocOL` + (VXOR fmt (OpReg maskReg) dst dst) + return (Any fmt code) + + vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register + vector_float_negate_sse l w expr = do + let fmt :: Format + mask :: CmmLit + (fmt, mask) = case w of + W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- Same comment as for vector_float_negate_avx, + W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- these should be -0.0 CmmFloat values. + _ -> panic "SSE floating-point negation: elements must be FF32 or FF64" + (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask) + (reg, exp) <- getSomeReg expr + let code dst = maskCode `appOL` + exp `snocOL` + (MOVU fmt (OpReg reg) (OpReg dst)) `snocOL` + (XOR fmt (OpReg maskReg) (OpReg dst)) + return (Any fmt code) + + ----------------------- + + -- TODO: we could use VBROADCASTSS/SD when AVX2 is available. + vector_float_broadcast_avx :: Length + -> Width + -> CmmExpr + -> NatM Register + vector_float_broadcast_avx len w expr = do + (dst, exp) <- getSomeReg expr + let fmt = VecFormat len (floatScalarFormat w) + code = VSHUF fmt (ImmInt 0) (OpReg dst) dst dst + return $ Fixed fmt dst (exp `snocOL` code) + + vector_float_broadcast_sse :: Length + -> Width + -> CmmExpr + -> NatM Register + vector_float_broadcast_sse len w expr = do + (dst, exp) <- getSomeReg expr + let fmt = VecFormat len (floatScalarFormat w) + code = SHUF fmt (ImmInt 0) (OpReg dst) dst + return $ Fixed fmt dst (exp `snocOL` code) + + vector_int_broadcast_avx2 :: Length + -> Width + -> CmmExpr + -> NatM Register + vector_int_broadcast_avx2 len w expr = do + (reg, exp) <- getNonClobberedReg expr + let (movFormat, fmt) = case w of + W8 -> (II32, VecFormat len FmtInt8) + W16 -> (II32, VecFormat len FmtInt16) + W32 -> (II32, VecFormat len FmtInt32) + W64 -> (II64, VecFormat len FmtInt64) + _ -> pprPanic "Broadcast not supported for: " (pdoc platform expr) + code dst = exp `snocOL` + -- VPBROADCAST from GPR requires AVX-512, + -- so we use an additional MOVD. + (MOVD movFormat fmt (OpReg reg) (OpReg dst)) `snocOL` + (VPBROADCAST fmt fmt (OpReg dst) dst) + return $ Any fmt code + + vector_int8x16_broadcast :: CmmExpr + -> NatM Register + vector_int8x16_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 16 FmtInt8 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PUNPCKLBW fmt (OpReg dst) dst) `snocOL` + (PUNPCKLWD (VecFormat 8 FmtInt16) (OpReg dst) dst) `snocOL` + (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) + ) + + vector_int16x8_broadcast :: CmmExpr + -> NatM Register + vector_int16x8_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 8 FmtInt16 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PUNPCKLWD fmt (OpReg dst) dst) `snocOL` + (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) + ) + + vector_int32x4_broadcast :: CmmExpr + -> NatM Register + vector_int32x4_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 4 FmtInt32 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst) + ) + + vector_int64x2_broadcast :: CmmExpr + -> NatM Register + vector_int64x2_broadcast expr = do + (reg, exp) <- getNonClobberedReg expr + let fmt = VecFormat 2 FmtInt64 + return $ Any fmt (\dst -> exp `snocOL` + (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL` + (PUNPCKLQDQ fmt (OpReg dst) dst) + ) + +getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps + sse4_1 <- sse4_1Enabled + sse4_2 <- sse4_2Enabled + avx <- avxEnabled + case mop of + MO_F_Eq _ -> condFltReg is32Bit EQQ x y + MO_F_Ne _ -> condFltReg is32Bit NE x y + MO_F_Gt _ -> condFltReg is32Bit GTT x y + MO_F_Ge _ -> condFltReg is32Bit GE x y + -- Invert comparison condition and swap operands + -- See Note [SSE Parity Checks] + MO_F_Lt _ -> condFltReg is32Bit GTT y x + MO_F_Le _ -> condFltReg is32Bit GE y x + + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt _ -> condIntReg GU x y + MO_U_Ge _ -> condIntReg GEU x y + MO_U_Lt _ -> condIntReg LU x y + MO_U_Le _ -> condIntReg LEU x y + + MO_F_Add w -> trivialFCode_sse2 w (\fmt op2 -> ADD fmt op2 . OpReg) x y + MO_F_Sub w -> trivialFCode_sse2 w (\fmt op2 -> SUB fmt op2 . OpReg) x y + MO_F_Quot w -> trivialFCode_sse2 w FDIV x y + MO_F_Mul w -> trivialFCode_sse2 w (\fmt op2 -> MUL fmt op2 . OpReg) x y + MO_F_Min w -> trivialFCode_sse2 w (MINMAX Min FloatMinMax) x y + MO_F_Max w -> trivialFCode_sse2 w (MINMAX Max FloatMinMax) x y + + MO_Add rep -> add_code rep x y + MO_Sub rep -> sub_code rep x y + + MO_S_Quot rep -> div_code rep True True x y + MO_S_Rem rep -> div_code rep True False x y + MO_U_Quot rep -> div_code rep False True x y + MO_U_Rem rep -> div_code rep False False x y + + MO_S_MulMayOflo rep -> imulMayOflo rep x y + + MO_Mul W8 -> imulW8 x y + MO_Mul rep -> triv_op rep IMUL + MO_And rep -> triv_op rep AND + MO_Or rep -> triv_op rep OR + MO_Xor rep -> triv_op rep XOR + + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode is not restrictive enough (sigh.) + -} + MO_Shl rep -> shift_code rep SHL x y {-False-} + MO_U_Shr rep -> shift_code rep SHR x y {-False-} + MO_S_Shr rep -> shift_code rep SAR x y {-False-} + + MO_VF_Shuffle 4 W32 is | avx -> vector_shuffle_float_avx 4 x y is + | otherwise -> vector_shuffle_floatx4_sse sse4_1 x y is + MO_VF_Shuffle 2 W64 is | avx -> vector_shuffle_double_avx 2 x y is + | otherwise -> vector_shuffle_doublex2_sse x y is + MO_VF_Shuffle {} -> sorry "Please use -fllvm for wide shuffle instructions" + + MO_VF_Extract l W32 | avx -> vector_float_extract l W32 x y + | otherwise -> vector_float_extract_sse l W32 x y + MO_VF_Extract l W64 -> vector_float_extract l W64 x y + MO_VF_Extract {} -> incorrectOperands + + MO_V_Extract 16 W8 | sse4_1 -> vector_int_extract_pextr 16 W8 x y + | otherwise -> vector_int8x16_extract_sse2 x y + MO_V_Extract 8 W16 -> vector_int_extract_pextr 8 W16 x y -- PEXTRW (SSE2) + MO_V_Extract 4 W32 | sse4_1 -> vector_int_extract_pextr 4 W32 x y + | otherwise -> vector_int32x4_extract_sse2 x y + MO_V_Extract 2 W64 | sse4_1 -> vector_int_extract_pextr 2 W64 x y + | otherwise -> vector_int64x2_extract_sse2 x y + -- SIMD NCG TODO: 256/512-bit vector + MO_V_Extract {} -> needLlvm mop + + MO_VF_Add l w | avx -> vector_float_op_avx VADD l w x y + | otherwise -> vector_float_op_sse (\fmt op2 -> ADD fmt op2 . OpReg) l w x y + + MO_VF_Sub l w | avx -> vector_float_op_avx VSUB l w x y + | otherwise -> vector_float_op_sse (\fmt op2 -> SUB fmt op2 . OpReg) l w x y + + MO_VF_Mul l w | avx -> vector_float_op_avx VMUL l w x y + | otherwise -> vector_float_op_sse (\fmt op2 -> MUL fmt op2 . OpReg) l w x y + + MO_VF_Quot l w | avx -> vector_float_op_avx VDIV l w x y + | otherwise -> vector_float_op_sse FDIV l w x y + + MO_VF_Min l w | avx -> vector_float_op_avx (VMINMAX Min FloatMinMax) l w x y + | otherwise -> vector_float_op_sse (MINMAX Min FloatMinMax) l w x y + + MO_VF_Max l w | avx -> vector_float_op_avx (VMINMAX Max FloatMinMax) l w x y + | otherwise -> vector_float_op_sse (MINMAX Max FloatMinMax) l w x y + + -- SIMD NCG TODO: 256/512-bit integer vector operations + MO_V_Shuffle 16 W8 is | not is32Bit -> vector_shuffle_int8x16 sse4_1 x y is + MO_V_Shuffle 8 W16 is -> vector_shuffle_int16x8 sse4_1 x y is + MO_V_Shuffle 4 W32 is -> vector_shuffle_int32x4 sse4_1 x y is + MO_V_Shuffle 2 W64 is -> vector_shuffle_int64x2 sse4_1 x y is + MO_V_Shuffle {} -> needLlvm mop + MO_V_Add l w | l * widthInBits w == 128 -> vector_int_op_sse PADD l w x y + | otherwise -> needLlvm mop + MO_V_Sub l w | l * widthInBits w == 128 -> vector_int_op_sse PSUB l w x y + | otherwise -> needLlvm mop + MO_V_Mul 16 W8 -> vector_int8x16_mul_sse2 x y + MO_V_Mul l@8 w@W16 -> vector_int_op_sse PMULL l w x y -- PMULLW (SSE2) + MO_V_Mul l@4 w@W32 | sse4_1 -> vector_int_op_sse PMULL l w x y -- PMULLD (SSE4.1) + | otherwise -> vector_int32x4_mul_sse2 x y + MO_V_Mul 2 W64 -> vector_int64x2_mul_sse2 x y + MO_V_Mul {} -> needLlvm mop + + MO_VU_Min l@16 w@W8 + -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUB (SSE2) + MO_VU_Min l@8 w@W16 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUW (SSE4.1) + | otherwise -> vector_word_minmax_sse Min l w x y + MO_VU_Min l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUD (SSE4.1) + | otherwise -> vector_word_minmax_sse Min l w x y + MO_VU_Min l@2 w@W64 + | sse4_2 -> vector_word_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_W64X2_Min) + MO_VU_Min {} -> needLlvm mop + MO_VU_Max l@16 w@W8 + -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUB (SSE2) + MO_VU_Max l@8 w@W16 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUW (SSE4.1) + | otherwise -> vector_word_minmax_sse Max l w x y + MO_VU_Max l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUD (SSE4.1) + | otherwise -> vector_word_minmax_sse Max l w x y + MO_VU_Max l@2 w@W64 + | sse4_2 -> vector_word_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_W64X2_Max) + MO_VU_Max {} -> needLlvm mop + MO_VS_Min l@16 w@W8 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSB (SSE4.1) + | otherwise -> vector_int_minmax_sse Min l w x y + MO_VS_Min l@8 w@W16 + -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSW (SSE2) + MO_VS_Min l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSD (SSE4.1) + | otherwise -> vector_int_minmax_sse Min l w x y + MO_VS_Min l@2 w@W64 + | sse4_2 -> vector_int_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_I64X2_Min) + MO_VS_Min {} -> needLlvm mop + MO_VS_Max l@16 w@W8 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSB (SSE4.1) + | otherwise -> vector_int_minmax_sse Max l w x y + MO_VS_Max l@8 w@W16 + -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSW (SSE2) + MO_VS_Max l@4 w@W32 + | sse4_1 -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSD (SSE4.1) + | otherwise -> vector_int_minmax_sse Max l w x y + MO_VS_Max l@2 w@W64 + | sse4_2 -> vector_int_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2 + -- The SSE2 version is implemented as a C call (MO_I64X2_Max) + MO_VS_Max {} -> needLlvm mop + + -- Unary MachOps + MO_S_Neg {} -> incorrectOperands + MO_F_Neg {} -> incorrectOperands + MO_Not {} -> incorrectOperands + MO_SF_Round {} -> incorrectOperands + MO_FS_Truncate {} -> incorrectOperands + MO_SS_Conv {} -> incorrectOperands + MO_XX_Conv {} -> incorrectOperands + MO_FF_Conv {} -> incorrectOperands + MO_UU_Conv {} -> incorrectOperands + MO_WF_Bitcast {} -> incorrectOperands + MO_FW_Bitcast {} -> incorrectOperands + MO_RelaxedRead {} -> incorrectOperands + MO_AlignmentCheck {} -> incorrectOperands + MO_VS_Neg {} -> incorrectOperands + MO_VF_Neg {} -> incorrectOperands + MO_V_Broadcast {} -> incorrectOperands + MO_VF_Broadcast {} -> incorrectOperands + + -- Ternary MachOps + MO_FMA {} -> incorrectOperands + MO_V_Insert {} -> incorrectOperands + MO_VF_Insert {} -> incorrectOperands + + where + -------------------- + triv_op width instr = trivialCode width op (Just op) x y + where op = instr (intFormat width) + + -- Special case for IMUL for bytes, since the result of IMULB will be in + -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider + -- values. + imulW8 :: CmmExpr -> CmmExpr -> NatM Register + imulW8 arg_a arg_b = do + (a_reg, a_code) <- getNonClobberedReg arg_a + b_code <- getAnyReg arg_b + + let code = a_code `appOL` b_code eax `appOL` + toOL [ IMUL2 format (OpReg a_reg) ] + format = intFormat W8 + + return (Fixed format eax code) + + imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register + imulMayOflo W8 a b = do + -- The general case (W16, W32, W64) doesn't work for W8 as its + -- multiplication doesn't use two registers. + -- + -- The plan is: + -- 1. truncate and sign-extend a and b to 8bit width + -- 2. multiply a' = a * b in 32bit width + -- 3. copy and sign-extend 8bit from a' to c + -- 4. compare a' and c: they are equal if there was no overflow + (a_reg, a_code) <- getNonClobberedReg a + (b_reg, b_code) <- getNonClobberedReg b + let + code = a_code `appOL` b_code `appOL` + toOL [ + MOVSxL II8 (OpReg a_reg) (OpReg a_reg), + MOVSxL II8 (OpReg b_reg) (OpReg b_reg), + IMUL II32 (OpReg b_reg) (OpReg a_reg), + MOVSxL II8 (OpReg a_reg) (OpReg eax), + CMP II16 (OpReg a_reg) (OpReg eax), + SETCC NE (OpReg eax) + ] + return (Fixed II8 eax code) + imulMayOflo rep a b = do + (a_reg, a_code) <- getNonClobberedReg a + b_code <- getAnyReg b + let + shift_amt = case rep of + W16 -> 15 + W32 -> 31 + W64 -> 63 + w -> panic ("shift_amt: " ++ show w) + + format = intFormat rep + code = a_code `appOL` b_code eax `appOL` + toOL [ + IMUL2 format (OpReg a_reg), -- result in %edx:%eax + SAR format (OpImm (ImmInt shift_amt)) (OpReg eax), + -- sign extend lower part + SUB format (OpReg edx) (OpReg eax) + -- compare against upper + -- eax==0 if high part == sign extended low part + ] + return (Fixed format eax code) + + -------------------- + shift_code :: Width + -> (Format -> Operand -> Operand -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register + + {- Case1: shift length as immediate -} + shift_code width instr x (CmmLit lit) + -- Handle the case of a shift larger than the width of the shifted value. + -- This is necessary since x86 applies a mask of 0x1f to the shift + -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by + -- `47 & 0x1f == 15`. See #20626. + | CmmInt n _ <- lit + , n >= fromIntegral (widthInBits width) + = getRegister $ CmmLit $ CmmInt 0 width + + | otherwise = do + x_code <- getAnyReg x + let + format = intFormat width + code dst + = x_code dst `snocOL` + instr format (OpImm (litToImm lit)) (OpReg dst) + return (Any format code) + + {- Case2: shift length is complex (non-immediate) + * y must go in %ecx. + * we cannot do y first *and* put its result in %ecx, because + %ecx might be clobbered by x. + * if we do y second, then x cannot be + in a clobbered reg. Also, we cannot clobber x's reg + with the instruction itself. + * so we can either: + - do y first, put its result in a fresh tmp, then copy it to %ecx later + - do y second and put its result into %ecx. x gets placed in a fresh + tmp. This is likely to be better, because the reg alloc can + eliminate this reg->reg move here (it won't eliminate the other one, + because the move is into the fixed %ecx). + * in the case of C calls the use of ecx here can interfere with arguments. + We avoid this with the hack described in Note [Evaluate C-call + arguments before placing in destination registers] + -} + shift_code width instr x y{-amount-} = do + x_code <- getAnyReg x + let format = intFormat width + tmp <- getNewRegNat format + y_code <- getAnyReg y + let + code = x_code tmp `appOL` + y_code ecx `snocOL` + instr format (OpReg ecx) (OpReg tmp) + return (Fixed format tmp code) + + -------------------- + add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + add_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger y + , rep /= W8 -- LEA doesn't support byte size (#18614) + = add_int rep x y + add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y + where format = intFormat rep + -- TODO: There are other interesting patterns we want to replace + -- with a LEA, e.g. `(x + offset) + (y << shift)`. + + -------------------- + sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register + sub_code rep x (CmmLit (CmmInt y _)) + | is32BitInteger (-y) + , rep /= W8 -- LEA doesn't support byte size (#18614) + = add_int rep x (-y) + sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y + + -- our three-operand add instruction: + add_int width x y = do + (x_reg, x_code) <- getSomeReg x + let + format = intFormat width + imm = ImmInt (fromInteger y) + code dst + = x_code `snocOL` + LEA format + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) + (OpReg dst) + -- + return (Any format code) + + ---------------------- + + -- See Note [DIV/IDIV for bytes] + div_code W8 signed quotient x y = do + let widen | signed = MO_SS_Conv W8 W16 + | otherwise = MO_UU_Conv W8 W16 + div_code + W16 + signed + quotient + (CmmMachOp widen [x]) + (CmmMachOp widen [y]) + + div_code width signed quotient x y = do + (y_op, y_code) <- getRegOrMem y -- cannot be clobbered + x_code <- getAnyReg x + let + format = intFormat width + widen | signed = CLTD format + | otherwise = XOR format (OpReg edx) (OpReg edx) + + instr | signed = IDIV + | otherwise = DIV + + code = y_code `appOL` + x_code eax `appOL` + toOL [widen, instr format y_op] + + result | quotient = eax + | otherwise = edx + + return (Fixed format result code) + + ----------------------- + -- Vector operations--- + vector_float_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr) + -> Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_op_avx instr l w = vector_op_avx_reg (\fmt -> instr fmt . OpReg) format + where format = case w of + W32 -> VecFormat l FmtFloat + W64 -> VecFormat l FmtDouble + _ -> pprPanic "Floating-point AVX vector operation not supported at this width" + (text "width:" <+> ppr w) + + vector_op_avx_reg :: (Format -> Reg -> Reg -> Reg -> Instr) + -> Format + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_op_avx_reg instr format expr1 expr2 = do + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let -- opcode src2 src1 dst <==> dst = src1 `opcode` src2 + code dst = exp1 `appOL` exp2 `snocOL` + (instr format reg2 reg1 dst) + return (Any format code) + + vector_float_op_sse :: (Format -> Operand -> Reg -> Instr) + -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_float_op_sse instr l w = vector_op_sse instr format + where format = case w of + W32 -> VecFormat l FmtFloat + W64 -> VecFormat l FmtDouble + _ -> pprPanic "Floating-point SSE vector operation not supported at this width" + (text "width:" <+> ppr w) + + vector_int_op_sse :: (Format -> Operand -> Reg -> Instr) + -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_int_op_sse instr l w = vector_op_sse instr format + where format = case w of + W8 -> VecFormat l FmtInt8 + W16 -> VecFormat l FmtInt16 + W32 -> VecFormat l FmtInt32 + W64 -> VecFormat l FmtInt64 + _ -> pprPanic "Integer SSE vector operation not supported at this width" + (text "width:" <+> ppr w) + + -- This function is similar to genTrivialCode, but re-using it would require + -- handling alignment correctly: SSE vector instructions typically require 16-byte + -- alignment for their memory operand (this restriction is relaxed with VEX-encoded + -- instructions). + -- For now, we always load the value into a register and avoid the alignment issue. + vector_op_sse :: (Format -> Operand -> Reg -> Instr) + -> Format + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_op_sse instr = vector_op_sse_reg (\fmt -> instr fmt . OpReg) + + vector_op_sse_reg :: (Format -> Reg -> Reg -> Instr) + -> Format + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_op_sse_reg instr format expr1 expr2 = do + config <- getConfig + exp1_code <- getAnyReg expr1 + (reg2, exp2_code) <- getSomeReg expr2 -- vector registers are never clobbered by an instruction + tmp <- getNewRegNat format + let code dst + -- opcode src2 src1 <==> src1 = src1 `opcode` src2 + | dst == reg2 = exp2_code `snocOL` + movInstr config format (OpReg reg2) (OpReg tmp) `appOL` -- MOVU or MOVDQU + exp1_code dst `snocOL` + instr format tmp dst + | otherwise = exp2_code `appOL` + exp1_code dst `snocOL` + instr format reg2 dst + return (Any format code) + -------------------- + vector_float_extract :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_extract l W32 expr (CmmLit lit) = do + (r, exp) <- getSomeReg expr + let format = VecFormat l FmtFloat + imm = litToImm lit + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` (MOV FF32 (OpReg r) (OpReg dst)) + CmmInt _ _ -> exp `snocOL` (VPSHUFD format imm (OpReg r) dst) + _ -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit) + return (Any FF32 code) + vector_float_extract _ W64 expr (CmmLit lit) = do + (r, exp) <- getSomeReg expr + let code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` + (MOV FF64 (OpReg r) (OpReg dst)) + CmmInt 1 _ -> exp `snocOL` + (MOVHLPS FF64 r dst) + _ -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit) + return (Any FF64 code) + vector_float_extract _ w c e = + pprPanic "Unsupported AVX floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w) + ----------------------- + + vector_float_extract_sse :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_float_extract_sse l W32 expr (CmmLit lit) + = do + (r,exp) <- getSomeReg expr + let format = VecFormat l FmtFloat + imm = litToImm lit + code dst + = case lit of + CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst)) + CmmInt _ _ -> exp `snocOL` (PSHUFD format imm (OpReg r) dst) + _ -> pprPanic "Unsupported SSE floating-point vector extract offset" (ppr lit) + return (Any FF32 code) + vector_float_extract_sse _ w c e + = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w) + ----------------------- + + -- PEXTRW ("to GPR" variant) is an SSE2 instruction, + -- whereas PEXTR{B,D,Q} and PEXTRW ("to memory" variant) require SSE4.1. + vector_int_extract_pextr :: Length + -> Width + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int_extract_pextr l w expr (CmmLit (CmmInt i _)) + | 0 <= i, i < toInteger l + = do + (r, exp) <- getSomeReg expr -- vector registers are never clobbered by an instruction + let (scalarFormat, vectorFormat) = case w of + W8 -> (II32, VecFormat l FmtInt8) + W16 -> (II32, VecFormat l FmtInt16) + W32 -> (II32, VecFormat l FmtInt32) + W64 -> (II64, VecFormat l FmtInt64) + _ -> sorry "Unsupported vector format" + code dst = exp `snocOL` + (PEXTR scalarFormat vectorFormat (ImmInteger i) r (OpReg dst)) + return (Any scalarFormat code) + vector_int_extract_pextr _ _ _ i + = pprPanic "Unsupported offset" (pdoc platform i) + + vector_int8x16_extract_sse2 :: CmmExpr + -> CmmExpr + -> NatM Register + vector_int8x16_extract_sse2 expr (CmmLit (CmmInt i _)) + | 0 <= i, i < 16 + = do + (r, exp) <- getSomeReg expr + let code dst = + case i `quotRem` 2 of + (j, 0) -> exp `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) -- PEXTRW + (j, _) -> exp `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) `snocOL` -- PEXTRW + (SHR II32 (OpImm (ImmInt 8)) (OpReg dst)) + return (Any II8 code) + vector_int8x16_extract_sse2 _ offset + = pprPanic "Unsupported offset" (pdoc platform offset) + + vector_int32x4_extract_sse2 :: CmmExpr + -> CmmExpr + -> NatM Register + vector_int32x4_extract_sse2 expr (CmmLit (CmmInt i _)) + | 0 <= i, i < 4 + = do + (r, exp) <- getSomeReg expr + let fmt = VecFormat 4 FmtInt32 + tmp <- getNewRegNat fmt + let code dst = + case i of + 0 -> exp `snocOL` + (MOVD fmt II32 (OpReg r) (OpReg dst)) + 1 -> exp `snocOL` + (PSHUFD fmt (ImmInt 0b01_01_01_01) (OpReg r) tmp) `snocOL` -- tmp <- (r[1],r[1],r[1],r[1]) + (MOVD fmt II32 (OpReg tmp) (OpReg dst)) + 2 -> exp `snocOL` + (PSHUFD fmt (ImmInt 0b11_10_11_10) (OpReg r) tmp) `snocOL` -- tmp <- (r[2],r[3],r[2],r[3]) + (MOVD fmt II32 (OpReg tmp) (OpReg dst)) + _ -> exp `snocOL` + (PSHUFD fmt (ImmInt 0b11_11_11_11) (OpReg r) tmp) `snocOL` -- tmp <- (r[3],r[3],r[3],r[3]) + (MOVD fmt II32 (OpReg tmp) (OpReg dst)) + return (Any II32 code) + vector_int32x4_extract_sse2 _ offset + = pprPanic "Unsupported offset" (pdoc platform offset) + + vector_int64x2_extract_sse2 :: CmmExpr + -> CmmExpr + -> NatM Register + vector_int64x2_extract_sse2 expr (CmmLit lit) + = do + (r, exp) <- getSomeReg expr + let fmt = VecFormat 2 FmtInt64 + tmp <- getNewRegNat fmt + let code dst = + case lit of + CmmInt 0 _ -> exp `snocOL` + (MOVD fmt II64 (OpReg r) (OpReg dst)) + CmmInt 1 _ -> exp `snocOL` + (MOVHLPS FF64 r tmp) `snocOL` + (MOVD fmt II64 (OpReg tmp) (OpReg dst)) + _ -> panic "Error in offset while unpacking" + return (Any II64 code) + vector_int64x2_extract_sse2 _ offset + = pprPanic "Unsupported offset" (pdoc platform offset) + + vector_int8x16_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register + vector_int8x16_mul_sse2 expr1 expr2 = do + -- use two SSE2 PMULLW (low 16 bits of int16 multiplication) operations + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let format = VecFormat 16 FmtInt8 + format16 = VecFormat 8 FmtInt16 -- for PMULLW + tmp1lo <- getNewRegNat format + tmp1hi <- getNewRegNat format + tmp2hi <- getNewRegNat format + tmp2lo <- getNewRegNat format + (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate 8 (CmmInt 0xff W16)) -- (0xff,0,0xff,0,...,0xff,0) :: Int8X16 + let code = exp1 `appOL` exp2 `appOL` maskCode `snocOL` + (MOVDQU format (OpReg reg1) (OpReg tmp1lo)) `snocOL` -- tmp1lo <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp2lo)) `snocOL` -- tmp2lo <- reg2 + (PUNPCKLBW format (OpReg reg1) tmp1lo) `snocOL` -- tmp1lo <- (tmp1lo[0],reg1[0],tmp1lo[1],reg1[1],...,tmp1lo[7],reg1[7]); The first operand does not really matter + (PUNPCKLBW format (OpReg reg2) tmp2lo) `snocOL` -- tmp2lo <- (tmp2lo[0],reg2[0],tmp2lo[1],reg2[1],...,tmp2lo[7],reg2[7]); The first operand does not really matter + (MOVDQU format (OpReg reg1) (OpReg tmp1hi)) `snocOL` -- tmp1hi <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp2hi)) `snocOL` -- tmp2hi <- reg2 + (PUNPCKHBW format (OpReg reg1) tmp1hi) `snocOL` -- tmp1hi <- (tmp1hi[8],reg1[8],tmp1hi[9],reg1[9],...,tmp1hi[15],reg1[15]); The first operand does not really matter + (PMULL format16 (OpReg tmp2lo) tmp1lo) `snocOL` -- PMULLW; tmp1lo <- (tmp1lo[0]*tmp2lo[0],*,tmp1lo[2]*tmp2lo[2],*,...,tmp1lo[14]*tmp2lo[14],*) + (PUNPCKHBW format (OpReg reg2) tmp2hi) `snocOL` -- tmp2hi <- (tmp2hi[8],reg2[8],tmp2hi[9],reg2[9],...,tmp2hi[15],reg2[15]); The first operand does not really matter + (PMULL format16 (OpReg tmp2hi) tmp1hi) `snocOL` -- PMULLW; tmp1hi <- (tmp1hi[0]*tmp2hi[0],*,tmp1hi[2]*tmp2hi[2],*,...,tmp1hi[14]*tmp2hi[14],*) + (PAND format (OpReg maskReg) tmp1lo) `snocOL` -- tmp1lo <- (tmp1lo[0],0,tmp1lo[2],0,...,tmp1lo[14],0) + (PAND format (OpReg maskReg) tmp1hi) `snocOL` -- tmp1hi <- (tmp1hi[0],0,tmp1hi[2],0,...,tmp1hi[14],0) + (PACKUSWB format (OpReg tmp1hi) tmp1lo) -- tmp1lo <- (tmp1lo[0],tmp1lo[2],...,tmp1lo[14],tmp1hi[0],tmp1hi[2],...tmp1hi[14]) + return (Fixed format tmp1lo code) + + vector_int32x4_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register + vector_int32x4_mul_sse2 expr1 expr2 = do + -- use two SSE2 PMULUDQ (int32 x int32 -> int64 multiplication) operations + (reg1, exp1) <- getSomeReg expr1 + (reg2, exp2) <- getSomeReg expr2 + let format = VecFormat 4 FmtInt32 + tmpEven <- getNewRegNat format + tmpOdd1 <- getNewRegNat format + tmpOdd2 <- getNewRegNat format + let code dst = exp1 `appOL` exp2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg tmpEven)) `snocOL` -- tmpEven <- reg1 + (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg1) tmpOdd1) `snocOL` -- tmpOdd1 <- (reg1[1],reg1[1],reg1[3],reg1[3]) + (PMULUDQ format (OpReg reg2) tmpEven) `snocOL` -- tmpEven <- (tmpEven[0]*reg2[0],*,tmpEven[2]*reg2[2],*) + (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg2) tmpOdd2) `snocOL` -- tmpOdd2 <- (reg2[1],reg2[1],reg2[3],reg2[3]) + (PMULUDQ format (OpReg tmpOdd2) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0]*tmpOdd2[0],*,tmpOdd1[2]*tmpOdd2[2],*) + (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpEven) dst) `snocOL` -- dst <- (tmpEven[0],tmpEven[2],tmpEven[0],tmpEven[0]) + (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpOdd1) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0],tmpOdd1[2],tmpOdd1[0],tmpOdd1[0]) + (PUNPCKLDQ format (OpReg tmpOdd1) dst) -- dst <- (dst[0],tmpOdd1[0],dst[1],tmpOdd1[1]) + return (Any format code) + + -- TODO: We could use `VPMULLQ` if AVX-512 or AVX10.1 is available. + vector_int64x2_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register + vector_int64x2_mul_sse2 expr1 expr2 = do + -- implement 64 bit multiplication using 32-bit PMULUDQ multiplication instructions + -- (lo1 + shiftL hi1 32) * (lo2 + shiftL hi2 32) = lo1 * lo2 + shiftL (lo1 * hi2) 32 + shiftL (lo2 * hi1) 32 + exp1 <- getAnyReg expr1 + exp2 <- getAnyReg expr2 + let format = VecFormat 2 FmtInt64 + reg1 <- getNewRegNat format + reg2 <- getNewRegNat format + tmp1Hi <- getNewRegNat format + tmp2Hi <- getNewRegNat format + let code dst = exp1 reg1 `appOL` exp2 reg2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg1) (OpReg tmp1Hi)) `snocOL` -- tmp1Hi <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp2Hi)) `snocOL` -- tmp2Hi <- reg2 + (PSRL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL` -- PSRLQ (logical shift); tmp1Hi <- (tmp1Hi[0] >> 32, tmp1Hi[1] >> 32) + (PMULUDQ format (OpReg reg2) dst) `snocOL` -- dst <- ((dst as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (dst as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64) + (PSRL format (OpImm (ImmInt 32)) tmp2Hi) `snocOL` -- PSRLQ (logical shift); tmp2Hi <- (tmp2Hi[0] >> 32, tmp2Hi[1] >> 32) + (PMULUDQ format (OpReg reg2) tmp1Hi) `snocOL` -- tmp1Hi <- ((tmp1Hi as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (tmp1Hi as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64) + (PMULUDQ format (OpReg reg1) tmp2Hi) `snocOL` -- tmp2Hi <- ((tmp2Hi as Word32X4)[0] * (reg1 as Word32X4)[0] as Word64, (tmp2Hi as Word32X4)[2] * (reg1 as Word32X4)[2] as Word64) + (PADD format (OpReg tmp2Hi) tmp1Hi) `snocOL` -- PADDQ; tmp1Hi <- (tmp1Hi[0] + tmp2Hi[0], tmp1Hi[1] + tmp2Hi[1]) + (PSLL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL` -- PSLLQ; tmp1Hi <- (tmp1Hi[0] << 32, tmp1Hi[1] << 32) + (PADD format (OpReg tmp1Hi) dst) -- PADDQ; dst <- (dst[0] + tmp1Hi[0], dst[1] + tmp1Hi[1]) + return (Any format code) + + vector_int_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_int_minmax_sse minmax l w expr1 expr2 = do + -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b) + exp1 <- getAnyReg expr1 + exp2 <- getAnyReg expr2 + let format = case w of + W8 -> VecFormat l FmtInt8 + W16 -> VecFormat l FmtInt16 + W32 -> VecFormat l FmtInt32 + W64 -> VecFormat l FmtInt64 + _ -> panic "Unsupported width" + reg1 <- getNewRegNat format + reg2 <- getNewRegNat format + tmp <- getNewRegNat format + let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp)) `snocOL` -- tmp <- reg2 + (PCMPGT format (OpReg reg2) dst) `snocOL` -- dst <- if dst > reg2 then True(-1) else False(0) + (PAND format (OpReg dst) tmp) `snocOL` -- tmp <- tmp & dst; if dst then tmp else 0 + (PANDN format (OpReg reg1) dst) `snocOL` -- dst <- ~dst & reg1; if dst then 0 else reg1 + (POR format (OpReg tmp) dst) -- dst <- tmp | dst + codeMax dst = exp1 reg1 `appOL` exp2 reg2 `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg1) (OpReg tmp)) `snocOL` -- tmp <- reg1 + (PCMPGT format (OpReg reg2) dst) `snocOL` -- dst <- if dst > reg2 then True(-1) else False(0) + (PAND format (OpReg dst) tmp) `snocOL` -- tmp <- tmp & dst; if dst then tmp else 0 + (PANDN format (OpReg reg2) dst) `snocOL` -- dst <- ~dst & reg2; if dst then 0 else reg2 + (POR format (OpReg tmp) dst) -- dst <- tmp | dst + return $ case minmax of + Min -> Any format codeMin + Max -> Any format codeMax + + vector_word_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register + vector_word_minmax_sse minmax l w expr1 expr2 = do + -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b) + -- We can use PCMPGT to compare unsigned integers by flipping the most significant bit. + exp1 <- getAnyReg expr1 + exp2 <- getAnyReg expr2 + let (format, sign) = case w of + W8 -> (VecFormat l FmtInt8, 0x80) + W16 -> (VecFormat l FmtInt16, 0x8000) + W32 -> (VecFormat l FmtInt32, 2^(31 :: Int)) + W64 -> (VecFormat l FmtInt64, 2^(63 :: Int)) + _ -> panic "Unsupported width" + reg1 <- getNewRegNat format + reg2 <- getNewRegNat format + tmp1 <- getNewRegNat format + tmp2 <- getNewRegNat format + (signReg, signCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l (CmmInt sign w)) + let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2 + (MOVDQU format (OpReg reg2) (OpReg tmp2)) `snocOL` -- tmp2 <- reg2 + (PXOR format (OpReg signReg) dst) `snocOL` -- dst <- dst ^ 2^(w-1) + (PXOR format (OpReg signReg) tmp1) `snocOL` -- tmp1 < dst ^ 2^(w-1) + (PCMPGT format (OpReg tmp1) dst) `snocOL` -- dst <- if dst > tmp1 then True(-1) else False(0) + (PAND format (OpReg dst) tmp2) `snocOL` -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0 + (PANDN format (OpReg reg1) dst) `snocOL` -- dst <- ~dst & reg1; if dst then 0 else reg1 + (POR format (OpReg tmp2) dst) -- dst <- tmp2 | dst + codeMax dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL` + (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1 + (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2 + (MOVDQU format (OpReg reg1) (OpReg tmp2)) `snocOL` -- tmp2 <- reg1 + (PXOR format (OpReg signReg) dst) `snocOL` -- dst <- dst ^ 2^(w-1) + (PXOR format (OpReg signReg) tmp1) `snocOL` -- tmp1 <- tmp1 ^ 2^(w-1) + (PCMPGT format (OpReg tmp1) dst) `snocOL` -- dst <- if dst > tmp1 then True(-1) else False(0) + (PAND format (OpReg dst) tmp2) `snocOL` -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0 + (PANDN format (OpReg reg2) dst) `snocOL` -- dst <- ~dst & reg2; if dst then 0 else reg2 + (POR format (OpReg tmp2) dst) -- dst <- tmp2 | dst + return $ case minmax of + Min -> Any format codeMin + Max -> Any format codeMax + + vector_shuffle_floatx4_sse :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_floatx4_sse sse4_1 v1 v2 is + | length is == 4, all (\i -> 0 <= i && i < 8) is = do + let fmt = VecFormat 4 FmtFloat + + -- A helper function to shuffle a vector `r` in-place using (dst,src) pairs + -- (r[d0],r[d1],...) <- (r[s0],r[s1],...) + inplaceShuffle pairs r = do + let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs + case mask of + 0b11_10_01_00 -> nilOL -- trivial + 0b01_00_01_00 -> unitOL (MOVLHPS fmt r r) + 0b11_10_11_10 -> unitOL (MOVHLPS fmt r r) + 0b01_01_00_00 -> unitOL (UNPCKL fmt (OpReg r) r) + 0b11_11_10_10 -> unitOL (UNPCKH fmt (OpReg r) r) + _ -> unitOL (SHUF fmt (ImmInt mask) (OpReg r) r) + + -- All elements are from one source vector + oneSource p0 p1 p2 p3 v = do + exp <- getAnyReg v + let code dst = exp dst `appOL` + inplaceShuffle [p0,p1,p2,p3] dst + return $ Any fmt code + + -- Two elements from one vector, other two from the other vector + twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v1 v2 + twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v2 v1 + twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v1 v2 + twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v2 v1 + twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_op_sse UNPCKL fmt v1 v2 + twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_op_sse UNPCKL fmt v2 v1 + twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_op_sse UNPCKH fmt v1 v2 + twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_op_sse UNPCKH fmt v2 v1 + twoAndTwo p0 p1 q0 q1 v1 v2 = + if sse4_1 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then + let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1) + in vector_op_sse (`BLEND` (ImmInt imm)) fmt v1 v2 + else do + let imm = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6) + reg <- vector_op_sse (`SHUF` (ImmInt imm)) fmt v1 v2 + exp <- anyReg reg + let code dst = exp dst `appOL` + inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst + return $ Any fmt code + + -- Three elements from one vector, the last one from the other vector + threeAndOne p0 p1 p2 q0 v1 v2 + | sse4_1 = do -- Use INSERTPS + exp1 <- getAnyReg v1 + (r2, exp2) <- getSomeReg v2 + let imm2 = (snd q0 `shiftL` 6) .|. (fst q0 `shiftL` 4) + dst <- getNewRegNat fmt + let code = exp1 dst `appOL` exp2 `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,fst q0)] dst `snocOL` + (INSERTPS fmt (ImmInt imm2) (OpReg r2) dst) + return $ Fixed fmt dst code + + | (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use MOVSS + exp1 <- getAnyReg v1 + (r2, exp2) <- getSomeReg v2 + dst <- getNewRegNat fmt + let code = exp1 dst `appOL` exp2 `snocOL` + (MOV fmt (OpReg r2) (OpReg dst)) `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,0)] dst + return $ Fixed fmt dst code + + | otherwise = do -- Use two or three SHUFPSs + (r1, exp1) <- getSomeReg v1 + exp2 <- getAnyReg v2 + let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6) + let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0) + (imm2, pairs) = + if fst q0 == 1 then + (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + else + (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + dst <- getNewRegNat fmt + let code = exp1 `appOL` exp2 dst `snocOL` + (SHUF fmt (ImmInt imm1) (OpReg r1) dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0]) + (SHUF fmt (ImmInt imm2) (OpReg r1) dst) `appOL` + inplaceShuffle pairs dst + return $ Fixed fmt dst code + + -- We partition the list of indices into those that refer to the first vector and those that + -- refer to the second, and handle each case depending on the number of indices in each group. + let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is) + case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of + ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1 + ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2 + ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2 + ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1 + ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2 + _ -> pprPanic "vector shuffle: cannot occur" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is) + + -- Shuffle with AVX instructions. + -- The components above 128 bits are shuffled in the same way as the lower 128 bits. + -- For example, `l == 8 && is == [0,2,5,7]` would represent `shuffleFloatX8# _ _ (# 0#, 2#, 9#, 11#, 4#, 6#, 13#, 15# #)`. + vector_shuffle_float_avx :: Length -- Vector length. 4 for XMM, 8 for YMM, 16 for ZMM. + -> CmmExpr + -> CmmExpr + -> [Int] -- 4-element list of indices + -> NatM Register + vector_shuffle_float_avx l v1 v2 is + | length is == 4, all (\i -> 0 <= i && i < 8) is = do + let fmt = VecFormat l FmtFloat + + -- A helper function to shuffle a vector using (dst,src) pairs + -- (dst[d0],dst[d1],...) <- (r[s0],r[s1],...) + inplaceShuffle pairs r dst = do + let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs + case mask of + 0b11_10_01_00 | r == dst -> nilOL + | otherwise -> unitOL (VMOVU fmt (OpReg r) (OpReg dst)) -- trivial + 0b01_00_01_00 | l == 4 -> unitOL (VMOVLHPS fmt r r dst) -- 128-bit only + 0b11_10_11_10 | l == 4 -> unitOL (VMOVHLPS fmt r r dst) -- 128-bit only + 0b01_01_00_00 -> unitOL (VUNPCKL fmt (OpReg r) r dst) + 0b11_11_10_10 -> unitOL (VUNPCKH fmt (OpReg r) r dst) + _ -> unitOL (VSHUF fmt (ImmInt mask) (OpReg r) r dst) + + -- All elements are from one source vector + oneSource p0 p1 p2 p3 v = do + (r, exp) <- getSomeReg v + let code dst = exp `appOL` + inplaceShuffle [p0,p1,p2,p3] r dst + return $ Any fmt code + + -- Two elements from one vector, other two from the other vector + twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v1 v2 + twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v2 v1 + twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v1 v2 + twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v2 v1 + twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v1 v2 + twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v2 v1 + twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v1 v2 + twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v2 v1 + twoAndTwo p0 p1 q0 q1 v1 v2 = + if l <= 8 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then + -- VBLENDPS does not support ZMM (no EVEX-encoded variant) + let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1) + imm' = if l == 4 then imm .|. (imm `shiftL` 4) else imm + in vector_float_op_avx (`VBLEND` (ImmInt imm')) l W32 v1 v2 + else do + let imm1 = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6) + reg <- vector_float_op_avx (`VSHUF` (ImmInt imm1)) l W32 v1 v2 + exp <- anyReg reg + let code dst = exp dst `appOL` + inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst dst + return $ Any fmt code + + -- Three elements from one vector, the last one from the other vector + threeAndOne p0 p1 p2 q0 v1 v2 + | l == 4, (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use VMOVSS (128-bit only) + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let code dst = exp1 `appOL` exp2 `snocOL` + (VMOV_MERGE fmt r2 r1 dst) `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,0)] dst dst + return $ Any fmt code + + | l == 4 = do -- Use VINSERTPS (128-bit only) + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let i = case [0, 1, 2, 3] \\ [snd p0, snd p1, snd p2] of + i:_ -> i -- We can clobber this position of r1 + _ -> panic "cannot occur" + imm = (snd q0 `shiftL` 6) .|. (i `shiftL` 4) + code dst = exp1 `appOL` exp2 `snocOL` + (VINSERTPS fmt (ImmInt imm) (OpReg r2) r1 dst) `appOL` + inplaceShuffle [p0,p1,p2,(fst q0,i)] dst dst + return $ Any fmt code + + | otherwise = do -- Use two or three VSHUFPSs + (r1, exp1) <- getSomeReg v1 + exp2 <- getAnyReg v2 + let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6) + let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0) + (imm2, pairs) = + if fst q0 == 1 then + (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + else + (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]) + -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2]) + -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst + dst <- getNewRegNat fmt + let code = exp1 `appOL` exp2 dst `snocOL` + (VSHUF fmt (ImmInt imm1) (OpReg r1) dst dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0]) + (VSHUF fmt (ImmInt imm2) (OpReg r1) dst dst) `appOL` + inplaceShuffle pairs dst dst + return $ Fixed fmt dst code + + -- We partition the list of indices into those that refer to the first vector and those that + -- refer to the second, and handle each case depending on the number of indices in each group. + let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is) + case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of + ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1 + ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2 + ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2 + ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1 + ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2 + _ -> pprPanic "vector shuffle: cannot occur" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is) + + vector_shuffle_doublex2_sse :: CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_doublex2_sse v1 v2 is + | [i0, i1] <- is = + let fmt = VecFormat 2 FmtDouble + in case (i0, i1) of + -- Trivial cases + (0, 1) -> getRegister' platform is32Bit v1 + (2, 3) -> getRegister' platform is32Bit v2 + + -- MOVSD/UNPCKLPD/UNPCKHPD have shorter encoding than SHUFPD + -- If SSE4.1 is available, BLENDPD could also be used in place of MOVSD (the encoding is longer though) + (0, 3) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v2 v1 -- MOVSD + (2, 1) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v1 v2 -- MOVSD + _ | i0 == i1 -> do + exp <- getAnyReg (if i0 <= 1 then v1 else v2) + let unpck = if i0 == 0 || i0 == 2 + then UNPCKL + else UNPCKH + code dst = exp dst `snocOL` + (unpck fmt (OpReg dst) dst) + return (Any fmt code) + (0, 2) -> vector_op_sse UNPCKL fmt v1 v2 + (2, 0) -> vector_op_sse UNPCKL fmt v2 v1 + (1, 3) -> vector_op_sse UNPCKH fmt v1 v2 + (3, 1) -> vector_op_sse UNPCKH fmt v2 v1 + + -- SHUFPD + (1, 2) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v1 v2 + (3, 0) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v2 v1 + (1, 0) -> do + exp <- getAnyReg v1 + let code dst = exp dst `snocOL` + (SHUF fmt (ImmInt 0b01) (OpReg dst) dst) + return (Any fmt code) + (3, 2) -> do + exp <- getAnyReg v2 + let code dst = exp dst `snocOL` + (SHUF fmt (ImmInt 0b01) (OpReg dst) dst) + return (Any fmt code) + _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is) + + -- Shuffle with AVX instructions. + -- The components above 128 bits are shuffled in the same way as the lower 128 bits. + -- For example, `l == 4 && is == [0,3]` would represent `shuffleDoubleX4# _ _ (# 0#, 5#, 2#, 7# #)`. + vector_shuffle_double_avx :: Length -- Vector length. 2 for XMM, 4 for YMM, 8 for ZMM. + -> CmmExpr + -> CmmExpr + -> [Int] -- 2-element list of indices + -> NatM Register + vector_shuffle_double_avx l v1 v2 is + | [i0, i1] <- is = + let fmt = VecFormat l FmtDouble + repeatShufpdMask m = case l of + 8 -> m .|. (m `shiftL` 2) .|. (m `shiftL` 4) .|. (m `shiftL` 6) + 4 -> m .|. (m `shiftL` 2) + _ -> m + in case (i0, i1) of + -- Trivial cases + (0, 1) -> getRegister' platform is32Bit v1 + (2, 3) -> getRegister' platform is32Bit v2 + + -- VMOVSD/VUNPCKLPD/VUNPCKHPD have shorter encoding than VSHUFPD + (0, 3) | l == 2 -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let code dst = exp1 `appOL` exp2 `snocOL` + (VMOV_MERGE fmt r1 r2 dst) -- VMOVSD + return (Any fmt code) + | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v1 v2 + (2, 1) | l == 2 -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let code dst = exp1 `appOL` exp2 `snocOL` + (VMOV_MERGE fmt r2 r1 dst) -- VMOVSD + return (Any fmt code) + | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v2 v1 + _ | i0 == i1 -> do + (r, exp) <- getSomeReg (if i0 <= 1 then v1 else v2) + let unpck = if i0 == 0 || i0 == 2 + then VUNPCKL + else VUNPCKH + code dst = exp `snocOL` + (unpck fmt (OpReg r) r dst) + return (Any fmt code) + (0, 2) -> vector_float_op_avx VUNPCKL l W64 v1 v2 + (2, 0) -> vector_float_op_avx VUNPCKL l W64 v2 v1 + (1, 3) -> vector_float_op_avx VUNPCKH l W64 v1 v2 + (3, 1) -> vector_float_op_avx VUNPCKH l W64 v2 v1 + + -- SHUFPD + (1, 2) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v1 v2 + (3, 0) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v2 v1 + (1, 0) -> do + (r, exp) <- getSomeReg v1 + let code dst = exp `snocOL` + (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst) + return (Any fmt code) + (3, 2) -> do + (r, exp) <- getSomeReg v2 + let code dst = exp `snocOL` + (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst) + return (Any fmt code) + _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is) + | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is) + + isZeroVecLit :: CmmExpr -> Bool + isZeroVecLit (CmmLit (CmmVec elems)) = all (\lit -> case lit of CmmInt 0 _ -> True; _ -> False) elems + isZeroVecLit _ = False + + vector_shuffle_int128_common :: Bool -> Format -> CmmExpr -> CmmExpr -> [Int] -> Maybe (NatM Register) + vector_shuffle_int128_common sse4_1 fmt v1 v2 is + | length is == n, all (\i -> 0 <= i && i < 2 * n) is = if + -- Trivial cases + | is == [0..n-1] -> Just $ getRegister' platform is32Bit v1 + | is == [n..2*n-1] -> Just $ getRegister' platform is32Bit v2 + + -- We would like to emit PXOR for these trivial cases, instead of PSLLDQ. + -- These conditions can be generalized to the cases where all elements are equal, + -- or more generally, a constant-folding rule. + | v1IsZero, all (< n) is -> Just $ getRegister' platform is32Bit v1 + | v2IsZero, all (>= n) is -> Just $ getRegister' platform is32Bit v2 + + -- PSLLDQ: v2 == 0 && is == [n..(2n-1),...,n..(2n-1);0,1,2,3,...,n-i-1] + | v2IsZero, (z, js) <- span (>= n) is, and (zipWith (==) js [0..]) -> Just $ do + exp1 <- getAnyReg v1 + let code dst = exp1 dst `snocOL` + (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PSLLDQ: v1 == 0 && is == [0..(n-1),...,0..(n-1);n,n+1,...,2n-i-1] + | v1IsZero, (z, js) <- span (< n) is, and (zipWith (==) js [n..]) -> Just $ do + exp2 <- getAnyReg v2 + let code dst = exp2 dst `snocOL` + (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PSRLDQ: v2 == 0 && is == [i,i+1,...,n-2,n-1;n..(2n-1),...,n..(2n-1)] + | v2IsZero, (js, z) <- span (< n) is, all (>= n) z, and (zipWith (==) (reverse js) [n-1,n-2..]) -> Just $ do + exp1 <- getAnyReg v1 + let code dst = exp1 dst `snocOL` + (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PSRLDQ: v1 == 0 && is == [n+i,...,2n-2,2n-1;0..(n-1),...,0..(n-1)] + | v1IsZero, (js, z) <- span (>= n) is, all (< n) z, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]) -> Just $ do + exp2 <- getAnyReg v2 + let code dst = exp2 dst `snocOL` + (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst) + return (Any fmt code) + + -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [i,i+1,...,n-2,n-1;n,n+1,...,n+i-1] + | (js, ks) <- span (< n) is, and (zipWith (==) (reverse js) [n-1,n-2..]), and (zipWith (==) ks [n..]) -> Just $ do + ssse3 <- ssse3Enabled + let amountInBytes = widthInBytes * length ks + if ssse3 + then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v2 v1 + else do + exp1 <- getAnyReg v1 + exp2 <- getAnyReg v2 + tmp <- getNewRegNat fmt + let code dst = exp1 tmp `snocOL` + (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL` + exp2 dst `snocOL` + (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL` + (POR fmt (OpReg tmp) dst) + return (Any fmt code) + + -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [n+i,n+i+1,...,2n-2,2n-1;0,1,...,i-1] + | (js, ks) <- span (>= n) is, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]), and (zipWith (==) ks [0..]) -> Just $ do + ssse3 <- ssse3Enabled + let amountInBytes = widthInBytes * length ks + if ssse3 + then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v1 v2 + else do + exp1 <- getAnyReg v1 + exp2 <- getAnyReg v2 + tmp <- getNewRegNat fmt + let code dst = exp2 tmp `snocOL` + (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL` + exp1 dst `snocOL` + (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL` + (POR fmt (OpReg tmp) dst) + return (Any fmt code) + + -- PBLENDW (SSE4.1): map (`mod` n) is == [0,1,...,n-1] if widthInBytes >= 2 + | sse4_1, widthInBytes >= 2, and (zipWith (\i j -> i `rem` n == j) is [0..]) -> Just $ do + let k = widthInBytes `quot` 2 + m = bit k - 1 + imm = foldr (\i acc -> if i >= n then (acc `shiftL` k) .|. m else acc `shiftL` k) 0 is + vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2 + + | otherwise -> Nothing + + | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is) + where + (n, widthInBytes) = case fmt of + VecFormat 16 FmtInt8 -> (16, 1) + VecFormat 8 FmtInt16 -> (8, 2) + VecFormat 4 FmtInt32 -> (4, 4) + VecFormat 2 FmtInt64 -> (2, 8) + _ -> pprPanic "Invalid format" (ppr fmt) + v1IsZero = isZeroVecLit v1 + v2IsZero = isZeroVecLit v2 + + vector_shuffle_int8x16 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int8x16 sse4_1 v1 v2 is + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = do + ssse3 <- ssse3Enabled + let fmtInt16X8 = VecFormat 8 FmtInt16 + v1IsZero = isZeroVecLit v1 + v2IsZero = isZeroVecLit v2 + tryInt16X8Mask [] = Just [] + tryInt16X8Mask (j0:j1:js) + | even j0, j1 == j0 + 1 = (j0 `quot` 2 :) <$> tryInt16X8Mask js + tryInt16X8Mask _ = Nothing + if + -- PUNPCKLBW / PUNPCKHBW + | [0,16,1,17,2,18,3,19,4,20,5,21,6,22,7,23] <- is -> vector_op_sse PUNPCKLBW fmt v1 v2 + | [16,0,17,1,18,2,19,3,20,4,21,5,22,6,23,7] <- is -> vector_op_sse PUNPCKLBW fmt v2 v1 + | [8,24,9,25,10,26,11,27,12,28,13,29,14,30,15,31] <- is -> vector_op_sse PUNPCKHBW fmt v1 v2 + | [24,8,25,9,26,10,27,11,28,12,29,13,30,14,31,15] <- is -> vector_op_sse PUNPCKHBW fmt v2 v1 + + -- PSHUFB (SSSE3) + | ssse3, all (< 16) is || v2IsZero -> do + exp1 <- getAnyReg v1 + let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is + Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1 + let code dst = exp1 dst `appOL` + amode_code1 `snocOL` + (PSHUFB fmt (OpAddr amode1) dst) + return (Any fmt code) + + -- PSHUFB (SSSE3) + | ssse3, all (>= 16) is || v1IsZero -> do + exp2 <- getAnyReg v2 + let mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is + Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2 + let code dst = exp2 dst `appOL` + amode_code2 `snocOL` + (PSHUFB fmt (OpAddr amode2) dst) + return (Any fmt code) + + -- PBLENDW (SSE4.1): js <- tryInt16X8Mask is, map (`mod` 8) js == [0,1,...,7] + | sse4_1, Just js <- tryInt16X8Mask is, and (zipWith (\i j -> i `rem` 8 == j) js [0..]) -> do + let imm = foldr (\i acc -> if i >= 8 then (acc `shiftL` 1) .|. 1 else acc `shiftL` 1) 0 js + vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2 + + -- General case with SSSE3: PSHUFB + PSHUFB + POR + | ssse3 -> do + exp1 <- getAnyReg v1 + exp2 <- getAnyReg v2 + tmp1 <- getNewRegNat fmt + let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is + mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is + Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1 + Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2 + let code dst = exp1 tmp1 `appOL` exp2 dst `appOL` + amode_code1 `snocOL` + (PSHUFB fmt (OpAddr amode1) tmp1) `appOL` + amode_code2 `snocOL` + (PSHUFB fmt (OpAddr amode2) dst) `snocOL` + (POR fmt (OpReg tmp1) dst) + return (Any fmt code) + + -- General case with SSE2: GPR + MOVQ + PUNPCKLQDQ + | otherwise -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + tmp <- getNewRegNat II64 + tmpLo <- getNewRegNat II64 + tmpHi <- getNewRegNat II64 + tmpXmm <- getNewRegNat fmt + dst <- getNewRegNat fmt + let place8Bits srcPos dstPos dst = + -- Assumption: 0 <= srcPos < 32, 0 <= dstPos < 8 + -- tmp <- (src[srcPos] `shiftR` ((srcPos `rem` 16) * 8)) .&. 0xff + -- dst <- dst .|. (tmp `shiftL` (dstPos * 8)) + let r = if srcPos < 16 then r1 else r2 + in case (srcPos `rem` 16) `quotRem` 2 of + (k, 0) -> toOL [ PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp) + , MOVZxL II8 (OpReg tmp) (OpReg tmp) + , SHL II64 (OpImm (ImmInt (8 * dstPos))) (OpReg tmp) + , OR II64 (OpReg tmp) (OpReg dst) + ] + (k, _) -> (PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)) `consOL` + ((case dstPos of + 0 -> unitOL (SHR II32 (OpImm (ImmInt 8)) (OpReg tmp)) + 1 -> unitOL (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) + _ -> toOL [ AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp) + , SHL II64 (OpImm (ImmInt (8 * (dstPos - 1)))) (OpReg tmp) ]) `snocOL` + (OR II64 (OpReg tmp) (OpReg dst))) + makeInt8x8OnGPR dst js = (XOR II32 (OpReg dst) (OpReg dst)) `consOL` + concatOL [ place8Bits srcPos dstPos dst | (srcPos, dstPos) <- zip js [0..] ] + code = exp1 `appOL` exp2 `appOL` + makeInt8x8OnGPR tmpLo (take 8 is) `snocOL` + (MOVD II64 fmt (OpReg tmpLo) (OpReg dst)) `appOL` + makeInt8x8OnGPR tmpHi (drop 8 is) `snocOL` + (MOVD II64 fmt (OpReg tmpHi) (OpReg tmpXmm)) `snocOL` + (PUNPCKLQDQ fmt (OpReg tmpXmm) dst) + return (Fixed fmt dst code) + where fmt = VecFormat 16 FmtInt8 + + vector_shuffle_int16x8 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int16x8 sse4_1 v1 v2 is@(i0:i1:i2:i3:i4567@[i4,i5,i6,i7]) + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + let -- shufL src dst k0 k1 k2 k3 (0 <= k_i < 4): + -- dst <- (src[k0],src[k1],src[k2],src[k3],src[4],src[5],src[6],src[7]) + shufL src dst 0 1 2 3 | src == dst = nilOL + | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + shufL src dst k0 k1 k2 k3 = let imm = k0 + (k1 `shiftL` 2) + (k2 `shiftL` 4) + (k3 `shiftL` 6) + in unitOL (PSHUFLW fmt (ImmInt imm) (OpReg src) dst) + -- shufH src dst k0 k1 k2 k3 (4 <= k_i < 8): + -- dst <- (src[0],src[1],src[2],src[3],src[k0],src[k1],src[k2],src[k3]) + shufH src dst 4 5 6 7 | src == dst = nilOL + | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + shufH src dst k0 k1 k2 k3 = let imm = (k0 - 4) + ((k1 - 4) `shiftL` 2) + ((k2 - 4) `shiftL` 4) + ((k3 - 4) `shiftL` 6) + in unitOL (PSHUFHW fmt (ImmInt imm) (OpReg src) dst) + + shufLHImm src dst immLo immHi = case (immLo, immHi) of + (0b11_10_01_00, 0b11_10_01_00) + | src == dst -> nilOL + | otherwise -> unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + (0b11_10_01_00, _) -> unitOL (PSHUFHW fmt (ImmInt immHi) (OpReg src) dst) + (_, 0b11_10_01_00) -> unitOL (PSHUFLW fmt (ImmInt immLo) (OpReg src) dst) + (_, _) -> toOL [PSHUFLW fmt (ImmInt immLo) (OpReg src) dst, + PSHUFHW fmt (ImmInt immHi) (OpReg dst) dst] + + -- ks = [k0,...,k7] + -- Assumption: 0 <= k_i < 4 for 0 <= i < 4, 4 <= k_i < 8 for 4 <= i < 8 + -- dst <- (src[k0],...,src[k7]) + shufLH src dst ks + = let (k_lo, k_hi) = splitAt 4 ks + immLo = foldr (\k acc -> (acc `shiftL` 2) + k) 0 k_lo + immHi = foldr (\k acc -> (acc `shiftL` 2) + (k - 4)) 0 k_hi + in shufLHImm src dst immLo immHi + + -- shufRev src dst j0 j1 j2 j3 j4 j5 j6 j7: + -- Assumption: [j0,j1,j2,j3] `elem` permutations [0,1,2,3] && [j4,j5,j6,j7] `elem` permutations [4,5,6,7]: + -- dst[j0] <- src[0]; dst[j1] <- src[1]; dst[j2] <- src[2]; dst[j3] <- src[3]; + -- dst[j4] <- src[4]; dst[j5] <- src[5]; dst[j6] <- src[6]; dst[j7] <- src[7]; + shufRev src dst _j0 j1 j2 j3 _j4 j5 j6 j7 + = let immLo = (1 `shiftL` (2 * j1)) + (2 `shiftL` (2 * j2)) + (3 `shiftL` (2 * j3)) + immHi = (1 `shiftL` (2 * (j5 - 4))) + (2 `shiftL` (2 * (j6 - 4))) + (3 `shiftL` (2 * (j7 - 4))) + in shufLHImm src dst immLo immHi + i0123 = [i0, i1, i2, i3] + if + -- PSHUFLW + PSHUFHW + | all (\i -> i < 4) i0123 + , all (\i -> 4 <= i && i < 8) i4567 + -> do + let code dst = exp1 `appOL` + shufLH r1 dst is + return (Any fmt code) + + -- PSHUFLW + PSHUFHW + | all (\i -> 8 <= i && i < 12) i0123 + , all (\i -> 12 <= i) i4567 + -> do + let code dst = exp2 `appOL` + shufLH r2 dst (map (subtract 8) is) + return (Any fmt code) + + -- PSHUF{L,H}W + PBLENDW (SSE4.1) + | sse4_1 + , all (\i -> i `rem` 8 < 4) i0123 + , all (\i -> 4 <= i `rem` 8) i4567 + -> do + tmp <- getNewRegNat fmt + let imm = foldl' (\acc (i,p) -> if i >= 8 then setBit acc p else acc) 0 (zip is [0..]) + js = zipWith (\i p -> if i >= 8 then p else i) is [0..] + ks = zipWith (\i p -> if i >= 8 then i - 8 else p) is [0..] + code dst = exp1 `appOL` exp2 `appOL` + shufLH r2 tmp ks `appOL` + shufLH r1 dst js `snocOL` + (PBLENDW fmt (ImmInt imm) (OpReg tmp) dst) + return (Any fmt code) + + -- PSHUFLW + PSHUFLW + PUNPCKLWD + PSHUFLW + PSHUFHW + | all (\i -> i < 4 || (8 <= i && i < 12)) is + , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 4) [(0, i0), (1, i1), (2, i2), (3, i3)] + , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 4) [(4, i4), (5, i5), (6, i6), (7, i7)] + -> do + tmp1 <- getNewRegNat fmt + tmp2 <- getNewRegNat fmt + let code dst = exp1 `appOL` exp2 `appOL` + shufL r1 tmp1 k0 k1 k4 k5 `appOL` + shufL r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL` + (PUNPCKLWD fmt (OpReg tmp2) tmp1) `appOL` + shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7 + return (Any fmt code) + + -- PSHUFHW + PSHUFHW + PUNPCKHWD + PSHUFLW + PSHUFHW + | all (\i -> (4 <= i && i < 8) || 12 <= i) is + , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 8) [(0, i0), (1, i1), (2, i2), (3, i3)] + , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 8) [(4, i4), (5, i5), (6, i6), (7, i7)] + -> do + tmp1 <- getNewRegNat fmt + tmp2 <- getNewRegNat fmt + let code dst = exp1 `appOL` exp2 `appOL` + shufH r1 tmp1 k0 k1 k4 k5 `appOL` + shufH r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL` + (PUNPCKHWD fmt (OpReg tmp2) tmp1) `appOL` + shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7 + return (Any fmt code) + + -- Generic implementation + | otherwise -> do + tmp0 <- getNewRegNat II32 + tmps <- replicateM 7 (getNewRegNat II32) + let code dst = exp1 `appOL` exp2 `appOL` + toOL [ PEXTR II32 fmt (ImmInt i') r (OpReg tmp) + | (i, tmp) <- zip is (tmp0:tmps) + , let (i', r) = if i < 8 then (i, r1) else (i - 8, r2) + ] `snocOL` + (MOVD II32 fmt (OpReg tmp0) (OpReg dst)) `appOL` + toOL [ PINSR II32 fmt (ImmInt i) (OpReg tmp) dst + | (i, tmp) <- zip [1..] tmps + ] + return (Any fmt code) + where fmt = VecFormat 8 FmtInt16 + vector_shuffle_int16x8 _ _ _ is = pprPanic "vector shuffle: wrong number of indices (expected 8)" (ppr is) + + vector_shuffle_int32x4 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int32x4 sse4_1 v1 v2 is + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = do + let -- `pshufd imm src dst` is equivalent to `PSHUFD fmt (ImmInt imm) (OpReg src) dst` + pshufd 0b11_10_01_00 src dst + | src == dst = nilOL + | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst)) + pshufd imm src dst = unitOL (PSHUFD fmt (ImmInt imm) (OpReg src) dst) + + -- PSHUFD (composeImm imm1 imm2) src dst == (PSHUFD imm1 src tmp; PSHUFD imm2 tmp dst) + composeMask :: Int -> Int -> Int + composeMask imm1 imm2 = foldr (\i acc -> let j = (imm2 `shiftR` (2 * i)) .&. 3 + in (imm1 `shiftR` (2 * j) .&. 3) .|. (acc `shiftL` 2) + ) 0 [0..3] + + makeMask :: [(Int, Int)] -- List of (dst,src). If src == -1, the value there can be anything. + -> Int + makeMask m = foldl' (.|.) 0 [ src `shiftL` (2 * dst) | dst <- [0..3], let src = fromMaybe dst (mfilter (>= 0) $ lookup dst m) ] + + twoAndTwo p0@(1,_) p1@(3,_) q0@(0,_) q1@(2,_) imm4 v1 v2 = twoAndTwo' q0 q1 p0 p1 imm4 v2 v1 + twoAndTwo p0 p1 q0 q1 imm4 v1 v2 = twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 + twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 = do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + tmp <- getNewRegNat fmt + let (instr, imm1, imm2) = + if all (\(_,i) -> 2 <= i || i == -1) [p0,p1,q0,q1] then + -- The inputs are all from higher lanes + (PUNPCKHDQ, makeMask [(2,snd p0),(3,snd p1)], makeMask [(2,snd q0),(3,snd q1)]) + else + (PUNPCKLDQ, makeMask [(0,snd p0),(1,snd p1)], makeMask [(0,snd q0),(1,snd q1)]) + imm3 = makeMask [(fst p0,0),(fst q0,1),(fst p1,2),(fst q1,3)] + code dst = exp1 `appOL` exp2 `appOL` + pshufd imm2 r2 tmp `appOL` -- tmp <- (*,*,r2[snd q0],r2[snd q1]) or (r2[snd q0],r2[snd q1],*,*) + pshufd imm1 r1 dst `snocOL` -- dst <- (*,*,r1[snd p0],r1[snd p1]) or (r1[snd p0],r1[snd p1],*,*) + instr fmt (OpReg tmp) dst `appOL` -- dst <- (dst[0],tmp[0],dst[1],tmp[1]) = (r1[snd p0],r2[snd q0],r1[snd p1],r2[snd q1]) + pshufd (composeMask imm3 imm4) dst dst -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst q1]) <- dst + return $ Any fmt code + + threeAndOne p0 p1 p2 q0 + | snd p0 == snd p1 = twoAndTwo p0 p2 q0 (fst p1,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p0),(fst p2,fst p2),(fst q0,fst q0)]) + | snd p0 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p0),(fst q0,fst q0)]) + | snd p1 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p1),(fst q0,fst q0)]) + | otherwise = \v1 v2 -> do + (r1, exp1) <- getSomeReg v1 + (r2, exp2) <- getSomeReg v2 + tmp1 <- getNewRegNat fmt + if sse4_1 + then do + let imm1 = makeMask [p0,p1,p2] + imm2 = makeMask [q0] + imm3 = foldl' (.|.) 0 [ (if i == fst q0 then 0 else 3) `shiftL` (2 * i) | i <- [0..3] ] + let code dst = exp1 `appOL` exp2 `appOL` + pshufd imm1 r1 tmp1 `appOL` + pshufd imm2 r2 dst `snocOL` + PBLENDW fmt (ImmInt imm3) (OpReg tmp1) dst + return $ Any fmt code + else do + tmp2 <- getNewRegNat fmt + tmp3 <- getNewRegNat fmt + let imm1 = snd q0 .|. 0b11_10_01_00 + imm2 = snd p1 .|. 0b11_10_01_00 + imm3 = snd p0 .|. (snd p2 `shiftL` 2) .|. 0b11_10_00_00 + imm6 = makeMask [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)] + code dst = exp1 `appOL` exp2 `appOL` + pshufd imm1 r2 tmp1 `appOL` -- tmp1 <- (y0,*,*,*) + pshufd imm2 r1 tmp2 `appOL` -- tmp2 <- (x1,*,*,*) + pshufd imm3 r1 tmp3 `snocOL` -- tmp3 <- (x0,x2,*,*) + PUNPCKLDQ fmt (OpReg tmp2) tmp1 `snocOL` -- tmp1 <- unpckldq tmp1 tmp2 = (y0,x1,*,*) + PUNPCKLDQ fmt (OpReg tmp3) tmp1 `appOL` -- tmp1 <- unpckldq tmp1 tmp3 = (y0,x0,x1,x2) + pshufd imm6 tmp1 dst -- dst <- shuffle tmp1 + return $ Any fmt code + + let (from_first, from_second) = partition (\(_dstPos,srcPos) -> srcPos < 4) (zip [0..] is) + case (from_first, map (\(dstPos,srcPos) -> (dstPos, srcPos - 4)) from_second) of + ([p0,p1,p2,p3], []) -> do + (r, exp) <- getSomeReg v1 + let imm = makeMask [p0,p1,p2,p3] + code dst = exp `appOL` pshufd imm r dst + return $ Any fmt code + + ([], [q0,q1,q2,q3]) -> do + (r, exp) <- getSomeReg v2 + let imm = makeMask [q0,q1,q2,q3] + code dst = exp `appOL` pshufd imm r dst + return $ Any fmt code + + ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 0b11_10_01_00 v1 v2 + ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1 + ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2 + + _ -> pprPanic "vector shuffle: cannot occur" (ppr is) + where fmt = VecFormat 4 FmtInt32 + + vector_shuffle_int64x2 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register + vector_shuffle_int64x2 sse4_1 v1 v2 is + | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase + | otherwise = case is of + -- PUNPCKLQDQ / PUNPCKHQDQ + [i, i'] | i == i' -> do + exp <- getAnyReg $ if i < 2 then v1 else v2 + let instr = if i == 0 || i == 2 + then PUNPCKLQDQ + else PUNPCKHQDQ + code dst = exp dst `snocOL` + (instr fmt (OpReg dst) dst) + return $ Any fmt code + [0, 2] -> vector_op_sse PUNPCKLQDQ fmt v1 v2 + [2, 0] -> vector_op_sse PUNPCKLQDQ fmt v2 v1 + [1, 3] -> vector_op_sse PUNPCKHQDQ fmt v1 v2 + [3, 1] -> vector_op_sse PUNPCKHQDQ fmt v2 v1 + + -- PSHUFD + [1, 0] -> do + (r1, exp1) <- getSomeReg v1 + let code dst = exp1 `snocOL` + (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r1) dst) + return $ Any fmt code + [3, 2] -> do + (r2, exp2) <- getSomeReg v2 + let code dst = exp2 `snocOL` + (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r2) dst) + return $ Any fmt code + + -- Others: + -- If SSE4.1 is available, use PBLENDW (see vector_shuffle_int128_common). + -- Otherwise, we resort to SHUFPD. + [0, 3] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v1 v2 + [2, 1] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v2 v1 + + -- [0, 1], [2, 3], [1, 2], [3, 0] are covered by the common cases + + -- Indices are checked in vector_shuffle_int128_common, so the following line should be unreachable: + _ -> pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is) + where fmt = VecFormat 2 FmtInt64 + doubleFormat = VecFormat 2 FmtDouble + + +getRegister' platform _is32Bit (CmmMachOp mop [x, y, z]) = do -- ternary MachOps + avx <- avxEnabled + sse4_1 <- sse4_1Enabled + case mop of + -- Floating point fused multiply-add operations @ ± x*y ± z@ + MO_FMA var l w + | l * widthInBits w > 256 + -> sorry "Please use -fllvm for wide vector FMA support" + | otherwise + -> genFMA3Code l w var x y z + + -- Ternary vector operations + MO_VF_Insert l W32 | l == 4 -> vector_floatx4_insert_sse sse4_1 x y z + | otherwise -> + sorry $ "FloatX" ++ show l ++ "# insert operations require -fllvm" + -- SIMD NCG TODO: + -- + -- - add support for FloatX8, FloatX16. + MO_VF_Insert l W64 -> vector_double_insert avx l x y z + MO_V_Insert 16 W8 | sse4_1 -> vector_int_insert_pinsr 16 W8 x y z + | otherwise -> vector_int8x16_insert_sse2 x y z + MO_V_Insert 8 W16 -> vector_int_insert_pinsr 8 W16 x y z -- PINSRW (SSE2) + MO_V_Insert 4 W32 | sse4_1 -> vector_int_insert_pinsr 4 W32 x y z + | otherwise -> vector_int32x4_insert_sse2 x y z + MO_V_Insert 2 W64 | sse4_1 -> vector_int_insert_pinsr 2 W64 x y z + | otherwise -> vector_int64x2_insert_sse2 x y z + MO_V_Insert _ _ -> sorry "Unsupported integer vector insert operation; please use -fllvm" + + _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)" + (pprMachOp mop) + + where + -- SIMD NCG TODO: + -- + -- - add support for FloatX8, FloatX16. + vector_floatx4_insert_sse :: Bool + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_floatx4_insert_sse sse4_1 vecExpr valExpr (CmmLit (CmmInt offset _)) + | sse4_1 = do + (r, exp) <- getNonClobberedReg valExpr + fn <- getAnyReg vecExpr + let fmt = VecFormat 4 FmtFloat + imm = litToImm (CmmInt (offset `shiftL` 4) W32) + code dst = exp `appOL` + (fn dst) `snocOL` + (INSERTPS fmt imm (OpReg r) dst) + in return $ Any fmt code + | otherwise = do -- SSE <= 3 + (r, exp) <- getNonClobberedReg valExpr + fn <- getAnyReg vecExpr + let fmt = VecFormat 4 FmtFloat + tmp <- getNewRegNat fmt + let code dst + = case offset of + 0 -> exp `appOL` + (fn dst) `snocOL` + -- The following MOV compiles to MOVSS instruction and merges two vectors + (MOV fmt (OpReg r) (OpReg dst)) -- dst <- (r[0],dst[1],dst[2],dst[3]) + 1 -> exp `appOL` + (fn dst) `snocOL` + (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL` -- tmp <- dst + (UNPCKL fmt (OpReg r) dst) `snocOL` -- dst <- (dst[0],r[0],dst[1],r[1]) + (SHUF fmt (ImmInt 0xe4) (OpReg tmp) dst) -- dst <- (dst[0],dst[1],tmp[2],tmp[3]) + 2 -> exp `appOL` + (fn dst) `snocOL` + (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL` -- tmp <- dst + (MOV fmt (OpReg r) (OpReg tmp)) `snocOL` -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS + (SHUF fmt (ImmInt 0xc4) (OpReg tmp) dst) -- dst <- (dst[0],dst[1],tmp[0],tmp[3]) + 3 -> exp `appOL` + (fn dst) `snocOL` + (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL` -- tmp <- dst + (MOV fmt (OpReg r) (OpReg tmp)) `snocOL` -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS + (SHUF fmt (ImmInt 0x24) (OpReg tmp) dst) -- dst <- (dst[0],dst[1],tmp[2],tmp[0]) + _ -> panic "MO_VF_Insert FloatX4: unsupported offset" + in return $ Any fmt code + vector_floatx4_insert_sse _ _ _ offset + = pprPanic "Unsupported vector insert operation" $ + vcat + [ text "FloatX4#" + , text "offset:" <+> pdoc platform offset ] + + + -- SIMD NCG TODO: + -- + -- - add support for DoubleX4#, DoubleX8#. + vector_double_insert :: Bool + -> Length + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + -- DoubleX2 + vector_double_insert avx len@2 vecExpr valExpr (CmmLit offset) + = do + (valReg, valExp) <- getNonClobberedReg valExpr + (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction + let movu = if avx then VMOVU else MOVU + fmt = VecFormat len FmtDouble + code dst + = case offset of + CmmInt 0 _ -> valExp `appOL` + vecExp `snocOL` + (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL` + -- The following MOV compiles to MOVSD instruction and merges two vectors + (MOV (VecFormat 2 FmtDouble) (OpReg valReg) (OpReg dst)) + CmmInt 1 _ -> valExp `appOL` + vecExp `snocOL` + (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL` + (SHUF fmt (ImmInt 0b00) (OpReg valReg) dst) + _ -> pprPanic "MO_VF_Insert DoubleX2: unsupported offset" (ppr offset) + in return $ Any fmt code + vector_double_insert _ _ _ _ _ = + sorry "Unsupported floating-point vector insert operation; please use -fllvm" + -- For DoubleX4: use VSHUFPD. + -- For DoubleX8: use something like vinsertf64x2 followed by vpblendd? + + -- SIMD NCG TODO: + -- + -- - only supports 128-bit vector types (Int64X2, Int32X4, Int16X8, Int8X16), + -- add support for 256-bit and 512-bit vector types. + + -- PINSRW is an SSE2 instruction, whereas PINSR{B,D,Q} require SSE4.1. + vector_int_insert_pinsr :: HasCallStack => Length + -> Width + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int_insert_pinsr len w vecExpr valExpr (CmmLit (CmmInt offset _)) + | 0 <= offset, offset < toInteger len + = do + (valReg, valExp) <- getNonClobberedReg valExpr + vecCode <- getAnyReg vecExpr + let (scalarFormat, vectorFormat) = case w of + W8 -> (II32, VecFormat len FmtInt8) + W16 -> (II32, VecFormat len FmtInt16) + W32 -> (II32, VecFormat len FmtInt32) + W64 -> (II64, VecFormat len FmtInt64) + _ -> sorry "Unsupported vector format" + code dst = valExp `appOL` + (vecCode dst) `snocOL` + (PINSR scalarFormat vectorFormat (ImmInteger offset) (OpReg valReg) dst) + return $ Any vectorFormat code + vector_int_insert_pinsr _ _ _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset) + + vector_int8x16_insert_sse2 :: CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int8x16_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _)) + | 0 <= offset, offset < 16 + = do + (valReg, valExp) <- getNonClobberedReg valExpr + vecCode <- getAnyReg vecExpr + tmp <- getNewRegNat II32 + let vectorFormat = VecFormat 16 FmtInt8 + code dst + = case offset `quotRem` 2 of + (j, 0) -> valExp `appOL` + (vecCode dst) `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW + (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) `snocOL` + (MOVZxL II8 (OpReg valReg) (OpReg valReg)) `snocOL` + (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL` + (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW + (j, _) -> valExp `appOL` + (vecCode dst) `snocOL` + (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW + (MOVZxL II8 (OpReg tmp) (OpReg tmp)) `snocOL` + (SHL II32 (OpImm (ImmInt 8)) (OpReg valReg)) `snocOL` + (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL` + (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW + return $ Any vectorFormat code + vector_int8x16_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset) + + vector_int32x4_insert_sse2 :: CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int32x4_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _)) + | 0 <= offset, offset < 4 + = do + (valReg, valExp) <- getNonClobberedReg valExpr + vecCode <- getAnyReg vecExpr + -- Since SSE2 does not have an integer vector instruction to achieve this, + -- we are forced to either use floating-point vector instructions + -- or lots of integer vector instructions. (sigh) + let floatVectorFormat = VecFormat 4 FmtFloat + tmp1 <- getNewRegNat floatVectorFormat + tmp2 <- getNewRegNat floatVectorFormat + let vectorFormat = VecFormat 4 FmtInt32 + code dst + = case offset of + 0 -> valExp `appOL` + (vecCode dst) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` + (MOV floatVectorFormat (OpReg tmp1) (OpReg dst)) -- MOVSS; dst <- (tmp1[0],dst[1],dst[2],dst[3]) + 1 -> valExp `appOL` + (vecCode tmp1) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg dst)) `snocOL` -- dst <- (val,0,0,0) + (PUNPCKLQDQ vectorFormat (OpReg tmp1) dst) `snocOL` -- dst <- (dst[0],dst[1],tmp1[0],tmp1[1]) + (SHUF floatVectorFormat (ImmInt 0b11_10_00_10) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[2],dst[0],tmp1[2],tmp1[3]) + 2 -> valExp `appOL` + (vecCode dst) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0) + (MOVU floatVectorFormat (OpReg dst) (OpReg tmp2)) `snocOL` -- MOVUPS; tmp2 <- dst + (SHUF floatVectorFormat (ImmInt 0b01_00_01_11) (OpReg tmp1) tmp2) `snocOL` -- SHUFPS; tmp2 <- (tmp2[3],tmp2[1],tmp1[0],tmp1[1]) + (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp2) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp2[2],tmp2[0]) + _ -> valExp `appOL` + (vecCode dst) `snocOL` + (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0) + (SHUF floatVectorFormat (ImmInt 0b11_10_01_00) (OpReg dst) tmp1) `snocOL` -- SHUFPS; tmp1 <- (tmp1[0],tmp1[1],dst[2],dst[3]) + (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp1[2],tmp1[0]) + return $ Any vectorFormat code + vector_int32x4_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset) + + vector_int64x2_insert_sse2 :: CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register + vector_int64x2_insert_sse2 vecExpr valExpr (CmmLit offset) + = do + (valReg, valExp) <- getNonClobberedReg valExpr + (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction + let fmt = VecFormat 2 FmtInt64 + tmp <- getNewRegNat fmt + let code dst + = case offset of + CmmInt 0 _ -> valExp `appOL` + vecExp `snocOL` + (MOVHLPS FF64 vecReg tmp) `snocOL` + (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL` + (PUNPCKLQDQ fmt (OpReg tmp) dst) + CmmInt 1 _ -> valExp `appOL` + vecExp `snocOL` + (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL` + (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL` + (PUNPCKLQDQ fmt (OpReg tmp) dst) + _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset) + in return $ Any fmt code + vector_int64x2_insert_sse2 _ _ offset = pprPanic "MO_V_Insert Int64X2: unsupported offset" (pdoc platform offset) + +getRegister' _ _ (CmmMachOp mop (_:_:_:_:_)) = + pprPanic "getRegister(x86): MachOp with >= 4 arguments" (text $ show mop) + +getRegister' platform is32Bit load@(CmmLoad mem ty _) + | isVecType ty + = do + config <- getConfig + Amode addr mem_code <- getAmode mem + let code dst = + mem_code `snocOL` + movInstr config format (OpAddr addr) (OpReg dst) + return (Any format code) + | isFloatType ty + = do + Amode addr mem_code <- getAmode mem + loadAmode (floatFormat width) addr mem_code + + | is32Bit && not (isWord64 ty) + = do + let + instr = case width of + W8 -> MOVZxL II8 + -- We always zero-extend 8-bit loads, if we + -- can't think of anything better. This is because + -- we can't guarantee access to an 8-bit variant of every register + -- (esi and edi don't have 8-bit variants), so to make things + -- simpler we do our 8-bit arithmetic with full 32-bit registers. + _other -> MOV format + code <- intLoadCode instr mem + return (Any format code) + + | not is32Bit + -- Simpler memory load code on x86_64 + = do + code <- intLoadCode (MOV format) mem + return (Any format code) + + | otherwise + = pprPanic "getRegister(x86) CmmLoad" (pdoc platform load) + where + format = cmmTypeFormat ty + width = typeWidth ty + +-- Handle symbol references with LEA and %rip-relative addressing. +-- See Note [%rip-relative addressing on x86-64]. +getRegister' platform is32Bit (CmmLit lit) + | is_label lit + , not is32Bit + = do let format = cmmTypeFormat (cmmLitType platform lit) + imm = litToImm lit + op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm) + code dst = unitOL (LEA format op (OpReg dst)) + return (Any format code) + where + is_label (CmmLabel {}) = True + is_label (CmmLabelOff {}) = True + is_label (CmmLabelDiffOff {}) = True + is_label _ = False + +getRegister' platform is32Bit (CmmLit lit) = do + avx <- avxEnabled + + -- NB: it is important that the code produced here (to load a literal into + -- a register) doesn't clobber any registers other than the destination + -- register; the code for generating C calls relies on this property. + -- + -- In particular, we have: + -- + -- > loadIntoRegMightClobberOtherReg (CmmLit _) = False + -- + -- which means that we assume that loading a literal into a register + -- will not clobber any other registers. + + -- TODO: this function mishandles floating-point negative zero, + -- because -0.0 == 0.0 returns True and because we represent CmmFloat as + -- Rational, which can't properly represent negative zero. + + if + -- Zero: use XOR. + | isZeroLit lit + -> let code dst + | isIntFormat fmt + = let fmt' + | is32Bit + = fmt + | otherwise + -- x86_64: 32-bit xor is one byte shorter, + -- and zero-extends to 64 bits + = case fmt of + II64 -> II32 + _ -> fmt + in unitOL (XOR fmt' (OpReg dst) (OpReg dst)) + | avx + = if float_or_floatvec + then unitOL (VXOR fmt (OpReg dst) dst dst) + else unitOL (VPXOR fmt dst dst dst) + | otherwise + = if float_or_floatvec + then unitOL (XOR fmt (OpReg dst) (OpReg dst)) + else unitOL (PXOR fmt (OpReg dst) dst) + in return $ Any fmt code + + -- Constant vector: use broadcast. + | VecFormat l sFmt <- fmt + , CmmVec (f:fs) <- lit + , all (== f) fs + -> do let w = scalarWidth sFmt + broadcast = if isFloatScalarFormat sFmt + then MO_VF_Broadcast l w + else MO_V_Broadcast l w + valCode <- getAnyReg (CmmMachOp broadcast [CmmLit f]) + return $ Any fmt valCode + + -- Optimisation for loading small literals on x86_64: take advantage + -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit + -- instruction forms are shorter. + | not is32Bit, isWord64 cmmTy, not (isBigLit lit) + -> let + imm = litToImm lit + code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) + in + return (Any II64 code) + + -- Scalar integer: use an immediate. + | isIntFormat fmt + -> let imm = litToImm lit + code dst = unitOL (MOV fmt (OpImm imm) (OpReg dst)) + in return (Any fmt code) + + -- General case: load literal from data address. + | otherwise + -> do let w = formatToWidth fmt + Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes w) lit + loadAmode fmt addr addr_code + + where + cmmTy = cmmLitType platform lit + fmt = cmmTypeFormat cmmTy + float_or_floatvec = isFloatOrFloatVecFormat fmt + isZeroLit (CmmInt i _) = i == 0 + isZeroLit (CmmFloat f _) = f == 0 -- TODO: mishandles negative zero + isZeroLit (CmmVec fs) = all isZeroLit fs + isZeroLit _ = False + + isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff + isBigLit _ = False + -- note1: not the same as (not.is32BitLit), because that checks for + -- signed literals that fit in 32 bits, but we want unsigned + -- literals here. + -- note2: all labels are small, because we're assuming the + -- small memory model. See Note [%rip-relative addressing on x86-64]. + +getRegister' platform _ slot@(CmmStackSlot {}) = + pprPanic "getRegister(x86) CmmStackSlot" (pdoc platform slot) + +intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr + -> NatM (Reg -> InstrBlock) +intLoadCode instr mem = do + Amode src mem_code <- getAmode mem + return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst)) + +-- Compute an expression into *any* register, adding the appropriate +-- move instruction if necessary. +getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock) +getAnyReg expr = do + r <- getRegister expr + anyReg r + +anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock) +anyReg (Any _ code) = return code +anyReg (Fixed rep reg fcode) = do + config <- getConfig + return (\dst -> fcode `snocOL` mkRegRegMoveInstr config rep reg dst) + +-- A bit like getSomeReg, but we want a reg that can be byte-addressed. +-- Fixed registers might not be byte-addressable, so we make sure we've +-- got a temporary, inserting an extra reg copy if necessary. +getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock) +getByteReg expr = do + config <- getConfig + is32Bit <- is32BitPlatform + if is32Bit + then do r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + | isVirtualReg reg -> return (reg,code) + | otherwise -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp) + -- ToDo: could optimise slightly by checking for + -- byte-addressable real registers, but that will + -- happen very rarely if at all. + else getSomeReg expr -- all regs are byte-addressable on x86_64 + +-- Another variant: this time we want the result in a register that cannot +-- be modified by code to evaluate an arbitrary expression. +getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock) +getNonClobberedReg expr = do + r <- getRegister expr + config <- getConfig + let platform = ncgPlatform config + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + -- only certain regs can be clobbered + | reg `elem` instrClobberedRegs platform + -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp) + | otherwise -> + return (reg, code) + +-------------------------------------------------------------------------------- + +-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'. +-- +-- An 'Amode' is a datatype representing a valid address form for the target +-- (e.g. "Base + Index + disp" or immediate) and the code to compute it. +getAmode :: CmmExpr -> NatM Amode +getAmode e = do + platform <- getPlatform + let is32Bit = target32Bit platform + + case e of + CmmRegOff r n + -> getAmode $ mangleIndexTree r n + + CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement] + | not is32Bit + -> return $ Amode (ripRel (litToImm displacement)) nilOL + + -- This is all just ridiculous, since it carefully undoes + -- what mangleIndexTree has just done. + CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)] + | is32BitLit platform lit + -- assert (rep == II32)??? + -> do + (x_reg, x_code) <- getSomeReg x + let off = ImmInt (-(fromInteger i)) + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + + CmmMachOp (MO_Add _rep) [x, CmmLit lit] + | is32BitLit platform lit + -- assert (rep == II32)??? + -> do + (x_reg, x_code) <- getSomeReg x + let off = litToImm lit + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) + + -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be + -- recognised by the next rule. + CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)] + -> getAmode (CmmMachOp (MO_Add rep) [b,a]) + + -- Matches: (x + offset) + (y << shift) + CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset) + + CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + -> x86_complex_amode x y shift 0 + + CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]] + | shift == 0 || shift == 1 || shift == 2 || shift == 3 + && is32BitInteger offset + -> x86_complex_amode x y shift offset + + CmmMachOp (MO_Add _) [x,y] + | not (isLit y) -- we already handle valid literals above. + -> x86_complex_amode x y 0 0 + + CmmLit lit@(CmmFloat {}) + -> pprPanic "X86 CodeGen: attempt to use floating-point value as a memory address" + (ppr lit) + + -- Handle labels with %rip-relative addressing since in general the image + -- may be loaded anywhere in the 64-bit address space (e.g. on Windows + -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64]. + CmmLit lit + | not is32Bit + , is_label lit + -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL) + + CmmLit lit + | is32BitLit platform lit + -> return (Amode (ImmAddr (litToImm lit) 0) nilOL) + + -- Literal with offsets too big (> 32 bits) fails during the linking phase + -- (#15570). We already handled valid literals above so we don't have to + -- test anything here. + CmmLit (CmmLabelOff l off) + -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l) + , CmmLit (CmmInt (fromIntegral off) W64) + ]) + CmmLit (CmmLabelDiffOff l1 l2 off w) + -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w) + , CmmLit (CmmInt (fromIntegral off) W64) + ]) + + -- in case we can't do something better, we just compute the expression + -- and put the result in a register + _ -> do + (reg,code) <- getSomeReg e + return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) + where + is_label (CmmLabel{}) = True + is_label (CmmLabelOff{}) = True + is_label (CmmLabelDiffOff{}) = True + is_label _ = False + + +-- | Like 'getAmode', but on 32-bit use simple register addressing +-- (i.e. no index register). This stops us from running out of +-- registers on x86 when using instructions such as cmpxchg, which can +-- use up to three virtual registers and one fixed register. +getSimpleAmode :: CmmExpr -> NatM Amode +getSimpleAmode addr = is32BitPlatform >>= \case + False -> getAmode addr + True -> do + addr_code <- getAnyReg addr + config <- getConfig + addr_r <- getNewRegNat (intFormat (ncgWordWidth config)) + let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0) + return $! Amode amode (addr_code addr_r) + +x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode +x86_complex_amode base index shift offset + = do (x_reg, x_code) <- getNonClobberedReg base + -- x must be in a temp, because it has to stay live over y_code + -- we could compare x_reg and y_reg and do something better here... + (y_reg, y_code) <- getSomeReg index + let + code = x_code `appOL` y_code + base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; + n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" + return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) + code) + + + + +-- ----------------------------------------------------------------------------- +-- getOperand: sometimes any operand will do. + +-- getNonClobberedOperand: the value of the operand will remain valid across +-- the computation of an arbitrary expression, unless the expression +-- is computed directly into a register which the operand refers to +-- (see trivialCode where this function is used for an example). + +getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand (CmmLit lit) + | Just w <- isSuitableFloatingPointLit_maybe lit = do + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + | otherwise = do + platform <- getPlatform + if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit)) + then return (OpImm (litToImm lit), nilOL) + else getNonClobberedOperand_generic (CmmLit lit) + +getNonClobberedOperand (CmmLoad mem ty _) = do + is32Bit <- is32BitPlatform + -- this logic could be simplified + -- TODO FIXME + if (if is32Bit then not (isWord64 ty) else True) + -- if 32bit and ty is at float/double/simd value + -- or if 64bit + -- this could use some eyeballs or i'll need to stare at it more later + then do + platform <- ncgPlatform <$> getConfig + Amode src mem_code <- getAmode mem + (src',save_code) <- + if (amodeCouldBeClobbered platform src) + then do + tmp <- getNewRegNat (archWordFormat is32Bit) + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), + unitOL (LEA (archWordFormat is32Bit) + (OpAddr src) + (OpReg tmp))) + else + return (src, nilOL) + return (OpAddr src', mem_code `appOL` save_code) + else + -- if its a word or gcptr on 32bit? + getNonClobberedOperand_generic (CmmLoad mem ty NaturallyAligned) + +getNonClobberedOperand e = getNonClobberedOperand_generic e + +getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getNonClobberedOperand_generic e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +amodeCouldBeClobbered :: Platform -> AddrMode -> Bool +amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode) + +regClobbered :: Platform -> Reg -> Bool +regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr +regClobbered _ _ = False + +-- getOperand: the operand is not required to remain valid across the +-- computation of an arbitrary expression. +getOperand :: CmmExpr -> NatM (Operand, InstrBlock) + +getOperand (CmmLit lit) = case isSuitableFloatingPointLit_maybe lit of + Just w -> do + Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit + return (OpAddr addr, code) + Nothing -> do + platform <- getPlatform + if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit)) + then return (OpImm (litToImm lit), nilOL) + else getOperand_generic (CmmLit lit) + +getOperand (CmmLoad mem ty _) = do + is32Bit <- is32BitPlatform + if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else + getOperand_generic (CmmLoad mem ty NaturallyAligned) + +getOperand e = getOperand_generic e + +getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) +getOperand_generic e = do + (reg, code) <- getSomeReg e + return (OpReg reg, code) + +isOperand :: Platform -> CmmExpr -> Bool +isOperand _ (CmmLoad _ _ _) = True +isOperand platform (CmmLit lit) + = is32BitLit platform lit + || isSuitableFloatingPointLit lit +isOperand _ _ = False + +-- | Given a 'Register', produce a new 'Register' with an instruction block +-- which will check the value for alignment. Used for @-falignment-sanitisation@. +addAlignmentCheck :: Int -> Register -> Register +addAlignmentCheck align reg = + case reg of + Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg) + Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt reg) + where + check :: Format -> Reg -> InstrBlock + check fmt reg = + assert (isIntFormat fmt) $ + toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg) + , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel + ] + +memConstant :: Alignment -> CmmLit -> NatM Amode +memConstant align lit = do + lbl <- getNewLabelNat + let rosection = Section ReadOnlyData lbl + config <- getConfig + platform <- getPlatform + (addr, addr_code) <- if target32Bit platform + then do dynRef <- cmmMakeDynamicReference + config + DataReference + lbl + Amode addr addr_code <- getAmode dynRef + return (addr, addr_code) + else return (ripRel (ImmCLbl lbl), nilOL) + let code = + LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit]) + `consOL` addr_code + return (Amode addr code) + +-- | Load the value at the given address into any register. +loadAmode :: Format -> AddrMode -> InstrBlock -> NatM Register +loadAmode fmt addr addr_code = do + config <- getConfig + let load dst = movInstr config fmt (OpAddr addr) (OpReg dst) + return $ Any fmt (\ dst -> addr_code `snocOL` load dst) + +-- if we want a floating-point literal as an operand, we can +-- use it directly from memory. However, if the literal is +-- zero, we're better off generating it into a register using +-- xor. +isSuitableFloatingPointLit :: CmmLit -> Bool +isSuitableFloatingPointLit = isJust . isSuitableFloatingPointLit_maybe + +isSuitableFloatingPointLit_maybe :: CmmLit -> Maybe Width +isSuitableFloatingPointLit_maybe (CmmFloat f w) = w <$ guard (f /= 0.0) +isSuitableFloatingPointLit_maybe _ = Nothing + +getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) +getRegOrMem e@(CmmLoad mem ty _) = do + is32Bit <- is32BitPlatform + if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True) + then do + Amode src mem_code <- getAmode mem + return (OpAddr src, mem_code) + else do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) +getRegOrMem e = do + (reg, code) <- getNonClobberedReg e + return (OpReg reg, code) + +is32BitLit :: Platform -> CmmLit -> Bool +is32BitLit platform _lit + | target32Bit platform = True +is32BitLit platform lit = + case lit of + CmmInt i W64 -> is32BitInteger i + -- Except on Windows, assume that labels are in the range 0-2^31-1: this + -- assumes the small memory model. Note [%rip-relative addressing on + -- x86-64]. + CmmLabel _ -> low_image + -- however we can't assume that label offsets are in this range + -- (see #15570) + CmmLabelOff _ off -> low_image && is32BitInteger (fromIntegral off) + CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off) + _ -> True + where + -- Is the executable image certain to be located below 4GB? As noted in + -- Note [%rip-relative addressing on x86-64], this is not true on Windows. + low_image = + case platformOS platform of + OSMinGW32 -> False -- See Note [%rip-relative addressing on x86-64] + _ -> True + + +-- Set up a condition code for a conditional branch. + +getCondCode :: CmmExpr -> NatM CondCode + +-- yes, they really do seem to want exactly the same! + +getCondCode (CmmMachOp mop [x, y]) + = + case mop of + MO_F_Eq W32 -> condFltCode EQQ x y + MO_F_Ne W32 -> condFltCode NE x y + MO_F_Gt W32 -> condFltCode GTT x y + MO_F_Ge W32 -> condFltCode GE x y + -- Invert comparison condition and swap operands + -- See Note [SSE Parity Checks] + MO_F_Lt W32 -> condFltCode GTT y x + MO_F_Le W32 -> condFltCode GE y x + + MO_F_Eq W64 -> condFltCode EQQ x y + MO_F_Ne W64 -> condFltCode NE x y + MO_F_Gt W64 -> condFltCode GTT x y + MO_F_Ge W64 -> condFltCode GE x y + MO_F_Lt W64 -> condFltCode GTT y x + MO_F_Le W64 -> condFltCode GE y x + + _ -> condIntCode (machOpToCond mop) x y + +getCondCode other = do + platform <- getPlatform + pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other) + +machOpToCond :: MachOp -> Cond +machOpToCond mo = case mo of + MO_Eq _ -> EQQ + MO_Ne _ -> NE + MO_S_Gt _ -> GTT + MO_S_Ge _ -> GE + MO_S_Lt _ -> LTT + MO_S_Le _ -> LE + MO_U_Gt _ -> GU + MO_U_Ge _ -> GEU + MO_U_Lt _ -> LU + MO_U_Le _ -> LEU + _other -> pprPanic "machOpToCond" (pprMachOp mo) + +{- Note [64-bit integer comparisons on 32-bit] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + When doing these comparisons there are 2 kinds of + comparisons. + + * Comparison for equality (or lack thereof) + + We use xor to check if high/low bits are + equal. Then combine the results using or. + + * Other comparisons: + + We first compare the low registers + and use a subtraction with borrow to compare the high registers. + + For signed numbers the condition is determined by + the sign and overflow flags agreeing or not + and for unsigned numbers the condition is the carry flag. + +-} + +-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be +-- passed back up the tree. + +condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode +condIntCode cond x y = do platform <- getPlatform + condIntCode' platform cond x y + +condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +-- 64-bit integer comparisons on 32-bit +-- See Note [64-bit integer comparisons on 32-bit] +condIntCode' platform cond x y + | target32Bit platform && isWord64 (cmmExprType platform x) = do + + RegCode64 code1 r1hi r1lo <- iselExpr64 x + RegCode64 code2 r2hi r2lo <- iselExpr64 y + + -- we mustn't clobber r1/r2 so we use temporaries + tmp1 <- getNewRegNat II32 + tmp2 <- getNewRegNat II32 + + let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2 + return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode) + + where + intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 = + case cond of + -- These don't occur as argument of condIntCode' + ALWAYS -> panic "impossible" + NEG -> panic "impossible" + POS -> panic "impossible" + CARRY -> panic "impossible" + OFLO -> panic "impossible" + PARITY -> panic "impossible" + NOTPARITY -> panic "impossible" + -- Special case #1 x == y and x != y + EQQ -> (EQQ, cmpExact) + NE -> (NE, cmpExact) + -- [x >= y] + GE -> (GE, cmpGE) + GEU -> (GEU, cmpGE) + -- [x > y] + GTT -> (LTT, cmpLE) + GU -> (LU, cmpLE) + -- [x <= y] + LE -> (GE, cmpLE) + LEU -> (GEU, cmpLE) + -- [x < y] + LTT -> (LTT, cmpGE) + LU -> (LU, cmpGE) + where + cmpExact :: OrdList Instr + cmpExact = + toOL + [ MOV II32 (OpReg r1_hi) (OpReg tmp1) + , MOV II32 (OpReg r1_lo) (OpReg tmp2) + , XOR II32 (OpReg r2_hi) (OpReg tmp1) + , XOR II32 (OpReg r2_lo) (OpReg tmp2) + , OR II32 (OpReg tmp1) (OpReg tmp2) + ] + cmpGE = toOL + [ MOV II32 (OpReg r1_hi) (OpReg tmp1) + , CMP II32 (OpReg r2_lo) (OpReg r1_lo) + , SBB II32 (OpReg r2_hi) (OpReg tmp1) + ] + cmpLE = toOL + [ MOV II32 (OpReg r2_hi) (OpReg tmp1) + , CMP II32 (OpReg r1_lo) (OpReg r2_lo) + , SBB II32 (OpReg r1_hi) (OpReg tmp1) + ] + +-- memory vs immediate +condIntCode' platform cond (CmmLoad x ty _) (CmmLit lit) + | is32BitLit platform lit = do + Amode x_addr x_code <- getAmode x + let + imm = litToImm lit + code = x_code `snocOL` + CMP (cmmTypeFormat ty) (OpImm imm) (OpAddr x_addr) + -- + return (CondCode False cond code) + +-- anything vs zero, using a mask +-- TODO: Add some sanity checking!!!! +condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 ty)) + | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit + = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intFormat ty) (OpImm (ImmInteger mask)) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs zero +condIntCode' _ cond x (CmmLit (CmmInt 0 ty)) = do + (x_reg, x_code) <- getSomeReg x + let + code = x_code `snocOL` + TEST (intFormat ty) (OpReg x_reg) (OpReg x_reg) + -- + return (CondCode False cond code) + +-- anything vs operand +condIntCode' platform cond x y + | isOperand platform y = do + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` y_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg) + return (CondCode False cond code) +-- operand vs. anything: invert the comparison so that we can use a +-- single comparison instruction. + | isOperand platform x + , Just revcond <- maybeFlipCond cond = do + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getOperand x + let + code = y_code `appOL` x_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg) + return (CondCode False revcond code) + +-- anything vs anything +condIntCode' platform cond x y = do + (y_reg, y_code) <- getNonClobberedReg y + (x_op, x_code) <- getRegOrMem x + let + code = y_code `appOL` + x_code `snocOL` + CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op + return (CondCode False cond code) + + + +-------------------------------------------------------------------------------- +condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode + +condFltCode cond x y + = condFltCode_sse2 + where + + + -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be + -- an operand, but the right must be a reg. We can probably do better + -- than this general case... + condFltCode_sse2 = do + platform <- getPlatform + (x_reg, x_code) <- getNonClobberedReg x + (y_op, y_code) <- getOperand y + let + code = x_code `appOL` + y_code `snocOL` + CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg) + -- NB(1): we need to use the unsigned comparison operators on the + -- result of this comparison. + return (CondCode True (condToUnsigned cond) code) + +-- ----------------------------------------------------------------------------- +-- Generating assignments + +-- Assignments are really at the heart of the whole code generation +-- business. Almost all top-level nodes of any real importance are +-- assignments, which correspond to loads, stores, or register +-- transfers. If we're really lucky, some of the register transfers +-- will go away, because we can use the destination register to +-- complete the code generation for the right hand side. This only +-- fails when the right hand side is forced into a fixed register +-- (e.g. the result of a call). + +assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_IntCode :: CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_FltCode :: CmmReg -> CmmExpr -> NatM InstrBlock + +assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock +assignReg_VecCode :: CmmReg -> CmmExpr -> NatM InstrBlock + +-- integer assignment to memory + +-- specific case of adding/subtracting an integer to a particular address. +-- ToDo: catch other cases where we can use an operation directly on a memory +-- address. +assignMem_IntCode ty addr (CmmMachOp op [CmmLoad addr2 _ _, + CmmLit (CmmInt i _)]) + | addr == addr2, ty /= II64 || is32BitInteger i, + Just instr <- check op + = do Amode amode code_addr <- getAmode addr + let code = code_addr `snocOL` + instr ty (OpImm (ImmInt (fromIntegral i))) (OpAddr amode) + return code + where + check (MO_Add _) = Just ADD + check (MO_Sub _) = Just SUB + check _ = Nothing + -- ToDo: more? + +-- general case +assignMem_IntCode ty addr src = do + platform <- getPlatform + Amode addr code_addr <- getAmode addr + (code_src, op_src) <- get_op_RI platform src + let + code = code_src `appOL` + code_addr `snocOL` + MOV ty op_src (OpAddr addr) + -- NOTE: op_src is stable, so it will still be valid + -- after code_addr. This may involve the introduction + -- of an extra MOV to a temporary register, but we hope + -- the register allocator will get rid of it. + -- + return code + where + get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand) -- code, operator + get_op_RI platform (CmmLit lit) | is32BitLit platform lit + = return (nilOL, OpImm (litToImm lit)) + get_op_RI _ op + = do (reg,code) <- getNonClobberedReg op + return (code, OpReg reg) + + +-- Assign; dst is a reg, rhs is mem +assignReg_IntCode reg (CmmLoad src _ _) = do + let ty = cmmTypeFormat $ cmmRegType reg + load_code <- intLoadCode (MOV ty) src + platform <- ncgPlatform <$> getConfig + return (load_code (getRegisterReg platform reg)) + +-- dst is a reg, but src could be anything +assignReg_IntCode reg src = do + platform <- ncgPlatform <$> getConfig + code <- getAnyReg src + return (code (getRegisterReg platform reg)) + + +-- Floating point assignment to memory +assignMem_FltCode ty addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + let + code = src_code `appOL` + addr_code `snocOL` + MOV ty (OpReg src_reg) (OpAddr addr) + + return code + +-- Floating point assignment to a register/temporary +assignReg_FltCode reg src = do + src_code <- getAnyReg src + platform <- ncgPlatform <$> getConfig + return (src_code (getRegisterReg platform reg)) + +-- Vector assignment to a register/temporary +assignMem_VecCode ty addr src = do + (src_reg, src_code) <- getNonClobberedReg src + Amode addr addr_code <- getAmode addr + config <- getConfig + let + code = src_code `appOL` + addr_code `snocOL` + movInstr config ty (OpReg src_reg) (OpAddr addr) + return code + +assignReg_VecCode reg src = do + platform <- ncgPlatform <$> getConfig + src_code <- getAnyReg src + return (src_code (getRegisterReg platform reg)) + +genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock + +genJump (CmmLoad mem _ _) regs = do + Amode target code <- getAmode mem + return (code `snocOL` JMP (OpAddr target) regs) + +genJump (CmmLit lit) regs = + return (unitOL (JMP (OpImm (litToImm lit)) regs)) + +genJump expr regs = do + (reg,code) <- getSomeReg expr + return (code `snocOL` JMP (OpReg reg) regs) + + +-- ----------------------------------------------------------------------------- +-- Unconditional branches + +genBranch :: BlockId -> InstrBlock +genBranch = toOL . mkJumpInstr + + + +-- ----------------------------------------------------------------------------- +-- Conditional jumps/branches + +{- +Conditional jumps are always to local labels, so we can use branch +instructions. We peek at the arguments to decide what kind of +comparison to do. + +I386: First, we have to ensure that the condition +codes are set according to the supplied comparison operation. +-} + +genCondBranch + :: BlockId -- the source of the jump + -> BlockId -- the true branch target + -> BlockId -- the false branch target + -> CmmExpr -- the condition on which to branch + -> NatM InstrBlock -- Instructions + +genCondBranch bid id false expr = do + is32Bit <- is32BitPlatform + genCondBranch' is32Bit bid id false expr + +-- | We return the instructions generated. +genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr + -> NatM InstrBlock + +genCondBranch' _ bid id false bool = do + CondCode is_float cond cond_code <- getCondCode bool + if not is_float + then + return (cond_code `snocOL` JXX cond id `appOL` genBranch false) + else do + -- See Note [SSE Parity Checks] + let jmpFalse = genBranch false + code + = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + -- Use ASSERT so we don't break releases if + -- LTT/LE creep in somehow. + LTT -> + assertPpr False (text "Should have been turned into >") + and_ordered + LE -> + assertPpr False (text "Should have been turned into >=") + and_ordered + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) `appOL` jmpFalse + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] `appOL` jmpFalse + and_ordered = toOL [ + JXX PARITY false, + JXX cond id, + JXX ALWAYS false + ] + updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false) + return (cond_code `appOL` code) + +{- Note [Introducing cfg edges inside basic blocks] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + During instruction selection a statement `s` + in a block B with control of the sort: B -> C + will sometimes result in control + flow of the sort: + + ┌ < ┐ + v ^ + B -> B1 ┴ -> C + + as is the case for some atomic operations. + + Now to keep the CFG in sync when introducing B1 we clearly + want to insert it between B and C. However there is + a catch when we have to deal with self loops. + + We might start with code and a CFG of these forms: + + loop: + stmt1 ┌ < ┐ + .... v ^ + stmtX loop ┘ + stmtY + .... + goto loop: + + Now we introduce B1: + ┌ ─ ─ ─ ─ ─┐ + loop: │ ┌ < ┐ │ + instrs v │ │ ^ + .... loop ┴ B1 ┴ ┘ + instrsFromX + stmtY + goto loop: + + This is simple, all outgoing edges from loop now simply + start from B1 instead and the code generator knows which + new edges it introduced for the self loop of B1. + + Disaster strikes if the statement Y follows the same pattern. + If we apply the same rule that all outgoing edges change then + we end up with: + + loop ─> B1 ─> B2 ┬─┐ + │ │ └─<┤ │ + │ └───<───┘ │ + └───────<────────┘ + + This is problematic. The edge B1->B1 is modified as expected. + However the modification is wrong! + + The assembly in this case looked like this: + + _loop: + + _B1: + ... + cmpxchgq ... + jne _B1 + + + _B2: + ... + cmpxchgq ... + jne _B2 + + 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: + + _B1: + ... + cmpxchgq ... + jne _B1 + jmp _B1' + _B1': + + + _B2: + ... + + Now when inserting B2 we will only look at the outgoing edges of B1' and + everything will work out nicely. + + You might also wonder why we don't insert jumps at the end of _B1'. There is + no way another block ends up jumping to the labels _B1 or _B2 since they are + essentially invisible to other blocks. View them as control flow labels local + to the basic block if you'd like. + + Not doing this ultimately caused (part 2 of) #17334. +-} + + +-- ----------------------------------------------------------------------------- +-- Generating C calls + +-- Now the biggest nightmare---calls. Most of the nastiness is buried in +-- @get_arg@, which moves the arguments to the correct registers/stack +-- locations. Apart from that, the code is easy. +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. +-- +-- See Note [Keeping track of the current block] for information why we need +-- to take/return a block id. + +genForeignCall + :: ForeignTarget -- ^ function to call + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> BlockId -- ^ The block we are in + -> NatM (InstrBlock, Maybe BlockId) + +genForeignCall target dst args bid = do + case target of + PrimTarget prim -> genPrim bid prim dst args + ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args + +genPrim + :: BlockId -- ^ The block we are in + -> CallishMachOp -- ^ MachOp + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM (InstrBlock, Maybe BlockId) + +-- First we deal with cases which might introduce new blocks in the stream. +genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n] + = genAtomicRMW bid width amop dst addr n +genPrim bid (MO_Ctz width) [dst] [src] + = genCtz bid width dst src + +-- Then we deal with cases which not introducing new blocks in the stream. +genPrim bid prim dst args + = (,Nothing) <$> genSimplePrim bid prim dst args + +genSimplePrim + :: BlockId -- ^ the block we are in + -> CallishMachOp -- ^ MachOp + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM InstrBlock +genSimplePrim bid (MO_Memcpy align) [] [dst,src,n] = genMemCpy bid align dst src n +genSimplePrim bid (MO_Memmove align) [] [dst,src,n] = genMemMove bid align dst src n +genSimplePrim bid (MO_Memcmp align) [res] [dst,src,n] = genMemCmp bid align res dst src n +genSimplePrim bid (MO_Memset align) [] [dst,c,n] = genMemSet bid align dst c n +genSimplePrim _ MO_AcquireFence [] [] = return nilOL -- barriers compile to no code on x86/x86-64; +genSimplePrim _ MO_ReleaseFence [] [] = return nilOL -- we keep it this long in order to prevent earlier optimisations. +genSimplePrim _ MO_SeqCstFence [] [] = return $ unitOL MFENCE +genSimplePrim _ MO_Touch [] [_] = return nilOL +genSimplePrim _ (MO_Prefetch_Data n) [] [src] = genPrefetchData n src +genSimplePrim _ (MO_BSwap width) [dst] [src] = genByteSwap width dst src +genSimplePrim bid (MO_BRev width) [dst] [src] = genBitRev bid width dst src +genSimplePrim bid (MO_PopCnt width) [dst] [src] = genPopCnt bid width dst src +genSimplePrim bid (MO_Pdep width) [dst] [src,mask] = genPdep bid width dst src mask +genSimplePrim bid (MO_Pext width) [dst] [src,mask] = genPext bid width dst src mask +genSimplePrim bid (MO_Clz width) [dst] [src] = genClz bid width dst src +genSimplePrim bid (MO_UF_Conv width) [dst] [src] = genWordToFloat bid width dst src +genSimplePrim _ (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr +genSimplePrim _ (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val +genSimplePrim bid (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg bid width dst addr old new +genSimplePrim _ (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value +genSimplePrim _ (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y +genSimplePrim _ (MO_SubWordC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y +genSimplePrim _ (MO_AddIntC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO r c x y +genSimplePrim _ (MO_SubIntC w) [r,c] [x,y] = genAddSubRetCarry w SUB_CC (const Nothing) OFLO r c x y +genSimplePrim _ (MO_Add2 w) [h,l] [x,y] = genAddWithCarry w h l x y +genSimplePrim _ (MO_U_Mul2 w) [h,l] [x,y] = genUnsignedLargeMul w h l x y +genSimplePrim _ (MO_S_Mul2 w) [c,h,l] [x,y] = genSignedLargeMul w c h l x y +genSimplePrim _ (MO_S_QuotRem w) [q,r] [x,y] = genQuotRem w True q r Nothing x y +genSimplePrim _ (MO_U_QuotRem w) [q,r] [x,y] = genQuotRem w False q r Nothing x y +genSimplePrim _ (MO_U_QuotRem2 w) [q,r] [hx,lx,y] = genQuotRem w False q r (Just hx) lx y +genSimplePrim _ MO_F32_Fabs [dst] [src] = genFloatAbs W32 dst src +genSimplePrim _ MO_F64_Fabs [dst] [src] = genFloatAbs W64 dst src +genSimplePrim _ MO_F32_Sqrt [dst] [src] = genFloatSqrt FF32 dst src +genSimplePrim _ MO_F64_Sqrt [dst] [src] = genFloatSqrt FF64 dst src +genSimplePrim bid MO_F32_Sin [dst] [src] = genLibCCall bid (fsLit "sinf") [dst] [src] +genSimplePrim bid MO_F32_Cos [dst] [src] = genLibCCall bid (fsLit "cosf") [dst] [src] +genSimplePrim bid MO_F32_Tan [dst] [src] = genLibCCall bid (fsLit "tanf") [dst] [src] +genSimplePrim bid MO_F32_Exp [dst] [src] = genLibCCall bid (fsLit "expf") [dst] [src] +genSimplePrim bid MO_F32_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1f") [dst] [src] +genSimplePrim bid MO_F32_Log [dst] [src] = genLibCCall bid (fsLit "logf") [dst] [src] +genSimplePrim bid MO_F32_Log1P [dst] [src] = genLibCCall bid (fsLit "log1pf") [dst] [src] +genSimplePrim bid MO_F32_Asin [dst] [src] = genLibCCall bid (fsLit "asinf") [dst] [src] +genSimplePrim bid MO_F32_Acos [dst] [src] = genLibCCall bid (fsLit "acosf") [dst] [src] +genSimplePrim bid MO_F32_Atan [dst] [src] = genLibCCall bid (fsLit "atanf") [dst] [src] +genSimplePrim bid MO_F32_Sinh [dst] [src] = genLibCCall bid (fsLit "sinhf") [dst] [src] +genSimplePrim bid MO_F32_Cosh [dst] [src] = genLibCCall bid (fsLit "coshf") [dst] [src] +genSimplePrim bid MO_F32_Tanh [dst] [src] = genLibCCall bid (fsLit "tanhf") [dst] [src] +genSimplePrim bid MO_F32_Pwr [dst] [x,y] = genLibCCall bid (fsLit "powf") [dst] [x,y] +genSimplePrim bid MO_F32_Asinh [dst] [src] = genLibCCall bid (fsLit "asinhf") [dst] [src] +genSimplePrim bid MO_F32_Acosh [dst] [src] = genLibCCall bid (fsLit "acoshf") [dst] [src] +genSimplePrim bid MO_F32_Atanh [dst] [src] = genLibCCall bid (fsLit "atanhf") [dst] [src] +genSimplePrim bid MO_F64_Sin [dst] [src] = genLibCCall bid (fsLit "sin") [dst] [src] +genSimplePrim bid MO_F64_Cos [dst] [src] = genLibCCall bid (fsLit "cos") [dst] [src] +genSimplePrim bid MO_F64_Tan [dst] [src] = genLibCCall bid (fsLit "tan") [dst] [src] +genSimplePrim bid MO_F64_Exp [dst] [src] = genLibCCall bid (fsLit "exp") [dst] [src] +genSimplePrim bid MO_F64_ExpM1 [dst] [src] = genLibCCall bid (fsLit "expm1") [dst] [src] +genSimplePrim bid MO_F64_Log [dst] [src] = genLibCCall bid (fsLit "log") [dst] [src] +genSimplePrim bid MO_F64_Log1P [dst] [src] = genLibCCall bid (fsLit "log1p") [dst] [src] +genSimplePrim bid MO_F64_Asin [dst] [src] = genLibCCall bid (fsLit "asin") [dst] [src] +genSimplePrim bid MO_F64_Acos [dst] [src] = genLibCCall bid (fsLit "acos") [dst] [src] +genSimplePrim bid MO_F64_Atan [dst] [src] = genLibCCall bid (fsLit "atan") [dst] [src] +genSimplePrim bid MO_F64_Sinh [dst] [src] = genLibCCall bid (fsLit "sinh") [dst] [src] +genSimplePrim bid MO_F64_Cosh [dst] [src] = genLibCCall bid (fsLit "cosh") [dst] [src] +genSimplePrim bid MO_F64_Tanh [dst] [src] = genLibCCall bid (fsLit "tanh") [dst] [src] +genSimplePrim bid MO_F64_Pwr [dst] [x,y] = genLibCCall bid (fsLit "pow") [dst] [x,y] +genSimplePrim bid MO_F64_Asinh [dst] [src] = genLibCCall bid (fsLit "asinh") [dst] [src] +genSimplePrim bid MO_F64_Acosh [dst] [src] = genLibCCall bid (fsLit "acosh") [dst] [src] +genSimplePrim bid MO_F64_Atanh [dst] [src] = genLibCCall bid (fsLit "atanh") [dst] [src] +genSimplePrim bid MO_SuspendThread [tok] [rs,i] = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i] +genSimplePrim bid MO_ResumeThread [rs] [tok] = genRTSCCall bid (fsLit "resumeThread") [rs] [tok] +genSimplePrim bid MO_I64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y] +genSimplePrim bid MO_I64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y] +genSimplePrim bid MO_W64_Quot [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y] +genSimplePrim bid MO_W64_Rem [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y] +genSimplePrim bid (MO_VS_Quot 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VS_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid (MO_VS_Rem 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y] +genSimplePrim bid (MO_VS_Rem 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y] +genSimplePrim bid (MO_VS_Rem 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y] +genSimplePrim bid (MO_VS_Rem 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VS_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid (MO_VU_Quot 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y] +genSimplePrim bid (MO_VU_Quot 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y] +genSimplePrim bid (MO_VU_Quot 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y] +genSimplePrim bid (MO_VU_Quot 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VU_Quot {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid (MO_VU_Rem 16 W8) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y] +genSimplePrim bid (MO_VU_Rem 8 W16) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y] +genSimplePrim bid (MO_VU_Rem 4 W32) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y] +genSimplePrim bid (MO_VU_Rem 2 W64) [dst] [x,y] = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y] +genSimplePrim _ op@(MO_VU_Rem {}) _ _ = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op) +genSimplePrim bid MO_I64X2_Min [dst] [x,y] = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y] +genSimplePrim bid MO_I64X2_Max [dst] [x,y] = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y] +genSimplePrim bid MO_W64X2_Min [dst] [x,y] = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y] +genSimplePrim bid MO_W64X2_Max [dst] [x,y] = genPrimCCall bid (fsLit "hs_maxWord64X2") [dst] [x,y] +genSimplePrim _ op dst args = do + platform <- ncgPlatform <$> getConfig + pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args)) + +{- Note [Evaluate C-call arguments before placing in destination registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When producing code for C calls we must take care when placing arguments +in their final registers. Specifically, we must ensure that temporary register +usage due to evaluation of one argument does not clobber a register in which we +already placed a previous argument (e.g. as the code generation logic for +MO_Shl can clobber %rcx due to x86 instruction limitations). + +This is precisely what happened in #18527. Consider this C--: + + (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64)); + +Here we are calling the C function `doSomething` with three arguments, the last +involving a non-trivial expression involving MO_Shl. In this case the NCG could +naively generate the following assembly (where $tmp denotes some temporary +register and $argN denotes the register for argument N, as dictated by the +platform's calling convention): + + mov _s2hp, $arg1 # place first argument + mov _s2hq, $arg2 # place second argument + + # Compute 1 << _s2hz + mov _s2hz, %rcx + shl %cl, $tmp + + # Compute (_s2hw | (1 << _s2hz)) + mov _s2hw, $arg3 + or $tmp, $arg3 + + # Perform the call + call func + +This code is outright broken on Windows which assigns $arg1 to %rcx. This means +that the evaluation of the last argument clobbers the first argument. + +To avoid this we use a rather awful hack: when producing code for a C call with +at least one non-trivial argument, we first evaluate all of the arguments into +local registers before moving them into their final calling-convention-defined +homes. This is performed by 'evalArgs'. Here we define "non-trivial" to be an +expression which might contain a MachOp since these are the only cases which +might clobber registers. Furthermore, we use a conservative approximation of +this condition (only looking at the top-level of CmmExprs) to avoid spending +too much effort trying to decide whether we want to take the fast path. + +Note that this hack *also* applies to calls to out-of-line PrimTargets (which +are lowered via a C call), which will ultimately end up in +genForeignCall{32,64}. +-} + +-- | See Note [Evaluate C-call arguments before placing in destination registers] +evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual]) +evalArgs bid actuals + | any loadIntoRegMightClobberOtherReg actuals = do + regs_blks <- mapM evalArg actuals + return (concatOL $ map fst regs_blks, map snd regs_blks) + | otherwise = return (nilOL, actuals) + where + + evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr) + evalArg actual = do + platform <- getPlatform + lreg <- newLocalReg $ cmmExprType platform actual + (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual + -- The above assignment shouldn't change the current block + massert (isNothing bid1) + return (instrs, CmmReg $ CmmLocal lreg) + + newLocalReg :: CmmType -> NatM LocalReg + newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty + +-- | Might the code to put this expression into a register +-- clobber any other registers? +loadIntoRegMightClobberOtherReg :: CmmExpr -> Bool +loadIntoRegMightClobberOtherReg (CmmReg _) = False +loadIntoRegMightClobberOtherReg (CmmRegOff _ _) = False +loadIntoRegMightClobberOtherReg (CmmLit _) = False + -- NB: this last 'False' is slightly risky, because the code for loading + -- a literal into a register is not entirely trivial. +loadIntoRegMightClobberOtherReg _ = True + +-- Note [DIV/IDIV for bytes] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- IDIV reminder: +-- Size Dividend Divisor Quotient Remainder +-- byte %ax r/m8 %al %ah +-- word %dx:%ax r/m16 %ax %dx +-- dword %edx:%eax r/m32 %eax %edx +-- qword %rdx:%rax r/m64 %rax %rdx +-- +-- We do a special case for the byte division because the current +-- codegen doesn't deal well with accessing %ah register (also, +-- accessing %ah in 64-bit mode is complicated because it cannot be an +-- operand of many instructions). So we just widen operands to 16 bits +-- and get the results from %al, %dl. This is not optimal, but a few +-- register moves are probably not a huge deal when doing division. + + +-- | Generate C call to the given function in ghc-prim +genPrimCCall + :: BlockId + -> FastString + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genPrimCCall bid lbl_txt dsts args = do + config <- getConfig + -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel + let lbl = mkCmmCodeLabel ghcInternalUnitId lbl_txt + addr <- cmmMakeDynamicReference config CallReference lbl + let conv = ForeignConvention CCallConv [] [] CmmMayReturn + genCCall bid addr conv dsts args + +-- | Generate C call to the given function in libc +genLibCCall + :: BlockId + -> FastString + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genLibCCall bid lbl_txt dsts args = do + config <- getConfig + -- Assume we can call these functions directly, and that they're not in a dynamic library. + -- TODO: Why is this ok? Under linux this code will be in libm.so + -- Is it because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction + addr <- cmmMakeDynamicReference config CallReference lbl + let conv = ForeignConvention CCallConv [] [] CmmMayReturn + genCCall bid addr conv dsts args + +-- | Generate C call to the given function in the RTS +genRTSCCall + :: BlockId + -> FastString + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genRTSCCall bid lbl_txt dsts args = do + config <- getConfig + -- Assume we can call these functions directly, and that they're not in a dynamic library. + let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction + addr <- cmmMakeDynamicReference config CallReference lbl + let conv = ForeignConvention CCallConv [] [] CmmMayReturn + genCCall bid addr conv dsts args + +-- | Generate a real C call to the given address with the given convention +genCCall + :: BlockId + -> CmmExpr + -> ForeignConvention + -> [CmmFormal] + -> [CmmActual] + -> NatM InstrBlock +genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do + platform <- getPlatform + is32Bit <- is32BitPlatform + let args_hints = zip args (argHints ++ repeat NoHint) + prom_args = map (maybePromoteCArgToW32 platform) args_hints + (instrs0, args') <- evalArgs bid prom_args + instrs1 <- if is32Bit + then genCCall32 addr conv dest_regs args' + else genCCall64 addr conv dest_regs args' + return (instrs0 `appOL` instrs1) + +maybePromoteCArgToW32 :: Platform -> (CmmExpr, ForeignHint) -> CmmExpr +maybePromoteCArgToW32 platform (arg, hint) + | wfrom < wto = + -- As wto=W32, we only need to handle integer conversions, + -- never Float -> Double. + case hint of + SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg] + _ -> CmmMachOp (MO_UU_Conv wfrom wto) [arg] + | otherwise = arg + where + ty = cmmExprType platform arg + wfrom = typeWidth ty + wto = W32 + +genCCall32 :: CmmExpr -- ^ address of the function to call + -> ForeignConvention -- ^ calling convention + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM InstrBlock +genCCall32 addr _conv dest_regs args = do + config <- getConfig + let platform = ncgPlatform config + + -- If the size is smaller than the word, we widen things (see maybePromoteCArg) + arg_size_bytes :: CmmType -> Int + arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform)) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + push_arg :: CmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg arg -- we don't need the hints on x86 + | isWord64 arg_ty = do + RegCode64 code r_hi r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty || isVecType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + format = cmmTypeFormat arg_ty + in + + movInstr config format (OpReg reg) (OpAddr addr) + + ] + ) + + | otherwise = do + -- Arguments can be smaller than 32-bit, but we still use @PUSH + -- II32@ - the usual calling conventions expect integers to be + -- 4-byte aligned. + massert ((typeWidth arg_ty) <= W32) + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType platform arg + size = arg_size_bytes arg_ty -- Byte size + + let + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c. + sizes = map (arg_size_bytes . cmmExprType platform) (reverse args) + raw_arg_size = sum sizes + platformWordSizeInBytes platform + arg_pad_size = (roundTo 16 $ raw_arg_size) - raw_arg_size + tot_arg_size = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform + + + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) + + push_codes <- mapM push_arg (reverse args) + delta <- getDeltaNat + massert (delta == delta0 - tot_arg_size) + + -- deal with static vs dynamic call targets + callinsns <- + case addr of + CmmLit (CmmLabel lbl) + -> return $ unitOL (CALL (Left fn_imm) []) + where fn_imm = ImmCLbl lbl + _ + -> do { (dyn_r, dyn_c) <- getSomeReg addr + ; massert (isWord32 (cmmExprType platform addr)) + ; return $ dyn_c `snocOL` CALL (Right dyn_r) [] } + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + call = callinsns `appOL` + toOL ( + (if tot_arg_size == 0 then [] else + [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) + ++ + [DELTA delta0] + ) + setDeltaNat delta0 + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] + | isVecType ty + = unitOL (mkRegRegMoveInstr config (cmmTypeFormat ty) xmm0 r_dest) + | isFloatType ty = + -- we assume SSE2 + let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + fmt = floatFormat w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA (delta0 - b), + X87Store fmt tmp_amode, + -- X87Store only supported for the CDECL ABI + -- NB: This code will need to be + -- revisited once GHC does more work around + -- SIGFPE f + MOV fmt (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp), + DELTA delta0] + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intFormat w) + (OpReg eax) + (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getLocalRegReg dest + assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + +genCCall64 :: CmmExpr -- ^ address of function to call + -> ForeignConvention -- ^ calling convention + -> [CmmFormal] -- ^ where to put the result + -> [CmmActual] -- ^ arguments (of mixed type) + -> NatM InstrBlock +genCCall64 addr conv dest_regs args = do + config <- getConfig + let platform = ncgPlatform config + word_size = platformWordSizeInBytes platform + wordFmt = archWordFormat (target32Bit platform) + + -- Compute the code for loading arguments into registers, + -- returning the leftover arguments that will need to be passed on the stack. + -- + -- NB: the code for loading references to data into registers is computed + -- later (in 'pushArgs'), because we don't yet know where the data will be + -- placed (due to alignment requirements). + LoadArgs + { stackArgs = proper_stack_args + , stackDataArgs = stack_data_args + , usedRegs = arg_regs_used + , assignArgsCode = assign_args_code + } + <- loadArgs config args + + let + + -- Pad all arguments and data passed on stack to align them properly. + (stk_args_with_padding, args_aligned_16) = + padStackArgs platform (proper_stack_args, stack_data_args) + + -- Align stack to 16n for calls, assuming a starting stack + -- alignment of 16n - word_size on procedure entry. Which we + -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c + need_realign_call = args_aligned_16 + align_call_code <- + if need_realign_call + then addStackPadding word_size + else return nilOL + + -- Compute the code that pushes data to the stack, and also + -- the code that loads references to that data into registers, + -- when the data is passed by reference in a register. + (load_data_refs, push_code) <- + pushArgs config proper_stack_args stk_args_with_padding + + -- On Windows, leave stack space for the arguments that we are passing + -- in registers (the so-called shadow space). + let shadow_space = + if platformOS platform == OSMinGW32 + then 8 * length (allArgRegs platform) + -- NB: the shadow store is always 8 * 4 = 32 bytes large, + -- i.e. the cumulative size of rcx, rdx, r8, r9 (see 'allArgRegs'). + else 0 + shadow_space_code <- addStackPadding shadow_space + + let total_args_size + = shadow_space + + sum (map (stackArgSpace platform) stk_args_with_padding) + real_size = + total_args_size + if need_realign_call then word_size else 0 + + -- End of argument passing. + -- + -- Next step: emit the appropriate call instruction. + delta <- getDeltaNat + + let -- The System V AMD64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used + assign_eax_sse_regs + = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax)) + -- Note: we do this on Windows as well. It's not entirely clear why + -- it's needed (the Windows X86_64 calling convention does not + -- dictate it), but we get segfaults without it. + -- + -- One test case exhibiting the issue is T20030_test1j; + -- if you change this, make sure to run it in a loop for a while + -- with at least -j8 to check. + + -- Live registers we are annotating the call instruction with + arg_regs = [RegWithFormat eax wordFmt] ++ arg_regs_used + + -- deal with static vs dynamic call targets + (callinsns,_cconv) <- case addr of + CmmLit (CmmLabel lbl) -> + return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv) + _ -> do + (dyn_r, dyn_c) <- getSomeReg addr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall + (if real_size==0 then [] else + [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [dest] = + unitOL $ + mkRegRegMoveInstr config fmt reg r_dest + where + reg = if isIntFormat fmt then rax else xmm0 + fmt = cmmTypeFormat rep + rep = localRegType dest + r_dest = getRegisterReg platform (CmmLocal dest) + assign_code _many = panic "genForeignCall.assign_code many" + + return (align_call_code `appOL` + push_code `appOL` + assign_args_code `appOL` + load_data_refs `appOL` + shadow_space_code `appOL` + assign_eax_sse_regs `appOL` + call `appOL` + assign_code dest_regs) + +-- ----------------------------------------------------------------------------- +-- Loading arguments into registers for 64-bit C calls. + +-- | Information needed to know how to pass arguments in a C call, +-- and in particular how to load them into registers. +data LoadArgs + = LoadArgs + -- | Arguments that should be passed on the stack + { stackArgs :: [RawStackArg] + -- | Additional values to store onto the stack. + , stackDataArgs :: [CmmExpr] + -- | Which registers are we using for argument passing? + , usedRegs :: [RegWithFormat] + -- | The code to assign arguments to registers used for argument passing. + , assignArgsCode :: InstrBlock + } +instance Semigroup LoadArgs where + LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2 + = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2) +instance Monoid LoadArgs where + mempty = LoadArgs [] [] [] nilOL + +-- | An argument passed on the stack, either directly or by reference. +-- +-- The padding information hasn't yet been computed (see 'StackArg'). +data RawStackArg + -- | Pass the argument on the stack directly. + = RawStackArg { stackArgExpr :: CmmExpr } + -- | Pass the argument by reference. + | RawStackArgRef + { stackRef :: StackRef + -- ^ is the reference passed in a register, or on the stack? + , stackRefArgSize :: Int + -- ^ the size of the data pointed to + } + deriving ( Show ) + +-- | An argument passed on the stack, either directly or by reference, +-- with additional padding information. +data StackArg + -- | Pass the argument on the stack directly. + = StackArg + { stackArgExpr :: CmmExpr + , stackArgPadding :: Int + -- ^ padding required (in bytes) + } + -- | Pass the argument by reference. + | StackArgRef + { stackRef :: StackRef + -- ^ where the reference is passed + , stackRefArgSize :: Int + -- ^ the size of the data pointed to + , stackRefArgPadding :: Int + -- ^ padding of the data pointed to + -- (the reference itself never requires padding) + } + deriving ( Show ) + +-- | Where is a reference to data on the stack passed? +data StackRef + -- | In a register. + = InReg Reg + -- | On the stack. + | OnStack + deriving ( Eq, Ord, Show ) + +newtype Padding = Padding { paddingBytes :: Int } + deriving ( Show, Eq, Ord ) + +-- | How much space does this 'StackArg' take up on the stack? +-- +-- Only counts the "reference" part for references, not the data it points to. +stackArgSpace :: Platform -> StackArg -> Int +stackArgSpace platform = \case + StackArg arg padding -> + argSize platform arg + padding + StackArgRef { stackRef = ref } -> + case ref of + InReg {} -> 0 + OnStack {} -> 8 + +-- | Pad arguments, assuming we start aligned to a 16-byte boundary. +-- +-- Returns padded arguments, together with whether we end up aligned +-- to a 16-byte boundary. +padStackArgs :: Platform + -> ([RawStackArg], [CmmExpr]) + -> ([StackArg], Bool) +padStackArgs platform (args0, data_args0) = + let + -- Pad the direct args + (args, align_16_mid) = pad_args True args0 + + -- Pad the data section + (data_args, align_16_end) = pad_args align_16_mid (map RawStackArg data_args0) + + -- Now figure out where the data is placed relative to the direct arguments, + -- in order to resolve references. + resolve_args :: [(RawStackArg, Padding)] -> [Padding] -> [StackArg] + resolve_args [] _ = [] + resolve_args ((stk_arg, Padding pad):rest) pads = + let (this_arg, pads') = + case stk_arg of + RawStackArg arg -> (StackArg arg pad, pads) + RawStackArgRef ref size -> case pads of + Padding arg_pad : rest_pads -> + let arg = StackArgRef + { stackRef = ref + , stackRefArgSize = size + , stackRefArgPadding = arg_pad } + in (arg, rest_pads) + _ -> panic "padStackArgs: no padding info found for StackArgRef" + in this_arg : resolve_args rest pads' + + in + ( resolve_args args (fmap snd data_args) ++ + [ case data_arg of + RawStackArg arg -> StackArg arg pad + RawStackArgRef {} -> panic "padStackArgs: reference in data section" + | (data_arg, Padding pad) <- data_args + ] + , align_16_end ) + + where + pad_args :: Bool -> [RawStackArg] -> ([(RawStackArg, Padding)], Bool) + pad_args aligned_16 [] = ([], aligned_16) + pad_args aligned_16 (arg:args) + | needed_alignment > 16 + -- We don't know if the stack is aligned to 8 (mod 32) or 24 (mod 32). + -- This makes aligning the stack to a 32 or 64 byte boundary more + -- complicated, in particular with DELTA. + = sorry $ unlines + [ "X86_86 C call: unsupported argument." + , " Alignment requirement: " ++ show needed_alignment ++ " bytes." + , if platformOS platform == OSMinGW32 + then " The X86_64 NCG does not (yet) support Windows C calls with 256/512 bit vectors." + else " The X86_64 NCG cannot (yet) pass 256/512 bit vectors on the stack for C calls." + , " Please use the LLVM backend (-fllvm)." ] + | otherwise + = let ( rest, final_align_16 ) = pad_args next_aligned_16 args + in ( (arg, Padding padding) : rest, final_align_16 ) + + where + needed_alignment = case arg of + RawStackArg arg -> argSize platform arg + RawStackArgRef {} -> platformWordSizeInBytes platform + padding + | needed_alignment < 16 || aligned_16 + = 0 + | otherwise + = 8 + next_aligned_16 = not ( aligned_16 && needed_alignment < 16 ) + +-- | Load arguments into available registers. +loadArgs :: NCGConfig -> [CmmExpr] -> NatM LoadArgs +loadArgs config args + | platformOS platform == OSMinGW32 + = evalStateT (loadArgsWin config args) (allArgRegs platform) + | otherwise + = evalStateT (loadArgsSysV config args) (allIntArgRegs platform + ,allFPArgRegs platform) + where + platform = ncgPlatform config + +-- | Load arguments into available registers (System V AMD64 ABI). +loadArgsSysV :: NCGConfig + -> [CmmExpr] + -> StateT ([Reg], [Reg]) NatM LoadArgs +loadArgsSysV _ [] = return mempty +loadArgsSysV config (arg:rest) = do + (iregs, fregs) <- get + -- No available registers: pass everything on the stack (shortcut). + if null iregs && null fregs + then return $ + LoadArgs + { stackArgs = map RawStackArg (arg:rest) + , stackDataArgs = [] + , assignArgsCode = nilOL + , usedRegs = [] + } + else do + mbReg <- + if + | isIntFormat arg_fmt + , ireg:iregs' <- iregs + -> do put (iregs', fregs) + return $ Just ireg + | isFloatFormat arg_fmt || isVecFormat arg_fmt + , freg:fregs' <- fregs + -> do put (iregs, fregs') + return $ Just freg + | otherwise + -> return Nothing + this_arg <- + case mbReg of + Just reg -> do + assign_code <- lift $ loadArgIntoReg arg reg + return $ + LoadArgs + { stackArgs = [] -- passed in register + , stackDataArgs = [] + , assignArgsCode = assign_code + , usedRegs = [RegWithFormat reg arg_fmt] + } + Nothing -> do + return $ + -- No available register for this argument: pass it on the stack. + LoadArgs + { stackArgs = [RawStackArg arg] + , stackDataArgs = [] + , assignArgsCode = nilOL + , usedRegs = [] + } + others <- loadArgsSysV config rest + return $ this_arg S.<> others + + where + platform = ncgPlatform config + arg_fmt = cmmTypeFormat (cmmExprType platform arg) + +-- | Compute all things that will need to be pushed to the stack. +-- +-- On Windows, an argument passed by reference will require two pieces of data: +-- +-- - the reference (returned in the first position) +-- - the actual data (returned in the second position) +computeWinPushArgs :: Platform -> [CmmExpr] -> ([RawStackArg], [CmmExpr]) +computeWinPushArgs platform = go + where + go :: [CmmExpr] -> ([RawStackArg], [CmmExpr]) + go [] = ([], []) + go (arg:args) = + let + arg_size = argSize platform arg + (this_arg, add_this_arg) + | arg_size > 8 + = ( RawStackArgRef OnStack arg_size, (arg :) ) + | otherwise + = ( RawStackArg arg, id ) + (stk_args, stk_data) = go args + in + (this_arg:stk_args, add_this_arg stk_data) + +-- | Load arguments into available registers (Windows C X64 calling convention). +loadArgsWin :: NCGConfig -> [CmmExpr] -> StateT [(Reg,Reg)] NatM LoadArgs +loadArgsWin _ [] = return mempty +loadArgsWin config (arg:rest) = do + regs <- get + case regs of + reg:regs' -> do + put regs' + this_arg <- lift $ load_arg_win reg + rest <- loadArgsWin config rest + return $ this_arg S.<> rest + [] -> do + -- No more registers available: pass all (remaining) arguments on the stack. + let (stk_args, data_args) = computeWinPushArgs platform (arg:rest) + return $ + LoadArgs + { stackArgs = stk_args + , stackDataArgs = data_args + , assignArgsCode = nilOL + , usedRegs = [] + } + where + platform = ncgPlatform config + arg_fmt = cmmTypeFormat $ cmmExprType platform arg + load_arg_win (ireg, freg) + | isVecFormat arg_fmt + -- Vectors are passed by reference. + -- See Note [The Windows X64 C calling convention]. + = do return $ + LoadArgs + -- Pass the reference in a register, + -- and the argument data on the stack. + { stackArgs = [RawStackArgRef (InReg ireg) (argSize platform arg)] + , stackDataArgs = [arg] -- we don't yet know where the data will reside, + , assignArgsCode = nilOL -- so we defer computing the reference and storing it + -- in the register until later + , usedRegs = [RegWithFormat ireg II64] + } + | otherwise + = do let arg_reg + | isFloatFormat arg_fmt + = freg + | otherwise + = ireg + assign_code <- loadArgIntoReg arg arg_reg + -- Recall that, for varargs, we must pass floating-point + -- arguments in both fp and integer registers. + let (assign_code', regs') + | isFloatFormat arg_fmt = + ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg), + [ RegWithFormat freg FF64 + , RegWithFormat ireg II64 ]) + | otherwise = (assign_code, [RegWithFormat ireg II64]) + return $ + LoadArgs + { stackArgs = [] -- passed in register + , stackDataArgs = [] + , assignArgsCode = assign_code' + , usedRegs = regs' + } + +-- | Load an argument into a register. +-- +-- Assumes that the expression does not contain any MachOps, +-- as per Note [Evaluate C-call arguments before placing in destination registers]. +loadArgIntoReg :: CmmExpr -> Reg -> NatM InstrBlock +loadArgIntoReg arg reg = do + when (debugIsOn && loadIntoRegMightClobberOtherReg arg) $ do + platform <- getPlatform + massertPpr False $ + vcat [ text "loadArgIntoReg: arg might contain MachOp" + , text "arg:" <+> pdoc platform arg ] + arg_code <- getAnyReg arg + return $ arg_code reg + +-- ----------------------------------------------------------------------------- +-- Pushing arguments onto the stack for 64-bit C calls. + +-- | The size of an argument (in bytes). +-- +-- Never smaller than the platform word width. +argSize :: Platform -> CmmExpr -> Int +argSize platform arg = + max (platformWordSizeInBytes platform) $ + widthInBytes (typeWidth $ cmmExprType platform arg) + +-- | Add the given amount of padding on the stack. +addStackPadding :: Int -- ^ padding (in bytes) + -> NatM InstrBlock +addStackPadding pad_bytes + | pad_bytes == 0 + = return nilOL + | otherwise + = do delta <- getDeltaNat + setDeltaNat (delta - pad_bytes) + return $ + toOL [ SUB II64 (OpImm (ImmInt pad_bytes)) (OpReg rsp) + , DELTA (delta - pad_bytes) + ] + +-- | Push one argument directly to the stack (by value). +-- +-- Assumes the current stack pointer fulfills any necessary alignment requirements. +pushArgByValue :: NCGConfig -> CmmExpr -> NatM InstrBlock +pushArgByValue config arg + -- For 64-bit integer arguments, use PUSH II64. + -- + -- Note: we *must not* do this for smaller arguments. + -- For example, if we tried to push an argument such as @CmmLoad addr W32 aln@, + -- we could end up reading unmapped memory and segfaulting. + | isIntFormat fmt + , formatInBytes fmt == 8 + = do + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + return $ + arg_code `appOL` toOL + [ PUSH II64 arg_op + , DELTA (delta-arg_size) ] + + | otherwise + = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + return $ arg_code `appOL` toOL + [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp) + , DELTA (delta-arg_size) + , movInstr config fmt (OpReg arg_reg) (OpAddr (spRel platform 0)) ] + + where + platform = ncgPlatform config + arg_size = argSize platform arg + arg_rep = cmmExprType platform arg + fmt = cmmTypeFormat arg_rep + +-- | Load an argument into a register or push it to the stack. +loadOrPushArg :: NCGConfig -> (StackArg, Maybe Int) -> NatM (InstrBlock, InstrBlock) +loadOrPushArg config (stk_arg, mb_off) = + case stk_arg of + StackArg arg pad -> do + push_code <- pushArgByValue config arg + pad_code <- addStackPadding pad + return (nilOL, push_code `appOL` pad_code) + StackArgRef { stackRef = ref } -> + case ref of + -- Pass the reference in a register + InReg ireg -> + return (unitOL $ LEA II64 (OpAddr (spRel platform off)) (OpReg ireg), nilOL) + -- Pass the reference on the stack + OnStack {} -> do + tmp <- getNewRegNat II64 + delta <- getDeltaNat + setDeltaNat (delta-arg_ref_size) + let push_code = toOL + [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_ref_size)) (OpReg rsp) + , DELTA (delta-arg_ref_size) + , LEA II64 (OpAddr (spRel platform off)) (OpReg tmp) + , MOV II64 (OpReg tmp) (OpAddr (spRel platform 0)) ] + return (nilOL, push_code) + where off = expectJust mb_off + where + arg_ref_size = 8 -- passing a reference to the argument + platform = ncgPlatform config + +-- | Push arguments to the stack, right to left. +-- +-- On Windows, some arguments may need to be passed by reference, +-- which requires separately passing the data and the reference. +-- See Note [The Windows X64 C calling convention]. +pushArgs :: NCGConfig + -> [RawStackArg] + -- ^ arguments proper (i.e. don't include the data for arguments passed by reference) + -> [StackArg] + -- ^ arguments we are passing on the stack + -> NatM (InstrBlock, InstrBlock) +pushArgs config proper_args all_stk_args + = do { let + vec_offs :: [Maybe Int] + vec_offs + | platformOS platform == OSMinGW32 + = go stack_arg_size all_stk_args + | otherwise + = repeat Nothing + + --------------------- + -- Windows-only code + + -- Size of the arguments we are passing on the stack, counting only + -- the reference part for arguments passed by reference. + stack_arg_size = 8 * count not_in_reg proper_args + not_in_reg (RawStackArg {}) = True + not_in_reg (RawStackArgRef { stackRef = ref }) = + case ref of + InReg {} -> False + OnStack {} -> True + + -- Check an offset is valid (8-byte aligned), for assertions. + ok off = off `rem` 8 == 0 + + -- Tricky code: compute the stack offset to the vector data + -- for this argument. + -- + -- If you're confused, Note [The Windows X64 C calling convention] + -- contains a helpful diagram. + go :: Int -> [StackArg] -> [Maybe Int] + go _ [] = [] + go off (stk_arg:args) = + assertPpr (ok off) (text "unaligned offset:" <+> ppr off) $ + case stk_arg of + StackArg {} -> + -- Only account for the stack pointer movement. + let off' = off - stackArgSpace platform stk_arg + in Nothing : go off' args + StackArgRef + { stackRefArgSize = data_size + , stackRefArgPadding = data_pad } -> + assertPpr (ok data_size) (text "unaligned data size:" <+> ppr data_size) $ + assertPpr (ok data_pad) (text "unaligned data padding:" <+> ppr data_pad) $ + let off' = off + -- Next piece of data is after the data for this reference + + data_size + data_pad + -- ... and account for the stack pointer movement. + - stackArgSpace platform stk_arg + in Just (data_pad + off) : go off' args + + -- end of Windows-only code + ---------------------------- + + -- Push the stack arguments (right to left), + -- including both the reference and the data for arguments passed by reference. + ; (load_regs, push_args) <- foldMapM (loadOrPushArg config) (reverse $ zip all_stk_args vec_offs) + ; return (load_regs, push_args) } + where + platform = ncgPlatform config + +{- Note [The Windows X64 C calling convention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are a few facts about the Windows X64 C calling convention that +are important: + + - any argument larger than 8 bytes must be passed by reference, + and arguments smaller than 8 bytes are padded to 8 bytes. + + - the first four arguments are passed in registers: + - floating-point scalar arguments are passed in %xmm0, %xmm1, %xmm2, %xmm3 + - other arguments are passed in %rcx, %rdx, %r8, %r9 + (this includes vector arguments, passed by reference) + + For variadic functions, it is additionally expected that floating point + scalar arguments are copied to the corresponding integer register, e.g. + the data in xmm2 should also be copied to r8. + + There is no requirement about setting %al like there is for the + System V AMD64 ABI. + + - subsequent arguments are passed on the stack. + +There are also alignment requirements: + + - the data for vectors must be aligned to the size of the vector, + e.g. a 32 byte vector must be aligned on a 32 byte boundary, + + - the call instruction must be aligned to 16 bytes. + (This differs from the System V AMD64 ABI, which mandates that the call + instruction must be aligned to 32 bytes if there are any 32 byte vectors + passed on the stack.) + +This motivates our handling of vector values. Suppose we have a function call +with many arguments, several of them being vectors. We proceed as follows: + + - Add some padding, if necessary, to ensure the stack, when executing the call + instruction, is 16-byte aligned. Whether this padding is necessary depends + on what happens next. (Recall also that we start off at 8 (mod 16) alignment, + as per Note [Stack Alignment on X86] in rts/StgCRun.c) + - Push all the vectors to the stack first, adding padding after each one + if necessary. + - Then push the arguments: + - for non-vectors, proceed as usual, + - for vectors, push the address of the vector data we pushed above. + - Then assign the registers: + - for non-vectors, proceed as usual, + - for vectors, store the address in a general-purpose register, as opposed + to storing the data in an xmm register. + +For a concrete example, suppose we have a call of the form: + + f x1 x2 x3 x4 x5 x6 x7 + +in which: + + - x2, x3, x5 and x7 are 16 byte vectors + - the other arguments are all 8 byte wide + +Now, x1, x2, x3, x4 will get passed in registers, except that we pass +x2 and x3 by reference, because they are vectors. We proceed as follows: + + - push the vectors to the stack: x7, x5, x3, x2 (in that order) + - push the stack arguments in order: addr(x7), x6, addr(x5) + - load the remaining arguments into registers: x4, addr(x3), addr(x2), x1 + +The tricky part is to get the right offsets for the addresses of the vector +data. The following visualisation will hopefully clear things up: + + ┌──┐ + │▓▓│ ─── padding to align the call instruction + ╭─╴ ╞══╡ (ensures Sp, below, is 16-byte aligned) + │ │ │ + │ x7 ───╴ │ │ + │ ├──┤ + │ │ │ + │ x5 ───╴ │ │ + │ ├──┤ + vector data ────┤ │ │ +(individually padded) │ x3 ───╴ │ │ + │ ├──┤ + │ │ │ + │ x2 ───╴ │ │ + │ ├┄┄┤ + │ │▓▓│ ─── padding to align x2 to 16 bytes + ╭─╴ ╰─╴ ╞══╡ + │ addr(x7) ───╴ │ │ ╭─ from here: x7 is +64 + │ ├──┤ ╾──╯ = 64 (position of x5) + stack ───┤ x6 ───╴ │ │ + 16 (size of x5) + 0 (padding of x7) + arguments │ ├──┤ - 2 * 8 (x7 is 2 arguments higher than x5) + │ addr(x5) ───╴ │ │ + ╰─╴ ╭─╴ ╞══╡ ╾─── from here: + │ │ │ - x2 is +32 = 24 (stack_arg_size) + 8 (padding of x2) + shadow ───┤ │ │ - x3 is +48 = 32 (position of x2) + 16 (size of x2) + 0 (padding of x3) + space │ │ │ - x5 is +64 = 48 (position of x3) + 16 (size of x3) + 0 (padding of x5) + │ │ │ + ╰─╴ └──┘ ╾─── Sp + +This is all tested in the simd013 test. +-} + +-- ----------------------------------------------------------------------------- +-- Generating a table-branch + +{- +Note [Sub-word subtlety during jump-table indexing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Offset the index by the start index of the jump table. +It's important that we do this *before* the widening below. To see +why, consider a switch with a sub-word, signed discriminant such as: + + switch [-5...+2] x::I16 { + case -5: ... + ... + case +2: ... + } + +Consider what happens if we offset *after* widening in the case that +x=-4: + + // x == -4 == 0xfffc::I16 + indexWidened = UU_Conv(x); // == 0xfffc::I64 + indexExpr = indexWidened - (-5); // == 0x10000::I64 + +This index is clearly nonsense given that the jump table only has +eight entries. + +By contrast, if we widen *after* we offset then we get the correct +index (1), + + // x == -4 == 0xfffc::I16 + indexOffset = x - (-5); // == 1::I16 + indexExpr = UU_Conv(indexOffset); // == 1::I64 + +See #21186. +-} + +genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock + +genSwitch expr targets = do + config <- getConfig + let platform = ncgPlatform config + expr_w = cmmExprWidth platform expr + indexExpr0 = cmmOffset platform expr offset + -- We widen to a native-width register because we cannot use arbitrary sizes + -- in x86 addressing modes. + -- See Note [Sub-word subtlety during jump-table indexing]. + indexExpr = CmmMachOp + (MO_UU_Conv expr_w (platformWordWidth platform)) + [indexExpr0] + if ncgPIC config + then do + (reg,e_code) <- getNonClobberedReg indexExpr + -- getNonClobberedReg because it needs to survive across t_code + lbl <- getNewLabelNat + let is32bit = target32Bit platform + os = platformOS platform + -- Might want to use .rodata. instead, but as + -- long as it's something unique it'll work out since the + -- references to the jump table are in the appropriate section. + rosection = case os of + -- on Mac OS X/x86_64, put the jump table in the text section to + -- work around a limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous label in its section. + OSDarwin | not is32bit -> Section Text lbl + _ -> Section ReadOnlyData lbl + dynRef <- cmmMakeDynamicReference config DataReference lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) + + return $ e_code `appOL` t_code `appOL` toOL [ + ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids rosection lbl + ] + else do + (reg,e_code) <- getSomeReg indexExpr + lbl <- getNewLabelNat + let is32bit = target32Bit platform + if is32bit + then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl)) + jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl + in return $ e_code `appOL` unitOL jmp_code + else do + -- See Note [%rip-relative addressing on x86-64]. + tableReg <- getNewRegNat (intFormat (platformWordWidth platform)) + targetReg <- getNewRegNat (intFormat (platformWordWidth platform)) + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) + fmt = archWordFormat is32bit + code = e_code `appOL` toOL + [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg) + , MOV fmt op (OpReg targetReg) + , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl + ] + return code + where + (offset, blockIds) = switchTargetsToTable targets + ids = map (fmap DestBlockId) blockIds + +generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr) +generateJumpTableForInstr config (JMP_TBL _ ids section lbl) + = let getBlockId (DestBlockId id) = id + getBlockId _ = panic "Non-Label target in Jump Table" + blockIds = map (fmap getBlockId) ids + in Just (createJumpTable config blockIds section lbl) +generateJumpTableForInstr _ _ = Nothing + +createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel + -> GenCmmDecl (Alignment, RawCmmStatics) h g +createJumpTable config ids section lbl + = let jumpTable + | ncgPIC config = + let ww = ncgWordWidth config + jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 ww) + jumpTableEntryRel (Just blockid) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww) + where blockLabel = blockLbl blockid + in map jumpTableEntryRel ids + | otherwise = map (jumpTableEntry config) ids + in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable) + +extractUnwindPoints :: [Instr] -> [UnwindPoint] +extractUnwindPoints instrs = + [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs] + +-- ----------------------------------------------------------------------------- +-- 'condIntReg' and 'condFltReg': condition codes into registers + +-- Turn those condition codes into integers now (when they appear on +-- the right hand side of an assignment). +-- +-- (If applicable) Do not fill the delay slots here; you will confuse the +-- register allocator. + +condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register + +condIntReg cond x y = do + CondCode _ cond cond_code <- condIntCode cond x y + tmp <- getNewRegNat II8 + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] + return (Any II32 code) + + +-- Note [SSE Parity Checks] +-- ~~~~~~~~~~~~~~~~~~~~~~~~ +-- We have to worry about unordered operands (eg. comparisons +-- against NaN). If the operands are unordered, the comparison +-- sets the parity flag, carry flag and zero flag. +-- All comparisons are supposed to return false for unordered +-- operands except for !=, which returns true. +-- +-- Optimisation: we don't have to test the parity flag if we +-- know the test has already excluded the unordered case: eg > +-- and >= test for a zero carry flag, which can only occur for +-- ordered operands. +-- +-- By reversing comparisons we can avoid testing the parity +-- for < and <= as well. If any of the arguments is an NaN we +-- return false either way. If both arguments are valid then +-- x <= y <-> y >= x holds. So it's safe to swap these. +-- +-- We invert the condition inside getRegister'and getCondCode +-- which should cover all invertable cases. +-- All other functions translating FP comparisons to assembly +-- use these to two generate the comparison code. +-- +-- As an example consider a simple check: +-- +-- func :: Float -> Float -> Int +-- func x y = if x < y then 1 else 0 +-- +-- Which in Cmm gives the floating point comparison. +-- +-- if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf; +-- +-- We used to compile this to an assembly code block like this: +-- _c2gh: +-- ucomiss %xmm2,%xmm1 +-- jp _c2gf +-- jb _c2gg +-- jmp _c2gf +-- +-- Where we have to introduce an explicit +-- check for unordered results (using jmp parity): +-- +-- We can avoid this by exchanging the arguments and inverting the direction +-- of the comparison. This results in the sequence of: +-- +-- ucomiss %xmm1,%xmm2 +-- ja _c2g2 +-- jmp _c2g1 +-- +-- Removing the jump reduces the pressure on the branch prediction system +-- and plays better with the uOP cache. + +condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register +condFltReg is32Bit cond x y = condFltReg_sse2 + where + + + condFltReg_sse2 = do + CondCode _ cond cond_code <- condFltCode cond x y + tmp1 <- getNewRegNat (archWordFormat is32Bit) + tmp2 <- getNewRegNat (archWordFormat is32Bit) + let -- See Note [SSE Parity Checks] + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + -- Use ASSERT so we don't break releases if these creep in. + LTT -> assertPpr False (text "Should have been turned into >") $ + and_ordered dst + LE -> assertPpr False (text "Should have been turned into >=") $ + and_ordered dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL II8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + return (Any II32 code) + + +-- ----------------------------------------------------------------------------- +-- 'trivial*Code': deal with trivial instructions + +-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode', +-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions. +-- Only look for constants on the right hand side, because that's +-- where the generic optimizer will have put them. + +-- Similarly, for unary instructions, we don't have to worry about +-- matching an StInt as the argument, because genericOpt will already +-- have handled the constant-folding. + + +{- +The Rules of the Game are: + +* You cannot assume anything about the destination register dst; + it may be anything, including a fixed reg. + +* You may compute an operand into a fixed reg, but you may not + subsequently change the contents of that fixed reg. If you + want to do so, first copy the value either to a temporary + or into dst. You are free to modify dst even if it happens + to be a fixed reg -- that's not your problem. + +* You cannot assume that a fixed reg will stay live over an + arbitrary computation. The same applies to the dst reg. + +* Temporary regs obtained from getNewRegNat are distinct from + each other and from all other regs, and stay live over + arbitrary computations. + +-------------------- + +SDM's version of The Rules: + +* If getRegister returns Any, that means it can generate correct + code which places the result in any register, period. Even if that + register happens to be read during the computation. + + Corollary #1: this means that if you are generating code for an + operation with two arbitrary operands, you cannot assign the result + of the first operand into the destination register before computing + the second operand. The second operand might require the old value + of the destination register. + + Corollary #2: A function might be able to generate more efficient + code if it knows the destination register is a new temporary (and + therefore not read by any of the sub-computations). + +* If getRegister returns Any, then the code it generates may modify only: + (a) fresh temporaries + (b) the destination register + (c) known registers (eg. %ecx is used by shifts) + In particular, it may *not* modify global registers, unless the global + register happens to be the destination register. +-} + +trivialCode :: Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode width instr m a b + = do platform <- getPlatform + trivialCode' platform width instr m a b + +trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b + | is32BitLit platform lit_a = do + b_code <- getAnyReg b + let + code dst + = b_code dst `snocOL` + revinstr (OpImm (litToImm lit_a)) (OpReg dst) + return (Any (intFormat width) code) + +trivialCode' _ width instr _ a b + = genTrivialCode (intFormat width) (\op2 -> instr op2 . OpReg) a b + +-- This is re-used for floating pt instructions too. +genTrivialCode :: Format -> (Operand -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +genTrivialCode rep instr a b = do + (b_op, b_code) <- getNonClobberedOperand b + a_code <- getAnyReg a + tmp <- getNewRegNat rep + let + -- We want the value of 'b' to stay alive across the computation of 'a'. + -- But, we want to calculate 'a' straight into the destination register, + -- because the instruction only has two operands (dst := dst `op` src). + -- The troublesome case is when the result of 'b' is in the same register + -- as the destination 'reg'. In this case, we have to save 'b' in a + -- new temporary across the computation of 'a'. + code dst + | dst `regClashesWithOp` b_op = + b_code `appOL` + unitOL (MOV rep b_op (OpReg tmp)) `appOL` + a_code dst `snocOL` + instr (OpReg tmp) dst + | otherwise = + b_code `appOL` + a_code dst `snocOL` + instr b_op dst + return (Any rep code) + +regClashesWithOp :: Reg -> Operand -> Bool +reg `regClashesWithOp` OpReg reg2 = reg == reg2 +reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) +_ `regClashesWithOp` _ = False + +-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@, +-- with 3 operands (FMA3 instruction set). +genFMA3Code :: Length + -> Width + -> FMASign + -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register +genFMA3Code l w signs x y z = do + config <- getConfig + -- For the FMA instruction, we want to compute x * y + z + -- + -- There are three possible instructions we could emit: + -- + -- - fmadd213 z y x, result in x, z can be a memory address + -- - fmadd132 x z y, result in y, x can be a memory address + -- - fmadd231 y x z, result in z, y can be a memory address + -- + -- This suggests two possible optimisations: + -- + -- - OPTIMISATION 1 + -- If one argument is an address, use the instruction that allows + -- a memory address in that position. + -- + -- - OPTIMISATION 2 + -- If one argument is in a fixed register, use the instruction that puts + -- the result in that same register. + -- + -- Currently we follow neither of these optimisations, + -- opting to always use fmadd213 for simplicity. + -- + -- We would like to compute the result directly into the requested register. + -- To do so we must first compute `x` into the destination register. This is + -- only possible if the other arguments don't use the destination register. + -- We check for this and if there is a conflict we move the result only after + -- the computation. See #24496 how this went wrong in the past. + let rep + | l == 1 + = floatFormat w + | otherwise + = vecFormat (cmmVec l $ cmmFloat w) + (y_reg, y_code) <- getNonClobberedReg y + (z_op, z_code) <- getNonClobberedOperand z + x_code <- getAnyReg x + x_tmp <- getNewRegNat rep + let + fma213 = FMA3 rep signs FMA213 + + code, code_direct, code_mov :: Reg -> InstrBlock + -- Ideal: Compute the result directly into dst + code_direct dst = x_code dst `snocOL` + fma213 z_op y_reg dst + -- Fallback: Compute the result into a tmp reg and then move it. + code_mov dst = x_code x_tmp `snocOL` + fma213 z_op y_reg x_tmp `snocOL` + mkRegRegMoveInstr config rep x_tmp dst + + code dst = + y_code `appOL` + z_code `appOL` + ( if arg_regs_conflict then code_mov dst else code_direct dst ) + + where + + arg_regs_conflict = + y_reg == dst || + case z_op of + OpReg z_reg -> z_reg == dst + OpAddr amode -> dst `elem` addrModeRegs amode + OpImm {} -> False + + -- NB: Computing the result into a desired register using Any can be tricky. + -- So for now, we keep it simple. (See #24496). + return (Any rep code) + +----------- + +trivialUCode :: Format -> (Operand -> Instr) + -> CmmExpr -> NatM Register +trivialUCode rep instr x = do + x_code <- getAnyReg x + let + code dst = + x_code dst `snocOL` + instr (OpReg dst) + return (Any rep code) + +----------- + + +trivialFCode_sse2 :: Width -> (Format -> Operand -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialFCode_sse2 ty instr x y + = genTrivialCode format (instr format) x y + where format = floatFormat ty + + +-------------------------------------------------------------------------------- +coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register +coerceInt2FP from to x = coerce_sse2 + where + + coerce_sse2 = do + (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand + let + opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD + n -> panic $ "coerceInt2FP.sse: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc (intFormat from) x_op dst + return (Any (floatFormat to) code) + -- works even if the destination rep is 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 CmmExpr -> NatM Register +coerceFP2FP to x = do + (x_reg, x_code) <- getSomeReg x + let + opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; + n -> panic $ "coerceFP2FP: unhandled width (" + ++ show n ++ ")" + code dst = x_code `snocOL` opc x_reg dst + return (Any ( floatFormat to) code) + +-------------------------------------------------------------------------------- + +sse2NegCode :: Width -> CmmExpr -> NatM Register +sse2NegCode w x = do + let fmt = floatFormat w + x_code <- getAnyReg x + -- This is how gcc does it, so it can't be that bad: + let + const = case fmt of + FF32 -> CmmInt 0x80000000 W32 + FF64 -> CmmInt 0x8000000000000000 W64 + x@II8 -> wrongFmt x + x@II16 -> wrongFmt x + x@II32 -> wrongFmt x + x@II64 -> wrongFmt x + x@(VecFormat {}) -> wrongFmt x + + where + wrongFmt x = panic $ "sse2NegCode: " ++ show x + Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const + tmp <- getNewRegNat fmt + let + code dst = x_code dst `appOL` amode_code `appOL` toOL [ + MOV fmt (OpAddr amode) (OpReg tmp), + XOR fmt (OpReg tmp) (OpReg dst) + ] + -- + return (Any fmt code) + +needLlvm :: MachOp -> NatM a +needLlvm mop = + sorry $ unlines [ "Unsupported vector instruction for the native code generator:" + , show mop + , "Please use -fllvm." ] + +incorrectOperands :: NatM a +incorrectOperands = sorry "Incorrect number of operands" + +invalidConversion :: Width -> Width -> NatM a +invalidConversion from to = + sorry $ "Invalid conversion operation from " ++ show from ++ " to " ++ show to + +-- | This works on the invariant that all jumps in the given blocks are required. +-- Starting from there we try to make a few more jumps redundant by reordering +-- them. +-- We depend on the information in the CFG to do so so without a given CFG +-- we do nothing. +invertCondBranches :: Maybe CFG -- ^ CFG if present + -> LabelMap a -- ^ Blocks with info tables + -> [NatBasicBlock Instr] -- ^ List of basic blocks + -> [NatBasicBlock Instr] +invertCondBranches Nothing _ bs = bs +invertCondBranches (Just cfg) keep bs = + invert bs + where + invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr] + invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs) + | --pprTrace "Block" (ppr lbl1) True, + Just (jmp1,jmp2) <- last2 ins + , JXX cond1 target1 <- jmp1 + , target1 == lbl2 + --, pprTrace "CutChance" (ppr b1) True + , JXX ALWAYS target2 <- jmp2 + -- We have enough information to check if we can perform the inversion + -- TODO: We could also check for the last asm instruction which sets + -- status flags instead. Which I suspect is worse in terms of compiler + -- performance, but might be applicable to more cases + , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg + , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg + -- Both jumps come from the same cmm statement + , transitionSource edgeInfo1 == transitionSource edgeInfo2 + , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1 + + --Int comparisons are invertable + , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch + , Just _ <- maybeIntComparison op + , Just invCond <- maybeInvertCond cond1 + + --Swap the last two jumps, invert the conditional jumps condition. + = let jumps = + case () of + -- We are free the eliminate the jmp. So we do so. + _ | not (mapMember target1 keep) + -> [JXX invCond target2] + -- If the conditional target is unlikely we put the other + -- target at the front. + | edgeWeight edgeInfo2 > edgeWeight edgeInfo1 + -> [JXX invCond target2, JXX ALWAYS target1] + -- Keep things as-is otherwise + | otherwise + -> [jmp1, jmp2] + in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $ + (BasicBlock lbl1 + (dropTail 2 ins ++ jumps)) + : invert (b2:bs) + invert (b:bs) = b : invert bs + invert [] = [] + +genAtomicRMW + :: BlockId + -> Width + -> AtomicMachOp + -> LocalReg + -> CmmExpr + -> CmmExpr + -> NatM (InstrBlock, Maybe BlockId) +genAtomicRMW bid width amop dst addr n = do + Amode amode addr_code <- + if amop `elem` [AMO_Add, AMO_Sub] + then getAmode addr + else getSimpleAmode addr -- See genForeignCall for MO_Cmpxchg + arg <- getNewRegNat format + arg_code <- getAnyReg n + platform <- ncgPlatform <$> getConfig + + let dst_r = getRegisterReg platform (CmmLocal dst) + (code, lbl) <- op_code dst_r arg amode + return (addr_code `appOL` arg_code arg `appOL` code, Just lbl) + where + -- Code for the operation + op_code :: Reg -- Destination reg + -> Reg -- Register containing argument + -> AddrMode -- Address of location to mutate + -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId + op_code dst_r arg amode = do + case amop of + -- In the common case where dst_r is a virtual register the + -- final move should go away, because it's the last use of arg + -- and the first use of dst_r. + AMO_Add -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ], bid) + AMO_Sub -> return $ (toOL [ NEGI format (OpReg arg) + , LOCK (XADD format (OpReg arg) (OpAddr amode)) + , MOV format (OpReg arg) (OpReg dst_r) + ], bid) + -- In these cases we need a new block id, and have to return it so + -- that later instruction selection can reference it. + AMO_And -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst) + AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst + , NOT format dst + ]) + AMO_Or -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst) + AMO_Xor -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst) + where + -- Simulate operation that lacks a dedicated instruction using + -- cmpxchg. + cmpxchg_code :: (Operand -> Operand -> OrdList Instr) + -> NatM (OrdList Instr, BlockId) + cmpxchg_code instrs = do + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + tmp <- getNewRegNat format + + --Record inserted blocks + -- We turn A -> B into A -> A' -> A'' -> B + -- with a self loop on A'. + addImmediateSuccessorNat bid lbl1 + addImmediateSuccessorNat lbl1 lbl2 + updateCfgNat (addWeightEdge lbl1 lbl1 0) + + return $ (toOL + [ MOV format (OpAddr amode) (OpReg eax) + , JXX ALWAYS lbl1 + , NEWBLOCK lbl1 + -- Keep old value so we can return it: + , MOV format (OpReg eax) (OpReg dst_r) + , MOV format (OpReg eax) (OpReg tmp) + ] + `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL + [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode)) + , JXX NE lbl1 + -- See Note [Introducing cfg edges inside basic blocks] + -- why this basic block is required. + , JXX ALWAYS lbl2 + , NEWBLOCK lbl2 + ], + lbl2) + format = intFormat width + +-- | Count trailing zeroes +genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId) +genCtz bid width dst src = do + is32Bit <- is32BitPlatform + if is32Bit && width == W64 + then genCtz64_32 bid dst src + else (,Nothing) <$> genCtzGeneric width dst src + +-- | Count trailing zeroes +-- +-- 64-bit width on 32-bit architecture +genCtz64_32 + :: BlockId + -> LocalReg + -> CmmExpr + -> NatM (InstrBlock, Maybe BlockId) +genCtz64_32 bid dst src = do + RegCode64 vcode rhi rlo <- iselExpr64 src + let dst_r = getLocalRegReg dst + lbl1 <- getBlockIdNat + lbl2 <- getBlockIdNat + tmp_r <- getNewRegNat II64 + + -- New CFG Edges: + -- bid -> lbl2 + -- bid -> lbl1 -> lbl2 + -- We also changes edges originating at bid to start at lbl2 instead. + weights <- getCfgWeights + updateCfgNat (addWeightEdge bid lbl1 110 . + addWeightEdge lbl1 lbl2 110 . + addImmediateSuccessor weights bid lbl2) + + -- The following instruction sequence corresponds to the pseudo-code + -- + -- if (src) { + -- dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32); + -- } else { + -- dst = 64; + -- } + let instrs = vcode `appOL` toOL + ([ MOV II32 (OpReg rhi) (OpReg tmp_r) + , OR II32 (OpReg rlo) (OpReg tmp_r) + , MOV II32 (OpImm (ImmInt 64)) (OpReg dst_r) + , JXX EQQ lbl2 + , JXX ALWAYS lbl1 + + , NEWBLOCK lbl1 + , BSF II32 (OpReg rhi) dst_r + , ADD II32 (OpImm (ImmInt 32)) (OpReg dst_r) + , BSF II32 (OpReg rlo) tmp_r + , CMOV NE II32 (OpReg tmp_r) dst_r + , JXX ALWAYS lbl2 + + , NEWBLOCK lbl2 + ]) + return (instrs, Just lbl2) + +-- | Count trailing zeroes +-- +-- Generic case (width <= word size) +genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock +genCtzGeneric width dst src = do + code_src <- getAnyReg src + config <- getConfig + let bw = widthInBits width + let dst_r = getLocalRegReg dst + if ncgBmiVersion config >= Just BMI2 + then do + src_r <- getNewRegNat (intFormat width) + let instrs = appOL (code_src src_r) $ case width of + W8 -> toOL + [ OR II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r) + , TZCNT II32 (OpReg src_r) dst_r + ] + W16 -> toOL + [ TZCNT II16 (OpReg src_r) dst_r + , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) + ] + _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r + return instrs + else do + -- The following insn sequence makes sure 'ctz 0' has a defined value. + -- starting with Haswell, one could use the TZCNT insn instead. + let format = if width == W8 then II16 else intFormat width + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + let instrs = code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSF format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits + return instrs + + + +-- | Copy memory +-- +-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf +-- ncgInlineThresholdMemcpy). Otherwise, call C's memcpy. +genMemCpy + :: BlockId + -> Int + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genMemCpy bid align dst src arg_n = do + + let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n] + + case arg_n of + CmmLit (CmmInt n _) -> do + -- try to inline it + mcode <- genMemCpyInlineMaybe align dst src n + -- if it didn't inline, call the C function + case mcode of + Nothing -> libc_memcpy + Just c -> pure c + + -- not a literal size argument: call the C function + _ -> libc_memcpy + + + +genMemCpyInlineMaybe + :: Int + -> CmmExpr + -> CmmExpr + -> Integer + -> NatM (Maybe InstrBlock) +genMemCpyInlineMaybe align dst src n = do + config <- getConfig + let + platform = ncgPlatform config + maxAlignment = wordAlignment platform + -- only machine word wide MOVs are supported + effectiveAlignment = min (alignmentOf align) maxAlignment + format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment + + + -- The size of each move, in bytes. + let sizeBytes :: Integer + sizeBytes = fromIntegral (formatInBytes format) + + -- The number of instructions we will generate (approx). We need 2 + -- instructions per move. + let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes) + + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL + where + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + + if insns > fromIntegral (ncgInlineThresholdMemcpy config) + then pure Nothing + else do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat format + code_src <- getAnyReg src + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format + pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r (fromInteger n) + +-- | Set memory to the given byte +-- +-- Unroll memset calls if the number of bytes to copy isn't too large (cf +-- ncgInlineThresholdMemset). Otherwise, call C's memset. +genMemSet + :: BlockId + -> Int + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM InstrBlock +genMemSet bid align dst arg_c arg_n = do + + let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n] + + case (arg_c,arg_n) of + (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do + -- try to inline it + mcode <- genMemSetInlineMaybe align dst c n + -- if it didn't inline, call the C function + case mcode of + Nothing -> libc_memset + Just c -> pure c + + -- not literal size arguments: call the C function + _ -> libc_memset + +genMemSetInlineMaybe + :: Int + -> CmmExpr + -> Integer + -> Integer + -> NatM (Maybe InstrBlock) +genMemSetInlineMaybe align dst c n = do + config <- getConfig + let + platform = ncgPlatform config + maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported + effectiveAlignment = min (alignmentOf align) maxAlignment + format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + c8 = c4 `shiftL` 32 .|. c4 + + -- The number of instructions we will generate (approx). We need 1 + -- instructions per move. + insns = (n + sizeBytes - 1) `div` sizeBytes + + -- The size of each move, in bytes. + sizeBytes :: Integer + sizeBytes = fromIntegral (formatInBytes format) + + -- Depending on size returns the widest MOV instruction and its + -- width. + gen4 :: AddrMode -> Integer -> (InstrBlock, Integer) + gen4 addr size + | size >= 4 = + (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4) + | size >= 2 = + (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2) + | size >= 1 = + (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1) + | otherwise = (nilOL, 0) + + -- Generates a 64-bit wide MOV instruction from REG to MEM. + gen8 :: AddrMode -> Reg -> InstrBlock + gen8 addr reg8byte = + unitOL (MOV format (OpReg reg8byte) (OpAddr addr)) + + -- Unrolls memset when the widest MOV is <= 4 bytes. + go4 :: Reg -> Integer -> InstrBlock + go4 dst left = + if left <= 0 then nilOL + else curMov `appOL` go4 dst (left - curWidth) + where + possibleWidth = min left sizeBytes + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) + (curMov, curWidth) = gen4 dst_addr possibleWidth + + -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg + -- argument). Falls back to go4 when all 8 byte moves are + -- exhausted. + go8 :: Reg -> Reg -> Integer -> InstrBlock + go8 dst reg8byte left = + if possibleWidth >= 8 then + let curMov = gen8 dst_addr reg8byte + in curMov `appOL` go8 dst reg8byte (left - 8) + else go4 dst left + where + possibleWidth = min left sizeBytes + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left)) + + if fromInteger insns > ncgInlineThresholdMemset config + 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 + tmp <- getNewRegNat II32 + -- Swap the low and high halves of the register. + -- + -- NB: if dst_hi == rhi, we must make sure to preserve the contents + -- of rhi before writing to dst_hi (#25601). + let shuffle = if dst_hi == rhi && dst_lo == rlo then + toOL [ MOV II32 (OpReg rhi) (OpReg tmp), + MOV II32 (OpReg rlo) (OpReg dst_hi), + MOV II32 (OpReg tmp) (OpReg dst_lo) ] + else if dst_hi == rhi then + toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo), + MOV II32 (OpReg rlo) (OpReg dst_hi) ] + else + toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi), + MOV II32 (OpReg rhi) (OpReg dst_lo) ] + return $ vcode `appOL` shuffle `appOL` + toOL [ 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)] diff --git a/GHC/CmmToAsm/X86/Instr.hs b/GHC/CmmToAsm/X86/Instr.hs --- a/GHC/CmmToAsm/X86/Instr.hs +++ b/GHC/CmmToAsm/X86/Instr.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -30,12 +32,14 @@ , mkStackDeallocInstr , mkSpillInstr , mkRegRegMoveInstr + , movInstr , jumpDestsOfInstr , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr , isJumpishInstr + , MinOrMax(..), MinMaxType(..) ) where @@ -45,19 +49,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.Collections 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 @@ -65,11 +70,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. -- @@ -81,96 +87,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 @@ -197,12 +113,29 @@ -- 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/MOVQ SSE2 instructions + -- (bitcast between a general purpose register and a float register). + | MOVD + Format -- ^ input format + Format -- ^ output format + Operand Operand + -- NB: MOVD stores both the input and output formats. This is because + -- neither format fully determines the other, as either might be + -- a vector format, and we need to know the exact format in order to + -- correctly spill/unspill. See #25659. | CMOV Cond Format Operand Reg | MOVZxL Format Operand Operand -- ^ The format argument is the size of operand 1 (the number of bits we keep) @@ -242,6 +175,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 @@ -250,6 +185,8 @@ | SHL Format Operand{-amount-} Operand | SAR Format Operand{-amount-} Operand | SHR Format Operand{-amount-} Operand + | SHRD Format Operand{-amount-} Operand Operand + | SHLD Format Operand{-amount-} Operand Operand | BT Format Imm Operand | NOP @@ -258,7 +195,7 @@ -- We need to support the FSTP (x87 store and pop) instruction -- so that we can correctly read off the return value of an -- x86 CDECL C function call when its floating point. - -- so we dont include a register argument, and just use st(0) + -- so we don't include a register argument, and just use st(0) -- this instruction is used ONLY for return values of C ffi calls -- in x86_32 abi | X87Store Format AddrMode -- st(0), dst @@ -276,14 +213,15 @@ -- | 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. -- SSE2 floating-point division: - | FDIV Format Operand Operand -- divisor, dividend(dst) + | FDIV Format Operand Reg -- divisor, dividend(dst) -- use CMP for comparisons. ucomiss and ucomisd instructions -- compare single/double prec floating point respectively. @@ -304,7 +242,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 @@ -314,7 +252,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 @@ -350,8 +288,110 @@ | 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 + | VPBROADCAST Format Format Operand Reg -- scalar format, vector format, source, destination + | VEXTRACT Format Imm Reg Operand + | INSERTPS Format Imm Operand Reg + | VINSERTPS Format Imm Operand Reg Reg + | PINSR Format Format Imm Operand Reg -- scalar format, vector format, offset, scalar src, vector + | PEXTR Format Format Imm Reg Operand -- scalar format, vector format, offset, vector src, scalar dst + + -- move operations + + -- | 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 + -- | Alias for VMOVSS/VMOVSD, used to merge two vectors + | VMOV_MERGE Format Reg Reg Reg + + -- logic operations + | PXOR Format Operand Reg + | VPXOR Format Reg Reg Reg + | PAND Format Operand Reg + | PANDN Format Operand Reg + | POR Format Operand Reg + + -- Arithmetic + | VADD Format Operand Reg Reg + | VSUB Format Operand Reg Reg + | VMUL Format Operand Reg Reg + | VDIV Format Operand Reg Reg + | PADD Format Operand Reg + | PSUB Format Operand Reg + | PMULL Format Operand Reg + | PMULUDQ Format Operand Reg + + -- SIMD compare + | PCMPGT Format Operand Reg + + -- Shuffle + | SHUF Format Imm Operand Reg + | VSHUF Format Imm Operand Reg Reg + | PSHUFB Format Operand Reg + | PSHUFLW Format Imm Operand Reg + | PSHUFHW Format Imm Operand Reg + | PSHUFD Format Imm Operand Reg + | VPSHUFD Format Imm Operand Reg + | BLEND Format Imm Operand Reg + | VBLEND Format Imm Operand Reg Reg + | PBLENDW Format Imm Operand Reg + + -- | Move two 32-bit floats from the high part of an xmm register + -- to the low part of another xmm register. + -- + -- If the format is a vector format, the destination register is treated as the second source. + -- If the format is FF32 or FF64, the destination register is not treated as a source. + | MOVHLPS Format Reg Reg + | VMOVHLPS Format Reg Reg Reg + | MOVLHPS Format Reg Reg + | VMOVLHPS Format Reg Reg Reg + | UNPCKL Format Operand Reg + | VUNPCKL Format Operand Reg Reg + | UNPCKH Format Operand Reg + | VUNPCKH Format Operand Reg Reg + | PUNPCKLQDQ Format Operand Reg + | PUNPCKLDQ Format Operand Reg + | PUNPCKLWD Format Operand Reg + | PUNPCKLBW Format Operand Reg + | PUNPCKHQDQ Format Operand Reg + | PUNPCKHDQ Format Operand Reg + | PUNPCKHWD Format Operand Reg + | PUNPCKHBW Format Operand Reg + | PACKUSWB Format Operand Reg + + -- Shift + | PSLL Format Operand Reg + | PSLLDQ Format Imm Reg + | PSRL Format Operand Reg + | PSRLDQ Format Imm Reg + | PALIGNR Format Imm Operand Reg + + -- min/max + | MINMAX MinOrMax MinMaxType Format Operand Reg + | 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 @@ -366,98 +406,254 @@ 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 fmt1 fmt2 src dst -> + -- NB: MOVD and MOVQ always zero any remaining upper part of destination, + -- so the destination is "written" not "modified". + usageRW' fmt1 fmt2 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 - 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 -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + SQRT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst] - FETCHGOT reg -> mkRU [] [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] + VPBROADCAST sFmt vFmt src dst -> mkRU (use_R sFmt src []) [mk vFmt dst] + VEXTRACT fmt _off src dst -> usageRW fmt (OpReg src) dst + INSERTPS fmt (ImmInt off) src dst + -> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst] + 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] + VINSERTPS fmt _imm src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + PINSR sFmt vFmt _off src dst + -> mkRU (use_R sFmt src [mk vFmt dst]) [mk vFmt dst] + PEXTR sFmt vFmt _off src dst + -> usageRW' vFmt sFmt (OpReg src) dst + + VMOVU fmt src dst -> usageRW fmt src dst + MOVU fmt src dst -> usageRW fmt src dst + 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 + VMOV_MERGE fmt src2 src1 dst -> mkRU [mk fmt src1, mk fmt src2] [mk fmt 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] + + PAND fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PANDN fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + POR fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + VADD fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + VSUB fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + VMUL fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + VDIV fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst] + PADD fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PSUB fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PMULL fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PMULUDQ fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + PCMPGT fmt src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + SHUF fmt _mask src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VSHUF fmt _mask src1 src2 dst + -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst] + PSHUFB fmt mask dst + -> mkRU (use_R fmt mask [mk fmt dst]) [mk fmt dst] + PSHUFLW fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + PSHUFHW fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + PSHUFD fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + VPSHUFD fmt _mask src dst + -> mkRU (use_R fmt src []) [mk fmt dst] + BLEND fmt _mask src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VBLEND fmt _mask src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + PBLENDW fmt _mask src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + PSLL fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst] + PSLLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst] + PSRL fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst] + PSRLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst] + PALIGNR fmt _off src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + MOVHLPS fmt src dst + -> case fmt of + VecFormat {} -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst] + -- MOVHLPS moves the high 64 bits of src to the low 64 bits of dst, + -- keeping the high 64 bits of dst intact. + -- If we only care about the lower 64 bits of the result, + -- dst is only written to, not read. + FF64 -> mkRU [mk (VecFormat 2 FmtDouble) src] [mk fmt dst] + FF32 -> mkRU [mk (VecFormat 4 FmtFloat) src] [mk fmt dst] + _ -> pprPanic "regUsage: invalid format for MOVHLPS" (ppr fmt) + VMOVHLPS fmt src2 src1 dst + -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst] + MOVLHPS fmt src dst + -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst] + VMOVLHPS fmt src2 src1 dst + -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst] + UNPCKL fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VUNPCKL fmt src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + UNPCKH fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VUNPCKH fmt src2 src1 dst + -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst] + PUNPCKLQDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKLDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKLWD fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKLBW fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHQDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHDQ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHWD fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PUNPCKHBW fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + PACKUSWB fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + + MINMAX _ _ fmt src dst + -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst] + VMINMAX _ _ fmt src1 src2 dst + -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst] _other -> panic "regUsage: unrecognised instr" where + -- # Definitions -- -- Written: If the operand is a register, it's written. If it's an @@ -468,84 +664,102 @@ -- 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 - -- | 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 fmt1 fmt2 src dst -> patch2 (MOVD fmt1 fmt2) 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 @@ -565,12 +779,15 @@ 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 SHL fmt imm dst -> patch1 (SHL fmt imm) dst SAR fmt imm dst -> patch1 (SAR fmt imm) dst SHR fmt imm dst -> patch1 (SHR fmt imm) dst + SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2 + SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2 BT fmt imm src -> patch1 (BT fmt imm) src TEST fmt src dst -> patch2 (TEST fmt) src dst CMP fmt src dst -> patch2 (CMP fmt) src dst @@ -591,7 +808,7 @@ CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst) CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst) CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst) - FDIV fmt src dst -> FDIV fmt (patchOp src) (patchOp dst) + FDIV fmt src dst -> FDIV fmt (patchOp src) (env dst) SQRT fmt src dst -> SQRT fmt (patchOp src) (env dst) CALL (Left _) _ -> instr @@ -605,6 +822,8 @@ LOCATION {} -> instr UNWIND {} -> instr DELTA _ -> instr + LDATA {} -> instr + NEWBLOCK {} -> instr JXX _ _ -> instr JXX_GBL _ _ -> instr @@ -620,14 +839,124 @@ 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) + VPBROADCAST fmt1 fmt2 src dst + -> VPBROADCAST fmt1 fmt2 (patchOp src) (env dst) + VEXTRACT fmt off src dst + -> VEXTRACT fmt off (env src) (patchOp dst) + INSERTPS fmt off src dst + -> INSERTPS fmt off (patchOp src) (env dst) + VINSERTPS fmt off src2 src1 dst + -> VINSERTPS fmt off (patchOp src2) (env src1) (env dst) + PINSR fmt1 fmt2 off src dst + -> PINSR fmt1 fmt2 off (patchOp src) (env dst) + PEXTR fmt1 fmt2 off src dst + -> PEXTR fmt1 fmt2 off (env src) (patchOp dst) + VMOVU fmt src dst -> VMOVU fmt (patchOp src) (patchOp dst) + MOVU fmt src dst -> MOVU fmt (patchOp src) (patchOp dst) + 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) + VMOV_MERGE fmt src2 src1 dst -> VMOV_MERGE fmt (env src2) (env src1) (env dst) + + PXOR fmt src dst -> PXOR fmt (patchOp src) (env dst) + VPXOR fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst) + PAND fmt src dst -> PAND fmt (patchOp src) (env dst) + PANDN fmt src dst -> PANDN fmt (patchOp src) (env dst) + POR fmt src dst -> POR fmt (patchOp src) (env dst) + + VADD fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst) + VSUB fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst) + VMUL fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst) + VDIV fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst) + PADD fmt src dst -> PADD fmt (patchOp src) (env dst) + PSUB fmt src dst -> PSUB fmt (patchOp src) (env dst) + PMULL fmt src dst -> PMULL fmt (patchOp src) (env dst) + PMULUDQ fmt src dst -> PMULUDQ fmt (patchOp src) (env dst) + + PCMPGT fmt src dst -> PCMPGT fmt (patchOp src) (env dst) + + SHUF fmt off src dst + -> SHUF fmt off (patchOp src) (env dst) + VSHUF fmt off src1 src2 dst + -> VSHUF fmt off (patchOp src1) (env src2) (env dst) + PSHUFB fmt mask dst + -> PSHUFB fmt (patchOp mask) (env dst) + PSHUFLW fmt off src dst + -> PSHUFLW fmt off (patchOp src) (env dst) + PSHUFHW fmt off src dst + -> PSHUFHW fmt off (patchOp src) (env dst) + PSHUFD fmt off src dst + -> PSHUFD fmt off (patchOp src) (env dst) + VPSHUFD fmt off src dst + -> VPSHUFD fmt off (patchOp src) (env dst) + BLEND fmt mask src dst + -> BLEND fmt mask (patchOp src) (env dst) + VBLEND fmt mask src2 src1 dst + -> VBLEND fmt mask (patchOp src2) (env src1) (env dst) + PBLENDW fmt mask src dst + -> PBLENDW fmt mask (patchOp src) (env dst) + + PSLL fmt off dst + -> PSLL fmt (patchOp off) (env dst) + PSLLDQ fmt off dst + -> PSLLDQ fmt off (env dst) + PSRL fmt off dst + -> PSRL fmt (patchOp off) (env dst) + PSRLDQ fmt off dst + -> PSRLDQ fmt off (env dst) + PALIGNR fmt off src dst + -> PALIGNR fmt off (patchOp src) (env dst) + + MOVHLPS fmt src dst + -> MOVHLPS fmt (env src) (env dst) + VMOVHLPS fmt src2 src1 dst + -> VMOVHLPS fmt (env src2) (env src1) (env dst) + MOVLHPS fmt src dst + -> MOVLHPS fmt (env src) (env dst) + VMOVLHPS fmt src2 src1 dst + -> VMOVLHPS fmt (env src2) (env src1) (env dst) + UNPCKL fmt src dst + -> UNPCKL fmt (patchOp src) (env dst) + VUNPCKL fmt src2 src1 dst + -> VUNPCKL fmt (patchOp src2) (env src1) (env dst) + UNPCKH fmt src dst + -> UNPCKH fmt (patchOp src) (env dst) + VUNPCKH fmt src2 src1 dst + -> VUNPCKH fmt (patchOp src2) (env src1) (env dst) + PUNPCKLQDQ fmt src dst + -> PUNPCKLQDQ fmt (patchOp src) (env dst) + PUNPCKLDQ fmt src dst + -> PUNPCKLDQ fmt (patchOp src) (env dst) + PUNPCKLWD fmt src dst + -> PUNPCKLWD fmt (patchOp src) (env dst) + PUNPCKLBW fmt src dst + -> PUNPCKLBW fmt (patchOp src) (env dst) + PUNPCKHQDQ fmt src dst + -> PUNPCKHQDQ fmt (patchOp src) (env dst) + PUNPCKHDQ fmt src dst + -> PUNPCKHDQ fmt (patchOp src) (env dst) + PUNPCKHWD fmt src dst + -> PUNPCKHWD fmt (patchOp src) (env dst) + PUNPCKHBW fmt src dst + -> PUNPCKHBW fmt (patchOp src) (env dst) + PACKUSWB fmt src dst + -> PACKUSWB fmt (patchOp src) (env dst) + + MINMAX minMax ty fmt src dst + -> MINMAX minMax ty fmt (patchOp src) (env 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 @@ -708,42 +1037,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 @@ -794,37 +1190,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 @@ -871,7 +1316,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 @@ -901,18 +1345,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 -> @@ -982,13 +1417,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 @@ -997,8 +1432,6 @@ alloc = mkStackAllocInstr platform delta dealloc = mkStackDeallocInstr platform delta - retargetList = (zip entries (map mkBlockId uniqs)) - new_blockmap :: LabelMap BlockId new_blockmap = mapFromList retargetList @@ -1028,6 +1461,7 @@ ppr (DestBlockId bid) = text "jd:" <> ppr bid ppr (DestImm _imm) = text "jd:noShow" +-- Implementations of the methods of 'NgcImpl' getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid @@ -1038,7 +1472,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 @@ -1071,7 +1504,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 @@ -1086,15 +1519,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 diff --git a/GHC/CmmToAsm/X86/Ppr.hs b/GHC/CmmToAsm/X86/Ppr.hs --- a/GHC/CmmToAsm/X86/Ppr.hs +++ b/GHC/CmmToAsm/X86/Ppr.hs @@ -32,7 +32,6 @@ import GHC.CmmToAsm.Ppr import GHC.Cmm hiding (topInfoTable) -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -44,6 +43,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List ( intersperse ) import Data.Word -- Note [Subsections Via Symbols] @@ -72,45 +72,71 @@ 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 use + -- the entry label. + proc_lbl = case top_info_table of + Just (CmmStaticsRaw info_lbl _) -> info_lbl + Nothing -> 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) @@ -119,8 +145,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 @@ -137,16 +162,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 @@ -156,7 +181,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] @@ -292,16 +317,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 { @@ -319,20 +344,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 { @@ -373,7 +398,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"; @@ -383,11 +408,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" @@ -397,6 +446,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 @@ -406,6 +456,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 "d" + VecFormat _ FmtInt64 -> text "q" pprFormat_x87 :: IsLine doc => Format -> doc pprFormat_x87 x = case x of @@ -506,35 +563,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 @@ -586,12 +647,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 format1 format2 src dst + -> pprMovdOpOp (text "mov") format1 format2 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 @@ -678,14 +746,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) @@ -732,6 +806,12 @@ SHR format src dst -> pprShift (text "shr") format src dst + SHLD format src dst1 dst2 + -> pprShift2 (text "shld") format src dst1 dst2 + + SHRD format src dst1 dst2 + -> pprShift2 (text "shrd") format src dst1 dst2 + BT format imm src -> pprFormatImmOp (text "bt") format imm src @@ -835,7 +915,7 @@ -> pprFormatOp (text "mul") format op FDIV format op1 op2 - -> pprFormatOpOp (text "div") format op1 op2 + -> pprFormatOpReg (text "div") format op1 op2 FMA3 format var perm op1 op2 op3 -> let mnemo = case var of @@ -901,7 +981,151 @@ 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 + PADD format src dst + -> pprFormatOpReg (text "padd") format src dst + PSUB format src dst + -> pprFormatOpReg (text "psub") format src dst + PMULL format src dst + -> pprFormatOpReg (text "pmull") format src dst + PMULUDQ format src dst + -> pprOpReg (text "pmuludq") format src dst + PCMPGT format src dst + -> pprFormatOpReg (text "pcmpgt") format src dst + VBROADCAST format@(VecFormat _ sFmt) from to + -> pprBroadcast (text "vbroadcast") (scalarFormatFormat sFmt) format from to + VBROADCAST format _ _ + -> pprPanic "VBROADCAST: expected vector format" (ppr format) + VPBROADCAST scalarFormat format from to + -> pprBroadcast (text "vpbroadcast") scalarFormat format from to + VMOVU format from to + -> pprFormatOpOp (text "vmovu") format from to + MOVU format from to + -> 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" + VMOV_MERGE format src2 src1 dst + -> pprRegRegReg instr format src2 src1 dst + where instr = case format of + VecFormat _ FmtFloat -> text "vmovss" + VecFormat _ FmtDouble -> text "vmovsd" + _ -> pprPanic "invalid format for VMOV_MERGE" (ppr format) + + PXOR format src dst + -> pprPXor (text "pxor") format src dst + VPXOR format s1 s2 dst + -> pprXor (text "vpxor") format s1 s2 dst + PAND format src dst + -> pprOpReg (text "pand") format src dst + PANDN format src dst + -> pprOpReg (text "pandn") format src dst + POR format src dst + -> pprOpReg (text "por") format src dst + VEXTRACT format offset from to + -> pprFormatImmRegOp (text "vextract") format offset from to + INSERTPS format offset addr dst + -> pprInsert (text "insertps") format offset addr dst + VINSERTPS format offset src2 src1 dst + -> pprImmOpRegReg (text "vinsertps") format offset src2 src1 dst + PINSR scalarFormat vectorFormat offset src dst + -> pprPinsr (text "pinsr") scalarFormat vectorFormat offset src dst + PEXTR scalarFormat vectorFormat offset src dst + -> pprPextr (text "pextr") scalarFormat vectorFormat offset src dst + + SHUF format offset src dst + -> pprShuf (text "shuf" <> pprFormat format) format offset src dst + VSHUF format offset src1 src2 dst + -> pprVShuf (text "vshuf" <> pprFormat format) format offset src1 src2 dst + PSHUFB format mask dst + -> pprOpReg (text "pshufb") format mask dst + PSHUFLW format offset src dst + -> pprShuf (text "pshuflw") format offset src dst + PSHUFHW format offset src dst + -> pprShuf (text "pshufhw") format offset src dst + PSHUFD format offset src dst + -> pprShuf (text "pshufd") format offset src dst + VPSHUFD format offset src dst + -> pprShuf (text "vpshufd") format offset src dst + BLEND format mask src dst + -> pprFormatImmOpReg (text "blend") format mask src dst + VBLEND format mask src2 src1 dst + -> pprFormatImmOpRegReg (text "vblend") format mask src2 src1 dst + PBLENDW format mask src dst + -> pprShuf (text "pblendw") format mask src dst + + PSLL format offset dst + -> pprFormatOpReg (text "psll") format offset dst + PSLLDQ format offset dst + -> pprDoubleShift (text "pslldq") format offset dst + PSRL format offset dst + -> pprFormatOpReg (text "psrl") format offset dst + PSRLDQ format offset dst + -> pprDoubleShift (text "psrldq") format offset dst + PALIGNR format offset src dst + -> pprImmOpReg (text "palignr") format offset src dst + + MOVHLPS format from to + -> pprOpReg (text "movhlps") format (OpReg from) to + VMOVHLPS format src2 src1 dst + -> pprRegRegReg (text "vmovhlps") format src2 src1 dst + MOVLHPS format from to + -> pprOpReg (text "movlhps") format (OpReg from) to + VMOVLHPS format src2 src1 dst + -> pprRegRegReg (text "vmovlhps") format src2 src1 dst + UNPCKL format src dst + -> pprFormatOpReg (text "unpckl") format src dst + VUNPCKL format src2 src1 dst + -> pprFormatOpRegReg (text "vunpckl") format src2 src1 dst + UNPCKH format src dst + -> pprFormatOpReg (text "unpckh") format src dst + VUNPCKH format src2 src1 dst + -> pprFormatOpRegReg (text "vunpckh") format src2 src1 dst + PUNPCKLQDQ format from to + -> pprOpReg (text "punpcklqdq") format from to + PUNPCKLDQ format from to + -> pprOpReg (text "punpckldq") format from to + PUNPCKLWD format from to + -> pprOpReg (text "punpcklwd") format from to + PUNPCKLBW format from to + -> pprOpReg (text "punpcklbw") format from to + PUNPCKHQDQ format from to + -> pprOpReg (text "punpckhqdq") format from to + PUNPCKHDQ format from to + -> pprOpReg (text "punpckhdq") format from to + PUNPCKHWD format from to + -> pprOpReg (text "punpckhwd") format from to + PUNPCKHBW format from to + -> pprOpReg (text "punpckhbw") format from to + PACKUSWB format from to + -> pprOpReg (text "packuswb") format from to + + MINMAX minMax ty fmt src dst + -> pprMinMax False minMax ty fmt [src, OpReg 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' @@ -940,6 +1164,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 [ @@ -950,7 +1193,6 @@ pprOperand platform format op1 ] - pprFormatOp_ :: Line doc -> Format -> Operand -> doc pprFormatOp_ name format op1 = line $ hcat [ @@ -975,15 +1217,43 @@ pprOperand platform format op2 ] + pprMovdOpOp :: Line doc -> Format -> Format -> Operand -> Operand -> doc + pprMovdOpOp name format1 format2 op1 op2 + = let instr = case (format1, format2) of + -- bitcasts to/from a general purpose register to a floating point + -- register require II32 or II64. + (II32, _) -> text "d" + (II64, _) -> text "q" + (_, II32) -> text "d" + (_, II64) -> text "q" + _ -> panic "X86.Ppr.pprMovdOpOp: improper format for movd/movq." + in line $ hcat [ + char '\t' <> name <> instr <> space, + pprOperand platform format1 op1, + comma, + pprOperand platform format2 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 @@ -1009,7 +1279,27 @@ pprReg platform (archWordFormat (target32Bit platform)) reg2 ] + pprRegRegReg :: Line doc -> Format -> Reg -> Reg -> Reg -> doc + pprRegRegReg name format reg1 reg2 reg3 + = line $ hcat [ + pprMnemonic_ name, + pprReg platform format reg1, + comma, + pprReg platform format reg2, + comma, + pprReg platform format reg3 + ] + pprOpReg :: Line doc -> Format -> Operand -> Reg -> doc + pprOpReg name format op reg + = line $ hcat [ + 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 [ @@ -1070,7 +1360,18 @@ pprOperand platform format dest ] + pprShift2 :: Line doc -> Format -> Operand -> Operand -> Operand -> doc + pprShift2 name format src dest1 dest2 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform II8 src, -- src is 8-bit sized + comma, + pprOperand platform format dest1, + comma, + pprOperand platform format dest2 + ] + pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc pprFormatOpOpCoerce name format1 format2 op1 op2 = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, @@ -1083,3 +1384,179 @@ 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 -> Format -> Operand -> Reg -> doc + pprBroadcast name scalarFormat vectorFormat op dst + = line $ hcat [ + pprBroadcastMnemonic name vectorFormat, + pprOperand platform scalarFormat op, + comma, + pprReg platform vectorFormat dst + ] + + 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 + ] + + pprPinsr :: Line doc -> Format -> Format -> Imm -> Operand -> Reg -> doc + pprPinsr name scalarFormat vectorFormat imm src dst + = line $ hcat [ + pprMnemonic name vectorFormat, + pprDollImm imm, + comma, + pprOperand platform scalarFormat src, + comma, + pprReg platform vectorFormat dst + ] + + pprPextr :: Line doc -> Format -> Format -> Imm -> Reg -> Operand -> doc + pprPextr name scalarFormat vectorFormat imm src dst + = line $ hcat [ + pprMnemonic name vectorFormat, + pprDollImm imm, + comma, + pprReg platform vectorFormat src, + comma, + pprOperand platform scalarFormat dst + ] + + pprShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprShuf name format imm1 op2 reg3 + = line $ hcat [ + 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 -> Imm -> Reg -> doc + pprDoubleShift name format off reg + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm off, + comma, + pprReg platform format reg + ] + + pprImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprImmOpReg name format imm1 op2 reg3 + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + pprFormatImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc + pprFormatImmOpReg name format imm1 op2 reg3 + = line $ hcat [ + pprMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3 + ] + + pprImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc + pprImmOpRegReg name format imm1 op2 reg3 reg4 + = line $ hcat [ + pprGenMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3, + comma, + pprReg platform format reg4 + ] + + pprFormatImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc + pprFormatImmOpRegReg name format imm1 op2 reg3 reg4 + = line $ hcat [ + pprMnemonic name format, + pprDollImm imm1, + comma, + pprOperand platform format op2, + comma, + pprReg platform format reg3, + comma, + pprReg platform format reg4 + ] + + pprMinMax :: Bool -> MinOrMax -> MinMaxType -> Format -> [Operand] -> doc + 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 diff --git a/GHC/CmmToAsm/X86/RegInfo.hs b/GHC/CmmToAsm/X86/RegInfo.hs --- a/GHC/CmmToAsm/X86/RegInfo.hs +++ b/GHC/CmmToAsm/X86/RegInfo.hs @@ -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 @@ -68,5 +67,4 @@ -- ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8" -- ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb" -- ,"#d2d2d2","#d9d9d9","#e0e0e0"] - diff --git a/GHC/CmmToAsm/X86/Regs.hs b/GHC/CmmToAsm/X86/Regs.hs --- a/GHC/CmmToAsm/X86/Regs.hs +++ b/GHC/CmmToAsm/X86/Regs.hs @@ -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 dont 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 diff --git a/GHC/CmmToC.hs b/GHC/CmmToC.hs --- a/GHC/CmmToC.hs +++ b/GHC/CmmToC.hs @@ -38,8 +38,8 @@ import GHC.Cmm.CLabel import GHC.Cmm hiding (pprBBlock, pprStatic) import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Label import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.InitFini @@ -243,16 +243,9 @@ 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) -> + | not (isLibcFun lbl) -> pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs _ -> pprCall platform cast_fn cconv hresults hargs <> semi @@ -261,6 +254,13 @@ CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty + CmmUnsafeForeignCall (PrimTarget MO_ReleaseFence) [] [] -> + text "__atomic_thread_fence(__ATOMIC_RELEASE);" + CmmUnsafeForeignCall (PrimTarget MO_AcquireFence) [] [] -> + text "__atomic_thread_fence(__ATOMIC_ACQUIRE);" + CmmUnsafeForeignCall (PrimTarget MO_SeqCstFence) [] [] -> + text "__atomic_thread_fence(__ATOMIC_SEQ_CST);" + CmmUnsafeForeignCall target@(PrimTarget op) results args -> fn_call where @@ -433,6 +433,9 @@ where isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False +pprMachOpApp platform (MO_RelaxedRead w) [x] + = pprExpr platform (CmmLoad x (cmmBits w) NaturallyAligned) + pprMachOpApp platform mop args | Just ty <- machOpNeedsCast platform mop (map (cmmExprType platform) args) = ty <> parens (pprMachOpApp' platform mop args) @@ -532,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" @@ -698,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. @@ -774,102 +794,149 @@ -- 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") + (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" + ++ " should have been handled earlier!") + MO_S_MulMayOflo _ -> pprTrace "offending mop:" (text "MO_S_MulMayOflo") (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!") - - MO_VS_Quot {} -> pprTrace "offending mop:" - (text "MO_VS_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot" - ++ " should have been handled earlier!") - 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!") - - MO_VU_Quot {} -> pprTrace "offending mop:" - (text "MO_VU_Quot") - (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" - ++ " should have been handled earlier!") - 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 @@ -881,7 +948,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 @@ -944,8 +1011,9 @@ MO_F32_ExpM1 -> text "expm1f" MO_F32_Sqrt -> text "sqrtf" MO_F32_Fabs -> text "fabsf" - MO_ReadBarrier -> text "load_load_barrier" - MO_WriteBarrier -> text "write_barrier" + MO_AcquireFence -> unsupported + MO_ReleaseFence -> unsupported + MO_SeqCstFence -> unsupported MO_Memcpy _ -> text "__builtin_memcpy" MO_Memset _ -> text "__builtin_memset" MO_Memmove _ -> text "__builtin_memmove" @@ -979,6 +1047,14 @@ MO_AddIntC {} -> unsupported MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported + MO_VS_Quot {} -> unsupported + MO_VS_Rem {} -> unsupported + MO_VU_Quot {} -> unsupported + MO_VU_Rem {} -> unsupported + MO_I64X2_Min -> unsupported + MO_I64X2_Max -> unsupported + MO_W64X2_Min -> unsupported + MO_W64X2_Max -> unsupported MO_Touch -> unsupported -- we could support prefetch via "__builtin_prefetch" -- Not adding it for now @@ -1222,7 +1298,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 @@ -1243,14 +1318,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) @@ -1431,7 +1498,6 @@ doubleToWord64 :: Rational -> CmmLit doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64 - -- --------------------------------------------------------------------------- -- Utils @@ -1513,12 +1579,15 @@ pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc pprCtorArray platform initOrFini lbls = decls - <> text "static __attribute__((" <> attribute <> text "))" - <> text "void _hs_" <> attribute <> text "()" + <> text "static __attribute__((" <> text attribute <> text "))" + <> text "void _hs_" <> text suffix <> text "()" <> braces body where body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ] decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ] - attribute = case initOrFini of - IsInitArray -> text "constructor" - IsFiniArray -> text "destructor" + (attribute, suffix) = case initOrFini of + IsInitArray + -- See Note [JSFFI initialization] for details + | ArchWasm32 <- platformArch platform -> ("constructor(101)", "constructor") + | otherwise -> ("constructor", "constructor") + IsFiniArray -> ("destructor", "destructor") diff --git a/GHC/CmmToLlvm.hs b/GHC/CmmToLlvm.hs --- a/GHC/CmmToLlvm.hs +++ b/GHC/CmmToLlvm.hs @@ -11,7 +11,7 @@ ) where -import GHC.Prelude hiding ( head ) +import GHC.Prelude import GHC.Llvm import GHC.CmmToLlvm.Base @@ -21,11 +21,13 @@ import GHC.CmmToLlvm.Ppr import GHC.CmmToLlvm.Regs 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.Collections +import GHC.Cmm.Dataflow.Label +import GHC.Types.Unique.DSM import GHC.Utils.BufHandle import GHC.Driver.DynFlags import GHC.Platform ( platformArch, Arch(..) ) @@ -37,17 +39,18 @@ import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) -import Data.List.NonEmpty ( head ) -import Data.Maybe ( fromMaybe, catMaybes ) +import Data.Maybe ( fromMaybe, catMaybes, isNothing ) 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,12 +71,14 @@ "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "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) + 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..." + -- HACK: the Nothing case here is potentially wrong here but we -- currently don't use the LLVM version to guide code generation -- so this is okay. @@ -81,14 +86,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) @@ -96,7 +102,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 @@ -196,7 +202,7 @@ cmmMetaLlvmPrelude :: LlvmM () cmmMetaLlvmPrelude = do - metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do + tbaa_metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do -- Generate / lookup meta data IDs tbaaId <- getMetaUniqueId setUniqMeta uniq tbaaId @@ -209,9 +215,50 @@ -- just a name on its own. Previously `null` was accepted as the -- name. Nothing -> [ MetaStr name ] + + platform <- getPlatform cfg <- getConfig + let stack_alignment_metas = + case platformArch platform of + ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32] + _ -> [] + let codel_model_metas = + case platformArch platform of + -- FIXME: We should not rely on LLVM + ArchLoongArch64 -> [mkCodeModelMeta CMMedium] + _ -> [] + module_flags_metas <- mkModuleFlagsMeta (stack_alignment_metas ++ codel_model_metas) + let metas = tbaa_metas ++ module_flags_metas + cfg <- getConfig renderLlvm (ppLlvmMetas cfg metas) (ppLlvmMetas cfg metas) + +mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl] +mkNamedMeta name exprs = do + (ids, decls) <- unzip <$> mapM f exprs + return $ decls ++ [MetaNamed name ids] + where + f expr = do + i <- getMetaUniqueId + return (i, MetaUnnamed i expr) + +mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl] +mkModuleFlagsMeta = + mkNamedMeta "llvm.module.flags" . map moduleFlagToMetaExpr + +mkStackAlignmentMeta :: Integer -> ModuleFlag +mkStackAlignmentMeta alignment = + ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32) + +-- LLVM's @LLVM::CodeModel::Model@ enumeration +data CodeModel = CMMedium + +-- Pass -mcmodel=medium option to LLVM on LoongArch64 +mkCodeModelMeta :: CodeModel -> ModuleFlag +mkCodeModelMeta codemodel = + ModuleFlag MFBError "Code Model" (MetaLit $ LMIntLit n i32) + where + n = case codemodel of CMMedium -> 3 -- as of LLVM 8 -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary diff --git a/GHC/CmmToLlvm/Base.hs b/GHC/CmmToLlvm/Base.hs --- a/GHC/CmmToLlvm/Base.hs +++ b/GHC/CmmToLlvm/Base.hs @@ -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, @@ -41,6 +43,7 @@ import GHC.Llvm import GHC.CmmToLlvm.Regs import GHC.CmmToLlvm.Config +import GHC.CmmToLlvm.Version import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) @@ -54,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 @@ -72,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) @@ -115,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, []) @@ -148,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 @@ -178,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. @@ -187,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 @@ -195,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 -- 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+1) -- 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 @@ -269,20 +290,19 @@ -- the following get cleared for every function (see @withClearVars@) , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type - , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) + , envStackRegs :: [GlobalRegUse] -- ^ Non-constant registers (alloca'd in the function prelude) } 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 @@ -290,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 = [] @@ -348,12 +374,14 @@ funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap) -- | Set a register as allocated on the stack -markStackReg :: GlobalReg -> LlvmM () +markStackReg :: GlobalRegUse -> LlvmM () markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } -- | Check whether a register is allocated on the stack -checkStackReg :: GlobalReg -> LlvmM Bool -checkStackReg r = getEnv ((elem r) . envStackRegs) +checkStackReg :: GlobalReg -> LlvmM (Maybe CmmType) +checkStackReg r = do + stack_regs <- getEnv envStackRegs + return $ fmap globalRegUse_type $ lookupRegUse r stack_regs -- | Allocate a new global unnamed metadata identifier getMetaUniqueId :: LlvmM MetaId @@ -412,7 +440,7 @@ -- so as to make sure they have the most general type in the case that -- user code also uses these functions but with a different type than GHC -- internally. (Main offender is treating return type as 'void' instead of --- 'void *'). Fixes trac #5486. +-- 'void *'). Fixes #5486. ghcInternalFunctions :: LlvmM () ghcInternalFunctions = do platform <- getPlatform @@ -498,10 +526,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 diff --git a/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs --- a/GHC/CmmToLlvm/CodeGen.hs +++ b/GHC/CmmToLlvm/CodeGen.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Handle conversion of CmmProc to LLVM code. module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where @@ -24,26 +23,30 @@ import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph -import GHC.Cmm.Dataflow.Collections +import GHC.Cmm.Dataflow.Label import GHC.Data.FastString +import GHC.Data.Maybe (expectJust) 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 GHC.Utils.Panic.Plain (massert) 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.Foldable ( toList ) import Data.List ( nub ) +import qualified Data.List as List +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import Data.Maybe ( catMaybes ) type Atomic = Maybe MemoryOrdering @@ -55,8 +58,8 @@ -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] -genLlvmProc (CmmProc infos lbl live graph) = do - let blocks = toBlockListEntryFirstFalseFallthrough graph +genLlvmProc (CmmProc infos lbl live graph) + | Just blocks <- nonEmpty $ toBlockListEntryFirstFalseFallthrough graph = do (lmblocks, lmdata) <- basicBlocksCodeGen live blocks let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) @@ -68,12 +71,16 @@ -- * 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 -> NonEmpty CmmBlock -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) -basicBlocksCodeGen _ [] = panic "no entry block!" basicBlocksCodeGen live cmmBlocks = do -- Emit the prologue -- N.B. this must be its own block to ensure that the entry block of the @@ -83,20 +90,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) $ toList 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) @@ -111,15 +125,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, []) @@ -132,7 +146,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 @@ -172,39 +186,24 @@ fty = LMFunction funSig in getInstrinct2 fname fty --- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmM StmtData -barrier = do - let s = Fence False SyncSeqCst - return (unitOL s, []) - --- | Insert a 'barrier', unless the target platform is in the provided list of --- exceptions (where no code will be emitted instead). -barrierUnless :: [Arch] -> LlvmM StmtData -barrierUnless exs = do - platform <- getPlatform - if platformArch platform `elem` exs - then return (nilOL, []) - else barrier - -- | Foreign Calls genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. -genCall (PrimTarget MO_ReadBarrier) _ _ = - barrierUnless [ArchX86, ArchX86_64] - -genCall (PrimTarget MO_WriteBarrier) _ _ = - barrierUnless [ArchX86, ArchX86_64] +genCall (PrimTarget MO_AcquireFence) _ _ = runStmtsDecls $ + statement $ Fence False SyncAcquire +genCall (PrimTarget MO_ReleaseFence) _ _ = runStmtsDecls $ + statement $ Fence False SyncRelease +genCall (PrimTarget MO_SeqCstFence) _ _ = runStmtsDecls $ + statement $ Fence False SyncSeqCst genCall (PrimTarget MO_Touch) _ _ = return (nilOL, []) genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) - let ty = cmmToLlvmType $ localRegType dst - width = widthToLlvmFloat w + (dstV, ty) <- getCmmRegW (CmmLocal dst) + let width = widthToLlvmFloat w castV <- lift $ mkLocalVar ty ve <- exprToVarW e statement $ Assignment castV $ Cast LM_Uitofp ve width @@ -231,23 +230,22 @@ statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) --- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg --- and return types -genCall t@(PrimTarget (MO_PopCnt w)) dsts args = - genCallSimpleCast w t dsts args - -genCall t@(PrimTarget (MO_Pdep w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Pext w)) dsts args = - genCallSimpleCast2 w t dsts args -genCall t@(PrimTarget (MO_Clz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_Ctz w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BSwap w)) dsts args = - genCallSimpleCast w t dsts args -genCall t@(PrimTarget (MO_BRev w)) dsts args = - genCallSimpleCast w t dsts args +-- Handle Clz, Ctz, BRev, BSwap, Pdep, Pext, and PopCnt that need to only +-- convert arg and return types +genCall (PrimTarget op@(MO_Clz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Ctz w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BRev w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_BSwap w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pdep w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_Pext w)) [dst] args = + genCallSimpleCast w op dst args +genCall (PrimTarget op@(MO_PopCnt w)) [dst] args = + genCallSimpleCast w op dst args genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do addrVar <- exprToVarW addr @@ -255,7 +253,7 @@ let targetTy = widthToLlvmInt width ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) ptrVar <- doExprW (pLift targetTy) ptrExpr - dstVar <- getCmmRegW (CmmLocal dst) + (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst) let op = case amop of AMO_Add -> LAO_Add AMO_Sub -> LAO_Sub @@ -267,7 +265,7 @@ statement $ Store retVar dstVar Nothing [] genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) + (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst) v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned statement $ Store v1 dstV Nothing [] @@ -279,14 +277,14 @@ let targetTy = getVarType oldVar ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) ptrVar <- doExprW (pLift targetTy) ptrExpr - dstVar <- getCmmRegW (CmmLocal dst) + (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst) retVar <- doExprW (LMStructU [targetTy,i1]) $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst retVar' <- doExprW targetTy $ ExtractV retVar 0 statement $ Store retVar' dstVar Nothing [] genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do - dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar + (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst) addrVar <- exprToVarW addr valVar <- exprToVarW val let ptrTy = pLift $ getVarType valVar @@ -352,8 +350,8 @@ retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit -- And extract them into retH. retH <- doExprW width $ Cast LM_Trunc retShifted width - dstRegL <- getCmmRegW (CmmLocal dstL) - dstRegH <- getCmmRegW (CmmLocal dstH) + (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL) + (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH) statement $ Store retL dstRegL Nothing [] statement $ Store retH dstRegH Nothing [] @@ -383,9 +381,9 @@ retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1 retC1 <- doExprW i1 $ Compare LM_CMP_Ne retH retH' -- Compare op returns a 1-bit value (i1) retC <- doExprW width $ Cast LM_Zext retC1 width -- so we zero-extend it - dstRegL <- getCmmRegW (CmmLocal dstL) - dstRegH <- getCmmRegW (CmmLocal dstH) - dstRegC <- getCmmRegW (CmmLocal dstC) + (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL) + (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH) + (dstRegC, _dstC_ty) <- getCmmRegW (CmmLocal dstC) statement $ Store retL dstRegL Nothing [] statement $ Store retH dstRegH Nothing [] statement $ Store retC dstRegC Nothing [] @@ -420,8 +418,8 @@ let narrow var = doExprW width $ Cast LM_Trunc var width retDiv <- narrow retExtDiv retRem <- narrow retExtRem - dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) - dstRegR <- lift $ getCmmReg (CmmLocal dstR) + (dstRegQ, _dstQ_ty) <- lift $ getCmmReg (CmmLocal dstQ) + (dstRegR, _dstR_ty) <- lift $ getCmmReg (CmmLocal dstR) statement $ Store retDiv dstRegQ Nothing [] statement $ Store retRem dstRegR Nothing [] @@ -445,6 +443,34 @@ genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = genCallWithOverflow t w [dstV, dstO] [lhs, rhs] +genCall (PrimTarget (MO_VS_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SDiv lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +genCall (PrimTarget (MO_VS_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SRem lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +genCall (PrimTarget (MO_VU_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_UDiv lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + +genCall (PrimTarget (MO_VU_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_URem lhsVar rhsVar) + (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst) + statement $ Store result dstReg Nothing [] + -- Handle all other foreign calls and prim ops. genCall target res args = do platform <- getPlatform @@ -454,10 +480,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" @@ -507,7 +530,6 @@ let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy (llvmFunAlign platform) - argVars <- arg_varsW args_hints ([], nilOL, []) fptr <- getFunPtrW funTy target @@ -527,23 +549,21 @@ ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." let creg = ret_reg res - vreg <- getCmmRegW (CmmLocal creg) - if retTy == pLower (getVarType vreg) - then do - statement $ Store v1 vreg Nothing [] - doReturn - else do - let ty = pLower $ getVarType vreg - let op = case ty of - vt | isPointer vt -> LM_Bitcast - | isInt vt -> LM_Ptrtoint - | otherwise -> - panic $ "genCall: CmmReg bad match for" - ++ " returned type!" - - v2 <- doExprW ty $ Cast op v1 ty - statement $ Store v2 vreg Nothing [] - doReturn + (vreg, ty) <- getCmmRegW (CmmLocal creg) + if retTy == ty + then do + statement $ Store v1 vreg Nothing [] + doReturn + else do + let op = case ty of + vt | isPointer vt -> LM_Bitcast + | isInt vt -> LM_Ptrtoint + | otherwise -> + panic $ "genCall: CmmReg bad match for" + ++ " returned type!" + v2 <- doExprW ty $ Cast op v1 ty + statement $ Store v2 vreg Nothing [] + doReturn -- | Generate a call to an LLVM intrinsic that performs arithmetic operation -- with overflow bit (i.e., returns a struct containing the actual result of the @@ -560,7 +580,7 @@ , MO_AddWordC w , MO_SubWordC w ] - massert valid + Panic.massert valid let width = widthToLlvmInt w -- This will do most of the work of generating the call to the intrinsic and -- extracting the values from the struct. @@ -569,8 +589,8 @@ -- value is i, but overflowBit is i1, so we need to cast (Cmm expects -- both to be i) (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width - dstRegV <- getCmmReg (CmmLocal dstV) - dstRegO <- getCmmReg (CmmLocal dstO) + (dstRegV, _dstV_ty) <- getCmmReg (CmmLocal dstV) + (dstRegO, _dstO_ty) <- getCmmReg (CmmLocal dstO) let storeV = Store value dstRegV Nothing [] storeO = Store overflow dstRegO Nothing [] return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) @@ -619,64 +639,29 @@ -- since GHC only really has i32 and i64 types and things like Word8 are backed -- by an i32 and just present a logical i8 range. So we must handle conversions -- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width [width] - - dstV <- getCmmReg (CmmLocal dst) +genCallSimpleCast :: Width -> CallishMachOp -> CmmFormal -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast specW op dst args = do + let width = widthToLlvmInt specW + argsW = const width <$> args + dstType = cmmToLlvmType $ localRegType dst + signage = cmmPrimOpRetValSignage op - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV [width] - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast" retVs' - let s2 = Store retV' dstV Nothing [] + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width argsW + (dstV, _dst_ty) <- getCmmReg (CmmLocal dst) + let (_, arg_hints) = foreignTargetHints $ PrimTarget op + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars signage $ zip argsV argsW + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retV', stmts5) <- castVar signage retV dstType + let s2 = Store retV' dstV Nothing [] let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 + s1 `snocOL` stmts5 `snocOL` s2 return (stmts, top2 ++ top3) -genCallSimpleCast _ _ dsts _ = - panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") --- Handle simple function call that only need simple type casting, of the form: --- truncate arg >>= \a -> call(a) >>= zext --- --- since GHC only really has i32 and i64 types and things like Word8 are backed --- by an i32 and just present a logical i8 range. So we must handle conversions --- from i32 to i8 explicitly as LLVM is strict about types. -genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> LlvmM StmtData -genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do - let width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - - fname <- cmmPrimOpFunctions op - (fptr, _, top3) <- getInstrinct fname width (const width <$> args) - - dstV <- getCmmReg (CmmLocal dst) - - let (_, arg_hints) = foreignTargetHints t - let args_hints = zip args arg_hints - (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) - (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) - (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] - let retV' = singletonPanic "genCallSimpleCast2" retVs' - let s2 = Store retV' dstV Nothing [] - - let stmts = stmts2 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (stmts, top2 ++ top3) -genCallSimpleCast2 _ _ dsts _ = - panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") - -- | Create a function pointer from a target. getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget -> WriterT LlvmAccum LlvmM LlvmVar @@ -790,11 +775,47 @@ Signed -> LM_Sext Unsigned -> LM_Zext - cmmPrimOpRetValSignage :: CallishMachOp -> Signage cmmPrimOpRetValSignage mop = case mop of - MO_Pdep _ -> Unsigned - MO_Pext _ -> Unsigned + -- Some bit-wise operations /must/ always treat the input and output values + -- as 'Unsigned' in order to return the expected result values when pre/post- + -- operation bit-width truncation and/or extension occur. For example, + -- consider the Bit-Reverse operation: + -- + -- If the result of a Bit-Reverse is treated as signed, + -- an positive input can result in an negative output, i.e.: + -- + -- identity(0x03) = 0x03 = 00000011 + -- breverse(0x03) = 0xC0 = 11000000 + -- + -- Now if an extension is performed after the operation to + -- promote a smaller bit-width value into a larger bit-width + -- type, it is expected that the /bit-wise/ operations will + -- not be treated /numerically/ as signed. + -- + -- To illustrate the difference, consider how a signed extension + -- for the type i16 to i32 differs for out values above: + -- ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000 + -- ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000 + -- + -- Here we can see that the former output is the expected result + -- of a bit-wise operation which needs to be promoted to a larger + -- bit-width type. The latter output is not desirable when we must + -- constraining a value into a range of i16 within an i32 type. + -- + -- Hence we always treat the "signage" as unsigned for Bit-Reverse! + -- + -- The same reasoning applied to Bit-Reverse above applies to the other + -- bit-wise operations; do not sign extend a possibly negated number! + MO_BRev _ -> Unsigned + MO_BSwap _ -> Unsigned + MO_Clz _ -> Unsigned + MO_Ctz _ -> Unsigned + MO_Pdep _ -> Unsigned + MO_Pext _ -> Unsigned + MO_PopCnt _ -> Unsigned + + -- All other cases, default to preserving the numeric sign when extending. _ -> Signed -- | Decide what C function to use to implement a CallishMachOp @@ -1009,8 +1030,20 @@ -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the -- appropriate case of genCall. MO_U_Mul2 {} -> unsupported - MO_ReadBarrier -> unsupported - MO_WriteBarrier -> unsupported + + MO_VS_Quot {} -> unsupported + MO_VS_Rem {} -> unsupported + MO_VU_Quot {} -> unsupported + MO_VU_Rem {} -> unsupported + MO_I64X2_Min -> unsupported + MO_I64X2_Max -> unsupported + MO_W64X2_Min -> unsupported + MO_W64X2_Max -> unsupported + + MO_ReleaseFence -> unsupported + MO_AcquireFence -> unsupported + MO_SeqCstFence -> unsupported + MO_Touch -> unsupported MO_UF_Conv _ -> unsupported @@ -1052,7 +1085,7 @@ -- | Tail function calls -genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData +genJump :: CmmExpr -> LiveGlobalRegUses -> LlvmM StmtData -- Call to known function genJump (CmmLit (CmmLabel lbl)) live = do @@ -1089,11 +1122,9 @@ -- these with registers when possible. genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData genAssign reg val = do - vreg <- getCmmReg reg + (vreg, ty) <- getCmmReg reg (vval, stmts2, top2) <- exprToVar val let stmts = stmts2 - - let ty = (pLower . getVarType) vreg platform <- getPlatform case ty of -- Some registers are pointer types, so need to cast value to pointer @@ -1149,7 +1180,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 @@ -1317,21 +1348,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 -- @@ -1413,8 +1461,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 @@ -1428,6 +1476,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 @@ -1442,6 +1493,11 @@ 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" -- Handle unsupported cases explicitly so we get a warning @@ -1470,8 +1526,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 @@ -1494,19 +1552,24 @@ MO_V_Sub _ _ -> panicOp MO_V_Mul _ _ -> panicOp - MO_VS_Quot _ _ -> panicOp - MO_VS_Rem _ _ -> panicOp + MO_VS_Min _ _ -> panicOp + MO_VS_Max _ _ -> panicOp - MO_VU_Quot _ _ -> panicOp - MO_VU_Rem _ _ -> panicOp + MO_VU_Min _ _ -> panicOp + MO_VU_Max _ _ -> panicOp 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 @@ -1656,7 +1719,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 @@ -1669,12 +1732,6 @@ MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul - MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv - MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem - - MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv - MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem - MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul @@ -1684,28 +1741,42 @@ 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 - MO_AlignmentCheck {} -> 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 -#if __GLASGOW_HASKELL__ < 811 - MO_VF_Extract {} -> panicOp - MO_V_Extract {} -> panicOp -#endif + MO_RelaxedRead {} -> panicOp + MO_AlignmentCheck {} -> panicOp + where binLlvmOp ty binOp allow_y_cast = do platform <- getPlatform @@ -1756,6 +1827,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. @@ -1788,17 +1872,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 @@ -1807,11 +1889,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 @@ -1828,7 +1943,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] @@ -1869,7 +1990,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 @@ -1947,43 +2068,58 @@ -- | Handle CmmReg expression. This will return a pointer to the stack -- location of the register. Throws an error if it isn't allocated on -- the stack. -getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg :: CmmReg -> LlvmM (LlvmVar, LlvmType) getCmmReg (CmmLocal (LocalReg un _)) = do exists <- varLookup un case exists of - Just ety -> return (LMLocalVar un $ pLift ety) + Just ety -> return (LMLocalVar un $ pLift ety, ety) Nothing -> pprPanic "getCmmReg: Cmm register " $ ppr un <> text " was not allocated!" -- This should never happen, as every local variable should -- 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 (GlobalRegUse reg _reg_ty)) + = do onStack <- checkStackReg reg platform <- getPlatform - if onStack - then return (lmGlobalRegVar platform r) - else pprPanic "getCmmReg: Cmm register " $ - ppr g <> text " not stack-allocated!" + case onStack of + Just stack_ty -> do + let var = lmGlobalRegVar platform (GlobalRegUse reg stack_ty) + return (var, pLower $ getVarType var) + Nothing -> + pprPanic "getCmmReg: Cmm register " $ + ppr reg <> text " not stack-allocated!" -- | Return the value of a given register, as well as its type. Might -- need to be load from stack. getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) getCmmRegVal reg = case reg of - CmmGlobal g -> do - onStack <- checkStackReg (globalRegUseGlobalReg g) + CmmGlobal gu@(GlobalRegUse g _) -> do + onStack <- checkStackReg g platform <- getPlatform - if onStack then loadFromStack else do - let r = lmGlobalRegArg platform (globalRegUseGlobalReg g) - return (r, getVarType r, nilOL) + case onStack of + Just {} -> + loadFromStack + Nothing -> do + let r = lmGlobalRegArg platform gu + return (r, getVarType r, nilOL) _ -> loadFromStack - where loadFromStack = do - ptr <- getCmmReg reg - let ty = pLower $ getVarType ptr - (v, s) <- doExpr ty (Load ptr Nothing) - return (v, ty, unitOL s) + where + loadFromStack = do + platform <- getPlatform + (ptr, stack_reg_ty) <- getCmmReg reg + let reg_ty = case reg of + CmmGlobal g -> pLower $ getVarType $ lmGlobalRegVar platform g + CmmLocal {} -> stack_reg_ty + if reg_ty /= stack_reg_ty + then do + (v1, s1) <- doExpr stack_reg_ty (Load ptr Nothing) + (v2, s2) <- doExpr reg_ty (Cast LM_Bitcast v1 reg_ty) + return (v2, reg_ty, toOL [s1, s2]) + else do + (v, s) <- doExpr reg_ty (Load ptr Nothing) + return (v, reg_ty, unitOL s) -- | Allocate a local CmmReg on the stack allocReg :: CmmReg -> (LlvmVar, LlvmStatements) @@ -2009,10 +2145,17 @@ -- ] in return (mkIntLit width i, nilOL, []) -genLit _ (CmmFloat r w) - = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), +genLit _ (CmmFloat r W32) + = return (LMLitVar $ LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32), nilOL, []) +genLit _ (CmmFloat r W64) + = return (LMLitVar $ LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64), + nilOL, []) + +genLit _ (CmmFloat _r _w) + = panic "genLit (CmmLit:CmmFloat), unsupported float lit" + genLit opt (CmmVec ls) = do llvmLits <- mapM toLlvmLit ls return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) @@ -2089,8 +2232,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 -> NonEmpty CmmBlock -> LlvmM StmtData funPrologue live cmmBlocks = do + platform <- getPlatform let getAssignedRegs :: CmmNode O O -> [CmmReg] getAssignedRegs (CmmAssign reg _) = [reg] @@ -2098,7 +2242,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 -> @@ -2107,24 +2252,38 @@ 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 ty0) -> do + let reg = lmGlobalRegVar platform ru ty = (pLower . getVarType) reg trash = LMLitVar $ LMUndefLit ty - rval = if isLive r then arg else trash + rval = case mbLive r of + Just (GlobalRegUse _ ty') -> + lmGlobalRegArg platform (GlobalRegUse r ty') + _ -> trash alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - markStackReg r - return $ toOL [alloc, Store rval reg Nothing []] + markStackReg ru + case mbLive r of + Just (GlobalRegUse _ ty') + | let llvm_ty = cmmToLlvmType ty0 + llvm_ty' = cmmToLlvmType ty' + , llvm_ty /= llvm_ty' + -> do castV <- mkLocalVar (pLift llvm_ty') + return $ + toOL [ alloc + , Assignment castV $ Cast LM_Bitcast reg (pLift llvm_ty') + , Store rval castV Nothing [] + ] + _ -> + return $ toOL [alloc, Store rval reg Nothing []] return (concatOL stmtss `snocOL` jumpToEntry, []) where - entryBlk : _ = cmmBlocks + entryBlk :| _ = cmmBlocks jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk) -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue :: LiveGlobalRegUses -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do platform <- getPlatform @@ -2150,12 +2309,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 @@ -2165,7 +2328,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 @@ -2228,9 +2391,8 @@ -- | Returns TBAA meta data by unique getTBAAMeta :: Unique -> LlvmM [MetaAnnot] -getTBAAMeta u = do - mi <- getUniqMeta u - return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] +getTBAAMeta u = + List.singleton . MetaAnnot tbaa . MetaNode . expectJust <$> getUniqMeta u -- | Returns TBAA meta data for given register getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] @@ -2276,7 +2438,7 @@ LlvmAccum stmts decls <- execWriterT action return (stmts, decls) -getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar +getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM (LlvmVar, LlvmType) getCmmRegW = lift . getCmmReg genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar diff --git a/GHC/CmmToLlvm/Config.hs b/GHC/CmmToLlvm/Config.hs --- a/GHC/CmmToLlvm/Config.hs +++ b/GHC/CmmToLlvm/Config.hs @@ -1,34 +1,20 @@ -{-# LANGUAGE CPP #-} - -- | Llvm code generator configuration module GHC.CmmToLlvm.Config ( LlvmCgConfig(..) , LlvmConfig(..) , LlvmTarget(..) , initLlvmConfig - -- * LLVM version - , LlvmVersion(..) - , supportedLlvmVersionLowerBound - , supportedLlvmVersionUpperBound - , parseLlvmVersion - , llvmVersionSupported - , llvmVersionStr - , llvmVersionList ) where -#include "ghc-llvm-version.h" - import GHC.Prelude import GHC.Platform import GHC.Utils.Outputable import GHC.Settings.Utils import GHC.Utils.Panic +import GHC.CmmToLlvm.Version.Type (LlvmVersion) -import Data.Char (isDigit) -import Data.List (intercalate) -import qualified Data.List.NonEmpty as NE import System.FilePath data LlvmCgConfig = LlvmCgConfig @@ -36,6 +22,7 @@ , llvmCgContext :: !SDocContext -- ^ Context for LLVM code generation , llvmCgFillUndefWithGarbage :: !Bool -- ^ Fill undefined literals with garbage values , llvmCgSplitSection :: !Bool -- ^ Split sections + , llvmCgAvxEnabled :: !Bool , llvmCgBmiVersion :: Maybe BmiVersion -- ^ (x86) BMI instructions , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version @@ -93,43 +80,3 @@ { llvmTargets :: [(String, LlvmTarget)] , llvmPasses :: [(Int, String)] } - - ---------------------------------------------------------- --- LLVM version ---------------------------------------------------------- - -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } - deriving (Eq, Ord) - -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 - --- | The (inclusive) lower bound on the LLVM Version that is currently supported. -supportedLlvmVersionLowerBound :: LlvmVersion -supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| []) - --- | The (not-inclusive) upper bound bound on the LLVM Version that is currently supported. -supportedLlvmVersionUpperBound :: LlvmVersion -supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| []) - -llvmVersionSupported :: LlvmVersion -> Bool -llvmVersionSupported v = - v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound - -llvmVersionStr :: LlvmVersion -> String -llvmVersionStr = intercalate "." . map show . llvmVersionList - -llvmVersionList :: LlvmVersion -> [Int] -llvmVersionList = NE.toList . llvmVersionNE diff --git a/GHC/CmmToLlvm/Data.hs b/GHC/CmmToLlvm/Data.hs --- a/GHC/CmmToLlvm/Data.hs +++ b/GHC/CmmToLlvm/Data.hs @@ -10,6 +10,7 @@ import GHC.Prelude import GHC.Llvm +import GHC.Llvm.Types (widenFp) import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config @@ -124,7 +125,7 @@ prio = LMStaticLit $ LMIntLit 0xffff i32 in LMStaticStrucU [prio, fn, null] entry_ty - arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global + arr_var = LMGlobalVar var_nm arr_ty Appending 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 @@ -193,8 +194,14 @@ genStaticLit (CmmInt i w) = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) -genStaticLit (CmmFloat r w) - = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) +genStaticLit (CmmFloat r W32) + = return $ LMStaticLit (LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32)) + +genStaticLit (CmmFloat r W64) + = return $ LMStaticLit (LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64)) + +genStaticLit (CmmFloat _r _w) + = panic "genStaticLit (CmmLit:CmmFloat), unsupported float lit" genStaticLit (CmmVec ls) = do sls <- mapM toLlvmLit ls diff --git a/GHC/CmmToLlvm/Regs.hs b/GHC/CmmToLlvm/Regs.hs --- a/GHC/CmmToLlvm/Regs.hs +++ b/GHC/CmmToLlvm/Regs.hs @@ -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)] diff --git a/GHC/CmmToLlvm/Version.hs b/GHC/CmmToLlvm/Version.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Version.hs @@ -0,0 +1,43 @@ +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 diff --git a/GHC/CmmToLlvm/Version/Bounds.hs b/GHC/CmmToLlvm/Version/Bounds.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Version/Bounds.hs @@ -0,0 +1,19 @@ +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 (21 NE.:| []) diff --git a/GHC/CmmToLlvm/Version/Type.hs b/GHC/CmmToLlvm/Version/Type.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToLlvm/Version/Type.hs @@ -0,0 +1,11 @@ +module GHC.CmmToLlvm.Version.Type + ( LlvmVersion(..) + ) +where + +import GHC.Prelude + +import qualified Data.List.NonEmpty as NE + +newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } + deriving (Eq, Ord) diff --git a/GHC/Core.hs b/GHC/Core.hs --- a/GHC/Core.hs +++ b/GHC/Core.hs @@ -3,9 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NoPolyKinds #-} -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( @@ -16,9 +14,10 @@ -- * In/Out type synonyms InId, InBind, InExpr, InAlt, InArg, InType, InKind, - InBndr, InVar, InCoercion, InTyVar, InCoVar, + InBndr, InVar, InCoercion, InTyVar, InCoVar, InTyCoVar, OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, - OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion, + OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, + OutTyCoVar, MOutCoercion, -- ** 'Expr' construction mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, @@ -27,7 +26,7 @@ mkIntLit, mkIntLitWrap, mkWordLit, mkWordLitWrap, mkWord8Lit, - mkWord64LitWord64, mkInt64LitInt64, + mkWord32LitWord32, mkWord64LitWord64, mkInt64LitInt64, mkCharLit, mkStringLit, mkFloatLit, mkFloatLitFloat, mkDoubleLit, mkDoubleLitDouble, @@ -35,14 +34,16 @@ mkConApp, mkConApp2, mkTyBind, mkCoBind, varToCoreExpr, varsToCoreExprs, + mkBinds, + isId, cmpAltCon, cmpAlt, ltAlt, -- ** Simple 'Expr' access functions and predicates - bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts, foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, collectNBinders, collectNValBinders_maybe, - collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds, collectFunSimple, exprToType, @@ -59,12 +60,12 @@ unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, expandUnfolding_maybe, + expandUnfolding_maybe, maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding, - isInlineUnfolding, isBootUnfolding, + isInlineUnfolding, isBootUnfolding, isBetterUnfoldingThan, hasCoreUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, @@ -112,12 +113,15 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Data hiding (TyCon) import Data.Int +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE import Data.Word +import Control.DeepSeq + infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) @@ -312,6 +316,17 @@ | Rec [(b, (Expr b))] deriving Data +-- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for +-- instance. +-- +-- * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive +-- bindings with all the rhs/lhs pairs in @binds@ +-- * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding +-- for each rhs/lhs pairs in @binds@ +mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b] +mkBinds Recursive binds = [Rec binds] +mkBinds NonRecursive binds = map (uncurry NonRec) binds + {- Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -404,7 +419,7 @@ (This binding looks recursive, but isn't; it defines a top-level, curried function whose body just allocates and returns the data constructor.) - But if (a) the data contructor is nullary and (b) the data type is unlifted, + But if (a) the data constructor is nullary and (b) the data type is unlifted, this binding is unlifted. e.g. data S :: UnliftedType where { S1 :: S, S2 :: S -> S } we generate @@ -440,9 +455,6 @@ The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make. -For discussion of some implications of the let-can-float invariant primops see -Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps. - Historical Note [The let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules @@ -464,7 +476,7 @@ Note [Core top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted, -we allow binding primitive string literals (of type Addr#) of type Addr# at the +we allow binding primitive string literals (of type Addr#) at the top level. This allows us to share string literals earlier in the pipeline and crucially allows other optimizations in the Core2Core pipeline to fire. Consider, @@ -642,7 +654,7 @@ GHC allows us to abstract over calling conventions using **representation polymorphism**. For example, we have: - ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). a -> b -> b + ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). (a -> b) -> a -> b In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`, where the type variable `r :: RuntimeRep` abstracts over the runtime representation @@ -657,13 +669,6 @@ (except for join points: See Note [Invariants on join points]) I2. The type of a function argument must have a fixed runtime representation. -On top of these two invariants, GHC's internal eta-expansion mechanism also requires: - - I3. In any partial application `f e_1 .. e_n`, where `f` is `hasNoBinding`, - it must be the case that the application can be eta-expanded to match - the arity of `f`. - See Note [checkCanEtaExpand] in GHC.Core.Lint for more details. - Example of I1: \(r::RuntimeRep). \(a::TYPE r). \(x::a). e @@ -678,26 +683,26 @@ This contravenes I2: we are applying the function `f` to a value with an unknown runtime representation. -Examples of I3: +Note that these two invariants require us to check other types than just the +types of bound variables and types of function arguments, due to transformations +that GHC performs. For example, the definition - myUnsafeCoerce# :: forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b - myUnsafeCoerce# = unsafeCoerce# + myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b + myCoerce = coerce - This contravenes I3: we are instantiating `unsafeCoerce#` without any - value arguments, and with a remaining argument type, `a`, which does not - have a fixed runtime representation. - But `unsafeCorce#` has no binding (see Note [Wiring in unsafeCoerce#] - in GHC.HsToCore). So before code-generation we must saturate it - by eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate), thus - myUnsafeCoerce# = \x. unsafeCoerce# x - But we can't do that because now the \x binding would violate I1. +is invalid, because `coerce` has no binding (see GHC.Types.Id.Make.coerceId). +So, before code-generation, GHC saturates the RHS of 'myCoerce' by performing +an eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate): - bar :: forall (a :: TYPE) r (b :: TYPE r). a -> b - bar = unsafeCoerce# + myCoerce = \ (x :: TYPE r) -> coerce x - OK: eta expand to `\ (x :: Type) -> unsafeCoerce# x`, - and `x` has a fixed RuntimeRep. +However, this transformation would be invalid, because now the binding of x +in the lambda abstraction would violate I1. +See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete +and Note [Linting representation-polymorphic builtins] in GHC.Core.Lint for +more details. + Note that we currently require something slightly stronger than a fixed runtime representation: we check whether bound variables and function arguments have a /fixed RuntimeRep/ in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. @@ -748,10 +753,14 @@ its scrutinee is (see GHC.Core.Utils.exprIsTrivial). This is actually important; see Note [Empty case is trivial] in GHC.Core.Utils -* An empty case is replaced by its scrutinee during the CoreToStg - conversion; remember STG is un-typed, so there is no need for - the empty case to do the type conversion. +* We lower empty cases in GHC.CoreToStg.coreToStgExpr to an eval on the + scrutinee. +Historical Note: We used to lower EmptyCase in CorePrep by way of an +unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when +we were beginning to eta expand in arguments, plus required to mess with +heterogenously-kinded coercions. It's simpler to stick to it just a bit longer. + Note [Join points] ~~~~~~~~~~~~~~~~~~ In Core, a *join point* is a specially tagged function whose only occurrences @@ -1025,6 +1034,73 @@ operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for ideas how to fix this. +Note [Strict fields in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, evaluating a data constructor worker evaluates its strict fields. + +In other words, let's say we have the following data type + + data T a b = MkT !a b + +Now if `xs` reduces to `error "boom"`, then `MkT xs b` will throw that error. +Consequently, it is sound to seq the field before the call to the constructor, +e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`. +Let's call this transformation "field eval insertion". + +Note in particular that the data constructor application `MkT xs b` above is +*not* a value, unless `xs` is! + +This has pervasive effect on the Core pipeline: + +(SFC1) `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the + strict arguments of a DataCon worker are values/ok-for-spec themselves. + +(SFC2) `exprIsConApp_maybe` inserts field evals in the `FloatBind`s it returns, so + that the Simplifier, Constant-folding, the pattern-match checker, etc. all + see the inserted field evals when they match on strict workers. + + For example, + exprIsConApp_maybe (MkT e1 e2) + = Just ([FloatCase e1 x], MkT, [x,e2]) + Meaning that (MkT e1 e2) is indeed a data constructor application, but if + you want to decompose it (which is the purpose of exprIsConApp_maybe) you + must evaluate e1 first. + In case of case-of-known constructor, we get the rewrite + case MkT e1 e2 of MkT xs' b' -> b' + ==> + case e1 of xs' { __DEFAULT -> e2 } + which crucially retains the eval on e1. + +(SFC3) The demand signature of a data constructor is strict in strict field + position and lazy in non-strict fields. Likewise the demand *transformer* + of a DataCon worker can stricten up demands on strict field args. + See Note [Demand transformer for data constructors]. + +(SFC4) In the absence of `-fpedantic-bottoms`, it is still possible that some seqs + are ultimately dropped or delayed due to eta-expansion. + See Note [Dealing with bottom]. + +Strict field semantics is exploited and lowered in STG during EPT enforcement; +see Note [EPT enforcement lowers strict constructor worker semantics] for the +connection. + +It might be tempting to think that strict fields could be implemented in terms +of unlifted fields. However, unlifted fields behave differently when the data +constructor is partially applied; see Note [exprIsHNF for function applications] +for an example. + +Historical Note: +The delightfully simple description of strict field semantics is the result of +a long saga (#20749, the bits about strict data constructors in #21497, #22475), +where we tried a more lenient (but actually not) semantics first that would +allow both strict and lazy implementations of DataCon workers. This was favoured +because the "pervasive effect" throughout the compiler was deemed too large +(when it really turned out to be quite modest). +Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the +same way as above, otherwise the analysis would not be conservative wrt. the +lenient semantics (which includes the strict one). It is also much harder to +explain and maintain, as it turned out. + ************************************************************************ * * In/Out type synonyms @@ -1093,11 +1169,9 @@ -- -- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically -- -chooseOrphanAnchor local_names - | isEmptyNameSet local_names = IsOrphan - | otherwise = NotOrphan (minimum occs) - where - occs = map nameOccName $ nonDetEltsUniqSet local_names +chooseOrphanAnchor local_names = case nonEmpty $ nonDetEltsUniqSet local_names of + Nothing -> IsOrphan + Just local_names -> NotOrphan (minimum (NE.map nameOccName local_names)) -- It's OK to use nonDetEltsUFM here, see comments above instance Binary IsOrphan where @@ -1113,6 +1187,10 @@ n <- get bh return $ NotOrphan n +instance NFData IsOrphan where + rnf IsOrphan = () + rnf (NotOrphan n) = rnf n + {- Note [Orphans] ~~~~~~~~~~~~~~ @@ -1263,7 +1341,7 @@ -- | The number of arguments the 'ru_fn' must be applied -- to before the rule can match on it -ruleArity :: CoreRule -> Int +ruleArity :: CoreRule -> FullArgCount ruleArity (BuiltinRule {ru_nargs = n}) = n ruleArity (Rule {ru_args = args}) = length args @@ -1283,7 +1361,8 @@ ruleIdName = ru_fn isLocalRule :: CoreRule -> Bool -isLocalRule = ru_local +isLocalRule (BuiltinRule {}) = False +isLocalRule (Rule { ru_local = is_local }) = is_local -- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule @@ -1509,10 +1588,6 @@ mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon --- | Retrieves the template of an unfolding: panics if none is known -unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate = uf_tmpl - -- | Retrieves the template of an unfolding if possible -- maybeUnfoldingTemplate is used mainly when specialising, and we do -- want to specialise DFuns, so it's important to return a template @@ -1552,7 +1627,6 @@ -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' isConLikeUnfolding :: Unfolding -> Bool -isConLikeUnfolding (OtherCon _) = True isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache isConLikeUnfolding _ = False @@ -1637,6 +1711,33 @@ canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) canUnfold _ = False +isBetterUnfoldingThan :: Unfolding -> Unfolding -> Bool +-- See Note [Better unfolding] +isBetterUnfoldingThan NoUnfolding _ = False +isBetterUnfoldingThan BootUnfolding _ = False + +isBetterUnfoldingThan (CoreUnfolding {uf_cache = uc1}) unf2 + = case unf2 of + CoreUnfolding {uf_cache = uc2} -> uf_is_value uc1 && not (uf_is_value uc2) + OtherCon _ -> uf_is_value uc1 + _ -> True + -- Default case: CoreUnfolding better than NoUnfolding etc + -- Better than DFunUnfolding? I don't care. + +isBetterUnfoldingThan (DFunUnfolding {}) unf2 + | DFunUnfolding {} <- unf2 = False + | otherwise = True + +isBetterUnfoldingThan (OtherCon cs1) unf2 + = case unf2 of + CoreUnfolding {uf_cache = uc} -- If unf1 is OtherCon and unf2 is + -> not (uf_is_value uc) -- just a thunk, unf1 is better + + OtherCon cs2 -> not (null cs1) && null cs2 -- A bit crude + DFunUnfolding {} -> False + NoUnfolding -> True + BootUnfolding -> True + {- Note [Fragile unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An unfolding is "fragile" if it mentions free variables (and hence would @@ -1651,6 +1752,20 @@ We consider even a StableUnfolding as fragile, because it needs substitution. +Note [Better unfolding] +~~~~~~~~~~~~~~~~~~~~~~~ +(unf1 `isBetterUnfoldingThan` unf2) is used when we have + let x = in -- unf2 + let $j y = ...x... + in case x of + K a -> ...$j v.... + +At the /call site/ of $j, `x` has a better unfolding than it does at the +/defnition site/ of $j; so we are keener to inline $j. See +Note [Inlining join points] in GHC.Core.Opt.Simplify.Inline for discussion. + +The notion of "better" is encapsulated here. + Note [Stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~ When you say @@ -1897,6 +2012,9 @@ mkWord8Lit :: Integer -> Expr b mkWord8Lit w = Lit (mkLitWord8 w) +mkWord32LitWord32 :: Word32 -> Expr b +mkWord32LitWord32 w = Lit (mkLitWord32 (toInteger w)) + mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) @@ -2036,6 +2154,11 @@ rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] +rhssOfBinds :: [Bind b] -> [Expr b] +rhssOfBinds [] = [] +rhssOfBinds (NonRec _ rhs : bs) = rhs : rhssOfBinds bs +rhssOfBinds (Rec pairs : bs) = map snd pairs ++ rhssOfBinds bs + rhssOfAlts :: [Alt b] -> [Expr b] rhssOfAlts alts = [e | Alt _ _ e <- alts] @@ -2109,6 +2232,17 @@ = go expr [] where go (App f a) as = go f (a:as) + go e as = (e, as) + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectValArgs :: Expr b -> (Expr b, [Arg b]) +collectValArgs expr + = go expr [] + where + go (App f a) as + | isValArg a = go f (a:as) + | otherwise = go f as go e as = (e, as) -- | Takes a nested application expression and returns the function diff --git a/GHC/Core.hs-boot b/GHC/Core.hs-boot --- a/GHC/Core.hs-boot +++ b/GHC/Core.hs-boot @@ -1,3 +1,4 @@ +{-# LANGUAGE NoPolyKinds #-} module GHC.Core where import {-# SOURCE #-} GHC.Types.Var diff --git a/GHC/Core/Class.hs b/GHC/Core/Class.hs --- a/GHC/Core/Class.hs +++ b/GHC/Core/Class.hs @@ -18,7 +18,12 @@ classKey, className, classATs, classATItems, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, - classHasFds, isAbstractClass, + classHasFds, + + -- Predicates + -- NB: other isXXlass predicates are defined in GHC.Core.Predicate + -- to avoid module loops + isAbstractClass ) where import GHC.Prelude @@ -26,17 +31,17 @@ import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Hs.Extension (GhcRn) import GHC.Types.Var import GHC.Types.Name import GHC.Types.Basic import GHC.Types.Unique import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Utils.Outputable -import GHC.Data.BooleanFormula (BooleanFormula, mkTrue) +import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue ) import qualified Data.Data as Data @@ -77,10 +82,6 @@ -- > class C a b c | a b -> c, a c -> b where... -- -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'', - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type FunDep a = ([a],[a]) type ClassOpItem = (Id, DefMethInfo) @@ -136,7 +137,7 @@ -- Note [Type-checking default assoc decls] in GHC.Tc.TyCl. } -type ClassMinimalDef = BooleanFormula Name -- Required methods +type ClassMinimalDef = BooleanFormula GhcRn -- Required methods data ClassBody = AbstractClass diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs --- a/GHC/Core/Coercion.hs +++ b/GHC/Core/Coercion.hs @@ -24,35 +24,32 @@ -- ** Functions over coercions coVarRType, coVarLType, coVarTypes, - coVarKind, coVarKindsTypesRole, coVarRole, + coVarKind, coVarTypesRole, coVarRole, coercionType, mkCoercionType, coercionKind, coercionLKind, coercionRKind,coercionKinds, coercionRole, coercionKindRole, -- ** Constructing coercions - mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo, mkCoVarCo, mkCoVarCos, mkAxInstCo, mkUnbranchedAxInstCo, mkAxInstRHS, mkUnbranchedAxInstRHS, mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, mkSymCo, mkTransCo, - mkSelCo, getNthFun, getNthFromType, mkLRCo, + mkSelCo, mkSelCoResRole, getNthFun, selectFromType, mkLRCo, mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo, mkNakedFunCo, - mkForAllCo, mkForAllCos, mkHomoForAllCos, - mkPhantomCo, + mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos, + mkPhantomCo, mkAxiomCo, mkHoleCo, mkUnivCo, mkSubCo, - mkAxiomInstCo, mkProofIrrelCo, - downgradeRole, mkAxiomRuleCo, + mkProofIrrelCo, + downgradeRole, mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, mkKindCo, castCoercionKind, castCoercionKind1, castCoercionKind2, - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - mkNomPrimEqPred, - -- ** Decomposition instNewTyCon_maybe, @@ -74,7 +71,7 @@ mkCoherenceRightMCo, coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, - mkHomoForAllMCo, mkFunResMCo, mkPiMCos, + mkFunResMCo, mkPiMCos, isReflMCo, checkReflexiveMCo, -- ** Coercion variables @@ -95,10 +92,11 @@ -- ** Lifting liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, - liftCoSubstVarBndrUsing, isMappedByLC, + liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst, + updateLCSubst, - mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcSubst, lcInScopeSet, + mkSubstLiftingContext, liftingContextSubst, zapLiftingContext, + lcLookupCoVar, lcInScopeSet, LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, @@ -123,8 +121,7 @@ multToCo, mkRuntimeRepCo, - hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, - + hasCoercionHole, setCoHoleType ) where @@ -138,8 +135,9 @@ import GHC.Core.TyCo.Ppr import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Tidy -import GHC.Core.TyCo.Compare( eqType, eqTypeX ) +import GHC.Core.TyCo.Compare import GHC.Core.Type +import GHC.Core.Predicate( mkNomEqPred, mkReprEqPred ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Core.Coercion.Axiom @@ -163,12 +161,13 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad (foldM, zipWithM) import Data.Function ( on ) import Data.Char( isDigit ) import qualified Data.Monoid as Monoid +import Data.List.NonEmpty ( NonEmpty (..) ) +import Control.DeepSeq {- %************************************************************************ @@ -250,14 +249,14 @@ ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch - = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkForAllTyBinders Inferred bndrs') + = foldr1 (flip hangNotEmpty 2) $ + pprUserForAll (mkForAllTyBinders Inferred bndrs') :| -- See Note [Printing foralls in type family instances] in GHC.Iface.Type - , pp_lhs <+> ppr_rhs tidy_env ee_rhs - , vcat [ text "-- Defined" <+> pp_loc + (pp_lhs <+> ppr_rhs tidy_env ee_rhs) : + ( vcat [ text "-- Defined" <+> pp_loc , ppUnless (null incomps) $ whenPprDebug $ - text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] - ] + text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) : + [] where incomps = coAxBranchIncomps branch loc = coAxBranchSpan branch @@ -334,9 +333,24 @@ mkGReflCo :: Role -> Type -> MCoercionN -> Coercion mkGReflCo r ty mco | isGReflMCo mco = if r == Nominal then Refl ty - else GRefl r ty MRefl - | otherwise = GRefl r ty mco + else GRefl r ty MRefl + | otherwise + = -- I'd like to have this assert, but sadly it's not true during type + -- inference because the types are not fully zonked + -- assertPpr (case mco of + -- MCo co -> typeKind ty `eqType` coercionLKind co + -- MRefl -> True) + -- (vcat [ text "ty" <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + -- , case mco of + -- MCo co -> text "co" <+> ppr co + -- <+> dcolon <+> ppr (coercionKind co) + -- MRefl -> text "MRefl" + -- , callStackDoc ]) $ + GRefl r ty mco +mkGReflMCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion +mkGReflMCo r ty co = mkGReflCo r ty (MCo co) + -- | Compose two MCoercions via transitivity mkTransMCo :: MCoercion -> MCoercion -> MCoercion mkTransMCo MRefl co2 = co2 @@ -361,10 +375,6 @@ mkCastTyMCo ty MRefl = ty mkCastTyMCo ty (MCo co) = ty `mkCastTy` co -mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion -mkHomoForAllMCo _ MRefl = MRefl -mkHomoForAllMCo tcv (MCo co) = MCo (mkHomoForAllCos [tcv] co) - mkPiMCos :: [Var] -> MCoercion -> MCoercion mkPiMCos _ MRefl = MRefl mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) @@ -555,40 +565,48 @@ splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) splitFunCo_maybe _ = Nothing -splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) -splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) -splitForAllCo_maybe _ = Nothing +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR + , fco_kind = k_co, fco_body = co }) + = Just (tv, vL, vR, k_co, co) +splitForAllCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty + = Just (tcv, vis, vis, mkNomReflCo (varType tcv), mkReflCo r body_ty) +splitForAllCo_maybe _ = Nothing -- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder -splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) -splitForAllCo_ty_maybe (ForAllCo tv k_co co) - | isTyVar tv = Just (tv, k_co, co) +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +splitForAllCo_ty_maybe co + | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co + , isTyVar tv + = Just stuff splitForAllCo_ty_maybe _ = Nothing -- | Like 'splitForAllCo_maybe', but only returns Just for covar binder -splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) -splitForAllCo_co_maybe (ForAllCo cv k_co co) - | isCoVar cv = Just (cv, k_co, co) +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) +splitForAllCo_co_maybe co + | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co + , isCoVar cv + = Just stuff splitForAllCo_co_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type -coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1 -coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2 +coVarLType cv | (ty1, _, _) <- coVarTypesRole cv = ty1 +coVarRType cv | (_, ty2, _) <- coVarTypesRole cv = ty2 coVarTypes :: HasDebugCallStack => CoVar -> Pair Type -coVarTypes cv - | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv - = Pair ty1 ty2 +coVarTypes cv | (ty1, ty2, _) <- coVarTypesRole cv = Pair ty1 ty2 -coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) -coVarKindsTypesRole cv - | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) - = (k1, k2, ty1, ty2, eqTyConRole tc) +coVarTypesRole :: HasDebugCallStack => CoVar -> (Type,Type,Role) +coVarTypesRole cv + | Just (tc, [_,_,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = (ty1, ty2, eqTyConRole tc) | otherwise - = pprPanic "coVarKindsTypesRole, non coercion variable" + = pprPanic "coVarTypesRole, non coercion variable" (ppr cv $$ ppr (varType cv)) coVarKind :: CoVar -> Type @@ -919,101 +937,95 @@ -> Coercion mkAppCos co1 cos = foldl' mkAppCo co1 cos -{- Note [Unused coercion variable in ForAllCo] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the -motivation for checking coercion variable in types. -To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: -(1) In mkForAllCo, we check whether cv is a coercion variable - and whether it is not used in body_co. If so we construct a FunCo. -(2) We don't do this check in mkForAllCo. - In coercionKind, we use mkTyCoForAllTy to perform the check and construct - a FunTy when necessary. +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion +mkForAllCo v visL visR kind_co co + | Just (ty, r) <- isReflCo_maybe co + , isReflCo kind_co + , visL `eqForAllVis` visR + = mkReflCo r (mkTyCoForAllTy v visL ty) -We chose (2) for two reasons: + | otherwise + = mkForAllCo_NoRefl v visL visR kind_co co -* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not - make a difference. -* even if cv occurs in body_co, it is possible that cv does not occur in the kind - of body_co. Therefore the check in coercionKind is inevitable. +-- mkForAllVisCos [tv{vis}] constructs a cast +-- forall tv. res ~R# forall tv{vis} res`. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep +mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion +mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs + where + go (Bndr tv vis) + = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv)) -The last wrinkle is that there are restrictions around the use of the cv in the -coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that -we cannot prove that the type system is consistent with unrestricted use of this -cv; the consistency proof uses an untyped rewrite relation that works over types -with all coercions and casts removed. So, we can allow the cv to appear only in -positions that are erased. As an approximation of this (and keeping close to the -published theory), we currently allow the cv only within the type in a Refl node -and under a GRefl node (including in the Coercion stored in a GRefl). It's -possible other places are OK, too, but this is a safe approximation. +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same kind and visibility in both sides of the coercion +mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion +mkHomoForAllCos vs orig_co + | Just (ty, r) <- isReflCo_maybe orig_co + = mkReflCo r (mkTyCoForAllTys vs ty) + | otherwise + = foldr go orig_co vs + where + go (Bndr var vis) co + = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co -Sadly, with heterogeneous equality, this restriction might be able to be violated; -Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst -function might create an invalid coercion. Because a violation of the -restriction might lead to a program that "goes wrong", it is checked all the time, -even in a production compiler and without -dcore-lint. We *have* proved that the -problem does not occur with homogeneous equality, so this check can be dropped -once ~# is made to be homogeneous. --} +-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl; +-- the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.) +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl tcv visL visR kind_co co + = assertGoodForAllCo tcv visL visR kind_co co $ + assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $ + ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co } +assertGoodForAllCo :: HasDebugCallStack + => TyCoVar -> ForAllTyFlag -> ForAllTyFlag + -> CoercionN -> Coercion -> a -> a +-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep +assertGoodForAllCo tcv visL visR kind_co co + | isTyVar tcv + = assertPpr (tcv_type `eqType` kind_co_lkind) doc --- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. --- The kind of the tycovar should be the left-hand kind of the kind coercion. --- See Note [Unused coercion variable in ForAllCo] -mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion -mkForAllCo v kind_co co - | assert (varType v `eqType` (coercionLKind kind_co)) True - , assert (isTyVar v || almostDevoidCoVarOfCo v co) True - , Just (ty, r) <- isReflCo_maybe co - , isGReflCo kind_co - = mkReflCo r (mkTyCoInvForAllTy v ty) | otherwise - = ForAllCo v kind_co co + = assertPpr (tcv_type `eqType` kind_co_lkind) doc + -- The kind of the tycovar should be the left-hand kind of the kind coercion. + . assertPpr (almostDevoidCoVarOfCo tcv co) doc + -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep + . assertPpr (visL == coreTyLamForAllTyFlag + && visR == coreTyLamForAllTyFlag) doc + -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep + where + tcv_type = varType tcv + kind_co_lkind = coercionLKind kind_co --- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious --- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. --- The kind of the tycovar should be the left-hand kind of the kind coercion. -mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion -mkForAllCo_NoRefl v kind_co co - | assert (varType v `eqType` (coercionLKind kind_co)) True - , assert (not (isReflCo co)) True - , isCoVar v - , assert (almostDevoidCoVarOfCo v co) True - , not (v `elemVarSet` tyCoVarsOfCo co) - = mkFunCoNoFTF (coercionRole co) (multToCo ManyTy) kind_co co - -- Functions from coercions are always unrestricted - | otherwise - = ForAllCo v kind_co co + doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type + , text "Vis:" <+> ppr visL <+> ppr visR + , text "kind_co:" <+> ppr kind_co + , text "kind_co_lkind" <+> ppr kind_co_lkind + , text "body_co" <+> ppr co ] --- | Make nested ForAllCos -mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion -mkForAllCos bndrs co - | Just (ty, r ) <- isReflCo_maybe co - = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in - foldl' (flip $ uncurry mkForAllCo_NoRefl) - (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) - non_refls_rev'd - | otherwise - = foldr (uncurry mkForAllCo_NoRefl) co bndrs --- | Make a Coercion quantified over a type/coercion variable; --- the variable has the same type in both sides of the coercion -mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion -mkHomoForAllCos vs co - | Just (ty, r) <- isReflCo_maybe co - = mkReflCo r (mkTyCoInvForAllTys vs ty) +mkNakedForAllCo :: TyVar -- Never a CoVar + -> ForAllTyFlag -> ForAllTyFlag + -> CoercionN -> Coercion -> Coercion +-- This version lacks the assertion checks. +-- Used during type checking when the arguments may (legitimately) not be zonked +-- and so the assertions might (bogusly) fail +-- NB: since the coercions are un-zonked, we can't really deal with +-- (FC6) and (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep. +-- Fortunately we don't have to: this function is needed only for /type/ variables. +mkNakedForAllCo tv visL visR kind_co co + | assertPpr (isTyVar tv) (ppr tv) True + , Just (ty, r) <- isReflCo_maybe co + , isReflCo kind_co + , visL `eqForAllVis` visR + = mkReflCo r (mkForAllTy (Bndr tv visL) ty) | otherwise - = mkHomoForAllCos_NoRefl vs co + = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co } --- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious --- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. -mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion -mkHomoForAllCos_NoRefl vs orig_co - = assert (not (isReflCo orig_co)) - foldr go orig_co vs - where - go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co mkCoVarCo :: CoVar -> Coercion -- cv :: s ~# t @@ -1031,41 +1043,39 @@ optCoercion. Not a big deal either way. -} -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] +mkAxInstCo :: Role + -> CoAxiomRule -- Always BranchedAxiom or UnbranchedAxiom + -> [Type] -> [Coercion] -> Coercion -- mkAxInstCo can legitimately be called over-saturated; -- i.e. with more type arguments than the coercion requires -mkAxInstCo role ax index tys cos +-- Only called with BranchedAxiom or UnbranchedAxiom +mkAxInstCo role axr tys cos | arity == n_tys = downgradeRole role ax_role $ - mkAxiomInstCo ax_br index (rtys `chkAppend` cos) + AxiomCo axr (rtys `chkAppend` cos) | otherwise = assert (arity < n_tys) $ downgradeRole role ax_role $ - mkAppCos (mkAxiomInstCo ax_br index - (ax_args `chkAppend` cos)) + mkAppCos (AxiomCo axr (ax_args `chkAppend` cos)) leftover_args where - n_tys = length tys - ax_br = toBranchedAxiom ax - branch = coAxiomNthBranch ax_br index - tvs = coAxBranchTyVars branch - arity = length tvs - arg_roles = coAxBranchRoles branch - rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys - (ax_args, leftover_args) - = splitAt arity rtys - ax_role = coAxiomRole ax + (ax_role, branch) = case coAxiomRuleBranch_maybe axr of + Just (_tc, ax_role, branch) -> (ax_role, branch) + Nothing -> pprPanic "mkAxInstCo" (ppr axr) + n_tys = length tys + arity = length (coAxBranchTyVars branch) + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) = splitAt arity rtys -- worker function -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkAxiomInstCo ax index args - = assert (args `lengthIs` coAxiomArity ax index) $ - AxiomInstCo ax index args +mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomCo = AxiomCo -- to be used only with unbranched axioms mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched -> [Type] -> [Coercion] -> Coercion mkUnbranchedAxInstCo role ax tys cos - = mkAxInstCo role ax 0 tys cos + = mkAxInstCo role (UnbranchedAxiom ax) tys cos mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type -- Instantiate the axiom with specified types, @@ -1113,61 +1123,77 @@ -- | Make a universal coercion between two arbitrary types. mkUnivCo :: UnivCoProvenance + -> [Coercion] -- ^ Coercions on which this depends -> Role -- ^ role of the built coercion, "r" -> Type -- ^ t1 :: k1 -> Type -- ^ t2 :: k2 -> Coercion -- ^ :: t1 ~r t2 -mkUnivCo prov role ty1 ty2 +mkUnivCo prov deps role ty1 ty2 | ty1 `eqType` ty2 = mkReflCo role ty1 - | otherwise = UnivCo prov role ty1 ty2 + | otherwise = UnivCo { uco_prov = prov, uco_role = role + , uco_lty = ty1, uco_rty = ty2 + , uco_deps = deps } -- | Create a symmetric version of the given 'Coercion' that asserts -- equality between the same types but in the other "direction", so -- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. mkSymCo :: Coercion -> Coercion --- Do a few simple optimizations, but don't bother pushing occurrences --- of symmetry to the leaves; the optimizer will take care of that. -mkSymCo co | isReflCo co = co -mkSymCo (SymCo co) = co -mkSymCo (SubCo (SymCo co)) = SubCo co -mkSymCo co = SymCo co +-- Do a few simple optimizations, mainly to expose the underlying +-- constructors to other 'mk' functions. E.g. +-- mkInstCo (mkSymCo (ForAllCo ...)) ty +-- We want to push the SymCo inside the ForallCo, so that we can instantiate +-- This can make a big difference. E.g without coercion optimisation, GHC.Read +-- totally explodes; but when we push Sym inside ForAll, it's fine. +mkSymCo co | isReflCo co = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co }) + | isReflCo kco = co { fco_body = mkSymCo body_co } +mkSymCo co = SymCo co --- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. --- (co1 ; co2) -mkTransCo :: Coercion -> Coercion -> Coercion -mkTransCo co1 co2 | isReflCo co1 = co2 - | isReflCo co2 = co1 -mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) - = GRefl r t1 (MCo $ mkTransCo co1 co2) -mkTransCo co1 co2 = TransCo co1 co2 +-- | mkTransCo creates a new 'Coercion' by composing the two +-- given 'Coercion's transitively: (co1 ; co2) +mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion +mkTransCo co1 co2 + | isReflCo co1 = co2 + | isReflCo co2 = co1 + | GRefl r t1 (MCo kco1) <- co1 + , GRefl _ _ (MCo kco2) <- co2 + = GRefl r t1 (MCo $ mkTransCo kco1 kco2) + + | otherwise + = TransCo co1 co2 + +-------------------- +{- Note [mkSelCo precondition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To satisfy the Purely Kinded Type Invariant (PKTI), we require that + in any call (mkSelCo cs co) + * selectFromType cs (coercionLKind co) works + * selectFromType cs (coercionRKind co) works + * and hence coercionKind (SelCo cs co) works (PKTI) +-} + mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion +-- See Note [mkSelCo precondition] mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co mkSelCo_maybe :: HasDebugCallStack => CoSel -> Coercion -> Maybe Coercion --- mkSelCo_maybe tries to optimise call to mkSelCo +-- Note [mkSelCo precondition] mkSelCo_maybe cs co = assertPpr (good_call cs) bad_call_msg $ go cs co where - Pair ty1 ty2 = coercionKind co - go cs co - | Just (ty, _co_role) <- isReflCo_maybe co - = let new_role = coercionRole (SelCo cs co) - in Just (mkReflCo new_role (getNthFromType cs ty)) - -- The role of the result (new_role) does not have to - -- be equal to _co_role, the role of co, per Note [SelCo]. - -- This was revealed by #23938. - - go SelForAll (ForAllCo _ kind_co _) + go SelForAll (ForAllCo { fco_kind = kind_co }) = Just kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) -- then (nth SelForAll co :: k1 ~N k2) @@ -1185,9 +1211,30 @@ go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo = do { co' <- go cs co; return (mkSymCo co') } - go _ _ = Nothing + go cs co + | Just (ty, co_role) <- isReflCo_maybe co + = Just (mkReflCo (mkSelCoResRole cs co_role) (selectFromType cs ty)) + -- mkSelCoreResRole: The role of the result may not be + -- be equal to co_role, the role of co, per Note [SelCo]. + -- This was revealed by #23938. - -- Assertion checking + | Pair ty1 ty2 <- coercionKind co + , let sty1 = selectFromType cs ty1 + sty2 = selectFromType cs ty2 + co_role = coercionRole co + , sty1 `eqType` sty2 + = Just (mkReflCo (mkSelCoResRole cs co_role) sty1) + -- Checking for fully reflexive-ness (by seeing if sty1=sty2) + -- is worthwhile, because a non-Refl coercion `co` may well have a + -- reflexive (SelCo cs co). + -- E.g. co :: Either a b ~ Either a c + -- Then (SubCo (SelTyCon 0) co) is reflexive + + | otherwise = Nothing + + ----------- Assertion checking -------------- + -- NB: using coercionKind requires Note [mkSelCo precondition] + Pair ty1 ty2 = coercionKind co bad_call_msg = vcat [ text "Coercion =" <+> ppr co , text "LHS ty =" <+> ppr ty1 , text "RHS ty =" <+> ppr ty2 @@ -1216,6 +1263,14 @@ good_call _ = False +mkSelCoResRole :: CoSel -> Role -> Role +-- What is the role of (SelCo cs co), if co has role 'r'? +-- It is not just 'r'! +-- c.f. the SelCo case of coercionRole +mkSelCoResRole SelForAll _ = Nominal +mkSelCoResRole (SelTyCon _ r') _ = r' +mkSelCoResRole (SelFun fs) r = funRole r fs + -- | Extract the nth field of a FunCo getNthFun :: FunSel -> a -- ^ multiplicity @@ -1226,6 +1281,24 @@ getNthFun SelArg _ arg _ = arg getNthFun SelRes _ _ res = res +selectFromType :: HasDebugCallStack => CoSel -> Type -> Type +selectFromType (SelFun fs) ty + | Just (_af, mult, arg, res) <- splitFunTy_maybe ty + = getNthFun fs mult arg res + +selectFromType (SelTyCon n _) ty + | Just args <- tyConAppArgs_maybe ty + = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $ + args `getNth` n + +selectFromType SelForAll ty -- Works for both tyvar and covar + | Just (tv,_) <- splitForAllTyCoVar_maybe ty + = tyVarKind tv + +selectFromType cs ty + = pprPanic "selectFromType" (ppr cs $$ ppr ty) + +-------------------- mkLRCo :: LeftOrRight -> Coercion -> Coercion mkLRCo lr co | Just (ty, eq) <- isReflCo_maybe co @@ -1234,11 +1307,14 @@ = LRCo lr co -- | Instantiates a 'Coercion'. +-- Works for both tyvar and covar mkInstCo :: Coercion -> CoercionN -> Coercion -mkInstCo (ForAllCo tcv _kind_co body_co) co - | Just (arg, _) <- isReflCo_maybe co - -- works for both tyvar and covar - = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co +mkInstCo co_fun co_arg + | Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun + , Just (arg, _) <- isReflCo_maybe co_arg + = assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $ + -- If the arg is Refl, then kind_co must be reflexive too + substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co mkInstCo co arg = InstCo co arg -- | Given @ty :: k1@, @co :: k1 ~ k2@, @@ -1248,7 +1324,7 @@ | isGReflCo co = mkReflCo r ty -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ -- instead of @isReflCo@ - | otherwise = GRefl r ty (MCo co) + | otherwise = mkGReflMCo r ty co -- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, -- produces @co' :: (ty |> co) ~r ty@ @@ -1257,7 +1333,7 @@ | isGReflCo co = mkReflCo r ty -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ -- instead of @isReflCo@ - | otherwise = mkSymCo $ GRefl r ty (MCo co) + | otherwise = mkSymCo $ mkGReflMCo r ty co -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, -- produces @co' :: (ty |> co) ~r ty' @@ -1266,26 +1342,24 @@ mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion mkCoherenceLeftCo r ty co co2 | isGReflCo co = co2 - | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 + | otherwise = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2 -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, -- produces @co' :: ty' ~r (ty |> co) -- It is not only a utility function, but it saves allocation when co -- is a GRefl coercion. -mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion mkCoherenceRightCo r ty co co2 | isGReflCo co = co2 - | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) + | otherwise = co2 `mkTransCo` mkGReflMCo r ty co -- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. mkKindCo :: Coercion -> Coercion mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) mkKindCo (GRefl _ _ (MCo co)) = co -mkKindCo (UnivCo (PhantomProv h) _ _ _) = h -mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h mkKindCo co | Pair ty1 ty2 <- coercionKind co - -- generally, calling coercionKind during coercion creation is a bad idea, + -- Generally, calling coercionKind during coercion creation is a bad idea, -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, -- so it's OK here. , let tk1 = typeKind ty1 @@ -1336,9 +1410,6 @@ Just co' -> co' Nothing -> pprPanic "downgradeRole" (ppr co) -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion -mkAxiomRuleCo = AxiomRuleCo - -- | Make a "coercion between coercions". mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" -> CoercionN -- ^ :: phi1 ~N phi2 @@ -1350,8 +1421,8 @@ -- the individual coercions are. mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ -mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r - (mkCoercionTy g1) (mkCoercionTy g2) +mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r + (mkCoercionTy g1) (mkCoercionTy g2) {- %************************************************************************ @@ -1387,8 +1458,10 @@ = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 setNominalRole_maybe_helper (AppCo co1 co2) = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 - setNominalRole_maybe_helper (ForAllCo tv kind_co co) - = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper co@(ForAllCo { fco_visL = visL, fco_visR = visR, fco_body = body_co }) + | visL `eqForAllVis` visR -- See (FC3) in Note [ForAllCo] in GHC.Core.TyCo.Rep + = do { body_co' <- setNominalRole_maybe_helper body_co + ; return (co { fco_body = body_co' }) } setNominalRole_maybe_helper (SelCo cs co) = -- NB, this case recurses via setNominalRole_maybe, not -- setNominalRole_maybe_helper! @@ -1404,12 +1477,11 @@ pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co) setNominalRole_maybe_helper (InstCo co arg) = InstCo <$> setNominalRole_maybe_helper co <*> pure arg - setNominalRole_maybe_helper (UnivCo prov _ co1 co2) - | case prov of PhantomProv _ -> False -- should always be phantom - ProofIrrelProv _ -> True -- it's always safe - PluginProv _ -> False -- who knows? This choice is conservative. - CorePrepProv _ -> True - = Just $ UnivCo prov Nominal co1 co2 + setNominalRole_maybe_helper co@(UnivCo { uco_prov = prov }) + | case prov of PhantomProv {} -> False -- should always be phantom + ProofIrrelProv {} -> True -- it's always safe + PluginProv {} -> False -- who knows? This choice is conservative. + = Just $ co { uco_role = Nominal } setNominalRole_maybe_helper _ = Nothing -- | Make a phantom coercion between two types. The coercion passed @@ -1417,7 +1489,7 @@ -- types. mkPhantomCo :: Coercion -> Type -> Type -> Coercion mkPhantomCo h t1 t2 - = mkUnivCo (PhantomProv h) Phantom t1 t2 + = mkUnivCo PhantomProv [h] Phantom t1 t2 -- takes any coercion and turns it into a Phantom coercion toPhantomCo :: Coercion -> Coercion @@ -1478,7 +1550,7 @@ -- | like mkKindCo, but aggressively & recursively optimizes to avoid using -- a KindCo constructor. The output role is nominal. -promoteCoercion :: Coercion -> CoercionN +promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN -- First cases handles anything that should yield refl. promoteCoercion co = case co of @@ -1508,7 +1580,7 @@ | otherwise -> mkKindCo co - ForAllCo tv _ g + ForAllCo { fco_tcv = tv, fco_body = g } | isTyVar tv -> promoteCoercion g @@ -1519,22 +1591,19 @@ -- a coercion variable. So both sides have kind Type -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep). -- So the result is Refl, and that should have been caught by - -- the first equation above + -- the first equation above. Hence `assert False` mkNomReflCo liftedTypeKind FunCo {} -> mkKindCo co -- We can get Type~Constraint or Constraint~Type -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint)) - CoVarCo {} -> mkKindCo co - HoleCo {} -> mkKindCo co - AxiomInstCo {} -> mkKindCo co - AxiomRuleCo {} -> mkKindCo co - - UnivCo (PhantomProv kco) _ _ _ -> kco - UnivCo (ProofIrrelProv kco) _ _ _ -> kco - UnivCo (PluginProv _) _ _ _ -> mkKindCo co - UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co + CoVarCo {} -> mkKindCo co + HoleCo {} -> mkKindCo co + AxiomCo {} -> mkKindCo co + UnivCo {} -> mkKindCo co -- We could instead return the (single) `uco_deps` coercion in + -- the `ProofIrrelProv` and `PhantomProv` cases, but it doesn't + -- quite seem worth doing. SymCo g -> mkSymCo (promoteCoercion g) @@ -1641,8 +1710,8 @@ mkNomReflCo (mkCastTy t2 h) GRefl _ _ mco -> case mco of MRefl -> mkReflCo r (mkCastTy t2 h) - MCo kind_co -> GRefl r (mkCastTy t1 h) $ - MCo (mkSymCo h `mkTransCo` kind_co `mkTransCo` h) + MCo kind_co -> mkGReflMCo r (mkCastTy t1 h) + (mkSymCo h `mkTransCo` kind_co `mkTransCo` h) _ -> castCoercionKind2 g r t1 t2 h h -- | Creates a new coercion with both of its types casted by different casts @@ -1663,7 +1732,7 @@ -- | Make a forall 'Coercion', where both types related by the coercion -- are quantified over the same variable. mkPiCo :: Role -> Var -> Coercion -> Coercion -mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co +mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $ -- We didn't call mkForAllCo here because if v does not appear -- in co, the argument coercion will be nominal. But here we @@ -1681,7 +1750,7 @@ = mkFunCoNoFTF role mult arg_co res_co where arg_co = mkReflCo role (varType id) - mult = multToCo (varMult id) + mult = multToCo (idMult id) -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above @@ -1954,20 +2023,20 @@ -- Also maps coercion variables to ProofIrrelCos. -- like liftCoSubstWith, but allows for existentially-bound types as well -liftCoSubstWithEx :: Role -- desired role for output coercion - -> [TyVar] -- universally quantified tyvars +liftCoSubstWithEx :: [TyVar] -- universally quantified tyvars -> [Coercion] -- coercions to substitute for those -> [TyCoVar] -- existentially quantified tycovars -> [Type] -- types and coercions to be bound to ex vars - -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) -liftCoSubstWithEx role univs omegas exs rhos - = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) - psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) - in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) + -> (Type -> CoercionR, [Type]) -- (lifting function, converted ex args) + -- Returned coercion has Representational role +liftCoSubstWithEx univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual univs omegas) + psi = extendLiftingContextEx theta (zipEqual exs rhos) + in (ty_co_subst psi Representational, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion liftCoSubstWith r tvs cos ty - = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty + = liftCoSubst r (mkLiftingContext $ zipEqual tvs cos) ty -- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) -- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where @@ -1991,6 +2060,9 @@ mkSubstLiftingContext :: Subst -> LiftingContext mkSubstLiftingContext subst = LC subst emptyVarEnv +liftingContextSubst :: LiftingContext -> Subst +liftingContextSubst (LC subst _) = subst + -- | Extend a lifting context with a new mapping. extendLiftingContext :: LiftingContext -- ^ original LC -> TyCoVar -- ^ new variable to map... @@ -2003,6 +2075,15 @@ | otherwise = LC subst (extendVarEnv env tv arg) +-- | Extend the substitution component of a lifting context with +-- a new binding for a coercion variable. Used during coercion optimisation. +extendLiftingContextCvSubst :: LiftingContext + -> CoVar + -> Coercion + -> LiftingContext +extendLiftingContextCvSubst (LC subst env) cv co + = LC (extendCvSubst subst cv co) env + -- | Extend a lifting context with a new mapping, and extend the in-scope set extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC -> TyCoVar -- ^ new variable to map... @@ -2037,7 +2118,7 @@ -- lift_s2 :: s2 ~r s2' -- kco :: (s1 ~r s2) ~N (s1' ~r s2') assert (isCoVar v) $ - let (_, _, s1, s2, r) = coVarKindsTypesRole v + let (s1, s2, r) = coVarTypesRole v lift_s1 = ty_co_subst lc r s1 lift_s2 = ty_co_subst lc r s2 kco = mkTyConAppCo Nominal (equalityTyCon r) @@ -2056,15 +2137,11 @@ zapLiftingContext :: LiftingContext -> LiftingContext zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv --- | Like 'substForAllCoBndr', but works on a lifting context -substForAllCoBndrUsingLC :: Bool - -> (Coercion -> Coercion) - -> LiftingContext -> TyCoVar -> Coercion - -> (LiftingContext, TyCoVar, Coercion) -substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co - = (LC subst' lc_env, tv', co') +updateLCSubst :: LiftingContext -> (Subst -> (Subst, a)) -> (LiftingContext, a) +-- Lift a Subst-update function over LiftingContext +updateLCSubst (LC subst lc_env) upd = (LC subst' lc_env, res) where - (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co + (subst', res) = upd subst -- | The \"lifting\" operation which substitutes coercions for type -- variables in a type to produce a coercion. @@ -2082,22 +2159,22 @@ go r ty | Just ty' <- coreView ty = go r ty' go Phantom ty = lift_phantom ty - go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + go r (TyVarTy tv) = expectJust $ liftCoSubstTyVar lc r tv go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys) go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2) - go r t@(ForAllTy (Bndr v _) ty) + go r t@(ForAllTy (Bndr v vis) ty) = let (lc', v', h) = liftCoSubstVarBndr lc v body_co = ty_co_subst lc' r ty in if isTyVar v' || almostDevoidCoVarOfCo v' body_co -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo - -- imposes an extra restriction on where a covar can appear. See last - -- wrinkle in Note [Unused coercion variable in ForAllCo]. - -- We specifically check for this and panic because we know that - -- there's a hole in the type system here, and we'd rather panic than - -- fall into it. - then mkForAllCo v' h body_co + -- imposes an extra restriction on where a covar can appear. See + -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep + -- We specifically check for this and panic because we know that + -- there's a hole in the type system here (see (FC6), and we'd rather + -- panic than fall into it. + then mkForAllCo v' vis vis h body_co else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) go r ty@(LitTy {}) = assert (r == Nominal) $ mkNomReflCo ty @@ -2212,7 +2289,7 @@ stuff = fun lc old_kind eta = view_co stuff k1 = coercionLKind eta - new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) + new_var = uniqAway (substInScopeSet subst) (setVarType old_var k1) lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta -- :: new_var ~ new_var |> eta @@ -2232,7 +2309,7 @@ stuff = fun lc old_kind eta = view_co stuff k1 = coercionLKind eta - new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) + new_var = uniqAway (substInScopeSet subst) (setVarType old_var k1) -- old_var :: s1 ~r s2 -- eta :: (s1' ~r s2') ~N (t1 ~r t2) @@ -2310,13 +2387,13 @@ where equality_ty = selector (coercionKind co) --- | Extract the underlying substitution from the LiftingContext -lcSubst :: LiftingContext -> Subst -lcSubst (LC subst _) = subst +-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext' +lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion +lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getSubstInScope subst +lcInScopeSet (LC subst _) = substInScopeSet subst {- %************************************************************************ @@ -2331,33 +2408,28 @@ seqMCo (MCo co) = seqCo co seqCo :: Coercion -> () -seqCo (Refl ty) = seqType ty -seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco -seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos -seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k - `seq` seqCo co -seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq` - seqCo w `seq` seqCo co1 `seq` seqCo co2 -seqCo (CoVarCo cv) = cv `seq` () -seqCo (HoleCo h) = coHoleCoVar h `seq` () -seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos -seqCo (UnivCo p r t1 t2) - = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 -seqCo (SymCo co) = seqCo co -seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (SelCo n co) = n `seq` seqCo co -seqCo (LRCo lr co) = lr `seq` seqCo co -seqCo (InstCo co arg) = seqCo co `seq` seqCo arg -seqCo (KindCo co) = seqCo co -seqCo (SubCo co) = seqCo co -seqCo (AxiomRuleCo _ cs) = seqCos cs - -seqProv :: UnivCoProvenance -> () -seqProv (PhantomProv co) = seqCo co -seqProv (ProofIrrelProv co) = seqCo co -seqProv (PluginProv _) = () -seqProv (CorePrepProv _) = () +seqCo (Refl ty) = seqType ty +seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (CoVarCo cv) = cv `seq` () +seqCo (HoleCo h) = coHoleCoVar h `seq` () +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (SelCo n co) = n `seq` seqCo co +seqCo (LRCo lr co) = lr `seq` seqCo co +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (KindCo co) = seqCo co +seqCo (SubCo co) = seqCo co +seqCo (AxiomCo _ cs) = seqCos cs +seqCo (ForAllCo tv visL visR k co) + = seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq` + seqCo k `seq` seqCo co +seqCo (FunCo r af1 af2 w co1 co2) + = r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2 +seqCo (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = p `seq` r `seq` seqType t1 `seq` seqType t2 `seq` seqCos deps seqCos :: [Coercion] -> () seqCos [] = () @@ -2371,6 +2443,23 @@ %************************************************************************ -} +{- Note [coercionKind performance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +coercionKind, coercionLKind, and coercionRKind are very "hot" functions; in some +coercion-heavy programs they can have a material effect on compile time/allocation. + +Hence +* Rather than making one function which returns a pair (lots of allocation and + de-allocation) we have two functions, coercionLKind and coercionRKind, which + return the left and right kind respectively. + +* Both are defined by a single worker function `coercion_lr_kind`, which takes a + flag of type `LeftOrRight`. This worker function is marked INLINE, and inlined + at its precisely-two call-sites in coercionLKind and coercionRKind. + +Take care when making changes here... it's easy to accidentally add allocation! +-} + -- | Apply 'coercionKind' to multiple 'Coercion's coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys @@ -2390,124 +2479,108 @@ -- -- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. -coercionKind :: Coercion -> Pair Type +coercionKind :: HasDebugCallStack => Coercion -> Pair Type +-- See Note [coercionKind performance] coercionKind co = Pair (coercionLKind co) (coercionRKind co) -coercionLKind :: Coercion -> Type -coercionLKind co - = go co +coercionLKind, coercionRKind :: HasDebugCallStack => Coercion -> Type +-- See Note [coercionKind performance] +coercionLKind co = coercion_lr_kind CLeft co +coercionRKind co = coercion_lr_kind CRight co + +coercion_lr_kind :: HasDebugCallStack => LeftOrRight -> Coercion -> Type +{-# INLINE coercion_lr_kind #-} +-- See Note [coercionKind performance] +coercion_lr_kind which orig_co + = go orig_co where - go (Refl ty) = ty - go (GRefl _ ty _) = ty - go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) - go (AppCo co1 co2) = mkAppTy (go co1) (go co2) - go (ForAllCo tv1 _ co1) = mkTyCoInvForAllTy tv1 (go co1) - go (FunCo { fco_afl = af, fco_mult = mult, fco_arg = arg, fco_res = res}) - {- See Note [FunCo] -} = FunTy { ft_af = af, ft_mult = go mult - , ft_arg = go arg, ft_res = go res } - go (CoVarCo cv) = coVarLType cv - go (HoleCo h) = coVarLType (coHoleCoVar h) - go (UnivCo _ _ ty1 _) = ty1 - go (SymCo co) = coercionRKind co - go (TransCo co1 _) = go co1 - go (LRCo lr co) = pickLR lr (splitAppTy (go co)) - go (InstCo aco arg) = go_app aco [go arg] - go (KindCo co) = typeKind (go co) - go (SubCo co) = go co - go (SelCo d co) = getNthFromType d (go co) - go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) - go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ - coaxrProves ax $ map coercionKind cos + go (Refl ty) = ty + go (GRefl _ ty MRefl) = ty + go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty co1) + go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) + go (AppCo co1 co2) = mkAppTy (go co1) (go co2) + go (CoVarCo cv) = go_covar cv + go (HoleCo h) = go_covar (coHoleCoVar h) + go (SymCo co) = pickLR which (coercionRKind co, coercionLKind co) + go (TransCo co1 co2) = pickLR which (go co1, go co2) + go (LRCo lr co) = pickLR lr (splitAppTy (go co)) + go (InstCo aco arg) = go_app aco [go arg] + go (KindCo co) = typeKind (go co) + go (SubCo co) = go co + go (SelCo d co) = selectFromType d (go co) + go (AxiomCo ax cos) = go_ax ax cos - go_ax_inst ax ind tys - | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs } <- coAxiomNthBranch ax ind - , let (tys1, cotys1) = splitAtList tvs tys - cos1 = map stripCoercionTy cotys1 - = assert (tys `equalLength` (tvs ++ cvs)) $ - -- Invariant of AxiomInstCo: cos should - -- exactly saturate the axiom branch - substTyWith tvs tys1 $ - substTyWithCoVars cvs cos1 $ - mkTyConApp (coAxiomTyCon ax) lhs + go (UnivCo { uco_lty = lty, uco_rty = rty}) + = pickLR which (lty, rty) + go (FunCo { fco_afl = afl, fco_afr = afr, fco_mult = mult + , fco_arg = arg, fco_res = res}) + = -- See Note [FunCo] + FunTy { ft_af = pickLR which (afl, afr), ft_mult = go mult + , ft_arg = go arg, ft_res = go res } + go co@(ForAllCo { fco_tcv = tv1, fco_visL = visL, fco_visR = visR + , fco_kind = k_co, fco_body = co1 }) + = case which of + CLeft -> mkTyCoForAllTy tv1 visL (go co1) + CRight | isGReflCo k_co -- kind_co always has kind `Type`, thus `isGReflCo` + -> mkTyCoForAllTy tv1 visR (go co1) + | otherwise + -> go_forall_right empty_subst co + where + empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co) + + ------------- + go_covar cv = pickLR which (coVarLType cv, coVarRType cv) + + ------------- go_app :: Coercion -> [Type] -> Type -- Collect up all the arguments and apply all at once -- See Note [Nested InstCos] go_app (InstCo co arg) args = go_app co (go arg:args) go_app co args = piResultTys (go co) args -getNthFromType :: HasDebugCallStack => CoSel -> Type -> Type -getNthFromType (SelFun fs) ty - | Just (_af, mult, arg, res) <- splitFunTy_maybe ty - = getNthFun fs mult arg res - -getNthFromType (SelTyCon n _) ty - | Just args <- tyConAppArgs_maybe ty - = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $ - args `getNth` n - -getNthFromType SelForAll ty -- Works for both tyvar and covar - | Just (tv,_) <- splitForAllTyCoVar_maybe ty - = tyVarKind tv - -getNthFromType cs ty - = pprPanic "getNthFromType" (ppr cs $$ ppr ty) + ------------- + go_ax axr@(BuiltInFamRew bif) cos = check_bif_res axr (bifrw_proves bif (map coercionKind cos)) + go_ax axr@(BuiltInFamInj bif) [co] = check_bif_res axr (bifinj_proves bif (coercionKind co)) + go_ax axr@(BuiltInFamInj {}) _ = crash axr + go_ax (UnbranchedAxiom ax) cos = go_branch ax (coAxiomSingleBranch ax) cos + go_ax (BranchedAxiom ax i) cos = go_branch ax (coAxiomNthBranch ax i) cos -coercionRKind :: Coercion -> Type -coercionRKind co - = go co - where - go (Refl ty) = ty - go (GRefl _ ty MRefl) = ty - go (GRefl _ ty (MCo co1)) = mkCastTy ty co1 - go (TyConAppCo _ tc cos) = mkTyConApp tc (map go cos) - go (AppCo co1 co2) = mkAppTy (go co1) (go co2) - go (CoVarCo cv) = coVarRType cv - go (HoleCo h) = coVarRType (coHoleCoVar h) - go (FunCo { fco_afr = af, fco_mult = mult, fco_arg = arg, fco_res = res}) - {- See Note [FunCo] -} = FunTy { ft_af = af, ft_mult = go mult - , ft_arg = go arg, ft_res = go res } - go (UnivCo _ _ _ ty2) = ty2 - go (SymCo co) = coercionLKind co - go (TransCo _ co2) = go co2 - go (LRCo lr co) = pickLR lr (splitAppTy (go co)) - go (InstCo aco arg) = go_app aco [go arg] - go (KindCo co) = typeKind (go co) - go (SubCo co) = go co - go (SelCo d co) = getNthFromType d (go co) - go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) - go (AxiomRuleCo ax cos) = pSnd $ expectJust "coercionKind" $ - coaxrProves ax $ map coercionKind cos + ------------- + check_bif_res _ (Just (Pair lhs rhs)) = pickLR which (lhs,rhs) + check_bif_res axr Nothing = crash axr - go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar - | isGReflCo k_co = mkTyCoInvForAllTy tv1 (go co1) - -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = go_forall empty_subst co - where - empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co) + crash :: CoAxiomRule -> Type + crash axr = pprPanic "coercionKind" (ppr axr) - go_ax_inst ax ind tys - | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind - , let (tys2, cotys2) = splitAtList tvs tys - cos2 = map stripCoercionTy cotys2 - = assert (tys `equalLength` (tvs ++ cvs)) $ - -- Invariant of AxiomInstCo: cos should + ------------- + go_branch :: CoAxiom br -> CoAxBranch -> [Coercion] -> Type + go_branch ax (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_tys, cab_rhs = rhs_ty }) cos + = assert (cos `equalLength` tcvs) $ + -- Invariant of AxiomRuleCo: cos should -- exactly saturate the axiom branch - substTyWith tvs tys2 $ - substTyWithCoVars cvs cos2 rhs - - go_app :: Coercion -> [Type] -> Type - -- Collect up all the arguments and apply all at once - -- See Note [Nested InstCos] - go_app (InstCo co arg) args = go_app co (go arg:args) - go_app co args = piResultTys (go co) args + let (tys1, cotys1) = splitAtList tvs tys + cos1 = map stripCoercionTy cotys1 + in + -- You might think to use + -- substTy (zipTCvSubst tcvs ltys) (pickLR ...) + -- but #25066 makes it much less efficient than the silly calls below + substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + pickLR which (mkTyConApp tc lhs_tys, rhs_ty) + where + tc = coAxiomTyCon ax + tcvs | null cvs = tvs -- Very common case (currently always!) + | otherwise = tvs ++ cvs + tys = map go cos - go_forall subst (ForAllCo tv1 k_co co) + ------------- + go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR + , fco_kind = k_co, fco_body = co }) -- See Note [Nested ForAllCos] | isTyVar tv1 - = mkInfForAllTy tv2 (go_forall subst' co) + = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co) where k2 = coercionRKind k_co tv2 = setTyVarKind tv1 (substTy subst k2) @@ -2516,9 +2589,10 @@ | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $ TyVarTy tv2 `mkCastTy` mkSymCo k_co - go_forall subst (ForAllCo cv1 k_co co) + go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR + , fco_kind = k_co, fco_body = co }) | isCoVar cv1 - = mkTyCoInvForAllTy cv2 (go_forall subst' co) + = mkTyCoForAllTy cv2 visR (go_forall_right subst' co) where k2 = coercionRKind k_co r = coVarRole cv1 @@ -2541,53 +2615,22 @@ | otherwise = extendCvSubst (extendSubstInScope subst cv2) cv1 n_subst - go_forall subst other_co + go_forall_right subst other_co -- when other_co is not a ForAllCo = substTy subst (go other_co) -{- - -Note [Nested ForAllCos] -~~~~~~~~~~~~~~~~~~~~~~~ - -Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an -co)...) )`. We do not want to perform `n` single-type-variable -substitutions over the kind of `co`; rather we want to do one substitution -which substitutes for all of `a1`, `a2` ... simultaneously. If we do one -at a time we get the performance hole reported in #11735. +{- Note [Nested ForAllCos] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an co)...) )`. +We do not want to perform `n` single-type-variable substitutions over the kind +of `co`; rather we want to do one substitution which substitutes for all of +`a1`, `a2` ... simultaneously. If we do one at a time we get the performance +hole reported in #11735. Solution: gather up the type variables for nested `ForAllCos`, and substitute for them all at once. Remarkably, for #11735 this single change reduces /total/ compile time by a factor of more than ten. --} - --- | Retrieve the role from a coercion. -coercionRole :: Coercion -> Role -coercionRole = go - where - go (Refl _) = Nominal - go (GRefl r _ _) = r - go (TyConAppCo r _ _) = r - go (AppCo co1 _) = go co1 - go (ForAllCo _ _ co) = go co - go (FunCo { fco_role = r }) = r - go (CoVarCo cv) = coVarRole cv - go (HoleCo h) = coVarRole (coHoleCoVar h) - go (AxiomInstCo ax _ _) = coAxiomRole ax - go (UnivCo _ r _ _) = r - go (SymCo co) = go co - go (TransCo co1 _co2) = go co1 - go (SelCo SelForAll _co) = Nominal - go (SelCo (SelTyCon _ r) _co) = r - go (SelCo (SelFun fs) co) = funRole (coercionRole co) fs - go (LRCo {}) = Nominal - go (InstCo co _) = go co - go (KindCo {}) = Nominal - go (SubCo _) = Representational - go (AxiomRuleCo ax _) = coaxrRole ax - -{- Note [Nested InstCos] ~~~~~~~~~~~~~~~~~~~~~ In #5631 we found that 70% of the entire compilation time was @@ -2601,57 +2644,47 @@ But this is a *quadratic* algorithm, and the blew up #5631. So it's very important to do the substitution simultaneously; cf Type.piResultTys (which in fact we call here). - -} +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl _) = Nominal + go (GRefl r _ _) = r + go (TyConAppCo r _ _) = r + go (AppCo co1 _) = go co1 + go (ForAllCo { fco_body = co }) = go co + go (FunCo { fco_role = r }) = r + go (CoVarCo cv) = coVarRole cv + go (HoleCo h) = coVarRole (coHoleCoVar h) + go (UnivCo { uco_role = r }) = r + go (SymCo co) = go co + go (TransCo co1 _co2) = go co1 + go (SelCo cs co) = mkSelCoResRole cs (coercionRole co) + go (LRCo {}) = Nominal + go (InstCo co _) = go co + go (KindCo {}) = Nominal + go (SubCo _) = Representational + go (AxiomCo ax _) = coAxiomRuleRole ax + -- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' mkCoercionType :: Role -> Type -> Type -> Type -mkCoercionType Nominal = mkPrimEqPred -mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Nominal = mkNomEqPred +mkCoercionType Representational = mkReprEqPred mkCoercionType Phantom = \ty1 ty2 -> let ki1 = typeKind ty1 ki2 = typeKind ty2 in TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] --- | Creates a primitive nominal type equality predicate. --- t1 ~# t2 --- Invariant: the types are not Coercions -mkPrimEqPred :: Type -> Type -> Type -mkPrimEqPred ty1 ty2 - = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Creates a primitive representational type equality predicate. --- t1 ~R# t2 --- Invariant: the types are not Coercions -mkReprPrimEqPred :: Type -> Type -> Type -mkReprPrimEqPred ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind ty2 - --- | Makes a lifted equality predicate at the given role -mkPrimEqPredRole :: Role -> Type -> Type -> PredType -mkPrimEqPredRole Nominal = mkPrimEqPred -mkPrimEqPredRole Representational = mkReprPrimEqPred -mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" - --- | Creates a primitive nominal type equality predicate with an explicit --- (but homogeneous) kind: (~#) k k ty1 ty2 -mkNomPrimEqPred :: Kind -> Type -> Type -> Type -mkNomPrimEqPred k ty1 ty2 = mkTyConApp eqPrimTyCon [k, k, ty1, ty2] - -- | Assuming that two types are the same, ignoring coercions, find -- a nominal coercion between the types. This is useful when optimizing -- transitivity over coercion applications, where splitting two -- AppCos might yield different kinds. See Note [EtaAppCo] in -- "GHC.Core.Coercion.Opt". -buildCoercion :: Type -> Type -> CoercionN +buildCoercion :: HasDebugCallStack => Type -> Type -> CoercionN buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 where go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 @@ -2679,7 +2712,10 @@ mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2) go (TyConApp tc1 args1) (TyConApp tc2 args2) - = assert (tc1 == tc2) $ + = assertPpr (tc1 == tc2) (vcat [ ppr tc1 <+> ppr tc2 + , text "orig_ty1:" <+> ppr orig_ty1 + , text "orig_ty2:" <+> ppr orig_ty2 + ]) $ mkTyConAppCo Nominal tc1 (zipWith go args1 args2) go (AppTy ty1a ty1b) ty2 @@ -2690,19 +2726,19 @@ | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) + go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2) | isTyVar tv1 = assert (isTyVar tv2) $ - mkForAllCo tv1 kind_co (go ty1 ty2') + mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2') where kind_co = go (tyVarKind tv1) (tyVarKind tv2) in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTyWithInScope in_scope [tv2] [mkTyVarTy tv1 `mkCastTy` kind_co] ty2 - go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) + go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2) = assert (isCoVar cv1 && isCoVar cv2) $ - mkForAllCo cv1 kind_co (go ty1 ty2') + mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2') where s1 = varType cv1 s2 = varType cv2 kind_co = go s1 s2 @@ -2750,39 +2786,22 @@ -} has_co_hole_ty :: Type -> Monoid.Any -has_co_hole_co :: Coercion -> Monoid.Any -(has_co_hole_ty, _, has_co_hole_co, _) +(has_co_hole_ty, _, _, _) = foldTyCo folder () where folder = TyCoFolder { tcf_view = noView , tcf_tyvar = const2 (Monoid.Any False) , tcf_covar = const2 (Monoid.Any False) - , tcf_hole = \_ hole -> Monoid.Any (isHeteroKindCoHole hole) + , tcf_hole = \_ _ -> Monoid.Any True , tcf_tycobinder = const2 } --- | Is there a hetero-kind coercion hole in this type? --- (That is, a coercion hole with ch_hetero_kind=True.) --- See wrinkle (EIK2) of Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality -hasCoercionHoleTy :: Type -> Bool -hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty - --- | Is there a hetero-kind coercion hole in this coercion? -hasCoercionHoleCo :: Coercion -> Bool -hasCoercionHoleCo = Monoid.getAny . has_co_hole_co - -hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool -hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty) - where - (f, _, _, _) = foldTyCo folder () - - folder = TyCoFolder { tcf_view = noView - , tcf_tyvar = const2 (Monoid.Any False) - , tcf_covar = const2 (Monoid.Any False) - , tcf_hole = \ _ h -> Monoid.Any (getUnique h == getUnique hole) - , tcf_tycobinder = const2 - } +-- | Is there a coercion hole in this type? +-- See wrinkle (DE6) of Note [Defaulting equalities] in GHC.Tc.Solver.Default +hasCoercionHole :: Type -> Bool +hasCoercionHole = Monoid.getAny . has_co_hole_ty -- | Set the type of a 'CoercionHole' setCoHoleType :: CoercionHole -> Type -> CoercionHole setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t) + diff --git a/GHC/Core/Coercion.hs-boot b/GHC/Core/Coercion.hs-boot --- a/GHC/Core/Coercion.hs-boot +++ b/GHC/Core/Coercion.hs-boot @@ -16,16 +16,15 @@ mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion -mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion +mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkCoVarCo :: CoVar -> Coercion -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> [Coercion] -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion -mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion mkLRCo :: LeftOrRight -> Coercion -> Coercion mkInstCo :: Coercion -> Coercion -> Coercion @@ -34,7 +33,7 @@ mkKindCo :: Coercion -> Coercion mkSubCo :: HasDebugCallStack => Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion -mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion funRole :: Role -> FunSel -> Role @@ -42,16 +41,16 @@ isReflCo :: Coercion -> Bool isReflexiveCo :: Coercion -> Bool decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) -coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) +coVarTypesRole :: HasDebugCallStack => CoVar -> (Type, Type, Role) coVarRole :: CoVar -> Role mkCoercionType :: Role -> Type -> Type -> Type seqCo :: Coercion -> () -coercionKind :: Coercion -> Pair Type -coercionLKind :: Coercion -> Type -coercionRKind :: Coercion -> Type +coercionKind :: HasDebugCallStack => Coercion -> Pair Type +coercionLKind :: HasDebugCallStack => Coercion -> Type +coercionRKind :: HasDebugCallStack => Coercion -> Type coercionType :: Coercion -> Type topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) diff --git a/GHC/Core/Coercion/Axiom.hs b/GHC/Core/Coercion/Axiom.hs --- a/GHC/Core/Coercion/Axiom.hs +++ b/GHC/Core/Coercion/Axiom.hs @@ -30,7 +30,9 @@ Role(..), fsFromRole, - CoAxiomRule(..), TypeEqn, + CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn, + coAxiomRuleArgRoles, coAxiomRuleRole, + coAxiomRuleBranch_maybe, isNewtypeAxiomRule_maybe, BuiltInSynFamily(..), trivialBuiltInFamily ) where @@ -40,7 +42,7 @@ import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar ) -import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import {-# SOURCE #-} GHC.Core.TyCon ( TyCon, isNewTyCon ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Name @@ -49,7 +51,6 @@ import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable ) @@ -57,6 +58,7 @@ import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL ) +import Control.DeepSeq {- Note [Coercion axiom branches] @@ -80,12 +82,12 @@ ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char } -The axiom is used with the AxiomInstCo constructor of Coercion. If we wish +The axiom is used with the AxiomCo constructor of Coercion. If we wish to have a coercion showing that F (Maybe Int) ~ Char, it will look like axF[2] <*> :: F (Maybe Int) ~ Char -- or, written using concrete-ish syntax -- -AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] +AxiomRuleCo axF 2 [Refl *, Refl Maybe, Refl Int] Note that the index is 0-based. @@ -128,9 +130,22 @@ ************************************************************************ -} -type BranchIndex = Int -- The index of the branch in the list of branches - -- Counting from zero +{- Note [BranchIndex] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) +-} + +type BranchIndex = Int -- Counting from zero + -- The index of the branch in the list of branches + -- See Note [BranchIndex] + -- promoted data type data BranchFlag = Branched | Unbranched type Branched = 'Branched @@ -251,7 +266,7 @@ -- cab_tvs and cab_lhs may be eta-reduced; see -- Note [Eta reduction for data families] , cab_cvs :: [CoVar] - -- ^ Bound coercion variables + -- ^ Bound coercion variables -- Always empty, for now. -- See Note [Constraints in patterns] -- in GHC.Tc.TyCl @@ -269,20 +284,16 @@ deriving Data.Data toBranchedAxiom :: CoAxiom br -> CoAxiom Branched -toBranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toBranched branches) implicit +toBranchedAxiom ax@(CoAxiom { co_ax_branches = branches }) + = ax { co_ax_branches = toBranched branches } toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched -toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) - = CoAxiom unique name role tc (toUnbranched branches) implicit +toUnbranchedAxiom ax@(CoAxiom { co_ax_branches = branches }) + = ax { co_ax_branches = toUnbranched branches } coAxiomNumPats :: CoAxiom br -> Int coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) -coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch -coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index - = branchesNth bs index - coAxiomArity :: CoAxiom br -> BranchIndex -> Arity coAxiomArity ax index = length tvs + length cvs @@ -297,6 +308,14 @@ coAxiomBranches :: CoAxiom br -> Branches br coAxiomBranches = co_ax_branches +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = branchesNth bs index + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) + = arr ! 0 + coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) | snd (bounds arr) == 0 @@ -304,10 +323,6 @@ | otherwise = Nothing -coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch -coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) - = arr ! 0 - coAxiomTyCon :: CoAxiom br -> TyCon coAxiomTyCon = co_ax_tc @@ -545,6 +560,11 @@ 3 -> return Phantom _ -> panic ("get Role " ++ show tag) +instance NFData Role where + rnf Nominal = () + rnf Representational = () + rnf Phantom = () + {- ************************************************************************ * * @@ -553,76 +573,177 @@ * * ************************************************************************ -Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: +Note [CoAxiomRule] +~~~~~~~~~~~~~~~~~~ +A CoAxiomRule is a built-in axiom, one that we assume to be true: +CoAxiomRules come in four flavours: - forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 +* BuiltInFamRew: provides evidence for, say + (ax1) 3+4 ----> 7 + (ax2) s+0 ----> s + The evidence looks like + AxiomCo ax1 [3,4] :: 3+4 ~ 7 + AxiomCo ax2 [s] :: s+0 ~ s + The arguments in the AxiomCo are the /instantiating types/, or + more generally coercions (see Note [Coercion axioms applied to coercions] + in GHC.Core.TyCo.Rep). -My intention is to reuse these for both (~) and (~#). -The short-term plan is to use this datatype to represent the type-nat axioms. -In the longer run, it may be good to unify this and `CoAxiom`, -as `CoAxiom` is the special case when there are no assumptions. +* BuiltInFamInj: provides evidence for the injectivity of type families + For example + (ax3) g1: a+b ~ 0 ---> a~0 + (ax4) g2: a+b ~ 0 ---> b~0 + (ax5) g3: a+b1 ~ a~b2 ---> b1~b2 + The argument to the AxiomCo is the full coercion (always just one). + So then: + AxiomCo ax3 [g1] :: a ~ 0 + AxiomCo ax4 [g2] :: b ~ 0 + AxiomCo ax5 [g3] :: b1 ~ b2 + +* BranchedAxiom: used for closed type families + type family F a where + F Int = Bool + F Bool = Char + F a = a -> Int + We get one (CoAxiom Branched) for the entire family; when used in an + AxiomCo we pair it with the BranchIndex to say which branch to pick. + +* UnbranchedAxiom: used for several purposes; + - Newtypes + - Data family instances + - Open type family instances + +Note [Avoiding allocating lots of CoAxiomRules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CoAxiomRule is a sum type of four alternatives, which is very nice. But +there is a danger of allocating lots of (BuiltInFamRew bif) objects, every +time we (say) need a type-family rewrite. + +To avoid this allocation, we cache the appropraite CoAxiomRule inside each + BuiltInFamRewrite, BuiltInFamInjectivity +making a little circular data structure. See the `bifrw_axr` field of +BuiltInFamRewrite, and similarly the others. + +It's simple to do this, and saves a percent or two of allocation in programs +that do a lot of type-family work. -} --- | A more explicit representation for `t1 ~ t2`. -type TypeEqn = Pair Type +-- | CoAxiomRule describes a built-in axiom, one that we assume to be true +-- See Note [CoAxiomRule] +data CoAxiomRule + = BuiltInFamRew BuiltInFamRewrite -- Built-in type-family rewrites + -- e.g. 3+5 ~ 7 --- | For now, we work only with nominal equality. -data CoAxiomRule = CoAxiomRule - { coaxrName :: FastString - , coaxrAsmpRoles :: [Role] -- roles of parameter equations - , coaxrRole :: Role -- role of resulting equation - , coaxrProves :: [TypeEqn] -> Maybe TypeEqn - -- ^ coaxrProves returns @Nothing@ when it doesn't like - -- the supplied arguments. When this happens in a coercion - -- that means that the coercion is ill-formed, and Core Lint - -- checks for that. - } + | BuiltInFamInj BuiltInFamInjectivity -- Built-in type-family deductions + -- e.g. a+b~0 ==> a~0 + -- Always unary + | BranchedAxiom (CoAxiom Branched) BranchIndex -- Closed type family + + | UnbranchedAxiom (CoAxiom Unbranched) -- Open type family instance, + -- data family instances + -- and newtypes + +instance Eq CoAxiomRule where + (BuiltInFamRew bif1) == (BuiltInFamRew bif2) = bifrw_name bif1 == bifrw_name bif2 + (BuiltInFamInj bif1) == (BuiltInFamInj bif2) = bifinj_name bif1 == bifinj_name bif2 + (UnbranchedAxiom ax1) == (UnbranchedAxiom ax2) = getUnique ax1 == getUnique ax2 + (BranchedAxiom ax1 i1) == (BranchedAxiom ax2 i2) = getUnique ax1 == getUnique ax2 && i1 == i2 + _ == _ = False + +coAxiomRuleRole :: CoAxiomRule -> Role +coAxiomRuleRole (BuiltInFamRew {}) = Nominal +coAxiomRuleRole (BuiltInFamInj {}) = Nominal +coAxiomRuleRole (UnbranchedAxiom ax) = coAxiomRole ax +coAxiomRuleRole (BranchedAxiom ax _) = coAxiomRole ax + +coAxiomRuleArgRoles :: CoAxiomRule -> [Role] +coAxiomRuleArgRoles (BuiltInFamRew bif) = replicate (bifrw_arity bif) Nominal +coAxiomRuleArgRoles (BuiltInFamInj {}) = [Nominal] +coAxiomRuleArgRoles (UnbranchedAxiom ax) = coAxBranchRoles (coAxiomSingleBranch ax) +coAxiomRuleArgRoles (BranchedAxiom ax i) = coAxBranchRoles (coAxiomNthBranch ax i) + +coAxiomRuleBranch_maybe :: CoAxiomRule -> Maybe (TyCon, Role, CoAxBranch) +coAxiomRuleBranch_maybe (UnbranchedAxiom ax) = Just (co_ax_tc ax, co_ax_role ax, coAxiomSingleBranch ax) +coAxiomRuleBranch_maybe (BranchedAxiom ax i) = Just (co_ax_tc ax, co_ax_role ax, coAxiomNthBranch ax i) +coAxiomRuleBranch_maybe _ = Nothing + +isNewtypeAxiomRule_maybe :: CoAxiomRule -> Maybe (TyCon, CoAxBranch) +isNewtypeAxiomRule_maybe (UnbranchedAxiom ax) + | let tc = coAxiomTyCon ax, isNewTyCon tc = Just (tc, coAxiomSingleBranch ax) +isNewtypeAxiomRule_maybe _ = Nothing + instance Data.Data CoAxiomRule where -- don't traverse? toConstr _ = abstractConstr "CoAxiomRule" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "CoAxiomRule" -instance Uniquable CoAxiomRule where - getUnique = getUnique . coaxrName +instance Outputable CoAxiomRule where + ppr (BuiltInFamRew bif) = ppr (bifrw_name bif) + ppr (BuiltInFamInj bif) = ppr (bifinj_name bif) + ppr (UnbranchedAxiom ax) = ppr (coAxiomName ax) + ppr (BranchedAxiom ax i) = ppr (coAxiomName ax) <> brackets (int i) -instance Eq CoAxiomRule where - x == y = coaxrName x == coaxrName y +{- ********************************************************************* +* * + Built-in families +* * +********************************************************************* -} -instance Ord CoAxiomRule where - -- we compare lexically to avoid non-deterministic output when sets of rules - -- are printed - compare x y = lexicalCompareFS (coaxrName x) (coaxrName y) -instance Outputable CoAxiomRule where - ppr = ppr . coaxrName - +-- | A more explicit representation for `t1 ~ t2`. +type TypeEqn = Pair Type -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily - { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) - -- Does this reduce on the given arguments? - -- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type) - -- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) - -- :: F tys ~r rhs, - -- where the r in the output is coaxrRole of the rule. It is up to the - -- caller to ensure that this role is appropriate. - - , sfInteractTop :: [Type] -> Type -> [TypeEqn] + { sfMatchFam :: [BuiltInFamRewrite] + , sfInteract :: [BuiltInFamInjectivity] -- If given these type arguments and RHS, returns the equalities that - -- are guaranteed to hold. - - , sfInteractInert :: [Type] -> Type -> - [Type] -> Type -> [TypeEqn] - -- If given one set of arguments and result, and another set of arguments - -- and result, returns the equalities that are guaranteed to hold. + -- are guaranteed to hold. That is, if + -- (ar, Pair s1 s2) is an element of (sfInteract tys ty) + -- then AxiomRule ar [co :: F tys ~ ty] :: s1~s2 } +data BuiltInFamInjectivity -- Argument and result role are always Nominal + = BIF_Interact + { bifinj_name :: FastString + , bifinj_axr :: CoAxiomRule -- Cached copy of (BuiltInFamINj this-bif) + -- See Note [Avoiding allocating lots of CoAxiomRules] + + , bifinj_proves :: TypeEqn -> Maybe TypeEqn + -- ^ Always unary: just one TypeEqn argument + -- Returns @Nothing@ when it doesn't like the supplied argument. + -- When this happens in a coercion that means that the coercion is + -- ill-formed, and Core Lint checks for that. + } + +data BuiltInFamRewrite -- Argument roles and result role are always Nominal + = BIF_Rewrite + { bifrw_name :: FastString + , bifrw_axr :: CoAxiomRule -- Cached copy of (BuiltInFamRew this-bif) + -- See Note [Avoiding allocating lots of CoAxiomRules] + + , bifrw_fam_tc :: TyCon -- Needed for tyConsOfType + + , bifrw_arity :: Arity -- Number of type arguments needed + -- to instantiate this axiom + + , bifrw_match :: [Type] -> Maybe ([Type], Type) + -- coaxrMatch: does this reduce on the given arguments? + -- If it does, returns (types to instantiate the rule at, rhs type) + -- That is: mkAxiomCo ax (zipWith mkReflCo coAxiomRuleArgRoles ts) + -- :: F tys ~N rhs, + + , bifrw_proves :: [TypeEqn] -> Maybe TypeEqn } + -- length(inst_tys) = bifrw_arity + + -- INVARIANT: bifrw_match and bifrw_proves are related as follows: + -- If Just (inst_tys, res_ty) = bifrw_match ax arg_tys + -- then * length arg_tys = tyConArity fam_tc + -- * length inst_tys = bifrw_arity + -- * bifrw_proves (map (return @Pair) inst_tys) = Just (return @Pair res_ty) + + -- Provides default implementations that do nothing. trivialBuiltInFamily :: BuiltInSynFamily -trivialBuiltInFamily = BuiltInSynFamily - { sfMatchFam = \_ -> Nothing - , sfInteractTop = \_ _ -> [] - , sfInteractInert = \_ _ _ _ -> [] - } +trivialBuiltInFamily = BuiltInSynFamily { sfMatchFam = [], sfInteract = [] } diff --git a/GHC/Core/Coercion/Opt.hs b/GHC/Core/Coercion/Opt.hs --- a/GHC/Core/Coercion/Opt.hs +++ b/GHC/Core/Coercion/Opt.hs @@ -14,25 +14,24 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Compare( eqType, eqForAllVis ) import GHC.Core.Coercion import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify +import GHC.Types.Basic( SwapFlag(..), flipSwap, isSwapped, pickSwap, notSwapped ) +import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Unique.Set import GHC.Data.Pair -import GHC.Data.List.SetOps ( getNth ) import GHC.Utils.Outputable import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad ( zipWithM ) @@ -68,33 +67,56 @@ Note [Optimising InstCo] ~~~~~~~~~~~~~~~~~~~~~~~~ -(1) tv is a type variable -When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. +Optimising InstCo is pretty subtle: #15725, #25387. -Let's look at the typing rules. +(1) tv is a type variable. We want to optimise -h : k1 ~ k2 -tv:k1 |- g : t1 ~ t2 ------------------------------ -ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) + InstCo (ForAllCo tv kco g) g2 --> S(g) -g1 : (all tv:k1.t1') ~ (all tv:k2.t2') -g2 : s1 ~ s2 --------------------- -InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] +where S is some substitution. Let's look at the typing rules. -We thus want some coercion proving this: + kco : k1 ~ k2 + tv:k1 |- g : t1 ~ t2 + ----------------------------- + ForAllCo tv kco g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym kco]) - (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) + g1 : (all tv:k1.t1') ~ (all tv:k2.t2') + g2 : (s1:k1) ~ (s2:k2) + -------------------- + InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] -If we substitute the *type* tv for the *coercion* -(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. -This is bizarre, -though, because we're substituting a type variable with a coercion. However, -this operation already exists: it's called *lifting*, and defined in GHC.Core.Coercion. -We just need to enhance the lifting operation to be able to deal with -an ambient substitution, which is why a LiftingContext stores a TCvSubst. +Putting these two together + kco : k1 ~ k2 + tv:k1 |- g : t1 ~ t2 + g2 : (s1:k1) ~ (s2:k2) + -------------------- + InstCo (ForAllCo tv kco g) g2 : t1[tv |-> s1] ~ t2[tv |-> s2 |> sym kco] + +We thus want S(g) to have kind + + S(g) :: (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym kco]) + +All we need do is to substitute the coercion tv_co for tv: + S = [tv :-> tv_co] +where + tv_co : s1 ~ (s2 |> sym kco) +This looks bizarre, because we're substituting a /type variable/ with a +/coercion/. However, this operation already exists: it's called *lifting*, and +defined in GHC.Core.Coercion. We just need to enhance the lifting operation to +be able to deal with an ambient substitution, which is why a LiftingContext +stores a TCvSubst. + +In general if + S = [tv :-> tv_co] + tv_co : r1 ~ r2 + g : t1 ~ t2 +then + S(g) : t1[tv :-> r1] ~ t2[tv :-> r2] + +The substitution S is embodied in the LiftingContext argument of `opt_co4`; +See Note [The LiftingContext in optCoercion] + (2) cv is a coercion variable Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. @@ -119,6 +141,27 @@ So we substitute the coercion variable c for the coercion (h1 ~N (n1; h2; sym n2)) in g. + +Note [The LiftingContext in optCoercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To suppport Note [Optimising InstCo] the coercion optimiser carries a +GHC.Core.Coercion.LiftingContext, which comprises + * An ordinary Subst + * The `lc_env`: a mapping from /type variables/ to /coercions/ + +We don't actually have a separate function + liftCoSubstCo :: LiftingContext -> Coercion -> Coercion +The substitution of a type variable by a coercion is done by the calls to +`liftCoSubst` (on a type) in the Refl and GRefl cases of `opt_co4`. + +We use the following invariants: + (LC1) The coercions in the range of `lc_env` have already had all substitutions + applied; they are "OutCoercions". If you re-optimise these coercions, you + must zap the LiftingContext first. + + (LC2) However they have /not/ had the "ambient sym" (the second argument of + `opt_co4`) applied. The ambient sym applies to the entire coercion not + to the little bits being substituted. -} -- | Coercion optimisation options @@ -132,45 +175,52 @@ optCoercion opts env co | optCoercionEnabled opts = optCoercion' env co + {- - = pprTrace "optCoercion {" (text "Co:" <+> ppr co) $ + = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $ let result = optCoercion' env co in - pprTrace "optCoercion }" (vcat [ text "Co:" <+> ppr co - , text "Optco:" <+> ppr result ]) $ + pprTrace "optCoercion }" + (vcat [ text "Co:" <+> ppr (coercionSize co) + , text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)") + <+> ppr (coercionSize result) ]) $ result -} | otherwise = substCo env co - optCoercion' :: Subst -> Coercion -> NormalCo optCoercion' env co | debugIsOn - = let out_co = opt_co1 lc False co + = let out_co = opt_co1 lc NotSwapped co (Pair in_ty1 in_ty2, in_role) = coercionKindRole co (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + + details = vcat [ text "in_co:" <+> ppr co + , text "in_ty1:" <+> ppr in_ty1 + , text "in_ty2:" <+> ppr in_ty2 + , text "out_co:" <+> ppr out_co + , text "out_ty1:" <+> ppr out_ty1 + , text "out_ty2:" <+> ppr out_ty2 + , text "in_role:" <+> ppr in_role + , text "out_role:" <+> ppr out_role + ] in - assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 && - substTyUnchecked env in_ty2 `eqType` out_ty2 && - in_role == out_role) - (hang (text "optCoercion changed types!") - 2 (vcat [ text "in_co:" <+> ppr co - , text "in_ty1:" <+> ppr in_ty1 - , text "in_ty2:" <+> ppr in_ty2 - , text "out_co:" <+> ppr out_co - , text "out_ty1:" <+> ppr out_ty1 - , text "out_ty2:" <+> ppr out_ty2 - , text "in_role:" <+> ppr in_role - , text "out_role:" <+> ppr out_role - , vcat $ map ppr_one $ nonDetEltsUniqSet $ coVarsOfCo co - , text "subst:" <+> ppr env ])) - out_co + warnPprTrace (not (isReflCo out_co) && isReflexiveCo out_co) + "optCoercion: reflexive but not refl" details $ + -- The coercion optimiser should usually optimise + -- co:ty~ty --> Refl ty + -- But given a silly `newtype N = MkN N`, the axiom has type (N ~ N), + -- and so that can trigger this warning (e.g. test str002). + -- Maybe we should optimise that coercion to (Refl N), but it + -- just doesn't seem worth the bother + out_co - | otherwise = opt_co1 lc False co + | otherwise + = opt_co1 lc NotSwapped co where lc = mkSubstLiftingContext env - ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) +-- ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) type NormalCo = Coercion @@ -181,92 +231,110 @@ type NormalNonIdCo = NormalCo -- Extra invariant: not the identity --- | Do we apply a @sym@ to the result? -type SymFlag = Bool - -- | Do we force the result to be representational? type ReprFlag = Bool -- | Optimize a coercion, making no assumptions. All coercions in -- the lifting context are already optimized (and sym'd if nec'y) opt_co1 :: LiftingContext - -> SymFlag + -> SwapFlag -- IsSwapped => apply Sym to the result -> Coercion -> NormalCo opt_co1 env sym co = opt_co2 env sym (coercionRole co) co -- See Note [Optimising coercion optimisation] -- | Optimize a coercion, knowing the coercion's role. No other assumptions. opt_co2 :: LiftingContext - -> SymFlag - -> Role -- ^ The role of the input coercion + -> SwapFlag -- ^IsSwapped => apply Sym to the result + -> Role -- ^ The role of the input coercion -> Coercion -> NormalCo opt_co2 env sym Phantom co = opt_phantom env sym co -opt_co2 env sym r co = opt_co3 env sym Nothing r co +opt_co2 env sym r co = opt_co4 env sym False r co -- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +-- | Optimize a coercion, knowing the coercion's non-Phantom role, +-- and with an optional downgrade +opt_co3 :: LiftingContext -> SwapFlag -> Maybe Role -> Role -> Coercion -> NormalCo opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co -opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co +opt_co3 env sym (Just Representational) r co = opt_co4 env sym True r co -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore -opt_co3 env sym _ r co = opt_co4_wrap env sym False r co +opt_co3 env sym _ r co = opt_co4 env sym False r co -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag - -> Role -> Coercion -> NormalCo --- Precondition: In every call (opt_co4 lc sym rep role co) --- we should have role = coercionRole co -opt_co4_wrap = opt_co4 +opt_co4, opt_co4' :: LiftingContext -> SwapFlag -> ReprFlag + -> Role -> Coercion -> NormalCo +-- Precondition: In every call (opt_co4 lc sym rep role co) +-- we should have role = coercionRole co +-- Precondition: role is not Phantom +-- Postcondition: The resulting coercion is equivalant to +-- wrapsub (wrapsym (mksub co) +-- where wrapsym is SymCo if sym=True +-- wrapsub is SubCo if rep=True +-- opt_co4 is there just to support tracing, when debugging +-- Usually it just goes straight to opt_co4' +opt_co4 = opt_co4' + {- -opt_co4_wrap env sym rep r co - = pprTrace "opt_co4_wrap {" - ( vcat [ text "Sym:" <+> ppr sym - , text "Rep:" <+> ppr rep - , text "Role:" <+> ppr r - , text "Co:" <+> ppr co ]) $ - assert (r == coercionRole co ) $ - let result = opt_co4 env sym rep r co in - pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ - result --} +opt_co4 env sym rep r co + = pprTrace "opt_co4 {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + assert (r == coercionRole co ) $ + let result = opt_co4' env sym rep r co in + pprTrace "opt_co4 }" (ppr co $$ text "---" $$ ppr result) $ + assertPpr (res_role == coercionRole result) + (vcat [ text "Role:" <+> ppr r + , text "Result: " <+> ppr result + , text "Result type:" <+> ppr (coercionType result) ]) $ + result + where + res_role | rep = Representational + | otherwise = r +-} -opt_co4 env _ rep r (Refl ty) +opt_co4' env sym rep r (Refl ty) = assertPpr (r == Nominal) (text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr Nominal $$ text "Type:" <+> ppr ty) $ - liftCoSubst (chooseRole rep r) env ty + wrapSym sym $ liftCoSubst (chooseRole rep r) env ty + -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion] -opt_co4 env _ rep r (GRefl _r ty MRefl) +opt_co4' env sym rep r (GRefl _r ty MRefl) = assertPpr (r == _r) (text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr _r $$ text "Type:" <+> ppr ty) $ - liftCoSubst (chooseRole rep r) env ty + wrapSym sym $ liftCoSubst (chooseRole rep r) env ty + -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion] -opt_co4 env sym rep r (GRefl _r ty (MCo co)) +opt_co4' env sym rep r (GRefl _r ty (MCo kco)) = assertPpr (r == _r) (text "Expected role:" <+> ppr r $$ text "Found role:" <+> ppr _r $$ text "Type:" <+> ppr ty) $ - if isGReflCo co || isGReflCo co' - then liftCoSubst r' env ty - else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) + if isGReflCo kco || isGReflCo kco' + then wrapSym sym ty_co + else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co + -- ty :: k1 + -- kco :: k1 ~ k2 + -- Desired result coercion: ty ~ ty |> co where - r' = chooseRole rep r - ty' = substTy (lcSubstLeft env) ty - co' = opt_co4 env False False Nominal co + r' = chooseRole rep r + ty_co = liftCoSubst r' env ty + kco' = opt_co4 env NotSwapped False Nominal kco -opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co +opt_co4' env sym rep r (SymCo co) = opt_co4 env (flipSwap sym) rep r co -- surprisingly, we don't have to do anything to the env here. This is -- because any "lifting" substitutions in the env are tied to ForAllCos, -- which treat their left and right sides differently. We don't want to -- exchange them. -opt_co4 env sym rep r g@(TyConAppCo _r tc cos) +opt_co4' env sym rep r g@(TyConAppCo _r tc cos) = assert (r == _r) $ case (rep, r) of (True, Nominal) -> @@ -276,7 +344,7 @@ (repeat Nominal) cos) (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) + mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos) (_, Representational) -> -- must use opt_co2 here, because some roles may be P -- See Note [Optimising coercion optimisation] @@ -285,37 +353,41 @@ cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) -opt_co4 env sym rep r (AppCo co1 co2) - = mkAppCo (opt_co4_wrap env sym rep r co1) - (opt_co4_wrap env sym False Nominal co2) +opt_co4' env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4 env sym rep r co1) + (opt_co4 env sym False Nominal co2) -opt_co4 env sym rep r (ForAllCo tv k_co co) - = case optForAllCoBndr env sym tv k_co of - (env', tv', k_co') -> mkForAllCo tv' k_co' $ - opt_co4_wrap env' sym rep r co +opt_co4' env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = k_co, fco_body = co }) + = mkForAllCo tv' visL' visR' k_co' $ + opt_co4 env' sym rep r co -- Use the "mk" functions to check for nested Refls + where + !(env', tv', k_co') = optForAllCoBndr env sym tv k_co + !(visL', visR') = swapSym sym (visL, visR) -opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2) +opt_co4' env sym rep r (FunCo _r afl afr cow co1 co2) = assert (r == _r) $ mkFunCo2 r' afl' afr' cow' co1' co2' where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 cow' = opt_co1 env sym cow !r' | rep = Representational | otherwise = r - !(afl', afr') | sym = (afr,afl) - | otherwise = (afl,afr) + !(afl', afr') = swapSym sym (afl, afr) -opt_co4 env sym rep r (CoVarCo cv) - | Just co <- lookupCoVar (lcSubst env) cv - = opt_co4_wrap (zapLiftingContext env) sym rep r co +opt_co4' env sym rep r (CoVarCo cv) + | Just co <- lcLookupCoVar env cv -- see Note [Forall over coercion] for why + -- this is the right thing here + = -- pprTrace "CoVarCo" (ppr cv $$ ppr co) $ + opt_co4 (zapLiftingContext env) sym rep r co | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] = mkReflCo (chooseRole rep r) ty1 | otherwise - = assert (isCoVar cv1 ) + = assert (isCoVar cv1) $ wrapRole rep r $ wrapSym sym $ CoVarCo cv1 @@ -330,174 +402,161 @@ cv -- cv1 might have a substituted kind! -opt_co4 _ _ _ _ (HoleCo h) +opt_co4' _ _ _ _ (HoleCo h) = pprPanic "opt_univ fell into a hole" (ppr h) -opt_co4 env sym rep r (AxiomInstCo con ind cos) +opt_co4' env sym rep r (AxiomCo con cos) -- Do *not* push sym inside top-level axioms -- e.g. if g is a top-level axiom -- g a : f a ~ a -- then (sym (g ty)) /= g (sym ty) !! - = assert (r == coAxiomRole con ) - wrapRole rep (coAxiomRole con) $ + = assert (r == coAxiomRuleRole con ) + wrapRole rep (coAxiomRuleRole con) $ wrapSym sym $ -- some sub-cos might be P: use opt_co2 -- See Note [Optimising coercion optimisation] - AxiomInstCo con ind (zipWith (opt_co2 env False) - (coAxBranchRoles (coAxiomNthBranch con ind)) - cos) + AxiomCo con (zipWith (opt_co2 env NotSwapped) + (coAxiomRuleArgRoles con) + cos) -- Note that the_co does *not* have sym pushed into it -opt_co4 env sym rep r (UnivCo prov _r t1 t2) - = assert (r == _r ) - opt_univ env sym prov (chooseRole rep r) t1 t2 +opt_co4' env sym rep r (UnivCo { uco_prov = prov, uco_lty = t1 + , uco_rty = t2, uco_deps = deps }) + = opt_univ env sym prov deps (chooseRole rep r) t1 t2 -opt_co4 env sym rep r (TransCo co1 co2) - -- sym (g `o` h) = sym h `o` sym g - | sym = opt_trans in_scope co2' co1' - | otherwise = opt_trans in_scope co1' co2' +opt_co4' env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | isSwapped sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap env sym rep r co2 + co1' = opt_co4 env sym rep r co1 + co2' = opt_co4 env sym rep r co2 in_scope = lcInScopeSet env -opt_co4 env _sym rep r (SelCo n co) - | Just (ty, _co_role) <- isReflCo_maybe co - = liftCoSubst (chooseRole rep r) env (getNthFromType n ty) - -- NB: it is /not/ true that r = _co_role - -- Rather, r = coercionRole (SelCo n co) - -opt_co4 env sym rep r (SelCo (SelTyCon n r1) (TyConAppCo _ _ cos)) - = assert (r == r1 ) - opt_co4_wrap env sym rep r (cos `getNth` n) - --- see the definition of GHC.Builtin.Types.Prim.funTyCon -opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2)) - = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2) - -opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _)) - -- works for both tyvar and covar - = opt_co4_wrap env sym rep Nominal eta - -opt_co4 env sym rep r (SelCo n co) - | Just nth_co <- case (co', n) of - (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n) - (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2) - (ForAllCo _ eta _, SelForAll) -> Just eta - _ -> Nothing - = if rep && (r == Nominal) - -- keep propagating the SubCo - then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co - else nth_co +opt_co4' env sym rep r (SelCo cs co) + -- Historical note 1: we used to check `co` for Refl, TyConAppCo etc + -- before optimising `co`; but actually the SelCo will have been built + -- with mkSelCo, so these tests always fail. - | otherwise - = wrapRole rep r $ SelCo n co' - where - co' = opt_co1 env sym co + -- Historical note 2: if rep=True and r=Nominal, we used to recursively + -- call opt_co4 to re-optimse the result. But (a) that is inefficient + -- and (b) wrapRole uses mkSubCo which does much the same job + = wrapRole rep r $ mkSelCo cs $ opt_co1 env sym co -opt_co4 env sym rep r (LRCo lr co) +opt_co4' env sym rep r (LRCo lr co) | Just pr_co <- splitAppCo_maybe co = assert (r == Nominal ) - opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) + opt_co4 env sym rep Nominal (pick_lr lr pr_co) | Just pr_co <- splitAppCo_maybe co' = assert (r == Nominal) $ if rep - then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + then opt_co4 (zapLiftingContext env) NotSwapped True Nominal (pick_lr lr pr_co) else pick_lr lr pr_co | otherwise = wrapRole rep Nominal $ LRCo lr co' where - co' = opt_co4_wrap env sym False Nominal co + co' = opt_co4 env sym False Nominal co pick_lr CLeft (l, _) = l pick_lr CRight (_, r) = r +{- +Note [Forall over coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + type (:~:) :: forall k. k -> k -> Type + Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b + k1,k2,k3,k4 :: Type + eta :: (k1 ~# k2) ~# (k3 ~# k4) == ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4) + co1_3 :: k1 ~# k3 + co2_4 :: k2 ~# k4 + nth 2 eta :: k1 ~# k3 + nth 3 eta :: k2 ~# k4 + co11_31 :: ~# (sym co1_3) + co22_24 :: ~# co2_4 + (forall (cv :: eta). Refl co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) :: + (forall (cv :: k1 ~# k2). Refl Type k1 k2 ( ;; cv ;; ) ~# + (forall (cv :: k3 ~# k4). Refl Type k3 k4 + (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4)) + co1_2 :: k1 ~# k2 + co3_4 :: k3 ~# k4 + co5 :: co1_2 ~# co3_4 + InstCo (forall (cv :: eta). Refl co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 :: + (Refl Type k1 k2 ( ;; cv ;; ))[cv |-> co1_2] ~# + (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4] + == + (Refl Type k1 k2 ( ;; co1_2 ;; )) ~# + (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4)) + ==> + Refl co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24) +Conclusion: Because of the way this all works, we want to put in the *left-hand* +coercion in co5's type. (In the code, co5 is called `arg`.) +So we extend the environment binding cv to arg's left-hand type. +-} + -- See Note [Optimising InstCo] -opt_co4 env sym rep r (InstCo co1 arg) +opt_co4' env sym rep r (InstCo fun_co arg_co) -- forall over type... - | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 - = opt_co4_wrap (extendLiftingContext env tv - (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) - -- mkSymCo kind_co :: k1 ~ k2 - -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) - -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) - sym rep r co_body + | Just (tv, _visL, _visR, k_co, body_co) <- splitForAllCo_ty_maybe fun_co + -- tv :: k1 + -- k_co :: k1 ~ k2 + -- body_co :: t1 ~ t2 + -- arg_co :: (s1:k1) ~ (s2:k2) + , let arg_co' = opt_co4 env NotSwapped False Nominal arg_co + -- Do /not/ push Sym into the arg_co, hence sym=False + -- see (LC2) of Note [The LiftingContext in optCoercion] + k_co' = opt_co4 env NotSwapped False Nominal k_co + s2' = coercionRKind arg_co' + tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co' + -- mkSymCo kind_co :: k2 ~ k1 + -- tv_co :: (s1 :: k1) ~ (((s2 :: k2) |> (sym kind_co)) :: k1) + = opt_co4 (extendLiftingContext env tv tv_co) sym rep r body_co - -- forall over coercion... - | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 - , CoercionTy h1 <- t1 - , CoercionTy h2 <- t2 - = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 - in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + -- See Note [Forall over coercion] + | Just (cv, _visL, _visR, _kind_co, body_co) <- splitForAllCo_co_maybe fun_co + , CoercionTy h1 <- coercionLKind arg_co + , let h1' = opt_co4 env NotSwapped False Nominal h1 + = opt_co4 (extendLiftingContextCvSubst env cv h1') sym rep r body_co - -- See if it is a forall after optimization - -- If so, do an inefficient one-variable substitution, then re-optimize + -- OK so those cases didn't work. See if it is a forall /after/ optimization + -- If so, do an inefficient one-variable substitution, then re-optimize -- forall over type... - | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' - = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' - (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) - False False r' co_body' - - -- forall over coercion... - | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' - , CoercionTy h1' <- t1' - , CoercionTy h2' <- t2' - = let new_co = mk_new_co cv' kind_co' h1' h2' - in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) - False False r' co_body' + | Just (tv', _visL, _visR, k_co', body_co') <- splitForAllCo_ty_maybe fun_co' + , let s2' = coercionRKind arg_co' + tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co' + env' = extendLiftingContext (zapLiftingContext env) tv' tv_co + = opt_co4 env' NotSwapped False r' body_co' - | otherwise = InstCo co1' arg' - where - co1' = opt_co4_wrap env sym rep r co1 - r' = chooseRole rep r - arg' = opt_co4_wrap env sym False Nominal arg - sym_arg = wrapSym sym arg' + -- See Note [Forall over coercion] + | Just (cv', _visL, _visR, _kind_co', body_co') <- splitForAllCo_co_maybe fun_co' + , CoercionTy h1' <- coercionLKind arg_co' + , let env' = extendLiftingContextCvSubst (zapLiftingContext env) cv' h1' + = opt_co4 env' NotSwapped False r' body_co' - -- Performance note: don't be alarmed by the two calls to coercionKind - -- here, as only one call to coercionKind is actually demanded per guard. - -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used - -- when checking if co1' (i.e., co1 post-optimization) is a forall. - -- - -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' - -- might have an extra Sym at the front (after being optimized) that co1 - -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) - Pair t1 t2 = coercionKind sym_arg - Pair t1' t2' = coercionKind arg' + -- Those cases didn't work either, so rebuild the InstCo + -- Push Sym into /both/ function /and/ arg_coument + | otherwise = InstCo fun_co' arg_co' - mk_new_co cv kind_co h1 h2 - = let -- h1 :: (t1 ~ t2) - -- h2 :: (t3 ~ t4) - -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) - -- n1 :: t1 ~ t3 - -- n2 :: t2 ~ t4 - -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) - r2 = coVarRole cv - kind_co' = downgradeRole r2 Nominal kind_co - n1 = mkSelCo (SelTyCon 2 r2) kind_co' - n2 = mkSelCo (SelTyCon 3 r2) kind_co' - in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 - (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) + where + -- fun_co' arg_co' are both optimised, /and/ we have pushed `sym` into both + -- So no more sym'ing on th results of fun_co' arg_co' + fun_co' = opt_co4 env sym rep r fun_co + arg_co' = opt_co4 env sym False Nominal arg_co + r' = chooseRole rep r -opt_co4 env sym _rep r (KindCo co) +opt_co4' env sym _rep r (KindCo co) = assert (r == Nominal) $ let kco' = promoteCoercion co in case kco' of KindCo co' -> promoteCoercion (opt_co1 env sym co') - _ -> opt_co4_wrap env sym False Nominal kco' + _ -> opt_co4 env sym False Nominal kco' -- This might be able to be optimized more to do the promotion -- and substitution/optimization at the same time -opt_co4 env sym _ r (SubCo co) +opt_co4' env sym _ r (SubCo co) = assert (r == Representational) $ - opt_co4_wrap env sym True Nominal co - --- This could perhaps be optimized more. -opt_co4 env sym rep r (AxiomRuleCo co cs) - = assert (r == coaxrRole co) $ - wrapRole rep r $ - wrapSym sym $ - AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + opt_co4 env sym True Nominal co {- Note [Optimise CoVarCo to Refl] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -511,9 +570,13 @@ ------------- -- | Optimize a phantom coercion. The input coercion may not necessarily -- be a phantom, but the output sure will be. -opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo +opt_phantom :: LiftingContext -> SwapFlag -> Coercion -> NormalCo +opt_phantom env sym (UnivCo { uco_prov = prov, uco_lty = t1 + , uco_rty = t2, uco_deps = deps }) + = opt_univ env sym prov deps Phantom t1 t2 + opt_phantom env sym co - = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 + = opt_univ env sym PhantomProv [mkKindCo co] Phantom ty1 ty2 where Pair ty1 ty2 = coercionKind co @@ -525,8 +588,8 @@ Any :: forall k. k - Any * Int :: * - Any (*->*) Maybe Int :: * + Any @Type Int :: Type + Any @(Type->Type) Maybe Int :: Type Hence the need to compare argument lengths; see #13658 @@ -548,17 +611,25 @@ -} -opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role - -> Type -> Type -> Coercion -opt_univ env sym (PhantomProv h) _r ty1 ty2 - | sym = mkPhantomCo h' ty2' ty1' - | otherwise = mkPhantomCo h' ty1' ty2' +opt_univ :: LiftingContext -> SwapFlag -> UnivCoProvenance + -> [Coercion] + -> Role -> Type -> Type -> Coercion +opt_univ env sym prov deps role ty1 ty2 + = let ty1' = substTyUnchecked (lcSubstLeft env) ty1 + ty2' = substTyUnchecked (lcSubstRight env) ty2 + deps' = map (opt_co1 env sym) deps + (ty1'', ty2'') = swapSym sym (ty1', ty2') + in + mkUnivCo prov deps' role ty1'' ty2'' + +{- +opt_univ env PhantomProv cvs _r ty1 ty2 + = mkUnivCo PhantomProv cvs Phantom ty1' ty2' where - h' = opt_co4 env sym False Nominal h ty1' = substTy (lcSubstLeft env) ty1 ty2' = substTy (lcSubstRight env) ty2 -opt_univ env sym prov role oty1 oty2 +opt_univ1 env prov cvs' role oty1 oty2 | Just (tc1, tys1) <- splitTyConApp_maybe oty1 , Just (tc2, tys2) <- splitTyConApp_maybe oty2 , tc1 == tc2 @@ -567,33 +638,37 @@ -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps = let roles = tyConRoleListX role tc1 - arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 - arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos + arg_cos = zipWith3 (mkUnivCo prov cvs') roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env False False) roles arg_cos in mkTyConAppCo role tc1 arg_cos' -- can't optimize the AppTy case because we can't build the kind coercions. - | Just (tv1, ty1) <- splitForAllTyVar_maybe oty1 - , Just (tv2, ty2) <- splitForAllTyVar_maybe oty2 + | Just (Bndr tv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1 + , isTyVar tv1 + , Just (Bndr tv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2 + , isTyVar tv2 -- NB: prov isn't interesting here either = let k1 = tyVarKind tv1 k2 = tyVarKind tv2 - eta = mkUnivCo prov' Nominal k1 k2 + eta = mkUnivCo prov cvs' Nominal k1 k2 -- eta gets opt'ed soon, but not yet. ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 - (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + (env', tv1', eta') = optForAllCoBndr env False tv1 eta in - mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + mkForAllCo tv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2') - | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1 - , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2 + | Just (Bndr cv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1 + , isCoVar cv1 + , Just (Bndr cv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2 + , isCoVar cv2 -- NB: prov isn't interesting here either = let k1 = varType cv1 k2 = varType cv2 r' = coVarRole cv1 - eta = mkUnivCo prov' Nominal k1 k2 + eta = mkUnivCo prov cvs' Nominal k1 k2 eta_d = downgradeRole r' Nominal eta -- eta gets opt'ed soon, but not yet. n_co = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo` @@ -601,47 +676,62 @@ (mkSelCo (SelTyCon 3 r') eta_d) ty2' = substTyWithCoVars [cv2] [n_co] ty2 - (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + (env', cv1', eta') = optForAllCoBndr env False cv1 eta in - mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + mkForAllCo cv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2') | otherwise = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 ty2 = substTyUnchecked (lcSubstRight env) oty2 - (a, b) | sym = (ty2, ty1) - | otherwise = (ty1, ty2) in - mkUnivCo prov' role a b - - where - prov' = case prov of -#if __GLASGOW_HASKELL__ < 901 --- This alt is redundant with the first match of the FunDef - PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco -#endif - ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco - PluginProv _ -> prov - CorePrepProv _ -> prov + mkUnivCo prov cvs' role ty1 ty2 +-} ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList is = zipWithEqual "opt_transList" (opt_trans is) +opt_transList is = zipWithEqual (opt_trans is) -- The input lists must have identical length. -opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo + +-- opt_trans just allows us to add some debug tracing +-- Usually it just goes to opt_trans' opt_trans is co1 co2 + = -- (if coercionRKind co1 `eqType` coercionLKind co2 + -- then (\x -> x) else + -- pprTrace "opt_trans" (vcat [ text "co1" <+> ppr co1 + -- , text "co2" <+> ppr co2 + -- , text "co1 kind" <+> ppr (coercionKind co1) + -- , text "co2 kind" <+> ppr (coercionKind co2) + -- , callStackDoc ])) $ + opt_trans' is co1 co2 + +{- +opt_trans is co1 co2 + = assertPpr (r1==r2) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2]) $ + assertPpr (rres == r1) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2, text "res" <+> ppr rres <+> ppr res ]) $ + res + where + res = opt_trans' is co1 co2 + rres = coercionRole res + r1 = coercionRole co1 + r2 = coercionRole co1 +-} + +opt_trans' :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans' is co1 co2 | isReflCo co1 = co2 -- optimize when co1 is a Refl Co | otherwise = opt_trans1 is co1 co2 -opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +opt_trans1 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo -- First arg is not the identity opt_trans1 is co1 co2 | isReflCo co2 = co1 -- optimize when co2 is a Refl Co | otherwise = opt_trans2 is co1 co2 -opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +opt_trans2 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo -- Neither arg is the identity opt_trans2 is (TransCo co1a co1b) co2 -- Don't know whether the sub-coercions are the identity @@ -658,16 +748,27 @@ else opt_trans1 is co1_2a co2b opt_trans2 _ co1 co2 - = mkTransCo co1 co2 + = mk_trans_co co1 co2 + ------ -- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo +opt_trans_rule :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo -opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) +opt_trans_rule _ in_co1 in_co2 + | assertPpr (coercionRKind in_co1 `eqType` coercionLKind in_co2) + (vcat [ text "in_co1" <+> ppr in_co1 + , text "in_co2" <+> ppr in_co2 + , text "in_co1 kind" <+> ppr (coercionKind in_co1) + , text "in_co2 kind" <+> ppr (coercionKind in_co2) + , callStackDoc ]) $ + False + = panic "opt_trans_rule" -- This entire equation is purely assertion checking + +opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _t2 (MCo co2)) = assert (r1 == r2) $ fireTransRule "GRefl" in_co1 in_co2 $ - mkGReflRightCo r1 t1 (opt_trans is co1 co2) + mk_grefl_right_co r1 t1 (opt_trans is co1 co2) -- Push transitivity through matching destructors opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2) @@ -690,20 +791,13 @@ = fireTransRule "TrPushInst" in_co1 in_co2 $ mkInstCo (opt_trans is co1 co2) ty1 -opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) - in_co2@(UnivCo p2 r2 _tyl2 tyr2) - | Just prov' <- opt_trans_prov p1 p2 +opt_trans_rule _ + in_co1@(UnivCo { uco_prov = p1, uco_role = r1, uco_lty = tyl1, uco_deps = deps1 }) + in_co2@(UnivCo { uco_prov = p2, uco_role = r2, uco_rty = tyr2, uco_deps = deps2 }) + | p1 == p2 -- If the provenances are different, opt'ing will be very confusing = assert (r1 == r2) $ fireTransRule "UnivCo" in_co1 in_co2 $ - mkUnivCo prov' r1 tyl1 tyr2 - where - -- if the provenances are different, opt'ing will be very confusing - opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) - = Just $ PhantomProv $ opt_trans is kco1 kco2 - opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) - = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 - opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 - opt_trans_prov _ _ = Nothing + mkUnivCo p1 (deps1 ++ deps2) r1 tyl1 tyr2 -- Push transitivity down through matching top-level constructors. opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) @@ -747,23 +841,23 @@ -- Push transitivity inside forall -- forall over types. opt_trans_rule is co1 co2 - | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 - , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 - = push_trans tv1 eta1 r1 tv2 eta2 r2 + | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2 - | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 - , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 - = push_trans tv1 eta1 r1 tv2 eta2 r2 + | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2 where - push_trans tv1 eta1 r1 tv2 eta2 r2 + push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR -- Given: - -- co1 = /\ tv1 : eta1. r1 - -- co2 = /\ tv2 : eta2. r2 + -- co1 = /\ tv1 : eta1 . r1 + -- co2 = /\ tv2 : eta2 . r2 -- Wanted: - -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) + -- /\tv1 : (eta1;eta2) . (r1; r2[tv2 |-> tv1 |> eta1]) = fireTransRule "EtaAllTy_ty" co1 co2 $ - mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2') where is' = is `extendInScopeSet` tv1 r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 @@ -771,94 +865,93 @@ -- Push transitivity inside forall -- forall over coercions. opt_trans_rule is co1 co2 - | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 - , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 - = push_trans cv1 eta1 r1 cv2 eta2 r2 + | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2 - | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 - , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 - = push_trans cv1 eta1 r1 cv2 eta2 r2 + | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2 where - push_trans cv1 eta1 r1 cv2 eta2 r2 + push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR -- Given: - -- co1 = /\ cv1 : eta1. r1 - -- co2 = /\ cv2 : eta2. r2 + -- co1 = /\ (cv1 : eta1) . r1 + -- co2 = /\ (cv2 : eta2) . r2 -- Wanted: -- n1 = nth 2 eta1 -- n2 = nth 3 eta1 -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) = fireTransRule "EtaAllTy_co" co1 co2 $ - mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2') where is' = is `extendInScopeSet` cv1 role = coVarRole cv1 eta1' = downgradeRole role Nominal eta1 n1 = mkSelCo (SelTyCon 2 role) eta1' n2 = mkSelCo (SelTyCon 3 role) eta1' - r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` - (mkCoVarCo cv1) `mkTransCo` n2]) + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co` + (mkCoVarCo cv1) `mk_trans_co` n2]) r2 -- Push transitivity inside axioms opt_trans_rule is co1 co2 + -- TrPushAxSym/TrPushSymAx + -- Put this first! Otherwise (#23619) we get + -- newtype N a = MkN a + -- axN :: forall a. N a ~ a + -- Now consider (axN ty ; sym (axN ty)) + -- If we put TrPushSymAxR first, we'll get + -- (axN ty ; sym (axN ty)) :: N ty ~ N ty -- Obviously Refl + -- --> axN (sym (axN ty)) :: N ty ~ N ty -- Very stupid + | Just (sym1, axr1, cos1) <- isAxiomCo_maybe co1 + , Just (sym2, axr2, cos2) <- isAxiomCo_maybe co2 + , axr1 == axr2 + , sym1 == flipSwap sym2 + , Just (tc, role, branch) <- coAxiomRuleBranch_maybe axr1 + , let qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch + lhs = mkTyConApp tc (coAxBranchLHS branch) + rhs = coAxBranchRHS branch + pivot_tvs = exactTyCoVarsOfType (pickSwap sym2 lhs rhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if isSwapped sym2 + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + -- See Note [Push transitivity inside axioms] and -- Note [Push transitivity inside newtype axioms only] -- TrPushSymAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , isNewTyCon (coAxiomTyCon con) - , True <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + | Just (sym, axr, cos1) <- isAxiomCo_maybe co1 + , isSwapped sym + , Just cos2 <- matchNewtypeBranch sym axr co2 + , let newAxInst = AxiomCo axr (opt_transList is (map mkSymCo cos2) cos1) = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst -- TrPushAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , isNewTyCon (coAxiomTyCon con) - , False <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + | Just (sym, axr, cos1) <- isAxiomCo_maybe co1 + , notSwapped sym + , Just cos2 <- matchNewtypeBranch sym axr co2 + , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2) = fireTransRule "TrPushAxR" co1 co2 newAxInst -- TrPushSymAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , isNewTyCon (coAxiomTyCon con) - , True <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + | Just (sym, axr, cos2) <- isAxiomCo_maybe co2 + , isSwapped sym + , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1 + , let newAxInst = AxiomCo axr (opt_transList is cos2 (map mkSymCo cos1)) = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst -- TrPushAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , isNewTyCon (coAxiomTyCon con) - , False <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + | Just (sym, axr, cos2) <- isAxiomCo_maybe co2 + , notSwapped sym + , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1 + , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2) = fireTransRule "TrPushAxL" co1 co2 newAxInst - -- TrPushAxSym/TrPushSymAx - | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe - , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe - , con1 == con2 - , ind1 == ind2 - , sym1 == not sym2 - , let branch = coAxiomNthBranch con1 ind1 - qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch - lhs = coAxNthLHS con1 ind1 - rhs = coAxBranchRHS branch - pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) - , all (`elemVarSet` pivot_tvs) qtvs - = fireTransRule "TrPushAxSym" co1 co2 $ - if sym2 - -- TrPushAxSym - then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs - -- TrPushSymAx - else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs - where - co1_is_axiom_maybe = isAxiom_maybe co1 - co2_is_axiom_maybe = isAxiom_maybe co2 - role = coercionRole co1 -- should be the same as coercionRole co2! opt_trans_rule _ co1 co2 -- Identity rule | let ty1 = coercionLKind co1 @@ -905,7 +998,7 @@ co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs - co2bs'' = zipWith mkTransCo co2bs' co2bs + co2bs'' = zipWith mk_trans_co co2bs' co2bs in mkAppCos (opt_trans is co1a co2a') (zipWith (opt_trans is) co1bs co2bs'') @@ -1022,7 +1115,7 @@ :: Equal (Id Int) (Id Bool) ~ False which is bogus! This is because the type system isn't smart enough to know -that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type +that (Id Int) and (Id Bool) are SurelyApart, as they're headed by type families. At the time of writing, I (Richard Eisenberg) couldn't think of a way of detecting this any more efficient than just building the optimised coercion and checking. @@ -1087,10 +1180,14 @@ -} ----------- -wrapSym :: SymFlag -> Coercion -> Coercion -wrapSym sym co | sym = mkSymCo co - | otherwise = co +swapSym :: SwapFlag -> (a,a) -> (a,a) +swapSym IsSwapped (x,y) = (y,x) +swapSym NotSwapped (x,y) = (x,y) +wrapSym :: SwapFlag -> Coercion -> Coercion +wrapSym IsSwapped co = mkSymCo co +wrapSym NotSwapped co = co + -- | Conditionally set a role to be representational wrapRole :: ReprFlag -> Role -- ^ current role @@ -1107,24 +1204,26 @@ chooseRole _ r = r ----------- -isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) -isAxiom_maybe (SymCo co) - | Just (sym, con, ind, cos) <- isAxiom_maybe co - = Just (not sym, con, ind, cos) -isAxiom_maybe (AxiomInstCo con ind cos) - = Just (False, con, ind, cos) -isAxiom_maybe _ = Nothing +isAxiomCo_maybe :: Coercion -> Maybe (SwapFlag, CoAxiomRule, [Coercion]) +-- We don't expect to see nested SymCo; and that lets us write a simple, +-- non-recursive function. (If we see a nested SymCo we'll just fail, +-- which is ok.) +isAxiomCo_maybe (SymCo (AxiomCo ax cos)) = Just (IsSwapped, ax, cos) +isAxiomCo_maybe (AxiomCo ax cos) = Just (NotSwapped, ax, cos) +isAxiomCo_maybe _ = Nothing -matchAxiom :: Bool -- True = match LHS, False = match RHS - -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] -matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co - | CoAxBranch { cab_tvs = qtvs +matchNewtypeBranch :: SwapFlag -- IsSwapped = match LHS, NotSwapped = match RHS + -> CoAxiomRule + -> Coercion -> Maybe [Coercion] +matchNewtypeBranch sym axr co + | Just (tc,branch) <- isNewtypeAxiomRule_maybe axr + , CoAxBranch { cab_tvs = qtvs , cab_cvs = [] -- can't infer these, so fail if there are any , cab_roles = roles , cab_lhs = lhs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , cab_rhs = rhs } <- branch , Just subst <- liftCoMatch (mkVarSet qtvs) - (if sym then (mkTyConApp tc lhs) else rhs) + (pickSwap sym rhs (mkTyConApp tc lhs)) co , all (`isMappedByLC` subst) qtvs = zipWithM (liftCoSubstTyVar subst) roles qtvs @@ -1186,39 +1285,47 @@ eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4) h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) -} -etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) -- Try to make the coercion be of form (forall tv:kind_co. co) etaForAllCo_ty_maybe co - | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co - = Just (tv, kind_co, r) + | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, visL, visR, kind_co, r) - | Pair ty1 ty2 <- coercionKind co - , Just (tv1, _) <- splitForAllTyVar_maybe ty1 - , isForAllTy_ty ty2 + | (Pair ty1 ty2, role) <- coercionKindRole co + , Just (Bndr tv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1 + , isTyVar tv1 + , Just (Bndr tv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2 + , isTyVar tv2 + -- can't eta-expand at nominal role unless visibilities match + , (role /= Nominal) || (vis1 `eqForAllVis` vis2) , let kind_co = mkSelCo SelForAll co - = Just ( tv1, kind_co - , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) + = Just ( tv1, vis1, vis2, kind_co + , mkInstCo co (mk_grefl_right_co Nominal (TyVarTy tv1) kind_co)) | otherwise = Nothing -etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) -- Try to make the coercion be of form (forall cv:kind_co. co) etaForAllCo_co_maybe co - | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co - = Just (cv, kind_co, r) + | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, visL, visR, kind_co, r) - | Pair ty1 ty2 <- coercionKind co - , Just (cv1, _) <- splitForAllCoVar_maybe ty1 - , isForAllTy_co ty2 + | (Pair ty1 ty2, role) <- coercionKindRole co + , Just (Bndr cv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1 + , isCoVar cv1 + , Just (Bndr cv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2 + , isCoVar cv2 + -- can't eta-expand at nominal role unless visibilities match + , (role /= Nominal) = let kind_co = mkSelCo SelForAll co r = coVarRole cv1 l_co = mkCoVarCo cv1 kind_co' = downgradeRole r Nominal kind_co r_co = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co') - `mkTransCo` l_co - `mkTransCo` mkSelCo (SelTyCon 3 r) kind_co' - in Just ( cv1, kind_co + `mk_trans_co` l_co + `mk_trans_co` mkSelCo (SelTyCon 3 r) kind_co' + in Just ( cv1, vis1, vis2, kind_co , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) | otherwise @@ -1294,7 +1401,113 @@ -} -optForAllCoBndr :: LiftingContext -> Bool - -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) -optForAllCoBndr env sym - = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env +{- Note [Optimising ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If sym=NotSwapped, optimising ForAllCo is relatively easy: + opt env (ForAllCo tcv kco bodyco) + = ForAllCo tcv' (opt env kco) (opt env' bodyco) + where + (env', tcv') = substBndr env tcv + +Just apply the substitution to the kind of the binder, deal with +shadowing etc, and recurse. Remember in (ForAllCo tcv kco bodyco) + varKind tcv = coercionLKind kco + +But if sym=Swapped, things are trickier. Here is an identity that helps: + Sym (ForAllCo (tv:k1) (kco:k1~k2) bodyco) + = ForAllCo (tv:k2) (Sym kco : k2~k1) + (Sym (bodyco[tv:->tv:k2 |> Sym kco])) + +* We re-type tv:k1 to become tv:k2. +* We push Sym into kco +* We push Sym into bodyco +* BUT we must /also/ remember to replace all occurrences of + of tv:k1 in bodyco by (tv:k2 |> Sym kco) + This mirrors what happens in the typing rule for ForAllCo + See Note [ForAllCo] in GHC.Core.TyCo.Rep + +-} +optForAllCoBndr :: LiftingContext -> SwapFlag + -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +-- See Note [Optimising ForAllCo] +optForAllCoBndr env sym tcv kco + = (env', tcv', kco') + where + kco' = opt_co4 env sym False Nominal kco -- Push sym into kco + (env', tcv') = updateLCSubst env upd_subst + + upd_subst :: Subst -> (Subst, TyCoVar) + upd_subst subst + | isTyVar tcv = upd_subst_tv subst + | otherwise = upd_subst_cv subst + + upd_subst_tv subst + | notSwapped sym || isReflCo kco' = (subst1, tv1) + | otherwise = (subst2, tv2) + where + -- subst1,tv1: apply the substitution to the binder and its kind + -- NB: varKind tv = coercionLKind kco + (subst1, tv1) = substTyVarBndr subst tcv + -- In the Swapped case, we re-kind the type variable, AND + -- override the substitution for the original variable to the + -- re-kinded one, suitably casted + tv2 = tv1 `setTyVarKind` coercionLKind kco' + subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco')) + `extendSubstInScope` tv2 + + upd_subst_cv subst -- ToDo: probably not right yet + | notSwapped sym || isReflCo kco' = (subst1, cv1) + | otherwise = (subst2, cv2) + where + (subst1, cv1) = substCoVarBndr subst tcv + cv2 = cv1 `setTyVarKind` coercionLKind kco' + subst2 = subst1 `extendSubstInScope` cv2 + + +{- ********************************************************************** +%* * + Assertion-checking versions of functions in Coercion.hs +%* * +%********************************************************************* -} + +-- We can't check the assertions in the "main" functions of these +-- functions, because the assertions don't hold during zonking. +-- But they are fantastically helpful in finding bugs in the coercion +-- optimiser itself, so I have copied them here with assertions. + +mk_trans_co :: HasDebugCallStack => Coercion -> Coercion -> Coercion +-- Do assertion checking in mk_trans_co +mk_trans_co co1 co2 + = assertPpr (coercionRKind co1 `eqType` coercionLKind co2) + (vcat [ text "co1" <+> ppr co1 + , text "co2" <+> ppr co2 + , text "co1 kind" <+> ppr (coercionKind co1) + , text "co2 kind" <+> ppr (coercionKind co2) + , callStackDoc ]) $ + mkTransCo co1 co2 + +mk_coherence_right_co :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion +mk_coherence_right_co r ty co co2 + = assertGRefl ty co $ + mkCoherenceRightCo r ty co co2 + +assertGRefl :: HasDebugCallStack => Type -> Coercion -> r -> r +assertGRefl ty co res + = assertPpr (typeKind ty `eqType` coercionLKind co) + (vcat [ pp_ty "ty" ty + , pp_co "co" co + , callStackDoc ]) $ + res + +mk_grefl_right_co :: Role -> Type -> CoercionN -> Coercion +mk_grefl_right_co r ty co + = assertGRefl ty co $ + mkGReflRightCo r ty co + +pp_co :: String -> Coercion -> SDoc +pp_co s co = text s <+> hang (ppr co) 2 (dcolon <+> ppr (coercionKind co)) + +pp_ty :: String -> Type -> SDoc +pp_ty s ty = text s <+> hang (ppr ty) 2 (dcolon <+> ppr (typeKind ty)) + diff --git a/GHC/Core/ConLike.hs b/GHC/Core/ConLike.hs --- a/GHC/Core/ConLike.hs +++ b/GHC/Core/ConLike.hs @@ -12,6 +12,7 @@ , conLikeConLikeName , isVanillaConLike , conLikeArity + , conLikeVisArity , conLikeFieldLabels , conLikeConInfo , conLikeInstOrigArgTys @@ -23,7 +24,6 @@ , conLikeFullSig , conLikeResTy , conLikeFieldType - , conLikesWithFields , conLikeIsInfix , conLikeHasBuilder ) where @@ -34,6 +34,7 @@ import GHC.Core.Multiplicity import GHC.Core.PatSyn import GHC.Core.TyCo.Rep (Type, ThetaType) +import GHC.Core.TyCon (tyConDataCons) import GHC.Core.Type(mkTyConApp) import GHC.Types.Unique import GHC.Types.Name @@ -112,11 +113,16 @@ gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "ConLike" --- | Number of arguments +-- | Number of value arguments conLikeArity :: ConLike -> Arity conLikeArity (RealDataCon data_con) = dataConSourceArity data_con conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn +-- | Number of visible arguments +conLikeVisArity :: ConLike -> VisArity +conLikeVisArity (RealDataCon data_con) = dataConVisArity data_con +conLikeVisArity (PatSynCon pat_syn) = patSynVisArity pat_syn + -- | Names of fields used for selectors conLikeFieldLabels :: ConLike -> [FieldLabel] conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con @@ -125,8 +131,15 @@ -- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'. conLikeConInfo :: ConLike -> ConInfo conLikeConInfo con = - mkConInfo (conLikeArity con) (conLikeFieldLabels con) + mkConInfo (conLikeConLikeInfo con) (conLikeArity con) (conLikeFieldLabels con) +-- | Compute a 'ConLikeInfo' from a 'ConLike'. +conLikeConLikeInfo :: ConLike -> ConLikeInfo +conLikeConLikeInfo (RealDataCon con) + = ConIsData { conLikeDataCons = getName <$> tyConDataCons (dataConTyCon con) } +conLikeConLikeInfo (PatSynCon {}) + = ConIsPatSyn + -- | Returns just the instantiated /value/ argument types of a 'ConLike', -- (excluding dictionary args) conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type] @@ -140,10 +153,11 @@ -- followed by the existentially quantified type variables. For data -- constructors, the situation is slightly more complicated—see -- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon". -conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder] +conLikeUserTyVarBinders :: ConLike -> [TyVarBinder] conLikeUserTyVarBinders (RealDataCon data_con) = dataConUserTyVarBinders data_con conLikeUserTyVarBinders (PatSynCon pat_syn) = + tyVarSpecToBinders $ patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`. @@ -221,13 +235,6 @@ conLikeFieldType :: ConLike -> FieldLabelString -> Type conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label - - --- | The ConLikes that have *all* the given fields -conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] -conLikesWithFields con_likes lbls = filter has_flds con_likes - where has_flds dc = all (has_fld dc) lbls - has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) conLikeIsInfix :: ConLike -> Bool conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc diff --git a/GHC/Core/DataCon.hs b/GHC/Core/DataCon.hs --- a/GHC/Core/DataCon.hs +++ b/GHC/Core/DataCon.hs @@ -35,6 +35,7 @@ dataConNonlinearType, dataConDisplayType, dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConConcreteTyVars, dataConUserTyVars, dataConUserTyVarBinders, dataConTheta, dataConStupidTheta, @@ -44,22 +45,24 @@ dataConInstUnivs, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, dataConSrcBangs, - dataConSourceArity, dataConRepArity, + dataConSourceArity, dataConVisArity, dataConRepArity, dataConIsInfix, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitTyThings, - dataConRepStrictness, dataConImplBangs, dataConBoxer, + dataConRepStrictness, + dataConImplBangs, dataConBoxer, splitDataProductType_maybe, -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, + isLazyDataConRep, isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon, - isUnboxedSumDataCon, isCovertGadtDataCon, + isUnboxedSumDataCon, isCovertGadtDataCon, isUnaryClassDataCon, isVanillaDataCon, isNewDataCon, isTypeDataCon, classDataCon, dataConCannotMatch, - dataConUserTyVarsNeedWrapper, checkDataConTyVars, - isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, + dataConUserTyVarBindersNeedWrapper, checkDataConTyVars, + isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, -- ** Promotion related functions @@ -69,6 +72,7 @@ import GHC.Prelude import Language.Haskell.Syntax.Basic +import Language.Haskell.Syntax.Module.Name import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type @@ -76,7 +80,7 @@ import GHC.Core.Unify import GHC.Core.TyCon import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Compare( eqType, eqForAllVis ) import GHC.Core.Multiplicity import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel @@ -96,10 +100,11 @@ import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) import GHC.Data.Graph.UnVar -- UnVarSet and operations +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars ) + import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB @@ -107,8 +112,7 @@ import qualified Data.Data as Data import Data.Char import Data.List( find ) - -import Language.Haskell.Syntax.Module.Name +import Control.DeepSeq {- Note [Data constructor representation] @@ -378,11 +382,6 @@ -} -- | A data constructor --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', --- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma' - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data DataCon = MkData { dcName :: Name, -- This is the name of the *source data con* @@ -450,13 +449,21 @@ -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames -- Reason: less confusing, and easier to generate Iface syntax + -- The type variables of this data constructor that must be + -- instantiated to concrete types. For example: the RuntimeRep + -- variables of unboxed tuples and unboxed sums. + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + dcConcreteTyVars :: ConcreteTyVars, + -- The type/coercion vars in the order the user wrote them [c,y,x,b] -- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders is -- exactly the set of tyvars (*not* covars) of dcExTyCoVars unioned -- with the set of dcUnivTyVars whose tyvars do not appear in dcEqSpec -- So dcUserTyVarBinders is a subset of (dcUnivTyVars ++ dcExTyCoVars) -- See Note [DataCon user type variable binders] - dcUserTyVarBinders :: [InvisTVBinder], + dcUserTyVarBinders :: [TyVarBinder], dcEqSpec :: [EqSpec], -- Equalities derived from the result type, -- _as written by the programmer_. @@ -515,6 +522,18 @@ -- Matches 1-1 with dcOrigArgTys -- Hence length = dataConSourceArity dataCon + dcImplBangs :: [HsImplBang], + -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + dcStricts :: [StrictnessMark], + -- One mark for every field of the DataCon worker; + -- if it's empty, then all fields are lazy, + -- otherwise 1-1 with dataConRepArgTys. + -- See also Note [Strict fields in Core] in GHC.Core + -- for the effect on the strictness signature + dcFields :: [FieldLabel], -- Field labels for this constructor, in the -- same order as the dcOrigArgTys; @@ -561,24 +580,8 @@ } -{- Note [TyVarBinders in DataCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For the TyVarBinders in a DataCon and PatSyn: - - * Each argument flag is Inferred or Specified. - None are Required. (A DataCon is a term-level function; see - Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep.) - -Why do we need the TyVarBinders, rather than just the TyVars? So that -we can construct the right type for the DataCon with its foralls -attributed the correct visibility. That in turn governs whether you -can use visible type application at a call of the data constructor. - -See also [DataCon user type variable binders] for an extended discussion on the -order in which TyVarBinders appear in a DataCon. - -Note [Existential coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For now (Aug 2018) we can't write coercion quantifications in source Haskell, but we can in Core. Consider having: @@ -639,25 +642,42 @@ A DataCon has two different sets of type variables: * dcUserTyVarBinders, for the type variables binders in the order in which they - originally arose in the user-written type signature. + originally arose in the user-written type signature, and with user-specified + visibilities. - They are the forall'd binders of the data con /wrapper/, which the user calls. - - Their order *does* matter for TypeApplications, so they are full TyVarBinders, - complete with visibilities. + - With RequiredTypeArguments, some of the foralls may be visible, e.g. + MkT :: forall a b. forall c -> (a, b, c) -> T a b c + so the binders are full TyVarBinders, complete with visibilities. + - Even if we only consider invisible foralls, the order and specificity of + binders matter for TypeApplications. + * dcUnivTyVars and dcExTyCoVars, for the "true underlying" (i.e. of the data con worker) universal type variable and existential type/coercion variables, respectively. - They (i.e. univ ++ ex) are the forall'd variables of the data con /worker/ - - Their order is irrelevant for the purposes of TypeApplications, - and as a consequence, they do not come equipped with visibilities - (that is, they are TyVars/TyCoVars instead of ForAllTyBinders). + - They do not come equipped with visibilities: + dcUnivTyVars :: [TyVar] -- not [TyVarBinder] + dcExTyCoVars :: [TyCoVar] -- not [ForAllTyBinder] + Instead, we treat them as having the Specified (coreTyLamForAllTyFlag) + visibility. For example: + wrapper type: forall {a} b. forall c -> ... + worker type: forall a b c. ... + This is a design choice. Reasons: + * Workers are never called by the user. They are part of the Core + language where visibilities don't matter as much. + * Consistency with type lambdas in Core. As Note [Required foralls in Core] + in GHC.Core.TyCo.Rep explains, (/\a. e) :: (forall a. e_ty), and we need + a coercion to cast it to (forall a -> e_ty). + As a consequence, we may need to adjust visibilities with a cast in the + wrapper. See Note [Flag cast in data con wrappers]. -Often (dcUnivTyVars ++ dcExTyCoVars) = dcUserTyVarBinders; but they may differ -for two reasons, coming next: +Often (dcUnivTyVars ++ dcExTyCoVars) = binderVars dcUserTyVarBinders; but they +may differ for two reasons, coming next: --- Reason (R1): Order of quantification in GADT syntax --- @@ -819,13 +839,6 @@ -- after unboxing and flattening, -- and *including* all evidence args - , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys - -- See also Note [Data-con worker strictness] - - , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) - -- about the original arguments; 1-1 with orig_arg_tys - -- See Note [Bangs on data constructor arguments] - } type DataConEnv a = UniqFM DataCon a -- Keyed by DataCon @@ -834,17 +847,18 @@ -- | Haskell Source Bang -- --- Bangs on data constructor arguments as the user wrote them in the --- source code. +-- Bangs on data constructor arguments as written by the user, including the +-- source code for exact-printing. -- -- @(HsSrcBang _ SrcUnpack SrcLazy)@ and -- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ -data HsSrcBang = - HsSrcBang SourceText -- Note [Pragma source text] in "GHC.Types.SourceText" - SrcUnpackedness - SrcStrictness +-- +-- In the AST, the @SourceText@ is hidden inside the extension point +-- 'Language.Haskell.Syntax.Extension.XConDeclField'. +data HsSrcBang + = HsSrcBang SourceText SrcUnpackedness SrcStrictness -- See Note [Pragma source text] in "GHC.Types.SourceText" deriving Data.Data -- | Haskell Implementation Bang @@ -888,49 +902,14 @@ eqSpecPair (EqSpec tv ty) = (tv, ty) eqSpecPreds :: [EqSpec] -> ThetaType -eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty +eqSpecPreds spec = [ mkNomEqPred (mkTyVarTy tv) ty | EqSpec tv ty <- spec ] instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) -{- Note [Data-con worker strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Notice that we do *not* say the worker Id is strict even if the data -constructor is declared strict - e.g. data T = MkT ![Int] Bool -Even though most often the evals are done by the *wrapper* $WMkT, there are -situations in which tag inference will re-insert evals around the worker. -So for all intents and purposes the *worker* MkT is strict, too! - -Unfortunately, if we exposed accurate strictness of DataCon workers, we'd -see the following transformation: - - f xs = case xs of xs' { __DEFAULT -> ... case MkT xs b of x { __DEFAULT -> [x] } } -- DmdAnal: Strict in xs - ==> { drop-seq, binder swap on xs' } - f xs = case MkT xs b of x { __DEFAULT -> [x] } -- DmdAnal: Still strict in xs - ==> { case-to-let } - f xs = let x = MkT xs' b in [x] -- DmdAnal: No longer strict in xs! - -I.e., we are ironically losing strictness in `xs` by dropping the eval on `xs` -and then doing case-to-let. The issue is that `exprIsHNF` currently says that -every DataCon worker app is a value. The implicit assumption is that surrounding -evals will have evaluated strict fields like `xs` before! But now that we had -just dropped the eval on `xs`, that assumption is no longer valid. - -Long story short: By keeping the demand signature lazy, the Simplifier will not -drop the eval on `xs` and using `exprIsHNF` to decide case-to-let and others -remains sound. - -Similarly, during demand analysis in dmdTransformDataConSig, we bump up the -field demand with `C_01`, *not* `C_11`, because the latter exposes too much -strictness that will drop the eval on `xs` above. - -This issue is discussed at length in -"Failed idea: no wrappers for strict data constructors" in #21497 and #22475. - -Note [Bangs on data constructor arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT !Int {-# UNPACK #-} !Int Bool @@ -956,8 +935,8 @@ the flag settings in the importing module. Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make -* The dcr_bangs field of the dcRep field records the [HsImplBang] - If T was defined in this module, Without -O the dcr_bangs might be +* The dcImplBangs field records the [HsImplBang] + If T was defined in this module, Without -O the dcImplBangs might be [HsStrict _, HsStrict _, HsLazy] With -O it might be [HsStrict _, HsUnpack _, HsLazy] @@ -966,6 +945,20 @@ With -XStrictData it might be [HsStrict _, HsUnpack _, HsStrict _] +* Core passes will often need to know whether the DataCon worker or wrapper in + an application is strict in some (lifted) field or not. This is tracked in the + demand signature attached to a DataCon's worker resp. wrapper Id. + + So if you've got a DataCon dc, you can get the demand signature by + `idDmdSig (dataConWorkId dc)` and make out strict args by testing with + `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives + you the demand signature of the wrapper, if it exists. + + These demand signatures are set in GHC.Types.Id.Make.mkDataConWorkId, + computed from the single source of truth `dataConRepStrictness`, which is + generated from `dcStricts`. + Note that `dataConRepStrictness` lines up 1-1 with `idDmdSig (dataConWorkId dc)`. + Note [Detecting useless UNPACK pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to issue a warning when there's an UNPACK pragma in the source code, @@ -1001,7 +994,6 @@ The boolean flag is used only for this warning. See #11270 for motivation. - ************************************************************************ * * \subsection{Instances} @@ -1089,6 +1081,16 @@ 1 -> return SrcUnpack _ -> return NoSrcUnpack +instance NFData SrcStrictness where + rnf SrcLazy = () + rnf SrcStrict = () + rnf NoSrcStrict = () + +instance NFData SrcUnpackedness where + rnf SrcNoUnpack = () + rnf SrcUnpack = () + rnf NoSrcUnpack = () + -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True @@ -1103,6 +1105,11 @@ isBanged (HsStrict {}) = True isBanged HsLazy = False +isUnpacked :: HsImplBang -> Bool +isUnpacked (HsUnpack {}) = True +isUnpacked (HsStrict {}) = False +isUnpacked HsLazy = False + isSrcStrict :: SrcStrictness -> Bool isSrcStrict SrcStrict = True isSrcStrict _ = False @@ -1128,16 +1135,19 @@ -- | Build a new data constructor mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyCoVar] -- ^ Existentials. - -> [InvisTVBinder] -- ^ User-written 'TyVarBinder's. - -- These must be Inferred/Specified. - -- See @Note [TyVarBinders in DataCons]@ + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [HsImplBang] -- ^ Strictness/unpack annotations, as inferred by the compiler + -> [StrictnessMark] -- ^ Strictness marks for the DataCon worker's fields in Core + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> ConcreteTyVars + -- ^ TyVars which must be instantiated with + -- concrete types + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's -> [EqSpec] -- ^ GADT equalities -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper -> [KnotTied (Scaled Type)] -- ^ Original argument types @@ -1153,9 +1163,11 @@ -- Can get the tag from the TyCon mkDataCon name declared_infix prom_info - arg_stricts -- Must match orig_arg_tys 1-1 + arg_stricts -- Must match orig_arg_tys 1-1 + impl_bangs -- Must match orig_arg_tys 1-1 + str_marks -- Must be empty or match dataConRepArgTys 1-1 fields - univ_tvs ex_tvs user_tvbs + univ_tvs ex_tvs conc_tvs user_tvbs eq_spec theta orig_arg_tys orig_res_ty rep_info rep_tycon tag stupid_theta work_id rep @@ -1170,18 +1182,22 @@ = con where is_vanilla = null ex_tvs && null eq_spec && null theta + str_marks' | not $ any isMarkedStrict str_marks = [] + | otherwise = str_marks con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, + dcConcreteTyVars = conc_tvs, dcUserTyVarBinders = user_tvbs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcStupidTheta = stupid_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, - dcSrcBangs = arg_stricts, + dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs, + dcStricts = str_marks', dcFields = fields, dcTag = tag, dcRepType = rep_ty, dcWorkId = work_id, dcRep = rep, @@ -1210,8 +1226,8 @@ -- Hence using mkScaledFunctionTys. -- See Note [Promoted data constructors] in GHC.Core.TyCon - prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv - | Bndr tv spec <- user_tvbs ] + prom_tv_bndrs = [ mkNamedTyConBinder vis tv + | Bndr tv vis <- user_tvbs ] fresh_names = freshNames (map getName user_tvbs) -- fresh_names: make sure that the "anonymous" tyvars don't @@ -1237,12 +1253,12 @@ , let uniq = mkAlphaTyVarUnique n occ = mkTyVarOccFS (mkFastString ('x' : show n)) - , not (uniq `elementOfUniqSet` avoid_uniqs) + , not (uniq `memberUniqueSet` avoid_uniqs) , not (occ `elemOccSet` avoid_occs) ] where - avoid_uniqs :: UniqSet Unique - avoid_uniqs = mkUniqSet (map getUnique avoids) + avoid_uniqs :: UniqueSet + avoid_uniqs = fromListUniqueSet (map getUnique avoids) avoid_occs :: OccSet avoid_occs = mkOccSet (map getOccName avoids) @@ -1293,15 +1309,24 @@ dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) = univ_tvs ++ ex_tvs +-- | Which type variables of this data constructor that must be +-- instantiated to concrete types? +-- For example: the RuntimeRep variables of unboxed tuples and unboxed sums. +-- +-- See Note [Representation-polymorphism checking built-ins] +-- in GHC.Tc.Utils.Concrete +dataConConcreteTyVars :: DataCon -> ConcreteTyVars +dataConConcreteTyVars (MkData { dcConcreteTyVars = concs }) = concs + -- See Note [DataCon user type variable binders] -- | The type variables of the constructor, in the order the user wrote them dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs -- See Note [DataCon user type variable binders] --- | 'InvisTVBinder's for the type variables of the constructor, in the order the +-- | 'TyVarBinder's for the type variables of the constructor, in the order the -- user wrote them -dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConUserTyVarBinders = dcUserTyVarBinders -- | Dependent (kind-level) equalities in a constructor. @@ -1318,7 +1343,7 @@ = [ EqSpec tv ty | cv <- ex_tcvs , isCoVar cv - , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + , let (ty1, ty, _) = coVarTypesRole cv tv = getTyVar ty1 ] @@ -1388,10 +1413,18 @@ dataConSrcBangs :: DataCon -> [HsSrcBang] dataConSrcBangs = dcSrcBangs --- | Source-level arity of the data constructor +-- | Number of value arguments of the data constructor dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity +-- | Number of visible arguments of the data constructor +dataConVisArity :: DataCon -> VisArity +dataConVisArity (MkData { dcUserTyVarBinders = tvbs, dcSourceArity = arity }) + = n_of_required_ty_args + n_of_val_args + where + n_of_val_args = arity + n_of_required_ty_args = count isVisibleForAllTyBinder tvbs + -- | Gives the number of value arguments (including zero-width coercions) -- stored by the given `DataCon`'s worker in its Core representation. This may -- differ from the number of arguments that appear in the source code; see also @@ -1415,20 +1448,25 @@ isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 +isLazyDataConRep :: DataCon -> Bool +-- ^ True <==> All fields are lazy +isLazyDataConRep dc = null (dcStricts dc) + dataConRepStrictness :: DataCon -> [StrictnessMark] --- ^ Give the demands on the arguments of a --- Core constructor application (Con dc args) -dataConRepStrictness dc = case dcRep dc of - NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] - DCR { dcr_stricts = strs } -> strs +-- ^ Give the demands on the runtime arguments of a Core DataCon worker +-- application. +-- The length of the list matches `dataConRepArgTys` (e.g., the number +-- of runtime arguments). +dataConRepStrictness dc + | isLazyDataConRep dc + = replicate (dataConRepArity dc) NotMarkedStrict + | otherwise + = dcStricts dc dataConImplBangs :: DataCon -> [HsImplBang] -- The implementation decisions about the strictness/unpack of each -- source program argument to the data constructor -dataConImplBangs dc - = case dcRep dc of - NoDataConRep -> replicate (dcSourceArity dc) HsLazy - DCR { dcr_bangs = bangs } -> bangs +dataConImplBangs dc = dcImplBangs dc dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer @@ -1545,7 +1583,7 @@ dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty, dcStupidTheta = stupid_theta }) - = mkInvisForAllTys user_tvbs $ + = mkForAllTys user_tvbs $ mkInvisFunTys (stupid_theta ++ theta) $ mkScaledFunTys arg_tys $ res_ty @@ -1557,7 +1595,7 @@ dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty, dcStupidTheta = stupid_theta }) - = mkInvisForAllTys user_tvbs $ + = mkForAllTys user_tvbs $ mkInvisFunTys (stupid_theta ++ theta) $ mkScaledFunTys arg_tys' $ res_ty @@ -1754,10 +1792,15 @@ && not (isTyVarTy ty) -- See Note [isCovertGadtDataCon] for -- an example where 'ty' is a tyvar +isUnaryClassDataCon :: DataCon -> Bool +isUnaryClassDataCon dc = isUnaryClassTyCon (dataConTyCon dc) + {- Note [isCovertGadtDataCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (isCovertGadtDataCon K) returns True if K is a GADT data constructor, but -does not /look/ like it. Consider (#21447) +does not /look/ like it. It is used only to help in error message printing. + +Consider (#21447) type T :: TYPE r -> Type data T a where { MkT :: b -> T b } Here MkT doesn't look GADT-like, but it is. If we make the kind applications @@ -1875,21 +1918,53 @@ wrapper_vars = dataConUserTyVars dc -dataConUserTyVarsNeedWrapper :: DataCon -> Bool --- Check whether the worker and wapper have the same type variables --- in the same order. If not, we need a wrapper to swizzle them. +dataConUserTyVarBindersNeedWrapper :: DataCon -> Bool +-- Check whether the worker and wrapper have the same type variables +-- in the same order and with the same visibility. If not, we need a +-- wrapper to swizzle them. -- See Note [DataCon user type variable binders], as well as -- Note [Data con wrappers and GADT syntax] for an explanation of what -- mkDataConRep is doing with this function. -dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs - , dcExTyCoVars = ex_tvs - , dcEqSpec = eq_spec }) +dataConUserTyVarBindersNeedWrapper (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , dcUserTyVarBinders = user_tvbs + , dcEqSpec = eq_spec }) = assert (null eq_spec || answer) -- all GADTs should say "yes" here answer where - answer = (univ_tvs ++ ex_tvs) /= dataConUserTyVars dc - -- Worker tyvars Wrapper tyvars + answer = need_reorder || need_flag_cast + need_reorder = (univ_tvs ++ ex_tvs) /= binderVars user_tvbs + need_flag_cast = any (not . eqForAllVis coreTyLamForAllTyFlag) + (binderFlags user_tvbs) + -- See Note [Flag cast in data con wrappers] +{- Note [Flag cast in data con wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the data declaration + + data G a where + MkG :: forall a -> a -> G a + +The user-facing type of MkG has a 'Required' forall. Workers, on the other hand, +always use 'Specified' foralls (coreTyLamForAllTyFlag). So we need a wrapper: + + wrapper type: forall a -> a -> G a + worker type: forall a. a -> G a + +Concretely, it looks like this: + + $WMkG = /\a. \(x:a). MkG a x |> co + +where 'co' is a coercion constructed by GHC.Core.Coercion.mkForAllVisCos. +The cast is added by the call to mkCoreTyLams in GHC.Types.Id.Make.mkDataConRep. + +In general, wrappers may use 'Inferred', 'Specified', or 'Required' foralls. +However, we do /not/ need a cast to convert 'Inferred' to 'Specified' because they are +'eqType'-equal. Only a 'Required' forall necessitates a cast in the wrapper. + +See Note [ForAllTy and type equality], Note [Comparing visibility], +and Note [Required foralls in Core]. +-} {- %************************************************************************ diff --git a/GHC/Core/DataCon.hs-boot b/GHC/Core/DataCon.hs-boot --- a/GHC/Core/DataCon.hs-boot +++ b/GHC/Core/DataCon.hs-boot @@ -1,7 +1,7 @@ module GHC.Core.DataCon where import GHC.Prelude -import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, InvisTVBinder ) +import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, TyVarBinder ) import {-# SOURCE #-} GHC.Types.Name( Name, NamedThing ) import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) import GHC.Types.FieldLabel ( FieldLabel ) @@ -19,7 +19,7 @@ dataConTyCon :: DataCon -> TyCon dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar] -dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Scaled Type] diff --git a/GHC/Core/FVs.hs b/GHC/Core/FVs.hs --- a/GHC/Core/FVs.hs +++ b/GHC/Core/FVs.hs @@ -36,12 +36,11 @@ ruleLhsFreeIds, ruleLhsFreeIdsList, ruleRhsFreeVars, rulesRhsFreeIds, - exprFVs, + exprFVs, exprLocalFVs, addBndrFV, addBndrsFV, -- * Orphan names - orphNamesOfType, orphNamesOfTypes, - orphNamesOfCo, orphNamesOfCoCon, orphNamesOfAxiomLHS, - exprsOrphNames, + orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS, + orphNamesOfExprs, -- * Core syntax tree annotation with free variables FVAnn, -- annotation, abstract @@ -97,23 +96,23 @@ -- | Find all locally-defined free Ids or type variables in an expression -- returning a non-deterministic set. exprFreeVars :: CoreExpr -> VarSet -exprFreeVars = fvVarSet . exprFVs +exprFreeVars = fvVarSet . exprLocalFVs -- | Find all locally-defined free Ids or type variables in an expression -- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" -- for why export it. -exprFVs :: CoreExpr -> FV -exprFVs = filterFV isLocalVar . expr_fvs +exprLocalFVs :: CoreExpr -> FV +exprLocalFVs = filterFV isLocalVar . exprFVs -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministic set. exprFreeVarsDSet :: CoreExpr -> DVarSet -exprFreeVarsDSet = fvDVarSet . exprFVs +exprFreeVarsDSet = fvDVarSet . exprLocalFVs -- | Find all locally-defined free Ids or type variables in an expression -- returning a deterministically ordered list. exprFreeVarsList :: CoreExpr -> [Var] -exprFreeVarsList = fvVarList . exprFVs +exprFreeVarsList = fvVarList . exprLocalFVs -- | Find all locally-defined free Ids in an expression exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids @@ -145,68 +144,65 @@ -- | Find all locally-defined free Ids or type variables in several expressions -- returning a non-deterministic set. exprsFreeVars :: [CoreExpr] -> VarSet -exprsFreeVars = fvVarSet . exprsFVs +exprsFreeVars = fvVarSet . exprsLocalFVs -- | Find all locally-defined free Ids or type variables in several expressions -- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV" -- for why export it. -exprsFVs :: [CoreExpr] -> FV -exprsFVs exprs = mapUnionFV exprFVs exprs +exprsLocalFVs :: [CoreExpr] -> FV +exprsLocalFVs exprs = mapUnionFV exprLocalFVs exprs -- | Find all locally-defined free Ids or type variables in several expressions -- returning a deterministically ordered list. exprsFreeVarsList :: [CoreExpr] -> [Var] -exprsFreeVarsList = fvVarList . exprsFVs +exprsFreeVarsList = fvVarList . exprsLocalFVs -- | Find all locally defined free Ids in a binding group bindFreeVars :: CoreBind -> VarSet bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ - addBndrs (map fst prs) + addBndrsFV (map fst prs) (mapUnionFV rhs_fvs prs) -- | Finds free variables in an expression selected by a predicate exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> VarSet -exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e +exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ exprFVs e -- | Finds free variables in an expression selected by a predicate -- returning a deterministically ordered list. exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> [Var] -exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e +exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ exprFVs e -- | Finds free variables in an expression selected by a predicate -- returning a deterministic set. exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting -> CoreExpr -> DVarSet -exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e +exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ exprFVs e -- | Finds free variables in several expressions selected by a predicate exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting -> [CoreExpr] -> VarSet -exprsSomeFreeVars fv_cand es = - fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es +exprsSomeFreeVars fv_cand es = fvVarSet $ filterFV fv_cand $ mapUnionFV exprFVs es -- | Finds free variables in several expressions selected by a predicate -- returning a deterministically ordered list. exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting -> [CoreExpr] -> [Var] -exprsSomeFreeVarsList fv_cand es = - fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es +exprsSomeFreeVarsList fv_cand es = fvVarList $ filterFV fv_cand $ mapUnionFV exprFVs es -- | Finds free variables in several expressions selected by a predicate -- returning a deterministic set. exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting -> [CoreExpr] -> DVarSet -exprsSomeFreeVarsDSet fv_cand e = - fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e +exprsSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ mapUnionFV exprFVs e -- Comment about obsolete code -- We used to gather the free variables the RULES at a variable occurrence @@ -236,108 +232,90 @@ -- | otherwise = set -- SLPJ Feb06 -addBndr :: CoreBndr -> FV -> FV -addBndr bndr fv fv_cand in_scope acc +addBndrFV :: CoreBndr -> FV -> FV +addBndrFV bndr fv fv_cand in_scope acc = (varTypeTyCoFVs bndr `unionFV` -- Include type variables in the binder's type -- (not just Ids; coercion variables too!) FV.delFV bndr fv) fv_cand in_scope acc -addBndrs :: [CoreBndr] -> FV -> FV -addBndrs bndrs fv = foldr addBndr fv bndrs +addBndrsFV :: [CoreBndr] -> FV -> FV +addBndrsFV bndrs fv = foldr addBndrFV fv bndrs -expr_fvs :: CoreExpr -> FV -expr_fvs (Type ty) fv_cand in_scope acc = +exprsFVs :: [CoreExpr] -> FV +exprsFVs exprs = mapUnionFV exprFVs exprs + +exprFVs :: CoreExpr -> FV +exprFVs (Type ty) fv_cand in_scope acc = tyCoFVsOfType ty fv_cand in_scope acc -expr_fvs (Coercion co) fv_cand in_scope acc = +exprFVs (Coercion co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc -expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -expr_fvs (Tick t expr) fv_cand in_scope acc = - (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc -expr_fvs (App fun arg) fv_cand in_scope acc = - (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc -expr_fvs (Lam bndr body) fv_cand in_scope acc = - addBndr bndr (expr_fvs body) fv_cand in_scope acc -expr_fvs (Cast expr co) fv_cand in_scope acc = - (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc +exprFVs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc +exprFVs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +exprFVs (Tick t expr) fv_cand in_scope acc = + (tickish_fvs t `unionFV` exprFVs expr) fv_cand in_scope acc +exprFVs (App fun arg) fv_cand in_scope acc = + (exprFVs fun `unionFV` exprFVs arg) fv_cand in_scope acc +exprFVs (Lam bndr body) fv_cand in_scope acc = + addBndrFV bndr (exprFVs body) fv_cand in_scope acc +exprFVs (Cast expr co) fv_cand in_scope acc = + (exprFVs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc -expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc - = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr +exprFVs (Case scrut bndr ty alts) fv_cand in_scope acc + = (exprFVs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndrFV bndr (mapUnionFV alt_fvs alts)) fv_cand in_scope acc where - alt_fvs (Alt _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs) + alt_fvs (Alt _ bndrs rhs) = addBndrsFV bndrs (exprFVs rhs) -expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc - = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) +exprFVs (Let (NonRec bndr rhs) body) fv_cand in_scope acc + = (rhs_fvs (bndr, rhs) `unionFV` addBndrFV bndr (exprFVs body)) fv_cand in_scope acc -expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc - = addBndrs (map fst pairs) - (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) +exprFVs (Let (Rec pairs) body) fv_cand in_scope acc + = addBndrsFV (map fst pairs) + (mapUnionFV rhs_fvs pairs `unionFV` exprFVs body) fv_cand in_scope acc --------- rhs_fvs :: (Id, CoreExpr) -> FV -rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` +rhs_fvs (bndr, rhs) = exprFVs rhs `unionFV` bndrRuleAndUnfoldingFVs bndr -- Treat any RULES as extra RHSs of the binding --------- -exprs_fvs :: [CoreExpr] -> FV -exprs_fvs exprs = mapUnionFV expr_fvs exprs - tickish_fvs :: CoreTickish -> FV tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV -{- -************************************************************************ -* * -\section{Free names} -* * -************************************************************************ --} - --- | Finds the free /external/ names of an expression, notably --- including the names of type constructors (which of course do not show --- up in 'exprFreeVars'). -exprOrphNames :: CoreExpr -> NameSet --- There's no need to delete local binders, because they will all --- be /internal/ names. -exprOrphNames e - = go e - where - go (Var v) - | isExternalName n = unitNameSet n - | otherwise = emptyNameSet - where n = idName v - go (Lit _) = emptyNameSet - go (Type ty) = orphNamesOfType ty -- Don't need free tyvars - go (Coercion co) = orphNamesOfCo co - go (App e1 e2) = go e1 `unionNameSet` go e2 - go (Lam v e) = go e `delFromNameSet` idName v - go (Tick _ e) = go e - go (Cast e co) = go e `unionNameSet` orphNamesOfCo co - go (Let (NonRec _ r) e) = go e `unionNameSet` go r - go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e - go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty - `unionNameSet` unionNameSets (map go_alt as) - - go_alt (Alt _ _ r) = go r - --- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details -exprsOrphNames :: [CoreExpr] -> NameSet -exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es - - {- ********************************************************************** %* * - orphNamesXXX - + Orphan names %* * %********************************************************************* -} +{- Note [Finding orphan names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions here (orphNamesOfType, orphNamesOfExpr etc) traverse a template: + * the head of an class instance decl + * the LHS of a type-family instance + * the arguments of a RULE +to find TyCons or (in the case of a RULE) Ids, that will be matched against when +matching the template. If none of these orphNames are locally defined, the instance +or RULE is an orphan: see Note [Orphans] in GHC.Core + +Wrinkles: + (ON1) We do not need to look inside coercions, because we never match against + them. Indeed, it'd be wrong to do so, because it could make an instance + into a non-orphan, when it really is an orphan. + + (ON2) These orphNames functions are also (rather separately) used by GHCi, to + implement :info. When you say ":info Foo", we show all the instances that + involve `Foo`; that is, all the instances whose oprhNames include `Foo`. + + To support `:info (->)` we need to ensure that (->) is treated as an orphName + of FunTy, which is a bit messy since the "real" TyCon is `FUN` +-} + orphNamesOfTyCon :: TyCon -> NameSet orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of Nothing -> emptyNameSet @@ -350,6 +328,8 @@ orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) `unionNameSet` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg + orphNamesOfType (TyConApp tycon tys) = func `unionNameSet` orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys @@ -367,9 +347,9 @@ fun_tc = tyConName (funTyFlagTyCon af) -orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg -orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co -orphNamesOfType (CoercionTy co) = orphNamesOfCo co +-- Coercions: see wrinkle (ON1) of Note [Finding orphan names] +orphNamesOfType (CastTy ty _co) = orphNamesOfType ty +orphNamesOfType (CoercionTy _co) = emptyNameSet orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet @@ -377,56 +357,6 @@ orphNamesOfTypes :: [Type] -> NameSet orphNamesOfTypes = orphNamesOfThings orphNamesOfType -orphNamesOfMCo :: MCoercion -> NameSet -orphNamesOfMCo MRefl = emptyNameSet -orphNamesOfMCo (MCo co) = orphNamesOfCo co - -orphNamesOfCo :: Coercion -> NameSet -orphNamesOfCo (Refl ty) = orphNamesOfType ty -orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco -orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (ForAllCo _ kind_co co) = orphNamesOfCo kind_co - `unionNameSet` orphNamesOfCo co -orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 }) - = orphNamesOfCo co_mult - `unionNameSet` orphNamesOfCo co1 - `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (CoVarCo _) = emptyNameSet -orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos -orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 - `unionNameSet` orphNamesOfType t2 -orphNamesOfCo (SymCo co) = orphNamesOfCo co -orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 -orphNamesOfCo (SelCo _ co) = orphNamesOfCo co -orphNamesOfCo (LRCo _ co) = orphNamesOfCo co -orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg -orphNamesOfCo (KindCo co) = orphNamesOfCo co -orphNamesOfCo (SubCo co) = orphNamesOfCo co -orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs -orphNamesOfCo (HoleCo _) = emptyNameSet - -orphNamesOfProv :: UnivCoProvenance -> NameSet -orphNamesOfProv (PhantomProv co) = orphNamesOfCo co -orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co -orphNamesOfProv (PluginProv _) = emptyNameSet -orphNamesOfProv (CorePrepProv _) = emptyNameSet - -orphNamesOfCos :: [Coercion] -> NameSet -orphNamesOfCos = orphNamesOfThings orphNamesOfCo - -orphNamesOfCoCon :: CoAxiom br -> NameSet -orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches - -orphNamesOfCoAxBranches :: Branches br -> NameSet -orphNamesOfCoAxBranches - = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches - -orphNamesOfCoAxBranch :: CoAxBranch -> NameSet -orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) - = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs - -- | `orphNamesOfAxiomLHS` collects the names of the concrete types and -- type constructors that make up the LHS of a type family instance, -- including the family name itself. @@ -441,12 +371,45 @@ = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) `extendNameSet` getName (coAxiomTyCon axiom) --- Detect FUN 'Many as an application of (->), so that :i (->) works as expected +-- Detect (FUN 'Many) as an application of (->), so that :i (->) works as expected -- (see #8535) Issue #16475 describes a more robust solution +-- See wrinkle (ON2) of Note [Finding orphan names] orph_names_of_fun_ty_con :: Mult -> NameSet orph_names_of_fun_ty_con ManyTy = unitNameSet unrestrictedFunTyConName orph_names_of_fun_ty_con _ = emptyNameSet +-- | Finds the free /external/ names of an expression, notably +-- including the names of type constructors (which of course do not show +-- up in 'exprFreeVars'). +orphNamesOfExpr :: CoreExpr -> NameSet +-- There's no need to delete local binders, because they will all +-- be /internal/ names. +orphNamesOfExpr e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = idName v + go (Lit _) = emptyNameSet + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion _co) = emptyNameSet -- See wrinkle (ON1) of Note [Finding orphan names] + go (App e1 e2) = go e1 `unionNameSet` go e2 + go (Lam v e) = go e `delFromNameSet` idName v + go (Tick _ e) = go e + go (Cast e _co) = go e -- See wrinkle (ON1) of Note [Finding orphan names] + go (Let (NonRec _ r) e) = go e `unionNameSet` go r + go (Let (Rec prs) e) = orphNamesOfExprs (map snd prs) `unionNameSet` go e + go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty + `unionNameSet` unionNameSets (map go_alt as) + + go_alt (Alt _ _ r) = go r + +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +orphNamesOfExprs :: [CoreExpr] -> NameSet +orphNamesOfExprs es = foldr (unionNameSet . orphNamesOfExpr) emptyNameSet es + + {- ************************************************************************ * * @@ -468,7 +431,7 @@ -- See Note [Rule free var hack] , ru_bndrs = bndrs , ru_rhs = rhs, ru_args = args }) - = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs) + = filterFV isLocalVar $ addBndrsFV bndrs (exprsFVs exprs) where exprs = case from of LhsOnly -> args @@ -687,9 +650,9 @@ = case unf of CoreUnfolding { uf_tmpl = rhs, uf_src = src } | isStableSource src - -> Just (filterFV isLocalVar $ expr_fvs rhs) + -> Just (exprLocalFVs rhs) DFunUnfolding { df_bndrs = bndrs, df_args = args } - -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) + -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args) -- DFuns are top level, so no fvs from types of bndrs _other -> Nothing @@ -736,7 +699,7 @@ | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v) | otherwise = (emptyDVarSet, AnnVar v) where - mult_vars = tyCoVarsOfTypeDSet (varMult v) + mult_vars = tyCoVarsOfTypeDSet (idMult v) ty_fvs = dVarTypeTyCoVars v -- See Note [The FVAnn invariant] @@ -798,4 +761,3 @@ go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) - diff --git a/GHC/Core/FamInstEnv.hs b/GHC/Core/FamInstEnv.hs --- a/GHC/Core/FamInstEnv.hs +++ b/GHC/Core/FamInstEnv.hs @@ -42,6 +42,7 @@ import GHC.Core.Unify import GHC.Core.Type as Type import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.Compare( eqType, eqTypes ) import GHC.Core.TyCon import GHC.Core.Coercion @@ -49,27 +50,30 @@ import GHC.Core.Reduction import GHC.Core.RoughMap import GHC.Core.FVs( orphNamesOfAxiomLHS ) + +import GHC.Builtin.Types.Literals( tryMatchFam ) + import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name -import GHC.Data.FastString -import GHC.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc -import Control.Monad -import Data.List( mapAccumL ) -import Data.Array( Array, assocs ) +import GHC.Types.Name.Set import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Types.Name.Set +import GHC.Data.FastString +import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.List.Infinite (Infinite (..)) import qualified GHC.Data.List.Infinite as Inf +import Control.Monad +import Data.List( mapAccumL ) +import Data.Array( Array, assocs ) + {- ************************************************************************ * * @@ -244,10 +248,10 @@ ppr_tc_sort = case flavor of SynFamilyInst -> text "type" DataFamilyInst tycon - | isDataTyCon tycon -> text "data" - | isNewTyCon tycon -> text "newtype" - | isAbstractTyCon tycon -> text "data" - | otherwise -> text "WEIRD" <+> ppr tycon + | isBoxedDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax , text "Tvs:" <+> ppr tvs @@ -370,7 +374,7 @@ - For finding overlaps and conflicts - For finding the representation type...see FamInstEnv.topNormaliseType - and its call site in GHC.Core.Opt.Simplify + and its call site in GHC.Core.Opt.Simplify.Iteration - In standalone deriving instance Eq (T [Int]) we need to find the representation type for T [Int] @@ -484,8 +488,8 @@ apart(target, pattern) = not (unify(flatten(target), pattern)) where flatten (implemented in flattenTys, below) converts all type-family -applications into fresh variables. (See -Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.) +applications into fresh variables. (See Note [Apartness and type families] +in GHC.Core.Unify.) Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~ @@ -509,11 +513,11 @@ only when we can be sure that 'a' is not Int. To achieve this, after finding a possible match within the equations, we have to -go back to all previous equations and check that, under the -substitution induced by the match, other branches are surely apart. (See -Note [Apartness].) This is similar to what happens with class -instance selection, when we need to guarantee that there is only a match and -no unifiers. The exact algorithm is different here because the +go back to all previous equations and check that, under the substitution induced +by the match, other branches are surely apart, using `tcUnifyTysFG`. (See +Note [Apartness and type families] in GHC.Core.Unify.) This is similar to what +happens with class instance selection, when we need to guarantee that there is +only a match and no unifiers. The exact algorithm is different here because the potentially-overlapping group is closed. As another example, consider this: @@ -576,7 +580,7 @@ compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) - = case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of + = case tcUnifyTysFG alwaysBindFam alwaysBindTv commonlhs1 commonlhs2 of -- Here we need the cab_tvs of the two branches to be disinct. -- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom. SurelyApart -> True @@ -607,7 +611,8 @@ -- See Note [Verifying injectivity annotation], case 1. = let getInjArgs = filterByList injectivity in_scope = mkInScopeSetList (tvs1 ++ tvs2) - in case tcUnifyTyWithTFs True in_scope rhs1 rhs2 of -- True = two-way pre-unification + in case tcUnifyTyForInjectivity True in_scope rhs1 rhs2 of + -- True = two-way pre-unification Nothing -> InjectivityAccepted -- RHS are different, so equations are injective. -- This is case 1A from Note [Verifying injectivity annotation] @@ -1190,13 +1195,12 @@ | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys - = let co = mkAxInstCo role ax ind inst_tys inst_cos + = let co = mkAxInstCo role (BranchedAxiom ax ind) inst_tys inst_cos in Just $ coercionRedn co - | Just ax <- isBuiltInSynFamTyCon_maybe tc - , Just (coax,ts,ty) <- sfMatchFam ax tys - , role == coaxrRole coax - = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) + | Just builtin_fam <- isBuiltInSynFamTyCon_maybe tc + , Just (rewrite,ts,ty) <- tryMatchFam builtin_fam tys + = let co = mkAxiomCo rewrite (map mkNomReflCo ts) in Just $ mkReduction co ty | otherwise @@ -1226,22 +1230,16 @@ -> Maybe (BranchIndex, [Type], [Coercion]) go (index, branch) other = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs - , cab_lhs = tpl_lhs - , cab_incomps = incomps }) = branch - in_scope = mkInScopeSet (unionVarSets $ - map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - -- See Note [Flattening type-family applications when matching instances] - -- in GHC.Core.Unify - flattened_target = flattenTys in_scope target_tys + , cab_lhs = tpl_lhs }) = branch in case tcMatchTys tpl_lhs target_tys of - Just subst -- matching worked. now, check for apartness. - | apartnessCheck flattened_target branch - -> -- matching worked & we're apart from all incompatible branches. + Just subst -- Matching worked. now, check for apartness. + | apartnessCheck target_tys branch + -> -- Matching worked & we're apart from all incompatible branches. -- success assert (all (isJust . lookupCoVar subst) tpl_cvs) $ Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) - -- failure. keep looking + -- Failure. keep looking _ -> other -- | Do an apartness check, as described in the "Closed Type Families" paper @@ -1249,15 +1247,12 @@ -- ('CoAxBranch') of a closed type family can be used to reduce a certain target -- type family application. apartnessCheck :: [Type] - -- ^ /flattened/ target arguments. Make sure they're flattened! See - -- Note [Flattening type-family applications when matching instances] - -- in GHC.Core.Unify. - -> CoAxBranch -- ^ the candidate equation we wish to use + -> CoAxBranch -- ^ The candidate equation we wish to use -- Precondition: this matches the target -> Bool -- ^ True <=> equation can fire -apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) +apartnessCheck target (CoAxBranch { cab_incomps = incomps }) = all (isSurelyApart - . tcUnifyTysFG alwaysBindFun flattened_target + . tcUnifyTysFG alwaysBindFam alwaysBindTv target . coAxBranchLHS) incomps where isSurelyApart SurelyApart = True @@ -1341,7 +1336,7 @@ -- * newtypes -- returning an appropriate Representational coercion. Specifically, if -- topNormaliseType_maybe env ty = Just (co, ty') --- then +-- then postconditions: -- (a) co :: ty ~R ty' -- (b) ty' is not a newtype, and is not a type-family or data-family redex -- diff --git a/GHC/Core/InstEnv.hs b/GHC/Core/InstEnv.hs --- a/GHC/Core/InstEnv.hs +++ b/GHC/Core/InstEnv.hs @@ -11,10 +11,10 @@ module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult, - Canonical, PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers, + CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, - instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances, + instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst, instanceDFunId, updateClsInstDFuns, updateClsInstDFun, fuzzyClsInstCmp, orphNamesOfClsInst, @@ -42,8 +42,10 @@ import GHC.Core.Class import GHC.Core.Unify import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType ) +import GHC.Hs.Extension import GHC.Unit.Module.Env +import GHC.Unit.Module.Warnings import GHC.Unit.Types import GHC.Types.Var import GHC.Types.Unique.DSet @@ -60,7 +62,6 @@ import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Semigroup {- @@ -108,6 +109,10 @@ , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag , is_orphan :: IsOrphan + , is_warn :: Maybe (WarningTxt GhcRn) + -- Warning emitted when the instance is used + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict } deriving Data @@ -169,7 +174,7 @@ Reason for freshness: we use unification when checking for overlap etc, and that requires the tyvars to be distinct. -The invariant is checked by the ASSERT in lookupInstEnv'. +The invariant is checked by the ASSERT in instEnvMatchesAndUnifiers. Note [Proper-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -218,6 +223,16 @@ instance Outputable ClsInst where ppr = pprInstance +pprDFunId :: DFunId -> SDoc +-- Prints the analogous information to `pprInstance` +-- but with just the DFunId +pprDFunId dfun + = hang dfun_header + 2 (vcat [ text "--" <+> pprDefinedAt (getName dfun) + , whenPprDebug (ppr dfun) ]) + where + dfun_header = ppr_overlap_dfun_hdr empty dfun + pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec @@ -229,11 +244,18 @@ pprInstanceHdr :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) - = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) + = ppr_overlap_dfun_hdr (ppr flag) dfun +ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc +ppr_overlap_dfun_hdr flag_sdoc dfun + = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun) + pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) +instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn) +instanceWarning = is_warn + instanceHead :: ClsInst -> ([TyVar], Class, [Type]) -- Returns the head, using the fresh tyvars from the ClsInst instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys }) @@ -261,17 +283,18 @@ mkLocalClsInst :: DFunId -> OverlapFlag -> [TyVar] -> Class -> [Type] + -> Maybe (WarningTxt GhcRn) -> ClsInst -- Used for local instances, where we can safely pull on the DFunId. -- Consider using newClsInst instead; this will also warn if -- the instance is an orphan. -mkLocalClsInst dfun oflag tvs cls tys +mkLocalClsInst dfun oflag tvs cls tys warn = ClsInst { is_flag = oflag, is_dfun = dfun , is_tvs = tvs , is_dfun_name = dfun_name , is_cls = cls, is_cls_nm = cls_name , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys - , is_orphan = orph + , is_orphan = orph, is_warn = warn } where cls_name = className cls @@ -302,24 +325,26 @@ choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedClsInst :: Name -- ^ the name of the class - -> [RoughMatchTc] -- ^ the rough match signature of the instance - -> Name -- ^ the 'Name' of the dictionary binding - -> DFunId -- ^ the 'Id' of the dictionary. - -> OverlapFlag -- ^ may this instance overlap? - -> IsOrphan -- ^ is this instance an orphan? +mkImportedClsInst :: Name -- ^ the name of the class + -> [RoughMatchTc] -- ^ the rough match signature of the instance + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? + -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file -- The bound tyvars of the dfun are guaranteed fresh, because -- the dfun has been typechecked out of the same interface file -mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan +mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn = ClsInst { is_flag = oflag, is_dfun = dfun , is_tvs = tvs, is_tys = tys , is_dfun_name = dfun_name , is_cls_nm = cls_nm, is_cls = cls , is_tcs = RM_KnownTc cls_nm : mb_tcs - , is_orphan = orphan } + , is_orphan = orphan + , is_warn = warn } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) @@ -574,21 +599,25 @@ manual section on "overlapping instances". At risk of duplication, here are the rules. If the rules change, change this text and the user manual simultaneously. The link may be this: -http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap +https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/instances.html#instance-overlap The willingness to be overlapped or incoherent is a property of the -instance declaration itself, controlled as follows: +instance declaration itself, controlled by its `OverlapMode`, as follows - * An instance is "incoherent" + * An instance is "incoherent" (OverlapMode = `Incoherent` or `NonCanonical`) if it has an `INCOHERENT` pragma, or if it appears in a module compiled with `-XIncoherentInstances`. + In those cases: + -fspecialise-incoherents on => Incoherent + -fspecialise-incoherents off => NonCanonical + NB: it is on by default - * An instance is "overlappable" + * An instance is "overlappable" (OverlapMode = `Overlappable` or `Overlaps`) if it has an `OVERLAPPABLE` or `OVERLAPS` pragma, or if it appears in a module compiled with `-XOverlappingInstances`, or if the instance is incoherent. - * An instance is "overlapping" + * An instance is "overlapping" (OverlapMode = `Overlapping` or `Overlaps`) if it has an `OVERLAPPING` or `OVERLAPS` pragma, or if it appears in a module compiled with `-XOverlappingInstances`, or if the instance is incoherent. @@ -598,14 +627,22 @@ (IL0) If there are any local Givens that match (potentially unifying any metavariables, even untouchable ones) the target constraint, - the search fails. See Note [Instance and Given overlap] in - GHC.Tc.Solver.Dict. + the search fails unless -XIncoherentInstances is enabled. See + Note [Instance and Given overlap] in GHC.Tc.Solver.Dict. This is + implemented by the first guard in matchClassInst. -(IL1) Find all instances `I` that *match* the target constraint; that is, the target - constraint is a substitution instance of `I`. These instance declarations are - the /candidates/. +(IL1) Find `all_matches` and `all_unifs` in `lookupInstEnv`: + - all_matches: all instances `I` that *match* the target constraint (that + is, the target constraint is a substitution instance of `I`). These + instance declarations are the /candidates/. + - all_unifs: all non-incoherent instances that *unify with but do not match* + the target constraint. These are not candidates, but might match later if + the target constraint is furhter instantiated. See + `data PotentialUnifiers` for more precise details. -(IL2) If there are no candidates, the search fails. +(IL2) If there are no candidates, the search fails + (lookupInstEnv returns no final_matches). The PotentialUnifiers are returned + by lookupInstEnv for use in error message generation (mkDictErr). (IL3) Eliminate any candidate `IX` for which there is another candidate `IY` such that both of the following hold: @@ -616,19 +653,39 @@ client to deliberately override an instance from a library, without requiring a change to the library.) -(IL4) If all the remaining candidates are *incoherent*, the search succeeds, - returning an arbitrary surviving candidate. + In addition, provided there is at least one candidate, eliminate any other + candidates that are *incoherent*. (In particular, if all remaining candidates + are incoherent, all except an arbitrarily chosen one will be eliminated.) -(IL5) If more than one non-*incoherent* candidate remains, the search - fails. Otherwise there is exactly one non-*incoherent* - candidate; call it the "prime candidate". + This is implemented by `pruneOverlappedMatches`, producing final_matches in + lookupInstEnv. See Note [Instance overlap and guards] and + Note [Incoherent instances]. -(IL6) Now find all instances that unify with the target constraint, - but do not match it. Such non-candidate instances might match - when the target constraint is further instantiated. If all of - them are *incoherent* top-level instances, the search succeeds, - returning the prime candidate. Otherwise the search fails. +(IL4) If exactly one *incoherent* candidate remains, the search succeeds. + (By the previous step, there cannot be more than one incoherent candidate + remaining.) + In this case, lookupInstEnv returns the successful match, and it returns + NoUnifiers as the final_unifs, which amounts to skipping the following + steps. + +(IL5) If more than one candidate remains, the search fails. (We have already + eliminated the incoherent candidates, and we have no way to select + between non-incoherent candidates.) + +(IL6) Otherwise there is exactly one candidate remaining. The all_unifs + computed at step (IL1) are returned from lookupInstEnv as final_unifs. + + If there are no potential unifiers, the search succeeds (in matchInstEnv). + If there is at least one (non-incoherent) potential unifier, matchInstEnv + returns a NotSure result and refrains from committing to the instance. + + Incoherent instances are not returned as part of the potential unifiers. This + affects error messages: they will not be listed as "potentially matching instances" + in an "Overlapping instances" or "Ambiguous type variable" error. + See also Note [Recording coherence information in `PotentialUnifiers`]. + + Notice that these rules are not influenced by flag settings in the client module, where the instances are *used*. These rules make it possible for a library author to design a library that relies on @@ -762,8 +819,11 @@ d1 :: C tys d2 :: C tys then the dictionary d1 can be used in place of d2 and vice versa; it is as if -(C tys) is a singleton type. How do we guarantee this? Let's use this -example +(C tys) is a singleton type. If d1 and d2 are interchangeable, we say that +they constitute /canonical evidence/ for (C tys). We have a special data type, +`CanonoicalEvidence`, for recording whether evidence is canonical. + +Let's use this example class C a where { op :: a -> Int } instance C [a] where {...} -- (I1) instance {-# OVERLAPPING #-} C [Int] where {...} -- (I2) @@ -782,7 +842,7 @@ programmer can contrive, with some effort), all bets are off; we really can't make any guarantees at all. -* But what about [W] C [b], which might arise from +* But what about [W] C [b]? This might arise from risky :: b -> Int risky x = op [x] We can't pick (I2) because `b` is not Int. But if we pick (I1), and later @@ -838,20 +898,22 @@ and sometimes we don't. It would be best to have a per-instance pragma, but for now we have a global flag: -* If an instance has an `{-# INCOHERENT #-}` pragma, we use its `OverlapFlag` to - label it as either - * `Incoherent`: meaning incoherent but still specialisable, or - * `NonCanonical`: meaning incoherent and not specialisable. +* If an instance has an `{-# INCOHERENT #-}` pragma, we the `OverlapFlag` of the + `ClsInst` to label it as either + * `Incoherent`: meaning incoherent but still specialisable, or + * `NonCanonical`: meaning incoherent and not specialisable. + The module-wide `-fspecialise-incoherents` flag (on by default) determines + which choice is made. -The module-wide `-fspecialise-incoherents` flag determines which -choice is made. The rest of this note describes what happens for -`NonCanonical` instances, i.e. with `-fno-specialise-incoherents`. + See GHC.Tc.Utils.Instantiate.getOverlapFlag. +The rest of this note describes what happens for `NonCanonical` +instances, i.e. with `-fno-specialise-incoherents`. + To avoid this incoherence breaking the specialiser, -* We label as "non-canonical" the dictionary constructed by a - (potentially) incoherent use of an instance declaration whose - `OverlapFlag` is `NonCanonical`. +* We label as "non-canonical" any dictionary constructed by a (potentially) + incoherent use of an ClsInst. * We do not specialise a function if there is a non-canonical dictionary in the /transistive dependencies/ of its dictionary @@ -878,17 +940,57 @@ Here are the moving parts: * GHC.Core.InstEnv.lookupInstEnv tells if any incoherent unifiers were discarded - in step (IL6) of the instance lookup. + in step (IL4) or (IL6) of the instance lookup: see + Note [Recording coherence information in `PotentialUnifiers`] and + Note [Canonicity for incoherent matches]. * That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary. -* `GHC.HsToCore.Binds.dsHsWrapper` desugars the evidence application (f d) into - (nospec f d) if `d` is incoherent. It has to do a dependency analysis to - determine transitive dependencies, but we need to do that anyway. - See Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds. - +* In the desugarer we exploit this info: + see Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr. See also Note [nospecId magic] in GHC.Types.Id.Make. + + +Note [Canonicity for incoherent matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the selected instance is INCOHERENT at step (IL4) of +Note [Rules for instance lookup], we ignore all unifiers, +whether or not they are marked with INCOHERENT pragmas. +This is implemented by returning NoUnifiers in final_unifs. +NoUnifiers takes an argument indicating whether the match was canonical +as described in Note [Coherence and specialisation: overview] and +Note [Recording coherence information in `PotentialUnifiers`]. + +To determine whether an incoherent match was canonical, we look *only* +at the OverlapFlag of the instance being matched. For example: + + class C a + instance {-# INCOHERENT #-} C a -- (1) + instance C Int -- (2) + + [W] C tau + +Here we match instance (1) and discard instance (2). If (1) is Incoherent +(under -fspecialise-incoherents), it is important that we treat the match +as EvCanonical so that we do not block specialisation (see #25883). + +What about the following situation: + + instance {-# INCOHERENT #-} C a -- (1), in a module with -fspecialise-incoherents (Incoherent) + instance {-# INCOHERENT #-} C Int -- (2), in a module with -fno-specialise-incoherents (NonCanonical) + + [W] C tau + +Again we match instance (1) and discard instance (2). It is not obvious +whether Incoherent or NonCanonical should "win" here, but it seems more +consistent with the previous example to look only at the flag on instance (1). + +What about if the only instance that can match is marked as NonCanonical? +In this case are no unifiers at all, so all_unifs = NoUnifiers EvCanonical. +It is not obvious what -fno-specialise-incoherents should do here, but +currently it returns NoUnifiers EvCanonical. + -} type DFunInstType = Maybe Type @@ -991,26 +1093,46 @@ LookupInstErrNotFound deriving (Generic) -type Canonical = Bool +-- | `CanonicalEvidence` says whether a piece of evidence has a singleton type; +-- For example, given (d1 :: C Int), will any other (d2 :: C Int) do equally well? +-- See Note [Coherence and specialisation: overview] above, and +-- Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds +data CanonicalEvidence + = EvCanonical + | EvNonCanonical +andCanEv :: CanonicalEvidence -> CanonicalEvidence -> CanonicalEvidence +-- Only canonical if both are +andCanEv EvCanonical EvCanonical = EvCanonical +andCanEv _ _ = EvNonCanonical + -- See Note [Recording coherence information in `PotentialUnifiers`] -data PotentialUnifiers = NoUnifiers Canonical - -- NoUnifiers True: We have a unique solution modulo canonicity - -- NoUnifiers False: The solutions is not canonical, and thus - -- we shouldn't specialise on it. - | OneOrMoreUnifiers (NonEmpty ClsInst) - -- This list is lazy as we only look at all the unifiers when - -- printing an error message. It can be expensive to compute all - -- the unifiers because if you are matching something like C a[sk] then - -- all instances will unify. +data PotentialUnifiers + = NoUnifiers CanonicalEvidence + -- Either there were no unifiers, or all were incoherent + -- + -- NoUnifiers EvNonCanonical: + -- We discarded (via INCOHERENT) some instances that unify, + -- and that are marked NonCanonical; so the matching instance + -- should be traeated as EvNonCanonical + -- NoUnifiers EvCanonical: + -- We discarded no NonCanonical incoherent unifying instances, + -- so the matching instance can be treated as EvCanonical + | OneOrMoreUnifiers (NonEmpty ClsInst) + -- There are some /coherent/ unifiers; here they are + -- + -- This list is lazy as we only look at all the unifiers when + -- printing an error message. It can be expensive to compute all + -- the unifiers because if you are matching something like C a[sk] then + -- all instances will unify. + {- Note [Recording coherence information in `PotentialUnifiers`] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - When we find a matching instance, there might be other instances that could potentially unify with the goal. For `INCOHERENT` instances, we -don't care (see steps IL4 and IL6 in Note [Rules for instance -lookup]). But if we have potentially unifying coherent instance, we +don't care (see step (IL6) in Note [Rules for instance lookup]). +But if we have potentially unifying coherent instance, we report these `OneOrMoreUnifiers` so that `matchInstEnv` can go down the `NotSure` route. @@ -1020,30 +1142,59 @@ overview] for why we care at all). So when the set of potential unifiers is empty, we record in `NoUnifiers` if the one solution is `Canonical`. + +For example, suppose we have: + + class C x y + instance C a Bool -- (1) + instance {-# INCOHERENT #-} C Int a -- (2) + + [W] C x Bool + +Here instance (1) matches the Wanted, and since instance (2) is INCOHERENT +we want to succeed with the match rather than getting stick at step (IL6). +But if -fno-specialise-incoherents was enabled for (2), the specialiser is +not permitted to specialise this dictionary later, so lookupInstEnv reports +the PotentialUnifiers as NoUnifiers EvNonCanonical. + -} +instance Outputable CanonicalEvidence where + ppr EvCanonical = text "canonical" + ppr EvNonCanonical = text "non-canonical" + instance Outputable PotentialUnifiers where - ppr (NoUnifiers c) = text "NoUnifiers" <+> if c then text "canonical" else text "non-canonical" - ppr xs = ppr (getPotentialUnifiers xs) + ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c + ppr xs = ppr (getCoherentUnifiers xs) instance Semigroup PotentialUnifiers where - NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 && c2) + NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 `andCanEv` c2) NoUnifiers _ <> u = u - OneOrMoreUnifiers (unifier :| unifiers) <> u = OneOrMoreUnifiers (unifier :| (unifiers <> getPotentialUnifiers u)) + OneOrMoreUnifiers (unifier :| unifiers) <> u + = OneOrMoreUnifiers (unifier :| (unifiers <> getCoherentUnifiers u)) -getPotentialUnifiers :: PotentialUnifiers -> [ClsInst] -getPotentialUnifiers NoUnifiers{} = [] -getPotentialUnifiers (OneOrMoreUnifiers cls) = NE.toList cls +getCoherentUnifiers :: PotentialUnifiers -> [ClsInst] +getCoherentUnifiers NoUnifiers{} = [] +getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls +-- | Are there no *coherent* unifiers? nullUnifiers :: PotentialUnifiers -> Bool nullUnifiers NoUnifiers{} = True nullUnifiers _ = False -lookupInstEnv' :: InstEnv -- InstEnv to look in - -> VisibleOrphanModules -- But filter against this - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - PotentialUnifiers) -- These don't match but do unify +-- | Are there any unifiers, ignoring those marked Incoherent (but including any +-- marked NonCanonical)? +someUnifiers :: PotentialUnifiers -> Bool +someUnifiers (NoUnifiers EvCanonical) = False +someUnifiers _ = True + + +instEnvMatchesAndUnifiers + :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + PotentialUnifiers) -- These don't match but do unify -- (no incoherent ones in here) -- The second component of the result pair happens when we look up -- Foo [a] @@ -1055,8 +1206,8 @@ -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' (InstEnv rm) vis_mods cls tys - = (foldr check_match [] rough_matches, check_unifier rough_unifiers) +instEnvMatchesAndUnifiers (InstEnv rm) vis_mods cls tys + = (foldr check_match [] rough_matches, check_unifiers rough_unifiers) where (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm rough_tcs = RML_KnownTc (className cls) : roughMatchTcsLookup tys @@ -1069,29 +1220,23 @@ | Just subst <- tcMatchTys tpl_tys tys = ((item, map (lookupTyVar subst) tpl_tvs) : acc) + | otherwise = acc - - noncanonically_matched :: PotentialUnifiers -> PotentialUnifiers - noncanonically_matched (NoUnifiers _) = NoUnifiers False - noncanonically_matched u = u + check_unifiers :: [ClsInst] -> PotentialUnifiers + check_unifiers [] = NoUnifiers EvCanonical + check_unifiers (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items) - check_unifier :: [ClsInst] -> PotentialUnifiers - check_unifier [] = NoUnifiers True - check_unifier (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items) | not (instIsVisible vis_mods item) - = check_unifier items -- See Note [Instance lookup and orphan instances] - | Just {} <- tcMatchTys tpl_tys tys = check_unifier items - -- Does not match, so next check whether the things unify - -- See Note [Overlapping instances] - -- Record that we encountered non-canonical instances: Note [Coherence and specialisation: overview] - | isNonCanonical item - = noncanonically_matched $ check_unifier items - -- Ignore ones that are incoherent: Note [Incoherent instances] - | isIncoherent item - = check_unifier items + = check_unifiers items -- See Note [Instance lookup and orphan instances] + -- If it matches, check_match has gotten it, so skip over it here + | Just {} <- tcMatchTys tpl_tys tys + = check_unifiers items + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] | otherwise = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set) ((ppr cls <+> ppr tys) $$ @@ -1099,20 +1244,38 @@ -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them -- See Note [Template tyvars are fresh] - case tcUnifyTysFG instanceBindFun tpl_tys tys of + case tcUnifyTysFG alwaysBindFam instanceBindFun tpl_tys tys of + -- alwaysBindFam: the family-application can't be in the instance head, + -- but it certainly can be in the Wanted constraint we are matching! + -- -- We consider MaybeApart to be a case where the instance might -- apply in the future. This covers an instance like C Int and -- a target like [W] C (F a), where F is a type family. - SurelyApart -> check_unifier items + -- See (ATF1) in Note [Apartness and type families] in GHC.Core.Unify + SurelyApart -> check_unifiers items -- See Note [Infinitary substitution in lookup] - MaybeApart MARInfinite _ -> check_unifier items - _ -> - OneOrMoreUnifiers (item :| getPotentialUnifiers (check_unifier items)) + MaybeApart MARInfinite _ -> check_unifiers items + _ -> add_unifier item (check_unifiers items) where tpl_tv_set = mkVarSet tpl_tvs tys_tv_set = tyCoVarsOfTypes tys + add_unifier :: ClsInst -> PotentialUnifiers -> PotentialUnifiers + -- Record that we encountered non-canonical instances: + -- Note [Coherence and specialisation: overview] + add_unifier item other_unifiers + | not (isIncoherent item) + = OneOrMoreUnifiers (item :| getCoherentUnifiers other_unifiers) + + -- So `item` is incoherent; see Note [Incoherent instances] + | otherwise + = case other_unifiers of + OneOrMoreUnifiers{} -> other_unifiers + NoUnifiers{} | isNonCanonical item -> NoUnifiers EvNonCanonical + | otherwise -> other_unifiers + + --------------- -- This is the common way to call this function. lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions @@ -1130,10 +1293,13 @@ tys = (final_matches, final_unifs, unsafe_overlapped) where - (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys - (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys + -- (IL1): Find all instances that match the target constraint + (home_matches, home_unifs) = instEnvMatchesAndUnifiers home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = instEnvMatchesAndUnifiers pkg_ie vis_mods cls tys all_matches = home_matches <> pkg_matches all_unifs = home_unifs <> pkg_unifs + + -- (IL3): Eliminate candidates that are overlapped or incoherent final_matches = pruneOverlappedMatches all_matches -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't @@ -1146,9 +1312,19 @@ _ -> [] -- If the selected match is incoherent, discard all unifiers + -- See (IL4) of Note [Rules for instance lookup] final_unifs = case final_matches of - (m:_) | isIncoherent (fst m) -> NoUnifiers True - _ -> all_unifs + (m:ms) | isIncoherent (fst m) + -- Incoherent match, so discard all unifiers, but + -- keep track of dropping coherent or non-canonical ones + -- if the match is non-canonical. + -- See Note [Canonicity for incoherent matches] + -> assertPpr (null ms) (ppr final_matches) $ + NoUnifiers $ + if isNonCanonical (fst m) && someUnifiers all_unifs + then EvNonCanonical + else EvCanonical + _ -> all_unifs -- Note [Safe Haskell isSafeOverlap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1325,7 +1501,10 @@ pruneOverlappedMatches :: [InstMatch] -> [InstMatch] -- ^ Remove from the argument list any InstMatches for which another -- element of the list is more specific, and overlaps it, using the --- rules of Note [Rules for instance lookup] +-- rules of Note [Rules for instance lookup], esp (IL3) +-- +-- Incoherent instances are discarded, unless all are incoherent, +-- in which case exactly one is kept. pruneOverlappedMatches all_matches = instMatches $ foldr insert_overlapping noMatches all_matches @@ -1459,8 +1638,8 @@ Example: class C a b c where foo :: (a,b,c) instance C [a] b Int - instance [incoherent] [Int] b c - instance [incoherent] C a Int c + instance {-# INCOHERENT #-} C [Int] b c + instance {-# INCOHERENT #-} C a Int c Thanks to the incoherent flags, [Wanted] C [a] b Int works: Only instance one matches, the others just unify, but are marked @@ -1492,14 +1671,14 @@ ************************************************************************ -} -instanceBindFun :: BindFun -instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = Apart +instanceBindFun :: BindTvFun +instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = DontBindMe | otherwise = BindMe - -- Note [Binding when looking up instances] + -- Note [Super skolems: binding when looking up instances] {- -Note [Binding when looking up instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Super skolems: binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When looking up in the instance environment, or family-instance environment, we are careful about multiple matches, as described above in Note [Overlapping instances] @@ -1515,9 +1694,9 @@ f :: T -> Int f (MkT x) = op [x,x] The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and -so it is a super skolem. (See the use of tcInstSuperSkolTyVarsX in +so it is a "super skolem". (See the use of tcInstSuperSkolTyVarsX in GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to -isOverlappableTyVar, and the use of Apart in instanceBindFun, above, means +isOverlappableTyVar, and the use of DontBindMe in instanceBindFun, above, means that these will be treated as fresh constants in the unification algorithm during instance lookup. Without this treatment, GHC would complain, saying that the choice of instance depended on the instantiation of 'a'; but of diff --git a/GHC/Core/LateCC.hs b/GHC/Core/LateCC.hs --- a/GHC/Core/LateCC.hs +++ b/GHC/Core/LateCC.hs @@ -1,167 +1,94 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} --- | Adds cost-centers after the core piple has run. +-- | Adds cost-centers after the core pipline has run. module GHC.Core.LateCC - ( addLateCostCentresMG - , addLateCostCentresPgm - , addLateCostCentres -- Might be useful for API users - , Env(..) + ( -- * Inserting cost centres + addLateCostCenters ) where -import Control.Applicative -import Control.Monad -import qualified Data.Set as S - import GHC.Prelude -import GHC.Types.CostCentre -import GHC.Types.CostCentre.State -import GHC.Types.Name hiding (varName) -import GHC.Types.Tickish -import GHC.Unit.Module.ModGuts -import GHC.Types.Var -import GHC.Unit.Types -import GHC.Data.FastString -import GHC.Core -import GHC.Core.Opt.Monad -import GHC.Core.Utils (mkTick) -import GHC.Types.Id -import GHC.Driver.DynFlags +import GHC.Core +import GHC.Core.LateCC.OverloadedCalls +import GHC.Core.LateCC.TopLevelBinds +import GHC.Core.LateCC.Types +import GHC.Core.LateCC.Utils +import GHC.Core.Seq +import qualified GHC.Data.Strict as Strict +import GHC.Core.Utils +import GHC.Tc.Utils.TcType +import GHC.Types.SrcLoc +import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Error (withTiming) -import GHC.Utils.Monad.State.Strict - - -{- Note [Collecting late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Usually cost centres defined by a module are collected -during tidy by collectCostCentres. However with `-fprof-late` -we insert cost centres after inlining. So we keep a list of -all the cost centres we inserted and combine that with the list -of cost centres found during tidy. - -To avoid overhead when using -fprof-inline there is a flag to stop -us from collecting them here when we run this pass before tidy. - -Note [Adding late cost centres] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is very simple. For every top level binder -`f = rhs` we compile it as if the user had written -`f = {-# SCC f #-} rhs`. - -If we do this after unfoldings for `f` have been created this -doesn't impact core-level optimizations at all. If we do it -before the cost centre will be included in the unfolding and -might inhibit optimizations at the call site. For this reason -we provide flags for both approaches as they have different -tradeoffs. - -We also don't add a cost centre for any binder that is a constructor -worker or wrapper. These will never meaningfully enrich the resulting -profile so we improve efficiency by omitting those. - --} - -addLateCostCentresMG :: ModGuts -> CoreM ModGuts -addLateCostCentresMG guts = do - dflags <- getDynFlags - let env :: Env - env = Env - { thisModule = mg_module guts - , ccState = newCostCentreState - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = False -- See Note [Collecting late cost centres] - } - let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts)) - } - return guts' +import GHC.Types.RepType (mightBeFunTy) -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre) -addLateCostCentresPgm dflags logger mod binds = - withTiming logger - (text "LateCC"<+>brackets (ppr mod)) - (\(a,b) -> a `seqList` (b `seq` ())) $ do - let env = Env - { thisModule = mod - , ccState = newCostCentreState - , countEntries = gopt Opt_ProfCountEntries dflags - , collectCCs = True -- See Note [Collecting late cost centres] - } - (binds', ccs) = addLateCostCentres env binds - when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ - putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds')) - return (binds', ccs) +-- | Late cost center insertion logic used by the driver +addLateCostCenters :: + Logger + -- ^ Logger + -> LateCCConfig + -- ^ Late cost center configuration + -> CoreProgram + -- ^ The program + -> IO (CoreProgram, LateCCState (Strict.Maybe SrcSpan)) +addLateCostCenters logger LateCCConfig{..} core_binds = do -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre) -addLateCostCentres env binds = - let (binds', state) = runState (mapM (doBind env) binds) initLateCCState - in (binds',lcs_ccs state) + -- If top-level late CCs are enabled via either -fprof-late or + -- -fprof-late-overloaded, add them + (top_level_cc_binds, top_level_late_cc_state) <- + case lateCCConfig_whichBinds of + LateCCNone -> + return (core_binds, initLateCCState ()) + _ -> + withTiming + logger + (text "LateTopLevelCCs" <+> brackets (ppr this_mod)) + (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ()) + $ {-# SCC lateTopLevelCCs #-} do + pure $ + doLateCostCenters + lateCCConfig_env + (initLateCCState ()) + (topLevelBindsCC top_level_cc_pred) + core_binds + -- If overloaded call CCs are enabled via -fprof-late-overloaded-calls, add + -- them + (late_cc_binds, late_cc_state) <- + if lateCCConfig_overloadedCalls then + withTiming + logger + (text "LateOverloadedCallsCCs" <+> brackets (ppr this_mod)) + (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ()) + $ {-# SCC lateoverloadedCallsCCs #-} do + pure $ + doLateCostCenters + lateCCConfig_env + (top_level_late_cc_state { lateCCState_extra = Strict.Nothing }) + overloadedCallsCC + top_level_cc_binds + else + return + ( top_level_cc_binds + , top_level_late_cc_state { lateCCState_extra = Strict.Nothing } + ) -doBind :: Env -> CoreBind -> M CoreBind -doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs -doBind env (Rec bs) = Rec <$> mapM doPair bs + return (late_cc_binds, late_cc_state) where - doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr)) - doPair (b,rhs) = (b,) <$> doBndr env b rhs - -doBndr :: Env -> Id -> CoreExpr -> M CoreExpr -doBndr env bndr rhs - -- Cost centres on constructor workers are pretty much useless - -- so we don't emit them if we are looking at the rhs of a constructor - -- binding. - | Just _ <- isDataConId_maybe bndr = pure rhs - | otherwise = doBndr' env bndr rhs - - --- We want to put the cost centre below the lambda as we only care about executions of the RHS. -doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr -doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs -doBndr' env bndr rhs = do - let name = idName bndr - name_loc = nameSrcSpan name - cc_name = getOccFS name - count = countEntries env - cc_flavour <- getCCFlavour cc_name - let cc_mod = thisModule env - bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc - note = ProfNote bndrCC count True - addCC env bndrCC - return $ mkTick note rhs - -data LateCCState = LateCCState - { lcs_state :: !CostCentreState - , lcs_ccs :: S.Set CostCentre - } -type M = State LateCCState - -initLateCCState :: LateCCState -initLateCCState = LateCCState newCostCentreState mempty - -getCCFlavour :: FastString -> M CCFlavour -getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name - -getCCIndex' :: FastString -> M CostCentreIndex -getCCIndex' name = do - state <- get - let (index,cc_state') = getCCIndex name (lcs_state state) - put (state { lcs_state = cc_state'}) - return index - -addCC :: Env -> CostCentre -> M () -addCC !env cc = do - state <- get - when (collectCCs env) $ do - let ccs' = S.insert cc (lcs_ccs state) - put (state { lcs_ccs = ccs'}) - -data Env = Env - { thisModule :: !Module - , countEntries:: !Bool - , ccState :: !CostCentreState - , collectCCs :: !Bool - } + top_level_cc_pred :: CoreExpr -> Bool + top_level_cc_pred = + case lateCCConfig_whichBinds of + LateCCBinds -> \rhs -> + -- Make sure we record any functions. Even if it's something like `f = g`. + mightBeFunTy (exprType rhs) || + -- If the RHS is a CAF doing work also insert a CC. + not (exprIsWorkFree rhs) + LateCCOverloadedBinds -> + isOverloadedTy . exprType + LateCCNone -> + -- This is here for completeness, we won't actually use this + -- predicate in this case since we'll shortcut. + const False + this_mod = lateCCEnv_module lateCCConfig_env diff --git a/GHC/Core/LateCC/OverloadedCalls.hs b/GHC/Core/LateCC/OverloadedCalls.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/OverloadedCalls.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module GHC.Core.LateCC.OverloadedCalls + ( overloadedCallsCC + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified GHC.Data.Strict as Strict + +import GHC.Data.FastString +import GHC.Core +import GHC.Core.LateCC.Utils +import GHC.Core.LateCC.Types +import GHC.Core.Make +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Var + +type OverloadedCallsCCState = Strict.Maybe SrcSpan + +{- Note [Overloaded Calls and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently GHC considers cost centres as destructive to +join contexts. Or in other words this is not considered valid: + + join f x = ... + in + ... -> scc jmp + +This makes the functionality of `-fprof-late-overloaded-calls` not feasible +for join points in general. We used to try to work around this by putting the +ticks on the rhs of the join point rather than around the jump. However beyond +the loss of accuracy this was broken for recursive join points as we ended up +with something like: + + rec-join f x = scc ... jmp f x + +Which similarly is not valid as the tick once again destroys the tail call. +One might think we could limit ourselves to non-recursive tail calls and do +something clever like: + + join f x = scc ... + in ... jmp f x + +And sometimes this works! But sometimes the full rhs would look something like: + + join g x = .... + join f x = scc ... -> jmp g x + +Which, would again no longer be valid. I believe in the long run we can make +cost centre ticks non-destructive to join points. Or we could keep track of +where we are/are not allowed to insert a cost centre. But in the short term I will +simply disable the annotation of join calls under this flag. +-} + +-- | Insert cost centres on function applications with dictionary arguments. The +-- source locations attached to the cost centres is approximated based on the +-- "closest" source note encountered in the traversal. +overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind +overloadedCallsCC = + processBind + where + processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind + processBind core_bind = + case core_bind of + NonRec b e -> + NonRec b <$> wrap_if_join b (processExpr e) + Rec es -> + Rec <$> mapM (\(b,e) -> (b,) <$> wrap_if_join b (processExpr e)) es + where + -- If an overloaded function is turned into a join point, we won't add + -- SCCs directly to calls since it makes them non-tail calls. Instead, + -- we look for join points here and add an SCC to their RHS if they are + -- overloaded. + wrap_if_join :: + CoreBndr + -> LateCCM OverloadedCallsCCState CoreExpr + -> LateCCM OverloadedCallsCCState CoreExpr + wrap_if_join _b pexpr = do + -- See Note [Overloaded Calls and join points] + expr <- pexpr + return expr + + processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr + processExpr expr = + case expr of + -- The case we care about: Application + app@App{} -> do + -- Here we have some application like `f v1 ... vN`, where v1 ... vN + -- should be the function's type arguments followed by the value + -- arguments. To determine if the `f` is an overloaded function, we + -- check if any of the arguments v1 ... vN are dictionaries. + let + (f, xs) = collectArgs app + resultTy = applyTypeToArgs (exprType f) xs + + -- Recursively process the arguments first for no particular reason + args <- mapM processExpr xs + let app' = mkCoreApps f args + + if + -- Check if any of the arguments are dictionaries + any isDictExpr args + + -- Avoid instrumenting dictionary functions, which may be + -- overloaded if there are superclasses, by checking if the result + -- type of the function is a dictionary type. + && not (isDictTy resultTy) + + -- Avoid instrumenting constraint selectors like eq_sel + && (typeTypeOrConstraint resultTy /= ConstraintLike) + + -- Avoid instrumenting join points. + -- (See comment in processBind above) + -- Also see Note [Overloaded Calls and join points] + && not (isJoinVarExpr f) + then do + -- Extract a name and source location from the function being + -- applied + let + cc_name :: FastString + cc_name = + maybe (fsLit "") getOccFS (exprName app) + + cc_srcspan <- + fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $ + lift $ gets lateCCState_extra + + insertCC cc_name cc_srcspan app' + else + return app' + + -- For recursive constructors of Expr, we traverse the nested Exprs + Lam b e -> + mkCoreLams [b] <$> processExpr e + Let b e -> + mkCoreLet <$> processBind b <*> processExpr e + Case e b t alts -> + Case + <$> processExpr e + <*> pure b + <*> pure t + <*> mapM processAlt alts + Cast e co -> + mkCast <$> processExpr e <*> pure co + Tick t e -> do + trackSourceNote t $ + mkTick t <$> processExpr e + + -- For non-recursive constructors of Expr, we do nothing + x -> return x + + processAlt :: CoreAlt -> LateCCM OverloadedCallsCCState CoreAlt + processAlt (Alt c bs e) = Alt c bs <$> processExpr e + + trackSourceNote :: CoreTickish -> LateCCM OverloadedCallsCCState a -> LateCCM OverloadedCallsCCState a + trackSourceNote tick act = + case tick of + SourceNote rss _ -> do + -- Prefer source notes from the current file + in_current_file <- + maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$> + asks lateCCEnv_file + if not in_current_file then + act + else do + loc <- lift $ gets lateCCState_extra + lift . modify $ \s -> + s { lateCCState_extra = + Strict.Just $ RealSrcSpan rss mempty + } + x <- act + lift . modify $ \s -> + s { lateCCState_extra = loc + } + return x + _ -> + act + + -- Utility functions + + -- Extract a Name from an expression. If it is an application, attempt to + -- extract a name from the applied function. If it is a variable, return the + -- Name of the variable. If it is a tick/cast, attempt to extract a Name + -- from the expression held in the tick/cast. Otherwise return Nothing. + exprName :: CoreExpr -> Maybe Name + exprName = + \case + App f _ -> + exprName f + Var f -> + Just (idName f) + Tick _ e -> + exprName e + Cast e _ -> + exprName e + _ -> + Nothing + + -- Determine whether an expression is a dictionary + isDictExpr :: CoreExpr -> Bool + isDictExpr = + maybe False isDictTy . exprType' + where + exprType' :: CoreExpr -> Maybe Type + exprType' = \case + Type{} -> Nothing + expr -> Just $ exprType expr + + -- Determine whether an expression is a join variable + isJoinVarExpr :: CoreExpr -> Bool + isJoinVarExpr = + \case + Var var -> isJoinId var + Tick _ e -> isJoinVarExpr e + Cast e _ -> isJoinVarExpr e + _ -> False diff --git a/GHC/Core/LateCC/TopLevelBinds.hs b/GHC/Core/LateCC/TopLevelBinds.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/TopLevelBinds.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TupleSections #-} +module GHC.Core.LateCC.TopLevelBinds where + +import GHC.Prelude + +import GHC.Core.LateCC.Types +import GHC.Core.LateCC.Utils + +import GHC.Core +import GHC.Core.Opt.Monad +import GHC.Driver.DynFlags +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module.ModGuts + +import Data.Maybe + +{- Note [Collecting late cost centres] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Usually cost centres defined by a module are collected +during tidy by collectCostCentres. However with `-fprof-late` +we insert cost centres after inlining. So we keep a list of +all the cost centres we inserted and combine that with the list +of cost centres found during tidy. + +To avoid overhead when using -fprof-inline there is a flag to stop +us from collecting them here when we run this pass before tidy. + +Note [Adding late cost centres to top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is very simple. For a top level binder +`f = rhs` we compile it as if the user had written +`f = {-# SCC f #-} rhs`. + +If we do this after unfoldings for `f` have been created this +doesn't impact core-level optimizations at all. If we do it +before the cost centre will be included in the unfolding and +might inhibit optimizations at the call site. For this reason +we provide flags for both approaches as they have different +tradeoffs. + +To reduce overhead we ignore workfree bindings because they don't contribute +meaningfully to a performance profile. This reduces code size massively as it +allows us to allocate definitions like `val = Just 32` at compile time instead +of turning them into a CAF of the form `val = let x = Just 32 in x` which +would be the alternative. + +We make an exception for rhss with function types. This allows us to get +cost centres on eta-reduced definitions like `f = g`. By putting a tick onto +`f`s rhs we end up with + + f = \eta1 eta2 ... etan -> + g eta1 ... etan + +Which can make it easier to understand call graphs of an application. + +We also don't add a cost centre for any binder that is a constructor +worker or wrapper. These will never meaningfully enrich the resulting +profile so we improve efficiency by omitting those. + +-} + +-- | Add late cost centres directly to the 'ModGuts'. This is used inside the +-- core pipeline with the -fprof-late-inline flag. It should not be used after +-- tidy, since it does not manually track inserted cost centers. See +-- Note [Collecting late cost centres]. +topLevelBindsCCMG :: ModGuts -> CoreM ModGuts +topLevelBindsCCMG guts = do + dflags <- getDynFlags + let + env = + LateCCEnv + { lateCCEnv_module = mg_module guts + + -- We don't use this for topLevelBindsCC, so Nothing is okay + , lateCCEnv_file = Nothing + + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = False + } + guts' = + guts + { mg_binds = + fst + ( doLateCostCenters + env + (initLateCCState ()) + (topLevelBindsCC (const True)) + (mg_binds guts) + ) + } + return guts' + +-- | Insert cost centres on top-level bindings in the module, depending on +-- whether or not they satisfy the given predicate. +topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind +topLevelBindsCC pred core_bind = + case core_bind of + NonRec b rhs -> + NonRec b <$> doBndr b rhs + Rec bs -> + Rec <$> mapM doPair bs + where + doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr)) + doPair (b,rhs) = (b,) <$> doBndr b rhs + + doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr + doBndr bndr rhs + -- Not a constructor worker. + -- Cost centres on constructor workers are pretty much useless so we don't emit them + -- if we are looking at the rhs of a constructor binding. + | isNothing (isDataConId_maybe bndr) + , pred rhs + = addCC bndr rhs + | otherwise = pure rhs + + -- We want to put the cost centre below the lambda as we only care about + -- executions of the RHS. Note that the lambdas might be hidden under ticks + -- or casts. So look through these as well. + addCC :: Id -> CoreExpr -> LateCCM s CoreExpr + addCC bndr (Cast rhs co) = pure Cast <*> addCC bndr rhs <*> pure co + addCC bndr (Tick t rhs) = (Tick t) <$> addCC bndr rhs + addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs + addCC bndr rhs = do + let name = idName bndr + cc_loc = nameSrcSpan name + cc_name = getOccFS name + insertCC cc_name cc_loc rhs diff --git a/GHC/Core/LateCC/Types.hs b/GHC/Core/LateCC/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/Types.hs @@ -0,0 +1,74 @@ +-- | Types related to late cost center insertion +module GHC.Core.LateCC.Types + ( LateCCConfig(..) + , LateCCBindSpec(..) + , LateCCEnv(..) + , LateCCState(..) + , initLateCCState + , LateCCM + ) where + +import GHC.Prelude + +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Unit.Types + +-- | Late cost center insertion configuration. +-- +-- Specifies whether cost centers are added to overloaded function call sites +-- and/or top-level bindings, and which top-level bindings they are added to. +-- Also holds the cost center insertion environment. +data LateCCConfig = + LateCCConfig + { lateCCConfig_whichBinds :: !LateCCBindSpec + , lateCCConfig_overloadedCalls :: !Bool + , lateCCConfig_env :: !LateCCEnv + } + +-- | The types of top-level bindings we support adding cost centers to. +data LateCCBindSpec = + LateCCNone + | LateCCBinds + | LateCCOverloadedBinds + +-- | Late cost centre insertion environment +data LateCCEnv = LateCCEnv + { lateCCEnv_module :: !Module + -- ^ Current module + , lateCCEnv_file :: Maybe FastString + -- ^ Current file, if we have one + , lateCCEnv_countEntries:: !Bool + -- ^ Whether the inserted cost centers should count entries + , lateCCEnv_collectCCs :: !Bool + -- ^ Whether to collect the cost centres we insert. See + -- Note [Collecting late cost centres] + + } + +-- | Late cost centre insertion state, indexed by some extra state type that an +-- insertion method may require. +data LateCCState s = LateCCState + { lateCCState_ccs :: !(S.Set CostCentre) + -- ^ Cost centres that have been inserted + , lateCCState_ccState :: !CostCentreState + -- ^ Per-module state tracking for cost centre indices + , lateCCState_extra :: !s + } + +-- | The empty late cost centre insertion state +initLateCCState :: s -> LateCCState s +initLateCCState s = + LateCCState + { lateCCState_ccState = newCostCentreState + , lateCCState_ccs = mempty + , lateCCState_extra = s + } + +-- | Late cost centre insertion monad +type LateCCM s = ReaderT LateCCEnv (State (LateCCState s)) diff --git a/GHC/Core/LateCC/Utils.hs b/GHC/Core/LateCC/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/LateCC/Utils.hs @@ -0,0 +1,80 @@ +module GHC.Core.LateCC.Utils + ( -- * Inserting cost centres + doLateCostCenters -- Might be useful for API users + + -- ** Helpers for defining insertion methods + , getCCFlavour + , insertCC + ) where + +import GHC.Prelude + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Data.Set as S + +import GHC.Core +import GHC.Core.LateCC.Types +import GHC.Core.Utils +import GHC.Data.FastString +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Types.SrcLoc +import GHC.Types.Tickish + +-- | Insert cost centres into the 'CoreProgram' using the provided environment, +-- initial state, and insertion method. +doLateCostCenters + :: LateCCEnv + -- ^ Environment to run the insertion in + -> LateCCState s + -- ^ Initial state to run the insertion with + -> (CoreBind -> LateCCM s CoreBind) + -- ^ Insertion method + -> CoreProgram + -- ^ Bindings to consider + -> (CoreProgram, LateCCState s) +doLateCostCenters env state method binds = + runLateCC env state $ mapM method binds + +-- | Evaluate late cost centre insertion +runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s) +runLateCC env state = (`runState` state) . (`runReaderT` env) + +-- | Given the name of a cost centre, get its flavour +getCCFlavour :: FastString -> LateCCM s CCFlavour +getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name + where + getCCIndex' :: FastString -> LateCCM s CostCentreIndex + getCCIndex' name = do + cc_state <- lift $ gets lateCCState_ccState + let (index, cc_state') = getCCIndex name cc_state + lift . modify $ \s -> s { lateCCState_ccState = cc_state'} + return index + +-- | Insert a cost centre with the specified name and source span on the given +-- expression. The inserted cost centre will be appropriately tracked in the +-- late cost centre state. +insertCC + :: FastString + -- ^ Name of the cost centre to insert + -> SrcSpan + -- ^ Source location to associate with the cost centre + -> CoreExpr + -- ^ Expression to wrap in the cost centre + -> LateCCM s CoreExpr +insertCC cc_name cc_loc expr = do + cc_flavour <- getCCFlavour cc_name + env <- ask + let + cc_mod = lateCCEnv_module env + cc = NormalCC cc_flavour cc_name cc_mod cc_loc + note = ProfNote cc (lateCCEnv_countEntries env) True + when (lateCCEnv_collectCCs env) $ do + lift . modify $ \s -> + s { lateCCState_ccs = S.insert cc (lateCCState_ccs s) + } + return $ mkTick note expr + diff --git a/GHC/Core/Lint.hs b/GHC/Core/Lint.hs --- a/GHC/Core/Lint.hs +++ b/GHC/Core/Lint.hs @@ -33,3617 +33,3916 @@ import GHC.Driver.DynFlags -import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) -import GHC.Unit.Module.ModGuts -import GHC.Platform - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.Stats ( coreBindsStats ) -import GHC.Core.DataCon -import GHC.Core.Ppr -import GHC.Core.Coercion -import GHC.Core.Type as Type -import GHC.Core.Multiplicity -import GHC.Core.UsageEnv -import GHC.Core.TyCo.Rep -- checks validity of types/coercions -import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr -import GHC.Core.TyCon as TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.FamInstEnv( compatibleBranches ) -import GHC.Core.Unify -import GHC.Core.Opt.Arity ( typeArity, exprIsDeadEnd ) - -import GHC.Core.Opt.Monad - -import GHC.Types.Literal -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.SrcLoc -import GHC.Types.Tickish -import GHC.Types.RepType -import GHC.Types.Basic -import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) - -import GHC.Builtin.Names -import GHC.Builtin.Types.Prim -import GHC.Builtin.Types ( multiplicityTy ) - -import GHC.Data.Bag -import GHC.Data.List.SetOps - -import GHC.Utils.Monad -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Misc -import GHC.Utils.Error -import qualified GHC.Utils.Error as Err -import GHC.Utils.Logger - -import Control.Monad -import Data.Foldable ( for_, toList ) -import Data.List.NonEmpty ( NonEmpty(..), groupWith ) -import Data.List ( partition ) -import Data.Maybe -import GHC.Data.Pair -import GHC.Base (oneShot) -import GHC.Data.Unboxed - -{- -Note [Core Lint guarantee] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Core Lint is the type-checker for Core. Using it, we get the following guarantee: - -If all of: -1. Core Lint passes, -2. there are no unsafe coercions (i.e. unsafeEqualityProof), -3. all plugin-supplied coercions (i.e. PluginProv) are valid, and -4. all case-matches are complete -then running the compiled program will not seg-fault, assuming no bugs downstream -(e.g. in the code generator). This guarantee is quite powerful, in that it allows us -to decouple the safety of the resulting program from the type inference algorithm. - -However, do note point (4) above. Core Lint does not check for incomplete case-matches; -see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, -an incomplete case-match might slip by Core Lint and cause trouble at runtime. - -Note [GHC Formalism] -~~~~~~~~~~~~~~~~~~~~ -This file implements the type-checking algorithm for System FC, the "official" -name of the Core language. Type safety of FC is heart of the claim that -executables produced by GHC do not have segmentation faults. Thus, it is -useful to be able to reason about System FC independently of reading the code. -To this purpose, there is a document core-spec.pdf built in docs/core-spec that -contains a formalism of the types and functions dealt with here. If you change -just about anything in this file or you change other types/functions throughout -the Core language (all signposted to this note), you should update that -formalism. See docs/core-spec/README for more info about how to do so. - -Note [check vs lint] -~~~~~~~~~~~~~~~~~~~~ -This file implements both a type checking algorithm and also general sanity -checking. For example, the "sanity checking" checks for TyConApp on the left -of an AppTy, which should never happen. These sanity checks don't really -affect any notion of type soundness. Yet, it is convenient to do the sanity -checks at the same time as the type checks. So, we use the following naming -convention: - -- Functions that begin with 'lint'... are involved in type checking. These - functions might also do some sanity checking. - -- Functions that begin with 'check'... are *not* involved in type checking. - They exist only for sanity checking. - -Issues surrounding variable naming, shadowing, and such are considered *not* -to be part of type checking, as the formalism omits these details. - -Summary of checks -~~~~~~~~~~~~~~~~~ -Checks that a set of core bindings is well-formed. The PprStyle and String -just control what we print in the event of an error. The Bool value -indicates whether we have done any specialisation yet (in which case we do -some extra checks). - -We check for - (a) type errors - (b) Out-of-scope type variables - (c) Out-of-scope local variables - (d) Ill-kinded types - (e) Incorrect unsafe coercions - -If we have done specialisation the we check that there are - (a) No top-level bindings of primitive (unboxed type) - -Note [Linting function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All saturated applications of funTyCon are represented with the FunTy constructor. -See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim - - We check this invariant in lintType. - -Note [Linting type lets] -~~~~~~~~~~~~~~~~~~~~~~~~ -In the desugarer, it's very very convenient to be able to say (in effect) - let a = Type Bool in - let x::a = True in -That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". -One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] -in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). - -* Hence when linting we need to remember that a=Int, else we - might reject a correct program. So we carry a type substitution (in - this example [a -> Bool]) and apply this substitution before - comparing types. In effect, in Lint, type equality is always - equality-modulo-le-subst. This is in the le_subst field of - LintEnv. But nota bene: - - (SI1) The le_subst substitution is applied to types and coercions only - - (SI2) The result of that substitution is used only to check for type - equality, to check well-typed-ness, /but is then discarded/. - The result of substitution does not outlive the CoreLint pass. - - (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. - -* The function - lintInTy :: Type -> LintM (Type, Kind) - returns a substituted type. - -* When we encounter a binder (like x::a) we must apply the substitution - to the type of the binding variable. lintBinders does this. - -* Clearly we need to clone tyvar binders as we go. - -* But take care (#17590)! We must also clone CoVar binders: - let a = TYPE (ty |> cv) - in \cv -> blah - blindly substituting for `a` might capture `cv`. - -* Alas, when cloning a coercion variable we might choose a unique - that happens to clash with an inner Id, thus - \cv_66 -> let wild_X7 = blah in blah - We decide to clone `cv_66` because it's already in scope. Fine, - choose a new unique. Aha, X7 looks good. So we check the lambda - body with le_subst of [cv_66 :-> cv_X7] - - This is all fine, even though we use the same unique as wild_X7. - As (SI2) says, we do /not/ return a new lambda - (\cv_X7 -> let wild_X7 = blah in ...) - We simply use the le_subst substitution in types/coercions only, when - checking for equality. - -* We still need to check that Id occurrences are bound by some - enclosing binding. We do /not/ use the InScopeSet for the le_subst - for this purpose -- it contains only TyCoVars. Instead we have a separate - le_ids for the in-scope Id binders. - -Sigh. We might want to explore getting rid of type-let! - -Note [Bad unsafe coercion] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions -Linter introduces additional rules that checks improper coercion between -different types, called bad coercions. Following coercions are forbidden: - - (a) coercions between boxed and unboxed values; - (b) coercions between unlifted values of the different sizes, here - active size is checked, i.e. size of the actual value but not - the space allocated for value; - (c) coercions between floating and integral boxed values, this check - is not yet supported for unboxed tuples, as no semantics were - specified for that; - (d) coercions from / to vector type - (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be - coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules - (a-e) holds. - -Note [Join points] -~~~~~~~~~~~~~~~~~~ -We check the rules listed in Note [Invariants on join points] in GHC.Core. The -only one that causes any difficulty is the first: All occurrences must be tail -calls. To this end, along with the in-scope set, we remember in le_joins the -subset of in-scope Ids that are valid join ids. For example: - - join j x = ... in - case e of - A -> jump j y -- good - B -> case (jump j z) of -- BAD - C -> join h = jump j w in ... -- good - D -> let x = jump j v in ... -- BAD - -A join point remains valid in case branches, so when checking the A -branch, j is still valid. When we check the scrutinee of the inner -case, however, we set le_joins to empty, and catch the -error. Similarly, join points can occur free in RHSes of other join -points but not the RHSes of value bindings (thunks and functions). - -Note [Avoiding compiler perf traps when constructing error messages.] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's quite common to put error messages into a where clause when it might -be triggered by multiple branches. E.g. - - checkThing x y z = - case x of - X -> unless (correctX x) $ failWithL errMsg - Y -> unless (correctY y) $ failWithL errMsg - where - errMsg = text "My error involving:" $$ ppr x <+> ppr y - -However ghc will compile this to: - - checkThink x y z = - let errMsg = text "My error involving:" $$ ppr x <+> ppr y - in case x of - X -> unless (correctX x) $ failWithL errMsg - Y -> unless (correctY y) $ failWithL errMsg - -Putting the allocation of errMsg into the common non-error path. -One way to work around this is to turn errMsg into a function: - - checkThink x y z = - case x of - X -> unless (correctX x) $ failWithL (errMsg x y) - Y -> unless (correctY y) $ failWithL (errMsg x y) - where - errMsg x y = text "My error involving:" $$ ppr x <+> ppr y - -This way `errMsg` is a static function and it being defined in the common -path does not result in allocation in the hot path. This can be surprisingly -impactful. Changing `lint_app` reduced allocations for one test program I was -looking at by ~4%. - -Note [MCInfo for Lint] -~~~~~~~~~~~~~~~~~~~~~~ -When printing a Lint message, use the MCInfo severity so that the -message is printed on stderr rather than stdout (#13342). - -************************************************************************ -* * - Beginning and ending passes -* * -************************************************************************ --} - --- | Configuration for boilerplate operations at the end of a --- compilation pass producing Core. -data EndPassConfig = EndPassConfig - { ep_dumpCoreSizes :: !Bool - -- ^ Whether core bindings should be dumped with the size of what they - -- are binding (i.e. the size of the RHS of the binding). - - , ep_lintPassResult :: !(Maybe LintPassResultConfig) - -- ^ Whether we should lint the result of this pass. - - , ep_namePprCtx :: !NamePprCtx - - , ep_dumpFlag :: !(Maybe DumpFlag) - - , ep_prettyPass :: !SDoc - - , ep_passDetails :: !SDoc - } - -endPassIO :: Logger - -> EndPassConfig - -> CoreProgram -> [CoreRule] - -> IO () --- Used by the IO-is CorePrep too -endPassIO logger cfg binds rules - = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag - (renderWithContext defaultSDocContext (ep_prettyPass cfg)) - (ep_passDetails cfg) binds rules - ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> - lintPassResult logger lp_cfg binds - } - where - mb_flag = case ep_dumpFlag cfg of - Just flag | logHasDumpFlag logger flag -> Just flag - | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag - _ -> Nothing - -dumpPassResult :: Logger - -> Bool -- dump core sizes? - -> NamePprCtx - -> Maybe DumpFlag -- Just df => show details in a file whose - -- name is specified by df - -> String -- Header - -> SDoc -- Extra info to appear after header - -> CoreProgram -> [CoreRule] - -> IO () -dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> do - logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc - - -- Report result size - -- This has the side effect of forcing the intermediate to be evaluated - -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg logger 2 size_doc - } - - where - size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] - - dump_doc = vcat [ nest 2 extra_info - , size_doc - , blankLine - , if dump_core_sizes - then pprCoreBindingsWithSize binds - else pprCoreBindings binds - , ppUnless (null rules) pp_rules ] - pp_rules = vcat [ blankLine - , text "------ Local rules for imported ids --------" - , pprRules rules ] - -{- -************************************************************************ -* * - Top-level interfaces -* * -************************************************************************ --} - -data LintPassResultConfig = LintPassResultConfig - { lpr_diagOpts :: !DiagOpts - , lpr_platform :: !Platform - , lpr_makeLintFlags :: !LintFlags - , lpr_showLintWarnings :: !Bool - , lpr_passPpr :: !SDoc - , lpr_localsInScope :: ![Var] - } - -lintPassResult :: Logger -> LintPassResultConfig - -> CoreProgram -> IO () -lintPassResult logger cfg binds - = do { let warns_and_errs = lintCoreBindings' - (LintConfig - { l_diagOpts = lpr_diagOpts cfg - , l_platform = lpr_platform cfg - , l_flags = lpr_makeLintFlags cfg - , l_vars = lpr_localsInScope cfg - }) - binds - ; Err.showPass logger $ - "Core Linted result of " ++ - renderWithContext defaultSDocContext (lpr_passPpr cfg) - ; displayLintResults logger - (lpr_showLintWarnings cfg) (lpr_passPpr cfg) - (pprCoreBindings binds) warns_and_errs - } - -displayLintResults :: Logger - -> Bool -- ^ If 'True', display linter warnings. - -- If 'False', ignore linter warnings. - -> SDoc -- ^ The source of the linted program - -> SDoc -- ^ The linted program, pretty-printed - -> WarnsAndErrs - -> IO () -displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) - | not (isEmptyBag errs) - = do { logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] - $ withPprStyle defaultDumpStyle - (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs - , text "*** Offending Program ***" - , pp_pgm - , text "*** End of Offense ***" ]) - ; Err.ghcExit logger 1 } - - | not (isEmptyBag warns) - , log_enable_debug (logFlags logger) - , display_warnings - = logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] - $ withPprStyle defaultDumpStyle - (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) - - | otherwise = return () - -lint_banner :: String -> SDoc -> SDoc -lint_banner string pass = text "*** Core Lint" <+> text string - <+> text ": in result of" <+> pass - <+> text "***" - --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs --- Returns (warnings, errors) --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreBindings' cfg binds - = initL cfg $ - addLoc TopLevelBindings $ - do { checkL (null dups) (dupVars dups) - ; checkL (null ext_dups) (dupExtVars ext_dups) - ; lintRecBindings TopLevel all_pairs $ \_ -> - return () } - where - all_pairs = flattenBinds binds - -- Put all the top-level binders in scope at the start - -- This is because rewrite rules can bring something - -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" - binders = map fst all_pairs - - (_, dups) = removeDups compare binders - - -- ext_dups checks for names with different uniques - -- but the same External name M.n. We don't - -- allow this at top level: - -- M.n{r3} = ... - -- M.n{r29} = ... - -- because they both get the same linker symbol - ext_dups = snd $ removeDupsOn ord_ext $ - filter isExternalName $ map Var.varName binders - ord_ext n = (nameModule n, nameOccName n) - -{- -************************************************************************ -* * -\subsection[lintUnfolding]{lintUnfolding} -* * -************************************************************************ - -Note [Linting Unfoldings from Interfaces] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use this to check all top-level unfoldings that come in from interfaces -(it is very painful to catch errors otherwise). - -We do not need to call lintUnfolding on unfoldings that are nested within -top-level unfoldings; they are linted when we lint the top-level unfolding; -hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. - --} - -lintUnfolding :: Bool -- ^ True <=> is a compulsory unfolding - -> LintConfig - -> SrcLoc - -> CoreExpr - -> Maybe (Bag SDoc) -- Nothing => OK - -lintUnfolding is_compulsory cfg locn expr - | isEmptyBag errs = Nothing - | otherwise = Just errs - where - (_warns, errs) = initL cfg $ - if is_compulsory - -- See Note [Checking for representation polymorphism] - then noFixedRuntimeRepChecks linter - else linter - linter = addLoc (ImportedUnfolding locn) $ - lintCoreExpr expr - -lintExpr :: LintConfig - -> CoreExpr - -> Maybe (Bag SDoc) -- Nothing => OK - -lintExpr cfg expr - | isEmptyBag errs = Nothing - | otherwise = Just errs - where - (_warns, errs) = initL cfg linter - linter = addLoc TopLevelBindings $ - lintCoreExpr expr - -{- -************************************************************************ -* * -\subsection[lintCoreBinding]{lintCoreBinding} -* * -************************************************************************ - -Check a core binding, returning the list of variables bound. --} - --- Returns a UsageEnv because this function is called in lintCoreExpr for --- Let - -lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] - -> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv]) -lintRecBindings top_lvl pairs thing_inside - = lintIdBndrs top_lvl bndrs $ \ bndrs' -> - do { ues <- zipWithM lint_pair bndrs' rhss - ; a <- thing_inside bndrs' - ; return (a, ues) } - where - (bndrs, rhss) = unzip pairs - lint_pair bndr' rhs - = addLoc (RhsOf bndr') $ - do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs - ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty - ; return ue } - -lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv) -lintLetBody bndrs body - = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) - ; mapM_ (lintJoinBndrType body_ty) bndrs - ; return (body_ty, body_ue) } - -lintLetBind :: TopLevelFlag -> RecFlag -> LintedId - -> CoreExpr -> LintedType -> LintM () --- Binder's type, and the RHS, have already been linted --- This function checks other invariants -lintLetBind top_lvl rec_flag binder rhs rhs_ty - = do { let binder_ty = idType binder - ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) - - -- If the binding is for a CoVar, the RHS should be (Coercion co) - -- See Note [Core type and coercion invariant] in GHC.Core - ; checkL (not (isCoVar binder) || isCoArg rhs) - (mkLetErr binder rhs) - - -- Check the let-can-float invariant - -- See Note [Core let-can-float invariant] in GHC.Core - ; checkL ( isJoinId binder - || mightBeLiftedType binder_ty - || (isNonRec rec_flag && exprOkForSpeculation rhs) - || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed - || exprIsTickedString rhs) - (badBndrTyMsg binder (text "unlifted")) - - -- Check that if the binder is at the top level and has type Addr#, - -- that it is a string literal. - -- See Note [Core top-level string literals]. - ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) - || exprIsTickedString rhs) - (mkTopNonLitStrMsg binder) - - ; flags <- getLintFlags - - -- Check that a join-point binder has a valid type - -- NB: lintIdBinder has checked that it is not top-level bound - ; case isJoinId_maybe binder of - Nothing -> return () - Just arity -> checkL (isValidJoinPointType arity binder_ty) - (mkInvalidJoinPointMsg binder binder_ty) - - ; when (lf_check_inline_loop_breakers flags - && isStableUnfolding (realIdUnfolding binder) - && isStrongLoopBreaker (idOccInfo binder) - && isInlinePragma (idInlinePragma binder)) - (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) - -- Only non-rule loop breakers inhibit inlining - - -- We used to check that the dmdTypeDepth of a demand signature never - -- exceeds idArity, but that is an unnecessary complication, see - -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal - - -- Check that the binder's arity is within the bounds imposed by the type - -- and the strictness signature. See Note [Arity invariants for bindings] - -- and Note [Trimming arity] - - ; checkL (typeArity (idType binder) >= idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds typeArity" <+> - ppr (typeArity (idType binder)) <> colon <+> - ppr binder) - - -- See Note [idArity varies independently of dmdTypeDepth] - -- in GHC.Core.Opt.DmdAnal - ; case splitDmdSig (idDmdSig binder) of - (demands, result_info) | isDeadEndDiv result_info -> - checkL (demands `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds arity imposed by the strictness signature" <+> - ppr (idDmdSig binder) <> colon <+> - ppr binder) - - _ -> return () - - ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) - - ; addLoc (UnfoldingOf binder) $ - lintIdUnfolding binder binder_ty (idUnfolding binder) - ; return () } - - -- We should check the unfolding, if any, but this is tricky because - -- the unfolding is a SimplifiableCoreExpr. Give up for now. - --- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' --- in that it doesn't reject occurrences of the function 'makeStatic' when they --- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and --- for join points, it skips the outer lambdas that take arguments to the --- join point. --- --- See Note [Checking StaticPtrs]. -lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv) --- NB: the Id can be Linted or not -- it's only used for --- its OccInfo and join-pointer-hood -lintRhs bndr rhs - | Just arity <- isJoinId_maybe bndr - = lintJoinLams arity (Just bndr) rhs - | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = lintJoinLams arity Nothing rhs - --- Allow applications of the data constructor @StaticPtr@ at the top --- but produce errors otherwise. -lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go - where - -- Allow occurrences of 'makeStatic' at the top-level but produce errors - -- otherwise. - go :: StaticPtrCheck -> LintM (OutType, UsageEnv) - go AllowAtTopLevel - | (binders0, rhs') <- collectTyBinders rhs - , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' - = markAllJoinsBad $ - foldr - -- imitate @lintCoreExpr (Lam ...)@ - lintLambda - -- imitate @lintCoreExpr (App ...)@ - (do fun_ty_ue <- lintCoreExpr fun - lintCoreArgs fun_ty_ue [Type t, info, e] - ) - binders0 - go _ = markAllJoinsBad $ lintCoreExpr rhs - --- | Lint the RHS of a join point with expected join arity of @n@ (see Note --- [Join points] in "GHC.Core"). -lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (LintedType, UsageEnv) -lintJoinLams join_arity enforce rhs - = go join_arity rhs - where - go 0 expr = lintCoreExpr expr - go n (Lam var body) = lintLambda var $ go (n-1) body - go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas - = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs - | otherwise -- Future join point, not yet eta-expanded - = markAllJoinsBad $ lintCoreExpr expr - -- Body of lambda is not a tail position - -lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () -lintIdUnfolding bndr bndr_ty uf - | isStableUnfolding uf - , Just rhs <- maybeUnfoldingTemplate uf - = do { ty <- fst <$> (if isCompulsoryUnfolding uf - then noFixedRuntimeRepChecks $ lintRhs bndr rhs - -- ^^^^^^^^^^^^^^^^^^^^^^^ - -- See Note [Checking for representation polymorphism] - else lintRhs bndr rhs) - ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } -lintIdUnfolding _ _ _ - = return () -- Do not Lint unstable unfoldings, because that leads - -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars - -{- Note [Checking for INLINE loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very suspicious if a strong loop breaker is marked INLINE. - -However, the desugarer generates instance methods with INLINE pragmas -that form a mutually recursive group. Only after a round of -simplification are they unravelled. So we suppress the test for -the desugarer. Here is an example: - instance Eq T where - t1 == t2 = blah - t1 /= t2 = not (t1 == t2) - {-# INLINE (/=) #-} - -This will generate something like - -- From the class decl for Eq - data Eq a = EqDict (a->a->Bool) (a->a->Bool) - eq_sel :: Eq a -> (a->a->Bool) - eq_sel (EqDict eq _) = eq - - -- From the instance Eq T - $ceq :: T -> T -> Bool - $ceq = blah - - Rec { $dfEqT :: Eq T {-# DFunId #-} - $dfEqT = EqDict $ceq $cnoteq - - $cnoteq :: T -> T -> Bool {-# INLINE #-} - $cnoteq x y = not (eq_sel $dfEqT x y) } - -Notice that - -* `$dfEqT` and `$cnotEq` are mutually recursive. - -* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and - we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun - selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop - breaker. - -So we make `$cnoteq` into the loop breaker. That means it can't -inline, despite the INLINE pragma. That's what gives rise to the -warning, which is perfectly appropriate for, say - Rec { {-# INLINE f #-} f = \x -> ...f.... } -We can't inline a recursive function -- it's a loop breaker. - -But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get - Rec { - $dfEqT :: Eq T {-# DFunId #-} - $dfEqT = EqDict $ceq $cnoteq - - $cnoteq :: T -> T -> Bool {-# INLINE #-} - $cnoteq x y = not ($ceq x y) } - -and now the dependencies of the Rec have gone, and we can split it up to give - NonRec { $dfEqT :: Eq T {-# DFunId #-} - $dfEqT = EqDict $ceq $cnoteq } - - NonRec { $cnoteq :: T -> T -> Bool {-# INLINE #-} - $cnoteq x y = not ($ceq x y) } - -Now $cnoteq is not a loop breaker any more, so the INLINE pragma can -take effect -- the warning turned out to be temporary. - -To stop excessive warnings, this warning for INLINE loop breakers is -switched off when linting the result of the desugarer. See -lf_check_inline_loop_breakers in GHC.Core.Lint. - - -Note [Checking for representation polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We ordinarily want to check for bad representation polymorphism. See -Note [Representation polymorphism invariants] in GHC.Core. However, we do *not* -want to do this in a compulsory unfolding. Compulsory unfoldings arise -only internally, for things like newtype wrappers, dictionaries, and -(notably) unsafeCoerce#. These might legitimately be representation-polymorphic; -indeed representation-polymorphic unfoldings are a primary reason for the -very existence of compulsory unfoldings (we can't compile code for -the original, representation-polymorphic, binding). - -It is vitally important that we do representation polymorphism checks *after* -performing the unfolding, but not beforehand. This is all safe because -we will check any unfolding after it has been unfolded; checking the -unfolding beforehand is merely an optimization, and one that actively -hurts us here. - -Note [Linting of runRW#] -~~~~~~~~~~~~~~~~~~~~~~~~ -runRW# has some very special behavior (see Note [runRW magic] in -GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing -join points in its argument. For example, this is fine: - - join j x = ... - in runRW# (\s. case v of - A -> j 3 - B -> j 4) - -Usually those calls to the join point 'j' would not be valid tail calls, -because they occur in a function argument. But in the case of runRW# -they are fine, because runRW# (\s.e) behaves operationally just like e. -(runRW# is ultimately inlined in GHC.CoreToStg.Prep.) - -In the case that the continuation is /not/ a lambda we simply disable this -special behaviour. For example, this is /not/ fine: - - join j = ... - in runRW# @r @ty (jump j) - - - -************************************************************************ -* * -\subsection[lintCoreExpr]{lintCoreExpr} -* * -************************************************************************ --} - --- Linted things: substitution applied, and type is linted -type LintedType = Type -type LintedKind = Kind -type LintedCoercion = Coercion -type LintedTyCoVar = TyCoVar -type LintedId = Id - --- | Lint an expression cast through the given coercion, returning the type --- resulting from the cast. -lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType -lintCastExpr expr expr_ty co - = do { co' <- lintCoercion co - ; let (Pair from_ty to_ty, role) = coercionKindRole co' - ; checkValueType to_ty $ - text "target of cast" <+> quotes (ppr co') - ; lintRole co' Representational role - ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) - ; return to_ty } - -lintCoreExpr :: CoreExpr -> LintM (LintedType, UsageEnv) --- The returned type has the substitution from the monad --- already applied to it: --- lintCoreExpr e subst = exprType (subst e) --- --- The returned "type" can be a kind, if the expression is (Type ty) - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] - -lintCoreExpr (Var var) - = do - var_pair@(var_ty, _) <- lintIdOcc var 0 - checkCanEtaExpand (Var var) [] var_ty - return var_pair - -lintCoreExpr (Lit lit) - = return (literalType lit, zeroUE) - -lintCoreExpr (Cast expr co) - = do (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) - -- markAllJoinsBad: see Note [Join points and casts] - to_ty <- lintCastExpr expr expr_ty co - return (to_ty, ue) - -lintCoreExpr (Tick tickish expr) - = do case tickish of - Breakpoint _ _ ids -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () - markAllJoinsBadIf block_joins $ lintCoreExpr expr - where - block_joins = not (tickish `tickishScopesLike` SoftScope) - -- TODO Consider whether this is the correct rule. It is consistent with - -- the simplifier's behaviour - cost-centre-scoped ticks become part of - -- the continuation, and thus they behave like part of an evaluation - -- context, but soft-scoped and non-scoped ticks simply wrap the result - -- (see Simplify.simplTick). - -lintCoreExpr (Let (NonRec tv (Type ty)) body) - | isTyVar tv - = -- See Note [Linting type lets] - do { ty' <- lintType ty - ; lintTyBndr tv $ \ tv' -> - do { addLoc (RhsOf tv) $ lintTyKind tv' ty' - -- Now extend the substitution so we - -- take advantage of it in the body - ; extendTvSubstL tv ty' $ - addLoc (BodyOfLetRec [tv]) $ - lintCoreExpr body } } - -lintCoreExpr (Let (NonRec bndr rhs) body) - | isId bndr - = do { -- First Lint the RHS, before bringing the binder into scope - (rhs_ty, let_ue) <- lintRhs bndr rhs - - -- See Note [Multiplicity of let binders] in Var - -- Now lint the binder - ; lintBinder LetBind bndr $ \bndr' -> - do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty - ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } } - - | otherwise - = failWithL (mkLetErr bndr rhs) -- Not quite accurate - -lintCoreExpr e@(Let (Rec pairs) body) - = do { -- Check that the list of pairs is non-empty - checkL (not (null pairs)) (emptyRec e) - - -- Check that there are no duplicated binders - ; let (_, dups) = removeDups compare bndrs - ; checkL (null dups) (dupVars dups) - - -- Check that either all the binders are joins, or none - ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ - mkInconsistentRecMsg bndrs - - -- See Note [Multiplicity of let binders] in Var - ; ((body_type, body_ue), ues) <- - lintRecBindings NotTopLevel pairs $ \ bndrs' -> - lintLetBody bndrs' body - ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1 addUE ues)) } - where - bndrs = map fst pairs - -lintCoreExpr e@(App _ _) - | Var fun <- fun - , fun `hasKey` runRWKey - -- N.B. we may have an over-saturated application of the form: - -- runRW (\s -> \x -> ...) y - , ty_arg1 : ty_arg2 : arg3 : rest <- args - = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1 - ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 - -- See Note [Linting of runRW#] - ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) - lintRunRWCont expr@(Lam _ _) = - lintJoinLams 1 (Just fun) expr - lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other - -- TODO: Look through ticks? - ; (arg3_ty, ue3) <- lintRunRWCont arg3 - ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3 - ; lintCoreArgs app_ty rest } - - | otherwise - = do { fun_pair <- lintCoreFun fun (length args) - ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args - ; checkCanEtaExpand fun args app_ty - ; return app_pair} - where - skipTick t = case collectFunSimple e of - (Var v) -> etaExpansionTick v t - _ -> tickishFloatable t - (fun, args, _source_ticks) = collectArgsTicks skipTick e - -- We must look through source ticks to avoid #21152, for example: - -- - -- reallyUnsafePtrEquality - -- = \ @a -> - -- (src reallyUnsafePtrEquality#) - -- @Lifted @a @Lifted @a - -- - -- To do this, we use `collectArgsTicks tickishFloatable` to match - -- the eta expansion behaviour, as per Note [Eta expansion and source notes] - -- in GHC.Core.Opt.Arity. - -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. - -- See Note [Ticks and mandatory eta expansion] - -lintCoreExpr (Lam var expr) - = markAllJoinsBad $ - lintLambda var $ lintCoreExpr expr - -lintCoreExpr (Case scrut var alt_ty alts) - = lintCaseExpr scrut var alt_ty alts - --- This case can't happen; linting types in expressions gets routed through --- lintCoreArgs -lintCoreExpr (Type ty) - = failWithL (text "Type found as expression" <+> ppr ty) - -lintCoreExpr (Coercion co) - = do { co' <- addLoc (InCo co) $ - lintCoercion co - ; return (coercionType co', zeroUE) } - ----------------------- -lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed - -> LintM (LintedType, UsageEnv) -- returns type of the *variable* -lintIdOcc var nargs - = addLoc (OccOf var) $ - do { checkL (isNonCoVarId var) - (text "Non term variable" <+> ppr var) - -- See GHC.Core Note [Variable occurrences in Core] - - -- Check that the type of the occurrence is the same - -- as the type of the binding site. The inScopeIds are - -- /un-substituted/, so this checks that the occurrence type - -- is identical to the binder type. - -- This makes things much easier for things like: - -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... - -- The "::Maybe a" on the occurrence is referring to the /outer/ a. - -- If we compared /substituted/ types we'd risk comparing - -- (Maybe a) from the binding site with bogus (Maybe a1) from - -- the occurrence site. Comparing un-substituted types finesses - -- this altogether - ; (bndr, linted_bndr_ty) <- lookupIdInScope var - ; let occ_ty = idType var - bndr_ty = idType bndr - ; ensureEqTys occ_ty bndr_ty $ - mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_ty - - -- Check for a nested occurrence of the StaticPtr constructor. - -- See Note [Checking StaticPtrs]. - ; lf <- getLintFlags - ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ - checkL (idName var /= makeStaticName) $ - text "Found makeStatic nested in an expression" - - ; checkDeadIdOcc var - ; checkJoinOcc var nargs - ; case isDataConId_maybe var of - Nothing -> return () - Just dc -> checkTypeDataConOcc "expression" dc - - ; usage <- varCallSiteUsage var - - ; return (linted_bndr_ty, usage) } - -lintCoreFun :: CoreExpr - -> Int -- Number of arguments (type or val) being passed - -> LintM (LintedType, UsageEnv) -- Returns type of the *function* -lintCoreFun (Var var) nargs - = lintIdOcc var nargs - -lintCoreFun (Lam var body) nargs - -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; - -- See Note [Beta redexes] - | nargs /= 0 - = lintLambda var $ lintCoreFun body (nargs - 1) - -lintCoreFun expr nargs - = markAllJoinsBadIf (nargs /= 0) $ - -- See Note [Join points are less general than the paper] - lintCoreExpr expr ------------------- -lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) -lintLambda var lintBody = - addLoc (LambdaBodyOf var) $ - lintBinder LambdaBind var $ \ var' -> - do { (body_ty, ue) <- lintBody - ; ue' <- checkLinearity ue var' - ; return (mkLamType var' body_ty, ue') } ------------------- -checkDeadIdOcc :: Id -> LintM () --- Occurrences of an Id should never be dead.... --- except when we are checking a case pattern -checkDeadIdOcc id - | isDeadOcc (idOccInfo id) - = do { in_case <- inCasePat - ; checkL in_case - (text "Occurrence of a dead Id" <+> ppr id) } - | otherwise - = return () - ------------------- -lintJoinBndrType :: LintedType -- Type of the body - -> LintedId -- Possibly a join Id - -> LintM () --- Checks that the return type of a join Id matches the body --- E.g. join j x = rhs in body --- The type of 'rhs' must be the same as the type of 'body' -lintJoinBndrType body_ty bndr - | Just arity <- isJoinId_maybe bndr - , let bndr_ty = idType bndr - , (bndrs, res) <- splitPiTys bndr_ty - = checkL (length bndrs >= arity - && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ - hang (text "Join point returns different type than body") - 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) - , text "Join arity:" <+> ppr arity - , text "Body type:" <+> ppr body_ty ]) - | otherwise - = return () - -checkJoinOcc :: Id -> JoinArity -> LintM () --- Check that if the occurrence is a JoinId, then so is the --- binding site, and it's a valid join Id -checkJoinOcc var n_args - | Just join_arity_occ <- isJoinId_maybe var - = do { mb_join_arity_bndr <- lookupJoinId var - ; case mb_join_arity_bndr of { - Nothing -> -- Binder is not a join point - do { join_set <- getValidJoins - ; addErrL (text "join set " <+> ppr join_set $$ - invalidJoinOcc var) } ; - - Just join_arity_bndr -> - - do { checkL (join_arity_bndr == join_arity_occ) $ - -- Arity differs at binding site and occurrence - mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ - - ; checkL (n_args == join_arity_occ) $ - -- Arity doesn't match #args - mkBadJumpMsg var join_arity_occ n_args } } } - - | otherwise - = return () - -checkTypeDataConOcc :: String -> DataCon -> LintM () --- Check that the Id is not a data constructor of a `type data` declaration --- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module -checkTypeDataConOcc what dc - = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $ - (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) - --- | This function checks that we are able to perform eta expansion for --- functions with no binding, in order to satisfy invariant I3 --- from Note [Representation polymorphism invariants] in GHC.Core. -checkCanEtaExpand :: CoreExpr -- ^ the function (head of the application) we are checking - -> [CoreArg] -- ^ the arguments to the application - -> LintedType -- ^ the instantiated type of the overall application - -> LintM () -checkCanEtaExpand (Var fun_id) args app_ty - = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags - ; when (do_rep_poly_checks && hasNoBinding fun_id) $ - checkL (null bad_arg_tys) err_msg } - where - arity :: Arity - arity = idArity fun_id - - nb_val_args :: Int - nb_val_args = count isValArg args - - -- Check the remaining argument types, past the - -- given arguments and up to the arity of the 'Id'. - -- Returns the types that couldn't be determined to have - -- a fixed RuntimeRep. - check_args :: [Type] -> [Type] - check_args = go (nb_val_args + 1) - where - go :: Int -- index of the argument (starting from 1) - -> [Type] -- arguments - -> [Type] -- value argument types that could not be - -- determined to have a fixed runtime representation - go i _ - | i > arity - = [] - go _ [] - -- The Arity of an Id should never exceed the number of value arguments - -- that can be read off from the Id's type. - -- See Note [Arity and function types] in GHC.Types.Id.Info. - = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type" - $ vcat - [ text "fun_id =" <+> ppr fun_id - , text "arity =" <+> ppr arity - , text "app_ty =" <+> ppr app_ty - , text "args = " <+> ppr args - , text "nb_val_args =" <+> ppr nb_val_args ] - go i (ty : bndrs) - | typeHasFixedRuntimeRep ty - = go (i+1) bndrs - | otherwise - = ty : go (i+1) bndrs - - bad_arg_tys :: [Type] - bad_arg_tys = check_args . map (scaledThing . fst) $ getRuntimeArgTys app_ty - -- We use 'getRuntimeArgTys' to find all the argument types, - -- including those hidden under newtypes. For example, - -- if `FunNT a b` is a newtype around `a -> b`, then - -- when checking - -- - -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c - -- - -- we should check that the instantiations of BOTH `a` AND `b` - -- have a fixed runtime representation. - - err_msg :: SDoc - err_msg - = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id) - , text "The following type" <> plural bad_arg_tys - <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:" - , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ] - - ppr_ty_ki :: Type -> SDoc - ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty) -checkCanEtaExpand _ _ _ - = return () - --- Check that the usage of var is consistent with var itself, and pop the var --- from the usage environment (this is important because of shadowing). -checkLinearity :: UsageEnv -> Var -> LintM UsageEnv -checkLinearity body_ue lam_var = - case varMultMaybe lam_var of - Just mult -> do - let (lhs, body_ue') = popUE body_ue lam_var - err_msg = text "Linearity failure in lambda:" <+> ppr lam_var - $$ ppr lhs <+> text "⊈" <+> ppr mult - ensureSubUsage lhs mult err_msg - return body_ue' - Nothing -> return body_ue -- A type variable - -{- Note [Join points and casts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that this should be OK: - join j x = rhs - in (case e of - A -> alt1 - B x -> (jump j x) |> co) - -You might think that, since the cast is ultimately erased, the jump to -`j` should still be OK as a join point. But no! See #21716. Suppose - - newtype Age = MkAge Int -- axAge :: Age ~ Int - f :: Int -> ... -- f strict in it's first argument - -and consider the expression - - f (join j :: Bool -> Age - j x = (rhs1 :: Age) - in case v of - Just x -> (j x |> axAge :: Int) - Nothing -> rhs2) - -Then, if the Simplifier pushes the strict call into the join points -and alternatives we'll get - - join j' x = f (rhs1 :: Age) - in case v of - Just x -> j' x |> axAge - Nothing -> f rhs2 - -Utterly bogus. `f` expects an `Int` and we are giving it an `Age`. -No no no. Casts destroy the tail-call property. Henc markAllJoinsBad -in the (Cast expr co) case of lintCoreExpr. - -Note [No alternatives lint check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case expressions with no alternatives are odd beasts, and it would seem -like they would worth be looking at in the linter (cf #10180). We -used to check two things: - -* exprIsHNF is false: it would *seem* to be terribly wrong if - the scrutinee was already in head normal form. - -* exprIsDeadEnd is true: we should be able to see why GHC believes the - scrutinee is diverging for sure. - -It was already known that the second test was not entirely reliable. -Unfortunately (#13990), the first test turned out not to be reliable -either. Getting the checks right turns out to be somewhat complicated. - -For example, suppose we have (comment 8) - - data T a where - TInt :: T Int - - absurdTBool :: T Bool -> a - absurdTBool v = case v of - - data Foo = Foo !(T Bool) - - absurdFoo :: Foo -> a - absurdFoo (Foo x) = absurdTBool x - -GHC initially accepts the empty case because of the GADT conditions. But then -we inline absurdTBool, getting - - absurdFoo (Foo x) = case x of - -x is in normal form (because the Foo constructor is strict) but the -case is empty. To avoid this problem, GHC would have to recognize -that matching on Foo x is already absurd, which is not so easy. - -More generally, we don't really know all the ways that GHC can -lose track of why an expression is bottom, so we shouldn't make too -much fuss when that happens. - - -Note [Beta redexes] -~~~~~~~~~~~~~~~~~~~ -Consider: - - join j @x y z = ... in - (\@x y z -> jump j @x y z) @t e1 e2 - -This is clearly ill-typed, since the jump is inside both an application and a -lambda, either of which is enough to disqualify it as a tail call (see Note -[Invariants on join points] in GHC.Core). However, strictly from a -lambda-calculus perspective, the term doesn't go wrong---after the two beta -reductions, the jump *is* a tail call and everything is fine. - -Why would we want to allow this when we have let? One reason is that a compound -beta redex (that is, one with more than one argument) has different scoping -rules: naively reducing the above example using lets will capture any free -occurrence of y in e2. More fundamentally, type lets are tricky; many passes, -such as Float Out, tacitly assume that the incoming program's type lets have -all been dealt with by the simplifier. Thus we don't want to let-bind any types -in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately -before Float Out. - -All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this -loophole, doing so to avoid re-traversing large functions (beta-reducing a type -lambda without introducing a type let requires a substitution). TODO: Improve -simpleOptPgm so that we can forget all this ever happened. - -************************************************************************ -* * -\subsection[lintCoreArgs]{lintCoreArgs} -* * -************************************************************************ - -The basic version of these functions checks that the argument is a -subtype of the required type, as one would expect. --} - --- Takes the functions type and arguments as argument. --- Returns the *result* of applying the function to arguments. --- e.g. f :: Int -> Bool -> Int would return `Int` as result type. -lintCoreArgs :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv) -lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args - -lintCoreArg :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv) -lintCoreArg (fun_ty, ue) (Type arg_ty) - = do { checkL (not (isCoercionTy arg_ty)) - (text "Unnecessary coercion-to-type injection:" - <+> ppr arg_ty) - ; arg_ty' <- lintType arg_ty - ; res <- lintTyApp fun_ty arg_ty' - ; return (res, ue) } - -lintCoreArg (fun_ty, fun_ue) arg - = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg - -- See Note [Representation polymorphism invariants] in GHC.Core - ; flags <- getLintFlags - - ; when (lf_check_fixed_rep flags) $ - -- Only check that 'arg_ty' has a fixed RuntimeRep - -- if 'lf_check_fixed_rep' is on. - do { checkL (typeHasFixedRuntimeRep arg_ty) - (text "Argument does not have a fixed runtime representation" - <+> ppr arg <+> dcolon - <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) } - - ; lintValApp arg fun_ty arg_ty fun_ue arg_ue } - ------------------ -lintAltBinders :: UsageEnv - -> Var -- Case binder - -> LintedType -- Scrutinee type - -> LintedType -- Constructor type - -> [(Mult, OutVar)] -- Binders - -> LintM UsageEnv --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] - = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) - ; return rhs_ue } -lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) - | isTyVar bndr - = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) - ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } - | otherwise - = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE - -- We can pass zeroUE to lintValApp because we ignore its usage - -- calculation and compute it in the call for checkCaseLinearity below. - ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr - ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } - --- | Implements the case rules for linearity -checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv -checkCaseLinearity ue case_bndr var_w bndr = do - ensureSubUsage lhs rhs err_msg - lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (varMult bndr) - return $ deleteUE ue bndr - where - lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) - rhs = case_bndr_w `mkMultMul` var_w - err_msg = (text "Linearity failure in variable:" <+> ppr bndr - $$ ppr lhs <+> text "⊈" <+> ppr rhs - $$ text "Computed by:" - <+> text "LHS:" <+> lhs_formula - <+> text "RHS:" <+> rhs_formula) - lhs_formula = ppr bndr_usage <+> text "+" - <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) - rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w - case_bndr_w = varMult case_bndr - case_bndr_usage = lookupUE ue case_bndr - bndr_usage = lookupUE ue bndr - - - ------------------ -lintTyApp :: LintedType -> LintedType -> LintM LintedType -lintTyApp fun_ty arg_ty - | Just (tv,body_ty) <- splitForAllTyCoVar_maybe fun_ty - = do { lintTyKind tv arg_ty - ; in_scope <- getInScope - -- substTy needs the set of tyvars in scope to avoid generating - -- uniques that are already in scope. - -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst - ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } - - | otherwise - = failWithL (mkTyAppMsg fun_ty arg_ty) - ------------------ - --- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ --- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the --- application. -lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv) -lintValApp arg fun_ty arg_ty fun_ue arg_ue - | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty - = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) - ; let app_ue = addUE fun_ue (scaleUE w arg_ue) - ; return (res_ty', app_ue) } - | otherwise - = failWithL err2 - where - err2 = mkNonFunAppMsg fun_ty arg_ty arg - -lintTyKind :: OutTyVar -> LintedType -> LintM () --- Both args have had substitution applied - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintTyKind tyvar arg_ty - = unless (arg_kind `eqType` tyvar_kind) $ - addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) - where - tyvar_kind = tyVarKind tyvar - arg_kind = typeKind arg_ty - -{- -************************************************************************ -* * -\subsection[lintCoreAlts]{lintCoreAlts} -* * -************************************************************************ --} - -lintCaseExpr :: CoreExpr -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv) -lintCaseExpr scrut var alt_ty alts = - do { let e = Case scrut var alt_ty alts -- Just for error messages - - -- Check the scrutinee - ; (scrut_ty, scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut - -- See Note [Join points are less general than the paper] - -- in GHC.Core - ; let scrut_mult = varMult var - - ; alt_ty <- addLoc (CaseTy scrut) $ - lintValueType alt_ty - ; var_ty <- addLoc (IdTy var) $ - lintValueType (idType var) - - -- We used to try to check whether a case expression with no - -- alternatives was legitimate, but this didn't work. - -- See Note [No alternatives lint check] for details. - - -- Check that the scrutinee is not a floating-point type - -- if there are any literal alternatives - -- See GHC.Core Note [Case expression invariants] item (5) - -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold - ; let isLitPat (Alt (LitAlt _) _ _) = True - isLitPat _ = False - ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts) - (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." - $$ text "scrut" <+> ppr scrut) - - ; case tyConAppTyCon_maybe (idType var) of - Just tycon - | debugIsOn - , isAlgTyCon tycon - , not (isAbstractTyCon tycon) - , null (tyConDataCons tycon) - , not (exprIsDeadEnd scrut) - -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var)) - -- This can legitimately happen for type families - $ return () - _otherwise -> return () - - -- Don't use lintIdBndr on var, because unboxed tuple is legitimate - - ; subst <- getSubst - ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst) - -- See GHC.Core Note [Case expression invariants] item (7) - - ; lintBinder CaseBind var $ \_ -> - do { -- Check the alternatives - ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts - ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues - ; checkCaseAlts e scrut_ty alts - ; return (alt_ty, case_ue) } } - -checkCaseAlts :: CoreExpr -> LintedType -> [CoreAlt] -> LintM () --- a) Check that the alts are non-empty --- b1) Check that the DEFAULT comes first, if it exists --- b2) Check that the others are in increasing order --- c) Check that there's a default for infinite types --- NB: Algebraic cases are not necessarily exhaustive, because --- the simplifier correctly eliminates case that can't --- possibly match. - -checkCaseAlts e ty alts = - do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) - -- See GHC.Core Note [Case expression invariants] item (2) - - ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) - -- See GHC.Core Note [Case expression invariants] item (3) - - -- For types Int#, Word# with an infinite (well, large!) number of - -- possible values, there should usually be a DEFAULT case - -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to - -- have *no* case alternatives. - -- In effect, this is a kind of partial test. I suppose it's possible - -- that we might *know* that 'x' was 1 or 2, in which case - -- case x of { 1 -> e1; 2 -> e2 } - -- would be fine. - ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) - (nonExhaustiveAltsMsg e) } - where - (con_alts, maybe_deflt) = findDefault alts - - -- Check that successive alternatives have strictly increasing tags - increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest - increasing_tag _ = True - - non_deflt (Alt DEFAULT _ _) = False - non_deflt _ = True - - is_infinite_ty = case tyConAppTyCon_maybe ty of - Nothing -> False - Just tycon -> isPrimTyCon tycon - -lintAltExpr :: CoreExpr -> LintedType -> LintM UsageEnv -lintAltExpr expr ann_ty - = do { (actual_ty, ue) <- lintCoreExpr expr - ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) - ; return ue } - -- See GHC.Core Note [Case expression invariants] item (6) - -lintCoreAlt :: Var -- Case binder - -> LintedType -- Type of scrutinee - -> Mult -- Multiplicity of scrutinee - -> LintedType -- Type of the alternative - -> CoreAlt - -> LintM UsageEnv --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) = - do { lintL (null args) (mkDefaultArgsMsg args) - ; rhs_ue <- lintAltExpr rhs alt_ty - ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr - err_msg = text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr - $$ ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult - ; ensureSubUsage case_bndr_usage scrut_mult err_msg - ; return rhs_ue' } - -lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) - | litIsLifted lit - = failWithL integerScrutinisedMsg - | otherwise - = do { lintL (null args) (mkDefaultArgsMsg args) - ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) - ; rhs_ue <- lintAltExpr rhs alt_ty - ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks - } - where - lit_ty = literalType lit - -lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) - | isNewTyCon (dataConTyCon con) - = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) - | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty - = addLoc (CaseAlt alt) $ do - { checkTypeDataConOcc "pattern" con - ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - - -- Instantiate the universally quantified - -- type variables of the data constructor - ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys - ; binderMult (Named _) = ManyTy - ; binderMult (Anon st _) = scaledMult st - -- See Note [Validating multiplicities in a case] - ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } - - -- And now bring the new binders into scope - ; lintBinders CasePatBind args $ \ args' -> do - { - rhs_ue <- lintAltExpr rhs alt_ty - ; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities args')) - ; return $ deleteUE rhs_ue' case_bndr - } - } - - | otherwise -- Scrut-ty is wrong shape - = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) - -{- -Note [Validating multiplicities in a case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose 'MkT :: a %m -> T m a'. -If we are validating 'case (x :: T Many a) of MkT y -> ...', -we have to substitute m := Many in the type of MkT - in particular, -y can be used Many times and that expression would still be linear in x. -We do this by looking at con_payload_ty, which is the type of the datacon -applied to the surrounding arguments. -Testcase: linear/should_compile/MultConstructor - -Data constructors containing existential tyvars will then have -Named binders, which are always multiplicity Many. -Testcase: indexed-types/should_compile/GADT1 --} - -lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () -lintLinearBinder doc actual_usage described_usage - = ensureSubMult actual_usage described_usage err_msg - where - err_msg = (text "Multiplicity of variable does not agree with its context" - $$ doc - $$ ppr actual_usage - $$ text "Annotation:" <+> ppr described_usage) - -{- -************************************************************************ -* * -\subsection[lint-types]{Types} -* * -************************************************************************ --} - --- When we lint binders, we (one at a time and in order): --- 1. Lint var types or kinds (possibly substituting) --- 2. Add the binder to the in scope set, and if its a coercion var, --- we may extend the substitution to reflect its (possibly) new kind -lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a -lintBinders _ [] linterF = linterF [] -lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> - lintBinders site vars $ \ vars' -> - linterF (var':vars') - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a -lintBinder site var linterF - | isTyCoVar var = lintTyCoBndr var linterF - | otherwise = lintIdBndr NotTopLevel site var linterF - -lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a -lintTyBndr = lintTyCoBndr -- We could specialise it, I guess - -lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a -lintTyCoBndr tcv thing_inside - = do { subst <- getSubst - ; tcv_type' <- lintType (varType tcv) - ; let tcv' = uniqAway (getSubstInScope subst) $ - setVarType tcv tcv_type' - subst' = extendTCvSubstWithClone subst tcv tcv' - - -- See (FORALL1) and (FORALL2) in GHC.Core.Type - ; if (isTyVar tcv) - then -- Check that in (forall (a:ki). blah) we have ki:Type - lintL (isLiftedTypeKind (typeKind tcv_type')) $ - hang (text "TyVar whose kind does not have kind Type:") - 2 (ppr tcv' <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr (typeKind tcv_type')) - else -- Check that in (forall (cv::ty). blah), - -- then ty looks like (t1 ~# t2) - lintL (isCoVarType tcv_type') $ - text "CoVar with non-coercion type:" <+> pprTyVar tcv - - ; updateSubst subst' (thing_inside tcv') } - -lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a -lintIdBndrs top_lvl ids thing_inside - = go ids thing_inside - where - go :: [Id] -> ([Id] -> LintM a) -> LintM a - go [] thing_inside = thing_inside [] - go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> - go ids $ \ids' -> - thing_inside (id' : ids') - -lintIdBndr :: TopLevelFlag -> BindingSite - -> InVar -> (OutVar -> LintM a) -> LintM a --- Do substitution on the type of a binder and add the var with this --- new type to the in-scope set of the second argument --- ToDo: lint its rules -lintIdBndr top_lvl bind_site id thing_inside - = assertPpr (isId id) (ppr id) $ - do { flags <- getLintFlags - ; checkL (not (lf_check_global_ids flags) || isLocalId id) - (text "Non-local Id binder" <+> ppr id) - -- See Note [Checking for global Ids] - - -- Check that if the binder is nested, it is not marked as exported - ; checkL (not (isExportedId id) || is_top_lvl) - (mkNonTopExportedMsg id) - - -- Check that if the binder is nested, it does not have an external name - ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) - (mkNonTopExternalNameMsg id) - - -- See Note [Representation polymorphism invariants] in GHC.Core - ; lintL (isJoinId id || not (lf_check_fixed_rep flags) - || typeHasFixedRuntimeRep id_ty) $ - text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+> - parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) - - -- Check that a join-id is a not-top-level let-binding - ; when (isJoinId id) $ - checkL (not is_top_lvl && is_let_bind) $ - mkBadJoinBindMsg id - - -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); - -- if so, it should be a CoVar, and checked by lintCoVarBndr - ; lintL (not (isCoVarType id_ty)) - (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) - - -- Check that the lambda binder has no value or OtherCon unfolding. - -- See #21496 - ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) - (text "Lambda binder with value or OtherCon unfolding.") - - ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty) - - ; addInScopeId id linted_ty $ - thing_inside (setIdType id linted_ty) } - where - id_ty = idType id - - is_top_lvl = isTopLevel top_lvl - is_let_bind = case bind_site of - LetBind -> True - _ -> False - -{- -%************************************************************************ -%* * - Types -%* * -%************************************************************************ --} - -lintValueType :: Type -> LintM LintedType --- Types only, not kinds --- Check the type, and apply the substitution to it --- See Note [Linting type lets] -lintValueType ty - = addLoc (InType ty) $ - do { ty' <- lintType ty - ; let sk = typeKind ty' - ; lintL (isTYPEorCONSTRAINT sk) $ - hang (text "Ill-kinded type:" <+> ppr ty) - 2 (text "has kind:" <+> ppr sk) - ; return ty' } - -checkTyCon :: TyCon -> LintM () -checkTyCon tc - = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) - -------------------- -lintType :: Type -> LintM LintedType - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintType (TyVarTy tv) - | not (isTyVar tv) - = failWithL (mkBadTyVarMsg tv) - - | otherwise - = do { subst <- getSubst - ; case lookupTyVar subst tv of - Just linted_ty -> return linted_ty - - -- In GHCi we may lint an expression with a free - -- type variable. Then it won't be in the - -- substitution, but it should be in scope - Nothing | tv `isInScope` subst - -> return (TyVarTy tv) - | otherwise - -> failWithL $ - hang (text "The type variable" <+> pprBndr LetBind tv) - 2 (text "is out of scope") - } - -lintType ty@(AppTy t1 t2) - | TyConApp {} <- t1 - = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty - | otherwise - = do { t1' <- lintType t1 - ; t2' <- lintType t2 - ; lint_ty_app ty (typeKind t1') [t2'] - ; return (AppTy t1' t2') } - -lintType ty@(TyConApp tc tys) - | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc - = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags - ; lintTySynFamApp report_unsat ty tc tys } - - | Just {} <- tyConAppFunTy_maybe tc tys - -- We should never see a saturated application of funTyCon; such - -- applications should be represented with the FunTy constructor. - -- See Note [Linting function types] - = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty)) - - | otherwise -- Data types, data families, primitive types - = do { checkTyCon tc - ; tys' <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) tys' - ; return (TyConApp tc tys') } - --- arrows can related *unlifted* kinds, so this has to be separate from --- a dependent forall. -lintType ty@(FunTy af tw t1 t2) - = do { t1' <- lintType t1 - ; t2' <- lintType t2 - ; tw' <- lintType tw - ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw' - ; let real_af = chooseFunTyFlag t1 t2 - ; unless (real_af == af) $ addErrL $ - hang (text "Bad FunTyFlag in FunTy") - 2 (vcat [ ppr ty - , text "FunTyFlag =" <+> ppr af - , text "Computed FunTyFlag =" <+> ppr real_af ]) - ; return (FunTy af tw' t1' t2') } - -lintType ty@(ForAllTy (Bndr tcv vis) body_ty) - | not (isTyCoVar tcv) - = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty) - | otherwise - = lintTyCoBndr tcv $ \tcv' -> - do { body_ty' <- lintType body_ty - ; lintForAllBody tcv' body_ty' - - ; when (isCoVar tcv) $ - lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $ - text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) - -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] - -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo] - - ; return (ForAllTy (Bndr tcv' vis) body_ty') } - -lintType ty@(LitTy l) - = do { lintTyLit l; return ty } - -lintType (CastTy ty co) - = do { ty' <- lintType ty - ; co' <- lintStarCoercion co - ; let tyk = typeKind ty' - cok = coercionLKind co' - ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok) - ; return (CastTy ty' co') } - -lintType (CoercionTy co) - = do { co' <- lintCoercion co - ; return (CoercionTy co') } - ------------------ -lintForAllBody :: LintedTyCoVar -> LintedType -> LintM () --- Do the checks for the body of a forall-type -lintForAllBody tcv body_ty - = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty) - - -- For type variables, check for skolem escape - -- See Note [Phantom type variables in kinds] in GHC.Core.Type - -- The kind of (forall cv. th) is liftedTypeKind, so no - -- need to check for skolem-escape in the CoVar case - ; let body_kind = typeKind body_ty - ; when (isTyVar tcv) $ - case occCheckExpand [tcv] body_kind of - Just {} -> return () - Nothing -> failWithL $ - hang (text "Variable escape in forall:") - 2 (vcat [ text "tyvar:" <+> ppr tcv - , text "type:" <+> ppr body_ty - , text "kind:" <+> ppr body_kind ]) - } - ------------------ -lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType --- The TyCon is a type synonym or a type family (not a data family) --- See Note [Linting type synonym applications] --- c.f. GHC.Tc.Validity.check_syn_tc_app -lintTySynFamApp report_unsat ty tc tys - | report_unsat -- Report unsaturated only if report_unsat is on - , tys `lengthLessThan` tyConArity tc - = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) - - -- Deal with type synonyms - | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys - , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' - = do { -- Kind-check the argument types, but without reporting - -- un-saturated type families/synonyms - tys' <- setReportUnsat False (mapM lintType tys) - - ; when report_unsat $ - do { _ <- lintType expanded_ty - ; return () } - - ; lint_ty_app ty (tyConKind tc) tys' - ; return (TyConApp tc tys') } - - -- Otherwise this must be a type family - | otherwise - = do { tys' <- mapM lintType tys - ; lint_ty_app ty (tyConKind tc) tys' - ; return (TyConApp tc tys') } - ------------------ --- Confirms that a type is really TYPE r or Constraint -checkValueType :: LintedType -> SDoc -> LintM () -checkValueType ty doc - = lintL (isTYPEorCONSTRAINT kind) - (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ - text "when checking" <+> doc) - where - kind = typeKind ty - ------------------ -lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintArrow what t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw - -- or lintArrow "coercion `blah'" k1 k2 kw - = do { unless (isTYPEorCONSTRAINT k1) (report (text "argument") k1) - ; unless (isTYPEorCONSTRAINT k2) (report (text "result") k2) - ; unless (isMultiplicityTy kw) (report (text "multiplicity") kw) } - where - k1 = typeKind t1 - k2 = typeKind t2 - kw = typeKind tw - report ar k = addErrL (vcat [ hang (text "Ill-kinded" <+> ar) - 2 (text "in" <+> what) - , what <+> text "kind:" <+> ppr k ]) - ------------------ -lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM () -lint_ty_app msg_ty k tys - -- See Note [Avoiding compiler perf traps when constructing error messages.] - = lint_app (\msg_ty -> text "type" <+> quotes (ppr msg_ty)) msg_ty k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () -lint_co_app msg_ty k tys - -- See Note [Avoiding compiler perf traps when constructing error messages.] - = lint_app (\msg_ty -> text "coercion" <+> quotes (ppr msg_ty)) msg_ty k tys - ----------------- -lintTyLit :: TyLit -> LintM () -lintTyLit (NumTyLit n) - | n >= 0 = return () - | otherwise = failWithL msg - where msg = text "Negative type literal:" <+> integer n -lintTyLit (StrTyLit _) = return () -lintTyLit (CharTyLit _) = return () - -lint_app :: Outputable msg_thing => (msg_thing -> SDoc) -> msg_thing -> LintedKind -> [LintedType] -> LintM () --- (lint_app d fun_kind arg_tys) --- We have an application (f arg_ty1 .. arg_tyn), --- where f :: fun_kind - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] --- --- Being strict in the kind here avoids quite a few pointless thunks --- reducing allocations by ~5% -lint_app mk_msg msg_type !kfn arg_tys - = do { !in_scope <- getInScope - -- We need the in_scope set to satisfy the invariant in - -- Note [The substitution invariant] in GHC.Core.TyCo.Subst - -- Forcing the in scope set eagerly here reduces allocations by up to 4%. - ; go_app in_scope kfn arg_tys - } - where - - -- We use explicit recursion instead of a fold here to avoid go_app becoming - -- an allocated function closure. This reduced allocations by up to 7% for some - -- modules. - go_app :: InScopeSet -> LintedKind -> [Type] -> LintM () - go_app !in_scope !kfn ta - | Just kfn' <- coreView kfn - = go_app in_scope kfn' ta - - go_app _in_scope _kind [] = return () - - go_app in_scope fun_kind@(FunTy _ _ kfa kfb) (ta:tas) - = do { let ka = typeKind ta - ; unless (ka `eqType` kfa) $ - addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) - ; go_app in_scope kfb tas } - - go_app in_scope (ForAllTy (Bndr kv _vis) kfn) (ta:tas) - = do { let kv_kind = varType kv - ka = typeKind ta - ; unless (ka `eqType` kv_kind) $ - addErrL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ - ppr ta <+> dcolon <+> ppr ka))) - ; let kind' = substTy (extendTCvSubst (mkEmptySubst in_scope) kv ta) kfn - ; go_app in_scope kind' tas } - - go_app _ kfn ta - = failWithL (lint_app_fail_msg kfn arg_tys mk_msg msg_type (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) - --- This is a top level definition to ensure we pass all variables of the error message --- explicitly and don't capture them as free variables. Otherwise this binder might --- become a thunk that get's allocated in the hot code path. --- See Note [Avoiding compiler perf traps when constructing error messages.] -lint_app_fail_msg :: (Outputable a1, Outputable a2) => a1 -> a2 -> (t -> SDoc) -> t -> SDoc -> SDoc -lint_app_fail_msg kfn arg_tys mk_msg msg_type extra = vcat [ hang (text "Kind application error in") 2 (mk_msg msg_type) - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg types =" <+> ppr arg_tys) - , extra ] -{- ********************************************************************* -* * - Linting rules -* * -********************************************************************* -} - -lintCoreRule :: OutVar -> LintedType -> CoreRule -> LintM () -lintCoreRule _ _ (BuiltinRule {}) - = return () -- Don't bother - -lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs - , ru_args = args, ru_rhs = rhs }) - = lintBinders LambdaBind bndrs $ \ _ -> - do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args - ; (rhs_ty, _) <- case isJoinId_maybe fun of - Just join_arity - -> do { checkL (args `lengthIs` join_arity) $ - mkBadJoinPointRuleMsg fun join_arity rule - -- See Note [Rules for join points] - ; lintCoreExpr rhs } - _ -> markAllJoinsBad $ lintCoreExpr rhs - ; ensureEqTys lhs_ty rhs_ty $ - (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty - , text "rhs type:" <+> ppr rhs_ty - , text "fun_ty:" <+> ppr fun_ty ]) - ; let bad_bndrs = filter is_bad_bndr bndrs - - ; checkL (null bad_bndrs) - (rule_doc <+> text "unbound" <+> ppr bad_bndrs) - -- See Note [Linting rules] - } - where - rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon - - lhs_fvs = exprsFreeVars args - rhs_fvs = exprFreeVars rhs - - is_bad_bndr :: Var -> Bool - -- See Note [Unbound RULE binders] in GHC.Core.Rules - is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) - && bndr `elemVarSet` rhs_fvs - && isNothing (isReflCoVar_maybe bndr) - - -{- Note [Linting rules] -~~~~~~~~~~~~~~~~~~~~~~~ -It's very bad if simplifying a rule means that one of the template -variables (ru_bndrs) that /is/ mentioned on the RHS becomes -not-mentioned in the LHS (ru_args). How can that happen? Well, in #10602, -SpecConstr stupidly constructed a rule like - - forall x,c1,c2. - f (x |> c1 |> c2) = .... - -But simplExpr collapses those coercions into one. (Indeed in #10602, -it collapsed to the identity and was removed altogether.) - -We don't have a great story for what to do here, but at least -this check will nail it. - -NB (#11643): it's possible that a variable listed in the -binders becomes not-mentioned on both LHS and RHS. Here's a silly -example: - RULE forall x y. f (g x y) = g (x+1) (y-1) -And suppose worker/wrapper decides that 'x' is Absent. Then -we'll end up with - RULE forall x y. f ($gw y) = $gw (x+1) -This seems sufficiently obscure that there isn't enough payoff to -try to trim the forall'd binder list. - -Note [Rules for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A join point cannot be partially applied. However, the left-hand side of a rule -for a join point is effectively a *pattern*, not a piece of code, so there's an -argument to be made for allowing a situation like this: - - join $sj :: Int -> Int -> String - $sj n m = ... - j :: forall a. Eq a => a -> a -> String - {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} - j @a $dEq x y = ... - -Applying this rule can't turn a well-typed program into an ill-typed one, so -conceivably we could allow it. But we can always eta-expand such an -"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact -the simplifier would have to in order to deal with the RHS. So we take a -conservative view and don't allow undersaturated rules for join points. See -Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion. --} - -{- -************************************************************************ -* * - Linting coercions -* * -************************************************************************ --} - -{- Note [Asymptotic efficiency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting coercions (and types actually) we return a linted -(substituted) coercion. Then we often have to take the coercionKind of -that returned coercion. If we get long chains, that can be asymptotically -inefficient, notably in -* TransCo -* InstCo -* SelCo (cf #9233) -* LRCo - -But the code is simple. And this is only Lint. Let's wait to see if -the bad perf bites us in practice. - -A solution would be to return the kind and role of the coercion, -as well as the linted coercion. Or perhaps even *only* the kind and role, -which is what used to happen. But that proved tricky and error prone -(#17923), so now we return the coercion. --} - - --- lints a coercion, confirming that its lh kind and its rh kind are both * --- also ensures that the role is Nominal -lintStarCoercion :: InCoercion -> LintM LintedCoercion -lintStarCoercion g - = do { g' <- lintCoercion g - ; let Pair t1 t2 = coercionKind g' - ; checkValueType t1 (text "the kind of the left type in" <+> ppr g) - ; checkValueType t2 (text "the kind of the right type in" <+> ppr g) - ; lintRole g Nominal (coercionRole g) - ; return g' } - -lintCoercion :: InCoercion -> LintM LintedCoercion --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] - -lintCoercion (CoVarCo cv) - | not (isCoVar cv) - = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) - 2 (text "With offending type:" <+> ppr (varType cv))) - - | otherwise - = do { subst <- getSubst - ; case lookupCoVar subst cv of - Just linted_co -> return linted_co ; - Nothing - | cv `isInScope` subst - -> return (CoVarCo cv) - | otherwise - -> - -- lintCoBndr always extends the substitution - failWithL $ - hang (text "The coercion variable" <+> pprBndr LetBind cv) - 2 (text "is out of scope") - } - - -lintCoercion (Refl ty) - = do { ty' <- lintType ty - ; return (Refl ty') } - -lintCoercion (GRefl r ty MRefl) - = do { ty' <- lintType ty - ; return (GRefl r ty' MRefl) } - -lintCoercion (GRefl r ty (MCo co)) - = do { ty' <- lintType ty - ; co' <- lintCoercion co - ; let tk = typeKind ty' - tl = coercionLKind co' - ; ensureEqTys tk tl $ - hang (text "GRefl coercion kind mis-match:" <+> ppr co) - 2 (vcat [ppr ty', ppr tk, ppr tl]) - ; lintRole co' Nominal (coercionRole co') - ; return (GRefl r ty' (MCo co')) } - -lintCoercion co@(TyConAppCo r tc cos) - | Just {} <- tyConAppFunCo_maybe r tc cos - = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) - 2 (ppr co)) - -- All saturated TyConAppCos should be FunCos - - | Just {} <- synTyConDefn_maybe tc - = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) - - | otherwise - = do { checkTyCon tc - ; cos' <- mapM lintCoercion cos - ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos') - ; lint_co_app co (tyConKind tc) (map pFst co_kinds) - ; lint_co_app co (tyConKind tc) (map pSnd co_kinds) - ; zipWithM_ (lintRole co) (tyConRoleListX r tc) co_roles - ; return (TyConAppCo r tc cos') } - -lintCoercion co@(AppCo co1 co2) - | TyConAppCo {} <- co1 - = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) - | Just (TyConApp {}, _) <- isReflCo_maybe co1 - = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) - | otherwise - = do { co1' <- lintCoercion co1 - ; co2' <- lintCoercion co2 - ; let (Pair lk1 rk1, r1) = coercionKindRole co1' - (Pair lk2 rk2, r2) = coercionKindRole co2' - ; lint_co_app co (typeKind lk1) [lk2] - ; lint_co_app co (typeKind rk1) [rk2] - - ; if r1 == Phantom - then lintL (r2 == Phantom || r2 == Nominal) - (text "Second argument in AppCo cannot be R:" $$ - ppr co) - else lintRole co Nominal r2 - - ; return (AppCo co1' co2') } - ----------- -lintCoercion co@(ForAllCo tcv kind_co body_co) - | not (isTyCoVar tcv) - = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) - | otherwise - = do { kind_co' <- lintStarCoercion kind_co - ; lintTyCoBndr tcv $ \tcv' -> - do { body_co' <- lintCoercion body_co - ; ensureEqTys (varType tcv') (coercionLKind kind_co') $ - text "Kind mis-match in ForallCo" <+> ppr co - - -- Assuming kind_co :: k1 ~ k2 - -- Need to check that - -- (forall (tcv:k1). lty) and - -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) - -- are both well formed. Easiest way is to call lintForAllBody - -- for each; there is actually no need to do the funky substitution - ; let Pair lty rty = coercionKind body_co' - ; lintForAllBody tcv' lty - ; lintForAllBody tcv' rty - - ; when (isCoVar tcv) $ - lintL (almostDevoidCoVarOfCo tcv body_co) $ - text "Covar can only appear in Refl and GRefl: " <+> ppr co - -- See "last wrinkle" in GHC.Core.Coercion - -- Note [Unused coercion variable in ForAllCo] - -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] - - ; return (ForAllCo tcv' kind_co' body_co') } } - -lintCoercion co@(FunCo { fco_role = r, fco_afl = afl, fco_afr = afr - , fco_mult = cow, fco_arg = co1, fco_res = co2 }) - = do { co1' <- lintCoercion co1 - ; co2' <- lintCoercion co2 - ; cow' <- lintCoercion cow - ; let Pair lt1 rt1 = coercionKind co1 - Pair lt2 rt2 = coercionKind co2 - Pair ltw rtw = coercionKind cow - ; lintL (afl == chooseFunTyFlag lt1 lt2) (bad_co_msg "afl") - ; lintL (afr == chooseFunTyFlag rt1 rt2) (bad_co_msg "afr") - ; lintArrow (bad_co_msg "arrowl") lt1 lt2 ltw - ; lintArrow (bad_co_msg "arrowr") rt1 rt2 rtw - ; lintRole co1 r (coercionRole co1) - ; lintRole co2 r (coercionRole co2) - ; ensureEqTys (typeKind ltw) multiplicityTy (bad_co_msg "mult-l") - ; ensureEqTys (typeKind rtw) multiplicityTy (bad_co_msg "mult-r") - ; let expected_mult_role = case r of - Phantom -> Phantom - _ -> Nominal - ; lintRole cow expected_mult_role (coercionRole cow) - ; return (co { fco_mult = cow', fco_arg = co1', fco_res = co2' }) } - where - bad_co_msg s = hang (text "Bad coercion" <+> parens (text s)) - 2 (vcat [ text "afl:" <+> ppr afl - , text "afr:" <+> ppr afr - , text "arg_co:" <+> ppr co1 - , text "res_co:" <+> ppr co2 ]) - --- See Note [Bad unsafe coercion] -lintCoercion co@(UnivCo prov r ty1 ty2) - = do { ty1' <- lintType ty1 - ; ty2' <- lintType ty2 - ; let k1 = typeKind ty1' - k2 = typeKind ty2' - ; prov' <- lint_prov k1 k2 prov - - ; when (r /= Phantom && isTYPEorCONSTRAINT k1 - && isTYPEorCONSTRAINT k2) - (checkTypes ty1 ty2) - - ; return (UnivCo prov' r ty1' ty2') } - where - report s = hang (text $ "Unsafe coercion: " ++ s) - 2 (vcat [ text "From:" <+> ppr ty1 - , text " To:" <+> ppr ty2]) - isUnBoxed :: PrimRep -> Bool - isUnBoxed = not . isGcPtrRep - - -- see #9122 for discussion of these checks - checkTypes t1 t2 - | allow_ill_kinded_univ_co prov - = return () -- Skip kind checks - | otherwise - = do { checkWarnL fixed_rep_1 - (report "left-hand type does not have a fixed runtime representation") - ; checkWarnL fixed_rep_2 - (report "right-hand type does not have a fixed runtime representation") - ; when (fixed_rep_1 && fixed_rep_2) $ - do { checkWarnL (reps1 `equalLength` reps2) - (report "between values with different # of reps") - ; zipWithM_ validateCoercion reps1 reps2 }} - where - fixed_rep_1 = typeHasFixedRuntimeRep t1 - fixed_rep_2 = typeHasFixedRuntimeRep t2 - - -- don't look at these unless lev_poly1/2 are False - -- Otherwise, we get #13458 - reps1 = typePrimRep t1 - reps2 = typePrimRep t2 - - -- CorePrep deliberately makes ill-kinded casts - -- e.g (case error @Int "blah" of {}) :: Int# - -- ==> (error @Int "blah") |> Unsafe Int Int# - -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep - allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind - allow_ill_kinded_univ_co _ = False - - validateCoercion :: PrimRep -> PrimRep -> LintM () - validateCoercion rep1 rep2 - = do { platform <- getPlatform - ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) - (report "between unboxed and boxed value") - ; checkWarnL (TyCon.primRepSizeB platform rep1 - == TyCon.primRepSizeB platform rep2) - (report "between unboxed values of different size") - ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) - (TyCon.primRepIsFloat rep2) - ; case fl of - Nothing -> addWarnL (report "between vector types") - Just False -> addWarnL (report "between float and integral values") - _ -> return () - } - - lint_prov k1 k2 (PhantomProv kco) - = do { kco' <- lintStarCoercion kco - ; lintRole co Phantom r - ; check_kinds kco' k1 k2 - ; return (PhantomProv kco') } - - lint_prov k1 k2 (ProofIrrelProv kco) - = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co) - ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co) - ; kco' <- lintStarCoercion kco - ; check_kinds kco k1 k2 - ; return (ProofIrrelProv kco') } - - lint_prov _ _ prov@(PluginProv _) = return prov - lint_prov _ _ prov@(CorePrepProv _) = return prov - - check_kinds kco k1 k2 - = do { let Pair k1' k2' = coercionKind kco - ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft co) - ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) } - - -lintCoercion (SymCo co) - = do { co' <- lintCoercion co - ; return (SymCo co') } - -lintCoercion co@(TransCo co1 co2) - = do { co1' <- lintCoercion co1 - ; co2' <- lintCoercion co2 - ; let ty1b = coercionRKind co1' - ty2a = coercionLKind co2' - ; ensureEqTys ty1b ty2a - (hang (text "Trans coercion mis-match:" <+> ppr co) - 2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')])) - ; lintRole co (coercionRole co1) (coercionRole co2) - ; return (TransCo co1' co2') } - -lintCoercion the_co@(SelCo cs co) - = do { co' <- lintCoercion co - ; let (Pair s t, co_role) = coercionKindRole co' - - ; if -- forall (both TyVar and CoVar) - | Just _ <- splitForAllTyCoVar_maybe s - , Just _ <- splitForAllTyCoVar_maybe t - , SelForAll <- cs - , (isForAllTy_ty s && isForAllTy_ty t) - || (isForAllTy_co s && isForAllTy_co t) - -> return (SelCo cs co') - - -- function - | isFunTy s - , isFunTy t - , SelFun {} <- cs - -> return (SelCo cs co') - - -- TyCon - | Just (tc_s, tys_s) <- splitTyConApp_maybe s - , Just (tc_t, tys_t) <- splitTyConApp_maybe t - , tc_s == tc_t - , SelTyCon n r0 <- cs - , isInjectiveTyCon tc_s co_role - -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep - , tys_s `equalLength` tys_t - , tys_s `lengthExceeds` n - -> do { lintRole the_co (tyConRole co_role tc_s n) r0 - ; return (SelCo cs co') } - - | otherwise - -> failWithL (hang (text "Bad SelCo:") - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion the_co@(LRCo lr co) - = do { co' <- lintCoercion co - ; let Pair s t = coercionKind co' - r = coercionRole co' - ; lintRole co Nominal r - ; case (splitAppTy_maybe s, splitAppTy_maybe t) of - (Just _, Just _) -> return (LRCo lr co') - _ -> failWithL (hang (text "Bad LRCo:") - 2 (ppr the_co $$ ppr s $$ ppr t)) } - -lintCoercion (InstCo co arg) - = do { co' <- lintCoercion co - ; arg' <- lintCoercion arg - ; let Pair t1 t2 = coercionKind co' - Pair s1 s2 = coercionKind arg' - - ; lintRole arg Nominal (coercionRole arg') - - ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of - -- forall over tvar - { (Just (tv1,_), Just (tv2,_)) - | typeKind s1 `eqType` tyVarKind tv1 - , typeKind s2 `eqType` tyVarKind tv2 - -> return (InstCo co' arg') - | otherwise - -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co) - - ; _ -> case (splitForAllCoVar_maybe t1, splitForAllCoVar_maybe t2) of - -- forall over covar - { (Just (cv1, _), Just (cv2, _)) - | typeKind s1 `eqType` varType cv1 - , typeKind s2 `eqType` varType cv2 - , CoercionTy _ <- s1 - , CoercionTy _ <- s2 - -> return (InstCo co' arg') - | otherwise - -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co) - - ; _ -> failWithL (text "Bad argument of inst") }}} - -lintCoercion co@(AxiomInstCo con ind cos) - = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) - (bad_ax (text "index out of range")) - ; let CoAxBranch { cab_tvs = ktvs - , cab_cvs = cvs - , cab_roles = roles } = coAxiomNthBranch con ind - ; unless (cos `equalLength` (ktvs ++ cvs)) $ - bad_ax (text "lengths") - ; cos' <- mapM lintCoercion cos - ; subst <- getSubst - ; let empty_subst = zapSubst subst - ; _ <- foldlM check_ki (empty_subst, empty_subst) - (zip3 (ktvs ++ cvs) roles cos') - ; let fam_tc = coAxiomTyCon con - ; case checkAxInstCo co of - Just bad_branch -> bad_ax $ text "inconsistent with" <+> - pprCoAxBranch fam_tc bad_branch - Nothing -> return () - ; return (AxiomInstCo con ind cos') } - where - bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what) - 2 (ppr co)) - - check_ki (subst_l, subst_r) (ktv, role, arg') - = do { let Pair s' t' = coercionKind arg' - sk' = typeKind s' - tk' = typeKind t' - ; lintRole arg' role (coercionRole arg') - ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) - ktv_kind_r = substTy subst_r (tyVarKind ktv) - ; unless (sk' `eqType` ktv_kind_l) - (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) - ; unless (tk' `eqType` ktv_kind_r) - (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) - ; return (extendTCvSubst subst_l ktv s', - extendTCvSubst subst_r ktv t') } - -lintCoercion (KindCo co) - = do { co' <- lintCoercion co - ; return (KindCo co') } - -lintCoercion (SubCo co') - = do { co' <- lintCoercion co' - ; lintRole co' Nominal (coercionRole co') - ; return (SubCo co') } - -lintCoercion this@(AxiomRuleCo ax cos) - = do { cos' <- mapM lintCoercion cos - ; lint_roles 0 (coaxrAsmpRoles ax) cos' - ; case coaxrProves ax (map coercionKind cos') of - Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ] - Just _ -> return (AxiomRuleCo ax cos') } - where - err :: forall a. String -> [SDoc] -> LintM a - err m xs = failWithL $ - hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName ax) : xs) - - lint_roles n (e : es) (co : cos) - | e == coercionRole co = lint_roles (n+1) es cos - | otherwise = err "Argument roles mismatch" - [ text "In argument:" <+> int (n+1) - , text "Expected:" <+> ppr e - , text "Found:" <+> ppr (coercionRole co) ] - lint_roles _ [] [] = return () - lint_roles n [] rs = err "Too many coercion arguments" - [ text "Expected:" <+> int n - , text "Provided:" <+> int (n + length rs) ] - - lint_roles n es [] = err "Not enough coercion arguments" - [ text "Expected:" <+> int (n + length es) - , text "Provided:" <+> int n ] - -lintCoercion (HoleCo h) - = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h - ; lintCoercion (CoVarCo (coHoleCoVar h)) } - - -{- -Note [Conflict checking with AxiomInstCo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following type family and axiom: - -type family Equal (a :: k) (b :: k) :: Bool -type instance where - Equal a a = True - Equal a b = False --- -Equal :: forall k::*. k -> k -> Bool -axEqual :: { forall k::*. forall a::k. Equal k a a ~ True - ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } - -The coercion (axEqual[1] <*> ) :: (Equal * Int Int ~ False) - -and that all is OK. But, all is not OK: we want to use the first branch of the -axiom in this case, not the second. The problem is that the parameters of the -first branch can unify with the supplied coercions, thus meaning that the first -branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv". - -For more details, see the section "Branched axiom conflict checking" in -docs/core-spec, which defines the corresponding no_conflict function used by the -Co_AxiomInstCo rule in the section "Coercion typing". --} - --- | Check to make sure that an AxInstCo is internally consistent. --- Returns the conflicting branch, if it exists --- See Note [Conflict checking with AxiomInstCo] -checkAxInstCo :: Coercion -> Maybe CoAxBranch --- defined here to avoid dependencies in GHC.Core.Coercion --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -checkAxInstCo (AxiomInstCo ax ind cos) - = let branch = coAxiomNthBranch ax ind - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - incomps = coAxBranchIncomps branch - (tys, cotys) = splitAtList tvs (map coercionLKind cos) - co_args = map stripCoercionTy cotys - subst = zipTvSubst tvs tys `composeTCvSubst` - zipCvSubst cvs co_args - target = Type.substTys subst (coAxBranchLHS branch) - in_scope = mkInScopeSet $ - unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) - flattened_target = flattenTys in_scope target in - check_no_conflict flattened_target incomps - where - check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch - check_no_conflict _ [] = Nothing - check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) - -- See Note [Apartness] in GHC.Core.FamInstEnv - | SurelyApart <- tcUnifyTysFG alwaysBindFun flat lhs_incomp - = check_no_conflict flat rest - | otherwise - = Just b -checkAxInstCo _ = Nothing - - -{- -************************************************************************ -* * - Axioms -* * -************************************************************************ --} - -lintAxioms :: Logger - -> LintConfig - -> SDoc -- ^ The source of the linted axioms - -> [CoAxiom Branched] - -> IO () -lintAxioms logger cfg what axioms = - displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ - initL cfg $ - do { mapM_ lint_axiom axioms - ; let axiom_groups = groupWith coAxiomTyCon axioms - ; mapM_ lint_axiom_group axiom_groups } - -lint_axiom :: CoAxiom Branched -> LintM () -lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches - , co_ax_role = ax_role }) - = addLoc (InAxiom ax) $ - do { mapM_ (lint_branch tc) branch_list - ; extra_checks } - where - branch_list = fromBranches branches - - extra_checks - | isNewTyCon tc - = do { CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs_tys } - <- case branch_list of - [branch] -> return branch - _ -> failWithL (text "multi-branch axiom with newtype") - ; let ax_lhs = mkInfForAllTys tvs $ - mkTyConApp tc lhs_tys - nt_tvs = takeList tvs (tyConTyVars tc) - -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon - nt_lhs = mkInfForAllTys nt_tvs $ - mkTyConApp tc (mkTyVarTys nt_tvs) - -- See Note [Newtype eta] in GHC.Core.TyCon - ; lintL (ax_lhs `eqType` nt_lhs) - (text "Newtype axiom LHS does not match newtype definition") - ; lintL (null cvs) - (text "Newtype axiom binds coercion variables") - ; lintL (null eta_tvs) -- See Note [Eta reduction for data families] - -- which is not about newtype axioms - (text "Newtype axiom has eta-tvs") - ; lintL (ax_role == Representational) - (text "Newtype axiom role not representational") - ; lintL (roles `equalLength` tvs) - (text "Newtype axiom roles list is the wrong length." $$ - text "roles:" <+> sep (map ppr roles)) - ; lintL (roles == takeList roles (tyConRoles tc)) - (vcat [ text "Newtype axiom roles do not match newtype tycon's." - , text "axiom roles:" <+> sep (map ppr roles) - , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ]) - } - - | isFamilyTyCon tc - = do { if | isTypeFamilyTyCon tc - -> lintL (ax_role == Nominal) - (text "type family axiom is not nominal") - - | isDataFamilyTyCon tc - -> lintL (ax_role == Representational) - (text "data family axiom is not representational") - - | otherwise - -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc) - - ; mapM_ (lint_family_branch tc) branch_list } - - | otherwise - = addErrL (text "Axiom tycon is neither a newtype nor a family.") - -lint_branch :: TyCon -> CoAxBranch -> LintM () -lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = lhs_args, cab_rhs = rhs }) - = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> - do { let lhs = mkTyConApp ax_tc lhs_args - ; lhs' <- lintType lhs - ; rhs' <- lintType rhs - ; let lhs_kind = typeKind lhs' - rhs_kind = typeKind rhs' - ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $ - hang (text "Inhomogeneous axiom") - 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ - text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } - -- Type and Constraint are not Apart, so this test allows - -- the newtype axiom for a single-method class. Indeed the - -- whole reason Type and Constraint are not Apart is to allow - -- such axioms! - --- these checks do not apply to newtype axioms -lint_family_branch :: TyCon -> CoAxBranch -> LintM () -lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_cvs = cvs - , cab_roles = roles - , cab_lhs = lhs - , cab_incomps = incomps }) - = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs) - (text "Type family axiom has eta-tvs") - ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs) - (text "Quantified variable in family axiom unused in LHS") - ; lintL (all isTyFamFree lhs) - (text "Type family application on LHS of family axiom") - ; lintL (all (== Nominal) roles) - (text "Non-nominal role in family axiom" $$ - text "roles:" <+> sep (map ppr roles)) - ; lintL (null cvs) - (text "Coercion variables bound in family axiom") - ; forM_ incomps $ \ br' -> - lintL (not (compatibleBranches br br')) $ - hang (text "Incorrect incompatible branches:") - 2 (vcat [text "Branch:" <+> ppr br, - text "Bogus incomp:" <+> ppr br']) } - -lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () -lint_axiom_group (_ :| []) = return () -lint_axiom_group (ax :| axs) - = do { lintL (isOpenFamilyTyCon tc) - (text "Non-open-family with multiple axioms") - ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs - , ax2 <- all_axs ] - ; mapM_ (lint_axiom_pair tc) all_pairs } - where - all_axs = ax : axs - tc = coAxiomTyCon ax - -lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM () -lint_axiom_pair tc (ax1, ax2) - | Just br1@(CoAxBranch { cab_tvs = tvs1 - , cab_lhs = lhs1 - , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1 - , Just br2@(CoAxBranch { cab_tvs = tvs2 - , cab_lhs = lhs2 - , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2 - = lintL (compatibleBranches br1 br2) $ - vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2 - , text "are incompatible" ] - , text "tvs1 =" <+> pprTyVars tvs1 - , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1) - , text "rhs1 =" <+> ppr rhs1 - , text "tvs2 =" <+> pprTyVars tvs2 - , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2) - , text "rhs2 =" <+> ppr rhs2 ] - - | otherwise - = addErrL (text "Open type family axiom has more than one branch: either" <+> - ppr ax1 <+> text "or" <+> ppr ax2) - -{- -************************************************************************ -* * -\subsection[lint-monad]{The Lint monad} -* * -************************************************************************ --} - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] -data LintEnv - = LE { le_flags :: LintFlags -- Linting the result of this pass - , le_loc :: [LintLocInfo] -- Locations - - , le_subst :: Subst -- Current TyCo substitution - -- See Note [Linting type lets] - -- /Only/ substitutes for type variables; - -- but might clone CoVars - -- We also use le_subst to keep track of - -- in-scope TyVars and CoVars (but not Ids) - -- Range of the Subst is LintedType/LintedCo - - , le_ids :: VarEnv (Id, LintedType) -- In-scope Ids - -- Used to check that occurrences have an enclosing binder. - -- The Id is /pre-substitution/, used to check that - -- the occurrence has an identical type to the binder - -- The LintedType is used to return the type of the occurrence, - -- without having to lint it again. - - , le_joins :: IdSet -- Join points in scope that are valid - -- A subset of the InScopeSet in le_subst - -- See Note [Join points] - - , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the - -- alias-like binders, as found in - -- non-recursive lets. - - , le_platform :: Platform -- ^ Target platform - , le_diagOpts :: DiagOpts -- ^ Target platform - } - -data LintFlags - = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] - , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] - , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] - , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] - , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] - , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] - } - --- See Note [Checking StaticPtrs] -data StaticPtrCheck - = AllowAnywhere - -- ^ Allow 'makeStatic' to occur anywhere. - | AllowAtTopLevel - -- ^ Allow 'makeStatic' calls at the top-level only. - | RejectEverywhere - -- ^ Reject any 'makeStatic' occurrence. - deriving Eq - -newtype LintM a = - LintM' { unLintM :: - LintEnv -> - WarnsAndErrs -> -- Warning and error messages so far - LResult a } -- Result and messages (if any) - - -pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a --- See Note [The one-shot state monad trick] in GHC.Utils.Monad -pattern LintM m <- LintM' m - where - LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we) - -- LintM m = LintM' (oneShot $ oneShot m) -{-# COMPLETE LintM #-} - -instance Functor (LintM) where - fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w) - -type WarnsAndErrs = (Bag SDoc, Bag SDoc) - --- Using a unboxed tuple here reduced allocations for a lint heavy --- file by ~6%. Using MaybeUB reduced them further by another ~12%. -type LResult a = (# MaybeUB a, WarnsAndErrs #) - -pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a -pattern LResult m w = (# m, w #) -{-# COMPLETE LResult #-} - -mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2 -mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w - --- Just for testing. -fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a -fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs -fromBoxedLResult (Nothing,errs) = LResult NothingUB errs - -{- Note [Checking for global Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before CoreTidy, all locally-bound Ids must be LocalIds, even -top-level ones. See Note [Exported LocalIds] and #9857. - -Note [Checking StaticPtrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. - -Every occurrence of the function 'makeStatic' should be moved to the -top level by the FloatOut pass. It's vital that we don't have nested -'makeStatic' occurrences after CorePrep, because we populate the Static -Pointer Table from the top-level bindings. See SimplCore Note [Grand -plan for static forms]. - -The linter checks that no occurrence is left behind, nested within an -expression. The check is enabled only after the FloatOut, CorePrep, -and CoreTidy passes and only if the module uses the StaticPointers -language extension. Checking more often doesn't help since the condition -doesn't hold until after the first FloatOut pass. - -Note [Type substitution] -~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we need a type substitution? Consider - /\(a:*). \(x:a). /\(a:*). id a x -This is ill typed, because (renaming variables) it is really - /\(a:*). \(x:a). /\(b:*). id b x -Hence, when checking an application, we can't naively compare x's type -(at its binding site) with its expected type (at a use site). So we -rename type binders as we go, maintaining a substitution. - -The same substitution also supports let-type, current expressed as - (/\(a:*). body) ty -Here we substitute 'ty' for 'a' in 'body', on the fly. - -Note [Linting type synonym applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When linting a type-synonym, or type-family, application - S ty1 .. tyn -we behave as follows (#15057, #T15664): - -* If lf_report_unsat_syns = True, and S has arity < n, - complain about an unsaturated type synonym or type family - -* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. - - Reason: catch out of scope variables or other ill-kinded gubbins, - even if S discards that argument entirely. E.g. (#15012): - type FakeOut a = Int - type family TF a - type instance TF Int = FakeOut a - Here 'a' is out of scope; but if we expand FakeOut, we conceal - that out-of-scope error. - - Reason for switching off lf_report_unsat_syns: with - LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they - are saturated when the type is expanded. Example - type T f = f Int - type S a = a -> a - type Z = T S - In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. - -* If lf_report_unsat_syns is on, expand the synonym application and - lint the result. Reason: want to check that synonyms are saturated - when the type is expanded. - -Note [Linting linearity] -~~~~~~~~~~~~~~~~~~~~~~~~ -Core understands linear types: linearity is checked with the flag -`-dlinear-core-lint`. Why not make `-dcore-lint` check linearity? Because -optimisation passes are not (yet) guaranteed to maintain linearity. They should -do so semantically (GHC is careful not to duplicate computation) but it is much -harder to ensure that the statically-checkable constraints of Linear Core are -maintained. The current Linear Core is described in the wiki at: -https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation. - -Why don't the optimisation passes maintain the static types of Linear Core? -Because doing so would cripple some important optimisations. Here is an -example: - - data T = MkT {-# UNPACK #-} !Int - -The wrapper for MkT is - - $wMkT :: Int %1 -> T - $wMkT n = case %1 n of - I# n' -> MkT n' - -This introduces, in particular, a `case %1` (this is not actual Haskell or Core -syntax), where the `%1` means that the `case` expression consumes its scrutinee -linearly. - -Now, `case %1` interacts with the binder swap optimisation in a non-trivial -way. Take a slightly modified version of the code for $wMkT: - - case %1 x of z { - I# n' -> (x, n') - } - -Binder-swap wants to change this to - - case %1 x of z { - I# n' -> let x = z in (x, n') - } - -Now, this is not something that a linear type checker usually considers -well-typed. It is not something that `-dlinear-core-lint` considers to be -well-typed either. But it's only because `-dlinear-core-lint` is not good -enough. However, making `-dlinear-core-lint` recognise this expression as valid -is not obvious. There are many such interactions between a linear type system -and GHC optimisations documented in the linear-type implementation wiki page -[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]. - -PRINCIPLE: The type system bends to the optimisation, not the other way around. - -In the original linear-types implementation, we had tried to make every -optimisation pass produce code that passes `-dlinear-core-lint`. It had proved -very difficult. And we kept finding corner case after corner case. Plus, we -used to restrict transformations when `-dlinear-core-lint` couldn't typecheck -the result. There are still occurrences of such restrictions in the code. But -our current stance is that such restrictions can be removed. - -For instance, some optimisations can create a letrec which uses a variable -linearly, e.g. - - letrec f True = f False - f False = x - in f True - -uses 'x' linearly, but this is not seen by the linter. This issue is discussed -in ticket #18694. - -Plus in many cases, in order to make a transformation compatible with linear -linting, we ended up restricting to avoid producing patterns that were not -recognised as linear by the linter. This violates the above principle. - -In the future, we may be able to lint the linearity of the output of -Core-to-Core passes (#19165). But right now, we can't. Therefore, in virtue of -the principle above, after the desguarer, the optimiser should take no special -pains to preserve linearity (in the type system sense). - -In general the optimiser tries hard not to lose sharing, so it probably doesn't -actually make linear things non-linear. We postulate that any program -transformation which breaks linearity would negatively impact performance, and -therefore wouldn't be suitable for an optimiser. An alternative to linting -linearity after each pass is to prove this statement. - -There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123 - -Note [checkCanEtaExpand] -~~~~~~~~~~~~~~~~~~~~~~~~ -The checkCanEtaExpand function is responsible for enforcing invariant I3 -from Note [Representation polymorphism invariants] in GHC.Core: in any -partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to -eta expand `f` to match the declared arity of `f`. - -Wrinkle 1: eta-expansion and newtypes - - Most of the time, when we have a partial application `f e_1 .. e_n` - in which `f` is `hasNoBinding`, we eta-expand it up to its arity - as follows: - - \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity - - However, we might need to insert casts if some of the arguments - that `f` takes are under a newtype. - For example, suppose `f` `hasNoBinding`, has arity 1 and type - - f :: forall r (a :: TYPE r). Identity (a -> a) - - then we eta-expand the nullary application `f` to - - ( \ x -> f x ) |> co - - where - - co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) ) - - In this case we would have to perform a representation-polymorphism check on the instantiation - of `a`. - -Wrinkle 2: 'hasNoBinding' and laziness - - It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing - the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in - Note [Lazily checking Unfoldings] in GHC.IfaceToCore. --} - -instance Applicative LintM where - pure x = LintM $ \ _ errs -> LResult (JustUB x) errs - --(Just x, errs) - (<*>) = ap - -instance Monad LintM where - m >>= k = LintM (\ env errs -> - let res = unLintM m env errs in - case res of - LResult (JustUB r) errs' -> unLintM (k r) env errs' - LResult NothingUB errs' -> LResult NothingUB errs' - ) - -- LError errs'-> LError errs') - -- let (res, errs') = unLintM m env errs in - -- Just r -> unLintM (k r) env errs' - -- Nothing -> (Nothing, errs')) - -instance MonadFail LintM where - fail err = failWithL (text err) - -getPlatform :: LintM Platform -getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs)) - -data LintLocInfo - = RhsOf Id -- The variable bound - | OccOf Id -- Occurrence of id - | LambdaBodyOf Id -- The lambda-binder - | RuleOf Id -- Rules attached to a binder - | UnfoldingOf Id -- Unfolding of a binder - | BodyOfLetRec [Id] -- One of the binders - | CaseAlt CoreAlt -- Case alternative - | CasePat CoreAlt -- The *pattern* of the case alternative - | CaseTy CoreExpr -- The type field of a case expression - -- with this scrutinee - | IdTy Id -- The type field of an Id binder - | AnExpr CoreExpr -- Some expression - | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) - | TopLevelBindings - | InType Type -- Inside a type - | InCo Coercion -- Inside a coercion - | InAxiom (CoAxiom Branched) -- Inside a CoAxiom - -data LintConfig = LintConfig - { l_diagOpts :: !DiagOpts -- ^ Diagnostics opts - , l_platform :: !Platform -- ^ Target platform - , l_flags :: !LintFlags -- ^ Linting the result of this pass - , l_vars :: ![Var] -- ^ 'Id's that should be treated as being in scope - } - -initL :: LintConfig - -> LintM a -- ^ Action to run - -> WarnsAndErrs -initL cfg m - = case unLintM m env (emptyBag, emptyBag) of - LResult (JustUB _) errs -> errs - LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs - | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ - "without reporting an error message") empty - where - (tcvs, ids) = partition isTyCoVar $ l_vars cfg - env = LE { le_flags = l_flags cfg - , le_subst = mkEmptySubst (mkInScopeSetList tcvs) - , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] - , le_joins = emptyVarSet - , le_loc = [] - , le_ue_aliases = emptyNameEnv - , le_platform = l_platform cfg - , le_diagOpts = l_diagOpts cfg - } - -setReportUnsat :: Bool -> LintM a -> LintM a --- Switch off lf_report_unsat_syns -setReportUnsat ru thing_inside - = LintM $ \ env errs -> - let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } - in unLintM thing_inside env' errs - --- See Note [Checking for representation polymorphism] -noFixedRuntimeRepChecks :: LintM a -> LintM a -noFixedRuntimeRepChecks thing_inside - = LintM $ \env errs -> - let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } } - in unLintM thing_inside env' errs - -getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) - -checkL :: Bool -> SDoc -> LintM () -checkL True _ = return () -checkL False msg = failWithL msg - --- like checkL, but relevant to type checking -lintL :: Bool -> SDoc -> LintM () -lintL = checkL - -checkWarnL :: Bool -> SDoc -> LintM () -checkWarnL True _ = return () -checkWarnL False msg = addWarnL msg - -failWithL :: SDoc -> LintM a -failWithL msg = LintM $ \ env (warns,errs) -> - fromBoxedLResult (Nothing, (warns, addMsg True env errs msg)) - -addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \ env (warns,errs) -> - fromBoxedLResult (Just (), (warns, addMsg True env errs msg)) - -addWarnL :: SDoc -> LintM () -addWarnL msg = LintM $ \ env (warns,errs) -> - fromBoxedLResult (Just (), (addMsg False env warns msg, errs)) - -addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc -addMsg is_error env msgs msg - = assertPpr (notNull loc_msgs) msg $ - msgs `snocBag` mk_msg msg - where - loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first - loc_msgs = map dumpLoc (le_loc env) - - cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs - , text "Substitution:" <+> ppr (le_subst env) ] - context | is_error = cxt_doc - | otherwise = whenPprDebug cxt_doc - -- Print voluminous info for Lint errors - -- but not for warnings - - msg_span = case [ span | (loc,_) <- loc_msgs - , let span = srcLocSpan loc - , isGoodSrcSpan span ] of - [] -> noSrcSpan - (s:_) -> s - !diag_opts = le_diagOpts env - mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span - (msg $$ context) - -addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m - = LintM $ \ env errs -> - unLintM m (env { le_loc = extra_loc : le_loc env }) errs - -inCasePat :: LintM Bool -- A slight hack; see the unique call site -inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs) - where - is_case_pat (LE { le_loc = CasePat {} : _ }) = True - is_case_pat _other = False - -addInScopeId :: Id -> LintedType -> LintM a -> LintM a -addInScopeId id linted_ty m - = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set, le_ue_aliases = aliases }) errs -> - unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) - , le_joins = add_joins join_set - , le_ue_aliases = delFromNameEnv aliases (idName id) }) errs - -- When shadowing an alias, we need to make sure the Id is no longer - -- classified as such. E.g. in - -- let x = in case x of x { _DEFAULT -> } - -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1. - where - add_joins join_set - | isJoinId id = extendVarSet join_set id -- Overwrite with new arity - | otherwise = delVarSet join_set id -- Remove any existing binding - -getInScopeIds :: LintM (VarEnv (Id,LintedType)) -getInScopeIds = LintM (\env errs -> fromBoxedLResult (Just (le_ids env), errs)) - -extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a -extendTvSubstL tv ty m - = LintM $ \ env errs -> - unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs - -updateSubst :: Subst -> LintM a -> LintM a -updateSubst subst' m - = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs - -markAllJoinsBad :: LintM a -> LintM a -markAllJoinsBad m - = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs - -markAllJoinsBadIf :: Bool -> LintM a -> LintM a -markAllJoinsBadIf True m = markAllJoinsBad m -markAllJoinsBadIf False m = m - -getValidJoins :: LintM IdSet -getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) - -getSubst :: LintM Subst -getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) - -getUEAliases :: LintM (NameEnv UsageEnv) -getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> fromBoxedLResult (Just (getSubstInScope $ le_subst env), errs)) - -lookupIdInScope :: Id -> LintM (Id, LintedType) -lookupIdInScope id_occ - = do { in_scope_ids <- getInScopeIds - ; case lookupVarEnv in_scope_ids id_occ of - Just (id_bndr, linted_ty) - -> do { checkL (not (bad_global id_bndr)) $ global_in_scope id_bndr - ; return (id_bndr, linted_ty) } - Nothing -> do { checkL (not is_local) local_out_of_scope - ; return (id_occ, idType id_occ) } } - -- We don't bother to lint the type - -- of global (i.e. imported) Ids - where - is_local = mustHaveLocalBinding id_occ - local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ - global_in_scope id_bndr = hang (text "Occurrence is GlobalId, but binding is LocalId") - 2 $ vcat [hang (text "occurrence:") 2 $ pprBndr LetBind id_occ - ,hang (text "binder :") 2 $ pprBndr LetBind id_bndr - ] - bad_global id_bnd = isGlobalId id_occ - && isLocalId id_bnd - && not (isWiredIn id_occ) - -- 'bad_global' checks for the case where an /occurrence/ is - -- a GlobalId, but there is an enclosing binding fora a LocalId. - -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, - -- but GHCi adds GlobalIds from the interactive context. These - -- are fine; hence the test (isLocalId id == isLocalId v) - -- NB: when compiling Control.Exception.Base, things like absentError - -- are defined locally, but appear in expressions as (global) - -- wired-in Ids after worker/wrapper - -- So we simply disable the test in this case - -lookupJoinId :: Id -> LintM (Maybe JoinArity) --- Look up an Id which should be a join point, valid here --- If so, return its arity, if not return Nothing -lookupJoinId id - = do { join_set <- getValidJoins - ; case lookupVarSet join_set id of - Just id' -> return (isJoinId_maybe id') - Nothing -> return Nothing } - -addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a -addAliasUE id ue thing_inside = LintM $ \ env errs -> - let new_ue_aliases = - extendNameEnv (le_ue_aliases env) (getName id) ue - in - unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs - -varCallSiteUsage :: Id -> LintM UsageEnv -varCallSiteUsage id = - do m <- getUEAliases - return $ case lookupNameEnv m (getName id) of - Nothing -> singleUsageUE id - Just id_ue -> id_ue - -ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () --- check ty2 is subtype of ty1 (ie, has same structure but usage --- annotations need only be consistent, not equal) --- Assumes ty1,ty2 are have already had the substitution applied -ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg - -ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () -ensureSubUsage Bottom _ _ = return () -ensureSubUsage Zero described_mult err_msg = ensureSubMult ManyTy described_mult err_msg -ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg - -ensureSubMult :: Mult -> Mult -> SDoc -> LintM () -ensureSubMult actual_mult described_mult err_msg = do - flags <- getLintFlags - when (lf_check_linearity flags) $ - unless (deepSubMult actual_mult described_mult) $ - addErrL err_msg - where - -- Check for submultiplicity using the following rules: - -- 1. x*y <= z when x <= z and y <= z. - -- This rule follows from the fact that x*y = sup{x,y} for any - -- multiplicities x,y. - -- 2. x <= y*z when x <= y or x <= z. - -- This rule is not complete: when x = y*z, we cannot - -- change y*z <= y*z to y*z <= y or y*z <= z. - -- However, we eliminate products on the LHS in step 1. - -- 3. One <= x and x <= Many for any x, as checked by 'submult'. - -- 4. x <= x. - -- Otherwise, we fail. - deepSubMult :: Mult -> Mult -> Bool - deepSubMult m n - | Just (m1, m2) <- isMultMul m = deepSubMult m1 n && deepSubMult m2 n - | Just (n1, n2) <- isMultMul n = deepSubMult m n1 || deepSubMult m n2 - | Submult <- m `submult` n = True - | otherwise = m `eqType` n - -lintRole :: Outputable thing - => thing -- where the role appeared - -> Role -- expected - -> Role -- actual - -> LintM () -lintRole co r1 r2 - = lintL (r1 == r2) - (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> - text "got" <+> ppr r2 $$ - text "in" <+> ppr co) - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) - -dumpLoc (RhsOf v) - = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) - -dumpLoc (OccOf v) - = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) - -dumpLoc (LambdaBodyOf b) - = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) - -dumpLoc (RuleOf b) - = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) - -dumpLoc (UnfoldingOf b) - = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) - -dumpLoc (BodyOfLetRec []) - = (noSrcLoc, text "In body of a letrec with no binders") - -dumpLoc (BodyOfLetRec bs@(b:_)) - = ( getSrcLoc b, text "In the body of letrec with binders" <+> pp_binders bs) - -dumpLoc (AnExpr e) - = (noSrcLoc, text "In the expression:" <+> ppr e) - -dumpLoc (CaseAlt (Alt con args _)) - = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CasePat (Alt con args _)) - = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) - -dumpLoc (CaseTy scrut) - = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") - 2 (ppr scrut)) - -dumpLoc (IdTy b) - = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) - -dumpLoc (ImportedUnfolding locn) - = (locn, text "In an imported unfolding") -dumpLoc TopLevelBindings - = (noSrcLoc, Outputable.empty) -dumpLoc (InType ty) - = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InCo co) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) -dumpLoc (InAxiom ax) - = (getSrcLoc ax, hang (text "In the coercion axiom") - 2 (pprCoAxiom ax)) - -pp_binders :: [Var] -> SDoc -pp_binders bs = sep (punctuate comma (map pp_binder bs)) - -pp_binder :: Var -> SDoc -pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] - | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] - ------------------------------------------------------- --- Messages for case expressions - -mkDefaultArgsMsg :: [Var] -> SDoc -mkDefaultArgsMsg args - = hang (text "DEFAULT case with binders") - 4 (ppr args) - -mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc -mkCaseAltMsg e ty1 ty2 - = hang (text "Type of case alternatives not the same as the annotation on case:") - 4 (vcat [ text "Actual type:" <+> ppr ty1, - text "Annotation on case:" <+> ppr ty2, - text "Alt Rhs:" <+> ppr e ]) - -mkScrutMsg :: Id -> Type -> Type -> Subst -> SDoc -mkScrutMsg var var_ty scrut_ty subst - = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, - text "Result binder type:" <+> ppr var_ty,--(idType var), - text "Scrutinee type:" <+> ppr scrut_ty, - hsep [text "Current TCv subst", ppr subst]] - -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc -mkNonDefltMsg e - = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) -mkNonIncreasingAltsMsg e - = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) - -nonExhaustiveAltsMsg :: CoreExpr -> SDoc -nonExhaustiveAltsMsg e - = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) - -mkBadConMsg :: TyCon -> DataCon -> SDoc -mkBadConMsg tycon datacon - = vcat [ - text "In a case alternative, data constructor isn't in scrutinee type:", - text "Scrutinee type constructor:" <+> ppr tycon, - text "Data con:" <+> ppr datacon - ] - -mkBadPatMsg :: Type -> Type -> SDoc -mkBadPatMsg con_result_ty scrut_ty - = vcat [ - text "In a case alternative, pattern result type doesn't match scrutinee type:", - text "Pattern result type:" <+> ppr con_result_ty, - text "Scrutinee type:" <+> ppr scrut_ty - ] - -integerScrutinisedMsg :: SDoc -integerScrutinisedMsg - = text "In a LitAlt, the literal is lifted (probably Integer)" - -mkBadAltMsg :: Type -> CoreAlt -> SDoc -mkBadAltMsg scrut_ty alt - = vcat [ text "Data alternative when scrutinee is not a tycon application", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - -mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc -mkNewTyDataConAltMsg scrut_ty alt - = vcat [ text "Data alternative for newtype datacon", - text "Scrutinee type:" <+> ppr scrut_ty, - text "Alternative:" <+> pprCoreAlt alt ] - - ------------------------------------------------------- --- Other error messages - -mkAppMsg :: Type -> Type -> CoreExpr -> SDoc -mkAppMsg expected_arg_ty actual_arg_ty arg - = vcat [text "Argument value doesn't match argument type:", - hang (text "Expected arg type:") 4 (ppr expected_arg_ty), - hang (text "Actual arg type:") 4 (ppr actual_arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc -mkNonFunAppMsg fun_ty arg_ty arg - = vcat [text "Non-function type in function position", - hang (text "Fun type:") 4 (ppr fun_ty), - hang (text "Arg type:") 4 (ppr arg_ty), - hang (text "Arg:") 4 (ppr arg)] - -mkLetErr :: TyVar -> CoreExpr -> SDoc -mkLetErr bndr rhs - = vcat [text "Bad `let' binding:", - hang (text "Variable:") - 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), - hang (text "Rhs:") - 4 (ppr rhs)] - -mkTyAppMsg :: Type -> Type -> SDoc -mkTyAppMsg ty arg_ty - = vcat [text "Illegal type application:", - hang (text "Exp type:") - 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -emptyRec :: CoreExpr -> SDoc -emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) - -mkRhsMsg :: Id -> SDoc -> Type -> SDoc -mkRhsMsg binder what ty - = vcat - [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, - ppr binder], - hsep [text "Binder's type:", ppr (idType binder)], - hsep [text "Rhs type:", ppr ty]] - -badBndrTyMsg :: Id -> SDoc -> SDoc -badBndrTyMsg binder what - = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder - , text "Binder's type:" <+> ppr (idType binder) ] - -mkNonTopExportedMsg :: Id -> SDoc -mkNonTopExportedMsg binder - = hsep [text "Non-top-level binder is marked as exported:", ppr binder] - -mkNonTopExternalNameMsg :: Id -> SDoc -mkNonTopExternalNameMsg binder - = hsep [text "Non-top-level binder has an external name:", ppr binder] - -mkTopNonLitStrMsg :: Id -> SDoc -mkTopNonLitStrMsg binder - = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] - -mkKindErrMsg :: TyVar -> Type -> SDoc -mkKindErrMsg tyvar arg_ty - = vcat [text "Kinds don't match in type application:", - hang (text "Type variable:") - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (text "Arg type:") - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc -mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) - -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc -mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) - -mk_cast_err :: String -- ^ What sort of casted thing this is - -- (\"expression\" or \"type\"). - -> String -- ^ What sort of coercion is being used - -- (\"type\" or \"kind\"). - -> SDoc -- ^ The thing being casted. - -> Coercion -> Type -> Type -> SDoc -mk_cast_err thing_str co_str pp_thing co from_ty thing_ty - = vcat [from_msg <+> text "of Cast differs from" <+> co_msg - <+> text "of" <+> enclosed_msg, - from_msg <> colon <+> ppr from_ty, - text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon - <+> ppr thing_ty, - text "Actual" <+> enclosed_msg <> colon <+> pp_thing, - text "Coercion used in cast:" <+> ppr co - ] - where - co_msg, from_msg, enclosed_msg :: SDoc - co_msg = text co_str - from_msg = text "From-" <> co_msg - enclosed_msg = text "enclosed" <+> text thing_str - -mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc -mkBadUnivCoMsg lr co - = text "Kind mismatch on the" <+> pprLeftOrRight lr <+> - text "side of a UnivCo:" <+> ppr co - -mkBadProofIrrelMsg :: Type -> Coercion -> SDoc -mkBadProofIrrelMsg ty co - = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:") - 2 (vcat [ text "type:" <+> ppr ty - , text "co:" <+> ppr co ]) - -mkBadTyVarMsg :: Var -> SDoc -mkBadTyVarMsg tv - = text "Non-tyvar used in TyVarTy:" - <+> ppr tv <+> dcolon <+> ppr (varType tv) - -mkBadJoinBindMsg :: Var -> SDoc -mkBadJoinBindMsg var - = vcat [ text "Bad join point binding:" <+> ppr var - , text "Join points can be bound only by a non-top-level let" ] - -mkInvalidJoinPointMsg :: Var -> Type -> SDoc -mkInvalidJoinPointMsg var ty - = hang (text "Join point has invalid type:") - 2 (ppr var <+> dcolon <+> ppr ty) - -mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc -mkBadJoinArityMsg var ar n rhs - = vcat [ text "Join point has too few lambdas", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of lambdas:" <+> ppr (ar - n), - text "Rhs = " <+> ppr rhs - ] - -invalidJoinOcc :: Var -> SDoc -invalidJoinOcc var - = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var - , text "The binder is either not a join point, or not valid here" ] - -mkBadJumpMsg :: Var -> Int -> Int -> SDoc -mkBadJumpMsg var ar nargs - = vcat [ text "Join point invoked with wrong number of arguments", - text "Join var:" <+> ppr var, - text "Join arity:" <+> ppr ar, - text "Number of arguments:" <+> int nargs ] - -mkInconsistentRecMsg :: [Var] -> SDoc -mkInconsistentRecMsg bndrs - = vcat [ text "Recursive let binders mix values and join points", - text "Binders:" <+> hsep (map ppr_with_details bndrs) ] - where - ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) - -mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc -mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ - = vcat [ text "Mismatch in join point arity between binder and occurrence" - , text "Var:" <+> ppr bndr - , text "Arity at binding site:" <+> ppr join_arity_bndr - , text "Arity at occurrence: " <+> ppr join_arity_occ ] - -mkBndrOccTypeMismatchMsg :: Var -> Var -> LintedType -> LintedType -> SDoc -mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty - = vcat [ text "Mismatch in type between binder and occurrence" - , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty - , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr var_ty - , text " Before subst:" <+> ppr (idType var) ] - -mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc -mkBadJoinPointRuleMsg bndr join_arity rule - = vcat [ text "Join point has rule with wrong number of arguments" - , text "Var:" <+> ppr bndr - , text "Join arity:" <+> ppr join_arity - , text "Rule:" <+> ppr rule ] - -pprLeftOrRight :: LeftOrRight -> SDoc -pprLeftOrRight CLeft = text "left" -pprLeftOrRight CRight = text "right" +import GHC.Tc.Utils.TcType + ( ConcreteTvOrigin(..), ConcreteTyVars + , isFloatingPrimTy, isTyFamFree ) +import GHC.Tc.Types.Origin + ( FixedRuntimeRepOrigin(..) ) +import GHC.Unit.Module.ModGuts +import GHC.Platform + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.Stats ( coreBindsStats ) +import GHC.Core.DataCon +import GHC.Core.Ppr +import GHC.Core.Coercion +import GHC.Core.Type as Type +import GHC.Core.Predicate( isCoVarType ) +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Core.TyCo.Rep -- checks validity of types/coercions +import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis ) +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCon as TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv( compatibleBranches ) +import GHC.Core.Unify +import GHC.Core.Opt.Arity ( typeArity, exprIsDeadEnd ) + +import GHC.Core.Opt.Monad + +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.SrcLoc +import GHC.Types.Tickish +import GHC.Types.Unique.FM ( isNullUFM, sizeUFM ) +import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv ) + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim + +import GHC.Data.Bag +import GHC.Data.List.SetOps + +import GHC.Utils.Monad +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Error +import qualified GHC.Utils.Error as Err +import GHC.Utils.Logger + +import GHC.Data.Pair +import GHC.Base (oneShot) +import GHC.Data.Unboxed + +import Control.Monad +import Data.Foldable ( for_, toList ) +import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty ) +import Data.Maybe +import Data.IntMap.Strict ( IntMap ) +import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList ) + +{- +Note [Core Lint guarantee] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Core Lint is the type-checker for Core. Using it, we get the following guarantee: + +If all of: +1. Core Lint passes, +2. there are no unsafe coercions (i.e. unsafeEqualityProof), +3. all plugin-supplied coercions (i.e. PluginProv) are valid, and +4. all case-matches are complete +then running the compiled program will not seg-fault, assuming no bugs downstream +(e.g. in the code generator). This guarantee is quite powerful, in that it allows us +to decouple the safety of the resulting program from the type inference algorithm. + +However, do note point (4) above. Core Lint does not check for incomplete case-matches; +see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there, +an incomplete case-match might slip by Core Lint and cause trouble at runtime. + +Note [GHC Formalism] +~~~~~~~~~~~~~~~~~~~~ +This file implements the type-checking algorithm for System FC, the "official" +name of the Core language. Type safety of FC is heart of the claim that +executables produced by GHC do not have segmentation faults. Thus, it is +useful to be able to reason about System FC independently of reading the code. +To this purpose, there is a document core-spec.pdf built in docs/core-spec that +contains a formalism of the types and functions dealt with here. If you change +just about anything in this file or you change other types/functions throughout +the Core language (all signposted to this note), you should update that +formalism. See docs/core-spec/README for more info about how to do so. + +Note [check vs lint] +~~~~~~~~~~~~~~~~~~~~ +This file implements both a type checking algorithm and also general sanity +checking. For example, the "sanity checking" checks for TyConApp on the left +of an AppTy, which should never happen. These sanity checks don't really +affect any notion of type soundness. Yet, it is convenient to do the sanity +checks at the same time as the type checks. So, we use the following naming +convention: + +- Functions that begin with 'lint'... are involved in type checking. These + functions might also do some sanity checking. + +- Functions that begin with 'check'... are *not* involved in type checking. + They exist only for sanity checking. + +Issues surrounding variable naming, shadowing, and such are considered *not* +to be part of type checking, as the formalism omits these details. + +Summary of checks +~~~~~~~~~~~~~~~~~ +Checks that a set of core bindings is well-formed. The PprStyle and String +just control what we print in the event of an error. The Bool value +indicates whether we have done any specialisation yet (in which case we do +some extra checks). + +We check for + (a) type errors + (b) Out-of-scope type variables + (c) Out-of-scope local variables + (d) Ill-kinded types + (e) Incorrect unsafe coercions + +If we have done specialisation the we check that there are + (a) No top-level bindings of primitive (unboxed type) + +Note [Linting function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All saturated applications of funTyCon are represented with the FunTy constructor. +See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim + + We check this invariant in lintType. + +Note [Linting type lets] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the desugarer, it's very very convenient to be able to say (in effect) + let a = Type Bool in + let x::a = True in +That is, use a type let. See Note [Core type and coercion invariant] in "GHC.Core". +One place it is used is in mkWwBodies; see Note [Join points and beta-redexes] +in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this feature; I'm not sure). + +* Hence when linting we need to remember that a=Int, else we + might reject a correct program. So we carry a type substitution (in + this example [a -> Bool]) and apply this substitution before + comparing types. In effect, in Lint, type equality is always + equality-modulo-le-subst. This is in the le_subst field of + LintEnv. But nota bene: + + (SI1) The le_subst substitution is applied to types and coercions only + + (SI2) The result of that substitution is used only to check for type + equality, to check well-typed-ness, /but is then discarded/. + The result of substitution does not outlive the CoreLint pass. + + (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders. + +* The function + lintInTy :: Type -> LintM (Type, Kind) + returns a substituted type. + +* When we encounter a binder (like x::a) we must apply the substitution + to the type of the binding variable. lintBinders does this. + +* Clearly we need to clone tyvar binders as we go. + +* But take care (#17590)! We must also clone CoVar binders: + let a = TYPE (ty |> cv) + in \cv -> blah + blindly substituting for `a` might capture `cv`. + +* Alas, when cloning a coercion variable we might choose a unique + that happens to clash with an inner Id, thus + \cv_66 -> let wild_X7 = blah in blah + We decide to clone `cv_66` because it's already in scope. Fine, + choose a new unique. Aha, X7 looks good. So we check the lambda + body with le_subst of [cv_66 :-> cv_X7] + + This is all fine, even though we use the same unique as wild_X7. + As (SI2) says, we do /not/ return a new lambda + (\cv_X7 -> let wild_X7 = blah in ...) + We simply use the le_subst substitution in types/coercions only, when + checking for equality. + +* We still need to check that Id occurrences are bound by some + enclosing binding. We do /not/ use the InScopeSet for the le_subst + for this purpose -- it contains only TyCoVars. Instead we have a separate + le_ids for the in-scope Id binders. + +Sigh. We might want to explore getting rid of type-let! + +Note [Bad unsafe coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions +Linter introduces additional rules that checks improper coercion between +different types, called bad coercions. Following coercions are forbidden: + + (a) coercions between boxed and unboxed values; + (b) coercions between unlifted values of the different sizes, here + active size is checked, i.e. size of the actual value but not + the space allocated for value; + (c) coercions between floating and integral boxed values, this check + is not yet supported for unboxed tuples, as no semantics were + specified for that; + (d) coercions from / to vector type + (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be + coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules + (a-e) holds. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +We check the rules listed in Note [Invariants on join points] in GHC.Core. The +only one that causes any difficulty is the first: All occurrences must be tail +calls. To this end, along with the in-scope set, we remember in le_joins the +subset of in-scope Ids that are valid join ids. For example: + + join j x = ... in + case e of + A -> jump j y -- good + B -> case (jump j z) of -- BAD + C -> join h = jump j w in ... -- good + D -> let x = jump j v in ... -- BAD + +A join point remains valid in case branches, so when checking the A +branch, j is still valid. When we check the scrutinee of the inner +case, however, we set le_joins to empty, and catch the +error. Similarly, join points can occur free in RHSes of other join +points but not the RHSes of value bindings (thunks and functions). + +Note [Avoiding compiler perf traps when constructing error messages.] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's quite common to put error messages into a where clause when it might +be triggered by multiple branches. E.g. + + checkThing x y z = + case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + where + errMsg = text "My error involving:" $$ ppr x <+> ppr y + +However ghc will compile this to: + + checkThink x y z = + let errMsg = text "My error involving:" $$ ppr x <+> ppr y + in case x of + X -> unless (correctX x) $ failWithL errMsg + Y -> unless (correctY y) $ failWithL errMsg + +Putting the allocation of errMsg into the common non-error path. +One way to work around this is to turn errMsg into a function: + + checkThink x y z = + case x of + X -> unless (correctX x) $ failWithL (errMsg x y) + Y -> unless (correctY y) $ failWithL (errMsg x y) + where + errMsg x y = text "My error involving:" $$ ppr x <+> ppr y + +This way `errMsg` is a static function and it being defined in the common +path does not result in allocation in the hot path. This can be surprisingly +impactful. Changing `lint_app` reduced allocations for one test program I was +looking at by ~4%. + +Note [MCInfo for Lint] +~~~~~~~~~~~~~~~~~~~~~~ +When printing a Lint message, use the MCInfo severity so that the +message is printed on stderr rather than stdout (#13342). + +************************************************************************ +* * + Beginning and ending passes +* * +************************************************************************ +-} + +-- | Configuration for boilerplate operations at the end of a +-- compilation pass producing Core. +data EndPassConfig = EndPassConfig + { ep_dumpCoreSizes :: !Bool + -- ^ Whether core bindings should be dumped with the size of what they + -- are binding (i.e. the size of the RHS of the binding). + + , ep_lintPassResult :: !(Maybe LintPassResultConfig) + -- ^ Whether we should lint the result of this pass. + + , ep_namePprCtx :: !NamePprCtx + + , ep_dumpFlag :: !(Maybe DumpFlag) + + , ep_prettyPass :: !SDoc + + , ep_passDetails :: !SDoc + } + +endPassIO :: Logger + -> EndPassConfig + -> CoreProgram -> [CoreRule] + -> IO () +-- Used by the IO-is CorePrep too +endPassIO logger cfg binds rules + = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag + (renderWithContext defaultSDocContext (ep_prettyPass cfg)) + (ep_passDetails cfg) binds rules + ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> + lintPassResult logger lp_cfg binds + } + where + mb_flag = case ep_dumpFlag cfg of + Just flag | logHasDumpFlag logger flag -> Just flag + | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag + _ -> Nothing + +dumpPassResult :: Logger + -> Bool -- dump core sizes? + -> NamePprCtx + -> Maybe DumpFlag -- Just df => show details in a file whose + -- name is specified by df + -> String -- Header + -> SDoc -- Extra info to appear after header + -> CoreProgram -> [CoreRule] + -> IO () +dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules + = do { forM_ mb_flag $ \flag -> do + logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc + + -- Report result size + -- This has the side effect of forcing the intermediate to be evaluated + -- if it's not already forced by a -ddump flag. + ; Err.debugTraceMsg logger 2 size_doc + } + + where + size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))] + + dump_doc = vcat [ nest 2 extra_info + , size_doc + , blankLine + , if dump_core_sizes + then pprCoreBindingsWithSize binds + else pprCoreBindings binds + , ppUnless (null rules) pp_rules ] + pp_rules = vcat [ blankLine + , text "------ Local rules for imported ids --------" + , pprRules rules ] + +{- +************************************************************************ +* * + Top-level interfaces +* * +************************************************************************ +-} + +data LintPassResultConfig = LintPassResultConfig + { lpr_diagOpts :: !DiagOpts + , lpr_platform :: !Platform + , lpr_makeLintFlags :: !LintFlags + , lpr_showLintWarnings :: !Bool + , lpr_passPpr :: !SDoc + , lpr_localsInScope :: ![Var] + } + +lintPassResult :: Logger -> LintPassResultConfig + -> CoreProgram -> IO () +lintPassResult logger cfg binds + = do { let warns_and_errs = lintCoreBindings' + (LintConfig + { l_diagOpts = lpr_diagOpts cfg + , l_platform = lpr_platform cfg + , l_flags = lpr_makeLintFlags cfg + , l_vars = lpr_localsInScope cfg + }) + binds + ; Err.showPass logger $ + "Core Linted result of " ++ + renderWithContext defaultSDocContext (lpr_passPpr cfg) + ; displayLintResults logger + (lpr_showLintWarnings cfg) (lpr_passPpr cfg) + (pprCoreBindings binds) warns_and_errs + } + +displayLintResults :: Logger + -> Bool -- ^ If 'True', display linter warnings. + -- If 'False', ignore linter warnings. + -> SDoc -- ^ The source of the linted program + -> SDoc -- ^ The linted program, pretty-printed + -> WarnsAndErrs + -> IO () +displayLintResults logger display_warnings pp_what pp_pgm (warns, errs) + | not (isEmptyBag errs) + = do { logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] + $ withPprStyle defaultDumpStyle + (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs + , text "*** Offending Program ***" + , pp_pgm + , text "*** End of Offense ***" ]) + ; Err.ghcExit logger 1 } + + | not (isEmptyBag warns) + , log_enable_debug (logFlags logger) + , display_warnings + = logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] + $ withPprStyle defaultDumpStyle + (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) + + | otherwise = return () + +lint_banner :: String -> SDoc -> SDoc +lint_banner string pass = text "*** Core Lint" <+> text string + <+> text ": in result of" <+> pass + <+> text "***" + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs +-- Returns (warnings, errors) +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreBindings' cfg binds + = initL cfg $ + addLoc TopLevelBindings $ + do { -- Check that all top-level binders are distinct + -- We do not allow [NonRec x=1, NonRec y=x, NonRec x=2] + -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal + checkL (null dups) (dupVars dups) + + -- Check for External top level binders with the same M.n name + ; checkL (null ext_dups) (dupExtVars ext_dups) + + -- Typecheck the bindings + ; lintRecBindings TopLevel all_pairs $ \_ -> + return () } + where + all_pairs = flattenBinds binds + -- Put all the top-level binders in scope at the start + -- This is because rewrite rules can bring something + -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal" + binders = map fst all_pairs + + (_, dups) = removeDups compare binders + + -- ext_dups checks for names with different uniques + -- but the same External name M.n. We don't + -- allow this at top level: + -- M.n{r3} = ... + -- M.n{r29} = ... + -- because they both get the same linker symbol + ext_dups = snd $ removeDupsOn ord_ext $ + filter isExternalName $ map Var.varName binders + ord_ext n = (nameModule n, nameOccName n) + +{- +************************************************************************ +* * +\subsection[lintUnfolding]{lintUnfolding} +* * +************************************************************************ + +Note [Linting Unfoldings from Interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use this to check all top-level unfoldings that come in from interfaces +(it is very painful to catch errors otherwise). + +We do not need to call lintUnfolding on unfoldings that are nested within +top-level unfoldings; they are linted when we lint the top-level unfolding; +hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore. + +-} + +lintUnfolding :: Bool -- ^ True <=> is a compulsory unfolding + -> LintConfig + -> SrcLoc + -> CoreExpr + -> Maybe (Bag SDoc) -- Nothing => OK + +lintUnfolding is_compulsory cfg locn expr + | isEmptyBag errs = Nothing + | otherwise = Just errs + where + (_warns, errs) = initL cfg $ + if is_compulsory + -- See Note [Checking for representation polymorphism] + then noFixedRuntimeRepChecks linter + else linter + linter = addLoc (ImportedUnfolding locn) $ + lintCoreExpr expr + +lintExpr :: LintConfig + -> CoreExpr + -> Maybe (Bag SDoc) -- Nothing => OK + +lintExpr cfg expr + | isEmptyBag errs = Nothing + | otherwise = Just errs + where + (_warns, errs) = initL cfg linter + linter = addLoc TopLevelBindings $ + lintCoreExpr expr + +{- +************************************************************************ +* * +\subsection[lintCoreBinding]{lintCoreBinding} +* * +************************************************************************ + +Check a core binding, returning the list of variables bound. +-} + +-- Returns a UsageEnv because this function is called in lintCoreExpr for +-- Let + +lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)] + -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv]) +lintRecBindings top_lvl pairs thing_inside + = lintIdBndrs top_lvl bndrs $ \ bndrs' -> + do { ues <- zipWithM lint_pair bndrs' rhss + ; a <- thing_inside bndrs' + ; return (a, ues) } + where + (bndrs, rhss) = unzip pairs + lint_pair bndr' rhs + = addLoc (RhsOf bndr') $ + do { (rhs_ty, ue) <- lintRhs bndr' rhs -- Check the rhs + ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty + ; return ue } + +lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv) +lintLetBody loc bndrs body + = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body) + ; mapM_ (lintJoinBndrType body_ty) bndrs + ; return (body_ty, body_ue) } + +lintLetBind :: TopLevelFlag -> RecFlag -> OutId + -> CoreExpr -> OutType -> LintM () +-- Binder's type, and the RHS, have already been linted +-- This function checks other invariants +lintLetBind top_lvl rec_flag binder rhs rhs_ty + = do { let binder_ty = idType binder + ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty) + + -- If the binding is for a CoVar, the RHS should be (Coercion co) + -- See Note [Core type and coercion invariant] in GHC.Core + ; checkL (not (isCoVar binder) || isCoArg rhs) + (mkLetErr binder rhs) + + -- Check the let-can-float invariant + -- See Note [Core let-can-float invariant] in GHC.Core + ; checkL ( isJoinId binder + || mightBeLiftedType binder_ty + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed + || exprIsTickedString rhs) + (badBndrTyMsg binder (text "unlifted")) + + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal. + -- See Note [Core top-level string literals]. + ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy) + || exprIsTickedString rhs) + (mkTopNonLitStrMsg binder) + + ; flags <- getLintFlags + + -- Check that a join-point binder has a valid type + -- NB: lintIdBinder has checked that it is not top-level bound + ; case idJoinPointHood binder of + NotJoinPoint -> return () + JoinPoint arity -> checkL (isValidJoinPointType arity binder_ty) + (mkInvalidJoinPointMsg binder binder_ty) + + ; when (lf_check_inline_loop_breakers flags + && isStableUnfolding (realIdUnfolding binder) + && isStrongLoopBreaker (idOccInfo binder) + && isInlinePragma (idInlinePragma binder)) + (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder)) + -- Only non-rule loop breakers inhibit inlining + + -- We used to check that the dmdTypeDepth of a demand signature never + -- exceeds idArity, but that is an unnecessary complication, see + -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal + + -- Check that the binder's arity is within the bounds imposed by the type + -- and the strictness signature. See Note [Arity invariants for bindings] + -- and Note [Trimming arity] + + ; checkL (typeArity (idType binder) >= idArity binder) + (text "idArity" <+> ppr (idArity binder) <+> + text "exceeds typeArity" <+> + ppr (typeArity (idType binder)) <> colon <+> + ppr binder) + + -- See Note [idArity varies independently of dmdTypeDepth] + -- in GHC.Core.Opt.DmdAnal + ; case splitDmdSig (idDmdSig binder) of + (demands, result_info) | isDeadEndDiv result_info -> + if (demands `lengthAtLeast` idArity binder) + then return () + else pprTrace "Hack alert: lintLetBind #24623" + (ppr (idArity binder) $$ ppr (idDmdSig binder)) $ + return () +-- checkL (demands `lengthAtLeast` idArity binder) +-- (text "idArity" <+> ppr (idArity binder) <+> +-- text "exceeds arity imposed by the strictness signature" <+> +-- ppr (idDmdSig binder) <> colon <+> +-- ppr binder) + + _ -> return () + + ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) + + ; addLoc (UnfoldingOf binder) $ + lintIdUnfolding binder binder_ty (idUnfolding binder) + ; return () } + + -- We should check the unfolding, if any, but this is tricky because + -- the unfolding is a SimplifiableCoreExpr. Give up for now. + +-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject occurrences of the function 'makeStatic' when they +-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and +-- for join points, it skips the outer lambdas that take arguments to the +-- join point. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv) +-- NB: the Id can be Linted or not -- it's only used for +-- its OccInfo and join-pointer-hood +lintRhs bndr rhs + | JoinPoint arity <- idJoinPointHood bndr + = lintJoinLams arity (Just bndr) rhs + | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) + = lintJoinLams arity Nothing rhs + +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go + where + -- Allow occurrences of 'makeStatic' at the top-level but produce errors + -- otherwise. + go :: StaticPtrCheck -> LintM (OutType, UsageEnv) + go AllowAtTopLevel + | (binders0, rhs') <- collectTyBinders rhs + , Just (fun, t, info, e) <- collectMakeStaticArgs rhs' + = markAllJoinsBad $ + foldr + -- imitate @lintCoreExpr (Lam ...)@ + lintLambda + -- imitate @lintCoreExpr (App ...)@ + (do fun_ty_ue <- lintCoreExpr fun + lintCoreArgs fun_ty_ue [Type t, info, e] + ) + binders0 + go _ = markAllJoinsBad $ lintCoreExpr rhs + +-- | Lint the RHS of a join point with expected join arity of @n@ (see Note +-- [Join points] in "GHC.Core"). +lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv) +lintJoinLams join_arity enforce rhs + = go join_arity rhs + where + go 0 expr = lintCoreExpr expr + go n (Lam var body) = lintLambda var $ go (n-1) body + go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas + = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs + | otherwise -- Future join point, not yet eta-expanded + = markAllJoinsBad $ lintCoreExpr expr + -- Body of lambda is not a tail position + +lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () +lintIdUnfolding bndr bndr_ty uf + | isStableUnfolding uf + , Just rhs <- maybeUnfoldingTemplate uf + = do { ty <- fst <$> (if isCompulsoryUnfolding uf + then noFixedRuntimeRepChecks $ lintRhs bndr rhs + -- ^^^^^^^^^^^^^^^^^^^^^^^ + -- See Note [Checking for representation polymorphism] + else lintRhs bndr rhs) + ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) } +lintIdUnfolding _ _ _ + = return () -- Do not Lint unstable unfoldings, because that leads + -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars + +{- Note [Checking for INLINE loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very suspicious if a strong loop breaker is marked INLINE. + +However, the desugarer generates instance methods with INLINE pragmas +that form a mutually recursive group. Only after a round of +simplification are they unravelled. So we suppress the test for +the desugarer. Here is an example: + instance Eq T where + t1 == t2 = blah + t1 /= t2 = not (t1 == t2) + {-# INLINE (/=) #-} + +This will generate something like + -- From the class decl for Eq + data Eq a = EqDict (a->a->Bool) (a->a->Bool) + eq_sel :: Eq a -> (a->a->Bool) + eq_sel (EqDict eq _) = eq + + -- From the instance Eq T + $ceq :: T -> T -> Bool + $ceq = blah + + Rec { $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq + + $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not (eq_sel $dfEqT x y) } + +Notice that + +* `$dfEqT` and `$cnotEq` are mutually recursive. + +* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and + we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun + selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop + breaker. + +So we make `$cnoteq` into the loop breaker. That means it can't +inline, despite the INLINE pragma. That's what gives rise to the +warning, which is perfectly appropriate for, say + Rec { {-# INLINE f #-} f = \x -> ...f.... } +We can't inline a recursive function -- it's a loop breaker. + +But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get + Rec { + $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq + + $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not ($ceq x y) } + +and now the dependencies of the Rec have gone, and we can split it up to give + NonRec { $dfEqT :: Eq T {-# DFunId #-} + $dfEqT = EqDict $ceq $cnoteq } + + NonRec { $cnoteq :: T -> T -> Bool {-# INLINE #-} + $cnoteq x y = not ($ceq x y) } + +Now $cnoteq is not a loop breaker any more, so the INLINE pragma can +take effect -- the warning turned out to be temporary. + +To stop excessive warnings, this warning for INLINE loop breakers is +switched off when linting the result of the desugarer. See +lf_check_inline_loop_breakers in GHC.Core.Lint. + + +Note [Checking for representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We ordinarily want to check for bad representation polymorphism. See +Note [Representation polymorphism invariants] in GHC.Core. However, we do *not* +want to do this in a compulsory unfolding. Compulsory unfoldings arise +only internally, for things like newtype wrappers, dictionaries, and +(notably) unsafeCoerce#. These might legitimately be representation-polymorphic; +indeed representation-polymorphic unfoldings are a primary reason for the +very existence of compulsory unfoldings (we can't compile code for +the original, representation-polymorphic, binding). + +It is vitally important that we do representation polymorphism checks *after* +performing the unfolding, but not beforehand. This is all safe because +we will check any unfolding after it has been unfolded; checking the +unfolding beforehand is merely an optimization, and one that actively +hurts us here. + +Note [Linting of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~ +runRW# has some very special behavior (see Note [runRW magic] in +GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing +join points in its argument. For example, this is fine: + + join j x = ... + in runRW# (\s. case v of + A -> j 3 + B -> j 4) + +Usually those calls to the join point 'j' would not be valid tail calls, +because they occur in a function argument. But in the case of runRW# +they are fine, because runRW# (\s.e) behaves operationally just like e. +(runRW# is ultimately inlined in GHC.CoreToStg.Prep.) + +In the case that the continuation is /not/ a lambda we simply disable this +special behaviour. For example, this is /not/ fine: + + join j = ... + in runRW# @r @ty (jump j) + +Note [Coercions in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (Type ty) can occur only as the argument of an application, +or the RHS of a non-recursive Let. But what about (Coercion co)? + +Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose +definition is: + coercible_sel :: Coercible a b => (a ~R# b) + coercible_sel d = case d of + MkCoercibleDict (co :: a ~# b) -> Coercion co + +So this function has a (Coercion co) in the alternative of a case. + +Richard says (!11908): it shouldn't appear outside of arguments, but we've been +loose about this. coercible_sel is some thin ice. Really we should be unpacking +Coercible using case, not a selector. I recall looking into this a few years +back and coming to the conclusion that the fix was worse than the disease. Don't +remember the details, but could probably recover it if we want to revisit. + +So Lint current accepts (Coercion co) in arbitrary places. There is no harm in +that: it really is a value, albeit a zero-bit value. + +************************************************************************ +* * +\subsection[lintCoreExpr]{lintCoreExpr} +* * +************************************************************************ +-} + +lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv) +-- The returned type has the substitution from the monad +-- already applied to it: +-- lintCoreExpr e subst = exprType (subst e) +-- +-- The returned "type" can be a kind, if the expression is (Type ty) + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoreExpr (Var var) + = do { var_pair@(var_ty, _) <- lintIdOcc var 0 + -- See Note [Linting representation-polymorphic builtins] + ; checkRepPolyBuiltin (Var var) [] var_ty + --checkDataToTagPrimOpTyCon (Var var) [] + ; return var_pair } + +lintCoreExpr (Lit lit) + = return (literalType lit, zeroUE) + +lintCoreExpr (Cast expr co) + = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr) + -- markAllJoinsBad: see Note [Join points and casts] + + ; lintCoercion co + ; lintRole co Representational (coercionRole co) + ; Pair from_ty to_ty <- substCoKindM co + ; checkValueType (typeKind to_ty) $ + text "target of cast" <+> quotes (ppr co) + ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty) + ; return (to_ty, ue) } + +lintCoreExpr (Tick tickish expr) + = do { case tickish of + Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0 + _ -> return () + ; markAllJoinsBadIf block_joins $ lintCoreExpr expr } + where + block_joins = not (tickish `tickishScopesLike` SoftScope) + -- TODO Consider whether this is the correct rule. It is consistent with + -- the simplifier's behaviour - cost-centre-scoped ticks become part of + -- the continuation, and thus they behave like part of an evaluation + -- context, but soft-scoped and non-scoped ticks simply wrap the result + -- (see Simplify.simplTick). + +lintCoreExpr (Let (NonRec tv (Type ty)) body) + | isTyVar tv + = -- See Note [Linting type lets] + do { ty' <- lintTypeAndSubst ty + ; lintTyCoBndr tv $ \ tv' -> + do { addLoc (RhsOf tv) $ lintTyKind tv' ty' + -- Now extend the substitution so we + -- take advantage of it in the body + ; extendTvSubstL tv ty' $ + addLoc (BodyOfLet tv) $ + lintCoreExpr body } } + +lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr + = do { -- First Lint the RHS, before bringing the binder into scope + (rhs_ty, let_ue) <- lintRhs bndr rhs + + -- See Note [Multiplicity of let binders] in Var + -- Now lint the binder + ; lintBinder LetBind bndr $ \bndr' -> + do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty + ; addAliasUE bndr' let_ue $ + lintLetBody (BodyOfLet bndr') [bndr'] body } } + + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + +lintCoreExpr e@(Let (Rec pairs) body) + = do { -- Check that the list of pairs is non-empty + checkL (not (null pairs)) (emptyRec e) + + -- Check that there are no duplicated binders + ; let (_, dups) = removeDups compare bndrs + ; checkL (null dups) (dupVars dups) + + -- Check that either all the binders are joins, or none + ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $ + mkInconsistentRecMsg bndrs + + -- See Note [Multiplicity of let binders] in Var + ; ((body_type, body_ue), ues) <- + lintRecBindings NotTopLevel pairs $ \ bndrs' -> + lintLetBody (BodyOfLetRec bndrs') bndrs' body + ; return (body_type, body_ue `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) } + where + bndrs = map fst pairs + +lintCoreExpr e@(App _ _) + | Var fun <- fun + , fun `hasKey` runRWKey + -- See Note [Linting of runRW#] + -- N.B. we may have an over-saturated application of the form: + -- runRW (\s -> \x -> ...) y + , ty_arg1 : ty_arg2 : cont_arg : rest <- args + = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) + lint_rw_cont expr@(Lam _ _) mult fun_ue + = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr + ; let app_ue = addUE fun_ue (scaleUE mult arg_ue) + ; return (arg_ty, app_ue) } + + lint_rw_cont expr mult ue + = lintValArg expr mult ue + -- TODO: Look through ticks? + + ; runrw_pr <- lintApp (text "runRW# expression") + lintTyArg lint_rw_cont + (idType fun) [ty_arg1,ty_arg2,cont_arg] zeroUE + ; lintCoreArgs runrw_pr rest } + + | otherwise + = do { fun_pair <- lintCoreFun fun (length args) + ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args + + -- See Note [Linting representation-polymorphic builtins] + ; checkRepPolyBuiltin fun args app_ty + ; --checkDataToTagPrimOpTyCon fun args + + ; return app_pair} + where + skipTick t = case collectFunSimple e of + (Var v) -> etaExpansionTick v t + _ -> tickishFloatable t + (fun, args, _source_ticks) = collectArgsTicks skipTick e + -- We must look through source ticks to avoid #21152, for example: + -- + -- reallyUnsafePtrEquality + -- = \ @a -> + -- (src reallyUnsafePtrEquality#) + -- @Lifted @a @Lifted @a + -- + -- To do this, we use `collectArgsTicks tickishFloatable` to match + -- the eta expansion behaviour, as per Note [Eta expansion and source notes] + -- in GHC.Core.Opt.Arity. + -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow. + -- See Note [Ticks and mandatory eta expansion] + +lintCoreExpr (Lam var expr) + = markAllJoinsBad $ + lintLambda var $ lintCoreExpr expr + +lintCoreExpr (Case scrut var alt_ty alts) + = lintCaseExpr scrut var alt_ty alts + +-- This case can't happen; linting types in expressions gets routed through lintTyArg +lintCoreExpr (Type ty) + = failWithL (text "Type found as expression" <+> ppr ty) + +lintCoreExpr (Coercion co) + -- See Note [Coercions in terms] + = do { addLoc (InCo co) $ lintCoercion co + ; ty <- substTyM (coercionType co) + ; return (ty, zeroUE) } + +---------------------- +lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed + -> LintM (OutType, UsageEnv) -- returns type of the *variable* +lintIdOcc in_id nargs + = addLoc (OccOf in_id) $ + do { checkL (isNonCoVarId in_id) + (text "Non term variable" <+> ppr in_id) + -- See GHC.Core Note [Variable occurrences in Core] + + -- Check that the type of the occurrence is the same + -- as the type of the binding site. The inScopeIds are + -- /un-substituted/, so this checks that the occurrence type + -- is identical to the binder type. + -- This makes things much easier for things like: + -- /\a. \(x::Maybe a). /\a. ...(x::Maybe a)... + -- The "::Maybe a" on the occurrence is referring to the /outer/ a. + -- If we compared /substituted/ types we'd risk comparing + -- (Maybe a) from the binding site with bogus (Maybe a1) from + -- the occurrence site. Comparing un-substituted types finesses + -- this altogether + ; out_ty <- lintVarOcc in_id + + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + ; lf <- getLintFlags + ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $ + checkL (idName in_id /= makeStaticName) $ + text "Found makeStatic nested in an expression" + + ; checkDeadIdOcc in_id + + ; case isDataConId_maybe in_id of + Nothing -> return () + Just dc -> checkTypeDataConOcc "expression" dc + + ; checkJoinOcc in_id nargs + ; usage <- varCallSiteUsage in_id + + ; return (out_ty, usage) } + + + +lintCoreFun :: CoreExpr + -> Int -- Number of arguments (type or val) being passed + -> LintM (OutType, UsageEnv) -- Returns type of the *function* +lintCoreFun (Var var) nargs + = lintIdOcc var nargs + +lintCoreFun (Lam var body) nargs + -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; + -- See Note [Beta redexes] + | nargs /= 0 + = lintLambda var $ lintCoreFun body (nargs - 1) + +lintCoreFun expr nargs + = markAllJoinsBadIf (nargs /= 0) $ + -- See Note [Join points are less general than the paper] + lintCoreExpr expr +------------------ +lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv) +lintLambda var lintBody = + addLoc (LambdaBodyOf var) $ + lintBinder LambdaBind var $ \ var' -> + do { (body_ty, ue) <- lintBody + ; ue' <- checkLinearity ue var' + ; return (mkLamType var' body_ty, ue') } +------------------ +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (text "Occurrence of a dead Id" <+> ppr id) } + | otherwise + = return () + +------------------ +lintJoinBndrType :: OutType -- Type of the body + -> OutId -- Possibly a join Id + -> LintM () +-- Checks that the return type of a join Id matches the body +-- E.g. join j x = rhs in body +-- The type of 'rhs' must be the same as the type of 'body' +lintJoinBndrType body_ty bndr + | JoinPoint arity <- idJoinPointHood bndr + , let bndr_ty = idType bndr + , (bndrs, res) <- splitPiTys bndr_ty + = checkL (length bndrs >= arity + && body_ty `eqType` mkPiTys (drop arity bndrs) res) $ + hang (text "Join point returns different type than body") + 2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr) + , text "Join arity:" <+> ppr arity + , text "Body type:" <+> ppr body_ty ]) + | otherwise + = return () + +checkJoinOcc :: Id -> JoinArity -> LintM () +-- Check that if the occurrence is a JoinId, then so is the +-- binding site, and it's a valid join Id +checkJoinOcc var n_args + | JoinPoint join_arity_occ <- idJoinPointHood var + = do { mb_join_arity_bndr <- lookupJoinId var + ; case mb_join_arity_bndr of { + NotJoinPoint -> do { join_set <- getValidJoins + ; addErrL (text "join set " <+> ppr join_set $$ + invalidJoinOcc var) } ; + + JoinPoint join_arity_bndr -> + + do { checkL (join_arity_bndr == join_arity_occ) $ + -- Arity differs at binding site and occurrence + mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ + + ; checkL (n_args == join_arity_occ) $ + -- Arity doesn't match #args + mkBadJumpMsg var join_arity_occ n_args } } } + + | otherwise + = return () + +checkTypeDataConOcc :: String -> DataCon -> LintM () +-- Check that the Id is not a data constructor of a `type data` declaration +-- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module +checkTypeDataConOcc what dc + = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $ + (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) + +{- +-- | Check that a use of a dataToTag# primop satisfies conditions DTT2 +-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class +-- +-- Ignores applications not headed by dataToTag# primops. + +-- Commented out because GHC.PrimopWrappers doesn't respect this condition yet. +-- See wrinkle DTW7 in Note [DataToTag overview]. +checkDataToTagPrimOpTyCon + :: CoreExpr -- ^ the function (head of the application) we are checking + -> [CoreArg] -- ^ The arguments to the application + -> LintM () +checkDataToTagPrimOpTyCon (Var fun_id) args + | Just op <- isPrimOpId_maybe fun_id + , op == DataToTagSmallOp || op == DataToTagLargeOp + = case args of + Type _levity : Type dty : _rest + | Just (tc, _) <- splitTyConApp_maybe dty + , isValidDTT2TyCon tc + -> do platform <- getPlatform + let numConstrs = tyConFamilySize tc + isSmallOp = op == DataToTagSmallOp + checkL (isSmallFamily platform numConstrs == isSmallOp) $ + text "dataToTag# primop-size/tycon-family-size mismatch" + | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:" + <+> ppr dty + _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:" + <+> ppr (take 2 args) + +checkDataToTagPrimOpTyCon _ _ = pure () +-} + +-- | Check representation-polymorphic invariants in an application of a +-- built-in function or newtype constructor. +-- +-- See Note [Linting representation-polymorphic builtins]. +checkRepPolyBuiltin :: CoreExpr -- ^ the function (head of the application) we are checking + -> [CoreArg] -- ^ the arguments to the application + -> OutType -- ^ the instantiated type of the overall application + -> LintM () +checkRepPolyBuiltin (Var fun_id) args app_ty + = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags + ; when (do_rep_poly_checks && hasNoBinding fun_id) $ + if + -- (2) representation-polymorphic unlifted newtypes + | Just dc <- isDataConId_maybe fun_id + , isNewDataCon dc + -> if tcHasFixedRuntimeRep $ dataConTyCon dc + then return () + else checkRepPolyNewtypeApp dc args app_ty + + -- (1) representation-polymorphic builtins + | otherwise + -> checkRepPolyBuiltinApp fun_id args + } +checkRepPolyBuiltin _ _ _ = return () + +checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> OutType -> LintM () +checkRepPolyNewtypeApp nt args app_ty + -- If the newtype is saturated, we're OK. + | any isValArg args + = return () + -- Otherwise, check we can eta-expand. + | otherwise + = case getRuntimeArgTys app_ty of + (Scaled _ first_val_arg_ty, _):_ + | not $ typeHasFixedRuntimeRep first_val_arg_ty + -> failWithL (err_msg first_val_arg_ty) + _ -> return () + + where + + err_msg :: Type -> SDoc + err_msg bad_arg_ty + = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot + , text "Its argument type does not have a fixed runtime representation:" + , nest 2 $ ppr_ty_ki bad_arg_ty ] + + ppr_ty_ki :: Type -> SDoc + ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + +checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM () +checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg + where + + conc_binder_positions :: IntMap ConcreteTvOrigin + conc_binder_positions + = concreteTyVarPositions fun_id + $ idDetailsConcreteTvs + $ idDetails fun_id + + max_pos :: Int + max_pos = + case nonEmpty $ IntMap.keys conc_binder_positions of + Nothing -> 0 + Just positions -> maximum positions + + not_concs :: [(SDoc, ConcreteTvOrigin)] + not_concs = + mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing)) + -- NB: 1-indexed + + is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin) + is_bad (pos, mb_arg) + | Just conc_reason <- IntMap.lookup pos conc_binder_positions + , Just bad_ty <- case mb_arg of + Just (Type ki) + | isConcreteType ki + -> Nothing + | otherwise + -- Here we handle the situation in which a "must be concrete" TyVar + -- has been instantiated with a type that is not concrete. + -> Just $ quotes (ppr ki) <+> text "is not concrete." + -- We expected a type argument in this position, and got something else: panic! + Just arg -> + pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $ + vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id) + , text "pos:" <+> ppr pos + , text "arg:" <+> ppr arg ] + Nothing -> + -- Here we handle the situation in which a "must be concrete" TyVar + -- has not been instantiated at all. + case conc_reason of + ConcreteFRR frr_orig -> + let ty = frr_type frr_orig + in Just $ ppr ty <+> dcolon <+> ppr (typeKind ty) + = Just (bad_ty, conc_reason) + | otherwise + = Nothing + + err_msg :: SDoc + err_msg + = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs + + ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc + ppr_not_conc (bad_ty, conc) = + vcat + [ ppr_conc_orig conc + , nest 2 bad_ty ] + + ppr_conc_orig :: ConcreteTvOrigin -> SDoc + ppr_conc_orig (ConcreteFRR frr_orig) = + case frr_orig of + FixedRuntimeRepOrigin { frr_context = ctxt } -> + hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ] + +-- | Compute the 1-indexed positions in the outer forall'd quantified type variables +-- of the type in which the concrete type variables occur. +-- +-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. +concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin +concreteTyVarPositions fun_id conc_tvs + | isNullUFM conc_tvs + = IntMap.empty + | otherwise + = case splitForAllTyCoVars (idType fun_id) of + ([], _) -> IntMap.empty + (tvs, _) -> + let positions = + IntMap.fromList + [ (pos, conc_orig) + | (tv, pos) <- zip tvs [1..] + , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv) + ] + -- Assert that we have as many positions as concrete type variables, + -- i.e. we are not missing any concreteness information. + in assertPpr (sizeUFM conc_tvs == length positions) + (vcat [ text "concreteTyVarPositions: missing concreteness information" + , text "fun_id:" <+> ppr fun_id + , text "tvs:" <+> ppr tvs + , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs) + , text " Actual # of concrete tvs:" <+> ppr (length positions) ]) + positions + +-- Check that the usage of var is consistent with var itself, and pop the var +-- from the usage environment (this is important because of shadowing). +checkLinearity :: UsageEnv -> OutVar -> LintM UsageEnv +checkLinearity body_ue lam_var = + case varMultMaybe lam_var of + Just mult -> do + let (lhs, body_ue') = popUE body_ue lam_var + err_msg = vcat [ text "Linearity failure in lambda:" <+> ppr lam_var + , ppr lhs <+> text "⊈" <+> ppr mult + , ppr body_ue ] + ensureSubUsage lhs mult err_msg + return body_ue' + Nothing -> return body_ue -- A type variable + +{- Note [Join points and casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that this should be OK: + join j x = rhs + in (case e of + A -> alt1 + B x -> (jump j x) |> co) + +You might think that, since the cast is ultimately erased, the jump to +`j` should still be OK as a join point. But no! See #21716. Suppose + + newtype Age = MkAge Int -- axAge :: Age ~ Int + f :: Int -> ... -- f strict in it's first argument + +and consider the expression + + f (join j :: Bool -> Age + j x = (rhs1 :: Age) + in case v of + Just x -> (j x |> axAge :: Int) + Nothing -> rhs2) + +Then, if the Simplifier pushes the strict call into the join points +and alternatives we'll get + + join j' x = f (rhs1 :: Age) + in case v of + Just x -> j' x |> axAge + Nothing -> f rhs2 + +Utterly bogus. `f` expects an `Int` and we are giving it an `Age`. +No no no. Casts destroy the tail-call property. Henc markAllJoinsBad +in the (Cast expr co) case of lintCoreExpr. + +Note [No alternatives lint check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case expressions with no alternatives are odd beasts, and it would seem +like they would worth be looking at in the linter (cf #10180). We +used to check two things: + +* exprIsHNF is false: it would *seem* to be terribly wrong if + the scrutinee was already in head normal form. + +* exprIsDeadEnd is true: we should be able to see why GHC believes the + scrutinee is diverging for sure. + +It was already known that the second test was not entirely reliable. +Unfortunately (#13990), the first test turned out not to be reliable +either. Getting the checks right turns out to be somewhat complicated. + +For example, suppose we have (comment 8) + + data T a where + TInt :: T Int + + absurdTBool :: T Bool -> a + absurdTBool v = case v of + + data Foo = Foo !(T Bool) + + absurdFoo :: Foo -> a + absurdFoo (Foo x) = absurdTBool x + +GHC initially accepts the empty case because of the GADT conditions. But then +we inline absurdTBool, getting + + absurdFoo (Foo x) = case x of + +x is in normal form (because the Foo constructor is strict) but the +case is empty. To avoid this problem, GHC would have to recognize +that matching on Foo x is already absurd, which is not so easy. + +More generally, we don't really know all the ways that GHC can +lose track of why an expression is bottom, so we shouldn't make too +much fuss when that happens. + + +Note [Beta redexes] +~~~~~~~~~~~~~~~~~~~ +Consider: + + join j @x y z = ... in + (\@x y z -> jump j @x y z) @t e1 e2 + +This is clearly ill-typed, since the jump is inside both an application and a +lambda, either of which is enough to disqualify it as a tail call (see Note +[Invariants on join points] in GHC.Core). However, strictly from a +lambda-calculus perspective, the term doesn't go wrong---after the two beta +reductions, the jump *is* a tail call and everything is fine. + +Why would we want to allow this when we have let? One reason is that a compound +beta redex (that is, one with more than one argument) has different scoping +rules: naively reducing the above example using lets will capture any free +occurrence of y in e2. More fundamentally, type lets are tricky; many passes, +such as Float Out, tacitly assume that the incoming program's type lets have +all been dealt with by the simplifier. Thus we don't want to let-bind any types +in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately +before Float Out. + +All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this +loophole, doing so to avoid re-traversing large functions (beta-reducing a type +lambda without introducing a type let requires a substitution). TODO: Improve +simpleOptPgm so that we can forget all this ever happened. + +************************************************************************ +* * +\subsection[lintCoreArgs]{lintCoreArgs} +* * +************************************************************************ + +The basic version of these functions checks that the argument is a +subtype of the required type, as one would expect. +-} + +-- Takes the functions type and arguments as argument. +-- Returns the *result* of applying the function to arguments. +-- e.g. f :: Int -> Bool -> Int would return `Int` as result type. +lintCoreArgs :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv) +lintCoreArgs (fun_ty, fun_ue) args + = lintApp (text "expression") + lintTyArg lintValArg fun_ty args fun_ue + +lintTyArg :: InExpr -> LintM OutType + +-- Type argument +lintTyArg (Type arg_ty) + = do { checkL (not (isCoercionTy arg_ty)) + (text "Unnecessary coercion-to-type injection:" + <+> ppr arg_ty) + ; lintTypeAndSubst arg_ty } +lintTyArg arg + = failWithL (hang (text "Expected type argument but found") 2 (ppr arg)) + +lintValArg :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv) +lintValArg arg mult fun_ue + = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg + -- See Note [Representation polymorphism invariants] in GHC.Core + + ; flags <- getLintFlags + ; when (lf_check_fixed_rep flags) $ + -- Only check that 'arg_ty' has a fixed RuntimeRep + -- if 'lf_check_fixed_rep' is on. + do { checkL (typeHasFixedRuntimeRep arg_ty) + (text "Argument does not have a fixed runtime representation" + <+> ppr arg <+> dcolon + <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) } + + ; let app_ue = addUE fun_ue (scaleUE mult arg_ue) + ; return (arg_ty, app_ue) } + +----------------- +lintAltBinders :: UsageEnv + -> Var -- Case binder + -> OutType -- Scrutinee type + -> OutType -- Constructor type + -> [(Mult, OutVar)] -- Binders + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] + = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) + ; return rhs_ue } +lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs) + | isTyVar bndr + = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) + ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty' bndrs } + | otherwise + = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE + -- We can pass zeroUE to lintValApp because we ignore its usage + -- calculation and compute it in the call for checkCaseLinearity below. + ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr + ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs } + +-- | Implements the case rules for linearity +checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv +checkCaseLinearity ue case_bndr var_w bndr = do + ensureSubUsage lhs rhs err_msg + lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (idMult bndr) + return $ deleteUE ue bndr + where + lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage) + rhs = case_bndr_w `mkMultMul` var_w + err_msg = (text "Linearity failure in variable:" <+> ppr bndr + $$ ppr lhs <+> text "⊈" <+> ppr rhs + $$ text "Computed by:" + <+> text "LHS:" <+> lhs_formula + <+> text "RHS:" <+> rhs_formula) + lhs_formula = ppr bndr_usage <+> text "+" + <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w) + rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w + case_bndr_w = idMult case_bndr + case_bndr_usage = lookupUE ue case_bndr + bndr_usage = lookupUE ue bndr + + + +----------------- +lintTyApp :: OutType -> OutType -> LintM OutType +lintTyApp fun_ty arg_ty + | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty + = do { lintTyKind tv arg_ty + ; in_scope <- getInScope + -- substTy needs the set of tyvars in scope to avoid generating + -- uniques that are already in scope. + -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst + ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) } + + | otherwise + = failWithL (mkTyAppMsg fun_ty arg_ty) + +----------------- + +-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ +-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the +-- application. +lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv + -> LintM (OutType, UsageEnv) +lintValApp arg fun_ty arg_ty fun_ue arg_ue + | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty + = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg) + ; let app_ue = addUE fun_ue (scaleUE w arg_ue) + ; return (res_ty', app_ue) } + | otherwise + = failWithL err2 + where + err2 = mkNonFunAppMsg fun_ty arg_ty arg + +lintTyKind :: OutTyVar -> OutType -> LintM () +-- Both args have had substitution applied + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintTyKind tyvar arg_ty + = unless (arg_kind `eqType` tyvar_kind) $ + addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind)) + where + tyvar_kind = tyVarKind tyvar + arg_kind = typeKind arg_ty + +{- +************************************************************************ +* * +\subsection[lintCoreAlts]{lintCoreAlts} +* * +************************************************************************ +-} + +lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv) +lintCaseExpr scrut case_bndr alt_ty alts + = do { let e = Case scrut case_bndr alt_ty alts -- Just for error messages + + -- Check the scrutinee + ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut + -- See Note [Join points are less general than the paper] + -- in GHC.Core + + ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty + + ; checkCaseAlts e scrut scrut_ty' alts + + -- Lint the case-binder. Must do this after linting the scrutinee + -- because the case-binder isn't in scope in the scrutineex + ; lintBinder CaseBind case_bndr $ \case_bndr' -> + -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate + + do { let case_bndr_ty' = idType case_bndr' + scrut_mult = idMult case_bndr' + + ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty') + -- See GHC.Core Note [Case expression invariants] item (7) + + ; -- Check the alternatives + ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts + ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues + ; return (alt_ty', case_ue) } } + +checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM () +-- a) Check that the alts are non-empty +-- b1) Check that the DEFAULT comes first, if it exists +-- b2) Check that the others are in increasing order +-- c) Check that there's a default for infinite types +-- d) Check that the scrutinee is not a floating-point type +-- if there are any literal alternatives +-- e) Check if the scrutinee type has no constructors +-- +-- We used to try to check whether a case expression with no +-- alternatives was legitimate, but this didn't work. +-- See Note [No alternatives lint check] for details. +-- +-- NB: Algebraic cases are not necessarily exhaustive, because +-- the simplifier correctly eliminates case that can't +-- possibly match. +checkCaseAlts e scrut scrut_ty alts + = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e) + -- See GHC.Core Note [Case expression invariants] item (2) + + ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e) + -- See GHC.Core Note [Case expression invariants] item (3) + + -- For types Int#, Word# with an infinite (well, large!) number of + -- possible values, there should usually be a DEFAULT case + -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to + -- have *no* case alternatives. + -- In effect, this is a kind of partial test. I suppose it's possible + -- that we might *know* that 'x' was 1 or 2, in which case + -- case x of { 1 -> e1; 2 -> e2 } + -- would be fine. + ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts) + (nonExhaustiveAltsMsg e) + + -- Check that the scrutinee is not a floating-point type + -- if there are any literal alternatives + -- See GHC.Core Note [Case expression invariants] item (5) + -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold + ; checkL (not $ isFloatingPrimTy scrut_ty && any is_lit_alt alts) + (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)." + $$ text "scrut" <+> ppr scrut) + + -- Check if scrutinee type has no constructors + -- Just a trace message for now + ; case tyConAppTyCon_maybe scrut_ty of + Just tycon + | debugIsOn + , isAlgTyCon tycon + , not (isAbstractTyCon tycon) + , null (tyConDataCons tycon) + , not (exprIsDeadEnd scrut) + -> pprTrace "Lint warning: case scrutinee type has no constructors" + (ppr scrut_ty) + -- This can legitimately happen for type families + $ return () + _otherwise -> return () + } + where + (con_alts, maybe_deflt) = findDefault alts + + -- Check that successive alternatives have strictly increasing tags + increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest + increasing_tag _ = True + + non_deflt (Alt DEFAULT _ _) = False + non_deflt _ = True + + is_lit_alt (Alt (LitAlt _) _ _) = True + is_lit_alt _ = False + + is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of + Nothing -> False + Just tycon -> isPrimTyCon tycon + +lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv +lintAltExpr expr ann_ty + = do { (actual_ty, ue) <- lintCoreExpr expr + ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) + ; return ue } + -- See GHC.Core Note [Case expression invariants] item (6) + +lintCoreAlt :: OutId -- Case binder + -> OutType -- Type of scrutinee + -> Mult -- Multiplicity of scrutinee + -> OutType -- Type of the alternative + -> CoreAlt + -> LintM UsageEnv +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) = + do { lintL (null args) (mkDefaultArgsMsg args) + ; rhs_ue <- lintAltExpr rhs alt_ty + ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr + err_msg = vcat [ text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr + , ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult ] + ; ensureSubUsage case_bndr_usage scrut_mult err_msg + ; return rhs_ue' } + +lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs) + | litIsLifted lit + = failWithL integerScrutinisedMsg + | otherwise + = do { lintL (null args) (mkDefaultArgsMsg args) + ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty) + ; rhs_ue <- lintAltExpr rhs alt_ty + ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks + } + where + lit_ty = literalType lit + +lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs) + | isNewTyCon (dataConTyCon con) + = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt) + | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty + = addLoc (CaseAlt alt) $ do + { checkTypeDataConOcc "pattern" con + ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) + + -- Instantiate the universally quantified + -- type variables of the data constructor + ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys + ; binderMult (Named _) = ManyTy + ; binderMult (Anon st _) = scaledMult st + -- See Note [Validating multiplicities in a case] + ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty } + + -- And now bring the new binders into scope + ; lintBinders CasePatBind args $ \ args' -> do + { rhs_ue <- lintAltExpr rhs alt_ty + ; rhs_ue' <- addLoc (CasePat alt) $ + lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty + (zipEqual multiplicities args') + ; return $ deleteUE rhs_ue' case_bndr + } + } + + | otherwise -- Scrut-ty is wrong shape + = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) + +{- +Note [Validating multiplicities in a case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose 'MkT :: a %m -> T m a'. +If we are validating 'case (x :: T Many a) of MkT y -> ...', +we have to substitute m := Many in the type of MkT - in particular, +y can be used Many times and that expression would still be linear in x. +We do this by looking at con_payload_ty, which is the type of the datacon +applied to the surrounding arguments. +Testcase: linear/should_compile/MultConstructor + +Data constructors containing existential tyvars will then have +Named binders, which are always multiplicity Many. +Testcase: indexed-types/should_compile/GADT1 +-} + +lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () +lintLinearBinder doc actual_usage described_usage + = ensureSubMult actual_usage described_usage err_msg + where + err_msg = (text "Multiplicity of variable does not agree with its context" + $$ doc + $$ ppr actual_usage + $$ text "Annotation:" <+> ppr described_usage) + +{- +************************************************************************ +* * +\subsection[lint-types]{Types} +* * +************************************************************************ +-} + +-- When we lint binders, we (one at a time and in order): +-- 1. Lint var types or kinds (possibly substituting) +-- 2. Add the binder to the in scope set, and if its a coercion var, +-- we may extend the substitution to reflect its (possibly) new kind +lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a +lintBinders _ [] linterF = linterF [] +lintBinders site (var:vars) linterF = lintBinder site var $ \var' -> + lintBinders site vars $ \ vars' -> + linterF (var':vars') + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a +lintBinder site var linterF + | isTyCoVar var = lintTyCoBndr var linterF + | otherwise = lintIdBndr NotTopLevel site var linterF + +lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a +lintTyCoBndr tcv thing_inside + = do { tcv_type' <- lintTypeAndSubst (varType tcv) + ; let tcv_kind' = typeKind tcv_type' + + -- See (FORALL1) and (FORALL2) in GHC.Core.Type + ; if (isTyVar tcv) + then -- Check that in (forall (a:ki). blah) we have ki:Type + lintL (isLiftedTypeKind tcv_kind') $ + hang (text "TyVar whose kind does not have kind Type:") + 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind') + else -- Check that in (forall (cv::ty). blah), + -- then ty looks like (t1 ~# t2) + lintL (isCoVarType tcv_type') $ + text "CoVar with non-coercion type:" <+> pprTyVar tcv + + ; addInScopeTyCoVar tcv tcv_type' thing_inside } + +lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a +lintIdBndrs top_lvl ids thing_inside + = go ids thing_inside + where + go :: [Id] -> ([Id] -> LintM a) -> LintM a + go [] thing_inside = thing_inside [] + go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' -> + go ids $ \ids' -> + thing_inside (id' : ids') + +lintIdBndr :: TopLevelFlag -> BindingSite + -> InVar -> (OutVar -> LintM a) -> LintM a +-- Do substitution on the type of a binder and add the var with this +-- new type to the in-scope set of the second argument +-- ToDo: lint its rules +lintIdBndr top_lvl bind_site id thing_inside + = assertPpr (isId id) (ppr id) $ + do { flags <- getLintFlags + ; checkL (not (lf_check_global_ids flags) || isLocalId id) + (text "Non-local Id binder" <+> ppr id) + -- See Note [Checking for global Ids] + + -- Check that if the binder is nested, it is not marked as exported + ; checkL (not (isExportedId id) || is_top_lvl) + (mkNonTopExportedMsg id) + + -- Check that if the binder is nested, it does not have an external name + ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl) + (mkNonTopExternalNameMsg id) + + -- See Note [Representation polymorphism invariants] in GHC.Core + ; lintL (isJoinId id || not (lf_check_fixed_rep flags) + || typeHasFixedRuntimeRep id_ty) $ + text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+> + parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty)) + + -- Check that a join-id is a not-top-level let-binding + ; when (isJoinId id) $ + checkL (not is_top_lvl && is_let_bind) $ + mkBadJoinBindMsg id + + -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2); + -- if so, it should be a CoVar, and checked by lintCoVarBndr + ; lintL (not (isCoVarType id_ty)) + (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty) + + -- Check that the lambda binder has no value or OtherCon unfolding. + -- See #21496 + ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id))) + (text "Lambda binder with value or OtherCon unfolding.") + + ; out_ty <- addLoc (IdTy id) (lintValueType id_ty) + + ; addInScopeId id out_ty thing_inside } + where + id_ty = idType id + + is_top_lvl = isTopLevel top_lvl + is_let_bind = case bind_site of + LetBind -> True + _ -> False + +{- +%************************************************************************ +%* * + Types +%* * +%************************************************************************ +-} + +{- Note [Linting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that + lintType :: InType -> LintM () + lintCoercion :: InCoercion -> LintM () +Neither returns anything. + +If you need the kind of the type, then do `typeKind` and then apply +the ambient substitution using `substTyM`. Note that the substitution +empty unless there is shadowing or type-lets; and if the substitution is +empty, the `substTyM` is a no-op. + +It is better to take the kind and then substitute, rather than substitute +and then take the kind, becaues the kind is usually smaller. + +Note: you might wonder if we should apply the same logic to expressions. +Why do we have + lintExpr :: InExpr -> LintM OutType +Partly inertia; but also taking the type of an expresison involve looking +down a deep chain of let's, whereas that is not true of taking the kind +of a type. It'd be worth an experiment though. + +Historical note: in the olden days we had + lintType :: InType -> LintM OutType +but that burned a huge amount of allocation building an OutType that was +often discarded, or used only to get its kind. + +I also experimented with + lintType :: InType -> LintM OutKind +but that too was slower. It is also much simpler to return ()! If we +return the kind we have to duplicate the logic in `typeKind`; and it is +much worse for coercions. +-} + +lintValueType :: Type -> LintM OutType +-- Types only, not kinds +-- Check the type, and apply the substitution to it +-- See Note [Linting type lets] +lintValueType ty + = addLoc (InType ty) $ + do { ty' <- lintTypeAndSubst ty + ; let sk = typeKind ty' + ; lintL (isTYPEorCONSTRAINT sk) $ + hang (text "Ill-kinded type:" <+> ppr ty) + 2 (text "has kind:" <+> ppr sk) + ; return ty' } + +checkTyCon :: TyCon -> LintM () +checkTyCon tc + = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc) + +------------------- +lintTypeAndSubst :: InType -> LintM OutType +lintTypeAndSubst ty = do { lintType ty; substTyM ty } + -- In GHCi we may lint an expression with a free + -- type variable. Then it won't be in the + -- substitution, but it should be in scope + +lintType :: InType -> LintM () +-- See Note [Linting types and coercions] +-- +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintType (TyVarTy tv) + | not (isTyVar tv) + = failWithL (mkBadTyVarMsg tv) + + | otherwise + = do { _ <- lintVarOcc tv + ; return () } + +lintType ty@(AppTy t1 t2) + | TyConApp {} <- t1 + = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty + | otherwise + = do { let (fun_ty, arg_tys) = collect t1 [t2] + ; lintType fun_ty + ; fun_kind <- substTyM (typeKind fun_ty) + ; lint_ty_app ty fun_kind arg_tys } + where + collect (AppTy f a) as = collect f (a:as) + collect fun as = (fun, as) + +lintType ty@(TyConApp tc tys) + | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc + = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags + ; lintTySynFamApp report_unsat ty tc tys } + + | Just {} <- tyConAppFunTy_maybe tc tys + -- We should never see a saturated application of funTyCon; such + -- applications should be represented with the FunTy constructor. + -- See Note [Linting function types] + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty)) + + | otherwise -- Data types, data families, primitive types + = do { checkTyCon tc + ; lint_ty_app ty (tyConKind tc) tys } + +-- arrows can related *unlifted* kinds, so this has to be separate from +-- a dependent forall. +lintType ty@(FunTy af tw t1 t2) + = do { lintType t1 + ; lintType t2 + ; lintType tw + ; lintArrow (text "type or kind" <+> quotes (ppr ty)) af t1 t2 tw } + +lintType ty@(ForAllTy {}) + = go [] ty + where + go :: [OutTyCoVar] -> InType -> LintM () + -- Loop, collecting the forall-binders + go tcvs ty@(ForAllTy (Bndr tcv _) body_ty) + | not (isTyCoVar tcv) + = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty) + + | otherwise + = lintTyCoBndr tcv $ \tcv' -> + do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] + -- Suspicious because it works on InTyCoVar; c.f. ForAllCo + when (isCoVar tcv) $ + lintL (anyFreeVarsOfType (== tcv) body_ty) $ + text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty) + + ; go (tcv' : tcvs) body_ty } + + go tcvs body_ty + = do { lintType body_ty + ; lintForAllBody tcvs body_ty } + +lintType (CastTy ty co) + = do { lintType ty + ; ty_kind <- substTyM (typeKind ty) + ; co_lk <- lintStarCoercion co + ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) } + +lintType (LitTy l) = lintTyLit l +lintType (CoercionTy co) = lintCoercion co + +----------------- +lintForAllBody :: [OutTyCoVar] -> InType -> LintM () +-- Do the checks for the body of a forall-type +lintForAllBody tcvs body_ty + = do { -- For type variables, check for skolem escape + -- See Note [Phantom type variables in kinds] in GHC.Core.Type + -- The kind of (forall cv. th) is liftedTypeKind, so no + -- need to check for skolem-escape in the CoVar case + body_kind <- substTyM (typeKind body_ty) + ; case occCheckExpand tcvs body_kind of + Just {} -> return () + Nothing -> failWithL $ + hang (text "Variable escape in forall:") + 2 (vcat [ text "tycovars (reversed):" <+> ppr tcvs + , text "type:" <+> ppr body_ty + , text "kind:" <+> ppr body_kind ]) + ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) } + +----------------- +lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM () +-- The TyCon is a type synonym or a type family (not a data family) +-- See Note [Linting type synonym applications] +-- c.f. GHC.Tc.Validity.check_syn_tc_app +lintTySynFamApp report_unsat ty tc tys + | report_unsat -- Report unsaturated only if report_unsat is on + , tys `lengthLessThan` tyConArity tc + = failWithL (hang (text "Un-saturated type application") 2 (ppr ty)) + + -- Deal with type synonyms + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys + , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys' + = do { when report_unsat $ do { _ <- lintType expanded_ty + ; return () } + + ; -- Kind-check the argument types, but without reporting + -- un-saturated type families/synonyms + ; setReportUnsat False $ + lint_ty_app ty (tyConKind tc) tys } + + -- Otherwise this must be a type family + | otherwise + = lint_ty_app ty (tyConKind tc) tys + +----------------- +-- Confirms that a kind is really TYPE r or Constraint +checkValueType :: OutKind -> SDoc -> LintM () +checkValueType kind doc + = lintL (isTYPEorCONSTRAINT kind) + (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$ + text "when checking" <+> doc) + +----------------- +lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] +lintArrow what af t1 t2 tw -- Eg lintArrow "type or kind `blah'" k1 k2 kw + -- or lintArrow "coercion `blah'" k1 k2 kw + = do { k1 <- substTyM (typeKind t1) + ; k2 <- substTyM (typeKind t2) + ; kw <- substTyM (typeKind tw) + ; unless (isTYPEorCONSTRAINT k1) (report (text "argument") t1 k1) + ; unless (isTYPEorCONSTRAINT k2) (report (text "result") t2 k2) + ; unless (isMultiplicityTy kw) (report (text "multiplicity") tw kw) + + ; let real_af = chooseFunTyFlag t1 t2 + ; unless (real_af == af) $ addErrL $ + hang (text "Bad FunTyFlag") + 2 (vcat [ text "FunTyFlag =" <+> ppr af + , text "Computed FunTyFlag =" <+> ppr real_af + , text "in" <+> what ]) } + where + report ar t k = addErrL (hang (text "Ill-kinded" <+> ar) + 2 (vcat [ ppr t <+> dcolon <+> ppr k + , text "in" <+> what ])) + +----------------- +lintTyLit :: TyLit -> LintM () +lintTyLit (NumTyLit n) + | n >= 0 = return () + | otherwise = failWithL msg + where msg = text "Negative type literal:" <+> integer n +lintTyLit (StrTyLit _) = return () +lintTyLit (CharTyLit _) = return () + +----------------- +lint_ty_app :: InType -> OutKind -> [InType] -> LintM () +lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty)) + +lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM () +lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co)) + +lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM () +lint_tyco_app msg fun_kind arg_tys + -- See Note [Avoiding compiler perf traps when constructing error messages.] + = do { _ <- lintApp msg (\ty -> do { lintType ty; substTyM ty }) + (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) }) + fun_kind arg_tys () + ; return () } + +---------------- +lintApp :: forall in_a acc. Outputable in_a => + SDoc + -> (in_a -> LintM OutType) -- Lint the thing and return its value + -> (in_a -> Mult -> acc -> LintM (OutKind, acc)) -- Lint the thing and return its type + -> OutType + -> [in_a] -- The arguments, always "In" things + -> acc -- Used (only) for UsageEnv in /term/ applications + -> LintM (OutType,acc) +-- lintApp is a performance-critical function, which deals with multiple +-- applications such as (/\a./\b./\c. expr) @ta @tb @tc +-- When returning the type of this expression we want to avoid substituting a:=ta, +-- and /then/ substituting b:=tb, etc. That's quadratic, and can be a huge +-- perf hole. So we gather all the arguments [in_a], and then gather the +-- substitution incrementally in the `go` loop. +-- +-- lintApp is used: +-- * for term applications (lintCoreArgs) +-- * for type applications (lint_ty_app) +-- * for coercion application (lint_co_app) +-- To deal with these cases `lintApp` has two higher order arguments; +-- but we specialise it for each call site (by inlining) +{-# INLINE lintApp #-} -- INLINE: very few call sites; + -- not recursive; specialised at its call sites + +lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc + = do { !in_scope <- getInScope + -- We need the in_scope set to satisfy the invariant in + -- Note [The substitution invariant] in GHC.Core.TyCo.Subst + -- Forcing the in scope set eagerly here reduces allocations by up to 4%. + + ; let init_subst = mkEmptySubst in_scope + + go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc) + -- The Subst applies (only) to the fun_ty + -- c.f. GHC.Core.Type.piResultTys, which has a similar loop + + go subst fun_ty acc [] + = return (substTy subst fun_ty, acc) + + go subst (ForAllTy (Bndr tv _vis) body_ty) acc (arg:args) + = do { arg' <- lint_forall_arg arg + ; let tv_kind = substTy subst (varType tv) + karg' = typeKind arg' + subst' = extendTCvSubst subst tv arg' + ; ensureEqTys karg' tv_kind $ + lint_app_fail_msg msg orig_fun_ty all_args + (hang (text "Forall:" <+> (ppr tv $$ ppr tv_kind)) + 2 (ppr arg' <+> dcolon <+> ppr karg')) + ; go subst' body_ty acc args } + + go subst fun_ty@(FunTy _ mult exp_arg_ty res_ty) acc (arg:args) + = do { (arg_ty, acc') <- lint_arrow_arg arg (substTy subst mult) acc + ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $ + lint_app_fail_msg msg orig_fun_ty all_args + (hang (text "Fun:" <+> ppr fun_ty) + 2 (vcat [ text "exp_arg_ty:" <+> ppr exp_arg_ty + , text "arg:" <+> ppr arg <+> dcolon <+> ppr arg_ty ])) + ; go subst res_ty acc' args } + + go subst fun_ty acc args + | Just fun_ty' <- coreView fun_ty + = go subst fun_ty' acc args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst (substTy subst fun_ty) acc args + + | otherwise + = failWithL (lint_app_fail_msg msg orig_fun_ty all_args + (text "Not a fun:" <+> (ppr fun_ty $$ ppr args))) + + ; go init_subst orig_fun_ty acc all_args } + +-- This is a top level definition to ensure we pass all variables of the error message +-- explicitly and don't capture them as free variables. Otherwise this binder might +-- become a thunk that get's allocated in the hot code path. +-- See Note [Avoiding compiler perf traps when constructing error messages.] +lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc +lint_app_fail_msg msg kfn arg_tys extra + = vcat [ hang (text "Application error in") 2 msg + , nest 2 (text "Function type =" <+> ppr kfn) + , nest 2 (text "Args =" <+> ppr arg_tys) + , extra ] + +{- ********************************************************************* +* * + Linting rules +* * +********************************************************************* -} + +lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM () +lintCoreRule _ _ (BuiltinRule {}) + = return () -- Don't bother + +lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs }) + = lintBinders LambdaBind bndrs $ \ _ -> + do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args + ; (rhs_ty, _) <- case idJoinPointHood fun of + JoinPoint join_arity + -> do { checkL (args `lengthIs` join_arity) $ + mkBadJoinPointRuleMsg fun join_arity rule + -- See Note [Rules for join points] + ; lintCoreExpr rhs } + _ -> markAllJoinsBad $ lintCoreExpr rhs + ; ensureEqTys lhs_ty rhs_ty $ + (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty + , text "rhs type:" <+> ppr rhs_ty + , text "fun_ty:" <+> ppr fun_ty ]) + ; let bad_bndrs = filter is_bad_bndr bndrs + + ; checkL (null bad_bndrs) + (rule_doc <+> text "unbound" <+> ppr bad_bndrs) + -- See Note [Linting rules] + } + where + rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon + + lhs_fvs = exprsFreeVars args + rhs_fvs = exprFreeVars rhs + + is_bad_bndr :: Var -> Bool + -- See Note [Unbound RULE binders] in GHC.Core.Rules + is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs) + && bndr `elemVarSet` rhs_fvs + && isNothing (isReflCoVar_maybe bndr) + + +{- Note [Linting rules] +~~~~~~~~~~~~~~~~~~~~~~~ +It's very bad if simplifying a rule means that one of the template +variables (ru_bndrs) that /is/ mentioned on the RHS becomes +not-mentioned in the LHS (ru_args). How can that happen? Well, in #10602, +SpecConstr stupidly constructed a rule like + + forall x,c1,c2. + f (x |> c1 |> c2) = .... + +But simplExpr collapses those coercions into one. (Indeed in #10602, +it collapsed to the identity and was removed altogether.) + +We don't have a great story for what to do here, but at least +this check will nail it. + +NB (#11643): it's possible that a variable listed in the +binders becomes not-mentioned on both LHS and RHS. Here's a silly +example: + RULE forall x y. f (g x y) = g (x+1) (y-1) +And suppose worker/wrapper decides that 'x' is Absent. Then +we'll end up with + RULE forall x y. f ($gw y) = $gw (x+1) +This seems sufficiently obscure that there isn't enough payoff to +try to trim the forall'd binder list. + +Note [Rules for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point cannot be partially applied. However, the left-hand side of a rule +for a join point is effectively a *pattern*, not a piece of code, so there's an +argument to be made for allowing a situation like this: + + join $sj :: Int -> Int -> String + $sj n m = ... + j :: forall a. Eq a => a -> a -> String + {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-} + j @a $dEq x y = ... + +Applying this rule can't turn a well-typed program into an ill-typed one, so +conceivably we could allow it. But we can always eta-expand such an +"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact +the simplifier would have to in order to deal with the RHS. So we take a +conservative view and don't allow undersaturated rules for join points. See +Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion. +-} + +{- +************************************************************************ +* * + Linting coercions +* * +************************************************************************ +-} + +{- Note [Asymptotic efficiency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting coercions (and types actually) we return a linted +(substituted) coercion. Then we often have to take the coercionKind of +that returned coercion. If we get long chains, that can be asymptotically +inefficient, notably in +* TransCo +* InstCo +* SelCo (cf #9233) +* LRCo + +But the code is simple. And this is only Lint. Let's wait to see if +the bad perf bites us in practice. + +A solution would be to return the kind and role of the coercion, +as well as the linted coercion. Or perhaps even *only* the kind and role, +which is what used to happen. But that proved tricky and error prone +(#17923), so now we return the coercion. +-} + + +-- lintStarCoercion lints a coercion, confirming that its lh kind and +-- its rh kind are both *; also ensures that the role is Nominal +-- Returns the lh kind +lintStarCoercion :: InCoercion -> LintM OutType +lintStarCoercion g + = do { lintCoercion g + ; Pair t1 t2 <- substCoKindM g + ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g) + ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g) + ; lintRole g Nominal (coercionRole g) + ; return t1 } + +substCoKindM :: InCoercion -> LintM (Pair OutType) +substCoKindM co + = do { let !(Pair lk rk) = coercionKind co + ; lk' <- substTyM lk + ; rk' <- substTyM rk + ; return (Pair lk' rk') } + +lintCoercion :: HasDebugCallStack => InCoercion -> LintM () +-- See Note [Linting types and coercions] +-- +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] + +lintCoercion (CoVarCo cv) + | not (isCoVar cv) + = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv) + 2 (text "With offending type:" <+> ppr (varType cv))) + + | otherwise -- C.f. lintType (TyVarTy tv), which has better docs + = do { _ <- lintVarOcc cv; return () } + +lintCoercion (Refl ty) = lintType ty +lintCoercion (GRefl _r ty MRefl) = lintType ty + +lintCoercion (GRefl _r ty (MCo co)) + = do { lintType ty + ; lintCoercion co + ; tk <- substTyM (typeKind ty) + ; tl <- substTyM (coercionLKind co) + ; ensureEqTys tk tl $ + hang (text "GRefl coercion kind mis-match:" <+> ppr co) + 2 (vcat [ppr ty, ppr tk, ppr tl]) + ; lintRole co Nominal (coercionRole co) } + +lintCoercion co@(TyConAppCo r tc cos) + | Just {} <- tyConAppFunCo_maybe r tc cos + = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) + 2 (ppr co)) + -- All saturated TyConAppCos should be FunCos + + | Just {} <- synTyConDefn_maybe tc + = failWithL (text "Synonym in TyConAppCo:" <+> ppr co) + + | otherwise + = do { checkTyCon tc + ; mapM_ lintCoercion cos + ; let tc_kind = tyConKind tc + ; lint_co_app co tc_kind (map coercionLKind cos) + ; lint_co_app co tc_kind (map coercionRKind cos) + ; zipWithM_ (lintRole co) (tyConRoleListX r tc) (map coercionRole cos) } + + +lintCoercion co@(AppCo co1 co2) + | TyConAppCo {} <- co1 + = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co) + | Just (TyConApp {}, _) <- isReflCo_maybe co1 + = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co) + | otherwise + = do { lintCoercion co1 + ; lintCoercion co2 + ; let !(Pair lt1 rt1) = coercionKind co1 + ; lk1 <- substTyM (typeKind lt1) + ; rk1 <- substTyM (typeKind rt1) + ; lint_co_app co lk1 [coercionLKind co2] + ; lint_co_app co rk1 [coercionRKind co2] + + ; let r2 = coercionRole co2 + ; if coercionRole co1 == Phantom + then lintL (r2 == Phantom || r2 == Nominal) + (text "Second argument in AppCo cannot be R:" $$ + ppr co) + else lintRole co Nominal r2 } + +---------- +lintCoercion co@(ForAllCo {}) +-- See Note [ForAllCo] in GHC.Core.TyCo.Rep for the typing rule for ForAllCo + = do { _ <- go [] co; return () } + where + go :: [OutTyCoVar] -- Binders in reverse order + -> InCoercion -> LintM Role + go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = body_co }) + | not (isTyCoVar tcv) + = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co) + + | otherwise + = do { lk <- lintStarCoercion kind_co + ; lintTyCoBndr tcv $ \tcv' -> + do { ensureEqTys (varType tcv') lk $ + text "Kind mis-match in ForallCo" <+> ppr co + + -- I'm not very sure about this part, because it traverses body_co + -- but at least it's on a cold path (a ForallCo for a CoVar) + -- Also it works on InTyCoVar and InCoercion, which is suspect + ; when (isCoVar tcv) $ + do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $ + text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co + -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep + ; lintL (almostDevoidCoVarOfCo tcv body_co) $ + text "Covar can only appear in Refl and GRefl: " <+> ppr co } + -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep + + ; role <- go (tcv':tcvs) body_co + + ; when (role == Nominal) $ + lintL (visL `eqForAllVis` visR) $ + text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co + + ; return role } } + + go tcvs body_co + = do { lintCoercion body_co + + -- Need to check that + -- (forall (tcv:k1). lty) and + -- (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv]) + -- are both well formed, including the skolem escape check. + -- Easiest way is to call lintForAllBody for each + ; let Pair lty rty = coercionKind body_co + ; lintForAllBody tcvs lty + ; lintForAllBody tcvs rty + + ; return (coercionRole body_co) } + + +lintCoercion (FunCo { fco_role = r, fco_afl = afl, fco_afr = afr + , fco_mult = cow, fco_arg = co1, fco_res = co2 }) + = do { lintCoercion co1 + ; lintCoercion co2 + ; lintCoercion cow + ; let Pair lt1 rt1 = coercionKind co1 + Pair lt2 rt2 = coercionKind co2 + Pair ltw rtw = coercionKind cow + ; lintArrow (bad_co_msg "arrowl") afl lt1 lt2 ltw + ; lintArrow (bad_co_msg "arrowr") afr rt1 rt2 rtw + ; lintRole co1 r (coercionRole co1) + ; lintRole co2 r (coercionRole co2) + ; let expected_mult_role = case r of + Phantom -> Phantom + _ -> Nominal + ; lintRole cow expected_mult_role (coercionRole cow) } + where + bad_co_msg s = hang (text "Bad coercion" <+> parens (text s)) + 2 (vcat [ text "afl:" <+> ppr afl + , text "afr:" <+> ppr afr + , text "arg_co:" <+> ppr co1 + , text "res_co:" <+> ppr co2 ]) + +-- See Note [Bad unsafe coercion] +lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov + , uco_lty = ty1, uco_rty = ty2, uco_deps = deps }) + = do { -- Check the role. PhantomProv must have Phantom role, otherwise any role is fine + case prov of + PhantomProv -> lintRole co Phantom r + _ -> return () + + -- Check the to and from types + ; lintType ty1 + ; lintType ty2 + ; tk1 <- substTyM (typeKind ty1) + ; tk2 <- substTyM (typeKind ty2) + + ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2) + (checkTypes ty1 ty2) + + -- Check the coercions on which this UnivCo depends + ; mapM_ lintCoercion deps } + where + report s = hang (text $ "Unsafe coercion: " ++ s) + 2 (vcat [ text "From:" <+> ppr ty1 + , text " To:" <+> ppr ty2]) + isUnBoxed :: PrimRep -> Bool + isUnBoxed = not . isGcPtrRep + + -- see #9122 for discussion of these checks + checkTypes t1 t2 + = do { checkWarnL fixed_rep_1 + (report "left-hand type does not have a fixed runtime representation") + ; checkWarnL fixed_rep_2 + (report "right-hand type does not have a fixed runtime representation") + ; when (fixed_rep_1 && fixed_rep_2) $ + do { checkWarnL (reps1 `equalLength` reps2) + (report "between values with different # of reps") + ; zipWithM_ validateCoercion reps1 reps2 }} + where + fixed_rep_1 = typeHasFixedRuntimeRep t1 + fixed_rep_2 = typeHasFixedRuntimeRep t2 + + -- don't look at these unless lev_poly1/2 are False + -- Otherwise, we get #13458 + reps1 = typePrimRep t1 + reps2 = typePrimRep t2 + + validateCoercion :: PrimRep -> PrimRep -> LintM () + validateCoercion rep1 rep2 + = do { platform <- getPlatform + ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) + (report "between unboxed and boxed value") + ; checkWarnL (TyCon.primRepSizeB platform rep1 + == TyCon.primRepSizeB platform rep2) + (report "between unboxed values of different size") + ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) + (TyCon.primRepIsFloat rep2) + ; case fl of + Nothing -> addWarnL (report "between vector types") + Just False -> addWarnL (report "between float and integral values") + _ -> return () + } + +lintCoercion (SymCo co) = lintCoercion co + +lintCoercion co@(TransCo co1 co2) + = do { lintCoercion co1 + ; lintCoercion co2 + ; rk1 <- substTyM (coercionRKind co1) + ; lk2 <- substTyM (coercionLKind co2) + ; ensureEqTys rk1 lk2 + (hang (text "Trans coercion mis-match:" <+> ppr co) + 2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)])) + ; lintRole co (coercionRole co1) (coercionRole co2) } + +lintCoercion the_co@(SelCo cs co) + = do { lintCoercion co + ; Pair s t <- substCoKindM co + + ; if -- forall (both TyVar and CoVar) + | Just _ <- splitForAllTyCoVar_maybe s + , Just _ <- splitForAllTyCoVar_maybe t + , SelForAll <- cs + , (isForAllTy_ty s && isForAllTy_ty t) + || (isForAllTy_co s && isForAllTy_co t) + -> return () + + -- function + | isFunTy s + , isFunTy t + , SelFun {} <- cs + -> return () + + -- TyCon + | Just (tc_s, tys_s) <- splitTyConApp_maybe s + , Just (tc_t, tys_t) <- splitTyConApp_maybe t + , tc_s == tc_t + , SelTyCon n r0 <- cs + , let co_role = coercionRole co + , isInjectiveTyCon tc_s co_role + -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep + , tys_s `equalLength` tys_t + , tys_s `lengthExceeds` n + -> do { lintRole the_co (tyConRole co_role tc_s n) r0 + ; return () } + + | otherwise + -> failWithL (hang (text "Bad SelCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + +lintCoercion the_co@(LRCo _lr co) + = do { lintCoercion co + ; Pair s t <- substCoKindM co + ; lintRole co Nominal (coercionRole co) + ; case (splitAppTy_maybe s, splitAppTy_maybe t) of + (Just {}, Just {}) -> return () + _ -> failWithL (hang (text "Bad LRCo:") + 2 (ppr the_co $$ ppr s $$ ppr t)) } + + +lintCoercion orig_co@(InstCo co arg) + = go co [arg] + where + go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) } + go co args = do { lintCoercion co + ; let Pair lty rty = coercionKind co + ; lty' <- substTyM lty + ; rty' <- substTyM rty + ; in_scope <- getInScope + ; let subst = mkEmptySubst in_scope + ; go_args (subst, lty') (subst,rty') args } + + ------------- + go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion] + -> LintM () + go_args _ _ [] + = return () + go_args lty rty (arg:args) + = do { (lty1, rty1) <- go_arg lty rty arg + ; go_args lty1 rty1 args } + + ------------- + go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion + -> LintM ((Subst,OutType), (Subst,OutType)) + go_arg (lsubst,lty) (rsubst,rty) arg + = do { lintRole arg Nominal (coercionRole arg) + ; Pair arg_lty arg_rty <- substCoKindM arg + + ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of + -- forall over tvar + (Just (ltv,lty1), Just (rtv,rty1)) + | typeKind arg_lty `eqType` substTy lsubst (tyVarKind ltv) + , typeKind arg_rty `eqType` substTy rsubst (tyVarKind rtv) + -> return ( (extendTCvSubst lsubst ltv arg_lty, lty1) + , (extendTCvSubst rsubst rtv arg_rty, rty1) ) + | otherwise + -> failWithL (hang (text "Kind mis-match in inst coercion") + 2 (vcat [ text "arg" <+> ppr arg + , text "lty" <+> ppr lty <+> dcolon <+> ppr (typeKind lty) + , text "rty" <+> ppr rty <+> dcolon <+> ppr (typeKind rty) + , text "arg_lty" <+> ppr arg_lty <+> dcolon <+> ppr (typeKind arg_lty) + , text "arg_rty" <+> ppr arg_rty <+> dcolon <+> ppr (typeKind arg_rty) + , text "ltv" <+> ppr ltv <+> dcolon <+> ppr (tyVarKind ltv) + , text "rtv" <+> ppr rtv <+> dcolon <+> ppr (tyVarKind rtv) ])) + + _ -> failWithL (text "Bad argument of inst" <+> ppr orig_co) } + +lintCoercion this_co@(AxiomCo ax cos) + = do { mapM_ lintCoercion cos + ; lint_roles 0 (coAxiomRuleArgRoles ax) cos + ; prs <- mapM substCoKindM cos + ; lint_ax ax prs } + + where + lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM () + lint_ax (BuiltInFamRew bif) prs + = checkL (isJust (bifrw_proves bif prs)) bad_bif + lint_ax (BuiltInFamInj bif) prs + = checkL (case prs of + [pr] -> isJust (bifinj_proves bif pr) + _ -> False) + bad_bif + lint_ax (UnbranchedAxiom ax) prs + = lintBranch this_co (coAxiomTyCon ax) (coAxiomSingleBranch ax) prs + lint_ax (BranchedAxiom ax ind) prs + = do { checkL (0 <= ind && ind < numBranches (coAxiomBranches ax)) + (bad_ax this_co (text "index out of range")) + ; lintBranch this_co (coAxiomTyCon ax) (coAxiomNthBranch ax ind) prs } + + bad_bif = bad_ax this_co (text "Proves returns Nothing") + + err :: forall a. String -> [SDoc] -> LintM a + err m xs = failWithL $ + hang (text m) 2 $ vcat (text "Rule:" <+> ppr ax : xs) + + lint_roles n (e : es) (co:cos) + | e == coercionRole co + = lint_roles (n+1) es cos + | otherwise = err "Argument roles mismatch" + [ text "In argument:" <+> int (n+1) + , text "Expected:" <+> ppr e + , text "Found:" <+> ppr (coercionRole co) ] + lint_roles _ [] [] = return () + lint_roles n [] rs = err "Too many coercion arguments" + [ text "Expected:" <+> int n + , text "Provided:" <+> int (n + length rs) ] + + lint_roles n es [] = err "Not enough coercion arguments" + [ text "Expected:" <+> int (n + length es) + , text "Provided:" <+> int n ] + +lintCoercion (KindCo co) = lintCoercion co + +lintCoercion (SubCo co) + = do { lintCoercion co + ; lintRole co Nominal (coercionRole co) } + +lintCoercion (HoleCo h) + = failWithL (text "Unfilled coercion hole:" <+> ppr h) + +{- +Note [Conflict checking for axiom applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } + +The coercion (axEqual[1] <*> ) :: (Equal * Int Int ~ False) + +and that all is OK. But, all is not OK: we want to use the first branch of the +axiom in this case, not the second. The problem is that the parameters of the +first branch can unify with the supplied coercions, thus meaning that the first +branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv". + +For more details, see the section "Branched axiom conflict checking" in +docs/core-spec, which defines the corresponding no_conflict function used by the +Co_AxiomInstCo rule in the section "Coercion typing". +-} + +-- | Check to make sure that an axiom application is internally consistent. +-- Returns the conflicting branch, if it exists +-- Note [Conflict checking for axiom applications] +lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM () +-- defined here to avoid dependencies in GHC.Core.Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +lintBranch this_co fam_tc branch arg_kinds + | CoAxBranch { cab_tvs = ktvs, cab_cvs = cvs } <- branch + = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $ + (bad_ax this_co (text "lengths")) + + ; subst <- getSubst + ; let empty_subst = zapSubst subst + ; _ <- foldlM check_ki (empty_subst, empty_subst) + (zip (ktvs ++ cvs) arg_kinds) + + ; case check_no_conflict target incomps of + Nothing -> return () + Just bad_branch -> failWithL $ bad_ax this_co $ + text "inconsistent with" <+> + pprCoAxBranch fam_tc bad_branch } + where + check_ki (subst_l, subst_r) (ktv, Pair s' t') + = do { let sk' = typeKind s' + tk' = typeKind t' + ; let ktv_kind_l = substTy subst_l (tyVarKind ktv) + ktv_kind_r = substTy subst_r (tyVarKind ktv) + ; checkL (sk' `eqType` ktv_kind_l) + (bad_ax this_co (text "check_ki1" <+> vcat [ ppr this_co, ppr sk', ppr ktv, ppr ktv_kind_l ] )) + ; checkL (tk' `eqType` ktv_kind_r) + (bad_ax this_co (text "check_ki2" <+> vcat [ ppr this_co, ppr tk', ppr ktv, ppr ktv_kind_r ] )) + ; return (extendTCvSubst subst_l ktv s', + extendTCvSubst subst_r ktv t') } + + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map pFst arg_kinds) + co_args = map stripCoercionTy cotys + subst = zipTvSubst tvs tys `composeTCvSubst` + zipCvSubst cvs co_args + target = Type.substTys subst (coAxBranchLHS branch) + + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in GHC.Core.FamInstEnv + | SurelyApart <- tcUnifyTysFG alwaysBindFam alwaysBindTv flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b + +bad_ax :: Coercion -> SDoc -> SDoc +bad_ax this_co what + = hang (text "Bad axiom application" <+> parens what) 2 (ppr this_co) + + +{- +************************************************************************ +* * + Axioms +* * +************************************************************************ +-} + +lintAxioms :: Logger + -> LintConfig + -> SDoc -- ^ The source of the linted axioms + -> [CoAxiom Branched] + -> IO () +lintAxioms logger cfg what axioms = + displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ + initL cfg $ + do { mapM_ lint_axiom axioms + ; let axiom_groups = groupWith coAxiomTyCon axioms + ; mapM_ lint_axiom_group axiom_groups } + +lint_axiom :: CoAxiom Branched -> LintM () +lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches + , co_ax_role = ax_role }) + = addLoc (InAxiom ax) $ + do { mapM_ (lint_branch tc) branch_list + ; extra_checks } + where + branch_list = fromBranches branches + + extra_checks + | isNewTyCon tc + = do { CoAxBranch { cab_tvs = ax_tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs_tys } + <- case branch_list of + [branch] -> return branch + _ -> failWithL (text "multi-branch axiom with newtype") + + -- The LHS of the axiom is (N lhs_tys) + -- We expect it to be (N ax_tvs) + ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys) + (text "Newtype axiom LHS does not match newtype definition") + ; lintL (null cvs) + (text "Newtype axiom binds coercion variables") + ; lintL (null eta_tvs) -- See Note [Eta reduction for data families] + -- which is not about newtype axioms + (text "Newtype axiom has eta-tvs") + ; lintL (ax_role == Representational) + (text "Newtype axiom role not representational") + ; lintL (roles `equalLength` ax_tvs) + (text "Newtype axiom roles list is the wrong length." $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (roles == takeList roles (tyConRoles tc)) + (vcat [ text "Newtype axiom roles do not match newtype tycon's." + , text "axiom roles:" <+> sep (map ppr roles) + , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ]) + } + + | isFamilyTyCon tc + = do { if | isTypeFamilyTyCon tc + -> lintL (ax_role == Nominal) + (text "type family axiom is not nominal") + + | isDataFamilyTyCon tc + -> lintL (ax_role == Representational) + (text "data family axiom is not representational") + + | otherwise + -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc) + + ; mapM_ (lint_family_branch tc) branch_list } + + | otherwise + = addErrL (text "Axiom tycon is neither a newtype nor a family.") + +lint_branch :: TyCon -> CoAxBranch -> LintM () +lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs_args, cab_rhs = rhs }) + = lintBinders LambdaBind (tvs ++ cvs) $ \_ -> + do { let lhs = mkTyConApp ax_tc lhs_args + ; lintType lhs + ; lintType rhs + ; lhs_kind <- substTyM (typeKind lhs) + ; rhs_kind <- substTyM (typeKind rhs) + ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $ + hang (text "Inhomogeneous axiom") + 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ + text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } + -- Type and Constraint are not Apart, so this test allows + -- the newtype axiom for a single-method class. Indeed the + -- whole reason Type and Constraint are not Apart is to allow + -- such axioms! + +-- these checks do not apply to newtype axioms +lint_family_branch :: TyCon -> CoAxBranch -> LintM () +lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_roles = roles + , cab_lhs = lhs + , cab_incomps = incomps }) + = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs) + (text "Type family axiom has eta-tvs") + ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs) + (text "Quantified variable in family axiom unused in LHS") + ; lintL (all isTyFamFree lhs) + (text "Type family application on LHS of family axiom") + ; lintL (all (== Nominal) roles) + (text "Non-nominal role in family axiom" $$ + text "roles:" <+> sep (map ppr roles)) + ; lintL (null cvs) + (text "Coercion variables bound in family axiom") + ; forM_ incomps $ \ br' -> + lintL (not (compatibleBranches br br')) $ + hang (text "Incorrect incompatible branches:") + 2 (vcat [text "Branch:" <+> ppr br, + text "Bogus incomp:" <+> ppr br']) } + +lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM () +lint_axiom_group (_ :| []) = return () +lint_axiom_group (ax :| axs) + = do { lintL (isOpenFamilyTyCon tc) + (text "Non-open-family with multiple axioms") + ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs + , ax2 <- all_axs ] + ; mapM_ (lint_axiom_pair tc) all_pairs } + where + all_axs = ax : axs + tc = coAxiomTyCon ax + +lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM () +lint_axiom_pair tc (ax1, ax2) + | Just br1@(CoAxBranch { cab_tvs = tvs1 + , cab_lhs = lhs1 + , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1 + , Just br2@(CoAxBranch { cab_tvs = tvs2 + , cab_lhs = lhs2 + , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2 + = lintL (compatibleBranches br1 br2) $ + vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2 + , text "are incompatible" ] + , text "tvs1 =" <+> pprTyVars tvs1 + , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1) + , text "rhs1 =" <+> ppr rhs1 + , text "tvs2 =" <+> pprTyVars tvs2 + , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2) + , text "rhs2 =" <+> ppr rhs2 ] + + | otherwise + = addErrL (text "Open type family axiom has more than one branch: either" <+> + ppr ax1 <+> text "or" <+> ppr ax2) + +{- +************************************************************************ +* * +\subsection[lint-monad]{The Lint monad} +* * +************************************************************************ +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] +data LintEnv + = LE { le_flags :: LintFlags -- Linting the result of this pass + , le_loc :: [LintLocInfo] -- Locations + + , le_subst :: Subst + -- Current substitution, for TyCoVars only. + -- Non-CoVar Ids don't appear in here, not even in the InScopeSet + -- Used for (a) cloning to avoid shadowing of TyCoVars, + -- so that eqType works ok + -- (b) substituting for let-bound tyvars, when we have + -- (let @a = Int -> Int in ...) + + , le_in_vars :: VarEnv (InVar, OutType) + -- Maps an InVar (i.e. its unique) to its binding InVar + -- and to its OutType + -- /All/ in-scope variables are here (term variables, + -- type variables, and coercion variables) + -- Used at an occurrence of the InVar + + , le_joins :: IdSet -- Join points in scope that are valid + -- A subset of the InScopeSet in le_subst + -- See Note [Join points] + + , le_ue_aliases :: NameEnv UsageEnv + -- See Note [Linting linearity] + -- Assigns usage environments to the alias-like binders, + -- as found in non-recursive lets. + -- Domain is OutIds + + , le_platform :: Platform -- ^ Target platform + , le_diagOpts :: DiagOpts -- ^ Target platform + } + +data LintFlags + = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] + , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs] + , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications] + , lf_check_linearity :: Bool -- ^ See Note [Linting linearity] + , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism] + } + +-- See Note [Checking StaticPtrs] +data StaticPtrCheck + = AllowAnywhere + -- ^ Allow 'makeStatic' to occur anywhere. + | AllowAtTopLevel + -- ^ Allow 'makeStatic' calls at the top-level only. + | RejectEverywhere + -- ^ Reject any 'makeStatic' occurrence. + deriving Eq + +newtype LintM a = + LintM' { unLintM :: + LintEnv -> + WarnsAndErrs -> -- Warning and error messages so far + LResult a } -- Result and messages (if any) + + +pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern LintM m <- LintM' m + where + LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we) + -- LintM m = LintM' (oneShot $ oneShot m) +{-# COMPLETE LintM #-} + +instance Functor (LintM) where + fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w) + +type WarnsAndErrs = (Bag SDoc, Bag SDoc) + +-- Using a unboxed tuple here reduced allocations for a lint heavy +-- file by ~6%. Using MaybeUB reduced them further by another ~12%. +-- +-- Warning: if you don't inline the matcher for JustUB etc, Lint becomes +-- /tremendously/ inefficient, and compiling GHC.Tc.Errors.Types (which +-- contains gigantic types) is very very slow indeed. Conclusion: make +-- sure unfoldings are expose in GHC.Data.Unboxed, and that you compile +-- Lint.hs with optimistation on. +type LResult a = (# MaybeUB a, WarnsAndErrs #) + +pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a +pattern LResult m w = (# m, w #) +{-# COMPLETE LResult #-} + +mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2 +mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w + +-- Just for testing. +fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a +fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs +fromBoxedLResult (Nothing,errs) = LResult NothingUB errs + +{- Note [Checking for global Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before CoreTidy, all locally-bound Ids must be LocalIds, even +top-level ones. See Note [Exported LocalIds] and #9857. + +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. + +Every occurrence of the function 'makeStatic' should be moved to the +top level by the FloatOut pass. It's vital that we don't have nested +'makeStatic' occurrences after CorePrep, because we populate the Static +Pointer Table from the top-level bindings. See SimplCore Note [Grand +plan for static forms]. + +The linter checks that no occurrence is left behind, nested within an +expression. The check is enabled only after the FloatOut, CorePrep, +and CoreTidy passes and only if the module uses the StaticPointers +language extension. Checking more often doesn't help since the condition +doesn't hold until after the first FloatOut pass. + +Note [Type substitution] +~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we need a type substitution? Consider + /\(a:*). \(x:a). /\(a:*). id a x +This is ill typed, because (renaming variables) it is really + /\(a:*). \(x:a). /\(b:*). id b x +Hence, when checking an application, we can't naively compare x's type +(at its binding site) with its expected type (at a use site). So we +rename type binders as we go, maintaining a substitution. + +The same substitution also supports let-type, current expressed as + (/\(a:*). body) ty +Here we substitute 'ty' for 'a' in 'body', on the fly. + +Note [Linting type synonym applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When linting a type-synonym, or type-family, application + S ty1 .. tyn +we behave as follows (#15057, #T15664): + +* If lf_report_unsat_syns = True, and S has arity < n, + complain about an unsaturated type synonym or type family + +* Switch off lf_report_unsat_syns, and lint ty1 .. tyn. + + Reason: catch out of scope variables or other ill-kinded gubbins, + even if S discards that argument entirely. E.g. (#15012): + type FakeOut a = Int + type family TF a + type instance TF Int = FakeOut a + Here 'a' is out of scope; but if we expand FakeOut, we conceal + that out-of-scope error. + + Reason for switching off lf_report_unsat_syns: with + LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they + are saturated when the type is expanded. Example + type T f = f Int + type S a = a -> a + type Z = T S + In Z's RHS, S appears unsaturated, but it is saturated when T is expanded. + +* If lf_report_unsat_syns is on, expand the synonym application and + lint the result. Reason: want to check that synonyms are saturated + when the type is expanded. + +Note [Linting linearity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Lint ignores linearity unless `-dlinear-core-lint` is set. For why, see below. + +* When do we /check linearity/ in Lint? That is, when is `-dlinear-core-lint` + lint set? Answer: we check linearity in the output of the desugarer, shortly + after type checking. + +* When so we /not/ check linearity in Lint? On all passes after desugaring. Why? + Because optimisation passes are not (yet) guaranteed to maintain linearity. + They should do so semantically (GHC is careful not to duplicate computation) + but it is much harder to ensure that the statically-checkable constraints of + Linear Core are maintained. See examples below. + +The current Linear Core is described in the wiki at: +https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation. + +Concretely, "ignore linearity in Lint" specifically means two things: +* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity` +* In `ensureSubMult`, do nothing + +Here are some examples of how the optimiser can break linearity checking. Other +examples are documented in the linear-type implementation wiki page +[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes] + +* EXAMPLE 1: the binder swap transformation + Consider + + data T = MkT {-# UNPACK #-} !Int + + The wrapper for MkT is + + $wMkT :: Int %1 -> T + $wMkT n = case %1 n of + I# n' -> MkT n' + + This introduces, in particular, a `case %1` (this is not actual Haskell or + Core syntax), where the `%1` means that the `case` expression consumes its + scrutinee linearly. + + Now, `case %1` interacts with the binder swap optimisation in a non-trivial + way. Take a slightly modified version of the code for $wMkT: + + case %1 x of z { + I# n' -> (x, n') + } + + Binder-swap changes this to + + case %1 x of z { + I# n' -> let x = z in (x, n') + } + + This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly + 2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees + two uses of n' where there should be a single one. + +* EXAMPLE 2: letrec + Some optimisations can create a letrec which uses a variable + linearly, e.g. + + letrec f True = f False + f False = x + in f True + + uses 'x' linearly, but this is not seen by the linter, which considers, + conservatively, that a letrec always has multiplicity Many (in particular + that every captured free variable must have multiplicity Many). This issue + is discussed in ticket #18694. + +* EXAMPLE 3: rewrite rules + Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be + treated the same by rewrite rules (see also Note [Rewrite rules ignore + multiplicities in FunTy] in GHC.Core.Unify). Consider + + m :: Bool -> A + m' :: (Bool -> Bool) -> A + {- RULES "ex" forall f. m (f True) = m' f -} + + f :: Bool %1 -> A + x = m (f True) + + The rule "ex" must match . So the linter must accept `m' f`. + +* EXAMPLE 4: eta-reduction + Eta-expansion can change linear functions into unrestricted functions + + f :: A %1 -> B + + g :: A %Many -> B + g = \x -> f x + + Eta-reduction undoes this and produces: + + g :: A %Many -> B + g = f + +Historical note: In the original linear-types implementation, we had tried to +make every optimisation pass produce code that passes `-dlinear-core-lint`. It +had proved very difficult. We kept finding corner case after corner +case. Furthermore, to attempt to achieve that goal we ended up restricting +transformations when `-dlinear-core-lint` couldn't typecheck the result. + +In the future, we may be able to lint the linearity of the output of +Core-to-Core passes (#19165). But this shouldn't be done at the expense of +producing efficient code. Therefore we lay the following principle. + +PRINCIPLE: The type system bends to the optimisation, not the other way around. + +There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123 + +Note [Linting representation-polymorphic builtins] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Representation-polymorphism checking built-ins], on +top of the two main representation-polymorphism invariants described in the +Note [Representation polymorphism invariants], we must perform additional +representation-polymorphism checks on builtin functions which don't have a +binding, for example to ensure that we don't run afoul of the +representation-polymorphism invariants when eta-expanding. + +There are two situations: + + 1. Builtins which have skolem type variables which must be instantiated to + concrete types, such as the RuntimeRep type argument r to the catch# primop. + + 2. Representation-polymorphic unlifted newtypes, which must always be instantiated + at a fixed runtime representation. + +For 1, consider for example 'coerce': + + coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b + +We store in the IdDetails of the coerce Id that the first binder, r, must always +be instantiated to a concrete type. We thus check this in Core Lint: whenever we +see an application of the form + + coerce @{rep1} ... + +we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp". +Moreover, not instantiating these type variables at all is also an error, as +we would again not be able to perform eta-expansion. (This is a bit more theoretical, +as in user programs the typechecker will insert these type applications when +instantiating, but it can still arise when constructing Core expressions). + +For 2, whenever we have an unlifted newtype such as + + type RR :: Type -> RuntimeRep + type family RR a + + type F :: forall (a :: Type) -> TYPE (RR a) + type family F a + + type N :: forall (a :: Type) -> TYPE (RR a) + newtype N a = MkN (F a) + +and an unsaturated occurrence + + MkN @ty -- NB: no value argument! + +we check that the (instantiated) argument type has a fixed runtime representation. +This is done in the function "checkRepPolyNewtypeApp". +-} + +instance Applicative LintM where + pure x = LintM $ \ _ errs -> LResult (JustUB x) errs + --(Just x, errs) + (<*>) = ap + +instance Monad LintM where + m >>= k = LintM (\ env errs -> + let res = unLintM m env errs in + case res of + LResult (JustUB r) errs' -> unLintM (k r) env errs' + LResult NothingUB errs' -> LResult NothingUB errs' + ) + -- LError errs'-> LError errs') + -- let (res, errs') = unLintM m env errs in + -- Just r -> unLintM (k r) env errs' + -- Nothing -> (Nothing, errs')) + +instance MonadFail LintM where + fail err = failWithL (text err) + +getPlatform :: LintM Platform +getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs)) + +data LintLocInfo + = RhsOf Id -- The variable bound + | OccOf Id -- Occurrence of id + | LambdaBodyOf Id -- The lambda-binder + | RuleOf Id -- Rules attached to a binder + | UnfoldingOf Id -- Unfolding of a binder + | BodyOfLet Id -- The let-bound variable + | BodyOfLetRec [Id] -- The binders of the let + | CaseAlt CoreAlt -- Case alternative + | CasePat CoreAlt -- The *pattern* of the case alternative + | CaseTy CoreExpr -- The type field of a case expression + -- with this scrutinee + | IdTy Id -- The type field of an Id binder + | AnExpr CoreExpr -- Some expression + | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) + | TopLevelBindings + | InType Type -- Inside a type + | InCo Coercion -- Inside a coercion + | InAxiom (CoAxiom Branched) -- Inside a CoAxiom + +data LintConfig = LintConfig + { l_diagOpts :: !DiagOpts -- ^ Diagnostics opts + , l_platform :: !Platform -- ^ Target platform + , l_flags :: !LintFlags -- ^ Linting the result of this pass + , l_vars :: ![Var] -- ^ 'Id's that should be treated as being in scope + } + +initL :: LintConfig + -> LintM a -- ^ Action to run + -> WarnsAndErrs +initL cfg m + = case unLintM m env (emptyBag, emptyBag) of + LResult (JustUB _) errs -> errs + LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs + | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++ + "without reporting an error message") empty + where + vars = l_vars cfg + env = LE { le_flags = l_flags cfg + , le_subst = mkEmptySubst (mkInScopeSetList vars) + , le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ] + , le_joins = emptyVarSet + , le_loc = [] + , le_ue_aliases = emptyNameEnv + , le_platform = l_platform cfg + , le_diagOpts = l_diagOpts cfg + } + +setReportUnsat :: Bool -> LintM a -> LintM a +-- Switch off lf_report_unsat_syns +setReportUnsat ru thing_inside + = LintM $ \ env errs -> + let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } } + in unLintM thing_inside env' errs + +-- See Note [Checking for representation polymorphism] +noFixedRuntimeRepChecks :: LintM a -> LintM a +noFixedRuntimeRepChecks thing_inside + = LintM $ \env errs -> + let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } } + in unLintM thing_inside env' errs + +getLintFlags :: LintM LintFlags +getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs) + +checkL :: Bool -> SDoc -> LintM () +checkL True _ = return () +checkL False msg = failWithL msg + +-- like checkL, but relevant to type checking +lintL :: Bool -> SDoc -> LintM () +lintL = checkL + +checkWarnL :: Bool -> SDoc -> LintM () +checkWarnL True _ = return () +checkWarnL False msg = addWarnL msg + +failWithL :: SDoc -> LintM a +failWithL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Nothing, (warns, addMsg True env errs msg)) + +addErrL :: SDoc -> LintM () +addErrL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Just (), (warns, addMsg True env errs msg)) + +addWarnL :: SDoc -> LintM () +addWarnL msg = LintM $ \ env (warns,errs) -> + fromBoxedLResult (Just (), (addMsg True env warns msg, errs)) + +addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc +addMsg show_context env msgs msg + = assertPpr (notNull loc_msgs) msg $ + msgs `snocBag` mk_msg msg + where + loc_msgs :: [(SrcLoc, SDoc)] -- Innermost first + loc_msgs = map dumpLoc (le_loc env) + + cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs + , text "Substitution:" <+> ppr (le_subst env) ] + + context | show_context = cxt_doc + | otherwise = whenPprDebug cxt_doc + -- Print voluminous info for Lint errors + -- but not for warnings + + msg_span = case [ span | (loc,_) <- loc_msgs + , let span = srcLocSpan loc + , isGoodSrcSpan span ] of + [] -> noSrcSpan + (s:_) -> s + !diag_opts = le_diagOpts env + mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span + (msg $$ context) + +addLoc :: LintLocInfo -> LintM a -> LintM a +addLoc extra_loc m + = LintM $ \ env errs -> + unLintM m (env { le_loc = extra_loc : le_loc env }) errs + +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs) + where + is_case_pat (LE { le_loc = CasePat {} : _ }) = True + is_case_pat _other = False + +addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a +-- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned +addInScopeId in_id out_ty thing_inside + = LintM $ \ env errs -> + let !(out_id, env') = add env + in unLintM (thing_inside out_id) env' errs + + where + add env@(LE { le_in_vars = id_vars, le_joins = join_set + , le_ue_aliases = aliases, le_subst = subst }) + = (out_id, env1) + where + env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' } + + in_vars' = extendVarEnv id_vars in_id (in_id, out_ty) + aliases' = delFromNameEnv aliases (idName in_id) + -- aliases': when shadowing an alias, we need to make sure the + -- Id is no longer classified as such. E.g. + -- let x = in case x of x { _DEFAULT -> } + -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1. + + -- A very tiny optimisation, not sure if it's really worth it + -- Short-cut when the substitution is a no-op + out_id | isEmptyTCvSubst subst = in_id + | otherwise = setIdType in_id out_ty + + join_set' + | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity + | otherwise = delVarSet join_set in_id -- Remove any existing binding + +addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a +-- This function clones to avoid shadowing of TyCoVars +addInScopeTyCoVar tcv tcv_type thing_inside + = LintM $ \ env@(LE { le_in_vars = in_vars, le_subst = subst }) errs -> + let (tcv', subst') = subst_bndr subst + env' = env { le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type) + , le_subst = subst' } + in unLintM (thing_inside tcv') env' errs + where + subst_bndr subst + | isEmptyTCvSubst subst -- No change in kind + , not (tcv `elemInScopeSet` in_scope) -- Not already in scope + = -- Do not extend the substitution, just the in-scope set + (if (varType tcv `eqType` tcv_type) then (\x->x) else + pprTrace "addInScopeTyCoVar" ( + vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv) + , text "tcv_type" <+> ppr tcv_type ])) $ + (tcv, subst `extendSubstInScope` tcv) + + -- Clone, and extend the substitution + | let tcv' = uniqAway in_scope (setVarType tcv tcv_type) + = (tcv', extendTCvSubstWithClone subst tcv tcv') + where + in_scope = substInScopeSet subst + +getInVarEnv :: LintM (VarEnv (InId, OutType)) +getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs)) + +extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a +extendTvSubstL tv ty m + = LintM $ \ env errs -> + unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs + +markAllJoinsBad :: LintM a -> LintM a +markAllJoinsBad m + = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs + +markAllJoinsBadIf :: Bool -> LintM a -> LintM a +markAllJoinsBadIf True m = markAllJoinsBad m +markAllJoinsBadIf False m = m + +getValidJoins :: LintM IdSet +getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs)) + +getSubst :: LintM Subst +getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs)) + +substTyM :: InType -> LintM OutType +-- Apply the substitution to the type +-- The substitution is often empty, in which case it is a no-op +substTyM ty + = do { subst <- getSubst + ; return (substTy subst ty) } + +getUEAliases :: LintM (NameEnv UsageEnv) +getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs)) + +getInScope :: LintM InScopeSet +getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs)) + +lintVarOcc :: InVar -> LintM OutType +-- Used at an occurrence of a variable: term variables, type variables, and coercion variables +-- Checks two things: +-- a) that it is in scope +-- b) that the InType at the ocurrences matches the InType at the binding site +lintVarOcc v_occ + = do { in_var_env <- getInVarEnv + ; case lookupVarEnv in_var_env v_occ of + Nothing | isGlobalId v_occ -> return (idType v_occ) + | otherwise -> failWithL (text pp_what <+> quotes (ppr v_occ) + <+> text "is out of scope") + Just (v_bndr, out_ty) -> do { check_bad_global v_bndr + ; ensureEqTys occ_ty bndr_ty $ -- Compares InTypes + mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty + ; return out_ty } + where + occ_ty = varType v_occ + bndr_ty = varType v_bndr } + where + pp_what | isTyVar v_occ = "The type variable" + | isCoVar v_occ = "The coercion variable" + | otherwise = "The value variable" + + -- 'check_bad_global' checks for the case where an /occurrence/ is + -- a GlobalId, but there is an enclosing binding fora a LocalId. + -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr, + -- but GHCi adds GlobalIds from the interactive context. These + -- are fine; hence the test (isLocalId id == isLocalId v) + -- NB: when compiling Control.Exception.Base, things like absentError + -- are defined locally, but appear in expressions as (global) + -- wired-in Ids after worker/wrapper + -- So we simply disable the test in this case + check_bad_global v_bndr + | isGlobalId v_occ + , isLocalId v_bndr + , not (isWiredIn v_occ) + = failWithL $ hang (text "Occurrence is GlobalId, but binding is LocalId") + 2 (vcat [ hang (text "occurrence:") 2 $ pprBndr LetBind v_occ + , hang (text "binder :") 2 $ pprBndr LetBind v_bndr ]) + | otherwise + = return () + +lookupJoinId :: Id -> LintM JoinPointHood +-- Look up an Id which should be a join point, valid here +-- If so, return its arity, if not return Nothing +lookupJoinId id + = do { join_set <- getValidJoins + ; case lookupVarSet join_set id of + Just id' -> return (idJoinPointHood id') + Nothing -> return NotJoinPoint } + +addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a +addAliasUE id ue thing_inside = LintM $ \ env errs -> + let new_ue_aliases = + extendNameEnv (le_ue_aliases env) (getName id) ue + in + unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs + +varCallSiteUsage :: OutId -> LintM UsageEnv +varCallSiteUsage id = + do m <- getUEAliases + return $ case lookupNameEnv m (getName id) of + Nothing -> singleUsageUE id + Just id_ue -> id_ue + +ensureEqTys :: OutType -> OutType -> SDoc -> LintM () +-- check ty2 is subtype of ty1 (ie, has same structure but usage +-- annotations need only be consistent, not equal) +-- Assumes ty1,ty2 are have already had the substitution applied +{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys] +ensureEqTys ty1 ty2 msg + = do { flags <- getLintFlags + ; lintL (eq_type flags ty1 ty2) msg } + +eq_type :: LintFlags -> Type -> Type -> Bool +-- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to +-- be equal. See Note [Linting linearity]. +eq_type flags ty1 ty2 | lf_check_linearity flags = eqType ty1 ty2 + | otherwise = eqTypeIgnoringMultiplicity ty1 ty2 + +{- Note [INLINE ensureEqTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To make Lint fast, we want to avoid allocating a thunk for in + ensureEqTypes ty1 ty2 +because the test almost always succeeds, and isn't needed. +So we INLINE `ensureEqTys`. This actually make a difference of +1-2% when compiling programs with -dcore-lint. +-} + +ensureSubUsage :: Usage -> Mult -> SDoc -> LintM () +ensureSubUsage Bottom _ _ = return () +ensureSubUsage Zero described_mult err_msg = ensureSubMult ManyTy described_mult err_msg +ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg + +ensureSubMult :: Mult -> Mult -> SDoc -> LintM () +ensureSubMult actual_mult described_mult err_msg = do + flags <- getLintFlags + when (lf_check_linearity flags) $ + unless (deepSubMult actual_mult described_mult) $ + addErrL err_msg + where + -- Check for submultiplicity using the following rules: + -- 1. x*y <= z when x <= z and y <= z. + -- This rule follows from the fact that x*y = sup{x,y} for any + -- multiplicities x,y. + -- 2. x <= y*z when x <= y or x <= z. + -- This rule is not complete: when x = y*z, we cannot + -- change y*z <= y*z to y*z <= y or y*z <= z. + -- However, we eliminate products on the LHS in step 1. + -- 3. One <= x and x <= Many for any x, as checked by 'submult'. + -- 4. x <= x. + -- Otherwise, we fail. + deepSubMult :: Mult -> Mult -> Bool + deepSubMult m n + | Just (m1, m2) <- isMultMul m = deepSubMult m1 n && deepSubMult m2 n + | Just (n1, n2) <- isMultMul n = deepSubMult m n1 || deepSubMult m n2 + | Submult <- m `submult` n = True + | otherwise = m `eqType` n + +lintRole :: Outputable thing + => thing -- where the role appeared + -> Role -- expected + -> Role -- actual + -> LintM () +lintRole co r1 r2 + = lintL (r1 == r2) + (text "Role incompatibility: expected" <+> ppr r1 <> comma <+> + text "got" <+> ppr r2 $$ + text "in" <+> ppr co) + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) + +dumpLoc (RhsOf v) + = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v]) + +dumpLoc (OccOf v) + = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v) + +dumpLoc (LambdaBodyOf b) + = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b) + +dumpLoc (RuleOf b) + = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b) + +dumpLoc (UnfoldingOf b) + = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) + +dumpLoc (BodyOfLet b) + = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b) + +dumpLoc (BodyOfLetRec []) + = (noSrcLoc, text "In body of a letrec with no binders") + +dumpLoc (BodyOfLetRec bs@(b:_)) + = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs) + +dumpLoc (AnExpr e) + = (noSrcLoc, text "In the expression:" <+> ppr e) + +dumpLoc (CaseAlt (Alt con args _)) + = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CasePat (Alt con args _)) + = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args)) + +dumpLoc (CaseTy scrut) + = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:") + 2 (ppr scrut)) + +dumpLoc (IdTy b) + = (getSrcLoc b, text "In the type of a binder:" <+> ppr b) + +dumpLoc (ImportedUnfolding locn) + = (locn, text "In an imported unfolding") +dumpLoc TopLevelBindings + = (noSrcLoc, Outputable.empty) +dumpLoc (InType ty) + = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) +dumpLoc (InAxiom ax) + = (getSrcLoc ax, hang (text "In the coercion axiom") + 2 (pprCoAxiom ax)) + +pp_binders :: [Var] -> SDoc +pp_binders bs = sep (punctuate comma (map pp_binder bs)) + +pp_binder :: Var -> SDoc +pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] + | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] + +------------------------------------------------------ +-- Messages for case expressions + +mkDefaultArgsMsg :: [Var] -> SDoc +mkDefaultArgsMsg args + = hang (text "DEFAULT case with binders") + 4 (ppr args) + +mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc +mkCaseAltMsg e ty1 ty2 + = hang (text "Type of case alternatives not the same as the annotation on case:") + 4 (vcat [ text "Actual type:" <+> ppr ty1, + text "Annotation on case:" <+> ppr ty2, + text "Alt Rhs:" <+> ppr e ]) + +mkScrutMsg :: Id -> Type -> Type -> SDoc +mkScrutMsg var var_ty scrut_ty + = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, + text "Result binder type:" <+> ppr var_ty,--(idType var), + text "Scrutinee type:" <+> ppr scrut_ty] + +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc +mkNonDefltMsg e + = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) +mkNonIncreasingAltsMsg e + = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) + +nonExhaustiveAltsMsg :: CoreExpr -> SDoc +nonExhaustiveAltsMsg e + = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) + +mkBadConMsg :: TyCon -> DataCon -> SDoc +mkBadConMsg tycon datacon + = vcat [ + text "In a case alternative, data constructor isn't in scrutinee type:", + text "Scrutinee type constructor:" <+> ppr tycon, + text "Data con:" <+> ppr datacon + ] + +mkBadPatMsg :: Type -> Type -> SDoc +mkBadPatMsg con_result_ty scrut_ty + = vcat [ + text "In a case alternative, pattern result type doesn't match scrutinee type:", + text "Pattern result type:" <+> ppr con_result_ty, + text "Scrutinee type:" <+> ppr scrut_ty + ] + +integerScrutinisedMsg :: SDoc +integerScrutinisedMsg + = text "In a LitAlt, the literal is lifted (probably Integer)" + +mkBadAltMsg :: Type -> CoreAlt -> SDoc +mkBadAltMsg scrut_ty alt + = vcat [ text "Data alternative when scrutinee is not a tycon application", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + +mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc +mkNewTyDataConAltMsg scrut_ty alt + = vcat [ text "Data alternative for newtype datacon", + text "Scrutinee type:" <+> ppr scrut_ty, + text "Alternative:" <+> pprCoreAlt alt ] + + +------------------------------------------------------ +-- Other error messages + +mkAppMsg :: Type -> Type -> CoreExpr -> SDoc +mkAppMsg expected_arg_ty actual_arg_ty arg + = vcat [text "Argument value doesn't match argument type:", + hang (text "Expected arg type:") 4 (ppr expected_arg_ty), + hang (text "Actual arg type:") 4 (ppr actual_arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc +mkNonFunAppMsg fun_ty arg_ty arg + = vcat [text "Non-function type in function position", + hang (text "Fun type:") 4 (ppr fun_ty), + hang (text "Arg type:") 4 (ppr arg_ty), + hang (text "Arg:") 4 (ppr arg)] + +mkLetErr :: TyVar -> CoreExpr -> SDoc +mkLetErr bndr rhs + = vcat [text "Bad `let' binding:", + hang (text "Variable:") + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (text "Rhs:") + 4 (ppr rhs)] + +mkTyAppMsg :: OutType -> Type -> SDoc +mkTyAppMsg ty arg_ty + = vcat [text "Illegal type application:", + hang (text "Function type:") + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (text "Type argument:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +emptyRec :: CoreExpr -> SDoc +emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) + +mkRhsMsg :: Id -> SDoc -> Type -> SDoc +mkRhsMsg binder what ty + = vcat + [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, + ppr binder], + hsep [text "Binder's type:", ppr (idType binder)], + hsep [text "Rhs type:", ppr ty]] + +badBndrTyMsg :: Id -> SDoc -> SDoc +badBndrTyMsg binder what + = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder + , text "Binder's type:" <+> ppr (idType binder) ] + +mkNonTopExportedMsg :: Id -> SDoc +mkNonTopExportedMsg binder + = hsep [text "Non-top-level binder is marked as exported:", ppr binder] + +mkNonTopExternalNameMsg :: Id -> SDoc +mkNonTopExternalNameMsg binder + = hsep [text "Non-top-level binder has an external name:", ppr binder] + +mkTopNonLitStrMsg :: Id -> SDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + +mkKindErrMsg :: TyVar -> Type -> SDoc +mkKindErrMsg tyvar arg_ty + = vcat [text "Kinds don't match in type application:", + hang (text "Type variable:") + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (text "Arg type:") + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc +mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) + +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc +mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) + +mk_cast_err :: String -- ^ What sort of casted thing this is + -- (\"expression\" or \"type\"). + -> String -- ^ What sort of coercion is being used + -- (\"type\" or \"kind\"). + -> SDoc -- ^ The thing being casted. + -> Coercion -> Type -> Type -> SDoc +mk_cast_err thing_str co_str pp_thing co from_ty thing_ty + = vcat [from_msg <+> text "of Cast differs from" <+> co_msg + <+> text "of" <+> enclosed_msg, + from_msg <> colon <+> ppr from_ty, + text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon + <+> ppr thing_ty, + text "Actual" <+> enclosed_msg <> colon <+> pp_thing, + text "Coercion used in cast:" <+> ppr co + ] + where + co_msg, from_msg, enclosed_msg :: SDoc + co_msg = text co_str + from_msg = text "From-" <> co_msg + enclosed_msg = text "enclosed" <+> text thing_str + +mkBadTyVarMsg :: Var -> SDoc +mkBadTyVarMsg tv + = text "Non-tyvar used in TyVarTy:" + <+> ppr tv <+> dcolon <+> ppr (varType tv) + +mkBadJoinBindMsg :: Var -> SDoc +mkBadJoinBindMsg var + = vcat [ text "Bad join point binding:" <+> ppr var + , text "Join points can be bound only by a non-top-level let" ] + +mkInvalidJoinPointMsg :: Var -> Type -> SDoc +mkInvalidJoinPointMsg var ty + = hang (text "Join point has invalid type:") + 2 (ppr var <+> dcolon <+> ppr ty) + +mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc +mkBadJoinArityMsg var ar n rhs + = vcat [ text "Join point has too few lambdas", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of lambdas:" <+> ppr (ar - n), + text "Rhs = " <+> ppr rhs + ] + +invalidJoinOcc :: Var -> SDoc +invalidJoinOcc var + = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var + , text "The binder is either not a join point, or not valid here" ] + +mkBadJumpMsg :: Var -> Int -> Int -> SDoc +mkBadJumpMsg var ar nargs + = vcat [ text "Join point invoked with wrong number of arguments", + text "Join var:" <+> ppr var, + text "Join arity:" <+> ppr ar, + text "Number of arguments:" <+> int nargs ] + +mkInconsistentRecMsg :: [Var] -> SDoc +mkInconsistentRecMsg bndrs + = vcat [ text "Recursive let binders mix values and join points", + text "Binders:" <+> hsep (map ppr_with_details bndrs) ] + where + ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr) + +mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc +mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ + = vcat [ text "Mismatch in join point arity between binder and occurrence" + , text "Var:" <+> ppr bndr + , text "Arity at binding site:" <+> ppr join_arity_bndr + , text "Arity at occurrence: " <+> ppr join_arity_occ ] + +mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc +mkBndrOccTypeMismatchMsg var bndr_ty occ_ty + = vcat [ text "Mismatch in type between binder and occurrence" + , text "Binder: " <+> ppr var <+> dcolon <+> ppr bndr_ty + , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ] + +mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc +mkBadJoinPointRuleMsg bndr join_arity rule + = vcat [ text "Join point has rule with wrong number of arguments" + , text "Var:" <+> ppr bndr + , text "Join arity:" <+> ppr join_arity + , text "Rule:" <+> ppr rule ] dupVars :: [NonEmpty Var] -> SDoc dupVars vars diff --git a/GHC/Core/Make.hs b/GHC/Core/Make.hs --- a/GHC/Core/Make.hs +++ b/GHC/Core/Make.hs @@ -1,11 +1,10 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Handy functions for creating much Core syntax module GHC.Core.Make ( -- * Constructing normal syntax mkCoreLet, mkCoreLets, - mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, mkWildCase, mkIfThenElse, + mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps, + mkCoreLams, mkCoreTyLams, + mkWildCase, mkIfThenElse, mkWildValBinder, mkSingleAltCase, sortQuantVars, castBottomExpr, @@ -65,11 +64,12 @@ import GHC.Types.Unique.Supply import GHC.Core -import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec ) +import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast ) import GHC.Core.Type -import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.Coercion ( isCoVar ) -import GHC.Core.DataCon ( DataCon, dataConWorkId ) +import GHC.Core.Predicate ( scopedSort, isEqPred ) +import GHC.Core.TyCo.Compare ( eqType ) +import GHC.Core.Coercion ( isCoVar, mkRepReflCo, mkForAllVisCos ) +import GHC.Core.DataCon ( DataCon, dataConWorkId, dataConWrapId ) import GHC.Core.Multiplicity import GHC.Builtin.Types @@ -79,12 +79,13 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Char ( ord ) infixl 4 `mkCoreApp`, `mkCoreApps` @@ -122,6 +123,14 @@ mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr mkCoreLams = mkLams +-- | Create a type lambda (/\a b c. e) and apply a cast to fix up visibilities +-- if needed. See Note [Required foralls in Core] +mkCoreTyLams :: [TyVarBinder] -> CoreExpr -> CoreExpr +mkCoreTyLams binders body = mkCast lam co + where + lam = mkCoreLams (binderVars binders) body + co = mkForAllVisCos binders (mkRepReflCo (exprType body)) + -- | Bind a list of binding groups over an expression. The leftmost binding -- group becomes the outermost group in the resulting expression mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr @@ -133,6 +142,13 @@ mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args +-- | A variant of 'mkCoreConApps' constructs an expression which represents the +-- application of a number of expressions to that of a data constructor +-- expression using the wrapper, not the worker, of the data constructor. The +-- leftmost expression in the list is applied first +mkCoreConWrapApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConWrapApps con args = mkCoreApps (Var (dataConWrapId con)) args + -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first mkCoreApps :: CoreExpr -- ^ function @@ -224,12 +240,12 @@ mkLitRubbish ty | not (noFreeVarsOfType rep) = Nothing -- Satisfy INVARIANT 1 - | isCoVarType ty + | isEqPred ty = Nothing -- Satisfy INVARIANT 2 | otherwise = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty]) where - Just (torc, rep) = sORTKind_maybe (typeKind ty) + (torc, rep) = expectJust $ sORTKind_maybe (typeKind ty) {- ************************************************************************ @@ -469,12 +485,12 @@ -- | Build the type of a big tuple that holds the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreVarTupTy :: [Id] -> Type +mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) -- | Build the type of a big tuple that holds the specified type of thing -- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTupTy :: [Type] -> Type +mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $ map boxTy tys @@ -499,7 +515,7 @@ where e_ty = exprType e -boxTy :: Type -> Type +boxTy :: HasDebugCallStack => Type -> Type -- ^ `boxTy ty` is the boxed version of `ty`. That is, -- if `e :: ty`, then `wrapBox e :: boxTy ty`. -- Note that if `ty :: Type`, `boxTy ty` just returns `ty`. @@ -609,8 +625,13 @@ where tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] tpl_vs = mkTemplateLocals tpl_tys - [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s, - the_var `elem` gp ] + (tpl_v, group) = case + [ (tpl,gp) + | (tpl,gp) <- zipEqual tpl_vs vars_s + , the_var `elem` gp + ] of + [x] -> x + _ -> panic "mkBigTupleSelector" -- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) mkBigTupleSelectorSolo vars the_var scrut_var scrut @@ -908,7 +929,7 @@ nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID err_nm :: String -> Unique -> Id -> Name -err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id +err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id @@ -1251,7 +1272,7 @@ mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id -- Error function --- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a +-- with type: forall (r::RuntimeRep) (a::TYPE r). Addr# -> a -- with arity: 1 -- which diverges after being given one argument -- The Addr# is expected to be the address of @@ -1277,7 +1298,7 @@ mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $ mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar) where - (tyvar:_) = mkTemplateTyVars [kind] + tyvar:|_ = expectNonEmpty $ mkTemplateTyVars [kind] kind = case torc of TypeLike -> mkTYPEapp runtimeRep1Ty ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty diff --git a/GHC/Core/Map/Expr.hs b/GHC/Core/Map/Expr.hs --- a/GHC/Core/Map/Expr.hs +++ b/GHC/Core/Map/Expr.hs @@ -40,6 +40,7 @@ import qualified Data.Map as Map import GHC.Types.Name.Env import Control.Monad( (>=>) ) +import GHC.Types.Literal (Literal) {- This module implements TrieMaps over Core related data structures @@ -121,6 +122,7 @@ alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) foldTM k (CoreMap m) = foldTM k m filterTM f (CoreMap m) = CoreMap (filterTM f m) + mapMaybeTM f (CoreMap m) = CoreMap (mapMaybeTM f m) -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended -- key makes it suitable for recursive traversal, since it can track binders, @@ -128,6 +130,8 @@ -- inside another 'TrieMap', this is the type you want. type CoreMapG = GenMap CoreMapX +type LiteralMap a = Map.Map Literal a + -- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without -- the 'GenMap' optimization. data CoreMapX a @@ -267,6 +271,7 @@ alterTM = xtE foldTM = fdE filterTM = ftE + mapMaybeTM = mpE -------------------------- ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a @@ -283,6 +288,20 @@ , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick } +mpE :: (a -> Maybe b) -> CoreMapX a -> CoreMapX b +mpE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = mapMaybeTM f cvar, cm_lit = mapMaybeTM f clit + , cm_co = mapMaybeTM f cco, cm_type = mapMaybeTM f ctype + , cm_cast = fmap (mapMaybeTM f) ccast, cm_app = fmap (mapMaybeTM f) capp + , cm_lam = fmap (mapMaybeTM f) clam, cm_letn = fmap (fmap (mapMaybeTM f)) cletn + , cm_letr = fmap (fmap (mapMaybeTM f)) cletr, cm_case = fmap (mapMaybeTM f) ccase + , cm_ecase = fmap (mapMaybeTM f) cecase, cm_tick = fmap (mapMaybeTM f) ctick } + -------------------------- lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a lookupCoreMap cm e = lookupTM e cm @@ -405,6 +424,7 @@ alterTM = xtA emptyCME foldTM = fdA filterTM = ftA + mapMaybeTM = mpA instance Eq (DeBruijn CoreAlt) where D env1 a1 == D env2 a2 = go a1 a2 where @@ -442,3 +462,9 @@ fdA k m = foldTM k (am_deflt m) . foldTM (foldTM k) (am_data m) . foldTM (foldTM k) (am_lit m) + +mpA :: (a -> Maybe b) -> AltMap a -> AltMap b +mpA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = mapMaybeTM f adeflt + , am_data = fmap (mapMaybeTM f) adata + , am_lit = fmap (mapMaybeTM f) alit } diff --git a/GHC/Core/Map/Type.hs b/GHC/Core/Map/Type.hs --- a/GHC/Core/Map/Type.hs +++ b/GHC/Core/Map/Type.hs @@ -38,6 +38,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Rep +import GHC.Core.TyCon( isForgetfulSynTyCon ) import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Data.TrieMap @@ -95,6 +96,7 @@ alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) foldTM k (CoercionMap m) = foldTM k m filterTM f (CoercionMap m) = CoercionMap (filterTM f m) + mapMaybeTM f (CoercionMap m) = CoercionMap (mapMaybeTM f m) type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a) @@ -111,6 +113,7 @@ alterTM = xtC foldTM f (CoercionMapX core_tm) = foldTM f core_tm filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm) + mapMaybeTM f (CoercionMapX core_tm) = CoercionMapX (mapMaybeTM f core_tm) instance Eq (DeBruijn Coercion) where D env1 co1 == D env2 co2 @@ -188,6 +191,7 @@ alterTM = xtT foldTM = fdT filterTM = filterT + mapMaybeTM = mpT instance Eq (DeBruijn Type) where (==) = eqDeBruijnType @@ -228,10 +232,11 @@ andEq TEQX e = hasCast e andEq TEQ e = e - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type - go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 [])) - | tc1 == tc2 - = TEQ + -- See Note [Comparing type synonyms] in GHC.Core.TyCo.Compare + go (D env1 (TyConApp tc1 tys1)) (D env2 (TyConApp tc2 tys2)) + | tc1 == tc2, not (isForgetfulSynTyCon tc1) + = gos env1 env2 tys1 tys2 + go env_t@(D env t) env_t'@(D env' t') | Just new_t <- coreView t = go (D env new_t) env_t' | Just new_t' <- coreView t' = go env_t (D env' new_t') @@ -378,6 +383,7 @@ alterTM = xtTyLit foldTM = foldTyLit filterTM = filterTyLit + mapMaybeTM = mpTyLit emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } @@ -405,6 +411,10 @@ filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } +mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b +mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) + = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc } + ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this -- is the type you want. The keys in this map may have different kinds. @@ -433,6 +443,7 @@ alterTM k f m = xtTT (deBruijnize k) f m foldTM k (TypeMap m) = foldTM (foldTM k) m filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m) + mapMaybeTM f (TypeMap m) = TypeMap (fmap (mapMaybeTM f) m) foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = foldTM k m z @@ -477,6 +488,7 @@ alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) foldTM f (LooseTypeMap m) = foldTM f m filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m) + mapMaybeTM f (LooseTypeMap m) = LooseTypeMap (mapMaybeTM f m) {- ************************************************************************ @@ -556,10 +568,13 @@ alterTM = xtBndr emptyCME foldTM = fdBndrMap filterTM = ftBndrMap + mapMaybeTM = mpBndrMap fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm +mpBndrMap :: (a -> Maybe b) -> BndrMap a -> BndrMap b +mpBndrMap f (BndrMap tm) = BndrMap (fmap (mapMaybeTM f) tm) -- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all -- of these data types have binding forms. @@ -592,6 +607,7 @@ alterTM = xtVar emptyCME foldTM = fdVar filterTM = ftVar + mapMaybeTM = mpVar lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v @@ -617,9 +633,24 @@ ftVar f (VM { vm_bvar = bv, vm_fvar = fv }) = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv } +mpVar :: (a -> Maybe b) -> VarMap a -> VarMap b +mpVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = mapMaybeTM f bv, vm_fvar = mapMaybeTM f fv } + ------------------------------------------------- lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a lkDNamed n env = lookupDNameEnv env (getName n) xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a xtDNamed tc f m = alterDNameEnv f m (getName tc) + +mpT :: (a -> Maybe b) -> TypeMapX a -> TypeMapX b +mpT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = mapMaybeTM f tvar + , tm_app = fmap (mapMaybeTM f) tapp + , tm_tycon = mapMaybeTM f ttycon + , tm_forall = fmap (mapMaybeTM f) tforall + , tm_tylit = mapMaybeTM f tlit + , tm_coerce = tcoerce >>= f } diff --git a/GHC/Core/Multiplicity.hs b/GHC/Core/Multiplicity.hs --- a/GHC/Core/Multiplicity.hs +++ b/GHC/Core/Multiplicity.hs @@ -30,7 +30,9 @@ , IsSubmult(..) , submult , mapScaledType - , pprArrowWithMultiplicity ) where + , pprArrowWithMultiplicity + , MultiplicityFlag(..) + ) where import GHC.Prelude @@ -395,3 +397,8 @@ | otherwise = ppr (funTyFlagTyCon af) +-- | In Core, without `-dlinear-core-lint`, some function must ignore +-- multiplicities. See Note [Linting linearity] in GHC.Core.Lint. +data MultiplicityFlag + = RespectMultiplicities + | IgnoreMultiplicities diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs --- a/GHC/Core/Opt/Arity.hs +++ b/GHC/Core/Opt/Arity.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} -- | Arity and eta expansion module GHC.Core.Opt.Arity @@ -52,9 +53,9 @@ import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.DataCon -import GHC.Core.TyCon ( tyConArity ) +import GHC.Core.TyCon ( TyCon, tyConArity, isInjectiveTyCon ) import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) -import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy ) +import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy ) import GHC.Core.Multiplicity -- We have two sorts of substitution: @@ -68,6 +69,7 @@ import GHC.Types.Demand import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) import GHC.Types.Id +import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic @@ -84,9 +86,10 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NE import Data.Maybe( isJust ) {- @@ -198,8 +201,10 @@ = go initRecTc ty where go rec_nts ty - | Just (_, ty') <- splitForAllTyCoVar_maybe ty - = go rec_nts ty' + | Just (tcv, ty') <- splitForAllTyCoVar_maybe ty + = if isCoVar tcv + then idOneShotInfo tcv : go rec_nts ty' + else go rec_nts ty' | Just (_,_,arg,res) <- splitFunTy_maybe ty = typeOneShot arg : go rec_nts res @@ -513,8 +518,11 @@ Of course both (1) and (2) are readily defeated by disguising the bottoms. -4. Note [Newtype arity] -~~~~~~~~~~~~~~~~~~~~~~~~ +There also is an interaction with Note [Combining arity type with demand info], +outlined in Wrinkle (CAD1). + +Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~ Non-recursive newtypes are transparent, and should not get in the way. We do (currently) eta-expand recursive newtypes too. So if we have, say @@ -716,7 +724,7 @@ now reflects the (cost-free) arity of the expression Why do we ever need an "unsafe" ArityType, such as the example above? -Because its (cost-free) arity may increased by combineWithDemandOneShots +Because its (cost-free) arity may increased by combineWithCallCards in findRhsArity. See Note [Combining arity type with demand info]. Thus the function `arityType` returns a regular "unsafe" ArityType, that @@ -918,14 +926,14 @@ NonRecursive -> trimArityType ty_arity (cheapArityType rhs) ty_arity = typeArity (idType bndr) - id_one_shots = idDemandOneShots bndr + use_call_cards = useSiteCallCards bndr step :: ArityEnv -> SafeArityType step env = trimArityType ty_arity $ safeArityType $ -- See Note [Arity invariants for bindings], item (3) - arityType env rhs `combineWithDemandOneShots` id_one_shots + combineWithCallCards env (arityType env rhs) use_call_cards -- trimArityType: see Note [Trim arity inside the loop] - -- combineWithDemandOneShots: take account of the demand on the + -- combineWithCallCards: take account of the demand on the -- binder. Perhaps it is always called with 2 args -- let f = \x. blah in (f 3 4, f 1 9) -- f's demand-info says how many args it is called with @@ -950,14 +958,24 @@ where next_at = step (extendSigEnv init_env bndr cur_at) -infixl 2 `combineWithDemandOneShots` - -combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType +combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType -- See Note [Combining arity type with demand info] -combineWithDemandOneShots at@(AT lams div) oss +combineWithCallCards env at@(AT lams div) cards | null lams = at | otherwise = AT (zip_lams lams oss) div where + oss = map card_to_oneshot cards + card_to_oneshot n + | isAtMostOnce n, not (pedanticBottoms env) + -- Take care for -fpedantic-bottoms; + -- see Note [Combining arity type with demand info], Wrinkle (CAD1) + = OneShotLam + | n == C_11 + -- Safe to eta-expand even in the presence of -fpedantic-bottoms + -- see Note [Combining arity type with demand info], Wrinkle (CAD1) + = OneShotLam + | otherwise + = NoOneShotInfo zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams lams [] = lams zip_lams [] oss | isDeadEndDiv div = [] @@ -966,29 +984,33 @@ zip_lams ((ch,os1):lams) (os2:oss) = (ch, os1 `bestOneShot` os2) : zip_lams lams oss -idDemandOneShots :: Id -> [OneShotInfo] -idDemandOneShots bndr - = call_arity_one_shots `zip_lams` dmd_one_shots +useSiteCallCards :: Id -> [Card] +useSiteCallCards bndr + = call_arity_one_shots `zip_cards` dmd_one_shots where - call_arity_one_shots :: [OneShotInfo] + call_arity_one_shots :: [Card] call_arity_one_shots | call_arity == 0 = [] - | otherwise = NoOneShotInfo : replicate (call_arity-1) OneShotLam - -- Call Arity analysis says the function is always called - -- applied to this many arguments. The first NoOneShotInfo is because - -- if Call Arity says "always applied to 3 args" then the one-shot info - -- we get is [NoOneShotInfo, OneShotLam, OneShotLam] + | otherwise = C_0N : replicate (call_arity-1) C_01 + -- Call Arity analysis says /however often the function is called/, it is + -- always applied to this many arguments. + -- The first C_0N is because of the "however often it is called" part. + -- Thus if Call Arity says "always applied to 3 args" then the one-shot info + -- we get is [C_0N, C_01, C_01] call_arity = idCallArity bndr - dmd_one_shots :: [OneShotInfo] + dmd_one_shots :: [Card] -- If the demand info is C(x,C(1,C(1,.))) then we know that an -- application to one arg is also an application to three - dmd_one_shots = argOneShots (idDemandInfo bndr) + dmd_one_shots = case idDemandInfo bndr of + AbsDmd -> [] -- There is no use in eta expanding + BotDmd -> [] -- when the binding could be dropped instead + _ :* sd -> callCards sd -- Take the *longer* list - zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2 - zip_lams [] lams2 = lams2 - zip_lams lams1 [] = lams1 + zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2 + zip_cards [] ns2 = ns2 + zip_cards ns1 [] = ns1 {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1084,7 +1106,7 @@ result: arity=3, which is better than we could do from either source alone. -The "combining" part is done by combineWithDemandOneShots. It +The "combining" part is done by combineWithCallCards. It uses info from both Call Arity and demand analysis. We may have /more/ call demands from the calls than we have lambdas @@ -1103,6 +1125,22 @@ Nor, in the case of f2, do we want to push that error call under a lambda. Hence the takeWhile in combineWithDemandDoneShots. +Wrinkles: + +(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms + (See Note [Dealing with bottom]). Consider + + let f = \x y. error "blah" in + f 2 1 `seq` Just (f 3 2 1) + -- Demand on f is C(x,C(1,C(M,L))) + + Usually, it is OK to consider a lambda that is called *at most* once (so call + cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it. + But with -fpedantic-bottoms that is no longer true: If we were to eta-expand + f to arity 3, we'd discard the error raised when evaluating `f 2 1`. + Hence in the presence of -fpedantic-bottoms, we must have C_11 for + eta-expansion. + Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly to CPR (see Note [Don't w/w join points for CPR] in @@ -1235,8 +1273,14 @@ floatIn :: Cost -> ArityType -> ArityType -- We have something like (let x = E in b), -- where b has the given arity type. -floatIn IsCheap at = at -floatIn IsExpensive at = addWork at +-- NB: be as lazy as possible in the Cost-of-E argument; +-- we can often get away without ever looking at it +-- See Note [Care with nested expressions] +floatIn ch at@(AT lams div) + = case lams of + [] -> at + (IsExpensive,_):_ -> at + (_,os):lams -> AT ((ch,os):lams) div addWork :: ArityType -> ArityType -- Add work to the outermost level of the arity type @@ -1319,6 +1363,25 @@ first bullet). So 'go2' gets an arityType of \(C?)(C1).T, which is what we want. +Note [Care with nested expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + arityType (Just ) +We will take + arityType Just = AT [(IsCheap,os)] topDiv +and then do + arityApp (AT [(IsCheap os)] topDiv) (exprCost ) +The result will be AT [] topDiv. It doesn't matter what +is! The same is true of + arityType (let x = in ) +where the cost of doesn't matter unless has a useful +arityType. + +TL;DR in `floatIn`, do not to look at the Cost argument until you have to. + +I found this when looking at #24471, although I don't think it was really +the main culprit. + Note [Combining case branches: andWithTail] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When combining the ArityTypes for two case branches (with andArityType) @@ -1360,6 +1423,16 @@ We really want to eta-expand this! #20103 is quite convincing! We do this regardless of -fdicts-cheap; it's not really a dictionary. +We also want to check both for (IP blah CallStack) and for CallStack itself. +We might have either + d :: IP blah CallStack -- Or HasCallStack + d = (cs-expr :: CallStack) |> (nt-ax :: CallStack ~ IP blah CallStack) +or just + cs :: CallStack + cs = cs-expr + +Test T20103 is an example of the latter. + Note [Eta expanding through dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the experimental -fdicts-cheap flag is on, we eta-expand through @@ -1459,11 +1532,11 @@ cheap_dict = case mb_ty of Nothing -> False Just ty -> (ao_dicts_cheap opts && isDictTy ty) - || isCallStackPredTy ty + || isCallStackPredTy ty || isCallStackTy ty -- See Note [Eta expanding through dictionaries] -- See Note [Eta expanding through CallStacks] - cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why @@ -1529,23 +1602,22 @@ -- f x y = case x of { (a,b) -> e } -- The difference is observable using 'seq' -- -arityType env (Case scrut bndr _ alts) - | exprIsDeadEnd scrut || null alts - = botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] - - | not (pedanticBottoms env) -- See (2) in Note [Dealing with bottom] - , myExprIsCheap env scrut (Just (idType bndr)) - = alts_type +arityType env (Case scrut bndr _ altList) + | not $ exprIsDeadEnd scrut, Just alts <- nonEmpty altList + = let env' = delInScope env bndr + arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs + alts_type = foldr1 (andArityType env) (NE.map arity_type_alt alts) + in if + | not (pedanticBottoms env) -- See (2) in Note [Dealing with bottom] + , myExprIsCheap env scrut (Just (idType bndr)) + -> alts_type - | exprOkForSpeculation scrut - = alts_type + | exprOkForSpeculation scrut + -> alts_type - | otherwise -- In the remaining cases we may not push - = addWork alts_type -- evaluation of the scrutinee in - where - env' = delInScope env bndr - arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs - alts_type = foldr1 (andArityType env) (map arity_type_alt alts) + | otherwise -- In the remaining cases we may not push + -> addWork alts_type -- evaluation of the scrutinee in + | otherwise = botArityType -- Do not eta expand. See (1) in Note [Dealing with bottom] arityType env (Let (NonRec b rhs) e) = -- See Note [arityType for non-recursive let-bindings] @@ -1882,9 +1954,8 @@ has an unfolding we have to push it into there too. AND j might be recursive... -So for now I'm abandoning the no-crap rule in this case. I think -that for the use in CorePrep it really doesn't matter; and if -it does, then CoreToStg.myCollectArgs will fall over. +So for now I'm abandoning the no-crap rule in this case, conscious that this +causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]. (Moreover, I think that casts can make the no-crap rule fail too.) @@ -2039,8 +2110,8 @@ Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp -To a first approximation EtaInfo is just [Var]. But -casts complicate the question. If we have +To a first approximation EtaInfo is just [Var]. But casts complicate +the question. If we have newtype N a = MkN (S -> a) axN :: N a ~ S -> a and @@ -2056,6 +2127,20 @@ data EtaInfo = EI [Var] MCoercionR +Precisely, here is the (EtaInfo Invariant): + + EI bs co :: EtaInfo + +describes a particular eta-expansion, thus: + + Abstraction: (\b1 b2 .. bn. []) |> sym co + Application: ([] |> co) b1 b2 .. bn + + e :: T + co :: T ~R (t1 -> t2 -> .. -> tn -> tr) + e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co + + Note [Check for reflexive casts in eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It turns out that the casts created by the above mechanism are often Refl. @@ -2111,13 +2196,7 @@ -------------- data EtaInfo = EI [Var] MCoercionR - --- (EI bs co) describes a particular eta-expansion, as follows: --- Abstraction: (\b1 b2 .. bn. []) |> sym co --- Application: ([] |> co) b1 b2 .. bn --- --- e :: T co :: T ~ (t1 -> t2 -> .. -> tn -> tr) --- e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co + -- See Note [The EtaInfo mechanism] instance Outputable EtaInfo where ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) @@ -2181,7 +2260,7 @@ -- If e :: ty -- then etaInfoApp e eis :: etaInfoApp ty eis etaInfoAppTy ty (EI bs mco) - = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs) + = applyTypeToArgs ty1 (map varToCoreExpr bs) where ty1 = case mco of MRefl -> ty @@ -2227,18 +2306,18 @@ go _ [] subst _ ----------- Done! No more expansion needed - = (getSubstInScope subst, EI [] MRefl) + = (substInScopeSet subst, EI [] MRefl) go n oss@(one_shot:oss1) subst ty ----------- Forall types (forall a. ty) - | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty + | Just (Bndr tcv vis, ty') <- splitForAllForAllTyBinder_maybe ty , (subst', tcv') <- Type.substVarBndr subst tcv , let oss' | isTyVar tcv = oss | otherwise = oss1 -- A forall can bind a CoVar, in which case -- we consume one of the [OneShotInfo] , (in_scope, EI bs mco) <- go n oss' subst' ty' - = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco)) + = (in_scope, EI (tcv' : bs) (mkEtaForAllMCo (Bndr tcv' vis) ty' mco)) ----------- Function types (t1 -> t2) | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty @@ -2274,13 +2353,26 @@ -- but its type isn't a function, or a binder -- does not have a fixed runtime representation = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr) - (getSubstInScope subst, EI [] MRefl) + (substInScopeSet subst, EI [] MRefl) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). -- So we simply decline to eta-expand. Otherwise we'd end up -- with an explicit lambda having a non-function type +mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion +mkEtaForAllMCo (Bndr tcv vis) ty mco + = case mco of + MRefl | vis == coreTyLamForAllTyFlag -> MRefl + | otherwise -> mk_fco (mkRepReflCo ty) + MCo co -> mk_fco co + where + mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag + (mkNomReflCo (varType tcv)) co) + -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly + -- the (EtaInfo Invariant). (sym co) wraps a lambda that always has + -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep {- ************************************************************************ @@ -2417,14 +2509,6 @@ And here are a few more technical criteria for when it is *not* sound to eta-reduce that are specific to Core and GHC: -(L) With linear types, eta-reduction can break type-checking: - f :: A ⊸ B - g :: A -> B - g = \x. f x - The above is correct, but eta-reducing g would yield g=f, the linter will - complain that g and f don't have the same type. NB: Not unsound in the - dynamic semantics, but unsound according to the static semantics of Core. - (J) We may not undersaturate join points. See Note [Invariants on join points] in GHC.Core, and #20599. @@ -2684,7 +2768,7 @@ | fun `elemUnVarSet` rec_ids -- Criterion (R) = False -- Don't eta-reduce in fun in its own recursive RHSs - | cantEtaReduceFun fun -- Criteria (L), (J), (W), (B) + | cantEtaReduceFun fun -- Criteria (J), (W), (B) = False -- Function can't be eta reduced to arity 0 -- without violating invariants of Core and GHC @@ -2707,7 +2791,7 @@ arity = idArity fun --------------- - ok_lam v = isTyVar v || isEvVar v + ok_lam v = isTyVar v || isEvId v -- See Note [Eta reduction makes sense], point (2) --------------- @@ -2720,9 +2804,19 @@ -- (and similarly for tyvars, coercion args) , [CoreTickish]) -- See Note [Eta reduction with casted arguments] - ok_arg bndr (Type ty) co _ - | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkHomoForAllCos [tv] co, []) + ok_arg bndr (Type arg_ty) co fun_ty + | Just tv <- getTyVar_maybe arg_ty + , bndr == tv = case splitForAllForAllTyBinder_maybe fun_ty of + Just (Bndr _ vis, _) -> Just (fco, []) + where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co + -- The lambda we are eta-reducing always has visibility + -- 'coreTyLamForAllTyFlag' which may or may not match + -- the visibility on the inner function (#24014) + kco = mkNomReflCo (tyVarKind tv) + Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type" + (text "fun:" <+> ppr bndr + $$ text "arg:" <+> ppr arg_ty + $$ text "fun_ty:" <+> ppr fun_ty) ok_arg bndr (Var v) co fun_ty | bndr == v , let mult = idMult bndr @@ -2744,7 +2838,7 @@ ok_arg _ _ _ _ = Nothing -- | Can we eta-reduce the given function --- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L). +-- See Note [Eta reduction soundness], criteria (B), (J), and (W). cantEtaReduceFun :: Id -> Bool cantEtaReduceFun fun = hasNoBinding fun -- (B) @@ -2758,12 +2852,7 @@ -- Don't undersaturate StrictWorkerIds. -- See Note [CBV Function Ids] in GHC.Types.Id.Info. - || isLinearType (idType fun) -- (L) - -- Don't perform eta reduction on linear types. - -- If `f :: A %1-> B` and `g :: A -> B`, - -- then `g x = f x` is OK but `g = f` is not. - {- ********************************************************************* * * The "push rules" @@ -2933,21 +3022,31 @@ | otherwise = Nothing -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion +pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR -> Maybe (DataCon , [Type] -- Universal type args , [CoreExpr]) -- All other args incl existentials -- Implement the KPush reduction rule as described in "Down with kinds" -- The transformation applies iff we have -- (C e1 ... en) `cast` co --- where co :: (T t1 .. tn) ~ to_ty +-- where co :: (T t1 .. tn) ~ (T s1 .. sn) -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) -pushCoDataCon dc dc_args co - | isReflCo co || from_ty `eqType` to_ty -- try cheap test first - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args - = Just (dc, map exprToType univ_ty_args, rest_args) +pushCoDataCon dc dc_args MRefl = Just $! (push_dc_refl dc dc_args) +pushCoDataCon dc dc_args (MCo co) = push_dc_gen dc dc_args co (coercionKind co) +push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr]) +push_dc_refl dc dc_args + = (dc, map exprToType univ_ty_args, rest_args) + where + !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + +push_dc_gen :: DataCon -> [CoreExpr] -> CoercionR -> Pair Type + -> Maybe (DataCon, [Type], [CoreExpr]) +push_dc_gen dc dc_args co (Pair from_ty to_ty) + | from_ty `eqType` to_ty -- try cheap test first + = Just $! (push_dc_refl dc dc_args) + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty , to_tc == dataConTyCon dc -- These two tests can fail; we might see @@ -2955,46 +3054,54 @@ -- where S is a type function. In fact, exprIsConApp -- will probably not be called in such circumstances, -- but there's nothing wrong with it + = Just (push_data_con to_tc to_tc_arg_tys dc dc_args co Representational) - = let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tcvars = dataConExTyCoVars dc - arg_tys = dataConRepArgTys dc + | otherwise + = Nothing - non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args - -- Make the "Psi" from the paper - omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) - (psi_subst, to_ex_arg_tys) - = liftCoSubstWithEx Representational - dc_univ_tyvars - omegas - dc_ex_tcvars - (map exprToType ex_args) +push_data_con :: TyCon -> [Type] -> DataCon -> [CoreExpr] + -> CoercionR -> Role -- Coercion and its role + -> (DataCon, [Type], [CoreExpr]) +push_data_con to_tc to_tc_arg_tys dc dc_args co role + = assertPpr (eqType from_ty dc_app_ty) dump_doc $ + assertPpr (equalLength val_args arg_tys) dump_doc $ + assertPpr (role == coercionRole co) dump_doc $ + assertPpr (isInjectiveTyCon to_tc role) dump_doc $ + -- isInjectiveTyCon: see (UCM9) in Note [Unary class magic] + -- in GHC.Core.TyCon + (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + where + Pair from_ty to_ty = coercionKind co + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc - -- Cast the value arguments (which include dictionaries) - new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args - cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + dc_app_ty = mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) - to_ex_args = map Type to_ex_arg_tys + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, - ppr arg_tys, ppr dc_args, - ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc - , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] - in - assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $ - assertPpr (equalLength val_args arg_tys) dump_doc $ - Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co (tyConRolesX role to_tc) + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx dc_univ_tyvars + omegas + dc_ex_tcvars + (map exprToType ex_args) - | otherwise - = Nothing + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) - where - Pair from_ty to_ty = coercionKind co + to_ex_args = map Type to_ex_arg_tys + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars + , ppr arg_tys, ppr dc_args + , ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc + , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ] + collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) -- Collect lambda binders, pushing coercions inside if possible -- E.g. (\x.e) |> g g :: -> blah @@ -3050,15 +3157,12 @@ | otherwise = (reverse bs, mkCast (Lam b e) co) -{- - -Note [collectBindersPushingCo] +{- Note [collectBindersPushingCo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We just look for coercions of form % w -> blah (and similarly for foralls) to keep this function simple. We could do more elaborate stuff, but it'd involve substitution etc. - -} {- ********************************************************************* @@ -3151,7 +3255,7 @@ = (subst', eta_id') where Scaled mult' ty' = Type.substScaledTyUnchecked subst ty - eta_id' = uniqAway (getSubstInScope subst) $ + eta_id' = uniqAway (substInScopeSet subst) $ mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' -- "OrCoVar" since this can be used to eta-expand -- coercion abstractions diff --git a/GHC/Core/Opt/CSE.hs b/GHC/Core/Opt/CSE.hs --- a/GHC/Core/Opt/CSE.hs +++ b/GHC/Core/Opt/CSE.hs @@ -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, isJoinId_maybe, idUnfolding ) +import GHC.Types.Var.Env ( mkInScopeSet, mkInScopeSetList ) +import GHC.Types.Id import GHC.Core.Utils ( mkAltExpr , exprIsTickedString , stripTicksE, stripTicksT, mkTicks ) @@ -43,7 +39,7 @@ When we then see y1 = C a b y2 = C y1 b -we replace the C a b with x1. But then we *dont* want to +we replace the C a b with x1. But then we *don't* want to add x1 -> y1 to the mapping. Rather, we want the reverse, y1 -> x1 so that a subsequent binding y2 = C y1 b @@ -383,14 +379,21 @@ -} cseProgram :: CoreProgram -> CoreProgram -cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds) +cseProgram binds + = snd (mapAccumL (cseBind TopLevel) init_env binds) + where + init_env = emptyCSEnv $ + mkInScopeSetList (bindersOfBinds binds) + -- Put all top-level binders into scope; it is possible to have + -- forward references. See Note [Glomming] in GHC.Core.Opt.OccurAnal + -- Missing this caused #25468 cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind) cseBind toplevel env (NonRec b e) = (env2, NonRec b2 e2) where -- See Note [Separate envs for let rhs and body] - (env1, b1) = addBinder env b + (env1, b1) = addNonRecBinder toplevel env b (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1 cseBind toplevel env (Rec [(in_id, rhs)]) @@ -408,7 +411,7 @@ = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) where - (env1, Identity out_id) = addRecBinders env (Identity in_id) + (env1, Identity out_id) = addRecBinders toplevel env (Identity in_id) rhs' = cseExpr env1 rhs rhs'' = stripTicksE tickishFloatable rhs' ticks = stripTicksT tickishFloatable rhs' @@ -418,7 +421,7 @@ cseBind toplevel env (Rec pairs) = (env2, Rec pairs') where - (env1, bndrs1) = addRecBinders env (map fst pairs) + (env1, bndrs1) = addRecBinders toplevel env (map fst pairs) (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1) do_one env (pr, b1) = cse_bind toplevel env env pr b1 @@ -436,7 +439,7 @@ -- See Note [Take care with literal strings] = (env_body', (out_id', in_rhs)) - | Just arity <- isJoinId_maybe out_id + | JoinPoint arity <- idJoinPointHood out_id -- See Note [Look inside join-point binders] = let (params, in_body) = collectNBinders arity in_rhs (env', params') = addBinders env_rhs params @@ -635,7 +638,10 @@ doing this if there are no RULES; and other things being equal it delays optimisation to delay inlining (#17409) +* There can be a subtle order-dependency, as described in #25526; + it may matter whether we end up with f=g or g=f. + ---- Historical note --- This patch is simpler and more direct than an earlier @@ -696,7 +702,8 @@ -- as a convenient entry point for users of the GHC API. cseOneExpr :: InExpr -> OutExpr cseOneExpr e = cseExpr env e - where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } + where + env = emptyCSEnv (mkInScopeSet (exprFreeVars e)) cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t) @@ -754,7 +761,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 +769,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 +829,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 +839,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. ************************************************************************ * * @@ -865,9 +869,11 @@ -- See Note [CSE for recursive bindings] } -emptyCSEnv :: CSEnv -emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap - , cs_subst = emptySubst } +emptyCSEnv :: InScopeSet -> CSEnv +emptyCSEnv in_scope + = CS { cs_map = emptyCoreMap + , cs_rec_map = emptyCoreMap + , cs_subst = mkEmptySubst in_scope } lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr lookupCSEnv (CS { cs_map = csmap }) expr @@ -912,8 +918,19 @@ where (sub', vs') = substBndrs (cs_subst cse) vs -addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id) -addRecBinders = \ cse vs -> - let (sub', vs') = substRecBndrs (cs_subst cse) vs - in (cse { cs_subst = sub' }, vs') +addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var) +-- Don't clone at top level +addNonRecBinder top_lvl cse v + | isTopLevel top_lvl = (cse, v) + | otherwise = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v + +addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id) +-- Don't clone at top level +addRecBinders top_lvl cse vs + | isTopLevel top_lvl = (cse, vs) + | otherwise = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs {-# INLINE addRecBinders #-} diff --git a/GHC/Core/Opt/CallArity.hs b/GHC/Core/Opt/CallArity.hs --- a/GHC/Core/Opt/CallArity.hs +++ b/GHC/Core/Opt/CallArity.hs @@ -2,7 +2,6 @@ -- Copyright (c) 2014 Joachim Breitner -- -{-# LANGUAGE BangPatterns #-} module GHC.Core.Opt.CallArity ( callArityAnalProgram @@ -24,6 +23,7 @@ import GHC.Utils.Misc import Control.Arrow ( first, second ) +import Data.List.NonEmpty ( NonEmpty (..) ) {- @@ -697,7 +697,7 @@ -- See Note [Trimming arity] trimArity :: Id -> Arity -> Arity -trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] +trimArity v a = minimum (a :| max_arity_by_type : max_arity_by_strsig : []) where max_arity_by_type = typeArity (idType v) max_arity_by_strsig diff --git a/GHC/Core/Opt/CallerCC/Types.hs b/GHC/Core/Opt/CallerCC/Types.hs --- a/GHC/Core/Opt/CallerCC/Types.hs +++ b/GHC/Core/Opt/CallerCC/Types.hs @@ -19,6 +19,7 @@ import GHC.Utils.Panic import qualified GHC.Utils.Binary as B import Data.Char +import Control.DeepSeq import Language.Haskell.Syntax.Module.Name @@ -33,6 +34,11 @@ ppr (PWildcard rest) = char '*' <> ppr rest ppr PEnd = Outputable.empty +instance NFData NamePattern where + rnf (PChar c n) = rnf c `seq` rnf n + rnf (PWildcard np) = rnf np + rnf PEnd = () + instance B.Binary NamePattern where get bh = do tag <- B.get bh @@ -61,20 +67,23 @@ type Parser = P.ReadP parseNamePattern :: Parser NamePattern -parseNamePattern = pattern +parseNamePattern = namePattern where - pattern = star P.<++ wildcard P.<++ char P.<++ end - star = PChar '*' <$ P.string "\\*" <*> pattern + namePattern = star P.<++ wildcard P.<++ char P.<++ end + star = PChar '*' <$ P.string "\\*" <*> namePattern wildcard = do void $ P.char '*' - PWildcard <$> pattern - char = PChar <$> P.get <*> pattern + PWildcard <$> namePattern + char = PChar <$> P.get <*> namePattern end = PEnd <$ P.eof data CallerCcFilter = CallerCcFilter { ccfModuleName :: Maybe ModuleName , ccfFuncName :: NamePattern } + +instance NFData CallerCcFilter where + rnf (CallerCcFilter mn n) = rnf mn `seq` rnf n instance Outputable CallerCcFilter where ppr ccf = diff --git a/GHC/Core/Opt/ConstantFold.hs b/GHC/Core/Opt/ConstantFold.hs --- a/GHC/Core/Opt/ConstantFold.hs +++ b/GHC/Core/Opt/ConstantFold.hs @@ -20,7 +20,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- | Constant Folder module GHC.Core.Opt.ConstantFold @@ -34,6 +34,7 @@ import GHC.Prelude import GHC.Platform +import GHC.Float import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id @@ -54,9 +55,8 @@ import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon - ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon - , isNewTyCon, tyConDataCons - , tyConFamilySize, isTypeDataTyCon ) + ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize + , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) @@ -69,12 +69,10 @@ import GHC.Cmm.Type ( Width(..) ) import GHC.Data.FastString -import GHC.Data.Maybe ( orElse ) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Applicative ( Alternative(..) ) import Control.Monad @@ -104,7 +102,8 @@ primOpRules :: Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ] - DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ] + DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ] + DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ] -- Int8 operations Int8AddOp -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+)) @@ -658,6 +657,38 @@ , removeOp32 , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ] + CastWord64ToDoubleOp -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitNumber _ n + | v <- castWord64ToDouble (fromInteger n) + -- we can't represent those float literals in Core until #18897 is fixed + , not (isNaN v || isInfinite v || isNegativeZero v) + -> Just (mkDoubleLitDouble v) + _ -> Nothing + ] + + CastWord32ToFloatOp -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitNumber _ n + | v <- castWord32ToFloat (fromInteger n) + -- we can't represent those float literals in Core until #18897 is fixed + , not (isNaN v || isInfinite v || isNegativeZero v) + -> Just (mkFloatLitFloat v) + _ -> Nothing + ] + + CastDoubleToWord64Op -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitDouble n -> Just (mkWord64LitWord64 (castDoubleToWord64 (fromRational n))) + _ -> Nothing + ] + + CastFloatToWord32Op -> mkPrimOpRule nm 1 + [ unaryLit $ \_env -> \case + LitFloat n -> Just (mkWord32LitWord32 (castFloatToWord32 (fromRational n))) + _ -> Nothing + ] + OrdOp -> mkPrimOpRule nm 1 [ liftLit charToIntLit , semiInversePrimOp ChrOp ] ChrOp -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs @@ -823,7 +854,6 @@ AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -1099,7 +1129,7 @@ _ | shift_len == 0 -> pure e1 -- See Note [Guarding against silly shifts] - _ | shift_len < 0 || shift_len > bit_size + _ | shift_len < 0 || shift_len >= bit_size -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0 -- Be sure to use lit_num_ty here, so we get a correctly typed zero. -- See #18589 @@ -1581,15 +1611,15 @@ let x = I# (error "invalid shift") in ... -This was originally done in the fix to #16449 but this breaks the let-can-float -invariant (see Note [Core let-can-float invariant] in GHC.Core) as noted in #16742. -For the reasons discussed in Note [Checking versus non-checking -primops] (in the PrimOp module) there is no safe way to rewrite the argument of I# -such that it bottoms. +This was originally done in the fix to #16449 but this breaks the +let-can-float invariant (see Note [Core let-can-float invariant] in +GHC.Core) as noted in #16742. For the reasons discussed under +"NoEffect" in Note [Classifying primop effects] (in GHC.Builtin.PrimOps) +there is no safe way to rewrite the argument of I# such that it bottoms. -Consequently we instead take advantage of the fact that large shifts are -undefined behavior (see associated documentation in primops.txt.pp) and -transform the invalid shift into an "obviously incorrect" value. +Consequently we instead take advantage of the fact that the result of a +large shift is unspecified (see associated documentation in primops.txt.pp) +and transform the invalid shift into an "obviously incorrect" value. There are two cases: @@ -1966,6 +1996,14 @@ generate calls in derived instances of Enum. So we compromise: a rewrite rule rewrites a bad instance of tagToEnum# to an error call, and emits a warning. + +We also do something similar if we can see that the argument of tagToEnum is out +of bounds, e.g. `tagToEnum# 99# :: Bool`. +Replacing this with an error expression is better for two reasons: +* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...` +* Should we actually end up executing the relevant code at runtime the user will + see a meaningful error message, instead of a segfault or incorrect result. +See #25976. -} tagToEnumRule :: RuleM CoreExpr @@ -1977,9 +2015,13 @@ Just (tycon, tc_args) | isEnumerationTyCon tycon -> do let tag = fromInteger i correct_tag dc = (dataConTagZ dc) == tag - (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) - massert (null rest) - return $ mkTyApps (Var (dataConWorkId dc)) tc_args + Just dataCons <- pure $ tyConDataCons_maybe tycon + case filter correct_tag dataCons of + (dc:rest) -> do + massert (null rest) + pure $ mkTyApps (Var (dataConWorkId dc)) tc_args + -- Literal is out of range, e.g. tagToEnum @Bool #4 + [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range" -- See Note [tagToEnum#] _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $ @@ -1987,12 +2029,14 @@ ------------------------------ dataToTagRule :: RuleM CoreExpr --- See Note [dataToTag# magic]. +-- Used for both dataToTagSmall# and dataToTagLarge#. +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b where -- dataToTag (tagToEnum x) ==> x a = do - [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs + [Type _lev, Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs guard $ tag_to_enum `hasKey` tagToEnumKey guard $ ty1 `eqType` ty2 return tag @@ -2003,42 +2047,13 @@ -- where x's unfolding is a constructor application b = do platform <- getPlatform - [_, val_arg] <- getArgs + [_lev, _ty, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg massert (not (isNewTyCon (dataConTyCon dc))) return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) -{- Note [dataToTag# magic] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The primop dataToTag# is unusual because it evaluates its argument. -Only `SeqOp` shares that property. (Other primops do not do anything -as fancy as argument evaluation.) The special handling for dataToTag# -is: -* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp, - (actually in app_ok). Most primops with lifted arguments do not - evaluate those arguments, but DataToTagOp and SeqOp are two - exceptions. We say that they are /never/ ok-for-speculation, - regardless of the evaluated-ness of their argument. - See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp] - -* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr, - that evaluates its argument and then extracts the tag from - the returned value. - -* An application like (dataToTag# (Just x)) is optimised by - dataToTagRule in GHC.Core.Opt.ConstantFold. - -* A case expression like - case (dataToTag# e) of - gets transformed t - case e of - by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag] - -See #15696 for a long saga. --} - {- ********************************************************************* * * unsafeEqualityProof @@ -2055,7 +2070,7 @@ ; fn <- getFunction ; let (_, ue) = splitForAllTyCoVars (idType fn) tc = tyConAppTyCon ue -- tycon: UnsafeEquality - (dc:_) = tyConDataCons tc -- data con: UnsafeRefl + dc = tyConSingleDataCon tc -- data con: UnsafeRefl -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r). -- UnsafeEquality r a a ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) } @@ -2063,75 +2078,18 @@ {- ********************************************************************* * * - Rules for seq# and spark# + Rules for spark# * * ********************************************************************* -} -{- Note [seq# magic] -~~~~~~~~~~~~~~~~~~~~ -The primop - seq# :: forall a s . a -> State# s -> (# State# s, a #) - -is /not/ the same as the Prelude function seq :: a -> b -> b -as you can see from its type. In fact, seq# is the implementation -mechanism for 'evaluate' - - evaluate :: a -> IO a - evaluate a = IO $ \s -> seq# a s - -The semantics of seq# is - * evaluate its first argument - * and return it - -Things to note - -* Why do we need a primop at all? That is, instead of - case seq# x s of (# x, s #) -> blah - why not instead say this? - case x of { DEFAULT -> blah) - - Reason (see #5129): if we saw - catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler - - then we'd drop the 'case x' because the body of the case is bottom - anyway. But we don't want to do that; the whole /point/ of - seq#/evaluate is to evaluate 'x' first in the IO monad. - - In short, we /always/ evaluate the first argument and never - just discard it. - -* Why return the value? So that we can control sharing of seq'd - values: in - let x = e in x `seq` ... x ... - We don't want to inline x, so better to represent it as - let x = e in case seq# x RW of (# _, x' #) -> ... x' ... - also it matches the type of rseq in the Eval monad. - -Implementing seq#. The compiler has magic for SeqOp in - -- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# s) - -- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# - -- GHC.Core.Utils.exprOkForSpeculation; - see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils - -- Simplify.addEvals records evaluated-ness for the result; see - Note [Adding evaluatedness info to pattern-bound variables] - in GHC.Core.Opt.Simplify --} - -seqRule :: RuleM CoreExpr -seqRule = do +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: RuleM CoreExpr +sparkRule = do -- reduce on HNF [Type _ty_a, Type _ty_s, a, s] <- getArgs guard $ exprIsHNF a return $ mkCoreUnboxedTuple [s, a] - --- spark# :: forall a s . a -> State# s -> (# State# s, a #) -sparkRule :: RuleM CoreExpr -sparkRule = seqRule -- reduce on HNF, just the same - -- XXX perhaps we shouldn't do this, because a spark eliminated by - -- this rule won't be counted as a dud at runtime? + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? {- ************************************************************************ @@ -2655,6 +2613,10 @@ inline f_ty (f a b c) = a b c (if f has an unfolding, EVEN if it's a loop breaker) + Additionally the rule looks through ticks/casts as well (#24808): + inline f_ty (f a b c |> co) = a b c |> co + inline f_ty ( f a b c ) = a b c + It's important to allow the argument to 'inline' to have args itself (a) because its more forgiving to allow the programmer to write either inline f a b c @@ -2667,18 +2629,31 @@ -} match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_inline (Type _ : e : _) - | (Var f, args1) <- collectArgs e, - Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! - = Just (mkApps unf args1) +match_inline (Type _ : e : _) = go e + -- Maybe Monad ahead: + where + go (Var f) = -- Ignore the IdUnfoldingFun here! + (maybeUnfoldingTemplate (realIdUnfolding f)) + go (App f a) = do { f' <- go f; pure $ App f' a } + -- inline (f |> co) + go (Cast e co) = do { app <- go e; pure (Cast app co) } + -- inline ( f) + go (Tick t e) = do { app <- go e; pure (Tick t app) } + go _ = Nothing match_inline _ = Nothing -------------------------------------------------------- -- Note [Constant folding through nested expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- GHC has some support for constant folding through nested expressions (i.e. +-- when constants are not only arguments of the considered App node but to one +-- of its own argument (an App node too), see examples below). -- +-- For performance reason, this optimization is only enabled with -O1 and above. +-- As with all optimizations, it can also be independently enabled with its own +-- command-line flag too: -fnum-constant-folding (grep Opt_NumConstantFolding). +-- -- We use rewrites rules to perform constant folding. It means that we don't -- have a global view of the expression we are trying to optimise. As a -- consequence we only perform local (small-step) transformations that either: @@ -3099,6 +3074,11 @@ -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y) -- increase operation numbers + -- x and (y or ... or x or ... or z) ==> x + (x, is_or_list num_ops -> Just xs) + | any (cheapEqExpr x) xs + -> Just x + _ -> Nothing where mkL = Lit . mkNumLiteral platform num_ops @@ -3122,6 +3102,11 @@ -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y) -- increase operation numbers + -- x or (y and ... and x and ... and z) ==> x + (x, is_and_list num_ops -> Just xs) + | any (cheapEqExpr x) xs + -> Just x + _ -> Nothing where mkL = Lit . mkNumLiteral platform num_ops @@ -3160,7 +3145,7 @@ App (OpVal op') x | op == op' -> Just x _ -> Nothing -is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr) +is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg) is_add num_ops e = is_binop (numAdd num_ops) e is_sub num_ops e = is_binop (numSub num_ops) e is_mul num_ops e = is_binop (numMul num_ops) e @@ -3171,6 +3156,25 @@ is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr) is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e +-- Return a list of operands for a given operation. +-- E.e. is_and_list (a and ... and z) => [a,...,z] for any nesting of the and +-- operation +is_list :: (CoreExpr -> Maybe (CoreArg,CoreArg)) -> CoreExpr -> Maybe [CoreArg] +is_list f e_org = case f e_org of -- do we have the operator at all? + Just (a,b) -> Just (go [a,b]) + Nothing -> Nothing + where + go = \case + [] -> [] + (e:es) -> case f e of + -- we can't split any more: add to the result list + Nothing -> e : go es + Just (a,b) -> go (a:b:es) + +is_and_list, is_or_list :: NumOps -> CoreExpr -> Maybe [CoreArg] +is_and_list ops = is_list (is_and ops) +is_or_list ops = is_list (is_or ops) + -- match operation with a literal (handles commutativity) is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr) is_lit_add num_ops e = is_lit' is_add num_ops e @@ -3404,21 +3408,29 @@ , \v -> (App (App (Var f) type_arg) (Var v))) -- See Note [caseRules for dataToTag] -caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x - | Just DataToTagOp <- isPrimOpId_maybe f - , Just (tc, _) <- tcSplitTyConApp_maybe ty - , isAlgTyCon tc - , not (isTypeDataTyCon tc) -- See wrinkle (W2c) in GHC.Rename.Module - -- Note [Type data declarations] - = Just (v, tx_con_dtt ty - , \v -> App (App (Var f) (Type ty)) (Var v)) +caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x + | Just op <- isPrimOpId_maybe f + , op == DataToTagSmallOp || op == DataToTagLargeOp + = case splitTyConApp_maybe ty of + Just (tc, _) | isValidDTT2TyCon tc + -> Just (v, tx_con_dtt tc + , \v' -> Var f `App` Type lev `App` Type ty `App` Var v') + _ -> pprTraceUserWarning warnMsg Nothing + where + warnMsg = vcat $ map text + [ "Found dataToTag primop applied to a non-ADT type. This could" + , "be a future bug in GHC, or it may be caused by an unsupported" + , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#." + , "In either case, the GHC developers would like to know about it!" + , "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug" + ] caseRules _ _ = Nothing -- | Case rules -- --- It's important that occurence info are present, hence the use of In* types. +-- It's important that occurrence info are present, hence the use of In* types. caseRules2 :: InExpr -- ^ Scutinee -> InId -- ^ Case-binder @@ -3519,9 +3531,9 @@ tx_con_tte platform (DataAlt dc) -- See Note [caseRules for tagToEnum] = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc -tx_con_dtt :: Type -> AltCon -> Maybe AltCon +tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon tx_con_dtt _ DEFAULT = Just DEFAULT -tx_con_dtt ty (LitAlt (LitNumber LitNumInt i)) +tx_con_dtt tc (LitAlt (LitNumber LitNumInt i)) | tag >= 0 , tag < n_data_cons = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) @@ -3529,17 +3541,16 @@ = Nothing where tag = fromInteger i :: ConTagZ - tc = tyConAppTyCon ty n_data_cons = tyConFamilySize tc data_cons = tyConDataCons tc -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) +tx_con_dtt _ alt = pprPanic "caseRules/dataToTag: bad alt" (ppr alt) {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to transform - case tagToEnum x of + case tagToEnum# x of False -> e1 True -> e2 into @@ -3547,13 +3558,13 @@ 0# -> e1 1# -> e2 -This rule eliminates a lot of boilerplate. For +See #8317. This rule eliminates a lot of boilerplate. For if (x>y) then e2 else e1 we generate - case tagToEnum (x ># y) of + case tagToEnum# (x ># y) of False -> e1 True -> e2 -and it is nice to then get rid of the tagToEnum. +and it is nice to then get rid of the tagToEnum#. Beware (#14768): avoid the temptation to map constructor 0 to DEFAULT, in the hope of getting this @@ -3571,15 +3582,16 @@ DEFAULT -> e1 DEFAULT -> e2 -Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils -(add_default in mkCase3). +Instead, when possible, we turn one branch into DEFAULT in +GHC.Core.Opt.Simplify.Utils.mkCase2; see Note [Literal cases] +in that module. Note [caseRules for dataToTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [dataToTag# magic]. +See also Note [DataToTag overview] in GHC.Tc.Instance.Class. We want to transform - case dataToTag x of + case dataToTagSmall# x of DEFAULT -> e1 1# -> e2 into @@ -3587,14 +3599,23 @@ DEFAULT -> e1 (:) _ _ -> e2 -Note the need for some wildcard binders in -the 'cons' case. +(Note the need for some wildcard binders in the 'cons' case.) -For the time, we only apply this transformation when the type of `x` is a type -headed by a normal tycon. In particular, we do not apply this in the case of a -data family tycon, since that would require carefully applying coercion(s) -between the data family and the data family instance's representation type, -which caseRules isn't currently engineered to handle (#14680). +This transformation often enables further optimisation via +case-flattening and case-of-known-constructor and can be very +important for code using derived Eq instances. + +We can apply this transformation only when we can easily get the +constructors from the type at which dataToTagSmall# is used. And we +cannot apply this transformation at "type data"-related types without +breaking invariant I1 from Note [Type data declarations] in +GHC.Rename.Module. That leaves exactly the types satisfying condition +DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class. + +All of the above applies identically for `dataToTagLarge#`. And +thanks to wrinkle DTW5, there is no need to worry about large-tag +arguments for `dataToTagSmall#`; those cause undefined behavior anyway. + Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/CprAnal.hs b/GHC/Core/Opt/CprAnal.hs --- a/GHC/Core/Opt/CprAnal.hs +++ b/GHC/Core/Opt/CprAnal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate @@ -22,12 +23,15 @@ import GHC.Types.Cpr import GHC.Types.Unique.MemoFun +import GHC.Core import GHC.Core.FamInstEnv import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Utils -import GHC.Core +import GHC.Core.Coercion +import GHC.Core.Reduction import GHC.Core.Seq +import GHC.Core.TyCon import GHC.Core.Opt.WorkWrap.Utils import GHC.Data.Graph.UnVar -- for UnVarSet @@ -209,16 +213,20 @@ -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType' cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $ - cprAnal' env e + cprAnal' env e cprAnal' _ (Lit lit) = (topCprType, Lit lit) cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact cprAnal' _ (Coercion co) = (topCprType, Coercion co) cprAnal' env (Cast e co) - = (cpr_ty, Cast e' co) + = (cpr_ty', Cast e' co) where (cpr_ty, e') = cprAnal env e + cpr_ty' + | cpr_ty == topCprType = topCprType -- cheap case first + | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors] + | otherwise = cpr_ty cprAnal' env (Tick t e) = (cpr_ty, Tick t e') @@ -281,7 +289,7 @@ -> extendSigEnvAllSame env ids sig ForeachField field_cprs | let sigs = zipWith (mkCprSig . idArity) ids field_cprs - -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) + -> extendSigEnvList env (zipEqual ids sigs) | otherwise = extendSigEnvAllSame env ids topCprSig (rhs_ty, rhs') = cprAnal env_alt rhs @@ -296,9 +304,16 @@ -- See Note [Nested CPR] exprTerminates :: CoreExpr -> TermFlag +-- ^ A /very/ simple termination analysis. exprTerminates e - | exprIsHNF e = Terminates -- A /very/ simple termination analysis. - | otherwise = MightDiverge + | exprIsHNF e = Terminates + | exprOkForSpeculation e = Terminates + | otherwise = MightDiverge + -- Annoyingly, we have to check both for HNF and ok-for-spec. + -- * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing! + -- * `lvl` is an HNF if its unfolding is evaluated + -- (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never + -- ok-for-spec due to Note [exprOkForSpeculation and evaluated variables]. cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) -- Main function that takes care of /nested/ CPR. See Note [Nested CPR] @@ -339,7 +354,7 @@ | isLocalId id = assertPpr (isDataStructure id) (ppr id) topCprType -- See Note [CPR for DataCon wrappers] - | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id) + | Just rhs <- dataConWrapUnfolding_maybe id = fst $ cprAnalApp env rhs args -- DataCon worker | Just con <- isDataConWorkId_maybe id @@ -361,14 +376,16 @@ -- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, -- given a saturated number of 'CprType's for its field expressions. -- Implements the Nested part of Note [Nested CPR]. -cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType +cprTransformDataConWork :: AnalEnv -> DataCon + -> [(CprType, CoreArg)] -- Info about /value/ arguments + -> CprType cprTransformDataConWork env con args | null (dataConExTyCoVars con) -- No existentials , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE] , args `lengthIs` wkr_arity , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors] - -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True - = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) + = -- pprTraceWith "cprTransformDataConWork" (\r -> ppr con <+> ppr wkr_arity <+> ppr args <+> ppr r) $ + CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) | otherwise = topCprType where @@ -384,6 +401,19 @@ mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 +isRecNewTyConApp :: AnalEnv -> Type -> Bool +-- See Note [CPR for recursive newtype constructors] +isRecNewTyConApp env ty + --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined + | Just (tc, tc_args) <- splitTyConApp_maybe ty = + if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args + -> isRecNewTyConApp env rhs + | Just dc <- newTyConDataCon_maybe tc + -> ae_rec_dc env dc == DefinitelyRecursive + | otherwise + -> False + | otherwise = False + -- -- * Bindings -- @@ -407,12 +437,18 @@ | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, [(Id,CoreExpr)]) + abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ] + -- The fixed-point varies the idCprSig field of the binders and and their -- entries in the AnalEnv, and terminates if that annotation does not change -- any more. loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) loop n env pairs | found_fixpoint = (reset_env', pairs') + | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort | otherwise = loop (n+1) env' pairs' where -- In all but the first iteration, delete the virgin flag @@ -505,14 +541,16 @@ | isDataStructure id -- Data structure => no code => no need to analyse rhs = (id, rhs, env) | otherwise - = (id `setIdCprSig` sig', rhs', env') + = -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig') + (id `setIdCprSig` sig', rhs', env') where (rhs_ty, rhs') = cprAnal env rhs -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty - | otherwise = rhs_ty + | rhs_ty == topCprType = topCprType -- cheap case first + | stays_thunk = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' -- See Note [OPAQUE pragma] @@ -631,7 +669,7 @@ , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. , ae_rec_dc :: DataCon -> IsRecDataConResult - -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType } instance Outputable AnalEnv where @@ -1034,10 +1072,11 @@ What can we do about it? - A. Don't CPR functions that return a *recursive data type* (the list in this - case). This is the solution we adopt. Rationale: the benefit of CPR on - recursive data structures is slight, because it only affects the outer layer - of a potentially massive data structure. + A. Don't give recursive data constructors or casts representing recursive newtype constructors + the CPR property (the list in this case). This is the solution we adopt. + Rationale: the benefit of CPR on recursive data structures is slight, + because it only affects the outer layer of a potentially massive data + structure. B. Don't CPR any *recursive function*. That would be quite conservative, as it would also affect e.g. the factorial function. C. Flat CPR only for recursive functions. This prevents the asymptotic @@ -1047,11 +1086,16 @@ `c` in the second eqn of `replicateC`). But we'd need to know which paths were hot. We want such static branch frequency estimates in #20378. -We adopt solution (A) It is ad-hoc, but appears to work reasonably well. -Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too: -See Note [Detecting recursive data constructors]. We don't have to be perfect -and can simply keep on unboxing if unsure. +We adopt solution (A). It is ad-hoc, but appears to work reasonably well. +Specifically: +* For data constructors, in `cprTransformDataConWork` we check for a recursive + data constructor by calling `ae_rec_dc env`, which is just a memoised version + of `isRecDataCon`. See Note [Detecting recursive data constructors] +* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype + by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`. + See Note [CPR for recursive newtype constructors] + Note [Detecting recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ What qualifies as a "recursive data constructor" as per @@ -1067,12 +1111,15 @@ types of its data constructors and check `tc_args` for recursion. C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to `rhs`, look into the `rhs` type. + D. If `ty = f a`, then look into `f` and `a` + E. If `ty = ty' |> co`, then look into `ty'` A few perhaps surprising points: 1. It deems any function type as non-recursive, because it's unlikely that a recursion through a function type builds up a recursive data structure. - 2. It doesn't look into kinds or coercion types because there's nothing to unbox. + 2. It doesn't look into kinds, literals or coercion types because we are + ultimately looking for value-level recursion. Same for promoted data constructors. 3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not; we simply look at its definition/DataCons and its field tys and look for @@ -1144,6 +1191,22 @@ I've played with the idea to make points (1) through (3) of 'isRecDataCon' configurable like (4) to enable more re-use throughout the compiler, but haven't found a killer app for that yet, so ultimately didn't do that. + +Note [CPR for recursive newtype constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A newtype constructor is considered recursive iff the data constructor of the +equivalent datatype definition is recursive. +See Note [CPR for recursive data constructors]. +Detection is a bit complicated by the fact that newtype constructor applications +reflect as Casts in Core: + + newtype List a = C (Maybe (a, List a)) + xs = C (Just (0, C Nothing)) + ==> {desugar to Core} + xs = Just (0, Nothing |> sym N:List) |> sym N:List + +So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than +in `cprTransformDataConWork` as for data constructors. Note [CPR examples] ~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs --- a/GHC/Core/Opt/DmdAnal.hs +++ b/GHC/Core/Opt/DmdAnal.hs @@ -23,7 +23,6 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type -import GHC.Core.Predicate( isEqualityClass, isCTupleClass ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) @@ -33,6 +32,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 ) @@ -47,7 +47,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Outputable import Data.List ( mapAccumL ) @@ -88,7 +87,7 @@ -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. -- --- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note +-- Note: use `seqBinds` on the result to avoid leaks due to laziness (cf Note -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds @@ -426,7 +425,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 @@ -555,7 +554,9 @@ WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) where want_precise_field_dmds (DataAlt dc) - | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc + | let tc = dataConTyCon dc + , assertPpr (not (isNewTyCon tc)) (ppr dc) True -- DataAlt is never newtype + , Nothing <- tyConSingleDataCon_maybe $ dataConTyCon dc = False -- Not a product type, even though this is the -- only remaining possible data constructor | DefinitelyRecursive <- ae_rec_dc env dc @@ -603,16 +604,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@ @@ -800,14 +806,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 @@ -815,7 +825,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. @@ -825,6 +836,10 @@ from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +You might think that we should check for side-effects rather than just for +precise exceptions. Right you are! See Note [Side-effects and strictness] +for why we unfortunately do not. + Note [Demand analysis for recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ T11545 features a single-product, recursive data type @@ -998,14 +1013,14 @@ -> 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 = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $ dmdTransformDataConSig (dataConRepStrictness con) sd -- See Note [DmdAnal for DataCon wrappers] - | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var) + | Just rhs <- dataConWrapUnfolding_maybe var , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs = dmd_ty -- Dictionary component selectors @@ -1029,10 +1044,10 @@ TopLevel | isInterestingTopLevelFn var -- Top-level things will be used multiple times or not at - -- all anyway, hence the multDmd below: It means we don't + -- all anyway, hence the `floatifyDmd`: it means we don't -- have to track whether @var@ is used strictly or at most - -- once, because ultimately it never will. - -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness + -- once, because ultimately it never will + -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd)) | otherwise -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later -- Everything else: @@ -1071,31 +1086,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 @@ -1127,13 +1144,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 isJoinId_maybe fn of - Just join_arity -> count isId $ fst $ collectNBinders join_arity rhs - Nothing -> 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 @@ -1157,8 +1167,8 @@ go depth ty sd | depth <= max_depth , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty - , Just dc <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyCoVars dc) -- Can't unbox results with existentials + , Just [dc] <- canUnboxTyCon tc -- tc is not a newtype + , null (dataConExTyCoVars dc) -- Can't unbox results with existentials , dataConRepArity dc <= dmd_unbox_width (ae_opts env) , Just (_, ds) <- viewProd (dataConRepArity dc) sd , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args @@ -1233,47 +1243,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 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 @@ -1283,22 +1343,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: @@ -1329,6 +1384,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: @@ -1403,7 +1482,7 @@ Now if f is subsequently inlined, we'll use 'g' and ... disaster. SOLUTION: if f has a stable unfolding, treat every free variable as a -/demand root/, that is: Analyse it as if it was a variable occuring in a +/demand root/, that is: Analyse it as if it was a variable occurring in a 'topDmd' context. This is done in `demandRoot` (which we also use for exported top-level ids). Do the same for Ids free in the RHS of any RULES for f. @@ -1896,10 +1975,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. -} @@ -1922,32 +2001,38 @@ 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 + -- vcat [text "function:" <+> ppr fn + -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ (arg_dmds', set_lam_dmds arg_dmds' rhs) @@ -1955,23 +2040,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], @@ -2081,12 +2172,6 @@ -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal -> DontUnbox - | doNotUnbox ty - -> DontUnbox -- See Note [Do not unbox class dictionaries] - -- NB: 'ty' has not been normalised, so this will (rightly) - -- catch newtype dictionaries too. - -- NB: even for bottoming functions, don't unbox dictionaries - | DefinitelyRecursive <- ae_rec_dc env dc -- See Note [Which types are unboxed?] -- and Note [Demand analysis for recursive data constructors] @@ -2096,76 +2181,6 @@ -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args) (dataConRepStrictness dc) dmds) - - -doNotUnbox :: Type -> Bool --- Do not unbox class dictionaries, except equality classes and tuples --- Note [Do not unbox class dictionaries] -doNotUnbox arg_ty - = case tyConAppTyCon_maybe arg_ty of - Just tc | Just cls <- tyConClass_maybe tc - -> not (isEqualityClass cls || isCTupleClass cls) - -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries] - - _ -> False - -{- Note [Do not unbox class dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never unbox class dictionaries in worker/wrapper. - -1. INLINABLE functions - If we have - f :: Ord a => [a] -> Int -> a - {-# INLINABLE f #-} - and we worker/wrapper f, we'll get a worker with an INLINABLE pragma - (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), - which can still be specialised by the type-class specialiser, something like - fw :: Ord a => [a] -> Int# -> a - - BUT if f is strict in the Ord dictionary, we might unpack it, to get - fw :: (a->a->Bool) -> [a] -> Int# -> a - and the type-class specialiser can't specialise that. An example is #6056. - - Historical note: #14955 describes how I got this fix wrong the first time. - I got aware of the issue in T5075 by the change in boxity of loop between - demand analysis runs. - -2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur - occur without INLINABLE, when we use -fexpose-all-unfoldings and - -fspecialise-aggressively to do vigorous cross-module specialisation. - -3. #18421 found that unboxing a dictionary can also make the worker less likely - to inline; the inlining heuristics seem to prefer to inline a function - applied to a dictionary over a function applied to a bunch of functions. - -TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing -a raft of higher-order functions isn't a huge win anyway -- you really want to -specialise the function. - -Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398) - f :: (% Eq a, Show a %) => blah - with -fdicts-strict it is great to unbox to - $wf :: Eq a => Show a => blah - (where I have written out the currying explicitly). Now we can specialise - $wf on the Eq or Show dictionary. Nothing is lost. - - And something is gained. It is possible that `f` will look like this: - f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)... - where there is a recurive call to `f`, or to another function that takes the - same tuple dictionary, but where the tuple is built from the components of - `d`. The Simplier does not fix this. But if we unpacked the dictionary - we'd get - $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %) - in ...f @a (% sel1 d, sel2 d %) - and all the tuple building and taking apart will disappear. - -Wrinkle (DNB2): we /do/ wnat to unbox equality dictionaries, - for (~), (~~), and Coercible (#23398). Their payload is a single unboxed - coercion. We never want to specialise on `(t1 ~ t2)`. All that would do is - to make a copy of the function's RHS with a particular coercion. Unlike - normal class methods, that does not unlock any new optimisation - opportunities in the specialised RHS. --} {- ********************************************************************* * * diff --git a/GHC/Core/Opt/Exitify.hs b/GHC/Core/Opt/Exitify.hs --- a/GHC/Core/Opt/Exitify.hs +++ b/GHC/Core/Opt/Exitify.hs @@ -36,20 +36,24 @@ -} import GHC.Prelude +import GHC.Builtin.Uniques +import GHC.Core +import GHC.Core.Utils +import GHC.Core.FVs +import GHC.Core.Type + import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Core -import GHC.Core.Utils -import GHC.Utils.Monad.State.Strict -import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Core.FVs -import GHC.Data.FastString -import GHC.Core.Type +import GHC.Types.Basic( JoinPointHood(..) ) + +import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc( mapSnd ) +import GHC.Data.FastString + import Data.Bifunctor import Control.Monad @@ -160,7 +164,7 @@ go captured (_, AnnLet ann_bind body) -- join point, RHS and body are in tail-call position | AnnNonRec j rhs <- ann_bind - , Just join_arity <- isJoinId_maybe j + , JoinPoint join_arity <- idJoinPointHood j = do let (params, join_body) = collectNAnnBndrs join_arity rhs join_body' <- go (captured ++ params) join_body let rhs' = mkLams params join_body' diff --git a/GHC/Core/Opt/FloatIn.hs b/GHC/Core/Opt/FloatIn.hs --- a/GHC/Core/Opt/FloatIn.hs +++ b/GHC/Core/Opt/FloatIn.hs @@ -29,7 +29,7 @@ import GHC.Core.Type import GHC.Types.Basic ( RecFlag(..), isRec ) -import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Id ( idType, isJoinId, idJoinPointHood ) import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set @@ -173,7 +173,7 @@ = wrapFloats drop_here $ mkTicks ticks $ mkApps (fiExpr platform fun_drop ann_fun) - (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args) + (zipWithEqual (fiExpr platform) arg_drops ann_args) -- use zipWithEqual, we should have -- length ann_args = length arg_fvs = length arg_drops where @@ -234,6 +234,29 @@ we're careful not to float into the target of a jump (though we can float into the arguments just fine). +Floating in can /enhance/ join points. Consider this (#3458) + f2 x = let g :: Int -> Int + g y = if y==0 then y+x else g (y-1) + in case g x of + 0 -> True + _ -> False + +Here `g` is not a join point. But if we float inwards it becomes one! We +float in; the occurrence analyser identifies `g` as a join point; the Simplifier +retains that property, so we get + f2 x = case (joinrec + g y = if y==0 then y+x else g (y-1) + in jump g x) of + 0 -> True + _ -> False + +Now that outer case gets pushed into the RHS of the joinrec, giving + f2 x = joinrec g y = if y==0 + then case y+x of { 0 -> True; _ -> False } + else jump g (y-1) + in jump g x +Nice! + Note [Floating in past a lambda group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * We must be careful about floating inside a value lambda. @@ -322,7 +345,7 @@ * In fiExpr (AnnCase ...). Remember to include the case_bndr in the binders. Again, no need to delete the alt binders from the rhs - free vars, beause any bindings mentioning them will be dropped + free vars, because any bindings mentioning them will be dropped here unconditionally. -} @@ -423,6 +446,30 @@ array indexing operations, which have a single DEFAULT alternative without any binders, to be floated inward. +In particular, we want to be able to transform + + case indexIntArray# arr i of vi { + __DEFAULT -> case <# j n of _ { + __DEFAULT -> False + 1# -> case indexIntArray# arr j of vj { + __DEFAULT -> ... vi ... vj ... + } + } + } + +by floating in `indexIntArray# arr i` to produce + + case <# j n of _ { + __DEFAULT -> False + 1# -> case indexIntArray# arr i of vi { + __DEFAULT -> case indexIntArray# arr j of vj { + __DEFAULT -> ... vi ... vj ... + } + } + } + +...which skips the `indexIntArray# arr i` call entirely in the out-of-bounds branch. + SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed scalars also need to be floated inward, but unpacks have a single non-DEFAULT alternative that binds the elements of the tuple. We now therefore also support @@ -431,12 +478,11 @@ But there are wrinkles * Which unlifted cases do we float? - See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which - explains: - - We can float in can_fail primops (which concerns imprecise exceptions), - but we can't float them out. - - But we can float a has_side_effects primop, but NOT inside a lambda, - so for now we don't float them at all. Hence exprOkForSideEffects. + See Note [Transformations affected by primop effects] in GHC.Builtin.PrimOps + which explains: + - We can float in or discard CanFail primops, but we can't float them out. + - We don't want to discard a synchronous exception or side effect + so we don't float those at all. Hence exprOkToDiscard. - Throwing precise exceptions is a special case of the previous point: We may /never/ float in a call to (something that ultimately calls) 'raiseIO#'. @@ -448,7 +494,7 @@ ===> f (case a /# b of r -> F# r) because that creates a new thunk that wasn't there before. And - because it can't be floated out (can_fail), the thunk will stay + because it can't be floated out (CanFail), the thunk will stay there. Disaster! (This happened in nofib 'simple' and 'scs'.) Solution: only float cases into the branches of other cases, and @@ -477,7 +523,7 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs]) | isUnliftedType (idType case_bndr) -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType - , exprOkForSideEffects (deAnnotate scrut) + , exprOkToDiscard (deAnnotate scrut) -- See Note [Floating primops] = wrapFloats shared_binds $ fiExpr platform (case_float : rhs_binds) rhs @@ -497,7 +543,7 @@ = wrapFloats drop_here1 $ wrapFloats drop_here2 $ Case (fiExpr platform scrut_drops scrut) case_bndr ty - (zipWithEqual "fiExpr" fi_alt alts_drops_s alts) + (zipWithEqual fi_alt alts_drops_s alts) -- use zipWithEqual, we should have length alts_drops_s = length alts where -- Float into the scrut and alts-considered-together just like App @@ -594,12 +640,12 @@ fi_bind to_drops pairs = [ (binder, fiRhs platform to_drop binder rhs) - | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] + | ((binder, rhs), to_drop) <- zipEqual pairs to_drops ] ------------------ fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs - | Just join_arity <- isJoinId_maybe bndr + | JoinPoint join_arity <- idJoinPointHood bndr , let (bndrs, body) = collectNAnnBndrs join_arity rhs = mkLams bndrs (fiExpr platform to_drop body) | otherwise @@ -775,7 +821,7 @@ | otherwise = floatIsCase bind || n_used_alts > 1 -- floatIsCase: see Note [Floating primops] - new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe + new_fork_boxes = zipWithEqual insert_maybe fork_boxes used_in_flags insert :: DropBox -> DropBox diff --git a/GHC/Core/Opt/FloatOut.hs b/GHC/Core/Opt/FloatOut.hs --- a/GHC/Core/Opt/FloatOut.hs +++ b/GHC/Core/Opt/FloatOut.hs @@ -22,7 +22,7 @@ import GHC.Utils.Logger import GHC.Types.Id ( Id, idType, -- idArity, isDeadEndId, - isJoinId, isJoinId_maybe ) + isJoinId, idJoinPointHood ) import GHC.Types.Tickish import GHC.Core.Opt.SetLevels import GHC.Types.Unique.Supply ( UniqSupply ) @@ -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') }} @@ -487,7 +441,7 @@ -> LevelledExpr -> (FloatStats, FloatBinds, CoreExpr) floatRhs bndr rhs - | Just join_arity <- isJoinId_maybe bndr + | JoinPoint join_arity <- idJoinPointHood bndr , Just (bndrs, body) <- try_collect join_arity rhs [] = case bndrs of [] -> floatExpr rhs @@ -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 diff --git a/GHC/Core/Opt/Monad.hs b/GHC/Core/Opt/Monad.hs --- a/GHC/Core/Opt/Monad.hs +++ b/GHC/Core/Opt/Monad.hs @@ -73,23 +73,27 @@ import Control.Monad import Control.Applicative ( Alternative(..) ) -data FloatOutSwitches = FloatOutSwitches { - floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if - -- doing so will abstract over n or fewer - -- value variables - -- Nothing <=> float all lambdas to top level, - -- regardless of how many free variables - -- Just 0 is the vanilla case: float a lambda - -- iff it has no free vars +data FloatOutSwitches = FloatOutSwitches + { floatOutLambdas :: Maybe Int -- ^ Just n <=> float lambdas to top level, if + -- doing so will abstract over n or fewer + -- value variables + -- Nothing <=> float all lambdas to top level, + -- regardless of how many free variables + -- Just 0 is the vanilla case: float a lambda + -- iff it has no free vars - floatOutConstants :: Bool, -- ^ True <=> float constants to top level, - -- even if they do not escape a lambda - floatOutOverSatApps :: Bool, - -- ^ True <=> float out over-saturated applications - -- based on arity information. - -- See Note [Floating over-saturated applications] - -- in GHC.Core.Opt.SetLevels - floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. + , floatOutConstants :: Bool -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + + , floatOutOverSatApps :: Bool -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in GHC.Core.Opt.SetLevels + , floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. + + , floatJoinsToTop :: Bool -- ^ Float join points to top level if possible + -- See Note [Floating join point bindings] + -- in GHC.Core.Opt.SetLevels } instance Outputable FloatOutSwitches where ppr = pprFloatOutSwitches @@ -100,6 +104,7 @@ sep $ punctuate comma $ [ text "Lam =" <+> ppr (floatOutLambdas sw) , text "Consts =" <+> ppr (floatOutConstants sw) + , text "JoinsToTop =" <+> ppr (floatJoinsToTop sw) , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) {- diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs --- a/GHC/Core/Opt/OccurAnal.hs +++ b/GHC/Core/Opt/OccurAnal.hs @@ -1,3589 +1,4073 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -************************************************************************ -* * -\section[OccurAnal]{Occurrence analysis pass} -* * -************************************************************************ - -The occurrence analyser re-typechecks a core expression, returning a new -core expression with (hopefully) improved usage information. --} - -module GHC.Core.Opt.OccurAnal ( - occurAnalysePgm, - occurAnalyseExpr, - zapLambdaBndrs, scrutBinderSwap_maybe - ) where - -import GHC.Prelude hiding ( head, init, last, tail ) - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - mkCastMCo, mkTicks ) -import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) -import GHC.Core.Coercion -import GHC.Core.Predicate ( isDictId ) -import GHC.Core.Type -import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) - -import GHC.Data.Maybe( isJust, orElse ) -import GHC.Data.Graph.Directed ( SCC(..), Node(..) - , stronglyConnCompFromEdgedVerticesUniq - , stronglyConnCompFromEdgedVerticesUniqR ) -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Basic -import GHC.Types.Tickish -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Var -import GHC.Types.Demand ( argOneShots, argsOneShots ) - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc - -import GHC.Builtin.Names( runRWKey ) -import GHC.Unit.Module( Module ) - -import Data.List (mapAccumL, mapAccumR) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.List.NonEmpty as NE - -{- -************************************************************************ -* * - occurAnalysePgm, occurAnalyseExpr -* * -************************************************************************ - -Here's the externally-callable interface: --} - --- | Do occurrence analysis, and discard occurrence info returned -occurAnalyseExpr :: CoreExpr -> CoreExpr -occurAnalyseExpr expr = expr' - where - (WithUsageDetails _ expr') = occAnal initOccEnv expr - -occurAnalysePgm :: Module -- Used only in debug output - -> (Id -> Bool) -- Active unfoldings - -> (Activation -> Bool) -- Active rules - -> [CoreRule] -- Local rules for imported Ids - -> CoreProgram -> CoreProgram -occurAnalysePgm this_mod active_unf active_rule imp_rules binds - | isEmptyDetails final_usage - = occ_anald_binds - - | otherwise -- See Note [Glomming] - = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage)) - occ_anald_glommed_binds - where - init_env = initOccEnv { occ_rule_act = active_rule - , occ_unf_act = active_unf } - - (WithUsageDetails final_usage occ_anald_binds) = go init_env binds - (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel - imp_rule_edges - (flattenBinds binds) - initial_uds - -- It's crucial to re-analyse the glommed-together bindings - -- so that we establish the right loop breakers. Otherwise - -- we can easily create an infinite loop (#9583 is an example) - -- - -- Also crucial to re-analyse the /original/ bindings - -- in case the first pass accidentally discarded as dead code - -- a binding that was actually needed (albeit before its - -- definition site). #17724 threw this up. - - initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) - -- The RULES declarations keep things alive! - - -- imp_rule_edges maps a top-level local binder 'f' to the - -- RHS free vars of any IMP-RULE, a local RULE for an imported function, - -- where 'f' appears on the LHS - -- e.g. RULE foldr f = blah - -- imp_rule_edges contains f :-> fvs(blah) - -- We treat such RULES as extra rules for 'f' - -- See Note [Preventing loops due to imported functions rules] - imp_rule_edges :: ImpRuleEdges - imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv - [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $ - exprsFreeIds args `delVarSetList` bndrs - | Rule { ru_act = act, ru_bndrs = bndrs - , ru_args = args, ru_rhs = rhs } <- imp_rules - -- Not BuiltinRules; see Note [Plugin rules] - , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ] - - go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind] - go !_ [] - = WithUsageDetails initial_uds [] - go env (bind:binds) - = WithUsageDetails final_usage (bind' ++ binds') - where - (WithUsageDetails bs_usage binds') = go env binds - (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage - -{- ********************************************************************* -* * - IMP-RULES - Local rules for imported functions -* * -********************************************************************* -} - -type ImpRuleEdges = IdEnv [(Activation, VarSet)] - -- Mapping from a local Id 'f' to info about its IMP-RULES, - -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS - -- We record (a) its Activation and (b) the RHS free vars - -- See Note [IMP-RULES: local rules for imported functions] - -noImpRuleEdges :: ImpRuleEdges -noImpRuleEdges = emptyVarEnv - -lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)] -lookupImpRules imp_rule_edges bndr - = case lookupVarEnv imp_rule_edges bndr of - Nothing -> [] - Just vs -> vs - -impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails --- Variable mentioned in RHS of an IMP-RULE for the bndr, --- whether active or not -impRulesScopeUsage imp_rules_info - = foldr add emptyDetails imp_rules_info - where - add (_,vs) usage = addManyOccs usage vs - -impRulesActiveFvs :: (Activation -> Bool) -> VarSet - -> [(Activation,VarSet)] -> VarSet -impRulesActiveFvs is_active bndr_set vs - = foldr add emptyVarSet vs `intersectVarSet` bndr_set - where - add (act,vs) acc | is_active act = vs `unionVarSet` acc - | otherwise = acc - -{- Note [IMP-RULES: local rules for imported functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We quite often have - * A /local/ rule - * for an /imported/ function -like this: - foo x = blah - {-# RULE "map/foo" forall xs. map foo xs = xs #-} -We call them IMP-RULES. They are important in practice, and occur a -lot in the libraries. - -IMP-RULES are held in mg_rules of ModGuts, and passed in to -occurAnalysePgm. - -Main Invariant: - -* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS - just like a RULE for f. - -Note [IMP-RULES: unavoidable loops] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - f = /\a. B.g a - RULE B.g Int = 1 + f Int -Note that - * The RULE is for an imported function. - * f is non-recursive -Now we -can get - f Int --> B.g Int Inlining f - --> 1 + f Int Firing RULE -and so the simplifier goes into an infinite loop. This -would not happen if the RULE was for a local function, -because we keep track of dependencies through rules. But -that is pretty much impossible to do for imported Ids. Suppose -f's definition had been - f = /\a. C.h a -where (by some long and devious process), C.h eventually inlines to -B.g. We could only spot such loops by exhaustively following -unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) -f. - -We regard this potential infinite loop as a *programmer* error. -It's up the programmer not to write silly rules like - RULE f x = f x -and the example above is just a more complicated version. - -Note [Specialising imported functions] (referred to from Specialise) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For *automatically-generated* rules, the programmer can't be -responsible for the "programmer error" in Note [IMP-RULES: unavoidable -loops]. In particular, consider specialising a recursive function -defined in another module. If we specialise a recursive function B.g, -we get - g_spec = .....(B.g Int)..... - RULE B.g Int = g_spec -Here, g_spec doesn't look recursive, but when the rule fires, it -becomes so. And if B.g was mutually recursive, the loop might not be -as obvious as it is here. - -To avoid this, - * When specialising a function that is a loop breaker, - give a NOINLINE pragma to the specialised function - -Note [Preventing loops due to imported functions rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - import GHC.Base (foldr) - - {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} - filter p xs = build (\c n -> foldr (filterFB c p) n xs) - filterFB c p = ... - - f = filter p xs - -Note that filter is not a loop-breaker, so what happens is: - f = filter p xs - = {inline} build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -We are in an infinite loop. - -A more elaborate example (that I actually saw in practice when I went to -mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: - {-# LANGUAGE RankNTypes #-} - module GHCList where - - import Prelude hiding (filter) - import GHC.Base (build) - - {-# INLINABLE filter #-} - filter :: (a -> Bool) -> [a] -> [a] - filter p [] = [] - filter p (x:xs) = if p x then x : filter p xs else filter p xs - - {-# NOINLINE [0] filterFB #-} - filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b - filterFB c p x r | p x = x `c` r - | otherwise = r - - {-# RULES - "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr - (filterFB c p) n xs) - "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p - #-} - -Then (because RULES are applied inside INLINABLE unfoldings, but inlinings -are not), the unfolding given to "filter" in the interface file will be: - filter p [] = [] - filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs - -Note that because this unfolding does not mention "filter", filter is not -marked as a strong loop breaker. Therefore at a use site in another module: - filter p xs - = {inline} - case xs of [] -> [] - (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) - else build (\c n -> foldr (filterFB c p) n xs) - - build (\c n -> foldr (filterFB c p) n xs) - = {inline} foldr (filterFB (:) p) [] xs - = {RULE} filter p xs - -And we are in an infinite loop again, except that this time the loop is producing an -infinitely large *term* (an unrolling of filter) and so the simplifier finally -dies with "ticks exhausted" - -SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB' -because it mentions 'filterFB' on the LHS. This is the Main Invariant -in Note [IMP-RULES: local rules for imported functions]. - -So, during loop-breaker analysis: - -- for each active RULE for a local function 'f' we add an edge between - 'f' and the local FVs of the rule RHS - -- for each active RULE for an *imported* function we add dependency - edges between the *local* FVS of the rule LHS and the *local* FVS of - the rule RHS. - -Even with this extra hack we aren't always going to get things -right. For example, it might be that the rule LHS mentions an imported -Id, and another module has a RULE that can rewrite that imported Id to -one of our local Ids. - -Note [Plugin rules] -~~~~~~~~~~~~~~~~~~~ -Conal Elliott (#11651) built a GHC plugin that added some -BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to -do some domain-specific transformations that could not be expressed -with an ordinary pattern-matching CoreRule. But then we can't extract -the dependencies (in imp_rule_edges) from ru_rhs etc, because a -BuiltinRule doesn't have any of that stuff. - -So we simply assume that BuiltinRules have no dependencies, and filter -them out from the imp_rule_edges comprehension. - -Note [Glomming] -~~~~~~~~~~~~~~~ -RULES for imported Ids can make something at the top refer to -something at the bottom: - - foo = ...(B.f @Int)... - $sf = blah - RULE: B.f @Int = $sf - -Applying this rule makes foo refer to $sf, although foo doesn't appear to -depend on $sf. (And, as in Note [IMP-RULES: local rules for imported functions], the -dependency might be more indirect. For example, foo might mention C.t -rather than B.f, where C.t eventually inlines to B.f.) - -NOTICE that this cannot happen for rules whose head is a -locally-defined function, because we accurately track dependencies -through RULES. It only happens for rules whose head is an imported -function (B.f in the example above). - -Solution: - - When simplifying, bring all top level identifiers into - scope at the start, ignoring the Rec/NonRec structure, so - that when 'h' pops up in f's rhs, we find it in the in-scope set - (as the simplifier generally expects). This happens in simplTopBinds. - - - In the occurrence analyser, if there are any out-of-scope - occurrences that pop out of the top, which will happen after - firing the rule: f = \x -> h x - h = \y -> 3 - then just glom all the bindings into a single Rec, so that - the *next* iteration of the occurrence analyser will sort - them all out. This part happens in occurAnalysePgm. - -This is a legitimate situation where the need for glomming doesn't -point to any problems. However, when GHC is compiled with -DDEBUG, we -produce a warning addressed to the GHC developers just in case we -require glomming due to an out-of-order reference that is caused by -some earlier transformation stage misbehaving. --} - -{- -************************************************************************ -* * - Bindings -* * -************************************************************************ - -Note [Recursive bindings: the grand plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Loop breaking is surprisingly subtle. First read the section 4 of -"Secrets of the GHC inliner". This describes our basic plan. We -avoid infinite inlinings by choosing loop breakers, and ensuring that -a loop breaker cuts each loop. - -See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which -deals with a closely related source of infinite loops. - -When we come across a binding group - Rec { x1 = r1; ...; xn = rn } -we treat it like this (occAnalRecBind): - -1. Note [Forming Rec groups] - Occurrence-analyse each right hand side, and build a - "Details" for each binding to capture the results. - Wrap the details in a LetrecNode, ready for SCC analysis. - All this is done by makeNode. - - The edges of this graph are the "scope edges". - -2. Do SCC-analysis on these Nodes: - - Each CyclicSCC will become a new Rec - - Each AcyclicSCC will become a new NonRec - - The key property is that every free variable of a binding is - accounted for by the scope edges, so that when we are done - everything is still in scope. - -3. For each AcyclicSCC, just make a NonRec binding. - -4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we - identify suitable loop-breakers to ensure that inlining terminates. - This is done by occAnalRec. - - To do so, form the loop-breaker graph, do SCC analysis. For each - CyclicSCC we choose a loop breaker, delete all edges to that node, - re-analyse the SCC, and iterate. See Note [Choosing loop breakers] - for the details - - -Note [Dead code] -~~~~~~~~~~~~~~~~ -Dropping dead code for a cyclic Strongly Connected Component is done -in a very simple way: - - the entire SCC is dropped if none of its binders are mentioned - in the body; otherwise the whole thing is kept. - -The key observation is that dead code elimination happens after -dependency analysis: so 'occAnalBind' processes SCCs instead of the -original term's binding groups. - -Thus 'occAnalBind' does indeed drop 'f' in an example like - - letrec f = ...g... - g = ...(...g...)... - in - ...g... - -when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in -'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes -'AcyclicSCC f', where 'body_usage' won't contain 'f'. - -Note [Forming Rec groups] -~~~~~~~~~~~~~~~~~~~~~~~~~ -The key point about the "Forming Rec groups" step is that it /preserves -scoping/. If 'x' is mentioned, it had better be bound somewhere. So if -we start with - Rec { f = ...h... - ; g = ...f... - ; h = ...f... } -we can split into SCCs - Rec { f = ...h... - ; h = ..f... } - NonRec { g = ...f... } - -We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g -uses f", no matter how indirectly. We do a SCC analysis with an edge -f -> g if "f mentions g". That is, g is free in: - a) the rhs 'ef' - b) or the RHS of a rule for f, whether active or inactive - Note [Rules are extra RHSs] - c) or the LHS or a rule for f, whether active or inactive - Note [Rule dependency info] - d) the RHS of an /active/ local IMP-RULE - Note [IMP-RULES: local rules for imported functions] - -(b) and (c) apply regardless of the activation of the RULE, because even if -the rule is inactive its free variables must be bound. But (d) doesn't need -to worry about this because IMP-RULES are always notionally at the bottom -of the file. - - * Note [Rules are extra RHSs] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" - keeps the specialised "children" alive. If the parent dies - (because it isn't referenced any more), then the children will die - too (unless they are already referenced directly). - - So in Example [eftInt], eftInt and eftIntFB will be put in the - same Rec, even though their 'main' RHSs are both non-recursive. - - We must also include inactive rules, so that their free vars - remain in scope. - - * Note [Rule dependency info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a RuleInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. - Why both? Consider - x = y - RULE f x = v+4 - Then if we substitute y for x, we'd better do so in the - rule's LHS too, so we'd better ensure the RULE appears to mention 'x' - as well as 'v' - - * Note [Rules are visible in their own rec group] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We want the rules for 'f' to be visible in f's right-hand side. - And we'd like them to be visible in other functions in f's Rec - group. E.g. in Note [Specialisation rules] we want f' rule - to be visible in both f's RHS, and fs's RHS. - - This means that we must simplify the RULEs first, before looking - at any of the definitions. This is done by Simplify.simplRecBind, - when it calls addLetIdInfo. - -Note [TailUsageDetails when forming Rec groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is -computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`. -That is because the binding might still become a *non-recursive join point* in -the AcyclicSCC case of dependency analysis! -Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get -a regular, adjusted UsageDetails. -See Note [Join points and unfoldings/rules] for more details on the contract. - -Note [Stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~ -None of the above stuff about RULES applies to a stable unfolding -stored in a CoreUnfolding. The unfolding, if any, is simplified -at the same time as the regular RHS of the function (ie *not* like -Note [Rules are visible in their own rec group]), so it should be -treated *exactly* like an extra RHS. - -Or, rather, when computing loop-breaker edges, - * If f has an INLINE pragma, and it is active, we treat the - INLINE rhs as f's rhs - * If it's inactive, we treat f as having no rhs - * If it has no INLINE pragma, we look at f's actual rhs - - -There is a danger that we'll be sub-optimal if we see this - f = ...f... - [INLINE f = ..no f...] -where f is recursive, but the INLINE is not. This can just about -happen with a sufficiently odd set of rules; eg - - foo :: Int -> Int - {-# INLINE [1] foo #-} - foo x = x+1 - - bar :: Int -> Int - {-# INLINE [1] bar #-} - bar x = foo x + 1 - - {-# RULES "foo" [~1] forall x. foo x = bar x #-} - -Here the RULE makes bar recursive; but it's INLINE pragma remains -non-recursive. It's tempting to then say that 'bar' should not be -a loop breaker, but an attempt to do so goes wrong in two ways: - a) We may get - $df = ...$cfoo... - $cfoo = ...$df.... - [INLINE $cfoo = ...no-$df...] - But we want $cfoo to depend on $df explicitly so that we - put the bindings in the right order to inline $df in $cfoo - and perhaps break the loop altogether. (Maybe this - b) - - -Example [eftInt] -~~~~~~~~~~~~~~~ -Example (from GHC.Enum): - - eftInt :: Int# -> Int# -> [Int] - eftInt x y = ...(non-recursive)... - - {-# INLINE [0] eftIntFB #-} - eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r - eftIntFB c n x y = ...(non-recursive)... - - {-# RULES - "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) - "eftIntList" [1] eftIntFB (:) [] = eftInt - #-} - -Note [Specialisation rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this group, which is typical of what SpecConstr builds: - - fs a = ....f (C a).... - f x = ....f (C a).... - {-# RULE f (C a) = fs a #-} - -So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). - -But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify - - fs is inlined (say it's small) - - now there's another opportunity to apply the RULE - -This showed up when compiling Control.Concurrent.Chan.getChanContents. -Hence the transitive rule_fv_env stuff described in -Note [Rules and loop breakers]. - ------------------------------------------------------------- -Note [Finding join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's the occurrence analyser's job to find bindings that we can turn into join -points, but it doesn't perform that transformation right away. Rather, it marks -the eligible bindings as part of their occurrence data, leaving it to the -simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. -The simplifier then eta-expands the RHS if needed and then updates the -occurrence sites. Dividing the work this way means that the occurrence analyser -still only takes one pass, yet one can always tell the difference between a -function call and a jump by looking at the occurrence (because the same pass -changes the 'IdDetails' and propagates the binders to their occurrence sites). - -To track potential join points, we use the 'occ_tail' field of OccInfo. A value -of `AlwaysTailCalled n` indicates that every occurrence of the variable is a -tail call with `n` arguments (counting both value and type arguments). Otherwise -'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the -rest of 'OccInfo' until it goes on the binder. - -Note [Join arity prediction based on joinRhsArity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, the join arity from tail occurrences of a join point (O) may be -higher or lower than the manifest join arity of the join body (M). E.g., - - -- M > O: - let f x y = x + y -- M = 2 - in if b then f 1 else f 2 -- O = 1 - ==> { Contify for join arity 1 } - join f x = \y -> x + y - in if b then jump f 1 else jump f 2 - - -- M < O - let f = id -- M = 0 - in if ... then f 12 else f 13 -- O = 1 - ==> { Contify for join arity 1, eta-expand f } - join f x = id x - in if b then jump f 12 else jump f 13 - -But for *recursive* let, it is crucial that both arities match up, consider - - letrec f x y = if ... then f x else True - in f 42 - -Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump -would not happen in a tail context! Contification is invalid here. -So indeed it is crucial to demand that M=O. - -(Side note: Actually, we could be more specific: Let O1 be the join arity of -occurrences from the letrec RHS and O2 the join arity from the let body. Then -we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later. -M=O is the specific case where we don't want to eta-expand. Neither the join -points paper nor GHC does this at the moment.) - -We can capitalise on this observation and conclude that *if* f could become a -joinrec (without eta-expansion), it will have join arity M. -Now, M is just the result of 'joinRhsArity', a rather simple, local analysis. -It is also the join arity inside the 'TailUsageDetails' returned by -'occAnalLamTail', so we can predict join arity without doing any fixed-point -iteration or really doing any deep traversal of let body or RHS at all. -We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'. - -All this is quite apparent if you look at the contification transformation in -Fig. 5 of "Compiling without Continuations" (which does not account for -eta-expansion at all, mind you). The letrec case looks like this - - letrec f = /\as.\xs. L[us] in L'[es] - ... and a bunch of conditions establishing that f only occurs - in app heads of join arity (len as + len xs) inside us and es ... - -The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However, -for non-recursive functions, this is the definition of contification from the -paper: - - let f = /\as.\xs.u in L[es] ... conditions ... - -Note that u could be a lambda itself, as we have seen. No relationship between M -and O to exploit here. - -Note [Join points and unfoldings/rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let j2 y = blah - let j x = j2 (x+x) - {-# INLINE [2] j #-} - in case e of { A -> j 1; B -> ...; C -> j 2 } - -Before j is inlined, we'll have occurrences of j2 in -both j's RHS and in its stable unfolding. We want to discover -j2 as a join point. So 'occAnalUnfolding' returns an unadjusted -'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the -unfolding to the actual join arity using the same 'adjustTailArity' as for -the RHS, see Note [Adjusting right-hand sides]. - -Same with rules. Suppose we have: - - let j :: Int -> Int - j y = 2 * y - let k :: Int -> Int -> Int - {-# RULES "SPEC k 0" k 0 y = j y #-} - k x y = x + 2 * y - in case e of { A -> k 1 2; B -> k 3 5; C -> blah } - -We identify k as a join point, and we want j to be a join point too. -Without the RULE it would be, and we don't want the RULE to mess it -up. So provided the join-point arity of k matches the args of the -rule we can allow the tail-call info from the RHS of the rule to -propagate. - -* Note that the join arity of the RHS and that of the unfolding or RULE might - mismatch: - - let j x y = j2 (x+x) - {-# INLINE[2] j = \x. g #-} - {-# RULE forall x y z. j x y z = h 17 #-} - in j 1 2 - - So it is crucial that we adjust each TailUsageDetails individually - with the actual join arity 2 here before we combine with `andUDs`. - Here, that means losing tail call info on `g` and `h`. - -* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for - RHS, unfolding and RULE combined. Clearly, if they don't agree on their join - arity, we have to do some adjusting. We choose to adjust to the join arity - of the RHS, because that is likely the join arity that the join point will - have; see Note [Join arity prediction based on joinRhsArity]. - - If the guess is correct, then tail calls in the RHS are preserved; a necessary - condition for the whole binding becoming a joinrec. - The guess can only be incorrect in the 'AcyclicSCC' case when the binding - becomes a non-recursive join point with a different join arity. But then the - eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will - be with a different join arity and destroy unsound tail call info with - 'markNonTail'. - -* Wrinkle for RULES. Suppose the example was a bit different: - let j :: Int -> Int - j y = 2 * y - k :: Int -> Int -> Int - {-# RULES "SPEC k 0" k 0 = j #-} - k x y = x + 2 * y - in ... - If we eta-expanded the rule all would be well, but as it stands the - one arg of the rule don't match the join-point arity of 2. - - Conceivably we could notice that a potential join point would have - an "undersaturated" rule and account for it. This would mean we - could make something that's been specialised a join point, for - instance. But local bindings are rarely specialised, and being - overly cautious about rules only costs us anything when, for some `j`: - - * Before specialisation, `j` has non-tail calls, so it can't be a join point. - * During specialisation, `j` gets specialised and thus acquires rules. - * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), - and so now `j` *could* become a join point. - - This appears to be very rare in practice. TODO Perhaps we should gather - statistics to be sure. - ------------------------------------------------------------- -Note [Adjusting right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's a bit of a dance we need to do after analysing a lambda expression or -a right-hand side. In particular, we need to - - a) call 'markAllNonTail' *unless* the binding is for a join point, and - the TailUsageDetails from the RHS has the right join arity; e.g. - join j x y = case ... of - A -> j2 p - B -> j2 q - in j a b - Here we want the tail calls to j2 to be tail calls of the whole expression - b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot - lambda, or a non-recursive join point - -Some examples, with how the free occurrences in e (assumed not to be a value -lambda) get marked: - - inside lam non-tail-called - ------------------------------------------------------------ - let x = e No Yes - let f = \x -> e Yes Yes - let f = \x{OneShot} -> e No Yes - \x -> e Yes Yes - join j x = e No No - joinrec j x = e Yes No - -There are a few other caveats; most importantly, if we're marking a binding as -'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so -that the effect cascades properly. Consequently, at the time the RHS is -analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must -return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage' -once join-point-hood has been decided and eventual one-shot annotations have -been added through 'markNonRecJoinOneShots'. - -It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed -perform a similar sequence of steps. Thus, here is an interleaving of events -of both functions, serving as a specification: - - 1. Call 'occAnalLamTail' to find usage information for the RHS. - Recursive case: 'makeNode' - Non-recursive case: 'occAnalNonRecBind' - 2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`. - Same whether recursive or not.) - 3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make - the binding a join point. - Cyclic Recursive case: 'mkLoopBreakerNodes' - Acyclic Recursive case: `occAnalRec AcyclicSCC{}` - Non-recursive case: 'occAnalNonRecBind' - 4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g., - FloatOut sees one-shot annotations on lambdas - Acyclic Recursive case: `occAnalRec AcyclicSCC{}` calls 'adjustNonRecRhs' - Non-recursive case: 'occAnalNonRecBind' calls 'adjustNonRecRhs' - 5. Call 'adjustTailUsage' accordingly. - Cyclic Recursive case: 'tagRecBinders' - Acyclic Recursive case: 'adjustNonRecRhs' - Non-recursive case: 'adjustNonRecRhs' --} - -data WithUsageDetails a = WithUsageDetails !UsageDetails !a - -data WithTailUsageDetails a = WithTailUsageDetails !TailUsageDetails !a - ------------------------------------------------------------------- --- occAnalBind ------------------------------------------------------------------- - -occAnalBind :: OccEnv -- The incoming OccEnv - -> TopLevelFlag - -> ImpRuleEdges - -> CoreBind - -> UsageDetails -- Usage details of scope - -> WithUsageDetails [CoreBind] -- Of the whole let(rec) - -occAnalBind !env lvl top_env (NonRec binder rhs) body_usage - = occAnalNonRecBind env lvl top_env binder rhs body_usage -occAnalBind env lvl top_env (Rec pairs) body_usage - = occAnalRecBind env lvl top_env pairs body_usage - ------------------ -occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr - -> UsageDetails -> WithUsageDetails [CoreBind] -occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage - | isTyVar bndr -- A type let; we don't gather usage info - = WithUsageDetails body_usage [NonRec bndr rhs] - - | not (bndr `usedIn` body_usage) - = WithUsageDetails body_usage [] -- See Note [Dead code] - - | otherwise -- It's mentioned in the body - = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr final_rhs] - where - WithUsageDetails body_usage' tagged_bndr = tagNonRecBinder lvl body_usage bndr - - -- Get the join info from the *new* decision - -- See Note [Join points and unfoldings/rules] - -- => join arity O of Note [Join arity prediction based on joinRhsArity] - mb_join_arity = willBeJoinId_maybe tagged_bndr - is_join_point = isJust mb_join_arity - - --------- Right hand side --------- - env1 | is_join_point = env -- See Note [Join point RHSs] - | certainly_inline = env -- See Note [Cascading inlines] - | otherwise = rhsCtxt env - - -- See Note [Sources of one-shot information] - rhs_env = env1 { occ_one_shots = argOneShots dmd } - -- See Note [Join arity prediction based on joinRhsArity] - -- Match join arity O from mb_join_arity with manifest join arity M as - -- returned by of occAnalLamTail. It's totally OK for them to mismatch; - -- hence adjust the UDs from the RHS - WithUsageDetails adj_rhs_uds final_rhs - = adjustNonRecRhs mb_join_arity $ occAnalLamTail rhs_env rhs - rhs_usage = adj_rhs_uds `andUDs` adj_unf_uds `andUDs` adj_rule_uds - final_bndr = tagged_bndr `setIdSpecialisation` mkRuleInfo rules' - `setIdUnfolding` unf2 - - --------- Unfolding --------- - -- See Note [Join points and unfoldings/rules] - unf | isId bndr = idUnfolding bndr - | otherwise = NoUnfolding - WithTailUsageDetails unf_uds unf1 = occAnalUnfolding rhs_env unf - unf2 = markNonRecUnfoldingOneShots mb_join_arity unf1 - adj_unf_uds = adjustTailArity mb_join_arity unf_uds - - --------- Rules --------- - -- See Note [Rules are extra RHSs] and Note [Rule dependency info] - -- and Note [Join points and unfoldings/rules] - rules_w_uds = occAnalRules rhs_env bndr - rules' = map fstOf3 rules_w_uds - imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr) - -- imp_rule_uds: consider - -- h = ... - -- g = ... - -- RULE map g = h - -- Then we want to ensure that h is in scope everywhere - -- that g is (since the RULE might turn g into h), so - -- we make g mention h. - - adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds - add_rule_uds (_, l, r) uds - = l `andUDs` adjustTailArity mb_join_arity r `andUDs` uds - - ---------- - occ = idOccInfo tagged_bndr - certainly_inline -- See Note [Cascading inlines] - = case occ of - OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 } - -> active && not_stable - _ -> False - - dmd = idDemandInfo bndr - active = isAlwaysActive (idInlineActivation bndr) - not_stable = not (isStableUnfolding (idUnfolding bndr)) - ------------------ -occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] - -> UsageDetails -> WithUsageDetails [CoreBind] --- For a recursive group, we --- * occ-analyse all the RHSs --- * compute strongly-connected components --- * feed those components to occAnalRec --- See Note [Recursive bindings: the grand plan] -occAnalRecBind !env lvl imp_rule_edges pairs body_usage - = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs - where - sccs :: [SCC NodeDetails] - sccs = {-# SCC "occAnalBind.scc" #-} - stronglyConnCompFromEdgedVerticesUniq nodes - - nodes :: [LetrecNode] - nodes = {-# SCC "occAnalBind.assoc" #-} - map (makeNode rhs_env imp_rule_edges bndr_set) pairs - - bndrs = map fst pairs - bndr_set = mkVarSet bndrs - rhs_env = env `addInScope` bndrs - -adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr --- ^ This function concentrates shared logic between occAnalNonRecBind and the --- AcyclicSCC case of occAnalRec. --- * It applies 'markNonRecJoinOneShots' to the RHS --- * and returns the adjusted rhs UsageDetails combined with the body usage -adjustNonRecRhs mb_join_arity (WithTailUsageDetails rhs_tuds rhs) - = WithUsageDetails rhs_uds' rhs' - where - --------- Marking (non-rec) join binders one-shot --------- - !rhs' | Just ja <- mb_join_arity = markNonRecJoinOneShots ja rhs - | otherwise = rhs - --------- Adjusting right-hand side usage --------- - rhs_uds' = adjustTailUsage mb_join_arity rhs' rhs_tuds - -bindersOfSCC :: SCC NodeDetails -> [Var] -bindersOfSCC (AcyclicSCC nd) = [nd_bndr nd] -bindersOfSCC (CyclicSCC ds) = map nd_bndr ds - ------------------------------ -occAnalRec :: OccEnv -> TopLevelFlag - -> SCC NodeDetails - -> WithUsageDetails [CoreBind] - -> WithUsageDetails [CoreBind] - --- Check for Note [Dead code] --- NB: Only look at body_uds, ignoring uses in the SCC -occAnalRec !_ _ scc (WithUsageDetails body_uds binds) - | not (any (`usedIn` body_uds) (bindersOfSCC scc)) - = WithUsageDetails body_uds binds - --- The NonRec case is just like a Let (NonRec ...) above -occAnalRec !_ lvl - (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) - (WithUsageDetails body_uds binds) - = WithUsageDetails (body_uds' `andUDs` rhs_uds') (NonRec bndr' rhs' : binds) - where - WithUsageDetails body_uds' tagged_bndr = tagNonRecBinder lvl body_uds bndr - mb_join_arity = willBeJoinId_maybe tagged_bndr - WithUsageDetails rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds - !unf' = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr) - !bndr' = tagged_bndr `setIdUnfolding` unf' - --- The Rec case is the interesting one --- See Note [Recursive bindings: the grand plan] --- See Note [Loop breaking] -occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds) - = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes) - WithUsageDetails final_uds (Rec pairs : binds) - where - all_simple = all nd_simple details_s - - ------------------------------ - -- Make the nodes for the loop-breaker analysis - -- See Note [Choosing loop breakers] for loop_breaker_nodes - final_uds :: UsageDetails - loop_breaker_nodes :: [LoopBreakerNode] - (WithUsageDetails final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s - - ------------------------------ - weak_fvs :: VarSet - weak_fvs = mapUnionVarSet nd_weak_fvs details_s - - --------------------------- - -- Now reconstruct the cycle - pairs :: [(Id,CoreExpr)] - pairs | all_simple = reOrderNodes 0 weak_fvs loop_breaker_nodes [] - | otherwise = loopBreakNodes 0 weak_fvs loop_breaker_nodes [] - -- In the common case when all are "simple" (no rules at all) - -- the loop_breaker_nodes will include all the scope edges - -- so a SCC computation would yield a single CyclicSCC result; - -- and reOrderNodes deals with exactly that case. - -- Saves a SCC analysis in a common case - - -{- ********************************************************************* -* * - Loop breaking -* * -********************************************************************* -} - -{- Note [Choosing loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does -loop-breaking on each CyclicSCC of the original program: - -* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC - -* loopBreakNodes: Do SCC analysis on it - -* reOrderNodes: For each CyclicSCC, pick a loop breaker - * Delete edges to that loop breaker - * Do another SCC analysis on that reduced SCC - * Repeat - -To form the loop-breaker graph, we construct a new set of Nodes, the -"loop-breaker nodes", with the same details but different edges, the -"loop-breaker edges". The loop-breaker nodes have both more and fewer -dependencies than the scope edges: - - More edges: - If f calls g, and g has an active rule that mentions h then - we add an edge from f -> h. See Note [Rules and loop breakers]. - - Fewer edges: we only include dependencies - * only on /active/ rules, - * on rule /RHSs/ (not LHSs) - -The scope edges, by contrast, must be much more inclusive. - -The nd_simple flag tracks the common case when a binding has no RULES -at all, in which case the loop-breaker edges will be identical to the -scope edges. - -Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is -chosen as a loop breaker, because their RHSs don't mention each other. -And indeed both can be inlined safely. - -Note [inl_fvs] -~~~~~~~~~~~~~~ -Note that the loop-breaker graph includes edges for occurrences in -/both/ the RHS /and/ the stable unfolding. Consider this, which actually -occurred when compiling BooleanFormula.hs in GHC: - - Rec { lvl1 = go - ; lvl2[StableUnf = go] = lvl1 - ; go = ...go...lvl2... } - -From the point of view of infinite inlining, we need only these edges: - lvl1 :-> go - lvl2 :-> go -- The RHS lvl1 will never be used for inlining - go :-> go, lvl2 - -But the danger is that, lacking any edge to lvl1, we'll put it at the -end thus - Rec { lvl2[ StableUnf = go] = lvl1 - ; go[LoopBreaker] = ...go...lvl2... } - ; lvl1[Occ=Once] = go } - -And now the Simplifer will try to use PreInlineUnconditionally on lvl1 -(which occurs just once), but because it is last we won't actually -substitute in lvl2. Sigh. - -To avoid this possibility, we include edges from lvl2 to /both/ its -stable unfolding /and/ its RHS. Hence the defn of inl_fvs in -makeNode. Maybe we could be more clever, but it's very much a corner -case. - -Note [Weak loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a last nasty wrinkle. Suppose we have - - Rec { f = f_rhs - RULE f [] = g - - h = h_rhs - g = h - ...more... } - -Remember that we simplify the RULES before any RHS (see Note -[Rules are visible in their own rec group] above). - -So we must *not* postInlineUnconditionally 'g', even though -its RHS turns out to be trivial. (I'm assuming that 'g' is -not chosen as a loop breaker.) Why not? Because then we -drop the binding for 'g', which leaves it out of scope in the -RULE! - -Here's a somewhat different example of the same thing - Rec { q = r - ; r = ...p... - ; p = p_rhs - RULE p [] = q } -Here the RULE is "below" q, but we *still* can't postInlineUnconditionally -q, because the RULE for p is active throughout. So the RHS of r -might rewrite to r = ...q... -So q must remain in scope in the output program! - -We "solve" this by: - - Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True) - iff q is a mentioned in the RHS of any RULE (active on not) - in the Rec group - -Note the "active or not" comment; even if a RULE is inactive, we -want its RHS free vars to stay alive (#20820)! - -A normal "strong" loop breaker has IAmLoopBreaker False. So: - - Inline postInlineUnconditionally -strong IAmLoopBreaker False no no -weak IAmLoopBreaker True yes no - other yes yes - -The **sole** reason for this kind of loop breaker is so that -postInlineUnconditionally does not fire. Ugh. - -Annoyingly, since we simplify the rules *first* we'll never inline -q into p's RULE. That trivial binding for q will hang around until -we discard the rule. Yuk. But it's rare. - -Note [Rules and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we form the loop-breaker graph (Step 4 in Note [Recursive -bindings: the grand plan]), we must be careful about RULEs. - -For a start, we want a loop breaker to cut every cycle, so inactive -rules play no part; we need only consider /active/ rules. -See Note [Finding rule RHS free vars] - -The second point is more subtle. A RULE is like an equation for -'f' that is *always* inlined if it is applicable. We do *not* disable -rules for loop-breakers. It's up to whoever makes the rules to make -sure that the rules themselves always terminate. See Note [Rules for -recursive functions] in GHC.Core.Opt.Simplify - -Hence, if - f's RHS (or its stable unfolding if it has one) mentions g, and - g has a RULE that mentions h, and - h has a RULE that mentions f - -then we *must* choose f to be a loop breaker. Example: see Note -[Specialisation rules]. So our plan is this: - - Take the free variables of f's RHS, and augment it with all the - variables reachable by a transitive sequence RULES from those - starting points. - -That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes. -Wrinkles: - -* We only consider /active/ rules. See Note [Finding rule RHS free vars] - -* We need only consider free vars that are also binders in this Rec - group. See also Note [Finding rule RHS free vars] - -* We only consider variables free in the *RHS* of the rule, in - contrast to the way we build the Rec group in the first place (Note - [Rule dependency info]) - -* Why "transitive sequence of rules"? Because active rules apply - unconditionally, without checking loop-breaker-ness. - See Note [Loop breaker dependencies]. - -Note [Finding rule RHS free vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this real example from Data Parallel Haskell - tagZero :: Array Int -> Array Tag - {-# INLINE [1] tagZeroes #-} - tagZero xs = pmap (\x -> fromBool (x==0)) xs - - {-# RULES "tagZero" [~1] forall xs n. - pmap fromBool = tagZero xs #-} -So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. -However, tagZero can only be inlined in phase 1 and later, while -the RULE is only active *before* phase 1. So there's no problem. - -To make this work, we look for the RHS free vars only for -*active* rules. That's the reason for the occ_rule_act field -of the OccEnv. - -Note [loopBreakNodes] -~~~~~~~~~~~~~~~~~~~~~ -loopBreakNodes is applied to the list of nodes for a cyclic strongly -connected component (there's guaranteed to be a cycle). It returns -the same nodes, but - a) in a better order, - b) with some of the Ids having a IAmALoopBreaker pragma - -The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means -that the simplifier can guarantee not to loop provided it never records an inlining -for these no-inline guys. - -Furthermore, the order of the binds is such that if we neglect dependencies -on the no-inline Ids then the binds are topologically sorted. This means -that the simplifier will generally do a good job if it works from top bottom, -recording inlinings for any Ids which aren't marked as "no-inline" as it goes. --} - -type Binding = (Id,CoreExpr) - --- See Note [loopBreakNodes] -loopBreakNodes :: Int - -> VarSet -- Binders whose dependencies may be "missing" - -- See Note [Weak loop breakers] - -> [LoopBreakerNode] - -> [Binding] -- Append these to the end - -> [Binding] - --- Return the bindings sorted into a plausible order, and marked with loop breakers. --- See Note [loopBreakNodes] -loopBreakNodes depth weak_fvs nodes binds - = -- pprTrace "loopBreakNodes" (ppr nodes) $ - go (stronglyConnCompFromEdgedVerticesUniqR nodes) - where - go [] = binds - go (scc:sccs) = loop_break_scc scc (go sccs) - - loop_break_scc scc binds - = case scc of - AcyclicSCC node -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds - CyclicSCC nodes -> reOrderNodes depth weak_fvs nodes binds - ----------------------------------- -reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding] - -- Choose a loop breaker, mark it no-inline, - -- and call loopBreakNodes on the rest -reOrderNodes _ _ [] _ = panic "reOrderNodes" -reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds -reOrderNodes depth weak_fvs (node : nodes) binds - = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen - -- , text "chosen" <+> ppr chosen_nodes ]) $ - loopBreakNodes new_depth weak_fvs unchosen $ - (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds) - where - (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb - (snd_score (node_payload node)) - [node] [] nodes - - approximate_lb = depth >= 2 - new_depth | approximate_lb = 0 - | otherwise = depth+1 - -- After two iterations (d=0, d=1) give up - -- and approximate, returning to d=0 - -nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding -nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs}) - = (set_id_occ bndr, rhs) - -mk_loop_breaker :: Id -> Id -mk_loop_breaker bndr - = bndr `setIdOccInfo` occ' - where - occ' = strongLoopBreaker { occ_tail = tail_info } - tail_info = tailCallInfo (idOccInfo bndr) - -mk_non_loop_breaker :: VarSet -> Id -> Id --- See Note [Weak loop breakers] -mk_non_loop_breaker weak_fvs bndr - | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ' - | otherwise = bndr - where - occ' = weakLoopBreaker { occ_tail = tail_info } - tail_info = tailCallInfo (idOccInfo bndr) - ----------------------------------- -chooseLoopBreaker :: Bool -- True <=> Too many iterations, - -- so approximate - -> NodeScore -- Best score so far - -> [LoopBreakerNode] -- Nodes with this score - -> [LoopBreakerNode] -- Nodes with higher scores - -> [LoopBreakerNode] -- Unprocessed nodes - -> ([LoopBreakerNode], [LoopBreakerNode]) - -- This loop looks for the bind with the lowest score - -- to pick as the loop breaker. The rest accumulate in -chooseLoopBreaker _ _ loop_nodes acc [] - = (loop_nodes, acc) -- Done - - -- If approximate_loop_breaker is True, we pick *all* - -- nodes with lowest score, else just one - -- See Note [Complexity of loop breaking] -chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) - | approx_lb - , rank sc == rank loop_sc - = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes - - | sc `betterLB` loop_sc -- Better score so pick this new one - = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes - - | otherwise -- Worse score so don't pick it - = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes - where - sc = snd_score (node_payload node) - -{- -Note [Complexity of loop breaking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The loop-breaking algorithm knocks out one binder at a time, and -performs a new SCC analysis on the remaining binders. That can -behave very badly in tightly-coupled groups of bindings; in the -worst case it can be (N**2)*log N, because it does a full SCC -on N, then N-1, then N-2 and so on. - -To avoid this, we switch plans after 2 (or whatever) attempts: - Plan A: pick one binder with the lowest score, make it - a loop breaker, and try again - Plan B: pick *all* binders with the lowest score, make them - all loop breakers, and try again -Since there are only a small finite number of scores, this will -terminate in a constant number of iterations, rather than O(N) -iterations. - -You might thing that it's very unlikely, but RULES make it much -more likely. Here's a real example from #1969: - Rec { $dm = \d.\x. op d - {-# RULES forall d. $dm Int d = $s$dm1 - forall d. $dm Bool d = $s$dm2 #-} - - dInt = MkD .... opInt ... - dInt = MkD .... opBool ... - opInt = $dm dInt - opBool = $dm dBool - - $s$dm1 = \x. op dInt - $s$dm2 = \x. op dBool } -The RULES stuff means that we can't choose $dm as a loop breaker -(Note [Choosing loop breakers]), so we must choose at least (say) -opInt *and* opBool, and so on. The number of loop breakers is -linear in the number of instance declarations. - -Note [Loop breakers and INLINE/INLINABLE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Avoid choosing a function with an INLINE pramga as the loop breaker! -If such a function is mutually-recursive with a non-INLINE thing, -then the latter should be the loop-breaker. - -It's vital to distinguish between INLINE and INLINABLE (the -Bool returned by hasStableCoreUnfolding_maybe). If we start with - Rec { {-# INLINABLE f #-} - f x = ...f... } -and then worker/wrapper it through strictness analysis, we'll get - Rec { {-# INLINABLE $wf #-} - $wf p q = let x = (p,q) in ...f... - - {-# INLINE f #-} - f x = case x of (p,q) -> $wf p q } - -Now it is vital that we choose $wf as the loop breaker, so we can -inline 'f' in '$wf'. - -Note [DFuns should not be loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's particularly bad to make a DFun into a loop breaker. See -Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance - -We give DFuns a higher score than ordinary CONLIKE things because -if there's a choice we want the DFun to be the non-loop breaker. Eg - -rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) - - $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) - {-# DFUN #-} - $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) - } - -Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it -if we can't unravel the DFun first. - -Note [Constructor applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really really important to inline dictionaries. Real -example (the Enum Ordering instance from GHC.Base): - - rec f = \ x -> case d of (p,q,r) -> p x - g = \ x -> case d of (p,q,r) -> q x - d = (v, f, g) - -Here, f and g occur just once; but we can't inline them into d. -On the other hand we *could* simplify those case expressions if -we didn't stupidly choose d as the loop breaker. -But we won't because constructor args are marked "Many". -Inlining dictionaries is really essential to unravelling -the loops in static numeric dictionaries, see GHC.Float. - -Note [Closure conversion] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. -The immediate motivation came from the result of a closure-conversion transformation -which generated code like this: - - data Clo a b = forall c. Clo (c -> a -> b) c - - ($:) :: Clo a b -> a -> b - Clo f env $: x = f env x - - rec { plus = Clo plus1 () - - ; plus1 _ n = Clo plus2 n - - ; plus2 Zero n = n - ; plus2 (Succ m) n = Succ (plus $: m $: n) } - -If we inline 'plus' and 'plus1', everything unravels nicely. But if -we choose 'plus1' as the loop breaker (which is entirely possible -otherwise), the loop does not unravel nicely. - - -@occAnalUnfolding@ deals with the question of bindings where the Id is marked -by an INLINE pragma. For these we record that anything which occurs -in its RHS occurs many times. This pessimistically assumes that this -inlined binder also occurs many times in its scope, but if it doesn't -we'll catch it next time round. At worst this costs an extra simplifier pass. -ToDo: try using the occurrence info for the inline'd binder. - -[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. -[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. - - -************************************************************************ -* * - Making nodes -* * -************************************************************************ --} - --- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'. --- The Unique key is gotten from the Id. -type LetrecNode = Node Unique NodeDetails - --- | Node details as consumed by 'occAnalRec'. -data NodeDetails - = ND { nd_bndr :: Id -- Binder - - , nd_rhs :: !(WithTailUsageDetails CoreExpr) - -- ^ RHS, already occ-analysed - -- With TailUsageDetails from RHS, and RULES, and stable unfoldings, - -- ignoring phase (ie assuming all are active). - -- NB: Unadjusted TailUsageDetails, as if this Node becomes a - -- non-recursive join point! - -- See Note [TailUsageDetails when forming Rec groups] - - , nd_inl :: IdSet -- Free variables of the stable unfolding and the RHS - -- but excluding any RULES - -- This is the IdSet that may be used if the Id is inlined - - , nd_simple :: Bool -- True iff this binding has no local RULES - -- If all nodes are simple we don't need a loop-breaker - -- dep-anal before reconstructing. - - , nd_weak_fvs :: IdSet -- Variables bound in this Rec group that are free - -- in the RHS of any rule (active or not) for this bndr - -- See Note [Weak loop breakers] - - , nd_active_rule_fvs :: IdSet -- Variables bound in this Rec group that are free - -- in the RHS of an active rule for this bndr - -- See Note [Rules and loop breakers] - } - -instance Outputable NodeDetails where - ppr nd = text "ND" <> braces - (sep [ text "bndr =" <+> ppr (nd_bndr nd) - , text "uds =" <+> ppr uds - , text "inl =" <+> ppr (nd_inl nd) - , text "simple =" <+> ppr (nd_simple nd) - , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd) - ]) - where WithTailUsageDetails uds _ = nd_rhs nd - --- | Digraph with simplified and completely occurrence analysed --- 'SimpleNodeDetails', retaining just the info we need for breaking loops. -type LoopBreakerNode = Node Unique SimpleNodeDetails - --- | Condensed variant of 'NodeDetails' needed during loop breaking. -data SimpleNodeDetails - = SND { snd_bndr :: IdWithOccInfo -- OccInfo accurate - , snd_rhs :: CoreExpr -- properly occur-analysed - , snd_score :: NodeScore - } - -instance Outputable SimpleNodeDetails where - ppr nd = text "SND" <> braces - (sep [ text "bndr =" <+> ppr (snd_bndr nd) - , text "score =" <+> ppr (snd_score nd) - ]) - --- The NodeScore is compared lexicographically; --- e.g. lower rank wins regardless of size -type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker - , Int -- Size of rhs: higher => more likely to be picked as LB - -- Maxes out at maxExprSize; we just use it to prioritise - -- small functions - , Bool ) -- Was it a loop breaker before? - -- True => more likely to be picked - -- Note [Loop breakers, node scoring, and stability] - -rank :: NodeScore -> Int -rank (r, _, _) = r - -makeNode :: OccEnv -> ImpRuleEdges -> VarSet - -> (Var, CoreExpr) -> LetrecNode --- See Note [Recursive bindings: the grand plan] -makeNode !env imp_rule_edges bndr_set (bndr, rhs) - = DigraphNode { node_payload = details - , node_key = varUnique bndr - , node_dependencies = nonDetKeysUniqSet scope_fvs } - -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR - -- is still deterministic with edges in nondeterministic order as - -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. - where - details = ND { nd_bndr = bndr' - , nd_rhs = WithTailUsageDetails scope_uds rhs' - , nd_inl = inl_fvs - , nd_simple = null rules_w_uds && null imp_rule_info - , nd_weak_fvs = weak_fvs - , nd_active_rule_fvs = active_rule_fvs } - - bndr' = bndr `setIdUnfolding` unf' - `setIdSpecialisation` mkRuleInfo rules' - - -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the - -- JoinArity rhs_ja of unadj_rhs_uds. - unadj_inl_uds = unadj_rhs_uds `andUDs` adj_unf_uds - unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds - scope_uds = TUD rhs_ja unadj_scope_uds - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - scope_fvs = udFreeVars bndr_set unadj_scope_uds - -- scope_fvs: all occurrences from this binder: RHS, unfolding, - -- and RULES, both LHS and RHS thereof, active or inactive - - inl_fvs = udFreeVars bndr_set unadj_inl_uds - -- inl_fvs: vars that would become free if the function was inlined. - -- We conservatively approximate that by thefree vars from the RHS - -- and the unfolding together. - -- See Note [inl_fvs] - - - --------- Right hand side --------- - -- Constructing the edges for the main Rec computation - -- See Note [Forming Rec groups] - -- and Note [TailUsageDetails when forming Rec groups] - -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because - -- (a) we don't yet know the final joinpointhood. It might not become a - -- join point after all! - -- (b) we don't even know whether it stays a recursive RHS after the SCC - -- analysis we are about to seed! So we can't markAllInsideLam in - -- advance, because if it ends up as a non-recursive join point we'll - -- consider it as one-shot and don't need to markAllInsideLam. - -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage - -- until occAnalRec. In effect, we pretend that the RHS becomes a - -- non-recursive join point and fix up later with adjustTailUsage. - rhs_env = rhsCtxt env - WithTailUsageDetails (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs - -- corresponding call to adjustTailUsage in occAnalRec and tagRecBinders - - --------- Unfolding --------- - -- See Note [Join points and unfoldings/rules] - unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness - -- here because that is what we are setting! - WithTailUsageDetails unf_tuds unf' = occAnalUnfolding rhs_env unf - adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds - -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M - -- of Note [Join arity prediction based on joinRhsArity] - - --------- IMP-RULES -------- - is_active = occ_rule_act env :: Activation -> Bool - imp_rule_info = lookupImpRules imp_rule_edges bndr - imp_rule_uds = impRulesScopeUsage imp_rule_info - imp_rule_fvs = impRulesActiveFvs is_active bndr_set imp_rule_info - - --------- All rules -------- - -- See Note [Join points and unfoldings/rules] - -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M - -- of Note [Join arity prediction based on joinRhsArity] - rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_tuds) - | (r,l,rhs_tuds) <- occAnalRules rhs_env bndr ] - rules' = map fstOf3 rules_w_uds - - adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds - add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds - - -------- active_rule_fvs ------------ - active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds - add_active_rule (rule, _, rhs_uds) fvs - | is_active (ruleActivation rule) - = udFreeVars bndr_set rhs_uds `unionVarSet` fvs - | otherwise - = fvs - - -------- weak_fvs ------------ - -- See Note [Weak loop breakers] - weak_fvs = foldr add_rule emptyVarSet rules_w_uds - add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs - -mkLoopBreakerNodes :: OccEnv -> TopLevelFlag - -> UsageDetails -- for BODY of let - -> [NodeDetails] - -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date --- See Note [Choosing loop breakers] --- This function primarily creates the Nodes for the --- loop-breaker SCC analysis. More specifically: --- a) tag each binder with its occurrence info --- b) add a NodeScore to each node --- c) make a Node with the right dependency edges for --- the loop-breaker SCC analysis --- d) adjust each RHS's usage details according to --- the binder's (new) shotness and join-point-hood -mkLoopBreakerNodes !env lvl body_uds details_s - = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs') - where - WithUsageDetails final_uds bndrs' = tagRecBinders lvl body_uds details_s - - mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr - = DigraphNode { node_payload = simple_nd - , node_key = varUnique old_bndr - , node_dependencies = nonDetKeysUniqSet lb_deps } - -- It's OK to use nonDetKeysUniqSet here as - -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges - -- in nondeterministic order as explained in - -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. - where - WithTailUsageDetails _ rhs = nd_rhs nd - simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score } - score = nodeScore env new_bndr lb_deps nd - lb_deps = extendFvs_ rule_fv_env inl_fvs - -- See Note [Loop breaker dependencies] - - rule_fv_env :: IdEnv IdSet - -- Maps a variable f to the variables from this group - -- reachable by a sequence of RULES starting with f - -- Domain is *subset* of bound vars (others have no rule fvs) - -- See Note [Finding rule RHS free vars] - -- Why transClosureFV? See Note [Loop breaker dependencies] - rule_fv_env = transClosureFV $ mkVarEnv $ - [ (b, rule_fvs) - | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s - , not (isEmptyVarSet rule_fvs) ] - -{- Note [Loop breaker dependencies] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The loop breaker dependencies of x in a recursive -group { f1 = e1; ...; fn = en } are: - -- The "inline free variables" of f: the fi free in - f's stable unfolding and RHS; see Note [inl_fvs] - -- Any fi reachable from those inline free variables by a sequence - of RULE rewrites. Remember, rule rewriting is not affected - by fi being a loop breaker, so we have to take the transitive - closure in case f is the only possible loop breaker in the loop. - - Hence rule_fv_env. We need only account for /active/ rules. --} - ------------------------------------------- -nodeScore :: OccEnv - -> Id -- Binder with new occ-info - -> VarSet -- Loop-breaker dependencies - -> NodeDetails - -> NodeScore -nodeScore !env new_bndr lb_deps - (ND { nd_bndr = old_bndr, nd_rhs = WithTailUsageDetails _ bind_rhs }) - - | not (isId old_bndr) -- A type or coercion variable is never a loop breaker - = (100, 0, False) - - | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers - = (0, 0, True) -- See Note [Self-recursion and loop breakers] - - | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has - = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker - - | exprIsTrivial rhs - = mk_score 10 -- Practically certain to be inlined - -- Used to have also: && not (isExportedId bndr) - -- But I found this sometimes cost an extra iteration when we have - -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } - -- where df is the exported dictionary. Then df makes a really - -- bad choice for loop breaker - - | DFunUnfolding { df_args = args } <- old_unf - -- Never choose a DFun as a loop breaker - -- Note [DFuns should not be loop breakers] - = (9, length args, is_lb) - - -- Data structures are more important than INLINE pragmas - -- so that dictionary/method recursion unravels - - | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf - = mk_score 6 - - | is_con_app rhs -- Data types help with cases: - = mk_score 5 -- Note [Constructor applications] - - | isStableUnfolding old_unf - , can_unfold - = mk_score 3 - - | isOneOcc (idOccInfo new_bndr) - = mk_score 2 -- Likely to be inlined - - | can_unfold -- The Id has some kind of unfolding - = mk_score 1 - - | otherwise - = (0, 0, is_lb) - - where - mk_score :: Int -> NodeScore - mk_score rank = (rank, rhs_size, is_lb) - - -- is_lb: see Note [Loop breakers, node scoring, and stability] - is_lb = isStrongLoopBreaker (idOccInfo old_bndr) - - old_unf = realIdUnfolding old_bndr - can_unfold = canUnfold old_unf - rhs = case old_unf of - CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } - | isStableSource src - -> unf_rhs - _ -> bind_rhs - -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding - rhs_size = case old_unf of - CoreUnfolding { uf_guidance = guidance } - | UnfIfGoodArgs { ug_size = size } <- guidance - -> size - _ -> cheapExprSize rhs - - - -- Checking for a constructor application - -- Cheap and cheerful; the simplifier moves casts out of the way - -- The lambda case is important to spot x = /\a. C (f a) - -- which comes up when C is a dictionary constructor and - -- f is a default method. - -- Example: the instance for Show (ST s a) in GHC.ST - -- - -- However we *also* treat (\x. C p q) as a con-app-like thing, - -- Note [Closure conversion] - is_con_app (Var v) = isConLikeId v - is_con_app (App f _) = is_con_app f - is_con_app (Lam _ e) = is_con_app e - is_con_app (Tick _ e) = is_con_app e - is_con_app (Let _ e) = is_con_app e -- let x = let y = blah in (a,b) - is_con_app _ = False -- We will float the y out, so treat - -- the x-binding as a con-app (#20941) - -maxExprSize :: Int -maxExprSize = 20 -- Rather arbitrary - -cheapExprSize :: CoreExpr -> Int --- Maxes out at maxExprSize -cheapExprSize e - = go 0 e - where - go n e | n >= maxExprSize = n - | otherwise = go1 n e - - go1 n (Var {}) = n+1 - go1 n (Lit {}) = n+1 - go1 n (Type {}) = n - go1 n (Coercion {}) = n - go1 n (Tick _ e) = go1 n e - go1 n (Cast e _) = go1 n e - go1 n (App f a) = go (go1 n f) a - go1 n (Lam b e) - | isTyVar b = go1 n e - | otherwise = go (n+1) e - go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) - go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) - - gos n [] = n - gos n (e:es) | n >= maxExprSize = n - | otherwise = gos (go1 n e) es - -betterLB :: NodeScore -> NodeScore -> Bool --- If n1 `betterLB` n2 then choose n1 as the loop breaker -betterLB (rank1, size1, lb1) (rank2, size2, _) - | rank1 < rank2 = True - | rank1 > rank2 = False - | size1 < size2 = False -- Make the bigger n2 into the loop breaker - | size1 > size2 = True - | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it - | otherwise = False -- See Note [Loop breakers, node scoring, and stability] - -{- Note [Self-recursion and loop breakers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - rec { f = ...f...g... - ; g = .....f... } -then 'f' has to be a loop breaker anyway, so we may as well choose it -right away, so that g can inline freely. - -This is really just a cheap hack. Consider - rec { f = ...g... - ; g = ..f..h... - ; h = ...f....} -Here f or g are better loop breakers than h; but we might accidentally -choose h. Finding the minimal set of loop breakers is hard. - -Note [Loop breakers, node scoring, and stability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To choose a loop breaker, we give a NodeScore to each node in the SCC, -and pick the one with the best score (according to 'betterLB'). - -We need to be jolly careful (#12425, #12234) about the stability -of this choice. Suppose we have - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...f.. - False -> ..f... - -In each iteration of the simplifier the occurrence analyser OccAnal -chooses a loop breaker. Suppose in iteration 1 it choose g as the loop -breaker. That means it is free to inline f. - -Suppose that GHC decides to inline f in the branches of the case, but -(for some reason; eg it is not saturated) in the rhs of g. So we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...g...g..... - False -> ..g..g.... - -Now suppose that, for some reason, in the next iteration the occurrence -analyser chooses f as the loop breaker, so it can freely inline g. And -again for some reason the simplifier inlines g at its calls in the case -branches, but not in the RHS of f. Then we get - - let rec { f = ...g...g... - ; g = ...f...f... } - in - case x of - True -> ...(...f...f...)...(...f..f..)..... - False -> ..(...f...f...)...(..f..f...).... - -You can see where this is going! Each iteration of the simplifier -doubles the number of calls to f or g. No wonder GHC is slow! - -(In the particular example in comment:3 of #12425, f and g are the two -mutually recursive fmap instances for CondT and Result. They are both -marked INLINE which, oddly, is why they don't inline in each other's -RHS, because the call there is not saturated.) - -The root cause is that we flip-flop on our choice of loop breaker. I -always thought it didn't matter, and indeed for any single iteration -to terminate, it doesn't matter. But when we iterate, it matters a -lot!! - -So The Plan is this: - If there is a tie, choose the node that - was a loop breaker last time round - -Hence the is_lb field of NodeScore --} - -{- ********************************************************************* -* * - Lambda groups -* * -********************************************************************* -} - -{- Note [Occurrence analysis for lambda binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For value lambdas we do a special hack. Consider - (\x. \y. ...x...) -If we did nothing, x is used inside the \y, so would be marked -as dangerous to dup. But in the common case where the abstraction -is applied to two arguments this is over-pessimistic, which delays -inlining x, which forces more simplifier iterations. - -So the occurrence analyser collaborates with the simplifier to treat -a /lambda-group/ specially. A lambda-group is a contiguous run of -lambda and casts, e.g. - Lam x (Lam y (Cast (Lam z body) co)) - -* Occurrence analyser: we just mark each binder in the lambda-group - (here: x,y,z) with its occurrence info in the *body* of the - lambda-group. See occAnalLamTail. - -* Simplifier. The simplifier is careful when partially applying - lambda-groups. See the call to zapLambdaBndrs in - GHC.Core.Opt.Simplify.simplExprF1 - GHC.Core.SimpleOpt.simple_app - -* Why do we take care to account for intervening casts? Answer: - currently we don't do eta-expansion and cast-swizzling in a stable - unfolding (see Historical-note [Eta-expansion in stable unfoldings]). - So we can get - f = \x. ((\y. ...x...y...) |> co) - Now, since the lambdas aren't together, the occurrence analyser will - say that x is OnceInLam. Now if we have a call - (f e1 |> co) e2 - we'll end up with - let x = e1 in ...x..e2... - and it'll take an extra iteration of the Simplifier to substitute for x. - -A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity -recognises except that the latter looks through (some) ticks. Maybe a lambda -group should also look through (some) ticks? --} - -isOneShotFun :: CoreExpr -> Bool --- The top level lambdas, ignoring casts, of the expression --- are all one-shot. If there aren't any lambdas at all, this is True -isOneShotFun (Lam b e) = isOneShotBndr b && isOneShotFun e -isOneShotFun (Cast e _) = isOneShotFun e -isOneShotFun _ = True - -zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr --- If (\xyz. t) appears under-applied to only two arguments, --- we must zap the occ-info on x,y, because they appear under the \z --- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal --- --- NB: `arg_count` includes both type and value args -zapLambdaBndrs fun arg_count - = -- If the lambda is fully applied, leave it alone; if not - -- zap the OccInfo on the lambdas that do have arguments, - -- so they beta-reduce to use-many Lets rather than used-once ones. - zap arg_count fun `orElse` fun - where - zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr - -- Nothing => No need to change the occ-info - -- Just e => Had to change - zap 0 e | isOneShotFun e = Nothing -- All remaining lambdas are one-shot - | otherwise = Just e -- in which case no need to zap - zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) } - zap n (Lam b e) = do { e' <- zap (n-1) e - ; return (Lam (zap_bndr b) e') } - zap _ _ = Nothing -- More arguments than lambdas - - zap_bndr b | isTyVar b = b - | otherwise = zapLamIdInfo b - -occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr --- ^ See Note [Occurrence analysis for lambda binders]. --- It does the following: --- * Sets one-shot info on the lambda binder from the OccEnv, and --- removes that one-shot info from the OccEnv --- * Sets the OccEnv to OccVanilla when going under a value lambda --- * Tags each lambda with its occurrence information --- * Walks through casts --- * Package up the analysed lambda with its manifest join arity --- --- This function does /not/ do --- markAllInsideLam or --- markAllNonTail --- The caller does that, via adjustTailUsage (mostly calls go through --- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call --- adjustTailUsage to discharge the assumed join arity. --- --- In effect, the analysis result is for a non-recursive join point with --- manifest arity and adjustTailUsage does the fixup. --- See Note [Adjusting right-hand sides] -occAnalLamTail env (Lam bndr expr) - | isTyVar bndr - , let env1 = addOneInScope env bndr - , WithTailUsageDetails (TUD ja usage) expr' <- occAnalLamTail env1 expr - = WithTailUsageDetails (TUD (ja+1) usage) (Lam bndr expr') - -- Important: Keep the 'env' unchanged so that with a RHS like - -- \(@ x) -> K @x (f @x) - -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain - -- from inlining f. See the beginning of Note [Cascading inlines]. - - | otherwise -- So 'bndr' is an Id - = let (env_one_shots', bndr1) - = case occ_one_shots env of - [] -> ([], bndr) - (os : oss) -> (oss, updOneShotInfo bndr os) - -- Use updOneShotInfo, not setOneShotInfo, as pre-existing - -- one-shot info might be better than what we can infer, e.g. - -- due to explicit use of the magic 'oneShot' function. - -- See Note [The oneShot function] - - env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' } - env2 = addOneInScope env1 bndr - WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env2 expr - (usage', bndr2) = tagLamBinder usage bndr1 - in WithTailUsageDetails (TUD (ja+1) usage') (Lam bndr2 expr') - --- For casts, keep going in the same lambda-group --- See Note [Occurrence analysis for lambda binders] -occAnalLamTail env (Cast expr co) - = let WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env expr - -- usage1: see Note [Gather occurrences of coercion variables] - usage1 = addManyOccs usage (coVarsOfCo co) - - -- usage2: see Note [Occ-anal and cast worker/wrapper] - usage2 = case expr of - Var {} | isRhsEnv env -> markAllMany usage1 - _ -> usage1 - - -- usage3: you might think this was not necessary, because of - -- the markAllNonTail in adjustTailUsage; but not so! For a - -- join point, adjustTailUsage doesn't do this; yet if there is - -- a cast, we must! Also: why markAllNonTail? See - -- GHC.Core.Lint: Note Note [Join points and casts] - usage3 = markAllNonTail usage2 - - in WithTailUsageDetails (TUD ja usage3) (Cast expr' co) - -occAnalLamTail env expr = case occAnal env expr of - WithUsageDetails usage expr' -> WithTailUsageDetails (TUD 0 usage) expr' - -{- Note [Occ-anal and cast worker/wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider y = e; x = y |> co -If we mark y as used-once, we'll inline y into x, and the Cast -worker/wrapper transform will float it straight back out again. See -Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify. - -So in this particular case we want to mark 'y' as Many. It's very -ad-hoc, but it's also simple. It's also what would happen if we gave -the binding for x a stable unfolding (as we usually do for wrappers, thus - y = e - {-# INLINE x #-} - x = y |> co -Now y appears twice -- once in x's stable unfolding, and once in x's -RHS. So it'll get a Many occ-info. (Maybe Cast w/w should create a stable -unfolding, which would obviate this Note; but that seems a bit of a -heavyweight solution.) - -We only need to this in occAnalLamTail, not occAnal, because the top leve -of a right hand side is handled by occAnalLamTail. --} - - -{- ********************************************************************* -* * - Right hand sides -* * -********************************************************************* -} - -occAnalUnfolding :: OccEnv - -> Unfolding - -> WithTailUsageDetails Unfolding --- Occurrence-analyse a stable unfolding; --- discard a non-stable one altogether and return empty usage details. -occAnalUnfolding !env unf - = case unf of - unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src -> - let - WithTailUsageDetails (TUD rhs_ja usage) rhs' = occAnalLamTail env rhs - - unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules] - | otherwise = unf { uf_tmpl = rhs' } - in WithTailUsageDetails (TUD rhs_ja (markAllMany usage)) unf' - -- markAllMany: see Note [Occurrences in stable unfoldings] - | otherwise -> WithTailUsageDetails (TUD 0 emptyDetails) unf - -- For non-Stable unfoldings we leave them undisturbed, but - -- don't count their usage because the simplifier will discard them. - -- We leave them undisturbed because nodeScore uses their size info - -- to guide its decisions. It's ok to leave un-substituted - -- expressions in the tree because all the variables that were in - -- scope remain in scope; there is no cloning etc. - - unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) - -> WithTailUsageDetails (TUD 0 final_usage) (unf { df_args = args' }) - where - env' = env `addInScope` bndrs - (WithUsageDetails usage args') = occAnalList env' args - final_usage = usage `addLamCoVarOccs` bndrs `delDetailsList` bndrs - -- delDetailsList; no need to use tagLamBinders because we - -- never inline DFuns so the occ-info on binders doesn't matter - - unf -> WithTailUsageDetails (TUD 0 emptyDetails) unf - -occAnalRules :: OccEnv - -> Id -- Get rules from here - -> [(CoreRule, -- Each (non-built-in) rule - UsageDetails, -- Usage details for LHS - TailUsageDetails)] -- Usage details for RHS -occAnalRules !env bndr - = map occ_anal_rule (idCoreRules bndr) - where - occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = (rule', lhs_uds', TUD rhs_ja rhs_uds') - where - env' = env `addInScope` bndrs - rule' | noBinderSwaps env = rule -- Note [Unfoldings and rules] - | otherwise = rule { ru_args = args', ru_rhs = rhs' } - - (WithUsageDetails lhs_uds args') = occAnalList env' args - lhs_uds' = markAllManyNonTail (lhs_uds `delDetailsList` bndrs) - `addLamCoVarOccs` bndrs - - (WithUsageDetails rhs_uds rhs') = occAnal env' rhs - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - rhs_uds' = markAllMany $ - rhs_uds `delDetailsList` bndrs - rhs_ja = length args -- See Note [Join points and unfoldings/rules] - - occ_anal_rule other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails) - -{- Note [Join point RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - x = e - join j = Just x - -We want to inline x into j right away, so we don't want to give -the join point a RhsCtxt (#14137). It's not a huge deal, because -the FloatIn pass knows to float into join point RHSs; and the simplifier -does not float things out of join point RHSs. But it's a simple, cheap -thing to do. See #14137. - -Note [Occurrences in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f p = BIG - {-# INLINE g #-} - g y = not (f y) -where this is the /only/ occurrence of 'f'. So 'g' will get a stable -unfolding. Now suppose that g's RHS gets optimised (perhaps by a rule -or inlining f) so that it doesn't mention 'f' any more. Now the last -remaining call to f is in g's Stable unfolding. But, even though there -is only one syntactic occurrence of f, we do /not/ want to do -preinlineUnconditionally here! - -The INLINE pragma says "inline exactly this RHS"; perhaps the -programmer wants to expose that 'not', say. If we inline f that will make -the Stable unfoldign big, and that wasn't what the programmer wanted. - -Another way to think about it: if we inlined g as-is into multiple -call sites, now there's be multiple calls to f. - -Bottom line: treat all occurrences in a stable unfolding as "Many". -We still leave tail call information intact, though, as to not spoil -potential join points. - -Note [Unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally unfoldings and rules are already occurrence-analysed, so we -don't want to reconstruct their trees; we just want to analyse them to -find how they use their free variables. - -EXCEPT if there is a binder-swap going on, in which case we do want to -produce a new tree. - -So we have a fast-path that keeps the old tree if the occ_bs_env is -empty. This just saves a bit of allocation and reconstruction; not -a big deal. - -This fast path exposes a tricky cornder, though (#22761). Supose we have - Unfolding = \x. let y = foo in x+1 -which includes a dead binding for `y`. In occAnalUnfolding we occ-anal -the unfolding and produce /no/ occurrences of `foo` (since `y` is -dead). But if we discard the occ-analysed syntax tree (which we do on -our fast path), and use the old one, we still /have/ an occurrence of -`foo` -- and that can lead to out-of-scope variables (#22761). - -Solution: always keep occ-analysed trees in unfoldings and rules, so they -have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. - -Note [Cascading inlines] -~~~~~~~~~~~~~~~~~~~~~~~~ -By default we use an rhsCtxt for the RHS of a binding. This tells the -occ anal n that it's looking at an RHS, which has an effect in -occAnalApp. In particular, for constructor applications, it makes -the arguments appear to have NoOccInfo, so that we don't inline into -them. Thus x = f y - k = Just x -we do not want to inline x. - -But there's a problem. Consider - x1 = a0 : [] - x2 = a1 : x1 - x3 = a2 : x2 - g = f x3 -First time round, it looks as if x1 and x2 occur as an arg of a -let-bound constructor ==> give them a many-occurrence. -But then x3 is inlined (unconditionally as it happens) and -next time round, x2 will be, and the next time round x1 will be -Result: multiple simplifier iterations. Sigh. - -So, when analysing the RHS of x3 we notice that x3 will itself -definitely inline the next time round, and so we analyse x3's rhs in -an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. - -Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally. -If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and - (b) certainly_inline says "yes" when preInlineUnconditionally says "no" -then the simplifier iterates indefinitely: - x = f y - k = Just x -- We decide that k is 'certainly_inline' - v = ...k... -- but preInlineUnconditionally doesn't inline it -inline ==> - k = Just (f y) - v = ...k... -float ==> - x1 = f y - k = Just x1 - v = ...k... - -This is worse than the slow cascade, so we only want to say "certainly_inline" -if it really is certain. Look at the note with preInlineUnconditionally -for the various clauses. - - -************************************************************************ -* * - Expressions -* * -************************************************************************ --} - -occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr] -occAnalList !_ [] = WithUsageDetails emptyDetails [] -occAnalList env (e:es) = let - (WithUsageDetails uds1 e') = occAnal env e - (WithUsageDetails uds2 es') = occAnalList env es - in WithUsageDetails (uds1 `andUDs` uds2) (e' : es') - -occAnal :: OccEnv - -> CoreExpr - -> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids - -occAnal !_ expr@(Lit _) = WithUsageDetails emptyDetails expr - -occAnal env expr@(Var _) = occAnalApp env (expr, [], []) - -- At one stage, I gathered the idRuleVars for the variable here too, - -- which in a way is the right thing to do. - -- But that went wrong right after specialisation, when - -- the *occurrences* of the overloaded function didn't have any - -- rules in them, so the *specialised* versions looked as if they - -- weren't used at all. - -occAnal _ expr@(Type ty) - = WithUsageDetails (addManyOccs emptyDetails (coVarsOfType ty)) expr -occAnal _ expr@(Coercion co) - = WithUsageDetails (addManyOccs emptyDetails (coVarsOfCo co)) expr - -- See Note [Gather occurrences of coercion variables] - -{- Note [Gather occurrences of coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to gather info about what coercion variables appear, for two reasons: - -1. So that we can sort them into the right place when doing dependency analysis. - -2. So that we know when they are surely dead. - -It is useful to know when they a coercion variable is surely dead, -when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase. -For example (#20143): - - case unsafeEqualityProof @blah of - UnsafeRefl cv -> ...no use of cv... - -Here we can discard the case, since unsafeEqualityProof always terminates. -But only if the coercion variable 'cv' is unused. - -Another example from #15696: we had something like - case eq_sel d of co -> ...(typeError @(...co...) "urk")... -Then 'd' was substituted by a dictionary, so the expression -simpified to - case (Coercion ) of cv -> ...(typeError @(...cv...) "urk")... - -We can only drop the case altogether if 'cv' is unused, which is not -the case here. - -Conclusion: we need accurate dead-ness info for CoVars. -We gather CoVar occurrences from: - - * The (Type ty) and (Coercion co) cases of occAnal - - * The type 'ty' of a lambda-binder (\(x:ty). blah) - See addLamCoVarOccs - -But it is not necessary to gather CoVars from the types of other binders. - -* For let-binders, if the type mentions a CoVar, so will the RHS (since - it has the same type) - -* For case-alt binders, if the type mentions a CoVar, so will the scrutinee - (since it has the same type) --} - -occAnal env (Tick tickish body) - | SourceNote{} <- tickish - = WithUsageDetails usage (Tick tickish body') - -- SourceNotes are best-effort; so we just proceed as usual. - -- If we drop a tick due to the issues described below it's - -- not the end of the world. - - | tickish `tickishScopesLike` SoftScope - = WithUsageDetails (markAllNonTail usage) (Tick tickish body') - - | Breakpoint _ _ ids <- tickish - = WithUsageDetails (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body') - -- never substitute for any of the Ids in a Breakpoint - - | otherwise - = WithUsageDetails usage_lam (Tick tickish body') - where - (WithUsageDetails usage body') = occAnal env body - -- for a non-soft tick scope, we can inline lambdas only - usage_lam = markAllNonTail (markAllInsideLam usage) - -- TODO There may be ways to make ticks and join points play - -- nicer together, but right now there are problems: - -- let j x = ... in tick (j 1) - -- Making j a join point may cause the simplifier to drop t - -- (if the tick is put into the continuation). So we don't - -- count j 1 as a tail call. - -- See #14242. - -occAnal env (Cast expr co) - = let (WithUsageDetails usage expr') = occAnal env expr - usage1 = addManyOccs usage (coVarsOfCo co) - -- usage2: see Note [Gather occurrences of coercion variables] - usage2 = markAllNonTail usage1 - -- usage3: calls inside expr aren't tail calls any more - in WithUsageDetails usage2 (Cast expr' co) - -occAnal env app@(App _ _) - = occAnalApp env (collectArgsTicks tickishFloatable app) - -occAnal env expr@(Lam {}) - = adjustNonRecRhs Nothing $ occAnalLamTail env expr -- mb_join_arity == Nothing <=> markAllManyNonTail - -occAnal env (Case scrut bndr ty alts) - = let - (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut - alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr - (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts - alts_usage = foldr orUDs emptyDetails alts_usage_s - (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr - total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1 - -- Alts can have tail calls, but the scrutinee can't - in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts') - where - do_alt !env (Alt con bndrs rhs) - = let - (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs - (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs - in -- See Note [Binders in case alternatives] - (alt_usg, Alt con tagged_bndrs rhs1) - -occAnal env (Let bind body) - = let - body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind - (WithUsageDetails body_usage body') = occAnal body_env body - (WithUsageDetails final_usage binds') = occAnalBind env NotTopLevel - noImpRuleEdges bind body_usage - in WithUsageDetails final_usage (mkLets binds' body') - -occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr --- The `fun` argument is just an accumulating parameter, --- the base for building the application we return -occAnalArgs !env fun args !one_shots - = go emptyDetails fun args one_shots - where - go uds fun [] _ = WithUsageDetails uds fun - go uds fun (arg:args) one_shots - = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots' - where - !(WithUsageDetails arg_uds arg') = occAnal arg_env arg - !(arg_env, one_shots') - | isTypeArg arg = (env, one_shots) - | otherwise = valArgCtxt env one_shots - -{- -Applications are dealt with specially because we want -the "build hack" to work. - -Note [Arguments of let-bound constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. - -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. --} - -occAnalApp :: OccEnv - -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish]) - -> WithUsageDetails (Expr CoreBndr) --- Naked variables (not applied) end up here too -occAnalApp !env (Var fun, args, ticks) - -- Account for join arity of runRW# continuation - -- See Note [Simplification of runRW#] - -- - -- NB: Do not be tempted to make the next (Var fun, args, tick) - -- equation into an 'otherwise' clause for this equation - -- The former has a bang-pattern to occ-anal the args, and - -- we don't want to occ-anal them twice in the runRW# case! - -- This caused #18296 - | fun `hasKey` runRWKey - , [t1, t2, arg] <- args - , WithUsageDetails usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg - = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) - -occAnalApp env (Var fun_id, args, ticks) - = WithUsageDetails all_uds (mkTicks ticks app') - where - -- Lots of banged bindings: this is a very heavily bit of code, - -- so it pays not to make lots of thunks here, all of which - -- will ultimately be forced. - !(fun', fun_id') = lookupBndrSwap env fun_id - !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots - - fun_uds = mkOneOcc fun_id' int_cxt n_args - -- NB: fun_uds is computed for fun_id', not fun_id - -- See (BS1) in Note [The binder-swap substitution] - - all_uds = fun_uds `andUDs` final_args_uds - - !final_args_uds = markAllNonTail $ - markAllInsideLamIf (isRhsEnv env && is_exp) $ - args_uds - -- We mark the free vars of the argument of a constructor or PAP - -- as "inside-lambda", if it is the RHS of a let(rec). - -- This means that nothing gets inlined into a constructor or PAP - -- argument position, which is what we want. Typically those - -- constructor arguments are just variables, or trivial expressions. - -- We use inside-lam because it's like eta-expanding the PAP. - -- - -- This is the *whole point* of the isRhsEnv predicate - -- See Note [Arguments of let-bound constructors] - - !n_val_args = valArgCount args - !n_args = length args - !int_cxt = case occ_encl env of - OccScrut -> IsInteresting - _other | n_val_args > 0 -> IsInteresting - | otherwise -> NotInteresting - - !is_exp = isExpandableApp fun_id n_val_args - -- See Note [CONLIKE pragma] in GHC.Types.Basic - -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs - - one_shots = argsOneShots (idDmdSig fun_id) guaranteed_val_args - guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo - (occ_one_shots env)) - -- See Note [Sources of one-shot information], bullet point A'] - -occAnalApp env (fun, args, ticks) - = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds)) - (mkTicks ticks app') - where - !(WithUsageDetails args_uds app') = occAnalArgs env fun' args [] - !(WithUsageDetails fun_uds fun') = occAnal (addAppCtxt env args) fun - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexs like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some OneShotLam items - -- onto the context stack. - -addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args - | n_val_args > 0 - = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt - , occ_encl = OccVanilla } - -- OccVanilla: the function part of the application - -- is no longer on OccRhs or OccScrut - | otherwise - = env - where - n_val_args = valArgCount args - - -{- -Note [Sources of one-shot information] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The occurrence analyser obtains one-shot-lambda information from two sources: - -A: Saturated applications: eg f e1 .. en - - In general, given a call (f e1 .. en) we can propagate one-shot info from - f's strictness signature into e1 .. en, but /only/ if n is enough to - saturate the strictness signature. A strictness signature like - - f :: C(1,C(1,L))LS - - means that *if f is applied to three arguments* then it will guarantee to - call its first argument at most once, and to call the result of that at - most once. But if f has fewer than three arguments, all bets are off; e.g. - - map (f (\x y. expensive) e2) xs - - Here the \x y abstraction may be called many times (once for each element of - xs) so we should not mark x and y as one-shot. But if it was - - map (f (\x y. expensive) 3 2) xs - - then the first argument of f will be called at most once. - - The one-shot info, derived from f's strictness signature, is - computed by 'argsOneShots', called in occAnalApp. - -A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) - where f is as above. - - In this case, f is only manifestly applied to one argument, so it does not - look saturated. So by the previous point, we should not use its strictness - signature to learn about the one-shotness of \x y. But in this case we can: - build is fully applied, so we may use its strictness signature; and from - that we learn that build calls its argument with two arguments *at most once*. - - So there is really only one call to f, and it will have three arguments. In - that sense, f is saturated, and we may proceed as described above. - - Hence the computation of 'guaranteed_val_args' in occAnalApp, using - '(occ_one_shots env)'. See also #13227, comment:9 - -B: Let-bindings: eg let f = \c. let ... in \n -> blah - in (build f, build f) - - Propagate one-shot info from the demand-info on 'f' to the - lambdas in its RHS (which may not be syntactically at the top) - - This information must have come from a previous run of the demand - analyser. - -Previously, the demand analyser would *also* set the one-shot information, but -that code was buggy (see #11770), so doing it only in on place, namely here, is -saner. - -Note [OneShots] -~~~~~~~~~~~~~~~ -When analysing an expression, the occ_one_shots argument contains information -about how the function is being used. The length of the list indicates -how many arguments will eventually be passed to the analysed expression, -and the OneShotInfo indicates whether this application is once or multiple times. - -Example: - - Context of f occ_one_shots when analysing f - - f 1 2 [OneShot, OneShot] - map (f 1) [OneShot, NoOneShotInfo] - build f [OneShot, OneShot] - f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] - -Note [Binders in case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - case x of y { (a,b) -> f y } -We treat 'a', 'b' as dead, because they don't physically occur in the -case alternative. (Indeed, a variable is dead iff it doesn't occur in -its scope in the output of OccAnal.) It really helps to know when -binders are unused. See esp the call to isDeadBinder in -Simplify.mkDupableAlt - -In this example, though, the Simplifier will bring 'a' and 'b' back to -life, because it binds 'y' to (a,b) (imagine got inlined and -scrutinised y). --} - -{- -************************************************************************ -* * - OccEnv -* * -************************************************************************ --} - -data OccEnv - = OccEnv { occ_encl :: !OccEncl -- Enclosing context information - , occ_one_shots :: !OneShots -- See Note [OneShots] - , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active - , occ_rule_act :: Activation -> Bool -- Which rules are active - -- See Note [Finding rule RHS free vars] - - -- See Note [The binder-swap substitution] - -- If x :-> (y, co) is in the env, - -- then please replace x by (y |> mco) - -- Invariant of course: idType x = exprType (y |> mco) - , occ_bs_env :: !(IdEnv (OutId, MCoercion)) - -- Domain is Global and Local Ids - -- Range is just Local Ids - , occ_bs_rng :: !VarSet - -- Vars (TyVars and Ids) free in the range of occ_bs_env - } - - ------------------------------ --- OccEncl is used to control whether to inline into constructor arguments --- For example: --- x = (p,q) -- Don't inline p or q --- y = /\a -> (p a, q a) -- Still don't inline p or q --- z = f (p,q) -- Do inline p,q; it may make a rule fire --- So OccEncl tells enough about the context to know what to do when --- we encounter a constructor application or PAP. --- --- OccScrut is used to set the "interesting context" field of OncOcc - -data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - - | OccScrut -- Scrutintee of a case - -- Can inline into constructor args - - | OccVanilla -- Argument of function, body of lambda, etc - -- Do inline into constructor args here - -instance Outputable OccEncl where - ppr OccRhs = text "occRhs" - ppr OccScrut = text "occScrut" - ppr OccVanilla = text "occVanilla" - --- See Note [OneShots] -type OneShots = [OneShotInfo] - -initOccEnv :: OccEnv -initOccEnv - = OccEnv { occ_encl = OccVanilla - , occ_one_shots = [] - - -- To be conservative, we say that all - -- inlines and rules are active - , occ_unf_act = \_ -> True - , occ_rule_act = \_ -> True - - , occ_bs_env = emptyVarEnv - , occ_bs_rng = emptyVarSet } - -noBinderSwaps :: OccEnv -> Bool -noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env - -scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv -scrutCtxt !env alts - | interesting_alts = env { occ_encl = OccScrut, occ_one_shots = [] } - | otherwise = env { occ_encl = OccVanilla, occ_one_shots = [] } - where - interesting_alts = case alts of - [] -> False - [alt] -> not (isDefaultAlt alt) - _ -> True - -- 'interesting_alts' is True if the case has at least one - -- non-default alternative. That in turn influences - -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! - -rhsCtxt :: OccEnv -> OccEnv -rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] } - -valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) -valArgCtxt !env [] - = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) -valArgCtxt env (one_shots:one_shots_s) - = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) - -isRhsEnv :: OccEnv -> Bool -isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of - OccRhs -> True - _ -> False - -addOneInScope :: OccEnv -> CoreBndr -> OccEnv --- Needed for all Vars not just Ids --- See Note [The binder-swap substitution] (BS3) -addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr - | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } - | otherwise = env { occ_bs_env = swap_env `delVarEnv` bndr } - -addInScope :: OccEnv -> [Var] -> OccEnv --- Needed for all Vars not just Ids --- See Note [The binder-swap substitution] (BS3) -addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs - | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } - | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs } - - --------------------- -transClosureFV :: VarEnv VarSet -> VarEnv VarSet --- If (f,g), (g,h) are in the input, then (f,h) is in the output --- as well as (f,g), (g,h) -transClosureFV env - | no_change = env - | otherwise = transClosureFV (listToUFM_Directly new_fv_list) - where - (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) - -- It's OK to use nonDetUFMToList here because we'll forget the - -- ordering by creating a new set with listToUFM - bump no_change (b,fvs) - | no_change_here = (no_change, (b,fvs)) - | otherwise = (False, (b,new_fvs)) - where - (new_fvs, no_change_here) = extendFvs env fvs - -------------- -extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet -extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag - -extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool) --- (extendFVs env s) returns --- (s `union` env(s), env(s) `subset` s) -extendFvs env s - | isNullUFM env - = (s, True) - | otherwise - = (s `unionVarSet` extras, extras `subVarSet` s) - where - extras :: VarSet -- env(s) - extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $ - -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes - intersectUFM_C (\x _ -> x) env (getUniqSet s) - -{- -************************************************************************ -* * - Binder swap -* * -************************************************************************ - -Note [Binder swap] -~~~~~~~~~~~~~~~~~~ -The "binder swap" transformation swaps occurrence of the -scrutinee of a case for occurrences of the case-binder: - - (1) case x of b { pi -> ri } - ==> - case x of b { pi -> ri[b/x] } - - (2) case (x |> co) of b { pi -> ri } - ==> - case (x |> co) of b { pi -> ri[b |> sym co/x] } - -The substitution ri[b/x] etc is done by the occurrence analyser. -See Note [The binder-swap substitution]. - -There are two reasons for making this swap: - -(A) It reduces the number of occurrences of the scrutinee, x. - That in turn might reduce its occurrences to one, so we - can inline it and save an allocation. E.g. - let x = factorial y in case x of b { I# v -> ...x... } - If we replace 'x' by 'b' in the alternative we get - let x = factorial y in case x of b { I# v -> ...b... } - and now we can inline 'x', thus - case (factorial y) of b { I# v -> ...b... } - -(B) The case-binder b has unfolding information; in the - example above we know that b = I# v. That in turn allows - nested cases to simplify. Consider - case x of b { I# v -> - ...(case x of b2 { I# v2 -> rhs })... - If we replace 'x' by 'b' in the alternative we get - case x of b { I# v -> - ...(case b of b2 { I# v2 -> rhs })... - and now it is trivial to simplify the inner case: - case x of b { I# v -> - ...(let b2 = b in rhs)... - - The same can happen even if the scrutinee is a variable - with a cast: see Note [Case of cast] - -The reason for doing these transformations /here in the occurrence -analyser/ is because it allows us to adjust the OccInfo for 'x' and -'b' as we go. - - * Suppose the only occurrences of 'x' are the scrutinee and in the - ri; then this transformation makes it occur just once, and hence - get inlined right away. - - * If instead the Simplifier replaces occurrences of x with - occurrences of b, that will mess up b's occurrence info. That in - turn might have consequences. - -There is a danger though. Consider - let v = x +# y - in case (f v) of w -> ...v...v... -And suppose that (f v) expands to just v. Then we'd like to -use 'w' instead of 'v' in the alternative. But it may be too -late; we may have substituted the (cheap) x+#y for v in the -same simplifier pass that reduced (f v) to v. - -I think this is just too bad. CSE will recover some of it. - -Note [The binder-swap substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The binder-swap is implemented by the occ_bs_env field of OccEnv. -There are two main pieces: - -* Given case x |> co of b { alts } - we add [x :-> (b, sym co)] to the occ_bs_env environment; this is - done by addBndrSwap. - -* Then, at an occurrence of a variable, we look up in the occ_bs_env - to perform the swap. This is done by lookupBndrSwap. - -Some tricky corners: - -(BS1) We do the substitution before gathering occurrence info. So in - the above example, an occurrence of x turns into an occurrence - of b, and that's what we gather in the UsageDetails. It's as - if the binder-swap occurred before occurrence analysis. See - the computation of fun_uds in occAnalApp. - -(BS2) When doing a lookup in occ_bs_env, we may need to iterate, - as you can see implemented in lookupBndrSwap. Why? - Consider case x of a { 1# -> e1; DEFAULT -> - case x of b { 2# -> e2; DEFAULT -> - case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}} - At the first case addBndrSwap will extend occ_bs_env with - [x :-> a] - At the second case we occ-anal the scrutinee 'x', which looks up - 'x in occ_bs_env, returning 'a', as it should. - Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding - occ_bs_env = [x :-> a, a :-> b] - At the third case we'll again look up 'x' which returns 'a'. - But we don't want to stop the lookup there, else we'll end up with - case x of a { 1# -> e1; DEFAULT -> - case a of b { 2# -> e2; DEFAULT -> - case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}} - Instead, we want iterate the lookup in addBndrSwap, to give - case x of a { 1# -> e1; DEFAULT -> - case a of b { 2# -> e2; DEFAULT -> - case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}} - This makes a particular difference for case-merge, which works - only if the scrutinee is the case-binder of the immediately enclosing - case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils - See #19581 for the bug report that showed this up. - -(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, - and we encounter: - (i) \x. blah - Here we want to delete the x-binding from occ_bs_env - - (ii) \b. blah - This is harder: we really want to delete all bindings that - have 'b' free in the range. That is a bit tiresome to implement, - so we compromise. We keep occ_bs_rng, which is the set of - free vars of rng(occc_bs_env). If a binder shadows any of these - variables, we discard all of occ_bs_env. Safe, if a bit - brutal. NB, however: the simplifer de-shadows the code, so the - next time around this won't happen. - - These checks are implemented in addInScope. - (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623) - because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we - must not replace `x` by `...a...` under /\a. ...x..., or similarly - under a case pattern match that binds `a`. - - An alternative would be for the occurrence analyser to do cloning as - it goes. In principle it could do so, but it'd make it a bit more - complicated and there is no great benefit. The simplifer uses - cloning to get a no-shadowing situation, the care-when-shadowing - behaviour above isn't needed for long. - -(BS4) The domain of occ_bs_env can include GlobaIds. Eg - case M.foo of b { alts } - We extend occ_bs_env with [M.foo :-> b]. That's fine. - -(BS5) We have to apply the occ_bs_env substitution uniformly, - including to (local) rules and unfoldings. - -(BS6) We must be very careful with dictionaries. - See Note [Care with binder-swap on dictionaries] - -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (x `cast` co) of b { I# -> - ... (case (x `cast` co) of {...}) ... -We'd like to eliminate the inner case. That is the motivation for -equation (2) in Note [Binder swap]. When we get to the inner case, we -inline x, cancel the casts, and away we go. - -Note [Care with binder-swap on dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note explains why we need isDictId in scrutBinderSwap_maybe. -Consider this tricky example (#21229, #21470): - - class Sing (b :: Bool) where sing :: Bool - instance Sing 'True where sing = True - instance Sing 'False where sing = False - - f :: forall a. Sing a => blah - - h = \ @(a :: Bool) ($dSing :: Sing a) - let the_co = Main.N:Sing[0] :: Sing a ~R# Bool - case ($dSing |> the_co) of wild - True -> f @'True (True |> sym the_co) - False -> f @a dSing - -Now do a binder-swap on the case-expression: - - h = \ @(a :: Bool) ($dSing :: Sing a) - let the_co = Main.N:Sing[0] :: Sing a ~R# Bool - case ($dSing |> the_co) of wild - True -> f @'True (True |> sym the_co) - False -> f @a (wild |> sym the_co) - -And now substitute `False` for `wild` (since wild=False in the False branch): - - h = \ @(a :: Bool) ($dSing :: Sing a) - let the_co = Main.N:Sing[0] :: Sing a ~R# Bool - case ($dSing |> the_co) of wild - True -> f @'True (True |> sym the_co) - False -> f @a (False |> sym the_co) - -And now we have a problem. The specialiser will specialise (f @a d)a (for all -vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using -Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise. - -The real problem is the binder-swap. It swaps a dictionary variable $dSing -(of kind Constraint) for a term variable wild (of kind Type). And that is -dangerous: a dictionary is a /singleton/ type whereas a general term variable is -not. In this particular example, Bool is most certainly not a singleton type! - -Conclusion: - for a /dictionary variable/ do not perform - the clever cast version of the binder-swap - -Hence the subtle isDictId in scrutBinderSwap_maybe. - -Note [Zap case binders in proxy bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From the original - case x of cb(dead) { p -> ...x... } -we will get - case x of cb(live) { p -> ...cb... } - -Core Lint never expects to find an *occurrence* of an Id marked -as Dead, so we must zap the OccInfo on cb before making the -binding x = cb. See #5028. - -NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier -doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. - --} - -addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv --- See Note [The binder-swap substitution] -addBndrSwap scrut case_bndr - env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) - | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut - , scrut_var /= case_bndr - -- Consider: case x of x { ... } - -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop - = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) - , occ_bs_rng = rng_vars `extendVarSet` case_bndr' - `unionVarSet` tyCoVarsOfMCo mco } - - | otherwise - = env - where - case_bndr' = zapIdOccInfo case_bndr - -- See Note [Zap case binders in proxy bindings] - -scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion) --- If (scrutBinderSwap_maybe e = Just (v, mco), then --- v = e |> mco --- See Note [Case of cast] --- See Note [Care with binder-swap on dictionaries] --- --- We use this same function in SpecConstr, and Simplify.Iteration, --- when something binder-swap-like is happening -scrutBinderSwap_maybe (Var v) = Just (v, MRefl) -scrutBinderSwap_maybe (Cast (Var v) co) - | not (isDictId v) = Just (v, MCo (mkSymCo co)) - -- Cast: see Note [Case of cast] - -- isDictId: see Note [Care with binder-swap on dictionaries] - -- The isDictId rejects a Constraint/Constraint binder-swap, perhaps - -- over-conservatively. But I have never seen one, so I'm leaving - -- the code as simple as possible. Losing the binder-swap in a - -- rare case probably has very low impact. -scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e -- Drop ticks -scrutBinderSwap_maybe _ = Nothing - -lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) --- See Note [The binder-swap substitution] --- Returns an expression of the same type as Id -lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr - = case lookupVarEnv bs_env bndr of { - Nothing -> (Var bndr, bndr) ; - Just (bndr1, mco) -> - - -- Why do we iterate here? - -- See (BS2) in Note [The binder-swap substitution] - case lookupBndrSwap env bndr1 of - (fun, fun_id) -> (mkCastMCo fun mco, fun_id) } - -{- Historical note [Proxy let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to do the binder-swap transformation by introducing -a proxy let-binding, thus; - - case x of b { pi -> ri } - ==> - case x of b { pi -> let x = b in ri } - -But that had two problems: - -1. If 'x' is an imported GlobalId, we'd end up with a GlobalId - on the LHS of a let-binding which isn't allowed. We worked - around this for a while by "localising" x, but it turned - out to be very painful #16296, - -2. In CorePrep we use the occurrence analyser to do dead-code - elimination (see Note [Dead code in CorePrep]). But that - occasionally led to an unlifted let-binding - case x of b { DEFAULT -> let x::Int# = b in ... } - which disobeys one of CorePrep's output invariants (no unlifted - let-bindings) -- see #5433. - -Doing a substitution (via occ_bs_env) is much better. - -Historical Note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressions when --fno-case-of-case is on. Old remarks: - "This happens in the first simplifier pass, - and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) - If we eliminate the inner case, we trap it inside the I# v -> arm, - which might prevent some full laziness happening. I've seen this - in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] - Hence the check for NoCaseOfCase." -However, now the full-laziness pass itself reverses the binder-swap, so this -check is no longer necessary. - -Historical Note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This old note describes a problem that is also fixed by doing the -binder-swap in OccAnal: - - There is another situation when it might make sense to suppress the - case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - - We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - - But there is no point in doing it for the inner case, because w1 can't - be inlined anyway. Furthermore, doing the case-swapping involves - zapping w2's occurrence info (see paragraphs that follow), and that - forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - - This is plain silly in the common case where w2 is dead. - - Even so, I can't see a good way to implement this idea. I tried - not doing the binder-swap if the scrutinee was already evaluated - but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - - Notice that because MkT is strict, x is marked "evaluated". But to - eliminate the last case, we must either make sure that x (as well as - x1) has unfolding MkT y1. The straightforward thing to do is to do - the binder-swap. So this whole note is a no-op. - -It's fixed by doing the binder-swap in OccAnal because we can do the -binder-swap unconditionally and still get occurrence analysis -information right. - - -************************************************************************ -* * -\subsection[OccurAnal-types]{OccEnv} -* * -************************************************************************ - -Note [UsageDetails and zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On many occasions, we must modify all gathered occurrence data at once. For -instance, all occurrences underneath a (non-one-shot) lambda set the -'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but -that takes O(n) time and we will do this often---in particular, there are many -places where tail calls are not allowed, and each of these causes all variables -to get marked with 'NoTailCallInfo'. - -Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along -with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" -recording which variables have been zapped in some way. Zapping all occurrence -info then simply means setting the corresponding zapped set to the whole -'OccInfoEnv', a fast O(1) operation. --} - -type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage - -- INVARIANT: never IAmDead - -- (Deadness is signalled by not being in the map at all) - -type ZappedSet = OccInfoEnv -- Values are ignored - -data UsageDetails - = UD { ud_env :: !OccInfoEnv - , ud_z_many :: !ZappedSet -- apply 'markMany' to these - , ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these - , ud_z_no_tail :: !ZappedSet } -- apply 'markNonTail' to these - -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv - -instance Outputable UsageDetails where - ppr ud = ppr (ud_env (flattenUsageDetails ud)) - --- | Captures the result of applying 'occAnalLamTail' to a function `\xyz.body`. --- The TailUsageDetails records --- * the number of lambdas (including type lambdas: a JoinArity) --- * UsageDetails for the `body`, unadjusted by `adjustTailUsage`. --- If the binding turns out to be a join point with the indicated join --- arity, this unadjusted usage details is just what we need; otherwise we --- need to discard tail calls. That's what `adjustTailUsage` does. -data TailUsageDetails = TUD !JoinArity !UsageDetails - -instance Outputable TailUsageDetails where - ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds - - -------------------- --- UsageDetails API - -andUDs, orUDs - :: UsageDetails -> UsageDetails -> UsageDetails -andUDs = combineUsageDetailsWith addOccInfo -orUDs = combineUsageDetailsWith orOccInfo - -mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails -mkOneOcc id int_cxt arity - | isLocalId id - = emptyDetails { ud_env = unitVarEnv id occ_info } - | otherwise - = emptyDetails - where - occ_info = OneOcc { occ_in_lam = NotInsideLam - , occ_n_br = oneBranch - , occ_int_cxt = int_cxt - , occ_tail = AlwaysTailCalled arity } - -addManyOccId :: UsageDetails -> Id -> UsageDetails --- Add the non-committal (id :-> noOccInfo) to the usage details -addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo } - --- Add several occurrences, assumed not to be tail calls -addManyOcc :: Var -> UsageDetails -> UsageDetails -addManyOcc v u | isId v = addManyOccId u v - | otherwise = u - -- Give a non-committal binder info (i.e noOccInfo) because - -- a) Many copies of the specialised thing can appear - -- b) We don't want to substitute a BIG expression inside a RULE - -- even if that's the only occurrence of the thing - -- (Same goes for INLINE.) - -addManyOccs :: UsageDetails -> VarSet -> UsageDetails -addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set - -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes - -addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails --- Add any CoVars free in the type of a lambda-binder --- See Note [Gather occurrences of coercion variables] -addLamCoVarOccs uds bndrs - = uds `addManyOccs` coVarsOfTypes (map varType bndrs) - -delDetails :: UsageDetails -> Id -> UsageDetails -delDetails ud bndr - = ud `alterUsageDetails` (`delVarEnv` bndr) - -delDetailsList :: UsageDetails -> [Id] -> UsageDetails -delDetailsList ud bndrs - = ud `alterUsageDetails` (`delVarEnvList` bndrs) - -emptyDetails :: UsageDetails -emptyDetails = UD { ud_env = emptyVarEnv - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_no_tail = emptyVarEnv } - -isEmptyDetails :: UsageDetails -> Bool -isEmptyDetails = isEmptyVarEnv . ud_env - -markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail - :: UsageDetails -> UsageDetails -markAllMany ud = ud { ud_z_many = ud_env ud } -markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } -markAllNonTail ud = ud { ud_z_no_tail = ud_env ud } - -markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails - -markAllInsideLamIf True ud = markAllInsideLam ud -markAllInsideLamIf False ud = ud - -markAllNonTailIf True ud = markAllNonTail ud -markAllNonTailIf False ud = ud - - -markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo - -lookupDetails :: UsageDetails -> Id -> OccInfo -lookupDetails ud id - = case lookupVarEnv (ud_env ud) id of - Just occ -> doZapping ud id occ - Nothing -> IAmDead - -usedIn :: Id -> UsageDetails -> Bool -v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud - -udFreeVars :: VarSet -> UsageDetails -> VarSet --- Find the subset of bndrs that are mentioned in uds -udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud) - -restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet -restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs - -------------------- --- Auxiliary functions for UsageDetails implementation - -combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) - -> UsageDetails -> UsageDetails -> UsageDetails -combineUsageDetailsWith plus_occ_info ud1 ud2 - | isEmptyDetails ud1 = ud2 - | isEmptyDetails ud2 = ud1 - | otherwise - = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) - , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) - , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) - , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } - -doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo -doZapping ud var occ - = doZappingByUnique ud (varUnique var) occ - -doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo -doZappingByUnique (UD { ud_z_many = many - , ud_z_in_lam = in_lam - , ud_z_no_tail = no_tail }) - uniq occ - = occ2 - where - occ1 | uniq `elemVarEnvByKey` many = markMany occ - | uniq `elemVarEnvByKey` in_lam = markInsideLam occ - | otherwise = occ - occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1 - | otherwise = occ1 - -alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails -alterUsageDetails !ud f - = UD { ud_env = f (ud_env ud) - , ud_z_many = f (ud_z_many ud) - , ud_z_in_lam = f (ud_z_in_lam ud) - , ud_z_no_tail = f (ud_z_no_tail ud) } - -flattenUsageDetails :: UsageDetails -> UsageDetails -flattenUsageDetails ud@(UD { ud_env = env }) - = UD { ud_env = mapUFM_Directly (doZappingByUnique ud) env - , ud_z_many = emptyVarEnv - , ud_z_in_lam = emptyVarEnv - , ud_z_no_tail = emptyVarEnv } - -------------------- --- See Note [Adjusting right-hand sides] -adjustTailUsage :: Maybe JoinArity - -> CoreExpr -- Rhs, AFTER occAnalLamTail - -> TailUsageDetails -- From body of lambda - -> UsageDetails -adjustTailUsage mb_join_arity rhs (TUD rhs_ja usage) - = -- c.f. occAnal (Lam {}) - markAllInsideLamIf (not one_shot) $ - markAllNonTailIf (not exact_join) $ - usage - where - one_shot = isOneShotFun rhs - exact_join = mb_join_arity == Just rhs_ja - -adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails -adjustTailArity mb_rhs_ja (TUD ud_ja usage) = - markAllNonTailIf (mb_rhs_ja /= Just ud_ja) usage - -markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr --- For a /non-recursive/ join point we can mark all --- its join-lambda as one-shot; and it's a good idea to do so -markNonRecJoinOneShots join_arity rhs - = go join_arity rhs - where - go 0 rhs = rhs - go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b) - (go (n-1) rhs) - go _ rhs = rhs -- Not enough lambdas. This can legitimately happen. - -- e.g. let j = case ... in j True - -- This will become an arity-1 join point after the - -- simplifier has eta-expanded it; but it may not have - -- enough lambdas /yet/. (Lint checks that JoinIds do - -- have enough lambdas.) - -markNonRecUnfoldingOneShots :: Maybe JoinArity -> Unfolding -> Unfolding --- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding -markNonRecUnfoldingOneShots mb_join_arity unf - | Just ja <- mb_join_arity - , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf - , isStableSource src - , let !tmpl' = markNonRecJoinOneShots ja tmpl - = unf{uf_tmpl=tmpl'} - | otherwise - = unf - -type IdWithOccInfo = Id - -tagLamBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders -tagLamBinders usage binders - = usage' `seq` (usage', bndrs') - where - (usage', bndrs') = mapAccumR tagLamBinder usage binders - -tagLamBinder :: UsageDetails -- Of scope - -> Id -- Binder - -> (UsageDetails, -- Details with binder removed - IdWithOccInfo) -- Tagged binders --- Used for lambda and case binders --- It copes with the fact that lambda bindings can have a --- stable unfolding, used for join points -tagLamBinder usage bndr - = (usage2, bndr') - where - occ = lookupDetails usage bndr - bndr' = setBinderOcc (markNonTail occ) bndr - -- Don't try to make an argument into a join point - usage1 = usage `delDetails` bndr - usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr) - -- This is effectively the RHS of a - -- non-join-point binding, so it's okay to use - -- addManyOccsSet, which assumes no tail calls - | otherwise = usage1 - -tagNonRecBinder :: TopLevelFlag -- At top level? - -> UsageDetails -- Of scope - -> CoreBndr -- Binder - -> WithUsageDetails -- Details with binder removed - IdWithOccInfo -- Tagged binder - -tagNonRecBinder lvl usage binder - = let - occ = lookupDetails usage binder - will_be_join = decideJoinPointHood lvl usage (NE.singleton binder) - occ' | will_be_join = -- must already be marked AlwaysTailCalled - assert (isAlwaysTailCalled occ) occ - | otherwise = markNonTail occ - binder' = setBinderOcc occ' binder - usage' = usage `delDetails` binder - in - WithUsageDetails usage' binder' - -tagRecBinders :: TopLevelFlag -- At top level? - -> UsageDetails -- Of body of let ONLY - -> [NodeDetails] - -> WithUsageDetails -- Adjusted details for whole scope, - -- with binders removed - [IdWithOccInfo] -- Tagged binders --- Substantially more complicated than non-recursive case. Need to adjust RHS --- details *before* tagging binders (because the tags depend on the RHSes). -tagRecBinders lvl body_uds details_s - = let - bndrs = map nd_bndr details_s - - -- 1. See Note [Join arity prediction based on joinRhsArity] - -- Determine possible join-point-hood of whole group, by testing for - -- manifest join arity M. - -- This (re-)asserts that makeNode had made tuds for that same arity M! - unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s - test_manifest_arity ND{nd_rhs=WithTailUsageDetails tuds rhs} - = adjustTailArity (Just (joinRhsArity rhs)) tuds - - bndr_ne = expectNonEmpty "List of binders is never empty" bndrs - will_be_joins = decideJoinPointHood lvl unadj_uds bndr_ne - - mb_join_arity :: Id -> Maybe JoinArity - -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity] - -- This is the source O - mb_join_arity bndr - -- Can't use willBeJoinId_maybe here because we haven't tagged - -- the binder yet (the tag depends on these adjustments!) - | will_be_joins - , let occ = lookupDetails unadj_uds bndr - , AlwaysTailCalled arity <- tailCallInfo occ - = Just arity - | otherwise - = assert (not will_be_joins) -- Should be AlwaysTailCalled if - Nothing -- we are making join points! - - -- 2. Adjust usage details of each RHS, taking into account the - -- join-point-hood decision - rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs rhs_tuds -- matching occAnalLamTail in makeNode - | ND { nd_bndr = bndr, nd_rhs = WithTailUsageDetails rhs_tuds rhs } - <- details_s ] - - -- 3. Compute final usage details from adjusted RHS details - adj_uds = foldr andUDs body_uds rhs_udss' - - -- 4. Tag each binder with its adjusted details - bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr - | bndr <- bndrs ] - - -- 5. Drop the binders from the adjusted details and return - usage' = adj_uds `delDetailsList` bndrs - in - WithUsageDetails usage' bndrs' - -setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr -setBinderOcc occ_info bndr - | isTyVar bndr = bndr - | isExportedId bndr = if isManyOccs (idOccInfo bndr) - then bndr - else setIdOccInfo bndr noOccInfo - -- Don't use local usage info for visible-elsewhere things - -- BUT *do* erase any IAmALoopBreaker annotation, because we're - -- about to re-generate it and it shouldn't be "sticky" - - | otherwise = setIdOccInfo bndr occ_info - --- | Decide whether some bindings should be made into join points or not, based --- on its occurrences. This is --- Returns `False` if they can't be join points. Note that it's an --- all-or-nothing decision, as if multiple binders are given, they're --- assumed to be mutually recursive. --- --- It must, however, be a final decision. If we say `True` for 'f', --- and then subsequently decide /not/ make 'f' into a join point, then --- the decision about another binding 'g' might be invalidated if (say) --- 'f' tail-calls 'g'. --- --- See Note [Invariants on join points] in "GHC.Core". -decideJoinPointHood :: TopLevelFlag -> UsageDetails - -> NonEmpty CoreBndr - -> Bool -decideJoinPointHood TopLevel _ _ - = False -decideJoinPointHood NotTopLevel usage bndrs - | isJoinId (NE.head bndrs) - = warnPprTrace (not all_ok) - "OccurAnal failed to rediscover join point(s)" (ppr bndrs) - all_ok - | otherwise - = all_ok - where - -- See Note [Invariants on join points]; invariants cited by number below. - -- Invariant 2 is always satisfiable by the simplifier by eta expansion. - all_ok = -- Invariant 3: Either all are join points or none are - all ok bndrs - - ok bndr - | -- Invariant 1: Only tail calls, all same join arity - AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) - - , -- Invariant 1 as applied to LHSes of rules - all (ok_rule arity) (idCoreRules bndr) - - -- Invariant 2a: stable unfoldings - -- See Note [Join points and INLINE pragmas] - , ok_unfolding arity (realIdUnfolding bndr) - - -- Invariant 4: Satisfies polymorphism rule - , isValidJoinPointType arity (idType bndr) - = True - - | otherwise - = False - - ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans - ok_rule join_arity (Rule { ru_args = args }) - = args `lengthIs` join_arity - -- Invariant 1 as applied to LHSes of rules - - -- ok_unfolding returns False if we should /not/ convert a non-join-id - -- into a join-id, even though it is AlwaysTailCalled - ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) - = not (isStableSource src && join_arity > joinRhsArity rhs) - ok_unfolding _ (DFunUnfolding {}) - = False - ok_unfolding _ _ - = True - -willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity -willBeJoinId_maybe bndr - | isId bndr - , AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr) - = Just arity - | otherwise - = isJoinId_maybe bndr - - -{- Note [Join points and INLINE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = let g = \x. not -- Arity 1 - {-# INLINE g #-} - in case x of - A -> g True True - B -> g True False - C -> blah2 - -Here 'g' is always tail-called applied to 2 args, but the stable -unfolding captured by the INLINE pragma has arity 1. If we try to -convert g to be a join point, its unfolding will still have arity 1 -(since it is stable, and we don't meddle with stable unfoldings), and -Lint will complain (see Note [Invariants on join points], (2a), in -GHC.Core. #13413. - -Moreover, since g is going to be inlined anyway, there is no benefit -from making it a join point. - -If it is recursive, and uselessly marked INLINE, this will stop us -making it a join point, which is annoying. But occasionally -(notably in class methods; see Note [Instances and loop breakers] in -GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion -unravels; so ignoring INLINE pragmas on recursive things isn't good -either. - -See Invariant 2a of Note [Invariants on join points] in GHC.Core - - -************************************************************************ -* * -\subsection{Operations over OccInfo} -* * -************************************************************************ --} - -markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo - -markMany IAmDead = IAmDead -markMany occ = ManyOccs { occ_tail = occ_tail occ } - -markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam } -markInsideLam occ = occ - -markNonTail IAmDead = IAmDead -markNonTail occ = occ { occ_tail = NoTailCallInfo } - -addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo - -addOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $ - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } - -- Both branches are at least One - -- (Argument is never IAmDead) - --- (orOccInfo orig new) is used --- when combining occurrence info from branches of a case - -orOccInfo (OneOcc { occ_in_lam = in_lam1 - , occ_n_br = nbr1 - , occ_int_cxt = int_cxt1 - , occ_tail = tail1 }) - (OneOcc { occ_in_lam = in_lam2 - , occ_n_br = nbr2 - , occ_int_cxt = int_cxt2 - , occ_tail = tail2 }) - = OneOcc { occ_n_br = nbr1 + nbr2 - , occ_in_lam = in_lam1 `mappend` in_lam2 - , occ_int_cxt = int_cxt1 `mappend` int_cxt2 - , occ_tail = tail1 `andTailCallInfo` tail2 } - -orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $ - ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` - tailCallInfo a2 } +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-} + +{-# OPTIONS_GHC -fmax-worker-args=12 #-} +-- The -fmax-worker-args=12 is there because the main functions +-- are strict in the OccEnv, and it turned out that with the default settting +-- some functions would unbox the OccEnv ad some would not, depending on how +-- many /other/ arguments the function has. Inconsistent unboxing is very +-- bad for performance, so I increased the limit to allow it to unbox +-- consistently. + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[OccurAnal]{Occurrence analysis pass} +* * +************************************************************************ + +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. +-} + +module GHC.Core.Opt.OccurAnal ( + occurAnalysePgm, + occurAnalyseExpr, + zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, + mkCastMCo, mkTicks ) +import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo ) + +import GHC.Data.Maybe( orElse ) +import GHC.Data.Graph.Directed ( SCC(..), Node(..) + , stronglyConnCompFromEdgedVerticesUniq + , stronglyConnCompFromEdgedVerticesUniqR ) +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Demand ( argOneShots, argsOneShots, isDeadEndSig ) + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Builtin.Names( runRWKey ) +import GHC.Unit.Module( Module ) + +import Data.List (mapAccumL) +import Data.List.NonEmpty (NonEmpty (..)) + +{- +************************************************************************ +* * + occurAnalysePgm, occurAnalyseExpr +* * +************************************************************************ + +Here's the externally-callable interface: +-} + +-- | Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr :: CoreExpr -> CoreExpr +occurAnalyseExpr expr = expr' + where + WUD _ expr' = occAnal initOccEnv expr + +occurAnalysePgm :: Module -- Used only in debug output + -> (Id -> Bool) -- Active unfoldings + -> (Activation -> Bool) -- Active rules + -> [CoreRule] -- Local rules for imported Ids + -> CoreProgram -> CoreProgram +occurAnalysePgm this_mod active_unf active_rule imp_rules binds + | isEmptyDetails final_usage + = occ_anald_binds + + | otherwise -- See Note [Glomming] + = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage)) + occ_anald_glommed_binds + where + init_env = initOccEnv { occ_rule_act = active_rule + , occ_unf_act = active_unf } + + WUD final_usage occ_anald_binds = go binds init_env + WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel + imp_rule_edges + (flattenBinds binds) + initial_uds + -- It's crucial to re-analyse the glommed-together bindings + -- so that we establish the right loop breakers. Otherwise + -- we can easily create an infinite loop (#9583 is an example) + -- + -- Also crucial to re-analyse the /original/ bindings + -- in case the first pass accidentally discarded as dead code + -- a binding that was actually needed (albeit before its + -- definition site). #17724 threw this up. + + initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules) + -- The RULES declarations keep things alive! + + -- imp_rule_edges maps a top-level local binder 'f' to the + -- RHS free vars of any IMP-RULE, a local RULE for an imported function, + -- where 'f' appears on the LHS + -- e.g. RULE foldr f = blah + -- imp_rule_edges contains f :-> fvs(blah) + -- We treat such RULES as extra rules for 'f' + -- See Note [Preventing loops due to imported functions rules] + imp_rule_edges :: ImpRuleEdges + imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv + [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $ + exprsFreeIds args `delVarSetList` bndrs + | Rule { ru_act = act, ru_bndrs = bndrs + , ru_args = args, ru_rhs = rhs } <- imp_rules + -- Not BuiltinRules; see Note [Plugin rules] + , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ] + + go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind] + go [] _ = WUD initial_uds [] + go (bind:binds) env = occAnalBind env TopLevel + imp_rule_edges bind (go binds) (++) + +{- ********************************************************************* +* * + IMP-RULES + Local rules for imported functions +* * +********************************************************************* -} + +type ImpRuleEdges = IdEnv [(Activation, VarSet)] + -- Mapping from a local Id 'f' to info about its IMP-RULES, + -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS + -- We record (a) its Activation and (b) the RHS free vars + -- See Note [IMP-RULES: local rules for imported functions] + +noImpRuleEdges :: ImpRuleEdges +noImpRuleEdges = emptyVarEnv + +lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)] +lookupImpRules imp_rule_edges bndr + = case lookupVarEnv imp_rule_edges bndr of + Nothing -> [] + Just vs -> vs + +impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails +-- Variable mentioned in RHS of an IMP-RULE for the bndr, +-- whether active or not +impRulesScopeUsage imp_rules_info + = foldr add emptyDetails imp_rules_info + where + add (_,vs) usage = addManyOccs usage vs + +impRulesActiveFvs :: (Activation -> Bool) -> VarSet + -> [(Activation,VarSet)] -> VarSet +impRulesActiveFvs is_active bndr_set vs + = foldr add emptyVarSet vs `intersectVarSet` bndr_set + where + add (act,vs) acc | is_active act = vs `unionVarSet` acc + | otherwise = acc + +{- Note [IMP-RULES: local rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We quite often have + * A /local/ rule + * for an /imported/ function +like this: + foo x = blah + {-# RULE "map/foo" forall xs. map foo xs = xs #-} +We call them IMP-RULES. They are important in practice, and occur a +lot in the libraries. + +IMP-RULES are held in mg_rules of ModGuts, and passed in to +occurAnalysePgm. + +Main Invariant: + +* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS + just like a RULE for f. + +Note [IMP-RULES: unavoidable loops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Specialising imported functions] (referred to from Specialise) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [IMP-RULES: unavoidable +loops]. In particular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might not be +as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE RankNTypes #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB' +because it mentions 'filterFB' on the LHS. This is the Main Invariant +in Note [IMP-RULES: local rules for imported functions]. + +So, during loop-breaker analysis: + +- for each active RULE for a local function 'f' we add an edge between + 'f' and the local FVs of the rule RHS + +- for each active RULE for an *imported* function we add dependency + edges between the *local* FVS of the rule LHS and the *local* FVS of + the rule RHS. + +Even with this extra hack we aren't always going to get things +right. For example, it might be that the rule LHS mentions an imported +Id, and another module has a RULE that can rewrite that imported Id to +one of our local Ids. + +Note [Plugin rules] +~~~~~~~~~~~~~~~~~~~ +Conal Elliott (#11651) built a GHC plugin that added some +BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to +do some domain-specific transformations that could not be expressed +with an ordinary pattern-matching CoreRule. But then we can't extract +the dependencies (in imp_rule_edges) from ru_rhs etc, because a +BuiltinRule doesn't have any of that stuff. + +So we simply assume that BuiltinRules have no dependencies, and filter +them out from the imp_rule_edges comprehension. + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to +something at the bottom: + + foo = ...(B.f @Int)... + $sf = blah + RULE: B.f @Int = $sf + +Applying this rule makes foo refer to $sf, although foo doesn't appear to +depend on $sf. (And, as in Note [IMP-RULES: local rules for imported functions], the +dependency might be more indirect. For example, foo might mention C.t +rather than B.f, where C.t eventually inlines to B.f.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.f in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +This is a legitimate situation where the need for glomming doesn't +point to any problems. However, when GHC is compiled with -DDEBUG, we +produce a warning addressed to the GHC developers just in case we +require glomming due to an out-of-order reference that is caused by +some earlier transformation stage misbehaving. +-} + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ + +Note [Recursive bindings: the grand plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. We +avoid infinite inlinings by choosing loop breakers, and ensuring that +a loop breaker cuts each loop. + +See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which +deals with a closely related source of infinite loops. + +When we come across a binding group + Rec { x1 = r1; ...; xn = rn } +we treat it like this (occAnalRecBind): + +1. Note [Forming Rec groups] + Occurrence-analyse each right hand side, and build a + "Details" for each binding to capture the results. + Wrap the details in a LetrecNode, ready for SCC analysis. + All this is done by makeNode. + + The edges of this graph are the "scope edges". + +2. Do SCC-analysis on these Nodes: + - Each CyclicSCC will become a new Rec + - Each AcyclicSCC will become a new NonRec + + The key property is that every free variable of a binding is + accounted for by the scope edges, so that when we are done + everything is still in scope. + +3. For each AcyclicSCC, just make a NonRec binding. + +4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we + identify suitable loop-breakers to ensure that inlining terminates. + This is done by occAnalRec. + + To do so, form the loop-breaker graph, do SCC analysis. For each + CyclicSCC we choose a loop breaker, delete all edges to that node, + re-analyse the SCC, and iterate. See Note [Choosing loop breakers] + for the details + + +Note [Dead code] +~~~~~~~~~~~~~~~~ +Dropping dead code for a cyclic Strongly Connected Component is done +in a very simple way: + + the entire SCC is dropped if none of its binders are mentioned + in the body; otherwise the whole thing is kept. + +The key observation is that dead code elimination happens after +dependency analysis: so 'occAnalBind' processes SCCs instead of the +original term's binding groups. + +Thus 'occAnalBind' does indeed drop 'f' in an example like + + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in +'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes +'AcyclicSCC f', where 'body_usage' won't contain 'f'. + +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The key point about the "Forming Rec groups" step is that it /preserves +scoping/. If 'x' is mentioned, it had better be bound somewhere. So if +we start with + Rec { f = ...h... + ; g = ...f... + ; h = ...f... } +we can split into SCCs + Rec { f = ...h... + ; h = ..f... } + NonRec { g = ...f... } + +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g +uses f", no matter how indirectly. We do a SCC analysis with an edge +f -> g if "f mentions g". That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f, whether active or inactive + Note [Rules are extra RHSs] + c) or the LHS or a rule for f, whether active or inactive + Note [Rule dependency info] + d) the RHS of an /active/ local IMP-RULE + Note [IMP-RULES: local rules for imported functions] + +(b) and (c) apply regardless of the activation of the RULE, because even if +the rule is inactive its free variables must be bound. But (d) doesn't need +to worry about this because IMP-RULES are always notionally at the bottom +of the file. + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + So in Example [eftInt], eftInt and eftIntFB will be put in the + same Rec, even though their 'main' RHSs are both non-recursive. + + We must also include inactive rules, so that their free vars + remain in scope. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a RuleInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Note [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + +Note [TailUsageDetails when forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is +computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`. +That is because the binding might still become a *non-recursive join point* in +the AcyclicSCC case of dependency analysis! +Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get +a regular, adjusted UsageDetails. +See Note [Join points and unfoldings/rules] for more details on the contract. + +Note [Stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to a stable unfolding +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. +Hence the transitive rule_fv_env stuff described in +Note [Rules and loop breakers]. + +Note [Occurrence analysis for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two somewhat artificial programs (#22404) + + Program (P1) Program (P2) + ------------------------------ ------------------------------------- + let v = in let v = in + join j = case v of (a,b) -> a + in case x of in case x of + A -> case v of (a,b) -> a A -> j + B -> case v of (a,b) -> a B -> j + C -> case v of (a,b) -> b C -> case v of (a,b) -> b + D -> [] D -> [] + +In (P1), `v` gets allocated, as a thunk, every time this code is executed. But +notice that `v` occurs at most once in any case branch; the occurrence analyser +spots this and returns a OneOcc{ occ_n_br = 3 } for `v`. Then the code in +GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three +use sites, and discards the let-binding. That way, we avoid allocating `v` in +the A,B,C branches (though we still compute it of course), and branch D +doesn't involve at all. This sometimes makes a Really Big +Difference. + +In (P2) we have shared the common RHS of A, B, in a join point `j`. We would +like to inline `v` in just the same way as in (P1). But the usual strategy +for let bindings is conservative and uses `andUDs` to combine usage from j's +RHS to its body; as if `j` was called on every code path (once, albeit). In +the case of (P2), we'll get ManyOccs for `v`. Important optimisation lost! + +Solving this problem makes the Simplifier less fragile. For example, +the Simplifier might inline `j`, and convert (P2) into (P1)... or it might +not, depending in a perhaps-fragile way on the size of the join point. +I was motivated to implement this feature of the occurrence analyser +when trying to make optimisation join points simpler and more robust +(see e.g. #23627). + +The occurrence analyser therefore has clever code that behaves just as +if you inlined `j` at all its call sites. Here is a tricky variant +to keep in mind: + + Program (P3) + ------------------------------- + join j = case v of (a,b) -> a + in case f v of + A -> j + B -> j + C -> [] + +If you mentally inline `j` you'll see that `v` is used twice on the path +through A, so it should have ManyOcc. Bear this case in mind! + +* We treat /non-recursive/ join points specially. Recursive join points are + treated like any other letrec, as before. Moreover, we only give this special + treatment to /pre-existing/ non-recursive join points, not the ones that we + discover for the first time in this sweep of the occurrence analyser. + +* In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps + each in-scope non-recursive join point, such as `j` above, to + a "zeroed form" of its RHS's usage details. The "zeroed form" + * deletes ManyOccs + * maps a OneOcc to OneOcc{ occ_n_br = 0 } + In our example, occ_join_points will be extended with + [j :-> [v :-> OneOcc{occ_n_br=0}]] + See addJoinPoint. + +* At an occurrence of a join point, we do everything as normal, but add in the + UsageDetails from the occ_join_points. See mkOneOcc. + +* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use + `orUDs`, not `andUDs` to combine the usage from the RHS with the usage from + the body. + +Here are the consequences + +* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed + form, the occ_n_br field of a OneOcc binder still counts the number of + /actual lexical occurrences/ of the variable. In Program P2, for example, + `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3. + There are two lexical occurrences of `v`! + (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.) + +* In the tricky (P3) we'll get an `andUDs` of + * OneOcc{occ_n_br=0} from the occurrences of `j`) + * OneOcc{occ_n_br=1} from the (f v) + These are `andUDs` together in `addOccInfo`, and hence + `v` gets ManyOccs, just as it should. Clever! + +There are a couple of tricky wrinkles + +(W1) Consider this example which shadows `j`: + join j = rhs in + in case x of { K j -> ..j..; ... } + Clearly when we come to the pattern `K j` we must drop the `j` + entry in occ_join_points. + + This is done by `drop_shadowed_joins` in `addInScope`. + +(W2) Consider this example which shadows `v`: + join j = ...v... + in case x of { K v -> ..j..; ... } + + We can't make j's occurrences in the K alternative give rise to an + occurrence of `v` (via occ_join_points), because it'll just be deleted by + the `K v` pattern. Yikes. This is rare because shadowing is rare, but + it definitely can happen. Solution: when bringing `v` into scope at + the `K v` pattern, chuck out of occ_join_points any elements whose + UsageDetails mentions `v`. Instead, just `andUDs` all that usage in + right here. + + This requires work in two places. + * In `preprocess_env`, we detect if the newly-bound variables intersect + the free vars of occ_join_points. (These free vars are conveniently + simply the domain of the OccInfoEnv for that join point.) If so, + we zap the entire occ_join_points. + * In `postprcess_uds`, we add the chucked-out join points to the + returned UsageDetails, with `andUDs`. + +(W3) Consider this example, which shadows `j`, but this time in an argument + join j = rhs + in f (case x of { K j -> ...; ... }) + We can zap the entire occ_join_points when looking at the argument, + because `j` can't posibly occur -- it's a join point! And the smaller + occ_join_points is, the better. Smaller to look up in mkOneOcc, and + more important, less looking-up when checking (W2). + + This is done in setNonTailCtxt. It's important /not/ to do this for + join-point RHS's because of course `j` can occur there! + + NB: this is just about efficiency: it is always safe /not/ to zap the + occ_join_points. + +(W4) What if the join point binding has a stable unfolding, or RULES? + They are just alternative right-hand sides, and at each call site we + will use only one of them. So again, we can use `orUDs` to combine + usage info from all these alternatives RHSs. + +Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3). + +Note [Finding join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's the occurrence analyser's job to find bindings that we can turn into join +points, but it doesn't perform that transformation right away. Rather, it marks +the eligible bindings as part of their occurrence data, leaving it to the +simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. +The simplifier then eta-expands the RHS if needed and then updates the +occurrence sites. Dividing the work this way means that the occurrence analyser +still only takes one pass, yet one can always tell the difference between a +function call and a jump by looking at the occurrence (because the same pass +changes the 'IdDetails' and propagates the binders to their occurrence sites). + +To track potential join points, we use the 'occ_tail' field of OccInfo. A value +of `AlwaysTailCalled n` indicates that every occurrence of the variable is a +tail call with `n` arguments (counting both value and type arguments). Otherwise +'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the +rest of 'OccInfo' until it goes on the binder. + +Note [Join arity prediction based on joinRhsArity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, the join arity from tail occurrences of a join point (O) may be +higher or lower than the manifest join arity of the join body (M). E.g., + + -- M > O: + let f x y = x + y -- M = 2 + in if b then f 1 else f 2 -- O = 1 + ==> { Contify for join arity 1 } + join f x = \y -> x + y + in if b then jump f 1 else jump f 2 + + -- M < O + let f = id -- M = 0 + in if ... then f 12 else f 13 -- O = 1 + ==> { Contify for join arity 1, eta-expand f } + join f x = id x + in if b then jump f 12 else jump f 13 + +But for *recursive* let, it is crucial that both arities match up, consider + + letrec f x y = if ... then f x else True + in f 42 + +Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump +would not happen in a tail context! Contification is invalid here. +So indeed it is crucial to demand that M=O. + +(Side note: Actually, we could be more specific: Let O1 be the join arity of +occurrences from the letrec RHS and O2 the join arity from the let body. Then +we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later. +M=O is the specific case where we don't want to eta-expand. Neither the join +points paper nor GHC does this at the moment.) + +We can capitalise on this observation and conclude that *if* f could become a +joinrec (without eta-expansion), it will have join arity M. +Now, M is just the result of 'joinRhsArity', a rather simple, local analysis. +It is also the join arity inside the 'TailUsageDetails' returned by +'occAnalLamTail', so we can predict join arity without doing any fixed-point +iteration or really doing any deep traversal of let body or RHS at all. +We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'. + +All this is quite apparent if you look at the contification transformation in +Fig. 5 of "Compiling without Continuations" (which does not account for +eta-expansion at all, mind you). The letrec case looks like this + + letrec f = /\as.\xs. L[us] in L'[es] + ... and a bunch of conditions establishing that f only occurs + in app heads of join arity (len as + len xs) inside us and es ... + +The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However, +for non-recursive functions, this is the definition of contification from the +paper: + + let f = /\as.\xs.u in L[es] ... conditions ... + +Note that u could be a lambda itself, as we have seen. No relationship between M +and O to exploit here. + +Note [Join points and unfoldings/rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let j2 y = blah + let j x = j2 (x+x) + {-# INLINE [2] j #-} + in case e of { A -> j 1; B -> ...; C -> j 2 } + +Before j is inlined, we'll have occurrences of j2 in +both j's RHS and in its stable unfolding. We want to discover +j2 as a join point. So 'occAnalUnfolding' returns an unadjusted +'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the +unfolding to the actual join arity using the same 'adjustTailArity' as for +the RHS, see Note [Adjusting right-hand sides]. + +Same with rules. Suppose we have: + + let j :: Int -> Int + j y = 2 * y + let k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 y = j y #-} + k x y = x + 2 * y + in case e of { A -> k 1 2; B -> k 3 5; C -> blah } + +We identify k as a join point, and we want j to be a join point too. +Without the RULE it would be, and we don't want the RULE to mess it +up. So provided the join-point arity of k matches the args of the +rule we can allow the tail-call info from the RHS of the rule to +propagate. + +* Note that the join arity of the RHS and that of the unfolding or RULE might + mismatch: + + let j x y = j2 (x+x) + {-# INLINE[2] j = \x. g #-} + {-# RULE forall x y z. j x y z = h 17 #-} + in j 1 2 + + So it is crucial that we adjust each TailUsageDetails individually + with the actual join arity 2 here before we combine with `andUDs`. + Here, that means losing tail call info on `g` and `h`. + +* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for + RHS, unfolding and RULE combined. Clearly, if they don't agree on their join + arity, we have to do some adjusting. We choose to adjust to the join arity + of the RHS, because that is likely the join arity that the join point will + have; see Note [Join arity prediction based on joinRhsArity]. + + If the guess is correct, then tail calls in the RHS are preserved; a necessary + condition for the whole binding becoming a joinrec. + The guess can only be incorrect in the 'AcyclicSCC' case when the binding + becomes a non-recursive join point with a different join arity. But then the + eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will + be with a different join arity and destroy unsound tail call info with + 'markNonTail'. + +* Wrinkle for RULES. Suppose the example was a bit different: + let j :: Int -> Int + j y = 2 * y + k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 = j #-} + k x y = x + 2 * y + in ... + If we eta-expanded the rule all would be well, but as it stands the + one arg of the rule don't match the join-point arity of 2. + + Conceivably we could notice that a potential join point would have + an "undersaturated" rule and account for it. This would mean we + could make something that's been specialised a join point, for + instance. But local bindings are rarely specialised, and being + overly cautious about rules only costs us anything when, for some `j`: + + * Before specialisation, `j` has non-tail calls, so it can't be a join point. + * During specialisation, `j` gets specialised and thus acquires rules. + * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), + and so now `j` *could* become a join point. + + This appears to be very rare in practice. TODO Perhaps we should gather + statistics to be sure. + +------------------------------------------------------------ +Note [Adjusting right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a dance we need to do after analysing a lambda expression or +a right-hand side. In particular, we need to + + a) call 'markAllNonTail' *unless* the binding is for a join point, and + the TailUsageDetails from the RHS has the right join arity; e.g. + join j x y = case ... of + A -> j2 p + B -> j2 q + in j a b + Here we want the tail calls to j2 to be tail calls of the whole expression + b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot + lambda, or a non-recursive join point + +Some examples, with how the free occurrences in e (assumed not to be a value +lambda) get marked: + + inside lam non-tail-called + ------------------------------------------------------------ + let x = e No Yes + let f = \x -> e Yes Yes + let f = \x{OneShot} -> e No Yes + \x -> e Yes Yes + join j x = e No No + joinrec j x = e Yes No + +There are a few other caveats; most importantly, if we're marking a binding as +'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so +that the effect cascades properly. Consequently, at the time the RHS is +analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must +return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage' +once join-point-hood has been decided and eventual one-shot annotations have +been added through 'markNonRecJoinOneShots'. + +It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed +perform a similar sequence of steps. Thus, here is an interleaving of events +of both functions, serving as a specification: + + 1. Call 'occAnalLamTail' to find usage information for the RHS. + Recursive case: 'makeNode' + Non-recursive case: 'occAnalNonRecBind' + 2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`. + Same whether recursive or not.) + 3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make + the binding a join point. + Cyclic Recursive case: 'mkLoopBreakerNodes' + Acyclic Recursive case: `occAnalRec AcyclicSCC{}` + Non-recursive case: 'occAnalNonRecBind' + 4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g., + FloatOut sees one-shot annotations on lambdas + Acyclic Recursive case: `occAnalRec AcyclicSCC{}` calls 'adjustNonRecRhs' + Non-recursive case: 'occAnalNonRecBind' calls 'adjustNonRecRhs' + 5. Call 'adjustTailUsage' accordingly. + Cyclic Recursive case: 'tagRecBinders' + Acyclic Recursive case: 'adjustNonRecRhs' + Non-recursive case: 'adjustNonRecRhs' +-} + +------------------------------------------------------------------ +-- occAnalBind +------------------------------------------------------------------ + +occAnalBind + :: OccEnv + -> TopLevelFlag + -> ImpRuleEdges + -> CoreBind + -> (OccEnv -> WithUsageDetails r) -- Scope of the bind + -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds + -> WithUsageDetails r -- Of the whole let(rec) + +occAnalBind env lvl ire (Rec pairs) thing_inside combine + = addInScopeList env (map fst pairs) $ \env -> + let WUD body_uds body' = thing_inside env + WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds + in WUD bind_uds (combine binds' body') + +occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine + | isTyVar bndr -- A type let; we don't gather usage info + = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside + in WUD body_uds (combine [NonRec bndr rhs] res) + + -- /Existing/ non-recursive join points + -- See Note [Occurrence analysis for join points] + | mb_join@(JoinPoint {}) <- idJoinPointHood bndr + = -- Analyse the RHS and /then/ the body + let -- Analyse the rhs first, generating rhs_uds + !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs + rhs_uds = foldr1 orUDs rhs_uds_s -- NB: orUDs. See (W4) of + -- Note [Occurrence analysis for join points] + + -- Now analyse the body, adding the join point + -- into the environment with addJoinPoint + !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env -> + thing_inside (addJoinPoint env bndr' rhs_uds) + in + if isDeadOcc occ -- Drop dead code; see Note [Dead code] + then WUD body_uds body + else WUD (rhs_uds `orUDs` body_uds) -- Note `orUDs` + (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs'] + body) + + -- The normal case, including newly-discovered join points + -- Analyse the body and /then/ the RHS + | WUD body_uds (occ,body) <- occAnalNonRecBody env bndr thing_inside + = if isDeadOcc occ -- Drop dead code; see Note [Dead code] + then WUD body_uds body + else let + -- Get the join info from the *new* decision; NB: bndr is not already a JoinId + -- See Note [Join points and unfoldings/rules] + -- => join arity O of Note [Join arity prediction based on joinRhsArity] + (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr + + !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs + in WUD (foldr andUDs body_uds rhs_uds_s) -- Note `andUDs` + (combine [NonRec final_bndr rhs'] body) + +----------------- +occAnalNonRecBody :: OccEnv -> Id + -> (OccEnv -> WithUsageDetails r) -- Scope of the bind + -> (WithUsageDetails (OccInfo, r)) +occAnalNonRecBody env bndr thing_inside + = addInScopeOne env bndr $ \env -> + let !(WUD inner_uds res) = thing_inside env + !occ = lookupLetOccInfo inner_uds bndr + in WUD inner_uds (occ, res) + +----------------- +occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges + -> JoinPointHood -> Id -> CoreExpr + -> (NonEmpty UsageDetails, Id, CoreExpr) +occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs + | null rules, null imp_rule_infos + = -- Fast path for common case of no rules. This is only worth + -- 0.1% perf on average, but it's also only a line or two of code + ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs ) + | otherwise + = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs ) + where + --------- Right hand side --------- + -- For join points, set occ_encl to OccVanilla, via setTailCtxt. If we have + -- join j = Just (f x) in ... + -- we do not want to float the (f x) to + -- let y = f x in join j = Just y in ... + -- That's that OccRhs would do; but there's no point because + -- j will never be scrutinised. + rhs_env = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs + rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf + + -- See Note [Join arity prediction based on joinRhsArity] + -- Match join arity O from mb_join_arity with manifest join arity M as + -- returned by of occAnalLamTail. It's totally OK for them to mismatch; + -- hence adjust the UDs from the RHS + WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $ + occAnalLamTail rhs_env rhs + final_bndr_with_rules + | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] + | otherwise = bndr `setIdSpecialisation` mkRuleInfo rules' + `setIdUnfolding` unf1 + final_bndr_no_rules + | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] + | otherwise = bndr `setIdUnfolding` unf1 + + --------- Unfolding --------- + -- See Note [Join points and unfoldings/rules] + unf = idUnfolding bndr + WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf + adj_unf_uds = adjustTailArity mb_join unf_tuds + + --------- Rules --------- + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + -- and Note [Join points and unfoldings/rules] + rules = idCoreRules bndr + rules_w_uds = map (occAnalRule rhs_env) rules + rules' = map fstOf3 rules_w_uds + imp_rule_infos = lookupImpRules imp_rule_edges bndr + imp_rule_uds = [impRulesScopeUsage imp_rule_infos] + -- imp_rule_uds: consider + -- h = ... + -- g = ... + -- RULE map g = h + -- Then we want to ensure that h is in scope everywhere + -- that g is (since the RULE might turn g into h), so + -- we make g mention h. + + adj_rule_uds :: [UsageDetails] + adj_rule_uds = imp_rule_uds ++ + [ l `andUDs` adjustTailArity mb_join r + | (_,l,r) <- rules_w_uds ] + +mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl +-- Precondition: Id is not a join point +mkNonRecRhsCtxt lvl bndr unf + | certainly_inline = OccVanilla -- See Note [Cascading inlines] + | otherwise = OccRhs + where + certainly_inline -- See Note [Cascading inlines] + = -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind + -- has set the OccInfo for this binder before calling occAnalNonRecRhs + case idOccInfo bndr of + OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 } + -> active && not stable_unf && not top_bottoming + _ -> False + + active = isAlwaysActive (idInlineActivation bndr) + stable_unf = isStableUnfolding unf + top_bottoming = isTopLevel lvl && isDeadEndId bndr + +----------------- +occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] + -> UsageDetails -> WithUsageDetails [CoreBind] +-- For a recursive group, we +-- * occ-analyse all the RHSs +-- * compute strongly-connected components +-- * feed those components to occAnalRec +-- See Note [Recursive bindings: the grand plan] +occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage + = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs + where + sccs :: [SCC NodeDetails] + sccs = stronglyConnCompFromEdgedVerticesUniq nodes + + nodes :: [LetrecNode] + nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs + + bndrs = map fst pairs + bndr_set = mkVarSet bndrs + +----------------------------- +occAnalRec :: OccEnv -> TopLevelFlag + -> SCC NodeDetails + -> WithUsageDetails [CoreBind] + -> WithUsageDetails [CoreBind] + +-- The NonRec case is just like a Let (NonRec ...) above +occAnalRec !_ lvl + (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) + (WUD body_uds binds) + | isDeadOcc occ -- Check for dead code: see Note [Dead code] + = WUD body_uds binds + | otherwise + = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr + !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds + in WUD (body_uds `andUDs` rhs_uds') + (NonRec bndr' rhs' : binds) + where + occ = lookupLetOccInfo body_uds bndr + +-- The Rec case is the interesting one +-- See Note [Recursive bindings: the grand plan] +-- See Note [Loop breaking] +occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds) + | not (any needed details_s) + = -- Check for dead code: see Note [Dead code] + -- NB: Only look at body_uds, ignoring uses in the SCC + WUD body_uds binds + + | otherwise + = WUD final_uds (Rec pairs : binds) + where + all_simple = all nd_simple details_s + + needed :: NodeDetails -> Bool + needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env + body_env = ud_env body_uds + + ------------------------------ + -- Make the nodes for the loop-breaker analysis + -- See Note [Choosing loop breakers] for loop_breaker_nodes + final_uds :: UsageDetails + loop_breaker_nodes :: [LoopBreakerNode] + WUD final_uds loop_breaker_nodes = mkLoopBreakerNodes env lvl body_uds details_s + + ------------------------------ + weak_fvs :: VarSet + weak_fvs = mapUnionVarSet nd_weak_fvs details_s + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | all_simple = reOrderNodes 0 weak_fvs loop_breaker_nodes [] + | otherwise = loopBreakNodes 0 weak_fvs loop_breaker_nodes [] + -- In the common case when all are "simple" (no rules at all) + -- the loop_breaker_nodes will include all the scope edges + -- so a SCC computation would yield a single CyclicSCC result; + -- and reOrderNodes deals with exactly that case. + -- Saves a SCC analysis in a common case + + +{- ********************************************************************* +* * + Loop breaking +* * +********************************************************************* -} + +{- Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does +loop-breaking on each CyclicSCC of the original program: + +* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC + +* loopBreakNodes: Do SCC analysis on it + +* reOrderNodes: For each CyclicSCC, pick a loop breaker + * Delete edges to that loop breaker + * Do another SCC analysis on that reduced SCC + * Repeat + +To form the loop-breaker graph, we construct a new set of Nodes, the +"loop-breaker nodes", with the same details but different edges, the +"loop-breaker edges". The loop-breaker nodes have both more and fewer +dependencies than the scope edges: + + More edges: + If f calls g, and g has an active rule that mentions h then + we add an edge from f -> h. See Note [Rules and loop breakers]. + + Fewer edges: we only include dependencies + * only on /active/ rules, + * on rule /RHSs/ (not LHSs) + +The scope edges, by contrast, must be much more inclusive. + +The nd_simple flag tracks the common case when a binding has no RULES +at all, in which case the loop-breaker edges will be identical to the +scope edges. + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note [inl_fvs] +~~~~~~~~~~~~~~ +Note that the loop-breaker graph includes edges for occurrences in +/both/ the RHS /and/ the stable unfolding. Consider this, which actually +occurred when compiling BooleanFormula.hs in GHC: + + Rec { lvl1 = go + ; lvl2[StableUnf = go] = lvl1 + ; go = ...go...lvl2... } + +From the point of view of infinite inlining, we need only these edges: + lvl1 :-> go + lvl2 :-> go -- The RHS lvl1 will never be used for inlining + go :-> go, lvl2 + +But the danger is that, lacking any edge to lvl1, we'll put it at the +end thus + Rec { lvl2[ StableUnf = go] = lvl1 + ; go[LoopBreaker] = ...go...lvl2... } + ; lvl1[Occ=Once] = go } + +And now the Simplifer will try to use PreInlineUnconditionally on lvl1 +(which occurs just once), but because it is last we won't actually +substitute in lvl2. Sigh. + +To avoid this possibility, we include edges from lvl2 to /both/ its +stable unfolding /and/ its RHS. Hence the defn of inl_fvs in +makeNode. Maybe we could be more clever, but it's very much a corner +case. + +Note [Weak loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... } + +Remember that we simplify the RULES before any RHS (see Note +[Rules are visible in their own rec group] above). + +So we must *not* postInlineUnconditionally 'g', even though +its RHS turns out to be trivial. (I'm assuming that 'g' is +not chosen as a loop breaker.) Why not? Because then we +drop the binding for 'g', which leaves it out of scope in the +RULE! + +Here's a somewhat different example of the same thing + Rec { q = r + ; r = ...p... + ; p = p_rhs + RULE p [] = q } +Here the RULE is "below" q, but we *still* can't postInlineUnconditionally +q, because the RULE for p is active throughout. So the RHS of r +might rewrite to r = ...q... +So q must remain in scope in the output program! + +We "solve" this by: + + Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff q is a mentioned in the RHS of any RULE (active on not) + in the Rec group + +Note the "active or not" comment; even if a RULE is inactive, we +want its RHS free vars to stay alive (#20820)! + +A normal "strong" loop breaker has IAmLoopBreaker False. So: + + Inline postInlineUnconditionally +strong IAmLoopBreaker False no no +weak IAmLoopBreaker True yes no + other yes yes + +The **sole** reason for this kind of loop breaker is so that +postInlineUnconditionally does not fire. Ugh. + +Annoyingly, since we simplify the rules *first* we'll never inline +q into p's RULE. That trivial binding for q will hang around until +we discard the rule. Yuk. But it's rare. + +Note [Rules and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we form the loop-breaker graph (Step 4 in Note [Recursive +bindings: the grand plan]), we must be careful about RULEs. + +For a start, we want a loop breaker to cut every cycle, so inactive +rules play no part; we need only consider /active/ rules. +See Note [Finding rule RHS free vars] + +The second point is more subtle. A RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in GHC.Core.Opt.Simplify + +Hence, if + f's RHS (or its stable unfolding if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. So our plan is this: + + Take the free variables of f's RHS, and augment it with all the + variables reachable by a transitive sequence RULES from those + starting points. + +That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes. +Wrinkles: + +* We only consider /active/ rules. See Note [Finding rule RHS free vars] + +* We need only consider free vars that are also binders in this Rec + group. See also Note [Finding rule RHS free vars] + +* We only consider variables free in the *RHS* of the rule, in + contrast to the way we build the Rec group in the first place (Note + [Rule dependency info]) + +* Why "transitive sequence of rules"? Because active rules apply + unconditionally, without checking loop-breaker-ness. + See Note [Loop breaker dependencies]. + +Note [Finding rule RHS free vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} +So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. +However, tagZero can only be inlined in phase 1 and later, while +the RULE is only active *before* phase 1. So there's no problem. + +To make this work, we look for the RHS free vars only for +*active* rules. That's the reason for the occ_rule_act field +of the OccEnv. + +Note [loopBreakNodes] +~~~~~~~~~~~~~~~~~~~~~ +loopBreakNodes is applied to the list of nodes for a cyclic strongly +connected component (there's guaranteed to be a cycle). It returns +the same nodes, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma + +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. +-} + +type Binding = (Id,CoreExpr) + +-- See Note [loopBreakNodes] +loopBreakNodes :: Int + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [LoopBreakerNode] + -> [Binding] -- Append these to the end + -> [Binding] + +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +-- See Note [loopBreakNodes] +loopBreakNodes depth weak_fvs nodes binds + = -- pprTrace "loopBreakNodes" (ppr nodes) $ + go (stronglyConnCompFromEdgedVerticesUniqR nodes) + where + go [] = binds + go (scc:sccs) = loop_break_scc scc (go sccs) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds + CyclicSCC nodes -> reOrderNodes depth weak_fvs nodes binds + +---------------------------------- +reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- and call loopBreakNodes on the rest +reOrderNodes _ _ [] _ = panic "reOrderNodes" +reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds +reOrderNodes depth weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen + -- , text "chosen" <+> ppr chosen_nodes ]) $ + loopBreakNodes new_depth weak_fvs unchosen $ + (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds) + where + (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb + (snd_score (node_payload node)) + [node] [] nodes + + approximate_lb = depth >= 2 + new_depth | approximate_lb = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 + +nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding +nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs}) + = (set_id_occ bndr, rhs) + +mk_loop_breaker :: Id -> Id +mk_loop_breaker bndr + = bndr `setIdOccInfo` occ' + where + occ' = strongLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +mk_non_loop_breaker :: VarSet -> Id -> Id +-- See Note [Weak loop breakers] +mk_non_loop_breaker weak_fvs bndr + | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ' + | otherwise = bndr + where + occ' = weakLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +---------------------------------- +chooseLoopBreaker :: Bool -- True <=> Too many iterations, + -- so approximate + -> NodeScore -- Best score so far + -> [LoopBreakerNode] -- Nodes with this score + -> [LoopBreakerNode] -- Nodes with higher scores + -> [LoopBreakerNode] -- Unprocessed nodes + -> ([LoopBreakerNode], [LoopBreakerNode]) + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in +chooseLoopBreaker _ _ loop_nodes acc [] + = (loop_nodes, acc) -- Done + + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] +chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) + | approx_lb + , rank sc == rank loop_sc + = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes + + | sc `betterLB` loop_sc -- Better score so pick this new one + = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes + + | otherwise -- Worse score so don't pick it + = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes + where + sc = snd_score (node_payload node) + +{- +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakers is +linear in the number of instance declarations. + +Note [Loop breakers and INLINE/INLINABLE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Avoid choosing a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +It's vital to distinguish between INLINE and INLINABLE (the +Bool returned by hasStableCoreUnfolding_maybe). If we start with + Rec { {-# INLINABLE f #-} + f x = ...f... } +and then worker/wrapper it through strictness analysis, we'll get + Rec { {-# INLINABLE $wf #-} + $wf p q = let x = (p,q) in ...f... + + {-# INLINE f #-} + f x = case x of (p,q) -> $wf p q } + +Now it is vital that we choose $wf as the loop breaker, so we can +inline 'f' in '$wf'. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-loop breaker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. + +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. + + +@occAnalUnfolding@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that this +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. + + +************************************************************************ +* * + Making nodes +* * +************************************************************************ +-} + +-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'. +-- The Unique key is gotten from the Id. +type LetrecNode = Node Unique NodeDetails + +-- | Node details as consumed by 'occAnalRec'. +data NodeDetails + = ND { nd_bndr :: Id -- Binder + + , nd_rhs :: !(WithTailUsageDetails CoreExpr) + -- ^ RHS, already occ-analysed + -- With TailUsageDetails from RHS, and RULES, and stable unfoldings, + -- ignoring phase (ie assuming all are active). + -- NB: Unadjusted TailUsageDetails, as if this Node becomes a + -- non-recursive join point! + -- See Note [TailUsageDetails when forming Rec groups] + + , nd_inl :: IdSet -- Free variables of the stable unfolding and the RHS + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , nd_simple :: Bool -- True iff this binding has no local RULES + -- If all nodes are simple we don't need a loop-breaker + -- dep-anal before reconstructing. + + , nd_weak_fvs :: IdSet -- Variables bound in this Rec group that are free + -- in the RHS of any rule (active or not) for this bndr + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Variables bound in this Rec group that are free + -- in the RHS of an active rule for this bndr + -- See Note [Rules and loop breakers] + } + +instance Outputable NodeDetails where + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr uds + , text "inl =" <+> ppr (nd_inl nd) + , text "simple =" <+> ppr (nd_simple nd) + , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd) + ]) + where + WTUD uds _ = nd_rhs nd + +-- | Digraph with simplified and completely occurrence analysed +-- 'SimpleNodeDetails', retaining just the info we need for breaking loops. +type LoopBreakerNode = Node Unique SimpleNodeDetails + +-- | Condensed variant of 'NodeDetails' needed during loop breaking. +data SimpleNodeDetails + = SND { snd_bndr :: IdWithOccInfo -- OccInfo accurate + , snd_rhs :: CoreExpr -- properly occur-analysed + , snd_score :: NodeScore + } + +instance Outputable SimpleNodeDetails where + ppr nd = text "SND" <> braces + (sep [ text "bndr =" <+> ppr (snd_bndr nd) + , text "score =" <+> ppr (snd_score nd) + ]) + +-- The NodeScore is compared lexicographically; +-- e.g. lower rank wins regardless of size +type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker + , Int -- Size of rhs: higher => more likely to be picked as LB + -- Maxes out at maxExprSize; we just use it to prioritise + -- small functions + , Bool ) -- Was it a loop breaker before? + -- True => more likely to be picked + -- Note [Loop breakers, node scoring, and stability] + +rank :: NodeScore -> Int +rank (r, _, _) = r + +makeNode :: OccEnv -> ImpRuleEdges -> VarSet + -> (Var, CoreExpr) -> LetrecNode +-- See Note [Recursive bindings: the grand plan] +makeNode !env imp_rule_edges bndr_set (bndr, rhs) + = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $ + DigraphNode { node_payload = details + , node_key = varUnique bndr + , node_dependencies = nonDetKeysUniqSet scope_fvs } + -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR + -- is still deterministic with edges in nondeterministic order as + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + details = ND { nd_bndr = bndr' + , nd_rhs = WTUD (TUD rhs_ja unadj_scope_uds) rhs' + , nd_inl = inl_fvs + , nd_simple = null rules_w_uds && null imp_rule_info + , nd_weak_fvs = weak_fvs + , nd_active_rule_fvs = active_rule_fvs } + + bndr' | noBinderSwaps env = bndr -- See Note [Unfoldings and rules] + | otherwise = bndr `setIdUnfolding` unf' + `setIdSpecialisation` mkRuleInfo rules' + + -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the + -- JoinArity rhs_ja of unadj_rhs_uds. + unadj_inl_uds = unadj_rhs_uds `andUDs` adj_unf_uds + unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + scope_fvs = udFreeVars bndr_set unadj_scope_uds + -- scope_fvs: all occurrences from this binder: RHS, unfolding, + -- and RULES, both LHS and RHS thereof, active or inactive + + inl_fvs = udFreeVars bndr_set unadj_inl_uds + -- inl_fvs: vars that would become free if the function was inlined. + -- We conservatively approximate that by the free vars from the RHS + -- and the unfolding together. + -- See Note [inl_fvs] + + + --------- Right hand side --------- + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + -- and Note [TailUsageDetails when forming Rec groups] + -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because + -- (a) we don't yet know the final joinpointhood. It might not become a + -- join point after all! + -- (b) we don't even know whether it stays a recursive RHS after the SCC + -- analysis we are about to seed! So we can't markAllInsideLam in + -- advance, because if it ends up as a non-recursive join point we'll + -- consider it as one-shot and don't need to markAllInsideLam. + -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage + -- until occAnalRec. In effect, we pretend that the RHS becomes a + -- non-recursive join point and fix up later with adjustTailUsage. + rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs + -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint), + -- it's safe to zap the occ_join_points, because they can't occur in RHS. + WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs + -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders + + --------- Unfolding --------- + -- See Note [Join points and unfoldings/rules] + unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness + -- here because that is what we are setting! + WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf + adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds + -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M + -- of Note [Join arity prediction based on joinRhsArity] + + --------- IMP-RULES -------- + is_active = occ_rule_act env :: Activation -> Bool + imp_rule_info = lookupImpRules imp_rule_edges bndr + imp_rule_uds = impRulesScopeUsage imp_rule_info + imp_rule_fvs = impRulesActiveFvs is_active bndr_set imp_rule_info + + --------- All rules -------- + -- See Note [Join points and unfoldings/rules] + -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M + -- of Note [Join arity prediction based on joinRhsArity] + rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] + rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds) + | rule <- idCoreRules bndr + , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ] + rules' = map fstOf3 rules_w_uds + + adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds + add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds + + -------- active_rule_fvs ------------ + active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds + add_active_rule (rule, _, rhs_uds) fvs + | is_active (ruleActivation rule) + = udFreeVars bndr_set rhs_uds `unionVarSet` fvs + | otherwise + = fvs + + -------- weak_fvs ------------ + -- See Note [Weak loop breakers] + weak_fvs = foldr add_rule emptyVarSet rules_w_uds + add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs + +mkLoopBreakerNodes :: OccEnv -> TopLevelFlag + -> UsageDetails -- for BODY of let + -> [NodeDetails] + -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date +-- See Note [Choosing loop breakers] +-- This function primarily creates the Nodes for the +-- loop-breaker SCC analysis. More specifically: +-- a) tag each binder with its occurrence info +-- b) add a NodeScore to each node +-- c) make a Node with the right dependency edges for +-- the loop-breaker SCC analysis +-- d) adjust each RHS's usage details according to +-- the binder's (new) shotness and join-point-hood +mkLoopBreakerNodes !env lvl body_uds details_s + = WUD final_uds (zipWithEqual mk_lb_node details_s bndrs') + where + WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s + + mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs + , nd_rhs = WTUD _ rhs }) new_bndr + = DigraphNode { node_payload = simple_nd + , node_key = varUnique old_bndr + , node_dependencies = nonDetKeysUniqSet lb_deps } + -- It's OK to use nonDetKeysUniqSet here as + -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges + -- in nondeterministic order as explained in + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where + simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score } + score = nodeScore env new_bndr lb_deps nd + lb_deps = extendFvs_ rule_fv_env inl_fvs + -- See Note [Loop breaker dependencies] + + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- reachable by a sequence of RULES starting with f + -- Domain is *subset* of bound vars (others have no rule fvs) + -- See Note [Finding rule RHS free vars] + -- Why transClosureFV? See Note [Loop breaker dependencies] + rule_fv_env = transClosureFV $ mkVarEnv $ + [ (b, rule_fvs) + | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s + , not (isEmptyVarSet rule_fvs) ] + +{- Note [Loop breaker dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop breaker dependencies of x in a recursive +group { f1 = e1; ...; fn = en } are: + +- The "inline free variables" of f: the fi free in + f's stable unfolding and RHS; see Note [inl_fvs] + +- Any fi reachable from those inline free variables by a sequence + of RULE rewrites. Remember, rule rewriting is not affected + by fi being a loop breaker, so we have to take the transitive + closure in case f is the only possible loop breaker in the loop. + + Hence rule_fv_env. We need only account for /active/ rules. +-} + +------------------------------------------ +nodeScore :: OccEnv + -> Id -- Binder with new occ-info + -> VarSet -- Loop-breaker dependencies + -> NodeDetails + -> NodeScore +nodeScore !env new_bndr lb_deps + (ND { nd_bndr = old_bndr, nd_rhs = WTUD _ bind_rhs }) + + | not (isId old_bndr) -- A type or coercion variable is never a loop breaker + = (100, 0, False) + + | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers + = (0, 0, True) -- See Note [Self-recursion and loop breakers] + + | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + + | exprIsTrivial rhs + = mk_score 10 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + | DFunUnfolding { df_args = args } <- old_unf + -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] + = (9, length args, is_lb) + + -- Data structures are more important than INLINE pragmas + -- so that dictionary/method recursion unravels + + | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf + = mk_score 6 + + | is_con_app rhs -- Data types help with cases: + = mk_score 5 -- Note [Constructor applications] + + | isStableUnfolding old_unf + , can_unfold + = mk_score 3 + + | isOneOcc (idOccInfo new_bndr) + = mk_score 2 -- Likely to be inlined + + | can_unfold -- The Id has some kind of unfolding + = mk_score 1 + + | otherwise + = (0, 0, is_lb) + + where + mk_score :: Int -> NodeScore + mk_score rank = (rank, rhs_size, is_lb) + + -- is_lb: see Note [Loop breakers, node scoring, and stability] + is_lb = isStrongLoopBreaker (idOccInfo old_bndr) + + old_unf = realIdUnfolding old_bndr + can_unfold = canUnfold old_unf + rhs = case old_unf of + CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } + | isStableSource src + -> unf_rhs + _ -> bind_rhs + -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding + rhs_size = case old_unf of + CoreUnfolding { uf_guidance = guidance } + | UnfIfGoodArgs { ug_size = size } <- guidance + -> size + _ -> cheapExprSize rhs + + + -- Checking for a constructor application + -- Cheap and cheerful; the simplifier moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isConLikeId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Tick _ e) = is_con_app e + is_con_app (Let _ e) = is_con_app e -- let x = let y = blah in (a,b) + is_con_app _ = False -- We will float the y out, so treat + -- the x-binding as a con-app (#20941) + +maxExprSize :: Int +maxExprSize = 20 -- Rather arbitrary + +cheapExprSize :: CoreExpr -> Int +-- Maxes out at maxExprSize +cheapExprSize e + = go 0 e + where + go n e | n >= maxExprSize = n + | otherwise = go1 n e + + go1 n (Var {}) = n+1 + go1 n (Lit {}) = n+1 + go1 n (Type {}) = n + go1 n (Coercion {}) = n + go1 n (Tick _ e) = go1 n e + go1 n (Cast e _) = go1 n e + go1 n (App f a) = go (go1 n f) a + go1 n (Lam b e) + | isTyVar b = go1 n e + | otherwise = go (n+1) e + go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) + go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) + + gos n [] = n + gos n (e:es) | n >= maxExprSize = n + | otherwise = gos (go1 n e) es + +betterLB :: NodeScore -> NodeScore -> Bool +-- If n1 `betterLB` n2 then choose n1 as the loop breaker +betterLB (rank1, size1, lb1) (rank2, size2, _) + | rank1 < rank2 = True + | rank1 > rank2 = False + | size1 < size2 = False -- Make the bigger n2 into the loop breaker + | size1 > size2 = True + | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it + | otherwise = False -- See Note [Loop breakers, node scoring, and stability] + +{- Note [Self-recursion and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + rec { f = ...f...g... + ; g = .....f... } +then 'f' has to be a loop breaker anyway, so we may as well choose it +right away, so that g can inline freely. + +This is really just a cheap hack. Consider + rec { f = ...g... + ; g = ..f..h... + ; h = ...f....} +Here f or g are better loop breakers than h; but we might accidentally +choose h. Finding the minimal set of loop breakers is hard. + +Note [Loop breakers, node scoring, and stability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To choose a loop breaker, we give a NodeScore to each node in the SCC, +and pick the one with the best score (according to 'betterLB'). + +We need to be jolly careful (#12425, #12234) about the stability +of this choice. Suppose we have + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...f.. + False -> ..f... + +In each iteration of the simplifier the occurrence analyser OccAnal +chooses a loop breaker. Suppose in iteration 1 it choose g as the loop +breaker. That means it is free to inline f. + +Suppose that GHC decides to inline f in the branches of the case, but +(for some reason; eg it is not saturated) in the rhs of g. So we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...g...g..... + False -> ..g..g.... + +Now suppose that, for some reason, in the next iteration the occurrence +analyser chooses f as the loop breaker, so it can freely inline g. And +again for some reason the simplifier inlines g at its calls in the case +branches, but not in the RHS of f. Then we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...(...f...f...)...(...f..f..)..... + False -> ..(...f...f...)...(..f..f...).... + +You can see where this is going! Each iteration of the simplifier +doubles the number of calls to f or g. No wonder GHC is slow! + +(In the particular example in comment:3 of #12425, f and g are the two +mutually recursive fmap instances for CondT and Result. They are both +marked INLINE which, oddly, is why they don't inline in each other's +RHS, because the call there is not saturated.) + +The root cause is that we flip-flop on our choice of loop breaker. I +always thought it didn't matter, and indeed for any single iteration +to terminate, it doesn't matter. But when we iterate, it matters a +lot!! + +So The Plan is this: + If there is a tie, choose the node that + was a loop breaker last time round + +Hence the is_lb field of NodeScore +-} + +{- ********************************************************************* +* * + Lambda groups +* * +********************************************************************* -} + +{- Note [Occurrence analysis for lambda binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For value lambdas we do a special hack. Consider + (\x. \y. ...x...) +If we did nothing, x is used inside the \y, so would be marked +as dangerous to dup. But in the common case where the abstraction +is applied to two arguments this is over-pessimistic, which delays +inlining x, which forces more simplifier iterations. + +So the occurrence analyser collaborates with the simplifier to treat +a /lambda-group/ specially. A lambda-group is a contiguous run of +lambda and casts, e.g. + Lam x (Lam y (Cast (Lam z body) co)) + +* Occurrence analyser: we just mark each binder in the lambda-group + (here: x,y,z) with its occurrence info in the *body* of the + lambda-group. See occAnalLamTail. + +* Simplifier. The simplifier is careful when partially applying + lambda-groups. See the call to zapLambdaBndrs in + GHC.Core.Opt.Simplify.simplExprF1 + GHC.Core.SimpleOpt.simple_app + +* Why do we take care to account for intervening casts? Answer: + currently we don't do eta-expansion and cast-swizzling in a stable + unfolding (see Historical-note [Eta-expansion in stable unfoldings]). + So we can get + f = \x. ((\y. ...x...y...) |> co) + Now, since the lambdas aren't together, the occurrence analyser will + say that x is OnceInLam. Now if we have a call + (f e1 |> co) e2 + we'll end up with + let x = e1 in ...x..e2... + and it'll take an extra iteration of the Simplifier to substitute for x. + +A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity +recognises except that the latter looks through (some) ticks. Maybe a lambda +group should also look through (some) ticks? +-} + +isOneShotFun :: CoreExpr -> Bool +-- The top level lambdas, ignoring casts, of the expression +-- are all one-shot. If there aren't any lambdas at all, this is True +isOneShotFun (Lam b e) = isOneShotBndr b && isOneShotFun e +isOneShotFun (Cast e _) = isOneShotFun e +isOneShotFun _ = True + +zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear under the \z +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: `arg_count` includes both type and value args +zapLambdaBndrs fun arg_count + = -- If the lambda is fully applied, leave it alone; if not + -- zap the OccInfo on the lambdas that do have arguments, + -- so they beta-reduce to use-many Lets rather than used-once ones. + zap arg_count fun `orElse` fun + where + zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr + -- Nothing => No need to change the occ-info + -- Just e => Had to change + zap 0 e | isOneShotFun e = Nothing -- All remaining lambdas are one-shot + | otherwise = Just e -- in which case no need to zap + zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) } + zap n (Lam b e) = do { e' <- zap (n-1) e + ; return (Lam (zap_bndr b) e') } + zap _ _ = Nothing -- More arguments than lambdas + + zap_bndr b | isTyVar b = b + | otherwise = zapLamIdInfo b + +occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr +-- ^ See Note [Occurrence analysis for lambda binders]. +-- It does the following: +-- * Sets one-shot info on the lambda binder from the OccEnv, and +-- removes that one-shot info from the OccEnv +-- * Sets the OccEnv to OccVanilla when going under a value lambda +-- * Tags each lambda with its occurrence information +-- * Walks through casts +-- * Package up the analysed lambda with its manifest join arity +-- +-- This function does /not/ do +-- markAllInsideLam or +-- markAllNonTail +-- The caller does that, via adjustTailUsage (mostly calls go through +-- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call +-- adjustTailUsage to discharge the assumed join arity. +-- +-- In effect, the analysis result is for a non-recursive join point with +-- manifest arity and adjustTailUsage does the fixup. +-- See Note [Adjusting right-hand sides] +occAnalLamTail env expr + = let !(WUD usage expr') = occ_anal_lam_tail env expr + in WTUD (TUD (joinRhsArity expr) usage) expr' + +occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr +-- Does not markInsideLam etc for the outmost batch of lambdas +occ_anal_lam_tail env expr@(Lam {}) + = go env [] expr + where + go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr + go env rev_bndrs (Lam bndr body) + | isTyVar bndr + = go env (bndr:rev_bndrs) body + -- Important: Unlike a value binder, do not modify occ_encl + -- to OccVanilla, so that with a RHS like + -- \(@ x) -> K @x (f @x) + -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain + -- from inlining f. See the beginning of Note [Cascading inlines]. + + | otherwise + = let (env_one_shots', bndr') + = case occ_one_shots env of + [] -> ([], bndr) + (os : oss) -> (oss, updOneShotInfo bndr os) + -- Use updOneShotInfo, not setOneShotInfo, as pre-existing + -- one-shot info might be better than what we can infer, e.g. + -- due to explicit use of the magic 'oneShot' function. + -- See Note [oneShot magic] + env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' } + in go env' (bndr':rev_bndrs) body + + go env rev_bndrs body + = addInScope env rev_bndrs $ \env -> + let !(WUD usage body') = occ_anal_lam_tail env body + wrap_lam body bndr = Lam (tagLamBinder usage bndr) body + in WUD (usage `addLamCoVarOccs` rev_bndrs) + (foldl' wrap_lam body' rev_bndrs) + +-- For casts, keep going in the same lambda-group +-- See Note [Occurrence analysis for lambda binders] +occ_anal_lam_tail env (Cast expr co) + = let WUD usage expr' = occ_anal_lam_tail env expr + -- usage1: see Note [Gather occurrences of coercion variables] + usage1 = addManyOccs usage (coVarsOfCo co) + + -- usage2: see Note [Occ-anal and cast worker/wrapper] + usage2 = case expr of + Var {} | isRhsEnv env -> markAllMany usage1 + _ -> usage1 + + -- usage3: you might think this was not necessary, because of + -- the markAllNonTail in adjustTailUsage; but not so! For a + -- join point, adjustTailUsage doesn't do this; yet if there is + -- a cast, we must! Also: why markAllNonTail? See + -- GHC.Core.Lint: Note Note [Join points and casts] + usage3 = markAllNonTail usage2 + + in WUD usage3 (Cast expr' co) + +occ_anal_lam_tail env expr -- Not Lam, not Cast + = occAnal env expr + +{- Note [Occ-anal and cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider y = e; x = y |> co +If we mark y as used-once, we'll inline y into x, and the Cast +worker/wrapper transform will float it straight back out again. See +Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify. + +So in this particular case we want to mark 'y' as Many. It's very +ad-hoc, but it's also simple. It's also what would happen if we gave +the binding for x a stable unfolding (as we usually do for wrappers, thus + y = e + {-# INLINE x #-} + x = y |> co +Now y appears twice -- once in x's stable unfolding, and once in x's +RHS. So it'll get a Many occ-info. (Maybe Cast w/w should create a stable +unfolding, which would obviate this Note; but that seems a bit of a +heavyweight solution.) + +We only need to this in occAnalLamTail, not occAnal, because the top leve +of a right hand side is handled by occAnalLamTail. +-} + + +{- ********************************************************************* +* * + Right hand sides +* * +********************************************************************* -} + +occAnalUnfolding :: OccEnv + -> Unfolding + -> WithTailUsageDetails Unfolding +-- Occurrence-analyse a stable unfolding; +-- discard a non-stable one altogether and return empty usage details. +occAnalUnfolding !env unf + = case unf of + unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + | isStableSource src -> + let + WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs + unf' = unf { uf_tmpl = rhs' } + in WTUD (TUD rhs_ja (markAllMany uds)) unf' + -- markAllMany: see Note [Occurrences in stable unfoldings] + + | otherwise -> WTUD (TUD 0 emptyDetails) unf + -- For non-Stable unfoldings we leave them undisturbed, but + -- don't count their usage because the simplifier will discard them. + -- We leave them undisturbed because nodeScore uses their size info + -- to guide its decisions. It's ok to leave un-substituted + -- expressions in the tree because all the variables that were in + -- scope remain in scope; there is no cloning etc. + + unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + -> let WUD uds args' = addInScopeList env bndrs $ \ env -> + occAnalList env args + in WTUD (TUD 0 uds) (unf { df_args = args' }) + -- No need to use tagLamBinders because we + -- never inline DFuns so the occ-info on binders doesn't matter + + unf -> WTUD (TUD 0 emptyDetails) unf + +occAnalRule :: OccEnv + -> CoreRule + -> (CoreRule, -- Each (non-built-in) rule + UsageDetails, -- Usage details for LHS + TailUsageDetails) -- Usage details for RHS +occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = (rule', lhs_uds', TUD rhs_ja rhs_uds') + where + rule' = rule { ru_args = args', ru_rhs = rhs' } + + WUD lhs_uds args' = addInScopeList env bndrs $ \env -> + occAnalList env args + + lhs_uds' = markAllManyNonTail lhs_uds + WUD rhs_uds rhs' = addInScopeList env bndrs $ \env -> + occAnal env rhs + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_uds' = markAllMany rhs_uds + rhs_ja = length args -- See Note [Join points and unfoldings/rules] + +occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails) + +{- Note [Occurrences in stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f p = BIG + {-# INLINE g #-} + g y = not (f y) +where this is the /only/ occurrence of 'f'. So 'g' will get a stable +unfolding. Now suppose that g's RHS gets optimised (perhaps by a rule +or inlining f) so that it doesn't mention 'f' any more. Now the last +remaining call to f is in g's Stable unfolding. But, even though there +is only one syntactic occurrence of f, we do /not/ want to do +preinlineUnconditionally here! + +The INLINE pragma says "inline exactly this RHS"; perhaps the +programmer wants to expose that 'not', say. If we inline f that will make +the Stable unfoldign big, and that wasn't what the programmer wanted. + +Another way to think about it: if we inlined g as-is into multiple +call sites, now there's be multiple calls to f. + +Bottom line: treat all occurrences in a stable unfolding as "Many". +We still leave tail call information intact, though, as to not spoil +potential join points. + +Note [Unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally unfoldings and rules are already occurrence-analysed, so we +don't want to reconstruct their trees; we just want to analyse them to +find how they use their free variables. + +EXCEPT if there is a binder-swap going on, in which case we do want to +produce a new tree. + +So we have a fast-path that keeps the old tree if the occ_bs_env is +empty. This just saves a bit of allocation and reconstruction; not +a big deal. + +Two tricky corners: + +* Dead bindings (#22761). Supose we have + Unfolding = \x. let y = foo in x+1 + which includes a dead binding for `y`. In occAnalUnfolding we occ-anal + the unfolding and produce /no/ occurrences of `foo` (since `y` is + dead). But if we discard the occ-analysed syntax tree (which we do on + our fast path), and use the old one, we still /have/ an occurrence of + `foo` -- and that can lead to out-of-scope variables (#22761). + + Solution: always keep occ-analysed trees in unfoldings and rules, so they + have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core. + +* One-shot binders. Consider + {- f has Stable unfolding \p q -> blah + Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -} + f = \x y. blah + + Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has + occ_one_shots = [NoOneShortInfo, OneShotLam] + This will put OneShotLam on the \y. And it'll put it on the \q. But the + noBinderSwap check will mean that we discard this new occ-anal'd unfolding + and keep the old one, with no OneShotInfo. + + This looks a little inconsistent, but the Stable unfolding is just used for + inlinings; OneShotInfo isn't a lot of use here. + +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an OccRhs for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an OccVanilla context, not OccRhs. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally. +If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and + (b) certainly_inline says "yes" when preInlineUnconditionally says "no" +then the simplifier iterates indefinitely: + x = f y + k = Just x -- We decide that k is 'certainly_inline' + v = ...k... -- but preInlineUnconditionally doesn't inline it +inline ==> + k = Just (f y) + v = ...k... +float ==> + x1 = f y + k = Just x1 + v = ...k... + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. See #24582 for an example of the two getting out of sync. + + +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr] +occAnalList !_ [] = WUD emptyDetails [] +occAnalList env (e:es) = let + (WUD uds1 e') = occAnal env e + (WUD uds2 es') = occAnalList env es + in WUD (uds1 `andUDs` uds2) (e' : es') + +occAnal :: OccEnv + -> CoreExpr + -> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids + +occAnal !_ expr@(Lit _) = WUD emptyDetails expr + +occAnal env expr@(Var _) = occAnalApp env (expr, [], []) + -- At one stage, I gathered the idRuleVars for the variable here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + +occAnal _ expr@(Type ty) + = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr +occAnal _ expr@(Coercion co) + = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr + -- See Note [Gather occurrences of coercion variables] + +{- Note [Gather occurrences of coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, for two reasons: + +1. So that we can sort them into the right place when doing dependency analysis. + +2. So that we know when they are surely dead. + +It is useful to know when they a coercion variable is surely dead, +when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase. +For example (#20143): + + case unsafeEqualityProof @blah of + UnsafeRefl cv -> ...no use of cv... + +Here we can discard the case, since unsafeEqualityProof always terminates. +But only if the coercion variable 'cv' is unused. + +Another example from #15696: we had something like + case eq_sel d of co -> ...(typeError @(...co...) "urk")... +Then 'd' was substituted by a dictionary, so the expression +simpified to + case (Coercion ) of cv -> ...(typeError @(...cv...) "urk")... + +We can only drop the case altogether if 'cv' is unused, which is not +the case here. + +Conclusion: we need accurate dead-ness info for CoVars. +We gather CoVar occurrences from: + + * The (Type ty) and (Coercion co) cases of occAnal + + * The type 'ty' of a lambda-binder (\(x:ty). blah) + See addCoVarOccs + +But it is not necessary to gather CoVars from the types of other binders. + +* For let-binders, if the type mentions a CoVar, so will the RHS (since + it has the same type) + +* For case-alt binders, if the type mentions a CoVar, so will the scrutinee + (since it has the same type) +-} + +occAnal env (Tick tickish body) + = WUD usage' (Tick tickish body') + where + WUD usage body' = occAnal env body + + usage' + | tickish `tickishScopesLike` SoftScope + = usage -- For soft-scoped ticks (including SourceNotes) we don't want + -- to lose join-point-hood, so we don't mess with `usage` (#24078) + + -- For a non-soft tick scope, we can inline lambdas only, so we + -- abandon tail calls, and do markAllInsideLam too: usage_lam + + | Breakpoint _ _ ids <- tickish + = -- Never substitute for any of the Ids in a Breakpoint + addManyOccs usage_lam (mkVarSet ids) + + | otherwise + = usage_lam + + usage_lam = markAllNonTail (markAllInsideLam usage) + + -- TODO There may be ways to make ticks and join points play + -- nicer together, but right now there are problems: + -- let j x = ... in tick (j 1) + -- Making j a join point may cause the simplifier to drop t + -- (if the tick is put into the continuation). So we don't + -- count j 1 as a tail call. + -- See #14242. + +occAnal env (Cast expr co) + = let (WUD usage expr') = occAnal env expr + usage1 = addManyOccs usage (coVarsOfCo co) + -- usage2: see Note [Gather occurrences of coercion variables] + usage2 = markAllNonTail usage1 + -- usage3: calls inside expr aren't tail calls any more + in WUD usage2 (Cast expr' co) + +occAnal env app@(App _ _) + = occAnalApp env (collectArgsTicks tickishFloatable app) + +occAnal env expr@(Lam {}) + = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail + occAnalLamTail env expr + +occAnal env (Case scrut bndr ty alts) + = let + WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut + + WUD alts_usage (tagged_bndr, alts') + = addInScopeOne env bndr $ \env -> + let alt_env = addBndrSwap scrut' bndr $ + setTailCtxt env -- Kill off OccRhs + WUD alts_usage alts' = do_alts alt_env alts + tagged_bndr = tagLamBinder alts_usage bndr + in WUD alts_usage (tagged_bndr, alts') + + total_usage = markAllNonTail scrut_usage `andUDs` alts_usage + -- Alts can have tail calls, but the scrutinee can't + + in WUD total_usage (Case scrut' tagged_bndr ty alts') + where + do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt] + do_alts _ [] = WUD emptyDetails [] + do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts') + where + WUD uds1 alt' = do_alt env alt + WUD uds2 alts' = do_alts env alts + + do_alt !env (Alt con bndrs rhs) + = addInScopeList env bndrs $ \ env -> + let WUD rhs_usage rhs' = occAnal env rhs + tagged_bndrs = tagLamBinders rhs_usage bndrs + in -- See Note [Binders in case alternatives] + WUD rhs_usage (Alt con tagged_bndrs rhs') + +occAnal env (Let bind body) + = occAnalBind env NotTopLevel noImpRuleEdges bind + (\env -> occAnal env body) mkLets + +occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] + -> [OneShots] -- Very commonly empty, notably prior to dmd anal + -> WithUsageDetails CoreExpr +-- The `fun` argument is just an accumulating parameter, +-- the base for building the application we return +occAnalArgs !env fun args !one_shots + = go emptyDetails fun args one_shots + where + env_args = setNonTailCtxt encl env + + -- Make bottoming functions interesting + -- See Note [Bottoming function calls] + encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut + | otherwise = OccVanilla + + go uds fun [] _ = WUD uds fun + go uds fun (arg:args) one_shots + = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots' + where + !(WUD arg_uds arg') = occAnal arg_env arg + !(arg_env, one_shots') + | isTypeArg arg + = (env_args, one_shots) + | otherwise + = case one_shots of + [] -> (env_args, []) -- Fast path; one_shots is often empty + (os : one_shots') -> (setOneShots os env_args, one_shots') + +{- +Applications are dealt with specially because we want +the "build hack" to work. + +Note [Bottoming function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x = (a,b) in + case p of + A -> ...(error x).. + B -> ...(ertor x)... + +postInlineUnconditionally may duplicate x's binding, but sometimes it +does so only if the use site IsInteresting. Pushing allocation into error +branches is good, so we try to make bottoming calls look interesting, by +setting occ_encl = OccScrut for such calls. + +The slightly-artificial test T21128 is a good example. It's probably +not a huge deal. + +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. +-} + +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish]) + -> WithUsageDetails (Expr CoreBndr) +-- Naked variables (not applied) end up here too +occAnalApp !env (Var fun, args, ticks) + -- Account for join arity of runRW# continuation + -- See Note [Simplification of runRW#] + -- + -- NB: Do not be tempted to make the next (Var fun, args, tick) + -- equation into an 'otherwise' clause for this equation + -- The former has a bang-pattern to occ-anal the args, and + -- we don't want to occ-anal them twice in the runRW# case! + -- This caused #18296 + | fun `hasKey` runRWKey + , [t1, t2, arg] <- args + , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg + = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + +occAnalApp env (Var fun_id, args, ticks) + = WUD all_uds (mkTicks ticks app') + where + -- Lots of banged bindings: this is a very heavily bit of code, + -- so it pays not to make lots of thunks here, all of which + -- will ultimately be forced. + !(fun', fun_id') = lookupBndrSwap env fun_id + !(WUD args_uds app') = occAnalArgs env fun' args one_shots + + fun_uds = mkOneOcc env fun_id' int_cxt n_args + -- NB: fun_uds is computed for fun_id', not fun_id + -- See (BS1) in Note [The binder-swap substitution] + + all_uds = fun_uds `andUDs` final_args_uds + + !final_args_uds = markAllNonTail $ + markAllInsideLamIf (isRhsEnv env && is_exp) $ + -- isRhsEnv: see Note [OccEncl] + args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "inside-lambda", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor or PAP + -- argument position, which is what we want. Typically those + -- constructor arguments are just variables, or trivial expressions. + -- We use inside-lam because it's like eta-expanding the PAP. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] + + !n_val_args = valArgCount args + !n_args = length args + !int_cxt = case occ_encl env of + OccScrut -> IsInteresting + _other | n_val_args > 0 -> IsInteresting + | otherwise -> NotInteresting + + !is_exp = isExpandableApp fun_id n_val_args + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs + + one_shots = argsOneShots (idDmdSig fun_id) guaranteed_val_args + guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo + (occ_one_shots env)) + -- See Note [Sources of one-shot information], bullet point A'] + +occAnalApp env (fun, args, ticks) + = WUD (markAllNonTail (fun_uds `andUDs` args_uds)) + (mkTicks ticks app') + where + !(WUD args_uds app') = occAnalArgs env fun' args [] + !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexes like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some OneShotLam items + -- onto the context stack. + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + | n_val_args > 0 + = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt + , occ_encl = OccVanilla } + -- OccVanilla: the function part of the application + -- is no longer on OccRhs or OccScrut + | otherwise + = env + where + n_val_args = valArgCount args + + +{- +Note [Sources of one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrence analyser obtains one-shot-lambda information from two sources: + +A: Saturated applications: eg f e1 .. en + + In general, given a call (f e1 .. en) we can propagate one-shot info from + f's strictness signature into e1 .. en, but /only/ if n is enough to + saturate the strictness signature. A strictness signature like + + f :: C(1,C(1,L))LS + + means that *if f is applied to three arguments* then it will guarantee to + call its first argument at most once, and to call the result of that at + most once. But if f has fewer than three arguments, all bets are off; e.g. + + map (f (\x y. expensive) e2) xs + + Here the \x y abstraction may be called many times (once for each element of + xs) so we should not mark x and y as one-shot. But if it was + + map (f (\x y. expensive) 3 2) xs + + then the first argument of f will be called at most once. + + The one-shot info, derived from f's strictness signature, is + computed by 'argsOneShots', called in occAnalApp. + +A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) + where f is as above. + + In this case, f is only manifestly applied to one argument, so it does not + look saturated. So by the previous point, we should not use its strictness + signature to learn about the one-shotness of \x y. But in this case we can: + build is fully applied, so we may use its strictness signature; and from + that we learn that build calls its argument with two arguments *at most once*. + + So there is really only one call to f, and it will have three arguments. In + that sense, f is saturated, and we may proceed as described above. + + Hence the computation of 'guaranteed_val_args' in occAnalApp, using + '(occ_one_shots env)'. See also #13227, comment:9 + +B: Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + + Propagate one-shot info from the demand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) + + This information must have come from a previous run of the demand + analyser. + +Previously, the demand analyser would *also* set the one-shot information, but +that code was buggy (see #11770), so doing it only in on place, namely here, is +saner. + +Note [OneShots] +~~~~~~~~~~~~~~~ +When analysing an expression, the occ_one_shots argument contains information +about how the function is being used. The length of the list indicates +how many arguments will eventually be passed to the analysed expression, +and the OneShotInfo indicates whether this application is once or multiple times. + +Example: + + Context of f occ_one_shots when analysing f + + f 1 2 [OneShot, OneShot] + map (f 1) [OneShot, NoOneShotInfo] + build f [OneShot, OneShot] + f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, because it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). +-} + +{- +************************************************************************ +* * + OccEnv +* * +************************************************************************ +-} + +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- See Note [OneShots] + , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active + , occ_rule_act :: Activation -> Bool -- Which rules are active + -- See Note [Finding rule RHS free vars] + + -- See Note [The binder-swap substitution] + -- If x :-> (y, co) is in the env, + -- then please replace x by (y |> mco) + -- Invariant of course: idType x = exprType (y |> mco) + , occ_bs_env :: !(IdEnv (OutId, MCoercion)) + -- Domain is Global and Local Ids + -- Range is just Local Ids + , occ_bs_rng :: !VarSet + -- Vars (TyVars and Ids) free in the range of occ_bs_env + + -- Usage details of the RHS of in-scope non-recursive join points + -- Invariant: no Id maps to an empty OccInfoEnv + -- See Note [Occurrence analysis for join points] + , occ_join_points :: !JoinPointInfo + } + +type JoinPointInfo = IdEnv OccInfoEnv + +----------------------------- +{- Note [OccEncl] +~~~~~~~~~~~~~~~~~ +OccEncl is used to control whether to inline into constructor arguments. + +* OccRhs: consider + let p = in + let x = Just p + in ...case p of ... + + Here `p` occurs syntactically once, but we want to mark it as InsideLam + to stop `p` inlining. We want to leave the x-binding as a constructor + applied to variables, so that the Simplifier can simplify that inner `case`. + + The OccRhs just tells occAnalApp to mark occurrences in constructor args + +* OccScrut: consider (case x of ...). Here we want to give `x` OneOcc + with "interesting context" field int_cxt = True. The OccScrut tells + occAnalApp (which deals with lone variables too) when to set this field + to True. +-} + +data OccEncl -- See Note [OccEncl] + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + | OccScrut -- Scrutintee of a case + | OccVanilla -- Everything else + +instance Outputable OccEncl where + ppr OccRhs = text "occRhs" + ppr OccScrut = text "occScrut" + ppr OccVanilla = text "occVanilla" + +-- See Note [OneShots] +type OneShots = [OneShotInfo] + +initOccEnv :: OccEnv +initOccEnv + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] + + -- To be conservative, we say that all + -- inlines and rules are active + , occ_unf_act = \_ -> True + , occ_rule_act = \_ -> True + + , occ_join_points = emptyVarEnv + , occ_bs_env = emptyVarEnv + , occ_bs_rng = emptyVarSet } + +noBinderSwaps :: OccEnv -> Bool +noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env + +setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv +setScrutCtxt !env alts + = setNonTailCtxt encl env + where + encl | interesting_alts = OccScrut + | otherwise = OccVanilla + + interesting_alts = case alts of + [] -> False + [alt] -> not (isDefaultAlt alt) + _ -> True + -- 'interesting_alts' is True if the case has at least one + -- non-default alternative. That in turn influences + -- pre/postInlineUnconditionally. Grep for "occ_int_cxt"! + +{- Note [The OccEnv for a right hand side] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we create the OccEnv for a RHS (in mkRhsOccEnv)? + +For a non-join point binding, x = rhs + + * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles + + * occ_join_points: zap them! + + * occ_one_shots: initialise from the idDemandInfo; + see Note [Sources of one-shot information] + +For a join point binding, j x = rhs + + * occ_encl: Consider + x = e + join j = Just x + We want to inline x into j right away, so we don't want to give the join point + a OccRhs (#14137); we want OccVanilla. It's not a huge deal, because the + FloatIn pass knows to float into join point RHSs; and the simplifier does not + float things out of join point RHSs. But it's a simple, cheap thing to do. + + * occ_join_points: no need to zap. + + * occ_one_shots: we start with one-shot-info from the context, which indeed + applies to the /body/ of the join point, after walking past the binders. + So we add to the front a OneShotInfo for each value-binder of the join + point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point + binders caused #25096.) + + For the join point binders themselves, of a /non-recursive/ join point, + we make the binder a OneShotLam. Again see `extendOneShotsForJoinPoint`. + + These one-shot infos then get attached to the binder by `occAnalLamTail`. +-} + +setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv +setNonTailCtxt ctxt !env + = env { occ_encl = ctxt + , occ_one_shots = [] + , occ_join_points = zapJoinPointInfo (occ_join_points env) } + +setTailCtxt :: OccEnv -> OccEnv +setTailCtxt !env = env { occ_encl = OccVanilla } + -- Preserve occ_one_shots, occ_join points + -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt): + +mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv +-- See Note [The OccEnv for a right hand side] +-- For a join point: +-- - Keep occ_one_shots, occ_joinPoints from the context +-- - But push enough OneShotInfo onto occ_one_shots to account +-- for the join-point value binders +-- - Set occ_encl to OccVanilla +-- For non-join points +-- - Zap occ_one_shots and occ_join_points +-- - Set occ_encl to specified OccEncl +mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points }) + is_rec encl jp_hood bndr rhs + | JoinPoint join_arity <- jp_hood + = env { occ_encl = OccVanilla + , occ_one_shots = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + , occ_join_points = ctxt_join_points } + + | otherwise + = env { occ_encl = encl + , occ_one_shots = argOneShots (idDemandInfo bndr) + -- argOneShots: see Note [Sources of one-shot information] + , occ_join_points = zapJoinPointInfo ctxt_join_points } + +zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo +-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped). +-- See (W3) of Note [Occurrence analysis for join points] +-- +-- Zapping improves efficiency, slightly, if you accidentally introduce a bug, +-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you +-- might lose those uds, and that might mean we don't record all occurrencs, and +-- that means we duplicate a redex.... a very nasty bug (which I encountered!). +-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it +-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this +-- bug before it does any damage. +#ifdef DEBUG +zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info +#else +zapJoinPointInfo _ = emptyVarEnv +#endif + +extendOneShotsForJoinPoint + :: RecFlag -> JoinArity -> CoreExpr + -> [OneShotInfo] -> [OneShotInfo] +-- Push enough OneShortInfos on the front of ctxt_one_shots +-- to account for the value lambdas of the join point +extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots + = go join_arity rhs + where + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + -- But not so for recursive ones + os = case is_rec of + NonRecursive -> OneShotLam + Recursive -> NoOneShotInfo + + go 0 _ = ctxt_one_shots + go n (Lam b rhs) + | isId b = os : go (n-1) rhs + | otherwise = go (n-1) rhs + go _ _ = [] -- Not enough lambdas. This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + +setOneShots :: OneShots -> OccEnv -> OccEnv +setOneShots os !env + | null os = env -- Fast path for common case + | otherwise = env { occ_one_shots = os } + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of + OccRhs -> True + _ -> False + +addInScopeList :: OccEnv -> [Var] + -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a +{-# INLINE addInScopeList #-} +addInScopeList env bndrs thing_inside + | null bndrs = thing_inside env -- E.g. nullary constructors in a `case` + | otherwise = addInScope env bndrs thing_inside + +addInScopeOne :: OccEnv -> Id + -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a +{-# INLINE addInScopeOne #-} +addInScopeOne env bndr = addInScope env [bndr] + +addInScope :: OccEnv -> [Var] + -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a +{-# INLINE addInScope #-} +-- This function is called a lot, so we want to inline the fast path +-- so we don't have to allocate thing_inside and call it +-- The bndrs must include TyVars as well as Ids, because of +-- (BS3) in Note [Binder swap] +-- We do not assume that the bndrs are in scope order; in fact the +-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order + +-- Fast path when the is no environment-munging to do +-- This is rather common: notably at top level, but nested too +addInScope env bndrs thing_inside + | isEmptyVarEnv (occ_bs_env env) + , isEmptyVarEnv (occ_join_points env) + , WUD uds res <- thing_inside env + = WUD (delBndrsFromUDs bndrs uds) res + +addInScope env bndrs thing_inside + = WUD uds' res + where + bndr_set = mkVarSet bndrs + !(env', bad_joins) = preprocess_env env bndr_set + !(WUD uds res) = thing_inside env' + uds' = postprocess_uds bndrs bad_joins uds + +preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo) +preprocess_env env@(OccEnv { occ_join_points = join_points + , occ_bs_rng = bs_rng_vars }) + bndr_set + | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points) + | otherwise = (drop_shadowed_swaps env, emptyVarEnv) + where + drop_shadowed_swaps :: OccEnv -> OccEnv + -- See Note [The binder-swap substitution] (BS3) + drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env }) + | isEmptyVarEnv swap_env + = env + | bs_rng_vars `intersectsVarSet` bndr_set + = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet } + | otherwise + = env { occ_bs_env = swap_env `minusUFM` bndr_fm } + + drop_shadowed_joins :: OccEnv -> OccEnv + -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2) + drop_shadowed_joins env = env { occ_join_points = emptyVarEnv } + + -- bad_joins is true if it would be wrong to push occ_join_points inwards + -- (a) `bndrs` includes any of the occ_join_points + -- (b) `bndrs` includes any variables free in the RHSs of occ_join_points + bad_joins :: Bool + bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points + + bndr_fm :: UniqFM Var Var + bndr_fm = getUniqSet bndr_set + + is_bad :: Unique -> OccInfoEnv -> Bool -> Bool + is_bad uniq join_uds rest + = uniq `elemUniqSet_Directly` bndr_set || + not (bndr_fm `disjointUFM` join_uds) || + rest + +postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails +postprocess_uds bndrs bad_joins uds + = add_bad_joins (delBndrsFromUDs bndrs uds) + where + add_bad_joins :: UsageDetails -> UsageDetails + -- Add usage info for occ_join_points that we cannot push inwards + -- because of shadowing + -- See Note [Occurrence analysis for join points] wrinkle (W2) + add_bad_joins uds + | isEmptyVarEnv bad_joins = uds + | otherwise = modifyUDEnv extend_with_bad_joins uds + + extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv + extend_with_bad_joins env + = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins + + add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv + -- Behave like `andUDs` when adding in the bad_joins + add_bad_join uniq join_env env + | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env + | otherwise = env + +addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv +addJoinPoint env bndr rhs_uds + | isEmptyVarEnv zeroed_form + = env + | otherwise + = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form } + where + zeroed_form = mkZeroedForm rhs_uds + +mkZeroedForm :: UsageDetails -> OccInfoEnv +-- See Note [Occurrence analysis for join points] for "zeroed form" +mkZeroedForm (UD { ud_env = rhs_occs }) + = mapMaybeUFM do_one rhs_occs + where + do_one :: LocalOcc -> Maybe LocalOcc + do_one (ManyOccL {}) = Nothing + do_one occ@(OneOccL {}) = Just (occ { lo_n_br = 0 }) + +-------------------- +transClosureFV :: VarEnv VarSet -> VarEnv VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +-- as well as (f,g), (g,h) +transClosureFV env + | no_change = env + | otherwise = transClosureFV (listToUFM_Directly new_fv_list) + where + (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) + -- It's OK to use nonDetUFMToList here because we'll forget the + -- ordering by creating a new set with listToUFM + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + +extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) + where + extras :: VarSet -- env(s) + extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $ + -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes + intersectUFM_C (\x _ -> x) env (getUniqSet s) + +{- +************************************************************************ +* * + Binder swap +* * +************************************************************************ + +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +The "binder swap" transformation swaps occurrence of the +scrutinee of a case for occurrences of the case-binder: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> ri[b/x] } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> ri[b |> sym co/x] } + +The substitution ri[b/x] etc is done by the occurrence analyser. +See Note [The binder-swap substitution]. + +There are two reasons for making this swap: + +(A) It reduces the number of occurrences of the scrutinee, x. + That in turn might reduce its occurrences to one, so we + can inline it and save an allocation. E.g. + let x = factorial y in case x of b { I# v -> ...x... } + If we replace 'x' by 'b' in the alternative we get + let x = factorial y in case x of b { I# v -> ...b... } + and now we can inline 'x', thus + case (factorial y) of b { I# v -> ...b... } + +(B) The case-binder b has unfolding information; in the + example above we know that b = I# v. That in turn allows + nested cases to simplify. Consider + case x of b { I# v -> + ...(case x of b2 { I# v2 -> rhs })... + If we replace 'x' by 'b' in the alternative we get + case x of b { I# v -> + ...(case b of b2 { I# v2 -> rhs })... + and now it is trivial to simplify the inner case: + case x of b { I# v -> + ...(let b2 = b in rhs)... + + The same can happen even if the scrutinee is a variable + with a cast: see Note [Case of cast] + +The reason for doing these transformations /here in the occurrence +analyser/ is because it allows us to adjust the OccInfo for 'x' and +'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If instead the Simplifier replaces occurrences of x with + occurrences of b, that will mess up b's occurrence info. That in + turn might have consequences. + +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [The binder-swap substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binder-swap is implemented by the occ_bs_env field of OccEnv. +There are two main pieces: + +* Given case x |> co of b { alts } + we add [x :-> (b, sym co)] to the occ_bs_env environment; this is + done by addBndrSwap. + +* Then, at an occurrence of a variable, we look up in the occ_bs_env + to perform the swap. This is done by lookupBndrSwap. + +Some tricky corners: + +(BS1) We do the substitution before gathering occurrence info. So in + the above example, an occurrence of x turns into an occurrence + of b, and that's what we gather in the UsageDetails. It's as + if the binder-swap occurred before occurrence analysis. See + the computation of fun_uds in occAnalApp. + +(BS2) When doing a lookup in occ_bs_env, we may need to iterate, + as you can see implemented in lookupBndrSwap. Why? + Consider case x of a { 1# -> e1; DEFAULT -> + case x of b { 2# -> e2; DEFAULT -> + case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}} + At the first case addBndrSwap will extend occ_bs_env with + [x :-> a] + At the second case we occ-anal the scrutinee 'x', which looks up + 'x in occ_bs_env, returning 'a', as it should. + Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding + occ_bs_env = [x :-> a, a :-> b] + At the third case we'll again look up 'x' which returns 'a'. + But we don't want to stop the lookup there, else we'll end up with + case x of a { 1# -> e1; DEFAULT -> + case a of b { 2# -> e2; DEFAULT -> + case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}} + Instead, we want iterate the lookup in addBndrSwap, to give + case x of a { 1# -> e1; DEFAULT -> + case a of b { 2# -> e2; DEFAULT -> + case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}} + This makes a particular difference for case-merge, which works + only if the scrutinee is the case-binder of the immediately enclosing + case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils + See #19581 for the bug report that showed this up. + +(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, + and we encounter: + (i) \x. blah + Here we want to delete the x-binding from occ_bs_env + + (ii) \b. blah + This is harder: we really want to delete all bindings that + have 'b' free in the range. That is a bit tiresome to implement, + so we compromise. We keep occ_bs_rng, which is the set of + free vars of rng(occc_bs_env). If a binder shadows any of these + variables, we discard all of occ_bs_env. Safe, if a bit + brutal. NB, however: the simplifer de-shadows the code, so the + next time around this won't happen. + + These checks are implemented in addInScope. + (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623) + because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we + must not replace `x` by `...a...` under /\a. ...x..., or similarly + under a case pattern match that binds `a`. + + An alternative would be for the occurrence analyser to do cloning as + it goes. In principle it could do so, but it'd make it a bit more + complicated and there is no great benefit. The simplifer uses + cloning to get a no-shadowing situation, the care-when-shadowing + behaviour above isn't needed for long. + +(BS4) The domain of occ_bs_env can include GlobaIds. Eg + case M.foo of b { alts } + We extend occ_bs_env with [M.foo :-> b]. That's fine. + +(BS5) We have to apply the occ_bs_env substitution uniformly, + including to (local) rules and unfoldings. + +(BS6) For interest (only), + see Historical Note [Care with binder-swap on dictionaries] + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Historical Note [Care with binder-swap on dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is now out-dated; it has been rendered irrelevant by +Note [Unary class magic] in GHC.Core.TyCon. I'm leaving it here in +case we are every tempted to return to newtype classes. + +This (historical) Note explains why we need isDictId in scrutOkForBinderSwap. +Consider this tricky example (#21229, #21470): + + class Sing (b :: Bool) where sing :: Bool + instance Sing 'True where sing = True + instance Sing 'False where sing = False + + f :: forall a. Sing a => blah + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a dSing + +Now do a binder-swap on the case-expression: + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a (wild |> sym the_co) + +And now substitute `False` for `wild` (since wild=False in the False branch): + + h = \ @(a :: Bool) ($dSing :: Sing a) + let the_co = Main.N:Sing[0] :: Sing a ~R# Bool + case ($dSing |> the_co) of wild + True -> f @'True (True |> sym the_co) + False -> f @a (False |> sym the_co) + +And now we have a problem. The specialiser will specialise (f @a d)a (for all +vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using +Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise. + +The real problem is the binder-swap. It swaps a dictionary variable $dSing +(of kind Constraint) for a term variable wild (of kind Type). And that is +dangerous: a dictionary is a /singleton/ type whereas a general term variable is +not. In this particular example, Bool is most certainly not a singleton type! + +Conclusion: + for a /dictionary variable/ do not perform + the clever cast version of the binder-swap + +Hence the subtle isDictId in scrutOkForBinderSwap. + +Why this Note is now outdated. Using Note [Unary class magic] in GHC.Core.TyCon +the program above becomes + h = \ @(a :: Bool) ($dSing :: Sing a) + case sing @a $dSing of (wild::Bool) + True -> f @'True $dSing + False -> f @a $dSing +so the issue of binder-swapping doesn't arise. + +End of Historical Note. + +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> ...cb... } + +Core Lint never expects to find an *occurrence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See #5028. + +NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier +doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. + +-} + +addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [The binder-swap substitution] +addBndrSwap scrut case_bndr + env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) + | DoBinderSwap scrut_var mco <- scrutOkForBinderSwap scrut + , scrut_var /= case_bndr + -- Consider: case x of x { ... } + -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop + = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) + , occ_bs_rng = rng_vars `extendVarSet` case_bndr' + `unionVarSet` tyCoVarsOfMCo mco } + + | otherwise + = env + where + case_bndr' = zapIdOccInfo case_bndr + -- See Note [Zap case binders in proxy bindings] + +-- | See bBinderSwaOk. +data BinderSwapDecision + = NoBinderSwap + | DoBinderSwap OutVar MCoercion + +scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision +-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then +-- v = e |> mco +-- See Note [Case of cast] +-- See Historical Note [Care with binder-swap on dictionaries] +-- +-- We use this same function in SpecConstr, and Simplify.Iteration, +-- when something binder-swap-like is happening +scrutOkForBinderSwap e + = case e of + Tick _ e -> scrutOkForBinderSwap e -- Drop ticks + Var v -> DoBinderSwap v MRefl + Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co)) + -- Cast: see Note [Case of cast] + _ -> NoBinderSwap + +lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) +-- See Note [The binder-swap substitution] +-- Returns an expression of the same type as Id +lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr + = case lookupVarEnv bs_env bndr of { + Nothing -> (Var bndr, bndr) ; + Just (bndr1, mco) -> + + -- Why do we iterate here? + -- See (BS2) in Note [The binder-swap substitution] + case lookupBndrSwap env bndr1 of + (fun, fun_id) -> (mkCastMCo fun mco, fun_id) } + +{- Historical note [Proxy let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to do the binder-swap transformation by introducing +a proxy let-binding, thus; + + case x of b { pi -> ri } + ==> + case x of b { pi -> let x = b in ri } + +But that had two problems: + +1. If 'x' is an imported GlobalId, we'd end up with a GlobalId + on the LHS of a let-binding which isn't allowed. We worked + around this for a while by "localising" x, but it turned + out to be very painful #16296, + +2. In CorePrep we use the occurrence analyser to do dead-code + elimination (see Note [Dead code in CorePrep]). But that + occasionally led to an unlifted let-binding + case x of b { DEFAULT -> let x::Int# = b in ... } + which disobeys one of CorePrep's output invariants (no unlifted + let-bindings) -- see #5433. + +Doing a substitution (via occ_bs_env) is much better. + +Historical Note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressions when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical Note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. The straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. + + +************************************************************************ +* * +\subsection[OccurAnal-types]{OccEnv} +* * +************************************************************************ + +Note [UsageDetails and zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On many occasions, we must modify all gathered occurrence data at once. For +instance, all occurrences underneath a (non-one-shot) lambda set the +'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but +that takes O(n) time and we will do this often---in particular, there are many +places where tail calls are not allowed, and each of these causes all variables +to get marked with 'NoTailCallInfo'. + +Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along +with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" +recording which variables have been zapped in some way. Zapping all occurrence +info then simply means setting the corresponding zapped set to the whole +'OccInfoEnv', a fast O(1) operation. + +Note [LocalOcc] +~~~~~~~~~~~~~~~ +LocalOcc is used purely internally, in the occurrence analyser. It differs from +GHC.Types.Basic.OccInfo because it has only OneOcc and ManyOcc; it does not need +IAmDead or IAmALoopBreaker. + +Note that `OneOccL` doesn't meant that it occurs /syntactially/ only once; it +means that it is /used/ only once. It might occur syntactically many times. +For example, in (case x of A -> y; B -> y; C -> True), +* `y` is used only once +* but it occurs syntactically twice + +-} + +type OccInfoEnv = IdEnv LocalOcc -- A finite map from an expression's + -- free variables to their usage + +data LocalOcc -- See Note [LocalOcc] + = OneOccL { lo_n_br :: {-# UNPACK #-} !BranchCount -- Number of syntactic occurrences + , lo_tail :: !TailCallInfo + -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3) + -- gives NoTailCallInfo + , lo_int_cxt :: !InterestingCxt } + | ManyOccL !TailCallInfo + +instance Outputable LocalOcc where + ppr (OneOccL { lo_n_br = n, lo_tail = tci }) + = text "OneOccL" <> braces (ppr n <> comma <> ppr tci) + ppr (ManyOccL tci) = text "ManyOccL" <> braces (ppr tci) + +localTailCallInfo :: LocalOcc -> TailCallInfo +localTailCallInfo (OneOccL { lo_tail = tci }) = tci +localTailCallInfo (ManyOccL tci) = tci + +type ZappedSet = OccInfoEnv -- Values are ignored + +data UsageDetails + = UD { ud_env :: !OccInfoEnv + , ud_z_many :: !ZappedSet -- apply 'markMany' to these + , ud_z_in_lam :: !ZappedSet -- apply 'markInsideLam' to these + , ud_z_tail :: !ZappedSet -- zap tail-call info for these + } + -- INVARIANT: All three zapped sets are subsets of ud_env + +instance Outputable UsageDetails where + ppr ud@(UD { ud_env = env, ud_z_tail = z_tail }) + = text "UD" <+> (braces $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr (lookupOccInfoByUnique ud uq) + | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ]) + $$ nest 2 (text "ud_z_tail" <+> ppr z_tail) + where + do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)] + do_one uniq occ occs = (uniq, occ) : occs + +--------------------- +-- | TailUsageDetails captures the result of applying 'occAnalLamTail' +-- to a function `\xyz.body`. The TailUsageDetails pairs together +-- * the number of lambdas (including type lambdas: a JoinArity) +-- * UsageDetails for the `body` of the lambda, unadjusted by `adjustTailUsage`. +-- If the binding turns out to be a join point with the indicated join +-- arity, this unadjusted usage details is just what we need; otherwise we +-- need to discard tail calls. That's what `adjustTailUsage` does. +data TailUsageDetails = TUD !JoinArity !UsageDetails + +instance Outputable TailUsageDetails where + ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds + +--------------------- +data WithUsageDetails a = WUD !UsageDetails !a +data WithTailUsageDetails a = WTUD !TailUsageDetails !a + +------------------- +-- UsageDetails API + +andUDs, orUDs + :: UsageDetails -> UsageDetails -> UsageDetails +andUDs = combineUsageDetailsWith andLocalOcc +orUDs = combineUsageDetailsWith orLocalOcc + +mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc !env id int_cxt arity + | not (isLocalId id) + = emptyDetails + + | Just join_uds <- lookupVarEnv (occ_join_points env) id + = -- See Note [Occurrence analysis for join points] + assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $ + -- We only put non-empty join-points into occ_join_points + mkSimpleDetails (extendVarEnv join_uds id occ) + + | otherwise + = mkSimpleDetails (unitVarEnv id occ) + + where + occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt + , lo_tail = AlwaysTailCalled arity } + +-- Add several occurrences, assumed not to be tail calls +add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv +add_many_occ v env | isId v = extendVarEnv env v (ManyOccL NoTailCallInfo) + | otherwise = env + -- Give a non-committal binder info (i.e noOccInfo) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) + +addManyOccs :: UsageDetails -> VarSet -> UsageDetails +addManyOccs uds var_set + | isEmptyVarSet var_set = uds + | otherwise = uds { ud_env = add_to (ud_env uds) } + where + add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set + -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes + +addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails +-- Add any CoVars free in the type of a lambda-binder +-- See Note [Gather occurrences of coercion variables] +addLamCoVarOccs uds bndrs + = foldr add uds bndrs + where + add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr) + +emptyDetails :: UsageDetails +emptyDetails = mkSimpleDetails emptyVarEnv + +isEmptyDetails :: UsageDetails -> Bool +isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env + +mkSimpleDetails :: OccInfoEnv -> UsageDetails +mkSimpleDetails env = UD { ud_env = env + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_tail = emptyVarEnv } + +modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails +modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env } + +delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails +-- Delete these binders from the UsageDetails +delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many + , ud_z_in_lam = z_in_lam, ud_z_tail = z_tail }) + = UD { ud_env = env `delVarEnvList` bndrs + , ud_z_many = z_many `delVarEnvList` bndrs + , ud_z_in_lam = z_in_lam `delVarEnvList` bndrs + , ud_z_tail = z_tail `delVarEnvList` bndrs } + +markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail + :: UsageDetails -> UsageDetails +markAllMany ud@(UD { ud_env = env }) = ud { ud_z_many = env } +markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env } +markAllNonTail ud@(UD { ud_env = env }) = ud { ud_z_tail = env } +markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo + +markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails + +markAllInsideLamIf True ud = markAllInsideLam ud +markAllInsideLamIf False ud = ud + +markAllNonTailIf True ud = markAllNonTail ud +markAllNonTailIf False ud = ud + +lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo +lookupTailCallInfo uds id + | UD { ud_z_tail = z_tail, ud_env = env } <- uds + , not (id `elemVarEnv` z_tail) + , Just occ <- lookupVarEnv env id + = localTailCallInfo occ + | otherwise + = NoTailCallInfo + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env + +restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet +restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs + +------------------- +-- Auxiliary functions for UsageDetails implementation + +combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc) + -> UsageDetails -> UsageDetails -> UsageDetails +{-# INLINE combineUsageDetailsWith #-} +combineUsageDetailsWith plus_occ_info + uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 }) + uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 }) + | isEmptyVarEnv env1 = uds2 + | isEmptyVarEnv env2 = uds1 + | otherwise + = UD { ud_env = plusVarEnv_C plus_occ_info env1 env2 + , ud_z_many = plusVarEnv z_many1 z_many2 + , ud_z_in_lam = plusVarEnv z_in_lam1 z_in_lam2 + , ud_z_tail = plusVarEnv z_tail1 z_tail2 } + +lookupLetOccInfo :: UsageDetails -> Id -> OccInfo +-- Don't use locally-generated occ_info for exported (visible-elsewhere) +-- things. Instead just give noOccInfo. +-- NB: setBinderOcc will (rightly) erase any LoopBreaker info; +-- we are about to re-generate it and it shouldn't be "sticky" +lookupLetOccInfo ud id + | isExportedId id = noOccInfo + | otherwise = lookupOccInfoByUnique ud (idUnique id) + +lookupOccInfo :: UsageDetails -> Id -> OccInfo +lookupOccInfo ud id = lookupOccInfoByUnique ud (idUnique id) + +lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo +lookupOccInfoByUnique (UD { ud_env = env + , ud_z_many = z_many + , ud_z_in_lam = z_in_lam + , ud_z_tail = z_tail }) + uniq + = case lookupVarEnv_Directly env uniq of + Nothing -> IAmDead + Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt + , lo_tail = tail_info }) + | uniq `elemVarEnvByKey`z_many + -> ManyOccs { occ_tail = mk_tail_info tail_info } + | otherwise + -> OneOcc { occ_in_lam = in_lam + , occ_n_br = n_br + , occ_int_cxt = int_cxt + , occ_tail = mk_tail_info tail_info } + where + in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam + | otherwise = NotInsideLam + + Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info } + where + mk_tail_info ti + | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo + | otherwise = ti + + + +------------------- +-- See Note [Adjusting right-hand sides] + +adjustNonRecRhs :: JoinPointHood + -> WithTailUsageDetails CoreExpr + -> WithUsageDetails CoreExpr +-- ^ This function concentrates shared logic between occAnalNonRecBind and the +-- AcyclicSCC case of occAnalRec. +-- It returns the adjusted rhs UsageDetails combined with the body usage +adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs) + = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs + + +adjustTailUsage :: JoinPointHood + -> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail + -> UsageDetails +adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs) + = -- c.f. occAnal (Lam {}) + markAllInsideLamIf (not one_shot) $ + markAllNonTailIf (not exact_join) $ + uds + where + one_shot = isOneShotFun rhs + exact_join = mb_join_arity == JoinPoint rhs_ja + +adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails +adjustTailArity mb_rhs_ja (TUD ja usage) + = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage + +type IdWithOccInfo = Id + +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> [IdWithOccInfo] -- Tagged binders +tagLamBinders usage binders + = map (tagLamBinder usage) binders + +tagLamBinder :: UsageDetails -- Of scope + -> Id -- Binder + -> IdWithOccInfo -- Tagged binders +-- Used for lambda and case binders +-- No-op on TyVars +-- A lambda binder never has an unfolding, so no need to look for that +tagLamBinder usage bndr + = setBinderOcc (markNonTail occ) bndr + -- markNonTail: don't try to make an argument into a join point + where + occ = lookupOccInfo usage bndr + +tagNonRecBinder :: TopLevelFlag -- At top level? + -> OccInfo -- Of scope + -> CoreBndr -- Binder + -> (IdWithOccInfo, JoinPointHood) -- Tagged binder +-- No-op on TyVars +-- Precondition: OccInfo is not IAmDead +tagNonRecBinder lvl occ bndr + | okForJoinPoint lvl bndr tail_call_info + , AlwaysTailCalled ar <- tail_call_info + = (setBinderOcc occ bndr, JoinPoint ar) + | otherwise + = (setBinderOcc zapped_occ bndr, NotJoinPoint) + where + tail_call_info = tailCallInfo occ + zapped_occ = markNonTail occ + +tagRecBinders :: TopLevelFlag -- At top level? + -> UsageDetails -- Of body of let ONLY + -> [NodeDetails] + -> WithUsageDetails -- Adjusted details for whole scope, + -- with binders removed + [IdWithOccInfo] -- Tagged binders +-- Substantially more complicated than non-recursive case. Need to adjust RHS +-- details *before* tagging binders (because the tags depend on the RHSes). +tagRecBinders lvl body_uds details_s + = let + bndrs = map nd_bndr details_s + + -- 1. See Note [Join arity prediction based on joinRhsArity] + -- Determine possible join-point-hood of whole group, by testing for + -- manifest join arity M. + -- This (re-)asserts that makeNode had made tuds for that same arity M! + unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s + test_manifest_arity ND{nd_rhs = WTUD tuds rhs} + = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds + + will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs + + mb_join_arity :: Id -> JoinPointHood + -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity] + -- This is the source O + mb_join_arity bndr + -- Can't use willBeJoinId_maybe here because we haven't tagged + -- the binder yet (the tag depends on these adjustments!) + | will_be_joins + , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr + = JoinPoint arity + | otherwise + = assert (not will_be_joins) -- Should be AlwaysTailCalled if + NotJoinPoint -- we are making join points! + + -- 2. Adjust usage details of each RHS, taking into account the + -- join-point-hood decision + rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds + -- Matching occAnalLamTail in makeNode + | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ] + + -- 3. Compute final usage details from adjusted RHS details + adj_uds = foldr andUDs body_uds rhs_udss' + + -- 4. Tag each binder with its adjusted details + bndrs' = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr + | bndr <- bndrs ] + + in + WUD adj_uds bndrs' + +setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setBinderOcc occ_info bndr + | isTyVar bndr = bndr + | occ_info == idOccInfo bndr = bndr + | otherwise = setIdOccInfo bndr occ_info + +-- | Decide whether some bindings should be made into join points or not, based +-- on its occurrences. This is +-- Returns `False` if they can't be join points. Note that it's an +-- all-or-nothing decision, as if multiple binders are given, they're +-- assumed to be mutually recursive. +-- +-- It must, however, be a final decision. If we say `True` for 'f', +-- and then subsequently decide /not/ make 'f' into a join point, then +-- the decision about another binding 'g' might be invalidated if (say) +-- 'f' tail-calls 'g'. +-- +-- See Note [Invariants on join points] in "GHC.Core". +decideRecJoinPointHood :: TopLevelFlag -> UsageDetails + -> [CoreBndr] -> Bool +decideRecJoinPointHood lvl usage bndrs + = all ok bndrs -- Invariant 3: Either all are join points or none are + where + ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr) + +okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool + -- See Note [Invariants on join points]; invariants cited by number below. + -- Invariant 2 is always satisfiable by the simplifier by eta expansion. +okForJoinPoint lvl bndr tail_call_info + | isJoinId bndr -- A current join point should still be one! + = warnPprTrace lost_join "Lost join point" lost_join_doc $ + True + | valid_join + = True + | otherwise + = False + where + valid_join | NotTopLevel <- lvl + , AlwaysTailCalled arity <- tail_call_info + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = True + | otherwise + = False + + lost_join | JoinPoint ja <- idJoinPointHood bndr + = not valid_join || + (case tail_call_info of -- Valid join but arity differs + AlwaysTailCalled ja' -> ja /= ja' + _ -> False) + | otherwise = False + + ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans + ok_rule join_arity (Rule { ru_args = args }) + = args `lengthIs` join_arity + -- Invariant 1 as applied to LHSes of rules + + -- ok_unfolding returns False if we should /not/ convert a non-join-id + -- into a join-id, even though it is AlwaysTailCalled + ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) + = not (isStableSource src && join_arity > joinRhsArity rhs) + ok_unfolding _ (DFunUnfolding {}) + = False + ok_unfolding _ _ + = True + + lost_join_doc + = vcat [ text "bndr:" <+> ppr bndr + , text "tc:" <+> ppr tail_call_info + , text "rules:" <+> ppr (idCoreRules bndr) + , case tail_call_info of + AlwaysTailCalled arity -> + vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr)) + , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ] + _ -> empty ] + +{- Note [Join points and INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let g = \x. not -- Arity 1 + {-# INLINE g #-} + in case x of + A -> g True True + B -> g True False + C -> blah2 + +Here 'g' is always tail-called applied to 2 args, but the stable +unfolding captured by the INLINE pragma has arity 1. If we try to +convert g to be a join point, its unfolding will still have arity 1 +(since it is stable, and we don't meddle with stable unfoldings), and +Lint will complain (see Note [Invariants on join points], (2a), in +GHC.Core. #13413. + +Moreover, since g is going to be inlined anyway, there is no benefit +from making it a join point. + +If it is recursive, and uselessly marked INLINE, this will stop us +making it a join point, which is annoying. But occasionally +(notably in class methods; see Note [Instances and loop breakers] in +GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion +unravels; so ignoring INLINE pragmas on recursive things isn't good +either. + +See Invariant 2a of Note [Invariants on join points] in GHC.Core + + +************************************************************************ +* * +\subsection{Operations over OccInfo} +* * +************************************************************************ +-} + +markNonTail :: OccInfo -> OccInfo +markNonTail IAmDead = IAmDead +markNonTail occ = occ { occ_tail = NoTailCallInfo } + +andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc +andLocalOcc occ1 occ2 = ManyOccL (tci1 `andTailCallInfo` tci2) + where + !tci1 = localTailCallInfo occ1 + !tci2 = localTailCallInfo occ2 + +orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc +-- (orLocalOcc occ1 occ2) is used +-- when combining occurrence info from branches of a case +orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 }) + (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 }) + = OneOccL { lo_n_br = nbr1 + nbr2 + , lo_int_cxt = int_cxt1 `mappend` int_cxt2 + , lo_tail = tci1 `andTailCallInfo` tci2 } +orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2 andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) diff --git a/GHC/Core/Opt/Pipeline.hs b/GHC/Core/Opt/Pipeline.hs --- a/GHC/Core/Opt/Pipeline.hs +++ b/GHC/Core/Opt/Pipeline.hs @@ -22,7 +22,7 @@ import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) -import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) +import GHC.Core.Rules ( RuleBase, ruleCheckProgram, getRules ) import GHC.Core.Ppr ( pprCoreBindings ) import GHC.Core.Utils ( dumpIdInfoOfProgram ) import GHC.Core.Lint ( lintAnnots ) @@ -43,7 +43,7 @@ import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Opt.CallerCC ( addCallerCostCentres ) -import GHC.Core.LateCC (addLateCostCentresMG) +import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -76,7 +76,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc , mg_rdr_env = rdr_env }) - = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars + = do { hpt_rule_base <- home_pkg_rules + ; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars uniq_tag = 's' ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod @@ -96,11 +97,11 @@ where dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env extra_vars = interactiveInScope (hsc_IC hsc_env) - home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod - , gwib_isBoot = NotBoot }) - hpt_rule_base = mkRuleBase home_pkg_rules - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod) + (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot }) + name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to @@ -184,11 +185,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 +216,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 +278,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, @@ -463,12 +467,17 @@ let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } + -- Important to force this now as name_ppr_ctx lives through an entire phase in + -- the optimiser and if it's not forced then the entire previous `ModGuts` will + -- be retained until the end of the phase. (See #24328 for more analysis) + let !rdr_env = mg_rdr_env guts let name_ppr_ctx = mkNamePprCtx (initPromotionTickContext dflags) (hsc_unit_env hsc_env) - (mg_rdr_env guts) + rdr_env + case pass of CoreDoSimplify opts -> {-# SCC "Simplify" #-} liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts @@ -515,7 +524,7 @@ addCallerCostCentres guts CoreAddLateCcs -> {-# SCC "AddLateCcs" #-} - addLateCostCentresMG guts + topLevelBindsCCMG guts CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts @@ -567,7 +576,7 @@ , dmd_max_worker_args = maxWorkerArgs dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds - Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + Logger.putDumpFileMaybe logger Opt_D_dump_dmd_signatures "Demand signatures" FormatText $ dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds diff --git a/GHC/Core/Opt/SetLevels.hs b/GHC/Core/Opt/SetLevels.hs --- a/GHC/Core/Opt/SetLevels.hs +++ b/GHC/Core/Opt/SetLevels.hs @@ -15,7 +15,7 @@ outwards (@FloatOut@). 2. We also let-ify many expressions (notably case scrutinees), so they - will have a fighting chance of being floated sensible. + will have a fighting chance of being floated sensibly. 3. Note [Need for cloning during float-out] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -44,19 +44,39 @@ case x of wild { p -> ...wild... } we substitute x for wild in the RHS of the case alternatives: case x of wild { p -> ...x... } - This means that a sub-expression involving x is not "trapped" inside the RHS. + This means that a sub-expression involving x is not "trapped" inside the RHS + (i.e. it can now be floated out, whereas if it mentioned wild it could not). And it's not inconvenient because we already have a substitution. - Note that this is EXACTLY BACKWARDS from the what the simplifier does. - The simplifier tries to get rid of occurrences of x, in favour of wild, - in the hope that there will only be one remaining occurrence of x, namely - the scrutinee of the case, and we can inline it. + For example, consider: + + f x = letrec go y = case x of z { (a,b) -> ...(expensive z)... } + in ... + + If we do the reverse binder-swap we get + + f x = letrec go y = case x of z { (a,b) -> ...(expensive x)... } + in ... + + and now we can float out: + + f x = let t = expensive x + in letrec go y = case x of z { (a,b) -> ...(t)... } + in ... + + Now (expensive x) is computed once, rather than once each time around the 'go' loop. + + Note that this is EXACTLY BACKWARDS from the what the simplifier does. + The simplifier tries to get rid of occurrences of x, in favour of wild, + in the hope that there will only be one remaining occurrence of x, namely + the scrutinee of the case, and we can inline it. + -} module GHC.Core.Opt.SetLevels ( setLevels, - Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl, + Level(..), tOP_LEVEL, LevelledBind, LevelledExpr, LevelledBndr, FloatSpec(..), floatSpecLevel, @@ -67,12 +87,7 @@ import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) -import GHC.Core.Utils ( exprType, exprIsHNF - , exprOkForSpeculation - , exprIsTopLevelBindable - , collectMakeStaticArgs - , mkLamTypes, extendInScopeSetBndrs - ) +import GHC.Core.Utils import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr ) import GHC.Core.FVs -- all of it import GHC.Core.Subst @@ -110,7 +125,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Maybe @@ -130,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 @@ -170,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: @@ -197,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 @@ -223,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 {- ************************************************************************ @@ -302,7 +287,7 @@ -- there is no need call substAndLvlBndrs here lvl_top env is_rec bndr rhs = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr) - Nothing -- Not a join point + NotJoinPoint (freeVars rhs) ; return (stayPut tOP_LEVEL bndr, rhs') } @@ -402,7 +387,7 @@ -> CoreExprWithFVs -- Input expression -> LvlM LevelledExpr -- Result expression lvlNonTailExpr env expr - = lvlExpr (placeJoinCeiling env) expr + = lvlExpr env expr ------------------------------------------- lvlApp :: LevelEnv @@ -514,7 +499,7 @@ * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. - - exrpIsHNF catches the key case of an evaluated variable + - exprIsHNF catches the key case of an evaluated variable - exprOkForSpeculation is /false/ of an evaluated variable; See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils @@ -599,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] @@ -629,7 +614,9 @@ = lvlExpr env e -- See Note [Case MFEs] lvlMFE env strict_ctxt ann_expr - | floatTopLvlOnly env && not (isTopLvl dest_lvl) + | notWorthFloating expr abs_vars + || not float_me + || floatTopLvlOnly env && not (isTopLvl dest_lvl) -- Only floating to the top level is allowed. || hasFreeJoin env fvs -- If there is a free join, don't float -- See Note [Free join points] @@ -637,18 +624,16 @@ -- We can't let-bind an expression if we don't know -- how it will be represented at runtime. -- See Note [Representation polymorphism invariants] in GHC.Core - || notWorthFloating expr abs_vars - || not float_me - = -- Don't float it out + = -- Don't float it out lvlExpr env ann_expr | float_is_new_lam || exprIsTopLevelBindable expr expr_ty -- No wrapping needed if the type is lifted, or is a literal string -- or if we are wrapping it in one or more value lambdas = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive - is_bot_lam join_arity_maybe ann_expr + is_bot_lam NotJoinPoint ann_expr -- Treat the expr just like a right-hand side - ; var <- newLvlVar expr1 join_arity_maybe is_mk_static + ; var <- newLvlVar expr1 NotJoinPoint is_mk_static ; let var2 = annotateBotStr var float_n_lams mb_bot_str ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1) (mkVarApps (Var var2) abs_vars)) } @@ -669,7 +654,7 @@ Case expr1 (stayPut l1r ubx_bndr) box_ty [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))] - ; var <- newLvlVar float_rhs Nothing is_mk_static + ; var <- newLvlVar float_rhs NotJoinPoint is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty @@ -692,7 +677,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] @@ -706,28 +691,27 @@ (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars - join_arity_maybe = Nothing - is_mk_static = isJust (collectMakeStaticArgs expr) -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. + -- Never float trivial expressions; + -- notably, save_work might be true of a lone evaluated variable. float_me = saves_work || saves_alloc || is_mk_static - -- 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] + is_hnf = exprIsHNF expr + saves_work = escapes_value_lam -- (a) + && not is_hnf -- (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) - || exprIsHNF expr -- (b) + || is_hnf -- (b) || (is_bot_lam && escapes_value_lam)) -- (c) hasFreeJoin :: LevelEnv -> DVarSet -> Bool @@ -738,31 +722,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 literals 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 @@ -812,23 +871,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 = 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 @@ -955,6 +1067,11 @@ as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot argument. + Do /not/ do this for bottoming /join-point/ bindings. They may call other + join points (#24768), and floating to the top would abstract over those join + points, which we should never do. + + See Maessen's paper 1999 "Bottom extraction: factoring error handling out of functional programs" (unpublished I think). @@ -997,7 +1114,6 @@ either, so fusion will happen. It can be a big effect, esp in some artificial benchmarks (e.g. integer, queens), but there is no perfect answer. - -} annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id @@ -1014,111 +1130,142 @@ = id notWorthFloating :: CoreExpr -> [Var] -> Bool --- Returns True if the expression would be replaced by --- something bigger than it is now. For example: --- abs_vars = tvars only: return True if e is trivial, --- but False for anything bigger --- abs_vars = [x] (an Id): return True for trivial, or an application (f x) --- but False for (f x x) --- --- One big goal is that floating should be idempotent. Eg if --- we replace e with (lvl79 x y) and then run FloatOut again, don't want --- to replace (lvl79 x y) with (lvl83 x y)! - +-- See Note [notWorthFloating] notWorthFloating e abs_vars - = go e (count isId abs_vars) + = go e 0 where - go (Var {}) n = n >= 0 - go (Lit lit) n = assert (n==0) $ - litIsTrivial lit -- Note [Floating literals] - go (Tick t e) n = not (tickishIsCode t) && go e n - go (Cast e _) n = go e n + n_abs_vars = count isId abs_vars -- See (NWF5) + + go :: CoreExpr -> Int -> Bool + -- (go e n) return True if (e x1 .. xn) is not worth floating + -- where `e` has n trivial value arguments x1..xn + -- See (NWF4) + go (Lit lit) n = (n==0) -- See (NWF1b) + && litIsTrivial lit -- See (NWF1a) + go (Type {}) _ = True + go (Tick t e) n = not (tickishIsCode t) && go e n + go (Cast e _) n = n==0 || go e n -- See (NWF3) + go (Coercion {}) _ = True go (App e arg) n - -- See Note [Floating applications to coercions] - | Type {} <- arg = go e n - | n==0 = False - | is_triv arg = go e (n-1) - | otherwise = False - go _ _ = False + | Type {} <- arg = go e n -- Just types, not coercions (NWF2) + | exprIsTrivial arg = go e (n+1) + | otherwise = n==0 && exprIsUnaryClassFun e + -- (f non-triv) is worth floating, + -- unless if is a unary class fun + go (Case e b _ as) _ + -- Do not float the `case` part of trivial cases (NWF3) + -- We'll have a look at the RHS when we get there + | null as + = True -- See Note [Empty case is trivial] + | Just {} <- isUnsafeEqualityCase e b as + = True -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + | otherwise + = False - is_triv (Lit {}) = True -- Treat all literals as trivial - is_triv (Var {}) = True -- (ie not worth floating) - is_triv (Cast e _) = is_triv e - is_triv (App e (Type {})) = is_triv e -- See Note [Floating applications to coercions] - is_triv (Tick t e) = not (tickishIsCode t) && is_triv e - is_triv _ = False + go (Var v) n + | isUnaryClassId v = n==1 -- (op x) is not worth floating, but (op x y) is!! + -- See (NWF3) + | n==0 = True -- Naked variable + | n <= n_abs_vars = True -- (f a b c) is not worth floating if + | otherwise = False -- a,b,c are all abstracted; see (NWF5) -{- -Note [Floating literals] -~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to float Integer literals, so that they get shared, -rather than being allocated every time round the loop. -Hence the litIsTrivial. + go _ _ = False -- Let etc is worth floating -Ditto literal strings (LitString), which we'd like to float to top -level, which is now possible. +{- Note [notWorthFloating] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +`notWorthFloating` returns True if the expression would be replaced by something +bigger than it is now. One big goal is that floating should be idempotent. Eg +if we replace e with (lvl79 x y) and then run FloatOut again, don't want to +replace (lvl79 x y) with (lvl83 x y)! -Note [Floating applications to coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don’t float out variables applied only to type arguments, since the -extra binding would be pointless: type arguments are completely erased. -But *coercion* arguments aren’t (see Note [Coercion tokens] in -"GHC.CoreToStg" and Note [Count coercion arguments in boring contexts] in -"GHC.Core.Unfold"), so we still want to float out variables applied only to -coercion arguments. +For example: + abs_vars = tvars only: return True if e is trivial, + but False for anything bigger + abs_vars = [x] (an Id): return True for trivial, or an application (f x) + but False for (f x x) -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. +(NWF1a) It's important to float Integer literals, so that they get shared, rather + than being allocated every time round the loop. Hence the litIsTrivial. -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. + Ditto literal strings (LitString), which we'd like to float to top + level, which is now possible. -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. +(NWF1b) You might think that a literal should never be applied to a value + (hence n=0) but actually we can get (see test T23024): + RUBBISH @(a->b) (x::a) + See Note [Rubbish literals] in GHC.Types.Literal. (Mind you, we should be + in dead code at this point!) +(NWF2) We don’t float out variables applied only to type arguments, since the + extra binding would be pointless: type arguments are completely erased. + But *coercion* arguments aren’t (see Note [Coercion tokens] in + "GHC.CoreToStg" and Note [inlineBoringOk] in"GHC.Core.Unfold"), + so we still want to float out variables applied only to + coercion arguments. -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ +(NWF3) Some expressions have trivial wrappers: + - Casts (e |> co) + - Unary-class applications: + - Dictionary applications (MkC meth) + - Class-op applictions (op dict) + - Case of empty alts + - Unsafe-equality case + In all these cases we say "not worth floating", and we do so /regardless/ + of the wrapped expression. The SetLevels stuff may subsequently float the + components of the expression. -The binding stuff works for top level too. + Example: is it worth floating (f x |> co)? No! If we did we'd get + lvl = f x |> co + ...lvl.... + Then we'd do cast worker/wrapper and end up with. + lvl' = f x + ...(lvl' |> co)... + Silly! Better not to float it in the first place. If we say "no" here, + we'll subsequently say "yes" for (f x) and get + lvl = f x + ....(lvl |> co)... + which is what we want. In short: don't float trivial wrappers. + +(NWF4) The only non-trivial expression that we say "not worth floating" for + is an application + f x y z + where the number of value arguments is <= the number of abstracted Ids. + This is what makes floating idempotent. Hence counting the number of + value arguments in `go` + +(NWF5) In #24471 we had something like + x1 = I# 1 + ... + x1000 = I# 1000 + foo = f x1 (f x2 (f x3 ....)) + So every sub-expression in `foo` has lots and lots of free variables. But + none of these sub-expressions float anywhere; the entire float-out pass is a + no-op. + + So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where + it obviously /is/ worth floating. (In #24471 it turned out that we were + testing `abs_vars` (a relatively complicated calculation that takes at least + O(n-free-vars) time to compute) for every sub-expression.) + + Hence testing `n_abs_vars only` at the very end. -} +{- ********************************************************************* +* * + Bindings + This binding stuff works for top level too. +* * +********************************************************************* -} + lvlBind :: LevelEnv -> CoreBindWithFVs -> LvlM (LevelledBind, LevelEnv) 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) @@ -1129,7 +1276,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') } @@ -1137,7 +1284,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') } @@ -1148,32 +1295,27 @@ 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 - is_bot_lam = isJust mb_bot_str + is_bot_lam = not is_join && isJust mb_bot_str -- is_bot_lam: looks like (\xy. bot), maybe zero lams - -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) + -- NB: not isBottomThunk! + -- 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 - mb_join_arity = isJoinId_maybe bndr - is_join = isJust mb_join_arity + 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 (isJoinId_maybe b) r + lvl_rhs (b,r) = lvlRhs env' Recursive is_bot (idJoinPointHood b) r ; rhss' <- mapM lvl_rhs pairs ; return (Rec (bndrs' `zip` rhss'), env') } @@ -1206,7 +1348,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 $ @@ -1232,13 +1374,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 = Nothing - | otherwise = isJoinId_maybe 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]) @@ -1249,9 +1387,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 @@ -1264,7 +1434,7 @@ lvlRhs :: LevelEnv -> RecFlag -> Bool -- Is this a bottoming function - -> Maybe JoinArity + -> JoinPointHood -> CoreExprWithFVs -> LvlM LevelledExpr lvlRhs env rec_flag is_bot mb_join_arity expr @@ -1273,7 +1443,7 @@ lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag -> Bool -- Binding is for a bottoming function - -> Maybe JoinArity + -> JoinPointHood -> CoreExprWithFVs -> LvlM (Expr LevelledBndr) -- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline @@ -1284,17 +1454,16 @@ else lvlExpr body_env body ; return (mkLams bndrs' body') } where - (bndrs, body) | Just join_arity <- mb_join_arity + (bndrs, body) | JoinPoint join_arity <- mb_join_arity = collectNAnnBndrs join_arity rhs | otherwise = collectAnnBndrs rhs (env1, bndrs1) = substBndrsSL NonRecursive env bndrs all_bndrs = abs_vars ++ bndrs1 - (body_env, bndrs') | Just _ <- mb_join_arity + (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 @@ -1405,7 +1574,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) @@ -1420,20 +1588,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) @@ -1447,7 +1607,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 @@ -1518,8 +1677,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 @@ -1564,7 +1721,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 } @@ -1605,20 +1761,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 @@ -1647,11 +1796,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 @@ -1721,14 +1865,14 @@ -- but we may need to adjust its arity dest_is_top = isTopLvl dest_lvl transfer_join_info bndr new_bndr - | Just join_arity <- isJoinId_maybe bndr + | JoinPoint join_arity <- idJoinPointHood bndr , not dest_is_top = new_bndr `asJoinId` join_arity + length abs_vars | otherwise = new_bndr newLvlVar :: LevelledExpr -- The RHS of the new binding - -> Maybe JoinArity -- Its join arity, if it is a join point + -> JoinPointHood -- Its join arity, if it is a join point -> Bool -- True <=> the RHS looks like (makeStatic ...) -> LvlM Id newLvlVar lvld_rhs join_arity_maybe is_mk_static @@ -1752,11 +1896,10 @@ cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) new_lvl vs - = do { (subst', vs') <- cloneBndrs subst vs + = do { (subst', vs') <- cloneBndrsM subst vs -- N.B. We are not moving the body of the case, merely its case - -- binders. Consequently we should *not* set le_ctxt_lvl 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') } @@ -1773,10 +1916,9 @@ env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) dest_lvl vs = do { let vs1 = map zap vs - -- See Note [Zapping the demand info] ; (subst', vs2) <- case is_rec of - NonRecursive -> cloneBndrs subst vs1 - Recursive -> cloneRecIdBndrs subst vs1 + NonRecursive -> cloneBndrsM subst vs1 + Recursive -> cloneRecIdBndrsM subst vs1 ; let prs = vs `zip` vs2 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 @@ -1786,9 +1928,12 @@ ; return (env', vs2) } where zap :: Var -> Var - zap v | isId v = zap_join (zapIdDemandInfo v) + -- See Note [Floatifying demand info when floating] + -- and Note [Zapping JoinId when floating] + zap v | isId v = zap_join (floatifyIdDemandInfo v) | otherwise = v + -- See Note [Zapping JoinId when floating] zap_join | isTopLvl dest_lvl = zapJoinId | otherwise = id @@ -1797,16 +1942,38 @@ | isTyVar v = delVarEnv id_env v | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1) -{- -Note [Zapping the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -VERY IMPORTANT: we must zap the demand info if the thing is going to -float out, because it may be less demanded than at its original -binding site. Eg - f :: Int -> Int - f x = let v = 3*4 in v+x -Here v is strict; but if we float v to top level, it isn't any more. +{- Note [Zapping JoinId when floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we are floating a join point, it won't be one anymore, so we zap +the join point information. -Similarly, if we're floating a join point, it won't be one anymore, so we zap -join point information as well. +Note [Floatifying demand info when floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When floating we must lazify the outer demand info on the Id +because it may be less demanded than at its original binding site. +For example: + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict and used at most once; but if we float v to top level, +that isn't true any more. Specifically, we lose track of v's cardinality info: + * if `f` is called multiple times, then `v` is used more than once + * if `f` is never called, then `v` is never evaluated. + +But NOTE that we only need to adjust the /top-level/ cardinality info. +For example + let x = (e1,e2) + in ...(case x of (a,b) -> a+b)... +If we float x outwards, it may no longer be strict, but IF it is ever +evaluated THEN its components will be evaluated. So we to lazify and +many-ify its demand-info, not discard it entirely. + +Same if we have + let f = \x y . blah + in ...(f a b)...(f c d)... +Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can +keep that `1C` called-once inner demand. It's only the outer strictness +that we kill. + +Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the +fact that `v` may be used any number of times, from zero upwards. -} diff --git a/GHC/Core/Opt/Simplify.hs b/GHC/Core/Opt/Simplify.hs --- a/GHC/Core/Opt/Simplify.hs +++ b/GHC/Core/Opt/Simplify.hs @@ -17,7 +17,8 @@ import GHC.Core.Utils ( mkTicks, stripTicksTop ) import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) -import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding ) +import GHC.Core.Opt.Simplify.Utils ( activeRule ) +import GHC.Core.Opt.Simplify.Inline ( activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Stats ( simplCountN ) @@ -43,10 +44,6 @@ import Control.Monad import Data.Foldable ( for_ ) -#if __GLASGOW_HASKELL__ <= 810 -import GHC.Utils.Panic ( panic ) -#endif - {- ************************************************************************ * * @@ -202,7 +199,7 @@ -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 + return ( "Simplifier bailed out", iteration_no - 1 , totalise counts_so_far , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) @@ -285,9 +282,6 @@ -- Loop do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 } } -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "do_iteration" -#endif where -- Remember the counts_so_far are reversed totalise :: [SimplCount] -> SimplCount diff --git a/GHC/Core/Opt/Simplify/Env.hs b/GHC/Core/Opt/Simplify/Env.hs --- a/GHC/Core/Opt/Simplify/Env.hs +++ b/GHC/Core/Opt/Simplify/Env.hs @@ -8,29 +8,31 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - SimplMode(..), updMode, - smPedanticBottoms, smPlatform, + SimplMode(..), updMode, smPlatform, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, - seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seOptCoercionOpts, sePhase, sePlatform, sePreInline, seRuleOpts, seRules, seUnfoldingOpts, - mkSimplEnv, extendIdSubst, + mkSimplEnv, extendIdSubst, extendCvIdSubst, extendTvSubst, extendCvSubst, zapSubstEnv, setSubstEnv, bumpCaseDepth, getInScope, setInScopeFromE, setInScopeFromF, setInScopeSet, modifyInScope, addNewInScopeIds, getSimplRules, enterRecGroupRHSs, + reSimplifying, + SimplEnvIS, checkSimplEnvIS, pprBadSimplEnvIS, + -- * Substitution results SimplSR(..), mkContEx, substId, lookupRecBndr, -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, simplBinder, simplBinders, - substTy, substTyVar, getSubst, + substTy, substTyVar, getFullSubst, getTCvSubst, substCo, substCoVar, -- * Floats @@ -58,8 +60,9 @@ import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core import GHC.Core.Utils +import GHC.Core.Subst( substExprSC ) import GHC.Core.Unfold -import GHC.Core.TyCo.Subst (emptyIdSubstEnv) +import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst) import GHC.Core.Multiplicity( Scaled(..), mkMultMul ) import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo @@ -84,7 +87,6 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import Data.List ( intersperse, mapAccumL ) @@ -155,6 +157,17 @@ | Set by user | SimplMode | TopEnvConfig | | Computed on initialization | SimplEnv | SimplTopEnv | +Note [Inline depth] +~~~~~~~~~~~~~~~~~~~ +When we inline an /already-simplified/ unfolding, we +* Zap the substitution environment; the inlined thing is an OutExpr +* Bump the seInlineDepth in the SimplEnv +Both these tasks are done in zapSubstEnv. + +The seInlineDepth tells us how deep in inlining we are. Currently, +seInlineDepth is used for just one purpose: when we encounter a +coercion we don't apply optCoercion to it if seInlineDepth>0. +Reason: it has already been optimised once, no point in doing so again. -} data SimplEnv @@ -184,9 +197,26 @@ -- They are all OutVars, and all bound in this module , seInScope :: !InScopeSet -- OutVars only - , seCaseDepth :: !Int -- Depth of multi-branch case alternatives + , seCaseDepth :: !Int -- Depth of multi-branch case alternatives + + , seInlineDepth :: !Int -- 0 initially, 1 when we inline an already-simplified + -- unfolding, and simplify again; and so on + -- See Note [Inline depth] } +type SimplEnvIS = SimplEnv + -- Invariant: the substitution is empty + -- We want this SimplEnv for its InScopeSet and flags + +checkSimplEnvIS :: SimplEnvIS -> Bool +-- Check the invariant for SimplEnvIS +checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +pprBadSimplEnvIS :: SimplEnvIS -> SDoc +-- Print a SimplEnv that fails checkSimplEnvIS +pprBadSimplEnvIS env = ppr (getFullSubst (seInScope env) env) + seArityOpts :: SimplEnv -> ArityOpts seArityOpts env = sm_arity_opts (seMode env) @@ -220,9 +250,6 @@ seOptCoercionOpts :: SimplEnv -> OptCoercionOpts seOptCoercionOpts env = sm_co_opt_opts (seMode env) -sePedanticBottoms :: SimplEnv -> Bool -sePedanticBottoms env = smPedanticBottoms (seMode env) - sePhase :: SimplEnv -> CompilerPhase sePhase env = sm_phase (seMode env) @@ -277,9 +304,6 @@ where pp_flag f s = ppUnless f (text "no") <+> s -smPedanticBottoms :: SimplMode -> Bool -smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts) - smPlatform :: SimplMode -> Platform smPlatform opts = roPlatform (sm_rule_opts opts) @@ -377,7 +401,7 @@ -- | A substitution result. data SimplSR - = DoneEx OutExpr (Maybe JoinArity) + = DoneEx OutExpr JoinPointHood -- If x :-> DoneEx e ja is in the SimplIdSubst -- then replace occurrences of x by e -- and ja = Just a <=> x is a join-point of arity a @@ -402,8 +426,8 @@ ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e where pp_mj = case mj of - Nothing -> empty - Just n -> parens (int n) + NotJoinPoint -> empty + JoinPoint n -> parens (int n) ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] @@ -492,14 +516,15 @@ mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv mkSimplEnv mode fam_envs - = SimplEnv { seMode = mode - , seFamEnvs = fam_envs - , seInScope = init_in_scope - , seTvSubst = emptyVarEnv - , seCvSubst = emptyVarEnv - , seIdSubst = emptyVarEnv - , seRecIds = emptyUnVarSet - , seCaseDepth = 0 } + = SimplEnv { seMode = mode + , seFamEnvs = fam_envs + , seInScope = init_in_scope + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv + , seRecIds = emptyUnVarSet + , seCaseDepth = 0 + , seInlineDepth = 0 } -- The top level "enclosing CC" is "SUBSUMED". init_in_scope :: InScopeSet @@ -535,6 +560,9 @@ bumpCaseDepth :: SimplEnv -> SimplEnv bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 } +reSimplifying :: SimplEnv -> Bool +reSimplifying (SimplEnv { seInlineDepth = n }) = n>0 + --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res @@ -551,6 +579,10 @@ = assert (isCoVar var) $ env {seCvSubst = extendVarEnv csubst var co} +extendCvIdSubst :: SimplEnv -> Id -> OutExpr -> SimplEnv +extendCvIdSubst env bndr (Coercion co) = extendCvSubst env bndr co +extendCvIdSubst env bndr rhs = extendIdSubst env bndr (DoneEx rhs NotJoinPoint) + --------------------- getInScope :: SimplEnv -> InScopeSet getInScope env = seInScope env @@ -620,7 +652,12 @@ --------------------- zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} +-- See Note [Inline depth] +-- We call zapSubstEnv precisely when we are about to +-- simplify an already-simplified term +zapSubstEnv env@(SimplEnv { seInlineDepth = n }) + = env { seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv + , seInlineDepth = n+1 } setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } @@ -1237,34 +1274,47 @@ ************************************************************************ -} -getSubst :: SimplEnv -> Subst -getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env - , seCvSubst = cv_env }) - = mkSubst in_scope tv_env cv_env emptyIdSubstEnv +getTCvSubst :: SimplEnv -> Subst +getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = mkSubst in_scope emptyVarEnv tv_env cv_env +getFullSubst :: InScopeSet -> SimplEnv -> Subst +getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) + = mk_full_subst in_scope tv_env cv_env id_env + +mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst +mk_full_subst in_scope tv_env cv_env id_env + = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env + where + to_expr :: SimplSR -> CoreExpr + -- A tiresome impedence-matcher + to_expr (DoneEx e _) = e + to_expr (DoneId v) = Var v + to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e + substTy :: HasDebugCallStack => SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getSubst env) ty +substTy env ty = Type.substTy (getTCvSubst env) ty substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getSubst env) tv +substTyVar env tv = Type.substTyVar (getTCvSubst env) tv substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv - = case Type.substTyVarBndr (getSubst env) tv of + = case Type.substTyVarBndr (getTCvSubst env) tv of (Subst in_scope' _ tv_env' cv_env', tv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv') substCoVar :: SimplEnv -> CoVar -> Coercion -substCoVar env tv = Coercion.substCoVar (getSubst env) tv +substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) substCoVarBndr env cv - = case Coercion.substCoVarBndr (getSubst env) cv of + = case Coercion.substCoVarBndr (getTCvSubst env) cv of (Subst in_scope' _ tv_env' cv_env', cv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') substCo :: SimplEnv -> Coercion -> Coercion -substCo env co = Coercion.substCo (getSubst env) co +substCo env co = Coercion.substCo (getTCvSubst env) co ------------------ substIdType :: SimplEnv -> Id -> Id @@ -1280,4 +1330,4 @@ no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w subst = Subst in_scope emptyIdSubstEnv tv_env cv_env old_ty = idType id - old_w = varMult id + old_w = idMult id diff --git a/GHC/Core/Opt/Simplify/Inline.hs b/GHC/Core/Opt/Simplify/Inline.hs --- a/GHC/Core/Opt/Simplify/Inline.hs +++ b/GHC/Core/Opt/Simplify/Inline.hs @@ -6,12 +6,11 @@ -} -{-# LANGUAGE BangPatterns #-} module GHC.Core.Opt.Simplify.Inline ( -- * Cheap and cheerful inlining checks. couldBeSmallEnoughToInline, - smallEnoughToInline, + smallEnoughToInline, activeUnfolding, -- * The smart inlining decisions are made by callSiteInline callSiteInline, CallCtxt(..), @@ -21,10 +20,16 @@ import GHC.Driver.Flags +import GHC.Core.Opt.Simplify.Env + import GHC.Core import GHC.Core.Unfold +import GHC.Core.FVs( exprFreeIds ) + import GHC.Types.Id -import GHC.Types.Basic ( Arity, RecFlag(..) ) +import GHC.Types.Var.Env( InScopeSet, lookupInScope ) +import GHC.Types.Var.Set +import GHC.Types.Basic ( Arity, RecFlag(..), isActive ) import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable @@ -87,16 +92,14 @@ StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: Logger - -> UnfoldingOpts - -> Int -- Case depth +callSiteInline :: SimplEnv + -> Logger -> Id -- The Id - -> Bool -- True <=> unfolding is active -> Bool -- True if there are no arguments at all (incl type args) -> [ArgSummary] -- One for each value arg; True if it is interesting -> CallCtxt -- True <=> continuation is interesting -> Maybe CoreExpr -- Unfolding, if any -callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_infos cont_info +callSiteInline env logger id lone_variable arg_infos cont_info = case idUnfolding id of -- idUnfolding checks for loop-breakers, returning NoUnfolding -- Things with an INLINE pragma may have an unfolding *and* @@ -104,15 +107,31 @@ CoreUnfolding { uf_tmpl = unf_template , uf_cache = unf_cache , uf_guidance = guidance } - | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable + | active_unf -> tryUnfolding env logger id lone_variable arg_infos cont_info unf_template unf_cache guidance - | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing + | otherwise -> traceInline logger uf_opts id "Inactive unfolding:" (ppr id) Nothing NoUnfolding -> Nothing BootUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun + where + uf_opts = seUnfoldingOpts env + active_unf = activeUnfolding (seMode env) id +activeUnfolding :: SimplMode -> Id -> Bool +activeUnfolding mode id + | isCompulsoryUnfolding (realIdUnfolding id) + = True -- Even sm_inline can't override compulsory unfoldings + | otherwise + = isActive (sm_phase mode) (idInlineActivation id) + && sm_inline mode + -- `or` isStableUnfolding (realIdUnfolding id) + -- Inline things when + -- (a) they are active + -- (b) sm_inline says so, except that for stable unfoldings + -- (ie pragmas) we inline anyway + -- | Report the inlining of an identifier's RHS to the user, if requested. traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a traceInline logger opts inline_id str doc result @@ -133,8 +152,9 @@ {- Note [Avoid inlining into deeply nested cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Also called "exponential inlining". -Consider a function f like this: +Consider a function f like this: (#18730) f arg1 arg2 = case ... @@ -145,46 +165,44 @@ However sometimes this doesn't quite work out like that. Consider this code: -f1 arg1 arg2 ... = ... - case _foo of - alt1 -> ... f2 arg1 ... - alt2 -> ... f2 arg2 ... + f1 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f2 arg1 ... + alt2 -> ... f2 arg2 ... -f2 arg1 arg2 ... = ... - case _foo of - alt1 -> ... f3 arg1 ... - alt2 -> ... f3 arg2 ... + f2 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f3 arg1 ... + alt2 -> ... f3 arg2 ... -f3 arg1 arg2 ... = ... + f3 arg1 arg2 ... = ... -... repeats up to n times. And then f1 is -applied to some arguments: + ... repeats up to n times. And then f1 is + applied to some arguments: -foo = ... f1 ... + foo = ... f1 ... -Initially f2..fn are not interesting to inline so we don't. -However we see that f1 is applied to interesting args. -So it's an obvious choice to inline those: +Initially f2..fn are not interesting to inline so we don't. However we see +that f1 is applied to interesting args. So it's an obvious choice to inline +those: -foo = - ... - case _foo of - alt1 -> ... f2 ... - alt2 -> ... f2 ... + foo = ... + case _foo of + alt1 -> ... f2 ... + alt2 -> ... f2 ... -As a result we go and inline f2 both mentions of f2 in turn are now applied to interesting -arguments and f2 is small: +As a result we go and inline f2 both mentions of f2 in turn are now applied to +interesting arguments and f2 is small: -foo = - ... - case _foo of - alt1 -> ... case _foo of - alt1 -> ... f3 ... - alt2 -> ... f3 ... + foo = ... + case _foo of + alt1 -> ... case _foo of + alt1 -> ... f3 ... + alt2 -> ... f3 ... - alt2 -> ... case _foo of - alt1 -> ... f3 ... - alt2 -> ... f3 ... + alt2 -> ... case _foo of + alt1 -> ... f3 ... + alt2 -> ... f3 ... The same thing happens for each binding up to f_n, duplicating the amount of inlining done in each step. Until at some point we are either done or run out of simplifier @@ -201,19 +219,73 @@ * We can ignore the first n levels of case nestings for inlining decisions using -funfolding-case-threshold. -* The penalty grows linear with the depth. It's computed as size*(depth-threshold)/scaling. + +* The penalty grows linear with the depth. It's computed as + size*(depth-threshold)/scaling. Scaling can be set with -funfolding-case-scaling. +Reflections and wrinkles + +* See also Note [Do not add unfoldings to join points at birth] in + GHC.Core.Opt.Simplify.Iteration + +* The total case depth is really the wrong thing; it will inhibit inlining of a + local function, just because there is some giant case nest further out. What we + want is the /difference/ in case-depth between the binding site and the call site. + That could be done quite easily by adding the case-depth to the Unfolding of the + function. + +* What matters more than /depth/ is total /width/; that is how many alternatives + are in the tree. We could perhaps multiply depth by width at each case expression. + +* There might be a case nest with many alternatives, but the function is called in + only a handful of them. So maybe we should ignore case-depth, and instead penalise + funtions that are called many times -- after all, inlining them bloats code. + + But in the scenario above, we are simplifying an inlined fuction, without doing a + global occurrence analysis each time. So if we based the penalty on multiple + occurences, we should /also/ add a penalty when simplifying an already-simplified + expression. We do track this (seInlineDepth) but currently we barely use it. + + An advantage of using occurrences+inline depth is that it'll work when no + case expressions are involved. See #15488. + +* Test T18730 did not involve join points. But join points are very prone to + the same kind of thing. For exampe in #13253, and several related tickets, + we got an exponential blowup in code size from a program that looks like + this. + + let j1a x = case f y of { True -> p; False -> q } + j1b x = case f y of { True -> q; False -> p } + j2a x = case f (y+1) of { True -> j1a x; False -> j1b x} + j2b x = case f (y+1) of { True -> j1b x; False -> j1a x} + ... + in case f (y+10) of { True -> j10a 7; False -> j10b 8 } + + The first danger is this: in Simplifier iteration 1 postInlineUnconditionally + inlines the last functions, j10a and j10b (they are both small). Now we have + two calls to j9a and two to j9b. In the next Simplifer iteration, + postInlineUnconditionally inlines all four of these calls, leaving four calls + to j8a and j8b. Etc. + + Happily, this probably /won't/ happen because the Simplifier works top down, so it'll + inline j1a/j1b into j2a/j2b, which will make the latter bigger; so the process + will stop. But we still need to stop the inline cascade described at the head + of this Note. + Some guidance on setting these defaults: -* A low treshold (<= 2) is needed to prevent exponential cases from spiraling out of +* A low threshold (<= 2) is needed to prevent exponential cases from spiraling out of control. We picked 2 for no particular reason. + * Scaling the penalty by any more than 30 means the reproducer from T18730 won't compile even with reasonably small values of n. Instead it will run out of runs/ticks. This means to positively affect the reproducer a scaling <= 30 is required. + * A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks. (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps) + * A scaling of >= 25 showed no regressions on nofib. However it showed a number of (small) regression for compiler perf benchmarks. @@ -222,15 +294,15 @@ will still avoid this pattern sometimes. This is a "safe" default, where we err on the side of compiler blowup instead of risking runtime regressions. -For cases where the default falls short the flag can be changed to allow more/less inlining as -needed on a per-module basis. +For cases where the default falls short the flag can be changed to allow +more/less inlining as needed on a per-module basis. -} -tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt +tryUnfolding :: SimplEnv -> Logger -> Id -> Bool -> [ArgSummary] -> CallCtxt -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance -> Maybe CoreExpr -tryUnfolding logger opts !case_depth id lone_variable arg_infos +tryUnfolding env logger id lone_variable arg_infos cont_info unf_template unf_cache guidance = case guidance of UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing @@ -242,31 +314,53 @@ | otherwise -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing where - some_benefit = calc_some_benefit uf_arity + some_benefit = calc_some_benefit uf_arity True enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } - | unfoldingVeryAggressive opts - -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template) - | is_wf && some_benefit && small_enough - -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template) - | otherwise - -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing + | isJoinId id, small_enough -> inline_join_point + | unfoldingVeryAggressive opts -> yes + | is_wf, some_benefit, small_enough -> yes + | otherwise -> no where - some_benefit = calc_some_benefit (length arg_discounts) - -- See Note [Avoid inlining into deeply nested cases] - depth_treshold = unfoldingCaseThreshold opts - depth_scaling = unfoldingCaseScaling opts - depth_penalty | case_depth <= depth_treshold = 0 - | otherwise = (size * (case_depth - depth_treshold)) `div` depth_scaling + yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template) + no = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing + + some_benefit = calc_some_benefit (length arg_discounts) False + + -- depth_penalty: see Note [Avoid inlining into deeply nested cases] + depth_threshold = unfoldingCaseThreshold opts + depth_scaling = unfoldingCaseScaling opts + depth_penalty | case_depth <= depth_threshold = 0 + | otherwise = (size * (case_depth - depth_threshold)) `div` depth_scaling + adjusted_size = size + depth_penalty - discount small_enough = adjusted_size <= unfoldingUseThreshold opts discount = computeDiscount arg_discounts res_discount arg_infos cont_info - extra_doc = vcat [ text "case depth =" <+> int case_depth + extra_doc = vcat [ ppWhen (isJoinId id) $ + text "join" <+> fsep [ ppr (v, hasCoreUnfolding (idUnfolding v) + , fmap (isEvaldUnfolding . idUnfolding) (lookupInScope in_scope v) + , is_more_evald in_scope v) + | v <- vselems (exprFreeIds unf_template) ] , text "depth based penalty =" <+> int depth_penalty - , text "discounted size =" <+> int adjusted_size ] + , text "adjusted size =" <+> int adjusted_size ] + + inline_join_point -- See Note [Inlining join points] + | or (zipWith scrut_arg arg_discounts arg_infos) = yes + | anyVarSet (is_more_evald in_scope) $ + exprFreeIds unf_template = yes + | otherwise = no + -- scrut_arg is True if the function body has a discount and the arg is a value + scrut_arg disc ValueArg = disc > 0 + scrut_arg _ _ = False + where + opts = seUnfoldingOpts env + case_depth = seCaseDepth env + inline_depth = seInlineDepth env + in_scope = seInScope env + -- Unpack the UnfoldingCache lazily because it may not be needed, and all -- its fields are strict; so evaluating unf_cache at all forces all the -- isWorkFree etc computations to take place. That risks wasting effort for @@ -281,6 +375,8 @@ , text "is exp:" <+> ppr is_exp , text "is work-free:" <+> ppr is_wf , text "guidance" <+> ppr guidance + , text "case depth =" <+> int case_depth + , text "inline depth =" <+> int inline_depth , extra_doc , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] @@ -293,9 +389,9 @@ -- arguments (ie n_val_args >= arity). But there must -- be *something* interesting about some argument, or the -- result context, to make it worth inlining - calc_some_benefit :: Arity -> Bool -- The Arity is the number of args + calc_some_benefit :: Arity -> Bool -> Bool -- The Arity is the number of args -- expected by the unfolding - calc_some_benefit uf_arity + calc_some_benefit uf_arity is_inline | not saturated = interesting_args -- Under-saturated -- Note [Unsaturated applications] | otherwise = interesting_args -- Saturated or over-saturated @@ -317,11 +413,23 @@ ValAppCtxt -> True -- Note [Cast then apply] RuleArgCtxt -> uf_arity > 0 -- See Note [RHS of lets] DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - RhsCtxt NonRecursive + RhsCtxt NonRecursive | is_inline -> uf_arity > 0 -- See Note [RHS of lets] _other -> False -- See Note [Nested functions] +vselems :: VarSet -> [Var] +vselems s = nonDetStrictFoldVarSet (\v vs -> v : vs) [] s + +is_more_evald :: InScopeSet -> Id -> Bool +-- See Note [Inlining join points] +is_more_evald in_scope v + | Just v1 <- lookupInScope in_scope v + , idUnfolding v1 `isBetterUnfoldingThan` idUnfolding v + = True + | otherwise + = False + {- Note [RHS of lets] ~~~~~~~~~~~~~~~~~~~~~ When the call is the argument of a function with a RULE, or the RHS of a let, @@ -339,6 +447,94 @@ /non-recursive/ let as not-totally-boring. A /recursive/ let isn't going be inlined so there is much less point. Hence the (only reason for the) RecFlag in RhsCtxt + +We inline only if `f` has an `UnfWhen` guidance. I found that being more eager +led to fruitless inlining. See Note [Seq is boring] wrinkle (SB1) in +GHC.Core.Opt.Simplify.Utils. + +Note [Inlining join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we /do not/ want to inline join points /even if they are small/. +See Note [Duplicating join points] in GHC.Core.Opt.Simplify.Iteration. + +But, assuming it is small, there are various times when we /do/ want to +inline a (non-recursive) join point. Namely, if either of these hold: + +(1) A /scrutinised/ argument (non-zero discount) has a /ValueArg/ info. + Inlining will give some benefit. + +(2) A free variable of the RHS is + * Is /not/ evaluated at the join point defn site + * Is evaluated at the join point call site. + This is the is_more_evald predicate. + +(1) is fairly obvious but (2) is less so. Here is the code for `integerGT` +without (2): + + integerGt = \ (x :: Integer) (y :: Integer) -> + join fail _ = case x of { + IS x1 -> case y of { + IS y1 -> case <# x1 y1 of + _DEFAULT -> case ==# x1 y1 of + DEFAULT -> True; + 1# -> False + 1# -> False + IP ds1 -> False + IN ds1 -> True + + IP x1 -> case y of { + _DEFAULT -> True; + IP y1 -> case bigNatCompare x1 y1 of + _DEFAULT -> False; + GT -> True + IN x1 -> case y of { + _DEFAULT -> False; + IN y1 -> case bigNatCompare y1 x1 of + _DEFAULT -> False; + GT -> True + in case x of { + _DEFAULT -> jump fail GHC.Prim.(##); + IS x1 -> case y of { + _DEFAULT -> jump fail GHC.Prim.(##); + IS y1 -> tagToEnum# @Bool (># x1 y1) + +If we inline `fail` we get /much/ better code. The only clue is that +`x` and `y` (a) are not evaluated at the definition site, and (b) are +evaluated at the call site. This predicate is `isBetterUnfoldingThan`. + +You might think that the variable should also be /scrutinised/ in the +join-point RHS, but here are two reasons for not taking that into +account. + +First, we see code somewhat like this in imaginary/wheel-sieve1: + let x = in + join $j = (x,y) in + case z of + A -> case x of + P -> $j + Q -> blah + B -> (x,x) + C -> True +Here `x` can't be duplicated into the branches becuase it is used +in both the join point and the A branch. But if we inline $j we get + let x = in + case z of + A -> case x of x' + P -> (x', y) + Q -> blah + B -> x + C -> True +and now we /can/ duplicate x into the branches, at which point: + * it is used strictly in the A branch (evaluated, but no thunk) + * it is used lazily in the B branch (still a thunk) + * it is not used at all in the C branch (no thunk) + +Second, spectral/treejoin gets a big win from SpecConstr due +to evaluated-ness. Something like this: + join $j x = ...(foo fv)... + in case fv of I# x -> + ... jump $j True ... +If we inline $j, SpecConstr sees a call (foo (I# x)) and specialises. Note [Unsaturated applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs --- a/GHC/Core/Opt/Simplify/Iteration.hs +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -8,4500 +8,4805 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiWayIf #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where - -import GHC.Prelude - -import GHC.Platform - -import GHC.Driver.Flags - -import GHC.Core -import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Opt.ConstantFold -import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) -import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Simplify.Inline -import GHC.Core.Opt.Simplify.Utils -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutBinderSwap_maybe ) -import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) -import qualified GHC.Core.Make -import GHC.Core.Coercion hiding ( substCo, substCoVar ) -import GHC.Core.Reduction -import GHC.Core.Coercion.Opt ( optCoercion ) -import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) -import GHC.Core.DataCon - ( DataCon, dataConWorkId, dataConRepStrictness - , dataConRepArgTys, isUnboxedTupleDataCon - , StrictnessMark (..) ) -import GHC.Core.Opt.Stats ( Tick(..) ) -import GHC.Core.Ppr ( pprCoreExpr ) -import GHC.Core.Unfold -import GHC.Core.Unfold.Make -import GHC.Core.Utils -import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe - , pushCoTyArg, pushCoValArg, exprIsDeadEnd - , typeArity, arityTypeArity, etaExpandAT ) -import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) -import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Rules ( lookupRule, getRules ) -import GHC.Core.Multiplicity - -import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 -import GHC.Types.SourceText -import GHC.Types.Id -import GHC.Types.Id.Make ( seqId ) -import GHC.Types.Id.Info -import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) -import GHC.Types.Demand -import GHC.Types.Unique ( hasKey ) -import GHC.Types.Basic -import GHC.Types.Tickish -import GHC.Types.Var ( isTyCoVar ) -import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) -import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) -import GHC.Builtin.Names( runRWKey ) - -import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) -import GHC.Data.FastString -import GHC.Unit.Module ( moduleName ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Monad ( mapAccumLM, liftIO ) -import GHC.Utils.Logger -import GHC.Utils.Misc - -import Control.Monad - -{- -The guts of the simplifier is in this module, but the driver loop for -the simplifier is in GHC.Core.Opt.Pipeline - -Note [The big picture] -~~~~~~~~~~~~~~~~~~~~~~ -The general shape of the simplifier is this: - - simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - - * SimplEnv contains - - Simplifier mode - - Ambient substitution - - InScopeSet - - * SimplFloats contains - - Let-floats (which includes ok-for-spec case-floats) - - Join floats - - InScopeSet (including all the floats) - - * Expressions - simplExpr :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - The result of simplifying an /expression/ is (floats, expr) - - A bunch of floats (let bindings, join bindings) - - A simplified expression. - The overall result is effectively (let floats in expr) - - * Bindings - simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) - The result of simplifying a binding is - - A bunch of floats, the last of which is the simplified binding - There may be auxiliary bindings too; see prepareRhs - - An environment suitable for simplifying the scope of the binding - - The floats may also be empty, if the binding is inlined unconditionally; - in that case the returned SimplEnv will have an augmented substitution. - - The returned floats and env both have an in-scope set, and they are - guaranteed to be the same. - -Eta expansion -~~~~~~~~~~~~~~ -For eta expansion, we want to catch things like - - case e of (a,b) -> \x -> case a of (p,q) -> \y -> r - -If the \x was on the RHS of a let, we'd eta expand to bring the two -lambdas together. And in general that's a good thing to do. Perhaps -we should eta expand wherever we find a (value) lambda? Then the eta -expansion at a let RHS can concentrate solely on the PAP case. - -Note [In-scope set as a substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Lookups in in-scope set], an in-scope set can act as -a substitution. Specifically, it acts as a substitution from variable to -variables /with the same unique/. - -Why do we need this? Well, during the course of the simplifier, we may want to -adjust inessential properties of a variable. For instance, when performing a -beta-reduction, we change - - (\x. e) u ==> let x = u in e - -We typically want to add an unfolding to `x` so that it inlines to (the -simplification of) `u`. - -We do that by adding the unfolding to the binder `x`, which is added to the -in-scope set. When simplifying occurrences of `x` (every occurrence!), they are -replaced by their “updated” version from the in-scope set, hence inherit the -unfolding. This happens in `SimplEnv.substId`. - -Another example. Consider - - case x of y { Node a b -> ...y... - ; Leaf v -> ...y... } - -In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we -want y's unfolding to be (Leaf v). We achieve this by adding the appropriate -unfolding to y, and re-adding it to the in-scope set. See the calls to -`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. - -It's quite convenient. This way we don't need to manipulate the substitution all -the time: every update to a binder is automatically reflected to its bound -occurrences. - -Note [Bangs in the Simplifier] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Both SimplFloats and SimplEnv do *not* generally benefit from making -their fields strict. I don't know if this is because of good use of -laziness or unintended side effects like closures capturing more variables -after WW has run. - -But the end result is that we keep these lazy, but force them in some places -where we know it's beneficial to the compiler. - -Similarly environments returned from functions aren't *always* beneficial to -force. In some places they would never be demanded so forcing them early -increases allocation. In other places they almost always get demanded so -it's worthwhile to force them early. - -Would it be better to through every allocation of e.g. SimplEnv and decide -wether or not to make this one strict? Absolutely! Would be a good use of -someones time? Absolutely not! I made these strict that showed up during -a profiled build or which I noticed while looking at core for one reason -or another. - -The result sadly is that we end up with "random" bangs in the simplifier -where we sometimes force e.g. the returned environment from a function and -sometimes we don't for the same function. Depending on the context around -the call. The treatment is also not very consistent. I only added bangs -where I saw it making a difference either in the core or benchmarks. Some -patterns where it would be beneficial aren't convered as a consequence as -I neither have the time to go through all of the core and some cases are -too small to show up in benchmarks. - - - -************************************************************************ -* * -\subsection{Bindings} -* * -************************************************************************ --} - -simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) --- See Note [The big picture] -simplTopBinds env0 binds0 - = do { -- Put all the top-level binders into scope at the start - -- so that if a rewrite rule has unexpectedly brought - -- anything into scope, then we don't get a complaint about that. - -- It's rather as if the top-level binders were imported. - -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". - -- See Note [Bangs in the Simplifier] - ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) - ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 - ; freeTick SimplifierDone - ; return (floats, env2) } - where - -- We need to track the zapped top-level binders, because - -- they should have their fragile IdInfo zapped (notably occurrence info) - -- That's why we run down binds and bndrs' simultaneously. - -- - simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) - simpl_binds env [] = return (emptyFloats env, env) - simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind - ; (floats, env2) <- simpl_binds env1 binds - -- See Note [Bangs in the Simplifier] - ; let !floats1 = float `addFloats` floats - ; return (floats1, env2) } - - simpl_bind env (Rec pairs) - = simplRecBind env (BC_Let TopLevel Recursive) pairs - simpl_bind env (NonRec b r) - = do { let bind_cxt = BC_Let TopLevel NonRecursive - ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt - ; simplRecOrTopPair env' bind_cxt b b' r } - -{- -************************************************************************ -* * - Lazy bindings -* * -************************************************************************ - -simplRecBind is used for - * recursive bindings only --} - -simplRecBind :: SimplEnv -> BindContext - -> [(InId, InExpr)] - -> SimplM (SimplFloats, SimplEnv) -simplRecBind env0 bind_cxt pairs0 - = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 - ; let new_bndrs = map sndOf3 triples - ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> - go env triples - ; return (mkRecFloats rec_floats, env2) } - where - add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) - -- Add the (substituted) rules to the binder - add_rules env (bndr, rhs) - = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt - ; return (env', (bndr, bndr', rhs)) } - - go env [] = return (emptyFloats env, env) - - go env ((old_bndr, new_bndr, rhs) : pairs) - = do { (float, env1) <- simplRecOrTopPair env bind_cxt - old_bndr new_bndr rhs - ; (floats, env2) <- go env1 pairs - ; return (float `addFloats` floats, env2) } - -{- -simplOrTopPair is used for - * recursive bindings (whether top level or not) - * top-level non-recursive bindings - -It assumes the binder has already been simplified, but not its IdInfo. --} - -simplRecOrTopPair :: SimplEnv - -> BindContext - -> InId -> OutBndr -> InExpr -- Binder and rhs - -> SimplM (SimplFloats, SimplEnv) - -simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs - | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr rhs env - = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} - simplTrace "SimplBindr:inline-uncond" (ppr old_bndr) $ - do { tick (PreInlineUnconditionally old_bndr) - ; return ( emptyFloats env, env' ) } - - | otherwise - = case bind_cxt of - BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ - simplJoinBind is_rec cont - (old_bndr,env) (new_bndr,env) (rhs,env) - - BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ - simplLazyBind top_lvl is_rec - (old_bndr,env) (new_bndr,env) (rhs,env) - -simplTrace :: String -> SDoc -> SimplM a -> SimplM a -simplTrace herald doc thing_inside = do - logger <- getLogger - if logHasDumpFlag logger Opt_D_verbose_core2core - then logTraceMsg logger herald doc thing_inside - else thing_inside - --------------------------- -simplLazyBind :: TopLevelFlag -> RecFlag - -> (InId, SimplEnv) -- InBinder, and static env for its unfolding (if any) - -> (OutId, SimplEnv) -- OutBinder, and SimplEnv after simplifying that binder - -- The OutId has IdInfo (notably RULES), - -- except arity, unfolding - -> (InExpr, SimplEnv) -- The RHS and its static environment - -> SimplM (SimplFloats, SimplEnv) --- Precondition: Ids only, no TyVars; not a JoinId --- Precondition: rhs obeys the let-can-float invariant -simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) - = assert (isId bndr ) - assertPpr (not (isJoinId bndr)) (ppr bndr) $ - -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ - do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] - (tvs, body) = case collectTyAndValBinders rhs of - (tvs, [], body) - | surely_not_lam body -> (tvs, body) - _ -> ([], rhs) - - surely_not_lam (Lam {}) = False - surely_not_lam (Tick t e) - | not (tickishFloatable t) = surely_not_lam e - -- eta-reduction could float - surely_not_lam _ = True - -- Do not do the "abstract tyvar" thing if there's - -- a lambda inside, because it defeats eta-reduction - -- f = /\a. \x. g a x - -- should eta-reduce. - - ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs - -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils - - -- Simplify the RHS - ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) - is_rec (idDemandInfo bndr) - ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont - - -- ANF-ise a constructor or PAP rhs - ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-} - prepareBinding env top_lvl is_rec - False -- Not strict; this is simplLazyBind - bndr1 body_floats0 body0 - -- Subtle point: we do not need or want tvs' in the InScope set - -- of body_floats2, so we pass in 'env' not 'body_env'. - -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do - -- more renaming than necessary => extra work (see !7777 and test T16577). - -- Don't need: we wrap tvs' around the RHS anyway. - - ; (rhs_floats, body3) - <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating - {-#SCC "simplLazyBind-simple-floating" #-} - return (body_floats2, body2) - - else -- Non-empty floats, and non-empty tyvars: do type-abstraction first - {-#SCC "simplLazyBind-type-abstraction-first" #-} - do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl - tvs' body_floats2 body2 - ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds - ; return (poly_floats, body3) } - - ; let env1 = env `setInScopeFromF` rhs_floats - ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont - ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1) - ; return (rhs_floats `addFloats` bind_float, env2) } - --------------------------- -simplJoinBind :: RecFlag - -> SimplCont - -> (InId, SimplEnv) -- InBinder, with static env for its unfolding - -> (OutId, SimplEnv) -- OutBinder; SimplEnv has the binder in scope - -- The OutId has IdInfo, except arity, unfolding - -> (InExpr, SimplEnv) -- The right hand side and its env - -> SimplM (SimplFloats, SimplEnv) -simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se) - = do { let rhs_env = rhs_se `setInScopeFromE` env - ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) } - --------------------------- -simplAuxBind :: SimplEnv - -> InId -- Old binder; not a JoinId - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) --- A specialised variant of completeBindX used to construct non-recursive --- auxiliary bindings, notably in knownCon. --- --- The binder comes from a case expression (case binder or alternative) --- and so does not have rules, unfolding, inline pragmas etc. --- --- Precondition: rhs satisfies the let-can-float invariant - -simplAuxBind env bndr new_rhs - | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $ - isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return (emptyFloats env, env) -- Here c is dead, and we avoid - -- creating the binding c = (a,b) - - -- The cases would be inlined unconditionally by completeBind: - -- but it seems not uncommon, and avoids faff to do it here - -- This is safe because it's only used for auxiliary bindings, which - -- have no NOLINE pragmas, nor RULEs - | exprIsTrivial new_rhs -- Short-cut for let x = y in ... - = return ( emptyFloats env - , case new_rhs of - Coercion co -> extendCvSubst env bndr co - _ -> extendIdSubst env bndr (DoneEx new_rhs Nothing) ) - - | otherwise - = do { -- ANF-ise the RHS - let !occ_fs = getOccFS bndr - ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs - ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet) - ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats - - -- Simplify the binder and complete the binding - ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr - ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive) - (bndr,env) (new_bndr, rhs1, env1) - - ; return (rhs_floats `addFloats` bind_float, env2) } - - -{- ********************************************************************* -* * - Cast worker/wrapper -* * -************************************************************************ - -Note [Cast worker/wrapper] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have a binding - x = e |> co -we want to do something very similar to worker/wrapper: - $wx = e - x = $wx |> co - -We call this making a cast worker/wrapper in tryCastWorkerWrapper. - -The main motivaiton is that x can be inlined freely. There's a chance -that e will be a constructor application or function, or something -like that, so moving the coercion to the usage site may well cancel -the coercions and lead to further optimisation. Example: - - data family T a :: * - data instance T Int = T Int - - foo :: Int -> Int -> Int - foo m n = ... - where - t = T m - go 0 = 0 - go n = case t of { T m -> go (n-m) } - -- This case should optimise - -A second reason for doing cast worker/wrapper is that the worker/wrapper -pass after strictness analysis can't deal with RHSs like - f = (\ a b c. blah) |> co -Instead, it relies on cast worker/wrapper to get rid of the cast, -leaving a simpler job for demand-analysis worker/wrapper. See #19874. - -Wrinkles - -1. We must /not/ do cast w/w on - f = g |> co - otherwise it'll just keep repeating forever! You might think this - is avoided because the call to tryCastWorkerWrapper is guarded by - preInlineUnconditinally, but I'm worried that a loop-breaker or an - exported Id might say False to preInlineUnonditionally. - -2. We need to be careful with inline/noinline pragmas: - rec { {-# NOINLINE f #-} - f = (...g...) |> co - ; g = ...f... } - This is legitimate -- it tells GHC to use f as the loop breaker - rather than g. Now we do the cast thing, to get something like - rec { $wf = ...g... - ; f = $wf |> co - ; g = ...f... } - Where should the NOINLINE pragma go? If we leave it on f we'll get - rec { $wf = ...g... - ; {-# NOINLINE f #-} - f = $wf |> co - ; g = ...f... } - and that is bad: the whole point is that we want to inline that - cast! We want to transfer the pagma to $wf: - rec { {-# NOINLINE $wf #-} - $wf = ...g... - ; f = $wf |> co - ; g = ...f... } - c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. - -3. We should still do cast w/w even if `f` is INLINEABLE. E.g. - {- f: Stable unfolding = -} - f = (\xy. ) |> co - Then we want to w/w to - {- $wf: Stable unfolding = |> sym co -} - $wf = \xy. - f = $wf |> co - Notice that the stable unfolding moves to the worker! Now demand analysis - will work fine on $wf, whereas it has trouble with the original f. - c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. - This point also applies to strong loopbreakers with INLINE pragmas, see - wrinkle (4). - -4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence - hasInlineUnfolding in tryCastWorkerWrapper, which responds False to - loop-breakers) because they'll definitely be inlined anyway, cast and - all. And if we do cast w/w for an INLINE function with arity zero, we get - something really silly: we inline that "worker" right back into the wrapper! - Worse than a no-op, because we have then lost the stable unfolding. - -All these wrinkles are exactly like worker/wrapper for strictness analysis: - f is the wrapper and must inline like crazy - $wf is the worker and must carry f's original pragma -See Note [Worker/wrapper for INLINABLE functions] -and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. - -See #17673, #18093, #18078, #19890. - -Note [Preserve strictness in cast w/w] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the Note [Cast worker/wrapper] transformation, keep the strictness info. -Eg - f = e `cast` co -- f has strictness SSL -When we transform to - f' = e -- f' also has strictness SSL - f = f' `cast` co -- f still has strictness SSL - -Its not wrong to drop it on the floor, but better to keep it. - -Note [Preserve RuntimeRep info in cast w/w] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must not do cast w/w when the presence of the coercion is needed in order -to determine the runtime representation. - -Example: - - Suppose we have a type family: - - type F :: RuntimeRep - type family F where - F = LiftedRep - - together with a type `ty :: TYPE F` and a top-level binding - - a :: ty |> TYPE F[0] - - The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. - However, were we to apply cast w/w, we would get: - - b :: ty - b = ... - - a :: ty |> TYPE F[0] - a = b `cast` GRefl (TYPE F[0]) - - Now we are in trouble because `ty :: TYPE F` does not have a known runtime - representation, because we need to be able to reduce the nullary type family - application `F` to find that out. - -Conclusion: only do cast w/w when doing so would not lose the RuntimeRep -information. That is, when handling `Cast rhs co`, don't attempt cast w/w -unless the kind of the type of rhs is concrete, in the sense of -Note [Concrete types] in GHC.Tc.Utils.Concrete. --} - -tryCastWorkerWrapper :: SimplEnv -> BindContext - -> InId -> OccInfo - -> OutId -> OutExpr - -> SimplM (SimplFloats, SimplEnv) --- See Note [Cast worker/wrapper] -tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co) - | BC_Let top_lvl is_rec <- bind_cxt -- Not join points - , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform - -- a DFunUnfolding in mk_worker_unfolding - , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 - , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 - , isConcreteType (typeKind work_ty) -- Don't peel off a cast if doing so would - -- lose the underlying runtime representation. - -- See Note [Preserve RuntimeRep info in cast w/w] - , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings - -- See Note [OPAQUE pragma] - = do { uniq <- getUniqueM - ; let work_name = mkSystemVarName uniq occ_fs - work_id = mkLocalIdWithInfo work_name ManyTy work_ty work_info - is_strict = isStrictId bndr - - ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict - work_id (emptyFloats env) rhs - - ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs - ; let work_id_w_unf = work_id `setIdUnfolding` work_unf - floats = rhs_floats `addLetFloats` - unitLetFloat (NonRec work_id_w_unf work_rhs) - - triv_rhs = Cast (Var work_id_w_unf) co - - ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs - -- Almost always True, because the RHS is trivial - -- In that case we want to eliminate the binding fast - -- We conservatively use postInlineUnconditionally so that we - -- check all the right things - then do { tick (PostInlineUnconditionally bndr) - ; return ( floats - , extendIdSubst (setInScopeFromF env floats) old_bndr $ - DoneEx triv_rhs Nothing ) } - - else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs - ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) - `setIdUnfolding` wrap_unf - floats' = floats `extendFloats` NonRec bndr' triv_rhs - ; return ( floats', setInScopeFromF env floats' ) } } - where - -- Force the occ_fs so that the old Id is not retained in the new Id. - !occ_fs = getOccFS bndr - uf_opts = seUnfoldingOpts env - work_ty = coercionLKind co - info = idInfo bndr - work_arity = arityInfo info `min` typeArity work_ty - - work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info - `setCprSigInfo` cprSigInfo info - `setDemandInfo` demandInfo info - `setInlinePragInfo` inlinePragInfo info - `setArityInfo` work_arity - -- We do /not/ want to transfer OccInfo, Rules - -- Note [Preserve strictness in cast w/w] - -- and Wrinkle 2 of Note [Cast worker/wrapper] - - ----------- Worker unfolding ----------- - -- Stable case: if there is a stable unfolding we have to compose with (Sym co); - -- the next round of simplification will do the job - -- Non-stable case: use work_rhs - -- Wrinkle 3 of Note [Cast worker/wrapper] - mk_worker_unfolding top_lvl work_id work_rhs - = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers - unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) - | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) - _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs - -tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings - = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr - , text "rhs:" <+> ppr rhs ]) - ; return (mkFloatBind env (NonRec bndr rhs)) } - -mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma --- See Note [Cast worker/wrapper] -mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info }) - = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" - , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] - , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap - , inl_act = wrap_act -- See Note [Wrapper activation] - , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap - -- RuleMatchInfo is (and must be) unaffected - where - -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap - -- But simpler, because we don't need to disable during InitialPhase - wrap_act | isNeverActive fn_act = activateDuringFinal - | otherwise = fn_act - - -{- ********************************************************************* -* * - prepareBinding, prepareRhs, makeTrivial -* * -********************************************************************* -} - -prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool - -> Id -- Used only for its OccName; can be InId or OutId - -> SimplFloats -> OutExpr - -> SimplM (SimplFloats, OutExpr) --- In (prepareBinding ... bndr floats rhs), the binding is really just --- bndr = let floats in rhs --- Maybe we can ANF-ise this binding and float out; e.g. --- bndr = let a = f x in K a a (g x) --- we could float out to give --- a = f x --- tmp = g x --- bndr = K a a tmp --- That's what prepareBinding does --- Precondition: binder is not a JoinId --- Postcondition: the returned SimplFloats contains only let-floats -prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs - = do { -- Never float join-floats out of a non-join let-binding (which this is) - -- So wrap the body in the join-floats right now - -- Hence: rhs_floats1 consists only of let-floats - let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs - - -- rhs_env: add to in-scope set the binders from rhs_floats - -- so that prepareRhs knows what is in scope in rhs - ; let rhs_env = env `setInScopeFromF` rhs_floats1 - -- Force the occ_fs so that the old Id is not retained in the new Id. - !occ_fs = getOccFS bndr - - -- Now ANF-ise the remaining rhs - ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1 - - -- Finally, decide whether or not to float - ; let all_floats = rhs_floats1 `addLetFloats` anf_floats - ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2 - then -- Float! - do { tick LetFloatFromLet - ; return (all_floats, rhs2) } - - else -- Abandon floating altogether; revert to original rhs - -- Since we have already built rhs1, we just need to add - -- rhs_floats1 to it - return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } - -{- Note [prepareRhs] -~~~~~~~~~~~~~~~~~~~~ -prepareRhs takes a putative RHS, checks whether it's a PAP or -constructor application and, if so, converts it to ANF, so that the -resulting thing can be inlined more easily. Thus - x = (f a, g b) -becomes - t1 = f a - t2 = g b - x = (t1,t2) - -We also want to deal well cases like this - v = (f e1 `cast` co) e2 -Here we want to make e1,e2 trivial and get - x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 -That's what the 'go' loop in prepareRhs does --} - -prepareRhs :: HasDebugCallStack - => SimplEnv -> TopLevelFlag - -> FastString -- Base for any new variables - -> OutExpr - -> SimplM (LetFloats, OutExpr) --- Transforms a RHS into a better RHS by ANF'ing args --- for expandable RHSs: constructors and PAPs --- e.g x = Just e --- becomes a = e -- 'a' is fresh --- x = Just a --- See Note [prepareRhs] -prepareRhs env top_lvl occ rhs0 - | is_expandable = anfise rhs0 - | otherwise = return (emptyLetFloats, rhs0) - where - -- We can' use exprIsExpandable because the WHOLE POINT is that - -- we want to treat (K ) as expandable, because we are just - -- about "anfise" the expression. exprIsExpandable would - -- just say no! - is_expandable = go rhs0 0 - where - go (Var fun) n_val_args = isExpandableApp fun n_val_args - go (App fun arg) n_val_args - | isTypeArg arg = go fun n_val_args - | otherwise = go fun (n_val_args + 1) - go (Cast rhs _) n_val_args = go rhs n_val_args - go (Tick _ rhs) n_val_args = go rhs n_val_args - go _ _ = False - - anfise :: OutExpr -> SimplM (LetFloats, OutExpr) - anfise (Cast rhs co) - = do { (floats, rhs') <- anfise rhs - ; return (floats, Cast rhs' co) } - anfise (App fun (Type ty)) - = do { (floats, rhs') <- anfise fun - ; return (floats, App rhs' (Type ty)) } - anfise (App fun arg) - = do { (floats1, fun') <- anfise fun - ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg - ; return (floats1 `addLetFlts` floats2, App fun' arg') } - anfise (Var fun) - = return (emptyLetFloats, Var fun) - - anfise (Tick t rhs) - -- We want to be able to float bindings past this - -- tick. Non-scoping ticks don't care. - | tickishScoped t == NoScope - = do { (floats, rhs') <- anfise rhs - ; return (floats, Tick t rhs') } - - -- On the other hand, for scoping ticks we need to be able to - -- copy them on the floats, which in turn is only allowed if - -- we can obtain non-counting ticks. - | (not (tickishCounts t) || tickishCanSplit t) - = do { (floats, rhs') <- anfise rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) - floats' = mapLetFloats floats tickIt - ; return (floats', Tick t rhs') } - - anfise other = return (emptyLetFloats, other) - -makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) -makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) - = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e - ; return (floats, arg { as_arg = e' }) } -makeTrivialArg _ arg - = return (emptyLetFloats, arg) -- CastBy, TyArg - -makeTrivial :: HasDebugCallStack - => SimplEnv -> TopLevelFlag -> Demand - -> FastString -- ^ A "friendly name" to build the new binder from - -> OutExpr - -> SimplM (LetFloats, OutExpr) --- Binds the expression to a variable, if it's not trivial, returning the variable --- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] -makeTrivial env top_lvl dmd occ_fs expr - | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise - -- See Note [Cannot trivialise] - = return (emptyLetFloats, expr) - - | Cast expr' co <- expr - = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' - ; return (floats, Cast triv_expr co) } - - | otherwise -- 'expr' is not of form (Cast e co) - = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr - ; uniq <- getUniqueM - ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name ManyTy expr_ty id_info - - -- Now something very like completeBind, - -- but without the postInlineUnconditionally part - ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 - -- Technically we should extend the in-scope set in 'env' with - -- the 'floats' from prepareRHS; but they are all fresh, so there is - -- no danger of introducing name shadowing in eta expansion - - ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2 - - ; let final_id = addLetBndrInfo var arity_type unf - bind = NonRec final_id expr2 - - ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) - ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } - where - id_info = vanillaIdInfo `setDemandInfo` dmd - expr_ty = exprType expr - uf_opts = seUnfoldingOpts env - -bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool --- True iff we can have a binding of this expression at this level --- Precondition: the type is the type of the expression -bindingOk top_lvl expr expr_ty - | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty - | otherwise = True - -{- Note [Cannot trivialise] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - f :: Int -> Addr# - - foo :: Bar - foo = Bar (f 3) - -Then we can't ANF-ise foo, even though we'd like to, because -we can't make a top-level binding for the Addr# (f 3). And if -so we don't want to turn it into - foo = let x = f 3 in Bar x -because we'll just end up inlining x back, and that makes the -simplifier loop. Better not to ANF-ise it at all. - -Literal strings are an exception. - - foo = Ptr "blob"# - -We want to turn this into: - - foo1 = "blob"# - foo = Ptr foo1 - -See Note [Core top-level string literals] in GHC.Core. - -************************************************************************ -* * - Completing a lazy binding -* * -************************************************************************ - -completeBind - * deals only with Ids, not TyVars - * takes an already-simplified binder and RHS - * is used for both recursive and non-recursive bindings - * is used for both top-level and non-top-level bindings - -It does the following: - - tries discarding a dead binding - - tries PostInlineUnconditionally - - add unfolding [this is the only place we add an unfolding] - - add arity - - extend the InScopeSet of the SimplEnv - -It does *not* attempt to do let-to-case. Why? Because it is used for - - top-level bindings (when let-to-case is impossible) - - many situations where the "rhs" is known to be a WHNF - (so let-to-case is inappropriate). - -Nor does it do the atomic-argument thing --} - -completeBind :: BindContext - -> (InId, SimplEnv) -- Old binder, and the static envt in which to simplify - -- its stable unfolding (if any) - -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId. - -- And the SimplEnv with that OutId in scope. - -> SimplM (SimplFloats, SimplEnv) --- completeBind may choose to do its work --- * by extending the substitution (e.g. let x = y in ...) --- * or by adding to the floats in the envt --- --- Binder /can/ be a JoinId --- Precondition: rhs obeys the let-can-float invariant -completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) - | isCoVar old_bndr - = case new_rhs of - Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) - _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) - - | otherwise - = assert (isId new_bndr) $ - do { let old_info = idInfo old_bndr - old_unf = realUnfoldingInfo old_info - occ_info = occInfo old_info - - -- Do eta-expansion on the RHS of the binding - -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils - ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs - - -- Simplify the unfolding; see Note [Environment for simplLetUnfolding] - ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env) - bind_cxt old_bndr - eta_rhs (idType new_bndr) new_arity old_unf - - ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding - -- See Note [In-scope set as a substitution] - - ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs - - then -- Inline and discard the binding - do { tick (PostInlineUnconditionally old_bndr) - ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs - -- See Note [Use occ-anald RHS in postInlineUnconditionally] - ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ - return ( emptyFloats env - , extendIdSubst env old_bndr $ - DoneEx unf_rhs (isJoinId_maybe new_bndr)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding - - else -- Keep the binding; do cast worker/wrapper - -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $ - tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs } - -addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId -addLetBndrInfo new_bndr new_arity_type new_unf - = new_bndr `setIdInfo` info5 - where - new_arity = arityTypeArity new_arity_type - info1 = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info: Note [Setting the new unfolding] - info2 = info1 `setUnfoldingInfo` new_unf - - -- Demand info: Note [Setting the demand info] - info3 | isEvaldUnfolding new_unf - = zapDemandInfo info2 `orElse` info2 - | otherwise - = info2 - - -- Bottoming bindings: see Note [Bottoming bindings] - info4 = case arityTypeBotSigs_maybe new_arity_type of - Nothing -> info3 - Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $ - info3 `setDmdSigInfo` str_sig - `setCprSigInfo` cpr_sig - - -- Zap call arity info. We have used it by now (via - -- `tryEtaExpandRhs`), and the simplifier can invalidate this - -- information, leading to broken code later (e.g. #13479) - info5 = zapCallArityInfo info4 - - -{- Note [Bottoming bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - let x = error "urk" - in ...(case x of )... -or - let f = \y. error (y ++ "urk") - in ...(case f "foo" of )... - -Then we'd like to drop the dead immediately. So it's good to -propagate the info that x's (or f's) RHS is bottom to x's (or f's) -IdInfo as rapidly as possible. - -We use tryEtaExpandRhs on every binding, and it turns out that the -arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already -does a simple bottoming-expression analysis. So all we need to do -is propagate that info to the binder's IdInfo. - -This showed up in #12150; see comment:16. - -There is a second reason for settting the strictness signature. Consider - let -- f :: <[S]b> - f = \x. error "urk" - in ...(f a b c)... -Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f` -to eta-expand to - let f = \x y z. error "urk" - in ...(f a b c)... - -But now f's strictness signature has too short an arity; see -GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth]. -Fortuitously, the same strictness-signature-fixup code -gives the function a new strictness signature with the right number of -arguments. Example in stranal/should_compile/EtaExpansion. - -Note [Setting the demand info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the unfolding is a value, the demand info may -go pear-shaped, so we nuke it. Example: - let x = (a,b) in - case x of (p,q) -> h p q x -Here x is certainly demanded. But after we've nuked -the case, we'll get just - let x = (a,b) in h a b x -and now x is not demanded (I'm assuming h is lazy) -This really happens. Similarly - let f = \x -> e in ...f..f... -After inlining f at some of its call sites the original binding may -(for example) be no longer strictly demanded. -The solution here is a bit ad hoc... - -Note [Use occ-anald RHS in postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we postInlineUnconditionally 'f in - let f = \x -> x True in ...(f blah)... -then we'd like to inline the /occ-anald/ RHS for 'f'. If we -use the non-occ-anald version, we'll end up with a - ...(let x = blah in x True)... -and hence an extra Simplifier iteration. - -We already /have/ the occ-anald version in the Unfolding for -the Id. Well, maybe not /quite/ always. If the binder is Dead, -postInlineUnconditionally will return True, but we may not have an -unfolding because it's too big. Hence the belt-and-braces `orElse` -in the defn of unf_rhs. The Nothing case probably never happens. - -Note [Environment for simplLetUnfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to be rather careful about the static environment in which -we simplify a stable unfolding. Consider (#24242): - - f x = let y_Xb = ... in - let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in - ... - -Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen; -see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier]. -This is perfectly fine. The `y_Xb` in the stable unfolding of the non- -recursive binding for `step1` refers, of course, to `let y_Xb = ....`. -When simplifying the binder `step1_Xb` we'll give it a new unique, and -extend the static environment with [Xb :-> step1_Xc], say. - -But when simplifying step1's stable unfolding, we must use static environment -/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps -[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc]. - -That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping -track of the right environment for the unfolding of that InId. See the type -of `simplLazyBind`, `simplJoinBind`, `completeBind`. - -This only matters when we have - - A non-recursive binding for f - - has a stable unfolding - - and that unfolding mentions a variable y - - that has the same unique as f. -So triggering a bug here is really hard! - -************************************************************************ -* * -\subsection[Simplify-simplExpr]{The main function: simplExpr} -* * -************************************************************************ - -The reason for this OutExprStuff stuff is that we want to float *after* -simplifying a RHS, not before. If we do so naively we get quadratic -behaviour as things float out. - -To see why it's important to do it after, consider this (real) example: - - let t = f x - in fst t -==> - let t = let a = e1 - b = e2 - in (a,b) - in fst t -==> - let a = e1 - b = e2 - t = (a,b) - in - a -- Can't inline a this round, cos it appears twice -==> - e1 - -Each of the ==> steps is a round of simplification. We'd save a -whole round if we float first. This can cascade. Consider - - let f = g d - in \x -> ...f... -==> - let f = let d1 = ..d.. in \y -> e - in \x -> ...f... -==> - let d1 = ..d.. - in \x -> ...(\y ->e)... - -Only in this second round can the \y be applied, and it -might do the same again. --} - -simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr -simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier] - = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] - ; return (Type ty') } - -simplExpr env expr - = simplExprC env expr (mkBoringStop expr_out_ty) - where - expr_out_ty :: OutType - expr_out_ty = substTy env (exprType expr) - -- NB: Since 'expr' is term-valued, not (Type ty), this call - -- to exprType will succeed. exprType fails on (Type ty). - -simplExprC :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM OutExpr - -- Simplify an expression, given a continuation -simplExprC env expr cont - = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ - do { (floats, expr') <- simplExprF env expr cont - ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ - -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ - -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ - return (wrapFloats floats expr') } - --------------------------------------------------- -simplExprF :: SimplEnv - -> InExpr -- A term-valued expression, never (Type ty) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF !env e !cont -- See Note [Bangs in the Simplifier] - = {- pprTrace "simplExprF" (vcat - [ ppr e - , text "cont =" <+> ppr cont - , text "inscope =" <+> ppr (seInScope env) - , text "tvsubst =" <+> ppr (seTvSubst env) - , text "idsubst =" <+> ppr (seIdSubst env) - , text "cvsubst =" <+> ppr (seCvSubst env) - ]) $ -} - simplExprF1 env e cont - -simplExprF1 :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplExprF1 _ (Type ty) cont - = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) - -- simplExprF does only with term-valued expressions - -- The (Type ty) case is handled separately by simplExpr - -- and by the other callers of simplExprF - -simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont -simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont -simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont -simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont -simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont - -simplExprF1 env (App fun arg) cont - = {-#SCC "simplExprF1-App" #-} case arg of - Type ty -> do { -- The argument type will (almost) certainly be used - -- in the output program, so just force it now. - -- See Note [Avoiding space leaks in OutType] - arg' <- simplType env ty - - -- But use substTy, not simplType, to avoid forcing - -- the hole type; it will likely not be needed. - -- See Note [The hole type in ApplyToTy] - ; let hole' = substTy env (exprType fun) - - ; simplExprF env fun $ - ApplyToTy { sc_arg_ty = arg' - , sc_hole_ty = hole' - , sc_cont = cont } } - _ -> - -- Crucially, sc_hole_ty is a /lazy/ binding. It will - -- be forced only if we need to run contHoleType. - -- When these are forced, we might get quadratic behavior; - -- this quadratic blowup could be avoided by drilling down - -- to the function and getting its multiplicities all at once - -- (instead of one-at-a-time). But in practice, we have not - -- observed the quadratic behavior, so this extra entanglement - -- seems not worthwhile. - simplExprF env fun $ - ApplyToVal { sc_arg = arg, sc_env = env - , sc_hole_ty = substTy env (exprType fun) - , sc_dup = NoDup, sc_cont = cont } - -simplExprF1 env expr@(Lam {}) cont - = {-#SCC "simplExprF1-Lam" #-} - simplLam env (zapLambdaBndrs expr n_args) cont - -- zapLambdaBndrs: the issue here is under-saturated lambdas - -- (\x1. \x2. e) arg1 - -- Here x1 might have "occurs-once" occ-info, because occ-info - -- is computed assuming that a group of lambdas is applied - -- all at once. If there are too few args, we must zap the - -- occ-info, UNLESS the remaining binders are one-shot - where - n_args = countArgs cont - -- NB: countArgs counts all the args (incl type args) - -- and likewise drop counts all binders (incl type lambdas) - -simplExprF1 env (Case scrut bndr _ alts) cont - = {-#SCC "simplExprF1-Case" #-} - simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr - , sc_alts = alts - , sc_env = env, sc_cont = cont }) - -simplExprF1 env (Let (Rec pairs) body) cont - | Just pairs' <- joinPointBindings_maybe pairs - = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont - - | otherwise - = {-#SCC "simplRecE" #-} simplRecE env pairs body cont - -simplExprF1 env (Let (NonRec bndr rhs) body) cont - | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) - = {-#SCC "simplExprF1-NonRecLet-Type" #-} - assert (isTyVar bndr) $ - do { ty' <- simplType env ty - ; simplExprF (extendTvSubst env bndr ty') body cont } - - | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env - -- Because of the let-can-float invariant, it's ok to - -- inline freely, or to drop the binding if it is dead. - = do { tick (PreInlineUnconditionally bndr) - ; simplExprF env' body cont } - - -- Now check for a join point. It's better to do the preInlineUnconditionally - -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial - -- binding like { j = j2 |> co } would first be eta-expanded and then inlined - -- Better to test preInlineUnconditionally first. - | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs - = {-#SCC "simplNonRecJoinPoint" #-} - simplNonRecJoinPoint env bndr' rhs' body cont - - | otherwise - = {-#SCC "simplNonRecE" #-} - simplNonRecE env FromLet bndr (rhs, env) body cont - -{- Note [Avoiding space leaks in OutType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since the simplifier is run for multiple iterations, we need to ensure -that any thunks in the output of one simplifier iteration are forced -by the evaluation of the next simplifier iteration. Otherwise we may -retain multiple copies of the Core program and leak a terrible amount -of memory (as in #13426). - -The simplifier is naturally strict in the entire "Expr part" of the -input Core program, because any expression may contain binders, which -we must find in order to extend the SimplEnv accordingly. But types -do not contain binders and so it is tempting to write things like - - simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! - -This is Bad because the result includes a thunk (substTy env ty) which -retains a reference to the whole simplifier environment; and the next -simplifier iteration will not force this thunk either, because the -line above is not strict in ty. - -So instead our strategy is for the simplifier to fully evaluate -OutTypes when it emits them into the output Core program, for example - - simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good - ; return (Type ty') } - -where the only difference from above is that simplType calls seqType -on the result of substTy. - -However, SimplCont can also contain OutTypes and it's not necessarily -a good idea to force types on the way in to SimplCont, because they -may end up not being used and forcing them could be a lot of wasted -work. T5631 is a good example of this. - -- For ApplyToTy's sc_arg_ty, we force the type on the way in because - the type will almost certainly appear as a type argument in the - output program. - -- For the hole types in Stop and ApplyToTy, we force the type when we - emit it into the output program, after obtaining it from - contResultType. (The hole type in ApplyToTy is only directly used - to form the result type in a new Stop continuation.) --} - ---------------------------------- --- Simplify a join point, adding the context. --- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: --- \x1 .. xn -> e => \x1 .. xn -> E[e] --- Note that we need the arity of the join point, since e may be a lambda --- (though this is unlikely). See Note [Join points and case-of-case]. -simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont - -> SimplM OutExpr -simplJoinRhs env bndr expr cont - | Just arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders arity expr - mult = contHoleScaling cont - ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) - ; join_body' <- simplExprC env' join_body cont - ; return $ mkLams join_bndrs' join_body' } - - | otherwise - = pprPanic "simplJoinRhs" (ppr bndr) - ---------------------------------- -simplType :: SimplEnv -> InType -> SimplM OutType - -- Kept monadic just so we can do the seqType - -- See Note [Avoiding space leaks in OutType] -simplType env ty - = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` return new_ty - where - new_ty = substTy env ty - ---------------------------------- -simplCoercionF :: SimplEnv -> InCoercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCoercionF env co cont - = do { co' <- simplCoercion env co - ; rebuild env (Coercion co') cont } - -simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion -simplCoercion env co - = do { let opt_co = optCoercion opts (getSubst env) co - ; seqCo opt_co `seq` return opt_co } - where - opts = seOptCoercionOpts env - ------------------------------------ --- | Push a TickIt context outwards past applications and cases, as --- long as this is a non-scoping tick, to let case and application --- optimisations apply. - -simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplTick env tickish expr cont - -- A scoped tick turns into a continuation, so that we can spot - -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do - -- it this way, then it would take two passes of the simplifier to - -- reduce ((scc t (\x . e)) e'). - -- NB, don't do this with counting ticks, because if the expr is - -- bottom, then rebuildCall will discard the continuation. - --- XXX: we cannot do this, because the simplifier assumes that --- the context can be pushed into a case with a single branch. e.g. --- scc case expensive of p -> e --- becomes --- case expensive of p -> scc e --- --- So I'm disabling this for now. It just means we will do more --- simplifier iterations that necessary in some cases. - --- | tickishScoped tickish && not (tickishCounts tickish) --- = simplExprF env expr (TickIt tickish cont) - - -- For unscoped or soft-scoped ticks, we are allowed to float in new - -- cost, so we simply push the continuation inside the tick. This - -- has the effect of moving the tick to the outside of a case or - -- application context, allowing the normal case and application - -- optimisations to fire. - | tickish `tickishScopesLike` SoftScope - = do { (floats, expr') <- simplExprF env expr cont - ; return (floats, mkTick tickish expr') - } - - -- Push tick inside if the context looks like this will allow us to - -- do a case-of-case - see Note [case-of-scc-of-case] - | Select {} <- cont, Just expr' <- push_tick_inside - = simplExprF env expr' cont - - -- We don't want to move the tick, but we might still want to allow - -- floats to pass through with appropriate wrapping (or not, see - -- wrap_floats below) - --- | not (tickishCounts tickish) || tickishCanSplit tickish - -- = wrap_floats - - | otherwise - = no_floating_past_tick - - where - - -- Try to push tick inside a case, see Note [case-of-scc-of-case]. - push_tick_inside = - case expr0 of - Case scrut bndr ty alts - -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) - _other -> Nothing - where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) - movable t = not (tickishCounts t) || - t `tickishScopesLike` NoScope || - tickishCanSplit t - tickScrut e = foldr mkTick e ticks - -- Alternatives get annotated with all ticks that scope in some way, - -- but we don't want to count entries. - tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) - ts_scope = map mkNoCount $ - filter (not . (`tickishScopesLike` NoScope)) ticks - - no_floating_past_tick = - do { let (inc,outc) = splitCont cont - ; (floats, expr1) <- simplExprF env expr inc - ; let expr2 = wrapFloats floats expr1 - tickish' = simplTickish env tickish - ; rebuild env (mkTick tickish' expr2) outc - } - --- Alternative version that wraps outgoing floats with the tick. This --- results in ticks being duplicated, as we don't make any attempt to --- eliminate the tick if we re-inline the binding (because the tick --- semantics allows unrestricted inlining of HNFs), so I'm not doing --- this any more. FloatOut will catch any real opportunities for --- floating. --- --- wrap_floats = --- do { let (inc,outc) = splitCont cont --- ; (env', expr') <- simplExprF (zapFloats env) expr inc --- ; let tickish' = simplTickish env tickish --- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), --- mkTick (mkNoCount tickish') rhs) --- -- when wrapping a float with mkTick, we better zap the Id's --- -- strictness info and arity, because it might be wrong now. --- ; let env'' = addFloats env (mapFloats env' wrap_float) --- ; rebuild env'' expr' (TickIt tickish' outc) --- } - - - simplTickish env tickish - | Breakpoint ext n ids <- tickish - = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) - | otherwise = tickish - - -- Push type application and coercion inside a tick - splitCont :: SimplCont -> (SimplCont, SimplCont) - splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) - where (inc,outc) = splitCont tail - splitCont (CastIt co c) = (CastIt co inc, outc) - where (inc,outc) = splitCont c - splitCont other = (mkBoringStop (contHoleType other), other) - - getDoneId (DoneId id) = Just id - getDoneId (DoneEx (Var id) _) = Just id - getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst - getDoneId other = pprPanic "getDoneId" (ppr other) - --- Note [case-of-scc-of-case] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- It's pretty important to be able to transform case-of-case when --- there's an SCC in the way. For example, the following comes up --- in nofib/real/compress/Encode.hs: --- --- case scctick --- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje --- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> --- (ww1_s13f, ww2_s13g, ww3_s13h) --- } --- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> --- tick --- (ww_s12Y, --- ww1_s12Z, --- PTTrees.PT --- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) --- } --- --- We really want this case-of-case to fire, because then the 3-tuple --- will go away (indeed, the CPR optimisation is relying on this --- happening). But the scctick is in the way - we need to push it --- inside to expose the case-of-case. So we perform this --- transformation on the inner case: --- --- scctick c (case e of { p1 -> e1; ...; pn -> en }) --- ==> --- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } --- --- So we've moved a constant amount of work out of the scc to expose --- the case. We only do this when the continuation is interesting: in --- for now, it has to be another Case (maybe generalise this later). - -{- -************************************************************************ -* * -\subsection{The main rebuilder} -* * -************************************************************************ --} - -rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) --- At this point the substitution in the SimplEnv should be irrelevant; --- only the in-scope set matters -rebuild env expr cont - = case cont of - Stop {} -> return (emptyFloats env, expr) - TickIt t cont -> rebuild env (mkTick t expr) cont - CastIt co cont -> rebuild env (mkCast expr co) cont - -- NB: mkCast implements the (Coercion co |> g) optimisation - - Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } - -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - - StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } - -> rebuildCall env (addValArgTo fun expr fun_ty ) cont - - StrictBind { sc_bndr = b, sc_body = body, sc_env = se - , sc_cont = cont, sc_from = from_what } - -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont - - ApplyToTy { sc_arg_ty = ty, sc_cont = cont} - -> rebuild env (App expr (Type ty)) cont - - ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag - , sc_cont = cont, sc_hole_ty = fun_ty } - -- See Note [Avoid redundant simplification] - -> do { (_, _, arg') <- simplArg env dup_flag fun_ty se arg - ; rebuild env (App expr arg') cont } - -completeBindX :: SimplEnv - -> FromWhat - -> InId -> OutExpr -- Non-recursively bind this Id to this (simplified) expression - -- (the let-can-float invariant may not be satisfied) - -> InExpr -- In this body - -> SimplCont -- Consumed by this continuation - -> SimplM (SimplFloats, OutExpr) -completeBindX env from_what bndr rhs body cont - | FromBeta arg_ty <- from_what - , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant - = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules - ; (floats, expr') <- simplNonRecBody env1 from_what body cont - -- Do not float floats past the Case binder below - ; let expr'' = wrapFloats floats expr' - case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] - ; return (emptyFloats env, case_expr) } - - | otherwise -- Make a let-binding - = do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) - - ; let is_strict = isStrictId bndr2 - -- isStrictId: use simplified binder because the InId bndr might not have - -- a fixed runtime representation, which isStrictId doesn't expect - -- c.f. Note [Dark corner with representation polymorphism] - - ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict - bndr2 (emptyFloats env) rhs - -- NB: it makes a surprisingly big difference (5% in compiler allocation - -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', - -- because this is simplNonRecX, so bndr is not in scope in the RHS. - - ; let env3 = env2 `setInScopeFromF` rhs_floats - ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive) - (bndr,env) (bndr2, rhs1, env3) - -- Must pass env1 to completeBind in case simplBinder had to clone, - -- and extended the substitution with [bndr :-> new_bndr] - - -- Simplify the body - ; (body_floats, body') <- simplNonRecBody env4 from_what body cont - - ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats - ; return ( all_floats, body' ) } - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -{- Note [Optimising reflexivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important (for compiler performance) to get rid of reflexivity as soon -as it appears. See #11735, #14737, and #15019. - -In particular, we want to behave well on - - * e |> co1 |> co2 - where the two happen to cancel out entirely. That is quite common; - e.g. a newtype wrapping and unwrapping cancel. - - - * (f |> co) @t1 @t2 ... @tn x1 .. xm - Here we will use pushCoTyArg and pushCoValArg successively, which - build up SelCo stacks. Silly to do that if co is reflexive. - -However, we don't want to call isReflexiveCo too much, because it uses -type equality which is expensive on big types (#14737 comment:7). - -A good compromise (determined experimentally) seems to be to call -isReflexiveCo - * when composing casts, and - * at the end - -In investigating this I saw missed opportunities for on-the-fly -coercion shrinkage. See #15090. --} - - -simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplCast env body co0 cont0 - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 - ; cont1 <- {-#SCC "simplCast-addCoerce" #-} - if isReflCo co1 - then return cont0 -- See Note [Optimising reflexivity] - else addCoerce co1 cont0 - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } - where - -- If the first parameter is MRefl, then simplifying revealed a - -- reflexive coercion. Omit. - addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont - addCoerceM MRefl cont = return cont - addCoerceM (MCo co) cont = addCoerce co cont - - addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont - addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity] - | isReflexiveCo co' = return cont - | otherwise = addCoerce co' cont - where - co' = mkTransCo co1 co2 - - addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty - = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM m_co' tail - ; return (ApplyToTy { sc_arg_ty = arg_ty' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } - -- NB! As the cast goes past, the - -- type of the hole changes (#16312) - - -- (f |> co) e ===> (f (e |> co1)) |> co2 - -- where co :: (s1->s2) ~ (t1->t2) - -- co1 :: t1 ~ s1 - -- co2 :: s2 ~ t2 - addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail - , sc_hole_ty = fun_ty }) - | Just (m_co1, m_co2) <- pushCoValArg co - , fixed_rep m_co1 - = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM m_co2 tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; - -- Avoid simplifying if possible; - -- See Note [Avoiding exponential behaviour] - - MCo co1 -> - do { (dup', arg_se', arg') <- simplArg env dup fun_ty arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' - , sc_dup = dup' - , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } - - addCoerce co cont - | isReflexiveCo co = return cont -- Having this at the end makes a huge - -- difference in T12227, for some reason - -- See Note [Optimising reflexivity] - | otherwise = return (CastIt co cont) - - fixed_rep :: MCoercionR -> Bool - fixed_rep MRefl = True - fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co - -- Without this check, we can get an argument which does not - -- have a fixed runtime representation. - -- See Note [Representation polymorphism invariants] in GHC.Core - -- test: typecheck/should_run/EtaExpandLevPoly - -simplArg :: SimplEnv -> DupFlag - -> OutType -- Type of the function applied to this arg - -> StaticEnv -> CoreExpr -- Expression with its static envt - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplArg env dup_flag fun_ty arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { let arg_env' = arg_env `setInScopeFromE` env - ; arg' <- simplExprC arg_env' arg (mkBoringStop (funArgTy fun_ty)) - ; return (Simplified, zapSubstEnv arg_env', arg') } - -- Return a StaticEnv that includes the in-scope set from 'env', - -- because arg' may well mention those variables (#20639) - -{- -************************************************************************ -* * -\subsection{Lambdas} -* * -************************************************************************ --} - -simplNonRecBody :: SimplEnv -> FromWhat - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplNonRecBody env from_what body cont - = case from_what of - FromLet -> simplExprF env body cont - FromBeta {} -> simplLam env body cont - -simplLam :: SimplEnv -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont -simplLam env expr cont = simplExprF env expr cont - -simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- Type beta-reduction -simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) - = do { tick (BetaReduction bndr) - ; simplLam (extendTvSubst env bndr arg_ty) body cont } - --- Value beta-reduction -simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_dup = dup - , sc_hole_ty = fun_ty}) - = do { tick (BetaReduction bndr) - ; let arg_ty = funArgTy fun_ty - ; if | isSimplified dup -- Don't re-simplify if we've simplified it once - -- Including don't preInlineUnconditionally - -- See Note [Avoiding exponential behaviour] - -> completeBindX env (FromBeta arg_ty) bndr arg body cont - - | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se - , not (needsCaseBinding arg_ty arg) - -- Ok to test arg::InExpr in needsCaseBinding because - -- exprOkForSpeculation is stable under simplification - -> do { tick (PreInlineUnconditionally bndr) - ; simplLam env' body cont } - - | otherwise - -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont } - --- Discard a non-counting tick on a lambda. This may change the --- cost attribution slightly (moving the allocation of the --- lambda elsewhere), but we don't care: optimisation changes --- cost attribution all the time. -simpl_lam env bndr body (TickIt tickish cont) - | not (tickishCounts tickish) - = simpl_lam env bndr body cont - --- Not enough args, so there are real lambdas left to put in the result -simpl_lam env bndr body cont - = do { let (inner_bndrs, inner_body) = collectBinders body - ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) - ; body' <- simplExpr env' inner_body - ; new_lam <- rebuildLam env' bndrs' body' cont - ; rebuild env' new_lam cont } - -------------- -simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) --- Historically this had a special case for when a lambda-binder --- could have a stable unfolding; --- see Historical Note [Case binders and join points] --- But now it is much simpler! We now only remove unfoldings. --- See Note [Never put `OtherCon` unfoldings on lambda binders] -simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr) - -simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) -simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs - ------------------- -simplNonRecE :: SimplEnv - -> FromWhat - -> InId -- The binder, always an Id - -- Never a join point - -- The static env for its unfolding (if any) is the first parameter - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> InExpr -- Body of the let/lambda - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplNonRecE is used for --- * from=FromLet: a non-top-level non-recursive non-join-point let-expression --- * from=FromBeta: a binding arising from a beta reduction --- --- simplNonRecE env b (rhs, rhs_se) body k --- = let env in --- cont< let b = rhs_se(rhs) in body > --- --- It deals with strict bindings, via the StrictBind continuation, --- which may abort the whole process. --- --- from_what=FromLet => the RHS satisfies the let-can-float invariant --- Otherwise it may or may not satisfy it. - -simplNonRecE env from_what bndr (rhs, rhs_se) body cont - | assert (isId bndr && not (isJoinId bndr) ) $ - is_strict_bind - = -- Evaluate RHS strictly - simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - - | otherwise -- Evaluate RHS lazily - = do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) - ; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive - (bndr,env) (bndr2,env2) (rhs,rhs_se) - ; (floats2, expr') <- simplNonRecBody env3 from_what body cont - ; return (floats1 `addFloats` floats2, expr') } - - where - is_strict_bind = case from_what of - FromBeta arg_ty | isUnliftedType arg_ty -> True - -- If we are coming from a beta-reduction (FromBeta) we must - -- establish the let-can-float invariant, so go via StrictBind - -- If not, the invariant holds already, and it's optional. - -- Using arg_ty: see Note [Dark corner with representation polymorphism] - -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg - -- When we come to `x=arg` we myst choose lazy/strict correctly - -- It's wrong to err in either directly - - _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr) - - ------------------- -simplRecE :: SimplEnv - -> [(InId, InExpr)] - -> InExpr - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --- simplRecE is used for --- * non-top-level recursive lets in expressions --- Precondition: not a join-point binding -simplRecE env pairs body cont - = do { let bndrs = map fst pairs - ; massert (all (not . isJoinId) bndrs) - ; env1 <- simplRecBndrs env bndrs - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs - ; (floats2, expr') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, expr') } - -{- Note [Dark corner with representation polymorphism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail -if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). -So we are careful to call `isStrictId` on the OutId, not the InId, in case we have - ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) -That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell -if x is lifted or unlifted from that. - -We only get such redexes from the compulsory inlining of a wired-in, -representation-polymorphic function like `rightSection` (see -GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined -such compulsory inlinings already, but belt and braces does no harm. - -Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the -Simplifier without first calling SimpleOpt, so anything involving -GHCi or TH and operator sections will fall over if we don't take -care here. - -Note [Avoiding exponential behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One way in which we can get exponential behaviour is if we simplify a -big expression, and then re-simplify it -- and then this happens in a -deeply-nested way. So we must be jolly careful about re-simplifying -an expression (#13379). That is why simplNonRecX does not try -preInlineUnconditionally (unlike simplNonRecE). - -Example: - f BIG, where f has a RULE -Then - * We simplify BIG before trying the rule; but the rule does not fire - * We inline f = \x. x True - * So if we did preInlineUnconditionally we'd re-simplify (BIG True) - -However, if BIG has /not/ already been simplified, we'd /like/ to -simplify BIG True; maybe good things happen. That is why - -* simplLam has - - a case for (isSimplified dup), which goes via simplNonRecX, and - - a case for the un-simplified case, which goes via simplNonRecE - -* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, - in at least two places - - In simplCast/addCoerce, where we check for isReflCo - - In rebuildCall we avoid simplifying arguments before we have to - (see Note [Trying rewrite rules]) - - -************************************************************************ -* * - Join points -* * -********************************************************************* -} - -{- Note [Rules and unfolding for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - simplExpr (join j x = rhs ) cont - ( {- RULE j (p:ps) = blah -} ) - ( {- StableUnfolding j = blah -} ) - (in blah ) - -Then we will push 'cont' into the rhs of 'j'. But we should *also* push -'cont' into the RHS of - * Any RULEs for j, e.g. generated by SpecConstr - * Any stable unfolding for j, e.g. the result of an INLINE pragma - -Simplifying rules and stable-unfoldings happens a bit after -simplifying the right-hand side, so we remember whether or not it -is a join point, and what 'cont' is, in a value of type MaybeJoinCont - -#13900 was caused by forgetting to push 'cont' into the RHS -of a SpecConstr-generated RULE for a join point. --} - -simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplNonRecJoinPoint env bndr rhs body cont - = assert (isJoinId bndr ) $ - wrapJoinCont env cont $ \ env cont -> - do { -- We push join_cont into the join RHS and the body; - -- and wrap wrap_cont around the whole thing - ; let mult = contHoleScaling cont - res_ty = contResultType cont - ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) - ; (floats2, body') <- simplExprF env3 body cont - ; return (floats1 `addFloats` floats2, body') } - - ------------------- -simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] - -> InExpr -> SimplCont - -> SimplM (SimplFloats, OutExpr) -simplRecJoinPoint env pairs body cont - = wrapJoinCont env cont $ \ env cont -> - do { let bndrs = map fst pairs - mult = contHoleScaling cont - res_ty = contResultType cont - ; env1 <- simplRecJoinBndrs env bndrs mult res_ty - -- NB: bndrs' don't have unfoldings or rules - -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs - ; (floats2, body') <- simplExprF env2 body cont - ; return (floats1 `addFloats` floats2, body') } - --------------------- -wrapJoinCont :: SimplEnv -> SimplCont - -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) - -> SimplM (SimplFloats, OutExpr) --- Deal with making the continuation duplicable if necessary, --- and with the no-case-of-case situation. -wrapJoinCont env cont thing_inside - | contIsStop cont -- Common case; no need for fancy footwork - = thing_inside env cont - - | not (seCaseCase env) - -- See Note [Join points with -fno-case-of-case] - = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) - ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 - ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont - ; return (floats2 `addFloats` floats3, expr3) } - - | otherwise - -- Normal case; see Note [Join points and case-of-case] - = do { (floats1, cont') <- mkDupableCont env cont - ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' - ; return (floats1 `addFloats` floats2, result) } - - --------------------- -trimJoinCont :: Id -- Used only in error message - -> Maybe JoinArity - -> SimplCont -> SimplCont --- Drop outer context from join point invocation (jump) --- See Note [Join points and case-of-case] - -trimJoinCont _ Nothing cont - = cont -- Not a jump -trimJoinCont var (Just arity) cont - = trim arity cont - where - trim 0 cont@(Stop {}) - = cont - trim 0 cont - = mkBoringStop (contResultType cont) - trim n cont@(ApplyToVal { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } - trim n cont@(ApplyToTy { sc_cont = k }) - = cont { sc_cont = trim (n-1) k } -- join arity counts types! - trim _ cont - = pprPanic "completeCall" $ ppr var $$ ppr cont - - -{- Note [Join points and case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we perform the case-of-case transform (or otherwise push continuations -inward), we want to treat join points specially. Since they're always -tail-called and we want to maintain this invariant, we can do this (for any -evaluation context E): - - E[join j = e - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> f 3] - - --> - - join j = E[e] - in case ... of - A -> jump j 1 - B -> jump j 2 - C -> E[f 3] - -As is evident from the example, there are two components to this behavior: - - 1. When entering the RHS of a join point, copy the context inside. - 2. When a join point is invoked, discard the outer context. - -We need to be very careful here to remain consistent---neither part is -optional! - -We need do make the continuation E duplicable (since we are duplicating it) -with mkDupableCont. - - -Note [Join points with -fno-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose case-of-case is switched off, and we are simplifying - - case (join j x = in - case y of - A -> j 1 - B -> j 2 - C -> e) of - -Usually, we'd push the outer continuation (case . of ) into -both the RHS and the body of the join point j. But since we aren't doing -case-of-case we may then end up with this totally bogus result - - join x = case of in - case (case y of - A -> j 1 - B -> j 2 - C -> e) of - -This would be OK in the language of the paper, but not in GHC: j is no longer -a join point. We can only do the "push continuation into the RHS of the -join point j" if we also push the continuation right down to the /jumps/ to -j, so that it can evaporate there. If we are doing case-of-case, we'll get to - - join x = case of in - case y of - A -> j 1 - B -> j 2 - C -> case e of - -which is great. - -Bottom line: if case-of-case is off, we must stop pushing the continuation -inwards altogether at any join point. Instead simplify the (join ... in ...) -with a Stop continuation, and wrap the original continuation around the -outside. Surprisingly tricky! - - -************************************************************************ -* * - Variables -* * -************************************************************************ - -Note [zapSubstEnv] -~~~~~~~~~~~~~~~~~~ -When simplifying something that has already been simplified, be sure to -zap the SubstEnv. This is VITAL. Consider - let x = e in - let y = \z -> ...x... in - \ x -> ...y... - -We'll clone the inner \x, adding x->x' in the id_subst Then when we -inline y, we must *not* replace x by x' in the inlined copy!! - -Note [Fast path for data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For applications of a data constructor worker, the full glory of -rebuildCall is a waste of effort; -* They never inline, obviously -* They have no rewrite rules -* They are not strict (see Note [Data-con worker strictness] - in GHC.Core.DataCon) -So it's fine to zoom straight to `rebuild` which just rebuilds the -call in a very straightforward way. - -Some programs have a /lot/ of data constructors in the source program -(compiler/perf/T9961 is an example), so this fast path can be very -valuable. --} - -simplVar :: SimplEnv -> InVar -> SimplM OutExpr --- Look up an InVar in the environment -simplVar env var - -- Why $! ? See Note [Bangs in the Simplifier] - | isTyVar var = return $! Type $! (substTyVar env var) - | isCoVar var = return $! Coercion $! (substCoVar env var) - | otherwise - = case substId env var of - ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids - in simplExpr env' e - DoneId var1 -> return (Var var1) - DoneEx e _ -> return e - -simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) -simplIdF env var cont - | isDataConWorkId var -- See Note [Fast path for data constructors] - = rebuild env (Var var) cont - | otherwise - = case substId env var of - ContEx tvs cvs ids e -> simplExprF env' e cont - -- Don't trimJoinCont; haven't already simplified e, - -- so the cont is not embodied in e - where - env' = setSubstEnv env tvs cvs ids - - DoneId var1 -> - do { rule_base <- getSimplRules - ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont - info = mkArgInfo env rule_base var1 cont' - ; rebuildCall env info cont' } - - DoneEx e mb_join -> simplExprF env' e cont' - where - cont' = trimJoinCont var mb_join cont - env' = zapSubstEnv env -- See Note [zapSubstEnv] - ---------------------------------------------------------- --- Dealing with a call site - -rebuildCall :: SimplEnv -> ArgInfo -> SimplCont - -> SimplM (SimplFloats, OutExpr) - ----------- Bottoming applications -------------- -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont - -- When we run out of strictness args, it means - -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo - -- Then we want to discard the entire strict continuation. E.g. - -- * case (error "hello") of { ... } - -- * (error "Hello") arg - -- * f (error "Hello") where f is strict - -- etc - -- Then, especially in the first of these cases, we'd like to discard - -- the continuation, leaving just the bottoming expression. But the - -- type might not be right, so we may have to add a coerce. - | not (contIsTrivial cont) -- Only do this if there is a non-trivial - -- continuation to discard, else we do it - -- again and again! - = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] - return (emptyFloats env, castBottomExpr res cont_ty) - where - res = argInfoExpr fun rev_args - cont_ty = contResultType cont - ----------- Try inlining, if ai_rewrite = TryInlining -------- --- In the TryInlining case we try inlining immediately, before simplifying --- any (more) arguments. Why? See Note [Rewrite rules and inlining]. --- --- If there are rewrite rules we'll skip this case until we have --- simplified enough args to satisfy nr_wanted==0 in the TryRules case below --- Then we'll try the rules, and if that fails, we'll do TryInlining -rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args - , ai_rewrite = TryInlining }) cont - = do { logger <- getLogger - ; let full_cont = pushSimplifiedRevArgs env rev_args cont - ; mb_inline <- tryInlining env logger fun full_cont - ; case mb_inline of - Just expr -> do { checkedTick (UnfoldingDone fun) - ; let env1 = zapSubstEnv env - ; simplExprF env1 expr full_cont } - Nothing -> rebuildCall env (info { ai_rewrite = TryNothing }) cont - } - ----------- Try rewrite RULES, if ai_rewrite = TryRules -------------- --- See Note [Rewrite rules and inlining] --- See also Note [Trying rewrite rules] -rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args - , ai_rewrite = TryRules nr_wanted rules }) cont - | nr_wanted == 0 || no_more_args - = -- We've accumulated a simplified call in - -- so try rewrite rules; see Note [RULES apply to simplified arguments] - -- See also Note [Rules for recursive functions] - do { mb_match <- tryRules env rules fun (reverse rev_args) cont - ; case mb_match of - Just (env', rhs, cont') -> simplExprF env' rhs cont' - Nothing -> rebuildCall env (info { ai_rewrite = TryInlining }) cont } - where - -- If we have run out of arguments, just try the rules; there might - -- be some with lower arity. Casts get in the way -- they aren't - -- allowed on rule LHSs - no_more_args = case cont of - ApplyToTy {} -> False - ApplyToVal {} -> False - _ -> True - ----------- Simplify type applications and casts -------------- -rebuildCall env info (CastIt co cont) - = rebuildCall env (addCastTo info co) cont - -rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) - = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont - ----------- The runRW# rule. Do this after absorbing all arguments ------ --- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. --- --- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o --- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) -rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont, sc_hole_ty = fun_ty }) - | fun_id `hasKey` runRWKey - , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args - -- Do this even if (contIsStop cont), or if seCaseCase is off. - -- See Note [No eta-expansion in runRW#] - = do { let arg_env = arg_se `setInScopeFromE` env - - overall_res_ty = contResultType cont - -- hole_ty is the type of the current runRW# application - (outer_cont, new_runrw_res_ty, inner_cont) - | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont) - | otherwise = (cont, hole_ty, mkBoringStop hole_ty) - -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify - -- Note [Case-of-case and full laziness] - - -- If the argument is a literal lambda already, take a short cut - -- This isn't just efficiency: - -- * If we don't do this we get a beta-redex every time, so the - -- simplifier keeps doing more iterations. - -- * Even more important: see Note [No eta-expansion in runRW#] - ; arg' <- case arg of - Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body inner_cont - ; return (Lam s' body') } - -- Important: do not try to eta-expand this lambda - -- See Note [No eta-expansion in runRW#] - - _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy - ; let (m,_,_) = splitFunTy fun_ty - env' = arg_env `addNewInScopeIds` [s'] - cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' - , sc_env = env', sc_cont = inner_cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } - -- cont' applies to s', then K - ; body' <- simplExprC env' arg cont' - ; return (Lam s' body') } - - ; let rr' = getRuntimeRep new_runrw_res_ty - call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] - ; rebuild env call' outer_cont } - ----------- Simplify value arguments -------------------- -rebuildCall env fun_info - (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup_flag, sc_hole_ty = fun_ty - , sc_cont = cont }) - -- Argument is already simplified - | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo fun_info arg fun_ty) cont - - -- Strict arguments - | isStrictArgInfo fun_info - , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify - -- Note [Case-of-case and full laziness] - = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ - simplExprF (arg_se `setInScopeFromE` env) arg - (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty - , sc_dup = Simplified - , sc_cont = cont }) - -- Note [Shadowing in the Simplifier] - - -- Lazy arguments - | otherwise - -- DO NOT float anything outside, hence simplExprC - -- There is no benefit (unlike in a let-binding), and we'd - -- have to be very careful about bogus strictness through - -- floating a demanded let. - = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg - (mkLazyArgStop arg_ty fun_info) - ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } - where - arg_ty = funArgTy fun_ty - - ----------- No further useful info, revert to generic rebuild ------------ -rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont - = rebuild env (argInfoExpr fun rev_args) cont - ------------------------------------ -tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) -tryInlining env logger var cont - | Just expr <- callSiteInline logger uf_opts case_depth var active_unf - lone_variable arg_infos interesting_cont - = do { dump_inline expr cont - ; return (Just expr) } - - | otherwise - = return Nothing - - where - uf_opts = seUnfoldingOpts env - case_depth = seCaseDepth env - (lone_variable, arg_infos, call_cont) = contArgs cont - interesting_cont = interestingCallContext env call_cont - active_unf = activeUnfolding (seMode env) var - - log_inlining doc - = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) - Opt_D_dump_inlinings - "" FormatText doc - - dump_inline unfolding cont - | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () - | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = when (isExternalName (idName var)) $ - log_inlining $ - sep [text "Inlining done:", nest 4 (ppr var)] - | otherwise - = log_inlining $ - sep [text "Inlining done: " <> ppr var, - nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), - text "Cont: " <+> ppr cont])] - - -{- Note [Trying rewrite rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet -simplified. We want to simplify enough arguments to allow the rules -to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone -is sufficient. Example: class ops - (+) dNumInt e2 e3 -If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the -latter's strictness when simplifying e2, e3. Moreover, suppose we have - RULE f Int = \x. x True - -Then given (f Int e1) we rewrite to - (\x. x True) e1 -without simplifying e1. Now we can inline x into its unique call site, -and absorb the True into it all in the same pass. If we simplified -e1 first, we couldn't do that; see Note [Avoiding exponential behaviour]. - -So we try to apply rules if either - (a) no_more_args: we've run out of argument that the rules can "see" - (b) nr_wanted: none of the rules wants any more arguments - - -Note [RULES apply to simplified arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very desirable to try RULES once the arguments have been simplified, because -doing so ensures that rule cascades work in one pass. Consider - {-# RULES g (h x) = k x - f (k x) = x #-} - ...f (g (h x))... -Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If -we match f's rules against the un-simplified RHS, it won't match. This -makes a particularly big difference when superclass selectors are involved: - op ($p1 ($p2 (df d))) -We want all this to unravel in one sweep. - -Note [Rewrite rules and inlining] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we try to arrange that inlining is disabled (via a pragma) if -a rewrite rule should apply, so that the rule has a decent chance to fire -before we inline the function. - -But it turns out that (especially when type-class specialisation or -SpecConstr is involved) it is very helpful for the the rewrite rule to -"win" over inlining when both are active at once: see #21851, #22097. - -The simplifier arranges to do this, as follows. In effect, the ai_rewrite -field of the ArgInfo record is the state of a little state-machine: - -* mkArgInfo sets the ai_rewrite field to TryRules if there are any rewrite - rules avaialable for that function. - -* rebuildCall simplifies arguments until enough are simplified to match the - rule with greatest arity. See Note [RULES apply to simplified arguments] - and the first field of `TryRules`. - - But no more! As soon as we have simplified enough arguments to satisfy the - maximum-arity rules, we try the rules; see Note [Trying rewrite rules]. - -* Once we have tried rules (or immediately if there are no rules) set - ai_rewrite to TryInlining, and the Simplifier will try to inline the - function. We want to try this immediately (before simplifying any (more) - arguments). Why? Consider - f BIG where f = \x{OneOcc}. ...x... - If we inline `f` before simplifying `BIG` well use preInlineUnconditionally, - and we'll simplify BIG once, at x's occurrence, rather than twice. - -* GHC.Core.Opt.Simplify.Utils. mkRewriteCall: if there are no rules, and no - unfolding, we can skip both TryRules and TryInlining, which saves work. - -Note [Avoid redundant simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because RULES apply to simplified arguments, there's a danger of repeatedly -simplifying already-simplified arguments. An important example is that of - (>>=) d e1 e2 -Here e1, e2 are simplified before the rule is applied, but don't really -participate in the rule firing. So we mark them as Simplified to avoid -re-simplifying them. - -Note [Shadowing in the Simplifier] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This part of the simplifier may return an expression that has shadowing. -(See Note [Shadowing in Core] in GHC.Core.hs.) Consider - f (...(\a -> e)...) (case y of (a,b) -> e') -where f is strict in its second arg -If we simplify the innermost one first we get (...(\a -> e)...) -Simplifying the second arg makes us float the case out, so we end up with - case y of (a,b) -> f (...(\a -> e)...) e' -So the output does not have the no-shadowing invariant. However, there is -no danger of getting name-capture, because when the first arg was simplified -we used an in-scope set that at least mentioned all the variables free in its -static environment, and that is enough. - -We can't just do innermost first, or we'd end up with a dual problem: - case x of (a,b) -> f e (...(\a -> e')...) - -I spent hours trying to recover the no-shadowing invariant, but I just could -not think of an elegant way to do it. The simplifier is already knee-deep in -continuations. We have to keep the right in-scope set around; AND we have -to get the effect that finding (error "foo") in a strict arg position will -discard the entire application and replace it with (error "foo"). Getting -all this at once is TOO HARD! - -See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils. - -Note [No eta-expansion in runRW#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we see `runRW# (\s. blah)` we must not attempt to eta-expand that -lambda. Why not? Because -* `blah` can mention join points bound outside the runRW# -* eta-expansion uses arityType, and -* `arityType` cannot cope with free join Ids: - -So the simplifier spots the literal lambda, and simplifies inside it. -It's a very special lambda, because it is the one the OccAnal spots and -allows join points bound /outside/ to be called /inside/. - -See Note [No free join points in arityType] in GHC.Core.Opt.Arity - -************************************************************************ -* * - Rewrite rules -* * -************************************************************************ --} - -tryRules :: SimplEnv -> [CoreRule] - -> Id - -> [ArgSpec] -- In /normal, forward/ order - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) - -tryRules env rules fn args call_cont - | null rules - = return Nothing - -{- Disabled until we fix #8326 - | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#] - , [_type_arg, val_arg] <- args - , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont - , isDeadBinder bndr - = do { let enum_to_tag :: CoreAlt -> CoreAlt - -- Takes K -> e into tagK# -> e - -- where tagK# is the tag of constructor K - enum_to_tag (DataAlt con, [], rhs) - = assert (isEnumerationTyCon (dataConTyCon con) ) - (LitAlt tag, [], rhs) - where - tag = mkLitInt (sePlatform env) (toInteger (dataConTag con - fIRST_TAG)) - enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt) - - new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts - new_bndr = setIdType bndr intPrimTy - -- The binder is dead, but should have the right type - ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) } --} - - | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env) - (activeRule (seMode env)) fn - (argInfoAppArgs args) rules - -- Fire a rule for the function - = do { logger <- getLogger - ; checkedTick (RuleFired (ruleName rule)) - ; let cont' = pushSimplifiedArgs zapped_env - (drop (ruleArity rule) args) - call_cont - -- (ruleArity rule) says how - -- many args the rule consumed - - occ_anald_rhs = occurAnalyseExpr rule_rhs - -- See Note [Occurrence-analyse after rule firing] - ; dump logger rule rule_rhs - ; return (Just (zapped_env, occ_anald_rhs, cont')) } - -- The occ_anald_rhs and cont' are all Out things - -- hence zapping the environment - - | otherwise -- No rule fires - = do { logger <- getLogger - ; nodump logger -- This ensures that an empty file is written - ; return Nothing } - - where - ropts = seRuleOpts env - zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] - - printRuleModule rule - = parens (maybe (text "BUILTIN") - (pprModuleName . moduleName) - (ruleModule rule)) - - dump logger rule rule_rhs - | logHasDumpFlag logger Opt_D_dump_rule_rewrites - = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat - [ text "Rule:" <+> ftext (ruleName rule) - , text "Module:" <+> printRuleModule rule - , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) - , text "After: " <+> hang (pprCoreExpr rule_rhs) 2 - (sep $ map ppr $ drop (ruleArity rule) args) - , text "Cont: " <+> ppr call_cont ] - - | logHasDumpFlag logger Opt_D_dump_rule_firings - = log_rule Opt_D_dump_rule_firings "Rule fired:" $ - ftext (ruleName rule) - <+> printRuleModule rule - - | otherwise - = return () - - nodump logger - | logHasDumpFlag logger Opt_D_dump_rule_rewrites - = liftIO $ - touchDumpFile logger Opt_D_dump_rule_rewrites - - | logHasDumpFlag logger Opt_D_dump_rule_firings - = liftIO $ - touchDumpFile logger Opt_D_dump_rule_firings - - | otherwise - = return () - - log_rule flag hdr details - = do - { logger <- getLogger - ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText - $ sep [text hdr, nest 4 details] - } - -trySeqRules :: SimplEnv - -> OutExpr -> InExpr -- Scrutinee and RHS - -> SimplCont - -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont)) --- See Note [User-defined RULES for seq] -trySeqRules in_env scrut rhs cont - = do { rule_base <- getSimplRules - ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont } - where - no_cast_scrut = drop_casts scrut - scrut_ty = exprType no_cast_scrut - seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b - res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b - res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b - res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty - res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty - rhs_ty = substTy in_env (exprType rhs) - rhs_rep = getRuntimeRep rhs_ty - out_args = [ TyArg { as_arg_ty = rhs_rep - , as_hole_ty = seq_id_ty } - , TyArg { as_arg_ty = scrut_ty - , as_hole_ty = res1_ty } - , TyArg { as_arg_ty = rhs_ty - , as_hole_ty = res2_ty } - , ValArg { as_arg = no_cast_scrut - , as_dmd = seqDmd - , as_hole_ty = res3_ty } ] - rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs - , sc_env = in_env, sc_cont = cont - , sc_hole_ty = res4_ty } - - -- Lazily evaluated, so we don't do most of this - - drop_casts (Cast e _) = drop_casts e - drop_casts e = e - -{- Note [User-defined RULES for seq] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given - case (scrut |> co) of _ -> rhs -look for rules that match the expression - seq @t1 @t2 scrut -where scrut :: t1 - rhs :: t2 - -If you find a match, rewrite it, and apply to 'rhs'. - -Notice that we can simply drop casts on the fly here, which -makes it more likely that a rule will match. - -See Note [User-defined RULES for seq] in GHC.Types.Id.Make. - -Note [Occurrence-analyse after rule firing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After firing a rule, we occurrence-analyse the instantiated RHS before -simplifying it. Usually this doesn't make much difference, but it can -be huge. Here's an example (simplCore/should_compile/T7785) - - map f (map f (map f xs) - -= -- Use build/fold form of map, twice - map f (build (\cn. foldr (mapFB c f) n - (build (\cn. foldr (mapFB c f) n xs)))) - -= -- Apply fold/build rule - map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) - -= -- Beta-reduce - -- Alas we have no occurrence-analysed, so we don't know - -- that c is used exactly once - map f (build (\cn. let c1 = mapFB c f in - foldr (mapFB c1 f) n xs)) - -= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) - -- We can do this because (mapFB c n) is a PAP and hence expandable - map f (build (\cn. let c1 = mapFB c n in - foldr (mapFB c (f.f)) n x)) - -This is not too bad. But now do the same with the outer map, and -we get another use of mapFB, and t can interact with /both/ remaining -mapFB calls in the above expression. This is stupid because actually -that 'c1' binding is dead. The outer map introduces another c2. If -there is a deep stack of maps we get lots of dead bindings, and lots -of redundant work as we repeatedly simplify the result of firing rules. - -The easy thing to do is simply to occurrence analyse the result of -the rule firing. Note that this occ-anals not only the RHS of the -rule, but also the function arguments, which by now are OutExprs. -E.g. - RULE f (g x) = x+1 - -Call f (g BIG) --> (\x. x+1) BIG - -The rule binders are lambda-bound and applied to the OutExpr arguments -(here BIG) which lack all internal occurrence info. - -Is this inefficient? Not really: we are about to walk over the result -of the rule firing to simplify it, so occurrence analysis is at most -a constant factor. - -Note, however, that the rule RHS is /already/ occ-analysed; see -Note [OccInfo in unfoldings and rules] in GHC.Core. There is something -unsatisfactory about doing it twice; but the rule RHS is usually very -small, and this is simple. - -Note [Optimising tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an enumeration data type: - - data Foo = A | B | C - -Then we want to transform - - case tagToEnum# x of ==> case x of - A -> e1 DEFAULT -> e1 - B -> e2 1# -> e2 - C -> e3 2# -> e3 - -thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT -alternative we retain it (remember it comes first). If not the case must -be exhaustive, and we reflect that in the transformed version by adding -a DEFAULT. Otherwise Lint complains that the new case is not exhaustive. -See #8317. - -Note [Rules for recursive functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that we shouldn't apply rules for a loop breaker: -doing so might give rise to an infinite loop, because a RULE is -rather like an extra equation for the function: - RULE: f (g x) y = x+y - Eqn: f a y = a-y - -But it's too drastic to disable rules for loop breakers. -Even the foldr/build rule would be disabled, because foldr -is recursive, and hence a loop breaker: - foldr k z (build g) = g k z -So it's up to the programmer: rules can cause divergence - - -************************************************************************ -* * - Rebuilding a case expression -* * -************************************************************************ - -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> let y# = x# in e - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise -this idea to look for a case where we're scrutinising a variable, and we know -that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be eliminated by the CaseElim transformation. -This includes things like (==# a# b#)::Bool so that we simplify - case ==# a# b# of { True -> x; False -> x } -to just - x -This particular example shows up in default methods for -comparison operations (e.g. in (>=) for Int.Int32) - -Note [Case to let transformation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a case over a lifted type has a single alternative, and is being -used as a strict 'let' (all isDeadBinder bndrs), we may want to do -this transformation: - - case e of r ===> let r = e in ...r... - _ -> ...r... - -We treat the unlifted and lifted cases separately: - -* Unlifted case: 'e' satisfies exprOkForSpeculation - (ok-for-spec is needed to satisfy the let-can-float invariant). - This turns case a +# b of r -> ...r... - into let r = a +# b in ...r... - and thence .....(a +# b).... - - However, if we have - case indexArray# a i of r -> ...r... - we might like to do the same, and inline the (indexArray# a i). - But indexArray# is not okForSpeculation, so we don't build a let - in rebuildCase (lest it get floated *out*), so the inlining doesn't - happen either. Annoying. - -* Lifted case: we need to be sure that the expression is already - evaluated (exprIsHNF). If it's not already evaluated - - we risk losing exceptions, divergence or - user-specified thunk-forcing - - even if 'e' is guaranteed to converge, we don't want to - create a thunk (call by need) instead of evaluating it - right away (call by value) - - However, we can turn the case into a /strict/ let if the 'r' is - used strictly in the body. Then we won't lose divergence; and - we won't build a thunk because the let is strict. - See also Note [Case-to-let for strictly-used binders] - -Note [Case-to-let for strictly-used binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have this: - case of r { _ -> ..r.. } - -where 'r' is used strictly in (..r..), we can safely transform to - let r = in ...r... - -This is a Good Thing, because 'r' might be dead (if the body just -calls error), or might be used just once (in which case it can be -inlined); or we might be able to float the let-binding up or down. -E.g. #15631 has an example. - -Note that this can change the error behaviour. For example, we might -transform - case x of { _ -> error "bad" } - --> error "bad" -which is might be puzzling if 'x' currently lambda-bound, but later gets -let-bound to (error "good"). - -Nevertheless, the paper "A semantics for imprecise exceptions" allows -this transformation. If you want to fix the evaluation order, use -'pseq'. See #8900 for an example where the loss of this -transformation bit us in practice. - -See also Note [Empty case alternatives] in GHC.Core. - -Historical notes - -There have been various earlier versions of this patch: - -* By Sept 18 the code looked like this: - || scrut_is_demanded_var scrut - - scrut_is_demanded_var :: CoreExpr -> Bool - scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s - scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) - scrut_is_demanded_var _ = False - - This only fired if the scrutinee was a /variable/, which seems - an unnecessary restriction. So in #15631 I relaxed it to allow - arbitrary scrutinees. Less code, less to explain -- but the change - had 0.00% effect on nofib. - -* Previously, in Jan 13 the code looked like this: - || case_bndr_evald_next rhs - - case_bndr_evald_next :: CoreExpr -> Bool - -- See Note [Case binder next] - case_bndr_evald_next (Var v) = v == case_bndr - case_bndr_evald_next (Cast e _) = case_bndr_evald_next e - case_bndr_evald_next (App e _) = case_bndr_evald_next e - case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e - case_bndr_evald_next _ = False - - This patch was part of fixing #7542. See also - Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.) - - -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print - -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: Void# -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} - -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: - -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x - -At a particular call site we have (f v 1). So we inline to get - - if v < 0 then jtos x - else if 1==0 then "" else jtos x - -Now simplify the 1==0 conditional: - - if v<0 then jtos v else jtos v - -Now common-up the two branches of the case: - - case (v<0) of DEFAULT -> jtos v - -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. - - -Note [FloatBinds from constructor wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have FloatBinds coming from the constructor wrapper -(as in Note [exprIsConApp_maybe on data constructors with wrappers]), -we cannot float past them. We'd need to float the FloatBind -together with the simplify floats, unfortunately the -simplifier doesn't have case-floats. The simplest thing we can -do is to wrap all the floats here. The next iteration of the -simplifier will take care of all these cases and lets. - -Given data T = MkT !Bool, this allows us to simplify -case $WMkT b of { MkT x -> f x } -to -case b of { b' -> f b' }. - -We could try and be more clever (like maybe wfloats only contain -let binders, so we could float them). But the need for the -extra complication is not clear. - -Note [Do not duplicate constructor applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#20125) - let x = (a,b) - in ...(case x of x' -> blah)...x...x... - -We want that `case` to vanish (since `x` is bound to a data con) leaving - let x = (a,b) - in ...(let x'=x in blah)...x..x... - -In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, -since is bound to (a,b). But in eliminating the case, if the scrutinee -is trivial, we want to bind the case-binder to the scrutinee, /not/ to -the constructor application. Hence the case_bndr_rhs in rebuildCase. - -This applies equally to a non-DEFAULT case alternative, say - let x = (a,b) in ...(case x of x' { (p,q) -> blah })... -This variant is handled by bind_case_bndr in knownCon. - -We want to bind x' to x, and not to a duplicated (a,b)). --} - ---------------------------------------------------------- --- Eliminate the case if possible - -rebuildCase, reallyRebuildCase - :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Alternatives (increasing order) - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - --------------------------------------------------- --- 1. Eliminate the case if there's a known constructor --------------------------------------------------- - -rebuildCase env scrut case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors - -- because literals are inlined more vigorously - , not (litIsLifted lit) - = do { tick (KnownBranch case_bndr) - ; case findAlt (LitAlt lit) alts of - Nothing -> missingAlt env case_bndr alts cont - Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } - - | Just (in_scope', wfloats, con, ty_args, other_args) - <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - , let env0 = setInScopeSet env in_scope' - = do { tick (KnownBranch case_bndr) - ; let scaled_wfloats = map scale_float wfloats - -- case_bndr_unf: see Note [Do not duplicate constructor applications] - case_bndr_rhs | exprIsTrivial scrut = scrut - | otherwise = con_app - con_app = Var (dataConWorkId con) `mkTyApps` ty_args - `mkApps` other_args - ; case findAlt (DataAlt con) alts of - Nothing -> missingAlt env0 case_bndr alts cont - Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs - Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args - other_args case_bndr bs rhs cont - } - where - simple_rhs env wfloats case_bndr_rhs bs rhs = - assert (null bs) $ - do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs - -- scrut is a constructor application, - -- hence satisfies let-can-float invariant - ; (floats2, expr') <- simplExprF env' rhs cont - ; case wfloats of - [] -> return (floats1 `addFloats` floats2, expr') - _ -> return - -- See Note [FloatBinds from constructor wrappers] - ( emptyFloats env, - GHC.Core.Make.wrapFloats wfloats $ - wrapFloats (floats1 `addFloats` floats2) expr' )} - - -- This scales case floats by the multiplicity of the continuation hole (see - -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because - -- they are aliases anyway. - scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = - let - scale_id id = scaleVarBy holeScaling id - in - GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) - scale_float f = f - - holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr - -- We are in the following situation - -- case[p] case[q] u of { D x -> C v } of { C x -> w } - -- And we are producing case[??] u of { D x -> w[x\v]} - -- - -- What should the multiplicity `??` be? In order to preserve the usage of - -- variables in `u`, it needs to be `pq`. - -- - -- As an illustration, consider the following - -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } - -- Where C :: A %1 -> T is linear - -- If we were to produce a case[1], like the inner case, we would get - -- case[1] of { C x -> (x, x) } - -- Which is ill-typed with respect to linearity. So it needs to be a - -- case[Many]. - --------------------------------------------------- --- 2. Eliminate the case if scrutinee is evaluated --------------------------------------------------- - -rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont - -- See if we can get rid of the case altogether - -- See Note [Case elimination] - -- mkCase made sure that if all the alternatives are equal, - -- then there is now only one (DEFAULT) rhs - - -- 2a. Dropping the case altogether, if - -- a) it binds nothing (so it's really just a 'seq') - -- b) evaluating the scrutinee has no side effects - | is_plain_seq - , exprOkForSideEffects scrut - -- The entire case is dead, so we can drop it - -- if the scrutinee converges without having imperative - -- side effects or raising a Haskell exception - -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps - = simplExprF env rhs cont - - -- 2b. Turn the case into a let, if - -- a) it binds only the case-binder - -- b) unlifted case: the scrutinee is ok-for-speculation - -- lifted case: the scrutinee is in HNF (or will later be demanded) - -- See Note [Case to let transformation] - | all_dead_bndrs - , doCaseToLet scrut case_bndr - = do { tick (CaseElim case_bndr) - ; (floats1, env') <- simplAuxBind env case_bndr scrut - ; (floats2, expr') <- simplExprF env' rhs cont - ; return (floats1 `addFloats` floats2, expr') } - - -- 2c. Try the seq rules if - -- a) it binds only the case binder - -- b) a rule for seq applies - -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make - | is_plain_seq - = do { mb_rule <- trySeqRules env scrut rhs cont - ; case mb_rule of - Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont' - Nothing -> reallyRebuildCase env scrut case_bndr alts cont } - --------------------------------------------------- --- 3. Primop-related case-rules --------------------------------------------------- - - |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts - = reallyRebuildCase env scrut' case_bndr' alts' cont - - where - all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] - is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect - -rebuildCase env scrut case_bndr alts cont - = reallyRebuildCase env scrut case_bndr alts cont - - -doCaseToLet :: OutExpr -- Scrutinee - -> InId -- Case binder - -> Bool --- The situation is case scrut of b { DEFAULT -> body } --- Can we transform thus? let { b = scrut } in body -doCaseToLet scrut case_bndr - | isTyCoVar case_bndr -- Respect GHC.Core - = isTyCoArg scrut -- Note [Core type and coercion invariant] - - | isUnliftedType (exprType scrut) - -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). - -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' - -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. - -- Using `exprType` is typically cheap because `scrut` is typically a variable. - -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts - -- the brain more. Consider that if this test ever turns out to be a perf - -- problem (which seems unlikely). - = exprOkForSpeculation scrut - - | otherwise -- Scrut has a lifted type - = exprIsHNF scrut - || isStrUsedDmd (idDemandInfo case_bndr) - -- See Note [Case-to-let for strictly-used binders] - --------------------------------------------------- --- 3. Catch-all case --------------------------------------------------- - -reallyRebuildCase env scrut case_bndr alts cont - | not (seCaseCase env) -- Only when case-of-case is on. - -- See GHC.Driver.Config.Core.Opt.Simplify - -- Note [Case-of-case and full laziness] - = do { case_expr <- simplAlts env scrut case_bndr alts - (mkBoringStop (contHoleType cont)) - ; rebuild env case_expr cont } - - | otherwise - = do { (floats, env', cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts env' scrut - (scaleIdBy holeScaling case_bndr) - (scaleAltsBy holeScaling alts) - cont' - ; return (floats, case_expr) } - where - holeScaling = contHoleScaling cont - -- Note [Scaling in case-of-case] - -{- -simplCaseBinder checks whether the scrutinee is a variable, v. If so, -try to eliminate uses of v in the RHSs in favour of case_bndr; that -way, there's a chance that v will now only be used once, and hence -inlined. - -Historical note: we use to do the "case binder swap" in the Simplifier -so there were additional complications if the scrutinee was a variable. -Now the binder-swap stuff is done in the occurrence analyser; see -"GHC.Core.Opt.OccurAnal" Note [Binder swap]. - -Note [knownCon occ info] -~~~~~~~~~~~~~~~~~~~~~~~~ -If the case binder is not dead, then neither are the pattern bound -variables: - case of x { (a,b) -> - case x of { (p,q) -> p } } -Here (a,b) both look dead, but come alive after the inner case is eliminated. -The point is that we bring into the envt a binding - let x = (a,b) -after the outer case, and that makes (a,b) alive. At least we do unless -the case binder is guaranteed dead. - -Note [Case alternative occ info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are simply reconstructing a case (the common case), we always -zap the occurrence info on the binders in the alternatives. Even -if the case binder is dead, the scrutinee is usually a variable, and *that* -can bring the case-alternative binders back to life. -See Note [Add unfolding for scrutinee] - -Note [Improving seq] -~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: * -> * - type instance F Int = Int - -We'd like to transform - case e of (x :: F Int) { DEFAULT -> rhs } -===> - case e `cast` co of (x'::Int) - I# x# -> let x = x' `cast` sym co - in rhs - -so that 'rhs' can take advantage of the form of x'. Notice that Note -[Case of cast] (in OccurAnal) may then apply to the result. - -We'd also like to eliminate empty types (#13468). So if - - data Void - type instance F Bool = Void - -then we'd like to transform - case (x :: F Bool) of { _ -> error "urk" } -===> - case (x |> co) of (x' :: Void) of {} - -Nota Bene: we used to have a built-in rule for 'seq' that dropped -casts, so that - case (x |> co) of { _ -> blah } -dropped the cast; in order to improve the chances of trySeqRules -firing. But that works in the /opposite/ direction to Note [Improving -seq] so there's a danger of flip/flopping. Better to make trySeqRules -insensitive to the cast, which is now is. - -The need for [Improving seq] showed up in Roman's experiments. Example: - foo :: F Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -At one point I did transformation in LiberateCase, but it's more -robust here. (Otherwise, there's a danger that we'll simply drop the -'seq' altogether, before LiberateCase gets to see it.) - -Note [Scaling in case-of-case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When two cases commute, if done naively, the multiplicities will be wrong: - - case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] - { (z[Many], t[Many]) -> z - } - -The multiplicities here, are correct, but if I perform a case of case: - - case u of w[1] - { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } - } - -This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and -`y` must have multiplicities `Many` not `1`! The correct solution is to make -all the `1`-s be `Many`-s instead: - - case u of w[Many] - { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } - } - -In general, when commuting two cases, the rule has to be: - - case (case … of x[p] {…}) of y[q] { … } - ===> case … of x[p*q] { … case … of y[q] { … } } - -This is materialised, in the simplifier, by the fact that every time we simplify -case alternatives with a continuation (the surrounded case (or more!)), we must -scale the entire case we are simplifying, by a scaling factor which can be -computed in the continuation (with function `contHoleScaling`). --} - -simplAlts :: SimplEnv - -> OutExpr -- Scrutinee - -> InId -- Case binder - -> [InAlt] -- Non-empty - -> SimplCont - -> SimplM OutExpr -- Returns the complete simplified case expression - -simplAlts env0 scrut case_bndr alts cont' - = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr - , text "cont':" <+> ppr cont' - , text "in_scope" <+> ppr (seInScope env0) ]) - ; (env1, case_bndr1) <- simplBinder env0 case_bndr - ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding - env2 = modifyInScope env1 case_bndr2 - -- See Note [Case binder evaluated-ness] - fam_envs = seFamEnvs env0 - - ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut - case_bndr case_bndr2 alts - - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts - -- NB: it's possible that the returned in_alts is empty: this is handled - -- by the caller (rebuildCase) in the missingAlt function - -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts - -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils - - ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts --- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return () - - ; let alts_ty' = contResultType cont' - -- See Note [Avoiding space leaks in OutType] - ; seqType alts_ty' `seq` - mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' } - - ------------------------------------- -improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv - -> OutExpr -> InId -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) --- Note [Improving seq] -improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] - | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - -improveSeq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - - ------------------------------------- -simplAlt :: SimplEnv - -> Maybe OutExpr -- The scrutinee - -> [AltCon] -- These constructors can't be present when - -- matching the DEFAULT alternative - -> OutId -- The case binder - -> SimplCont - -> InAlt - -> SimplM OutAlt - -simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) - = assert (null bndrs) $ - do { let env' = addBinderUnfolding env case_bndr' - (mkOtherCon imposs_deflt_cons) - -- Record the constructors that the case-binder *can't* be. - ; rhs' <- simplExprC env' rhs cont' - ; return (Alt DEFAULT [] rhs') } - -simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs) - = assert (null bndrs) $ - do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit) - ; rhs' <- simplExprC env' rhs cont' - ; return (Alt (LitAlt lit) [] rhs') } - -simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs) - = do { -- See Note [Adding evaluatedness info to pattern-bound variables] - let vs_with_evals = addEvals scrut' con vs - ; (env', vs') <- simplBinders env vs_with_evals - - -- Bind the case-binder to (con args) - ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_app :: OutExpr - con_app = mkConApp2 con inst_tys' vs' - - ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app - ; rhs' <- simplExprC env'' rhs cont' - ; return (Alt (DataAlt con) vs' rhs') } - -{- Note [Adding evaluatedness info to pattern-bound variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -addEvals records the evaluated-ness of the bound variables of -a case pattern. This is *important*. Consider - - data T = T !Int !Int - - case x of { T a b -> T (a+1) b } - -We really must record that b is already evaluated so that we don't -go and re-evaluate it when constructing the result. -See Note [Data-con worker strictness] in GHC.Core.DataCon - -NB: simplLamBndrs preserves this eval info - -In addition to handling data constructor fields with !s, addEvals -also records the fact that the result of seq# is always in WHNF. -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226): - - case seq# v s of - (# s', v' #) -> E - -we want the compiler to be aware that v' is in WHNF in E. - -Open problem: we don't record that v itself is in WHNF (and we can't -do it here). The right thing is to do some kind of binder-swap; -see #15226 for discussion. --} - -addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id] --- See Note [Adding evaluatedness info to pattern-bound variables] -addEvals scrut con vs - -- Deal with seq# applications - | Just scr <- scrut - , isUnboxedTupleDataCon con - , [s,x] <- vs - -- Use stripNArgs rather than collectArgsTicks to avoid building - -- a list of arguments only to throw it away immediately. - , Just (Var f) <- stripNArgs 4 scr - , Just SeqOp <- isPrimOpId_maybe f - , let x' = zapIdOccInfoAndSetEvald MarkedStrict x - = [s, x'] - - -- Deal with banged datacon fields -addEvals _scrut con vs = go vs the_strs - where - the_strs = dataConRepStrictness con - - go [] [] = [] - go (v:vs') strs | isTyVar v = v : go vs' strs - go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs - go _ _ = pprPanic "Simplify.addEvals" - (ppr con $$ - ppr vs $$ - ppr_with_length (map strdisp the_strs) $$ - ppr_with_length (dataConRepArgTys con) $$ - ppr_with_length (dataConRepStrictness con)) - where - ppr_with_length list - = ppr list <+> parens (text "length =" <+> ppr (length list)) - strdisp :: StrictnessMark -> SDoc - strdisp MarkedStrict = text "MarkedStrict" - strdisp NotMarkedStrict = text "NotMarkedStrict" - -zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id -zapIdOccInfoAndSetEvald str v = - setCaseBndrEvald str $ -- Add eval'dness info - zapIdOccInfo v -- And kill occ info; - -- see Note [Case alternative occ info] - -addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv -addAltUnfoldings env mb_scrut case_bndr con_app - = do { let con_app_unf = mk_simple_unf con_app - env1 = addBinderUnfolding env case_bndr con_app_unf - - -- See Note [Add unfolding for scrutinee] - env2 | Just scrut <- mb_scrut - , Just (v,mco) <- scrutBinderSwap_maybe scrut - = addBinderUnfolding env1 v $ - if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf - then con_app_unf -- twice in the common case - else mk_simple_unf (mkCastMCo con_app mco) - - | otherwise = env1 - - ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr mb_scrut, ppr con_app]) - ; return env2 } - where - -- Force the opts, so that the whole SimplEnv isn't retained - !opts = seUnfoldingOpts env - mk_simple_unf = mkSimpleUnfolding opts - -addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv -addBinderUnfolding env bndr unf - | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf - = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) - "unfolding type mismatch" - (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ - modifyInScope env (bndr `setIdUnfolding` unf) - - | otherwise - = modifyInScope env (bndr `setIdUnfolding` unf) - -zapBndrOccInfo :: Bool -> Id -> Id --- Consider case e of b { (a,b) -> ... } --- Then if we bind b to (a,b) in "...", and b is not dead, --- then we must zap the deadness info on a,b -zapBndrOccInfo keep_occ_info pat_id - | keep_occ_info = pat_id - | otherwise = zapIdOccInfo pat_id - -{- Note [Case binder evaluated-ness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin on a (OtherCon []) unfolding to the case-binder of a Case, -even though it'll be over-ridden in every case alternative with a more -informative unfolding. Why? Because suppose a later, less clever, pass -simply replaces all occurrences of the case binder with the binder itself; -then Lint may complain about the let-can-float invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... - ; K -> blah } - -The let-can-float invariant requires that y is evaluated in the call to -reallyUnsafePtrEquality#, which it is. But we still want that to be true if we -propagate binders to occurrences. - -This showed up in #13027. - -Note [Add unfolding for scrutinee] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general it's unlikely that a variable scrutinee will appear -in the case alternatives case x of { ...x unlikely to appear... } -because the binder-swap in OccurAnal has got rid of all such occurrences -See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". - -BUT it is still VERY IMPORTANT to add a suitable unfolding for a -variable scrutinee, in simplAlt. Here's why - case x of y - (a,b) -> case b of c - I# v -> ...(f y)... -There is no occurrence of 'b' in the (...(f y)...). But y gets -the unfolding (a,b), and *that* mentions b. If f has a RULE - RULE f (p, I# q) = ... -we want that rule to match, so we must extend the in-scope env with a -suitable unfolding for 'y'. It's *essential* for rule matching; but -it's also good for case-elimination -- suppose that 'f' was inlined -and did multi-level case analysis, then we'd solve it in one -simplifier sweep instead of two. - -HOWEVER, given - case x of y { Just a -> r1; Nothing -> r2 } -we do not want to add the unfolding x -> y to 'x', which might seem cool, -since 'y' itself has different unfoldings in r1 and r2. Reason: if we -did that, we'd have to zap y's deadness info and that is a very useful -piece of information. - -So instead we add the unfolding x -> Just a, and x -> Nothing in the -respective RHSs. - -Since this transformation is tantamount to a binder swap, we use -GHC.Core.Opt.OccurAnal.scrutBinderSwap_maybe to do the check. - -Exactly the same issue arises in GHC.Core.Opt.SpecConstr; -see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr - - -************************************************************************ -* * -\subsection{Known constructor} -* * -************************************************************************ - -We are a bit careful with occurrence info. Here's an example - - (\x* -> case x of (a*, b) -> f a) (h v, e) - -where the * means "occurs once". This effectively becomes - case (h v, e) of (a*, b) -> f a) -and then - let a* = h v; b = e in f a -and then - f (h v) - -All this should happen in one sweep. --} - -knownCon :: SimplEnv - -> OutExpr -- The scrutinee - -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) - -> InId -> [InBndr] -> InExpr -- The alternative - -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont - = do { (floats1, env1) <- bind_args env bs dc_args - ; (floats2, env2) <- bind_case_bndr env1 - ; (floats3, expr') <- simplExprF env2 rhs cont - ; case dc_floats of - [] -> - return (floats1 `addFloats` floats2 `addFloats` floats3, expr') - _ -> - return ( emptyFloats env - -- See Note [FloatBinds from constructor wrappers] - , GHC.Core.Make.wrapFloats dc_floats $ - wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } - where - zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId - - -- Ugh! - bind_args env' [] _ = return (emptyFloats env', env') - - bind_args env' (b:bs') (Type ty : args) - = assert (isTyVar b ) - bind_args (extendTvSubst env' b ty) bs' args - - bind_args env' (b:bs') (Coercion co : args) - = assert (isCoVar b ) - bind_args (extendCvSubst env' b co) bs' args - - bind_args env' (b:bs') (arg : args) - = assert (isId b) $ - do { let b' = zap_occ b - -- zap_occ: the binder might be "dead", because it doesn't - -- occur in the RHS; and simplAuxBind may therefore discard it. - -- Nevertheless we must keep it if the case-binder is alive, - -- because it may be used in the con_app. See Note [knownCon occ info] - ; (floats1, env2) <- simplAuxBind env' b' arg -- arg satisfies let-can-float invariant - ; (floats2, env3) <- bind_args env2 bs' args - ; return (floats1 `addFloats` floats2, env3) } - - bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ - text "scrut:" <+> ppr scrut - - -- It's useful to bind bndr to scrut, rather than to a fresh - -- binding x = Con arg1 .. argn - -- because very often the scrut is a variable, so we avoid - -- creating, and then subsequently eliminating, a let-binding - -- BUT, if scrut is a not a variable, we must be careful - -- about duplicating the arg redexes; in that case, make - -- a new con-app from the args - bind_case_bndr env - | isDeadBinder bndr = return (emptyFloats env, env) - | exprIsTrivial scrut = return (emptyFloats env - , extendIdSubst env bndr (DoneEx scrut Nothing)) - -- See Note [Do not duplicate constructor applications] - | otherwise = do { dc_args <- mapM (simplVar env) bs - -- dc_ty_args are already OutTypes, - -- but bs are InBndrs - ; let con_app = Var (dataConWorkId dc) - `mkTyApps` dc_ty_args - `mkApps` dc_args - ; simplAuxBind env bndr con_app } - -------------------- -missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, OutExpr) - -- This isn't strictly an error, although it is unusual. - -- It's possible that the simplifier might "see" that - -- an inner case has no accessible alternatives before - -- it "sees" that the entire branch of an outer case is - -- inaccessible. So we simply put an error case here instead. -missingAlt env case_bndr _ cont - = warnPprTrace True "missingAlt" (ppr case_bndr) $ - -- See Note [Avoiding space leaks in OutType] - let cont_ty = contResultType cont - in seqType cont_ty `seq` - return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt") - -{- -************************************************************************ -* * -\subsection{Duplicating continuations} -* * -************************************************************************ - -Consider - let x* = case e of { True -> e1; False -> e2 } - in b -where x* is a strict binding. Then mkDupableCont will be given -the continuation - case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop -and will split it into - dupable: case [] of { True -> $j1; False -> $j2 } ; stop - join floats: $j1 = e1, $j2 = e2 - non_dupable: let x* = [] in b; stop - -Putting this back together would give - let x* = let { $j1 = e1; $j2 = e2 } in - case e of { True -> $j1; False -> $j2 } - in b -(Of course we only do this if 'e' wants to duplicate that continuation.) -Note how important it is that the new join points wrap around the -inner expression, and not around the whole thing. - -In contrast, any let-bindings introduced by mkDupableCont can wrap -around the entire thing. - -Note [Bottom alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have - case (case x of { A -> error .. ; B -> e; C -> error ..) - of alts -then we can just duplicate those alts because the A and C cases -will disappear immediately. This is more direct than creating -join points and inlining them away. See #4930. --} - --------------------- -mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM ( SimplFloats -- Join points (if any) - , SimplEnv -- Use this for the alts - , SimplCont) -mkDupableCaseCont env alts cont - | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont - ; let env' = bumpCaseDepth $ - env `setInScopeFromF` floats - ; return (floats, env', cont) } - | otherwise = return (emptyFloats env, env, cont) - -altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative -altsWouldDup [] = False -- See Note [Bottom alternatives] -altsWouldDup [_] = False -altsWouldDup (alt:alts) - | is_bot_alt alt = altsWouldDup alts - | otherwise = not (all is_bot_alt alts) - -- otherwise case: first alt is non-bot, so all the rest must be bot - where - is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs - -------------------------- -mkDupableCont :: SimplEnv - -> SimplCont - -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with - -- extra let/join-floats and in-scope variables - , SimplCont) -- dup_cont: duplicable continuation -mkDupableCont env cont - = mkDupableContWithDmds env (repeat topDmd) cont - -mkDupableContWithDmds - :: SimplEnv -> [Demand] -- Demands on arguments; always infinite - -> SimplCont -> SimplM ( SimplFloats, SimplCont) - -mkDupableContWithDmds env _ cont - | contIsDupable cont - = return (emptyFloats env, cont) - -mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn - -mkDupableContWithDmds env dmds (CastIt ty cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, CastIt ty cont') } - --- Duplicating ticks for now, not sure if this is good or not -mkDupableContWithDmds env dmds (TickIt t cont) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, TickIt t cont') } - -mkDupableContWithDmds env _ - (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what - , sc_env = se, sc_cont = cont}) --- See Note [Duplicating StrictBind] --- K[ let x = <> in b ] --> join j x = K[ b ] --- j <> - = do { let sb_env = se `setInScopeFromE` env - ; (sb_env1, bndr') <- simplBinder sb_env bndr - ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont - -- No need to use mkDupableCont before simplNonRecBody; we - -- use cont once here, and then share the result if necessary - - ; let join_body = wrapFloats floats1 join_inner - res_ty = contResultType cont - - ; mkDupableStrictBind env bndr' join_body res_ty } - -mkDupableContWithDmds env _ - (StrictArg { sc_fun = fun, sc_cont = cont - , sc_fun_ty = fun_ty }) - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - | isNothing (isDataConId_maybe (ai_fun fun)) - , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points] - = -- Use Plan A of Note [Duplicating StrictArg] - do { let (_ : dmds) = ai_dmds fun - ; (floats1, cont') <- mkDupableContWithDmds env dmds cont - -- Use the demands from the function to add the right - -- demand info on any bindings we make for further args - ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) - (ai_args fun) - ; return ( foldl' addLetFloats floats1 floats_s - , StrictArg { sc_fun = fun { ai_args = args' } - , sc_cont = cont' - , sc_fun_ty = fun_ty - , sc_dup = OkToDup} ) } - - | otherwise - = -- Use Plan B of Note [Duplicating StrictArg] - -- K[ f a b <> ] --> join j x = K[ f a b x ] - -- j <> - do { let rhs_ty = contResultType cont - (m,arg_ty,_) = splitFunTy fun_ty - ; arg_bndr <- newId (fsLit "arg") m arg_ty - ; let env' = env `addNewInScopeIds` [arg_bndr] - ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont - ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } - where - thumbsUpPlanA (StrictArg {}) = False - thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k - thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k - thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k - thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k - thumbsUpPlanA (Select {}) = True - thumbsUpPlanA (StrictBind {}) = True - thumbsUpPlanA (Stop {}) = True - -mkDupableContWithDmds env dmds - (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) - = do { (floats, cont') <- mkDupableContWithDmds env dmds cont - ; return (floats, ApplyToTy { sc_cont = cont' - , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se - , sc_cont = cont, sc_hole_ty = hole_ty }) - = -- e.g. [...hole...] (...arg...) - -- ==> - -- let a = ...arg... - -- in [...hole...] a - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { let (dmd:cont_dmds) = dmds -- Never fails - ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont - ; let env' = env `setInScopeFromF` floats1 - ; (_, se', arg') <- simplArg env' dup hole_ty se arg - ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' - ; let all_floats = floats1 `addLetFloats` let_floats2 - ; return ( all_floats - , ApplyToVal { sc_arg = arg'' - , sc_env = se' `setInScopeFromF` all_floats - -- Ensure that sc_env includes the free vars of - -- arg'' in its in-scope set, even if makeTrivial - -- has turned arg'' into a fresh variable - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup, sc_cont = cont' - , sc_hole_ty = hole_ty }) } - -mkDupableContWithDmds env _ - (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) - = -- e.g. (case [...hole...] of { pi -> ei }) - -- ===> - -- let ji = \xij -> ei - -- in case [...hole...] of { pi -> ji xij } - -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable - do { tick (CaseOfCase case_bndr) - ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont - -- NB: We call mkDupableCaseCont here to make cont duplicable - -- (if necessary, depending on the number of alts) - -- And this is important: see Note [Fusing case continuations] - - ; let cont_scaling = contHoleScaling cont - -- See Note [Scaling in case-of-case] - ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) - ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts) - -- Safe to say that there are no handled-cons for the DEFAULT case - -- NB: simplBinder does not zap deadness occ-info, so - -- a dead case_bndr' will still advertise its deadness - -- This is really important because in - -- case e of b { (# p,q #) -> ... } - -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), - -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. - -- In the new alts we build, we have the new case binder, so it must retain - -- its deadness. - -- NB: we don't use alt_env further; it has the substEnv for - -- the alternatives, and we don't want that - - ; let platform = sePlatform env - ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt platform case_bndr') - emptyJoinFloats alts' - - ; let all_floats = floats `addJoinFloats` join_floats - -- Note [Duplicated env] - ; return (all_floats - , Select { sc_dup = OkToDup - , sc_bndr = case_bndr' - , sc_alts = alts'' - , sc_env = zapSubstEnv se `setInScopeFromF` all_floats - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_cont = mkBoringStop (contResultType cont) } ) } - -mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType - -> SimplM (SimplFloats, SimplCont) -mkDupableStrictBind env arg_bndr join_rhs res_ty - | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points] - = return (emptyFloats env - , StrictBind { sc_bndr = arg_bndr - , sc_body = join_rhs - , sc_env = zapSubstEnv env - , sc_from = FromLet - -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils - , sc_dup = OkToDup - , sc_cont = mkBoringStop res_ty } ) - | otherwise - = do { join_bndr <- newJoinId [arg_bndr] res_ty - ; let arg_info = ArgInfo { ai_fun = join_bndr - , ai_rewrite = TryNothing, ai_args = [] - , ai_encl = False, ai_dmds = repeat topDmd - , ai_discs = repeat 0 } - ; return ( addJoinFloats (emptyFloats env) $ - unitJoinFloat $ - NonRec join_bndr $ - Lam (setOneShotLambda arg_bndr) join_rhs - , StrictArg { sc_dup = OkToDup - , sc_fun = arg_info - , sc_fun_ty = idType join_bndr - , sc_cont = mkBoringStop res_ty - } ) } - -mkDupableAlt :: Platform -> OutId - -> JoinFloats -> OutAlt - -> SimplM (JoinFloats, OutAlt) -mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in) - | exprIsTrivial alt_rhs_in -- See point (2) of Note [Duplicating join points] - = return (jfloats, Alt con alt_bndrs alt_rhs_in) - - | otherwise - = do { let rhs_ty' = exprType alt_rhs_in - - bangs - | DataAlt c <- con - = dataConRepStrictness c - | otherwise = [] - - abstracted_binders = abstract_binders alt_bndrs bangs - - abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)] - abstract_binders [] [] - -- Abstract over the case binder too if it's used. - | isDeadBinder case_bndr = [] - | otherwise = [(case_bndr,MarkedStrict)] - abstract_binders (alt_bndr:alt_bndrs) marks - -- Abstract over all type variables just in case - | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks - abstract_binders (alt_bndr:alt_bndrs) (mark:marks) - -- The deadness info on the new Ids is preserved by simplBinders - -- We don't abstract over dead ids here. - | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks - | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks - abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in) - - filtered_binders = map fst abstracted_binders - -- We want to make any binder with an evaldUnfolding strict in the rhs. - -- See Note [Call-by-value for worker args] (which also applies to join points) - (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in - - final_args = varsToCoreExprs filtered_binders - -- Note [Join point abstraction] - - -- We make the lambdas into one-shot-lambdas. The - -- join point is sure to be applied at most once, and doing so - -- prevents the body of the join point being floated out by - -- the full laziness pass - final_bndrs = map one_shot filtered_binders - one_shot v | isId v = setOneShotLambda v - | otherwise = v - - -- No lambda binder has an unfolding, but (currently) case binders can, - -- so we must zap them here. - join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs - - ; join_bndr <- newJoinId filtered_binders rhs_ty' - - ; let join_call = mkApps (Var join_bndr) final_args - alt' = Alt con alt_bndrs join_call - - ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) - , alt') } - -- See Note [Duplicated env] - -{- -Note [Fusing case continuations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important to fuse two successive case continuations when the -first has one alternative. That's why we call prepareCaseCont here. -Consider this, which arises from thunk splitting (see Note [Thunk -splitting] in GHC.Core.Opt.WorkWrap): - - let - x* = case (case v of {pn -> rn}) of - I# a -> I# a - in body - -The simplifier will find - (Var v) with continuation - Select (pn -> rn) ( - Select [I# a -> I# a] ( - StrictBind body Stop - -So we'll call mkDupableCont on - Select [I# a -> I# a] (StrictBind body Stop) -There is just one alternative in the first Select, so we want to -simplify the rhs (I# a) with continuation (StrictBind body Stop) -Supposing that body is big, we end up with - let $j a = - in case v of { pn -> case rn of - I# a -> $j a } -This is just what we want because the rn produces a box that -the case rn cancels with. - -See #4957 a fuller example. - -Note [Duplicating join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IN #19996 we discovered that we want to be really careful about -inlining join points. Consider - case (join $j x = K f x ) - (in case v of ) - ( p1 -> $j x1 ) of - ( p2 -> $j x2 ) - ( p3 -> $j x3 ) - K g y -> blah[g,y] - -Here the join-point RHS is very small, just a constructor -application (K x y). So we might inline it to get - case (case v of ) - ( p1 -> K f x1 ) of - ( p2 -> K f x2 ) - ( p3 -> K f x3 ) - K g y -> blah[g,y] - -But now we have to make `blah` into a join point, /abstracted/ -over `g` and `y`. In contrast, if we /don't/ inline $j we -don't need a join point for `blah` and we'll get - join $j x = let g=f, y=x in blah[g,y] - in case v of - p1 -> $j x1 - p2 -> $j x2 - p3 -> $j x3 - -This can make a /massive/ difference, because `blah` can see -what `f` is, instead of lambda-abstracting over it. - -To achieve this: - -1. Do not postInlineUnconditionally a join point, until the Final - phase. (The Final phase is still quite early, so we might consider - delaying still more.) - -2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for - all alternatives, except for exprIsTrival RHSs. Previously we used - exprIsDupable. This generates a lot more join points, but makes - them much more case-of-case friendly. - - It is definitely worth checking for exprIsTrivial, otherwise we get - an extra Simplifier iteration, because it is inlined in the next - round. - -3. By the same token we want to use Plan B in - Note [Duplicating StrictArg] when the RHS of the new join point - is a data constructor application. That same Note explains why we - want Plan A when the RHS of the new join point would be a - non-data-constructor application - -4. You might worry that $j will be inlined by the call-site inliner, - but it won't because the call-site context for a join is usually - extremely boring (the arguments come from the pattern match). - And if not, then perhaps inlining it would be a good idea. - - You might also wonder if we get UnfWhen, because the RHS of the - join point is no bigger than the call. But in the cases we care - about it will be a little bigger, because of that free `f` in - $j x = K f x - So for now we don't do anything special in callSiteInline - -There is a bit of tension between (2) and (3). Do we want to retain -the join point only when the RHS is -* a constructor application? or -* just non-trivial? -Currently, a bit ad-hoc, but we definitely want to retain the join -point for data constructors in mkDupalbleALt (point 2); that is the -whole point of #19996 described above. - -Historical Note [Case binders and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: this entire Note is now irrelevant. In Jun 21 we stopped -adding unfoldings to lambda binders (#17530). It was always a -hack and bit us in multiple small and not-so-small ways - -Consider this - case (case .. ) of c { - I# c# -> ....c.... - -If we make a join point with c but not c# we get - $j = \c -> ....c.... - -But if later inlining scrutinises the c, thus - - $j = \c -> ... case c of { I# y -> ... } ... - -we won't see that 'c' has already been scrutinised. This actually -happens in the 'tabulate' function in wave4main, and makes a significant -difference to allocation. - -An alternative plan is this: - - $j = \c# -> let c = I# c# in ...c.... - -but that is bad if 'c' is *not* later scrutinised. - -So instead we do both: we pass 'c' and 'c#' , and record in c's inlining -(a stable unfolding) that it's really I# c#, thus - - $j = \c# -> \c[=I# c#] -> ...c.... - -Absence analysis may later discard 'c'. - -NB: take great care when doing strictness analysis; - see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. - -Also note that we can still end up passing stuff that isn't used. Before -strictness analysis we have - let $j x y c{=(x,y)} = (h c, ...) - in ... -After strictness analysis we see that h is strict, we end up with - let $j x y c{=(x,y)} = ($wh x y, ...) -and c is unused. - -Note [Duplicated env] -~~~~~~~~~~~~~~~~~~~~~ -Some of the alternatives are simplified, but have not been turned into a join point -So they *must* have a zapped subst-env. So we can't use completeNonRecX to -bind the join point, because it might to do PostInlineUnconditionally, and -we'd lose that when zapping the subst-env. We could have a per-alt subst-env, -but zapping it (as we do in mkDupableCont, the Select case) is safe, and -at worst delays the join-point inlining. - -Note [Funky mkLamTypes] -~~~~~~~~~~~~~~~~~~~~~~ -Notice the funky mkLamTypes. If the constructor has existentials -it's possible that the join point will be abstracted over -type variables as well as term variables. - Example: Suppose we have - data T = forall t. C [t] - Then faced with - case (case e of ...) of - C t xs::[t] -> rhs - We get the join point - let j :: forall t. [t] -> ... - j = /\t \xs::[t] -> rhs - in - case (case e of ...) of - C t xs::[t] -> j t xs - -Note [Duplicating StrictArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dealing with making a StrictArg continuation duplicable has turned out -to be one of the trickiest corners of the simplifier, giving rise -to several cases in which the simplier expanded the program's size -*exponentially*. They include - #13253 exponential inlining - #10421 ditto - #18140 strict constructors - #18282 another nested-function call case - -Suppose we have a call - f e1 (case x of { True -> r1; False -> r2 }) e3 -and f is strict in its second argument. Then we end up in -mkDupableCont with a StrictArg continuation for (f e1 <> e3). -There are two ways to make it duplicable. - -* Plan A: move the entire call inwards, being careful not - to duplicate e1 or e3, thus: - let a1 = e1 - a3 = e3 - in case x of { True -> f a1 r1 a3 - ; False -> f a1 r2 a3 } - -* Plan B: make a join point: - join $j x = f e1 x e3 - in case x of { True -> jump $j r1 - ; False -> jump $j r2 } - - Notice that Plan B is very like the way we handle strict bindings; - see Note [Duplicating StrictBind]. And Plan B is exactly what we'd - get if we turned use a case expression to evaluate the strict arg: - - case (case x of { True -> r1; False -> r2 }) of - r -> f e1 r e3 - - So, looking at Note [Duplicating join points], we also want Plan B - when `f` is a data constructor. - -Plan A is often good. Here's an example from #3116 - go (n+1) (case l of - 1 -> bs' - _ -> Chunk p fpc (o+1) (l-1) bs') - -If we pushed the entire call for 'go' inside the case, we get -call-pattern specialisation for 'go', which is *crucial* for -this particular program. - -Here is another example. - && E (case x of { T -> F; F -> T }) - -Pushing the call inward (being careful not to duplicate E) - let a = E - in case x of { T -> && a F; F -> && a T } - -and now the (&& a F) etc can optimise. Moreover there might -be a RULE for the function that can fire when it "sees" the -particular case alternative. - -But Plan A can have terrible, terrible behaviour. Here is a classic -case: - f (f (f (f (f True)))) - -Suppose f is strict, and has a body that is small enough to inline. -The innermost call inlines (seeing the True) to give - f (f (f (f (case v of { True -> e1; False -> e2 })))) - -Now, suppose we naively push the entire continuation into both -case branches (it doesn't look large, just f.f.f.f). We get - case v of - True -> f (f (f (f e1))) - False -> f (f (f (f e2))) - -And now the process repeats, so we end up with an exponentially large -number of copies of f. No good! - -CONCLUSION: we want Plan A in general, but do Plan B is there a -danger of this nested call behaviour. The function that decides -this is called thumbsUpPlanA. - -Note [Keeping demand info in StrictArg Plan A] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Following on from Note [Duplicating StrictArg], another common code -pattern that can go bad is this: - f (case x1 of { T -> F; F -> T }) - (case x2 of { T -> F; F -> T }) - ...etc... -when f is strict in all its arguments. (It might, for example, be a -strict data constructor whose wrapper has not yet been inlined.) - -We use Plan A (because there is no nesting) giving - let a2 = case x2 of ... - a3 = case x3 of ... - in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } - -Now we must be careful! a2 and a3 are small, and the OneOcc code in -postInlineUnconditionally may inline them both at both sites; see Note -Note [Inline small things to avoid creating a thunk] in -Simplify.Utils. But if we do inline them, the entire process will -repeat -- back to exponential behaviour. - -So we are careful to keep the demand-info on a2 and a3. Then they'll -be /strict/ let-bindings, which will be dealt with by StrictBind. -That's why contIsDupableWithDmds is careful to propagage demand -info to the auxiliary bindings it creates. See the Demand argument -to makeTrivial. - -Note [Duplicating StrictBind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We make a StrictBind duplicable in a very similar way to -that for case expressions. After all, - let x* = e in b is similar to case e of x -> b - -So we potentially make a join-point for the body, thus: - let x = <> in b ==> join j x = b - in j <> - -Just like StrictArg in fact -- and indeed they share code. - -Note [Join point abstraction] Historical note -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This note is now historical, describing how (in the past) we used -to add a void argument to nullary join points. But now that "join -point" is not a fuzzy concept but a formal syntactic construct (as -distinguished by the JoinId constructor of IdDetails), each of these -concerns is handled separately, with no need for a vestigial extra -argument. - -Join points always have at least one value argument, -for several reasons - -* If we try to lift a primitive-typed something out - for let-binding-purposes, we will *caseify* it (!), - with potentially-disastrous strictness results. So - instead we turn it into a function: \v -> e - where v::Void#. The value passed to this function is void, - which generates (almost) no code. - -* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now - we make the join point into a function whenever used_bndrs' - is empty. This makes the join-point more CPR friendly. - Consider: let j = if .. then I# 3 else I# 4 - in case .. of { A -> j; B -> j; C -> ... } - - Now CPR doesn't w/w j because it's a thunk, so - that means that the enclosing function can't w/w either, - which is a lose. Here's the example that happened in practice: - kgmod :: Int -> Int -> Int - kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 - then 78 - else 5 - -* Let-no-escape. We want a join point to turn into a let-no-escape - so that it is implemented as a jump, and one of the conditions - for LNE is that it's not updatable. In CoreToStg, see - Note [What is a non-escaping let] - -* Floating. Since a join point will be entered once, no sharing is - gained by floating out, but something might be lost by doing - so because it might be allocated. - -I have seen a case alternative like this: - True -> \v -> ... -It's a bit silly to add the realWorld dummy arg in this case, making - $j = \s v -> ... - True -> $j s -(the \v alone is enough to make CPR happy) but I think it's rare - -There's a slight infelicity here: we pass the overall -case_bndr to all the join points if it's used in *any* RHS, -because we don't know its usage in each RHS separately - - - -************************************************************************ -* * - Unfoldings -* * -************************************************************************ --} - -simplLetUnfolding :: SimplEnv - -> BindContext - -> InId - -> OutExpr -> OutType -> ArityType - -> Unfolding -> SimplM Unfolding -simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf - | isStableUnfolding unf - = simplStableUnfolding env bind_cxt id rhs_ty arity unf - | isExitJoinId id - = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify - | otherwise - = -- Otherwise, we end up retaining all the SimpleEnv - let !opts = seUnfoldingOpts env - in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs - -------------------- -mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource - -> InId -> OutExpr -> SimplM Unfolding -mkLetUnfolding !uf_opts top_lvl src id new_rhs - = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In GHC.Iface.Tidy we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. - where - -- Might as well force this, profiles indicate up to 0.5MB of thunks - -- just from this site. - !is_top_lvl = isTopLevel top_lvl - -- See Note [Force bottoming field] - !is_bottoming = isDeadEndId id - -------------------- -simplStableUnfolding :: SimplEnv -> BindContext - -> InId - -> OutType - -> ArityType -- Used to eta expand, but only for non-join-points - -> Unfolding - ->SimplM Unfolding --- Note [Setting the new unfolding] -simplStableUnfolding env bind_cxt id rhs_ty id_arity unf - = case unf of - NoUnfolding -> return unf - BootUnfolding -> return unf - OtherCon {} -> return unf - - DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } - -> do { (env', bndrs') <- simplBinders unf_env bndrs - ; args' <- mapM (simplExpr env') args - ; return (mkDFunUnfolding bndrs' con args') } - - CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } - | isStableSource src - -> do { expr' <- case bind_cxt of - BC_Join _ cont -> -- Binder is a join point - -- See Note [Rules and unfolding for join points] - simplJoinRhs unf_env id expr cont - BC_Let _ is_rec -> -- Binder is not a join point - do { let cont = mkRhsStop rhs_ty is_rec topDmd - -- mkRhsStop: switch off eta-expansion at the top level - ; expr' <- simplExprC unf_env expr cont - ; return (eta_expand expr') } - ; case guide of - UnfWhen { ug_boring_ok = boring_ok } - -- Happens for INLINE things - -- Really important to force new_boring_ok since otherwise - -- `ug_boring_ok` is a thunk chain of - -- inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ... - -- See #20134 - -> let !new_boring_ok = boring_ok || inlineBoringOk expr' - guide' = guide { ug_boring_ok = new_boring_ok } - -- Refresh the boring-ok flag, in case expr' - -- has got small. This happens, notably in the inlinings - -- for dfuns for single-method classes; see - -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. - -- A test case is #4138 - -- But retain a previous boring_ok of True; e.g. see - -- the way it is set in calcUnfoldingGuidanceWithArity - in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide') - -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold - - _other -- Happens for INLINABLE things - -> mkLetUnfolding uf_opts top_lvl src id expr' } - -- If the guidance is UnfIfGoodArgs, this is an INLINABLE - -- unfolding, and we need to make sure the guidance is kept up - -- to date with respect to any changes in the unfolding. - - | otherwise -> return noUnfolding -- Discard unstable unfoldings - where - uf_opts = seUnfoldingOpts env - -- Forcing this can save about 0.5MB of max residency and the result - -- is small and easy to compute so might as well force it. - top_lvl = bindContextLevel bind_cxt - !is_top_lvl = isTopLevel top_lvl - act = idInlineActivation id - unf_env = updMode (updModeForStableUnfoldings act) env - -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils - - -- See Note [Eta-expand stable unfoldings] - -- Use the arity from the main Id (in id_arity), rather than computing it from rhs - -- Not used for join points - eta_expand expr | seEtaExpand env - , exprArity expr < arityTypeArity id_arity - , wantEtaExpansion expr - = etaExpandAT (getInScope env) id_arity expr - | otherwise - = expr - -{- Note [Eta-expand stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For INLINE/INLINABLE things (which get stable unfoldings) there's a danger -of getting - f :: Int -> Int -> Int -> Blah - [ Arity = 3 -- Good arity - , Unf=Stable (\xy. blah) -- Less good arity, only 2 - f = \pqr. e - -This can happen because f's RHS is optimised more vigorously than -its stable unfolding. Now suppose we have a call - g = f x -Because f has arity=3, g will have arity=2. But if we inline f (using -its stable unfolding) g's arity will reduce to 1, because -hasn't been optimised yet. This happened in the 'parsec' library, -for Text.Pasec.Char.string. - -Generally, if we know that 'f' has arity N, it seems sensible to -eta-expand the stable unfolding to arity N too. Simple and consistent. - -Wrinkles - -* See Historical-note [Eta-expansion in stable unfoldings] in - GHC.Core.Opt.Simplify.Utils - -* Don't eta-expand a trivial expr, else each pass will eta-reduce it, - and then eta-expand again. See Note [Which RHSs do we eta-expand?] - in GHC.Core.Opt.Simplify.Utils. - -* Don't eta-expand join points; see Note [Do not eta-expand join points] - in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point - case (bind_cxt = BC_Join {}) doesn't use eta_expand. - -Note [Force bottoming field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to force bottoming, or the new unfolding holds -on to the old unfolding (which is part of the id). - -Note [Setting the new unfolding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* If there's an INLINE pragma, we simplify the RHS gently. Maybe we - should do nothing at all, but simplifying gently might get rid of - more crap. - -* If not, we make an unfolding from the new RHS. But *only* for - non-loop-breakers. Making loop breakers not have an unfolding at all - means that we can avoid tests in exprIsConApp, for example. This is - important: if exprIsConApp says 'yes' for a recursive thing, then we - can get into an infinite loop - -If there's a stable unfolding on a loop breaker (which happens for -INLINABLE), we hang on to the inlining. It's pretty dodgy, but the -user did say 'INLINE'. May need to revisit this choice. - -************************************************************************ -* * - Rules -* * -************************************************************************ - -Note [Rules in a letrec] -~~~~~~~~~~~~~~~~~~~~~~~~ -After creating fresh binders for the binders of a letrec, we -substitute the RULES and add them back onto the binders; this is done -*before* processing any of the RHSs. This is important. Manuel found -cases where he really, really wanted a RULE for a recursive function -to apply in that function's own right-hand side. - -See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" --} - -addBndrRules :: SimplEnv -> InBndr -> OutBndr - -> BindContext - -> SimplM (SimplEnv, OutBndr) --- Rules are added back into the bin -addBndrRules env in_id out_id bind_cxt - | null old_rules - = return (env, out_id) - | otherwise - = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt - ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules - ; return (modifyInScope env final_id, final_id) } - where - old_rules = ruleInfoRules (idSpecialisation in_id) - -simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule] --- Simplify local rules for imported Ids -simplImpRules env rules - = simplRules env Nothing rules (BC_Let TopLevel NonRecursive) - -simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] - -> BindContext -> SimplM [CoreRule] -simplRules env mb_new_id rules bind_cxt - = mapM simpl_rule rules - where - simpl_rule rule@(BuiltinRule {}) - = return rule - - simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args - , ru_fn = fn_name, ru_rhs = rhs - , ru_act = act }) - = do { (env', bndrs') <- simplBinders env bndrs - ; let rhs_ty = substTy env' (exprType rhs) - rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] - BC_Let {} -> mkBoringStop rhs_ty - BC_Join _ cont -> assertPpr join_ok bad_join_msg cont - lhs_env = updMode updModeForRules env' - rhs_env = updMode (updModeForStableUnfoldings act) env' - -- See Note [Simplifying the RHS of a RULE] - -- Force this to avoid retaining reference to old Id - !fn_name' = case mb_new_id of - Just id -> idName id - Nothing -> fn_name - - -- join_ok is an assertion check that the join-arity of the - -- binder matches that of the rule, so that pushing the - -- continuation into the RHS makes sense - join_ok = case mb_new_id of - Just id | Just join_arity <- isJoinId_maybe id - -> length args == join_arity - _ -> False - bad_join_msg = vcat [ ppr mb_new_id, ppr rule - , ppr (fmap isJoinId_maybe mb_new_id) ] +module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Core +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.ConstantFold +import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.Opt.Simplify.Env +import GHC.Core.Opt.Simplify.Inline +import GHC.Core.Opt.Simplify.Utils +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) ) +import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) +import qualified GHC.Core.Make +import GHC.Core.Coercion hiding ( substCo, substCoVar ) +import GHC.Core.Reduction +import GHC.Core.Coercion.Opt ( optCoercion ) +import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe ) +import GHC.Core.DataCon +import GHC.Core.Opt.Stats ( Tick(..) ) +import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Core.Unfold +import GHC.Core.Unfold.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe + , pushCoTyArg, pushCoValArg, exprIsDeadEnd + , typeArity, arityTypeArity, etaExpandAT ) +import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} ) +import GHC.Core.Rules ( lookupRule, getRules ) +import GHC.Core.Multiplicity + +import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326 +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.Id.Make ( seqId ) +import GHC.Types.Id.Info +import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) +import GHC.Types.Demand +import GHC.Types.Unique ( hasKey ) +import GHC.Types.Basic +import GHC.Types.Tickish +import GHC.Types.Var ( isTyCoVar ) +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey, seqHashKey ) + +import GHC.Data.Maybe ( isNothing, orElse, mapMaybe ) +import GHC.Data.FastString +import GHC.Unit.Module ( moduleName ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger +import GHC.Utils.Misc + +import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) + +{- +The guts of the simplifier is in this module, but the driver loop for +the simplifier is in GHC.Core.Opt.Pipeline + +Note [The big picture] +~~~~~~~~~~~~~~~~~~~~~~ +The general shape of the simplifier is this: + + simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + + * SimplEnv contains + - Simplifier mode + - Ambient substitution + - InScopeSet + + * SimplFloats contains + - Let-floats (which includes ok-for-spec case-floats) + - Join floats + - InScopeSet (including all the floats) + + * Expressions + simplExpr :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + The result of simplifying an /expression/ is (floats, expr) + - A bunch of floats (let bindings, join bindings) + - A simplified expression. + The overall result is effectively (let floats in expr) + + * Bindings + simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv) + The result of simplifying a binding is + - A bunch of floats, the last of which is the simplified binding + There may be auxiliary bindings too; see prepareRhs + - An environment suitable for simplifying the scope of the binding + + The floats may also be empty, if the binding is inlined unconditionally; + in that case the returned SimplEnv will have an augmented substitution. + + The returned floats and env both have an in-scope set, and they are + guaranteed to be the same. + +Eta expansion +~~~~~~~~~~~~~~ +For eta expansion, we want to catch things like + + case e of (a,b) -> \x -> case a of (p,q) -> \y -> r + +If the \x was on the RHS of a let, we'd eta expand to bring the two +lambdas together. And in general that's a good thing to do. Perhaps +we should eta expand wherever we find a (value) lambda? Then the eta +expansion at a let RHS can concentrate solely on the PAP case. + +Note [In-scope set as a substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Lookups in in-scope set], an in-scope set can act as +a substitution. Specifically, it acts as a substitution from variable to +variables /with the same unique/. + +Why do we need this? Well, during the course of the simplifier, we may want to +adjust inessential properties of a variable. For instance, when performing a +beta-reduction, we change + + (\x. e) u ==> let x = u in e + +We typically want to add an unfolding to `x` so that it inlines to (the +simplification of) `u`. + +We do that by adding the unfolding to the binder `x`, which is added to the +in-scope set. When simplifying occurrences of `x` (every occurrence!), they are +replaced by their “updated” version from the in-scope set, hence inherit the +unfolding. This happens in `SimplEnv.substId`. + +Another example. Consider + + case x of y { Node a b -> ...y... + ; Leaf v -> ...y... } + +In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we +want y's unfolding to be (Leaf v). We achieve this by adding the appropriate +unfolding to y, and re-adding it to the in-scope set. See the calls to +`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere. + +It's quite convenient. This way we don't need to manipulate the substitution all +the time: every update to a binder is automatically reflected to its bound +occurrences. + +Note [Bangs in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both SimplFloats and SimplEnv do *not* generally benefit from making +their fields strict. I don't know if this is because of good use of +laziness or unintended side effects like closures capturing more variables +after WW has run. + +But the end result is that we keep these lazy, but force them in some places +where we know it's beneficial to the compiler. + +Similarly environments returned from functions aren't *always* beneficial to +force. In some places they would never be demanded so forcing them early +increases allocation. In other places they almost always get demanded so +it's worthwhile to force them early. + +Would it be better to through every allocation of e.g. SimplEnv and decide +wether or not to make this one strict? Absolutely! Would be a good use of +someones time? Absolutely not! I made these strict that showed up during +a profiled build or which I noticed while looking at core for one reason +or another. + +The result sadly is that we end up with "random" bangs in the simplifier +where we sometimes force e.g. the returned environment from a function and +sometimes we don't for the same function. Depending on the context around +the call. The treatment is also not very consistent. I only added bangs +where I saw it making a difference either in the core or benchmarks. Some +patterns where it would be beneficial aren't convered as a consequence as +I neither have the time to go through all of the core and some cases are +too small to show up in benchmarks. + + + +************************************************************************ +* * +\subsection{Bindings} +* * +************************************************************************ +-} + +simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) +-- See Note [The big picture] +simplTopBinds env0 binds0 + = do { -- Put all the top-level binders into scope at the start + -- so that if a rewrite rule has unexpectedly brought + -- anything into scope, then we don't get a complaint about that. + -- It's rather as if the top-level binders were imported. + -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal". + -- See Note [Bangs in the Simplifier] + ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0) + ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0 + ; freeTick SimplifierDone + ; return (floats, env2) } + where + -- We need to track the zapped top-level binders, because + -- they should have their fragile IdInfo zapped (notably occurrence info) + -- That's why we run down binds and bndrs' simultaneously. + -- + simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv) + simpl_binds env [] = return (emptyFloats env, env) + simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind + ; (floats, env2) <- simpl_binds env1 binds + -- See Note [Bangs in the Simplifier] + ; let !floats1 = float `addFloats` floats + ; return (floats1, env2) } + + simpl_bind env (Rec pairs) + = simplRecBind env (BC_Let TopLevel Recursive) pairs + simpl_bind env (NonRec b r) + = do { let bind_cxt = BC_Let TopLevel NonRecursive + ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt + ; simplRecOrTopPair env' bind_cxt b b' r } + +{- +************************************************************************ +* * + Lazy bindings +* * +************************************************************************ + +simplRecBind is used for + * recursive bindings only +-} + +simplRecBind :: SimplEnv -> BindContext + -> [(InId, InExpr)] + -> SimplM (SimplFloats, SimplEnv) +simplRecBind env0 bind_cxt pairs0 + = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 + ; let new_bndrs = map sndOf3 triples + ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> + go env triples + ; return (mkRecFloats rec_floats, env2) } + where + add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) + -- Add the (substituted) rules to the binder + add_rules env (bndr, rhs) + = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt + ; return (env', (bndr, bndr', rhs)) } + + go env [] = return (emptyFloats env, env) + + go env ((old_bndr, new_bndr, rhs) : pairs) + = do { (float, env1) <- simplRecOrTopPair env bind_cxt + old_bndr new_bndr rhs + ; (floats, env2) <- go env1 pairs + ; return (float `addFloats` floats, env2) } + +{- +simplOrTopPair is used for + * recursive bindings (whether top level or not) + * top-level non-recursive bindings + +It assumes the binder has already been simplified, but not its IdInfo. +-} + +simplRecOrTopPair :: SimplEnv + -> BindContext + -> InId -> OutBndr -> InExpr -- Binder and rhs + -> SimplM (SimplFloats, SimplEnv) + +simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs + | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) + old_bndr rhs env + = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} + simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ + do { tick (PreInlineUnconditionally old_bndr) + ; return ( emptyFloats env, env' ) } + + | otherwise + = case bind_cxt of + BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ + simplJoinBind is_rec cont + (old_bndr,env) (new_bndr,env) (rhs,env) + + BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ + simplLazyBind top_lvl is_rec + (old_bndr,env) (new_bndr,env) (rhs,env) + +simplTrace :: String -> SDoc -> SimplM a -> SimplM a +simplTrace herald doc thing_inside = do + logger <- getLogger + if logHasDumpFlag logger Opt_D_verbose_core2core + then logTraceMsg logger herald doc thing_inside + else thing_inside + +-------------------------- +simplLazyBind :: TopLevelFlag -> RecFlag + -> (InId, SimplEnv) -- InBinder, and static env for its unfolding (if any) + -> (OutId, SimplEnv) -- OutBinder, and SimplEnv after simplifying that binder + -- The OutId has IdInfo (notably RULES), + -- except arity, unfolding + -> (InExpr, SimplEnv) -- The RHS and its static environment + -> SimplM (SimplFloats, SimplEnv) +-- Precondition: Ids only, no TyVars; not a JoinId +-- Precondition: rhs obeys the let-can-float invariant +simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) + = assert (isId bndr ) + assertPpr (not (isJoinId bndr)) (ppr bndr) $ + -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ + do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier] + (tvs, body) = case collectTyAndValBinders rhs of + (tvs, [], body) + | surely_not_lam body -> (tvs, body) + _ -> ([], rhs) + + surely_not_lam (Lam {}) = False + surely_not_lam (Tick t e) + | not (tickishFloatable t) = surely_not_lam e + -- eta-reduction could float + surely_not_lam _ = True + -- Do not do the "abstract tyvar" thing if there's + -- a lambda inside, because it defeats eta-reduction + -- f = /\a. \x. g a x + -- should eta-reduce. + + ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs + -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils + + -- Simplify the RHS + ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) + is_rec (idDemandInfo bndr) + ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont + + -- ANF-ise a constructor or PAP rhs + ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-} + prepareBinding env top_lvl is_rec + False -- Not strict; this is simplLazyBind + bndr1 body_floats0 body0 + -- Subtle point: we do not need or want tvs' in the InScope set + -- of body_floats2, so we pass in 'env' not 'body_env'. + -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do + -- more renaming than necessary => extra work (see !7777 and test T16577). + -- Don't need: we wrap tvs' around the RHS anyway. + + ; (rhs_floats, body3) + <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating + {-#SCC "simplLazyBind-simple-floating" #-} + return (body_floats2, body2) + + else -- Non-empty floats, and non-empty tyvars: do type-abstraction first + {-#SCC "simplLazyBind-type-abstraction-first" #-} + do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl + tvs' body_floats2 body2 + ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds + ; return (poly_floats, body3) } + + ; let env1 = env `setInScopeFromF` rhs_floats + ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1) + ; return (rhs_floats `addFloats` bind_float, env2) } + +-------------------------- +simplJoinBind :: RecFlag + -> SimplCont + -> (InId, SimplEnv) -- InBinder, with static env for its unfolding + -> (OutId, SimplEnv) -- OutBinder; SimplEnv has the binder in scope + -- The OutId has IdInfo, except arity, unfolding + -> (InExpr, SimplEnv) -- The right hand side and its env + -> SimplM (SimplFloats, SimplEnv) +simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se) + = do { let rhs_env = rhs_se `setInScopeFromE` env + ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont + ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) } + +-------------------------- +simplAuxBind :: String + -> SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of completeBindX used to construct non-recursive +-- auxiliary bindings, notably in knownCon. +-- +-- The binder comes from a case expression (case binder or alternative) +-- and so does not have rules, unfolding, inline pragmas etc. +-- +-- Precondition: rhs satisfies the let-can-float invariant + +simplAuxBind _str env bndr new_rhs + | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $ + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + -- Next we have a fast-path for cases that would be inlined unconditionally by + -- completeBind: but it seems not uncommon, and it turns to be a little more + -- efficient (in compile time allocations) to do it here. + -- Effectively this is just a vastly-simplified postInlineUnconditionally + -- See Note [Post-inline for single-use things] in GHC.Core.Opt.Simplify.Utils + -- We could instead use postInlineUnconditionally itself, but I think it's simpler + -- and more direct to focus on the "hot" cases. + -- e.g. auxiliary bindings have no NOLINE pragmas, RULEs, or stable unfoldings + | exprIsTrivial new_rhs -- Short-cut for let x = y in ... + || case (idOccInfo bndr) of + OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True + _ -> False + = return ( emptyFloats env + , extendCvIdSubst env bndr new_rhs ) -- bndr can be a CoVar + + | otherwise + = do { -- ANF-ise the RHS + let !occ_fs = getOccFS bndr + ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs + ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet) + ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats + + -- Simplify the binder and complete the binding + ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr + ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (new_bndr, rhs1, env1) + + ; return (rhs_floats `addFloats` bind_float, env2) } + + +{- ********************************************************************* +* * + Cast worker/wrapper +* * +************************************************************************ + +Note [Cast worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have a binding + x = e |> co +we want to do something very similar to worker/wrapper: + $wx = e + x = $wx |> co + +We call this making a cast worker/wrapper in tryCastWorkerWrapper. + +The main motivaiton is that x can be inlined freely. There's a chance +that e will be a constructor application or function, or something +like that, so moving the coercion to the usage site may well cancel +the coercions and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + t = T m + go 0 = 0 + go n = case t of { T m -> go (n-m) } + -- This case should optimise + +A second reason for doing cast worker/wrapper is that the worker/wrapper +pass after strictness analysis can't deal with RHSs like + f = (\ a b c. blah) |> co +Instead, it relies on cast worker/wrapper to get rid of the cast, +leaving a simpler job for demand-analysis worker/wrapper. See #19874. + +Wrinkles + +1. We must /not/ do cast w/w on + f = g |> co + otherwise it'll just keep repeating forever! You might think this + is avoided because the call to tryCastWorkerWrapper is guarded by + preInlineUnconditinally, but I'm worried that a loop-breaker or an + exported Id might say False to preInlineUnonditionally. + +2. We need to be careful with inline/noinline pragmas: + rec { {-# NOINLINE f #-} + f = (...g...) |> co + ; g = ...f... } + This is legitimate -- it tells GHC to use f as the loop breaker + rather than g. Now we do the cast thing, to get something like + rec { $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + Where should the NOINLINE pragma go? If we leave it on f we'll get + rec { $wf = ...g... + ; {-# NOINLINE f #-} + f = $wf |> co + ; g = ...f... } + and that is bad: the whole point is that we want to inline that + cast! We want to transfer the pagma to $wf: + rec { {-# NOINLINE $wf #-} + $wf = ...g... + ; f = $wf |> co + ; g = ...f... } + c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +3. We should still do cast w/w even if `f` is INLINEABLE. E.g. + {- f: Stable unfolding = -} + f = (\xy. ) |> co + Then we want to w/w to + {- $wf: Stable unfolding = |> sym co -} + $wf = \xy. + f = $wf |> co + Notice that the stable unfolding moves to the worker! Now demand analysis + will work fine on $wf, whereas it has trouble with the original f. + c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap. + This point also applies to strong loopbreakers with INLINE pragmas, see + wrinkle (4). + +4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence + hasInlineUnfolding in tryCastWorkerWrapper, which responds False to + loop-breakers) because they'll definitely be inlined anyway, cast and + all. And if we do cast w/w for an INLINE function with arity zero, we get + something really silly: we inline that "worker" right back into the wrapper! + Worse than a no-op, because we have then lost the stable unfolding. + +All these wrinkles are exactly like worker/wrapper for strictness analysis: + f is the wrapper and must inline like crazy + $wf is the worker and must carry f's original pragma +See Note [Worker/wrapper for INLINABLE functions] +and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + +See #17673, #18093, #18078, #19890. + +Note [Preserve strictness in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the Note [Cast worker/wrapper] transformation, keep the strictness info. +Eg + f = e `cast` co -- f has strictness SSL +When we transform to + f' = e -- f' also has strictness SSL + f = f' `cast` co -- f still has strictness SSL + +Its not wrong to drop it on the floor, but better to keep it. + +Note [Preserve RuntimeRep info in cast w/w] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not do cast w/w when the presence of the coercion is needed in order +to determine the runtime representation. + +Example: + + Suppose we have a type family: + + type F :: RuntimeRep + type family F where + F = LiftedRep + + together with a type `ty :: TYPE F` and a top-level binding + + a :: ty |> TYPE F[0] + + The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding. + However, were we to apply cast w/w, we would get: + + b :: ty + b = ... + + a :: ty |> TYPE F[0] + a = b `cast` GRefl (TYPE F[0]) + + Now we are in trouble because `ty :: TYPE F` does not have a known runtime + representation, because we need to be able to reduce the nullary type family + application `F` to find that out. + +Conclusion: only do cast w/w when doing so would not lose the RuntimeRep +information. That is, when handling `Cast rhs co`, don't attempt cast w/w +unless the kind of the type of rhs is concrete, in the sense of +Note [Concrete types] in GHC.Tc.Utils.Concrete. +-} + +tryCastWorkerWrapper :: SimplEnv -> BindContext + -> InId -> OutId -> OutExpr + -> SimplM (SimplFloats, SimplEnv) +-- See Note [Cast worker/wrapper] +tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co) + | BC_Let top_lvl is_rec <- bind_cxt -- Not join points + , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform + -- a DFunUnfolding in mk_worker_unfolding + , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1 + , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4 + , typeHasFixedRuntimeRep work_ty -- Don't peel off a cast if doing so would + -- lose the underlying runtime representation. + -- See Note [Preserve RuntimeRep info in cast w/w] + , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings + -- See Note [OPAQUE pragma] + = do { uniq <- getUniqueM + ; let work_name = mkSystemVarName uniq occ_fs + work_id = mkLocalIdWithInfo work_name ManyTy work_ty work_info + is_strict = isStrictId bndr + + ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict + work_id (emptyFloats env) rhs + + ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs + ; let work_id_w_unf = work_id `setIdUnfolding` work_unf + floats = rhs_floats `addLetFloats` + unitLetFloat (NonRec work_id_w_unf work_rhs) + + triv_rhs = Cast (Var work_id_w_unf) co + + ; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs + -- Almost always True, because the RHS is trivial + -- In that case we want to eliminate the binding fast + -- We conservatively use postInlineUnconditionally so that we + -- check all the right things + then do { tick (PostInlineUnconditionally bndr) + ; return ( floats + , extendIdSubst (setInScopeFromF env floats) old_bndr $ + DoneEx triv_rhs NotJoinPoint ) } + + else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs + ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr) + `setIdUnfolding` wrap_unf + floats' = floats `extendFloats` NonRec bndr' triv_rhs + ; return ( floats', setInScopeFromF env floats' ) } } + where + -- Force the occ_fs so that the old Id is not retained in the new Id. + !occ_fs = getOccFS bndr + work_ty = coercionLKind co + info = idInfo bndr + work_arity = arityInfo info `min` typeArity work_ty + + work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info + `setCprSigInfo` cprSigInfo info + `setDemandInfo` demandInfo info + `setInlinePragInfo` inlinePragInfo info + `setArityInfo` work_arity + -- We do /not/ want to transfer OccInfo, Rules + -- Note [Preserve strictness in cast w/w] + -- and Wrinkle 2 of Note [Cast worker/wrapper] + + ----------- Worker unfolding ----------- + -- Stable case: if there is a stable unfolding we have to compose with (Sym co); + -- the next round of simplification will do the job + -- Non-stable case: use work_rhs + -- Wrinkle 3 of Note [Cast worker/wrapper] + mk_worker_unfolding top_lvl work_id work_rhs + = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) }) + _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs + +tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings + = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr + , text "rhs:" <+> ppr rhs ]) + ; return (mkFloatBind env (NonRec bndr rhs)) } + +mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma +-- See Note [Cast worker/wrapper] +mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info }) + = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" + , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions] + , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap + , inl_act = wrap_act -- See Note [Wrapper activation] + , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap + -- RuleMatchInfo is (and must be) unaffected + where + -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap + -- But simpler, because we don't need to disable during InitialPhase + wrap_act | isNeverActive fn_act = activateDuringFinal + | otherwise = fn_act + + +{- ********************************************************************* +* * + prepareBinding, prepareRhs, makeTrivial +* * +********************************************************************* -} + +prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool + -> Id -- Used only for its OccName; can be InId or OutId + -> SimplFloats -> OutExpr + -> SimplM (SimplFloats, OutExpr) +-- In (prepareBinding ... bndr floats rhs), the binding is really just +-- bndr = let floats in rhs +-- Maybe we can ANF-ise this binding and float out; e.g. +-- bndr = let a = f x in K a a (g x) +-- we could float out to give +-- a = f x +-- tmp = g x +-- bndr = K a a tmp +-- That's what prepareBinding does +-- Precondition: binder is not a JoinId +-- Postcondition: the returned SimplFloats contains only let-floats +prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs + = do { -- Never float join-floats out of a non-join let-binding (which this is) + -- So wrap the body in the join-floats right now + -- Hence: rhs_floats1 consists only of let-floats + let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs + + -- rhs_env: add to in-scope set the binders from rhs_floats + -- so that prepareRhs knows what is in scope in rhs + ; let rhs_env = env `setInScopeFromF` rhs_floats1 + -- Force the occ_fs so that the old Id is not retained in the new Id. + !occ_fs = getOccFS bndr + + -- Now ANF-ise the remaining rhs + ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1 + + -- Finally, decide whether or not to float + ; let all_floats = rhs_floats1 `addLetFloats` anf_floats + ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2 + then -- Float! + do { tick LetFloatFromLet + ; return (all_floats, rhs2) } + + else -- Abandon floating altogether; revert to original rhs + -- Since we have already built rhs1, we just need to add + -- rhs_floats1 to it + return (emptyFloats env, wrapFloats rhs_floats1 rhs1) } + +{- Note [prepareRhs] +~~~~~~~~~~~~~~~~~~~~ +prepareRhs takes a putative RHS, checks whether it's a PAP or +constructor application and, if so, converts it to ANF, so that the +resulting thing can be inlined more easily. Thus + x = (f a, g b) +becomes + t1 = f a + t2 = g b + x = (t1,t2) + +We also want to deal well cases like this + v = (f e1 `cast` co) e2 +Here we want to make e1,e2 trivial and get + x1 = e1; x2 = e2; v = (f x1 `cast` co) v2 +That's what the 'go' loop in prepareRhs does +-} + +prepareRhs :: HasDebugCallStack + => SimplEnv -> TopLevelFlag + -> FastString -- Base for any new variables + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Transforms a RHS into a better RHS by ANF'ing args +-- for expandable RHSs: constructors and PAPs +-- e.g x = Just e +-- becomes a = e -- 'a' is fresh +-- x = Just a +-- See Note [prepareRhs] +prepareRhs env top_lvl occ rhs0 + | is_expandable = anfise rhs0 + | otherwise = return (emptyLetFloats, rhs0) + where + -- We can't use exprIsExpandable because the WHOLE POINT is that + -- we want to treat (K ) as expandable, because we are just + -- about "anfise" the expression. exprIsExpandable would + -- just say no! + is_expandable = go rhs0 0 + where + go (Var fun) n_val_args = isExpandableApp fun n_val_args + go (App fun arg) n_val_args + | isTypeArg arg = go fun n_val_args + | otherwise = go fun (n_val_args + 1) + go (Cast rhs _) n_val_args = go rhs n_val_args + go (Tick _ rhs) n_val_args = go rhs n_val_args + go _ _ = False + + anfise :: OutExpr -> SimplM (LetFloats, OutExpr) + anfise (Cast rhs co) + = do { (floats, rhs') <- anfise rhs + ; return (floats, Cast rhs' co) } + anfise (App fun (Type ty)) + = do { (floats, rhs') <- anfise fun + ; return (floats, App rhs' (Type ty)) } + anfise (App fun arg) + = do { (floats1, fun') <- anfise fun + ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg + ; return (floats1 `addLetFlts` floats2, App fun' arg') } + anfise (Var fun) + = return (emptyLetFloats, Var fun) + + anfise (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (floats, rhs') <- anfise rhs + ; return (floats, Tick t rhs') } + + -- On the other hand, for scoping ticks we need to be able to + -- copy them on the floats, which in turn is only allowed if + -- we can obtain non-counting ticks. + | (not (tickishCounts t) || tickishCanSplit t) + = do { (floats, rhs') <- anfise rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (floats', Tick t rhs') } + + anfise other = return (emptyLetFloats, other) + +makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) +makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd }) + = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e + ; return (floats, arg { as_arg = e' }) } +makeTrivialArg _ arg@(TyArg {}) + = return (emptyLetFloats, arg) + +makeTrivial :: HasDebugCallStack + => SimplEnv -> TopLevelFlag -> Demand + -> FastString -- ^ A "friendly name" to build the new binder from + -> OutExpr + -> SimplM (LetFloats, OutExpr) +-- Binds the expression to a variable, if it's not trivial, returning the variable +-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A] +makeTrivial env top_lvl dmd occ_fs expr + | exprIsTrivial expr -- Already trivial + || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + -- See Note [Cannot trivialise] + = return (emptyLetFloats, expr) + + | Cast expr' co <- expr + = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr' + ; return (floats, Cast triv_expr co) } + + | otherwise -- 'expr' is not of form (Cast e co) + = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr + ; uniq <- getUniqueM + ; let name = mkSystemVarName uniq occ_fs + var = mkLocalIdWithInfo name ManyTy expr_ty id_info + + -- Now something very like completeBind, + -- but without the postInlineUnconditionally part + ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 + -- Technically we should extend the in-scope set in 'env' with + -- the 'floats' from prepareRHS; but they are all fresh, so there is + -- no danger of introducing name shadowing in eta expansion + + ; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2 + + ; let final_id = addLetBndrInfo var arity_type unf + bind = NonRec final_id expr2 + + ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ]) + ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) } + where + id_info = vanillaIdInfo `setDemandInfo` dmd + expr_ty = exprType expr + +bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +-- True iff we can have a binding of this expression at this level +-- Precondition: the type is the type of the expression +bindingOk top_lvl expr expr_ty + | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty + | otherwise = True + +{- Note [Cannot trivialise] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + f :: Int -> Addr# + + foo :: Bar + foo = Bar (f 3) + +Then we can't ANF-ise foo, even though we'd like to, because +we can't make a top-level binding for the Addr# (f 3). And if +so we don't want to turn it into + foo = let x = f 3 in Bar x +because we'll just end up inlining x back, and that makes the +simplifier loop. Better not to ANF-ise it at all. + +Literal strings are an exception. + + foo = Ptr "blob"# + +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [Core top-level string literals] in GHC.Core. + +************************************************************************ +* * + Completing a lazy binding +* * +************************************************************************ + +completeBind + * deals only with Ids, not TyVars + * takes an already-simplified binder and RHS + * is used for both recursive and non-recursive bindings + * is used for both top-level and non-top-level bindings + +It does the following: + - tries discarding a dead binding + - tries PostInlineUnconditionally + - add unfolding [this is the only place we add an unfolding] + - add arity + - extend the InScopeSet of the SimplEnv + +It does *not* attempt to do let-to-case. Why? Because it is used for + - top-level bindings (when let-to-case is impossible) + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). + +Nor does it do the atomic-argument thing +-} + +completeBind :: BindContext + -> (InId, SimplEnv) -- Old binder, and the static envt in which to simplify + -- its stable unfolding (if any) + -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId. + -- And the SimplEnv with that OutId in scope. + -> SimplM (SimplFloats, SimplEnv) +-- completeBind may choose to do its work +-- * by extending the substitution (e.g. let x = y in ...) +-- * or by adding to the floats in the envt +-- +-- Binder /can/ be a JoinId +-- Precondition: rhs obeys the let-can-float invariant +completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) + _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise + = assert (isId new_bndr) $ + do { let old_info = idInfo old_bndr + old_unf = realUnfoldingInfo old_info + + -- Do eta-expansion on the RHS of the binding + -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils + ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs + + -- Simplify the unfolding; see Note [Environment for simplLetUnfolding] + ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env) + bind_cxt old_bndr + eta_rhs (idType new_bndr) new_arity old_unf + + ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding + -- See Note [In-scope set as a substitution] + + ; if postInlineUnconditionally env bind_cxt old_bndr new_bndr_w_info eta_rhs + + then -- Inline and discard the binding + do { tick (PostInlineUnconditionally old_bndr) + ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs + -- See Note [Use occ-anald RHS in postInlineUnconditionally] + ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $ + return ( emptyFloats env + , extendIdSubst env old_bndr $ + DoneEx unf_rhs (idJoinPointHood new_bndr)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else -- Keep the binding; do cast worker/wrapper +-- simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr +-- , text "eta_rhs" <+> ppr eta_rhs ]) $ + tryCastWorkerWrapper env bind_cxt old_bndr new_bndr_w_info eta_rhs } + +addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId +addLetBndrInfo new_bndr new_arity_type new_unf + = new_bndr `setIdInfo` info5 + where + new_arity = arityTypeArity new_arity_type + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unf + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unf + = lazifyDemandInfo info2 `orElse` info2 + | otherwise + = info2 + + -- Bottoming bindings: see Note [Bottoming bindings] + info4 = case arityTypeBotSigs_maybe new_arity_type of + Nothing -> info3 + Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $ + info3 `setDmdSigInfo` str_sig + `setCprSigInfo` cpr_sig + + -- Zap call arity info. We have used it by now (via + -- `tryEtaExpandRhs`), and the simplifier can invalidate this + -- information, leading to broken code later (e.g. #13479) + info5 = zapCallArityInfo info4 + + +{- Note [Bottoming bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + let x = error "urk" + in ...(case x of )... +or + let f = \y. error (y ++ "urk") + in ...(case f "foo" of )... + +Then we'd like to drop the dead immediately. So it's good to +propagate the info that x's (or f's) RHS is bottom to x's (or f's) +IdInfo as rapidly as possible. + +We use tryEtaExpandRhs on every binding, and it turns out that the +arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already +does a simple bottoming-expression analysis. So all we need to do +is propagate that info to the binder's IdInfo. + +This showed up in #12150; see comment:16. + +There is a second reason for settting the strictness signature. Consider + let -- f :: <[S]b> + f = \x. error "urk" + in ...(f a b c)... +Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f` +to eta-expand to + let f = \x y z. error "urk" + in ...(f a b c)... + +But now f's strictness signature has too short an arity; see +GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth]. +Fortuitously, the same strictness-signature-fixup code +gives the function a new strictness signature with the right number of +arguments. Example in stranal/should_compile/EtaExpansion. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + +Note [Use occ-anald RHS in postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we postInlineUnconditionally 'f in + let f = \x -> x True in ...(f blah)... +then we'd like to inline the /occ-anald/ RHS for 'f'. If we +use the non-occ-anald version, we'll end up with a + ...(let x = blah in x True)... +and hence an extra Simplifier iteration. + +We already /have/ the occ-anald version in the Unfolding for +the Id. Well, maybe not /quite/ always. If the binder is Dead, +postInlineUnconditionally will return True, but we may not have an +unfolding because it's too big. Hence the belt-and-braces `orElse` +in the defn of unf_rhs. The Nothing case probably never happens. + +Note [Environment for simplLetUnfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be rather careful about the static environment in which +we simplify a stable unfolding. Consider (#24242): + + f x = let y_Xb = ... in + let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in + ... + +Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen; +see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier]. +This is perfectly fine. The `y_Xb` in the stable unfolding of the non- +recursive binding for `step1` refers, of course, to `let y_Xb = ....`. +When simplifying the binder `step1_Xb` we'll give it a new unique, and +extend the static environment with [Xb :-> step1_Xc], say. + +But when simplifying step1's stable unfolding, we must use static environment +/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps +[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc]. + +That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping +track of the right environment for the unfolding of that InId. See the type +of `simplLazyBind`, `simplJoinBind`, `completeBind`. + +This only matters when we have + - A non-recursive binding for f + - has a stable unfolding + - and that unfolding mentions a variable y + - that has the same unique as f. +So triggering a bug here is really hard! + +************************************************************************ +* * +\subsection[Simplify-simplExpr]{The main function: simplExpr} +* * +************************************************************************ + +The reason for this OutExprStuff stuff is that we want to float *after* +simplifying a RHS, not before. If we do so naively we get quadratic +behaviour as things float out. + +To see why it's important to do it after, consider this (real) example: + + let t = f x + in fst t +==> + let t = let a = e1 + b = e2 + in (a,b) + in fst t +==> + let a = e1 + b = e2 + t = (a,b) + in + a -- Can't inline a this round, cos it appears twice +==> + e1 + +Each of the ==> steps is a round of simplification. We'd save a +whole round if we float first. This can cascade. Consider + + let f = g d + in \x -> ...f... +==> + let f = let d1 = ..d.. in \y -> e + in \x -> ...f... +==> + let d1 = ..d.. + in \x -> ...(\y ->e)... + +Only in this second round can the \y be applied, and it +might do the same again. +-} + +simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr +simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier] + = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType] + ; return (Type ty') } + +simplExpr env expr + = simplExprC env expr (mkBoringStop expr_out_ty) + where + expr_out_ty :: OutType + expr_out_ty = substTy env (exprType expr) + -- NB: Since 'expr' is term-valued, not (Type ty), this call + -- to exprType will succeed. exprType fails on (Type ty). + +simplExprC :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM OutExpr + -- Simplify an expression, given a continuation +simplExprC env expr cont + = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $ + do { (floats, expr') <- simplExprF env expr cont + ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ + -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ + -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $ + return (wrapFloats floats expr') } + +-------------------------------------------------- +simplExprF :: SimplEnv + -> InExpr -- A term-valued expression, never (Type ty) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF !env e !cont -- See Note [Bangs in the Simplifier] + = -- pprTrace "simplExprF" (vcat + -- [ ppr e + -- , text "cont =" <+> ppr cont + -- , text "inscope =" <+> ppr (seInScope env) + -- , text "tvsubst =" <+> ppr (seTvSubst env) + -- , text "idsubst =" <+> ppr (seIdSubst env) + -- , text "cvsubst =" <+> ppr (seCvSubst env) + -- ]) $ + simplExprF1 env e cont + +simplExprF1 :: HasDebugCallStack + => SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplExprF1 _ (Type ty) cont + = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont) + -- simplExprF does only with term-valued expressions + -- The (Type ty) case is handled separately by simplExpr + -- and by the other callers of simplExprF + +simplExprF1 env (Var v) cont = {-#SCC "simplInId" #-} simplInId env v cont +simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont +simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont +simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont +simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont + +simplExprF1 env (App fun arg) cont + = {-#SCC "simplExprF1-App" #-} case arg of + Type ty -> do { -- The argument type will (almost) certainly be used + -- in the output program, so just force it now. + -- See Note [Avoiding space leaks in OutType] + arg' <- simplType env ty + + -- But use substTy, not simplType, to avoid forcing + -- the hole type; it will likely not be needed. + -- See Note [The hole type in ApplyToTy] + ; let hole' = substTy env (exprType fun) + + ; simplExprF env fun $ + ApplyToTy { sc_arg_ty = arg' + , sc_hole_ty = hole' + , sc_cont = cont } } + _ -> + -- Crucially, sc_hole_ty is a /lazy/ binding. It will + -- be forced only if we need to run contHoleType. + -- When these are forced, we might get quadratic behavior; + -- this quadratic blowup could be avoided by drilling down + -- to the function and getting its multiplicities all at once + -- (instead of one-at-a-time). But in practice, we have not + -- observed the quadratic behavior, so this extra entanglement + -- seems not worthwhile. + simplExprF env fun $ + ApplyToVal { sc_arg = arg, sc_env = env + , sc_hole_ty = substTy env (exprType fun) + , sc_dup = NoDup, sc_cont = cont } + +simplExprF1 env expr@(Lam {}) cont + = {-#SCC "simplExprF1-Lam" #-} + simplLam env (zapLambdaBndrs expr n_args) cont + -- zapLambdaBndrs: the issue here is under-saturated lambdas + -- (\x1. \x2. e) arg1 + -- Here x1 might have "occurs-once" occ-info, because occ-info + -- is computed assuming that a group of lambdas is applied + -- all at once. If there are too few args, we must zap the + -- occ-info, UNLESS the remaining binders are one-shot + where + n_args = countArgs cont + -- NB: countArgs counts all the args (incl type args) + -- and likewise drop counts all binders (incl type lambdas) + +simplExprF1 env (Case scrut bndr _ alts) cont + = {-#SCC "simplExprF1-Case" #-} + simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr + , sc_alts = alts + , sc_env = env, sc_cont = cont }) + +simplExprF1 env (Let (Rec pairs) body) cont + | Just pairs' <- joinPointBindings_maybe pairs + = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont + + | otherwise + = {-#SCC "simplRecE" #-} simplRecE env pairs body cont + +simplExprF1 env (Let (NonRec bndr rhs) body) cont + | Type ty <- rhs -- First deal with type lets (let a = Type ty in e) + = {-#SCC "simplExprF1-NonRecLet-Type" #-} + assert (isTyVar bndr) $ + do { ty' <- simplType env ty + ; simplExprF (extendTvSubst env bndr ty') body cont } + + | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env + -- Because of the let-can-float invariant, it's ok to + -- inline freely, or to drop the binding if it is dead. + = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ + tick (PreInlineUnconditionally bndr) + ; simplExprF env' body cont } + + -- Now check for a join point. It's better to do the preInlineUnconditionally + -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial + -- binding like { j = j2 |> co } would first be eta-expanded and then inlined + -- Better to test preInlineUnconditionally first. + | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs + = {-#SCC "simplNonRecJoinPoint" #-} + simplNonRecJoinPoint env bndr' rhs' body cont + + | otherwise + = {-#SCC "simplNonRecE" #-} + simplNonRecE env FromLet bndr (rhs, env) body cont + +{- Note [Avoiding space leaks in OutType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the simplifier is run for multiple iterations, we need to ensure +that any thunks in the output of one simplifier iteration are forced +by the evaluation of the next simplifier iteration. Otherwise we may +retain multiple copies of the Core program and leak a terrible amount +of memory (as in #13426). + +The simplifier is naturally strict in the entire "Expr part" of the +input Core program, because any expression may contain binders, which +we must find in order to extend the SimplEnv accordingly. But types +do not contain binders and so it is tempting to write things like + + simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad! + +This is Bad because the result includes a thunk (substTy env ty) which +retains a reference to the whole simplifier environment; and the next +simplifier iteration will not force this thunk either, because the +line above is not strict in ty. + +So instead our strategy is for the simplifier to fully evaluate +OutTypes when it emits them into the output Core program, for example + + simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good + ; return (Type ty') } + +where the only difference from above is that simplType calls seqType +on the result of substTy. + +However, SimplCont can also contain OutTypes and it's not necessarily +a good idea to force types on the way in to SimplCont, because they +may end up not being used and forcing them could be a lot of wasted +work. T5631 is a good example of this. + +- For ApplyToTy's sc_arg_ty, we force the type on the way in because + the type will almost certainly appear as a type argument in the + output program. + +- For the hole types in Stop and ApplyToTy, we force the type when we + emit it into the output program, after obtaining it from + contResultType. (The hole type in ApplyToTy is only directly used + to form the result type in a new Stop continuation.) +-} + +--------------------------------- +-- Simplify a join point, adding the context. +-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do: +-- \x1 .. xn -> e => \x1 .. xn -> E[e] +-- Note that we need the arity of the join point, since e may be a lambda +-- (though this is unlikely). See Note [Join points and case-of-case]. +simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont + -> SimplM OutExpr +simplJoinRhs env bndr expr cont + | JoinPoint arity <- idJoinPointHood bndr + = do { let (join_bndrs, join_body) = collectNBinders arity expr + mult = contHoleScaling cont + ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs) + ; join_body' <- simplExprC env' join_body cont + ; return $ mkLams join_bndrs' join_body' } + + | otherwise + = pprPanic "simplJoinRhs" (ppr bndr) + +--------------------------------- +simplType :: SimplEnv -> InType -> SimplM OutType + -- Kept monadic just so we can do the seqType + -- See Note [Avoiding space leaks in OutType] +simplType env ty + = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ + seqType new_ty `seq` return new_ty + where + new_ty = substTy env ty + +--------------------------------- +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; rebuild env (Coercion co') cont } + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion +simplCoercion env co + = do { let opt_co | reSimplifying env = substCo env co + | otherwise = optCoercion opts subst co + -- If (reSimplifying env) is True we have already simplified + -- this coercion once, and we don't want do so again; doing + -- so repeatedly risks non-linear behaviour + -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env + ; seqCo opt_co `seq` return opt_co } + where + subst = getTCvSubst env + opts = seOptCoercionOpts env + +----------------------------------- +-- | Push a TickIt context outwards past applications and cases, as +-- long as this is a non-scoping tick, to let case and application +-- optimisations apply. + +simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplTick env tickish expr cont + -- A scoped tick turns into a continuation, so that we can spot + -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do + -- it this way, then it would take two passes of the simplifier to + -- reduce ((scc t (\x . e)) e'). + -- NB, don't do this with counting ticks, because if the expr is + -- bottom, then rebuildCall will discard the continuation. + +-------------------------- +-- | tickishScoped tickish && not (tickishCounts tickish) +-- = simplExprF env expr (TickIt tickish cont) +-- XXX: we cannot do this, because the simplifier assumes that +-- the context can be pushed into a case with a single branch. e.g. +-- scc case expensive of p -> e +-- becomes +-- case expensive of p -> scc e +-- +-- So I'm disabling this for now. It just means we will do more +-- simplifier iterations that necessary in some cases. +-------------------------- + + -- For unscoped or soft-scoped ticks, we are allowed to float in new + -- cost, so we simply push the continuation inside the tick. This + -- has the effect of moving the tick to the outside of a case or + -- application context, allowing the normal case and application + -- optimisations to fire. + | tickish `tickishScopesLike` SoftScope + = do { (floats, expr') <- simplExprF env expr cont + ; return (floats, mkTick tickish expr') + } + + -- Push tick inside if the context looks like this will allow us to + -- do a case-of-case - see Note [case-of-scc-of-case] + | Select {} <- cont, Just expr' <- push_tick_inside + = simplExprF env expr' cont + + -- We don't want to move the tick, but we might still want to allow + -- floats to pass through with appropriate wrapping (or not, see + -- wrap_floats below) + --- | not (tickishCounts tickish) || tickishCanSplit tickish + -- = wrap_floats + + | otherwise + = no_floating_past_tick + + where + + -- Try to push tick inside a case, see Note [case-of-scc-of-case]. + push_tick_inside = + case expr0 of + Case scrut bndr ty alts + -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts) + _other -> Nothing + where (ticks, expr0) = stripTicksTop movable (Tick tickish expr) + movable t = not (tickishCounts t) || + t `tickishScopesLike` NoScope || + tickishCanSplit t + tickScrut e = foldr mkTick e ticks + -- Alternatives get annotated with all ticks that scope in some way, + -- but we don't want to count entries. + tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope) + ts_scope = map mkNoCount $ + filter (not . (`tickishScopesLike` NoScope)) ticks + + no_floating_past_tick = + do { let (inc,outc) = splitCont cont + ; (floats, expr1) <- simplExprF env expr inc + ; let expr2 = wrapFloats floats expr1 + tickish' = simplTickish env tickish + ; rebuild env (mkTick tickish' expr2) outc + } + +-- Alternative version that wraps outgoing floats with the tick. This +-- results in ticks being duplicated, as we don't make any attempt to +-- eliminate the tick if we re-inline the binding (because the tick +-- semantics allows unrestricted inlining of HNFs), so I'm not doing +-- this any more. FloatOut will catch any real opportunities for +-- floating. +-- +-- wrap_floats = +-- do { let (inc,outc) = splitCont cont +-- ; (env', expr') <- simplExprF (zapFloats env) expr inc +-- ; let tickish' = simplTickish env tickish +-- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0), +-- mkTick (mkNoCount tickish') rhs) +-- -- when wrapping a float with mkTick, we better zap the Id's +-- -- strictness info and arity, because it might be wrong now. +-- ; let env'' = addFloats env (mapFloats env' wrap_float) +-- ; rebuild env'' expr' (TickIt tickish' outc) +-- } + + + simplTickish env tickish + | Breakpoint ext bid ids <- tickish + = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids) + | otherwise = tickish + + -- Push type application and coercion inside a tick + splitCont :: SimplCont -> (SimplCont, SimplCont) + splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont cont@(CastIt { sc_cont = tail }) = (cont { sc_cont = inc }, outc) + where (inc,outc) = splitCont tail + splitCont other = (mkBoringStop (contHoleType other), other) + + getDoneId (DoneId id) = Just id + getDoneId (DoneEx (Var id) _) = Just id + getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst + getDoneId other = pprPanic "getDoneId" (ppr other) + +-- Note [case-of-scc-of-case] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It's pretty important to be able to transform case-of-case when +-- there's an SCC in the way. For example, the following comes up +-- in nofib/real/compress/Encode.hs: +-- +-- case scctick +-- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje +-- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) -> +-- (ww1_s13f, ww2_s13g, ww3_s13h) +-- } +-- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) -> +-- tick +-- (ww_s12Y, +-- ww1_s12Z, +-- PTTrees.PT +-- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf) +-- } +-- +-- We really want this case-of-case to fire, because then the 3-tuple +-- will go away (indeed, the CPR optimisation is relying on this +-- happening). But the scctick is in the way - we need to push it +-- inside to expose the case-of-case. So we perform this +-- transformation on the inner case: +-- +-- scctick c (case e of { p1 -> e1; ...; pn -> en }) +-- ==> +-- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en } +-- +-- So we've moved a constant amount of work out of the scc to expose +-- the case. We only do this when the continuation is interesting: in +-- for now, it has to be another Case (maybe generalise this later). + +{- +************************************************************************ +* * +\subsection{The main rebuilder} +* * +************************************************************************ +-} + +rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont + +rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) +-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant; +-- only the in-scope set matters, plus the flags. +rebuild_go env expr cont + = assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $ + case cont of + Stop {} -> return (emptyFloats env, expr) + TickIt t cont -> rebuild_go env (mkTick t expr) cont + CastIt { sc_co = co, sc_opt = opt, sc_cont = cont } + -> rebuild_go env (mkCast expr co') cont + -- NB: mkCast implements the (Coercion co |> g) optimisation + where + co' = optOutCoercion env co opt + + Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } + -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont + + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } + -> rebuildCall env (addValArgTo fun expr fun_ty) cont + + StrictBind { sc_bndr = b, sc_body = body, sc_env = se + , sc_cont = cont, sc_from = from_what } + -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont + + ApplyToTy { sc_arg_ty = ty, sc_cont = cont} + -> rebuild_go env (App expr (Type ty)) cont + + ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag + , sc_cont = cont, sc_hole_ty = fun_ty } + -- See Note [Avoid redundant simplification] + -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg + ; rebuild_go env (App expr arg') cont } + +completeBindX :: SimplEnv + -> FromWhat + -> InId -> OutExpr -- Non-recursively bind this Id to this (simplified) expression + -- (the let-can-float invariant may not be satisfied) + -> InExpr -- In this body + -> SimplCont -- Consumed by this continuation + -> SimplM (SimplFloats, OutExpr) +completeBindX env from_what bndr rhs body cont + | FromBeta arg_levity <- from_what + , needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant + = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules + ; (floats, expr') <- simplNonRecBody env1 from_what body cont + -- Do not float floats past the Case binder below + ; let expr'' = wrapFloats floats expr' + case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] + ; return (emptyFloats env, case_expr) } + + | otherwise -- Make a let-binding + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + + ; let is_strict = isStrictId bndr2 + -- isStrictId: use simplified binder because the InId bndr might not have + -- a fixed runtime representation, which isStrictId doesn't expect + -- c.f. Note [Dark corner with representation polymorphism] + + ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict + bndr2 (emptyFloats env) rhs + -- NB: it makes a surprisingly big difference (5% in compiler allocation + -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', + -- because this is completeBindX, so bndr is not in scope in the RHS. + + ; let env3 = env2 `setInScopeFromF` rhs_floats + ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (bndr2, rhs1, env3) + -- Must pass env1 to completeBind in case simplBinder had to clone, + -- and extended the substitution with [bndr :-> new_bndr] + + -- Simplify the body + ; (body_floats, body') <- simplNonRecBody env4 from_what body cont + + ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats + ; return ( all_floats, body' ) } + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +{- Note [Optimising reflexivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important (for compiler performance) to get rid of reflexivity as soon +as it appears. See #11735, #14737, and #15019. + +In particular, we want to behave well on + + * e |> co1 |> co2 + where the two happen to cancel out entirely. That is quite common; + e.g. a newtype wrapping and unwrapping cancel. + + + * (f |> co) @t1 @t2 ... @tn x1 .. xm + Here we will use pushCoTyArg and pushCoValArg successively, which + build up SelCo stacks. Silly to do that if co is reflexive. + +However, we don't want to call isReflexiveCo too much, because it uses +type equality which is expensive on big types (#14737 comment:7). + +A good compromise (determined experimentally) seems to be to call +isReflexiveCo + * when composing casts, and + * at the end + +In investigating this I saw missed opportunities for on-the-fly +coercion shrinkage. See #15090. + +Note [Avoid re-simplifying coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some benchmarks (with deeply nested cases) we successively push +casts onto the SimplCont. We don't want to call the coercion optimiser +on each successive composition -- that's at least quadratic. So: + +* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to + record whether the coercion optimiser has been applied to the coercion. + +* In `simplCast`, when we see (Cast e co), we simplify `co` to get + an OutCoercion, and built a CastIt with sc_opt=True. + + Actually not quite: if we are simplifying the result of inlining an + unfolding (seInlineDepth > 0), then instead of /optimising/ it again, + just /substitute/ which is cheaper. See `simplCoercion`. + +* In `addCoerce` (in `simplCast`) if we combine this new coercion with + an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False. + +* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise + the (presumably composed) coercion if sc_opt=False; this is done + by `optOutCoercion`. + +* When duplicating a continuation in `mkDupableContWithDmds`, before + duplicating a CastIt, optimise the coercion. Otherwise we'll end up + optimising it separately in the duplicate copies. +-} + + +optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion +-- See Note [Avoid re-simplifying coercions] +optOutCoercion env co already_optimised + | already_optimised = co -- See Note [Avoid re-simplifying coercions] + | otherwise = optCoercion opts empty_subst co + where + empty_subst = mkEmptySubst (seInScope env) + opts = seOptCoercionOpts env + +simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplCast env body co0 cont0 + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0 + ; cont1 <- {-#SCC "simplCast-addCoerce" #-} + if isReflCo co1 + then return cont0 -- See Note [Optimising reflexivity] + else addCoerce co1 True cont0 + -- True <=> co1 is optimised + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 } + where + + -- If the first parameter is MRefl, then simplifying revealed a + -- reflexive coercion. Omit. + addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerceM MRefl _ cont = return cont + addCoerceM (MCo co) opt cont = addCoerce co opt cont + + addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont + addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity] + = addCoerce (mkTransCo co1 co2) False cont + -- False: (mkTransCo co1 co2) is not fully optimised + -- See Note [Avoid re-simplifying coercions] + + addCoerce co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty + = {-#SCC "addCoerce-pushCoTyArg" #-} + do { tail' <- addCoerceM m_co' opt tail + ; return (ApplyToTy { sc_arg_ty = arg_ty' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } + -- NB! As the cast goes past, the + -- type of the hole changes (#16312) + -- (f |> co) e ===> (f (e |> co1)) |> co2 + -- where co :: (s1->s2) ~ (t1->t2) + -- co1 :: t1 ~ s1 + -- co2 :: s2 ~ t2 + addCoerce co opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup, sc_cont = tail + , sc_hole_ty = fun_ty }) + | not opt -- pushCoValArg duplicates the coercion, so optimise first + = addCoerce (optOutCoercion (zapSubstEnv env) co opt) True cont + + | Just (m_co1, m_co2) <- pushCoValArg co + , fixed_rep m_co1 + = {-#SCC "addCoerce-pushCoValArg" #-} + do { tail' <- addCoerceM m_co2 opt tail + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; + -- See Note [Avoiding simplifying repeatedly] + + MCo co1 -> + do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg + -- When we build the ApplyTo we can't mix the OutCoercion + -- 'co' with the InExpr 'arg', so we simplify + -- to make it all consistent. It's a bit messy. + -- But it isn't a common case. + -- Example of use: #995 + ; return (ApplyToVal { sc_arg = mkCast arg' co1 + , sc_env = arg_se' + , sc_dup = dup' + , sc_cont = tail' + , sc_hole_ty = coercionLKind co }) } } } + + addCoerce co opt cont + | isReflCo co = return cont -- Having this at the end makes a huge + -- difference in T12227, for some reason + -- See Note [Optimising reflexivity] + | otherwise = return (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) + + fixed_rep :: MCoercionR -> Bool + fixed_rep MRefl = True + fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co + -- Without this check, we can get an argument which does not + -- have a fixed runtime representation. + -- See Note [Representation polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + +simplLazyArg :: SimplEnvIS -- ^ Used only for its InScopeSet + -> DupFlag + -> OutType -- ^ Type of the function applied to this arg + -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app + -- `f a1 ... an` where we have ArgInfo on + -- how `f` uses `ai`, affecting the Stop + -- continuation passed to 'simplExprC' + -> StaticEnv -> CoreExpr -- ^ Expression with its static envt + -> SimplM (DupFlag, StaticEnv, OutExpr) +simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg + | isSimplified dup_flag + = return (dup_flag, arg_env, arg) + | otherwise + = do { let arg_env' = arg_env `setInScopeFromE` env + ; let arg_ty = funArgTy fun_ty + ; let stop = case mb_arg_info of + Nothing -> mkBoringStop arg_ty + Just ai -> mkLazyArgStop arg_ty ai + ; arg' <- simplExprC arg_env' arg stop + ; return (Simplified, zapSubstEnv arg_env', arg') } + -- Return a StaticEnv that includes the in-scope set from 'env', + -- because arg' may well mention those variables (#20639) + +{- +************************************************************************ +* * +\subsection{Lambdas} +* * +************************************************************************ +-} + +simplNonRecBody :: SimplEnv -> FromWhat + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecBody env from_what body cont + = case from_what of + FromLet -> simplExprF env body cont + FromBeta {} -> simplLam env body cont + +simplLam :: SimplEnv -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont +simplLam env expr cont = simplExprF env expr cont + +simpl_lam :: HasDebugCallStack + => SimplEnv -> InBndr -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- Type beta-reduction +simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) + = do { tick (BetaReduction bndr) + ; simplLam (extendTvSubst env bndr arg_ty) body cont } + +-- Coercion beta-reduction +simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se + , sc_cont = cont }) + = assertPpr (isCoVar bndr) (ppr bndr) $ + do { tick (BetaReduction bndr) + ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co + ; simplLam (extendCvSubst env bndr arg_co') body cont } + +-- Value beta-reduction +-- This works for /coercion/ lambdas too +simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_dup = dup + , sc_hole_ty = fun_ty}) + = do { tick (BetaReduction bndr) + ; let from_what = FromBeta arg_levity + arg_levity + | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted + | otherwise = typeLevity (funArgTy fun_ty) + -- Example: (\(cv::a ~# b). blah) co + -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType + + -- Using fun_ty: see Note [Dark corner with representation polymorphism] + -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg + -- When we come to `x=arg` we must choose lazy/strict correctly + -- It's wrong to err in either direction + -- But fun_ty is an OutType, so is fully substituted + + ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se + , not (needsCaseBindingL arg_levity arg) + -- Ok to test arg::InExpr in needsCaseBinding because + -- exprOkForSpeculation is stable under simplification + , not ( isSimplified dup && -- See (SR2) in Note [Avoiding simplifying repeatedly] + not (exprIsTrivial arg) && + not (isDeadOcc (idOccInfo bndr)) ) + -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $ + tick (PreInlineUnconditionally bndr) + ; simplLam env' body cont } + + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- Including don't preInlineUnconditionally + -- See Note [Avoiding simplifying repeatedly] + -> completeBindX env from_what bndr arg body cont + + | otherwise + -> simplNonRecE env from_what bndr (arg, arg_se) body cont } + +-- Discard a non-counting tick on a lambda. This may change the +-- cost attribution slightly (moving the allocation of the +-- lambda elsewhere), but we don't care: optimisation changes +-- cost attribution all the time. +simpl_lam env bndr body (TickIt tickish cont) + | not (tickishCounts tickish) + = simpl_lam env bndr body cont + +-- Not enough args, so there are real lambdas left to put in the result +simpl_lam env bndr body cont + = do { let (inner_bndrs, inner_body) = collectBinders body + ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs) + ; body' <- simplExpr env' inner_body + ; new_lam <- rebuildLam env' bndrs' body' cont + ; rebuild env' new_lam cont } + +------------- +simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) +-- Historically this had a special case for when a lambda-binder +-- could have a stable unfolding; +-- see Historical Note [Case binders and join points] +-- But now it is much simpler! We now only remove unfoldings. +-- See Note [Never put `OtherCon` unfoldings on lambda binders] +simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr) + +simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr]) +simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs + +------------------ +simplNonRecE :: HasDebugCallStack + => SimplEnv + -> FromWhat + -> InId -- The binder, always an Id + -- Never a join point + -- The static env for its unfolding (if any) is the first parameter + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> InExpr -- Body of the let/lambda + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplNonRecE is used for +-- * from=FromLet: a non-top-level non-recursive non-join-point let-expression +-- * from=FromBeta: a binding arising from a beta reduction +-- +-- simplNonRecE env b (rhs, rhs_se) body k +-- = let env in +-- cont< let b = rhs_se(rhs) in body > +-- +-- It deals with strict bindings, via the StrictBind continuation, +-- which may abort the whole process. +-- +-- from_what=FromLet => the RHS satisfies the let-can-float invariant +-- Otherwise it may or may not satisfy it. + +simplNonRecE env from_what bndr (rhs, rhs_se) body cont + | assert (isId bndr && not (isJoinId bndr) ) $ + is_strict_bind + = -- Evaluate RHS strictly + simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + | otherwise -- Evaluate RHS lazily + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + ; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive + (bndr,env) (bndr2,env2) (rhs,rhs_se) + ; (floats2, expr') <- simplNonRecBody env3 from_what body cont + ; return (floats1 `addFloats` floats2, expr') } + + where + is_strict_bind = case from_what of + FromBeta Unlifted -> True + -- If we are coming from a beta-reduction (FromBeta) we must + -- establish the let-can-float invariant, so go via StrictBind + -- If not, the invariant holds already, and it's optional. + + -- (FromBeta Lifted) or FromLet: look at the demand info + _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr) + + +------------------ +simplRecE :: SimplEnv + -> [(InId, InExpr)] + -> InExpr + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-- simplRecE is used for +-- * non-top-level recursive lets in expressions +-- Precondition: not a join-point binding +simplRecE env pairs body cont + = do { let bndrs = map fst pairs + ; massert (all (not . isJoinId) bndrs) + ; env1 <- simplRecBndrs env bndrs + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs + ; (floats2, expr') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, expr') } + +{- Note [Dark corner with representation polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail +if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). +So we are careful to call `isStrictId` on the OutId, not the InId, in case we have + ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) +That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell +if x is lifted or unlifted from that. + +We only get such redexes from the compulsory inlining of a wired-in, +representation-polymorphic function like `rightSection` (see +GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined +such compulsory inlinings already, but belt and braces does no harm. + +Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the +Simplifier without first calling SimpleOpt, so anything involving +GHCi or TH and operator sections will fall over if we don't take +care here. + +Note [Avoiding simplifying repeatedly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One way in which we can get exponential behaviour is if we simplify a +big expression, and then re-simplify it -- and then this happens in a +deeply-nested way. So we must be jolly careful about re-simplifying +an expression (#13379). + +Example: + f BIG, where f has a RULE +Then + * We simplify BIG before trying the rule; but the rule does not fire + (forcing this simplification is why we have the RULE in this example) + * We inline f = \x. g x, in `simpl_lam` + * So if `simpl_lam` did preInlineUnconditionally we get (g BIG) + * Now if g has a RULE we'll simplify BIG again, and this whole thing can + iterate. + * However, if `f` did not have a RULE, so that BIG has /not/ already been + simplified, we /want/ to do preInlineUnconditionally in simpl_lam. + +So we go to some effort to avoid repeatedly simplifying the same thing: + +* ApplyToVal has a (sc_dup :: DupFlag) field which records if the argument + has been evaluated. + +* simplArg checks this flag to avoid re-simplifying. + +* simpl_lam has: + - a case for (isSimplified dup), which goes via completeBindX, and + - a case for an un-simplified argument, which tries preInlineUnconditionally + +* We go to some efforts to avoid unnecessarily simplifying ApplyToVal, + in at least two places + - In simplCast/addCoerce, where we check for isReflCo + - We sometimes try rewrite RULES befoe simplifying arguments; + see Note [tryRules: plan (BEFORE)] + +Wrinkles: + +(SR1) All that said /postInlineUnconditionally/ (called in `completeBind`) does + fire in the above (f BIG) situation. See Note [Post-inline for single-use + things] in Simplify.Utils. This certainly risks repeated simplification, + but in practice seems to be a small win. + +(SR2) When considering preInlineUnconditionally in `simpl_lam`, if the + expression is trivial, or it is dead (the binder doesn't occur), then there + is no danger of simplifying repeatedly. But there is a benefit: it can save + a simplifier iteration. So we check for that. + + +************************************************************************ +* * + Join points +* * +********************************************************************* -} + +{- Note [Rules and unfolding for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + simplExpr (join j x = rhs ) cont + ( {- RULE j (p:ps) = blah -} ) + ( {- StableUnfolding j = blah -} ) + (in blah ) + +Then we will push 'cont' into the rhs of 'j'. But we should *also* push +'cont' into the RHS of + * Any RULEs for j, e.g. generated by SpecConstr + * Any stable unfolding for j, e.g. the result of an INLINE pragma + +Simplifying rules and stable-unfoldings happens a bit after +simplifying the right-hand side, so we remember whether or not it +is a join point, and what 'cont' is, in a value of type MaybeJoinCont + +#13900 was caused by forgetting to push 'cont' into the RHS +of a SpecConstr-generated RULE for a join point. +-} + +simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplNonRecJoinPoint env bndr rhs body cont + = assert (isJoinId bndr ) $ + wrapJoinCont env cont $ \ env cont -> + do { -- We push join_cont into the join RHS and the body; + -- and wrap wrap_cont around the whole thing + ; let mult = contHoleScaling cont + res_ty = contResultType cont + ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) + ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) + ; (floats2, body') <- simplExprF env3 body cont + ; return (floats1 `addFloats` floats2, body') } + + +------------------ +simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)] + -> InExpr -> SimplCont + -> SimplM (SimplFloats, OutExpr) +simplRecJoinPoint env pairs body cont + = wrapJoinCont env cont $ \ env cont -> + do { let bndrs = map fst pairs + mult = contHoleScaling cont + res_ty = contResultType cont + ; env1 <- simplRecJoinBndrs env bndrs mult res_ty + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs + ; (floats2, body') <- simplExprF env2 body cont + ; return (floats1 `addFloats` floats2, body') } + +-------------------- +wrapJoinCont :: SimplEnv -> SimplCont + -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr)) + -> SimplM (SimplFloats, OutExpr) +-- Deal with making the continuation duplicable if necessary, +-- and with the no-case-of-case situation. +wrapJoinCont env cont thing_inside + | contIsStop cont -- Common case; no need for fancy footwork + = thing_inside env cont + + | not (seCaseCase env) + -- See Note [Join points with -fno-case-of-case] + = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont)) + ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1 + ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont + ; return (floats2 `addFloats` floats3, expr3) } + + | otherwise + -- Normal case; see Note [Join points and case-of-case] + = do { (floats1, cont') <- mkDupableCont env cont + ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont' + ; return (floats1 `addFloats` floats2, result) } + + +-------------------- +trimJoinCont :: Id -- Used only in error message + -> JoinPointHood + -> SimplCont -> SimplCont +-- Drop outer context from join point invocation (jump) +-- See Note [Join points and case-of-case] + +trimJoinCont _ NotJoinPoint cont + = cont -- Not a jump +trimJoinCont var (JoinPoint arity) cont + = trim arity cont + where + trim 0 cont@(Stop {}) + = cont + trim 0 cont + = mkBoringStop (contResultType cont) + trim n cont@(ApplyToVal { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } + trim n cont@(ApplyToTy { sc_cont = k }) + = cont { sc_cont = trim (n-1) k } -- join arity counts types! + trim _ cont + = pprPanic "completeCall" $ ppr var $$ ppr cont + + +{- Note [Join points and case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we perform the case-of-case transform (or otherwise push continuations +inward), we want to treat join points specially. Since they're always +tail-called and we want to maintain this invariant, we can do this (for any +evaluation context E): + + E[join j = e + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> f 3] + + --> + + join j = E[e] + in case ... of + A -> jump j 1 + B -> jump j 2 + C -> E[f 3] + +As is evident from the example, there are two components to this behavior: + + 1. When entering the RHS of a join point, copy the context inside. + 2. When a join point is invoked, discard the outer context. + +We need to be very careful here to remain consistent---neither part is +optional! + +We need do make the continuation E duplicable (since we are duplicating it) +with mkDupableCont. + + +Note [Join points with -fno-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose case-of-case is switched off, and we are simplifying + + case (join j x = in + case y of + A -> j 1 + B -> j 2 + C -> e) of + +Usually, we'd push the outer continuation (case . of ) into +both the RHS and the body of the join point j. But since we aren't doing +case-of-case we may then end up with this totally bogus result + + join x = case of in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of + +This would be OK in the language of the paper, but not in GHC: j is no longer +a join point. We can only do the "push continuation into the RHS of the +join point j" if we also push the continuation right down to the /jumps/ to +j, so that it can evaporate there. If we are doing case-of-case, we'll get to + + join x = case of in + case y of + A -> j 1 + B -> j 2 + C -> case e of + +which is great. + +Bottom line: if case-of-case is off, we must stop pushing the continuation +inwards altogether at any join point. Instead simplify the (join ... in ...) +with a Stop continuation, and wrap the original continuation around the +outside. Surprisingly tricky! + + +************************************************************************ +* * + Variables +* * +************************************************************************ + +Note [zapSubstEnv] +~~~~~~~~~~~~~~~~~~ +When simplifying something that has already been simplified, be sure to +zap the SubstEnv. This is VITAL. Consider + let x = e in + let y = \z -> ...x... in + \ x -> ...y... + +We'll clone the inner \x, adding x->x' in the id_subst Then when we +inline y, we must *not* replace x by x' in the inlined copy!! + +Note [Fast path for lazy data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For applications of a /lazy/ data constructor worker, the full glory of +rebuildCall is a waste of effort; +* They never inline, obviously +* They have no rewrite rules +* Lazy constructors don't need the `StrictArg` treatment. +So it's fine to zoom straight to `rebuild` which just rebuilds the +call in a very straightforward way. + +For a data constructor worker that is strict (see Note [Strict fields in Core]) +we take the slow path, so that we'll transform + K (case x of (a,b) -> a) --> case x of (a,b) -> K a +via the StrictArg case of rebuildCall + +Some programs have a /lot/ of data constructors in the source program +(compiler/perf/T9961 is an example), so this fast path can be very +valuable. +-} + +simplInVar :: SimplEnv -> InVar -> SimplM OutExpr +-- Look up an InVar in the environment +simplInVar env var + -- Why $! ? See Note [Bangs in the Simplifier] + | isTyVar var = return $! Type $! (substTyVar env var) + | isCoVar var = return $! Coercion $! (substCoVar env var) + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids + in simplExpr env' e + DoneId var1 -> return (Var var1) + DoneEx e _ -> return e + +simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) +simplInId env var cont + | Just dc <- isDataConWorkId_maybe var + , isLazyDataConRep dc -- See Note [Fast path for lazy data constructors] + = rebuild zapped_env (Var var) cont + | otherwise + = case substId env var of + ContEx tvs cvs ids e -> simplExprF env' e cont + -- Don't trimJoinCont; haven't already simplified e, + -- so the cont is not embodied in e + where + env' = setSubstEnv env tvs cvs ids + + DoneId out_id -> simplOutId zapped_env out_id cont' + where + cont' = trimJoinCont out_id (idJoinPointHood out_id) cont + + DoneEx e mb_join -> simplExprF zapped_env e cont' + where + cont' = trimJoinCont var mb_join cont + where + zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] + +--------------------------------------------------------- +simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) + +---------- The runRW# rule ------ +-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. +-- +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# @rr @hole_ty body ] --> runRW @rr' @ty' (\s. K[ body s ]) +simplOutId env fun cont + | fun `hasKey` runRWKey + , ApplyToTy { sc_cont = cont1 } <- cont + , ApplyToTy { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1 + , ApplyToVal { sc_cont = cont3, sc_arg = arg + , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2 + -- Do this even if (contIsStop cont), or if seCaseCase is off. + -- See Note [No eta-expansion in runRW#] + = do { let arg_env = arg_se `setInScopeFromE` env + + overall_res_ty = contResultType cont3 + -- hole_ty is the type of the current runRW# application + (outer_cont, new_runrw_res_ty, inner_cont) + | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont3) + | otherwise = (cont3, hole_ty, mkBoringStop hole_ty) + -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + + -- If the argument is a literal lambda already, take a short cut + -- This isn't just efficiency: + -- * If we don't do this we get a beta-redex every time, so the + -- simplifier keeps doing more iterations. + -- * Even more important: see Note [No eta-expansion in runRW#] + ; arg' <- case arg of + Lam s body -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body inner_cont + ; return (Lam s' body') } + -- Important: do not try to eta-expand this lambda + -- See Note [No eta-expansion in runRW#] + + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = arg_env `addNewInScopeIds` [s'] + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' + , sc_env = env', sc_cont = inner_cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } + -- cont' applies to s', then K + ; body' <- simplExprC env' arg cont' + ; return (Lam s' body') } + + ; let rr' = getRuntimeRep new_runrw_res_ty + call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] + ; rebuild env call' outer_cont } + +-- Normal case for (f e1 .. en) +simplOutId env fun cont + = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules] + do { rule_base <- getSimplRules + ; let rules_for_me = getRules rule_base fun + out_args = contOutArgs env cont :: [OutExpr] + ; mb_match <- if not (null rules_for_me) && + (isClassOpId fun || activeUnfolding (seMode env) fun) + then tryRules env rules_for_me fun out_args + else return Nothing + ; case mb_match of { + Just (rule_arity, rhs) -> simplExprF env rhs $ + dropContArgs rule_arity cont ; + Nothing -> + + -- Try inlining + do { logger <- getLogger + ; mb_inline <- tryInlining env logger fun cont + ; case mb_inline of{ + Just expr -> do { checkedTick (UnfoldingDone fun) + ; simplExprF env expr cont } ; + Nothing -> + + -- Neither worked, so just rebuild + do { let arg_info = mkArgInfo env fun rules_for_me cont + ; rebuildCall env arg_info cont + } } } } } + +--------------------------------------------------------- +-- Dealing with a call site + +rebuildCall :: SimplEnvIS -> ArgInfo -> SimplCont + -> SimplM (SimplFloats, OutExpr) +-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant; +-- it is usually empty, and regardless should be ignored. +-- Only the in-scope set matters, plus the seMode flags + +-- Check the invariant +rebuildCall env arg_info _cont + | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env $$ ppr arg_info) False + = pprPanic "rebuildCall" empty + +---------- Bottoming applications -------------- +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont + -- When we run out of strictness args, it means + -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo + -- Then we want to discard the entire strict continuation. E.g. + -- * case (error "hello") of { ... } + -- * (error "Hello") arg + -- * f (error "Hello") where f is strict + -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. + | not (contIsTrivial cont) -- Only do this if there is a non-trivial + -- continuation to discard, else we do it + -- again and again! + = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType] + return (emptyFloats env, castBottomExpr res cont_ty) + where + res = argInfoExpr fun rev_args + cont_ty = contResultType cont + +---------- Simplify type applications -------------- +rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }) + = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont + +---------- Simplify value arguments -------------------- +rebuildCall env fun_info + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_dup = dup_flag, sc_hole_ty = fun_ty + , sc_cont = cont }) + -- Argument is already simplified + | isSimplified dup_flag -- See Note [Avoid redundant simplification] + = rebuildCall env (addValArgTo fun_info arg fun_ty) cont + + -- Strict arguments + | isStrictArgInfo fun_info + , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ + simplExprF (arg_se `setInScopeFromE` env) arg + (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = Simplified + , sc_cont = cont }) + -- Note [Shadowing in the Simplifier] + + -- Lazy arguments + | otherwise + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } + +---------- No further useful info, revert to generic rebuild ------------ +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont + | null rules + = rebuild env (argInfoExpr fun rev_args) cont + | otherwise -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules] + = do { let args = reverse rev_args + ; mb_match <- tryRules env rules fun (map argSpecArg args) + ; case mb_match of + Just (rule_arity, rhs) -> simplExprF env rhs $ + pushSimplifiedArgs env (drop rule_arity args) cont + Nothing -> rebuild env (argInfoExpr fun rev_args) cont } + +----------------------------------- +tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr) +tryInlining env logger var cont + | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont + = do { dump_inline expr cont + ; return (Just expr) } + + | otherwise + = return Nothing + + where + (lone_variable, arg_infos, call_cont) = contArgs cont + interesting_cont = interestingCallContext env call_cont + + log_inlining doc + = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) + Opt_D_dump_inlinings + "" FormatText doc + + dump_inline unfolding cont + | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return () + | not (logHasDumpFlag logger Opt_D_verbose_core2core) + = when (isExternalName (idName var)) $ + log_inlining $ + sep [text "Inlining done:", nest 4 (ppr var)] + | otherwise + = log_inlining $ + sep [text "Inlining done: " <> ppr var, + nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), + text "Cont: " <+> ppr cont])] + + +{- Note [When to apply rewrite rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we apply rewrite rules before simplifying the arguments, or after? +Each is highly desirable in some cases, and in fact we do both! + + - Plan (BEFORE) selectively, in `simplOutId` + See Note [tryRules: plan (BEFORE)] + + - Plan (AFTER) always, in the finishing-up case of `rebuildCall` + See Note [tryRules: plan (AFTER)] + +Historical note. Pre-2025, GHC only did tryRules once, when it had simplified +enough arguments to saturate all the RULEs it had in hand. But alas, if a new +unrelated RULE showed up (but did not fire), it could nevertheless change the +simplifier's behaviour a bit; and that messed up deterministic compilation +(#25170). (This was particularly nasty if the rule wasn't even transitively +below the module being compiled.) Current solution: ensure that adding a new, +unrelated rule that never fires does not change the simplifier behaviour. End +of historical note. + +Note [tryRules: plan (BEFORE)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is sometimes desirable to apply RULES before simplifying the function +arguments. We do so in `simplOutId`. + +We do so /selectively/ (see (BF2)), in two particular cases: + +* Class ops + (+) dNumInt e2 e3 + If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the + latter's strictness when simplifying e2, e3. Moreover, if + (+) dNumInt e2 e3 --> (\x y -> ....) e2 e3 + Frequently `x` is used just once in the body of the (\x y -> ...). + If `e2` is un-simplified we can preInlineUnconditinally and that saves + simplifying `e2` twice. See Note [Avoiding simplifying repeatedly]. + +* Specialisation RULES. In general we try to arrange that inlining is disabled + (via a pragma) if a rewrite rule should apply, so that the rule has a decent + chance to fire before we inline the function. + + But it turns out that (especially when type-class specialisation or + SpecConstr is involved) it is very helpful for the the rewrite rule to + "win" over inlining when both are active at once: see #21851, #22097. + + So if the Id has an unfolding, we want to try RULES before we try inlining. + +Wrinkles: + +(BF1) Each un-simplified argument has its own static environment, stored + in its `ApplyToVal` nodes. So we can't just match on the un-simplified + arguments: we have to apply that static environment as a substitution + first! This is done lazily in `GHC.Core.Opt.Simplify.Utils.contOutArgs`, + so it'll be done just enough to allow the rule to match, or not. + +(BF2) The "selectively" in Plan (BEFORE) is a bit ad-hoc: + + * We want Plan (BEFORE) for class ops (see above in this Note) + + * But we do NOT want Plan (BEFORE) for primops, because the constant-folding + rules are quite complicated and expensive, and we don't want to try them + twice. Moreover the benefts of Plan (BEFORE), described in the Note, don't + apply to primops. + +Note [tryRules: plan (AFTER)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very desirable to try RULES once the arguments have been simplified, +because doing so ensures that rule cascades work in one pass. We do this +in the finishing-up case of `rebuildCall`. + +Consider + {-# RULES g (h x) = k x + f (k x) = x #-} + ...f (g (h x))... +Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If +we match f's rules against the un-simplified RHS, it won't match. This +makes a particularly big difference for + +* Superclass selectors + op ($p1 ($p2 (df d))) + We want all this to unravel in one sweep + +* Constant folding + +# 3# (+# 4# 5#) + We want this to happen in one pass + +Note [Avoid redundant simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because RULES often apply to simplified arguments (see Note [Plan (AFTER)]), +there's a danger of simplifying already-simplified arguments. For example, +suppose we have + RULE f (x,y) = $sf x y +and the expression + f (p,q) e1 e2 +With Plan (AFTER) by the time the rule fires, we will have already simplified e1, e2, +and we want to avoid doing so a second time. So ApplyToVal records if the argument +is already Simplified. + +Note [Shadowing in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This part of the simplifier may return an expression that has shadowing. +(See Note [Shadowing in Core] in GHC.Core.hs.) Consider + f (...(\a -> e)...) (case y of (a,b) -> e') +where f is strict in its second arg +If we simplify the innermost one first we get (...(\a -> e)...) +Simplifying the second arg makes us float the case out, so we end up with + case y of (a,b) -> f (...(\a -> e)...) e' +So the output does not have the no-shadowing invariant. However, there is +no danger of getting name-capture, because when the first arg was simplified +we used an in-scope set that at least mentioned all the variables free in its +static environment, and that is enough. + +We can't just do innermost first, or we'd end up with a dual problem: + case x of (a,b) -> f e (...(\a -> e')...) + +I spent hours trying to recover the no-shadowing invariant, but I just could +not think of an elegant way to do it. The simplifier is already knee-deep in +continuations. We have to keep the right in-scope set around; AND we have +to get the effect that finding (error "foo") in a strict arg position will +discard the entire application and replace it with (error "foo"). Getting +all this at once is TOO HARD! + +See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils. + +Note [No eta-expansion in runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see `runRW# (\s. blah)` we must not attempt to eta-expand that +lambda. Why not? Because +* `blah` can mention join points bound outside the runRW# +* eta-expansion uses arityType, and +* `arityType` cannot cope with free join Ids: + +So the simplifier spots the literal lambda, and simplifies inside it. +It's a very special lambda, because it is the one the OccAnal spots and +allows join points bound /outside/ to be called /inside/. + +See Note [No free join points in arityType] in GHC.Core.Opt.Arity + +************************************************************************ +* * + Rewrite rules +* * +************************************************************************ +-} + +tryRules :: SimplEnv -> [CoreRule] + -> OutId -> [OutExpr] + -> SimplM (Maybe (FullArgCount, CoreExpr)) + +tryRules env rules fn args + | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env + act_fun fn args rules + -- Fire a rule for the function + = do { logger <- getLogger + ; checkedTick (RuleFired (ruleName rule)) + ; let occ_anald_rhs = occurAnalyseExpr rule_rhs + -- See Note [Occurrence-analyse after rule firing] + ; dump logger rule rule_rhs + ; return (Just (ruleArity rule, occ_anald_rhs)) } + + | otherwise -- No rule fires + = do { logger <- getLogger + ; nodump logger -- This ensures that an empty file is written + ; return Nothing } + + where + ropts = seRuleOpts env :: RuleOpts + in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv + act_fun = activeRule (seMode env) :: Activation -> Bool + + printRuleModule rule + = parens (maybe (text "BUILTIN") + (pprModuleName . moduleName) + (ruleModule rule)) + + dump logger rule rule_rhs + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat + [ text "Rule:" <+> ftext (ruleName rule) + , text "Module:" <+> printRuleModule rule + , text "Full arity:" <+> ppr (ruleArity rule) + , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args)) + , text "After: " <+> pprCoreExpr rule_rhs ] + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = log_rule Opt_D_dump_rule_firings "Rule fired:" $ + ftext (ruleName rule) + <+> printRuleModule rule + + | otherwise + = return () + + nodump logger + | logHasDumpFlag logger Opt_D_dump_rule_rewrites + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_rewrites + + | logHasDumpFlag logger Opt_D_dump_rule_firings + = liftIO $ + touchDumpFile logger Opt_D_dump_rule_firings + + | otherwise + = return () + + log_rule flag hdr details + = do + { logger <- getLogger + ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText + $ sep [text hdr, nest 4 details] + } + +trySeqRules :: SimplEnv + -> OutExpr -> InExpr -- Scrutinee and RHS + -> SimplCont + -> SimplM (Maybe (CoreExpr, SimplCont)) +-- See Note [User-defined RULES for seq] +-- `in_env` applies to `rhs :: InExpr` but not to `scrut :: OutExpr` +trySeqRules in_env scrut rhs cont + = do { rule_base <- getSimplRules + ; let seq_rules = getRules rule_base seqId + ; mb_match <- tryRules in_env seq_rules seqId out_args + ; case mb_match of + Nothing -> return Nothing + Just (rule_arity, rhs) -> return (Just (rhs, cont')) + where + cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont + } + where + no_cast_scrut = drop_casts scrut + + -- All these are OutTypes + scrut_ty = exprType no_cast_scrut + seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b + res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b + res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b + res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty + res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty + rhs_ty = substTy in_env (exprType rhs) + rhs_rep = getRuntimeRep rhs_ty + + out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] + -- Cheaper than (map argSpecArg out_arg_specs) + out_arg_specs = [ TyArg { as_arg_ty = rhs_rep + , as_hole_ty = seq_id_ty } + , TyArg { as_arg_ty = scrut_ty + , as_hole_ty = res1_ty } + , TyArg { as_arg_ty = rhs_ty + , as_hole_ty = res2_ty } + , ValArg { as_arg = no_cast_scrut + , as_dmd = seqDmd + , as_hole_ty = res3_ty } ] + rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs + , sc_env = in_env, sc_cont = cont + , sc_hole_ty = res4_ty } + + -- Lazily evaluated, so we don't do most of this + drop_casts (Cast e _) = drop_casts e + drop_casts e = e + +{- Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given + case (scrut |> co) of _ -> rhs +look for rules that match the expression + seq @t1 @t2 scrut +where scrut :: t1 + rhs :: t2 + +If you find a match, rewrite it, and apply to 'rhs'. + +Notice that we can simply drop casts on the fly here, which +makes it more likely that a rule will match. + +See Note [User-defined RULES for seq] in GHC.Types.Id.Make. + +Note [Occurrence-analyse after rule firing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After firing a rule, we occurrence-analyse the instantiated RHS before +simplifying it. Usually this doesn't make much difference, but it can +be huge. Here's an example (simplCore/should_compile/T7785) + + map f (map f (map f xs) + += -- Use build/fold form of map, twice + map f (build (\cn. foldr (mapFB c f) n + (build (\cn. foldr (mapFB c f) n xs)))) + += -- Apply fold/build rule + map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n)) + += -- Beta-reduce + -- Alas we have no occurrence-analysed, so we don't know + -- that c is used exactly once + map f (build (\cn. let c1 = mapFB c f in + foldr (mapFB c1 f) n xs)) + += -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g) + -- We can do this because (mapFB c n) is a PAP and hence expandable + map f (build (\cn. let c1 = mapFB c n in + foldr (mapFB c (f.f)) n x)) + +This is not too bad. But now do the same with the outer map, and +we get another use of mapFB, and t can interact with /both/ remaining +mapFB calls in the above expression. This is stupid because actually +that 'c1' binding is dead. The outer map introduces another c2. If +there is a deep stack of maps we get lots of dead bindings, and lots +of redundant work as we repeatedly simplify the result of firing rules. + +The easy thing to do is simply to occurrence analyse the result of +the rule firing. Note that this occ-anals not only the RHS of the +rule, but also the function arguments, which by now are OutExprs. +E.g. + RULE f (g x) = x+1 + +Call f (g BIG) --> (\x. x+1) BIG + +The rule binders are lambda-bound and applied to the OutExpr arguments +(here BIG) which lack all internal occurrence info. + +Is this inefficient? Not really: we are about to walk over the result +of the rule firing to simplify it, so occurrence analysis is at most +a constant factor. + +Note, however, that the rule RHS is /already/ occ-analysed; see +Note [OccInfo in unfoldings and rules] in GHC.Core. There is something +unsatisfactory about doing it twice; but the rule RHS is usually very +small, and this is simple. + +Note [Rules for recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that we shouldn't apply rules for a loop breaker: +doing so might give rise to an infinite loop, because a RULE is +rather like an extra equation for the function: + RULE: f (g x) y = x+y + Eqn: f a y = a-y + +But it's too drastic to disable rules for loop breakers. +Even the foldr/build rule would be disabled, because foldr +is recursive, and hence a loop breaker: + foldr k z (build g) = g k z +So it's up to the programmer: rules can cause divergence + + +************************************************************************ +* * + Rebuilding a case expression +* * +************************************************************************ + +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> let y# = x# in e + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise +this idea to look for a case where we're scrutinising a variable, and we know +that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be eliminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparison operations (e.g. in (>=) for Int.Int32) + +Note [Case to let transformation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a case over a lifted type has a single alternative, and is being +used as a strict 'let' (all isDeadBinder bndrs), we may want to do +this transformation: + + case e of r ===> let r = e in ...r... + _ -> ...r... + +We treat the unlifted and lifted cases separately: + +* Unlifted case: 'e' satisfies exprOkForSpeculation + (ok-for-spec is needed to satisfy the let-can-float invariant). + This turns case a +# b of r -> ...r... + into let r = a +# b in ...r... + and thence .....(a +# b).... + + However, if we have + case indexArray# a i of r -> ...r... + we might like to do the same, and inline the (indexArray# a i). + But indexArray# is not okForSpeculation, so we don't build a let + in rebuildCase (lest it get floated *out*), so the inlining doesn't + happen either. Annoying. + +* Lifted case: we need to be sure that the expression is already + evaluated (exprIsHNF). If it's not already evaluated + - we risk losing exceptions, divergence or + user-specified thunk-forcing + - even if 'e' is guaranteed to converge, we don't want to + create a thunk (call by need) instead of evaluating it + right away (call by value) + + However, we can turn the case into a /strict/ let if the 'r' is + used strictly in the body. Then we won't lose divergence; and + we won't build a thunk because the let is strict. + See also Note [Case-to-let for strictly-used binders] + +Note [Case-to-let for strictly-used binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have this: + case of r { _ -> ..r.. } +where 'r' is used strictly in (..r..), we /could/ safely transform to + let r = in ...r... +As a special case, we have a plain `seq` like + case r of r1 { _ -> ...r1... } +where `r` is used strictly, we /could/ simply drop the `case` to get + ...r.... + +HOWEVER, there are some serious downsides to this transformation, so +GHC doesn't do it any longer (#24251): + +* Suppose the Simplifier sees + case x of y* { __DEFAULT -> + let z = case y of { __DEFAULT -> expr } in + z+1 } + The "y*" means "y is used strictly in its scope. Now we may: + - Eliminate the inner case because `y` is evaluated. + Now the demand-info on `y` is not right, because `y` is no longer used + strictly in its scope. But it is hard to spot that without doing a new + demand analysis. So there is a danger that we will subsequently: + - Eliminate the outer case because `y` is used strictly + Yikes! We can't eliminate both! + +* It introduces space leaks (#24251). Consider + go 0 where go x = x `seq` go (x + 1) + It is an infinite loop, true, but it should not leak space. Yet if we drop + the `seq`, it will. Another great example is #21741. + +* Dropping the outer `case` can change the error behaviour. For example, + we might transform + case x of { _ -> error "bad" } --> error "bad" + which is might be puzzling if 'x' currently lambda-bound, but later gets + let-bound to (error "good"). Tht is OK accoring to the paper "A semantics for + imprecise exceptions", but see #8900 for an example where the loss of this + transformation bit us in practice. + +* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x` + is strictly used, and we could soundly transform to + let x = e in f x + But if f's strictness info got worse (which can happen in in obscure cases; + see #21392) then we might have turned a non-thunk into a thunk! Bad. + +Lacking this "drop-strictly-used-seq" transformation means we can end up with +some redundant-looking evals. For example, consider + f x y = case x of DEFAULT -> -- A redundant-looking eval + case y of + True -> case x of { Nothing -> False; Just z -> z } + False -> case x of { Nothing -> True; Just z -> z } +That outer eval will be retained right through to code generation. But, +perhaps surprisingly, that is probably a /good/ thing: + + Key point: those inner (case x) expressions will be compiled a simple 'if', + because the code generator can see that `x` is, at those points, evaluated + and properly tagged. + +If we dropped the outer eval, both the inner (case x) expressions would need to +do a proper eval, pushing a return address, with an info table. See the example +in #15631 where, in the Description, the (case ys) will be a simple multi-way +jump. + +In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs +transformation, binary sizes fell by 1%, and a few programs actually allocated +less and ran faster. A case in point is nofib/imaginary/digits-of-e2. (I'm not +sure exactly why it improves so much, though.) + +Slightly related: Note [Empty case alternatives] in GHC.Core. + +Historical notes: + +There have been various earlier versions of this patch: + +* By Sept 18 the code looked like this: + || scrut_is_demanded_var scrut + + scrut_is_demanded_var :: CoreExpr -> Bool + scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s + scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) + scrut_is_demanded_var _ = False + + This only fired if the scrutinee was a /variable/, which seems + an unnecessary restriction. So in #15631 I relaxed it to allow + arbitrary scrutinees. Less code, less to explain -- but the change + had 0.00% effect on nofib. + +* Previously, in Jan 13 the code looked like this: + || case_bndr_evald_next rhs + + case_bndr_evald_next :: CoreExpr -> Bool + -- See Note [Case binder next] + case_bndr_evald_next (Var v) = v == case_bndr + case_bndr_evald_next (Cast e _) = case_bndr_evald_next e + case_bndr_evald_next (App e _) = case_bndr_evald_next e + case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e + case_bndr_evald_next _ = False + + This patch was part of fixing #7542. See also + Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.) + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: Void# -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. + + +Note [FloatBinds from constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have FloatBinds coming from the constructor wrapper +(as in Note [exprIsConApp_maybe on data constructors with wrappers]), +we cannot float past them. We'd need to float the FloatBind +together with the simplify floats, unfortunately the +simplifier doesn't have case-floats. The simplest thing we can +do is to wrap all the floats here. The next iteration of the +simplifier will take care of all these cases and lets. + +Given data T = MkT !Bool, this allows us to simplify +case $WMkT b of { MkT x -> f x } +to +case b of { b' -> f b' }. + +We could try and be more clever (like maybe wfloats only contain +let binders, so we could float them). But the need for the +extra complication is not clear. + +Note [Do not duplicate constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#20125) + let x = (a,b) + in ...(case x of x' -> blah)...x...x... + +We want that `case` to vanish (since `x` is bound to a data con) leaving + let x = (a,b) + in ...(let x'=x in blah)...x..x... + +In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`, +since is bound to (a,b). But in eliminating the case, if the scrutinee +is trivial, we want to bind the case-binder to the scrutinee, /not/ to +the constructor application. Hence the case_bndr_rhs in rebuildCase. + +This applies equally to a non-DEFAULT case alternative, say + let x = (a,b) in ...(case x of x' { (p,q) -> blah })... +This variant is handled by bind_case_bndr in knownCon. + +We want to bind x' to x, and not to a duplicated (a,b)). +-} + +--------------------------------------------------------- +-- Eliminate the case if possible + +rebuildCase, reallyRebuildCase + :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Alternatives (increasing order) + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +-------------------------------------------------- +-- 1. Eliminate the case if there's a known constructor +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts cont + | Lit lit <- scrut -- No need for same treatment as constructors + -- because literals are inlined more vigorously + , not (litIsLifted lit) + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs } + + | Just (in_scope', wfloats, con, ty_args, other_args) + <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + , let env0 = setInScopeSet env in_scope' + = do { tick (KnownBranch case_bndr) + ; let scaled_wfloats = map scale_float wfloats + -- case_bndr_unf: see Note [Do not duplicate constructor applications] + case_bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId con) `mkTyApps` ty_args + `mkApps` other_args + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env0 case_bndr alts cont + Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs + Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args + other_args case_bndr bs rhs cont + } + where + simple_rhs env wfloats case_bndr_rhs bs rhs = + assert (null bs) $ + do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs + -- scrut is a constructor application, + -- hence satisfies let-can-float invariant + ; (floats2, expr') <- simplExprF env' rhs cont + ; case wfloats of + [] -> return (floats1 `addFloats` floats2, expr') + _ -> return + -- See Note [FloatBinds from constructor wrappers] + ( emptyFloats env, + GHC.Core.Make.wrapFloats wfloats $ + wrapFloats (floats1 `addFloats` floats2) expr' )} + + -- This scales case floats by the multiplicity of the continuation hole (see + -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because + -- they are aliases anyway. + scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) = + let + scale_id id = scaleVarBy holeScaling id + in + GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars) + scale_float f = f + + holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr + -- We are in the following situation + -- case[p] case[q] u of { D x -> C v } of { C x -> w } + -- And we are producing case[??] u of { D x -> w[x\v]} + -- + -- What should the multiplicity `??` be? In order to preserve the usage of + -- variables in `u`, it needs to be `pq`. + -- + -- As an illustration, consider the following + -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) } + -- Where C :: A %1 -> T is linear + -- If we were to produce a case[1], like the inner case, we would get + -- case[1] of { C x -> (x, x) } + -- Which is ill-typed with respect to linearity. So it needs to be a + -- case[Many]. + +-------------------------------------------------- +-- 2. Eliminate the case if scrutinee is evaluated +-------------------------------------------------- + +rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont + -- See if we can get rid of the case altogether + -- See Note [Case elimination] + -- mkCase made sure that if all the alternatives are equal, + -- then there is now only one (DEFAULT) rhs + + -- 2a. Dropping the case altogether, if + -- a) it binds nothing (so it's really just a 'seq') + -- b) evaluating the scrutinee has no side effects + | is_plain_seq + , exprOkToDiscard scrut + -- The entire case is dead, so we can drop it + -- if the scrutinee converges without having imperative + -- side effects or raising a Haskell exception + = simplExprF env rhs cont + + -- 2b. Turn the case into a let, if + -- a) it binds only the case-binder + -- b) unlifted case: the scrutinee is ok-for-speculation + -- lifted case: the scrutinee is in HNF (or will later be demanded) + -- See Note [Case to let transformation] + | all_dead_bndrs + , doCaseToLet scrut case_bndr + = do { tick (CaseElim case_bndr) + ; (floats1, env') <- simplAuxBind "rebuildCaseAlt1" env case_bndr scrut + ; (floats2, expr') <- simplExprF env' rhs cont + ; return (floats1 `addFloats` floats2, expr') } + + -- 2c. Try the seq rules if + -- a) it binds only the case binder + -- b) a rule for seq applies + -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make + | is_plain_seq + = do { mb_rule <- trySeqRules env scrut rhs cont + ; case mb_rule of + Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont' + Nothing -> reallyRebuildCase env scrut case_bndr alts cont } + +-------------------------------------------------- +-- 3. Primop-related case-rules +-------------------------------------------------- + + |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts + = reallyRebuildCase env scrut' case_bndr' alts' cont + + where + all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] + is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect + +rebuildCase env scrut case_bndr alts cont + = reallyRebuildCase env scrut case_bndr alts cont + +doCaseToLet :: OutExpr -- Scrutinee + -> InId -- Case binder + -> Bool +-- The situation is case scrut of b { DEFAULT -> body } +-- Can we transform thus? let { b = scrut } in body +doCaseToLet scrut case_bndr + | isTyCoVar case_bndr -- Respect GHC.Core + = isTyCoArg scrut -- Note [Core type and coercion invariant] + + | isUnliftedType (exprType scrut) + -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase). + -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr' + -- (which is an 'InId'): see Note [Dark corner with representation polymorphism]. + -- Using `exprType` is typically cheap because `scrut` is typically a variable. + -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts + -- the brain more. Consider that if this test ever turns out to be a perf + -- problem (which seems unlikely). + = exprOkForSpeculation scrut + + | otherwise -- Scrut has a lifted type + = exprIsHNF scrut + -- || isStrUsedDmd (idDemandInfo case_bndr) + -- We no longer look at the demand on the case binder + -- See Note [Case-to-let for strictly-used binders] + +-------------------------------------------------- +-- 3. Catch-all case +-------------------------------------------------- + +reallyRebuildCase env scrut case_bndr alts cont + | not (seCaseCase env) -- Only when case-of-case is on. + -- See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + = do { case_expr <- simplAlts env scrut case_bndr alts + (mkBoringStop (contHoleType cont)) + ; rebuild (zapSubstEnv env) case_expr cont } + + | otherwise + = do { (floats, env', cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts env' scrut + (scaleIdBy holeScaling case_bndr) + (scaleAltsBy holeScaling alts) + cont' + ; return (floats, case_expr) } + where + holeScaling = contHoleScaling cont + -- Note [Scaling in case-of-case] + +{- +simplCaseBinder checks whether the scrutinee is a variable, v. If so, +try to eliminate uses of v in the RHSs in favour of case_bndr; that +way, there's a chance that v will now only be used once, and hence +inlined. + +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyser; see +"GHC.Core.Opt.OccurAnal" Note [Binder swap]. + +Note [knownCon occ info] +~~~~~~~~~~~~~~~~~~~~~~~~ +If the case binder is not dead, then neither are the pattern bound +variables: + case of x { (a,b) -> + case x of { (p,q) -> p } } +Here (a,b) both look dead, but come alive after the inner case is eliminated. +The point is that we bring into the envt a binding + let x = (a,b) +after the outer case, and that makes (a,b) alive. At least we do unless +the case binder is guaranteed dead. + +Note [DataAlt occ info] +~~~~~~~~~~~~~~~~~~~~~~~ +Our general goal is to preserve dead-ness occ-info on the field binders of a +case alternative. Why? It's generally a good idea, but one specific reason is to +support (SEQ4) of Note [seq# magic]. + +But we have to be careful: even if the field binder is not mentioned in the case +alternative and thus annotated IAmDead by OccurAnal, it might "come back to +life" in one of two ways: + + 1. If the case binder is alive, its unfolding might bring back the field + binder, as in Note [knownCon occ info]: + case blah of y { I# _ -> $wf (case y of I# v -> v) } + ==> + case blah of y { I# v -> $wf v } + 2. Even if the case binder appears to be dead, there is the scenario in + Note [Add unfolding for scrutinee], in which the fields come back to live + through the unfolding of variable scrutinee, as follows: + join j = case x of Just v -> blah v; Nothing -> ... in + case x of Just _ -> jump j; Nothing -> ... + ==> { inline j, unfold x to Just v, simplify } + join j = case x of Just v -> blah v; Nothing -> ... in + case x of Just v -> blah v; Nothing -> ... + +Thus, when we are simply reconstructing a case (the common case), and the +case binder is not dead, or the scrutinee is a variable, we zap the +occurrence info on DataAlt field binders. See `adjustFieldOccInfo`. + +Note [Improving seq] +~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: * -> * + type instance F Int = Int + +We'd like to transform + case e of (x :: F Int) { DEFAULT -> rhs } +===> + case e `cast` co of (x'::Int) + I# x# -> let x = x' `cast` sym co + in rhs + +so that 'rhs' can take advantage of the form of x'. Notice that Note +[Case of cast] (in OccurAnal) may then apply to the result. + +We'd also like to eliminate empty types (#13468). So if + + data Void + type instance F Bool = Void + +then we'd like to transform + case (x :: F Bool) of { _ -> error "urk" } +===> + case (x |> co) of (x' :: Void) of {} + +Nota Bene: we used to have a built-in rule for 'seq' that dropped +casts, so that + case (x |> co) of { _ -> blah } +dropped the cast; in order to improve the chances of trySeqRules +firing. But that works in the /opposite/ direction to Note [Improving +seq] so there's a danger of flip/flopping. Better to make trySeqRules +insensitive to the cast, which is now is. + +The need for [Improving seq] showed up in Roman's experiments. Example: + foo :: F Int -> Int -> Int + foo t n = t `seq` bar n + where + bar 0 = 0 + bar n = bar (n - case t of TI i -> i) +Here we'd like to avoid repeated evaluating t inside the loop, by +taking advantage of the `seq`. + +At one point I did transformation in LiberateCase, but it's more +robust here. (Otherwise, there's a danger that we'll simply drop the +'seq' altogether, before LiberateCase gets to see it.) + +Note [Scaling in case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When two cases commute, if done naively, the multiplicities will be wrong: + + case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many] + { (z[Many], t[Many]) -> z + } + +The multiplicities here, are correct, but if I perform a case of case: + + case u of w[1] + { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and +`y` must have multiplicities `Many` not `1`! The correct solution is to make +all the `1`-s be `Many`-s instead: + + case u of w[Many] + { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z } + } + +In general, when commuting two cases, the rule has to be: + + case (case … of x[p] {…}) of y[q] { … } + ===> case … of x[p*q] { … case … of y[q] { … } } + +This is materialised, in the simplifier, by the fact that every time we simplify +case alternatives with a continuation (the surrounded case (or more!)), we must +scale the entire case we are simplifying, by a scaling factor which can be +computed in the continuation (with function `contHoleScaling`). +-} + +simplAlts :: SimplEnv + -> OutExpr -- Scrutinee + -> InId -- Case binder + -> [InAlt] -- Non-empty + -> SimplCont + -> SimplM OutExpr -- Returns the complete simplified case expression + +simplAlts env0 scrut case_bndr alts cont' + = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr + , text "cont':" <+> ppr cont' + , text "in_scope" <+> ppr (seInScope env0) ]) + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding + env2 = modifyInScope env1 case_bndr2 + -- See Note [Case binder evaluated-ness] + fam_envs = seFamEnvs env0 + + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut + case_bndr case_bndr2 alts + + ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts + -- NB: it's possible that the returned in_alts is empty: this is handled + -- by the caller (rebuildCase) in the missingAlt function + -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts + -- See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils + + ; alts' <- forM in_alts $ + simplAlt alt_env' (Just scrut') imposs_deflt_cons + case_bndr' (scrutOkForBinderSwap scrut) cont' + + ; let alts_ty' = contResultType cont' + -- See Note [Avoiding space leaks in OutType] + ; seqType alts_ty' `seq` + mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' } + + +------------------------------------ +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _] + | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + + +------------------------------------ +simplAlt :: SimplEnv + -> Maybe OutExpr -- The scrutinee + -> [AltCon] -- These constructors can't be present when + -- matching the DEFAULT alternative + -> OutId -- The case binder `bndr` + -> BinderSwapDecision -- DoBinderSwap v co <==> scrut = Just (v |> co), + -- add unfolding `v :-> bndr |> sym co` + -> SimplCont + -> InAlt + -> SimplM OutAlt + +simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs) + = assert (null bndrs) $ + do { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt DEFAULT [] rhs') } + +simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs) + = assert (null bndrs) $ + do { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit) + ; rhs' <- simplExprC env' rhs cont' + ; return (Alt (LitAlt lit) [] rhs') } + +simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs) + = do { -- See Note [Adding evaluatedness info to pattern-bound variables] + -- and Note [DataAlt occ info] + ; let vs_with_info = adjustFieldsIdInfo scrut' case_bndr' bndr_swap' con vs + -- Adjust evaluated-ness and occ-info flags before `simplBinders` + -- because the latter extends the in-scope set, which propagates this + -- adjusted info to use sites. + ; (env', vs') <- simplBinders env vs_with_info + + -- Bind the case-binder to (con args) + ; let inst_tys' = tyConAppArgs (idType case_bndr') + con_app :: OutExpr + con_app = mkConApp2 con inst_tys' vs' + env'' = addAltUnfoldings env' case_bndr' bndr_swap' con_app + + ; rhs' <- simplExprC env'' rhs cont' + ; return (Alt (DataAlt con) vs' rhs') } + +{- Note [Adding evaluatedness info to pattern-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +addEvals records the evaluated-ness of the bound variables of +a case pattern. This is *important*. Consider + + data T = T !Int !Int + + case x of { T a b -> T (a+1) b } + +We really must record that b is already evaluated so that we don't +go and re-evaluate it when constructing the result. +See Note [Strict fields in Core] in GHC.Core. + +NB: simplLamBndrs preserves this eval info + +In addition to handling data constructor fields with !s, addEvals +also records the fact that the result of seq# is always in WHNF. +See Note [seq# magic] in GHC.Types.Id.Make. Example (#15226): + + case seq# v s of + (# s', v' #) -> E + +we want the compiler to be aware that v' is in WHNF in E. + +Open problem: we don't record that v itself is in WHNF (and we can't +do it here). The right thing is to do some kind of binder-swap; +see #15226 for discussion. +-} + +adjustFieldsIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id] +-- See Note [Adding evaluatedness info to pattern-bound variables] +-- and Note [DataAlt occ info] +adjustFieldsIdInfo scrut case_bndr bndr_swap con vs + -- Deal with seq# applications + | Just scr <- scrut + , isUnboxedTupleDataCon con + , [s,x] <- vs + -- Use stripNArgs rather than collectArgsTicks to avoid building + -- a list of arguments only to throw it away immediately. + , Just (Var f) <- stripNArgs 4 scr + , f `hasKey` seqHashKey + , let x' = setCaseBndrEvald MarkedStrict x + = map (adjustFieldOccInfo case_bndr bndr_swap) [s, x'] + + -- Deal with banged datacon fields + -- This case is quite allocation sensitive to T9233 which has a large record + -- with strict fields. Hence we try not to update vs twice! +adjustFieldsIdInfo _scrut case_bndr bndr_swap con vs + | Nothing <- dataConWrapId_maybe con + -- A common fast path; no need to allocate the_strs when they are all lazy + -- anyway! It shaves off 2% in T9675 + = map (adjustFieldOccInfo case_bndr bndr_swap) vs + | otherwise + = go vs the_strs + where + the_strs = dataConRepStrictness con + + go [] [] = [] + go (v:vs') strs | isTyVar v = v : go vs' strs + go (v:vs') (str:strs) = adjustFieldOccInfo case_bndr bndr_swap (setCaseBndrEvald str v) : go vs' strs + go _ _ = pprPanic "Simplify.adjustFieldsIdInfo" + (ppr con $$ + ppr vs $$ + ppr_with_length (map strdisp the_strs) $$ + ppr_with_length (dataConRepArgTys con) $$ + ppr_with_length (dataConRepStrictness con)) + where + ppr_with_length list + = ppr list <+> parens (text "length =" <+> ppr (length list)) + strdisp :: StrictnessMark -> SDoc + strdisp MarkedStrict = text "MarkedStrict" + strdisp NotMarkedStrict = text "NotMarkedStrict" + +adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr +-- Kill occ info if we do binder swap and the case binder is alive; +-- see Note [DataAlt occ info] +adjustFieldOccInfo case_bndr bndr_swap field_bndr + | isTyVar field_bndr + = field_bndr + + | not (isDeadBinder case_bndr) -- (1) in the Note: If the case binder is alive, + = zapIdOccInfo field_bndr -- the field binders might come back alive + + | DoBinderSwap{} <- bndr_swap -- (2) in the Note: If binder swap might take place, + = zapIdOccInfo field_bndr -- the case binder might come back alive + + | otherwise + = field_bndr -- otherwise the field binders stay dead + +addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv +addDefaultUnfoldings env case_bndr bndr_swap imposs_deflt_cons + = env2 + where + unf = mkOtherCon imposs_deflt_cons + -- Record the constructors that the case-binder *can't* be. + env1 = addBinderUnfolding env case_bndr unf + env2 | DoBinderSwap v _mco <- bndr_swap + = addBinderUnfolding env1 v unf + | otherwise = env1 + + +addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv +addAltUnfoldings env case_bndr bndr_swap con_app + = env2 + where + con_app_unf = mk_simple_unf con_app + env1 = addBinderUnfolding env case_bndr con_app_unf + + -- See Note [Add unfolding for scrutinee] + env2 | DoBinderSwap v mco <- bndr_swap + = addBinderUnfolding env1 v $ + if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf + then con_app_unf -- twice in the common case + else mk_simple_unf (mkCastMCo con_app mco) + + | otherwise = env1 + + -- Force the opts, so that the whole SimplEnv isn't retained + !opts = seUnfoldingOpts env + mk_simple_unf = mkSimpleUnfolding opts + +addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv +addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = warnPprTrace (not (eqType (idType bndr) (exprType tmpl))) + "unfolding type mismatch" + (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $ + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise + = modifyInScope env (bndr `setIdUnfolding` unf) + +zapBndrOccInfo :: Bool -> Id -> Id +-- Consider case e of b { (a,b) -> ... } +-- Then if we bind b to (a,b) in "...", and b is not dead, +-- then we must zap the deadness info on a,b +zapBndrOccInfo keep_occ_info pat_id + | keep_occ_info = pat_id + | otherwise = zapIdOccInfo pat_id + +{- Note [Case binder evaluated-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin on a (OtherCon []) unfolding to the case-binder of a Case, +even though it'll be over-ridden in every case alternative with a more +informative unfolding. Why? Because suppose a later, less clever, pass +simply replaces all occurrences of the case binder with the binder itself; +then Lint may complain about the let-can-float invariant. Example + case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... + ; K -> blah } + +The let-can-float invariant requires that y is evaluated in the call to +reallyUnsafePtrEquality#, which it is. But we still want that to be true if we +propagate binders to occurrences. + +This showed up in #13027. + +Note [Add unfolding for scrutinee] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general it's unlikely that a variable scrutinee will appear +in the case alternatives case x of { ...x unlikely to appear... } +because the binder-swap in OccurAnal has got rid of all such occurrences +See Note [Binder swap] in "GHC.Core.Opt.OccurAnal". + +BUT it is still VERY IMPORTANT to add a suitable unfolding for a +variable scrutinee, in simplAlt. Here's why + case x of y + (a,b) -> case b of c + I# v -> ...(f y)... +There is no occurrence of 'b' in the (...(f y)...). But y gets +the unfolding (a,b), and *that* mentions b. If f has a RULE + RULE f (p, I# q) = ... +we want that rule to match, so we must extend the in-scope env with a +suitable unfolding for 'y'. It's *essential* for rule matching; but +it's also good for case-elimination -- suppose that 'f' was inlined +and did multi-level case analysis, then we'd solve it in one +simplifier sweep instead of two. + +HOWEVER, given + case x of y { Just a -> r1; Nothing -> r2 } +we do not want to add the unfolding x -> y to 'x', which might seem cool, +since 'y' itself has different unfoldings in r1 and r2. Reason: if we +did that, we'd have to zap y's deadness info and that is a very useful +piece of information. + +So instead we add the unfolding x -> Just a, and x -> Nothing in the +respective RHSs. + +Since this transformation is tantamount to a binder swap, we use +GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap to do the check. + +Exactly the same issue arises in GHC.Core.Opt.SpecConstr; +see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr + + +************************************************************************ +* * +\subsection{Known constructor} +* * +************************************************************************ + +We are a bit careful with occurrence info. Here's an example + + (\x* -> case x of (a*, b) -> f a) (h v, e) + +where the * means "occurs once". This effectively becomes + case (h v, e) of (a*, b) -> f a) +and then + let a* = h v; b = e in f a +and then + f (h v) + +All this should happen in one sweep. +-} + +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont + -> SimplM (SimplFloats, OutExpr) + +knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont + = do { (floats1, env1) <- bind_args env bs dc_args + ; (floats2, env2) <- bind_case_bndr env1 + ; (floats3, expr') <- simplExprF env2 rhs cont + ; case dc_floats of + [] -> + return (floats1 `addFloats` floats2 `addFloats` floats3, expr') + _ -> + return ( emptyFloats env + -- See Note [FloatBinds from constructor wrappers] + , GHC.Core.Make.wrapFloats dc_floats $ + wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') } + where + zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId + + -- Ugh! + bind_args env' [] _ = return (emptyFloats env', env') + + bind_args env' (b:bs') (Type ty : args) + = assert (isTyVar b ) + bind_args (extendTvSubst env' b ty) bs' args + + bind_args env' (b:bs') (Coercion co : args) + = assert (isCoVar b ) + bind_args (extendCvSubst env' b co) bs' args + + bind_args env' (b:bs') (arg : args) + = assert (isId b) $ + do { let b' = zap_occ b + -- zap_occ: the binder might be "dead", because it doesn't + -- occur in the RHS; and simplAuxBind may therefore discard it. + -- Nevertheless we must keep it if the case-binder is alive, + -- because it may be used in the con_app. See Note [knownCon occ info] + ; (floats1, env2) <- simplAuxBind "knownCon" env' b' arg -- arg satisfies let-can-float invariant + ; (floats2, env3) <- bind_args env2 bs' args + ; return (floats1 `addFloats` floats2, env3) } + + bind_args _ _ _ = + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ + text "scrut:" <+> ppr scrut + + -- It's useful to bind bndr to scrut, rather than to a fresh + -- binding x = Con arg1 .. argn + -- because very often the scrut is a variable, so we avoid + -- creating, and then subsequently eliminating, a let-binding + -- BUT, if scrut is a not a variable, we must be careful + -- about duplicating the arg redexes; in that case, make + -- a new con-app from the args + bind_case_bndr env + | isDeadBinder bndr = return (emptyFloats env, env) + | exprIsTrivial scrut = return (emptyFloats env + , extendIdSubst env bndr (DoneEx scrut NotJoinPoint)) + -- See Note [Do not duplicate constructor applications] + | otherwise = do { dc_args <- mapM (simplInVar env) bs + -- dc_ty_args are already OutTypes, + -- but bs are InBndrs + ; let con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` dc_args + ; simplAuxBind "case-bndr" env bndr con_app } + +------------------- +missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont + -> SimplM (SimplFloats, OutExpr) + -- This isn't strictly an error, although it is unusual. + -- It's possible that the simplifier might "see" that + -- an inner case has no accessible alternatives before + -- it "sees" that the entire branch of an outer case is + -- inaccessible. So we simply put an error case here instead. +missingAlt env case_bndr _ cont + = warnPprTrace True "missingAlt" (ppr case_bndr) $ + -- See Note [Avoiding space leaks in OutType] + let cont_ty = contResultType cont + in seqType cont_ty `seq` + return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt") + +{- +************************************************************************ +* * +\subsection{Duplicating continuations} +* * +************************************************************************ + +Consider + let x* = case e of { True -> e1; False -> e2 } + in b +where x* is a strict binding. Then mkDupableCont will be given +the continuation + case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop +and will split it into + dupable: case [] of { True -> $j1; False -> $j2 } ; stop + join floats: $j1 = e1, $j2 = e2 + non_dupable: let x* = [] in b; stop + +Putting this back together would give + let x* = let { $j1 = e1; $j2 = e2 } in + case e of { True -> $j1; False -> $j2 } + in b +(Of course we only do this if 'e' wants to duplicate that continuation.) +Note how important it is that the new join points wrap around the +inner expression, and not around the whole thing. + +In contrast, any let-bindings introduced by mkDupableCont can wrap +around the entire thing. + +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away. See #4930. +-} + +-------------------- +mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont + -> SimplM ( SimplFloats -- Join points (if any) + , SimplEnv -- Use this for the alts + , SimplCont) +mkDupableCaseCont env alts cont + | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont + ; let env' = bumpCaseDepth $ + env `setInScopeFromF` floats + ; return (floats, env', cont) } + | otherwise = return (emptyFloats env, env, cont) + +altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative +altsWouldDup [] = False -- See Note [Bottom alternatives] +altsWouldDup [_] = False +altsWouldDup (alt:alts) + | is_bot_alt alt = altsWouldDup alts + | otherwise = not (all is_bot_alt alts) + -- otherwise case: first alt is non-bot, so all the rest must be bot + where + is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs + +------------------------- +mkDupableCont :: SimplEnv + -> SimplCont + -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with + -- extra let/join-floats and in-scope variables + , SimplCont) -- dup_cont: duplicable continuation +mkDupableCont env cont + = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont + +mkDupableContWithDmds + :: SimplEnvIS -> [Demand] -- Demands on arguments; always infinite + -> SimplCont -> SimplM ( SimplFloats, SimplCont) + +mkDupableContWithDmds env _ cont + -- Check the invariant + | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False + = pprPanic "mkDupableContWithDmds" empty + + | contIsDupable cont + = return (emptyFloats env, cont) + +mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn + +mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, CastIt { sc_co = optOutCoercion env co opt + , sc_opt = True, sc_cont = cont' }) } + -- optOutCoercion: see Note [Avoid re-simplifying coercions] + +-- Duplicating ticks for now, not sure if this is good or not +mkDupableContWithDmds env dmds (TickIt t cont) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, TickIt t cont') } + +mkDupableContWithDmds env _ + (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what + , sc_env = se, sc_cont = cont}) +-- See Note [Duplicating StrictBind] +-- K[ let x = <> in b ] --> join j x = K[ b ] +-- j <> + = do { let sb_env = se `setInScopeFromE` env + ; (sb_env1, bndr') <- simplBinder sb_env bndr + ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont + -- No need to use mkDupableCont before simplNonRecBody; we + -- use cont once here, and then share the result if necessary + + ; let join_body = wrapFloats floats1 join_inner + res_ty = contResultType cont + + ; mkDupableStrictBind env bndr' join_body res_ty } + +mkDupableContWithDmds env _ + (StrictArg { sc_fun = fun, sc_cont = cont + , sc_fun_ty = fun_ty }) + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + | isNothing (isDataConId_maybe (ai_fun fun)) + -- isDataConId: see point (DJ4) of Note [Duplicating join points] + , thumbsUpPlanA cont + = -- Use Plan A of Note [Duplicating StrictArg] +-- pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $ + do { let _ :| dmds = expectNonEmpty $ ai_dmds fun + ; (floats1, cont') <- mkDupableContWithDmds env dmds cont + -- Use the demands from the function to add the right + -- demand info on any bindings we make for further args + ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env) + (ai_args fun) + ; return ( foldl' addLetFloats floats1 floats_s + , StrictArg { sc_fun = fun { ai_args = args' } + , sc_cont = cont' + , sc_fun_ty = fun_ty + , sc_dup = OkToDup} ) } + + | otherwise + = -- Use Plan B of Note [Duplicating StrictArg] + -- K[ f a b <> ] --> join j x = K[ f a b x ] + -- j <> + do { let rhs_ty = contResultType cont + (m,arg_ty,_) = splitFunTy fun_ty + ; arg_bndr <- newId (fsLit "arg") m arg_ty + ; let env' = env `addNewInScopeIds` [arg_bndr] + ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont + ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } + where + thumbsUpPlanA (StrictArg {}) = False + thumbsUpPlanA (StrictBind {}) = True + thumbsUpPlanA (Stop {}) = True + thumbsUpPlanA (Select {}) = True + thumbsUpPlanA (CastIt { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k + thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k + +mkDupableContWithDmds env dmds + (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) + = do { (floats, cont') <- mkDupableContWithDmds env dmds cont + ; return (floats, ApplyToTy { sc_cont = cont' + , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env dmds + (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se + , sc_cont = cont, sc_hole_ty = hole_ty }) + = -- e.g. [...hole...] (...arg...) + -- ==> + -- let a = ...arg... + -- in [...hole...] a + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { let dmd:|cont_dmds = expectNonEmpty dmds + ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont + ; let env' = env `setInScopeFromF` floats1 + ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg + ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg' + ; let all_floats = floats1 `addLetFloats` let_floats2 + ; return ( all_floats + , ApplyToVal { sc_arg = arg'' + , sc_env = se' `setInScopeFromF` all_floats + -- Ensure that sc_env includes the free vars of + -- arg'' in its in-scope set, even if makeTrivial + -- has turned arg'' into a fresh variable + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup, sc_cont = cont' + , sc_hole_ty = hole_ty }) } + +mkDupableContWithDmds env _ + (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + = -- e.g. (case [...hole...] of { pi -> ei }) + -- ===> + -- let ji = \xij -> ei + -- in case [...hole...] of { pi -> ji xij } + -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable + do { tick (CaseOfCase case_bndr) + ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont + -- NB: We call mkDupableCaseCont here to make cont duplicable + -- (if necessary, depending on the number of alts) + -- And this is important: see Note [Fusing case continuations] + + ; let cont_scaling = contHoleScaling cont + -- See Note [Scaling in case-of-case] + ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) + ; alts' <- forM (scaleAltsBy cont_scaling alts) $ + simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont + -- Safe to say that there are no handled-cons for the DEFAULT case + -- NB: simplBinder does not zap deadness occ-info, so + -- a dead case_bndr' will still advertise its deadness + -- This is really important because in + -- case e of b { (# p,q #) -> ... } + -- b is always dead, and indeed we are not allowed to bind b to (# p,q #), + -- which might happen if e was an explicit unboxed pair and b wasn't marked dead. + -- In the new alts we build, we have the new case binder, so it must retain + -- its deadness. + -- NB: we don't use alt_env further; it has the substEnv for + -- the alternatives, and we don't want that + + ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt env case_bndr') + emptyJoinFloats alts' + + ; let all_floats = floats `addJoinFloats` join_floats + -- Note [Duplicated env] + ; return (all_floats + , Select { sc_dup = OkToDup + , sc_bndr = case_bndr' + , sc_alts = alts'' + , sc_env = zapSubstEnv se `setInScopeFromF` all_floats + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_cont = mkBoringStop (contResultType cont) } ) } + +mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType + -> SimplM (SimplFloats, SimplCont) +mkDupableStrictBind env arg_bndr join_rhs res_ty + | uncondInlineJoin [arg_bndr] join_rhs + -- See point (DJ2) of Note [Duplicating join points] + = return (emptyFloats env + , StrictBind { sc_bndr = arg_bndr + , sc_body = join_rhs + , sc_env = zapSubstEnv env + , sc_from = FromLet + -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils + , sc_dup = OkToDup + , sc_cont = mkBoringStop res_ty } ) + | otherwise + = do { join_bndr <- newJoinId [arg_bndr] res_ty + ; let arg_info = ArgInfo { ai_fun = join_bndr + , ai_rules = [], ai_args = [] + , ai_encl = False, ai_dmds = repeat topDmd + , ai_discs = repeat 0 } + ; return ( addJoinFloats (emptyFloats env) $ + unitJoinFloat $ + NonRec join_bndr $ + Lam (setOneShotLambda arg_bndr) join_rhs + , StrictArg { sc_dup = OkToDup + , sc_fun = arg_info + , sc_fun_ty = idType join_bndr + , sc_cont = mkBoringStop res_ty + } ) } + +mkDupableAlt :: SimplEnv -> OutId + -> JoinFloats -> OutAlt + -> SimplM (JoinFloats, OutAlt) +mkDupableAlt _env case_bndr jfloats (Alt con alt_bndrs alt_rhs_in) + | uncondInlineJoin alt_bndrs alt_rhs_in + -- See point (DJ2) of Note [Duplicating join points] + = return (jfloats, Alt con alt_bndrs alt_rhs_in) + + | otherwise + = do { let rhs_ty' = exprType alt_rhs_in + + bangs + | DataAlt c <- con + = dataConRepStrictness c + | otherwise = [] + + abstracted_binders = abstract_binders alt_bndrs bangs + + abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)] + abstract_binders [] [] + -- Abstract over the case binder too if it's used. + | isDeadBinder case_bndr = [] + | otherwise = [(case_bndr,MarkedStrict)] + abstract_binders (alt_bndr:alt_bndrs) marks + -- Abstract over all type variables just in case + | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks + abstract_binders (alt_bndr:alt_bndrs) (mark:marks) + -- The deadness info on the new Ids is preserved by simplBinders + -- We don't abstract over dead ids here. + | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks + | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks + abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in) + + filtered_binders = map fst abstracted_binders + -- We want to make any binder with an evaldUnfolding strict in the rhs. + -- See Note [Call-by-value for worker args] (which also applies to join points) + rhs_with_seqs = mkStrictFieldSeqs abstracted_binders alt_rhs_in + + final_args = varsToCoreExprs filtered_binders + -- Note [Join point abstraction] + + -- We make the lambdas into one-shot-lambdas. The + -- join point is sure to be applied at most once, and doing so + -- prevents the body of the join point being floated out by + -- the full laziness pass + final_bndrs = map one_shot filtered_binders + one_shot v | isId v = setOneShotLambda v + | otherwise = v + + -- No lambda binder has an unfolding, but (currently) case binders can, + -- so we must zap them here. + join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs + + ; join_bndr <- newJoinId filtered_binders rhs_ty' + ; let -- join_bndr_w_unf = join_bndr `setIdUnfolding` + -- mkUnfolding uf_opts VanillaSrc False False join_rhs Nothing + -- See Note [Do not add unfoldings to join points at birth] + join_call = mkApps (Var join_bndr) final_args + alt' = Alt con alt_bndrs join_call + + ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs) + , alt') } + -- See Note [Duplicated env] + +{- +Note [Do not add unfoldings to join points at birth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#15360) + + case (case (case (case ...))) of + Left x -> e1 + Right y -> e2 + +We will make a join point for e1, e2, thus + $j1a x = e1 + $j1b y = e2 + +Now those join point calls count as "duplicable" , so we feel free to duplicate +them into the loop nest. And each of those calls are then subject to +callSiteInline, which might inline them, if e1, e2 are reasonably small. Now, +if this applies recursive to the next `case` inwards, and so on, the net +effect is that we can get an exponential number of calls to $j1a and $j1b, and +an exponential number of inlinings (since each is done independently). + +This hit #15360 (not a complicated program!) badly. Our simple solution is this: +when a join point is born, we don't give it an unfolding, so it will not be inlined +at its call sites, at least not in that pass. So we end up with + $j1a x = e1 + $j1b y = e2 + $j2a x = ...$j1a ... $j1b... + $j2b x = ...$j1a ... $j1b... + ... and so on... + +In the next iteration of the Simplifier we are into Note [Avoid inlining into +deeply nested cases] in Simplify.Inline, which is still a challenge. But at +least we have a chance. If we add inlinings at birth we never get that chance. + +Wrinkle + +(JU1) It turns out that the same problem shows up in a different guise, via + Note [Post-inline for single-use things] in Simplify.Utils. I think + we have something like + case K (join $j x = in jblah) of K y{OneOcc} -> blah + where $j is a freshly-born join point. After case-of-known-constructor + wo we end up substituting (join $j x = in jblah) for `y` in `blah`; + and thus we re-simplify that join binding. In test T15630 this results in + massive duplication. + + So in `simplLetUnfolding` we spot this case a bit hackily; a freshly-born + join point will have OccInfo of ManyOccs, unlike an existing join point which + will have OneOcc. So in simplLetUnfolding we kill the unfolding of a freshly + born join point. + +I can't quite articulate precisely why this is so important. But it makes a +MASSIVE difference in T15630 (a fantastic test case); and at worst it'll merely +delay inlining join points by one simplifier iteration. + +In effect (JU1) just extends the original Note [Do not add unfoldings to join +points at birth] to occasions where we re-visit the same join-point in the same +Simplifier iteration. + +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in GHC.Core.Opt.WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StrictBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See #4957 a fuller example. + +Note [Duplicating join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19996 we discovered that we want to be really careful about +inlining join points. Consider + case (join $j x = K f x ) + (in case v of ) + ( p1 -> $j x1 ) of + ( p2 -> $j x2 ) + ( p3 -> $j x3 ) + K g y -> blah[g,y] + +Here the join-point RHS is very small, just a constructor +application (K f x). So we might inline it to get + case (case v of ) + ( p1 -> K f x1 ) of + ( p2 -> K f x2 ) + ( p3 -> K f x3 ) + K g y -> blah[g,y] + +But now we have to make `blah` into a join point, /abstracted/ +over `g` and `y`. We get + join $j2 g y = blah + in case v of + p1 -> $j2 f x1 + p2 -> $j2 f x2 + p3 -> $j2 f x3 +So now we can't see that `g` is always `f` in `blah`. + +In contrast, if we /don't/ inline $j we +don't need a new join point for `blah` and we'll get + join $j' x = let g=f, y=x in blah[g,y] + in case v of + p1 -> $j' x1 + p2 -> $j' x2 + p3 -> $j' x3 + +This can make a /massive/ difference, because `blah` can see +what `f` is, instead of lambda-abstracting over it. + +If instead the RHS of the join point is a simple application that has no free +variables, as in + + case (join $j x f = K f x ) + (in case v of ) + ( p1 -> $j x1 f1 ) of + ( p2 -> $j x2 f2 ) + ( p3 -> $j x3 f3 ) + K g y -> blah[g,y] + +then no information can be gained by preserving the join point (c.f. `f` being +free in the join point above and being useful to `blah`). In this case, it's +more beneficial to inline the join point (see (DJ3)(c)) to allow further +optimisations to fire. An example where failing to do this went wrong is #25723. + +Beyond this, not-inlining join points reduces duplication. In the above +example, if `blah` was small enough we'd inline it, but that duplicates code, +for no gain. Best just to keep not-inline the join point in the first place. +So not-inlining join points is our default: but see Note [Inlining join points] +in GHC.Core.Opt.Simplify.Inline for when we /do/ inline them. + +To achieve this parsimonious inlining of join points, we need to do two things: +(a) create a join point even if the RHS is small; and (b) don't do +unconditional-inlining for join points. + +(DJ1) Do not postInlineUnconditionally a join point, ever. Doing + postInlineUnconditionally is primarily to push allocation into cold + branches; but a join point doesn't allocate, so that's a non-motivation. + +(DJ2) In mkDupableAlt and mkDupableStrictBind, generate an alterative for /all/ + alternatives, /except/ for ones that will definitely inline unconditionally + straight away. (In that case it's silly to make a join point in the first + place; it just takes an extra Simplifier iteration to undo.) This choice is + made by GHC.Core.Unfold.uncondInlineJoin. + + This plan generates a lot of join points, but makes them much more + case-of-case friendly. + +(DJ3) When should `uncondInlineJoin` return True? + (a) (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see + the defn of exprIsTrivial. Also nullary constructors. + + (b) The RHS is a call ($j x y z), where the arguments are all trivial and $j + is a join point: there is no point in creating an indirection. + + (c) The RHS is a data constructor application (K x y z) where + + - all the args x,y,z are trivial + - the free LocalIds of `f x y z` are a subset of the join point binders + + Examples that return True + $j x y = K y (x |> co) + $j x y = x (y @Int) + Examples that return False + $j x = K y x -- y is free + $j y = f y -- f is free + + Not duplicating these join points has no benefits and blocks other important + optimisations from firing (see #25723) + +(DJ4) By the same token we want to use Plan B in Note [Duplicating StrictArg] when + the RHS of the new join point is a data constructor application. See the + call to isDataConId in the StrictArg case of mkDupableContWithDmds. + + That same Note [Duplicating StrictArg] explains why we sometimes want Plan A + when the RHS of the new join point would be a non-data-constructor + application + +(DJ5) You might worry that $j = K x y might look so small that it is inlined + by the call site inliner, defeating (DJ3). But in fact + + - The UnfoldingGuidance for a join point is only UnfWhen (unconditional) + if `uncondInlineJoin` is true; see GHC.Core.Unfold.uncondInline + + - `GHC.Core.Opt.Simplify.Inline.tryUnfolding` has a special case for join + points, described Note [Inlining join points] in that module. + +Historical Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this entire Note is now irrelevant. In Jun 21 we stopped +adding unfoldings to lambda binders (#17530). It was always a +hack and bit us in multiple small and not-so-small ways + +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutinises the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +(a stable unfolding) that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + +NB: take great care when doing strictness analysis; + see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal. + +Also note that we can still end up passing stuff that isn't used. Before +strictness analysis we have + let $j x y c{=(x,y)} = (h c, ...) + in ... +After strictness analysis we see that h is strict, we end up with + let $j x y c{=(x,y)} = ($wh x y, ...) +and c is unused. + +Note [Duplicated env] +~~~~~~~~~~~~~~~~~~~~~ +Some of the alternatives are simplified, but have not been turned into a join point +So they *must* have a zapped subst-env. So we can't use completeNonRecX to +bind the join point, because it might to do PostInlineUnconditionally, and +we'd lose that when zapping the subst-env. We could have a per-alt subst-env, +but zapping it (as we do in mkDupableCont, the Select case) is safe, and +at worst delays the join-point inlining. + +Note [Funky mkLamTypes] +~~~~~~~~~~~~~~~~~~~~~~ +Notice the funky mkLamTypes. If the constructor has existentials +it's possible that the join point will be abstracted over +type variables as well as term variables. + Example: Suppose we have + data T = forall t. C [t] + Then faced with + case (case e of ...) of + C t xs::[t] -> rhs + We get the join point + let j :: forall t. [t] -> ... + j = /\t \xs::[t] -> rhs + in + case (case e of ...) of + C t xs::[t] -> j t xs + +Note [Duplicating StrictArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with making a StrictArg continuation duplicable has turned out +to be one of the trickiest corners of the simplifier, giving rise +to several cases in which the simplier expanded the program's size +*exponentially*. They include + #13253 exponential inlining + #10421 ditto + #18140 strict constructors + #18282 another nested-function call case + +Suppose we have a call + f e1 (case x of { True -> r1; False -> r2 }) e3 +and f is strict in its second argument. Then we end up in +mkDupableCont with a StrictArg continuation for (f e1 <> e3). +There are two ways to make it duplicable. + +* Plan A: move the entire call inwards, being careful not + to duplicate e1 or e3, thus: + let a1 = e1 + a3 = e3 + in case x of { True -> f a1 r1 a3 + ; False -> f a1 r2 a3 } + +* Plan B: make a join point: + join $j x = f e1 x e3 + in case x of { True -> jump $j r1 + ; False -> jump $j r2 } + + Notice that Plan B is very like the way we handle strict bindings; + see Note [Duplicating StrictBind]. And Plan B is exactly what we'd + get if we turned use a case expression to evaluate the strict arg: + + case (case x of { True -> r1; False -> r2 }) of + r -> f e1 r e3 + + So, looking at Note [Duplicating join points], we also want Plan B + when `f` is a data constructor. + +Plan A is often good: + +* The calls to `f` may well be able to inline, since they are now applied + to more informative arguments, `r1`, `r2`. For example: + && E (case x of { T -> F; F -> T }) + Pushing the call inward (being careful not to duplicate E) we get + let a = E + in case x of { T -> && a F; F -> && a T } + and now the (&& a F) etc can optimise. + +* Moreover there might be a RULE for the function that can fire when it "sees" + the particular case alternative. + +* More specialisation can happen. Here's an example from #3116 + go (n+1) (case l of + 1 -> bs' + _ -> Chunk p fpc (o+1) (l-1) bs') + + If we pushed the entire call for 'go' inside the case, we get + call-pattern specialisation for 'go', which is *crucial* for + this particular program. + +But Plan A can have terrible, terrible behaviour. Here is a classic +case: + f (f (f (f (f True)))) + +Suppose f is strict, and has a body that is small enough to inline. +The innermost call inlines (seeing the True) to give + f (f (f (f (case v of { True -> e1; False -> e2 })))) + +Now, suppose we naively push the entire continuation into both +case branches (it doesn't look large, just f.f.f.f). We get + case v of + True -> f (f (f (f e1))) + False -> f (f (f (f e2))) + +And now the process repeats, so we end up with an exponentially large +number of copies of f. No good! + +CONCLUSION: we want Plan A in general, but do Plan B is there a +danger of this nested call behaviour. The function that decides +this is called thumbsUpPlanA. + +Note [Keeping demand info in StrictArg Plan A] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Following on from Note [Duplicating StrictArg], another common code +pattern that can go bad is this: + f (case x1 of { T -> F; F -> T }) + (case x2 of { T -> F; F -> T }) + ...etc... +when f is strict in all its arguments. (It might, for example, be a +strict data constructor whose wrapper has not yet been inlined.) + +We use Plan A (because there is no nesting) giving + let a2 = case x2 of ... + a3 = case x3 of ... + in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... } + +Now we must be careful! a2 and a3 are small, and the OneOcc code in +postInlineUnconditionally may inline them both at both sites; see Note +Note [Inline small things to avoid creating a thunk] in +Simplify.Utils. But if we do inline them, the entire process will +repeat -- back to exponential behaviour. + +So we are careful to keep the demand-info on a2 and a3. Then they'll +be /strict/ let-bindings, which will be dealt with by StrictBind. +That's why contIsDupableWithDmds is careful to propagage demand +info to the auxiliary bindings it creates. See the Demand argument +to makeTrivial. + +Note [Duplicating StrictBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We make a StrictBind duplicable in a very similar way to +that for case expressions. After all, + let x* = e in b is similar to case e of x -> b + +So we potentially make a join-point for the body, thus: + let x = <> in b ==> join j x = b + in j <> + +Just like StrictArg in fact -- and indeed they share code. + +Note [Join point abstraction] Historical note +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This note is now historical, describing how (in the past) we used +to add a void argument to nullary join points. But now that "join +point" is not a fuzzy concept but a formal syntactic construct (as +distinguished by the JoinId constructor of IdDetails), each of these +concerns is handled separately, with no need for a vestigial extra +argument. + +Join points always have at least one value argument, +for several reasons + +* If we try to lift a primitive-typed something out + for let-binding-purposes, we will *caseify* it (!), + with potentially-disastrous strictness results. So + instead we turn it into a function: \v -> e + where v::Void#. The value passed to this function is void, + which generates (almost) no code. + +* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now + we make the join point into a function whenever used_bndrs' + is empty. This makes the join-point more CPR friendly. + Consider: let j = if .. then I# 3 else I# 4 + in case .. of { A -> j; B -> j; C -> ... } + + Now CPR doesn't w/w j because it's a thunk, so + that means that the enclosing function can't w/w either, + which is a lose. Here's the example that happened in practice: + kgmod :: Int -> Int -> Int + kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0 + then 78 + else 5 + +* Let-no-escape. We want a join point to turn into a let-no-escape + so that it is implemented as a jump, and one of the conditions + for LNE is that it's not updatable. In CoreToStg, see + Note [What is a non-escaping let] + +* Floating. Since a join point will be entered once, no sharing is + gained by floating out, but something might be lost by doing + so because it might be allocated. + +I have seen a case alternative like this: + True -> \v -> ... +It's a bit silly to add the realWorld dummy arg in this case, making + $j = \s v -> ... + True -> $j s +(the \v alone is enough to make CPR happy) but I think it's rare + +There's a slight infelicity here: we pass the overall +case_bndr to all the join points if it's used in *any* RHS, +because we don't know its usage in each RHS separately + + + +************************************************************************ +* * + Unfoldings +* * +************************************************************************ +-} + +simplLetUnfolding :: SimplEnv + -> BindContext + -> InId + -> OutExpr -> OutType -> ArityType + -> Unfolding -> SimplM Unfolding +simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf + | isStableUnfolding unf + = simplStableUnfolding env bind_cxt id rhs_ty arity unf + + | freshly_born_join_point id + = -- This is a tricky one! + -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth] + return noUnfolding + + | isExitJoinId id + = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify + return noUnfolding + + | otherwise + = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs + + where + is_join_point = isJoinId id + freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id) + -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627 + +------------------- +mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource + -> InId -> Bool -- True <=> this is a join point + -> OutExpr -> SimplM Unfolding +mkLetUnfolding env top_lvl src id is_join new_rhs + = return (mkUnfolding uf_opts src is_top_lvl is_bottoming is_join new_rhs Nothing) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In GHC.Iface.Tidy we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. + where + -- !opts: otherwise, we end up retaining all the SimpleEnv + !uf_opts = seUnfoldingOpts env + + -- Might as well force this, profiles indicate up to + -- 0.5MB of thunks just from this site. + !is_top_lvl = isTopLevel top_lvl + -- See Note [Force bottoming field] + !is_bottoming = isDeadEndId id + +------------------- +simplStableUnfolding :: SimplEnv -> BindContext + -> InId + -> OutType + -> ArityType -- Used to eta expand, but only for non-join-points + -> Unfolding + ->SimplM Unfolding +-- Note [Setting the new unfolding] +simplStableUnfolding env bind_cxt id rhs_ty id_arity unf + = case unf of + NoUnfolding -> return unf + BootUnfolding -> return unf + OtherCon {} -> return unf + + DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args } + -> do { (env', bndrs') <- simplBinders unf_env bndrs + ; args' <- mapM (simplExpr env') args + ; return (mkDFunUnfolding bndrs' con args') } + + CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } + | isStableSource src + -> do { expr' <- case bind_cxt of + BC_Join _ cont -> -- Binder is a join point + -- See Note [Rules and unfolding for join points] + simplJoinRhs unf_env id expr cont + BC_Let _ is_rec -> -- Binder is not a join point + do { let cont = mkRhsStop rhs_ty is_rec topDmd + -- mkRhsStop: switch off eta-expansion at the top level + ; expr' <- simplExprC unf_env expr cont + ; return (eta_expand expr') } + ; case guide of + UnfWhen { ug_boring_ok = boring_ok } + -- Happens for INLINE things + -- Really important to force new_boring_ok since otherwise + -- `ug_boring_ok` is a thunk chain of + -- inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ... + -- See #20134 + -> let !new_boring_ok = boring_ok || inlineBoringOk expr' + guide' = guide { ug_boring_ok = new_boring_ok } + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in GHC.Tc.TyCl.Instance. + -- A test case is #4138 + -- But retain a previous boring_ok of True; e.g. see + -- the way it is set in calcUnfoldingGuidanceWithArity + in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide') + -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold + + _other -- Happens for INLINABLE things + -> mkLetUnfolding env top_lvl src id False expr' } + -- If the guidance is UnfIfGoodArgs, this is an INLINABLE + -- unfolding, and we need to make sure the guidance is kept up + -- to date with respect to any changes in the unfolding. + + | otherwise -> return noUnfolding -- Discard unstable unfoldings + where + -- Forcing this can save about 0.5MB of max residency and the result + -- is small and easy to compute so might as well force it. + top_lvl = bindContextLevel bind_cxt + !is_top_lvl = isTopLevel top_lvl + act = idInlineActivation id + unf_env = updMode (updModeForStableUnfoldings act) env + -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils + + -- See Note [Eta-expand stable unfoldings] + -- Use the arity from the main Id (in id_arity), rather than computing it from rhs + -- Not used for join points + eta_expand expr | seEtaExpand env + , exprArity expr < arityTypeArity id_arity + , wantEtaExpansion expr + = etaExpandAT (getInScope env) id_arity expr + | otherwise + = expr + +{- Note [Eta-expand stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For INLINE/INLINABLE things (which get stable unfoldings) there's a danger +of getting + f :: Int -> Int -> Int -> Blah + [ Arity = 3 -- Good arity + , Unf=Stable (\xy. blah) -- Less good arity, only 2 + f = \pqr. e + +This can happen because f's RHS is optimised more vigorously than +its stable unfolding. Now suppose we have a call + g = f x +Because f has arity=3, g will have arity=2. But if we inline f (using +its stable unfolding) g's arity will reduce to 1, because +hasn't been optimised yet. This happened in the 'parsec' library, +for Text.Pasec.Char.string. + +Generally, if we know that 'f' has arity N, it seems sensible to +eta-expand the stable unfolding to arity N too. Simple and consistent. + +Wrinkles + +* See Historical-note [Eta-expansion in stable unfoldings] in + GHC.Core.Opt.Simplify.Utils + +* Don't eta-expand a trivial expr, else each pass will eta-reduce it, + and then eta-expand again. See Note [Which RHSs do we eta-expand?] + in GHC.Core.Opt.Simplify.Utils. + +* Don't eta-expand join points; see Note [Do not eta-expand join points] + in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point + case (bind_cxt = BC_Join {}) doesn't use eta_expand. + +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's a stable unfolding on a loop breaker (which happens for +INLINABLE), we hang on to the inlining. It's pretty dodgy, but the +user did say 'INLINE'. May need to revisit this choice. + +************************************************************************ +* * + Rules +* * +************************************************************************ + +Note [Rules in a letrec] +~~~~~~~~~~~~~~~~~~~~~~~~ +After creating fresh binders for the binders of a letrec, we +substitute the RULES and add them back onto the binders; this is done +*before* processing any of the RHSs. This is important. Manuel found +cases where he really, really wanted a RULE for a recursive function +to apply in that function's own right-hand side. + +See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal" +-} + +addBndrRules :: SimplEnv -> InBndr -> OutBndr + -> BindContext + -> SimplM (SimplEnv, OutBndr) +-- Rules are added back into the bin +addBndrRules env in_id out_id bind_cxt + | null old_rules + = return (env, out_id) + | otherwise + = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt + ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules + ; return (modifyInScope env final_id, final_id) } + where + old_rules = ruleInfoRules (idSpecialisation in_id) + +simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule] +-- Simplify local rules for imported Ids +simplImpRules env rules + = simplRules env Nothing rules (BC_Let TopLevel NonRecursive) + +simplRules :: SimplEnv -> Maybe OutId -> [CoreRule] + -> BindContext -> SimplM [CoreRule] +simplRules env mb_new_id rules bind_cxt + = mapM simpl_rule rules + where + simpl_rule rule@(BuiltinRule {}) + = return rule + + simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_act = act }) + = do { (env', bndrs') <- simplBinders env bndrs + ; let rhs_ty = substTy env' (exprType rhs) + rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] + BC_Let {} -> mkBoringStop rhs_ty + BC_Join _ cont -> assertPpr join_ok bad_join_msg cont + lhs_env = updMode updModeForRules env' + rhs_env = updMode (updModeForStableUnfoldings act) env' + -- See Note [Simplifying the RHS of a RULE] + -- Force this to avoid retaining reference to old Id + !fn_name' = case mb_new_id of + Just id -> idName id + Nothing -> fn_name + + -- join_ok is an assertion check that the join-arity of the + -- binder matches that of the rule, so that pushing the + -- continuation into the RHS makes sense + join_ok = case mb_new_id of + Just id | JoinPoint join_arity <- idJoinPointHood id + -> length args == join_arity + _ -> False + bad_join_msg = vcat [ ppr mb_new_id, ppr rule + , ppr (fmap idJoinPointHood mb_new_id) ] ; args' <- mapM (simplExpr lhs_env) args ; rhs' <- simplExprC rhs_env rhs rhs_cont diff --git a/GHC/Core/Opt/Simplify/Monad.hs b/GHC/Core/Opt/Simplify/Monad.hs --- a/GHC/Core/Opt/Simplify/Monad.hs +++ b/GHC/Core/Opt/Simplify/Monad.hs @@ -219,7 +219,6 @@ join_arity = length bndrs details = JoinId join_arity Nothing id_info = vanillaIdInfo `setArityInfo` arity --- `setOccInfo` strongLoopBreaker ; return (mkLocalVar details name ManyTy join_id_ty id_info) } diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs --- a/GHC/Core/Opt/Simplify/Utils.hs +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -13,7 +13,7 @@ -- Inlining, preInlineUnconditionally, postInlineUnconditionally, - activeUnfolding, activeRule, + activeRule, getUnfoldingInRuleMatch, updModeForStableUnfoldings, updModeForRules, @@ -25,15 +25,15 @@ isSimplified, contIsStop, contIsDupable, contResultType, contHoleType, contHoleScaling, contIsTrivial, contArgs, contIsRhs, - countArgs, + countArgs, contOutArgs, dropContArgs, mkBoringStop, mkRhsStop, mkLazyArgStop, interestingCallContext, -- ArgInfo - ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo, - addValArgTo, addCastTo, addTyArgTo, - argInfoExpr, argInfoAppArgs, - pushSimplifiedArgs, pushSimplifiedRevArgs, + ArgInfo(..), ArgSpec(..), mkArgInfo, + addValArgTo, addTyArgTo, + argInfoExpr, argSpecArg, + pushSimplifiedArgs, isStrictArgInfo, lazyArgContext, abstractFloats, @@ -48,14 +48,13 @@ import GHC.Core import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Simplify.Inline +import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline ) import GHC.Core.Opt.Stats ( Tick(..) ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) import GHC.Core.FVs import GHC.Core.Utils -import GHC.Core.Rules( RuleEnv, getRules ) import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make @@ -81,10 +80,11 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad ( when ) import Data.List ( sortBy ) +import GHC.Types.Name.Env +import Data.Graph {- ********************************************************************* * * @@ -162,9 +162,12 @@ | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] - OutCoercion -- The coercion simplified + { sc_co :: OutCoercion -- The coercion simplified -- Invariant: never an identity coercion - SimplCont + , sc_opt :: Bool -- True <=> sc_co has had optCoercion applied to it + -- See Note [Avoid re-simplifying coercions] + -- in GHC.Core.Opt.Simplify.Iteration + , sc_cont :: SimplCont } | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] @@ -215,7 +218,7 @@ type StaticEnv = SimplEnv -- Just the static part is relevant -data FromWhat = FromLet | FromBeta OutType +data FromWhat = FromLet | FromBeta Levity -- See Note [DupFlag invariants] data DupFlag = NoDup -- Unsimplified, might be big @@ -273,21 +276,23 @@ = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty where pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd] - ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont - ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont + ppr (CastIt { sc_co = co, sc_cont = cont }) + = (text "CastIt" <+> pprOptCo co) $$ ppr cont + ppr (TickIt t cont) + = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) - = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty) + = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty) 2 (pprParendExpr arg)) $$ ppr cont ppr (StrictBind { sc_bndr = b, sc_cont = cont }) = (text "StrictBind" <+> ppr b) $$ ppr cont ppr (StrictArg { sc_fun = ai, sc_cont = cont }) = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont - ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) + ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_cont = cont }) = (text "Select" <+> ppr dup <+> ppr bndr) $$ - whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + whenPprDebug (nest 2 $ ppr alts) $$ ppr cont {- Note [The hole type in ApplyToTy] @@ -318,11 +323,10 @@ = ArgInfo { ai_fun :: OutId, -- The function ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) - - ai_rewrite :: RewriteCall, -- What transformation to try next for this call - -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration + -- NB: all these argumennts are already simplified - ai_encl :: Bool, -- Flag saying whether this function + ai_rules :: [CoreRule], -- Rules for this function + ai_encl :: Bool, -- Flag saying whether this function -- or an enclosing one has rules (recursively) -- True => be keener to inline in all args @@ -336,12 +340,6 @@ -- Always infinite } -data RewriteCall -- What rewriting to try next for this call - -- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration - = TryRules FullArgCount [CoreRule] - | TryInlining - | TryNothing - data ArgSpec = ValArg { as_dmd :: Demand -- Demand placed on this argument , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal @@ -350,61 +348,46 @@ | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah) - | CastBy OutCoercion -- Cast by this; c.f. CastIt - instance Outputable ArgInfo where - ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds }) + ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules }) = text "ArgInfo" <+> braces (sep [ text "fun =" <+> ppr fun , text "dmds(first 10) =" <+> ppr (take 10 dmds) - , text "args =" <+> ppr args ]) + , text "args =" <+> ppr args + , text "rewrite =" <+> ppr rules ]) instance Outputable ArgSpec where ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty - ppr (CastBy c) = text "CastBy" <+> ppr c addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo addValArgTo ai arg hole_ty - | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rewrite = rew } <- ai + | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai -- Pop the top demand and and discounts off , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } = ai { ai_args = arg_spec : ai_args ai , ai_dmds = dmds - , ai_discs = discs - , ai_rewrite = decArgCount rew } + , ai_discs = discs } | otherwise = pprPanic "addValArgTo" (ppr ai $$ ppr arg) -- There should always be enough demands and discounts addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo -addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai - , ai_rewrite = decArgCount (ai_rewrite ai) } +addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai } where arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } -addCastTo :: ArgInfo -> OutCoercion -> ArgInfo -addCastTo ai co = ai { ai_args = CastBy co : ai_args ai } - isStrictArgInfo :: ArgInfo -> Bool -- True if the function is strict in the next argument isStrictArgInfo (ArgInfo { ai_dmds = dmds }) | dmd:_ <- dmds = isStrUsedDmd dmd | otherwise = False -argInfoAppArgs :: [ArgSpec] -> [OutExpr] -argInfoAppArgs [] = [] -argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast -argInfoAppArgs (ValArg { as_arg = arg } : as) = arg : argInfoAppArgs as -argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as - -pushSimplifiedArgs, pushSimplifiedRevArgs - :: SimplEnv - -> [ArgSpec] -- In normal, forward order for pushSimplifiedArgs, - -- in /reverse/ order for pushSimplifiedRevArgs - -> SimplCont -> SimplCont -pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args -pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args +pushSimplifiedArgs :: SimplEnv + -> [ArgSpec] -- In normal, forward order + -> SimplCont -> SimplCont +pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args +-- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont @@ -413,8 +396,11 @@ = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified -- The SubstEnv will be ignored since sc_dup=Simplified , sc_hole_ty = hole_ty, sc_cont = cont } -pushSimplifiedArg _ (CastBy c) cont = CastIt c cont +argSpecArg :: ArgSpec -> OutExpr +argSpecArg (ValArg { as_arg = arg }) = arg +argSpecArg (TyArg { as_arg_ty = ty }) = Type ty + argInfoExpr :: OutId -> [ArgSpec] -> OutExpr -- NB: the [ArgSpec] is reversed so that the first arg -- in the list is the last one in the application @@ -424,29 +410,7 @@ go [] = Var fun go (ValArg { as_arg = arg } : as) = go as `App` arg go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty - go (CastBy co : as) = mkCast (go as) co -decArgCount :: RewriteCall -> RewriteCall -decArgCount (TryRules n rules) = TryRules (n-1) rules -decArgCount rew = rew - -mkRewriteCall :: Id -> RuleEnv -> RewriteCall --- See Note [Rewrite rules and inlining] in GHC.Core.Opt.Simplify.Iteration --- We try to skip any unnecessary stages: --- No rules => skip TryRules --- No unfolding => skip TryInlining --- This skipping is "just" for efficiency. But rebuildCall is --- quite a heavy hammer, so skipping stages is a good plan. --- And it's extremely simple to do. -mkRewriteCall fun rule_env - | not (null rules) = TryRules n_required rules - | canUnfold unf = TryInlining - | otherwise = TryNothing - where - n_required = maximum (map ruleArity rules) - rules = getRules rule_env fun - unf = idUnfolding fun - {- ************************************************************************ * * @@ -470,7 +434,7 @@ ------------------- contIsRhs :: SimplCont -> Maybe RecFlag contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec -contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context +contIsRhs (CastIt { sc_cont = k }) = contIsRhs k -- For f = e |> co, treat e as Rhs context contIsRhs _ = Nothing ------------------- @@ -484,7 +448,7 @@ contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants] contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto... contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto... -contIsDupable (CastIt _ k) = contIsDupable k +contIsDupable (CastIt { sc_cont = k }) = contIsDupable k contIsDupable _ = False ------------------- @@ -493,13 +457,13 @@ contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k -- This one doesn't look right. A value application is not trivial -- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k -contIsTrivial (CastIt _ k) = contIsTrivial k +contIsTrivial (CastIt { sc_cont = k }) = contIsTrivial k contIsTrivial _ = False ------------------- contResultType :: SimplCont -> OutType contResultType (Stop ty _ _) = ty -contResultType (CastIt _ k) = contResultType k +contResultType (CastIt { sc_cont = k }) = contResultType k contResultType (StrictBind { sc_cont = k }) = contResultType k contResultType (StrictArg { sc_cont = k }) = contResultType k contResultType (Select { sc_cont = k }) = contResultType k @@ -510,7 +474,7 @@ contHoleType :: SimplCont -> OutType contHoleType (Stop ty _ _) = ty contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt co _) = coercionLKind co +contHoleType (CastIt { sc_co = co }) = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) = perhapsSubstTy dup se (idType b) contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty @@ -530,7 +494,8 @@ -- case-of-case transformation. contHoleScaling :: SimplCont -> Mult contHoleScaling (Stop _ _ _) = OneTy -contHoleScaling (CastIt _ k) = contHoleScaling k +contHoleScaling (CastIt { sc_cont = k }) + = contHoleScaling k contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) = idMult id `mkMultMul` contHoleScaling k contHoleScaling (Select { sc_bndr = id, sc_cont = k }) @@ -549,14 +514,14 @@ -- and other values; skipping over casts. countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont -countArgs (CastIt _ cont) = countArgs cont +countArgs (CastIt { sc_cont = cont }) = countArgs cont countArgs _ = 0 countValArgs :: SimplCont -> Int -- Count value arguments only countValArgs (ApplyToTy { sc_cont = cont }) = countValArgs cont countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont -countValArgs (CastIt _ cont) = countValArgs cont +countValArgs (CastIt { sc_cont = cont }) = countValArgs cont countValArgs _ = 0 ------------------- @@ -576,13 +541,41 @@ go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k }) = go (is_interesting arg se : args) k go args (ApplyToTy { sc_cont = k }) = go args k - go args (CastIt _ k) = go args k + go args (CastIt { sc_cont = k }) = go args k go args k = (False, reverse args, k) is_interesting arg se = interestingArg se arg -- Do *not* use short-cutting substitution here -- because we want to get as much IdInfo as possible +contOutArgs :: SimplEnv -> SimplCont -> [OutExpr] +-- Get the leading arguments from the `SimplCont`, as /OutExprs/ +contOutArgs env cont + = go cont + where + in_scope = seInScope env + + go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) + = Type ty : go cont + + go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont }) + | isSimplified dup = arg : go cont + | otherwise = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont + -- Make sure we apply the static environment `sc_env` as a substitution + -- to get an OutExpr. See (BF1) in Note [tryRules: plan (BEFORE)] + -- in GHC.Core.Opt.Simplify.Iteration + -- NB: we use substExpr, not substExprSC: we want to get the benefit of + -- knowing what is evaluated etc, via the in-scope set + + -- No more arguments + go _ = [] + +dropContArgs :: FullArgCount -> SimplCont -> SimplCont +dropContArgs 0 cont = cont +dropContArgs n (ApplyToTy { sc_cont = cont }) = dropContArgs (n-1) cont +dropContArgs n (ApplyToVal { sc_cont = cont }) = dropContArgs (n-1) cont +dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont) + -- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'. -- This can be more insightful than the limited syntactic context that -- 'SimplCont' provides, because the 'Stop' constructor might carry a useful @@ -595,10 +588,10 @@ -- about what to do then and no call sites so far seem to care. contEvalContext :: SimplCont -> SubDemand contEvalContext k = case k of - (Stop _ _ sd) -> sd - (TickIt _ k) -> contEvalContext k - (CastIt _ k) -> contEvalContext k - ApplyToTy{sc_cont=k} -> contEvalContext k + Stop _ _ sd -> sd + TickIt _ k -> contEvalContext k + CastIt { sc_cont = k } -> contEvalContext k + ApplyToTy{ sc_cont = k } -> contEvalContext k -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k -- Not 100% sure that's correct, . Here's an example: -- f (e x) and f :: @@ -614,29 +607,26 @@ -- and case binder dmds, see addCaseBndrDmd. No priority right now. ------------------- -mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo - -mkArgInfo env rule_base fun cont +mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo +mkArgInfo env fun rules_for_fun cont | n_val_args < idArity fun -- Note [Unsaturated functions] = ArgInfo { ai_fun = fun, ai_args = [] - , ai_rewrite = fun_rewrite + , ai_rules = rules_for_fun , ai_encl = False , ai_dmds = vanilla_dmds , ai_discs = vanilla_discounts } | otherwise = ArgInfo { ai_fun = fun , ai_args = [] - , ai_rewrite = fun_rewrite + , ai_rules = rules_for_fun , ai_encl = fun_has_rules || contHasRules cont , ai_dmds = add_type_strictness (idType fun) arg_dmds , ai_discs = arg_discounts } where - n_val_args = countValArgs cont - fun_rewrite = mkRewriteCall fun rule_base - fun_has_rules = case fun_rewrite of - TryRules {} -> True - _ -> False + n_val_args = countValArgs cont + fun_has_rules = not (null rules_for_fun) + vanilla_discounts, arg_discounts :: [Int] vanilla_discounts = repeat 0 arg_discounts = case idUnfolding fun of @@ -794,45 +784,87 @@ True -> Just x False -> Just (x-1) -Now consider these cases: +Now consider these variants of + case (f x) of ... -1. case f x of b{-dead-} { DEFAULT -> blah[no b] } - Inlining (f x) will allow us to avoid ever allocating (Just x), - since the case binder `b` is dead. We will end up with a +1. [Dead case binder]: inline f + case f x of b{-dead-} { DEFAULT -> blah[no b] } + Inlining (f x) will allow us to avoid ever allocating (Just x), + since the case binder `b` is dead. We will end up with a join point for blah, thus join j = blah in case v of { True -> j; False -> j } - which will turn into (case v of DEFAULT -> blah - All good - -2. case f x of b { DEFAULT -> blah[b] } - Inlining (f x) will still mean we allocate (Just x). We'd get: - join j b = blah[b] - case v of { True -> j (Just x); False -> j (Just (x-1)) } - No new optimisations are revealed. Nothing is gained. - (This is the situation in T22317.) - -2a. case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] } - Instead of DEFAULT we have a single constructor alternative - with all dead binders. This is just a variant of (2); no - gain from inlining (f x) + which will turn into (case v of DEFAULT -> blah) + All good -3. case f x of b { Just y -> blah[y,b] } - Inlining (f x) will mean we still allocate (Just x), - but we also get to bind `y` without fetching it out of the Just, thus +2. [Live case binder, live alt binders]: inline f + case f x of b { Just y -> blah[y,b] } + Inlining (f x) will mean we still allocate (Just x), + but we also get to bind `y` without fetching it out of the Just, thus join j y b = blah[y,b] case v of { True -> j x (Just x) ; False -> let y = x-1 in j y (Just y) } Inlining (f x) has a small benefit, perhaps. (To T14955 it makes a surprisingly large difference of ~30% to inline here.) +3. [Live case binder, dead alt binders]: maybe don't inline f + case f x of b { DEFAULT -> blah[b] } + Inlining (f x) will still mean we allocate (Just x). We'd get: + join j b = blah[b] + case v of { True -> j (Just x); False -> j (Just (x-1)) } + No new optimisations are revealed. Nothing is gained. + (This is the situation in T22317.) -Conclusion: if the case expression - * Has a non-dead case-binder - * Has one alternative + A variant is when we have a data constructor with dead binders: + case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] } + Instead of DEFAULT we have a single constructor alternative + with all dead binders. Again, no gain from inlining (f x) + +4. [Live case binder, dead alt binders]: small f + Suppose f is CPR'd, so it looks like + f x = case $wf x of (# a #) -> Just a + Then even in case (3) we want to inline: + case f x of b { DEFAULT -> blah[b] } + --> + case $wf x of (# a #) -> + let b = Just a in blah[b] + This is very good; we now know a lot about `b` (instead of nothing) + and `blah` might benefit. Similarly if `f` has a join point + f x = join $j y = Just y in ... + Again the case (f x) is now consuming a constructor (Just y). + + This is very like the situation described in Note [RHS of lets] + in GHC.Core.Opt.Simplify.Inline; (case e of b -> blah) is just + like a strict `let`. + +Conclusion: in interestingCallCtxt, a case-expression (i.e. Select continuation) +usually gives a CaseCtxt (cases 1,2); but when (cases 3,4): + * It has a non-dead case-binder + * It has one alternative * All the binders in the alternative are dead -then the `case` is just a strict let-binding, and the scrutinee is -BoringCtxt (don't inline). Otherwise CaseCtxt. +then the `case` is just a strict let-binding, so use RhsCtxt NonRecursive. +This RhsCtxt gives a small incentive for small functions to inline. +That incentive is what is needed in case (4). + +Wrinkle (SB1). The 'small incentive' is implemented by `calc_some_benefit` in +GHC.Core.Opt.Simplify.Inline.tryUnfolding. We restrict the incentive just to +funtions that have unfolding guidance of `UnfWhen`, which particularly includes +wrappers created by CPR, exactly case (4) above. Without this limitation I +got too much fruitless inlining, which led to regressions (#22317 is an example). + +A good example of a function where this 'small incentive' is important is +GHC.Internal.Bignum.Integer where we ended up with calls like this: + case (integerSignum a b) of r -> ... +but were failing to inline integerSignum, even though it always returns +a single constructor, so it is very helpful to inline it. There is also an +issue of confluence-of-the-simplifier. Suppose we have + f x = case x of r -> ... +and the Simplifier sees + f (integerSigNum a b) +Because `f` scrutines `x`, the unfolding guidance for f gives a discount +for `x`; and that discount makes interestingCallContext for the context +`f <>` return DiscArgCtxt, which again gives that incentive. We don't want +the incentive to disappear when we inline `f`! -} lazyArgContext :: ArgInfo -> CallCtxt @@ -867,7 +899,7 @@ | not (seCaseCase env) = BoringCtxt -- See Note [No case of case is boring] | [Alt _ bs _] <- alts , all isDeadBinder bs - , not (isDeadBinder case_bndr) = BoringCtxt -- See Note [Seq is boring] + , not (isDeadBinder case_bndr) = RhsCtxt NonRecursive -- See Note [Seq is boring] | otherwise = CaseCtxt @@ -882,7 +914,7 @@ interesting (Stop _ cci _) = cci interesting (TickIt _ k) = interesting k interesting (ApplyToTy { sc_cont = k }) = interesting k - interesting (CastIt _ k) = interesting k + interesting (CastIt { sc_cont = k }) = interesting k -- If this call is the arg of a strict function, the context -- is a bit interesting. If we inline here, we may get useful -- evaluation information to avoid repeated evals: e.g. @@ -922,7 +954,7 @@ where go (ApplyToVal { sc_cont = cont }) = go cont go (ApplyToTy { sc_cont = cont }) = go cont - go (CastIt _ cont) = go cont + go (CastIt { sc_cont = cont }) = go cont go (StrictArg { sc_fun = fun }) = ai_encl fun go (Stop _ RuleArgCtxt _) = True go (TickIt _ c) = go c @@ -993,17 +1025,41 @@ env' = env `addNewInScopeIds` bindersOf b go_var n v - | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that - -- data constructors here - | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding - | n > 0 = NonTrivArg -- Saturated or unknown call - | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding - -- See Note [Conlike is interesting] - | otherwise = TrivArg -- n==0, no useful unfolding - where - conlike_unfolding = isConLikeUnfolding (idUnfolding v) + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here + -- DFuns are con-like; see Note [Conlike is interesting] + | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding + | n > 0 = NonTrivArg -- Saturated or unknown call + | otherwise -- n==0, no value arguments; look for an interesting unfolding + = case idUnfolding v of + OtherCon [] -> NonTrivArg -- It's evaluated, but that's all we know + OtherCon _ -> ValueArg -- Evaluated and we know it isn't these constructors + -- See Note [OtherCon and interestingArg] + DFunUnfolding {} -> ValueArg -- We konw that idArity=0 + CoreUnfolding{ uf_cache = cache } + | uf_is_conlike cache -> ValueArg -- Includes constructor applications + | uf_is_value cache -> NonTrivArg -- Things like partial applications + | otherwise -> TrivArg + BootUnfolding -> TrivArg + NoUnfolding -> TrivArg -{- +{- Note [OtherCon and interestingArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +interstingArg returns + (a) NonTrivArg for an arg with an OtherCon [] unfolding + (b) ValueArg for an arg with an OtherCon [c1,c2..] unfolding. + +Reason for (a): I found (in the GHC.Internal.Bignum.Integer module) that I was +inlining a pretty big function when all we knew was that its arguments +were evaluated, nothing more. That in turn make the enclosing function +too big to inline elsewhere. + +Reason for (b): we want to inline integerCompare here + integerLt# :: Integer -> Integer -> Bool# + integerLt# (IS x) (IS y) = x <# y + integerLt# x y | LT <- integerCompare x y = 1# + integerLt# _ _ = 0# + ************************************************************************ * * SimplMode @@ -1224,19 +1280,6 @@ continuation. -} -activeUnfolding :: SimplMode -> Id -> Bool -activeUnfolding mode id - | isCompulsoryUnfolding (realIdUnfolding id) - = True -- Even sm_inline can't override compulsory unfoldings - | otherwise - = isActive (sm_phase mode) (idInlineActivation id) - && sm_inline mode - -- `or` isStableUnfolding (realIdUnfolding id) - -- Inline things when - -- (a) they are active - -- (b) sm_inline says so, except that for stable unfoldings - -- (ie pragmas) we inline anyway - getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv -- When matching in RULE, we want to "look through" an unfolding -- (to see a constructor) if *rules* are on, even if *inlinings* @@ -1453,6 +1496,10 @@ canInlineInLam (Lit _) = True canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam (Var v) = case idOccInfo v of + OneOcc { occ_in_lam = IsInsideLam } -> True + ManyOccs {} -> True + _ -> False canInlineInLam _ = False -- not ticks. Counting ticks cannot be duplicated, and non-counting -- ticks around a Lam will disappear anyway. @@ -1472,6 +1519,18 @@ -- simplifications). Until phase zero we take no special notice of -- top level things, but then we become more leery about inlining -- them. + -- + -- What exactly to check in `early_phase` above is the subject of #17910. + -- + -- !10088 introduced an additional Simplifier iteration in LargeRecord + -- because we first FloatOut `case unsafeEqualityProof of ... -> I# 2#` + -- (a non-trivial value) which we immediately inline back in. + -- Ideally, we'd never have inlined it because the binding turns out to + -- be expandable; unfortunately we need an iteration of the Simplifier to + -- attach the proper unfolding and can't check isExpandableUnfolding right + -- here. + -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look + -- at the non-existent unfolding for the `I# 2#` which is also floated out.) {- ************************************************************************ @@ -1515,15 +1574,14 @@ postInlineUnconditionally :: SimplEnv -> BindContext - -> OutId -- The binder (*not* a CoVar), including its unfolding - -> OccInfo -- From the InId + -> InId -> OutId -- The binder (*not* a CoVar), including its unfolding -> OutExpr -> Bool -- Precondition: rhs satisfies the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, -- for unlifted, side-effect-ful bindings -postInlineUnconditionally env bind_cxt bndr occ_info rhs +postInlineUnconditionally env bind_cxt old_bndr bndr rhs | not active = False | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" @@ -1531,40 +1589,33 @@ | isTopLevel (bindContextLevel bind_cxt) = False -- Note [Top level and postInlineUnconditionally] | exprIsTrivial rhs = True - | BC_Join {} <- bind_cxt -- See point (1) of Note [Duplicating join points] - , not (phase == FinalPhase) = False -- in Simplify.hs + | BC_Join {} <- bind_cxt = False -- See point (1) of Note [Duplicating join points] + -- in GHC.Core.Opt.Simplify.Iteration | otherwise = case occ_info of OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br } -- See Note [Inline small things to avoid creating a thunk] - -> n_br < 100 -- See Note [Suppress exponential blowup] + | n_br >= 100 -> False -- See #23627 - && smallEnoughToInline uf_opts unfolding -- Small enough to dup - -- ToDo: consider discount on smallEnoughToInline if int_cxt is true - -- - -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1 - -- Reason: doing so risks exponential behaviour. We simplify a big - -- expression, inline it, and simplify it again. But if the - -- very same thing happens in the big expression, we get - -- exponential cost! - -- PRINCIPLE: when we've already simplified an expression once, - -- make sure that we only inline it if it's reasonably small. + | n_br == 1, NotInsideLam <- in_lam -- One syntactic occurrence + -> True -- See Note [Post-inline for single-use things] - && (in_lam == NotInsideLam || - -- Outside a lambda, we want to be reasonably aggressive - -- about inlining into multiple branches of case - -- e.g. let x = - -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } - -- Inlining can be a big win if C3 is the hot-spot, even if - -- the uses in C1, C2 are not 'interesting' - -- An example that gets worse if you add int_cxt here is 'clausify' +-- | is_unlifted -- Unlifted binding, hence ok-for-spec +-- -> True -- hence cheap to inline probably just a primop +-- -- Not a big deal either way +-- No, this is wrong. {v = p +# q; x = K v}. +-- Don't inline v; it'll just get floated out again. Stupid. - (isCheapUnfolding unfolding && int_cxt == IsInteresting)) - -- isCheap => acceptable work duplication; in_lam may be true - -- int_cxt to prevent us inlining inside a lambda without some - -- good reason. See the notes on int_cxt in preInlineUnconditionally + | is_demanded + -> False -- No allocation (it'll be a case expression in the end) + -- so inlining duplicates code but nothing more + | otherwise + -> work_ok in_lam int_cxt && smallEnoughToInline uf_opts unfolding + -- Multiple syntactic occurences; but lazy, and small enough to dup + -- ToDo: consider discount on smallEnoughToInline if int_cxt is true + IAmDead -> True -- This happens; for example, the case_bndr during case of -- known constructor: case (a,b) of x { (p,q) -> ... } -- Here x isn't mentioned in the RHS, so we don't want to @@ -1572,23 +1623,29 @@ _ -> False --- Here's an example that we don't handle well: --- let f = if b then Left (\x.BIG) else Right (\y.BIG) --- in \y. ....case f of {...} .... --- Here f is used just once, and duplicating the case work is fine (exprIsCheap). --- But --- - We can't preInlineUnconditionally because that would invalidate --- the occ info for b. --- - We can't postInlineUnconditionally because the RHS is big, and --- that risks exponential behaviour --- - We can't call-site inline, because the rhs is big --- Alas! - where - unfolding = idUnfolding bndr - uf_opts = seUnfoldingOpts env - phase = sePhase env - active = isActive phase (idInlineActivation bndr) + work_ok NotInsideLam _ = True + work_ok IsInsideLam IsInteresting = isCheapUnfolding unfolding + work_ok IsInsideLam NotInteresting = False + -- NotInsideLam: outside a lambda, we want to be reasonably aggressive + -- about inlining into multiple branches of case + -- e.g. let x = + -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... } + -- Inlining can be a big win if C3 is the hot-spot, even if + -- the uses in C1, C2 are not 'interesting' + -- An example that gets worse if you add int_cxt here is 'clausify' + + -- InsideLam: check for acceptable work duplication, using isCheapUnfoldign + -- int_cxt to prevent us inlining inside a lambda without some + -- good reason. See the notes on int_cxt in preInlineUnconditionally + +-- is_unlifted = isUnliftedType (idType bndr) + is_demanded = isStrUsedDmd (idDemandInfo bndr) + occ_info = idOccInfo old_bndr + unfolding = idUnfolding bndr + uf_opts = seUnfoldingOpts env + phase = sePhase env + active = isActive phase (idInlineActivation bndr) -- See Note [pre/postInlineUnconditionally in gentle mode] {- Note [Inline small things to avoid creating a thunk] @@ -1609,38 +1666,52 @@ to allocate more. An egregious example is test perf/compiler/T14697, where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more. -Note [Suppress exponential blowup] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #13253, and several related tickets, we got an exponential blowup -in code size from postInlineUnconditionally. The trouble comes when -we have - let j1a = case f y of { True -> p; False -> q } - j1b = case f y of { True -> q; False -> p } - j2a = case f (y+1) of { True -> j1a; False -> j1b } - j2b = case f (y+1) of { True -> j1b; False -> j1a } - ... - in case f (y+10) of { True -> j10a; False -> j10b } +Note [Post-inline for single-use things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have -when there are many branches. In pass 1, postInlineUnconditionally -inlines j10a and j10b (they are both small). Now we have two calls -to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines -all four of these calls, leaving four calls to j8a and j8b. Etc. -Yikes! This is exponential! + let x = rhs in ...x... -A possible plan: stop doing postInlineUnconditionally -for some fixed, smallish number of branches, say 4. But that turned -out to be bad: see Note [Inline small things to avoid creating a thunk]. -And, as it happened, the problem with #13253 was solved in a -different way (Note [Duplicating StrictArg] in Simplify). +and `x` is used exactly once, and not inside a lambda, then we will usually +preInlineUnconditinally. But we can still get this situation in +postInlineUnconditionally: -So I just set an arbitrary, high limit of 100, to stop any -totally exponential behaviour. + case K rhs of K x -> ...x.... -This still leaves the nasty possibility that /ordinary/ inlining (not -postInlineUnconditionally) might inline these join points, each of -which is individually quiet small. I'm still not sure what to do -about this (e.g. see #15488). +Here we'll use `simplAuxBind` to bind `x` to (the already-simplified) `rhs`; +and `x` is used exactly once. It's beneficial to inline right away; otherwise +we risk creating + let x = rhs in ...x... + +which will take another iteration of the Simplifier to eliminate. We do this in +two places + +1. In the full `postInlineUnconditionally` look for the special case + of "one occurrence, not under a lambda", and inline unconditionally then. + + This is a bit risky: see Note [Avoiding simplifying repeatedly] in + Simplify.Iteration. But in practice it seems to be a small win. + +2. `simplAuxBind` does a kind of poor-man's `postInlineUnconditionally`. It + does not need to account for many of the cases (e.g. top level) that the + full `postInlineUnconditionally` does. Moreover, we don't have an + OutId, which `postInlineUnconditionally` needs. I got a slight improvement + in compiler performance when I added this test. + +Here's an example that we don't currently handle well: + let f = if b then Left (\x.BIG) else Right (\y.BIG) + in \y. ....case f of {...} .... +Here f is used just once, and duplicating the case work is fine (exprIsCheap). +But + - We can't preInlineUnconditionally because that would invalidate + the occ info for b. + - We can't postInlineUnconditionally because the RHS is big, and + that risks exponential behaviour + - We can't call-site inline, because the rhs is big +Alas! + + Note [Top level and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't do postInlineUnconditionally for top-level things (even for @@ -2096,6 +2167,27 @@ which showed that it's harder to do polymorphic specialisation well if there are dictionaries abstracted over unnecessary type variables. See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise + +(AB5) We do dependency analysis on recursive groups prior to determining + which variables to abstract over. + This is useful, because ANFisation in prepareBinding may float out + values out of a complex recursive binding, e.g., + letrec { xs = g @a "blah"# ((:) 1 []) xs } in ... + ==> { prepareBinding } + letrec { foo = "blah"# + bar = [42] + xs = g @a foo bar xs } in + ... + and we don't want to abstract foo and bar over @a. + + (Why is it OK to float the unlifted `foo` there? + See Note [Core top-level string literals] in GHC.Core; + it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.) + + It is also necessary to do dependency analysis, because + otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the + top-level, and that triggers a CoreLint error because `foo` is *not* + manifestly a literal string. -} abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats @@ -2103,15 +2195,27 @@ abstractFloats uf_opts top_lvl main_tvs floats body = assert (notNull body_floats) $ assert (isNilOL (sfJoinFloats floats)) $ - do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats + do { let sccs = concatMap to_sccs body_floats + ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs ; return (float_binds, GHC.Core.Subst.substExpr subst body) } where is_top_lvl = isTopLevel top_lvl body_floats = letFloatBinds (sfLetFloats floats) empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) - abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind) - abstract subst (NonRec id rhs) + -- See wrinkle (AB5) in Note [Which type variables to abstract over] + -- for why we need to re-do dependency analysis + to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)] + to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it + to_sccs (Rec prs) = sccs + where + (ids,rhss) = unzip prs + sccs = depAnal (\(id,_rhs,_fvs) -> [getName id]) + (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3) + (zip3 ids rhss (map exprFreeVars rhss)) + + abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind) + abstract subst (AcyclicSCC (id, rhs, _empty_var_set)) = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs' !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app @@ -2122,7 +2226,7 @@ -- tvs_here: see Note [Which type variables to abstract over] tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') - abstract subst (Rec prs) + abstract subst (CyclicSCC trpls) = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps) poly_pairs = [ mk_poly2 poly_id tvs_here rhs' @@ -2130,15 +2234,15 @@ , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] ; return (subst', Rec poly_pairs) } where - (ids,rhss) = unzip prs - + (ids,rhss,_fvss) = unzip3 trpls -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs) + tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls) -- See wrinkle (AB4) in Note [Which type variables to abstract over] - get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs - get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs) + get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs + get_rec_rhs_tvs rhs_fvs = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs + -- nonDet is safe because of wrinkle (AB3) get_tvs :: Var -> VarSet -> VarSet get_tvs var free_tvs @@ -2184,7 +2288,7 @@ = (poly_id `setIdUnfolding` unf, poly_rhs) where poly_rhs = mkLams tvs_here rhs - unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs Nothing + unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False False poly_rhs Nothing -- We want the unfolding. Consider -- let @@ -2315,7 +2419,25 @@ Var v -> otherCons (idUnfolding v) _ -> [] +{- Note [Merging nested cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic case-merge stuff is described in Note [Merge Nested Cases] in GHC.Core.Utils +We do it here in `prepareAlts` (on InAlts) rather than after (on OutAlts) for two reasons: + +* It "belongs" here with `filterAlts`, `refineDefaultAlt` and `combineIdenticalAlts`. + +* In test perf/compiler/T22428 I found that I was getting extra Simplifer iterations: + 1. Create a join point + 2. That join point gets inlined at all call sites, so it is now dead. + 3. Case-merge happened, but left behind some trivial bindings (see `mergeCaseAlts`) + 4. Get rid of the trivial bindings + The first two seem reasonable. It's imaginable that we could do better on + (3), by making case-merge join-point-aware, but it's not trivial. But the + fourth is just stupid. Rather than always do an extra iteration, it's better + to do the transformation on the input-end of teh Simplifier. +-} + {- ************************************************************************ * * @@ -2325,28 +2447,9 @@ mkCase tries these things -* Note [Merge Nested Cases] * Note [Eliminate Identity Case] * Note [Scrutinee Constant Folding] -Note [Merge Nested Cases] -~~~~~~~~~~~~~~~~~~~~~~~~~ - case e of b { ==> case e of b { - p1 -> rhs1 p1 -> rhs1 - ... ... - pm -> rhsm pm -> rhsm - _ -> case b of b' { pn -> let b'=b in rhsn - pn -> rhsn ... - ... po -> let b'=b in rhso - po -> rhso _ -> let b'=b in rhsd - _ -> rhsd - } - -which merges two cases in one case when -- the default alternative of -the outer case scrutinises the same variable as the outer case. This -transformation is called Case Merging. It avoids that the same -variable is scrutinised multiple times. - Note [Eliminate Identity Case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ case e of ===> e @@ -2438,7 +2541,6 @@ see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold - Note [Example of case-merging and caseRules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The case-transformation rules are quite powerful. Here's a @@ -2454,9 +2556,9 @@ In Core after a bit of simplification we get: - f x = case dataToTag# x of a# { _DEFAULT -> + f x = case dataToTagLarge# x of a# { _DEFAULT -> case a# of - _DEFAULT -> case dataToTag# x of b# { _DEFAULT -> + _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT -> case b# of _DEFAULT -> ... 1# -> "two" @@ -2468,8 +2570,8 @@ The case-merge transformation Note [Merge Nested Cases] does this (affecting both pairs of cases): - f x = case dataToTag# x of a# { - _DEFAULT -> case dataToTag# x of b# { + f x = case dataToTagLarge# x of a# { + _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT -> ... 1# -> "two" } @@ -2477,22 +2579,22 @@ } Now Note [caseRules for dataToTag] does its work, again -on both dataToTag# cases: +on both dataToTagLarge# cases: f x = case x of x1 { - _DEFAULT -> case dataToTag# x1 of a# { _DEFAULT -> + _DEFAULT -> case dataToTagLarge# x1 of a# { _DEFAULT -> case x of x2 { - _DEFAULT -> case dataToTag# x2 of b# { _DEFAULT -> ... } + _DEFAULT -> case dataToTagLarge# x2 of b# { _DEFAULT -> ... } B -> "two" }} A -> "one" } -The new dataToTag# calls come from the "reconstruct scrutinee" part of +The new dataToTagLarge# calls come from the "reconstruct scrutinee" part of caseRules (note that a# and b# were not dead in the original program before all this merging). However, since a# and b# /are/ in fact dead -in the resulting program, we are left with redundant dataToTag# calls. +in the resulting program, we are left with redundant dataToTagLarge# calls. But they are easily eliminated by doing caseRules again, in the next Simplifier iteration, this time noticing that a# and b# are dead. Hence the "dead-binder" sub-case of Wrinkle 1 of Note @@ -2524,48 +2626,28 @@ -------------------------------------------------- -- 1. Merge Nested Cases +-- See Note [Merge Nested Cases] +-- Note [Example of case-merging and caseRules] +-- Note [Cascading case merge] -------------------------------------------------- -mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) +mkCase mode scrut outer_bndr alts_ty alts | sm_case_merge mode - , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) - <- stripTicksTop tickishFloatable deflt_rhs - , inner_scrut_var == outer_bndr + , Just (joins, alts') <- mergeCaseAlts outer_bndr alts = do { tick (CaseMerge outer_bndr) - - ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args) - (Alt con args (wrap_rhs rhs)) - -- Simplifier's no-shadowing invariant should ensure - -- that outer_bndr is not shadowed by the inner patterns - wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs - -- The let is OK even for unboxed binders, - - wrapped_alts | isDeadBinder inner_bndr = inner_alts - | otherwise = map wrap_alt inner_alts - - merged_alts = mergeAlts outer_alts wrapped_alts - -- NB: mergeAlts gives priority to the left - -- case x of - -- A -> e1 - -- DEFAULT -> case x of - -- A -> e2 - -- B -> e3 - -- When we merge, we must ensure that e1 takes - -- precedence over e2 as the value for A! - - ; fmap (mkTicks ticks) $ - mkCase1 mode scrut outer_bndr alts_ty merged_alts - } - -- Warning: don't call mkCase recursively! + ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts' + ; return (mkLets joins case_expr) } + -- mkCase1: don't call mkCase recursively! -- Firstly, there's no point, because inner alts have already had -- mkCase applied to them, so they won't have a case in their default -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr -- in munge_rhs may put a case into the DEFAULT branch! - -mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts + | otherwise + = mkCase1 mode scrut outer_bndr alts_ty alts -------------------------------------------------- -- 2. Eliminate Identity Case +-- See Note [Eliminate Identity Case] -------------------------------------------------- mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case @@ -2609,8 +2691,10 @@ mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts + -------------------------------------------------- -- 2. Scrutinee Constant Folding +-- See Note [Scrutinee Constant Folding] -------------------------------------------------- mkCase2 mode scrut bndr alts_ty alts @@ -2720,8 +2804,9 @@ isExitJoinId :: Var -> Bool isExitJoinId id = isJoinId id - && isOneOcc (idOccInfo id) - && occ_in_lam (idOccInfo id) == IsInsideLam + && case idOccInfo id of + OneOcc { occ_in_lam = IsInsideLam } -> True + _ -> False {- Note [Dead binders] @@ -2729,64 +2814,4 @@ Note that dead-ness is maintained by the simplifier, so that it is accurate after simplification as well as before. - -Note [Cascading case merge] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Case merging should cascade in one sweep, because it -happens bottom-up - - case e of a { - DEFAULT -> case a of b - DEFAULT -> case b of c { - DEFAULT -> e - A -> ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> case a of b - DEFAULT -> let c = b in e - A -> let c = b in ea - B -> eb - C -> ec -==> - case e of a { - DEFAULT -> let b = a in let c = b in e - A -> let b = a in let c = b in ea - B -> let b = a in eb - C -> ec - - -However here's a tricky case that we still don't catch, and I don't -see how to catch it in one pass: - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -After occurrence analysis (and its binder-swap) we get this - - case x of c1 { I# a1 -> - let x = c1 in -- Binder-swap addition - case a1 of c2 -> - 0 -> ... - DEFAULT -> case x of c3 { I# a2 -> - case a2 of ... - -When we simplify the inner case x, we'll see that -x=c1=I# a1. So we'll bind a2 to a1, and get - - case x of c1 { I# a1 -> - case a1 of c2 -> - 0 -> ... - DEFAULT -> case a1 of ... - -This is correct, but we can't do a case merge in this sweep -because c2 /= a1. Reason: the binding c1=I# a1 went inwards -without getting changed to c1=I# c2. - -I don't think this is worth fixing, even if I knew how. It'll -all come out in the next pass anyway. -} diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs --- a/GHC/Core/Opt/SpecConstr.hs +++ b/GHC/Core/Opt/SpecConstr.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP, LambdaCase #-} -#if __GLASGOW_HASKELL__ < 905 -{-# LANGUAGE PatternSynonyms #-} -#endif +{-# LANGUAGE LambdaCase #-} {- ToDo [Oct 2013] ~~~~~~~~~~~~~~~ @@ -14,13 +11,10 @@ \section[SpecConstr]{Specialise over constructors} -} - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.Core.Opt.SpecConstr( specConstrProgram, - SpecConstrAnnotation(..) + SpecConstrAnnotation(..), + SpecFailWarning(..) ) where import GHC.Prelude @@ -36,12 +30,12 @@ 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 ) import GHC.Core.Rules -import GHC.Core.Predicate ( typeDeterminesValue ) +import GHC.Core.Predicate ( scopedSort, typeDeterminesValue ) import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon (TyCon, tyConName ) import GHC.Core.Multiplicity @@ -51,6 +45,7 @@ import GHC.Unit.Module import GHC.Unit.Module.ModGuts +import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) ) @@ -66,13 +61,11 @@ import GHC.Types.Unique.FM import GHC.Types.Unique( hasKey ) -import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) -import GHC.Data.Pair +import GHC.Data.Maybe ( fromMaybe, orElse, catMaybes, isJust, isNothing ) import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Utils.Panic.Plain import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad @@ -82,8 +75,9 @@ import GHC.Exts( SpecConstrAnnotation(..) ) import GHC.Serialized ( deserializeWithData ) -import Control.Monad ( zipWithM ) -import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) +import Control.Monad +import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL ) +import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) import Data.Tuple @@ -520,14 +514,19 @@ ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set sc_force to True when calling specLoop. This flag does four things: - * Ignore specConstrThreshold, to specialise functions of arbitrary size +(FS1) Ignore specConstrThreshold, to specialise functions of arbitrary size (see scTopBind) - * Ignore specConstrCount, to make arbitrary numbers of specialisations +(FS2) Ignore specConstrCount, to make arbitrary numbers of specialisations (see specialise) - * Specialise even for arguments that are not scrutinised in the loop +(FS3) Specialise even for arguments that are not scrutinised in the loop (see argToPat; #4448) - * Only specialise on recursive types a finite number of times - (see is_too_recursive; #5550; Note [Limit recursive specialisation]) +(FS4) Only specialise on recursive types a finite number of times + (see sc_recursive; #5550; Note [Limit recursive specialisation]) +(FS5) Use a different restriction on the maximum number of arguments which + the optimisation will specialise. We tried removing the limit on worker + args for forced specs (#14003) but this caused issues when specializing + code for large data structures (#25197). + This is handled by `too_many_worker_args` in `callsToNewPats` The flag holds only for specialising a single binding group, and NOT for nested bindings. (So really it should be passed around explicitly @@ -638,6 +637,17 @@ representing strict fields. See Note [Call-by-value for worker args] for why we do this. +(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944). + We don't want to make + case M.foo_acf of M.foo_acf { DEFAULT -> blah } + because the binder of a case-expression should never be imported. Rather, + we must localise it thus: + case M.foo_acf of foo_acf { DEFAULT -> blah } + We keep the same unique, so in the next round of simplification we'll replace + any M.foo_acf's in `blah` by `foo_acf`. + + c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils. + Note [Specialising on dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In #21386, SpecConstr saw this call: @@ -770,16 +780,25 @@ specConstrProgram guts = do { env0 <- initScEnv guts ; us <- getUniqueSupplyM - ; let (_usg, binds') = initUs_ us $ + ; let (_usg, binds', warnings) = initUs_ us $ scTopBinds env0 (mg_binds guts) + ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings) + ; return (guts { mg_binds = binds' }) } -scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind]) -scTopBinds _env [] = return (nullUsage, []) -scTopBinds env (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $ + where + specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing + warn_msg :: SpecFailWarnings -> SDoc + warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$ + text "which resulted in no specialization being generated for these functions:" $$ + nest 2 (vcat (map ppr warnings)) $$ + (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.") +scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning]) +scTopBinds _env [] = return (nullUsage, [], []) +scTopBinds env (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $ (\env -> scTopBinds env bs) - ; return (usg, b' ++ bs') } + ; return (usg, b' ++ bs', warnings) } {- ************************************************************************ @@ -788,48 +807,71 @@ * * ************************************************************************ -Note [Work-free values only in environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_vals field keeps track of in-scope value bindings, so -that if we come across (case x of Just y ->...) we can reduce the -case from knowing that x is bound to a pair. +Note [ConVal work-free-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_vals field keeps track of in-scope value bindings, and is used in +two ways: -But only *work-free* values are ok here. For example if the envt had - x -> Just (expensive v) -then we do NOT want to expand to - let y = expensive v in ... -because the x-binding still exists and we've now duplicated (expensive v). +(1) To do case-of-known-constructor in a case expression. E.g. if sc_vals + includes [x :-> ConVal Just e], then we can simplify + case x of Just y -> ... + with the case-of-known-constructor transformation. (Yes this is + done by the Simplifier, but SpecConstr creates new opportunities when + it makes a specialised RHS for a function.) -This seldom happens because let-bound constructor applications are -ANF-ised, but it can happen as a result of on-the-fly transformations in -SpecConstr itself. Here is #7865: + For (1) it is crucial that the arguments are /work-free/; see (CV1) + below. - let { - a'_shr = - case xs_af8 of _ { - [] -> acc_af6; - : ds_dgt [Dmd=] ds_dgu [Dmd=] -> - (expensive x_af7, x_af7 - } } in - let { - ds_sht = - case a'_shr of _ { (p'_afd, q'_afe) -> - TSpecConstr_DoubleInline.recursive - (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) - } } in +(2) To figure out call pattresns. E.g. if sc_vals includes + [x :-> ConVal Just e], and we have call (f x), then we might want + to specialise `f (Just _)` -When processed knowing that xs_af8 was bound to a cons, we simplify to - a'_shr = (expensive x_af7, x_af7) -and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. -(There are other occurrences of a'_shr.) No no no. + For (2) it is /not/ important that the constructor arguments are work-free; + indeed, it would be bad to insist on that. For example + let x = Just + in ....(f x)... + Here we want to specialise for `f (Just _)`, and we won't do so if we + don't allow [x :-> ConVal Just e] into the environment. Does this ever happen? + Yes: see #24282. -It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned -into a work-free value again, thus - a1 = expensive x_af7 - a'_shr = (a1, x_af7) -but that's more work, so until its shown to be important I'm going to -leave it for now. + (Yes, the Simplifier will ANF that let-binding, but SpecConstr can + make more: see (CV1) for an example.) +Wrinkle: + +(CV1) Why is work-free-ness important for (1)? In the example in (1) above, of `e` is + expensive, we do /not/ want to simplify + case x of { Just y -> ... } ==> let y = e in ... + because the x-binding still exists and we've now duplicated `e`. + + This seldom happens because let-bound constructor applications are ANF-ised, but + it can happen as a result of on-the-fly transformations in SpecConstr itself. + Here is #7865: + + let { a'_shr = + case xs_af8 of _ { + [] -> acc_af6; + : ds_dgt [Dmd=] ds_dgu [Dmd=] -> + (expensive x_af7, x_af7 + } } in + let { ds_sht = + case a'_shr of _ { (p'_afd, q'_afe) -> + TSpecConstr_DoubleInline.recursive + (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd) + } } in + + When processed knowing that xs_af8 was bound to a cons, we simplify to + a'_shr = (expensive x_af7, x_af7) + and we do NOT want to inline that at the occurrence of a'_shr in ds_sht. + (There are other occurrences of a'_shr.) No no no. + + It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned + into a work-free value again, thus + a1 = expensive x_af7 + a'_shr = (a1, x_af7) + but that's more work, so until its shown to be important I'm going to + leave it for now. + Note [Making SpecConstr keener] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this, in (perf/should_run/T9339) @@ -870,6 +912,12 @@ -- ^ The threshold at which a worker-wrapper transformation used as part of -- this pass will no longer happen, measured in the number of arguments. + , sc_max_forced_args :: !Int + -- ^ The threshold at which a worker-wrapper transformation used as part of + -- this pass will no longer happen even if a SPEC arg was used to force + -- specialization. Measured in the number of arguments. + -- See Note [Forcing specialisation] + , sc_debug :: !Bool -- ^ Whether to print debug information @@ -909,10 +957,6 @@ sc_vals :: ValueEnv, -- Domain is OutIds (*after* applying the substitution) -- Used even for top-level bindings (but not imported ones) - -- The range of the ValueEnv is *work-free* values - -- such as (\x. blah), or (Just v) - -- but NOT (Just (expensive v)) - -- See Note [Work-free values only in environment] sc_annotations :: UniqFM Name SpecConstrAnnotation } @@ -921,19 +965,30 @@ type HowBoundEnv = VarEnv HowBound -- Domain is OutVars --------------------- -type ValueEnv = IdEnv Value -- Domain is OutIds -data Value = ConVal AltCon [CoreArg] -- _Saturated_ constructors - -- The AltCon is never DEFAULT - | LambdaVal -- Inlinable lambdas or PAPs +type ValueEnv = IdEnv Value -- Domain is OutIds +data Value = ConVal -- Constructor application + Bool -- True <=> all args are work-free + -- See Note [ConVal work-free-ness] + AltCon -- Never DEFAULT + [CoreArg] -- Saturates the constructor + | LambdaVal -- Inlinable lambdas or PAPs + instance Outputable Value where - ppr (ConVal con args) = ppr con <+> interpp'SP args - ppr LambdaVal = text "" + ppr LambdaVal = text "" + 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" + --------------------- initScOpts :: DynFlags -> Module -> SpecConstrOpts initScOpts dflags this_mod = SpecConstrOpts { sc_max_args = maxWorkerArgs dflags, + sc_max_forced_args = maxForcedSpecArgs dflags, sc_debug = hasPprDebug dflags, sc_uf_opts = unfoldingOpts dflags, sc_module = this_mod, @@ -981,16 +1036,7 @@ scSubstId env v = lookupIdSubst (sc_subst env) v --- Solo is only defined in base starting from ghc-9.2 -#if !(MIN_VERSION_base(4, 16, 0)) -data Solo a = Solo a -#endif --- The Solo constructor was renamed to MkSolo in ghc 9.5 -#if __GLASGOW_HASKELL__ < 905 -pattern MkSolo :: a -> Solo a -pattern MkSolo a = Solo a -#endif -- The !subst ensures that we force the selection `(sc_subst env)`, which avoids -- retaining all of `env` when we only need `subst`. The `Solo` means that the @@ -1057,11 +1103,10 @@ (subst', bndr') = substBndr (sc_subst env) bndr extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv -extendValEnv env _ Nothing = env -extendValEnv env id (Just cv) - | valueIsWorkFree cv -- Don't duplicate work!! #7865 - = env { sc_vals = extendVarEnv (sc_vals env) id cv } -extendValEnv env _ _ = env +extendValEnv env id mb_val + = case mb_val of + Nothing -> env + Just cv -> env { sc_vals = extendVarEnv (sc_vals env) id cv } extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var]) -- When we encounter @@ -1075,7 +1120,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 @@ -1088,8 +1133,8 @@ cval = case con of DEFAULT -> Nothing - LitAlt {} -> Just (ConVal con []) - DataAlt {} -> Just (ConVal con vanilla_args) + LitAlt {} -> Just (ConVal True con []) + DataAlt {} -> Just (ConVal True con vanilla_args) where vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ varsToCoreExprs alt_bndrs @@ -1169,7 +1214,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. @@ -1254,13 +1299,12 @@ scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } combineUsages :: [ScUsage] -> ScUsage -combineUsages [] = nullUsage -combineUsages us = foldr1 combineUsage us +combineUsages = foldr1WithDefault nullUsage combineUsage -lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) +lookupOccs :: Traversable f => ScUsage -> f OutVar -> (ScUsage, f ArgOcc) lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, - [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs]) + fromMaybe NoOcc . lookupVarEnv sc_occs <$> bndrs) data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument | UnkOcc -- Used in some unknown way @@ -1275,7 +1319,7 @@ deadArgOcc NoOcc = True specialisableArgOcc :: ArgOcc -> Bool --- | Does this occurence represent one worth specializing for. +-- | Does this occurrence represent one worth specializing for. specialisableArgOcc UnkOcc = False specialisableArgOcc NoOcc = False specialisableArgOcc (ScrutOcc {}) = True @@ -1323,7 +1367,7 @@ combineOcc UnkOcc UnkOcc = UnkOcc combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] -combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys +combineOccs xs ys = zipWithEqual combineOcc xs ys setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage -- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee @@ -1348,29 +1392,29 @@ -} scBind :: TopLevelFlag -> ScEnv -> InBind - -> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the binding - -> UniqSM (ScUsage, [OutBind], a) + -> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning])) -- Specialise the scope of the binding + -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning]) scBind top_lvl env (NonRec bndr rhs) do_body | isTyVar bndr -- Type-lets may be created by doBeta - = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs) - ; return (final_usage, [], body') } + = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs) + ; return (final_usage, [], body', warnings) } | not (isTopLevel top_lvl) -- Nested non-recursive value binding -- See Note [Specialising local let bindings] = do { let (body_env, bndr') = extendBndr env bndr -- Not necessary at top level; but here we are nested - ; rhs_info <- scRecRhs env (bndr',rhs) + ; (rhs_info, rhs_ws) <- scRecRhs env (bndr',rhs) ; let body_env2 = extendHowBound body_env [bndr'] RecFun rhs' = ri_new_rhs rhs_info body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - ; (body_usg, body') <- do_body body_env3 + ; (body_usg, body', warnings_body) <- do_body body_env3 -- Now make specialised copies of the binding, -- based on calls in body_usg - ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info + ; (spec_usg, specs, warnings_bnd) <- specNonRec env (scu_calls body_usg) rhs_info -- NB: For non-recursive bindings we inherit sc_force flag from -- the parent function (see Note [Forcing specialisation]) @@ -1379,7 +1423,7 @@ bind_usage = (body_usg `delCallsFor` [bndr']) `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg] - ; return (bind_usage, spec_bnds, body') + ; return (bind_usage, spec_bnds, body', mconcat [warnings_bnd, warnings_body, rhs_ws]) } | otherwise -- Top-level, non-recursive value binding @@ -1391,49 +1435,50 @@ -- -- I tried always specialising non-recursive top-level bindings too, -- but found some regressions (see !8135). So I backed off. - = do { (rhs_usage, rhs') <- scExpr env rhs + = do { (rhs_usage, rhs', ws_rhs) <- scExpr env rhs -- At top level, we've already put all binders into scope; see initScEnv -- Hence no need to call `extendBndr`. But we still want to -- extend the `ValueEnv` to record the value of this binder. ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs') - ; (body_usage, body') <- do_body body_env + ; (body_usage, body', body_warnings) <- do_body body_env - ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') } + ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) } scBind top_lvl env (Rec prs) do_body | isTopLevel top_lvl , Just threshold <- sc_size (sc_opts env) - , not force_spec + , not force_spec -- See Note [Forcing specialisation], point (FS1) , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss) = -- Do no specialisation if the RHSs are too big -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor -- why it only applies at top level. But that's the way it has been -- for a while. See #21456. - do { (body_usg, body') <- do_body rhs_env2 - ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss + do { (body_usg, body', warnings_body) <- do_body rhs_env2 + ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg) `delCallsFor` bndrs' bind' = Rec (bndrs' `zip` rhss') - ; return (all_usg, [bind'], body') } + ; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) } | otherwise - = do { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; (body_usg, body') <- do_body rhs_env2 + = do { (rhs_infos, rhs_wss) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; let rhs_ws = mconcat rhs_wss + ; (body_usg, body', warnings_body) <- do_body rhs_env2 - ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec) - (scu_calls body_usg) rhs_infos + ; (spec_usg, specs, spec_ws) <- specRec (scForce rhs_env2 force_spec) + (scu_calls body_usg) rhs_infos -- Do not unconditionally generate specialisations from rhs_usgs -- Instead use them only if we find an unspecialised call -- See Note [Seeding recursive groups] ; let all_usg = (spec_usg `combineUsage` body_usg) -- Note [spec_usg includes rhs_usg] `delCallsFor` bndrs' - bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs)) + bind' = Rec (concat (zipWithEqual ruleInfoBinds rhs_infos specs)) -- zipWithEqual: length of returned [SpecInfo] -- should be the same as incoming [RhsInfo] - ; return (all_usg, [bind'], body') } + ; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) } where (bndrs,rhss) = unzip prs force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation] @@ -1461,56 +1506,63 @@ harmful. I'm not sure. -} +withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings) +withWarnings ws (use,expr,ws2) = (use,expr,ws ++ ws2) + ------------------------ -scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) +scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings) -- The unique supply is needed when we invent -- a new name for the specialised function and its args scExpr env e = scExpr' env e scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (mkVarUsage env v' [], Var v') + Var v' -> return (mkVarUsage env v' [], Var v', []) e' -> scExpr (zapScSubst env) e' scExpr' env (Type t) = let !(MkSolo ty') = scSubstTy env t - in return (nullUsage, Type ty') -scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) -scExpr' _ e@(Lit {}) = return (nullUsage, e) -scExpr' env (Tick t e) = do (usg, e') <- scExpr env e - return (usg, Tick (scTickish env t) e') -scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, mkCast e' (scSubstCo env co)) + in return (nullUsage, Type ty', []) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c), []) +scExpr' _ e@(Lit {}) = return (nullUsage, e, []) +scExpr' env (Tick t e) = do (usg, e', ws) <- scExpr env e + return (usg, Tick (scTickish env t) e', ws) +scExpr' env (Cast e co) = do (usg, e', ws) <- scExpr env e + return (usg, mkCast e' (scSubstCo env co), ws) -- Important to use mkCast here -- See Note [SpecConstr call patterns] scExpr' env e@(App _ _) = scApp env (collectArgs e) scExpr' env (Lam b e) = do let (env', b') = extendBndr env b - (usg, e') <- scExpr env' e - return (usg, Lam b' e') + (usg, e', ws) <- scExpr env' e + return (usg, Lam b' e', ws) scExpr' env (Let bind body) - = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $ + = do { (final_usage, binds', body', ws) <- scBind NotTopLevel env bind $ (\env -> scExpr env body) - ; return (final_usage, mkLets binds' body') } + ; return (final_usage, mkLets binds' body', ws) } scExpr' env (Case scrut b ty alts) - = do { (scrut_usg, scrut') <- scExpr env scrut + = do { (scrut_usg, scrut', ws) <- scExpr env scrut ; case isValue (sc_vals env) scrut' of - Just (ConVal con args) -> sc_con_app con args scrut' - _other -> sc_vanilla scrut_usg scrut' + Just (ConVal args_are_work_free con args) + | args_are_work_free -> sc_con_app con args scrut' ws + -- Don't duplicate work!! #7865 + -- See Note [ConVal work-free-ness] (1) + _other -> sc_vanilla scrut_usg scrut' ws } where - sc_con_app con args scrut' -- Known constructor; simplify + sc_con_app con args scrut' ws -- Known constructor; simplify = do { let Alt _ bs rhs = findAlt con alts `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr") alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) - ; scExpr alt_env' rhs } + ; (use',expr',ws_new) <- scExpr alt_env' rhs + ; return (use',expr',ws ++ ws_new) } - sc_vanilla scrut_usg scrut' -- Normal case + sc_vanilla scrut_usg scrut' ws -- Normal case = do { let (alt_env,b') = extendBndrWith RecArg env b -- Record RecArg for the components - ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts + ; (alt_usgs, alt_occs, alts', ws_alts) <- mapAndUnzip4M (sc_alt alt_env scrut' b') alts ; let scrut_occ = foldr combineOcc NoOcc alt_occs scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ @@ -1520,21 +1572,21 @@ ; let !(MkSolo ty') = scSubstTy env ty ; return (foldr combineUsage scrut_usg' alt_usgs, - Case scrut' b' ty' alts') } + Case scrut' b' ty' alts', ws ++ concat ws_alts) } single_alt = isSingleton alts sc_alt env scrut' b' (Alt con bs rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 - ; (usg, rhs') <- scExpr env2 rhs - ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) + ; (usg, rhs', ws) <- scExpr env2 rhs + ; let (usg', b_occ:|arg_occs) = lookupOccs usg (b':|bs2) scrut_occ = case con of DataAlt dc -- See Note [Do not specialise evals] | not (single_alt && all deadArgOcc arg_occs) -> ScrutOcc (unitUFM dc arg_occs) _ -> UnkOcc - ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } + ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) } -- | Substitute the free variables captured by a breakpoint. @@ -1583,19 +1635,20 @@ still worth specialising on x. Hence the /single-alternative/ guard. -} -scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) +scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings) scApp env (Var fn, args) -- Function is a variable = assert (not (null args)) $ do { args_w_usgs <- mapM (scExpr env) args - ; let (arg_usgs, args') = unzip args_w_usgs + ; let (arg_usgs, args', arg_ws) = unzip3 args_w_usgs arg_usg = combineUsages arg_usgs + arg_w = concat arg_ws ; case scSubstId env fn of - fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') + fn'@(Lam {}) -> withWarnings arg_w <$> scExpr (zapScSubst env) (doBeta fn' args') -- Do beta-reduction and try again Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args', - mkApps (Var fn') args') + mkApps (Var fn') args', arg_w ) where -- arg_usg': see Note [Specialising on dictionaries] arg_usg' | Just cls <- isClassOpId_maybe fn' @@ -1604,7 +1657,7 @@ | otherwise = arg_usg - other_fn' -> return (arg_usg, mkApps other_fn' args') } + other_fn' -> return (arg_usg, mkApps other_fn' args', arg_w) } -- NB: doing this ignores any usage info from the substituted -- function, but I don't think that matters. If it does -- we can fix it. @@ -1618,9 +1671,9 @@ -- which it may, we can get -- (let f = ...f... in f) arg1 arg2 scApp env (other_fn, args) - = do { (fn_usg, fn') <- scExpr env other_fn - ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args - ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } + = do { (fn_usg, fn', fn_ws) <- scExpr env other_fn + ; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args + ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) } ---------------------- mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage @@ -1636,16 +1689,16 @@ | otherwise = evalScrutOcc ---------------------- -scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo +scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecFailWarnings) scRecRhs env (bndr,rhs) = do { let (arg_bndrs,body) = collectBinders rhs (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs - ; (body_usg, body') <- scExpr body_env body + ; (body_usg, body', body_ws) <- scExpr body_env body ; let (rhs_usg, arg_occs) = lookupOccs body_usg arg_bndrs' ; return (RI { ri_rhs_usg = rhs_usg , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body' , ri_lam_bndrs = arg_bndrs, ri_lam_body = body - , ri_arg_occs = arg_occs }) } + , ri_arg_occs = arg_occs }, body_ws) } -- The arg_occs says how the visible, -- lambda-bound binders of the RHS are used -- (including the TyVar binders) @@ -1714,7 +1767,7 @@ specNonRec :: ScEnv -> CallEnv -- Calls in body -> RhsInfo -- Structure info usage info for un-specialised RHS - -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) + -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]) -- Usage from RHSs (specialised and not) -- plus details of specialisations specNonRec env body_calls rhs_info @@ -1724,11 +1777,12 @@ specRec :: ScEnv -> CallEnv -- Calls in body -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs - -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) + -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings) + -- Usage from all RHSs (specialised and not) -- plus details of specialisations specRec env body_calls rhs_infos - = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) + = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) [] -- body_calls: see Note [Seeding recursive groups] -- NB: 'go' always calls 'specialise' once, which in turn unleashes -- si_mb_unspec if there are any boring calls in body_calls, @@ -1743,23 +1797,25 @@ -- Two accumulating parameters: -> ScUsage -- Usage from earlier specialisations -> [SpecInfo] -- Details of specialisations so far - -> UniqSM (ScUsage, [SpecInfo]) - go n_iter seed_calls usg_so_far spec_infos + -> SpecFailWarnings -- Warnings so far + -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings) + go n_iter seed_calls usg_so_far spec_infos ws_so_far = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos) -- , text "iteration" <+> int n_iter -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos) -- ]) $ do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos - ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg + + ; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg extra_usg = combineUsages extra_usg_s all_usg = usg_so_far `combineUsage` extra_usg new_calls = scu_calls extra_usg - ; go_again n_iter new_calls all_usg all_spec_infos } + ; go_again n_iter new_calls all_usg all_spec_infos (ws_so_far ++ concat extra_ws) } -- go_again deals with termination - go_again n_iter seed_calls usg_so_far spec_infos + go_again n_iter seed_calls usg_so_far spec_infos ws_so_far | isEmptyVarEnv seed_calls - = return (usg_so_far, spec_infos) + = return (usg_so_far, spec_infos, ws_so_far) -- Limit recursive specialisation -- See Note [Limit recursive specialisation] @@ -1767,15 +1823,16 @@ , sc_force env || isNothing (sc_count opts) -- If both of these are false, the sc_count -- threshold will prevent non-termination + -- See Note [Forcing specialisation], point (FS4) and (FS2) , any ((> the_limit) . si_n_specs) spec_infos = -- Give up on specialisation, but don't forget to include the rhs_usg -- for the unspecialised function, since it may now be called -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos) - in return (usg_so_far `combineUsage` rhs_usgs, spec_infos) + in return (usg_so_far `combineUsage` rhs_usgs, spec_infos, ws_so_far) | otherwise - = go (n_iter + 1) seed_calls usg_so_far spec_infos + = go (n_iter + 1) seed_calls usg_so_far spec_infos ws_so_far -- See Note [Limit recursive specialisation] the_limit = case sc_count opts of @@ -1788,7 +1845,7 @@ -> CallEnv -- Info on newly-discovered calls to this function -> RhsInfo -> SpecInfo -- Original RHS plus patterns dealt with - -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage + -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning]) -- New specialised versions and their usage -- See Note [spec_usg includes rhs_usg] @@ -1806,7 +1863,7 @@ | isDeadEndId fn -- Note [Do not specialise diverging functions] -- /and/ do not generate specialisation seeds from its RHS = -- pprTrace "specialise bot" (ppr fn) $ - return (nullUsage, spec_info) + return (nullUsage, spec_info, []) | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] @@ -1817,7 +1874,7 @@ , not (null arg_bndrs) -- Only specialise functions , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ - do { (boring_call, pats_discarded, new_pats) + do { (boring_call, pats_discarded, new_pats, warnings) <- callsToNewPats env fn spec_info arg_occs all_calls ; let n_pats = length new_pats @@ -1832,7 +1889,7 @@ -- , text "new_pats" <+> ppr new_pats]) ; let spec_env = decreaseSpecCount env n_pats - ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body) + ; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body) (new_pats `zip` [spec_count..]) -- See Note [Specialise original body] @@ -1856,15 +1913,16 @@ ; return (new_usg, SI { si_specs = new_specs ++ specs , si_n_specs = spec_count + n_pats - , si_mb_unspec = mb_unspec' }) } + , si_mb_unspec = mb_unspec' } + ,warnings ++ concat new_wss) } | otherwise -- No calls, inactive, or not a function -- Behave as if there was a single, boring call = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $ case mb_unspec of -- Behave as if there was a single, boring call - Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) + Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }, []) -- See Note [spec_usg includes rhs_usg] - Nothing -> return (nullUsage, spec_info) + Nothing -> return (nullUsage, spec_info, []) --------------------- @@ -1873,7 +1931,7 @@ -> [InVar] -- Lambda-binders of RHS; should match patterns -> InExpr -- Body of the original function -> (CallPat, Int) - -> UniqSM (ScUsage, OneSpec) -- Rule and binding + -> UniqSM (ScUsage, OneSpec, SpecFailWarnings) -- Rule and binding, warnings if any -- spec_one creates a specialised copy of the function, together -- with a rule for using it. I'm very proud of how short this @@ -1925,7 +1983,7 @@ -- Specialise the body -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env) - ; (spec_usg, spec_body) <- scExpr body_env body + ; (spec_usg, spec_body, body_warnings) <- scExpr body_env body -- And build the results ; (qvars', pats') <- generaliseDictPats qvars pats @@ -1934,8 +1992,8 @@ = calcSpecInfo fn arg_bndrs call_pat extra_bndrs spec_arity = count isId spec_lam_args - spec_join_arity | isJoinId fn = Just (length spec_call_args) - | otherwise = Nothing + spec_join_arity | isJoinId fn = JoinPoint (length spec_call_args) + | otherwise = NotJoinPoint spec_id = asWorkerLikeId $ mkLocalId spec_name ManyTy (mkLamTypes spec_lam_args spec_body_ty) @@ -1946,6 +2004,7 @@ `asJoinId_maybe` spec_join_arity -- Conditionally use result of new worker-wrapper transform + -- mkSeqs: see Note [SpecConstr and strict fields] spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body) rule_rhs = mkVarApps (Var spec_id) spec_call_args inline_act = idInlineActivation fn @@ -1973,7 +2032,7 @@ -- ] ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id - , os_rhs = spec_rhs }) } + , os_rhs = spec_rhs }, body_warnings) } generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats @@ -1996,8 +2055,8 @@ | otherwise = return (extra_qvs, pat) --- See Note [SpecConstr and strict fields] mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr +-- See Note [SpecConstr and strict fields] mkSeqs seqees res_ty rhs = foldr addEval rhs seqees where @@ -2005,7 +2064,11 @@ addEval arg_id rhs -- Argument representing strict field and it's worth passing via cbv | shouldStrictifyIdForCbv arg_id - = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs]) + = Case (Var arg_id) + (localiseId arg_id) -- See (SCF1) in Note [SpecConstr and strict fields] + res_ty + ([Alt DEFAULT [] rhs]) + | otherwise = rhs @@ -2243,7 +2306,7 @@ * The list of argument patterns, cp_args, is no longer than the visible lambdas of the binding, ri_arg_occs. This is done via - the zipWithM in callToPats. + the zipWithM in callToPat. * The list of argument patterns can certainly be shorter than the lambdas in the function definition (under-saturated). For example @@ -2253,7 +2316,7 @@ * In fact we deliberately shrink the list of argument patterns, cp_args, by trimming off all the boring ones at the end (see - `dropWhileEnd is_boring` in callToPats). Since the RULE only + `dropWhileEnd is_boring` in callToPat). Since the RULE only applies when it is saturated, this shrinking makes the RULE more applicable. But it does mean that the argument patterns do not necessarily saturate the lambdas of the function. @@ -2296,68 +2359,55 @@ Consider (#14270) a call like let f = e - in ... f (K @(a |> co)) ... + in ... f (K @(a |> cv)) ... -where 'co' is a coercion variable not in scope at f's definition site. +where 'cv' is a coercion variable not in scope at f's definition site. If we aren't careful we'll get - let $sf a co = e (K @(a |> co)) - RULE "SC:f" forall a co. f (K @(a |> co)) = $sf a co + let $sf a cv = e (K @(a |> cv)) + RULE "SC:f" forall a cv. f (K @(a |> cv)) = $sf a co f = e in ... -But alas, when we match the call we won't bind 'co', because type-matching -(for good reasons) discards casts). - -I don't know how to solve this, so for now I'm just discarding any -call patterns that - * Mentions a coercion variable in a type argument - * That is not in scope at the binding of the function - -I think this is very rare. +But alas, when we match the call we may fail to bind 'co', because the rule +matcher in GHC.Core.Rules cannot reliably bind coercion variables that appear +in casts (see Note [Casts in the template] in GHC.Core.Rules). -It is important (e.g. #14936) that this /only/ applies to -coercions mentioned in casts. We don't want to be discombobulated -by casts in terms! For example, consider - f ((e1,e2) |> sym co) -where, say, - f :: Foo -> blah - co :: Foo ~R (Int,Int) +This seems intractable (see #23209). So: -Here we definitely do want to specialise for that pair! We do not -match on the structure of the coercion; instead we just match on a -coercion variable, so the RULE looks like +* Key point: we /never/ quantify over coercion variables in a SpecConstr rule. + If we would need to quantify over a coercion variable, we just discard the + call pattern. See the test for `bad_covars` in callToPat. - forall (x::Int, y::Int, co :: (Int,Int) ~R Foo) - f ((x,y) |> co) = $sf x y co +* However (#14936) we /do/ still allow casts in call patterns. For example + f ((e1,e2) |> sym co) + where, say, + f :: Foo -> blah -- Foo is a newtype + f = f_rhs + co :: Foo ~R (Int,Int) + We want to specialise on that pair! -Often the body of f looks like - f arg = ...(case arg |> co' of - (x,y) -> blah)... +So for our function f, we might generate + RULE forall x y. f ((x,y) |> co) = $sf x y + $sf x y = f_rhs ((x,y) |> co) -so that the specialised f will turn into - $sf x y co = let arg = (x,y) |> co - in ...(case arg>| co' of - (x,y) -> blah).... +This works provided the free vars of `co` are either in-scope at the +definition of `f`, or quantified. For the latter, suppose `f` was polymorphic: -which will simplify to not use 'co' at all. But we can't guarantee -that co will end up unused, so we still pass it. Absence analysis -may remove it later. + f2 :: Foo2 a -> blah -- Foo is a newtype + f2 = f2_rhs + co2 :: Foo a ~R (a,a) -Note that this /also/ discards the call pattern if we have a cast in a -/term/, although in fact Rules.match does make a very flaky and -fragile attempt to match coercions. e.g. a call like - f (Maybe Age) (Nothing |> co) blah - where co :: Maybe Int ~ Maybe Age -will be discarded. It's extremely fragile to match on the form of a -coercion, so I think it's better just not to try. A more complicated -alternative would be to discard calls that mention coercion variables -only in kind-casts, but I'm doing the simple thing for now. +Then it's fine for `co2` to mention `a`. We'll get + RULE forall a (x::a) (y::a). f2 @a ((x,y) |> co2) = $sf2 a x y + $sf2 @a x y = f2_rhs ((x,y) |> co2) -} data CallPat = CP { cp_qvars :: [Var] -- Quantified variables , cp_args :: [CoreExpr] -- Arguments , cp_strict_args :: [Var] } -- Arguments we want to pass unlifted even if they are boxed + -- See Note [SpecConstr and strict fields] + -- See Note [SpecConstr call patterns] instance Outputable CallPat where @@ -2366,36 +2416,63 @@ , text "cp_args =" <+> ppr args , text "cp_strict_args = " <> ppr strict ]) +newtype SpecFailWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name } + +type SpecFailWarnings = [SpecFailWarning] + +instance Outputable SpecFailWarning where + ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name + +combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings +combineSpecWarning = (++) + +data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name + callsToNewPats :: ScEnv -> Id -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM ( Bool -- At least one boring call , Bool -- Patterns were discarded - , [CallPat] ) -- Patterns to specialise + , [CallPat] -- Patterns to specialise + , [SpecFailWarning] -- Things that didn't specialise we want to warn the user about) + ) -- Result has no duplicate patterns, -- nor ones mentioned in si_specs (hence "new" patterns) -- Bool indicates that there was at least one boring pattern -- The "New" in the name means "patterns that are not already covered -- by an existing specialisation" callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls - = do { mb_pats <- mapM (callToPats env bndr_occs) calls + = do { mb_pats <- mapM (callToPat env bndr_occs) calls ; let have_boring_call = any isNothing mb_pats good_pats :: [CallPat] good_pats = catMaybes mb_pats + in_scope = substInScopeSet (sc_subst env) + -- Remove patterns we have already done new_pats = filterOut is_done good_pats - is_done p = any (samePat p . os_pat) done_specs + is_done p = any is_better done_specs + where + is_better done = betterPat in_scope (os_pat done) p -- Remove duplicates - non_dups = nubBy samePat new_pats + non_dups = subsumePats in_scope new_pats -- Remove ones that have too many worker variables - small_pats = filterOut too_big non_dups - too_big (CP { cp_qvars = vars, cp_args = args }) - = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars) + (small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups + + -- too_many_worker_args :: CallPat -> Either SpecFailWarning Bool + too_many_worker_args (CP { cp_qvars = vars, cp_args = args }) + | sc_force env + -- See (FS5) of Note [Forcing specialisation] + = if (isWorkerSmallEnough (sc_max_forced_args $ sc_opts env) (valArgCount args) vars) + then WorkerSmallEnough + else WorkerTooLargeForced (idName fn) + | (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars) + = WorkerSmallEnough + | otherwise = WorkerTooLarge -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils @@ -2404,35 +2481,47 @@ (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats -- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , text "good_pats:" <+> ppr good_pats +-- , text "new_pats:" <+> ppr new_pats +-- , text "non_dups:" <+> ppr non_dups +-- , text "small_pats:" <+> ppr small_pats -- , text "done_specs:" <+> ppr (map os_pat done_specs) -- , text "trimmed_pats:" <+> ppr trimmed_pats ]) - ; return (have_boring_call, pats_were_discarded, trimmed_pats) } + ; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) } -- If any of the calls does not give rise to a specialisation, either -- because it is boring, or because there are too many specialisations, -- return a flag to say so, so that we know to keep the original function. + where + partitionByWorkerSize worker_size pats = go pats [] [] + where + go [] small warnings = (small, warnings) + go (p:ps) small warnings = + case worker_size p of + WorkerSmallEnough -> go ps (p:small) warnings + WorkerTooLarge -> go ps small warnings + WorkerTooLargeForced name -> go ps small (SpecFailForcedArgCount name : warnings) trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat]) -- True <=> some patterns were discarded -- See Note [Choosing patterns] trim_pats env fn (SI { si_n_specs = done_spec_count }) pats - | sc_force env - || isNothing mb_scc - || n_remaining >= n_pats - = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) - (False, pats) -- No need to trim + | False <- sc_force env + , Just max_specs <- mb_scc + , let n_remaining = max_specs - done_spec_count + , n_remaining < n_pats + = emit_trace max_specs n_remaining $ -- Need to trim, so keep the best ones + (True, take n_remaining sorted_pats) | otherwise - = emit_trace $ -- Need to trim, so keep the best ones - (True, take n_remaining sorted_pats) + = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) + (False, pats) -- No need to trim where n_pats = length pats spec_count' = n_pats + done_spec_count - n_remaining = max_specs - done_spec_count mb_scc = sc_count $ sc_opts env - Just max_specs = mb_scc sorted_pats = map fst $ sortBy (comparing snd) $ @@ -2455,41 +2544,44 @@ n_cons (Lit {}) = 1 n_cons _ = 0 - emit_trace result + emit_trace max_specs n_remaining result | debugIsOn || sc_debug (sc_opts env) -- Suppress this scary message for ordinary users! #5125 = pprTrace "SpecConstr" msg result | otherwise = result - msg = vcat [ sep [ text "Function" <+> quotes (ppr fn) - , nest 2 (text "has" <+> - speakNOf spec_count' (text "call pattern") <> comma <+> - text "but the limit is" <+> int max_specs) ] - , text "Use -fspec-constr-count=n to set the bound" - , text "done_spec_count =" <+> int done_spec_count - , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats - , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] - + where + msg = vcat + [ sep + [ text "Function" <+> quotes (ppr fn) + , nest 2 + ( text "has" <+> + speakNOf spec_count' (text "call pattern") <> comma <+> + text "but the limit is" <+> int max_specs ) ] + , text "Use -fspec-constr-count=n to set the bound" + , text "done_spec_count =" <+> int done_spec_count + , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats + , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ] -callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) +callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) -- The [Var] is the variables to quantify over in the rule -- Type variables come first, since they may scope -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs call@(Call fn args con_env) - = do { let in_scope = getSubstInScope (sc_subst env) +callToPat env bndr_occs call@(Call fn args con_env) + = do { let in_scope = substInScopeSet (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 @@ -2507,32 +2599,25 @@ -- See Note [Free type variables of the qvar types] -- See Note [Shadowing in SpecConstr] at the top - (ktvs, ids) = partition isTyVar qvars - qvars' = scopedSort ktvs ++ map sanitise ids + (qktvs, qids) = partition isTyVar qvars + qvars' = scopedSort qktvs ++ map sanitise qids -- Order into kind variables, type variables, term variables -- The kind of a type variable may mention a kind variable -- and the type of a term variable may mention a type variable - sanitise id = updateIdTypeAndMult expandTypeSynonyms id + sanitise id = updateIdTypeAndMult expandTypeSynonyms id -- See Note [Free type variables of the qvar types] - -- Check for bad coercion variables: see Note [SpecConstr and casts] - ; let bad_covars :: CoVarSet - bad_covars = mapUnionVarSet get_bad_covars pats - get_bad_covars :: CoreArg -> CoVarSet - get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty) - get_bad_covars _ = emptyVarSet - bad_covar v = isId v && not (is_in_scope v) - - ; warnPprTrace (not (isEmptyVarSet bad_covars)) + ; let bad_covars = filter isCoVar qids + ; warnPprTrace (not (null bad_covars)) "SpecConstr: bad covars" (ppr bad_covars $$ ppr call) $ - if interesting && isEmptyVarSet bad_covars + if interesting && null bad_covars then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats , cp_strict_args = concat cbv_ids } --- ; pprTraceM "callToPatsOut" $ +-- ; pprTraceM "callToPatOut" $ -- vcat [ text "fn:" <+> ppr fn -- , text "args:" <+> ppr args -- , text "bndr_occs:" <+> ppr bndr_occs @@ -2600,44 +2685,22 @@ -- Here we can specialise for f (v,w) -- because the rule-matcher will look through the let. -{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" -argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ - | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" - = argToPat env in_scope val_env rhs arg_occ --} - + -- Casts: see Note [SpecConstr and casts] argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str | not (ignoreType env ty2) = do { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str ; if not interesting then wildCardPat ty2 arg_str - else do - { -- Make a wild-card pattern for the coercion - uniq <- getUniqueM - ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoercionType Representational ty1 ty2) - ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } } - where - Pair ty1 ty2 = coercionKind co - - - -{- Disabling lambda specialisation for now - It's fragile, and the spec_loop can be infinite -argToPat in_scope val_env arg arg_occ - | is_value_lam arg - = return (True, arg) + else + return (interesting, Cast arg' co, strict_args) } where - is_value_lam (Lam v e) -- Spot a value lambda, even if - | isId v = True -- it is inside a type lambda - | otherwise = is_value_lam e - is_value_lam other = False --} + ty2 = coercionRKind co -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs argToPat1 env in_scope val_env arg arg_occ _arg_str - | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + | Just (ConVal _wf (DataAlt dc) args) <- isValue val_env arg + -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2) , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args @@ -2687,6 +2750,7 @@ -- In that case it counts as "interesting" argToPat1 env in_scope val_env (Var v) arg_occ arg_str | sc_force env || specialisableArgOcc arg_occ -- (a) + -- See Note [Forcing specialisation], point (FS3) , is_value -- (b) -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] -- So sc_keen focused just on f (I# x), where we have freshly-allocated @@ -2720,6 +2784,25 @@ -- f x y = letrec g z = ... in g (x,y) -- We don't want to specialise for that *particular* x,y + +{- Disabled; see Note [Matching cases] in "GHC.Core.Rules" +argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ + | exprOkForSpeculation scrut -- See Note [Matching cases] in "GHC.Core.Rules" + = argToPat env in_scope val_env rhs arg_occ +-} + +{- Disabling lambda specialisation for now + It's fragile, and the spec_loop can be infinite +argToPat in_scope val_env arg arg_occ + | is_value_lam arg + = return (True, arg) + where + is_value_lam (Lam v e) -- Spot a value lambda, even if + | isId v = True -- it is inside a type lambda + | otherwise = is_value_lam e + is_value_lam other = False +-} + -- The default case: make a wild-card -- We use this for coercions too argToPat1 _env _in_scope _val_env arg _arg_occ arg_str @@ -2735,7 +2818,7 @@ isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit) | litIsLifted lit = Nothing - | otherwise = Just (ConVal (LitAlt lit) []) + | otherwise = Just (ConVal True (LitAlt lit) []) isValue env (Var v) | Just cval <- lookupVarEnv env v @@ -2743,8 +2826,11 @@ -- but that doesn't take account of which branch of a -- case we are in, which is the whole point - | not (isLocalId v) && isCheapUnfolding unf - = isValue env (unfoldingTemplate unf) + | not (isLocalId v) + , isCheapUnfolding unf + , Just rhs <- maybeUnfoldingTemplate unf -- Succeds if isCheapUnfolding does + = isValue env rhs -- Can't use isEvaldUnfolding because + -- we want to consult the `env` where unf = idUnfolding v -- However we do want to consult the unfolding @@ -2766,7 +2852,7 @@ DataConWorkId con | args `lengthAtLeast` dataConRepArity con -- Check saturated; might be > because the -- arity excludes type args - -> Just (ConVal (DataAlt con) args) + -> Just (ConVal (all exprIsWorkFree args) (DataAlt con) args) DFunId {} -> Just LambdaVal -- DFunId: see Note [Specialising on dictionaries] @@ -2779,44 +2865,82 @@ isValue _env _expr = Nothing -valueIsWorkFree :: Value -> Bool -valueIsWorkFree LambdaVal = True -valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args +betterPat :: InScopeSet -> CallPat -> CallPat -> Bool +-- pat1 f @a (Just @a (x::a)) +-- is better than +-- pat2 f @Int (Just @Int (x::Int)) +-- That is, we can instantiate pat1 to get pat2, using only type instantiate +-- See Note [Pattern duplicate elimination] +betterPat is (CP { cp_qvars = vs1, cp_args = as1 }) + (CP { cp_qvars = vs2, cp_args = as2 }) + | equalLength as1 as2 + = case matchExprs ise vs1 as1 as2 of + Just (_, ms) -> all exprIsTrivial ms + Nothing -> False -samePat :: CallPat -> CallPat -> Bool -samePat (CP { cp_qvars = vs1, cp_args = as1 }) - (CP { cp_qvars = vs2, cp_args = as2 }) - = all2 same as1 as2 + | otherwise -- We must handle patterns of unequal length separately (#24282) + = False -- For the pattern with more args, the last arg is "interesting" + -- but the corresponding one on the other is "not interesting"; + -- So we can't get from one to the other with only exprIsTrivial + -- instantiation. Example nofib/spectral/ansi, function `loop`: + -- P1: loop (I# x) (a : b) + -- P2: loop (I# y) -- Pattern eta-reduced + -- Neither is better than the other, in the sense of betterPat where - -- If the args are the same, their strictness marks will be too so we don't compare those. - same (Var v1) (Var v2) - | v1 `elem` vs1 = v2 `elem` vs2 - | v2 `elem` vs2 = False - | otherwise = v1 == v2 + ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding) - same (Lit l1) (Lit l2) = l1==l2 - same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 +subsumePats :: InScopeSet -> [CallPat] -> [CallPat] +-- Remove any patterns subsumed by others +-- See Note [Pattern duplicate elimination] +-- Other than deleting subsumed patterns, this operation is a no-op; +-- in particular it does not reverse the input. It should not matter +-- but in #24282 it did; doing it this way keeps the existing behaviour. +subsumePats is pats = foldl add [] pats + where + add :: [CallPat] -> CallPat -> [CallPat] + add [] ci = [ci] + add (ci1:cis) ci2 | betterPat is ci1 ci2 = ci1 : cis + | betterPat is ci2 ci1 = ci2 : cis + | otherwise = ci1 : add cis ci2 - same (Type {}) (Type {}) = True -- Note [Ignore type differences] - same (Coercion {}) (Coercion {}) = True - same (Tick _ e1) e2 = same e1 e2 -- Ignore casts and notes - same (Cast e1 _) e2 = same e1 e2 - same e1 (Tick _ e2) = same e1 e2 - same e1 (Cast e2 _) = same e1 e2 +{- +Note [Pattern duplicate elimination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider f :: (a,a) -> blah, and two calls + f @Int (x,y) + f @Bool (p,q) - same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $ - False -- Let, lambda, case should not occur - bad (Case {}) = True - bad (Let {}) = True - bad (Lam {}) = True - bad _other = False +The danger is that we'll generate two *essentially identical* specialisations, +both for pairs, but with different types instantiating `a` (see #24229). -{- -Note [Ignore type differences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not want to generate specialisations where the call patterns -differ only in their type arguments! Not only is it utterly useless, -but it also means that (with polymorphic recursion) we can generate -an infinite number of specialisations. Example is Data.Sequence.adjustTree, -I think. +But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises +that argument. So SpecConstr should never need to specialise f's polymorphic +type arguments. Even with only one of these calls we should be able to +generalise to the `CallPat` + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + +Doing so isn't trivial, though. + +For now we content ourselves with a simpler plan: eliminate a call pattern +if another pattern subsumes it; this is done by `subsumePats`. +For example here are two patterns + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)] + +The first can be instantiated to the second, /by instantiating types only/. +This subsumption relationship is checked by `betterPat`. Note that if +we have + + cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)] + cp_qvars = [], cp_args = [@Bool (True,False)] + +the first does *not* subsume the second; the second is more specific. + +In our initial example with `f @Int` and `f @Bool` neither subsumes the other, +so we will get two essentially-identical specialisations. Boo. We rely on our +crude throttling mechanisms to stop this getting out of control -- with +polymorphic recursion we can generate an infinite number of specialisations. +Example is Data.Sequence.adjustTree, I think. -} diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE MultiWayIf #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -16,9 +16,9 @@ import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) -import GHC.Core.Multiplicity -import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe ) import GHC.Core.Predicate +import GHC.Core.Class( classMethods ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core @@ -28,16 +28,14 @@ import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable - , mkCast, exprType + , mkCast, exprType, exprIsHNF , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs -import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) --- import GHC.Core.Ppr( pprIds ) import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( maybeToList, isJust ) +import GHC.Data.Maybe ( isJust ) import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -48,7 +46,7 @@ import GHC.Types.Name import GHC.Types.Tickish import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar ) +import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id @@ -58,9 +56,9 @@ import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc +import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain( assert ) import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts @@ -69,6 +67,8 @@ import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) {- ************************************************************************ @@ -1203,14 +1203,21 @@ ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1244,16 +1251,18 @@ -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args - | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f) + | let rules = getRules (se_rules env) f + , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 - , (fun, args) <- collectArgs expr' - = fireRewriteRules env fun (args++rest_args) + , (fun', args') <- collectArgs expr' + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1281,7 +1290,8 @@ , UsageDetails) specCase env scrut' case_bndr [Alt con args rhs] | -- See Note [Floating dictionaries out of cases] - interestingDict scrut' (idType case_bndr) + isDictTy (idType case_bndr) + , interestingDict env scrut' , not (isDeadBinder case_bndr && null sc_args') = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') @@ -1319,7 +1329,7 @@ -- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $ ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where - (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) + (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args) sc_args' = filter is_flt_sc_arg args' clone_me bndr = do { uniq <- getUniqueM @@ -1339,7 +1349,6 @@ where var_ty = idType var - specCase env scrut case_bndr alts = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts ; return (scrut, case_bndr', alts', uds_alts) } @@ -1356,6 +1365,7 @@ where (env_rhs, args') = substBndrs env_alt args + {- Note [Fire rules in the specialiser] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#21851) @@ -1380,9 +1390,9 @@ The call to `g` in `h` will make us specialise `g @Int`. And the specialised version of `g` will contain the call `f @Int`; but in the subsequent run of the Simplifier, there will be a competition between: -* The user-supplied SPECIALISE rule for `f` -* The inlining of the wrapper for `f` -In fact, the latter wins -- see Note [Rewrite rules and inlining] in + * The user-supplied SPECIALISE rule for `f` + * The inlining of the wrapper for `f` +In fact, the latter wins -- see Note [tryRules: plan (BEFORE)] GHC.Core.Opt.Simplify.Iteration. However, it a bit fragile. Moreover consider (test T21851_2): @@ -1411,11 +1421,10 @@ we load it up just once, in `initRuleEnv`, called at the beginning of `specProgram`. -NB: you might wonder if running rules in the specialiser (this Note) -renders Note [Rewrite rules and inlining] in the Simplifier redundant. -That is, if we run rules in the specialiser, does it matter if we make -rules "win" over inlining in the Simplifier? Yes, it does! See the -discussion in #21851. +NB: you might wonder if running rules in the specialiser (this Note) renders +Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is, +if we run rules in the specialiser, does it matter if we make rules "win" over +inlining in the Simplifier? Yes, it does! See the discussion in #21851. Note [Floating dictionaries out of cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1486,11 +1495,12 @@ -- This is important: see Note [Update unfolding after specialisation] -- And in any case cloneBndrSM discards non-Stable unfoldings - fn3 = zapIdDemandInfo fn2 + fn3 = floatifyIdDemandInfo fn2 -- We zap the demand info because the binding may float, -- which would invalidate the demand info (see #17810 for example). -- Destroying demand info is not terrible; specialisation is -- always followed soon by demand analysis. + -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds `extendInScope` fn3 @@ -1623,7 +1633,7 @@ -- This function checks existing rules, and does not create -- duplicate ones. So the caller does not need to do this filtering. --- See 'already_covered' +-- See `alreadyCovered` type SpecInfo = ( [CoreRule] -- Specialisation rules , [(Id,CoreExpr)] -- Specialised definition @@ -1646,16 +1656,14 @@ -- switch off specialisation for inline functions = -- pprTrace "specCalls: some" (vcat - -- [ text "function" <+> ppr fn - -- , text "calls:" <+> ppr calls_for_me - -- , text "subst" <+> ppr (se_subst env) ]) $ + -- [ text "function" <+> ppr fn + -- , text "calls:" <+> ppr calls_for_me + -- , text "subst" <+> ppr (se_subst env) ]) $ foldlM spec_call ([], [], emptyUDs) calls_for_me | otherwise -- No calls or RHS doesn't fit our preconceptions - = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn)) + = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me) "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $ - -- isClassOpId: class-op Ids never inline; we specialise them - -- through fireRewriteRules. So don't complain about missed opportunities -- Note [Specialisation shape] -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs) @@ -1667,26 +1675,34 @@ fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here inl_prag = idInlinePragma fn inl_act = inlinePragmaActivation inl_prag + is_active = isActive (beginPhase inl_act) :: Activation -> Bool + -- is_active: inl_act is the activation we are going to put in the new + -- SPEC rule; so we want to see if it is covered by another rule with + -- that same activation. is_local = isLocalId fn is_dfun = isDFunId fn dflags = se_dflags env this_mod = se_module env + subst = se_subst env + in_scope = Core.substInScopeSet subst -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] - already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool - already_covered env new_rules args -- Note [Specialisations already covered] - = isJust (specLookupRule env fn args (beginPhase inl_act) - (new_rules ++ existing_rules)) - -- Rules: we look both in the new_rules (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - -- inl_act: is the activation we are going to put in the new SPEC - -- rule; so we want to see if it is covered by another rule with - -- that same activation. + -- Copy InlinePragma information from the parent Id. + -- So if f has INLINE[1] so does spec_fn + spec_inl_prag + | not is_local -- See Note [Specialising imported functions] + , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal + = neverInlinePragma + | otherwise + = inl_prag + not_in_scope :: InterestingVarFun + not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope) + ---------------------------------------------------------- -- Specialise to one particular call pattern spec_call :: SpecInfo -- Accumulating parameter @@ -1698,57 +1714,92 @@ | otherwise = call_args saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs) mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType - | otherwise = UnspecArg + | otherwise = UnspecArg - ; ( useful, rhs_env2, leftover_bndrs - , rule_bndrs, rule_lhs_args - , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args + -- Find qvars, the type variables to add to the binders for the rule + -- Namely those free in `ty` that aren't in scope + -- See (MP2) in Note [Specialising polymorphic dictionaries] + ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args + subst' = subst `Core.extendSubstInScopeList` poly_qvars + -- Maybe we should clone the poly_qvars telescope? --- ; pprTrace "spec_call" (vcat --- [ text "fun: " <+> ppr fn --- , text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs1:" <+> ppr spec_bndrs1 --- , text "leftover_bndrs:" <+> pprIds leftover_bndrs --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_bndrs" <+> ppr rhs_bndrs --- , text "rhs_body" <+> ppr rhs_body --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () + -- Any free Ids will have caused the call to be dropped + ; massertPpr (all isTyCoVar poly_qvars) + (ppr fn $$ ppr all_call_args $$ ppr poly_qvars) - ; if not useful -- No useful specialisation - || already_covered rhs_env2 rules_acc rule_lhs_args + ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args) + <- specHeader subst' rhs_bndrs all_call_args + ; let all_rule_bndrs = poly_qvars ++ rule_bndrs + env' = env { se_subst = subst'' } + + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules + -- all_rules: we look both in the rules_acc (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + already_covered = alreadyCovered env' all_rule_bndrs fn + rule_lhs_args is_active all_rules + +{- ; pprTrace "spec_call" (vcat + [ text "fun: " <+> ppr fn + , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "already_covered:" <+> ppr already_covered + , text "poly_qvars: " <+> ppr poly_qvars + , text "useful: " <+> ppr useful + , text "all_rule_bndrs:" <+> ppr all_rule_bndrs + , text "rule_lhs_args:" <+> ppr rule_lhs_args + , text "spec_bndrs:" <+> ppr spec_bndrs + , text "dx_binds:" <+> ppr dx_binds + , text "spec_args: " <+> ppr spec_args + , text "rhs_bndrs" <+> ppr rhs_bndrs + , text "rhs_body" <+> ppr rhs_body + , text "subst''" <+> ppr subst'' ]) $ + return () +-} + + ; if not useful -- No useful specialisation + || already_covered -- Useful, but done already then return spec_acc else - do { -- Run the specialiser on the specialised RHS - -- The "1" suffix is before we maybe add the void arg - ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - -- to the rhs_uds; see Note [Specialising Calls] - ; let rhs_uds_w_dx = dx_binds `consDictBinds` rhs_uds - spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs - (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx - spec_rhs1 = mkLams spec_rhs_bndrs $ - wrapDictBindsE dumped_dbs rhs_body' - spec_fn_ty1 = exprType spec_rhs1 + -- Not useless, not already covered: make a specialised binding + do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs + (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs + -- Run the specialiser on the specialised RHS + ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body + +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} + + -- Make the RHS of the specialised function + ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' + (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds + (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1) + -- dx_binds comes from the arguments to the call, and so can mention + -- poly_qvars but no other local binders + spec_rhs = mkLams poly_qvars $ + wrapDictBindsE outer_dumped_dbs $ + mkLams spec_rhs_bndrs $ + wrapDictBindsE inner_dumped_dbs rhs_body' + rule_rhs_args = poly_qvars ++ spec_bndrs + -- Maybe add a void arg to the specialised function, -- to avoid unlifted bindings -- See Note [Specialisations Must Be Lifted] -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg - add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) - (spec_bndrs, spec_rhs, spec_fn_ty) - | add_void_arg = ( voidPrimId : spec_bndrs1 - , Lam voidArgId spec_rhs1 - , mkVisFunTyMany unboxedUnitTy spec_fn_ty1) - | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) - join_arity_decr = length rule_lhs_args - length spec_bndrs + spec_fn_ty = exprType spec_rhs + add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn) + (rule_rhs_args1, spec_rhs1, spec_fn_ty1) + | add_void_arg = ( voidPrimId : rule_rhs_args + , Lam voidArgId spec_rhs + , mkVisFunTyMany unboxedUnitTy spec_fn_ty ) + | otherwise = (rule_rhs_args, spec_rhs, spec_fn_ty) -------------------------------------- -- Add a suitable unfolding; see Note [Inline specialisations] @@ -1756,22 +1807,14 @@ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) simpl_opts = initSimpleOpts dflags wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds - spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body + spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body rule_lhs_args fn_unf -------------------------------------- -- Adding arity information just propagates it a bit faster -- See Note [Arity decrease] in GHC.Core.Opt.Simplify - -- Copy InlinePragma information from the parent Id. - -- So if f has INLINE[1] so does spec_fn - arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs - - spec_inl_prag - | not is_local -- See Note [Specialising imported functions] - , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal - = neverInlinePragma - | otherwise - = inl_prag + join_arity_decr = length rule_lhs_args - length rule_rhs_args1 + arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args1 spec_fn_info = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr) @@ -1783,10 +1826,10 @@ spec_fn_details = case idDetails fn of JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing - DFunId is_nt -> DFunId is_nt + DFunId unary -> DFunId unary _ -> VanillaId - ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info + ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'. @@ -1798,36 +1841,56 @@ text "SPEC" spec_rule = mkSpecRule dflags this_mod True inl_act - herald fn rule_bndrs rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs) - - spec_f_w_arity = spec_fn + herald fn all_rule_bndrs rule_lhs_args + (mkVarApps (Var spec_fn) rule_rhs_args1) _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type - , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty1 , ppr rhs_bndrs, ppr call_args , ppr spec_rule + , text "acc" <+> ppr rules_acc + , text "existing" <+> ppr existing_rules ] ; -- pprTrace "spec_call: rule" _rule_trace_doc - return ( spec_rule : rules_acc - , (spec_f_w_arity, spec_rhs) : pairs_acc - , spec_uds `thenUDs` uds_acc + return ( spec_rule : rules_acc + , (spec_fn, spec_rhs1) : pairs_acc + , rhs_uds2 `thenUDs` uds_acc ) } } +alreadyCovered :: SpecEnv + -> [Var] -> Id -> [CoreExpr] -- LHS of possible new rule + -> (Activation -> Bool) -- Which rules are active + -> [CoreRule] -> Bool +-- Note [Specialisations already covered] esp (SC2) +alreadyCovered env bndrs fn args is_active rules + = case specLookupRule env fn args is_active rules of + Nothing -> False + Just (rule, _) + | isAutoRule rule -> -- Discard identical rules + -- We know that (fn args) is an instance of RULE + -- Check if RULE is an instance of (fn args) + ruleLhsIsMoreSpecific in_scope bndrs args rule + | otherwise -> True -- User rules dominate + where + in_scope = substInScopeSet (se_subst env) + -- Convenience function for invoking lookupRule from Specialise -- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] -specLookupRule :: SpecEnv -> Id -> [CoreExpr] - -> CompilerPhase -- Look up rules as if we were in this phase +specLookupRule :: HasDebugCallStack + => SpecEnv -> Id -> [CoreExpr] + -> (Activation -> Bool) -- Which rules are active -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -specLookupRule env fn args phase rules +specLookupRule env fn args is_active rules + | null rules + = Nothing -- Saves building a few thunks in the common case + | otherwise = lookupRule ropts in_scope_env is_active fn args rules where dflags = se_dflags env - in_scope = getSubstInScope (se_subst env) + in_scope = substInScopeSet (se_subst env) in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active) ropts = initRuleOpts dflags - is_active = isActive phase {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1947,12 +2010,15 @@ and suppose it is called at: - f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3 + f @T1 @T2 @T3 7 dEqT1 ($dfShow dShowT2) t3 This call is described as a 'CallInfo' whose 'ci_key' is: - [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1 - , SpecDict ($dfShow dShowT2), UnspecArg ] + [ SpecType T1, SpecType T2, UnspecType + , UnspecArg + , SpecDict dEqT1 + , SpecDict ($dfShow dShowT2) + , UnspecArg ] Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? Because we must specialise the function on type variables that appear @@ -2128,17 +2194,20 @@ Note [Evidence foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#12212) that we are specialising - f :: forall a b. (Num a, F a ~ F b) => blah + f :: forall a b. (Num a, F a ~# F b) => blah with a=b=Int. Then the RULE will be something like - RULE forall (d:Num Int) (g :: F Int ~ F Int). + RULE forall (d:Num Int) (g :: F Int ~# F Int). f Int Int d g = f_spec +where that `g` is really (Coercion (CoVar g)), since `g` is a +coercion variable and can't appear as (Var g). + But both varToCoreExpr (when constructing the LHS args), and the simplifier (when simplifying the LHS args), will transform to RULE forall (d:Num Int) (g :: F Int ~ F Int). f Int Int d = f_spec by replacing g with Refl. So now 'g' is unbound, which results in a later crash. So we use Refl right off the bat, and do not forall-quantify 'g': - * varToCoreExpr generates a Refl + * varToCoreExpr generates a (Coercion Refl) * exprsFreeIdsList returns the Ids bound by the args, which won't include g @@ -2326,22 +2395,25 @@ Note [Specialisations already covered] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We obviously don't want to generate two specialisations for the same -argument pattern. There are two wrinkles +argument pattern. Wrinkles -1. We do the already-covered test in specDefn, not when we generate -the CallInfo in mkCallUDs. We used to test in the latter place, but -we now iterate the specialiser somewhat, and the Id at the call site -might therefore not have all the RULES that we can see in specDefn +(SC1) We do the already-covered test in specDefn, not when we generate + the CallInfo in mkCallUDs. We used to test in the latter place, but + we now iterate the specialiser somewhat, and the Id at the call site + might therefore not have all the RULES that we can see in specDefn -2. What about two specialisations where the second is an *instance* -of the first? If the more specific one shows up first, we'll generate -specialisations for both. If the *less* specific one shows up first, -we *don't* currently generate a specialisation for the more specific -one. (See the call to lookupRule in already_covered.) Reasons: - (a) lookupRule doesn't say which matches are exact (bad reason) - (b) if the earlier specialisation is user-provided, it's - far from clear that we should auto-specialise further +(SC2) What about two specialisations where the second is an *instance* + of the first? It's a bit arbitrary, but here's what we do: + * If the existing one is user-specified, via a SPECIALISE pragma, we + suppress the further specialisation. + * If the existing one is auto-generated, we generate a second RULE + for the more specialised version. + The latter is important because we don't want the accidental order + of calls to determine what specialisations we generate. +(SC3) Annoyingly, we /also/ eliminate duplicates in `filterCalls`. + See (MP3) in Note [Specialising polymorphic dictionaries] + Note [Auto-specialisation and RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: @@ -2478,22 +2550,22 @@ | UnspecArg instance Outputable SpecArg where - ppr (SpecType t) = text "SpecType" <+> ppr t - ppr UnspecType = text "UnspecType" - ppr (SpecDict d) = text "SpecDict" <+> ppr d - ppr UnspecArg = text "UnspecArg" - -specArgFreeIds :: SpecArg -> IdSet -specArgFreeIds (SpecType {}) = emptyVarSet -specArgFreeIds (SpecDict dx) = exprFreeIds dx -specArgFreeIds UnspecType = emptyVarSet -specArgFreeIds UnspecArg = emptyVarSet + ppr (SpecType t) = text "SpecType" <+> ppr t + ppr (SpecDict d) = text "SpecDict" <+> ppr d + ppr UnspecType = text "UnspecType" + ppr UnspecArg = text "UnspecArg" -specArgFreeVars :: SpecArg -> VarSet -specArgFreeVars (SpecType ty) = tyCoVarsOfType ty -specArgFreeVars (SpecDict dx) = exprFreeVars dx -specArgFreeVars UnspecType = emptyVarSet -specArgFreeVars UnspecArg = emptyVarSet +specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV +-- Find the free vars of the SpecArgs that are not already in scope +specArgsFVs interesting args + = filterFV interesting $ + foldr (unionFV . get) emptyFV args + where + get :: SpecArg -> FV + get (SpecType ty) = tyCoFVsOfType ty + get (SpecDict dx) = exprFVs dx + get UnspecType = emptyFV + get UnspecArg = emptyFV isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True @@ -2543,103 +2615,90 @@ -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: SpecEnv - -> [InBndr] -- The binders from the original function 'f' + :: Core.Subst -- This substitution applies to the [InBndr] + -> [InBndr] -- Binders from the original function `f` -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened -- Not the same as any (isSpecDict args) because -- the args might be longer than bndrs - -- Returned arguments - , SpecEnv -- Substitution to apply to the body of 'f' - , [OutBndr] -- Leftover binders from the original function 'f' - -- that don’t have a corresponding SpecArg + , Core.Subst -- Apply this to the body -- RULE helpers - , [OutBndr] -- Binders for the RULE - , [OutExpr] -- Args for the LHS of the rule + -- `RULE forall rule_bndrs. f rule_es = $sf spec_bndrs` + , [OutBndr] -- rule_bndrs: Binders for the RULE + , [OutExpr] -- rule_es: Args for the LHS of the rule -- Specialised function helpers - , [OutBndr] -- Binders for $sf - , [DictBind] -- Auxiliary dictionary bindings - , [OutExpr] -- Specialised arguments for unfolding - -- Same length as "Args for LHS of rule" + -- `$sf = \spec_bndrs. let { dx_binds } in spec_arg` + , [OutBndr] -- spec_bndrs: Binders for $sf, and args for the RHS + -- of the RULE. Subset of rule_bndrs. + , [DictBind] -- dx_binds: Auxiliary dictionary bindings + , [OutExpr] -- spec_args: Specialised arguments for unfolding + -- Same length as "Args for LHS of rule" ) +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader subst [] _ = pure (False, subst, [], [], [], [], []) +specHeader subst _ [] = pure (False, subst, [], [], [], [], []) + -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader env (bndr : bndrs) (SpecType ty : args) - = do { -- Find qvars, the type variables to add to the binders for the rule - -- Namely those free in `ty` that aren't in scope - -- See (MP2) in Note [Specialising polymorphic dictionaries] - let in_scope = Core.getSubstInScope (se_subst env) - qvars = scopedSort $ - filterOut (`elemInScopeSet` in_scope) $ - tyCoVarsOfTypeList ty - (env1, qvars') = substBndrs env qvars - ty' = substTy env1 ty - env2 = extendTvSubst env1 bndr ty' - ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env2 bndrs args - ; pure ( useful - , env3 - , leftover_bndrs - , qvars' ++ rule_bs - , Type ty' : rule_es - , qvars' ++ bs' - , dx - , Type ty' : spec_args - ) - } +specHeader subst (bndr:bndrs) (SpecType ty : args) + = do { let subst1 = Core.extendTvSubst subst bndr ty + ; (useful, subst2, rule_bs, rule_args, spec_bs, dx, spec_args) + <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , rule_bs, Type ty : rule_args + , spec_bs, dx, Type ty : spec_args ) } -- Next we have a type that we don't want to specialise. We need to perform -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader env (bndr : bndrs) (UnspecType : args) - = do { let (env', bndr') = substBndr env bndr - ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( useful - , env'' - , leftover_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , bndr' : bs' - , dx - , varToCoreExpr bndr' : spec_args - ) - } +specHeader subst (bndr:bndrs) (UnspecType : args) + = do { let (subst1, bndr') = Core.substBndr subst bndr + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) + <- specHeader subst1 bndrs args + ; let ty_e' = Type (mkTyVarTy bndr') + ; pure ( useful, subst2 + , bndr' : rule_bs, ty_e' : rule_es + , bndr' : spec_bs, dx, ty_e' : spec_args ) } +specHeader subst (bndr:bndrs) (_ : args) + | isDeadBinder bndr + , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + , Just rubbish_lit <- mkLitRubbish (idType bndr') + = -- See Note [Drop dead args from specialisations] + do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args + ; pure ( useful, subst2 + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dx, rubbish_lit : spec_args ) } + -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. -specHeader env (bndr : bndrs) (SpecDict d : args) - | not (isDeadBinder bndr) - , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) - -- See Note [Weird special case for SpecDict] - = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders] - ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d - ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env2 bndrs args - ; pure ( True -- Ha! A useful specialisation! - , env3 - , leftover_bndrs - -- See Note [Evidence foralls] - , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs - , varToCoreExpr bndr' : rule_es - , bs' - , maybeToList dx_bind ++ dx - , spec_dict : spec_args - ) - } - where - in_scope = Core.getSubstInScope (se_subst env) +specHeader subst (bndr:bndrs) (SpecDict dict_arg : args) + = do { -- Make up a fresh binder to use in the RULE + -- It might turn into a dict binding (via bindAuxiliaryDict) which we + -- then float, so we use cloneIdBndr to get a completely fresh binder + us <- getUniqueSupplyM + ; let (subst1, bndr') = Core.cloneIdBndr subst us (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS + ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg + + ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args + + ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx } + ; pure ( True, subst3 -- Ha! A useful specialisation! + , bndr' : rule_bs, Var bndr' : rule_es + , spec_bs, dx', spec_dict : spec_args ) } + -- Finally, we don't want to specialise on this argument 'i': --- - It's an UnSpecArg, or --- - It's a dead dictionary -- We need to produce a binder, LHS and RHS argument for the RULE, and -- a binder for the specialised body. -- @@ -2647,76 +2706,48 @@ -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader env (bndr : bndrs) (_ : args) - -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead - = do { -- see Note [Zap occ info in rule binders] - let (env', bndr') = substBndr env (zapIdOccInfo bndr) - ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - - ; let bndr_ty = idType bndr' - - -- See Note [Drop dead args from specialisations] - -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let - (mb_spec_bndr, spec_arg) - | isDeadBinder bndr - , Just lit_expr <- mkLitRubbish bndr_ty - = (Nothing, lit_expr) - | otherwise - = (Just bndr', varToCoreExpr bndr') - - ; pure ( useful - , env'' - , leftover_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , case mb_spec_bndr of - Just b' -> b' : bs' - Nothing -> bs' - , dx - , spec_arg : spec_args - ) - } +specHeader subst (bndr:bndrs) (UnspecArg : args) + = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr) + -- zapIdOccInfo: see Note [Zap occ info in rule binders] + ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args --- If we run out of binders, stop immediately --- See Note [Specialisation Must Preserve Sharing] -specHeader env [] _ = pure (False, env, [], [], [], [], [], []) + ; let dummy_arg = varToCoreExpr bndr' + -- dummy_arg is usually just (Var bndr), + -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr)) + -- or even Coercion Refl (if t1=t2) + -- See Note [Evidence foralls] + bndrs = exprFreeIdsList dummy_arg --- Return all remaining binders from the original function. These have the --- invariant that they should all correspond to unspecialised arguments, so --- it's safe to stop processing at this point. -specHeader env bndrs [] - = pure (False, env', bndrs', [], [], [], [], []) - where - (env', bndrs') = substBndrs env bndrs + ; pure ( useful, subst2 + , bndrs ++ rule_bs, dummy_arg : rule_es + , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) } -- | Binds a dictionary argument to a fresh name, to preserve sharing bindAuxiliaryDict - :: SpecEnv + :: Subst -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression - -> ( SpecEnv -- Substitutes for orig_dict_id + -> ( Subst -- Substitutes for orig_dict_id , Maybe DictBind -- Auxiliary dict binding, if any , OutExpr) -- Witnessing expression (always trivial) -bindAuxiliaryDict env@(SE { se_subst = subst }) - orig_dict_id fresh_dict_id dict_expr +bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg -- If the dictionary argument is trivial, -- don’t bother creating a new dict binding; just substitute - | exprIsTrivial dict_expr - = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr } - in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $ - (env', Nothing, dict_expr) + | exprIsTrivial dict_arg + , let subst' = Core.extendSubst subst orig_dict_id dict_arg + = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $ + (subst', Nothing, dict_arg) | otherwise -- Non-trivial dictionary arg; make an auxiliary binding - = let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_expr + , let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg - dict_bind = mkDB (NonRec fresh_dict_id' dict_expr) - env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id') - `Core.extendSubstInScope` fresh_dict_id' } - -- Ensure the new unfolding is in the in-scope set - in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $ - (env', Just dict_bind, Var fresh_dict_id') + dict_bind = mkDB (NonRec fresh_dict_id' dict_arg) + subst' = Core.extendSubst subst orig_dict_id (Var fresh_dict_id') + `Core.extendSubstInScope` fresh_dict_id' + -- Ensure the new unfolding is in the in-scope set + = -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $ + (subst', Just dict_bind, Var fresh_dict_id') addDictUnfolding :: Id -> CoreExpr -> Id -- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting] @@ -2803,12 +2834,10 @@ Note [Specialising polymorphic dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Note June 2023: This has proved to be quite a tricky optimisation to get right see (#23469, #23109, #21229, #23445) so it is now guarded by a flag `-fpolymorphic-specialisation`. - Consider class M a where { foo :: a -> Int } @@ -2848,12 +2877,27 @@ function. (MP3) If we have f :: forall m. Monoid m => blah, and two calls - (f @(Endo b) (d :: Monoid (Endo b)) - (f @(Endo (c->c)) (d :: Monoid (Endo (c->c))) + (f @(Endo b) (d1 :: Monoid (Endo b)) + (f @(Endo (c->c)) (d2 :: Monoid (Endo (c->c))) we want to generate a specialisation only for the first. The second is just a substitution instance of the first, with no greater specialisation. - Hence the call to `remove_dups` in `filterCalls`. + Hence the use of `removeDupCalls` in `filterCalls`. + You might wonder if `d2` might be more specialised than `d1`; but no. + This `removeDupCalls` thing is at the definition site of `f`, and both `d1` + and `d2` are in scope. So `d1` is simply more polymorphic than `d2`, but + is just as specialised. + + This distinction is sadly lost once we build a RULE, so `alreadyCovered` + can't be so clever. E.g if we have an existing RULE + forall @a (d1:Ord Int) (d2: Eq a). f @a @Int d1 d2 = ... + and a putative new rule + forall (d1:Ord Int) (d2: Eq Int). f @Int @Int d1 d2 = ... + we /don't/ want the existing rule to subsume the new one. + + So we sadly put up with having two rather different places where we + eliminate duplicates: `alreadyCovered` and `removeDupCalls`. + All this arose in #13873, in the unexpected form that a SPECIALISE pragma made the program slower! The reason was that the specialised function $sinsertWith arising from the pragma looked rather like `f` @@ -2900,7 +2944,7 @@ is a top-level dictionary-former. This actually happened in #22459, because of (MP1) of Note [Specialising polymorphic dictionaries]. -How can we speicalise $wsplit? We might try +How can we specialise $wsplit? We might try RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit @@ -2950,16 +2994,29 @@ -- The list of types and dictionaries is guaranteed to -- match the type of f -- The Bag may contain duplicate calls (i.e. f @T and another f @T) - -- These dups are eliminated by already_covered in specCalls + -- These dups are eliminated by alreadyCovered in specCalls data CallInfo - = CI { ci_key :: [SpecArg] -- All arguments + = CI { ci_key :: [SpecArg] -- Arguments of the call + -- See Note [The (CI-KEY) invariant] + , ci_fvs :: IdSet -- Free Ids of the ci_key call -- /not/ including the main id itself, of course -- NB: excluding tyvars: -- See Note [Specialising polymorphic dictionaries] } +{- Note [The (CI-KEY) invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (CI-KEY): + In the `ci_key :: [SpecArg]` field of `CallInfo`, + * The list is non-empty + * The least element is always a `SpecDict` + +In this way the RULE has as few args as possible, which broadens its +applicability, since rules only fire when saturated. +-} + type DictExpr = CoreExpr ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet @@ -3004,22 +3061,16 @@ = MkUD {ud_binds = emptyFDBs, ud_calls = unitDVarEnv id $ CIS id $ unitBag (CI { ci_key = args - , ci_fvs = call_fvs }) } + , ci_fvs = fvVarSet call_fvs }) } where - call_fvs = - foldr (unionVarSet . free_var_fn) emptyVarSet args - - free_var_fn = - if gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) - then specArgFreeIds - else specArgFreeVars - - + poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags spec_env) - -- specArgFreeIds: we specifically look for free Ids, not TyVars - -- see (MP1) in Note [Specialising polymorphic dictionaries] - -- - -- We don't include the 'id' itself. + -- With -fpolymorphic-specialisation, keep just local /Ids/ + -- Otherwise, keep /all/ free vars including TyVars + -- See (MP1) in Note [Specialising polymorphic dictionaries] + -- But NB: we don't include the 'id' itself. + call_fvs | poly_spec = specArgsFVs isLocalId args + | otherwise = specArgsFVs isLocalVar args mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails mkCallUDs env fun args @@ -3048,33 +3099,87 @@ ci_key :: [SpecArg] ci_key = dropWhileEndLE (not . isSpecDict) $ zipWith mk_spec_arg args pis - -- Drop trailing args until we get to a SpecDict - -- In this way the RULE has as few args as possible, - -- which broadens its applicability, since rules only - -- fire when saturated + -- Establish (CI-KEY): drop trailing args until we get to a SpecDict mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg - mk_spec_arg arg (Named bndr) + mk_spec_arg (Type ty) (Named bndr) | binderVar bndr `elemVarSet` constrained_tyvars - = case arg of - Type ty -> SpecType ty - _ -> pprPanic "ci_key" $ ppr arg - | otherwise = UnspecType + = SpecType ty + | otherwise + = UnspecType + mk_spec_arg non_type_arg (Named bndr) + = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr) -- For "invisibleFunArg", which are the type-class dictionaries, -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg - mk_spec_arg arg (Anon pred af) + mk_spec_arg arg (Anon _pred af) | isInvisibleFunArg af - , interestingDict arg (scaledThing pred) + , interestingDict env arg -- See Note [Interesting dictionary arguments] = SpecDict arg | otherwise = UnspecArg -{- -Note [Ticks on applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +wantCallsFor :: SpecEnv -> Id -> Bool +-- See Note [wantCallsFor] +wantCallsFor _env f + = case idDetails f of + RecSelId {} -> False + DataConWorkId {} -> False + DataConWrapId {} -> False + ClassOpId {} -> False + PrimOpId {} -> False + FCallId {} -> False + TickBoxOpId {} -> False + CoVarId {} -> False + + DFunId {} -> True + VanillaId {} -> True + JoinId {} -> True + WorkerLikeId {} -> True + RepPolyId {} -> True + +interestingDict :: SpecEnv -> CoreExpr -> Bool +-- This is a subtle and important function +-- See Note [Interesting dictionary arguments] +interestingDict env (Var v) -- See (ID3) and (ID5) + | Just rhs <- maybeUnfoldingTemplate (idUnfolding v) + -- Might fail for loop breaker dicts but that seems fine. + = interestingDict env rhs + +interestingDict env arg -- Main Plan: use exprIsConApp_maybe + | Cast inner_arg _ <- arg -- See (ID5) + = if | isConstraintKind $ typeKind $ exprType inner_arg + -- If coercions were always homo-kinded, we'd know + -- that this would be the only case + -> interestingDict env inner_arg + + -- Check for an implicit parameter at the top + | Just (cls,_) <- getClassPredTys_maybe arg_ty + , isIPClass cls -- See (ID5) + -> False + + -- Otherwise we are unwrapping a unary type class + | otherwise + -> exprIsHNF arg -- See (ID7) + + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg + , Just cls <- tyConClass_maybe (dataConTyCon data_con) + , definitely_not_ip_like -- See (ID4) + = if null (classMethods cls) -- See (ID6) + then any (interestingDict env) args + else True + + | otherwise + = not (exprIsTrivial arg) && definitely_not_ip_like -- See (ID8) + where + arg_ty = exprType arg + definitely_not_ip_like = not (couldBeIPLike arg_ty) + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding + +{- Note [Ticks on applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticks such as source location annotations can sometimes make their way onto applications (see e.g. #21697). So if we see something like @@ -3086,51 +3191,128 @@ The resulting RULE also has to be able to match this annotated use site, so we only look through ticks that RULE matching looks through (see Note [Tick annotations in RULE matching] in GHC.Core.Rules). --} -wantCallsFor :: SpecEnv -> Id -> Bool -wantCallsFor _env _f = True - -- We could reduce the size of the UsageDetails by being less eager - -- about collecting calls for LocalIds: there is no point for - -- ones that are lambda-bound. We can't decide this by looking at - -- the (absence of an) unfolding, because unfoldings for local - -- functions are discarded by cloneBindSM, so no local binder will - -- have an unfolding at this stage. We'd have to keep a candidate - -- set of let-binders. - -- - -- Not many lambda-bound variables have dictionary arguments, so - -- this would make little difference anyway. - -- - -- For imported Ids we could check for an unfolding, but we have to - -- do so anyway in canSpecImport, and it seems better to have it - -- all in one place. So we simply collect usage info for imported - -- overloaded functions. +Note [wantCallsFor] +~~~~~~~~~~~~~~~~~~~ +`wantCallsFor env f` says whether the Specialiser should collect calls for +function `f`; other thing being equal, the fewer calls we collect the better. It +is False for things we can't specialise: -{- Note [Interesting dictionary arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* ClassOpId: never inline and we don't have a defn to specialise; we specialise + them through fireRewriteRules. +* PrimOpId: are never overloaded +* Data constructors: we never specialise them + +We could reduce the size of the UsageDetails by being less eager about +collecting calls for some LocalIds: there is no point for ones that are +lambda-bound. We can't decide this by looking at the (absence of an) unfolding, +because unfoldings for local functions are discarded by cloneBindSM, so no local +binder will have an unfolding at this stage. We'd have to keep a candidate set +of let-binders. + +Not many lambda-bound variables have dictionary arguments, so this would make +little difference anyway. + +For imported Ids we could check for an unfolding, but we have to do so anyway in +canSpecImport, and it seems better to have it all in one place. So we simply +collect usage info for imported overloaded functions. + +Note [Interesting dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this \a.\d:Eq a. let f = ... in ...(f d)... There really is not much point in specialising f wrt the dictionary d, because the code for the specialised f is not improved at all, because d is lambda-bound. We simply get junk specialisations. -What is "interesting"? Just that it has *some* structure. But what about -variables? We look in the variable's /unfolding/. And that means -that we must be careful to ensure that dictionaries have unfoldings, +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see +if the argument is a dictionary constructor applied to some arguments, in which +case we can clearly specialise. But there are wrinkles: -* cloneBndrSM discards non-Stable unfoldings -* specBind updates the unfolding after specialisation - See Note [Update unfolding after specialisation] -* bindAuxiliaryDict adds an unfolding for an aux dict - see Note [Specialisation modulo dictionary selectors] -* specCase adds unfoldings for the new bindings it creates +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the + argument is + (% d1, d2 %) |> co + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family. + Then its type (F Int a) looks very un-informative, but the term is super + helpful. See #19747 (where missing this point caused a 70x slow down) + and #7785. -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables didn't have unfoldings. But makes a -massive difference in a few cases, eg #5113. For nofib as a -whole it's only a small win: 2.2% improvement in allocation for ansi, -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. +(ID2) Note that the Main Plan works fine for an argument that is a DFun call, + e.g. $fOrdList $dOrdInt + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good! +(ID3) For variables, we look in the variable's /unfolding/. And that means + that we must be careful to ensure that dictionaries /have/ unfoldings: + * cloneBndrSM discards non-Stable unfoldings + * specBind updates the unfolding after specialisation + See Note [Update unfolding after specialisation] + * bindAuxiliaryDict adds an unfolding for an aux dict + see Note [Specialisation modulo dictionary selectors] + * specCase adds unfoldings for the new bindings it creates + + We accidentally lost accurate tracking of local variables for a long + time, because cloned variables didn't have unfoldings. But makes a + massive difference in a few cases, eg #5113. For nofib as a + whole it's only a small win: 2.2% improvement in allocation for ansi, + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size. + +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains + an implicit parameter, because implicit parameters are emphatically not singleton + types. See #25999: + useImplicit :: (?i :: Int) => Int + useImplicit = ?i + 1 + + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit) + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values. + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike` + in `definitely_not_ip_like`. + +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type + constructor at the top of both sides. But see the example in (ID1), where that + is not true. For the same reason, we can't rely on `exprIsConApp_maybe` to look + through unfoldings (because there might be a cast inside), hence dealing with + expandable unfoldings in `interestingDict` directly. + + For the same reasons as in (ID4), we must take care to not allow an implicit + parameter to sneak through, so we must not unwrap the newtype cast for the + unary IP class; hence the `isIPClass` call. (We don't need to call + `couldBeIPLike`, as implicit parameters hidden behind a type family are + detected by the recursive call to `interestingDict` on the argument inside the + cast.) + +(ID6) The Main Plan says that it's worth specialising if the argument is an application + of a dictionary contructor. But what if the dictionary has no methods? Then we + gain nothing by specialising, unless the /superclasses/ are interesting. A case + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class + with N superclasses and no methods. + +(ID7) A unary (single-method) class is currently represented by (meth |> co). We + will unwrap the cast (see (ID5)) and then want to reply "yes" if the method + has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a + new story for unary classes, see #23109, and this special case will become + irrelevant.) + +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a + non-trivial argument as interesting. In T19695 we have this: + askParams :: Monad m => blah + mhelper :: MonadIO m => blah + mhelper (d:MonadIO m) = ...(askParams @m ($p1 d)).... + where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is + specialised at `Handler` we'll get this call in the specialised `$smhelper`: + askParams @Handler ($p1 $fMonadIOHandler) + and we /definitely/ want to specialise that, even though the argument isn't + visibly a dictionary application. In fact the specialiser fires the superclass + selector rule (see Note [Fire rules in the specialiser]), so we get + askParams @Handler ($cp1MonadIO $fMonadIOIO) + but it /still/ doesn't look like a dictionary application. + + Conclusion: we optimistically assume that any non-trivial argument is worth + specialising on. + + So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look + under type-family casts (ID1) and constraint tuples (ID6). + Note [Update unfolding after specialisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#21848) @@ -3157,12 +3339,13 @@ Now `f` turns into: f @a @b (dd :: D a) (ds :: Show b) a b + = let dc :: D a = %p1 dd -- Superclass selection in meth @a dc .... meth @a dc .... When we specialise `f`, at a=Int say, that superclass selection can -nfire (via rewiteClassOps), but that info (that 'dc' is now a +fire (via rewiteClassOps), but that info (that 'dc' is now a particular dictionary `C`, of type `C Int`) must be available to the call `meth @a dc`, so that we can fire the `meth` class-op, and thence specialise `wombat`. @@ -3172,27 +3355,6 @@ the Rec case.) -} -interestingDict :: CoreExpr -> Type -> Bool --- A dictionary argument is interesting if it has *some* structure, --- see Note [Interesting dictionary arguments] --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case --- To make this work, we need to ensure that dictionaries have --- unfoldings in them. -interestingDict arg arg_ty - | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value] - | otherwise = go arg - where - go (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - go (Type _) = False - go (Coercion _) = False - go (App fn (Type _)) = go fn - go (App fn (Coercion _)) = go fn - go (Tick _ a) = go a - go (Cast e _) = go e - go _ = True - thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) (MkUD {ud_binds = db2, ud_calls = calls2}) @@ -3289,7 +3451,11 @@ -- Used at a lambda or case binder; just dump anything mentioning the binder dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) | null bndrs = (uds, nilOL) -- Common in case alternatives - | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ + | otherwise = -- pprTrace "dumpUDs" (vcat + -- [ text "bndrs" <+> ppr bndrs + -- , text "uds" <+> ppr uds + -- , text "free_uds" <+> ppr free_uds + -- , text "dump-dbs" <+> ppr dump_dbs ]) $ (free_uds, dump_dbs) where free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls } @@ -3328,20 +3494,17 @@ calls_for_me = case lookupDVarEnv orig_calls fn of Nothing -> [] Just cis -> filterCalls cis orig_dbs - -- filterCalls: drop calls that (directly or indirectly) - -- refer to fn. See Note [Avoiding loops (DFuns)] ---------------------- filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo] --- Remove dominated calls (Note [Specialising polymorphic dictionaries]) --- and loopy DFuns (Note [Avoiding loops (DFuns)]) +-- Remove +-- (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries] +-- (b) loopy DFuns: Note [Avoiding loops (DFuns)] filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs }) - | isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns - = filter ok_call de_dupd_calls - | otherwise -- Do not apply it to non-DFuns - = de_dupd_calls -- See Note [Avoiding loops (non-DFuns)] + | isDFunId fn = filter ok_call de_dupd_calls -- Deals with (b) + | otherwise = de_dupd_calls where - de_dupd_calls = remove_dups call_bag + de_dupd_calls = removeDupCalls call_bag -- Deals with (a) dump_set = foldl' go (unitVarSet fn) dbs -- This dump-set could also be computed by splitDictBinds @@ -3355,10 +3518,10 @@ ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set -remove_dups :: Bag CallInfo -> [CallInfo] +removeDupCalls :: Bag CallInfo -> [CallInfo] -- Calls involving more generic instances beat more specific ones. -- See (MP3) in Note [Specialising polymorphic dictionaries] -remove_dups calls = foldr add [] calls +removeDupCalls calls = foldr add [] calls where add :: CallInfo -> [CallInfo] -> [CallInfo] add ci [] = [ci] @@ -3367,16 +3530,24 @@ | otherwise = ci2 : add ci1 cis beats_or_same :: CallInfo -> CallInfo -> Bool +-- (beats_or_same ci1 ci2) is True if specialising on ci1 subsumes ci2 +-- That is: ci1's types are less specialised than ci2 +-- ci1 specialises on the same dict args as ci2 beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 }) = go args1 args2 where - go [] _ = True + go [] [] = True go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2 - go (_:_) [] = False + -- If one or the other runs dry, the other must still have a SpecDict + -- because of the (CI-KEY) invariant. So neither subsumes the other; + -- one is more specialised (faster code) but the other is more generally + -- applicable. + go _ _ = False + go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2) - go_arg UnspecType UnspecType = True go_arg (SpecDict {}) (SpecDict {}) = True + go_arg UnspecType UnspecType = True go_arg UnspecArg UnspecArg = True go_arg _ _ = False @@ -3444,9 +3615,9 @@ (ys, uds2) <- mapAndCombineSM f xs return (y:ys, uds1 `thenUDs` uds2) -extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv -extendTvSubst env tv ty - = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } +-- extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv +-- extendTvSubst env tv ty +-- = env { se_subst = Core.extendTvSubst (se_subst env) tv ty } extendInScope :: SpecEnv -> OutId -> SpecEnv extendInScope env@(SE { se_subst = subst }) bndr @@ -3466,7 +3637,7 @@ substBndr env bs = case Core.substBndr (se_subst env) bs of (subst', bs') -> (env { se_subst = subst' }, bs') -substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) +substBndrs :: Traversable f => SpecEnv -> f CoreBndr -> (SpecEnv, f CoreBndr) substBndrs env bs = case Core.substBndrs (se_subst env) bs of (subst', bs') -> (env { se_subst = subst' }, bs') @@ -3481,20 +3652,9 @@ cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id]) cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs - = do { (subst', bndrs') <- Core.cloneRecIdBndrs subst bndrs + = do { (subst', bndrs') <- Core.cloneRecIdBndrsM subst bndrs ; let env' = env { se_subst = subst' } ; return (env', bndrs') } - -newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr) --- Make up completely fresh binders for the dictionaries --- Their bindings are going to float outwards -newDictBndr env@(SE { se_subst = subst }) b - = do { uniq <- getUniqueM - ; let n = idName b - ty' = substTyUnchecked subst (idType b) - b' = mkUserLocal (nameOccName n) uniq ManyTy ty' (getSrcSpan n) - env' = env { se_subst = subst `Core.extendSubstInScope` b' } - ; pure (env', b') } newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id -- Give the new Id a similar occurrence name to the old one diff --git a/GHC/Core/Opt/StaticArgs.hs b/GHC/Core/Opt/StaticArgs.hs --- a/GHC/Core/Opt/StaticArgs.hs +++ b/GHC/Core/Opt/StaticArgs.hs @@ -111,7 +111,7 @@ let (binders, rhss) = unzip pairs rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss let (rhss', sat_info_rhss') = unzip rhss_SATed - return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') + return (Rec (zipEqual binders rhss'), mergeIdSATInfos sat_info_rhss') data App = VarApp Id | TypeApp Type | CoApp Coercion data Staticness a = Static a | NotStatic diff --git a/GHC/Core/Opt/Stats.hs b/GHC/Core/Opt/Stats.hs --- a/GHC/Core/Opt/Stats.hs +++ b/GHC/Core/Opt/Stats.hs @@ -179,6 +179,13 @@ transformations for the same reason as PreInlineUnconditionally, so it's probably not innocuous anyway. + One annoying variant is this. CaseMerge introduces auxiliary bindings + let b = b' in ... + This takes another full run of the simplifier to elimiante. But if + the PostInlineUnconditionally, replacing b with b', is the only thing + that happens in a Simplifier run, that probably really is innocuous. + Perhaps an opportunity here. + KnownBranch, BetaReduction: May drop chunks of code, and thereby enable PreInlineUnconditionally for some let-binding which now occurs once diff --git a/GHC/Core/Opt/WorkWrap.hs b/GHC/Core/Opt/WorkWrap.hs --- a/GHC/Core/Opt/WorkWrap.hs +++ b/GHC/Core/Opt/WorkWrap.hs @@ -35,7 +35,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Monad import GHC.Core.DataCon @@ -759,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) ] @@ -787,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) @@ -830,8 +839,8 @@ -- inl_act: see Note [Worker activation] -- inl_rule: it does not make sense for workers to be constructorlike. - work_join_arity | isJoinId fn_id = Just join_arity - | otherwise = Nothing + work_join_arity | isJoinId fn_id = JoinPoint join_arity + | otherwise = NotJoinPoint -- worker is join point iff wrapper is join point -- (see Note [Don't w/w join points for CPR]) diff --git a/GHC/Core/Opt/WorkWrap/Utils.hs b/GHC/Core/Opt/WorkWrap/Utils.hs --- a/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/GHC/Core/Opt/WorkWrap/Utils.hs @@ -15,7 +15,8 @@ , findTypeShape, IsRecDataConResult(..), isRecDataCon , mkAbsentFiller , isWorkerSmallEnough, dubiousDataConInstArgTys - , boringSplit , usefulSplit + , boringSplit, usefulSplit, workWrapArity + , canUnboxType, canUnboxTyCon ) where @@ -29,8 +30,10 @@ 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.Predicate( isEqualityClass ) import GHC.Core.TyCon import GHC.Core.TyCon.Set import GHC.Core.TyCon.RecWalk @@ -55,7 +58,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Applicative ( (<|>) ) import Control.Monad ( zipWithM ) @@ -63,6 +65,7 @@ import GHC.Types.RepType import GHC.Unit.Types +import GHC.Core.TyCo.Rep {- ************************************************************************ @@ -160,6 +163,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 @@ -206,8 +210,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 @@ -216,7 +220,7 @@ ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars) empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs) zapped_arg_vars = map zap_var arg_vars - ; (subst, cloned_arg_vars) <- cloneBndrs empty_subst zapped_arg_vars + ; (subst, cloned_arg_vars) <- cloneBndrsM empty_subst zapped_arg_vars ; let res_ty' = substTyUnchecked subst res_ty init_str_marks = map (const NotMarkedStrict) cloned_arg_vars @@ -272,6 +276,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 @@ -289,6 +297,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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -598,7 +613,7 @@ -- 's' will be 'Demand' or 'Cpr'. data DataConPatContext s = DataConPatContext - { dcpc_dc :: !DataCon + { dcpc_dc :: !DataCon -- INVARIANT: canUnboxTyCon is true of this DataCon's tycon , dcpc_tc_args :: ![Type] , dcpc_co :: !Coercion , dcpc_args :: ![s] @@ -651,7 +666,7 @@ -- From here we are strict and not absent | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty - , Just dc <- tyConSingleAlgDataCon_maybe tc + , Just [dc] <- canUnboxTyCon tc -- tc is never a newtype , let arity = dataConRepArity dc , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis] , dmds `lengthIs` dataConRepArity dc @@ -669,7 +684,7 @@ canUnboxResult fam_envs ty cpr | Just (con_tag, arg_cprs) <- asConCpr cpr , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty - , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning + , Just dcs <- canUnboxTyCon tc <|> open_body_ty_warning , dcs `lengthAtLeast` con_tag -- This might not be true if we import the -- type constructor via a .hs-boot file (#8743) , let dc = dcs `getNth` (con_tag - fIRST_TAG) @@ -689,8 +704,101 @@ -- See Note [non-algebraic or open body type warning] open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing -{- Note [Which types are unboxed?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +canUnboxType :: HasDebugCallStack => Type -> Maybe [DataCon] +canUnboxType arg_ty = case tyConAppTyCon_maybe arg_ty of + Just tc -> canUnboxTyCon tc + Nothing -> Nothing + +canUnboxTyCon :: HasDebugCallStack => TyCon -> Maybe [DataCon] +-- True for +-- boxed algebraic datatypes +-- unboxed tuples and sums +-- +-- False for +-- class dictionaries, except equality classes and tuples +-- See Note [Do not unbox class dictionaries] +-- +-- Precondition: tc is not a newtype +canUnboxTyCon tc + | Just cls <- tyConClass_maybe tc + , not (isEqualityClass cls) + = Nothing -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries] + + | otherwise + = assertPpr (not (isNewTyCon tc)) (ppr tc) $ -- Check precondition + tyConDataCons_maybe tc + +{- Note [Do not unbox class dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never unbox class dictionaries in worker/wrapper. + +1. INLINABLE functions + If we have + f :: Ord a => [a] -> Int -> a + {-# INLINABLE f #-} + and we worker/wrapper f, we'll get a worker with an INLINABLE pragma + (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), + which can still be specialised by the type-class specialiser, something like + fw :: Ord a => [a] -> Int# -> a + + BUT if f is strict in the Ord dictionary, we might unpack it, to get + fw :: (a->a->Bool) -> [a] -> Int# -> a + and the type-class specialiser can't specialise that. An example is #6056. + + Historical note: #14955 describes how I got this fix wrong the first time. + I got aware of the issue in T5075 by the change in boxity of loop between + demand analysis runs. + +2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur + occur without INLINABLE, when we use -fexpose-all-unfoldings and + -fspecialise-aggressively to do vigorous cross-module specialisation. + +3. #18421 found that unboxing a dictionary can also make the worker less likely + to inline; the inlining heuristics seem to prefer to inline a function + applied to a dictionary over a function applied to a bunch of functions. + +TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing +a raft of higher-order functions isn't a huge win anyway -- you really want to +specialise the function. + +Wrinkle (DNB1): we /do not/ to unbox tuple dictionaries either. We used to + have a special case to unbox tuple dictionaries (#23398), but it ultimately + turned out to be a very bad idea (see !19747#note_626297). In summary: + + - If w/w unboxes tuple dictionaries we get things like + case d of CTuple2 d1 d2 -> blah + rather than + let { d1 = sc_sel1 d; d2 = sc_sel2 d } in blah + The latter works much better with the specialiser: when `d` is instantiated + to some useful dictionary the `sc_sel1 d` selection can fire. + + - The attempt to deal with unpacking dictionaries with `case` led to + significant extra complexity in the type-class specialiser (#26158) that is + rendered unnecessary if we only take do superclass selection with superclass + selectors, never with `case` expressions. + + Even with that extra complexity, specialisation was /still/ sometimes worse, + and sometimes /tremendously/ worse (a factor of 70x); see #19747. + + - Suppose f :: forall a. (% Eq a, Show a %) => blah + The specialiser is perfectly capable of specialising a call like + f @Int (% dEqInt, dShowInt %) + so the tuple doesn't get in the way. + + - It's simpler and more uniform. There is nothing special about constraint + tuples; anyone can write class (C1 a, C2 a) => D a where {} + +Wrinkle (DNB2): we /do/ want to unbox equality dictionaries, + for (~), (~~), and Coercible (#23398). Their payload is a single unboxed + coercion. We never want to specialise on `(t1 ~ t2)`. All that would do is + to make a copy of the function's RHS with a particular coercion. Unlike + normal class methods, that does not unlock any new optimisation + opportunities in the specialised RHS. + +Note [Which types are unboxed?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Worker/wrapper will unbox 1. A strict data type argument, that @@ -822,7 +930,7 @@ before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now. -See also Note [Tag Inference] and Note [CBV Function Ids] +See also Note [EPT enforcement] and Note [CBV Function Ids] Note [Worker/wrapper for strict arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -848,7 +956,7 @@ The worker `$wf` is a CBV function (see `Note [CBV Function Ids]` in GHC.Types.Id.Info) and the code generator guarantees that every -call to `$wf` has a properly tagged argument (see `GHC.Stg.InferTags.Rewrite`). +call to `$wf` has a properly tagged argument (see `GHC.Stg.EnforceEpt.Rewrite`). Is this a win? Not always: * It can cause slight codesize increases. This is since we push evals to every @@ -971,7 +1079,7 @@ -- don't end up in lambda binders of the worker. -- See Note [Never put `OtherCon` unfoldings on lambda binders] arg_ids' = map zapIdUnfolding $ - zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds + zipWithEqual setIdDemandInfo arg_ids ds unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) dc (ex_tvs' ++ arg_ids') @@ -996,21 +1104,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 }) @@ -1173,7 +1285,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]). @@ -1181,7 +1293,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 @@ -1206,8 +1318,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 @@ -1217,9 +1329,31 @@ 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 fragile @@ -1313,7 +1447,8 @@ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args = go rec_tc rhs - | Just con <- tyConSingleAlgDataCon_maybe tc + | not (isNewTyCon tc) + , Just con <- tyConSingleDataCon_maybe tc , Just rec_tc <- if isTupleTyCon tc then Just rec_tc else checkRecTc rec_tc tc @@ -1388,23 +1523,29 @@ | arg_ty <- map scaledThing (dataConRepArgTys dc) ] go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult - go_arg_ty fuel visited_tcs ty - --- | pprTrace "arg_ty" (ppr ty) False = undefined + go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $ + case coreFullView ty of + TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args + -- See Note [Detecting recursive data constructors], points (B) and (C) - | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty - = go_arg_ty fuel visited_tcs ty' + ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty' -- See Note [Detecting recursive data constructors], point (A) - | Just (tc, tc_args) <- splitTyConApp_maybe ty - = go_tc_app fuel visited_tcs tc tc_args + CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' - | otherwise - = NonRecursiveOrUnsure + AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a + -- See Note [Detecting recursive data constructors], point (D) + FunTy{} -> NonRecursiveOrUnsure + -- See Note [Detecting recursive data constructors], point (1) + + -- (TyVarTy{} | LitTy{} | CastTy{}) + _ -> NonRecursiveOrUnsure + go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult go_tc_app fuel visited_tcs tc tc_args = case tyConDataCons_maybe tc of - --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined + ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args -- This is the only place where we look at tc_args, which might have -- See Note [Detecting recursive data constructors], point (C) and (5) diff --git a/GHC/Core/PatSyn.hs b/GHC/Core/PatSyn.hs --- a/GHC/Core/PatSyn.hs +++ b/GHC/Core/PatSyn.hs @@ -12,7 +12,8 @@ PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn, -- ** Type deconstruction - patSynName, patSynArity, patSynIsInfix, patSynResultType, + patSynName, patSynArity, patSynVisArity, + patSynIsInfix, patSynResultType, isVanillaPatSyn, patSynArgs, patSynMatcher, patSynBuilder, @@ -421,6 +422,13 @@ -- | Arity of the pattern synonym patSynArity :: PatSyn -> Arity patSynArity = psArity + +-- | Number of visible arguments of the pattern synonym +patSynVisArity :: PatSyn -> VisArity +patSynVisArity ps = n_of_required_ty_args + n_of_val_args + where + n_of_val_args = psArity ps + n_of_required_ty_args = 0 -- no visible forall in pattern synonyms yet (#23704) -- | Is this a \'vanilla\' pattern synonym (no existentials, no provided constraints)? isVanillaPatSyn :: PatSyn -> Bool diff --git a/GHC/Core/Ppr.hs b/GHC/Core/Ppr.hs --- a/GHC/Core/Ppr.hs +++ b/GHC/Core/Ppr.hs @@ -44,7 +44,6 @@ import GHC.Core.TyCo.Ppr import GHC.Core.Coercion import GHC.Types.Basic -import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.SrcLoc ( pprUserRealSpan ) @@ -140,8 +139,8 @@ pp_val_bdr = pprPrefixOcc val_bdr pp_bind = case bndrIsJoin_maybe val_bdr of - Nothing -> pp_normal_bind - Just ar -> pp_join_bind ar + NotJoinPoint -> pp_normal_bind + JoinPoint ar -> pp_join_bind ar pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr) @@ -240,7 +239,13 @@ _ -> parens (hang (pprParendExpr fun) 2 pp_args) } -ppr_expr add_par (Case expr var ty [Alt con args rhs]) +ppr_expr add_par (Case expr _ ty []) -- Empty Case + = add_par $ sep [text "case" + <+> pprCoreExpr expr + <+> whenPprDebug (text "return" <+> ppr ty), + text "of {}"] + +ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case = sdocOption sdocPrintCaseAsLet $ \case True -> add_par $ -- See Note [Print case as let] sep [ sep [ text "let! {" @@ -264,7 +269,7 @@ where ppr_bndr = pprBndr CaseBind -ppr_expr add_par (Case expr var ty alts) +ppr_expr add_par (Case expr var ty alts) -- Multi alt Case = add_par $ sep [sep [text "case" <+> pprCoreExpr expr @@ -306,12 +311,12 @@ pprCoreExpr expr] where keyword (NonRec b _) - | isJust (bndrIsJoin_maybe b) = text "join" - | otherwise = text "let" + | isJoinPoint (bndrIsJoin_maybe b) = text "join" + | otherwise = text "let" keyword (Rec pairs) | ((b,_):_) <- pairs - , isJust (bndrIsJoin_maybe b) = text "joinrec" - | otherwise = text "letrec" + , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec" + | otherwise = text "letrec" ppr_expr add_par (Tick tickish expr) = sdocOption sdocSuppressTicks $ \case @@ -382,13 +387,13 @@ pprBndr = pprCoreBinder pprInfixOcc = pprInfixName . varName pprPrefixOcc = pprPrefixName . varName - bndrIsJoin_maybe = isJoinId_maybe + bndrIsJoin_maybe = idJoinPointHood instance Outputable b => OutputableBndr (TaggedBndr b) where pprBndr _ b = ppr b -- Simple pprInfixOcc b = ppr b pprPrefixOcc b = ppr b - bndrIsJoin_maybe (TB b _) = isJoinId_maybe b + bndrIsJoin_maybe (TB b _) = idJoinPointHood b pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc pprOcc Infix = pprInfixOcc @@ -689,9 +694,10 @@ ppr modl, comma, ppr ix, text ">"] - ppr (Breakpoint _ext ix vars) = + ppr (Breakpoint _ext bid vars) = hcat [text "break<", - ppr ix, + ppr (bi_tick_mod bid), comma, + ppr (bi_tick_index bid), text ">", parens (hcat (punctuate comma (map ppr vars)))] ppr (ProfNote { profNoteCC = cc, diff --git a/GHC/Core/Predicate.hs b/GHC/Core/Predicate.hs --- a/GHC/Core/Predicate.hs +++ b/GHC/Core/Predicate.hs @@ -8,50 +8,117 @@ module GHC.Core.Predicate ( Pred(..), classifyPredType, - isPredTy, isEvVarType, + isPredTy, isSimplePredTy, -- Equality predicates EqRel(..), eqRelRole, - isEqPrimPred, isEqPred, + isEqPred, isReprEqPred, isEqClassPred, isCoVarType, getEqPredTys, getEqPredTys_maybe, getEqPredRole, - predTypeEqRel, - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - mkNomPrimEqPred, + predTypeEqRel, pprPredType, + mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole, -- Class predicates mkClassPred, isDictTy, typeDeterminesValue, - isClassPred, isEqualityClass, isCTupleClass, + isClassPred, isEqualityClass, isCTupleClass, isUnaryClass, getClassPredTys, getClassPredTys_maybe, classMethodTy, classMethodInstTy, -- Implicit parameters - isIPLikePred, mentionsIP, isIPTyCon, isIPClass, + couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, decomposeIPPred, isCallStackTy, isCallStackPred, isCallStackPredTy, + isExceptionContextPred, isExceptionContextTy, isIPPred_maybe, -- Evidence variables - DictId, isEvVar, isDictId + DictId, isEvId, isDictId, + -- * Well-scoped free variables + scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, + + -- Equality left-hand sides + CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe, + canEqLHSKind, canEqLHSType, eqCanEqLHS + ) where import GHC.Prelude import GHC.Core.Type import GHC.Core.Class -import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCo.Compare( tcEqTyConApps ) +import GHC.Core.TyCo.FVs( tyCoVarsOfTypeList, tyCoVarsOfTypesList ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk +import GHC.Types.Name( getOccName ) import GHC.Types.Var -import GHC.Core.Coercion +import GHC.Types.Var.Set import GHC.Core.Multiplicity ( scaledThing ) import GHC.Builtin.Names +import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.FastString + +{- ********************************************************************* +* * +* Pred and PredType * +* * +********************************************************************* -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "predicate" or "predicate type", + type synonym `PredType` + returns True to `isPredTy` +is any type of kind (CONSTRAINT r) for some `r`. + + (a) A "class predicate" (aka dictionary type) is the type of a (boxed) + type-class dictionary + Test: isDictTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) An "equality predicate" is a primitive, unboxed equalities + Test: isEqPred + Binders: CoVars (can appear in coercions) + Kind: CONSTRAINT (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) A "simple predicate type" is either a class predicate or an equality predicate + Test: isSimplePredTy + Kind: Constraint or CONSTRAINT (TupleRep []) + Examples: all coercion types and dictionary types + + (d) A "forall-predicate" is the type of a possibly-polymorphic function + returning a predicate; e.g. + forall a. Eq a => Eq [a] + + (e) An "irred predicate" is any other type of kind (CONSTRAINT r), + typically something like `c` or `c Int`, for some suitably-kinded `c` + + +* Predicates are classified by `classifyPredType`. + +* Equality types and dictionary types are mutually exclusive. + +* Predicates are the things solved by the constraint solver; and + /evidence terms/ witness those solutions. An /evidence variable/ + (or EvId) has a type that is a PredType. + +* Generally speaking, the /type/ of a predicate determines its /value/; + that is, predicates are singleton types. The big exception is implicit + parameters. See Note [Type determines value] + +* In a FunTy { ft_af = af }, where af = FTF_C_T or FTF_C_C, + the argument type is always a Predicate type. +-} + -- | A predicate in the solver. The solver tries to prove Wanted predicates -- from Given ones. data Pred @@ -59,7 +126,7 @@ -- | A typeclass predicate. = ClassPred Class [Type] - -- | A type equality predicate. + -- | A type equality predicate, (t1 ~#N t2) or (t1 ~#R t2) | EqPred EqRel Type Type -- | An irreducible predicate. @@ -73,45 +140,138 @@ -- NB: There is no TuplePred case -- Tuple predicates like (Eq a, Ord b) are just treated -- as ClassPred, as if we had a tuple class with two superclasses - -- class (c1, c2) => (%,%) c1 c2 + -- class (c1, c2) => CTuple2 c1 c2 -classifyPredType :: PredType -> Pred -classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of - Just (tc, [_, _, ty1, ty2]) - | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 - | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 +classifyPredType :: HasDebugCallStack => PredType -> Pred +-- Precondition: the argument is a predicate type, with kind (CONSTRAINT _) +classifyPredType ev_ty + = assertPpr (isPredTy ev_ty) (ppr ev_ty) $ + case splitTyConApp_maybe ev_ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 + | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 - Just (tc, tys) - | Just clas <- tyConClass_maybe tc - -> ClassPred clas tys + Just (tc, tys) + | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys - _ | (tvs, rho) <- splitForAllTyCoVars ev_ty - , (theta, pred) <- splitFunTys rho - , not (null tvs && null theta) - -> ForAllPred tvs (map scaledThing theta) pred + _ | (tvs, rho) <- splitForAllTyCoVars ev_ty + , (theta, pred) <- splitFunTys rho + , not (null tvs && null theta) + -> ForAllPred tvs (map scaledThing theta) pred - | otherwise - -> IrredPred ev_ty + | otherwise + -> IrredPred ev_ty --- --------------------- Dictionary types --------------------------------- +isSimplePredTy :: HasDebugCallStack => Type -> Bool +-- Return True for (t1 ~# t2) regardless of role, and (C tys) +-- /Not/ true of quantified-predicate type like (forall a. Eq a => Eq [a]) +-- Precondition: expects a type that classifies values (i.e. not a type constructor) +-- See Note [Types for coercions, predicates, and evidence] +isSimplePredTy ty + = case tyConAppTyCon_maybe ty of + Nothing -> False + Just tc -> isClassTyCon tc || + tc `hasKey` eqPrimTyConKey || + tc `hasKey` eqReprPrimTyConKey +isPredTy :: Type -> Bool +-- True of all types of kind (CONSTRAINT r) for some `r` +-- See Note [Types for coercions, predicates, and evidence] +-- +-- In particular it is True of +-- - the constraints handled by the constraint solver, +-- including quantified constraints +-- - dictionary functions (forall a. Eq a => Eq [a]) +isPredTy ty = case typeTypeOrConstraint ty of + TypeLike -> False + ConstraintLike -> True + +typeDeterminesValue :: PredType -> Bool +-- ^ Is the type *guaranteed* to determine the value? +-- Might say No even if the type does determine the value. +-- See Note [Type determines value] +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty) + + +{- +Note [Evidence for quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks +taking a quantified constraint like + (forall a. C a => a ~ b) +and generate superclass evidence + (forall a. C a => a ~# b) + +This is a funny thing: neither isPredTy nor isCoVarType are true +of it. So we are careful not to generate it in the first place: +see Note [Equality superclasses in quantified constraints] +in GHC.Tc.Solver.Dict. +-} + +-- --------------------- Equality predicates --------------------------------- + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" +isEqPred :: PredType -> Bool +-- True of (s ~# t) (s ~R# t) +-- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coecible s t) +isEqPred ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +isCoVarType :: Type -> Bool +-- Just a synonym for isEqPred +isCoVarType = isEqPred + +isReprEqPred :: PredType -> Bool +-- True of (s ~R# t) +isReprEqPred ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +-- --------------------- Class predicates --------------------------------- + mkClassPred :: Class -> [Type] -> PredType mkClassPred clas tys = mkTyConApp (classTyCon clas) tys +isClassPred :: PredType -> Bool +isClassPred ty = case tyConAppTyCon_maybe ty of + Just tc -> isClassTyCon tc + _ -> False + isDictTy :: Type -> Bool --- True of dictionaries (Eq a) and --- dictionary functions (forall a. Eq a => Eq [a]) --- See Note [Type determines value] --- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs) --- for why it's important to catch dictionary bindings -isDictTy ty = isClassPred pred - where - (_, pred) = splitInvisPiTys ty +isDictTy = isClassPred -typeDeterminesValue :: Type -> Bool --- See Note [Type determines value] -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) +isEqClassPred :: PredType -> Bool +isEqClassPred ty -- True of (s ~ t) and (s ~~ t) + -- ToDo: should we check saturation? + | Just tc <- tyConAppTyCon_maybe ty + , Just cls <- tyConClass_maybe tc + = isEqualityClass cls + | otherwise + = False +isEqualityClass :: Class -> Bool +-- True of (~), (~~), and Coercible +-- These all have a single primitive-equality superclass, either (~N# or ~R#) +isEqualityClass cls + = cls `hasKey` heqTyConKey + || cls `hasKey` eqTyConKey + || cls `hasKey` coercibleTyConKey + +isCTupleClass :: Class -> Bool +isCTupleClass cls = isTupleTyCon (classTyCon cls) + +isUnaryClass :: Class -> Bool +isUnaryClass cls = isUnaryClassTyCon (classTyCon cls) + getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of Just (clas, tys) -> (clas, tys) @@ -153,6 +313,10 @@ purposes of specialisation. Note that we still want to specialise functions with implicit params if they have *other* dicts which are class params; see #17930. + +It's also not always possible to infer that a type determines the value +if type families are in play. See #19747 for one such example. + -} -- --------------------- Equality predicates --------------------------------- @@ -170,6 +334,37 @@ eqRelRole NomEq = Nominal eqRelRole ReprEq = Representational +-- | Creates a primitive nominal type equality predicate. +-- t1 ~# t2 +-- Invariant: the types are not Coercions +mkNomEqPred :: Type -> Type -> Type +mkNomEqPred ty1 ty2 + = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Creates a primitive representational type equality predicate. +-- t1 ~R# t2 +-- Invariant: the types are not Coercions +mkReprEqPred :: Type -> Type -> Type +mkReprEqPred ty1 ty2 + = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Makes a lifted equality predicate at the given role +mkEqPred :: EqRel -> Type -> Type -> PredType +mkEqPred NomEq = mkNomEqPred +mkEqPred ReprEq = mkReprEqPred + +-- | Makes a lifted equality predicate at the given role +mkEqPredRole :: Role -> Type -> Type -> PredType +mkEqPredRole Nominal = mkNomEqPred +mkEqPredRole Representational = mkReprEqPred +mkEqPredRole Phantom = panic "mkEqPred phantom" + getEqPredTys :: PredType -> (Type, Type) getEqPredTys ty = case splitTyConApp_maybe ty of @@ -188,71 +383,26 @@ _ -> Nothing getEqPredRole :: PredType -> Role +-- Precondition: the PredType is (s ~#N t) or (s ~#R t) getEqPredRole ty = eqRelRole (predTypeEqRel ty) --- | Get the equality relation relevant for a pred type. +-- | Get the equality relation relevant for a pred type +-- Returns NomEq for dictionary predicates, etc predTypeEqRel :: PredType -> EqRel predTypeEqRel ty - | Just (tc, _) <- splitTyConApp_maybe ty - , tc `hasKey` eqReprPrimTyConKey - = ReprEq - | otherwise - = NomEq - -{------------------------------------------- -Predicates on PredType ---------------------------------------------} - -{- -Note [Evidence for quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks -taking a quantified constraint like - (forall a. C a => a ~ b) -and generate superclass evidence - (forall a. C a => a ~# b) - -This is a funny thing: neither isPredTy nor isCoVarType are true -of it. So we are careful not to generate it in the first place: -see Note [Equality superclasses in quantified constraints] -in GHC.Tc.Solver.Dict. --} - -isEvVarType :: Type -> Bool --- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b) --- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2) --- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep --- See Note [Evidence for quantified constraints] -isEvVarType ty = isCoVarType ty || isPredTy ty - -isClassPred :: PredType -> Bool -isClassPred ty = case tyConAppTyCon_maybe ty of - Just tc -> isClassTyCon tc - _ -> False - -isEqPred :: PredType -> Bool -isEqPred ty -- True of (a ~ b) and (a ~~ b) - -- ToDo: should we check saturation? - | Just tc <- tyConAppTyCon_maybe ty - , Just cls <- tyConClass_maybe tc - = isEqualityClass cls - | otherwise - = False - -isEqPrimPred :: PredType -> Bool -isEqPrimPred ty = isCoVarType ty - -- True of (a ~# b) (a ~R# b) - -isEqualityClass :: Class -> Bool --- True of (~), (~~), and Coercible --- These all have a single primitive-equality superclass, either (~N# or ~R#) -isEqualityClass cls - = cls `hasKey` heqTyConKey - || cls `hasKey` eqTyConKey - || cls `hasKey` coercibleTyConKey + | isReprEqPred ty = ReprEq + | otherwise = NomEq -isCTupleClass :: Class -> Bool -isCTupleClass cls = isTupleTyCon (classTyCon cls) +pprPredType :: PredType -> SDoc +-- Special case for (t1 ~# t2) and (t1 ~R# t2) +pprPredType pred + = case classifyPredType pred of + EqPred eq_rel t1 t2 -> sep [ ppr t1, ppr (getOccName eq_tc) <+> ppr t2 ] + where + eq_tc = case eq_rel of + NomEq -> eqPrimTyCon + ReprEq -> eqReprPrimTyCon + _ -> ppr pred {- ********************************************************************* * * @@ -260,6 +410,8 @@ * * ********************************************************************* -} +-- --------------------- Nomal implicit-parameter predicates --------------- + isIPTyCon :: TyCon -> Bool isIPTyCon tc = tc `hasKey` ipClassKey -- Class and its corresponding TyCon have the same Unique @@ -277,6 +429,40 @@ | otherwise = Nothing +-- | Take a type (IP sym ty), where IP is the built in IP class +-- and return (ip, MkIP, [sym,ty]), where +-- `ip` is the class-op for class IP +-- `MkIP` is the data constructor for class IP +decomposeIPPred :: Type -> (Id, [Type]) +decomposeIPPred ty + | Just (cls, tys) <- getClassPredTys_maybe ty + , [ip_op] <- classMethods cls + = assertPpr (isIPClass cls && isUnaryClass cls) (ppr ty) $ + (ip_op, tys) + | otherwise = pprPanic "decomposeIP" (ppr ty) + +-- --------------------- ExceptionContext predicates -------------------------- + +-- | Is a 'PredType' an @ExceptionContext@ implicit parameter? +-- +-- If so, return the name of the parameter. +isExceptionContextPred :: Class -> [Type] -> Maybe FastString +isExceptionContextPred cls tys + | [ty1, ty2] <- tys + , isIPClass cls + , isExceptionContextTy ty2 + = isStrLitTy ty1 + | otherwise + = Nothing + +-- | Is a type an 'ExceptionContext'? +isExceptionContextTy :: Type -> Bool +isExceptionContextTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` exceptionContextTyConKey + | otherwise + = False + -- --------------------- CallStack predicates --------------------------------- isCallStackPredTy :: Type -> Bool @@ -309,37 +495,44 @@ | otherwise = False --- --------------------- isIPLike and mentionsIP -------------------------- +-- --------------------- couldBeIPLike and mightMentionIP -------------------------- -- See Note [Local implicit parameters] -isIPLikePred :: Type -> Bool +couldBeIPLike :: Type -> Bool -- Is `pred`, or any of its superclasses, an implicit parameter? -- See Note [Local implicit parameters] -isIPLikePred pred = mentions_ip_pred initIPRecTc Nothing pred +couldBeIPLike pred + = might_mention_ip1 initIPRecTc (const True) (const True) pred -mentionsIP :: Type -> Class -> [Type] -> Bool --- Is (cls tys) an implicit parameter with key `str_ty`, or --- is any of its superclasses such at thing. +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string + -> (Type -> Bool) -- ^ predicate on the type + -> Class + -> [Type] -> Bool +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if: +-- +-- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@ +-- are both @True@, +-- - or any superclass of @cls tys@ has this property. +-- -- See Note [Local implicit parameters] -mentionsIP str_ty cls tys = mentions_ip initIPRecTc (Just str_ty) cls tys +mightMentionIP = might_mention_ip initIPRecTc -mentions_ip :: RecTcChecker -> Maybe Type -> Class -> [Type] -> Bool -mentions_ip rec_clss mb_str_ty cls tys - | Just (str_ty', _) <- isIPPred_maybe cls tys - = case mb_str_ty of - Nothing -> True - Just str_ty -> str_ty `eqType` str_ty' +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool +might_mention_ip rec_clss str_cond ty_cond cls tys + | Just (str_ty, ty) <- isIPPred_maybe cls tys + = str_cond str_ty && ty_cond ty | otherwise - = or [ mentions_ip_pred rec_clss mb_str_ty (classMethodInstTy sc_sel_id tys) + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) | sc_sel_id <- classSCSelIds cls ] -mentions_ip_pred :: RecTcChecker -> Maybe Type -> Type -> Bool -mentions_ip_pred rec_clss mb_str_ty ty + +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool +might_mention_ip1 rec_clss str_cond ty_cond ty | Just (cls, tys) <- getClassPredTys_maybe ty , let tc = classTyCon cls , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss else checkRecTc rec_clss tc - = mentions_ip rec_clss' mb_str_ty cls tys + = might_mention_ip rec_clss' str_cond ty_cond cls tys | otherwise = False -- Includes things like (D []) where D is -- a Constraint-ranged family; #7785 @@ -352,7 +545,7 @@ See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict. -The function isIPLikePred tells if this predicate, or any of its +The function couldBeIPLike tells if this predicate, or any of its superclasses, is an implicit parameter. Why are implicit parameters special? Unlike normal classes, we can @@ -360,7 +553,7 @@ let ?x = True in ... So in various places we must be careful not to assume that any value of the right type will do; we must carefully look for the innermost binding. -So isIPLikePred checks whether this is an implicit parameter, or has +So couldBeIPLike checks whether this is an implicit parameter, or has a superclass that is an implicit parameter. Several wrinkles @@ -401,21 +594,219 @@ think nothing does. * I'm a little concerned about type variables; such a variable might be instantiated to an implicit parameter. I don't think this - matters in the cases for which isIPLikePred is used, and it's pretty + matters in the cases for which couldBeIPLike is used, and it's pretty obscure anyway. * The superclass hunt stops when it encounters the same class again, but in principle we could have the same class, differently instantiated, and the second time it could have an implicit parameter -I'm going to treat these as problems for another day. They are all exotic. -} +I'm going to treat these as problems for another day. They are all exotic. +Note [Using typesAreApart when calling mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We call 'mightMentionIP' in two situations: + + (1) to check that a predicate does not contain any implicit parameters + IP str ty, for a fixed literal str and any type ty, + (2) to check that a predicate does not contain any HasCallStack or + HasExceptionContext constraints. + +In both of these cases, we want to be sure, so we should be conservative: + + For (1), the predicate might contain an implicit parameter IP Str a, where + Str is a type family such as: + + type family MyStr where MyStr = "abc" + + To safeguard against this (niche) situation, instead of doing a simple + type equality check, we use 'typesAreApart'. This allows us to recognise + that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'. + + For (2), we similarly might have + + type family MyCallStack where MyCallStack = CallStack + + Again, here we use 'typesAreApart'. This allows us to see that + + (?foo :: MyCallStack) + + is indeed a CallStack constraint, hidden under a type family. +-} + {- ********************************************************************* * * Evidence variables * * ********************************************************************* -} -isEvVar :: Var -> Bool -isEvVar var = isEvVarType (varType var) +isEvId :: Var -> Bool +isEvId var = isPredTy (varType var) isDictId :: Id -> Bool isDictId id = isDictTy (varType id) + + +{- ********************************************************************* +* * + scopedSort + + This function lives here becuase it uses isEvId +* * +********************************************************************* -} + +{- Note [ScopedSort] +~~~~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given @[ a::k, k::Type, b::k ]@ +-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@. +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType" + +scopedSort :: [Var] -> [Var] +scopedSort = go [] [] + where + go :: [Var] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted Var's types + + -- This list is in 1-to-1 correspondence with the sorted Vars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [Var] -- yet to be sorted + -> [Var] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: Var -- var to insert + -> [Var] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([Var], [TyCoVarSet]) -- augmented lists + -- Generally we put the new Var at the front of the accumulating list + -- (leading to a stable sort) unless there is are reason to put it later. + insert v [] [] = ([v], [tyCoVarsOfType (varType v)]) + insert v (a:as) (fvs:fvss) + | (isTyVar v && isId a) || -- TyVars precede Ids + (isEvId v && isId a && not (isEvId a)) || -- DictIds precede non-DictIds + (v `elemVarSet` fvs) + -- (a) put Ids after TyVars, and (b) respect dependencies + , (as', fvss') <- insert v as fvss + = (a:as', fvs `unionVarSet` fv_v : fvss') + + | otherwise -- Put `v` at the front + = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss) + where + fv_v = tyCoVarsOfType (varType v) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + + +{- ********************************************************************* +* * +* Equality left-hand sides +* * +********************************************************************* -} + +-- | A 'CanEqLHS' is a type that can appear on the left of a canonical +-- equality: a type variable or /exactly-saturated/ type family application. +data CanEqLHS + = TyVarLHS TyVar + | TyFamLHS TyCon -- ^ TyCon of the family + [Type] -- ^ Arguments, /exactly saturating/ the family + +instance Outputable CanEqLHS where + ppr (TyVarLHS tv) = ppr tv + ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args) + +----------------------------------- +-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated +-- type family application? +-- Does not look through type synonyms. +canEqLHS_maybe :: Type -> Maybe CanEqLHS +canEqLHS_maybe xi + | Just tv <- getTyVar_maybe xi + = Just $ TyVarLHS tv + + | otherwise + = canTyFamEqLHS_maybe xi + +canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS +canTyFamEqLHS_maybe xi + | Just (tc, args) <- tcSplitTyConApp_maybe xi + , isTypeFamilyTyCon tc + , args `lengthIs` tyConArity tc + = Just $ TyFamLHS tc args + + | otherwise + = Nothing + +-- | Convert a 'CanEqLHS' back into a 'Type' +canEqLHSType :: CanEqLHS -> Type +canEqLHSType (TyVarLHS tv) = mkTyVarTy tv +canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args + +-- | Retrieve the kind of a 'CanEqLHS' +canEqLHSKind :: CanEqLHS -> Kind +canEqLHSKind (TyVarLHS tv) = tyVarKind tv +canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args + +-- | Are two 'CanEqLHS's equal? +eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool +eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2 +eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2) + = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2 +eqCanEqLHS _ _ = False + diff --git a/GHC/Core/Reduction.hs b/GHC/Core/Reduction.hs --- a/GHC/Core/Reduction.hs +++ b/GHC/Core/Reduction.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} module GHC.Core.Reduction ( @@ -376,7 +373,7 @@ -> Reduction mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty) = mkReduction - (mkForAllCo tv1 h co) + (mkForAllCo tv1 vis vis h co) (mkForAllTy (Bndr tv2 vis) ty) where tv2 = setTyVarKind tv1 ki' @@ -389,7 +386,7 @@ mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction mkHomoForAllRedn bndrs (Reduction co ty) = mkReduction - (mkHomoForAllCos (binderVars bndrs) co) + (mkHomoForAllCos bndrs co) (mkForAllTys bndrs ty) {-# INLINE mkHomoForAllRedn #-} diff --git a/GHC/Core/RoughMap.hs b/GHC/Core/RoughMap.hs --- a/GHC/Core/RoughMap.hs +++ b/GHC/Core/RoughMap.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} - -- | 'RoughMap' is an approximate finite map data structure keyed on -- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's -- (e.g. an instance head). diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs --- a/GHC/Core/Rules.hs +++ b/GHC/Core/Rules.hs @@ -9,7 +9,7 @@ -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( -- ** Looking up rules - lookupRule, + lookupRule, matchExprs, ruleLhsIsMoreSpecific, -- ** RuleBase, RuleEnv RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, @@ -30,7 +30,8 @@ rulesOfBinds, getRules, pprRulesForUser, -- * Making rules - mkRule, mkSpecRule, roughTopNames + mkRule, mkSpecRule, roughTopNames, + ruleIsOrphan ) where @@ -48,7 +49,7 @@ import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, bindFreeVars - , rulesFreeVarsDSet, exprsOrphNames ) + , rulesFreeVarsDSet, orphNamesOfExprs ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind, mkCastMCo ) @@ -86,6 +87,7 @@ import GHC.Data.Bag import GHC.Data.List.SetOps( hasNoDups ) +import GHC.Utils.FV( filterFV, fvVarSet ) import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic @@ -206,7 +208,7 @@ -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables -- mentioned on its left-hand side are locally defined - lhs_names = extendNameSet (exprsOrphNames args) fn + lhs_names = extendNameSet (orphNamesOfExprs args) fn -- Since rules get eventually attached to one of the free names -- from the definition when compiling the ABI hash, we should make @@ -220,9 +222,9 @@ -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- Make a specialisation rule, for Specialise or SpecConstr mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity rule - Nothing -> rule + = case idJoinPointHood fn of + JoinPoint join_arity -> etaExpandToJoinPointRule join_arity rule + NotJoinPoint -> rule where rule = mkRule this_mod is_auto is_local rule_name @@ -443,23 +445,39 @@ getRules :: RuleEnv -> Id -> [CoreRule] -- Given a RuleEnv and an Id, find the visible rules for that Id -- See Note [Where rules are found] -getRules (RuleEnv { re_local_rules = local_rules - , re_home_rules = home_rules - , re_eps_rules = eps_rules +-- +-- This function is quite heavily used, so it's worth trying to make it efficient +getRules (RuleEnv { re_local_rules = local_rule_base + , re_home_rules = home_rule_base + , re_eps_rules = eps_rule_base , re_visible_orphs = orphs }) fn | Just {} <- isDataConId_maybe fn -- Short cut for data constructor workers = [] -- and wrappers, which never have any rules - | otherwise - = idCoreRules fn ++ - get local_rules ++ - find_visible home_rules ++ - find_visible eps_rules + | Just export_flag <- isLocalId_maybe fn + = -- LocalIds can't have rules in the local_rule_base (used for imported fns) + -- nor external packages; but there can (just) be rules in another module + -- in the home package, if it is exported + case export_flag of + NotExported -> idCoreRules fn + Exported -> case get home_rule_base of + [] -> idCoreRules fn + home_rules -> drop_orphs home_rules ++ idCoreRules fn + | otherwise + = -- This case expression is a fast path, to avoid calling the + -- recursive (++) in the common case where there are no rules at all + case (get local_rule_base, get home_rule_base, get eps_rule_base) of + ([], [], []) -> idCoreRules fn + (local_rules, home_rules, eps_rules) -> local_rules ++ + drop_orphs home_rules ++ + drop_orphs eps_rules ++ + idCoreRules fn where fn_name = idName fn - find_visible rb = filter (ruleIsVisible orphs) (get rb) + drop_orphs [] = [] -- Fast path; avoid invoking recursive filter + drop_orphs xs = filter (ruleIsVisible orphs) xs get rb = lookupNameEnv rb fn_name `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool @@ -467,6 +485,10 @@ ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } = notOrphan orph || origin `elemModuleSet` vis_orphs +ruleIsOrphan :: CoreRule -> Bool +ruleIsOrphan (BuiltinRule {}) = False +ruleIsOrphan (Rule { ru_orphan = orph }) = isOrphan orph + {- Note [Where rules are found] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The rules for an Id come from two places: @@ -521,7 +543,8 @@ -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful. -lookupRule :: RuleOpts -> InScopeEnv +lookupRule :: HasDebugCallStack + => RuleOpts -> InScopeEnv -> (Activation -> Bool) -- When rule is active -> Id -- Function head -> [CoreExpr] -- Args @@ -551,7 +574,7 @@ = go ((r,mkTicks ticks e):ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$ - -- ppr [ (arg_id, unfoldingTemplate unf) + -- ppr [ (arg_id, maybeUnfoldingTemplate unf) -- | Var arg_id <- args -- , let unf = idUnfolding arg_id -- , isCheapUnfolding unf] ) @@ -565,8 +588,8 @@ findBest _ _ (rule,ans) [] = (rule,ans) findBest in_scope target (rule1,ans1) ((rule2,ans2):prs) - | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs - | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs + | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs + | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs | debugIsOn = let pp_rule rule = ifPprDebug (ppr rule) (doubleQuotes (ftext (ruleName rule))) @@ -581,17 +604,25 @@ where (fn,args) = target -isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool --- The call (rule1 `isMoreSpecific` rule2) +ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool +-- The call (rule1 `ruleIsMoreSpecific` rule2) -- sees if rule2 can be instantiated to look like rule1 --- See Note [isMoreSpecific] -isMoreSpecific _ (BuiltinRule {}) _ = False -isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True -isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 }) - (Rule { ru_bndrs = bndrs2, ru_args = args2 - , ru_name = rule_name2, ru_rhs = rhs2 }) - = isJust (matchN in_scope_env - rule_name2 bndrs2 args2 args1 rhs2) +-- See Note [ruleIsMoreSpecific] +ruleIsMoreSpecific in_scope rule1 rule2 + = case rule1 of + BuiltinRule {} -> False + Rule { ru_bndrs = bndrs1, ru_args = args1 } + -> ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2 + +ruleLhsIsMoreSpecific :: InScopeSet + -> [Var] -> [CoreExpr] -- LHS of a possible new rule + -> CoreRule -- An existing rule + -> Bool -- New one is more specific +ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2 + = case rule2 of + BuiltinRule {} -> True + Rule { ru_bndrs = bndrs2, ru_args = args2 } + -> isJust (matchExprs in_scope_env bndrs2 args2 args1) where full_in_scope = in_scope `extendInScopeSetList` bndrs1 in_scope_env = ISE full_in_scope noUnfoldingFun @@ -600,9 +631,9 @@ noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -{- Note [isMoreSpecific] +{- Note [ruleIsMoreSpecific] ~~~~~~~~~~~~~~~~~~~~~~~~ -The call (rule1 `isMoreSpecific` rule2) +The call (rule1 `ruleIsMoreSpecific` rule2) sees if rule2 can be instantiated to look like rule1. Wrinkle: @@ -645,7 +676,8 @@ -} ------------------------------------ -matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) +matchRule :: HasDebugCallStack + => RuleOpts -> InScopeEnv -> (Activation -> Bool) -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -690,7 +722,8 @@ --------------------------------------- -matchN :: InScopeEnv +matchN :: HasDebugCallStack + => InScopeEnv -> RuleName -> [Var] -> [CoreExpr] -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template -> Maybe CoreExpr @@ -704,15 +737,24 @@ -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs +matchN ise _rule_name tmpl_vars tmpl_es target_es rhs + = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es + ; return (bind_wrapper $ + mkLams tmpl_vars rhs `mkApps` matched_es) } + +matchExprs :: HasDebugCallStack + => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] + -> Maybe (BindWrapper, [CoreExpr]) -- 1-1 with the [Var] +matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 - bind_wrapper = rs_binds rule_subst + + ; let bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] - ; return (bind_wrapper $ - mkLams tmpl_vars rhs `mkApps` matched_es) } + + ; return (bind_wrapper, matched_es) } where (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars -- See Note [Cloning the template binders] @@ -723,7 +765,7 @@ , rv_unf = id_unf } lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) - -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + -- Need to return a RuleSubst solely for the benefit of fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) | isId tmpl_var1 @@ -752,13 +794,13 @@ unbound tmpl_var = pprPanic "Template variable unbound in rewrite rule" $ vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) - , text "Rule" <+> pprRuleName rule_name , text "Rule bndrs:" <+> ppr tmpl_vars , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] ---------------------- -match_exprs :: RuleMatchEnv -> RuleSubst +match_exprs :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst -> [CoreExpr] -- Templates -> [CoreExpr] -- Targets -> Maybe RuleSubst @@ -798,7 +840,7 @@ The rule looks like forall (a::*) (d::Eq Char) (x :: Foo a Char). - f (Foo a Char) d x = True + f @(Foo a Char) d x = True Matching the rule won't bind 'a', and legitimately so. We fudge by pretending that 'a' is bound to (Any :: *). @@ -944,49 +986,83 @@ but the Simplifer pushes the casts in an application to to the right, if it can, so this doesn't really arise. -Note [Coercion arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~ -What if we have (f co) in the template, where the 'co' is a coercion -argument to f? Right now we have nothing in place to ensure that a -coercion /argument/ in the template is a variable. We really should, -perhaps by abstracting over that variable. - -C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. - -For now, though, we simply behave badly, by failing in match_co. -We really should never rely on matching the structure of a coercion -(which is just a proof). - Note [Casts in the template] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the definition +This Note concerns `matchTemplateCast`. Consider the definition f x = e, and SpecConstr on call pattern f ((e1,e2) |> co) -We'll make a RULE +The danger is that We'll make a RULE RULE forall a,b,g. f ((a,b)|> g) = $sf a b g $sf a b g = e[ ((a,b)|> g) / x ] -So here is the invariant: +This requires the rule-matcher to bind the coercion variable `g`. +That is Very Deeply Suspicious: - In the template, in a cast (e |> co), - the cast `co` is always a /variable/. +* It would be unreasonable to match on a structured coercion in a pattern, + such as RULE forall g. f (x |> Sym g) = ... + because the strucure of a coercion is arbitrary and may change -- it's their + /type/ that matters. -Matching should bind that variable to an actual coercion, so that we -can use it in $sf. So a Cast on the LHS (the template) calls -match_co, which succeeds when the template cast is a variable -- which -it always is. That is why match_co has so few cases. +* We considered insisting that in a template, in a cast (e |> co), the the cast + `co` is always a /variable/ cv. That looks a bit more plausible, but #23209 + (and related tickets) shows that it's very fragile. For example suppose `e` + is a variable `f`, and the simplifier has an unconditional substitution + [f :-> g |> co2] + Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more! +In short, it is Very Deeply Suspicious for a rule to quantify over a coercion +variable. And SpecConstr no longer does so: see Note [SpecConstr and casts] in +SpecConstr. + +Wrinkles: + +(CT0) It is, however, OK for a cast to appear in a template provided the cast mentions + none of the template variables. For example + newtype N a = MkN (a,a) -- Axiom ax:N a :: (a,a) ~R N a + f :: N a -> bah + RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ... + When matching we can just move these casts to the other side: + match (tmpl |> co) tgt --> match tmpl (tgt |> sym co) + See matchTemplateCast. + +(CT1) We need to be careful about scoping, and to match left-to-right, so that we + know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we + can apply that substitition + +(CT2) Annoyingly, we still want support one case in which the RULE quantifies + over a coercion variable: the dreaded map/coerce RULE. + See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt. + + Since that can happen, matchTemplateCast laboriously checks whether the + coercion mentions a template coercion variable; and if so does the Very Deeply + Suspicious `match_co` instead. It works fine for map/coerce, where the + coercion is always a variable and will (robustly) remain so. + See also * Note [Coercion arguments] * Note [Matching coercion variables] in GHC.Core.Unify. * Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils: sm_cast_swizzle is switched off in the template of a RULE + +Note [Coercion arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~ +What if we have (f (Coercion co)) in the template, where the 'co' is a coercion +argument to f? Right now we have nothing in place to ensure that a +coercion /argument/ in the template is a variable. We really should, +perhaps by abstracting over that variable. + +C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs. + +For now, though, we simply behave badly, by failing in match_co. +We really should never rely on matching the structure of a coercion +(which is just a proof). -} ---------------------- -match :: RuleMatchEnv +match :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst -- Substitution applies to template only -> CoreExpr -- Template -> CoreExpr -- Target @@ -1044,14 +1120,7 @@ -- This is important: see Note [Cancel reflexive casts] match renv subst (Cast e1 co1) e2 mco - = -- See Note [Casts in the template] - do { let co2 = case mco of - MRefl -> mkRepReflCo (exprType e2) - MCo co2 -> co2 - ; subst1 <- match_co renv subst co1 co2 - -- If match_co succeeds, then (exprType e1) = (exprType e2) - -- Hence the MRefl in the next line - ; match renv subst1 e1 e2 MRefl } + = matchTemplateCast renv subst e1 co1 e2 mco ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco @@ -1191,7 +1260,7 @@ [f :-> \x p. p*p] but that is fine. -(W2) This wrinkle concerns the overlp between the new HOP rule and the existing +(W2) This wrinkle concerns the overlap between the new HOP rule and the existing decompose-application rule. See 3.1 of GHC Proposal #555 for a discussion. Consider potential match: @@ -1229,7 +1298,7 @@ f (\(MkT @b (d::Num b) (x::b)) -> h @b d x) = ... where the HOP is (h @b d x). In principle this might be possible, but it seems fragile; e.g. we would still need to insist that the (invisible) - @b was a type variable. And since `h` gets a polymoprhic type, that + @b was a type variable. And since `h` gets a polymorphic type, that type would have to be declared by the programmer. Maybe one day. But for now, we insist (in `arg_as_lcl_var`)that a HOP @@ -1274,7 +1343,7 @@ in_scope_env = ISE in_scope (rv_unf renv) -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily -- a superset of the free vars of e2; it is only guaranteed a superset of - -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe + -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe -- wants an in-scope set that includes all the free vars of its argument. -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630) , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 @@ -1433,6 +1502,41 @@ -} ------------- +matchTemplateCast + :: RuleMatchEnv -> RuleSubst + -> CoreExpr -> Coercion + -> CoreExpr -> MCoercion + -> Maybe RuleSubst +matchTemplateCast renv subst e1 co1 e2 mco + | isEmptyVarSet $ fvVarSet $ + filterFV (`elemVarSet` rv_tmpls renv) $ -- Check that the coercion does not + tyCoFVsOfCo substed_co -- mention any of the template variables + = -- This is the good path + -- See Note [Casts in the template] wrinkle (CT0) + match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co))) + + | otherwise + = -- This is the Deeply Suspicious Path + -- See Note [Casts in the template] + do { let co2 = case mco of + MRefl -> mkRepReflCo (exprType e2) + MCo co2 -> co2 + ; subst1 <- match_co renv subst co1 co2 + -- If match_co succeeds, then (exprType e1) = (exprType e2) + -- Hence the MRefl in the next line + ; match renv subst1 e1 e2 MRefl } + where + substed_co = substCo current_subst co1 + + current_subst :: Subst + current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv)) + (rs_tv_subst subst) + emptyCvSubstEnv + -- emptyCvSubstEnv: ugh! + -- If there were any CoVar substitutions they would be in + -- rs_id_subst; but we don't expect there to be any; see + -- Note [Casts in the template] + match_co :: RuleMatchEnv -> RuleSubst -> Coercion @@ -1495,7 +1599,8 @@ not_captured fv = not (inRnEnvR rn_env fv) ------------------------------------------ -match_var :: RuleMatchEnv +match_var :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -1531,7 +1636,8 @@ -- template x, so we must rename first! ------------------------------------------ -match_tmpl_var :: RuleMatchEnv +match_tmpl_var :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target diff --git a/GHC/Core/Rules/Config.hs b/GHC/Core/Rules/Config.hs --- a/GHC/Core/Rules/Config.hs +++ b/GHC/Core/Rules/Config.hs @@ -5,9 +5,15 @@ -- | Rule options data RuleOpts = RuleOpts - { roPlatform :: !Platform -- ^ Target platform - , roNumConstantFolding :: !Bool -- ^ Enable more advanced numeric constant folding - , roExcessRationalPrecision :: !Bool -- ^ Cut down precision of Rational values to that of Float/Double if disabled - , roBignumRules :: !Bool -- ^ Enable rules for bignums + { roPlatform :: !Platform + -- ^ Target platform + , roNumConstantFolding :: !Bool + -- ^ Enable constant folding through nested expressions. + -- + -- See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold + , roExcessRationalPrecision :: !Bool + -- ^ Cut down precision of Rational values to that of Float/Double if disabled + , roBignumRules :: !Bool + -- ^ Enable rules for bignums } diff --git a/GHC/Core/SimpleOpt.hs b/GHC/Core/SimpleOpt.hs --- a/GHC/Core/SimpleOpt.hs +++ b/GHC/Core/SimpleOpt.hs @@ -8,7 +8,7 @@ SimpleOpts (..), defaultSimpleOpts, -- ** Simple expression optimiser - simpleOptPgm, simpleOptExpr, simpleOptExprWith, + simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith, -- ** Join points joinPointBinding_maybe, joinPointBindings_maybe, @@ -29,28 +29,32 @@ import GHC.Core.Unfold.Make import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) +import GHC.Core.DataCon +import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) +import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import GHC.Core.Predicate( isCoVarType ) +import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) + import GHC.Types.Literal import GHC.Types.Id import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) ) import GHC.Types.Var ( isNonCoVarId ) import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Core.DataCon import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) import GHC.Types.Tickish -import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) -import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Types.Basic + import GHC.Builtin.Types import GHC.Builtin.Names -import GHC.Types.Basic + import GHC.Unit.Module ( Module ) import GHC.Utils.Encoding import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc + import GHC.Data.Maybe ( orElse ) import GHC.Data.Graph.UnVar import Data.List (mapAccumL) @@ -85,6 +89,24 @@ expression. In fact, the simple optimiser is a good example of this little dance in action; the full Simplifier is a lot more complicated. +Note [The InScopeSet for simpleOptExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Care must be taken to remove unfoldings from `Var`s collected by exprFreeVars +before using them to construct an in-scope set hence `zapIdUnfolding` in `init_subst`. +Consider calling `simpleOptExpr` on an expression like + +``` + case x of (a,b) -> (x,a) +``` + +* One of those two occurrences of x has an unfolding (the one in (x,a), with +unfolding x = (a,b)) and the other does not. (Inside a case GHC adds +unfolding-info to the scrutinee's Id.) +* But exprFreeVars just builds a set, so it's a bit random which occurrence is collected. +* Then simpleOptExpr replaces each occurrence of x with the one in the in-scope set. +* Bad bad bad: then the x in case x of ... may be replaced with a version that has an unfolding. + +See ticket #25790 -} -- | Simple optimiser options @@ -92,6 +114,8 @@ { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options , so_eta_red :: !Bool -- ^ Eta reduction on? + , so_inline :: !Bool -- ^ False <=> do no inlining whatsoever, + -- even for trivial or used-once things } -- | Default options for the Simple optimiser. @@ -100,6 +124,7 @@ { so_uf_opts = defaultUnfoldingOpts , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } , so_eta_red = False + , so_inline = True } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -131,17 +156,23 @@ = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) simpleOptExprWith opts init_subst expr where - init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) - -- It's potentially important to make a proper in-scope set - -- Consider let x = ..y.. in \y. ...x... - -- Then we should remember to clone y before substituting - -- for x. It's very unlikely to occur, because we probably - -- won't *be* substituting for x if it occurs inside a - -- lambda. - -- + init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr))) + -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr] + -- It's a bit painful to call exprFreeVars, because it makes -- three passes instead of two (occ-anal, and go) +simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr +-- A variant of simpleOptExpr, but without +-- occurrence analysis or inlining of any kind. +-- Result: we don't inline evidence bindings, which is useful for the specialiser +simpleOptExprNoInline opts expr + = simple_opt_expr init_env expr + where + init_opts = opts { so_inline = False } + init_env = (emptyEnv init_opts) { soe_subst = init_subst } + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser] simpleOptExprWith opts subst expr @@ -215,7 +246,7 @@ = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst } soeInScope :: SimpleOptEnv -> InScopeSet -soeInScope (SOE { soe_subst = subst }) = getSubstInScope subst +soeInScope (SOE { soe_subst = subst }) = substInScopeSet subst soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv soeSetInScope in_scope env2@(SOE { soe_subst = subst2 }) @@ -229,7 +260,7 @@ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} --------------- -simple_opt_clo :: HasCallStack +simple_opt_clo :: HasDebugCallStack => InScopeSet -> SimpleClo -> OutExpr @@ -242,7 +273,7 @@ where rec_ids = soe_rec_ids env subst = soe_subst env - in_scope = getSubstInScope subst + in_scope = substInScopeSet subst in_scope_env = ISE in_scope alwaysActiveUnfoldingFun --------------- @@ -264,7 +295,6 @@ go lam@(Lam {}) = go_lam env [] lam go (Case e b ty as) - -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' -- We don't need to be concerned about floats when looking for coerce. @@ -274,7 +304,7 @@ _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs where (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ - zipEqual "simpleOptExpr" bs es + zipEqual bs es -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b @@ -336,10 +366,12 @@ = simple_app (soeSetInScope (soeInScope env) env') e as | let unf = idUnfolding v - , isCompulsoryUnfolding (idUnfolding v) + , isCompulsoryUnfolding unf , isAlwaysActive (idInlineActivation v) -- See Note [Unfold compulsory unfoldings in RULE LHSs] - = simple_app (soeZapSubst env) (unfoldingTemplate unf) as + , Just rhs <- maybeUnfoldingTemplate unf + -- Always succeeds if isCompulsoryUnfolding does + = simple_app (soeZapSubst env) rhs as | otherwise , let out_fn = lookupIdSubst (soe_subst env) v @@ -400,7 +432,7 @@ simple_app env e as = finish_app env (simple_opt_expr env e) as -finish_app :: HasCallStack +finish_app :: HasDebugCallStack => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -- See Note [Eliminate casts in function position] finish_app env (Cast (Lam x e) co) as@(_:_) @@ -450,7 +482,7 @@ -- (simple_bind_pair subst in_var out_rhs) -- either extends subst with (in_var -> out_rhs) -- or returns Nothing -simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) +simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts }) in_bndr mb_out_bndr clo@(rhs_env, in_rhs) top_level | Type ty <- in_rhs -- let a::* = TYPE ty in @@ -476,9 +508,9 @@ stable_unf = isStableUnfolding (idUnfolding in_bndr) active = isAlwaysActive (idInlineActivation in_bndr) occ = idOccInfo in_bndr - in_scope = getSubstInScope subst + in_scope = substInScopeSet subst - out_rhs | Just join_arity <- isJoinId_maybe in_bndr + out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr = simple_join_rhs join_arity | otherwise = simple_opt_clo in_scope clo @@ -492,6 +524,7 @@ pre_inline_unconditionally :: Bool pre_inline_unconditionally + | not (so_inline opts) = False -- Not if so_inline is False | isExportedId in_bndr = False | stable_unf = False | not active = False -- Note [Inline prag in simplOpt] @@ -514,6 +547,12 @@ = exprIsTrivial rhs -- Can duplicate || safe_to_inline (idOccInfo bndr) -- Occurs at most once +do_case_elim :: CoreExpr -> Id -> [Id] -> Bool +do_case_elim scrut case_bndr alt_bndrs + = exprIsHNF scrut + && safe_to_inline (idOccInfo case_bndr) + && all isDeadBinder alt_bndrs + ------------------- simple_out_bind :: TopLevelFlag -> SimpleOptEnv @@ -537,13 +576,14 @@ -> InId -> Maybe OutId -> OutExpr -> OccInfo -> Bool -> Bool -> TopLevelFlag -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) -simple_out_bind_pair env in_bndr mb_out_bndr out_rhs +simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts }) + in_bndr mb_out_bndr out_rhs occ_info active stable_unf top_level | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr) -- Type and coercion bindings are caught earlier -- See Note [Core type and coercion invariant] post_inline_unconditionally - = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } + = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs } , Nothing) | otherwise @@ -556,6 +596,7 @@ post_inline_unconditionally :: Bool post_inline_unconditionally + | not (so_inline opts) = False -- Not if so_inline is False | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] | not active = False -- in GHC.Core.Opt.Simplify.Utils @@ -768,6 +809,7 @@ unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc (isTopLevel top_level) False -- may be bottom or not + False -- Not a join point new_rhs Nothing wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr @@ -822,35 +864,39 @@ This matches literal uses of `map coerce` in code, but that's not what we want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) -too. Some of this is addressed by compulsorily unfolding coerce on the LHS, -yielding +too. Achieving all this is surprisingly tricky: - forall a b (dict :: Coercible * a b). - map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... +(MC1) We must compulsorily unfold MkAge to a cast. + See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -Getting better. But this isn't exactly what gets produced. This is because -Coercible essentially has ~R# as a superclass, and superclasses get eagerly -extracted during solving. So we get this: +(MC2) We must compulsorily unfold coerce on the rule LHS, yielding + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... - forall a b (dict :: Coercible * a b). - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = ... + Getting better. But this isn't exactly what gets produced. This is because + Coercible essentially has ~R# as a superclass, and superclasses get eagerly + extracted during solving. So we get this: -Unfortunately, this still abstracts over a Coercible dictionary. We really -want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, -which transforms the above to (see also Note [Desugaring coerce as cast] in -Desugar) + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... - forall a b (co :: a ~R# b). - let dict = MkCoercible @* @a @b co in - case Coercible_SCSel @* @a @b dict of - _ [Dead] -> map @a @b (\(x :: a) -> case dict of - MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + Unfortunately, this still abstracts over a Coercible dictionary. We really + want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, + which transforms the above to -Now, we need simpleOptExpr to fix this up. It does so by taking three -separate actions: + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + + See Note [Desugaring coerce as cast] in GHC.HsToCore + +(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three + separate actions: 1. Inline certain non-recursive bindings. The choice whether to inline is made in simple_bind_pair. Note the rather specific check for MkCoercible in there. @@ -862,6 +908,10 @@ just packed and inline them. This is also done in simple_opt_expr's `go` function. +(MC4) The map/coerce rule is the only compelling reason for having a RULE that + quantifies over a coercion variable, something that is otherwise Very Deeply + Suspicious. See Note [Casts in the template] in GHC.Core.Rules. Ugh! + This is all a fair amount of special-purpose hackery, but it's for a good cause. And it won't hurt other RULES and such that it comes across. @@ -1206,7 +1256,7 @@ This Note exists solely to document the problem. -} -data ConCont = CC [CoreExpr] Coercion +data ConCont = CC [CoreExpr] MCoercion -- Substitution already applied -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument @@ -1228,7 +1278,7 @@ => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) exprIsConApp_maybe ise@(ISE in_scope id_unf) expr - = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) + = go (Left in_scope) [] expr (CC [] MRefl) where go :: Either InScopeSet Subst -- Left in-scope means "empty substitution" @@ -1241,14 +1291,12 @@ go subst floats (Tick t expr) cont | not (tickishIsCode t) = go subst floats expr cont - go subst floats (Cast expr co1) (CC args co2) + go subst floats (Cast expr co1) (CC args m_co2) | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args -- See Note [Push coercions in exprIsConApp_maybe] - = case m_co1' of - MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) - MRefl -> go subst floats expr (CC args' co2) + = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2)) - go subst floats (App fun arg) (CC args co) + go subst floats (App fun arg) (CC args mco) | let arg_type = exprType arg , not (isTypeArg arg) && needsCaseBinding arg_type arg -- An unlifted argument that’s not ok for speculation must not simply be @@ -1267,21 +1315,18 @@ -- simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec -- Good: returning (Mk#, [x]) with a float of case exp of x { DEFAULT -> [] } -- simplifier produces case exp of a { DEFAULT -> exp[x/a] } - = let arg' = subst_expr subst arg - bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type) - float = FloatCase arg' bndr DEFAULT [] - subst' = subst_extend_in_scope subst bndr - in go subst' (float:floats) fun (CC (Var bndr : args) co) + , (subst', float, bndr) <- case_bind subst arg arg_type + = go subst' (float:floats) fun (CC (Var bndr : args) mco) | otherwise - = go subst floats fun (CC (subst_expr subst arg : args) co) + = go subst floats fun (CC (subst_expr subst arg : args) mco) - go subst floats (Lam bndr body) (CC (arg:args) co) + go subst floats (Lam bndr body) (CC (arg:args) mco) | do_beta_by_substitution bndr arg - = go (extend subst bndr arg) floats body (CC args co) + = go (extend subst bndr arg) floats body (CC args mco) | otherwise = let (subst', bndr') = subst_bndr subst bndr float = FloatLet (NonRec bndr' arg) - in go subst' (float:floats) body (CC args co) + in go subst' (float:floats) body (CC args mco) go subst floats (Let (NonRec bndr rhs) expr) cont | not (isJoinId bndr) @@ -1292,33 +1337,38 @@ in go subst' (float:floats) expr cont go subst floats (Case scrut b _ [Alt con vars expr]) cont + | do_case_elim scrut' b vars -- See Note [Case elim in exprIsConApp_maybe] + = go (extend subst b scrut') floats expr cont + | otherwise = let - scrut' = subst_expr subst scrut (subst', b') = subst_bndr subst b (subst'', vars') = subst_bndrs subst' vars float = FloatCase scrut' b' con vars' in go subst'' (float:floats) expr cont + where + scrut' = subst_expr subst scrut go (Right sub) floats (Var v) cont - = go (Left (getSubstInScope sub)) + = go (Left (substInScopeSet sub)) floats (lookupIdSubst sub v) cont - go (Left in_scope) floats (Var fun) cont@(CC args co) + go (Left in_scope) floats (Var fun) cont@(CC args mco) | Just con <- isDataConWorkId_maybe fun , count isValArg args == idArity fun - = succeedWith in_scope floats $ - pushCoDataCon con args co + , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args + -- mkFieldSeqFloats: See (SFC2) in Note [Strict fields in Core] + = succeedWith in_scope' (seq_floats ++ floats) $ + pushCoDataCon con args' mco -- Look through data constructor wrappers: they inline late (See Note -- [Activation for data constructor wrappers]) but we want to do -- case-of-known-constructor optimisation eagerly (see Note -- [exprIsConApp_maybe on data constructors with wrappers]). - | isDataConWrapId fun - , let rhs = uf_tmpl (realIdUnfolding fun) + | Just rhs <- dataConWrapUnfolding_maybe fun = go (Left in_scope) floats rhs cont -- Look through dictionary functions; see Note [Unfolding DFuns] @@ -1331,7 +1381,7 @@ -- simplOptExpr initialises the in-scope set with exprFreeVars, -- but that doesn't account for DFun unfoldings = succeedWith in_scope floats $ - pushCoDataCon con (map (substExpr subst) dfun_args) co + pushCoDataCon con (map (substExpr subst) dfun_args) mco -- Look through unfoldings, but only arity-zero one; -- if arity > 0 we are effectively inlining a function call, @@ -1349,7 +1399,7 @@ , [arg] <- args , Just (LitString str) <- exprIsLiteral_maybe ise arg = succeedWith in_scope floats $ - dealWithStringLiteral fun str co + dealWithStringLiteral fun str mco where unfolding = id_unf fun extend_in_scope unf_fvs @@ -1373,7 +1423,7 @@ -- The Left case is wildly dominant subst_in_scope (Left in_scope) = in_scope - subst_in_scope (Right s) = getSubstInScope s + subst_in_scope (Right s) = substInScopeSet s subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v) subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v) @@ -1397,17 +1447,49 @@ extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) extend (Right s) v e = Right (extendSubst s v e) + case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id) + case_bind subst expr expr_ty = (subst', float, bndr) + where + bndr = setCaseBndrEvald MarkedStrict $ + uniqAway (subst_in_scope subst) $ + mkWildValBinder ManyTy expr_ty + subst' = subst_extend_in_scope subst bndr + expr' = subst_expr subst expr + float = FloatCase expr' bndr DEFAULT [] + mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr]) + -- See Note [Strict fields in Core] for what a field seq is and (SFC2) for + -- why we insert them + mkFieldSeqFloats in_scope dc args + | isLazyDataConRep dc + = (in_scope, [], args) + | otherwise + = (in_scope', floats', ty_args ++ val_args') + where + (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args + (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual str_marks val_args + str_marks = dataConRepStrictness dc + do_one (str, arg) (in_scope,floats,args) + | NotMarkedStrict <- str = no_seq + | exprIsHNF arg = no_seq + | otherwise = (in_scope', float:floats, Var bndr:args) + where + no_seq = (in_scope, floats, arg:args) + (in_scope', float, bndr) = + case case_bind (Left in_scope) arg (exprType arg) of + (Left in_scope', float, bndr) -> (in_scope', float, bndr) + (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right) + -- See Note [exprIsConApp_maybe on literal strings] -dealWithStringLiteral :: Var -> BS.ByteString -> Coercion +dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion -> Maybe (DataCon, [Type], [CoreExpr]) -- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS -- turns those into [] automatically, but just in case something else in GHC -- generates a string literal directly. -dealWithStringLiteral fun str co = +dealWithStringLiteral fun str mco = case utf8UnconsByteString str of - Nothing -> pushCoDataCon nilDataCon [Type charTy] co + Nothing -> pushCoDataCon nilDataCon [Type charTy] mco Just (char, charTail) -> let char_expr = mkConApp charDataCon [mkCharLit char] -- In singleton strings, just add [] instead of unpackCstring# ""#. @@ -1416,9 +1498,30 @@ else App (Var fun) (Lit (LitString charTail)) - in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co + in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco {- +Note [Case elim in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data K a = MkK !a + + $WMkK x = case x of y -> K y -- Wrapper for MkK + + ...case $WMkK v of K w -> + +We call `exprIsConApp_maybe` on ($WMkK v); we inline the wrapper +and beta-reduce, so we get to + exprIsConApp_maybe (case v of y -> K y) + +So we may float the case, and end up with + case v of y -> [y/w] + +But if `v` is already evaluated, the next run of the Simplifier will +eliminate the case, and we may then make more progress with . +Better to do it in one iteration. Hence the `do_case_elim` +check in `exprIsConApp_maybe`. + Note [Unfolding DFuns] ~~~~~~~~~~~~~~~~~~~~~~ DFuns look like diff --git a/GHC/Core/Stats.hs b/GHC/Core/Stats.hs --- a/GHC/Core/Stats.hs +++ b/GHC/Core/Stats.hs @@ -98,7 +98,7 @@ coStats co = zeroCS { cs_co = coercionSize co } coreBindsSize :: [CoreBind] -> Int --- We use coreBindStats for user printout +-- We use coreBindsStats for user printout -- but this one is a quick and dirty basis for -- the simplifier's tick limit coreBindsSize bs = sum (map bindSize bs) diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs --- a/GHC/Core/Subst.hs +++ b/GHC/Core/Subst.hs @@ -19,18 +19,19 @@ substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst, + emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendIdSubstWithClone, extendSubst, extendSubstList, extendSubstWithVar, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, - isInScope, setInScope, getSubstInScope, + isInScope, setInScope, substInScopeSet, extendTvSubst, extendCvSubst, delBndr, delBndrs, zapSubst, -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + cloneBndrsM, cloneRecIdBndrsM, ) where @@ -61,7 +62,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL) @@ -163,12 +163,14 @@ -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst extendSubst subst var arg = case arg of - Type ty -> assert (isTyVar var) $ extendTvSubst subst var ty - Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co - _ -> assert (isId var) $ extendIdSubst subst var arg + Type ty -> assertPpr (isTyVar var) doc $ extendTvSubst subst var ty + Coercion co -> assertPpr (isCoVar var) doc $ extendCvSubst subst var co + _ -> assertPpr (isId var) doc $ extendIdSubst subst var arg + where + doc = ppr var <+> text ":=" <+> ppr arg extendSubstWithVar :: Subst -> Var -> Var -> Subst extendSubstWithVar subst v1 v2 @@ -239,8 +241,7 @@ -- their canonical representatives in the in-scope set substExprSC subst orig_expr | isEmptySubst subst = orig_expr - | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ - substExpr subst orig_expr + | otherwise = substExpr subst orig_expr -- | substExpr applies a substitution to an entire 'CoreExpr'. Remember, -- you may only apply the substitution /once/: @@ -371,7 +372,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ - (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_env tvs cvs, new_id) + (Subst new_in_scope new_env tvs cvs, new_id) where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 @@ -385,14 +386,16 @@ -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with -- rec_subst, when dealing with a mutually-recursive group - new_id = maybeModifyIdInfo mb_new_info id2 + !new_id = maybeModifyIdInfo mb_new_info id2 mb_new_info = substIdInfo rec_subst id2 (idInfo id2) -- NB: unfolding info may be zapped -- Extend the substitution if the unique has changed -- See the notes with substTyVarBndr for the delVarEnv - new_env | no_change = delVarEnv env old_id - | otherwise = extendVarEnv env old_id (Var new_id) + !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id + -- Forcing new_in_scope improves T9675 by 1.7% + !new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) no_change = id1 == old_id -- See Note [Extending the IdSubstEnv] @@ -417,25 +420,32 @@ cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) -cloneBndrs :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var]) +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) -- Works for all kinds of variables (typically case binders) -- not just Ids -cloneBndrs subst vs - = do us <- getUniquesM - pure $ mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` us) +cloneBndrs subst us vs + = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) +cloneBndrsM :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrsM subst vs = cloneBndrs subst `flip` vs <$> getUniqueSupplyM + cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) cloneBndr subst uniq v | isTyVar v = cloneTyVarBndr subst v uniq | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too -- | Clone a mutually recursive group of 'Id's -cloneRecIdBndrs :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id]) -cloneRecIdBndrs subst ids - = do us <- getUniquesM - let (subst', ids') = mapAccumL (clone_id subst') subst (ids `zip` us) - pure (subst', ids') +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids = + let x@(subst', _) = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us) + in x +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrsM :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id]) +cloneRecIdBndrsM subst ids = cloneRecIdBndrs subst `flip` ids <$> getUniqueSupplyM + -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use -- Discards non-Stable unfoldings @@ -444,13 +454,15 @@ -> (Subst, Id) -- Transformed pair clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) - = (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) + = (Subst new_in_scope new_idvs tvs new_cvs, new_id) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 - new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 - (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) - | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) + !new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 + !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id + -- Forcing new_in_scope improves T9675 by 1.7% + (!new_idvs, !new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) + | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) {- ************************************************************************ @@ -479,7 +491,7 @@ -- in a Note in the id's type itself where old_ty = idType id - old_w = varMult id + old_w = idMult id ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. @@ -587,13 +599,13 @@ = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc | otherwise , let fv_expr = lookupIdSubst subst fv - = exprFVs fv_expr (const True) emptyVarSet $! acc + = exprLocalFVs fv_expr (const True) emptyVarSet $! acc ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish -substTickish subst (Breakpoint ext n ids) - = Breakpoint ext n (mapMaybe do_one ids) +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) where do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst diff --git a/GHC/Core/Tidy.hs b/GHC/Core/Tidy.hs --- a/GHC/Core/Tidy.hs +++ b/GHC/Core/Tidy.hs @@ -16,12 +16,12 @@ import GHC.Core import GHC.Core.Type - +import GHC.Core.TyCo.Tidy import GHC.Core.Seq ( seqUnfolding ) + import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd ) -import GHC.Core.Coercion ( tidyCo ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Unique (getUnique) @@ -30,6 +30,7 @@ import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Types.Tickish + import GHC.Data.Maybe import GHC.Utils.Misc import Data.List (mapAccumL) @@ -132,7 +133,7 @@ -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs - | is_wkr_like || isJust mb_join_id + | is_wkr_like || isJoinPoint mb_join_id , valid_unlifted_worker val_args = -- pprTrace "computeCbvInfo" -- (text "fun" <+> ppr fun_id $$ @@ -147,14 +148,14 @@ | otherwise = fun_id where - mb_join_id = isJoinId_maybe fun_id + mb_join_id = idJoinPointHood fun_id is_wkr_like = isWorkerLikeId fun_id val_args = filter isId lam_bndrs -- When computing CbvMarks, we limit the arity of join points to -- the JoinArity, because that's the arity we are going to use -- when calling it. There may be more lambdas than that on the RHS. - lam_bndrs | Just join_arity <- mb_join_id + lam_bndrs | JoinPoint join_arity <- mb_join_id = fst $ collectNBinders join_arity rhs | otherwise = fst $ collectBinders rhs @@ -234,8 +235,8 @@ ------------ Tickish -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish -tidyTickish env (Breakpoint ext ix ids) - = Breakpoint ext ix (map (tidyVarOcc env) ids) +tidyTickish env (Breakpoint ext bid ids) + = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- @@ -430,7 +431,7 @@ Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we -must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make. +must preserve this info in inlinings. See Note [oneShot magic] in GHC.Types.Id.Make. This applies to lambda binders only, hence it is stored in IfaceLamBndr. -} diff --git a/GHC/Core/TyCo/Compare.hs b/GHC/Core/TyCo/Compare.hs --- a/GHC/Core/TyCo/Compare.hs +++ b/GHC/Core/TyCo/Compare.hs @@ -7,14 +7,17 @@ -- | Type equality and comparison module GHC.Core.TyCo.Compare ( - -- * Type comparison - eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, - nonDetCmpTypesX, nonDetCmpTc, + -- * Type equality + eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes, eqVarBndrs, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - tcEqTyConApps, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, + tcEqTyConApps, tcEqTyConAppArgs, + mayLookIdentical, + -- * Type comparison + nonDetCmpType, + -- * Visiblity comparision eqForAllVis, cmpForAllVis @@ -22,15 +25,18 @@ import GHC.Prelude -import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe ) +import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe + , isLevityTy, isRuntimeRepTy, isMultiplicityTy ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCon +import GHC.Core.Multiplicity( MultiplicityFlag(..) ) import GHC.Types.Var import GHC.Types.Unique import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Utils.Outputable import GHC.Utils.Misc @@ -50,7 +56,11 @@ {- ********************************************************************* * * - Type equality + Type equality + + We don't use (==) from class Eq, partly so that we know where + type equality is called, and partly because there are multiple + variants. * * ********************************************************************* -} @@ -70,15 +80,134 @@ * See Historical Note [Typechecker equality vs definitional equality] below +Note [Casts and coercions in type comparision] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As (EQTYPE) in Note [Non-trivial definitional equality] says, our +general plan, implemented by `fullEq`, is: + (1) ignore both casts and coercions when comparing types, + (2) instead, compare the /kinds/ of the two types, + as well as the types themselves + +If possible we want to avoid step (2), comparing the kinds; doing so involves +calling `typeKind` and doing another comparision. + +When can we avoid doing so? Answer: we can certainly avoid doing so if the +types we are comparing have no casts or coercions. But we can do better. +Consider + eqType (TyConApp T [s1, ..., sn]) (TyConApp T [t1, .., tn]) +We are going to call (eqType s1 t1), (eqType s2 t2) etc. + +The kinds of `s1` and `t1` must be equal, because these TyConApps are well-kinded, +and both TyConApps are headed by the same T. So the first recursive call to `eqType` +certainly doesn't need to check kinds. If that call returns False, we stop. Otherwise, +we know that `s1` and `t1` are themselves equal (not just their kinds). This +makes the kinds of `s2` and `t2` to be equal, because those kinds come from the +kind of T instantiated with `s1` and `t1` -- which are the same. Thus we do not +need to check the kinds of `s2` and `t2`. By induction, we don't need to check +the kinds of *any* of the types in a TyConApp, and we also do not need to check +the kinds of the TyConApps themselves. + +Conclusion: + +* casts and coercions under a TyConApp don't matter -- even including type synonyms + +* In step (2), use `hasCasts` to tell if there are any casts to worry about. It + does not look very deep, because TyConApps and FunTys are so common, and it + doesn't allocate. The only recursive cases are AppTy and ForAllTy. + +Alternative implementation. Instead of `hasCasts`, we could make the +generic_eq_type function return + data EqResult = NotEq | EqWithNoCasts | EqWithCasts +Practically free; but stylistically I prefer useing `hasCasts`: + * `generic_eq_type` can just uses familiar booleans + * There is a lot more branching with the three-value variant. + * It separates concerns. No need to think about cast-tracking when doing the + equality comparison. + * Indeed sometimes we omit the kind check unconditionally, so tracking it is just wasted + work. +I did try both; there was no perceptible perf difference so I chose `hasCasts` version. + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +Note [Comparing type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the task of testing equality between two 'Type's of the form + + TyConApp tc tys1 = TyConApp tc tys2 + +where `tc` is a type synonym. A naive way to perform this comparison these +would first expand the synonym and then compare the resulting expansions. + +However, this is obviously wasteful and the RHS of `tc` may be large. We'd +prefer to compare `tys1 = tys2`. When is that sound? Precisely when the +synonym is not /forgetful/; that is, all its type variables appear in its +RHS -- see `GHC.Core.TyCon.isForgetfulSynTyCon`. + +Of course, if we find that the TyCons are *not* equal then we still need to +perform the expansion as their RHSs may still be equal. + +This works fine for /equality/, but not for /comparison/. Consider + type S a b = (b, a) +Now consider + S Int Bool `compare` S Char Char +The ordering may depend on whether we expand the synonym or not, and we +don't want the result to depend on that. So for comparison we stick to +/nullary/ synonyms only, which is still useful. + +We perform this optimisation in a number of places: + + * GHC.Core.TyCo.Compare.eqType (works for non-nullary synonyms) + * GHC.Core.Map.TYpe.eqDeBruijnType (works for non-nullary synonyms) + * GHC.Core.Types.nonDetCmpType (nullary only) + +This optimisation is especially helpful for the ubiquitous GHC.Types.Type, +since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications +whenever possible. See Note [Using synonyms to compress types] in +GHC.Core.Type for details. + +Currently-missed opportunity (#25009): +* In the case of forgetful synonyms, we could still compare the args, pairwise, + and then compare the RHS's with a suitably extended RnEnv2. That would avoid + comparing the same arg repeatedly. e.g. + type S a b = (a,a) + Compare S y ~ S y + If we expand, we end up compare with itself twice. + + But since forgetful synonyms are rare, we have not tried this. + Note [Type comparisons using object pointer comparisons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Quite often we substitute the type from a definition site into -occurances without a change. This means for code like: +occurrences without a change. This means for code like: \x -> (x,x,x) The type of every `x` will often be represented by a single object in the heap. We can take advantage of this by shortcutting the equality check if two types are represented by the same pointer under the hood. In some cases this reduces compiler allocations by ~2%. + +See Note [Pointer comparison operations] in GHC.Builtin.primops.txt.pp + +Note [Respecting multiplicity when comparing types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, we respect multiplicities (i.e. the linear part of the type +system) when comparing types. Doing so is of course crucial during typechecking. + +But for reasons described in Note [Linting linearity] in GHC.Core.Lint, it is hard +to ensure that Core is always type-correct when it comes to linearity. So +* `eqTypeIgnoringMultiplicity` provides a way to compare types that /ignores/ multiplicities +* We use this multiplicity-blind comparison very occasionally, notably + - in Core Lint: see Note [Linting linearity] in GHC.Core.Lint + - in rule matching: see Note [Rewrite rules ignore multiplicities in FunTy] + in GHC.Core.Unify -} @@ -86,151 +215,249 @@ tcEqKind = tcEqType tcEqType :: HasDebugCallStack => Type -> Type -> Bool --- ^ tcEqType implements typechecker equality --- It behaves just like eqType, but is implemented --- differently (for now) -tcEqType ty1 ty2 - = tcEqTypeNoSyns ki1 ki2 - && tcEqTypeNoSyns ty1 ty2 - where - ki1 = typeKind ty1 - ki2 = typeKind ty2 +tcEqType = eqType -- | Just like 'tcEqType', but will return True for types of different kinds -- as long as their non-coercion structure is identical. tcEqTypeNoKindCheck :: Type -> Type -> Bool -tcEqTypeNoKindCheck ty1 ty2 - = tcEqTypeNoSyns ty1 ty2 +tcEqTypeNoKindCheck = eqTypeNoKindCheck -- | Check whether two TyConApps are the same; if the number of arguments -- are different, just checks the common prefix of arguments. tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool tcEqTyConApps tc1 args1 tc2 args2 - = tc1 == tc2 && - and (zipWith tcEqTypeNoKindCheck args1 args2) + = tc1 == tc2 && tcEqTyConAppArgs args1 args2 + +tcEqTyConAppArgs :: [Type] -> [Type] -> Bool +-- Args do not have to have equal length; +-- we discard the excess of the longer one +tcEqTyConAppArgs args1 args2 + = and (zipWith tcEqTypeNoKindCheck args1 args2) -- No kind check necessary: if both arguments are well typed, then -- any difference in the kinds of later arguments would show up -- as differences in earlier (dependent) arguments -{- -Note [Specialising tc_eq_type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type equality predicates in Type are hit pretty hard during typechecking. -Consequently we take pains to ensure that these paths are compiled to -efficient, minimally-allocating code. +-- | Type equality on lists of types, looking through type synonyms +eqTypes :: [Type] -> [Type] -> Bool +eqTypes [] [] = True +eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2 +eqTypes _ _ = False -To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into -its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating -some dynamic branches, this allows the simplifier to eliminate the closure -allocations that would otherwise be necessary to capture the two boolean "mode" -flags. This reduces allocations by a good fraction of a percent when compiling -Cabal. +eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing -See #19226. --} +initRnEnv :: Type -> Type -> RnEnv2 +initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $ + tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb --- | Type equality comparing both visible and invisible arguments and expanding --- type synonyms. -tcEqTypeNoSyns :: Type -> Type -> Bool -tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb +eqTypeNoKindCheck :: Type -> Type -> Bool +eqTypeNoKindCheck ty1 ty2 = eq_type_expand_respect ty1 ty2 --- | Like 'tcEqType', but returns True if the /visible/ part of the types --- are equal, even if they are really unequal (in the invisible bits) -tcEqTypeVis :: Type -> Type -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 +-- | Type equality comparing both visible and invisible arguments, +-- expanding synonyms and respecting multiplicities. +eqType :: HasCallStack => Type -> Type -> Bool +eqType ta tb = fullEq eq_type_expand_respect ta tb +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool +eqTypeX env ta tb = fullEq (eq_type_expand_respect_x env) ta tb + +eqTypeIgnoringMultiplicity :: Type -> Type -> Bool +-- See Note [Respecting multiplicity when comparing types] +eqTypeIgnoringMultiplicity ta tb = fullEq eq_type_expand_ignore ta tb + -- | Like 'pickyEqTypeVis', but returns a Bool for convenience pickyEqType :: Type -> Type -> Bool -- Check when two types _look_ the same, _including_ synonyms. -- So (pickyEqType String [Char]) returns False -- This ignores kinds and coercions, because this is used only for printing. -pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 +pickyEqType ta tb = eq_type_keep_respect ta tb --- | Real worker for 'tcEqType'. No kind check! -tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms - -> Bool -- ^ True <=> compare visible args only - -> Type -> Type - -> Bool --- Flags False, False is the usual setting for tc_eq_type +{- Note [Specialising type equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type equality predicates in Type are hit pretty hard by GHC. Consequently +we take pains to ensure that these paths are compiled to efficient, +minimally-allocating code. Plan: + +* The main workhorse is `inline_generic_eq_type_x`. It is /non-recursive/ + and is marked INLINE. + +* `inline_generic_eq_type_x` has various parameters that control what it does: + * syn_flag::SynFlag whether type synonyms are expanded or kept. + * mult_flag::MultiplicityFlag whether multiplicities are ignored or respected + * mb_env::Maybe RnEnv2 an optional RnEnv2. + +* `inline_generic_eq_type_x` has a handful of call sites, namely the ones + in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc. It inlines + at all these sites, specialising to the data values passed for the + control parameters. + +* All /other/ calls to `inline_generic_eq_type_x` go via + generic_eq_type_x = inline_generic_eq_type_x + {-# NOINLNE generic_eq_type_x #-} + The idea is that all calls to `generic_eq_type_x` are specialised by the + RULES, so this NOINLINE version is seldom, if ever, actually called. + +* For each of specialised copy of `inline_generic_eq_type_x, there is a + corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args) + into the appropriate specialied version. + +See #19226. +-} + +-- | This flag controls whether we expand synonyms during comparison +data SynFlag = ExpandSynonyms | KeepSynonyms + +eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect + :: Type -> Type -> Bool +eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x + :: RnEnv2 -> Type -> Type -> Bool + +eq_type_expand_respect = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing +eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env) +eq_type_expand_ignore = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing +eq_type_expand_ignore_x env = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env) +eq_type_keep_respect = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing +eq_type_keep_respect_x env = inline_generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env) + +{-# RULES +"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing + = eq_type_expand_respect +"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env) + = eq_type_expand_respect_x env +"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing + = eq_type_expand_ignore +"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env) + = eq_type_expand_ignore_x env +"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing + = eq_type_keep_respect +"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env) + = eq_type_keep_respect_x env + #-} + +-- --------------------------------------------------------------- +-- | Real worker for 'eqType'. No kind check! +-- Inline it at the (handful of local) call sites +-- The "generic" bit refers to the flag paramerisation +-- See Note [Specialising type equality]. +generic_eq_type_x, inline_generic_eq_type_x + :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> Bool + +{-# NOINLINE generic_eq_type_x #-} +generic_eq_type_x = inline_generic_eq_type_x -- See Note [Computing equality on types] in Type -tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 - = go orig_env orig_ty1 orig_ty2 - where - go :: RnEnv2 -> Type -> Type -> Bool - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. - go _ (TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = True - go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2 - go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2' +{-# INLINE inline_generic_eq_type_x #-} +-- This non-recursive function can inline at its (few) call sites. The +-- recursion goes via generic_eq_type_x, which is the loop-breaker. +inline_generic_eq_type_x syn_flag mult_flag mb_env + = \ t1 t2 -> t1 `seq` t2 `seq` + let go = generic_eq_type_x syn_flag mult_flag mb_env + -- Abbreviation for recursive calls - go env (TyVarTy tv1) (TyVarTy tv2) - = rnOccL env tv1 == rnOccR env tv2 + gos [] [] = True + gos (t1:ts1) (t2:ts2) = go t1 t2 && gos ts1 ts2 + gos _ _ = False - go _ (LitTy lit1) (LitTy lit2) - = lit1 == lit2 + in case (t1,t2) of + _ | 1# <- reallyUnsafePtrEquality# t1 t2 -> True + -- See Note [Type comparisons using object pointer comparisons] - go env (ForAllTy (Bndr tv1 vis1) ty1) - (ForAllTy (Bndr tv2 vis2) ty2) - = vis1 `eqForAllVis` vis2 - && (vis_only || go env (varType tv1) (varType tv2)) - && go (rnBndr2 env tv1 tv2) ty1 ty2 + (TyConApp tc1 tys1, TyConApp tc2 tys2) + | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms] + -> gos tys1 tys2 + _ | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 -> go t1' t2 + | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 -> go t1 t2' + + (TyConApp tc1 ts1, TyConApp tc2 ts2) + | tc1 == tc2 -> gos ts1 ts2 + | otherwise -> False + + (TyVarTy tv1, TyVarTy tv2) + -> case mb_env of + Nothing -> tv1 == tv2 + Just env -> rnOccL env tv1 == rnOccR env tv2 + + (LitTy lit1, LitTy lit2) -> lit1 == lit2 + (CastTy t1' _, _) -> go t1' t2 -- Ignore casts + (_, CastTy t2' _) -> go t1 t2' -- Ignore casts + (CoercionTy {}, CoercionTy {}) -> True -- Ignore coercions + -- Make sure we handle all FunTy cases since falling through to the -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked -- kind variable, which causes things to blow up. -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check -- kinds here - go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) - = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2 - where - kinds_eq | vis_only = True - | otherwise = go env (typeKind arg1) (typeKind arg2) && - go env (typeKind res1) (typeKind res2) + (FunTy _ w1 arg1 res1, FunTy _ w2 arg2 res2) + -> fullEq go arg1 arg2 + && fullEq go res1 res2 + && (case mult_flag of + RespectMultiplicities -> go w1 w2 + IgnoreMultiplicities -> True) -- See Note [Equality on AppTys] in GHC.Core.Type - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2 - = go env s1 s2 && go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1 - = go env s1 s2 && go env t1 t2 + (AppTy s1 t1', _) + | Just (s2, t2') <- tcSplitAppTyNoView_maybe t2 + -> go s1 s2 && go t1' t2' + (_, AppTy s2 t2') + | Just (s1, t1') <- tcSplitAppTyNoView_maybe t1 + -> go s1 s2 && go t1' t2' - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 + (ForAllTy (Bndr tv1 vis1) body1, ForAllTy (Bndr tv2 vis2) body2) + -> case mb_env of + Nothing -> generic_eq_type_x syn_flag mult_flag + (Just (initRnEnv t1 t2)) t1 t2 + Just env + | vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] + -> go (varType tv1) (varType tv2) -- Always do kind-check + && generic_eq_type_x syn_flag mult_flag + (Just (rnBndr2 env tv1 tv2)) body1 body2 + | otherwise + -> False - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True + _ -> False - go _ _ _ = False +fullEq :: (Type -> Type -> Bool) -> Type -> Type -> Bool +-- Do "full equality" including the kind check +-- See Note [Casts and coercions in type comparision] +{-# INLINE fullEq #-} +fullEq eq ty1 ty2 + = case eq ty1 ty2 of + False -> False + True | hasCasts ty1 || hasCasts ty2 + -> eq (typeKind ty1) (typeKind ty2) + | otherwise + -> True - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False +hasCasts :: Type -> Bool +-- Fast, does not look deep, does not allocate +hasCasts (CastTy {}) = True +hasCasts (CoercionTy {}) = True +hasCasts (AppTy t1 t2) = hasCasts t1 || hasCasts t2 +hasCasts (ForAllTy _ ty) = hasCasts ty +hasCasts _ = False -- TyVarTy, TyConApp, FunTy, LitTy - tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore - tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles - | otherwise = repeat False -- Ignore nothing - -- The repeat False is necessary because tycons - -- can legitimately be oversaturated - where - bndrs = tyConBinders tc - inviss = map isInvisibleTyConBinder bndrs - orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. - +{- ********************************************************************* +* * + Comparing ForAllTyFlags +* * +********************************************************************* -} -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function -- equates 'Specified' and 'Inferred'. Used for printing. eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool -- See Note [ForAllTy and type equality] --- If you change this, see IMPORTANT NOTE in the above Note eqForAllVis Required Required = True eqForAllVis (Invisible _) (Invisible _) = True eqForAllVis _ _ = False @@ -240,7 +467,6 @@ -- equates 'Specified' and 'Inferred'. Used for printing. cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering -- See Note [ForAllTy and type equality] --- If you change this, see IMPORTANT NOTE in the above Note cmpForAllVis Required Required = EQ cmpForAllVis Required (Invisible {}) = LT cmpForAllVis (Invisible _) Required = GT @@ -251,13 +477,59 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we compare (ForAllTy (Bndr tv1 vis1) ty1) and (ForAllTy (Bndr tv2 vis2) ty2) -what should we do about `vis1` vs `vis2`. +what should we do about `vis1` vs `vis2`? -First, we always compare with `eqForAllVis` and `cmpForAllVis`. -But what decision do we make? +We had a long debate about this: see #22762 and GHC Proposal 558. +Here is the conclusion. -Should GHC type-check the following program (adapted from #15740)? +* In Haskell, we really do want (forall a. ty) and (forall a -> ty) to be + distinct types, not interchangeable. The latter requires a type argument, + but the former does not. See GHC Proposal 558. +* We /really/ do not want the typechecker and Core to have different notions of + equality. That is, we don't want `tcEqType` and `eqType` to differ. Why not? + Not so much because of code duplication but because it is virtually impossible + to cleave the two apart. Here is one particularly awkward code path: + The type checker calls `substTy`, which calls `mkAppTy`, + which calls `mkCastTy`, which calls `isReflexiveCo`, which calls `eqType`. + +* Moreover the resolution of the TYPE vs CONSTRAINT story was to make the + typechecker and Core have a single notion of equality. + +* So in GHC: + - `tcEqType` and `eqType` implement the same equality + - (forall a. ty) and (forall a -> ty) are distinct types in both Core and typechecker + - That is, both `eqType` and `tcEqType` distinguish them. + +* But /at representational role/ we can relate the types. That is, + (forall a. ty) ~R (forall a -> ty) + After all, since types are erased, they are represented the same way. + See Note [ForAllCo] and the typing rule for ForAllCo given there + +* What about (forall a. ty) and (forall {a}. ty)? See Note [Comparing visibility]. + +Note [Comparing visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are sure that we want to distinguish (forall a. ty) and (forall a -> ty); see +Note [ForAllTy and type equality]. But we have /three/ settings for the ForAllTyFlag: + * Specified: forall a. ty + * Inferred: forall {a}. ty + * Required: forall a -> ty + +We could (and perhaps should) distinguish all three. But for now we distinguish +Required from Specified/Inferred, and ignore the distinction between Specified +and Inferred. + +The answer doesn't matter too much, provided we are consistent. And we are consistent +because we always compare ForAllTyFlags with + * `eqForAllVis` + * `cmpForAllVis`. +(You can only really check this by inspecting all pattern matches on ForAllTyFlags.) +So if we change the decision, we just need to change those functions. + +Why don't we distinguish all three? Should GHC type-check the following program +(adapted from #15740)? + {-# LANGUAGE PolyKinds, ... #-} data D a type family F :: forall k. k -> Type @@ -303,15 +575,11 @@ | | forall k -> <...> | Yes | -------------------------------------------------- -IMPORTANT NOTE: if we want to change this decision, ForAllCo will need to carry -visiblity (by taking a ForAllTyBinder rathre than a TyCoVar), so that -coercionLKind/RKind build forall types that match (are equal to) the desired -ones. Otherwise we get an infinite loop in the solver via canEqCanLHSHetero. Examples: T16946, T15079. Historical Note [Typechecker equality vs definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note describes some history, in case there are vesitges of this +This Note describes some history, in case there are vestiges of this history lying around in the code. Summary: prior to summer 2022, GHC had have two notions of equality @@ -343,91 +611,13 @@ ************************************************************************ * * Comparison for types - (We don't use instances so that we know where it happens) + + Not so heavily used, less carefully optimised * * ************************************************************************ -Note [Equality on AppTys] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In our cast-ignoring equality, we want to say that the following two -are equal: - - (Maybe |> co) (Int |> co') ~? Maybe Int - -But the left is an AppTy while the right is a TyConApp. The solution is -to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and -then continue. Easy to do, but also easy to forget to do. - -Note [Comparing nullary type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the task of testing equality between two 'Type's of the form - - TyConApp tc [] - -where @tc@ is a type synonym. A naive way to perform this comparison these -would first expand the synonym and then compare the resulting expansions. - -However, this is obviously wasteful and the RHS of @tc@ may be large; it is -much better to rather compare the TyCons directly. Consequently, before -expanding type synonyms in type comparisons we first look for a nullary -TyConApp and simply compare the TyCons if we find one. Of course, if we find -that the TyCons are *not* equal then we still need to perform the expansion as -their RHSs may still be equal. - -We perform this optimisation in a number of places: - - * GHC.Core.Types.eqType - * GHC.Core.Types.nonDetCmpType - * GHC.Core.Unify.unify_ty - * GHC.Tc.Solver.Equality.can_eq_nc' - * TcUnify.uType - -This optimisation is especially helpful for the ubiquitous GHC.Types.Type, -since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications -whenever possible. See Note [Using synonyms to compress types] in -GHC.Core.Type for details. - --} - -eqType :: Type -> Type -> Bool --- ^ Type equality on source types. Does not look through @newtypes@, --- 'PredType's or type families, but it does look through type synonyms. --- This first checks that the kinds of the types are equal and then --- checks whether the types are equal, ignoring casts and coercions. --- (The kind check is a recursive call, but since all kinds have type --- @Type@, there is no need to check the types of kinds.) --- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep". -eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 - -- It's OK to use nonDetCmpType here and eqType is deterministic, - -- nonDetCmpType does equality deterministically - --- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. -eqTypeX :: RnEnv2 -> Type -> Type -> Bool -eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 - -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, - -- nonDetCmpTypeX does equality deterministically - --- | Type equality on lists of types, looking through type synonyms --- but not newtypes. -eqTypes :: [Type] -> [Type] -> Bool -eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 - -- It's OK to use nonDetCmpType here and eqTypes is deterministic, - -- nonDetCmpTypes does equality deterministically - -eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 --- Check that the var lists are the same length --- and have matching kinds; if so, extend the RnEnv2 --- Returns Nothing if they don't match -eqVarBndrs env [] [] - = Just env -eqVarBndrs env (tv1:tvs1) (tv2:tvs2) - | eqTypeX env (varType tv1) (varType tv2) - = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 -eqVarBndrs _ _ _= Nothing - -- Now here comes the real worker -{- Note [nonDetCmpType nondeterminism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX @@ -439,6 +629,7 @@ -} nonDetCmpType :: Type -> Type -> Ordering +{-# INLINE nonDetCmpType #-} nonDetCmpType !t1 !t2 -- See Note [Type comparisons using object pointer comparisons] | 1# <- reallyUnsafePtrEquality# t1 t2 @@ -450,13 +641,7 @@ = nonDetCmpTypeX rn_env t1 t2 where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) -{-# INLINE nonDetCmpType #-} -nonDetCmpTypes :: [Type] -> [Type] -> Ordering -nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) - -- | An ordering relation between two 'Type's (known below as @t1 :: k1@ -- and @t2 :: k2@) data TypeOrdering = TLT -- ^ @t1 < t2@ @@ -470,6 +655,7 @@ nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep -- See Note [Computing equality on types] + -- Always respects multiplicities, unlike eqType nonDetCmpTypeX env orig_t1 orig_t2 = case go env orig_t1 orig_t2 of -- If there are casts then we also need to do a comparison of @@ -503,10 +689,11 @@ -- Returns both the resulting ordering relation between -- the two types and whether either contains a cast. go :: RnEnv2 -> Type -> Type -> TypeOrdering - -- See Note [Comparing nullary type synonyms]. + go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 - = TEQ + = TEQ -- See Note [Comparing type synonyms] + go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 | Just t2' <- coreView t2 = go env t1 t2' @@ -514,7 +701,7 @@ go env (TyVarTy tv1) (TyVarTy tv2) = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2) - = liftOrdering (vis1 `cmpForAllVis` vis2) + = liftOrdering (vis1 `cmpForAllVis` vis2) -- See Note [ForAllTy and type equality] `thenCmpTy` go env (varType tv1) (varType tv2) `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 @@ -562,13 +749,6 @@ gos _ _ [] = TGT gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 -------------- -nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering -nonDetCmpTypesX _ [] [] = EQ -nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 S.<> - nonDetCmpTypesX env tys1 tys2 -nonDetCmpTypesX _ [] _ = LT -nonDetCmpTypesX _ _ [] = GT ------------- -- | Compare two 'TyCon's. @@ -581,4 +761,93 @@ u2 = tyConUnique tc2 +{- ********************************************************************* +* * + mayLookIdentical +* * +********************************************************************* -} + +mayLookIdentical :: Type -> Type -> Bool +-- | Returns True if the /visible/ part of the types +-- might look equal, even if they are really unequal (in the invisible bits) +-- +-- This function is very similar to tc_eq_type but it is much more +-- heuristic. Notably, it is always safe to return True, even with types +-- that might (in truth) be unequal -- this affects error messages only +-- (Originally this test was done by eqType with an extra flag, but the result +-- was hard to understand.) +mayLookIdentical orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + + go :: RnEnv2 -> Type -> Type -> Bool + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms] + = gos env (tyConBinders tc1) ts1 ts2 + + go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2 + go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2 + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 `eqForAllVis` vis2 -- See Note [ForAllTy and type equality] + && go (rnBndr2 env tv1 tv2) ty1 ty2 + -- Visible stuff only: ignore kinds of binders + + -- If we have (forall (r::RunTimeRep). ty1 ~ blah) then respond + -- with True. Reason: the type pretty-printer defaults RuntimeRep + -- foralls (see Ghc.Iface.Type.hideNonStandardTypes). That can make, + -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the + -- same as a very different type (#24553). By responding True, we + -- tell GHC (see calls of mayLookIdentical) to display without defaulting. + -- See Note [Showing invisible bits of types in error messages] + -- in GHC.Tc.Errors.Ppr + go _ (ForAllTy b _) _ | isDefaultableBndr b = True + go _ _ (ForAllTy b _) | isDefaultableBndr b = True + + go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) + = go env arg1 arg2 && go env res1 res2 && go env w1 w2 + -- Visible stuff only: ignore agg kinds + + -- See Note [Equality on AppTys] in GHC.Core.Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2 + + go _ _ _ = False + + gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool + gos _ _ [] [] = True + gos env bs (t1:ts1) (t2:ts2) + | (invisible, bs') <- case bs of + [] -> (False, []) + (b:bs) -> (isInvisibleTyConBinder b, bs) + = (invisible || go env t1 t2) && gos env bs' ts1 ts2 + + gos _ _ _ _ = False + + +isDefaultableBndr :: ForAllTyBinder -> Bool +-- This function should line up with the defaulting done +-- by GHC.Iface.Type.defaultIfaceTyVarsOfKind +-- See Note [Showing invisible bits of types in error messages] +-- in GHC.Tc.Errors.Ppr +isDefaultableBndr (Bndr tv vis) + = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv) + where + is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki || isMultiplicityTy ki diff --git a/GHC/Core/TyCo/FVs.hs b/GHC/Core/TyCo/FVs.hs --- a/GHC/Core/TyCo/FVs.hs +++ b/GHC/Core/TyCo/FVs.hs @@ -19,6 +19,7 @@ tyCoVarsOfCoDSet, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoList, + coVarsOfCoDSet, coVarsOfCosDSet, almostDevoidCoVarOfCo, @@ -39,10 +40,6 @@ -- * Occurrence-check expansion occCheckExpand, - -- * Well-scoped free variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - -- * Closing over kinds closeOverKindsDSet, closeOverKindsList, closeOverKinds, @@ -58,10 +55,10 @@ import GHC.Builtin.Types.Prim( funTyFlagTyCon ) -import Data.Monoid as DM ( Endo(..), Any(..) ) +import Data.Monoid as DM ( Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon -import GHC.Core.Coercion.Axiom( coAxiomTyCon ) +import GHC.Core.Coercion.Axiom( CoAxiomRule(..), BuiltInFamRewrite(..), coAxiomTyCon ) import GHC.Utils.FV import GHC.Types.Var @@ -71,9 +68,10 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc -import GHC.Utils.Panic import GHC.Data.Pair +import Data.Semigroup + {- %************************************************************************ %* * @@ -227,6 +225,17 @@ kind are free -- regardless of whether some local variable has the same Unique. So if we're looking at a variable occurrence at all, then all variables in its kind are free. + +Note [Free vars and synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When finding free variables we generally do not expand synonyms. So given + type T a = Int +the type (T [b]) will return `b` as a free variable, even though expanding the +synonym would get rid of it. Expanding synonyms might lead to types that look +ill-scoped; an alternative we have not explored. + +But see `occCheckExpand` in this module for a function that does, selectively, +expand synonyms to reduce free-var occurences. -} {- ********************************************************************* @@ -289,16 +298,19 @@ ********************************************************************* -} tyCoVarsOfType :: Type -> TyCoVarSet +-- The "deep" TyCoVars of the the type tyCoVarsOfType ty = runTyCoVars (deep_ty ty) -- Alternative: -- tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty) tyCoVarsOfTypes :: [Type] -> TyCoVarSet +-- The "deep" TyCoVars of the the type tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys) -- Alternative: -- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- The "deep" TyCoVars of the the coercion -- See Note [Free variables of types] tyCoVarsOfCo co = runTyCoVars (deep_co co) @@ -316,7 +328,7 @@ (deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -deepTcvFolder = TyCoFolder { tcf_view = noView +deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where @@ -374,7 +386,7 @@ (shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -shallowTcvFolder = TyCoFolder { tcf_view = noView +shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where @@ -446,6 +458,16 @@ -- See Note [CoercionHoles and coercion free variables] -- in GHC.Core.TyCo.Rep +------- Same again, but for DCoVarSet ---------- +-- But this time the free vars are shallow + +coVarsOfCosDSet :: [Coercion] -> DCoVarSet +coVarsOfCosDSet cos = fvDVarSetSome isCoVar (tyCoFVsOfCos cos) + +coVarsOfCoDSet :: Coercion -> DCoVarSet +coVarsOfCoDSet co = fvDVarSetSome isCoVar (tyCoFVsOfCo co) + + {- ********************************************************************* * * Closing over kinds @@ -584,6 +606,7 @@ emptyVarSet -- See Note [Closing over free variable kinds] (v:acc_list, extendVarSet acc_set v) tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc + -- See Note [Free vars and synonyms] tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc tyCoFVsOfType (FunTy _ w arg res) f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc @@ -631,7 +654,7 @@ tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc -tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc +tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc @@ -640,10 +663,10 @@ tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc -- See Note [CoercionHoles and coercion free variables] -tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc -tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc - = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 - `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (AxiomCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc +tyCoFVsOfCo (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps}) fv_cand in_scope acc + = (tyCoFVsOfCos deps `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc tyCoFVsOfCo (SelCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc @@ -651,18 +674,11 @@ tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc tyCoFVsOfCoVar :: CoVar -> FV tyCoFVsOfCoVar v fv_cand in_scope acc = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc -tyCoFVsOfProv :: UnivCoProvenance -> FV -tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc -tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc - tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc @@ -672,7 +688,7 @@ -- | Given a covar and a coercion, returns True if covar is almost devoid in -- the coercion. That is, covar can only appear in Refl and GRefl. --- See last wrinkle in Note [Unused coercion variable in ForAllCo] in "GHC.Core.Coercion" +-- See (FC6) in Note [ForAllCo] in "GHC.Core.TyCo.Rep" almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool almostDevoidCoVarOfCo cv co = almost_devoid_co_var_of_co co cv @@ -686,7 +702,7 @@ almost_devoid_co_var_of_co (AppCo co arg) cv = almost_devoid_co_var_of_co co cv && almost_devoid_co_var_of_co arg cv -almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv +almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv = almost_devoid_co_var_of_co kind_co cv && (v == cv || almost_devoid_co_var_of_co co cv) almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv @@ -695,10 +711,10 @@ && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv -almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv - = almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv - = almost_devoid_co_var_of_prov p cv +almost_devoid_co_var_of_co (AxiomCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv +almost_devoid_co_var_of_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) cv + = almost_devoid_co_var_of_cos deps cv && almost_devoid_co_var_of_type t1 cv && almost_devoid_co_var_of_type t2 cv almost_devoid_co_var_of_co (SymCo co) cv @@ -717,8 +733,6 @@ = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (SubCo co) cv = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv - = almost_devoid_co_var_of_cos cs cv almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool almost_devoid_co_var_of_cos [] _ = True @@ -726,14 +740,6 @@ = almost_devoid_co_var_of_co co cv && almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool -almost_devoid_co_var_of_prov (PhantomProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (ProofIrrelProv co) cv - = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (PluginProv _) _ = True -almost_devoid_co_var_of_prov (CorePrepProv _) _ = True - almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True almost_devoid_co_var_of_type (TyConApp _ tys) cv @@ -809,7 +815,7 @@ isInjectiveInType :: TyVar -> Type -> Bool -- True <=> tv /definitely/ appears injectively in ty -- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty) --- Ignore occurence in coercions, and even in injective positions of +-- Ignore occurrence in coercions, and even in injective positions of -- type families. isInjectiveInType tv ty = go ty @@ -943,7 +949,9 @@ {-# INLINE afvFolder #-} -- so that specialization to (const True) works afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any -afvFolder check_fv = TyCoFolder { tcf_view = noView +-- 'afvFolder' is short for "any-free-var folder", good for checking +-- if any free var of a type satisfies a predicate `check_fv` +afvFolder check_fv = TyCoFolder { tcf_view = noView -- See Note [Free vars and synonyms] , tcf_tyvar = do_tcv, tcf_covar = do_tcv , tcf_hole = do_hole, tcf_tycobinder = do_bndr } where @@ -976,107 +984,6 @@ where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet -{- ********************************************************************* -* * - scopedSort -* * -********************************************************************* -} - -{- Note [ScopedSort] -~~~~~~~~~~~~~~~~~~~~ -Consider - - foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () - -This function type is implicitly generalised over [a, b, k, k2]. These -variables will be Specified; that is, they will be available for visible -type application. This is because they are written in the type signature -by the user. - -However, we must ask: what order will they appear in? In cases without -dependency, this is easy: we just use the lexical left-to-right ordering -of first occurrence. With dependency, we cannot get off the hook so -easily. - -We thus state: - - * These variables appear in the order as given by ScopedSort, where - the input to ScopedSort is the left-to-right order of first occurrence. - -Note that this applies only to *implicit* quantification, without a -`forall`. If the user writes a `forall`, then we just use the order given. - -ScopedSort is defined thusly (as proposed in #15743): - * Work left-to-right through the input list, with a cursor. - * If variable v at the cursor is depended on by any earlier variable w, - move v immediately before the leftmost such w. - -INVARIANT: The prefix of variables before the cursor form a valid telescope. - -Note that ScopedSort makes sense only after type inference is done and all -types/kinds are fully settled and zonked. - --} - --- | Do a topological sort on a list of tyvars, --- so that binders occur before occurrences --- E.g. given [ a::k, k::*, b::k ] --- it'll return a well-scoped list [ k::*, a::k, b::k ] --- --- This is a deterministic sorting operation --- (that is, doesn't depend on Uniques). --- --- It is also meant to be stable: that is, variables should not --- be reordered unnecessarily. This is specified in Note [ScopedSort] --- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType" - -scopedSort :: [TyCoVar] -> [TyCoVar] -scopedSort = go [] [] - where - go :: [TyCoVar] -- already sorted, in reverse order - -> [TyCoVarSet] -- each set contains all the variables which must be placed - -- before the tv corresponding to the set; they are accumulations - -- of the fvs in the sorted tvs' kinds - - -- This list is in 1-to-1 correspondence with the sorted tyvars - -- INVARIANT: - -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) - -- That is, each set in the list is a superset of all later sets. - - -> [TyCoVar] -- yet to be sorted - -> [TyCoVar] - go acc _fv_list [] = reverse acc - go acc fv_list (tv:tvs) - = go acc' fv_list' tvs - where - (acc', fv_list') = insert tv acc fv_list - - insert :: TyCoVar -- var to insert - -> [TyCoVar] -- sorted list, in reverse order - -> [TyCoVarSet] -- list of fvs, as above - -> ([TyCoVar], [TyCoVarSet]) -- augmented lists - insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) - insert tv (a:as) (fvs:fvss) - | tv `elemVarSet` fvs - , (as', fvss') <- insert tv as fvss - = (a:as', fvs `unionVarSet` fv_tv : fvss') - - | otherwise - = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) - where - fv_tv = tyCoVarsOfType (tyVarKind tv) - - -- lists not in correspondence - insert _ _ _ = panic "scopedSort" - --- | Get the free vars of a type in scoped order -tyCoVarsOfTypeWellScoped :: Type -> [TyVar] -tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList - --- | Get the free vars of types in scoped order -tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] -tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList - {- ************************************************************************ * * @@ -1085,6 +992,21 @@ ************************************************************************ -} +{- Note [tyConsOfType] +~~~~~~~~~~~~~~~~~~~~~~ +It is slightly odd to find the TyCons of a type. Especially since, via a type +family reduction or axiom, a type that doesn't mention T might start to mention T. + +This function is used in only three places: +* In GHC.Tc.Validity.validDerivPred, when identifying "exotic" predicates. +* In GHC.Tc.Errors.Ppr.pprTcSolverReportMsg, when trying to print a helpful + error about overlapping instances +* In utils/dump-decls/Main.hs, an ill-documented module. + +None seem critical. Currently tyConsOfType looks inside coercions, but perhaps +it doesn't even need to do that. +-} + -- | All type constructors occurring in the type; looking through type -- synonyms, but not newtypes. -- When it finds a Class, it returns the class TyCon. @@ -1109,11 +1031,13 @@ go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg - go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co + go_co (ForAllCo { fco_kind = kind_co, fco_body = co }) + = go_co kind_co `unionUniqSets` go_co co go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r }) = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r - go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args - go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (AxiomCo ax args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos }) + = go t1 `unionUniqSets` go t2 `unionUniqSets` go_cos cos go_co (CoVarCo {}) = emptyUniqSet go_co (HoleCo {}) = emptyUniqSet go_co (SymCo co) = go_co co @@ -1123,23 +1047,19 @@ go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg go_co (KindCo co) = go_co co go_co (SubCo co) = go_co co - go_co (AxiomRuleCo _ cs) = go_cos cs go_mco MRefl = emptyUniqSet go_mco (MCo co) = go_co co - go_prov (PhantomProv co) = go_co co - go_prov (ProofIrrelProv co) = go_co co - go_prov (PluginProv _) = emptyUniqSet - go_prov (CorePrepProv _) = emptyUniqSet - -- this last case can happen from the tyConsOfType used from - -- checkTauTvUpdate - go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos go_tc tc = unitUniqSet tc - go_ax ax = go_tc $ coAxiomTyCon ax + go_ax (UnbranchedAxiom ax) = go_tc $ coAxiomTyCon ax + go_ax (BranchedAxiom ax _) = go_tc $ coAxiomTyCon ax + go_ax (BuiltInFamRew bif) = go_tc $ bifrw_fam_tc bif + go_ax (BuiltInFamInj {}) = emptyUniqSet -- A free-floating axiom + tyConsOfTypes :: [Type] -> UniqSet TyCon tyConsOfTypes tys = foldr (unionUniqSets . tyConsOfType) emptyUniqSet tys @@ -1293,14 +1213,32 @@ go_co cxt (AppCo co arg) = do { co' <- go_co cxt co ; arg' <- go_co cxt arg ; return (AppCo co' arg') } - go_co cxt@(as, env) (ForAllCo tv kind_co body_co) + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (SymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (TransCo co1' co2') } + go_co cxt (SelCo n co) = do { co' <- go_co cxt co + ; return (SelCo n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (LRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (InstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (KindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (SubCo co') } + + go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co }) = do { kind_co' <- go_co cxt kind_co ; let tv' = setVarType tv $ coercionLKind kind_co' env' = extendVarEnv env tv tv' as' = as `delVarSet` tv ; body' <- go_co (as', env') body_co - ; return (ForAllCo tv' kind_co' body') } + ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) } + go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 }) = do { co1' <- go_co cxt co1 ; co2' <- go_co cxt co2 @@ -1316,34 +1254,11 @@ | bad_var_occ as (ch_co_var h) = Nothing | otherwise = return co - go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args - ; return (AxiomInstCo ax ind args') } - go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p - ; ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (UnivCo p' r ty1' ty2') } - go_co cxt (SymCo co) = do { co' <- go_co cxt co - ; return (SymCo co') } - go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (TransCo co1' co2') } - go_co cxt (SelCo n co) = do { co' <- go_co cxt co - ; return (SelCo n co') } - go_co cxt (LRCo lr co) = do { co' <- go_co cxt co - ; return (LRCo lr co') } - go_co cxt (InstCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (InstCo co' arg') } - go_co cxt (KindCo co) = do { co' <- go_co cxt co - ; return (KindCo co') } - go_co cxt (SubCo co) = do { co' <- go_co cxt co - ; return (SubCo co') } - go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs - ; return (AxiomRuleCo ax cs') } - - ------------------ - go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co - go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co - go_prov _ p@(PluginProv _) = return p - go_prov _ p@(CorePrepProv _) = return p + go_co cxt (AxiomCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (AxiomCo ax cs') } + go_co cxt co@(UnivCo { uco_lty = ty1, uco_rty = ty2, uco_deps = cos }) + = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; cos' <- mapM (go_co cxt) cos + ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = cos' }) } diff --git a/GHC/Core/TyCo/FVs.hs-boot b/GHC/Core/TyCo/FVs.hs-boot --- a/GHC/Core/TyCo/FVs.hs-boot +++ b/GHC/Core/TyCo/FVs.hs-boot @@ -1,6 +1,8 @@ module GHC.Core.TyCo.FVs where import GHC.Prelude ( Bool ) +import GHC.Types.Var.Set( TyCoVarSet ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) noFreeVarsOfType :: Type -> Bool +tyCoVarsOfType :: Type -> TyCoVarSet diff --git a/GHC/Core/TyCo/Ppr.hs b/GHC/Core/TyCo/Ppr.hs --- a/GHC/Core/TyCo/Ppr.hs +++ b/GHC/Core/TyCo/Ppr.hs @@ -14,7 +14,7 @@ pprTyVar, pprTyVars, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, - pprDataCons, pprWithExplicitKindsWhen, + pprDataCons, pprWithInvisibleBitsWhen, pprWithTYPE, pprSourceTyCon, @@ -41,8 +41,11 @@ import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs import GHC.Core.Class -import GHC.Types.Var +import GHC.Core.Predicate( scopedSort ) import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) + +import GHC.Types.Var + import GHC.Iface.Type import GHC.Types.Var.Set @@ -93,6 +96,13 @@ -- NB: debug-style is used for -dppr-debug -- dump-style is used for -ddump-tc-trace etc +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + + pprTyLit :: TyLit -> SDoc pprTyLit = pprIfaceTyLit . toIfaceTyLit @@ -100,12 +110,6 @@ pprKind = pprType pprParendKind = pprParendType -tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType -tidyToIfaceTypeStyX env ty sty - | userStyle sty = tidyToIfaceTypeX env ty - | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty - -- in latter case, don't tidy, as we'll be printing uniques. - tidyToIfaceType :: Type -> IfaceType tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv @@ -117,9 +121,12 @@ -- leave them as IfaceFreeTyVar. This is super-important -- for debug printing. tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + -- NB: if the type has /already/ been tidied (for example by the typechecker) + -- the tidy step here is a no-op. See Note [Tidying is idempotent] + -- in GHC.Core.TyCo.Tidy where env' = tidyFreeTyCoVars env free_tcvs - free_tcvs = tyCoVarsOfTypeWellScoped ty + free_tcvs = tyCoVarsOfTypeList ty ------------ pprCo, pprParendCo :: Coercion -> SDoc @@ -317,7 +324,7 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] where (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc + user_bndrs = dataConUserTyVarBinders dc forAllDoc = pprUserForAll user_bndrs thetaDoc = pprThetaArrowTy theta argsDoc = hsep (fmap pprParendType (map scaledThing arg_tys)) @@ -330,13 +337,14 @@ -- TODO: toIfaceTcArgs seems rather wasteful here ------------------ --- | Display all kind information (with @-fprint-explicit-kinds@) when the --- provided 'Bool' argument is 'True'. --- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". -pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc -pprWithExplicitKindsWhen b +-- | Display all foralls, runtime-reps, and kind information +-- when provided 'Bool' argument is 'True'. See GHC.Tc.Errors.Ppr +-- Note [Showing invisible bits of types in error messages] +pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc +pprWithInvisibleBitsWhen b = updSDocContext $ \ctx -> - if b then ctx { sdocPrintExplicitKinds = True } + if b then ctx { sdocPrintExplicitKinds = True + , sdocPrintExplicitRuntimeReps = True } else ctx -- | This variant preserves any use of TYPE in a type, effectively diff --git a/GHC/Core/TyCo/Rep.hs b/GHC/Core/TyCo/Rep.hs --- a/GHC/Core/TyCo/Rep.hs +++ b/GHC/Core/TyCo/Rep.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK not-home #-} @@ -38,7 +37,7 @@ -- * Coercions Coercion(..), CoSel(..), FunSel(..), UnivCoProvenance(..), - CoercionHole(..), coHoleCoVar, setCoHoleCoVar, isHeteroKindCoHole, + CoercionHole(..), coHoleCoVar, setCoHoleCoVar, CoercionN, CoercionR, CoercionP, KindCoercion, MCoercion(..), MCoercionR, MCoercionN, @@ -48,7 +47,7 @@ mkFunTy, mkNakedFunTy, mkVisFunTy, mkScaledFunTys, mkInvisFunTy, mkInvisFunTys, - tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys, + tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkPiTy, mkPiTys, mkVisFunTyMany, mkVisFunTysMany, @@ -61,7 +60,7 @@ TyCoFolder(..), foldTyCo, noView, -- * Sizes - typeSize, typesSize, coercionSize, provSize, + typeSize, typesSize, coercionSize, -- * Multiplicities Scaled(..), scaledMult, scaledThing, mapScaledType, Mult @@ -71,12 +70,14 @@ import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) import {-# SOURCE #-} GHC.Builtin.Types +import {-# SOURCE #-} GHC.Core.TyCo.FVs( tyCoVarsOfType ) -- Use in assertions import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: import GHC.Types.Var +import GHC.Types.Var.Set( elemVarSet ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -152,13 +153,15 @@ -- for example unsaturated type synonyms -- can appear as the right hand side of a type synonym. - | ForAllTy + | ForAllTy -- See Note [ForAllTy] {-# UNPACK #-} !ForAllTyBinder - Type -- ^ A Π type. - -- Note [When we quantify over a coercion variable] - -- INVARIANT: If the binder is a coercion variable, it must - -- be mentioned in the Type. See - -- Note [Unused coercion variable in ForAllTy] + -- ForAllTyBinder: see GHC.Types.Var + -- Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] + Type + -- INVARIANT: If the binder is a coercion variable, it must + -- be mentioned in the Type. + -- See Note [Unused coercion variable in ForAllTy] + -- See Note [Why ForAllTy can quantify over a coercion variable] | FunTy -- ^ FUN m t1 t2 Very common, so an important special case -- See Note [Function types] @@ -258,47 +261,9 @@ multiplicity argument nondependent in #20164. * Re the ft_af field: see Note [FunTyFlag] in GHC.Types.Var - See Note [Types for coercions, predicates, and evidence] - This visibility info makes no difference in Core; it matters - only when we regard the type as a Haskell source type. - -Note [Types for coercions, predicates, and evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat differently: - - (a) Predicate types - Test: isPredTy - Binders: DictIds - Kind: Constraint - Examples: (Eq a), and (a ~ b) - - (b) Coercion types are primitive, unboxed equalities - Test: isCoVarTy - Binders: CoVars (can appear in coercions) - Kind: TYPE (TupleRep []) - Examples: (t1 ~# t2) or (t1 ~R# t2) - - (c) Evidence types is the type of evidence manipulated by - the type constraint solver. - Test: isEvVarType - Binders: EvVars - Kind: Constraint or TYPE (TupleRep []) - Examples: all coercion types and predicate types - -Coercion types and predicate types are mutually exclusive, -but evidence types are a superset of both. - -When treated as a user type, - - - Predicates (of kind Constraint) are invisible and are - implicitly instantiated - - - Coercion types, and non-pred evidence types (i.e. not - of kind Constrain), are just regular old types, are - visible, and are not implicitly instantiated. - -In a FunTy { ft_af = af } and af = FTF_C_T or FTF_C_C, the argument -type is always a Predicate type. + See Note [Types for coercions, predicates, and evidence] in + GHC.Core.Predicate. This visibility info makes no difference in Core; + it matter only when we regard the type as a Haskell source type. Note [Weird typing rule for ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -349,15 +314,25 @@ Note [Non-trivial definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is Int |> <*> the same as Int? YES! In order to reduce headaches, -we decide that any reflexive casts in types are just ignored. -(Indeed they must be. See Note [Respecting definitional equality].) -More generally, the `eqType` function, which defines Core's type equality -relation, ignores casts and coercion arguments, as long as the -two types have the same kind. This allows us to be a little sloppier -in keeping track of coercions, which is a good thing. It also means -that eqType does not depend on eqCoercion, which is also a good thing. +Is ((IO |> co1) Int |> co2) equal to (IO Int)? +Assume + co1 :: (Type->Type) ~ (Type->Wombat) + co2 :: Wombat ~ Type +Well, yes. The casts are just getting in the way. +See also Note [Respecting definitional equality]. +So we do this: + +(EQTYPE) + The `eqType` function, which defines Core's type equality relation, + - /ignores/ casts, and + - /ignores/ coercion arguments + - /provided/ two types have the same kind + +This allows us to be a little sloppier in keeping track of coercions, which is a +good thing. It also means that eqType does not depend on eqCoercion, which is +also a good thing. + Why is this sensible? That is, why is something different than α-equivalence appropriate for the implementation of eqType? @@ -452,7 +427,7 @@ Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done -in mkCastTy. This is (EQ1) below. +in mkCastTy. This is (EQ2) below. Unfortunately, that's not the end of the story. Consider comparing (T a b c) =? (T a b |> (co -> )) (c |> co) @@ -475,7 +450,7 @@ In order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). -This is (EQ2) below. +This is (EQ3) below. One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. The kind of the body is the same as the kind of the ForAllTy. Accordingly, @@ -488,9 +463,9 @@ In sum, in order to uphold (EQ), we need the following invariants: - (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable - cast is one that relates either a FunTy to a FunTy or a - ForAllTy to a ForAllTy. + (EQ1) No decomposable CastTy to the left of an AppTy, + where a "decomposable cast" is one that relates + either a FunTy to a FunTy, or a ForAllTy to a ForAllTy. (EQ2) No reflexive casts in CastTy. (EQ3) No nested CastTys. (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). @@ -517,8 +492,22 @@ expand into TyConApps, we must check the kinds of the arg and the res. -Note [When we quantify over a coercion variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [ForAllTy] +~~~~~~~~~~~~~~~ +A (ForAllTy (Bndr tcv vis) ty) can quantify over a TyVar or, less commonly, a CoVar. +See Note [Why ForAllTy can quantify over a coercion variable] for why we need the latter. + +(FT1) Invariant: See Note [Weird typing rule for ForAllTy] + +(FT2) Invariant: in (ForAllTy (Bndr tcv vis) ty), + if tcv is a CoVar, then vis = coreTyLamForAllTyFlag. + Visibility is not important for coercion abstractions, + because they are not user-visible. + +(FT3) Invariant: see Note [Unused coercion variable in ForAllTy] + +Note [Why ForAllTy can quantify over a coercion variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely) a CoVar. We support quantifying over a CoVar here in order to support a homogeneous (~#) relation (someday -- not yet implemented). Here is @@ -541,10 +530,8 @@ make this work out. See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2 -which gives a general road map that covers this space. - -Having this feature in Core does *not* mean we have it in source Haskell. -See #15710 about that. +which gives a general road map that covers this space. Having this feature in +Core does *not* mean we have it in source Haskell. See #15710 about that. Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -721,22 +708,6 @@ where af = invisArg (typeTypeOrConstraint res) -tcMkVisFunTy :: Mult -> Type -> Type -> Type --- Always TypeLike, user-specified multiplicity. --- Does not have the assert-checking in mkFunTy: used by the typechecker --- to avoid looking at the result kind, which may not be zonked -tcMkVisFunTy mult arg res - = FunTy { ft_af = visArgTypeLike, ft_mult = mult - , ft_arg = arg, ft_res = res } - -tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type --- Always TypeLike, invisible argument --- Does not have the assert-checking in mkFunTy: used by the typechecker --- to avoid looking at the result kind, which may not be zonked -tcMkInvisFunTy res_torc arg res - = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy - , ft_arg = arg, ft_res = res } - mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type -- Always TypeLike, user-specified multiplicity. mkVisFunTy = mkFunTy visArgTypeLike @@ -763,19 +734,21 @@ where af = visArg (typeTypeOrConstraint ty) -tcMkScaledFunTys :: [Scaled Type] -> Type -> Type --- All visible args --- Result type must be TypeLike --- No mkFunTy assert checking; result kind may not be zonked -tcMkScaledFunTys tys ty = foldr mk ty tys - where - mk (Scaled mult arg) res = tcMkVisFunTy mult arg res - --------------- -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder -- See Note [Unused coercion variable in ForAllTy] mkForAllTy :: ForAllTyBinder -> Type -> Type -mkForAllTy = ForAllTy +mkForAllTy bndr body + = assertPpr (good_bndr bndr) (ppr bndr <+> ppr body) $ + ForAllTy bndr body + where + -- Check ForAllTy invariants + good_bndr (Bndr cv vis) + | isCoVar cv = vis == coreTyLamForAllTyFlag + -- See (FT2) in Note [ForAllTy] + && (cv `elemVarSet` tyCoVarsOfType body) + -- See (FT3) in Note [ForAllTy] + | otherwise = True -- | Wraps foralls over the type using the provided 'TyCoVar's from left to right mkForAllTys :: [ForAllTyBinder] -> Type -> Type @@ -785,11 +758,11 @@ mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) -mkPiTy :: PiTyBinder -> Type -> Type +mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type mkPiTy (Anon ty1 af) ty2 = mkScaledFunTy af ty1 ty2 mkPiTy (Named bndr) ty = mkForAllTy bndr ty -mkPiTys :: [PiTyBinder] -> Type -> Type +mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs -- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you @@ -800,6 +773,31 @@ mkNakedTyConTy :: TyCon -> Type mkNakedTyConTy tycon = TyConApp tycon [] +tcMkVisFunTy :: Mult -> Type -> Type -> Type +-- Always TypeLike result, user-specified multiplicity. +-- Does not have the assert-checking in mkFunTy: used by the typechecker +-- to avoid looking at the result kind, which may not be zonked +tcMkVisFunTy mult arg res + = FunTy { ft_af = visArgTypeLike, ft_mult = mult + , ft_arg = arg, ft_res = res } + +tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type +-- Always invisible (constraint) argument, result specified by res_torc +-- Does not have the assert-checking in mkFunTy: used by the typechecker +-- to avoid looking at the result kind, which may not be zonked +tcMkInvisFunTy res_torc arg res + = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } + +tcMkScaledFunTys :: [Scaled Type] -> Type -> Type +-- All visible args +-- Result type must be TypeLike +-- No mkFunTy assert checking; result kind may not be zonked +tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys + +tcMkScaledFunTy :: Scaled Type -> Type -> Type +tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res + {- %************************************************************************ %* * @@ -849,13 +847,19 @@ | AppCo Coercion CoercionN -- lift AppTy -- AppCo :: e -> N -> e - -- See Note [Forall coercions] - | ForAllCo TyCoVar KindCoercion Coercion + -- See Note [ForAllCo] + | ForAllCo + { fco_tcv :: TyCoVar + , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind + , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind + -- See (FC7) of Note [ForAllCo] + , fco_kind :: KindCoercion + , fco_body :: Coercion } -- ForAllCo :: _ -> N -> e -> e | FunCo -- FunCo :: "e" -> N/P -> e -> e -> e -- See Note [FunCo] for fco_afl, fco_afr - { fco_role :: Role + { fco_role :: Role , fco_afl :: FunTyFlag -- Arrow for coercionLKind , fco_afr :: FunTyFlag -- Arrow for coercionRKind , fco_mult :: CoercionN @@ -867,9 +871,7 @@ | CoVarCo CoVar -- :: _ -> (N or R) -- result role depends on the tycon of the variable's type - -- AxiomInstCo :: e -> _ -> ?? -> e - | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] - -- See also [CoAxiom index] + | AxiomCo CoAxiomRule [Coercion] -- The coercion arguments always *precisely* saturate -- arity of (that branch of) the CoAxiom. If there are -- any left over, we use AppCo. @@ -877,13 +879,14 @@ -- The roles of the argument coercions are determined -- by the cab_roles field of the relevant branch of the CoAxiom - | AxiomRuleCo CoAxiomRule [Coercion] - -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule - -- The number coercions should match exactly the expectations - -- of the CoAxiomRule (i.e., the rule is fully saturated). - - | UnivCo UnivCoProvenance Role Type Type - -- :: _ -> "e" -> _ -> _ -> e + | UnivCo -- See Note [UnivCo] + -- Of kind (lty ~role rty) + { uco_prov :: UnivCoProvenance + , uco_role :: Role + , uco_lty, uco_rty :: Type + , uco_deps :: [Coercion] -- Coercions on which it depends + -- See Note [The importance of tracking UnivCo dependencies] + } | SymCo Coercion -- :: e -> e | TransCo Coercion Coercion -- :: e -> e -> e @@ -921,13 +924,13 @@ | SelForAll -- Decomposes (forall a. co) - deriving( Eq, Data.Data ) + deriving( Eq, Data.Data, Ord ) data FunSel -- See Note [SelCo] = SelMult -- Multiplicity | SelArg -- Argument of function | SelRes -- Result of function - deriving( Eq, Data.Data ) + deriving( Eq, Data.Data, Ord ) type CoercionN = Coercion -- always nominal type CoercionR = Coercion -- always representational @@ -938,15 +941,25 @@ ppr = pprCo instance Outputable CoSel where - ppr (SelTyCon n _r) = text "Tc" <> parens (int n) - ppr SelForAll = text "All" - ppr (SelFun fs) = text "Fun" <> parens (ppr fs) + ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r) + ppr SelForAll = text "All" + ppr (SelFun fs) = text "Fun" <> parens (ppr fs) +pprOneCharRole :: Role -> SDoc +pprOneCharRole Nominal = char 'N' +pprOneCharRole Representational = char 'R' +pprOneCharRole Phantom = char 'P' + instance Outputable FunSel where ppr SelMult = text "mult" ppr SelArg = text "arg" ppr SelRes = text "res" +instance NFData FunSel where + rnf SelMult = () + rnf SelArg = () + rnf SelRes = () + instance Binary CoSel where put_ bh (SelTyCon n r) = do { putByte bh 0; put_ bh n; put_ bh r } put_ bh SelForAll = putByte bh 1 @@ -963,9 +976,9 @@ _ -> return (SelFun SelRes) } instance NFData CoSel where - rnf (SelTyCon n r) = n `seq` r `seq` () + rnf (SelTyCon n r) = rnf n `seq` rnf r `seq` () rnf SelForAll = () - rnf (SelFun fs) = fs `seq` () + rnf (SelFun fs) = rnf fs `seq` () -- | A semantically more meaningful type to represent what may or may not be a -- useful 'Coercion'. @@ -1045,26 +1058,28 @@ between ForallTys, or TyConApps, or FunTys. There are three forms, split by the CoSel field inside the SelCo: -SelTyCon, SelForAll, and SelFun. +SelTyCon, SelForAll, and SelFun. The typing rules below are directly +checked by the SelCo case of GHC.Core.Lint.lintCoercion. * SelTyCon: - co : (T s1..sn) ~r0 (T t1..tn) - T is a data type, not a newtype, nor an arrow type - r = tyConRole tc r0 i + co : (T s1..sn) ~r (T t1..tn) + T is not a saturated FunTyCon (use SelFun for that) + T is injective at role r + ri = tyConRole tc r i i < n (i is zero-indexed) ---------------------------------- - SelCo (SelTyCon i r) : si ~r ti + SelCo (SelTyCon i ri) co : si ~ri ti - "Not a newtype": see Note [SelCo and newtypes] - "Not an arrow type": see SelFun below + "Injective at role r": see Note [SelCo and newtypes] + "Not saturated FunTyCon": see SelFun below See Note [SelCo Cached Roles] * SelForAll: co : forall (a:k1).t1 ~r0 forall (a:k2).t2 ---------------------------------- - SelCo SelForAll : k1 ~N k2 + SelCo SelForAll co : k1 ~N k2 NB: SelForAll always gives a Nominal coercion. @@ -1074,17 +1089,17 @@ co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) r = funRole r0 SelMult ---------------------------------- - SelCo (SelFun SelMult) : m1 ~r m2 + SelCo (SelFun SelMult) co : m1 ~r m2 co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) r = funRole r0 SelArg ---------------------------------- - SelCo (SelFun SelArg) : s1 ~r s2 + SelCo (SelFun SelArg) co : s1 ~r s2 co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) r = funRole r0 SelRes ---------------------------------- - SelCo (SelFun SelRes) : t1 ~r t2 + SelCo (SelFun SelRes) co : t1 ~r t2 Note [FunCo] ~~~~~~~~~~~~ @@ -1146,57 +1161,123 @@ which can be optimized to F g. -Note [CoAxiom index] -~~~~~~~~~~~~~~~~~~~~ -A CoAxiom has 1 or more branches. Each branch has contains a list -of the free type variables in that branch, the LHS type patterns, -and the RHS type for that branch. When we apply an axiom to a list -of coercions, we must choose which branch of the axiom we wish to -use, as the different branches may have different numbers of free -type variables. (The number of type patterns is always the same -among branches, but that doesn't quite concern us here.) +Note [Required foralls in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty). +It has type + forall a. e_ty +Note the Specified visibility of (forall a. e_ty); the Core type just isn't able +to express more than one visiblity, and we pick `Specified`. See `exprType` and +`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreTyLamForAllTyFlag`. -The Int in the AxiomInstCo constructor is the 0-indexed number -of the chosen branch. +So how can we ever get a term of type (forall a -> e_ty)? Answer: /only/ via a +cast built with ForAllCo. See `GHC.Core.Coercion.mkForAllVisCos`, +`GHC.Tc.Types.Evidence.mkWpForAllCast` and `GHC.Core.Make.mkCoreTyLams`. +This does not seem very satisfying, but it does the job. -Note [Forall coercions] -~~~~~~~~~~~~~~~~~~~~~~~ +An alternative would be to put a visibility flag into `Lam` (a huge change), +or into a `TyVar` (a more plausible change), but we leave that for the future. + +See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. + +Note [ForAllCo] +~~~~~~~~~~~~~~~ +See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare. + Constructing coercions between forall-types can be a bit tricky, because the kinds of the bound tyvars can be different. The typing rule is: + G |- kind_co : k1 ~N k2 + tv1 \not\in fv(typeKind(t1),typeKind(t2)) -- Skolem escape + G, tv1:k1 |- co : t1 ~r t2 + if r=N, then vis1=vis2 + ------------------------------------ + G |- ForAllCo (tv1:k1) vis1 vis2 kind_co co + : forall (tv1:k1) . t1 + ~r + forall (tv1:k2) . (t2[tv1 |-> (tv1:k2) |> sym kind_co]) - kind_co : k1 ~ k2 - tv1:k1 |- co : t1 ~ t2 - ------------------------------------------------------------------- - ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ - all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) +Several things to note here -First, the TyCoVar stored in a ForAllCo is really an optimisation: this field -should be a Name, as its kind is redundant. Thinking of the field as a Name -is helpful in understanding what a ForAllCo means. -The kind of TyCoVar always matches the left-hand kind of the coercion. +(FC1) First, the TyCoVar stored in a ForAllCo is really just a convenience: this + field should be a Name, as its kind is redundant. Thinking of the field as a + Name is helpful in understanding what a ForAllCo means. The kind of TyCoVar + always matches the left-hand kind of the coercion. -The idea is that kind_co gives the two kinds of the tyvar. See how, in the -conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + * The idea is that kind_co gives the two kinds of the tyvar. See how, in the + conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. -Of course, a type variable can't have different kinds at the same time. So, -we arbitrarily prefer the first kind when using tv1 in the inner coercion -co, which shows that t1 equals t2. + * Of course, a type variable can't have different kinds at the same time. + So, in `co` itself we use (tv1 : k1); hence the premise + tv1:k1 |- co : t1 ~r t2 -The last wrinkle is that we need to fix the kinds in the conclusion. In -t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of -the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with -(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it -mentions the same name with different kinds, but it *is* well-kinded, noting -that `(tv1:k2) |> sym kind_co` has kind k1. + * The last wrinkle is that we need to fix the kinds in the conclusion. In + t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of + the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with + (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it + mentions the same name with different kinds, but it *is* well-kinded, noting + that `(tv1:k2) |> sym kind_co` has kind k1. -This all really would work storing just a Name in the ForAllCo. But we can't -add Names to, e.g., VarSets, and there generally is just an impedance mismatch -in a bunch of places. So we use tv1. When we need tv2, we can use -setTyVarKind. + We could instead store just a Name in the ForAllCo, and it might even be + more efficient to do so. But we can't add Names to, e.g., VarSets, and + there generally is just an impedance mismatch in a bunch of places. So we + use tv1. When we need tv2, we can use setTyVarKind. +(FC2) Note that the kind coercion must be Nominal; and that the role `r` of + the final coercion is the same as that of the body coercion. + +(FC3) A ForAllCo allows casting between visibilities. For example: + ForAllCo a Required Specified (SubCo (Refl ty)) + : (forall a -> ty) ~R (forall a. ty) + But you can only cast between visiblities at Representational role; + Hence the premise + if r=N, then vis1=vis2 + in the typing rule. See also Note [ForAllTy and type equality] in + GHC.Core.TyCo.Compare. + +(FC4) See Note [Required foralls in Core]. + +(FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that + `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy] + in GHC.Core.TyCo.Rep for the motivation. If it does not appear free, + use FunTy. + + However we do /not/ impose the same restriction on ForAllCo in /coercions/. + Instead, in coercionLKind and coercionRKind, we use mkTyCoForAllTy to perform + the check and construct a FunTy when necessary. Why? + * For a coercion, all that matters is its kind, So ForAllCo vs FunCo does not + make a difference. + * Even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. + +(FC6) Invariant: in a ForAllCo where fco_tcv is a coercion variable, `cv`, + we insist that `cv` appears only in positions that are erased. In fact we use + a conservative approximation of this: we require that + (almostDevoidCoVarOfCo cv fco_body) + holds. This function checks that `cv` appers only within the type in a Refl + node and under a GRefl node (including in the Coercion stored in a GRefl). + It's possible other places are OK, too, but this is a safe approximation. + + Why all this fuss? See Section 5.8.5.2 of Richard's thesis. The idea is that + we cannot prove that the type system is consistent with unrestricted use of this + cv; the consistency proof uses an untyped rewrite relation that works over types + with all coercions and casts removed. So, we can allow the cv to appear only in + positions that are erased. + + Sadly, with heterogeneous equality, this restriction might be able to be + violated; Richard's thesis is unable to prove that it isn't. Specifically, the + liftCoSubst function might create an invalid coercion. Because a violation of + the restriction might lead to a program that "goes wrong", it is checked all + the time, even in a production compiler and without -dcore-lint. We *have* + proved that the problem does not occur with homogeneous equality, so this + check can be dropped once ~# is made to be homogeneous. + +(FC7) Invariant: in a ForAllCo, if fco_tcv is a CoVar, then + fco_visL = fco_visR = coreTyLamForAllTyFlag + c.f. (FT2) in Note [ForAllTy] + Note [Predicate coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1360,6 +1441,10 @@ Yikes! Clearly, this is terrible. The solution is simple: forbid SelCo to be used on newtypes if the internal coercion is representational. +More specifically, we use isInjectiveTyCon to determine whether +T is injective at role r: +* Newtypes and datatypes are both injective at Nominal role, but +* Newtypes are not injective at Representational role See the SelCo equation for GHC.Core.Lint.lintCoercion. This is not just some corner case discovered by a segfault somewhere; @@ -1405,17 +1490,30 @@ %************************************************************************ %* * - UnivCoProvenance + UnivCo %* * %************************************************************************ +Note [UnivCo] +~~~~~~~~~~~~~ A UnivCo is a coercion whose proof does not directly express its role and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof). -The different kinds of UnivCo are described by UnivCoProvenance. Really -each is entirely separate, but they all share the need to represent their -role and kind, which is done in the UnivCo constructor. +The different kinds of UnivCo are described by UnivCoProvenance. Really each +is entirely separate, but they all share the need to represent these fields: + UnivCo + { uco_prov :: UnivCoProvenance + , uco_role :: Role + , uco_lty, uco_rty :: Type + , uco_deps :: [Coercion] -- Coercions on which it depends + +Here, + * uco_role, uco_lty, uco_rty express the type of the coercion + * uco_prov says where it came from + * uco_deps specifies the coercions on which this proof (which is not + explicity given) depends. See + Note [The importance of tracking UnivCo dependencies] -} -- | For simplicity, we have just one UnivCo that represents a coercion from @@ -1427,47 +1525,139 @@ -- that they don't tell you what types they coercion between. (That info -- is in the 'UnivCo' constructor of 'Coercion'. data UnivCoProvenance - = PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom - -- roled coercions - - | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are - -- considered equivalent. See Note [ProofIrrelProv]. - -- Can be used in Nominal or Representational coercions + = PhantomProv -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions - | PluginProv String -- ^ From a plugin, which asserts that this coercion - -- is sound. The string is for the use of the plugin. + | ProofIrrelProv -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions - | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep - Bool -- True <=> the UnivCo must be homogeneously kinded - -- False <=> allow hetero-kinded, e.g. Int ~ Int# + | PluginProv String + -- ^ From a plugin, which asserts that this coercion is sound. + -- The string and the variable set are for the use by the plugin. - deriving Data.Data + deriving (Eq, Ord, Data.Data) + -- Why Ord? See Note [Ord instance of IfaceType] in GHC.Iface.Type instance Outputable UnivCoProvenance where - ppr (PhantomProv _) = text "(phantom)" - ppr (ProofIrrelProv _) = text "(proof irrel.)" - ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - ppr (CorePrepProv _) = text "(CorePrep)" + ppr PhantomProv = text "(phantom)" + ppr (ProofIrrelProv {}) = text "(proof irrel)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) +instance NFData UnivCoProvenance where + rnf p = p `seq` () + +instance Binary UnivCoProvenance where + put_ bh PhantomProv = putByte bh 1 + put_ bh ProofIrrelProv = putByte bh 2 + put_ bh (PluginProv a) = putByte bh 3 >> put_ bh a + get bh = do + tag <- getByte bh + case tag of + 1 -> return PhantomProv + 2 -> return ProofIrrelProv + 3 -> do a <- get bh + return $ PluginProv a + _ -> panic ("get UnivCoProvenance " ++ show tag) + + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~# Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo ProofIrrelProv Nominal (CoercionTy co1) (CoercionTy co2) [co5] + where + co5 :: (a1 ~# Bool) ~# (a2 ~# Bool) + co5 = TyConAppCo Nominal (~#) [, , co4, ] + + +Note [The importance of tracking UnivCo dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is vital that `UnivCo` (a coercion that lacks a proper proof) +tracks the coercions on which it depends. To see why, consider this program: + + type S :: Nat -> Nat + + data T (a::Nat) where + T1 :: T 0 + T2 :: ... + + f :: T a -> S (a+1) -> S 1 + f = /\a (x:T a) (y:a). + case x of + T1 (gco : a ~# 0) -> y |> wco + +For this to typecheck we need `wco :: S (a+1) ~# S 1`, given that `gco : a ~# 0`. +To prove that we need to know that `a+1 = 1` if `a=0`, which a plugin might know. +So it solves `wco` by providing a `UnivCo (PluginProv "my-plugin") (a+1) 1 [gco]`. + + But the `uco_deps` in `PluginProv` must mention `gco`! + +Why? Otherwise we might float the entire expression (y |> wco) out of the +the case alternative for `T1` which brings `gco` into scope. If this +happens then we aren't far from a segmentation fault or much worse. +See #23923 for a real-world example of this happening. + +So it is /crucial/ for the `UnivCo` to mention, in `uco_deps`, the coercion +variables used by the plugin to justify the `UnivCo` that it builds. You +should think of it like `TyConAppCo`: the `UnivCo` proof constructor is +applied to a list of coercions, just as `TyConAppCo` is + +It's very convenient to record a full coercion, not just a set of free coercion +variables, because during typechecking those coercions might contain coercion +holes `HoleCo`, which get filled in later. +-} + +{- ********************************************************************** +%* * + Coercion holes +%* * +%********************************************************************* -} + -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole = CoercionHole { ch_co_var :: CoVar -- See Note [CoercionHoles and coercion free variables] , ch_ref :: IORef (Maybe Coercion) - - , ch_hetero_kind :: Bool - -- True <=> arises from a kind-level equality - -- See Note [Equalities with incompatible kinds] - -- in GHC.Tc.Solver.Equality, wrinkle (EIK2) } coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var -isHeteroKindCoHole :: CoercionHole -> Bool -isHeteroKindCoHole = ch_hetero_kind - setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole setCoHoleCoVar h cv = h { ch_co_var = cv } @@ -1478,25 +1668,12 @@ dataTypeOf _ = mkNoRepType "CoercionHole" instance Outputable CoercionHole where - ppr (CoercionHole { ch_co_var = cv, ch_hetero_kind = hk }) - = braces (ppr cv <> ppWhen hk (text "[hk]")) + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) instance Uniquable CoercionHole where getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv -{- Note [Phantom coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = T1 | T2 -Then we have - T s ~R T t -for any old s,t. The witness for this is (TyConAppCo T Rep co), -where (co :: s ~P t) is a phantom coercion built with PhantomProv. -The role of the UnivCo is always Phantom. The Coercion stored is the -(nominal) kind coercion between the types - kind(s) ~N kind (t) - -Note [Coercion holes] +{- Note [Coercion holes] ~~~~~~~~~~~~~~~~~~~~~~~~ During typechecking, constraint solving for type classes works by - Generate an evidence Id, d7 :: Num a @@ -1571,40 +1748,10 @@ Here co2 is a CoercionHole. But we /must/ know that it is free in co1, because that's all that stops it floating outside the implication. - - -Note [ProofIrrelProv] -~~~~~~~~~~~~~~~~~~~~~ -A ProofIrrelProv is a coercion between coercions. For example: - - data G a where - MkG :: G Bool - -In core, we get - - G :: * -> * - MkG :: forall (a :: *). (a ~ Bool) -> G a - -Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want -a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be - - TyConAppCo Nominal MkG [co3, co4] - where - co3 :: co1 ~ co2 - co4 :: a1 ~ a2 - -Note that - co1 :: a1 ~ Bool - co2 :: a2 ~ Bool - -Here, - co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) - where - co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) - co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] -} + {- ********************************************************************* * * foldType and foldCoercion @@ -1661,7 +1808,6 @@ | tv `elemVarSet` acc = acc | otherwise = acc `extendVarSet` tv - we want to end up with fvs ty = go emptyVarSet ty emptyVarSet where @@ -1691,6 +1837,38 @@ But, amazingly, we get good code here too. GHC is careful not to mark TyCoFolder data constructor for deep_tcf as a loop breaker, so the record selections still cancel. And eta expansion still happens too. + +Note [Use explicit recursion in foldTyCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In foldTyCo you'll see things like: + go_tys _ [] = mempty + go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts +where we use /explicit recursion/. You might wonder about using foldl instead: + go_tys env = foldl (\t acc -> go_ty env t `mappend` acc) mempty +Or maybe foldl', or foldr. + +But don't do that for two reasons (see #24591) + +* We sometimes instantiate `a` to (Endo VarSet). Remembering + newtype Endo a = Endo (a->a) + after inlining `foldTyCo` bodily, the explicit recursion looks like + go_tys _ [] = \acc -> acc + go_tys env (t:ts) = \acc -> go_ty env t (go_tys env ts acc) + The strictness analyser has no problem spotting that this function is + strict in `acc`, provided `go_ty` is. + + But in the foldl form that is /much/ less obvious, and the strictness + analyser fails utterly. Result: lots and lots of thunks get built. In + !12037, Mikolaj found that GHC allocated /six times/ as much heap + on test perf/compiler/T9198 as a result of this single problem! + +* Second, while I think that using `foldr` would be fine (simple experiments in + #24591 suggest as much), it builds a local loop (with env free) and I'm not 100% + confident it'll be lambda lifted in the end. It seems more direct just to write + the code we want. + + On the other hand in `go_cvs` we might hope that the `foldr` will fuse with the + `dVarSetElems` so I have used `foldr`. -} data TyCoFolder env a @@ -1729,12 +1907,11 @@ = let !env' = tycobinder env tv vis -- Avoid building a thunk here in go_ty env (varType tv) `mappend` go_ty env' inner - -- Explicit recursion because using foldr builds a local - -- loop (with env free) and I'm not confident it'll be - -- lambda lifted in the end + -- See Note [Use explicit recursion in foldTyCo] go_tys _ [] = mempty go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts + -- See Note [Use explicit recursion in foldTyCo] go_cos _ [] = mempty go_cos env (c:cs) = go_co env c `mappend` go_cos env cs @@ -1744,13 +1921,13 @@ go_co env (TyConAppCo _ _ args) = go_cos env args go_co env (AppCo c1 c2) = go_co env c1 `mappend` go_co env c2 go_co env (CoVarCo cv) = covar env cv - go_co env (AxiomInstCo _ _ args) = go_cos env args + go_co env (AxiomCo _ cos) = go_cos env cos go_co env (HoleCo hole) = cohole env hole - go_co env (UnivCo p _ t1 t2) = go_prov env p `mappend` go_ty env t1 - `mappend` go_ty env t2 + go_co env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = go_ty env t1 `mappend` go_ty env t2 + `mappend` go_cos env deps go_co env (SymCo co) = go_co env co go_co env (TransCo c1 c2) = go_co env c1 `mappend` go_co env c2 - go_co env (AxiomRuleCo _ cos) = go_cos env cos go_co env (SelCo _ co) = go_co env co go_co env (LRCo _ co) = go_co env co go_co env (InstCo co arg) = go_co env co `mappend` go_co env arg @@ -1760,17 +1937,12 @@ go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 }) = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2 - go_co env (ForAllCo tv kind_co co) + go_co env (ForAllCo tv _vis1 _vis2 kind_co co) = go_co env kind_co `mappend` go_ty env (varType tv) `mappend` go_co env' co where env' = tycobinder env tv Inferred - go_prov env (PhantomProv co) = go_co env co - go_prov env (ProofIrrelProv co) = go_co env co - go_prov _ (PluginProv _) = mempty - go_prov _ (CorePrepProv _) = mempty - -- | A view function that looks through nothing. noView :: Type -> Maybe Type noView _ = Nothing @@ -1815,13 +1987,14 @@ coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (AppCo co arg) = coercionSize co + coercionSize arg -coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h +coercionSize (ForAllCo { fco_kind = h, fco_body = co }) + = 1 + coercionSize co + coercionSize h coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2 + coercionSize w coercionSize (CoVarCo _) = 1 coercionSize (HoleCo _) = 1 -coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) -coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (AxiomCo _ cs) = 1 + sum (map coercionSize cs) +coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 }) = 1 + typeSize t1 + typeSize t2 coercionSize (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 coercionSize (SelCo _ co) = 1 + coercionSize co @@ -1829,13 +2002,6 @@ coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg coercionSize (KindCo co) = 1 + coercionSize co coercionSize (SubCo co) = 1 + coercionSize co -coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) - -provSize :: UnivCoProvenance -> Int -provSize (PhantomProv co) = 1 + coercionSize co -provSize (ProofIrrelProv co) = 1 + coercionSize co -provSize (PluginProv _) = 1 -provSize (CorePrepProv _) = 1 {- ************************************************************************ diff --git a/GHC/Core/TyCo/Rep.hs-boot b/GHC/Core/TyCo/Rep.hs-boot --- a/GHC/Core/TyCo/Rep.hs-boot +++ b/GHC/Core/TyCo/Rep.hs-boot @@ -3,8 +3,9 @@ import GHC.Utils.Outputable ( Outputable ) import Data.Data ( Data ) -import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, ForAllTyFlag, FunTyFlag ) +import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, FunTyFlag ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) +import Language.Haskell.Syntax.Specificity (ForAllTyFlag) data Type data Coercion diff --git a/GHC/Core/TyCo/Subst.hs b/GHC/Core/TyCo/Subst.hs --- a/GHC/Core/TyCo/Subst.hs +++ b/GHC/Core/TyCo/Subst.hs @@ -5,7 +5,6 @@ -} -{-# LANGUAGE BangPatterns #-} -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst @@ -14,14 +13,14 @@ Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, - mkSubst, mkTvSubst, mkCvSubst, mkIdSubst, + mkSubst, mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst, getTvSubstEnv, getIdSubstEnv, - getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + getCvSubstEnv, substInScopeSet, setInScope, getSubstRangeTyCoFVs, isInScope, elemSubst, notElemSubst, zapSubst, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTCvSubst, extendTCvSubstWithClone, extendCvSubst, extendCvSubstWithClone, - extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, + extendTvSubst, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, unionSubst, zipTyEnv, zipCoEnv, @@ -42,7 +41,7 @@ cloneTyVarBndr, cloneTyVarBndrs, substVarBndr, substVarBndrs, substTyVarBndr, substTyVarBndrs, - substCoVarBndr, + substCoVarBndr, substDCoVarSet, substTyVar, substTyVars, substTyVarToTyVar, substTyCoVars, substTyCoBndr, substForAllCoBndr, @@ -58,12 +57,12 @@ ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo , mkNomReflCo, mkSubCo, mkSymCo , mkFunCo2, mkForAllCo, mkUnivCo - , mkAxiomInstCo, mkAppCo, mkGReflCo + , mkAxiomCo, mkAppCo, mkGReflCo , mkInstCo, mkLRCo, mkTyConAppCo , mkCoercionType - , coercionKind, coercionLKind, coVarKindsTypesRole ) + , coercionLKind, coVarTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) -import {-# SOURCE #-} GHC.Core.Ppr ( ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr import {-# SOURCE #-} GHC.Core ( CoreExpr ) import GHC.Core.TyCo.Rep @@ -73,7 +72,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Data.Pair import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Types.Unique.Supply @@ -82,7 +80,6 @@ import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.List (mapAccumL) @@ -105,9 +102,9 @@ data Subst = Subst InScopeSet -- Variables in scope (both Ids and TyVars) /after/ -- applying the substitution - IdSubstEnv -- Substitution from NcIds to CoreExprs - TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from CoVars to Coercions + IdSubstEnv -- Substitution from InId to OutExpr + TvSubstEnv -- Substitution from InTyVar to OutType + CvSubstEnv -- Substitution from InCoVar to OutCoercion -- INVARIANT 1: See Note [The substitution invariant] -- This is what lets us deal with name capture properly @@ -116,7 +113,7 @@ -- see Note [Substitutions apply only once] -- -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst" - -- and Note [Extending the TvSubstEnv and CvSubstEnv] + -- and Note [Extending the TvSubstEnv and CvSubstEnv] -- -- INVARIANT 4: See Note [Substituting types, coercions, and expressions] @@ -184,8 +181,10 @@ we use during unifications, it must not be repeatedly applied. Note [Extending the TvSubstEnv and CvSubstEnv] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tcvsubst_invariant# for the invariants that must hold. +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TvSubstEnv and CvSubstEnv have a binding for each TyCoVar + - whose unique has changed, OR + - whose kind has changed This invariant allows a short-cut when the subst envs are empty: if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) @@ -208,7 +207,7 @@ * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty Note [Substituting types, coercions, and expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Types and coercions are mutually recursive, and either may have variables "belonging" to the other. Thus, every time we wish to substitute in a type, we may also need to substitute in a coercion, and vice versa. @@ -272,9 +271,12 @@ isEmptyTCvSubst (Subst _ _ tv_env cv_env) = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs +mkSubst :: InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst +mkSubst = Subst +mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst +mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs + mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv @@ -296,8 +298,8 @@ getCvSubstEnv (Subst _ _ _ cenv) = cenv -- | Find the in-scope set: see Note [The substitution invariant] -getSubstInScope :: Subst -> InScopeSet -getSubstInScope (Subst in_scope _ _ _) = in_scope +substInScopeSet :: Subst -> InScopeSet +substInScopeSet (Subst in_scope _ _ _) = in_scope setInScope :: Subst -> InScopeSet -> Subst setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs @@ -374,13 +376,6 @@ = assert (isTyVar tv) $ Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst -extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty - = assert (isTyVar v ) - extendTvSubstAndInScope subst v ty -extendTvSubstBinderAndInScope subst (Anon {}) _ - = subst - extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst -- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone -- Does not look in the kind of the new variable; @@ -509,7 +504,7 @@ , not (all isCoVar cvs) = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos) | otherwise - = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + = mkVarEnv (zipEqual cvs cos) -- Pretty printing, for debugging only @@ -535,7 +530,8 @@ In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, how do we push sym into a ForAllCo? It's a little ugly. -Here is the typing rule: +Ignoring visibility, here is the typing rule +(see Note [ForAllCo] in GHC.Core.TyCo.Rep). h : k1 ~# k2 (tv : k1) |- g : ty1 ~# ty2 @@ -622,7 +618,7 @@ -- Pre-condition: the 'in_scope' set should satisfy Note [The substitution -- invariant]; specifically it should include the free vars of 'tys', -- and of 'ty' minus the domain of the subst. -substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty = assert (tvs `equalLength` tys ) substTy (mkTvSubst in_scope tenv) ty @@ -650,12 +646,12 @@ substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) -- | Type substitution, see 'zipTvSubst' -substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type] substTysWith tvs tys = assert (tvs `equalLength` tys ) substTys (zipTvSubst tvs tys) -- | Type substitution, see 'zipTvSubst' -substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type] substTysWithCoVars cvs cos = assert (cvs `equalLength` cos ) substTys (zipCvSubst cvs cos) @@ -663,7 +659,7 @@ -- to the in-scope set. This is useful for the case when the free variables -- aren't already in the in-scope set or easily available. -- See also Note [The substitution invariant]. -substTyAddInScope :: Subst -> Type -> Type +substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type substTyAddInScope subst ty = substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty @@ -715,7 +711,7 @@ -- Note [The substitution invariant]. substTy :: HasDebugCallStack => Subst -> Type -> Type substTy subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty @@ -726,8 +722,8 @@ -- substTy and remove this function. Please don't use in new code. substTyUnchecked :: Subst -> Type -> Type substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty - | otherwise = subst_ty subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty @@ -820,7 +816,7 @@ Nothing -> TyVarTy tv substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar --- Apply the substitution, expecing the result to be a TyVarTy +-- Apply the substitution, expecting the result to be a TyVarTy substTyVarToTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv) $ case lookupVarEnv tenv tv of @@ -886,18 +882,19 @@ go :: Coercion -> Coercion go (Refl ty) = mkNomReflCo $! (go_ty ty) go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) - go (TyConAppCo r tc args)= let args' = map go args - in args' `seqList` mkTyConAppCo r tc args' + go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args + go (AxiomCo con cos) = mkAxiomCo con $! go_cos cos go (AppCo co arg) = (mkAppCo $! go co) $! go arg - go (ForAllCo tv kind_co co) + go (ForAllCo tv visL visR kind_co co) = case substForAllCoBndrUnchecked subst tv kind_co of (subst', tv', kind_co') -> - ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co + ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co go (FunCo r afl afr w co1 co2) = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2 go (CoVarCo cv) = substCoVar subst cv - go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos - go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! - (go_ty t1)) $! (go_ty t2) + go (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = ((((mkUnivCo $! p) $! go_cos deps) $! r) $! + (go_ty t1)) $! (go_ty t2) go (SymCo co) = mkSymCo $! (go co) go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) go (SelCo d co) = mkSelCo d $! (go co) @@ -905,23 +902,25 @@ go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg go (KindCo co) = mkKindCo $! (go co) go (SubCo co) = mkSubCo $! (go co) - go (AxiomRuleCo c cs) = let cs1 = map go cs - in cs1 `seqList` AxiomRuleCo c cs1 go (HoleCo h) = HoleCo $! go_hole h - go_prov (PhantomProv kco) = PhantomProv (go kco) - go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) - go_prov p@(PluginProv _) = p - go_prov p@(CorePrepProv _) = p + go_cos cos = let cos' = map go cos + in cos' `seqList` cos' -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } +-- | Perform a substitution within a 'DVarSet' of free variables, +-- returning the shallow free coercion variables. +substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet +substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $ + dVarSetElems cvs + substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst - = substForAllCoBndrUsing False (substCo subst) subst + = substForAllCoBndrUsing (substCo subst) subst -- | Like 'substForAllCoBndr', but disables sanity checks. -- The problems that the sanity checks in substCo catch are described in @@ -931,29 +930,25 @@ substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst - = substForAllCoBndrUsing False (substCoUnchecked subst) subst + = substForAllCoBndrUsing (substCoUnchecked subst) subst -- See Note [Sym and ForAllCo] -substForAllCoBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co +substForAllCoBndrUsing :: (Coercion -> Coercion) -- transformation to kind co -> Subst -> TyCoVar -> KindCoercion -> (Subst, TyCoVar, KindCoercion) -substForAllCoBndrUsing sym sco subst old_var - | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var - | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var +substForAllCoBndrUsing sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sco subst old_var -substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co +substForAllCoTyVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co -> Subst -> TyVar -> KindCoercion -> (Subst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co +substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isTyVar old_var ) ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv , new_var, new_kind_co ) where - new_env | no_change && not sym = delVarEnv tenv old_var - | sym = extendVarEnv tenv old_var $ - TyVarTy new_var `CastTy` new_kind_co + new_env | no_change = delVarEnv tenv old_var | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) no_kind_change = noFreeVarsOfCo old_kind_co @@ -970,17 +965,16 @@ new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) -substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co +substForAllCoCoVarBndrUsing :: (Coercion -> Coercion) -- transformation to kind co -> Subst -> CoVar -> KindCoercion -> (Subst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) +substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isCoVar old_var ) ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv , new_var, new_kind_co ) where - new_cenv | no_change && not sym = delVarEnv cenv old_var + new_cenv | no_change = delVarEnv cenv old_var | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) no_kind_change = noFreeVarsOfCo old_kind_co @@ -989,11 +983,8 @@ new_kind_co | no_kind_change = old_kind_co | otherwise = sco old_kind_co - Pair h1 h2 = coercionKind new_kind_co - - new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type - new_var_type | sym = h2 - | otherwise = h1 + new_ki1 = coercionLKind new_kind_co + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1 substCoVar :: Subst -> CoVar -> Coercion substCoVar (Subst _ _ _ cenv) cv @@ -1091,7 +1082,7 @@ new_var = uniqAway in_scope subst_old_var subst_old_var = mkCoVar (varName old_var) new_var_type - (_, _, t1, t2, role) = coVarKindsTypesRole old_var + (t1, t2, role) = coVarTypesRole old_var t1' = subst_fn subst t1 t2' = subst_fn subst t2 new_var_type = mkCoercionType role t1' t2' diff --git a/GHC/Core/TyCo/Tidy.hs b/GHC/Core/TyCo/Tidy.hs --- a/GHC/Core/TyCo/Tidy.hs +++ b/GHC/Core/TyCo/Tidy.hs @@ -1,26 +1,27 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Tidying types and coercions for printing in error messages. module GHC.Core.TyCo.Tidy ( -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, + tidyType, tidyTypes, + tidyCo, tidyCos, tidyTopType, - tidyCo, tidyCos, - tidyForAllTyBinder, tidyForAllTyBinders + + tidyOpenType, tidyOpenTypes, + tidyOpenTypeX, tidyOpenTypesX, + tidyFreeTyCoVars, tidyFreeTyCoVarX, tidyFreeTyCoVarsX, + + tidyAvoiding, + tidyVarBndr, tidyVarBndrs, avoidNameClashes, + tidyForAllTyBinder, tidyForAllTyBinders, + tidyTyCoVarOcc ) where import GHC.Prelude import GHC.Data.FastString +import GHC.Core.Predicate( scopedSort ) import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) - +import GHC.Core.TyCo.FVs import GHC.Types.Name hiding (varName) import GHC.Types.Var import GHC.Types.Var.Env @@ -28,12 +29,76 @@ import Data.List (mapAccumL) -{- -%************************************************************************ -%* * -\subsection{TidyType} -%* * -%************************************************************************ +{- ********************************************************************** + + TidyType + +********************************************************************** -} + +{- Note [Tidying open types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When tidying some open types [t1,..,tn], we find their free vars, and tidy them first. + +But (tricky point) we restrict the occ_env part of inner_env to just the /free/ +vars of [t1..tn], so that we don't gratuitously rename the /bound/ variables. + +Example: assume the TidyEnv + ({"a1","b"} , [a_4 :-> a1, b_7 :-> b]) +and call tidyOpenTypes on + [a_1, forall a_2. Maybe (a_2,a_4), forall b. (b,a_1)] +All the a's have the same OccName, but different uniques. + +The TidyOccEnv binding for "b" relates b_7, which doesn't appear free in the +these types at all, so we don't want that to mess up the tidying for the +(forall b...). + +So we proceed as follows: + 1. Find the free vars. + In our example:the free vars are a_1 and a_4: + + 2. Use tidyFreeTyCoVars to tidy them (workhorse: `tidyFreeCoVarX`) + In our example: + * a_4 already has a tidy form, a1, so don't change that + * a_1 gets tidied to a2 + + 3. Trim the TidyOccEnv to OccNames of the tidied free vars (`trimTidyEnv`) + In our example "a1" and "a2" + + 4. Now tidy the types. In our example we get + [a2, forall a3. Maybe (a3,a1), forall b. (b, a2)] + +Note [Tidying is idempotent] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Key invariant: tidyFreeTyCoVars is idempotent, at least if you start with +an empty TidyEnv. This is important because: + + * The typechecker error message processing carefully tidies types, using + global knowledge; see for example calls to `tidyCt` in GHC.Tc.Errors. + + * Then the type pretty-printer, GHC.Core.TyCo.Ppr.pprType tidies the type + again, because that's important for pretty-printing types in general. + +But the second tidying is a no-op if the first step has happened, because +all the free vars will have distinct OccNames, so no renaming needs to happen. + +Note [tidyAvoiding] +~~~~~~~~~~~~~~~~~~~ +Consider tidying this unsolved constraint in GHC.Tc.Errors.report_unsolved. + C a_33, (forall a. Eq a => D a) +Here a_33 is a free unification variable. If we firs tidy [a_33 :-> "a"] +then we have no choice but to tidy the `forall a` to something else. But it +is confusing (sometimes very confusing) to gratuitously rename skolems in +this way -- see #24868. So it is better to : + + * Find the /bound/ skolems (just `a` in this case) + * Initialise the TidyOccEnv to avoid using "a" + * Now tidy the free a_33 to, say, "a1" + * Delete "a" from the TidyOccEnv + +This is done by `tidyAvoiding`. + +The last step is very important; if we leave "a" in the TidyOccEnv, when +we get to the (forall a. blah) we'll rename `a` to "a2", avoiding "a". -} -- | This tidies up a type for printing in an error message, or in @@ -94,31 +159,38 @@ tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv -- ^ Add the free 'TyVar's to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyCoVars tidy_env tyvars - = fst (tidyOpenTyCoVars tidy_env tyvars) +-- Precondition: input free vars are closed over kinds and +-- This function does a scopedSort, so that tidied variables +-- have tidied kinds. +-- See Note [Tidying is idempotent] +tidyFreeTyCoVars tidy_env tyvars = fst (tidyFreeTyCoVarsX tidy_env tyvars) --------------- -tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars +tidyFreeTyCoVarsX :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +-- Precondition: input free vars are closed over kinds and +-- This function does a scopedSort, so that tidied variables +-- have tidied kinds. +-- See Note [Tidying is idempotent] +tidyFreeTyCoVarsX env tyvars = mapAccumL tidyFreeTyCoVarX env $ + scopedSort tyvars --------------- -tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyFreeTyCoVarX :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name -- using the environment if one has not already been allocated. See -- also 'tidyVarBndr' -tidyOpenTyCoVar env@(_, subst) tyvar +-- See Note [Tidying is idempotent] +tidyFreeTyCoVarX env@(_, subst) tyvar = case lookupVarEnv subst tyvar of - Just tyvar' -> (env, tyvar') -- Already substituted - Nothing -> - let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) - in tidyVarBndr env' tyvar -- Treat it as a binder + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> tidyVarBndr env tyvar -- Treat it as a binder --------------- tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar -tidyTyCoVarOcc env@(_, subst) tv - = case lookupVarEnv subst tv of - Nothing -> updateVarType (tidyType env) tv - Just tv' -> tv' +tidyTyCoVarOcc env@(_, subst) tcv + = case lookupVarEnv subst tcv of + Nothing -> updateVarType (tidyType env) tcv + Just tcv' -> tcv' --------------- @@ -156,23 +228,27 @@ -- -- See Note [Strictness in tidyType and friends] tidyType :: TidyEnv -> Type -> Type -tidyType _ t@(LitTy {}) = t -- Preserve sharing -tidyType env (TyVarTy tv) = TyVarTy $! tidyTyCoVarOcc env tv -tidyType _ t@(TyConApp _ []) = t -- Preserve sharing if possible -tidyType env (TyConApp tycon tys) = TyConApp tycon $! tidyTypes env tys -tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w - ; !arg' = tidyType env arg - ; !res' = tidyType env res } - in ty { ft_mult = w', ft_arg = arg', ft_res = res' } -tidyType env (ty@(ForAllTy{})) = (mkForAllTys' $! (zip tvs' vis)) $! tidyType env' body_ty - where - (tvs, vis, body_ty) = splitForAllTyCoVars' ty - (env', tvs') = tidyVarBndrs env tvs -tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) -tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) +tidyType _ t@(LitTy {}) = t -- Preserve sharing +tidyType env (TyVarTy tv) = TyVarTy $! tidyTyCoVarOcc env tv +tidyType _ t@(TyConApp _ []) = t -- Preserve sharing if possible +tidyType env (TyConApp tycon tys) = TyConApp tycon $! tidyTypes env tys +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) +tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w + ; !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_mult = w', ft_arg = arg', ft_res = res' } +tidyType env (ty@(ForAllTy{})) = tidyForAllType env ty +tidyForAllType :: TidyEnv -> Type -> Type +tidyForAllType env ty + = (mkForAllTys' $! (zip tcvs' vis)) $! tidyType body_env body_ty + where + (tcvs, vis, body_ty) = splitForAllTyCoVars' ty + (body_env, tcvs') = tidyVarBndrs env tcvs + -- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that -- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but -- how should they be named? @@ -189,25 +265,54 @@ --------------- +tidyAvoiding :: [OccName] + -> (TidyEnv -> a -> TidyEnv) + -> a -> TidyEnv +-- Initialise an empty TidyEnv with some bound vars to avoid, +-- run the do_tidy function, and then remove the bound vars again. +-- See Note [tidyAvoiding] +tidyAvoiding bound_var_avoids do_tidy thing + = (occs' `delTidyOccEnvList` bound_var_avoids, vars') + where + (occs', vars') = do_tidy init_tidy_env thing + init_tidy_env = mkEmptyTidyEnv (initTidyOccEnv bound_var_avoids) + +--------------- +trimTidyEnv :: TidyEnv -> [TyCoVar] -> TidyEnv +trimTidyEnv (occ_env, var_env) tcvs + = (trimTidyOccEnv occ_env (map getOccName tcvs), var_env) + +--------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself -tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) -tidyOpenTypes env tys - = (env', tidyTypes (trimmed_occ_env, var_env) tys) +tidyOpenTypesX :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +-- See Note [Tidying open types] +tidyOpenTypesX env tys + = (env1, tidyTypes inner_env tys) where - (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ - tyCoVarsOfTypesWellScoped tys - trimmed_occ_env = initTidyOccEnv (map getOccName tvs') - -- The idea here was that we restrict the new TidyEnv to the - -- _free_ vars of the types, so that we don't gratuitously rename - -- the _bound_ variables of the types. + free_tcvs :: [TyCoVar] -- Closed over kinds + free_tcvs = tyCoVarsOfTypesList tys + (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs + inner_env = trimTidyEnv env1 free_tcvs' --------------- -tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) -tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in - (env', ty') +tidyOpenTypeX :: TidyEnv -> Type -> (TidyEnv, Type) +-- See Note [Tidying open types] +tidyOpenTypeX env ty + = (env1, tidyType inner_env ty) + where + free_tcvs = tyCoVarsOfTypeList ty + (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs + inner_env = trimTidyEnv env1 free_tcvs' --------------- +tidyOpenTypes :: TidyEnv -> [Type] -> [Type] +tidyOpenTypes env ty = snd (tidyOpenTypesX env ty) + +tidyOpenType :: TidyEnv -> Type -> Type +tidyOpenType env ty = snd (tidyOpenTypeX env ty) + +--------------- -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) tidyTopType :: Type -> Type tidyTopType ty = tidyType emptyTidyEnv ty @@ -218,7 +323,7 @@ -- -- See Note [Strictness in tidyType and friends] tidyCo :: TidyEnv -> Coercion -> Coercion -tidyCo env@(_, subst) co +tidyCo env co = go co where go_mco MRefl = MRefl @@ -228,18 +333,20 @@ go (GRefl r ty mco) = (GRefl r $! tidyType env ty) $! go_mco mco go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 - go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) - where (envp, tvp) = tidyVarBndr env tv + go (ForAllCo tv visL visR h co) + = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co) + where (envp, tvp) = tidyVarBndr env tv -- the case above duplicates a bit of work in tidying h and the kind -- of tv. But the alternative is to use coercionKind, which seems worse. go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2 - go (CoVarCo cv) = case lookupVarEnv subst cv of - Nothing -> CoVarCo cv - Just cv' -> CoVarCo cv' - go (HoleCo h) = HoleCo h - go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos - go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! - tidyType env t1) $! tidyType env t2 + go (CoVarCo cv) = CoVarCo $! go_cv cv + go (HoleCo h) = HoleCo $! go_hole h + go (AxiomCo ax cos) = AxiomCo ax $ strictMap go cos + go (UnivCo prov role t1 t2 cos) + = ((UnivCo prov role + $! tidyType env t1) + $! tidyType env t2) + $! strictMap go cos go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 go (SelCo d co) = SelCo d $! go co @@ -247,12 +354,11 @@ go (InstCo co ty) = (InstCo $! go co) $! go ty go (KindCo co) = KindCo $! go co go (SubCo co) = SubCo $! go co - go (AxiomRuleCo ax cos) = AxiomRuleCo ax $ strictMap go cos - go_prov (PhantomProv co) = PhantomProv $! go co - go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co - go_prov p@(PluginProv _) = p - go_prov p@(CorePrepProv _) = p + go_cv cv = tidyTyCoVarOcc env cv + + go_hole (CoercionHole cv r) = (CoercionHole $! go_cv cv) r + -- Tidy even the holes; tidied types should have tidied kinds tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env) diff --git a/GHC/Core/TyCon.hs b/GHC/Core/TyCon.hs --- a/GHC/Core/TyCon.hs +++ b/GHC/Core/TyCon.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -25,7 +24,8 @@ mkRequiredTyConBinder, mkAnonTyConBinder, mkAnonTyConBinders, tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, + isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder, + isInferredTyConBinder, isVisibleTcbVis, isInvisSpecTcbVis, -- ** Field labels @@ -46,8 +46,9 @@ noTcTyConScopedTyVars, -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, - isClassTyCon, isFamInstTyCon, + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, + isUnaryClassTyCon, isUnaryClassTyCon_maybe, + isFamInstTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon, @@ -56,10 +57,10 @@ tyConMustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe, isDataKindsPromotedDataCon, - isKindTyCon, isLiftedTypeKindTyConName, + isKindTyCon, isKindName, isLiftedTypeKindTyConName, isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, - isDataTyCon, + isBoxedDataTyCon, isTypeDataTyCon, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, @@ -68,13 +69,14 @@ isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, tyConInjectivityInfo, isBuiltInSynFamTyCon_maybe, - isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, isImplicitTyCon, isTyConWithSrcDataCons, isTcTyCon, setTcTyConKind, tcHasFixedRuntimeRep, isConcreteTyCon, + isValidDTT2TyCon, -- ** Extracting information out of TyCons tyConName, @@ -85,8 +87,6 @@ tyConCType_maybe, tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConAlgDataCons_maybe, - tyConSingleAlgDataCon_maybe, tyConFamilySize, tyConStupidTheta, tyConArity, @@ -125,10 +125,11 @@ -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, - primRepSizeB, - primElemRepSizeB, + isGcPtrRep, + primRepSizeB, primRepSizeW64_B, + primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, primRepsCompatible, primRepCompatible, @@ -173,13 +174,13 @@ import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants import GHC.Utils.Misc import GHC.Types.Unique.Set import GHC.Unit.Module +import Control.DeepSeq import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -487,7 +488,7 @@ | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv | otherwise = mkAnonTyConBinder tv -tyConBinderForAllTyFlag :: TyConBinder -> ForAllTyFlag +tyConBinderForAllTyFlag :: VarBndr a TyConBndrVis -> ForAllTyFlag tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis tyConBndrVisForAllTyFlag :: TyConBndrVis -> ForAllTyFlag @@ -513,10 +514,22 @@ isInvisSpecTcbVis (NamedTCB Specified) = True isInvisSpecTcbVis _ = False +isInvisInferTcbVis :: TyConBndrVis -> Bool +isInvisInferTcbVis (NamedTCB Inferred) = True +isInvisInferTcbVis _ = False + +isInvisSpecTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisSpecTyConBinder (Bndr _ tcb_vis) = isInvisSpecTcbVis tcb_vis + isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) +isInferredTyConBinder :: VarBndr var TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInferredTyConBinder (Bndr _ tcb_vis) = isInvisInferTcbVis tcb_vis + -- Build the 'tyConKind' from the binders and the result kind. -- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. mkTyConKind :: [TyConBinder] -> Kind -> Kind @@ -599,10 +612,11 @@ - but changing Anon/Required to Specified The last part about Required->Specified comes from this: - data T k (a:k) b = MkT (a b) -Here k is Required in T's kind, but we don't have Required binders in -the PiTyBinders for a term (see Note [No Required PiTyBinder in terms] -in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's PiTyBinders + data T k (a :: k) b = MkT (a b) +Here k is Required in T's kind, but we didn't have Required binders in +types of terms before the advent of the new, experimental RequiredTypeArguments +extension. So we historically changed Required to Specified when making MkT's PiTyBinders +and now continue to do so to avoid a breaking change. -} @@ -717,7 +731,12 @@ 0 -> return AnonTCB _ -> do { vis <- get bh; return (NamedTCB vis) } } +instance NFData TyConBndrVis where + rnf AnonTCB = () + rnf (NamedTCB vis) = rnf vis + + {- ********************************************************************* * * The TyCon type @@ -839,7 +858,8 @@ -- are fine), again after expanding any -- nested synonyms - synIsForgetful :: Bool, -- True <= at least one argument is not mentioned + synIsForgetful :: Bool, -- See Note [Forgetful type synonyms] + -- True <= at least one argument is not mentioned -- in the RHS (or is mentioned only under -- forgetful synonyms) -- Test is conservative, so True does not guarantee @@ -1111,6 +1131,11 @@ -- in tcHasFixedRuntimeRep. } + | UnaryClassTyCon { -- See Note [Unary class magic], esp (UCM2) + -- INVARIANT: the algTcFlavour of this TyCon is ClassTyCon + data_con :: DataCon + } + mkSumTyConRhs :: [DataCon] -> AlgTyConRhs mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) @@ -1166,11 +1191,12 @@ -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons (DataTyCon{ data_cons = cs }) = cs -visibleDataCons (NewTyCon{ data_con = c }) = [c] -visibleDataCons (TupleTyCon{ data_con = c }) = [c] -visibleDataCons (SumTyCon{ data_cons = cs }) = cs +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (UnaryClassTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs -- | Describes the flavour of an algebraic type constructor. For -- classes and data families, this flavour includes a reference to @@ -1188,7 +1214,9 @@ | UnboxedSumTyCon -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep" + -- See Note [ATyCon for classes] in "GHC.Types.TyThing" + -- INVARIANT: the algTcRhs is never NewTyCon; it could be + -- TupleTyCon, DataTyCon, UnaryClassTyCon | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the -- current tycon @@ -1336,7 +1364,7 @@ Note [Enumeration types] ~~~~~~~~~~~~~~~~~~~~~~~~ We define datatypes with no constructors to *not* be -enumerations; this fixes trac #2578, Otherwise we +enumerations; this fixes #2578, Otherwise we end up generating an empty table for __closure_tbl which is used by tagToEnum# to map Int# to constructors @@ -1406,6 +1434,194 @@ See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. +Note [Unary class magic] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a class with just one method, or with no methods and one +superclass: + class UC a where { op :: a -> a } + class Eq a => UD a where {} +Such a class is called a /unary class/. + +We could represent the dictionary for a unary class with a data type: + data UC a where { MkUC :: (a->a) -> UC a } + data UD a where { MkUD :: Eq a => UD a } +But it would be more efficent to use a newtype; and for decades GHC did +exactly that, because: + + * Unary classes are surprisingly common, so it's a useful optimisation. + + * The `reflection` library uses `unsafeCoerce` to /rely/ on the fact that + a unary class is ultimately represented by its payload. We may not like + it, and I hope to ultimately eliminate the necessity for this by using + `withDict` (see Note [withDict] in GHC.Tc.Instance.Class). But meanwhile + we'd prefer not to break this usage. + +But alas, using a newtype representation (surprisingly) led multiple, subtle, +Bad Things: see Note [Representing unary classes with newtypes: bad, bad, bad]. + +This Note explains what GHC now does for unary classes. + +(UCM0) Throughout the compiler, right up to the code generator, GHC thinks that a + unary class is just like a non-unary class: + - Represented by a data type, + - with one constructor, + - which has one field + +(UCM1) Then when converting from Core to STG, in GHC.CoreToStg, we effectively + transform + - op ta tb tc dict_arg --> dict_arg + - MkUC ta tb tc meth_arg --> meth_arg + + Note that we do this transformation well /after/ generating an interface file, + so importing modules only see the data constructor. + + This late transformation has a lot in common with the treatment of + `unsafeEqualityProof`; see (U2) in Note [Implementing unsafeCoerce] + in GHC.Internal.Unsafe.Coerce. + +In this way we get the efficiency of a newtype without the bugs that we get +by exposing the newtype representation too early. + +There are a number of wrinkles + +(UCM2) The TyCon for a unary class is /not/ identified as a newtype. + Rather, it has its own AlgTyConRhs, namely `UnaryClassTyCon` + +(UCM3) Unlike non-unary classes, a value of type (C ty), where `C` is a unary + class, might be bottom, because it is represented by the method type alone. + See GHC.Core.Type.isTerminatingType. + + Similarly in exprOkForSpeculation/exprOkToDiscard/exprOkForSpecEval, + in GHC.Core.Utils. In the utility funcion `app_ok` we need a special + case for the DFunIds; they generally terminate, but not for unary classes. + +(UMC4) To avoid regressions, in Core we want to remember that + (MkUC x) is really just x + (op d) is really just d + We account for this in several places: + + - `GHC.Core.Utils.exprIsTrivial` treats the above two forms as trivial + + - `GHC.Core.Unfold.sizeExpr` (which computes the size of an expression to + guide inlining) treats (MkUC e) as the same size as `e`, and similarly + (op d). + + - `GHC.Core.Unfold.inlineBoringOK` where we want to ensure that we + always-inline (MkUC op), even into a boring context. See (IB6) + in Note [inlineBoringOk] + +(UCM5) `GHC.Core.Unfold.Make.mkDFunUnfolding` builds a `DFunUnfolding` for + non-unary classes, but just an /ordinary/ unfolding for unary classes. + instance Num a => Num [a] where { .. } -- (I1) + instance UC a => UC [a] where { op = $cop } -- (I2) + From (I1) we get + $fNumList = /\a \(d:Num a). MkNum (..) (..) (..) + -- $fNumList has a DFunUnfolding + But from (I2) we get + $fUCList = /\a (d:UC a). MkUC ($cop a d) + -- $fUCList has a regular CoreUnfolding + + Why? Because we can safely inline $fUCList without code-size blow-up. + Just one less indirection. It'd probably work ok with a DFunUnfolding; + and it'd add another case for (UCM4) to spot. + +(UCM6) In the constraint solver, when constructing evidence for a unary class + (e.g. implicit parameters, withDict) be careful to use + - the data constructor to build it: see `evDictApp`, `evUnaryDictAppE` + - the class op to take it apart: see `evUnwrapIP` + +(UCM7) You might worry about + class UC1 a where { op :: Int# } -- Single unboxed field + class (a ~# b) => UC2 a b where {} -- Unboxed equality superclass + But these are illegal: predicates are always boxed, and all classes must have + lifted fields. + +(UCM8) The data constructor for a unary class has no wrapper, just a worker. + (And the worker is turned into a cast by GHC.CoreToStg.Prep.isUnaryClassApp, + as described above.) + +(UCM9) Unary classes are treated as injective by `isInjectiveTyCon`, just like + non-unary classes (which are TupleTyCons or DataTyCons). This matters, + because of the injectivity check done by lintCoercion (SelCo cs co) + in GHC.Core.Lint. There is a similar injectivity check in + GHC.Core.Opt.Arity.pushCoDataCon. + + Generally, we want unary classes to behave like ordinary non-unary ones. + +(UCM10) When, precisely, is a class unary? It is unary iff + it has one field (superclass or method) + of boxed type + The boxed-ness important. Consider + class (a ~# b) => a ~ b where {} + which is `eqClass` in GHC.Builtin.Types. This has only one field, but it is + definitely not a unary class: it is definitely represented by an ordinary + algebraic data type with a single field of type (a ~# b). + + See `unary_class` in `GHC.Tc.TyCl.tcClassDecl1` + +(UCM11) When building evidence for classes (unary or not) and implicit parameters, + the constraint solver is careful to use functions that hide the precise + evidence construction method. Eg.g `evWrapIPE`. + +(UCM12) In an interface-file description of a Class, we record whether or not + the class is unary. In theory this field is redundant, but because its value + depends on the superclass and method fields, it's very easy to end up with + a black hole when rehydrating interface the interface file. Easiest just to + store the bit! See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody. + + +Note [Representing unary classes with newtypes: bad, bad, bad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past we represented a unary class with a newtype, but that led to +some at least three really subtle bad consequences. + +* Problem 1: When we represented unary classes via a newtype, the + newtype axiom looked like + t1::CONSTRAINT r ~ t2::TYPE r + If TYPE and CONSTRAINT are apart, this can create unsoundness, via KindCo; + see #21623. Now we never make such a coercion, so that worry about TYPE + being apart from CONSTRAINT has gone away entirely. Hooray. + +* Problem 2: a horrible hack in GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap; + see Historical Note [Care with binder-swap on dictionaries]. + Now the hack is gone. + +* Problem 3: bogus specialisation. The gory details are explained + at https://gitlab.haskell.org/ghc/ghc/-/issues/23109#note_499130 + + We had (using newtype classes) + newtype SNat a = MKSNat Natural -- axiom snCo a :: SNat a ~ Natural + class KNat a where { natSing :: SNat a } -- axiom knCo a :: KNat a ~ SNat a + and a pattern match + K @a (g : 32 ~ a+1) -> ...(foo @a (d :: KNat a))... + where K is a data constructor binding `a` as an existential. + + In the code I was looking at, after lots of inlining an simplification, we find + that (d::KNat a) is built like this: + (d1 :: KNat 32) = 32 |> sym (snCo 32) |> sym (knCo 32) + (d2 :: SNat (a+1)) = d1 |> knCo g + (d3 :: Natural) = d2 |> snCo (a+1) + (d4 :: Natural) = d3 - 1 + (d :: KNat a) = d4 |> sym (snCo a) |> sym (knCo a) + + But d3 :: Natural = 32 |> (co's involving g) :: Natural ~ Natural + and that is just Refl. So we drop all the co's, including the crucial `g`, + and just say d3 = 32; and + d :: KNat a = (32-1) |> sym (snCo a) |> sym (knCo a) + Now, we can float `d` outwards, crucially aided by polymorphic specialisation, + (Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise) + and use that evidence to get an utterly bogus specialisation for the function + foo :: forall b. KNat b => blah + + Solution: don't use newtype classes. Then we get + (d1 :: KNat 32) = MkKN @32 (32 |> sym (snCo 32)) + (d2 :: SNat (a+1)) = natSing d1 |> SN g + (d3 :: Natural) = d2 |> snCo (a+1) + (d4 :: Natural) = d3 -1 + (d :: KNat a) = MkKN @a (d4 |> sym (snCo a)) + Now we don't get cancelling-out coercions. + + ************************************************************************ * * TyConRepName @@ -1530,13 +1746,16 @@ -} --- | A 'PrimRep' is an abstraction of a type. It contains information that --- the code generator needs in order to pass arguments, return results, + +-- | A 'PrimRep' is an abstraction of a /non-void/ type. +-- (Use 'PrimRepOrVoidRep' if you want void types too.) +-- It contains information that the code generator needs +-- in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep - = VoidRep - | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value +-- Unpacking of sum types is only supported since 9.6.1 + = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value | Int32Rep -- ^ Signed, 32-bit value @@ -1553,6 +1772,10 @@ | VecRep Int PrimElemRep -- ^ A vector deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep + -- See Note [VoidRep] in GHC.Types.RepType + deriving (Data.Data, Eq, Ord, Show) + data PrimElemRep = Int8ElemRep | Int16ElemRep @@ -1573,58 +1796,52 @@ ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 put_ bh (BoxedRep ml) = case ml of -- cheaper storage of the levity than using -- the Binary (Maybe Levity) instance - Nothing -> putByte bh 1 - Just Lifted -> putByte bh 2 - Just Unlifted -> putByte bh 3 - put_ bh Int8Rep = putByte bh 4 - put_ bh Int16Rep = putByte bh 5 - put_ bh Int32Rep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh IntRep = putByte bh 8 - put_ bh Word8Rep = putByte bh 9 - put_ bh Word16Rep = putByte bh 10 - put_ bh Word32Rep = putByte bh 11 - put_ bh Word64Rep = putByte bh 12 - put_ bh WordRep = putByte bh 13 - put_ bh AddrRep = putByte bh 14 - put_ bh FloatRep = putByte bh 15 - put_ bh DoubleRep = putByte bh 16 - put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per + Nothing -> putByte bh 0 + Just Lifted -> putByte bh 1 + Just Unlifted -> putByte bh 2 + put_ bh Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure $ BoxedRep Nothing - 2 -> pure $ BoxedRep (Just Lifted) - 3 -> pure $ BoxedRep (Just Unlifted) - 4 -> pure Int8Rep - 5 -> pure Int16Rep - 6 -> pure Int32Rep - 7 -> pure Int64Rep - 8 -> pure IntRep - 9 -> pure Word8Rep - 10 -> pure Word16Rep - 11 -> pure Word32Rep - 12 -> pure Word64Rep - 13 -> pure WordRep - 14 -> pure AddrRep - 15 -> pure FloatRep - 16 -> pure DoubleRep - 17 -> VecRep <$> get bh <*> get bh + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) instance Binary PrimElemRep where put_ bh per = putByte bh (fromIntegral (fromEnum per)) get bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _ = False @@ -1669,12 +1886,40 @@ DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform BoxedRep _ -> platformWordSizeInBytes platform - VoidRep -> 0 (VecRep len rep) -> len * primElemRepSizeB platform rep +-- | Like primRepSizeB but assumes pointers/words are 8 words wide. +-- +-- This can be useful to compute the size of a rep as if we were compiling +-- for a 64bit platform. +primRepSizeW64_B :: PrimRep -> Int +primRepSizeW64_B = \case + IntRep -> 8 + WordRep -> 8 + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> 8 + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> 8 + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> 8 + BoxedRep{} -> 8 + (VecRep len rep) -> len * primElemRepSizeW64_B rep + primElemRepSizeB :: Platform -> PrimElemRep -> Int primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep +-- | Like primElemRepSizeB but assumes pointers/words are 8 words wide. +-- +-- This can be useful to compute the size of a rep as if we were compiling +-- for a 64bit platform. +primElemRepSizeW64_B :: PrimElemRep -> Int +primElemRepSizeW64_B = primRepSizeW64_B . primElemRepToPrimRep + primElemRepToPrimRep :: PrimElemRep -> PrimRep primElemRepToPrimRep Int8ElemRep = Int8Rep primElemRepToPrimRep Int16ElemRep = Int16Rep @@ -1868,7 +2113,7 @@ noTcTyConScopedTyVars :: [(Name, TcTyVar)] noTcTyConScopedTyVars = [] --- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld#@ +-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld@ -- Primitive TyCons are marshalable iff not lifted. -- If you'd like to change this, modify marshalablePrimTyCon. mkPrimTyCon :: Name -> [TyConBinder] @@ -1946,19 +2191,30 @@ | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True | otherwise = False -isDataTyCon :: TyCon -> Bool +-- | Returns @True@ if a boxed type headed by the given @TyCon@ +-- satisfies condition DTT2 of Note [DataToTag overview] in +-- GHC.Tc.Instance.Class +isValidDTT2TyCon :: TyCon -> Bool +isValidDTT2TyCon = isBoxedDataTyCon + +isBoxedDataTyCon :: TyCon -> Bool -- ^ Returns @True@ for data types that are /definitely/ represented by -- heap-allocated constructors. These are scrutinised by Core-level -- @case@ expressions, and they get info tables allocated for them. -- --- Generally, the function will be true for all @data@ types and false --- for @newtype@s, unboxed tuples, unboxed sums and type family --- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- Generally, the function will be +-- true for all `data` types and +-- false for newtype +-- unboxed tuples +-- unboxed sums +-- type family +-- type data +-- 'TyCon's. But it is not guaranteed to return `True` in all cases -- that it could. -- -- NB: for a data type family, only the /instance/ 'TyCon's -- get an info table. The family declaration 'TyCon' does not -isDataTyCon (TyCon { tyConDetails = details }) +isBoxedDataTyCon (TyCon { tyConDetails = details }) | AlgTyCon {algTcRhs = rhs} <- details = case rhs of TupleTyCon { tup_sort = sort } @@ -1969,8 +2225,9 @@ -- See Note [Type data declarations] in GHC.Rename.Module. DataTyCon { is_type_data = type_data } -> not type_data NewTyCon {} -> False + UnaryClassTyCon {} -> False AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon _ = False +isBoxedDataTyCon _ = False -- | Was this 'TyCon' declared as "type data"? -- See Note [Type data declarations] in GHC.Rename.Module. @@ -1987,23 +2244,34 @@ -- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality" isInjectiveTyCon :: TyCon -> Role -> Bool isInjectiveTyCon (TyCon { tyConDetails = details }) role - = go details role + = go details where - go _ Phantom = True -- Vacuously; (t1 ~P t2) holds for all t1, t2! - go (AlgTyCon {}) Nominal = True - go (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs - go (SynonymTyCon {}) _ = False + go _ | Phantom <- role = True -- Vacuously; (t1 ~P t2) holds for all t1, t2! + + go (AlgTyCon {algTcRhs = rhs}) + | Nominal <- role = True + | Representational <- role = go_alg_rep rhs + go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) - Nominal = True - go (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj - go (FamilyTyCon {}) _ = False - go (PrimTyCon {}) _ = True - go (PromotedDataCon {}) _ = True - go (TcTyCon {}) _ = True + | Nominal <- role = True + go (FamilyTyCon { famTcInj = Injective inj }) + | Nominal <- role = and inj + go (FamilyTyCon {}) = False - -- Reply True for TcTyCon to minimise knock on type errors - -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl + go (SynonymTyCon {}) = False + go (PrimTyCon {}) = True + go (PromotedDataCon {}) = True + go (TcTyCon {}) = True + -- Reply True for TcTyCon to minimise knock on type errors + -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl + -- go_alg_rep used only at Representational role + go_alg_rep (TupleTyCon {}) = True + go_alg_rep (SumTyCon {}) = True + go_alg_rep (DataTyCon {}) = True + go_alg_rep (UnaryClassTyCon {}) = True -- See (UCM9) in Note [Unary class magic] + go_alg_rep (AbstractTyCon {}) = False + go_alg_rep (NewTyCon {}) = False -- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds -- (where r is the role passed in): @@ -2023,15 +2291,6 @@ -- In all other cases, injectivity implies generativity go r _ = isInjectiveTyCon tc r --- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective --- with respect to representational equality? -isGenInjAlgRhs :: AlgTyConRhs -> Bool -isGenInjAlgRhs (TupleTyCon {}) = True -isGenInjAlgRhs (SumTyCon {}) = True -isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (AbstractTyCon {}) = False -isGenInjAlgRhs (NewTyCon {}) = False - -- | Is this 'TyCon' that for a @newtype@ isNewTyCon :: TyCon -> Bool isNewTyCon (TyCon { tyConDetails = details }) @@ -2080,11 +2339,43 @@ -- True. Thus, False means that all bound variables appear on the RHS; -- True may not mean anything, as the test to set this flag is -- conservative. +-- +-- See Note [Forgetful type synonyms] isForgetfulSynTyCon :: TyCon -> Bool isForgetfulSynTyCon (TyCon { tyConDetails = details }) | SynonymTyCon { synIsForgetful = forget } <- details = forget | otherwise = False +{- Note [Forgetful type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type synonyms is /forgetful/ if its RHS fails to mention one (or more) of its bound variables. + +Forgetfulness is conservative: + * A non-forgetful synonym /guarantees/ to mention all its bound variables in its RHS. + * It is always safe to classify a synonym as forgetful. + +Examples: + type R = Int -- Not forgetful + type S a = Int -- Forgetful + type T1 a = Int -> S a -- Forgetful + type T2 a = a -> S a -- Not forgetful + type T3 a = Int -> F a -- Not forgetful + where type family F a + +* R shows that nullary synonyms are not forgetful. + +* T2 shows that forgetfulness needs to account for uses of forgetful + synonyms. `a` appears on the RHS, but only under a forgetful S + +* T3 shows that non-forgetfulness is not the same as injectivity. T3 mentions its + bound variable on its RHS, but under a type family. So it is entirely possible + that T3 Int ~ T3 Bool + +* Since type synonyms are non-recursive, we don't need a fixpoint analysis to + determine forgetfulness. It's rather easy -- see `GHC.Core.Type.buildSynTyCon`, + which is a bit over-conservative for over-saturated synonyms. +-} + -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand. @@ -2114,9 +2405,11 @@ isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details }) | AlgTyCon { algTcRhs = rhs } <- details = case rhs of - DataTyCon { is_enum = res } -> res - TupleTyCon {} -> arity == 0 - _ -> False + DataTyCon { is_enum = res } -> res + TupleTyCon { tup_sort = tsort } + | arity == 0 -> isBoxed (tupleSortBoxity tsort) + -- () is an enumeration, but (##) is not + _ -> False | otherwise = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family? @@ -2278,19 +2571,35 @@ = not (isTypeDataCon dc) | otherwise = False --- | Is this tycon really meant for use at the kind level? That is, --- should it be permitted without -XDataKinds? +-- | Is this 'TyCon' really meant for use at the kind level? That is, +-- should it be permitted without @DataKinds@? isKindTyCon :: TyCon -> Bool -isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys +isKindTyCon = isKindUniquable +-- | This is 'Name' really meant for use at the kind level? That is, +-- should it be permitted wihout @DataKinds@? +isKindName :: Name -> Bool +isKindName = isKindUniquable + +-- | The workhorse for 'isKindTyCon' and 'isKindName'. +isKindUniquable :: Uniquable a => a -> Bool +isKindUniquable thing = getUnique thing `memberUniqueSet` kindTyConKeys + -- | These TyCons should be allowed at the kind level, even without -- -XDataKinds. -kindTyConKeys :: UniqSet Unique -kindTyConKeys = unionManyUniqSets - ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ] - : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon - , multiplicityTyCon - , vecCountTyCon, vecElemTyCon ] ) +kindTyConKeys :: UniqueSet +kindTyConKeys = fromListUniqueSet $ + -- Make sure to keep this in sync with the following: + -- + -- - The Overview section in docs/users_guide/exts/data_kinds.rst in the GHC + -- User's Guide. + -- + -- - The typecheck/should_compile/T22141f.hs test case, which ensures that all + -- of these can successfully be used without DataKinds. + [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey, cONSTRAINTTyConKey ] + ++ concatMap tycon_with_datacons [ runtimeRepTyCon, levityTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ] where tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) @@ -2352,10 +2661,14 @@ -- the representation be fully-known, including levity variables. -- This might be relaxed in the future (#15532). - TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) + TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) || + -- (# #) also has fixed rep. + tyConArity tc == 0 SumTyCon {} -> False -- only unboxed sums here + UnaryClassTyCon {} -> True -- Always boxed + NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep -- A newtype might not have a fixed runtime representation -- with UnliftedNewtypes (#17360) @@ -2487,11 +2800,12 @@ tyConDataCons_maybe (TyCon { tyConDetails = details }) | AlgTyCon {algTcRhs = rhs} <- details = case rhs of - DataTyCon { data_cons = cons } -> Just cons - NewTyCon { data_con = con } -> Just [con] - TupleTyCon { data_con = con } -> Just [con] - SumTyCon { data_cons = cons } -> Just cons - _ -> Nothing + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + UnaryClassTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing tyConDataCons_maybe _ = Nothing -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ @@ -2502,11 +2816,12 @@ tyConSingleDataCon_maybe (TyCon { tyConDetails = details }) | AlgTyCon { algTcRhs = rhs } <- details = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - NewTyCon { data_con = c } -> Just c - _ -> Nothing - | otherwise = Nothing + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + UnaryClassTyCon { data_con = c } -> Just c + _ -> Nothing + | otherwise = Nothing -- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. tyConSingleDataCon :: TyCon -> DataCon @@ -2515,23 +2830,6 @@ Just c -> c Nothing -> pprPanic "tyConDataCon" (ppr tc) --- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes. -tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleAlgDataCon_maybe tycon - | isNewTyCon tycon = Nothing - | otherwise = tyConSingleDataCon_maybe tycon - --- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type --- or a sum type with data constructors dcs. If the 'TyCon' has more than one --- constructor, or represents a primitive or function type constructor then --- @Nothing@ is returned. --- --- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes. -tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConAlgDataCons_maybe tycon - | isNewTyCon tycon = Nothing - | otherwise = tyConDataCons_maybe tycon - -- | Determine the number of value constructors a 'TyCon' has. Panics if the -- 'TyCon' is not algebraic or a tuple tyConFamilySize :: TyCon -> Int @@ -2540,6 +2838,7 @@ = case rhs of DataTyCon { data_cons_size = size } -> size NewTyCon {} -> 1 + UnaryClassTyCon {} -> 1 TupleTyCon {} -> 1 SumTyCon { data_cons_size = size } -> size _ -> pprPanic "tyConFamilySize 1" (ppr tc) @@ -2603,6 +2902,7 @@ tyConStupidTheta tc@(TyCon { tyConDetails = details }) | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid | PrimTyCon {} <- details = [] + | PromotedDataCon {} <- details = [] | otherwise = pprPanic "tyConStupidTheta" (ppr tc) -- | Extract the 'TyVar's bound by a vanilla type synonym @@ -2628,6 +2928,22 @@ | FamilyTyCon {famTcFlav = flav} <- details = Just flav | otherwise = Nothing +isUnaryClassTyCon :: TyCon -> Bool +isUnaryClassTyCon tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClassTyCon {} } <- details + = assertPpr (case flav of { ClassTyCon {} -> True; _ -> False }) (ppr tc) $ + True + | otherwise + = False + +isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon) +isUnaryClassTyCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = ClassTyCon cls _ + , algTcRhs = UnaryClassTyCon { data_con = dc } } <- details + = Just (cls, dc) + | otherwise + = Nothing + -- | Is this 'TyCon' that for a class instance? isClassTyCon :: TyCon -> Bool isClassTyCon (TyCon { tyConDetails = details }) @@ -2742,11 +3058,12 @@ SumTyCon {} -> SumFlavour DataTyCon {} -> DataTypeFlavour NewTyCon {} -> NewtypeFlavour + UnaryClassTyCon {} -> ClassFlavour AbstractTyCon {} -> AbstractTypeFlavour | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details = case flav of - DataFamilyTyCon{} -> OpenFamilyFlavour IAmData parent + DataFamilyTyCon{} -> OpenFamilyFlavour (IAmData DataType) parent OpenSynFamilyTyCon -> OpenFamilyFlavour IAmType parent ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour @@ -2767,7 +3084,7 @@ tcFlavourMustBeSaturated AbstractTypeFlavour {} = False tcFlavourMustBeSaturated BuiltInTypeFlavour = False tcFlavourMustBeSaturated PromotedDataConFlavour = False -tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData -> False; IAmType -> True } +tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True } tcFlavourMustBeSaturated TypeSynonymFlavour = True tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True @@ -2815,6 +3132,10 @@ 0 -> return NotInjective _ -> do { xs <- get bh ; return (Injective xs) } } + +instance NFData Injectivity where + rnf NotInjective = () + rnf (Injective xs) = rnf xs -- | Returns whether or not this 'TyCon' is definite, or a hole -- that may be filled in at some later point. See Note [Skolem abstract data] diff --git a/GHC/Core/TyCon.hs-boot b/GHC/Core/TyCon.hs-boot --- a/GHC/Core/TyCon.hs-boot +++ b/GHC/Core/TyCon.hs-boot @@ -12,6 +12,7 @@ type TyConRepName = Name +isNewTyCon :: TyCon -> Bool isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool diff --git a/GHC/Core/TyCon/Env.hs b/GHC/Core/TyCon/Env.hs --- a/GHC/Core/TyCon/Env.hs +++ b/GHC/Core/TyCon/Env.hs @@ -103,7 +103,7 @@ anyTyConEnv f x = nonDetFoldUFM ((||) . f) False x disjointTyConEnv x y = disjointUFM x y -lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n) +lookupTyConEnv_NF env n = expectJust (lookupTyConEnv env n) -- | Deterministic TyCon Environment -- diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs --- a/GHC/Core/Type.hs +++ b/GHC/Core/Type.hs @@ -33,7 +33,7 @@ mkScaledFunTys, mkInvisFunTy, mkInvisFunTys, tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy, - splitFunTy, splitFunTy_maybe, + splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe, splitFunTys, funResultTy, funArgTy, funTyConAppTy_maybe, funTyFlagTyCon, tyConAppFunTy_maybe, tyConAppFunCo_maybe, @@ -48,14 +48,14 @@ mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTy, mkSpecForAllTys, - mkVisForAllTys, mkTyCoInvForAllTy, + mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy, mkInfForAllTy, mkInfForAllTys, splitForAllTyCoVars, splitForAllTyVars, splitForAllReqTyBinders, splitForAllInvisTyBinders, - splitForAllForAllTyBinders, + splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe, splitForAllTyCoVar_maybe, splitForAllTyCoVar, splitForAllTyVar_maybe, splitForAllCoVar_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, + splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders, getRuntimeArgTys, mkTyConBindersPreferAnon, mkPiTy, mkPiTys, @@ -69,21 +69,18 @@ mkCharLitTy, isCharLitTy, isLitTy, - isPredTy, - getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, getLevity, levityType_maybe, mkCastTy, mkCoercionTy, splitCastTy_maybe, ErrorMsgType, - userTypeError_maybe, pprUserTypeErrorTy, + userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy, coAxNthLHS, stripCoercionTy, - splitInvisPiTys, splitInvisPiTysN, - invisibleTyBndrCount, + splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount, filterOutInvisibleTypes, filterOutInferredTypes, partitionInvisibleTypes, partitionInvisibles, tyConForAllTyFlags, appTyForAllTyFlags, @@ -113,7 +110,7 @@ isForAllTy_ty, isForAllTy_co, isForAllTy_invis_ty, isPiTy, isTauTy, isFamFreeTy, - isCoVarType, isAtomicTy, + isAtomicTy, isValidJoinPointType, tyConAppNeedsKindSig, @@ -122,11 +119,11 @@ mkTYPEapp, mkTYPEapp_maybe, mkCONSTRAINTapp, mkCONSTRAINTapp_maybe, mkBoxedRepApp_maybe, mkTupleRepApp_maybe, - typeOrConstraintKind, + typeOrConstraintKind, liftedTypeOrConstraintKind, -- *** Levity and boxity sORTKind_maybe, typeTypeOrConstraint, - typeLevity_maybe, tyConIsTYPEorCONSTRAINT, + typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT, isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind, isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, isBoxedRuntimeRep, @@ -135,7 +132,7 @@ kindBoxedRepLevity_maybe, mightBeLiftedType, mightBeUnliftedType, definitelyLiftedType, definitelyUnliftedType, - isAlgType, isDataFamilyAppType, + isAlgType, isDataFamilyApp, isSatTyFamApp, isPrimitiveType, isStrictType, isTerminatingType, isLevityTy, isLevityVar, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, @@ -154,7 +151,7 @@ Kind, -- ** Finding the kind of a type - typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, + typeKind, typeHasFixedRuntimeRep, tcIsLiftedTypeKind, isConstraintKind, isConstraintLikeKind, returnsConstraintKind, tcIsBoxedTypeKind, isTypeLikeKind, @@ -171,17 +168,13 @@ anyFreeVarsOfType, anyFreeVarsOfTypes, noFreeVarsOfType, - expandTypeSynonyms, + expandTypeSynonyms, expandSynTyConApp_maybe, typeSize, occCheckExpand, -- ** Closing over kinds closeOverKindsDSet, closeOverKindsList, closeOverKinds, - -- * Well-scoped lists of variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - -- * Forcing evaluation of types seqType, seqTypes, @@ -198,15 +191,14 @@ -- ** Manipulating type substitutions emptyTvSubstEnv, emptySubst, mkEmptySubst, - mkSubst, zipTvSubst, mkTvSubstPrs, + mkTCvSubst, zipTvSubst, mkTvSubstPrs, zipTCvSubst, notElemSubst, getTvSubstEnv, - zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTCvSubst, extendCvSubst, - extendTvSubst, extendTvSubstBinderAndInScope, - extendTvSubstList, extendTvSubstAndInScope, + extendTvSubst, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, extendTvSubstWithClone, extendTCvSubstWithClone, @@ -224,18 +216,10 @@ substTyCoBndr, substTyVarToTyVar, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyForAllTyBinder, tidyForAllTyBinders, - -- * Kinds isTYPEorCONSTRAINT, - isConcreteType, isFixedRuntimeRepKind, + isConcreteType, + isFixedRuntimeRepKind ) where import GHC.Prelude @@ -247,14 +231,12 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.Tidy import GHC.Core.TyCo.FVs -- friends: import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Types.Unique.Set import GHC.Core.TyCon import GHC.Builtin.Types.Prim @@ -273,7 +255,7 @@ import {-# SOURCE #-} GHC.Core.Coercion ( mkNomReflCo, mkGReflCo, mkReflCo , mkTyConAppCo, mkAppCo - , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo + , mkForAllCo, mkFunCo2, mkAxiomCo, mkUnivCo , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo , mkKindCo, mkSubCo, mkFunCo, funRole , decomposePiCos, coercionKind @@ -288,11 +270,10 @@ import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.FastString -import Control.Monad ( guard ) -import GHC.Data.Maybe ( orElse, isJust ) +import GHC.Data.Maybe ( orElse, isJust, firstJust ) +import GHC.List (build) -- $type_classification -- #type_classification# @@ -430,7 +411,7 @@ saturates [] _ = False saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1) -- Arities are always positive; the assertion just checks - -- that, to avoid an ininite loop in the bad case + -- that, to avoid an infinite loop in the bad case -- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path -- into call-sites. @@ -549,17 +530,18 @@ = mkTyConAppCo r tc (map (go_co subst) args) go_co subst (AppCo co arg) = mkAppCo (go_co subst co) (go_co subst arg) - go_co subst (ForAllCo tv kind_co co) + go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co }) = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in - mkForAllCo tv' kind_co' (go_co subst' co) + mkForAllCo tv' visL visR kind_co' (go_co subst' co) go_co subst (FunCo r afl afr w co1 co2) = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2) go_co subst (CoVarCo cv) = substCoVar subst cv - go_co subst (AxiomInstCo ax ind args) - = mkAxiomInstCo ax ind (map (go_co subst) args) - go_co subst (UnivCo p r t1 t2) - = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (AxiomCo ax cs) + = mkAxiomCo ax (map (go_co subst) cs) + go_co subst co@(UnivCo { uco_lty = lty, uco_rty = rty }) + = co { uco_lty = go subst lty, uco_rty = go subst rty } go_co subst (SymCo co) = mkSymCo (go_co subst co) go_co subst (TransCo co1 co2) @@ -574,21 +556,10 @@ = mkKindCo (go_co subst co) go_co subst (SubCo co) = mkSubCo (go_co subst co) - go_co subst (AxiomRuleCo ax cs) - = AxiomRuleCo ax (map (go_co subst) cs) go_co _ (HoleCo h) = pprPanic "expandTypeSynonyms hit a hole" (ppr h) - go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) - go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) - go_prov _ p@(PluginProv _) = p - go_prov _ p@(CorePrepProv _) = p - - -- the "False" and "const" are to accommodate the type of - -- substForAllCoBndrUsing, which is general enough to - -- handle coercion optimization (which sometimes swaps the - -- order of a coercion) - go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst {- Notes on type synonyms ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -816,7 +787,7 @@ [lev] -> levityType_maybe lev _ -> Nothing -- Type isn't of kind RuntimeRep -- The latter case happens via the call to isLiftedRuntimeRep - -- in GHC.Tc.Errors.Ppr.pprMisMatchMsg (#22742) + -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742) else Just Unlifted -- Avoid searching all the unlifted RuntimeRep type cons -- In the RuntimeRep data type, only LiftedRep is lifted @@ -827,7 +798,7 @@ -- Splitting Levity -------------------------------------------- --- | `levity_maybe` takes a Type of kind Levity, and returns its levity +-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity -- May not be possible for a type variable or type family application levityType_maybe :: LevityType -> Maybe Levity levityType_maybe lev @@ -850,7 +821,7 @@ Note [Efficiency for ForAllCo case of mapTyCoX] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. +As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches the left-hand kind of the coercion. This is convenient lots of the time, but not when mapping a function over a coercion. @@ -914,7 +885,8 @@ -> (go_ty (), go_tys (), go_co (), go_cos ()) {-# INLINE mapTyCoX #-} -- See Note [Specialising mappers] -mapTyCoX :: Monad m => TyCoMapper env m +mapTyCoX :: forall m env. Monad m + => TyCoMapper env m -> ( env -> Type -> m Type , env -> [Type] -> m [Type] , env -> Coercion -> m Coercion @@ -926,6 +898,7 @@ , tcm_hole = cohole }) = (go_ty, go_tys, go_co, go_cos) where + -- See Note [Use explicit recursion in mapTyCo] go_tys !_ [] = return [] go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys @@ -956,12 +929,14 @@ ; inner' <- go_ty env' inner ; return $ ForAllTy (Bndr tv' vis) inner' } + -- See Note [Use explicit recursion in mapTyCo] go_cos !_ [] = return [] go_cos !env (co:cos) = (:) <$> go_co env co <*> go_cos env cos go_mco !_ MRefl = return MRefl go_mco !env (MCo co) = MCo <$> (go_co env co) + go_co :: env -> Coercion -> m Coercion go_co !env (Refl ty) = Refl <$> go_ty env ty go_co !env (GRefl r ty mco) = mkGReflCo r <$> go_ty env ty <*> go_mco env mco go_co !env (AppCo c1 c2) = mkAppCo <$> go_co env c1 <*> go_co env c2 @@ -969,17 +944,20 @@ <*> go_co env c1 <*> go_co env c2 go_co !env (CoVarCo cv) = covar env cv go_co !env (HoleCo hole) = cohole env hole - go_co !env (UnivCo p r t1 t2) = mkUnivCo <$> go_prov env p <*> pure r - <*> go_ty env t1 <*> go_ty env t2 + go_co !env (UnivCo { uco_prov = p, uco_role = r + , uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = mkUnivCo <$> pure p + <*> go_cos env deps + <*> pure r + <*> go_ty env t1 <*> go_ty env t2 go_co !env (SymCo co) = mkSymCo <$> go_co env co go_co !env (TransCo c1 c2) = mkTransCo <$> go_co env c1 <*> go_co env c2 - go_co !env (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos + go_co !env (AxiomCo r cos) = mkAxiomCo r <$> go_cos env cos go_co !env (SelCo i co) = mkSelCo i <$> go_co env co go_co !env (LRCo lr co) = mkLRCo lr <$> go_co env co go_co !env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg go_co !env (KindCo co) = mkKindCo <$> go_co env co go_co !env (SubCo co) = mkSubCo <$> go_co env co - go_co !env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos go_co !env co@(TyConAppCo r tc cos) | isTcTyCon tc = do { tc' <- tycon tc @@ -991,19 +969,29 @@ | otherwise = mkTyConAppCo r tc <$> go_cos env cos - go_co !env (ForAllCo tv kind_co co) + go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co }) = do { kind_co' <- go_co env kind_co - ; tycobinder env tv Inferred $ \env' tv' -> do + ; tycobinder env tv visL $ \env' tv' -> do ; co' <- go_co env' co - ; return $ mkForAllCo tv' kind_co' co' } + ; return $ mkForAllCo tv' visL visR kind_co' co' } -- See Note [Efficiency for ForAllCo case of mapTyCoX] - go_prov !env (PhantomProv co) = PhantomProv <$> go_co env co - go_prov !env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co - go_prov !_ p@(PluginProv _) = return p - go_prov !_ p@(CorePrepProv _) = return p +{- Note [Use explicit recursion in mapTyCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use explicit recursion in `mapTyCo`, rather than calling, say, `strictFoldDVarSet`, +for exactly the same reason as in Note [Use explicit recursion in foldTyCo] in +GHC.Core.TyCo.Rep. We are in a monadic context, and using too-clever higher order +functions makes the strictness analyser produce worse results. +We could probably use `foldr`, since it is inlined bodily, fairly early; but +I'm doing the simple thing and inlining it by hand. + +See !12037 for performance glitches caused by using `strictFoldDVarSet` (which is +definitely not inlined bodily). +-} + {- ********************************************************************* * * TyVarTy @@ -1063,14 +1051,13 @@ but suppose we want that. But then in the call to 'i', we end up decomposing (Eq Int => Int), and we definitely don't want that. -This really only applies to the type checker; in Core, '=>' and '->' -are the same, as are 'Constraint' and '*'. But for now I've put -the test in splitAppTyNoView_maybe, which applies throughout, because -the other calls to splitAppTy are in GHC.Core.Unify, which is also used by -the type checker (e.g. when matching type-function equations). - We are willing to split (t1 -=> t2) because the argument is still of kind Type, not Constraint. So the criterion is isVisibleFunArg. + +In Core there is no real reason to avoid such decomposition. But for now I've +put the test in splitAppTyNoView_maybe, which applies throughout, because the +other calls to splitAppTy are in GHC.Core.Unify, which is also used by the +type checker (e.g. when matching type-function equations). -} -- | Applies a type to another, as in e.g. @k a@ @@ -1151,7 +1138,7 @@ = splitAppTyNoView_maybe ty ------------- -splitAppTys :: Type -> (Type, [Type]) +splitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -- ^ Recursively splits a type as far as is possible, leaving a residual -- type being applied to and the type arguments applied to it. Never fails, -- even if that means returning an empty list of type applications. @@ -1238,14 +1225,42 @@ -- | Is this type a custom user error? -- If so, give us the error message. userTypeError_maybe :: Type -> Maybe ErrorMsgType -userTypeError_maybe t - = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t +userTypeError_maybe ty + | Just ty' <- coreView ty = userTypeError_maybe ty' +userTypeError_maybe (TyConApp tc (_kind : msg : _)) + | tyConName tc == errorMessageTypeErrorFamName -- There may be more than 2 arguments, if the type error is -- used as a type constructor (e.g. at kind `Type -> Type`). + = Just msg +userTypeError_maybe _ + = Nothing - ; guard (tyConName tc == errorMessageTypeErrorFamName) - ; return msg } +deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType +-- Look for custom user error, deeply inside the type +deepUserTypeError_maybe ty + | Just ty' <- coreView ty = userTypeError_maybe ty' +deepUserTypeError_maybe (TyConApp tc tys) + | tyConName tc == errorMessageTypeErrorFamName + , _kind : msg : _ <- tys + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + = Just msg + | tyConMustBeSaturated tc -- Don't go looking for user type errors + -- inside type family arguments (see #20241). + = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys) + | otherwise + = foldr (firstJust . deepUserTypeError_maybe) Nothing tys +deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty +deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res }) + = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res +deepUserTypeError_maybe (AppTy t1 t2) + = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2 +deepUserTypeError_maybe (CastTy ty _) + = deepUserTypeError_maybe ty +deepUserTypeError_maybe _ -- TyVarTy, CoercionTy, LitTy + = Nothing + -- | Render a type corresponding to a user type error into a SDoc. pprUserTypeErrorTy :: ErrorMsgType -> SDoc pprUserTypeErrorTy ty = @@ -1316,6 +1331,8 @@ funTyConAppTy_maybe af mult arg res | Just arg_rep <- getRuntimeRep_maybe arg , Just res_rep <- getRuntimeRep_maybe res + -- If you're changing the lines below, you'll probably want to adapt the + -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly. , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res] | otherwise = [ arg_rep, res_rep, arg, res] = Just $ (funTyFlagTyCon af, args) @@ -1405,6 +1422,15 @@ | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res) | otherwise = Nothing +{-# INLINE splitVisibleFunTy_maybe #-} +splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Works on visible function types only (t1 -> t2), and +-- returns t1 and t2, but not the multiplicity +splitVisibleFunTy_maybe ty + | FunTy af _ arg res <- coreFullView ty + , isVisibleFunArg af = Just (arg, res) + | otherwise = Nothing + splitFunTys :: Type -> ([Scaled Type], Type) splitFunTys ty = split [] ty ty where @@ -1419,7 +1445,7 @@ | FunTy { ft_res = res } <- coreFullView ty = res | otherwise = pprPanic "funResultTy" (ppr ty) -funArgTy :: Type -> Type +funArgTy :: HasDebugCallStack => Type -> Type -- ^ Extract the function argument type and panic if that is not possible funArgTy ty | FunTy { ft_arg = arg } <- coreFullView ty = arg @@ -1473,8 +1499,9 @@ | FunTy { ft_res = res } <- ty = piResultTys res args - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst init_subst tv arg) res args + | ForAllTy (Bndr tcv _) res <- ty + = -- Both type and coercion variables + go (extendTCvSubst init_subst tcv arg) res args | Just ty' <- coreView ty = piResultTys ty' orig_args @@ -1601,7 +1628,7 @@ splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty) -splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type]) +splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Same as splitTyConApp_maybe but without looking through synonyms splitTyConAppNoView_maybe ty = case ty of @@ -1620,7 +1647,7 @@ -- of a 'FunTy' with an argument of unknown kind 'FunTy' -- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of -- the form `TYPE rep`. This isn't usually a problem but may --- be temporarily the cas during canonicalization: +-- be temporarily the case during canonicalization: -- see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality -- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, -- Wrinkle around FunTy @@ -1763,15 +1790,26 @@ to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) to_tyb (Bndr tv AnonTCB) = Anon (tymult (varType tv)) FTF_T_T --- | Make a dependent forall over an 'Inferred' variable -mkTyCoInvForAllTy :: TyCoVar -> Type -> Type -mkTyCoInvForAllTy tv ty +-- | Make a dependent forall over a TyCoVar +mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type +mkTyCoForAllTy tv vis ty | isCoVar tv , not (tv `elemVarSet` tyCoVarsOfType ty) + -- Maintain ForAllTy's invariants + -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep = mkVisFunTyMany (varType tv) ty | otherwise - = ForAllTy (Bndr tv Inferred) ty + = ForAllTy (mkForAllTyBinder vis tv) ty +-- | Make a dependent forall over a TyCoVar +mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type +mkTyCoForAllTys bndrs ty + = foldr (\(Bndr var vis) -> mkTyCoForAllTy var vis) ty bndrs + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty = mkTyCoForAllTy tv Inferred ty + -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar mkInfForAllTy :: TyVar -> Type -> Type mkInfForAllTy tv ty = assert (isTyVar tv ) @@ -1918,6 +1956,8 @@ _ -> False -- | Is this a function? +-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function. +-- It would merely be a forall wrapping a function type. isFunTy :: Type -> Bool isFunTy ty | FunTy {} <- coreFullView ty = True @@ -1937,14 +1977,20 @@ go ty | Just ty' <- coreView ty = go ty' go res = res --- | Attempts to take a forall type apart, but only if it's a proper forall, --- with a named binder +-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder +splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type) +splitForAllForAllTyBinder_maybe ty + | ForAllTy bndr inner_ty <- coreFullView ty = Just (bndr, inner_ty) + | otherwise = Nothing + + +-- | Attempts to take a ForAllTy apart, returning the Var splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTyCoVar_maybe ty | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty) | otherwise = Nothing --- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder. +-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) splitForAllTyVar_maybe ty | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty @@ -1989,6 +2035,18 @@ split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split orig_ty _ bs = (reverse bs, orig_ty) +collectPiTyBinders :: Type -> [PiTyBinder] +collectPiTyBinders ty = build $ \c n -> + let + split (ForAllTy b res) = Named b `c` split res + split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + = Anon (Scaled w arg) af `c` split res + split ty | Just ty' <- coreView ty = split ty' + split _ = n + in + split ty +{-# INLINE collectPiTyBinders #-} + -- | Extracts a list of run-time arguments from a function type, -- looking through newtypes to the right of arrows. -- @@ -2030,12 +2088,12 @@ | otherwise = [] -invisibleTyBndrCount :: Type -> Int +invisibleBndrCount :: Type -> Int -- Returns the number of leading invisible forall'd binders in the type -- Includes invisible predicate arguments; e.g. for -- e.g. forall {k}. (k ~ *) => k -> k -- returns 2 not 1 -invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty)) +invisibleBndrCount ty = length (fst (splitInvisPiTys ty)) -- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. -- Stops at the first visible binder. @@ -2233,6 +2291,21 @@ isFamFreeTy (CastTy ty _) = isFamFreeTy ty isFamFreeTy (CoercionTy _) = False -- Not sure about this +-- | Check whether a type is a data family type +isDataFamilyApp :: Type -> Bool +isDataFamilyApp ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +isSatTyFamApp :: Type -> Maybe (TyCon, [Type]) +-- Return the argument if we have a saturated type family application +-- Why saturated? See (ATF4) in Note [Apartness and type families] +isSatTyFamApp (TyConApp tc tys) + | isTypeFamilyTyCon tc + && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated + = Just (tc, tys) +isSatTyFamApp _ = Nothing + buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> KnotTied Type -> TyCon -- This function is here because here is where we have @@ -2241,24 +2314,22 @@ = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful is_concrete where + qtvs = mkVarSet (map binderVar binders) is_tau = isTauTy rhs is_fam_free = isFamFreeTy rhs - is_concrete = uniqSetAll isConcreteTyCon rhs_tycons - -- NB: is_concrete is allowed to be conservative, returning False - -- more often than it could. e.g. - -- type S a b = b - -- type family F a - -- type T a = S (F a) a - -- We will mark T as not-concrete, even though (since S ignore its first - -- argument, it could be marked concrete. - - is_forgetful = not (all ((`elemVarSet` rhs_tyvars) . binderVar) binders) || - uniqSetAny isForgetfulSynTyCon rhs_tycons - -- NB: is_forgetful is allowed to be conservative, returning True more often - -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon + is_concrete = isConcreteTypeWith qtvs rhs + is_forgetful = not (qtvs `subVarSet` expanded_rhs_tyvars) - rhs_tycons = tyConsOfType rhs - rhs_tyvars = tyCoVarsOfType rhs + expanded_rhs_tyvars = tyCoVarsOfType (expandTypeSynonyms rhs) + -- See Note [Forgetful type synonyms] in GHC.Core.TyCon + -- To find out if this TyCon is forgetful, expand the synonyms in its RHS + -- and check that all of the binders are free in the expanded type. + -- We really only need to expand the /forgetful/ synonyms on the RHS, + -- but we don't currently have a function to do that. + -- Failing to expand the RHS led to #25094, e.g. + -- type Bucket a b c = Key (a,b,c) + -- type Key x = Any + -- Here Bucket is definitely forgetful! {- ************************************************************************ @@ -2276,6 +2347,11 @@ typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) +typeLevity :: HasDebugCallStack => Type -> Levity +typeLevity ty = case typeLevity_maybe ty of + Just lev -> lev + Nothing -> pprPanic "typeLevity" (ppr ty) + -- | Is the given type definitely unlifted? -- See "Type#type_classification" for what an unlifted type is. -- @@ -2286,8 +2362,6 @@ -- isUnliftedType returns True for forall'd unlifted types: -- x :: forall a. Int# -- I found bindings like these were getting floated to the top level. - -- They are pretty bogus types, mind you. It would be better never to - -- construct them isUnliftedType ty = case typeLevity_maybe ty of Just Lifted -> False @@ -2399,12 +2473,6 @@ isAlgTyCon tc _other -> False --- | Check whether a type is a data family type -isDataFamilyAppType :: Type -> Bool -isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of - Just tc -> isDataFamilyTyCon tc - _ -> False - -- | Computes whether an argument (or let right hand side) should -- be computed strictly or lazily, based only on its type. -- Currently, it's just 'isUnliftedType'. @@ -2419,21 +2487,11 @@ -- NB: unlifted types are not terminating types! -- e.g. you can write a term (loop 1)::Int# that diverges. isTerminatingType ty = case tyConAppTyCon_maybe ty of - Just tc -> isClassTyCon tc && not (isNewTyCon tc) + Just tc -> isClassTyCon tc && not (isUnaryClassTyCon tc) + -- A non-unary class TyCon is terminating + -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon _ -> False --- | Does this type classify a core (unlifted) Coercion? --- At either role nominal or representational --- (t1 ~# t2) or (t1 ~R# t2) --- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep" -isCoVarType :: Type -> Bool - -- ToDo: should we check saturation? -isCoVarType ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey - | otherwise - = False - isPrimitiveType :: Type -> Bool -- ^ Returns true of types that are opaque to Haskell. isPrimitiveType ty = case splitTyConApp_maybe ty of @@ -2617,9 +2675,7 @@ -- No need to expand synonyms typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys typeKind (LitTy l) = typeLiteralKind l -typeKind (FunTy { ft_af = af }) = case funTyFlagResultTypeOrConstraint af of - TypeLike -> liftedTypeKind - ConstraintLike -> constraintKind +typeKind (FunTy { ft_af = af }) = liftedTypeOrConstraintKind (funTyFlagResultTypeOrConstraint af) typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (CastTy _ty co) = coercionRKind co typeKind (CoercionTy co) = coercionType co @@ -2634,25 +2690,27 @@ go fun args = piResultTys (typeKind fun) args typeKind ty@(ForAllTy {}) - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! + = assertPpr (not (null tcvs)) (ppr ty) $ + -- If tcvs is empty somehow we'll get an infinite loop! + case occCheckExpand tcvs body_kind of + -- We must make sure tvs do not occur in kind, + -- as they would be out of scope! -- See Note [Phantom type variables in kinds] Nothing -> pprPanic "typeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + (ppr ty $$ ppr tcvs $$ ppr body <+> dcolon <+> ppr body_kind) - Just k' | all isTyVar tvs -> k' -- Rule (FORALL1) - | otherwise -> lifted_kind_from_body -- Rule (FORALL2) + Just k' | all isTyVar tcvs -> k' -- Rule (FORALL1) + | otherwise -> lifted_kind_from_body -- Rule (FORALL2) where - (tvs, body) = splitForAllTyVars ty - body_kind = typeKind body + (tcvs, body) = splitForAllTyCoVars ty -- Important: splits both TyVar and CoVar binders + body_kind = typeKind body lifted_kind_from_body -- Implements (FORALL2) = case sORTKind_maybe body_kind of - Just (ConstraintLike, _) -> constraintKind - Just (TypeLike, _) -> liftedTypeKind - Nothing -> pprPanic "typeKind" (ppr body_kind) + Just (torc, _) -> liftedTypeOrConstraintKind torc + Nothing -> pprPanic "typeKind" (ppr body_kind) + --------------------------------------------- sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type) @@ -2691,14 +2749,6 @@ | otherwise -> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty)) -isPredTy :: HasDebugCallStack => Type -> Bool --- Precondition: expects a type that classifies values --- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep --- Returns True for types of kind (CONSTRAINT _), False for ones of kind (TYPE _) -isPredTy ty = case typeTypeOrConstraint ty of - TypeLike -> False - ConstraintLike -> True - -- | Does this classify a type allowed to have values? Responds True to things -- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. isTYPEorCONSTRAINT :: Kind -> Bool @@ -2783,19 +2833,6 @@ go (ForAllTy _ ty) = go ty go ty = isFixedRuntimeRepKind (typeKind ty) -argsHaveFixedRuntimeRep :: Type -> Bool --- ^ True if the argument types of this function type --- all have a fixed-runtime-rep -argsHaveFixedRuntimeRep ty - = all ok bndrs - where - ok :: PiTyBinder -> Bool - ok (Anon ty _) = typeHasFixedRuntimeRep (scaledThing ty) - ok _ = True - - bndrs :: [PiTyBinder] - (bndrs, _) = splitPiTys ty - -- | Checks that a kind of the form 'Type', 'Constraint' -- or @'TYPE r@ is concrete. See 'isConcreteType'. -- @@ -2812,9 +2849,19 @@ -- -- See Note [Concrete types] in GHC.Tc.Utils.Concrete. isConcreteType :: Type -> Bool -isConcreteType = go +isConcreteType = isConcreteTypeWith emptyVarSet + +-- | Like 'isConcreteType', but allows passing in a set of 'TyVar's that +-- should be considered concrete. +-- +-- See Note [Concrete types] in GHC.Tc.Utils.Concrete. +isConcreteTypeWith :: TyVarSet -> Type -> Bool +-- This version, with a 'TyVarSet' argument, supports 'mkSynonymTyCon', +-- which needs to test the RHS for concreteness, under the assumption that +-- the binders are instantiated to concrete types +isConcreteTypeWith conc_tvs = go where - go (TyVarTy tv) = isConcreteTyVar tv + go (TyVarTy tv) = isConcreteTyVar tv || tv `elemVarSet` conc_tvs go (AppTy ty1 ty2) = go ty1 && go ty2 go (TyConApp tc tys) = go_tc tc tys go ForAllTy{} = False @@ -2825,6 +2872,7 @@ go CastTy{} = False go CoercionTy{} = False + go_tc :: TyCon -> [Type] -> Bool go_tc tc tys | isForgetfulSynTyCon tc -- E.g. type S a = Int -- Then (S x) is concrete even if x isn't @@ -2840,7 +2888,6 @@ | otherwise -- E.g. type families = False - {- %************************************************************************ %* * @@ -3223,8 +3270,9 @@ Goal (b) is particularly useful as it makes traversals (e.g. free variable traversal, substitution, and comparison) more efficient. Comparison in particular takes special advantage of nullary type synonym -applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing -nullary type synonyms] in "GHC.Core.Type". +applications (e.g. things like @TyConApp typeTyCon []@). See +* Note [Comparing type synonyms] in "GHC.Core.TyCo.Compare" +* Note [Unifying type synonyms] in "GHC.Core.Unify" To accomplish these we use a number of tricks, implemented by mkTyConApp. @@ -3384,3 +3432,7 @@ typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind typeOrConstraintKind TypeLike rep = mkTYPEapp rep typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep + +liftedTypeOrConstraintKind :: TypeOrConstraint -> Kind +liftedTypeOrConstraintKind TypeLike = liftedTypeKind +liftedTypeOrConstraintKind ConstraintLike = constraintKind diff --git a/GHC/Core/Type.hs-boot b/GHC/Core/Type.hs-boot --- a/GHC/Core/Type.hs-boot +++ b/GHC/Core/Type.hs-boot @@ -9,31 +9,18 @@ import GHC.Types.Var( FunTyFlag, TyVar ) import GHC.Types.Basic( TypeOrConstraint ) -isPredTy :: HasDebugCallStack => Type -> Bool -isCoercionTy :: Type -> Bool -mkAppTy :: Type -> Type -> Type -mkCastTy :: Type -> Coercion -> Type -mkTyConApp :: TyCon -> [Type] -> Type -mkCoercionTy :: Coercion -> Type -piResultTy :: HasDebugCallStack => Type -> Type -> Type - -typeKind :: HasDebugCallStack => Type -> Type -typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint - -coreView :: Type -> Maybe Type -rewriterView :: Type -> Maybe Type -isRuntimeRepTy :: Type -> Bool -isLevityTy :: Type -> Bool -isMultiplicityTy :: Type -> Bool +coreView :: Type -> Maybe Type +rewriterView :: Type -> Maybe Type +chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag +typeKind :: HasDebugCallStack => Type -> Type +isCoercionTy :: Type -> Bool +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type +mkTyConApp :: TyCon -> [Type] -> Type +getLevity :: HasDebugCallStack => Type -> Type +getTyVar_maybe :: Type -> Maybe TyVar isLiftedTypeKind :: Type -> Bool -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -tyConAppTyCon_maybe :: Type -> Maybe TyCon -getTyVar_maybe :: Type -> Maybe TyVar - -getLevity :: HasDebugCallStack => Type -> Type - partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) - -chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag +typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint diff --git a/GHC/Core/Unfold.hs b/GHC/Core/Unfold.hs --- a/GHC/Core/Unfold.hs +++ b/GHC/Core/Unfold.hs @@ -16,7 +16,6 @@ -} -{-# LANGUAGE BangPatterns #-} module GHC.Core.Unfold ( Unfolding, UnfoldingGuidance, -- Abstract types @@ -32,29 +31,38 @@ updateVeryAggressive, updateCaseScaling, updateCaseThreshold, updateReportPrefix, - inlineBoringOk, calcUnfoldingGuidance + inlineBoringOk, calcUnfoldingGuidance, + uncondInlineJoin ) where import GHC.Prelude import GHC.Core import GHC.Core.Utils -import GHC.Types.Id import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Class( Class ) +import GHC.Core.Predicate( isUnaryClass ) + +import GHC.Types.Id import GHC.Types.Literal -import GHC.Builtin.PrimOps import GHC.Types.Id.Info import GHC.Types.RepType ( isZeroBitTy ) import GHC.Types.Basic ( Arity, RecFlag ) -import GHC.Core.Type +import GHC.Types.ForeignCall +import GHC.Types.Tickish + +import GHC.Builtin.PrimOps import GHC.Builtin.Names + import GHC.Data.Bag + import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.ForeignCall -import GHC.Types.Tickish import qualified Data.ByteString as BS +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE -- | Unfolding options data UnfoldingOpts = UnfoldingOpts @@ -180,24 +188,6 @@ ppr RuleArgCtxt = text "RuleArgCtxt" {- -Note [Occurrence analysis of unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do occurrence-analysis of unfoldings once and for all, when the -unfolding is built, rather than each time we inline them. - -But given this decision it's vital that we do -*always* do it. Consider this unfolding - \x -> letrec { f = ...g...; g* = f } in body -where g* is (for some strange reason) the loop breaker. If we don't -occ-anal it when reading it in, we won't mark g as a loop breaker, and -we may inline g entirely in body, dropping its binding, and leaving -the occurrence in f out of scope. This happened in #8892, where -the unfolding in question was a DFun unfolding. - -But more generally, the simplifier is designed on the -basis that it is looking at occurrence-analysed expressions, so better -ensure that they actually are. - Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to @@ -229,44 +219,136 @@ ************************************************************************ -} +{- Note [inlineBoringOk] +~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [INLINE for small functions] + +The function `inlineBoringOk` returns True (boringCxtOk) if the supplied +unfolding, which looks like (\x y z. body), is such that the result of +inlining a saturated call is no bigger than `body`. Some wrinkles: + +(IB1) An important case is + - \x. (x `cast` co) + +(IB2) If `body` looks like a data constructor worker, we become keener + to inline, by ignoring the number of arguments; we just insist they + are all trivial. Reason: in a call like `f (g x y)`, if `g` unfolds + to a data construtor, we can allocate a data constructor instead of + a thunk (g x y). + + A case in point where a GADT data constructor failed to inline (#25713) + $WK = /\a \x. K @a x + We really want to inline a boring call to $WK so that we allocate + a data constructor not a thunk ($WK @ty x). + + But not for nullary constructors! We don't want to turn + f ($WRefl @ty) + into + f (Refl @ty ) + because the latter might allocate, whereas the former shares. + (You might wonder if (Refl @ty ) should allocate, but I think + that currently it does.) So for nullary constructors, `inlineBoringOk` + returns False. + +(IB3) Types and coercions do not count towards the expression size. + They are ultimately erased. + +(IB4) If there are no value arguments, `inlineBoringOk` we have to be + careful (#17182). If we have + let y = x @Int in f y y + there’s no reason not to inline y at both use sites — no work is + actually duplicated. + + But not so for coercion arguments! Unlike type arguments, which have + no runtime representation, coercion arguments *do* have a runtime + representation (albeit the zero-width VoidRep, see Note [Coercion + tokens] in "GHC.CoreToStg"). For example: + let y = g @Int in g y y + Here `co` is a value argument, and calling it twice might duplicate + work. + + Even if `g` is a data constructor, so no work is duplicated, + inlining `y` might duplicate allocation of a data constructor object + (#17787). See also (IB2). + + TL;DR: if `is_fun` is False, so we have no value arguments, we /do/ + count coercion arguments, despite (IB3). + +(IB5) You might wonder about an unfolding like (\x y z -> x (y z)), + whose body is, in some sense, just as small as (g x y z). + But `inlineBoringOk` doesn't attempt anything fancy; it just looks + for a function call with trivial arguments, Keep it simple. + +(IB6) If we have an unfolding (K op) where K is a unary-class data constructor, + we want to inline it! So that we get calls (f op), which in turn can see (in + STG land) that `op` is already evaluated and properly tagged. (If `op` isn't + trivial we will have baled out before we get to the Var case.) This made + a big difference in benchmarks for the `effectful` library; details in !10479. + + See Note [Unary class magic] in GHC/Core/TyCon. +-} + inlineBoringOk :: CoreExpr -> Bool --- See Note [INLINE for small functions] -- True => the result of inlining the expression is -- no bigger than the expression itself -- eg (\x y -> f y x) --- This is a quick and dirty version. It doesn't attempt --- to deal with (\x y z -> x (y z)) --- The really important one is (x `cast` c) +-- See Note [inlineBoringOk] inlineBoringOk e = go 0 e where + is_fun = isValFun e + go :: Int -> CoreExpr -> Bool - go credit (Lam x e) | isId x = go (credit+1) e - | otherwise = go credit e - -- See Note [Count coercion arguments in boring contexts] - go credit (App f (Type {})) = go credit f - go credit (App f a) | credit > 0 - , exprIsTrivial a = go (credit-1) f - go credit (Tick _ e) = go credit e -- dubious - go credit (Cast e _) = go credit e - go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce] - | isUnsafeEqualityProof scrut = go credit rhs - go _ (Var {}) = boringCxtOk - go _ _ = boringCxtNotOk + -- credit = #(value lambdas) = #(value args) + go credit (Lam x e) | isRuntimeVar x = go (credit+1) e + | otherwise = go credit e -- See (IB3) + go credit (App f (Type {})) = go credit f -- See (IB3) + go credit (App f (Coercion {})) + | is_fun = go credit f -- See (IB3) + | otherwise = go (credit-1) f -- See (IB4) + go credit (App f a) | exprIsTrivial a = go (credit-1) f + + go credit (Case e b _ alts) + | null alts + = go credit e -- EmptyCase is like e + | Just rhs <- isUnsafeEqualityCase e b alts + = go credit rhs -- See Note [Inline unsafeCoerce] + + go credit (Tick _ e) = go credit e -- dubious + go credit (Cast e _) = go credit e -- See (IB3) + + -- Lit: we assume credit >= 0; literals aren't functions + go _ (Lit l) = litIsTrivial l && boringCxtOk + + go credit (Var v) | isDataConWorkId v, is_fun = boringCxtOk -- See (IB2) + | isUnaryClassId v = boringCxtOk -- See (IB6) + | credit >= 0 = boringCxtOk + | otherwise = boringCxtNotOk + + go _ _ = boringCxtNotOk + +isValFun :: CoreExpr -> Bool +-- True of functions with at least +-- one top-level value lambda +isValFun (Lam b e) | isRuntimeVar b = True + | otherwise = isValFun e +isValFun _ = False + calcUnfoldingGuidance :: UnfoldingOpts -> Bool -- Definitely a top-level, bottoming binding + -> Bool -- True <=> join point -> CoreExpr -- Expression to look at -> UnfoldingGuidance -calcUnfoldingGuidance opts is_top_bottoming (Tick t expr) +calcUnfoldingGuidance opts is_top_bottoming is_join (Tick t expr) | not (tickishIsCode t) -- non-code ticks don't matter for unfolding - = calcUnfoldingGuidance opts is_top_bottoming expr -calcUnfoldingGuidance opts is_top_bottoming expr + = calcUnfoldingGuidance opts is_top_bottoming is_join expr +calcUnfoldingGuidance opts is_top_bottoming is_join expr = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of TooBig -> UnfNever SizeIs size cased_bndrs scrut_discount - | uncondInline expr n_val_bndrs size + | uncondInline is_join expr bndrs n_val_bndrs body size -> UnfWhen { ug_unsat_ok = unSaturatedOk , ug_boring_ok = boringCxtOk , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] @@ -303,7 +385,7 @@ We really want to inline unsafeCoerce, even when applied to boring arguments. It doesn't look as if its RHS is smaller than the call unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x -but that case is discarded -- see Note [Implementing unsafeCoerce] +but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce] in base:Unsafe.Coerce. Moreover, if we /don't/ inline it, we may be left with @@ -311,7 +393,9 @@ which will build a thunk -- bad, bad, bad. Conclusion: we really want inlineBoringOk to be True of the RHS of -unsafeCoerce. This is (U4) in Note [Implementing unsafeCoerce]. +unsafeCoerce. And it really is, because we regard + case unsafeEqualityProof @a @b of UnsafeRefl -> rhs +as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce]. Note [Computing the size of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -407,39 +491,70 @@ NB: you might think that PostInlineUnconditionally would do this but it doesn't fire for top-level things; see GHC.Core.Opt.Simplify.Utils Note [Top level and postInlineUnconditionally] - -Note [Count coercion arguments in boring contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In inlineBoringOK, we ignore type arguments when deciding whether an -expression is okay to inline into boring contexts. This is good, since -if we have a definition like - - let y = x @Int in f y y - -there’s no reason not to inline y at both use sites — no work is -actually duplicated. It may seem like the same reasoning applies to -coercion arguments, and indeed, in #17182 we changed inlineBoringOK to -treat coercions the same way. - -However, this isn’t a good idea: unlike type arguments, which have -no runtime representation, coercion arguments *do* have a runtime -representation (albeit the zero-width VoidRep, see Note [Coercion tokens] -in "GHC.CoreToStg"). This caused trouble in #17787 for DataCon wrappers for -nullary GADT constructors: the wrappers would be inlined and each use of -the constructor would lead to a separate allocation instead of just -sharing the wrapper closure. - -The solution: don’t ignore coercion arguments after all. -} -uncondInline :: CoreExpr -> Arity -> Int -> Bool +uncondInline :: Bool -> CoreExpr -> [Var] -> Arity -> CoreExpr -> Int -> Bool -- Inline unconditionally if there no size increase -- Size of call is arity (+1 for the function) -- See Note [INLINE for small functions] -uncondInline rhs arity size +uncondInline is_join rhs bndrs arity body size + | is_join = uncondInlineJoin bndrs body | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) +uncondInlineJoin :: [Var] -> CoreExpr -> Bool +-- See Note [Duplicating join points] point (DJ3) in GHC.Core.Opt.Simplify.Iteration +uncondInlineJoin bndrs body + + -- (DJ3)(a) + | exprIsTrivial body + = True -- Nullary constructors, literals + + -- (DJ3)(b) and (DJ3)(c) combined + | indirectionOrAppWithoutFVs + = True + + | otherwise + = False + + where + -- (DJ3)(b): + -- - $j1 x = $j2 y x |> co -- YES, inline indirection regardless of free vars + -- (DJ3)(c): + -- - $j1 x y = K y x |> co -- YES, inline! + -- - $j2 x = K f x -- No, don't! (because f is free) + indirectionOrAppWithoutFVs = go False body + + go !seen_fv (App f a) + | Just has_fv <- go_arg a + = go (seen_fv || has_fv) f + | otherwise = False -- Not trivial + go seen_fv (Var v) + | isJoinId v = True -- Indirection to another join point; always inline + | isDataConId v = not seen_fv -- e.g. $j a b = K a b + | v `elem` bndrs = not seen_fv -- e.g. $j a b = b a + go seen_fv (Cast e _) = go seen_fv e + go seen_fv (Tick _ e) = go seen_fv e + go _ _ = False + + -- go_arg returns: + -- - `Nothing` if arg is not trivial + -- - `Just True` if arg is trivial but contains free var, literal, or constructor + -- - `Just False` if arg is trivial without free vars + go_arg (Type {}) = Just False + go_arg (Coercion {}) = Just False + go_arg (Lit l) + | litIsTrivial l = Just True -- e.g. $j x = $j2 x 7 YES, but $j x = K x 7 NO + | otherwise = Nothing + go_arg (App f a) + | isTyCoArg a = go_arg f -- e.g. $j f = K (f @a) + | otherwise = Nothing + go_arg (Cast e _) = go_arg e + go_arg (Tick _ e) = go_arg e + go_arg (Var f) = Just $! f `notElem` bndrs + go_arg _ = Nothing + + sizeExpr :: UnfoldingOpts -> Int -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these @@ -483,15 +598,12 @@ (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) pairs - size_up (Case e _ _ alts) - | null alts - = size_up e -- case e of {} never returns, so take size of scrutinee - - size_up (Case e _ _ alts) - -- Now alts is non-empty - | Just v <- is_top_arg e -- We are scrutinising an argument variable - = let - alt_sizes = map size_up_alt alts + size_up (Case e _ _ alts) = case nonEmpty alts of + Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee + Just alts + | Just v <- is_top_arg e -> -- We are scrutinising an argument variable + let + alt_sizes = NE.map size_up_alt alts -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable @@ -518,14 +630,15 @@ -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself + + | otherwise -> size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e is_top_arg _ = Nothing - - size_up (Case e _ _ alts) = size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts where case_size | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) @@ -563,7 +676,7 @@ = False size_up_rhs (bndr, rhs) - | Just join_arity <- isJoinId_maybe bndr + | JoinPoint join_arity <- idJoinPointHood bndr -- Skip arguments to join point , (_bndrs, body) <- collectNBinders join_arity rhs = size_up body @@ -590,11 +703,13 @@ size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize size_up_call fun val_args voids = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId {} -> classOpSize opts top_args val_args - _ -> funSize opts top_args fun (length val_args) voids + FCallId _ -> sizeN (callSize (length val_args) voids) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op _ -> primOpSize op (length val_args) + ClassOpId cls _ -> classOpSize opts cls top_args val_args + _ | fun `hasKey` buildIdKey -> buildSize + | fun `hasKey` augmentIdKey -> augmentSize + | otherwise -> funSize opts top_args fun (length val_args) voids ------------ size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 @@ -659,21 +774,24 @@ -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) -classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize +classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize -- See Note [Conlike is interesting] -classOpSize _ _ [] - = sizeZero -classOpSize opts top_args (arg1 : other_args) - = SizeIs size arg_discount 0 +classOpSize opts cls top_args args + | isUnaryClass cls + = sizeZero -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon + | otherwise + = case args of + [] -> sizeZero + (arg1:other_args) -> SizeIs (size other_args) (arg_discount arg1) 0 where - size = 20 + (10 * length other_args) + size other_args = 20 + (10 * length other_args) + -- If the class op is scrutinising a lambda bound dictionary then -- give it a discount, to encourage the inlining of this function -- The actual discount is rather arbitrarily chosen - arg_discount = case arg1 of - Var dict | dict `elem` top_args - -> unitBag (dict, unfoldingDictDiscount opts) - _other -> emptyBag + arg_discount (Var dict) | dict `elem` top_args + = unitBag (dict, unfoldingDictDiscount opts) + arg_discount _ = emptyBag -- | The size of a function call callSize @@ -690,18 +808,19 @@ :: Int -- ^ number of value args -> Int -- ^ number of value args that are void -> Int -jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) +jumpSize _n_val_args _voids = 0 -- Jumps are small, and we don't want penalise them + + -- Old version: + -- 2 * (1 + n_val_args - voids) -- A jump is 20% the size of a function call. Making jumps free reopens -- bug #6048, but making them any more expensive loses a 21% improvement in -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a -- better solution? funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize --- Size for functions that are not constructors or primops +-- Size for function calls where the function is not a constructor or primops -- Note [Function applications] funSize opts top_args fun n_val_args voids - | fun `hasKey` buildIdKey = buildSize - | fun `hasKey` augmentIdKey = augmentSize | otherwise = SizeIs size arg_discount res_discount where some_val_args = n_val_args > 0 @@ -730,6 +849,8 @@ -- See Note [Unboxed tuple size and result discount] | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10 + + | isUnaryClassDataCon dc = sizeZero -- See Note [Constructor size and result discount] | otherwise = SizeIs 10 emptyBag 10 diff --git a/GHC/Core/Unfold/Make.hs b/GHC/Core/Unfold/Make.hs --- a/GHC/Core/Unfold/Make.hs +++ b/GHC/Core/Unfold/Make.hs @@ -57,6 +57,7 @@ = mkUnfolding opts src True {- Top level -} (isDeadEndSig strict_sig) + False {- Not a join point -} expr -- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first @@ -79,14 +80,24 @@ mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs - = mkUnfolding opts VanillaSrc False False rhs Nothing + = mkUnfolding opts VanillaSrc False False False rhs Nothing mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops + | isUnaryClassDataCon con + = -- See (UCM5) in Note [Unary class magic] in GHC.Core.TyCon + mkDataConUnfolding $ + mkLams bndrs $ + mkApps (Var (dataConWrapId con)) ops + -- This application will satisfy the Core invariants + -- from Note [Representation polymorphism invariants] in GHC.Core, + -- because typeclass method types are never unlifted. + + | otherwise = DFunUnfolding { df_bndrs = bndrs , df_con = con , df_args = map occurAnalyseExpr ops } - -- See Note [Occurrence analysis of unfoldings] + -- See Note [OccInfo in unfoldings and rules] in GHC.Core mkDataConUnfolding :: CoreExpr -> Unfolding -- Used for non-newtype data constructors with non-trivial wrappers @@ -96,7 +107,10 @@ where guide = UnfWhen { ug_arity = manifestArity expr , ug_unsat_ok = unSaturatedOk - , ug_boring_ok = False } + , ug_boring_ok = inlineBoringOk expr } + -- inineBoringOk; sometimes wrappers are very simple, like + -- \@a p q. K @a p q + -- and then we definitely want to inline it #25713 mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split @@ -117,7 +131,7 @@ = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance where new_tmpl = simpleOptExpr opts (work_fn tmpl) - guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl + guidance = calcUnfoldingGuidance (so_uf_opts opts) False False new_tmpl mkWorkerUnfolding _ _ _ = noUnfolding @@ -156,7 +170,7 @@ mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding mkInlinableUnfolding opts src expr - = mkUnfolding (so_uf_opts opts) src False False expr' Nothing + = mkUnfolding (so_uf_opts opts) src False False False expr' Nothing where expr' = simpleOptExpr opts expr @@ -183,6 +197,9 @@ spec_app (mkLams old_bndrs arg) -- The beta-redexes created by spec_app will be -- simplified away by simplOptExpr + -- ToDo: this is VERY DELICATE for type args. We make + -- (\@a @b x y. TYPE ty) ty1 ty2 d1 d2 + -- and rely on it simplifying to ty[ty1/a, ty2/b] specUnfolding opts spec_bndrs spec_app rule_lhs_args (CoreUnfolding { uf_src = src, uf_tmpl = tmpl @@ -319,16 +336,17 @@ -> Bool -- Is top-level -> Bool -- Definitely a bottoming binding -- (only relevant for top-level bindings) + -> Bool -- True <=> join point -> CoreExpr -> Maybe UnfoldingCache -> Unfolding -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it -mkUnfolding opts src top_lvl is_bottoming expr cache +mkUnfolding opts src top_lvl is_bottoming is_join expr cache = mkCoreUnfolding src top_lvl expr cache guidance where is_top_bottoming = top_lvl && is_bottoming - guidance = calcUnfoldingGuidance opts is_top_bottoming expr + guidance = calcUnfoldingGuidance opts is_top_bottoming is_join expr -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] @@ -338,7 +356,7 @@ mkCoreUnfolding src top_lvl expr precomputed_cache guidance = CoreUnfolding { uf_tmpl = cache `seq` occurAnalyseExpr expr - -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings] + -- occAnalyseExpr: see Note [OccInfo in unfoldings and rules] in GHC.Core -- See #20905 for what a discussion of this 'seq'. -- We are careful to make sure we only -- have one copy of an unfolding around at once. @@ -459,7 +477,7 @@ a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding. * The template of the unfolding is the result of performing occurrence analysis - (Note [Occurrence analysis of unfoldings]) + (Note [OccInfo in unfoldings and rules] in GHC.Core) * Predicates are applied to the unanalysed expression Therefore if we are not thoughtful about forcing you can end up in a situation where the diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -11,2096 +11,2531 @@ tcMatchTyX_BM, ruleMatchTyKiX, -- Side-effect free unification - tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, - tcUnifyTysFG, tcUnifyTyWithTFs, - BindFun, BindFlag(..), matchBindFun, alwaysBindFun, - UnifyResult, UnifyResultM(..), MaybeApartReason(..), - typesCantMatch, typesAreApart, - - -- Matching a type against a lifted type (coercion) - liftCoMatch, - - -- The core flattening algorithm - flattenTys, flattenTysX, - - ) where - -import GHC.Prelude - -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName ) -import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey ) -import GHC.Core.Type hiding ( getTvSubstEnv ) -import GHC.Core.Coercion hiding ( getCvSubstEnv ) -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Compare ( eqType, tcEqType ) -import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) -import GHC.Core.TyCo.Subst ( mkTvSubst, emptyIdSubstEnv ) -import GHC.Core.Map.Type -import GHC.Utils.FV( FV, fvVarList ) -import GHC.Utils.Misc -import GHC.Data.Pair -import GHC.Utils.Outputable -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Exts( oneShot ) -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.FastString - -import Data.List ( mapAccumL ) -import Control.Monad -import qualified Data.Semigroup as S - -{- - -Unification is much tricker than you might think. - -1. The substitution we generate binds the *template type variables* - which are given to us explicitly. - -2. We want to match in the presence of foralls; - e.g (forall a. t1) ~ (forall b. t2) - - That is what the RnEnv2 is for; it does the alpha-renaming - that makes it as if a and b were the same variable. - Initialising the RnEnv2, so that it can generate a fresh - binder when necessary, entails knowing the free variables of - both types. - -3. We must be careful not to bind a template type variable to a - locally bound variable. E.g. - (forall a. x) ~ (forall b. b) - where x is the template type variable. Then we do not want to - bind x to a/b! This is a kind of occurs check. - The necessary locals accumulate in the RnEnv2. - -Note [tcMatchTy vs tcMatchTyKi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This module offers two variants of matching: with kinds and without. -The TyKi variant takes two types, of potentially different kinds, -and matches them. Along the way, it necessarily also matches their -kinds. The Ty variant instead assumes that the kinds are already -eqType and so skips matching up the kinds. - -How do you choose between them? - -1. If you know that the kinds of the two types are eqType, use - the Ty variant. It is more efficient, as it does less work. - -2. If the kinds of variables in the template type might mention type families, - use the Ty variant (and do other work to make sure the kinds - work out). These pure unification functions do a straightforward - syntactic unification and do no complex reasoning about type - families. Note that the types of the variables in instances can indeed - mention type families, so instance lookup must use the Ty variant. - - (Nothing goes terribly wrong -- no panics -- if there might be type - families in kinds in the TyKi variant. You just might get match - failure even though a reducing a type family would lead to success.) - -3. Otherwise, if you're sure that the variable kinds do not mention - type families and you're not already sure that the kind of the template - equals the kind of the target, then use the TyKi version. --} - --- | Some unification functions are parameterised by a 'BindFun', which --- says whether or not to allow a certain unification to take place. --- A 'BindFun' takes the 'TyVar' involved along with the 'Type' it will --- potentially be bound to. --- --- It is possible for the variable to actually be a coercion variable --- (Note [Matching coercion variables]), but only when one-way matching. --- In this case, the 'Type' will be a 'CoercionTy'. -type BindFun = TyCoVar -> Type -> BindFlag - --- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) --- @s@ such that @s(t1)@ equals @t2@. --- The returned substitution might bind coercion variables, --- if the variable is an argument to a GADT constructor. --- --- Precondition: typeKind ty1 `eqType` typeKind ty2 --- --- We don't pass in a set of "template variables" to be bound --- by the match, because tcMatchTy (and similar functions) are --- always used on top-level types, so we can bind any of the --- free variables of the LHS. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTy :: Type -> Type -> Maybe Subst -tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] - -tcMatchTyX_BM :: BindFun -> Subst - -> Type -> Type -> Maybe Subst -tcMatchTyX_BM bind_me subst ty1 ty2 - = tc_match_tys_x bind_me False subst [ty1] [ty2] - --- | Like 'tcMatchTy', but allows the kinds of the types to differ, --- and thus matches them as well. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKi :: Type -> Type -> Maybe Subst -tcMatchTyKi ty1 ty2 - = tc_match_tys alwaysBindFun True [ty1] [ty2] - --- | This is similar to 'tcMatchTy', but extends a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyX :: Subst -- ^ Substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe Subst -tcMatchTyX subst ty1 ty2 - = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2] - --- | Like 'tcMatchTy' but over a list of types. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTys :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe Subst -- ^ One-shot; in principle the template - -- variables could be free in the target -tcMatchTys tys1 tys2 - = tc_match_tys alwaysBindFun False tys1 tys2 - --- | Like 'tcMatchTyKi' but over a list of types. --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKis :: [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe Subst -- ^ One-shot substitution -tcMatchTyKis tys1 tys2 - = tc_match_tys alwaysBindFun True tys1 tys2 - --- | Like 'tcMatchTys', but extending a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTysX :: Subst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe Subst -- ^ One-shot substitution -tcMatchTysX subst tys1 tys2 - = tc_match_tys_x alwaysBindFun False subst tys1 tys2 - --- | Like 'tcMatchTyKis', but extending a substitution --- See also Note [tcMatchTy vs tcMatchTyKi] -tcMatchTyKisX :: Subst -- ^ Substitution to extend - -> [Type] -- ^ Template - -> [Type] -- ^ Target - -> Maybe Subst -- ^ One-shot substitution -tcMatchTyKisX subst tys1 tys2 - = tc_match_tys_x alwaysBindFun True subst tys1 tys2 - --- | Same as tc_match_tys_x, but starts with an empty substitution -tc_match_tys :: BindFun - -> Bool -- ^ match kinds? - -> [Type] - -> [Type] - -> Maybe Subst -tc_match_tys bind_me match_kis tys1 tys2 - = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2 - where - in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) - --- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' -tc_match_tys_x :: BindFun - -> Bool -- ^ match kinds? - -> Subst - -> [Type] - -> [Type] - -> Maybe Subst -tc_match_tys_x bind_me match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2 - = case tc_unify_tys bind_me - False -- Matching, not unifying - False -- Not an injectivity check - match_kis - (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of - Unifiable (tv_env', cv_env') - -> Just $ Subst in_scope id_env tv_env' cv_env' - _ -> Nothing - --- | This one is called from the expression matcher, --- which already has a MatchEnv in hand -ruleMatchTyKiX - :: TyCoVarSet -- ^ template variables - -> RnEnv2 - -> TvSubstEnv -- ^ type substitution to extend - -> Type -- ^ Template - -> Type -- ^ Target - -> Maybe TvSubstEnv -ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target --- See Note [Kind coercions in Unify] - = case tc_unify_tys (matchBindFun tmpl_tvs) False False - True -- <-- this means to match the kinds - rn_env tenv emptyCvSubstEnv [tmpl] [target] of - Unifiable (tenv', _) -> Just tenv' - _ -> Nothing - --- | Allow binding only for any variable in the set. Variables may --- be bound to any type. --- Used when doing simple matching; e.g. can we find a substitution --- --- @ --- S = [a :-> t1, b :-> t2] such that --- S( Maybe (a, b->Int ) = Maybe (Bool, Char -> Int) --- @ -matchBindFun :: TyCoVarSet -> BindFun -matchBindFun tvs tv _ty - | tv `elemVarSet` tvs = BindMe - | otherwise = Apart - --- | Allow the binding of any variable to any type -alwaysBindFun :: BindFun -alwaysBindFun _tv _ty = BindMe - -{- -************************************************************************ -* * - GADTs -* * -************************************************************************ - -Note [Pruning dead case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider data T a where - T1 :: T Int - T2 :: T a - - newtype X = MkX Int - newtype Y = MkY Char - - type family F a - type instance F Bool = Int - -Now consider case x of { T1 -> e1; T2 -> e2 } - -The question before the house is this: if I know something about the type -of x, can I prune away the T1 alternative? - -Suppose x::T Char. It's impossible to construct a (T Char) using T1, - Answer = YES we can prune the T1 branch (clearly) - -Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated -to 'Bool', in which case x::T Int, so - ANSWER = NO (clearly) - -We see here that we want precisely the apartness check implemented within -tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely -apart. Note that since we are simply dropping dead code, a conservative test -suffices. --} - --- | Given a list of pairs of types, are any two members of a pair surely --- apart, even after arbitrary type function evaluation and substitution? -typesCantMatch :: [(Type,Type)] -> Bool --- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (uncurry typesAreApart) prs - -typesAreApart :: Type -> Type -> Bool -typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of - SurelyApart -> True - _ -> False -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [Fine-grained unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- -no substitution to finite types makes these match. But, a substitution to -*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. -Why do we care? Consider these two type family instances: - -type instance F x x = Int -type instance F [y] y = Bool - -If we also have - -type instance Looper = [Looper] - -then the instances potentially overlap. The solution is to use unification -over infinite terms. This is possible (see [1] for lots of gory details), but -a full algorithm is a little more power than we need. Instead, we make a -conservative approximation and just omit the occurs check. - -[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf - -tcUnifyTys considers an occurs-check problem as the same as general unification -failure. - -tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check -failure ("MaybeApart"), or general failure ("SurelyApart"). - -See also #8162. - -It's worth noting that unification in the presence of infinite types is not -complete. This means that, sometimes, a closed type family does not reduce -when it should. See test case indexed-types/should_fail/Overlap15 for an -example. - -Note [Unification result] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When unifying t1 ~ t2, we return -* Unifiable s, if s is a substitution such that s(t1) is syntactically the - same as s(t2), modulo type-synonym expansion. -* SurelyApart, if there is no substitution s such that s(t1) = s(t2), - where "=" includes type-family reductions. -* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason. - -Examples -* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify -* [(a,Int)] ~ [(Bool,b)]: Unifiable -* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool (the unifier - does not try this) -* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart either; consider - a := Loop - where type family Loop where Loop = Maybe Loop - -There is the possibility that two types are MaybeApart for *both* reasons: - -* (a, F Int) ~ (Maybe a, Bool) - -What reason should we use? The *only* consumer of the reason is described -in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal -there is identify which instances might match a target later (but don't -match now) -- except that we want to ignore the possibility of infinitary -substitutions. So let's examine a concrete scenario: - - class C a b c - instance C a (Maybe a) Bool - -- other instances, including one that will actually match - [W] C b b (F Int) - -Do we want the instance as a future possibility? No. The only way that -instance can match is in the presence of an infinite type (infinitely -nested Maybes). We thus say that MARInfinite takes precedence, so that -InstEnv treats this case as an infinitary substitution case; the fact -that a type family is involved is only incidental. We thus define -the Semigroup instance for MaybeApartReason to prefer MARInfinite. - -Note [The substitution in MaybeApart] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? -Because consider unifying these: - -(a, a, Int) ~ (b, [b], Bool) - -If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we -apply the subst we have so far and discover that we need [b |-> [b]]. Because -this fails the occurs check, we say that the types are MaybeApart (see above -Note [Fine-grained unification]). But, we can't stop there! Because if we -continue, we discover that Int is SurelyApart from Bool, and therefore the -types are apart. This has practical consequences for the ability for closed -type family applications to reduce. See test case -indexed-types/should_compile/Overlap14. - --} - --- | Simple unification of two types; all type variables are bindable --- Precondition: the kinds are already equal -tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe Subst - -- A regular one-shot (idempotent) substitution -tcUnifyTy t1 t2 = tcUnifyTys alwaysBindFun [t1] [t2] - --- | Like 'tcUnifyTy', but also unifies the kinds -tcUnifyTyKi :: Type -> Type -> Maybe Subst -tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [t1] [t2] - --- | Unify two types, treating type family applications as possibly unifying --- with anything and looking through injective type family applications. --- Precondition: kinds are the same -tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; - -- False <=> do one-way matching. - -- See end of sec 5.2 from the paper - -> InScopeSet -- Should include the free tyvars of both Type args - -> Type -> Type -- Types to unify - -> Maybe Subst --- This algorithm is an implementation of the "Algorithm U" presented in --- the paper "Injective type families for Haskell", Figures 2 and 3. --- The code is incorporated with the standard unifier for convenience, but --- its operation should match the specification in the paper. -tcUnifyTyWithTFs twoWay in_scope t1 t2 - = case tc_unify_tys alwaysBindFun twoWay True False - rn_env emptyTvSubstEnv emptyCvSubstEnv - [t1] [t2] of - Unifiable (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst - MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst - -- we want to *succeed* in questionable cases. This is a - -- pre-unification algorithm. - SurelyApart -> Nothing - where - rn_env = mkRnEnv2 in_scope - - maybe_fix | twoWay = niFixSubst in_scope - | otherwise = mkTvSubst in_scope -- when matching, don't confuse - -- domain with range - ------------------ -tcUnifyTys :: BindFun - -> [Type] -> [Type] - -> Maybe Subst - -- ^ A regular one-shot (idempotent) substitution - -- that unifies the erased types. See comments - -- for 'tcUnifyTysFG' - --- The two types may have common type variables, and indeed do so in the --- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD -tcUnifyTys bind_fn tys1 tys2 - = case tcUnifyTysFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- | Like 'tcUnifyTys' but also unifies the kinds -tcUnifyTyKis :: BindFun - -> [Type] -> [Type] - -> Maybe Subst -tcUnifyTyKis bind_fn tys1 tys2 - = case tcUnifyTyKisFG bind_fn tys1 tys2 of - Unifiable result -> Just result - _ -> Nothing - --- This type does double-duty. It is used in the UM (unifier monad) and to --- return the final result. See Note [Fine-grained unification] -type UnifyResult = UnifyResultM Subst - --- | See Note [Unification result] -data UnifyResultM a = Unifiable a -- the subst that unifies the types - | MaybeApart MaybeApartReason - a -- the subst has as much as we know - -- it must be part of a most general unifier - -- See Note [The substitution in MaybeApart] - | SurelyApart - deriving Functor - --- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence: --- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv --- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint; --- it's really only MARInfinite that's interesting here. -data MaybeApartReason - = MARTypeFamily -- ^ matching e.g. F Int ~? Bool - - | MARInfinite -- ^ matching e.g. a ~? Maybe a - - | MARTypeVsConstraint -- ^ matching Type ~? Constraint or the arrow types - -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim - -instance Outputable MaybeApartReason where - ppr MARTypeFamily = text "MARTypeFamily" - ppr MARInfinite = text "MARInfinite" - ppr MARTypeVsConstraint = text "MARTypeVsConstraint" - -instance Semigroup MaybeApartReason where - -- see end of Note [Unification result] for why - MARTypeFamily <> r = r - MARInfinite <> _ = MARInfinite - MARTypeVsConstraint <> r = r - -instance Applicative UnifyResultM where - pure = Unifiable - (<*>) = ap - -instance Monad UnifyResultM where - SurelyApart >>= _ = SurelyApart - MaybeApart r1 x >>= f = case f x of - Unifiable y -> MaybeApart r1 y - MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y - SurelyApart -> SurelyApart - Unifiable x >>= f = f x - --- | @tcUnifyTysFG bind_tv tys1 tys2@ attempts to find a substitution @s@ (whose --- domain elements all respond 'BindMe' to @bind_tv@) such that --- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned --- Coercions. This version requires that the kinds of the types are the same, --- if you unify left-to-right. -tcUnifyTysFG :: BindFun - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTysFG bind_fn tys1 tys2 - = tc_unify_tys_fg False bind_fn tys1 tys2 - -tcUnifyTyKisFG :: BindFun - -> [Type] -> [Type] - -> UnifyResult -tcUnifyTyKisFG bind_fn tys1 tys2 - = tc_unify_tys_fg True bind_fn tys1 tys2 - -tc_unify_tys_fg :: Bool - -> BindFun - -> [Type] -> [Type] - -> UnifyResult -tc_unify_tys_fg match_kis bind_fn tys1 tys2 - = do { (env, _) <- tc_unify_tys bind_fn True False match_kis rn_env - emptyTvSubstEnv emptyCvSubstEnv - tys1 tys2 - ; return $ niFixSubst in_scope env } - where - in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 - rn_env = mkRnEnv2 in_scope - --- | This function is actually the one to call the unifier -- a little --- too general for outside clients, though. -tc_unify_tys :: BindFun - -> AmIUnifying -- ^ True <=> unify; False <=> match - -> Bool -- ^ True <=> doing an injectivity check - -> Bool -- ^ True <=> treat the kinds as well - -> RnEnv2 - -> TvSubstEnv -- ^ substitution to extend - -> CvSubstEnv - -> [Type] -> [Type] - -> UnifyResultM (TvSubstEnv, CvSubstEnv) --- NB: It's tempting to ASSERT here that, if we're not matching kinds, then --- the kinds of the types should be the same. However, this doesn't work, --- as the types may be a dependent telescope, where later types have kinds --- that mention variables occurring earlier in the list of types. Here's an --- example (from typecheck/should_fail/T12709): --- template: [rep :: RuntimeRep, a :: TYPE rep] --- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] --- We can see that matching the first pair will make the kinds of the second --- pair equal. Yet, we still don't need a separate pass to unify the kinds --- of these types, so it's appropriate to use the Ty variant of unification. --- See also Note [tcMatchTy vs tcMatchTyKi]. -tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 - = initUM tv_env cv_env $ - do { when match_kis $ - unify_tys env kis1 kis2 - ; unify_tys env tys1 tys2 - ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } - where - env = UMEnv { um_bind_fun = bind_fn - , um_skols = emptyVarSet - , um_unif = unif - , um_inj_tf = inj_check - , um_rn_env = rn_env } - - kis1 = map typeKind tys1 - kis2 = map typeKind tys2 - -instance Outputable a => Outputable (UnifyResultM a) where - ppr SurelyApart = text "SurelyApart" - ppr (Unifiable x) = text "Unifiable" <+> ppr x - ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x - -{- -************************************************************************ -* * - Non-idempotent substitution -* * -************************************************************************ - -Note [Non-idempotent substitution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During unification we use a TvSubstEnv/CvSubstEnv pair that is - (a) non-idempotent - (b) loop-free; ie repeatedly applying it yields a fixed point - -Note [Finding the substitution fixpoint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Finding the fixpoint of a non-idempotent substitution arising from a -unification is much trickier than it looks, because of kinds. Consider - T k (H k (f:k)) ~ T * (g:*) -If we unify, we get the substitution - [ k -> * - , g -> H k (f:k) ] -To make it idempotent we don't want to get just - [ k -> * - , g -> H * (f:k) ] -We also want to substitute inside f's kind, to get - [ k -> * - , g -> H k (f:*) ] -If we don't do this, we may apply the substitution to something, -and get an ill-formed type, i.e. one where typeKind will fail. -This happened, for example, in #9106. - -It gets worse. In #14164 we wanted to take the fixpoint of -this substitution - [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) - (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) - , a_aY6 :-> a_aXQ ] - -We have to apply the substitution for a_aY6 two levels deep inside -the invocation of F! We don't have a function that recursively -applies substitutions inside the kinds of variable occurrences (and -probably rightly so). - -So, we work as follows: - - 1. Start with the current substitution (which we are - trying to fixpoint - [ xs :-> F a (z :: a) (rest :: G a (z :: a)) - , a :-> b ] - - 2. Take all the free vars of the range of the substitution: - {a, z, rest, b} - NB: the free variable finder closes over - the kinds of variable occurrences - - 3. If none are in the domain of the substitution, stop. - We have found a fixpoint. - - 4. Remove the variables that are bound by the substitution, leaving - {z, rest, b} - - 5. Do a topo-sort to put them in dependency order: - [ b :: *, z :: a, rest :: G a z ] - - 6. Apply the substitution left-to-right to the kinds of these - tyvars, extending it each time with a new binding, so we - finish up with - [ xs :-> ..as before.. - , a :-> b - , b :-> b :: * - , z :-> z :: b - , rest :-> rest :: G b (z :: b) ] - Note that rest now has the right kind - - 7. Apply this extended substitution (once) to the range of - the /original/ substitution. (Note that we do the - extended substitution would go on forever if you tried - to find its fixpoint, because it maps z to z.) - - 8. And go back to step 1 - -In Step 6 we use the free vars from Step 2 as the initial -in-scope set, because all of those variables appear in the -range of the substitution, so they must all be in the in-scope -set. But NB that the type substitution engine does not look up -variables in the in-scope set; it is used only to ensure no -shadowing. --} - -niFixSubst :: InScopeSet -> TvSubstEnv -> Subst --- Find the idempotent fixed point of the non-idempotent substitution --- This is surprisingly tricky: --- see Note [Finding the substitution fixpoint] --- ToDo: use laziness instead of iteration? -niFixSubst in_scope tenv - | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) - | otherwise = subst - where - range_fvs :: FV - range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) - -- It's OK to use nonDetEltsUFM here because the - -- order of range_fvs, range_tvs is immaterial - - range_tvs :: [TyVar] - range_tvs = fvVarList range_fvs - - not_fixpoint = any in_domain range_tvs - in_domain tv = tv `elemVarEnv` tenv - - free_tvs = scopedSort (filterOut in_domain range_tvs) - - -- See Note [Finding the substitution fixpoint], Step 6 - subst = foldl' add_free_tv - (mkTvSubst in_scope tenv) - free_tvs - - add_free_tv :: Subst -> TyVar -> Subst - add_free_tv subst tv - = extendTvSubst subst tv (mkTyVarTy tv') - where - tv' = updateTyVarKind (substTy subst) tv - -niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet --- Apply the non-idempotent substitution to a set of type variables, --- remembering that the substitution isn't necessarily idempotent --- This is used in the occurs check, before extending the substitution -niSubstTvSet tsubst tvs - = nonDetStrictFoldUniqSet (unionVarSet . get) emptyVarSet tvs - -- It's OK to use a non-deterministic fold here because we immediately forget - -- the ordering by creating a set. - where - get tv - | Just ty <- lookupVarEnv tsubst tv - = niSubstTvSet tsubst (tyCoVarsOfType ty) - - | otherwise - = unitVarSet tv - -{- -************************************************************************ -* * - unify_ty: the main workhorse -* * -************************************************************************ - -Note [Specification of unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The pure unifier, unify_ty, defined in this module, tries to work out -a substitution to make two types say True to eqType. NB: eqType is -itself not purely syntactic; it accounts for CastTys; -see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep - -Unlike the "impure unifiers" in the typechecker (the eager unifier in -GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality), -the pure unifier does /not/ work up to ~. - -The algorithm implemented here is rather delicate, and we depend on it -to uphold certain properties. This is a summary of these required -properties. - -Notation: - θ,φ substitutions - ξ type-function-free types - τ,σ other types - τ♭ type τ, flattened - - ≡ eqType - -(U1) Soundness. - If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). - θ is a most general unifier for τ₁ and τ₂. - -(U2) Completeness. - If (unify ξ₁ ξ₂) = SurelyApart, - then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). - -These two properties are stated as Property 11 in the "Closed Type Families" -paper (POPL'14). Below, this paper is called [CTF]. - -(U3) Apartness under substitution. - If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, - for any θ. (Property 12 from [CTF]) - -(U4) Apart types do not unify. - If (unify ξ τ♭) = SurelyApart, then there exists no θ - such that θ(ξ) = θ(τ). (Property 13 from [CTF]) - -THEOREM. Completeness w.r.t ~ - If (unify τ₁♭ τ₂♭) = SurelyApart, - then there exists no proof that (τ₁ ~ τ₂). - -PROOF. See appendix of [CTF]. - - -The unification algorithm is used for type family injectivity, as described -in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run -in this mode, it has the following properties. - -(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even - after arbitrary type family reductions. Note that σ and τ are - not flattened here. - -(I2) If (unify σ τ) = MaybeApart θ, and if some - φ exists such that φ(σ) ~ φ(τ), then φ extends θ. - - -Furthermore, the RULES matching algorithm requires this property, -but only when using this algorithm for matching: - -(M1) If (match σ τ) succeeds with θ, then all matchable tyvars - in σ are bound in θ. - - Property M1 means that we must extend the substitution with, - say (a ↦ a) when appropriate during matching. - See also Note [Self-substitution when matching]. - -(M2) Completeness of matching. - If θ(σ) = τ, then (match σ τ) = Unifiable φ, - where θ is an extension of φ. - -Sadly, property M2 and I2 conflict. Consider - -type family F1 a b where - F1 Int Bool = Char - F1 Double String = Char - -Consider now two matching problems: - -P1. match (F1 a Bool) (F1 Int Bool) -P2. match (F1 a Bool) (F1 Double String) - -In case P1, we must find (a ↦ Int) to satisfy M2. -In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note -that the correct mapping for I2 is (a ↦ Int). There is no way to discover -this, but we mustn't map a to anything else!) - -We thus must parameterize the algorithm over whether it's being used -for an injectivity check (refrain from looking at non-injective arguments -to type families) or not (do indeed look at those arguments). This is -implemented by the um_inj_tf field of UMEnv. - -(It's all a question of whether or not to include equation (7) from Fig. 2 -of [ITF].) - -This extra parameter is a bit fiddly, perhaps, but seemingly less so than -having two separate, almost-identical algorithms. - -Note [Self-substitution when matching] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should happen when we're *matching* (not unifying) a1 with a1? We -should get a substitution [a1 |-> a1]. A successful match should map all -the template variables (except ones that disappear when expanding synonyms). -But when unifying, we don't want to do this, because we'll then fall into -a loop. - -This arrangement affects the code in three places: - - If we're matching a refined template variable, don't recur. Instead, just - check for equality. That is, if we know [a |-> Maybe a] and are matching - (a ~? Maybe Int), we want to just fail. - - - Skip the occurs check when matching. This comes up in two places, because - matching against variables is handled separately from matching against - full-on types. - -Note that this arrangement was provoked by a real failure, where the same -unique ended up in the template as in the target. (It was a rule firing when -compiling Data.List.NonEmpty.) - -Note [Matching coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - type family F a - - data G a where - MkG :: F a ~ Bool => G a - - type family Foo (x :: G a) :: F a - type instance Foo MkG = False - -We would like that to be accepted. For that to work, we need to introduce -a coercion variable on the left and then use it on the right. Accordingly, -at use sites of Foo, we need to be able to use matching to figure out the -value for the coercion. (See the desugared version: - - axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) - -) We never want this action to happen during *unification* though, when -all bets are off. - -Note [Kind coercions in Unify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We wish to match/unify while ignoring casts. But, we can't just ignore -them completely, or we'll end up with ill-kinded substitutions. For example, -say we're matching `a` with `ty |> co`. If we just drop the cast, we'll -return [a |-> ty], but `a` and `ty` might have different kinds. We can't -just match/unify their kinds, either, because this might gratuitously -fail. After all, `co` is the witness that the kinds are the same -- they -may look nothing alike. - -So, we pass a kind coercion to the match/unify worker. This coercion witnesses -the equality between the substed kind of the left-hand type and the substed -kind of the right-hand type. Note that we do not unify kinds at the leaves -(as we did previously). We thus have - -Hence: (Unification Kind Invariant) ------------------------------------ -In the call - unify_ty ty1 ty2 kco -it must be that - subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)) -where `subst` is the ambient substitution in the UM monad. And in the call - unify_tys tys1 tys2 -(which has no kco), after we unify any prefix of tys1,tys2, the kinds of the -head of the remaining tys1,tys2 are identical after substitution. This -implies, for example, that the kinds of the head of tys1,tys2 are identical -after substitution. - -To get this coercion, we first have to match/unify -the kinds before looking at the types. Happily, we need look only one level -up, as all kinds are guaranteed to have kind *. - -When we're working with type applications (either TyConApp or AppTy) we -need to worry about establishing INVARIANT, as the kinds of the function -& arguments aren't (necessarily) included in the kind of the result. -When unifying two TyConApps, this is easy, because the two TyCons are -the same. Their kinds are thus the same. As long as we unify left-to-right, -we'll be sure to unify types' kinds before the types themselves. (For example, -think about Proxy :: forall k. k -> *. Unifying the first args matches up -the kinds of the second args.) - -For AppTy, we must unify the kinds of the functions, but once these are -unified, we can continue unifying arguments without worrying further about -kinds. - -The interface to this module includes both "...Ty" functions and -"...TyKi" functions. The former assume that INVARIANT is already -established, either because the kinds are the same or because the -list of types being passed in are the well-typed arguments to some -type constructor (see two paragraphs above). The latter take a separate -pre-pass over the kinds to establish INVARIANT. Sometimes, it's important -not to take the second pass, as it caused #12442. - -We thought, at one point, that this was all unnecessary: why should -casts be in types in the first place? But they are sometimes. In -dependent/should_compile/KindEqualities2, we see, for example the -constraint Num (Int |> (blah ; sym blah)). We naturally want to find -a dictionary for that constraint, which requires dealing with -coercions in this manner. - -Note [Matching in the presence of casts (1)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When matching, it is crucial that no variables from the template -end up in the range of the matching substitution (obviously!). -When unifying, that's not a constraint; instead we take the fixpoint -of the substitution at the end. - -So what should we do with this, when matching? - unify_ty (tmpl |> co) tgt kco - -Previously, wrongly, we pushed 'co' in the (horrid) accumulating -'kco' argument like this: - unify_ty (tmpl |> co) tgt kco - = unify_ty tmpl tgt (kco ; co) - -But that is obviously wrong because 'co' (from the template) ends -up in 'kco', which in turn ends up in the range of the substitution. - -This all came up in #13910. Because we match tycon arguments -left-to-right, the ambient substitution will already have a matching -substitution for any kinds; so there is an easy fix: just apply -the substitution-so-far to the coercion from the LHS. - -Note that - -* When matching, the first arg of unify_ty is always the template; - we never swap round. - -* The above argument is distressingly indirect. We seek a - better way. - -* One better way is to ensure that type patterns (the template - in the matching process) have no casts. See #14119. - -Note [Matching in the presence of casts (2)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) -and we are matching - tcMatchTy (T k (a::k)) (T j (b::j)) - -Then we'll match k :-> j, as expected. But then in unify_tys -we invoke - unify_tys env (a::k) (b::j) (Refl j) - -Although we have unified k and j, it's very important that we put -(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. -If we put (Refl k) we'd end up with the substitution - a :-> b |> Refl k -which is bogus because one of the template variables, k, -appears in the range of the substitution. Eek. - -Similar care is needed in unify_ty_app. - - -Note [Polykinded tycon applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose T :: forall k. Type -> K -and we are unifying - ty1: T @Type Int :: Type - ty2: T @(Type->Type) Int Int :: Type - -These two TyConApps have the same TyCon at the front but they -(legitimately) have different numbers of arguments. They -are surelyApart, so we can report that without looking any -further (see #15704). - -Note [Unifying type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unifying type applications is quite subtle, as we found -in #23134 and #22647, when type families are involved. - -Suppose - type family F a :: Type -> Type - type family G k :: k = r | r -> k - -and consider these examples: - -* F Int ~ F Char, where F is injective - Since F is injective, we can reduce this to Int ~ Char, - therefore SurelyApart. - -* F Int ~ F Char, where F is not injective - Without injectivity, return MaybeApart. - -* G Type ~ G (Type -> Type) Int - Even though G is injective and the arguments to G are different, - we cannot deduce apartness because the RHS is oversaturated. - For example, G might be defined as - G Type = Maybe Int - G (Type -> Type) = Maybe - So we return MaybeApart. - -* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char) - F Int Bool ~ Maybe a -- MaybeApart - F Int Bool ~ a b -- MaybeApart - F Int Bool ~ Char -> Bool -- MaybeApart - An oversaturated type family can match an application, - whether it's a TyConApp, AppTy or FunTy. Decompose. - -* F Int ~ a b - We cannot decompose a saturated, or under-saturated - type family application. We return MaybeApart. - -To handle all those conditions, unify_ty goes through -the following checks in sequence, where Fn is a type family -of arity n: - -* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n - A saturated application. - Here we can unify arguments in which Fn is injective. -* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n - A saturated type family can match anything - we return MaybeApart. -* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n - An oversaturated type family can be decomposed. -* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n - If we couldn't decompose in the previous step, we return SurelyApart. - -Afterwards, the rest of the code doesn't have to worry about type families. --} - --------------- unify_ty: the main workhorse ----------- - -type AmIUnifying = Bool -- True <=> Unifying - -- False <=> Matching - -unify_ty :: UMEnv - -> Type -> Type -- Types to be unified and a co - -> CoercionN -- A coercion between their kinds - -- See Note [Kind coercions in Unify] - -> UM () --- Precondition: see (Unification Kind Invariant) --- --- See Note [Specification of unification] --- Respects newtypes, PredTypes --- See Note [Computing equality on types] in GHC.Core.Type -unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco - -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. - | tc1 == tc2 - = return () - -unify_ty env ty1 ty2 kco - -- Now handle the cases we can "look through": synonyms and casts. - | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco - | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco - | CastTy ty1' co <- ty1 = if um_unif env - then unify_ty env ty1' ty2 (co `mkTransCo` kco) - else -- See Note [Matching in the presence of casts (1)] - do { subst <- getSubst env - ; let co' = substCo subst co - ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } - | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) - -unify_ty env (TyVarTy tv1) ty2 kco - = uVar env tv1 ty2 kco -unify_ty env ty1 (TyVarTy tv2) kco - | um_unif env -- If unifying, can swap args - = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) - -unify_ty env ty1 ty2 _kco - - -- Handle non-oversaturated type families first - -- See Note [Unifying type applications] - -- - -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T - -- Note that both sides must not be oversaturated - | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1 - , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2 - , tc1 == tc2 - = do { let inj = case tyConInjectivityInfo tc1 of - NotInjective -> repeat False - Injective bs -> bs - - (inj_tys1, noninj_tys1) = partitionByList inj tys1 - (inj_tys2, noninj_tys2) = partitionByList inj tys2 - - ; unify_tys env inj_tys1 inj_tys2 - ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] - don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } - - | Just _ <- isSatTyFamApp mb_tc_app1 -- (C2) A (not-over-saturated) type-family application - = maybeApart MARTypeFamily -- behaves like a type variable; might match - - | Just _ <- isSatTyFamApp mb_tc_app2 -- (C2) A (not-over-saturated) type-family application - -- behaves like a type variable; might unify - -- but doesn't match (as in the TyVarTy case) - = if um_unif env then maybeApart MARTypeFamily else surelyApart - - -- Handle oversaturated type families. - -- - -- They can match an application (TyConApp/FunTy/AppTy), this is handled - -- the same way as in the AppTy case below. - -- - -- If there is no application, an oversaturated type family can only - -- match a type variable or a saturated type family, - -- both of which we handled earlier. So we can say surelyApart. - | Just (tc1, _) <- mb_tc_app1 - , isTypeFamilyTyCon tc1 - = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 - , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 - -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) - | otherwise -> surelyApart -- (C4) - - | Just (tc2, _) <- mb_tc_app2 - , isTypeFamilyTyCon tc2 - = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 - , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 - -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) - | otherwise -> surelyApart -- (C4) - - -- At this point, neither tc1 nor tc2 can be a type family. - | Just (tc1, tys1) <- mb_tc_app1 - , Just (tc2, tys2) <- mb_tc_app2 - , tc1 == tc2 - = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1) - ; unify_tys env tys1 tys2 - } - - -- TYPE and CONSTRAINT are not Apart - -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim - -- NB: at this point we know that the two TyCons do not match - | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1 - , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2 - , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) || - (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey) - = maybeApart MARTypeVsConstraint - -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim - -- Note [Type and Constraint are not apart] - - -- The arrow types are not Apart - -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim - -- wrinkle (W2) - -- NB1: at this point we know that the two TyCons do not match - -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via - -- splitTyConApp_maybe. But yes we do: we need to look at those implied - -- kind argument in order to satisfy (Unification Kind Invariant) - | FunTy {} <- ty1 - , FunTy {} <- ty2 - = maybeApart MARTypeVsConstraint - -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim - -- Note [Type and Constraint are not apart] - - where - mb_tc_app1 = splitTyConApp_maybe ty1 - mb_tc_app2 = splitTyConApp_maybe ty2 - - -- Applications need a bit of care! - -- They can match FunTy and TyConApp, so use splitAppTy_maybe - -- NB: we've already dealt with type variables, - -- so if one type is an App the other one jolly well better be too -unify_ty env (AppTy ty1a ty1b) ty2 _kco - | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty env ty1 (AppTy ty2a ty2b) _kco - | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 - = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () - -unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco - = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) - ; let env' = umRnBndr2 env tv1 tv2 - ; unify_ty env' ty1 ty2 kco } - --- See Note [Matching coercion variables] -unify_ty env (CoercionTy co1) (CoercionTy co2) kco - = do { c_subst <- getCvSubstEnv - ; case co1 of - CoVarCo cv - | not (um_unif env) - , not (cv `elemVarEnv` c_subst) - , let (_, co_l, co_r) = decomposeFunCo kco - -- Because the coercion is used in a type, it should be safe to - -- ignore the multiplicity coercion. - -- cv :: t1 ~ t2 - -- co2 :: s1 ~ s2 - -- co_l :: t1 ~ s1 - -- co_r :: t2 ~ s2 - rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r - , BindMe <- tvBindFlag env cv (CoercionTy rhs_co) - -> do { checkRnEnv env (tyCoVarsOfCo co2) - ; extendCvEnv cv rhs_co } - _ -> return () } - -unify_ty _ _ _ _ = surelyApart - -unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () -unify_ty_app env ty1 ty1args ty2 ty2args - | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 - , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2 - = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) - - | otherwise - = do { let ki1 = typeKind ty1 - ki2 = typeKind ty2 - -- See Note [Kind coercions in Unify] - ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) - ; unify_ty env ty1 ty2 (mkNomReflCo ki2) - -- Very important: 'ki2' not 'ki1' - -- See Note [Matching in the presence of casts (2)] - ; unify_tys env ty1args ty2args } - -unify_tys :: UMEnv -> [Type] -> [Type] -> UM () --- Precondition: see (Unification Kind Invariant) -unify_tys env orig_xs orig_ys - = go orig_xs orig_ys - where - go [] [] = return () - go (x:xs) (y:ys) - -- See Note [Kind coercions in Unify] - = do { unify_ty env x y (mkNomReflCo $ typeKind y) - -- Very important: 'y' not 'x' - -- See Note [Matching in the presence of casts (2)] - ; go xs ys } - go _ _ = surelyApart - -- Possibly different saturations of a polykinded tycon - -- See Note [Polykinded tycon applications] - -isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type]) --- Return the argument if we have a saturated type family application --- If it is /over/ saturated then we return False. E.g. --- unify_ty (F a b) (c d) where F has arity 1 --- we definitely want to decompose that type application! (#22647) -isSatTyFamApp tapp@(Just (tc, tys)) - | isTypeFamilyTyCon tc - && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated - = tapp -isSatTyFamApp _ = Nothing - ---------------------------------- -uVar :: UMEnv - -> InTyVar -- Variable to be unified - -> Type -- with this Type - -> Coercion -- :: kind tv ~N kind ty - -> UM () - -uVar env tv1 ty kco - = do { -- Apply the ambient renaming - let tv1' = umRnOccL env tv1 - - -- Check to see whether tv1 is refined by the substitution - ; subst <- getTvSubstEnv - ; case (lookupVarEnv subst tv1') of - Just ty' | um_unif env -- Unifying, so call - -> unify_ty env ty' ty kco -- back into unify - | otherwise - -> -- Matching, we don't want to just recur here. - -- this is because the range of the subst is the target - -- type, not the template type. So, just check for - -- normal type equality. - unless ((ty' `mkCastTy` kco) `tcEqType` ty) $ - surelyApart - -- NB: it's important to use `tcEqType` instead of `eqType` here, - -- otherwise we might not reject a substitution - -- which unifies `Type` with `Constraint`, e.g. - -- a call to tc_unify_tys with arguments - -- - -- tys1 = [k,k] - -- tys2 = [Type, Constraint] - -- - -- See test cases: T11715b, T20521. - Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue - -uUnrefined :: UMEnv - -> OutTyVar -- variable to be unified - -> Type -- with this Type - -> Type -- (version w/ expanded synonyms) - -> Coercion -- :: kind tv ~N kind ty - -> UM () - --- We know that tv1 isn't refined - -uUnrefined env tv1' ty2 ty2' kco - | Just ty2'' <- coreView ty2' - = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms - -- This is essential, in case we have - -- type Foo a = a - -- and then unify a ~ Foo a - - | TyVarTy tv2 <- ty2' - = do { let tv2' = umRnOccR env tv2 - ; unless (tv1' == tv2' && um_unif env) $ do - -- If we are unifying a ~ a, just return immediately - -- Do not extend the substitution - -- See Note [Self-substitution when matching] - - -- Check to see whether tv2 is refined - { subst <- getTvSubstEnv - ; case lookupVarEnv subst tv2 of - { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco - ; _ -> - - do { -- So both are unrefined - -- Bind one or the other, depending on which is bindable - ; let rhs1 = ty2 `mkCastTy` mkSymCo kco - rhs2 = ty1 `mkCastTy` kco - b1 = tvBindFlag env tv1' rhs1 - b2 = tvBindFlag env tv2' rhs2 - ty1 = mkTyVarTy tv1' - ; case (b1, b2) of - (BindMe, _) -> bindTv env tv1' rhs1 - (_, BindMe) | um_unif env - -> bindTv (umSwapRn env) tv2 rhs2 - - _ | tv1' == tv2' -> return () - -- How could this happen? If we're only matching and if - -- we're comparing forall-bound variables. - - _ -> surelyApart - }}}} - -uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable - = case tvBindFlag env tv1' rhs of - Apart -> surelyApart - BindMe -> bindTv env tv1' rhs - where - rhs = ty2 `mkCastTy` mkSymCo kco - -bindTv :: UMEnv -> OutTyVar -> Type -> UM () --- OK, so we want to extend the substitution with tv := ty --- But first, we must do a couple of checks -bindTv env tv1 ty2 - = do { let free_tvs2 = tyCoVarsOfType ty2 - - -- Make sure tys mentions no local variables - -- E.g. (forall a. b) ~ (forall a. [a]) - -- We should not unify b := [a]! - ; checkRnEnv env free_tvs2 - - -- Occurs check, see Note [Fine-grained unification] - -- Make sure you include 'kco' (which ty2 does) #14846 - ; occurs <- occursCheck env tv1 free_tvs2 - - ; if occurs then maybeApart MARInfinite - else extendTvEnv tv1 ty2 } - -occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool -occursCheck env tv free_tvs - | um_unif env - = do { tsubst <- getTvSubstEnv - ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } - - | otherwise -- Matching; no occurs check - = return False -- See Note [Self-substitution when matching] - -{- -%************************************************************************ -%* * - Binding decisions -* * -************************************************************************ --} - -data BindFlag - = BindMe -- ^ A regular type variable - - | Apart -- ^ Declare that this type variable is /apart/ from the - -- type provided. That is, the type variable will never - -- be instantiated to that type. - -- See also Note [Binding when looking up instances] - -- in GHC.Core.InstEnv. - deriving Eq --- NB: It would be conceivable to have an analogue to MaybeApart here, --- but there is not yet a need. - -{- -************************************************************************ -* * - Unification monad -* * -************************************************************************ --} - -data UMEnv - = UMEnv { um_unif :: AmIUnifying - - , um_inj_tf :: Bool - -- Checking for injectivity? - -- See (end of) Note [Specification of unification] - - , um_rn_env :: RnEnv2 - -- Renaming InTyVars to OutTyVars; this eliminates - -- shadowing, and lines up matching foralls on the left - -- and right - - , um_skols :: TyVarSet - -- OutTyVars bound by a forall in this unification; - -- Do not bind these in the substitution! - -- See the function tvBindFlag - - , um_bind_fun :: BindFun - -- User-supplied BindFlag function, - -- for variables not in um_skols - } - -data UMState = UMState - { um_tv_env :: TvSubstEnv - , um_cv_env :: CvSubstEnv } - -newtype UM a - = UM' { unUM :: UMState -> UnifyResultM (UMState, a) } - -- See Note [The one-shot state monad trick] in GHC.Utils.Monad - -pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a --- See Note [The one-shot state monad trick] in GHC.Utils.Monad -pattern UM m <- UM' m - where - UM m = UM' (oneShot m) -{-# COMPLETE UM #-} - -instance Functor UM where - fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s)) - -instance Applicative UM where - pure a = UM (\s -> pure (s, a)) - (<*>) = ap - -instance Monad UM where - {-# INLINE (>>=) #-} - -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad - m >>= k = UM (\state -> - do { (state', v) <- unUM m state - ; unUM (k v) state' }) - -instance MonadFail UM where - fail _ = UM (\_ -> SurelyApart) -- failed pattern match - -initUM :: TvSubstEnv -- subst to extend - -> CvSubstEnv - -> UM a -> UnifyResultM a -initUM subst_env cv_subst_env um - = case unUM um state of - Unifiable (_, subst) -> Unifiable subst - MaybeApart r (_, subst) -> MaybeApart r subst - SurelyApart -> SurelyApart - where - state = UMState { um_tv_env = subst_env - , um_cv_env = cv_subst_env } - -tvBindFlag :: UMEnv -> OutTyVar -> Type -> BindFlag -tvBindFlag env tv rhs - | tv `elemVarSet` um_skols env = Apart - | otherwise = um_bind_fun env tv rhs - -getTvSubstEnv :: UM TvSubstEnv -getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) - -getCvSubstEnv :: UM CvSubstEnv -getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) - -getSubst :: UMEnv -> UM Subst -getSubst env = do { tv_env <- getTvSubstEnv - ; cv_env <- getCvSubstEnv - ; let in_scope = rnInScopeSet (um_rn_env env) - ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) } - -extendTvEnv :: TyVar -> Type -> UM () -extendTvEnv tv ty = UM $ \state -> - Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) - -extendCvEnv :: CoVar -> Coercion -> UM () -extendCvEnv cv co = UM $ \state -> - Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) - -umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv -umRnBndr2 env v1 v2 - = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } - where - (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 - -checkRnEnv :: UMEnv -> VarSet -> UM () -checkRnEnv env varset - | isEmptyVarSet skol_vars = return () - | varset `disjointVarSet` skol_vars = return () - | otherwise = surelyApart - where - skol_vars = um_skols env - -- NB: That isEmptyVarSet guard is a critical optimization; - -- it means we don't have to calculate the free vars of - -- the type, often saving quite a bit of allocation. - --- | Converts any SurelyApart to a MaybeApart -don'tBeSoSure :: MaybeApartReason -> UM () -> UM () -don'tBeSoSure r um = UM $ \ state -> - case unUM um state of - SurelyApart -> MaybeApart r (state, ()) - other -> other - -umRnOccL :: UMEnv -> TyVar -> TyVar -umRnOccL env v = rnOccL (um_rn_env env) v - -umRnOccR :: UMEnv -> TyVar -> TyVar -umRnOccR env v = rnOccR (um_rn_env env) v - -umSwapRn :: UMEnv -> UMEnv -umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } - -maybeApart :: MaybeApartReason -> UM () -maybeApart r = UM (\state -> MaybeApart r (state, ())) - -surelyApart :: UM a -surelyApart = UM (\_ -> SurelyApart) - -{- -%************************************************************************ -%* * - Matching a (lifted) type against a coercion -%* * -%************************************************************************ - -This section defines essentially an inverse to liftCoSubst. It is defined -here to avoid a dependency from Coercion on this module. - --} - -data MatchEnv = ME { me_tmpls :: TyVarSet - , me_env :: RnEnv2 } - --- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if --- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, --- where @==@ there means that the result of 'liftCoSubst' has the same --- type as the original co; but may be different under the hood. --- That is, it matches a type against a coercion of the same --- "shape", and returns a lifting substitution which could have been --- used to produce the given coercion from the given type. --- Note that this function is incomplete -- it might return Nothing --- when there does indeed exist a possible lifting context. --- --- This function is incomplete in that it doesn't respect the equality --- in `eqType`. That is, it's possible that this will succeed for t1 and --- fail for t2, even when t1 `eqType` t2. That's because it depends on --- there being a very similar structure between the type and the coercion. --- This incompleteness shouldn't be all that surprising, especially because --- it depends on the structure of the coercion, which is a silly thing to do. --- --- The lifting context produced doesn't have to be exacting in the roles --- of the mappings. This is because any use of the lifting context will --- also require a desired role. Thus, this algorithm prefers mapping to --- nominal coercions where it can do so. -liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext -liftCoMatch tmpls ty co - = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co - ; cenv2 <- ty_co_match menv cenv1 ty co - (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) - ; return (LC (mkEmptySubst in_scope) cenv2) } - where - menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } - in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) - -- Like tcMatchTy, assume all the interesting variables - -- in ty are in tmpls - - ki = typeKind ty - ki_co = promoteCoercion co - ki_ki_co = mkNomReflCo liftedTypeKind - - Pair co_lkind co_rkind = coercionKind ki_co - --- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -- ^ ambient helpful info - -> LiftCoEnv -- ^ incoming subst - -> Type -- ^ ty, type to match - -> Coercion -- ^ co :: lty ~r rty, coercion to match against - -> Coercion -- ^ :: kind(lsubst(ty)) ~N kind(lty) - -> Coercion -- ^ :: kind(rsubst(ty)) ~N kind(rty) - -> Maybe LiftCoEnv - -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles. - -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty, - -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env) -ty_co_match menv subst ty co lkco rkco - | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco - - -- handle Refl case: - | tyCoVarsOfType ty `isNotInDomainOf` subst - , Just (ty', _) <- isReflCo_maybe co - , ty `eqType` ty' - -- Why `eqType` and not `tcEqType`? Because this function is only used - -- during coercion optimisation, after type-checking has finished. - = Just subst - - where - isNotInDomainOf :: VarSet -> VarEnv a -> Bool - isNotInDomainOf set env - = noneSet (\v -> elemVarEnv v env) set - - noneSet :: (Var -> Bool) -> VarSet -> Bool - noneSet f = allVarSet (not . f) - -ty_co_match menv subst ty co lkco rkco - | CastTy ty' co' <- ty - -- See Note [Matching in the presence of casts (1)] - = let empty_subst = mkEmptySubst (rnInScopeSet (me_env menv)) - substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' - substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' - in - ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) - (substed_co_r `mkTransCo` rkco) - - | SymCo co' <- co - = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco - - -- Match a type variable against a non-refl coercion -ty_co_match menv subst (TyVarTy tv1) co lkco rkco - | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 - = if eqCoercionX (nukeRnEnvL rn_env) co1' co - then Just subst - else Nothing -- no match since tv1 matches two different coercions - - | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var - = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) - then Nothing -- occurs check failed - else Just $ extendVarEnv subst tv1' $ - castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) - - | otherwise - = Nothing - - where - rn_env = me_env menv - tv1' = rnOccL rn_env tv1 - - -- just look through SubCo's. We don't really care about roles here. -ty_co_match menv subst ty (SubCo co) lkco rkco - = ty_co_match menv subst ty co lkco rkco - -ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco - | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] -ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco - | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 - -- yes, the one from Type, not TcType; this is for coercion optimization - = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] - -ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco - = ty_co_match_tc menv subst tc1 tys tc2 cos - -ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) - (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco - = ty_co_match_args menv subst [w, rep1, rep2, ty1, ty2] - [co_w, co1_rep, co2_rep, co1, co2] - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - co1_rep = mkRuntimeRepCo co1 - co2_rep = mkRuntimeRepCo co2 - -- NB: we include the RuntimeRep arguments in the matching; - -- not doing so caused #21205. - -ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) - (ForAllCo tv2 kind_co2 co2) - lkco rkco - | isTyVar tv1 && isTyVar tv2 - = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 - ki_ki_co ki_ki_co - ; let rn_env0 = me_env menv - rn_env1 = rnBndr2 rn_env0 tv1 tv2 - menv' = menv { me_env = rn_env1 } - ; ty_co_match menv' subst1 ty1 co2 lkco rkco } - where - ki_ki_co = mkNomReflCo liftedTypeKind - --- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) --- (ForAllCo cv2 kind_co2 co2) --- lkco rkco --- | isCoVar cv1 && isCoVar cv2 --- We seems not to have enough information for this case --- 1. Given: --- cv1 :: (s1 :: k1) ~r (s2 :: k2) --- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) --- eta1 = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2) --- :: s1' ~ t1 --- eta2 = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2) --- :: s2' ~ t2 --- Wanted: --- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 --- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 --- Question: How do we get kcoi? --- 2. Given: --- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep --- rkco :: <*> --- Wanted: --- ty_co_match menv' subst2 ty1 co2 lkco' rkco' --- Question: How do we get lkco' and rkco'? - -ty_co_match _ subst (CoercionTy {}) _ _ _ - = Just subst -- don't inspect coercions - -ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco - = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) - -ty_co_match menv subst ty co1 lkco rkco - | Just (CastTy t co, r) <- isReflCo_maybe co1 - -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us - -- t |> co ~ t ; ; t ~ t |> co - -- But transitive coercions are not helpful. Therefore we deal - -- with it here: we do recursion on the smaller reflexive coercion, - -- while propagating the correct kind coercions. - = let kco' = mkSymCo co - in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') - (rkco `mkTransCo` kco') - -ty_co_match menv subst ty co lkco rkco - | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco - | otherwise = Nothing - -ty_co_match_tc :: MatchEnv -> LiftCoEnv - -> TyCon -> [Type] - -> TyCon -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_tc menv subst tc1 tys1 tc2 cos2 - = do { guard (tc1 == tc2) - ; ty_co_match_args menv subst tys1 cos2 } - -ty_co_match_app :: MatchEnv -> LiftCoEnv - -> Type -> [Type] -> Coercion -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_app menv subst ty1 ty1args co2 co2args - | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 - , Just (co2', co2a) <- splitAppCo_maybe co2 - = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) - - | otherwise - = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co - ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 - ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco - ; ty_co_match_args menv subst2 ty1args co2args } - where - ki1 = typeKind ty1 - ki2 = promoteCoercion co2 - ki_ki_co = mkNomReflCo liftedTypeKind - -ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] - -> Maybe LiftCoEnv -ty_co_match_args menv subst (ty:tys) (arg:args) - = do { let Pair lty rty = coercionKind arg - lkco = mkNomReflCo (typeKind lty) - rkco = mkNomReflCo (typeKind rty) - ; subst' <- ty_co_match menv subst ty arg lkco rkco - ; ty_co_match_args menv subst' tys args } -ty_co_match_args _ subst [] [] = Just subst -ty_co_match_args _ _ _ _ = Nothing - -pushRefl :: Coercion -> Maybe Coercion -pushRefl co = - case (isReflCo_maybe co) of - Just (AppTy ty1 ty2, Nominal) - -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) - Just (FunTy af w ty1 ty2, r) - -> Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2)) - Just (TyConApp tc tys, r) - -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys)) - Just (ForAllTy (Bndr tv _) ty, r) - -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) - -- NB: NoRefl variant. Otherwise, we get a loop! - _ -> Nothing - -{- -************************************************************************ -* * - Flattening -* * -************************************************************************ - -Note [Flattening type-family applications when matching instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in "Closed type families with overlapping equations" -http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf -we need to flatten core types before unifying them, when checking for "surely-apart" -against earlier equations of a closed type family. -Flattening means replacing all top-level uses of type functions with -fresh variables, *taking care to preserve sharing*. That is, the type -(Either (F a b) (F a b)) should flatten to (Either c c), never (Either -c d). - -Here is a nice example of why it's all necessary: - - type family F a b where - F Int Bool = Char - F a b = Double - type family G a -- open, no instances - -How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, -while the second equation does. But, before reducing, we must make sure that the -target can never become (F Int Bool). Well, no matter what G Float becomes, it -certainly won't become *both* Int and Bool, so indeed we're safe reducing -(F (G Float) (G Float)) to Double. - -This is necessary not only to get more reductions (which we might be -willing to give up on), but for substitutivity. If we have (F x x), we -can see that (F x x) can reduce to Double. So, it had better be the -case that (F blah blah) can reduce to Double, no matter what (blah) -is! Flattening as done below ensures this. - -We also use this flattening operation to check for class instances. -If we have - instance C (Maybe b) - instance {-# OVERLAPPING #-} C (Maybe Bool) - [W] C (Maybe (F a)) -we want to know that the second instance might match later. So we -flatten the (F a) in the target before trying to unify with instances. -(This is done in GHC.Core.InstEnv.lookupInstEnv'.) - -The algorithm works by building up a TypeMap TyVar, mapping -type family applications to fresh variables. This mapping must -be threaded through all the function calls, as any entry in -the mapping must be propagated to all future nodes in the tree. - -The algorithm also must track the set of in-scope variables, in -order to make fresh variables as it flattens. (We are far from a -source of fresh Uniques.) See Wrinkle 2, below. - -There are wrinkles, of course: - -1. The flattening algorithm must account for the possibility - of inner `forall`s. (A `forall` seen here can happen only - because of impredicativity. However, the flattening operation - is an algorithm in Core, which is impredicative.) - Suppose we have (forall b. F b) -> (forall b. F b). Of course, - those two bs are entirely unrelated, and so we should certainly - not flatten the two calls F b to the same variable. Instead, they - must be treated separately. We thus carry a substitution that - freshens variables; we must apply this substitution (in - `coreFlattenTyFamApp`) before looking up an application in the environment. - Note that the range of the substitution contains only TyVars, never anything - else. - - For the sake of efficiency, we only apply this substitution when absolutely - necessary. Namely: - - * We do not perform the substitution at all if it is empty. - * We only need to worry about the arguments of a type family that are within - the arity of said type family, so we can get away with not applying the - substitution to any oversaturated type family arguments. - * Importantly, we do /not/ achieve this substitution by recursively - flattening the arguments, as this would be wrong. Consider `F (G a)`, - where F and G are type families. We might decide that `F (G a)` flattens - to `beta`. Later, the substitution is non-empty (but does not map `a`) and - so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course, - `F gamma` is unknown, and so we flatten it to `delta`, but it really - should have been `beta`! Argh! - - Moral of the story: instead of flattening the arguments, just substitute - them directly. - -2. There are two different reasons we might add a variable - to the in-scope set as we work: - - A. We have just invented a new flattening variable. - B. We have entered a `forall`. - - Annoying here is that in-scope variable source (A) must be - threaded through the calls. For example, consider (F b -> forall c. F c). - Suppose that, when flattening F b, we invent a fresh variable c. - Now, when we encounter (forall c. F c), we need to know c is already in - scope so that we locally rename c to c'. However, if we don't thread through - the in-scope set from one argument of (->) to the other, we won't know this - and might get very confused. - - In contrast, source (B) increases only as we go deeper, as in-scope sets - normally do. However, even here we must be careful. The TypeMap TyVar that - contains mappings from type family applications to freshened variables will - be threaded through both sides of (forall b. F b) -> (forall b. F b). We - thus must make sure that the two `b`s don't get renamed to the same b1. (If - they did, then looking up `F b1` would yield the same flatten var for - each.) So, even though `forall`-bound variables should really be in the - in-scope set only when they are in scope, we retain these variables even - outside of their scope. This ensures that, if we encounter a fresh - `forall`-bound b, we will rename it to b2, not b1. Note that keeping a - larger in-scope set than strictly necessary is always OK, as in-scope sets - are only ever used to avoid collisions. - - Sadly, the freshening substitution described in (1) really mustn't bind - variables outside of their scope: note that its domain is the *unrenamed* - variables. This means that the substitution gets "pushed down" (like a - reader monad) while the in-scope set gets threaded (like a state monad). - Because a Subst contains its own in-scope set, we don't carry a Subst; - instead, we just carry a TvSubstEnv down, tying it to the InScopeSet - traveling separately as necessary. - -3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k: - - type family F ty_1 ... ty_k :: res_k - - It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a - flattening skolem. But we must instead flatten it to - `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the - type family. - - Why is this better? Consider the following concrete example from #16995: - - type family Param :: Type -> Type - - type family LookupParam (a :: Type) :: Type where - LookupParam (f Char) = Bool - LookupParam x = Int - - foo :: LookupParam (Param ()) - foo = 42 - - In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to - `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if - `alpha` is apart from `f Char`, so it won't fall through to the second - equation. But since the `Param` type family has arity 0, we can instead - flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is - apart from `f Char`, permitting the second equation to be reached. - - Not only does this allow more programs to be accepted, it's also important - for correctness. Not doing this was the root cause of the Core Lint error - in #16995. - -flattenTys is defined here because of module dependencies. --} - -data FlattenEnv - = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type]) - -- domain: exactly-saturated type family applications - -- range: (fresh variable, type family tycon, args) - , fe_in_scope :: InScopeSet } - -- See Note [Flattening type-family applications when matching instances] - -emptyFlattenEnv :: InScopeSet -> FlattenEnv -emptyFlattenEnv in_scope - = FlattenEnv { fe_type_map = emptyTypeMap - , fe_in_scope = in_scope } - -updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv -updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) } - -flattenTys :: InScopeSet -> [Type] -> [Type] --- See Note [Flattening type-family applications when matching instances] -flattenTys in_scope tys = fst (flattenTysX in_scope tys) - -flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type])) --- See Note [Flattening type-family applications when matching instances] --- NB: the returned types mention the fresh type variables --- in the domain of the returned env, whose range includes --- the original type family applications. Building a substitution --- from this information and applying it would yield the original --- types -- almost. The problem is that the original type might --- have something like (forall b. F a b); the returned environment --- can't really sensibly refer to that b. So it may include a locally- --- bound tyvar in its range. Currently, the only usage of this env't --- checks whether there are any meta-variables in it --- (in GHC.Tc.Solver.Monad.mightEqualLater), so this is all OK. -flattenTysX in_scope tys - = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in - (result, build_env (fe_type_map env)) - where - build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type]) - build_env env_in - = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys)) - env_in emptyVarEnv - -coreFlattenTys :: TvSubstEnv -> FlattenEnv - -> [Type] -> (FlattenEnv, [Type]) -coreFlattenTys subst = mapAccumL (coreFlattenTy subst) - -coreFlattenTy :: TvSubstEnv -> FlattenEnv - -> Type -> (FlattenEnv, Type) -coreFlattenTy subst = go - where - go env ty | Just ty' <- coreView ty = go env ty' - - go env (TyVarTy tv) - | Just ty <- lookupVarEnv subst tv = (env, ty) - | otherwise = let (env', ki) = go env (tyVarKind tv) in - (env', mkTyVarTy $ setTyVarKind tv ki) - go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, AppTy ty1' ty2') - go env (TyConApp tc tys) - -- NB: Don't just check if isFamilyTyCon: this catches *data* families, - -- which are generative and thus can be preserved during flattening - | not (isGenerativeTyCon tc Nominal) - = coreFlattenTyFamApp subst env tc tys - - | otherwise - = let (env', tys') = coreFlattenTys subst env tys in - (env', mkTyConApp tc tys') - - go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) - = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 - (env3, mult') = go env2 mult in - (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' }) - - go env (ForAllTy (Bndr tv vis) ty) - = let (env1, subst', tv') = coreFlattenVarBndr subst env tv - (env2, ty') = coreFlattenTy subst' env1 ty in - (env2, ForAllTy (Bndr tv' vis) ty') - - go env ty@(LitTy {}) = (env, ty) - - go env (CastTy ty co) - = let (env1, ty') = go env ty - (env2, co') = coreFlattenCo subst env1 co in - (env2, CastTy ty' co') - - go env (CoercionTy co) - = let (env', co') = coreFlattenCo subst env co in - (env', CoercionTy co') - - --- when flattening, we don't care about the contents of coercions. --- so, just return a fresh variable of the right (flattened) type -coreFlattenCo :: TvSubstEnv -> FlattenEnv - -> Coercion -> (FlattenEnv, Coercion) -coreFlattenCo subst env co - = (env2, mkCoVarCo covar) - where - (env1, kind') = coreFlattenTy subst env (coercionType co) - covar = mkFlattenFreshCoVar (fe_in_scope env1) kind' - -- Add the covar to the FlattenEnv's in-scope set. - -- See Note [Flattening type-family applications when matching instances], wrinkle 2A. - env2 = updateInScopeSet env1 (flip extendInScopeSet covar) - -coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv - -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar) -coreFlattenVarBndr subst env tv - = (env2, subst', tv') - where - -- See Note [Flattening type-family applications when matching instances], wrinkle 2B. - kind = varType tv - (env1, kind') = coreFlattenTy subst env kind - tv' = uniqAway (fe_in_scope env1) (setVarType tv kind') - subst' = extendVarEnv subst tv (mkTyVarTy tv') - env2 = updateInScopeSet env1 (flip extendInScopeSet tv') - -coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv - -> TyCon -- type family tycon - -> [Type] -- args, already flattened - -> (FlattenEnv, Type) -coreFlattenTyFamApp tv_subst env fam_tc fam_args - = case lookupTypeMap type_map fam_ty of - Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args') - Nothing -> - let tyvar_name = mkFlattenFreshTyName fam_tc - tv = uniqAway in_scope $ - mkTyVar tyvar_name (typeKind fam_ty) - - ty' = mkAppTys (mkTyVarTy tv) leftover_args' - env'' = env' { fe_type_map = extendTypeMap type_map fam_ty - (tv, fam_tc, sat_fam_args) - , fe_in_scope = extendInScopeSet in_scope tv } - in (env'', ty') - where - arity = tyConArity fam_tc - tcv_subst = Subst (fe_in_scope env) emptyIdSubstEnv tv_subst emptyVarEnv - (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $ - splitAt arity fam_args - -- Apply the substitution before looking up an application in the - -- environment. See Note [Flattening type-family applications when matching instances], - -- wrinkle 1. - -- NB: substTys short-cuts the common case when the substitution is empty. - sat_fam_args' = substTys tcv_subst sat_fam_args - (env', leftover_args') = coreFlattenTys tv_subst env leftover_args - -- `fam_tc` may be over-applied to `fam_args` (see - -- Note [Flattening type-family applications when matching instances] - -- wrinkle 3), so we split it into the arguments needed to saturate it - -- (sat_fam_args') and the rest (leftover_args') - fam_ty = mkTyConApp fam_tc sat_fam_args' - FlattenEnv { fe_type_map = type_map - , fe_in_scope = in_scope } = env' - -mkFlattenFreshTyName :: Uniquable a => a -> Name -mkFlattenFreshTyName unq - = mkSysTvName (getUnique unq) (fsLit "flt") - -mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar -mkFlattenFreshCoVar in_scope kind - = let uniq = unsafeGetFreshLocalUnique in_scope - name = mkSystemVarName uniq (fsLit "flc") - in mkCoVar name kind - + tcUnifyTy, tcUnifyTys, tcUnifyFunDeps, tcUnifyDebugger, + tcUnifyTysFG, tcUnifyTyForInjectivity, + BindTvFun, BindFamFun, BindFlag(..), + matchBindTv, alwaysBindTv, alwaysBindFam, dontCareBindFam, + UnifyResult, UnifyResultM(..), MaybeApartReason(..), + typesCantMatch, typesAreApart, + + -- Matching a type against a lifted type (coercion) + liftCoMatch + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey ) +import GHC.Core.Type hiding ( getTvSubstEnv ) +import GHC.Core.Coercion hiding ( getCvSubstEnv ) +import GHC.Core.Predicate( scopedSort ) +import GHC.Core.TyCon +import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe ) +import GHC.Core.TyCon.Env +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs ) +import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) +import GHC.Core.TyCo.Subst ( mkTvSubst ) +import GHC.Core.Map.Type +import GHC.Core.Multiplicity + +import GHC.Utils.FV( FV, fvVarList ) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Types.Basic( SwapFlag(..) ) +import GHC.Types.Unique.FM +import GHC.Exts( oneShot ) +import GHC.Utils.Panic + +import GHC.Data.Pair +import GHC.Data.TrieMap +import GHC.Data.Maybe( orElse ) + +import Control.Monad +import qualified Data.Semigroup as S +import GHC.Builtin.Types.Prim (fUNTyCon) + +{- Note [The Core unifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module contains the (pure) unifier two types. It is subtle in a number +of ways. Here we summarise, but see Note [Specification of unification]. + +(CU1) It creates a substition only for "bindable" or "template" type variables. + These are identified by a `um_bind_tv_fun` function passed down in the `UMEnv` + environment. + +(CU2) We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + That is what the `um_rn_env :: RnEnv2` field of `UMEnv` is for; it does the + alpha-renaming that makes it as if `a` and `b` were the same variable. + Initialising the `RnEnv2`, so that it can generate a fresh binder when + necessary, entails knowing the free variables of both types. + + Of course, we must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where `x` is the template type variable. Then we do not want to + bind `x` to a/b! See `mentionsForAllBoundTyVarsL/R`. + +(CU3) We want to take special care for type families. + See the big Note [Apartness and type families] + +(CU4) Rather than returning just "unifiable" or "not-unifiable" we do "fine-grained" + unification (hence "fg" or "FG" in this module) returning three possiblities, + captured in `UnifyResult`: + - Unifiable subst : certainly unifiable with this type substitution + - SurelyApart : cannot be unifiable, regardless of how type familes reduce + - MaybeApart : neither of the above + See Note [Unification result]. + + Four reasons for MaybeApart (see `MaybeApartReason`). The first two are the + big ones! + * MARTypeFamily: + Family reduction might make the two types equal + Maybe (F Int) ~ Maybe Bool + See Note [Apartness and type families] + * MARInfinite (occurs check): + See Note [Infinitary substitutions] + * MARTypeVsConstraint: + See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + * MARCast (obscure): + See (KCU2) in Note [Kind coercions in Unify] + +(CU5) We need to take care with kinds. See Note [tcMatchTy vs tcMatchTyKi] + +(CU6) The "unifier" can also do /matching/, governed by `um_unif :: AmIUnifying`. + When matching, the LHS and RHS namespaces are unrelated. In particular, the + bindable type variable can occur (unrelatedly) in the RHS. E.g. + match (a,Maybe a) ~ ([a], Maybe [a]) + We get the substitution [a :-> [a]], without confusing the + LHS `a` with the RHS `a`. The substitition is "one-shot", and should not be + iterated. + +Note [Infinitary substitutions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. This is the famous +"occurs check". + +But, a substitution to *infinite* types can unify these two types: + [x |-> [[...]]], y |-> [[[...]]] ]. + +Why do we care? Consider these two type family instances: + + type instance F x x = Int + type instance F [y] y = Bool + +If we also have + + type instance Looper = [Looper] + +then the instances potentially overlap -- they are not "apart". So we must +distinguish failure-to-unify from definitely-apart. The solution is to use +unification over infinite terms. This is possible (see [1] for lots of gory +details), but a full algorithm is a little more powerful than we need. Instead, +we make a conservative approximation and just omit the occurs check. + + [1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +See also #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [tcMatchTy vs tcMatchTyKi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module offers two variants of matching: with kinds and without. +The TyKi variant takes two types, of potentially different kinds, +and matches them. Along the way, it necessarily also matches their +kinds. The Ty variant instead assumes that the kinds are already +eqType and so skips matching up the kinds. + +How do you choose between them? + +1. If you know that the kinds of the two types are eqType, use + the Ty variant. It is more efficient, as it does less work. + +2. If the kinds of variables in the template type might mention type families, + use the Ty variant (and do other work to make sure the kinds + work out). These pure unification functions do a straightforward + syntactic unification and do no complex reasoning about type + families. Note that the types of the variables in instances can indeed + mention type families, so instance lookup must use the Ty variant. + + (Nothing goes terribly wrong -- no panics -- if there might be type + families in kinds in the TyKi variant. You just might get match + failure even though a reducing a type family would lead to success.) + +3. Otherwise, if you're sure that the variable kinds do not mention + type families and you're not already sure that the kind of the template + equals the kind of the target, then use the TyKi version. + +Note [Unification result] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See `UnifyResult` and `UnifyResultM`. When unifying t1 ~ t2, we return +* Unifiable s, if s is a substitution such that s(t1) is syntactically the + same as s(t2), modulo type-synonym expansion. +* SurelyApart, if there is no substitution s such that s(t1) = s(t2), + where "=" includes type-family reductions. +* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason. + +Examples +* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify + +* [(a,Int)] ~ [(Bool,b)]: Unifiable + +* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool + (the unifier does not try this) + +* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart + either; consider + a := Loop + where type family Loop where Loop = Maybe Loop + +Wrinkle (UR1): see `combineMAR` + There is the possibility that two types are MaybeApart for *both* reasons: + + * (a, F Int) ~ (Maybe a, Bool) + + What reason should we use? The *only* consumer of the reason is described + in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal + there is identify which instances might match a target later (but don't + match now) -- except that we want to ignore the possibility of infinitary + substitutions. So let's examine a concrete scenario: + + class C a b c + instance C a (Maybe a) Bool + -- other instances, including one that will actually match + [W] C b b (F Int) + + Do we want the instance as a future possibility? No. The only way that + instance can match is in the presence of an infinite type (infinitely nested + Maybes). We thus say that `MARInfinite` takes precedence, so that InstEnv treats + this case as an infinitary substitution case; the fact that a type family is + involved is only incidental. We thus define `combineMAR` to prefer + `MARInfinite`. + +Note [Apartness and type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a b where + F Int Bool = Char + F a b = Double + type family G a -- open, no instances + +How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't +match immediately while the second equation does. But, before reducing, we must +make sure that the target can never become (F Int Bool). Well, no matter what G +Float becomes, it certainly won't become *both* Int and Bool, so indeed we're +safe reducing (F (G Float) (G Float)) to Double. + +So we must say that the argument list + (G Float) (G Float) is SurelyApart from Int Bool + +This is necessary not only to get more reductions (which we might be willing to +give up on), but for /substitutivity/. If we have (F x x), we can see that (F x x) +can reduce to Double. So, it had better be the case that (F blah blah) can +reduce to Double, no matter what (blah) is! + +To achieve this, `go` in `uVarOrFam` does this; + +* We maintain /two/ substitutions, not just one: + * um_tv_env: the regular substitution, mapping TyVar :-> Type + * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application + In effect, these constitute one substitution mapping + CanEqLHS :-> Types + +* When we attempt to unify (G Float) ~ Int, we return MaybeApart.. + but we /also/ add a "family substitution" [G Float :-> Int], + to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`. + +* When we later encounter (G Float) ~ Bool, we apply the family substitution, + very much as we apply the conventional [tyvar :-> type] substitution + when we encounter a type variable. See the `lookupFamEnv` in `go` in + `uVarOrFam`. + + So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart. Bingo. + + +Wrinkles + +(ATF0) Once we encounter a type-family application, we only ever return + MaybeApart or SurelyApart + but never `Unifiable`. Accordingly, we only return a TyCoVar substitution + from `tcUnifyTys` and friends; we don't return a type-family substitution as + well. (We could imagine doing so, though.) + +(ATF1) Exactly the same mechanism is used in class-instance checking. + If we have + instance C (Maybe b) + instance {-# OVERLAPPING #-} C (Maybe Bool) + [W] C (Maybe (F a)) + we want to know that the second instance might match later, when we know more about `a`. + The function `GHC.Core.InstEnv.instEnvMatchesAndUnifiers` uses `tcUnifyTysFG` to + account for type families in the type being matched. + +(ATF2) A very similar check is made in `GHC.Tc.Utils.Unify.mightEqualLater`, which + again uses `tcUnifyTysFG` to account for the possibility of type families. See + Note [What might equal later?] in GHC.Tc.Utils.Unify, esp example (10). + +(ATF3) What about foralls? For example, supppose we are unifying + (forall a. F a) -> (forall a. F a) + against some other type. Those two (F a) types are unrelated, bound by + different foralls; we cannot extend the um_fam_env with a binding [F a :-> blah] + + So to keep things simple, the entire family-substitution machinery is used + only if there are no enclosing foralls (see the `under_forall` check in + `uSatFamApp`). That's fine, because the apartness business is used only for + reducing type-family applications, and class instances, and their arguments + can't have foralls anyway. + + The bottom line is that we won't discover that + (forall a. (a, F Int, F Int)) + is surely apart from + (forall a. (a, Int, Bool)) + but that doesn't matter. Fixing this would be possible, but would require + quite a bit of head-scratching. + +(ATF4) The family substitution only has /saturated/ family applications in + its domain. Consider the following concrete example from #16995: + + type family Param :: Type -> Type -- arity 0 + + type family LookupParam (a :: Type) :: Type where + LookupParam (f Char) = Bool + LookupParam x = Int + + foo :: LookupParam (Param ()) + foo = 42 + + In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to + `Int`. So (f Char) ~ (Param ()) must be SurelyApart. Remember, since + `Param` is a nullary type family, it is over-saturated in (Param ()). + This unification will only be SurelyApart if we decompose the outer AppTy + separately, to then give (() ~ Char). + + Not only does this allow more programs to be accepted, it's also important + for correctness. Not doing this was the root cause of the Core Lint error + in #16995. + +(ATF5) Consider + instance (Generic1 f, Ord (Rep1 f a)) + => Ord (Generically1 f a) where ... + -- The "..." gives rise to [W] Ord (Generically1 f a) + where Rep1 is a type family. + + We must use the instance decl (recursively) to simplify the [W] constraint; + we do /not/ want to worry that the `[G] Ord (Rep1 f a)` might be an + alternative path. So `noMatchableGivenDicts` must return False; + so `mightMatchLater` must return False; so when um_bind_fam_fun returns + `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`. See + `go` in `uVarOrFam` + + This looks a bit sketchy, because they aren't SurelyApart, but see + Note [What might equal later?] in GHC.Tc.Utils.Unify, esp "Red Herring". + + If we are under a forall, we return `MaybeApart`; that seems more conservative, + and class constraints are on tau-types so it doesn't matter. + +(ATF6) When /matching/ can we ever have a type-family application on the LHS, in + the template? You might think not, because type-class-instance and + type-family-instance heads can't include type families. E.g. + instance C (F a) where ... -- Illegal + + But you'd be wrong: even when matching, we can see type families in the LHS template: + * In `checkValidClass`, in `check_dm` we check that the default method has the + right type, using matching, both ways. And that type may have type-family + applications in it. Examples in test CoOpt_Singletons and T26457. + + * In the specialiser: see the call to `tcMatchTy` in + `GHC.Core.Opt.Specialise.beats_or_same` + + * With -fpolymorphic-specialisation, we might get a specialiation rule like + RULE forall a (d :: Eq (Maybe (F a))) . + f @(Maybe (F a)) d = ... + See #25965. + + * A user-written RULE could conceivably have a type-family application + in the template. It might not be a good rule, but I don't think we currently + check for this. + + In all these cases we are only interested in finding a substitution /for + type variables/ that makes the match work. So we simply want to recurse into + the arguments of the type family. E.g. + Template: forall a. Maybe (F a) + Target: Maybe (F Int) + We want to succeed with substitution [a :-> Int]. See (ATF9). + + Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`, + etc, we always end up in `tc_match_tys_x`. There we invoke the unifier + but we do not distinguish between `SurelyApart` and `MaybeApart`. So in + these cases we can set `um_bind_fam_fun` to `neverBindFam`. + +(ATF7) There is one other, very special case of matching where we /do/ want to + bind type families in `um_fam_env`, namely in GHC.Tc.Solver.Equality, the call + to `tcUnifyTyForInjectivity False` in `improve_injective_wanted_top`. + Consider + of a match. Consider + type family G6 a = r | r -> a + type instance G6 [a] = [G a] + type instance G6 Bool = Int + and suppose we have a Wanted constraint + [W] G6 alpha ~ [Int] + According to Section 5.2 of "Injective type families for Haskell", we /match/ + the RHS each of type instance with [Int]. So we try + Template: [G a] Target: [Int] + and we want to succeed with MaybeApart, so that we can generate the improvement + constraint + [W] alpha ~ [beta] + where beta is fresh. We do this by binding [G a :-> Int] + +(ATF8) The treatment of type families is governed by + um_bind_fam_fun :: BindFamFun + in UMEnv, where + type BindFamFun = TyCon -> [Type] -> Type -> BindFlag + There are some simple BindFamFun functions provided: + alwaysBindFam do the clever stuff above + neverBindFam treat type families as SurelyApart + dontCareBindFam type families shouldn't exist at all + This function only affects the difference between the results MaybeApart and + SurelyApart; it never does not affect whether or not we return Unifiable. + +(ATF9) Decomposition. Consider unifying + F a ~ F Int + when `um_bind_fam_fun` says DontBindMe. There is a unifying substitition [a :-> Int], + and we want to find it, returning Unifiable. Why? + - Remember, this is the Core unifier -- we are not doing type inference + - When we have two equal types, like F a ~ F a, it is ridiculous to say that they + are MaybeApart. Example: the two-way tcMatchTy in `checkValidClass` and #26457. + + (ATF9-1) But consider unifying + F Int ~ F Bool + Although Int and Bool are SurelyApart, we must return MaybeApart for the outer + unification. Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable + alone, but weakens `SurelyApart` to `MaybeApart`. + + (ATF9-2) We want this decomposition to occur even under a forall (this was #26457). + E.g. (forall a. F Int) -> Int ~ (forall a. F Int) ~ Int + + +(ATF10) Injectivity. Consider (AFT9) where F is known to be injective. Then if we + are unifying + F Int ~ F Bool + we /can/ say SurelyApart. See the inj/noninj stuff in `go_fam_fam`. + +(ATF11) Consider unifying + [F Int, F Int, F Bool] ~ [F Bool, Char, Double] + We find (F Int ~ F Bool), so we can decompose. But we /also/ want to remember + the substitution [F Int :-> F Bool]. Then from (F Int ~ Char) we get the + substitution [F Bool :-> Char]. And that flat-out contradicts (F Bool ~ Double) + so we should get SurelyApart. + + Key point: when decomposing (F tys1 ~ F tys2), we should /also/ extend the + type-family substitution. + + (ATF11-1) All this cleverness only matters when unifying, not when matching + +(ATF12) There is a horrid exception for the injectivity check. See (UR1) in + in Note [Specification of unification]. + +(ATF13) We have to be careful about the occurs check. + See Note [The occurs check in the Core unifier] + +SIDE NOTE. The paper "Closed type families with overlapping equations" +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +tries to achieve the same effect with a standard yes/no unifier, by "flattening" +the types (replacing each type-family application with a fresh type variable) +and then unifying. But that does not work well. Consider (#25657) + + type MyEq :: k -> k -> Bool + type family MyEq a b where + MyEq a a = 'True + MyEq _ _ = 'False + + type Var :: forall {k}. Tag -> k + type family Var tag = a | a -> tag + +Then, because Var is injective, we want + MyEq (Var A) (Var B) --> False + MyEq (Var A) (Var A) --> True + +But if we flattten the types (Var A) and (Var B) we'll just get fresh type variables, +and all is lost. But with the current algorithm we have that + a a ~ (Var A) (Var B) +is SurelyApart, so the first equation definitely doesn't match and we can try the +second, which does. END OF SIDE NOTE. + +Note [Shortcomings of the apartness test] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Apartness and type families] is very clever. + +But it still has shortcomings (#26358). Consider unifying + [F a, F Int, Int] ~ [Bool, Char, a] +Working left to right you might think we would build the mapping + F a :-> Bool + F Int :-> Char +Now we discover that `a` unifies with `Int`. So really these two lists are Apart +because F Int can't be both Bool and Char. + +Just the same applies when adding a type-family binding to um_fam_env: + [F (G Float), F Int, G Float] ~ [Bool, Char, Iont] +Again these are Apart, because (G Float = Int), +and (F Int) can't be both Bool and Char + +But achieving this is very tricky! Perhaps whenever we unify a type variable, +or a type family, we should run it over the domain and (maybe range) of the +type-family mapping too? Sigh. + +For now we make no such attempt. +* The um_fam_env has only /un-substituted/ types. +* We look up only /un-substituted/ types in um_fam_env + +This may make us say MaybeApart when we could say SurelyApart, but it has no +effect on the correctness of unification: if we return Unifiable, it really is +Unifiable. + +This is all quite subtle. suppose we have: + um_tv_env: c :-> b + um_fam_env F b :-> a +and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will +fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq, +getting: + um_tv_env: a :-> F c, c :-> b + um_fam_env F b :-> a + +Does that loop, like this: + a --> F c --> F b --> a? +No, because we do not substitute (F c) to (F b) and then look up in um_fam_env; +we look up only un-substituted types. +-} + +{- ********************************************************************* +* * + Binding decisions +* * +********************************************************************* -} + +data BindFlag + = BindMe -- ^ A bindable type variable + + | DontBindMe -- ^ Do not bind this type variable is /apart/ + -- See also Note [Super skolems: binding when looking up instances] + -- in GHC.Core.InstEnv. + deriving Eq + +-- | Some unification functions are parameterised by a 'BindTvFun', which +-- says whether or not to allow a certain unification to take place. +-- A 'BindTvFun' takes the 'TyVar' involved along with the 'Type' it will +-- potentially be bound to. +-- +-- It is possible for the variable to actually be a coercion variable +-- (Note [Matching coercion variables]), but only when one-way matching. +-- In this case, the 'Type' will be a 'CoercionTy'. +type BindTvFun = TyCoVar -> Type -> BindFlag + +-- | BindFamFun is similiar to BindTvFun, but deals with a saturated +-- type-family application. See Note [Apartness and type families]. +type BindFamFun = TyCon -> [Type] -> Type -> BindFlag + +-- | Allow binding only for any variable in the set. Variables may +-- be bound to any type. +-- Used when doing simple matching; e.g. can we find a substitution +-- +-- @ +-- S = [a :-> t1, b :-> t2] such that +-- S( Maybe (a, b->Int ) = Maybe (Bool, Char -> Int) +-- @ +matchBindTv :: TyCoVarSet -> BindTvFun +matchBindTv tvs tv _ty + | tv `elemVarSet` tvs = BindMe + | otherwise = DontBindMe + +-- | Allow the binding of any variable to any type +alwaysBindTv :: BindTvFun +alwaysBindTv _tv _ty = BindMe + +-- | Allow the binding of a type-family application to any type +alwaysBindFam :: BindFamFun +-- See (ATF8) in Note [Apartness and type families] +alwaysBindFam _tc _args _rhs = BindMe + +dontCareBindFam :: HasCallStack => BindFamFun +-- See (ATF8) in Note [Apartness and type families] +dontCareBindFam tc args rhs + = pprPanic "dontCareBindFam" $ + vcat [ ppr tc <+> ppr args, text "rhs" <+> ppr rhs ] + +-- | Don't allow the binding of a type-family application at all +neverBindFam :: BindFamFun +-- See (ATF8) in Note [Apartness and type families] +neverBindFam _tc _args _rhs = DontBindMe + + +{- ********************************************************************* +* * + Various wrappers for matching +* * +********************************************************************* -} + +-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) +-- @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might bind coercion variables, +-- if the variable is an argument to a GADT constructor. +-- +-- Precondition: typeKind ty1 `eqType` typeKind ty2 +-- +-- We don't pass in a set of "template variables" to be bound +-- by the match, because tcMatchTy (and similar functions) are +-- always used on top-level types, so we can bind any of the +-- free variables of the LHS. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTy :: HasDebugCallStack => Type -> Type -> Maybe Subst +tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] + +tcMatchTyX_BM :: HasDebugCallStack + => BindTvFun -> Subst + -> Type -> Type -> Maybe Subst +tcMatchTyX_BM bind_tv subst ty1 ty2 + = tc_match_tys_x bind_tv False subst [ty1] [ty2] + +-- | Like 'tcMatchTy', but allows the kinds of the types to differ, +-- and thus matches them as well. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKi :: HasDebugCallStack => Type -> Type -> Maybe Subst +tcMatchTyKi ty1 ty2 + = tc_match_tys alwaysBindTv True [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyX :: HasDebugCallStack + => Subst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe Subst +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x alwaysBindTv False subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTys :: HasDebugCallStack + => [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot; in principle the template + -- variables could be free in the target + -- See (CU6) in Note [The Core unifier] +tcMatchTys tys1 tys2 + = tc_match_tys alwaysBindTv False tys1 tys2 + +-- | Like 'tcMatchTyKi' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKis :: HasDebugCallStack + => [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot substitution + -- See (CU6) in Note [The Core unifier] +tcMatchTyKis tys1 tys2 + = tc_match_tys alwaysBindTv True tys1 tys2 + +-- | Like 'tcMatchTys', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTysX :: HasDebugCallStack + => Subst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot substitution +tcMatchTysX subst tys1 tys2 + = tc_match_tys_x alwaysBindTv False subst tys1 tys2 + +-- | Like 'tcMatchTyKis', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKisX :: HasDebugCallStack + => Subst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe Subst -- ^ One-shot substitution +tcMatchTyKisX subst tys1 tys2 + = tc_match_tys_x alwaysBindTv True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: HasDebugCallStack + => BindTvFun + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe Subst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + +-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' +tc_match_tys_x :: HasDebugCallStack + => BindTvFun + -> Bool -- ^ match kinds? + -> Subst + -> [Type] + -> [Type] + -> Maybe Subst +tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2 + = case tc_unify_tys neverBindFam -- (ATF7) in Note [Apartness and type families] + bind_tv + False -- Matching, not unifying + False -- Not an injectivity check + match_kis + RespectMultiplicities + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ Subst in_scope id_env tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyKiX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys neverBindFam (matchBindTv tmpl_tvs) + -- neverBindFam: a type family probably shouldn't appear + -- on the LHS of a RULE, although we don't currently prevent it. + -- But even if it did, (ATF8) in Note [Apartness and type families] + -- says it doesn't matter becuase here we only care about Unifiable. + -- So neverBindFam is efficient, and sufficient. + False -- Matching, not unifying + False -- No doing an injectivity check + True -- Match the kinds + IgnoreMultiplicities + -- See Note [Rewrite rules ignore multiplicities in FunTy] + rn_env tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +We see here that we want precisely the apartness check implemented within +tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely +apart. Note that since we are simply dropping dead code, a conservative test +suffices. +-} + +-- | Given a list of pairs of types, are any two members of a pair surely +-- apart, even after arbitrary type function evaluation and substitution? +typesCantMatch :: [(Type,Type)] -> Bool +-- See Note [Pruning dead case alternatives] +typesCantMatch prs = any (uncurry typesAreApart) prs + +typesAreApart :: Type -> Type -> Bool +typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFam alwaysBindTv [t1] [t2] of + SurelyApart -> True + _ -> False +{- +************************************************************************ +* * + Various wrappers for unification +* * +********************************************************************* -} + +-- | Simple unification of two types; all type variables are bindable +-- Precondition: the kinds are already equal +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe Subst + -- A regular one-shot (idempotent) substitution +tcUnifyTy t1 t2 = tcUnifyTys alwaysBindTv [t1] [t2] + +tcUnifyDebugger :: Type -> Type -> Maybe Subst +tcUnifyDebugger t1 t2 + = case tc_unify_tys_fg + True -- Unify kinds + neverBindFam -- Does not affect Unifiable, so pick max efficient + -- See (ATF8) in Note [Apartness and type families] + alwaysBindTv + [t1] [t2] of + Unifiable subst -> Just subst + _ -> Nothing + +-- | Like 'tcUnifyTys' but also unifies the kinds +tcUnifyFunDeps :: TyCoVarSet + -> [Type] -> [Type] + -> Maybe Subst +tcUnifyFunDeps qtvs tys1 tys2 + = case tc_unify_tys_fg + True -- Unify kinds + dontCareBindFam -- Class-instance heads never mention type families + (matchBindTv qtvs) + tys1 tys2 of + Unifiable subst -> Just subst + _ -> Nothing + +-- | Unify or match a type-family RHS with a type (possibly another type-family RHS) +-- Precondition: kinds are the same +tcUnifyTyForInjectivity + :: AmIUnifying -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> InScopeSet -- Should include the free tyvars of both Type args + -> Type -> Type -- Types to unify + -> Maybe Subst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyForInjectivity unif in_scope t1 t2 + = case tc_unify_tys alwaysBindFam alwaysBindTv + unif -- Am I unifying? + True -- Do injectivity checks + False -- Don't check outermost kinds + RespectMultiplicities + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst + MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst + -- We want to *succeed* in questionable cases. + -- This is a pre-unification algorithm. + SurelyApart -> Nothing + where + rn_env = mkRnEnv2 in_scope + + maybe_fix | unif = niFixSubst in_scope + | otherwise = mkTvSubst in_scope -- when matching, don't confuse + -- domain with range + +----------------- +tcUnifyTys :: BindTvFun + -> [Type] -> [Type] + -> Maybe Subst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG neverBindFam bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- | (tcUnifyTysFG bind_fam bind_tv tys1 tys2) does "fine-grain" unification +-- of tys1 and tys2, under the control of `bind_fam` and `bind_tv`. +-- This version requires that the kinds of the types are the same, +-- if you unify left-to-right. +-- See Note [The Core unifier] +tcUnifyTysFG :: BindFamFun -> BindTvFun + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fam bind_tv tys1 tys2 + = tc_unify_tys_fg False bind_fam bind_tv tys1 tys2 + +tc_unify_tys_fg :: Bool + -> BindFamFun -> BindTvFun + -> [Type] -> [Type] + -> UnifyResult +tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2 + = do { (tv_env, _) <- tc_unify_tys bind_fam bind_tv + True -- Unifying + False -- Not doing an injectivity check + match_kis -- Match outer kinds + RespectMultiplicities rn_env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixSubst in_scope tv_env } + where + in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + rn_env = mkRnEnv2 in_scope + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: BindFamFun -> BindTvFun + -> AmIUnifying -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> Bool -- ^ True <=> treat the kinds as well + -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then +-- the kinds of the types should be the same. However, this doesn't work, +-- as the types may be a dependent telescope, where later types have kinds +-- that mention variables occurring earlier in the list of types. Here's an +-- example (from typecheck/should_fail/T12709): +-- template: [rep :: RuntimeRep, a :: TYPE rep] +-- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] +-- We can see that matching the first pair will make the kinds of the second +-- pair equal. Yet, we still don't need a separate pass to unify the kinds +-- of these types, so it's appropriate to use the Ty variant of unification. +-- See also Note [tcMatchTy vs tcMatchTyKi]. +tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2 + = initUM tv_env cv_env $ + do { when match_kis $ + unify_tys env kis1 kis2 + ; unify_tys env tys1 tys2 } + where + env = UMEnv { um_bind_tv_fun = bind_tv + , um_bind_fam_fun = bind_fam + , um_foralls = emptyVarSet + , um_unif = unif + , um_inj_tf = inj_check + , um_arr_mult = match_mults + , um_rn_env = rn_env } + + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 + + +{- ********************************************************************* +* * + UnifyResult, MaybeApart etc +* * +********************************************************************* -} + +{- Note [Rewrite rules ignore multiplicities in FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following (higher-order) rule: + +m :: Bool -> Bool -> Bool +{-# RULES "m" forall f. m (f True) = f #-} + +let x = m ((,) @Bool @Bool True True) + +The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True :: +Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default] +in GHC.Core.Multiplicity) Should the rule match? Yes! According to the +principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation +shouldn't be constrained by linearity. + +However, when matching the template variable `f` to `(,) True`, we do check that +their types unify (see Note [Matching variable types] in GHC.Core.Rules). So +when unifying types for the sake of rule-matching, the unification algorithm +must be able to ignore multiplicities altogether. + +How is this done? + (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching, + and hence want to ignore multiplicities. + (2) The field is set to True in by `ruleMatchTyKiX`. + (3) It is consulted when matching `FunTy` in `unify_ty`. + +Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it +was a regular type constructor. In this case, and when the types being unified +are *function* arrows, but not constraint arrows, then the first argument is a +multiplicity. + +We select this situation by comparing the type constructor with fUNTyCon. In +this case, and this case only, we can safely drop the first argument (using the +tail function) and unify the rest. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Infinitary substitutions]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. +-} + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Unification result] +type UnifyResult = UnifyResultM Subst + +-- | See Note [Unification result] +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart MaybeApartReason + a -- the subst has as much as we know + -- it must be part of a most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + deriving Functor + +-- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence: +-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv +-- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint; +-- it's really only MARInfinite that's interesting here. +data MaybeApartReason + = MARTypeFamily -- ^ matching e.g. F Int ~? Bool + + | MARInfinite -- ^ matching e.g. a ~? Maybe a + + | MARTypeVsConstraint -- ^ matching Type ~? Constraint or the arrow types + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + + | MARCast -- ^ Very obscure. + -- See (KCU2) in Note [Kind coercions in Unify] + + +combineMAR :: MaybeApartReason -> MaybeApartReason -> MaybeApartReason +-- See (UR1) in Note [Unification result] for why MARInfinite wins +combineMAR MARInfinite _ = MARInfinite -- MARInfinite wins +combineMAR MARTypeFamily r = r -- Otherwise it doesn't really matter +combineMAR MARTypeVsConstraint r = r +combineMAR MARCast r = r + +instance Outputable MaybeApartReason where + ppr MARTypeFamily = text "MARTypeFamily" + ppr MARInfinite = text "MARInfinite" + ppr MARTypeVsConstraint = text "MARTypeVsConstraint" + ppr MARCast = text "MARCast" + +instance Semigroup MaybeApartReason where + (<>) = combineMAR + +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + SurelyApart >>= _ = SurelyApart + MaybeApart r1 x >>= f = case f x of + Unifiable y -> MaybeApart r1 y + MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y + SurelyApart -> SurelyApart + Unifiable x >>= f = f x + +instance Outputable a => Outputable (UnifyResultM a) where + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv/CvSubstEnv pair that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is much trickier than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitution to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in #9106. + +It gets worse. In #14164 we wanted to take the fixpoint of +this substitution + [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) + (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) + , a_aY6 :-> a_aXQ ] + +We have to apply the substitution for a_aY6 two levels deep inside +the invocation of F! We don't have a function that recursively +applies substitutions inside the kinds of variable occurrences (and +probably rightly so). + +So, we work as follows: + + 1. Start with the current substitution (which we are + trying to fixpoint + [ xs :-> F a (z :: a) (rest :: G a (z :: a)) + , a :-> b ] + + 2. Take all the free vars of the range of the substitution: + {a, z, rest, b} + NB: the free variable finder closes over + the kinds of variable occurrences + + 3. If none are in the domain of the substitution, stop. + We have found a fixpoint. + + 4. Remove the variables that are bound by the substitution, leaving + {z, rest, b} + + 5. Do a topo-sort to put them in dependency order: + [ b :: *, z :: a, rest :: G a z ] + + 6. Apply the substitution left-to-right to the kinds of these + tyvars, extending it each time with a new binding, so we + finish up with + [ xs :-> ..as before.. + , a :-> b + , b :-> b :: * + , z :-> z :: b + , rest :-> rest :: G b (z :: b) ] + Note that rest now has the right kind + + 7. Apply this extended substitution (once) to the range of + the /original/ substitution. (Note that we do the + extended substitution would go on forever if you tried + to find its fixpoint, because it maps z to z.) + + 8. And go back to step 1 + +In Step 6 we use the free vars from Step 2 as the initial +in-scope set, because all of those variables appear in the +range of the substitution, so they must all be in the in-scope +set. But NB that the type substitution engine does not look up +variables in the in-scope set; it is used only to ensure no +shadowing. +-} + +niFixSubst :: InScopeSet -> TvSubstEnv -> Subst +-- Find the idempotent fixed point of the non-idempotent substitution +-- This is surprisingly tricky: +-- see Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixSubst in_scope tenv + | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) + | otherwise = subst + where + range_fvs :: FV + range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) + -- It's OK to use nonDetEltsUFM here because the + -- order of range_fvs, range_tvs is immaterial + + range_tvs :: [TyVar] + range_tvs = fvVarList range_fvs + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + -- See Note [Finding the substitution fixpoint], Step 6 + subst = foldl' add_free_tv + (mkTvSubst in_scope tenv) + free_tvs + + add_free_tv :: Subst -> TyVar -> Subst + add_free_tv subst tv + = extendTvSubst subst tv (mkTyVarTy tv') + where + tv' = updateTyVarKind (substTy subst) tv + +{- +************************************************************************ +* * + unify_ty: the main workhorse +* * +************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pure unifier, unify_ty, defined in this module, tries to work out +a substitution to make two types say True to eqType. NB: eqType is +itself not purely syntactic; it accounts for CastTys; +see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + +Unlike the "impure unifiers" in the typechecker (the eager unifier in +GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality), +the pure unifier does /not/ work up to ~. + +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. + If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). + θ is a most general unifier for τ₁ and τ₂. + +(U2) Completeness. + If (unify ξ₁ ξ₂) = SurelyApart, + then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. + If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, + for any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. + If (unify ξ τ♭) = SurelyApart, then there exists no θ + such that θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ + If (unify τ₁♭ τ₂♭) = SurelyApart, + then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even + after arbitrary type family reductions. + +(I2) If (unify σ τ) = MaybeApart θ, and if some + φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars + in σ are bound in θ. + + Property M1 means that we must extend the substitution with, + say (a ↦ a) when appropriate during matching. + See also Note [Self-substitution when unifying or matching]. + +(M2) Completeness of matching. + If θ(σ) = τ, then (match σ τ) = Unifiable φ, + where θ is an extension of φ. + +Wrinkle (SI1): um_inj_tf: + Sadly, property M2 and I2 conflict. Consider + + type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + + Consider now two matching problems: + + P1. match (F1 a Bool) (F1 Int Bool) + P2. match (F1 a Bool) (F1 Double String) + + In case P1, we must find (a ↦ Int) to satisfy M2. In case P2, we must /not/ + find (a ↦ Double), in order to satisfy I2. (Note that the correct mapping for + I2 is (a ↦ Int). There is no way to discover this, but we mustn't map a to + anything else!) + + We thus must parameterize the algorithm over whether it's being used + for an injectivity check (refrain from looking at non-injective arguments + to type families) or not (do indeed look at those arguments). This is + implemented by the um_inj_tf field of UMEnv. + + (It's all a question of whether or not to include equation (7) from Fig. 2 + of [ITF].) + + This extra parameter is a bit fiddly, perhaps, but seemingly less so than + having two separate, almost-identical algorithms. + +Note [Self-substitution when unifying or matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What happens when we are unifying or matching two identical type variables? + a ~ a + +* When /unifying/, just succeed, without binding [a :-> a] in the substitution, + else we'd get an infinite substitution. We need to make this check before + we do the occurs check, of course. + +* When /matching/, and `a` is a bindable variable from the template, we /do/ + want to extend the substitution. Remember, a successful match should map all + the template variables (except ones that disappear when expanding synonyms), + + But when `a` is /not/ a bindable variable (perhaps it is a globally-in-scope + skolem) we want to treat it like a constant `Int ~ Int` and succeed. + + Notice: no occurs check! It's fine to match (a ~ Maybe a), because the + template vars of the template come from a different name space to the free + vars of the target. + + Note that this arrangement was provoked by a real failure, where the same + unique ended up in the template as in the target. (It was a rule firing when + compiling Data.List.NonEmpty.) + +* What about matching a /non-bindable/ variable? For example: + template-vars : {a} + matching problem: (forall b. b -> a) ~ (forall c. c -> Int) + We want to emerge with the substitution [a :-> Int] + But on the way we will encounter (b ~ b), when we match the bits before the + arrow under the forall, having renamed `c` to `b`. This match should just + succeed, just like (Int ~ Int), without extending the substitution. + + It's important to do this for /non-bindable/ variables, not just for + forall-bound ones. In an associated type + instance C (Maybe a) where { type F (Maybe a) = Int } + `checkConsistentFamInst` matches (Maybe a) from the header against (Maybe a) + from the type-family instance, with `a` marked as non-bindable. + + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left and then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion `kco` to the main `unify_ty`. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. Note that we do not unify kinds at the leaves +(as we did previously). + +Hence: (UKINV) Unification Kind Invariant +* In the call + unify_ty ty1 ty2 kco + it must be that + subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)) + where `subst` is the ambient substitution in the UM monad +* In the call + unify_tys tys1 tys2 + (which has no kco), after we unify any prefix of tys1,tys2, the kinds of the + head of the remaining tys1,tys2 are identical after substitution. This + implies, for example, that the kinds of the head of tys1,tys2 are identical + after substitution. + +Preserving (UKINV) takes a bit of work, governed by the `match_kis` flag in +`tc_unify_tys`: + +* When we're working with type applications (either TyConApp or AppTy) we + need to worry about establishing (UKINV), as the kinds of the function + & arguments aren't (necessarily) included in the kind of the result. + When unifying two TyConApps, this is easy, because the two TyCons are + the same. Their kinds are thus the same. As long as we unify left-to-right, + we'll be sure to unify types' kinds before the types themselves. (For example, + think about Proxy :: forall k. k -> *. Unifying the first args matches up + the kinds of the second args.) + +* For AppTy, we must unify the kinds of the functions, but once these are + unified, we can continue unifying arguments without worrying further about + kinds. + +* The interface to this module includes both "...Ty" functions and + "...TyKi" functions. The former assume that (UKINV) is already + established, either because the kinds are the same or because the + list of types being passed in are the well-typed arguments to some + type constructor (see two paragraphs above). The latter take a separate + pre-pass over the kinds to establish (UKINV). Sometimes, it's important + not to take the second pass, as it caused #12442. + +Wrinkles + +(KCU1) We ensure that the `kco` argument never mentions variables in the + domain of either RnEnvL or RnEnvR. Why? + + * `kco` is used only to build the final well-kinded substitution + a :-> ty |> kco + The range of the substitution never mentions forall-bound variables, + so `kco` cannot either. + + * `kco` mixes up types from both left and right arguments of + `unify_ty`, which have different renamings in the RnEnv2. + + The easiest thing is to insist that `kco` does not need renaming with + the RnEnv2; it mentions no forall-bound variables. + + To achieve this we do a `mentionsForAllBoundTyVars` test in the + `CastTy` cases of `unify_ty`. + +(KCU2) Suppose we are unifying + (forall a. x |> (...F a b...) ~ (forall a. y) + We can't bind y :-> x |> (...F a b...), becuase of that free `a`. + + But if we later learn that b=Int, and F a Int = Bool, + that free `a` might disappear, so we could unify with + y :-> x |> (...Bool...) + + Conclusion: if there is a free forall-bound variable in a cast, + return MaybeApart, with a MaybeApartReason of MARCast. + +(KCU3) We thought, at one point, that this was all unnecessary: why should + casts be in types in the first place? But they are sometimes. In + dependent/should_compile/KindEqualities2, we see, for example the + constraint Num (Int |> (blah ; sym blah)). We naturally want to find + a dictionary for that constraint, which requires dealing with + coercions in this manner. + +Note [Matching in the presence of casts (1)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching, it is crucial that no variables from the template +end up in the range of the matching substitution (obviously!). +When unifying, that's not a constraint; instead we take the fixpoint +of the substitution at the end. + +So what should we do with this, when matching? + unify_ty (tmpl |> co) tgt kco + +Previously, wrongly, we pushed 'co' in the (horrid) accumulating +'kco' argument like this: + unify_ty (tmpl |> co) tgt kco + = unify_ty tmpl tgt (kco ; co) + +But that is obviously wrong because 'co' (from the template) ends +up in 'kco', which in turn ends up in the range of the substitution. + +This all came up in #13910. Because we match tycon arguments +left-to-right, the ambient substitution will already have a matching +substitution for any kinds; so there is an easy fix: just apply +the substitution-so-far to the coercion from the LHS. + +Note that + +* When matching, the first arg of unify_ty is always the template; + we never swap round. + +* The above argument is distressingly indirect. We seek a + better way. + +* One better way is to ensure that type patterns (the template + in the matching process) have no casts. See #14119. + +Note [Matching in the presence of casts (2)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another wrinkle (#17395). Suppose (T :: forall k. k -> Type) +and we are matching + tcMatchTy (T k (a::k)) (T j (b::j)) + +Then we'll match k :-> j, as expected. But then in unify_tys +we invoke + unify_tys env (a::k) (b::j) (Refl j) + +Although we have unified k and j, it's very important that we put +(Refl j), /not/ (Refl k) as the fourth argument to unify_tys. +If we put (Refl k) we'd end up with the substitution + a :-> b |> Refl k +which is bogus because one of the template variables, k, +appears in the range of the substitution. Eek. + +Similar care is needed in unify_ty_app. + + +Note [Polykinded tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: forall k. Type -> K +and we are unifying + ty1: T @Type Int :: Type + ty2: T @(Type->Type) Int Int :: Type + +These two TyConApps have the same TyCon at the front but they +(legitimately) have different numbers of arguments. They +are surelyApart, so we can report that without looking any +further (see #15704). + +Note [Unifying type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unifying type applications is quite subtle, as we found +in #23134 and #22647, when type families are involved. + +Suppose + type family F a :: Type -> Type + type family G k :: k = r | r -> k + +and consider these examples: + +* F Int ~ F Char, where F is injective + Since F is injective, we can reduce this to Int ~ Char, + therefore SurelyApart. + +* F Int ~ F Char, where F is not injective + Without injectivity, return MaybeApart. + +* G Type ~ G (Type -> Type) Int + Even though G is injective and the arguments to G are different, + we cannot deduce apartness because the RHS is oversaturated. + For example, G might be defined as + G Type = Maybe Int + G (Type -> Type) = Maybe + So we return MaybeApart. + +* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char) + F Int Bool ~ Maybe a -- MaybeApart + F Int Bool ~ a b -- MaybeApart + F Int Bool ~ Char -> Bool -- MaybeApart + An oversaturated type family can match an application, + whether it's a TyConApp, AppTy or FunTy. Decompose. + +* F Int ~ a b + We cannot decompose a saturated, or under-saturated + type family application. We return MaybeApart. + +To handle all those conditions, unify_ty goes through +the following checks in sequence, where Fn is a type family +of arity n: + +* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n + A saturated application. + Here we can unify arguments in which Fn is injective. +* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n + A saturated type family can match anything - we return MaybeApart. +* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n + An oversaturated type family can be decomposed. +* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n + If we couldn't decompose in the previous step, we return SurelyApart. + +Afterwards, the rest of the code doesn't have to worry about type families. + +Note [Unifying type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the task of unifying two 'Type's of the form + + TyConApp tc [] ~ TyConApp tc [] + +where `tc` is a type synonym. A naive way to perform this comparison these +would first expand the synonym and then compare the resulting expansions. + +However, this is obviously wasteful and the RHS of `tc` may be large; it is +much better to rather compare the TyCons directly. Consequently, before +expanding type synonyms in type comparisons we first look for a nullary +TyConApp and simply compare the TyCons if we find one. + +Of course, if we find that the TyCons are *not* equal then we still need to +perform the expansion as their RHSs may still be unifiable. E.g + type T = S (a->a) + type S a = [a] +and consider + T Int ~ S (Int -> Int) + +We can't decompose non-nullary synonyms. E.g. + type R a = F a -- Where F is a type family +and consider + R (a->a) ~ R Int +We can't conclude that (a->) ~ Int. (There is a currently-missed opportunity +here; if we knew that R was /injective/, perhaps we could decompose.) + +We perform the nullary-type-synonym optimisation in a number of places: + + * GHC.Core.Unify.unify_ty + * GHC.Tc.Solver.Equality.can_eq_nc' + * GHC.Tc.Utils.Unify.uType + +This optimisation is especially helpful for the ubiquitous GHC.Types.Type, +since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications +whenever possible. See Note [Using synonyms to compress types] in +GHC.Core.Type for details. + +c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare +-} + +-------------- unify_ty: the main workhorse ----------- + +type AmIUnifying = Bool -- True <=> Unifying + -- False <=> Matching + +type InType = Type -- Before applying the RnEnv2 +type OutCoercion = Coercion -- After applying the RnEnv2 + + +unify_ty :: UMEnv + -> InType -> InType -- Types to be unified + -> OutCoercion -- A nominal coercion between their kinds + -- OutCoercion: the RnEnv has already been applied + -- When matching, the coercion is in "target space", + -- not "template space" + -- See Note [Kind coercions in Unify] + -> UM () +-- Precondition: see (Unification Kind Invariant) +-- +-- See Note [Specification of unification] +-- Respects newtypes, PredTypes +-- See Note [Computing equality on types] in GHC.Core.Type +unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco + -- See Note [Unifying type synonyms] + | tc1 == tc2 + = return () + +unify_ty env ty1 ty2 kco + -- Now handle the cases we can "look through": synonyms and casts. + | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco + +unify_ty env (CastTy ty1 co1) ty2 kco + | mentionsForAllBoundTyVarsL env (tyCoVarsOfCo co1) + -- See (KCU1) in Note [Kind coercions in Unify] + = maybeApart MARCast -- See (KCU2) + + | um_unif env + = unify_ty env ty1 ty2 (co1 `mkTransCo` kco) + + | otherwise -- We are matching, not unifying + = do { subst <- getSubst env + ; let co' = substCo subst co1 + -- We match left-to-right, so the free template vars of the + -- coercion should already have been matched. + -- See Note [Matching in the presence of casts (1)] + -- NB: co1 does not mention forall-bound vars, so no need to rename + ; unify_ty env ty1 ty2 (co' `mkTransCo` kco) } + +unify_ty env ty1 (CastTy ty2 co2) kco + | mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2) + -- See (KCU1) in Note [Kind coercions in Unify] + = maybeApart MARCast -- See (KCU2) + | otherwise + = unify_ty env ty1 ty2 (kco `mkTransCo` mkSymCo co2) + -- NB: co2 does not mention forall-bound variables + +-- Applications need a bit of care! +-- They can match FunTy and TyConApp, so use splitAppTy_maybe +unify_ty env (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty env ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + -- ToDo: See Note [Unifying coercion-foralls] + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) + ; let env' = umRnBndr2 env tv1 tv2 + ; unify_ty env' ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty env (CoercionTy co1) (CoercionTy co2) kco + = do { c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not (um_unif env) + , not (cv `elemVarEnv` c_subst) -- Not forall-bound + , let (_mult_co, co_l, co_r) = decomposeFunCo kco + -- Because the coercion is used in a type, it should be safe to + -- ignore the multiplicity coercion, _mult_co + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r + , BindMe <- um_bind_tv_fun env cv (CoercionTy rhs_co) + -> if mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2) + then surelyApart + else extendCvEnv cv rhs_co + + _ -> return () } + +unify_ty env (TyVarTy tv1) ty2 kco + = uVarOrFam env (TyVarLHS tv1) ty2 kco + +unify_ty env ty1 (TyVarTy tv2) kco + | um_unif env -- If unifying, can swap args; but not when matching + = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco) + +-- Deal with TyConApps +unify_ty env ty1 ty2 kco + -- Handle non-oversaturated type families first + -- See Note [Unifying type applications] + | Just (tc,tys) <- mb_sat_fam_app1 + = uVarOrFam env (TyFamLHS tc tys) ty2 kco + + | um_unif env + , Just (tc,tys) <- mb_sat_fam_app2 + = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco) + + -- Handle oversaturated type families. Suppose we have + -- (F a b) ~ (c d) where F has arity 1 + -- We definitely want to decompose that type application! (#22647) + -- + -- If there is no application, an oversaturated type family can only + -- match a type variable or a saturated type family, + -- both of which we handled earlier. So we can say surelyApart. + | Just (tc1, _) <- mb_tc_app1 + , isTypeFamilyTyCon tc1 + = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) + | otherwise -> surelyApart -- (C4) + + | Just (tc2, _) <- mb_tc_app2 + , isTypeFamilyTyCon tc2 + = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 + , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 + -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) + | otherwise -> surelyApart -- (C4) + + -- At this point, neither tc1 nor tc2 can be a type family. + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 + = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1) + ; unify_tc_app env tc1 tys1 tys2 + } + + -- TYPE and CONSTRAINT are not Apart + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + -- NB: at this point we know that the two TyCons do not match + | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1 + , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2 + , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) || + (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey) + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] + + -- The arrow types are not Apart + -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim + -- wrinkle (W2) + -- NB1: at this point we know that the two TyCons do not match + -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via + -- splitTyConApp_maybe. But yes we do: we need to look at those implied + -- kind argument in order to satisfy (Unification Kind Invariant) + | FunTy {} <- ty1 + , FunTy {} <- ty2 + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] + + where + mb_tc_app1 = splitTyConApp_maybe ty1 + mb_tc_app2 = splitTyConApp_maybe ty2 + mb_sat_fam_app1 = isSatTyFamApp ty1 + mb_sat_fam_app2 = isSatTyFamApp ty2 + +unify_ty _ _ _ _ = surelyApart + +----------------------------- +unify_tc_app :: UMEnv -> TyCon -> [Type] -> [Type] -> UM () +-- Mainly just unifies the argument types; +-- but with a special case for fUNTyCon +unify_tc_app env tc tys1 tys2 + | tc == fUNTyCon + , IgnoreMultiplicities <- um_arr_mult env + , (_mult1 : no_mult_tys1) <- tys1 + , (_mult2 : no_mult_tys2) <- tys2 + = -- We're comparing function arrow types here (not constraint arrow + -- types!), and they have at least one argument, which is the arrow's + -- multiplicity annotation. The flag `um_arr_mult` instructs us to + -- ignore multiplicities in this very case. This is a little tricky: see + -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy]. + unify_tys env no_mult_tys1 no_mult_tys2 + + | otherwise + = unify_tys env tys1 tys2 + +----------------------------- +unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () +-- Deal with (t1 t1args) ~ (t2 t2args) +-- where length t1args = length t2args +unify_ty_app env ty1 ty1args ty2 ty2args + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 + , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2 + = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) + + | otherwise + = do { let ki1 = typeKind ty1 + ki2 = typeKind ty2 + -- See Note [Kind coercions in Unify] + ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) + ; unify_ty env ty1 ty2 (mkNomReflCo ki2) + -- Very important: 'ki2' not 'ki1' + -- See Note [Matching in the presence of casts (2)] + ; unify_tys env ty1args ty2args } + +----------------------------- +unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +-- Precondition: see (Unification Kind Invariant) +unify_tys env orig_xs orig_ys + = go orig_xs orig_ys + where + go [] [] = return () + go (x:xs) (y:ys) + -- See Note [Kind coercions in Unify] + = do { unify_ty env x y (mkNomReflCo $ typeKind y) + -- Very important: 'y' not 'x' + -- See Note [Matching in the presence of casts (2)] + ; go xs ys } + go _ _ = surelyApart + -- Possibly different saturations of a polykinded tycon + -- See Note [Polykinded tycon applications] + +--------------------------------- +uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM () +-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy +-- (b) both args have had coreView already applied +-- Why saturated? See (ATF4) in Note [Apartness and type families] +uVarOrFam env ty1 ty2 kco + = do { substs <- getSubstEnvs +-- ; pprTrace "uVarOrFam" (vcat +-- [ text "ty1" <+> ppr ty1 +-- , text "ty2" <+> ppr ty2 +-- , text "tv_env" <+> ppr (um_tv_env substs) +-- , text "fam_env" <+> ppr (um_fam_env substs) ]) $ + ; go NotSwapped substs ty1 ty2 kco } + where + foralld_tvs = um_foralls env + under_forall = not (isEmptyVarSet foralld_tvs) + + -- `go` takes two bites at the cherry; if the first one fails + -- it swaps the arguments and tries again; and then it fails. + -- The SwapFlag argument tells `go` whether it is on the first + -- bite (NotSwapped) or the second (IsSwapped). + -- E.g. a ~ F p q + -- Starts with: go a (F p q) + -- if `a` not bindable, swap to: go (F p q) a + + ----------------------------- + -- LHS is a type variable + -- The sequence of tests is very similar to go_tv + go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM () + go swapped substs lhs@(TyVarLHS tv1) ty2 kco + | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1' + = -- We already have a substitution for tv1 + if | um_unif env -> unify_ty env ty1' ty2 kco + | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return () + | otherwise -> surelyApart + -- Unifying: recurse into unify_ty + -- Matching: we /don't/ want to just recurse here, because the range of + -- the subst is the target type, not the template type. So, just check + -- for normal type equality. + -- NB: it's important to use `tcEqType` instead of `eqType` here, + -- otherwise we might not reject a substitution + -- which unifies `Type` with `Constraint`, e.g. + -- a call to tc_unify_tys with arguments + -- + -- tys1 = [k,k] + -- tys2 = [Type, Constraint] + -- + -- See test cases: T11715b, T20521. + + -- If we are matching or unifying a ~ a, take care + -- See Note [Self-substitution when unifying or matching] + | TyVarTy tv2 <- ty2 + , let tv2' = umRnOccR env tv2 + , tv1' == tv2' + = if | um_unif env -> return () + | tv1_is_bindable -> extendTvEnv tv1' ty2 + | otherwise -> return () + + | tv1_is_bindable + , not (mentionsForAllBoundTyVarsR env ty2_fvs) + -- ty2_fvs: kco does not mention forall-bound vars + , not occurs_check + = -- No occurs check, nor skolem-escape; just bind the tv + -- We don't need to rename `rhs` because it mentions no forall-bound vars + extendTvEnv tv1' rhs -- Bind tv1:=rhs and continue + + -- When unifying, try swapping: + -- e.g. a ~ F p q with `a` not bindable: we might succeed with go_fam + -- e.g. a ~ beta with `a` not bindable: we might be able to bind `beta` + -- e.g. beta ~ F beta Int occurs check; but MaybeApart after swapping + | um_unif env + , NotSwapped <- swapped -- If we have swapped already, don't do so again + , Just lhs2 <- canEqLHS_maybe ty2 + = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco) + + | occurs_check = maybeApart MARInfinite -- Occurs check + | otherwise = surelyApart + + where + tv1' = umRnOccL env tv1 + ty2_fvs = tyCoVarsOfType ty2 + rhs = ty2 `mkCastTy` mkSymCo kco + tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs) + -- tv1' is not forall-bound, but tv1 can still differ + -- from tv1; see Note [Cloning the template binders] + -- in GHC.Core.Rules. So give tv1' to um_bind_tv_fun. + , BindMe <- um_bind_tv_fun env tv1' rhs + = True + | otherwise + = False + + occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs + -- Occurs check, only when unifying + -- see Note [Infinitary substitutions] + -- Make sure you include `kco` in rhs #14846 + + ----------------------------- + -- LHS is a saturated type-family application + -- Invariant: ty2 is not a TyVarTy + go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco + -- Check if we have an existing substitution for the LHS; if so, recurse + -- But not under a forall; see (ATF3) in Note [Apartness and type families] + -- Hence the RnEnv2 is empty + | not under_forall + , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1 + = if | um_unif env -> unify_ty env ty1' ty2 kco + -- Below here we are matching + -- The return () case deals with: + -- Template: (F a)..(F a) + -- Target: (F b)..(F b) + -- This should match! With [a :-> b] + | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return () + | otherwise -> maybeApart MARTypeFamily + + -- Check for equality F tys1 ~ F tys2 + -- Very important that this can happen under a forall, so that we + -- successfully match (forall a. F a) ~ (forall b. F b) See (ATF9-2) + | Just (tc2, tys2) <- isSatTyFamApp ty2 + , tc1 == tc2 + = go_fam_fam substs tc1 tys1 tys2 kco + + -- If we are under a forall, just give up + -- see (ATF3) and (ATF5) in Note [Apartness and type families] + | under_forall + = maybeApart MARTypeFamily + + -- Now check if we can bind the (F tys) to the RHS + -- Again, not under a forall; see (ATF3) + -- This can happen even when matching: see (ATF7) + | BindMe <- um_bind_fam_fun env tc1 tys1 rhs + = if uOccursCheck substs emptyVarSet lhs rhs + then maybeApart MARInfinite + else do { extendFamEnv tc1 tys1 rhs + -- We don't substitute tys1 before extending + -- See Note [Shortcomings of the apartness test] + ; maybeApart MARTypeFamily } + + -- Swap in case of (F a b) ~ (G c d e) + -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e) + -- NB: a type family can appear on the template when matching + -- see (ATF6) in Note [Apartness and type families] + -- (Only worth doing this if we are not under a forall.) + | um_unif env + , NotSwapped <- swapped + , Just lhs2 <- canEqLHS_maybe ty2 + = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco) + + | otherwise -- See (ATF5) in Note [Apartness and type families] + = surelyApart + + where + rhs = ty2 `mkCastTy` mkSymCo kco + + ----------------------------- + -- go_fam_fam: LHS and RHS are both saturated type-family applications, + -- for the same type-family F + go_fam_fam substs tc tys1 tys2 kco + -- Decompose (F tys1 ~ F tys2): (ATF9) + -- Use injectivity information of F: (ATF10) + -- But first bind the type-fam if poss: (ATF11) + = do { bind_fam_if_poss -- (ATF11) + ; unify_tys env inj_tys1 inj_tys2 -- (ATF10) + ; unless (um_inj_tf env) $ -- (ATF12) + don'tBeSoSure MARTypeFamily $ -- (ATF9-1) + unify_tys env noninj_tys1 noninj_tys2 } + where + inj = case tyConInjectivityInfo tc of + NotInjective -> repeat False + Injective bs -> bs + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + bind_fam_if_poss + | not (um_unif env) -- Not when matching (ATF11-1) + = return () + | under_forall -- Not under a forall (ATF3) + = return () + | BindMe <- um_bind_fam_fun env tc tys1 rhs1 + = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $ + extendFamEnv tc tys1 rhs1 + -- At this point um_unif=True, so we can unify either way + | BindMe <- um_bind_fam_fun env tc tys2 rhs2 + = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $ + extendFamEnv tc tys2 rhs2 + | otherwise + = return () + + rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco + rhs2 = mkTyConApp tc tys1 `mkCastTy` kco + + +uOccursCheck :: UMState + -> TyVarSet -- Bound by enclosing foralls; see (OCU1) + -> CanEqLHS -> Type -- Can we unify (lhs := ty)? + -> Bool +-- See Note [The occurs check in the Core unifier] and (ATF13) +uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty + = go bvs ty + where + go :: TyCoVarSet -- Bound by enclosing foralls; see (OCU1) + -> Type -> Bool + go bvs ty | Just ty' <- coreView ty = go bvs ty' + go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv + = go bvs ty' + | TyVarLHS tv' <- lhs, tv==tv' + = True + | otherwise + = go bvs (tyVarKind tv) + go bvs (AppTy ty1 ty2) = go bvs ty1 || go bvs ty2 + go _ (LitTy {}) = False + go bvs (FunTy _ w arg res) = go bvs w || go bvs arg || go bvs res + go bvs (TyConApp tc tys) = go_tc bvs tc tys + + go bvs (ForAllTy (Bndr tv _) ty) + = go bvs (tyVarKind tv) || + (case lhs of + TyVarLHS tv' | tv==tv' -> False -- Shadowing + | otherwise -> go (bvs `extendVarSet` tv) ty + TyFamLHS {} -> False) -- Lookups don't happen under a forall + + go bvs (CastTy ty _co) = go bvs ty -- ToDo: should we worry about `co`? + go _ (CoercionTy _co) = False -- ToDo: should we worry about `co`? + + go_tc bvs tc tys + | isEmptyVarSet bvs -- Never look up in um_fam_env under a forall (ATF3) + , isTypeFamilyTyCon tc + , Just ty' <- lookupFamEnv fam_env tc (take arity tys) + -- NB: we look up /un-substituted/ types; + -- See Note [Shortcomings of the apartness test] + = go bvs ty' || any (go bvs) (drop arity tys) + + | TyFamLHS tc' tys' <- lhs + , tc == tc' + , tys `lengthAtLeast` arity -- Saturated, or over-saturated + , tcEqTyConAppArgs tys tys' + = True + + | otherwise + = any (go bvs) tys + where + arity = tyConArity tc + +{- Note [The occurs check in the Core unifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes, +so we'll get an infinite loop if we have, for example + um_tv_env: a :-> F b -- (1) + um_fam_env F b :-> a -- (2) + +So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty` +could lead to a loop. That is, could there by a type `s` such that + applySubsts( (substs + lhs:->ty), s ) is infinite + +It's vital that we do both at once: we might have (1) already and add (2); +or we might have (2) already and add (1). + +A very similar task is done by GHC.Tc.Utils.Unify.checkTyEqRhs. + +(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive + under a forall; indeed it is /unsound/ to consult it because we may have a binding + (F a :-> Int), and then unify (forall a. ...(F a)...) with something. We don't + want to map that (F a) to Int! + +(OCU2) Performance. Consider unifying + [a, b] ~ [big-ty, (a,a,a)] + We'll unify a:=big-ty. Then we'll attempt b:=(a,a,a), but must do an occurs check. + So we'll walk over big-ty, looking for `b`. And then again, and again, once for + each occurrence of `a`. A similar thing happens for + [a, (b,b,b)] ~ [big-ty, (a,a,a)] + albeit a bit less obviously. + + Potentially we could use a cache to record checks we have already done; + but I have not attempted that yet. Precisely similar remarks would apply + to GHC.Tc.Utils.Unify.checkTyEqRhs + +Note [Unifying coercion-foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we try to unify (forall cv. t1) ~ (forall cv. t2). +See Note [ForAllTy] in GHC.Core.TyCo.Rep. + +The problem with coercion variables is that coercion abstraction is not erased: +the `kco` shouldn't propagate from outside the ForAllTy to inside. Instead, I think +the correct new `kco` for the recursive call is `mkNomReflCo liftedTypeKind` (but I'm +a little worried it might be Constraint sometimes). + +This potential problem has been there a long time, and I'm going to let +sleeping dogs lie for now. +-} + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +data UMEnv + = UMEnv { um_unif :: AmIUnifying + + , um_inj_tf :: Bool + -- Checking for injectivity? + -- See (SI1) in Note [Specification of unification] + + , um_arr_mult :: MultiplicityFlag + -- Whether to unify multiplicity arguments when unifying arrows. + -- See Note [Rewrite rules ignore multiplicities in FunTy] + + , um_rn_env :: RnEnv2 + -- Renaming InTyVars to OutTyVars; this eliminates shadowing, and + -- lines up matching foralls on the left and right + -- See (CU2) in Note [The Core unifier] + + , um_foralls :: TyVarSet + -- OutTyVars bound by a forall in this unification; + -- Do not bind these in the substitution! + -- See the function tvBindFlag + + , um_bind_tv_fun :: BindTvFun + -- User-supplied BindFlag function, for variables not in um_foralls + -- See (CU1) in Note [The Core unifier] + + , um_bind_fam_fun :: BindFamFun + -- Similar to um_bind_tv_fun, but for type-family applications + -- See (ATF8) in Note [Apartness and type families] + } + +type FamSubstEnv = TyConEnv (ListMap TypeMap Type) + -- Map a TyCon and a list of types to a type + -- Domain of FamSubstEnv is exactly-saturated type-family + -- applications (F t1...tn) + +lookupFamEnv :: FamSubstEnv -> TyCon -> [Type] -> Maybe Type +lookupFamEnv env tc tys + = do { tys_map <- lookupTyConEnv env tc + ; lookupTM tys tys_map } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv + , um_fam_env :: FamSubstEnv } + -- um_tv_env, um_cv_env, um_fam_env are all "global" substitutions; + -- that is, neither their domains nor their ranges mention any variables + -- in um_foralls; i.e. variables bound by foralls inside the types being unified + + -- When /matching/ um_fam_env is usually empty; but not quite always. + -- See (ATF7) of Note [Apartness and type families] + +newtype UM a + = UM' { unUM :: UMState -> UnifyResultM (UMState, a) } + -- See Note [The one-shot state monad trick] in GHC.Utils.Monad + +pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern UM m <- UM' m + where + UM m = UM' (oneShot m) +{-# COMPLETE UM #-} + +instance Functor UM where + fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s)) + +instance Applicative UM where + pure a = UM (\s -> pure (s, a)) + (<*>) = ap + +instance Monad UM where + {-# INLINE (>>=) #-} + -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad + m >>= k = UM (\state -> + do { (state', v) <- unUM m state + ; unUM (k v) state' }) + +instance MonadFail UM where + fail _ = UM (\_ -> SurelyApart) -- failed pattern match + +initUM :: TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM () + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +initUM subst_env cv_subst_env um + = case unUM um state of + Unifiable (state, _) -> Unifiable (get state) + MaybeApart r (state, _) -> MaybeApart r (get state) + SurelyApart -> SurelyApart + where + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env + , um_fam_env = emptyTyConEnv } + get (UMState { um_tv_env = tv_env, um_cv_env = cv_env }) = (tv_env, cv_env) + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) + +getSubstEnvs :: UM UMState +getSubstEnvs = UM $ \state -> Unifiable (state, state) + +getSubst :: UMEnv -> UM Subst +getSubst env = do { tv_env <- getTvSubstEnv + ; cv_env <- getCvSubstEnv + ; let in_scope = rnInScopeSet (um_rn_env env) + ; return (mkTCvSubst in_scope tv_env cv_env) } + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +extendFamEnv :: TyCon -> [Type] -> Type -> UM () +extendFamEnv tc tys ty = UM $ \state -> + Unifiable (state { um_fam_env = extend (um_fam_env state) tc }, ()) + where + extend :: FamSubstEnv -> TyCon -> FamSubstEnv + extend = alterTyConEnv alter_tm + + alter_tm :: Maybe (ListMap TypeMap Type) -> Maybe (ListMap TypeMap Type) + alter_tm m_elt = Just (alterTM tys (\_ -> Just ty) (m_elt `orElse` emptyTM)) + +umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv +umRnBndr2 env v1 v2 + = env { um_rn_env = rn_env', um_foralls = um_foralls env `extendVarSet` v' } + where + (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 + +mentionsForAllBoundTyVarsL, mentionsForAllBoundTyVarsR :: UMEnv -> VarSet -> Bool +-- See (CU2) in Note [The Core unifier] +mentionsForAllBoundTyVarsL = mentions_forall_bound_tvs inRnEnvL +mentionsForAllBoundTyVarsR = mentions_forall_bound_tvs inRnEnvR + +mentions_forall_bound_tvs :: (RnEnv2 -> TyVar -> Bool) -> UMEnv -> VarSet -> Bool +mentions_forall_bound_tvs in_rn_env env varset + | isEmptyVarSet (um_foralls env) = False + | anyVarSet (in_rn_env (um_rn_env env)) varset = True + | otherwise = False + -- NB: That isEmptyVarSet guard is a critical optimization; + -- it means we don't have to calculate the free vars of + -- the type, often saving quite a bit of allocation. + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: MaybeApartReason -> UM () -> UM () +don'tBeSoSure r um = UM $ \ state -> + case unUM um state of + SurelyApart -> MaybeApart r (state, ()) + other -> other + +umRnOccL :: UMEnv -> TyVar -> TyVar +umRnOccL env v = rnOccL (um_rn_env env) v + +umRnOccR :: UMEnv -> TyVar -> TyVar +umRnOccR env v = rnOccR (um_rn_env env) v + +umSwapRn :: UMEnv -> UMEnv +umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } + +maybeApart :: MaybeApartReason -> UM () +maybeApart r = UM (\state -> MaybeApart r (state, ())) + +surelyApart :: UM a +surelyApart = UM (\_ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +data MatchEnv = ME { me_tmpls :: TyVarSet + , me_env :: RnEnv2 } + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, +-- where @==@ there means that the result of 'liftCoSubst' has the same +-- type as the original co; but may be different under the hood. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptySubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co :: lty ~r rty, coercion to match against + -> Coercion -- ^ :: kind(lsubst(ty)) ~N kind(lty) + -> Coercion -- ^ :: kind(rsubst(ty)) ~N kind(rty) + -> Maybe LiftCoEnv + -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles. + -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty, + -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env) +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + -- Why `eqType` and not `tcEqType`? Because this function is only used + -- during coercion optimisation, after type-checking has finished. + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = allVarSet (not . f) + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + -- See Note [Matching in the presence of casts (1)] + = let empty_subst = mkEmptySubst (rnInScopeSet (me_env menv)) + substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' + substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' + in + ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) + (substed_co_r `mkTransCo` rkco) + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco + = ty_co_match_tc menv subst tc1 tys tc2 cos + +ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 }) + (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco + = ty_co_match_args menv subst [w, rep1, rep2, ty1, ty2] + [co_w, co1_rep, co2_rep, co1, co2] + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + co1_rep = mkRuntimeRepCo co1 + co2_rep = mkRuntimeRepCo co2 + -- NB: we include the RuntimeRep arguments in the matching; + -- not doing so caused #21205. + +ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1) + (ForAllCo tv2 vis1c vis2c kind_co2 co2) + lkco rkco + | isTyVar tv1 && isTyVar tv2 + , vis1t == vis1c && vis1c == vis2c -- Is this necessary? + -- Is this visibility check necessary? @rae says: yes, I think the + -- check is necessary, if we're caring about visibility (and we are). + -- But ty_co_match is a dark and not important corner. + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco + = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) + +ty_co_match menv subst ty co1 lkco rkco + | Just (CastTy t co, r) <- isReflCo_maybe co1 + -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us + -- t |> co ~ t ; ; t ~ t |> co + -- But transitive coercions are not helpful. Therefore we deal + -- with it here: we do recursion on the smaller reflexive coercion, + -- while propagating the correct kind coercions. + = let kco' = mkSymCo co + in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') + (rkco `mkTransCo` kco') + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 } + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> [Type] -> Coercion -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1 ty1args co2 co2args + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 + , Just (co2', co2a) <- splitAppCo_maybe co2 + = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) + + | otherwise + = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 + ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco + ; ty_co_match_args menv subst2 ty1args co2args } + where + ki1 = typeKind ty1 + ki2 = promoteCoercion co2 + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args menv subst (ty:tys) (arg:args) + = do { let Pair lty rty = coercionKind arg + lkco = mkNomReflCo (typeKind lty) + rkco = mkNomReflCo (typeKind rty) + ; subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args } +ty_co_match_args _ subst [] [] = Just subst +ty_co_match_args _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl co = + case (isReflCo_maybe co) of + Just (AppTy ty1 ty2, Nominal) + -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) + Just (FunTy af w ty1 ty2, r) + -> Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2)) + Just (TyConApp tc tys, r) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys)) + Just (ForAllTy (Bndr tv vis) ty, r) + -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis + , fco_kind = mkNomReflCo (varType tv) + , fco_body = mkReflCo r ty }) + _ -> Nothing diff --git a/GHC/Core/UsageEnv.hs b/GHC/Core/UsageEnv.hs --- a/GHC/Core/UsageEnv.hs +++ b/GHC/Core/UsageEnv.hs @@ -90,9 +90,13 @@ combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2) -- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. -supUEs :: [UsageEnv] -> UsageEnv +-- Used with @f = '[]'@ and @f = 'NonEmpty'@ +supUEs :: Foldable f => f UsageEnv -> UsageEnv supUEs = foldr supUE bottomUE +-- INLINE to ensure specialization at use site, and to avoid multiple specialization on the same +-- type +{-# INLINE supUEs #-} deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -11,26 +11,28 @@ -- * Constructing expressions mkCast, mkCastMCo, mkPiMCo, mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, - bindNonRec, needsCaseBinding, + bindNonRec, needsCaseBinding, needsCaseBindingL, mkAltExpr, mkDefaultCase, mkSingleAltCase, -- * Taking expressions apart findDefault, addDefault, findAlt, isDefaultAlt, - mergeAlts, trimConArgs, + mergeAlts, mergeCaseAlts, trimConArgs, filterAlts, combineIdenticalAlts, refineDefaultAlt, scaleAltsBy, -- * Properties of expressions - exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, + exprType, coreAltType, coreAltsType, + mkLamType, mkLamTypes, mkFunctionType, exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, trivial_expr_fold, exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, + exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval, exprIsWorkFree, exprIsConLike, isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, + exprIsUnaryClassFun, isUnaryClassId, altsAreExhaustive, etaExpansionTick, -- * Equality @@ -59,7 +61,7 @@ mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId, -- * unsafeEqualityProof - isUnsafeEqualityProof, + isUnsafeEqualityCase, -- * Dumping stuff dumpIdInfoOfProgram @@ -70,8 +72,11 @@ import GHC.Core import GHC.Core.Ppr +import GHC.Core.FVs( bindFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type +import GHC.Core.Predicate( isEqPred ) +import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.FamInstEnv import GHC.Core.TyCo.Compare( eqType, eqTypeX ) import GHC.Core.Coercion @@ -79,7 +84,7 @@ import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) +import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey ) import GHC.Builtin.PrimOps import GHC.Types.Var @@ -95,6 +100,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Demand +import GHC.Types.RepType (isZeroBitTy) import GHC.Data.FastString import GHC.Data.Maybe @@ -104,15 +110,15 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import Data.ByteString ( ByteString ) import Data.Function ( on ) import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) +import qualified Data.List as Partial ( init, last ) import Data.Ord ( comparing ) +import Control.Monad ( guard ) import qualified Data.Set as Set -import GHC.Types.RepType (isZeroBitTy) {- ************************************************************************ @@ -139,7 +145,7 @@ exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) = case collectArgs e of - (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args + (fun, args) -> applyTypeToArgs (exprType fun) args exprType (Type ty) = pprPanic "exprType" (ppr ty) coreAltType :: CoreAlt -> Type @@ -161,20 +167,23 @@ -- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. -- This is used, for example, when producing the type of a lambda. --- Always uses Inferred binders. +-- mkLamTypes :: [Var] -> Type -> Type -- ^ 'mkLamType' for multiple type or value arguments mkLamType v body_ty | isTyVar v - = mkForAllTy (Bndr v Inferred) body_ty + = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty + -- coreTyLamForAllTyFlag: see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep | isCoVar v , v `elemVarSet` tyCoVarsOfType body_ty - = mkForAllTy (Bndr v Required) body_ty + -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep + = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty | otherwise - = mkFunctionType (varMult v) (varType v) body_ty + = mkFunctionType (idMult v) (idType v) body_ty mkLamTypes vs ty = foldr mkLamType ty vs @@ -215,11 +224,10 @@ Note that there might be existentially quantified coercion variables, too. -} -applyTypeToArgs :: HasDebugCallStack => SDoc -> Type -> [CoreExpr] -> Type +applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type -- ^ Determines the type resulting from applying an expression with given type --- to given argument expressions. --- The first argument is just for debugging, and gives some context -applyTypeToArgs pp_e op_ty args +applyTypeToArgs op_ty args = go op_ty args where go op_ty [] = op_ty @@ -238,8 +246,7 @@ go_ty_args op_ty rev_tys args = go (piResultTys op_ty (reverse rev_tys)) args - panic_msg as = vcat [ text "Expression:" <+> pp_e - , text "Type:" <+> ppr op_ty + panic_msg as = vcat [ text "Type:" <+> ppr op_ty , text "Args:" <+> ppr args , text "Args':" <+> ppr as ] @@ -263,43 +270,30 @@ -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr -mkCast e co - | assertPpr (coercionRole co == Representational) - (text "coercion" <+> ppr co <+> text "passed to mkCast" - <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $ - isReflCo co - = e -mkCast (Coercion e_co) co - | isCoVarType (coercionRKind co) - -- The guard here checks that g has a (~#) on both sides, - -- otherwise decomposeCo fails. Can in principle happen - -- with unsafeCoerce - = Coercion (mkCoCast e_co co) - -mkCast (Cast expr co2) co - = warnPprTrace (let { from_ty = coercionLKind co; - to_ty2 = coercionRKind co2 } in - not (from_ty `eqType` to_ty2)) - "mkCast" - (vcat ([ text "expr:" <+> ppr expr - , text "co2:" <+> ppr co2 - , text "co:" <+> ppr co ])) $ - mkCast expr (mkTransCo co2 co) - -mkCast (Tick t expr) co - = Tick t (mkCast expr co) - mkCast expr co - = let from_ty = coercionLKind co in - warnPprTrace (not (from_ty `eqType` exprType expr)) + = assertPpr (coercionRole co == Representational) + (text "coercion" <+> ppr co <+> text "passed to mkCast" + <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $ + warnPprTrace (not (coercionLKind co `eqType` exprType expr)) "Trying to coerce" (text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co) $$ callStackDoc) $ - (Cast expr co) + case expr of + Cast expr co2 -> mkCast expr (mkTransCo co2 co) + Tick t expr -> Tick t (mkCast expr co) + Coercion e_co | isEqPred (coercionRKind co) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce + -> Coercion (mkCoCast e_co co) + _ | isReflCo co -> expr + | otherwise -> Cast expr co + + {- ********************************************************************* * * Attaching ticks @@ -314,7 +308,6 @@ -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t - -- mkTick' handles floating of ticks *into* the expression. -- In this function, `top` is applied after adding the tick, and `rest` before. -- This will result in applications that look like (top $ Tick t $ rest expr). @@ -325,6 +318,10 @@ -> CoreExpr -- current expression -> CoreExpr mkTick' top rest expr = case expr of + -- Float ticks into unsafe coerce the same way we would do with a cast. + Case scrut bndr ty alts@[Alt ac abs _rhs] + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs -- Cost centre ticks should never be reordered relative to each -- other. Therefore we can stop whenever two collide. @@ -510,15 +507,22 @@ case_bind = mkDefaultCase rhs bndr body let_bind = Let (NonRec bndr rhs) body --- | Tests whether we have to use a @case@ rather than @let@ binding for this --- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant" -needsCaseBinding :: Type -> CoreExpr -> Bool -needsCaseBinding ty rhs - = mightBeUnliftedType ty && not (exprOkForSpeculation rhs) - -- Make a case expression instead of a let - -- These can arise either from the desugarer, - -- or from beta reductions: (\x.e) (x +# y) +-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@ +-- binding for this expression as per the invariants of 'CoreExpr': see +-- "GHC.Core#let_can_float_invariant" +-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else +-- `typeLevity ty` will fail; but that should be the case because +-- `needsCaseBinding` is only called once typechecking is complete +needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool +needsCaseBinding ty rhs = needsCaseBindingL (typeLevity ty) rhs +needsCaseBindingL :: Levity -> CoreExpr -> Bool +-- True <=> make a case expression instead of a let +-- These can arise either from the desugarer, +-- or from beta reductions: (\x.e) (x +# y) +needsCaseBindingL Lifted _rhs = False +needsCaseBindingL Unlifted rhs = not (exprOkForSpeculation rhs) + mkAltExpr :: AltCon -- ^ Case alternative constructor -> [CoreBndr] -- ^ Things bound by the pattern match -> [Type] -- ^ The type arguments to the case alternative @@ -646,6 +650,76 @@ -} --------------------------------- +mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) +-- See Note [Merge Nested Cases] +mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) + | Just (joins, inner_alts) <- go deflt_rhs + = Just (joins, mergeAlts outer_alts inner_alts) + -- NB: mergeAlts gives priority to the left + -- case x of + -- A -> e1 + -- DEFAULT -> case x of + -- A -> e2 + -- B -> e3 + -- When we merge, we must ensure that e1 takes + -- precedence over e2 as the value for A! + where + go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt]) + + -- Whizzo: we can merge! + go (Case (Var inner_scrut_var) inner_bndr _ inner_alts) + | inner_scrut_var == outer_bndr + , not (inner_bndr == outer_bndr) -- Avoid shadowing + , let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs' + -- inner_bndr is never dead! It's the scrutinee! + -- The let is OK even for unboxed binders + -- See Note [Merge Nested Cases] wrinkle (MC2) + do_one (Alt con bndrs rhs) + | any (== outer_bndr) bndrs = Nothing + | otherwise = Just (Alt con bndrs (wrap_let rhs)) + = do { alts' <- mapM do_one inner_alts + ; return ([], alts') } + + -- Deal with tagToEnum# See Note [Merge Nested Cases] wrinkle (MC3) + go (App (App (Var f) (Type type_arg)) (Var v)) + | v == outer_bndr + , Just TagToEnumOp <- isPrimOpId_maybe f + , Just tc <- tyConAppTyCon_maybe type_arg + , Just (dc1:dcs) <- tyConDataCons_maybe tc -- At least one data constructor + , dcs `lengthAtMost` 3 -- Arbitrary + = return ( [], mk_alts dc1 dcs) + where + mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc + mk_rhs dc = Var (dataConWorkId dc) + mk_alts dc1 dcs = Alt DEFAULT [] (mk_rhs dc1) + : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs] + + -- Float out let/join bindings + -- See Note [Merge Nested Cases] wrinkle (MC4) + go (Let bind body) + | null outer_alts || isJoinBind bind + = do { (joins, alts) <- go body + + -- Check for capture; but only if we could otherwise do a merge + ; let capture = outer_bndr `elem` bindersOf bind + || outer_bndr `elemVarSet` bindFreeVars bind + ; guard (not capture) + + ; return (bind:joins, alts ) } + | otherwise + = Nothing + + -- We don't want ticks to get in the way; just push them inwards. + -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#) + go (Tick t body) + = do { (joins, alts) <- go body + ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) } + + go _ = Nothing + +mergeCaseAlts _ _ = Nothing + +--------------------------------- mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second @@ -760,7 +834,165 @@ | otherwise -- The common case = (False, all_alts) -{- Note [Refine DEFAULT case alternatives] +{- Note [Merge Nested Cases] +~~~~~~~~~~~~~~~~~~~~~~~~~ + case e of b { ==> case e of b { + p1 -> rhs1 p1 -> rhs1 + ... ... + pm -> rhsm pm -> rhsm + _ -> case b of b' { pn -> let b'=b in rhsn + pn -> rhsn ... + ... po -> let b'=b in rhso + po -> rhso _ -> let b'=b in rhsd + _ -> rhsd + } + +which merges two cases in one case when -- the default alternative of +the outer case scrutinises the same variable as the outer case. This +transformation is called Case Merging. It avoids that the same +variable is scrutinised multiple times. + +Wrinkles + +(MC1) Historical note. I tried making `mergeCaseAlts` "looks though" an inner + single-alternative case-on-variable. For example + case x of { + ...outer-alts... + DEFAULT -> case y of (a,b) -> + case x of { A -> rhs1; B -> rhs2 } + ===> + case x of + ...outer-alts... + a -> case y of (a,b) -> rhs1 + B -> case y of (a,b) -> rhs2 + + This duplicates the `case y` but it removes the case x; so it is a win + in terms of execution time (combining the cases on x) at the cost of + perhaps duplicating the `case y`. A case in point is integerEq, which + is defined thus + integerEq :: Integer -> Integer -> Bool + integerEq !x !y = isTrue# (integerEq# x y) + which becomes + integerEq + = \ (x :: Integer) (y_aAL :: Integer) -> + case x of x1 { __DEFAULT -> + case y of y1 { __DEFAULT -> + case x1 of { + IS x2 -> case y1 of { + __DEFAULT -> GHC.Types.False; + IS y2 -> tagToEnum# @Bool (==# x2 y2) }; + IP x2 -> ... + IN x2 -> ... + We want to merge the outer `case x` with the inner `case x1`. + + But (a) this is all a bit dubious: see #24251, and + (b) it is hard to combine with (MC4) + So I'm not doing this any more. If we want to do it, we'll handle it + separately: #24251. + + End of historical note + +(MC2) The auxiliary bindings b'=b are annoying, because they force another + simplifier pass, but there seems no easy way to avoid them. See + Note [Which transformations are innocuous] in GHC.Core.Opt.Stats. + +(MC3) Consider + case f x of (r::Int#) -> tagToEnum# r :: Bool + `mergeCaseAlts` as a special case to treat this as if it was + case f x of r -> + case r of { 0# -> False; 1# -> True } + which can be merged to + case f x of { 0# -> False; 1# -> True } + + To see why this is important, return to + case f x of (r::Int#) -> tagToEnum# r :: Bool + and supppose `f` inlines to a case expression. Then then we get + let $j r = tagToEnum# r + case .. of { .. jump $j 0#; ...jump $j 1# ... } + Now if the entire expression is consumed by another case-expression, + that outer case will only see (tagToEnum# r) which it can't do much + with. Whereas the result of the above case-merge generates much better + code: no branching on Int# + +(MC4) Consider + case f x of r -> + join $j y = in + case r of { ...alts ... } + This is pretty common, and it a pity for it to defeat the case-merge + transformation; and it makes the optimiser fragile to inlining decisions + for join points. + + So `mergeCaseAlts` floats out any join points. It doesn't float out + non-join-points unless the /outer/ case has just one alternative; doing + so would risk more allocation + +(MC5) See Note [Cascading case merge] + +See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils + + +Note [Cascading case merge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Case merging should cascade in one sweep, because the Simplifier tries it /after/ +simplifying (and hence case-merging) the inner case. For example + + case e of a { + DEFAULT -> case a of b + DEFAULT -> case b of c { + DEFAULT -> e + A -> ea + B -> eb + C -> ec +==> {simplify inner case} + case e of a { + DEFAULT -> case a of b + DEFAULT -> let c = b in e + A -> let c = b in ea + B -> eb + C -> ec +==> {case-merge on outer case} + case e of a { + DEFAULT -> let b = a in let c = b in e + A -> let b = a in let c = b in ea + B -> let b = a in eb + C -> ec + + +However here's a tricky case that we still don't catch, and I don't +see how to catch it in one pass: + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +After occurrence analysis (and its binder-swap) we get this + + case x of c1 { I# a1 -> + let x = c1 in -- Binder-swap addition + case a1 of c2 -> + 0 -> ... + DEFAULT -> case x of c3 { I# a2 -> + case a2 of ... + +When we simplify the inner case x, we'll see that +x=c1=I# a1. So we'll bind a2 to a1, and get + + case x of c1 { I# a1 -> + case a1 of c2 -> + 0 -> ... + DEFAULT -> case a1 of ... + +This is correct, but we can't do a case merge in this sweep +because c2 /= a1. Reason: the binding c1=I# a1 went inwards +without getting changed to c1=I# c2. + +I don't think this is worth fixing, even if I knew how. It'll +all come out in the next pass anyway. + + +Note [Refine DEFAULT case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one possible value it could be. @@ -1025,7 +1257,7 @@ Ticks are only trivial if they are pure annotations. If we treat "tick x" as trivial, it will be inlined inside lambdas and the entry count will be skewed, for example. Furthermore "scc x" will -turn into just "x" in mkTick. +turn into just "x" in mkTick. At least if `x` is not a function. Note [Empty case is trivial] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1064,15 +1296,25 @@ -- * `case e of {}` an empty case trivial_expr_fold k_id k_lit k_triv k_not_triv = go where + -- If you change this function, be sure to change + -- SetLevels.notWorthFloating as well! + -- (Or yet better: Come up with a way to share code with this function.) go (Var v) = k_id v -- See Note [Variables are trivial] go (Lit l) | litIsTrivial l = k_lit l go (Type _) = k_triv go (Coercion _) = k_triv - go (App f t) | not (isRuntimeArg t) = go f + go (App f arg) + | not (isRuntimeArg arg) = go f + | exprIsUnaryClassFun f = go arg + | otherwise = k_not_triv go (Lam b e) | not (isRuntimeVar b) = go e go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial] go (Cast e _) = go e - go (Case e _ _ []) = go e -- See Note [Empty case is trivial] + go (Case e b _ as) + | null as + = go e -- See Note [Empty case is trivial] + | Just rhs <- isUnsafeEqualityCase e b as + = go rhs -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce go _ = k_not_triv exprIsTrivial :: CoreExpr -> Bool @@ -1259,18 +1501,23 @@ in \w. v True -} --------------------- -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree e = exprIsCheapX isWorkFreeApp e - -exprIsCheap :: CoreExpr -> Bool -exprIsCheap e = exprIsCheapX isCheapApp e +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool {-# INLINE exprIsCheapX #-} --- allow specialization of exprIsCheap and exprIsWorkFree +-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable -- instead of having an unknown call to ok_app -exprIsCheapX ok_app e +-- expandable=True <=> Treat Case and Let as cheap, if their sub-expressions are. +-- This flag is set for exprIsExpandable +exprIsCheapX ok_app expandable e = ok e where ok e = go 0 e @@ -1281,7 +1528,7 @@ go _ (Type {}) = True go _ (Coercion {}) = True go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = ok scrut && + go n (Case scrut _ _ alts) = not expandable && ok scrut && and [ go n rhs | Alt _ _ rhs <- alts ] go n (Tick t e) | tickishCounts t = False | otherwise = go n e @@ -1289,90 +1536,26 @@ | otherwise = go n e go n (App f e) | isRuntimeArg e = go (n+1) f && ok e | otherwise = go n f - go n (Let (NonRec _ r) e) = go n e && ok r - go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + go n (Let (NonRec _ r) e) = not expandable && go n e && ok r + go n (Let (Rec prs) e) = not expandable && go n e && all (ok . snd) prs -- Case: see Note [Case expressions are work-free] -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] - -{- Note [exprIsExpandable] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -An expression is "expandable" if we are willing to duplicate it, if doing -so might make a RULE or case-of-constructor fire. Consider - let x = (a,b) - y = build g - in ....(case x of (p,q) -> rhs)....(foldr k z y).... - -We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), -but we do want - - * the case-expression to simplify - (via exprIsConApp_maybe, exprIsLiteral_maybe) - - * the foldr/build RULE to fire - (by expanding the unfolding during rule matching) - -So we classify the unfolding of a let-binding as "expandable" (via the -uf_expandable field) if we want to do this kind of on-the-fly -expansion. Specifically: - -* True of constructor applications (K a b) - -* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. - (NB: exprIsCheap might not be true of this) - -* False of case-expressions. If we have - let x = case ... in ...(case x of ...)... - we won't simplify. We have to inline x. See #14688. - -* False of let-expressions (same reason); and in any case we - float lets out of an RHS if doing so will reveal an expandable - application (see SimplEnv.doFloatFromRhs). - -* Take care: exprIsExpandable should /not/ be true of primops. I - found this in test T5623a: - let q = /\a. Ptr a (a +# b) - in case q @ Float of Ptr v -> ...q... +-------------------- +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e - q's inlining should not be expandable, else exprIsConApp_maybe will - say that (q @ Float) expands to (Ptr a (a +# b)), and that will - duplicate the (a +# b) primop, which we should not do lightly. - (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) --} +-------------------- +exprIsCheap :: CoreExpr -> Bool +-- See Note [exprIsCheap] +exprIsCheap e = exprIsCheapX isCheapApp False e -------------------------------------- +-------------------- exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable] -exprIsExpandable e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = isExpandableApp v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Tick t e) | tickishCounts t = False - | otherwise = go n e - go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e - | otherwise = go n e - go n (App f e) | isRuntimeArg e = go (n+1) f && ok e - | otherwise = go n f - go _ (Case {}) = False - go _ (Let {}) = False - - -------------------------------------- -type CheapAppFun = Id -> Arity -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? - -- True mainly of data constructors, partial applications; - -- but with minor variations: - -- isWorkFreeApp - -- isCheapApp +exprIsExpandable e = exprIsCheapX isExpandableApp True e isWorkFreeApp :: CheapAppFun isWorkFreeApp fn n_val_args @@ -1383,6 +1566,7 @@ | otherwise = case idDetails fn of DataConWorkId {} -> True + PrimOpId op _ -> primOpIsWorkFree op _ -> False isCheapApp :: CheapAppFun @@ -1391,7 +1575,7 @@ | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] | otherwise = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId op _ -> primOpIsCheap op @@ -1406,6 +1590,7 @@ | isWorkFreeApp fn n_val_args = True | otherwise = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 PrimOpId {} -> False @@ -1437,6 +1622,50 @@ I'm not sure why we have a special case for bottoming functions in isCheapApp. Maybe we don't need it. +Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) + Note [isExpandableApp: bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that isExpandableApp does not respond True to bottoming @@ -1480,45 +1709,73 @@ So we treat the application of a function (negate in this case) to a *dictionary* as expandable. In effect, every function is CONLIKE when it's applied only to dictionaries. +-} +isUnaryClassId :: Id -> Bool +-- True of (a) the method selector (classop) +-- (b) the dictionary data constructor +-- of a unary class +isUnaryClassId v + | Just cls <- isClassOpId_maybe v = isUnaryClass cls + | Just dc <- isDataConWorkId_maybe v = isUnaryClassDataCon dc + | otherwise = False -************************************************************************ +exprIsUnaryClassFun :: CoreExpr -> Bool +-- True of an a type application (f @t1 .. @tn), +-- where `f` is a unary-class-id +-- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon +exprIsUnaryClassFun (App f (Type {})) = exprIsUnaryClassFun f +exprIsUnaryClassFun (Var v) = isUnaryClassId v +exprIsUnaryClassFun _ = False + + +{- ********************************************************************* * * exprOkForSpeculation * * -************************************************************************ --} +********************************************************************* -} ----------------------------- --- | 'exprOkForSpeculation' returns True of an expression that is: +-- | To a first approximation, 'exprOkForSpeculation' returns True of +-- an expression that is: -- -- * Safe to evaluate even if normal order eval might not --- evaluate the expression at all, or +-- evaluate the expression at all, and -- -- * Safe /not/ to evaluate even if normal order would do so -- --- It is usually called on arguments of unlifted type, but not always --- In particular, Simplify.rebuildCase calls it on lifted types --- when a 'case' is a plain 'seq'. See the example in --- Note [exprOkForSpeculation: case expressions] below +-- More specifically, this means that: +-- * A: Evaluation of the expression reaches weak-head-normal-form, +-- * B: soon, +-- * C: without causing a write side effect (e.g. writing a mutable variable). -- --- Precisely, it returns @True@ iff: --- a) The expression guarantees to terminate, --- b) soon, --- c) without causing a write side effect (e.g. writing a mutable variable) --- d) without throwing a Haskell exception --- e) without risking an unchecked runtime exception (array out of bounds, --- divide by zero) +-- In particular, an expression that may +-- * throw a synchronous Haskell exception, or +-- * risk an unchecked runtime exception (e.g. array +-- out of bounds, divide by zero) +-- is /not/ considered OK-for-speculation, as these violate condition A. -- --- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- For 'exprOkToDiscard', condition A is weakened to allow expressions +-- that might risk an unchecked runtime exception but must otherwise +-- reach weak-head-normal-form. +-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard') -- --- Note that --- exprIsHNF implies exprOkForSpeculation --- exprOkForSpeculation implies exprOkForSideEffects +-- But in fact both functions are a bit more conservative than the above, +-- in at least the following ways: -- --- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps" --- and Note [Transformations affected by can_fail and has_side_effects] +-- * W1: We do not take advantage of already-evaluated lifted variables. +-- As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation'; +-- if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is +-- 'True', while @exprOkForSpeculation y@ is 'False'. +-- See Note [exprOkForSpeculation and evaluated variables] for why. +-- * W2: Read-effects on mutable variables are currently also included. +-- See Note [Classifying primop effects] "GHC.Builtin.PrimOps". +-- * W3: Currently, 'exprOkForSpeculation' always returns 'False' for +-- let-expressions. Lets can be stacked deeply, so we just give up. +-- In any case, the argument of 'exprOkForSpeculation' is usually in +-- a strict context, so any lets will have been floated away. -- +-- -- As an example of the considerations in this test, consider: -- -- > let x = case y# +# 1# of { r# -> I# r# } @@ -1531,12 +1788,24 @@ -- > in E -- > } -- --- We can only do this if the @y + 1@ is ok for speculation: it has no +-- We can only do this if the @y# +# 1#@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception. +-- +-- +-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps" +-- and Note [Transformations affected by primop effects]. +-- +-- 'exprOkForSpeculation' is used to define Core's let-can-float +-- invariant. (See Note [Core let-can-float invariant] in +-- "GHC.Core".) It is therefore frequently called on arguments of +-- unlifted type, especially via 'needsCaseBinding'. But it is +-- sometimes called on expressions of lifted type as well. For +-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep". -exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool + +exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation -exprOkForSideEffects = expr_ok fun_always_ok primOpOkForSideEffects +exprOkToDiscard = expr_ok fun_always_ok primOpOkToDiscard fun_always_ok :: Id -> Bool fun_always_ok _ = True @@ -1566,10 +1835,7 @@ | otherwise = expr_ok fun_ok primop_ok e expr_ok _ _ (Let {}) = False - -- Lets can be stacked deeply, so just give up. - -- In any case, the argument of exprOkForSpeculation is - -- usually in a strict context, so any lets will have been - -- floated away. +-- See W3 in the Haddock comment for exprOkForSpeculation expr_ok fun_ok primop_ok (Case scrut bndr _ alts) = -- See Note [exprOkForSpeculation: case expressions] @@ -1597,20 +1863,27 @@ _ -> False ----------------------------- -app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool app_ok fun_ok primop_ok fun args | not (fun_ok fun) = False -- This code path is only taken for Note [Speculative evaluation] + + | idArity fun > n_val_args + -- Partial application: just check passing the arguments is OK + = args_ok + | otherwise = case idDetails fun of - DFunId new_type -> not new_type + DFunId unary_class -> not unary_class -- DFuns terminate, unless the dict is implemented - -- with a newtype in which case they may not + -- by a no-op in which case they may not + -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon - DataConWorkId {} -> True - -- The strictness of the constructor has already - -- been expressed by its "wrapper", so we don't need - -- to take the arguments into account + DataConWorkId dc + | isLazyDataConRep dc + -> args_ok + | otherwise + -> fields_ok (dataConRepStrictness dc) ClassOpId _ is_terminating_result | is_terminating_result -- See Note [exprOkForSpeculation and type classes] @@ -1621,10 +1894,10 @@ PrimOpId op _ | primOpIsDiv op - , Lit divisor <- last args + , Lit divisor <- Partial.last args -- there can be 2 args (most div primops) or 3 args -- (WordQuotRem2Op), hence the use of last/init - -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (init args) + -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args) -- Special case for dividing operations that fail -- In general they are NOT ok-for-speculation -- (which primop_ok will catch), but they ARE OK @@ -1632,16 +1905,7 @@ -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner loop - | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] - -> False -- for the special cases for SeqOp and DataToTagOp - | DataToTagOp <- op - -> False - | KeepAliveOp <- op - -> False - - | otherwise - -> primop_ok op -- Check the primop itself - && and (zipWith arg_ok arg_tys args) -- Check the arguments + | otherwise -> primop_ok op && args_ok _other -- Unlifted and terminating types; -- Also c.f. the Var case of exprIsHNF @@ -1654,12 +1918,8 @@ -- (If we added unlifted function types this would change, -- and we'd need to actually test n_val_args == 0.) - -- Partial applications - | idArity fun > n_val_args -> - and (zipWith arg_ok arg_tys args) -- Check the arguments - -- Functions that terminate fast without raising exceptions etc - -- See Note [Discarding unnecessary unsafeEqualityProofs] + -- See (U12) of Note [Implementing unsafeCoerce] | fun `hasKey` unsafeEqualityProofIdKey -> True | otherwise -> False @@ -1671,21 +1931,35 @@ n_val_args = valArgCount args (arg_tys, _) = splitPiTys fun_ty - -- Used for arguments to primops and to partial applications + -- Even if a function call itself is OK, any unlifted + -- args are still evaluated eagerly and must be checked + args_ok = all2Prefix arg_ok arg_tys args arg_ok :: PiTyVarBinder -> CoreExpr -> Bool arg_ok (Named _) _ = True -- A type argument arg_ok (Anon ty _) arg -- A term argument | definitelyLiftedType (scaledThing ty) - = True -- See Note [Primops with lifted arguments] + = True -- lifted args are not evaluated eagerly | otherwise = expr_ok fun_ok primop_ok arg + -- Used for strict DataCon worker arguments + -- See (SFC1) of Note [Strict fields in Core] + fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args + field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool + field_ok (Named _) _ _ = True + field_ok (Anon ty _) str arg + | NotMarkedStrict <- str -- iff it's a lazy field + , definitelyLiftedType (scaledThing ty) -- and its type is lifted + = True -- then the worker app does not eval + | otherwise + = expr_ok fun_ok primop_ok arg + ----------------------------- altsAreExhaustive :: [Alt b] -> Bool -- True <=> the case alternatives are definitely exhaustive -- False <=> they may or may not be altsAreExhaustive [] - = False -- Should not happen + = True -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core altsAreExhaustive (Alt con1 _ _ : alts) = case con1 of DEFAULT -> True @@ -1823,78 +2097,37 @@ ------- End of historical note ------------ -Note [Primops with lifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Is this ok-for-speculation (see #13027)? - reallyUnsafePtrEquality# a b -Well, yes. The primop accepts lifted arguments and does not -evaluate them. Indeed, in general primops are, well, primitive -and do not perform evaluation. - -Bottom line: - * In exprOkForSpeculation we simply ignore all lifted arguments. - * In the rare case of primops that /do/ evaluate their arguments, - (namely DataToTagOp and SeqOp) return False; see - Note [exprOkForSpeculation and evaluated variables] - -Note [exprOkForSpeculation and SeqOp/DataToTagOp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most primops with lifted arguments don't evaluate them -(see Note [Primops with lifted arguments]), so we can ignore -that argument entirely when doing exprOkForSpeculation. - -But DataToTagOp and SeqOp are exceptions to that rule. -For reasons described in Note [exprOkForSpeculation and -evaluated variables], we simply return False for them. - -Not doing this made #5129 go bad. -Lots of discussion in #15696. - Note [exprOkForSpeculation and evaluated variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that - seq# :: forall a s. a -> State# s -> (# State# s, a #) - dataToTag# :: forall a. a -> Int# -must always evaluate their first argument. - -Now consider these examples: +Consider these examples: * case x of y { DEFAULT -> ....y.... } Should 'y' (alone) be considered ok-for-speculation? - * case x of y { DEFAULT -> ....let z = dataToTag# y... } - Should (dataToTag# y) be considered ok-for-spec? + * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... } + Should (dataToTagLarge# y) be considered ok-for-spec? Recall that + dataToTagLarge# :: forall a. a -> Int# + must always evaluate its argument. (See also Note [DataToTag overview].) You could argue 'yes', because in the case alternative we know that 'y' is evaluated. But the binder-swap transformation, which is extremely useful for float-out, changes these expressions to case x of y { DEFAULT -> ....x.... } - case x of y { DEFAULT -> ....let z = dataToTag# x... } + case x of y { DEFAULT -> ....let z = dataToTagLarge# x... } And now the expression does not obey the let-can-float invariant! Yikes! -Moreover we really might float (dataToTag# x) outside the case, +Moreover we really might float (dataToTagLarge# x) outside the case, and then it really, really doesn't obey the let-can-float invariant. The solution is simple: exprOkForSpeculation does not try to take advantage of the evaluated-ness of (lifted) variables. And it returns -False (always) for DataToTagOp and SeqOp. +False (always) for primops that perform evaluation. We achieve the latter +by marking the relevant primops as "ThrowsException" or +"ReadWriteEffect"; see also Note [Classifying primop effects] in +GHC.Builtin.PrimOps. Note that exprIsHNF /can/ and does take advantage of evaluated-ness; it doesn't have the trickiness of the let-can-float invariant to worry about. -Note [Discarding unnecessary unsafeEqualityProofs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #20143 we found - case unsafeEqualityProof @t1 @t2 of UnsafeRefl cv[dead] -> blah -where 'blah' didn't mention 'cv'. We'd like to discard this -redundant use of unsafeEqualityProof, via GHC.Core.Opt.Simplify.rebuildCase. -To do this we need to know - (a) that cv is unused (done by OccAnal), and - (b) that unsafeEqualityProof terminates rapidly without side effects. - -At the moment we check that explicitly here in exprOkForSideEffects, -but one might imagine a more systematic check in future. - - ************************************************************************ * * exprIsHNF, exprIsConLike @@ -1906,17 +2139,18 @@ -- ~~~~~~~~~~~~~~~~ -- | exprIsHNF returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form. This is used to decide whether it's ok --- to change: +-- to perform case-to-let for lifted expressions, which changes: -- --- > case x of _ -> e +-- > case x of x' { _ -> e } -- -- into: -- --- > e +-- > let x' = x in e -- --- and to decide whether it's safe to discard a 'seq'. +-- and in so doing makes the binding lazy. -- -- So, it does /not/ treat variables as evaluated, unless they say they are. +-- -- However, it /does/ treat partial applications and constructor applications -- as values, even if their arguments are non-trivial, provided the argument -- type is lifted. For example, both of these are values: @@ -1946,12 +2180,14 @@ -- or PAPs. -- exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like +exprIsHNFlike is_con is_con_unf e + = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $ + is_hnf_like e where is_hnf_like (Var v) -- NB: There are no value args at this point - = id_app_is_value v 0 -- Catches nullary constructors, - -- so that [] and () are values, for example - -- and (e.g.) primops that don't have unfoldings + = id_app_is_value v [] -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings || is_con_unf (idUnfolding v) -- Check the thing's unfolding; it might be bound to a value -- or to a guaranteed-evaluated variable (isEvaldUnfolding) @@ -1975,32 +2211,79 @@ -- See Note [exprIsHNF Tick] is_hnf_like (Cast e _) = is_hnf_like e is_hnf_like (App e a) - | isValArg a = app_is_value e 1 + | isValArg a = app_is_value e [a] | otherwise = is_hnf_like e is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like (Case e b _ as) + | Just rhs <- isUnsafeEqualityCase e b as + = is_hnf_like rhs is_hnf_like _ = False - -- 'n' is the number of value args to which the expression is applied - -- And n>0: there is at least one value argument - app_is_value :: CoreExpr -> Int -> Bool - app_is_value (Var f) nva = id_app_is_value f nva - app_is_value (Tick _ f) nva = app_is_value f nva - app_is_value (Cast f _) nva = app_is_value f nva - app_is_value (App f a) nva - | isValArg a = - app_is_value f (nva + 1) && - not (needsCaseBinding (exprType a) a) - -- For example f (x /# y) where f has arity two, and the first - -- argument is unboxed. This is not a value! - -- But f 34# is a value. - -- NB: Check app_is_value first, the arity check is cheaper - | otherwise = app_is_value f nva - app_is_value _ _ = False + -- Collect arguments through Casts and Ticks and call id_app_is_value + app_is_value :: CoreExpr -> [CoreArg] -> Bool + app_is_value (Var f) as = id_app_is_value f as + app_is_value (Tick _ f) as = app_is_value f as + app_is_value (Cast f _) as = app_is_value f as + app_is_value (App f a) as | isValArg a = app_is_value f (a:as) + | otherwise = app_is_value f as + app_is_value _ _ = False - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args + id_app_is_value id val_args + | Just dc <- isDataConWorkId_maybe id + , isUnaryClassDataCon dc + = all is_hnf_like val_args -- Look through unary class data cons + | otherwise + -- See Note [exprIsHNF for function applications] + -- for the specification and examples + = case compare (idArity id) (length val_args) of + EQ | is_con id -> -- Saturated app of a DataCon/CONLIKE Id + case mb_str_marks id of + Just str_marks -> -- with strict fields; see (SFC1) of Note [Strict fields in Core] + assert (val_args `equalLength` str_marks) $ + fields_hnf str_marks + Nothing -> -- without strict fields: like PAP + args_hnf -- NB: CONLIKEs are lazy! + GT -> -- PAP: Check unlifted val_args + args_hnf + + _ -> False + + where + -- Saturated, Strict DataCon: Check unlifted val_args and strict fields + fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args + + -- PAP: Check unlifted val_args + args_hnf = all2Prefix check_arg val_arg_tys val_args + + fun_ty = idType id + val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty) + -- val_arg_tys = map exprType val_args, but much less costly. + -- The obvious definition regresses T16577 by 30% so we don't do it. + + check_arg a_ty a + | mightBeUnliftedType a_ty = is_hnf_like a + | otherwise = True + -- Check unliftedness; for example f (x /# 12#) where f has arity two, + -- and the first argument is unboxed. This is not a value! + -- But f 34# is a value, so check args for HNFs. + -- NB: We check arity (and CONLIKEness) first because it's cheaper + -- and we reject quickly on saturated apps. + check_field a_ty str a + | mightBeUnliftedType a_ty = is_hnf_like a + | isMarkedStrict str = is_hnf_like a + | otherwise = True + -- isMarkedStrict: Respect Note [Strict fields in Core] + + mb_str_marks id + | Just dc <- isDataConWorkId_maybe id + , not (isLazyDataConRep dc) + = Just (dataConRepStrictness dc) + | otherwise + = Nothing + +{-# INLINE exprIsHNFlike #-} + {- Note [exprIsHNF Tick] ~~~~~~~~~~~~~~~~~~~~~ @@ -2014,6 +2297,58 @@ regarded as HNF if the expression they surround is HNF, because the tick is there to tell us that the expression was evaluated, so we don't want to discard a seq on it. + +Note [exprIsHNF for function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an application with an Id head where the argument is a redex: + + f + +Is this expression a value? + +The answer depends on the type of `f`, its arity and whether or not it is a +strict data constructor. The decision diagram is as follows: + +* If is unlifted, it is *not* a value (regardless of arity!) +* Otherwise, is lifted. + Does its `idArity` (a lower bound on the actual arity) + exceed the number of actual arguments (= 1)? + * If so, it is a PAP and thus a value + * If not, it is a saturated call. + Is it a lazy data constructor? Then it is a value. + Is it a strict data constructor? Then it is *not* a value. (See also Note [Strict fields in Core].) + Otherwise, it is a regular, possibly saturated function call, and hence *not* a value. + +The code in exprIsHNF is tweaked for efficiency, hence it delays the +unliftedness check after the arity check. + +Here are a few examples (enshrined in testcase AppIsHNF) to bring home this +point. Let us say that + + f :: Int# -> Int -> Int -> Int, with idArity 3 + expensive# :: Int -> Int# -- unlifted result + expensive :: Int -> Int -- lifted result + data T where + K1 :: !Int -> Int -> T -- strict field + K2 :: Int# -> Int -> T -- unlifted field + +Now consider + + f (expensive# 1) 2 -- Not HNF + f 1# (expensive 2) -- HNF + + K1 1 (expensive 2) -- HNF + K1 (expensive 1) 2 -- Not HNF + K1 (expensive 1) -- HNF (!) + + K2 1# (expensive 1) -- HNF + K2 (expensive# 1) 2 -- Not HNF + K2 (expensive# 1) -- Not HNF (!) + +Note that the cases marked (!) exemplify that strict fields are different to +unlifted fields when considering partial applications: Unlifted fields are +evaluated eagerly whereas evaluation of strict fields is delayed until the call +is saturated. -} -- | Can we bind this 'CoreExpr' at the top level? @@ -2388,11 +2723,16 @@ -- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@ -- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through -- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix. +-- +-- Postcondition: tc is not a newtype (guaranteed by topNormaliseType_maybe) normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) normSplitTyConApp_maybe fam_envs ty | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty `orElse` (mkReflRedn Representational ty) , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + , not (isNewTyCon tc) -- How can tc be a newtype, after `topNormaliseType`? + -- Answer: if it is a recursive newtype, `topNormaliseType` + -- may be a no-op. Example: tc226 = Just (tc, tc_args, co) normSplitTyConApp_maybe _ _ = Nothing @@ -2560,7 +2900,7 @@ The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated. But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated -already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this. +already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this. This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good. We only apply this when we think there is a benefit in doing so however. There are a number of cases in which @@ -2653,7 +2993,7 @@ 5) Functions -Functions are tricky (see Note [TagInfo of functions] in InferTags). +Functions are tricky (see Note [TagInfo of functions] in EnforceEpt). But the gist of it even if we make a higher order function argument strict we can't avoid the tag check when it's used later in the body. So there is no benefit. @@ -2672,7 +3012,7 @@ -- When we strictify we want to skip strict args otherwise the logic is the same -- as for shouldUseCbvForId so we common up the logic here. --- Basically returns true if it would be benefitial for runtime to pass this argument +-- Basically returns true if it would be beneficial for runtime to pass this argument -- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args -- we are not allowed to force. wantCbvForId :: Bool -> Var -> Bool @@ -2685,7 +3025,7 @@ -- See Note [Which Ids should be strictified] point 2) , mightBeLiftedType ty -- Functions sometimes get a zero tag so we can't eliminate the tag check. - -- See Note [TagInfo of functions] in InferTags. + -- See Note [TagInfo of functions] in EnforceEpt. -- See Note [Which Ids should be strictified] point 5) , not $ isFunTy ty -- If the var is strict already a seq is redundant. @@ -2707,11 +3047,20 @@ * * ********************************************************************* -} -isUnsafeEqualityProof :: CoreExpr -> Bool +isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr -- See (U3) and (U4) in -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce -isUnsafeEqualityProof e - | Var v `App` Type _ `App` Type _ `App` Type _ <- e - = v `hasKey` unsafeEqualityProofIdKey +isUnsafeEqualityCase scrut bndr alts + | [Alt ac _ rhs] <- alts + , DataAlt dc <- ac + , dc `hasKey` unsafeReflDataConKey + , isDeadBinder bndr + -- We can only discard the case if the case-binder is dead + -- It usually is, but see #18227 + , Var v `App` _ `App` _ `App` _ <- scrut + , v `hasKey` unsafeEqualityProofIdKey + -- Check that the scrutinee really is unsafeEqualityProof + -- and not, say, error + = Just rhs | otherwise - = False + = Nothing diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs --- a/GHC/CoreToIface.hs +++ b/GHC/CoreToIface.hs @@ -43,16 +43,13 @@ , toIfaceVar -- * Other stuff , toIfaceLFInfo - -- * CgBreakInfo - , dehydrateCgBreakInfo + , toIfaceBooleanFormula ) where import GHC.Prelude import GHC.StgToCmm.Types -import GHC.ByteCode.Types - import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom @@ -62,13 +59,14 @@ import GHC.Core.PatSyn import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.TyCo.Tidy ( tidyCo ) +import GHC.Core.TyCo.Tidy import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Types ( heqTyCon ) import GHC.Iface.Syntax import GHC.Data.FastString +import GHC.Data.BooleanFormula qualified as BF(BooleanFormula(..)) import GHC.Types.Id import GHC.Types.Id.Info @@ -82,12 +80,14 @@ import GHC.Types.Tickish import GHC.Types.Demand ( isNopSig ) import GHC.Types.Cpr ( topCprSig ) +import GHC.Types.SrcLoc (unLoc) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import GHC.Hs.Extension (GhcRn) + import Data.Maybe ( isNothing, catMaybes ) {- Note [Avoiding space leaks in toIface*] @@ -122,7 +122,7 @@ toIfaceTvBndr = toIfaceTvBndrX emptyVarSet toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr -toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) +toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar)) , toIfaceTypeX fr (tyVarKind tyvar) ) @@ -134,7 +134,7 @@ toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar) - , occNameFS (getOccName covar) + , mkIfLclName (occNameFS (getOccName covar)) , toIfaceTypeX fr (varType covar) ) @@ -177,7 +177,7 @@ -- translates the tyvars in 'free' as IfaceFreeTyVars -- -- Synonyms are retained in the interface type -toIfaceTypeX fr (TyVarTy tv) -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type +toIfaceTypeX fr (TyVarTy tv) -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type | tv `elemVarSet` fr = IfaceFreeTyVar tv | otherwise = IfaceTyVar (toIfaceTyVar tv) toIfaceTypeX fr ty@(AppTy {}) = @@ -219,11 +219,11 @@ arity = tyConArity tc n_tys = length tys -toIfaceTyVar :: TyVar -> FastString -toIfaceTyVar = occNameFS . getOccName +toIfaceTyVar :: TyVar -> IfLclName +toIfaceTyVar = mkIfLclName . occNameFS . getOccName -toIfaceCoVar :: CoVar -> FastString -toIfaceCoVar = occNameFS . getOccName +toIfaceCoVar :: CoVar -> IfLclName +toIfaceCoVar = mkIfLclName . occNameFS . getOccName ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon @@ -265,7 +265,7 @@ toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x -toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x) toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x ---------------- @@ -284,24 +284,23 @@ go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) go (CoVarCo cv) - -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type - | cv `elemVarSet` fr = IfaceFreeCoVar cv - | otherwise = IfaceCoVarCo (toIfaceCoVar cv) - go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) + -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type + | cv `elemVarSet` fr = IfaceFreeCoVar cv + | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) - go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) - go (SymCo co) = IfaceSymCo (go co) - go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) - go (SelCo d co) = IfaceSelCo d (go co) - go (LRCo lr co) = IfaceLRCo lr (go co) - go (InstCo co arg) = IfaceInstCo (go co) (go arg) - go (KindCo c) = IfaceKindCo (go c) - go (SubCo co) = IfaceSubCo (go co) - go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) - go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) - go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r - (toIfaceTypeX fr t1) - (toIfaceTypeX fr t2) + go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) + go (SymCo co) = IfaceSymCo (go co) + go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) + go (SelCo d co) = IfaceSelCo d (go co) + go (LRCo lr co) = IfaceLRCo lr (go co) + go (InstCo co arg) = IfaceInstCo (go co) (go arg) + go (KindCo c) = IfaceKindCo (go c) + go (SubCo co) = IfaceSubCo (go co) + go (AxiomCo ax cs) = IfaceAxiomCo (toIfaceAxiomRule ax) (map go cs) + go (UnivCo { uco_prov = p, uco_role = r, uco_lty = t1, uco_rty = t2, uco_deps = deps }) + = IfaceUnivCo p r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) (map go deps) + go co@(TyConAppCo r tc cos) = assertPpr (isNothing (tyConAppFunCo_maybe r tc cos)) (ppr co) $ IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) @@ -309,17 +308,20 @@ go (FunCo { fco_role = r, fco_mult = w, fco_arg = co1, fco_res = co2 }) = IfaceFunCo r (go w) (go co1) (go co2) - go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) - (toIfaceCoercionX fr' k) - (toIfaceCoercionX fr' co) + go (ForAllCo tv visL visR k co) + = IfaceForAllCo (toIfaceBndr tv) + visL + visR + (toIfaceCoercionX fr' k) + (toIfaceCoercionX fr' co) where fr' = fr `delVarSet` tv - go_prov :: UnivCoProvenance -> IfaceUnivCoProv - go_prov (PhantomProv co) = IfacePhantomProv (go co) - go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) - go_prov (PluginProv str) = IfacePluginProv str - go_prov (CorePrepProv b) = IfaceCorePrepProv b +toIfaceAxiomRule :: CoAxiomRule -> IfaceAxiomRule +toIfaceAxiomRule (BuiltInFamRew bif) = IfaceAR_X (mkIfLclName (bifrw_name bif)) +toIfaceAxiomRule (BuiltInFamInj bif) = IfaceAR_X (mkIfLclName (bifinj_name bif)) +toIfaceAxiomRule (BranchedAxiom ax i) = IfaceAR_B (coAxiomName ax) i +toIfaceAxiomRule (UnbranchedAxiom ax) = IfaceAR_U (coAxiomName ax) toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet @@ -432,10 +434,10 @@ toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang toIfaceLetBndr :: Id -> IfaceLetBndr -toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) +toIfaceLetBndr id = IfLetBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id)) (toIfaceIdInfo (idInfo id)) - (toIfaceJoinInfo (isJoinId_maybe id)) + (idJoinPointHood id) -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax @@ -443,7 +445,7 @@ toIfaceTopBndr id = if isExternalName name then IfGblTopBndr name - else IfLclTopBndr (occNameFS (getOccName id)) (toIfaceType (idType id)) + else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id)) (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id)) where name = getName id @@ -502,10 +504,6 @@ inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing | otherwise = Just (HsInline inline_prag) -toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo -toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar -toIfaceJoinInfo Nothing = IfaceNotJoinPoint - -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs @@ -540,6 +538,14 @@ , isStableSource src = IfWhen arity unsat_ok boring_ok | otherwise = IfNoGuidance +toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula +toIfaceBooleanFormula = go + where + go (BF.Var nm ) = IfVar $ mkIfLclName . getOccFS . unLoc $ nm + go (BF.And bfs ) = IfAnd $ map (go . unLoc) bfs + go (BF.Or bfs ) = IfOr $ map (go . unLoc) bfs + go (BF.Parens bf) = IfParens $ (go . unLoc) bf + {- ************************************************************************ * * @@ -558,12 +564,10 @@ toIfaceExpr (App f a) = toIfaceApp f [a] toIfaceExpr (Case s x ty as) | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) - | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) + | otherwise = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as) toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) -toIfaceExpr (Tick t e) - | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) - | otherwise = toIfaceExpr e +toIfaceExpr (Tick t e) = IfaceTick (toIfaceTickish t) (toIfaceExpr e) toIfaceOneShot :: Id -> IfaceOneShot toIfaceOneShot id | isId id @@ -573,13 +577,13 @@ = IfaceNoOneShot --------------------- -toIfaceTickish :: CoreTickish -> Maybe IfaceTickish -toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) -toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) -toIfaceTickish (SourceNote src (LexicalFastString names)) = Just (IfaceSource src names) -toIfaceTickish (Breakpoint {}) = Nothing - -- Ignore breakpoints, since they are relevant only to GHCi, and - -- should not be serialised (#8333) +toIfaceTickish :: CoreTickish -> IfaceTickish +toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push +toIfaceTickish (HpcTick modl ix) = IfaceHpcTick modl ix +toIfaceTickish (SourceNote src (LexicalFastString names)) = + IfaceSource src names +toIfaceTickish (Breakpoint _ ix fv) = + IfaceBreakpoint ix (toIfaceVar <$> fv) --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr @@ -604,7 +608,7 @@ in (top_bndr, rhs') -- The sharing behaviour is currently disabled due to #22807, and relies on - -- finished #220056 to be re-enabled. + -- finished #20056 to be re-enabled. disabledDueTo22807 = True already_has_unfolding b = not disabledDueTo22807 @@ -615,7 +619,7 @@ --------------------- toIfaceAlt :: CoreAlt -> IfaceAlt -toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) +toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r) --------------------- toIfaceCon :: AltCon -> IfaceConAlt @@ -623,7 +627,7 @@ toIfaceCon (LitAlt l) = assertPpr (not (isLitRubbish l)) (ppr l) $ -- assert: see Note [Rubbish literals] wrinkle (b) IfaceLitAlt l -toIfaceCon DEFAULT = IfaceDefault +toIfaceCon DEFAULT = IfaceDefaultAlt --------------------- toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr @@ -660,7 +664,7 @@ -- Foreign calls have special syntax | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (occNameFS $ nameOccName name) + | otherwise = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name)) where name = idName v ty = idType v @@ -694,16 +698,7 @@ LFLetNoEscape -> panic "toIfaceLFInfo: LFLetNoEscape" --- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> CgBreakInfo -dehydrateCgBreakInfo ty_vars idOffSets tick_ty = - CgBreakInfo - { cgb_tyvars = map toIfaceTvBndr ty_vars - , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets - , cgb_resty = toIfaceType tick_ty - } - {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this example (#10083, #12789): @@ -776,8 +771,8 @@ Note [Interface File with Core: Sharing RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IMPORTANT: This optimisation is currently disabled due to #22027, it can be - re-enabled once #220056 is implemented. +IMPORTANT: This optimisation is currently disabled due to #22807, it can be + re-enabled once #22056 is implemented. In order to avoid duplicating definitions for bindings which already have unfoldings we do some minor headstands to avoid serialising the RHS of a definition if it has @@ -790,9 +785,9 @@ * When creating the interface, check the criteria above and don't serialise the RHS if such a case. - See -* When reading an interface, look at the realIdUnfolding, and then the unfoldingTemplate. - See `tc_iface_binding` for where this happens. + +* When reading an interface, look at the realIdUnfolding, and then the + maybeUnfoldingTemplate. See `tc_iface_binding` for where this happens. There are two main reasons why the mi_extra_decls field exists rather than shoe-horning all the core bindings diff --git a/GHC/CoreToStg.hs b/GHC/CoreToStg.hs --- a/GHC/CoreToStg.hs +++ b/GHC/CoreToStg.hs @@ -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 ( isUsedOnceDmd ) -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 @@ -54,10 +52,8 @@ import GHC.Utils.Monad import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad (ap) -import Data.Maybe (fromMaybe) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -225,6 +221,22 @@ -- (For the gory details, see also the (unpublished) paper, “Practical -- aspects of evidence-based compilation in System FC.”) +-- Note [Saturation of data constructors in STG] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We guarantee that `StgConApp` is an exactly-saturated application of a data +-- constructor worker. +-- +-- * If the data constructor is /under/-saturated we just fall through to build +-- a `StgApp`. Remember, data constructor workers have a regular top-level definition +-- (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply +-- that function. +-- +-- * If the data constructor is /over/-saturated, which can happen (see #23865) we again +-- fall through to `StgApp`. That will fail horribly at runtime (by applying data +-- constructor to an argument) but it should be in dead code, and at least the compiler +-- itself won't crash. (We could inject an error-thunk instead.) + + -- -------------------------------------------------------------- -- Setting variable info: top-level, binds, RHSs -- -------------------------------------------------------------- @@ -340,10 +352,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 @@ -374,7 +388,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 @@ -390,24 +404,25 @@ -- CorePrep should have converted them all to a real core representation. coreToStgExpr (Lit (LitNumber LitNumBigNat _)) = panic "coreToStgExpr: LitNumBigNat" coreToStgExpr (Lit l) = return (StgLit l) -coreToStgExpr (Var v) = coreToStgApp v [] [] +coreToStgExpr (Var v) = coreToStgApp v [] [] (idType v) coreToStgExpr (Coercion _) -- See Note [Coercion tokens] - = coreToStgApp coercionTokenId [] [] + = coreToStgApp coercionTokenId [] [] (idType coercionTokenId) coreToStgExpr expr@(App _ _) = case app_head of - Var f -> coreToStgApp f args ticks -- Regular application - Lit l | isLitRubbish l -- If there is LitRubbish at the head, - -- discard the arguments - -- Recompute representation, because in - -- '(RUBBISH[rep] x) :: (T :: TYPE rep2)' - -- rep might not be equal to rep2 - -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep (exprType expr)) + Var f -> coreToStgApp f args ticks res_ty -- Regular application + Lit l | isLitRubbish l -- Discard arguments if head is LitRubbish + -- Recompute representation, because in + -- '(RUBBISH[rep] x) :: (T :: TYPE rep2)' + -- rep might not be equal to rep2 + -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep res_ty) _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr) where - (app_head, args, ticks) = myCollectArgs expr + res_ty = exprType expr + (app_head, args, ticks) = myCollectArgs expr res_ty + coreToStgExpr expr@(Lam _ _) = let (args, body) = myCollectBinders expr @@ -429,30 +444,23 @@ = coreToStgExpr expr -- Cases require a little more real work. - -{- -coreToStgExpr (Case scrut _ _ []) +coreToStgExpr (Case scrut bndr _ alts) + | null alts + -- See Note [Empty case alternatives] in GHC.Core If the case + -- alternatives are empty, the scrutinee must diverge or raise an + -- exception, so we can just dive into it. + -- + -- Of course this may seg-fault if the scrutinee *does* return. A + -- belt-and-braces approach would be to move this case into the + -- code generator, and put a return point anyway that calls a + -- runtime system error function. = coreToStgExpr scrut - -- See Note [Empty case alternatives] in GHC.Core If the case - -- alternatives are empty, the scrutinee must diverge or raise an - -- exception, so we can just dive into it. - -- - -- Of course this may seg-fault if the scrutinee *does* return. A - -- belt-and-braces approach would be to move this case into the - -- code generator, and put a return point anyway that calls a - -- runtime system error function. -coreToStgExpr e0@(Case scrut bndr _ [alt]) = do - | isUnsafeEqualityProof scrut - , isDeadBinder bndr -- We can only discard the case if the case-binder is dead - -- It usually is, but see #18227 - , (_,_,rhs) <- alt + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce = coreToStgExpr rhs - -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce --} --- The normal case for case-expressions -coreToStgExpr (Case scrut bndr _ alts) + | otherwise = do { scrut2 <- coreToStgExpr scrut ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts) ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) } @@ -517,57 +525,72 @@ coreToStgApp :: Id -- Function -> [CoreArg] -- Arguments - -> [CoreTickish] -- Debug ticks + -> [StgTickish] -- From the application nodes + -> Type -- Type of the whole application -> CtsM StgExpr -coreToStgApp f args ticks = do - (args', ticks') <- coreToStgArgs args - how_bound <- lookupVarCts f +coreToStgApp f core_args app_ticks res_ty + = do { how_bound <- lookupVarCts f + ; (stg_args, arg_ticks) <- coreToStgArgs core_args + ; let app = mkStgApp f how_bound core_args stg_args res_ty + all_ticks = app_ticks ++ arg_ticks - let - n_val_args = valArgCount args + -- Forcing these fixes a leak in the code generator, + -- noticed while profiling for #4367 + ; app `seq` return (foldr add_tick app all_ticks)} + where + add_tick !t !e = StgTick t e - -- Mostly, the arity info of a function is in the fn's IdInfo - -- But new bindings introduced by CoreSat may not have no - -- arity info; it would do us no good anyway. For example: - -- let f = \ab -> e in f - -- No point in having correct arity info for f! - -- Hence the hasArity stuff below. - -- NB: f_arity is only consulted for LetBound things - f_arity = stgArity f how_bound - saturated = f_arity <= n_val_args +mkStgApp :: Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr +mkStgApp f how_bound core_args stg_args res_ty + = case idDetails f of + DataConWorkId dc + | exactly_saturated -- See Note [Saturation of data constructors in STG] + -> if isUnboxedSumDataCon dc then + StgConApp dc NoNumber stg_args (sumPrimReps core_args) + else + StgConApp dc NoNumber stg_args [] - res_ty = exprType (mkApps (Var f) args) - app = case idDetails f of - DataConWorkId dc - | saturated -> StgConApp dc NoNumber args' - (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty))) + -- Some primitive operator that might be implemented as a library call. + -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps + -- we require that primop applications be saturated. + PrimOpId op _ -> -- assertPpr saturated (ppr f <+> ppr stg_args) $ + StgOpApp (StgPrimOp op) stg_args res_ty - -- Some primitive operator that might be implemented as a library call. - -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps - -- we require that primop applications be saturated. - PrimOpId op _ -> -- assertPpr saturated (ppr f <+> ppr args) $ - StgOpApp (StgPrimOp op) args' res_ty + -- A call to some primitive Cmm function. + FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) + PrimCallConv _)) + -> assert exactly_saturated $ + StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) stg_args res_ty - -- A call to some primitive Cmm function. - FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True) - PrimCallConv _)) - -> assert saturated $ - StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty + -- A regular foreign call. + FCallId call -> assert exactly_saturated $ + StgOpApp (StgFCallOp call (idType f)) stg_args res_ty - -- A regular foreign call. - FCallId call -> assert saturated $ - StgOpApp (StgFCallOp call (idType f)) args' res_ty + TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args) - TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') - _other -> StgApp f args' + _other -> StgApp f stg_args + where + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. + -- NB: f_arity is only consulted for LetBound things + f_arity = stgArity f how_bound + n_val_args = length stg_args -- StgArgs are all value arguments + exactly_saturated = f_arity == n_val_args - add_tick !t !e = StgTick t e - tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks') - -- Forcing these fixes a leak in the code generator, noticed while - -- profiling for trac #4367 - app `seq` return tapp - +-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's +-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0 +-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0] +-- and we return the list [[LiftedRep], [IntRep]]. +-- See Note [Representations in StgConApp] in GHC.Stg.Unarise. +sumPrimReps :: [CoreArg] -> [[PrimRep]] +sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty + = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args +sumPrimReps _ = [] -- --------------------------------------------------------------------------- -- Argument lists -- This is the guy that turns applications into A-normal form @@ -578,11 +601,7 @@ -- CoreArgs may not immediately look trivial, e.g., `case e of {}` or -- `case unsafeequalityProof of UnsafeRefl -> e` might intervene. -- Good thing we can just call `trivial_expr_fold` here. -getStgArgFromTrivialArg e - | Just s <- exprIsTickedString_maybe e -- This case is just for backport to GHC 9.8, - = StgLitArg (LitString s) -- where we used to treat strings as valid StgArgs - | otherwise - = trivial_expr_fold StgVarArg StgLitArg panic panic e +getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e where panic = pprPanic "getStgArgFromTrivialArg" (ppr e) @@ -614,11 +633,11 @@ ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg) arg' = getStgArgFromTrivialArg arg arg_rep = typePrimRep arg_ty - stg_arg_rep = typePrimRep (stgArgType arg') + stg_arg_rep = stgArgRep arg' bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg) - warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) (return ()) + warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) return (arg' : stg_args, ticks' ++ ticks) @@ -686,166 +705,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 | isUsedOnceDmd (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 | isUsedOnceDmd (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 @@ -934,15 +811,6 @@ Just xx -> xx Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound -getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) -getAllCAFsCC this_mod = - let - span = mkGeneralSrcSpan (mkFastString "") -- 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. filterStgBinders :: [Var] -> [Var] @@ -958,20 +826,45 @@ -- | If the argument expression is (potential chain of) 'App', return the head -- of the app chain, and collect ticks/args along the chain. -myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish]) -myCollectArgs expr +-- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was +-- wrapped in casts, empty case, ticks, etc. +-- So keep in sync with 'exprIsTrivial'. +myCollectArgs :: HasDebugCallStack + => CoreExpr -> Type -> (CoreExpr, [CoreArg], [StgTickish]) +myCollectArgs expr res_ty = go expr [] [] where - go h@(Var _v) as ts = (h, as, ts) - go (App f a) as ts = go f (a:as) ts - go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as) - (ppr e $$ ppr as $$ ppr ts) $ - -- See Note [Ticks in applications] - go e as (t:ts) -- ticks can appear in type apps - go (Cast e _) as ts = go e as ts - go (Lam b e) as ts - | isTyVar b = go e as ts -- Note [Collect args] - go e as ts = (e, as, ts) + go h@(Var f) as ts + | isUnaryClassId f, (the_arg:as') <- dropWhile isTypeArg as + = go the_arg as' ts + -- See (UCM1) in Note [Unary class magic] in GHC.Core.TyCon + -- isUnaryClassId includes both the class op and the data-con + + | otherwise + = (h, as, ts) + + go (App f a) as ts = go f (a:as) ts + go (Cast e _) as ts = go e as ts + go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as) + (ppr e $$ ppr as $$ ppr ts) $ + -- See Note [Ticks in applications] + -- ticks can appear in type apps + go e as (coreToStgTick res_ty t : ts) + + go (Case e b _ alts) as ts -- Just like in exprIsTrivial! + -- Otherwise we fall over in case we encounter + -- `(case f a of {}) b` in the future. + | null alts + = assertPpr (null as) (ppr e $$ ppr as $$ ppr expr) $ + go e [] ts -- NB: Empty case discards arguments + | Just rhs <- isUnsafeEqualityCase e b alts + = go rhs as ts -- Discards unsafeCoerce in App heads + + go (Lam b e) as ts + | isTyVar b + = go e (drop 1 as) ts -- Note [Collect args] + + go e as ts = (e, as, ts) {- Note [Collect args] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/CoreToStg/AddImplicitBinds.hs b/GHC/CoreToStg/AddImplicitBinds.hs new file mode 100644 --- /dev/null +++ b/GHC/CoreToStg/AddImplicitBinds.hs @@ -0,0 +1,151 @@ +{- +(c) The University of Glasgow, 1994-2006 + +Add implicit bindings +-} + +module GHC.CoreToStg.AddImplicitBinds ( addImplicitBinds ) where + +import GHC.Prelude + +import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) ) + +import GHC.Unit( ModLocation(..) ) + +import GHC.Core +import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId ) +import GHC.Core.TyCon( TyCon, tyConDataCons, isBoxedDataTyCon, tyConClass_maybe ) +import GHC.Core.Class( classAllSelIds ) + +import GHC.Types.Name +import GHC.Types.Tickish( GenTickish( SourceNote ) ) +import GHC.Types.Id( dataConWrapUnfolding_maybe ) +import GHC.Types.Id.Make( mkDictSelRhs ) +import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) + +import GHC.Utils.Outputable +import GHC.Data.FastString + + +{- ********************************************************************* +* * + Implicit bindings +* * +********************************************************************* -} + +{- Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`addImplicitBinds` injects the so-called "implicit bindings" generated by +the TyCons of the module. Specifically: + + * Data constructor wrappers + * Data constructor workers: see Note [Data constructor workers] + * Class op selectors: we want curriedn versions of these too + +Note that /record selector/ are injected much earlier, at the beginning +of the pipeline -- see Note [Record selectors] in GHC.Tc.TyCl.Utils. + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +because GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (#2844). +It's much safer just to inject them right at the end, after tidying. + +Oh: two other reasons for injecting them late: + + - If implicit Ids are already in the bindings when we start tidying, + we'd have to be careful not to treat them as external Ids (in + the sense of chooseExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = + but nothing referring to a18 (because the implicit Id is the + one that does, and implicit Ids don't appear in interface files). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. +-} + + +addImplicitBinds :: CorePrepPgmConfig -> ModLocation + -> [TyCon] -> CoreProgram -> IO CoreProgram +addImplicitBinds pgm_cfg mod_loc tycons binds + = return (implicit_binds ++ binds) + where + gen_debug_info = cpPgm_generateDebugInfo pgm_cfg + implicit_binds = concatMap (mkImplicitBinds gen_debug_info mod_loc) tycons + + +mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind] +-- See Note [Data constructor workers] +-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy +mkImplicitBinds gen_debug_info mod_loc tycon + = classop_binds ++ datacon_binds + where + datacon_binds + | isBoxedDataTyCon tycon + = concatMap (dataConBinds gen_debug_info mod_loc) (tyConDataCons tycon) + | otherwise + = [] + -- The 'otherwise' includes family TyCons of course, but also (less obviously) + -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make + -- * type data: we don't want any code for type-only stuff (#24620) + + classop_binds + | Just cls <- tyConClass_maybe tycon + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + | otherwise + = [] + +dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind] +dataConBinds gen_debug_info mod_loc data_con + = wrapper_bind ++ worker_bind + where + work_id = dataConWorkId data_con + wrap_id = dataConWrapId data_con + worker_bind = [NonRec work_id (add_tick (Var work_id))] + -- worker_bind: the ice is thin here, but it works: + -- CorePrep will eta-expand it + wrapper_bind = case dataConWrapUnfolding_maybe wrap_id of + Nothing -> [] + Just rhs -> [NonRec wrap_id rhs] + add_tick = tick_it gen_debug_info mod_loc (getName data_con) + +tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr +-- If we want to generate debug info, we put a source note on the +-- worker. This is useful, especially for heap profiling. +tick_it generate_debug_info mod_loc name + | not generate_debug_info = id + | RealSrcSpan span _ <- nameSrcSpan name = tick span + | Just file <- ml_hs_file mod_loc = tick (span1 file) + | otherwise = tick (span1 "???") + where + tick span = Tick $ SourceNote span $ + LexicalFastString $ mkFastString $ + renderWithContext defaultSDocContext $ ppr name + span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + + + + diff --git a/GHC/CoreToStg/Prep.hs b/GHC/CoreToStg/Prep.hs --- a/GHC/CoreToStg/Prep.hs +++ b/GHC/CoreToStg/Prep.hs @@ -1,2341 +1,2858 @@ -{-# LANGUAGE BangPatterns #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -(c) The University of Glasgow, 1994-2006 - - -Core pass to saturate constructors and PrimOps --} - -module GHC.CoreToStg.Prep - ( CorePrepConfig (..) - , CorePrepPgmConfig (..) - , corePrepPgm - , corePrepExpr - , mkConvertNumLiteral - ) -where - -import GHC.Prelude - -import GHC.Platform - -import GHC.Driver.Flags - -import GHC.Tc.Utils.Env -import GHC.Unit - -import GHC.Builtin.Names -import GHC.Builtin.Types - -import GHC.Core.Utils -import GHC.Core.Opt.Arity -import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) -import GHC.Core -import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Core.Opt.OccurAnal -import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) - -import GHC.Data.Maybe -import GHC.Data.OrdList -import GHC.Data.FastString -import GHC.Data.Pair -import GHC.Data.Graph.UnVar - -import GHC.Utils.Error -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Outputable -import GHC.Utils.Monad ( mapAccumLM ) -import GHC.Utils.Logger - -import GHC.Types.Demand -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Id.Make ( realWorldPrimId ) -import GHC.Types.Basic -import GHC.Types.Name ( Name, NamedThing(..), nameSrcSpan, isInternalName ) -import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) -import GHC.Types.Literal -import GHC.Types.Tickish -import GHC.Types.TyThing -import GHC.Types.Unique.Supply - -import Data.List ( unfoldr ) -import Data.Functor.Identity -import Control.Monad - -{- -Note [CorePrep Overview] -~~~~~~~~~~~~~~~~~~~~~~~~ - -The goal of this pass is to prepare for code generation. - -1. Saturate constructor and primop applications. - -2. Convert to A-normal form; that is, function arguments - are always variables. - - * Use case for strict arguments: - f E ==> case E of x -> f x - (where f is strict) - - * Use let for non-trivial lazy arguments - f E ==> let x = E in f x - (were f is lazy and x is non-trivial) - -3. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' - rhss in let-form right up to this point.] - -4. Ensure that *value* lambdas only occur as the RHS of a binding - (The code generator can't deal with anything else.) - Type lambdas are ok, however, because the code gen discards them. - -5. [Not any more; nuked Jun 2002] Do the seq/par munging. - -6. Clone all local Ids. - This means that all such Ids are unique, rather than the - weaker guarantee of no clashes which the simplifier provides. - And that is what the code generator needs. - - We don't clone TyVars or CoVars. The code gen doesn't need that, - and doing so would be tiresome because then we'd need - to substitute in types and coercions. - - We need to clone ids for two reasons: - + Things associated with labels in the final code must be truly unique in - order to avoid labels being shadowed in the final output. - + Even binders without info tables like function arguments or alternative - bound binders must be unique at least in their type/unique combination. - We only emit a single declaration for each binder when compiling to C - so if binders are not unique we would either get duplicate declarations - or misstyped variables. The later happend in #22402. - + We heavily use unique-keyed maps in the backend which can go wrong when - ids with the same unique are meant to represent the same variable. - -7. Give each dynamic CCall occurrence a fresh unique; this is - rather like the cloning step above. - -8. Inject bindings for the "implicit" Ids: - * Constructor wrappers - * Constructor workers - We want curried definitions for all of these in case they - aren't inlined by some caller. - - 9. Convert bignum literals into their core representation. - -10. Uphold tick consistency while doing this: We move ticks out of - (non-type) applications where we can, and make sure that we - annotate according to scoping rules when floating. - -11. Collect cost centres (including cost centres in unfoldings) if we're in - profiling mode. We have to do this here because we won't have unfoldings - after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules]. - -12. Eliminate case clutter in favour of unsafe coercions. - See Note [Unsafe coercions] - -13. Eliminate some magic Ids, specifically - runRW# (\s. e) ==> e[readWorldId/s] - lazy e ==> e (see Note [lazyId magic] in GHC.Types.Id.Make) - noinline e ==> e - nospec e ==> e - ToDo: keepAlive# ... - This is done in cpeApp - -This is all done modulo type applications and abstractions, so that -when type erasure is done for conversion to STG, we don't end up with -any trivial or useless bindings. - -Note [Unsafe coercions] -~~~~~~~~~~~~~~~~~~~~~~~ -CorePrep does these two transformations: - -1. Convert empty case to cast with an unsafe coercion - (case e of {}) ===> e |> unsafe-co - See Note [Empty case alternatives] in GHC.Core: if the case - alternatives are empty, the scrutinee must diverge or raise an - exception, so we can just dive into it. - - Of course, if the scrutinee *does* return, we may get a seg-fault. - A belt-and-braces approach would be to persist empty-alternative - cases to code generator, and put a return point anyway that calls a - runtime system error function. - - Notice that eliminating empty case can lead to an ill-kinded coercion - case error @Int "foo" of {} :: Int# - ===> error @Int "foo" |> unsafe-co - where unsafe-co :: Int ~ Int# - But that's fine because the expression diverges anyway. And it's - no different to what happened before. - -2. Eliminate unsafeEqualityProof in favour of an unsafe coercion - case unsafeEqualityProof of UnsafeRefl g -> e - ===> e[unsafe-co/g] - See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - - Note that this requires us to substitute 'unsafe-co' for 'g', and - that is the main (current) reason for cpe_tyco_env in CorePrepEnv. - Tiresome, but not difficult. - -These transformations get rid of "case clutter", leaving only casts. -We are doing no further significant transformations, so the reasons -for the case forms have disappeared. And it is extremely helpful for -the ANF-ery, CoreToStg, and backends, if trivial expressions really do -look trivial. #19700 was an example. - -In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)), -The boolean 'b' says whether the unsafe coercion is supposed to be -kind-homogeneous (yes for (2), no for (1). This information is used -/only/ by Lint. - -Note [CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 - - Applications - app ::= lit | var | app arg | app ty | app co | app |> co - - Expressions - body ::= app - | 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 - -We define a synonym for each of these non-terminals. Functions -with the corresponding name produce a result in that syntax. --} - -type CpeArg = CoreExpr -- Non-terminal 'arg' -type CpeApp = CoreExpr -- Non-terminal 'app' -type CpeBody = CoreExpr -- Non-terminal 'body' -type CpeRhs = CoreExpr -- Non-terminal 'rhs' - -{- -************************************************************************ -* * - Top level stuff -* * -************************************************************************ --} - -data CorePrepPgmConfig = CorePrepPgmConfig - { cpPgm_endPassConfig :: !EndPassConfig - , cpPgm_generateDebugInfo :: !Bool - } - -corePrepPgm :: Logger - -> CorePrepConfig - -> CorePrepPgmConfig - -> Module -> ModLocation -> CoreProgram -> [TyCon] - -> IO CoreProgram -corePrepPgm logger cp_cfg pgm_cfg - this_mod mod_loc binds data_tycons = - withTiming logger - (text "CorePrep"<+>brackets (ppr this_mod)) - (\a -> a `seqList` ()) $ do - us <- mkSplitUniqSupply 's' - let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg - - let - implicit_binds = mkDataConWorkers - (cpPgm_generateDebugInfo pgm_cfg) - mod_loc data_tycons - -- NB: we must feed mkImplicitBinds through corePrep too - -- so that they are suitably cloned and eta-expanded - - binds_out = initUs_ us $ do - floats1 <- corePrepTopBinds initialCorePrepEnv binds - floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds - return (deFloatTop (floats1 `appendFloats` floats2)) - - endPassIO logger (cpPgm_endPassConfig pgm_cfg) - binds_out [] - return binds_out - -corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr -corePrepExpr logger config expr = do - withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do - us <- mkSplitUniqSupply 's' - let initialCorePrepEnv = mkInitialCorePrepEnv config - let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) - return new_expr - -corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats --- Note [Floating out of top level bindings] -corePrepTopBinds initialCorePrepEnv binds - = go initialCorePrepEnv binds - where - go _ [] = return emptyFloats - go env (bind : binds) = do (env', floats, maybe_new_bind) - <- cpeBind TopLevel env bind - massert (isNothing maybe_new_bind) - -- Only join points get returned this way by - -- cpeBind, and no join point may float to top - floatss <- go env' binds - return (floats `appendFloats` floatss) - -mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind] --- See Note [Data constructor workers] --- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy -mkDataConWorkers generate_debug_info mod_loc data_tycons - = [ NonRec id (tick_it (getName data_con) (Var id)) - -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it - data_con <- tyConDataCons tycon, - let id = dataConWorkId data_con - ] - where - -- If we want to generate debug info, we put a source note on the - -- worker. This is useful, especially for heap profiling. - tick_it name - | not generate_debug_info = id - | RealSrcSpan span _ <- nameSrcSpan name = tick span - | Just file <- ml_hs_file mod_loc = tick (span1 file) - | otherwise = tick (span1 "???") - where tick span = Tick $ SourceNote span $ - LexicalFastString $ mkFastString $ renderWithContext defaultSDocContext $ ppr name - span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 - -{- -Note [Floating out of top level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: we do need to float out of top-level bindings -Consider x = length [True,False] -We want to get - s1 = False : [] - s2 = True : s1 - x = length s2 - -We return a *list* of bindings, because we may start with - x* = f (g y) -where x is demanded, in which case we want to finish with - a = g y - x* = f a -And then x will actually end up case-bound - -Note [Join points and floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Join points can float out of other join points but not out of value bindings: - - let z = - let w = ... in -- can float - join k = ... in -- can't float - ... jump k ... - join j x1 ... xn = - let y = ... in -- can float (but don't want to) - join h = ... in -- can float (but not much point) - ... jump h ... - in ... - -Here, the jump to h remains valid if h is floated outward, but the jump to k -does not. - -We don't float *out* of join points. It would only be safe to float out of -nullary join points (or ones where the arguments are all either type arguments -or dead binders). Nullary join points aren't ever recursive, so they're always -effectively one-shot functions, which we don't float out of. We *could* float -join points from nullary join points, but there's no clear benefit at this -stage. - -Note [Data constructor workers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Create any necessary "implicit" bindings for data con workers. We -create the rather strange (non-recursive!) binding - - $wC = \x y -> $wC x y - -i.e. a curried constructor that allocates. This means that we can -treat the worker for a constructor like any other function in the rest -of the compiler. The point here is that CoreToStg will generate a -StgConApp for the RHS, rather than a call to the worker (which would -give a loop). As Lennart says: the ice is thin here, but it works. - -Hmm. Should we create bindings for dictionary constructors? They are -always fully applied, and the bindings are just there to support -partial applications. But it's easier to let them through. - - -Note [Dead code in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Imagine that we got an input program like this (see #4962): - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g True (Just x) + g () (Just x), g) - where - g :: Show a => a -> Maybe Int -> Int - g _ Nothing = x - g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown - -After specialisation and SpecConstr, we would get something like this: - - f :: Show b => Int -> (Int, b -> Maybe Int -> Int) - f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) - where - {-# RULES g $dBool = g$Bool - g $dUnit = g$Unit #-} - g = ... - {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} - g$Bool = ... - {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} - g$Unit = ... - g$Bool_True_Just = ... - g$Unit_Unit_Just = ... - -Note that the g$Bool and g$Unit functions are actually dead code: they -are only kept alive by the occurrence analyser because they are -referred to by the rules of g, which is being kept alive by the fact -that it is used (unspecialised) in the returned pair. - -However, at the CorePrep stage there is no way that the rules for g -will ever fire, and it really seems like a shame to produce an output -program that goes to the trouble of allocating a closure for the -unreachable g$Bool and g$Unit functions. - -The way we fix this is to: - * In cloneBndr, drop all unfoldings/rules - - * In deFloatTop, run a simple dead code analyser on each top-level - RHS to drop the dead local bindings. - -The reason we don't just OccAnal the whole output of CorePrep is that -the tidier ensures that all top-level binders are GlobalIds, so they -don't show up in the free variables any longer. So if you run the -occurrence analyser on the output of CoreTidy (or later) you e.g. turn -this program: - - Rec { - f = ... f ... - } - -Into this one: - - f = ... f ... - -(Since f is not considered to be free in its own RHS.) - - -Note [keepAlive# magic] -~~~~~~~~~~~~~~~~~~~~~~~ -When interacting with foreign code, it is often necessary for the user to -extend the lifetime of a heap object beyond the lifetime that would be apparent -from the on-heap references alone. For instance, a program like: - - foreign import safe "hello" hello :: ByteArray# -> IO () - - callForeign :: IO () - callForeign = IO $ \s0 -> - case newByteArray# n# s0 of (# s1, barr #) -> - unIO hello barr s1 - -As-written this program is susceptible to memory-unsafety since there are -no references to `barr` visible to the garbage collector. Consequently, if a -garbage collection happens during the execution of the C function `hello`, it -may be that the array is freed while in use by the foreign function. - -To address this, we introduced a new primop, keepAlive#, which "scopes over" -the computation needing the kept-alive value: - - keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b). - a -> State# RealWorld -> (State# RealWorld -> b) -> b - -When entered, an application (keepAlive# x s k) will apply `k` to the state -token, evaluating it to WHNF. However, during the course of this evaluation -will *guarantee* that `x` is considered to be alive. - -There are a few things to note here: - - - we are RuntimeRep-polymorphic in the value to be kept-alive. This is - necessary since we will often (but not always) be keeping alive something - unlifted (like a ByteArray#) - - - we are RuntimeRep-polymorphic in the result value since the result may take - many forms (e.g. a boxed value, a raw state token, or a (# State s, result #). - -We implement this operation by desugaring to touch# during CorePrep (see -GHC.CoreToStg.Prep.cpeApp). Specifically, - - keepAlive# x s0 k - -is transformed to: - - case k s0 of r -> - case touch# x realWorld# of s1 -> - r - -Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a -pointer to `x` and entering `k s0`. This compilation strategy is safe -because we do no optimization on STG that would drop or re-order the -continuation containing the `touch#`. However, if we were to become more -aggressive in our STG pipeline then we would need to revisit this. - -Beyond this CorePrep transformation, there is very little special about -keepAlive#. However, we did explore (and eventually gave up on) -an optimisation which would allow unboxing of constructed product results, -which we describe below. - - -Lost optimisation: CPR unboxing --------------------------------- -One unfortunate property of this approach is that the simplifier is unable to -unbox the result of a keepAlive# expression. For instance, consider the program: - - case keepAlive# arr s0 ( - \s1 -> case peekInt arr s1 of - (# s2, r #) -> I# r - ) of - I# x -> ... - -This is a surprisingly common pattern, previously used, e.g., in -GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around -with optimising this away by pushing strict contexts (like the -`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can -recover unboxing, it can also unfortunately in general change the asymptotic -memory (namely stack) behavior of the program. For instance, consider - - writeN = - ... - case keepAlive# x s0 (\s1 -> something s1) of - (# s2, x #) -> - writeN ... - -As it is tail-recursive, this program will run in constant space. However, if -we push outer case into the continuation we get: - - writeN = - - case keepAlive# x s0 (\s1 -> - case something s1 of - (# s2, x #) -> - writeN ... - ) of - ... - -Which ends up building a stack which is linear in the recursion depth. For this -reason, we ended up giving up on this optimisation. - - -Historical note: touch# and its inadequacy ------------------------------------------- -Prior to the introduction of `keepAlive#` we instead addressed the need for -lifetime extension with the `touch#` primop: - - touch# :: a -> State# s -> State# s - -This operation would ensure that the `a` value passed as the first argument was -considered "alive" at the time the primop application is entered. - -For instance, the user might modify `callForeign` as: - - callForeign :: IO () - callForeign s0 = IO $ \s0 -> - case newByteArray# n# s0 of (# s1, barr #) -> - case unIO hello barr s1 of (# s2, () #) -> - case touch# barr s2 of s3 -> - (# s3, () #) - -However, in #14346 we discovered that this primop is insufficient in the -presence of simplification. For instance, consider a program like: - - callForeign :: IO () - callForeign s0 = IO $ \s0 -> - case newByteArray# n# s0 of (# s1, barr #) -> - case unIO (forever $ hello barr) s1 of (# s2, () #) -> - case touch# barr s2 of s3 -> - (# s3, () #) - -In this case the Simplifier may realize that (forever $ hello barr) -will never return and consequently that the `touch#` that follows is dead code. -As such, it will be dropped, resulting in memory unsoundness. -This unsoundness lead to the introduction of keepAlive#. - - - -Other related tickets: - - - #15544 - - #17760 - - #14375 - - #15260 - - #18061 - -************************************************************************ -* * - The main code -* * -************************************************************************ --} - -cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind - -> UniqSM (CorePrepEnv, - Floats, -- Floating value bindings - Maybe CoreBind) -- Just bind' <=> returned new bind; no float - -- Nothing <=> added bind' to floats instead -cpeBind top_lvl env (NonRec bndr rhs) - | not (isJoinId bndr) - = do { (env1, bndr1) <- cpCloneBndr env bndr - ; let dmd = idDemandInfo bndr - is_unlifted = isUnliftedType (idType bndr) - ; (floats, rhs1) <- cpePair top_lvl NonRecursive - dmd is_unlifted - env bndr1 rhs - -- See Note [Inlining in CorePrep] - ; let triv_rhs = exprIsTrivial rhs1 - env2 | triv_rhs = extendCorePrepEnvExpr env1 bndr rhs1 - | otherwise = env1 - floats1 | triv_rhs, isInternalName (idName bndr) - = floats - | otherwise - = addFloat floats new_float - - new_float = mkFloat env dmd is_unlifted bndr1 rhs1 - - ; return (env2, floats1, Nothing) } - - | otherwise -- A join point; see Note [Join points and floating] - = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point - do { (_, bndr1) <- cpCloneBndr env bndr - ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs - ; return (extendCorePrepEnv env bndr bndr2, - emptyFloats, - Just (NonRec bndr2 rhs1)) } - -cpeBind top_lvl env (Rec pairs) - | not (isJoinId (head bndrs)) - = do { (env, bndrs1) <- cpCloneBndrs env bndrs - ; let env' = enterRecGroupRHSs env bndrs1 - ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env') - bndrs1 rhss - - ; let (floats_s, rhss1) = unzip stuff - all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) - (concatFloats floats_s) - -- use env below, so that we reset cpe_rec_ids - ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), - unitFloat (FloatLet (Rec all_pairs)), - Nothing) } - - | otherwise -- See Note [Join points and floating] - = do { (env, bndrs1) <- cpCloneBndrs env bndrs - ; let env' = enterRecGroupRHSs env bndrs1 - ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss - - ; let bndrs2 = map fst pairs1 - -- use env below, so that we reset cpe_rec_ids - ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), - emptyFloats, - Just (Rec pairs1)) } - where - (bndrs, rhss) = unzip pairs - - -- Flatten all the floats, and the current - -- group into a single giant Rec - add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 - add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - add_float b _ = pprPanic "cpeBind" (ppr b) - ---------------- -cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool - -> CorePrepEnv -> OutId -> CoreExpr - -> UniqSM (Floats, CpeRhs) --- Used for all bindings --- The binder is already cloned, hence an OutId -cpePair top_lvl is_rec dmd is_unlifted env bndr rhs - = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair - do { (floats1, rhs1) <- cpeRhsE env rhs - - -- See if we are allowed to float this stuff out of the RHS - ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 - - -- Make the arity match up - ; (floats3, rhs3) - <- if manifestArity rhs1 <= arity - then return (floats2, cpeEtaExpand arity rhs2) - else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ - -- Note [Silly extra arguments] - (do { v <- newVar (idType bndr) - ; let float = mkFloat env topDmd False v rhs2 - ; return ( addFloat floats2 float - , cpeEtaExpand arity (Var v)) }) - - -- Wrap floating ticks - ; let (floats4, rhs4) = wrapTicks floats3 rhs3 - - ; return (floats4, rhs4) } - where - arity = idArity bndr -- We must match this arity - - --------------------- - float_from_rhs floats rhs - | isEmptyFloats floats = return (emptyFloats, rhs) - | isTopLevel top_lvl = float_top floats rhs - | otherwise = float_nested floats rhs - - --------------------- - float_nested floats rhs - | wantFloatNested is_rec dmd is_unlifted floats rhs - = return (floats, rhs) - | otherwise = dontFloat floats rhs - - --------------------- - float_top floats rhs - | allLazyTop floats - = return (floats, rhs) - - | Just floats <- canFloat floats rhs - = return floats - - | otherwise - = dontFloat floats rhs - -dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody) --- Non-empty floats, but do not want to float from rhs --- So wrap the rhs in the floats --- But: rhs1 might have lambdas, and we can't --- put them inside a wrapBinds -dontFloat floats1 rhs - = do { (floats2, body) <- rhsToBody rhs - ; return (emptyFloats, wrapBinds floats1 $ - wrapBinds floats2 body) } - -{- Note [Silly extra arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we had this - f{arity=1} = \x\y. e -We *must* match the arity on the Id, so we have to generate - f' = \x\y. e - f = \x. f' x - -It's a bizarre case: why is the arity on the Id wrong? Reason -(in the days of __inline_me__): - f{arity=0} = __inline_me__ (let v = expensive in \xy. e) -When InlineMe notes go away this won't happen any more. But -it seems good for CorePrep to be robust. --} - ---------------- -cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr - -> UniqSM (JoinId, CpeRhs) --- Used for all join bindings --- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils -cpeJoinPair env bndr rhs - = assert (isJoinId bndr) $ - do { let Just join_arity = isJoinId_maybe bndr - (bndrs, body) = collectNBinders join_arity rhs - - ; (env', bndrs') <- cpCloneBndrs env bndrs - - ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts - -- with a lambda - - ; let rhs' = mkCoreLams bndrs' body' - bndr' = bndr `setIdUnfolding` evaldUnfolding - `setIdArity` count isId bndrs - -- See Note [Arity and join points] - - ; return (bndr', rhs') } - -{- -Note [Arity and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Up to now, we've allowed a join point to have an arity greater than its join -arity (minus type arguments), since this is what's useful for eta expansion. -However, for code gen purposes, its arity must be exactly the number of value -arguments it will be called with, and it must have exactly that many value -lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: - - join j x y z = \w -> ... in ... - => - join j x y z = (let f = \w -> ... in f) in ... - -This is also what happens with Note [Silly extra arguments]. Note that it's okay -for us to mess with the arity because a join point is never exported. --} - --- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs --- --------------------------------------------------------------------------- - -cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- If --- e ===> (bs, e') --- then --- e = let bs in e' (semantically, that is!) --- --- For example --- f (g x) ===> ([v = g x], f v) - -cpeRhsE env (Type ty) - = return (emptyFloats, Type (cpSubstTy env ty)) -cpeRhsE env (Coercion co) - = return (emptyFloats, Coercion (cpSubstCo env co)) -cpeRhsE env expr@(Lit (LitNumber nt i)) - = case cp_convertNumLit (cpe_config env) nt i of - Nothing -> return (emptyFloats, expr) - Just e -> cpeRhsE env e -cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr -cpeRhsE env expr@(App {}) = cpeApp env expr - -cpeRhsE env (Let bind body) - = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind - ; (body_floats, body') <- cpeRhsE env' body - ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' - Nothing -> body' - ; return (bind_floats `appendFloats` body_floats, expr') } - -cpeRhsE env (Tick tickish expr) - -- Pull out ticks if they are allowed to be floated. - | tickishFloatable tickish - = do { (floats, body) <- cpeRhsE env expr - -- See [Floating Ticks in CorePrep] - ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } - | otherwise - = do { body <- cpeBodyNF env expr - ; return (emptyFloats, mkTick tickish' body) } - where - tickish' | Breakpoint ext n fvs <- tickish - -- See also 'substTickish' - = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) - | otherwise - = tickish - -cpeRhsE env (Cast expr co) - = do { (floats, expr') <- cpeRhsE env expr - ; return (floats, Cast expr' (cpSubstCo env co)) } - -cpeRhsE env expr@(Lam {}) - = do { let (bndrs,body) = collectBinders expr - ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body - ; return (emptyFloats, mkLams bndrs' body') } - --- Eliminate empty case --- See Note [Unsafe coercions] -cpeRhsE env (Case scrut _ ty []) - = do { (floats, scrut') <- cpeRhsE env scrut - ; let ty' = cpSubstTy env ty - scrut_ty' = exprType scrut' - co' = mkUnivCo prov Representational scrut_ty' ty' - prov = CorePrepProv False - -- False says that the kinds of two types may differ - -- E.g. we might cast Int to Int#. This is fine - -- because the scrutinee is guaranteed to diverge - - ; return (floats, Cast scrut' co') } - -- This can give rise to - -- Warning: Unsafe coercion: between unboxed and boxed value - -- but it's fine because 'scrut' diverges - --- Eliminate unsafeEqualityProof --- See Note [Unsafe coercions] -cpeRhsE env (Case scrut bndr _ alts) - | isUnsafeEqualityProof scrut - , isDeadBinder bndr -- We can only discard the case if the case-binder - -- is dead. It usually is, but see #18227 - , [Alt _ [co_var] rhs] <- alts - , let Pair ty1 ty2 = coVarTypes co_var - the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2) - prov = CorePrepProv True -- True <=> kind homogeneous - env' = extendCoVarEnv env co_var the_co - = cpeRhsE env' rhs - -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 - , 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 ty alts'') } - where - sat_alt env (Alt con bs rhs) - = do { (env2, bs') <- cpCloneBndrs env bs - ; rhs' <- cpeBodyNF env2 rhs - ; return (Alt con bs' rhs') } - --- --------------------------------------------------------------------------- --- CpeBody: produces a result satisfying CpeBody --- --------------------------------------------------------------------------- - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without --- producing any floats (any generated floats are immediately --- let-bound using 'wrapBinds'). Generally you want this, esp. --- when you've reached a binding form (e.g., a lambda) and --- floating any further would be incorrect. -cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr - = do { (floats, body) <- cpeBody env expr - ; return (wrapBinds floats body) } - --- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce --- a list of 'Floats' which are being propagated upwards. In --- fact, this function is used in only two cases: to --- implement 'cpeBodyNF' (which is what you usually want), --- and in the case when a let-binding is in a case scrutinee--here, --- we can always float out: --- --- case (let x = y in z) of ... --- ==> let x = y in case z of ... --- -cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) -cpeBody env expr - = do { (floats1, rhs) <- cpeRhsE env expr - ; (floats2, body) <- rhsToBody rhs - ; return (floats1 `appendFloats` floats2, body) } - --------- -rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-binding - -rhsToBody (Tick t expr) - | tickishScoped t == NoScope -- only float out of non-scoped annotations - = do { (floats, expr') <- rhsToBody expr - ; return (floats, mkTick t expr') } - -rhsToBody (Cast e co) - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - = do { (floats, e') <- rhsToBody e - ; return (floats, Cast e' co) } - -rhsToBody expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] - | all isTyVar bndrs -- Type lambdas are ok - = return (emptyFloats, expr) - | otherwise -- Some value lambdas - = do { let rhs = cpeEtaExpand (exprArity expr) expr - ; fn <- newVar (exprType rhs) - ; let float = FloatLet (NonRec fn rhs) - ; return (unitFloat float, Var fn) } - where - (bndrs,_) = collectBinders expr - -rhsToBody expr = return (emptyFloats, expr) - - -{- Note [No eta reduction needed in rhsToBody] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Historical note. In the olden days we used to have a Prep-specific -eta-reduction step in rhsToBody: - rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) - -The goal was to reduce - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } - -to avoid allocating a lambda. Of course, we'd allocate a PAP -instead, which is hardly better, but that's the way it was. - -Now we simply don't bother with this. It doesn't seem to be a win, -and it's extra work. --} - --- --------------------------------------------------------------------------- --- CpeApp: produces a result satisfying CpeApp --- --------------------------------------------------------------------------- - -data ArgInfo = CpeApp CoreArg - | CpeCast Coercion - | CpeTick 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 - -{- Note [Ticks and mandatory eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Something like - `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool` -caused a compiler panic in #20938. Why did this happen? -The simplifier will eta-reduce the rhs giving us a partial -application of tagToEnum#. The tick is then pushed inside the -type argument. That is we get - `(Tick tagToEnum#) @Bool` -CorePrep would go on to see a undersaturated tagToEnum# application -and eta expand the expression under the tick. Giving us: - (Tick (\forall a. x -> tagToEnum# @a x) @Bool -Suddenly tagToEnum# is applied to a polymorphic type and the code generator -panics as it needs a concrete type to determine the representation. - -The problem in my eyes was that the tick covers a partial application -of a primop. There is no clear semantic for such a construct as we can't -partially apply a primop since they do not have bindings. -We fix this by expanding the scope of such ticks slightly to cover the body -of the eta-expanded expression. - -We do this by: -* Checking if an application is headed by a primOpish thing. -* If so we collect floatable ticks and usually but also profiling ticks - along with regular arguments. -* When rebuilding the application we check if any profiling ticks appear - before the primop is fully saturated. -* If the primop isn't fully satured we eta expand the primop application - and scope the tick to scope over the body of the saturated expression. - -Going back to #20938 this means starting with - `(Tick tagToEnum#) @Bool` -we check if the function head is a primop (yes). This means we collect the -profiling tick like if it was floatable. Giving us - (tagToEnum#, [CpeTick foo, CpeApp @Bool]). -cpe_app filters out the tick as a underscoped tick on the expression -`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the -body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. --} -cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) --- May return a CpeRhs because of saturating primops -cpeApp top_env expr - = do { let (terminal, args) = collect_args expr - -- ; pprTraceM "cpeApp" $ (ppr expr) - ; cpe_app top_env terminal args - } - - where - -- We have a nested data structure of the form - -- e `App` a1 `App` a2 ... `App` an, convert it into - -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) - -- We use 'ArgInfo' because we may also need to - -- record casts and ticks. Depth counts the number - -- of arguments that would consume strictness information - -- (so, no type or coercion arguments.) - collect_args :: CoreExpr -> (CoreExpr, [ArgInfo]) - collect_args e = go e [] - where - go (App fun arg) as - = go fun (CpeApp arg : as) - go (Cast fun co) as - = go fun (CpeCast 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. - -- See Note [Ticks and mandatory eta expansion] - -- Here we look inside `fun` before we make the final decision about - -- floating the tick which isn't optimal for perf. But this only makes - -- a difference if we have a non-floatable tick which is somewhat rare. - | Var vh <- head - , Var head' <- lookupCorePrepEnv top_env vh - , etaExpansionTick head' tickish - = (head,as') - where - (head,as') = go fun (CpeTick tickish : as) - - -- Terminal could still be an app if it's wrapped by a tick. - -- E.g. Tick (f x) can give us (f x) as terminal. - go terminal as = (terminal, as) - - cpe_app :: CorePrepEnv - -> CoreExpr -- The thing we are calling - -> [ArgInfo] - -> UniqSM (Floats, CpeRhs) - cpe_app env (Var f) (CpeApp Type{} : CpeApp 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 - -- Replace (noinline a) with a - -- See Note [noinlineId magic] in GHC.Types.Id.Make - || f `hasKey` nospecIdKey -- Replace (nospec a) with a - -- See Note [nospecId magic] in GHC.Types.Id.Make - - -- Consider the code: - -- - -- lazy (f x) y - -- - -- We need to make sure that we need to recursively collect arguments on - -- "f x", otherwise we'll float "f x" out (it's not a variable) and - -- end up with this awful -ddump-prep: - -- - -- case f x of f_x { - -- __DEFAULT -> f_x y - -- } - -- - -- rather than the far superior "f x y". Test case is par01. - = let (terminal, args') = collect_args arg - in cpe_app env terminal (args' ++ args) - - -- runRW# magic - cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp 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) - -- 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) - -- TODO: What about casts? - where - has_value_arg [] = False - has_value_arg (CpeApp arg:_rest) - | not (isTyCoArg arg) = True - has_value_arg (_:rest) = has_value_arg rest - - cpe_app env (Var v) args - = do { v1 <- fiddleCCall v - ; let e2 = lookupCorePrepEnv env v1 - hd = getIdFromTrivialExpr_maybe e2 - -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion] - min_arity = case hd of - Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing - Nothing -> Nothing - -- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v)) - ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity - ; mb_saturate hd app floats unsat_ticks depth } - where - depth = val_args args - stricts = case idDmdSig v of - DmdSig (DmdType _ demands) - | listLengthCmp demands depth /= GT -> demands - -- length demands <= depth - | otherwise -> [] - -- If depth < length demands, then we have too few args to - -- satisfy strictness info so we have to ignore all the - -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd - - -- We inlined into something that's not a var and has no args. - -- Bounce it back up to cpeRhsE. - cpe_app env fun [] = cpeRhsE env fun - - -- Here we get: - -- N-variable fun, better let-bind it - -- This case covers literals, apps, lams or let expressions applied to arguments. - -- Basically things we want to ANF before applying to arguments. - cpe_app env fun args - = do { (fun_floats, fun') <- cpeArg env evalDmd fun - -- If evalDmd says that it's sure to be evaluated, - -- we'll end up case-binding it - ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing - ; mb_saturate Nothing app floats unsat_ticks (val_args args) } - - -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG) - val_args :: [ArgInfo] -> Int - val_args args = go args 0 - where - go [] !n = n - go (info:infos) n = - case info of - CpeCast {} -> go infos n - CpeTick 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' - where - !n' - | isTypeArg e = n - | otherwise = n+1 - - -- Saturate if necessary - mb_saturate head app floats unsat_ticks depth = - case head of - Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks - ; return (floats, sat_app) } - _other -> do { massert (null unsat_ticks) - ; return (floats, app) } - - -- Deconstruct and rebuild the application, floating any non-atomic - -- arguments to the outside. We collect the type of the expression, - -- the head of the application, and the number of actual value arguments, - -- all of which are used to possibly saturate this application if it - -- has a constructor or primop at the head. - rebuild_app - :: CorePrepEnv - -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp -- The function - -> Floats - -> [Demand] - -> Maybe Arity - -> UniqSM (CpeApp - ,Floats - ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] - ) - rebuild_app env args app floats ss req_depth = - rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth) - - rebuild_app' - :: CorePrepEnv - -> [ArgInfo] -- The arguments (inner to outer) - -> CpeApp - -> Floats - -> [Demand] - -> [CoreTickish] - -> Int -- Number of arguments required to satisfy minimal tick scopes. - -> UniqSM (CpeApp, Floats, [CoreTickish]) - rebuild_app' _ [] app floats ss rt_ticks !_req_depth - = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info - return (app, floats, rt_ticks) - - rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of - -- See Note [Ticks and mandatory eta expansion] - _ - | not (null rt_ticks) - , req_depth <= 0 - -> - let tick_fun = foldr mkTick fun' rt_ticks - in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth - - CpeApp (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) - -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth - where - co' = cpSubstCo env co - - CpeApp 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) - (ss1 : ss_rest, False) -> (ss1, ss_rest) - ([], _) -> (topDmd, []) - (fs, arg') <- cpeArg top_env ss1 arg - rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1) - - CpeCast 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 - | tickishPlace tickish == PlaceRuntime - , req_depth > 0 - -> assert (isProfTick tickish) $ - rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth - | otherwise - -- See [Floating Ticks in CorePrep] - -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss rt_ticks req_depth - -isLazyExpr :: CoreExpr -> Bool --- See Note [lazyId magic] in GHC.Types.Id.Make -isLazyExpr (Cast e _) = isLazyExpr e -isLazyExpr (Tick _ e) = isLazyExpr e -isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey -isLazyExpr _ = False - -{- Note [runRW magic] -~~~~~~~~~~~~~~~~~~~~~ -Some definitions, for instance @runST@, must have careful control over float out -of the bindings in their body. Consider this use of @runST@, - - f x = runST ( \ s -> let (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' ) - -If we inline @runST@, we'll get: - - f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -And now if we allow the @newArray#@ binding to float out to become a CAF, -we end up with a result that is totally and utterly wrong: - - f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in \ x -> - let (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -All calls to @f@ will share a {\em single} array! Clearly this is nonsense and -must be prevented. - -This is what @runRW#@ gives us: by being inlined extremely late in the -optimization (right before lowering to STG, in CorePrep), we can ensure that -no further floating will occur. This allows us to safely inline things like -@runST@, which are otherwise needlessly expensive (see #10678 and #5916). - -'runRW' has a variety of quirks: - - * 'runRW' is known-key with a NOINLINE definition in - GHC.Magic. This definition is used in cases where runRW is curried. - - * In addition to its normal Haskell definition in GHC.Magic, we give it - a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding - the incorrect sharing due to float-out noted above. - - * It is levity-polymorphic: - - runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) - => (State# RealWorld -> (# State# RealWorld, o #)) - -> (# State# RealWorld, o #) - - * It has some special simplification logic to allow unboxing of results when - runRW# appears in a strict context. See Note [Simplification of runRW#] - below. - - * Since its body is inlined, we allow runRW#'s argument to contain jumps to - join points. That is, the following is allowed: - - join j x = ... - in runRW# @_ @_ (\s -> ... jump j 42 ...) - - The Core Linter knows about this. See Note [Linting of runRW#] in - GHC.Core.Lint for details. - - The occurrence analyser and SetLevels also know about this, as described in - Note [Simplification of runRW#]. - -Other relevant Notes: - - * Note [Simplification of runRW#] below, describing a transformation of runRW - applications in strict contexts performed by the simplifier. - * Note [Linting of runRW#] in GHC.Core.Lint - * Note [runRW arg] below, describing a non-obvious case where the - late-inlining could go wrong. - - - Note [runRW arg] -~~~~~~~~~~~~~~~~~~~ -Consider the Core program (from #11291), - - runRW# (case bot of {}) - -The late inlining logic in cpe_app would transform this into: - - (case bot of {}) realWorld# - -Which would rise to a panic in CoreToStg.myCollectArgs, which expects only -variables in function position. - -However, as runRW#'s strictness signature captures the fact that it will call -its argument this can't happen: the simplifier will transform the bottoming -application into simply (case bot of {}). - -Note that this reasoning does *not* apply to non-bottoming continuations like: - - hello :: Bool -> Int - hello n = - runRW# ( - case n of - True -> \s -> 23 - _ -> \s -> 10) - -Why? The difference is that (case bot of {}) is considered by okCpeArg to be -trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both -the function and the arguments) will forgo binding it to a variable. By -contrast, in the non-bottoming case of `hello` above the function will be -deemed non-trivial and consequently will be case-bound. - - -Note [Simplification of runRW#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the program, - - case runRW# (\s -> I# 42#) of - I# n# -> f n# - -There is no reason why we should allocate an I# constructor given that we -immediately destructure it. - -To avoid this the simplifier has a special transformation rule, specific to -runRW#, that pushes a strict context into runRW#'s continuation. See the -`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`. That is, it transforms - - K[ runRW# @r @ty cont ] - ~> - runRW# @r @ty (\s -> K[cont s]) - -This has a few interesting implications. Consider, for instance, this program: - - join j = ... - in case runRW# @r @ty cont of - result -> jump j result - -Performing the transform described above would result in: - - join j x = ... - in runRW# @r @ty (\s -> - case cont of in - result -> jump j result - ) - -If runRW# were a "normal" function this call to join point j would not be -allowed in its continuation argument. However, since runRW# is inlined (as -described in Note [runRW magic] above), such join point occurrences are -completely fine. Both occurrence analysis (see the runRW guard in occAnalApp) -and Core Lint (see the App case of lintCoreExpr) have special treatment for -runRW# applications. See Note [Linting of runRW#] for details on the latter. - -Moreover, it's helpful to ensure that runRW's continuation isn't floated out -For instance, if we have - - runRW# (\s -> do_something) - -where do_something contains only top-level free variables, we may be tempted to -float the argument to the top-level. However, we must resist this urge as since -doing so would then require that runRW# produce an allocation and call, e.g.: - - let lvl = \s -> do_somethign - in - ....(runRW# lvl).... - -whereas without floating the inlining of the definition of runRW would result -in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special -treatment for runRW# applications, ensure the arguments are not floated as -MFEs. - -Now that we float evaluation context into runRW#, we also have to give runRW# a -special higher-order CPR transformer lest we risk #19822. E.g., - - case runRW# (\s -> doThings) of x -> Data.Text.Text x something something' - ~> - runRW# (\s -> case doThings s of x -> Data.Text.Text x something something') - -The former had the CPR property, and so should the latter. - -Other considered designs ------------------------- - -One design that was rejected was to *require* that runRW#'s continuation be -headed by a lambda. However, this proved to be quite fragile. For instance, -SetLevels is very eager to float bottoming expressions. For instance given -something of the form, - - runRW# @r @ty (\s -> case expr of x -> undefined) - -SetLevels will see that the body the lambda is bottoming and will consequently -float it to the top-level (assuming expr has no free coercion variables which -prevent this). We therefore end up with - - runRW# @r @ty (\s -> lvl s) - -Which the simplifier will beta reduce, leaving us with - - runRW# @r @ty lvl - -Breaking our desired invariant. Ultimately we decided to simply accept that -the continuation may not be a manifest lambda. - - --- --------------------------------------------------------------------------- --- CpeArg: produces a result satisfying CpeArg --- --------------------------------------------------------------------------- - -Note [ANF-ising literal string arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a program like, - - data Foo = Foo Addr# - - foo = Foo "turtle"# - -When we go to ANFise this we might think that we want to float the string -literal like we do any other non-trivial argument. This would look like, - - foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s } - -However, this 1) isn't necessary since strings are in a sense "trivial"; and 2) -wreaks havoc on the CAF annotations that we produce here since we the result -above is caffy since it is updateable. Ideally at some point in the future we -would like to just float the literal to the top level as suggested in #11312, - - s = "turtle"# - foo = Foo s - -However, until then we simply add a special case excluding literals from the -floating done by cpeArg. --} - --- | Is an argument okay to CPE? -okCpeArg :: CoreExpr -> Bool --- Don't float literals. See Note [ANF-ising literal string arguments]. -okCpeArg (Lit _) = False --- Do not eta expand a trivial argument -okCpeArg expr = not (exprIsTrivial expr) - --- This is where we arrange that a non-trivial argument is let-bound -cpeArg :: CorePrepEnv -> Demand - -> CoreArg -> UniqSM (Floats, CpeArg) -cpeArg env dmd arg - = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; let arg_ty = exprType arg1 - is_unlifted = isUnliftedType arg_ty - want_float = wantFloatNested NonRecursive dmd is_unlifted - ; (floats2, arg2) <- if want_float floats1 arg1 - then return (floats1, arg1) - else dontFloat floats1 arg1 - -- Else case: arg1 might have lambdas, and we can't - -- put them inside a wrapBinds - - ; if okCpeArg arg2 - then do { v <- newVar arg_ty - ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat env dmd is_unlifted v arg3 - ; return (addFloat floats2 arg_float, varToCoreExpr v) } - else return (floats2, arg2) - } - -{- -Note [Floating unlifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider C (let v* = expensive in v) - -where the "*" indicates "will be demanded". Usually v will have been -inlined by now, but let's suppose it hasn't (see #2756). Then we -do *not* want to get - - let v* = expensive in C v - -because that has different strictness. Hence the use of 'allLazy'. -(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) - - ------------------------------------------------------------------------------- --- Building the saturated syntax --- --------------------------------------------------------------------------- - -Note [Eta expansion of hasNoBinding things in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -maybeSaturate deals with eta expanding to saturate things that can't deal with -unsaturated applications (identified by 'hasNoBinding', currently -foreign calls, unboxed tuple/sum constructors, and representation-polymorphic -primitives such as 'coerce' and 'unsafeCoerce#'). - -Historical Note: Note that eta expansion in CorePrep used to be very fragile -due to the "prediction" of CAFfyness that we used to make during tidying. -We previously saturated primop -applications here as well but due to this fragility (see #16846) we now deal -with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps. --} - -maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs -maybeSaturate fn expr n_args unsat_ticks - | hasNoBinding fn -- There's no binding - = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr - - | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids] - , not applied_marks - = assertPpr - ( not (isJoinId fn)) -- See Note [Do not eta-expand join points] - ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ - text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ - text "join_arity" <+> ppr (isJoinId_maybe fn) $$ - text "fn_arity" <+> ppr fn_arity - ) $ - -- pprTrace "maybeSat" - -- ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ - -- text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ - -- text "join_arity" <+> ppr (isJoinId_maybe fn) $$ - -- text "fn_arity" <+> ppr fn_arity $$ - -- text "excess_arity" <+> ppr excess_arity $$ - -- text "mark_arity" <+> ppr mark_arity - -- ) $ - return sat_expr - - | otherwise - = assert (null unsat_ticks) $ - return expr - where - mark_arity = idCbvMarkArity fn - fn_arity = idArity fn - excess_arity = (max fn_arity mark_arity) - n_args - sat_expr = cpeEtaExpand excess_arity expr - applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . reverse . expectJust "maybeSaturate" $ (idCbvMarks_maybe fn)) - -- For join points we never eta-expand (See Note [Do not eta-expand join points]) - -- so we assert all arguments that need to be passed cbv are visible so that the backend can evalaute them if required.. -{- -************************************************************************ -* * - Simple GHC.Core operations -* * -************************************************************************ --} - -{- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder Remember, -CorePrep must not change arity - -Eta expansion might not have happened already, because it is done by -the simplifier only when there at least one lambda already. - -NB1:we could refrain when the RHS is trivial (which can happen - for exported things). This would reduce the amount of code - generated (a little) and make things a little worse for - code compiled without -O. The case in point is data constructor - wrappers. - -NB2: we have to be careful that the result of etaExpand doesn't - invalidate any of the assumptions that CorePrep is attempting - to establish. One possible cause is eta expanding inside of - an SCC note - we're now careful in etaExpand to make sure the - SCC is pushed inside any new lambdas that are generated. - -Note [Eta expansion and the CorePrep invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out to be much much easier to do eta expansion -*after* the main CorePrep stuff. But that places constraints -on the eta expander: given a CpeRhs, it must return a CpeRhs. - -For example here is what we do not want: - f = /\a -> g (h 3) -- h has arity 2 -After ANFing we get - f = /\a -> let s = h 3 in g s -and now we do NOT want eta expansion to give - f = /\a -> \ y -> (let s = h 3 in g s) y - -Instead GHC.Core.Opt.Arity.etaExpand gives - f = /\a -> \y -> let s = h 3 in g s y - --} - -cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs -cpeEtaExpand arity expr - | arity == 0 = expr - | otherwise = etaExpand arity expr - -{- -************************************************************************ -* * - Floats -* * -************************************************************************ - -Note [Pin demand info on floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pin demand info on floated lets, so that we can see the one-shot thunks. - -Note [Speculative evaluation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since call-by-value is much cheaper than call-by-need, we case-bind arguments -that are either - - 1. Strictly evaluated anyway, according to the DmdSig of the callee, or - 2. ok-for-spec, according to 'exprOkForSpeculation' - -While (1) is a no-brainer and always beneficial, (2) is a bit -more subtle, as the careful haddock for 'exprOkForSpeculation' -points out. Still, by case-binding the argument we don't need -to allocate a thunk for it, whose closure must be retained as -long as the callee might evaluate it. And if it is evaluated on -most code paths anyway, we get to turn the unknown eval in the -callee into a known call at the call site. - -Very Nasty Wrinkle - -We must be very careful not to speculate recursive calls! Doing so -might well change termination behavior. - -That comes up in practice for DFuns, which are considered ok-for-spec, -because they always immediately return a constructor. -See Note [NON-BOTTOM-DICTS invariant] in GHC.Core. - -But not so if you speculate the recursive call, as #20836 shows: - - class Foo m => Foo m where - runFoo :: m a -> m a - newtype Trans m a = Trans { runTrans :: m a } - instance Monad m => Foo (Trans m) where - runFoo = id - -(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The -example in #20836 is more compelling, but boils down to the same thing.) -This program compiles to the following DFun for the `Trans` instance: - - Rec { - $fFooTrans - = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id) - end Rec } - -Note that the DFun immediately terminates and produces a dictionary, just -like DFuns ought to, but it calls itself recursively to produce the `Foo m` -dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so -that we can speculate its calls, and hence use call-by-value, we get: - - $fFooTrans - = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc -> - C:Foo sc (\ @a -> id) - -and that's an infinite loop! -Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the -*body* of the letrec, it's absolutely fine to use call-by-value on -`foo ($fFooTrans d)`. - -Our solution is this: we track in cpe_rec_ids the set of enclosing -recursively-bound Ids, the RHSs of which we are currently transforming and then -in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation', -basically) we'll say that any binder in this set is not ok-for-spec. - -Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we -prep up `rhs1`, we have to include not only `f1`, but all binders of the group -`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive -DFuns. - -NB: If at some point we decide to have a termination analysis for general -functions (#8655, !1866), we need to take similar precautions for (guarded) -recursive functions: - - repeat x = x : repeat x - -Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x` -is a cheap call that we are willing to speculate, but *not* in repeat's RHS. -Fortunately, pce_rec_ids already has all the information we need in that case. - -The problem is very similar to Note [Eta reduction in recursive RHSs]. -Here as well as there it is *unsound* to change the termination properties -of the very function whose termination properties we are exploiting. - -It is also similar to Note [Do not strictify a DFun's parameter dictionaries], -where marking recursive DFuns (of undecidable *instances*) strict in dictionary -*parameters* leads to quite the same change in termination as above. --} - -data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - CpeBody -- Always ok-for-speculation - Id -- Case binder - AltCon [Var] -- Single alternative - Bool -- Ok-for-speculation; False of a strict, - -- but lifted binding - - -- | See Note [Floating Ticks in CorePrep] - | FloatTick CoreTickish - -data Floats = Floats OkToSpec (OrdList FloatingBind) - -instance Outputable FloatingBind where - ppr (FloatLet b) = ppr b - ppr (FloatCase r b k bs ok) = text "case" <> braces (ppr ok) <+> ppr r - <+> text "of"<+> ppr b <> text "@" - <> case bs of - [] -> ppr k - _ -> parens (ppr k <+> ppr bs) - ppr (FloatTick t) = ppr t - -instance Outputable Floats where - ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+> - braces (vcat (map ppr (fromOL fs))) - -instance Outputable OkToSpec where - ppr OkToSpec = text "OkToSpec" - ppr IfUnboxedOk = text "IfUnboxedOk" - ppr NotOkToSpec = text "NotOkToSpec" - --- Can we float these binds out of the rhs of a let? We cache this decision --- to avoid having to recompute it in a non-linear way when there are --- deeply nested lets. -data OkToSpec - = OkToSpec -- Lazy bindings of lifted type - | IfUnboxedOk -- A mixture of lazy lifted bindings and n - -- ok-to-speculate unlifted bindings - | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings - -mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind -mkFloat env dmd is_unlifted bndr rhs - | is_strict || ok_for_spec -- See Note [Speculative evaluation] - , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec - -- Don't make a case for a HNF binding, even if it's strict - -- Otherwise we get case (\x -> e) of ...! - - | is_unlifted = FloatCase rhs bndr DEFAULT [] True - -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled - -- because exprOkForSpeculation isn't stable under ANF-ing. See for - -- example #19489 where the following unlifted expression: - -- - -- GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] - -- (GHC.Types.: @a_ax0 a2_agq a3_agl) - -- - -- is ok-for-spec but is ANF-ised into: - -- - -- let sat = GHC.Types.: @a_ax0 a2_agq a3_agl - -- in GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] sat - -- - -- which isn't ok-for-spec because of the let-expression. - - | is_hnf = FloatLet (NonRec bndr rhs) - | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs) - -- See Note [Pin demand info on floats] - where - is_hnf = exprIsHNF rhs - is_strict = isStrUsedDmd dmd - ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs - is_rec_call = (`elemUnVarSet` cpe_rec_ids env) - -emptyFloats :: Floats -emptyFloats = Floats OkToSpec nilOL - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats _ bs) = isNilOL bs - -wrapBinds :: Floats -> CpeBody -> CpeBody -wrapBinds (Floats _ binds) body - = foldrOL mk_bind body binds - where - mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body] - mk_bind (FloatLet bind) body = Let bind body - mk_bind (FloatTick tickish) body = mkTick tickish body - -addFloat :: Floats -> FloatingBind -> Floats -addFloat (Floats ok_to_spec floats) new_float - = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) - where - check (FloatLet {}) = OkToSpec - check (FloatCase _ _ _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - check FloatTick{} = OkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level - -unitFloat :: FloatingBind -> Floats -unitFloat = addFloat emptyFloats - -appendFloats :: Floats -> Floats -> Floats -appendFloats (Floats spec1 floats1) (Floats spec2 floats2) - = Floats (combine spec1 spec2) (floats1 `appOL` floats2) - -concatFloats :: [Floats] -> OrdList FloatingBind -concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL - -combine :: OkToSpec -> OkToSpec -> OkToSpec -combine NotOkToSpec _ = NotOkToSpec -combine _ NotOkToSpec = NotOkToSpec -combine IfUnboxedOk _ = IfUnboxedOk -combine _ IfUnboxedOk = IfUnboxedOk -combine _ _ = OkToSpec - -deFloatTop :: Floats -> [CoreBind] --- For top level only; we don't expect any FloatCases -deFloatTop (Floats _ floats) - = foldrOL get [] floats - where - get (FloatLet b) bs = get_bind b : bs - get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs - get b _ = pprPanic "corePrepPgm" (ppr b) - - -- See Note [Dead code in CorePrep] - get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) - get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] - ---------------------------------------------------------------------------- - -canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -canFloat (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec -- Worth trying - , Just fs' <- go nilOL (fromOL fs) - = Just (Floats OkToSpec fs', rhs) - | otherwise - = Nothing - where - go :: OrdList FloatingBind -> [FloatingBind] - -> Maybe (OrdList FloatingBind) - - go (fbs_out) [] = Just fbs_out - - go fbs_out (fb@(FloatLet _) : fbs_in) - = go (fbs_out `snocOL` fb) fbs_in - - go fbs_out (ft@FloatTick{} : fbs_in) - = go (fbs_out `snocOL` ft) fbs_in - - go _ (FloatCase{} : _) = Nothing - - -wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool -wantFloatNested is_rec dmd is_unlifted floats rhs - = isEmptyFloats floats - || isStrUsedDmd dmd - || is_unlifted - || (allLazyNested is_rec floats && exprIsHNF rhs) - -- Why the test for allLazyNested? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early - -allLazyTop :: Floats -> Bool -allLazyTop (Floats OkToSpec _) = True -allLazyTop _ = False - -allLazyNested :: RecFlag -> Floats -> Bool -allLazyNested _ (Floats OkToSpec _) = True -allLazyNested _ (Floats NotOkToSpec _) = False -allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec - -{- -************************************************************************ -* * - Cloning -* * -************************************************************************ --} - --- --------------------------------------------------------------------------- --- The environment --- --------------------------------------------------------------------------- - -{- Note [Inlining in CorePrep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a subtle but important invariant that must be upheld in the output -of CorePrep: there are no "trivial" updatable thunks. Thus, this Core -is impermissible: - - let x :: () - x = y - -(where y is a reference to a GLOBAL variable). Thunks like this are silly: -they can always be profitably replaced by inlining x with y. Consequently, -the code generator/runtime does not bother implementing this properly -(specifically, there is no implementation of stg_ap_0_upd_info, which is the -stack frame that would be used to update this thunk. The "0" means it has -zero free variables.) - -In general, the inliner is good at eliminating these let-bindings. However, -there is one case where these trivial updatable thunks can arise: when -we are optimizing away 'lazy' (see Note [lazyId magic], and also -'cpeRhsE'.) Then, we could have started with: - - let x :: () - 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. - -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. - -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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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: - - let x :: () - x = lazy @ (forall a. a) y @ Bool - -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. - --} - -data CorePrepConfig = CorePrepConfig - { cp_catchNonexhaustiveCases :: !Bool - -- ^ Whether to generate a default alternative with ``error`` in these - -- cases. This is helpful when debugging demand analysis or type - -- checker bugs which can sometimes manifest as segmentation faults. - - , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr) - -- ^ Convert some numeric literals (Integer, Natural) into their final - -- Core form. - } - -data CorePrepEnv - = CPE { cpe_config :: !CorePrepConfig - -- ^ This flag is intended to aid in debugging strictness - -- analysis bugs. These are particularly nasty to chase down as - -- they may manifest as segmentation faults. When this flag is - -- enabled we instead produce an 'error' expression to catch - -- the case where a function we think should bottom - -- unexpectedly returns. - , cpe_env :: IdEnv CoreExpr -- Clone local Ids - -- ^ This environment is used for three operations: - -- - -- 1. To support cloning of local Ids so that they are - -- all unique (see item (6) of CorePrep overview). - -- - -- 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) - - , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv] - - , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] - } - -mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv -mkInitialCorePrepEnv cfg = CPE - { cpe_config = cfg - , cpe_env = emptyVarEnv - , cpe_tyco_env = Nothing - , cpe_rec_ids = emptyUnVarSet - } - -extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv -extendCorePrepEnv cpe id id' - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') } - -extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv -extendCorePrepEnvExpr cpe id expr - = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr } - -extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv -extendCorePrepEnvList cpe prs - = cpe { cpe_env = extendVarEnvList (cpe_env cpe) - (map (\(id, id') -> (id, Var id')) prs) } - -lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr -lookupCorePrepEnv cpe id - = case lookupVarEnv (cpe_env cpe) id of - Nothing -> Var id - Just exp -> exp - -enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv -enterRecGroupRHSs env grp - = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) } - ------------------------------------------------------------------------------- --- CpeTyCoEnv --- --------------------------------------------------------------------------- - -{- Note [CpeTyCoEnv] -~~~~~~~~~~~~~~~~~~~~ -The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution -for type and coercion variables - -* We need the coercion substitution to support the elimination of - unsafeEqualityProof (see Note [Unsafe coercions]) - -* We need the type substitution in case one of those unsafe - coercions occurs in the kind of tyvar binder (sigh) - -We don't need an in-scope set because we don't clone any of these -binders at all, so no new capture can take place. - -The cpe_tyco_env is almost always empty -- it only gets populated -when we get under an usafeEqualityProof. Hence the Maybe CpeTyCoEnv, -which makes everything into a no-op in the common case. --} - -data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv - -emptyTCE :: CpeTyCoEnv -emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv - -extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv -extend_tce_cv (TCE tv_env cv_env) cv co - = TCE tv_env (extendVarEnv cv_env cv co) - -extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv -extend_tce_tv (TCE tv_env cv_env) tv ty - = TCE (extendVarEnv tv_env tv ty) cv_env - -lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -lookup_tce_cv (TCE _ cv_env) cv - = case lookupVarEnv cv_env cv of - Just co -> co - Nothing -> mkCoVarCo cv - -lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type -lookup_tce_tv (TCE tv_env _) tv - = case lookupVarEnv tv_env tv of - Just ty -> ty - Nothing -> mkTyVarTy tv - -extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv -extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co - = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) } - where - tce = mb_tce `orElse` emptyTCE - - -cpSubstTy :: CorePrepEnv -> Type -> Type -cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty - = case mb_env of - Just env -> runIdentity (subst_ty env ty) - Nothing -> ty - -cpSubstCo :: CorePrepEnv -> Coercion -> Coercion -cpSubstCo (CPE { cpe_tyco_env = mb_env }) co - = case mb_env of - Just tce -> runIdentity (subst_co tce co) - Nothing -> co - -subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity -subst_tyco_mapper = TyCoMapper - { tcm_tyvar = \env tv -> return (lookup_tce_tv env tv) - , tcm_covar = \env cv -> return (lookup_tce_cv env cv) - , tcm_hole = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole) - , tcm_tycobinder = \env tcv _vis k -> if isTyVar tcv - then uncurry k (subst_tv_bndr env tcv) - else uncurry k (subst_cv_bndr env tcv) - , tcm_tycon = \tc -> return tc } - -subst_ty :: CpeTyCoEnv -> Type -> Identity Type -subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion -(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper - -cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar) -cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv - = case mb_env of - Nothing -> (env, tv) - Just tce -> (env { cpe_tyco_env = Just tce' }, tv') - where - (tce', tv') = subst_tv_bndr tce tv - -subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar) -subst_tv_bndr tce tv - = (extend_tce_tv tce tv (mkTyVarTy tv'), tv') - where - tv' = mkTyVar (tyVarName tv) kind' - kind' = runIdentity $ subst_ty tce $ tyVarKind tv - -cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar) -cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv - = case mb_env of - Nothing -> (env, cv) - Just tce -> (env { cpe_tyco_env = Just tce' }, cv') - where - (tce', cv') = subst_cv_bndr tce cv - -subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar) -subst_cv_bndr tce cv - = (extend_tce_cv tce cv (mkCoVarCo cv'), cv') - where - cv' = mkCoVar (varName cv) ty' - ty' = runIdentity (subst_ty tce $ varType cv) - ------------------------------------------------------------------------------- --- Cloning binders --- --------------------------------------------------------------------------- - -cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar]) -cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs - -cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) -cpCloneBndr env bndr - | isTyVar bndr - = return (cpSubstTyVarBndr env bndr) - - | isCoVar bndr - = return (cpSubstCoVarBndr env bndr) - - | otherwise - = do { bndr' <- clone_it bndr - - -- Drop (now-useless) rules/unfoldings - -- See Note [Drop unfoldings and rules] - -- and Note [Preserve evaluatedness] in GHC.Core.Tidy - -- And force it.. otherwise the old unfolding is just retained. - -- See #22071 - ; let !unfolding' = trimUnfolding (realIdUnfolding bndr) - -- Simplifier will set the Id's unfolding - - bndr'' = bndr' `setIdUnfolding` unfolding' - `setIdSpecialisation` emptyRuleInfo - - ; return (extendCorePrepEnv env bndr bndr'', bndr'') } - where - clone_it bndr - | isLocalId bndr - = do { uniq <- getUniqueM - ; let ty' = cpSubstTy env (idType bndr) - ; return (setVarUnique (setIdType bndr ty') uniq) } - - | otherwise -- Top level things, which we don't want - -- to clone, have become GlobalIds by now - = return bndr - -{- Note [Drop unfoldings and rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to drop the unfolding/rules on every Id: - - - We are now past interface-file generation, and in the - codegen pipeline, so we really don't need full unfoldings/rules - - - The unfolding/rule may be keeping stuff alive that we'd like - to discard. See Note [Dead code in CorePrep] - - - Getting rid of unnecessary unfoldings reduces heap usage - - - We are changing uniques, so if we didn't discard unfoldings/rules - we'd have to substitute in them - -HOWEVER, we want to preserve evaluated-ness; -see Note [Preserve evaluatedness] in GHC.Core.Tidy. --} - ------------------------------------------------------------------------------- --- Cloning ccall Ids; each must have a unique name, --- to give the code generator a handle to hang it on --- --------------------------------------------------------------------------- - -fiddleCCall :: Id -> UniqSM Id -fiddleCCall id - | isFCallId id = (id `setVarUnique`) <$> getUniqueM - | otherwise = return id - ------------------------------------------------------------------------------- --- Generating new binders --- --------------------------------------------------------------------------- - -newVar :: Type -> UniqSM Id -newVar ty - = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty - - ------------------------------------------------------------------------------- --- Floating ticks --- --------------------------------------------------------------------------- --- --- Note [Floating Ticks in CorePrep] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- It might seem counter-intuitive to float ticks by default, given --- that we don't actually want to move them if we can help it. On the --- other hand, nothing gets very far in CorePrep anyway, and we want --- to preserve the order of let bindings and tick annotations in --- relation to each other. For example, if we just wrapped let floats --- when they pass through ticks, we might end up performing the --- following transformation: --- --- src<...> let foo = bar in baz --- ==> let foo = src<...> bar in src<...> baz --- --- Because the let-binding would float through the tick, and then --- immediately materialize, achieving nothing but decreasing tick --- accuracy. The only special case is the following scenario: --- --- let foo = src<...> (let a = b in bar) in baz --- ==> let foo = src<...> bar; a = src<...> b in baz --- --- Here we would not want the source tick to end up covering "baz" and --- therefore refrain from pushing ticks outside. Instead, we copy them --- into the floating binds (here "a") in cpePair. Note that where "b" --- or "bar" are (value) lambdas we have to push the annotations --- further inside in order to uphold our rules. --- --- All of this is implemented below in @wrapTicks@. - --- | Like wrapFloats, but only wraps tick floats -wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) -wrapTicks (Floats flag floats0) expr = - (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1)) - where (floats1, ticks1) = foldlOL go ([], []) $ floats0 - -- Deeply nested constructors will produce long lists of - -- redundant source note floats here. We need to eliminate - -- those early, as relying on mkTick to spot it after the fact - -- can yield O(n^3) complexity [#11095] - go (floats, ticks) (FloatTick t) - = assert (tickishPlace t == PlaceNonLam) - (floats, if any (flip tickishContains t) ticks - then ticks else t:ticks) - go (floats, ticks) f - = (foldr wrap f (reverse ticks):floats, ticks) - - wrap t (FloatLet bind) = FloatLet (wrapBind t bind) - wrap t (FloatCase r b con bs ok) = FloatCase (mkTick t r) b con bs ok - wrap _ other = pprPanic "wrapTicks: unexpected float!" - (ppr other) - wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) - wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) - ------------------------------------------------------------------------------- --- Numeric literals --- --------------------------------------------------------------------------- - --- | Create a function that converts Bignum literals into their final CoreExpr -mkConvertNumLiteral - :: Platform - -> HomeUnit - -> (Name -> IO TyThing) - -> IO (LitNumType -> Integer -> Maybe CoreExpr) -mkConvertNumLiteral platform home_unit lookup_global = do - let - guardBignum act - | isHomeUnitInstanceOf home_unit primUnitId - = return $ panic "Bignum literals are not supported in ghc-prim" - | isHomeUnitInstanceOf home_unit bignumUnitId - = return $ panic "Bignum literals are not supported in ghc-bignum" - | otherwise = act - - lookupBignumId n = guardBignum (tyThingId <$> lookup_global n) - - -- The lookup is done here but the failure (panic) is reported lazily when we - -- try to access the `bigNatFromWordList` function. - -- - -- If we ever get built-in ByteArray# literals, we could avoid the lookup by - -- directly using the Integer/Natural wired-in constructors for big numbers. - - bignatFromWordListId <- lookupBignumId bignatFromWordListName - - let - convertNumLit nt i = case nt of - LitNumBigNat -> Just (convertBignatPrim i) - _ -> Nothing - - convertBignatPrim i = - let - -- ByteArray# literals aren't supported (yet). Were they supported, - -- we would use them directly. We would need to handle - -- wordSize/endianness conversion between host and target - -- wordSize = platformWordSize platform - -- byteOrder = platformByteOrder platform - - -- For now we build a list of Words and we produce - -- `bigNatFromWordList# list_of_words` - - words = mkListExpr wordTy (reverse (unfoldr f i)) - where - f 0 = Nothing - f x = let low = x .&. mask - high = x `shiftR` bits - in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high) - bits = platformWordSizeInBits platform - mask = 2 ^ bits - 1 - - in mkApps (Var bignatFromWordListId) [words] - - - return convertNumLit +{-# LANGUAGE ViewPatterns #-} + +{- +(c) The University of Glasgow, 1994-2006 + + +Core pass to saturate constructors and PrimOps +-} + +module GHC.CoreToStg.Prep + ( CorePrepConfig (..) + , CorePrepPgmConfig (..) + , corePrepPgm + , corePrepExpr + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Driver.Flags + +import GHC.Unit + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +import GHC.Core.Utils +import GHC.Core.Opt.Arity +import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) +import GHC.Core +import GHC.Core.Subst +import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Opt.OccurAnal + +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.FastString +import GHC.Data.Graph.UnVar + +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Logger + +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Id.Make ( realWorldPrimId ) +import GHC.Types.Basic +import GHC.Types.Name ( OccName, NamedThing(..), isInternalName ) +import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Literal +import GHC.Types.Tickish +import GHC.Types.Unique.Supply + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import Data.ByteString.Builder.Prim + +import Control.Monad +import Data.List (intercalate) + +{- +Note [CorePrep Overview] +~~~~~~~~~~~~~~~~~~~~~~~~ + +The goal of this pass is to prepare for code generation. + +1. Saturate constructor and primop applications. + +2. Convert to A-normal form; that is, function arguments + are always variables. + + * Use case for strict arguments: + f E ==> case E of x -> f x + (where f is strict) + + * Use let for non-trivial lazy arguments + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) + +3. Similarly, convert any unboxed lets into cases. + [I'm experimenting with leaving 'ok-for-speculation' + rhss in let-form right up to this point.] + +4. Ensure that *value* lambdas only occur as the RHS of a binding + (The code generator can't deal with anything else.) + Type lambdas are ok, however, because the code gen discards them. + +5. ANF-isation results in additional bindings that can obscure values. + We float these out; see Note [Floating in CorePrep]. + +6. Clone all local Ids. See Note [Cloning in CorePrep] + +7. Give each dynamic CCall occurrence a fresh unique; this is + rather like the cloning step above. + +8. Convert bignum literals into their core representation. + +9. Uphold tick consistency while doing this: We move ticks out of + (non-type) applications where we can, and make sure that we + annotate according to scoping rules when floating. + +10. Collect cost centres (including cost centres in unfoldings) if we're in + profiling mode. We have to do this here because we won't have unfoldings + after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules]. + +11. Eliminate some magic Ids, specifically + runRW# (\s. e) ==> e[readWorldId/s] + lazy e ==> e (see Note [lazyId magic] in GHC.Types.Id.Make) + noinline e ==> e + nospec e ==> e + ToDo: keepAlive# ... + This is done in cpeApp + +This is all done modulo type applications and abstractions, so that +when type erasure is done for conversion to STG, we don't end up with +any trivial or useless bindings. + +Note [CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the syntax of the Core produced by CorePrep: + + Trivial expressions + arg ::= lit | var + | arg ty | /\a. arg + | co | arg |> co + + Applications + app ::= lit | var | app arg | app ty | app co | app |> co + + Expressions + body ::= app + | 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 + +We define a synonym for each of these non-terminals. Functions +with the corresponding name produce a result in that syntax. + +Note [Cloning in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In CorePrep we +* Always clone non-CoVar Ids, so each has a unique Unique +* Sometimes clone CoVars and TyVars + +We always clone non-CoVarIds, for three reasons + +1. Things associated with labels in the final code must be truly unique in + order to avoid labels being shadowed in the final output. + +2. Even binders without info tables like function arguments or alternative + bound binders must be unique at least in their type/unique combination. + We only emit a single declaration for each binder when compiling to C + so if binders are not unique we would either get duplicate declarations + or misstyped variables. The later happend in #22402. + +3. We heavily use unique-keyed maps in the backend which can go wrong when + ids with the same unique are meant to represent the same variable. + +Generally speaking we don't clone TyVars or CoVars. The code gen doesn't need +that (they are erased), and doing so would be tiresome because then we'd need +to substitute in types and coercions. But sometimes need to: see +Note [Cloning CoVars and TyVars] + +Note [Cloning CoVars and TyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Normally we don't need to clone TyVars and CoVars, but there is one occasion +when we do (see #24463). When we have + case unsafeEqualityProof ... of UnsafeRefl g -> ... +we try to float it, using UnsafeEqualityCase. +Why? See (U3) in Note [Implementing unsafeCoerce] + +Alas, floating it widens the scope of `g`, and that led to catastrophe in +#24463, when two identically-named g's shadowed. + +Solution: clone `g`; see `cpCloneCoVarBndr`. + +BUT once we clone `g` we must apply the cloning substitution to all types +and coercions. But that in turn means that, given a binder like + /\ (a :: kind |> g). blah +we must substitute in a's kind, and hence need to substitute for `a` +itself in `blah`. + +So our plan is: + * Maintain a full Subst in `cpe_subst` + + * Clone a CoVar when we we meet an `isUnsafeEqualityCase`; + otherwise TyVar/CoVar binders are never cloned. + + * So generally the TCvSubst is empty + + * Apply the substitution to type and coercion arguments in Core; but + happily `substTy` has a no-op short-cut for an empty TCvSubst, so this + is usually very cheap. + + * In `cpCloneBndr`, for a tyvar/covar binder, check for an empty substitution; + in that case just do nothing +-} + +type CpeArg = CoreExpr -- Non-terminal 'arg' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' + +{- +************************************************************************ +* * + Top level stuff +* * +************************************************************************ +-} + +data CorePrepPgmConfig = CorePrepPgmConfig + { cpPgm_endPassConfig :: !EndPassConfig + , cpPgm_generateDebugInfo :: !Bool + } + +corePrepPgm :: Logger + -> CorePrepConfig + -> CorePrepPgmConfig + -> Module -> CoreProgram + -> IO CoreProgram +corePrepPgm logger cp_cfg pgm_cfg + this_mod binds = + withTiming logger + (text "CorePrep"<+>brackets (ppr this_mod)) + (\a -> a `seqList` ()) $ do + let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg + + us <- mkSplitUniqSupply 's' + let + floats = initUs_ us $ + corePrepTopBinds initialCorePrepEnv binds + binds_out = deFloatTop floats + + endPassIO logger (cpPgm_endPassConfig pgm_cfg) + binds_out [] + + return binds_out + +corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr +corePrepExpr logger config expr = do + withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do + us <- mkSplitUniqSupply 's' + let initialCorePrepEnv = mkInitialCorePrepEnv config + let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) + putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + return new_expr + +corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats +-- Note [Floating out of top level bindings] +corePrepTopBinds initialCorePrepEnv binds + = go initialCorePrepEnv binds + where + go _ [] = return emptyFloats + go env (bind : binds) = do (env', floats, maybe_new_bind) + <- cpeBind TopLevel env bind + massert (isNothing maybe_new_bind) + -- Only join points get returned this way by + -- cpeBind, and no join point may float to top + floatss <- go env' binds + return (floats `zipFloats` floatss) + +{- ********************************************************************* +* * + The main code +* * +********************************************************************* -} + +{- Note [Floating in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +ANFisation risks producing a lot of nested lets that obscures values: + let v = (:) (f 14) [] in e + ==> { ANF in CorePrep } + let v = let sat = f 14 in (:) sat [] in e +Here, `v` is not a value anymore, and we'd allocate a thunk closure for `v` that +allocates a thunk for `sat` and then allocates the cons cell. +Hence we carry around a bunch of floated bindings with us so that we again +expose the values: + let v = let sat = f 14 in (:) sat [] in e + ==> { Float sat } + let sat = f 14 in + let v = (:) sat [] in e +(We will not do this transformation if `v` does not become a value afterwards; +see Note [wantFloatLocal].) +If `v` is bound at the top-level, we might even float `sat` to top-level; +see Note [Floating out of top level bindings]. +For nested let bindings, we have to keep in mind Note [Core letrec invariant] +and may exploit strict contexts; see Note [wantFloatLocal]. + +There are 3 main categories of floats, encoded in the `FloatingBind` type: + + * `Float`: A floated binding, as `sat` above. + These come in different flavours as described by their `FloatInfo` and + `BindInfo`, which captures how far the binding can be floated and whether or + not we want to case-bind. See Note [BindInfo and FloatInfo]. + * `UnsafeEqualityCase`: Used for floating around unsafeEqualityProof bindings; + see (U3) of Note [Implementing unsafeCoerce]. + It's exactly a `Float` that is `CaseBound` and `LazyContextFloatable` + (see `mkNonRecFloat`), but one that has a non-DEFAULT Case alternative to + 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 +Consider x = length [True,False] +We want to get + s1 = False : [] + s2 = True : s1 + x = length s2 + +We return a *list* of bindings, because we may start with + x* = f (g y) +where x is demanded, in which case we want to finish with + a = g y + x* = f a +And then x will actually end up case-bound + +Note [Join points and floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points can float out of other join points but not out of value bindings: + + let z = + let w = ... in -- can float + join k = ... in -- can't float + ... jump k ... + join j x1 ... xn = + let y = ... in -- can float (but don't want to) + join h = ... in -- can float (but not much point) + ... jump h ... + in ... + +Here, the jump to h remains valid if h is floated outward, but the jump to k +does not. + +We don't float *out* of join points. It would only be safe to float out of +nullary join points (or ones where the arguments are all either type arguments +or dead binders). Nullary join points aren't ever recursive, so they're always +effectively one-shot functions, which we don't float out of. We *could* float +join points from nullary join points, but there's no clear benefit at this +stage. + +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this (see #4962): + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they +are only kept alive by the occurrence analyser because they are +referred to by the rules of g, which is being kept alive by the fact +that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g +will ever fire, and it really seems like a shame to produce an output +program that goes to the trouble of allocating a closure for the +unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + + * In deFloatTop, run a simple dead code analyser on each top-level + RHS to drop the dead local bindings. + +The reason we don't just OccAnal the whole output of CorePrep is that +the tidier ensures that all top-level binders are GlobalIds, so they +don't show up in the free variables any longer. So if you run the +occurrence analyser on the output of CoreTidy (or later) you e.g. turn +this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + +Note [keepAlive# magic] +~~~~~~~~~~~~~~~~~~~~~~~ +When interacting with foreign code, it is often necessary for the user to +extend the lifetime of a heap object beyond the lifetime that would be apparent +from the on-heap references alone. For instance, a program like: + + foreign import safe "hello" hello :: ByteArray# -> IO () + + callForeign :: IO () + callForeign = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + unIO hello barr s1 + +As-written this program is susceptible to memory-unsafety since there are +no references to `barr` visible to the garbage collector. Consequently, if a +garbage collection happens during the execution of the C function `hello`, it +may be that the array is freed while in use by the foreign function. + +To address this, we introduced a new primop, keepAlive#, which "scopes over" +the computation needing the kept-alive value: + + keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b). + a -> State# RealWorld -> (State# RealWorld -> b) -> b + +When entered, an application (keepAlive# x s k) will apply `k` to the state +token, evaluating it to WHNF. However, during the course of this evaluation +will *guarantee* that `x` is considered to be alive. + +There are a few things to note here: + + - we are RuntimeRep-polymorphic in the value to be kept-alive. This is + necessary since we will often (but not always) be keeping alive something + unlifted (like a ByteArray#) + + - we are RuntimeRep-polymorphic in the result value since the result may take + many forms (e.g. a boxed value, a raw state token, or a (# State s, result #). + +We implement this operation by desugaring to touch# during CorePrep (see +GHC.CoreToStg.Prep.cpeApp). Specifically, + + keepAlive# x s0 k + +is transformed to: + + case k s0 of r -> + case touch# x realWorld# of s1 -> + r + +Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a +pointer to `x` and entering `k s0`. This compilation strategy is safe +because we do no optimization on STG that would drop or re-order the +continuation containing the `touch#`. However, if we were to become more +aggressive in our STG pipeline then we would need to revisit this. + +Beyond this CorePrep transformation, there is very little special about +keepAlive#. However, we did explore (and eventually gave up on) +an optimisation which would allow unboxing of constructed product results, +which we describe below. + + +Lost optimisation: CPR unboxing +-------------------------------- +One unfortunate property of this approach is that the simplifier is unable to +unbox the result of a keepAlive# expression. For instance, consider the program: + + case keepAlive# arr s0 ( + \s1 -> case peekInt arr s1 of + (# s2, r #) -> I# r + ) of + I# x -> ... + +This is a surprisingly common pattern, previously used, e.g., in +GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around +with optimising this away by pushing strict contexts (like the +`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can +recover unboxing, it can also unfortunately in general change the asymptotic +memory (namely stack) behavior of the program. For instance, consider + + writeN = + ... + case keepAlive# x s0 (\s1 -> something s1) of + (# s2, x #) -> + writeN ... + +As it is tail-recursive, this program will run in constant space. However, if +we push outer case into the continuation we get: + + writeN = + + case keepAlive# x s0 (\s1 -> + case something s1 of + (# s2, x #) -> + writeN ... + ) of + ... + +Which ends up building a stack which is linear in the recursion depth. For this +reason, we ended up giving up on this optimisation. + + +Historical note: touch# and its inadequacy +------------------------------------------ +Prior to the introduction of `keepAlive#` we instead addressed the need for +lifetime extension with the `touch#` primop: + + touch# :: a -> State# s -> State# s + +This operation would ensure that the `a` value passed as the first argument was +considered "alive" at the time the primop application is entered. + +For instance, the user might modify `callForeign` as: + + callForeign :: IO () + callForeign s0 = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + case unIO hello barr s1 of (# s2, () #) -> + case touch# barr s2 of s3 -> + (# s3, () #) + +However, in #14346 we discovered that this primop is insufficient in the +presence of simplification. For instance, consider a program like: + + callForeign :: IO () + callForeign s0 = IO $ \s0 -> + case newByteArray# n# s0 of (# s1, barr #) -> + case unIO (forever $ hello barr) s1 of (# s2, () #) -> + case touch# barr s2 of s3 -> + (# s3, () #) + +In this case the Simplifier may realize that (forever $ hello barr) +will never return and consequently that the `touch#` that follows is dead code. +As such, it will be dropped, resulting in memory unsoundness. +This unsoundness lead to the introduction of keepAlive#. + + + +Other related tickets: + + - #15544 + - #17760 + - #14375 + - #15260 + - #18061 +-} + +cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, + Floats, -- Floating value bindings + Maybe CoreBind) -- Just bind' <=> returned new bind; no float + -- Nothing <=> added bind' to floats instead +cpeBind top_lvl env (NonRec bndr rhs) + | not (isJoinId bndr) + = do { (env1, bndr1) <- cpCloneBndr env bndr + ; let dmd = idDemandInfo bndr + lev = typeLevity (idType bndr) + ; (floats, rhs1) <- cpePair top_lvl NonRecursive + dmd lev env bndr1 rhs + -- See Note [Inlining in CorePrep] + ; let triv_rhs = exprIsTrivial rhs1 + env2 | triv_rhs = extendCorePrepEnvExpr env1 bndr rhs1 + | otherwise = env1 + floats1 | triv_rhs, isInternalName (idName bndr) + = floats + | otherwise + = snocFloat floats new_float + + (new_float, _bndr2) = mkNonRecFloat env lev bndr1 rhs1 + + ; return (env2, floats1, Nothing) } + + | otherwise -- A join point; see Note [Join points and floating] + = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point + do { (_, bndr1) <- cpCloneBndr env bndr + ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs + ; return (extendCorePrepEnv env bndr bndr2, + emptyFloats, + Just (NonRec bndr2 rhs1)) } + +cpeBind top_lvl env (Rec pairs) + | not (isJoinId (head bndrs)) + = do { (env, bndrs1) <- cpCloneBndrs env bndrs + ; let env' = enterRecGroupRHSs env bndrs1 + ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env') + bndrs1 rhss + + ; let (zipManyFloats -> floats, rhss1) = unzip stuff + -- Glom all floats into the Rec, *except* FloatStrings; see + -- see Note [ANF-ising literal string arguments], Wrinkle (FS1) + is_lit (Float (NonRec _ rhs) CaseBound TopLvlFloatable) = exprIsTickedString rhs + is_lit _ = False + (string_floats, top) = partitionOL is_lit (fs_binds floats) + -- Strings will *always* be in `top_floats` (we made sure of + -- that in `snocOL`), so that's the only field we need to + -- partition. + floats' = floats { fs_binds = top } + all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) (getFloats floats') + -- use env below, so that we reset cpe_rec_ids + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1), + snocFloat (emptyFloats { fs_binds = string_floats }) + (Float (Rec all_pairs) LetBound TopLvlFloatable), + Nothing) } + + | otherwise -- See Note [Join points and floating] + = do { (env, bndrs1) <- cpCloneBndrs env bndrs + ; let env' = enterRecGroupRHSs env bndrs1 + ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss + + ; let bndrs2 = map fst pairs1 + -- use env below, so that we reset cpe_rec_ids + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), + emptyFloats, + Just (Rec pairs1)) } + where + (bndrs, rhss) = unzip pairs + + -- Flatten all the floats, and the current + -- group into a single giant Rec + add_float (Float bind bound _) prs2 + | bound /= CaseBound + || 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 + -- just as well put them in the Rec, in contrast to lifted bindings. + = case bind of + NonRec x e -> (x,e) : prs2 + Rec prs1 -> prs1 ++ prs2 + add_float f _ = pprPanic "cpeBind" (ppr f) + + +--------------- +cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity + -> CorePrepEnv -> OutId -> CoreExpr + -> UniqSM (Floats, CpeRhs) +-- Used for all bindings +-- The binder is already cloned, hence an OutId +cpePair top_lvl is_rec dmd lev env0 bndr rhs + = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair + do { (floats1, rhs1) <- cpeRhsE env rhs + + -- See if we are allowed to float this stuff out of the RHS + ; let dec = want_float_from_rhs floats1 rhs1 + ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs3) + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $ + -- Note [Silly extra arguments] + (do { v <- newVar env (idType bndr) + ; let (float, v') = mkNonRecFloat env Lifted v rhs2 + ; return ( snocFloat floats2 float + , cpeEtaExpand arity (Var v')) }) + + -- Wrap floating ticks + ; let (floats4, rhs4) = wrapTicks floats3 rhs3 + + ; return (floats4, rhs4) } + where + env = pushBinderContext bndr env0 + + arity = idArity bndr -- We must match this arity + + want_float_from_rhs floats rhs + | isTopLevel top_lvl = wantFloatTop floats + | otherwise = wantFloatLocal is_rec dmd lev floats rhs + +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} + +--------------- +cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr + -> UniqSM (JoinId, CpeRhs) +-- Used for all join bindings +-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils +cpeJoinPair env bndr rhs + = assert (isJoinId bndr) $ + do { let join_arity = case idJoinPointHood bndr of + JoinPoint join_arity -> join_arity + _ -> panic "cpeJoinPair" + (bndrs, body) = collectNBinders join_arity rhs + + ; (env', bndrs') <- cpCloneBndrs env bndrs + + ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts + -- with a lambda + + ; let rhs' = mkCoreLams bndrs' body' + bndr' = bndr `setIdUnfolding` evaldUnfolding + `setIdArity` count isId bndrs + -- See Note [Arity and join points] + + ; return (bndr', rhs') } + +{- +Note [Arity and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Up to now, we've allowed a join point to have an arity greater than its join +arity (minus type arguments), since this is what's useful for eta expansion. +However, for code gen purposes, its arity must be exactly the number of value +arguments it will be called with, and it must have exactly that many value +lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS: + + join j x y z = \w -> ... in ... + => + join j x y z = (let f = \w -> ... in f) in ... + +This is also what happens with Note [Silly extra arguments]. Note that it's okay +for us to mess with the arity because a join point is never exported. +-} + +-- --------------------------------------------------------------------------- +-- CpeRhs: produces a result satisfying CpeRhs +-- --------------------------------------------------------------------------- + +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- If +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) +-- +-- For example +-- f (g x) ===> ([v = g x], f v) + +cpeRhsE env (Type ty) + = return (emptyFloats, Type (cpSubstTy env ty)) +cpeRhsE env (Coercion co) + = return (emptyFloats, Coercion (cpSubstCo env co)) +cpeRhsE env expr@(Lit lit) + | LitNumber LitNumBigNat i <- lit + = cpeBigNatLit env i + | otherwise = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE env expr@(App {}) = cpeApp env expr + +cpeRhsE env (Let bind body) + = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind + ; (body_floats, body') <- cpeRhsE env' body + ; let expr' = case maybe_bind' of Just bind' -> Let bind' body' + Nothing -> body' + ; return (bind_floats `appFloats` body_floats, expr') } + +cpeRhsE env (Tick tickish expr) + -- Pull out ticks if they are allowed to be floated. + | tickishFloatable tickish + = do { (floats, body) <- cpeRhsE env expr + -- See [Floating Ticks in CorePrep] + ; return (FloatTick tickish `consFloat` floats, body) } + | otherwise + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, mkTick tickish' body) } + where + tickish' | Breakpoint ext bid fvs <- tickish + -- See also 'substTickish' + = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) + | otherwise + = tickish + +cpeRhsE env (Cast expr co) + = do { (floats, expr') <- cpeRhsE env expr + ; return (floats, Cast expr' (cpSubstCo env co)) } + +cpeRhsE env expr@(Lam {}) + = do { let (bndrs,body) = collectBinders expr + ; (env', bndrs') <- cpCloneBndrs env bndrs + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } + +cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _]) + -- See (U3) in Note [Implementing unsafeCoerce] + -- We need make the Case float, otherwise we get + -- let x = case ... of UnsafeRefl co -> + -- let y = expr in + -- K y + -- in f x + -- instead of + -- case ... of UnsafeRefl co -> + -- let y = expr in + -- let x = K y + -- in f x + -- Note that `x` is a value here. This is visible in the GHCi debugger tests + -- (such as `print003`). + | Just rhs <- isUnsafeEqualityCase scrut bndr alts + = do { (floats_scrut, scrut) <- cpeBody env scrut + + ; (env, bndr') <- cpCloneBndr env bndr + ; (env, covar') <- cpCloneCoVarBndr env covar + -- Important: here we clone the CoVar + -- See Note [Cloning CoVars and TyVars] + + -- Up until here this should do exactly the same as the regular code + -- path of `cpeRhsE Case{}`. + ; (floats_rhs, rhs) <- cpeBody env rhs + -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might + -- become a value + ; let case_float = UnsafeEqualityCase scrut bndr' con [covar'] + -- NB: It is OK to "evaluate" the proof eagerly. + -- Usually there's the danger that we float the unsafeCoerce out of + -- a branching Case alt. Not so here, because the regular code path + -- for `cpeRhsE Case{}` will not float out of alts. + 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 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 bndr3 = bndr2 `setIdUnfolding` evaldUnfolding + ; 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' + + ; case alts'' of + [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds] + | let float = mkCaseFloat bndr3 scrut' + -> return (snocFloat floats float, rhs) + _ -> return (floats, Case scrut' bndr3 (cpSubstTy env ty) alts'') } + where + sat_alt env (Alt con bs rhs) + = do { (env2, bs') <- cpCloneBndrs env bs + ; rhs' <- cpeBodyNF env2 rhs + ; return (Alt con bs' rhs') } + +-- --------------------------------------------------------------------------- +-- CpeBody: produces a result satisfying CpeBody +-- --------------------------------------------------------------------------- + +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without +-- producing any floats (any generated floats are immediately +-- let-bound using 'wrapBinds'). Generally you want this, esp. +-- when you've reached a binding form (e.g., a lambda) and +-- floating any further would be incorrect. +cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody +cpeBodyNF env expr + = do { (floats, body) <- cpeBody env expr + ; return (wrapBinds floats body) } + +-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce +-- a list of 'Floats' which are being propagated upwards. In +-- fact, this function is used in only two cases: to +-- implement 'cpeBodyNF' (which is what you usually want), +-- and in the case when a let-binding is in a case scrutinee--here, +-- we can always float out: +-- +-- case (let x = y in z) of ... +-- ==> let x = y in case z of ... +-- +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody env expr + = do { (floats1, rhs) <- cpeRhsE env expr + ; (floats2, body) <- rhsToBody env rhs + ; return (floats1 `appFloats` floats2, body) } + +-------- +rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-binding + +rhsToBody env (Tick t expr) + | tickishScoped t == NoScope -- only float out of non-scoped annotations + = do { (floats, expr') <- rhsToBody env expr + ; return (floats, mkTick t expr') } + +rhsToBody env (Cast e co) + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + = do { (floats, e') <- rhsToBody env e + ; return (floats, Cast e' co) } + +rhsToBody env expr@(Lam {}) -- See Note [No eta reduction needed in rhsToBody] + | all isTyVar bndrs -- Type lambdas are ok + = return (emptyFloats, expr) + | otherwise -- Some value lambdas + = do { let rhs = cpeEtaExpand (exprArity expr) expr + ; fn <- newVar env (exprType rhs) + ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable + ; return (unitFloat float, Var fn) } + where + (bndrs,_) = collectBinders expr + +rhsToBody _env expr = return (emptyFloats, expr) + + +{- Note [No eta reduction needed in rhsToBody] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Historical note. In the olden days we used to have a Prep-specific +eta-reduction step in rhsToBody: + rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep bndrs body + = return (emptyFloats, no_lam_result) + +The goal was to reduce + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } + +to avoid allocating a lambda. Of course, we'd allocate a PAP +instead, which is hardly better, but that's the way it was. + +Now we simply don't bother with this. It doesn't seem to be a win, +and it's extra work. +-} + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- + +data ArgInfo = AIApp CoreArg -- NB: Not a CpeApp yet + | AICast Coercion + | AITick CoreTickish + +instance Outputable ArgInfo where + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something like + `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool` +caused a compiler panic in #20938. Why did this happen? +The simplifier will eta-reduce the rhs giving us a partial +application of tagToEnum#. The tick is then pushed inside the +type argument. That is we get + `(Tick tagToEnum#) @Bool` +CorePrep would go on to see a undersaturated tagToEnum# application +and eta expand the expression under the tick. Giving us: + (Tick (\forall a. x -> tagToEnum# @a x) @Bool +Suddenly tagToEnum# is applied to a polymorphic type and the code generator +panics as it needs a concrete type to determine the representation. + +The problem in my eyes was that the tick covers a partial application +of a primop. There is no clear semantic for such a construct as we can't +partially apply a primop since they do not have bindings. +We fix this by expanding the scope of such ticks slightly to cover the body +of the eta-expanded expression. + +We do this by: +* Checking if an application is headed by a primOpish thing. +* If so we collect floatable ticks and usually but also profiling ticks + along with regular arguments. +* When rebuilding the application we check if any profiling ticks appear + before the primop is fully saturated. +* If the primop isn't fully satured we eta expand the primop application + and scope the tick to scope over the body of the saturated expression. + +Going back to #20938 this means starting with + `(Tick tagToEnum#) @Bool` +we check if the function head is a primop (yes). This means we collect the +profiling tick like if it was floatable. Giving us + (tagToEnum#, [CpeTick foo, CpeApp @Bool]). +cpe_app filters out the tick as a underscoped tick on the expression +`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the +body of the eta-expansion lambdas. Giving us `\x -> Tick (tagToEnum# @Bool x)`. +-} +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- 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) + ; cpe_app top_env terminal args + } + + where + -- We have a nested data structure of the form + -- e `App` a1 `App` a2 ... `App` an, convert it into + -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth) + -- We use 'ArgInfo' because we may also need to + -- record casts and ticks. Depth counts the number + -- of arguments that would consume strictness information + -- (so, no type or coercion arguments.) + collect_args :: CoreExpr -> (CoreExpr, [ArgInfo]) + collect_args e = go e [] + where + go (App fun arg) as + = go fun (AIApp arg : as) + go (Cast fun 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. + -- See Note [Ticks and mandatory eta expansion] + -- Here we look inside `fun` before we make the final decision about + -- floating the tick which isn't optimal for perf. But this only makes + -- a difference if we have a non-floatable tick which is somewhat rare. + | Var vh <- head + , Var head' <- lookupCorePrepEnv top_env vh + , etaExpansionTick head' tickish + = (head,as') + where + (head,as') = go fun (AITick tickish : as) + + -- Terminal could still be an app if it's wrapped by a tick. + -- E.g. Tick (f x) can give us (f x) as terminal. + go terminal as = (terminal, as) + + cpe_app :: CorePrepEnv + -> CoreExpr -- The thing we are calling + -> [ArgInfo] + -> UniqSM (Floats, CpeRhs) + 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 + -- Replace (noinline a) with a + -- See Note [noinlineId magic] in GHC.Types.Id.Make + || f `hasKey` nospecIdKey -- Replace (nospec a) with a + -- See Note [nospecId magic] in GHC.Types.Id.Make + + -- Consider the code: + -- + -- lazy (f x) y + -- + -- We need to make sure that we need to recursively collect arguments on + -- "f x", otherwise we'll float "f x" out (it's not a variable) and + -- end up with this awful -ddump-prep: + -- + -- case f x of f_x { + -- __DEFAULT -> f_x y + -- } + -- + -- rather than the far superior "f x y". Test case is par01. + = let (terminal, args') = collect_args arg + in cpe_app env terminal (args' ++ args) + + -- runRW# magic + 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 (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 (AIApp (Var realWorldPrimId) : rest) + -- TODO: What about casts? + where + has_value_arg [] = False + 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 <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty + ; let tup = mkCoreUnboxedTuple [token, Var case_bndr] + ; let float = mkCaseFloat 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 + hd = getIdFromTrivialExpr_maybe e2 + -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion] + min_arity = case hd of + Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing + Nothing -> Nothing + -- ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v)) + ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity + ; mb_saturate hd app floats unsat_ticks depth } + where + depth = val_args args + stricts = case idDmdSig v of + DmdSig (DmdType _ demands) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd + + -- We inlined into something that's not a var and has no args. + -- Bounce it back up to cpeRhsE. + cpe_app env fun [] = cpeRhsE env fun + + -- Here we get: + -- N-variable fun, better let-bind it + -- This case covers literals, apps, lams or let expressions applied to arguments. + -- Basically things we want to ANF before applying to arguments. + cpe_app env fun args + = do { (fun_floats, fun') <- cpeArg env evalDmd fun + -- If evalDmd says that it's sure to be evaluated, + -- we'll end up case-binding it + ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing + ; mb_saturate Nothing app floats unsat_ticks (val_args args) } + + -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG) + val_args :: [ArgInfo] -> Int + val_args args = go args 0 + where + go [] !n = n + go (info:infos) n = + case info of + 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 + AIApp e -> go infos n' + where + !n' + | isTypeArg e = n + | otherwise = n+1 + + -- Saturate if necessary + mb_saturate head app floats unsat_ticks depth = + case head of + Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks + ; return (floats, sat_app) } + _other -> do { massert (null unsat_ticks) + ; return (floats, app) } + + -- Deconstruct and rebuild the application, floating any non-atomic + -- arguments to the outside. We collect the type of the expression, + -- the head of the application, and the number of actual value arguments, + -- all of which are used to possibly saturate this application if it + -- has a constructor or primop at the head. + rebuild_app + :: CorePrepEnv + -> [ArgInfo] -- The arguments (inner to outer) + -> CpeApp -- The function + -> Floats -- INVARIANT: These floats don't bind anything that is in the CpeApp! + -- Just stuff floated out from the head of the application. + -> [Demand] + -> Maybe Arity + -> UniqSM (CpeApp + ,Floats + ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion] + ) + rebuild_app env args app floats ss req_depth = + rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth) + + rebuild_app' + :: CorePrepEnv + -> [ArgInfo] -- The arguments (inner to outer); substitution not applied + -> CpeApp -- Substitution already applied + -> Floats + -> [Demand] + -> [CoreTickish] + -> Int -- Number of arguments required to satisfy minimal tick scopes. + -> UniqSM (CpeApp, Floats, [CoreTickish]) + rebuild_app' _ [] app floats ss rt_ticks !_req_depth + = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info + return (app, floats, rt_ticks) + + rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of + -- See Note [Ticks and mandatory eta expansion] + _ | not (null rt_ticks), req_depth <= 0 + -> let tick_fun = foldr mkTick fun' rt_ticks + in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth + + 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 + + AIApp (Coercion co) + -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth + where + co' = cpSubstCo env co + + 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) + (ss1 : ss_rest, False) -> (ss1, ss_rest) + ([], _) -> (topDmd, []) + (fs, arg') <- cpeArg env ss1 arg + rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1) + + AICast co + -> 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] + AITick tickish + | tickishPlace tickish == PlaceRuntime + , req_depth > 0 + -> assert (isProfTick tickish) $ + rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth + | otherwise + -- See [Floating Ticks in CorePrep] + -> rebuild_app' env as fun' (snocFloat floats (FloatTick tickish)) ss rt_ticks req_depth + +isLazyExpr :: CoreExpr -> Bool +-- See Note [lazyId magic] in GHC.Types.Id.Make +isLazyExpr (Cast e _) = isLazyExpr e +isLazyExpr (Tick _ e) = isLazyExpr e +isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey +isLazyExpr _ = False + +{- Note [runRW magic] +~~~~~~~~~~~~~~~~~~~~~ +Some definitions, for instance @runST@, must have careful control over float out +of the bindings in their body. Consider this use of @runST@, + + f x = runST ( \ s -> let (a, s') = newArray# 100 [] s + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' ) + +If we inline @runST@, we'll get: + + f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +And now if we allow the @newArray#@ binding to float out to become a CAF, +we end up with a result that is totally and utterly wrong: + + f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! + in \ x -> + let (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +All calls to @f@ will share a {\em single} array! Clearly this is nonsense and +must be prevented. + +This is what @runRW#@ gives us: by being inlined extremely late in the +optimization (right before lowering to STG, in CorePrep), we can ensure that +no further floating will occur. This allows us to safely inline things like +@runST@, which are otherwise needlessly expensive (see #10678 and #5916). + +'runRW' has a variety of quirks: + + * 'runRW' is known-key with a NOINLINE definition in + GHC.Magic. This definition is used in cases where runRW is curried. + + * In addition to its normal Haskell definition in GHC.Magic, we give it + a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding + the incorrect sharing due to float-out noted above. + + * It is levity-polymorphic: + + runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) + => (State# RealWorld -> (# State# RealWorld, o #)) + -> (# State# RealWorld, o #) + + * It has some special simplification logic to allow unboxing of results when + runRW# appears in a strict context. See Note [Simplification of runRW#] + below. + + * Since its body is inlined, we allow runRW#'s argument to contain jumps to + join points. That is, the following is allowed: + + join j x = ... + in runRW# @_ @_ (\s -> ... jump j 42 ...) + + The Core Linter knows about this. See Note [Linting of runRW#] in + GHC.Core.Lint for details. + + The occurrence analyser and SetLevels also know about this, as described in + Note [Simplification of runRW#]. + +Other relevant Notes: + + * Note [Simplification of runRW#] below, describing a transformation of runRW + applications in strict contexts performed by the simplifier. + * Note [Linting of runRW#] in GHC.Core.Lint + * Note [runRW arg] below, describing a non-obvious case where the + late-inlining could go wrong. + +Note [runRW arg] +~~~~~~~~~~~~~~~~~~~ +Consider the Core program (from #11291), + + runRW# (case bot of {}) + +The late inlining logic in cpe_app would transform this into: + + (case bot of {}) realWorld# + +Which would rise to a panic in CoreToStg.myCollectArgs, which expects only +variables in function position. + +However, as runRW#'s strictness signature captures the fact that it will call +its argument this can't happen: the simplifier will transform the bottoming +application into simply (case bot of {}). + +Note that this reasoning does *not* apply to non-bottoming continuations like: + + hello :: Bool -> Int + hello n = + runRW# ( + case n of + True -> \s -> 23 + _ -> \s -> 10) + +Why? The difference is that (case bot of {}) is considered by okCpeArg to be +trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both +the function and the arguments) will forgo binding it to a variable. By +contrast, in the non-bottoming case of `hello` above the function will be +deemed non-trivial and consequently will be case-bound. + +Note [Simplification of runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the program, + + case runRW# (\s -> I# 42#) of + I# n# -> f n# + +There is no reason why we should allocate an I# constructor given that we +immediately destructure it. + +To avoid this the simplifier has a special transformation rule, specific to +runRW#, that pushes a strict context into runRW#'s continuation. See the +`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`. That is, it transforms + + K[ runRW# @r @ty cont ] + ~> + runRW# @r @ty (\s -> K[cont s]) + +This has a few interesting implications. Consider, for instance, this program: + + join j = ... + in case runRW# @r @ty cont of + result -> jump j result + +Performing the transform described above would result in: + + join j x = ... + in runRW# @r @ty (\s -> + case cont of in + result -> jump j result + ) + +If runRW# were a "normal" function this call to join point j would not be +allowed in its continuation argument. However, since runRW# is inlined (as +described in Note [runRW magic] above), such join point occurrences are +completely fine. Both occurrence analysis (see the runRW guard in occAnalApp) +and Core Lint (see the App case of lintCoreExpr) have special treatment for +runRW# applications. See Note [Linting of runRW#] for details on the latter. + +Moreover, it's helpful to ensure that runRW's continuation isn't floated out +For instance, if we have + + runRW# (\s -> do_something) + +where do_something contains only top-level free variables, we may be tempted to +float the argument to the top-level. However, we must resist this urge as since +doing so would then require that runRW# produce an allocation and call, e.g.: + + let lvl = \s -> do_somethign + in + ....(runRW# lvl).... + +whereas without floating the inlining of the definition of runRW would result +in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special +treatment for runRW# applications, ensure the arguments are not floated as +MFEs. + +Now that we float evaluation context into runRW#, we also have to give runRW# a +special higher-order CPR transformer lest we risk #19822. E.g., + + case runRW# (\s -> doThings) of x -> Data.Text.Text x something something' + ~> + runRW# (\s -> case doThings s of x -> Data.Text.Text x something something') + +The former had the CPR property, and so should the latter. + +Other considered designs +------------------------ +One design that was rejected was to *require* that runRW#'s continuation be +headed by a lambda. However, this proved to be quite fragile. For instance, +SetLevels is very eager to float bottoming expressions. For instance given +something of the form, + + runRW# @r @ty (\s -> case expr of x -> undefined) + +SetLevels will see that the body the lambda is bottoming and will consequently +float it to the top-level (assuming expr has no free coercion variables which +prevent this). We therefore end up with + + runRW# @r @ty (\s -> lvl s) + +Which the simplifier will beta reduce, leaving us with + + runRW# @r @ty lvl + +Breaking our desired invariant. Ultimately we decided to simply accept that +the continuation may not be a manifest lambda. + + +-- --------------------------------------------------------------------------- +-- CpeArg: produces a result satisfying CpeArg +-- --------------------------------------------------------------------------- + +Note [ANF-ising literal string arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a Core program like, + + data Foo = Foo Addr# + foo = Foo "turtle"# + +String literals are non-trivial, see 'GHC.Types.Literal.litIsTrivial', hence +they are non-atomic in STG. +With -O1, FloatOut is likely to have floated most of these strings to top-level, +not least to give CSE a chance to deduplicate strings early (before the +linker, that is). +(Notable exceptions seem to be applications of 'unpackAppendCString#'.) +But with -O0, there is no FloatOut, so CorePrep must do the ANFisation to + + s = "turtle"# + foo = Foo s + +(String literals are the only kind of binding allowed at top-level and hence +their `FloatInfo` is `TopLvlFloatable`.) + +This appears to lead to bad code if the arg is under a lambda, because CorePrep +doesn't float out of RHSs, e.g., (T23270) + + foo x = ... patError "turtle"# ... +==> foo x = ... case "turtle"# of s { __DEFAULT -> petError s } ... + +This looks bad because it evals an HNF on every call. +But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm: + + [section ""cstring" . cB4_str" { + cB4_str: + I8[] "turtle" + } + ... + _sAG::I64 = cB4_str; + R2 = _sAG::I64; + Sp = Sp + 8; + call Control.Exception.Base.patError_info(R2) args: 8, res: 0, upd: 8; + +Wrinkles: + +(FS1) We detect string literals in `cpeBind Rec{}` and float them out anyway; + otherwise we'd try to bind a string literal in a letrec, violating + Note [Core letrec invariant]. Since we know that literals don't have + free variables, we float further. + Arguably, we could just as well relax the letrec invariant for + string literals, or anthing that is a value (lifted or not). + This is tracked in #24036. +-} + +-- This is where we arrange that a non-trivial argument is let-bound +cpeArg :: CorePrepEnv -> Demand + -> CoreArg -> UniqSM (Floats, CpeArg) +cpeArg env dmd arg + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + ; let arg_ty = exprType arg1 + lev = typeLevity arg_ty + dec = wantFloatLocal NonRecursive dmd lev floats1 arg1 + ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1 + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + + -- Now ANF-ise any non-trivial argument + -- NB: "non-trivial" includes string literals; + -- see Note [ANF-ising literal string arguments] + ; if exprIsTrivial arg2 + then return (floats2, arg2) + else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty + -- See Note [Pin demand info on floats] + ; let arity = cpeArgArity env dec floats1 arg2 + arg3 = cpeEtaExpand arity arg2 + -- See Note [Eta expansion of arguments in CorePrep] + ; let (arg_float, v') = mkNonRecFloat env lev v arg3 + ---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2) + ; return (snocFloat floats2 arg_float, varToCoreExpr v') } + } + +cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity +-- ^ See Note [Eta expansion of arguments in CorePrep] +-- Returning 0 means "no eta-expansion"; see cpeEtaExpand +cpeArgArity env float_decision floats1 arg + | FloatNone <- float_decision + -- 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 + , not (eta_would_wreck_join arg) + -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] + = case exprEtaExpandArity ao arg of + Nothing -> 0 + Just at -> arityTypeArity at + + | otherwise + = exprArity arg -- this is cheap enough for -O0 + +eta_would_wreck_join :: CoreExpr -> Bool +-- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in +-- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep] +eta_would_wreck_join (Let bs e) = isJoinBind bs || eta_would_wreck_join e +eta_would_wreck_join (Lam _ e) = eta_would_wreck_join e +eta_would_wreck_join (Cast e _) = eta_would_wreck_join e +eta_would_wreck_join (Tick _ e) = eta_would_wreck_join e +eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts) +eta_would_wreck_join _ = False + +maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs +maybeSaturate fn expr n_args unsat_ticks + | hasNoBinding fn -- There's no binding + -- See Note [Eta expansion of hasNoBinding things in CorePrep] + = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr + + | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids] + , not applied_marks + = assertPpr + ( not (isJoinId fn)) -- See Note [Do not eta-expand join points] + ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ + text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ + text "join_arity" <+> ppr (idJoinPointHood fn) $$ + text "fn_arity" <+> ppr fn_arity + ) $ + -- pprTrace "maybeSat" + -- ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$ + -- text "marks:" <+> ppr (idCbvMarks_maybe fn) $$ + -- text "join_arity" <+> ppr (isJoinId_maybe fn) $$ + -- text "fn_arity" <+> ppr fn_arity $$ + -- text "excess_arity" <+> ppr excess_arity $$ + -- text "mark_arity" <+> ppr mark_arity + -- ) $ + return sat_expr + + | otherwise + = assert (null unsat_ticks) $ + return expr + where + mark_arity = idCbvMarkArity fn + fn_arity = idArity fn + excess_arity = (max fn_arity mark_arity) - n_args + sat_expr = cpeEtaExpand excess_arity expr + applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . + reverse . expectJust $ (idCbvMarks_maybe fn)) + -- For join points we never eta-expand (See Note [Do not eta-expand join points]) + -- so we assert all arguments that need to be passed cbv are visible so that the + -- backend can evalaute them if required.. + +{- Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~ +Eta expand to match the arity claimed by the binder Remember, +CorePrep must not change arity + +Eta expansion might not have happened already, because it is done by +the simplifier only when there at least one lambda already. + +NB1:we could refrain when the RHS is trivial (which can happen + for exported things). This would reduce the amount of code + generated (a little) and make things a little worse for + code compiled without -O. The case in point is data constructor + wrappers. + +NB2: we have to be careful that the result of etaExpand doesn't + invalidate any of the assumptions that CorePrep is attempting + to establish. One possible cause is eta expanding inside of + an SCC note - we're now careful in etaExpand to make sure the + SCC is pushed inside any new lambdas that are generated. + +Note [Eta expansion of hasNoBinding things in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +maybeSaturate deals with eta expanding to saturate things that can't deal +with unsaturated applications (identified by 'hasNoBinding', currently +foreign calls, unboxed tuple/sum constructors, and representation-polymorphic +primitives such as 'coerce' and 'unsafeCoerce#'). + +Historical Note: Note that eta expansion in CorePrep used to be very fragile +due to the "prediction" of CAFfyness that we used to make during tidying. We +previously saturated primop applications here as well but due to this +fragility (see #16846) we now deal with this another way, as described in +Note [Primop wrappers] in GHC.Builtin.PrimOps. + +Note [Eta expansion and the CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out to be much much easier to do eta expansion +*after* the main CorePrep stuff. But that places constraints +on the eta expander: given a CpeRhs, it must return a CpeRhs. + +For example here is what we do not want: + f = /\a -> g (h 3) -- h has arity 2 +After ANFing we get + f = /\a -> let s = h 3 in g s +and now we do NOT want eta expansion to give + f = /\a -> \ y -> (let s = h 3 in g s) y + +Instead GHC.Core.Opt.Arity.etaExpand gives + f = /\a -> \y -> let s = h 3 in g s y + +Note [Eta expansion of arguments in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to + + let t = g x + in f t + +We really don't want that `t` to be a thunk! That just wastes runtime, updating +a thunk with a PAP etc. The code generator could in principle allocate a PAP, +but in fact it does not know how to do that -- it's easier just to eta-expand: + + let t = \y. g x y + in f t + +To what arity should we eta-expand the argument? `cpeArg` uses two strategies, +governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O): + + 1. Cheap, with -O0: just use `exprArity`. + 2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`, + same function the Simplifier uses to eta expand RHSs and lambda bodies. + +The only reason for using (1) rather than (2) is to keep compile times down. +Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and +T5321*. However, Plan (2) catches cases that (1) misses. +For example (#23083, assuming -fno-pedantic-bottoms): + + let t = case z of __DEFAULT -> g x + in f t + +to + + let t = \y -> case z of __DEFAULT -> g x y + in f t + +Note that there is a missed opportunity in eta expanding `t` earlier, in the +Simplifier: It would allow us to inline `g`, potentially enabling further +simplification. But then we could have inlined `g` into the PAP to begin with, +and that is discussed in #23150; hence we needn't worry about that in CorePrep. + +There is a nasty Wrinkle: + +(EA1) When eta expanding an argument headed by a join point, we might get + "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts + it. This crap means the output does not conform to the syntax in + Note [CorePrep invariants], which then makes later passes crash (#25033). + Consider + + f (join j x = rhs in ...(j 1)...(j 2)...) + + where the argument has arity 1. We might be tempted to eta expand, to + + f (\y -> (join j x = rhs in ...(j 1)...(j 2)...) y) + + Why hasn't the App to `y` been pushed into the join point? That's exactly + the crap of Note [Eta expansion for join points], so we have to put up + with it here. + In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid + `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App + case of `coreToStgExpr`. + + Hence, in `eta_would_wreck_join`, we check for the cases where an + intervening join point binding in the tail context of the argument would + make eta-expansion break Note [CorePrep invariants], in which + case we abstain from eta expansion. + + This scenario occurs rarely; hence it's OK to generate sub-optimal code. + The alternative would be to fix Note [Eta expansion for join points], but + that's quite challenging due to unfoldings of (recursive) join points. + + `eta_would_wreck_join` sees if there are any join points, like `j` above + that would be messed up. It must look inside lambdas (#25033); consider + f (\x. join j y = ... in ...(j 1)...(j 3)...) + We can't eta expand that `\x` any more than we could if the join was at + the top. (And when there's a lambda, we don't have a thunk anyway.) + +(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like + let in rhs + where is non-empty and can't be floated out of a lazy context (see + `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0 + forthwith. Without this short-cut we will call exprEtaExpandArity on the + `arg`, and might be enormous. exprEtaExpandArity be very expensive + on this: it uses arityType, and may look at . + + On the other hand, if float_decision = FloatAll, there will be no + let-bindings around 'arg'; they will have floated out. So + exprEtaExpandArity is cheap. + + This can make a huge difference on deeply nested expressions like + f (f (f (f (f ...)))) + #24471 is a good example, where Prep took 25% of compile time! +-} + +cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs +cpeEtaExpand arity expr + | arity == 0 = expr + | otherwise = etaExpand arity expr + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ + +Note [Pin demand info on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pin demand info on floated lets, so that we can see one-shot thunks. +For example, + f (g x) +where `f` uses its argument at most 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 str-ctx + 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 [Pin evaluatedness on floats] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When creating a new float `sat=e` in `mkNonRecFloat`, we propagate `sat` with an +`evaldUnfolding` if `e` is a value. + +To see why, consider a call to a CBV function, such as a DataCon worker with +*strict* fields, in an argument context, such as + + data Box a = Box !a + ... f (Box e) ... + +where `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`. +After ANFisation, we want to get the very nice code + + case x +# 1# of x' -> + let sat = I# x' in + let sat2 = Box sat in + f sat2 + +Note that Case (2) of Note [wantFloatLocal] is in effect. That is, + + * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f + * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound. + * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can + be let-bound. + +Hence no thunk needs to be allocated! However, in order to recognise +`Box sat` as a value, it is crucial that the newly created `sat` has an +`evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`. +and we would get the far worse code + + let sat2 = + case x +# 1# of x' -> + case I# x' of sat' -> + Box sat in + f sat2 + +A live example of this is T24730, inspired by $walexGetByte. + +Note [Speculative evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since call-by-value is much cheaper than call-by-need, we case-bind arguments +that are either + + 1. Strictly evaluated anyway, according to the DmdSig of the callee, or + 2. ok-for-spec, according to 'exprOkForSpeculation'. + This includes DFuns `$fEqList a`, for example. + (Could identify more in the future; see reference to !1866 below.) + +While (1) is a no-brainer and always beneficial, (2) is a bit +more subtle, as the careful haddock for 'exprOkForSpeculation' +points out. Still, by case-binding the argument we don't need +to allocate a thunk for it, whose closure must be retained as +long as the callee might evaluate it. And if it is evaluated on +most code paths anyway, we get to turn the unknown eval in the +callee into a known call at the call site. + +Very Nasty Wrinkle + +We must be very careful not to speculate recursive calls! Doing so +might well change termination behavior. + +That comes up in practice for DFuns, which are considered ok-for-spec, +because they always immediately return a constructor. +See Note [NON-BOTTOM-DICTS invariant] in GHC.Core. + +But not so if you speculate the recursive call, as #20836 shows: + + class Foo m => Foo m where + runFoo :: m a -> m a + newtype Trans m a = Trans { runTrans :: m a } + instance Monad m => Foo (Trans m) where + runFoo = id + +(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The +example in #20836 is more compelling, but boils down to the same thing.) +This program compiles to the following DFun for the `Trans` instance: + + Rec { + $fFooTrans + = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id) + end Rec } + +Note that the DFun immediately terminates and produces a dictionary, just +like DFuns ought to, but it calls itself recursively to produce the `Foo m` +dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so +that we can speculate its calls, and hence use call-by-value, we get: + + $fFooTrans + = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc -> + C:Foo sc (\ @a -> id) + +and that's an infinite loop! +Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the +*body* of the letrec, it's absolutely fine to use call-by-value on +`foo ($fFooTrans d)`. + +Our solution is this: we track in cpe_rec_ids the set of enclosing +recursively-bound Ids, the RHSs of which we are currently transforming and then +in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation', +basically) we'll say that any binder in this set is not ok-for-spec. + +Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we +prep up `rhs1`, we have to include not only `f1`, but all binders of the group +`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive +DFuns. + +NB: If at some point we decide to have a termination analysis for general +functions (#8655, !1866), we need to take similar precautions for (guarded) +recursive functions: + + repeat x = x : repeat x + +Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x` +is a cheap call that we are willing to speculate, but *not* in repeat's RHS. +Fortunately, pce_rec_ids already has all the information we need in that case. + +The problem is very similar to Note [Eta reduction in recursive RHSs]. +Here as well as there it is *unsound* to change the termination properties +of the very function whose termination properties we are exploiting. + +It is also similar to Note [Do not strictify a DFun's parameter dictionaries], +where marking recursive DFuns (of undecidable *instances*) strict in dictionary +*parameters* leads to quite the same change in termination as above. + +Note [BindInfo and FloatInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `BindInfo` of a `Float` describes whether it will be case-bound or +let-bound: + + * `LetBound`: A let binding `let x = rhs in ...`, can be Rec or NonRec. + * `CaseBound`: A case binding `case rhs of x -> { __DEFAULT -> .. }`. + (So always NonRec.) + Some case-bound things (string literals, lifted bindings) + can float to top-level (but not all), hence it is similar + to, but not the same as `StrictContextFloatable :: FloatInfo` + described below. + +This info is used in `wrapBinds` to pick the corresponding binding form. + +We want to case-bind iff the binding is (non-recursive, and) either + + * ok-for-spec-eval (and perhaps lifted, see Note [Speculative evaluation]), or + * unlifted, or + * strictly used + +The `FloatInfo` of a `Float` describes how far it can float without +(a) violating Core invariants and (b) changing semantics. + + * 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`. + Counterexample: A strict or unlifted binding that isn't ok-for-spec-eval + such as `case divInt# x y of r -> { __DEFAULT -> I# r }`. + Here, we may not foat out the strict `r = divInt# x y`. + + * A binding is `TopLvlFloatable` if it is `LazyContextFloatable` and also can + be bound at the top level. + Counterexample: A strict or unlifted binding (ok-for-spec-eval or not) + such as `case x +# y of r -> { __DEFAULT -> I# r }`. + +This meaning of "at least" is encoded in `floatsAtLeastAsFarAs`. +Note that today, `LetBound` implies `TopLvlFloatable`, so we could make do with +the the following enum (check `mkNonRecFloat` for whether this is up to date): + + LetBoundTopLvlFloatable (lifted or boxed values) + CaseBoundTopLvlFloatable (strings, ok-for-spec-eval and lifted) + CaseBoundLazyContextFloatable (ok-for-spec-eval and unlifted) + CaseBoundStrictContextFloatable (not ok-for-spec-eval and unlifted) + +Although there is redundancy in the current encoding, SG thinks it is cleaner +conceptually. + +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 in the coreprep phase has a positive +effect on performance, however we have found that some forms of speculative +evaluation can lead to large performance regressions. See #25284. + +Therefore we have some flags to control which types of speculative evaluation +are done: + + -fspec-eval + Globally enable/disable speculative evaluation ( -fno-spec-eval also turns + off all other speculative evaluation). On by default for all + optimization levels. Turning on this flag by itself should never cause + a performance regression. Please open a ticket if you find any. + + -fspec-eval-dictfun + Enable speculative evaluation for dictionary functions. Off by default + since it can cause an increase in allocations (#24284). We have no + examples that show a large performance improvement when turning on this + flag. Please open a ticket if you find any. + +Also see the optimization section in the User's Guide for the description of +these flags and when to use them. + +Note [Floats and FloatDecision] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have a special datatype `Floats` for modelling a telescope of `FloatingBind` +and caching its "maximum" `FloatInfo`, according to `floatsAtLeastAsFarAs` +(see Note [BindInfo and FloatInfo] for the ordering). +There are several operations for creating and combining `Floats` that maintain +scoping and the cached `FloatInfo`. + +When deciding whether we want to float out a `Floats` out of a binding context +such as `let x = <> in e` (let), `f <>` (app), or `x = <>; ...` (top-level), +we consult the cached `FloatInfo` of the `Floats`: + + * If we want to float to the top-level (`x = <>; ...`), we check whether + we may float-at-least-as-far-as `TopLvlFloatable`, in which case we + respond with `FloatAll :: FloatDecision`; otherwise we say `FloatNone`. + * If we want to float locally (let or app), then the floating decision is + described in Note [wantFloatLocal]. + +`executeFloatDecision` is then used to act on the particular `FloatDecision`. +-} + +-- See Note [BindInfo and FloatInfo] +data BindInfo + = CaseBound -- ^ A strict binding + | LetBound -- ^ A lazy or value binding + deriving Eq + +-- See Note [BindInfo and FloatInfo] +data FloatInfo + = TopLvlFloatable + -- ^ Anything that can be bound at top-level, such as arbitrary lifted + -- bindings or anything that responds True to `exprIsHNF`, such as literals or + -- saturated DataCon apps where unlifted or strict args are values. + + | LazyContextFloatable + -- ^ Anything that can be floated out of a lazy context. + -- In addition to any 'TopLvlFloatable' things, this includes (unlifted) + -- bindings that are ok-for-spec that we intend to case-bind. + + | StrictContextFloatable + -- ^ Anything that can be floated out of a strict evaluation context. + -- That is possible for all bindings; this is the Top element of 'FloatInfo'. + + deriving Eq + +instance Outputable BindInfo where + ppr CaseBound = text "Case" + ppr LetBound = text "Let" + +instance Outputable FloatInfo where + ppr TopLvlFloatable = text "top-lvl" + ppr LazyContextFloatable = text "lzy-ctx" + ppr StrictContextFloatable = text "str-ctx" + +-- See Note [Floating in CorePrep] +-- and Note [BindInfo and FloatInfo] +data FloatingBind + = Float !CoreBind !BindInfo !FloatInfo -- Never a join-point binding + | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr] + | FloatTick CoreTickish + +-- See Note [Floats and FloatDecision] +data Floats + = Floats + { fs_info :: !FloatInfo + , fs_binds :: !(OrdList FloatingBind) + } + +instance Outputable FloatingBind where + ppr (Float b bi fi) = ppr bi <+> ppr fi <+> ppr b + ppr (FloatTick t) = ppr t + ppr (UnsafeEqualityCase scrut b k bs) = text "case" <+> ppr scrut + <+> text "of"<+> ppr b <> text "@" + <> case bs of + [] -> ppr k + _ -> parens (ppr k <+> ppr bs) + +instance Outputable Floats where + ppr (Floats info binds) = text "Floats" <> brackets (ppr info) <> braces (ppr binds) + +lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo +lubFloatInfo StrictContextFloatable _ = StrictContextFloatable +lubFloatInfo _ StrictContextFloatable = StrictContextFloatable +lubFloatInfo LazyContextFloatable _ = LazyContextFloatable +lubFloatInfo _ LazyContextFloatable = LazyContextFloatable +lubFloatInfo TopLvlFloatable TopLvlFloatable = TopLvlFloatable + +floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool +-- See Note [Floats and FloatDecision] +floatsAtLeastAsFarAs l r = l `lubFloatInfo` r == r + +emptyFloats :: Floats +emptyFloats = Floats TopLvlFloatable nilOL + +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ b) = isNilOL b + +getFloats :: Floats -> OrdList FloatingBind +getFloats = fs_binds + +unitFloat :: FloatingBind -> Floats +unitFloat = snocFloat emptyFloats + +floatInfo :: FloatingBind -> FloatInfo +floatInfo (Float _ _ info) = info +floatInfo UnsafeEqualityCase{} = LazyContextFloatable -- See Note [Floating in CorePrep] +floatInfo FloatTick{} = TopLvlFloatable -- We filter these out in cpePair, + -- see Note [Floating Ticks in CorePrep] + +-- | Append a `FloatingBind` `b` to a `Floats` telescope `bs` that may reference any +-- binding of the 'Floats'. +snocFloat :: Floats -> FloatingBind -> Floats +snocFloat floats fb = + Floats { fs_info = lubFloatInfo (fs_info floats) (floatInfo fb) + , fs_binds = fs_binds floats `snocOL` fb } + +-- | Cons a `FloatingBind` `b` to a `Floats` telescope `bs` which scopes over +-- `b`. +consFloat :: FloatingBind -> Floats -> Floats +consFloat fb floats = + Floats { fs_info = lubFloatInfo (fs_info floats) (floatInfo fb) + , fs_binds = fb `consOL` fs_binds floats } + +-- | Append two telescopes, nesting the right inside the left. +appFloats :: Floats -> Floats -> Floats +appFloats outer inner = + Floats { fs_info = lubFloatInfo (fs_info outer) (fs_info inner) + , fs_binds = fs_binds outer `appOL` fs_binds inner } + +-- | Zip up two `Floats`, none of which scope over the other +zipFloats :: Floats -> Floats -> Floats +-- We may certainly just nest one telescope in the other, so appFloats is a +-- valid implementation strategy. +zipFloats = appFloats + +-- | `zipFloats` a bunch of independent telescopes. +zipManyFloats :: [Floats] -> Floats +zipManyFloats = foldr zipFloats emptyFloats + +data FloatInfoArgs + = FIA + { fia_levity :: Levity + , fia_demand :: Demand + , fia_is_hnf :: Bool + , fia_is_triv :: Bool + , fia_is_string :: Bool + , fia_is_dc_worker :: Bool + , fia_ok_for_spec :: Bool + } + +defFloatInfoArgs :: Id -> CoreExpr -> FloatInfoArgs +defFloatInfoArgs bndr rhs + = FIA + { fia_levity = typeLevity (idType bndr) + , fia_demand = idDemandInfo bndr -- mkCaseFloat uses evalDmd + , fia_is_hnf = exprIsHNF rhs + , fia_is_triv = exprIsTrivial rhs + , fia_is_string = exprIsTickedString rhs + , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False + , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval + } + +decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo) +decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf, + fia_is_triv=is_triv, fia_is_string=is_string, + fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec} + | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable) + -- is_lifted: We currently don't allow unlifted values at the + -- top-level or inside letrecs + -- (but SG thinks that in principle, we should) + -- is_triv: Should not turn `case x of x' ->` into `let x' = x` + -- when x is a HNF (cf. fun3 of T24264) + | is_dc_worker = (LetBound, TopLvlFloatable) + -- We need this special case for nullary unlifted DataCon + -- workers/wrappers (top-level bindings) until #17521 is fixed + | is_string = (CaseBound, TopLvlFloatable) + -- String literals are unboxed (so must be case-bound) and float to + -- the top-level + | ok_for_spec = (CaseBound, case lev of Unlifted -> LazyContextFloatable + Lifted -> TopLvlFloatable) + -- See Note [Speculative evaluation] + -- Ok-for-spec-eval things will be case-bound, lifted or not. + -- But when it's lifted we are ok with floating it to top-level + -- (where it is actually bound lazily). + | Unlifted <- lev = (CaseBound, StrictContextFloatable) + | isStrUsedDmd dmd = (CaseBound, StrictContextFloatable) + -- These will never be floated out of a lazy RHS context + | Lifted <- lev = (LetBound, TopLvlFloatable) + -- And these float freely but can't be speculated, hence LetBound + +mkCaseFloat :: Id -> CpeRhs -> FloatingBind +mkCaseFloat bndr scrut + = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info) + -- -- <+> ppr is_lifted <+> ppr is_strict + -- -- <+> ppr ok_for_spec <+> ppr evald + -- $$ ppr scrut) $ + Float (NonRec bndr scrut) bound info + where + !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr scrut) + { fia_demand = evalDmd + -- Strict demand, so that we do not let-bind unless it's a value + , fia_is_dc_worker = False + -- DataCon worker *bindings* are never case-bound + , fia_ok_for_spec = False + -- We do not currently float around case bindings. + -- (ok-for-spec case bindings are unlikely anyway.) + } + +mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id) +mkNonRecFloat env lev bndr rhs + = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info) + -- <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted" + -- <+> if ok_for_spec then text "ok-for-spec" else empty + -- <+> if evald then text "evald" else empty + -- $$ ppr rhs) $ + (Float (NonRec bndr' rhs) bound info, bndr') + where + !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr rhs) + { fia_levity = lev + , fia_is_hnf = is_hnf + , fia_ok_for_spec = ok_for_spec + } + + is_hnf = exprIsHNF rhs + 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 + is_rec_call = (`elemUnVarSet` cpe_rec_ids env) + + -- See Note [Pin evaluatedness on floats] + bndr' | is_hnf = bndr `setIdUnfolding` evaldUnfolding + | otherwise = bndr + +-- | Wrap floats around an expression +wrapBinds :: Floats -> CpeBody -> CpeBody +wrapBinds floats body + = -- pprTraceWith "wrapBinds" (\res -> ppr floats $$ ppr body $$ ppr res) $ + foldrOL mk_bind body (getFloats floats) + where + -- See Note [BindInfo and FloatInfo] on whether we pick Case or Let here + mk_bind f@(Float bind CaseBound _) body + | NonRec bndr rhs <- bind + = mkDefaultCase rhs bndr body + | otherwise + = pprPanic "wrapBinds" (ppr f) + mk_bind (Float bind _ _) body + = Let bind body + mk_bind (UnsafeEqualityCase scrut b con bs) body + = mkSingleAltCase scrut b con bs body + mk_bind (FloatTick tickish) body + = mkTick tickish body + +-- | Put floats at top-level +deFloatTop :: Floats -> [CoreBind] +-- Precondition: No Strict or LazyContextFloatable 'FloatInfo', no ticks! +deFloatTop floats + = foldrOL get [] (getFloats floats) + where + get (Float b _ TopLvlFloatable) bs + = get_bind b : bs + get b _ = pprPanic "deFloatTop" (ppr b) + + -- See Note [Dead code in CorePrep] + get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e) + get_bind (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] + +--------------------------------------------------------------------------- + +{- Note [wantFloatLocal] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x = let y = e1 in e2 + in e +Similarly for `(\x. e) (let y = e1 in e2)`. +Do we want to float `y` out of `x`? +(This is discussed in detail in the paper +"Let-floating: moving bindings to give faster programs".) + +`wantFloatLocal` is concerned with answering this question. +It considers the Demand on `x`, whether or not `e2` is unlifted and the +`FloatInfo` of the `y` binding (e.g., it might itself be unlifted, a value, +strict, or ok-for-spec). + +We float out if ... + 1. ... the binding context is strict anyway, so either `x` is used strictly + or has unlifted type. + Doing so is trivially sound and won`t increase allocations, so we + return `FloatAll`. + This might happen while ANF-ising `f (g (h 13))` where `f`,`g` are strict: + f (g (h 13)) + ==> { ANF } + case (case h 13 of r -> g r) of r2 -> f r2 + ==> { Float } + case h 13 of r -> case g r of r2 -> f r2 + The latter is easier to read and grows less stack. + 2. ... `e2` becomes a value in doing so, in which case we won't need to + allocate a thunk for `x`/the arg that closes over the FVs of `e1`. + In general, this is only sound if `y=e1` is `LazyContextFloatable`. + (See Note [BindInfo and FloatInfo].) + Nothing is won if `x` doesn't become a value + (i.e., `let x = let sat = f 14 in g sat in e`), + so we return `FloatNone` if there is any float that is + `StrictContextFloatable`, and return `FloatAll` otherwise. + +To elaborate on (2), consider the case when the floated binding is +`e1 = divInt# a b`, e.g., not `LazyContextFloatable`: + let x = I# (a `divInt#` b) + in e +this ANFises to + let x = case a `divInt#` b of r { __DEFAULT -> I# r } + in e +If `x` is used lazily, we may not float `r` further out. +A float binding `x +# y` is OK, though, and so every ok-for-spec-eval +binding is `LazyContextFloatable`. + +Wrinkles: + + (W1) When the outer binding is a letrec, i.e., + letrec x = case a +# b of r { __DEFAULT -> f y r } + y = [x] + in e + we don't want to float `LazyContextFloatable` bindings such as `r` either + and require `TopLvlFloatable` instead. + The reason is that we don't track FV of FloatBindings, so we would need + to park them in the letrec, + letrec r = a +# b -- NB: r`s RHS might scope over x and y + x = f y r + y = [x] + in e + and now we have violated Note [Core letrec invariant]. + So we preempt this case in `wantFloatLocal`, responding `FloatNone` unless + all floats are `TopLvlFloatable`. +-} + +data FloatDecision + = FloatNone + | FloatAll + +instance Outputable FloatDecision where + ppr FloatNone = text "none" + ppr FloatAll = text "all" + +executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs) +executeFloatDecision env dec floats rhs + = case dec of + FloatAll -> return (floats, rhs) + FloatNone + | isEmptyFloats floats -> return (emptyFloats, rhs) + | otherwise -> do { (floats', body) <- rhsToBody env rhs + ; return (emptyFloats, wrapBinds floats $ + wrapBinds floats' body) } + -- FloatNone case: `rhs` might have lambdas, and we can't + -- put them inside a wrapBinds, which expects a `CpeBody`. + +wantFloatTop :: Floats -> FloatDecision +wantFloatTop fs + | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll + | otherwise = FloatNone + +wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision +-- See Note [wantFloatLocal] +wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs + | isEmptyFloats floats -- Well yeah... + || isStrUsedDmd rhs_dmd -- Case (1) of Note [wantFloatLocal] + || rhs_lev == Unlifted -- dito + || (fs_info floats `floatsAtLeastAsFarAs` max_float_info && exprIsHNF rhs) + -- Case (2) of Note [wantFloatLocal] + = FloatAll + + | otherwise + = FloatNone + where + max_float_info | isRec is_rec = TopLvlFloatable + | otherwise = LazyContextFloatable + -- See Note [wantFloatLocal], Wrinkle (W1) + -- for 'is_rec' + +{- +************************************************************************ +* * + Cloning +* * +************************************************************************ +-} + +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +{- Note [Inlining in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a subtle but important invariant that must be upheld in the output +of CorePrep: there are no "trivial" updatable thunks. Thus, this Core +is impermissible: + + let x :: () + x = y + +(where y is a reference to a GLOBAL variable). Thunks like this are silly: +they can always be profitably replaced by inlining x with y. Consequently, +the code generator/runtime does not bother implementing this properly +(specifically, there is no implementation of stg_ap_0_upd_info, which is the +stack frame that would be used to update this thunk. The "0" means it has +zero free variables.) + +In general, the inliner is good at eliminating these let-bindings. However, +there is one case where these trivial updatable thunks can arise: when +we are optimizing away 'lazy' (see Note [lazyId magic], and also +'cpeRhsE'.) Then, we could have started with: + + let x :: () + 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. + +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. + +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 [CorePrepEnv: cpe_subst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field, +for these reasons: + +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] (#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 + { cp_catchNonexhaustiveCases :: !Bool + -- ^ Whether to generate a default alternative with ``error`` in these + -- cases. This is helpful when debugging demand analysis or type + -- checker bugs which can sometimes manifest as segmentation faults. + + , cp_platform :: Platform + + , cp_arityOpts :: !(Maybe ArityOpts) + -- ^ 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 + = CPE { cpe_config :: !CorePrepConfig + -- ^ This flag is intended to aid in debugging strictness + -- analysis bugs. These are particularly nasty to chase down as + -- they may manifest as segmentation faults. When this flag is + -- enabled we instead produce an 'error' expression to catch + -- the case where a function we think should bottom + -- unexpectedly returns. + + , cpe_subst :: Subst -- ^ See Note [CorePrepEnv: cpe_subst] + + , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] + + , cpe_context :: [OccName] -- ^ See Note [Binder context] + } + +mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv +mkInitialCorePrepEnv cfg = CPE + { cpe_config = cfg + , cpe_subst = emptySubst + , cpe_rec_ids = emptyUnVarSet + , cpe_context = [] + } + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv cpe@(CPE { cpe_subst = subst }) id id' + = cpe { cpe_subst = subst2 } + where + subst1 = extendSubstInScope subst id' + subst2 = extendIdSubst subst1 id (Var id') + +extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv +extendCorePrepEnvList cpe@(CPE { cpe_subst = subst }) prs + = cpe { cpe_subst = subst2 } + where + subst1 = extendSubstInScopeList subst (map snd prs) + subst2 = extendIdSubstList subst1 [(id, Var id') | (id,id') <- prs] + +extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv +extendCorePrepEnvExpr cpe id expr + = cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr } + +lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr +lookupCorePrepEnv cpe id + = case lookupIdSubst_maybe (cpe_subst cpe) id of + Just e -> e + Nothing -> Var id + -- Do not use GHC.Core.Subs.lookupIdSubst because that is a no-op on GblIds; + -- and Tidy has made top-level externally-visible Ids into GblIds + +enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv +enterRecGroupRHSs env grp + = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) } + +cpSubstTy :: CorePrepEnv -> Type -> Type +cpSubstTy (CPE { cpe_subst = subst }) ty = substTy subst ty + -- substTy has a short-cut if the TCvSubst is empty + +cpSubstCo :: CorePrepEnv -> Coercion -> Coercion +cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co + -- substCo has a short-cut if the TCvSubst is empty + +-- | See Note [Binder context] +pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv +pushBinderContext ident env + | lengthAtLeast (cpe_context env) 2 + = env + | otherwise + = env { cpe_context = getOccName ident : cpe_context env} + +------------------------------------------------------------------------------ +-- Cloning binders +-- --------------------------------------------------------------------------- + +cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs + +cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) +-- Clone the CoVar +-- See Note [Cloning CoVars and TyVars] +cpCloneCoVarBndr env@(CPE { cpe_subst = subst }) covar + = assertPpr (isCoVar covar) (ppr covar) $ + do { uniq <- getUniqueM + ; let covar1 = setVarUnique covar uniq + covar2 = updateVarType (substTy subst) covar1 + subst1 = extendTCvSubstWithClone subst covar covar2 + ; return (env { cpe_subst = subst1 }, covar2) } + +cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) +-- See Note [Cloning in CorePrep] +cpCloneBndr env@(CPE { cpe_subst = subst }) bndr + | isTyCoVar bndr -- See Note [Cloning CoVars and TyVars] + = if isEmptyTCvSubst subst -- The common case + then return (env { cpe_subst = extendSubstInScope subst bndr }, bndr) + else -- No need to clone the Unique; but we must apply the substitution + let bndr1 = updateVarType (substTy subst) bndr + subst1 = extendTCvSubstWithClone subst bndr bndr1 + in return (env { cpe_subst = subst1 }, bndr1) + + | otherwise -- A non-CoVar Id + = do { bndr1 <- clone_it bndr + ; let bndr2 = updateIdTypeAndMult (substTy subst) bndr1 + + -- Drop (now-useless) rules/unfoldings + -- See Note [Drop unfoldings and rules] + -- and Note [Preserve evaluatedness] in GHC.Core.Tidy + -- And force it.. otherwise the old unfolding is just retained. + -- See #22071 + ; let !unfolding' = trimUnfolding (realIdUnfolding bndr) + -- Simplifier will set the Id's unfolding + + bndr3 = bndr2 `setIdUnfolding` unfolding' + `setIdSpecialisation` emptyRuleInfo + + ; return (extendCorePrepEnv env bndr bndr3, bndr3) } + where + clone_it bndr + | isLocalId bndr + = do { uniq <- getUniqueM + ; return (setVarUnique bndr uniq) } + + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + = return bndr + +{- Note [Drop unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to drop the unfolding/rules on every Id: + + - We are now past interface-file generation, and in the + codegen pipeline, so we really don't need full unfoldings/rules + + - The unfolding/rule may be keeping stuff alive that we'd like + to discard. See Note [Dead code in CorePrep] + + - Getting rid of unnecessary unfoldings reduces heap usage + + - We are changing uniques, so if we didn't discard unfoldings/rules + we'd have to substitute in them + +HOWEVER, we want to preserve evaluated-ness; +see Note [Preserve evaluatedness] in GHC.Core.Tidy. +-} + +------------------------------------------------------------------------------ +-- Cloning ccall Ids; each must have a unique name, +-- to give the code generator a handle to hang it on +-- --------------------------------------------------------------------------- + +fiddleCCall :: Id -> UniqSM Id +fiddleCCall id + | isFCallId id = (id `setVarUnique`) <$> getUniqueM + | otherwise = return id + +------------------------------------------------------------------------------ +-- Generating new binders +-- --------------------------------------------------------------------------- + +newVar :: CorePrepEnv -> Type -> UniqSM Id +newVar env ty + -- See Note [Binder context] + = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty + where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat" + +{- Note [Binder context] + ~~~~~~~~~~~~~~~~~~~~~ + To ensure that the compiled program (specifically symbol names) + remains understandable to the user we maintain a context + of binders that we are currently under. This allows us to give + identifiers conjured during CorePrep more contextually-meaningful + names. This is done in `newVar`. + -} + +------------------------------------------------------------------------------ +-- Floating ticks +-- --------------------------------------------------------------------------- +-- +-- Note [Floating Ticks in CorePrep] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- It might seem counter-intuitive to float ticks by default, given +-- that we don't actually want to move them if we can help it. On the +-- other hand, nothing gets very far in CorePrep anyway, and we want +-- to preserve the order of let bindings and tick annotations in +-- relation to each other. For example, if we just wrapped let floats +-- when they pass through ticks, we might end up performing the +-- following transformation: +-- +-- src<...> let foo = bar in baz +-- ==> let foo = src<...> bar in src<...> baz +-- +-- Because the let-binding would float through the tick, and then +-- immediately materialize, achieving nothing but decreasing tick +-- accuracy. The only special case is the following scenario: +-- +-- let foo = src<...> (let a = b in bar) in baz +-- ==> let foo = src<...> bar; a = src<...> b in baz +-- +-- Here we would not want the source tick to end up covering "baz" and +-- therefore refrain from pushing ticks outside. Instead, we copy them +-- into the floating binds (here "a") in cpePair. Note that where "b" +-- or "bar" are (value) lambdas we have to push the annotations +-- further inside in order to uphold our rules. +-- +-- All of this is implemented below in @wrapTicks@. + +-- | Like wrapFloats, but only wraps tick floats +wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) +wrapTicks floats expr + | (floats1, ticks1) <- fold_fun go floats + = (floats1, foldrOL mkTick expr ticks1) + where fold_fun f floats = + let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats) + in (floats { fs_binds = binds }, ticks) + -- Deeply nested constructors will produce long lists of + -- redundant source note floats here. We need to eliminate + -- those early, as relying on mkTick to spot it after the fact + -- can yield O(n^3) complexity [#11095] + go (flt_binds, ticks) (FloatTick t) + = assert (tickishPlace t == PlaceNonLam) + (flt_binds, if any (flip tickishContains t) ticks + then ticks else ticks `snocOL` t) + go (flt_binds, ticks) f@UnsafeEqualityCase{} + -- unsafe equality case will be erased; don't wrap anything! + = (flt_binds `snocOL` f, ticks) + go (flt_binds, ticks) f@Float{} + = (flt_binds `snocOL` foldrOL wrap f ticks, ticks) + + wrap t (Float bind bound info) = Float (wrapBind t bind) bound info + wrap _ f = pprPanic "Unexpected FloatingBind" (ppr f) + wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) + wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) + +------------------------------------------------------------------------------ +-- Numeric literals +-- --------------------------------------------------------------------------- + +-- | Converts Bignum literals into their final CoreExpr +cpeBigNatLit + :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs) +cpeBigNatLit env i = assert (i >= 0) $ do + let + platform = cp_platform (cpe_config env) + + -- Per the documentation in GHC.Internal.Bignum.BigNat, a BigNat# is: + -- "Represented as an array of limbs (Word#) stored in + -- little-endian order (Word# themselves use machine order)." + -- + -- "Invariant (canonical representation): higher Word# is non-zero." + -- So we need to break up the integer into target-word-sized chunks, + -- and encode each of them using the target's byte-order. + encodeBigNat + :: forall a. Num a => FixedPrim a -> BS.ByteString + encodeBigNat encodeWord + = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i)) + -- (quadratic complexity due to repeated shifts... ok for now) + where + f 0 = Nothing + f x = let low = fromInteger x :: a + high = x `shiftR` bits + in Just (low, high) + bits = platformWordSizeInBits platform + + words :: BS.ByteString + words = case (platformWordSize platform, platformByteOrder platform) of + (PW4, LittleEndian) -> encodeBigNat word32LE + (PW4, BigEndian ) -> encodeBigNat word32BE + (PW8, LittleEndian) -> encodeBigNat word64LE + (PW8, BigEndian ) -> encodeBigNat word64BE + + -- Ideally we would just generate a ByteArray# literal here: + -- pure (emptyFloats, Lit (LitByteArray words)) + -- But sadly we don't have those yet, even in Core. (See also #17747.) + -- So instead we generate: + -- * An `Addr#` literal that contains the contents of the + -- `ByteArray#` we want to create. This gets its own float. + -- * A call to `newByteArray#` with the appropriate size + -- * A call to `copyAddrToByteArray#` to initialize the `ByteArray#` + -- * A call to `unsafeFreezeByteArray#` to make the types match + litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy + -- returned from newByteArray#: + deadNewByteArrayTupleId + <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $ + mkTupleTy Unboxed [ realWorldStatePrimTy + , realWorldMutableByteArrayPrimTy + ] + stateTokenFromNewByteArrayId + <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + mutableByteArrayId + <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy + -- returned from copyAddrToByteArray#: + stateTokenFromCopyId + <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + -- returned from unsafeFreezeByteArray#: + deadFreezeTupleId + <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $ + mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy] + stateTokenFromFreezeId + <- (`setIdOccInfo` IAmDead) <$> + mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy + byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy + + let + litAddrRhs = Lit (LitString words) + -- not "mkLitString"; that does UTF-8 encoding, which we don't want here + (litAddrFloat, litAddrId') = mkNonRecFloat env Unlifted litAddrId litAddrRhs + + contentsLength = mkIntLit platform (toInteger (BS.length words)) + + newByteArrayCall = + Var (primOpId NewByteArrayOp_Char) + `App` Type realWorldTy + `App` contentsLength + `App` Var realWorldPrimId + + copyContentsCall = + Var (primOpId CopyAddrToByteArrayOp) + `App` Type realWorldTy + `App` Var litAddrId' + `App` Var mutableByteArrayId + `App` mkIntLit platform 0 + `App` contentsLength + `App` Var stateTokenFromNewByteArrayId + + unsafeFreezeCall = + Var (primOpId UnsafeFreezeByteArrayOp) + `App` Type realWorldTy + `App` Var mutableByteArrayId + `App` Var stateTokenFromCopyId + + unboxed2tuple_altcon :: AltCon + unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2) + + finalRhs = + Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy + [ Alt unboxed2tuple_altcon + [stateTokenFromNewByteArrayId, mutableByteArrayId] + copyContentsCase + ] + + copyContentsCase = + Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy + [ Alt DEFAULT [] unsafeFreezeCase + ] + + unsafeFreezeCase = + Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy + [ Alt unboxed2tuple_altcon + [stateTokenFromFreezeId, byteArrayId] + (Var byteArrayId) + ] + + pure (emptyFloats `snocFloat` litAddrFloat, finalRhs) diff --git a/GHC/Data/Bag.hs b/GHC/Data/Bag.hs --- a/GHC/Data/Bag.hs +++ b/GHC/Data/Bag.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-} module GHC.Data.Bag ( Bag, -- abstract type @@ -15,7 +16,7 @@ mapBag, pprBag, elemBag, lengthBag, filterBag, partitionBag, partitionBagWith, - concatBag, catBagMaybes, foldBag, + concatBag, catBagMaybes, foldBag_flip, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL, concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag, @@ -193,24 +194,10 @@ partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats, fails) = partitionWith pred (toList vs) -foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative - -> (a -> r) -- Replace UnitBag with this - -> r -- Replace EmptyBag with this - -> Bag a - -> r - -{- Standard definition -foldBag t u e EmptyBag = e -foldBag t u e (UnitBag x) = u x -foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) -foldBag t u e (ListBag xs) = foldr (t.u) e xs --} - --- More tail-recursive definition, exploiting associativity of "t" -foldBag _ _ e EmptyBag = e -foldBag t u e (UnitBag x) = u x `t` e -foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 -foldBag t u e (ListBag xs) = foldr (t.u) e xs +foldBag_flip :: (a -> b -> b) -> Bag a -> b -> b +-- Just foldr with flipped arguments, +-- so it can be chained more nicely +foldBag_flip k bag z = foldr k z bag mapBag :: (a -> b) -> Bag a -> Bag b mapBag = fmap diff --git a/GHC/Data/Bitmap.hs b/GHC/Data/Bitmap.hs --- a/GHC/Data/Bitmap.hs +++ b/GHC/Data/Bitmap.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE BangPatterns #-} - -- -- (c) The University of Glasgow 2003-2006 -- diff --git a/GHC/Data/BooleanFormula.hs b/GHC/Data/BooleanFormula.hs --- a/GHC/Data/BooleanFormula.hs +++ b/GHC/Data/BooleanFormula.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveTraversable #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} -------------------------------------------------------------------------------- -- | Boolean formulas without quantifiers and without negation. @@ -8,75 +9,64 @@ -- This module is used to represent minimal complete definitions for classes. -- module GHC.Data.BooleanFormula ( - BooleanFormula(..), LBooleanFormula, - mkFalse, mkTrue, mkAnd, mkOr, mkVar, + module Language.Haskell.Syntax.BooleanFormula, isFalse, isTrue, + bfMap, bfTraverse, eval, simplify, isUnsatisfied, implies, impliesAtom, - pprBooleanFormula, pprBooleanFormulaNice + pprBooleanFormula, pprBooleanFormulaNice, pprBooleanFormulaNormal ) where -import GHC.Prelude hiding ( init, last ) - -import Data.List ( nub, intersperse ) +import Data.List ( intersperse ) import Data.List.NonEmpty ( NonEmpty (..), init, last ) -import Data.Data -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Parser.Annotation ( LocatedL ) -import GHC.Types.SrcLoc +import GHC.Prelude hiding ( init, last ) import GHC.Types.Unique import GHC.Types.Unique.Set +import GHC.Types.SrcLoc (unLoc) +import GHC.Utils.Outputable +import GHC.Parser.Annotation ( SrcSpanAnnL ) +import GHC.Hs.Extension (GhcPass (..), OutputableBndrId) +import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP) +import Language.Haskell.Syntax.BooleanFormula + ---------------------------------------------------------------------- -- Boolean formula type and smart constructors ---------------------------------------------------------------------- -type LBooleanFormula a = LocatedL (BooleanFormula a) - -data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] - | Parens (LBooleanFormula a) - deriving (Eq, Data, Functor, Foldable, Traversable) - -mkVar :: a -> BooleanFormula a -mkVar = Var - -mkFalse, mkTrue :: BooleanFormula a -mkFalse = Or [] -mkTrue = And [] +type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL --- Convert a Bool to a BooleanFormula -mkBool :: Bool -> BooleanFormula a -mkBool False = mkFalse -mkBool True = mkTrue +-- if we had Functor/Traversable (LbooleanFormula p) we could use that +-- as a constraint and we wouldn't need to specialize to just GhcPass p, +-- but becuase LBooleanFormula is a type synonym such a constraint is +-- impossible. --- Make a conjunction, and try to simplify -mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd +-- BooleanFormula can't be an instance of functor because it can't lift +-- arbitrary functions `a -> b`, only functions of type `LIdP a -> LIdP b` +-- ditto for Traversable. +bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p')) + -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p') +bfMap f = go where - -- See Note [Simplification of BooleanFormulas] - fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] - fromAnd (L _ (And xs)) = Just xs - -- assume that xs are already simplified - -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs - fromAnd (L _ (Or [])) = Nothing - -- in case of False we bail out, And [..,mkFalse,..] == mkFalse - fromAnd x = Just [x] - mkAnd' [x] = unLoc x - mkAnd' xs = And xs + go (Var a ) = Var $ f a + go (And bfs) = And $ map (fmap go) bfs + go (Or bfs) = Or $ map (fmap go) bfs + go (Parens bf ) = Parens $ fmap go bf -mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a -mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr +bfTraverse :: Applicative f + => (LIdP (GhcPass p) -> f (LIdP (GhcPass p'))) + -> BooleanFormula (GhcPass p) + -> f (BooleanFormula (GhcPass p')) +bfTraverse f = go where - -- See Note [Simplification of BooleanFormulas] - fromOr (L _ (Or xs)) = Just xs - fromOr (L _ (And [])) = Nothing - fromOr x = Just [x] - mkOr' [x] = unLoc x - mkOr' xs = Or xs + go (Var a ) = Var <$> f a + go (And bfs) = And <$> traverse @[] (traverse go) bfs + go (Or bfs) = Or <$> traverse @[] (traverse go) bfs + go (Parens bf ) = Parens <$> traverse go bf + {- Note [Simplification of BooleanFormulas] ~~~~~~~~~~~~~~~~~~~~~~ @@ -115,15 +105,15 @@ -- Evaluation and simplification ---------------------------------------------------------------------- -isFalse :: BooleanFormula a -> Bool +isFalse :: BooleanFormula (GhcPass p) -> Bool isFalse (Or []) = True isFalse _ = False -isTrue :: BooleanFormula a -> Bool +isTrue :: BooleanFormula (GhcPass p) -> Bool isTrue (And []) = True isTrue _ = False -eval :: (a -> Bool) -> BooleanFormula a -> Bool +eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool eval f (Var x) = f x eval f (And xs) = all (eval f . unLoc) xs eval f (Or xs) = any (eval f . unLoc) xs @@ -131,18 +121,24 @@ -- Simplify a boolean formula. -- The argument function should give the truth of the atoms, or Nothing if undecided. -simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a +simplify :: forall p. Eq (LIdP (GhcPass p)) + => (LIdP (GhcPass p) -> Maybe Bool) + -> BooleanFormula (GhcPass p) + -> BooleanFormula (GhcPass p) simplify f (Var a) = case f a of Nothing -> Var a Just b -> mkBool b -simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) -simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs) +simplify f (Or xs) = mkOr (map (fmap (simplify f)) xs) simplify f (Parens x) = simplify f (unLoc x) -- Test if a boolean formula is satisfied when the given values are assigned to the atoms -- if it is, returns Nothing -- if it is not, return (Just remainder) -isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) +isUnsatisfied :: Eq (LIdP (GhcPass p)) + => (LIdP (GhcPass p) -> Bool) + -> BooleanFormula (GhcPass p) + -> Maybe (BooleanFormula (GhcPass p)) isUnsatisfied f bf | isTrue bf' = Nothing | otherwise = Just bf' @@ -155,42 +151,42 @@ -- eval f x == False <==> isFalse (simplify (Just . f) x) -- If the boolean formula holds, does that mean that the given atom is always true? -impliesAtom :: Eq a => BooleanFormula a -> a -> Bool -Var x `impliesAtom` y = x == y -And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs +impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool +Var x `impliesAtom` y = (unLoc x) == (unLoc y) +And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs -- we have all of xs, so one of them implying y is enough -Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs -Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y +Or xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs +Parens x `impliesAtom` y = unLoc x `impliesAtom` y -implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool +implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) where - go :: Uniquable a => Clause a -> Clause a -> Bool + go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool go l@Clause{ clauseExprs = hyp:hyps } r = case hyp of - Var x | memberClauseAtoms x r -> True - | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r + Var x | memberClauseAtoms (unLoc x) r -> True + | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' go l r@Clause{ clauseExprs = con:cons } = case con of - Var x | memberClauseAtoms x l -> True - | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } + Var x | memberClauseAtoms (unLoc x) l -> True + | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons } Parens con' -> go l r { clauseExprs = unLoc con':cons } And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } go _ _ = False -- A small sequent calculus proof engine. -data Clause a = Clause { - clauseAtoms :: UniqSet a, - clauseExprs :: [BooleanFormula a] +data Clause p = Clause { + clauseAtoms :: UniqSet (IdP p), + clauseExprs :: [BooleanFormula p] } -extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a +extendClauseAtoms :: Uniquable (IdP p) => Clause p -> IdP p -> Clause p extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } -memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool +memberClauseAtoms :: Uniquable (IdP p) => IdP p -> Clause p -> Bool memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c ---------------------------------------------------------------------- @@ -199,28 +195,29 @@ -- Pretty print a BooleanFormula, -- using the arguments as pretty printers for Var, And and Or respectively -pprBooleanFormula' :: (Rational -> a -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> (Rational -> [SDoc] -> SDoc) - -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula' :: (Rational -> LIdP (GhcPass p) -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula (GhcPass p) -> SDoc pprBooleanFormula' pprVar pprAnd pprOr = go where go p (Var x) = pprVar p x - go p (And []) = cparen (p > 0) $ empty + go p (And []) = cparen (p > 0) empty go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) go _ (Or []) = keyword $ text "FALSE" go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) go p (Parens x) = go p (unLoc x) -- Pretty print in source syntax, "a | b | c,d,e" -pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc) + -> Rational -> BooleanFormula (GhcPass p) -> SDoc pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr where pprAnd p = cparen (p > 3) . fsep . punctuate comma pprOr p = cparen (p > 2) . fsep . intersperse vbar -- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? -pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc +pprBooleanFormulaNice :: Outputable (LIdP (GhcPass p)) => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 where pprVar _ = quotes . ppr @@ -230,14 +227,13 @@ pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs) pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) -instance (OutputableBndr a) => Outputable (BooleanFormula a) where +instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where ppr = pprBooleanFormulaNormal -pprBooleanFormulaNormal :: (OutputableBndr a) - => BooleanFormula a -> SDoc +pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNormal = go where - go (Var x) = pprPrefixOcc x + go (Var x) = pprPrefixOcc (unLoc x) go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) go (Or []) = keyword $ text "FALSE" go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) diff --git a/GHC/Data/EnumSet.hs b/GHC/Data/EnumSet.hs --- a/GHC/Data/EnumSet.hs +++ b/GHC/Data/EnumSet.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet diff --git a/GHC/Data/FastMutInt.hs b/GHC/Data/FastMutInt.hs --- a/GHC/Data/FastMutInt.hs +++ b/GHC/Data/FastMutInt.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected diff --git a/GHC/Data/FastString.hs b/GHC/Data/FastString.hs --- a/GHC/Data/FastString.hs +++ b/GHC/Data/FastString.hs @@ -1,15 +1,20 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0) +{-# OPTIONS_GHC -fno-unoptimized-core-for-interpreter #-} +#endif -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected +-- +-- Also important, if you load this module into GHCi then the data representation of +-- FastString has to match that of the host compiler due to the shared FastString +-- table. Otherwise you will get segfaults when the table is consulted and the fields +-- from the FastString are in an incorrect order. -- | -- There are two principal string types used internally by GHC: @@ -130,9 +135,6 @@ import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Short as SBS -#if !MIN_VERSION_bytestring(0,11,0) -import qualified Data.ByteString.Short.Internal as SBS -#endif import GHC.Data.ShortText (ShortText(..)) import Foreign.C import System.IO @@ -142,13 +144,8 @@ import Foreign -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import GHC.Conc.Sync (sharedCAF) -#endif -#if __GLASGOW_HASKELL__ < 811 -import GHC.Base (unpackCString#,unpackNBytes#) -#endif import GHC.Exts import GHC.IO @@ -204,8 +201,8 @@ -- ----------------------------------------------------------------------------- -{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All -'FastString's are stored in a global hashtable to support fast O(1) +{-| A 'FastString' is a Modified UTF-8 encoded string together with a unique ID. +All 'FastString's are stored in a global hashtable to support fast O(1) comparison. It is also associated with a lazy reference to the Z-encoding @@ -289,13 +286,16 @@ -- `lexicalCompareFS` (i.e. which compares FastStrings on their String -- representation). Hence it is deterministic from one run to the other. newtype LexicalFastString - = LexicalFastString FastString + = LexicalFastString { getLexicalFastString :: FastString } deriving newtype (Eq, Show) deriving stock Data instance Ord LexicalFastString where compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2 +instance NFData LexicalFastString where + rnf (LexicalFastString f) = rnf f + -- ----------------------------------------------------------------------------- -- Construction @@ -310,9 +310,18 @@ See Note [Updating the FastString table] on how it's updated. -} data FastStringTable = FastStringTable - {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets - {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets - (Array# (IORef FastStringTableSegment)) -- concurrent segments + {-# UNPACK #-} !FastMutInt + -- ^ The unique ID counter shared with all buckets + -- + -- We unpack the 'FastMutInt' counter as it is always consumed strictly. + {-# NOUNPACK #-} !FastMutInt + -- ^ Number of computed z-encodings for all buckets. + -- + -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk + -- in 'mkFastStringWith' and needs to be boxed any way. + -- If this is unpacked, then we box this single 'FastMutInt' once for each + -- allocated FastString. + (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments data FastStringTableSegment = FastStringTableSegment {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment @@ -394,17 +403,13 @@ -- use the support wired into the RTS to share this CAF among all images of -- libHSghc -#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) - return tab -#else sharedCAF tab getOrSetLibHSghcFastStringTable --- from the 9.3 RTS; the previouss RTS before might not have this symbol. The +-- from the 9.3 RTS; the previous RTS before might not have this symbol. The -- right way to do this however would be to define some HAVE_FAST_STRING_TABLE -- or similar rather than use (odd parity) development versions. foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) -#endif {- @@ -509,6 +514,10 @@ go (fs@(FastString {fs_sbs=fs_sbs}) : ls) | fs_sbs == sbs = Just fs | otherwise = go ls +-- bucket_match used to inline before changes to instance Eq ShortByteString +-- in bytestring-0.12, which made it slightly larger than inlining threshold. +-- Non-inlining causes a small, but measurable performance regression, so let's force it. +{-# INLINE bucket_match #-} mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = @@ -583,11 +592,7 @@ -- DO NOT move this let binding! indexCharOffAddr# reads from the -- pointer so we need to evaluate this based on the length check -- above. Not doing this right caused #17909. -#if __GLASGOW_HASKELL__ >= 901 !c = int8ToInt# (indexInt8Array# ba# n) -#else - !c = indexInt8Array# ba# n -#endif !h2 = (h *# 16777619#) `xorI#` c in loop h2 (n +# 1#) @@ -698,10 +703,6 @@ -- ----------------------------------------------------------------------------- -- under the carpet -#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) -foreign import ccall unsafe "strlen" - cstringLength# :: Addr# -> Int# -#endif ptrStrLength :: Ptr Word8 -> Int {-# INLINE ptrStrLength #-} diff --git a/GHC/Data/FastString/Env.hs b/GHC/Data/FastString/Env.hs --- a/GHC/Data/FastString/Env.hs +++ b/GHC/Data/FastString/Env.hs @@ -82,7 +82,7 @@ filterFsEnv x y = filterUFM x y mapMaybeFsEnv f x = mapMaybeUFM f x -lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) +lookupFsEnv_NF env n = expectJust (lookupFsEnv env n) strictMapFsEnv :: (a -> b) -> FastStringEnv a -> FastStringEnv b strictMapFsEnv = strictMapUFM diff --git a/GHC/Data/FlatBag.hs b/GHC/Data/FlatBag.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/FlatBag.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE UnboxedTuples #-} +module GHC.Data.FlatBag + ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag) + , emptyFlatBag + , unitFlatBag + , sizeFlatBag + , elemsFlatBag + , mappendFlatBag + -- * Construction + , fromList + , fromSmallArray + ) where + +import GHC.Prelude + +import Control.DeepSeq + +import GHC.Data.SmallArray + +-- | Store elements in a flattened representation. +-- +-- A 'FlatBag' is a data structure that stores an ordered list of elements +-- in a flat structure, avoiding the overhead of a linked list. +-- Use this data structure, if the code requires the following properties: +-- +-- * Elements are stored in a long-lived object, and benefit from a flattened +-- representation. +-- * The 'FlatBag' will be traversed but not extended or filtered. +-- * The number of elements should be known. +-- * Sharing of the empty case improves memory behaviour. +-- +-- A 'FlagBag' aims to have as little overhead as possible to store its elements. +-- To achieve that, it distinguishes between the empty case, singleton, tuple +-- and general case. +-- Thus, we only pay for the additional three words of an 'Array' if we have at least +-- three elements. +data FlatBag a + = EmptyFlatBag + | UnitFlatBag !a + | TupleFlatBag !a !a + | FlatBag {-# UNPACK #-} !(SmallArray a) + +instance Functor FlatBag where + fmap _ EmptyFlatBag = EmptyFlatBag + fmap f (UnitFlatBag a) = UnitFlatBag $ f a + fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b) + fmap f (FlatBag e) = FlatBag $ mapSmallArray f e + +instance Foldable FlatBag where + foldMap _ EmptyFlatBag = mempty + foldMap f (UnitFlatBag a) = f a + foldMap f (TupleFlatBag a b) = f a `mappend` f b + foldMap f (FlatBag arr) = foldMapSmallArray f arr + + length = fromIntegral . sizeFlatBag + +instance Traversable FlatBag where + traverse _ EmptyFlatBag = pure EmptyFlatBag + traverse f (UnitFlatBag a) = UnitFlatBag <$> f a + traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b + traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl) + +instance NFData a => NFData (FlatBag a) where + rnf EmptyFlatBag = () + rnf (UnitFlatBag a) = rnf a + rnf (TupleFlatBag a b) = rnf a `seq` rnf b + rnf (FlatBag arr) = rnfSmallArray arr + +-- | Create an empty 'FlatBag'. +-- +-- The empty 'FlatBag' is shared over all instances. +emptyFlatBag :: FlatBag a +emptyFlatBag = EmptyFlatBag + +-- | Create a singleton 'FlatBag'. +unitFlatBag :: a -> FlatBag a +unitFlatBag = UnitFlatBag + +-- | Calculate the size of +sizeFlatBag :: FlatBag a -> Word +sizeFlatBag EmptyFlatBag = 0 +sizeFlatBag UnitFlatBag{} = 1 +sizeFlatBag TupleFlatBag{} = 2 +sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr + +-- | Get all elements that are stored in the 'FlatBag'. +elemsFlatBag :: FlatBag a -> [a] +elemsFlatBag EmptyFlatBag = [] +elemsFlatBag (UnitFlatBag a) = [a] +elemsFlatBag (TupleFlatBag a b) = [a, b] +elemsFlatBag (FlatBag arr) = + [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]] + +-- | Combine two 'FlatBag's. +-- +-- The new 'FlatBag' contains all elements from both 'FlatBag's. +-- +-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused. +mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a +mappendFlatBag EmptyFlatBag b = b +mappendFlatBag a EmptyFlatBag = a +mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b +mappendFlatBag a b = + fromList (sizeFlatBag a + sizeFlatBag b) + (elemsFlatBag a ++ elemsFlatBag b) + +-- | Store the list in a flattened memory representation, avoiding the memory overhead +-- of a linked list. +-- +-- The size 'n' needs to be smaller or equal to the length of the list. +-- If it is smaller than the length of the list, overflowing elements are +-- discarded. It is undefined behaviour to set 'n' to be bigger than the +-- length of the list. +fromList :: Word -> [a] -> FlatBag a +fromList n elts = + case elts of + [] -> EmptyFlatBag + [a] -> UnitFlatBag a + [a, b] -> TupleFlatBag a b + xs -> + FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs)) + +-- | Convert a 'SizedSeq' into its flattened representation. +-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification +-- is necessary. +fromSmallArray :: SmallArray a -> FlatBag a +fromSmallArray s = case sizeofSmallArray s of + 0 -> EmptyFlatBag + 1 -> UnitFlatBag (indexSmallArray s 0) + 2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1) + _ -> FlatBag s + diff --git a/GHC/Data/Graph/Collapse.hs b/GHC/Data/Graph/Collapse.hs --- a/GHC/Data/Graph/Collapse.hs +++ b/GHC/Data/Graph/Collapse.hs @@ -11,7 +11,7 @@ , VizCollapseMonad(..) , NullCollapseViz(..) , runNullCollapse - , MonadUniqSM(..) + , MonadUniqDSM(..) ) where @@ -24,8 +24,8 @@ import GHC.Cmm.Dataflow.Label import GHC.Data.Graph.Inductive.Graph -import GHC.Types.Unique.Supply -import GHC.Utils.Panic +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 @@ -131,7 +126,7 @@ -- to a single supernode, then materialize (``inflate'') the reducible -- equivalent graph from that supernode. The `Supernode` class -- defines only the methods needed to collapse; rematerialization is --- the responsiblity of the client. +-- the responsibility of the client. -- -- During the Hecht-Ullman algorithm, every supernode has a unique -- entry point, which is given by `superLabel`. But this invariant is @@ -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 diff --git a/GHC/Data/Graph/Color.hs b/GHC/Data/Graph/Color.hs --- a/GHC/Data/Graph/Color.hs +++ b/GHC/Data/Graph/Color.hs @@ -380,5 +380,3 @@ in chooseColor - - diff --git a/GHC/Data/Graph/Directed.hs b/GHC/Data/Graph/Directed.hs --- a/GHC/Data/Graph/Directed.hs +++ b/GHC/Data/Graph/Directed.hs @@ -8,13 +8,14 @@ module GHC.Data.Graph.Directed ( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, - graphFromVerticesAndAdjacency, + graphFromVerticesAndAdjacency, emptyGraph, SCC(..), Node(..), G.flattenSCC, G.flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, - reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG, + reachablesG, + transposeG, outgoingG, emptyG, findCycle, @@ -43,7 +44,6 @@ -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ - import GHC.Prelude import GHC.Utils.Misc ( sortWith, count ) @@ -60,14 +60,14 @@ import qualified Data.Graph as G import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation -import Data.Tree import GHC.Types.Unique import GHC.Types.Unique.FM -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import qualified Data.Set as S +-- The graph internals are defined in the .Internal module so they can be +-- imported by GHC.Data.Graph.Directed.Reachability while still allowing this +-- module to export it abstractly. +import GHC.Data.Graph.Directed.Internal + {- ************************************************************************ * * @@ -86,14 +86,6 @@ arranged densely in 0.n -} -data Graph node = Graph { - gr_int_graph :: IntGraph, - gr_vertex_to_node :: Vertex -> node, - gr_node_to_vertex :: node -> Maybe Vertex - } - -data Edge node = Edge node node - {-| Representation for nodes of the Graph. * The @payload@ is user data, just carried around in this module @@ -357,51 +349,22 @@ topologicalSortG graph = map (gr_vertex_to_node graph) result where result = {-# SCC "Digraph.topSort" #-} G.topSort (gr_int_graph graph) -reachableG :: Graph node -> node -> [node] -reachableG graph from = map (gr_vertex_to_node graph) result - where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) - result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] - outgoingG :: Graph node -> node -> [node] outgoingG graph from = map (gr_vertex_to_node graph) result - where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) + where from_vertex = expectJust (gr_node_to_vertex graph from) result = gr_int_graph graph ! from_vertex --- | Given a list of roots return all reachable nodes. +-- | Given a list of roots, return all reachable nodes in topological order. +-- Implemented using a depth-first traversal. reachablesG :: Graph node -> [node] -> [node] reachablesG graph froms = map (gr_vertex_to_node graph) result where result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) vs vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] --- | Efficiently construct a map which maps each key to it's set of transitive --- dependencies. Only works on acyclic input. -allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key) -allReachable = all_reachable reachableGraph - --- | Efficiently construct a map which maps each key to it's set of transitive --- dependencies. Less efficient than @allReachable@, but works on cyclic input as well. -allReachableCyclic :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key) -allReachableCyclic = all_reachable reachableGraphCyclic - -all_reachable :: Ord key => (IntGraph -> IM.IntMap IS.IntSet) -> Graph node -> (node -> key) -> M.Map key (S.Set key) -all_reachable int_reachables (Graph g from _) keyOf = - M.fromList [(k, IS.foldr (\v' vs -> keyOf (from v') `S.insert` vs) S.empty vs) - | (v, vs) <- IM.toList int_graph - , let k = keyOf (from v)] - where - int_graph = int_reachables g - hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node -verticesG :: Graph node -> [node] -verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph) - -edgesG :: Graph node -> [Edge node] -edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph) - where v2n = gr_vertex_to_node graph - transposeG :: Graph node -> Graph node transposeG graph = Graph (G.transposeG (gr_int_graph graph)) (gr_vertex_to_node graph) @@ -410,114 +373,12 @@ emptyG :: Graph node -> Bool emptyG g = graphEmpty (gr_int_graph g) -{- -************************************************************************ -* * -* Showing Graphs -* * -************************************************************************ --} - -instance Outputable node => Outputable (Graph node) where - ppr graph = vcat [ - hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), - hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) - ] - -instance Outputable node => Outputable (Edge node) where - ppr (Edge from to) = ppr from <+> text "->" <+> ppr to - graphEmpty :: G.Graph -> Bool graphEmpty g = lo > hi where (lo, hi) = bounds g -{- -************************************************************************ -* * -* IntGraphs -* * -************************************************************************ --} -type IntGraph = G.Graph - {- ------------------------------------------------------------- --- Depth first search numbering ------------------------------------------------------------- --} - --- Data.Tree has flatten for Tree, but nothing for Forest -preorderF :: Forest a -> [a] -preorderF ts = concatMap flatten ts - -{- ------------------------------------------------------------- --- Finding reachable vertices ------------------------------------------------------------- --} - --- This generalizes reachable which was found in Data.Graph -reachable :: IntGraph -> [Vertex] -> [Vertex] -reachable g vs = preorderF (G.dfs g vs) - -reachableGraph :: IntGraph -> IM.IntMap IS.IntSet -reachableGraph g = res - where - do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v)) - res = IM.fromList [(v, do_one v) | v <- G.vertices g] - -scc :: IntGraph -> [SCC Vertex] -scc graph = map decode forest - where - forest = {-# SCC "Digraph.scc" #-} G.scc graph - - decode (Node v []) | mentions_itself v = CyclicSCC [v] - | otherwise = AcyclicSCC v - decode other = CyclicSCC (dec other []) - where dec (Node v ts) vs = v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) - -reachableGraphCyclic :: IntGraph -> IM.IntMap IS.IntSet -reachableGraphCyclic g = foldl' add_one_comp mempty comps - where - neighboursOf v = g!v - - comps = scc g - - -- To avoid divergence on cyclic input, we build the result - -- strongly connected component by component, in topological - -- order. For each SCC, we know that: - -- - -- * All vertices in the component can reach all other vertices - -- in the component ("local" reachables) - -- - -- * Other reachable vertices ("remote" reachables) must come - -- from earlier components, either via direct neighbourhood, or - -- transitively from earlier reachability map - -- - -- This allows us to build the extension of the reachability map - -- directly, without any self-reference, thereby avoiding a loop. - add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet - add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier - where - earlier_neighbours = neighboursOf v - earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours - all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further) - add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier - where - all_locals = IS.fromList vs - local v = IS.delete v all_locals - -- Arguably, for a cyclic SCC we should include each - -- vertex in its own reachable set. However, this could - -- lead to a lot of extra pain in client code to avoid - -- looping when traversing the reachability map. - all_neighbours = IS.fromList (concatMap neighboursOf vs) - earlier_neighbours = all_neighbours IS.\\ all_locals - earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours) - all_remotes = IS.unions (earlier_neighbours : earlier_further) - -{- ************************************************************************ * * * Classify Edge Types @@ -619,7 +480,8 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor) where key_extractor = node_key (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor - key_vertex_pair (a, b) = (expectJust "graphFromVerticesAndAdjacency" $ key_vertex a, - expectJust "graphFromVerticesAndAdjacency" $ key_vertex b) + key_vertex_pair (a, b) = (expectJust $ key_vertex a, + expectJust $ key_vertex b) reduced_edges = map key_vertex_pair edges graph = G.buildG bounds reduced_edges + diff --git a/GHC/Data/Graph/Directed/Internal.hs b/GHC/Data/Graph/Directed/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Directed/Internal.hs @@ -0,0 +1,79 @@ +module GHC.Data.Graph.Directed.Internal where + +import GHC.Prelude +import GHC.Utils.Outputable + +import Data.Array +import qualified Data.Graph as G +import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation +import Data.Tree + +data Graph node = Graph { + gr_int_graph :: IntGraph, + gr_vertex_to_node :: Vertex -> node, + gr_node_to_vertex :: node -> Maybe Vertex +} + +data Edge node = Edge node node + +------------------------------------------------------------ +-- Nodes and Edges +------------------------------------------------------------ + +verticesG :: Graph node -> [node] +verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph) + +edgesG :: Graph node -> [Edge node] +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph) + where v2n = gr_vertex_to_node graph + +------------------------------------------------------------ +-- Showing Graphs +------------------------------------------------------------ + +instance Outputable node => Outputable (Graph node) where + ppr graph = vcat [ + hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), + hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) + ] + +instance Outputable node => Outputable (Edge node) where + ppr (Edge from to) = ppr from <+> text "->" <+> ppr to + +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} + +type IntGraph = G.Graph + +------------------------------------------------------------ +-- Depth first search numbering +------------------------------------------------------------ + +-- Data.Tree has flatten for Tree, but nothing for Forest +preorderF :: Forest a -> [a] +preorderF ts = concatMap flatten ts + +------------------------------------------------------------ +-- Finding reachable vertices +------------------------------------------------------------ + +-- This generalizes reachable which was found in Data.Graph +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (G.dfs g vs) + +scc :: IntGraph -> [SCC Vertex] +scc graph = map decode forest + where + forest = {-# SCC "Digraph.scc" #-} G.scc graph + + decode (Node v []) | mentions_itself v = CyclicSCC [v] + | otherwise = AcyclicSCC v + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + diff --git a/GHC/Data/Graph/Directed/Reachability.hs b/GHC/Data/Graph/Directed/Reachability.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Directed/Reachability.hs @@ -0,0 +1,178 @@ +-- | An abstract interface for a fast reachability data structure constructed +-- from a 'GHC.Data.Graph.Directed' graph. +module GHC.Data.Graph.Directed.Reachability + ( ReachabilityIndex + + -- * Constructing a reachability index + , graphReachability, cyclicGraphReachability + + -- * Reachability queries + , allReachable, allReachableMany + , isReachable, isReachableMany + + -- * Debugging + , reachabilityIndexMembers + + ) + where + +import GHC.Prelude +import GHC.Data.Maybe + +import qualified Data.Graph as G +import Data.Graph ( Vertex, SCC(..) ) + +import Data.Array ((!)) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS + +import GHC.Data.Graph.Directed.Internal + +-------------------------------------------------------------------------------- +-- * Reachability index +-------------------------------------------------------------------------------- + +-- | The abstract data structure for fast reachability queries +data ReachabilityIndex node = ReachabilityIndex { + index :: IM.IntMap IS.IntSet, + from_vertex :: Vertex -> node, + to_vertex :: node -> Maybe Vertex +} + +-- +reachabilityIndexMembers :: ReachabilityIndex node -> [node] +reachabilityIndexMembers (ReachabilityIndex index from_vert _) = map from_vert (IM.keys index) + +-------------------------------------------------------------------------------- +-- * Construction +-------------------------------------------------------------------------------- + +-- | Construct a 'ReachabilityIndex' from an acyclic 'Graph'. +-- If the graph can have cycles, use 'cyclicGraphReachability' +graphReachability :: Graph node -> ReachabilityIndex node +graphReachability (Graph g from to) = + ReachabilityIndex{index = reachableGraph, from_vertex = from, to_vertex = to} + where + reachableGraph :: IM.IntMap IS.IntSet + reachableGraph = IM.fromList [(v, do_one v) | v <- G.vertices g] + + do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup reachableGraph) (g ! v)) + +-- | Construct a 'ReachabilityIndex' from a 'Graph' which may have cycles. +-- If this reachability index is just going to be used once, it may make sense +-- to use 'reachablesG' instead, which will traverse the reachable nodes without +-- constructing the index -- which may be faster. +cyclicGraphReachability :: Graph node -> ReachabilityIndex node +cyclicGraphReachability (Graph g from to) = + ReachabilityIndex{index = reachableGraphCyclic, from_vertex = from, to_vertex = to} + where + reachableGraphCyclic :: IM.IntMap IS.IntSet + reachableGraphCyclic = foldl' add_one_comp mempty comps + + neighboursOf v = g!v + + comps = scc g + + -- To avoid divergence on cyclic input, we build the result + -- strongly connected component by component, in topological + -- order. For each SCC, we know that: + -- + -- * All vertices in the component can reach all other vertices + -- in the component ("local" reachables) + -- + -- * Other reachable vertices ("remote" reachables) must come + -- from earlier components, either via direct neighbourhood, or + -- transitively from earlier reachability map + -- + -- This allows us to build the extension of the reachability map + -- directly, without any self-reference, thereby avoiding a loop. + add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet + add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier + where + earlier_neighbours = neighboursOf v + earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours + all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further) + add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier + where + all_locals = IS.fromList vs + local v = IS.delete v all_locals + -- Arguably, for a cyclic SCC we should include each + -- vertex in its own reachable set. However, this could + -- lead to a lot of extra pain in client code to avoid + -- looping when traversing the reachability map. + all_neighbours = IS.fromList (concatMap neighboursOf vs) + earlier_neighbours = all_neighbours IS.\\ all_locals + earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours) + all_remotes = IS.unions (earlier_neighbours : earlier_further) + +-------------------------------------------------------------------------------- +-- * Reachability queries +-------------------------------------------------------------------------------- + +-- | 'allReachable' returns the nodes reachable from the given @root@ node. +-- +-- Properties: +-- * The list of nodes /does not/ include the @root@ node! +-- * The list of nodes is deterministically ordered, but according to an +-- internal order determined by the indices attributed to graph nodes. +-- +-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead. +allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -} +allReachable (ReachabilityIndex index from to) root = map from result + where root_i = expectJust (to root) + hits = {-# SCC "allReachable" #-} IM.lookup root_i index + result = IS.toList $! expectJust hits + +-- | 'allReachableMany' returns all nodes reachable from the many given @roots@. +-- +-- Properties: +-- * The list of nodes /does not/ include the @roots@ node! +-- * The list of nodes is deterministically ordered, but according to an +-- internal order determined by the indices attributed to graph nodes. +-- * This function has $O(n)$ complexity where $n$ is the number of @roots@. +-- +-- If you need a topologically sorted list, consider using the functions +-- exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead ('reachableG'). +allReachableMany :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -} +allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList hits) + where roots_i = [ v | Just v <- map to roots ] + hits = {-# SCC "allReachableMany" #-} + IS.unions $ map (expectJust . flip IM.lookup index) roots_i + +-- | Fast reachability query. +-- +-- On graph @g@ with nodes @a@ and @b@, @isReachable g a b@ +-- asks whether @b@ can be reached through @g@ starting from @a@. +-- +-- Properties: +-- * No self loops, i.e. @isReachable _ a a == False@ +isReachable :: ReachabilityIndex node {-^ @g@ -} + -> node -- ^ @a@ + -> node -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @a@ +isReachable (ReachabilityIndex index _ to) a b = + IS.member b_i $ + expectJust $ IM.lookup a_i index + where a_i = expectJust $ to a + b_i = expectJust $ to b + +-- | Fast reachability query with many roots. +-- +-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@ +-- asks whether @b@ can be reached through @g@ from any of the @roots@. +-- +-- By partially applying this function to a set of roots, the resulting function can +-- be applied many times and share the initial work. +-- +-- Properties: +-- * No self loops, i.e. @isReachableMany _ [a] a == False@ +isReachableMany :: ReachabilityIndex node -- ^ @g@ + -> [node] -- ^ @roots@ + -> (node -> Bool) -- ^ @b@ is reachable from any of the @roots@ +isReachableMany (ReachabilityIndex index _ to) roots = + let roots_i = [ v | Just v <- map to roots ] + unions = + IS.unions $ + map (expectJust . flip IM.lookup index) roots_i + in \b -> let b_i = expectJust $ to b + in IS.member b_i unions diff --git a/GHC/Data/Graph/Inductive/Graph.hs b/GHC/Data/Graph/Inductive/Graph.hs --- a/GHC/Data/Graph/Inductive/Graph.hs +++ b/GHC/Data/Graph/Inductive/Graph.hs @@ -70,6 +70,7 @@ import Data.Function (on) import qualified Data.IntSet as IntSet import Data.List (delete, groupBy, sort, sortBy, (\\)) +import Data.List.NonEmpty (nonEmpty) import Data.Maybe (fromMaybe, isJust) import GHC.Utils.Panic @@ -167,11 +168,9 @@ -- | The minimum and maximum 'Node' in a 'Graph'. nodeRange :: gr a b -> (Node,Node) - nodeRange g - | isEmpty g = panic "nodeRange of empty graph" - | otherwise = (minimum vs, maximum vs) - where - vs = nodes g + nodeRange g = case nonEmpty (nodes g) of + Nothing -> panic "nodeRange of empty graph" + Just vs -> (minimum vs, maximum vs) -- | A list of all 'LEdge's in the 'Graph'. labEdges :: gr a b -> [LEdge b] diff --git a/GHC/Data/Graph/Inductive/PatriciaTree.hs b/GHC/Data/Graph/Inductive/PatriciaTree.hs --- a/GHC/Data/Graph/Inductive/PatriciaTree.hs +++ b/GHC/Data/Graph/Inductive/PatriciaTree.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph' -- using big-endian patricia tree (i.e. "Data.IntMap"). diff --git a/GHC/Data/IOEnv.hs b/GHC/Data/IOEnv.hs --- a/GHC/Data/IOEnv.hs +++ b/GHC/Data/IOEnv.hs @@ -22,7 +22,7 @@ IOEnvFailure(..), -- Getting at the environment - getEnv, setEnv, updEnv, + getEnv, setEnv, updEnv, updEnvIO, runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, tryM, tryAllM, tryMostM, fixM, @@ -253,3 +253,8 @@ updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnv #-} updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) + +-- | Perform a computation with an altered environment +updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnvIO #-} +updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env) diff --git a/GHC/Data/List.hs b/GHC/Data/List.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List.hs @@ -0,0 +1,25 @@ +module GHC.Data.List where + +mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) +mapAndUnzip _ [] = ([], []) +mapAndUnzip f (x:xs) + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs + in + (r1:rs1, r2:rs2) + +mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) +mapAndUnzip3 _ [] = ([], [], []) +mapAndUnzip3 f (x:xs) + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs + in + (r1:rs1, r2:rs2, r3:rs3) + +mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e]) +mapAndUnzip4 _ [] = ([], [], [], []) +mapAndUnzip4 f (x:xs) + = let (r1, r2, r3, r4) = f x + (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs + in + (r1:rs1, r2:rs2, r3:rs3, r4:rs4) diff --git a/GHC/Data/List/Infinite.hs b/GHC/Data/List/Infinite.hs --- a/GHC/Data/List/Infinite.hs +++ b/GHC/Data/List/Infinite.hs @@ -16,15 +16,18 @@ , allListsOf , toList , repeat + , enumFrom ) where -import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), Traversable (..), flip, otherwise) +import Prelude ((-), Applicative (..), Bool (..), Enum (succ), Foldable, Functor (..), Int, Maybe (..), Monad (..), Traversable (..), (<$>), flip, otherwise) import Control.Category (Category (..)) import Control.Monad (guard) import qualified Data.Foldable as F import Data.List.NonEmpty (NonEmpty (..)) import qualified GHC.Base as List (build) +infixr 5 `Inf` + data Infinite a = Inf a (Infinite a) deriving (Foldable, Functor, Traversable) @@ -44,6 +47,11 @@ pure = repeat Inf f fs <*> Inf a as = Inf (f a) (fs <*> as) +instance Monad Infinite where + x >>= f = join (f <$> x) + where + join (Inf a as) = head a `Inf` join (tail <$> as) + mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b mapMaybe f = go where @@ -170,6 +178,10 @@ "repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a "repeatFB" [1] repeatFB Inf = repeat #-} + +enumFrom :: Enum a => a -> Infinite a +enumFrom = iterate succ +{-# INLINE enumFrom #-} {- Note [Fusion for `Infinite` lists] diff --git a/GHC/Data/List/NonEmpty.hs b/GHC/Data/List/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List/NonEmpty.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where + +import Prelude (Bool, (.)) +import Control.Applicative +import qualified Control.Monad as List (zipWithM) +import Data.Foldable (Foldable (toList)) +import Data.List.NonEmpty hiding (toList, unzip) +import qualified Data.List as List +import qualified GHC.Data.List as List + +zipWithM :: Applicative f => (a -> b -> f c) -> NonEmpty a -> NonEmpty b -> f (NonEmpty c) +zipWithM f (a:|as) (b:|bs) = liftA2 (:|) (f a b) (List.zipWithM f as bs) +-- Inline to enable fusion of `List.zipWithM` +-- See Note [Fusion for zipN/zipWithN] in List.hs +{-# INLINE zipWithM #-} + +unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b) +unzip ((a,b):|xs) = (a:|as, b:|bs) + where + (as, bs) = List.unzip xs + +unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c) +unzip3 ((a,b,c):|xs) = (a:|as, b:|bs, c:|cs) + where + (as, bs, cs) = List.unzip3 xs + +mapAndUnzip :: (a -> (b, c)) -> NonEmpty a -> (NonEmpty b, NonEmpty c) +mapAndUnzip f (x:|xs) = (b:|bs, c:|cs) + where + (b, c) = f x + (bs, cs) = List.mapAndUnzip f xs + +mapAndUnzip3 :: (a -> (b, c, d)) -> NonEmpty a -> (NonEmpty b, NonEmpty c, NonEmpty d) +mapAndUnzip3 f (x:|xs) = (b:|bs, c:|cs, d:|ds) + where + (b, c, d) = f x + (bs, cs, ds) = List.mapAndUnzip3 f xs + +isSingleton :: NonEmpty a -> Bool +isSingleton = List.null . tail diff --git a/GHC/Data/Maybe.hs b/GHC/Data/Maybe.hs --- a/GHC/Data/Maybe.hs +++ b/GHC/Data/Maybe.hs @@ -33,7 +33,9 @@ import Control.Exception (SomeException(..)) import Data.Maybe import Data.Foldable ( foldlM, for_ ) -import GHC.Utils.Misc (HasDebugCallStack) +import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Panic +import GHC.Utils.Outputable import Data.List.NonEmpty ( NonEmpty ) import Control.Applicative( Alternative( (<|>) ) ) @@ -66,10 +68,14 @@ go Nothing action = action go result@(Just _) _action = return result -expectJust :: HasDebugCallStack => String -> Maybe a -> a +expectJust :: HasCallStack => Maybe a -> a +-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectJust #-} -expectJust _ (Just x) = x -expectJust err Nothing = error ("expectJust " ++ err) +expectJust = fromMaybe expectJustError + +expectJustError :: HasCallStack => a +expectJustError = pprPanic "expectJust" empty +{-# NOINLINE expectJustError #-} whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust = for_ diff --git a/GHC/Data/OrdList.hs b/GHC/Data/OrdList.hs --- a/GHC/Data/OrdList.hs +++ b/GHC/Data/OrdList.hs @@ -4,8 +4,6 @@ -} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-} @@ -16,8 +14,8 @@ OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL, nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, headOL, - mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse, - strictlyEqOL, strictlyOrdOL + mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, + partitionOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL ) where import GHC.Prelude @@ -219,6 +217,25 @@ foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 foldlOL k z (Many xs) = foldl' k z xs + +partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a) +partitionOL _ None = (None,None) +partitionOL f (One x) + | f x = (One x, None) + | otherwise = (None, One x) +partitionOL f (Two xs ys) = (Two ls1 ls2, Two rs1 rs2) + where !(!ls1,!rs1) = partitionOL f xs + !(!ls2,!rs2) = partitionOL f ys +partitionOL f (Cons x xs) + | f x = (Cons x ls, rs) + | otherwise = (ls, Cons x rs) + where !(!ls,!rs) = partitionOL f xs +partitionOL f (Snoc xs x) + | f x = (Snoc ls x, rs) + | otherwise = (ls, Snoc rs x) + where !(!ls,!rs) = partitionOL f xs +partitionOL f (Many xs) = (toOL ls, toOL rs) + where !(!ls,!rs) = NE.partition f xs toOL :: [a] -> OrdList a toOL [] = None diff --git a/GHC/Data/OsPath.hs b/GHC/Data/OsPath.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/OsPath.hs @@ -0,0 +1,29 @@ +module GHC.Data.OsPath + ( + -- * OsPath initialisation and transformation + OsPath + , OsString + , encodeUtf + , decodeUtf + , unsafeDecodeUtf + , unsafeEncodeUtf + , os + -- * Common utility functions + , () + , (<.>) + ) + where + +import GHC.Prelude + +import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Panic (panic) + +import System.OsPath +import System.Directory.Internal (os) + +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. +-- Prefer 'decodeUtf' and gracious error handling. +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath +unsafeDecodeUtf p = + either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p) diff --git a/GHC/Data/Pair.hs b/GHC/Data/Pair.hs --- a/GHC/Data/Pair.hs +++ b/GHC/Data/Pair.hs @@ -11,8 +11,8 @@ , unPair , toPair , swap - , pLiftFst - , pLiftSnd + , pLiftFst, pLiftSnd + , unzipPairs ) where @@ -58,3 +58,14 @@ pLiftSnd :: (a -> a) -> Pair a -> Pair a pLiftSnd f (Pair a b) = Pair a (f b) + +unzipPairs :: [Pair a] -> ([a], [a]) +unzipPairs [] = ([], []) +unzipPairs (Pair a b : prs) = (a:as, b:bs) + where + !(as,bs) = unzipPairs prs + -- This makes the unzip work eagerly, building no thunks at + -- the cost of doing all the work up-front. + +instance Foldable1 Pair where + foldMap1 f (Pair a b) = f a Semi.<> f b diff --git a/GHC/Data/SmallArray.hs b/GHC/Data/SmallArray.hs --- a/GHC/Data/SmallArray.hs +++ b/GHC/Data/SmallArray.hs @@ -11,18 +11,32 @@ , freezeSmallArray , unsafeFreezeSmallArray , indexSmallArray + , sizeofSmallArray , listToArray + , mapSmallArray + , foldMapSmallArray + , rnfSmallArray + + -- * IO Operations + , SmallMutableArrayIO + , newSmallArrayIO + , writeSmallArrayIO + , unsafeFreezeSmallArrayIO ) where import GHC.Exts import GHC.Prelude +import GHC.IO import GHC.ST +import Control.DeepSeq data SmallArray a = SmallArray (SmallArray# a) data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) +type SmallMutableArrayIO a = SmallMutableArray RealWorld a + newSmallArray :: Int -- ^ size -> a -- ^ initial contents @@ -32,6 +46,9 @@ newSmallArray (I# sz) x s = case newSmallArray# sz x s of (# s', a #) -> (# s', SmallMutableArray a #) +newSmallArrayIO :: Int -> a -> IO (SmallMutableArrayIO a) +newSmallArrayIO sz x = IO $ \s -> newSmallArray sz x s + writeSmallArray :: SmallMutableArray s a -- ^ array -> Int -- ^ index @@ -41,7 +58,13 @@ {-# INLINE writeSmallArray #-} writeSmallArray (SmallMutableArray a) (I# i) x = writeSmallArray# a i x +writeSmallArrayIO :: SmallMutableArrayIO a + -> Int + -> a + -> IO () +writeSmallArrayIO a ix v = IO $ \s -> (# writeSmallArray a ix v s, () #) + -- | Copy and freeze a slice of a mutable array. freezeSmallArray :: SmallMutableArray s a -- ^ source @@ -64,16 +87,69 @@ case unsafeFreezeSmallArray# ma s of (# s', a #) -> (# s', SmallArray a #) +unsafeFreezeSmallArrayIO :: SmallMutableArrayIO a -> IO (SmallArray a) +unsafeFreezeSmallArrayIO arr = IO $ \s -> unsafeFreezeSmallArray arr s +-- | Get the size of a 'SmallArray' +sizeofSmallArray + :: SmallArray a + -> Int +{-# INLINE sizeofSmallArray #-} +sizeofSmallArray (SmallArray sa#) = + case sizeofSmallArray# sa# of + s -> I# s + -- | Index a small-array (no bounds checking!) indexSmallArray :: SmallArray a -- ^ array -> Int -- ^ index -> a {-# INLINE indexSmallArray #-} -indexSmallArray (SmallArray sa#) (I# i) = case indexSmallArray# sa# i of - (# v #) -> v +indexSmallArray (SmallArray sa#) (I# i) = + case indexSmallArray# sa# i of + (# v #) -> v +-- | Map a function over the elements of a 'SmallArray' +-- +mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b +{-# INLINE mapSmallArray #-} +mapSmallArray f sa = runST $ ST $ \s -> + let + n = sizeofSmallArray sa + go !i saMut# state# + | i < n = + let + a = indexSmallArray sa i + newState# = writeSmallArray saMut# i (f a) state# + in + go (i + 1) saMut# newState# + | otherwise = state# + in + case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of + (# s', mutArr #) -> + case go 0 mutArr s' of + s'' -> unsafeFreezeSmallArray mutArr s'' + +-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice +foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m +{-# INLINE foldMapSmallArray #-} +foldMapSmallArray f sa = go 0 + where + n = sizeofSmallArray sa + go i + | i < n = f (indexSmallArray sa i) `mappend` go (i + 1) + | otherwise = mempty + +-- | Force the elements of the given 'SmallArray' +-- +rnfSmallArray :: NFData a => SmallArray a -> () +{-# INLINE rnfSmallArray #-} +rnfSmallArray sa = go 0 + where + n = sizeofSmallArray sa + go !i + | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1) + | otherwise = () -- | Convert a list into an array. listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a diff --git a/GHC/Data/Stream.hs b/GHC/Data/Stream.hs --- a/GHC/Data/Stream.hs +++ b/GHC/Data/Stream.hs @@ -9,7 +9,7 @@ -- | Monadic streams module GHC.Data.Stream ( - Stream(..), StreamS(..), runStream, yield, liftIO, + Stream(..), StreamS(..), runStream, yield, liftIO, liftEff, hoistEff, collect, consume, fromList, map, mapM, mapAccumL_ ) where @@ -140,3 +140,22 @@ go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b >>= \r' -> return $ Yield r' (go c' f1 h1 p))) go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m) + +-- | Lift an effect into the Stream +liftEff :: Monad m => m b -> Stream m a b +liftEff eff = Stream $ \_f g -> Effect (g <$> eff) + +-- | Hoist the underlying Stream effect +-- Note this is not very efficience since, just like 'mapAccumL_', it also needs +-- to traverse and rebuild the whole stream. +hoistEff :: forall m n a b. (Applicative m, Monad n) => (forall x. m x -> n x) -> Stream m a b -> Stream n a b +hoistEff h s = Stream $ \f g -> hs f g (runStream s :: StreamS m a b) where + hs :: (a -> n r') + -> (b -> StreamS n r' r) + -> StreamS m a b + -> StreamS n r' r + hs f g x = case x of + Done d -> g d + Yield a r -> Effect (f a >>= \r' -> return $ Yield r' (hs f g r)) + Effect e -> Effect (h (hs f g <$> e)) + diff --git a/GHC/Data/Strict.hs b/GHC/Data/Strict.hs --- a/GHC/Data/Strict.hs +++ b/GHC/Data/Strict.hs @@ -9,8 +9,8 @@ module GHC.Data.Strict ( Maybe(Nothing, Just), fromMaybe, + GHC.Data.Strict.maybe, Pair(And), - -- Not used at the moment: -- -- Either(Left, Right), @@ -18,16 +18,26 @@ ) where import GHC.Prelude hiding (Maybe(..), Either(..)) + import Control.Applicative import Data.Semigroup import Data.Data +import Control.DeepSeq data Maybe a = Nothing | Just !a deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data) +instance NFData a => NFData (Maybe a) where + rnf Nothing = () + rnf (Just x) = rnf x + fromMaybe :: a -> Maybe a -> a fromMaybe d Nothing = d fromMaybe _ (Just x) = x + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe d _ Nothing = d +maybe _ f (Just x) = f x apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b apMaybe (Just f) (Just x) = Just (f x) diff --git a/GHC/Data/StringBuffer.hs b/GHC/Data/StringBuffer.hs --- a/GHC/Data/StringBuffer.hs +++ b/GHC/Data/StringBuffer.hs @@ -6,10 +6,9 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised @@ -48,6 +47,7 @@ -- * Parsing integers parseUnsignedInteger, + findHashOffset, -- * Checking for bi-directional format characters containsBidirectionalFormatChar, @@ -76,12 +76,7 @@ import GHC.Exts import Foreign -#if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr (unsafeWithForeignPtr) -#else -unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b -unsafeWithForeignPtr = withForeignPtr -#endif -- ----------------------------------------------------------------------------- -- The StringBuffer type @@ -418,3 +413,15 @@ '_' -> go (i + 1) x -- skip "_" (#14473) char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0 + +-- | Find the offset of the '#' character in the StringBuffer. +-- +-- Make sure that it contains one before calling this function! +findHashOffset :: StringBuffer -> Int +findHashOffset (StringBuffer buf _ cur) + = inlinePerformIO $ withForeignPtr buf $ \ptr -> do + let + go p = peek p >>= \case + (0x23 :: Word8) -> pure $! ((p `minusPtr` ptr) - cur) + _ -> go (p `plusPtr` 1) + go (ptr `plusPtr` cur) diff --git a/GHC/Data/TrieMap.hs b/GHC/Data/TrieMap.hs --- a/GHC/Data/TrieMap.hs +++ b/GHC/Data/TrieMap.hs @@ -13,8 +13,6 @@ MaybeMap, -- * Maps over 'List' values ListMap, - -- * Maps over 'Literal's - LiteralMap, -- * 'TrieMap' class TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM, @@ -30,7 +28,6 @@ import GHC.Prelude -import GHC.Types.Literal import GHC.Types.Unique.DFM import GHC.Types.Unique( Uniquable ) @@ -72,7 +69,7 @@ lookupTM :: forall b. Key m -> m b -> Maybe b alterTM :: forall b. Key m -> XT b -> m b -> m b filterTM :: (a -> Bool) -> m a -> m a - + mapMaybeTM :: (a -> Maybe b) -> m a -> m b foldTM :: (a -> b -> b) -> m a -> b -> b -- The unusual argument order here makes -- it easy to compose calls to foldTM; @@ -149,6 +146,7 @@ alterTM = xtInt foldTM k m z = IntMap.foldr k z m filterTM f m = IntMap.filter f m + mapMaybeTM f m = IntMap.mapMaybe f m xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a xtInt k f m = IntMap.alter f k m @@ -160,6 +158,7 @@ alterTM k f m = Map.alter f k m foldTM k m z = Map.foldr k z m filterTM f m = Map.filter f m + mapMaybeTM f m = Map.mapMaybe f m {- @@ -236,6 +235,7 @@ alterTM k f m = alterUDFM f m k foldTM k m z = foldUDFM k z m filterTM f m = filterUDFM f m + mapMaybeTM f m = mapMaybeUDFM f m {- ************************************************************************ @@ -262,6 +262,7 @@ alterTM = xtMaybe alterTM foldTM = fdMaybe filterTM = ftMaybe + mapMaybeTM = mpMaybe instance TrieMap m => Foldable (MaybeMap m) where foldMap = foldMapTM @@ -284,6 +285,10 @@ ftMaybe f (MM { mm_nothing = mn, mm_just = mj }) = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj } +mpMaybe :: TrieMap m => (a -> Maybe b) -> MaybeMap m a -> MaybeMap m b +mpMaybe f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = mn >>= f, mm_just = mapMaybeTM f mj } + foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b foldMaybe _ Nothing b = b foldMaybe k (Just a) b = k a b @@ -317,6 +322,7 @@ alterTM = xtList alterTM foldTM = fdList filterTM = ftList + mapMaybeTM = mpList instance TrieMap m => Foldable (ListMap m) where foldMap = foldMapTM @@ -343,15 +349,9 @@ ftList f (LM { lm_nil = mnil, lm_cons = mcons }) = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } -{- -************************************************************************ -* * - Basic maps -* * -************************************************************************ --} - -type LiteralMap a = Map.Map Literal a +mpList :: TrieMap m => (a -> Maybe b) -> ListMap m a -> ListMap m b +mpList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = mnil >>= f, lm_cons = fmap (mapMaybeTM f) mcons } {- ************************************************************************ @@ -408,6 +408,7 @@ alterTM = xtG foldTM = fdG filterTM = ftG + mapMaybeTM = mpG instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where foldMap = foldMapTM @@ -470,3 +471,11 @@ ftG f (MultiMap m) = MultiMap (filterTM f m) -- we don't have enough information to reconstruct the key to make -- a SingletonMap + +{-# INLINEABLE mpG #-} +mpG :: TrieMap m => (a -> Maybe b) -> GenMap m a -> GenMap m b +mpG _ EmptyMap = EmptyMap +mpG f (SingletonMap k v) = case f v of + Just v' -> SingletonMap k v' + Nothing -> EmptyMap +mpG f (MultiMap m) = MultiMap (mapMaybeTM f m) diff --git a/GHC/Data/Unboxed.hs b/GHC/Data/Unboxed.hs --- a/GHC/Data/Unboxed.hs +++ b/GHC/Data/Unboxed.hs @@ -4,6 +4,13 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnliftedNewtypes #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + -- If you use -fomit-interface-pragmas for your build, we won't + -- inline the matcher for JustUB, and that turns out to have a + -- catastropic effect on Lint, which uses unboxed Maybes. + -- Simple fix: switch off -fomit-interface-pragmas for this tiny + -- and very stable module. + module GHC.Data.Unboxed ( MaybeUB(JustUB, NothingUB), fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB diff --git a/GHC/Data/Word64Map.hs b/GHC/Data/Word64Map.hs --- a/GHC/Data/Word64Map.hs +++ b/GHC/Data/Word64Map.hs @@ -1,14 +1,6 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} -#endif - -#include "containers.h" ----------------------------------------------------------------------------- -- | diff --git a/GHC/Data/Word64Map/Internal.hs b/GHC/Data/Word64Map/Internal.hs --- a/GHC/Data/Word64Map/Internal.hs +++ b/GHC/Data/Word64Map/Internal.hs @@ -1,20 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -#include "containers.h" ----------------------------------------------------------------------------- -- | @@ -313,14 +302,12 @@ import GHC.Utils.Containers.Internal.BitUtil import GHC.Utils.Containers.Internal.StrictPair -#ifdef __GLASGOW_HASKELL__ import Data.Coerce import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType, gcast1) import GHC.Exts (build) import qualified GHC.Exts as GHCExts import Text.Read -#endif import qualified Control.Category as Category import Data.Word @@ -491,7 +478,6 @@ rnf (Tip _ v) = rnf v rnf (Bin _ _ l r) = rnf l `seq` rnf r -#if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- A Data instance @@ -515,7 +501,6 @@ intMapDataType :: DataType intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr] -#endif {-------------------------------------------------------------------- Query @@ -2404,13 +2389,11 @@ go (Tip k x) = Tip k (f x) go Nil = Nil -#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-} {-# RULES "map/map" forall f g xs . map f (map g xs) = map (f . g) xs "map/coerce" map coerce = coerce #-} -#endif -- | \(O(n)\). Map a function over all values in the map. -- @@ -2424,7 +2407,6 @@ Tip k x -> Tip k (f k x) Nil -> Nil -#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] mapWithKey #-} {-# RULES "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) = @@ -2434,7 +2416,6 @@ "map/mapWithKey" forall f g xs . map f (mapWithKey g xs) = mapWithKey (\k a -> f (g k a)) xs #-} -#endif -- | \(O(n)\). -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ @@ -3103,13 +3084,11 @@ Lists --------------------------------------------------------------------} -#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance GHCExts.IsList (Word64Map a) where type Item (Word64Map a) = (Key,a) fromList = fromList toList = toList -#endif -- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list -- fusion. @@ -3137,7 +3116,6 @@ toDescList = foldlWithKey (\xs k x -> (k,x):xs) [] -- List fusion for the list generating functions. -#if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion. -- They are important to convert unfused methods back, see mapFB in prelude. foldrFB :: (Key -> a -> b -> b) -> b -> Word64Map a -> b @@ -3169,7 +3147,6 @@ {-# RULES "Word64Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-} {-# RULES "Word64Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-} {-# RULES "Word64Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-} -#endif -- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. @@ -3359,11 +3336,9 @@ instance Functor Word64Map where fmap = map -#ifdef __GLASGOW_HASKELL__ a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r) a <$ Tip k _ = Tip k a _ <$ Nil = Nil -#endif {-------------------------------------------------------------------- Show @@ -3385,19 +3360,12 @@ Read --------------------------------------------------------------------} instance (Read e) => Read (Word64Map e) where -#ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromList",s) <- lex r - (xs,t) <- reads s - return (fromList xs,t) -#endif -- | @since 0.5.9 instance Read1 Word64Map where diff --git a/GHC/Data/Word64Map/Lazy.hs b/GHC/Data/Word64Map/Lazy.hs --- a/GHC/Data/Word64Map/Lazy.hs +++ b/GHC/Data/Word64Map/Lazy.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.Word64Map.Lazy @@ -67,11 +61,7 @@ module GHC.Data.Word64Map.Lazy ( -- * Map type -#if !defined(TESTING) Word64Map, Key -- instance Eq,Show -#else - Word64Map(..), Key -- instance Eq,Show -#endif -- * Construction , empty diff --git a/GHC/Data/Word64Map/Strict.hs b/GHC/Data/Word64Map/Strict.hs --- a/GHC/Data/Word64Map/Strict.hs +++ b/GHC/Data/Word64Map/Strict.hs @@ -1,11 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.Word64Map.Strict @@ -86,11 +79,7 @@ module GHC.Data.Word64Map.Strict ( -- * Map type -#if !defined(TESTING) Word64Map, Key -- instance Eq,Show -#else - Word64Map(..), Key -- instance Eq,Show -#endif -- * Construction , empty @@ -254,4 +243,3 @@ ) where import GHC.Data.Word64Map.Strict.Internal -import Prelude () diff --git a/GHC/Data/Word64Map/Strict/Internal.hs b/GHC/Data/Word64Map/Strict/Internal.hs --- a/GHC/Data/Word64Map/Strict/Internal.hs +++ b/GHC/Data/Word64Map/Strict/Internal.hs @@ -1,11 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.Word64Map.Strict.Internal @@ -86,11 +81,7 @@ module GHC.Data.Word64Map.Strict.Internal ( -- * Map type -#if !defined(TESTING) Word64Map, Key -- instance Eq,Show -#else - Word64Map(..), Key -- instance Eq,Show -#endif -- * Construction , empty @@ -827,13 +818,11 @@ go (Tip k x) = Tip k $! f x go Nil = Nil -#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-} {-# RULES "map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs "map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs #-} -#endif -- | \(O(n)\). Map a function over all values in the map. -- @@ -847,7 +836,6 @@ Tip k x -> Tip k $! f k x Nil -> Nil -#ifdef __GLASGOW_HASKELL__ -- Pay close attention to strictness here. We need to force the -- intermediate result for map f . map g, and we need to refrain -- from forcing it for map f . L.map g, etc. @@ -875,7 +863,6 @@ "map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) = mapWithKey (\k a -> f (g k a)) xs #-} -#endif -- | \(O(n)\). -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ diff --git a/GHC/Data/Word64Set.hs b/GHC/Data/Word64Set.hs --- a/GHC/Data/Word64Set.hs +++ b/GHC/Data/Word64Set.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.Word64Set @@ -65,11 +59,7 @@ -- $strictness -- * Set type -#if !defined(TESTING) Word64Set -- instance Eq,Show -#else - Word64Set(..) -- instance Eq,Show -#endif , Key -- * Construction @@ -155,10 +145,6 @@ , showTree , showTreeWith -#if defined(TESTING) - -- * Internals - , match -#endif ) where import GHC.Data.Word64Set.Internal as WS diff --git a/GHC/Data/Word64Set/Internal.hs b/GHC/Data/Word64Set/Internal.hs --- a/GHC/Data/Word64Set/Internal.hs +++ b/GHC/Data/Word64Set/Internal.hs @@ -1,19 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif {-# OPTIONS_HADDOCK not-home #-} -#include "containers.h" - ----------------------------------------------------------------------------- -- | -- Module : Data.Word64Set.Internal @@ -205,17 +194,12 @@ import GHC.Utils.Containers.Internal.BitUtil import GHC.Utils.Containers.Internal.StrictPair -#if __GLASGOW_HASKELL__ import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType) import qualified Data.Data import Text.Read -#endif -#if __GLASGOW_HASKELL__ import qualified GHC.Exts -#endif -import qualified Data.Foldable as Foldable import Data.Functor.Identity (Identity(..)) infixl 9 \\{-This comment teaches CPP correct behaviour -} @@ -279,7 +263,6 @@ (<>) = union stimes = stimesIdempotentMonoid -#if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- A Data instance @@ -302,7 +285,6 @@ intSetDataType :: DataType intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr] -#endif {-------------------------------------------------------------------- Query @@ -513,15 +495,11 @@ choose True = inserted choose False = deleted -#ifndef __GLASGOW_HASKELL__ -{-# INLINE alterF #-} -#else {-# INLINABLE [2] alterF #-} {-# RULES "alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s #-} -#endif {-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> Word64Set -> Identity Word64Set #-} @@ -529,10 +507,10 @@ Union --------------------------------------------------------------------} -- | The union of a list of sets. -unions :: Foldable f => f Word64Set -> Word64Set -unions xs - = Foldable.foldl' union empty xs +{-# INLINABLE unions #-} +unions :: [Word64Set] -> Word64Set +unions = List.foldl' union empty -- | \(O(n+m)\). The union of two sets. union :: Word64Set -> Word64Set -> Word64Set @@ -1139,13 +1117,11 @@ Lists --------------------------------------------------------------------} -#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance GHC.Exts.IsList Word64Set where type Item Word64Set = Key fromList = fromList toList = toList -#endif -- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion. toList :: Word64Set -> [Key] @@ -1163,7 +1139,6 @@ toDescList = foldl (flip (:)) [] -- List fusion for the list generating functions. -#if __GLASGOW_HASKELL__ -- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion. -- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude. foldrFB :: (Key -> b -> b) -> b -> Word64Set -> b @@ -1189,13 +1164,12 @@ {-# RULES "Word64Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-} {-# RULES "Word64Set.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-} {-# RULES "Word64Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} -#endif -- | \(O(n \min(n,W))\). Create a set from a list of integers. +{-# INLINABLE fromList #-} fromList :: [Key] -> Word64Set -fromList xs - = Foldable.foldl' ins empty xs +fromList = List.foldl' ins empty where ins t x = insert x t @@ -1313,19 +1287,12 @@ Read --------------------------------------------------------------------} instance Read Word64Set where -#ifdef __GLASGOW_HASKELL__ readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec return (fromList xs) readListPrec = readListPrecDefault -#else - readsPrec p = readParen (p > 10) $ \ r -> do - ("fromList",s) <- lex r - (xs,t) <- reads s - return (fromList xs,t) -#endif {-------------------------------------------------------------------- NFData @@ -1547,7 +1514,6 @@ {-# INLINE foldr'Bits #-} {-# INLINE takeWhileAntitoneBits #-} -#if defined(__GLASGOW_HASKELL__) indexOfTheOnlyBit :: Nat -> Word64 {-# INLINE indexOfTheOnlyBit #-} indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask @@ -1614,63 +1580,6 @@ else ((1 `shiftLL` b) - 1) in bitmap .&. m -#else -{---------------------------------------------------------------------- - In general case we use logarithmic implementation of - lowestBitSet and highestBitSet, which works up to bit sizes of 64. - - Folds are linear scans. -----------------------------------------------------------------------} - -lowestBitSet n0 = - let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0) else (n0 `shiftRL` 32, 32) - (n2,b2) = if n1 .&. 0xFFFF /= 0 then (n1,b1) else (n1 `shiftRL` 16, 16+b1) - (n3,b3) = if n2 .&. 0xFF /= 0 then (n2,b2) else (n2 `shiftRL` 8, 8+b2) - (n4,b4) = if n3 .&. 0xF /= 0 then (n3,b3) else (n3 `shiftRL` 4, 4+b3) - (n5,b5) = if n4 .&. 0x3 /= 0 then (n4,b4) else (n4 `shiftRL` 2, 2+b4) - b6 = if n5 .&. 0x1 /= 0 then b5 else 1+b5 - in b6 - -highestBitSet n0 = - let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32) else (n0,0) - (n2,b2) = if n1 .&. 0xFFFF0000 /= 0 then (n1 `shiftRL` 16, 16+b1) else (n1,b1) - (n3,b3) = if n2 .&. 0xFF00 /= 0 then (n2 `shiftRL` 8, 8+b2) else (n2,b2) - (n4,b4) = if n3 .&. 0xF0 /= 0 then (n3 `shiftRL` 4, 4+b3) else (n3,b3) - (n5,b5) = if n4 .&. 0xC /= 0 then (n4 `shiftRL` 2, 2+b4) else (n4,b4) - b6 = if n5 .&. 0x2 /= 0 then 1+b5 else b5 - in b6 - -foldlBits prefix f z bm = let lb = lowestBitSet bm - in go (prefix+lb) z (bm `shiftRL` lb) - where go !_ acc 0 = acc - go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1) - | otherwise = go (bi + 1) acc (n `shiftRL` 1) - -foldl'Bits prefix f z bm = let lb = lowestBitSet bm - in go (prefix+lb) z (bm `shiftRL` lb) - where go !_ !acc 0 = acc - go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1) - | otherwise = go (bi + 1) acc (n `shiftRL` 1) - -foldrBits prefix f z bm = let lb = lowestBitSet bm - in go (prefix+lb) (bm `shiftRL` lb) - where go !_ 0 = z - go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1)) - | otherwise = go (bi + 1) (n `shiftRL` 1) - -foldr'Bits prefix f z bm = let lb = lowestBitSet bm - in go (prefix+lb) (bm `shiftRL` lb) - where - go !_ 0 = z - go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1) - | otherwise = go (bi + 1) (n `shiftRL` 1) - -takeWhileAntitoneBits prefix predicate = foldl'Bits prefix f 0 -- Does not use antitone property - where - f acc bi | predicate bi = acc .|. bitmapOf bi - | otherwise = acc - -#endif {-------------------------------------------------------------------- diff --git a/GHC/Driver/Backend.hs b/GHC/Driver/Backend.hs --- a/GHC/Driver/Backend.hs +++ b/GHC/Driver/Backend.hs @@ -58,8 +58,6 @@ , DefunctionalizedCodeOutput(..) -- *** Back-end functions for assembly , DefunctionalizedPostHscPipeline(..) - , DefunctionalizedAssemblerProg(..) - , DefunctionalizedAssemblerInfoGetter(..) -- *** Other back-end functions , DefunctionalizedCDefs(..) -- ** Names of back ends (for API clients of version 9.4 or earlier) @@ -94,8 +92,6 @@ , backendSupportsHpc , backendSupportsCImport , backendSupportsCExport - , backendAssemblerProg - , backendAssemblerInfoGetter , backendCDefs , backendCodeOutput , backendUseJSLinker @@ -217,6 +213,8 @@ ArchPPC_64 {} -> True ArchAArch64 -> True ArchWasm32 -> True + ArchRISCV64 -> True + ArchLoongArch64 -> True _ -> False -- | Is the platform supported by the JS backend? @@ -348,40 +346,6 @@ deriving Show --- | Names a function that runs the assembler, of this type: --- --- > Logger -> DynFlags -> Platform -> [Option] -> IO () --- --- The functions so named are defined in "GHC.Driver.Pipeline.Execute". - -data DefunctionalizedAssemblerProg - = StandardAssemblerProg - -- ^ Use the standard system assembler - | JSAssemblerProg - -- ^ JS Backend compile to JS via Stg, and so does not use any assembler - | DarwinClangAssemblerProg - -- ^ If running on Darwin, use the assembler from the @clang@ - -- toolchain. Otherwise use the standard system assembler. - - - --- | Names a function that discover from what toolchain the assembler --- is coming, of this type: --- --- > Logger -> DynFlags -> Platform -> IO CompilerInfo --- --- The functions so named are defined in "GHC.Driver.Pipeline.Execute". - -data DefunctionalizedAssemblerInfoGetter - = StandardAssemblerInfoGetter - -- ^ Interrogate the standard system assembler - | JSAssemblerInfoGetter - -- ^ If using the JS backend; return 'Emscripten' - | DarwinClangAssemblerInfoGetter - -- ^ If running on Darwin, return `Clang`; otherwise - -- interrogate the standard system assembler. - - -- | Names a function that generates code and writes the results to a -- file, of this type: -- @@ -549,7 +513,7 @@ backendRespectsSpecialise (Named Interpreter) = False backendRespectsSpecialise (Named NoBackend) = False --- | This back end wants the `mi_globals` field of a +-- | This back end wants the `mi_top_env` field of a -- `ModIface` to be populated (with the top-level bindings -- of the original source). Only true for the interpreter. backendWantsGlobalBindings :: Backend -> Bool @@ -592,12 +556,12 @@ -- `NotValid`, it carries a message that is shown to -- users. backendSimdValidity :: Backend -> Validity' String -backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named NCG) = IsValid backendSimdValidity (Named LLVM) = IsValid -backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] -backendSimdValidity (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] -backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] -backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] +backendSimdValidity (Named JavaScript) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] +backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] +backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."] -- | This flag says whether the back end supports large -- binary blobs. See Note [Embedding large binary blobs] @@ -766,45 +730,6 @@ backendSupportsCExport (Named JavaScript) = True backendSupportsCExport (Named Interpreter) = False backendSupportsCExport (Named NoBackend) = True - --- | This (defunctionalized) function runs the assembler --- used on the code that is written by this back end. A --- program determined by a combination of back end, --- `DynFlags`, and `Platform` is run with the given --- `Option`s. --- --- The function's type is --- @ --- Logger -> DynFlags -> Platform -> [Option] -> IO () --- @ --- --- This field is usually defaulted. -backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg -backendAssemblerProg (Named NCG) = StandardAssemblerProg -backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg -backendAssemblerProg (Named ViaC) = StandardAssemblerProg -backendAssemblerProg (Named JavaScript) = JSAssemblerProg -backendAssemblerProg (Named Interpreter) = StandardAssemblerProg -backendAssemblerProg (Named NoBackend) = StandardAssemblerProg - --- | This (defunctionalized) function is used to retrieve --- an enumeration value that characterizes the C/assembler --- part of a toolchain. The function caches the info in a --- mutable variable that is part of the `DynFlags`. --- --- The function's type is --- @ --- Logger -> DynFlags -> Platform -> IO CompilerInfo --- @ --- --- This field is usually defaulted. -backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter -backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter -backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named JavaScript) = JSAssemblerInfoGetter -backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter -backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter -- | When using this back end, it may be necessary or -- advisable to pass some `-D` options to a C compiler. diff --git a/GHC/Driver/Backpack.hs b/GHC/Driver/Backpack.hs --- a/GHC/Driver/Backpack.hs +++ b/GHC/Driver/Backpack.hs @@ -24,7 +24,7 @@ -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Parser import GHC.Driver.Config.Diagnostic import GHC.Driver.Monad import GHC.Driver.Session @@ -45,14 +45,13 @@ import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad import GHC.Iface.Recomp -import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.SourceFile import GHC.Types.Unique.FM -import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet +import GHC.Types.Basic (convImportLevel) import GHC.Utils.Outputable import GHC.Utils.Fingerprint @@ -67,13 +66,13 @@ import GHC.Unit.Finder import GHC.Unit.Module.Graph import GHC.Unit.Module.ModSummary -import GHC.Unit.Home.ModInfo import GHC.Linker.Types import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe +import GHC.Data.OsPath (unsafeEncodeUtf, os) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.Data.EnumSet as EnumSet @@ -91,6 +90,9 @@ import qualified Data.Map as Map import qualified Data.Set as Set import GHC.Types.Error (mkUnknownDiagnostic) +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () @@ -99,8 +101,9 @@ dflags0 <- getDynFlags let dflags1 = dflags0 let parser_opts1 = initParserOpts dflags1 - (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename - (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts + logger0 <- getLogger + (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 (supportedLanguagePragmas dflags1) src_filename + (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma logger0 dflags1 src_opts modifySession (hscSetFlags dflags) logger <- getLogger -- Get the logger after having set the session flags, -- so that logger options are correctly set. @@ -333,7 +336,7 @@ ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) - let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags + let hi_dir = expectJust $ hiDir dflags export_mod ms = (ms_mod_name ms, ms_mod ms) -- Export everything! mods = [ export_mod ms | ms <- mgModSummaries mod_graph @@ -341,15 +344,17 @@ -- Compile relevant only hsc_env <- getSession - let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) - linkables = map (expectJust "bkp link" . homeModInfoObject) - . filter ((==HsSrcFile) . mi_hsc_src . hm_iface) - $ home_mod_infos - getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us) - obj_files = concatMap getOfiles linkables + let takeLinkables x + | mi_hsc_src (hm_iface x) == HsSrcFile + = [Just $ expectJust $ homeModInfoObject x] + | otherwise + = [Nothing] + linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env) + let + obj_files = concatMap linkableFiles linkables state = hsc_units hsc_env - let compat_fs = unitIdFS cid + compat_fs = unitIdFS cid compat_pn = PackageName compat_fs unit_id = homeUnitId (hsc_home_unit hsc_env) @@ -442,16 +447,17 @@ -- update platform constants dflags <- liftIO $ updatePlatformConstants dflags0 mconstants - let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv + let unit_env = UnitEnv { ue_platform = targetPlatform dflags , ue_namever = ghcNameVersion dflags , ue_current_unit = homeUnitId home_unit , ue_home_unit_graph = - unitEnv_singleton + HUG.unitEnv_singleton (homeUnitId home_unit) - (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit)) + (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit)) , ue_eps = ue_eps old_unit_env + , ue_module_graph = ue_module_graph old_unit_env } setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env } @@ -580,7 +586,7 @@ NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of MustCompile -> empty RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" - ModuleNode _ _ -> + ModuleNode {} -> case recomp of UpToDate | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty @@ -589,6 +595,7 @@ MustCompile -> empty RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" LinkNode _ _ -> showMsg (text "Linking ") empty + UnitNode {} -> showMsg (text "Package ") empty -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not @@ -741,16 +748,19 @@ -- create an "empty" hsig file to induce compilation for the -- requirement. let hsig_set = Set.fromList - [ ms_mod_name ms + [ moduleNodeInfoModuleName ms | ModuleNode _ ms <- nodes - , ms_hsc_src ms == HsigFile + , moduleNodeInfoHscSource ms == Just HsigFile ] req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) -> if Set.member mod_name hsig_set then return Nothing else fmap Just $ summariseRequirement pn mod_name - - let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env)) + let inodes = instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env) + -- TODO: Backpack mode does not properly support ExternalPackage nodes yet + -- Module nodes do not get given package dependencies (see hsModuleToModSummary). + let pkg_nodes = ordNub $ map (\(_, iud) -> UnitNode [] (instUnitInstanceOf iud)) inodes + let graph_nodes = nodes ++ req_nodes ++ (map (uncurry InstantiationNode) $ inodes) ++ pkg_nodes key_nodes = map mkNodeKey graph_nodes all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link] -- This error message is not very good but .bkp mode is just for testing so @@ -772,7 +782,7 @@ let PackageName pn_fs = pn let location = mkHomeModLocation2 fopts mod_name - (unpackFS pn_fs moduleNameSlashes mod_name) "hsig" + (unsafeEncodeUtf $ unpackFS pn_fs moduleNameSlashes mod_name) (os "hsig") env <- getBkpEnv src_hash <- liftIO $ getFileHash (bkp_filename env) @@ -781,7 +791,7 @@ let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1) let fc = hsc_FC hsc_env - mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location + mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name @@ -795,13 +805,12 @@ ms_iface_date = hi_timestamp, ms_hie_date = hie_timestamp, ms_srcimps = [], - ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports, - ms_ghc_prim_import = False, + ms_textual_imps = ((,,) NormalLevel NoPkgQual . noLoc) <$> extra_sig_imports, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { hsmodExt = XModulePs { hsmodAnn = noAnn, - hsmodLayout = NoLayoutInfo, + hsmodLayout = EpNoLayout, hsmodDeprecMessage = Nothing, hsmodHaddockModHeader = Nothing }, @@ -816,8 +825,8 @@ ms_hspp_opts = dflags, ms_hspp_buf = Nothing } - let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ] - return (ModuleNode nodes ms) + let nodes = [mkModuleEdge NormalLevel (NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit))) | mn <- extra_sig_imports ] + return (ModuleNode nodes (ModuleNodeCompile ms)) summariseDecl :: PackageName -> HscSource @@ -854,17 +863,14 @@ -- To add insult to injury, we don't even actually use -- these filenames to figure out where the hi files go. -- A travesty! - let location0 = mkHomeModLocation2 fopts modname - (unpackFS unit_fs + let location = mkHomeModLocation fopts modname + (unsafeEncodeUtf $ unpackFS unit_fs moduleNameSlashes modname) - (case hsc_src of - HsigFile -> "hsig" - HsBootFile -> "hs-boot" - HsSrcFile -> "hs") - -- DANGEROUS: bootifying can POISON the module finder cache - let location = case hsc_src of - HsBootFile -> addBootSuffixLocnOut location0 - _ -> location0 + (case hsc_src of + HsigFile -> os "hsig" + HsBootFile -> os "hs-boot" + HsSrcFile -> os "hs") + hsc_src -- This duplicates a pile of logic in GHC.Driver.Make hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location) hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location) @@ -872,28 +878,23 @@ -- Also copied from 'getImports' let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps - -- GHC.Prim doesn't exist physically, so don't go looking for it. - (ordinary_imps, ghc_prim_import) - = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc) - ord_idecls - implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports modname loc implicit_prelude imps rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname - convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) + convImport (L _ i) = (convImportLevel (ideclLevelSpec i), rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i) extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname - let normal_imports = map convImport (implicit_imports ++ ordinary_imps) + let normal_imports = map convImport (implicit_imports ++ ord_idecls) (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports -- So that Finder can find it, even though it doesn't exist... this_mod <- liftIO $ do let home_unit = hsc_home_unit hsc_env let fc = hsc_FC hsc_env - addHomeModuleToFinder fc home_unit modname location + addHomeModuleToFinder fc home_unit modname location hsc_src let ms = ModSummary { ms_mod = this_mod, ms_hsc_src = hsc_src, @@ -903,14 +904,13 @@ Just d -> d) ".." moduleNameSlashes modname <.> "hi", ms_hspp_opts = dflags, ms_hspp_buf = Nothing, - ms_srcimps = map convImport src_idecls, - ms_ghc_prim_import = not (null ghc_prim_import), + ms_srcimps = (\i -> reLoc (ideclName (unLoc i))) <$> src_idecls, ms_textual_imps = normal_imports -- We have to do something special here: -- due to merging, requirements may end up with -- extra imports - ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports) - ++ ((,) NoPkgQual . noLoc <$> implicit_sigs), + ++ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) + ++ ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs), -- This is our hack to get the parse tree to the right spot ms_parsed_mod = Just (HsParsedModule { hpm_module = hsmod, @@ -930,12 +930,12 @@ let inst_nodes = map NodeKey_Unit inst_deps mod_nodes = -- hs-boot edge - [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (moduleUnitId this_mod))], NotBoot == isBootSummary ms, k `elem` home_keys ] ++ + [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot) (moduleUnitId this_mod))], NotBoot == isBootSummary ms, k `elem` home_keys ] ++ -- Normal edges - [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] + [k | (_, _, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys] - return (ModuleNode (mod_nodes ++ inst_nodes) ms) + return (ModuleNode (map mkNormalEdge (mod_nodes ++ inst_nodes)) (ModuleNodeCompile ms)) -- | Create a new, externally provided hashed unit id from -- a hash. diff --git a/GHC/Driver/CmdLine.hs b/GHC/Driver/CmdLine.hs --- a/GHC/Driver/CmdLine.hs +++ b/GHC/Driver/CmdLine.hs @@ -26,13 +26,12 @@ import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc import GHC.Types.Error import GHC.Utils.Error import GHC.Driver.Errors.Types -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage import GHC.Utils.Outputable (text) import Data.Function diff --git a/GHC/Driver/CodeOutput.hs b/GHC/Driver/CodeOutput.hs --- a/GHC/Driver/CodeOutput.hs +++ b/GHC/Driver/CodeOutput.hs @@ -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 \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 \n" ++ cplusplus_hdr) cplusplus_ftr putDumpFileMaybe logger Opt_D_dump_foreign "Foreign export stubs" FormatC stub_c_output_d diff --git a/GHC/Driver/Config.hs b/GHC/Driver/Config.hs --- a/GHC/Driver/Config.hs +++ b/GHC/Driver/Config.hs @@ -3,6 +3,7 @@ ( initOptCoercionOpts , initSimpleOpts , initEvalOpts + , EvalStep(..) ) where @@ -25,15 +26,32 @@ { so_uf_opts = unfoldingOpts dflags , so_co_opts = initOptCoercionOpts dflags , so_eta_red = gopt Opt_DoEtaReduction dflags + , so_inline = True } +-- | Instruct the interpreter evaluation to break... +data EvalStep + -- | ... at every breakpoint tick + = EvalStepSingle + -- | ... after any evaluation to WHNF + -- (See Note [Debugger: Step-out]) + | EvalStepOut + -- | ... only on explicit breakpoints + | EvalStepNone + -- | Extract GHCi options from DynFlags and step -initEvalOpts :: DynFlags -> Bool -> EvalOpts +initEvalOpts :: DynFlags -> EvalStep -> EvalOpts initEvalOpts dflags step = EvalOpts { useSandboxThread = gopt Opt_GhciSandbox dflags - , singleStep = step + , singleStep = singleStep + , stepOut = stepOut , breakOnException = gopt Opt_BreakOnException dflags , breakOnError = gopt Opt_BreakOnError dflags } + where + (singleStep, stepOut) = case step of + EvalStepSingle -> (True, False) + EvalStepOut -> (False, True) + EvalStepNone -> (False, False) diff --git a/GHC/Driver/Config/Cmm.hs b/GHC/Driver/Config/Cmm.hs --- a/GHC/Driver/Config/Cmm.hs +++ b/GHC/Driver/Config/Cmm.hs @@ -22,13 +22,7 @@ , 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 } where platform = targetPlatform dflags - usingInconsistentPicReg = - case (platformArch platform, platformOS platform, positionIndependent dflags) - of (ArchX86, OSDarwin, pic) -> pic - _ -> False diff --git a/GHC/Driver/Config/CmmToAsm.hs b/GHC/Driver/Config/CmmToAsm.hs --- a/GHC/Driver/Config/CmmToAsm.hs +++ b/GHC/Driver/Config/CmmToAsm.hs @@ -59,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 @@ -67,6 +70,7 @@ , 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) diff --git a/GHC/Driver/Config/CmmToLlvm.hs b/GHC/Driver/Config/CmmToLlvm.hs --- a/GHC/Driver/Config/CmmToLlvm.hs +++ b/GHC/Driver/Config/CmmToLlvm.hs @@ -23,6 +23,7 @@ , llvmCgContext = initSDocContext dflags PprCode , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags , llvmCgSplitSection = gopt Opt_SplitSections dflags + , llvmCgAvxEnabled = isAvxEnabled dflags , llvmCgBmiVersion = case platformArch (targetPlatform dflags) of ArchX86_64 -> bmiVersion dflags ArchX86 -> bmiVersion dflags diff --git a/GHC/Driver/Config/Core/Lint.hs b/GHC/Driver/Config/Core/Lint.hs --- a/GHC/Driver/Config/Core/Lint.hs +++ b/GHC/Driver/Config/Core/Lint.hs @@ -83,7 +83,7 @@ coreDumpFlag CoreDoStaticArgs = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_stranal +coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec @@ -132,8 +132,7 @@ -- we have eta-expanded data constructors with representation-polymorphic -- bindings; so we switch off the representation-polymorphism checks. -- The very simple optimiser will beta-reduce them away. - -- See Note [Checking for representation-polymorphic built-ins] - -- in GHC.HsToCore.Expr. + -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete check_fixed_rep = case pass of CoreDesugar -> False _ -> True diff --git a/GHC/Driver/Config/Core/Opt/LiberateCase.hs b/GHC/Driver/Config/Core/Opt/LiberateCase.hs --- a/GHC/Driver/Config/Core/Opt/LiberateCase.hs +++ b/GHC/Driver/Config/Core/Opt/LiberateCase.hs @@ -6,7 +6,7 @@ import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) ) --- | Initialize configuration for the liberate case Core optomization +-- | Initialize configuration for the liberate case Core optimization -- pass. initLiberateCaseOpts :: DynFlags -> LibCaseOpts initLiberateCaseOpts dflags = LibCaseOpts diff --git a/GHC/Driver/Config/Core/Rules.hs b/GHC/Driver/Config/Core/Rules.hs --- a/GHC/Driver/Config/Core/Rules.hs +++ b/GHC/Driver/Config/Core/Rules.hs @@ -5,19 +5,15 @@ import GHC.Prelude import GHC.Driver.Flags -import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform, homeUnitId_ ) +import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform ) import GHC.Core.Rules.Config -import GHC.Unit.Types ( primUnitId, bignumUnitId ) - -- | Initialize RuleOpts from DynFlags initRuleOpts :: DynFlags -> RuleOpts initRuleOpts dflags = RuleOpts { roPlatform = targetPlatform dflags , roNumConstantFolding = gopt Opt_NumConstantFolding dflags , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags - -- disable bignum rules in ghc-prim and ghc-bignum itself - , roBignumRules = homeUnitId_ dflags /= primUnitId - && homeUnitId_ dflags /= bignumUnitId + , roBignumRules = True } diff --git a/GHC/Driver/Config/CoreToStg/Prep.hs b/GHC/Driver/Config/CoreToStg/Prep.hs --- a/GHC/Driver/Config/CoreToStg/Prep.hs +++ b/GHC/Driver/Config/CoreToStg/Prep.hs @@ -9,7 +9,7 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Config.Core.Lint -import GHC.Tc.Utils.Env +import GHC.Driver.Config.Core.Opt.Arity import GHC.Types.Var import GHC.Utils.Outputable ( alwaysQualify ) @@ -17,14 +17,15 @@ initCorePrepConfig :: HscEnv -> IO CorePrepConfig initCorePrepConfig hsc_env = do - convertNumLit <- do - let platform = targetPlatform $ hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - lookup_global = lookupGlobal hsc_env - mkConvertNumLiteral platform home_unit lookup_global + let dflags = hsc_dflags hsc_env return $ CorePrepConfig - { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env - , cp_convertNumLit = convertNumLit + { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags + , cp_platform = targetPlatform dflags + , 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 diff --git a/GHC/Driver/Config/Diagnostic.hs b/GHC/Driver/Config/Diagnostic.hs --- a/GHC/Driver/Config/Diagnostic.hs +++ b/GHC/Driver/Config/Diagnostic.hs @@ -19,7 +19,7 @@ import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage) -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Ppr () -- Diagnostic instances import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error diff --git a/GHC/Driver/Config/Finder.hs b/GHC/Driver/Config/Finder.hs --- a/GHC/Driver/Config/Finder.hs +++ b/GHC/Driver/Config/Finder.hs @@ -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 } diff --git a/GHC/Driver/Config/HsToCore.hs b/GHC/Driver/Config/HsToCore.hs --- a/GHC/Driver/Config/HsToCore.hs +++ b/GHC/Driver/Config/HsToCore.hs @@ -12,7 +12,7 @@ { bang_opt_strict_data = xopt LangExt.StrictData dflags , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags -- Don't unbox if we aren't optimising; rather arbitrarily, - -- we use -fomit-iface-pragmas as the indication + -- we use -fomit-interface-pragmas as the indication , bang_opt_unbox_strict = gopt Opt_UnboxStrictFields dflags , bang_opt_unbox_small = gopt Opt_UnboxSmallStrictFields dflags } diff --git a/GHC/Driver/Config/Linker.hs b/GHC/Driver/Config/Linker.hs --- a/GHC/Driver/Config/Linker.hs +++ b/GHC/Driver/Config/Linker.hs @@ -1,13 +1,92 @@ module GHC.Driver.Config.Linker ( initFrameworkOpts - ) where + , initLinkerConfig + ) +where +import GHC.Prelude +import GHC.Platform import GHC.Linker.Config import GHC.Driver.DynFlags +import GHC.Driver.Session +import Data.List (isPrefixOf) + initFrameworkOpts :: DynFlags -> FrameworkOpts initFrameworkOpts dflags = FrameworkOpts { foFrameworkPaths = frameworkPaths dflags , foCmdlineFrameworks = cmdlineFrameworks dflags } + +-- | Initialize linker configuration from DynFlags +initLinkerConfig :: DynFlags -> LinkerConfig +initLinkerConfig dflags = + let + -- see Note [Solaris linker] + ld_filter = case platformOS (targetPlatform dflags) of + OSSolaris2 -> sunos_ld_filter + _ -> id + sunos_ld_filter :: [String] -> [String] + sunos_ld_filter x = if (undefined_found x && ld_warning_found x) + then (ld_prefix x) ++ (ld_postfix x) + else x + breakStartsWith x y = break (isPrefixOf x) y + ld_prefix = fst . breakStartsWith "Undefined" + undefined_found = not . null . snd . breakStartsWith "Undefined" + ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" + ld_postfix = tail . snd . ld_warn_break + ld_warning_found = not . null . snd . ld_warn_break + + -- program and arguments + -- + -- `-optl` args come at the end, so that later `-l` options + -- given there manually can fill in symbols needed by + -- Haskell libraries coming in via `args`. + (p,pre_args) = pgm_l dflags + post_args = map Option (getOpts dflags opt_l) + + in LinkerConfig + { linkerProgram = p + , linkerOptionsPre = pre_args + , linkerOptionsPost = post_args + , linkerTempDir = tmpDir dflags + , linkerFilter = ld_filter + } + +{- Note [Solaris linker] + ~~~~~~~~~~~~~~~~~~~~~ + SunOS/Solaris ld emits harmless warning messages about unresolved + symbols in case of compiling into shared library when we do not + link against all the required libs. That is the case of GHC which + does not link against RTS library explicitly in order to be able to + choose the library later based on binary application linking + parameters. The warnings look like: + +Undefined first referenced + symbol in file +stg_ap_n_fast ./T2386_Lib.o +stg_upd_frame_info ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o +newCAF ./T2386_Lib.o +stg_bh_upd_frame_info ./T2386_Lib.o +stg_ap_ppp_fast ./T2386_Lib.o +templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o +stg_ap_p_fast ./T2386_Lib.o +stg_ap_pp_fast ./T2386_Lib.o +ld: warning: symbol referencing errors + + this is actually coming from T2386 testcase. The emitting of those + warnings is also a reason why so many TH testcases fail on Solaris. + + Following filter code is SunOS/Solaris linker specific and should + filter out only linker warnings. Please note that the logic is a + little bit more complex due to the simple reason that we need to preserve + any other linker emitted messages. If there are any. Simply speaking + if we see "Undefined" and later "ld: warning:..." then we omit all + text between (including) the marks. Otherwise we copy the whole output. +-} + diff --git a/GHC/Driver/Config/Logger.hs b/GHC/Driver/Config/Logger.hs --- a/GHC/Driver/Config/Logger.hs +++ b/GHC/Driver/Config/Logger.hs @@ -17,6 +17,7 @@ , log_default_dump_context = initSDocContext dflags defaultDumpStyle , log_dump_flags = dumpFlags dflags , log_show_caret = gopt Opt_DiagnosticsShowCaret dflags + , log_diagnostics_as_json = gopt Opt_DiagnosticsAsJSON dflags , log_show_warn_groups = gopt Opt_ShowWarnGroups dflags , log_enable_timestamps = not (gopt Opt_SuppressTimestamps dflags) , log_dump_to_file = gopt Opt_DumpToFile dflags diff --git a/GHC/Driver/Config/Parser.hs b/GHC/Driver/Config/Parser.hs --- a/GHC/Driver/Config/Parser.hs +++ b/GHC/Driver/Config/Parser.hs @@ -1,5 +1,6 @@ module GHC.Driver.Config.Parser ( initParserOpts + , supportedLanguagePragmas ) where @@ -17,9 +18,10 @@ mkParserOpts <$> extensionFlags <*> initDiagOpts - <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform) <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream <*> const True -- use LINE/COLUMN to update the internal location +supportedLanguagePragmas :: DynFlags -> [String] +supportedLanguagePragmas = supportedLanguagesAndExtensions . platformArchOS . targetPlatform diff --git a/GHC/Driver/Config/Stg/Pipeline.hs b/GHC/Driver/Config/Stg/Pipeline.hs --- a/GHC/Driver/Config/Stg/Pipeline.hs +++ b/GHC/Driver/Config/Stg/Pipeline.hs @@ -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 diff --git a/GHC/Driver/Config/StgToCmm.hs b/GHC/Driver/Config/StgToCmm.hs --- a/GHC/Driver/Config/StgToCmm.hs +++ b/GHC/Driver/Config/StgToCmm.hs @@ -14,6 +14,7 @@ import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile +import GHC.Platform.Regs import GHC.Utils.Error import GHC.Unit.Module import GHC.Utils.Outputable @@ -37,10 +38,10 @@ -- 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 + , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags , stgToCmmInfoTableMapWithFallback = gopt Opt_InfoTableMapWithFallback dflags , stgToCmmInfoTableMapWithStack = gopt Opt_InfoTableMapWithStack dflags @@ -51,8 +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 + , 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 @@ -74,22 +80,30 @@ | otherwise -> const True - , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm + , stgToCmmAllowIntMul2Instr = (ncg && (x86ish || aarch64)) || llvm + , stgToCmmAllowWordMul2Instr = (ncg && (x86ish || ppc || aarch64)) || llvm + , stgToCmmAllowIntWord64X2MinMax = (ncg && x86ish && isSse4_2Enabled dflags) || llvm -- SIMD flags , stgToCmmVecInstrsErr = vec_err , stgToCmmAvx = isAvxEnabled dflags , stgToCmmAvx2 = isAvx2Enabled dflags , stgToCmmAvx512f = isAvx512fEnabled dflags , stgToCmmTickyAP = gopt Opt_Ticky_AP dflags + -- See Note [Saving foreign call target to local] + , stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform } 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) JSPrimitives -> (False, False) NcgPrimitives -> (True, False) LlvmPrimitives -> (False, True) + aarch64 = case platformArch platform of + ArchAArch64 -> True + _ -> False x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True diff --git a/GHC/Driver/Config/StgToJS.hs b/GHC/Driver/Config/StgToJS.hs --- a/GHC/Driver/Config/StgToJS.hs +++ b/GHC/Driver/Config/StgToJS.hs @@ -1,11 +1,15 @@ module GHC.Driver.Config.StgToJS ( initStgToJSConfig + , initJSLinkConfig ) where import GHC.StgToJS.Types +import GHC.StgToJS.Linker.Types import GHC.Driver.DynFlags +import GHC.Driver.Config.Linker + import GHC.Platform.Ways import GHC.Utils.Outputable @@ -30,4 +34,19 @@ , csRuntimeAssert = False -- settings , csContext = initSDocContext dflags defaultDumpStyle + , csLinkerConfig = initLinkerConfig dflags } + +-- | Default linker configuration +initJSLinkConfig :: DynFlags -> JSLinkConfig +initJSLinkConfig dflags = JSLinkConfig + { lcNoJSExecutables = False + , lcNoHsMain = False + , lcNoRts = False + , lcNoStats = False + , lcCombineAll = True + , lcForeignRefs = True + , lcForceEmccRts = False + , lcLinkCsources = not (gopt Opt_DisableJsCsources dflags) + } + diff --git a/GHC/Driver/Config/Tidy.hs b/GHC/Driver/Config/Tidy.hs --- a/GHC/Driver/Config/Tidy.hs +++ b/GHC/Driver/Config/Tidy.hs @@ -36,10 +36,12 @@ , 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 , opt_static_ptr_opts = static_ptr_opts + , opt_keep_auto_rules = gopt Opt_KeepAutoRules dflags } initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts diff --git a/GHC/Driver/Downsweep.hs b/GHC/Driver/Downsweep.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Downsweep.hs @@ -0,0 +1,1547 @@ +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} +module GHC.Driver.Downsweep + ( downsweep + , downsweepThunk + , downsweepInstalledModules + , downsweepFromRootNodes + , downsweepInteractiveImports + , DownsweepMode(..) + -- * Summary functions + , summariseModule + , summariseFile + , summariseModuleInterface + , SummariseResult(..) + -- * Helper functions + , instantiationNodes + , checkHomeUnitsClosed + ) where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Driver.Config.Finder (initFinderOpts) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Phases +import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess) +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Messager +import GHC.Driver.MakeSem +import GHC.Driver.MakeAction +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Ppr + +import GHC.Iface.Load + +import GHC.Parser.Header +import GHC.Rename.Names +import GHC.Tc.Utils.Backpack +import GHC.Runtime.Context + +import Language.Haskell.Syntax.ImpExp + +import GHC.Data.Graph.Directed +import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) +import qualified GHC.Data.Maybe as M +import GHC.Data.OsPath ( unsafeEncodeUtf ) +import GHC.Data.StringBuffer +import GHC.Data.Graph.Directed.Reachability +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Exception ( throwIO, SomeAsyncException ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.Fingerprint +import GHC.Utils.TmpFs +import GHC.Utils.Constants + +import GHC.Types.Error +import GHC.Types.Target +import GHC.Types.SourceFile +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Types.Unique.Map +import GHC.Types.PkgQual +import GHC.Types.Basic + + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Graph +import GHC.Unit.Module.Deps +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Stage + +import Data.Either ( rights, partitionEithers, lefts ) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) +import qualified Control.Monad.Catch as MC +import Data.Maybe +import Data.List (partition) +import Data.Time +import Data.List (unfoldr) +import Data.Bifunctor (first, bimap) +import System.Directory +import System.FilePath + +import Control.Monad.Trans.Reader +import qualified Data.Map.Strict as M +import Control.Monad.Trans.Class +import System.IO.Unsafe (unsafeInterleaveIO) + +{- +Note [Downsweep and the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The ModuleGraph stores the relationship between all the modules, units, and +instantiations in the current session. + +When we do downsweep, we build up a new ModuleGraph, starting from the root +modules. By following all the dependencies we construct a graph which allows +us to answer questions about the transitive closure of the imports. + +The module graph is accessible in the HscEnv. + +When is this graph constructed? + +1. In `--make` mode, we construct the graph before starting to do any compilation. + +2. In `-c` (oneshot) mode, we construct the graph when we have calculated the + ModSummary for the module we are compiling. The `ModuleGraph` is stored in a + thunk, so it is only constructed when it is needed. This avoids reading + the interface files of the whole transitive closure unless they are needed. + +3. In some situations (such as loading plugins) we may need to construct the + graph without having a ModSummary. In this case we use the `downsweepInstalledModules` + function. + +The result is having a uniform graph available for the whole compilation pipeline. + +-} + +-- This caches the answer to the question, if we are in this unit, what does +-- an import of this module mean. +type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo] + +----------------------------------------------------------------------------- +-- +-- | Downsweep (dependency analysis) for --make mode +-- +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. +-- +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned ModuleGraph has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. +-- +-- This function is intendned for use by --make mode and will also insert +-- LinkNodes and InstantiationNodes for any home units. +-- +-- It will also turn on code generation for any modules that need it by calling +-- 'enableCodeGenForTH'. +downsweep :: HscEnv + -> (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> [ModSummary] + -- ^ Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO ([DriverMessages], ModuleGraph) + -- The non-error elements of the returned list all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true in + -- which case there can be repeats +downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do + n_jobs <- mkWorkerLimit (hsc_dflags hsc_env) + (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary + let closure_errs = checkHomeUnitsClosed unit_env + unit_env = hsc_unit_env hsc_env + + all_errs = closure_errs ++ root_errs + + case all_errs of + [] -> do + (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) [] + + let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) + + let all_nodes = downsweep_nodes ++ unit_nodes + let all_errs = downsweep_errs ++ other_errs + + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + -- if we have been passed -fno-code, we enable code generation + -- for dependencies of modules that have -XTemplateHaskell, + -- otherwise those modules will fail to compile. + -- See Note [-fno-code mode] #8025 + th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes + + return (all_errs, th_configured_nodes) + _ -> return (all_errs, emptyMG) + where + summary = getRootSummary excl_mods old_summary_map + + -- A cache from file paths to the already summarised modules. The same file + -- can be used in multiple units so the map is also keyed by which unit the + -- file was used in. + -- Reuse these if we can because the most expensive part of downsweep is + -- reading the headers. + old_summary_map :: M.Map (UnitId, FilePath) ModSummary + old_summary_map = + M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] + + -- Dependencies arising on a unit (backpack and module linking deps) + unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] + unitModuleNodes summaries uid hue = + maybeToList (linkNodes summaries uid hue) + +-- | Calculate the module graph starting from a single ModSummary. The result is a +-- thunk, which when forced will perform the downsweep. This is useful in oneshot +-- mode where the module graph may never be needed. +-- If downsweep fails, then the resulting errors are just thrown. +downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph +downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..." + ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] [] + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + return (mkModuleGraph mg) + +-- | Construct a module graph starting from the interactive context. +-- Produces, a thunk, which when forced will perform the downsweep. +-- This graph contains the current interactive module, and its dependencies. +-- +-- Invariant: The hsc_mod_graph already contains the relevant home modules which +-- might be imported by the interactive imports. +-- +-- This is a first approximation for this function. There probably should also +-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6 +-- and so on) +-- See Note [runTcInteractive module graph] +downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph +downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do + debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...") + let imps = ic_imports (hsc_IC hsc_env) + + let interactive_mn = icInteractiveModule ic + -- No sensible value for ModLocation.. if you hit this panic then you probably + -- need to add proper support for modules without any source files to the driver. + let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps) + let key = moduleToMnk interactive_mn NotBoot + let node_type = ModuleNodeFixed key ml + + -- The existing nodes in the module graph. This will be populated when GHCi runs + -- :load. Any home package modules need to already be in here. + let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ] + + (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes + let interactive_node = ModuleNode module_edges node_type + + let all_nodes = M.elems graph + return $ mkModuleGraph (interactive_node : all_nodes) + + where + -- + mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName)) + -- A simple edge to a module from the same home unit + mkEdge (IIModule n) = + let + mod_node_key = ModNodeKeyWithUid + { mnkModuleName = GWIB (moduleName n) NotBoot + , mnkUnitId = + -- 'toUnitId' is safe here, as we can't import modules that + -- don't have a 'UnitId'. + toUnitId (moduleUnit n) + } + mod_node_edge = + ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key) + in Left mod_node_edge + -- A complete import statement + mkEdge (IIDecl i) = + let lvl = convImportLevel (ideclLevelSpec i) + wanted_mod = unLoc (ideclName i) + is_boot = ideclSource i + mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i) + unitId = homeUnitId $ hsc_home_unit hsc_env + in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot) + +loopFromInteractive :: HscEnv + -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -> M.Map NodeKey ModuleGraphNode + -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode) +loopFromInteractive _ [] cached_nodes = return ([], cached_nodes) +loopFromInteractive hsc_env (edge:edges) cached_nodes = + case edge of + Left edge -> do + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes + return (edge : edges, cached_nodes') + Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do + let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env) + let k _ loc mod = + let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg [] + case found of + -- Case 1: Home modules have to already be in the cache. + FoundHome (ModuleNodeFixed mod _) -> do + let edge = ModuleNodeEdge lvl (NodeKey_Module mod) + -- Note: Does not perform any further downsweep as the module must already be in the cache. + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes + return (edge : edges, cached_nodes') + -- Case 2: External units may not be in the cache, if we haven't already initialised the + -- module graph. We can construct the module graph for those here by calling loopUnit. + External uid -> do + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + cached_nodes' = loopUnit hsc_env' cached_nodes [uid] + edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid) + (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes' + return (edge : edges, cached_nodes') + -- And if it's not found.. just carry on and hope. + _ -> loopFromInteractive hsc_env edges cached_nodes + + +-- | Create a module graph from a list of installed modules. +-- This is used by the loader when we need to load modules but there +-- isn't already an existing module graph. For example, when loading plugins +-- during initialisation. +-- +-- If you call this function, then if the `Module` you request to downsweep can't +-- be found then this function will throw errors. +-- If you need to use this function elsewhere, then it would make sense to make it +-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit. +-- At the moment, it is overfitted for what `get_reachable_nodes` needs. +downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph +downsweepInstalledModules hsc_env mods = do + let + (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods + installed_mods = map (fst . getModuleInstantiation) home_mods + external_uids = map moduleUnitId external_mods + + process :: InstalledModule -> IO ModuleNodeInfo + process i = do + res <- findExactModule hsc_env i NotBoot + case res of + InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc + -- It is an internal-ish error if this happens, since we any call to this function should + -- already know that we can find the modules we need to load. + _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i + + nodes <- mapM process installed_mods + (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids + + -- Similarly here, we should really not get any errors, but print them out if we do. + let dflags = hsc_dflags hsc_env + liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env) + (initPrintConfig dflags) + (initDiagOpts dflags) + (GhcDriverMessage <$> unionManyMessages errs) + + return (mkModuleGraph mg) + + + +-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used +-- by --make mode, and fixed nodes by oneshot mode. +-- +-- See Note [Module Types in the ModuleGraph] for the difference between the two. +data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed + +-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root +-- 'UnitId's. +-- This function will start at the given roots, and traverse downwards to find +-- all the dependencies, all the way to the leaf units. +downsweepFromRootNodes :: HscEnv + -> M.Map (UnitId, FilePath) ModSummary + -> [ModuleName] + -> Bool + -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies + -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo + -> [UnitId] -- ^ The starting units + -> IO ([DriverMessages], [ModuleGraphNode]) +downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids + = do + let root_map = mkRootMap root_nodes + checkDuplicates root_map + let env = DownsweepEnv hsc_env mode old_summaries excl_mods + (deps', map0) <- runDownsweepM env $ do + (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map) + let all_deps = loopUnit hsc_env module_deps root_uids + let all_instantiations = getHomeUnitInstantiations hsc_env + deps' <- loopInstantiations all_instantiations all_deps + return (deps', map0) + + + let downsweep_errs = lefts $ concat $ M.elems map0 + downsweep_nodes = M.elems deps' + + return (downsweep_errs, downsweep_nodes) + where + getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)] + getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env) + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates + :: DownsweepCache + -> IO () + checkDuplicates root_map + | not allow_dup_roots + , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root + | otherwise = pure () + where + dup_roots :: [[ModuleNodeInfo]] -- Each at least of length 2 + dup_roots = filterOut isSingleton $ map rights (M.elems root_map) + + +calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] +calcDeps ms = + -- Add a dependency on the HsBoot file if it exists + -- This gets passed to the loopImports function which just ignores it if it + -- can't be found. + [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ + [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ] + + +type DownsweepM a = ReaderT DownsweepEnv IO a +data DownsweepEnv = DownsweepEnv { + downsweep_hsc_env :: HscEnv + , _downsweep_mode :: DownsweepMode + , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary + , _downsweep_excl_mods :: [ModuleName] +} + +runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a +runDownsweepM env act = runReaderT act env + + +loopInstantiations :: [(UnitId, InstantiatedUnit)] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopInstantiations [] done = pure done +loopInstantiations ((home_uid, iud) :xs) done = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + done' = loopUnit hsc_env' done [instUnitInstanceOf iud] + payload = InstantiationNode home_uid iud + loopInstantiations xs (M.insert (mkNodeKey payload) payload done') + + +-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit +loopSummaries :: [ModSummary] + -> (M.Map NodeKey ModuleGraphNode, + DownsweepCache) + -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache) +loopSummaries [] done = pure done +loopSummaries (ms:next) (done, summarised) + | Just {} <- M.lookup k done + = loopSummaries next (done, summarised) + -- Didn't work out what the imports mean yet, now do that. + | otherwise = do + (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised + -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. + (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' + loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'') + where + k = NodeKey_Module (msKey ms) + + hs_file_for_boot + | HsBootFile <- ms_hsc_src ms + = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) + | otherwise + = Nothing + +loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is + +loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache) +loopModuleNodeInfo mod_node_info (done, summarised) = do + case mod_node_info of + ModuleNodeCompile ms -> do + loopSummaries [ms] (done, summarised) + ModuleNodeFixed mod ml -> do + done' <- loopFixedModule mod ml done + return (done', summarised) + +-- NB: loopFixedModule does not take a downsweep cache, because if you +-- ever reach a Fixed node, everything under that also must be fixed. +loopFixedModule :: ModNodeKeyWithUid -> ModLocation + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedModule key loc done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> return done + Nothing -> do + -- MP: TODO, we should just read the dependency info from the interface rather than either + -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory) + -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation) + read_result <- liftIO $ + -- 1. Check if the interface is already loaded into the EPS by some other + -- part of the compiler. + lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case + Just iface -> return (M.Succeeded iface) + Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc) + case read_result of + M.Succeeded iface -> do + -- Computer information about this node + let node_deps = ifaceDeps (mi_deps iface) + edges = map mkFixedEdge node_deps + node = ModuleNode edges (ModuleNodeFixed key loc) + foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps) + -- Ignore any failure, we might try to read a .hi-boot file for + -- example, even if there is not one. + M.Failed {} -> + return done + +loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedNodeKey _ done (Left key) = do + loopFixedImports [key] done +loopFixedNodeKey home_uid done (Right uid) = do + -- Set active unit so that looking loopUnit finds the correct + -- -package flags in the unit state. + hsc_env <- asks downsweep_hsc_env + let hsc_env' = hscSetActiveUnitId home_uid hsc_env + return $ loopUnit hsc_env' done [uid] + +mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge +mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key) +mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid) + +ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)] +ifaceDeps deps = + [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid) + | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps) + ] ++ + [ Right (tcImportLevel lvl, uid) + | (lvl, uid) <- Set.toList (dep_direct_pkgs deps) + ] + +-- Like loopImports, but we already know exactly which module we are looking for. +loopFixedImports :: [ModNodeKeyWithUid] + -> M.Map NodeKey ModuleGraphNode + -> DownsweepM (M.Map NodeKey ModuleGraphNode) +loopFixedImports [] done = pure done +loopFixedImports (key:keys) done = do + let nk = NodeKey_Module key + hsc_env <- asks downsweep_hsc_env + case M.lookup nk done of + Just {} -> loopFixedImports keys done + Nothing -> do + read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key) + case read_result of + InstalledFound loc -> do + done' <- loopFixedModule key loc done + loopFixedImports keys done' + _otherwise -> + -- If the finder fails, just keep going, there will be another + -- error later. + loopFixedImports keys done + +downsweepSummarise :: HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> DownsweepM SummariseResult +downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do + DownsweepEnv hsc_env mode old_summaries excl_mods <- ask + case mode of + DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods + DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + + +-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover +-- a new module by doing this. +loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))] + -- Work list: process these modules + -> M.Map NodeKey ModuleGraphNode + -> DownsweepCache + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> DownsweepM ([ModuleNodeEdge], + M.Map NodeKey ModuleGraphNode, DownsweepCache) + -- The result is the completed NodeMap +loopImports [] done summarised = return ([], done, summarised) +loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised + | Just summs <- M.lookup cache_key summarised + = case summs of + [Right ms] -> do + let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms)) + (rest, summarised', done') <- loopImports ss done summarised + return (nk: rest, summarised', done') + [Left _err] -> + loopImports ss done summarised + _errs -> do + loopImports ss done summarised + | otherwise + = do + hsc_env <- asks downsweep_hsc_env + let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) + mb_s <- downsweepSummarise home_unit + is_boot wanted_mod mb_pkg + Nothing + case mb_s of + NotThere -> loopImports ss done summarised + External uid -> do + -- Pass an updated hsc_env to loopUnit, as each unit might + -- have a different visible package database. + let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env + let done' = loopUnit hsc_env' done [uid] + (other_deps, done'', summarised') <- loopImports ss done' summarised + return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised') + FoundInstantiation iud -> do + (other_deps, done', summarised') <- loopImports ss done summarised + return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised') + FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) + FoundHome s -> do + (done', summarised') <- + loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised) + (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' + + -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. + return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised) + where + cache_key = (home_uid, mb_pkg, unLoc <$> gwib) + GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib + wanted_mod = L loc mod + +loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode +loopUnit _ cache [] = cache +loopUnit lcl_hsc_env cache (u:uxs) = do + let nk = (NodeKey_ExternalUnit u) + case Map.lookup nk cache of + Just {} -> loopUnit lcl_hsc_env cache uxs + Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of + Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs + Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u) + +multiRootsErr :: [ModuleNodeInfo] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ fmap GhcDriverMessage $ + mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files + where + mod = moduleNodeInfoModule summ1 + files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs + +moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages +moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod) + +-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. +-- These are used to represent the type checking that is done after +-- all the free holes (sigs in current package) relevant to that instantiation +-- are compiled. This is necessary to catch some instantiation errors. +instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)] +instantiationNodes uid unit_state = map (uid,) iuids_to_check + where + iuids_to_check :: [InstantiatedUnit] + iuids_to_check = + nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state) + where + goUnitId uid = + [ recur + | VirtUnit indef <- [uid] + , inst <- instUnitInsts indef + , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst + ] + +-- The linking plan for each module. If we need to do linking for a home unit +-- then this function returns a graph node which depends on all the modules in the home unit. + +-- At the moment nothing can depend on these LinkNodes. +linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode) +linkNodes summaries uid hue = + let dflags = homeUnitEnv_dflags hue + ofile = outputFile_ dflags + + unit_nodes :: [NodeKey] + unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries) + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + no_hs_main = gopt Opt_NoHsMain dflags + + main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes + + do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib + + in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking -> + Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) + -- This should be an error, not a warning (#10895). + | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) + | otherwise -> Nothing + +getRootSummary :: + [ModuleName] -> + M.Map (UnitId, FilePath) ModSummary -> + HscEnv -> + Target -> + IO (Either DriverMessages ModSummary) +getRootSummary excl_mods old_summary_map hsc_env target + | TargetFile file mb_phase <- targetId + = do + let offset_file = augmentByWorkingDirectory dflags file + exists <- liftIO $ doesFileExist offset_file + if exists || isJust maybe_buf + then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + maybe_buf + else + return $ Left $ singleMessage $ + mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) + | TargetModule modl <- targetId + = do + maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot + (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) + maybe_buf excl_mods + pure case maybe_summary of + FoundHome (ModuleNodeCompile s) -> Right s + FoundHomeWithError err -> Left (snd err) + _ -> Left (moduleNotFoundErr uid modl) + where + Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target + home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) + rootLoc = mkGeneralSrcSpan (fsLit "") + dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) + +-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline +-- system. +-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses +-- 'withAbstractSem' to wait for a free slot, limiting the number of +-- concurrently computed summaries to the value of the @-j@ option or the slots +-- allocated by the job server, if that is used. +-- +-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because +-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the +-- result won't be read anyway here. +-- +-- To emulate the current behavior, we funnel exceptions past the concurrency +-- barrier and rethrow the first one afterwards. +rootSummariesParallel :: + WorkerLimit -> + HscEnv -> + (GhcMessage -> AnyGhcDiagnostic) -> + Maybe Messager -> + (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) -> + IO ([DriverMessages], [ModSummary]) +rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do + (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles) + runPipelines n_jobs hsc_env diag_wrapper msg actions + (sequence . catMaybes <$> sequence get_results) >>= \case + Right results -> pure (partitionEithers (concat results)) + Left exc -> throwIO exc + where + bundles = mk_bundles targets + + mk_bundles = unfoldr \case + [] -> Nothing + ts -> Just (splitAt bundle_size ts) + + bundle_size = 20 + + targets = hsc_targets hsc_env + + action_and_result (log_queue_id, ts) = do + res_var <- liftIO newEmptyMVar + pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var) + + action log_queue_id target_bundle = do + env@MakeEnv {compile_sem} <- ask + lift $ lift $ + withAbstractSem compile_sem $ + withLoggerHsc log_queue_id env \ lcl_hsc_env -> + MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case + Left e | Just (_ :: SomeAsyncException) <- fromException e -> + throwIO e + a -> pure a + +-- | This function checks then important property that if both p and q are home units +-- then any dependency of p, which transitively depends on q is also a home unit. +-- +-- See Note [Multiple Home Units], section 'Closure Property'. +checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] +checkHomeUnitsClosed ue + | Set.null bad_unit_ids = [] + | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] + where + home_id_set = HUG.allUnits $ ue_home_unit_graph ue + bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -} + rootLoc = mkGeneralSrcSpan (fsLit "") + + downwards_closure :: Graph (Node UnitId UnitId) + downwards_closure = graphFromEdgedVerticesUniq graphNodes + + inverse_closure = graphReachability $ transposeG downwards_closure + + upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] + + all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) + all_unit_direct_deps + = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue + where + go rest this this_uis = + plusUniqMap_C Set.union + (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) + rest + where + external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) + this_units = homeUnitEnv_units this_uis + this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] + + graphNodes :: [Node UnitId UnitId] + graphNodes = go Set.empty home_id_set + where + go done todo + = case Set.minView todo of + Nothing -> [] + Just (uid, todo') + | Set.member uid done -> go done todo' + | otherwise -> case lookupUniqMap all_unit_direct_deps uid of + Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) + Just depends -> + let todo'' = (depends Set.\\ done) `Set.union` todo' + in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' + +-- | Update the every ModSummary that is depended on +-- by a module that needs template haskell. We enable codegen to +-- the specified target, disable optimization and change the .hi +-- and .o file locations to be temporary files. +-- See Note [-fno-code mode] +enableCodeGenForTH + :: Logger + -> TmpFs + -> UnitEnv + -> [ModuleGraphNode] + -> IO ModuleGraph +enableCodeGenForTH logger tmpfs unit_env = + enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env + + +data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord) + +instance Outputable CodeGenEnable where + ppr = text . show + +-- | Helper used to implement 'enableCodeGenForTH'. +-- In particular, this enables +-- unoptimized code generation for all modules that meet some +-- condition (first parameter), or are dependencies of those +-- modules. The second parameter is a condition to check before +-- marking modules for code generation. +enableCodeGenWhen + :: Logger + -> TmpFs + -> TempFileLifetime + -> TempFileLifetime + -> UnitEnv + -> [ModuleGraphNode] + -> IO ModuleGraph +enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do + mgMapM enable_code_gen mg + where + defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env) + + enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo + enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms + enable_code_gen m@(ModuleNodeFixed {}) = return m + + -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`. + -- It would be good to consider how to make these checks more uniform and not duplicated. + enable_code_gen_ms :: ModSummary -> IO ModSummary + enable_code_gen_ms ms + | ModSummary + { ms_location = ms_location + , ms_hsc_src = HsSrcFile + , ms_hspp_opts = dflags + } <- ms + , Just enable_spec <- needs_codegen_map ms = + if | nocode_enable ms -> do + let new_temp_file suf dynsuf = do + tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf + let dyn_tn = tn -<.> dynsuf + addFilesToClean tmpfs dynLife [dyn_tn] + return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn) + -- We don't want to create .o or .hi files unless we have been asked + -- to by the user. But we need them, so we patch their locations in + -- the ModSummary with temporary files. + -- + ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <- + -- If ``-fwrite-interface` is specified, then the .o and .hi files + -- are written into `-odir` and `-hidir` respectively. #16670 + if gopt Opt_WriteInterface dflags + then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location) + , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location)) + else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags)) + <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags)) + let new_dflags = case enable_spec of + EnableByteCode -> dflags { backend = interpreterBackend } + EnableObject -> dflags { backend = defaultBackendOf ms } + EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms} + let ms' = ms + { ms_location = + ms_location { ml_hi_file_ospath = hi_file + , ml_obj_file_ospath = o_file + , ml_dyn_hi_file_ospath = dyn_hi_file + , ml_dyn_obj_file_ospath = dyn_o_file } + , ms_hspp_opts = updOptLevel 0 $ new_dflags + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + + -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough) + -- we only get to this case if the default backend is already generating object files, but we need dynamic + -- objects + | bytecode_and_enable enable_spec ms -> do + let ms' = ms + { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + | dynamic_too_enable enable_spec ms -> do + let ms' = ms + { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + | ext_interp_enable ms -> do + let ms' = ms + { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter + } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + + | needs_full_ways dflags -> do + let ms' = ms { ms_hspp_opts = set_full_ways dflags } + -- Recursive call to catch the other cases + enable_code_gen_ms ms' + + | otherwise -> return ms + + enable_code_gen_ms ms = return ms + + nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) = + not (backendGeneratesCode (backend dflags)) && + -- Don't enable codegen for TH on indefinite packages; we + -- can't compile anything anyway! See #16219. + isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) + + bytecode_and_enable enable_spec ms = + -- In the situation where we **would** need to enable dynamic-too + -- IF we had decided we needed objects + dynamic_too_enable EnableObject ms + -- but we prefer to use bytecode rather than objects + && prefer_bytecode + -- and we haven't already turned it on + && not generate_both + where + lcl_dflags = ms_hspp_opts ms + prefer_bytecode = case enable_spec of + EnableByteCodeAndObject -> True + EnableByteCode -> True + EnableObject -> False + + generate_both = gopt Opt_ByteCodeAndObjectCode lcl_dflags + + -- #8180 - when using TemplateHaskell, switch on -dynamic-too so + -- the linker can correctly load the object files. This isn't necessary + -- when using -fexternal-interpreter. + -- FIXME: Duplicated from makeDynFlagsConsistent + dynamic_too_enable enable_spec ms + | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags = + not isDynWay && not dyn_too_enabled + && enable_object + | otherwise = + hostIsDynamic && not hostIsProfiled && internalInterpreter && + not isDynWay && not isProfWay && not dyn_too_enabled + && enable_object + where + lcl_dflags = ms_hspp_opts ms + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) + dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags + isDynWay = hasWay (ways lcl_dflags) WayDyn + isProfWay = hasWay (ways lcl_dflags) WayProf + enable_object = case enable_spec of + EnableByteCode -> False + EnableByteCodeAndObject -> True + EnableObject -> True + + -- #16331 - when no "internal interpreter" is available but we + -- need to process some TemplateHaskell or QuasiQuotes, we automatically + -- turn on -fexternal-interpreter. + ext_interp_enable ms = not ghciSupported && internalInterpreter + where + lcl_dflags = ms_hspp_opts ms + internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) + + + mg = mkModuleGraph mod_graph + + (td_map, lookup_node) = mkStageDeps mod_graph + + queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns) + + -- NB: Do not inline these, it is very important to share them across all calls + -- to needs_obj_set and needs_bc_set. + !query_obj = + let !deps = queryReachable need_obj_set + in \k -> deps (expectJust $ lookup_node k) + + !query_bc = + let !deps = queryReachable need_bc_set + in \k -> deps (expectJust $ lookup_node k) + + -- The direct dependencies of modules which require object code + need_obj_set = + + -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only + -- it's dependencies. + [ (mkNodeKey m, RunStage) + | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph + , isTemplateHaskellOrQQNonBoot ms + , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)) + ] + + -- The direct dependencies of modules which require byte code + need_bc_set = + [ (mkNodeKey m, RunStage) + | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph + , isTemplateHaskellOrQQNonBoot ms + , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms) + ] + + needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool + needs_obj_set k = query_obj (NodeKey_Module k, CompileStage) + + needs_bc_set k = query_bc (NodeKey_Module k, CompileStage) + + -- A map which tells us how to enable code generation for a NodeKey + needs_codegen_map :: ModSummary -> Maybe CodeGenEnable + needs_codegen_map ms = + let nk = msKey ms + + + -- Another option here would be to just produce object code, rather than both object and + -- byte code + in case (needs_obj_set nk, needs_bc_set nk) of + (True, True) -> Just EnableByteCodeAndObject + (True, False) -> Just EnableObject + (False, True) -> Just EnableByteCode + (False, False) -> Nothing + + -- FIXME: Duplicated from makeDynFlagsConsistent + needs_full_ways dflags + = ghcLink dflags == LinkInMemory && + not (gopt Opt_ExternalInterpreter dflags) && + targetWays_ dflags /= hostFullWays + set_full_ways dflags = + let platform = targetPlatform dflags + dflags_a = dflags { targetWays_ = hostFullWays } + dflags_b = foldl gopt_set dflags_a + $ concatMap (wayGeneralFlags platform) + hostFullWays + dflags_c = foldl gopt_unset dflags_b + $ concatMap (wayUnsetGeneralFlags platform) + hostFullWays + in dflags_c + +{- Note [-fno-code mode] +~~~~~~~~~~~~~~~~~~~~~~~~ +GHC offers the flag -fno-code for the purpose of parsing and typechecking a +program without generating object files. This is intended to be used by tooling +and IDEs to provide quick feedback on any parser or type errors as cheaply as +possible. + +When GHC is invoked with -fno-code, no object files or linked output will be +generated. As many errors and warnings as possible will be generated, as if +-fno-code had not been passed. The session DynFlags will have +backend == NoBackend. + +-fwrite-interface +~~~~~~~~~~~~~~~~ +Whether interface files are generated in -fno-code mode is controlled by the +-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is +not also passed. Recompilation avoidance requires interface files, so passing +-fno-code without -fwrite-interface should be avoided. If -fno-code were +re-implemented today, there would be no need for -fwrite-interface as it +would considered always on; this behaviour is as it is for backwards compatibility. + +================================================================ +IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER +================================================================ + +Template Haskell +~~~~~~~~~~~~~~~~ +A module using Template Haskell may invoke an imported function from inside a +splice. This will cause the type-checker to attempt to execute that code, which +would fail if no object files had been generated. See #8025. To rectify this, +during the downsweep we patch the DynFlags in the ModSummary of any home module +that is imported by a module that uses Template Haskell to generate object +code. + +The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled +or not in the module which needs the code generation. If the module requires byte-code then +dependencies will generate byte-code, otherwise they will generate object files. +In the case where some modules require byte-code and some object files, both are +generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these +configurations. + +The object files (and interface files if -fwrite-interface is disabled) produced +for Template Haskell are written to temporary files. + +Note that since Template Haskell can run arbitrary IO actions, -fno-code mode +is no more secure than running without it. + +Explicit Level Imports +~~~~~~~~~~~~~~~~~~~~~~ +When `-XExplicitLevelImports` is enabled, code is only generated for modules +needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers +the question, if I compile a module for a specific stage, then which modules at +other stages do I need. The roots of this query are the modules which use `TemplateHaskell` +at the runtime stage, and modules we need code generation for are those which +are needed at the compile time stage. All the logic about how ExplicitLevelImports +and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps. + +Potential TODOS: +~~~~~ +* Remove -fwrite-interface and have interface files always written in -fno-code + mode +* Both .o and .dyn_o files are generated for template haskell, but we only need + .dyn_o (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays') +* In make mode, a message like + Compiling A (A.hs, /tmp/ghc_123.o) + is shown if downsweep enabled object code generation for A. Perhaps we should + show "nothing" or "temporary object file" instead. Note that one + can currently use -keep-tmp-files and inspect the generated file with the + current behaviour. +* Offer a -no-codedir command line option, and write what were temporary + object files there. This would speed up recompilation. +* Use existing object files (if they are up to date) instead of always + generating temporary ones. +-} + +-- | Populate the Downsweep cache with the root modules. +mkRootMap + :: [ModuleNodeInfo] + -> DownsweepCache +mkRootMap summaries = Map.fromListWith (flip (++)) + [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ] + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Maybe (StringBuffer,UTCTime) + -> IO (Either DriverMessages ModSummary) + +summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, + | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries + = do + let location = ms_location $ old_summary + + src_hash <- get_src_hash + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getFileHash may fail, but that's the right + -- behaviour. + + -- return the cached summary if the source didn't change + checkSummaryHash + hsc_env (new_summary src_fn) + old_summary location src_hash + + | otherwise + = do src_hash <- get_src_hash + new_summary src_fn src_hash + where + -- change the main active unit so all operations happen relative to the given unit + hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + -- src_fn does not necessarily exist on the filesystem, so we need to + -- check what kind of target we are dealing with + get_src_hash = case maybe_buf of + Just (buf,_) -> return $ fingerprintStringBuffer buf + Nothing -> liftIO $ getFileHash src_fn + + new_summary src_fn src_hash = runExceptT $ do + preimps@PreprocessedImports {..} + <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf + + let fopts = initFinderOpts (hsc_dflags hsc_env) + (basename, extension) = splitExtension src_fn + + hsc_src + | isHaskellSigSuffix (drop 1 extension) = HsigFile + | isHaskellBootSuffix (drop 1 extension) = HsBootFile + | otherwise = HsSrcFile + + -- Make a ModLocation for this file, adding the @-boot@ suffix to + -- all paths if the original was a boot file. + location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ do + let home_unit = hsc_home_unit hsc_env + let fc = hsc_FC hsc_env + addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_hash = src_hash + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_preimps = preimps + } + +checkSummaryHash + :: HscEnv + -> (Fingerprint -> IO (Either e ModSummary)) + -> ModSummary -> ModLocation -> Fingerprint + -> IO (Either e ModSummary) +checkSummaryHash + hsc_env new_summary + old_summary + location src_hash + | ms_hs_hash old_summary == src_hash && + not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do + -- update the object-file timestamp + obj_timestamp <- modificationTimeIfExists (ml_obj_file location) + + -- We have to repopulate the Finder's cache for file targets + -- because the file might not even be on the regular search path + -- and it was likely flushed in depanal. This is not technically + -- needed when we're called from sumariseModule but it shouldn't + -- hurt. + let fc = hsc_FC hsc_env + mod = ms_mod old_summary + hsc_src = ms_hsc_src old_summary + addModuleToFinder fc mod location hsc_src + + hi_timestamp <- modificationTimeIfExists (ml_hi_file location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file location) + + return $ Right + ( old_summary + { ms_obj_date = obj_timestamp + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + } + ) + + | otherwise = + -- source changed: re-summarise. + new_summary src_hash + +data SummariseResult = + FoundInstantiation InstantiatedUnit + | FoundHomeWithError (UnitId, DriverMessages) + | FoundHome ModuleNodeInfo + | External UnitId + | NotThere + +-- | summariseModule finds the location of the source file for the given module. +-- This version always returns a ModuleNodeCompile node, it is useful for +-- --make mode. +summariseModule :: HscEnv + -> HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> Maybe (StringBuffer, UTCTime) + -> [ModuleName] + -> IO SummariseResult +summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf + + +-- | Like summariseModule but for interface files that we don't want to compile. +-- This version always returns a ModuleNodeFixed node. +summariseModuleInterface :: HscEnv + -> HomeUnit + -> IsBootInterface + -> Located ModuleName + -> PkgQual + -> [ModuleName] + -> IO SummariseResult +summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods = + summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods + where + k _hsc_env loc mod = do + -- The finder will return a path to the .hi-boot even if it doesn't actually + -- exist. So check if it exists first before concluding it's there. + does_exist <- doesFileExist (ml_hi_file loc) + if does_exist + then let key = moduleToMnk mod is_boot + in return $ FoundHome (ModuleNodeFixed key loc) + else return NotThere + + + +-- Summarise a module, and pick up source and timestamp. +summariseModuleDispatch + :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module. + -> HscEnv + -> HomeUnit + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> PkgQual + -> [ModuleName] -- Modules to exclude + -> IO SummariseResult + + +summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods + | wanted_mod `elem` excl_mods + = return NotThere + | otherwise = find_it + where + -- Temporarily change the currently active home unit so all operations + -- happen relative to it + hsc_env = hscSetActiveHomeUnit home_unit hsc_env' + + find_it :: IO SummariseResult + + find_it = do + found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg + case found of + Found location mod + | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env -> + -- Home package + k hsc_env location mod + | VirtUnit iud <- moduleUnit mod + , not (isHomeModule home_unit mod) + -> return $ FoundInstantiation iud + | otherwise -> return $ External (moduleUnitId mod) + _ -> return NotThere + -- Not found + -- (If it is TRULY not found at all, we'll + -- error when we actually try to compile) + + +-- | The continuation to summarise a home module if we want to find the source file +-- for it and potentially compile it. +summariseModuleWithSource + :: HomeUnit + -> M.Map (UnitId, FilePath) ModSummary + -- ^ Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Maybe (StringBuffer, UTCTime) + -> HscEnv + -> ModLocation + -> Module + -> IO SummariseResult +summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let src_fn = expectJust (ml_hs_file location) + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_h <- fileHashIfExists src_fn + case maybe_h of + -- This situation can also happen if we have found the .hs file but the + -- .hs-boot file doesn't exist. + Nothing -> return NotThere + Just h -> do + fresult <- new_summary_cache_check location mod src_fn h + return $ case fresult of + Left err -> FoundHomeWithError (moduleUnitId mod, err) + Right ms -> FoundHome (ModuleNodeCompile ms) + + where + dflags = hsc_dflags hsc_env + new_summary_cache_check loc mod src_fn h + | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = + + -- check the hash on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has changed then need to resummarise. + case maybe_buf of + Just (buf,_) -> + checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf) + Nothing -> + checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h + | otherwise = new_summary loc mod src_fn h + + new_summary :: ModLocation + -> Module + -> FilePath + -> Fingerprint + -> IO (Either DriverMessages ModSummary) + new_summary location mod src_fn src_hash + = runExceptT $ do + preimps@PreprocessedImports {..} + -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP + -- See multiHomeUnits_cpp2 test + <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf + + -- NB: Despite the fact that is_boot is a top-level parameter, we + -- don't actually know coming into this function what the HscSource + -- of the module in question is. This is because we may be processing + -- this module because another module in the graph imported it: in this + -- case, we know if it's a boot or not because of the {-# SOURCE #-} + -- annotation, but we don't know if it's a signature or a regular + -- module until we actually look it up on the filesystem. + let hsc_src + | is_boot == IsBoot = HsBootFile + | isHaskellSigFilename src_fn = HsigFile + | otherwise = HsSrcFile + + when (pi_mod_name /= moduleName mod) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod) + + let instantiations = homeUnitInstantiations home_unit + when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ + throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc + $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations + + liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary + { nms_src_fn = src_fn + , nms_src_hash = src_hash + , nms_hsc_src = hsc_src + , nms_location = location + , nms_mod = mod + , nms_preimps = preimps + } + +-- | Convenience named arguments for 'makeNewModSummary' only used to make +-- code more readable, not exported. +data MakeNewModSummary + = MakeNewModSummary + { nms_src_fn :: FilePath + , nms_src_hash :: Fingerprint + , nms_hsc_src :: HscSource + , nms_location :: ModLocation + , nms_mod :: Module + , nms_preimps :: PreprocessedImports + } + +makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary +makeNewModSummary hsc_env MakeNewModSummary{..} = do + let PreprocessedImports{..} = nms_preimps + obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) + dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) + hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) + hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) + + extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name + (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps + + return $ + ModSummary + { ms_mod = nms_mod + , ms_hsc_src = nms_hsc_src + , ms_location = nms_location + , ms_hspp_file = pi_hspp_fn + , ms_hspp_opts = pi_local_dflags + , ms_hspp_buf = Just pi_hspp_buf + , ms_parsed_mod = Nothing + , ms_srcimps = pi_srcimps + , ms_textual_imps = + ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) ++ + ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs) ++ + pi_theimps + , ms_hs_hash = nms_src_hash + , ms_iface_date = hi_timestamp + , ms_hie_date = hie_timestamp + , ms_obj_date = obj_timestamp + , ms_dyn_obj_date = dyn_obj_timestamp + } + +data PreprocessedImports + = PreprocessedImports + { pi_local_dflags :: DynFlags + , pi_srcimps :: [Located ModuleName] + , pi_theimps :: [(ImportLevel, PkgQual, Located ModuleName)] + , pi_hspp_fn :: FilePath + , pi_hspp_buf :: StringBuffer + , pi_mod_name_loc :: SrcSpan + , pi_mod_name :: ModuleName + } + +-- Preprocess the source file and get its imports +-- The pi_local_dflags contains the OPTIONS pragmas +getPreprocessedImports + :: HscEnv + -> FilePath + -> Maybe Phase + -> Maybe (StringBuffer, UTCTime) + -- ^ optional source code buffer and modification time + -> ExceptT DriverMessages IO PreprocessedImports +getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do + (pi_local_dflags, pi_hspp_fn) + <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase + pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn + (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name) + <- ExceptT $ do + let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags + popts = initParserOpts pi_local_dflags + mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn + return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) + let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn)) + let pi_srcimps = pi_srcimps' + let pi_theimps = rn_imps pi_theimps' + return PreprocessedImports {..} diff --git a/GHC/Driver/DynFlags.hs b/GHC/Driver/DynFlags.hs --- a/GHC/Driver/DynFlags.hs +++ b/GHC/Driver/DynFlags.hs @@ -42,6 +42,8 @@ targetProfile, + ReexportedModule(..), + -- ** Manipulating DynFlags defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags @@ -60,10 +62,10 @@ versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, - -- * Linker/compiler information - LinkerInfo(..), - CompilerInfo(..), + -- + baseUnitId, + -- * Include specifications IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, addImplicitQuoteInclude, @@ -71,6 +73,21 @@ -- * SDoc initSDocContext, initDefaultSDocContext, initPromotionTickContext, + + -- * Platform features + isSse3Enabled, + isSsse3Enabled, + isSse4_1Enabled, + isSse4_2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + isFmaEnabled, + isBmiEnabled, + isBmi2Enabled ) where import GHC.Prelude @@ -87,6 +104,7 @@ import GHC.Builtin.Names ( mAIN_NAME ) import GHC.Driver.Backend import GHC.Driver.Flags +import GHC.Driver.IncludeSpecs import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Plugins.External import GHC.Settings @@ -116,7 +134,6 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Writer (WriterT) -import Data.IORef import Data.Word import System.IO import System.IO.Error (catchIOError) @@ -155,6 +172,8 @@ -- formerly Settings ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, fileSettings :: {-# UNPACK #-} !FileSettings, + unitSettings :: {-# UNPACK #-} !UnitSettings, + targetPlatform :: Platform, -- Filled in by SysTools toolSettings :: {-# UNPACK #-} !ToolSettings, platformMisc :: {-# UNPACK #-} !PlatformMisc, @@ -196,6 +215,7 @@ dmdUnboxWidth :: !Int, -- ^ Whether DmdAnal should optimistically put an -- Unboxed demand on returned products with at most -- this number of fields + ifCompression :: Int, specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types @@ -242,7 +262,7 @@ workingDirectory :: Maybe FilePath, thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units hiddenModules :: Set.Set ModuleName, - reexportedModules :: Set.Set ModuleName, + reexportedModules :: [ReexportedModule], -- ways targetWays_ :: Ways, -- ^ Target way flags from the command line @@ -384,9 +404,17 @@ unfoldingOpts :: !UnfoldingOpts, maxWorkerArgs :: Int, + maxForcedSpecArgs :: Int, ghciHistSize :: Int, + -- wasm ghci browser mode + ghciBrowserHost :: !String, + ghciBrowserPort :: !Int, + ghciBrowserPuppeteerLaunchOpts :: !(Maybe String), + ghciBrowserPlaywrightBrowserType :: !(Maybe String), + ghciBrowserPlaywrightLaunchOpts :: !(Maybe String), + flushOut :: FlushOut, ghcVersionFile :: Maybe FilePath, @@ -402,6 +430,8 @@ useUnicode :: Bool, useColor :: OverridingBool, canUseColor :: Bool, + useErrorLinks :: OverridingBool, + canUseErrorLinks :: Bool, colScheme :: Col.Scheme, -- | what kind of {-# SCC #-} to add automatically @@ -421,15 +451,6 @@ avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. fma :: Bool, -- ^ Enable FMA instructions. - -- | Run-time linker information (what options we need, etc.) - rtldInfo :: IORef (Maybe LinkerInfo), - - -- | Run-time C compiler information - rtccInfo :: IORef (Maybe CompilerInfo), - - -- | Run-time assembler information - rtasmInfo :: IORef (Maybe CompilerInfo), - -- Constants used to control the amount of optimization done. -- | Max size, in bytes, of inline array allocations. @@ -491,9 +512,8 @@ initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do let - refRtldInfo <- newIORef Nothing - refRtccInfo <- newIORef Nothing - refRtasmInfo <- newIORef Nothing + -- This is not bulletproof: we test that 'localeEncoding' is Unicode-capable, + -- but potentially 'hGetEncoding' 'stdout' might be different. Still good enough. canUseUnicode <- do let enc = localeEncoding str = "‘’" (withCString enc str $ \cstr -> @@ -514,10 +534,9 @@ useUnicode = useUnicode', useColor = useColor', canUseColor = stderrSupportsAnsiColors, + -- if the terminal supports color, we assume it supports links as well + canUseErrorLinks = stderrSupportsAnsiColors, colScheme = colScheme', - rtldInfo = refRtldInfo, - rtccInfo = refRtccInfo, - rtasmInfo = refRtasmInfo, tmpDir = TempDir tmp_dir } @@ -544,6 +563,7 @@ maxPmCheckModels = 30, simplTickFactor = 100, dmdUnboxWidth = 3, -- Default: Assume an unboxed demand on function bodies returning a triple + ifCompression = 2, -- Default: Apply safe compressions specConstrThreshold = Just 2000, specConstrCount = Just 3, specConstrRecursive = 3, @@ -578,7 +598,7 @@ workingDirectory = Nothing, thisPackageName = Nothing, hiddenModules = Set.empty, - reexportedModules = Set.empty, + reexportedModules = [], objectDir = Nothing, dylibInstallName = Nothing, @@ -630,6 +650,7 @@ splitInfo = Nothing, ghcNameVersion = sGhcNameVersion mySettings, + unitSettings = sUnitSettings mySettings, fileSettings = sFileSettings mySettings, toolSettings = sToolSettings mySettings, targetPlatform = sTargetPlatform mySettings, @@ -674,15 +695,25 @@ unfoldingOpts = defaultUnfoldingOpts, maxWorkerArgs = 10, + maxForcedSpecArgs = 333, + -- 333 is fairly arbitrary, see Note [Forcing specialisation]:FS5 ghciHistSize = 50, -- keep a log of length 50 by default + ghciBrowserHost = "127.0.0.1", + ghciBrowserPort = 0, + ghciBrowserPuppeteerLaunchOpts = Nothing, + ghciBrowserPlaywrightBrowserType = Nothing, + ghciBrowserPlaywrightLaunchOpts = Nothing, + flushOut = defaultFlushOut, pprUserLength = 5, pprCols = 100, useUnicode = False, useColor = Auto, canUseColor = False, + useErrorLinks = Auto, + canUseErrorLinks = False, colScheme = Col.defaultScheme, profAuto = NoProfAuto, callerCcFilters = [], @@ -697,9 +728,6 @@ avx512pf = False, -- Use FMA by default on AArch64 fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64, - rtldInfo = panic "defaultDynFlags: no rtldInfo", - rtccInfo = panic "defaultDynFlags: no rtccInfo", - rtasmInfo = panic "defaultDynFlags: no rtasmInfo", maxInlineAllocSize = 128, maxInlineMemcpyInsns = 32, @@ -724,16 +752,6 @@ defaultFlushOut :: FlushOut defaultFlushOut = FlushOut $ hFlush stdout - - -data OnOff a = On a - | Off a - deriving (Eq, Show) - -instance Outputable a => Outputable (OnOff a) where - ppr (On x) = text "On" <+> ppr x - ppr (Off x) = text "Off" <+> ppr x - -- OnOffs accumulate in reverse order, so we use foldr in order to -- process them in the right order flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension @@ -755,31 +773,6 @@ -- | Use the specific semaphore @@ to control parallelism (@-jsem @ flag). | ParMakeSemaphore FilePath --- ----------------------------------------------------------------------------- --- Linker/compiler information - --- LinkerInfo contains any extra options needed by the system linker. -data LinkerInfo - = GnuLD [Option] - | Mold [Option] - | GnuGold [Option] - | LlvmLLD [Option] - | DarwinLD [Option] - | SolarisLD [Option] - | AixLD [Option] - | UnknownLD - deriving Eq - --- CompilerInfo tells us which C compiler we're using -data CompilerInfo - = GCC - | Clang - | AppleClang - | AppleClang51 - | Emscripten - | UnknownCC - deriving Eq - -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to @@ -945,44 +938,17 @@ | PkgDbPath FilePath deriving Eq --- | Used to differentiate the scope an include needs to apply to. --- We have to split the include paths to avoid accidentally forcing recursive --- includes since -I overrides the system search paths. See #14312. -data IncludeSpecs - = IncludeSpecs { includePathsQuote :: [String] - , includePathsGlobal :: [String] - -- | See Note [Implicit include paths] - , includePathsQuoteImplicit :: [String] - } - deriving Show --- | Append to the list of includes a path that shall be included using `-I` --- when the C compiler is called. These paths override system search paths. -addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs -addGlobalInclude spec paths = let f = includePathsGlobal spec - in spec { includePathsGlobal = f ++ paths } --- | Append to the list of includes a path that shall be included using --- `-iquote` when the C compiler is called. These paths only apply when quoted --- includes are used. e.g. #include "foo.h" -addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs -addQuoteInclude spec paths = let f = includePathsQuote spec - in spec { includePathsQuote = f ++ paths } - --- | These includes are not considered while fingerprinting the flags for iface --- | See Note [Implicit include paths] -addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs -addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec - in spec { includePathsQuoteImplicit = f ++ paths } - +-- An argument to --reexported-module which can optionally specify a module renaming. +data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName + , reexportTo :: ModuleName + } --- | Concatenate and flatten the list of global and quoted includes returning --- just a flat list of paths. -flattenIncludes :: IncludeSpecs -> [String] -flattenIncludes specs = - includePathsQuote specs ++ - includePathsQuoteImplicit specs ++ - includePathsGlobal specs +instance Outputable ReexportedModule where + ppr (ReexportedModule from to) = + if from == to then ppr from + else ppr from <+> text "as" <+> ppr to {- Note [Implicit include paths] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1175,6 +1141,7 @@ Opt_GenManifest, Opt_GhciHistory, Opt_GhciSandbox, + Opt_GhciDoLoadTargets, Opt_HelpfulErrors, Opt_KeepHiFiles, Opt_KeepOFiles, @@ -1190,7 +1157,8 @@ Opt_ShowErrorContext, Opt_SuppressStgReps, Opt_UnoptimizedCoreForInterpreter, - Opt_SpecialiseIncoherents + Opt_SpecialiseIncoherents, + Opt_WriteSelfRecompInfo ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] @@ -1199,12 +1167,10 @@ -- Default floating flags (see Note [RHS Floating]) ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ] - ++ default_PIC platform ++ validHoleFitDefaults - where platform = sTargetPlatform settings -- | These are the default settings for the display and sorting of valid hole @@ -1248,8 +1214,8 @@ -- Default settings of flags, before any command-line overrides optLevelFlags -- see Note [Documenting optimisation flags] = [ ([0,1,2], Opt_DoLambdaEtaExpansion) - , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] - , ([0,1,2], Opt_LlvmTBAA) + , ([1,2], Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep] + , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] , ([0,1,2], Opt_ProfManualCcs ) , ([2], Opt_DictsStrict) @@ -1300,12 +1266,10 @@ -- RegsGraph suffers performance regression. See #7679 -- , ([2], Opt_StaticArgumentTransformation) -- Static Argument Transformation needs investigation. See #9374 + , ([0,1,2], Opt_SpecEval) + , ([], Opt_SpecEvalDictFun) ] -type TurnOnFlag = Bool -- True <=> we are turning the flag on - -- False <=> we are turning the flag off -turnOn :: TurnOnFlag; turnOn = True -turnOff :: TurnOnFlag; turnOff = False default_PIC :: Platform -> [GeneralFlag] default_PIC platform = @@ -1325,12 +1289,14 @@ (OSDarwin, ArchAArch64) -> [Opt_PIC] (OSLinux, ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] (OSLinux, ArchARM {}) -> [Opt_PIC, Opt_ExternalDynamicRefs] + (OSLinux, ArchRISCV64 {}) -> [Opt_PIC, Opt_ExternalDynamicRefs] (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in -- OpenBSD since 5.3 release -- (1 May 2013) we need to -- always generate PIC. See -- #10597 for more -- information. + (OSLinux, ArchLoongArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] _ -> [] -- | The language extensions implied by the various language variants. @@ -1339,7 +1305,7 @@ languageExtensions :: Maybe Language -> [LangExt.Extension] -- Nothing: the default case -languageExtensions Nothing = languageExtensions (Just GHC2021) +languageExtensions Nothing = languageExtensions (Just defaultLanguage) languageExtensions (Just Haskell98) = [LangExt.ImplicitPrelude, @@ -1357,8 +1323,10 @@ -- turning it off breaks code, so we're keeping it on for -- backwards compatibility. Cabal uses -XHaskell98 by -- default unless you specify another language. - LangExt.DeepSubsumption + LangExt.DeepSubsumption, -- Non-standard but enabled for backwards compatability (see GHC proposal #511) + LangExt.ListTuplePuns, + LangExt.ImplicitStagePersistence ] languageExtensions (Just Haskell2010) @@ -1375,7 +1343,10 @@ LangExt.DoAndIfThenElse, LangExt.FieldSelectors, LangExt.RelaxedPolyRec, - LangExt.DeepSubsumption ] + LangExt.DeepSubsumption, + LangExt.ListTuplePuns, + LangExt.ImplicitStagePersistence + ] languageExtensions (Just GHC2021) = [LangExt.ImplicitPrelude, @@ -1389,6 +1360,7 @@ LangExt.DoAndIfThenElse, LangExt.FieldSelectors, LangExt.RelaxedPolyRec, + LangExt.ListTuplePuns, -- Now the new extensions (not in Haskell2010) LangExt.BangPatterns, LangExt.BinaryLiterals, @@ -1425,8 +1397,20 @@ LangExt.TupleSections, LangExt.TypeApplications, LangExt.TypeOperators, - LangExt.TypeSynonymInstances] + LangExt.TypeSynonymInstances, + LangExt.ImplicitStagePersistence + ] +languageExtensions (Just GHC2024) + = languageExtensions (Just GHC2021) ++ + [LangExt.DataKinds, + LangExt.DerivingStrategies, + LangExt.DisambiguateRecordFields, + LangExt.ExplicitNamespaces, + LangExt.GADTs, + LangExt.MonoLocalBinds, + LangExt.LambdaCase, + LangExt.RoleAnnotations] ways :: DynFlags -> Ways ways dflags @@ -1484,9 +1468,13 @@ versionedFilePath :: ArchOS -> FilePath versionedFilePath platform = uniqueSubdir platform +-- | Access the unit-id of the version of `base` which we will automatically link +-- against. +baseUnitId :: DynFlags -> UnitId +baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags) + -- SDoc ------------------------------------------- - -- | Initialize the pretty-printing options initSDocContext :: DynFlags -> PprStyle -> SDocContext initSDocContext dflags style = SDC @@ -1497,6 +1485,7 @@ , sdocDefaultDepth = pprUserLength dflags , sdocLineLength = pprCols dflags , sdocCanUseUnicode = useUnicode dflags + , sdocPrintErrIndexLinks = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags) , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags , sdocPprDebug = dopt Opt_D_ppr_debug dflags , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags @@ -1524,7 +1513,7 @@ , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags , sdocLinearTypes = xopt LangExt.LinearTypes dflags - , sdocListTuplePuns = True + , sdocListTuplePuns = xopt LangExt.ListTuplePuns dflags , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } @@ -1536,6 +1525,57 @@ initPromotionTickContext :: DynFlags -> PromotionTickContext initPromotionTickContext dflags = PromTickCtx { - ptcListTuplePuns = True, + ptcListTuplePuns = xopt LangExt.ListTuplePuns dflags, ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags } + +-- ----------------------------------------------------------------------------- +-- SSE, AVX, FMA + +isSse3Enabled :: DynFlags -> Bool +isSse3Enabled dflags = sseVersion dflags >= Just SSE3 + +isSsse3Enabled :: DynFlags -> Bool +isSsse3Enabled dflags = sseVersion dflags >= Just SSSE3 + +isSse4_1Enabled :: DynFlags -> Bool +isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4 + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +isAvx512pfEnabled :: DynFlags -> Bool +isAvx512pfEnabled dflags = avx512pf dflags + +isFmaEnabled :: DynFlags -> Bool +isFmaEnabled dflags = fma dflags + +-- ----------------------------------------------------------------------------- +-- BMI2 + +isBmiEnabled :: DynFlags -> Bool +isBmiEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI1 + ArchX86 -> bmiVersion dflags >= Just BMI1 + _ -> False + +isBmi2Enabled :: DynFlags -> Bool +isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI2 + ArchX86 -> bmiVersion dflags >= Just BMI2 + _ -> False diff --git a/GHC/Driver/Env.hs b/GHC/Driver/Env.hs --- a/GHC/Driver/Env.hs +++ b/GHC/Driver/Env.hs @@ -1,7 +1,9 @@ - +{-# LANGUAGE LambdaCase #-} module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -13,8 +15,7 @@ , hsc_all_home_unit_ids , hscUpdateLoggerFlags , hscUpdateHUG - , hscUpdateHPT_lazy - , hscUpdateHPT + , hscInsertHPT , hscSetActiveHomeUnit , hscSetActiveUnitId , hscActiveUnitId @@ -24,18 +25,20 @@ , runInteractiveHsc , hscEPS , hscInterp - , hptCompleteSigs - , hptAllInstances - , hptInstancesBelow - , hptAnns - , hptAllThings - , hptSomeThingsBelowUs - , hptRules , prepareAnnotations , discardIC , lookupType , lookupIfaceByModule + , lookupIfaceByModuleHsc , mainModIs + + , hugRulesBelow + , hugInstancesBelow + , hugAnnsBelow + , hugCompleteSigsBelow + + -- * Legacy API + , hscUpdateHPT ) where @@ -56,22 +59,18 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Home.ModInfo -import GHC.Unit.Env +import GHC.Unit.Home.PackageTable +import GHC.Unit.Home.Graph +import GHC.Unit.Module.Graph +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Env as UnitEnv import GHC.Unit.External -import GHC.Core ( CoreRule ) -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv - -import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) -import GHC.Types.CompleteMatch import GHC.Types.Error ( emptyMessages, Messages ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.TyThing -import GHC.Builtin.Names ( gHC_PRIM ) - import GHC.Data.Maybe import GHC.Utils.Exception as Ex @@ -81,13 +80,19 @@ import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Core.Rules +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Builtin.Names + import Data.IORef import qualified Data.Set as Set -import GHC.Unit.Module.Graph runHsc :: HscEnv -> Hsc a -> IO a -runHsc hsc_env (Hsc hsc) = do - (a, w) <- hsc hsc_env emptyMessages +runHsc hsc_env hsc = do + (a, w) <- runHsc' hsc_env hsc let dflags = hsc_dflags hsc_env let !diag_opts = initDiagOpts dflags !print_config = initPrintConfig dflags @@ -110,13 +115,13 @@ runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) hsc_home_unit :: HscEnv -> HomeUnit -hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env +hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env hsc_units :: HasDebugCallStack => HscEnv -> UnitState -hsc_units = ue_units . hsc_unit_env +hsc_units = ue_homeUnitState . hsc_unit_env hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env @@ -127,22 +132,21 @@ hsc_HUG :: HscEnv -> HomeUnitGraph hsc_HUG = ue_home_unit_graph . hsc_unit_env -hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId -hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG +hsc_mod_graph :: HscEnv -> ModuleGraph +hsc_mod_graph = ue_module_graph . hsc_unit_env -hscUpdateHPT_lazy :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv -hscUpdateHPT_lazy f hsc_env = - let !res = updateHpt_lazy f (hsc_unit_env hsc_env) - in hsc_env { hsc_unit_env = res } +hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId +hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG -hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv -hscUpdateHPT f hsc_env = - let !res = updateHpt f (hsc_unit_env hsc_env) - in hsc_env { hsc_unit_env = res } +hscInsertHPT :: HomeModInfo -> HscEnv -> IO () +hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env) hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } +setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv +setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } } + {- Note [Target code interpreter] @@ -166,7 +170,7 @@ The target code interpreter to use can be selected per session via the `hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in which case Template Haskell and GHCi will fail to run. The interpreter to use is -configured via command-line flags (in `GHC.setSessionDynFlags`). +configured via command-line flags (in `GHC.setTopSessionDynFlags`). -} @@ -217,66 +221,68 @@ hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -hptCompleteSigs :: HscEnv -> [CompleteMatch] -hptCompleteSigs = hptAllThings (md_complete_matches . hm_details) - --- | Find all the instance declarations (of classes and families) from --- the Home Package Table filtered by the provided predicate function. --- Used in @tcRnImports@, to select the instances that are in the --- transitive closure of imports from the currently compiled module. -hptAllInstances :: HscEnv -> (InstEnv, [FamInst]) -hptAllInstances hsc_env - = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do - let details = hm_details mod_info - return (md_insts details, md_fam_insts details) - in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) - --- | Find instances visible from the given set of imports -hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst]) -hptInstancesBelow hsc_env uid mnwib = - let - mn = gwib_mod mnwib - (insts, famInsts) = - unzip $ hptSomeThingsBelowUs (\mod_info -> - let details = hm_details mod_info - -- Don't include instances for the current module - in if moduleName (mi_module (hm_iface mod_info)) == mn - then [] - else [(md_insts details, md_fam_insts details)]) - True -- Include -hi-boot - hsc_env - uid - mnwib - in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) - --- | Get rules from modules "below" this one (in the dependency sense) -hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule] -hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False +-------------------------------------------------------------------------------- +-- * Queries on Transitive Closure +-------------------------------------------------------------------------------- +-- | Find all rules in modules that are in the transitive closure of the given +-- module. +hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase +hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$> + hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn --- | Get annotations from modules "below" this one (in the dependency sense) -hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation] -hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env +-- | Get annotations from all modules "below" this one (in the dependency +-- sense) within the home units. If the module is @Nothing@, returns /all/ +-- annotations in the home units. +hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv +hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$> + hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn -hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] -hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd) - (hugElts (hsc_HUG hsc_env)) +-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the +-- given module. +hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches +hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> + hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn --- | Get things from modules "below" this one (in the dependency sense) --- C.f Inst.hptInstances -hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a] -hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn - | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] +-- | Find instances visible from the given set of imports +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst]) +hugInstancesBelow hsc_env uid mnwib = do + let mn = gwib_mod mnwib + (insts, famInsts) <- + unzip . concat <$> + hugSomeThingsBelowUs (\mod_info -> + let details = hm_details mod_info + -- Don't include instances for the current module + in if moduleName (mi_module (hm_iface mod_info)) == mn + then [] + else [(md_insts details, md_fam_insts details)]) + True -- Include -hi-boot + hsc_env + uid + mnwib + return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) - | otherwise +-- | Get things from modules in the transitive closure of the given module. +-- +-- Note: Don't expose this function. This is a footgun if exposed! +hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]] +-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk +-- These things are currently stored in the EPS for home packages. (See #25795 for +-- progress in removing these kind of checks; and making these functions of +-- `UnitEnv` rather than `HscEnv`) +-- See Note [Downsweep and the ModuleGraph] +hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return [] +hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn = let hug = hsc_HUG hsc_env mg = hsc_mod_graph hsc_env in - [ thing - | - -- Find each non-hi-boot module below me - (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (moduleGraphModulesBelow mg uid mn) + sequence + [ things + -- "Finding each non-hi-boot module below me" maybe could be cached (well, + -- the inverse) in the module graph to avoid filtering the boots out of + -- the transitive closure out every time this is called + | (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) + <- Set.toList (moduleGraphModulesBelow mg uid mn) , include_hi_boot || (is_boot == NotBoot) -- unsavoury: when compiling the base package with --make, we @@ -286,20 +292,17 @@ , mod /= moduleName gHC_PRIM , not (mod == gwib_mod mn && uid == mod_uid) - -- Look it up in the HPT - , let things = case lookupHug hug mod_uid mod of - Just info -> extract info - Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty + -- Look it up in the HUG + , let things = lookupHug hug mod_uid mod >>= \case + Just info -> return $ extract info + Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg mempty msg = vcat [text "missing module" <+> ppr mod, text "When starting from" <+> ppr mn, text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn), text "Probable cause: out-of-date interface files"] -- This really shouldn't happen, but see #962 - , thing <- things ] - - -- | Deal with gathering annotations in from all possible places -- and combining them into a single 'AnnEnv' prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv @@ -311,11 +314,13 @@ -- otherwise load annotations from all home package table -- entries regardless of dependency ordering. get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot) - home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts + home_pkg_anns <- fromMaybe (hugAllAnns (hsc_unit_env hsc_env)) + $ uncurry (hugAnnsBelow hsc_env) + . get_mod <$> mb_guts + let other_pkg_anns = eps_ann_env eps - ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, - Just home_pkg_anns, - Just other_pkg_anns] + !ann_env = maybe id plusAnnEnv mb_this_module_anns $! + plusAnnEnv home_pkg_anns other_pkg_anns return ann_env -- | Find the 'TyThing' for the given 'Name' by using all the resources @@ -327,9 +332,9 @@ lookupType hsc_env name = do eps <- liftIO $ hscEPS hsc_env let pte = eps_PTE eps - return $ lookupTypeInPTE hsc_env pte name + lookupTypeInPTE hsc_env pte name -lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> Maybe TyThing +lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing) lookupTypeInPTE hsc_env pte name = ty where hpt = hsc_HUG hsc_env @@ -338,12 +343,12 @@ then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) else nameModule name - !ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) + ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) -- in one-shot, we don't use the HPT - then lookupNameEnv pte name - else case lookupHugByModule mod hpt of - Just hm -> lookupNameEnv (md_types (hm_details hm)) name - Nothing -> lookupNameEnv pte name + then return $! lookupNameEnv pte name + else HUG.lookupHugByModule mod hpt >>= \case + Just hm -> pure $! lookupNameEnv (md_types (hm_details hm)) name + Nothing -> pure $! lookupNameEnv pte name -- | Find the 'ModIface' for a 'Module', searching in both the loaded home -- and external package module information @@ -351,9 +356,9 @@ :: HomeUnitGraph -> PackageIfaceTable -> Module - -> Maybe ModIface + -> IO (Maybe ModIface) lookupIfaceByModule hug pit mod - = case lookupHugByModule mod hug of + = HUG.lookupHugByModule mod hug >>= pure . \case Just hm -> Just (hm_iface hm) Nothing -> lookupModuleEnv pit mod -- If the module does come from the home package, why do we look in the PIT as well? @@ -363,8 +368,13 @@ -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. +lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface) +lookupIfaceByModuleHsc hsc_env mod = do + eps <- hscEPS hsc_env + lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod + mainModIs :: HomeUnitEnv -> Module -mainModIs hue = mkHomeModule (expectJust "mainModIs" $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) +mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue)) -- | Retrieve the target code interpreter -- @@ -425,3 +435,19 @@ where home_unit = hsc_home_unit hsc_env old_name = ic_name old_ic + + +-------------------------------------------------------------------------------- +-- * The Legacy API, should be removed after enough deprecation cycles +-------------------------------------------------------------------------------- + +{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \ + \ operation. Instead, the HPT is an insert-only data structure. If you want to \ + \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \ + \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-} +hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv +hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue } + where + ue = hsc_unit_env hsc_env + upd hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) } + diff --git a/GHC/Driver/Env/Types.hs b/GHC/Driver/Env/Types.hs --- a/GHC/Driver/Env/Types.hs +++ b/GHC/Driver/Env/Types.hs @@ -18,7 +18,6 @@ import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types -import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -65,9 +64,6 @@ hsc_targets :: [Target], -- ^ The targets (or roots) of the current session - hsc_mod_graph :: ModuleGraph, - -- ^ The module graph of the current session - hsc_IC :: InteractiveContext, -- ^ The context for evaluating interactive statements @@ -112,3 +108,4 @@ , hsc_llvm_config :: !LlvmConfigCache -- ^ LLVM configuration cache. } + diff --git a/GHC/Driver/Errors.hs b/GHC/Driver/Errors.hs --- a/GHC/Driver/Errors.hs +++ b/GHC/Driver/Errors.hs @@ -13,20 +13,22 @@ import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger -printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () +printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () printMessages logger msg_opts opts msgs = sequence_ [ let style = mkErrStyle name_ppr_ctx ctx = (diag_ppr_ctx opts) { sdocStyle = style } - in logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $ - updSDocContext (\_ -> ctx) (messageWithHints dia) - | MsgEnvelope { errMsgSpan = s, - errMsgDiagnostic = dia, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = name_ppr_ctx } + in (if log_diags_as_json + then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg + else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $ + updSDocContext (\_ -> ctx) (messageWithHints dia)) + | msg@MsgEnvelope { errMsgSpan = s, + errMsgDiagnostic = dia, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = name_ppr_ctx } <- sortMsgBag (Just opts) (getMessages msgs) ] where - messageWithHints :: Diagnostic a => a -> SDoc + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e in case diagnosticHints e of @@ -34,6 +36,7 @@ [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) + log_diags_as_json = log_diagnostics_as_json (logFlags logger) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. diff --git a/GHC/Driver/Errors/Ppr.hs b/GHC/Driver/Errors/Ppr.hs --- a/GHC/Driver/Errors/Ppr.hs +++ b/GHC/Driver/Errors/Ppr.hs @@ -14,13 +14,15 @@ import GHC.Driver.Errors.Types import GHC.Driver.Flags import GHC.Driver.DynFlags -import GHC.HsToCore.Errors.Ppr () -import GHC.Parser.Errors.Ppr () +import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage +import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage import GHC.Types.Error -import GHC.Types.Error.Codes ( constructorCode ) +import GHC.Types.Error.Codes import GHC.Unit.Types import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Unit.Module +import GHC.Unit.Module.Graph import GHC.Unit.State import GHC.Types.Hint import GHC.Types.SrcLoc @@ -30,8 +32,9 @@ import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) import GHC.Iface.Errors.Types -import GHC.Tc.Errors.Ppr () -import GHC.Iface.Errors.Ppr () +import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage +import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage +import GHC.CmmToLlvm.Version (llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound) -- -- Suggestions @@ -59,7 +62,7 @@ -> diagnosticMessage (dsMessageOpts opts) m GhcDriverMessage m -> diagnosticMessage (driverMessageOpts opts) m - GhcUnknownMessage (UnknownDiagnostic f m) + GhcUnknownMessage (UnknownDiagnostic f _ m) -> diagnosticMessage (f opts) m diagnosticReason = \case @@ -86,7 +89,7 @@ GhcUnknownMessage m -> diagnosticHints m - diagnosticCode = constructorCode + diagnosticCode = constructorCode @GHC instance HasDefaultDiagnosticOpts DriverMessageOpts where defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) @@ -94,7 +97,7 @@ instance Diagnostic DriverMessage where type DiagnosticOpts DriverMessage = DriverMessageOpts diagnosticMessage opts = \case - DriverUnknownMessage (UnknownDiagnostic f m) + DriverUnknownMessage (UnknownDiagnostic f _ m) -> diagnosticMessage (f opts) m DriverPsHeaderMessage m -> diagnosticMessage (psDiagnosticOpts opts) m @@ -152,7 +155,7 @@ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) - DriverModuleNotFound mod + DriverModuleNotFound _uid mod -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally") DriverFileModuleNameMismatch actual expected -> mkSimpleDecorated $ @@ -238,7 +241,48 @@ -> mkSimpleDecorated $ text $ "unrecognised warning flag: -" ++ arg DriverDeprecatedFlag arg msg -> mkSimpleDecorated $ text $ arg ++ " is deprecated: " ++ msg + DriverModuleGraphCycle path + -> mkSimpleDecorated $ vcat + [ text "Module graph contains a cycle:" + , nest 2 (show_path path) ] + where + 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_node (UnitNode uid _) = pprPanic "UnitNode should not be in a cycle" (ppr uid) + + ppr_ms :: ModuleNodeInfo -> SDoc + ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+> + (parens (text (node_path ms))) + + node_path :: ModuleNodeInfo -> FilePath + node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of + Just f -> f + Nothing -> ml_hi_file (moduleNodeInfoLocation ms) + DriverInstantiationNodeInDependencyGeneration node -> + mkSimpleDecorated $ + vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" + , nest 2 $ ppr node ] + DriverNoConfiguredLLVMToolchain -> + mkSimpleDecorated $ + text "GHC was not configured with a supported LLVM toolchain" $$ + text ("Make sure you have installed LLVM between [" + ++ llvmVersionStr supportedLlvmVersionLowerBound + ++ " and " + ++ llvmVersionStr supportedLlvmVersionUpperBound + ++ ") and reinstall GHC to ensure -fllvm works") + diagnosticReason = \case DriverUnknownMessage m -> diagnosticReason m @@ -303,6 +347,12 @@ -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags DriverDeprecatedFlag {} -> WarningWithFlag Opt_WarnDeprecatedFlags + DriverModuleGraphCycle {} + -> ErrorWithoutFlag + DriverInstantiationNodeInDependencyGeneration {} + -> ErrorWithoutFlag + DriverNoConfiguredLLVMToolchain + -> WarningWithoutFlag diagnosticHints = \case DriverUnknownMessage m @@ -370,5 +420,11 @@ -> noHints DriverDeprecatedFlag {} -> noHints + DriverModuleGraphCycle {} + -> noHints + DriverInstantiationNodeInDependencyGeneration {} + -> noHints + DriverNoConfiguredLLVMToolchain + -> noHints - diagnosticCode = constructorCode + diagnosticCode = constructorCode @GHC diff --git a/GHC/Driver/Errors/Types.hs b/GHC/Driver/Errors/Types.hs --- a/GHC/Driver/Errors/Types.hs +++ b/GHC/Driver/Errors/Types.hs @@ -4,6 +4,7 @@ module GHC.Driver.Errors.Types ( GhcMessage(..) + , AnyGhcDiagnostic , GhcMessageOpts(..) , DriverMessage(..) , DriverMessageOpts(..) @@ -24,10 +25,11 @@ import Data.Bifunctor import Data.Typeable -import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt) +import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt, ReexportedModule) import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage)) import GHC.Types.Error import GHC.Unit.Module +import GHC.Unit.Module.Graph import GHC.Unit.State import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) ) @@ -93,10 +95,11 @@ -- 'Diagnostic' constraint ensures that worst case scenario we can still -- render this into something which can be eventually converted into a -- 'DecoratedSDoc'. - GhcUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts GhcMessage)) -> GhcMessage + GhcUnknownMessage :: (UnknownDiagnosticFor GhcMessage) -> GhcMessage deriving Generic +type AnyGhcDiagnostic = UnknownDiagnosticFor GhcMessage data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage , tcMessageOpts :: DiagnosticOpts TcRnMessage @@ -110,7 +113,7 @@ -- conversion can happen gradually. This function should not be needed within -- GHC, as it would typically be used by plugin or library authors (see -- comment for the 'GhcUnknownMessage' type constructor) -ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage +ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint GhcMessage, Diagnostic a, Typeable a) => a -> GhcMessage ghcUnknownMessage = GhcUnknownMessage . mkSimpleUnknownDiagnostic -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on @@ -129,7 +132,7 @@ -- | A message from the driver. data DriverMessage where -- | Simply wraps a generic 'Diagnostic' message @a@. - DriverUnknownMessage :: UnknownDiagnostic (DiagnosticOpts DriverMessage) -> DriverMessage + DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage -- | A parse error in parsing a Haskell file header during dependency -- analysis @@ -151,7 +154,7 @@ {-| DriverUnknown is a warning that arises when a user tries to reexport a module which isn't part of that unit. -} - DriverUnknownReexportedModules :: UnitId -> [ModuleName] -> DriverMessage + DriverUnknownReexportedModules :: UnitId -> [ReexportedModule] -> DriverMessage {-| DriverUnknownHiddenModules is a warning that arises when a user tries to hide a module which isn't part of that unit. @@ -184,7 +187,7 @@ Test cases: None. -} - DriverModuleNotFound :: !ModuleName -> DriverMessage + DriverModuleNotFound :: !UnitId -> !ModuleName -> DriverMessage {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name. The first field is the name written in the source code; the second argument is the name extracted @@ -383,6 +386,31 @@ DriverUnrecognisedFlag :: String -> DriverMessage DriverDeprecatedFlag :: String -> String -> DriverMessage + + {-| DriverModuleGraphCycle is an error that occurs if the module graph + contains cyclic imports. + + Test cases: + tests/backpack/should_fail/bkpfail51 + tests/driver/T20459 + tests/driver/T24196/T24196 + tests/driver/T24275/T24275 + + -} + DriverModuleGraphCycle :: [ModuleGraphNode] -> DriverMessage + + {- | DriverInstantiationNodeInDependencyGeneration is an error that occurs + if the module graph used for dependency generation contains + Backpack 'InstantiationNode's. -} + DriverInstantiationNodeInDependencyGeneration :: InstantiatedUnit -> DriverMessage + + {-| DriverNoConfiguredLLVMToolchain is an error that occurs if there is no + LLVM toolchain configured but -fllvm is passed as an option to the compiler. + + Test cases: None. + + -} + DriverNoConfiguredLLVMToolchain :: DriverMessage deriving instance Generic DriverMessage diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -1,9 +1,12 @@ +{-# LANGUAGE LambdaCase #-} + module GHC.Driver.Flags ( DumpFlag(..) , getDumpFlagFrom , enabledIfVerbose , GeneralFlag(..) , Language(..) + , defaultLanguage , optimisationFlags , codeGenFlags @@ -25,6 +28,23 @@ , minusWeverythingOpts , minusWcompatOpts , unusedBindsFlags + + , OnOff(..) + , TurnOnFlag + , turnOn + , turnOff + , impliedXFlags + , validHoleFitsImpliedGFlags + , impliedGFlags + , impliedOffGFlags + , glasgowExtsFlags + + , ExtensionDeprecation(..) + , Deprecation(..) + , extensionDeprecation + , deprecation + , extensionNames + , extensionName ) where @@ -38,9 +58,16 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) -data Language = Haskell98 | Haskell2010 | GHC2021 +import qualified GHC.LanguageExtensions as LangExt + +data Language = Haskell98 | Haskell2010 | GHC2021 | GHC2024 deriving (Eq, Enum, Show, Bounded) +-- | The default Language is used if one is not specified explicitly, by both +-- GHC and GHCi. +defaultLanguage :: Language +defaultLanguage = GHC2021 + instance Outputable Language where ppr = text . show @@ -49,8 +76,350 @@ get bh = toEnum <$> get bh instance NFData Language where - rnf x = x `seq` () + rnf Haskell98 = () + rnf Haskell2010 = () + rnf GHC2021 = () + rnf GHC2024 = () +data OnOff a = On a + | Off a + deriving (Eq, Show) + +instance Outputable a => Outputable (OnOff a) where + ppr (On x) = text "On" <+> ppr x + ppr (Off x) = text "Off" <+> ppr x + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) + +data ExtensionDeprecation + = ExtensionNotDeprecated + | ExtensionDeprecatedFor [LangExt.Extension] + | ExtensionFlagDeprecatedCond TurnOnFlag String + | ExtensionFlagDeprecated String + deriving Eq + +-- | Always returns 'Deprecated' even when the flag is +-- only conditionally deprecated. +deprecation :: ExtensionDeprecation -> Deprecation +deprecation ExtensionNotDeprecated = NotDeprecated +deprecation _ = Deprecated + +extensionDeprecation :: LangExt.Extension -> ExtensionDeprecation +extensionDeprecation = \case + LangExt.TypeInType -> ExtensionDeprecatedFor [LangExt.DataKinds, LangExt.PolyKinds] + LangExt.NullaryTypeClasses -> ExtensionDeprecatedFor [LangExt.MultiParamTypeClasses] + LangExt.RelaxedPolyRec -> ExtensionFlagDeprecatedCond turnOff + "You can't turn off RelaxedPolyRec any more" + LangExt.DatatypeContexts -> ExtensionFlagDeprecatedCond turnOn + "It was widely considered a misfeature, and has been removed from the Haskell language." + LangExt.AutoDeriveTypeable -> ExtensionFlagDeprecatedCond turnOn + "Typeable instances are created automatically for all types since GHC 8.2." + LangExt.OverlappingInstances -> ExtensionFlagDeprecated + "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS" + _ -> ExtensionNotDeprecated + + +extensionName :: LangExt.Extension -> String +extensionName = \case + LangExt.Cpp -> "CPP" + LangExt.OverlappingInstances -> "OverlappingInstances" + LangExt.UndecidableInstances -> "UndecidableInstances" + LangExt.IncoherentInstances -> "IncoherentInstances" + LangExt.UndecidableSuperClasses -> "UndecidableSuperClasses" + LangExt.MonomorphismRestriction -> "MonomorphismRestriction" + LangExt.MonoLocalBinds -> "MonoLocalBinds" + LangExt.DeepSubsumption -> "DeepSubsumption" + LangExt.RelaxedPolyRec -> "RelaxedPolyRec" -- Deprecated + LangExt.ExtendedDefaultRules -> "ExtendedDefaultRules" -- Use GHC's extended rules for defaulting + LangExt.NamedDefaults -> "NamedDefaults" + LangExt.ForeignFunctionInterface -> "ForeignFunctionInterface" + LangExt.UnliftedFFITypes -> "UnliftedFFITypes" + LangExt.InterruptibleFFI -> "InterruptibleFFI" + LangExt.CApiFFI -> "CApiFFI" + LangExt.GHCForeignImportPrim -> "GHCForeignImportPrim" + LangExt.JavaScriptFFI -> "JavaScriptFFI" + LangExt.ParallelArrays -> "ParallelArrays" -- Syntactic support for parallel arrays + LangExt.Arrows -> "Arrows" -- Arrow-notation syntax + LangExt.TemplateHaskell -> "TemplateHaskell" + LangExt.TemplateHaskellQuotes -> "TemplateHaskellQuotes" -- subset of TH supported by stage1, no splice + LangExt.QualifiedDo -> "QualifiedDo" + LangExt.QuasiQuotes -> "QuasiQuotes" + LangExt.ImplicitParams -> "ImplicitParams" + LangExt.ImplicitPrelude -> "ImplicitPrelude" + LangExt.ScopedTypeVariables -> "ScopedTypeVariables" + LangExt.AllowAmbiguousTypes -> "AllowAmbiguousTypes" + LangExt.UnboxedTuples -> "UnboxedTuples" + LangExt.UnboxedSums -> "UnboxedSums" + LangExt.UnliftedNewtypes -> "UnliftedNewtypes" + LangExt.UnliftedDatatypes -> "UnliftedDatatypes" + LangExt.BangPatterns -> "BangPatterns" + LangExt.TypeFamilies -> "TypeFamilies" + LangExt.TypeFamilyDependencies -> "TypeFamilyDependencies" + LangExt.TypeInType -> "TypeInType" -- Deprecated + LangExt.OverloadedStrings -> "OverloadedStrings" + LangExt.OverloadedLists -> "OverloadedLists" + LangExt.NumDecimals -> "NumDecimals" + LangExt.OrPatterns -> "OrPatterns" + LangExt.DisambiguateRecordFields -> "DisambiguateRecordFields" + LangExt.RecordWildCards -> "RecordWildCards" + LangExt.NamedFieldPuns -> "NamedFieldPuns" + LangExt.ViewPatterns -> "ViewPatterns" + LangExt.GADTs -> "GADTs" + LangExt.GADTSyntax -> "GADTSyntax" + LangExt.NPlusKPatterns -> "NPlusKPatterns" + LangExt.DoAndIfThenElse -> "DoAndIfThenElse" + LangExt.BlockArguments -> "BlockArguments" + LangExt.RebindableSyntax -> "RebindableSyntax" + LangExt.ConstraintKinds -> "ConstraintKinds" + LangExt.PolyKinds -> "PolyKinds" -- Kind polymorphism + LangExt.DataKinds -> "DataKinds" -- Datatype promotion + LangExt.TypeData -> "TypeData" -- allow @type data@ definitions + LangExt.InstanceSigs -> "InstanceSigs" + LangExt.ApplicativeDo -> "ApplicativeDo" + LangExt.LinearTypes -> "LinearTypes" + LangExt.RequiredTypeArguments -> "RequiredTypeArguments" -- Visible forall (VDQ) in types of terms + LangExt.StandaloneDeriving -> "StandaloneDeriving" + LangExt.DeriveDataTypeable -> "DeriveDataTypeable" + LangExt.AutoDeriveTypeable -> "AutoDeriveTypeable" -- Automatic derivation of Typeable + LangExt.DeriveFunctor -> "DeriveFunctor" + LangExt.DeriveTraversable -> "DeriveTraversable" + LangExt.DeriveFoldable -> "DeriveFoldable" + LangExt.DeriveGeneric -> "DeriveGeneric" -- Allow deriving Generic/1 + LangExt.DefaultSignatures -> "DefaultSignatures" -- Allow extra signatures for defmeths + LangExt.DeriveAnyClass -> "DeriveAnyClass" -- Allow deriving any class + LangExt.DeriveLift -> "DeriveLift" -- Allow deriving Lift + LangExt.DerivingStrategies -> "DerivingStrategies" + LangExt.DerivingVia -> "DerivingVia" -- Derive through equal representation + LangExt.TypeSynonymInstances -> "TypeSynonymInstances" + LangExt.FlexibleContexts -> "FlexibleContexts" + LangExt.FlexibleInstances -> "FlexibleInstances" + LangExt.ConstrainedClassMethods -> "ConstrainedClassMethods" + LangExt.MultiParamTypeClasses -> "MultiParamTypeClasses" + LangExt.NullaryTypeClasses -> "NullaryTypeClasses" + LangExt.FunctionalDependencies -> "FunctionalDependencies" + LangExt.UnicodeSyntax -> "UnicodeSyntax" + LangExt.ExistentialQuantification -> "ExistentialQuantification" + LangExt.MagicHash -> "MagicHash" + LangExt.EmptyDataDecls -> "EmptyDataDecls" + LangExt.KindSignatures -> "KindSignatures" + LangExt.RoleAnnotations -> "RoleAnnotations" + LangExt.ParallelListComp -> "ParallelListComp" + LangExt.TransformListComp -> "TransformListComp" + LangExt.MonadComprehensions -> "MonadComprehensions" + LangExt.GeneralizedNewtypeDeriving -> "GeneralizedNewtypeDeriving" + LangExt.RecursiveDo -> "RecursiveDo" + LangExt.PostfixOperators -> "PostfixOperators" + LangExt.TupleSections -> "TupleSections" + LangExt.PatternGuards -> "PatternGuards" + LangExt.LiberalTypeSynonyms -> "LiberalTypeSynonyms" + LangExt.RankNTypes -> "RankNTypes" + LangExt.ImpredicativeTypes -> "ImpredicativeTypes" + LangExt.TypeOperators -> "TypeOperators" + LangExt.ExplicitNamespaces -> "ExplicitNamespaces" + LangExt.PackageImports -> "PackageImports" + LangExt.ExplicitForAll -> "ExplicitForAll" + LangExt.AlternativeLayoutRule -> "AlternativeLayoutRule" + LangExt.AlternativeLayoutRuleTransitional -> "AlternativeLayoutRuleTransitional" + LangExt.DatatypeContexts -> "DatatypeContexts" + LangExt.NondecreasingIndentation -> "NondecreasingIndentation" + LangExt.RelaxedLayout -> "RelaxedLayout" + LangExt.TraditionalRecordSyntax -> "TraditionalRecordSyntax" + LangExt.LambdaCase -> "LambdaCase" + LangExt.MultiWayIf -> "MultiWayIf" + LangExt.BinaryLiterals -> "BinaryLiterals" + LangExt.NegativeLiterals -> "NegativeLiterals" + LangExt.HexFloatLiterals -> "HexFloatLiterals" + LangExt.DuplicateRecordFields -> "DuplicateRecordFields" + LangExt.OverloadedLabels -> "OverloadedLabels" + LangExt.EmptyCase -> "EmptyCase" + LangExt.PatternSynonyms -> "PatternSynonyms" + LangExt.PartialTypeSignatures -> "PartialTypeSignatures" + LangExt.NamedWildCards -> "NamedWildCards" + LangExt.StaticPointers -> "StaticPointers" + LangExt.TypeApplications -> "TypeApplications" + LangExt.Strict -> "Strict" + LangExt.StrictData -> "StrictData" + LangExt.EmptyDataDeriving -> "EmptyDataDeriving" + LangExt.NumericUnderscores -> "NumericUnderscores" + LangExt.QuantifiedConstraints -> "QuantifiedConstraints" + LangExt.StarIsType -> "StarIsType" + LangExt.ImportQualifiedPost -> "ImportQualifiedPost" + LangExt.CUSKs -> "CUSKs" + LangExt.StandaloneKindSignatures -> "StandaloneKindSignatures" + LangExt.LexicalNegation -> "LexicalNegation" + LangExt.FieldSelectors -> "FieldSelectors" + LangExt.OverloadedRecordDot -> "OverloadedRecordDot" + LangExt.OverloadedRecordUpdate -> "OverloadedRecordUpdate" + LangExt.TypeAbstractions -> "TypeAbstractions" + LangExt.ExtendedLiterals -> "ExtendedLiterals" + LangExt.ListTuplePuns -> "ListTuplePuns" + LangExt.MultilineStrings -> "MultilineStrings" + LangExt.ExplicitLevelImports -> "ExplicitLevelImports" + LangExt.ImplicitStagePersistence -> "ImplicitStagePersistence" + +-- | Is this extension known by any other names? For example +-- -XGeneralizedNewtypeDeriving is accepted +extensionAlternateNames :: LangExt.Extension -> [String] +extensionAlternateNames = \case + LangExt.GeneralizedNewtypeDeriving -> ["GeneralisedNewtypeDeriving"] + LangExt.RankNTypes -> ["Rank2Types", "PolymorphicComponents"] + _ -> [] + +extensionDeprecatedNames :: LangExt.Extension -> [String] +extensionDeprecatedNames = \case + LangExt.RecursiveDo -> ["DoRec"] + LangExt.NamedFieldPuns -> ["RecordPuns"] + LangExt.ScopedTypeVariables -> ["PatternSignatures"] + _ -> [] + +-- | All the names by which an extension is known. +extensionNames :: LangExt.Extension -> [ (ExtensionDeprecation, String) ] +extensionNames ext = mk (extensionDeprecation ext) (extensionName ext : extensionAlternateNames ext) + ++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext) + where mk depr = map (\name -> (depr, name)) + +impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (LangExt.RankNTypes, On LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, On LangExt.ExplicitForAll) + , (LangExt.ScopedTypeVariables, On LangExt.ExplicitForAll) + , (LangExt.LiberalTypeSynonyms, On LangExt.ExplicitForAll) + , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll) + , (LangExt.FlexibleInstances, On LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, On LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, On LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, On LangExt.TypeFamilies) + + , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude) -- NB: turn off! + + , (LangExt.DerivingVia, On LangExt.DerivingStrategies) + + , (LangExt.GADTs, On LangExt.GADTSyntax) + , (LangExt.GADTs, On LangExt.MonoLocalBinds) + , (LangExt.TypeFamilies, On LangExt.MonoLocalBinds) + + , (LangExt.TypeFamilies, On LangExt.KindSignatures) -- Type families use kind signatures + , (LangExt.PolyKinds, On LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (LangExt.TypeInType, On LangExt.DataKinds) + , (LangExt.TypeInType, On LangExt.PolyKinds) + , (LangExt.TypeInType, On LangExt.KindSignatures) + + -- Standalone kind signatures are a replacement for CUSKs. + , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, On LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, On LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, On LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, On LangExt.ParallelListComp) + , (LangExt.MonadComprehensions, On LangExt.ParallelListComp) + , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes) + , (LangExt.Strict, On LangExt.StrictData) + + -- Historically only UnboxedTuples was required for unboxed sums to work. + -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums. + , (LangExt.UnboxedTuples, On LangExt.UnboxedSums) + + -- The extensions needed to declare an H98 unlifted data type + , (LangExt.UnliftedDatatypes, On LangExt.DataKinds) + , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures) + + -- See (NVP3) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind + , (LangExt.LinearTypes, On LangExt.MonoLocalBinds) + + , (LangExt.ExplicitLevelImports, Off LangExt.ImplicitStagePersistence) + ] + + +validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +validHoleFitsImpliedGFlags + = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] + +-- | General flags that are switched on/off when other general flags are switched +-- on +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) + ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) + ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface) + ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore) + ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack) + ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback) + ] ++ validHoleFitsImpliedGFlags + +-- | General flags that are switched on/off when other general flags are switched +-- off +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +-- Please keep @docs/users_guide/what_glasgow_exts_does.rst@ up to date with this list. +glasgowExtsFlags :: [LangExt.Extension] +glasgowExtsFlags = [ + LangExt.ConstrainedClassMethods + , LangExt.DeriveDataTypeable + , LangExt.DeriveFoldable + , LangExt.DeriveFunctor + , LangExt.DeriveGeneric + , LangExt.DeriveTraversable + , LangExt.EmptyDataDecls + , LangExt.ExistentialQuantification + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.ForeignFunctionInterface + , LangExt.FunctionalDependencies + , LangExt.GeneralizedNewtypeDeriving + , LangExt.ImplicitParams + , LangExt.KindSignatures + , LangExt.LiberalTypeSynonyms + , LangExt.MagicHash + , LangExt.MultiParamTypeClasses + , LangExt.ParallelListComp + , LangExt.PatternGuards + , LangExt.PostfixOperators + , LangExt.RankNTypes + , LangExt.RecursiveDo + , LangExt.ScopedTypeVariables + , LangExt.StandaloneDeriving + , LangExt.TypeOperators + , LangExt.TypeSynonymInstances + , LangExt.UnboxedTuples + , LangExt.UnicodeSyntax + , LangExt.UnliftedFFITypes ] + -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session @@ -64,7 +433,7 @@ -- enabled if you run -ddump-cmm-verbose-by-proc -- Each flag corresponds to exact stage of Cmm pipeline. | Opt_D_dump_cmm_verbose - -- same as -ddump-cmm-verbose-by-proc but writes each stage + -- ^ same as -ddump-cmm-verbose-by-proc but writes each stage -- to a separate file (if used with -ddump-to-file) | Opt_D_dump_cmm_cfg | Opt_D_dump_cmm_cbe @@ -116,10 +485,11 @@ | Opt_D_dump_stg_cg -- ^ STG (after stg2stg) | Opt_D_dump_stg_tags -- ^ Result of tag inference analysis. | Opt_D_dump_stg_final -- ^ Final STG (before cmm gen) + | Opt_D_dump_stg_from_js_sinker -- ^ STG after JS sinker | Opt_D_dump_call_arity | Opt_D_dump_exitify - | Opt_D_dump_stranal - | Opt_D_dump_str_signatures + | Opt_D_dump_dmdanal + | Opt_D_dump_dmd_signatures | Opt_D_dump_cpranal | Opt_D_dump_cpr_signatures | Opt_D_dump_tc @@ -137,9 +507,9 @@ | Opt_D_dump_rn_stats | Opt_D_dump_opt_cmm | Opt_D_dump_simpl_stats - | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_cs_trace -- ^ Constraint solver in type checker | Opt_D_dump_tc_trace - | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker + | Opt_D_dump_ec_trace -- ^ Pattern match exhaustiveness checker | Opt_D_dump_if_trace | Opt_D_dump_splices | Opt_D_th_dec_file @@ -218,6 +588,7 @@ | Opt_DoAsmLinting | Opt_DoAnnotationLinting | Opt_DoBoundsChecking + | Opt_AddBcoName | Opt_NoLlvmMangler -- hidden flag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds @@ -227,9 +598,13 @@ | Opt_InfoTableMapWithFallback | Opt_InfoTableMapWithStack - | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_ShowWarnGroups -- Show the group a warning belongs to - | Opt_HideSourcePaths -- Hide module source/object paths + | Opt_WarnIsError + -- ^ @-Werror@; makes all warnings fatal. + -- See 'wopt_set_fatal' for making individual warnings fatal as in @-Werror=foo@. + | Opt_ShowWarnGroups + -- ^ Show the group a warning belongs to. + | Opt_HideSourcePaths + -- ^ @-fhide-source-paths@; hide module source/object paths. | Opt_PrintExplicitForalls | Opt_PrintExplicitKinds @@ -273,19 +648,19 @@ | Opt_SpecConstrKeen | Opt_SpecialiseIncoherents | Opt_DoLambdaEtaExpansion + | Opt_DoCleverArgEtaExpansion -- See Note [Eta expansion of arguments in CorePrep] | Opt_IgnoreAsserts | Opt_DoEtaReduction | Opt_CaseMerge - | Opt_CaseFolding -- Constant folding through case-expressions + | Opt_CaseFolding -- ^ Constant folding through case-expressions | Opt_UnboxStrictFields | Opt_UnboxSmallStrictFields | Opt_DictsCheap - | Opt_EnableRewriteRules -- Apply rewrite rules during simplification - | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices - | Opt_RegsGraph -- do graph coloring register allocation - | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation - | Opt_PedanticBottoms -- Be picky about how we treat bottom - | Opt_LlvmTBAA -- Use LLVM TBAA infrastructure for improving AA (hidden flag) + | Opt_EnableRewriteRules -- ^ Apply rewrite rules during simplification + | Opt_EnableThSpliceWarnings -- ^ Enable warnings for TH splices + | Opt_RegsGraph -- ^ Do graph coloring register allocation + | Opt_RegsIterative -- ^ Do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- ^ Be picky about how we treat bottom | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) | Opt_IrrefutableTuples | Opt_CmmSink @@ -293,28 +668,32 @@ | Opt_CmmElimCommonBlocks | Opt_CmmControlFlow | Opt_AsmShortcutting + | Opt_InterModuleFarJumps | Opt_OmitYields - | Opt_FunToThunk -- deprecated - | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_FunToThunk -- deprecated + | Opt_DictsStrict -- ^ Be strict in argument dictionaries | Opt_DmdTxDictSel -- ^ deprecated, no effect and behaviour is now default. -- Allowed switching of a special demand transformer for dictionary selectors - | Opt_Loopification -- See Note [Self-recursive tail calls] - | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. - | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. | Opt_CprAnal | Opt_WorkerWrapper | Opt_WorkerWrapperUnlift -- ^ Do W/W split for unlifting even if we won't unbox anything. | Opt_SolveConstantDicts | Opt_AlignmentSanitisation | Opt_CatchNonexhaustiveCases - | Opt_NumConstantFolding + | Opt_NumConstantFolding -- ^ See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold | Opt_CoreConstantFolding | Opt_FastPAPCalls -- #6084 + | Opt_SpecEval + | Opt_SpecEvalDictFun -- See Note [Controlling Speculative Evaluation] + -- Inference flags | Opt_DoTagInferenceChecks - -- PreInlining is on by default. The option is there just to see how + -- | PreInlining is on by default. The option is there just to see how -- bad things get if you turn it off! | Opt_SimplPreInlining @@ -322,17 +701,24 @@ | Opt_IgnoreInterfacePragmas | Opt_OmitInterfacePragmas | Opt_ExposeAllUnfoldings - | Opt_WriteInterface -- forces .hi files to be written even with -fno-code - | Opt_WriteHie -- generate .hie files + | Opt_ExposeOverloadedUnfoldings + | Opt_KeepAutoRules -- ^ Keep auto-generated rules even if they seem to have become useless + | Opt_WriteInterface -- ^ Forces .hi files to be written even with -fno-code + | Opt_WriteSelfRecompInfo + | Opt_WriteSelfRecompFlags -- ^ Include detailed flag information for self-recompilation debugging + | Opt_WriteHie -- ^ Generate .hie files -- JavaScript opts - | Opt_DisableJsMinifier -- ^ render JavaScript pretty-printed instead of minified (compacted) + | Opt_DisableJsMinifier -- ^ Render JavaScript pretty-printed instead of minified (compacted) + | Opt_DisableJsCsources -- ^ Don't link C sources (compiled to JS) with Haskell code (compiled to JS) -- profiling opts | Opt_AutoSccsOnIndividualCafs | Opt_ProfCountEntries | Opt_ProfLateInlineCcs | Opt_ProfLateCcs + | Opt_ProfLateOverloadedCcs + | Opt_ProfLateoverloadedCallsCCs | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations -- misc opts @@ -342,6 +728,7 @@ | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_OrigThunkInfo | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats @@ -366,6 +753,14 @@ | Opt_ValidateHie | Opt_LocalGhciHistory | Opt_NoIt + + -- wasm ghci browser mode + | Opt_GhciBrowser + | Opt_GhciBrowserRedirectWasiConsole + + -- | Instruct GHCi to load all targets on startup + | Opt_GhciDoLoadTargets + | Opt_HelpfulErrors | Opt_DeferTypeErrors -- Since 7.6 | Opt_DeferTypedHoles -- Since 7.10 @@ -406,10 +801,11 @@ | Opt_LinkRts -- output style opts - | Opt_ErrorSpans -- Include full span info in error messages, + | Opt_ErrorSpans -- ^ Include full span info in error messages, -- instead of just the start position. | Opt_DeferDiagnostics - | Opt_DiagnosticsShowCaret -- Show snippets of offending code + | Opt_DiagnosticsAsJSON -- ^ Dump diagnostics as JSON + | Opt_DiagnosticsShowCaret -- ^ Show snippets of offending code | Opt_PprCaseAsLet | Opt_PprShowTicks | Opt_ShowHoleConstraints @@ -432,35 +828,38 @@ | Opt_ShowLoadedModules | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] - -- Suppress a coercions inner structure, replacing it with '...' + -- | Suppress a coercions inner structure, replacing it with '...' | Opt_SuppressCoercions - -- Suppress the type of a coercion as well + -- | Suppress the type of a coercion as well | Opt_SuppressCoercionTypes | Opt_SuppressVarKinds - -- Suppress module id prefixes on variables. + -- | Suppress module id prefixes on variables. | Opt_SuppressModulePrefixes - -- Suppress type applications. + -- | Suppress type applications. | Opt_SuppressTypeApplications - -- Suppress info such as arity and unfoldings on identifiers. + -- | Suppress info such as arity and unfoldings on identifiers. | Opt_SuppressIdInfo - -- Suppress separate type signatures in core, but leave types on + -- | Suppress separate type signatures in core, but leave types on -- lambda bound vars | Opt_SuppressUnfoldings - -- Suppress the details of even stable unfoldings + -- | Suppress the details of even stable unfoldings | Opt_SuppressTypeSignatures - -- Suppress unique ids on variables. + -- | Suppress unique ids on variables. -- Except for uniques, as some simplifier phases introduce new -- variables that have otherwise identical names. | Opt_SuppressUniques | Opt_SuppressStgExts | Opt_SuppressStgReps - | Opt_SuppressTicks -- Replaces Opt_PprShowTicks + | Opt_SuppressTicks -- ^ Replaces Opt_PprShowTicks | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps -- Error message suppression | Opt_ShowErrorContext + -- Object code determinism + | Opt_ObjectDeterminism + -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified @@ -525,11 +924,11 @@ , Opt_EnableRewriteRules , Opt_RegsGraph , Opt_RegsIterative - , Opt_LlvmTBAA , Opt_IrrefutableTuples , Opt_CmmSink , Opt_CmmElimCommonBlocks , Opt_AsmShortcutting + , Opt_InterModuleFarJumps , Opt_FunToThunk , Opt_DmdTxDictSel , Opt_Loopification @@ -539,6 +938,8 @@ , Opt_WorkerWrapper , Opt_WorkerWrapperUnlift , Opt_SolveConstantDicts + , Opt_SpecEval + , Opt_SpecEvalDictFun ] -- | The set of flags which affect code generation and can change a program's @@ -570,7 +971,10 @@ -- Flags that affect generated code , Opt_ExposeAllUnfoldings + , Opt_ExposeOverloadedUnfoldings , Opt_NoTypeableBinds + , Opt_ObjectDeterminism + , Opt_Haddock -- Flags that affect catching of runtime errors , Opt_CatchNonexhaustiveCases @@ -582,6 +986,7 @@ , Opt_InfoTableMap , Opt_InfoTableMapWithStack , Opt_InfoTableMapWithFallback + , Opt_OrigThunkInfo ] data WarningFlag = @@ -617,7 +1022,7 @@ | Opt_WarnRedundantRecordWildcards | Opt_WarnDeprecatedFlags | Opt_WarnMissingMonadFailInstances -- since 8.0, has no effect since 8.8 - | Opt_WarnSemigroup -- since 8.0 + | Opt_WarnSemigroup -- since 8.0, has no effect since 9.8 | Opt_WarnDodgyExports | Opt_WarnDodgyImports | Opt_WarnOrphans @@ -646,49 +1051,62 @@ | Opt_WarnDerivingTypeable | Opt_WarnDeferredTypeErrors | Opt_WarnDeferredOutOfScopeVariables - | Opt_WarnNonCanonicalMonadInstances -- since 8.0 - | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 - | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 - | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 - | Opt_WarnUnrecognisedWarningFlags -- since 8.0 - | Opt_WarnSimplifiableClassConstraints -- Since 8.2 - | Opt_WarnCPPUndef -- Since 8.2 - | Opt_WarnUnbangedStrictPatterns -- Since 8.2 - | Opt_WarnMissingHomeModules -- Since 8.2 - | Opt_WarnPartialFields -- Since 8.4 + | Opt_WarnNonCanonicalMonadInstances -- ^ @since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- ^ @since 8.0, has no effect since 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- ^ @since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- ^ @since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- ^ @since 8.0 + | Opt_WarnSimplifiableClassConstraints -- ^ @since 8.2 + | Opt_WarnCPPUndef -- ^ @since 8.2 + | Opt_WarnUnbangedStrictPatterns -- ^ @since 8.2 + | Opt_WarnMissingHomeModules -- ^ @since 8.2 + | Opt_WarnPartialFields -- ^ @since 8.4 | Opt_WarnMissingExportList | Opt_WarnInaccessibleCode - | Opt_WarnStarIsType -- Since 8.6 - | Opt_WarnStarBinder -- Since 8.6 - | Opt_WarnImplicitKindVars -- Since 8.6 + | Opt_WarnStarIsType -- ^ @since 8.6 + | Opt_WarnStarBinder -- ^ @since 8.6 + | Opt_WarnImplicitKindVars -- ^ @since 8.6 | Opt_WarnSpaceAfterBang - | Opt_WarnMissingDerivingStrategies -- Since 8.8 - | Opt_WarnPrepositiveQualifiedModule -- Since 8.10 - | Opt_WarnUnusedPackages -- Since 8.10 - | Opt_WarnInferredSafeImports -- Since 8.10 - | Opt_WarnMissingSafeHaskellMode -- Since 8.10 - | Opt_WarnCompatUnqualifiedImports -- Since 8.10 + | Opt_WarnMissingDerivingStrategies -- ^ @since 8.8 + | Opt_WarnPrepositiveQualifiedModule -- ^ @since 8.10 + | Opt_WarnUnusedPackages -- ^ @since 8.10 + | Opt_WarnInferredSafeImports -- ^ @since 8.10 + | Opt_WarnMissingSafeHaskellMode -- ^ @since 8.10 + | Opt_WarnCompatUnqualifiedImports -- ^ @since 8.10 | Opt_WarnDerivingDefaults - | Opt_WarnInvalidHaddock -- Since 9.0 - | Opt_WarnOperatorWhitespaceExtConflict -- Since 9.2 - | Opt_WarnOperatorWhitespace -- Since 9.2 - | Opt_WarnAmbiguousFields -- Since 9.2 - | Opt_WarnImplicitLift -- Since 9.2 - | Opt_WarnMissingKindSignatures -- Since 9.2 - | Opt_WarnMissingPolyKindSignatures -- Since 9.8 - | Opt_WarnMissingExportedPatternSynonymSignatures -- since 9.2 - | Opt_WarnRedundantStrictnessFlags -- Since 9.4 - | Opt_WarnForallIdentifier -- Since 9.4 - | Opt_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2 - | Opt_WarnGADTMonoLocalBinds -- Since 9.4 - | Opt_WarnTypeEqualityOutOfScope -- Since 9.4 - | Opt_WarnTypeEqualityRequiresOperators -- Since 9.4 - | Opt_WarnLoopySuperclassSolve -- Since 9.6 - | Opt_WarnTermVariableCapture -- Since 9.8 - | Opt_WarnMissingRoleAnnotations -- Since 9.8 - | Opt_WarnImplicitRhsQuantification -- Since 9.8 - | Opt_WarnIncompleteExportWarnings -- Since 9.8 - | Opt_WarnInconsistentFlags -- Since 9.8 + | Opt_WarnInvalidHaddock -- ^ @since 9.0 + | Opt_WarnOperatorWhitespaceExtConflict -- ^ @since 9.2 + | Opt_WarnOperatorWhitespace -- ^ @since 9.2 + | Opt_WarnAmbiguousFields -- ^ @since 9.2 + | Opt_WarnImplicitLift -- ^ @since 9.2 + | Opt_WarnMissingKindSignatures -- ^ @since 9.2 + | Opt_WarnMissingPolyKindSignatures -- ^ @since 9.8 + | Opt_WarnMissingExportedPatternSynonymSignatures -- ^ @since 9.2 + | Opt_WarnRedundantStrictnessFlags -- ^ @since 9.4 + | Opt_WarnForallIdentifier -- ^ @since 9.4 + | Opt_WarnUnicodeBidirectionalFormatCharacters -- ^ @since 9.0.2 + | Opt_WarnGADTMonoLocalBinds -- ^ @since 9.4 + | Opt_WarnTypeEqualityOutOfScope -- ^ @since 9.4 + | Opt_WarnTypeEqualityRequiresOperators -- ^ @since 9.4 + | Opt_WarnLoopySuperclassSolve -- ^ @since 9.6, has no effect since 9.10 + | Opt_WarnTermVariableCapture -- ^ @since 9.8 + | Opt_WarnMissingRoleAnnotations -- ^ @since 9.8 + | Opt_WarnImplicitRhsQuantification -- ^ @since 9.8 + | Opt_WarnIncompleteExportWarnings -- ^ @since 9.8 + | Opt_WarnIncompleteRecordSelectors -- ^ @since 9.10 + | Opt_WarnBadlyLevelledTypes -- ^ @since 9.10 + | Opt_WarnInconsistentFlags -- ^ @since 9.8 + | Opt_WarnDataKindsTC -- ^ @since 9.10 + | Opt_WarnDefaultedExceptionContext -- ^ @since 9.10 + | Opt_WarnViewPatternSignatures -- ^ @since 9.12 + | Opt_WarnUselessSpecialisations -- ^ @since 9.14 + | Opt_WarnDeprecatedPragmas -- ^ @since 9.14 + | Opt_WarnRuleLhsEqualities + -- ^ @since 9.14, scheduled to be removed in 9.18 + -- + -- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig + | Opt_WarnUnusableUnpackPragmas -- Since 9.14 + | Opt_WarnPatternNamespaceSpecifier -- Since 9.14 deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag @@ -799,7 +1217,17 @@ Opt_WarnMissingRoleAnnotations -> "missing-role-annotations" :| [] Opt_WarnImplicitRhsQuantification -> "implicit-rhs-quantification" :| [] Opt_WarnIncompleteExportWarnings -> "incomplete-export-warnings" :| [] + Opt_WarnIncompleteRecordSelectors -> "incomplete-record-selectors" :| [] + Opt_WarnBadlyLevelledTypes -> "badly-levelled-types" :| [] Opt_WarnInconsistentFlags -> "inconsistent-flags" :| [] + Opt_WarnDataKindsTC -> "data-kinds-tc" :| [] + Opt_WarnDefaultedExceptionContext -> "defaulted-exception-context" :| [] + Opt_WarnViewPatternSignatures -> "view-pattern-signatures" :| [] + Opt_WarnUselessSpecialisations -> "useless-specialisations" :| ["useless-specializations"] + Opt_WarnDeprecatedPragmas -> "deprecated-pragmas" :| [] + Opt_WarnRuleLhsEqualities -> "rule-lhs-equalities" :| [] + Opt_WarnUnusableUnpackPragmas -> "unusable-unpack-pragmas" :| [] + Opt_WarnPatternNamespaceSpecifier -> "pattern-namespace-specifier" :| [] -- ----------------------------------------------------------------------------- -- Standard sets of warning options @@ -859,7 +1287,7 @@ -- | Warning groups. -- --- As all warnings are in the Weverything set, it is ignored when +-- As all warnings are in the 'W_everything' set, it is ignored when -- displaying to the user which group a warning is in. warningGroups :: [WarningGroup] warningGroups = [minBound..maxBound] @@ -874,7 +1302,7 @@ -- Separating this from 'warningGroups' allows for multiple -- hierarchies with no inherent relation to be defined. -- --- The special-case Weverything group is not included. +-- The special-case 'W_everything' group is not included. warningHierarchies :: [[WarningGroup]] warningHierarchies = hierarchies ++ map (:[]) rest where @@ -934,15 +1362,21 @@ Opt_WarnNonCanonicalMonadInstances, Opt_WarnNonCanonicalMonoidInstances, Opt_WarnOperatorWhitespaceExtConflict, - Opt_WarnForallIdentifier, Opt_WarnUnicodeBidirectionalFormatCharacters, Opt_WarnGADTMonoLocalBinds, - Opt_WarnLoopySuperclassSolve, + Opt_WarnBadlyLevelledTypes, Opt_WarnTypeEqualityRequiresOperators, - Opt_WarnInconsistentFlags + Opt_WarnInconsistentFlags, + Opt_WarnTypeEqualityOutOfScope, + Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 9.16 + Opt_WarnViewPatternSignatures, + Opt_WarnUselessSpecialisations, + Opt_WarnDeprecatedPragmas, + Opt_WarnRuleLhsEqualities, + Opt_WarnUnusableUnpackPragmas ] --- | Things you get with -W +-- | Things you get with @-W@. minusWOpts :: [WarningFlag] minusWOpts = standardWarnings ++ @@ -958,7 +1392,7 @@ Opt_WarnUnbangedStrictPatterns ] --- | Things you get with -Wall +-- | Things you get with @-Wall@. minusWallOpts :: [WarningFlag] minusWallOpts = minusWOpts ++ @@ -974,29 +1408,26 @@ Opt_WarnRedundantRecordWildcards, Opt_WarnIncompleteUniPatterns, Opt_WarnIncompletePatternsRecUpd, - Opt_WarnIncompleteExportWarnings + Opt_WarnIncompleteExportWarnings, + Opt_WarnIncompleteRecordSelectors, + Opt_WarnDerivingTypeable ] --- | Things you get with -Weverything, i.e. *all* known warnings flags +-- | Things you get with @-Weverything@, i.e. *all* known warnings flags. minusWeverythingOpts :: [WarningFlag] minusWeverythingOpts = [ toEnum 0 .. ] --- | Things you get with -Wcompat. +-- | Things you get with @-Wcompat@. -- -- This is intended to group together warnings that will be enabled by default -- at some point in the future, so that library authors eager to make their -- code future compatible to fix issues before they even generate warnings. minusWcompatOpts :: [WarningFlag] minusWcompatOpts - = [ Opt_WarnSemigroup - , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnNonCanonicalMonadInstances - , Opt_WarnCompatUnqualifiedImports - , Opt_WarnTypeEqualityOutOfScope - , Opt_WarnImplicitRhsQuantification + = [ Opt_WarnPatternNamespaceSpecifier ] --- | Things you get with -Wunused-binds +-- | Things you get with @-Wunused-binds@. unusedBindsFlags :: [WarningFlag] unusedBindsFlags = [ Opt_WarnUnusedTopBinds , Opt_WarnUnusedLocalBinds diff --git a/GHC/Driver/GenerateCgIPEStub.hs b/GHC/Driver/GenerateCgIPEStub.hs --- a/GHC/Driver/GenerateCgIPEStub.hs +++ b/GHC/Driver/GenerateCgIPEStub.hs @@ -10,18 +10,17 @@ import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel) import GHC.Cmm.Dataflow (O) import GHC.Cmm.Dataflow.Block (blockSplit, blockToList) -import GHC.Cmm.Dataflow.Collections -import GHC.Cmm.Dataflow.Label (Label) +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) @@ -29,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)) @@ -36,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)] @@ -194,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 @@ -208,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 <- diff --git a/GHC/Driver/Hooks.hs b/GHC/Driver/Hooks.hs --- a/GHC/Driver/Hooks.hs +++ b/GHC/Driver/Hooks.hs @@ -48,12 +48,11 @@ import GHC.Types.CostCentre import GHC.Types.IPE import GHC.Types.Meta -import GHC.Types.HpcInfo import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface -import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable import GHC.Core import GHC.Core.TyCon @@ -61,13 +60,13 @@ import GHC.Tc.Types import GHC.Stg.Syntax +import GHC.StgToCmm.CgUtils (CgStream) import GHC.StgToCmm.Types (ModuleLFInfos) import GHC.StgToCmm.Config import GHC.Cmm import GHCi.RemoteTypes -import GHC.Data.Stream import GHC.Data.Bag import qualified Data.Kind @@ -149,9 +148,9 @@ -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) , stgToCmmHook :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs - -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)) - , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a - -> IO (Stream IO RawCmmGroup a))) + -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos)) + , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a + -> IO (CgStream RawCmmGroup a))) } class HasHooks m where diff --git a/GHC/Driver/IncludeSpecs.hs b/GHC/Driver/IncludeSpecs.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/IncludeSpecs.hs @@ -0,0 +1,48 @@ +module GHC.Driver.IncludeSpecs + ( IncludeSpecs(..) + , addGlobalInclude + , addQuoteInclude + , addImplicitQuoteInclude + , flattenIncludes + ) where + +import GHC.Prelude + +-- | Used to differentiate the scope an include needs to apply to. +-- We have to split the include paths to avoid accidentally forcing recursive +-- includes since -I overrides the system search paths. See #14312. +data IncludeSpecs + = IncludeSpecs { includePathsQuote :: [String] + , includePathsGlobal :: [String] + -- | See Note [Implicit include paths] + , includePathsQuoteImplicit :: [String] + } + deriving Show + +-- | Append to the list of includes a path that shall be included using `-I` +-- when the C compiler is called. These paths override system search paths. +addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addGlobalInclude spec paths = let f = includePathsGlobal spec + in spec { includePathsGlobal = f ++ paths } + +-- | Append to the list of includes a path that shall be included using +-- `-iquote` when the C compiler is called. These paths only apply when quoted +-- includes are used. e.g. #include "foo.h" +addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addQuoteInclude spec paths = let f = includePathsQuote spec + in spec { includePathsQuote = f ++ paths } + +-- | These includes are not considered while fingerprinting the flags for iface +-- | See Note [Implicit include paths] +addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addImplicitQuoteInclude spec paths = let f = includePathsQuoteImplicit spec + in spec { includePathsQuoteImplicit = f ++ paths } + + +-- | Concatenate and flatten the list of global and quoted includes returning +-- just a flat list of paths. +flattenIncludes :: IncludeSpecs -> [String] +flattenIncludes specs = + includePathsQuote specs ++ + includePathsQuoteImplicit specs ++ + includePathsGlobal specs diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} - {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -50,6 +46,8 @@ , HscBackendAction (..), HscRecompStatus (..) , initModDetails , initWholeCoreBindings + , loadIfaceByteCode + , loadIfaceByteCodeLazy , hscMaybeWriteIface , hscCompileCmmFile @@ -64,6 +62,7 @@ , hscRecompStatus , hscParse , hscTypecheckRename + , hscTypecheckRenameWithDiagnostics , hscTypecheckAndGetWarnings , hscDesugar , makeSimpleDetails @@ -83,7 +82,7 @@ , hscRnImportDecls , hscTcRnLookupRdrName , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt - , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls + , hscParseDeclsWithLocation, hscParsedDecls , hscParseModuleWithLocation , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType , hscParseExpr @@ -105,12 +104,13 @@ , showModuleIndex , hscAddSptEntries , writeInterfaceOnlyMode + , loadByteCode + , genModDetails ) where import GHC.Prelude import GHC.Platform -import GHC.Platform.Ways import GHC.Driver.Plugins import GHC.Driver.Session @@ -118,6 +118,7 @@ import GHC.Driver.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Errors +import GHC.Driver.Messager import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) @@ -164,7 +165,7 @@ import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) -import GHC.Iface.Load ( ifaceStats, writeIface ) +import GHC.Iface.Load ( ifaceStats, writeIface, flagsToIfCompression, getGhcPrimIface ) import GHC.Iface.Make import GHC.Iface.Recomp import GHC.Iface.Tidy @@ -176,7 +177,6 @@ import GHC.Core import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Tidy ( tidyExpr ) -import GHC.Core.Type ( Type, Kind ) import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike import GHC.Core.Opt.Pipeline @@ -186,10 +186,12 @@ import GHC.Core.FamInstEnv import GHC.Core.Rules import GHC.Core.Stats -import GHC.Core.LateCC (addLateCostCentresPgm) +import GHC.Core.LateCC +import GHC.Core.LateCC.Types -import GHC.CoreToStg.Prep +import GHC.CoreToStg.Prep( CorePrepPgmConfig, corePrepPgm, corePrepExpr ) +import GHC.CoreToStg.AddImplicitBinds( addImplicitBinds ) import GHC.CoreToStg ( coreToStg ) import GHC.Parser.Errors.Types @@ -198,27 +200,28 @@ import GHC.Tc.Module import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) ) import GHC.Stg.Syntax import GHC.Stg.Pipeline ( stg2stg, StgCgInfos ) -import GHC.Builtin.Utils import GHC.Builtin.Names import qualified GHC.StgToCmm as StgToCmm ( codeGen ) 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 import GHC.Unit.Finder -import GHC.Unit.External import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface @@ -243,38 +246,37 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Name -import GHC.Types.Name.Cache ( initNameCache ) +import GHC.Types.Name.Cache ( newNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr import GHC.Types.TyThing -import GHC.Types.HpcInfo import GHC.Types.Unique.Supply (uniqFromTag) import GHC.Types.Unique.Set import GHC.Utils.Fingerprint ( Fingerprint ) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs +import GHC.Utils.Touch import qualified GHC.LanguageExtensions as LangExt 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 qualified GHC.SysTools 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 @@ -294,12 +296,15 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) -import GHC.Stg.InferTags.TagSig (seqTagSig) +import GHC.Platform.Ways +import GHC.Stg.EnforceEpt.TagSig (seqTagSig) import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Cmm.Config (CmmConfig) - +import Data.Bifunctor +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Home.PackageTable {- ********************************************************************** %* * @@ -308,25 +313,26 @@ %********************************************************************* -} newHscEnv :: FilePath -> DynFlags -> IO HscEnv -newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph +newHscEnv top_dir dflags = do + hpt <- emptyHomePackageTable + newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) where - home_unit_graph = unitEnv_singleton + home_unit_graph hpt = HUG.unitEnv_singleton (homeUnitId_ dflags) - (mkHomeUnitEnv dflags emptyHomePackageTable Nothing) + (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing) newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do - nc_var <- initNameCache 'r' knownKeyNames + nc_var <- newNameCache fc_var <- initFinderCache logger <- initLogger tmpfs <- initTmpFs - let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph + let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags) llvm_config <- initLlvmConfigCache top_dir return HscEnv { hsc_dflags = top_dynflags , hsc_logger = setLogFlags logger (initLogFlags top_dynflags) , hsc_targets = [] - , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags , hsc_NC = nc_var , hsc_FC = fc_var @@ -346,41 +352,11 @@ mySettings <- initSysTools top_dir dflags <- initDynFlags (defaultDynFlags mySettings) hsc_env <- newHscEnv top_dir dflags - checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags setUnsafeGlobalDynFlags dflags -- c.f. DynFlags.parseDynamicFlagsFull, which -- creates DynFlags and sets the UnsafeGlobalDynFlags return hsc_env --- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which --- breaks tables-next-to-code in dynamically linked modules. This --- check should be more selective but there is currently no released --- version where this bug is fixed. --- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and --- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO () -checkBrokenTablesNextToCode logger dflags = do - let invalidLdErr = "Tables-next-to-code not supported on ARM \ - \when using binutils ld (please see: \ - \https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - broken <- checkBrokenTablesNextToCode' logger dflags - when broken (panic invalidLdErr) - -checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool -checkBrokenTablesNextToCode' logger dflags - | not (isARM arch) = return False - | ways dflags `hasNotWay` WayDyn = return False - | not tablesNextToCode = return False - | otherwise = do - linkerInfo <- liftIO $ GHC.SysTools.getLinkerInfo logger dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - tablesNextToCode = platformTablesNextToCode platform - - -- ----------------------------------------------------------------------------- getDiagnostics :: Hsc (Messages GhcMessage) @@ -648,7 +624,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 @@ -672,7 +648,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 @@ -831,7 +814,6 @@ -} -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () -- | Do the recompilation avoidance checks for both one-shot and --make modes -- This function is the *only* place in the compiler where we decide whether to @@ -848,7 +830,7 @@ = do let msg what = case mHscMessage of - Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) + Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary)) Nothing -> return () -- First check to see if the interface file agrees with the @@ -863,7 +845,7 @@ case recomp_if_result of OutOfDateItem reason mb_checked_iface -> do msg $ NeedsRecompile reason - return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface + return $ HscRecompNeeded $ fmap mi_iface_hash mb_checked_iface UpToDateItem checked_iface -> do let lcl_dflags = ms_hspp_opts mod_summary if | not (backendGeneratesCode (backend lcl_dflags)) -> do @@ -881,7 +863,7 @@ , xopt LangExt.TemplateHaskell lcl_dflags -> do msg $ needsRecompileBecause THWithJS - return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface + return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface | otherwise -> do -- Do need linkable @@ -937,7 +919,7 @@ return $ HscUpToDate checked_iface $ linkable OutOfDateItem reason _ -> do msg $ NeedsRecompile reason - return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface + return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface -- | Check that the .o files produced by compilation are already up-to-date -- or not. @@ -966,7 +948,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 @@ -978,7 +960,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 @@ -987,54 +969,206 @@ let this_mod = ms_mod mod_sum if_date = fromJust $ ms_iface_date mod_sum - case mi_extra_decls iface of - Just extra_decls -> do - let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum) - return (UpToDateItem (LM if_date this_mod [CoreBindings fi])) + case iface_core_bindings iface (ms_location mod_sum) of + Just fi -> do + return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi)))) _ -> return $ outOfDateItemBecause MissingBytecode Nothing + -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- +add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> IO () +add_iface_to_hpt iface details = + hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable) -- Knot tying! See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] initModDetails :: HscEnv -> ModIface -> IO ModDetails initModDetails hsc_env iface = fixIO $ \details' -> do - let act hpt = addToHpt hpt (moduleName $ mi_module iface) - (HomeModInfo iface details' emptyHomeModInfoLinkable) - let !hsc_env' = hscUpdateHPT act hsc_env + add_iface_to_hpt iface details' hsc_env -- NB: This result is actually not that useful -- in one-shot mode, since we're not going to do -- any further typechecking. It's much more useful -- in make mode, since this HMI will go into the HPT. - genModDetails hsc_env' iface + genModDetails hsc_env iface --- 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_simplified_core <&> \(IfaceSimplifiedCore bindings foreign') -> + WholeCoreBindings { + wcb_bindings = bindings, + wcb_module = mi_module, + wcb_mod_location, + wcb_foreign = foreign' + } + where + ModIface {mi_module, mi_simplified_core} = iface + +-- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if +-- the interface contains any, using the supplied type env for typechecking. +-- +-- 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 + +loadIfaceByteCodeLazy :: + HscEnv -> + ModIface -> + ModLocation -> + TypeEnv -> + IO (Maybe Linkable) +loadIfaceByteCodeLazy hsc_env iface location type_env = + case iface_core_bindings iface location of + Nothing -> return Nothing + Just wcb -> do + Just <$> compile wcb + where + compile decls = do + ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls + linkable $ NE.singleton (LazyBCOs bcos fos) + + linkable parts = do + if_time <- modificationTimeIfExists (ml_hi_file location) + time <- maybe getCurrentTime pure if_time + return $!Linkable time (mi_module iface) parts + +-- | If the 'Linkable' contains Core bindings loaded from an interface, replace +-- them with a lazy IO thunk that compiles them to bytecode and foreign objects, +-- using the supplied environment for type checking. +-- +-- 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. + +-- TODO: We should just use loadIfaceByteCodeLazy instead of the two stage process with +-- loadByteCode and initWholeCoreBindings. The main reason it is like this is because +-- initWholeCoreBindings requires a ModDetails, which we don't have during recompilation +-- checking. We should modify recompilation checking to return a HomeModInfo directly. + +initWholeCoreBindings :: + HscEnv -> + ModIface -> + ModDetails -> + Linkable -> + IO Linkable +initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do + Linkable utc_time this_mod <$> mapM (go hsc_env) uls + where + go hsc_env' = \case + CoreBindings wcb -> do + add_iface_to_hpt iface details hsc_env + ~(bco, fos) <- unsafeInterleaveIO $ + compileWholeCoreBindings hsc_env' type_env wcb + pure (LazyBCOs bco fos) + l -> pure l + + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1107,12 +1241,17 @@ -- -- We usually desugar even when we are not generating code, otherwise we -- would miss errors thrown by the desugaring (see #10600). The only - -- exceptions are when the Module is Ghc.Prim or when it is not a - -- HsSrcFile Module. - mb_desugar <- - if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile - then Just <$> hscDesugar' (ms_location summary) tc_result - else pure Nothing + -- exception is when it is not a HsSrcFile module. + mb_desugar <- if + | hsc_src /= HsSrcFile -> pure Nothing + -- Desugar an empty ghc-prim:GHC.Prim module by filtering out all its + -- bindings: the reason is that some of them are invalid (such as top-level + -- unlifted ones like void# or proxy#) and cause HsToCore failures. + -- + -- We still need to desugar *something* because the driver and the linkers + -- expect a valid object file (.o) to be generated for this module. + | ms_mod summary == gHC_PRIM -> Just <$> hscDesugar' (ms_location summary) (tc_result { tcg_binds = [] }) + | otherwise -> Just <$> hscDesugar' (ms_location summary) tc_result -- Report the warnings from both typechecking and desugar together w <- getDiagnostics @@ -1130,11 +1269,11 @@ (cg_guts, details) <- liftIO $ hscTidy hsc_env simplified_guts - let !partial_iface = + !partial_iface <- liftIO $ {-# SCC "GHC.Driver.Main.mkPartialIface" #-} -- This `force` saves 2M residency in test T10370 -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env (cg_binds cg_guts) details summary simplified_guts) + fmap force (mkPartialIface hsc_env (cg_binds cg_guts) details summary (tcg_import_decls tc_result) simplified_guts) return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary, @@ -1157,7 +1296,11 @@ liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) - return $ HscUpdate iface + -- when compiling gHC_PRIM without generating code (e.g. with + -- Haddock), we still want the virtual interface in the cache + if ms_mod summary == gHC_PRIM + then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env)) + else return $ HscUpdate iface -- We are not generating code or writing an interface with simplified core so we can skip simplification @@ -1168,7 +1311,11 @@ liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) - return $ HscUpdate iface + -- when compiling gHC_PRIM without generating code (e.g. with + -- Haddock), we still want the virtual interface in the cache + if ms_mod summary == gHC_PRIM + then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env)) + else return $ HscUpdate iface {- Note [Writing interface files] @@ -1238,7 +1385,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 @@ -1255,7 +1402,7 @@ -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic -- interfaces stay in sync... -- - let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface)) + let change = old_iface /= Just (mi_iface_hash iface) let dt = dynamicTooState dflags @@ -1294,7 +1441,7 @@ -- .hie files. let hie_file = ml_hie_file mod_location whenM (doesFileExist hie_file) $ - GHC.SysTools.touch logger dflags "Touching hie file" hie_file + GHC.Utils.Touch.touch hie_file else -- See Note [Strictness in ModIface] forceModIface iface @@ -1328,46 +1475,7 @@ dumpIfaceStats hsc_env return new_details --------------------------------------------------------------- --- Progress displayers. --------------------------------------------------------------- -oneShotMsg :: Logger -> RecompileRequired -> IO () -oneShotMsg logger recomp = - case recomp of - UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" - NeedsRecompile _ -> return () - -batchMsg :: Messager -batchMsg = batchMsgWith (\_ _ _ _ -> empty) -batchMultiMsg :: Messager -batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node))) - -batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager -batchMsgWith extra hsc_env_start mod_index recomp node = - case recomp of - UpToDate - | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty - | otherwise -> return () - NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of - MustCompile -> empty - (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" - where - herald = case node of - LinkNode {} -> "Linking" - InstantiationNode {} -> "Instantiating" - ModuleNode {} -> "Compiling" - hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - state = hsc_units hsc_env - showMsg msg reason = - compilationProgressMsg logger $ - (showModuleIndex mod_index <> - msg <+> showModMsg dflags (recompileRequired recomp) node) - <> extra hsc_env mod_index recomp node - <> reason - -------------------------------------------------------------- -- Safe Haskell -------------------------------------------------------------- @@ -1511,7 +1619,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] @@ -1654,10 +1762,7 @@ lookup' :: Module -> Hsc (Maybe ModIface) lookup' m = do hsc_env <- getHscEnv - hsc_eps <- liftIO $ hscEPS hsc_env - let pkgIfaceT = eps_PIT hsc_eps - hug = hsc_HUG hsc_env - iface = lookupIfaceByModule hug pkgIfaceT m + iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m -- the 'lookupIfaceByModule' method will always fail when calling from GHCi -- as the compiler hasn't filled in the various module tables -- so we need to call 'getModuleInterface' to load from disk @@ -1812,54 +1917,102 @@ hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos ) -- ^ @Just f@ <=> _stub.c is f -hscGenHardCode hsc_env cgguts location output_filename = do - let CgGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cg_module = this_mod, +hscGenHardCode hsc_env cgguts mod_loc output_filename = do + let CgGuts{ cg_module = this_mod, cg_binds = core_binds, - cg_ccs = local_ccs, - cg_tycons = tycons, - cg_foreign = foreign_stubs0, - cg_foreign_files = foreign_files, - cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info, - cg_spt_entries = spt_entries + cg_ccs = local_ccs } = cgguts dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - llvm_config = hsc_llvm_config hsc_env - profile = targetProfile dflags - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes ------------------- - -- Insert late cost centres if enabled. - -- If `-fprof-late-inline` is enabled we can skip this, as it will have added - -- a superset of cost centres we would add here already. + -- ADD IMPLICIT BINDINGS + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + let cp_pgm_cfg :: CorePrepPgmConfig + cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env) + (interactiveInScope $ hsc_IC hsc_env) + binds_with_implicits <- addImplicitBinds cp_pgm_cfg mod_loc (cg_tycons cgguts) core_binds - (late_cc_binds, late_local_ccs) <- - if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags) - then {-# SCC lateCC #-} do - (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds - return ( binds, (S.toList late_ccs `mappend` local_ccs )) + ------------------- + -- INSERT LATE COST CENTRES, based on the provided flags. + -- + -- If -fprof-late-inline is enabled, we will skip adding CCs on any + -- top-level bindings here (via shortcut in `addLateCostCenters`), since + -- it will have already added a superset of the CCs we would add here. + let + late_cc_config :: LateCCConfig + late_cc_config = + LateCCConfig + { lateCCConfig_whichBinds = + if gopt Opt_ProfLateInlineCcs dflags then + LateCCNone + else if gopt Opt_ProfLateCcs dflags then + LateCCBinds + else if gopt Opt_ProfLateOverloadedCcs dflags then + LateCCOverloadedBinds else - return (core_binds, local_ccs) + LateCCNone + , lateCCConfig_overloadedCalls = + gopt Opt_ProfLateoverloadedCallsCCs dflags + , lateCCConfig_env = + LateCCEnv + { lateCCEnv_module = this_mod + , lateCCEnv_file = fsLit <$> ml_hs_file mod_loc + , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags + , lateCCEnv_collectCCs = True + } + } + (late_cc_binds, late_cc_state) <- + addLateCostCenters logger late_cc_config binds_with_implicits + when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $ + putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds)) ------------------- + -- RUN LATE PLUGINS + -- This is the last use of the CgGuts in a compilation. + -- From now on, we just use the bits we need. + ( CgGuts + { cg_tycons = tycons, + cg_foreign = foreign_stubs0, + cg_foreign_files = foreign_files, + cg_dep_pkgs = dependencies, + cg_spt_entries = spt_entries, + cg_binds = binds_to_prep, + cg_ccs = late_local_ccs + } + , _ + ) <- + {-# SCC latePlugins #-} + withTiming + logger + (text "LatePlugins"<+>brackets (ppr this_mod)) + (const ()) $ + withPlugins (hsc_plugins hsc_env) + (($ hsc_env) . latePlugin) + ( cgguts + { cg_binds = late_cc_binds + , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs + } + , lateCCState_ccState late_cc_state + ) + + let + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + llvm_config = hsc_llvm_config hsc_env + profile = targetProfile dflags + + ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - (prepd_binds) <- {-# SCC "CorePrep" #-} do - cp_cfg <- initCorePrepConfig hsc_env - corePrepPgm - (hsc_logger hsc_env) - cp_cfg - (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location late_cc_binds data_tycons + cp_cfg <- initCorePrepConfig hsc_env + (prepd_binds) <- {-# SCC "CorePrep" #-} + corePrepPgm + (hsc_logger hsc_env) cp_cfg cp_pgm_cfg + this_mod binds_to_prep ----------------- Convert to STG ------------------ (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) @@ -1872,7 +2025,7 @@ c `seqList` d `seqList` (seqEltsUFM (seqTagSig) tag_env)) - (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod location prepd_binds) + (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod mod_loc prepd_binds) let (stg_binds,_stg_deps) = unzip stg_binds_with_deps @@ -1920,9 +2073,9 @@ _ -> do cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod denv data_tycons + doCodeGen hsc_env this_mod denv tycons cost_centre_info - stg_binds hpc_info + stg_binds ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} @@ -1933,7 +2086,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 @@ -1941,8 +2094,8 @@ (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 + codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc + foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1 return ( output_filename, stub_c_exists, foreign_fps , Just stg_cg_infos, Just cmm_cg_infos) @@ -1952,19 +2105,20 @@ , 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]) -hscInteractive hsc_env cgguts location = do + -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode +hscInteractive hsc_env cgguts mod_loc = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env @@ -1977,51 +2131,50 @@ cgi_modBreaks = mod_breaks, cgi_spt_entries = spt_entries } = cgguts - data_tycons = filter isDataTyCon tycons - -- cg_tycons includes newtypes, for the benefit of External Core, - -- but we don't generate any code for newtypes + ------------------- + -- ADD IMPLICIT BINDINGS + let cp_pgm_cfg :: CorePrepPgmConfig + cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env) + (interactiveInScope $ hsc_IC hsc_env) + binds_to_prep <- addImplicitBinds cp_pgm_cfg mod_loc tycons core_binds ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} do - cp_cfg <- initCorePrepConfig hsc_env - corePrepPgm - (hsc_logger hsc_env) - cp_cfg - (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) - this_mod location core_binds data_tycons + cp_cfg <- initCorePrepConfig hsc_env + prepd_binds <- {-# SCC "CorePrep" #-} + corePrepPgm (hsc_logger hsc_env) cp_cfg cp_pgm_cfg + this_mod binds_to_prep -- The stg cg info only provides a runtime benfit, but is not requires so we just -- omit it here (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos) <- {-# SCC "CoreToStg" #-} - myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod location prepd_binds + myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod mod_loc prepd_binds let (stg_binds,_stg_deps) = unzip stg_binds_with_deps ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks + comp_bc <- byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries + ------------------ Create f-x-dynamic C-side stuff ----- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs - return (istub_c_exists, comp_bc, spt_entries) + <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod mod_loc foreign_stubs + return (istub_c_exists, comp_bc) +-- | Compile Core bindings and foreign inputs that were loaded from an +-- 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 @@ -2029,10 +2182,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) @@ -2052,12 +2207,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) @@ -2067,17 +2224,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 @@ -2085,15 +2249,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 --------------------- @@ -2117,13 +2282,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 +doCodeGen hsc_env this_mod denv tycons + cost_centre_info stg_binds_w_fvs = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env @@ -2134,14 +2298,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 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 @@ -2154,17 +2318,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 @@ -2172,16 +2346,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) @@ -2192,7 +2366,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 @@ -2282,12 +2456,6 @@ return $ Just (ids, hval, fix_env) --- | Compile a decls -hscDecls :: HscEnv - -> String -- ^ The statement - -> IO ([TyThing], InteractiveContext) -hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "" 1 - hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs) hscParseModuleWithLocation hsc_env source line_num str = do L _ mod <- @@ -2300,18 +2468,6 @@ HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str return decls --- | Compile a decls -hscDeclsWithLocation :: HscEnv - -> String -- ^ The statement - -> String -- ^ The source - -> Int -- ^ Starting line - -> IO ([TyThing], InteractiveContext) -hscDeclsWithLocation hsc_env str source linenumber = do - L _ (HsModule{ hsmodDecls = decls }) <- - runInteractiveHsc hsc_env $ - hscParseThingWithLocation source linenumber parseModule str - hscParsedDecls hsc_env decls - hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do hsc_env <- getHscEnv @@ -2328,12 +2484,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 -} @@ -2345,44 +2502,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) @@ -2612,12 +2746,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 @@ -2655,13 +2790,16 @@ 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) + return (expectJust $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) @@ -2714,10 +2852,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. @@ -2746,7 +2883,7 @@ jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots -- look up "id_sym" closure and create a StablePtr (HValue) from it - href <- lookupClosure interp (unpackFS id_sym) >>= \case + href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym) Just r -> pure r @@ -2773,18 +2910,6 @@ logDumpMsg logger "Interface statistics" (ifaceStats eps) -{- ********************************************************************** -%* * - Progress Messages: Module i of n -%* * -%********************************************************************* -} - -showModuleIndex :: (Int, Int) -> SDoc -showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " - where - -- compute the length of x > 0 in base 10 - len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) - pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags = diff --git a/GHC/Driver/Main.hs-boot b/GHC/Driver/Main.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Driver/Main.hs-boot @@ -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) diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -1,3046 +1,1935 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} - --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 2011 --- --- This module implements multi-module compilation, and is used --- by --make and GHCi. --- --- ----------------------------------------------------------------------------- -module GHC.Driver.Make ( - depanal, depanalE, depanalPartial, checkHomeUnitsClosed, - load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, - instantiationNodes, - - downsweep, - - topSortModuleGraph, - - ms_home_srcimps, ms_home_imps, - - summariseModule, - SummariseResult(..), - summariseFile, - hscSourceToIsBoot, - findExtraSigImports, - implicitRequirementsShallow, - - noModError, cyclicModuleErr, - SummaryNode, - IsBootInterface(..), mkNodeKey, - - ModNodeKey, ModNodeKeyWithUid(..), - ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith - ) where - -import GHC.Prelude -import GHC.Platform - -import GHC.Tc.Utils.Backpack -import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) - -import GHC.Runtime.Interpreter -import qualified GHC.Linker.Loader as Linker -import GHC.Linker.Types - -import GHC.Platform.Ways - -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Phases -import GHC.Driver.Pipeline -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Monad -import GHC.Driver.Env -import GHC.Driver.Errors -import GHC.Driver.Errors.Types -import GHC.Driver.Main -import GHC.Driver.MakeSem - -import GHC.Parser.Header - -import GHC.Iface.Load ( cannotFindModule ) -import GHC.IfaceToCore ( typecheckIface ) -import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) - -import GHC.Data.Bag ( listToBag ) -import GHC.Data.Graph.Directed -import GHC.Data.FastString -import GHC.Data.Maybe ( expectJust ) -import GHC.Data.StringBuffer -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Utils.Exception ( throwIO, SomeAsyncException ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc -import GHC.Utils.Error -import GHC.Utils.Logger -import GHC.Utils.Fingerprint -import GHC.Utils.TmpFs - -import GHC.Types.Basic -import GHC.Types.Error -import GHC.Types.Target -import GHC.Types.SourceFile -import GHC.Types.SourceError -import GHC.Types.SrcLoc -import GHC.Types.Unique.Map -import GHC.Types.PkgQual - -import GHC.Unit -import GHC.Unit.Env -import GHC.Unit.Finder -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Graph -import GHC.Unit.Home.ModInfo -import GHC.Unit.Module.ModDetails - -import Data.Either ( rights, partitionEithers, lefts ) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) -import qualified GHC.Conc as CC -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) -import qualified Control.Monad.Catch as MC -import Data.IORef -import Data.Maybe -import Data.Time -import Data.List (sortOn) -import Data.Bifunctor (first) -import System.Directory -import System.FilePath -import System.IO ( fixIO ) - -import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import GHC.Driver.Pipeline.LogQueue -import qualified Data.Map.Strict as M -import GHC.Types.TypeEnv -import Control.Monad.Trans.State.Lazy -import Control.Monad.Trans.Class -import GHC.Driver.Env.KnotVars -import Control.Concurrent.STM -import Control.Monad.Trans.Maybe -import GHC.Runtime.Loader -import GHC.Rename.Names -import GHC.Utils.Constants -import GHC.Types.Unique.DFM (udfmRestrictKeysSet) -import GHC.Types.Unique -import GHC.Iface.Errors.Types - -import qualified GHC.Data.Word64Set as W - --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- In case of errors, just throw them. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots - if isEmptyMessages errs - then pure mod_graph - else throwErrors (fmap GhcDriverMessage errs) - --- | Perform dependency analysis like in 'depanal'. --- In case of errors, the errors and an empty module graph are returned. -depanalE :: GhcMonad m => -- New for #17459 - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m (DriverMessages, ModuleGraph) -depanalE excluded_mods allow_dup_roots = do - hsc_env <- getSession - (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots - if isEmptyMessages errs - then do - hsc_env <- getSession - let one_unit_messages get_mod_errs k hue = do - errs <- get_mod_errs - unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph - - let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph - unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph - - - return $ errs `unionMessages` unused_home_mod_err - `unionMessages` unused_pkg_err - `unionMessages` unknown_module_err - - all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) - logDiagnostics (GhcDriverMessage <$> all_errs) - setSession hsc_env { hsc_mod_graph = mod_graph } - pure (emptyMessages, mod_graph) - else do - -- We don't have a complete module dependency graph, - -- The graph may be disconnected and is unusable. - setSession hsc_env { hsc_mod_graph = emptyMG } - pure (errs, emptyMG) - - --- | Perform dependency analysis like 'depanal' but return a partial module --- graph even in the face of problems with some modules. --- --- Modules which have parse errors in the module header, failing --- preprocessors or other issues preventing them from being summarised will --- simply be absent from the returned module graph. --- --- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the --- new module graph. -depanalPartial - :: GhcMonad m - => [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m (DriverMessages, ModuleGraph) - -- ^ possibly empty 'Bag' of errors and a module graph. -depanalPartial excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - logger = hsc_logger hsc_env - - withTiming logger (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg logger 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - -- Home package modules may have been moved or deleted, and new - -- source files may have appeared in the home package that shadow - -- external package modules, so we have to discard the existing - -- cached finder data. - liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) - - (errs, graph_nodes) <- liftIO $ downsweep - hsc_env (mgModSummaries old_graph) - excluded_mods allow_dup_roots - let - mod_graph = mkModuleGraph graph_nodes - return (unionManyMessages errs, mod_graph) - --- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. --- These are used to represent the type checking that is done after --- all the free holes (sigs in current package) relevant to that instantiation --- are compiled. This is necessary to catch some instantiation errors. --- --- In the future, perhaps more of the work of instantiation could be moved here, --- instead of shoved in with the module compilation nodes. That could simplify --- backpack, and maybe hs-boot too. -instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode] -instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check - where - iuids_to_check :: [InstantiatedUnit] - iuids_to_check = - nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state) - where - goUnitId uid = - [ recur - | VirtUnit indef <- [uid] - , inst <- instUnitInsts indef - , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst - ] - --- The linking plan for each module. If we need to do linking for a home unit --- then this function returns a graph node which depends on all the modules in the home unit. - --- At the moment nothing can depend on these LinkNodes. -linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode) -linkNodes summaries uid hue = - let dflags = homeUnitEnv_dflags hue - ofile = outputFile_ dflags - - unit_nodes :: [NodeKey] - unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries) - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - no_hs_main = gopt Opt_NoHsMain dflags - - main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes - - do_linking = main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib - - in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking -> - Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) - -- This should be an error, not a warning (#10895). - | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) - | otherwise -> Nothing - --- Note [Missing home modules] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Sometimes we don't want GHC to process modules that weren't specified as --- explicit targets. For example, cabal may want to enable this warning --- when building a library, so that GHC warns the user about modules listed --- neither in `exposed-modules` nor in `other-modules`. --- --- Here "home module" means a module that doesn't come from another package. --- --- For example, if GHC is invoked with modules "A" and "B" as targets, --- but "A" imports some other module "C", then GHC will issue a warning --- about module "C" not being listed in the command line. --- --- The warning in enabled by `-Wmissing-home-modules`. See #13129 -warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages -warnMissingHomeModules dflags targets mod_graph = - if null missing - then emptyMessages - else warn - where - diag_opts = initDiagOpts dflags - - -- We need to be careful to handle the case where (possibly - -- path-qualified) filenames (aka 'TargetFile') rather than module - -- names are being passed on the GHC command-line. - -- - -- For instance, `ghc --make src-exe/Main.hs` and - -- `ghc --make -isrc-exe Main` are supposed to be equivalent. - -- Note also that we can't always infer the associated module name - -- directly from the filename argument. See #13727. - is_known_module mod = - is_module_target mod - || - maybe False is_file_target (ml_hs_file (ms_location mod)) - - is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets - - is_file_target file = Set.member (withoutExt file) file_targets - - file_targets = Set.fromList (mapMaybe file_target targets) - - file_target Target {targetId} = - case targetId of - TargetModule _ -> Nothing - TargetFile file _ -> - Just (withoutExt (augmentByWorkingDirectory dflags file)) - - mod_targets = Set.fromList (mod_target <$> targets) - - mod_target Target {targetUnitId, targetId} = - case targetId of - TargetModule name -> (name, targetUnitId) - TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId) - - withoutExt = fst . splitExtension - - missing = map (moduleName . ms_mod) $ - filter (not . is_known_module) $ - (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) - (mgModSummaries mod_graph)) - - warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan - $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags) - --- Check that any modules we want to reexport or hide are actually in the package. -warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages -warnUnknownModules hsc_env dflags mod_graph = do - reexported_warns <- filterM check_reexport (Set.toList reexported_mods) - return $ final_msgs hidden_warns reexported_warns - where - diag_opts = initDiagOpts dflags - - unit_mods = Set.fromList (map ms_mod_name - (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) - (mgModSummaries mod_graph))) - - reexported_mods = reexportedModules dflags - hidden_mods = hiddenModules dflags - - hidden_warns = hidden_mods `Set.difference` unit_mods - - lookupModule mn = findImportedModule hsc_env mn NoPkgQual - - check_reexport mn = do - fr <- lookupModule mn - case fr of - Found _ m -> return (moduleUnitId m == homeUnitId_ dflags) - _ -> return True - - - warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan - $ diagnostic - - final_msgs hidden_warns reexported_warns - = - unionManyMessages $ - [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)] - ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)] - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo HomeUnitModule - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf HomeUnitModule - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - -{- -Note [Caching HomeModInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -API clients who call `load` like to cache the HomeModInfo in memory between -calls to this function. In the old days, this cache was a simple MVar which stored -a HomePackageTable. This was insufficient, as the interface files for boot modules -were not recorded in the cache. In the less old days, the cache was returned at the -end of load, and supplied at the start of load, however, this was not sufficient -because it didn't account for the possibility of exceptions such as SIGINT (#20780). - -So now, in the current day, we have this ModIfaceCache abstraction which -can incrementally be updated during the process of upsweep. This allows us -to store interface files for boot modules in an exception-safe way. - -When the final version of an interface file is completed then it is placed into -the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache. - -Note that because we only store the ModIface and Linkable in the ModIfaceCache, -hydration and rehydration is totally irrelevant, and we just store the CachedIface as -soon as it is completed. - --} - - --- Abstract interface to a cache of HomeModInfo --- See Note [Caching HomeModInfo] -data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface] - , iface_addToCache :: CachedIface -> IO () } - -addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO () -addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l) - -data CachedIface = CachedIface { cached_modiface :: !ModIface - , cached_linkable :: !HomeModLinkable } - -instance Outputable CachedIface where - ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln] - -noIfaceCache :: Maybe ModIfaceCache -noIfaceCache = Nothing - -newIfaceCache :: IO ModIfaceCache -newIfaceCache = do - ioref <- newIORef [] - return $ - ModIfaceCache - { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c)) - , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ())) - } - - - - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the backend (see 'DynFlags.backend' field) compiling --- and loading may result in files being created on disk. --- --- Calls the 'defaultWarnErrLogger' after each compiling each module, whether --- successful or not. --- --- If errors are encountered during dependency analysis, the module `depanalE` --- returns together with the errors an empty ModuleGraph. --- After processing this empty ModuleGraph, the errors of depanalE are thrown. --- All other errors are reported using the 'defaultWarnErrLogger'. - -load :: GhcMonad f => LoadHowMuch -> f SuccessFlag -load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much - -mkBatchMsg :: HscEnv -> Messager -mkBatchMsg hsc_env = - if length (hsc_all_home_unit_ids hsc_env) > 1 - -- This also displays what unit each module is from. - then batchMultiMsg - else batchMsg - -type AnyGhcDiagnostic = UnknownDiagnostic (DiagnosticOpts GhcMessage) - -loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them. - -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user. - -- If you are using the GHC API you can use this to override how messages - -- created during 'loadWithCache' are displayed to the user. - -> LoadHowMuch -- ^ How much `loadWithCache` should load - -> m SuccessFlag -loadWithCache cache diag_wrapper how_much = do - (errs, mod_graph) <- depanalE [] False -- #17459 - msg <- mkBatchMsg <$> getSession - success <- load' cache how_much diag_wrapper (Just msg) mod_graph - if isEmptyMessages errs - then pure success - else throwErrors (fmap GhcDriverMessage errs) - --- Note [Unused packages] --- ~~~~~~~~~~~~~~~~~~~~~~ --- Cabal passes `--package-id` flag for each direct dependency. But GHC --- loads them lazily, so when compilation is done, we have a list of all --- actually loaded packages. All the packages, specified on command line, --- but never loaded, are probably unused dependencies. - -warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages -warnUnusedPackages us dflags mod_graph = - let diag_opts = initDiagOpts dflags - - home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph) - - -- Only need non-source imports here because SOURCE imports are always HPT - loadedPackages = concat $ - mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs) - $ concatMap ms_imps home_mod_sum - - any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum - - used_args = Set.fromList (map unitId loadedPackages) - `Set.union` Set.fromList [ primUnitId | any_import_ghc_prim ] - - resolve (u,mflag) = do - -- The units which we depend on via the command line explicitly - flag <- mflag - -- Which we can find the UnitInfo for (should be all of them) - ui <- lookupUnit us u - -- Which are not explicitly used - guard (Set.notMember (unitId ui) used_args) - return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag) - - unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us) - - warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs) - - in if null unusedArgs - then emptyMessages - else warn - --- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any --- path from module to its boot file. -data ModuleGraphNodeWithBootFile - = ModuleGraphNodeWithBootFile - ModuleGraphNode - -- ^ The module itself (not the hs-boot module) - [NodeKey] - -- ^ The modules in between the module and its hs-boot file, - -- not including the hs-boot file itself. - - -instance Outputable ModuleGraphNodeWithBootFile where - ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps - --- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected --- component of the module graph. -data BuildPlan - -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle) - = SingleModule ModuleGraphNode - -- | A resolved cycle, linearised by hs-boot files - | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] - -- | An actual cycle, which wasn't resolved by hs-boot files - | UnresolvedCycle [ModuleGraphNode] - -instance Outputable BuildPlan where - ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn) - ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn - ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn - - --- Just used for an assertion -countMods :: BuildPlan -> Int -countMods (SingleModule _) = 1 -countMods (ResolvedCycle ns) = length ns -countMods (UnresolvedCycle ns) = length ns - --- See Note [Upsweep] for a high-level description. -createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] -createBuildPlan mod_graph maybe_top_mod = - let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod - - -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. - build_plan :: [BuildPlan] - build_plan - -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod - | otherwise = toBuildPlan cycle_mod_graph [] - - toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] - toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn) - toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn) - -- Interesting case - toBuildPlan ((CyclicSCC nodes):sccs) mgn = - let acyclic = collapseAcyclic (topSortWithBoot mgn) - -- Now perform another toposort but just with these nodes and relevant hs-boot files. - -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. - mresolved_cycle = collapseSCC (topSortWithBoot nodes) - in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] - - (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) - trans_deps_map = allReachable mg (mkNodeKey . node_payload) - -- Compute the intermediate modules between a file and its hs-boot file. - -- See Step 2a in Note [Upsweep] - boot_path mn uid = - map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $ - -- Don't include the boot module itself - Set.delete (NodeKey_Module (key IsBoot)) $ - -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are - -- the transitive dependencies of the non-boot file which transitively depend - -- on the boot file. - Set.filter (\nk -> nodeKeyUnitId nk == uid -- Cheap test - && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $ - expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map) - where - key ib = ModNodeKeyWithUid (GWIB mn ib) uid - - - -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists - boot_modules = mkModuleEnv - [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot] - - select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode] - select_boot_modules = mapMaybe (fmap fst . get_boot_module) - - get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]) - get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing - - -- Any cycles should be resolved now - collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] - -- Must be at least two nodes, as we were in a cycle - collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] - collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes) - -- Cyclic - collapseSCC nodes = Left (flattenSCCs nodes) - - toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile - toNodeWithBoot mn = - case get_boot_module mn of - -- The node doesn't have a boot file - Nothing -> Left mn - -- The node does have a boot file - Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path))) - - -- The toposort and accumulation of acyclic modules is solely to pick-up - -- hs-boot files which are **not** part of cycles. - collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan] - collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes - collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes - collapseAcyclic [] = [] - - topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing - - - in - - assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph)) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))]) - build_plan - -mkWorkerLimit :: DynFlags -> IO WorkerLimit -mkWorkerLimit dflags = - case parMakeCount dflags of - Nothing -> pure $ num_procs 1 - Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h)) - Just ParMakeNumProcessors -> num_procs <$> getNumProcessors - Just (ParMakeThisMany n) -> pure $ num_procs n - where - num_procs x = NumProcessorsLimit (max 1 x) - -isWorkerLimitSequential :: WorkerLimit -> Bool -isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1 -isWorkerLimitSequential (JSemLimit {}) = False - --- | This describes what we use to limit the number of jobs, either we limit it --- ourselves to a specific number or we have an external parallelism semaphore --- limit it for us. -data WorkerLimit - = NumProcessorsLimit Int - | JSemLimit - SemaphoreName - -- ^ Semaphore name to use - deriving Eq - --- | Generalized version of 'load' which also supports a custom --- 'Messager' (for reporting progress) and 'ModuleGraph' (generally --- produced by calling 'depanal'. -load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do - -- In normal usage plugins are initialised already by ghc/Main.hs this is protective - -- for any client who might interact with GHC via load'. - -- See Note [Timing of plugin initialization] - initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } - guessOutputFile - hsc_env <- getSession - - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let interp = hscInterp hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = - Set.fromList [ Module (ms_unitid s) (ms_mod_name s) - | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot] - -- TODO: Figure out what the correct form of this assert is. It's violated - -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot - -- files without corresponding hs files. - -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - -- not (ms_mod_name s `elem` all_home_mods)] - -- assert (null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `Set.member` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg logger - (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m))) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. It is just used for warning about unecessary source imports. - let mg2_with_srcimps :: [SCC ModuleGraphNode] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps) - - let maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - build_plan = createBuildPlan mod_graph maybe_top_mod - - - cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache - let - -- prune the HPT so everything is not retained when doing an - -- upsweep. - !pruned_cache = pruneCache cache - (flattenSCCs (filterToposortToModules mg2_with_srcimps)) - - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write an empty HPT to allow the old HPT to be GC'd. - - let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } - setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env - hsc_env <- getSession - - -- Unload everything - liftIO $ unload interp hsc_env - - liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep") - 2 (ppr build_plan)) - - worker_limit <- liftIO $ mkWorkerLimit dflags - - (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do - hsc_env <- getSession - liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan - modifySession (addDepsToHscEnv new_deps) - case upsweep_ok of - Failed -> loadFinish upsweep_ok - Succeeded -> do - liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") - loadFinish upsweep_ok - - - --- | Finish up after a load. -loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok - = do modifySession discardIC - return all_ok - - --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - -- Force mod_graph to avoid leaking env - let !mod_graph = hsc_mod_graph env - new_home_graph = - flip unitEnv_map (hsc_HUG env) $ \hue -> - let dflags = homeUnitEnv_dflags hue - platform = targetPlatform dflags - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - ms <- mgLookupModule mod_graph (mainModIs hue) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - - -- MP: This exception is quite sensitive to being forced, if you - -- force it here then the error message is different because it gets - -- caught by a different error handler than the test (T9930fail) expects. - -- Putting an exception into DynFlags is probably not a great design but - -- I'll write this comment rather than more eagerly force the exception. - name_exe = do - -- we must add the .exe extension unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 - !name' <- case platformArchOS platform of - ArchOS _ OSMinGW32 -> fmap (<.> "exe") name - ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name - _ -> name - mainModuleSrcPath' <- mainModuleSrcPath - -- #9930: don't clobber input files (unless they ask for it) - if name' == mainModuleSrcPath' - then throwGhcException . UsageError $ - "default output name would overwrite the input file; " ++ - "must specify -o explicitly" - else Just name' - in - case outputFile_ dflags of - Just _ -> hue - Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } } - in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } } - --- ----------------------------------------------------------------------------- --- --- | Prune the HomePackageTable --- --- Before doing an upsweep, we can throw away: --- --- - all ModDetails, all linked code --- - all unlinked code that is out of date with respect to --- the source file --- --- This is VERY IMPORTANT otherwise we'll end up requiring 2x the --- space at the end of the upsweep, because the topmost ModDetails of the --- old HPT holds on to the entire type environment from the previous --- compilation. --- Note [GHC Heap Invariants] -pruneCache :: [CachedIface] - -> [ModSummary] - -> [HomeModInfo] -pruneCache hpt summ - = strictMap prune hpt - where prune (CachedIface { cached_modiface = iface - , cached_linkable = linkable - }) = HomeModInfo iface emptyModDetails linkable' - where - modl = miKey iface - linkable' - | Just ms <- M.lookup modl ms_map - , mi_src_hash iface /= ms_hs_hash ms - = emptyHomeModInfoLinkable - | otherwise - = linkable - - -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error. - ms_map = M.fromListWith - (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2)) - ms2) - [(msKey ms, ms) | ms <- summ] - --- --------------------------------------------------------------------------- --- --- | Unloading -unload :: Interp -> HscEnv -> IO () -unload interp hsc_env - = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload interp hsc_env [] - _other -> return () - - -{- Parallel Upsweep - -The parallel upsweep attempts to concurrently compile the modules in the -compilation graph using multiple Haskell threads. - -The Algorithm - -* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is -a pair of an `IO a` action and a `MVar a`, where to place the result. - The list is sorted topologically, so can be executed in order without fear of - blocking. -* runPipelines takes this list and eventually passes it to runLoop which executes - each action and places the result into the right MVar. -* The amount of parallelism is controlled by a semaphore. This is just used around the - module compilation step, so that only the right number of modules are compiled at - the same time which reduces overall memory usage and allocations. -* Each proper node has a LogQueue, which dictates where to send it's output. -* The LogQueue is placed into the LogQueueQueue when the action starts and a worker - thread processes the LogQueueQueue printing logs for each module in a stable order. -* The result variable for an action producing `a` is of type `Maybe a`, therefore - it is still filled on a failure. If a module fails to compile, the - failure is propagated through the whole module graph and any modules which didn't - depend on the failure can still be compiled. This behaviour also makes the code - quite a bit cleaner. --} - - -{- - -Note [--make mode] -~~~~~~~~~~~~~~~~~ -There are two main parts to `--make` mode. - -1. `downsweep`: Starts from the top of the module graph and computes dependencies. -2. `upsweep`: Starts from the bottom of the module graph and compiles modules. - -The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which -computers how to build this ModuleGraph. - -Note [Upsweep] -~~~~~~~~~~~~~~ -Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes -the plan in order to compile the project. - -The first step is computing the build plan from a 'ModuleGraph'. - -The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for -how to build all the modules. - -``` -data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle - | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot] -- A resolved cycle, linearised by hs-boot files - | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files -``` - -The plan is computed in two steps: - -Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains - cycles. -Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should - result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle. -Step 2a: For each module in the cycle, if the module has a boot file then compute the - modules on the path between it and the hs-boot file. - These are the intermediate modules which: - (1) are (transitive) dependencies of the non-boot module, and - (2) have the boot module as a (transitive) dependency. - In particular, all such intermediate modules must appear in the same unit as - the module under consideration, as module cycles cannot cross unit boundaries. - This information is stored in ModuleGraphNodeWithBoot. - -The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function. - -* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions. -* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented - with a consistent knot-tied version of modules at the end. - - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration - is performed both before and after the module in question is compiled. - See Note [Hydrating Modules] for more information. -* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files - and are reported as an error to the user. - -The main trickiness of `interpretBuildPlan` is deciding which version of a dependency -is visible from each module. For modules which are not in a cycle, there is just -one version of a module, so that is always used. For modules in a cycle, there are two versions of -'HomeModInfo'. - -1. Internal to loop: The version created whilst compiling the loop by upsweep_mod. -2. External to loop: The knot-tied version created by typecheckLoop. - -Whilst compiling a module inside the loop, we need to use the (1). For a module which -is outside of the loop which depends on something from in the loop, the (2) version -is used. - -As the plan is interpreted, which version of a HomeModInfo is visible is updated -by updating a map held in a state monad. So after a loop has finished being compiled, -the visible module is the one created by typecheckLoop and the internal version is not -used again. - -This plan also ensures the most important invariant to do with module loops: - -> If you depend on anything within a module loop, before you can use the dependency, - the whole loop has to finish compiling. - -The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs -of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running -the action. This list is topologically sorted, so can be run in order to compute -the whole graph. - -As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which -can be queried at the end to get the result of all modules at the end, with their proper -visibility. For example, if any module in a loop fails then all modules in that loop will -report as failed because the visible node at the end will be the result of checking -these modules together. - --} - --- | Simple wrapper around MVar which allows a functor instance. -data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a)) - -deriving instance Functor ResultVar - -mkResultVar :: MVar (Maybe a) -> ResultVar a -mkResultVar = ResultVar id - --- | Block until the result is ready. -waitResult :: ResultVar a -> MaybeT IO a -waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var) - -data BuildResult = BuildResult { _resultOrigin :: ResultOrigin - , resultVar :: ResultVar (Maybe HomeModInfo, ModuleNameSet) - } - --- The origin of this result var, useful for debugging -data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show) - -data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show) - -mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult -mkBuildResult = BuildResult - - -data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult - -- The current way to build a specific TNodeKey, without cycles this just points to - -- the appropriate result of compiling a module but with - -- cycles there can be additional indirection and can point to the result of typechecking a loop - , nNODE :: Int - , hug_var :: MVar HomeUnitGraph - -- A global variable which is incrementally updated with the result - -- of compiling modules. - } - -nodeId :: BuildM Int -nodeId = do - n <- gets nNODE - modify (\m -> m { nNODE = n + 1 }) - return n - - -setModulePipeline :: NodeKey -> BuildResult -> BuildM () -setModulePipeline mgn build_result = do - modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) }) - -type BuildMap = M.Map NodeKey BuildResult - -getBuildMap :: BuildM BuildMap -getBuildMap = gets buildDep - -getDependencies :: [NodeKey] -> BuildMap -> [BuildResult] -getDependencies direct_deps build_map = - strictMap (expectJust "dep_map" . flip M.lookup build_map) direct_deps - -type BuildM a = StateT BuildLoopState IO a - - - - --- | Environment used when compiling a module -data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module - , compile_sem :: !AbstractSem - -- Modify the environment for module k, with the supplied logger modification function. - -- For -j1, this wrapper doesn't do anything - -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output - -- into the log queue. - , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a - , env_messager :: !(Maybe Messager) - , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic - } - -type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a - --- | Given the build plan, creates a graph which indicates where each NodeKey should --- get its direct dependencies from. This might not be the corresponding build action --- if the module participates in a loop. This step also labels each node with a number for the output. --- See Note [Upsweep] for a high-level description. -interpretBuildPlan :: HomeUnitGraph - -> Maybe ModIfaceCache - -> M.Map ModNodeKeyWithUid HomeModInfo - -> [BuildPlan] - -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle - , [MakeAction] -- Actions we need to run in order to build everything - , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end. -interpretBuildPlan hug mhmi_cache old_hpt plan = do - hug_var <- newMVar hug - ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var) - let wait = collect_results (buildDep build_map) - return (mcycle, plans, wait) - - where - collect_results build_map = - sequence (map (\br -> collect_result (fst <$> resultVar br)) (M.elems build_map)) - where - collect_result res_var = runMaybeT (waitResult res_var) - - n_mods = sum (map countMods plan) - - buildLoop :: [BuildPlan] - -> BuildM (Maybe [ModuleGraphNode], [MakeAction]) - -- Build the abstract pipeline which we can execute - -- Building finished - buildLoop [] = return (Nothing, []) - buildLoop (plan:plans) = - case plan of - -- If there was no cycle, then typecheckLoop is not necessary - SingleModule m -> do - one_plan <- buildSingleModule Nothing NoLoop m - (cycle, all_plans) <- buildLoop plans - return (cycle, one_plan : all_plans) - - -- For a resolved cycle, depend on everything in the loop, then update - -- the cache to point to this node rather than directly to the module build - -- nodes - ResolvedCycle ms -> do - pipes <- buildModuleLoop ms - (cycle, graph) <- buildLoop plans - return (cycle, pipes ++ graph) - - -- Can't continue past this point as the cycle is unresolved. - UnresolvedCycle ns -> return (Just ns, []) - - buildSingleModule :: Maybe [NodeKey] -- Modules we need to rehydrate before compiling this module - -> ResultOrigin - -> ModuleGraphNode -- The node we are compiling - -> BuildM MakeAction - buildSingleModule rehydrate_nodes origin mod = do - mod_idx <- nodeId - !build_map <- getBuildMap - hug_var <- gets hug_var - -- 1. Get the direct dependencies of this module - let direct_deps = nodeDependencies False mod - -- It's really important to force build_deps, or the whole buildMap is retained, - -- which would retain all the result variables, preventing us from collecting them - -- after they are no longer used. - !build_deps = getDependencies direct_deps build_map - let !build_action = - case mod of - InstantiationNode uid iu -> do - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps - executeInstantiationNode mod_idx n_mods hug uid iu - return (Nothing, deps) - ModuleNode _build_deps ms -> - let !old_hmi = M.lookup (msKey ms) old_hpt - rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes - in withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps - hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms - -- Write the HMI to an external cache (if one exists) - -- See Note [Caching HomeModInfo] - liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi - -- This global MVar is incrementally modified in order to avoid having to - -- recreate the HPT before compiling each module which leads to a quadratic amount of work. - liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi) - return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) - LinkNode _nks uid -> do - withCurrentUnit (moduleGraphNodeUnitId mod) $ do - (hug, deps) <- wait_deps_hug hug_var build_deps - executeLinkNode hug (mod_idx, n_mods) uid direct_deps - return (Nothing, deps) - - - res_var <- liftIO newEmptyMVar - let result_var = mkResultVar res_var - setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) - return $! (MakeAction build_action res_var) - - - buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] - buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do - ma <- buildSingleModule (Just deps) (Loop Initialise) mn - -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files" - rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps)) - return $ [ma, rehydrate_action] - - - buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction] - buildModuleLoop ms = do - build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms - let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot - extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot - let loop_mods = map extract ms - -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files" - -- Fixes the space leak described in that note. - rehydrate_action <- rehydrateAction Finalised loop_mods - - return $ build_modules ++ [rehydrate_action] - - -- An action which rehydrates the given keys - rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction - rehydrateAction origin deps = do - hug_var <- gets hug_var - !build_map <- getBuildMap - res_var <- liftIO newEmptyMVar - let loop_unit :: UnitId - !loop_unit = nodeKeyUnitId (gwib_mod (head deps)) - !build_deps = getDependencies (map gwib_mod deps) build_map - let loop_action = withCurrentUnit loop_unit $ do - (hug, tdeps) <- wait_deps_hug hug_var build_deps - hsc_env <- asks hsc_env - let new_hsc = setHUG hug hsc_env - mns :: [ModuleName] - mns = mapMaybe (nodeKeyModName . gwib_mod) deps - - hmis' <- liftIO $ rehydrateAfter new_hsc mns - - checkRehydrationInvariant hmis' deps - - -- Add hydrated interfaces to global variable - liftIO $ modifyMVar_ hug_var (\hug -> return $ foldr addHomeModInfoToHug hug hmis') - return (hmis', tdeps) - - let fanout i = first (Just . (!! i)) <$> mkResultVar res_var - -- From outside the module loop, anyone must wait for the loop to finish and then - -- use the result of the rehydrated iface. This makes sure that things not in the - -- module loop will see the updated interfaces for all the identifiers in the loop. - boot_key :: NodeKey -> NodeKey - boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } ) - boot_key k = pprPanic "boot_key" (ppr k) - - update_module_pipeline (m, i) = - case gwib_isBoot m of - NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i)) - IsBoot -> do - setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i)) - -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot - setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i)) - - let deps_i = zip deps [0..] - mapM update_module_pipeline deps_i - - return $ MakeAction loop_action res_var - - -- Checks that the interfaces returned from hydration match-up with the names of the - -- modules which were fed into the function. - checkRehydrationInvariant hmis deps = - let hmi_names = map (moduleName . mi_module . hm_iface) hmis - start = mapMaybe (nodeKeyModName . gwib_mod) deps - in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start) - - -withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a -withCurrentUnit uid = do - local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)}) - -upsweep - :: WorkerLimit -- ^ The number of workers we wish to run in parallel - -> HscEnv -- ^ The base HscEnv, which is augmented for each module - -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to - -> (GhcMessage -> AnyGhcDiagnostic) - -> Maybe Messager - -> M.Map ModNodeKeyWithUid HomeModInfo - -> [BuildPlan] - -> IO (SuccessFlag, [HomeModInfo]) -upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do - (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan - runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines - res <- collect_result - - let completed = [m | Just (Just m) <- res] - - -- Handle any cycle in the original compilation graph and return the result - -- of the upsweep. - case cycle of - Just mss -> do - let logger = hsc_logger hsc_env - liftIO $ fatalErrorMsg logger (cyclicModuleErr mss) - return (Failed, []) - Nothing -> do - let success_flag = successIf (all isJust res) - return (success_flag, completed) - -toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo -toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis]) - -miKey :: ModIface -> ModNodeKeyWithUid -miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi))) - -upsweep_inst :: HscEnv - -> Maybe Messager - -> Int -- index of module - -> Int -- total number of modules - -> UnitId - -> InstantiatedUnit - -> IO () -upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do - case mHscMessage of - Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid) - Nothing -> return () - runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid - pure () - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: HscEnv - -> Maybe Messager - -> Maybe HomeModInfo - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> IO HomeModInfo -upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do - hmi <- compileOne' mHscMessage hsc_env summary - mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi) - - -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module - -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I - -- am unsure if this is sound (wrt running TH splices for example). - -- This function only does anything if the linkable produced is a BCO, which only happens with the - -- bytecode backend, no need to guard against the backend type additionally. - addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env) - (homeModInfoByteCode hmi) - - return hmi - --- | Add the entries from a BCO linkable to the SPT table, see --- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. -addSptEntries :: HscEnv -> Maybe Linkable -> IO () -addSptEntries hsc_env mlinkable = - hscAddSptEntries hsc_env - [ spt - | Just linkable <- [mlinkable] - , unlinked <- linkableUnlinked linkable - , BCOs _ spts <- pure unlinked - , spt <- spts - ] - -{- Note [-fno-code mode] -~~~~~~~~~~~~~~~~~~~~~~~~ -GHC offers the flag -fno-code for the purpose of parsing and typechecking a -program without generating object files. This is intended to be used by tooling -and IDEs to provide quick feedback on any parser or type errors as cheaply as -possible. - -When GHC is invoked with -fno-code no object files or linked output will be -generated. As many errors and warnings as possible will be generated, as if --fno-code had not been passed. The session DynFlags will have -backend == NoBackend. - --fwrite-interface -~~~~~~~~~~~~~~~~ -Whether interface files are generated in -fno-code mode is controlled by the --fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is -not also passed. Recompilation avoidance requires interface files, so passing --fno-code without -fwrite-interface should be avoided. If -fno-code were -re-implemented today, -fwrite-interface would be discarded and it would be -considered always on; this behaviour is as it is for backwards compatibility. - -================================================================ -IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER -================================================================ - -Template Haskell -~~~~~~~~~~~~~~~~ -A module using template haskell may invoke an imported function from inside a -splice. This will cause the type-checker to attempt to execute that code, which -would fail if no object files had been generated. See #8025. To rectify this, -during the downsweep we patch the DynFlags in the ModSummary of any home module -that is imported by a module that uses template haskell, to generate object -code. - -The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled -or not in the module which needs the code generation. If the module requires byte-code then -dependencies will generate byte-code, otherwise they will generate object files. -In the case where some modules require byte-code and some object files, both are -generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these -configurations. - -The object files (and interface files if -fwrite-interface is disabled) produced -for template haskell are written to temporary files. - -Note that since template haskell can run arbitrary IO actions, -fno-code mode -is no more secure than running without it. - -Potential TODOS: -~~~~~ -* Remove -fwrite-interface and have interface files always written in -fno-code - mode -* Both .o and .dyn_o files are generated for template haskell, but we only need - .dyn_o. Fix it. -* In make mode, a message like - Compiling A (A.hs, /tmp/ghc_123.o) - is shown if downsweep enabled object code generation for A. Perhaps we should - show "nothing" or "temporary object file" instead. Note that one - can currently use -keep-tmp-files and inspect the generated file with the - current behaviour. -* Offer a -no-codedir command line option, and write what were temporary - object files there. This would speed up recompilation. -* Use existing object files (if they are up to date) instead of always - generating temporary ones. --} - --- Note [When source is considered modified] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- A number of functions in GHC.Driver accept a SourceModified argument, which --- is part of how GHC determines whether recompilation may be avoided (see the --- definition of the SourceModified data type for details). --- --- Determining whether or not a source file is considered modified depends not --- only on the source file itself, but also on the output files which compiling --- that module would produce. This is done because GHC supports a number of --- flags which control which output files should be produced, e.g. -fno-code --- -fwrite-interface and -fwrite-ide-file; we must check not only whether the --- source file has been modified since the last compile, but also whether the --- source file has been modified since the last compile which produced all of --- the output files which have been requested. --- --- Specifically, a source file is considered unmodified if it is up-to-date --- relative to all of the output files which have been requested. Whether or --- not an output file is up-to-date depends on what kind of file it is: --- --- * iface (.hi) files are considered up-to-date if (and only if) their --- mi_src_hash field matches the hash of the source file, --- --- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date --- if (and only if) their modification times on the filesystem are greater --- than or equal to the modification time of the corresponding .hi file. --- --- Why do we use '>=' rather than '>' for output files other than the .hi file? --- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a --- resolution of 2 seconds), we may often find that the .hi and .o files have --- the same modification time. Using >= is slightly unsafe, but it matches --- make's behaviour. --- --- This strategy allows us to do the minimum work necessary in order to ensure --- that all the files the user cares about are up-to-date; e.g. we should not --- worry about .o files if the user has indicated that they are not interested --- in them via -fno-code. See also #9243. --- --- Note that recompilation avoidance is dependent on .hi files being produced, --- which does not happen if -fno-write-interface -fno-code is passed. That is, --- passing -fno-write-interface -fno-code means that you cannot benefit from --- recompilation avoidance. See also Note [-fno-code mode]. --- --- The correctness of this strategy depends on an assumption that whenever we --- are producing multiple output files, the .hi file is always written first. --- If this assumption is violated, we risk recompiling unnecessarily by --- incorrectly regarding non-.hi files as outdated. --- - --- --------------------------------------------------------------------------- --- --- | Topological sort of the module graph -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> ModuleGraph - -> Maybe HomeUnitModule - -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModuleGraphNode] --- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes --- The resulting list of strongly-connected-components is in topologically --- sorted order, starting with the module(s) at the bottom of the --- dependency graph (ie compile them first) and ending with the ones at --- the top. --- --- Drop hi-boot nodes (first boolean arg)? --- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic --- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic -topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = - -- stronglyConnCompG flips the original order, so if we reverse - -- the summaries we get a stable topological sort. - topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod - -topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode] -topSortModules drop_hs_boot_nodes summaries mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - (graph, lookup_node) = - moduleGraphNodes drop_hs_boot_nodes summaries - - initial_graph = case mb_root_mod of - Nothing -> graph - Just (Module uid root_mod) -> - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid - , graph `hasVertexG` node - = node - | otherwise - = throwGhcException (ProgramError "module does not exist") - in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) - -newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } - deriving (Functor, Traversable, Foldable) - -emptyModNodeMap :: ModNodeMap a -emptyModNodeMap = ModNodeMap Map.empty - -modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a -modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m) - -modNodeMapElems :: ModNodeMap a -> [a] -modNodeMapElems (ModNodeMap m) = Map.elems m - -modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a -modNodeMapLookup k (ModNodeMap m) = Map.lookup k m - -modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a -modNodeMapSingleton k v = ModNodeMap (M.singleton k v) - -modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a -modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n) - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = do - diag_opts <- initDiagOpts <$> getDynFlags - when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do - let check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> MsgEnvelope GhcMessage - warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts - loc (DriverUnnecessarySourceImports mod) - logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs)) - - --- This caches the answer to the question, if we are in this unit, what does --- an import of this module mean. -type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary] - ------------------------------------------------------------------------------ --- --- | Downsweep (dependency analysis) --- --- Chase downwards from the specified root set, returning summaries --- for all home modules encountered. Only follow source-import --- links. --- --- We pass in the previous collection of summaries, which is used as a --- cache to avoid recalculating a module summary if the source is --- unchanged. --- --- The returned list of [ModSummary] nodes has one node for each home-package --- module, plus one for any hs-boot files. The imports of these nodes --- are all there, including the imports of non-home-package modules. -downsweep :: HscEnv - -> [ModSummary] - -- ^ Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> IO ([DriverMessages], [ModuleGraphNode]) - -- The non-error elements of the returned list all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true in - -- which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do - rootSummaries <- mapM getRootSummary roots - let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549 - root_map = mkRootMap rootSummariesOk - checkDuplicates root_map - (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map) - let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) - let unit_env = hsc_unit_env hsc_env - let tmpfs = hsc_tmpfs hsc_env - - let downsweep_errs = lefts $ concat $ M.elems map0 - downsweep_nodes = M.elems deps - - (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env) - all_nodes = downsweep_nodes ++ unit_nodes - all_errs = all_root_errs ++ downsweep_errs ++ other_errs - all_root_errs = closure_errs ++ map snd root_errs - - -- if we have been passed -fno-code, we enable code generation - -- for dependencies of modules that have -XTemplateHaskell, - -- otherwise those modules will fail to compile. - -- See Note [-fno-code mode] #8025 - th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes - if null all_root_errs - then return (all_errs, th_enabled_nodes) - else pure $ (all_root_errs, []) - where - -- Dependencies arising on a unit (backpack and module linking deps) - unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode] - unitModuleNodes summaries uid hue = - let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue) - in map Right instantiation_nodes - ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue) - - calcDeps ms = - -- Add a dependency on the HsBoot file if it exists - -- This gets passed to the loopImports function which just ignores it if it - -- can't be found. - [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++ - [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ] - - logger = hsc_logger hsc_env - roots = hsc_targets hsc_env - - -- A cache from file paths to the already summarised modules. The same file - -- can be used in multiple units so the map is also keyed by which unit the - -- file was used in. - -- Reuse these if we can because the most expensive part of downsweep is - -- reading the headers. - old_summary_map :: M.Map (UnitId, FilePath) ModSummary - old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries] - - getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary) - getRootSummary Target { targetId = TargetFile file mb_phase - , targetContents = maybe_buf - , targetUnitId = uid - } - = do let offset_file = augmentByWorkingDirectory dflags file - exists <- liftIO $ doesFileExist offset_file - if exists || isJust maybe_buf - then first (uid,) <$> - summariseFile hsc_env home_unit old_summary_map offset_file mb_phase - maybe_buf - else return $ Left $ (uid,) $ singleMessage - $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file) - where - dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) - home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) - getRootSummary Target { targetId = TargetModule modl - , targetContents = maybe_buf - , targetUnitId = uid - } - = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot - (L rootLoc modl) (ThisPkg (homeUnitId home_unit)) - maybe_buf excl_mods - case maybe_summary of - FoundHome s -> return (Right s) - FoundHomeWithError err -> return (Left err) - _ -> return $ Left $ (uid, moduleNotFoundErr modl) - where - home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates - :: DownsweepCache - -> IO () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton $ map rights (M.elems root_map) - - -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit - loopSummaries :: [ModSummary] - -> (M.Map NodeKey ModuleGraphNode, - DownsweepCache) - -> IO ((M.Map NodeKey ModuleGraphNode), DownsweepCache) - loopSummaries [] done = return done - loopSummaries (ms:next) (done, summarised) - | Just {} <- M.lookup k done - = loopSummaries next (done, summarised) - -- Didn't work out what the imports mean yet, now do that. - | otherwise = do - (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised - -- This has the effect of finding a .hs file if we are looking at the .hs-boot file. - (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised' - loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', summarised'') - where - k = NodeKey_Module (msKey ms) - - hs_file_for_boot - | HsBootFile <- ms_hsc_src ms - = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot)) - | otherwise - = Nothing - - - -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover - -- a new module by doing this. - loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))] - -- Work list: process these modules - -> M.Map NodeKey ModuleGraphNode - -> DownsweepCache - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> IO ([NodeKey], - M.Map NodeKey ModuleGraphNode, DownsweepCache) - -- The result is the completed NodeMap - loopImports [] done summarised = return ([], done, summarised) - loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised - | Just summs <- M.lookup cache_key summarised - = case summs of - [Right ms] -> do - let nk = NodeKey_Module (msKey ms) - (rest, summarised', done') <- loopImports ss done summarised - return (nk: rest, summarised', done') - [Left _err] -> - loopImports ss done summarised - _errs -> do - loopImports ss done summarised - | otherwise - = do - mb_s <- summariseModule hsc_env home_unit old_summary_map - is_boot wanted_mod mb_pkg - Nothing excl_mods - case mb_s of - NotThere -> loopImports ss done summarised - External _ -> do - (other_deps, done', summarised') <- loopImports ss done summarised - return (other_deps, done', summarised') - FoundInstantiation iud -> do - (other_deps, done', summarised') <- loopImports ss done summarised - return (NodeKey_Unit iud : other_deps, done', summarised') - FoundHomeWithError (_uid, e) -> loopImports ss done (Map.insert cache_key [(Left e)] summarised) - FoundHome s -> do - (done', summarised') <- - loopSummaries [s] (done, Map.insert cache_key [Right s] summarised) - (other_deps, final_done, final_summarised) <- loopImports ss done' summarised' - - -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now. - return (NodeKey_Module (msKey s) : other_deps, final_done, final_summarised) - where - cache_key = (home_uid, mb_pkg, unLoc <$> gwib) - home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env) - GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib - wanted_mod = L loc mod - --- | This function checks then important property that if both p and q are home units --- then any dependency of p, which transitively depends on q is also a home unit. --- --- See Note [Multiple Home Units], section 'Closure Property'. -checkHomeUnitsClosed :: UnitEnv -> [DriverMessages] -checkHomeUnitsClosed ue - | Set.null bad_unit_ids = [] - | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)] - where - home_id_set = unitEnv_keys $ ue_home_unit_graph ue - bad_unit_ids = upwards_closure Set.\\ home_id_set - rootLoc = mkGeneralSrcSpan (fsLit "") - - graph :: Graph (Node UnitId UnitId) - graph = graphFromEdgedVerticesUniq graphNodes - - -- downwards closure of graph - downwards_closure - = graphFromEdgedVerticesUniq [ DigraphNode uid uid (Set.toList deps) - | (uid, deps) <- M.toList (allReachable graph node_key)] - - inverse_closure = transposeG downwards_closure - - upwards_closure = Set.fromList $ map node_key $ reachablesG inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set] - - all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId) - all_unit_direct_deps - = unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue - where - go rest this this_uis = - plusUniqMap_C Set.union - (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps)) - rest - where - external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units) - this_units = homeUnitEnv_units this_uis - this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units] - - graphNodes :: [Node UnitId UnitId] - graphNodes = go Set.empty home_id_set - where - go done todo - = case Set.minView todo of - Nothing -> [] - Just (uid, todo') - | Set.member uid done -> go done todo' - | otherwise -> case lookupUniqMap all_unit_direct_deps uid of - Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps)) - Just depends -> - let todo'' = (depends Set.\\ done) `Set.union` todo' - in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo'' - --- | Update the every ModSummary that is depended on --- by a module that needs template haskell. We enable codegen to --- the specified target, disable optimization and change the .hi --- and .o file locations to be temporary files. --- See Note [-fno-code mode] -enableCodeGenForTH - :: Logger - -> TmpFs - -> UnitEnv - -> [ModuleGraphNode] - -> IO [ModuleGraphNode] -enableCodeGenForTH logger tmpfs unit_env = - enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env - - -data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord) - -instance Outputable CodeGenEnable where - ppr = text . show - --- | Helper used to implement 'enableCodeGenForTH'. --- In particular, this enables --- unoptimized code generation for all modules that meet some --- condition (first parameter), or are dependencies of those --- modules. The second parameter is a condition to check before --- marking modules for code generation. -enableCodeGenWhen - :: Logger - -> TmpFs - -> TempFileLifetime - -> TempFileLifetime - -> UnitEnv - -> [ModuleGraphNode] - -> IO [ModuleGraphNode] -enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = - mapM enable_code_gen mod_graph - where - defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env) - enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode - enable_code_gen n@(ModuleNode deps ms) - | ModSummary - { ms_location = ms_location - , ms_hsc_src = HsSrcFile - , ms_hspp_opts = dflags - } <- ms - , Just enable_spec <- mkNodeKey n `Map.lookup` needs_codegen_map = - if | nocode_enable ms -> do - let new_temp_file suf dynsuf = do - tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf - let dyn_tn = tn -<.> dynsuf - addFilesToClean tmpfs dynLife [dyn_tn] - return (tn, dyn_tn) - -- We don't want to create .o or .hi files unless we have been asked - -- to by the user. But we need them, so we patch their locations in - -- the ModSummary with temporary files. - -- - ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <- - -- If ``-fwrite-interface` is specified, then the .o and .hi files - -- are written into `-odir` and `-hidir` respectively. #16670 - if gopt Opt_WriteInterface dflags - then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location) - , (ml_obj_file ms_location, ml_dyn_obj_file ms_location)) - else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags)) - <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags)) - let new_dflags = case enable_spec of - EnableByteCode -> dflags { backend = interpreterBackend } - EnableObject -> dflags { backend = defaultBackendOf ms } - EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms} - let ms' = ms - { ms_location = - ms_location { ml_hi_file = hi_file - , ml_obj_file = o_file - , ml_dyn_hi_file = dyn_hi_file - , ml_dyn_obj_file = dyn_o_file } - , ms_hspp_opts = updOptLevel 0 $ new_dflags - } - -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') - - -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough) - -- we only get to this case if the default backend is already generating object files, but we need dynamic - -- objects - | bytecode_and_enable enable_spec ms -> do - let ms' = ms - { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode - } - -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') - | dynamic_too_enable enable_spec ms -> do - let ms' = ms - { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo - } - -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') - | ext_interp_enable ms -> do - let ms' = ms - { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter - } - -- Recursive call to catch the other cases - enable_code_gen (ModuleNode deps ms') - - | otherwise -> return n - - enable_code_gen ms = return ms - - nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) = - not (backendGeneratesCode (backend dflags)) && - -- Don't enable codegen for TH on indefinite packages; we - -- can't compile anything anyway! See #16219. - isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) - - bytecode_and_enable enable_spec ms = - -- In the situation where we **would** need to enable dynamic-too - -- IF we had decided we needed objects - dynamic_too_enable EnableObject ms - -- but we prefer to use bytecode rather than objects - && prefer_bytecode - -- and we haven't already turned it on - && not generate_both - where - lcl_dflags = ms_hspp_opts ms - prefer_bytecode = case enable_spec of - EnableByteCodeAndObject -> True - EnableByteCode -> True - EnableObject -> False - - generate_both = gopt Opt_ByteCodeAndObjectCode lcl_dflags - - -- #8180 - when using TemplateHaskell, switch on -dynamic-too so - -- the linker can correctly load the object files. This isn't necessary - -- when using -fexternal-interpreter. - dynamic_too_enable enable_spec ms - = hostIsDynamic && internalInterpreter && - not isDynWay && not isProfWay && not dyn_too_enabled - && enable_object - where - lcl_dflags = ms_hspp_opts ms - internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) - dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags - isDynWay = hasWay (ways lcl_dflags) WayDyn - isProfWay = hasWay (ways lcl_dflags) WayProf - enable_object = case enable_spec of - EnableByteCode -> False - EnableByteCodeAndObject -> True - EnableObject -> True - - -- #16331 - when no "internal interpreter" is available but we - -- need to process some TemplateHaskell or QuasiQuotes, we automatically - -- turn on -fexternal-interpreter. - ext_interp_enable ms = not ghciSupported && internalInterpreter - where - lcl_dflags = ms_hspp_opts ms - internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) - - (mg, lookup_node) = moduleGraphNodes False mod_graph - - mk_needed_set roots = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) roots) - - needs_obj_set, needs_bc_set :: Set.Set NodeKey - needs_obj_set = mk_needed_set need_obj_set - - needs_bc_set = mk_needed_set need_bc_set - - -- A map which tells us how to enable code generation for a NodeKey - needs_codegen_map :: Map.Map NodeKey CodeGenEnable - needs_codegen_map = - -- Another option here would be to just produce object code, rather than both object and - -- byte code - Map.unionWith (\_ _ -> EnableByteCodeAndObject) - (Map.fromList $ [(m, EnableObject) | m <- Set.toList needs_obj_set]) - (Map.fromList $ [(m, EnableByteCode) | m <- Set.toList needs_bc_set]) - - -- The direct dependencies of modules which require object code - need_obj_set = - concat - -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only - -- it's dependencies. - [ deps - | (ModuleNode deps ms) <- mod_graph - , isTemplateHaskellOrQQNonBoot ms - , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)) - ] - - -- The direct dependencies of modules which require byte code - need_bc_set = - concat - [ deps - | (ModuleNode deps ms) <- mod_graph - , isTemplateHaskellOrQQNonBoot ms - , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms) - ] - --- | Populate the Downsweep cache with the root modules. -mkRootMap - :: [ModSummary] - -> DownsweepCache -mkRootMap summaries = Map.fromListWith (flip (++)) - [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ] - ------------------------------------------------------------------------------ --- Summarising modules - --- We have two types of summarisation: --- --- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. --- --- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. - -summariseFile - :: HscEnv - -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Maybe (StringBuffer,UTCTime) - -> IO (Either DriverMessages ModSummary) - -summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, - | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries - = do - let location = ms_location $ old_summary - - src_hash <- get_src_hash - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getFileHash may fail, but that's the right - -- behaviour. - - -- return the cached summary if the source didn't change - checkSummaryHash - hsc_env (new_summary src_fn) - old_summary location src_hash - - | otherwise - = do src_hash <- get_src_hash - new_summary src_fn src_hash - where - -- change the main active unit so all operations happen relative to the given unit - hsc_env = hscSetActiveHomeUnit home_unit hsc_env' - -- src_fn does not necessarily exist on the filesystem, so we need to - -- check what kind of target we are dealing with - get_src_hash = case maybe_buf of - Just (buf,_) -> return $ fingerprintStringBuffer buf - Nothing -> liftIO $ getFileHash src_fn - - new_summary src_fn src_hash = runExceptT $ do - preimps@PreprocessedImports {..} - <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf - - let fopts = initFinderOpts (hsc_dflags hsc_env) - - -- Make a ModLocation for this file - let location = mkHomeModLocation fopts pi_mod_name src_fn - - -- 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 - - 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_location = location - , nms_mod = mod - , nms_preimps = preimps - } - -checkSummaryHash - :: HscEnv - -> (Fingerprint -> IO (Either e ModSummary)) - -> ModSummary -> ModLocation -> Fingerprint - -> IO (Either e ModSummary) -checkSummaryHash - hsc_env new_summary - old_summary - location src_hash - | ms_hs_hash old_summary == src_hash && - not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do - -- update the object-file timestamp - obj_timestamp <- modificationTimeIfExists (ml_obj_file location) - - -- We have to repopulate the Finder's cache for file targets - -- because the file might not even be on the regular search path - -- and it was likely flushed in depanal. This is not technically - -- needed when we're called from sumariseModule but it shouldn't - -- hurt. - -- Also, only add to finder cache for non-boot modules as the finder cache - -- makes sure to add a boot suffix for boot files. - _ <- do - let fc = hsc_FC hsc_env - case ms_hsc_src old_summary of - HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location - _ -> return () - - hi_timestamp <- modificationTimeIfExists (ml_hi_file location) - hie_timestamp <- modificationTimeIfExists (ml_hie_file location) - - return $ Right - ( old_summary - { ms_obj_date = obj_timestamp - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp - } - ) - - | otherwise = - -- source changed: re-summarise. - new_summary src_hash - -data SummariseResult = - FoundInstantiation InstantiatedUnit - | FoundHomeWithError (UnitId, DriverMessages) - | FoundHome ModSummary - | External UnitId - | NotThere - --- Summarise a module, and pick up source and timestamp. -summariseModule - :: HscEnv - -> HomeUnit - -> M.Map (UnitId, FilePath) ModSummary - -- ^ Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised - -> PkgQual - -> Maybe (StringBuffer, UTCTime) - -> [ModuleName] -- Modules to exclude - -> IO SummariseResult - - -summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg - maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return NotThere - | otherwise = find_it - where - -- Temporarily change the currently active home unit so all operations - -- happen relative to it - hsc_env = hscSetActiveHomeUnit home_unit hsc_env' - dflags = hsc_dflags hsc_env - - find_it :: IO SummariseResult - - find_it = do - found <- findImportedModule hsc_env wanted_mod mb_pkg - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | VirtUnit iud <- moduleUnit mod - , not (isHomeModule home_unit mod) - -> return $ FoundInstantiation iud - | otherwise -> return $ External (moduleUnitId mod) - _ -> return NotThere - -- Not found - -- (If it is TRULY not found at all, we'll - -- error when we actually try to compile) - - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' = case is_boot of - IsBoot -> addBootSuffixLocn location - NotBoot -> location - src_fn = expectJust "summarise2" (ml_hs_file location') - - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_h <- fileHashIfExists src_fn - case maybe_h of - -- This situation can also happen if we have found the .hs file but the - -- .hs-boot file doesn't exist. - Nothing -> return NotThere - Just h -> do - fresult <- new_summary_cache_check location' mod src_fn h - return $ case fresult of - Left err -> FoundHomeWithError (moduleUnitId mod, err) - Right ms -> FoundHome ms - - new_summary_cache_check loc mod src_fn h - | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map = - - -- check the hash on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has changed then need to resummarise. - case maybe_buf of - Just (buf,_) -> - checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf) - Nothing -> - checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h - | otherwise = new_summary loc mod src_fn h - - new_summary :: ModLocation - -> Module - -> FilePath - -> Fingerprint - -> IO (Either DriverMessages ModSummary) - new_summary location mod src_fn src_hash - = runExceptT $ do - preimps@PreprocessedImports {..} - -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP - -- See multiHomeUnits_cpp2 test - <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf - - -- NB: Despite the fact that is_boot is a top-level parameter, we - -- don't actually know coming into this function what the HscSource - -- of the module in question is. This is because we may be processing - -- this module because another module in the graph imported it: in this - -- case, we know if it's a boot or not because of the {-# SOURCE #-} - -- annotation, but we don't know if it's a signature or a regular - -- module until we actually look it up on the filesystem. - let hsc_src - | is_boot == IsBoot = HsBootFile - | isHaskellSigFilename src_fn = HsigFile - | otherwise = HsSrcFile - - when (pi_mod_name /= wanted_mod) $ - throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverFileModuleNameMismatch pi_mod_name wanted_mod - - let instantiations = homeUnitInstantiations home_unit - when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $ - throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations - - liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary - { nms_src_fn = src_fn - , nms_src_hash = src_hash - , nms_is_boot = is_boot - , nms_hsc_src = hsc_src - , nms_location = location - , nms_mod = mod - , nms_preimps = preimps - } - --- | Convenience named arguments for 'makeNewModSummary' only used to make --- code more readable, not exported. -data MakeNewModSummary - = MakeNewModSummary - { nms_src_fn :: FilePath - , nms_src_hash :: Fingerprint - , nms_is_boot :: IsBootInterface - , nms_hsc_src :: HscSource - , nms_location :: ModLocation - , nms_mod :: Module - , nms_preimps :: PreprocessedImports - } - -makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary -makeNewModSummary hsc_env MakeNewModSummary{..} = do - let PreprocessedImports{..} = nms_preimps - obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location) - dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location) - hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location) - hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) - - extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name - (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps - - return $ - ModSummary - { ms_mod = nms_mod - , ms_hsc_src = nms_hsc_src - , ms_location = nms_location - , ms_hspp_file = pi_hspp_fn - , ms_hspp_opts = pi_local_dflags - , ms_hspp_buf = Just pi_hspp_buf - , ms_parsed_mod = Nothing - , ms_srcimps = pi_srcimps - , ms_ghc_prim_import = pi_ghc_prim_import - , ms_textual_imps = - ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++ - ((,) NoPkgQual . noLoc <$> implicit_sigs) ++ - pi_theimps - , ms_hs_hash = nms_src_hash - , ms_iface_date = hi_timestamp - , ms_hie_date = hie_timestamp - , ms_obj_date = obj_timestamp - , ms_dyn_obj_date = dyn_obj_timestamp - } - -data PreprocessedImports - = PreprocessedImports - { pi_local_dflags :: DynFlags - , pi_srcimps :: [(PkgQual, Located ModuleName)] - , pi_theimps :: [(PkgQual, Located ModuleName)] - , pi_ghc_prim_import :: Bool - , pi_hspp_fn :: FilePath - , pi_hspp_buf :: StringBuffer - , pi_mod_name_loc :: SrcSpan - , pi_mod_name :: ModuleName - } - --- Preprocess the source file and get its imports --- The pi_local_dflags contains the OPTIONS pragmas -getPreprocessedImports - :: HscEnv - -> FilePath - -> Maybe Phase - -> Maybe (StringBuffer, UTCTime) - -- ^ optional source code buffer and modification time - -> ExceptT DriverMessages IO PreprocessedImports -getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do - (pi_local_dflags, pi_hspp_fn) - <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase - pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn - (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name) - <- ExceptT $ do - let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags - popts = initParserOpts pi_local_dflags - mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn - return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps) - let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) - let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn)) - let pi_srcimps = rn_imps pi_srcimps' - let pi_theimps = rn_imps pi_theimps' - return PreprocessedImports {..} - - ------------------------------------------------------------------------------ --- Error messages ------------------------------------------------------------------------------ - --- Defer and group warning, error and fatal messages so they will not get lost --- in the regular output. -withDeferredDiagnostics :: GhcMonad m => m a -> m a -withDeferredDiagnostics f = do - dflags <- getDynFlags - if not $ gopt Opt_DeferDiagnostics dflags - then f - else do - warnings <- liftIO $ newIORef [] - errors <- liftIO $ newIORef [] - fatals <- liftIO $ newIORef [] - logger <- getLogger - - let deferDiagnostics _dflags !msgClass !srcSpan !msg = do - let action = logMsg logger msgClass srcSpan msg - case msgClass of - MCDiagnostic SevWarning _reason _code - -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic SevError _reason _code - -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) - MCFatal - -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) - _ -> action - - printDeferredDiagnostics = liftIO $ - forM_ [warnings, errors, fatals] $ \ref -> do - -- This IORef can leak when the dflags leaks, so let us always - -- reset the content. The lazy variant is used here as we want to force - -- this error if the IORef is ever accessed again, rather than now. - -- See #20981 for an issue which discusses this general issue. - let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else [] - actions <- atomicModifyIORef ref $ \i -> (landmine, i) - sequence_ $ reverse actions - - MC.bracket - (pushLogHookM (const deferDiagnostics)) - (\_ -> popLogHookM >> printDeferredDiagnostics) - (\_ -> f) - -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage --- ToDo: we don't have a proper line number for this error -noModError hsc_env loc wanted_mod err - = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ - DriverInterfaceError $ - (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot)) - -{- -noHsFileErr :: SrcSpan -> String -> DriverMessages -noHsFileErr loc path - = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path) - -} - -moduleNotFoundErr :: ModuleName -> DriverMessages -moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod) - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ fmap GhcDriverMessage $ - mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files - where - mod = ms_mod summ1 - files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs - -cyclicModuleErr :: [ModuleGraphNode] -> SDoc --- 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)] - where - graph :: [Node NodeKey ModuleGraphNode] - graph = - [ DigraphNode - { node_payload = ms - , node_key = mkNodeKey ms - , node_dependencies = nodeDependencies False ms - } - | 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 6 (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 - then liftIO $ keepCurrentModuleTempFiles logger tmpfs - else liftIO $ cleanCurrentModuleTempFiles logger tmpfs - - -addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> HscEnv -addDepsToHscEnv deps hsc_env = - hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env - -setHPT :: HomePackageTable -> HscEnv -> HscEnv -setHPT deps hsc_env = - hscUpdateHPT (const $ deps) hsc_env - -setHUG :: HomeUnitGraph -> HscEnv -> HscEnv -setHUG deps hsc_env = - hscUpdateHUG (const $ deps) hsc_env - --- | Wrap an action to catch and handle exceptions. -wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a) -wrapAction msg_wrapper hsc_env k = do - let lcl_logger = hsc_logger hsc_env - lcl_dynflags = hsc_dflags hsc_env - print_config = initPrintConfig lcl_dynflags - let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err) - -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle - -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches` - -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to - -- internally using forkIO. - mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k - case mres of - Right res -> return $ Just res - Left exc -> do - case fromException exc of - Just (err :: SourceError) - -> logg err - Nothing -> case fromException exc of - -- ThreadKilled in particular needs to actually kill the thread. - -- So rethrow that and the other async exceptions - Just (err :: SomeAsyncException) -> throwIO err - _ -> errorMsg lcl_logger (text (show exc)) - return Nothing - -withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b -withParLog lqq_var k cont = do - let init_log = do - -- Make a new log queue - lq <- newLogQueue k - -- Add it into the LogQueueQueue - atomically $ initLogQueue lqq_var lq - return lq - finish_log lq = liftIO (finishLogQueue lq) - MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq))) - -withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a -withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do - withLogger k $ \modifyLogger -> do - let lcl_logger = modifyLogger (hsc_logger hsc_env) - hsc_env' = hsc_env { hsc_logger = lcl_logger } - -- Run continuation with modified logger - cont hsc_env' - - -executeInstantiationNode :: Int - -> Int - -> HomeUnitGraph - -> UnitId - -> InstantiatedUnit - -> RunMakeM () -executeInstantiationNode k n deps uid iu = do - env <- ask - -- Output of the logger is mediated by a central worker to - -- avoid output interleaving - msg <- asks env_messager - wrapper <- asks diag_wrapper - lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> - let lcl_hsc_env = setHUG deps hsc_env - in wrapAction wrapper lcl_hsc_env $ do - res <- upsweep_inst lcl_hsc_env msg k n uid iu - cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) - return res - - -executeCompileNode :: Int - -> Int - -> Maybe HomeModInfo - -> HomeUnitGraph - -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling - -> ModSummary - -> RunMakeM HomeModInfo -executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do - me@MakeEnv{..} <- ask - -- Rehydrate any dependencies if this module had a boot file or is a signature file. - lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do - hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mod fixed_mrehydrate_mods - let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas - lcl_dynflags = ms_hspp_opts mod - let lcl_hsc_env = - -- Localise the hsc_env to use the cached flags - hscSetFlags lcl_dynflags $ - hydrated_hsc_env - -- Compile the module, locking with a semaphore to avoid too many modules - -- being compiled at the same time leading to high memory usage. - wrapAction diag_wrapper lcl_hsc_env $ do - res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n - cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags - return res) - - where - fixed_mrehydrate_mods = - case ms_hsc_src mod of - -- MP: It is probably a bit of a misimplementation in backpack that - -- compiling a signature requires an knot_var for that unit. - -- If you remove this then a lot of backpack tests fail. - HsigFile -> Just [] - _ -> mrehydrate_mods - -{- Rehydration, see Note [Rehydrating Modules] -} - -rehydrate :: HscEnv -- ^ The HPT in this HscEnv needs rehydrating. - -> [HomeModInfo] -- ^ These are the modules we want to rehydrate. - -> IO HscEnv -rehydrate hsc_env hmis = do - debugTraceMsg logger 2 $ ( - text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis))) - new_mods <- fixIO $ \new_mods -> do - let new_hpt = addListToHpt old_hpt new_mods - let new_hsc_env = hscUpdateHPT_lazy (const new_hpt) hsc_env - mds <- initIfaceCheck (text "rehydrate") new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_mods = [ (mn,hmi{ hm_details = details }) - | (hmi,details) <- zip hmis mds - , let mn = moduleName (mi_module (hm_iface hmi)) ] - return new_mods - return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env - - where - logger = hsc_logger hsc_env - to_delete = (map (moduleName . mi_module . hm_iface) hmis) - -- Filter out old modules before tying the knot, otherwise we can end - -- up with a thunk which keeps reference to the old HomeModInfo. - !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete - --- If needed, then rehydrate the necessary modules with a suitable KnotVars for the --- module currently being compiled. -maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv -maybeRehydrateBefore hsc_env _ Nothing = return hsc_env -maybeRehydrateBefore hsc_env mod (Just mns) = do - knot_var <- initialise_knot_var hsc_env - let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns - rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis - - where - initialise_knot_var hsc_env = liftIO $ - let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod) - in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv - -rehydrateAfter :: HscEnv - -> [ModuleName] - -> IO [HomeModInfo] -rehydrateAfter new_hsc mns = do - let new_hpt = hsc_HPT new_hsc - hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns - hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) hmis - return $ map (\mn -> expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) mn) mns - -{- -Note [Hydrating Modules] -~~~~~~~~~~~~~~~~~~~~~~~~ -There are at least 4 different representations of an interface file as described -by this diagram. - ------------------------------- -| On-disk M.hi | ------------------------------- - | ^ - | Read file | Write file - V | -------------------------------- -| ByteString | -------------------------------- - | ^ - | Binary.get | Binary.put - V | --------------------------------- -| ModIface (an acyclic AST) | --------------------------------- - | ^ - | hydrate | mkIfaceTc - V | ---------------------------------- -| ModDetails (lots of cycles) | ---------------------------------- - -The last step, converting a ModIface into a ModDetails is known as "hydration". - -Hydration happens in three different places - -* When an interface file is initially loaded from disk, it has to be hydrated. -* When a module is finished compiling, we hydrate the ModIface in order to generate - the version of ModDetails which exists in memory (see Note [ModDetails and --make mode]) -* When dealing with boot files and module loops (see Note [Rehydrating Modules]) - -Note [Rehydrating Modules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a module has a boot file then it is critical to rehydrate the modules on -the path between the two (see #20561). - -Suppose we have ("R" for "recursive"): -``` -R.hs-boot: module R where - data T - g :: T -> T - -A.hs: module A( f, T, g ) where - import {-# SOURCE #-} R - data S = MkS T - f :: T -> S = ...g... - -R.hs: module R where - import A - data T = T1 | T2 S - g = ...f... -``` - -== Why we need to rehydrate A's ModIface before compiling R.hs - -After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type -type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same -AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about -it.) - -When compiling R.hs, we build a TyCon for `T`. But that TyCon mentions `S`, and -it currently has an AbstractTyCon for `T` inside it. But we want to build a -fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`. - -Solution: **rehydration**. *Before compiling `R.hs`*, rehydrate all the -ModIfaces below it that depend on R.hs-boot. To rehydrate a ModIface, call -`typecheckIface` to convert it to a ModDetails. It's just a de-serialisation -step, no type inference, just lookups. - -Now `S` will be bound to a thunk that, when forced, will "see" the final binding -for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot). -But note that this must be done *before* compiling R.hs. - -== Why we need to rehydrate A's ModIface after compiling R.hs - -When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding -mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that -all those `LocalIds` are turned into completed `GlobalIds`, replete with -unfoldings etc. Alas, that will not apply to the occurrences of `g` in `f`'s -unfolding. And if we leave matters like that, they will stay that way, and *all* -subsequent modules that import A will see a crippled unfolding for `f`. - -Solution: rehydrate both R and A's ModIface together, right after completing R.hs. - -~~ Which modules to rehydrate - -We only need rehydrate modules that are -* Below R.hs -* Above R.hs-boot - -There might be many unrelated modules (in the home package) that don't need to be -rehydrated. - -== Loops with multiple boot files - -It is possible for a module graph to have a loop (SCC, when ignoring boot files) -which requires multiple boot files to break. In this case, we must perform -several hydration steps: - 1. The hydration steps described above, which are necessary for correctness. - 2. An extra hydration step at the end of compiling the entire SCC, in order to - remove space leaks, as we explain below. - -Consider the following example: - - ┌─────┐ ┌─────┐ - │ A │ │ B │ - └──┬──┘ └──┬──┘ - │ │ - ┌───▼───────────▼───┐ - │ C │ - └───┬───────────┬───┘ - │ │ - ┌────▼───┐ ┌───▼────┐ - │ A-boot │ │ B-boot │ - └────────┘ └────────┘ - -A, B and C live together in a SCC. Suppose that we compile the modules in the -order: - - A-boot, B-boot, C, A, B. - -When we come to compile A, we will perform the necessary hydration steps, -because A has a boot file. This means that C will be hydrated relative to A, -and the ModDetails for A will reference C/A. Then, when B is compiled, -C will be rehydrated again, and so B will reference C/A,B. At this point, -its interface will be hydrated relative to both A and B. -This causes a space leak: there are now two different copies of C's ModDetails, -kept alive by modules A and B. This is especially problematic if C is large. - -The way to avoid this space leak is to rehydrate an entire SCC together at the -end of compilation, so that all the ModDetails point to interfaces for .hs files. -In this example, when we hydrate A, B and C together, then both A and B will refer to -C/A,B. - -See #21900 for some more discussion. - -== Modules "above" the loop - -This dark corner is the subject of #14092. - -Suppose we add to our example -``` -X.hs module X where - import A - data XT = MkX T - fx = ...g... -``` -If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`. So: - -* Either we should delay compiling X until after R has been compiled. (This is what we do) -* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot. - -Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode. -#20200 has lots of issues, many of them now fixed; -this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758). - -The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful. -Also closely related are - * #14092 - * #14103 - --} - -executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM () -executeLinkNode hug kn uid deps = do - withCurrentUnit uid $ do - MakeEnv{..} <- ask - let dflags = hsc_dflags hsc_env - let hsc_env' = setHUG hug hsc_env - msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager - - linkresult <- liftIO $ withAbstractSem compile_sem $ do - link (ghcLink dflags) - (hsc_logger hsc_env') - (hsc_tmpfs hsc_env') - (hsc_FC hsc_env') - (hsc_hooks hsc_env') - dflags - (hsc_unit_env hsc_env') - True -- We already decided to link - msg' - (hsc_HPT hsc_env') - case linkresult of - Failed -> fail "Link Failed" - Succeeded -> return () - -{- -Note [ModuleNameSet, efficiency and space leaks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -During upsweep, the results of compiling modules are placed into a MVar. When we need -to compute the right compilation environment for a module, we consult this MVar and -set the HomeUnitGraph accordingly. This is done to avoid having to precisely track -module dependencies and recreating the HUG from scratch each time, which is very expensive. - -In serial mode (-j1), this all works out fine: a module can only be compiled -after its dependencies have finished compiling, and compilation can't be -interleaved with the compilation of other module loops. This ensures that -the HUG only ever contains finalised interfaces. - -In parallel mode, we have to be more careful: the HUG variable can contain non-finalised -interfaces, which have been started by another thread. In order to avoid a space leak -in which a finalised interface is compiled against a HPT which contains a non-finalised -interface, we have to restrict the HUG to only contain the visible modules. - -The collection of visible modules explains which transitive modules are visible -from a certain point. It is recorded in the ModuleNameSet. -Before a module is compiled, we use this set to restrict the HUG to the visible -modules only, avoiding this tricky space leak. - -Efficiency of the ModuleNameSet is of utmost importance, because a union occurs for -each edge in the module graph. To achieve this, the set is represented directly as an IntSet, -which provides suitable performance – even using a UniqSet (which is backed by an IntMap) is -too slow. The crucial test of performance here is the time taken to a do a no-op build in --make mode. - -See test "jspace" for an example which used to trigger this problem. - --} - --- See Note [ModuleNameSet, efficiency and space leaks] -type ModuleNameSet = M.Map UnitId W.Word64Set - -addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet -addToModuleNameSet uid mn s = - let k = (getKey $ getUnique $ mn) - in M.insertWith (W.union) uid (W.singleton k) s - --- | Wait for some dependencies to finish and then read from the given MVar. -wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet) -wait_deps_hug hug_var deps = do - (_, module_deps) <- wait_deps deps - hug <- liftIO $ readMVar hug_var - let pruneHomeUnitEnv uid hme = - let -- Restrict to things which are in the transitive closure to avoid retaining - -- reference to loop modules which have already been compiled by other threads. - -- See Note [ModuleNameSet, efficiency and space leaks] - !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe W.empty $ M.lookup uid module_deps) - in hme { homeUnitEnv_hpt = new } - return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps) - --- | Wait for dependencies to finish, and then return their results. -wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet) -wait_deps [] = return ([], M.empty) -wait_deps (x:xs) = do - (res, deps) <- lift $ waitResult (resultVar x) - (hmis, all_deps) <- wait_deps xs - let !new_deps = deps `unionModuleNameSet` all_deps - case res of - Nothing -> return (hmis, new_deps) - Just hmi -> return (hmi:hmis, new_deps) - where - unionModuleNameSet = M.unionWith W.union - - --- Executing the pipelines - - -label_self :: String -> IO () -label_self thread_name = do - self_tid <- CC.myThreadId - CC.labelThread self_tid thread_name - - -runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () --- Don't even initialise plugins if there are no pipelines -runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do - liftIO $ label_self "main --make thread" - case n_job of - NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines - _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines - -runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () -runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = - let env = MakeEnv { hsc_env = plugin_hsc_env - , withLogger = \_ k -> k id - , compile_sem = AbstractSem (return ()) (return ()) - , env_messager = mHscMessager - , diag_wrapper = diag_wrapper - } - in runAllPipelines (NumProcessorsLimit 1) env all_pipelines - -runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a -runNjobsAbstractSem n_jobs action = do - compile_sem <- newQSem n_jobs - n_capabilities <- getNumCapabilities - n_cpus <- getNumProcessors - let - asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) - set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n - updNumCapabilities = do - -- Setting number of capabilities more than - -- CPU count usually leads to high userspace - -- lock contention. #9221 - set_num_caps $ min n_jobs n_cpus - resetNumCapabilities = set_num_caps n_capabilities - MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem - -runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a -runWorkerLimit worker_limit action = case worker_limit of - NumProcessorsLimit n_jobs -> - runNjobsAbstractSem n_jobs action - JSemLimit sem -> - runJSemAbstractSem sem action - --- | Build and run a pipeline -runParPipelines :: WorkerLimit -- ^ How to limit work parallelism - -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module - -> (GhcMessage -> AnyGhcDiagnostic) - -> Maybe Messager -- ^ Optional custom messager to use to report progress - -> [MakeAction] -- ^ The build plan for all the module nodes - -> IO () -runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do - - - -- A variable which we write to when an error has happened and we have to tell the - -- logging thread to gracefully shut down. - stopped_var <- newTVarIO False - -- The queue of LogQueues which actions are able to write to. When an action starts it - -- will add it's LogQueue into this queue. - log_queue_queue_var <- newTVarIO newLogQueueQueue - -- Thread which coordinates the printing of logs - wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var - - - -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue. - thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) - let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } - - runWorkerLimit worker_limit $ \abstract_sem -> do - let env = MakeEnv { hsc_env = thread_safe_hsc_env - , withLogger = withParLog log_queue_queue_var - , compile_sem = abstract_sem - , env_messager = mHscMessager - , diag_wrapper = diag_wrapper - } - -- Reset the number of capabilities once the upsweep ends. - runAllPipelines worker_limit env all_pipelines - atomically $ writeTVar stopped_var True - wait_log_thread - -withLocalTmpFS :: RunMakeM a -> RunMakeM a -withLocalTmpFS 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)) - -- 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 - --- | Run the given actions and then wait for them all to finish. -runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO () -runAllPipelines worker_limit env acts = do - let single_worker = isWorkerLimitSequential worker_limit - spawn_actions :: IO [ThreadId] - spawn_actions = if single_worker - then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts) - else runLoop forkIOWithUnmask env acts - - kill_actions :: [ThreadId] -> IO () - kill_actions tids = mapM_ killThread tids - - MC.bracket spawn_actions kill_actions $ \_ -> do - mapM_ waitMakeAction acts - --- | Execute each action in order, limiting the amount of parallelism by the given --- semaphore. -runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a] -runLoop _ _env [] = return [] -runLoop fork_thread env (MakeAction act res_var :acts) = do - new_thread <- - fork_thread $ \unmask -> (do - mres <- (unmask $ run_pipeline (withLocalTmpFS 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) - -data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) - -waitMakeAction :: MakeAction -> IO () -waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar - -{- Note [GHC Heap Invariants] - ~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note is a general place to explain some of the heap invariants which should -hold for a program compiled with --make mode. These invariants are all things -which can be checked easily using ghc-debug. - -1. No HomeModInfo are reachable via the EPS. - Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains - a reference to the entire HscEnv, if we are not careful the HscEnv will - contain the HomePackageTable at the time the interface was loaded and - it will never be released. - Where? dontLeakTheHPT in GHC.Iface.Load - -2. No KnotVars are live at the end of upsweep (#20491) - Why? KnotVars contains an old stale reference to the TypeEnv for modules - which participate in a loop. At the end of a loop all the KnotVars references - should be removed by the call to typecheckLoop. - Where? typecheckLoop in GHC.Driver.Make. - -3. Immediately after a reload, no ModDetails are live. - Why? During the upsweep all old ModDetails are replaced with a new ModDetails - generated from a ModIface. If we don't clear the ModDetails before the - reload takes place then memory usage during the reload is twice as much - as it should be as we retain a copy of the ModDetails for too long. - Where? pruneCache in GHC.Driver.Make - -4. No TcGblEnv or TcLclEnv are live after typechecking is completed. - Why? By the time we get to simplification all the data structures from typechecking - should be eliminated. - Where? No one place in the compiler. These leaks can be introduced by not suitable - forcing functions which take a TcLclEnv as an argument. - -5. At the end of a successful upsweep, the number of live ModDetails equals the - number of non-boot Modules. - Why? Each module has a HomeModInfo which contains a ModDetails from that module. - Where? See Note [ModuleNameSet, efficiency and space leaks], a variety of places - in the driver are responsible. +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ViewPatterns #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- +module GHC.Driver.Make ( + depanal, depanalE, depanalPartial, + load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache, + + downsweep, + + topSortModuleGraph, + + ms_home_srcimps, ms_home_imps, + + hscSourceToIsBoot, + findExtraSigImports, + implicitRequirementsShallow, + + noModError, cyclicModuleErr, + SummaryNode, + IsBootInterface(..), mkNodeKey, + + ModNodeKey, ModNodeKeyWithUid(..), + ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith, + + -- * Re-exports from Downsweep + checkHomeUnitsClosed, + summariseModule, + summariseModuleInterface, + SummariseResult(..), + summariseFile, + + instantiationNodes, + ) where + +import GHC.Prelude +import GHC.Platform + +import GHC.Tc.Utils.Backpack +import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) + +import GHC.Runtime.Interpreter +import qualified GHC.Linker.Loader as Linker +import GHC.Linker.Types + + +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Pipeline +import GHC.Driver.Session +import GHC.Driver.DynFlags (ReexportedModule(..)) +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Main +import GHC.Driver.MakeSem +import GHC.Driver.Downsweep +import GHC.Driver.MakeAction + +import GHC.ByteCode.Types + +import GHC.Iface.Load ( cannotFindModule, readIface ) +import GHC.IfaceToCore ( typecheckIface ) +import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) + +import GHC.Data.Bag ( listToBag ) +import GHC.Data.Graph.Directed +import GHC.Data.Maybe ( expectJust ) + +import GHC.Utils.Exception ( throwIO, SomeAsyncException ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import GHC.Types.Basic +import GHC.Types.Error +import GHC.Types.Target +import GHC.Types.SourceFile +import GHC.Types.SourceError +import GHC.Types.SrcLoc +import GHC.Types.PkgQual + +import GHC.Unit +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Graph +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module.ModDetails + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Control.Concurrent.MVar +import Control.Monad +import qualified Control.Monad.Catch as MC +import Data.IORef +import Data.Maybe +import Data.List (sortOn, groupBy, sortBy) +import qualified Data.List as List +import System.FilePath + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Data.Map.Strict as M +import GHC.Types.TypeEnv +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Class +import GHC.Driver.Env.KnotVars +import Control.Monad.Trans.Maybe +import GHC.Runtime.Loader +import GHC.Utils.Constants +import GHC.Iface.Errors.Types +import Data.Function +import qualified GHC.Data.Maybe as M + +import GHC.Data.Graph.Directed.Reachability +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Home.PackageTable + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- In case of errors, just throw them. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + (errs, mod_graph) <- depanalE mkUnknownDiagnostic Nothing excluded_mods allow_dup_roots + if isEmptyMessages errs + then pure mod_graph + else throwErrors (fmap GhcDriverMessage errs) + +-- | Perform dependency analysis like in 'depanal'. +-- In case of errors, the errors and an empty module graph are returned. +depanalE :: GhcMonad m => -- New for #17459 + (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (DriverMessages, ModuleGraph) +depanalE diag_wrapper msg excluded_mods allow_dup_roots = do + hsc_env <- getSession + (errs, mod_graph) <- depanalPartial diag_wrapper msg excluded_mods allow_dup_roots + if isEmptyMessages errs + then do + hsc_env <- getSession + let one_unit_messages get_mod_errs k hue = do + errs <- get_mod_errs + unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph + + let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph + + + return $ errs `unionMessages` unused_home_mod_err + `unionMessages` unused_pkg_err + `unionMessages` unknown_module_err + + all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env) + logDiagnostics (GhcDriverMessage <$> all_errs) + setSession (setModuleGraph mod_graph hsc_env) + pure (emptyMessages, mod_graph) + else do + -- We don't have a complete module dependency graph, + -- The graph may be disconnected and is unusable. + setSession (setModuleGraph emptyMG hsc_env) + pure (errs, emptyMG) + + +-- | Perform dependency analysis like 'depanal' but return a partial module +-- graph even in the face of problems with some modules. +-- +-- Modules which have parse errors in the module header, failing +-- preprocessors or other issues preventing them from being summarised will +-- simply be absent from the returned module graph. +-- +-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the +-- new module graph. +depanalPartial + :: GhcMonad m + => (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m (DriverMessages, ModuleGraph) + -- ^ possibly empty 'Bag' of errors and a module graph. +depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + logger = hsc_logger hsc_env + + withTiming logger (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg logger 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + -- Home package modules may have been moved or deleted, and new + -- source files may have appeared in the home package that shadow + -- external package modules, so we have to discard the existing + -- cached finder data. + liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env) + + (errs, mod_graph) <- liftIO $ downsweep + hsc_env diag_wrapper msg (mgModSummaries old_graph) + excluded_mods allow_dup_roots + return (unionManyMessages errs, mod_graph) + + +-- Note [Missing home modules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Sometimes we don't want GHC to process modules that weren't specified as +-- explicit targets. For example, cabal may want to enable this warning +-- when building a library, so that GHC warns the user about modules listed +-- neither in `exposed-modules` nor in `other-modules`. +-- +-- Here "home module" means a module that doesn't come from another package. +-- +-- For example, if GHC is invoked with modules "A" and "B" as targets, +-- but "A" imports some other module "C", then GHC will issue a warning +-- about module "C" not being listed in the command line. +-- +-- The warning in enabled by `-Wmissing-home-modules`. See #13129 +warnMissingHomeModules :: DynFlags -> [Target] -> ModuleGraph -> DriverMessages +warnMissingHomeModules dflags targets mod_graph = + if null missing + then emptyMessages + else warn + where + diag_opts = initDiagOpts dflags + + -- We need to be careful to handle the case where (possibly + -- path-qualified) filenames (aka 'TargetFile') rather than module + -- names are being passed on the GHC command-line. + -- + -- For instance, `ghc --make src-exe/Main.hs` and + -- `ghc --make -isrc-exe Main` are supposed to be equivalent. + -- Note also that we can't always infer the associated module name + -- directly from the filename argument. See #13727. + is_known_module mod = + is_module_target mod + || + maybe False is_file_target (ml_hs_file (ms_location mod)) + + is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets + + is_file_target file = Set.member (withoutExt file) file_targets + + file_targets = Set.fromList (mapMaybe file_target targets) + + file_target Target {targetId} = + case targetId of + TargetModule _ -> Nothing + TargetFile file _ -> + Just (withoutExt (augmentByWorkingDirectory dflags file)) + + mod_targets = Set.fromList (mod_target <$> targets) + + mod_target Target {targetUnitId, targetId} = + case targetId of + TargetModule name -> (name, targetUnitId) + TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId) + + withoutExt = fst . splitExtension + + missing = map (moduleName . ms_mod) $ + filter (not . is_known_module) $ + (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) + (mgModSummaries mod_graph)) + + warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan + $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags) + +-- Check that any modules we want to reexport or hide are actually in the package. +warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages +warnUnknownModules hsc_env dflags mod_graph = do + reexported_warns <- filterM check_reexport reexported_mods + return $ final_msgs hidden_warns reexported_warns + where + diag_opts = initDiagOpts dflags + + unit_mods = Set.fromList (map ms_mod_name + (filter (\ms -> ms_unitid ms == homeUnitId_ dflags) + (mgModSummaries mod_graph))) + + reexported_mods = reexportedModules dflags + hidden_mods = hiddenModules dflags + + hidden_warns = hidden_mods `Set.difference` unit_mods + + lookupModule mn = findImportedModule hsc_env mn NoPkgQual + + check_reexport mn = do + fr <- lookupModule (reexportFrom mn) + case fr of + Found _ m -> return (moduleUnitId m == homeUnitId_ dflags) + _ -> return True + + + warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan + $ diagnostic + + final_msgs hidden_warns reexported_warns + = + unionManyMessages $ + [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)] + ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)] + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo [HomeUnitModule] + -- ^ Load only the given modules and its dependencies. + -- If empty, we load none of the targets + | LoadDependenciesOf HomeUnitModule + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +{- +Note [Caching HomeModInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +API clients who call `load` like to cache the HomeModInfo in memory between +calls to this function. In the old days, this cache was a simple MVar which stored +a HomePackageTable. This was insufficient, as the interface files for boot modules +were not recorded in the cache. In the less old days, the cache was returned at the +end of load, and supplied at the start of load, however, this was not sufficient +because it didn't account for the possibility of exceptions such as SIGINT (#20780). + +So now, in the current day, we have this ModIfaceCache abstraction which +can incrementally be updated during the process of upsweep. This allows us +to store interface files for boot modules in an exception-safe way. + +When the final version of an interface file is completed then it is placed into +the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache. + +Note that because we only store the ModIface and Linkable in the ModIfaceCache, +hydration and rehydration is totally irrelevant, and we just store the CachedIface as +soon as it is completed. + +-} + + +-- Abstract interface to a cache of HomeModInfo +-- See Note [Caching HomeModInfo] +data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface] + , iface_addToCache :: CachedIface -> IO () } + +addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO () +addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l) + +data CachedIface = CachedIface { cached_modiface :: !ModIface + , cached_linkable :: !HomeModLinkable } + +instance Outputable CachedIface where + ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln] + +noIfaceCache :: Maybe ModIfaceCache +noIfaceCache = Nothing + +newIfaceCache :: IO ModIfaceCache +newIfaceCache = do + ioref <- newIORef [] + return $ + ModIfaceCache + { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c)) + , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ())) + } + + + + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the backend (see 'DynFlags.backend' field) compiling +-- and loading may result in files being created on disk. +-- +-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether +-- successful or not. +-- +-- If errors are encountered during dependency analysis, the module `depanalE` +-- returns together with the errors an empty ModuleGraph. +-- After processing this empty ModuleGraph, the errors of depanalE are thrown. +-- All other errors are reported using the 'defaultWarnErrLogger'. + +load :: GhcMonad f => LoadHowMuch -> f SuccessFlag +load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much + +mkBatchMsg :: HscEnv -> Messager +mkBatchMsg hsc_env = + if length (hsc_all_home_unit_ids hsc_env) > 1 + -- This also displays what unit each module is from. + then batchMultiMsg + else batchMsg + + +loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them. + -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user. + -- If you are using the GHC API you can use this to override how messages + -- created during 'loadWithCache' are displayed to the user. + -> LoadHowMuch -- ^ How much `loadWithCache` should load + -> m SuccessFlag +loadWithCache cache diag_wrapper how_much = do + msg <- mkBatchMsg <$> getSession + (errs, mod_graph) <- depanalE diag_wrapper (Just msg) [] False -- #17459 + success <- load' cache how_much diag_wrapper (Just msg) mod_graph + if isEmptyMessages errs + then pure success + else throwErrors (fmap GhcDriverMessage errs) + +-- Note [Unused packages] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- Cabal passes `-package-id` flag for each direct dependency. But GHC +-- loads them lazily, so when compilation is done, we have a list of all +-- actually loaded packages. All the packages, specified on command line, +-- but never loaded, are probably unused dependencies. + +warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages +warnUnusedPackages us dflags mod_graph = + let diag_opts = initDiagOpts dflags + + home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph) + + -- Only need non-source imports here because SOURCE imports are always HPT + loadedPackages = concat $ + mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs) + $ concatMap ms_imps home_mod_sum + + used_args = Set.fromList (map unitId loadedPackages) + + resolve (u,mflag) = do + -- The units which we depend on via the command line explicitly + flag <- mflag + -- Which we can find the UnitInfo for (should be all of them) + ui <- lookupUnit us u + -- Which are not explicitly used + guard (Set.notMember (unitId ui) used_args) + return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag) + + unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us) + + warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs) + + in if null unusedArgs + then emptyMessages + else warn + +-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any +-- path from module to its boot file. +data ModuleGraphNodeWithBootFile + = ModuleGraphNodeWithBootFile + ModuleGraphNode + -- ^ The module itself (not the hs-boot module) + [NodeKey] + -- ^ The modules in between the module and its hs-boot file, + -- not including the hs-boot file itself. + + +instance Outputable ModuleGraphNodeWithBootFile where + ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps + +-- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected +-- component of the module graph. +data BuildPlan + -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle) + = SingleModule ModuleGraphNode + -- | A resolved cycle, linearised by hs-boot files + | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile] + -- | An actual cycle, which wasn't resolved by hs-boot files + | UnresolvedCycle [ModuleGraphNode] + +instance Outputable BuildPlan where + ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn) + ppr (ResolvedCycle mgn) = text "ResolvedCycle:" <+> ppr mgn + ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn + + +-- Just used for an assertion +countMods :: BuildPlan -> Int +countMods (SingleModule _) = 1 +countMods (ResolvedCycle ns) = length ns +countMods (UnresolvedCycle ns) = length ns + +-- See Note [Upsweep] for a high-level description. +createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan] +createBuildPlan mod_graph maybe_top_mod = + let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod + + -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. + build_plan :: [BuildPlan] + build_plan + -- Fast path, if there are no boot modules just do a normal toposort + | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph + | otherwise = toBuildPlan cycle_mod_graph [] + + toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] + toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn) + toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn) + -- Interesting case + toBuildPlan ((CyclicSCC nodes):sccs) mgn = + let acyclic = collapseAcyclic (topSortWithBoot mgn) + -- Now perform another toposort but just with these nodes and relevant hs-boot files. + -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. + mresolved_cycle = collapseSCC (topSortWithBoot nodes) + in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] + + -- Compute the intermediate modules between a file and its hs-boot file. + -- See Step 2a in Note [Upsweep] + boot_path mn uid = + Set.toList $ + -- Don't include the boot module itself + Set.filter ((/= NodeKey_Module (key IsBoot)) . mkNodeKey) $ + -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are + -- the transitive dependencies of the non-boot file which transitively depend + -- on the boot file. + Set.filter (\(mkNodeKey -> nk) -> + nodeKeyUnitId nk == uid -- Cheap test + && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $ + Set.fromList $ + expectJust (mgReachable mod_graph (NodeKey_Module (key NotBoot))) + where + key ib = ModNodeKeyWithUid (GWIB mn ib) uid + + + -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists + boot_modules = mkModuleEnv + [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn))) + | m@(ModuleNode _ ms) <- mgModSummaries' mod_graph + , let mn = moduleNodeInfoModule ms + , isBootModuleNodeInfo ms == IsBoot] + + select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode] + select_boot_modules = mapMaybe (fmap fst . get_boot_module) + + get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]) + get_boot_module (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + = lookupModuleEnv boot_modules (moduleNodeInfoModule ms) + get_boot_module _ = Nothing + + -- Any cycles should be resolved now + collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] + -- Must be at least two nodes, as we were in a cycle + collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2] + collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes) + -- Cyclic + collapseSCC nodes = Left (flattenSCCs nodes) + + toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile + toNodeWithBoot mn = + case get_boot_module mn of + -- The node doesn't have a boot file + Nothing -> Left mn + -- The node does have a boot file + Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path))) + + -- The toposort and accumulation of acyclic modules is solely to pick-up + -- hs-boot files which are **not** part of cycles. + collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan] + collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes + collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes + collapseAcyclic [] = [] + + topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing + in + -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module + -- graph is pruned, reducing the number of 'build_plan' elements. + -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added + -- later in the processing. + assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))]) + build_plan + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 + +-- | Generalized version of 'load' which also supports a custom +-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally +-- produced by calling 'depanal'. +load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag +load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do + -- In normal usage plugins are initialised already by ghc/Main.hs this is protective + -- for any client who might interact with GHC via load'. + -- See Note [Timing of plugin initialization] + initializeSessionPlugins + modifySession (setModuleGraph mod_graph) + guessOutputFile + hsc_env <- getSession + + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let interp = hscInterp hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = + Set.fromList [ Module (ms_unitid s) (ms_mod_name s) + | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot] + -- TODO: Figure out what the correct form of this assert is. It's violated + -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot + -- files without corresponding hs files. + -- bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + -- not (ms_mod_name s `elem` all_home_mods)] + -- assert (null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo ms) = checkMods ms + checkHowMuch (LoadDependenciesOf m) = checkMods [m] + checkHowMuch _ = id + + checkMods ms and_then = + case List.partition (`Set.member` all_home_mods) ms of + (_, []) -> and_then + (_, not_found_mods) -> do + let + mkModuleNotFoundError m = + mkPlainErrorMsgEnvelope noSrcSpan + $ GhcDriverMessage + $ DriverModuleNotFound (moduleUnit m) (moduleName m) + throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods] + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. It is just used for warning about unnecessary source imports. + let mg2_with_srcimps :: [SCC ModuleGraphNode] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps) + + let maybe_top_mods = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just [m] + _ -> Nothing + + build_plan = createBuildPlan mod_graph maybe_top_mods + + + cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache + let + -- prune the HPT so everything is not retained when doing an + -- upsweep. + !pruned_cache = pruneCache cache + [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules mg2_with_srcimps))] + + + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write an empty HPT to allow the old HPT to be GC'd. + + let pruneHomeUnitEnv hme = do + emptyHPT <- liftIO emptyHomePackageTable + pure $! hme{ homeUnitEnv_hpt = emptyHPT } + hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph $ hsc_unit_env hsc_env) + let ue' = (hsc_unit_env hsc_env){ ue_home_unit_graph = hug' } + setSession $ discardIC hsc_env{hsc_unit_env = ue' } + hsc_env <- getSession + + -- Unload everything + liftIO $ unload interp hsc_env + + liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep") + 2 (ppr build_plan)) + + worker_limit <- liftIO $ mkWorkerLimit dflags + + (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do + hsc_env <- getSession + liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan + + -- At this point, all the HPT variables will be populated, but we don't want + -- to leak the contents of a failed session. + liftIO $ restrictDepsHscEnv new_deps hsc_env + case upsweep_ok of + Failed -> loadFinish upsweep_ok + Succeeded -> do + liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.") + loadFinish upsweep_ok + + + +-- | Finish up after a load. +loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok + = do modifySession discardIC + return all_ok + + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + -- Force mod_graph to avoid leaking env + let !mod_graph = hsc_mod_graph env + new_home_graph = + flip fmap (hsc_HUG env) $ \hue -> + let dflags = homeUnitEnv_dflags hue + platform = targetPlatform dflags + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + ms <- mgLookupModule mod_graph (mainModIs hue) + ml_hs_file (moduleNodeInfoLocation ms) + name = fmap dropExtension mainModuleSrcPath + + -- MP: This exception is quite sensitive to being forced, if you + -- force it here then the error message is different because it gets + -- caught by a different error handler than the test (T9930fail) expects. + -- Putting an exception into DynFlags is probably not a great design but + -- I'll write this comment rather than more eagerly force the exception. + name_exe = do + -- we must add the .exe extension unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by GHC.Driver.Pipeline.exeFileName. See #2248 + !name' <- case platformArchOS platform of + ArchOS _ OSMinGW32 -> fmap (<.> "exe") name + ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name + _ -> name + mainModuleSrcPath' <- mainModuleSrcPath + -- #9930: don't clobber input files (unless they ask for it) + if name' == mainModuleSrcPath' + then throwGhcException . UsageError $ + "default output name would overwrite the input file; " ++ + "must specify -o explicitly" + else Just name' + in + case outputFile_ dflags of + Just _ -> hue + Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } } + in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } } + +-- ----------------------------------------------------------------------------- +-- +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. +-- Note [GHC Heap Invariants] +pruneCache :: [CachedIface] + -> [ModSummary] + -> [HomeModInfo] +pruneCache hpt summ + = strictMap prune hpt + where prune (CachedIface { cached_modiface = iface + , cached_linkable = linkable + }) = HomeModInfo iface emptyModDetails linkable' + where + modl = miKey iface + linkable' + | Just ms <- M.lookup modl ms_map + , mi_src_hash iface == Just (ms_hs_hash ms) + = linkable + | otherwise + = emptyHomeModInfoLinkable + + -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error. + ms_map = M.fromListWith + (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2)) + ms2) + [(msKey ms, ms) | ms <- summ] + +-- --------------------------------------------------------------------------- +-- +-- | Unloading +unload :: Interp -> HscEnv -> IO () +unload interp hsc_env + = case ghcLink (hsc_dflags hsc_env) of + LinkInMemory -> Linker.unload interp hsc_env [] + _other -> return () + + +{- Parallel Upsweep + +The parallel upsweep attempts to concurrently compile the modules in the +compilation graph using multiple Haskell threads. + +The Algorithm + +* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is +a pair of an `IO a` action and a `MVar a`, where to place the result. + The list is sorted topologically, so can be executed in order without fear of + blocking. +* runPipelines takes this list and eventually passes it to runLoop which executes + each action and places the result into the right MVar. +* The amount of parallelism is controlled by a semaphore. This is just used around the + module compilation step, so that only the right number of modules are compiled at + the same time which reduces overall memory usage and allocations. +* Each proper node has a LogQueue, which dictates where to send it's output. +* The LogQueue is placed into the LogQueueQueue when the action starts and a worker + thread processes the LogQueueQueue printing logs for each module in a stable order. +* The result variable for an action producing `a` is of type `Maybe a`, therefore + it is still filled on a failure. If a module fails to compile, the + failure is propagated through the whole module graph and any modules which didn't + depend on the failure can still be compiled. This behaviour also makes the code + quite a bit cleaner. +-} + + +{- + +Note [--make mode] +~~~~~~~~~~~~~~~~~ +There are two main parts to `--make` mode. + +1. `downsweep`: Starts from the top of the module graph and computes dependencies. +2. `upsweep`: Starts from the bottom of the module graph and compiles modules. + +The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which +computers how to build this ModuleGraph. + +Note [Upsweep] +~~~~~~~~~~~~~~ +Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes +the plan in order to compile the project. + +The first step is computing the build plan from a 'ModuleGraph'. + +The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for +how to build all the modules. + +``` +data BuildPlan = SingleModule ModuleGraphNode -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle + | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot] -- A resolved cycle, linearised by hs-boot files + | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files +``` + +The plan is computed in two steps: + +Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains + cycles. +Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should + result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle. +Step 2a: For each module in the cycle, if the module has a boot file then compute the + modules on the path between it and the hs-boot file. + These are the intermediate modules which: + (1) are (transitive) dependencies of the non-boot module, and + (2) have the boot module as a (transitive) dependency. + In particular, all such intermediate modules must appear in the same unit as + the module under consideration, as module cycles cannot cross unit boundaries. + This information is stored in ModuleGraphNodeWithBoot. + +The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function. + +* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions. +* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented + with a consistent knot-tied version of modules at the end. + - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration + is performed both before and after the module in question is compiled. + See Note [Hydrating Modules] for more information. +* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files + and are reported as an error to the user. + +The main trickiness of `interpretBuildPlan` is deciding which version of a dependency +is visible from each module. For modules which are not in a cycle, there is just +one version of a module, so that is always used. For modules in a cycle, there are two versions of +'HomeModInfo'. + +1. Internal to loop: The version created whilst compiling the loop by upsweep_mod. +2. External to loop: The knot-tied version created by typecheckLoop. + +Whilst compiling a module inside the loop, we need to use the (1). For a module which +is outside of the loop which depends on something from in the loop, the (2) version +is used. + +As the plan is interpreted, which version of a HomeModInfo is visible is updated +by updating a map held in a state monad. So after a loop has finished being compiled, +the visible module is the one created by typecheckLoop and the internal version is not +used again. + +This plan also ensures the most important invariant to do with module loops: + +> If you depend on anything within a module loop, before you can use the dependency, + the whole loop has to finish compiling. + +The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs +of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running +the action. This list is topologically sorted, so can be run in order to compute +the whole graph. + +As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which +can be queried at the end to get the result of all modules at the end, with their proper +visibility. For example, if any module in a loop fails then all modules in that loop will +report as failed because the visible node at the end will be the result of checking +these modules together. + +-} + +-- | Simple wrapper around MVar which allows a functor instance. +data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a)) + +deriving instance Functor ResultVar + +mkResultVar :: MVar (Maybe a) -> ResultVar a +mkResultVar = ResultVar id + +-- | Block until the result is ready. +waitResult :: ResultVar a -> MaybeT IO a +waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var) + +data BuildResult = BuildResult { _resultOrigin :: ResultOrigin + , resultVar :: ResultVar (Maybe HomeModInfo) + } + +-- The origin of this result var, useful for debugging +data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show) + +data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show) + +mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult +mkBuildResult = BuildResult + + +data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult + -- The current way to build a specific TNodeKey, without cycles this just points to + -- the appropriate result of compiling a module but with + -- cycles there can be additional indirection and can point to the result of typechecking a loop + , nNODE :: Int + } + +nodeId :: BuildM Int +nodeId = do + n <- gets nNODE + modify (\m -> m { nNODE = n + 1 }) + return n + + +setModulePipeline :: NodeKey -> BuildResult -> BuildM () +setModulePipeline mgn build_result = do + modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) }) + +type BuildMap = M.Map NodeKey BuildResult + +getBuildMap :: BuildM BuildMap +getBuildMap = gets buildDep + +getDependencies :: [NodeKey] -> BuildMap -> [BuildResult] +getDependencies direct_deps build_map = + strictMap (expectJust . flip M.lookup build_map) direct_deps + +type BuildM a = StateT BuildLoopState IO a + + + + +-- | Given the build plan, creates a graph which indicates where each NodeKey should +-- get its direct dependencies from. This might not be the corresponding build action +-- if the module participates in a loop. This step also labels each node with a number for the output. +-- See Note [Upsweep] for a high-level description. +interpretBuildPlan :: HomeUnitGraph + -> Maybe ModIfaceCache + -> M.Map ModNodeKeyWithUid HomeModInfo + -> [BuildPlan] + -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle + , [MakeAction] -- Actions we need to run in order to build everything + , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end. +interpretBuildPlan hug mhmi_cache old_hpt plan = do + ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1) + let wait = collect_results (buildDep build_map) + return (mcycle, plans, wait) + + where + collect_results build_map = + sequence (map (\br -> collect_result (resultVar br)) (M.elems build_map)) + where + collect_result res_var = runMaybeT (waitResult res_var) + + -- Just used for an assertion + count_mods :: BuildPlan -> Int + count_mods (SingleModule m) = count_m m + count_mods (ResolvedCycle ns) = length ns + count_mods (UnresolvedCycle ns) = length ns + + count_m (UnitNode {}) = 0 + count_m _ = 1 + + n_mods = sum (map count_mods plan) + + buildLoop :: [BuildPlan] + -> BuildM (Maybe [ModuleGraphNode], [MakeAction]) + -- Build the abstract pipeline which we can execute + -- Building finished + buildLoop [] = return (Nothing, []) + buildLoop (plan:plans) = + case plan of + -- If there was no cycle, then typecheckLoop is not necessary + SingleModule m -> do + one_plan <- buildSingleModule Nothing NoLoop m + (cycle, all_plans) <- buildLoop plans + return (cycle, one_plan : all_plans) + + -- For a resolved cycle, depend on everything in the loop, then update + -- the cache to point to this node rather than directly to the module build + -- nodes + ResolvedCycle ms -> do + pipes <- buildModuleLoop ms + (cycle, graph) <- buildLoop plans + return (cycle, pipes ++ graph) + + -- Can't continue past this point as the cycle is unresolved. + UnresolvedCycle ns -> return (Just ns, []) + + buildSingleModule :: Maybe [NodeKey] -- Modules we need to rehydrate before compiling this module + -> ResultOrigin + -> ModuleGraphNode -- The node we are compiling + -> BuildM MakeAction + buildSingleModule rehydrate_nodes origin mod = do + !build_map <- getBuildMap + -- 1. Get the direct dependencies of this module + let direct_deps = mgNodeDependencies False mod + -- It's really important to force build_deps, or the whole buildMap is retained, + -- which would retain all the result variables, preventing us from collecting them + -- after they are no longer used. + !build_deps = getDependencies direct_deps build_map + !build_action <- + case mod of + InstantiationNode uid iu -> do + mod_idx <- nodeId + return $ withCurrentUnit (mgNodeUnitId mod) $ do + !_ <- wait_deps build_deps + executeInstantiationNode mod_idx n_mods hug uid iu + return Nothing + ModuleNode _build_deps ms -> do + let !old_hmi = M.lookup (mnKey ms) old_hpt + rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes + mod_idx <- nodeId + return $ withCurrentUnit (mgNodeUnitId mod) $ do + !_ <- wait_deps build_deps + hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms + -- Write the HMI to an external cache (if one exists) + -- See Note [Caching HomeModInfo] + liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi + -- Make sure the result is written to the HPT var + liftIO $ HUG.addHomeModInfoToHug hmi hug + return (Just hmi) + LinkNode _nks uid -> do + mod_idx <- nodeId + return $ withCurrentUnit (mgNodeUnitId mod) $ do + !_ <- wait_deps build_deps + executeLinkNode hug (mod_idx, n_mods) uid direct_deps + return Nothing + UnitNode {} -> return $ return Nothing + + + res_var <- liftIO newEmptyMVar + let result_var = mkResultVar res_var + setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) + return $! (MakeAction build_action res_var) + + + buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction] + buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do + ma <- buildSingleModule (Just deps) (Loop Initialise) mn + -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files" + rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps)) + return $ [ma, rehydrate_action] + + + buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction] + buildModuleLoop ms = do + build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms + let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot + extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot + let loop_mods = map extract ms + -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files" + -- Fixes the space leak described in that note. + rehydrate_action <- rehydrateAction Finalised loop_mods + + return $ build_modules ++ [rehydrate_action] + + -- An action which rehydrates the given keys + rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction + rehydrateAction origin deps = do + !build_map <- getBuildMap + res_var <- liftIO newEmptyMVar + let loop_unit :: UnitId + !loop_unit = nodeKeyUnitId (gwib_mod (head deps)) + !build_deps = getDependencies (map gwib_mod deps) build_map + let loop_action = withCurrentUnit loop_unit $ do + !_ <- wait_deps build_deps + hsc_env <- asks hsc_env + let mns :: [ModuleName] + mns = mapMaybe (nodeKeyModName . gwib_mod) deps + + hmis' <- liftIO $ rehydrateAfter hsc_env mns + + checkRehydrationInvariant hmis' deps + + -- Add hydrated interfaces to global variable + liftIO $ mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi hug) hmis' + return hmis' + + let fanout i = Just . (!! i) <$> mkResultVar res_var + -- From outside the module loop, anyone must wait for the loop to finish and then + -- use the result of the rehydrated iface. This makes sure that things not in the + -- module loop will see the updated interfaces for all the identifiers in the loop. + boot_key :: NodeKey -> NodeKey + boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } ) + boot_key k = pprPanic "boot_key" (ppr k) + + update_module_pipeline (m, i) = + case gwib_isBoot m of + NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i)) + IsBoot -> do + setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i)) + -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot + setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i)) + + let deps_i = zip deps [0..] + mapM update_module_pipeline deps_i + + return $ MakeAction loop_action res_var + + -- Checks that the interfaces returned from hydration match-up with the names of the + -- modules which were fed into the function. + checkRehydrationInvariant hmis deps = + let hmi_names = map (moduleName . mi_module . hm_iface) hmis + start = mapMaybe (nodeKeyModName . gwib_mod) deps + in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start) + + +withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a +withCurrentUnit uid = do + local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)}) + +upsweep + :: WorkerLimit -- ^ The number of workers we wish to run in parallel + -> HscEnv -- ^ The base HscEnv, which is augmented for each module + -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to + -> (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager + -> M.Map ModNodeKeyWithUid HomeModInfo + -> [BuildPlan] + -> IO (SuccessFlag, [HomeModInfo]) +upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do + (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan + runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines + res <- collect_result + + let completed = [m | Just (Just m) <- res] + + -- Handle any cycle in the original compilation graph and return the result + -- of the upsweep. + case cycle of + Just mss -> do + throwOneError $ cyclicModuleErr mss + Nothing -> do + let success_flag = successIf (all isJust res) + return (success_flag, completed) + +toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo +toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis]) + +upsweep_inst :: HscEnv + -> Maybe Messager + -> Int -- index of module + -> Int -- total number of modules + -> UnitId + -> InstantiatedUnit + -> IO () +upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do + case mHscMessage of + Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid) + Nothing -> return () + runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid + pure () + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> Maybe Messager + -> Maybe HomeModInfo + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo +upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do + hmi <- compileOne' mHscMessage hsc_env summary + mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi) + + -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module + -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I + -- am unsure if this is sound (wrt running TH splices for example). + -- This function only does anything if the linkable produced is a BCO, which + -- used to only happen with the bytecode backend, but with + -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating + -- object code, see #25230. + hscInsertHPT hmi hsc_env + addSptEntries (hsc_env) + (homeModInfoByteCode hmi) + + return hmi + +-- | Add the entries from a BCO linkable to the SPT table, see +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. +addSptEntries :: HscEnv -> Maybe Linkable -> IO () +addSptEntries hsc_env mlinkable = + hscAddSptEntries hsc_env + [ spt + | linkable <- maybeToList mlinkable + , bco <- linkableBCOs linkable + , spt <- bc_spt_entries bco + ] + + +-- Note [When source is considered modified] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A number of functions in GHC.Driver accept a SourceModified argument, which +-- is part of how GHC determines whether recompilation may be avoided (see the +-- definition of the SourceModified data type for details). +-- +-- Determining whether or not a source file is considered modified depends not +-- only on the source file itself, but also on the output files which compiling +-- that module would produce. This is done because GHC supports a number of +-- flags which control which output files should be produced, e.g. -fno-code +-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the +-- source file has been modified since the last compile, but also whether the +-- source file has been modified since the last compile which produced all of +-- the output files which have been requested. +-- +-- Specifically, a source file is considered unmodified if it is up-to-date +-- relative to all of the output files which have been requested. Whether or +-- not an output file is up-to-date depends on what kind of file it is: +-- +-- * iface (.hi) files are considered up-to-date if (and only if) their +-- mi_src_hash field matches the hash of the source file, +-- +-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date +-- if (and only if) their modification times on the filesystem are greater +-- than or equal to the modification time of the corresponding .hi file. +-- +-- Why do we use '>=' rather than '>' for output files other than the .hi file? +-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a +-- resolution of 2 seconds), we may often find that the .hi and .o files have +-- the same modification time. Using >= is slightly unsafe, but it matches +-- make's behaviour. +-- +-- This strategy allows us to do the minimum work necessary in order to ensure +-- that all the files the user cares about are up-to-date; e.g. we should not +-- worry about .o files if the user has indicated that they are not interested +-- in them via -fno-code. See also #9243. +-- +-- Note that recompilation avoidance is dependent on .hi files being produced, +-- which does not happen if -fno-write-interface -fno-code is passed. That is, +-- passing -fno-write-interface -fno-code means that you cannot benefit from +-- recompilation avoidance. See also Note [-fno-code mode]. +-- +-- The correctness of this strategy depends on an assumption that whenever we +-- are producing multiple output files, the .hi file is always written first. +-- If this assumption is violated, we risk recompiling unnecessarily by +-- incorrectly regarding non-.hi files as outdated. +-- + +-- --------------------------------------------------------------------------- +-- +-- | Topological sort of the module graph +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> ModuleGraph + -> Maybe [HomeUnitModule] + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModuleGraphNode] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic +topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = + topSortModules drop_hs_boot_nodes + (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph) + mb_root_mod + + + where + -- In order to get the "right" ordering + -- Module nodes must be in reverse lexigraphic order. + -- All modules nodes must appear before package nodes. + -- + -- MP: This is just the ordering which the tests needed in Jan 2025, it does + -- not arise from nature. + -- + -- Given the current implementation of scc, the result is in + -- The order is sensitive to the internal implementation in Data.Graph, + -- if it changes in future then this ordering will need to be modified. + -- + -- The SCC algorithm firstly transposes the input graph and then + -- performs dfs on the vertices in the order which they are originally given. + -- Therefore, if `ExternalUnit` nodes are first, the order returned will + -- be determined by the order the dependencies are stored in the transposed graph. + moduleGraphNodeRank :: NodeKey -> Int + moduleGraphNodeRank k = + case k of + NodeKey_Unit {} -> 0 + NodeKey_Module {} -> 1 + NodeKey_Link {} -> 2 + NodeKey_ExternalUnit {} -> 3 + + cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2) + `mappend` compare k2 k1 + +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode] +topSortModules drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = + moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just mods -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let + findNodeForModule (Module uid root_mod) + | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid + , graph `hasVertexG` node + = seq node node + | otherwise + = throwGhcException (ProgramError "module does not exist") + roots = fmap findNodeForModule mods + in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots)) + +newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } + deriving (Functor, Traversable, Foldable) + +emptyModNodeMap :: ModNodeMap a +emptyModNodeMap = ModNodeMap Map.empty + +modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a +modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m) + +modNodeMapElems :: ModNodeMap a -> [a] +modNodeMapElems (ModNodeMap m) = Map.elems m + +modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a +modNodeMapLookup k (ModNodeMap m) = Map.lookup k m + +modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a +modNodeMapSingleton k v = ModNodeMap (M.singleton k v) + +modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a +modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n) + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m () +warnUnnecessarySourceImports sccs = do + diag_opts <- initDiagOpts <$> getDynFlags + when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do + let check ms = + let mods_in_this_cycle = map moduleNodeInfoModuleName ms in + [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: Located ModuleName -> MsgEnvelope GhcMessage + warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts + loc (DriverUnnecessarySourceImports mod) + logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs)) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +-- Defer and group warning, error and fatal messages so they will not get lost +-- in the regular output. +withDeferredDiagnostics :: GhcMonad m => m a -> m a +withDeferredDiagnostics f = do + dflags <- getDynFlags + if not $ gopt Opt_DeferDiagnostics dflags + then f + else do + warnings <- liftIO $ newIORef [] + errors <- liftIO $ newIORef [] + fatals <- liftIO $ newIORef [] + logger <- getLogger + + let deferDiagnostics _dflags !msgClass !srcSpan !msg = do + let action = logMsg logger msgClass srcSpan msg + case msgClass of + MCDiagnostic SevWarning _reason _code + -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) + MCDiagnostic SevError _reason _code + -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) + MCFatal + -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) + _ -> action + + printDeferredDiagnostics = liftIO $ + forM_ [warnings, errors, fatals] $ \ref -> do + -- This IORef can leak when the dflags leaks, so let us always + -- reset the content. The lazy variant is used here as we want to force + -- this error if the IORef is ever accessed again, rather than now. + -- See #20981 for an issue which discusses this general issue. + let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else [] + actions <- atomicModifyIORef ref $ \i -> (landmine, i) + sequence_ $ reverse actions + + MC.bracket + (pushLogHookM (const deferDiagnostics)) + (\_ -> popLogHookM >> printDeferredDiagnostics) + (\_ -> f) + +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage +-- ToDo: we don't have a proper line number for this error +noModError hsc_env loc wanted_mod err + = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ + DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot)) + +{- +noHsFileErr :: SrcSpan -> String -> DriverMessages +noHsFileErr loc path + = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path) + -} + + + +cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = assert (not (null mss)) $ + case findCycle graph of + Nothing -> pprPanic "Unexpected non-cycle" (ppr mss) + Just path -> mkPlainErrorMsgEnvelope src_span $ + GhcDriverMessage $ DriverModuleGraphCycle path + where + src_span = maybe noSrcSpan (mkFileSrcSpan . moduleNodeInfoLocation) (mgNodeIsModule (head path)) + where + graph :: [Node NodeKey ModuleGraphNode] + graph = + [ DigraphNode + { node_payload = ms + , node_key = mkNodeKey ms + , node_dependencies = mgNodeDependencies False ms + } + | ms <- mss + ] + +cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () +cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = + if gopt Opt_KeepTmpFiles dflags + then liftIO $ keepCurrentModuleTempFiles logger tmpfs + else liftIO $ cleanCurrentModuleTempFiles logger tmpfs + + +-- | Thin each HPT variable to only contain keys from the given dependencies. +-- This is used at the end of upsweep to make sure that only completely successfully loaded +-- modules are visible for subsequent operations. +restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO () +restrictDepsHscEnv deps hsc_env = + let deps_with_unit = map (\xs -> (fst (head xs), map snd xs)) $ groupBy ((==) `on` fst) (sortOn fst (map go deps)) + hug = ue_home_unit_graph $ hsc_unit_env hsc_env + go hmi = (hmi_unit, hmi) + where + hmi_mod = mi_module (hm_iface hmi) + hmi_unit = toUnitId (moduleUnit hmi_mod) + in HUG.restrictHug deps_with_unit hug + + +setHUG :: HomeUnitGraph -> HscEnv -> HscEnv +setHUG deps hsc_env = + hscUpdateHUG (const $ deps) hsc_env + +-- | Wrap an action to catch and handle exceptions. +wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a) +wrapAction msg_wrapper hsc_env k = do + let lcl_logger = hsc_logger hsc_env + lcl_dynflags = hsc_dflags hsc_env + print_config = initPrintConfig lcl_dynflags + logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err) + -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle + -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches` + -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to + -- internally using forkIO. + mres <- MC.try $ prettyPrintGhcErrors lcl_logger $ k + case mres of + Right res -> return $ Just res + Left exc -> do + case fromException exc of + Just (err :: SourceError) + -> logg err + Nothing -> case fromException exc of + -- ThreadKilled in particular needs to actually kill the thread. + -- So rethrow that and the other async exceptions + Just (err :: SomeAsyncException) -> throwIO err + _ -> errorMsg lcl_logger (text (show exc)) + return Nothing + + + + +executeInstantiationNode :: Int + -> Int + -> HomeUnitGraph + -> UnitId + -> InstantiatedUnit + -> RunMakeM () +executeInstantiationNode k n deps uid iu = do + env <- ask + -- Output of the logger is mediated by a central worker to + -- avoid output interleaving + msg <- asks env_messager + wrapper <- asks diag_wrapper + lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> + let lcl_hsc_env = setHUG deps hsc_env + in wrapAction wrapper lcl_hsc_env $ do + res <- upsweep_inst lcl_hsc_env msg k n uid iu + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) + return res + + +-- | executeCompileNode interprets how --make module should compile a ModuleNode +-- +-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check +-- if the interface file exists and is up to date. If it is, we return those. +-- Otherwise, we compile the module and return the new HomeModInfo. +-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface +-- and artifacts from disk. + +executeCompileNode :: Int + -> Int + -> Maybe HomeModInfo + -> HomeUnitGraph + -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling + -> ModuleNodeInfo + -> RunMakeM HomeModInfo +executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do + me@MakeEnv{..} <- ask + -- Rehydrate any dependencies if this module had a boot file or is a signature file. + lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do + hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods + case mni of + ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me mod + ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc + ) + + where + fixed_mrehydrate_mods = + case moduleNodeInfoHscSource mni of + -- MP: It is probably a bit of a misimplementation in backpack that + -- compiling a signature requires an knot_var for that unit. + -- If you remove this then a lot of backpack tests fail. + Just HsigFile -> Just [] + _ -> mrehydrate_mods + + executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo) + executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc = + wrapAction diag_wrapper hsc_env $ do + forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc)) + read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc) + case read_result of + M.Failed interface_err -> + let mn = mnkModuleName mod + err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn)) + in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err)) + M.Succeeded iface -> do + details <- genModDetails hsc_env iface + mb_object <- findObjectLinkableMaybe (mi_module iface) loc + mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details) + let hm_linkable = HomeModLinkable mb_bytecode mb_object + return (HomeModInfo iface details hm_linkable) + + executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo) + executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do + let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas + lcl_dynflags = ms_hspp_opts mod + let lcl_hsc_env = + -- Localise the hsc_env to use the cached flags + hscSetFlags lcl_dynflags $ + hsc_env + -- Compile the module, locking with a semaphore to avoid too many modules + -- being compiled at the same time leading to high memory usage. + wrapAction diag_wrapper lcl_hsc_env $ do + res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags + return res + + +{- Rehydration, see Note [Rehydrating Modules] -} + +rehydrate :: HscEnv -- ^ The HPT in this HscEnv needs rehydrating. + -> [HomeModInfo] -- ^ These are the modules we want to rehydrate. + -> IO [HomeModInfo] +rehydrate hsc_env hmis = do + debugTraceMsg logger 2 $ ( + text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis))) + -- When the HPT was pure we had to tie a knot to update the ModDetails in the + -- HPT required to update those ModDetails, but since it was made an IORef we + -- just have to make sure the new ModDetails are "reset" so that the new + -- modules are looked up in HPT when it is forced. If we didn't "reset" the + -- ModDetails, modules in a loop would refer the wrong (hs-boot) definitions + -- (as explained in Note [Rehydrating Modules]). + mds <- initIfaceCheck (text "rehydrate") hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_mods = [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds + ] + return new_mods + + where + logger = hsc_logger hsc_env + +-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the +-- module currently being compiled. +maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv +maybeRehydrateBefore hsc_env _ Nothing = return hsc_env +maybeRehydrateBefore hsc_env mni (Just mns) = do + knot_var <- initialise_knot_var hsc_env + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var } + hmis <- mapM (fmap expectJust . lookupHpt (hsc_HPT hsc_env')) mns + hmis' <- rehydrate hsc_env' hmis + mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi (hsc_HUG hsc_env')) hmis' + return hsc_env' + + where + initialise_knot_var hsc_env = liftIO $ + let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni) + in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv + +rehydrateAfter :: HscEnv + -> [ModuleName] + -> IO [HomeModInfo] +rehydrateAfter hsc mns = do + let hpt = hsc_HPT hsc + hmis <- mapM (fmap expectJust . lookupHpt hpt) mns + rehydrate (hsc { hsc_type_env_vars = emptyKnotVars }) hmis + +{- +Note [Hydrating Modules] +~~~~~~~~~~~~~~~~~~~~~~~~ +There are at least 4 different representations of an interface file as described +by this diagram. + +------------------------------ +| On-disk M.hi | +------------------------------ + | ^ + | Read file | Write file + V | +------------------------------- +| ByteString | +------------------------------- + | ^ + | Binary.get | Binary.put + V | +-------------------------------- +| ModIface (an acyclic AST) | +-------------------------------- + | ^ + | hydrate | mkIfaceTc + V | +--------------------------------- +| ModDetails (lots of cycles) | +--------------------------------- + +The last step, converting a ModIface into a ModDetails is known as "hydration". + +Hydration happens in three different places + +* When an interface file is initially loaded from disk, it has to be hydrated. +* When a module is finished compiling, we hydrate the ModIface in order to generate + the version of ModDetails which exists in memory (see Note [ModDetails and --make mode]) +* When dealing with boot files and module loops (see Note [Rehydrating Modules]) + +Note [Rehydrating Modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a module has a boot file then it is critical to rehydrate the modules on +the path between the two (see #20561). + +Suppose we have ("R" for "recursive"): +``` +R.hs-boot: module R where + data T + g :: T -> T + +A.hs: module A( f, T, g ) where + import {-# SOURCE #-} R + data S = MkS T + f :: T -> S = ...g... + +R.hs: module R where + import A + data T = T1 | T2 S + g = ...f... +``` + +== Why we need to rehydrate A's ModIface before compiling R.hs + +After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type +that uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same +AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about +it.) + +When compiling R.hs, we build a TyCon for `T`. But that TyCon mentions `S`, and +it currently has an AbstractTyCon for `T` inside it. But we want to build a +fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`. + +Solution: **rehydration**. *Before compiling `R.hs`*, rehydrate all the +ModIfaces below it that depend on R.hs-boot. To rehydrate a ModIface, call +`typecheckIface` to convert it to a ModDetails. It's just a de-serialisation +step, no type inference, just lookups. + +Now `S` will be bound to a thunk that, when forced, will "see" the final binding +for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot). +But note that this must be done *before* compiling R.hs. + +== Why we need to rehydrate A's ModIface after compiling R.hs + +When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding +mentions the `LocalId` for `g`. But when we finish R, we carefully ensure that +all those `LocalIds` are turned into completed `GlobalIds`, replete with +unfoldings etc. Alas, that will not apply to the occurrences of `g` in `f`'s +unfolding. And if we leave matters like that, they will stay that way, and *all* +subsequent modules that import A will see a crippled unfolding for `f`. + +Solution: rehydrate both R and A's ModIface together, right after completing R.hs. + +~~ Which modules to rehydrate + +We only need rehydrate modules that are +* Below R.hs +* Above R.hs-boot + +There might be many unrelated modules (in the home package) that don't need to be +rehydrated. + +== Loops with multiple boot files + +It is possible for a module graph to have a loop (SCC, when ignoring boot files) +which requires multiple boot files to break. In this case, we must perform +several hydration steps: + 1. The hydration steps described above, which are necessary for correctness. + 2. An extra hydration step at the end of compiling the entire SCC, in order to + remove space leaks, as we explain below. + +Consider the following example: + + ┌─────┐ ┌─────┐ + │ A │ │ B │ + └──┬──┘ └──┬──┘ + │ │ + ┌───▼───────────▼───┐ + │ C │ + └───┬───────────┬───┘ + │ │ + ┌────▼───┐ ┌───▼────┐ + │ A-boot │ │ B-boot │ + └────────┘ └────────┘ + +A, B and C live together in a SCC. Suppose that we compile the modules in the +order: + + A-boot, B-boot, C, A, B. + +When we come to compile A, we will perform the necessary hydration steps, +because A has a boot file. This means that C will be hydrated relative to A, +and the ModDetails for A will reference C/A. Then, when B is compiled, +C will be rehydrated again, and so B will reference C/A,B. At this point, +its interface will be hydrated relative to both A and B. +This causes a space leak: there are now two different copies of C's ModDetails, +kept alive by modules A and B. This is especially problematic if C is large. + +The way to avoid this space leak is to rehydrate an entire SCC together at the +end of compilation, so that all the ModDetails point to interfaces for .hs files. +In this example, when we hydrate A, B and C together, then both A and B will refer to +C/A,B. + +See #21900 for some more discussion. + +== Modules "above" the loop + +This dark corner is the subject of #14092. + +Suppose we add to our example +``` +X.hs module X where + import A + data XT = MkX T + fx = ...g... +``` +If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`. So: + +* Either we should delay compiling X until after R has been compiled. (This is what we do) +* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot. + +Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode. +#20200 has lots of issues, many of them now fixed; +this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758). + +The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful. +Also closely related are + * #14092 + * #14103 + +-} + +executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM () +executeLinkNode hug kn uid deps = do + withCurrentUnit uid $ do + MakeEnv{..} <- ask + let dflags = hsc_dflags hsc_env + let hsc_env' = setHUG hug hsc_env + msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager + + linkresult <- liftIO $ withAbstractSem compile_sem $ do + link (ghcLink dflags) + (hsc_logger hsc_env') + (hsc_tmpfs hsc_env') + (hsc_FC hsc_env') + (hsc_hooks hsc_env') + dflags + (hsc_unit_env hsc_env') + True -- We already decided to link + msg' + (hsc_HPT hsc_env') + case linkresult of + Failed -> fail "Link Failed" + Succeeded -> return () + +-- | Wait for dependencies to finish, and then return their results. +wait_deps :: [BuildResult] -> RunMakeM [HomeModInfo] +wait_deps [] = return [] +wait_deps (x:xs) = do + res <- lift $ waitResult (resultVar x) + hmis <- wait_deps xs + case res of + Nothing -> return hmis + Just hmi -> return (hmi:hmis) + + +{- Note [GHC Heap Invariants] + ~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note is a general place to explain some of the heap invariants which should +hold for a program compiled with --make mode. These invariants are all things +which can be checked easily using ghc-debug. + +1. No HomeModInfo are reachable via the EPS. + Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains + a reference to the entire HscEnv, if we are not careful the HscEnv will + contain the HomePackageTable at the time the interface was loaded and + it will never be released. + Where? dontLeakTheHUG in GHC.Iface.Load + +2. No KnotVars are live at the end of upsweep (#20491) + Why? KnotVars contains an old stale reference to the TypeEnv for modules + which participate in a loop. At the end of a loop all the KnotVars references + should be removed by the call to typecheckLoop. + Where? typecheckLoop in GHC.Driver.Make. + +3. Immediately after a reload, no ModDetails are live. + Why? During the upsweep all old ModDetails are replaced with a new ModDetails + generated from a ModIface. If we don't clear the ModDetails before the + reload takes place then memory usage during the reload is twice as much + as it should be as we retain a copy of the ModDetails for too long. + Where? pruneCache in GHC.Driver.Make + +4. No TcGblEnv or TcLclEnv are live after typechecking is completed. + Why? By the time we get to simplification all the data structures from typechecking + should be eliminated. + Where? No one place in the compiler. These leaks can be introduced by not suitable + forcing functions which take a TcLclEnv as an argument. + +5. At the end of a successful upsweep, the number of live ModDetails equals the + number of non-boot Modules. + Why? Each module has a HomeModInfo which contains a ModDetails from that module. -} diff --git a/GHC/Driver/MakeAction.hs b/GHC/Driver/MakeAction.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/MakeAction.hs @@ -0,0 +1,248 @@ +{-# LANGUAGE CPP #-} +module GHC.Driver.MakeAction + ( MakeAction(..) + , MakeEnv(..) + , RunMakeM + -- * Running the pipelines + , runAllPipelines + , runParPipelines + , runSeqPipelines + , runPipelines + -- * Worker limit + , WorkerLimit(..) + , mkWorkerLimit + , runWorkerLimit + -- * Utility + , withLoggerHsc + , withParLog + , withLocalTmpFS + , withLocalTmpFSMake + ) where + +import GHC.Prelude +import GHC.Driver.DynFlags + +import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Errors.Types +import GHC.Driver.Messager +import GHC.Driver.MakeSem + +import GHC.Utils.Logger +import GHC.Utils.TmpFs + +import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) +import qualified GHC.Conc as CC +import Control.Concurrent.MVar +import Control.Monad +import qualified Control.Monad.Catch as MC + +import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities ) +import Control.Monad.Trans.Reader +import GHC.Driver.Pipeline.LogQueue +import Control.Concurrent.STM +import Control.Monad.Trans.Maybe + +-- Executing the pipelines + +mkWorkerLimit :: DynFlags -> IO WorkerLimit +mkWorkerLimit dflags = + case parMakeCount dflags of + Nothing -> pure $ num_procs 1 + Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h)) + Just ParMakeNumProcessors -> num_procs <$> getNumProcessors + Just (ParMakeThisMany n) -> pure $ num_procs n + where + num_procs x = NumProcessorsLimit (max 1 x) + +isWorkerLimitSequential :: WorkerLimit -> Bool +isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1 +isWorkerLimitSequential (JSemLimit {}) = False + +-- | This describes what we use to limit the number of jobs, either we limit it +-- ourselves to a specific number or we have an external parallelism semaphore +-- limit it for us. +data WorkerLimit + = NumProcessorsLimit Int + | JSemLimit + SemaphoreName + -- ^ Semaphore name to use + deriving Eq + +-- | Environment used when compiling a module +data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module + , compile_sem :: !AbstractSem + -- Modify the environment for module k, with the supplied logger modification function. + -- For -j1, this wrapper doesn't do anything + -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output + -- into the log queue. + , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a + , env_messager :: !(Maybe Messager) + , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic + } + + +label_self :: String -> IO () +label_self thread_name = do + self_tid <- CC.myThreadId + CC.labelThread self_tid thread_name + + +runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () +-- Don't even initialise plugins if there are no pipelines +runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do + liftIO $ label_self "main --make thread" + case n_job of + NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines + _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines + +runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO () +runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines = + let env = MakeEnv { hsc_env = plugin_hsc_env + , withLogger = \_ k -> k id + , compile_sem = AbstractSem (return ()) (return ()) + , env_messager = mHscMessager + , diag_wrapper = diag_wrapper + } + in runAllPipelines (NumProcessorsLimit 1) env all_pipelines + +runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a +runNjobsAbstractSem n_jobs action = do + compile_sem <- newQSem n_jobs + n_capabilities <- getNumCapabilities + n_cpus <- getNumProcessors + let + asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) + set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n + updNumCapabilities = do + -- Setting number of capabilities more than + -- CPU count usually leads to high userspace + -- lock contention. #9221 + set_num_caps $ min n_jobs n_cpus + resetNumCapabilities = set_num_caps n_capabilities + MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem + +runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a +#if defined(wasm32_HOST_ARCH) +runWorkerLimit _ action = do + lock <- newMVar () + action $ AbstractSem (takeMVar lock) (putMVar lock ()) +#else +runWorkerLimit worker_limit action = case worker_limit of + NumProcessorsLimit n_jobs -> + runNjobsAbstractSem n_jobs action + JSemLimit sem -> + runJSemAbstractSem sem action +#endif + +-- | Build and run a pipeline +runParPipelines :: WorkerLimit -- ^ How to limit work parallelism + -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module + -> (GhcMessage -> AnyGhcDiagnostic) + -> Maybe Messager -- ^ Optional custom messager to use to report progress + -> [MakeAction] -- ^ The build plan for all the module nodes + -> IO () +runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do + + + -- A variable which we write to when an error has happened and we have to tell the + -- logging thread to gracefully shut down. + stopped_var <- newTVarIO False + -- The queue of LogQueues which actions are able to write to. When an action starts it + -- will add it's LogQueue into this queue. + log_queue_queue_var <- newTVarIO newLogQueueQueue + -- Thread which coordinates the printing of logs + wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var + + + -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue. + thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env) + let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger } + + runWorkerLimit worker_limit $ \abstract_sem -> do + let env = MakeEnv { hsc_env = thread_safe_hsc_env + , withLogger = withParLog log_queue_queue_var + , compile_sem = abstract_sem + , env_messager = mHscMessager + , diag_wrapper = diag_wrapper + } + -- Reset the number of capabilities once the upsweep ends. + runAllPipelines worker_limit env all_pipelines + atomically $ writeTVar stopped_var True + wait_log_thread + +withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a +withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do + withLogger k $ \modifyLogger -> do + let lcl_logger = modifyLogger (hsc_logger hsc_env) + hsc_env' = hsc_env { hsc_logger = lcl_logger } + -- Run continuation with modified logger + cont hsc_env' + +withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b +withParLog lqq_var k cont = do + let init_log = do + -- Make a new log queue + lq <- newLogQueue k + -- Add it into the LogQueueQueue + atomically $ initLogQueue lqq_var lq + return lq + finish_log lq = liftIO (finishLogQueue lq) + MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq))) + +withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a +withLocalTmpFS tmpfs act = do + let initialiser = do + liftIO $ forkTmpFsFrom tmpfs + finaliser tmpfs_local = do + liftIO $ mergeTmpFsInto tmpfs_local tmpfs + -- Add remaining files which weren't cleaned up into local tmp fs for + -- clean-up later. + -- Clear the logQueue if this node had it's own log queue + MC.bracket initialiser finaliser act + +withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a +withLocalTmpFSMake env k = + withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs + -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }}) + + +-- | Run the given actions and then wait for them all to finish. +runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO () +runAllPipelines worker_limit env acts = do + let single_worker = isWorkerLimitSequential worker_limit + spawn_actions :: IO [ThreadId] + spawn_actions = if single_worker + then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts) + else runLoop forkIOWithUnmask env acts + + kill_actions :: [ThreadId] -> IO () + kill_actions tids = mapM_ killThread tids + + MC.bracket spawn_actions kill_actions $ \_ -> do + mapM_ waitMakeAction acts + +-- | Execute each action in order, limiting the amount of parallelism by the given +-- semaphore. +runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a] +runLoop _ _env [] = return [] +runLoop fork_thread env (MakeAction act res_var :acts) = do + + -- withLocalTmpFs has to occur outside of fork to remain deterministic + new_thread <- withLocalTmpFSMake env $ \lcl_env -> + fork_thread $ \unmask -> (do + mres <- (unmask $ run_pipeline lcl_env act) + `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure. + putMVar res_var mres) + threads <- runLoop fork_thread env acts + return (new_thread : threads) + where + run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a) + run_pipeline env p = runMaybeT (runReaderT p env) + +type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a + +data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) + +waitMakeAction :: MakeAction -> IO () +waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar diff --git a/GHC/Driver/MakeFile.hs b/GHC/Driver/MakeFile.hs --- a/GHC/Driver/MakeFile.hs +++ b/GHC/Driver/MakeFile.hs @@ -10,23 +10,24 @@ module GHC.Driver.MakeFile ( doMkDependHS + , doMkDependModuleGraph ) where import GHC.Prelude import qualified GHC +import GHC.Driver.Make import GHC.Driver.Monad import GHC.Driver.DynFlags -import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Driver.Env import GHC.Driver.Errors.Types import qualified GHC.SysTools as SysTools import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.OsPath (unsafeDecodeUtf) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.PkgQual @@ -53,6 +54,7 @@ import Data.IORef import qualified Data.Set as Set import GHC.Iface.Errors.Types +import Data.Either ----------------------------------------------------------------- -- @@ -62,8 +64,6 @@ doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do - logger <- getLogger - -- Initialisation dflags0 <- GHC.getSessionDynFlags @@ -85,17 +85,22 @@ then dflags1 { depSuffixes = [""] } else dflags1 - tmpfs <- hsc_tmpfs <$> getSession - files <- liftIO $ beginMkDependHS logger tmpfs dflags - -- Do the downsweep to find all the modules targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs GHC.setTargets targets let excl_mods = depExcludeMods dflags module_graph <- GHC.depanal excl_mods True {- Allow dup roots -} + doMkDependModuleGraph dflags module_graph - -- Sort into dependency order - -- There should be no cycles + + +doMkDependModuleGraph :: GhcMonad m => DynFlags -> ModuleGraph -> m () +doMkDependModuleGraph dflags module_graph = do + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getSession + let excl_mods = depExcludeMods dflags + + files <- liftIO $ beginMkDependHS logger tmpfs dflags let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted @@ -210,20 +215,22 @@ -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps dflags _ _ _ _ (CyclicSCC nodes) +processDeps _ _ _ _ _ (CyclicSCC nodes) = -- There shouldn't be any cycles; report them - throwGhcExceptionIO $ ProgramError $ - showSDoc dflags $ GHC.cyclicModuleErr nodes + throwOneError $ cyclicModuleErr nodes -processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) +processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node)) = -- There shouldn't be any backpack instantiations; report them as well - throwGhcExceptionIO $ ProgramError $ - showSDoc dflags $ - vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:" - , nest 2 $ ppr node ] -processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () + throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node)) +processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return () +processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return () +processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {}))) + -- No dependencies needed for fixed modules (already compiled) + = return () +processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile node))) = do { let extra_suffixes = depSuffixes dflags include_pkg_deps = depIncludePkgDeps dflags src_file = msHsFilePath node @@ -253,7 +260,7 @@ -- files if the module has a corresponding .hs-boot file (#14482) ; when (isBootSummary node == IsBoot) $ do let hi_boot = msHiFilePath node - let obj = removeBootSuffix (msObjFilePath node) + let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node) forM_ extra_suffixes $ \suff -> do let way_obj = insertSuffixes obj [suff] let way_hi_boot = insertSuffixes hi_boot [suff] @@ -275,10 +282,10 @@ ; let do_imps is_boot idecls = sequence_ [ do_imp loc is_boot mb_pkg mod - | (mb_pkg, L loc mod) <- idecls, + | (_lvl, mb_pkg, L loc mod) <- idecls, mod `notElem` excl_mods ] - ; do_imps IsBoot (ms_srcimps node) + ; do_imps IsBoot (map ((,,) NormalLevel NoPkgQual) (ms_srcimps node)) ; do_imps NotBoot (ms_imps node) } @@ -293,12 +300,12 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findImportedModule hsc_env imp pkg + r <- findImportedModuleWithIsBoot hsc_env imp is_boot pkg case r of Found loc _ -- Home package: just depend on the .hi or hi-boot file | isJust (ml_hs_file loc) || include_pkg_deps - -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + -> return (Just (ml_hi_file loc)) -- Not in this package: we don't need a dependency | otherwise @@ -404,43 +411,63 @@ -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries) where - cycle_mods :: [ModuleName] -- The modules in this cycle - cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries] + cycle_keys :: [NodeKey] -- The modules in this cycle + cycle_keys = map mkNodeKey summaries pp_group :: SCC ModuleGraphNode -> SDoc - pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms + pp_group (AcyclicSCC (ModuleNode deps m)) = pp_mod deps m pp_group (AcyclicSCC _) = empty pp_group (CyclicSCC mss) = assert (not (null boot_only)) $ -- The boot-only list must be non-empty, else there would -- be an infinite chain of non-boot imports, and we've -- already checked for that in processModDeps - pp_ms loop_breaker $$ vcat (map pp_group groups) + pp_mod loop_deps loop_breaker $$ vcat (map pp_group groups) where - (boot_only, others) = partition is_boot_only mss - is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms))) - is_boot_only _ = False - in_group (L _ m) = m `elem` group_mods - group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss] + (boot_only, others) = partitionEithers (map is_boot_only mss) + is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_key _ = False + is_boot_only n@(ModuleNode deps ms) = + let dep_mods = map edgeTargetKey deps + non_boot_deps = filter (not . is_boot_key) dep_mods + in if not (any in_group non_boot_deps) + then Left (deps, ms) + else Right n + is_boot_only n = Right n + in_group m = m `elem` group_mods + group_mods = map mkNodeKey mss - loop_breaker = head ([ms | ModuleNode _ ms <- boot_only]) - all_others = tail boot_only ++ others + (loop_deps, loop_breaker) = head boot_only + all_others = tail (map (uncurry ModuleNode) boot_only) ++ others groups = GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing - pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' ')) - <+> (pp_imps empty (map snd (ms_imps summary)) $$ - pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary))) - where - mod_str = moduleNameString (moduleName (ms_mod summary)) + pp_mod :: [ModuleNodeEdge] -> ModuleNodeInfo -> SDoc + pp_mod deps mn = + text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps (map edgeTargetKey deps) + where + mod_str = moduleNameString (moduleNodeInfoModuleName mn) - pp_imps :: SDoc -> [Located ModuleName] -> SDoc - pp_imps _ [] = empty - pp_imps what lms - = case [m | L _ m <- lms, m `elem` cycle_mods] of - [] -> empty - ms -> what <+> text "imports" <+> - pprWithCommas ppr ms + ppr_deps :: [NodeKey] -> SDoc + ppr_deps [] = empty + ppr_deps deps = + let is_mod_dep (NodeKey_Module {}) = True + is_mod_dep _ = False + + is_boot_dep (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True + is_boot_dep _ = False + + cycle_deps = filter (`elem` cycle_keys) deps + (mod_deps, other_deps) = partition is_mod_dep cycle_deps + (boot_deps, normal_deps) = partition is_boot_dep mod_deps + in vcat [ + if null normal_deps then empty + else text "imports" <+> pprWithCommas ppr normal_deps, + if null boot_deps then empty + else text "{-# SOURCE #-} imports" <+> pprWithCommas ppr boot_deps, + if null other_deps then empty + else text "depends on" <+> pprWithCommas ppr other_deps + ] ----------------------------------------------------------------- -- diff --git a/GHC/Driver/MakeSem.hs b/GHC/Driver/MakeSem.hs --- a/GHC/Driver/MakeSem.hs +++ b/GHC/Driver/MakeSem.hs @@ -343,7 +343,7 @@ tryAcquire _ _ _ = retry -- | When there are free tokens and no pending jobs, --- spawn a thread to release a token from the semamphore. +-- spawn a thread to release a token from the semaphore. -- -- See 'releaseThread'. tryRelease :: Jobserver diff --git a/GHC/Driver/Messager.hs b/GHC/Driver/Messager.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Messager.hs @@ -0,0 +1,66 @@ +module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where + +import GHC.Prelude +import GHC.Driver.Env +import GHC.Unit.Module.Graph +import GHC.Iface.Recomp +import GHC.Utils.Logger +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Unit.State + +type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO () + +-------------------------------------------------------------- +-- Progress displayers. +-------------------------------------------------------------- + +oneShotMsg :: Logger -> RecompileRequired -> IO () +oneShotMsg logger recomp = + case recomp of + UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required" + NeedsRecompile _ -> return () + +batchMsg :: Messager +batchMsg = batchMsgWith (\_ _ _ _ -> empty) +batchMultiMsg :: Messager +batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node))) + +batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager +batchMsgWith extra hsc_env_start mod_index recomp node = + case recomp of + UpToDate + | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty + | otherwise -> return () + NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of + MustCompile -> empty + (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]" + where + herald = case node of + LinkNode {} -> "Linking" + InstantiationNode {} -> "Instantiating" + ModuleNode {} -> "Compiling" + UnitNode {} -> "Loading" + hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + state = hsc_units hsc_env + showMsg msg reason = + compilationProgressMsg logger $ + (showModuleIndex mod_index <> + msg <+> showModMsg dflags (recompileRequired recomp) node) + <> extra hsc_env mod_index recomp node + <> reason + +{- ********************************************************************** +%* * + Progress Messages: Module i of n +%* * +%********************************************************************* -} + +showModuleIndex :: (Int, Int) -> SDoc +showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] " + where + -- compute the length of x > 0 in base 10 + len x = ceiling (logBase 10 (fromIntegral x+1) :: Float) + pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr diff --git a/GHC/Driver/Monad.hs b/GHC/Driver/Monad.hs --- a/GHC/Driver/Monad.hs +++ b/GHC/Driver/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-} +{-# LANGUAGE DerivingVia, NoPolyKinds #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- -- @@ -23,6 +23,8 @@ modifyLogger, pushLogHookM, popLogHookM, + pushJsonLogHookM, + popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -120,6 +122,12 @@ -- | Pop a log hook from the stack popLogHookM :: GhcMonad m => m () popLogHookM = modifyLogger popLogHook + +pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m () +pushJsonLogHookM = modifyLogger . pushJsonLogHook + +popJsonLogHookM :: GhcMonad m => m () +popJsonLogHookM = modifyLogger popJsonLogHook -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m () diff --git a/GHC/Driver/Phases.hs b/GHC/Driver/Phases.hs --- a/GHC/Driver/Phases.hs +++ b/GHC/Driver/Phases.hs @@ -23,6 +23,7 @@ isDynLibSuffix, isHaskellUserSrcSuffix, isHaskellSigSuffix, + isHaskellBootSuffix, isSourceSuffix, isHaskellishTarget, @@ -234,7 +235,7 @@ phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. @@ -247,7 +248,8 @@ -- Will not be deleted as temp files: haskellish_user_src_suffixes = - haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] + haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ] +haskellish_boot_suffixes = [ "hs-boot", "lhs-boot" ] haskellish_sig_suffixes = [ "hsig", "lhsig" ] backpackish_suffixes = [ "bkp" ] @@ -265,11 +267,12 @@ _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellBootSuffix s = s `elem` haskellish_boot_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes isJsSuffix s = s `elem` js_suffixes diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/GHC/Driver/Pipeline.hs @@ -1,14 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} - -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- @@ -51,6 +44,7 @@ import GHC.Prelude +import GHC.Builtin.Names import GHC.Platform @@ -83,7 +77,6 @@ import GHC.Linker.Types import GHC.StgToJS.Linker.Linker -import GHC.StgToJS.Linker.Types (defaultJSLinkConfig) import GHC.Utils.Outputable import GHC.Utils.Error @@ -99,11 +92,13 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.Load ( getGhcPrimIface ) import GHC.Runtime.Loader ( initializePlugins ) 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 @@ -112,11 +107,10 @@ import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder ---import GHC.Unit.State import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable import System.Directory import System.FilePath @@ -124,8 +118,9 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe -import Data.Either ( partitionEithers ) 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 @@ -259,7 +254,7 @@ where lcl_dflags = ms_hspp_opts summary location = ms_location summary - input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fn = expectJust (ml_hs_file location) input_fnpp = ms_hspp_file summary pipelineOutput = backendPipelineOutput bcknd @@ -409,18 +404,18 @@ LinkStaticLib -> True _ -> False - home_mod_infos = eltsHpt hpt + -- the packages we depend on + -- TODO: This should be a query on the 'ModuleGraph', since we need to + -- know which packages are actually needed at the runtime stage. + pkg_deps <- map snd . Set.toList <$> hptCollectDependencies hpt - -- the packages we depend on - pkg_deps = Set.toList - $ Set.unions - $ fmap (dep_direct_pkgs . mi_deps . hm_iface) - $ home_mod_infos + -- the linkables to link + linkables <- hptCollectObjects hpt - -- the linkables to link - linkables = map (expectJust "link". homeModInfoObject) home_mod_infos + -- the home modules, for tracing + home_modules <- hptCollectModules hpt - debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos)) + debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map ppr home_modules)) debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) @@ -430,8 +425,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) @@ -448,7 +442,7 @@ -- Don't showPass in Batch mode; doLink will do that for us. case ghcLink dflags of LinkBinary - | backendUseJSLinker (backend dflags) -> linkJSBinary logger fc dflags unit_env obj_files pkg_deps + | backendUseJSLinker (backend dflags) -> linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps @@ -465,14 +459,13 @@ return Succeeded -linkJSBinary :: Logger -> FinderCache -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkJSBinary logger fc dflags unit_env obj_files pkg_deps = do +linkJSBinary :: Logger -> TmpFs -> FinderCache -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkJSBinary logger tmpfs fc dflags unit_env obj_files pkg_deps = do -- we use the default configuration for now. In the future we may expose -- settings to the user via DynFlags. - let lc_cfg = defaultJSLinkConfig + let lc_cfg = initJSLinkConfig dflags let cfg = initStgToJSConfig dflags - let extra_js = mempty - jsLinkBinary fc lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps + jsLinkBinary fc lc_cfg cfg logger tmpfs dflags unit_env obj_files pkg_deps linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do @@ -480,7 +473,7 @@ -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). let platform = ue_platform unit_env - unit_state = ue_units unit_env + unit_state = ue_homeUnitState unit_env arch_os = platformArchOS platform exe_file = exeFileName arch_os staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file @@ -489,8 +482,7 @@ Right t -> do -- first check object files and extra_ld_inputs let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] - e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs - let (errs,extra_times) = partitionEithers e_extra_times + (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times then return $ needsRecompileBecause ObjectsChanged @@ -514,9 +506,7 @@ pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do - e_lib_times <- mapM (tryIO . getModificationUTCTime) - (catMaybes pkg_libfiles) - let (lib_errs,lib_times) = partitionEithers e_lib_times + (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles) if not (null lib_errs) || any (t <) lib_times then return $ needsRecompileBecause LibraryChanged else do @@ -555,28 +545,28 @@ compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- doesFileExist src - when (not exists) $ - throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src)) + let offset_file = augmentByWorkingDirectory dflags src + dflags = hsc_dflags hsc_env + mb_o_file = outputFile dflags + ghc_link = ghcLink dflags -- Set by -c or -no-link + notStopPreprocess | StopPreprocess <- stop_phase = False + | _ <- stop_phase = True + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + output + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile + -- avoid -E -fno-code undesirable interactions. see #20439 + | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent + -- -o foo applies to linker + | isJust mb_o_file = SpecificFile + -- -o foo applies to the file we are compiling now + | otherwise = Persistent + pipe_env = mkPipeEnv stop_phase offset_file mb_phase output + pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase - let - dflags = hsc_dflags hsc_env - mb_o_file = outputFile dflags - ghc_link = ghcLink dflags -- Set by -c or -no-link - notStopPreprocess | StopPreprocess <- stop_phase = False - | _ <- stop_phase = True - -- When linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - output - | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile - -- avoid -E -fno-code undesirable interactions. see #20439 - | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent - -- -o foo applies to linker - | isJust mb_o_file = SpecificFile - -- -o foo applies to the file we are compiling now - | otherwise = Persistent - pipe_env = mkPipeEnv stop_phase src mb_phase output - pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase + exists <- doesFileExist offset_file + when (not exists) $ + throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file)) runPipeline (hsc_hooks hsc_env) pipeline @@ -593,7 +583,7 @@ NoLink -> return () LinkBinary | backendUseJSLinker (backend dflags) - -> linkJSBinary logger fc dflags unit_env o_files [] + -> linkJSBinary logger tmpfs fc dflags unit_env o_files [] | otherwise -> linkBinary logger tmpfs dflags unit_env o_files [] LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] LinkDynLib -> linkDynLibCheck logger tmpfs dflags unit_env o_files [] @@ -628,9 +618,6 @@ LangObjcxx -> viaCPipeline Cobjcxx LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp LangJs -> \pe hsc_env ml fp -> Just <$> foreignJsPipeline pe hsc_env ml fp -#if __GLASGOW_HASKELL__ < 811 - RawObject -> panic "compileForeign: should be unreachable" -#endif pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession) res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c) case res of @@ -795,16 +782,22 @@ if backendGeneratesCode (backend (hsc_dflags hsc_env)) then do res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result - when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do + -- Only run dynamic-too if the backend generates object files + -- See Note [Writing interface files] + -- If we are writing a simple interface (not . backendWritesFiles), then + -- hscMaybeWriteIface in the regular pipeline will write both the hi and + -- dyn_hi files. This way we can avoid running the pipeline twice and + -- generating a duplicate linkable. + -- We must not run the backend a second time with `dynamicNow` enable because + -- all the work has already been done in the first pipeline. + when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (hsc_dflags hsc_env)) ) $ do let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result return res 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 @@ -823,19 +816,31 @@ -- 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) + -- when building ghc-internal with --make (e.g. with cabal-install), we want + -- the virtual interface for gHC_PRIM in the cache, not the empty one. + let miface_final + | ms_mod mod_sum == gHC_PRIM = getGhcPrimIface (hsc_hooks hsc_env) + | otherwise = miface + return (miface_final, final_linkable) + asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) asPipeline use_cpp pipe_env hsc_env location input_fn = case stop_phase pipe_env of StopAs -> return Nothing _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn) +lasPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) +lasPipeline use_cpp pipe_env hsc_env location input_fn = + case stop_phase pipe_env of + StopAs -> return Nothing + _ -> Just <$> use (T_LlvmAs use_cpp pipe_env hsc_env location input_fn) + viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) viaCPipeline c_phase pipe_env hsc_env location input_fn = do out_fn <- use (T_Cc c_phase pipe_env hsc_env location input_fn) @@ -859,7 +864,7 @@ if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env) then return llc_fn else use (T_LlvmMangle pipe_env hsc_env llc_fn) - asPipeline False pipe_env hsc_env location mangled_fn + lasPipeline False pipe_env hsc_env location mangled_fn cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) cmmCppPipeline pipe_env hsc_env input_fn = do @@ -931,7 +936,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) diff --git a/GHC/Driver/Pipeline.hs-boot b/GHC/Driver/Pipeline.hs-boot --- a/GHC/Driver/Pipeline.hs-boot +++ b/GHC/Driver/Pipeline.hs-boot @@ -3,12 +3,22 @@ import GHC.Driver.Env.Types ( HscEnv ) import GHC.ForeignSrcLang ( ForeignSrcLang ) -import GHC.Prelude (FilePath, IO) +import GHC.Prelude (FilePath, IO, Maybe, Either) import GHC.Unit.Module.Location (ModLocation) import GHC.Driver.Session (DynFlags) +import GHC.Driver.Phases (Phase) +import GHC.Driver.Errors.Types (DriverMessages) +import GHC.Types.Target (InputFileBuffer) import Language.Haskell.Syntax.Module.Name -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () + +preprocess :: HscEnv + -> FilePath + -> Maybe InputFileBuffer + -> Maybe Phase + -> IO (Either DriverMessages (DynFlags, FilePath)) + diff --git a/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs --- a/GHC/Driver/Pipeline/Execute.hs +++ b/GHC/Driver/Pipeline/Execute.hs @@ -4,7 +4,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} #include {- Functions for providing the default interpretation of the 'TPhase' actions @@ -21,8 +20,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 @@ -32,6 +33,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc import GHC.Driver.Main +import GHC.Driver.Downsweep import GHC.Tc.Types import GHC.Types.Error import GHC.Driver.Errors.Types @@ -46,7 +48,6 @@ import GHC.CmmToLlvm.Mangler import GHC.SysTools import GHC.SysTools.Cpp -import GHC.Utils.Panic.Plain import System.Directory import System.FilePath import GHC.Utils.Misc @@ -59,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 @@ -72,6 +74,7 @@ import GHC.Linker.ExtraObj import GHC.Linker.Dynamic import GHC.Utils.Panic +import GHC.Utils.Touch import GHC.Unit.Module.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Finder @@ -121,8 +124,8 @@ (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (CppOpts - { cppUseCc = True - , cppLinePragmas = True + { sourceCodePreprocessor = SCPCmmCpp + , cppLinePragmas = True }) input_fn output_fn return output_fn @@ -146,6 +149,8 @@ runLlvmOptPhase pipe_env hsc_env input_fn runPhase (T_LlvmLlc pipe_env hsc_env input_fn) = runLlvmLlcPhase pipe_env hsc_env input_fn +runPhase (T_LlvmAs cpp pipe_env hsc_env location input_fn) = do + runLlvmAsPhase cpp pipe_env hsc_env location input_fn runPhase (T_LlvmMangle pipe_env hsc_env input_fn) = runLlvmManglePhase pipe_env hsc_env input_fn runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) = @@ -283,17 +288,13 @@ return output_fn -runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath -runAsPhase with_cpp pipe_env hsc_env location input_fn = do +-- Run either 'clang' or 'gcc' phases +runGenericAsPhase :: (Logger -> DynFlags -> [Option] -> IO ()) -> [Option] -> Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +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 platform = ue_platform unit_env - -- LLVM from version 3.0 onwards doesn't support the OS X system - -- assembler, so we use clang as the assembler instead. (#5636) - let as_prog = applyAssemblerProg $ backendAssemblerProg (backend dflags) - let cmdline_include_paths = includePaths dflags let pic_c_flags = picCCOpts dflags @@ -303,17 +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 -> - as_prog + run_as logger dflags - platform - (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] @@ -334,14 +339,25 @@ , GHC.SysTools.FileOption "" inputFilename , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" temp_outputFilename - ]) + ] ++ extra_opts) debugTraceMsg logger 4 (text "Running the assembler") runAssembler input_fn output_fn return output_fn +-- Invoke `clang` to assemble a .S file produced by LLvm toolchain +runLlvmAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runLlvmAsPhase = + runGenericAsPhase runLlvmAs [ GHC.SysTools.Option "-Wno-unused-command-line-argument" ] +-- Invoke 'gcc' to assemble a .S file +runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runAsPhase = + runGenericAsPhase runAs [] + + + -- Note [JS Backend .o file procedure] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -370,14 +386,10 @@ -- | Run the JS Backend postHsc phase. runJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath -runJsPhase _pipe_env hsc_env _location input_fn = do - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - +runJsPhase _pipe_env _hsc_env _location input_fn = do -- The object file is already generated. We only touch it to ensure the -- timestamp is refreshed, see Note [JS Backend .o file procedure]. - touchObjectFile logger dflags input_fn - + touchObjectFile input_fn return input_fn -- | Deal with foreign JS files (embed them into .o files) @@ -392,28 +404,12 @@ embedJsFile logger dflags tmpfs unit_env input_fn output_fn return output_fn - -applyAssemblerProg - :: DefunctionalizedAssemblerProg - -> Logger -> DynFlags -> Platform -> [Option] -> IO () -applyAssemblerProg StandardAssemblerProg logger dflags _platform = - runAs logger dflags -applyAssemblerProg JSAssemblerProg logger dflags _platform = - runEmscripten logger dflags -applyAssemblerProg DarwinClangAssemblerProg logger dflags platform = - if platformOS platform == OSDarwin then - runClang logger dflags - else - runAs logger dflags - - - runCcPhase :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath runCcPhase cc_phase 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 home_unit = hsc_home_unit hsc_env + let home_unit = hsc_home_unit_maybe hsc_env let tmpfs = hsc_tmpfs hsc_env let platform = ue_platform unit_env let hcc = cc_phase `eqPhase` HCc @@ -435,19 +431,6 @@ includePathsQuoteImplicit cmdline_include_paths) let include_paths = include_paths_quote ++ include_paths_global - -- pass -D or -optP to preprocessor when compiling foreign C files - -- (#16737). Doing it in this way is simpler and also enable the C - -- compiler to perform preprocessing and parsing in a single pass, - -- but it may introduce inconsistency if a different pgm_P is specified. - let opts = getOpts dflags opt_P - aug_imports = augmentImports dflags opts - - more_preprocessor_opts = concat - [ ["-Xpreprocessor", i] - | not hcc - , i <- aug_imports - ] - let gcc_extra_viac_flags = extraGccViaCFlags dflags let pic_c_flags = picCCOpts dflags @@ -495,7 +478,7 @@ -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - ghcVersionH <- getGhcVersionPathName dflags unit_env + ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env withAtomicRename output_fn $ \temp_outputFilename -> GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( @@ -513,15 +496,24 @@ , 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. - ++ (if platformOS platform == OSMinGW32 && - isHomeUnitId home_unit baseUnitId - then [ "-DCOMPILING_BASE_PACKAGE" ] - else []) + ++ (case home_unit of + Just hu + | isHomeUnitId hu ghcInternalUnitId + , platformOS platform == OSMinGW32 + -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"] + _ -> []) -- GCC 4.6+ doesn't like -Wimplicit when compiling C++. ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx) @@ -533,10 +525,9 @@ else []) ++ verbFlags ++ cc_opt - ++ [ "-include", ghcVersionH ] + ++ ghcVersionH ++ framework_paths ++ include_paths - ++ more_preprocessor_opts ++ pkg_extra_cc_opts )) @@ -569,13 +560,13 @@ HsigFile -> do -- We need to create a REAL but empty .o file -- because we are going to attempt to put it in a library - let input_fn = expectJust "runPhase" (ml_hs_file location) + let input_fn = expectJust (ml_hs_file location) basename = dropExtension input_fn compileEmptyStub dflags hsc_env basename location mod_name -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make - HsBootFile -> touchObjectFile logger dflags o_file + HsBootFile -> touchObjectFile o_file HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" -- MP: I wonder if there are any lurking bugs here because we @@ -595,26 +586,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 @@ -625,7 +618,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") @@ -640,7 +633,7 @@ -- GHC.HsToCore.Ticks.isGoodTickSrcSpan where we check that the filename in -- a SrcLoc is the same as the source filename, the two will -- look bogusly different. See test: - -- libraries/hpc/tests/function/subdir/tough2.hs + -- testsuite/tests/hpc/function/subdir/tough2.hs escape ('\\':cs) = '\\':'\\': escape cs escape ('\"':cs) = '\\':'\"': escape cs escape ('\'':cs) = '\\':'\'': escape cs @@ -665,10 +658,11 @@ getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, Messages DriverMessage)) getFileArgs hsc_env input_fn = do let dflags0 = hsc_dflags hsc_env + logger = hsc_logger hsc_env parser_opts = initParserOpts dflags0 - (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn + (warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn (dflags1, unhandled_flags, warns) - <- parseDynamicFilePragma dflags0 src_opts + <- parseDynamicFilePragma logger dflags0 src_opts checkProcessArgsResult unhandled_flags return (dflags1, warns0, warns) @@ -679,8 +673,8 @@ (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (CppOpts - { cppUseCc = False - , cppLinePragmas = True + { sourceCodePreprocessor = SCPHsCpp + , cppLinePragmas = True }) input_fn output_fn return output_fn @@ -710,17 +704,17 @@ hsc_env <- initializePlugins hsc_env1 -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do + (hspp_buf,mod_name,imps,src_imps) <- do buf <- hGetStringBuffer input_fn let imp_prelude = xopt LangExt.ImplicitPrelude dflags popts = initParserOpts dflags rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) - rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn)) + rn_imps = fmap (\(s, rpk, lmn@(L _ mn)) -> (s, rn_pkg_qual mn rpk, lmn)) eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of Left errs -> throwErrors (GhcPsMessage <$> errs) - Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return - (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp) + Right (src_imps,imps, L _ mod_name) -> return + (Just buf, mod_name, rn_imps imps, src_imps) -- Take -o into account if present -- Very like -ohi, but we must *only* do this if we aren't linking @@ -743,7 +737,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 mod_name location src_flavour -- Make the ModSummary to hand to hscMain let @@ -759,7 +753,6 @@ ms_parsed_mod = Nothing, ms_iface_date = hi_date, ms_hie_date = hie_date, - ms_ghc_prim_import = ghc_prim_imp, ms_textual_imps = imps, ms_srcimps = src_imps } @@ -768,12 +761,19 @@ let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what + -- A lazy module graph thunk, don't force it unless you need it! + mg <- downsweepThunk hsc_env mod_summary + -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = + setModuleGraph mg + hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + + status <- hscRecompStatus (Just msg) hsc_env' mod_summary Nothing emptyHomeModInfoLinkable (1, 1) @@ -786,24 +786,18 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do let PipeEnv{ src_basename=basename, src_suffix=suff } = pipe_env - let location1 = mkHomeModLocation2 fopts mod_name basename suff - - -- Boot-ify it if necessary - let location2 - | HsBootFile <- src_flavour = addBootSuffixLocnOut location1 - | otherwise = location1 - + let location1 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour -- Take -ohi into account if present -- This can't be done in mkHomeModuleLocation because -- it only applies to the module being compiles let ohi = outputHi dflags - location3 | Just fn <- ohi = location2{ ml_hi_file = fn } - | otherwise = location2 + location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn } + | otherwise = location1 let dynohi = dynOutputHi dflags - location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn } - | otherwise = location3 + location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn } + | otherwise = location2 -- Take -o into account if present -- Very like -ohi, but we must *only* do this if we aren't linking @@ -816,11 +810,11 @@ location5 | Just ofile <- expl_o_file , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file , isNoLink (ghcLink dflags) - = location4 { ml_obj_file = ofile - , ml_dyn_obj_file = dyn_ofile } + = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile + , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile } | Just dyn_ofile <- expl_dyn_o_file - = location4 { ml_dyn_obj_file = dyn_ofile } - | otherwise = location4 + = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile } + | otherwise = location3 return location5 where fopts = initFinderOpts dflags @@ -968,11 +962,8 @@ -> DynFlags -> [(String, String)] -- ^ pairs of (opt, llc) arguments llvmOptions llvm_config dflags = - [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] - ++ [("-relocation-model=" ++ rmodel + [("-relocation-model=" ++ rmodel ,"-relocation-model=" ++ rmodel) | not (null rmodel)] - ++ [("-stack-alignment=" ++ (show align) - ,"-stack-alignment=" ++ (show align)) | align > 0 ] -- Additional llc flags ++ [("", "-mcpu=" ++ mcpu) | not (null mcpu) @@ -981,22 +972,22 @@ ++ [("", "-target-abi=" ++ abi) | not (null abi) ] where target = platformMisc_llvmTarget $ platformMisc dflags - Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config) + target_os = platformOS (targetPlatform dflags) + LlvmTarget _ mcpu mattr = expectJust $ 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 - align :: Int - align = case platformArch platform of - ArchX86_64 | isAvxEnabled dflags -> 32 - _ -> 0 - attrs :: String attrs = intercalate "," $ mattr ++ ["+sse4.2" | isSse4_2Enabled dflags ] @@ -1004,6 +995,9 @@ -- LLVM gates POPCNT instructions behind the popcnt flag, -- while the GHC NCG (as well as GCC, Clang) gates it -- behind SSE4.2 instead. + ++ ["+sse4.1" | isSse4_1Enabled dflags ] + ++ ["+ssse3" | isSsse3Enabled dflags ] + ++ ["+sse3" | isSse3Enabled dflags ] ++ ["+sse2" | isSse2Enabled platform ] ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ] @@ -1181,10 +1175,10 @@ -touchObjectFile :: Logger -> DynFlags -> FilePath -> IO () -touchObjectFile logger dflags path = do +touchObjectFile :: FilePath -> IO () +touchObjectFile path = do createDirectoryIfMissing True $ takeDirectory path - GHC.SysTools.touch logger dflags "Touching object file" path + GHC.Utils.Touch.touch path -- Note [-fPIC for assembler] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Driver/Pipeline/Phases.hs b/GHC/Driver/Pipeline/Phases.hs --- a/GHC/Driver/Pipeline/Phases.hs +++ b/GHC/Driver/Pipeline/Phases.hs @@ -47,6 +47,7 @@ T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_LlvmAs :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_MergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath diff --git a/GHC/Driver/Plugins.hs b/GHC/Driver/Plugins.hs --- a/GHC/Driver/Plugins.hs +++ b/GHC/Driver/Plugins.hs @@ -58,6 +58,10 @@ -- | hole fit plugins allow plugins to change the behavior of valid hole -- fit suggestions , HoleFitPluginR + -- ** Late plugins + -- | Late plugins can access and modify the core of a module after + -- optimizations have been applied and after interface creation. + , LatePlugin -- * Internal , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' @@ -89,8 +93,10 @@ import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types +import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic @@ -157,6 +163,13 @@ -- -- @since 8.10.1 + , latePlugin :: LatePlugin + -- ^ A plugin that runs after interface creation and after late cost centre + -- insertion. Useful for transformations that should not impact interfaces + -- or optimization at all. + -- + -- @since 9.10.1 + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. , parsedResultAction :: [CommandLineOption] -> ModSummary @@ -231,6 +244,8 @@ data StaticPlugin = StaticPlugin { spPlugin :: PluginWithArgs -- ^ the actual plugin together with its commandline arguments + , spInitialised :: Bool + -- ^ has this plugin been initialised (i.e. driverPlugin has been run) } lpModuleName :: LoadedPlugin -> ModuleName @@ -260,6 +275,7 @@ type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR +type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState) purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile @@ -280,6 +296,7 @@ , defaultingPlugin = const Nothing , holeFitPlugin = const Nothing , driverPlugin = const return + , latePlugin = \_ -> const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) , parsedResultAction = \_ _ -> return diff --git a/GHC/Driver/Ppr.hs b/GHC/Driver/Ppr.hs --- a/GHC/Driver/Ppr.hs +++ b/GHC/Driver/Ppr.hs @@ -6,6 +6,7 @@ , showPpr , showPprUnsafe , printForUser + , printForUserColoured ) where @@ -34,6 +35,13 @@ doc' = pprWithUnitState unit_state doc printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () -printForUser dflags handle name_ppr_ctx depth doc +printForUser = printForUser' False + +printForUserColoured :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUserColoured = printForUser' True + +printForUser' :: Bool -> DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUser' colour dflags handle name_ppr_ctx depth doc = printSDocLn ctx (PageMode False) handle doc - where ctx = initSDocContext dflags (mkUserStyle name_ppr_ctx depth) + where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth) + diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs --- a/GHC/Driver/Session.hs +++ b/GHC/Driver/Session.hs @@ -17,8 +17,6 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.Driver.Session ( -- * Dynamic flags and associated configuration types DumpFlag(..), @@ -80,6 +78,9 @@ safeDirectImpsReq, safeImplicitImpsReq, unsafeFlags, unsafeFlagsForInfer, + -- ** base + baseUnitId, + -- ** System tool settings and locations Settings(..), sProgramName, @@ -98,21 +99,24 @@ sPgm_F, sPgm_c, sPgm_cxx, + sPgm_cpp, sPgm_a, sPgm_l, sPgm_lm, - sPgm_dll, - sPgm_T, sPgm_windres, sPgm_ar, sPgm_ranlib, sPgm_lo, sPgm_lc, - sPgm_lcc, + sPgm_las, sPgm_i, sOpt_L, sOpt_P, sOpt_P_fingerprint, + sOpt_JSP, + sOpt_JSP_fingerprint, + sOpt_CmmP, + sOpt_CmmP_fingerprint, sOpt_F, sOpt_c, sOpt_cxx, @@ -122,12 +126,12 @@ sOpt_windres, sOpt_lo, sOpt_lc, - sOpt_lcc, sOpt_i, sExtraGccViaCFlags, sTargetPlatformString, sGhcWithInterpreter, sLibFFI, + sTargetRTSLinkerOnlySupportsSharedLibs, GhcNameVersion(..), FileSettings(..), PlatformMisc(..), @@ -136,12 +140,12 @@ ghcUsagePath, ghciUsagePath, topDir, versionedAppDir, versionedFilePath, extraGccViaCFlags, globalPackageDatabasePath, - pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T, - pgm_windres, pgm_ar, - pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i, - opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, - opt_P_signature, - opt_windres, opt_lo, opt_lc, opt_lcc, + pgm_L, pgm_P, pgm_JSP, pgm_CmmP, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l, + pgm_lm, pgm_windres, pgm_ar, + pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i, + opt_L, opt_P, opt_JSP, opt_CmmP, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i, + opt_P_signature, opt_JSP_signature, opt_CmmP_signature, + opt_windres, opt_lo, opt_lc, opt_las, updatePlatformConstants, -- ** Manipulating DynFlags @@ -158,6 +162,7 @@ updOptLevel, setTmpDir, setUnitId, + setHomeUnitId, TurnOnFlag, turnOn, @@ -201,6 +206,9 @@ setUnsafeGlobalDynFlags, -- * SSE and AVX + isSse3Enabled, + isSsse3Enabled, + isSse4_1Enabled, isSse4_2Enabled, isBmiEnabled, isBmi2Enabled, @@ -213,8 +221,6 @@ isFmaEnabled, -- * Linker/compiler information - LinkerInfo(..), - CompilerInfo(..), useXLinkerRPath, -- * Include specifications @@ -231,6 +237,7 @@ import GHC.Platform import GHC.Platform.Ways import GHC.Platform.Profile +import GHC.Platform.ArchOS import GHC.Unit.Types import GHC.Unit.Parser @@ -245,13 +252,17 @@ import GHC.Settings.Config import GHC.Core.Unfold import GHC.Driver.CmdLine +import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Constants (debugIsOn) import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Data.Bool +import GHC.Data.StringBuffer (stringToStringBuffer) import GHC.Types.Error +import GHC.Types.Name.Reader (RdrName(..)) +import GHC.Types.Name.Occurrence (isVarOcc, occNameString) import GHC.Utils.Monad import GHC.Types.SrcLoc import GHC.Types.SafeHaskell @@ -260,9 +271,12 @@ import GHC.Utils.TmpFs import GHC.Utils.Fingerprint import GHC.Utils.Outputable +import GHC.Utils.Error (emptyDiagOpts, logInfo) import GHC.Settings import GHC.CmmToAsm.CFG.Weight import GHC.Core.Opt.CallerCC +import GHC.Parser (parseIdentifier) +import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..)) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) @@ -275,6 +289,7 @@ import Data.Ord import Data.Char import Data.List (intercalate, sortBy, partition) +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set @@ -287,6 +302,7 @@ import qualified GHC.LanguageExtensions as LangExt + -- Note [Updating flag description in the User's Guide] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -382,6 +398,7 @@ settings dflags = Settings { sGhcNameVersion = ghcNameVersion dflags , sFileSettings = fileSettings dflags + , sUnitSettings = unitSettings dflags , sTargetPlatform = targetPlatform dflags , sToolSettings = toolSettings dflags , sPlatformMisc = platformMisc dflags @@ -392,26 +409,26 @@ pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags pgm_P :: DynFlags -> (String,[Option]) pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags +pgm_JSP :: DynFlags -> (String,[Option]) +pgm_JSP dflags = toolSettings_pgm_JSP $ toolSettings dflags +pgm_CmmP :: DynFlags -> (String,[Option]) +pgm_CmmP dflags = toolSettings_pgm_CmmP $ toolSettings dflags pgm_F :: DynFlags -> String pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags pgm_c :: DynFlags -> String pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags pgm_cxx :: DynFlags -> String pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags +pgm_cpp :: DynFlags -> (String,[Option]) +pgm_cpp dflags = toolSettings_pgm_cpp $ toolSettings dflags pgm_a :: DynFlags -> (String,[Option]) pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags pgm_l :: DynFlags -> (String,[Option]) pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags pgm_lm :: DynFlags -> Maybe (String,[Option]) pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags -pgm_dll :: DynFlags -> (String,[Option]) -pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags -pgm_T :: DynFlags -> String -pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags pgm_windres :: DynFlags -> String pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags -pgm_lcc :: DynFlags -> (String,[Option]) -pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags pgm_ar :: DynFlags -> String pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags pgm_ranlib :: DynFlags -> String @@ -420,6 +437,8 @@ pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags pgm_lc :: DynFlags -> (String,[Option]) pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags +pgm_las :: DynFlags -> (String,[Option]) +pgm_las dflags = toolSettings_pgm_las $ toolSettings dflags pgm_i :: DynFlags -> String pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags opt_L :: DynFlags -> [String] @@ -427,6 +446,11 @@ opt_P :: DynFlags -> [String] opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) ++ toolSettings_opt_P (toolSettings dflags) +opt_JSP :: DynFlags -> [String] +opt_JSP dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_JSP (toolSettings dflags) +opt_CmmP :: DynFlags -> [String] +opt_CmmP dflags = toolSettings_opt_CmmP $ toolSettings dflags -- This function packages everything that's needed to fingerprint opt_P -- flags. See Note [Repeated -optP hashing]. @@ -435,6 +459,17 @@ ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) , toolSettings_opt_P_fingerprint $ toolSettings dflags ) +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_JSP_signature :: DynFlags -> ([String], Fingerprint) +opt_JSP_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , toolSettings_opt_JSP_fingerprint $ toolSettings dflags + ) +-- This function packages everything that's needed to fingerprint opt_CmmP +-- flags. See Note [Repeated -optP hashing]. +opt_CmmP_signature :: DynFlags -> Fingerprint +opt_CmmP_signature = toolSettings_opt_CmmP_fingerprint . toolSettings opt_F :: DynFlags -> [String] opt_F dflags= toolSettings_opt_F $ toolSettings dflags @@ -442,7 +477,8 @@ opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) ++ toolSettings_opt_c (toolSettings dflags) opt_cxx :: DynFlags -> [String] -opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags +opt_cxx dflags = concatMap (wayOptcxx (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_cxx (toolSettings dflags) opt_a :: DynFlags -> [String] opt_a dflags= toolSettings_opt_a $ toolSettings dflags opt_l :: DynFlags -> [String] @@ -452,15 +488,19 @@ opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags opt_windres :: DynFlags -> [String] opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags -opt_lcc :: DynFlags -> [String] -opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags opt_lo :: DynFlags -> [String] opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags opt_lc :: DynFlags -> [String] opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags +opt_las :: DynFlags -> [String] +opt_las dflags = toolSettings_opt_las $ toolSettings dflags opt_i :: DynFlags -> [String] opt_i dflags= toolSettings_opt_i $ toolSettings dflags + +setBaseUnitId :: String -> DynP () +setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) } + ----------------------------------------------------------------------------- {- @@ -582,7 +622,8 @@ setDynObjectSuf, setDynHiSuf, setDylibInstallName, setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptc, addOptcxx, addOptP, + setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP, + addOptJSP, addOptCmmP, addCmdlineFramework, addHaddockOpts, addGhciScript, setInteractivePrint :: String -> DynFlags -> DynFlags @@ -671,7 +712,15 @@ -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] -- Config.hs should really use Option. setPgmP f = alterToolSettings (\s -> s { toolSettings_pgm_P = (pgm, map Option args)}) - where (pgm:args) = words f + where pgm:|args = expectNonEmpty $ words f +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmJSP f = alterToolSettings (\s -> s { toolSettings_pgm_JSP = (pgm, map Option args)}) + where pgm:|args = expectNonEmpty $ words f +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)}) + where pgm:|args = expectNonEmpty $ words f addOptl f = alterToolSettings (\s -> s { toolSettings_opt_l = f : toolSettings_opt_l s}) addOptc f = alterToolSettings (\s -> s { toolSettings_opt_c = f : toolSettings_opt_c s}) addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s}) @@ -680,9 +729,15 @@ , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) } -- See Note [Repeated -optP hashing] - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - +addOptJSP f = alterToolSettings $ \s -> s + { toolSettings_opt_JSP = f : toolSettings_opt_JSP s + , toolSettings_opt_JSP_fingerprint = fingerprintStrings (f : toolSettings_opt_JSP s) + } + -- See Note [Repeated -optP hashing] +addOptCmmP f = alterToolSettings $ \s -> s + { toolSettings_opt_CmmP = f : toolSettings_opt_CmmP s + , toolSettings_opt_CmmP_fingerprint = fingerprintStrings (f : toolSettings_opt_CmmP s) + } setDepMakefile :: FilePath -> DynFlags -> DynFlags setDepMakefile f d = d { depMakefile = f } @@ -757,7 +812,7 @@ -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). -parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] +parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. @@ -767,7 +822,7 @@ -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags -- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). -- Used to parse flags set in a modules pragma. -parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] +parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], Messages DriverMessage) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. @@ -816,10 +871,11 @@ :: forall m. MonadIO m => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against -> Bool -- ^ are the arguments from the command line? + -> Logger -- ^ logger -> DynFlags -- ^ current dynamic flags -> [Located String] -- ^ arguments to parse -> m (DynFlags, [Located String], Messages DriverMessage) -parseDynamicFlagsFull activeFlags cmdline dflags0 args = do +parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args -- See Note [Handling errors when parsing command-line flags] @@ -835,7 +891,7 @@ throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ intercalate "/" (map wayDesc (Set.toAscList theWays)))) - let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2 + let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2 -- Set timer stats & heap size when (enableTimeStats dflags3) $ liftIO enableTimingStats @@ -849,6 +905,9 @@ let diag_opts = initDiagOpts dflags3 warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns] + when (logVerbAtLeast logger 3) $ + mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb + return (dflags3, leftover, warns) -- | Check (and potentially disable) any extensions that aren't allowed @@ -949,7 +1008,6 @@ type FlagMaker m = String -> OptKind m -> Flag m type DynFlagMaker = FlagMaker (CmdLineP DynFlags) -data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) -- Make a non-deprecated flag make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) @@ -1062,6 +1120,8 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } , make_ord_flag defFlag "pgmlc" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) } + , make_ord_flag defFlag "pgmlas" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_las = (f,[]) } , make_ord_flag defFlag "pgmlm" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm = if null f then Nothing else Just (f,[]) } @@ -1071,6 +1131,10 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } , make_ord_flag defFlag "pgmP" (hasArg setPgmP) + , make_ord_flag defFlag "pgmJSP" + (hasArg setPgmJSP) + , make_ord_flag defFlag "pgmCmmP" + (hasArg setPgmCmmP) , make_ord_flag defFlag "pgmF" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } , make_ord_flag defFlag "pgmc" @@ -1098,8 +1162,6 @@ } , make_ord_flag defFlag "pgml-supports-no-pie" $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True } - , make_ord_flag defFlag "pgmdll" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) } , make_ord_flag defFlag "pgmwindres" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } , make_ord_flag defFlag "pgmar" @@ -1119,12 +1181,18 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } , make_ord_flag defFlag "optlc" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc = f : toolSettings_opt_lc s } + , make_ord_flag defFlag "optlas" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_las = f : toolSettings_opt_las s } , make_ord_flag defFlag "opti" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s } , make_ord_flag defFlag "optL" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L = f : toolSettings_opt_L s } , make_ord_flag defFlag "optP" (hasArg addOptP) + , make_ord_flag defFlag "optJSP" + (hasArg addOptJSP) + , make_ord_flag defFlag "optCmmP" + (hasArg addOptCmmP) , make_ord_flag defFlag "optF" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } , make_ord_flag defFlag "optc" @@ -1139,9 +1207,6 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } - , make_ord_flag defGhcFlag "split-objs" - (NoArg $ addWarn "ignoring -split-objs") - -- N.B. We may someday deprecate this in favor of -fsplit-sections, -- which has the benefit of also having a negating -fno-split-sections. , make_ord_flag defGhcFlag "split-sections" @@ -1325,6 +1390,13 @@ , make_ord_flag defFlag "fdiagnostics-color=never" (NoArg (upd (\d -> d { useColor = Never }))) + , make_ord_flag defFlag "fprint-error-index-links=auto" + (NoArg (upd (\d -> d { useErrorLinks = Auto }))) + , make_ord_flag defFlag "fprint-error-index-links=always" + (NoArg (upd (\d -> d { useErrorLinks = Always }))) + , make_ord_flag defFlag "fprint-error-index-links=never" + (NoArg (upd (\d -> d { useErrorLinks = Never }))) + -- Suppress all that is suppressible in core dumps. -- Except for uniques, as some simplifier phases introduce new variables that -- have otherwise identical names. @@ -1461,14 +1533,22 @@ "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead" , make_ord_flag defGhcFlag "ddump-stg-tags" (setDumpFlag Opt_D_dump_stg_tags) + , make_ord_flag defGhcFlag "ddump-stg-from-js-sinker" + (setDumpFlag Opt_D_dump_stg_from_js_sinker) , make_ord_flag defGhcFlag "ddump-call-arity" (setDumpFlag Opt_D_dump_call_arity) , make_ord_flag defGhcFlag "ddump-exitify" (setDumpFlag Opt_D_dump_exitify) - , make_ord_flag defGhcFlag "ddump-stranal" - (setDumpFlag Opt_D_dump_stranal) - , make_ord_flag defGhcFlag "ddump-str-signatures" - (setDumpFlag Opt_D_dump_str_signatures) + , make_dep_flag defGhcFlag "ddump-stranal" + (setDumpFlag Opt_D_dump_dmdanal) + "Use `-ddump-dmdanal` instead" + , make_dep_flag defGhcFlag "ddump-str-signatures" + (setDumpFlag Opt_D_dump_dmd_signatures) + "Use `-ddump-dmd-signatures` instead" + , make_ord_flag defGhcFlag "ddump-dmdanal" + (setDumpFlag Opt_D_dump_dmdanal) + , make_ord_flag defGhcFlag "ddump-dmd-signatures" + (setDumpFlag Opt_D_dump_dmd_signatures) , make_ord_flag defGhcFlag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) , make_ord_flag defGhcFlag "ddump-cpr-signatures" @@ -1577,15 +1657,15 @@ (NoArg (setGeneralFlag Opt_NoTypeableBinds)) , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) - , make_ord_flag defGhcFlag "ddump-json" - (setDumpFlag Opt_D_dump_json ) + , make_dep_flag defGhcFlag "ddump-json" + (setDumpFlag Opt_D_dump_json) + "Use `-fdiagnostics-as-json` instead" , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" (noArg (flip dopt_unset Opt_D_no_debug_output)) , make_ord_flag defGhcFlag "dno-debug-output" (setDumpFlag Opt_D_no_debug_output) - , make_ord_flag defGhcFlag "ddump-faststrings" (setDumpFlag Opt_D_dump_faststrings) @@ -1597,6 +1677,8 @@ d { sseVersion = Just SSE2 })) , make_ord_flag defGhcFlag "msse3" (noArg (\d -> d { sseVersion = Just SSE3 })) + , make_ord_flag defGhcFlag "mssse3" (noArg (\d -> + d { sseVersion = Just SSSE3 })) , make_ord_flag defGhcFlag "msse4" (noArg (\d -> d { sseVersion = Just SSE4 })) , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> @@ -1655,6 +1737,9 @@ , make_ord_flag defFlag "fno-refinement-level-hole-fits" (noArg (\d -> d { refLevelHoleFits = Nothing })) + , make_ord_flag defFlag "fwrite-if-compression" + (intSuffix (\n d -> d { ifCompression = n })) + , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" (noArg id) "vectors registers are now passed in registers by default." @@ -1757,8 +1842,23 @@ , make_ord_flag defFlag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n})) + , make_ord_flag defFlag "fmax-forced-spec-args" + (intSuffix (\n d -> d {maxForcedSpecArgs = n})) , make_ord_flag defGhciFlag "fghci-hist-size" (intSuffix (\n d -> d {ghciHistSize = n})) + + -- wasm ghci browser mode + , make_ord_flag defGhciFlag "fghci-browser-host" + $ hasArg $ \f d -> d { ghciBrowserHost = f } + , make_ord_flag defGhciFlag "fghci-browser-port" + $ intSuffix $ \n d -> d { ghciBrowserPort = n } + , make_ord_flag defGhciFlag "fghci-browser-puppeteer-launch-opts" + $ hasArg $ \f d -> d { ghciBrowserPuppeteerLaunchOpts = Just f } + , make_ord_flag defGhciFlag "fghci-browser-playwright-browser-type" + $ hasArg $ \f d -> d { ghciBrowserPlaywrightBrowserType = Just f } + , make_ord_flag defGhciFlag "fghci-browser-playwright-launch-opts" + $ hasArg $ \f d -> d { ghciBrowserPlaywrightLaunchOpts = Just f } + , make_ord_flag defGhcFlag "fmax-inline-alloc-size" (intSuffix (\n d -> d { maxInlineAllocSize = n })) , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" @@ -1892,6 +1992,7 @@ ------ JavaScript flags ----------------------------------------------- ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier)) + , make_ord_flag defFlag "ddisable-js-c-sources" (NoArg (setGeneralFlag Opt_DisableJsCsources)) ] ------ Language flags ------------------------------------------------- @@ -1984,6 +2085,7 @@ (NoArg (setGeneralFlag Opt_DistrustAllPackages)) , make_ord_flag defFlag "trust" (HasArg trustPackage) , make_ord_flag defFlag "distrust" (HasArg distrustPackage) + , make_ord_flag defFlag "base-unit-id" (HasArg setBaseUnitId) ] where setPackageEnv env = upd $ \s -> s { packageEnv = Just env } @@ -2076,18 +2178,6 @@ -> (Deprecation, FlagSpec flag) depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep - --- | Define a new deprecated flag where the deprecation message --- is shown depending on the flag value -depFlagSpecCond :: String - -> flag - -> (TurnOnFlag -> Bool) - -> String - -> (Deprecation, FlagSpec flag) -depFlagSpecCond name flag cond dep = - (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) - AllModes) - -- | Define a new flag for GHCi. flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) flagGhciSpec name flag = flagGhciSpec' name flag nop @@ -2172,12 +2262,13 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x Opt_WarnAmbiguousFields -> warnSpec x - Opt_WarnAutoOrphans - -> depWarnSpec x "it has no effect" + Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect" Opt_WarnCPPUndef -> warnSpec x + Opt_WarnBadlyLevelledTypes -> + warnSpec x ++ + subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types" Opt_WarnUnbangedStrictPatterns -> warnSpec x Opt_WarnDeferredTypeErrors -> warnSpec x Opt_WarnDeferredOutOfScopeVariables -> warnSpec x @@ -2196,26 +2287,25 @@ -> depWarnSpec x "it is not used, and was never implemented" Opt_WarnInaccessibleCode -> warnSpec x Opt_WarnImplicitPrelude -> warnSpec x - Opt_WarnImplicitKindVars - -> depWarnSpec x "it is now an error" + Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error" Opt_WarnIncompletePatterns -> warnSpec x Opt_WarnIncompletePatternsRecUpd -> warnSpec x Opt_WarnIncompleteUniPatterns -> warnSpec x Opt_WarnInconsistentFlags -> warnSpec x Opt_WarnInlineRuleShadowing -> warnSpec x Opt_WarnIdentities -> warnSpec x - Opt_WarnLoopySuperclassSolve -> warnSpec x + Opt_WarnLoopySuperclassSolve -> depWarnSpec x "it is now an error" Opt_WarnMissingFields -> warnSpec x Opt_WarnMissingImportList -> warnSpec x Opt_WarnMissingExportList -> warnSpec x Opt_WarnMissingLocalSignatures -> subWarnSpec "missing-local-sigs" x - "it is replaced by -Wmissing-local-signatures" + "it is replaced by -Wmissing-local-signatures" ++ warnSpec x Opt_WarnMissingMethods -> warnSpec x Opt_WarnMissingMonadFailInstances -> depWarnSpec x "fail is no longer a method of Monad" - Opt_WarnSemigroup -> warnSpec x + Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid" Opt_WarnMissingSignatures -> warnSpec x Opt_WarnMissingKindSignatures -> warnSpec x Opt_WarnMissingPolyKindSignatures -> warnSpec x @@ -2226,7 +2316,8 @@ Opt_WarnMonomorphism -> warnSpec x Opt_WarnNameShadowing -> warnSpec x Opt_WarnNonCanonicalMonadInstances -> warnSpec x - Opt_WarnNonCanonicalMonadFailInstances -> depWarnSpec x "fail is no longer a method of Monad" + Opt_WarnNonCanonicalMonadFailInstances + -> depWarnSpec x "fail is no longer a method of Monad" Opt_WarnNonCanonicalMonoidInstances -> warnSpec x Opt_WarnOrphans -> warnSpec x Opt_WarnOverflowedLiterals -> warnSpec x @@ -2273,13 +2364,15 @@ Opt_WarnPartialFields -> warnSpec x Opt_WarnPrepositiveQualifiedModule -> warnSpec x Opt_WarnUnusedPackages -> warnSpec x - Opt_WarnCompatUnqualifiedImports -> warnSpec x + Opt_WarnCompatUnqualifiedImports -> + depWarnSpec x "This warning no longer does anything; see GHC #24904" Opt_WarnInvalidHaddock -> warnSpec x Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x Opt_WarnOperatorWhitespace -> warnSpec x Opt_WarnImplicitLift -> warnSpec x Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x - Opt_WarnForallIdentifier -> warnSpec x + Opt_WarnForallIdentifier + -> depWarnSpec x "forall is no longer a valid identifier" Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x Opt_WarnGADTMonoLocalBinds -> warnSpec x Opt_WarnTypeEqualityOutOfScope -> warnSpec x @@ -2288,6 +2381,16 @@ Opt_WarnMissingRoleAnnotations -> warnSpec x Opt_WarnImplicitRhsQuantification -> warnSpec x Opt_WarnIncompleteExportWarnings -> warnSpec x + Opt_WarnIncompleteRecordSelectors -> warnSpec x + Opt_WarnDataKindsTC + -> depWarnSpec x "DataKinds violations are now always an error" + Opt_WarnDefaultedExceptionContext -> warnSpec x + Opt_WarnViewPatternSignatures -> warnSpec x + Opt_WarnUselessSpecialisations -> warnSpec x + Opt_WarnDeprecatedPragmas -> warnSpec x + Opt_WarnRuleLhsEqualities -> warnSpec x + Opt_WarnUnusableUnpackPragmas -> warnSpec x + Opt_WarnPatternNamespaceSpecifier -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups @@ -2355,6 +2458,7 @@ flagSpec "defer-typed-holes" Opt_DeferTypedHoles, flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + flagSpec "diagnostics-as-json" Opt_DiagnosticsAsJSON, -- With-ways needs to be reversible hence why its made via flagSpec unlike -- other debugging flags. flagSpec "dump-with-ways" Opt_DumpWithWays, @@ -2364,13 +2468,17 @@ Opt_DmdTxDictSel "effect is now unconditionally enabled", flagSpec "do-eta-reduction" Opt_DoEtaReduction, flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "do-clever-arg-eta-expansion" Opt_DoCleverArgEtaExpansion, -- See Note [Eta expansion of arguments in CorePrep] flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "orig-thunk-info" Opt_OrigThunkInfo, flagSpec "embed-manifest" Opt_EmbedManifest, flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings, flagSpec "error-spans" Opt_ErrorSpans, flagSpec "excess-precision" Opt_ExcessPrecision, flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "expose-overloaded-unfoldings" Opt_ExposeOverloadedUnfoldings, + flagSpec "keep-auto-rules" Opt_KeepAutoRules, flagSpec "expose-internal-symbols" Opt_ExposeInternalSymbols, flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, flagSpec "external-interpreter" Opt_ExternalInterpreter, @@ -2387,10 +2495,19 @@ flagSpec "gen-manifest" Opt_GenManifest, flagSpec "ghci-history" Opt_GhciHistory, flagSpec "ghci-leak-check" Opt_GhciLeakCheck, + flagSpec "inter-module-far-jumps" Opt_InterModuleFarJumps, flagSpec "validate-ide-info" Opt_ValidateHie, flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, flagGhciSpec "no-it" Opt_NoIt, flagSpec "ghci-sandbox" Opt_GhciSandbox, + + -- wasm ghci browser mode + flagGhciSpec "ghci-browser" Opt_GhciBrowser, + flagGhciSpec "ghci-browser-redirect-wasi-console" Opt_GhciBrowserRedirectWasiConsole, + + -- load all targets on GHCi startup + flagGhciSpec "load-initial-targets" Opt_GhciDoLoadTargets, + flagSpec "helpful-errors" Opt_HelpfulErrors, flagSpec "hpc" Opt_Hpc, flagSpec "ignore-asserts" Opt_IgnoreAsserts, @@ -2401,7 +2518,6 @@ flagSpec "late-dmd-anal" Opt_LateDmdAnal, flagSpec "late-specialise" Opt_LateSpecialise, flagSpec "liberate-case" Opt_LiberateCase, - flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, flagSpec "loopification" Opt_Loopification, flagSpec "block-layout-cfg" Opt_CfgBlocklayout, @@ -2428,6 +2544,8 @@ flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, flagSpec "prof-late" Opt_ProfLateCcs, + flagSpec "prof-late-overloaded" Opt_ProfLateOverloadedCcs, + flagSpec "prof-late-overloaded-calls" Opt_ProfLateoverloadedCallsCCs, flagSpec "prof-manual" Opt_ProfManualCcs, flagSpec "prof-late-inline" Opt_ProfLateInlineCcs, flagSpec "regs-graph" Opt_RegsGraph, @@ -2452,6 +2570,8 @@ flagSpec "use-rpaths" Opt_RPath, flagSpec "write-interface" Opt_WriteInterface, flagSpec "write-if-simplified-core" Opt_WriteIfSimplifiedCore, + flagSpec "write-if-self-recomp" Opt_WriteSelfRecompInfo, + flagSpec "write-if-self-recomp-flags" Opt_WriteSelfRecompFlags, flagSpec "write-ide-info" Opt_WriteHie, flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, @@ -2463,9 +2583,12 @@ flagSpec "catch-nonexhaustive-cases" Opt_CatchNonexhaustiveCases, flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, flagSpec "check-prim-bounds" Opt_DoBoundsChecking, + flagSpec "add-bco-name" Opt_AddBcoName, flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "core-constant-folding" Opt_CoreConstantFolding, flagSpec "fast-pap-calls" Opt_FastPAPCalls, + flagSpec "spec-eval" Opt_SpecEval, + flagSpec "spec-eval-dictfun" Opt_SpecEvalDictFun, flagSpec "cmm-control-flow" Opt_CmmControlFlow, flagSpec "show-warning-groups" Opt_ShowWarnGroups, flagSpec "hide-source-paths" Opt_HideSourcePaths, @@ -2475,6 +2598,7 @@ flagSpec "link-rts" Opt_LinkRts, flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode, flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects, + flagSpec "object-determinism" Opt_ObjectDeterminism, flagSpec' "compact-unwind" Opt_CompactUnwind (\turn_on -> updM (\dflags -> do unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) @@ -2569,12 +2693,12 @@ -- the rationale | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] - -- "JavaScriptFFI" is only supported on the JavaScript backend - | notJS, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName] + -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend + | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName] | otherwise = [name, noName] where isAIX = os == OSAIX - notJS = arch /= ArchJavaScript + notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ] noName = "No" ++ name name = flagSpecName flg @@ -2587,7 +2711,8 @@ languageFlagsDeps = [ flagSpec "Haskell98" Haskell98, flagSpec "Haskell2010" Haskell2010, - flagSpec "GHC2021" GHC2021 + flagSpec "GHC2021" GHC2021, + flagSpec "GHC2024" GHC2024 ] -- | These -X flags cannot be reversed with -XNo @@ -2601,266 +2726,38 @@ xFlags :: [FlagSpec LangExt.Extension] xFlags = map snd xFlagsDeps -xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] -xFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- See Note [Adding a language extension] --- Please keep the list of flags below sorted alphabetically - flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, - flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, - flagSpec "AlternativeLayoutRuleTransitional" - LangExt.AlternativeLayoutRuleTransitional, - flagSpec "Arrows" LangExt.Arrows, - depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable - id - ("Typeable instances are created automatically " ++ - "for all types since GHC 8.2."), - flagSpec "BangPatterns" LangExt.BangPatterns, - flagSpec "BinaryLiterals" LangExt.BinaryLiterals, - flagSpec "CApiFFI" LangExt.CApiFFI, - flagSpec "CPP" LangExt.Cpp, - flagSpec "CUSKs" LangExt.CUSKs, - flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, - flagSpec "ConstraintKinds" LangExt.ConstraintKinds, - flagSpec "DataKinds" LangExt.DataKinds, - depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts - id - ("It was widely considered a misfeature, " ++ - "and has been removed from the Haskell language."), - flagSpec "DefaultSignatures" LangExt.DefaultSignatures, - flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, - flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, - flagSpec "DeriveFoldable" LangExt.DeriveFoldable, - flagSpec "DeriveFunctor" LangExt.DeriveFunctor, - flagSpec "DeriveGeneric" LangExt.DeriveGeneric, - flagSpec "DeriveLift" LangExt.DeriveLift, - flagSpec "DeriveTraversable" LangExt.DeriveTraversable, - flagSpec "DerivingStrategies" LangExt.DerivingStrategies, - flagSpec' "DerivingVia" LangExt.DerivingVia - setDeriveVia, - flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, - flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, - flagSpec "BlockArguments" LangExt.BlockArguments, - depFlagSpec' "DoRec" LangExt.RecursiveDo - (deprecatedForExtension "RecursiveDo"), - flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, - flagSpec "FieldSelectors" LangExt.FieldSelectors, - flagSpec "EmptyCase" LangExt.EmptyCase, - flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, - flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, - flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, - flagSpec "ExplicitForAll" LangExt.ExplicitForAll, - flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, - flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, - flagSpec "ExtendedLiterals" LangExt.ExtendedLiterals, - flagSpec "FlexibleContexts" LangExt.FlexibleContexts, - flagSpec "FlexibleInstances" LangExt.FlexibleInstances, - flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, - flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, - flagSpec "GADTSyntax" LangExt.GADTSyntax, - flagSpec "GADTs" LangExt.GADTs, - flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, - flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving - setGenDeriving, - flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving - setGenDeriving, - flagSpec "ImplicitParams" LangExt.ImplicitParams, - flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, - flagSpec "ImportQualifiedPost" LangExt.ImportQualifiedPost, - flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, - flagSpec' "IncoherentInstances" LangExt.IncoherentInstances - setIncoherentInsts, - flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, - flagSpec "InstanceSigs" LangExt.InstanceSigs, - flagSpec "ApplicativeDo" LangExt.ApplicativeDo, - flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, - flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, - flagSpec "KindSignatures" LangExt.KindSignatures, - flagSpec "LambdaCase" LangExt.LambdaCase, - flagSpec "LexicalNegation" LangExt.LexicalNegation, - flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, - flagSpec "LinearTypes" LangExt.LinearTypes, - flagSpec "MagicHash" LangExt.MagicHash, - flagSpec "MonadComprehensions" LangExt.MonadComprehensions, - flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, - flagSpec "DeepSubsumption" LangExt.DeepSubsumption, - flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, - flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, - flagSpec "MultiWayIf" LangExt.MultiWayIf, - flagSpec "NumericUnderscores" LangExt.NumericUnderscores, - flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, - flagSpec "NamedFieldPuns" LangExt.NamedFieldPuns, - flagSpec "NamedWildCards" LangExt.NamedWildCards, - flagSpec "NegativeLiterals" LangExt.NegativeLiterals, - flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, - flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, - depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses - (deprecatedForExtension "MultiParamTypeClasses"), - flagSpec "NumDecimals" LangExt.NumDecimals, - depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances - setOverlappingInsts - "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", - flagSpec "OverloadedLabels" LangExt.OverloadedLabels, - flagSpec "OverloadedLists" LangExt.OverloadedLists, - flagSpec "OverloadedStrings" LangExt.OverloadedStrings, - flagSpec "PackageImports" LangExt.PackageImports, - flagSpec "ParallelArrays" LangExt.ParallelArrays, - flagSpec "ParallelListComp" LangExt.ParallelListComp, - flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, - flagSpec "PatternGuards" LangExt.PatternGuards, - depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables - (deprecatedForExtension "ScopedTypeVariables"), - flagSpec "PatternSynonyms" LangExt.PatternSynonyms, - flagSpec "PolyKinds" LangExt.PolyKinds, - flagSpec "PolymorphicComponents" LangExt.RankNTypes, - flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, - flagSpec "PostfixOperators" LangExt.PostfixOperators, - flagSpec "QuasiQuotes" LangExt.QuasiQuotes, - flagSpec "QualifiedDo" LangExt.QualifiedDo, - flagSpec "Rank2Types" LangExt.RankNTypes, - flagSpec "RankNTypes" LangExt.RankNTypes, - flagSpec "RebindableSyntax" LangExt.RebindableSyntax, - flagSpec "OverloadedRecordDot" LangExt.OverloadedRecordDot, - flagSpec "OverloadedRecordUpdate" LangExt.OverloadedRecordUpdate, - depFlagSpec' "RecordPuns" LangExt.NamedFieldPuns - (deprecatedForExtension "NamedFieldPuns"), - flagSpec "RecordWildCards" LangExt.RecordWildCards, - flagSpec "RecursiveDo" LangExt.RecursiveDo, - flagSpec "RelaxedLayout" LangExt.RelaxedLayout, - depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec - not - "You can't turn off RelaxedPolyRec any more", - flagSpec "RoleAnnotations" LangExt.RoleAnnotations, - flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, - flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, - flagSpec "StarIsType" LangExt.StarIsType, - flagSpec "StaticPointers" LangExt.StaticPointers, - flagSpec "Strict" LangExt.Strict, - flagSpec "StrictData" LangExt.StrictData, - flagSpec' "TemplateHaskell" LangExt.TemplateHaskell - checkTemplateHaskellOk, - flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, - flagSpec "StandaloneKindSignatures" LangExt.StandaloneKindSignatures, - flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, - flagSpec "TransformListComp" LangExt.TransformListComp, - flagSpec "TupleSections" LangExt.TupleSections, - flagSpec "TypeAbstractions" LangExt.TypeAbstractions, - flagSpec "TypeApplications" LangExt.TypeApplications, - flagSpec "TypeData" LangExt.TypeData, - depFlagSpec' "TypeInType" LangExt.TypeInType - (deprecatedForExtensions ["DataKinds", "PolyKinds"]), - flagSpec "TypeFamilies" LangExt.TypeFamilies, - flagSpec "TypeOperators" LangExt.TypeOperators, - flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, - flagSpec "UnboxedTuples" LangExt.UnboxedTuples, - flagSpec "UnboxedSums" LangExt.UnboxedSums, - flagSpec "UndecidableInstances" LangExt.UndecidableInstances, - flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, - flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, - flagSpec "UnliftedDatatypes" LangExt.UnliftedDatatypes, - flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, - flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes, - flagSpec "ViewPatterns" LangExt.ViewPatterns - ] - -validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -validHoleFitsImpliedGFlags - = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) - , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) - , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) - , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] - --- General flags that are switched on/off when other general flags are switched --- on -impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) - ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) - ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting) - ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) - ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface) - ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore) - ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack) - ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback) - ] ++ validHoleFitsImpliedGFlags - --- General flags that are switched on/off when other general flags are switched --- off -impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] -impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] - -impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] -impliedXFlags --- See Note [Updating flag description in the User's Guide] - = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) - , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) - , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) - , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) - , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) - , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) - , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) - , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 - , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) - - , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! - - , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) - - , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) - , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) - , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) - - , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures - , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds - - -- TypeInType is now just a synonym for a couple of other extensions. - , (LangExt.TypeInType, turnOn, LangExt.DataKinds) - , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) - , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) - - -- Standalone kind signatures are a replacement for CUSKs. - , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs) - - -- AutoDeriveTypeable is not very useful without DeriveDataTypeable - , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) - - -- We turn this on so that we can export associated type - -- type synonyms in subordinates (e.g. MyClass(type AssocType)) - , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) - , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) - - , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) - - -- Record wild-cards implies field disambiguation - -- Otherwise if you write (C {..}) you may well get - -- stuff like " 'a' not in scope ", which is a bit silly - -- if the compiler has just filled in field 'a' of constructor 'C' - , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) - - , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) - - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) - , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) - - -- Duplicate record fields require field disambiguation - , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) - - , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) - , (LangExt.Strict, turnOn, LangExt.StrictData) - - -- Historically only UnboxedTuples was required for unboxed sums to work. - -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums. - , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums) +makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)] +makeExtensionFlags ext = [ makeExtensionFlag name depr ext | (depr, name) <- extensionNames ext ] - -- The extensions needed to declare an H98 unlifted data type - , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds) - , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures) - ] +xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +xFlagsDeps = concatMap makeExtensionFlags [minBound .. maxBound] +makeExtensionFlag :: String -> ExtensionDeprecation -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension) +makeExtensionFlag name depr ext = (deprecation depr, spec) + where effect = extensionEffect ext + spec = FlagSpec name ext (\f -> effect f >> act f) AllModes + act = case depr of + ExtensionNotDeprecated -> nop + ExtensionDeprecatedFor xs + -> deprecate . deprecatedForExtensions (map extensionName xs) + ExtensionFlagDeprecatedCond cond str + -> \f -> when (f == cond) (deprecate str) + ExtensionFlagDeprecated str + -> const (deprecate str) +extensionEffect :: LangExt.Extension -> (TurnOnFlag -> DynP ()) +extensionEffect = \case + LangExt.TemplateHaskell + -> checkTemplateHaskellOk + LangExt.OverlappingInstances + -> setOverlappingInsts + LangExt.GeneralizedNewtypeDeriving + -> setGenDeriving + LangExt.IncoherentInstances + -> setIncoherentInsts + LangExt.DerivingVia + -> setDeriveVia + _ -> nop -- | Things you get with `-dlint`. enableDLint :: DynP () @@ -2886,40 +2783,6 @@ disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls mapM_ unSetExtensionFlag glasgowExtsFlags --- Please keep what_glasgow_exts_does.rst up to date with this list -glasgowExtsFlags :: [LangExt.Extension] -glasgowExtsFlags = [ - LangExt.ConstrainedClassMethods - , LangExt.DeriveDataTypeable - , LangExt.DeriveFoldable - , LangExt.DeriveFunctor - , LangExt.DeriveGeneric - , LangExt.DeriveTraversable - , LangExt.EmptyDataDecls - , LangExt.ExistentialQuantification - , LangExt.ExplicitNamespaces - , LangExt.FlexibleContexts - , LangExt.FlexibleInstances - , LangExt.ForeignFunctionInterface - , LangExt.FunctionalDependencies - , LangExt.GeneralizedNewtypeDeriving - , LangExt.ImplicitParams - , LangExt.KindSignatures - , LangExt.LiberalTypeSynonyms - , LangExt.MagicHash - , LangExt.MultiParamTypeClasses - , LangExt.ParallelListComp - , LangExt.PatternGuards - , LangExt.PostfixOperators - , LangExt.RankNTypes - , LangExt.RecursiveDo - , LangExt.ScopedTypeVariables - , LangExt.StandaloneDeriving - , LangExt.TypeOperators - , LangExt.TypeSynonymInstances - , LangExt.UnboxedTuples - , LangExt.UnicodeSyntax - , LangExt.UnliftedFFITypes ] setWarnSafe :: Bool -> DynP () setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) @@ -3116,13 +2979,18 @@ setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps where - deps = [ if turn_on then setExtensionFlag' d - else unSetExtensionFlag' d - | (f', turn_on, d) <- impliedXFlags, f' == f ] + deps :: [DynFlags -> DynFlags] + deps = [ setExtension d + | (f', d) <- impliedXFlags, f' == f ] -- When you set f, set the ones it implies -- NB: use setExtensionFlag recursively, in case the implied flags -- implies further flags + setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags + setExtension = \ case + On extension -> setExtensionFlag' extension + Off extension -> unSetExtensionFlag' extension + unSetExtensionFlag' f dflags = xopt_unset dflags f -- When you un-set f, however, we don't un-set the things it implies -- (except for -fno-glasgow-exts, which is treated specially) @@ -3252,6 +3120,9 @@ setUnitId :: String -> DynFlags -> DynFlags setUnitId p d = d { homeUnitId_ = stringToUnitId p } +setHomeUnitId :: UnitId -> DynFlags -> DynFlags +setHomeUnitId p d = d { homeUnitId_ = p } + setWorkingDirectory :: String -> DynFlags -> DynFlags setWorkingDirectory p d = d { workingDirectory = Just p } @@ -3286,9 +3157,26 @@ addReexportedModule :: String -> DynP () addReexportedModule p = - upd (\s -> s{ reexportedModules = Set.insert (mkModuleName p) (reexportedModules s) }) + upd (\s -> s{ reexportedModules = (parseReexportedModule p) : (reexportedModules s) }) +parseReexportedModule :: String -- string to parse + -> ReexportedModule +parseReexportedModule str + = case filter ((=="").snd) (readP_to_S parseItem str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse reexported module flag: " ++ str) + where + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (ReexportedModule orig new)) + +++ + return (ReexportedModule orig orig) + tok m = m >>= \x -> skipSpaces >> return x + + -- If we're linking a binary, then only backends that produce object -- code are allowed (requests for other target types are ignored). setBackend :: Backend -> DynP () @@ -3319,19 +3207,33 @@ Left err -> addErr err setMainIs :: String -> DynP () -setMainIs arg - | x:_ <- main_fn, isLower x -- The arg looked like "Foo.Bar.baz" - = upd $ \d -> d { mainFunIs = Just main_fn, - mainModuleNameIs = mkModuleName main_mod } +setMainIs arg = parse parse_main_f arg + where + parse callback str = case unP parseIdentifier (p_state str) of + PFailed _ -> addErr $ "Can't parse -main-is \"" ++ arg ++ "\" as an identifier or module." + POk _ (L _ re) -> callback re - | x:_ <- arg, isUpper x -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d { mainModuleNameIs = mkModuleName arg } + -- dummy parser state. + p_state str = initParserState + (mkParserOpts mempty emptyDiagOpts False False False True) + (stringToStringBuffer str) + (mkRealSrcLoc (mkFastString []) 1 1) - | otherwise -- The arg looked like "baz" - = upd $ \d -> d { mainFunIs = Just arg } - where - (main_mod, main_fn) = splitLongestPrefix arg (== '.') + parse_main_f (Unqual occ) + | isVarOcc occ = upd $ \d -> d { mainFunIs = main_f occ } + parse_main_f (Qual (ModuleName mod) occ) + | isVarOcc occ = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod + , mainFunIs = main_f occ } + -- append dummy "function" to parse A.B as the module A.B + -- and not the Data constructor B from the module A + parse_main_f _ = parse parse_mod (arg ++ ".main") + main_f = Just . occNameString + + parse_mod (Qual (ModuleName mod) _) = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod } + -- we appended ".m" and any parse error was caught. We are Qual or something went very wrong + parse_mod _ = error "unreachable" + addLdInputs :: Option -> DynFlags -> DynFlags addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} @@ -3502,7 +3404,17 @@ -- objects, but can't without -fPIC. See -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn -> - ["-fPIC", "-U__PIC__", "-D__PIC__"] + ["-fPIC", "-U__PIC__", "-D__PIC__"] ++ + -- Clang defaults to -fvisibility=hidden for wasm targets, + -- but we need these compile-time flags to generate PIC + -- objects that can be properly linked by wasm-ld using + -- --export-dynamic; without these flags we would need + -- -Wl,--export-all at .so link-time which will export + -- internal symbols as well, and that severely pollutes the + -- global symbol namespace. + (if platformArch (targetPlatform dflags) == ArchWasm32 + then [ "-fvisibility=default", "-fvisibility-inlines-hidden" ] + else []) -- gcc may be configured to have PIC on by default, let's be -- explicit here, see #15847 | otherwise -> ["-fno-PIC"] @@ -3551,11 +3463,15 @@ ("Project Patch Level1", cProjectPatchLevel1), ("Project Patch Level2", cProjectPatchLevel2), ("Project Unit Id", cProjectUnitId), + ("ghc-internal Unit Id", cGhcInternalUnitId), -- See Note [Special unit-ids] ("Booter version", cBooterVersion), ("Stage", cStage), ("Build platform", cBuildPlatformString), ("Host platform", cHostPlatformString), ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), + ("target os string", stringEncodeOS (platformOS (targetPlatform dflags))), + ("target arch string", stringEncodeArch (platformArch (targetPlatform dflags))), + ("target word size in bits", show (platformWordSizeInBits (targetPlatform dflags))), ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), ("Object splitting supported", showBool False), ("Have native code generator", showBool $ platformNcgSupported platform), @@ -3588,7 +3504,8 @@ ("GHC Profiled", showBool hostIsProfiled), ("Debug on", showBool debugIsOn), ("LibDir", topDir dflags), - -- The path of the global package database used by GHC + -- This is always an absolute path, unlike "Relative Global Package DB" which is + -- in the settings file. ("Global Package DB", globalPackageDatabasePath dflags) ] where @@ -3600,6 +3517,26 @@ expandDirectories :: FilePath -> Maybe FilePath -> String -> String expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd +-- Note [Special unit-ids] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Certain units are special to the compiler: +-- - Wired-in identifiers reference a specific unit-id of `ghc-internal`. +-- - GHC plugins must be linked against a specific unit-id of `ghc`, +-- namely the same one as the compiler. +-- - When using Template Haskell, the result of executing splices refer to +-- the Template Haskell ASTs created using constructors from `ghc-internal`, +-- and must be linked against the same `ghc-internal` unit-id as the compiler. +-- +-- We therefore expose the unit-id of `ghc-internal` ("ghc-internal Unit Id") and +-- ghc ("Project Unit Id") through `ghc --info`. +-- +-- This allows build tools to act accordingly, eg, if a user wishes to build a +-- GHC plugin, `cabal-install` might force them to use the exact `ghc` unit +-- that the compiler was linked against. +-- See: +-- - https://github.com/haskell/cabal/issues/10087 +-- - https://github.com/commercialhaskell/stack/issues/6749 + {- ----------------------------------------------------------------------------- Note [DynFlags consistency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3624,12 +3561,35 @@ the flags; this is because API clients may parse flags but update the DynFlags afterwords, before finally running code inside a session (see T10052 and #10052). + +Host ways vs Build ways mismatch +-------------------------------- +Many consistency checks aim to fix the situation where the wanted build ways +are not compatible with the ways the compiler is built in. This happens when +using the interpreter, TH, and the runtime linker, where the compiler cannot +load objects compiled for ways not matching its own. + +For instance, a profiled-dynamic object can only be loaded by a +profiled-dynamic compiler (and not any other kind of compiler). + +This incompatibility is traditionally solved in either of two ways: + +(1) Force the "wanted" build ways to match the compiler ways exactly, + guaranteeing they match. + +(2) Force the use of the external interpreter. When interpreting is offloaded + to the external interpreter it no longer matters what are the host compiler ways. + +In the checks and fixes performed by `makeDynFlagsConsistent`, the choice +between the two does not seem uniform. TODO: Make this choice more evident and uniform. -} -- | Resolve any internal inconsistencies in a set of 'DynFlags'. -- Returns the consistent 'DynFlags' as well as a list of warnings --- to report to the user. -makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn]) +-- to report to the user, and a list of verbose info msgs. +-- +-- See Note [DynFlags consistency] +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc]) -- Whenever makeDynFlagsConsistent does anything, it starts over, to -- ensure that a later change doesn't invalidate an earlier check. -- Be careful not to introduce potential loops! @@ -3711,15 +3671,58 @@ = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)} "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + | gopt Opt_ByteCode dflags || gopt Opt_ByteCodeAndObjectCode dflags + , not (gopt Opt_ExternalInterpreter dflags) + , hostIsProfiled + , ways dflags `hasNotWay` WayProf + = loop (gopt_set dflags Opt_ExternalInterpreter) + "Enabling external interpreter, because GHC is profiled and bytecode is being used for TH" + | LinkMergedObj <- ghcLink dflags , Nothing <- outputFile dflags - = pgmError "--output must be specified when using --merge-objs" + = pgmError "--output must be specified when using --merge-objs" - | otherwise = (dflags, mempty) + | platformTablesNextToCode platform + && os == OSMinGW32 + && arch == ArchAArch64 + = case backendCodeOutput (backend dflags) of + LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64" + NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64" + _ -> (dflags, mempty, mempty) + + -- When we do ghci, force using dyn ways if the target RTS linker + -- only supports dynamic code + | LinkInMemory <- ghcLink dflags + , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags + , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags) + = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $ + -- See checkOptions, -fexternal-interpreter is + -- required when using --interactive with a non-standard + -- way (-prof, -static, or -dynamic). + setGeneralFlag' Opt_ExternalInterpreter $ + addWay' WayDyn dflags + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , targetWays_ dflags /= hostFullWays + = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $ + let dflags_a = dflags { targetWays_ = hostFullWays } + dflags_b = foldl gopt_set dflags_a + $ concatMap (wayGeneralFlags platform) + hostFullWays + dflags_c = foldl gopt_unset dflags_b + $ concatMap (wayUnsetGeneralFlags platform) + hostFullWays + in dflags_c + + | otherwise = (dflags, mempty, mempty) where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") loop updated_dflags warning = case makeDynFlagsConsistent updated_dflags of - (dflags', ws) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws) + (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is) + loopNoWarn updated_dflags doc + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws, is) -> (dflags', ws, L loc (text doc):is) platform = targetPlatform dflags arch = platformArch platform os = platformOS platform @@ -3733,49 +3736,7 @@ -- ----------------------------------------------------------------------------- --- SSE, AVX, FMA -isSse4_2Enabled :: DynFlags -> Bool -isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 - -isAvxEnabled :: DynFlags -> Bool -isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags - -isAvx2Enabled :: DynFlags -> Bool -isAvx2Enabled dflags = avx2 dflags || avx512f dflags - -isAvx512cdEnabled :: DynFlags -> Bool -isAvx512cdEnabled dflags = avx512cd dflags - -isAvx512erEnabled :: DynFlags -> Bool -isAvx512erEnabled dflags = avx512er dflags - -isAvx512fEnabled :: DynFlags -> Bool -isAvx512fEnabled dflags = avx512f dflags - -isAvx512pfEnabled :: DynFlags -> Bool -isAvx512pfEnabled dflags = avx512pf dflags - -isFmaEnabled :: DynFlags -> Bool -isFmaEnabled dflags = fma dflags - --- ----------------------------------------------------------------------------- --- BMI2 - -isBmiEnabled :: DynFlags -> Bool -isBmiEnabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> bmiVersion dflags >= Just BMI1 - ArchX86 -> bmiVersion dflags >= Just BMI1 - _ -> False - -isBmi2Enabled :: DynFlags -> Bool -isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of - ArchX86_64 -> bmiVersion dflags >= Just BMI2 - ArchX86 -> bmiVersion dflags >= Just BMI2 - _ -> False - --- ----------------------------------------------------------------------------- - -- | Indicate if cost-centre profiling is enabled sccProfilingEnabled :: DynFlags -> Bool sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags) @@ -3785,12 +3746,19 @@ needSourceNotes dflags = debugLevel dflags > 0 || gopt Opt_InfoTableMap dflags + -- Source ticks are used to approximate the location of + -- overloaded call cost centers + || gopt Opt_ProfLateoverloadedCallsCCs dflags + -- ----------------------------------------------------------------------------- -- Linker/compiler information -- | Should we use `-XLinker -rpath` when linking or not? -- See Note [-fno-use-rpaths] useXLinkerRPath :: DynFlags -> OS -> Bool +-- wasm shared libs don't have RPATH at all and wasm-ld doesn't accept +-- any RPATH-related flags +useXLinkerRPath dflags _ | ArchWasm32 <- platformArch $ targetPlatform dflags = False useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS] useXLinkerRPath dflags _ = gopt Opt_RPath dflags diff --git a/GHC/Driver/Session/Inspect.hs b/GHC/Driver/Session/Inspect.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session/Inspect.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE LambdaCase #-} + +-- | GHC API utilities for inspecting the GHC session +module GHC.Driver.Session.Inspect where + +import GHC.Prelude +import GHC.Data.Maybe +import Control.Monad + +import GHC.ByteCode.Types +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Driver.Env +import GHC.Driver.Main +import GHC.Driver.Monad +import GHC.Driver.Session +import GHC.Rename.Names +import GHC.Runtime.Context +import GHC.Runtime.Interpreter +import GHC.Types.Avail +import GHC.Types.Name +import GHC.Types.Name.Ppr +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.PkgQual +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.TypeEnv +import GHC.Unit.External +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Utils.Misc +import GHC.Utils.Outputable +import qualified GHC.Unit.Home.Graph as HUG + +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ + +-- | Get the module dependency graph. +getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary +getModuleGraph = liftM hsc_mod_graph getSession + +{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-} +-- | Return @True@ \<==> module is loaded. +isLoaded :: GhcMonad m => ModuleName -> m Bool +isLoaded m = withSession $ \hsc_env -> liftIO $ do + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) + +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable' +-- for the given 'UnitId'. +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool +isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m + return $! isJust hmi + +-- | Check whether 'Module' is part of the 'HomeUnitGraph'. +-- +-- Similar to 'isLoadedModule', but for 'Module's. +isLoadedHomeModule :: GhcMonad m => Module -> m Bool +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do + hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env) + return $! isJust hmi + +-- | Return the bindings for the current interactive session. +getBindings :: GhcMonad m => m [TyThing] +getBindings = withSession $ \hsc_env -> + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([ClsInst], [FamInst]) +getInsts = withSession $ \hsc_env -> + let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) + in return (instEnvElts inst_env, fam_env) + +getNamePprCtx :: GhcMonad m => m NamePprCtx +getNamePprCtx = withSession $ \hsc_env -> do + return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env) + +-- | Container for information about a 'Module'. +data ModuleInfo = ModuleInfo { + minf_type_env :: TypeEnv, + minf_exports :: [AvailInfo], + minf_instances :: [ClsInst], + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode, + minf_modBreaks :: Maybe InternalModBreaks + } + -- We don't want HomeModInfo here, because a ModuleInfo applies + -- to package modules too. + +-- | Request information about a loaded 'Module' +getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X +getModuleInfo mdl = withSession $ \hsc_env -> do + if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env) + then liftIO $ getHomeModuleInfo hsc_env mdl + else liftIO $ getPackageModuleInfo hsc_env mdl + +getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getPackageModuleInfo hsc_env mdl + = do eps <- hscEPS hsc_env + iface <- hscGetModuleInterface hsc_env mdl + let + avails = mi_exports iface + pte = eps_PTE eps + tys = [ ty | name <- concatMap availNames avails, + Just ty <- [lookupTypeEnv pte name] ] + + return (Just (ModuleInfo { + minf_type_env = mkTypeEnv tys, + minf_exports = avails, + minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = Nothing + })) + +availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv +availsToGlobalRdrEnv hsc_env mod avails + = forceGlobalRdrEnv rdr_env + -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + where + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails) + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll} + decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod, + is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual, + is_dloc = srcLocSpan interactiveSrcLoc, + is_level = NormalLevel } + +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) +getHomeModuleInfo hsc_env mdl = + HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case + Nothing -> return Nothing + Just hmi -> do + let details = hm_details hmi + iface = hm_iface hmi + return (Just (ModuleInfo { + minf_type_env = md_types details, + minf_exports = md_exports details, + -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo. + minf_instances = instEnvElts $ md_insts details, + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, + minf_modBreaks = getModBreaks hmi + })) + +-- | The list of top-level entities defined in a module +modInfoTyThings :: ModuleInfo -> [TyThing] +modInfoTyThings minf = typeEnvElts (minf_type_env minf) + +modInfoExports :: ModuleInfo -> [Name] +modInfoExports minf = concatMap availNames $! minf_exports minf + +modInfoExportsWithSelectors :: ModuleInfo -> [Name] +modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf + +-- | Returns the instances defined by the specified module. +-- Warning: currently unimplemented for package modules. +modInfoInstances :: ModuleInfo -> [ClsInst] +modInfoInstances = minf_instances + +modInfoIsExportedName :: ModuleInfo -> Name -> Bool +modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) + +mkNamePprCtxForModule :: + GhcMonad m => + Module -> + ModuleInfo -> + m NamePprCtx +mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf)) + ptc = initPromotionTickContext (hsc_dflags hsc_env) + return name_ppr_ctx + +modInfoLookupName :: GhcMonad m => + ModuleInfo -> Name + -> m (Maybe TyThing) -- XXX: returns a Maybe X +modInfoLookupName minf name = withSession $ \hsc_env -> do + case lookupTypeEnv (minf_type_env minf) name of + Just tyThing -> return (Just tyThing) + Nothing -> liftIO (lookupType hsc_env name) + +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + +modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks +modInfoModBreaks = minf_modBreaks + diff --git a/GHC/Driver/Session/Units.hs b/GHC/Driver/Session/Units.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Session/Units.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TupleSections #-} +module GHC.Driver.Session.Units (initMake, initMulti) where + +-- The official GHC API +import qualified GHC +import GHC (parseTargetFiles, Ghc, GhcMonad(..)) + +import GHC.Driver.Env +import GHC.Driver.Errors +import GHC.Driver.Errors.Types +import GHC.Driver.Phases +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Pipeline ( oneShot, compileFile ) +import GHC.Driver.Config.Diagnostic + +import GHC.Unit.Env +import GHC.Unit (UnitId) +import GHC.Unit.Home.PackageTable +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.State ( emptyUnitState ) +import qualified GHC.Unit.State as State + +import GHC.Types.SrcLoc +import GHC.Types.SourceError + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Monad ( liftIO, mapMaybeM ) +import GHC.Data.Maybe + +import System.IO +import System.Exit +import System.FilePath +import Control.Monad +import Data.List ( partition, (\\) ) +import qualified Data.Set as Set +import Prelude +import GHC.ResponseFile (expandResponse) +import Data.Bifunctor +import GHC.Data.Graph.Directed +import qualified Data.List.NonEmpty as NE + +-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list. +removeRTS :: [String] -> [String] +removeRTS ("+RTS" : xs) = + case dropWhile (/= "-RTS") xs of + [] -> [] + (_ : ys) -> removeRTS ys +removeRTS (y:ys) = y : removeRTS ys +removeRTS [] = [] + +initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)] +initMake srcs = do + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + hsc_env <- GHC.getSession + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot hsc_env NoStop srcs) >> return [] + else do + + o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x) + non_hs_srcs + dflags <- GHC.getSessionDynFlags + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } + _ <- GHC.setSessionDynFlags dflags' + return hs_srcs + +initMulti :: NE.NonEmpty String + -> (DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ()) + -- ^ Function to lint initMulti DynFlags and sources. + -- In GHC, this is instanced to @checkOptions@. + -> Ghc ([(String, Maybe UnitId, Maybe Phase)]) +initMulti unitArgsFiles lintDynFlagsAndSrcs = do + hsc_env <- GHC.getSession + let logger = hsc_logger hsc_env + initial_dflags <- GHC.getSessionDynFlags + + dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do + when (verbosity initial_dflags > 2) (liftIO $ print f) + args <- liftIO $ expandResponse [f] + (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args)) + handleSourceError (\e -> do + GHC.printException e + liftIO $ exitWith (ExitFailure 1)) $ do + liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) + + let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args) + dflags4 = offsetDynFlags dflags3 + + let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs + + -- This is dubious as the whole unit environment won't be set-up correctly, but + -- that doesn't matter for what we use it for (linking and oneShot) + let dubious_hsc_env = hscSetFlags dflags4 hsc_env + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, []) + else do + + o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x) + non_hs_srcs + let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags4 } + + liftIO $ lintDynFlagsAndSrcs dflags5 srcs objs [] + + pure (dflags5, hs_srcs) + + let + unitDflags = NE.map fst dynFlagsAndSrcs + srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs + (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs)) + + checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags)) + + (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags + let home_units = HUG.allUnits initial_home_graph + + home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv + hue_flags = homeUnitEnv_dflags homeUnitEnv + dflags = homeUnitEnv_dflags homeUnitEnv + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units + + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants + emptyHpt <- liftIO $ emptyHomePackageTable + pure $ HomeUnitEnv + { homeUnitEnv_units = unit_state + , homeUnitEnv_unit_dbs = Just dbs + , homeUnitEnv_dflags = updated_dflags + , homeUnitEnv_hpt = emptyHpt + , homeUnitEnv_home_unit = Just home_unit + } + + checkUnitCycles initial_dflags home_unit_graph + + let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph + unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)) + let final_hsc_env = hsc_env { hsc_unit_env = unitEnv } + + GHC.setSession final_hsc_env + + -- if we have no haskell sources from which to do a dependency + -- analysis, then just do one-shot compilation and/or linking. + -- This means that "ghc Foo.o Bar.o -o baz" links the program as + -- we expect. + if (null hs_srcs) + then do + liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode." + liftIO $ exitWith (ExitFailure 1) + else do + +{- + o_files <- liftIO $ mapMaybeM + (\(src, uid, mphase) -> + compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase) + ) + (concat non_hs_srcs) + -} + + -- MP: This should probably modify dflags for each unit? + --let dflags' = dflags { ldInputs = map (FileOption "") o_files + -- ++ ldInputs dflags } + return $ concat hs_srcs + +checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc () +checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph) + where + + processSCCs [] = return () + processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs + processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids) + + + cycle_err uids = + hang (text "Units form a dependency cycle:") + 2 + (one_err uids) + + one_err uids = vcat $ + (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start) + ++ [text "-" <+> ppr final] + where + start = init uids + final = last uids + +-- | Check that we don't have multiple units with the same UnitId. +checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc () +checkDuplicateUnits dflags flags = + unless (null duplicate_ids) + (throwGhcException $ CmdLineError $ showSDoc dflags multi_err) + + where + uids = map (second homeUnitId_) flags + deduplicated_uids = ordNubOn snd uids + duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids) + + duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids + + one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp + + multi_err = + hang (text "Multiple units with the same unit-id:") + 2 + (vcat (map one_err duplicate_flags)) + + +offsetDynFlags :: DynFlags -> DynFlags +offsetDynFlags dflags = + dflags { hiDir = c hiDir + , objectDir = c objectDir + , stubDir = c stubDir + , hieDir = c hieDir + , dumpDir = c dumpDir } + + where + c f = augment_maybe (f dflags) + + augment_maybe Nothing = Nothing + augment_maybe (Just f) = Just (augment f) + augment f | isRelative f, Just offset <- workingDirectory dflags = offset f + | otherwise = f + + +createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId) +createUnitEnvFromFlags unitDflags = do + unitEnvList <- forM unitDflags $ \dflags -> do + emptyHpt <- emptyHomePackageTable + let newInternalUnitEnv = + HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing + return (homeUnitId_ dflags, newInternalUnitEnv) + let activeUnit = fst $ NE.head unitEnvList + return (HUG.hugFromList (NE.toList unitEnvList), activeUnit) + + diff --git a/GHC/Hs.hs b/GHC/Hs.hs --- a/GHC/Hs.hs +++ b/GHC/Hs.hs @@ -18,6 +18,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data +{-# LANGUAGE DataKinds #-} module GHC.Hs ( module Language.Haskell.Syntax, @@ -59,7 +60,7 @@ import GHC.Utils.Outputable import GHC.Types.Fixity ( Fixity ) import GHC.Types.SrcLoc -import GHC.Unit.Module.Warnings ( WarningTxt ) +import GHC.Unit.Module.Warnings -- libraries: import Data.Data hiding ( Fixity ) @@ -68,24 +69,13 @@ data XModulePs = XModulePs { hsmodAnn :: EpAnn AnnsModule, - hsmodLayout :: LayoutInfo GhcPs, + hsmodLayout :: EpLayout, -- ^ Layout info for the module. - -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. - hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), + -- For incomplete modules (e.g. the output of parseHeader), it is EpNoLayout. + hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs), -- ^ reason\/explanation for warning/deprecation of this module - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' - -- ,'GHC.Parser.Annotation.AnnClose' - -- - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs) -- ^ Haddock module info and description, unparsed - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' - -- ,'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation } deriving Data @@ -94,16 +84,21 @@ type instance XCModule GhcTc = DataConCantHappen type instance XXModule p = DataConCantHappen -type instance Anno ModuleName = SrcSpanAnnA - deriving instance Data (HsModule GhcPs) data AnnsModule = AnnsModule { - am_main :: [AddEpAnn], - am_decls :: [TrailingAnn], - am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- End of file and end of prior token + am_sig :: EpToken "signature", + am_mod :: EpToken "module", + am_where :: EpToken "where", + am_decls :: [TrailingAnn], -- ^ Semis before the start of top decls + am_cs :: [LEpaComment], -- ^ Comments before start of top decl, + -- used in exact printing only + am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- ^ End of file and end of prior token } deriving (Data, Eq) + +instance NoAnn AnnsModule where + noAnn = AnnsModule NoEpTok NoEpTok NoEpTok [] [] Nothing instance Outputable (HsModule GhcPs) where ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc } diff --git a/GHC/Hs/Basic.hs b/GHC/Hs/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Basic.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Fixity +module GHC.Hs.Basic + ( module Language.Haskell.Syntax.Basic + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Utils.Binary + +import Data.Data () + +import Language.Haskell.Syntax.Basic + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +instance Outputable Fixity where + ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] + + +instance Binary Fixity where + put_ bh (Fixity aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (Fixity aa ab) + +------------------------ + +instance Binary FixityDirection where + put_ bh InfixL = + putByte bh 0 + put_ bh InfixR = + putByte bh 1 + put_ bh InfixN = + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return InfixL + 1 -> return InfixR + _ -> return InfixN diff --git a/GHC/Hs/Binds.hs b/GHC/Hs/Binds.hs --- a/GHC/Hs/Binds.hs +++ b/GHC/Hs/Binds.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} -- used to pass the phase to ppr_mult_ann since MultAnn is a type family {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -25,16 +26,19 @@ module GHC.Hs.Binds ( module Language.Haskell.Syntax.Binds , module GHC.Hs.Binds + , HsRuleBndrsAnn(..) ) where import GHC.Prelude import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Binds +import Language.Haskell.Syntax.Expr( LHsExpr ) -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind ) +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) +import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal ) import GHC.Types.Tickish import GHC.Hs.Extension import GHC.Parser.Annotation @@ -46,13 +50,11 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var -import GHC.Data.Bag -import GHC.Data.BooleanFormula (LBooleanFormula) -import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc ((<||>)) import Data.Function import Data.List (sortBy) @@ -71,8 +73,8 @@ -- the ...LR datatypes are parameterized by two id types, -- one for the left and one for the right. -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where")) type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen @@ -85,7 +87,7 @@ [(RecFlag, LHsBinds idL)] [LSig GhcRn] -type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey +type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag type instance XXValBindsLR (GhcPass pL) pR = NHsValBindsLR (GhcPass pL) @@ -114,7 +116,7 @@ -- type Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. -type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn] +type instance XPatBind GhcPs (GhcPass pR) = NoExtField type instance XPatBind GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] type instance XPatBind GhcTc (GhcPass pR) = ( Type -- Type of the GRHSs @@ -132,12 +134,34 @@ type instance XXHsBindsLR GhcRn pR = DataConCantHappen type instance XXHsBindsLR GhcTc pR = AbsBinds -type instance XPSB (GhcPass idL) GhcPs = EpAnn [AddEpAnn] +type instance XPSB (GhcPass idL) GhcPs = AnnPSB type instance XPSB (GhcPass idL) GhcRn = NameSet -- Post renaming, FVs. See Note [Bind free vars] type instance XPSB (GhcPass idL) GhcTc = NameSet type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen +data AnnPSB + = AnnPSB { + ap_pattern :: EpToken "pattern", + ap_openc :: Maybe (EpToken "{"), + ap_closec :: Maybe (EpToken "}"), + ap_larrow :: Maybe (EpUniToken "<-" "←"), + ap_equal :: Maybe (EpToken "=") + } deriving Data + +instance NoAnn AnnPSB where + noAnn = AnnPSB noAnn noAnn noAnn noAnn noAnn + +setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc +setTcMultAnn mult (HsLinearAnn _) = HsLinearAnn mult +setTcMultAnn mult (HsExplicitMult _ p) = HsExplicitMult mult p +setTcMultAnn mult (HsUnannotated _) = HsUnannotated mult + +getTcMultAnn :: HsMultAnn GhcTc -> Mult +getTcMultAnn (HsLinearAnn mult) = mult +getTcMultAnn (HsExplicitMult mult _) = mult +getTcMultAnn (HsUnannotated mult) = mult + -- --------------------------------------------------------------------- -- | Typechecked, generalised bindings, used in the output to the type checker. @@ -432,7 +456,7 @@ = getPprDebug $ \case -- Print with sccs showing True -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) - False -> pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + False -> pprDeclList (pprLHsBindsForUser (concat (map snd sccs)) sigs) where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = text "rec" @@ -442,7 +466,7 @@ => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty - | otherwise = pprDeclList (map ppr (bagToList binds)) + | otherwise = pprDeclList (map ppr binds) pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, @@ -460,7 +484,7 @@ decls :: [(SrcSpan, SDoc)] decls = [(locA loc, ppr sig) | L loc sig <- sigs] ++ - [(locA loc, ppr bind) | L loc bind <- bagToList binds] + [(locA loc, ppr bind) | L loc bind <- binds] sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls @@ -488,20 +512,20 @@ isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) -emptyValBindsIn = ValBinds NoAnnSortKey emptyBag [] +emptyValBindsIn = ValBinds NoAnnSortKey [] [] emptyValBindsOut = XValBindsLR (NValBinds [] []) emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -emptyLHsBinds = emptyBag +emptyLHsBinds = [] isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool -isEmptyLHsBinds = isEmptyBag +isEmptyLHsBinds = null ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) - = ValBinds NoAnnSortKey (ds1 `unionBags` ds2) (sigs1 ++ sigs2) + = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) (XValBindsLR (NValBinds ds2 sigs2)) = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) @@ -516,8 +540,9 @@ (OutputableBndrId idL, OutputableBndrId idR) => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) - = pprPatBind pat grhss +ppr_monobind (PatBind { pat_lhs = pat, pat_mult = mult_ann, pat_rhs = grhss }) + = pprHsMultAnn @idL mult_ann + <+> pprPatBind pat grhss ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, @@ -545,10 +570,6 @@ ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (XHsBindsLR b) = case ghcPass @idL of -#if __GLASGOW_HASKELL__ <= 900 - GhcPs -> dataConCantHappen b - GhcRn -> dataConCantHappen b -#endif GhcTc -> ppr_absbinds b where ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars @@ -591,7 +612,7 @@ GhcPs -> ppr v GhcRn -> ppr v GhcTc -> ppr v - PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr_v vs) + PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr_v vs) where ppr_v v = case ghcPass @r of GhcPs -> ppr v @@ -606,9 +627,9 @@ GhcTc -> ppr v ppr_rhs = case dir of - Unidirectional -> ppr_simple (text "<-") + Unidirectional -> ppr_simple larrow ImplicitBidirectional -> ppr_simple equals - ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$ + ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$ (nest 2 $ pprFunBind mg) pprTicks :: SDoc -> SDoc -> SDoc @@ -623,10 +644,9 @@ then pp_when_debug else pp_no_debug -instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where +instance Outputable (XRecGhc (IdGhcP p)) => Outputable (RecordPatSynField (GhcPass p)) where ppr (RecordPatSynField { recordPatSynField = v }) = ppr v - {- ************************************************************************ * * @@ -650,7 +670,7 @@ isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -- EPA annotations in GhcPs, dictionary Id in GhcTc -type instance XCIPBind GhcPs = EpAnn [AddEpAnn] +type instance XCIPBind GhcPs = EpToken "=" type instance XCIPBind GhcRn = NoExtField type instance XCIPBind GhcTc = Id type instance XXIPBind (GhcPass p) = DataConCantHappen @@ -675,24 +695,95 @@ ************************************************************************ -} -type instance XTypeSig (GhcPass p) = EpAnn AnnSig -type instance XPatSynSig (GhcPass p) = EpAnn AnnSig -type instance XClassOpSig (GhcPass p) = EpAnn AnnSig -type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSpecInstSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) -type instance XMinimalSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) -type instance XSCCFunSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) -type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText) - -- SourceText: Note [Pragma source text] in "GHC.Types.SourceText" +type instance XTypeSig (GhcPass p) = AnnSig +type instance XPatSynSig (GhcPass p) = AnnSig +type instance XClassOpSig (GhcPass p) = AnnSig +type instance XFixSig (GhcPass p) = ((EpaLocation, Maybe EpaLocation), SourceText) +type instance XInlineSig (GhcPass p) = (EpaLocation, EpToken "#-}", ActivationAnn) +type instance XSpecSig (GhcPass p) = AnnSpecSig +type instance XSpecInstSig (GhcPass p) = ((EpaLocation, EpToken "instance", EpToken "#-}"), SourceText) +type instance XMinimalSig (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText) +type instance XSCCFunSig (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText) +type instance XCompleteMatchSig (GhcPass p) = ((EpaLocation, Maybe TokDcolon, EpToken "#-}"), SourceText) + +type instance XSpecSigE GhcPs = AnnSpecSig +type instance XSpecSigE GhcRn = Name +type instance XSpecSigE GhcTc = NoExtField + + -- SourceText: See Note [Pragma source text] in "GHC.Types.SourceText" type instance XXSig GhcPs = DataConCantHappen type instance XXSig GhcRn = IdSig type instance XXSig GhcTc = IdSig -type instance XFixitySig (GhcPass p) = NoExtField +type instance XFixitySig GhcPs = NamespaceSpecifier +type instance XFixitySig GhcRn = NamespaceSpecifier +type instance XFixitySig GhcTc = NoExtField type instance XXFixitySig (GhcPass p) = DataConCantHappen +data AnnSpecSig + = AnnSpecSig { + ass_open :: EpaLocation, + ass_close :: EpToken "#-}", + ass_dcolon :: Maybe TokDcolon, -- Only for old SpecSig, remove when it goes + ass_act :: ActivationAnn + } deriving Data + +instance NoAnn AnnSpecSig where + noAnn = AnnSpecSig noAnn noAnn noAnn noAnn + +data ActivationAnn + = ActivationAnn { + aa_openc :: EpToken "[", + aa_closec :: EpToken "]", + aa_tilde :: Maybe (EpToken "~"), + aa_val :: Maybe EpaLocation + } deriving (Data, Eq) + +instance NoAnn ActivationAnn where + noAnn = ActivationAnn noAnn noAnn noAnn noAnn + + +-- | Optional namespace specifier for fixity signatures, +-- WARNINIG and DEPRECATED pragmas. +-- +-- Examples: +-- +-- {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-} +-- -- ↑ DataNamespaceSpecifier +-- +-- {-# DEPRECATED type D "This type was deprecated" #-} +-- -- ↑ TypeNamespaceSpecifier +-- +-- infixr 6 data $ +-- -- ↑ DataNamespaceSpecifier +data NamespaceSpecifier + = NoNamespaceSpecifier + | TypeNamespaceSpecifier (EpToken "type") + | DataNamespaceSpecifier (EpToken "data") + deriving (Eq, Data) + +-- | Check if namespace specifiers overlap, i.e. if they are equal or +-- if at least one of them doesn't specify a namespace +overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool +overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True +overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True +overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True +overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True +overlappingNamespaceSpecifiers _ _ = False + +-- | Check if namespace is covered by a namespace specifier: +-- * NoNamespaceSpecifier covers both namespaces +-- * TypeNamespaceSpecifier covers the type namespace only +-- * DataNamespaceSpecifier covers the data namespace only +coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool +coveredByNamespaceSpecifier NoNamespaceSpecifier = const True +coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace +coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace +instance Outputable NamespaceSpecifier where + ppr NoNamespaceSpecifier = empty + ppr TypeNamespaceSpecifier{} = text "type" + ppr DataNamespaceSpecifier{} = text "data" + -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record the desired Id -- itself, replete with its name, type and IdDetails. Otherwise it's @@ -702,33 +793,58 @@ data AnnSig = AnnSig { - asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option - asRest :: [AddEpAnn] + asDcolon :: EpUniToken "::" "∷", + asPattern :: Maybe (EpToken "pattern"), + asDefault :: Maybe (EpToken "default") } deriving Data +instance NoAnn AnnSig where + noAnn = AnnSig noAnn noAnn noAnn -- | Type checker Specialisation Pragmas -- --- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer +-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker +-- to the desugarer data TcSpecPrags = IsDefaultMethod -- ^ Super-specialised: a default method should -- be macro-expanded at every call site | SpecPrags [LTcSpecPrag] - deriving Data --- | Located Type checker Specification Pragmas +-- | Located Type checker Specialisation Pragmas type LTcSpecPrag = Located TcSpecPrag --- | Type checker Specification Pragma +-- | Type checker Specialisation Pragma +-- +-- This data type is used to communicate between the typechecker and +-- the desugarer. data TcSpecPrag + -- | Old-form specialise pragma = SpecPrag - Id - HsWrapper - InlinePragma - -- ^ The Id to be specialised, a wrapper that specialises the - -- polymorphic function, and inlining spec for the specialised function - deriving Data + Id + -- ^ 'Id' to be specialised + HsWrapper + -- ^ wrapper that specialises the polymorphic function + InlinePragma + -- ^ inlining spec for the specialised function + -- | New-form specialise pragma + | SpecPragE + { spe_fn_nm :: Name + -- ^ 'Name' of the 'Id' being specialised + , spe_fn_id :: Id + -- ^ 'Id' being specialised + -- + -- Note that 'spe_fn_nm' may differ from @'idName' 'spe_fn_id'@ + -- in the case of instance methods, where the 'Name' is the + -- class-op selector but the 'spe_fn_id' is that for the local method + , spe_inl :: InlinePragma + -- ^ (optional) INLINE annotation and activation phase annotation + , spe_bndrs :: [Var] + -- ^ TyVars, EvVars, and Ids + , spe_call :: LHsExpr GhcTc + -- ^ The type-checked specialise expression + } + noSpecPrags :: TcSpecPrags noSpecPrags = SpecPrags [] @@ -750,19 +866,34 @@ | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (FixSig _ fix_sig) = ppr fix_sig -ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) - = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var) - (interpp'SP ty) inl) + +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec })) + = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $ + pprSpec (unLoc var) (interpp'SP ty) inl where pragmaSrc = case spec of - NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl) - _ -> "{-# " ++ extractSpecPragName (inl_src inl) ++ "_INLINE" + NoUserInlinePrag -> "{-# " ++ extractSpecPragName src + _ -> "{-# " ++ extractSpecPragName src ++ "_INLINE" + +ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec })) + = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $ + pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e) + where + -- SPECIALISE or SPECIALISE_INLINE + pragmaSrc = case spec of + NoUserInlinePrag -> "{-# " ++ extractSpecPragName src + _ -> "{-# " ++ extractSpecPragName src ++ "_INLINE" + + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = pprInline inl + ppr_sig (InlineSig _ var inl) = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}" where ppr_pfx = case inlinePragmaSource inl of SourceText src -> ftext src NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl) + ppr_sig (SpecInstSig (_, src) ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) ppr_sig (MinimalSig (_, src) bf) @@ -778,7 +909,7 @@ GhcTc -> ppr fn ppr_sig (CompleteMatchSig (_, src) cs mty) = pragSrcBrackets src "{-# COMPLETE" - ((hsep (punctuate comma (map ppr_n (unLoc cs)))) + ((hsep (punctuate comma (map ppr_n cs))) <+> opt_sig) where opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty @@ -797,6 +928,7 @@ | is_deflt = text "default type signature" | otherwise = text "class method signature" hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" +hsSigDoc (SpecSigE _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" -- Using the 'inlinePragmaName' function ensures that the pragma name for any -- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted @@ -823,8 +955,13 @@ instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where - ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] + ppr (FixitySig ns_spec names fixity) = sep [ppr fixity, ppr_ns_spec, pprops] where + ppr_ns_spec = + case ghcPass @p of + GhcPs -> ppr ns_spec + GhcRn -> ppr ns_spec + GhcTc -> empty pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) pragBrackets :: SDoc -> SDoc @@ -854,11 +991,58 @@ instance Outputable TcSpecPrag where ppr (SpecPrag var _ inl) = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "") inl + ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl }) + = text (extractSpecPragName $ inl_src inl) + <+> hang (ppr bndrs) 2 (pprLExpr spec_e) -pprMinimalSig :: (OutputableBndr name) - => LBooleanFormula (GenLocated l name) -> SDoc -pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) +pprMinimalSig :: OutputableBndrId p => LBooleanFormula (GhcPass p) -> SDoc +pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf + +{- ********************************************************************* +* * + RuleBndrs +* * +********************************************************************* -} + +data HsRuleBndrsAnn + = HsRuleBndrsAnn + { rb_tyanns :: Maybe (TokForall, EpToken ".") + -- ^ The locations of 'forall' and '.' for forall'd type vars + -- Using AddEpAnn to capture possible unicode variants + , rb_tmanns :: Maybe (TokForall, EpToken ".") + -- ^ The locations of 'forall' and '.' for forall'd term vars + -- Using AddEpAnn to capture possible unicode variants + } deriving (Data, Eq) + +instance NoAnn HsRuleBndrsAnn where + noAnn = HsRuleBndrsAnn Nothing Nothing + + + +type instance XXRuleBndrs (GhcPass _) = DataConCantHappen +type instance XCRuleBndrs GhcPs = HsRuleBndrsAnn +type instance XCRuleBndrs GhcRn = NoExtField +type instance XCRuleBndrs GhcTc = [Var] -- Binders of the rule, not + -- necessarily in dependency order + +type instance XRuleBndrSig (GhcPass _) = AnnTyVarBndr +type instance XCRuleBndr (GhcPass _) = AnnTyVarBndr +type instance XXRuleBndr (GhcPass _) = DataConCantHappen + +instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where + ppr (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) + = pp_forall_ty tyvs <+> pp_forall_tm tyvs + where + pp_forall_ty Nothing = empty + pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot + pp_forall_tm Nothing | null tmvs = empty + pp_forall_tm _ = forAllLit <+> fsep (map ppr tmvs) <> dot + +instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where + ppr (RuleBndr _ name) = ppr name + ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) + {- ************************************************************************ * * @@ -870,15 +1054,8 @@ type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA - --- For CompleteMatchSig -type instance Anno [LocatedN RdrName] = SrcSpan -type instance Anno [LocatedN Name] = SrcSpan -type instance Anno [LocatedN Id] = SrcSpan +type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = SrcAnn NoEpAnns -type instance Anno (LocatedN RdrName) = SrcSpan -type instance Anno (LocatedN Name) = SrcSpan -type instance Anno (LocatedN Id) = SrcSpan +type instance Anno StringLiteral = EpAnnCO diff --git a/GHC/Hs/Decls.hs b/GHC/Hs/Decls.hs --- a/GHC/Hs/Decls.hs +++ b/GHC/Hs/Decls.hs @@ -6,10 +6,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable +{-# LANGUAGE InstanceSigs #-} {- (c) The University of Glasgow 2006 @@ -29,6 +31,11 @@ -- ** Class or type declarations TyClDecl(..), LTyClDecl, DataDeclRn(..), + AnnDataDefn(..), + AnnClassDecl(..), + AnnSynDecl(..), + AnnFamilyDecl(..), + AnnClsInstDecl(..), TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupKindSigs, @@ -36,7 +43,7 @@ isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, tyFamInstDeclName, tyFamInstDeclLName, - countTyClDecls, pprTyClDeclFlavour, + countTyClDecls, tyClDeclFlavour, tyClDeclLName, tyClDeclTyVars, hsDeclHasCusk, famResultKindSignature, FamilyDecl(..), LFamilyDecl, @@ -49,11 +56,11 @@ TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS, - FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats, + FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations - DerivDecl(..), LDerivDecl, + DerivDecl(..), LDerivDecl, AnnDerivDecl, -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, derivStrategyName, foldDerivStrategy, mapDerivStrategy, @@ -74,12 +81,14 @@ CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, - HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta, + HsConDeclH98Details, HsConDeclGADTDetails(..), + AnnConDeclH98(..), AnnConDeclGADT(..), + hsConDeclTheta, getConNames, getRecConArgs_maybe, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations - WarnDecl(..), LWarnDecl, + WarnDecl(..), LWarnDecl, WarnDecls(..), LWarnDecls, -- ** Annotations AnnDecl(..), LAnnDecl, @@ -101,6 +110,7 @@ import GHC.Prelude import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Extension import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) -- Because Expr imports Decls via HsBracket @@ -110,7 +120,7 @@ import GHC.Hs.Doc import GHC.Types.Basic import GHC.Core.Coercion -import Language.Haskell.Syntax.Extension + import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Name @@ -125,11 +135,11 @@ import GHC.Types.SourceText import GHC.Core.Type import GHC.Types.ForeignCall -import GHC.Unit.Module.Warnings (WarningTxt(..)) +import GHC.Unit.Module.Warnings -import GHC.Data.Bag import GHC.Data.Maybe import Data.Data (Data) +import Data.List (concatMap) import Data.Foldable (toList) {- @@ -170,12 +180,12 @@ [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) partitionBindsAndSigs = go where - go [] = (emptyBag, [], [], [], [], []) + go [] = ([], [], [], [], [], []) go ((L l decl) : ds) = let (bs, ss, ts, tfis, dfis, docs) = go ds in case decl of ValD _ b - -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs) + -> (L l b : bs, ss, ts, tfis, dfis, docs) SigD _ s -> (bs, L l s : ss, ts, tfis, dfis, docs) TyClD _ (FamDecl _ t) @@ -221,6 +231,20 @@ , L loc (FixSig _ sig) <- sigs ] +hsGroupInstDecls :: HsGroup (GhcPass p) -> [LInstDecl (GhcPass p)] +hsGroupInstDecls = (=<<) group_instds . hs_tyclds + +-- Helpers to flatten TyClGroups. +-- See (TCDEP1) in Note [Dependency analysis of type and class decls] in GHC.Rename.Module +tyClGroupTyClDecls :: [TyClGroup (GhcPass p)] -> [LTyClDecl (GhcPass p)] +tyClGroupInstDecls :: [TyClGroup (GhcPass p)] -> [LInstDecl (GhcPass p)] +tyClGroupRoleDecls :: [TyClGroup (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)] +tyClGroupKindSigs :: [TyClGroup (GhcPass p)] -> [LStandaloneKindSig (GhcPass p)] +tyClGroupTyClDecls = Data.List.concatMap group_tyclds +tyClGroupInstDecls = Data.List.concatMap group_instds +tyClGroupRoleDecls = Data.List.concatMap group_roles +tyClGroupKindSigs = Data.List.concatMap group_kisigs + appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p) appendGroups @@ -336,11 +360,11 @@ type instance XFamDecl (GhcPass _) = NoExtField -type instance XSynDecl GhcPs = EpAnn [AddEpAnn] +type instance XSynDecl GhcPs = AnnSynDecl type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs -type instance XDataDecl GhcPs = EpAnn [AddEpAnn] +type instance XDataDecl GhcPs = NoExtField type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn @@ -350,17 +374,63 @@ , tcdFVs :: NameSet } deriving Data -type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) +type instance XClassDecl GhcPs = + ( AnnClassDecl + , EpLayout -- See Note [Class EpLayout] + , AnnSortKey DeclTag ) -- TODO:AZ:tidy up AnnSortKey - -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs type instance XXTyClDecl (GhcPass _) = DataConCantHappen -type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn] +type instance XCTyFamInstDecl (GhcPass _) = (EpToken "type", EpToken "instance") type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen +data AnnDataDefn + = AnnDataDefn { + andd_openp :: [EpToken "("], + andd_closep :: [EpToken ")"], + andd_type :: EpToken "type", + andd_newtype :: EpToken "newtype", + andd_data :: EpToken "data", + andd_instance :: EpToken "instance", + andd_dcolon :: TokDcolon, + andd_where :: EpToken "where", + andd_openc :: EpToken "{", + andd_closec :: EpToken "}", + andd_equal :: EpToken "=" + } deriving Data + +instance NoAnn AnnDataDefn where + noAnn = AnnDataDefn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +data AnnClassDecl + = AnnClassDecl { + acd_class :: EpToken "class", + acd_openp :: [EpToken "("], + acd_closep :: [EpToken ")"], + acd_vbar :: EpToken "|", + acd_where :: EpToken "where", + acd_openc :: EpToken "{", + acd_closec :: EpToken "}", + acd_semis :: [EpToken ";"] + } deriving Data + +instance NoAnn AnnClassDecl where + noAnn = AnnClassDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +data AnnSynDecl + = AnnSynDecl { + asd_opens :: [EpToken "("], + asd_closes :: [EpToken ")"], + asd_type :: EpToken "type", + asd_equal :: EpToken "=" + } deriving Data + +instance NoAnn AnnSynDecl where + noAnn = AnnSynDecl noAnn noAnn noAnn noAnn + ------------- Pretty printing FamilyDecls ----------- pprFlavour :: FamilyInfo pass -> SDoc @@ -390,6 +460,10 @@ tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln +tyClDeclTyVars :: TyClDecl (GhcPass p) -> LHsQTyVars (GhcPass p) +tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs +tyClDeclTyVars d = tcdTyVars d + countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) -- class, synonym decls, data, newtype, family decls countTyClDecls decls @@ -448,7 +522,7 @@ tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods, tcdATs = ats, tcdATDefs = at_defs}) - | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + | null sigs && null methods && null ats && null at_defs -- No "where" part = top_matter | otherwise -- Laid out @@ -476,7 +550,7 @@ ppr instds pp_vanilla_decl_head :: (OutputableBndrId p) - => XRec (GhcPass p) (IdP (GhcPass p)) + => XRecGhc (IdGhcP p) -> LHsQTyVars (GhcPass p) -> LexicalFixity -> Maybe (LHsContext (GhcPass p)) @@ -497,18 +571,23 @@ , hsep (map (ppr.unLoc) (varl:varsr))] pp_tyvars [] = pprPrefixOcc (unLoc thing) -pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc -pprTyClDeclFlavour (ClassDecl {}) = text "class" -pprTyClDeclFlavour (SynDecl {}) = text "type" -pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) - = pprFlavour info <+> text "family" -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) - = ppr (dataDefnConsNewOrData nd) +tyClDeclFlavour :: TyClDecl (GhcPass p) -> TyConFlavour tc +tyClDeclFlavour (ClassDecl {}) = ClassFlavour +tyClDeclFlavour (SynDecl {}) = TypeSynonymFlavour +tyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = case info of + DataFamily -> OpenFamilyFlavour (IAmData DataType) Nothing + OpenTypeFamily -> OpenFamilyFlavour IAmType Nothing + ClosedTypeFamily {} -> ClosedTypeFamilyFlavour +tyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) + = case dataDefnConsNewOrData nd of + NewType -> NewtypeFlavour + DataType -> DataTypeFlavour instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where ppr = pprFunDep -type instance XCFunDep (GhcPass _) = EpAnn [AddEpAnn] +type instance XCFunDep (GhcPass _) = TokRarrow type instance XXFunDep (GhcPass _) = DataConCantHappen pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc @@ -526,7 +605,14 @@ * * ********************************************************************* -} -type instance XCTyClGroup (GhcPass _) = NoExtField +type instance XCTyClGroup GhcPs = NoExtField + +type instance XCTyClGroup GhcRn = NameSet -- Lexical dependencies of an SCC + -- What names exactly are in this NameSet? See Note [Prepare TyClGroup FVs] in GHC.Rename.Module + -- How is this NameSet used? See Note [Retrying TyClGroups] in GHC.Tc.TyCl + +type instance XCTyClGroup GhcTc = DataConCantHappen + type instance XXTyClGroup (GhcPass _) = DataConCantHappen @@ -542,13 +628,31 @@ type instance XTyVarSig (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen -type instance XCFamilyDecl (GhcPass _) = EpAnn [AddEpAnn] +type instance XCFamilyDecl (GhcPass _) = AnnFamilyDecl type instance XXFamilyDecl (GhcPass _) = DataConCantHappen +data AnnFamilyDecl + = AnnFamilyDecl { + afd_openp :: [EpToken "("], + afd_closep :: [EpToken ")"], + afd_type :: EpToken "type", + afd_data :: EpToken "data", + afd_family :: EpToken "family", + afd_dcolon :: TokDcolon, + afd_equal :: EpToken "=", + afd_vbar :: EpToken "|", + afd_where :: EpToken "where", + afd_openc :: EpToken "{", + afd_dotdot :: EpToken "..", + afd_closec :: EpToken "}" + } deriving Data +instance NoAnn AnnFamilyDecl where + noAnn = AnnFamilyDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn + ------------- Functions over FamilyDecls ----------- -familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p)) +familyDeclLName :: FamilyDecl (GhcPass p) -> XRecGhc (IdGhcP p) familyDeclLName (FamilyDecl { fdLName = n }) = n familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p) @@ -558,18 +662,18 @@ famResultKindSignature (NoSig _) = Nothing famResultKindSignature (KindSig _ ki) = Just ki famResultKindSignature (TyVarSig _ bndr) = - case unLoc bndr of - UserTyVar _ _ _ -> Nothing - KindedTyVar _ _ _ ki -> Just ki + case hsBndrKind (unLoc bndr) of + HsBndrNoKind _ -> Nothing + HsBndrKind _ ki -> Just ki -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) -resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig +resultVariableName (TyVarSig _ sig) = hsLTyVarName sig resultVariableName _ = Nothing ------------- Pretty printing FamilyDecls ----------- -type instance XCInjectivityAnn (GhcPass _) = EpAnn [AddEpAnn] +type instance XCInjectivityAnn (GhcPass _) = TokRarrow type instance XXInjectivityAnn (GhcPass _) = DataConCantHappen instance OutputableBndrId p @@ -595,7 +699,7 @@ TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr pp_inj = case mb_inj of Just (L _ (InjectivityAnn _ lhs rhs)) -> - hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ] Nothing -> empty (pp_where, pp_eqns) = case info of ClosedTypeFamily mb_eqns -> @@ -613,10 +717,10 @@ * * ********************************************************************* -} -type instance XCHsDataDefn (GhcPass _) = NoExtField +type instance XCHsDataDefn (GhcPass _) = AnnDataDefn type instance XXHsDataDefn (GhcPass _) = DataConCantHappen -type instance XCHsDerivingClause (GhcPass _) = EpAnn [AddEpAnn] +type instance XCHsDerivingClause (GhcPass _) = EpToken "deriving" type instance XXHsDerivingClause (GhcPass _) = DataConCantHappen instance OutputableBndrId p @@ -652,7 +756,7 @@ ppr (DctSingle _ ty) = ppr ty ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn] +type instance XStandaloneKindSig GhcPs = (EpToken "type", TokDcolon) type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField @@ -661,11 +765,44 @@ standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn] -type instance XConDeclH98 (GhcPass _) = EpAnn [AddEpAnn] +type instance XConDeclGADT GhcPs = AnnConDeclGADT +type instance XConDeclGADT GhcRn = NoExtField +type instance XConDeclGADT GhcTc = NoExtField +type instance XConDeclH98 GhcPs = AnnConDeclH98 +type instance XConDeclH98 GhcRn = NoExtField +type instance XConDeclH98 GhcTc = NoExtField + type instance XXConDecl (GhcPass _) = DataConCantHappen +type instance XPrefixConGADT (GhcPass _) = NoExtField + +type instance XRecConGADT GhcPs = TokRarrow +type instance XRecConGADT GhcRn = NoExtField +type instance XRecConGADT GhcTc = NoExtField + +type instance XXConDeclGADTDetails (GhcPass _) = DataConCantHappen + +data AnnConDeclH98 + = AnnConDeclH98 { + acdh_forall :: TokForall, + acdh_dot :: EpToken ".", + acdh_darrow :: TokDarrow + } deriving Data + +instance NoAnn AnnConDeclH98 where + noAnn = AnnConDeclH98 noAnn noAnn noAnn + +data AnnConDeclGADT + = AnnConDeclGADT { + acdg_openp :: [EpToken "("], + acdg_closep :: [EpToken ")"], + acdg_dcolon :: TokDcolon + } deriving Data + +instance NoAnn AnnConDeclGADT where + noAnn = AnnConDeclGADT noAnn noAnn noAnn + -- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98 {con_name = name} = [name] @@ -674,14 +811,14 @@ -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. -- Otherwise, return 'Nothing'. -getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn]) +getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LHsConDeclRecField GhcRn]) getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of PrefixCon{} -> Nothing RecCon flds -> Just flds InfixCon{} -> Nothing getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of PrefixConGADT{} -> Nothing - RecConGADT flds _ -> Just flds + RecConGADT _ flds -> Just flds hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing = [] @@ -731,7 +868,7 @@ instance OutputableBndrId p => Outputable (StandaloneKindSig (GhcPass p)) where ppr (StandaloneKindSig _ v ki) - = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki + = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs @@ -755,27 +892,31 @@ where -- In ppr_details: let's not print the multiplicities (they are always 1, by -- definition) as they do not appear in an actual declaration. - ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1), + ppr_details (InfixCon t1 t2) = hsep [pprHsConDeclFieldNoMult t1, pprInfixOcc con, - ppr (hsScaledThing t2)] - ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con - : map (pprHsType . unLoc . hsScaledThing) tys) + pprHsConDeclFieldNoMult t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con + : map pprHsConDeclFieldNoMult tys) ppr_details (RecCon fields) = pprPrefixOcc con - <+> pprConDeclFields (unLoc fields) + <+> pprHsConDeclRecFields (unLoc fields) -pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs +pprConDecl (ConDeclGADT { con_names = cons + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon - <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt, + <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs + <+> hsep (map pprHsForAllTelescope inner_bndrs) + <+> pprLHsContext mcxt, sep (ppr_args args ++ [ppr res_ty]) ]) where - ppr_args (PrefixConGADT args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args - ppr_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields) <+> arrow] + ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> ppr_arr arr)) args + ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow] -- Display linear arrows as unrestricted with -XNoLinearTypes -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon) - ppr_arr (HsLinearArrow _) = sdocOption sdocLinearTypes $ \show_linear_types -> + ppr_arr (HsLinearAnn _) = sdocOption sdocLinearTypes $ \show_linear_types -> if show_linear_types then lollipop else arrow ppr_arr arr = pprHsArrow arr @@ -790,15 +931,22 @@ ************************************************************************ -} -type instance XCFamEqn (GhcPass _) r = EpAnn [AddEpAnn] +type instance XCFamEqn (GhcPass _) r = ([EpToken "("], [EpToken ")"], EpToken "=") type instance XXFamEqn (GhcPass _) r = DataConCantHappen -type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA - ----------------- Class instances ------------- -type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up -type instance XCClsInstDecl GhcRn = NoExtField +type instance XCClsInstDecl GhcPs = ( Maybe (LWarningTxt GhcPs) + -- The warning of the deprecated instance + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + , AnnClsInstDecl + , AnnSortKey DeclTag) -- For sorting the additional annotations + -- TODO:AZ:tidy up +type instance XCClsInstDecl GhcRn = Maybe (LWarningTxt GhcRn) + -- The warning of the deprecated instance + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict type instance XCClsInstDecl GhcTc = NoExtField type instance XXClsInstDecl (GhcPass _) = DataConCantHappen @@ -815,6 +963,31 @@ type instance XXInstDecl (GhcPass _) = DataConCantHappen +data AnnClsInstDecl + = AnnClsInstDecl { + acid_instance :: EpToken "instance", + acid_where :: EpToken "where", + acid_openc :: EpToken "{", + acid_semis :: [EpToken ";"], + acid_closec :: EpToken "}" + } deriving Data + +instance NoAnn AnnClsInstDecl where + noAnn = AnnClsInstDecl noAnn noAnn noAnn noAnn noAnn + +cidDeprecation :: forall p. IsPass p + => ClsInstDecl (GhcPass p) + -> Maybe (WarningTxt (GhcPass p)) +cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) + where + decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) + -> Maybe (LocatedP (WarningTxt (GhcPass p))) + decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } ) + = depr + decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr }) + = depr + decl_deprecation _ _ = Nothing + instance OutputableBndrId p => Outputable (TyFamInstDecl (GhcPass p)) where ppr = pprTyFamInstDecl TopLevel @@ -867,7 +1040,7 @@ pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) -> HsOuterFamEqnTyVarBndrs (GhcPass p) - -> HsTyPats (GhcPass p) + -> HsFamEqnPats (GhcPass p) -> LexicalFixity -> Maybe (LHsContext (GhcPass p)) -> SDoc @@ -878,11 +1051,11 @@ instance OutputableBndrId p => Outputable (ClsInstDecl (GhcPass p)) where - ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds - , cid_sigs = sigs, cid_tyfam_insts = ats - , cid_overlap_mode = mbOverlap - , cid_datafam_insts = adts }) - | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part + ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + | null sigs, null ats, null adts, null binds -- No "where" part = top_matter | otherwise -- Laid out @@ -892,8 +1065,9 @@ map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ pprLHsBindsForUser binds sigs ] where - top_matter = text "instance" <+> ppOverlapPragma mbOverlap - <+> ppr inst_ty + top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid) + <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty ppDerivStrategy :: OutputableBndrId p => Maybe (LDerivStrategy (GhcPass p)) -> SDoc @@ -939,10 +1113,6 @@ newOrDataToFlavour NewType = NewtypeFlavour newOrDataToFlavour DataType = DataTypeFlavour -instance Outputable NewOrData where - ppr NewType = text "newtype" - ppr DataType = text "data" - -- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@. anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool anyLConIsGadt xs = case toList xs of @@ -959,19 +1129,43 @@ ************************************************************************ -} -type instance XCDerivDecl (GhcPass _) = EpAnn [AddEpAnn] +type instance XCDerivDecl GhcPs = ( Maybe (LWarningTxt GhcPs) + -- The warning of the deprecated derivation + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + , AnnDerivDecl ) +type instance XCDerivDecl GhcRn = ( Maybe (LWarningTxt GhcRn) + -- The warning of the deprecated derivation + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict + , AnnDerivDecl ) +type instance XCDerivDecl GhcTc = AnnDerivDecl type instance XXDerivDecl (GhcPass _) = DataConCantHappen -type instance Anno OverlapMode = SrcSpanAnnP +type AnnDerivDecl = (EpToken "deriving", EpToken "instance") +derivDeprecation :: forall p. IsPass p + => DerivDecl (GhcPass p) + -> Maybe (WarningTxt (GhcPass p)) +derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) + where + decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) + -> Maybe (LocatedP (WarningTxt (GhcPass p))) + decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) + = depr + decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) + = depr + decl_deprecation _ _ = Nothing + instance OutputableBndrId p => Outputable (DerivDecl (GhcPass p)) where - ppr (DerivDecl { deriv_type = ty + ppr (deriv@DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) = hsep [ text "deriving" , ppDerivStrategy ds , text "instance" + , maybe empty ppr (derivDeprecation deriv) , ppOverlapPragma o , ppr ty ] @@ -983,15 +1177,15 @@ ************************************************************************ -} -type instance XStockStrategy GhcPs = EpAnn [AddEpAnn] +type instance XStockStrategy GhcPs = EpToken "stock" type instance XStockStrategy GhcRn = NoExtField type instance XStockStrategy GhcTc = NoExtField -type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn] +type instance XAnyClassStrategy GhcPs = EpToken "anyclass" type instance XAnyClassStrategy GhcRn = NoExtField type instance XAnyClassStrategy GhcTc = NoExtField -type instance XNewtypeStrategy GhcPs = EpAnn [AddEpAnn] +type instance XNewtypeStrategy GhcPs = EpToken "newtype" type instance XNewtypeStrategy GhcRn = NoExtField type instance XNewtypeStrategy GhcTc = NoExtField @@ -999,7 +1193,7 @@ type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs) +data XViaStrategyPs = XViaStrategyPs (EpToken "via") (LHsSigType GhcPs) instance OutputableBndrId p => Outputable (DerivStrategy (GhcPass p)) where @@ -1038,7 +1232,7 @@ ************************************************************************ -} -type instance XCDefaultDecl GhcPs = EpAnn [AddEpAnn] +type instance XCDefaultDecl GhcPs = (EpToken "default", EpToken "(", EpToken ")") type instance XCDefaultDecl GhcRn = NoExtField type instance XCDefaultDecl GhcTc = NoExtField @@ -1046,8 +1240,8 @@ instance OutputableBndrId p => Outputable (DefaultDecl (GhcPass p)) where - ppr (DefaultDecl _ tys) - = text "default" <+> parens (interpp'SP tys) + ppr (DefaultDecl _ cl tys) + = text "default" <+> maybe id ((<+>) . ppr) cl (parens (interpp'SP tys)) {- ************************************************************************ @@ -1057,22 +1251,23 @@ ************************************************************************ -} -type instance XForeignImport GhcPs = EpAnn [AddEpAnn] +type instance XForeignImport GhcPs = (EpToken "foreign", EpToken "import", TokDcolon) type instance XForeignImport GhcRn = NoExtField type instance XForeignImport GhcTc = Coercion -type instance XForeignExport GhcPs = EpAnn [AddEpAnn] +type instance XForeignExport GhcPs = (EpToken "foreign", EpToken "export", TokDcolon) type instance XForeignExport GhcRn = NoExtField type instance XForeignExport GhcTc = Coercion type instance XXForeignDecl (GhcPass _) = DataConCantHappen -type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity +type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity type instance XXForeignImport (GhcPass _) = DataConCantHappen -type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity +type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity type instance XXForeignExport (GhcPass _) = DataConCantHappen + -- pretty printing of foreign declarations instance OutputableBndrId p @@ -1126,39 +1321,35 @@ ************************************************************************ -} -type instance XCRuleDecls GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XCRuleDecls GhcPs = ((EpaLocation, EpToken "#-}"), SourceText) type instance XCRuleDecls GhcRn = SourceText type instance XCRuleDecls GhcTc = SourceText type instance XXRuleDecls (GhcPass _) = DataConCantHappen -type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText) +type instance XHsRule GhcPs = ((ActivationAnn, EpToken "="), SourceText) type instance XHsRule GhcRn = (HsRuleRn, SourceText) type instance XHsRule GhcTc = (HsRuleRn, SourceText) data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS deriving Data -type instance XXRuleDecl (GhcPass _) = DataConCantHappen - data HsRuleAnn = HsRuleAnn - { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn) - -- ^ The locations of 'forall' and '.' for forall'd type vars - -- Using AddEpAnn to capture possible unicode variants - , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn) - -- ^ The locations of 'forall' and '.' for forall'd term vars - -- Using AddEpAnn to capture possible unicode variants - , ra_rest :: [AddEpAnn] + { ra_tyanns :: Maybe (TokForall, EpToken ".") + , ra_tmanns :: Maybe (TokForall, EpToken ".") + , ra_equal :: EpToken "=" + , ra_rest :: ActivationAnn } deriving (Data, Eq) +instance NoAnn HsRuleAnn where + noAnn = HsRuleAnn Nothing Nothing noAnn noAnn + +type instance XXRuleDecl (GhcPass _) = DataConCantHappen + flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -type instance XCRuleBndr (GhcPass _) = EpAnn [AddEpAnn] -type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn] -type instance XXRuleBndr (GhcPass _) = DataConCantHappen - instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where ppr (HsRules { rds_ext = ext , rds_rules = rules }) @@ -1173,28 +1364,18 @@ ppr (HsRule { rd_ext = ext , rd_name = name , rd_act = act - , rd_tyvs = tys - , rd_tmvs = tms + , rd_bndrs = bndrs , rd_lhs = lhs , rd_rhs = rhs }) = sep [pprFullRuleName st name <+> ppr act, - nest 4 (pp_forall_ty tys <+> pp_forall_tm tys - <+> pprExpr (unLoc lhs)), + nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] where - pp_forall_ty Nothing = empty - pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot - pp_forall_tm Nothing | null tms = empty - pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot st = case ghcPass @p of GhcPs | (_, st) <- ext -> st GhcRn | (_, st) <- ext -> st GhcTc | (_, st) <- ext -> st -instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where - ppr (RuleBndr _ name) = ppr name - ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) - pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n) @@ -1207,13 +1388,13 @@ ************************************************************************ -} -type instance XWarnings GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XWarnings GhcPs = ((EpaLocation, EpToken "#-}"), SourceText) type instance XWarnings GhcRn = SourceText type instance XWarnings GhcTc = SourceText type instance XXWarnDecls (GhcPass _) = DataConCantHappen -type instance XWarning (GhcPass _) = EpAnn [AddEpAnn] +type instance XWarning (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]")) type instance XXWarnDecl (GhcPass _) = DataConCantHappen @@ -1229,8 +1410,9 @@ instance OutputableBndrId p => Outputable (WarnDecl (GhcPass p)) where - ppr (Warning _ thing txt) + ppr (Warning (ns_spec, _) thing txt) = ppr_category + <+> ppr ns_spec <+> hsep (punctuate comma (map ppr thing)) <+> ppr txt where @@ -1246,7 +1428,7 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText) +type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where @@ -1268,14 +1450,12 @@ ************************************************************************ -} -type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn] +type instance XCRoleAnnotDecl GhcPs = (EpToken "type", EpToken "role") type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen -type instance Anno (Maybe Role) = SrcAnn NoEpAnns - instance OutputableBndr (IdP (GhcPass p)) => Outputable (RoleAnnotDecl (GhcPass p)) where ppr (RoleAnnotDecl _ ltycon roles) @@ -1300,16 +1480,16 @@ type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA -type instance Anno (FamilyResultSig (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO type instance Anno CType = SrcSpanAnnP -type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno Bool = SrcAnn NoEpAnns -type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL +type instance Anno Bool = EpAnnCO +type instance Anno [LocatedA (HsConDeclRecField (GhcPass _))] = SrcSpanAnnL type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA @@ -1319,18 +1499,17 @@ type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP -type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns -type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (SourceText, RuleName) = EpAnnCO type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (Maybe Role) = SrcAnn NoEpAnns -type instance Anno CCallConv = SrcSpan -type instance Anno Safety = SrcSpan -type instance Anno CExportSpec = SrcSpan +type instance Anno (Maybe Role) = EpAnnCO +type instance Anno CCallConv = EpaLocation +type instance Anno Safety = EpaLocation +type instance Anno CExportSpec = EpaLocation diff --git a/GHC/Hs/Doc.hs b/GHC/Hs/Doc.hs --- a/GHC/Hs/Doc.hs +++ b/GHC/Hs/Doc.hs @@ -124,7 +124,7 @@ = DsiSectionHeading !Int !(HsDoc GhcRn) | DsiDocChunk !(HsDoc GhcRn) | DsiNamedChunkRef !String - | DsiExports !Avails + | DsiExports !DetOrdAvails | DsiModExport !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple -- modules with a single export declaration. E.g. @@ -133,7 +133,12 @@ -- > module M (module X) where -- > import R0 as X -- > import R1 as X - !Avails + -- + -- Invariant: This list of ModuleNames must be + -- sorted to guarantee interface file determinism. + !DetOrdAvails + -- ^ Invariant: This list of Avails must be sorted + -- to guarantee interface file determinism. instance Binary DocStructureItem where put_ bh = \case @@ -196,6 +201,8 @@ data Docs = Docs { docs_mod_hdr :: Maybe (HsDoc GhcRn) -- ^ Module header. + , docs_exports :: UniqMap Name (HsDoc GhcRn) + -- ^ Docs attached to module exports. , docs_decls :: UniqMap Name [HsDoc GhcRn] -- ^ Docs for declarations: functions, data types, instances, methods etc. -- A list because sometimes subsequent haddock comments can be combined into one @@ -216,14 +223,15 @@ } instance NFData Docs where - rnf (Docs mod_hdr decls args structure named_chunks haddock_opts language extentions) - = rnf mod_hdr `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks + rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions) + = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions `seq` () instance Binary Docs where put_ bh docs = do put_ bh (docs_mod_hdr docs) + put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_exports docs) put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs) put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs) put_ bh (docs_structure docs) @@ -233,6 +241,7 @@ put_ bh (docs_extensions docs) get bh = do mod_hdr <- get bh + exports <- listToUniqMap <$> get bh decls <- listToUniqMap <$> get bh args <- listToUniqMap <$> get bh structure <- get bh @@ -241,7 +250,8 @@ language <- get bh exts <- get bh pure Docs { docs_mod_hdr = mod_hdr - , docs_decls = decls + , docs_exports = exports + , docs_decls = decls , docs_args = args , docs_structure = structure , docs_named_chunks = named_chunks @@ -254,6 +264,7 @@ ppr docs = vcat [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr + , pprField (ppr . fmap pprHsDocDebug) "export docs" docs_exports , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args , pprField (vcat . map ppr) "documentation structure" docs_structure @@ -283,6 +294,7 @@ emptyDocs :: Docs emptyDocs = Docs { docs_mod_hdr = Nothing + , docs_exports = emptyUniqMap , docs_decls = emptyUniqMap , docs_args = emptyUniqMap , docs_structure = [] diff --git a/GHC/Hs/Doc.hs-boot b/GHC/Hs/Doc.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Hs/Doc.hs-boot @@ -0,0 +1,19 @@ +{-# LANGUAGE RoleAnnotations #-} +module GHC.Hs.Doc where + +-- See #21592 for progress on removing this boot file. + +import GHC.Types.SrcLoc +import GHC.Hs.DocString +import Data.Kind + +type role WithHsDocIdentifiers representational nominal +type WithHsDocIdentifiers :: Type -> Type -> Type +data WithHsDocIdentifiers a pass + +type HsDoc :: Type -> Type +type HsDoc = WithHsDocIdentifiers HsDocString + +type LHsDoc :: Type -> Type +type LHsDoc pass = Located (HsDoc pass) + diff --git a/GHC/Hs/DocString.hs b/GHC/Hs/DocString.hs --- a/GHC/Hs/DocString.hs +++ b/GHC/Hs/DocString.hs @@ -21,6 +21,7 @@ , renderHsDocStrings , exactPrintHsDocString , pprWithDocString + , printDecorator ) where import GHC.Prelude diff --git a/GHC/Hs/Dump.hs b/GHC/Hs/Dump.hs --- a/GHC/Hs/Dump.hs +++ b/GHC/Hs/Dump.hs @@ -4,7 +4,12 @@ -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-specialise #-} + -- Don't do type-class specialisation; it goes mad in this module + -- See #25463 + -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb -- traversal which falls back to displaying based on the constructor name, so -- can be used to dump anything having a @Data.Data@ instance. @@ -34,6 +39,7 @@ import Data.Data hiding (Fixity) import qualified Data.ByteString as B +import GHC.TypeLits -- | Should source spans be removed from output. data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan @@ -57,28 +63,39 @@ showAstData' = generic `ext1Q` list + `extQ` list_epaLocation + `extQ` list_epTokenOpenP + `extQ` list_epTokenCloseP `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan - `extQ` annotation `extQ` annotationModule - `extQ` annotationAddEpAnn `extQ` annotationGrhsAnn - `extQ` annotationEpAnnHsCase `extQ` annotationAnnList + `extQ` annotationAnnListWhere + `extQ` annotationAnnListCommas + `extQ` annotationAnnListIE `extQ` annotationEpAnnImportDecl - `extQ` annotationAnnParen - `extQ` annotationTrailingAnn - `extQ` annotationEpaLocation `extQ` annotationNoEpAnns - `extQ` addEpAnn + `extQ` annotationExprBracket + `extQ` annotationTypedBracket + `extQ` epTokenOC + `extQ` epTokenCC + `extQ` epTokenInstance + `extQ` epTokenForall + `extQ` annParen + `extQ` annClassDecl + `extQ` annSynDecl + `extQ` annDataDefn + `extQ` annFamilyDecl + `extQ` annClsInstDecl `extQ` lit `extQ` litr `extQ` litt `extQ` sourceText `extQ` deltaPos - `extQ` epaAnchor + `extQ` epaLocation + `extQ` maybe_epaLocation `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity `ext2Q` located `extQ` srcSpanAnnA `extQ` srcSpanAnnL @@ -101,6 +118,24 @@ bytestring :: B.ByteString -> SDoc bytestring = text . normalize_newlines . show + list_epaLocation :: [EpaLocation] -> SDoc + list_epaLocation ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[EpaLocation]" + NoBlankEpAnnotations -> list ls + + list_epTokenOpenP :: [EpToken "("] -> SDoc + list_epTokenOpenP ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[EpToken \"(\"]" + NoBlankEpAnnotations -> list ls + + list_epTokenCloseP :: [EpToken ")"] -> SDoc + list_epTokenCloseP ls = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "[EpToken \"(\"]" + NoBlankEpAnnotations -> list ls + list [] = brackets empty list [x] = brackets (showAstData' x) list (x1 : x2 : xs) = (text "[" <> showAstData' x1) @@ -137,18 +172,26 @@ , generic s ] sourceText :: SourceText -> SDoc - sourceText NoSourceText = parens $ text "NoSourceText" + sourceText NoSourceText = case bs of + BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked" + _ -> parens $ text "NoSourceText" sourceText (SourceText src) = case bs of - NoBlankSrcSpan -> parens $ text "SourceText" <+> ftext src - BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src - _ -> parens $ text "SourceText" <+> text "blanked" + BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked" + _ -> parens $ text "SourceText" <+> ftext src - epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r - epaAnchor (EpaDelta d cs) = case ba of - NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs - BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" + epaLocation :: EpaLocation -> SDoc + epaLocation (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s + epaLocation (EpaDelta s d cs) = case ba of + NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstData' cs + BlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> text "blanked" + maybe_epaLocation :: Maybe EpaLocation -> SDoc + maybe_epaLocation ml = case ba of + NoBlankEpAnnotations -> case ml of + Nothing -> parens $ text "Nothing" + Just l -> parens (text "Just" $$ showAstData' l) + BlankEpAnnotations -> parens $ text "Maybe EpaLocation:" <+> text "blanked" + deltaPos :: DeltaPos -> SDoc deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c @@ -166,35 +209,123 @@ srcSpan :: SrcSpan -> SDoc srcSpan ss = case bs of BlankSrcSpan -> text "{ ss }" - NoBlankSrcSpan -> braces $ char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - BlankSrcSpanFile -> braces $ char ' ' <> - (hang (pprUserSpan False ss) 1 - -- TODO: show annotations here - (text "")) + NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' ' + BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' ' realSrcSpan :: RealSrcSpan -> SDoc realSrcSpan ss = case bs of BlankSrcSpan -> text "{ ss }" - NoBlankSrcSpan -> braces $ char ' ' <> - (hang (ppr ss) 1 - -- TODO: show annotations here - (text "")) - BlankSrcSpanFile -> braces $ char ' ' <> - (hang (pprUserRealSpan False ss) 1 - -- TODO: show annotations here - (text "")) + NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' ' + BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' ' + annParen :: AnnParen -> SDoc + annParen ap = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen" + NoBlankEpAnnotations -> parens (case ap of + (AnnParens o c) -> text "AnnParens" $$ vcat [showAstData' o, showAstData' c] + (AnnParensHash o c) -> text "AnnParensHash" $$ vcat [showAstData' o, showAstData' c] + (AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c] + ) - addEpAnn :: AddEpAnn -> SDoc - addEpAnn (AddEpAnn a s) = case ba of + annClassDecl :: AnnClassDecl -> SDoc + annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnClassDecl" + NoBlankEpAnnotations -> + parens $ text "AnnClassDecl" + $$ vcat [showAstData' c, showAstData' ops, showAstData' cps, + showAstData' v, showAstData' w, showAstData' oc, + showAstData' cc, showAstData' s] + + annSynDecl :: AnnSynDecl -> SDoc + annSynDecl (AnnSynDecl ops cps t e) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnSynDecl" + NoBlankEpAnnotations -> + parens $ text "AnnSynDecl" + $$ vcat [showAstData' ops, showAstData' cps, + showAstData' t, showAstData' e] + + annDataDefn :: AnnDataDefn -> SDoc + annDataDefn (AnnDataDefn a b c d e f g h i j k) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnDataDefn" + NoBlankEpAnnotations -> + parens $ text "AnnDataDefn" + $$ vcat [showAstData' a, showAstData' b, showAstData' c, + showAstData' d, showAstData' e, showAstData' f, + showAstData' g, showAstData' h, showAstData' i, + showAstData' j, showAstData' k] + + annFamilyDecl :: AnnFamilyDecl -> SDoc + annFamilyDecl (AnnFamilyDecl a b c d e f g h i j k l) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl" + NoBlankEpAnnotations -> + parens $ text "AnnFamilyDecl" + $$ vcat [showAstData' a, showAstData' b, showAstData' c, + showAstData' d, showAstData' e, showAstData' f, + showAstData' g, showAstData' h, showAstData' i, + showAstData' j, showAstData' k, showAstData' l] + + annClsInstDecl :: AnnClsInstDecl -> SDoc + annClsInstDecl (AnnClsInstDecl a b c d e) = case ba of + BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl" + NoBlankEpAnnotations -> + parens $ text "AnnClsInstDecl" + $$ vcat [showAstData' a, showAstData' b, showAstData' c, + showAstData' d, showAstData' e] + + + annotationExprBracket :: BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|") -> SDoc + annotationExprBracket = annotationBracket + + annotationTypedBracket :: BracketAnn (EpToken "[||") (EpToken "[e||") -> SDoc + annotationTypedBracket = annotationBracket + + annotationBracket ::forall n h .(Data n, Data h, Typeable n, Typeable h) + => BracketAnn n h -> SDoc + annotationBracket a = case ba of BlankEpAnnotations -> parens - $ text "blanked:" <+> text "AddEpAnn" + $ text "blanked:" <+> text "BracketAnn" NoBlankEpAnnotations -> - parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s + parens $ case a of + BracketNoE t -> text "BracketNoE" <+> showAstData' t + BracketHasE t -> text "BracketHasE" <+> showAstData' t + epTokenOC :: EpToken "{" -> SDoc + epTokenOC = epToken' + + epTokenCC :: EpToken "}" -> SDoc + epTokenCC = epToken' + + epTokenInstance :: EpToken "instance" -> SDoc + epTokenInstance = epToken' + + epTokenForall :: TokForall -> SDoc + epTokenForall = epUniToken' + + epToken' :: KnownSymbol sym => EpToken sym -> SDoc + epToken' (EpTok s) = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpToken" + NoBlankEpAnnotations -> + parens $ text "EpTok" <+> epaLocation s + epToken' NoEpTok = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpToken" + NoBlankEpAnnotations -> + parens $ text "NoEpTok" + + epUniToken' :: EpUniToken sym1 sym2 -> SDoc + epUniToken' (EpUniTok s f) = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpUniToken" + NoBlankEpAnnotations -> + parens $ text "EpUniTok" <+> epaLocation s <+> ppr f + epUniToken' NoEpUniTok = case ba of + BlankEpAnnotations -> parens + $ text "blanked:" <+> text "EpUniToken" + NoBlankEpAnnotations -> + parens $ text "NoEpUniTok" + + var :: Var -> SDoc var v = braces $ text "Var:" <+> ppr v @@ -220,11 +351,6 @@ text "NameSet:" $$ (list . nameSetElemsStable $ ns) - fixity :: Fixity -> SDoc - fixity fx = braces $ - text "Fixity:" - <+> ppr fx - located :: (Data a, Data b) => GenLocated a b -> SDoc located (L ss a) = parens (text "L" @@ -233,35 +359,26 @@ -- ------------------------- - annotation :: EpAnn [AddEpAnn] -> SDoc - annotation = annotation' (text "EpAnn [AddEpAnn]") - annotationModule :: EpAnn AnnsModule -> SDoc annotationModule = annotation' (text "EpAnn AnnsModule") - annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc - annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") - annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") - annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc - annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") - - annotationAnnList :: EpAnn AnnList -> SDoc - annotationAnnList = annotation' (text "EpAnn AnnList") + annotationAnnList :: EpAnn (AnnList ()) -> SDoc + annotationAnnList = annotation' (text "EpAnn (AnnList ())") - annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc - annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") + annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc + annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))") - annotationAnnParen :: EpAnn AnnParen -> SDoc - annotationAnnParen = annotation' (text "EpAnn AnnParen") + annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc + annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") - annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc - annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") + annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc + annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))") - annotationEpaLocation :: EpAnn EpaLocation -> SDoc - annotationEpaLocation = annotation' (text "EpAnn EpaLocation") + annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc + annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns") @@ -275,32 +392,32 @@ -- ------------------------- - srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc + srcSpanAnnA :: EpAnn AnnListItem -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc + srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") - srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc + srcSpanAnnP :: EpAnn AnnPragma -> SDoc srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc + srcSpanAnnC :: EpAnn AnnContext -> SDoc srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") - srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc + srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") locatedAnn'' :: forall a. (Typeable a, Data a) - => SDoc -> SrcSpanAnn' a -> SDoc + => SDoc -> EpAnn a -> SDoc locatedAnn'' tag ss = parens $ case cast ss of - Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) -> + Just (ann :: EpAnn a) -> case ba of BlankEpAnnotations -> parens (text "blanked:" <+> tag) NoBlankEpAnnotations - -> text "SrcSpanAnn" <+> showAstData' ann - <+> srcSpan s + -> text (showConstr (toConstr ann)) + $$ vcat (gmapQ showAstData' ann) Nothing -> text "locatedAnn:unmatched" <+> tag <+> (parens $ text (showConstr (toConstr ss))) diff --git a/GHC/Hs/Expr.hs b/GHC/Hs/Expr.hs --- a/GHC/Hs/Expr.hs +++ b/GHC/Hs/Expr.hs @@ -32,2182 +32,2691 @@ -- friends: import GHC.Prelude -import GHC.Hs.Decls() -- import instances -import GHC.Hs.Pat -import GHC.Hs.Lit -import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import GHC.Hs.Extension -import GHC.Hs.Type -import GHC.Hs.Binds -import GHC.Parser.Annotation - --- others: -import GHC.Tc.Types.Evidence -import GHC.Types.Id.Info ( RecSelParent ) -import GHC.Types.Name -import GHC.Types.Name.Reader -import GHC.Types.Name.Set -import GHC.Types.Basic -import GHC.Types.Fixity -import GHC.Types.SourceText -import GHC.Types.SrcLoc -import GHC.Types.Tickish (CoreTickish) -import GHC.Types.Unique.Set (UniqSet) -import GHC.Core.ConLike ( conLikeName, ConLike ) -import GHC.Unit.Module (ModuleName) -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.FastString -import GHC.Core.Type -import GHC.Builtin.Types (mkTupleStr) -import GHC.Tc.Utils.TcType (TcType, TcTyVar) -import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) - --- libraries: -import Data.Data hiding (Fixity(..)) -import qualified Data.Data as Data (Fixity(..)) -import qualified Data.Kind -import Data.Maybe (isJust) -import Data.Foldable ( toList ) -import Data.List (uncons) -import Data.List.NonEmpty (NonEmpty) -import Data.Bifunctor (first) - -{- ********************************************************************* -* * - Expressions proper -* * -********************************************************************* -} - --- | Post-Type checking Expression --- --- PostTcExpr is an evidence expression attached to the syntax tree by the --- type checker (c.f. postTcType). -type PostTcExpr = HsExpr GhcTc - --- | Post-Type checking Table --- --- We use a PostTcTable where there are a bunch of pieces of evidence, more --- than is convenient to keep individually. -type PostTcTable = [(Name, PostTcExpr)] - -------------------------- - --- Defining SyntaxExpr in two stages allows for better type inference, because --- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity, --- noSyntaxExpr would be ambiguous. -type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p - -type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where - SyntaxExprGhc 'Parsed = NoExtField - SyntaxExprGhc 'Renamed = SyntaxExprRn - SyntaxExprGhc 'Typechecked = SyntaxExprTc - --- | The function to use in rebindable syntax. See Note [NoSyntaxExpr]. -data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn) - -- Why is the payload not just a Name? - -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" - | NoSyntaxExprRn - --- | An expression with wrappers, used for rebindable syntax --- --- This should desugar to --- --- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) --- > (syn_arg_wraps[1] arg1) ... --- --- where the actual arguments come from elsewhere in the AST. -data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc - , syn_arg_wraps :: [HsWrapper] - , syn_res_wrap :: HsWrapper } - | NoSyntaxExprTc -- See Note [NoSyntaxExpr] - --- | This is used for rebindable-syntax pieces that are too polymorphic --- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) -noExpr :: HsExpr (GhcPass p) -noExpr = HsLit noComments (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr")) - -noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) - -- Before renaming, and sometimes after - -- See Note [NoSyntaxExpr] -noSyntaxExpr = case ghcPass @p of - GhcPs -> noExtField - GhcRn -> NoSyntaxExprRn - GhcTc -> NoSyntaxExprTc - --- | Make a 'SyntaxExpr GhcRn' from an expression --- Used only in getMonadFailOp. --- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" -mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn -mkSyntaxExpr = SyntaxExprRn - --- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the --- renamer). -mkRnSyntaxExpr :: Name -> SyntaxExprRn -mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name - -instance Outputable SyntaxExprRn where - ppr (SyntaxExprRn expr) = ppr expr - ppr NoSyntaxExprRn = text "" - -instance Outputable SyntaxExprTc where - ppr (SyntaxExprTc { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = sdocOption sdocPrintExplicitCoercions $ \print_co -> - getPprDebug $ \debug -> - if debug || print_co - then ppr expr <> braces (pprWithCommas ppr arg_wraps) - <> braces (ppr res_wrap) - else ppr expr - - ppr NoSyntaxExprTc = text "" - --- | HsWrap appears only in typechecker output -data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper - (hs_syn GhcTc) -- the thing that is wrapped - -deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) - --- --------------------------------------------------------------------- - -data HsBracketTc = HsBracketTc - { hsb_quote :: HsQuote GhcRn -- See Note [The life cycle of a TH quotation] - , hsb_ty :: Type - , hsb_wrap :: Maybe QuoteWrapper -- The wrapper to apply type and dictionary argument to the quote. - , hsb_splices :: [PendingTcSplice] -- Output of the type checker is the *original* - -- renamed expression, plus - -- _typechecked_ splices to be - -- pasted back in by the desugarer - } - -type instance XTypedBracket GhcPs = EpAnn [AddEpAnn] -type instance XTypedBracket GhcRn = NoExtField -type instance XTypedBracket GhcTc = HsBracketTc -type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn] -type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices] - -- Output of the renamer is the *original* renamed expression, - -- plus _renamed_ splices to be type checked -type instance XUntypedBracket GhcTc = HsBracketTc - --- --------------------------------------------------------------------- - --- API Annotations types - -data EpAnnHsCase = EpAnnHsCase - { hsCaseAnnCase :: EpaLocation - , hsCaseAnnOf :: EpaLocation - , hsCaseAnnsRest :: [AddEpAnn] - } deriving Data - -data EpAnnUnboundVar = EpAnnUnboundVar - { hsUnboundBackquotes :: (EpaLocation, EpaLocation) - , hsUnboundHole :: EpaLocation - } deriving Data - -type instance XVar (GhcPass _) = NoExtField - --- Record selectors at parse time are HsVar; they convert to HsRecSel --- on renaming. -type instance XRecSel GhcPs = DataConCantHappen -type instance XRecSel GhcRn = NoExtField -type instance XRecSel GhcTc = NoExtField - -type instance XLam (GhcPass _) = NoExtField - --- OverLabel not present in GhcTc pass; see GHC.Rename.Expr --- Note [Handling overloaded and rebindable constructs] -type instance XOverLabel GhcPs = EpAnnCO -type instance XOverLabel GhcRn = EpAnnCO -type instance XOverLabel GhcTc = DataConCantHappen - --- --------------------------------------------------------------------- - -type instance XVar (GhcPass _) = NoExtField - -type instance XUnboundVar GhcPs = EpAnn EpAnnUnboundVar -type instance XUnboundVar GhcRn = NoExtField -type instance XUnboundVar GhcTc = HoleExprRef - -- We really don't need the whole HoleExprRef; just the IORef EvTerm - -- would be enough. But then deriving a Data instance becomes impossible. - -- Much, much easier just to define HoleExprRef with a Data instance and - -- store the whole structure. - -type instance XIPVar GhcPs = EpAnnCO -type instance XIPVar GhcRn = EpAnnCO -type instance XIPVar GhcTc = DataConCantHappen -type instance XOverLitE (GhcPass _) = EpAnnCO -type instance XLitE (GhcPass _) = EpAnnCO - -type instance XLam (GhcPass _) = NoExtField - -type instance XLamCase (GhcPass _) = EpAnn [AddEpAnn] - -type instance XApp (GhcPass _) = EpAnnCO - -type instance XAppTypeE GhcPs = NoExtField -type instance XAppTypeE GhcRn = NoExtField -type instance XAppTypeE GhcTc = Type - --- OpApp not present in GhcTc pass; see GHC.Rename.Expr --- Note [Handling overloaded and rebindable constructs] -type instance XOpApp GhcPs = EpAnn [AddEpAnn] -type instance XOpApp GhcRn = Fixity -type instance XOpApp GhcTc = DataConCantHappen - --- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr --- Note [Handling overloaded and rebindable constructs] -type instance XSectionL GhcPs = EpAnnCO -type instance XSectionR GhcPs = EpAnnCO -type instance XSectionL GhcRn = EpAnnCO -type instance XSectionR GhcRn = EpAnnCO -type instance XSectionL GhcTc = DataConCantHappen -type instance XSectionR GhcTc = DataConCantHappen - - -type instance XNegApp GhcPs = EpAnn [AddEpAnn] -type instance XNegApp GhcRn = NoExtField -type instance XNegApp GhcTc = NoExtField - -type instance XPar (GhcPass _) = EpAnnCO - -type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] -type instance XExplicitTuple GhcRn = NoExtField -type instance XExplicitTuple GhcTc = NoExtField - -type instance XExplicitSum GhcPs = EpAnn AnnExplicitSum -type instance XExplicitSum GhcRn = NoExtField -type instance XExplicitSum GhcTc = [Type] - -type instance XCase GhcPs = EpAnn EpAnnHsCase -type instance XCase GhcRn = HsMatchContext GhcTc -type instance XCase GhcTc = HsMatchContext GhcTc - -type instance XIf GhcPs = EpAnn AnnsIf -type instance XIf GhcRn = NoExtField -type instance XIf GhcTc = NoExtField - -type instance XMultiIf GhcPs = EpAnn [AddEpAnn] -type instance XMultiIf GhcRn = NoExtField -type instance XMultiIf GhcTc = Type - -type instance XLet GhcPs = EpAnnCO -type instance XLet GhcRn = NoExtField -type instance XLet GhcTc = NoExtField - -type instance XDo GhcPs = EpAnn AnnList -type instance XDo GhcRn = NoExtField -type instance XDo GhcTc = Type - -type instance XExplicitList GhcPs = EpAnn AnnList -type instance XExplicitList GhcRn = NoExtField -type instance XExplicitList GhcTc = Type --- GhcPs: ExplicitList includes all source-level --- list literals, including overloaded ones --- GhcRn and GhcTc: ExplicitList used only for list literals --- that denote Haskell's built-in lists. Overloaded lists --- have been expanded away in the renamer --- See Note [Handling overloaded and rebindable constructs] --- in GHC.Rename.Expr - -type instance XRecordCon GhcPs = EpAnn [AddEpAnn] -type instance XRecordCon GhcRn = NoExtField -type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function - -type instance XRecordUpd GhcPs = EpAnn [AddEpAnn] -type instance XRecordUpd GhcRn = NoExtField -type instance XRecordUpd GhcTc = DataConCantHappen - -- We desugar record updates in the typechecker. - -- See [Handling overloaded and rebindable constructs], - -- and [Record Updates] in GHC.Tc.Gen.Expr. - --- | Information about the parent of a record update: --- --- - the parent type constructor or pattern synonym, --- - the relevant con-likes, --- - the field labels. -data family HsRecUpdParent x - -data instance HsRecUpdParent GhcPs -data instance HsRecUpdParent GhcRn - = RnRecUpdParent - { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt - , rnRecUpdCons :: UniqSet ConLikeName } -data instance HsRecUpdParent GhcTc - = TcRecUpdParent - { tcRecUpdParent :: RecSelParent - , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt - , tcRecUpdCons :: UniqSet ConLike } - -type instance XLHsRecUpdLabels GhcPs = NoExtField -type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn) - -- Possible parents for the record update. -type instance XLHsRecUpdLabels GhcTc = DataConCantHappen - -type instance XLHsOLRecUpdLabels p = NoExtField - -type instance XGetField GhcPs = EpAnnCO -type instance XGetField GhcRn = NoExtField -type instance XGetField GhcTc = DataConCantHappen --- HsGetField is eliminated by the renamer. See [Handling overloaded --- and rebindable constructs]. - -type instance XProjection GhcPs = EpAnn AnnProjection -type instance XProjection GhcRn = NoExtField -type instance XProjection GhcTc = DataConCantHappen --- HsProjection is eliminated by the renamer. See [Handling overloaded --- and rebindable constructs]. - -type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn] -type instance XExprWithTySig GhcRn = NoExtField -type instance XExprWithTySig GhcTc = NoExtField - -type instance XArithSeq GhcPs = EpAnn [AddEpAnn] -type instance XArithSeq GhcRn = NoExtField -type instance XArithSeq GhcTc = PostTcExpr - -type instance XProc (GhcPass _) = EpAnn [AddEpAnn] - -type instance XStatic GhcPs = EpAnn [AddEpAnn] -type instance XStatic GhcRn = NameSet -type instance XStatic GhcTc = (NameSet, Type) - -- Free variables and type of expression, this is stored for convenience as wiring in - -- StaticPtr is a bit tricky (see #20150) - -type instance XPragE (GhcPass _) = NoExtField - -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL -type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA - -data AnnExplicitSum - = AnnExplicitSum { - aesOpen :: EpaLocation, - aesBarsBefore :: [EpaLocation], - aesBarsAfter :: [EpaLocation], - aesClose :: EpaLocation - } deriving Data - -data AnnFieldLabel - = AnnFieldLabel { - afDot :: Maybe EpaLocation - } deriving Data - -data AnnProjection - = AnnProjection { - apOpen :: EpaLocation, -- ^ '(' - apClose :: EpaLocation -- ^ ')' - } deriving Data - -data AnnsIf - = AnnsIf { - aiIf :: EpaLocation, - aiThen :: EpaLocation, - aiElse :: EpaLocation, - aiThenSemi :: Maybe EpaLocation, - aiElseSemi :: Maybe EpaLocation - } deriving Data - --- --------------------------------------------------------------------- - -type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) -type instance XXPragE (GhcPass _) = DataConCantHappen - -type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel -type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen - -type instance XPresent (GhcPass _) = EpAnn [AddEpAnn] - -type instance XMissing GhcPs = EpAnn EpaLocation -type instance XMissing GhcRn = NoExtField -type instance XMissing GhcTc = Scaled Type - -type instance XXTupArg (GhcPass _) = DataConCantHappen - -tupArgPresent :: HsTupArg (GhcPass p) -> Bool -tupArgPresent (Present {}) = True -tupArgPresent (Missing {}) = False - - -{- ********************************************************************* -* * - XXExpr: the extension constructor of HsExpr -* * -********************************************************************* -} - -type instance XXExpr GhcPs = DataConCantHappen -type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -type instance XXExpr GhcTc = XXExprGhcTc --- HsExpansion: see Note [Rebindable syntax and HsExpansion] below - - -data XXExprGhcTc - = WrapExpr -- Type and evidence application and abstractions - {-# UNPACK #-} !(HsWrap HsExpr) - - | ExpansionExpr -- See Note [Rebindable syntax and HsExpansion] below - {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc)) - - | ConLikeTc -- Result of typechecking a data-con - -- See Note [Typechecking data constructors] in - -- GHC.Tc.Gen.Head - -- The two arguments describe how to eta-expand - -- the data constructor when desugaring - ConLike [TcTyVar] [Scaled TcType] - - --------------------------------------- - -- Haskell program coverage (Hpc) Support - - | HsTick - CoreTickish - (LHsExpr GhcTc) -- sub-expression - - | HsBinTick - Int -- module-local tick number for True - Int -- module-local tick number for False - (LHsExpr GhcTc) -- sub-expression - - -{- ********************************************************************* -* * - Pretty-printing expressions -* * -********************************************************************* -} - -instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where - ppr expr = pprExpr expr - ------------------------ --- pprExpr, pprLExpr, pprBinds call pprDeeper; --- the underscore versions do not -pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc -pprLExpr (L _ e) = pprExpr e - -pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e - | otherwise = pprDeeper (ppr_expr e) - -isQuietHsExpr :: HsExpr id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsExpr (HsPar {}) = True --- applications don't display anything themselves -isQuietHsExpr (HsApp {}) = True -isQuietHsExpr (HsAppType {}) = True -isQuietHsExpr (OpApp {}) = True -isQuietHsExpr _ = False - -pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) - => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc -pprBinds b = pprDeeper (ppr b) - ------------------------ -ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc -ppr_lexpr e = ppr_expr (unLoc e) - -ppr_expr :: forall p. (OutputableBndrId p) - => HsExpr (GhcPass p) -> SDoc -ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v -ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv -ppr_expr (HsRecSel _ f) = pprPrefixOcc f -ppr_expr (HsIPVar _ v) = ppr v -ppr_expr (HsOverLabel _ s l) = char '#' <> case s of - NoSourceText -> ppr l - SourceText src -> ftext src -ppr_expr (HsLit _ lit) = ppr lit -ppr_expr (HsOverLit _ lit) = ppr lit -ppr_expr (HsPar _ _ e _) = parens (ppr_lexpr e) - -ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] - -ppr_expr e@(HsApp {}) = ppr_apps e [] -ppr_expr e@(HsAppType {}) = ppr_apps e [] - -ppr_expr (OpApp _ e1 op e2) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - - where - pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens - pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear - - pp_prefixly - = hang (ppr op) 2 (sep [pp_e1, pp_e2]) - - pp_infixly pp_op - = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) - -ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e - -ppr_expr (SectionL _ expr op) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - where - pp_expr = pprDebugParendExpr opPrec expr - - pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) - 4 (hsep [pp_expr, text "x_ )"]) - - pp_infixly v = (sep [pp_expr, v]) - -ppr_expr (SectionR _ op expr) - | Just pp_op <- ppr_infix_expr (unLoc op) - = pp_infixly pp_op - | otherwise - = pp_prefixly - where - pp_expr = pprDebugParendExpr opPrec expr - - pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) - 4 (pp_expr <> rparen) - - pp_infixly v = sep [v, pp_expr] - -ppr_expr (ExplicitTuple _ exprs boxity) - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `MkSolo x`, not `(x)` - | [Present _ expr] <- exprs - , Boxed <- boxity - = hsep [text (mkTupleStr Boxed dataName 1), ppr expr] - | otherwise - = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs)) - where - ppr_tup_args [] = [] - ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es - ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es - - punc (Present {} : _) = comma <> space - punc (Missing {} : _) = comma - punc (XTupArg {} : _) = comma <> space - punc [] = empty - -ppr_expr (ExplicitSum _ alt arity expr) - = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" - where - ppr_bars n = hsep (replicate n (char '|')) - -ppr_expr (HsLam _ matches) - = pprMatches matches - -ppr_expr (HsLamCase _ lc_variant matches) - = sep [ sep [lamCaseKeyword lc_variant], - nest 2 (pprMatches matches) ] - -ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts })) - = sep [ sep [text "case", nest 4 (ppr expr), text "of"], - pp_alts ] - where - pp_alts | null alts = text "{}" - | otherwise = nest 2 (pprMatches matches) - -ppr_expr (HsIf _ e1 e2 e3) - = sep [hsep [text "if", nest 2 (ppr e1), text "then"], - nest 4 (ppr e2), - text "else", - nest 4 (ppr e3)] - -ppr_expr (HsMultiIf _ alts) - = hang (text "if") 3 (vcat (map ppr_alt alts)) - where ppr_alt (L _ (GRHS _ guards expr)) = - hang vbar 2 (ppr_one one_alt) - where - ppr_one [] = panic "ppr_exp HsMultiIf" - ppr_one (h:t) = hang h 2 (sep t) - one_alt = [ interpp'SP guards - , text "->" <+> pprDeeper (ppr expr) ] - ppr_alt (L _ (XGRHS x)) = ppr x - --- special case: let ... in let ... -ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), - ppr_lexpr expr] - -ppr_expr (HsLet _ _ binds _ expr) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr expr)] - -ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts - -ppr_expr (ExplicitList _ exprs) - = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) - -ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) - = hang pp_con 2 (ppr rbinds) - where - -- con :: ConLikeP (GhcPass p) - -- so we need case analysis to know to print it - pp_con = case ghcPass @p of - GhcPs -> ppr con - GhcRn -> ppr con - GhcTc -> ppr con - -ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) - = case flds of - RegularRecUpdFields { recUpdFields= rbinds } -> - hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) - OverloadedRecUpdFields { olRecUpdFields = pbinds } -> - hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) - -ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) - = ppr fexp <> dot <> ppr field - -ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds)))) - -ppr_expr (ExprWithTySig _ expr sig) - = hang (nest 2 (ppr_lexpr expr) <+> dcolon) - 4 (ppr sig) - -ppr_expr (ArithSeq _ _ info) = brackets (ppr info) - -ppr_expr (HsTypedSplice ext e) = - case ghcPass @p of - GhcPs -> pprTypedSplice Nothing e - GhcRn -> pprTypedSplice (Just ext) e - GhcTc -> pprTypedSplice Nothing e -ppr_expr (HsUntypedSplice ext s) = - case ghcPass @p of - GhcPs -> pprUntypedSplice True Nothing s - GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s - GhcRn | HsUntypedSpliceTop _ e <- ext -> ppr e - GhcTc -> dataConCantHappen ext - -ppr_expr (HsTypedBracket b e) - = case ghcPass @p of - GhcPs -> thTyBrackets (ppr e) - GhcRn -> thTyBrackets (ppr e) - GhcTc | HsBracketTc _ _ty _wrap ps <- b -> - thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps -ppr_expr (HsUntypedBracket b q) - = case ghcPass @p of - GhcPs -> ppr q - GhcRn -> case b of - [] -> ppr q - ps -> ppr q $$ text "pending(rn)" <+> ppr ps - GhcTc | HsBracketTc rnq _ty _wrap ps <- b -> - ppr rnq `ppr_with_pending_tc_splices` ps - -ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) - = hsep [text "proc", ppr pat, text "->", ppr cmd] - -ppr_expr (HsStatic _ e) - = hsep [text "static", ppr e] - -ppr_expr (XExpr x) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> ppr x -#endif - GhcRn -> ppr x - GhcTc -> ppr x - -instance Outputable XXExprGhcTc where - ppr (WrapExpr (HsWrap co_fn e)) - = pprHsWrapper co_fn (\_parens -> pprExpr e) - - ppr (ExpansionExpr e) - = ppr e -- e is an HsExpansion, we print the original - -- expression (LHsExpr GhcPs), not the - -- desugared one (LHsExpr GhcTc). - - ppr (ConLikeTc con _ _) = pprPrefixOcc con - -- Used in error messages generated by - -- the pattern match overlap checker - - ppr (HsTick tickish exp) = - pprTicks (ppr exp) $ - ppr tickish <+> ppr_lexpr exp - - ppr (HsBinTick tickIdTrue tickIdFalse exp) = - pprTicks (ppr exp) $ - hcat [text "bintick<", - ppr tickIdTrue, - text ",", - ppr tickIdFalse, - text ">(", - ppr exp, text ")"] - -ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc -ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) -ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f) -ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) -ppr_infix_expr (XExpr x) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 901 - GhcPs -> Nothing -#endif - GhcRn -> ppr_infix_expr_rn x - GhcTc -> ppr_infix_expr_tc x -ppr_infix_expr _ = Nothing - -ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc -ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a - -ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc -ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e -ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a -ppr_infix_expr_tc (ConLikeTc {}) = Nothing -ppr_infix_expr_tc (HsTick {}) = Nothing -ppr_infix_expr_tc (HsBinTick {}) = Nothing - -ppr_apps :: (OutputableBndrId p) - => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] - -> SDoc -ppr_apps (HsApp _ (L _ fun) arg) args - = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) _ arg) args - = ppr_apps fun (Right arg : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) - where - pp (Left arg) = ppr arg - -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - -- = char '@' <> pprHsType arg - pp (Right arg) - = text "@" <> ppr arg - - -pprDebugParendExpr :: (OutputableBndrId p) - => PprPrec -> LHsExpr (GhcPass p) -> SDoc -pprDebugParendExpr p expr - = getPprDebug $ \case - True -> pprParendLExpr p expr - False -> pprLExpr expr - -pprParendLExpr :: (OutputableBndrId p) - => PprPrec -> LHsExpr (GhcPass p) -> SDoc -pprParendLExpr p (L _ e) = pprParendExpr p e - -pprParendExpr :: (OutputableBndrId p) - => PprPrec -> HsExpr (GhcPass p) -> SDoc -pprParendExpr p expr - | hsExprNeedsParens p expr = parens (pprExpr expr) - | otherwise = pprExpr expr - -- Using pprLExpr makes sure that we go 'deeper' - -- I think that is usually (always?) right - --- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs --- parentheses under precedence @p@. -hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool -hsExprNeedsParens prec = go - where - go :: HsExpr (GhcPass p) -> Bool - go (HsVar{}) = False - go (HsUnboundVar{}) = False - go (HsIPVar{}) = False - go (HsOverLabel{}) = False - go (HsLit _ l) = hsLitNeedsParens prec l - go (HsOverLit _ ol) = hsOverLitNeedsParens prec ol - go (HsPar{}) = False - go (HsApp{}) = prec >= appPrec - go (HsAppType {}) = prec >= appPrec - go (OpApp{}) = prec >= opPrec - go (NegApp{}) = prec > topPrec - go (SectionL{}) = True - go (SectionR{}) = True - -- Special-case unary boxed tuple applications so that they are - -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) - -- See Note [One-tuples] in GHC.Builtin.Types - go (ExplicitTuple _ [Present{}] Boxed) - = prec >= appPrec - go (ExplicitTuple{}) = False - go (ExplicitSum{}) = False - go (HsLam{}) = prec > topPrec - go (HsLamCase{}) = prec > topPrec - go (HsCase{}) = prec > topPrec - go (HsIf{}) = prec > topPrec - go (HsMultiIf{}) = prec > topPrec - go (HsLet{}) = prec > topPrec - go (HsDo _ sc _) - | isDoComprehensionContext sc = False - | otherwise = prec > topPrec - go (ExplicitList{}) = False - go (RecordUpd{}) = False - go (ExprWithTySig{}) = prec >= sigPrec - go (ArithSeq{}) = False - go (HsPragE{}) = prec >= appPrec - go (HsTypedSplice{}) = False - go (HsUntypedSplice{}) = False - go (HsTypedBracket{}) = False - go (HsUntypedBracket{}) = False - go (HsProc{}) = prec > topPrec - go (HsStatic{}) = prec >= appPrec - go (RecordCon{}) = False - go (HsRecSel{}) = False - go (HsProjection{}) = True - go (HsGetField{}) = False - go (XExpr x) = case ghcPass @p of - GhcTc -> go_x_tc x - GhcRn -> go_x_rn x -#if __GLASGOW_HASKELL__ <= 900 - GhcPs -> True -#endif - - go_x_tc :: XXExprGhcTc -> Bool - go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e - go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a - go_x_tc (ConLikeTc {}) = False - go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e - go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e - - go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool - go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a - - --- | Parenthesize an expression without token information -gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -gHsPar e = HsPar noAnn noHsTok e noHsTok - --- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, --- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. -parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -parenthesizeHsExpr p le@(L loc e) - | hsExprNeedsParens p e = L loc (gHsPar le) - | otherwise = le - -stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e -stripParensLHsExpr e = e - -stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p) -stripParensHsExpr (HsPar _ _ (L _ e) _) = stripParensHsExpr e -stripParensHsExpr e = e - -isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool --- True of a single token -isAtomicHsExpr (HsVar {}) = True -isAtomicHsExpr (HsLit {}) = True -isAtomicHsExpr (HsOverLit {}) = True -isAtomicHsExpr (HsIPVar {}) = True -isAtomicHsExpr (HsOverLabel {}) = True -isAtomicHsExpr (HsUnboundVar {}) = True -isAtomicHsExpr (HsRecSel{}) = True -isAtomicHsExpr (XExpr x) - | GhcTc <- ghcPass @p = go_x_tc x - | GhcRn <- ghcPass @p = go_x_rn x - where - go_x_tc :: XXExprGhcTc -> Bool - go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e - go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a - go_x_tc (ConLikeTc {}) = True - go_x_tc (HsTick {}) = False - go_x_tc (HsBinTick {}) = False - - go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool - go_x_rn (HsExpanded a _) = isAtomicHsExpr a - -isAtomicHsExpr _ = False - -instance Outputable (HsPragE (GhcPass p)) where - ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) = - pprWithSourceText st (text "{-# SCC") - -- no doublequotes if stl empty, for the case where the SCC was written - -- without quotes. - <+> pprWithSourceText stl (ftext lbl) <+> text "#-}" - - -{- ********************************************************************* -* * - HsExpansion and rebindable syntax -* * -********************************************************************* -} - -{- Note [Rebindable syntax and HsExpansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We implement rebindable syntax (RS) support by performing a desugaring -in the renamer. We transform GhcPs expressions and patterns affected by -RS into the appropriate desugared form, but **annotated with the original -expression/pattern**. - -Let us consider a piece of code like: - - {-# LANGUAGE RebindableSyntax #-} - ifThenElse :: Char -> () -> () -> () - ifThenElse _ _ _ = () - x = if 'a' then () else True - -The parsed AST for the RHS of x would look something like (slightly simplified): - - L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True)) - -Upon seeing such an AST with RS on, we could transform it into a -mere function call, as per the RS rules, equivalent to the -following function application: - - ifThenElse 'a' () True - -which doesn't typecheck. But GHC would report an error about -not being able to match the third argument's type (Bool) with the -expected type: (), in the expression _as desugared_, i.e in -the aforementioned function application. But the user never -wrote a function application! This would be pretty bad. - -To remedy this, instead of transforming the original HsIf -node into mere applications of 'ifThenElse', we keep the -original 'if' expression around too, using the TTG -XExpr extension point to allow GHC to construct an -'HsExpansion' value that will keep track of the original -expression in its first field, and the desugared one in the -second field. The resulting renamed AST would look like: - - L locif (XExpr - (HsExpanded - (HsIf (L loca 'a') - (L loctrue ()) - (L locfalse True) - ) - (App (L generatedSrcSpan - (App (L generatedSrcSpan - (App (L generatedSrcSpan (Var ifThenElse)) - (L loca 'a') - ) - ) - (L loctrue ()) - ) - ) - (L locfalse True) - ) - ) - ) - -When comes the time to typecheck the program, we end up calling -tcMonoExpr on the AST above. If this expression gives rise to -a type error, then it will appear in a context line and GHC -will pretty-print it using the 'Outputable (HsExpansion a b)' -instance defined below, which *only prints the original -expression*. This is the gist of the idea, but is not quite -enough to recover the error messages that we had with the -SyntaxExpr-based, typechecking/desugaring-to-core time -implementation of rebindable syntax. The key idea is to decorate -some elements of the desugared expression so as to be able to -give them a special treatment when typechecking the desugared -expression, to print a different context line or skip one -altogether. - -Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in -TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we -entered generated code, i.e code fabricated by the compiler when rebinding some -syntax. If someone tries to push some error context line while that field is set -to True, the pushing won't actually happen and the context line is just dropped. -Once we 'setSrcSpan' a real span (for an expression that was in the original -source code), we set 'tcl_in_gen_code' back to False, indicating that we -"emerged from the generated code tunnel", and that the expressions we will be -processing are relevant to report in context lines again. - -You might wonder why TcLclEnv has both - tcl_loc :: RealSrcSpan - tcl_in_gen_code :: Bool -Could we not store a Maybe RealSrcSpan? The problem is that we still -generate constraints when processing generated code, and a CtLoc must -contain a RealSrcSpan -- otherwise, error messages might appear -without source locations. So tcl_loc keeps the RealSrcSpan of the last -location spotted that wasn't generated; it's as good as we're going to -get in generated code. Once we get to sub-trees that are not -generated, then we update the RealSrcSpan appropriately, and set the -tcl_in_gen_code Bool to False. - ---- - -An overview of the constructs that are desugared in this way is laid out in -Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr. - -A general recipe to follow this approach for new constructs could go as follows: - -- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your - construct, in HsExpr or related syntax data types. -- At renaming-time: - - take your original node of interest (HsIf above) - - rename its subexpressions/subpatterns (condition and true/false - branches above) - - construct the suitable "rebound"-and-renamed result (ifThenElse call - above), where the 'SrcSpan' attached to any _fabricated node_ (the - HsVar/HsApp nodes, above) is set to 'generatedSrcSpan' - - take both the original node and that rebound-and-renamed result and wrap - them into an expansion construct: - for expressions, XExpr (HsExpanded ) - for patterns, XPat (HsPatExpanded ) - - At typechecking-time: - - remove any logic that was previously dealing with your rebindable - construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends. - - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we - typecheck the desugared expression while reporting the original one in - errors --} - -{- Note [Overview of record dot syntax] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is the note that explains all the moving parts for record dot -syntax. - -The language extensions @OverloadedRecordDot@ and -@OverloadedRecordUpdate@ (providing "record dot syntax") are -implemented using the techniques of Note [Rebindable syntax and -HsExpansion]. - -When OverloadedRecordDot is enabled: -- Field selection expressions - - e.g. foo.bar.baz - - Have abstract syntax HsGetField - - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions -- Field selector expressions e.g. (.x.y) - - Have abstract syntax HsProjection - - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions - -When OverloadedRecordUpdate is enabled: -- Record update expressions - - e.g. a{foo.bar=1, quux="corge", baz} - - Have abstract syntax RecordUpd - - With rupd_flds containting a Right - - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr) - - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions - - Note that this is true for all record updates even for those that do not involve '.' - -When OverloadedRecordDot is enabled and RebindableSyntax is not -enabled the name 'getField' is resolved to GHC.Records.getField. When -OverloadedRecordDot is enabled and RebindableSyntax is enabled the -name 'getField' is whatever in-scope name that is. - -When OverloadedRecordUpd is enabled and RebindableSyntax is not -enabled it is an error for now (temporary while we wait on native -setField support; see -https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When -OverloadedRecordUpd is enabled and RebindableSyntax is enabled the -names 'getField' and 'setField' are whatever in-scope names they are. --} - --- See Note [Rebindable syntax and HsExpansion] just above. -data HsExpansion orig expanded - = HsExpanded orig expanded - deriving Data - --- | Just print the original expression (the @a@). -instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where - ppr (HsExpanded orig expanded) - = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)]) - (ppr orig) - - -{- -************************************************************************ -* * -\subsection{Commands (in arrow abstractions)} -* * -************************************************************************ --} - -type instance XCmdArrApp GhcPs = EpAnn AddEpAnn -type instance XCmdArrApp GhcRn = NoExtField -type instance XCmdArrApp GhcTc = Type - -type instance XCmdArrForm GhcPs = EpAnn AnnList -type instance XCmdArrForm GhcRn = NoExtField -type instance XCmdArrForm GhcTc = NoExtField - -type instance XCmdApp (GhcPass _) = EpAnnCO -type instance XCmdLam (GhcPass _) = NoExtField -type instance XCmdPar (GhcPass _) = EpAnnCO - -type instance XCmdCase GhcPs = EpAnn EpAnnHsCase -type instance XCmdCase GhcRn = NoExtField -type instance XCmdCase GhcTc = NoExtField - -type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn] - -type instance XCmdIf GhcPs = EpAnn AnnsIf -type instance XCmdIf GhcRn = NoExtField -type instance XCmdIf GhcTc = NoExtField - -type instance XCmdLet GhcPs = EpAnnCO -type instance XCmdLet GhcRn = NoExtField -type instance XCmdLet GhcTc = NoExtField - -type instance XCmdDo GhcPs = EpAnn AnnList -type instance XCmdDo GhcRn = NoExtField -type instance XCmdDo GhcTc = Type - -type instance XCmdWrap (GhcPass _) = NoExtField - -type instance XXCmd GhcPs = DataConCantHappen -type instance XXCmd GhcRn = DataConCantHappen -type instance XXCmd GhcTc = HsWrap HsCmd - -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] - = SrcSpanAnnL - - -- If cmd :: arg1 --> res - -- wrap :: arg1 "->" arg2 - -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res - --- | Command Syntax Table (for Arrow syntax) -type CmdSyntaxTable p = [(Name, HsExpr p)] --- See Note [CmdSyntaxTable] - -{- -Note [CmdSyntaxTable] -~~~~~~~~~~~~~~~~~~~~~ -Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps -track of the methods needed for a Cmd. - -* Before the renamer, this list is an empty list - -* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ - For example, for the 'arr' method - * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) - * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) - where @arr_22@ is whatever 'arr' is in scope - -* After the type checker, it takes the form [(std_name, )] - where is the evidence for the method. This evidence is - instantiated with the class, but is still polymorphic in everything - else. For example, in the case of 'arr', the evidence has type - forall b c. (b->c) -> a b c - where 'a' is the ambient type of the arrow. This polymorphism is - important because the desugarer uses the same evidence at multiple - different types. - -This is Less Cool than what we normally do for rebindable syntax, which is to -make fully-instantiated piece of evidence at every use site. The Cmd way -is Less Cool because - * The renamer has to predict which methods are needed. - See the tedious GHC.Rename.Expr.methodNamesCmd. - - * The desugarer has to know the polymorphic type of the instantiated - method. This is checked by Inst.tcSyntaxName, but is less flexible - than the rest of rebindable syntax, where the type is less - pre-ordained. (And this flexibility is useful; for example we can - typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) --} - -data CmdTopTc - = CmdTopTc Type -- Nested tuple of inputs on the command's stack - Type -- return type of the command - (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] - -type instance XCmdTop GhcPs = NoExtField -type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] -type instance XCmdTop GhcTc = CmdTopTc - - -type instance XXCmdTop (GhcPass _) = DataConCantHappen - -instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where - ppr cmd = pprCmd cmd - ------------------------ --- pprCmd and pprLCmd call pprDeeper; --- the underscore versions do not -pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc -pprLCmd (L _ c) = pprCmd c - -pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc -pprCmd c | isQuietHsCmd c = ppr_cmd c - | otherwise = pprDeeper (ppr_cmd c) - -isQuietHsCmd :: HsCmd id -> Bool --- Parentheses do display something, but it gives little info and --- if we go deeper when we go inside them then we get ugly things --- like (...) -isQuietHsCmd (HsCmdPar {}) = True --- applications don't display anything themselves -isQuietHsCmd (HsCmdApp {}) = True -isQuietHsCmd _ = False - ------------------------ -ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc -ppr_lcmd c = ppr_cmd (unLoc c) - -ppr_cmd :: forall p. (OutputableBndrId p - ) => HsCmd (GhcPass p) -> SDoc -ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c) - -ppr_cmd (HsCmdApp _ c e) - = let (fun, args) = collect_args c [e] in - hang (ppr_lcmd fun) 2 (sep (map ppr args)) - where - collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) - -ppr_cmd (HsCmdLam _ matches) - = pprMatches matches - -ppr_cmd (HsCmdCase _ expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), text "of"], - nest 2 (pprMatches matches) ] - -ppr_cmd (HsCmdLamCase _ lc_variant matches) - = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ] - -ppr_cmd (HsCmdIf _ _ e ct ce) - = sep [hsep [text "if", nest 2 (ppr e), text "then"], - nest 4 (ppr ct), - text "else", - nest 4 (ppr ce)] - --- special case: let ... in let ... -ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {}))) - = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), - ppr_lcmd cmd] - -ppr_cmd (HsCmdLet _ _ binds _ cmd) - = sep [hang (text "let") 2 (pprBinds binds), - hang (text "in") 2 (ppr cmd)] - -ppr_cmd (HsCmdDo _ (L _ stmts)) = pprArrowExpr stmts - -ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) - = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) - = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) - = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] -ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) - = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] - -ppr_cmd (HsCmdArrForm _ (L _ op) ps_fix rn_fix args) - | HsVar _ (L _ v) <- op - = ppr_cmd_infix v - | GhcTc <- ghcPass @p - , XExpr (ConLikeTc c _ _) <- op - = ppr_cmd_infix (conLikeName c) - | otherwise - = fall_through - where - fall_through = hang (text "(|" <+> ppr_expr op) - 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") - - ppr_cmd_infix :: OutputableBndr v => v -> SDoc - ppr_cmd_infix v - | [arg1, arg2] <- args - , isJust rn_fix || ps_fix == Infix - = hang (pprCmdArg (unLoc arg1)) - 4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)]) - | otherwise - = fall_through - -ppr_cmd (XCmd x) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> ppr x - GhcRn -> ppr x -#endif - GhcTc -> case x of - HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) - -pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc -pprCmdArg (HsCmdTop _ cmd) - = ppr_lcmd cmd - -instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where - ppr = pprCmdArg - -{- -************************************************************************ -* * -\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} -* * -************************************************************************ --} - -type instance XMG GhcPs b = Origin -type instance XMG GhcRn b = Origin -type instance XMG GhcTc b = MatchGroupTc - -data MatchGroupTc - = MatchGroupTc - { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn - , mg_res_ty :: Type -- Type of the result, tr - , mg_origin :: Origin -- Origin (Generated vs FromSource) - } deriving Data - -type instance XXMatchGroup (GhcPass _) b = DataConCantHappen - -type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn] -type instance XXMatch (GhcPass _) b = DataConCantHappen - -instance (OutputableBndrId pr, Outputable body) - => Outputable (Match (GhcPass pr) body) where - ppr = pprMatch - -isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool -isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms - --- | Is there only one RHS in this list of matches? -isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool -isSingletonMatchGroup matches - | [L _ match] <- matches - , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match - = True - | otherwise - = False - -matchGroupArity :: MatchGroup (GhcPass id) body -> Arity --- Precondition: MatchGroup is non-empty --- This is called before type checking, when mg_arg_tys is not set -matchGroupArity (MG { mg_alts = alts }) - | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) - | otherwise = panic "matchGroupArity" - -hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] -hsLMatchPats (L _ (Match { m_pats = pats })) = pats - --- We keep the type checker happy by providing EpAnnComments. They --- can only be used if they follow a `where` keyword with no binds, --- but in that case the comment is attached to the following parsed --- item. So this can never be used in practice. -type instance XCGRHSs (GhcPass _) _ = EpAnnComments - -type instance XXGRHSs (GhcPass _) _ = DataConCantHappen - -data GrhsAnn - = GrhsAnn { - ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this? - ga_sep :: AddEpAnn -- ^ Match separator location - } deriving (Data) - -type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn - -- Location of matchSeparator - -- TODO:AZ does this belong on the GRHS, or GRHSs? - -type instance XXGRHS (GhcPass _) b = DataConCantHappen - -pprMatches :: (OutputableBndrId idR, Outputable body) - => MatchGroup (GhcPass idR) body -> SDoc -pprMatches MG { mg_alts = matches } - = vcat (map pprMatch (map unLoc (unLoc matches))) - -- Don't print the type; it's only a place-holder before typechecking - --- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId idR) - => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc -pprFunBind matches = pprMatches matches - --- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext -pprPatBind :: forall bndr p . (OutputableBndrId bndr, - OutputableBndrId p) - => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc -pprPatBind pat grhss - = sep [ppr pat, - nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)] - -pprMatch :: (OutputableBndrId idR, Outputable body) - => Match (GhcPass idR) body -> SDoc -pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss }) - = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) - , nest 2 (pprGRHSs ctxt grhss) ] - where - (herald, other_pats) - = case ctxt of - FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} - | SrcStrict <- strictness - -> assert (null pats) -- A strict variable binding - (char '!'<>pprPrefixOcc fun, pats) - - | Prefix <- fixity - -> (pprPrefixOcc fun, pats) -- f x y z = e - -- Not pprBndr; the AbsBinds will - -- have printed the signature - | otherwise - -> case pats of - (p1:p2:rest) - | null rest -> (pp_infix, []) -- x &&& y = e - | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e - where - pp_infix = pprParendLPat opPrec p1 - <+> pprInfixOcc fun - <+> pprParendLPat opPrec p2 - _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) - - LambdaExpr -> (char '\\', pats) - - -- We don't simply return (empty, pats) to avoid introducing an - -- additional `nest 2` via the empty herald - LamCaseAlt LamCases -> - maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats) - - ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> - maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats) - - ArrowMatchCtxt KappaExpr -> (char '\\', pats) - - ArrowMatchCtxt ProcExpr -> (text "proc", pats) - - _ -> case pats of - [] -> (empty, []) - [pat] -> (ppr pat, []) -- No parens around the single pat in a case - _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) - -pprGRHSs :: (OutputableBndrId idR, Outputable body) - => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc -pprGRHSs ctxt (GRHSs _ grhss binds) - = vcat (map (pprGRHS ctxt . unLoc) grhss) - -- Print the "where" even if the contents of the binds is empty. Only - -- EmptyLocalBinds means no "where" keyword - $$ ppUnless (eqEmptyLocalBinds binds) - (text "where" $$ nest 4 (pprBinds binds)) - -pprGRHS :: (OutputableBndrId idR, Outputable body) - => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc -pprGRHS ctxt (GRHS _ [] body) - = pp_rhs ctxt body - -pprGRHS ctxt (GRHS _ guards body) - = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] - -pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc -pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) - -instance Outputable GrhsAnn where - ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s - -{- -************************************************************************ -* * -\subsection{Do stmts and list comprehensions} -* * -************************************************************************ --} - --- Extra fields available post typechecking for RecStmt. -data RecStmtTc = - RecStmtTc - { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T - , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) - , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 - -- with recS_later_ids and recS_rec_ids, - -- and are the expressions that should be - -- returned by the recursion. - -- They may not quite be the Ids themselves, - -- because the Id may be *polymorphic*, but - -- the returned thing has to be *monomorphic*, - -- so they may be type applications - - , recS_ret_ty :: Type -- The type of - -- do { stmts; return (a,b,c) } - -- With rebindable syntax the type might not - -- be quite as simple as (m (tya, tyb, tyc)). - } - - -type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField - -type instance XBindStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn] -type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn -type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc - -data XBindStmtRn = XBindStmtRn - { xbsrn_bindOp :: SyntaxExpr GhcRn - , xbsrn_failOp :: FailOperator GhcRn - } - -data XBindStmtTc = XBindStmtTc - { xbstc_bindOp :: SyntaxExpr GhcTc - , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S - , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S - , xbstc_failOp :: FailOperator GhcTc - } - -type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField -type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField -type instance XApplicativeStmt (GhcPass _) GhcTc b = Type - -type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField -type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField -type instance XBodyStmt (GhcPass _) GhcTc b = Type - -type instance XLetStmt (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn] - -type instance XParStmt (GhcPass _) GhcPs b = NoExtField -type instance XParStmt (GhcPass _) GhcRn b = NoExtField -type instance XParStmt (GhcPass _) GhcTc b = Type - -type instance XTransStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn] -type instance XTransStmt (GhcPass _) GhcRn b = NoExtField -type instance XTransStmt (GhcPass _) GhcTc b = Type - -type instance XRecStmt (GhcPass _) GhcPs b = EpAnn AnnList -type instance XRecStmt (GhcPass _) GhcRn b = NoExtField -type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc - -type instance XXStmtLR (GhcPass _) (GhcPass _) b = DataConCantHappen - -type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen - -type instance XApplicativeArgOne GhcPs = NoExtField -type instance XApplicativeArgOne GhcRn = FailOperator GhcRn -type instance XApplicativeArgOne GhcTc = FailOperator GhcTc - -type instance XApplicativeArgMany (GhcPass _) = NoExtField -type instance XXApplicativeArg (GhcPass _) = DataConCantHappen - -instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))), - Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR))) - => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where - ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts - -instance (OutputableBndrId pl, OutputableBndrId pr, - Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA, - Outputable body) - => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where - ppr stmt = pprStmt stmt - -pprStmt :: forall idL idR body . (OutputableBndrId idL, - OutputableBndrId idR, - Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, - Outputable body) - => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc -pprStmt (LastStmt _ expr m_dollar_stripped _) - = whenPprDebug (text "[last]") <+> - (case m_dollar_stripped of - Just True -> text "return $" - Just False -> text "return" - Nothing -> empty) <+> - ppr expr -pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr -pprStmt (LetStmt _ binds) = hsep [text "let", pprBinds binds] -pprStmt (BodyStmt _ expr _ _) = ppr expr -pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) - -pprStmt (TransStmt { trS_stmts = stmts, trS_by = by - , trS_using = using, trS_form = form }) - = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) - -pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids - , recS_later_ids = later_ids }) - = text "rec" <+> - vcat [ ppr_do_stmts (unLoc segment) - , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids - , text "later_ids=" <> ppr later_ids])] - -pprStmt (ApplicativeStmt _ args mb_join) - = getPprStyle $ \style -> - if userStyle style - then pp_for_user - else pp_debug - where - -- make all the Applicative stuff invisible in error messages by - -- flattening the whole ApplicativeStmt nest back to a sequence - -- of statements. - pp_for_user = vcat $ concatMap flattenArg args - - -- ppr directly rather than transforming here, because we need to - -- inject a "return" which is hard when we're polymorphic in the id - -- type. - flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] - flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args - flattenStmt stmt = [ppr stmt] - - flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] - flattenArg (_, ApplicativeArgOne _ pat expr isBody) - | isBody = [ppr expr] -- See Note [Applicative BodyStmt] - | otherwise = [pprBindStmt pat expr] - flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = - concatMap flattenStmt stmts - - pp_debug = - let - ap_expr = sep (punctuate (text " |") (map pp_arg args)) - in - whenPprDebug (if isJust mb_join then text "[join]" else empty) <+> - (if lengthAtLeast args 2 then parens else id) ap_expr - - pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc - pp_arg (_, applicativeArg) = ppr applicativeArg - -pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc -pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr] - -instance (OutputableBndrId idL) - => Outputable (ApplicativeArg (GhcPass idL)) where - ppr = pprArg - -pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc -pprArg (ApplicativeArgOne _ pat expr isBody) - | isBody = ppr expr -- See Note [Applicative BodyStmt] - | otherwise = pprBindStmt pat expr -pprArg (ApplicativeArgMany _ stmts return pat ctxt) = - ppr pat <+> - text "<-" <+> - pprDo ctxt (stmts ++ - [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)]) - -pprTransformStmt :: (OutputableBndrId p) - => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) - -> Maybe (LHsExpr (GhcPass p)) -> SDoc -pprTransformStmt bndrs using by - = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) - , nest 2 (ppr using) - , nest 2 (pprBy by)] - -pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc -pprTransStmt by using ThenForm - = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] -pprTransStmt by using GroupForm - = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)] - -pprBy :: Outputable body => Maybe body -> SDoc -pprBy Nothing = empty -pprBy (Just e) = text "by" <+> ppr e - -pprDo :: (OutputableBndrId p, Outputable body, - Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA - ) - => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc -pprDo (DoExpr m) stmts = - ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts -pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts -pprDo (MDoExpr m) stmts = - ppr_module_name_prefix m <> text "mdo" <+> ppr_do_stmts stmts -pprDo ListComp stmts = brackets $ pprComp stmts -pprDo MonadComp stmts = brackets $ pprComp stmts - -pprArrowExpr :: (OutputableBndrId p, Outputable body, - Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA - ) - => [LStmt (GhcPass p) body] -> SDoc -pprArrowExpr stmts = text "do" <+> ppr_do_stmts stmts - -ppr_module_name_prefix :: Maybe ModuleName -> SDoc -ppr_module_name_prefix = \case - Nothing -> empty - Just module_name -> ppr module_name <> char '.' - -ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, - Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, - Outputable body) - => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc --- Print a bunch of do stmts -ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) - -pprComp :: (OutputableBndrId p, Outputable body, - Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) - => [LStmt (GhcPass p) body] -> SDoc -pprComp quals -- Prints: body | qual1, ..., qualn - | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals - = if null initStmts - -- If there are no statements in a list comprehension besides the last - -- one, we simply treat it like a normal list. This does arise - -- occasionally in code that GHC generates, e.g., in implementations of - -- 'range' for derived 'Ix' instances for product datatypes with exactly - -- one constructor (e.g., see #12583). - then ppr body - else hang (ppr body <+> vbar) 2 (pprQuals initStmts) - | otherwise - = pprPanic "pprComp" (pprQuals quals) - -pprQuals :: (OutputableBndrId p, Outputable body, - Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) - => [LStmt (GhcPass p) body] -> SDoc --- Show list comprehension qualifiers separated by commas -pprQuals quals = interpp'SP quals - -{- -************************************************************************ -* * - Template Haskell quotation brackets -* * -************************************************************************ --} - --- | Finalizers produced by a splice with --- 'Language.Haskell.TH.Syntax.addModFinalizer' --- --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how --- this is used. --- -newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] - --- A Data instance which ignores the argument of 'ThModFinalizers'. -instance Data ThModFinalizers where - gunfold _ z _ = z $ ThModFinalizers [] - toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] - --- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. --- This is the result of splicing a splice. It is produced by --- the renamer and consumed by the typechecker. It lives only between the two. -data HsUntypedSpliceResult thing -- 'thing' can be HsExpr or HsType - = HsUntypedSpliceTop - { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice. - , utsplice_result :: thing -- ^ The result of splicing; See Note [Lifecycle of a splice] - } - | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point - -type instance XTypedSplice GhcPs = (EpAnnCO, EpAnn [AddEpAnn]) -type instance XTypedSplice GhcRn = SplicePointName -type instance XTypedSplice GhcTc = DelayedSplice - -type instance XUntypedSplice GhcPs = EpAnnCO -type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn) -type instance XUntypedSplice GhcTc = DataConCantHappen - --- HsUntypedSplice -type instance XUntypedSpliceExpr GhcPs = EpAnn [AddEpAnn] -type instance XUntypedSpliceExpr GhcRn = EpAnn [AddEpAnn] -type instance XUntypedSpliceExpr GhcTc = DataConCantHappen - -type instance XQuasiQuote p = NoExtField - -type instance XXUntypedSplice p = DataConCantHappen - --- See Note [Running typed splices in the zonker] --- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice` -data DelayedSplice = - DelayedSplice - TcLclEnv -- The local environment to run the splice in - (LHsExpr GhcRn) -- The original renamed expression - TcType -- The result type of running the splice, unzonked - (LHsExpr GhcTc) -- The typechecked expression to run and splice in the result - --- A Data instance which ignores the argument of 'DelayedSplice'. -instance Data DelayedSplice where - gunfold _ _ _ = panic "DelayedSplice" - toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix - dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] - --- See Note [Pending Splices] -type SplicePointName = Name - -data UntypedSpliceFlavour - = UntypedExpSplice - | UntypedPatSplice - | UntypedTypeSplice - | UntypedDeclSplice - deriving Data - --- | Pending Renamer Splice -data PendingRnSplice - = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) - --- | Pending Type-checker Splice -data PendingTcSplice - = PendingTcSplice SplicePointName (LHsExpr GhcTc) - - -pprPendingSplice :: (OutputableBndrId p) - => SplicePointName -> LHsExpr (GhcPass p) -> SDoc -pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e)) - -pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc -pprTypedSplice n e = ppr_splice (text "$$") n e - -pprUntypedSplice :: forall p. (OutputableBndrId p) - => Bool -- Whether to precede the splice with "$" - -> Maybe SplicePointName -- Used for pretty printing when exists - -> HsUntypedSplice (GhcPass p) - -> SDoc -pprUntypedSplice True n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e -pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e -pprUntypedSplice _ _ (HsQuasiQuote _ q s) = ppr_quasi q (unLoc s) - -ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc -ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <> - ppr quote <> text "|]" - -ppr_splice :: (OutputableBndrId p) - => SDoc - -> Maybe SplicePointName - -> LHsExpr (GhcPass p) - -> SDoc -ppr_splice herald mn e - = herald - <> (case mn of - Nothing -> empty - Just splice_name -> whenPprDebug (brackets (ppr splice_name))) - <> ppr e - - -type instance XExpBr GhcPs = NoExtField -type instance XPatBr GhcPs = NoExtField -type instance XDecBrL GhcPs = NoExtField -type instance XDecBrG GhcPs = NoExtField -type instance XTypBr GhcPs = NoExtField -type instance XVarBr GhcPs = NoExtField -type instance XXQuote GhcPs = DataConCantHappen - -type instance XExpBr GhcRn = NoExtField -type instance XPatBr GhcRn = NoExtField -type instance XDecBrL GhcRn = NoExtField -type instance XDecBrG GhcRn = NoExtField -type instance XTypBr GhcRn = NoExtField -type instance XVarBr GhcRn = NoExtField -type instance XXQuote GhcRn = DataConCantHappen - --- See Note [The life cycle of a TH quotation] -type instance XExpBr GhcTc = DataConCantHappen -type instance XPatBr GhcTc = DataConCantHappen -type instance XDecBrL GhcTc = DataConCantHappen -type instance XDecBrG GhcTc = DataConCantHappen -type instance XTypBr GhcTc = DataConCantHappen -type instance XVarBr GhcTc = DataConCantHappen -type instance XXQuote GhcTc = NoExtField - -instance OutputableBndrId p - => Outputable (HsQuote (GhcPass p)) where - ppr = pprHsQuote - where - pprHsQuote :: forall p. (OutputableBndrId p) - => HsQuote (GhcPass p) -> SDoc - pprHsQuote (ExpBr _ e) = thBrackets empty (ppr e) - pprHsQuote (PatBr _ p) = thBrackets (char 'p') (ppr p) - pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) - pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) - pprHsQuote (TypBr _ t) = thBrackets (char 't') (ppr t) - pprHsQuote (VarBr _ True n) - = char '\'' <> pprPrefixOcc (unLoc n) - pprHsQuote (VarBr _ False n) - = text "''" <> pprPrefixOcc (unLoc n) - pprHsQuote (XQuote b) = case ghcPass @p of -#if __GLASGOW_HASKELL__ <= 900 - GhcPs -> dataConCantHappen b - GhcRn -> dataConCantHappen b -#endif - GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b) - -- See Note [The life cycle of a TH quotation] - -thBrackets :: SDoc -> SDoc -> SDoc -thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> - pp_body <+> text "|]" - -thTyBrackets :: SDoc -> SDoc -thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" - -instance Outputable PendingRnSplice where - ppr (PendingRnSplice _ n e) = pprPendingSplice n e - -instance Outputable PendingTcSplice where - ppr (PendingTcSplice n e) = pprPendingSplice n e - -ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc -ppr_with_pending_tc_splices x [] = x -ppr_with_pending_tc_splices x ps = x $$ text "pending(tc)" <+> ppr ps - -{- -************************************************************************ -* * -\subsection{Enumerations and list comprehensions} -* * -************************************************************************ --} - -instance OutputableBndrId p - => Outputable (ArithSeqInfo (GhcPass p)) where - ppr (From e1) = hcat [ppr e1, pp_dotdot] - ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] - ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] - ppr (FromThenTo e1 e2 e3) - = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] - -pp_dotdot :: SDoc -pp_dotdot = text " .. " - -{- -************************************************************************ -* * -\subsection{HsMatchCtxt} -* * -************************************************************************ --} - -instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where - ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) - ppr LambdaExpr = text "LambdaExpr" - ppr CaseAlt = text "CaseAlt" - ppr (LamCaseAlt lc_variant) = text "LamCaseAlt" <+> ppr lc_variant - ppr IfAlt = text "IfAlt" - ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c - ppr PatBindRhs = text "PatBindRhs" - ppr PatBindGuards = text "PatBindGuards" - ppr RecUpd = text "RecUpd" - ppr (StmtCtxt _) = text "StmtCtxt _" - ppr ThPatSplice = text "ThPatSplice" - ppr ThPatQuote = text "ThPatQuote" - ppr PatSyn = text "PatSyn" - -instance Outputable LamCaseVariant where - ppr = text . \case - LamCase -> "LamCase" - LamCases -> "LamCases" - -lamCaseKeyword :: LamCaseVariant -> SDoc -lamCaseKeyword LamCase = text "\\case" -lamCaseKeyword LamCases = text "\\cases" - -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - -instance Outputable HsArrowMatchContext where - ppr ProcExpr = text "ProcExpr" - ppr ArrowCaseAlt = text "ArrowCaseAlt" - ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant - ppr KappaExpr = text "KappaExpr" - -pprHsArrType :: HsArrAppType -> SDoc -pprHsArrType HsHigherOrderApp = text "higher order arrow application" -pprHsArrType HsFirstOrderApp = text "first order arrow application" - ------------------ - -instance OutputableBndrId p - => Outputable (HsStmtContext (GhcPass p)) where - ppr = pprStmtContext - --- Used to generate the string for a *runtime* error message -matchContextErrString :: OutputableBndrId p - => HsMatchContext (GhcPass p) -> SDoc -matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun -matchContextErrString CaseAlt = text "case" -matchContextErrString (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant -matchContextErrString IfAlt = text "multi-way if" -matchContextErrString PatBindRhs = text "pattern binding" -matchContextErrString PatBindGuards = text "pattern binding guards" -matchContextErrString RecUpd = text "record update" -matchContextErrString LambdaExpr = text "lambda" -matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c -matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime -matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString PatSyn = text "pattern synonym" -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" -matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" -matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour - -matchArrowContextErrString :: HsArrowMatchContext -> SDoc -matchArrowContextErrString ProcExpr = text "proc" -matchArrowContextErrString ArrowCaseAlt = text "case" -matchArrowContextErrString (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant -matchArrowContextErrString KappaExpr = text "kappa" - -matchDoContextErrString :: HsDoFlavour -> SDoc -matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command" -matchDoContextErrString (DoExpr m) = prependQualified m (text "'do' block") -matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block") -matchDoContextErrString ListComp = text "list comprehension" -matchDoContextErrString MonadComp = text "monad comprehension" - -pprMatchInCtxt :: (OutputableBndrId idR, Outputable body) - => Match (GhcPass idR) body -> SDoc -pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) - <> colon) - 4 (pprMatch match) - -pprStmtInCtxt :: (OutputableBndrId idL, - OutputableBndrId idR, - OutputableBndrId ctx, - Outputable body, - Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) - => HsStmtContext (GhcPass ctx) - -> StmtLR (GhcPass idL) (GhcPass idR) body - -> SDoc -pprStmtInCtxt ctxt (LastStmt _ e _ _) - | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" - = hang (text "In the expression:") 2 (ppr e) - -pprStmtInCtxt ctxt stmt - = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) - 2 (ppr_stmt stmt) - where - -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (TransStmt { trS_by = by, trS_using = using - , trS_form = form }) = pprTransStmt by using form - ppr_stmt stmt = pprStmt stmt - -matchSeparator :: HsMatchContext p -> SDoc -matchSeparator FunRhs{} = text "=" -matchSeparator CaseAlt = text "->" -matchSeparator LamCaseAlt{} = text "->" -matchSeparator IfAlt = text "->" -matchSeparator LambdaExpr = text "->" -matchSeparator ArrowMatchCtxt{} = text "->" -matchSeparator PatBindRhs = text "=" -matchSeparator PatBindGuards = text "=" -matchSeparator StmtCtxt{} = text "<-" -matchSeparator RecUpd = text "=" -- This can be printed by the pattern -matchSeparator PatSyn = text "<-" -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" - -pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsMatchContext p -> SDoc -pprMatchContext ctxt - | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt - | otherwise = text "a" <+> pprMatchContextNoun ctxt - where - want_an (FunRhs {}) = True -- Use "an" in front - want_an (ArrowMatchCtxt ProcExpr) = True - want_an (ArrowMatchCtxt KappaExpr) = True - want_an _ = False - -pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsMatchContext p -> SDoc -pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" - <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) -pprMatchContextNoun CaseAlt = text "case alternative" -pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant - <+> text "alternative" -pprMatchContextNoun IfAlt = text "multi-way if alternative" -pprMatchContextNoun RecUpd = text "record update" -pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" -pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" -pprMatchContextNoun PatBindRhs = text "pattern binding" -pprMatchContextNoun PatBindGuards = text "pattern binding guards" -pprMatchContextNoun LambdaExpr = text "lambda abstraction" -pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c -pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" - $$ pprAStmtContext ctxt -pprMatchContextNoun PatSyn = text "pattern synonym declaration" - -pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsMatchContext p -> SDoc -pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" - <+> quotes (ppr (unXRec @(NoGhcTc p) fun)) -pprMatchContextNouns PatBindGuards = text "pattern binding guards" -pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c -pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" - $$ pprAStmtContext ctxt -pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's' - -pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc -pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern" -pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation" -pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant - <+> text "alternative within arrow notation" -pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction" - -pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc -pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation" -pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant - <+> text "alternatives within arrow notation" -pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' - ------------------ -pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) - => HsStmtContext p -> SDoc -pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour -pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt - ------------------ -pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour -pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt -pprStmtContext ArrowExpr = text "'do' block in an arrow command" - --- Drop the inner contexts when reporting errors, else we get --- Unexpected transform statement --- in a transformed branch of --- transformed branch of --- transformed branch of monad comprehension -pprStmtContext (ParStmtCtxt c) = - ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) - (pprStmtContext c) -pprStmtContext (TransStmtCtxt c) = - ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) - (pprStmtContext c) - -pprStmtCat :: Stmt (GhcPass p) body -> SDoc -pprStmtCat (TransStmt {}) = text "transform" -pprStmtCat (LastStmt {}) = text "return expression" -pprStmtCat (BodyStmt {}) = text "body" -pprStmtCat (BindStmt {}) = text "binding" -pprStmtCat (LetStmt {}) = text "let" -pprStmtCat (RecStmt {}) = text "rec" -pprStmtCat (ParStmt {}) = text "parallel" -pprStmtCat (ApplicativeStmt {}) = text "applicative" - -pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc -pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour - where - pp_an = text "an" - pp_a = text "a" - article = case flavour of - MDoExpr Nothing -> pp_an - GhciStmtCtxt -> pp_an - _ -> pp_a -pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block") -pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block") -pprHsDoFlavour ListComp = text "list comprehension" -pprHsDoFlavour MonadComp = text "monad comprehension" -pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command" - -prependQualified :: Maybe ModuleName -> SDoc -> SDoc -prependQualified Nothing t = t -prependQualified (Just _) t = text "qualified" <+> t - -{- -************************************************************************ -* * -FieldLabelStrings -* * -************************************************************************ --} - -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where - ppr (FieldLabelStrings flds) = - hcat (punctuate dot (map (ppr . unXRec @p) flds)) - -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where - pprInfixOcc = pprFieldLabelStrings - pprPrefixOcc = pprFieldLabelStrings - -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprInfixOcc . unLoc - -pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc -pprFieldLabelStrings (FieldLabelStrings flds) = - hcat (punctuate dot (map (ppr . unXRec @p) flds)) - -pprPrefixFastString :: FastString -> SDoc -pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs) - -instance UnXRec p => Outputable (DotFieldOcc p) where - ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s - ppr XDotFieldOcc{} = text "XDotFieldOcc" - -{- -************************************************************************ -* * -\subsection{Anno instances} -* * -************************************************************************ --} - -type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL - -type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA - -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] - = SrcSpanAnnL -type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns -type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL -type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL -type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA -type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA -type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns -type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcAnn NoEpAnns -type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA - -type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA - -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnL - -type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns -type instance Anno FieldLabelString = SrcSpanAnnN - -type instance Anno FastString = SrcAnn NoEpAnns - -- Used in HsQuasiQuote and perhaps elsewhere - -type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns - -instance (Anno a ~ SrcSpanAnn' (EpAnn an)) +import GHC.Hs.Basic() -- import instances +import GHC.Hs.Decls() -- import instances +import GHC.Hs.Pat +import GHC.Hs.Lit +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Hs.Extension +import GHC.Hs.Type +import GHC.Hs.Binds +import GHC.Parser.Annotation + +-- others: +import GHC.Tc.Types.Evidence +import GHC.Types.Id.Info ( RecSelParent ) +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Name.Set +import GHC.Types.Basic +import GHC.Types.Fixity +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import GHC.Types.Tickish (CoreTickish) +import GHC.Types.Unique.Set (UniqSet) +import GHC.Types.ThLevelIndex +import GHC.Core.ConLike ( conLikeName, ConLike ) +import GHC.Unit.Module (ModuleName) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.FastString +import GHC.Core.Type +import GHC.Builtin.Types (mkTupleStr) +import GHC.Tc.Utils.TcType (TcType, TcTyVar) +import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv) + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified GHC.Boot.TH.Syntax as TH (Q) + +-- libraries: +import Data.Data hiding (Fixity(..)) +import qualified Data.Data as Data (Fixity(..)) +import qualified Data.Kind +import Data.Maybe (isJust) +import Data.Foldable ( toList ) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Void (Void) +import qualified Data.Set as S +{- ********************************************************************* +* * + Expressions proper +* * +********************************************************************* -} + +-- | Post-Type checking Expression +-- +-- PostTcExpr is an evidence expression attached to the syntax tree by the +-- type checker (c.f. postTcType). +type PostTcExpr = HsExpr GhcTc + +-- | Post-Type checking Table +-- +-- We use a PostTcTable where there are a bunch of pieces of evidence, more +-- than is convenient to keep individually. +type PostTcTable = [(Name, PostTcExpr)] + +------------------------- + +-- Defining SyntaxExpr in two stages allows for better type inference, because +-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity, +-- noSyntaxExpr would be ambiguous. +type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p + +type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where + SyntaxExprGhc 'Parsed = NoExtField + SyntaxExprGhc 'Renamed = SyntaxExprRn + SyntaxExprGhc 'Typechecked = SyntaxExprTc + +-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr]. +data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn) + -- Why is the payload not just a Name? + -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" + | NoSyntaxExprRn + +-- | An expression with wrappers, used for rebindable syntax +-- +-- This should desugar to +-- +-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) +-- > (syn_arg_wraps[1] arg1) ... +-- +-- where the actual arguments come from elsewhere in the AST. +data SyntaxExprTc = SyntaxExprTc { syn_expr :: HsExpr GhcTc + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + | NoSyntaxExprTc -- See Note [NoSyntaxExpr] + +-- | This is used for rebindable-syntax pieces that are too polymorphic +-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) +noExpr :: HsExpr (GhcPass p) +noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr")) + +noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after + -- See Note [NoSyntaxExpr] +noSyntaxExpr = case ghcPass @p of + GhcPs -> noExtField + GhcRn -> NoSyntaxExprRn + GhcTc -> NoSyntaxExprTc + +-- | Make a 'SyntaxExpr GhcRn' from an expression +-- Used only in getMonadFailOp. +-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr" +mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn +mkSyntaxExpr = SyntaxExprRn + +instance Outputable SyntaxExprRn where + ppr (SyntaxExprRn expr) = ppr expr + ppr NoSyntaxExprRn = text "" + +instance Outputable SyntaxExprTc where + ppr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = sdocOption sdocPrintExplicitCoercions $ \print_co -> + getPprDebug $ \debug -> + if debug || print_co + then ppr expr <> braces (pprWithCommas ppr arg_wraps) + <> braces (ppr res_wrap) + else ppr expr + + ppr NoSyntaxExprTc = text "" + +-- | HsWrap appears only in typechecker output +data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper + (hs_syn GhcTc) -- the thing that is wrapped + +deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn) + +-- --------------------------------------------------------------------- + +data HsBracketTc = HsBracketTc + { hsb_quote :: HsQuote GhcRn -- See Note [The life cycle of a TH quotation] + , hsb_ty :: Type + , hsb_wrap :: Maybe QuoteWrapper -- The wrapper to apply type and dictionary argument to the quote. + , hsb_splices :: [PendingTcSplice] -- Output of the type checker is the *original* + -- renamed expression, plus + -- _typechecked_ splices to be + -- pasted back in by the desugarer + } + +type instance XTypedBracket GhcPs = (BracketAnn (EpToken "[||") (EpToken "[e||"), EpToken "||]") +type instance XTypedBracket GhcRn = NoExtField +type instance XTypedBracket GhcTc = HsBracketTc +type instance XUntypedBracket GhcPs = NoExtField +type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices] + -- Output of the renamer is the *original* renamed expression, + -- plus _renamed_ splices to be type checked +type instance XUntypedBracket GhcTc = HsBracketTc + +data BracketAnn noE hasE + = BracketNoE noE + | BracketHasE hasE + deriving Data + +instance (NoAnn n, NoAnn h) => NoAnn (BracketAnn n h) where + noAnn = BracketNoE noAnn + +-- --------------------------------------------------------------------- + +-- API Annotations types + +data EpAnnHsCase = EpAnnHsCase + { hsCaseAnnCase :: EpToken "case" + , hsCaseAnnOf :: EpToken "of" + } deriving Data + +instance NoAnn EpAnnHsCase where + noAnn = EpAnnHsCase noAnn noAnn + +data EpAnnLam = EpAnnLam + { epl_lambda :: EpToken "\\" -- ^ Location of '\' keyword + , epl_case :: Maybe EpaLocation -- ^ Location of 'case' or + -- 'cases' keyword, depending + -- on related 'HsLamVariant'. + } deriving Data + +instance NoAnn EpAnnLam where + noAnn = EpAnnLam noAnn noAnn + +-- Record selectors at parse time are HsVar; they convert to HsRecSel +-- on renaming. +type instance XRecSel GhcPs = DataConCantHappen +type instance XRecSel GhcRn = NoExtField +type instance XRecSel GhcTc = NoExtField + +-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr +-- Note [Handling overloaded and rebindable constructs] +type instance XOverLabel GhcPs = SourceText +type instance XOverLabel GhcRn = SourceText +type instance XOverLabel GhcTc = DataConCantHappen + +-- --------------------------------------------------------------------- + +type instance XVar (GhcPass _) = NoExtField + +type instance XIPVar GhcPs = NoExtField +type instance XIPVar GhcRn = NoExtField +type instance XIPVar GhcTc = DataConCantHappen +type instance XOverLitE (GhcPass _) = NoExtField +type instance XLitE (GhcPass _) = NoExtField +type instance XLam (GhcPass _) = EpAnnLam +type instance XApp (GhcPass _) = NoExtField + +type instance XAppTypeE GhcPs = EpToken "@" +type instance XAppTypeE GhcRn = NoExtField +type instance XAppTypeE GhcTc = Type + +-- OpApp not present in GhcTc pass; see GHC.Rename.Expr +-- Note [Handling overloaded and rebindable constructs] +type instance XOpApp GhcPs = NoExtField +type instance XOpApp GhcRn = Fixity +type instance XOpApp GhcTc = DataConCantHappen + +-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr +-- Note [Handling overloaded and rebindable constructs] +type instance XSectionL GhcPs = NoExtField +type instance XSectionR GhcPs = NoExtField +type instance XSectionL GhcRn = NoExtField +type instance XSectionR GhcRn = NoExtField +type instance XSectionL GhcTc = DataConCantHappen +type instance XSectionR GhcTc = DataConCantHappen + + +type instance XNegApp GhcPs = EpToken "-" +type instance XNegApp GhcRn = NoExtField +type instance XNegApp GhcTc = NoExtField + +type instance XPar GhcPs = (EpToken "(", EpToken ")") +type instance XPar GhcRn = NoExtField +type instance XPar GhcTc = NoExtField + +type instance XExplicitTuple GhcPs = (EpaLocation, EpaLocation) +type instance XExplicitTuple GhcRn = NoExtField +type instance XExplicitTuple GhcTc = NoExtField + +type instance XExplicitSum GhcPs = AnnExplicitSum +type instance XExplicitSum GhcRn = NoExtField +type instance XExplicitSum GhcTc = [Type] + +type instance XCase GhcPs = EpAnnHsCase +type instance XCase GhcRn = HsMatchContextRn +type instance XCase GhcTc = HsMatchContextRn + +type instance XIf GhcPs = AnnsIf +type instance XIf GhcRn = NoExtField +type instance XIf GhcTc = NoExtField + +type instance XMultiIf GhcPs = (EpToken "if", EpToken "{", EpToken "}") +type instance XMultiIf GhcRn = NoExtField +type instance XMultiIf GhcTc = Type + +type instance XLet GhcPs = (EpToken "let", EpToken "in") +type instance XLet GhcRn = NoExtField +type instance XLet GhcTc = NoExtField + +type instance XDo GhcPs = AnnList EpaLocation +type instance XDo GhcRn = NoExtField +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = AnnList () +type instance XExplicitList GhcRn = NoExtField +type instance XExplicitList GhcTc = Type +-- GhcPs: ExplicitList includes all source-level +-- list literals, including overloaded ones +-- GhcRn and GhcTc: ExplicitList used only for list literals +-- that denote Haskell's built-in lists. Overloaded lists +-- have been expanded away in the renamer +-- See Note [Handling overloaded and rebindable constructs] +-- in GHC.Rename.Expr + +type instance XRecordCon GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) +type instance XRecordCon GhcRn = NoExtField +type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function + +type instance XRecordUpd GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) +type instance XRecordUpd GhcRn = NoExtField +type instance XRecordUpd GhcTc = DataConCantHappen + -- We desugar record updates in the typechecker. + -- See [Handling overloaded and rebindable constructs], + -- and [Record Updates] in GHC.Tc.Gen.Expr. + +-- | Information about the parent of a record update: +-- +-- - the parent type constructor or pattern synonym, +-- - the relevant con-likes, +-- - the field labels. +data family HsRecUpdParent x + +data instance HsRecUpdParent GhcPs +data instance HsRecUpdParent GhcRn + = RnRecUpdParent + { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt + , rnRecUpdCons :: UniqSet ConLikeName } +data instance HsRecUpdParent GhcTc + = TcRecUpdParent + { tcRecUpdParent :: RecSelParent + , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt + , tcRecUpdCons :: UniqSet ConLike } + +type instance XLHsRecUpdLabels GhcPs = NoExtField +type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn) + -- Possible parents for the record update. +type instance XLHsRecUpdLabels GhcTc = DataConCantHappen + +type instance XLHsOLRecUpdLabels p = NoExtField + +type instance XGetField GhcPs = NoExtField +type instance XGetField GhcRn = NoExtField +type instance XGetField GhcTc = DataConCantHappen +-- HsGetField is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + +type instance XProjection GhcPs = AnnProjection +type instance XProjection GhcRn = NoExtField +type instance XProjection GhcTc = DataConCantHappen +-- HsProjection is eliminated by the renamer. See [Handling overloaded +-- and rebindable constructs]. + +type instance XExprWithTySig GhcPs = TokDcolon +type instance XExprWithTySig GhcRn = NoExtField +type instance XExprWithTySig GhcTc = NoExtField + +type instance XArithSeq GhcPs = AnnArithSeq +type instance XArithSeq GhcRn = NoExtField +type instance XArithSeq GhcTc = PostTcExpr + +type instance XProc (GhcPass _) = (EpToken "proc", TokRarrow) + +type instance XStatic GhcPs = EpToken "static" +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = (NameSet, Type) + -- Free variables and type of expression, this is stored for convenience as wiring in + -- StaticPtr is a bit tricky (see #20150) + +type instance XEmbTy GhcPs = EpToken "type" +type instance XEmbTy GhcRn = NoExtField +type instance XEmbTy GhcTc = DataConCantHappen + -- A free-standing HsEmbTy is an error. + -- Valid usages are immediately desugared into Type. + + +{- +Note [Holes in expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note explains how GHC uses the `HsHole` constructor. + +`HsHole` is used to represent: + + - anonymous ("_") and named ("_x") holes in expressions, + - unbound variables, + - and parse errors. + +A `HsHole` can be thought of as any thing which is not necessarily a valid or +fully defined program fragment, but for which a type can be derived. + +Note that holes (wildcards) in types, and partial type signatures, are not +handled using the mechanisms described here. Instead, see +Note [The wildcard story for types] for the relevant information. + + +* User-facing behavior + + While GHC uses the same internal mechanism to derive the type for any + `HsHole`, it gives different feedback to the user depending on the type of + hole. For example, an anonymous hole of the form + + foo x = x && _ + + gives the diagnostic + + Foo.hs:5:14: error: [GHC-88464] + • Found hole: _ :: Bool + • In the second argument of ‘(&&)’, namely ‘_’ + In the expression: x && _ + + while an expression containing an unbound variable + + foo x = x && y + + gives + + Foo.hs:5:14: error: [GHC-88464] + Variable not in scope: y :: Bool + + +* HsHole during parsing, renaming, and type checking + + The usage of `HsHole` during the three phases is listed below. + + - Anynomous holes, i.e. the user wrote "_": + + Parser HsHole (HoleVar "_") + Renamer HsHole (HoleVar "_") + Typechecker HsHole (HoleVar "_", ref :: HoleExprRef) + + - Unbound variables and named holes; i.e. the user wrote "x" or "_x", where + `x` or `_x` is not in scope. A variable with a leading underscore has no + special meaning to the parser. + + Parser HsVar "_x" + Renamer HsHole (HoleVar "_x") + Typechecker HsHole (HoleVar "_x", ref :: HoleExprRef) + + - Parse errors currently do not survive beyond the parser because an error is + thrown after parsing. However, in the future GHC is intended to be tolerant + of parse errors until the type checking phase to provide diagnostics similar + to holes. This current singular case looks like this: + + Parser HsHole HoleError + + Note that between anonymous holes, named holes, and unbound variables only the + parsing phase is distinct, while during the renaming and type checking phases + the cases are handled identically. The distinction that the user can observe + is only introduced during final error reporting. There the `RdrName` is + examined to see whether it starts with an underscore or not to determine + whether the `HsHole` came from a hole or an out of scope variable. + + +* Contents of HoleExprRef + + The HoleExprRef type used in the type checking phase is a data structure + containing: + + - The type of the hole. + - A ref-cell that is filled in (by the typechecker) with an + error thunk. With -fdefer-type errors we use this as the + value of the hole. + - A Unique (see Note [Uniques and tags]). + +* Typechecking holes + + When the typechecker encounters a `HsHole`, it returns one with the + HoleExprRef, but also emits a `DelayedError` into the `WantedConstraints`. + This DelayedError later triggers the error reporting, and the filling-in of + the error thunk, in GHC.Tc.Errors. + + The user has the option of deferring errors until runtime with + `-fdefer-type-errors`. In this case, the hole carries evidence in its + `HoleExprRef`. This evidence is an erroring expression that prints an error + and crashes at runtime. + +* Desugaring holes + + During desugaring, the `(HsHole (HoleVar "x", ref))` is desugared by + reading the ref-cell to find the error thunk evidence term, put there by the + constraint solver. + +* Wrinkles: + + - Prior to fixing #17812, we used to invent an Id to hold the erroring + expression, and then bind it during type-checking. But this does not support + representation-polymorphic out-of-scope identifiers. See + typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach + described above. + + - You might think that the type in the HoleExprRef is the same as the type of + the hole. However, because the hole type (hole_ty) is rewritten with respect + to givens, this might not be the case. That is, the hole_ty is always (~) to + the type of the HoleExprRef, but they might not be `eqType`. We need the + type of the generated evidence to match what is expected in the context of + the hole, and so we must store these types separately. + + - We really don't need the whole HoleExprRef; just the IORef EvTerm would be + enough. But then deriving a Data instance becomes impossible. Much, much + easier just to define HoleExprRef with a Data instance and store the whole + structure. +-} +-- | Expression Hole. See Note [Holes in expressions]. +type instance XHole GhcPs = HoleKind +type instance XHole GhcRn = HoleKind +type instance XHole GhcTc = (HoleKind, HoleExprRef) + +data HoleKind + = HoleVar (LIdP GhcPs) + | HoleError + deriving Data + +-- | The RdrName for an unnamed hole ("_"). +unnamedHoleRdrName :: RdrName +unnamedHoleRdrName = mkUnqual varName (fsLit "_") + + +type instance XForAll GhcPs = NoExtField +type instance XForAll GhcRn = NoExtField +type instance XForAll GhcTc = DataConCantHappen + +type instance XQual GhcPs = NoExtField +type instance XQual GhcRn = NoExtField +type instance XQual GhcTc = DataConCantHappen + +type instance XFunArr GhcPs = NoExtField +type instance XFunArr GhcRn = NoExtField +type instance XFunArr GhcTc = DataConCantHappen + +type instance XPragE (GhcPass _) = NoExtField + +type instance XFunRhs = AnnFunRhs + +type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW +type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA + +multAnnToHsExpr :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> Maybe (LocatedA (HsExpr GhcRn)) +multAnnToHsExpr = expandHsMultAnnOf mkHsVar + +mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p) +mkHsVar n = HsVar noExtField $ + case ghcPass @p of + GhcPs -> n + GhcRn -> fmap (WithUserRdr $ nameRdrName $ unLoc n) n + GhcTc -> n + +mkHsVarWithUserRdr :: forall p. IsPass p => RdrName -> LIdP (GhcPass p) -> HsExpr (GhcPass p) +mkHsVarWithUserRdr rdr n = HsVar noExtField $ + case ghcPass @p of + GhcPs -> n + GhcRn -> fmap (WithUserRdr rdr) n + GhcTc -> n + +data AnnExplicitSum + = AnnExplicitSum { + aesOpen :: EpaLocation, + aesBarsBefore :: [EpToken "|"], + aesBarsAfter :: [EpToken "|"], + aesClose :: EpaLocation + } deriving Data + +instance NoAnn AnnExplicitSum where + noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn + +data AnnFieldLabel + = AnnFieldLabel { + afDot :: Maybe (EpToken ".") + } deriving Data + +instance NoAnn AnnFieldLabel where + noAnn = AnnFieldLabel Nothing + +data AnnProjection + = AnnProjection { + apOpen :: EpToken "(", + apClose :: EpToken ")" + } deriving Data + +instance NoAnn AnnProjection where + noAnn = AnnProjection noAnn noAnn + +data AnnArithSeq + = AnnArithSeq { + aas_open :: EpToken "[", + aas_comma :: Maybe (EpToken ","), + aas_dotdot :: EpToken "..", + aas_close :: EpToken "]" + } deriving Data + +instance NoAnn AnnArithSeq where + noAnn = AnnArithSeq noAnn noAnn noAnn noAnn + +data AnnsIf + = AnnsIf { + aiIf :: EpToken "if", + aiThen :: EpToken "then", + aiElse :: EpToken "else", + aiThenSemi :: Maybe (EpToken ";"), + aiElseSemi :: Maybe (EpToken ";") + } deriving Data + +instance NoAnn AnnsIf where + noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing + +data AnnFunRhs + = AnnFunRhs { + afr_strict :: EpToken "!", + afr_opens :: [EpToken "("], + afr_closes :: [EpToken ")"] + } deriving Data + +instance NoAnn AnnFunRhs where + noAnn = AnnFunRhs noAnn noAnn noAnn + +-- --------------------------------------------------------------------- + +type instance XSCC (GhcPass _) = (AnnPragma, SourceText) +type instance XXPragE (GhcPass _) = DataConCantHappen + +type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel +type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen + +type instance XPresent (GhcPass _) = NoExtField + +type instance XMissing GhcPs = EpAnn Bool -- True for empty last comma +type instance XMissing GhcRn = NoExtField +type instance XMissing GhcTc = Scaled Type + +type instance XXTupArg (GhcPass _) = DataConCantHappen + +tupArgPresent :: HsTupArg (GhcPass p) -> Bool +tupArgPresent (Present {}) = True +tupArgPresent (Missing {}) = False + +tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p)) +tupArgPresent_maybe (Present _ e) = Just e +tupArgPresent_maybe (Missing {}) = Nothing + +tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)] +tupArgsPresent_maybe = traverse tupArgPresent_maybe + + +{- ********************************************************************* +* * + XXExpr: the extension constructor of HsExpr +* * +********************************************************************* -} + +type instance XXExpr GhcPs = DataConCantHappen +type instance XXExpr GhcRn = XXExprGhcRn +type instance XXExpr GhcTc = XXExprGhcTc +-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below + + +{- ********************************************************************* +* * + Generating code for ExpandedThingRn + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +-- | The different source constructs that we use to instantiate the "original" field +-- in an `XXExprGhcRn original expansion` +data HsThingRn = OrigExpr (HsExpr GhcRn) + | OrigStmt (ExprLStmt GhcRn) + | OrigPat (LPat GhcRn) + +isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool +isHsThingRnExpr (OrigExpr{}) = True +isHsThingRnExpr _ = False + +isHsThingRnStmt (OrigStmt{}) = True +isHsThingRnStmt _ = False + +isHsThingRnPat (OrigPat{}) = True +isHsThingRnPat _ = False + +data XXExprGhcRn + = ExpandedThingRn { xrn_orig :: HsThingRn -- The original source thing + , xrn_expanded :: HsExpr GhcRn } -- The compiler generated expanded thing + + | PopErrCtxt -- A hint for typechecker to pop + {-# UNPACK #-} !(LHsExpr GhcRn) -- the top of the error context stack + -- Does not presist post renaming phase + -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn] + -- in `GHC.Tc.Gen.Do` + | HsRecSelRn (FieldOcc GhcRn) -- ^ Variable pointing to record selector + -- See Note [Non-overloaded record field selectors] and + -- Note [Record selectors in the AST] + + + +-- | Wrap a located expression with a `PopErrCtxt` +mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn +mkPopErrCtxtExpr a = XExpr (PopErrCtxt a) + +-- | Wrap a located expression with a PopSrcExpr with an appropriate location +mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn +mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original expression and +-- expanded expressions. +mkExpandedExpr + :: HsExpr GhcRn -- ^ source expression + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr) + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original do stmt and +-- expanded expression +mkExpandedStmt + :: ExprLStmt GhcRn -- ^ source statement + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr) + +mkExpandedPatRn + :: LPat GhcRn -- ^ source pattern + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr) + +-- | Build an expression using the extension constructor `XExpr`, +-- and the two components of the expansion: original do stmt and +-- expanded expression an associate with a provided location +mkExpandedStmtAt + :: SrcSpanAnnA -- ^ Location for the expansion expression + -> ExprLStmt GhcRn -- ^ source statement + -> HsExpr GhcRn -- ^ expanded expression + -> LHsExpr GhcRn -- ^ suitably wrapped located 'XXExprGhcRn' +mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr + +-- | Wrap the expanded version of the expression with a pop. +mkExpandedStmtPopAt + :: SrcSpanAnnA -- ^ Location for the expansion statement + -> ExprLStmt GhcRn -- ^ source statement + -> HsExpr GhcRn -- ^ expanded expression + -> LHsExpr GhcRn -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr + + +data XXExprGhcTc + = WrapExpr -- Type and evidence application and abstractions + HsWrapper (HsExpr GhcTc) + + | ExpandedThingTc -- See Note [Rebindable syntax and XXExprGhcRn] + -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` + { xtc_orig :: HsThingRn -- The original user written thing + , xtc_expanded :: HsExpr GhcTc } -- The expanded typechecked expression + + | ConLikeTc -- Result of typechecking a data-con + -- See Note [Typechecking data constructors] in + -- GHC.Tc.Gen.Head + -- The two arguments describe how to eta-expand + -- the data constructor when desugaring + ConLike [TcTyVar] [Scaled TcType] + + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + CoreTickish + (LHsExpr GhcTc) -- sub-expression + + | HsBinTick + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr GhcTc) -- sub-expression + + | HsRecSelTc (FieldOcc GhcTc) -- ^ Variable pointing to record selector + -- See Note [Non-overloaded record field selectors] and + -- Note [Record selectors in the AST] + + +-- | Build a 'XXExprGhcRn' out of an extension constructor, +-- and the two components of the expansion: original and +-- expanded typechecked expressions. +mkExpandedExprTc + :: HsExpr GhcRn -- ^ source expression + -> HsExpr GhcTc -- ^ expanded typechecked expression + -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr) + +-- | Build a 'XXExprGhcRn' out of an extension constructor. +-- The two components of the expansion are: original statement and +-- expanded typechecked expression. +mkExpandedStmtTc + :: ExprLStmt GhcRn -- ^ source do statement + -> HsExpr GhcTc -- ^ expanded typechecked expression + -> HsExpr GhcTc -- ^ suitably wrapped 'XXExprGhcRn' +mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr) + +{- ********************************************************************* +* * + Pretty-printing expressions +* * +********************************************************************* -} + +instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where + ppr expr = pprExpr expr + +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc +pprLExpr (L _ e) = pprExpr e + +pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar {}) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds b = pprDeeper (ppr b) + +----------------------- +ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr :: forall p. (OutputableBndrId p) + => HsExpr (GhcPass p) -> SDoc +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsHole x) = case (ghcPass @p, x) of + (GhcPs, HoleVar (L _ v)) -> pprPrefixOcc v + (GhcRn, HoleVar (L _ v)) -> pprPrefixOcc v + (GhcTc, (HoleVar (L _ v), _)) -> pprPrefixOcc v + (GhcPs, HoleError) -> pprPrefixOcc unnamedHoleRdrName + (GhcRn, HoleError) -> pprPrefixOcc unnamedHoleRdrName + (GhcTc, (HoleError, _)) -> pprPrefixOcc unnamedHoleRdrName +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel s l) = case ghcPass @p of + GhcPs -> helper s + GhcRn -> helper s + GhcTc -> dataConCantHappen s + where helper s = + char '#' <> case s of + NoSourceText -> ppr l + SourceText src -> ftext src +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] + +ppr_expr e@(HsApp {}) = ppr_apps e [] +ppr_expr e@(HsAppType {}) = ppr_apps e [] + +ppr_expr (OpApp _ e1 op e2) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + + where + pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear + + pp_prefixly + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) + + pp_infixly pp_op + = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) + +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e + +ppr_expr (SectionL _ expr op) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, text "x_ )"]) + + pp_infixly v = (sep [pp_expr, v]) + +ppr_expr (SectionR _ op expr) + | Just pp_op <- ppr_infix_expr (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) + 4 (pp_expr <> rparen) + + pp_infixly v = sep [v, pp_expr] + +ppr_expr (ExplicitTuple _ exprs boxity) + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `MkSolo x`, not `(x)` + | [Present _ expr] <- exprs + , Boxed <- boxity + = hsep [text (mkTupleStr Boxed dataName 1), ppr expr] + | otherwise + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs)) + where + ppr_tup_args [] = [] + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + + punc (Present {} : _) = comma <> space + punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space + punc [] = empty + +ppr_expr (ExplicitSum _ alt arity expr) + = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" + where + ppr_bars n = hsep (replicate n (char '|')) + +ppr_expr (HsLam _ lam_variant matches) + = case lam_variant of + LamSingle -> pprMatches matches + _ -> sep [ sep [lamCaseKeyword lam_variant] + , nest 2 (pprMatches matches) ] + +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts })) + = sep [ sep [text "case", nest 4 (ppr expr), text "of"], + pp_alts ] + where + pp_alts | null alts = text "{}" + | otherwise = nest 2 (pprMatches matches) + +ppr_expr (HsIf _ e1 e2 e3) + = sep [hsep [text "if", nest 2 (ppr e1), text "then"], + nest 4 (ppr e2), + text "else", + nest 4 (ppr e3)] + +ppr_expr (HsMultiIf _ alts) + = hang (text "if") 3 (vcat $ toList $ NE.map ppr_alt alts) + where ppr_alt (L _ (GRHS _ guards expr)) = + hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr))) + ppr_alt (L _ (XGRHS x)) = ppr x + +-- special case: let ... in let ... +ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), + ppr_lexpr expr] + +ppr_expr (HsLet _ binds expr) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr expr)] + +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ exprs) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) + = hang pp_con 2 (ppr rbinds) + where + -- con :: ConLikeP (GhcPass p) + -- so we need case analysis to know to print it + pp_con = case ghcPass @p of + GhcPs -> ppr con + GhcRn -> ppr con + GhcTc -> ppr con + +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds }) + = case flds of + RegularRecUpdFields { recUpdFields= rbinds } -> + hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + OverloadedRecUpdFields { olRecUpdFields = pbinds } -> + hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds)))) + +ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field }) + = ppr fexp <> dot <> ppr field + +ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds)))) + +ppr_expr (ExprWithTySig _ expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) + +ppr_expr (HsTypedSplice ext e) = + case ghcPass @p of + GhcPs -> pprTypedSplice Nothing e + GhcRn -> + case ext of + HsTypedSpliceNested n -> pprTypedSplice (Just n) e + HsTypedSpliceTop {} -> pprTypedSplice Nothing e + GhcTc -> pprTypedSplice Nothing e +ppr_expr (HsUntypedSplice ext s) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing s + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s + GhcRn | HsUntypedSpliceTop _ e <- ext -> ppr e + GhcTc -> dataConCantHappen ext + +ppr_expr (HsTypedBracket b e) + = case ghcPass @p of + GhcPs -> thTyBrackets (ppr e) + GhcRn -> thTyBrackets (ppr e) + GhcTc | HsBracketTc _ _ty _wrap ps <- b -> + thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps +ppr_expr (HsUntypedBracket b q) + = case ghcPass @p of + GhcPs -> ppr q + GhcRn -> case b of + [] -> ppr q + ps -> ppr q $$ whenPprDebug (text "pending(rn)" <+> ppr (map ppr_nested_splice ps)) + GhcTc | HsBracketTc rnq _ty _wrap ps <- b -> + ppr rnq `ppr_with_pending_tc_splices` ps + where + ppr_nested_splice (PendingRnSplice splice_name expr) = pprUntypedSplice False (Just splice_name) expr + +ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) + = hsep [text "proc", ppr pat, arrow, ppr cmd] + +ppr_expr (HsStatic _ e) + = hsep [text "static", ppr e] + +ppr_expr (HsEmbTy _ ty) + = hsep [text "type", ppr ty] + +ppr_expr (HsQual _ ctxt ty) + = sep [ppr_context ctxt, ppr_lexpr ty] + where + ppr_context (L _ ctxt) = + case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_expr ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow + +ppr_expr (HsForAll _ tele ty) + = sep [pprHsForAll tele Nothing, ppr_lexpr ty] + +ppr_expr (HsFunArr _ arr arg res) + = sep [ppr_lexpr arg, pprHsArrow arr <+> ppr_lexpr res] + +ppr_expr (XExpr x) = case ghcPass @p of + GhcRn -> ppr x + GhcTc -> ppr x + +instance Outputable HsThingRn where + ppr thing + = case thing of + OrigExpr x -> ppr_builder ":" x + OrigStmt x -> ppr_builder ":" x + OrigPat x -> ppr_builder ":" x + + where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x) + +instance Outputable XXExprGhcRn where + ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o) + ppr (PopErrCtxt e) = ifPprDebug (braces (text "" <+> ppr e)) (ppr e) + ppr (HsRecSelRn f) = pprPrefixOcc f + +instance Outputable XXExprGhcTc where + ppr (WrapExpr co_fn e) + = pprHsWrapper co_fn (\_parens -> pprExpr e) + + ppr (ExpandedThingTc o e) + = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o) + -- e is the expanded expression, we print the original + -- expression (HsExpr GhcRn), not the + -- expanded typechecked one (HsExpr GhcTc), + -- unless we are in ppr's debug mode printed both + + ppr (ConLikeTc con _ _) = pprPrefixOcc con + -- Used in error messages generated by + -- the pattern match overlap checker + + ppr (HsTick tickish exp) = + pprTicks (ppr exp) $ + ppr tickish <+> ppr_lexpr exp + + ppr (HsBinTick tickIdTrue tickIdFalse exp) = + pprTicks (ppr exp) $ + hcat [text "bintick<", + ppr tickIdTrue, + text ",", + ppr tickIdFalse, + text ">(", + ppr exp, text ")"] + ppr (HsRecSelTc f) = pprPrefixOcc f + +ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc +ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v) +ppr_infix_expr (HsHole x) = Just $ pprInfixOcc $ case (ghcPass @p, x) of + (GhcPs, HoleVar (L _ v)) -> v + (GhcRn, HoleVar (L _ v)) -> v + (GhcTc, (HoleVar (L _ v), _)) -> v + _ -> unnamedHoleRdrName -- TODO: this is the HoleError case; this should print the source text instead of "_". +ppr_infix_expr (XExpr x) = case ghcPass @p of + GhcRn -> ppr_infix_expr_rn x + GhcTc -> ppr_infix_expr_tc x +ppr_infix_expr _ = Nothing + +ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc +ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing +ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a +ppr_infix_expr_rn (HsRecSelRn f) = Just (pprInfixOcc f) + +ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc +ppr_infix_expr_tc (WrapExpr _ e) = ppr_infix_expr e +ppr_infix_expr_tc (ExpandedThingTc thing _) = ppr_infix_hs_expansion thing +ppr_infix_expr_tc (ConLikeTc {}) = Nothing +ppr_infix_expr_tc (HsTick {}) = Nothing +ppr_infix_expr_tc (HsBinTick {}) = Nothing +ppr_infix_expr_tc (HsRecSelTc f) = Just (pprInfixOcc f) + +ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc +ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e +ppr_infix_hs_expansion _ = Nothing + +ppr_apps :: (OutputableBndrId p) + => HsExpr (GhcPass p) + -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] + -> SDoc +ppr_apps (HsApp _ (L _ fun) arg) args + = ppr_apps fun (Left arg : args) +ppr_apps (HsAppType _ (L _ fun) arg) args + = ppr_apps fun (Right arg : args) +ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) + where + pp (Left arg) = ppr arg + -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) + -- = char '@' <> pprHsType arg + pp (Right arg) + = text "@" <> ppr arg + +pprDebugParendExpr :: (OutputableBndrId p) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr p expr + = getPprDebug $ \case + True -> pprParendLExpr p expr + False -> pprLExpr expr + +pprParendLExpr :: (OutputableBndrId p) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprParendLExpr p (L _ e) = pprParendExpr p e + +pprParendExpr :: (OutputableBndrId p) + => PprPrec -> HsExpr (GhcPass p) -> SDoc +pprParendExpr p expr + | hsExprNeedsParens p expr = parens (pprExpr expr) + | otherwise = pprExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + +-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs +-- parentheses under precedence @p@. +hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool +hsExprNeedsParens prec = go + where + go :: HsExpr (GhcPass p) -> Bool + go (HsVar{}) = False + go (HsIPVar{}) = False + go (HsOverLabel{}) = False + go (HsLit _ l) = hsLitNeedsParens prec l + go (HsOverLit _ ol) = hsOverLitNeedsParens prec ol + go (HsPar{}) = False + go (HsApp{}) = prec >= appPrec + go (HsAppType {}) = prec >= appPrec + go (OpApp{}) = prec >= opPrec + go (NegApp{}) = prec > topPrec + go (SectionL{}) = True + go (SectionR{}) = True + -- Special-case unary boxed tuple applications so that they are + -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) + -- See Note [One-tuples] in GHC.Builtin.Types + go (ExplicitTuple _ [Present{}] Boxed) + = prec >= appPrec + go (ExplicitTuple{}) = False + go (ExplicitSum{}) = False + go (HsLam{}) = prec > topPrec + go (HsCase{}) = prec > topPrec + go (HsIf{}) = prec > topPrec + go (HsMultiIf{}) = prec > topPrec + go (HsLet{}) = prec > topPrec + go (HsDo _ sc _) + | isDoComprehensionContext sc = False + | otherwise = prec > topPrec + go (ExplicitList{}) = False + go (RecordUpd{}) = False + go (ExprWithTySig{}) = prec >= sigPrec + go (ArithSeq{}) = False + go (HsPragE{}) = prec >= appPrec + go (HsTypedSplice{}) = False + go (HsUntypedSplice{}) = False + go (HsTypedBracket{}) = False + go (HsUntypedBracket{}) = False + go (HsProc{}) = prec > topPrec + go (HsStatic{}) = prec >= appPrec + go (RecordCon{}) = False + go (HsProjection{}) = True + go (HsGetField{}) = False + go (HsEmbTy{}) = prec > topPrec + go (HsHole{}) = False + go (HsForAll{}) = prec >= funPrec + go (HsQual{}) = prec >= funPrec + go (HsFunArr{}) = prec >= funPrec + go (XExpr x) = case ghcPass @p of + GhcTc -> go_x_tc x + GhcRn -> go_x_rn x + + go_x_tc :: XXExprGhcTc -> Bool + go_x_tc (WrapExpr _ e) = hsExprNeedsParens prec e + go_x_tc (ExpandedThingTc thing _) = hsExpandedNeedsParens thing + go_x_tc (ConLikeTc {}) = False + go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e + go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e + go_x_tc (HsRecSelTc{}) = False + + go_x_rn :: XXExprGhcRn -> Bool + go_x_rn (ExpandedThingRn thing _) = hsExpandedNeedsParens thing + go_x_rn (PopErrCtxt (L _ a)) = hsExprNeedsParens prec a + go_x_rn (HsRecSelRn{}) = False + + hsExpandedNeedsParens :: HsThingRn -> Bool + hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e + hsExpandedNeedsParens _ = False + +-- | Parenthesize an expression without token information +gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p) +gHsPar e = HsPar x e + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField + +-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, +-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. +parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr p le@(L loc e) + | hsExprNeedsParens p e = L loc (gHsPar le) + | otherwise = le + +stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e +stripParensLHsExpr e = e + +stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p) +stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e +stripParensHsExpr e = e + +isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool +-- True of a single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsOverLabel {}) = True +isAtomicHsExpr (HsHole{}) = True +isAtomicHsExpr (XExpr x) + | GhcTc <- ghcPass @p = go_x_tc x + | GhcRn <- ghcPass @p = go_x_rn x + where + go_x_tc :: XXExprGhcTc -> Bool + go_x_tc (WrapExpr _ e) = isAtomicHsExpr e + go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing + go_x_tc (ConLikeTc {}) = True + go_x_tc (HsTick {}) = False + go_x_tc (HsBinTick {}) = False + go_x_tc (HsRecSelTc{}) = True + + go_x_rn :: XXExprGhcRn -> Bool + go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing + go_x_rn (PopErrCtxt (L _ a)) = isAtomicHsExpr a + go_x_rn (HsRecSelRn{}) = True + + isAtomicExpandedThingRn :: HsThingRn -> Bool + isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e + isAtomicExpandedThingRn _ = False + +isAtomicHsExpr _ = False + +instance Outputable (HsPragE (GhcPass p)) where + ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) = + pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}" + + +{- ********************************************************************* +* * + XXExprGhcRn and rebindable syntax +* * +********************************************************************* -} + +{- Note [Rebindable syntax and XXExprGhcRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We implement rebindable syntax (RS) support by performing a desugaring +in the renamer. We transform GhcPs expressions and patterns affected by +RS into the appropriate desugared form, but **annotated with the original +expression/pattern**. + +Let us consider a piece of code like: + + {-# LANGUAGE RebindableSyntax #-} + ifThenElse :: Char -> () -> () -> () + ifThenElse _ _ _ = () + x = if 'a' then () else True + +The parsed AST for the RHS of x would look something like (slightly simplified): + + L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True)) + +Upon seeing such an AST with RS on, we could transform it into a +mere function call, as per the RS rules, equivalent to the +following function application: + + ifThenElse 'a' () True + +which doesn't typecheck. But GHC would report an error about +not being able to match the third argument's type (Bool) with the +expected type: (), in the expression _as desugared_, i.e in +the aforementioned function application. But the user never +wrote a function application! This would be pretty bad. + +To remedy this, instead of transforming the original HsIf +node into mere applications of 'ifThenElse', we keep the +original 'if' expression around too, using the TTG +XExpr extension point to allow GHC to construct an +'XXExprGhcRn' value that will keep track of the original +expression in its first field, and the desugared one in the +second field. The resulting renamed AST would look like: + + L locif (XExpr + (ExpandedThingRn + (HsIf (L loca 'a') + (L loctrue ()) + (L locfalse True) + ) + (App (L generatedSrcSpan + (App (L generatedSrcSpan + (App (L generatedSrcSpan (Var ifThenElse)) + (L loca 'a') + ) + ) + (L loctrue ()) + ) + ) + (L locfalse True) + ) + ) + ) + +When comes the time to typecheck the program, we end up calling +tcMonoExpr on the AST above. If this expression gives rise to +a type error, then it will appear in a context line and GHC +will pretty-print it using the 'Outputable (XXExprGhcRn a b)' +instance defined below, which *only prints the original +expression*. This is the gist of the idea, but is not quite +enough to recover the error messages that we had with the +SyntaxExpr-based, typechecking/desugaring-to-core time +implementation of rebindable syntax. The key idea is to decorate +some elements of the desugared expression so as to be able to +give them a special treatment when typechecking the desugared +expression, to print a different context line or skip one +altogether. + +Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in +TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we +entered generated code, i.e code fabricated by the compiler when rebinding some +syntax. If someone tries to push some error context line while that field is set +to True, the pushing won't actually happen and the context line is just dropped. +Once we 'setSrcSpan' a real span (for an expression that was in the original +source code), we set 'tcl_in_gen_code' back to False, indicating that we +"emerged from the generated code tunnel", and that the expressions we will be +processing are relevant to report in context lines again. + +You might wonder why TcLclEnv has both + tcl_loc :: RealSrcSpan + tcl_in_gen_code :: Bool +Could we not store a Maybe RealSrcSpan? The problem is that we still +generate constraints when processing generated code, and a CtLoc must +contain a RealSrcSpan -- otherwise, error messages might appear +without source locations. So tcl_loc keeps the RealSrcSpan of the last +location spotted that wasn't generated; it's as good as we're going to +get in generated code. Once we get to sub-trees that are not +generated, then we update the RealSrcSpan appropriately, and set the +tcl_in_gen_code Bool to False. + +--- + +An overview of the constructs that are desugared in this way is laid out in +Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr. + +A general recipe to follow this approach for new constructs could go as follows: + +- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your + construct, in HsExpr or related syntax data types. +- At renaming-time: + - take your original node of interest (HsIf above) + - rename its subexpressions/subpatterns (condition and true/false + branches above) + - construct the suitable "rebound"-and-renamed result (ifThenElse call + above), where the 'SrcSpan' attached to any _fabricated node_ (the + HsVar/HsApp nodes, above) is set to 'generatedSrcSpan' + - take both the original node and that rebound-and-renamed result and wrap + them into an expansion construct: + for expressions, XExpr (ExpandedThingRn ) + for patterns, XPat (HsPatExpanded ) + - At typechecking-time: + - remove any logic that was previously dealing with your rebindable + construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends. + - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we + typecheck the desugared expression while reporting the original one in + errors +-} + +{- Note [Overview of record dot syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the note that explains all the moving parts for record dot +syntax. + +The language extensions @OverloadedRecordDot@ and +@OverloadedRecordUpdate@ (providing "record dot syntax") are +implemented using the techniques of Note [Rebindable syntax and +XXExprGhcRn]. + +When OverloadedRecordDot is enabled: +- Field selection expressions + - e.g. foo.bar.baz + - Have abstract syntax HsGetField + - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions +- Field selector expressions e.g. (.x.y) + - Have abstract syntax HsProjection + - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions + +When OverloadedRecordUpdate is enabled: +- Record update expressions + - e.g. a{foo.bar=1, quux="corge", baz} + - Have abstract syntax RecordUpd + - With rupd_flds containting a Right + - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr) + - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions + - Note that this is true for all record updates even for those that do not involve '.' + +When OverloadedRecordDot is enabled and RebindableSyntax is not +enabled the name 'getField' is resolved to GHC.Records.getField. When +OverloadedRecordDot is enabled and RebindableSyntax is enabled the +name 'getField' is whatever in-scope name that is. + +When OverloadedRecordUpd is enabled and RebindableSyntax is not +enabled it is an error for now (temporary while we wait on native +setField support; see +https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When +OverloadedRecordUpd is enabled and RebindableSyntax is enabled the +names 'getField' and 'setField' are whatever in-scope names they are. +-} + + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ +-} + +type instance XCmdArrApp GhcPs = (IsUnicodeSyntax, EpaLocation) +type instance XCmdArrApp GhcRn = NoExtField +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm GhcPs = AnnList () +-- | fixity (filled in by the renamer), for forms that were converted from +-- OpApp's by the renamer +type instance XCmdArrForm GhcRn = Maybe Fixity +type instance XCmdArrForm GhcTc = Maybe Fixity + +type instance XCmdApp (GhcPass _) = NoExtField +type instance XCmdLam (GhcPass _) = NoExtField + +type instance XCmdPar GhcPs = (EpToken "(", EpToken ")") +type instance XCmdPar GhcRn = NoExtField +type instance XCmdPar GhcTc = NoExtField + +type instance XCmdCase GhcPs = EpAnnHsCase +type instance XCmdCase GhcRn = NoExtField +type instance XCmdCase GhcTc = NoExtField + +type instance XCmdLamCase (GhcPass _) = EpAnnLam + +type instance XCmdIf GhcPs = AnnsIf +type instance XCmdIf GhcRn = NoExtField +type instance XCmdIf GhcTc = NoExtField + +type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") +type instance XCmdLet GhcRn = NoExtField +type instance XCmdLet GhcTc = NoExtField + +type instance XCmdDo GhcPs = AnnList EpaLocation +type instance XCmdDo GhcRn = NoExtField +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = NoExtField + +type instance XXCmd GhcPs = DataConCantHappen +type instance XXCmd GhcRn = DataConCantHappen +type instance XXCmd GhcTc = HsWrap HsCmd + + -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res + +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxTable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious GHC.Rename.Expr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + +type instance XCmdTop GhcPs = NoExtField +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + + +type instance XXCmdTop (GhcPass _) = DataConCantHappen + +instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar {}) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp {}) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall p. (OutputableBndrId p + ) => HsCmd (GhcPass p) -> SDoc +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp _ c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map ppr args)) + where + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_cmd (HsCmdLam _ LamSingle matches) + = pprMatches matches +ppr_cmd (HsCmdLam _ lam_variant matches) + = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), text "of"], + nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdIf _ _ e ct ce) + = sep [hsep [text "if", nest 2 (ppr e), text "then"], + nest 4 (ppr ct), + text "else", + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {}))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet _ binds cmd) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr cmd)] + +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprArrowExpr stmts + +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm rn_fix (L _ op) ps_fix args) + | HsVar _ (L _ v) <- op + = ppr_cmd_infix v + | GhcTc <- ghcPass @p + , XExpr (ConLikeTc c _ _) <- op + = ppr_cmd_infix (conLikeName c) + | otherwise + = fall_through + where + fall_through = hang (text "(|" <+> ppr_expr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") + + ppr_cmd_infix :: OutputableBndr v => v -> SDoc + ppr_cmd_infix v + | [arg1, arg2] <- args + , case ghcPass @p of + GhcPs -> ps_fix == Infix + GhcRn -> isJust rn_fix || ps_fix == Infix + GhcTc -> isJust rn_fix || ps_fix == Infix + = hang (pprCmdArg (unLoc arg1)) + 4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)]) + | otherwise + = fall_through + +ppr_cmd (XCmd x) = case ghcPass @p of + GhcTc -> case x of + HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) + +pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg (HsCmdTop _ cmd) + = ppr_lcmd cmd + +instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where + ppr = pprCmdArg + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ +-} + +type instance XMG GhcPs b = Origin +type instance XMG GhcRn b = Origin -- See Note [Generated code and pattern-match checking] +type instance XMG GhcTc b = MatchGroupTc + +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + , mg_origin :: Origin -- Origin (Generated vs FromSource) + } deriving Data + +type instance XXMatchGroup (GhcPass _) b = DataConCantHappen + +type instance XCMatch (GhcPass _) b = NoExtField +type instance XXMatch (GhcPass _) b = DataConCantHappen + +instance (OutputableBndrId pr, Outputable body) + => Outputable (Match (GhcPass pr) body) where + ppr = pprMatch + +isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool +isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms + +-- | Is there only one RHS in this list of matches? +isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool +isSingletonMatchGroup matches + | [L _ match] <- matches + , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match + = True + | otherwise + = False + +matchGroupArity :: MatchGroup (GhcPass id) body -> Arity +-- This is called before type checking, when mg_arg_tys is not set +matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts] +matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1) + +hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] +hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats + +isInfixMatch :: Match (GhcPass p) body -> Bool +isInfixMatch match = case m_ctxt match of + FunRhs {mc_fixity = Infix} -> True + _ -> False + +-- We keep the type checker happy by providing EpAnnComments. They +-- can only be used if they follow a `where` keyword with no binds, +-- but in that case the comment is attached to the following parsed +-- item. So this can never be used in practice. +type instance XCGRHSs (GhcPass _) _ = EpAnnComments + +type instance XXGRHSs (GhcPass _) _ = DataConCantHappen + +data GrhsAnn + = GrhsAnn { + ga_vbar :: Maybe (EpToken "|"), + ga_sep :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->` + } deriving (Data) + +instance NoAnn GrhsAnn where + noAnn = GrhsAnn Nothing noAnn + +type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn + -- Location of matchSeparator + -- TODO:AZ does this belong on the GRHS, or GRHSs? + +type instance XXGRHS (GhcPass _) b = DataConCantHappen + +pprMatches :: (OutputableBndrId idR, Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprMatches MG { mg_alts = matches } + = vcat (map pprMatch (map unLoc (unLoc matches))) + -- Don't print the type; it's only a place-holder before typechecking + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndrId idR) + => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc +pprFunBind matches = pprMatches matches + +-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext +pprPatBind :: forall bndr p . (OutputableBndrId bndr, + OutputableBndrId p) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc +pprPatBind pat grhss + = sep [ppr pat, + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)] + +pprMatch :: (OutputableBndrId idR, Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatch (Match { m_pats = L _ pats, m_ctxt = ctxt, m_grhss = grhss }) + = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) + , nest 2 (pprGRHSs ctxt grhss) ] + where + -- lam_cases_result: we don't simply return (empty, pats) to avoid + -- introducing an additional `nest 2` via the empty herald + lam_cases_result = case pats of + [] -> (empty, []) + (p:ps) -> (pprParendLPat appPrec p, ps) + + (herald, other_pats) + = case ctxt of + FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} + | SrcStrict <- strictness + -> assert (null pats) -- A strict variable binding + (char '!'<>pprPrefixOcc fun, pats) + + | Prefix <- fixity + -> (pprPrefixOcc fun, pats) -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + | otherwise + -> case pats of + (p1:p2:rest) + | null rest -> (pp_infix, []) -- x &&& y = e + | otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e + where + pp_infix = pprParendLPat opPrec p1 + <+> pprInfixOcc fun + <+> pprParendLPat opPrec p2 + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) + + LamAlt LamSingle -> (char '\\', pats) + ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats) + LamAlt LamCases -> lam_cases_result + ArrowMatchCtxt (ArrowLamAlt LamCases) -> lam_cases_result + + ArrowMatchCtxt ProcExpr -> (text "proc", pats) + + _ -> case pats of + [] -> (empty, []) + [pat] -> (ppr pat, []) -- No parens around the single pat in a case + _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) + +pprGRHSs :: (OutputableBndrId idR, Outputable body) + => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs ctxt (GRHSs _ grhss binds) + = vcat (toList $ NE.map (pprGRHS ctxt . unLoc) grhss) + -- Print the "where" even if the contents of the binds is empty. Only + -- EmptyLocalBinds means no "where" keyword + $$ ppUnless (eqEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) + +pprGRHS :: (OutputableBndrId idR, Outputable body) + => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc +pprGRHS ctxt (GRHS _ [] body) + = pp_rhs ctxt body + +pprGRHS ctxt (GRHS _ guards body) + = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] + +pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) + +matchSeparator :: HsMatchContext fn -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = arrow +matchSeparator LamAlt{} = arrow +matchSeparator IfAlt = arrow +matchSeparator ArrowMatchCtxt{} = arrow +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern +matchSeparator PatSyn = text "<-" -- match checker trace +matchSeparator LazyPatCtx = panic "unused" +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" + +instance Outputable GrhsAnn where + ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +-- Extra fields available post typechecking for RecStmt. +data RecStmtTc = + RecStmtTc + { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). + } + + +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField + +type instance XBindStmt (GhcPass _) GhcPs b = EpUniToken "<-" "←" +type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn +type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc + +data XBindStmtRn = XBindStmtRn + { xbsrn_bindOp :: SyntaxExpr GhcRn + , xbsrn_failOp :: FailOperator GhcRn + } + +data XBindStmtTc = XBindStmtTc + { xbstc_bindOp :: SyntaxExpr GhcTc + , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S + , xbstc_failOp :: FailOperator GhcTc + } + +type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField +type instance XApplicativeStmt (GhcPass _) GhcTc = Type + +type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField +type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField +type instance XBodyStmt (GhcPass _) GhcTc b = Type + +type instance XLetStmt (GhcPass _) (GhcPass _) b = EpToken "let" + +type instance XParStmt (GhcPass _) GhcPs b = NoExtField +type instance XParStmt (GhcPass _) GhcRn b = NoExtField +type instance XParStmt (GhcPass _) GhcTc b = Type + +type instance XTransStmt (GhcPass _) GhcPs b = AnnTransStmt +type instance XTransStmt (GhcPass _) GhcRn b = NoExtField +type instance XTransStmt (GhcPass _) GhcTc b = Type + +type instance XRecStmt (GhcPass _) GhcPs b = AnnList (EpToken "rec") +type instance XRecStmt (GhcPass _) GhcRn b = NoExtField +type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc + +type instance XXStmtLR (GhcPass _) GhcPs b = DataConCantHappen +type instance XXStmtLR (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn +type instance XXStmtLR (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc + +data AnnTransStmt + = AnnTransStmt { + ats_then :: EpToken "then", + ats_group :: Maybe (EpToken "group"), + ats_by :: Maybe (EpToken "by"), + ats_using :: Maybe (EpToken "using") + } deriving Data + +instance NoAnn AnnTransStmt where + noAnn = AnnTransStmt noAnn noAnn noAnn noAnn + + +-- | 'ApplicativeStmt' represents an applicative expression built with +-- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the +-- appropriate applicative expression by the desugarer, but it is intended +-- to be invisible in error messages. +-- +-- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr" +-- +data ApplicativeStmt idL idR + = ApplicativeStmt + (XApplicativeStmt idL idR) -- Post typecheck, Type of the body + [ ( SyntaxExpr idR + , ApplicativeArg idL) ] + -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] + (Maybe (SyntaxExpr idR)) -- 'join', if necessary + +-- | Applicative Argument +data ApplicativeArg idL + = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) + { xarg_app_arg_one :: XApplicativeArgOne idL + -- ^ The fail operator, after renaming + -- + -- The fail operator is needed if this is a BindStmt + -- where the pattern can fail. E.g.: + -- (Just a) <- stmt + -- The fail operator will be invoked if the pattern + -- match fails. + -- It is also used for guards in MonadComprehensions. + -- The fail operator is Nothing + -- if the pattern match can't fail + , app_arg_pattern :: LPat idL -- WildPat if it was a BodyStmt (see below) + , arg_expr :: LHsExpr idL + , is_body_stmt :: Bool + -- ^ True <=> was a BodyStmt, + -- False <=> was a BindStmt. + -- See Note [Applicative BodyStmt] + } + | ApplicativeArgMany -- do { stmts; return vars } + { xarg_app_arg_many :: XApplicativeArgMany idL + , app_stmts :: [ExprLStmt idL] -- stmts + , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn) + , bv_pattern :: LPat idL -- (v1,...,vn) + , stmt_context :: HsDoFlavour + -- ^ context of the do expression, used in pprArg + } + | XApplicativeArg !(XXApplicativeArg idL) + +type family XApplicativeStmt x x' + +-- ApplicativeArg type families +type family XApplicativeArgOne x +type family XApplicativeArgMany x +type family XXApplicativeArg x + +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtField +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen + +type instance XApplicativeArgOne GhcPs = NoExtField +type instance XApplicativeArgOne GhcRn = FailOperator GhcRn +type instance XApplicativeArgOne GhcTc = FailOperator GhcTc + +type instance XApplicativeArgMany (GhcPass _) = NoExtField +type instance XXApplicativeArg (GhcPass _) = DataConCantHappen + +instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))), + Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR))) + => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + +instance (OutputableBndrId pl, OutputableBndrId pr, + Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA, + Outputable body) + => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where + ppr stmt = pprStmt stmt + +pprStmt :: forall idL idR body . (OutputableBndrId idL, + OutputableBndrId idR, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, + Outputable body) + => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc +pprStmt (LastStmt _ expr m_dollar_stripped _) + = whenPprDebug (text "[last]") <+> + (case m_dollar_stripped of + Just True -> text "return $" + Just False -> text "return" + Nothing -> empty) <+> + ppr expr +pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr +pprStmt (LetStmt _ binds) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr $ toList stmtss)) + +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by + , trS_using = using, trS_form = form }) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) + = text "rec" <+> + vcat [ ppr_do_stmts (unLoc segment) + , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , text "later_ids=" <> ppr later_ids])] + +pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of + GhcRn -> pprApplicativeStmt x + GhcTc -> pprApplicativeStmt x + + where + pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc + pprApplicativeStmt (ApplicativeStmt _ args mb_join) = + getPprStyle $ \style -> + if userStyle style + then pp_for_user + else pp_debug + where + -- make all the Applicative stuff invisible in error messages by + -- flattening the whole ApplicativeStmt nest back to a sequence + -- of statements. + pp_for_user = vcat $ concatMap flattenArg args + + -- ppr directly rather than transforming here, because we need to + -- inject a "return" which is hard when we're polymorphic in the id + -- type. + flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] + flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of + GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args + GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args + flattenStmt stmt = [ppr stmt] + + flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc] + flattenArg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = [ppr expr] -- See Note [Applicative BodyStmt] + | otherwise = [pprBindStmt pat expr] + flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = + concatMap flattenStmt stmts + + pp_debug = + let + ap_expr = sep (punctuate (text " |") (map pp_arg args)) + in + whenPprDebug (if isJust mb_join then text "[join]" else empty) <+> + (if lengthAtLeast args 2 then parens else id) ap_expr + + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc + pp_arg (_, applicativeArg) = ppr applicativeArg + +pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc +pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr] + +instance (OutputableBndrId idL) + => Outputable (ApplicativeArg (GhcPass idL)) where + ppr = pprArg + +pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc +pprArg (ApplicativeArgOne _ pat expr isBody) + | isBody = ppr expr -- See Note [Applicative BodyStmt] + | otherwise = pprBindStmt pat expr +pprArg (ApplicativeArgMany _ stmts return pat ctxt) = + ppr pat <+> + text "<-" <+> + pprDo ctxt (stmts ++ + [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)]) + +pprTransformStmt :: (OutputableBndrId p) + => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) + -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt bndrs using by + = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] + +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc +pprTransStmt by using ThenForm + = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by using GroupForm + = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)] + +pprBy :: Outputable body => Maybe body -> SDoc +pprBy Nothing = empty +pprBy (Just e) = text "by" <+> ppr e + +pprDo :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA + ) + => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc +pprDo (DoExpr m) stmts = + ppr_module_name_prefix m <> text "do" <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts +pprDo (MDoExpr m) stmts = + ppr_module_name_prefix m <> text "mdo" <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts + +pprArrowExpr :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA + ) + => [LStmt (GhcPass p) body] -> SDoc +pprArrowExpr stmts = text "do" <+> ppr_do_stmts stmts + +ppr_module_name_prefix :: Maybe ModuleName -> SDoc +ppr_module_name_prefix = \case + Nothing -> empty + Just module_name -> ppr module_name <> char '.' + +ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, + Outputable body) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +-- Print a bunch of do stmts +ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) + +pprComp :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) + => [LStmt (GhcPass p) body] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals + = if null initStmts + -- If there are no statements in a list comprehension besides the last + -- one, we simply treat it like a normal list. This does arise + -- occasionally in code that GHC generates, e.g., in implementations of + -- 'range' for derived 'Ix' instances for product datatypes with exactly + -- one constructor (e.g., see #12583). + then ppr body + else hang (ppr body <+> vbar) 2 (pprQuals initStmts) + | otherwise + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: (OutputableBndrId p, Outputable body, + Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) + => [LStmt (GhcPass p) body] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how +-- this is used. +-- +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] + +-- A Data instance which ignores the argument of 'ThModFinalizers'. +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] + +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. +-- This is the result of splicing a splice. It is produced by +-- the renamer and consumed by the typechecker. It lives only between the two. +data HsUntypedSpliceResult thing -- 'thing' can be HsExpr or HsType + = HsUntypedSpliceTop + { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice. + , utsplice_result :: thing -- ^ The result of splicing; See Note [Lifecycle of a splice] + } + | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point + +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +-- for an explanation of the Template Haskell extension points. +data HsTypedSpliceResult + = HsTypedSpliceTop + | HsTypedSpliceNested SplicePointName + +type instance XTypedSplice GhcPs = NoExtField +type instance XTypedSplice GhcRn = HsTypedSpliceResult +type instance XTypedSplice GhcTc = DelayedSplice + +type instance XUntypedSplice GhcPs = NoExtField +type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn) +type instance XUntypedSplice GhcTc = DataConCantHappen + +-- HsUntypedSplice +type instance XUntypedSpliceExpr GhcPs = EpToken "$" +type instance XUntypedSpliceExpr GhcRn = HsUserSpliceExt +type instance XUntypedSpliceExpr GhcTc = DataConCantHappen + +type instance XTypedSpliceExpr GhcPs = EpToken "$$" +type instance XTypedSpliceExpr GhcRn = NoExtField +type instance XTypedSpliceExpr GhcTc = NoExtField + +type instance XQuasiQuote GhcPs = NoExtField +type instance XQuasiQuote GhcRn = HsQuasiQuoteExt +type instance XQuasiQuote GhcTc = DataConCantHappen + + +type instance XXUntypedSplice GhcPs = DataConCantHappen +type instance XXUntypedSplice GhcRn = HsImplicitLiftSplice +type instance XXUntypedSplice GhcTc = DataConCantHappen + +type instance XXTypedSplice GhcPs = DataConCantHappen +type instance XXTypedSplice GhcRn = HsImplicitLiftSplice +type instance XXTypedSplice GhcTc = DataConCantHappen + +-- See Note [Running typed splices in the zonker] +-- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice` +data DelayedSplice = + DelayedSplice + TcLclEnv -- The local environment to run the splice in + (LHsExpr GhcRn) -- The original renamed expression + TcType -- The result type of running the splice, unzonked + (LHsExpr GhcTc) -- The typechecked expression to run and splice in the result + +-- A Data instance which ignores the argument of 'DelayedSplice'. +instance Data DelayedSplice where + gunfold _ _ _ = panic "DelayedSplice" + toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] + +-- See Note [Pending Splices] +type SplicePointName = Name + +data UntypedSpliceFlavour + = UntypedExpSplice + | UntypedPatSplice + | UntypedTypeSplice + | UntypedDeclSplice + deriving Data + + +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +-- A 'PendingRnSplice' is lifted from an untyped quotation and then typechecked. +data PendingRnSplice = PendingRnSplice SplicePointName (HsUntypedSplice GhcRn) + +instance Outputable PendingRnSplice where + ppr (PendingRnSplice sp expr) = + angleBrackets (ppr sp <> comma <+> pprUntypedSplice False Nothing expr) + +-- | Pending Type-checker Splice +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data PendingTcSplice + = PendingTcSplice SplicePointName (LHsExpr GhcTc) + +-- | Information about an implicit lift, discovered by the renamer +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data HsImplicitLiftSplice = + HsImplicitLiftSplice + { implicit_lift_bind_lvl :: S.Set ThLevelIndex + , implicit_lift_used_lvl :: ThLevelIndex + , implicit_lift_gre :: Maybe GlobalRdrElt + , implicit_lift_lid :: LIdOccP GhcRn + } + +-- | Information about a user-written splice, discovered by the renamer +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data HsUserSpliceExt = + HsUserSpliceExt + { user_splice_flavour :: UntypedSpliceFlavour + } + +-- | Information about a quasi-quoter, discovered by the renamer +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +data HsQuasiQuoteExt = + HsQuasiQuoteExt + { quasi_quote_flavour :: UntypedSpliceFlavour + } + + +pprTypedSplice :: forall p . (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc +pprTypedSplice n (HsTypedSpliceExpr _ e) = ppr_splice (text "$$") n e +pprTypedSplice n (XTypedSplice p) = + case ghcPass @p of + GhcRn -> case p of + HsImplicitLiftSplice _ _ _ lid -> ppr lid <+> whenPprDebug (maybe empty (brackets . ppr) n) + +pprUntypedSplice :: forall p. (OutputableBndrId p) + => Bool -- Whether to precede the splice with "$" + -> Maybe SplicePointName -- Used for pretty printing when exists + -> HsUntypedSplice (GhcPass p) + -> SDoc +pprUntypedSplice True n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e +pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e +pprUntypedSplice _ _ (HsQuasiQuote _ q s) = ppr_quasi (unLoc q) (unLoc s) +pprUntypedSplice _ _ (XUntypedSplice x) = + case ghcPass @p of + GhcRn -> case x of + HsImplicitLiftSplice _ _ _ lid -> ppr lid + +ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc +ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <> + ppr quote <> text "|]" + +ppr_splice :: (OutputableBndrId p) + => SDoc + -> Maybe SplicePointName + -> LHsExpr (GhcPass p) + -> SDoc +ppr_splice herald mn e + = herald + <> (case mn of + Nothing -> empty + Just splice_name -> whenPprDebug (brackets (ppr splice_name))) + <> ppr e + + +type instance XExpBr GhcPs = (BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|"), EpUniToken "|]" "⟧") +type instance XPatBr GhcPs = (EpToken "[p|", EpUniToken "|]" "⟧") +type instance XDecBrL GhcPs = (EpToken "[d|", EpUniToken "|]" "⟧", (EpToken "{", EpToken "}")) +type instance XDecBrG GhcPs = NoExtField +type instance XTypBr GhcPs = (EpToken "[t|", EpUniToken "|]" "⟧") +type instance XVarBr GhcPs = EpaLocation +type instance XXQuote GhcPs = DataConCantHappen + +type instance XExpBr GhcRn = NoExtField +type instance XPatBr GhcRn = NoExtField +type instance XDecBrL GhcRn = NoExtField +type instance XDecBrG GhcRn = NoExtField +type instance XTypBr GhcRn = NoExtField +type instance XVarBr GhcRn = NoExtField +type instance XXQuote GhcRn = DataConCantHappen + +-- See Note [The life cycle of a TH quotation] +type instance XExpBr GhcTc = DataConCantHappen +type instance XPatBr GhcTc = DataConCantHappen +type instance XDecBrL GhcTc = DataConCantHappen +type instance XDecBrG GhcTc = DataConCantHappen +type instance XTypBr GhcTc = DataConCantHappen +type instance XVarBr GhcTc = DataConCantHappen +type instance XXQuote GhcTc = NoExtField + +instance OutputableBndrId p + => Outputable (HsQuote (GhcPass p)) where + ppr = pprHsQuote + where + pprHsQuote :: forall p. (OutputableBndrId p) + => HsQuote (GhcPass p) -> SDoc + pprHsQuote (ExpBr _ e) = thBrackets empty (ppr e) + pprHsQuote (PatBr _ p) = thBrackets (char 'p') (ppr p) + pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) + pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) + pprHsQuote (TypBr _ t) = thBrackets (char 't') (ppr t) + pprHsQuote (VarBr _ True n) + = char '\'' <> pprPrefixOcc (unLoc n) + pprHsQuote (VarBr _ False n) + = text "''" <> pprPrefixOcc (unLoc n) + pprHsQuote (XQuote b) = case ghcPass @p of + GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b) + -- See Note [The life cycle of a TH quotation] + +thBrackets :: SDoc -> SDoc -> SDoc +thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> + pp_body <+> text "|]" + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]" + +instance Outputable PendingTcSplice where + ppr (PendingTcSplice n e) = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e)) + +ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc +ppr_with_pending_tc_splices x [] = x +ppr_with_pending_tc_splices x ps = x $$ whenPprDebug (text "pending(tc)" <+> ppr ps) + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +instance OutputableBndrId p + => Outputable (ArithSeqInfo (GhcPass p)) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot :: SDoc +pp_dotdot = text " .. " + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +type HsMatchContextPs = HsMatchContext (LIdP GhcPs) +type HsMatchContextRn = HsMatchContext (LIdP GhcRn) + +type HsStmtContextRn = HsStmtContext (LIdP GhcRn) + +instance Outputable fn => Outputable (HsMatchContext fn) where + ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) + ppr CaseAlt = text "CaseAlt" + ppr (LamAlt lam_variant) = text "LamAlt" <+> ppr lam_variant + ppr IfAlt = text "IfAlt" + ppr (ArrowMatchCtxt c) = text "ArrowMatchCtxt" <+> ppr c + ppr PatBindRhs = text "PatBindRhs" + ppr PatBindGuards = text "PatBindGuards" + ppr RecUpd = text "RecUpd" + ppr (StmtCtxt _) = text "StmtCtxt _" + ppr ThPatSplice = text "ThPatSplice" + ppr ThPatQuote = text "ThPatQuote" + ppr PatSyn = text "PatSyn" + ppr LazyPatCtx = text "LazyPatCtx" + +instance Outputable HsLamVariant where + ppr = text . \case + LamSingle -> "LamSingle" + LamCase -> "LamCase" + LamCases -> "LamCases" + +lamCaseKeyword :: HsLamVariant -> SDoc +lamCaseKeyword LamSingle = text "lambda" +lamCaseKeyword LamCase = text "\\case" +lamCaseKeyword LamCases = text "\\cases" + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + +instance Outputable HsArrowMatchContext where + ppr ProcExpr = text "ProcExpr" + ppr ArrowCaseAlt = text "ArrowCaseAlt" + ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant + +pprHsArrType :: HsArrAppType -> SDoc +pprHsArrType HsHigherOrderApp = text "higher order arrow application" +pprHsArrType HsFirstOrderApp = text "first order arrow application" + +----------------- + +instance Outputable fn => Outputable (HsStmtContext fn) where + ppr = pprStmtContext + +-- Used to generate the string for a *runtime* error message +matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc +matchContextErrString (FunRhs{mc_fun=fun}) = text "function" <+> ppr fun +matchContextErrString CaseAlt = text "case" +matchContextErrString (LamAlt lam_variant) = lamCaseKeyword lam_variant +matchContextErrString IfAlt = text "multi-way if" +matchContextErrString PatBindRhs = text "pattern binding" +matchContextErrString PatBindGuards = text "pattern binding guards" +matchContextErrString RecUpd = text "record update" +matchContextErrString (ArrowMatchCtxt c) = matchArrowContextErrString c +matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = text "pattern synonym" +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" +matchContextErrString (StmtCtxt (ArrowExpr)) = text "'do' block" +matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour +matchContextErrString LazyPatCtx = text "irrefutable pattern" + +matchArrowContextErrString :: HsArrowMatchContext -> SDoc +matchArrowContextErrString ProcExpr = text "proc" +matchArrowContextErrString ArrowCaseAlt = text "case" +matchArrowContextErrString (ArrowLamAlt LamSingle) = text "kappa" +matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant + +matchDoContextErrString :: HsDoFlavour -> SDoc +matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command" +matchDoContextErrString (DoExpr m) = prependQualified m (text "'do' block") +matchDoContextErrString (MDoExpr m) = prependQualified m (text "'mdo' block") +matchDoContextErrString ListComp = text "list comprehension" +matchDoContextErrString MonadComp = text "monad comprehension" + +pprMatchInCtxt :: (OutputableBndrId idR, Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) + <> colon) + 4 (pprMatch match) + +pprStmtInCtxt :: (OutputableBndrId idL, + OutputableBndrId idR, + Outputable fn, + Outputable body, + Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) + => HsStmtContext fn + -> StmtLR (GhcPass idL) (GhcPass idR) body + -> SDoc +pprStmtInCtxt ctxt (LastStmt _ e _ _) + | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (text "In the expression:") 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt + + +pprMatchContext :: Outputable p => HsMatchContext p -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an (ArrowMatchCtxt ProcExpr) = True + want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True + want_an LazyPatCtx = True + want_an _ = False + +pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun (LamAlt LamSingle) = text "lambda abstraction" +pprMatchContextNoun (LamAlt lam_variant) = lamCaseKeyword lam_variant + <+> text "alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record update" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" +pprMatchContextNoun LazyPatCtx = text "irrefutable pattern" + +pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc +pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" <+> quotes (ppr fun) +pprMatchContextNouns PatBindGuards = text "pattern binding guards" +pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c +pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" + $$ pprAStmtContext ctxt +pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's' + +pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern" +pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation" +pprArrowMatchContextNoun (ArrowLamAlt LamSingle) = text "arrow kappa abstraction" +pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant + <+> text "alternative within arrow notation" + +pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation" +pprArrowMatchContextNouns (ArrowLamAlt LamSingle) = text "arrow kappa abstractions" +pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant + <+> text "alternatives within arrow notation" +pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' + +----------------- +pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc +pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour +pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt + +----------------- +pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt +pprStmtContext ArrowExpr = text "'do' block in an arrow command" + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +pprStmtCat :: forall p body . IsPass p => Stmt (GhcPass p) body -> SDoc +pprStmtCat (TransStmt {}) = text "transform" +pprStmtCat (LastStmt {}) = text "return expression" +pprStmtCat (BodyStmt {}) = text "body" +pprStmtCat (BindStmt {}) = text "binding" +pprStmtCat (LetStmt {}) = text "let" +pprStmtCat (RecStmt {}) = text "rec" +pprStmtCat (ParStmt {}) = text "parallel" +pprStmtCat (XStmtLR _) = text "applicative" + +pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc +pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour + where + pp_an = text "an" + pp_a = text "a" + article = case flavour of + MDoExpr Nothing -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a +pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block") +pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block") +pprHsDoFlavour ListComp = text "list comprehension" +pprHsDoFlavour MonadComp = text "monad comprehension" +pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command" + +prependQualified :: Maybe ModuleName -> SDoc -> SDoc +prependQualified Nothing t = t +prependQualified (Just _) t = text "qualified" <+> t + +{- +************************************************************************ +* * +FieldLabelStrings +* * +************************************************************************ +-} + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where + ppr (FieldLabelStrings flds) = + hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds)) + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where + pprInfixOcc = pprFieldLabelStrings + pprPrefixOcc = pprFieldLabelStrings + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprInfixOcc . unLoc + +pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc +pprFieldLabelStrings (FieldLabelStrings flds) = + hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds)) + +pprPrefixFastString :: FastString -> SDoc +pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs) + +instance UnXRec p => Outputable (DotFieldOcc p) where + ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s + ppr XDotFieldOcc{} = text "XDotFieldOcc" + +{- +************************************************************************ +* * +\subsection{Anno instances} +* * +************************************************************************ +-} + +type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA +type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnC +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW + +type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA + +type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnLW +type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnLW +type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA +type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA +type instance Anno [LocatedA (Pat (GhcPass p))] = EpaLocation +type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO +type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = EpAnnCO +type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA + +type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA + +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW + +type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO +type instance Anno FieldLabelString = SrcSpanAnnN + +type instance Anno FastString = EpAnnCO + -- Used in HsQuasiQuote and perhaps elsewhere + +type instance Anno (DotFieldOcc (GhcPass p)) = EpAnnCO + +instance (HasAnnotation (Anno a)) => WrapXRec (GhcPass p) a where wrapXRec = noLocA diff --git a/GHC/Hs/Expr.hs-boot b/GHC/Hs/Expr.hs-boot --- a/GHC/Hs/Expr.hs-boot +++ b/GHC/Hs/Expr.hs-boot @@ -18,6 +18,7 @@ , MatchGroup , GRHSs , HsUntypedSplice + , HsTypedSplice ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) import GHC.Types.Name ( Name ) @@ -33,7 +34,7 @@ pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc pprUntypedSplice :: (OutputableBndrId p) => Bool -> Maybe SplicePointName -> HsUntypedSplice (GhcPass p) -> SDoc pprPatBind :: forall bndr p . (OutputableBndrId bndr, diff --git a/GHC/Hs/Extension.hs b/GHC/Hs/Extension.hs --- a/GHC/Hs/Extension.hs +++ b/GHC/Hs/Extension.hs @@ -25,10 +25,7 @@ import GHC.Prelude -import GHC.TypeLits (KnownSymbol, symbolVal) - import Data.Data hiding ( Fixity ) -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader @@ -101,13 +98,21 @@ -} -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation -type instance XRec (GhcPass p) a = GenLocated (Anno a) a +type instance XRec (GhcPass p) a = XRecGhc a +-- (XRecGhc tree) wraps `tree` in a GHC-specific, +-- but pass-independent, source location +type XRecGhc a = GenLocated (Anno a) a + type instance Anno RdrName = SrcSpanAnnN type instance Anno Name = SrcSpanAnnN type instance Anno Id = SrcSpanAnnN -type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), +type instance Anno (WithUserRdr a) = Anno a + +type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a, + Anno (IdOccGhcP p) ~ EpAnn a, + NoAnn a, IsPass p) instance UnXRec (GhcPass p) where @@ -174,11 +179,15 @@ -- | Allows us to check what phase we're in at GHC's runtime. -- For example, this class allows us to write --- > f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah --- > f e = case ghcPass @p of --- > GhcPs -> ... in this RHS we have HsExpr GhcPs... --- > GhcRn -> ... in this RHS we have HsExpr GhcRn... --- > GhcTc -> ... in this RHS we have HsExpr GhcTc... +-- +-- @ +-- f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah +-- f e = case ghcPass @p of +-- GhcPs -> ... in this RHS we have HsExpr GhcPs... +-- GhcRn -> ... in this RHS we have HsExpr GhcRn... +-- GhcTc -> ... in this RHS we have HsExpr GhcTc... +-- @ +-- -- which is very useful, for example, when pretty-printing. -- See Note [IsPass]. class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p @@ -201,6 +210,16 @@ IdGhcP 'Renamed = Name IdGhcP 'Typechecked = Id +type LIdGhcP p = XRecGhc (IdGhcP p) + +type instance IdOccP (GhcPass p) = IdOccGhcP p + +type family IdOccGhcP pass where + IdOccGhcP 'Parsed = RdrName + IdOccGhcP 'Renamed = WithUserRdr Name + IdOccGhcP 'Typechecked = Id +type LIdOccGhcP p = XRecGhc (IdOccGhcP p) + -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur. @@ -217,9 +236,13 @@ -- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass = ( OutputableBndr (IdGhcP pass) + , OutputableBndr (IdOccGhcP pass) , OutputableBndr (IdGhcP (NoGhcTcPass pass)) - , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass)) - , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass))) + , OutputableBndr (IdOccGhcP (NoGhcTcPass pass)) + , Outputable (LIdGhcP pass) + , Outputable (LIdOccGhcP pass) + , Outputable (LIdGhcP (NoGhcTcPass pass)) + , Outputable (LIdOccGhcP (NoGhcTcPass pass)) , IsPass pass ) @@ -236,16 +259,6 @@ pprIfTc pp = case ghcPass @p of GhcTc -> pp _ -> empty -type instance Anno (HsToken tok) = TokenLocation - -noHsTok :: GenLocated TokenLocation (HsToken tok) -noHsTok = L NoTokenLoc HsTok - -type instance Anno (HsUniToken tok utok) = TokenLocation - -noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) -noHsUniTok = L NoTokenLoc HsNormalTok - --- Outputable instance Outputable NoExtField where @@ -253,12 +266,3 @@ instance Outputable DataConCantHappen where ppr = dataConCantHappen - -instance KnownSymbol tok => Outputable (HsToken tok) where - ppr _ = text (symbolVal (Proxy :: Proxy tok)) - -instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where - ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok)) - ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok)) - -deriving instance Typeable p => Data (LayoutInfo (GhcPass p)) diff --git a/GHC/Hs/ImpExp.hs b/GHC/Hs/ImpExp.hs --- a/GHC/Hs/ImpExp.hs +++ b/GHC/Hs/ImpExp.hs @@ -8,6 +8,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension +{-# LANGUAGE MultiWayIf #-} + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -38,10 +40,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Unit.Module.Warnings (WarningTxt) +import GHC.Unit.Module.Warnings import Data.Data import Data.Maybe +import GHC.Hs.Doc (LHsDoc) {- @@ -56,16 +59,8 @@ type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA --- | Given two possible located 'qualified' tokens, compute a style --- (in a conforming Haskell program only one of the two can be not --- 'Nothing'). This is called from "GHC.Parser". -importDeclQualifiedStyle :: Maybe EpaLocation - -> Maybe EpaLocation - -> (Maybe EpaLocation, ImportDeclQualifiedStyle) -importDeclQualifiedStyle mPre mPost = - if isJust mPre then (mPre, QualifiedPre) - else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified) + -- | Convenience function to answer the question if an import decl. is -- qualified. isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool @@ -73,6 +68,7 @@ isImportDeclQualified _ = True + type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual @@ -80,11 +76,10 @@ type instance XCImportDecl GhcPs = XImportDeclPass type instance XCImportDecl GhcRn = XImportDeclPass type instance XCImportDecl GhcTc = DataConCantHappen - -- Note [Pragma source text] in "GHC.Types.SourceText" data XImportDeclPass = XImportDeclPass { ideclAnn :: EpAnn EpAnnImportDecl - , ideclSourceText :: SourceText + , ideclSourceText :: SourceText -- Note [Pragma source text] in "GHC.Types.SourceText" , ideclImplicit :: Bool -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude` -- that appears in any file that omits `import Prelude`, setting @@ -96,7 +91,7 @@ type instance XXImportDecl (GhcPass _) = DataConCantHappen type instance Anno ModuleName = SrcSpanAnnA -type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL +type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI deriving instance Data (IEWrappedName GhcPs) deriving instance Data (IEWrappedName GhcRn) @@ -111,14 +106,27 @@ -- API Annotations types data EpAnnImportDecl = EpAnnImportDecl - { importDeclAnnImport :: EpaLocation - , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation) - , importDeclAnnSafe :: Maybe EpaLocation - , importDeclAnnQualified :: Maybe EpaLocation - , importDeclAnnPackage :: Maybe EpaLocation - , importDeclAnnAs :: Maybe EpaLocation + { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword + , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively + , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword + , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword + , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword + , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) + , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword } deriving (Data) + +instance NoAnn EpAnnImportDecl where + noAnn = EpAnnImportDecl noAnn Nothing Nothing noAnn Nothing Nothing Nothing + +data EpAnnLevel = EpAnnLevelSplice (EpToken "splice") + | EpAnnLevelQuote (EpToken "quote") + deriving Data + +instance HasLoc EpAnnLevel where + getHasLoc (EpAnnLevelSplice tok) = getEpTokenSrcSpan tok + getHasLoc (EpAnnLevelQuote tok) = getEpTokenSrcSpan tok + -- --------------------------------------------------------------------- simpleImportDecl :: ModuleName -> ImportDecl GhcPs @@ -128,6 +136,7 @@ ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, + ideclLevelSpec = NotLevelled, ideclQualified = NotQualified, ideclAs = Nothing, ideclImportList = Nothing @@ -192,8 +201,10 @@ -} type instance XIEName (GhcPass _) = NoExtField -type instance XIEPattern (GhcPass _) = EpaLocation -type instance XIEType (GhcPass _) = EpaLocation +type instance XIEDefault (GhcPass _) = EpToken "default" +type instance XIEPattern (GhcPass _) = EpToken "pattern" +type instance XIEType (GhcPass _) = EpToken "type" +type instance XIEData (GhcPass _) = EpToken "data" type instance XXIEWrappedName (GhcPass _) = DataConCantHappen type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA @@ -203,36 +214,38 @@ -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEVar GhcPs = Maybe (LocatedP (WarningTxt GhcPs)) -type instance XIEVar GhcRn = Maybe (LocatedP (WarningTxt GhcRn)) +type instance XIEVar GhcPs = Maybe (LWarningTxt GhcPs) +type instance XIEVar GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEVar GhcTc = NoExtField -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEThingAbs GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn]) -type instance XIEThingAbs GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn]) -type instance XIEThingAbs GhcTc = EpAnn [AddEpAnn] +type instance XIEThingAbs GhcPs = Maybe (LWarningTxt GhcPs) +type instance XIEThingAbs GhcRn = Maybe (LWarningTxt GhcRn) +type instance XIEThingAbs GhcTc = () -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEThingAll GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn]) -type instance XIEThingAll GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn]) -type instance XIEThingAll GhcTc = EpAnn [AddEpAnn] +type instance XIEThingAll GhcPs = (Maybe (LWarningTxt GhcPs), (EpToken "(", EpToken "..", EpToken ")")) +type instance XIEThingAll GhcRn = (Maybe (LWarningTxt GhcRn), (EpToken "(", EpToken "..", EpToken ")")) +type instance XIEThingAll GhcTc = (EpToken "(", EpToken "..", EpToken ")") -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEThingWith GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn]) -type instance XIEThingWith GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn]) -type instance XIEThingWith GhcTc = EpAnn [AddEpAnn] +type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), IEThingWithAnns) +type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), IEThingWithAnns) +type instance XIEThingWith GhcTc = IEThingWithAnns +type IEThingWithAnns = (EpToken "(", EpToken "..", EpToken ",", EpToken ")") + -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports) -type instance XIEModuleContents GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn]) -type instance XIEModuleContents GhcRn = Maybe (LocatedP (WarningTxt GhcRn)) +type instance XIEModuleContents GhcPs = (Maybe (LWarningTxt GhcPs), EpToken "module") +type instance XIEModuleContents GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEModuleContents GhcTc = NoExtField type instance XIEGroup (GhcPass _) = NoExtField @@ -242,20 +255,21 @@ type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA +ieLIEWrappedName :: IE (GhcPass p) -> LIEWrappedName (GhcPass p) +ieLIEWrappedName (IEVar _ n _) = n +ieLIEWrappedName (IEThingAbs _ n _) = n +ieLIEWrappedName (IEThingWith _ n _ _ _) = n +ieLIEWrappedName (IEThingAll _ n _) = n +ieLIEWrappedName _ = panic "ieLIEWrappedName failed pattern match!" + ieName :: IE (GhcPass p) -> IdP (GhcPass p) -ieName (IEVar _ (L _ n)) = ieWrappedName n -ieName (IEThingAbs _ (L _ n)) = ieWrappedName n -ieName (IEThingWith _ (L _ n) _ _) = ieWrappedName n -ieName (IEThingAll _ (L _ n)) = ieWrappedName n -ieName _ = panic "ieName failed pattern match!" +ieName = lieWrappedName . ieLIEWrappedName ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] -ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n - : map (ieWrappedName . unLoc) ns --- NB the above case does not include names of field selectors +ieNames (IEVar _ (L _ n) _) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) _) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) _) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns ieNames (IEModuleContents {}) = [] ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] @@ -264,23 +278,25 @@ ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p)) ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p) where - ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LocatedP (WarningTxt (GhcPass p))) - ie_deprecation GhcPs (IEVar xie _) = xie - ie_deprecation GhcPs (IEThingAbs (xie, _) _) = xie - ie_deprecation GhcPs (IEThingAll (xie, _) _) = xie - ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _) = xie + ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p)) + ie_deprecation GhcPs (IEVar xie _ _) = xie + ie_deprecation GhcPs (IEThingAbs xie _ _) = xie + ie_deprecation GhcPs (IEThingAll (xie, _) _ _) = xie + ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _ _) = xie ie_deprecation GhcPs (IEModuleContents (xie, _) _) = xie - ie_deprecation GhcRn (IEVar xie _) = xie - ie_deprecation GhcRn (IEThingAbs (xie, _) _) = xie - ie_deprecation GhcRn (IEThingAll (xie, _) _) = xie - ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _) = xie + ie_deprecation GhcRn (IEVar xie _ _) = xie + ie_deprecation GhcRn (IEThingAbs xie _ _) = xie + ie_deprecation GhcRn (IEThingAll (xie, _) _ _) = xie + ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _ _) = xie ie_deprecation GhcRn (IEModuleContents xie _) = xie ie_deprecation _ _ = Nothing ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p) +ieWrappedLName (IEDefault _ (L l n)) = L l n ieWrappedLName (IEName _ (L l n)) = L l n ieWrappedLName (IEPattern _ (L l n)) = L l n ieWrappedLName (IEType _ (L l n)) = L l n +ieWrappedLName (IEData _ (L l n)) = L l n ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) ieWrappedName = unLoc . ieWrappedLName @@ -293,19 +309,40 @@ ieLWrappedName (L _ n) = ieWrappedLName n replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn +replaceWrappedName (IEDefault r (L l _)) n = IEDefault r (L l n) replaceWrappedName (IEName x (L l _)) n = IEName x (L l n) replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) replaceWrappedName (IEType r (L l _)) n = IEType r (L l n) +replaceWrappedName (IEData r (L l _)) n = IEData r (L l n) replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') +exportDocstring :: LHsDoc pass -> SDoc +exportDocstring doc = braces (text "docstring: " <> ppr doc) + instance OutputableBndrId p => Outputable (IE (GhcPass p)) where - ppr ie@(IEVar _ var) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc var)] - ppr ie@(IEThingAbs _ thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing)] - ppr ie@(IEThingAll _ thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ hcat [ppr (unLoc thing), text "(..)"]] - ppr ie@(IEThingWith _ thing wc withs) - = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))] + ppr ie@(IEVar _ var doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ ppr (unLoc var) + , exportDocstring <$> doc + ] + ppr ie@(IEThingAbs _ thing doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ ppr (unLoc thing) + , exportDocstring <$> doc + ] + ppr ie@(IEThingAll _ thing doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ hcat [ppr (unLoc thing) + , text "(..)"] + , exportDocstring <$> doc + ] + ppr ie@(IEThingWith _ thing wc withs doc) = + sep $ catMaybes [ ppr <$> ieDeprecation ie + , Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths)) + , exportDocstring <$> doc + ] where ppWiths = case wc of @@ -329,9 +366,11 @@ pprInfixOcc w = pprInfixOcc (ieWrappedName w) instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where + ppr (IEDefault _ (L _ n)) = text "default" <+> pprPrefixOcc n ppr (IEName _ (L _ n)) = pprPrefixOcc n ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n ppr (IEType _ (L _ n)) = text "type" <+> pprPrefixOcc n + ppr (IEData _ (L _ n)) = text "data" <+> pprPrefixOcc n pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name diff --git a/GHC/Hs/Instances.hs b/GHC/Hs/Instances.hs --- a/GHC/Hs/Instances.hs +++ b/GHC/Hs/Instances.hs @@ -33,6 +33,9 @@ import GHC.Hs.Pat import GHC.Hs.ImpExp import GHC.Parser.Annotation +import GHC.Types.Name.Reader (WithUserRdr(..)) +import GHC.Data.BooleanFormula (BooleanFormula(..)) +import Language.Haskell.Syntax.Extension (Anno) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs----------------------------------------- @@ -256,6 +259,13 @@ deriving instance Data (RuleBndr GhcRn) deriving instance Data (RuleBndr GhcTc) +deriving instance Data (RuleBndrs GhcPs) +deriving instance Data (RuleBndrs GhcRn) +deriving instance Data (RuleBndrs GhcTc) + +deriving instance Data TcSpecPrags +deriving instance Data TcSpecPrag + -- deriving instance (DataId p) => Data (WarnDecls p) deriving instance Data (WarnDecls GhcPs) deriving instance Data (WarnDecls GhcRn) @@ -374,29 +384,42 @@ deriving instance Data (ParStmtBlock GhcRn GhcRn) deriving instance Data (ParStmtBlock GhcTc GhcTc) +-- deriving instance (DataIdLR p p) => Data (ApplicativeStmt p p) +deriving instance Data (ApplicativeStmt GhcPs GhcPs) +deriving instance Data (ApplicativeStmt GhcPs GhcRn) +deriving instance Data (ApplicativeStmt GhcPs GhcTc) +deriving instance Data (ApplicativeStmt GhcRn GhcPs) +deriving instance Data (ApplicativeStmt GhcRn GhcRn) +deriving instance Data (ApplicativeStmt GhcRn GhcTc) +deriving instance Data (ApplicativeStmt GhcTc GhcPs) +deriving instance Data (ApplicativeStmt GhcTc GhcRn) +deriving instance Data (ApplicativeStmt GhcTc GhcTc) + -- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) deriving instance Data (ApplicativeArg GhcPs) deriving instance Data (ApplicativeArg GhcRn) deriving instance Data (ApplicativeArg GhcTc) -deriving instance Data (HsStmtContext GhcPs) -deriving instance Data (HsStmtContext GhcRn) -deriving instance Data (HsStmtContext GhcTc) - deriving instance Data HsArrowMatchContext -deriving instance Data HsDoFlavour - -deriving instance Data (HsMatchContext GhcPs) -deriving instance Data (HsMatchContext GhcRn) -deriving instance Data (HsMatchContext GhcTc) +deriving instance Data fn => Data (HsStmtContext fn) +deriving instance Data fn => Data (HsMatchContext fn) -- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p) deriving instance Data (HsUntypedSplice GhcPs) deriving instance Data (HsUntypedSplice GhcRn) deriving instance Data (HsUntypedSplice GhcTc) +deriving instance Data (HsTypedSplice GhcPs) +deriving instance Data (HsTypedSplice GhcRn) +deriving instance Data (HsTypedSplice GhcTc) + +deriving instance Data HsImplicitLiftSplice +deriving instance Data HsUserSpliceExt +deriving instance Data HsQuasiQuoteExt + deriving instance Data a => Data (HsUntypedSpliceResult a) +deriving instance Data HsTypedSpliceResult -- deriving instance (DataIdLR p p) => Data (HsQuote p) deriving instance Data (HsQuote GhcPs) @@ -425,6 +448,8 @@ -- deriving instance (DataId p) => Data (HsLit p) deriving instance Data (HsLit GhcPs) deriving instance Data (HsLit GhcRn) + +deriving instance Data HsLitTc deriving instance Data (HsLit GhcTc) -- deriving instance (DataIdLR p p) => Data (HsOverLit p) @@ -445,10 +470,6 @@ deriving instance Data ConPatTc -deriving instance Data (HsConPatTyArg GhcPs) -deriving instance Data (HsConPatTyArg GhcRn) -deriving instance Data (HsConPatTyArg GhcTc) - deriving instance (Data a, Data b) => Data (HsFieldBind a b) deriving instance (Data body) => Data (HsRecFields GhcPs body) @@ -488,6 +509,11 @@ deriving instance Data (HsPatSigType GhcRn) deriving instance Data (HsPatSigType GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsTyPat p) +deriving instance Data (HsTyPat GhcPs) +deriving instance Data (HsTyPat GhcRn) +deriving instance Data (HsTyPat GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p) deriving instance Data (HsForAllTelescope GhcPs) deriving instance Data (HsForAllTelescope GhcRn) @@ -498,52 +524,56 @@ deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) deriving instance (Data flag) => Data (HsTyVarBndr flag GhcTc) +-- deriving instance Data (HsBndrVar p) +deriving instance Data (HsBndrVar GhcPs) +deriving instance Data (HsBndrVar GhcRn) +deriving instance Data (HsBndrVar GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsBndrKind p) +deriving instance Data (HsBndrKind GhcPs) +deriving instance Data (HsBndrKind GhcRn) +deriving instance Data (HsBndrKind GhcTc) + -- deriving instance (DataIdLR p p) => Data (HsType p) deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +deriving instance Data HsTypeGhcPsExt + -- deriving instance (DataIdLR p p) => Data (HsTyLit p) deriving instance Data (HsTyLit GhcPs) deriving instance Data (HsTyLit GhcRn) deriving instance Data (HsTyLit GhcTc) --- deriving instance Data (HsLinearArrowTokens p) -deriving instance Data (HsLinearArrowTokens GhcPs) -deriving instance Data (HsLinearArrowTokens GhcRn) -deriving instance Data (HsLinearArrowTokens GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsArrow p) -deriving instance Data (HsArrow GhcPs) -deriving instance Data (HsArrow GhcRn) -deriving instance Data (HsArrow GhcTc) - --- deriving instance (DataIdLR p p) => Data (HsScaled p a) -deriving instance Data thing => Data (HsScaled GhcPs thing) -deriving instance Data thing => Data (HsScaled GhcRn thing) -deriving instance Data thing => Data (HsScaled GhcTc thing) +-- deriving instance (Data mult, DataIdLR p p) => Data (HsMultAnnOf mult p) +deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs) +deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcRn) +deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcTc) +deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcPs)) GhcPs) +deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn) +deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcTc)) GhcTc) -- deriving instance (Data a, Data b) => Data (HsArg p a b) deriving instance (Data a, Data b) => Data (HsArg GhcPs a b) deriving instance (Data a, Data b) => Data (HsArg GhcRn a b) deriving instance (Data a, Data b) => Data (HsArg GhcTc a b) --- deriving instance (DataIdLR p p) => Data (ConDeclField p) -deriving instance Data (ConDeclField GhcPs) -deriving instance Data (ConDeclField GhcRn) -deriving instance Data (ConDeclField GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsConDeclRecField p) +deriving instance Data (HsConDeclRecField GhcPs) +deriving instance Data (HsConDeclRecField GhcRn) +deriving instance Data (HsConDeclRecField GhcTc) +-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConDeclField on p) +deriving instance Data (HsConDeclField GhcPs) +deriving instance Data (HsConDeclField GhcRn) +deriving instance Data (HsConDeclField GhcTc) + -- deriving instance (DataId p) => Data (FieldOcc p) deriving instance Data (FieldOcc GhcPs) deriving instance Data (FieldOcc GhcRn) deriving instance Data (FieldOcc GhcTc) --- deriving instance DataId p => Data (AmbiguousFieldOcc p) -deriving instance Data (AmbiguousFieldOcc GhcPs) -deriving instance Data (AmbiguousFieldOcc GhcRn) -deriving instance Data (AmbiguousFieldOcc GhcTc) - - -- deriving instance (DataId name) => Data (ImportDecl name) deriving instance Data (ImportDecl GhcPs) deriving instance Data (ImportDecl GhcRn) @@ -561,6 +591,12 @@ -- --------------------------------------------------------------------- +deriving instance Data HsThingRn +deriving instance Data XXExprGhcRn +deriving instance Data a => Data (WithUserRdr a) + +-- --------------------------------------------------------------------- + deriving instance Data XXExprGhcTc deriving instance Data XXPatGhcTc @@ -569,3 +605,6 @@ deriving instance Data XViaStrategyPs -- --------------------------------------------------------------------- + +deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p)) +--------------------------------------------------------------------- diff --git a/GHC/Hs/Lit.hs b/GHC/Hs/Lit.hs --- a/GHC/Hs/Lit.hs +++ b/GHC/Hs/Lit.hs @@ -25,11 +25,14 @@ import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) +import GHC.Data.FastString (unpackFS) import GHC.Types.Basic (PprPrec(..), topPrec ) import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type +import GHC.Utils.Misc (split) import GHC.Utils.Outputable +import GHC.Utils.Panic (panic) import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension @@ -46,6 +49,7 @@ type instance XHsChar (GhcPass _) = SourceText type instance XHsCharPrim (GhcPass _) = SourceText type instance XHsString (GhcPass _) = SourceText +type instance XHsMultilineString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText type instance XHsInt (GhcPass _) = NoExtField type instance XHsIntPrim (GhcPass _) = SourceText @@ -58,12 +62,27 @@ type instance XHsWord16Prim (GhcPass _) = SourceText type instance XHsWord32Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText -type instance XHsInteger (GhcPass _) = SourceText -type instance XHsRat (GhcPass _) = NoExtField type instance XHsFloatPrim (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField -type instance XXLit (GhcPass _) = DataConCantHappen +type instance XXLit GhcPs = DataConCantHappen +type instance XXLit GhcRn = DataConCantHappen +type instance XXLit GhcTc = HsLitTc + +data HsLitTc + = HsInteger SourceText Integer Type + -- ^ Genuinely an integer; arises only + -- from TRANSLATION (overloaded + -- literals are done with HsOverLit) + | HsRat FractionalLit Type + -- ^ Genuinely a rational; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) +instance Eq HsLitTc where + (HsInteger _ x _) == (HsInteger _ y _) = x==y + (HsRat x _) == (HsRat y _) = x==y + _ == _ = False + data OverLitRn = OverLitRn { ol_rebindable :: Bool, -- Note [ol_rebindable] @@ -126,16 +145,15 @@ -- -- See Note [Printing of literals in Core] in GHC.Types.Literal -- for the reasoning. -hsLitNeedsParens :: PprPrec -> HsLit x -> Bool +hsLitNeedsParens :: forall x. IsPass x => PprPrec -> HsLit (GhcPass x) -> Bool hsLitNeedsParens p = go where go (HsChar {}) = False go (HsCharPrim {}) = False go (HsString {}) = False + go (HsMultilineString {}) = False go (HsStringPrim {}) = False go (HsInt _ x) = p > topPrec && il_neg x - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x go (HsFloatPrim {}) = False go (HsDoublePrim {}) = False go (HsIntPrim {}) = False @@ -148,13 +166,22 @@ go (HsWord16Prim {}) = False go (HsWord64Prim {}) = False go (HsWord32Prim {}) = False - go (XLit _) = False + go (XLit x) = case ghcPass @x of + GhcTc -> case x of + (HsInteger _ x _) -> p > topPrec && x < 0 + (HsRat x _) -> p > topPrec && fl_neg x --- | Convert a literal from one index type to another -convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) + +-- | Convert a literal from one index type to another. +-- The constraint XXLit (GhcPass p)~DataConCantHappen means that once the +-- XLit constructor is inhabited, we can no longer go back to the case where +-- its not. In practice it just means you can't just convertLit to go from +-- (HsLit GhcTc) -> (HsLit GhcPs/GhcRn), while all other conversions are fine. +convertLit :: XXLit (GhcPass p)~DataConCantHappen => HsLit (GhcPass p) -> HsLit (GhcPass p') convertLit (HsChar a x) = HsChar a x convertLit (HsCharPrim a x) = HsCharPrim a x convertLit (HsString a x) = HsString a x +convertLit (HsMultilineString a x) = HsMultilineString a x convertLit (HsStringPrim a x) = HsStringPrim a x convertLit (HsInt a x) = HsInt a x convertLit (HsIntPrim a x) = HsIntPrim a x @@ -167,8 +194,6 @@ convertLit (HsWord16Prim a x) = HsWord16Prim a x convertLit (HsWord32Prim a x) = HsWord32Prim a x convertLit (HsWord64Prim a x) = HsWord64Prim a x -convertLit (HsInteger a x b) = HsInteger a x b -convertLit (HsRat a x b) = HsRat a x b convertLit (HsFloatPrim a x) = HsFloatPrim a x convertLit (HsDoublePrim a x) = HsDoublePrim a x @@ -188,15 +213,17 @@ -} -- Instance specific to GhcPs, need the SourceText -instance Outputable (HsLit (GhcPass p)) where +instance IsPass p => Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) ppr (HsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsMultilineString st s) = + case st of + NoSourceText -> pprHsString s + SourceText src -> vcat $ map text $ split '\n' (unpackFS src) ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsInteger st i _) = pprWithSourceText st (integer i) - ppr (HsRat _ f _) = ppr f ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) @@ -209,6 +236,10 @@ ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w) ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w) ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w) + ppr (XLit x) = case ghcPass @p of + GhcTc -> case x of + (HsInteger st i _) -> pprWithSourceText st (integer i) + (HsRat f _) -> ppr f -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p @@ -227,10 +258,11 @@ -- mainly for too reasons: -- * We do not want to expose their internal representation -- * The warnings become too messy -pmPprHsLit :: HsLit (GhcPass x) -> SDoc +pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) +pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i) = integer (il_value i) pmPprHsLit (HsIntPrim _ i) = integer i @@ -243,8 +275,26 @@ pmPprHsLit (HsWord16Prim _ w) = integer w pmPprHsLit (HsWord32Prim _ w) = integer w pmPprHsLit (HsWord64Prim _ w) = integer w -pmPprHsLit (HsInteger _ i _) = integer i -pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d +pmPprHsLit (XLit x) = case ghcPass @p of + GhcTc -> case x of + (HsInteger _ i _) -> integer i + (HsRat f _) -> ppr f +negateOverLitVal :: OverLitVal -> OverLitVal +negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) +negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) +negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" + +instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where + compare (OverLit _ val1) (OverLit _ val2) = val1 `compare` val2 + compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 + compare _ _ = panic "Ord HsOverLit" + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) +instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where + (OverLit _ val1) == (OverLit _ val2) = val1 == val2 + (XOverLit val1) == (XOverLit val2) = val1 == val2 + _ == _ = panic "Eq HsOverLit" diff --git a/GHC/Hs/Pat.hs b/GHC/Hs/Pat.hs --- a/GHC/Hs/Pat.hs +++ b/GHC/Hs/Pat.hs @@ -4,10 +4,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -22,6 +24,8 @@ module GHC.Hs.Pat ( Pat(..), LPat, + isInvisArgPat, isInvisArgLPat, + isVisArgPat, isVisArgLPat, EpAnnSumPat(..), ConPatTc (..), ConLikeP, @@ -29,22 +33,22 @@ XXPatGhcTc(..), HsConPatDetails, hsConPatArgs, - HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, - hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, mkPrefixConPat, mkCharLitPat, mkNilPat, - isSimplePat, + isSimplePat, isPatSyn, looksLazyPatBind, isBangedLPat, gParPat, patNeedsParens, parenthesizePat, - isIrrefutableHsPat, isBoringHsPat, + isIrrefutableHsPat, + isBoringHsPat, + collectEvVarsPat, collectEvVarsPats, pprParendLPat, pprConArgs, @@ -72,18 +76,19 @@ import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Builtin.Types import GHC.Types.Var -import GHC.Types.Name.Reader ( RdrName ) +import GHC.Types.Name.Reader import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Core.Type import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats -import GHC.Data.Maybe -import GHC.Types.Name (Name, dataName) +import GHC.Types.Name + import Data.Data +import qualified Data.List( map ) +import qualified Data.List.NonEmpty as NE type instance XWildPat GhcPs = NoExtField type instance XWildPat GhcRn = NoExtField @@ -91,21 +96,23 @@ type instance XVarPat (GhcPass _) = NoExtField -type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~' +type instance XLazyPat GhcPs = EpToken "~" type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat GhcPs = EpAnnCO +type instance XAsPat GhcPs = EpToken "@" type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnnCO +type instance XParPat GhcPs = (EpToken "(", EpToken ")") +type instance XParPat GhcRn = NoExtField +type instance XParPat GhcTc = NoExtField -type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!' +type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = EpAnn AnnList +type instance XListPat GhcPs = AnnList () -- After parsing, ListPat can refer to a built-in Haskell list pattern -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField @@ -115,19 +122,23 @@ type instance XListPat GhcTc = Type -- List element type, for use in hsPatType. -type instance XTuplePat GhcPs = EpAnn [AddEpAnn] +type instance XTuplePat GhcPs = (EpaLocation, EpaLocation) type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = EpAnn EpAnnSumPat +type instance XOrPat GhcPs = NoExtField +type instance XOrPat GhcRn = NoExtField +type instance XOrPat GhcTc = Type + +type instance XSumPat GhcPs = EpAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XConPat GhcPs = EpAnn [AddEpAnn] +type instance XConPat GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) type instance XConPat GhcRn = NoExtField type instance XConPat GhcTc = ConPatTc -type instance XViewPat GhcPs = EpAnn [AddEpAnn] +type instance XViewPat GhcPs = TokRarrow type instance XViewPat GhcRn = Maybe (HsExpr GhcRn) -- The @HsExpr GhcRn@ gives an inverse to the view function. -- This is used for overloaded lists in particular. @@ -143,43 +154,128 @@ type instance XLitPat (GhcPass _) = NoExtField -type instance XNPat GhcPs = EpAnn [AddEpAnn] -type instance XNPat GhcRn = EpAnn [AddEpAnn] +type instance XNPat GhcPs = EpToken "-" +type instance XNPat GhcRn = EpToken "-" type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+" +type instance XNPlusKPat GhcPs = EpToken "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = EpAnn [AddEpAnn] +type instance XSigPat GhcPs = TokDcolon type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type +type instance XEmbTyPat GhcPs = EpToken "type" +type instance XEmbTyPat GhcRn = NoExtField +type instance XEmbTyPat GhcTc = Type + type instance XXPat GhcPs = DataConCantHappen type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn) -- Original pattern and its desugaring/expansion. - -- See Note [Rebindable syntax and HsExpansion]. + -- See Note [Rebindable syntax and XXExprGhcRn]. type instance XXPat GhcTc = XXPatGhcTc - -- After typechecking, we add extra constructors: CoPat and HsExpansion. - -- HsExpansion allows us to handle RebindableSyntax in pattern position: + -- After typechecking, we add extra constructors: CoPat and XXExprGhcRn. + -- XXExprGhcRn allows us to handle RebindableSyntax in pattern position: -- see "XXExpr GhcTc" for the counterpart in expressions. -type instance ConLikeP GhcPs = RdrName -- IdP GhcPs -type instance ConLikeP GhcRn = Name -- IdP GhcRn +type instance ConLikeP GhcPs = RdrName -- IdOccP GhcPs +type instance ConLikeP GhcRn = WithUserRdr Name -- IdOccP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsFieldBind _ = EpAnn [AddEpAnn] +type instance XHsRecFields GhcPs = NoExtField +type instance XHsRecFields GhcRn = NoExtField +type instance XHsRecFields GhcTc = NoExtField +type instance XHsFieldBind _ = Maybe (EpToken "=") + +-- The specificity of an invisible pattern from the parser is always +-- SpecifiedSpec. The specificity field supports code generated when deriving +-- newtype or via; see Note [Inferred invisible patterns]. +type instance XInvisPat GhcPs = (EpToken "@", Specificity) +type instance XInvisPat GhcRn = Specificity +type instance XInvisPat GhcTc = Type + + +{- Note [Invisible binders in functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC Proposal #448 (section 1.5 Type arguments in lambda patterns) introduces +binders for invisible type arguments (@a-binders) in function equations and +lambdas, e.g. + + 1. {-# LANGUAGE TypeAbstractions #-} + id1 :: a -> a + id1 @t x = x :: t -- @t-binder on the LHS of a function equation + + 2. {-# LANGUAGE TypeAbstractions #-} + ex :: (Int8, Int16) + ex = higherRank (\ @a x -> maxBound @a - x ) + -- @a-binder in a lambda pattern in an argument + -- to a higher-order function + higherRank :: (forall a. (Num a, Bounded a) => a -> a) -> (Int8, Int16) + higherRank f = (f 42, f 42) + +In the AST, invisible patterns are represented as InvisPat constructor inside of Pat: + data Pat p + = ... + | InvisPat (LHsType p) + ... + +Just like `BangPat`, the `Pat` data type allows `InvisPat` to appear in +nested positions. But this is often not allowed; e.g. + + f @a x = rhs -- YES + f (@a,x) = rhs -- NO + + g = do { @a <- e1; e2 } -- NO + h x = case x of { @a -> rhs } -- NO + +Rather than excluding these things syntactically, we reject them in the renamer +(see `rn_pats_general`). This actually gives a better error message than we +would get if they were rejected in the parser. + +Each pattern is either visible (not prefixed with @) or invisible (prefixed with @): + f :: forall a. forall b -> forall c. Int -> ... + f @a b @c x = ... + +In this example, the arg-patterns are + 1. InvisPat @a -- in the type sig: forall a. + 2. VarPat b -- in the type sig: forall b -> + 3. InvisPat @c -- in the type sig: forall c. + 4. VarPat x -- in the type sig: Int -> + +Invisible patterns are always type patterns, i.e. they are matched with +forall-bound type variables in the signature. Consequently, those variables (and +their binders) are erased during compilation, having no effect on program +execution at runtime. + +Visible patterns, on the other hand, may be matched with ordinary function +arguments (Int ->) as well as required type arguments (forall b ->). This means +that a visible pattern may either be erased or retained, and we only find out in +the type checker, namely in tcMatchPats, where we match up all arg-patterns with +quantifiers from the type signature. + +In other words, invisible patterns are always /erased/, while visible patterns +are sometimes /erased/ and sometimes /retained/. + +The desugarer has no use for erased patterns, as the type checker generates +HsWrappers to bind the corresponding type variables. Erased patterns are simply +discarded inside tcMatchPats, where we know if visible pattern retained or erased. +-} + -- --------------------------------------------------------------------- -- API Annotations types data EpAnnSumPat = EpAnnSumPat - { sumPatParens :: [AddEpAnn] - , sumPatVbarsBefore :: [EpaLocation] - , sumPatVbarsAfter :: [EpaLocation] + { sumPatParens :: (EpaLocation, EpaLocation) + , sumPatVbarsBefore :: [EpToken "|"] + , sumPatVbarsAfter :: [EpToken "|"] } deriving Data +instance NoAnn EpAnnSumPat where + noAnn = EpAnnSumPat (noAnn, noAnn) [] [] + -- --------------------------------------------------------------------- -- | Extension constructor for Pat, added after typechecking. @@ -202,11 +298,11 @@ } -- | Pattern expansion: original pattern, and desugared pattern, -- for RebindableSyntax and other overloaded syntax such as OverloadedLists. - -- See Note [Rebindable syntax and HsExpansion]. + -- See Note [Rebindable syntax and XXExprGhcRn]. | ExpansionPat (Pat GhcRn) (Pat GhcTc) --- See Note [Rebindable syntax and HsExpansion]. +-- See Note [Rebindable syntax and XXExprGhcRn]. data HsPatExpansion a b = HsPatExpanded a b deriving Data @@ -239,18 +335,18 @@ cpt_wrap :: HsWrapper } -hsRecFieldId :: HsRecField GhcTc arg -> Id -hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) q -> Located RdrName -hsRecUpdFieldRdr = fmap ambiguousFieldOccRdrName . reLoc . hfbLHS +hsRecFields :: HsRecFields (GhcPass p) arg -> [IdGhcP p] +hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds) -hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id -hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc +hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg] +hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds) -hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc -hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS +hsRecFieldSel :: HsRecField (GhcPass p) arg -> IdGhcP p +hsRecFieldSel = unLoc . foLabel . unLoc . hfbLHS +hsRecFieldId :: HsRecField GhcTc arg -> Id +hsRecFieldId = hsRecFieldSel {- ************************************************************************ @@ -260,10 +356,7 @@ ************************************************************************ -} -instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where - ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty - -instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot) +instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot) => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) @@ -281,7 +374,7 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat --- See Note [Rebindable syntax and HsExpansion]. +-- See Note [Rebindable syntax and XXExprGhcRn]. instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a) @@ -326,10 +419,10 @@ pprPat (WildPat _) = char '_' pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat -pprPat (AsPat _ name _ pat) = hcat [pprPrefixOcc (unLoc name), char '@', +pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] -pprPat (ParPat _ _ pat _) = parens (ppr pat) +pprPat (ParPat _ pat) = parens (ppr pat) pprPat (LitPat _ s) = ppr s pprPat (NPat _ l Nothing _) = ppr l pprPat (NPat _ l (Just _) _) = char '-' <> ppr l @@ -346,6 +439,7 @@ GhcTc -> dataConCantHappen ext pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) +pprPat (OrPat _ pats) = pprWithSemis ppr (NE.toList pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as -- `MkSolo x`, not `(x)` @@ -376,11 +470,20 @@ , cpt_dicts = dicts , cpt_binds = binds } = ext +pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp +pprPat (InvisPat x tp) = char '@' <> delimit (ppr tp) + where + delimit + | inferred = braces + | needs_parens = parens + | otherwise = id + inferred = case ghcPass @p of + GhcPs -> snd x == InferredSpec + GhcRn -> x == InferredSpec + GhcTc -> False + needs_parens = hsTypeNeedsParens appPrec $ unLoc $ hstp_body tp pprPat (XPat ext) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> dataConCantHappen ext -#endif GhcRn -> case ext of HsPatExpanded orig _ -> pprPat orig GhcTc -> case ext of @@ -400,8 +503,7 @@ pprConArgs :: (OutputableBndrId p, Outputable (Anno (IdGhcP p))) => HsConPatDetails (GhcPass p) -> SDoc -pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats) - where pprTyArgs tyargs = fsep (map ppr tyargs) +pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats @@ -419,7 +521,7 @@ -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc) - , pat_args = PrefixCon [] pats + , pat_args = PrefixCon pats , pat_con_ext = ConPatTc { cpt_tvs = [] , cpt_dicts = [] @@ -472,7 +574,7 @@ isBangedLPat = isBangedPat . unLoc isBangedPat :: Pat (GhcPass p) -> Bool -isBangedPat (ParPat _ _ p _) = isBangedLPat p +isBangedPat (ParPat _ p) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _ = False @@ -485,7 +587,7 @@ looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds })) - = anyBag (looksLazyPatBind . unLoc) binds + = any (looksLazyPatBind . unLoc) binds looksLazyPatBind _ = False @@ -493,14 +595,13 @@ looksLazyLPat = looksLazyPat . unLoc looksLazyPat :: Pat (GhcPass p) -> Bool -looksLazyPat (ParPat _ _ p _) = looksLazyLPat p -looksLazyPat (AsPat _ _ _ p) = looksLazyLPat p +looksLazyPat (ParPat _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True - {- Note [-XStrict and irrefutability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -526,55 +627,56 @@ See also Note [decideBangHood] in GHC.HsToCore.Utils. -} --- | (isIrrefutableHsPat p) is true if matching against p cannot fail + +-- | @isIrrefutableHsPat p@ is true if matching against @p@ cannot fail -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn -- in 3.17.2 of the Haskell 98 report.) -- --- WARNING: isIrrefutableHsPat returns False if it's in doubt. --- Specifically on a ConPatIn, which is what it sees for a --- (LPat Name) in the renamer, it doesn't know the size of the --- constructor family, so it returns False. Result: only --- tuple patterns are considered irrefutable at the renamer stage. +-- If isIrrefutableHsPat returns 'True', the pattern is definitely irrefutable. -- --- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat :: forall p. (OutputableBndrId p) - => Bool -- ^ Are we in a @-XStrict@ context? - -- See Note [-XStrict and irrefutability] - -> LPat (GhcPass p) -> Bool -isIrrefutableHsPat is_strict = goL +-- However, isIrrefutableHsPat returns 'False' if it's in doubt. It's a +-- best effort guess with the information we have available: +-- +-- - we sometimes call 'isIrrefutableHsPat' from the renamer, in which case +-- we don't have type information to hand. This means we can't properly +-- handle GADTs, nor the result TyCon of COMPLETE pragmas. +-- - even when calling 'isIrrefutableHsPat' in the typechecker, we don't keep +-- track of any long distance information like the pattern-match checker does. +isIrrefutableHsPat + :: forall p + . IsPass p + => Bool -- ^ Are we in a @-XStrict@ context? + -- See Note [-XStrict and irrefutability] + -> (ConLikeP (GhcPass p) -> Bool) -- ^ How to check whether the 'ConLike' in a + -- 'ConPat' pattern is irrefutable + -> LPat (GhcPass p) -- ^ The (located) pattern to check + -> Bool -- Is it irrefutable? +isIrrefutableHsPat is_strict irref_conLike pat = go (unLoc pat) where - goL :: LPat (GhcPass p) -> Bool - goL = go . unLoc + goL (L _ p) = go p go :: Pat (GhcPass p) -> Bool go (WildPat {}) = True go (VarPat {}) = True go (LazyPat _ p') | is_strict - = isIrrefutableHsPat False p' + = isIrrefutableHsPat False irref_conLike p' | otherwise = True go (BangPat _ pat) = goL pat - go (ParPat _ _ pat _) = goL pat - go (AsPat _ _ _ pat) = goL pat + go (ParPat _ pat) = goL pat + go (AsPat _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat go (TuplePat _ pats _) = all goL pats - go (SumPat {}) = False - -- See Note [Unboxed sum patterns aren't irrefutable] + go (OrPat _ pats) = any goL pats -- This is simplistic; see Note [Irrefutable or-patterns] + go (SumPat {}) = False -- See Note [Unboxed sum patterns aren't irrefutable] go (ListPat {}) = False - go (ConPat - { pat_con = con - , pat_args = details }) - = case ghcPass @p of - GhcPs -> False -- Conservative - GhcRn -> False -- Conservative - GhcTc -> case con of - L _ (PatSynCon _pat) -> False -- Conservative - L _ (RealDataCon con) -> - isJust (tyConSingleDataCon_maybe (dataConTyCon con)) - && all goL (hsConPatArgs details) + -- See Note [Irrefutability of ConPat] + go (ConPat { pat_con = L _ con, pat_args = details }) + = irref_conLike con + && all goL (hsConPatArgs details) go (LitPat {}) = False go (NPat {}) = False go (NPlusKPat {}) = False @@ -583,10 +685,12 @@ -- since we cannot know until the splice is evaluated. go (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). + go (EmbTyPat {}) = True + go (InvisPat {}) = True + go (XPat ext) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> dataConCantHappen ext -#endif GhcRn -> case ext of HsPatExpanded _ pat -> go pat GhcTc -> case ext of @@ -602,7 +706,7 @@ -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of - ParPat _ _ x _ -> isSimplePat x + ParPat _ x -> isSimplePat x SigPat _ x _ -> isSimplePat x LazyPat _ x -> isSimplePat x BangPat _ x -> isSimplePat x @@ -610,7 +714,7 @@ _ -> Nothing -- | Is this pattern boring from the perspective of pattern-match checking, --- i.e. introduces no new pieces of long-dinstance information +-- i.e. introduces no new pieces of long-distance information -- which could influence pattern-match checking? -- -- See Note [Boring patterns]. @@ -628,7 +732,7 @@ VarPat {} -> True LazyPat {} -> True BangPat _ pat -> goL pat - ParPat _ _ pat _ -> goL pat + ParPat _ pat -> goL pat AsPat {} -> False -- the pattern x@y links x and y together, -- which is a nontrivial piece of information ViewPat _ _ pat -> goL pat @@ -647,10 +751,13 @@ -- A pattern match on a GADT constructor can introduce -- type-level information (for example, T18572). -> False + OrPat _ pats -> all goL pats LitPat {} -> True NPat {} -> True NPlusKPat {} -> True SplicePat {} -> False + EmbTyPat {} -> True + InvisPat {} -> True XPat ext -> case ghcPass @p of GhcRn -> case ext of @@ -659,8 +766,97 @@ CoPat _ pat _ -> go pat ExpansionPat _ pat -> go pat -{- Note [Unboxed sum patterns aren't irrefutable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +isPatSyn :: LPat GhcTc -> Bool +isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True +isPatSyn _ = False + +{- Note [Irrefutability of ConPat] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constructor pattern `ConPat { pat_con, pat_args }` is irrefutable under two +conditions: + + Irref-ConLike: the constructor, pat_con, is itself irrefutable. + Irref-args : all of the argument patterns, pat_args, are irrefutable. + +The (Irref-ConLike) condition can be stated as follows: + + Irref-DataCon: a DataCon is irrefutable iff it is the only constructor of its + parent type constructor. + Irref-PatSyn: a PatSyn is irrefutable iff there is a COMPLETE pragma + containing this PatSyn as its sole member. + +To understand this, let's consider some simple examples: + + data A = MkA Int Bool + data BC = B Int | C + + pattern P :: Maybe Int -> BC + pattern P mb_i <- ( ( \ case { B i -> Just i; C -> Nothing } ) -> mb_i ) + {-# COMPLETE P #-} + +In this case: + + - the pattern 'A p1 p2' (for patterns 'p1 :: Int', 'p2 :: Bool') is irrefutable + precisely when both 'p1' and 'p2' are irrefutable (this is the same as + irrefutability of tuple patterns); + - neither of the patterns 'B p' (for any pattern 'p :: Int') or 'C' are irrefutable, + because the parent type constructor 'BC' contains more than one data constructor, + - the pattern 'P q', for a pattern 'q :: Maybe Int', is irrefutable precisely + when 'q' is irrefutable, due to the COMPLETE pragma on 'P'. + +Wrinkle [Irrefutability and COMPLETE pragma result TyCons] + + There is one subtlety in the Irref-PatSyn condition: COMPLETE pragmas may + optionally specify a result TyCon, as explained in Note [Implementation of COMPLETE pragmas] + in GHC.HsToCore.Pmc.Solver. + + So, for a COMPLETE pragma with a result TyCon, we would need to compute + 'completeMatchAppliesAtType' to ensure that the COMPLETE pragma is indeed + applicable. Doing so is not so straightforward in 'isIrrefutableHsPat', for + a couple of reasons: + + 1. 'isIrrefutableHsPat' is called from within the renamer, which means + we don't have the appropriate 'Type' to hand, + 2. Even when 'isIrrefutableHsPat' is called from within the typechecker, + computing 'completeMatchAppliesAtType' for a 'ConPat' which might be + nested deep inside the top-level call, such as + + ( ( _ , P (x :: Int) ) :: ( Int, Int ) + + would require keeping track of types as we recur in 'isIrrefutableHsPat', + which would be much more involved and require duplicating code from + the pattern match checker (it performs this check using the notion + of "match variables", which we don't have in the typechecker). + +Note [Irrefutable or-patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When is an or-pattern ( p_1 ; ... ; p_n ) irrefutable? It certainly suffices +that individual pattern p_i is irrefutable, but it isn't necessary. + +For example, with the datatype definition + + data ABC = A | B | C + +the or-pattern ( B ; C ; A ) is irrefutable. Similarly, one can take into +account COMPLETE pragmas, e.g. (P ; R ; Q) is irrefutable in the presence of +{-# COMPLETE P, Q, R #-}. This would extend Note [Irrefutability of ConPat] to +the case of disjunctions of constructor patterns. + +For now, the function 'isIrrefutableHsPat' does not take into account these +additional complications, and considers an or-pattern irrefutable precisely when +any of the summands are irrefutable. This pessimistic behaviour is OK: the contract +of 'isIrrefutableHsPat' is that it can only return 'True' for definitely irrefutable +patterns, but may conservatively return 'False' in other cases. + +The justification for this design choice is as follows: + + 1. Producing the correct answer in all cases would be rather difficult, + for example for a complex pattern such as ( P ; !( R ; S ; ( Q :: Ty ) ) ). + 2. Irrefutable or-patterns aren't particularly common or useful, given that + (currently) or-patterns aren't allowed to bind variables. + +Note [Unboxed sum patterns aren't irrefutable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as patterns. A simple example that demonstrates this is from #14228: @@ -731,8 +927,130 @@ incomplete pattern-match, as incompleteness inside do-notation is handled using MonadFail. However, we still want to propagate the fact that x is headed by the 'Just' constructor, to avoid a pattern-match warning on the last line. + +Note [Implementation of OrPatterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the implementation of the extension -XOrPatterns. + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0522-or-patterns.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/522 and others + +Parser +------ +We parse an or-pattern `pat_1; ...; pat_k` into `OrPat [pat_1, ..., pat_k]`, +where `OrPat` is a constructor of `Pat` in Language.Haskell.Syntax.Pat. +We occasionally refer to any of the `pat_k` as "pattern alternatives" below. +The changes to the parser are as outlined in Section 8.1 of the proposal. +The main productions are + + orpats -> exp | exp ';' orpats + aexp2 -> '(' orpats ')' + pat -> orpats + +Renamer and typechecker +----------------------- +The typing rule for or-patterns in terms of pattern types is + + Γ0, Σ0 ⊢ pat_i : τ ⤳ Γ0,Σi,Ψi + -------------------------------------------- + Γ0, Σ0 ⊢ ( pat_1; ...; pat_n ) : τ ⤳ Γ0,Σ0,∅ + +(See the proposal for what a pattern type `Γ, Σ ⊢ pat : τ ⤳ Γ,Σ,Ψ` is.) +The main points + + * None of the patterns may bind any variables, hence the same Γ0 in both input + and output. + * Any Given constraints bound by the pattern are discarded: the rule discards + the Σi returned by each pattern. + * Similarly any existentials Ψi bound by the pattern are discarded. + +In GHC.Rename.Pat.rnPatAndThen, we reject visible term and type binders (i.e. +concerning Γ0). + +Regarding the Givens Σi and existenials Ψi (i.e. invisible type binders) +introduced by the pattern alternatives `pat_i`, we discard them in +GHC.Tc.Gen.Pats.tc_pat in a manner similar to LazyPats; +see Note [Hopping the LIE in lazy patterns]. + +Why is it useful to allow Σi and Ψi only to discard them immediately after? +Consider + + data T a where MkT :: forall a x. Num a => x -> T a + foo :: T a -> a + foo (MkT{}; MkT{}) = 3 + +We do want to allow matching on MkT{} in or-patterns, despite them invisibly +binding an existential type variable `x` and a new Given constraint `Num a`. +Clearly, `x` must be dead in the RHS of foo, because there is no field binder +that brings it to life, so no harm done. +But we must be careful not to solve the `Num a` Wanted constraint in the RHS of +foo with the Given constraint from the pattern alternatives, hence we are +Hopping the LIE. + +Desugarer +--------- +The desugaring of or-patterns is complicated by the fact that we have to avoid +exponential code blowup. Consider + f (LT; GT) (EQ; GT) = rhs1 + f _ _ = rhs2 +The naïve desugaring of or-patterns would explode every or-pattern, thus + f LT EQ = rhs1 + f LT GT = rhs1 + f GT EQ = rhs1 + f GT GT = rhs1 + f _ _ = rhs2 +which leads to an exponential number of copies of `rhs1`. +Our current strategy, implemented in GHC.HsToCore.Match.tidy1, is to +desugar to LambdaCase and ViewPatterns, + f ((\case LT -> True; GT -> True; _ -> False) -> True) + ((\case EQ -> True; GT -> True; _ -> False) -> True) + = rhs1 + f _ _ = rhs2 +The existing code for ViewPatterns makes sure that we do not duplicate `rhs1` +and the Simplifier will take care to turn this into efficient code. + +Pattern-match checker +--------------------- +The changes to the pattern-match checker are described in detail in Section 4.9 +of the 2024 revision of the "Lower Your Guards" paper. +What follows is a brief summary of that change. + +The pattern-match checker desugars patterns as well, into syntactic variants of +*guard trees* such as `PmMatch`, describing a single Match `f ps | grhss`. +It used to be that each such guard trees nicely captured the effects of pattern +matching `ps` in a conjunctive list of `PmGrd`s, each of which refines +the set of Nablas that reach the RHS of the clause. +`PmGrd` is the heart of the Lower Your Guards approach: it is compositional, +simple, and *non-recursive*, unlike or-patterns! +Conjunction is implemented with the `...Pmc.Check.leftToRight` combinator. +But to desugar or-patterns, we need to compose with `Pmc.Check.topToBottom` +to model first match semantics! +This was previously impossible in the pattern fragment, and indeed is +incompatible with the simple "list of `PmGrd`s" desugaring of patterns. + +So our solution is to generalise "sequence of `PmGrd`" into a series-parallel +graph `GrdDag`, a special kind of DAG, where "series" corresponds to +left-to-right sequence and "parallel" corresponds to top-to-bottom or-pattern +alternatives. Example + + f (LT; GT) True (EQ; GT) = rhs + +desugars to + + /- LT <- x -\ /- EQ <- z -\ + . . True <- y . .-> rhs + \- GT <- x ./ \- GT <- z -/ + +Branching is GdAlt and models first-match semantics of or-patterns, and +sequencing is GdSeq. + +We must take care of exponential explosion of Covered sets for long matches like + g (LT; GT) (LT; GT) ... True = 1 +Fortunately, we can build on our existing throttling mechanism; +see Note [Countering exponential blowup] in GHC.HsToCore.Pmc.Check. -} + -- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs -- parentheses under precedence @p@. patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool @@ -742,15 +1060,15 @@ -- at a different GhcPass (see the case for GhcTc XPat below). go :: forall q. IsPass q => Pat (GhcPass q) -> Bool go (NPlusKPat {}) = p > opPrec + go (OrPat {}) = p > topPrec go (SplicePat {}) = False go (ConPat { pat_args = ds }) = conPatNeedsParens p ds go (SigPat {}) = p >= sigPrec go (ViewPat {}) = True + go (EmbTyPat {}) = True + go (InvisPat{}) = False go (XPat ext) = case ghcPass @q of -#if __GLASGOW_HASKELL__ < 901 - GhcPs -> dataConCantHappen ext -#endif GhcRn -> case ext of HsPatExpanded orig _ -> go orig GhcTc -> case ext of @@ -777,17 +1095,22 @@ -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@. -conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool +conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool conPatNeedsParens p = go where - go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts)) - go (InfixCon {}) = p >= opPrec -- type args should be empty in this case - go (RecCon {}) = False + go (PrefixCon args) = p >= appPrec && not (null args) + go (InfixCon {}) = p >= opPrec -- type args should be empty in this case + go (RecCon {}) = False -- | Parenthesize a pattern without token information -gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass) -gParPat p = ParPat noAnn noHsTok p noHsTok +gParPat :: forall p. IsPass p => LPat (GhcPass p) -> Pat (GhcPass p) +gParPat pat = ParPat x pat + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. @@ -799,6 +1122,7 @@ | patNeedsParens p pat = L loc (gParPat lpat) | otherwise = lpat + {- % Collect all EvVars from all constructor patterns -} @@ -814,11 +1138,12 @@ collectEvVarsPat pat = case pat of LazyPat _ p -> collectEvVarsLPat p - AsPat _ _ _ p -> collectEvVarsLPat p - ParPat _ _ p _ -> collectEvVarsLPat p + AsPat _ _ p -> collectEvVarsLPat p + ParPat _ p -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps + OrPat _ ps -> unionManyBags $ map collectEvVarsLPat (NE.toList ps) SumPat _ p _ _ -> collectEvVarsLPat p ConPat { pat_args = args @@ -845,7 +1170,7 @@ -} type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA -type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA -type instance Anno RecFieldsDotDot = SrcSpan +type instance Anno RecFieldsDotDot = EpaLocation diff --git a/GHC/Hs/Specificity.hs b/GHC/Hs/Specificity.hs new file mode 100644 --- /dev/null +++ b/GHC/Hs/Specificity.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module GHC.Hs.Specificity where + +import Prelude +import Control.DeepSeq (NFData(..)) + +import GHC.Utils.Outputable +import GHC.Utils.Binary + +import Language.Haskell.Syntax.Specificity + +{- ********************************************************************* +* * +* ForAllTyFlag +* * +********************************************************************* -} + +instance Outputable ForAllTyFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Binary Specificity where + put_ bh SpecifiedSpec = putByte bh 0 + put_ bh InferredSpec = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return SpecifiedSpec + _ -> return InferredSpec + +instance Binary ForAllTyFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +instance NFData Specificity where + rnf SpecifiedSpec = () + rnf InferredSpec = () +instance NFData ForAllTyFlag where + rnf (Invisible spec) = rnf spec + rnf Required = () + diff --git a/GHC/Hs/Stats.hs b/GHC/Hs/Stats.hs --- a/GHC/Hs/Stats.hs +++ b/GHC/Hs/Stats.hs @@ -11,7 +11,6 @@ import GHC.Prelude -import GHC.Data.Bag import GHC.Hs import GHC.Types.SrcLoc @@ -116,6 +115,7 @@ sig_info (FixSig {}) = (1,0,0,0,0) sig_info (TypeSig {}) = (0,1,0,0,0) sig_info (SpecSig {}) = (0,0,1,0,0) + sig_info (SpecSigE {}) = (0,0,1,0,0) sig_info (InlineSig {}) = (0,0,0,1,0) sig_info (ClassOpSig {}) = (0,0,0,0,1) sig_info _ = (0,0,0,0,0) @@ -135,9 +135,8 @@ spec_info (Just (Exactly, _)) = (0,0,0,0,0,1,0) spec_info (Just (EverythingBut, _)) = (0,0,0,0,0,0,1) - data_info (DataDecl { tcdDataDefn = HsDataDefn - { dd_cons = cs - , dd_derivs = derivs}}) + data_info (DataDecl { tcdDataDefn = dd :: HsDataDefn GhcPs }) + | HsDataDefn { dd_cons = cs, dd_derivs = derivs} <- dd = ( length cs , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s) 0 derivs ) @@ -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 diff --git a/GHC/Hs/Syn/Type.hs b/GHC/Hs/Syn/Type.hs --- a/GHC/Hs/Syn/Type.hs +++ b/GHC/Hs/Syn/Type.hs @@ -7,8 +7,7 @@ -- * Extracting types from HsExpr lhsExprType, hsExprType, hsWrapperType, -- * Extracting types from HsSyn - hsLitType, hsPatType, hsLPatType - + hsLitType, hsPatType, hsLPatType, ) where import GHC.Prelude @@ -42,15 +41,16 @@ hsLPatType (L _ p) = hsPatType p hsPatType :: Pat GhcTc -> Type -hsPatType (ParPat _ _ pat _) = hsLPatType pat +hsPatType (ParPat _ pat) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat _ lvar) = idType (unLoc lvar) hsPatType (BangPat _ pat) = hsLPatType pat hsPatType (LazyPat _ pat) = hsLPatType pat hsPatType (LitPat _ lit) = hsLitType lit -hsPatType (AsPat _ var _ _) = idType (unLoc var) +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 @@ -63,16 +63,19 @@ hsPatType (SigPat ty _ _) = ty hsPatType (NPat ty _ _ _) = ty hsPatType (NPlusKPat ty _ _ _ _ _) = ty +hsPatType (EmbTyPat ty _) = typeKind ty +hsPatType (InvisPat ty _) = typeKind ty hsPatType (XPat ext) = case ext of CoPat _ _ ty -> ty ExpansionPat _ pat -> hsPatType pat hsPatType (SplicePat v _) = dataConCantHappen v -hsLitType :: HsLit (GhcPass p) -> Type +hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type hsLitType (HsChar _ _) = charTy hsLitType (HsCharPrim _ _) = charPrimTy hsLitType (HsString _ _) = stringTy +hsLitType (HsMultilineString _ _) = stringTy hsLitType (HsStringPrim _ _) = addrPrimTy hsLitType (HsInt _ _) = intTy hsLitType (HsIntPrim _ _) = intPrimTy @@ -85,10 +88,12 @@ hsLitType (HsWord16Prim _ _) = word16PrimTy hsLitType (HsWord32Prim _ _) = word32PrimTy hsLitType (HsWord64Prim _ _) = word64PrimTy -hsLitType (HsInteger _ _ ty) = ty -hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy +hsLitType (XLit x) = case ghcPass @p of + GhcTc -> case x of + (HsInteger _ _ ty) -> ty + (HsRat _ ty) -> ty -- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion. @@ -98,19 +103,16 @@ -- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. hsExprType :: HsExpr GhcTc -> Type hsExprType (HsVar _ (L _ id)) = idType id -hsExprType (HsUnboundVar (HER _ ty _) _) = ty -hsExprType (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 -hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group -hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group +hsExprType (HsLam _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f -hsExprType (HsAppType x f _ _) = piResultTy (lhsExprType f) x +hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x hsExprType (OpApp v _ _ _) = dataConCantHappen v hsExprType (NegApp _ _ se) = syntaxExprType se -hsExprType (HsPar _ _ e _) = lhsExprType e +hsExprType (HsPar _ e) = lhsExprType e hsExprType (SectionL v _ _) = dataConCantHappen v hsExprType (SectionR v _ _) = dataConCantHappen v hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args @@ -118,7 +120,7 @@ hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group hsExprType (HsIf _ _ t _) = lhsExprType t hsExprType (HsMultiIf ty _) = ty -hsExprType (HsLet _ _ _ _ body) = lhsExprType body +hsExprType (HsLet _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr @@ -142,11 +144,17 @@ hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e -hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e -hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e +hsExprType (HsEmbTy x _) = dataConCantHappen x +hsExprType (HsHole (_, (HER _ ty _))) = ty +hsExprType (HsQual x _ _) = dataConCantHappen x +hsExprType (HsForAll x _ _) = dataConCantHappen x +hsExprType (HsFunArr x _ _ _) = dataConCantHappen x +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 @@ -193,7 +201,6 @@ go (WpTyLam tv) = liftPRType $ mkForAllTy (Bndr tv Inferred) go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) go (WpLet _) = id - go (WpMultCoercion _) = id lhsCmdTopType :: LHsCmdTop GhcTc -> Type lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty diff --git a/GHC/Hs/Type.hs b/GHC/Hs/Type.hs --- a/GHC/Hs/Type.hs +++ b/GHC/Hs/Type.hs @@ -23,20 +23,25 @@ -} module GHC.Hs.Type ( - Mult, HsScaled(..), - hsMult, hsScaledThing, - HsArrow(..), arrowToHsType, - HsLinearArrowTokens(..), - hsLinear, hsUnrestricted, isUnrestricted, - pprHsArrow, + Mult, + HsMultAnn, HsMultAnnOf(..), + multAnnToHsType, expandHsMultAnnOf, + EpLinear(..), EpArrowOrColon(..), + pprHsArrow, pprHsMultAnn, HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, - HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr, + HsTypeGhcPsExt(..), + HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis, + HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..), + HsBndrKind(..), + HsBndrVar(..), HsBndrVis(..), isHsBndrInvisible, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..), HsPatSigType(..), HsPSRn(..), + HsTyPat(..), HsTyPatRn(..), + HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn, HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, fromMaybeContext, @@ -46,20 +51,16 @@ LHsTypeArg, lhsTypeArgSrcSpan, OutputableBndrFlag, - LBangType, BangType, HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..), - getBangType, getBangStrictness, - ConDeclField(..), LConDeclField, pprConDeclFields, - - HsConDetails(..), noTypeArgs, + HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields, + HsConDetails(..), + HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult, + hsPlainTypeField, mkConDeclField, FieldOcc(..), LFieldOcc, mkFieldOcc, - AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc, - ambiguousFieldOccRdrName, ambiguousFieldOccLRdrName, - selectorAmbiguousFieldOcc, - unambiguousFieldOcc, ambiguousFieldOcc, + fieldOccRdrName, fieldOccLRdrName, OpName(..), @@ -68,14 +69,18 @@ hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit, mkHsOuterImplicit, mkHsOuterExplicit, mkHsImplicitSigType, mkHsExplicitSigType, - mkHsWildCardBndrs, mkHsPatSigType, + mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat, mkEmptyWildCardBndrs, mkHsForAllVisTele, mkHsForAllInvisTele, mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, - isHsKindedTyVar, hsTvbAllKinded, + isHsKindedTyVar, hsBndrVar, hsBndrKind, hsTvbAllKinded, hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, + hsTyVarLName, hsTyVarName, + hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarNames, + hsForAllTelescopeBndrs, + hsForAllTelescopeNames, + hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy, @@ -87,7 +92,7 @@ setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag, -- Printing - pprHsType, pprHsForAll, + pprHsType, pprHsForAll, pprHsForAllTelescope, pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs, pprLHsContext, hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext @@ -99,21 +104,21 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension -import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) +import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..) + , HsSrcBang(..), HsImplBang(..) + ) import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Fixity ( LexicalFixity(..) ) -import GHC.Types.Id ( Id ) import GHC.Types.SourceText import GHC.Types.Name -import GHC.Types.Name.Reader ( RdrName ) +import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr ) import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Names ( negateName ) -import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) +import GHC.Builtin.Types( oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) @@ -127,25 +132,7 @@ import Data.Data (Data) import qualified Data.Semigroup as S - -{- -************************************************************************ -* * -\subsection{Bang annotations} -* * -************************************************************************ --} - -getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p) -getBangType (L _ (HsBangTy _ _ lty)) = lty -getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) = - addCLocA lty lds (HsDocTy x lty lds) -getBangType lty = lty - -getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang -getBangStrictness (L _ (HsBangTy _ s _)) = s -getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s -getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) +import GHC.Data.Bag {- ************************************************************************ @@ -158,16 +145,15 @@ fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p) fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt -type instance XHsForAllVis (GhcPass _) = EpAnnForallTy +type instance XHsForAllVis (GhcPass _) = EpAnn (TokForall, TokRarrow) -- Location of 'forall' and '->' -type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy +type instance XHsForAllInvis (GhcPass _) = EpAnn (TokForall, EpToken ".") -- Location of 'forall' and '.' type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen -type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn) - -- ^ Location of 'forall' and '->' for HsForAllVis - -- Location of 'forall' and '.' for HsForAllInvis +type EpAnnForallVis = EpAnn (TokForall, TokRarrow) +type EpAnnForallInvis = EpAnn (TokForall, EpToken ".") type HsQTvsRn = [Name] -- Implicit variables -- For example, in data T (a :: k1 -> k2) = ... @@ -179,12 +165,12 @@ type instance XXLHsQTyVars (GhcPass _) = DataConCantHappen -mkHsForAllVisTele ::EpAnnForallTy -> +mkHsForAllVisTele ::EpAnnForallVis -> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p) mkHsForAllVisTele an vis_bndrs = HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs } -mkHsForAllInvisTele :: EpAnnForallTy +mkHsForAllInvisTele :: EpAnnForallInvis -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p) mkHsForAllInvisTele an invis_bndrs = HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs } @@ -202,7 +188,7 @@ type instance XHsOuterImplicit GhcRn = [Name] type instance XHsOuterImplicit GhcTc = [TyVar] -type instance XHsOuterExplicit GhcPs _ = EpAnnForallTy +type instance XHsOuterExplicit GhcPs _ = EpAnnForallInvis type instance XHsOuterExplicit GhcRn _ = NoExtField type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag] @@ -218,6 +204,10 @@ type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +type instance XHsTP GhcPs = NoExtField +type instance XHsTP GhcRn = HsTyPatRn +type instance XHsTP GhcTc = DataConCantHappen + -- | The extension field for 'HsPatSigType', which is only used in the -- renamer onwards. See @Note [Pattern signature binders and scoping]@. data HsPSRn = HsPSRn @@ -226,15 +216,79 @@ } deriving Data +-- HsTyPatRn is the extension field for `HsTyPat`, after renaming +-- E.g. pattern K @(Maybe (_x, a, b::Proxy k) +-- In the type pattern @(Maybe ...): +-- '_x' is a named wildcard +-- 'a' is explicitly bound +-- 'k' is implicitly bound +-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat +data HsTyPatRn = HsTPRn + { hstp_nwcs :: [Name] -- ^ Wildcard names + , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names + , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names + } + deriving Data + +-- | A variant of HsTyPatRn that uses Bags for efficient concatenation. +-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat +data HsTyPatRnBuilder = + HsTPRnB { + hstpb_nwcs :: Bag Name, + hstpb_imp_tvs :: Bag Name, + hstpb_exp_tvs :: Bag Name + } + +tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder +tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name} + +tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder +tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} = + mempty { + hstpb_nwcs = listToBag hsps_nwcs, + hstpb_imp_tvs = listToBag hsps_imp_tvs + } + +instance Semigroup HsTyPatRnBuilder where + HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 = + HsTPRnB + (nwcs1 `unionBags` nwcs2) + (imp_tvs1 `unionBags` imp_tvs2) + (exptvs1 `unionBags` exptvs2) + +instance Monoid HsTyPatRnBuilder where + mempty = HsTPRnB emptyBag emptyBag emptyBag + +buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn +buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} = + HsTPRn { + hstp_nwcs = bagToList hstpb_nwcs, + hstp_imp_tvs = bagToList hstpb_imp_tvs, + hstp_exp_tvs = bagToList hstpb_exp_tvs + } + +builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder +builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} = + HsTPRnB { + hstpb_nwcs = listToBag hstp_nwcs, + hstpb_imp_tvs = listToBag hstp_imp_tvs, + hstpb_exp_tvs = listToBag hstp_exp_tvs + } + type instance XXHsPatSigType (GhcPass _) = DataConCantHappen +type instance XXHsTyPat (GhcPass _) = DataConCantHappen type instance XHsSig (GhcPass _) = NoExtField type instance XXHsSigType (GhcPass _) = DataConCantHappen -hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p -hsSigWcType = sig_body . unXRec @p . hswc_body -dropWildCards :: LHsSigWcType pass -> LHsSigType pass +hsPatSigType :: HsPatSigType (GhcPass p) -> LHsType (GhcPass p) +hsPatSigType (HsPS { hsps_body = ty }) = ty + +hsSigWcType :: LHsSigWcType (GhcPass p) -> LHsType (GhcPass p) +hsSigWcType = sig_body . unLoc . hswc_body + +dropWildCards :: LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p) -- Drop the wildcard part of a LHsSigWcType dropWildCards sig_ty = hswc_body sig_ty @@ -250,7 +304,7 @@ mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField} -mkHsOuterExplicit :: EpAnnForallTy -> [LHsTyVarBndr flag GhcPs] +mkHsOuterExplicit :: EpAnnForallInvis -> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an , hso_bndrs = bndrs } @@ -260,7 +314,7 @@ HsSig { sig_ext = noExtField , sig_bndrs = mkHsOuterImplicit, sig_body = body } -mkHsExplicitSigType :: EpAnnForallTy +mkHsExplicitSigType :: EpAnnForallInvis -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs -> HsSigType GhcPs mkHsExplicitSigType an bndrs body = @@ -275,143 +329,272 @@ mkHsPatSigType ann x = HsPS { hsps_ext = ann , hsps_body = x } +mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs +mkHsTyPat x = HsTP { hstp_ext = noExtField + , hstp_body = x } + mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = [] } -------------------------------------------------- -type instance XUserTyVar (GhcPass _) = EpAnn [AddEpAnn] -type instance XKindedTyVar (GhcPass _) = EpAnn [AddEpAnn] - +type instance XTyVarBndr (GhcPass _) = AnnTyVarBndr type instance XXTyVarBndr (GhcPass _) = DataConCantHappen +type instance XBndrKind (GhcPass p) = NoExtField +type instance XBndrNoKind (GhcPass p) = NoExtField +type instance XXBndrKind (GhcPass p) = DataConCantHappen + +type instance XBndrVar (GhcPass p) = NoExtField + +type instance XBndrWildCard GhcPs = EpToken "_" +type instance XBndrWildCard GhcRn = NoExtField +type instance XBndrWildCard GhcTc = NoExtField + +type instance XXBndrVar (GhcPass p) = DataConCantHappen + +data AnnTyVarBndr + = AnnTyVarBndr { + atv_opens :: [EpaLocation], -- all "(" or all "{" + atv_closes :: [EpaLocation], -- all ")" or all "}" + atv_tv :: EpToken "'", + atv_dcolon :: TokDcolon + } deriving Data + +instance NoAnn AnnTyVarBndr where + noAnn = AnnTyVarBndr noAnn noAnn noAnn noAnn + -- | Return the attached flag hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag -hsTyVarBndrFlag (UserTyVar _ fl _) = fl -hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl +hsTyVarBndrFlag = tvb_flag -- By specialising to (GhcPass p) we know that XXTyVarBndr is DataConCantHappen --- so these two equations are exhaustive: extension construction can't happen +-- so the equation is exhaustive: extension construction can't happen -- | Set the attached flag setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass) -> HsTyVarBndr flag (GhcPass pass) -setHsTyVarBndrFlag f (UserTyVar x _ l) = UserTyVar x f l -setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k +setHsTyVarBndrFlag fl tvb = tvb { tvb_flag = fl } -- | Update the attached flag updateHsTyVarBndrFlag :: (flag -> flag') -> HsTyVarBndr flag (GhcPass pass) -> HsTyVarBndr flag' (GhcPass pass) -updateHsTyVarBndrFlag f (UserTyVar x flag name) = UserTyVar x (f flag) name -updateHsTyVarBndrFlag f (KindedTyVar x flag name ki) = KindedTyVar x (f flag) name ki +updateHsTyVarBndrFlag f tvb = tvb { tvb_flag = f (tvb_flag tvb) } +-- | Get the variable of the type variable binder +hsBndrVar :: HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass) +hsBndrVar = tvb_var + +-- | Get the kind of the type variable binder +hsBndrKind :: HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass) +hsBndrKind = tvb_kind + -- | Do all type variables in this 'LHsQTyVars' come with kind annotations? hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -instance NamedThing (HsTyVarBndr flag GhcRn) where - getName (UserTyVar _ _ v) = unLoc v - getName (KindedTyVar _ _ v _) = unLoc v +type instance XBndrRequired (GhcPass _) = NoExtField +type instance XBndrInvisible GhcPs = EpToken "@" +type instance XBndrInvisible GhcRn = NoExtField +type instance XBndrInvisible GhcTc = NoExtField + +type instance XXBndrVis (GhcPass _) = DataConCantHappen + +{- Note [Wildcard binders in disallowed contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In contexts where a type variable binder is expected (HsTyVarBndr), we usually +allow both named binders and wildcards, e.g. + + type Const1 a b = a -- ok + type Const2 a _ = a -- ok, too + +This applies to LHSs of data, newtype, type, class, type family and data family +declarations. However, we choose to reject wildcards in forall telescopes and +type family result variables (the latter being part of TypeFamilyDependencies): + + type family Fd a = _ -- disallowed (WildcardBndrInTyFamResultVar) + fn :: forall _. Int -- disallowed (WildcardBndrInForallTelescope) + +This restriction is placed solely because such binders have not been proposed +and there is no known use case for them. If we see user demand for wildcard +binders in these contexts, adding support for them would be as easy as dropping +the checks that reject them. The rest of the compiler can handle all wildcard +binders regardless of context by generating a fresh name (see `tcHsBndrVarName` +in GHC.Tc.Gen.HsType and `repHsBndrVar` in GHC.HsToCore.Quote). + +That is, in type declarations we have: + + type F _ = ... -- equivalent to ... + type F _a = ... -- where _a is fresh + +and the same principle could be applied to foralls: + + fn :: forall _. Int -- equivalent to ... + fn :: forall _a. Int -- where _a is fresh + +except the `forall _.` example is rejected by checkForAllTelescopeWildcardBndrs. +-} + type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] +type instance XTyVar (GhcPass _) = EpToken "'" type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = EpAnnCO -type instance XListTy (GhcPass _) = EpAnn AnnParen -type instance XTupleTy (GhcPass _) = EpAnn AnnParen -type instance XSumTy (GhcPass _) = EpAnn AnnParen -type instance XOpTy (GhcPass _) = EpAnn [AddEpAnn] -type instance XParTy (GhcPass _) = EpAnn AnnParen -type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn] +type instance XFunTy (GhcPass _) = NoExtField +type instance XListTy (GhcPass _) = AnnParen +type instance XTupleTy (GhcPass _) = AnnParen +type instance XSumTy (GhcPass _) = AnnParen +type instance XOpTy (GhcPass _) = NoExtField +type instance XParTy (GhcPass _) = (EpToken "(", EpToken ")") +type instance XIParamTy (GhcPass _) = TokDcolon type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] +type instance XKindSig (GhcPass _) = TokDcolon -type instance XAppKindTy (GhcPass _) = NoExtField +type instance XAppKindTy GhcPs = EpToken "@" +type instance XAppKindTy GhcRn = NoExtField +type instance XAppKindTy GhcTc = NoExtField type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy GhcTc = Kind -type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn] -type instance XBangTy (GhcPass _) = EpAnn [AddEpAnn] - -type instance XRecTy GhcPs = EpAnn AnnList -type instance XRecTy GhcRn = NoExtField -type instance XRecTy GhcTc = NoExtField +type instance XDocTy (GhcPass _) = NoExtField +type instance XConDeclField (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText) +type instance XXConDeclRecField (GhcPass _) = DataConCantHappen -type instance XExplicitListTy GhcPs = EpAnn [AddEpAnn] +type instance XExplicitListTy GhcPs = (EpToken "'", EpToken "[", EpToken "]") type instance XExplicitListTy GhcRn = NoExtField type instance XExplicitListTy GhcTc = Kind -type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn] +type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")") type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] type instance XTyLit (GhcPass _) = NoExtField -type instance XWildCardTy (GhcPass _) = NoExtField - -type instance XXType (GhcPass _) = HsCoreTy +type instance XWildCardTy GhcPs = EpToken "_" +type instance XWildCardTy GhcRn = NoExtField +type instance XWildCardTy GhcTc = NoExtField --- An escape hatch for tunnelling a Core 'Type' through 'HsType'. --- For more details on how this works, see: --- --- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType" --- --- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" -type HsCoreTy = Type +type instance XXType GhcPs = HsTypeGhcPsExt +type instance XXType GhcRn = HsCoreTy +type instance XXType GhcTc = DataConCantHappen type instance XNumTy (GhcPass _) = SourceText type instance XStrTy (GhcPass _) = SourceText type instance XCharTy (GhcPass _) = SourceText type instance XXTyLit (GhcPass _) = DataConCantHappen +type HsCoreTy = Type -oneDataConHsTy :: HsType GhcRn -oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) +-- Extension of HsType during parsing. +-- see Note [Trees That Grow] in Language.Haskell.Syntax.Extension +data HsTypeGhcPsExt + = HsCoreTy HsCoreTy + -- An escape hatch for tunnelling a Core 'Type' through 'HsType'. + -- For more details on how this works, see: + -- + -- @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType" + -- + -- @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" -manyDataConHsTy :: HsType GhcRn -manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName) + | HsBangTy (EpaLocation, EpToken "#-}", EpaLocation) + HsSrcBang + (LHsType GhcPs) + -- See Note [Parsing data type declarations] -hsLinear :: a -> HsScaled (GhcPass p) a -hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok)) + | HsRecTy (AnnList ()) + [LHsConDeclRecField GhcPs] + -- See Note [Parsing data type declarations] -hsUnrestricted :: a -> HsScaled (GhcPass p) a -hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok) +{- Note [Parsing data type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When parsing it is not always clear if we're parsing a constructor field type +or not. So during parsing we extend the type syntax to support bang annotations +and record braces. We do this through the extension constructor of (HsType GhcPs), +namely `HsTypeGhcPsExt`, adding data constructors for `HsBangTy` and `HsRecTy`. +Once parsing is done (i.e. (HsType GhcRn) and (HsType GhcTc)) these constructors +are not needed; instead the data is stored in `HsConDeclField`. It is an error +if it turns out the extensions were used outside of a constructor field type. +-} -isUnrestricted :: HsArrow GhcRn -> Bool -isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName -isUnrestricted _ = False +data EpArrowOrColon + = EpArrow !TokRarrow + | EpColon !TokDcolon + | EpPatBind + deriving Data --- | Convert an arrow into its corresponding multiplicity. In essence this --- erases the information of whether the programmer wrote an explicit --- multiplicity or a shorthand. -arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn -arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy -arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy -arrowToHsType (HsExplicitMult _ p _) = p +data EpLinear + = EpPct1 !(EpToken "%1") !EpArrowOrColon + | EpLolly !(EpToken "⊸") + deriving Data +instance NoAnn EpLinear where + noAnn = EpPct1 noAnn (EpArrow noAnn) + +type instance XUnannotated _ GhcPs = EpArrowOrColon +type instance XUnannotated _ GhcRn = NoExtField +type instance XUnannotated _ GhcTc = Mult + +type instance XLinearAnn _ GhcPs = EpLinear +type instance XLinearAnn _ GhcRn = NoExtField +type instance XLinearAnn _ GhcTc = Mult + +type instance XExplicitMult _ GhcPs = (EpToken "%", EpArrowOrColon) +type instance XExplicitMult _ GhcRn = NoExtField +type instance XExplicitMult _ GhcTc = Mult + +type instance XXMultAnnOf _ (GhcPass _) = DataConCantHappen + +multAnnToHsType :: HsMultAnn GhcRn -> Maybe (LHsType GhcRn) +multAnnToHsType = expandHsMultAnnOf (HsTyVar noAnn NotPromoted . fmap noUserRdr) + +-- | Convert an multiplicity annotation into its corresponding multiplicity. +-- If no annotation was written, `Nothing` is returned. +-- In this polymorphic function, `t` can be `HsType` or `HsExpr` +expandHsMultAnnOf :: (LocatedN Name -> t GhcRn) + -> HsMultAnnOf (LocatedA (t GhcRn)) GhcRn + -> Maybe (LocatedA (t GhcRn)) +expandHsMultAnnOf _mk_var HsUnannotated{} = Nothing +expandHsMultAnnOf mk_var (HsLinearAnn _) = Just (noLocA (mk_var (noLocA oneDataConName))) +expandHsMultAnnOf _mk_var (HsExplicitMult _ p) = Just p + instance - (OutputableBndrId pass) => - Outputable (HsArrow (GhcPass pass)) where + (Outputable mult, OutputableBndrId pass) => + Outputable (HsMultAnnOf mult (GhcPass pass)) where ppr arr = parens (pprHsArrow arr) -- See #18846 -pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc -pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False) -pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True) -pprHsArrow (HsExplicitMult _ p _) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) +pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsMultAnnOf mult (GhcPass pass) -> SDoc +pprHsArrow (HsUnannotated _) = pprArrowWithMultiplicity visArgTypeLike (Left False) +pprHsArrow (HsLinearAnn _) = pprArrowWithMultiplicity visArgTypeLike (Left True) +pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) -type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn] -type instance XXConDeclField (GhcPass _) = DataConCantHappen +-- Used to print, for instance, let bindings: +-- let %1 x = … +-- and record field declarations: +-- { x %1 :: … } +pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc +pprHsMultAnn (HsUnannotated _) = empty +pprHsMultAnn (HsLinearAnn _) = text "%1" +pprHsMultAnn (HsExplicitMult _ p) = text "%" <> ppr p +type instance XConDeclRecField (GhcPass _) = NoExtField +type instance XXConDeclRecField (GhcPass _) = DataConCantHappen + instance OutputableBndrId p - => Outputable (ConDeclField (GhcPass p)) where - ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty + => Outputable (HsConDeclRecField (GhcPass p)) where + ppr (HsConDeclRecField _ fld_n cfs) = pprMaybeWithDoc (cdf_doc cfs) (ppr_names fld_n <+> pprHsConDeclFieldWith ppr_mult cfs { cdf_doc = Nothing }) + where + ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc + ppr_names [n] = pprPrefixOcc n + ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns)) + ppr_mult :: HsMultAnn (GhcPass p) -> SDoc -> SDoc + ppr_mult mult tyDoc = pprHsMultAnn mult <+> dcolon <+> tyDoc + --------------------- hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] -- Get the lexically-scoped type variables of an LHsSigWcType: @@ -439,22 +622,32 @@ hsScopedKvs _ = [] --------------------- -hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> LIdP (GhcPass p) -hsTyVarLName (UserTyVar _ _ n) = n -hsTyVarLName (KindedTyVar _ _ n _) = n +hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p)) +hsTyVarLName tvb = + case hsBndrVar tvb of + HsBndrVar _ n -> Just n + HsBndrWildCard _ -> Nothing -hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) -hsTyVarName = unLoc . hsTyVarLName +hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p)) +hsTyVarName = fmap unLoc . hsTyVarLName -hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) +hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p)) hsLTyVarName = hsTyVarName . unLoc hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] -hsLTyVarNames = map hsLTyVarName +hsLTyVarNames = mapMaybe hsLTyVarName +hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)] +hsForAllTelescopeBndrs (HsForAllVis _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs +hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs + +hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)] +hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs +hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs + hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only -hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) +hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs) hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] -- All variables @@ -463,12 +656,12 @@ = kvs ++ hsLTyVarNames tvs hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN - => LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p)) + => LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p))) hsLTyVarLocName (L _ a) = hsTyVarLName a hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) +hsLTyVarLocNames qtvs = mapMaybe hsLTyVarLocName (hsQTvExplicit qtvs) -- | Get the kind signature of a type, ignoring parentheses: -- @@ -501,27 +694,26 @@ ************************************************************************ -} -mkAnonWildCardTy :: HsType GhcPs -mkAnonWildCardTy = HsWildCardTy noExtField +mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs +mkAnonWildCardTy tok = HsWildCardTy tok -mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN) +mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) => PromotionFlag - -> LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p)) + -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p) -mkHsOpTy prom ty1 op ty2 = HsOpTy noAnn prom ty1 op ty2 +mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2 mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppTy t1 t2 - = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2)) +mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2) mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy -mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p) +mkHsAppKindTy :: XAppKindTy (GhcPass p) + -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppKindTy ty at k - = addCLocAA ty k (HsAppKindTy noExtField ty at k) +mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k) {- ************************************************************************ @@ -537,60 +729,66 @@ -- splitHsFunType (a -> (b -> c)) = ([a,b], c) -- It returns API Annotations for any parens removed splitHsFunType :: - LHsType (GhcPass p) - -> ( [AddEpAnn], EpAnnComments -- The locations of any parens and + LHsType GhcPs + -> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and -- comments discarded - , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p)) + , [HsConDeclField GhcPs], LHsType GhcPs) splitHsFunType ty = go ty where - go (L l (HsParTy an ty)) + go (L l (HsParTy (op,cp) ty)) = let - (anns, cs, args, res) = splitHsFunType ty - anns' = anns ++ annParen2AddEpAnn an - cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an - in (anns', cs', args, res) + ((ops, cps), cs, args, res) = splitHsFunType ty + cs' = cs S.<> epAnnComments l + in ((ops++[op], cps ++ [cp]), cs', args, res) - go (L ll (HsFunTy (EpAnn _ _ cs) mult x y)) + go (L ll (HsFunTy _ mult x y)) | (anns, csy, args, res) <- splitHsFunType y - = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res) - where - L l t = x - x' = L (addCommentsToSrcAnn l cs) t + = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res) - go other = ([], emptyComments, [], other) + go other = (noAnn, emptyComments, [], other) -- | Retrieve the name of the \"head\" of a nested type application. -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more -- thorough. The purpose of this function is to examine instance heads, so it -- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.). -hsTyGetAppHead_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN) +hsTyGetAppHead_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) => LHsType (GhcPass p) - -> Maybe (LocatedN (IdP (GhcPass p))) + -> Maybe (LocatedN (IdOccP (GhcPass p))) hsTyGetAppHead_maybe = go where - go (L _ (HsTyVar _ _ ln)) = Just ln - go (L _ (HsAppTy _ l _)) = go l - go (L _ (HsAppKindTy _ t _ _)) = go t - go (L _ (HsOpTy _ _ _ ln _)) = Just ln - go (L _ (HsParTy _ t)) = go t - go (L _ (HsKindSig _ t _)) = go t - go _ = Nothing + go (L _ (HsTyVar _ _ ln)) = Just ln + go (L _ (HsAppTy _ l _)) = go l + go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsOpTy _ _ _ ln _)) = Just ln + go (L _ (HsParTy _ t)) = go t + go (L _ (HsKindSig _ t _)) = go t + go _ = Nothing ------------------------------------------------------------ +type instance XValArg (GhcPass _) = NoExtField + +type instance XTypeArg GhcPs = EpToken "@" +type instance XTypeArg GhcRn = NoExtField +type instance XTypeArg GhcTc = NoExtField + +type instance XArgPar (GhcPass _) = SrcSpan + +type instance XXArg (GhcPass _) = DataConCantHappen + -- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'. -lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan +lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan lhsTypeArgSrcSpan arg = case arg of - HsValArg tm -> getLocA tm - HsTypeArg at ty -> getTokenSrcSpan (getLoc at) `combineSrcSpans` getLocA ty + HsValArg _ tm -> getLocA tm + HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty HsArgPar sp -> sp -------------------------------- numVisibleArgs :: [HsArg p tm ty] -> Arity numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False + where is_vis (HsValArg _ _) = True + is_vis _ = False -------------------------------- @@ -605,7 +803,7 @@ -- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering -- @ pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg p tm ty] -> SDoc + => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc pprHsArgsApp thing fixity (argl:argr:args) | Infix <- fixity = let pp_op_app = hsep [ ppr_single_hs_arg argl @@ -620,7 +818,7 @@ -- | Pretty-print a prefix identifier to a list of 'HsArg's. ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) - => SDoc -> [HsArg p tm ty] -> SDoc + => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc ppr_hs_args_prefix_app acc [] = acc ppr_hs_args_prefix_app acc (arg:args) = case arg of @@ -630,8 +828,8 @@ -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty) - => HsArg p tm ty -> SDoc -ppr_single_hs_arg (HsValArg tm) = ppr tm + => HsArg (GhcPass p) tm ty -> SDoc +ppr_single_hs_arg (HsValArg _ tm) = ppr tm ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty -- GHC shouldn't be constructing ASTs such that this case is ever reached. -- Still, it's possible some wily user might construct their own AST that @@ -641,8 +839,8 @@ -- | This instance is meant for debug-printing purposes. If you wish to -- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where - ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg at ty) = text "HsTypeArg" <+> ppr at <+> ppr ty + ppr (HsValArg _ tm) = text "HsValArg" <+> ppr tm + ppr (HsTypeArg _ ty) = text "HsTypeArg" <+> ppr ty ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp -------------------------------- @@ -672,10 +870,10 @@ HsOuterImplicit{} -> ([], ignoreParens body) HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body) - (univs, ty1) = split_sig_ty ty - (reqs, ty2) = splitLHsQualTy ty1 - ((_an, exis), ty3) = splitLHsForAllTyInvis ty2 - (provs, ty4) = splitLHsQualTy ty3 + (univs, ty1) = split_sig_ty ty + (reqs, ty2) = splitLHsQualTy ty1 + (exis, ty3) = splitLHsForAllTyInvis ty2 + (provs, ty4) = splitLHsQualTy ty3 -- | Decompose a sigma type (of the form @forall . context => body@) -- into its constituent parts. @@ -695,8 +893,8 @@ -> ([LHsTyVarBndr Specificity (GhcPass p)] , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p)) splitLHsSigmaTyInvis ty - | ((_an,tvs), ty1) <- splitLHsForAllTyInvis ty - , (ctxt, ty2) <- splitLHsQualTy ty1 + | (tvs, ty1) <- splitLHsForAllTyInvis ty + , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) -- | Decompose a GADT type into its constituent parts. @@ -715,16 +913,29 @@ -- "GHC.Hs.Decls" for why this is important. splitLHsGadtTy :: LHsSigType GhcPs - -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs) + -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs) splitLHsGadtTy (L _ sig_ty) - | (outer_bndrs, rho_ty) <- split_bndrs sig_ty - , (mb_ctxt, tau_ty) <- splitLHsQualTy_KP rho_ty - = (outer_bndrs, mb_ctxt, tau_ty) + | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty + , (inner_bndrs, phi_ty) <- split_inner_bndrs sigma_ty + , (mb_ctxt, rho_ty) <- splitLHsQualTy_KP phi_ty + = case rho_ty of + L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs) + -- Bad! Record GADTs are not allowed to have inner_bndrs, + -- undo the split to get a proper error message later + -> (outer_bndrs, [], Nothing, sigma_ty) + _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty) where - split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) - split_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = + split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs) + split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) = (outer_bndrs, body_ty) + split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs) + split_inner_bndrs (L _ HsForAllTy { hst_tele = tele + , hst_body = body }) + = let ~(teles, t) = split_inner_bndrs body + in (tele:teles, t) + split_inner_bndrs t = ([], t) + -- | Decompose a type of the form @forall . body@ into its constituent -- parts. Only splits type variable binders that -- were quantified invisibly (e.g., @forall a.@, with a dot). @@ -741,11 +952,11 @@ -- Unlike 'splitLHsSigmaTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis :: - LHsType (GhcPass pass) -> ( (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]) + LHsType (GhcPass pass) -> ( [LHsTyVarBndr Specificity (GhcPass pass)] , LHsType (GhcPass pass)) splitLHsForAllTyInvis ty | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty) - = (fromMaybe (EpAnnNotUsed,[]) mb_tvbs, body) + = (fromMaybe [] mb_tvbs, body) -- | Decompose a type of the form @forall . body@ into its constituent -- parts. Only splits type variable binders that @@ -759,14 +970,13 @@ -- Unlike 'splitLHsForAllTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis_KP :: - LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]) + LHsType (GhcPass pass) -> (Maybe ([LHsTyVarBndr Specificity (GhcPass pass)]) , LHsType (GhcPass pass)) splitLHsForAllTyInvis_KP lty@(L _ ty) = case ty of - HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an - , hsf_invis_bndrs = tvs } + HsForAllTy { hst_tele = HsForAllInvis {hsf_invis_bndrs = tvs } , hst_body = body } - -> (Just (an, tvs), body) + -> (Just tvs, body) _ -> (Nothing, lty) -- | Decompose a type of the form @context => body@ into its constituent parts. @@ -820,9 +1030,9 @@ -- | Decompose a type class instance type (of the form -- @forall . context => instance_head@) into the @instance_head@ and -- retrieve the underlying class type constructor (if it exists). -getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN) +getLHsInstDeclClass_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN) => LHsSigType (GhcPass p) - -> Maybe (LocatedN (IdP (GhcPass p))) + -> Maybe (LocatedN (IdOccP (GhcPass p))) -- Works on (LHsSigType GhcPs) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty @@ -919,60 +1129,65 @@ FieldOcc * * ************************************************************************ --} -type instance XCFieldOcc GhcPs = NoExtField -type instance XCFieldOcc GhcRn = Name -type instance XCFieldOcc GhcTc = Id +Note [Ambiguous FieldOcc in record updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a "record field update" (`some_record{ field = expr }`), the field +occurrence may be ambiguous if there are multiple record types with that same +field label in scope. Instead of failing, we may attempt to do type-directed +disambiguation: if we typecheck the record field update, we can disambiguate +the `field` based on the record and field type. -type instance XXFieldOcc (GhcPass _) = DataConCantHappen +In practice, this means an identifier of a field occurrence +(`FieldOcc`) may have to go straight from `RdrName` to `Id`, since field +ambiguity makes it impossible to construct a `Name` for the field. -mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs -mkFieldOcc rdr = FieldOcc noExtField rdr +Since type-directed disambiguation is a GHC property rather than a property of +the GHC-Haskell AST, we still parameterise a `FieldOcc` occurrence by `IdP p`, +but in the case of the ambiguity we do the unthinkable and insert a mkUnboundName +in the name. Very bad, yes, but since type-directed disambiguation is on the way +out (see proposal https://github.com/ghc-proposals/ghc-proposals/pull/366), +we consider this acceptable for now. +see also Wrinkle [Disambiguating fields] and note [Type-directed record disambiguation] -type instance XUnambiguous GhcPs = NoExtField -type instance XUnambiguous GhcRn = Name -type instance XUnambiguous GhcTc = Id +NB: FieldOcc preserves the RdrName throughout its lifecycle for +exact printing purposes. +-} -type instance XAmbiguous GhcPs = NoExtField -type instance XAmbiguous GhcRn = NoExtField -type instance XAmbiguous GhcTc = Id +type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field +type instance XCFieldOcc GhcRn = RdrName +type instance XCFieldOcc GhcTc = RdrName -type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen +type instance XXFieldOcc (GhcPass p) = DataConCantHappen -instance Outputable (AmbiguousFieldOcc (GhcPass p)) where - ppr = ppr . ambiguousFieldOccRdrName +-------------------------------------------------------------------------------- -instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where - pprInfixOcc = pprInfixOcc . ambiguousFieldOccRdrName - pprPrefixOcc = pprPrefixOcc . ambiguousFieldOccRdrName +mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs +mkFieldOcc rdr = FieldOcc noExtField rdr -instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprPrefixOcc . unLoc +fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName +fieldOccRdrName fo = case ghcPass @p of + GhcPs -> unLoc $ foLabel fo + GhcRn -> foExt fo + GhcTc -> foExt fo -mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs -mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr +-- ToDo SPJ: remove +--fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p) +--fieldOccExt (FieldOcc { foExt = ext }) = ext -ambiguousFieldOccRdrName :: AmbiguousFieldOcc (GhcPass p) -> RdrName -ambiguousFieldOccRdrName = unLoc . ambiguousFieldOccLRdrName +fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName +fieldOccLRdrName fo = case ghcPass @p of + GhcPs -> foLabel fo + GhcRn -> case fo of + FieldOcc rdr sel -> + let (L l _) = sel + in L l rdr + GhcTc -> + let (L l _) = foLabel fo + in L l (foExt fo) -ambiguousFieldOccLRdrName :: AmbiguousFieldOcc (GhcPass p) -> LocatedN RdrName -ambiguousFieldOccLRdrName (Unambiguous _ rdr) = rdr -ambiguousFieldOccLRdrName (Ambiguous _ rdr) = rdr -selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id -selectorAmbiguousFieldOcc (Unambiguous sel _) = sel -selectorAmbiguousFieldOcc (Ambiguous sel _) = sel - -unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc -unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel -unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel - -ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc -ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr - {- ************************************************************************ * * @@ -982,10 +1197,10 @@ -} -- | Name of an operator in an operator application or section -data OpName = NormalOp Name -- ^ A normal identifier - | NegateOp -- ^ Prefix negation - | UnboundOp RdrName -- ^ An unbound identifier - | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence +data OpName = NormalOp (WithUserRdr Name) -- ^ A normal identifier + | NegateOp -- ^ Prefix negation + | UnboundOp RdrName -- ^ An unbound identifier + | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence instance Outputable OpName where ppr (NormalOp n) = ppr n @@ -1001,28 +1216,49 @@ ************************************************************************ -} +instance OutputableBndrId p => Outputable (HsBndrVar (GhcPass p)) where + ppr (HsBndrVar _ name) = ppr name + ppr (HsBndrWildCard _) = char '_' + class OutputableBndrFlag flag p where - pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc + pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc instance OutputableBndrFlag () p where - pprTyVarBndr (UserTyVar _ _ n) = ppr n - pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k] + pprTyVarBndr (HsTvb _ _ bvar bkind) = decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = parens_if_kind bkind d instance OutputableBndrFlag Specificity p where - pprTyVarBndr (UserTyVar _ SpecifiedSpec n) = ppr n - pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr n - pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k] - pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k] + pprTyVarBndr (HsTvb _ spec bvar bkind) = decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = case spec of + InferredSpec -> braces d + SpecifiedSpec -> parens_if_kind bkind d -instance OutputableBndrFlag (HsBndrVis p') p where - pprTyVarBndr (UserTyVar _ vis n) = pprHsBndrVis vis $ ppr n - pprTyVarBndr (KindedTyVar _ vis n k) = - pprHsBndrVis vis $ parens $ hsep [ppr n, dcolon, ppr k] +instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where + pprTyVarBndr (HsTvb _ bvis bvar bkind) = decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = case bvis of + HsBndrRequired _ -> parens_if_kind bkind d + HsBndrInvisible _ -> char '@' <> parens_if_kind bkind d -pprHsBndrVis :: HsBndrVis pass -> SDoc -> SDoc -pprHsBndrVis HsBndrRequired d = d -pprHsBndrVis (HsBndrInvisible _) d = char '@' <> d +instance OutputableBndrFlag ForAllTyFlag p where + pprTyVarBndr (HsTvb _ spec bvar bkind) = + text "forall" <+> decorate (ppr_hs_tvb bvar bkind) + where decorate :: SDoc -> SDoc + decorate d = case spec of + Inferred -> braces d <> dot + Specified -> parens_if_kind bkind d <> dot + Required -> parens_if_kind bkind d <+> text "->" +ppr_hs_tvb :: OutputableBndrId p => HsBndrVar (GhcPass p) -> HsBndrKind (GhcPass p) -> SDoc +ppr_hs_tvb bvar (HsBndrNoKind _) = ppr bvar +ppr_hs_tvb bvar (HsBndrKind _ k) = hsep [ppr bvar, dcolon, ppr k] + +parens_if_kind :: HsBndrKind (GhcPass p) -> SDoc -> SDoc +parens_if_kind (HsBndrNoKind _) d = d +parens_if_kind (HsBndrKind _ _) d = parens d + instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) = pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body @@ -1067,6 +1303,11 @@ instance (OutputableBndrId p) + => Outputable (HsTyPat (GhcPass p)) where + ppr (HsTP { hstp_body = ty }) = ppr ty + + +instance (OutputableBndrId p) => Outputable (HsTyLit (GhcPass p)) where ppr = ppr_tylit @@ -1078,24 +1319,41 @@ pprInfixOcc n = ppr n pprPrefixOcc n = ppr n -instance (Outputable tyarg, Outputable arg, Outputable rec) - => Outputable (HsConDetails tyarg arg rec) where - ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args - ppr (RecCon rec) = text "RecCon:" <+> ppr rec - ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon:" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] -instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where +pprHsConDeclFieldWith :: (OutputableBndrId p) + => (HsMultAnn (GhcPass p) -> SDoc -> SDoc) + -> HsConDeclField (GhcPass p) -> SDoc +pprHsConDeclFieldWith ppr_mult (CDF _ prag mark mult ty doc) = + pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty)) + +pprHsConDeclFieldNoMult :: (OutputableBndrId p) => HsConDeclField (GhcPass p) -> SDoc +pprHsConDeclFieldNoMult = pprHsConDeclFieldWith (\_ d -> d) + +hsPlainTypeField :: LHsType GhcPs -> HsConDeclField GhcPs +hsPlainTypeField = mkConDeclField (HsUnannotated (EpColon noAnn)) + +mkConDeclField :: HsMultAnn GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs +mkConDeclField mult (L _ (HsDocTy _ ty lds)) = (mkConDeclField mult ty) { cdf_doc = Just lds } +mkConDeclField mult (L _ (XHsType (HsBangTy ann (HsSrcBang srcTxt unp str) t))) = CDF (ann, srcTxt) unp str mult t Nothing +mkConDeclField mult t = CDF noAnn NoSrcUnpack NoSrcStrict mult t Nothing + +instance Outputable (XRecGhc (IdGhcP p)) => + Outputable (FieldOcc (GhcPass p)) where ppr = ppr . foLabel -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where - pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel - pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel +instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where + pprInfixOcc = pprInfixOcc . unXRec @(GhcPass pass) . foLabel + pprPrefixOcc = pprPrefixOcc . unXRec @(GhcPass pass) . foLabel -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where +instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass pass))) where pprInfixOcc = pprInfixOcc . unLoc pprPrefixOcc = pprPrefixOcc . unLoc - ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) @@ -1118,7 +1376,7 @@ => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = - pprHsForAll (mkHsForAllInvisTele noAnn bndrs) Nothing + pprHsForAllTelescope (mkHsForAllInvisTele noAnn bndrs) -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ -- only when @-dppr-debug@ is enabled. @@ -1126,13 +1384,16 @@ => HsForAllTelescope (GhcPass p) -> Maybe (LHsContext (GhcPass p)) -> SDoc pprHsForAll tele cxt - = pp_tele tele <+> pprLHsContext cxt - where - pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc - pp_tele tele = case tele of + = pprHsForAllTelescope tele <+> pprLHsContext cxt + +pprHsForAllTelescope :: forall p. OutputableBndrId p + => HsForAllTelescope (GhcPass p) + -> SDoc +pprHsForAllTelescope tele = + case tele of HsForAllVis { hsf_vis_bndrs = qtvs } -> pp_forall (space <> arrow) qtvs HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs - + where pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p) => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc pp_forall separator qtvs @@ -1156,30 +1417,9 @@ [L _ ty] -> ppr_mono_ty ty <+> darrow _ -> parens (interpp'SP ctxt) <+> darrow -pprConDeclFields :: OutputableBndrId p - => [LConDeclField (GhcPass p)] -> SDoc -pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) - where - ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, - cd_fld_doc = doc })) - = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty) - - ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc - ppr_names [n] = pprPrefixOcc n - ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns)) - -{- -Note [Printing KindedTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#3830 reminded me that we should really only print the kind -signature on a KindedTyVar if the kind signature was put there by the -programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, -rather than converting to KindedTyVars as before. - -(As it happens, the message in #3830 comes out a different way now, -and the problem doesn't show up; but having the flag on a KindedTyVar -seems like the Right Thing anyway.) --} +pprHsConDeclRecFields :: forall p. OutputableBndrId p + => [LHsConDeclRecField (GhcPass p)] -> SDoc +pprHsConDeclRecFields fields = braces (sep (punctuate comma (map ppr fields))) -- Printing works more-or-less as for Types @@ -1197,8 +1437,6 @@ ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] -ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty -ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name ppr_mono_ty (HsFunTy _ mult ty1 ty2) = ppr_fun_ty mult ty1 ty2 ppr_mono_ty (HsTupleTy _ con tys) @@ -1227,13 +1465,13 @@ ppr_mono_ty (HsExplicitListTy _ prom tys) | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) | otherwise = brackets (interpp'SP tys) -ppr_mono_ty (HsExplicitTupleTy _ tys) +ppr_mono_ty (HsExplicitTupleTy _ prom tys) -- Special-case unary boxed tuples so that they are pretty-printed as -- `'MkSolo x`, not `'(x)` | [ty] <- tys - = quote $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty] + = quote_tuple prom $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty] | otherwise - = quote $ parens (maybeAddSpace tys $ interpp'SP tys) + = quote_tuple prom $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t) = ppr t ppr_mono_ty (HsWildCardTy {}) = char '_' @@ -1241,7 +1479,7 @@ ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] -ppr_mono_ty (HsAppKindTy _ ty _ k) +ppr_mono_ty (HsAppKindTy _ ty k) = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 @@ -1255,11 +1493,16 @@ ppr_mono_ty (HsDocTy _ ty doc) = pprWithDoc doc $ ppr_mono_lty ty -ppr_mono_ty (XHsType t) = ppr t +ppr_mono_ty (XHsType t) = case ghcPass @p of + GhcPs -> case t of + HsCoreTy ty -> ppr ty + HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty + HsRecTy _ flds -> pprHsConDeclRecFields flds + GhcRn -> ppr t -------------------------- ppr_fun_ty :: (OutputableBndrId p) - => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc + => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc ppr_fun_ty mult ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2 @@ -1267,16 +1510,18 @@ in sep [p1, arr <+> p2] +quote_tuple :: PromotionFlag -> SDoc -> SDoc +quote_tuple IsPromoted doc = quote doc +quote_tuple NotPromoted doc = doc + -------------------------- -- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses -- under precedence @p@. -hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool +hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool hsTypeNeedsParens p = go_hs_ty where go_hs_ty (HsForAllTy{}) = p >= funPrec go_hs_ty (HsQualTy{}) = p >= funPrec - go_hs_ty (HsBangTy{}) = p > topPrec - go_hs_ty (HsRecTy{}) = False go_hs_ty (HsTyVar{}) = False go_hs_ty (HsFunTy{}) = p >= funPrec -- Special-case unary boxed tuple applications so that they are @@ -1296,7 +1541,7 @@ -- Special-case unary boxed tuple applications so that they are -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612) -- See Note [One-tuples] in GHC.Builtin.Types - go_hs_ty (HsExplicitTupleTy _ [_]) + go_hs_ty (HsExplicitTupleTy _ _ [_]) = p >= appPrec go_hs_ty (HsExplicitTupleTy{}) = False go_hs_ty (HsTyLit{}) = False @@ -1307,7 +1552,12 @@ go_hs_ty (HsOpTy{}) = p >= opPrec go_hs_ty (HsParTy{}) = False go_hs_ty (HsDocTy _ (L _ t) _) = go_hs_ty t - go_hs_ty (XHsType ty) = go_core_ty ty + go_hs_ty (XHsType t) = case ghcPass @p of + GhcPs -> case t of + HsCoreTy ty -> go_core_ty ty + HsBangTy{} -> p > topPrec + HsRecTy{} -> False + GhcRn -> go_core_ty t go_core_ty (TyVarTy{}) = False go_core_ty (AppTy{}) = p >= appPrec @@ -1339,8 +1589,6 @@ go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) | (L _ (c:_)) <- ctxt = goL c | otherwise = goL body - go (HsBangTy{}) = False - go (HsRecTy{}) = False go (HsTyVar _ p _) = isPromoted p go (HsFunTy _ _ arg _) = goL arg go (HsListTy{}) = False @@ -1356,7 +1604,7 @@ go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy _ t _) = goL t - go (HsAppKindTy _ t _ _) = goL t + go (HsAppKindTy _ t _) = goL t go (HsParTy{}) = False go (HsDocTy _ t _) = goL t go (XHsType{}) = False @@ -1364,7 +1612,7 @@ -- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is -- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply -- returns @ty@. -parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) +parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) parenthesizeHsType p lty@(L loc ty) | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty) | otherwise = lty @@ -1373,8 +1621,7 @@ -- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ -- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply -- returns @ctxt@ unchanged. -parenthesizeHsContext :: PprPrec - -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) +parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) parenthesizeHsContext p lctxt@(L loc ctxt) = case ctxt of [c] -> L loc [parenthesizeHsType p c] @@ -1388,7 +1635,6 @@ ************************************************************************ -} -type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA @@ -1401,8 +1647,7 @@ type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA -type instance Anno HsIPName = SrcAnn NoEpAnns -type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA +type instance Anno HsIPName = EpAnnCO +type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA -type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns -type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA diff --git a/GHC/Hs/Utils.hs b/GHC/Hs/Utils.hs --- a/GHC/Hs/Utils.hs +++ b/GHC/Hs/Utils.hs @@ -4,7 +4,7 @@ {-| Module : GHC.Hs.Utils Description : Generic helpers for the HsSyn type. -Copyright : (c) The University of Glasgow, 1992-2006 +Copyright : (c) The University of Glasgow, 1992-2023 Here we collect a variety of helper functions that construct or analyse HsSyn. All these functions deal with generic HsSyn; functions @@ -35,28 +35,33 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE RecordWildCards #-} module GHC.Hs.Utils( -- * Terms - mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, + mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, mkHsDictLet, mkHsLams, - mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo, + mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, + mkHsWrapPat, mkLHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, mkHsCmdIf, mkConLikeTc, - nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon, + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - mkLocatedList, + mkLocatedList, nlAscribe, + forgetUserRdr, noUserRdr, + -- * Bindings mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, @@ -105,7 +110,9 @@ hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, -- * Collecting implicit binders - lStmtsImplicits, hsValBindsImplicits, lPatImplicits + ImplicitFieldBinders(..), + lStmtsImplicits, hsValBindsImplicits, lPatImplicits, + lHsRecFieldsImplicits ) where import GHC.Prelude hiding (head, init, last, tail) @@ -130,7 +137,7 @@ import GHC.Core.Make ( mkChunkified ) import GHC.Core.Type ( Type, isUnliftedType ) -import GHC.Builtin.Types ( unitTy ) +import GHC.Builtin.Types ( unitTy, manyDataConTy ) import GHC.Types.Id import GHC.Types.Name @@ -144,17 +151,15 @@ import GHC.Types.SourceText import GHC.Data.FastString -import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import Control.Arrow ( first ) -import Data.Either ( partitionEithers ) import Data.Foldable ( toList ) import Data.List ( partition ) -import Data.List.NonEmpty ( nonEmpty ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.IntMap ( IntMap ) @@ -175,19 +180,19 @@ -} -- | @e => (e)@ -mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsPar e = L (getLoc e) (gHsPar e) mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) - ~ SrcAnn NoEpAnns) - => HsMatchContext (GhcPass p) - -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) + ~ EpAnn NoEpAnns) + => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> LocatedE [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) -mkSimpleMatch ctxt pats rhs +mkSimpleMatch ctxt (L l pats) rhs = L loc $ - Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats + Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = L l pats , m_grhss = unguardedGRHSs (locA loc) rhs noAnn } where loc = case pats of @@ -195,59 +200,59 @@ (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) - ~ SrcAnn NoEpAnns + ~ EpAnn NoEpAnns => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) unguardedGRHSs loc rhs an = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) - ~ SrcAnn NoEpAnns + ~ EpAnn NoEpAnns => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) - -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))] -unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)] + -> NonEmpty (LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))) +unguardedRHS an loc rhs = NE.singleton $ L (noAnnSrcSpan loc) (GRHS an [] rhs) type AnnoBody p body = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin - , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL + , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnLW , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA ) mkMatchGroup :: AnnoBody p body => Origin - -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = origin , mg_alts = matches } mkLamCaseMatchGroup :: AnnoBody p body => Origin - -> LamCaseVariant - -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] + -> HsLamVariant + -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) -mkLamCaseMatchGroup origin lc_variant (L l matches) +mkLamCaseMatchGroup origin lam_variant (L l matches) = mkMatchGroup origin (L l $ map fixCtxt matches) - where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant} + where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant} -mkLocatedList :: Semigroup a - => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2] +mkLocatedList :: (Semigroup a, NoAnn an) + => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2] mkLocatedList ms = case nonEmpty ms of Nothing -> noLocA [] Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2) +mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2) mkHsAppWith :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2) +mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2) mkHsApps :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) -mkHsApps = mkHsAppsWith addCLocAA +mkHsApps = mkHsAppsWith addCLocA mkHsAppsWith :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id)) @@ -257,42 +262,52 @@ mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn -mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct) +mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct) where t_body = hswc_body t - paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } + paren_wct = t { hswc_body = t_body } mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) - => [LPat (GhcPass p)] + => LocatedE [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) +mkHsLam (L l pats) body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches)) where - matches = mkMatchGroup (Generated SkipPmc) - (noLocA [mkSimpleMatch LambdaExpr pats' body]) + matches = mkMatchGroup (Generated OtherExpansion SkipPmc) + (noLocA [mkSimpleMatch (LamAlt LamSingle) (L l pats') body]) pats' = map (parenthesizePat appPrec) pats mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpEvLams dicts) expr +mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc] + -> LHsExpr GhcTc +mkHsSyntaxApps ann (SyntaxExprTc { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args + = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual mkLHsWrap arg_wraps args)) +mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args) + -- this function should never be called in scenarios where there is no + -- syntax expr + -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) - ~ SrcAnn NoEpAnns, + ~ EpAnn NoEpAnns, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) => LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) -mkHsCaseAlt pat expr - = mkSimpleMatch CaseAlt [pat] expr +mkHsCaseAlt (L l pat) expr + = mkSimpleMatch CaseAlt (L (l2l l) [L l pat]) expr nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys - = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id))) + = noLocA (mkHsWrap (mkWpTyApps tys) (mkHsVar (noLocA fun_id))) nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs @@ -306,7 +321,7 @@ mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat = parenthesizePat appPrec -nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) nlParPat p = noLocA (gParPat p) ------------------------------- @@ -316,17 +331,17 @@ mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs +mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> EpAnn AnnList + -> AnnList EpaLocation -> HsExpr GhcPs -mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] +mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-" -> Pat GhcPs -mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation +mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpToken "+" -> Pat GhcPs -- NB: The following functions all use noSyntaxExpr: the generated expressions @@ -335,7 +350,7 @@ -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) mkBodyStmt :: LocatedA (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs)) -mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) +mkPsBindStmt :: EpUniToken "<-" "←" -> LPat GhcPs -> LocatedA (bodyR GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn) -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn)) @@ -345,12 +360,12 @@ emptyRecStmt :: (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnL) + ~ SrcSpanAnnLW) => StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: (Anno [GenLocated (Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)] - ~ SrcSpanAnnL) + ~ SrcSpanAnnLW) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) @@ -358,9 +373,9 @@ (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnL) - => EpAnn AnnList - -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] + ~ SrcSpanAnnLW) + => AnnList (EpToken "rec") + -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) { recS_stmts = stmts } @@ -373,18 +388,21 @@ mkHsDo ctxt stmts = HsDo noAnn ctxt stmts mkHsDoAnns ctxt stmts anns = HsDo anns ctxt stmts mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn -mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns +mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns where - -- Strip the annotations from the location, they are in the embedded expr - last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr + -- Move the annotations to the top of the last_stmt + last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e) + last_stmt = L l last + -- last_stmt actually comes first in a list comprehension, consider all spans + loc = noAnnSrcSpan $ getHasLocList (last_stmt:stmts) -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf -> HsExpr GhcPs mkHsIf c a b anns = HsIf anns c a b -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf -> HsCmd GhcPs mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b @@ -392,17 +410,17 @@ mkNPlusKPat id lit anns = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkTransformByStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformByStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupByUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt :: AnnTransStmt -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt anns = TransStmt { trS_ext = anns , trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] @@ -451,14 +469,14 @@ emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking -mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) +mkLetStmt :: EpToken "let" -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds ------------------------------- -- | A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2 +mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (mkHsVar (noLocA op))) e2 mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) @@ -485,21 +503,17 @@ nlHsVar :: IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) -nlHsVar n = noLocA (HsVar noExtField (noLocA n)) - -nl_HsVar :: IsSrcSpanAnn p a - => IdP (GhcPass p) -> HsExpr (GhcPass p) -nl_HsVar n = HsVar noExtField (noLocA n) +nlHsVar n = noLocA (mkHsVar (noLocA n)) -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con)) nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) -nlHsLit n = noLocA (HsLit noComments n) +nlHsLit n = noLocA (HsLit noExtField n) nlHsIntLit :: Integer -> LHsExpr (GhcPass p) -nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n))) +nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n))) nlVarPat :: IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) @@ -509,18 +523,11 @@ nlLitPat l = noLocA (LitPat noExtField l) nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x)) +nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x)) nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc -nlHsSyntaxApps (SyntaxExprTc { syn_expr = fun - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) args - = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps" - mkLHsWrap arg_wraps args)) -nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args) - -- this function should never be called in scenarios where there is no - -- syntax expr +nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA nlHsApps :: IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) @@ -528,10 +535,10 @@ nlHsVarApps :: IsSrcSpanAnn p a => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p) -nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f)) - (map ((HsVar noExtField) . noLocA) xs)) +nlHsVarApps f xs = noLocA (foldl' mk (mkHsVar (noLocA f)) + (map (mkHsVar . noLocA) xs)) where - mk f a = HsApp noComments (noLocA f) (noLocA a) + mk f a = HsApp noExtField (noLocA f) (noLocA a) nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars) @@ -551,28 +558,28 @@ nlConPat con pats = noLocA $ ConPat { pat_con_ext = noAnn , pat_con = noLocA con - , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats) + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) } nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn nlConPatName con pats = noLocA $ ConPat { pat_con_ext = noExtField - , pat_con = noLocA con - , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats) + , pat_con = noLocA (noUserRdr con) + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) } nlNullaryConPat :: RdrName -> LPat GhcPs nlNullaryConPat con = noLocA $ ConPat { pat_con_ext = noAnn , pat_con = noLocA con - , pat_args = PrefixCon [] [] + , pat_args = PrefixCon [] } nlWildConPat :: DataCon -> LPat GhcPs nlWildConPat con = noLocA $ ConPat { pat_con_ext = noAnn , pat_con = noLocA $ getRdrName con - , pat_args = PrefixCon [] $ + , pat_args = PrefixCon $ replicate (dataConSourceArity con) nlWildPat } @@ -593,14 +600,14 @@ nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2) nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs -nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs --- AZ:Is this used? -nlHsLam match = noLocA $ HsLam noExtField - $ mkMatchGroup (Generated SkipPmc) (noLocA [match]) +nlHsLam match = noLocA $ HsLam noAnn LamSingle + $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match]) + nlHsPar e = noLocA (gHsPar e) -- nlHsIf should generate if-expressions which are NOT subject to @@ -609,42 +616,68 @@ nlHsIf cond true false = noLocA (HsIf noAnn cond true false) nlHsCase expr matches - = noLocA (HsCase noAnn expr (mkMatchGroup (Generated SkipPmc) (noLocA matches))) + = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches))) nlList exprs = noLocA (ExplicitList noAnn exprs) nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsTyVar :: IsSrcSpanAnn p a +nlHsTyVar :: forall p a. IsSrcSpanAnn p a => PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p) -nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: forall p. IsPass p + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t)) -nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x)) -nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b) +nlHsAppTy f t = noLocA (HsAppTy noExtField f t) +nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA $ noUserRdrP @p x)) +nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated x) a b) + where + x = case ghcPass @p of + GhcPs -> EpArrow noAnn + GhcRn -> noExtField + GhcTc -> manyDataConTy nlHsParTy t = noLocA (HsParTy noAnn t) -nlHsTyConApp :: IsSrcSpanAnn p a +nlHsTyConApp :: forall p a. IsSrcSpanAnn p a => PromotionFlag - -> LexicalFixity -> IdP (GhcPass p) + -> LexicalFixity -> IdOccP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp prom fixity tycon tys | Infix <- fixity - , HsValArg ty1 : HsValArg ty2 : rest <- tys - = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest + , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys + = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest | otherwise - = foldl' mk_app (nlHsTyVar prom tycon) tys + = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys where mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p) - mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg + mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg -- parenthesize things like `(A + B) C` - mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty)) - mk_app fun (HsTypeArg at ki) = noLocA (HsAppKindTy noExtField fun at (parenthesizeHsType appPrec ki)) - mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun) + mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty + mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki + mk_app fun (HsArgPar _) = nlHsParTy fun -nlHsAppKindTy :: +-- | Turn an 'IdP' into an 'IdOccP', with no user-written 'RdrName' information. +noUserRdrP :: forall p. IsPass p => IdP (GhcPass p) -> IdOccP (GhcPass p) +noUserRdrP = + case ghcPass @p of + GhcPs -> id + GhcRn -> noUserRdr + GhcTc -> id + +-- | Turn an 'IdOccP' into an 'IdP', discarding the user-written 'RdrName'. +forgetUserRdr :: forall p. IsPass p => IdOccP (GhcPass p) -> IdP (GhcPass p) +forgetUserRdr = + case ghcPass @p of + GhcPs -> id + GhcRn -> \ (WithUserRdr _rdr n) -> n + GhcTc -> id + +nlHsAppKindTy :: forall p. IsPass p => LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) -nlHsAppKindTy f k - = noLocA (HsAppKindTy noExtField f noHsTok (parenthesizeHsType appPrec k)) +nlHsAppKindTy f k = noLocA (HsAppKindTy x f k) + where + x = case ghcPass @p of + GhcPs -> noAnn + GhcRn -> noExtField + GhcTc -> noExtField {- Tuples. All these functions are *pre-typechecker* because they lack @@ -656,7 +689,7 @@ -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] _ = e mkLHsTupleExpr es ext - = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed + = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed mkLHsVarTuple :: IsSrcSpanAnn p a => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) @@ -666,7 +699,7 @@ nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLocA (TuplePat noAnn pats box) -missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs +missingTupArg :: EpAnn Bool -> HsTupArg GhcPs missingTupArg ann = Missing ann mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn @@ -700,12 +733,12 @@ -- | Convert an 'LHsType' to an 'LHsSigType'. hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs -hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of +hsTypeToHsSigType lty@(L loc ty) = case ty of HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an , hsf_invis_bndrs = bndrs } , hst_body = body } - -> mkHsExplicitSigType an bndrs body - _ -> mkHsImplicitSigType lty + -> L loc $ mkHsExplicitSigType an bndrs body + _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc -- | Convert an 'LHsType' to an 'LHsSigWcType'. hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs @@ -748,6 +781,13 @@ = L loc (ClassOpSig anns False nms (dropWildCards ty)) fiddle sig = sig + +-- | Type ascription: (e :: ty) +nlAscribe :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs +nlAscribe ty e = noLocA $ ExprWithTySig noAnn e + $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType + $ nlHsTyVar NotPromoted ty + {- ********************************************************************* * * --------- HsWrappers: type args, dict args, casts --------- @@ -759,7 +799,7 @@ mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc mkHsWrap co_fn e | isIdHsWrapper co_fn = e -mkHsWrap co_fn e = XExpr (WrapExpr $ HsWrap co_fn e) +mkHsWrap co_fn e = XExpr (WrapExpr co_fn e) mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr GhcTc -> HsExpr GhcTc @@ -783,6 +823,9 @@ mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = XPat $ CoPat co_fn p ty +mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc +mkLHsWrapPat co_fn (L loc p) ty = L loc (mkHsWrapPat co_fn p ty) + mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPatCo co pat ty | isReflCo co = pat | otherwise = XPat $ CoPat (mkWpCastN co) pat ty @@ -818,7 +861,7 @@ } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs -mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs +mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var (noLocA []) rhs mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc mkVarBind var rhs = L (getLoc rhs) $ @@ -826,7 +869,7 @@ var_id = var, var_rhs = rhs } mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs - -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs + -> LPat GhcPs -> HsPatSynDir GhcPs -> AnnPSB -> HsBind GhcPs mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb where psb = PSB{ psb_ext = anns @@ -837,9 +880,9 @@ -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix. -isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool +isInfixFunBind :: HsBindLR (GhcPass p1) (GhcPass p2) -> Bool isInfixFunBind (FunBind { fun_matches = MG _ matches }) - = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches) + = any (isInfixMatch . unLoc) (unLoc matches) isInfixFunBind _ = False -- |Return the 'SrcSpan' encompassing the contents of any enclosed binds @@ -849,14 +892,14 @@ = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) where bsSpans :: [SrcSpan] - bsSpans = map getLocA $ bagToList bs + bsSpans = map getLocA bs sigsSpans :: [SrcSpan] sigsSpans = map getLocA sigs spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs))) = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans) where bsSpans :: [SrcSpan] - bsSpans = map getLocA $ concatMap (bagToList . snd) bs + bsSpans = map getLocA $ concatMap snd bs sigsSpans :: [SrcSpan] sigsSpans = map getLocA sigs spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) @@ -865,30 +908,33 @@ ------------ -- | Convenience function using 'mkFunBind'. -- This is for generated bindings only, do not use for user-written code. -mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] +mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> LocatedE [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr - = L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun) - [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr - emptyLocalBinds] + = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun) + [mkMatch ctxt pats expr emptyLocalBinds] + where + ctxt :: HsMatchContextPs + ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn -- | Make a prefix, non-strict function 'HsMatchContext' -mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p -mkPrefixFunRhs n = FunRhs { mc_fun = n - , mc_fixity = Prefix - , mc_strictness = NoSrcStrict } +mkPrefixFunRhs :: fn -> AnnFunRhs -> HsMatchContext fn +mkPrefixFunRhs n an = FunRhs { mc_fun = n + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict + , mc_an = an } ------------ mkMatch :: forall p. IsPass p - => HsMatchContext (GhcPass p) - -> [LPat (GhcPass p)] + => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> LocatedE [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr binds - = noLocA (Match { m_ext = noAnn + = noLocA (Match { m_ext = noExtField , m_ctxt = ctxt - , m_pats = map mkParPat pats + , m_pats = pats , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds }) {- @@ -1009,7 +1055,7 @@ isUnliftedHsBind (PatSynBind {}) = panic "isUnliftedBind: PatSynBind" isUnliftedHsBinds :: LHsBinds GhcTc -> Bool -isUnliftedHsBinds = anyBag (isUnliftedHsBind . unLoc) +isUnliftedHsBinds = any (isUnliftedHsBind . unLoc) is_unlifted_id :: Id -> Bool is_unlifted_id id = isUnliftedType (idType id) @@ -1019,7 +1065,7 @@ -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? isBangedHsBind :: HsBind GhcTc -> Bool isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds })) - = anyBag (isBangedHsBind . unLoc) binds + = any (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) | [L _ match] <- unLoc $ mg_alts matches , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match @@ -1125,28 +1171,28 @@ ----------------- Statements -------------------------- -- collectLStmtsBinders - :: CollectPass (GhcPass idL) + :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> [LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectLStmtsBinders flag = concatMap (collectLStmtBinders flag) collectStmtsBinders - :: CollectPass (GhcPass idL) + :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectStmtsBinders flag = concatMap (collectStmtBinders flag) collectLStmtBinders - :: CollectPass (GhcPass idL) + :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] collectLStmtBinders flag = collectStmtBinders flag . unLoc collectStmtBinders - :: CollectPass (GhcPass idL) + :: forall idL idR body . (IsPass idL, IsPass idR, CollectPass (GhcPass idL)) => CollectFlag (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] @@ -1156,15 +1202,19 @@ LetStmt _ binds -> collectLocalBinders flag binds BodyStmt {} -> [] LastStmt {} -> [] - ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] + ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss] TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss - ApplicativeStmt _ args _ -> concatMap collectArgBinders args - where - collectArgBinders = \case - (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat - (_, ApplicativeArgMany { bv_pattern = pat }) -> collectPatBinders flag pat + XStmtLR x -> case ghcPass :: GhcPass idR of + GhcRn -> collectApplicativeStmtBndrs x + GhcTc -> collectApplicativeStmtBndrs x + where + collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)] + collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args + collectArgBinders = \case + ApplicativeArgOne { app_arg_pattern = pat } -> collectPatBinders flag pat + ApplicativeArgMany { bv_pattern = pat } -> collectPatBinders flag pat ----------------- Patterns -------------------------- @@ -1182,14 +1232,18 @@ -> [IdP p] collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats - ------------- --- | Indicate if evidence binders have to be collected. +-- | Indicate if evidence binders and type variable binders have +-- to be collected. -- --- This type is used as a boolean (should we collect evidence binders or not?) --- but also to pass an evidence that the AST has been typechecked when we do --- want to collect evidence binders, otherwise these binders are not available. +-- This type enumerates the modes of collecting bound variables +-- | evidence | type | term | ghc | +-- | binders | variables | variables | pass | +-- -------------------------------------------- +-- CollNoDictBinders | no | no | yes | any | +-- CollWithDictBinders | yes | no | yes | GhcTc | +-- CollVarTyVarBinders | no | yes | yes | GhcRn | -- -- See Note [Dictionary binders in ConPatOut] data CollectFlag p where @@ -1197,7 +1251,10 @@ CollNoDictBinders :: CollectFlag p -- | Collect evidence binders CollWithDictBinders :: CollectFlag GhcTc + -- | Collect variable and type variable binders, but no evidence binders + CollVarTyVarBinders :: CollectFlag GhcRn + collect_lpat :: forall p. CollectPass p => CollectFlag p -> LPat p @@ -1215,28 +1272,50 @@ WildPat _ -> bndrs LazyPat _ pat -> collect_lpat flag pat bndrs BangPat _ pat -> collect_lpat flag pat bndrs - AsPat _ a _ pat -> unXRec @p a : collect_lpat flag pat bndrs + AsPat _ a pat -> unXRec @p a : collect_lpat flag pat bndrs ViewPat _ _ pat -> collect_lpat flag pat bndrs - ParPat _ _ pat _ -> collect_lpat flag pat bndrs + ParPat _ pat -> collect_lpat flag pat bndrs ListPat _ pats -> foldr (collect_lpat flag) bndrs pats TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats + OrPat _ _ -> [] + -- See Note [Implementation of OrPatterns], Renamer: + -- evidence binders in an OrPat currently aren't visible outside their + -- binding pattern, so we return []. SumPat _ pat _ _ -> collect_lpat flag pat bndrs LitPat _ _ -> bndrs NPat {} -> bndrs NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs - SigPat _ pat _ -> collect_lpat flag pat bndrs + SigPat _ pat sig -> case flag of + CollNoDictBinders -> collect_lpat flag pat bndrs + CollWithDictBinders -> collect_lpat flag pat bndrs + CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig XPat ext -> collectXXPat @p flag ext bndrs SplicePat ext _ -> collectXSplicePat @p flag ext bndrs + EmbTyPat _ tp -> collect_ty_pat_bndrs flag tp bndrs + InvisPat _ tp -> collect_ty_pat_bndrs flag tp bndrs + -- See Note [Dictionary binders in ConPatOut] ConPat {pat_args=ps} -> case flag of CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) ++ collectEvBinders (cpt_binds (pat_con_ext pat)) + CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" +collect_ty_pat_bndrs :: CollectFlag p -> HsTyPat (NoGhcTc p) -> [IdP p] -> [IdP p] +collect_ty_pat_bndrs CollNoDictBinders _ bndrs = bndrs +collect_ty_pat_bndrs CollWithDictBinders _ bndrs = bndrs +collect_ty_pat_bndrs CollVarTyVarBinders tp bndrs = collectTyPatBndrs tp ++ bndrs + +collectTyPatBndrs :: HsTyPat GhcRn -> [Name] +collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs + +collectPatSigBndrs :: HsPatSigType GhcRn -> [Name] +collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs + add_ev_bndr :: EvBind -> [Id] -> [Id] add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs | otherwise = bs @@ -1271,7 +1350,6 @@ GhcTc -> case ext of AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++) -- I don't think we want the binders from the abe_binds - -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type collectXSplicePat flag ext = @@ -1371,7 +1449,7 @@ (foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)) where getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (foExt . unLoc) fs + getSelectorNames (ns, fs) = map unLoc ns ++ map (unLoc . foLabel . unLoc) fs ------------------- @@ -1452,7 +1530,7 @@ -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) - = foldr addPatSynSelector [] . unionManyBags $ map snd binds + = foldr addPatSynSelector [] . concat $ map snd binds addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels @@ -1464,7 +1542,7 @@ => [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds = [ psb | (_, lbinds) <- binds - , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ] + , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ] ------------------- hsLInstDeclBinders :: (IsPass p, OutputableBndrId p) @@ -1576,16 +1654,16 @@ get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p) -> (Maybe [Located Int], FieldIndices p) get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds - get_flds_h98 seen (PrefixCon _ []) = (Just [], seen) + get_flds_h98 seen (PrefixCon []) = (Just [], seen) get_flds_h98 seen _ = (Nothing, seen) get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p) -> (Maybe [Located Int], FieldIndices p) - get_flds_gadt seen (RecConGADT flds _) = first Just $ get_flds seen flds - get_flds_gadt seen (PrefixConGADT []) = (Just [], seen) + get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds + get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen) get_flds_gadt seen _ = (Nothing, seen) - get_flds :: FieldIndices p -> LocatedL [LConDeclField (GhcPass p)] + get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)] -> ([Located Int], FieldIndices p) get_flds seen flds = foldr add_fld ([], seen) fld_names @@ -1593,7 +1671,7 @@ add_fld fld (is, ixs) = let (i, ixs') = insertField fld ixs in (i:is, ixs') - fld_names = concatMap (cd_fld_names . unLoc) (unLoc flds) + fld_names = concatMap (cdrf_names . unLoc) (unLoc flds) -- | A bijection between record fields of a datatype and integers, -- used to implement Note [Collecting record fields in data declarations]. @@ -1613,7 +1691,7 @@ , fieldIndices = Map.empty , newInt = 0 } -insertField :: LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p) +insertField :: IsPass p => LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p) insertField new_fld fi@(FieldIndices flds idxs new_idx) | Just i <- Map.lookup rdr idxs = (L loc i, fi) @@ -1624,7 +1702,7 @@ (new_idx + 1)) where loc = getLocA new_fld - rdr = unLoc . foLabel . unLoc $ new_fld + rdr = fieldOccRdrName . unLoc $ new_fld {- @@ -1651,41 +1729,77 @@ * * ************************************************************************ -The job of this family of functions is to run through binding sites and find the set of all Names -that were defined "implicitly", without being explicitly written by the user. +The job of the following family of functions is to run through binding sites and find +the set of all Names that were defined "implicitly", without being explicitly written +by the user. -The main purpose is to find names introduced by record wildcards so that we can avoid -warning the user when they don't use those names (#4404) +Note [Collecting implicit binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We collect all the RHS Names that are implicitly introduced by record wildcards, +so that we can: -Since the addition of -Wunused-record-wildcards, this function returns a pair -of [(SrcSpan, [Name])]. Each element of the list is one set of implicit -binders, the first component of the tuple is the document describes the possible -fix to the problem (by removing the ..). + - avoid warning the user when they don't use those names (#4404), + - report deprecation warnings for deprecated fields that are used (#23382). -This means there is some unfortunate coupling between this function and where it -is used but it's only used for one specific purpose in one place so it seemed -easier. +The functions that collect implicit binders return a collection of 'ImplicitFieldBinders', +which associates each implicitly-introduced record field with the bound variables in the +RHS of the record field pattern, e.g. in + + data R = MkR { fld :: Int } + foo (MkR { .. }) = fld + +the renamer will elaborate this to + + foo (MkR { fld = fld_var }) = fld_var + +and the implicit binders function will return + + [ ImplicitFieldBinders { implFlBndr_field = fld + , implFlBndr_binders = [fld_var] } ] + +This information is then used: + + - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit + a warning when a record wildcard binds no new variables (redundant record wildcard) + or none of the bound variables are used (unused record wildcard). + - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning + when the field is deprecated and any of the binders are used. + +NOTE: the implFlBndr_binders field should always be a singleton + (since the RHS of an implicit binding should always be a VarPat, + created in rnHsRecPatsAndThen.mkVarPat) + -} -lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] - -> [(SrcSpan, [Name])] +-- | All binders corresponding to a single implicit record field pattern. +-- +-- See Note [Collecting implicit binders]. +data ImplicitFieldBinders + = ImplicitFieldBinders { implFlBndr_field :: Name + -- ^ The 'Name' of the record field + , implFlBndr_binders :: [Name] + -- ^ The binders of the RHS of the record field pattern + -- (in practice, always a singleton: see Note [Collecting implicit binders]) + } + +lStmtsImplicits :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] + -> [(SrcSpan, [ImplicitFieldBinders])] lStmtsImplicits = hs_lstmts where - hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] - -> [(SrcSpan, [Name])] + hs_lstmts :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] + -> [(SrcSpan, [ImplicitFieldBinders])] hs_lstmts = concatMap (hs_stmt . unLoc) - hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR))) - -> [(SrcSpan, [Name])] + hs_stmt :: forall idR body . IsPass idR => StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR))) + -> [(SrcSpan, [ImplicitFieldBinders])] hs_stmt (BindStmt _ pat _) = lPatImplicits pat - hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args - where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat - do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts + hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of + GhcRn -> hs_applicative_stmt x + GhcTc -> hs_applicative_stmt x hs_stmt (LetStmt _ binds) = hs_local_binds binds hs_stmt (BodyStmt {}) = [] hs_stmt (LastStmt {}) = [] - hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs - , s <- ss] + hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- toList xs , s <- ss] hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss @@ -1693,19 +1807,30 @@ hs_local_binds (HsIPBinds {}) = [] hs_local_binds (EmptyLocalBinds _) = [] -hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] + hs_applicative_stmt (ApplicativeStmt _ args _) = concatMap do_arg args + where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat + do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts + +hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) + -> [(SrcSpan, [ImplicitFieldBinders])] hsValBindsImplicits (XValBindsLR (NValBinds binds _)) = concatMap (lhsBindsImplicits . snd) binds hsValBindsImplicits (ValBinds _ binds _) = lhsBindsImplicits binds -lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])] -lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) [] +lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])] +lhsBindsImplicits = concatMap (lhs_bind . unLoc) where lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat lhs_bind _ = [] -lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])] +-- | Collect all record wild card binders in the given pattern. +-- +-- These are all the variables bound in all (possibly nested) record wildcard patterns +-- appearing inside the pattern. +-- +-- See Note [Collecting implicit binders]. +lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])] lPatImplicits = hs_lpat where hs_lpat lpat = hs_pat (unLoc lpat) @@ -1714,33 +1839,44 @@ hs_pat (LazyPat _ pat) = hs_lpat pat hs_pat (BangPat _ pat) = hs_lpat pat - hs_pat (AsPat _ _ _ pat) = hs_lpat pat + hs_pat (AsPat _ _ pat) = hs_lpat pat hs_pat (ViewPat _ _ pat) = hs_lpat pat - hs_pat (ParPat _ _ pat _) = hs_lpat pat + hs_pat (ParPat _ pat) = hs_lpat pat hs_pat (ListPat _ pats) = hs_lpats pats hs_pat (TuplePat _ pats _) = hs_lpats pats - hs_pat (SigPat _ pat _) = hs_lpat pat - hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps + hs_pat (ConPat {pat_args=ps}) = details ps hs_pat _ = [] - details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] - details _ (PrefixCon _ ps) = hs_lpats ps - details n (RecCon fs) = - [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] - ++ hs_lpats explicit_pats + details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])] + details (PrefixCon ps) = hs_lpats ps + details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds })) + = hs_lpats $ map (hfbRHS . unLoc) rec_flds + details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds })) + = [(l2l err_loc, implicit_field_binders)] + ++ hs_lpats explicit_pats - where implicit_pats = map (hfbRHS . unLoc) implicit - explicit_pats = map (hfbRHS . unLoc) explicit + where (explicit_pats, implicit_field_binders) + = rec_field_expl_impl rec_flds rec_dotdot + details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 - (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld - | (i, fld) <- [0..] `zip` rec_flds fs - , let pat_explicit = - maybe True ((i<) . unRecFieldsDotDot . unLoc) - (rec_dotdot fs)] - err_loc = maybe (getLocA n) getLoc (rec_dotdot fs) +lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)] + -> RecFieldsDotDot + -> [ImplicitFieldBinders] +lHsRecFieldsImplicits rec_flds rec_dotdot + = snd $ rec_field_expl_impl rec_flds rec_dotdot - details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 +rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)] + -> RecFieldsDotDot + -> ([LPat GhcRn], [ImplicitFieldBinders]) +rec_field_expl_impl rec_flds (RecFieldsDotDot { .. }) + = ( map (hfbRHS . unLoc) explicit_binds + , map implicit_field_binders implicit_binds ) + where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds + implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs })) + = ImplicitFieldBinders + { implFlBndr_field = unLoc $ foLabel (fld :: FieldOcc GhcRn) + , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs } diff --git a/GHC/HsToCore.hs b/GHC/HsToCore.hs --- a/GHC/HsToCore.hs +++ b/GHC/HsToCore.hs @@ -22,14 +22,12 @@ import GHC.Driver.Config import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) import GHC.Driver.Config.HsToCore.Ticks -import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Plugins import GHC.Hs -import GHC.HsToCore.Usage import GHC.HsToCore.Monad import GHC.HsToCore.Errors.Types import GHC.HsToCore.Expr @@ -41,7 +39,8 @@ import GHC.HsToCore.Docs import GHC.Tc.Types -import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceLoad ) +import GHC.Tc.Types.Origin ( Position(..), mkArgPos ) +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) import GHC.Tc.Module ( runTcInteractive ) import GHC.Core.Type @@ -53,6 +52,7 @@ import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Coercion +import GHC.Core.Predicate( scopedSort, mkNomEqPred ) import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules @@ -63,20 +63,20 @@ 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 ) import GHC.Utils.Error import GHC.Utils.Outputable -import GHC.Utils.Panic.Plain +import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Id.Info +import GHC.Types.Id.Make ( mkRepPolyIdConcreteTyVars ) import GHC.Types.ForeignStubs import GHC.Types.Avail import GHC.Types.Basic @@ -97,7 +97,8 @@ import Data.List (partition) import Data.IORef -import Data.Traversable (for) +import GHC.Iface.Make (mkRecompUsageInfo) +import GHC.Runtime.Interpreter (interpreterProfiled) {- ************************************************************************ @@ -120,26 +121,23 @@ tcg_imports = imports, tcg_exports = exports, tcg_keep = keep_var, - tcg_th_splice_used = tc_splice_used, tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, - tcg_merged = merged, tcg_warns = warns, tcg_anns = anns, tcg_binds = binds, tcg_imp_specs = imp_specs, - tcg_dependent_files = dependent_files, tcg_ev_binds = ev_binds, tcg_th_foreign_files = th_foreign_files_var, tcg_fords = fords, 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, tcg_complete_matches = complete_matches, tcg_self_boot = self_boot }) @@ -154,6 +152,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) @@ -163,13 +162,12 @@ mod mod_loc export_set (typeEnvTyCons type_env) binds else return (binds, Nothing) - ; modBreaks <- for - [ (i, s) - | i <- hsc_interp hsc_env - , (_, s) <- m_tickInfo - , breakpointsAllowed dflags - ] - $ \(interp, specs) -> mkModBreaks interp mod specs + ; let modBreaks + | Just (_, specs) <- m_tickInfo + , breakpointsAllowed dflags + = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs + | otherwise + = Nothing ; ds_hpc_info <- case m_tickInfo of Just (orig_file2, ticks) @@ -179,7 +177,7 @@ then writeMixEntries (hpcDir dflags) mod ticks orig_file2 else return 0 -- dummy hash when none are written pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo - _ -> pure $ emptyHpcInfo other_hpc_info + _ -> pure $ emptyHpcInfo ; (msgs, mb_res) <- initDs hsc_env tcg_env $ do { dsEvBinds ev_binds $ \ ds_ev_binds -> do @@ -224,26 +222,17 @@ ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps - ; let used_names = mkUsedNames tcg_env - pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) + ; let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) home_unit = hsc_home_unit hsc_env ; let deps = mkDependencies home_unit (tcg_mod tcg_env) (tcg_imports tcg_env) (map mi_module pluginModules) - ; used_th <- readIORef tc_splice_used - ; dep_files <- readIORef dependent_files ; safe_mode <- finalSafeMode dflags tcg_env - ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env) - ; let uc = initUsageConfig hsc_env - ; let plugins = hsc_plugins hsc_env - ; let fc = hsc_FC hsc_env - ; let unit_env = hsc_unit_env hsc_env - ; usages <- initIfaceLoad hsc_env $ - mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names - dep_files merged needed_mods needed_pkgs + ; usages <- mkRecompUsageInfo hsc_env tcg_env + -- id_mod /= mod when we are processing an hsig, but hsigs -- never desugared and compiled (there's no code!) -- Consequently, this should hold for any ModGuts that make @@ -261,12 +250,12 @@ mg_exports = exports, mg_usages = usages, mg_deps = deps, - mg_used_th = used_th, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_warns = warns, 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, @@ -287,18 +276,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 - ; let (spec_binds, spec_rules) = unzip spec_prs - ; return (concatOL spec_binds, spec_rules) } - combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind] -- Top-level bindings can include coercion bindings, but not via superclasses -- See Note [Top-level evidence] @@ -337,7 +314,7 @@ -- mb_result is Nothing only when a failure happens in the type-checker, -- but mb_core_expr is Nothing when a failure happens in the desugarer - let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result + let (ds_msgs, mb_core_expr) = expectJust mb_result case mb_core_expr of Nothing -> return () @@ -443,14 +420,18 @@ dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule (L loc (HsRule { rd_name = name , rd_act = rule_act - , rd_tmvs = vars + , rd_bndrs = RuleBndrs { rb_ext = bndrs } , rd_lhs = lhs , rd_rhs = rhs })) = putSrcSpanDs (locA loc) $ - do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] + do { let bndrs' = scopedSort bndrs + -- The scopedSort is because the binders may not + -- be in dependency order; see wrinkle (FTV1) in + -- Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ - unsetWOptM Opt_WarnIdentities $ + unsetWOptM Opt_WarnIdentities $ + zapUnspecables $ dsLExpr lhs -- Note [Desugaring RULE left hand sides] ; rhs' <- dsLExpr rhs @@ -551,6 +532,9 @@ the rule is precisely to optimise them: {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} +Finally, the `zapUnspecables` is to implement (NC1) of +Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr + Note [Desugaring coerce as cast] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want the user to express a rule saying roughly “mapping a coercion over a @@ -764,7 +748,7 @@ unsafe_equality k a b = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a] , mkTyConApp unsafe_equality_tc [k,b,a] - , mkNomPrimEqPred k a b + , mkNomEqPred a b ) -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to -- carefully swap the arguments above @@ -781,7 +765,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) @@ -795,5 +779,9 @@ arity = 1 - id = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info + concs = mkRepPolyIdConcreteTyVars + [((mkTyVarTy openAlphaTyVar, mkArgPos 1 Top), runtimeRep1TyVar)] + unsafeCoercePrimName + + id = mkExportedLocalId (RepPolyId concs) unsafeCoercePrimName ty `setIdInfo` info ; return (id, old_expr) } diff --git a/GHC/HsToCore/Arrows.hs b/GHC/HsToCore/Arrows.hs --- a/GHC/HsToCore/Arrows.hs +++ b/GHC/HsToCore/Arrows.hs @@ -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 @@ -295,7 +295,7 @@ let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty var <- selectSimpleMatchVarL ManyTy pat - match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr + match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) ManyTy pat env_stk_expr fail_expr let pat_ty = hsLPatType pat let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty (Lam var match_code) @@ -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) @@ -415,14 +415,7 @@ free_vars `unionDVarSet` (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) -dsCmd ids local_vars stack_ty res_ty - (HsCmdLam _ (MG { mg_alts - = (L _ [L _ (Match { m_pats = pats - , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) })) - env_ids - = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids - -dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids +dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids = dsLCmd ids local_vars stack_ty res_ty cmd env_ids -- D, xs |- e :: Bool @@ -442,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 @@ -504,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' @@ -535,18 +528,25 @@ -} dsCmd ids local_vars stack_ty res_ty - (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } ) + (HsCmdLam _ LamSingle (MG { mg_alts + = (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 + +dsCmd ids local_vars stack_ty res_ty + (HsCmdLam _ lam_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } ) env_ids = do arg_ids <- newSysLocalsDs arg_tys - let match_ctxt = ArrowLamCaseAlt lc_variant + let match_ctxt = ArrowLamAlt lam_variant pat_vars = mkVarSet arg_ids local_vars' = pat_vars `unionVarSet` local_vars (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty -- 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 @@ -591,14 +591,14 @@ -- -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do +dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do let defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds) local_vars' = defined_vars `unionVarSet` local_vars (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 @@ -646,8 +646,6 @@ dsHsWrapper wrap $ \core_wrap -> return (core_wrap core_cmd, env_ids') -dsCmd _ _ _ _ c@(HsCmdLam {}) _ = pprPanic "dsCmd" (ppr c) - -- D; ys |-a c : stk --> t (ys <= xs) -- --------------------- -- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c @@ -664,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 @@ -728,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 @@ -738,10 +736,11 @@ core_expr = buildEnvStack env_ids' stack_id' in_ty = envStackType env_ids stack_ty in_ty' = envStackType env_ids' stack_ty' + lam_cxt = ArrowMatchCtxt (ArrowLamAlt LamSingle) - fail_expr <- mkFailExpr (ArrowMatchCtxt KappaExpr) in_ty' + fail_expr <- mkFailExpr lam_cxt in_ty' -- match the patterns against the parameters - match_code <- matchSimplys (map Var param_ids) (ArrowMatchCtxt KappaExpr) pats core_expr + match_code <- matchSimplys (map Var param_ids) lam_cxt pats core_expr fail_expr -- match the parameters against the top of the old stack (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code @@ -785,9 +784,9 @@ let left_id = mkConLikeTc (RealDataCon left_con) right_id = mkConLikeTc (RealDataCon right_con) - left_expr ty1 ty2 e = noLocA $ HsApp noComments + left_expr ty1 ty2 e = noLocA $ HsApp noExtField (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e - right_expr ty1 ty2 e = noLocA $ HsApp noComments + right_expr ty1 ty2 e = noLocA $ HsApp noExtField (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e -- Prefix each tuple with a distinct series of Left's and Right's, @@ -809,9 +808,9 @@ -- i.e. Void. The choices then effectively become `arr absurd`, -- implemented as `arr \case {}`. Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> - dsExpr (HsLamCase EpAnnNotUsed LamCase + dsExpr (HsLam noAnn LamCase (MG { mg_alts = noLocA [] - , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated SkipPmc) + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion SkipPmc) })) -- Replace the commands in the case with these tagged tuples, @@ -853,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 @@ -955,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,8 +963,8 @@ fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty pat_id <- selectSimpleMatchVarL ManyTy pat match_code - <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr - pair_id <- newSysLocalDs ManyTy after_c_ty + <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) ManyTy pat body_expr fail_expr + pair_id <- newSysLocalMDs after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -1027,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 @@ -1114,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 @@ -1191,7 +1190,7 @@ -- Match a list of expressions against a list of patterns, left-to-right. matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext GhcTc -- Match kind + -> HsMatchContextRn -- Match kind -> [LPat GhcTc] -- Patterns they should match -> CoreExpr -- Return this if they all match -> CoreExpr -- Return this if they don't @@ -1199,14 +1198,14 @@ matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do match_code <- matchSimplys exps ctxt pats result_expr fail_expr - matchSimply exp ctxt pat match_code fail_expr + matchSimply exp ctxt ManyTy pat match_code fail_expr matchSimplys _ _ _ _ _ = panic "matchSimplys" -- List of leaf expressions, with set of variables bound in each 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) @@ -1216,7 +1215,7 @@ [(body, mkVarSet (collectLStmtsBinders CollWithDictBinders stmts) `unionVarSet` defined_vars) - | L _ (GRHS _ stmts body) <- grhss] + | L _ (GRHS _ stmts body) <- toList grhss] -- Replace the leaf commands in a match @@ -1234,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))) diff --git a/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs --- a/GHC/HsToCore/Binds.hs +++ b/GHC/HsToCore/Binds.hs @@ -1,1408 +1,1801 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - - -Pattern-matching bindings (HsBinds and MonoBinds) - -Handles @HsBinds@; those at the top level require different handling, -in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at -lower levels it is preserved with @let@/@letrec@s). --} - -module GHC.HsToCore.Binds - ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec - , dsHsWrapper, dsHsWrappers, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds - , dsWarnOrphanRule - ) -where - -import GHC.Prelude - -import GHC.Driver.DynFlags -import GHC.Driver.Config -import qualified GHC.LanguageExtensions as LangExt -import GHC.Unit.Module - -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr ) -import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper ) - -import GHC.HsToCore.Monad -import GHC.HsToCore.Errors.Types -import GHC.HsToCore.GuardedRHSs -import GHC.HsToCore.Utils -import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) - -import GHC.Hs -- lots of things -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.Make -import GHC.Core.Utils -import GHC.Core.Opt.Arity ( etaExpand ) -import GHC.Core.Unfold.Make -import GHC.Core.FVs -import GHC.Core.Predicate -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 ) - -import GHC.Builtin.Names -import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) - -import GHC.Tc.Types.Evidence - -import GHC.Types.Id -import GHC.Types.Id.Make ( nospecId ) -import GHC.Types.Name -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Var( EvVar ) -import GHC.Types.SrcLoc -import GHC.Types.Basic -import GHC.Types.Unique.Set( nonDetEltsUniqSet ) - -import GHC.Data.Maybe -import GHC.Data.OrdList -import GHC.Data.Graph.Directed -import GHC.Data.Bag -import qualified Data.Set as S - -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Misc -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import Control.Monad - -{-********************************************************************** -* * - Desugaring a MonoBinds -* * -**********************************************************************-} - --- | Desugar top level binds, strict binds are treated like normal --- binds since there is no good time to force before first usage. -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 - ; return nilOL } - - | otherwise - = do { (force_vars, prs) <- dsLHsBinds binds - ; when debugIsOn $ - do { xstrict <- xoptM LangExt.Strict - ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) } - -- with -XStrict, even top-level vars are listed as force vars. - - ; return (toOL prs) } - - where - unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds - bang_binds = filterBag (isBangedHsBind . unLoc) binds - - top_level_err bindsType (L loc bind) - = putSrcSpanDs (locA loc) $ - diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind) - - --- | Desugar all other kind of bindings, Ids of strict binds are returned to --- later be forced in the binding group body, see Note [Desugar Strict binds] -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) } - ------------------------- -dsLHsBind :: LHsBind GhcTc - -> DsM ([Id], [(Id,CoreExpr)]) -dsLHsBind (L loc bind) = do dflags <- getDynFlags - putSrcSpanDs (locA loc) $ dsHsBind dflags bind - --- | Desugar a single binding (or group of recursive binds). -dsHsBind :: DynFlags - -> HsBind GhcTc - -> DsM ([Id], [(Id,CoreExpr)]) - -- ^ The Ids of strict binds, to be forced in the body of the - -- binding group see Note [Desugar Strict binds] and all - -- bindings and their desugared right hand sides. - -dsHsBind dflags (VarBind { var_id = var - , var_rhs = expr }) - = do { core_expr <- dsLExpr expr - -- Dictionary bindings are always VarBinds, - -- so we only need do this here - ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr - force_var = if xopt LangExt.Strict dflags - then [id] - else [] - ; return (force_var, [core_bind]) } - -dsHsBind dflags b@(FunBind { fun_id = L loc fun - , fun_matches = matches - , fun_ext = (co_fn, tick) - }) - = do { dsHsWrapper co_fn $ \core_wrap -> do - { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $ - -- FromSource might not be accurate (we don't have any - -- origin annotations for things in this module), but at - -- worst we do superfluous calls to the pattern match - -- oracle. - -- addTyCs: Add type evidence to the refinement type - -- predicate of the coverage checker - -- See Note [Long-distance information] in "GHC.HsToCore.Pmc" - matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches - - ; let body' = mkOptTickBox tick body - rhs = core_wrap (mkLams args body') - core_binds@(id,_) = makeCorePair dflags fun False 0 rhs - force_var - -- Bindings are strict when -XStrict is enabled - | xopt LangExt.Strict dflags - , matchGroupArity matches == 0 -- no need to force lambdas - = [id] - | isBangedHsBind b - = [id] - | otherwise - = [] - ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) - -- , ppr (mg_alts matches) - -- , ppr args, ppr core_binds, ppr body']) $ - return (force_var, [core_binds]) } } - -dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = (ty, (rhs_tick, var_ticks)) - }) - = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss - ; body_expr <- dsGuarded grhss ty rhss_nablas - ; let body' = mkOptTickBox rhs_tick body_expr - pat' = decideBangHood dflags pat - ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body' - -- We silently ignore inline pragmas; no makeCorePair - -- Not so cool, but really doesn't matter - ; let force_var' = if isBangedLPat pat' - then [force_var] - else [] - ; return (force_var', sel_binds) } - -dsHsBind - dflags - (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = binds, abs_sig = has_sig })) - = do { ds_binds <- addTyCs FromSource (listToBag dicts) $ - dsLHsBinds binds - -- addTyCs: push type constraints deeper - -- for inner pattern match check - -- See Check, Note [Long-distance information] - - ; dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do - - -- dsAbsBinds does the hard work - { dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } } - -dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" - ------------------------ -dsAbsBinds :: DynFlags - -> [TyVar] -> [EvVar] -> [ABExport] - -> [CoreBind] -- Desugared evidence bindings - -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings - -> Bool -- Single binding with signature - -> DsM ([Id], [(Id,CoreExpr)]) - -dsAbsBinds dflags tyvars dicts exports - ds_ev_binds (force_vars, bind_prs) has_sig - - -- A very important common case: one exported variable - -- Non-recursive bindings come through this way - -- So do self-recursive bindings - -- gbl_id = wrap (/\tvs \dicts. let ev_binds - -- letrec bind_prs - -- in lcl_id) - | [export] <- exports - , ABE { abe_poly = global_id, abe_mono = local_id - , abe_wrap = wrap, abe_prags = prags } <- export - , Just force_vars' <- case force_vars of - [] -> Just [] - [v] | v == local_id -> Just [global_id] - _ -> Nothing - -- If there is a variable to force, it's just the - -- single variable we are binding here - = do { dsHsWrapper wrap $ \core_wrap -> do -- Usually the identity - { let rhs = core_wrap $ - mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_ev_binds $ - body - - body | has_sig - , [(_, lrhs)] <- bind_prs - = lrhs - | otherwise - = mkLetRec bind_prs (Var local_id) - - ; (spec_binds, rules) <- dsSpecs rhs prags - - ; let global_id' = addIdSpecialisations global_id rules - main_bind = makeCorePair dflags global_id' - (isDefaultMethod prags) - (dictArity dicts) rhs - - ; return (force_vars', main_bind : fromOL spec_binds) } } - - -- Another common case: no tyvars, no dicts - -- In this case we can have a much simpler desugaring - -- lcl_id{inl-prag} = rhs -- Auxiliary binds - -- gbl_id = lcl_id |> co -- Main binds - | null tyvars, null dicts - = do { let mk_main :: ABExport -> DsM (Id, CoreExpr) - mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id - , abe_wrap = wrap }) - -- No SpecPrags (no dicts) - -- Can't be a default method (default methods are singletons) - = do { dsHsWrapper wrap $ \core_wrap -> do - { return ( gbl_id `setInlinePragma` defaultInlinePragma - , core_wrap (Var lcl_id)) } } - - ; main_prs <- mapM mk_main exports - ; return (force_vars, flattenBinds ds_ev_binds - ++ mk_aux_binds bind_prs ++ main_prs ) } - - -- The general case - -- See Note [Desugaring AbsBinds] - | otherwise - = do { let aux_binds = Rec (mk_aux_binds bind_prs) - -- Monomorphic recursion possible, hence Rec - - new_force_vars = get_new_force_vars force_vars - locals = map abe_mono exports - all_locals = locals ++ new_force_vars - tup_expr = mkBigCoreVarTup all_locals - tup_ty = exprType tup_expr - ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ - mkCoreLets ds_ev_binds $ - mkLet aux_binds $ - tup_expr - - ; poly_tup_id <- newSysLocalDs ManyTy (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 - -- Note [Desugar Strict binds] - ; (exported_force_vars, extra_exports) <- get_exports force_vars - - ; let mk_bind (ABE { abe_wrap = wrap - , 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 - ; dsHsWrapper wrap $ \core_wrap -> do - { let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkBigTupleSelector all_locals local tup_id $ - mkVarApps (Var poly_tup_id) (tyvars ++ dicts) - rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs - ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags - ; let global' = (global `setInlinePragma` defaultInlinePragma) - `addIdSpecialisations` rules - -- Kill the INLINE pragma because it applies to - -- the user written (local) function. The global - -- Id is just the selector. Hmm. - ; return ((global', rhs) : fromOL spec_binds) } } - - ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) - - ; return ( exported_force_vars - , (poly_tup_id, poly_tup_rhs) : - concat export_binds_s) } - where - mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)] - mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs - | (lcl_id, rhs) <- bind_prs - , let lcl_w_inline = lookupVarEnv inline_env lcl_id - `orElse` lcl_id ] - - inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with - -- the inline pragma from the source - -- The type checker put the inline pragma - -- on the *global* Id, so we need to transfer it - inline_env - = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) - | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports - , let prag = idInlinePragma gbl_id ] - - global_env :: IdEnv Id -- Maps local Id to its global exported Id - global_env = - mkVarEnv [ (local, global) - | ABE { abe_mono = local, abe_poly = global } <- exports - ] - - -- find variables that are not exported - get_new_force_vars lcls = - foldr (\lcl acc -> case lookupVarEnv global_env lcl of - Just _ -> acc - Nothing -> lcl:acc) - [] lcls - - -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport]) - get_exports lcls = - foldM (\(glbls, exports) lcl -> - case lookupVarEnv global_env lcl of - Just glbl -> return (glbl:glbls, exports) - Nothing -> do export <- mk_export lcl - let glbl = abe_poly export - return (glbl:glbls, export:exports)) - ([],[]) lcls - - mk_export local = - do global <- newSysLocalDs ManyTy - (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE { abe_poly = global - , abe_mono = local - , abe_wrap = WpHole - , abe_prags = SpecPrags [] }) - --- | This is where we apply INLINE and INLINABLE pragmas. All we need to --- do is to attach the unfolding information to the Id. --- --- Other decisions about whether to inline are made in --- `calcUnfoldingGuidance` but the decision about whether to then expose --- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` --- using this information. ------------------------- -makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr - -> (Id, CoreExpr) -makeCorePair dflags gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined - -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance - = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) - - | otherwise - = case inlinePragmaSpec inline_prag of - NoUserInlinePrag -> (gbl_id, rhs) - NoInline {} -> (gbl_id, rhs) - Opaque {} -> (gbl_id, rhs) - Inlinable {} -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) - Inline {} -> inline_pair - where - simpl_opts = initSimpleOpts dflags - inline_prag = idInlinePragma gbl_id - inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs - inline_pair - | Just arity <- inlinePragmaSat inline_prag - -- Add an Unfolding for an INLINE (but not for NOINLINE) - -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] - , let real_arity = dict_arity + arity - -- NB: The arity passed to mkInlineUnfoldingWithArity - -- must take account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs - , etaExpand real_arity rhs) - - | otherwise - = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ - (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) - -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts - -{- -Note [Desugaring AbsBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the general AbsBinds case we desugar the binding to this: - - tup a (d:Num a) = let fm = ...gm... - gm = ...fm... - in (fm,gm) - f a d = case tup a d of { (fm,gm) -> fm } - g a d = case tup a d of { (fm,gm) -> fm } - -Note [Rules and inlining] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Common special case: no type or dictionary abstraction -This is a bit less trivial than you might suppose -The naive way would be to desugar to something like - f_lcl = ...f_lcl... -- The "binds" from AbsBinds - M.f = f_lcl -- Generated from "exports" -But we don't want that, because if M.f isn't exported, -it'll be inlined unconditionally at every call site (its rhs is -trivial). That would be ok unless it has RULES, which would -thereby be completely lost. Bad, bad, bad. - -Instead we want to generate - M.f = ...f_lcl... - f_lcl = M.f -Now all is cool. The RULES are attached to M.f (by SimplCore), -and f_lcl is rapidly inlined away. - -This does not happen in the same way to polymorphic binds, -because they desugar to - M.f = /\a. let f_lcl = ...f_lcl... in f_lcl -Although I'm a bit worried about whether full laziness might -float the f_lcl binding out and then inline M.f at its call site - -Note [Specialising in no-dict case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even if there are no tyvars or dicts, we may have specialisation pragmas. -Class methods can generate - AbsBinds [] [] [( ... spec-prag] - { AbsBinds [tvs] [dicts] ...blah } -So the overloading is in the nested AbsBinds. A good example is in GHC.Float: - - class (Real a, Fractional a) => RealFrac a where - round :: (Integral b) => a -> b - - instance RealFrac Float where - {-# SPECIALIZE round :: Float -> Int #-} - -The top-level AbsBinds for $cround has no tyvars or dicts (because the -instance does not). But the method is locally overloaded! - -Note [Abstracting over tyvars only] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When abstracting over type variable only (not dictionaries), we don't really need to -built a tuple and select from it, as we do in the general case. Instead we can take - - AbsBinds [a,b] [ ([a,b], fg, fl, _), - ([b], gg, gl, _) ] - { fl = e1 - gl = e2 - h = e3 } - -and desugar it to - - fg = /\ab. let B in e1 - gg = /\b. let a = () in let B in S(e2) - h = /\ab. let B in e3 - -where B is the *non-recursive* binding - fl = fg a b - gl = gg b - h = h a b -- See (b); note shadowing! - -Notice (a) g has a different number of type variables to f, so we must - use the mkArbitraryType thing to fill in the gaps. - We use a type-let to do that. - - (b) The local variable h isn't in the exports, and rather than - clone a fresh copy we simply replace h by (h a b), where - the two h's have different types! Shadowing happens here, - which looks confusing but works fine. - - (c) The result is *still* quadratic-sized if there are a lot of - small bindings. So if there are more than some small - number (10), we filter the binding set B by the free - variables of the particular RHS. Tiresome. - -Why got to this trouble? It's a common case, and it removes the -quadratic-sized tuple desugaring. Less clutter, hopefully faster -compilation, especially in a case where there are a *lot* of -bindings. - - -Note [Eta-expanding INLINE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo :: Eq a => a -> a - {-# INLINE foo #-} - foo x = ... - -If (foo d) ever gets floated out as a common sub-expression (which can -happen as a result of method sharing), there's a danger that we never -get to do the inlining, which is a Terribly Bad thing given that the -user said "inline"! - -To avoid this we preemptively eta-expand the definition, so that foo -has the arity with which it is declared in the source code. In this -example it has arity 2 (one for the Eq and one for x). Doing this -should mean that (foo d) is a PAP and we don't share it. - -Note [Nested arities] -~~~~~~~~~~~~~~~~~~~~~ -For reasons that are not entirely clear, method bindings come out looking like -this: - - AbsBinds [] [] [$cfromT <= [] fromT] - $cfromT [InlPrag=INLINE] :: T Bool -> Bool - { AbsBinds [] [] [fromT <= [] fromT_1] - fromT :: T Bool -> Bool - { fromT_1 ((TBool b)) = not b } } } - -Note the nested AbsBind. The arity for the unfolding on $cfromT should be -gotten from the binding for fromT_1. - -It might be better to have just one level of AbsBinds, but that requires more -thought! - - -Note [Desugar Strict binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma - -Desugaring strict variable bindings looks as follows (core below ==>) - - let !x = rhs - in body -==> - let x = rhs - in x `seq` body -- seq the variable - -and if it is a pattern binding the desugaring looks like - - let !pat = rhs - in body -==> - let x = rhs -- bind the rhs to a new variable - pat = x - in x `seq` body -- seq the new variable - -if there is no variable in the pattern desugaring looks like - - let False = rhs - in body -==> - let x = case rhs of {False -> (); _ -> error "Match failed"} - in x `seq` body - -In order to force the Ids in the binding group they are passed around -in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind. - -Consider a recursive group like this - - letrec - f : g = rhs[f,g] - in - -Without `Strict`, we get a translation like this: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (fm,gm) - - in let f = /\a. case t a of (fm,_) -> fm - in let g = /\a. case t a of (_,gm) -> gm - in - -Here `tm` is the monomorphic binding for `rhs`. - -With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. -Alas, `tm` isn't in scope in the `in ` part. - -The simplest thing is to return it in the polymorphic -tuple `t`, thus: - - let t = /\a. letrec tm = rhs[fm,gm] - fm = case t of fm:_ -> fm - gm = case t of _:gm -> gm - in - (tm, fm, gm) - - in let f = /\a. case t a of (_,fm,_) -> fm - in let g = /\a. case t a of (_,_,gm) -> gm - in let tm = /\a. case t a of (tm,_,_) -> tm - in tm `seq` - - -See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more -detailed explanation of the desugaring of strict bindings. - -Note [Strict binds checks] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several checks around properly formed strict bindings. They -all link to this Note. These checks must be here in the desugarer because -we cannot know whether or not a type is unlifted until after zonking, due -to representation polymorphism. These checks all used to be handled in the -typechecker in checkStrictBinds (before Jan '17). - -We define an "unlifted bind" to be any bind that binds an unlifted id. Note that - - x :: Char - (# True, x #) = blah - -is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. - -Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. -Define a "strict bind" to be either an unlifted bind or a banged bind. - -The restrictions are: - 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. - - 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged - unlifted bind, but an unbanged bind looks lazy, and we don't want users to be - surprised by the strictness of an unlifted bind.) Checked in first clause - of GHC.HsToCore.Expr.ds_val_bind. - - 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type - variables or constraints.) Checked in first clause - of GHC.HsToCore.Expr.ds_val_bind. - - 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. - --} - ------------------------- -dsSpecs :: CoreExpr -- Its rhs - -> TcSpecPrags - -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids - , [CoreRule] ) -- Rules for the Global Ids --- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind -dsSpecs _ IsDefaultMethod = return (nilOL, []) -dsSpecs poly_rhs (SpecPrags sps) - = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps - ; let (spec_binds_s, rules) = unzip pairs - ; return (concatOL spec_binds_s, rules) } - -dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding - -- Nothing => RULE is for an imported Id - -- rhs is in the Id's unfolding - -> Located TcSpecPrag - -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) -dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) - | isJust (isClassOpId_maybe poly_id) - = putSrcSpanDs loc $ - do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id) - ; return Nothing } -- There is no point in trying to specialise a class op - -- Moreover, classops don't (currently) have an inl_sat arity set - -- (it would be Just 0) and that in turn makes makeCorePair bleat - - | no_act_spec && isNeverActive rule_act - = putSrcSpanDs loc $ - do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id) - ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that - -- See Note [Activation pragmas for SPECIALISE] - - | otherwise - = putSrcSpanDs loc $ - do { uniq <- newUnique - ; let poly_name = idName poly_id - spec_occ = mkSpecOcc (getOccName poly_name) - spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) - (spec_bndrs, spec_app) = collectHsWrapBinders spec_co - -- spec_co looks like - -- \spec_bndrs. [] spec_args - -- perhaps with the body of the lambda wrapped in some WpLets - -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 - - ; dsHsWrapper spec_app $ \core_app -> do - - { let ds_lhs = core_app (Var poly_id) - spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs) - ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id - -- , text "spec_co:" <+> ppr spec_co - -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ - dflags <- getDynFlags - ; case decomposeRuleLhs dflags spec_bndrs ds_lhs (mkVarSet spec_bndrs) of { - Left msg -> do { diagnosticDs msg; return Nothing } ; - Right (rule_bndrs, _fn, rule_lhs_args) -> do - - { this_mod <- getModule - ; let fn_unf = realIdUnfolding poly_id - simpl_opts = initSimpleOpts dflags - spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf - spec_id = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many. - `setInlinePragma` inl_prag - `setIdUnfolding` spec_unf - - rule = mkSpecRule dflags this_mod False rule_act (text "USPEC") - poly_id rule_bndrs rule_lhs_args - (mkVarApps (Var spec_id) spec_bndrs) - spec_rhs = mkLams spec_bndrs (core_app poly_rhs) - - ; dsWarnOrphanRule rule - - ; 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 - -- just created using specUnfolding - } } } } - where - is_local_id = isJust mb_poly_rhs - poly_rhs | Just rhs <- mb_poly_rhs - = rhs -- Local Id; this is its rhs - | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) - = unfolding -- Imported Id; this is its unfolding - -- Use realIdUnfolding so we get the unfolding - -- even when it is a loop breaker. - -- We want to specialise recursive functions! - | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) - -- The type checker has checked that it *has* an unfolding - - id_inl = idInlinePragma poly_id - - -- See Note [Activation pragmas for SPECIALISE] - inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl - | not is_local_id -- See Note [Specialising imported functions] - -- in OccurAnal - , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = id_inl - -- Get the INLINE pragma from SPECIALISE declaration, or, - -- failing that, from the original Id - - spec_prag_act = inlinePragmaActivation spec_inl - - -- See Note [Activation pragmas for SPECIALISE] - -- no_act_spec is True if the user didn't write an explicit - -- phase specification in the SPECIALISE pragma - no_act_spec = case inlinePragmaSpec spec_inl of - NoInline _ -> isNeverActive spec_prag_act - Opaque _ -> isNeverActive spec_prag_act - _ -> isAlwaysActive spec_prag_act - rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit - | otherwise = spec_prag_act -- Specified by user - - -dsWarnOrphanRule :: CoreRule -> DsM () -dsWarnOrphanRule rule - = when (isOrphan (ru_orphan rule)) $ - diagnosticDs (DsOrphanRule rule) - -{- Note [SPECIALISE on INLINE functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to warn that using SPECIALISE for a function marked INLINE -would be a no-op; but it isn't! Especially with worker/wrapper split -we might have - {-# INLINE f #-} - f :: Ord a => Int -> a -> ... - f d x y = case x of I# x' -> $wf d x' y - -We might want to specialise 'f' so that we in turn specialise '$wf'. -We can't even /name/ '$wf' in the source code, so we can't specialise -it even if we wanted to. #10721 is a case in point. - -Note [Activation pragmas for SPECIALISE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -From a user SPECIALISE pragma for f, we generate - a) A top-level binding spec_fn = rhs - b) A RULE f dOrd = spec_fn - -We need two pragma-like things: - -* spec_fn's inline pragma: inherited from f's inline pragma (ignoring - activation on SPEC), unless overridden by SPEC INLINE - -* Activation of RULE: from SPECIALISE pragma (if activation given) - otherwise from f's inline pragma - -This is not obvious (see #5237)! - -Examples Rule activation Inline prag on spec'd fn ---------------------------------------------------------------------- -SPEC [n] f :: ty [n] Always, or NOINLINE [n] - copy f's prag - -NOINLINE f -SPEC [n] f :: ty [n] NOINLINE - copy f's prag - -NOINLINE [k] f -SPEC [n] f :: ty [n] NOINLINE [k] - copy f's prag - -INLINE [k] f -SPEC [n] f :: ty [n] INLINE [k] - copy f's prag - -SPEC INLINE [n] f :: ty [n] INLINE [n] - (ignore INLINE prag on f, - same activation for rule and spec'd fn) - -NOINLINE [k] f -SPEC f :: ty [n] INLINE [k] - - -************************************************************************ -* * -\subsection{Adding inline pragmas} -* * -************************************************************************ --} - -decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr - -> VarSet -- Free vars of the RHS - -> Either DsMessage ([Var], Id, [CoreExpr]) --- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, --- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs --- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS]) --- --- Returns an error message if the LHS isn't of the expected shape --- Note [Decomposing the left-hand side of a RULE] -decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs - | Var funId <- fun2 - , Just con <- isDataConId_maybe funId - = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] - - | otherwise = case decompose fun2 args2 of - Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "rhs_fvs:" <+> ppr rhs_fvs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "lhs2:" <+> ppr lhs2 - -- , text "fun2:" <+> ppr fun2 - -- , text "args2:" <+> ppr args2 - -- ]) $ - Left (DsRuleLhsTooComplicated orig_lhs lhs2) - Just (fn_id, args) - | not (null unbound) -> - -- Check for things unbound on LHS - -- See Note [Unused spec binders] - -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs_fvs:" <+> ppr lhs_fvs - -- , text "rhs_fvs:" <+> ppr rhs_fvs - -- , text "unbound:" <+> ppr unbound - -- ]) $ - Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) - | otherwise -> - -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs - -- , text "orig_lhs:" <+> ppr orig_lhs - -- , text "lhs1:" <+> ppr lhs1 - -- , text "extra_bndrs:" <+> ppr extra_bndrs - -- , text "fn_id:" <+> ppr fn_id - -- , text "args:" <+> ppr args - -- , text "args fvs:" <+> ppr (exprsFreeVarsList args) - -- ]) $ - Right (trimmed_bndrs ++ extra_bndrs, fn_id, args) - - where -- See Note [Variables unbound on the LHS] - lhs_fvs = exprsFreeVars args - all_fvs = lhs_fvs `unionVarSet` rhs_fvs - trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs - unbound = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs - -- Needed on RHS but not bound on LHS - - -- Add extra tyvar binders: Note [Free tyvars on rule LHS] - -- and extra dict binders: Note [Free dictionaries on rule LHS] - extra_bndrs = scopedSort extra_tvs ++ extra_dicts - where - extra_tvs = [ v | v <- extra_vars, isTyVar v ] - extra_dicts = - [ mkLocalId (localiseName (idName d)) ManyTy (idType d) - | d <- extra_vars, isDictId d ] - extra_vars = - [ v - | v <- exprsFreeVarsList args - , not (v `elemVarSet` orig_bndr_set) - , not (v == fn_id) ] - -- fn_id: do not quantify over the function itself, which may - -- itself be a dictionary (in pathological cases, #10251) - - where - simpl_opts = initSimpleOpts dflags - orig_bndr_set = mkVarSet orig_bndrs - - lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS] - (fun2,args2) = collectArgs lhs2 - - decompose (Var fn_id) args - | not (fn_id `elemVarSet` orig_bndr_set) - = Just (fn_id, args) - - decompose _ _ = Nothing - - drop_dicts :: CoreExpr -> CoreExpr - drop_dicts e - = wrap_lets needed bnds body - where - needed = orig_bndr_set `minusVarSet` exprFreeVars body - (bnds, body) = split_lets (occurAnalyseExpr e) - -- The occurAnalyseExpr drops dead bindings which is - -- crucial to ensure that every binding is used later; - -- which in turn makes wrap_lets work right - - split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) - split_lets (Let (NonRec d r) body) - | isDictId d -- Catches dictionaries, yes, but also catches dictionary - -- /functions/ arising from solving a - -- quantified contraint (#24370) - = ((d,r):bs, body') - where (bs, body') = split_lets body - - -- handle "unlifted lets" too, needed for "map/coerce" - split_lets (Case r d _ [Alt DEFAULT _ body]) - | isCoVar d - = ((d,r):bs, body') - where (bs, body') = split_lets body - - split_lets e = ([], e) - - wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr - wrap_lets _ [] body = body - wrap_lets needed ((d, r) : bs) body - | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) - | otherwise = wrap_lets needed bs body - where - rhs_fvs = exprFreeVars r - needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d - -{- -Note [Variables unbound on the LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously want to complain about - RULE forall x. f True = not x -because the forall'd variable `x` is not bound on the LHS. - -It can be a bit delicate when dictionaries are involved. -Consider #22471 - {-# RULES "foo" forall (f :: forall a. [a] -> Int). - foo (\xs. 1 + f xs) = 2 + foo f #-} - -We get two dicts on the LHS, one from `1` and one from `+`. -For reasons described in Note [The SimplifyRule Plan] in -GHC.Tc.Gen.Rule, we quantify separately over those dictionaries: - forall f (d1::Num Int) (d2 :: Num Int). - foo (\xs. (+) d1 (fromInteger d2 1) xs) = ... - -Now the desugarer shortcircuits (fromInteger d2 1) to (I# 1); so d2 is -not mentioned at all (on LHS or RHS)! We don't want to complain about -and unbound d2. Hence the trimmed_bndrs. - -Note [Decomposing the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several things going on here. -* drop_dicts: see Note [Drop dictionary bindings on rule LHS] -* simpleOptExpr: see Note [Simplify rule LHS] -* extra_dict_bndrs: see Note [Free dictionaries on rule LHS] - -Note [Free tyvars on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = C - - foo :: T a -> Int - foo C = 1 - - {-# RULES "myrule" foo C = 1 #-} - -After type checking the LHS becomes (foo alpha (C alpha)), where alpha -is an unbound meta-tyvar. The zonker in GHC.Tc.Zonk.Type is careful not to -turn the free alpha into Any (as it usually does). Instead it turns it -into a TyVar 'a'. See Note [Zonking the LHS of a RULE] in "GHC.Tc.Zonk.Type". - -Now we must quantify over that 'a'. It's /really/ inconvenient to do that -in the zonker, because the HsExpr data type is very large. But it's /easy/ -to do it here in the desugarer. - -Moreover, we have to do something rather similar for dictionaries; -see Note [Free dictionaries on rule LHS]. So that's why we look for -type variables free on the LHS, and quantify over them. - -This relies on there not being any in-scope tyvars, which is true for -user-defined RULEs, which are always top-level. - -Note [Free dictionaries on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, -which is presumably in scope at the function definition site, we can quantify -over it too. *Any* dict with that type will do. - -So for example when you have - f :: Eq a => a -> a - f = - ... SPECIALISE f :: Int -> Int ... - -Then we get the SpecPrag - SpecPrag (f Int dInt) - -And from that we want the rule - - RULE forall dInt. f Int dInt = f_spec - f_spec = let f = in f Int dInt - -But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External -Name, and you can't bind them in a lambda or forall without getting things -confused. Likewise it might have a stable unfolding or something, which would be -utterly bogus. So we really make a fresh Id, with the same unique and type -as the old one, but with an Internal name and no IdInfo. - -Note [Drop dictionary bindings on rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -drop_dicts drops dictionary bindings on the LHS where possible. - E.g. let d:Eq [Int] = $fEqList $fEqInt in f d - --> f d - Reasoning here is that there is only one d:Eq [Int], and so we can - quantify over it. That makes 'd' free in the LHS, but that is later - picked up by extra_dict_bndrs (see Note [Unused spec binders]). - - NB 1: We can only drop the binding if the RHS doesn't bind - one of the orig_bndrs, which we assume occur on RHS. - Example - f :: (Eq a) => b -> a -> a - {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} - Here we want to end up with - RULE forall d:Eq a. f ($dfEqList d) = f_spec d - Of course, the ($dfEqlist d) in the pattern makes it less likely - to match, but there is no other way to get d:Eq a - - NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all - the evidence bindings to be wrapped around the outside of the - LHS. (After simplOptExpr they'll usually have been inlined.) - dsHsWrapper does dependency analysis, so that civilised ones - will be simple NonRec bindings. We don't handle recursive - dictionaries! - - NB3: In the common case of a non-overloaded, but perhaps-polymorphic - specialisation, we don't need to bind *any* dictionaries for use - in the RHS. For example (#8331) - {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} - useAbstractMonad :: MonadAbstractIOST m => m Int - Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code - but the RHS uses no dictionaries, so we want to end up with - RULE forall s (d :: MonadAbstractIOST (ReaderT s)). - useAbstractMonad (ReaderT s) d = $suseAbstractMonad s - - #8848 is a good example of where there are some interesting - dictionary bindings to discard. - -The drop_dicts algorithm is based on these observations: - - * Given (let d = rhs in e) where d is a DictId, - matching 'e' will bind e's free variables. - - * So we want to keep the binding if one of the needed variables (for - which we need a binding) is in fv(rhs) but not already in fv(e). - - * The "needed variables" are simply the orig_bndrs. Consider - f :: (Eq a, Show b) => a -> b -> String - ... SPECIALISE f :: (Show b) => Int -> b -> String ... - Then orig_bndrs includes the *quantified* dictionaries of the type - namely (dsb::Show b), but not the one for Eq Int - -So we work inside out, applying the above criterion at each step. - - -Note [Simplify rule LHS] -~~~~~~~~~~~~~~~~~~~~~~~~ -simplOptExpr occurrence-analyses and simplifies the LHS: - - (a) Inline any remaining dictionary bindings (which hopefully - occur just once) - - (b) Substitute trivial lets, so that they don't get in the way. - Note that we substitute the function too; we might - have this as a LHS: let f71 = M.f Int in f71 - - (c) Do eta reduction. To see why, consider the fold/build rule, - which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... - This doesn't match unless you do eta reduction on the build argument. - Similarly for a LHS like - augment g (build h) - we do not want to get - augment (\a. g a) (build h) - otherwise we don't match when given an argument like - augment (\a. h a a) (build h) - -Note [Unused spec binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: a -> a - ... SPECIALISE f :: Eq a => a -> a ... -It's true that this *is* a more specialised type, but the rule -we get is something like this: - f_spec d = f - RULE: f = f_spec d -Note that the rule is bogus, because it mentions a 'd' that is -not bound on the LHS! But it's a silly specialisation anyway, because -the constraint is unused. We could bind 'd' to (error "unused") -but it seems better to reject the program because it's almost certainly -a mistake. That's what the isDeadBinder call detects. - -Note [No RULES on datacons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Previously, `RULES` like - - "JustNothing" forall x . Just x = Nothing - -were allowed. Simon Peyton Jones says this seems to have been a -mistake, that such rules have never been supported intentionally, -and that he doesn't know if they can break in horrible ways. -Furthermore, Ben Gamari and Reid Barton are considering trying to -detect the presence of "static data" that the simplifier doesn't -need to traverse at all. Such rules do not play well with that. -So for now, we ban them altogether as requested by #13290. See also #7398. - - -************************************************************************ -* * - Desugaring evidence -* * -************************************************************************ - -Note [Desugaring WpFun] -~~~~~~~~~~~~~~~~~~~~~~~ -See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means. -Roughly: - - (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ] - -This eta-expansion risk duplicating work, if `e` is not in HNF. -At one stage I thought we could avoid that by desugaring to - let f = e in \x. w_res[ f w_arg[x] ] -But that /fundamentally/ doesn't work, because `w_res` may bind -evidence that is used in `e`. - -This question arose when thinking about deep subsumption; see -https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649). - -Note [Desugaring non-canonical evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the evidence is canonical, we desugar WpEvApp by simply passing -core_tm directly to k: - - k core_tm - -If the evidence is not canonical, we mark the application with nospec: - - nospec @(cls => a) k core_tm - -where nospec :: forall a. a -> a ensures that the typeclass specialiser -doesn't attempt to common up this evidence term with other evidence terms -of the same type (see Note [nospecId magic] in GHC.Types.Id.Make). - -See Note [Coherence and specialisation: overview] for why we shouldn't -specialise incoherent evidence. - -We can find out if a given evidence is canonical or not during the -desugaring of its WpLet wrapper: an evidence is non-canonical if its -own resolution was incoherent (see Note [Incoherent instances]), or -if its definition refers to other non-canonical evidence. dsEvBinds is -the convenient place to compute this, since it already needs to do -inter-evidence dependency analysis to generate well-scoped -bindings. We then record this specialisability information in the -dsl_unspecables field of DsM's local environment. - --} - -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 } - --- We are about to construct an evidence application `f dict`. If the dictionary is --- non-specialisable, instead construct --- nospec f dict --- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does. -app_ev :: Bool -> CoreExpr -> CoreExpr -> CoreExpr -app_ev is_specable k core_tm - | not is_specable - = Var nospecId `App` Type (exprType k) `App` k `App` core_tm - - | otherwise - = k `App` core_tm - -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 [] -dsTcEvBinds_s (b:rest) k = assert (null rest) $ -- Zonker ensures null - dsTcEvBinds b k - -dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this -dsTcEvBinds (EvBinds bs) = dsEvBinds bs - --- * Desugars the ev_binds, sorts them into dependency order, and --- passes the resulting [CoreBind] to thing_inside --- * Extends the DsM (dsl_unspecable field) with specialisability information --- for each binder in ev_binds, before invoking thing_inside -dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a -dsEvBinds ev_binds thing_inside - = do { ds_binds <- mapBagM dsEvBind ev_binds - ; let comps = sort_ev_binds ds_binds - ; go comps thing_inside } - where - go ::[SCC (Node EvVar (Canonical, 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) } - 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 - new_unspecables - | transitively_unspecable = S.singleton v - | otherwise = mempty - ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables) - where - (pairs, direct_canonicity) = unzip $ map unpack_node nodes - - is_unspecable_remote dep = dep `S.member` unspecables - transitively_unspecable = or [ not 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] - - new_unspecables - | transitively_unspecable = S.fromList [ v | (v, _) <- pairs] - | otherwise = mempty - - unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps } = ((v, rhs), (canonical, deps)) - -sort_ev_binds :: Bag (Id, Canonical, CoreExpr) -> [SCC (Node EvVar (Canonical, 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 = foldr ((:) . mk_node) [] ds_binds - - mk_node :: (Id, Canonical, CoreExpr) -> Node EvVar (Canonical, CoreExpr) - mk_node (var, canonical, rhs) - = DigraphNode { node_payload = (canonical, rhs) - , node_key = var - , node_dependencies = nonDetEltsUniqSet $ - exprFreeVars rhs `unionVarSet` - coVarsOfType (varType var) } - -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq - -- 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 { eb_lhs = v, eb_rhs = r, eb_info = info }) = do - e <- dsEvTerm r - let canonical = case info of - EvBindGiven{} -> True - EvBindWanted{ ebi_canonical = canonical } -> canonical - return (v, canonical, e) - - -{-********************************************************************** -* * - Desugaring EvTerms -* * -**********************************************************************-} - -dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvExpr e) = return e -dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev -dsEvTerm (EvFun { et_tvs = tvs, et_given = given - , et_binds = ev_binds, et_body = wanted_id }) - = do { dsTcEvBinds ev_binds $ \ds_ev_binds -> do - { return $ (mkLams (tvs ++ given) $ - mkCoreLets ds_ev_binds $ - Var wanted_id) } } - - -{-********************************************************************** -* * - Desugaring Typeable dictionaries -* * -**********************************************************************-} - -dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr --- Return a CoreExpr :: Typeable ty --- This code is tightly coupled to the representation --- of TypeRep, in base library Data.Typeable.Internal -dsEvTypeable ty ev - = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable - ; let kind = typeKind ty - typeable_data_con = tyConSingleDataCon tyCl -- "Data constructor" - -- for Typeable - - ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a - - -- Package up the method as `Typeable` dictionary - ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } - -type TypeRepExpr = CoreExpr - --- | Returns a @CoreExpr :: TypeRep ty@ -ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr -ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) - = do { mkTrCon <- dsLookupGlobalId mkTrConName - -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a - ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName - ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName - -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep - - ; tc_rep <- tyConRep tc -- :: TyCon - ; let ks = tyConAppArgs ty - -- Construct a SomeTypeRep - toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr - toSomeTypeRep t ev = do - rep <- getRep ev t - return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] - ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t - ; let -- :: [SomeTypeRep] - kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps - - -- Note that we use the kind of the type, not the TyCon from which it - -- is constructed since the latter may be kind polymorphic whereas the - -- former we know is not (we checked in the solver). - ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) - , Type ty - , tc_rep - , kind_args ] - -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr - ; return expr - } - -ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) - | Just (t1,t2) <- splitAppTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; 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 mkTrApp) [ k1, k2, t1, t2 ]) - [ e1, e2 ] - -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Pattern-matching bindings (HsBinds and MonoBinds) + +Handles @HsBinds@; those at the top level require different handling, +in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at +lower levels it is preserved with @let@/@letrec@s). +-} + +module GHC.HsToCore.Binds + ( dsTopLHsBinds, dsLHsBinds + , dsImpSpecs, decomposeRuleLhs + , dsHsWrapper, dsHsWrappers + , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds + , dsWarnOrphanRule + ) +where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Config +import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Module + +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 +import GHC.HsToCore.Utils +import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) + +import GHC.Hs -- lots of things +import GHC.Core -- lots of things +import GHC.Core.SimpleOpt +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.InstEnv ( CanonicalEvidence(..) ) +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.Opt.Arity ( etaExpand ) +import GHC.Core.Unfold.Make +import GHC.Core.FVs +import GHC.Core.Predicate +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Rules +import GHC.Core.Ppr( pprCoreBinders ) +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Builtin.Names +import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) + +import GHC.Tc.Types.Evidence + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Var( EvVar, mkLocalVar ) +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Unique.Set( nonDetEltsUniqSet ) + +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Data.Graph.Directed +import GHC.Data.Bag + +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.Monad + + +{-********************************************************************** +* * + Desugaring a MonoBinds +* * +**********************************************************************-} + +-- | Desugar top level binds, strict binds are treated like normal +-- binds since there is no good time to force before first usage. +dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr)) +dsTopLHsBinds binds + -- see Note [Strict binds checks] + | 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 + = do { (force_vars, prs) <- dsLHsBinds binds + ; when debugIsOn $ + do { xstrict <- xoptM LangExt.Strict + ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) } + -- with -XStrict, even top-level vars are listed as force vars. + + ; return (toOL prs) } + + where + unlifted_binds = filter (isUnliftedHsBind . unLoc) binds + bang_binds = filter (isBangedHsBind . unLoc) binds + + top_level_err bindsType (L loc bind) + = putSrcSpanDs (locA loc) $ + diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind) +{- +Note [Return non-recursive bindings in dependency order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For recursive bindings, the desugarer has no choice: it returns a single big +Rec{...} group. + +But for /non-recursive/ bindings, the desugarer guarantees to desugar them to +a sequence of non-recurive Core bindings, in dependency order. + +Why is this important? Partly it saves a bit of work in the first run of the +occurrence analyser. But more importantly, for linear types, non-recursive lets +can be linear whereas recursive-let can't. Since we check the output of the +desugarer for linearity (see also Note [Linting linearity]), desugaring +non-recursive lets to recursive lets would break linearity checks. An +alternative is to refine the typing rule for recursive lets so that we don't +have to care (see in particular #23218 and #18694), but the outcome of this line +of work is still unclear. In the meantime, being a little precise in the +desugarer is cheap. (paragraph written on 2023-06-09) + +In dsLHSBinds (and dependencies), a single binding can be desugared to multiple +bindings. For instance because the source binding has the {-# SPECIALIZE #-} +pragma. In: + +f _ = … + where + {-# SPECIALIZE g :: F Int -> F Int #-} + g :: C a => F a -> F a + g _ = … + +The g binding desugars to + +let { + $sg = … } in + + g + [RULES: "SPEC g" g @Int $dC = $sg] + g = … + +In order to avoid generating a letrec that will immediately be reordered, we +make sure to return the binding in dependency order [$sg, g]. + +-} + +-- | Desugar all other kind of bindings, Ids of strict binds are returned to +-- later be forced in the binding group body, see Note [Desugar Strict binds] +-- +-- Invariant: the desugared bindings are returned in dependency order, +-- see Note [Return non-recursive bindings in dependency order] +dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBinds binds + = do { ds_bs <- mapM dsLHsBind binds + ; return (foldr (\(a, a') (b, b') -> (a ++ b, a' ++ b')) + ([], []) ds_bs) } + +------------------------ +dsLHsBind :: LHsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) +dsLHsBind (L loc bind) = do dflags <- getDynFlags + putSrcSpanDs (locA loc) $ dsHsBind dflags bind + +-- | Desugar a single binding (or group of recursive binds). +-- +-- Invariant: the desugared bindings are returned in dependency order, +-- see Note [Return non-recursive bindings in dependency order] +dsHsBind :: DynFlags + -> HsBind GhcTc + -> DsM ([Id], [(Id,CoreExpr)]) + -- ^ The Ids of strict binds, to be forced in the body of the + -- binding group see Note [Desugar Strict binds] and all + -- bindings and their desugared right hand sides. + +dsHsBind dflags (VarBind { var_id = var + , var_rhs = expr }) + = do { core_expr <- dsLExpr expr + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr + force_var = if xopt LangExt.Strict dflags + then [id] + else [] + ; return (force_var, [core_bind]) } + +dsHsBind dflags b@(FunBind { fun_id = L loc fun + , fun_matches = matches + , fun_ext = (co_fn, tick) + }) + = dsHsWrapper co_fn $ \core_wrap -> + do { (args, body) <- matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches + + ; let body' = mkOptTickBox tick body + rhs = core_wrap (mkLams args body') + core_binds@(id,_) = makeCorePair dflags fun False 0 rhs + force_var + -- Bindings are strict when -XStrict is enabled + | xopt LangExt.Strict dflags + , matchGroupArity matches == 0 -- no need to force lambdas + = [id] + | isBangedHsBind b + = [id] + | otherwise + = [] + ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun) + -- , ppr (mg_alts matches) + -- , ppr args, ppr core_binds, ppr body']) $ + return (force_var, [core_binds]) } + +dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_ext = (ty, (rhs_tick, var_ticks)) + }) + = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss + ; body_expr <- dsGuarded grhss ty rhss_nablas + ; let body' = mkOptTickBox rhs_tick body_expr + pat' = decideBangHood dflags pat + ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body' + -- We silently ignore inline pragmas; no makeCorePair + -- Not so cool, but really doesn't matter + ; let force_var' = if isBangedLPat pat' + then [force_var] + else [] + ; return (force_var', sel_binds) } + +dsHsBind + dflags + (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig })) + = addTyCs FromSource (listToBag dicts) $ + -- addTyCs: push type constraints deeper + -- for inner pattern match check + -- See Check, Note [Long-distance information] + dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do + do { ds_binds <- dsLHsBinds binds + -- dsAbsBinds does the hard work + ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds + (isSingleton binds) has_sig } + +dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" + +----------------------- +dsAbsBinds :: DynFlags + -> [TyVar] -> [EvVar] -> [ABExport] + -> [CoreBind] -- Desugared evidence bindings + -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings + -> Bool -- Single source binding + -> Bool -- Single binding with signature + -> DsM ([Id], [(Id,CoreExpr)]) + +dsAbsBinds dflags tyvars dicts exports + ds_ev_binds (force_vars, bind_prs) is_singleton has_sig + + -- A very important common case: one exported variable + -- Non-recursive bindings come through this way + -- So do self-recursive bindings + -- gbl_id = wrap (/\tvs \dicts. let ev_binds + -- letrec bind_prs + -- in lcl_id) + | [export] <- exports + , ABE { abe_poly = global_id, abe_mono = local_id + , abe_wrap = wrap, abe_prags = prags } <- export + , Just force_vars' <- case force_vars of + [] -> Just [] + [v] | v == local_id -> Just [global_id] + _ -> Nothing + -- If there is a variable to force, it's just the + -- single variable we are binding here + = do { dsHsWrapper wrap $ \core_wrap -> do -- Usually the identity + { let rhs = core_wrap $ + mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + body + + body | has_sig + , [(_, lrhs)] <- bind_prs + = lrhs + | otherwise + = mkLetRec bind_prs (Var local_id) + + ; (spec_binds, rules) <- dsSpecs rhs prags + + ; let global_id' = addIdSpecialisations global_id rules + main_bind = makeCorePair dflags global_id' + (isDefaultMethod prags) + (dictArity dicts) rhs + + ; return (force_vars', fromOL spec_binds ++ [main_bind]) } } + + -- Another common case: no tyvars, no dicts + -- In this case we can have a much simpler desugaring + -- lcl_id{inl-prag} = rhs -- Auxiliary binds + -- gbl_id = lcl_id |> co -- Main binds + -- + -- See Note [The no-tyvar no-dict case] + | null tyvars, null dicts + = do { let wrap_first_bind f ((main, main_rhs):other_binds) = + ((main, f main_rhs):other_binds) + wrap_first_bind _ [] = panic "dsAbsBinds received an empty binding list" + + mk_main :: ABExport -> DsM (Id, CoreExpr) + mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id + , abe_wrap = wrap }) + -- No SpecPrags (no dicts) + -- Can't be a default method (default methods are singletons) + = do { dsHsWrapper wrap $ \core_wrap -> do + { return ( gbl_id `setInlinePragma` defaultInlinePragma + , core_wrap (Var lcl_id)) } } + ; main_prs <- mapM mk_main exports + ; let bind_prs' = map mk_aux_bind bind_prs + -- When there's a single source binding, we wrap the evidence binding in a + -- separate let-rec (DSB1) inside the first desugared binding (DSB2). + -- See Note [The no-tyvar no-dict case]. + final_prs | is_singleton = wrap_first_bind (mkCoreLets ds_ev_binds) bind_prs' + | otherwise = flattenBinds ds_ev_binds ++ bind_prs' + ; return (force_vars, final_prs ++ main_prs ) } + + -- The general case + -- See Note [Desugaring AbsBinds] + | otherwise + = do { let aux_binds = Rec (map mk_aux_bind bind_prs) + -- Monomorphic recursion possible, hence Rec + + new_force_vars = get_new_force_vars force_vars + locals = map abe_mono exports + all_locals = locals ++ new_force_vars + tup_expr = mkBigCoreVarTup all_locals + tup_ty = exprType tup_expr + ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $ + mkCoreLets ds_ev_binds $ + mkLet aux_binds $ + tup_expr + + ; 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 + -- Note [Desugar Strict binds] + ; (exported_force_vars, extra_exports) <- get_exports force_vars + + ; let mk_bind (ABE { abe_wrap = wrap + , abe_poly = global + , abe_mono = local, abe_prags = spec_prags }) + -- See Note [ABExport wrapper] in "GHC.Hs.Binds" + = 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 $ + mkVarApps (Var poly_tup_id) (tyvars ++ dicts) + rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs + ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags + ; let global' = (global `setInlinePragma` defaultInlinePragma) + `addIdSpecialisations` rules + -- Kill the INLINE pragma because it applies to + -- the user written (local) function. The global + -- Id is just the selector. Hmm. + ; return (fromOL spec_binds ++ [(global', rhs)]) } } + + ; export_binds_s <- mapM mk_bind (exports ++ extra_exports) + + ; return ( exported_force_vars + , (poly_tup_id, poly_tup_rhs) : + concat export_binds_s) } + where + mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr) + mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id + `orElse` lcl_id + in + makeCorePair dflags lcl_w_inline False 0 rhs + + inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with + -- the inline pragma from the source + -- The type checker put the inline pragma + -- on the *global* Id, so we need to transfer it + inline_env + = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag) + | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports + , let prag = idInlinePragma gbl_id ] + + global_env :: IdEnv Id -- Maps local Id to its global exported Id + global_env = + mkVarEnv [ (local, global) + | ABE { abe_mono = local, abe_poly = global } <- exports + ] + + -- find variables that are not exported + get_new_force_vars lcls = + foldr (\lcl acc -> case lookupVarEnv global_env lcl of + Just _ -> acc + Nothing -> lcl:acc) + [] lcls + + -- find exports or make up new exports for force variables + get_exports :: [Id] -> DsM ([Id], [ABExport]) + get_exports lcls = + foldM (\(glbls, exports) lcl -> + case lookupVarEnv global_env lcl of + Just glbl -> return (glbl:glbls, exports) + Nothing -> do export <- mk_export lcl + let glbl = abe_poly export + return (glbl:glbls, export:exports)) + ([],[]) lcls + + mk_export local = + do global <- newSysLocalMDs + (exprType (mkLams tyvars (mkLams dicts (Var local)))) + return (ABE { abe_poly = global + , abe_mono = local + , abe_wrap = WpHole + , abe_prags = SpecPrags [] }) + +-- | This is where we apply INLINE and INLINABLE pragmas. All we need to +-- do is to attach the unfolding information to the Id. +-- +-- Other decisions about whether to inline are made in +-- `calcUnfoldingGuidance` but the decision about whether to then expose +-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal` +-- using this information. +------------------------ +makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr + -> (Id, CoreExpr) +makeCorePair dflags gbl_id is_default_method dict_arity rhs + | is_default_method -- Default methods are *always* inlined + -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) + + | otherwise + = case inlinePragmaSpec inline_prag of + NoUserInlinePrag -> (gbl_id, rhs) + NoInline {} -> (gbl_id, rhs) + Opaque {} -> (gbl_id, rhs) + Inlinable {} -> (gbl_id `setIdUnfolding` inlinable_unf, rhs) + Inline {} -> inline_pair + where + simpl_opts = initSimpleOpts dflags + inline_prag = idInlinePragma gbl_id + inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs + inline_pair + | Just arity <- inlinePragmaSat inline_prag + -- Add an Unfolding for an INLINE (but not for NOINLINE) + -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] + , let real_arity = dict_arity + arity + -- NB: The arity passed to mkInlineUnfoldingWithArity + -- must take account of the dictionaries + = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs + , etaExpand real_arity rhs) + + | otherwise + = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $ + (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +{- +Note [Desugaring AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the general AbsBinds case we desugar the binding to this: + + tup a (d:Num a) = let fm = ...gm... + gm = ...fm... + in (fm,gm) + f a d = case tup a d of { (fm,gm) -> fm } + g a d = case tup a d of { (fm,gm) -> fm } + +Note [Rules and inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Common special case: no type or dictionary abstraction +This is a bit less trivial than you might suppose +The naive way would be to desugar to something like + f_lcl = ...f_lcl... -- The "binds" from AbsBinds + M.f = f_lcl -- Generated from "exports" +But we don't want that, because if M.f isn't exported, +it'll be inlined unconditionally at every call site (its rhs is +trivial). That would be ok unless it has RULES, which would +thereby be completely lost. Bad, bad, bad. + +Instead we want to generate + M.f = ...f_lcl... + f_lcl = M.f +Now all is cool. The RULES are attached to M.f (by SimplCore), +and f_lcl is rapidly inlined away. + +This does not happen in the same way to polymorphic binds, +because they desugar to + M.f = /\a. let f_lcl = ...f_lcl... in f_lcl +Although I'm a bit worried about whether full laziness might +float the f_lcl binding out and then inline M.f at its call site + +Note [Specialising in no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even if there are no tyvars or dicts, we may have specialisation pragmas. +Class methods can generate + AbsBinds [] [] [( ... spec-prag] + { AbsBinds [tvs] [dicts] ...blah } +So the overloading is in the nested AbsBinds. A good example is in GHC.Float: + + class (Real a, Fractional a) => RealFrac a where + round :: (Integral b) => a -> b + + instance RealFrac Float where + {-# SPECIALIZE round :: Float -> Int #-} + +The top-level AbsBinds for $cround has no tyvars or dicts (because the +instance does not). But the method is locally overloaded! + +Note [The no-tyvar no-dict case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are desugaring + AbsBinds { tyvars = [] + , dicts = [] + , exports = [ ABE f fm, ABE g gm ] + , binds = B + , ev_binds = EB } +That is: no type variables or dictionary abstractions. Here, `f` and `fm` are +the polymorphic and monomorphic versions of `f`; in this special case they will +both have the same type. + +Specialising Note [Desugaring AbsBinds] for this case gives the desugaring + + tup = letrec EB' in letrec B' in (fm,gm) + f = case tup of { (fm,gm) -> fm } + g = case tup of { (fm,gm) -> fm } + +where B' is the result of desugaring B. This desugaring is a little silly: we +don't need the intermediate tuple (contrast with the general case where fm and f +have different types). So instead, in this case, we desugar to + + EB'; B'; f=fm; g=gm + +This is done in the `null tyvars, null dicts` case of `dsAbsBinds`. + +But there is a wrinkle (DSB1). If the original binding group was +/non-recursive/, we want to return a bunch of non-recursive bindings in +dependency order: see Note [Return non-recursive bindings in dependency order]. + +But there is no guarantee that EB', the desugared evidence bindings, will be +non-recursive. Happily, in the non-recursive case, B will have just a single +binding (f = rhs), so we can wrap EB' around its RHS, thus: + + fm = letrec EB' in rhs; f = fm + +There is a sub-wrinkle (DSB2). If B is a /pattern/ bindings, it will desugar to +a "main" binding followed by a bunch of selectors. The main binding always +comes first, so we can pick it out and wrap EB' around its RHS. For example + + AbsBinds { tyvars = [] + , dicts = [] + , exports = [ ABE p pm, ABE q qm ] + , binds = PatBind (pm, Just qm) rhs + , ev_binds = EB } + +can desguar to + + pt = let EB' in + case rhs of + (pm,Just qm) -> (pm,qm) + pm = case pt of (pm,qm) -> pm + qm = case pt of (pm,qm) -> qm + + p = pm + q = qm + +The first three bindings come from desugaring the PatBind, and subsequently +wrapping the RHS of the main binding in EB'. + +Why got to this trouble? It's a common case, and it removes the +quadratic-sized tuple desugaring. Less clutter, hopefully faster +compilation, especially in a case where there are a *lot* of +bindings. + +Note [Eta-expanding INLINE things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo :: Eq a => a -> a + {-# INLINE foo #-} + foo x = ... + +If (foo d) ever gets floated out as a common sub-expression (which can +happen as a result of method sharing), there's a danger that we never +get to do the inlining, which is a Terribly Bad thing given that the +user said "inline"! + +To avoid this we preemptively eta-expand the definition, so that foo +has the arity with which it is declared in the source code. In this +example it has arity 2 (one for the Eq and one for x). Doing this +should mean that (foo d) is a PAP and we don't share it. + +Note [Nested arities] +~~~~~~~~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the unfolding on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! + + +Note [Desugar Strict binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma + +Desugaring strict variable bindings looks as follows (core below ==>) + + let !x = rhs + in body +==> + let x = rhs + in x `seq` body -- seq the variable + +and if it is a pattern binding the desugaring looks like + + let !pat = rhs + in body +==> + let x = rhs -- bind the rhs to a new variable + pat = x + in x `seq` body -- seq the new variable + +if there is no variable in the pattern desugaring looks like + + let False = rhs + in body +==> + let x = case rhs of {False -> (); _ -> error "Match failed"} + in x `seq` body + +In order to force the Ids in the binding group they are passed around +in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind. + +Consider a recursive group like this + + letrec + f : g = rhs[f,g] + in + +Without `Strict`, we get a translation like this: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (fm,gm) + + in let f = /\a. case t a of (fm,_) -> fm + in let g = /\a. case t a of (_,gm) -> gm + in + +Here `tm` is the monomorphic binding for `rhs`. + +With `Strict`, we want to force `tm`, but NOT `fm` or `gm`. +Alas, `tm` isn't in scope in the `in ` part. + +The simplest thing is to return it in the polymorphic +tuple `t`, thus: + + let t = /\a. letrec tm = rhs[fm,gm] + fm = case t of fm:_ -> fm + gm = case t of _:gm -> gm + in + (tm, fm, gm) + + in let f = /\a. case t a of (_,fm,_) -> fm + in let g = /\a. case t a of (_,_,gm) -> gm + in let tm = /\a. case t a of (tm,_,_) -> tm + in tm `seq` + + +See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more +detailed explanation of the desugaring of strict bindings. + +Wrinkle 1: forcing linear variables + +Consider + + let %1 !x = rhs in +==> + let x = rhs in x `seq` + +In the desugared version x is used in both arguments of seq. This isn't +recognised a linear. So we can't strictly speaking use seq. Instead, the code is +really desugared as + + let x = rhs in case x of x { _ -> } + +The shadowing with the case-binder is crucial. The linear linter (see +Note [Linting linearity] in GHC.Core.Lint) understands this as linear. This is +what the seqVar function does. + +To be more precise, suppose x has multiplicity p, the fully annotated seqVar (in +Core, p is really stored inside x) is + + case x of %p x { _ -> } + +In linear Core, case u of %p y { _ -> v } consumes u with multiplicity p, and +makes y available with multiplicity p in v. Which is exactly what we want. + +Wrinkle 2: linear patterns + +Consider the following linear binding (linear lets are always non-recursive): + + let + %1 f : g = rhs + in + +The general case would desugar it to + + let t = let tm = rhs + fm = case tm of fm:_ -> fm + gm = case tm of _:gm -> gm + in + (tm, fm, gm) + + in let f = case t a of (_,fm,_) -> fm + in let g = case t a of (_,_,gm) -> gm + in let tm = case t a of (tm,_,_) -> tm + in tm `seq` + +But all the case expression drop variables, which is prohibited by +linearity. But because this is a non-recursive let (in particular we're +desugaring a single binding), we can (and do) desugar the binding as a simple +case-expression instead: + + case rhs of { + (f:g) -> + } + +This is handled by the special case: a non-recursive PatBind in +GHC.HsToCore.Expr.ds_val_bind. + +Note [Strict binds checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several checks around properly formed strict bindings. They +all link to this Note. These checks must be here in the desugarer because +we cannot know whether or not a type is unlifted until after zonking, due +to representation polymorphism. These checks all used to be handled in the +typechecker in checkStrictBinds (before Jan '17). + +We define an "unlifted bind" to be any bind that binds an unlifted id. Note that + + x :: Char + (# True, x #) = blah + +is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind. + +Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind. +Define a "strict bind" to be either an unlifted bind or a banged bind. + +The restrictions are: + 1. Strict binds may not be top-level. Checked in dsTopLHsBinds. + + 2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged + unlifted bind, but an unbanged bind looks lazy, and we don't want users to be + surprised by the strictness of an unlifted bind.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type + variables or constraints.) Checked in first clause + of GHC.HsToCore.Expr.ds_val_bind. + + 4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind. + +Note [Desugaring new-form SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker, +which is desugared in this module by `dsSpec`. For the context see +Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + +Suppose we have + f :: forall a b c d. (Ord a, Ord b, Eq c, Ix d) => ... + f = rhs + {-# SPECIALISE f @p @[p] @[Int] @(q,r) #-} + +The type-checker generates `the_call` which looks like + + spe_bndrs = (dx1 :: Ord p) (dx2::Ix q) (dx3::Ix r) + the_call = let d6 = dx1 + d2 = $fOrdList d6 + d3 = $fEqList $fEqInt + d7 = dx1 -- Solver may introduce + d1 = d7 -- these indirections + d4 = $fIxPair dx2 dx3 + in f @p @p @[Int] @(q,r) + (d1::Ord p) (d2::Ord [p]) (d3::Eq [Int]) (d4::Ix (q,r) + +We /could/ generate + RULE f d1 d2 d3 d4 e1..en = $sf d1 d2 d3 d4 + $sf d1 d2 d3 d4 = d1 d2 d3 d4 + +But that would do no specialisation at all! What we want is this: + RULE f d1 _d2 _d3 d4 e1..en = $sf d1 d4 + $sf d1 d4 = let d7 = d1 -- Renaming + dx1 = d1 -- Renaming + d6 = d1 -- Renaming + d2 = $fOrdList d6 + d3 = $fEqList $fEqInt + in rhs d1 d2 d3 d4 + +Notice that: + * We pass some, but not all, of the matched dictionaries to $sf + + * We get specialisations for d2 and d3, but not for d1, nor d4. + + * We had to introduce some renaming bindings at the top + to line things up + +The transformation goes in these steps + +(S1) decomposeCall: decompose `the_call` into + - `binds`: the enclosing let-bindings + - `rule_lhs_args`: the arguments of the call itself + + If the expression in the SPECIALISE pragma had a type signature, such as + SPECIALISE g :: Eq b => Int -> b -> b + then the desugared expression may have type abstractions and applications + "in the way", like this: + (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b) + The lambdas come from the type signature, which is then re-instantiated, + hence the applications of those lambdas. + + To handle these, `decomposeCall` uses the simple optimiser to simplify + this to + let { d = d2; d1 = $dfOrdInt } in f @Int @b d1 d + + Wrinkle (S1a): do no inlining in this "simple optimiser" phase: + use `simpleOptExprNoInline`. E.g. we don't want to turn it into + f @Int @b $dfOrdInt d2 + because the latter is harder to match. Similarly if we have + let { d1=d; d2=d } in f d1 d2 + we don't want to inline d1/d2 to get this + f d d + + TL;DR: as a result the dictionary arguments of the actual call, + `rule_lhs_args` are all distinct dictionary variables, not + expressions. + +(S2) Compute `rule_bndrs`: the free vars of `rule_lhs_args`, which + will be the forall'd template variables of the RULE. In the example, + rule_bndrs = d1,d2,d3,d4 + These variables will get values from a successful RULE match. + +(S3) `getRenamings`: starting from the rule_bndrs, make bindings for + all other variables that are equal to them. In the example, we + make renaming-bindings for d7, dx1, d6. Our goal is to bind + as many variables as possible, by deducing them from `rule_bndrs`. + If we have the binding + d1 = d7 (where `d1` is a rule_bndr) + we want to generate the renaming + d7 = d1 + which instead deduces d7 from d1 + + NB1: we don't actually have to remove the original bindings; + it's harmless to leave them + NB2: We also reverse bindings like d1 = d2 |> co, to get + d2 = d1 |> sym co + It's easy and slightly improves our ability to get bindings + for local variables from `rule_bndrs`. I'm not sure if it + matters in practice, but it's easy to do. + NB3: `getRenamings` works innermost first, so that we get transitivity. + E.g in our example we have + d7 = dx1 + d1 = d7 where d1 is rule_bndr + `getRenamings` generate the renamings + dx1 = d1 + d7 = d2 + +(S4) `pickSpecBinds`: pick the bindings we want to keep in the + specialised function. We start from `known_vars`, the variables we + know, namely the `rule_bndrs` and the binders from (S3), which are + all equal to one of the `rule_bndrs`. + + Then we keep a binding if the free vars of its RHS are all known. + In our example, `d2` and `d3` are both picked, but `d4` is not. + The non-picked ones won't end up being specialised. + +(S5) Finally, work out which of the `rule_bndrs` we must pass on to + specialised function. We just filter out ones bound by a renaming + or a picked binding. +-} + +------------------------ +dsSpecs :: CoreExpr -- Its rhs + -> TcSpecPrags + -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids +-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig +dsSpecs _ IsDefaultMethod = return (nilOL, []) +dsSpecs poly_rhs (SpecPrags sps) + = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps + ; let (spec_binds_s, rules) = unzip pairs + ; return (concatOL spec_binds_s, rules) } + +dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule]) +dsImpSpecs imp_specs + = do { spec_prs <- mapMaybeM spec_one imp_specs + ; let (spec_binds, spec_rules) = unzip spec_prs + ; return (concatOL spec_binds, spec_rules) } + where + spec_one (L loc prag) = putSrcSpanDs loc $ + dsSpec (get_rhs prag) prag + + get_rhs (SpecPrag poly_id _ _) = get_rhs1 poly_id + get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id + + get_rhs1 poly_id + | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id) + = unfolding -- Imported Id; this is its unfolding + -- Use realIdUnfolding so we get the unfolding + -- even when it is a loop breaker. + -- We want to specialise recursive functions! + | otherwise = pprPanic "dsImpSpecs" (ppr poly_id) + -- The type checker has checked that it *has* an unfolding + +dsLSpec :: CoreExpr -> Located TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsLSpec poly_rhs (L loc prag) + = putSrcSpanDs loc $ dsSpec poly_rhs prag + +dsSpec :: CoreExpr -- RHS to be specialised + -> TcSpecPrag + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl) + -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + | (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co + -- spec_co looks like + -- \spec_bndrs. [] spec_args + -- perhaps with the body of the lambda wrapped in some WpLets + -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2 + = dsHsWrapper spec_app $ \core_app -> + dsSpec_help (idName poly_id) poly_id poly_rhs + spec_inl spec_bndrs (core_app (Var poly_id)) + +dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm + , spe_fn_id = poly_id + , spe_inl = spec_inl + , spe_bndrs = bndrs + , spe_call = the_call }) + -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides] + unsetWOptM Opt_WarnIdentities $ + zapUnspecables $ + dsLExpr the_call + ; dsSpec_help poly_nm poly_id poly_rhs spec_inl bndrs ds_call } + +dsSpec_help :: Name -> Id -> CoreExpr -- Function to specialise + -> InlinePragma -> [Var] -> CoreExpr + -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) +dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call + = do { -- Decompose the call + -- Step (S1) of Note [Desugaring new-form SPECIALISE pragmas] + mb_call_info <- decomposeCall poly_id ds_call + ; case mb_call_info of { + Nothing -> return Nothing ; + Just (binds, rule_lhs_args) -> + + do { dflags <- getDynFlags + ; this_mod <- getModule + ; uniq <- newUnique + ; let locals = mkVarSet orig_bndrs `extendVarSetList` bindersOfBinds binds + is_local :: Var -> Bool + is_local v = v `elemVarSet` locals + + -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas] + rule_bndrs = scopedSort (exprsSomeFreeVarsList is_local rule_lhs_args) + + -- getRenamings: (S3) of Note [Desugaring new-form SPECIALISE pragmas] + rn_binds = getRenamings orig_bndrs binds rule_bndrs + + -- pickSpecBinds: (S4) of Note [Desugaring new-form SPECIALISE pragmas] + known_vars = mkVarSet rule_bndrs `extendVarSetList` bindersOfBinds rn_binds + picked_binds = pickSpecBinds is_local known_vars binds + + -- Find `spec_bndrs`: (S5) of Note [Desugaring new-form SPECIALISE pragmas] + -- Make spec_bndrs, the variables to pass to the specialised + -- function, by filtering out the rule_bndrs that aren't needed + spec_binds_bndr_set = mkVarSet (bindersOfBinds picked_binds) + `minusVarSet` exprsFreeVars (rhssOfBinds rn_binds) + spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs + + mk_spec_body fn_body = mkLets (rn_binds ++ picked_binds) $ + mkApps fn_body rule_lhs_args + -- NB: not mkCoreApps! That uses exprType on fun + -- which fails in specUnfolding, sigh + + poly_name = idName poly_id + spec_occ = mkSpecOcc (getOccName poly_name) + spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) + id_inl = idInlinePragma poly_id + + simpl_opts = initSimpleOpts dflags + fn_unf = realIdUnfolding poly_id + spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf + spec_info = vanillaIdInfo + `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl + `setUnfoldingInfo` spec_unf + spec_id = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info + -- Specialised binding is toplevel, hence Many. + + -- The RULE looks like + -- RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs + -- The specialised function looks like + -- $sf spec_bndrs = mk_spec_body + -- We also use mk_spec_body to specialise the methods in f's stable unfolding + -- NB: spec_bindrs is a subset of rule_bndrs + rule = mkSpecRule dflags this_mod False rule_act (text "USPEC") + poly_id rule_bndrs rule_lhs_args + (mkVarApps (Var spec_id) spec_bndrs) + + rule_ty = exprType (mkApps (Var poly_id) rule_lhs_args) + spec_ty = mkLamTypes spec_bndrs rule_ty + spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs) + + result = (unitOL (spec_id, spec_rhs), rule) + -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because + -- makeCorePair overwrites the unfolding, which we have + -- just created using specUnfolding + ; tracePm "dsSpec(new route)" $ + vcat [ text "poly_id" <+> ppr poly_id + , text "unfolding" <+> ppr (realIdUnfolding poly_id) + , text "orig_bndrs" <+> pprCoreBinders orig_bndrs + , text "locals" <+> ppr locals + , text "fvs" <+> ppr (exprsSomeFreeVarsList is_local rule_lhs_args) + , text "ds_call" <+> ppr ds_call + , text "binds" <+> ppr binds + , text "rule_lhs_args" <+> ppr rule_lhs_args + , text "rule_bndrs" <+> ppr rule_bndrs + , text "spec_bndrs" <+> ppr spec_bndrs + , text "rn_binds" <+> ppr rn_binds + , text "picked_binds" <+> ppr picked_binds ] + + ; dsWarnOrphanRule rule + + ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs + no_act_spec spec_inl rule_act of + Nothing -> return (Just result) + + Just reason -> do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason + ; if uselessSpecialisePragmaKeepAnyway reason + then return (Just result) + else return Nothing } } } } + + where + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + id_inl = idInlinePragma poly_id + inl_prag_act = inlinePragmaActivation id_inl + spec_prag_act = inlinePragmaActivation spec_inl + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline _ -> isNeverActive spec_prag_act + Opaque _ -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inl_prag_act -- Inherit + | otherwise = spec_prag_act -- Specified by user + + is_dfun = case idDetails poly_id of + DFunId {} -> True + _ -> False + +decomposeCall :: Id -> CoreExpr + -> DsM (Maybe ([CoreBind], [CoreExpr] )) +-- Decompose the call into (let in f ) +-- See (S1) in Note [Desugaring new-form SPECIALISE pragmas] +decomposeCall poly_id ds_call + = do { dflags <- getDynFlags + ; let simpl_opts = initSimpleOpts dflags + core_call = simpleOptExprNoInline simpl_opts ds_call + -- simpleOptExprNoInline: see Wrinkle (S1a)! + + ; case go [] core_call of { + Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call) + ; return Nothing } ; + Just result -> return (Just result) } } + where + go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind],[CoreExpr]) + go acc (Let bind body) = go (bind:acc) body + go acc (Cast e _) = go acc e -- Discard outer casts + -- ToDo: document this + go acc e + | (Var fun, args) <- collectArgs e + = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $ + Just (reverse acc, args) + | otherwise + = Nothing + + -- Is this SPECIALISE pragma useless? +checkUselessSpecPrag :: Id -> [CoreExpr] + -> [Var] -> Bool -> InlinePragma -> Activation + -> Maybe UselessSpecialisePragmaReason +checkUselessSpecPrag poly_id rule_lhs_args + spec_bndrs no_act_spec spec_inl rule_act + | isJust (isClassOpId_maybe poly_id) + -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + = Just UselessSpecialiseForClassMethodSelector + + | no_act_spec, isNeverActive rule_act + -- Function is NOINLINE, and the specialisation inherits that + -- See Note [Activation pragmas for SPECIALISE] + = Just UselessSpecialiseForNoInlineFunction + + | all is_nop_arg rule_lhs_args, not (isInlinePragma spec_inl) + -- The specialisation does nothing. + -- But don't complain if it is SPECIALISE INLINE (#4444) + = Just UselessSpecialiseNoSpecialisation + + | otherwise + = Nothing + + where + is_nop_arg (Type {}) = True + is_nop_arg (Coercion {}) = True + is_nop_arg (Cast e _) = is_nop_arg e + is_nop_arg (Tick _ e) = is_nop_arg e + is_nop_arg (Var x) = x `elem` spec_bndrs + is_nop_arg _ = False + + +getRenamings :: [Var] -> [CoreBind] -- orig_bndrs and bindings + -> [Var] -- rule_bndrs + -> [CoreBind] -- Binds some of the orig_bndrs to a rule_bndr +getRenamings orig_bndrs binds rule_bndrs + = [ NonRec b e | b <- orig_bndrs + , not (b `elem` rule_bndrs) + , Just e <- [lookupVarEnv final_renamings b] ] + where + init_renamings, final_renamings :: IdEnv CoreExpr + -- In this function, IdEnv maps a local variable to (v |> co), + -- where `v` is a rule_bndr + + init_renamings = mkVarEnv [ (v, Var v) | v <- rule_bndrs, isId v ] + final_renamings = go binds + + go :: [CoreBind] -> IdEnv CoreExpr + go [] = init_renamings + go (bind : binds) + | NonRec b rhs <- bind + , Just (v, mco) <- getCastedVar rhs + , Just e <- lookupVarEnv renamings b + = extendVarEnv renamings v (mkCastMCo e (mkSymMCo mco)) + | otherwise + = renamings + where + renamings = go binds + +pickSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind] -> [CoreBind] +pickSpecBinds _ _ [] = [] +pickSpecBinds is_local known_bndrs (bind:binds) + | all keep_me (rhssOfBind bind) + , let known_bndrs' = known_bndrs `extendVarSetList` bindersOf bind + = bind : pickSpecBinds is_local known_bndrs' binds + | otherwise + = pickSpecBinds is_local known_bndrs binds + where + keep_me rhs = isEmptyVarSet (exprSomeFreeVars bad_var rhs) + bad_var v = is_local v && not (v `elemVarSet` known_bndrs) + +getCastedVar :: CoreExpr -> Maybe (Var, MCoercionR) +getCastedVar (Var v) = Just (v, MRefl) +getCastedVar (Cast (Var v) co) = Just (v, MCo co) +getCastedVar _ = Nothing + +specFunInlinePrag :: Id -> InlinePragma + -> InlinePragma -> InlinePragma +-- See Note [Activation pragmas for SPECIALISE] +specFunInlinePrag poly_id id_inl spec_inl + | not (isDefaultInlinePragma spec_inl) = spec_inl + | isGlobalId poly_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = id_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + +dsWarnOrphanRule :: CoreRule -> DsM () +dsWarnOrphanRule rule + = when (ruleIsOrphan rule) $ + diagnosticDs (DsOrphanRule rule) + +{- Note [SPECIALISE on INLINE functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to warn that using SPECIALISE for a function marked INLINE +would be a no-op; but it isn't! Especially with worker/wrapper split +we might have + {-# INLINE f #-} + f :: Ord a => Int -> a -> ... + f d x y = case x of I# x' -> $wf d x' y + +We might want to specialise 'f' so that we in turn specialise '$wf'. +We can't even /name/ '$wf' in the source code, so we can't specialise +it even if we wanted to. #10721 is a case in point. + +Note [Activation pragmas for SPECIALISE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From a user SPECIALISE pragma for f, we generate + a) A top-level binding spec_fn = rhs + b) A RULE f dOrd = spec_fn + +We need two pragma-like things: + +* spec_fn's inline pragma: inherited from f's inline pragma (ignoring + activation on SPEC), unless overridden by SPEC INLINE + +* Activation of RULE: from SPECIALISE pragma (if activation given) + otherwise from f's inline pragma + +This is not obvious (see #5237)! + +Examples Rule activation Inline prag on spec'd fn +--------------------------------------------------------------------- +SPEC [n] f :: ty [n] Always, or NOINLINE [n] + copy f's prag + +NOINLINE f +SPEC [n] f :: ty [n] NOINLINE + copy f's prag + +NOINLINE [k] f +SPEC [n] f :: ty [n] NOINLINE [k] + copy f's prag + +INLINE [k] f +SPEC [n] f :: ty [n] INLINE [k] + copy f's prag + +SPEC INLINE [n] f :: ty [n] INLINE [n] + (ignore INLINE prag on f, + same activation for rule and spec'd fn) + +NOINLINE [k] f +SPEC f :: ty [n] INLINE [k] + + +************************************************************************ +* * +\subsection{Adding inline pragmas} +* * +************************************************************************ +-} + +decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr + -> VarSet -- Free vars of the RHS + -> Either DsMessage ([Var], Id, [CoreExpr]) +-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, +-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs +-- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS]) +-- +-- Returns an error message if the LHS isn't of the expected shape +-- Note [Decomposing the left-hand side of a RULE] +decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs + | Var funId <- fun2 + , Just con <- isDataConId_maybe funId + = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] + + | otherwise = case decompose fun2 args2 of + Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "rhs_fvs:" <+> ppr rhs_fvs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "lhs2:" <+> ppr lhs2 + -- , text "fun2:" <+> ppr fun2 + -- , text "args2:" <+> ppr args2 + -- ]) $ + Left (DsRuleLhsTooComplicated orig_lhs lhs2) + + Just (fn_id, args) + | not (null unbound) -> + -- Check for things unbound on LHS + -- See Note [Unused spec binders] + -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs_fvs:" <+> ppr lhs_fvs + -- , text "rhs_fvs:" <+> ppr rhs_fvs + -- , text "unbound:" <+> ppr unbound + -- ]) $ + Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) + | otherwise -> + -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs + -- , text "orig_lhs:" <+> ppr orig_lhs + -- , text "lhs1:" <+> ppr lhs1 + -- , text "trimmed_bndrs:" <+> ppr trimmed_bndrs + -- , text "extra_dicts:" <+> ppr extra_dicts + -- , text "fn_id:" <+> ppr fn_id + -- , text "args:" <+> ppr args + -- , text "args fvs:" <+> ppr (exprsFreeVarsList args) + -- ]) $ + Right (trimmed_bndrs ++ extra_dicts, fn_id, args) + + where -- See Note [Variables unbound on the LHS] + lhs_fvs = exprsFreeVars args + all_fvs = lhs_fvs `unionVarSet` rhs_fvs + trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs + unbound = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs + -- Needed on RHS but not bound on LHS + + -- extra_dicts: see Note [Free dictionaries on rule LHS] +-- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base + extra_dicts + = [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d) + | d <- exprsSomeFreeVarsList is_extra args ] + + is_extra v + = isSimplePredTy (idType v) + -- isSimplePredTy: includes coercions and dictionaries + -- But NOT dictionary functions; and in particular not + -- superclass-selector fuctions + + && not (v `elemVarSet` orig_bndr_set) + && not (v == fn_id) + -- fn_id: do not quantify over the function itself, which may + -- itself be a dictionary (in pathological cases, #10251) + + where + simpl_opts = initSimpleOpts dflags + orig_bndr_set = mkVarSet orig_bndrs + + lhs1 = drop_dicts orig_lhs + lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS] + (fun2,args2) = collectArgs lhs2 + + decompose (Var fn_id) args + | not (fn_id `elemVarSet` orig_bndr_set) + = Just (fn_id, args) + + decompose _ _ = Nothing + + drop_dicts :: CoreExpr -> CoreExpr + drop_dicts e + = wrap_lets needed bnds body + where + needed = orig_bndr_set `minusVarSet` exprFreeVars body + (bnds, body) = split_lets (occurAnalyseExpr e) + -- The occurAnalyseExpr drops dead bindings which is + -- crucial to ensure that every binding is used later; + -- which in turn makes wrap_lets work right + + split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) + split_lets (Let (NonRec d r) body) + | isPredTy (idType d) + -- isPredTy: catches dictionaries, yes, but also catches + -- dictionary /functions/ arising from solving a + -- quantified contraint (see #24370) + = ((d,r):bs, body') + where (bs, body') = split_lets body + + -- handle "unlifted lets" too, needed for "map/coerce" + split_lets (Case r d _ [Alt DEFAULT _ body]) + | isCoVar d + = ((d,r):bs, body') + where (bs, body') = split_lets body + + split_lets e = ([], e) + + wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr + wrap_lets _ [] body = body + wrap_lets needed ((d, r) : bs) body + | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body) + | otherwise = wrap_lets needed bs body + where + rhs_fvs = exprFreeVars r + needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d + +{- +Note [Variables unbound on the LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously want to complain about + RULE forall x. f True = not x +because the forall'd variable `x` is not bound on the LHS. + +It can be a bit delicate when dictionaries are involved. +Consider #22471 + {-# RULES "foo" forall (f :: forall a. [a] -> Int). + foo (\xs. 1 + f xs) = 2 + foo f #-} + +We get two dicts on the LHS, one from `1` and one from `+`. +For reasons described in Note [The SimplifyRule Plan] in +GHC.Tc.Gen.Sig, we quantify separately over those dictionaries: + forall f (d1::Num Int) (d2 :: Num Int). + foo (\xs. (+) d1 (fromInteger d2 1) xs) = ... + +Now the desugarer shortcircuits (fromInteger d2 1) to (I# 1); so d2 is +not mentioned at all (on LHS or RHS)! We don't want to complain about +and unbound d2. Hence the trimmed_bndrs. + +Note [Decomposing the left-hand side of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several things going on here. +* drop_dicts: see Note [Drop dictionary bindings on rule LHS] +* simpleOptExpr: see Note [Simplify rule LHS] +* extra_dict_bndrs: see Note [Free dictionaries on rule LHS] + +Note [Free dictionaries on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, +which is presumably in scope at the function definition site, we can quantify +over it too. *Any* dict with that type will do. + +So for example when you have + f :: Eq a => a -> a + f = + ... SPECIALISE f :: Int -> Int ... + +Then we get the SpecPrag + SpecPrag (f Int dInt) + +And from that we want the rule + + RULE forall dInt. f Int dInt = f_spec + f_spec = let f = in f Int dInt + +But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External +Name, and you can't bind them in a lambda or forall without getting things +confused. Likewise it might have a stable unfolding or something, which would be +utterly bogus. So we really make a fresh Id, with the same unique and type +as the old one, but with an Internal name and no IdInfo. + +Note [Drop dictionary bindings on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +drop_dicts drops dictionary bindings on the LHS where possible. + E.g. let d:Eq [Int] = $fEqList $fEqInt in f d + --> f d + Reasoning here is that there is only one d:Eq [Int], and so we can + quantify over it. That makes 'd' free in the LHS, but that is later + picked up by extra_dict_bndrs (see Note [Unused spec binders]). + + NB 1: We can only drop the binding if the RHS of the binding doesn't + mention one of the orig_bndrs, which we assume occur on RHS of + the rule. Example + f :: (Eq a) => b -> a -> a + {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-} + Here we want to end up with + RULE forall d:Eq a. f ($dfEqList d) = f_spec d + Of course, the ($dfEqlist d) in the pattern makes it less likely + to match, but there is no other way to get d:Eq a + + NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all + the evidence bindings to be wrapped around the outside of the + LHS. (After simplOptExpr they'll usually have been inlined.) + dsHsWrapper does dependency analysis, so that civilised ones + will be simple NonRec bindings. We don't handle recursive + dictionaries! + + NB3: In the common case of a non-overloaded, but perhaps-polymorphic + specialisation, we don't need to bind *any* dictionaries for use + in the RHS. For example (#8331) + {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-} + useAbstractMonad :: MonadAbstractIOST m => m Int + Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code + but the RHS uses no dictionaries, so we want to end up with + RULE forall s (d :: MonadAbstractIOST (ReaderT s)). + useAbstractMonad (ReaderT s) d = $suseAbstractMonad s + + #8848 is a good example of where there are some interesting + dictionary bindings to discard. + +The drop_dicts algorithm is based on these observations: + + * Given (let d = rhs in e) where d is a DictId, + matching 'e' will bind e's free variables. + + * So we want to keep the binding if one of the needed variables (for + which we need a binding) is in fv(rhs) but not already in fv(e). + + * The "needed variables" are simply the orig_bndrs. Consider + f :: (Eq a, Show b) => a -> b -> String + ... SPECIALISE f :: (Show b) => Int -> b -> String ... + Then orig_bndrs includes the *quantified* dictionaries of the type + namely (dsb::Show b), but not the one for Eq Int + +So we work inside out, applying the above criterion at each step. + + +Note [Simplify rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~ +simplOptExpr occurrence-analyses and simplifies the LHS: + + (a) Inline any remaining dictionary bindings (which hopefully + occur just once) + + (b) Substitute trivial lets, so that they don't get in the way. + Note that we substitute the function too; we might + have this as a LHS: let f71 = M.f Int in f71 + + (c) Do eta reduction. To see why, consider the fold/build rule, + which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... + This doesn't match unless you do eta reduction on the build argument. + Similarly for a LHS like + augment g (build h) + we do not want to get + augment (\a. g a) (build h) + otherwise we don't match when given an argument like + augment (\a. h a a) (build h) + +Note [Unused spec binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: a -> a + ... SPECIALISE f :: Eq a => a -> a ... +It's true that this *is* a more specialised type, but the rule +we get is something like this: + f_spec d = f + RULE: f = f_spec d +Note that the rule is bogus, because it mentions a 'd' that is +not bound on the LHS! But it's a silly specialisation anyway, because +the constraint is unused. We could bind 'd' to (error "unused") +but it seems better to reject the program because it's almost certainly +a mistake. That's what the isDeadBinder call detects. + +Note [No RULES on datacons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Previously, `RULES` like + + "JustNothing" forall x . Just x = Nothing + +were allowed. Simon Peyton Jones says this seems to have been a +mistake, that such rules have never been supported intentionally, +and that he doesn't know if they can break in horrible ways. +Furthermore, Ben Gamari and Reid Barton are considering trying to +detect the presence of "static data" that the simplifier doesn't +need to traverse at all. Such rules do not play well with that. +So for now, we ban them altogether as requested by #13290. See also #7398. + + +************************************************************************ +* * + Desugaring evidence +* * +************************************************************************ + +Note [Desugaring WpFun] +~~~~~~~~~~~~~~~~~~~~~~~ +See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means. +Roughly: + + (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ] + +This eta-expansion risk duplicating work, if `e` is not in HNF. +At one stage I thought we could avoid that by desugaring to + let f = e in \x. w_res[ f w_arg[x] ] +But that /fundamentally/ doesn't work, because `w_res` may bind +evidence that is used in `e`. + +This question arose when thinking about deep subsumption; see +https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649). +-} + +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 hs_wrap thing_inside + = ds_hs_wrapper hs_wrap $ \ core_wrap -> + addTyCs FromSource (hsWrapDictBinders hs_wrap) $ + -- addTyCs: Add type evidence to the refinement type + -- predicate of the coverage checker + -- See Note [Long-distance information] in "GHC.HsToCore.Pmc" + -- FromSource might not be accurate (we don't have any + -- origin annotations for things in this module), but at + -- worst we do superfluous calls to the pattern match + -- oracle. + thing_inside core_wrap + +ds_hs_wrapper :: HsWrapper + -> ((CoreExpr -> CoreExpr) -> DsM a) + -> DsM a +ds_hs_wrapper 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 (WpEvApp tm) k = do { core_tm <- dsEvTerm tm + ; k $ \e -> e `App` core_tm } + go (WpLet ev_binds) k = dsTcEvBinds ev_binds $ \bs -> + k (mkCoreLets bs) + go (WpCompose c1 c2) k = go c1 $ \w1 -> + 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 = mkCoreApp (text "dsHsWrapper") f a + arg = w1 (Var x) + in k (\e -> (Lam x (w2 (app e arg)))) } + +-------------------------------------- +dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a +dsTcEvBinds_s [] k = k [] +dsTcEvBinds_s (b:rest) k = assert (null rest) $ -- Zonker ensures null + dsTcEvBinds b k + +dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a +dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this +dsTcEvBinds (EvBinds bs) = dsEvBinds bs + +-- * Desugars the ev_binds, sorts them into dependency order, and +-- passes the resulting [CoreBind] to thing_inside +-- * Extends the DsM (dsl_unspecable field) with specialisability information +-- for each binder in ev_binds, before invoking thing_inside +dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a +dsEvBinds ev_binds thing_inside + = do { ds_binds <- mapBagM dsEvBind ev_binds + ; let comps = sort_ev_binds ds_binds + ; go comps thing_inside } + where + 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) } + go [] thing_inside = thing_inside [] + + ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables) + where + ((v, rhs), (this_canonical, deps)) = unpack_node node + new_unspecables = case mb_unspecables of + Nothing -> [] + Just unspecs | transitively_unspecable -> [v] + | otherwise -> [] + where + transitively_unspecable = is_unspecable this_canonical + || any (`elemVarSet` unspecs) deps + + ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables) + where + (pairs, direct_canonicity) = unzip $ map unpack_node nodes + + new_unspecables = case mb_unspecables of + Nothing -> [] + Just unspecs | transitively_unspecable -> map fst pairs + | otherwise -> [] + where + transitively_unspecable + = or [ is_unspecable this_canonical + || any (`elemVarSet` unspecs) deps + | (this_canonical, deps) <- direct_canonicity ] + -- Bindings from a given SCC are transitively specialisable if + -- all are specialisable and all their remote dependencies are + -- also specialisable; see Note [Desugaring non-canonical evidence] + + unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps } + = ((v, rhs), (canonical, deps)) + + 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 (CanonicalEvidence, CoreExpr) ] + edges = foldr ((:) . mk_node) [] ds_binds + + mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr) + mk_node (var, canonical, rhs) + = DigraphNode { node_payload = (canonical, rhs) + , node_key = var + , node_dependencies = nonDetEltsUniqSet $ + exprFreeVars rhs `unionVarSet` + coVarsOfType (varType var) } + -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq + -- 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, CanonicalEvidence, CoreExpr) +dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do + e <- dsEvTerm r + let canonical = case info of + EvBindGiven{} -> EvCanonical + EvBindWanted{ ebi_canonical = canonical } -> canonical + return (v, canonical, e) + + +{-********************************************************************** +* * + Desugaring EvTerms +* * +**********************************************************************-} + +dsEvTerm :: EvTerm -> DsM CoreExpr +dsEvTerm (EvExpr e) = return e +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvFun { et_tvs = tvs, et_given = given + , et_binds = ev_binds, et_body = wanted_id }) + = do { dsTcEvBinds ev_binds $ \ds_ev_binds -> + return $ (mkLams (tvs ++ given) $ + mkCoreLets ds_ev_binds $ + Var wanted_id) } + + +{-********************************************************************** +* * + Desugaring Typeable dictionaries +* * +**********************************************************************-} + +dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr +-- Return a CoreExpr :: Typeable ty +-- This code is tightly coupled to the representation +-- of TypeRep, in base library Data.Typeable.Internal +dsEvTypeable ty ev + = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable + ; let kind = typeKind ty + typeable_data_con = tyConSingleDataCon tyCl -- "Data constructor" + -- for Typeable + + ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a + + -- Package up the method as `Typeable` dictionary + ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } + +type TypeRepExpr = CoreExpr + +-- | Returns a @CoreExpr :: TypeRep ty@ +ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr +ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) + = do { mkTrCon <- dsLookupGlobalId mkTrConName + -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a + ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName + ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName + -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + + ; tc_rep <- tyConRep tc -- :: TyCon + ; let ks = tyConAppArgs ty + -- Construct a SomeTypeRep + toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr + toSomeTypeRep t ev = do + rep <- getRep ev t + return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] + ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t + ; let -- :: [SomeTypeRep] + kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps + + -- Note that we use the kind of the type, not the TyCon from which it + -- is constructed since the latter may be kind polymorphic whereas the + -- former we know is not (we checked in the solver). + ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr + ; return expr + } + +ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) + | 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) + ; let (_, k1, k2) = splitFunTy (typeKind t1) -- drop the multiplicity, + -- since it's a kind + ; let expr = mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ]) + [ e1, e2 ] + -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr ; return expr } diff --git a/GHC/HsToCore/Breakpoints.hs b/GHC/HsToCore/Breakpoints.hs --- a/GHC/HsToCore/Breakpoints.hs +++ b/GHC/HsToCore/Breakpoints.hs @@ -1,56 +1,108 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Information attached to Breakpoints generated from Ticks +-- +-- The breakpoint information stored in 'ModBreaks' is generated during +-- desugaring from the ticks annotating the source expressions. +-- +-- This information can be queried per-breakpoint using the 'BreakpointId' +-- datatype, which indexes tick-level breakpoint information. +-- +-- 'ModBreaks' and 'BreakpointId's are not to be confused with +-- 'InternalModBreaks' and 'InternalBreakId's. The latter are constructed +-- during bytecode generation and can be found in 'GHC.ByteCode.Breakpoints'. +-- +-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers] module GHC.HsToCore.Breakpoints - ( mkModBreaks + ( -- * ModBreaks + mkModBreaks, ModBreaks(..) + + -- ** Re-exports BreakpointId + , BreakpointId(..), BreakTickIndex ) where import GHC.Prelude - -import qualified GHC.Runtime.Interpreter as GHCi -import GHC.Runtime.Interpreter.Types -import GHCi.RemoteTypes -import GHC.ByteCode.Types -import GHC.Stack.CCS -import GHC.Unit +import Data.Array import GHC.HsToCore.Ticks (Tick (..)) - import GHC.Data.SizedSeq -import GHC.Utils.Outputable as Outputable - +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Types.Name (OccName) +import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) +import GHC.Unit.Module (Module) +import GHC.Utils.Outputable import Data.List (intersperse) -import Data.Array -mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks -mkModBreaks interp mod extendedMixEntries - = do - let count = fromIntegral $ sizeSS extendedMixEntries - entries = ssElts extendedMixEntries +-------------------------------------------------------------------------------- +-- ModBreaks +-------------------------------------------------------------------------------- - breakArray <- GHCi.newBreakArray interp count - ccs <- mkCCSArray interp mod count entries - mod_ptr <- GHCi.newModuleName interp (moduleName mod) - let - locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] - varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] - declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] - return $ emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - , modBreaks_module = mod_ptr - } +-- | All the information about the source-relevant breakpoints for a module +-- +-- This information is constructed once during desugaring (with `mkModBreaks`) +-- from breakpoint ticks and fixed/unchanged from there on forward. It could be +-- exported as an abstract datatype because it should never be updated after +-- construction, only queried. +-- +-- The arrays can be indexed using the int in the corresponding 'BreakpointId' +-- (i.e. the 'BreakpointId' whose 'Module' matches the 'Module' corresponding +-- to these 'ModBreaks') with the accessors 'modBreaks_locs', 'modBreaks_vars', +-- and 'modBreaks_decls'. +data ModBreaks + = ModBreaks + { modBreaks_locs :: !(Array BreakTickIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakTickIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakTickIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + -- See Note [Field modBreaks_decls] + , modBreaks_ccs :: !(Array BreakTickIndex (String, String)) + -- ^ Array pointing to cost centre info for each breakpoint; + -- actual 'CostCentre' allocation is done at link-time. + , modBreaks_module :: !Module + -- ^ The module to which this ModBreaks is associated. + -- We also cache this here for internal sanity checks. + } -mkCCSArray - :: Interp -> Module -> Int -> [Tick] - -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre)) -mkCCSArray interp modul count entries - | GHCi.interpreterProfiled interp = do - let module_str = moduleNameString (moduleName modul) - costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries) - return (listArray (0,count-1) costcentres) - | otherwise = return (listArray (0,-1) []) - where - mk_one t = (name, src) - where name = concat $ intersperse "." $ tick_path t - src = renderWithContext defaultSDocContext $ ppr $ tick_loc t +-- | Initialize memory for breakpoint data that is shared between the bytecode +-- generator and the interpreter. +-- +-- Since GHCi and the RTS need to interact with breakpoint data and the bytecode +-- generator needs to encode this information for each expression, the data is +-- allocated remotely in GHCi's address space and passed to the codegen as +-- foreign pointers. +mkModBreaks :: Bool {-^ Whether the interpreter is profiled and thus if we should include store a CCS array -} + -> Module -> SizedSeq Tick -> ModBreaks +mkModBreaks interpreterProfiled modl extendedMixEntries + = let count = fromIntegral $ sizeSS extendedMixEntries + entries = ssElts extendedMixEntries + locsTicks = listArray (0,count-1) [ tick_loc t | t <- entries ] + varsTicks = listArray (0,count-1) [ tick_ids t | t <- entries ] + declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ] + ccs + | interpreterProfiled = + listArray + (0, count - 1) + [ ( concat $ intersperse "." $ tick_path t, + renderWithContext defaultSDocContext $ ppr $ tick_loc t + ) + | t <- entries + ] + | otherwise = listArray (0, -1) [] + in ModBreaks + { modBreaks_locs = locsTicks + , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks + , modBreaks_ccs = ccs + , modBreaks_module = modl + } + +{- +Note [Field modBreaks_decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A value of eg ["foo", "bar", "baz"] in a `modBreaks_decls` field means: +The breakpoint is in the function called "baz" that is declared in a `let` +or `where` clause of a declaration called "bar", which itself is declared +in a `let` or `where` clause of the top-level function called "foo". +-} diff --git a/GHC/HsToCore/Coverage.hs b/GHC/HsToCore/Coverage.hs --- a/GHC/HsToCore/Coverage.hs +++ b/GHC/HsToCore/Coverage.hs @@ -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, diff --git a/GHC/HsToCore/Docs.hs b/GHC/HsToCore/Docs.hs --- a/GHC/HsToCore/Docs.hs +++ b/GHC/HsToCore/Docs.hs @@ -1,17 +1,12 @@ -- | Extract docs from the renamer output so they can be serialized. {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} 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,12 +30,11 @@ import qualified Data.Map as M import qualified Data.Set as Set import Data.Maybe -import Data.Semigroup +import qualified Data.Semigroup as S import GHC.IORef (readIORef) import GHC.Unit.Types import GHC.Hs 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 @@ -48,6 +42,8 @@ import GHC.Types.TypeEnv import GHC.Types.Id import GHC.Types.Unique.Map +import GHC.Utils.Outputable +import GHC.Utils.Panic -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from @@ -68,16 +64,17 @@ , tcg_imports = import_avails , tcg_insts = insts , tcg_fam_insts = fam_insts - , tcg_doc_hdr = mb_doc_hdr + , tcg_hdr_info = mb_hdr_info , tcg_th_docs = th_docs_var , tcg_type_env = ty_env } = do th_docs <- liftIO $ readIORef th_docs_var - let doc_hdr = (unLoc <$> mb_doc_hdr) + let doc_hdr = unLoc <$> fst mb_hdr_info ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs mod_docs = Docs { docs_mod_hdr = th_hdr <|> doc_hdr + , docs_exports = exports_docs -- Left biased union (see #21220) , docs_decls = plusUniqMap_C (\a _ -> a) ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs) @@ -105,6 +102,7 @@ , isDefaultMethodOcc occ ] + exports_docs = maybe emptyUniqMap mkExportsDocs mb_rn_exports (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs decls_with_docs = topDecls rn_decls local_insts = filter (nameIsLocalOrFrom semantic_mdl) @@ -114,6 +112,25 @@ named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls extractDocs _ _ = pure Nothing +mkExportsDocs :: [(LIE GhcRn, Avails)] -> UniqMap Name (HsDoc GhcRn) +mkExportsDocs = foldMap f + where + f :: (LIE GhcRn, Avails) -> UniqMap Name (HsDoc GhcRn) + f (L _ ie, avails) + | Just (L _ doc) <- ieExportDoc ie = + listToUniqMap [ (availName nm, doc) | nm <- avails ] + f _ = emptyUniqMap + + ieExportDoc :: IE GhcRn -> Maybe (ExportDoc GhcRn) + ieExportDoc (IEVar _ _ doc) = doc + ieExportDoc (IEThingAbs _ _ doc) = doc + ieExportDoc (IEThingAll _ _ doc) = doc + ieExportDoc (IEThingWith _ _ _ _ doc) = doc + ieExportDoc (IEModuleContents _ _) = Nothing + ieExportDoc (IEGroup _ _ _) = Nothing + ieExportDoc (IEDoc _ _) = Nothing + ieExportDoc (IEDocNamed _ _) = Nothing + -- | If we have an explicit export list, we extract the documentation structure -- from that. -- Otherwise we use the renamed exports and declarations. @@ -132,7 +149,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 @@ -147,13 +163,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: " @@ -167,15 +187,14 @@ -- Map from aliases to true module names. aliasMap :: Map ModuleName (NonEmpty ModuleName) aliasMap = - M.fromListWith (<>) $ + M.fromListWith (S.<>) $ (this_mdl_name, this_mdl_name :| []) - : (flip concatMap (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. @@ -189,10 +208,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: @@ -241,7 +260,7 @@ -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn))) mkMaps env instances decls = ( listsToMapWith (++) (map (nubByName fst) decls') - , listsToMapWith (<>) (filterMapping (not . IM.null) args) + , listsToMapWith (S.<>) (filterMapping (not . IM.null) args) ) where (decls', args) = unzip (map mappings decls) @@ -255,7 +274,7 @@ -> ( [(Name, [HsDoc GhcRn])] , [(Name, IntMap (HsDoc GhcRn))] ) - mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) = + mappings (L (EpAnn (EpaSpan (RealSrcSpan l _)) _ _) decl, doc) = (dm, am) where args = declTypeDocs decl @@ -269,7 +288,7 @@ ns = names l decl dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d] am = [(n, args) | n <- ns] ++ zip subNs subArgs - mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) + mappings (L (EpAnn _ _ _) _, _) = ([], []) instanceMap :: Map RealSrcSpan Name instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ] @@ -361,8 +380,8 @@ InstD _ (DataFamInstD _ (DataFamInstDecl d)) -> dataSubs (feqn_rhs d) - TyClD _ d | isClassDecl d -> classSubs d - | isDataDecl d -> dataSubs (tcdDataDefn d) + TyClD _ d | ClassDecl{} <- d -> classSubs d + | DataDecl{} <- d -> dataSubs (tcdDataDefn d) _ -> [] where classSubs dd = [ (name, doc, declTypeDocs d) @@ -378,9 +397,9 @@ , 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 _ (HsConDeclRecField _ ns (CDF { cdf_doc = doc }))) <- (unLoc flds) , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], IM.empty) | (l, doc) <- concatMap (extract_deriv_clause_tys . @@ -411,21 +430,23 @@ h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of - PrefixCon _ args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args - InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1) - , unLoc (hsScaledThing arg2) ] + PrefixCon args -> con_arg_docs 0 $ map cdf_doc args + InfixCon arg1 arg2 -> con_arg_docs 0 [ cdf_doc arg1, cdf_doc arg2 ] RecCon _ -> IM.empty gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of - PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] - RecConGADT _ _ -> con_arg_docs 1 [res_ty] + PrefixConGADT _ args -> con_arg_docs 0 $ map cdf_doc args ++ [res_doc] + RecConGADT _ _ -> con_arg_docs 1 [res_doc] + where + res_doc = case res_ty of + HsDocTy _ _ lds -> Just lds + _ -> Nothing -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn) +con_arg_docs :: Int -> [Maybe (LHsDoc GhcRn)] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..] where - f n (HsDocTy _ _ lds) = Just (n, unLoc lds) - f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds) + f n (Just lds) = Just (n, unLoc lds) f _ _ = Nothing isValD :: HsDecl a -> Bool @@ -434,15 +455,21 @@ -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] -classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls - where - decls = docs ++ defs ++ sigs ++ ats - docs = mkDecls tcdDocs (DocD noExtField) class_ - defs = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_ - sigs = mkDecls tcdSigs (SigD noExtField) class_ - ats = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_ +classDecls :: TyClDecl GhcRn -- Always a ClassDecl + -> [(LHsDecl GhcRn, [HsDoc GhcRn])] +classDecls decl + | ClassDecl { .. } <- decl + , let decls = docs ++ defs ++ sigs ++ ats + docs = mkDecls (DocD noExtField) tcdDocs + defs = mkDecls (ValD noExtField) tcdMeths + sigs = mkDecls (SigD noExtField) tcdSigs + ats = mkDecls (TyClD noExtField . FamDecl noExtField) tcdATs + = filterDecls . collectDocs . sortLocatedA $ decls + + | otherwise + = pprPanic "classDecls" (ppr decl) + -- | Extract function argument docs from inside top-level decls. declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case @@ -487,15 +514,15 @@ -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] -ungroup group_ = - mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField) group_ ++ - mkDecls hs_derivds (DerivD noExtField) group_ ++ - mkDecls hs_defds (DefD noExtField) group_ ++ - mkDecls hs_fords (ForD noExtField) group_ ++ - mkDecls hs_docs (DocD noExtField) group_ ++ - mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField) group_ ++ - mkDecls (typesigs . hs_valds) (SigD noExtField) group_ ++ - mkDecls (valbinds . hs_valds) (ValD noExtField) group_ +ungroup (HsGroup {..}) = + mkDecls (TyClD noExtField) (tyClGroupTyClDecls hs_tyclds) ++ + mkDecls (DerivD noExtField) hs_derivds ++ + mkDecls (DefD noExtField) hs_defds ++ + mkDecls (ForD noExtField) hs_fords ++ + mkDecls (DocD noExtField) hs_docs ++ + mkDecls (InstD noExtField) (tyClGroupInstDecls hs_tyclds) ++ + mkDecls (SigD noExtField) (typesigs hs_valds) ++ + mkDecls (ValD noExtField) (valbinds hs_valds) where typesigs :: HsValBinds GhcRn -> [LSig GhcRn] typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig @@ -503,7 +530,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. @@ -557,11 +584,10 @@ -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor -mkDecls :: (struct -> [GenLocated l decl]) - -> (decl -> hsDecl) - -> struct +mkDecls :: (decl -> hsDecl) + -> [GenLocated l decl] -> [GenLocated l hsDecl] -mkDecls field con = map (fmap con) . field +mkDecls con = map (fmap con) -- | Extracts out individual maps of documentation added via Template Haskell's -- @putDoc@. diff --git a/GHC/HsToCore/Errors/Ppr.hs b/GHC/HsToCore/Errors/Ppr.hs --- a/GHC/HsToCore/Errors/Ppr.hs +++ b/GHC/HsToCore/Errors/Ppr.hs @@ -7,7 +7,7 @@ module GHC.HsToCore.Errors.Ppr where -import GHC.Core.Predicate (isEvVar) +import GHC.Core.Predicate (isEvId) import GHC.Core.Type import GHC.Driver.Flags import GHC.Hs @@ -15,7 +15,7 @@ import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error -import GHC.Types.Error.Codes ( constructorCode ) +import GHC.Types.Error.Codes import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc @@ -27,7 +27,7 @@ instance Diagnostic DsMessage where type DiagnosticOpts DsMessage = NoDiagnosticOpts diagnosticMessage opts = \case - DsUnknownMessage (UnknownDiagnostic f m) + DsUnknownMessage (UnknownDiagnostic f _ m) -> diagnosticMessage (f opts) m DsEmptyEnumeration -> mkSimpleDecorated $ text "Enumeration is empty" @@ -83,14 +83,46 @@ StrictBinds -> "strict bindings" in mkSimpleDecorated $ hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind) - DsUselessSpecialiseForClassMethodSelector poly_id - -> mkSimpleDecorated $ - text "Ignoring useless SPECIALISE pragma for class selector:" <+> quotes (ppr poly_id) - DsUselessSpecialiseForNoInlineFunction poly_id - -> mkSimpleDecorated $ - text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id) - DsMultiplicityCoercionsNotSupported - -> mkSimpleDecorated $ text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities" + DsUselessSpecialisePragma poly_nm is_dfun rea -> + mkSimpleDecorated $ + vcat [ what <+> pragma <+> text "pragma" <> why + , additional ] + where + quoted_nm = quotes (ppr poly_nm) + what + | uselessSpecialisePragmaKeepAnyway rea + = text "Dubious" + | otherwise + = text "Ignoring useless" + pragma = if is_dfun + then text "SPECIALISE instance" + else text "SPECIALISE" + why = case rea of + UselessSpecialiseForClassMethodSelector -> + text " for class selector:" <+> quoted_nm + UselessSpecialiseForNoInlineFunction -> + text " for NOINLINE function:" <+> quoted_nm + UselessSpecialiseNoSpecialisation -> + -- Omit the Name for a DFunId, as it will be internal and not + -- very illuminating to users who don't know what a DFunId is. + (if is_dfun then empty else text " for" <+> quoted_nm) <> dot + + additional + | uselessSpecialisePragmaKeepAnyway rea + = -- No specialisation happening, but the pragma may still be useful. + -- For example (#25389): + -- + -- data G a where { G1 :: G Int, G2 :: G Bool } + -- f :: G a -> a + -- f G1 = ; f G2 = + -- {-# SPECIALISE f :: G Int -> Int #-} + -- -- In $sf, we get rid of dead code in + vcat + [ text "The pragma does not specialise away any class dictionaries," + , text "and neither is there any value specialisation." + ] + | otherwise + = empty DsOrphanRule rule -> mkSimpleDecorated $ text "Orphan rule:" <+> ppr rule DsRuleLhsTooComplicated orig_lhs lhs2 @@ -111,11 +143,11 @@ , text "is not bound in RULE lhs"]) 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs , text "Orig lhs:" <+> ppr orig_lhs - , text "optimised lhs:" <+> ppr lhs2 ]) + , text "Optimised lhs:" <+> ppr lhs2 ]) pp_bndr b | isTyVar b = text "type variable" <+> quotes (ppr b) - | isEvVar b = text "constraint" <+> quotes (ppr (varType b)) + | isEvId b = text "constraint" <+> quotes (ppr (varType b)) | otherwise = text "variable" <+> quotes (ppr b) DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs -> mkSimpleDecorated $ @@ -167,6 +199,8 @@ -> mkMsg "Splices within declaration brackets" empty ThNonLinearDataCon -> mkMsg "Non-linear fields in data constructors" empty + ThDataConVisibleForall + -> mkMsg "Visible forall in data constructors" empty where mkMsg what doc = mkSimpleDecorated $ @@ -207,6 +241,12 @@ <+> text "for"<+> quotes (ppr lhs_id) <+> text "might fire first") ] + DsIncompleteRecordSelector name cons maxCons -> mkSimpleDecorated $ + hang (text "Selecting the record field" <+> quotes (ppr name) + <+> text "may fail for the following constructors:") + 2 + (hsep $ punctuate comma $ + map ppr (take maxCons cons) ++ [ text "..." | lengthExceeds cons maxCons ]) diagnosticReason = \case DsUnknownMessage m -> diagnosticReason m @@ -220,9 +260,7 @@ DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _ -> maybe WarningWithoutFlag WarningWithFlag mb_flag DsTopLevelBindsNotAllowed{} -> ErrorWithoutFlag - DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag - DsUselessSpecialiseForNoInlineFunction{} -> WarningWithoutFlag - DsMultiplicityCoercionsNotSupported{} -> ErrorWithoutFlag + DsUselessSpecialisePragma{} -> WarningWithFlag Opt_WarnUselessSpecialisations DsOrphanRule{} -> WarningWithFlag Opt_WarnOrphans DsRuleLhsTooComplicated{} -> WarningWithoutFlag DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag @@ -237,6 +275,7 @@ DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing + DsIncompleteRecordSelector{} -> WarningWithFlag Opt_WarnIncompleteRecordSelectors diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m @@ -256,9 +295,7 @@ DsMaxPmCheckModelsReached{} -> [SuggestIncreaseMaxPmCheckModels] DsNonExhaustivePatterns{} -> noHints DsTopLevelBindsNotAllowed{} -> noHints - DsUselessSpecialiseForClassMethodSelector{} -> noHints - DsUselessSpecialiseForNoInlineFunction{} -> noHints - DsMultiplicityCoercionsNotSupported -> noHints + DsUselessSpecialisePragma{} -> noHints DsOrphanRule{} -> noHints DsRuleLhsTooComplicated{} -> noHints DsRuleIgnoredDueToConstructor{} -> noHints @@ -273,8 +310,9 @@ DsRecBindsNotAllowedForUnliftedTys{} -> noHints DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] + DsIncompleteRecordSelector{} -> noHints - diagnosticCode = constructorCode + diagnosticCode = constructorCode @GHC {- Note [Suggest NegativeLiterals] @@ -298,11 +336,11 @@ 2 (quotes (ppr elt_ty)) -- Print a single clause (for redundant/with-inaccessible-rhs) -pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc +pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc pprEqn ctx q txt = pprContext True ctx (text txt) $ \f -> f (q <+> matchSeparator ctx <+> text "...") -pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc +pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pprContext singular kind msg rest_of_msg_fun = vcat [text txt <+> msg, sep [ text "In" <+> ppr_match <> char ':' diff --git a/GHC/HsToCore/Errors/Types.hs b/GHC/HsToCore/Errors/Types.hs --- a/GHC/HsToCore/Errors/Types.hs +++ b/GHC/HsToCore/Errors/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} module GHC.HsToCore.Errors.Types where @@ -8,6 +9,7 @@ import GHC.Core (CoreRule, CoreExpr, RuleName) import GHC.Core.DataCon +import GHC.Core.ConLike import GHC.Core.Type import GHC.Driver.DynFlags (DynFlags, xopt) import GHC.Driver.Flags (WarningFlag) @@ -30,7 +32,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage -- | Simply wraps a generic 'Diagnostic' message. - = DsUnknownMessage (UnknownDiagnostic (DiagnosticOpts DsMessage)) + = DsUnknownMessage (UnknownDiagnosticFor DsMessage) {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is emitted if an enumeration is empty. @@ -85,18 +87,18 @@ -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately -- 'SrcInfo' gives us an 'SDoc' to begin with. - | DsRedundantBangPatterns !(HsMatchContext GhcTc) !SDoc + | DsRedundantBangPatterns !HsMatchContextRn !SDoc -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately -- 'SrcInfo' gives us an 'SDoc' to begin with. - | DsOverlappingPatterns !(HsMatchContext GhcTc) !SDoc + | DsOverlappingPatterns !HsMatchContextRn !SDoc -- FIXME(adn) Use a proper type instead of 'SDoc' - | DsInaccessibleRhs !(HsMatchContext GhcTc) !SDoc + | DsInaccessibleRhs !HsMatchContextRn !SDoc | DsMaxPmCheckModelsReached !MaxPmCheckModels - | DsNonExhaustivePatterns !(HsMatchContext GhcTc) + | DsNonExhaustivePatterns !HsMatchContextRn !ExhaustivityCheckType !MaxUncoveredPatterns [Id] @@ -104,11 +106,18 @@ | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc) - | DsUselessSpecialiseForClassMethodSelector !Id + {-| DsUselessSpecialisePragma is a warning (controlled by the -Wuseless-specialisations flag) + that is emitted for SPECIALISE pragmas that (most likely) don't do anything. - | DsUselessSpecialiseForNoInlineFunction !Id + Examples: - | DsMultiplicityCoercionsNotSupported + foo :: forall a. a -> a + {-# SPECIALISE foo :: Int -> Int #-} + -} + | DsUselessSpecialisePragma + !Name + !Bool -- ^ is this a @SPECIALISE instance@ pragma? + !UselessSpecialisePragmaReason | DsOrphanRule !CoreRule @@ -147,6 +156,25 @@ !RuleName -- the \"bad\" rule !Var + {-| DsIncompleteRecordSelector is a warning triggered when we are not certain whether + a record selector application will be successful. Currently, this means that + the warning is triggered when there is a record selector of a data type that + does not have that field in all its constructors. + + Example(s): + data T = T1 | T2 {x :: Bool} + f :: T -> Bool + f a = x a + + Test cases: + DsIncompleteRecSel1 + DsIncompleteRecSel2 + DsIncompleteRecSel3 + -} + | DsIncompleteRecordSelector !Name -- ^ The selector + ![ConLike] -- ^ The partial constructors + !Int -- ^ The max number of constructors reported + deriving Generic -- The positional number of the argument for an expression (first, second, third, etc) @@ -176,6 +204,26 @@ | ThWarningAndDeprecationPragmas [LIdP GhcRn] | ThSplicesWithinDeclBrackets | ThNonLinearDataCon + | ThDataConVisibleForall + +-- | Why is a @SPECIALISE@ pragmas useless? +data UselessSpecialisePragmaReason + -- | Useless @SPECIALISE@ pragma for a class method + = UselessSpecialiseForClassMethodSelector + -- | Useless @SPECIALISE@ pragma for a function with NOINLINE + | UselessSpecialiseForNoInlineFunction + -- | Useless @SPECIALISE@ pragma which generates a specialised function + -- which is identical to the original function at runtime. + | UselessSpecialiseNoSpecialisation + deriving Generic + +uselessSpecialisePragmaKeepAnyway :: UselessSpecialisePragmaReason -> Bool +uselessSpecialisePragmaKeepAnyway = \case + UselessSpecialiseForClassMethodSelector -> False + UselessSpecialiseForNoInlineFunction -> False + UselessSpecialiseNoSpecialisation -> True + -- See #25389/T25389 for why we might want to keep this specialisation + -- around even if it seemingly does nothing. data NegLiteralExtEnabled = YesUsingNegLiterals diff --git a/GHC/HsToCore/Expr.hs b/GHC/HsToCore/Expr.hs --- a/GHC/HsToCore/Expr.hs +++ b/GHC/HsToCore/Expr.hs @@ -1,8 +1,9 @@ - {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} {- (c) The University of Glasgow 2006 @@ -29,43 +30,52 @@ import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc +import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Errors.Types -import GHC.Types.SourceText -import GHC.Types.Name -import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.HsToCore.Ticks (stripTicksTopHsExpr) import GHC.Hs + -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad +import GHC.Tc.Instance.Class (lookupHasFieldLabel) + +import GHC.Core +import GHC.Core.FVs( exprsFreeVarsList ) +import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.Core.Type import GHC.Core.TyCo.Rep -import GHC.Core import GHC.Core.Utils import GHC.Core.Make +import GHC.Core.PatSyn import GHC.Driver.Session + +import GHC.Types.SourceText +import GHC.Types.Name hiding (varName) import GHC.Types.CostCentre import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Id.Make +import GHC.Types.Var( isInvisibleAnonPiTyBinder ) +import GHC.Types.Var.Set( isEmptyVarSet, elemVarSet ) +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Tickish + import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Builtin.Types import GHC.Builtin.Names -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Tickish + import GHC.Utils.Misc -import GHC.Data.Bag import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Core.PatSyn import Control.Monad {- @@ -86,7 +96,8 @@ -- caller sets location dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr dsValBinds (XValBindsLR (NValBinds binds _)) body - = foldrM ds_val_bind body binds + = do { dflags <- getDynFlags + ; foldrM (ds_val_bind dflags) body binds } dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn" ------------------------- @@ -99,19 +110,22 @@ ; foldrM ds_ip_bind inner ip_binds } } where ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr + -- Given (IPBind n s e), we have + -- n :: IP s ty, e :: ty + -- Use evWrapIP to convert `e` (the user-written RHS) to an IP dictionary ds_ip_bind (L _ (IPBind n _ e)) body = do e' <- dsLExpr e - return (Let (NonRec n e') body) + return (Let (NonRec n (evWrapIPE (idType n) e')) body) ------------------------- -- caller sets location -ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr +ds_val_bind :: DynFlags -> (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. -- Silently ignore INLINE and SPECIALISE pragmas... -ds_val_bind (NonRecursive, hsbinds) body - | [L loc bind] <- bagToList hsbinds +ds_val_bind _ (NonRecursive, hsbinds) body + | [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 @@ -144,14 +158,40 @@ is_polymorphic _ = False -ds_val_bind (is_rec, binds) _body - | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds +ds_val_bind _ (is_rec, binds) _body + | 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 +-- linear, but selectors as used in the general case aren't. So the general case +-- would transform a linear definition into a non-linear one. See Wrinkle 2 +-- 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))})] <- hsbinds + -- Non-recursive, non-overloaded bindings only come in ones + , pat' <- decideBangHood dflags pat + , isBangedLPat pat' + = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss + ; rhs_expr <- dsGuarded grhss ty rhss_nablas + ; let rhs' = mkOptTickBox rhs_tick rhs_expr + ; let body_ty = exprType body + ; let mult = getTcMultAnn mult_ann + ; error_expr <- mkErrorAppDs pAT_ERROR_ID body_ty (ppr pat') + ; matchSimply rhs' PatBindRhs mult pat' body error_expr } + -- This is the one place where matchSimply is given a non-ManyTy + -- multiplicity argument. + -- + -- In this form, there isn't a natural place for the var_ticks. In + -- mkSelectorBinds, the ticks are around the selector function but there + -- aren't any selection functions as we make a single pattern-match. Is this a + -- problem? + -- Ordinary case for bindings; none should be unlifted -ds_val_bind (is_rec, binds) body - = do { massert (isRec is_rec || isSingletonBag binds) +ds_val_bind _ (is_rec, binds) body + = do { massert (isRec is_rec || isSingleton binds) -- we should never produce a non-recursive list of multiple binds ; (force_vars,prs) <- dsLHsBinds binds @@ -160,18 +200,23 @@ -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType case prs of [] -> return body - _ -> return (Let (Rec prs) body') } - -- Use a Rec regardless of is_rec. - -- Why? Because it allows the binds to be all - -- mixed up, which is what happens in one rare case - -- Namely, for an AbsBind with no tyvars and no dicts, - -- but which does have dictionary bindings. - -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS] - -- It turned out that wrapping a Rec here was the easiest solution - -- - -- NB The previous case dealt with unlifted bindings, so we - -- only have to deal with lifted ones now; so Rec is ok + _ -> return (mkLets (mk_binds is_rec prs) body') } + -- We can make a non-recursive let because we make sure to return + -- the bindings in dependency order in dsLHsBinds, + -- see Note [Return non-recursive bindings in dependency order] in + -- GHC.HsToCore.Binds +-- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for +-- instance. +-- +-- * @'mk_binds' 'Recursive' binds@ makes a single mutually-recursive +-- bindings with all the rhs/lhs pairs in @binds@ +-- * @'mk_binds' 'NonRecursive' binds@ makes one non-recursive binding +-- for each rhs/lhs pairs in @binds@ +mk_binds :: RecFlag -> [(b, (Expr b))] -> [Bind b] +mk_binds Recursive binds = [Rec binds] +mk_binds NonRecursive binds = map (uncurry NonRec) binds + ------------------ dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = [] @@ -191,10 +236,10 @@ }) 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) + ; dsHsWrapper co_fn $ \core_wrap -> -- Can be non-identity (#21516) + do { let rhs' = core_wrap (mkOptTickBox tick rhs) ; return (bindNonRec fun rhs' body) } } dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss @@ -203,11 +248,8 @@ -- ==> case rhs of C x# y# -> body do { match_nablas <- pmcGRHSs PatBindGuards grhss ; rhs <- dsGuarded grhss ty match_nablas - ; let upat = unLoc pat - eqn = EqnInfo { eqn_pats = [upat], - eqn_orig = FromSource, - eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar ManyTy upat + ; let eqn = EqnMatch { eqn_pat = pat, eqn_rest = EqnDone (cantFailMatchResult body) } + ; var <- selectMatchVar ManyTy (unLoc pat) -- `var` will end up in a let binder, so the multiplicity -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) @@ -229,22 +271,20 @@ -- | Desugar a typechecked expression. dsExpr :: HsExpr GhcTc -> DsM CoreExpr -dsExpr (HsVar _ (L _ id)) = dsHsVar id -dsExpr (HsRecSel _ (FieldOcc id _)) = dsHsVar id -dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref - -- See Note [Holes] in GHC.Tc.Types.Constraint -dsExpr (HsPar _ _ e _) = dsLExpr e -dsExpr (ExprWithTySig _ e _) = dsLExpr e +dsExpr e@(HsVar {}) = dsApp e +dsExpr e@(HsApp {}) = dsApp e +dsExpr e@(HsAppType {}) = dsApp e -dsExpr (HsIPVar x _) = dataConCantHappen x +dsExpr (HsHole (_, (HER ref _ _))) = dsEvTerm =<< readMutVar ref + -- See Note [Holes in expressions] in GHC.Tc.Types.Constraint. -dsExpr (HsGetField x _ _) = dataConCantHappen x -dsExpr (HsProjection x _) = dataConCantHappen x +dsExpr (HsPar _ e) = dsLExpr e +dsExpr (ExprWithTySig _ e _) = dsLExpr e dsExpr (HsLit _ lit) = do { warnAboutOverflowedLit lit - ; dsLit (convertLit lit) } + ; dsLit lit } dsExpr (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit @@ -252,9 +292,14 @@ dsExpr e@(XExpr ext_expr_tc) = case ext_expr_tc of - ExpansionExpr (HsExpanded _ b) -> dsExpr b - WrapExpr {} -> dsHsWrapped e - ConLikeTc con tvs tys -> dsConLike con tvs tys + HsRecSelTc {} -> dsApp e + WrapExpr {} -> dsApp e + ConLikeTc {} -> dsApp e + + ExpandedThingTc o e + | OrigStmt (L loc _) <- o + -> putSrcSpanDsA loc $ dsExpr e + | otherwise -> dsExpr e -- Hpc Support HsTick tickish e -> do e' <- dsLExpr e @@ -273,6 +318,8 @@ mkBinaryTickBox ixT ixF e2 } + + -- Strip ticks due to #21701, need to be invariant about warnings we produce whether -- this is enabled or not. dsExpr (NegApp _ (L loc @@ -283,26 +330,16 @@ -- See Note [Checking "negative literals"] (lit { ol_val = HsIntegral (negateIntegralLit i) }) ; dsOverLit lit } - ; ; dsSyntaxExpr neg_expr [mkTicks ts expr'] } dsExpr (NegApp _ expr neg_expr) = do { expr' <- dsLExpr expr ; dsSyntaxExpr neg_expr [expr'] } -dsExpr (HsLam _ a_Match) - = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match +dsExpr (HsLam _ variant a_Match) + = uncurry mkCoreLams <$> matchWrapper (LamAlt variant) Nothing a_Match -dsExpr (HsLamCase _ lc_variant matches) - = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches -dsExpr e@(HsApp _ fun arg) - = do { fun' <- dsLExpr fun - ; arg' <- dsLExpr arg - ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' } - -dsExpr e@(HsAppType {}) = dsHsWrapped e - {- Note [Checking "negative literals"] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -343,10 +380,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 @@ -362,8 +399,17 @@ dsExpr (ExplicitSum types alt arity expr) = mkCoreUnboxedSum arity alt types <$> dsLExpr expr -dsExpr (HsPragE _ prag expr) = - ds_prag_expr prag expr +dsExpr (HsPragE _ (HsPragSCC _ cc) expr) + = do { dflags <- getDynFlags + ; if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags + then do + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + let nm = sl_fs cc + flavour <- mkExprCCFlavour <$> getCCIndexDsM nm + Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True) + <$> dsLExpr expr + else dsLExpr expr } dsExpr (HsCase ctxt discrim matches) = do { core_discrim <- dsLExpr discrim @@ -372,18 +418,18 @@ -- Pepe: The binds are in scope in the body but NOT in the binding group -- This is to avoid silliness in breakpoints -dsExpr (HsLet _ _ binds _ body) = do +dsExpr (HsLet _ binds body) = do body' <- dsLExpr body dsLocalBinds binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty -dsExpr (HsDo _ 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 _ MonadComp (L _ stmts)) = dsMonadComp stmts +dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty +dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts +dsExpr (HsDo res_ty ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty +dsExpr (HsDo res_ty ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts res_ty +dsExpr (HsDo res_ty ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts res_ty dsExpr (HsIf _ guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -392,10 +438,6 @@ ; return $ mkIfThenElse pred b1 b2 } dsExpr (HsMultiIf res_ty alts) - | null alts - = mkErrorExpr - - | otherwise = do { let grhss = GRHSs emptyComments alts emptyLocalBinds ; rhss_nablas <- pmcGRHSs IfAlt grhss ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas @@ -405,12 +447,6 @@ mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty (text "multi-way if") -{- -\noindent -\underline{\bf Various data construction things} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --} - dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs dsExpr (ArithSeq expr witness seq) @@ -419,42 +455,35 @@ Just fl -> do { newArithSeq <- dsArithSeq expr seq ; dsSyntaxExpr fl [newArithSeq] } -{- -Static Pointers -~~~~~~~~~~~~~~~ - -See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. - +{- Note [Desugaring static pointers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable +for an overview. g = ... static f ... ==> g = ... makeStatic loc f ... -} -dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do - expr_ds <- dsLExpr expr - let (_, [ty]) = splitTyConApp whole_ty - makeStaticId <- dsLookupGlobalId makeStaticName +dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) + = do { expr_ds <- dsLExpr expr + ; let (_, [ty]) = splitTyConApp whole_ty + ; makeStaticId <- dsLookupGlobalId makeStaticName - dflags <- getDynFlags - let platform = targetPlatform dflags - let (line, col) = case locA loc of - RealSrcSpan r _ -> - ( srcLocLine $ realSrcSpanStart r - , srcLocCol $ realSrcSpanStart r - ) - _ -> (0, 0) - srcLoc = mkCoreConApps (tupleDataCon Boxed 2) - [ Type intTy , Type intTy - , mkIntExprInt platform line, mkIntExprInt platform col - ] + ; dflags <- getDynFlags + ; let platform = targetPlatform dflags + (line, col) = case locA loc of + RealSrcSpan r _ -> ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r ) + _ -> (0, 0) + srcLoc = mkCoreTup [ mkIntExprInt platform line + , mkIntExprInt platform col + ] - putSrcSpanDsA loc $ return $ - mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] + ; putSrcSpanDsA loc $ return $ + mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ] } -{- -\noindent -\underline{\bf Record construction and update} - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Desugaring record construction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) \begin{verbatim} T { op2 = e } @@ -477,6 +506,7 @@ dsExpr (RecordCon { rcon_con = L _ con_like , rcon_flds = rbinds , rcon_ext = con_expr }) +-- See Note [Desugaring record construction] = do { con_expr' <- dsExpr con_expr ; let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -494,11 +524,10 @@ ; con_args <- if null labels then mapM unlabelled_bottom (map scaledThing arg_tys) - else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels) + else mapM mk_arg (zipEqual (map scaledThing arg_tys) labels) ; return (mkCoreApps con_expr' con_args) } -dsExpr (RecordUpd x _ _) = dataConCantHappen x -- Here is where we desugar the Template Haskell brackets and escapes @@ -513,39 +542,368 @@ -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd - -- HsSyn constructs that just shouldn't be here, because --- the renamer removed them. See GHC.Rename.Expr. +-- the renamer or typechecker removed them. See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs] -dsExpr (HsOverLabel x _ _) = dataConCantHappen x -dsExpr (OpApp x _ _ _) = dataConCantHappen x -dsExpr (SectionL x _ _) = dataConCantHappen x -dsExpr (SectionR x _ _) = dataConCantHappen x +dsExpr (HsIPVar x _) = dataConCantHappen x +dsExpr (HsGetField x _ _) = dataConCantHappen x +dsExpr (HsProjection x _) = dataConCantHappen x +dsExpr (RecordUpd x _ _) = dataConCantHappen x +dsExpr (HsEmbTy x _) = dataConCantHappen x +dsExpr (HsQual x _ _) = dataConCantHappen x +dsExpr (HsForAll x _ _) = dataConCantHappen x +dsExpr (HsFunArr x _ _ _) = dataConCantHappen x +dsExpr (HsOverLabel x _) = dataConCantHappen x +dsExpr (OpApp x _ _ _) = dataConCantHappen x +dsExpr (SectionL x _ _) = dataConCantHappen x +dsExpr (SectionR x _ _) = dataConCantHappen x -ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr -ds_prag_expr (HsPragSCC _ cc) expr = do - dflags <- getDynFlags - if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags - then do - mod_name <- getModule - count <- goptM Opt_ProfCountEntries - let nm = sl_fs cc - flavour <- mkExprCCFlavour <$> getCCIndexDsM nm - Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True) - <$> dsLExpr expr - else dsLExpr expr +{- ********************************************************************* +* * +* Desugaring applications +* * +********************************************************************* -} + +{- Note [Desugaring applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across an application (f e1 .. en) we collect up +all the desugared arguments, and then dispatch on the function f. +(Including the nullary case where n=0.) + +There are several special cases to handle + +* HsRecSel: a record selector gets warnings if it might fail. +* HsVar: special magic for `noinline` +* HsVar: special magic for `seq` + +Note [Desugaring seq] +~~~~~~~~~~~~~~~~~~~~~ +There are a few subtleties in the desugaring of `seq`, all +implemented in the `seqId` case of `ds_app_var`: + + 1. (as described in #1031) + + Consider, + f x y = x `seq` (y `seq` (# x,y #)) + + Because the argument to the outer 'seq' has an unlifted type, we'll use + call-by-value, and compile it as if we had + + f x y = case (y `seq` (# x,y #)) of v -> x `seq` v + + But that is bad, because we now evaluate y before x! + + Seq is very, very special! So we recognise it right here, and desugar to + case x of _ -> case y of _ -> (# x,y #) + + 2. (as described in #2273) + + Consider + let chp = case b of { True -> fst x; False -> 0 } + in chp `seq` ...chp... + Here the seq is designed to plug the space leak of retaining (snd x) + for too long. + + If we rely on the ordinary inlining of seq, we'll get + let chp = case b of { True -> fst x; False -> 0 } + case chp of _ { I# -> ...chp... } + + But since chp is cheap, and the case is an alluring context, we'll + inline chp into the case scrutinee. Now there is only one use of chp, + so we'll inline a second copy. Alas, we've now ruined the purpose of + the seq, by re-introducing the space leak: + case (case b of {True -> fst x; False -> 0}) of + I# _ -> ...case b of {True -> fst x; False -> 0}... + + We can try to avoid doing this by ensuring that the binder-swap in the + case happens, so we get this at an early stage: + case chp of chp2 { I# -> ...chp2... } + But this is fragile. The real culprit is the source program. Perhaps we + should have said explicitly + let !chp2 = chp in ...chp2... + + But that's painful. So the code here does a little hack to make seq + more robust: a saturated application of 'seq' is turned *directly* into + the case expression, thus: + x `seq` e2 ==> case x of x -> e2 -- Note shadowing! + e1 `seq` e2 ==> case x of _ -> e2 + + So we desugar our example to: + let chp = case b of { True -> fst x; False -> 0 } + case chp of chp { I# -> ...chp... } + And now all is well. + + The reason it's a hack is because if you define mySeq=seq, the hack + won't work on mySeq. + + 3. (as described in #2409) + + The isInternalName ensures that we don't turn + True `seq` e + into + case True of True { ... } + which stupidly tries to bind the datacon 'True'. +-} + +dsApp :: HsExpr GhcTc -> DsM CoreExpr +dsApp e = ds_app e [] [] + +---------------------- +ds_lapp :: LHsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr +-- The [LHsExpr] args correspond to the [CoreExpr] args, +-- but there may be more of the latter because they include +-- type and dictionary arguments +ds_lapp (L loc e) hs_args core_args + = putSrcSpanDsA loc $ + ds_app e hs_args core_args + +ds_app :: HsExpr GhcTc -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr +-- The work-horse +ds_app (HsPar _ e) hs_args core_args = ds_lapp e hs_args core_args + +ds_app (HsApp _ fun arg) hs_args core_args + = do { core_arg <- dsLExpr arg + ; ds_lapp fun (arg : hs_args) (core_arg : core_args) } + +ds_app (HsAppType arg_ty fun _) hs_args core_args + = ds_lapp fun hs_args (Type arg_ty : core_args) + +ds_app (XExpr (WrapExpr hs_wrap fun)) hs_args core_args + = do { (fun_wrap, all_args) <- splitHsWrapperArgs hs_wrap core_args + ; if isIdHsWrapper fun_wrap + then ds_app fun hs_args all_args + else do { core_fun <- dsHsWrapper fun_wrap $ \core_wrap -> + do { core_fun <- dsExpr fun + ; return (core_wrap core_fun) } + ; return (mkCoreApps core_fun all_args) } } + +ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args +-- Desugar desugars 'ConLikeTc': it eta-expands +-- data constructors to make linear types work. +-- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head + = do { ds_con <- dsHsConLike con + ; ids <- newSysLocalsDs tys + -- NB: these 'Id's may be representation-polymorphic; + -- see Wrinkle [Representation-polymorphic lambda] in + -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head. + ; let core_fun = mkLams tvs $ mkLams ids $ + ds_con `mkTyApps` mkTyVarTys tvs + `mkVarApps` ids + ; return (mkApps core_fun core_args) } + +ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args + = ds_app_rec_sel sel_id sel_id core_args + +ds_app (HsVar _ lfun) hs_args core_args + = ds_app_var lfun hs_args core_args + +ds_app e _hs_args core_args + = do { core_e <- dsExpr e + ; return (mkCoreApps core_e core_args) } + +--------------- +ds_app_var :: LocatedN Id -> [LHsExpr GhcTc] -> [CoreExpr] -> DsM CoreExpr +-- Desugar an application with HsVar at the head +ds_app_var (L loc fun_id) hs_args core_args + + ----------------------- + -- Deal with getField applications. General form: + -- getField + -- @GHC.Types.Symbol {k} + -- @"sel" x_ty + -- @T r_ty + -- @Int a_ty + -- ($dHasField :: HasField "sel" T Int) dict + -- :: T -> Int + -- where + -- $dHasField = sel |> (co :: T -> Int ~R# HasField "sel" T Int) + -- Alas, we cannot simply look at the unfolding of $dHasField below because it + -- has not been set yet, so we have to reconstruct the selector Id from the types. + | fun_id `hasKey` getFieldClassOpKey + = do { -- Look up the field named x/"sel" in the type r/T + fam_inst_envs <- dsGetFamInstEnvs + ; rdr_env <- dsGetGlobalRdrEnv + ; let core_arg_tys :: [Type] = [ty | Type ty <- core_args] + ; case lookupHasFieldLabel fam_inst_envs rdr_env core_arg_tys of + Just (sel_name,_,_,_) + -> do { sel_id <- dsLookupGlobalId sel_name + ; tracePm "getfield2" (ppr sel_id) + ; ds_app_rec_sel sel_id fun_id core_args } + _ -> ds_app_finish fun_id core_args } + + ----------------------- + -- Warn about identities for (fromInteger :: Integer -> Integer) etc + -- They all have a type like: forall . => arg_ty -> res_ty + | idName fun_id `elem` numericConversionNames + , let (conv_ty, _) = apply_invis_args fun_id core_args + , Just (arg_ty, res_ty) <- splitVisibleFunTy_maybe conv_ty + = do { dflags <- getDynFlags + ; when (wopt Opt_WarnIdentities dflags + && arg_ty `eqType` res_ty) $ + -- So we are converting ty -> ty + diagnosticDs (DsIdentitiesFound fun_id conv_ty) + + ; ds_app_finish fun_id core_args } + + ----------------------- + -- Warn about unused return value in + -- do { ...; e; ... } when e returns (say) an Int + | fun_id `hasKey` thenMClassOpKey -- It is the built-in Prelude.(>>) + -- (>>) :: forall m. Monad m => forall a b. m a -> (b->m b) -> m b + , Type m_ty : _dict : Type arg_ty : _ <- core_args + , hs_arg : _ <- hs_args + = do { tracePm ">>" (ppr loc $$ ppr arg_ty $$ ppr (isGeneratedSrcSpan (locA loc))) + ; when (isGeneratedSrcSpan (locA loc)) $ -- It is a compiler-generated (>>) + warnDiscardedDoBindings hs_arg m_ty arg_ty + ; ds_app_finish fun_id core_args } + + ----------------------- + -- Deal with `noinline` + -- See Note [noinlineId magic] in GHC.Types.Id.Make + | fun_id `hasKey` noinlineIdKey + , Type _ : arg1 : rest_args <- core_args + , (inner_fun, inner_args) <- collectArgs arg1 + = return (Var fun_id `App` Type (exprType inner_fun) `App` inner_fun + `mkCoreApps` inner_args `mkCoreApps` rest_args) + + ----------------------- + -- Deal with `seq` + -- See Note [Desugaring seq], points (1) and (2) + | fun_id `hasKey` seqIdKey + , Type _r : Type ty1 : Type ty2 : arg1 : arg2 : rest_args <- core_args + , let case_bndr = case arg1 of + Var v1 | isInternalName (idName v1) + -> v1 -- Note [Desugaring seq], points (2) and (3) + _ -> mkWildValBinder ManyTy ty1 + = return (Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2] + `mkCoreApps` rest_args) + + ----------------------- + -- Phew! No more special cases. Just build an applications + | otherwise + = ds_app_finish fun_id core_args + +--------------- +ds_app_finish :: Id -> [CoreExpr] -> DsM CoreExpr +-- We are about to construct an application that may include evidence applications +-- `f dict`. If the dictionary is non-specialisable, instead construct +-- nospec f dict +-- See Note [nospecId magic] in GHC.Types.Id.Make for what `nospec` does. +-- See Note [Desugaring non-canonical evidence] +ds_app_finish fun_id core_args + = do { mb_unspecables <- getUnspecables + ; let fun_ty = idType fun_id + free_dicts = exprsFreeVarsList + [ e | (e,pi_bndr) <- core_args `zip` fst (splitPiTys fun_ty) + , isInvisibleAnonPiTyBinder pi_bndr ] + + fun | Just unspecables <- mb_unspecables + , not (isEmptyVarSet unspecables) -- Fast path + , any (`elemVarSet` unspecables) free_dicts + = Var nospecId `App` Type fun_ty `App` Var fun_id + | otherwise + = Var fun_id + + ; return (mkCoreApps fun core_args) } + +--------------- +ds_app_rec_sel :: Id -- The record selector Id itself + -> Id -- The function at the the head + -> [CoreExpr] -- Its arguments + -> DsM CoreExpr +-- Desugar an application with HsRecSelId at the head +ds_app_rec_sel sel_id fun_id core_args + | RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id + , RSI { rsi_undef = cons_wo_field } <- rec_sel_info + = do { -- Record selectors are warned about if they are not present in all of the + -- parent data type's constructors, or always in case of pattern synonym record + -- selectors (regulated by a flag). However, this only produces a warning if + -- it's not a part of a record selector application. For example: + -- data T = T1 | T2 {s :: Bool} + -- g y = map s y -- Warn here + -- f x = s x -- No warning here + ; let (fun_ty, val_args) = apply_invis_args fun_id core_args + + ; tracePm "ds_app_rec_sel" (ppr fun_ty $$ ppr val_args) + ; case val_args of + + -- There is a value argument + -- See (IRS2) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + (arg:_) -> pmcRecSel sel_id arg + + -- No value argument, but the selector is + -- applied to all its type arguments + -- See (IRS3) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + [] | Just (val_arg_ty, _) <- splitVisibleFunTy_maybe fun_ty + -> do { dummy <- newSysLocalDs (Scaled ManyTy val_arg_ty) + ; pmcRecSel sel_id (Var dummy) } + + -- Not even applied to all its type args + -- See (IRS4) of Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + _ -> unless (null cons_wo_field) $ + do { dflags <- getDynFlags + ; let maxCons = maxUncoveredPatterns dflags + ; diagnosticDs $ DsIncompleteRecordSelector (idName sel_id) cons_wo_field maxCons } + + ; ds_app_finish fun_id core_args } + + | otherwise + = pprPanic "ds_app_rec_sel" (ppr sel_id $$ ppr (idDetails sel_id)) + where + +apply_invis_args :: Id -> [CoreExpr] -> (Type, [CoreExpr]) +-- Apply function to the initial /type/ args; +-- return the type of the instantiated function, +-- and the remaining args +-- e.g. apply_type_args (++) [Type Int, Var xs] +-- = ([Int] -> [Int] -> [Int], [Var xs]) +apply_invis_args fun_id args + = (applyTypeToArgs fun_ty invis_args, rest_args) + where + fun_ty = idType fun_id + (invis_args, rest_args) = splitAt (invisibleBndrCount fun_ty) args + ------------------------------ +splitHsWrapperArgs :: HsWrapper -> [CoreArg] -> DsM (HsWrapper, [CoreArg]) +-- Splits the wrapper into the trailing arguments, and leftover bit +splitHsWrapperArgs wrap args = go wrap args + where + go (WpTyApp ty) args = return (WpHole, Type ty : args) + go (WpEvApp tm) args = do { core_tm <- dsEvTerm tm + ; return (WpHole, core_tm : args)} + go (WpCompose w1 w2) args + = do { (w1', args') <- go w1 args + ; if isIdHsWrapper w1' + then go w2 args' + else return (w1' <.> w2, args') } + go wrap args = return (wrap, args) + +------------------------------ +dsHsConLike :: ConLike -> DsM CoreExpr +dsHsConLike (RealDataCon dc) + = return (varToCoreExpr (dataConWrapId dc)) +dsHsConLike (PatSynCon ps) + | Just (builder_name, _, add_void) <- patSynBuilder ps + = do { builder_id <- dsLookupGlobalId builder_name + ; return (if add_void + then mkCoreApp (text "dsConLike" <+> ppr ps) + (Var builder_id) unboxedUnitExpr + else Var builder_id) } + | otherwise + = pprPanic "dsConLike" (ppr ps) + +------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr dsSyntaxExpr (SyntaxExprTc { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) arg_exprs - = do { fun <- dsExpr expr - ; dsHsWrappers arg_wraps $ \core_arg_wraps -> do - { dsHsWrapper res_wrap $ \core_res_wrap -> do - { let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs - ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } } } + = do { fun <- dsExpr expr + ; dsHsWrappers arg_wraps $ \core_arg_wraps -> + dsHsWrapper res_wrap $ \core_res_wrap -> + do { let wrapped_args = zipWithEqual ($) core_arg_wraps arg_exprs + ; return $ core_res_wrap (mkCoreApps fun wrapped_args) } } dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr" findField :: [LHsRecField GhcTc arg] -> Name -> [arg] @@ -556,6 +914,53 @@ {- %-------------------------------------------------------------------- +Note [Desugaring non-canonical evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When constructing an application + f @ty1 ty2 .. dict1 dict2 .. arg1 arg2 .. +if the evidence `dict_i` is canonical, we simply build that application. +But if any of the `dict_i` are /non-canonical/, we wrap the application +in `nospec`, thus + nospec @fty f @ty1 @ty2 .. dict1 dict2 .. arg1 arg2 .. +where nospec :: forall a. a -> a ensures that the typeclass specialiser +doesn't attempt to common up this evidence term with other evidence terms +of the same type (see Note [nospecId magic] in GHC.Types.Id.Make). + +See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv for +what a "non-canonical" dictionary is, and whe shouldn't specialise on it. + +How do we decide if the arguments are non-canonical dictionaries? + +* In `ds_app_finish` we look for dictionary arguments (invisible value args) + +* In the DsM monad we track the "unspecables" (i.e. non-canonical dictionaries) + in the `dsl_unspecable` field of `DsLclEnv` + +* We extend that unspecable set via `addUnspecables`, in `dsEvBinds`. + A dictionary is non-canonical if its own resolution was incoherent (see + Note [Incoherent instances]), or if its definition refers to other non-canonical + evidence. `dsEvBinds` is the convenient place to compute this, since it already + needs to do inter-evidence dependency analysis to generate well-scoped + bindings. + +Wrinkle: + +(NC1) We don't do this in the LHS of a RULE. In particular, if we have + f :: (Num a, HasCallStack) => a -> a + {-# SPECIALISE f :: Int -> Int #-} + then making a rule like + RULE forall d1:Num Int, d2:HasCallStack. + f @Int d1 d2 = $sf + is pretty dodgy, because $sf won't get the call stack passed in d2. + But that's what you asked for in the SPECIALISE pragma, so we'll obey. + + We definitely can't desugar that LHS into this! + nospec (f @Int d1) d2 + + This is done by zapping the unspecables in `dsRule` to Nothing. That `Nothing` + says not to collect unspecables at all. + + Note [Desugaring explicit lists] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Explicit lists are desugared in a cleverer way to prevent some @@ -661,8 +1066,14 @@ Haskell 98 report: -} -dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr -dsDo ctx stmts +dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> Type -> DsM CoreExpr +-- This code path seems inactive for regular Do, +-- which is expanded in GHC.Tc.Gen.Do. +-- It is used only for ApplicativeDo (even the BindStmt case), which is *very* +-- annoying because it is a lot of duplicated code that is seldomly tested. +-- But we are on course to expane Applicative in GHC.Tc.Gen.Do, at which +-- point all this will go away +dsDo ctx stmts res_ty = goL stmts where goL [] = panic "dsDo" @@ -674,7 +1085,9 @@ go _ (BodyStmt _ rhs then_expr _) stmts = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs (exprType rhs2) + ; case tcSplitAppTy_maybe (exprType rhs2) of + Just (m_ty, elt_ty) -> warnDiscardedDoBindings rhs m_ty elt_ty + Nothing -> return () -- Odd, but not warning ; rest <- goL stmts ; dsSyntaxExpr then_expr [rhs2, rest] } @@ -683,6 +1096,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 @@ -690,40 +1106,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 @@ -749,11 +1134,11 @@ later_pats = rec_tup_pats rets = map noLocA rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated SkipPmc) - mfix_arg = noLocA $ HsLam noExtField + match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion SkipPmc) + mfix_arg = noLocA $ HsLam noAnn LamSingle (MG { mg_alts = noLocA [mkSimpleMatch - LambdaExpr - [mfix_pat] body] + (LamAlt LamSingle) + (noLocA [mfix_pat]) body] , mg_ext = match_group }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats @@ -765,6 +1150,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" @@ -814,49 +1230,7 @@ because we already know 'y' is of the form "Just ...". See test case T21360b. -************************************************************************ -* * - Desugaring Variables -* * -************************************************************************ --} -dsHsVar :: Id -> DsM CoreExpr --- We could just call dsHsUnwrapped; but this is a short-cut --- for the very common case of a variable with no wrapper. -dsHsVar var - = return (varToCoreExpr var) -- See Note [Desugaring vars] - -dsHsConLike :: ConLike -> DsM CoreExpr -dsHsConLike (RealDataCon dc) - = return (varToCoreExpr (dataConWrapId dc)) -dsHsConLike (PatSynCon ps) - | Just (builder_name, _, add_void) <- patSynBuilder ps - = do { builder_id <- dsLookupGlobalId builder_name - ; return (if add_void - then mkCoreApp (text "dsConLike" <+> ppr ps) - (Var builder_id) unboxedUnitExpr - else Var builder_id) } - | otherwise - = pprPanic "dsConLike" (ppr ps) - --- | This function desugars 'ConLikeTc': it eta-expands --- data constructors to make linear types work. --- --- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head -dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr -dsConLike con tvs tys - = do { ds_con <- dsHsConLike con - ; ids <- newSysLocalsDs tys - -- NB: these 'Id's may be representation-polymorphic; - -- see Wrinkle [Representation-polymorphic lambda] in - -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head. - ; return (mkLams tvs $ - mkLams ids $ - ds_con `mkTyApps` mkTyVarTys tvs - `mkVarApps` ids) } - -{- ************************************************************************ * * \subsection{Errors and contexts} @@ -865,62 +1239,30 @@ -} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM () -warnDiscardedDoBindings rhs rhs_ty - | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty +warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM () +warnDiscardedDoBindings rhs m_ty elt_ty = do { warn_unused <- woptM Opt_WarnUnusedDoBind ; warn_wrong <- woptM Opt_WarnWrongDoBind ; when (warn_unused || warn_wrong) $ do { fam_inst_envs <- dsGetFamInstEnvs ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty - - -- Warn about discarding non-() things in 'monadic' binding - ; if warn_unused && not (isUnitTy norm_elt_ty) + supressible_ty = + isUnitTy norm_elt_ty || isAnyTy norm_elt_ty || isZonkAnyTy norm_elt_ty + -- Warn about discarding things in 'monadic' binding, + -- however few types are excluded: + -- * Unit type `()` + -- * `ZonkAny` or `Any` type see (Any8) of Note [Any types] + ; if warn_unused && not supressible_ty then diagnosticDs (DsUnusedDoBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + -- Example: do { return 3; blah } + -- We get (>>) @m d @(m Int) (return 3) blah when warn_wrong $ - case tcSplitAppTy_maybe norm_elt_ty of - Just (elt_m_ty, _) - | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty - -> diagnosticDs (DsWrongDoBind rhs elt_ty) - _ -> return () } } - - | otherwise -- RHS does have type of form (m ty), which is weird - = return () -- but at least this warning is irrelevant - -{- -************************************************************************ -* * - dsHsWrapped -* * -************************************************************************ --} - ------------------------------- -dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr -dsHsWrapped orig_hs_expr - = go idHsWrapper orig_hs_expr - where - go wrap (HsPar _ _ (L _ hs_e) _) - = go wrap hs_e - go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e))) - = go (wrap1 <.> wrap2) hs_e - go wrap (HsAppType ty (L _ hs_e) _ _) - = go (wrap <.> WpTyApp ty) hs_e - - go wrap (HsVar _ (L _ var)) - = do { dsHsWrapper wrap $ \wrap' -> do - { let expr = wrap' (varToCoreExpr var) - ty = exprType expr - ; dflags <- getDynFlags - ; warnAboutIdentities dflags var ty - ; return expr } } - - go wrap hs_e - = do { dsHsWrapper wrap $ \wrap' -> do - { addTyCs FromSource (hsWrapDictBinders wrap) $ - do { e <- dsExpr hs_e - ; return (wrap' e) } } } + case tcSplitAppTy_maybe norm_elt_ty of + Just (elt_m_ty, _) + | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty + -> diagnosticDs (DsWrongDoBind rhs elt_ty) + _ -> return () } } diff --git a/GHC/HsToCore/Foreign/C.hs b/GHC/HsToCore/Foreign/C.hs --- a/GHC/HsToCore/Foreign/C.hs +++ b/GHC/HsToCore/Foreign/C.hs @@ -56,7 +56,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Encoding import Data.Maybe @@ -74,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 @@ -109,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 -> @@ -121,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) @@ -176,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 @@ -234,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 @@ -397,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 @@ -444,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)) @@ -544,11 +515,10 @@ , text "rts_inCall" <> parens ( char '&' <> cap <> text "rts_apply" <> parens ( - cap <> - text "(HaskellObj)" + cap <> (if is_IO_res_ty - then text "runIO_closure" - else text "runNonIO_closure") + then text "ghc_hs_iface->runIO_closure" + else text "ghc_hs_iface->runNonIO_closure") <> comma <> expr_to_run ) <+> comma @@ -626,17 +596,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 diff --git a/GHC/HsToCore/Foreign/Call.hs b/GHC/HsToCore/Foreign/Call.hs --- a/GHC/HsToCore/Foreign/Call.hs +++ b/GHC/HsToCore/Foreign/Call.hs @@ -22,30 +22,35 @@ import GHC.Prelude import GHC.Core - -import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make -import GHC.Types.SourceText -import GHC.Types.Id.Make -import GHC.Types.ForeignCall import GHC.Core.DataCon -import GHC.HsToCore.Utils - -import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Coercion -import GHC.Builtin.Types.Prim import GHC.Core.TyCon -import GHC.Builtin.Types +import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) + +import GHC.HsToCore.Monad +import GHC.HsToCore.Utils + +import GHC.Types.SourceText +import GHC.Types.Id.Make +import GHC.Types.ForeignCall import GHC.Types.Basic import GHC.Types.Literal +import GHC.Types.RepType (typePrimRep1) + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types import GHC.Builtin.Names + import GHC.Driver.DynFlags + import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Maybe @@ -138,10 +143,12 @@ 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 + -- Possibly-recursive newtypes | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty = unboxArg (mkCastDs arg co) @@ -150,7 +157,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 @@ -162,8 +169,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] ) @@ -173,11 +180,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] @@ -197,7 +204,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) @@ -227,7 +233,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 @@ -263,7 +269,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")) @@ -277,8 +283,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] @@ -335,8 +341,10 @@ -- Data types with a single constructor, which has a single arg -- This includes types like Ptr and ForeignPtr | Just (tycon, tycon_arg_tys) <- maybe_tc_app - , Just data_con <- tyConSingleAlgDataCon_maybe tycon -- One constructor - , null (dataConExTyCoVars data_con) -- no existentials + , not (isNewTyCon tycon) -- Newtypes should have been dealt with above, but + -- a recursive one might fall through here, I think + , Just data_con <- tyConSingleDataCon_maybe tycon -- One constructor + , null (dataConExTyCoVars data_con) -- no existentials , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys -- One argument = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty ; let marshal_con e = Var (dataConWrapId data_con) diff --git a/GHC/HsToCore/Foreign/Decl.hs b/GHC/HsToCore/Foreign/Decl.hs --- a/GHC/HsToCore/Foreign/Decl.hs +++ b/GHC/HsToCore/Foreign/Decl.hs @@ -20,6 +20,7 @@ import GHC.HsToCore.Foreign.C import GHC.HsToCore.Foreign.JavaScript +import GHC.HsToCore.Foreign.Wasm import GHC.HsToCore.Foreign.Utils import GHC.HsToCore.Monad @@ -86,16 +87,16 @@ do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) let id' = unLoc id - (bs, h, c) <- dsFImport id' co spec + (bs, h, c, ids) <- dsFImport id' co spec traceIf (text "fi end" <+> ppr id) - return (h, c, [], bs) + return (h, c, ids, bs) do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co , fd_fe = CExport _ (L _ (CExportStatic _ ext_nm cconv)) }) = do - (h, c, _, _) <- dsFExport id co ext_nm cconv False - return (h, c, [id], []) + (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv False + return (h, c, ids, bs) {- ************************************************************************ @@ -126,12 +127,20 @@ dsFImport :: Id -> Coercion -> ForeignImport (GhcPass p) - -> DsM ([Binding], CHeader, CStub) + -> DsM ([Binding], CHeader, CStub, [Id]) dsFImport id co (CImport _ cconv safety mHeader spec) = do platform <- getPlatform - case platformArch platform of - ArchJavaScript -> dsJsImport id co spec (unLoc cconv) (unLoc safety) mHeader - _ -> dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader + let cconv' = unLoc cconv + safety' = unLoc safety + case (platformArch platform, cconv') of + (ArchJavaScript, _) -> do + (bs, h, c) <- dsJsImport id co spec cconv' safety' mHeader + pure (bs, h, c, []) + (ArchWasm32, JavaScriptCallConv) -> + dsWasmJSImport id co spec safety' + _ -> do + (bs, h, c) <- dsCImport id co spec cconv' safety' mHeader + pure (bs, h, c, []) {- ************************************************************************ @@ -164,13 +173,20 @@ -> 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 ) dsFExport fn_id co ext_name cconv is_dyn = do platform <- getPlatform - case platformArch platform of - ArchJavaScript -> dsJsFExport fn_id co ext_name cconv is_dyn - _ -> dsCFExport fn_id co ext_name cconv is_dyn + case (platformArch platform, cconv) of + (ArchJavaScript, _) -> do + (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) <- dsCFExport fn_id co ext_name cconv is_dyn + pure (h, c, ts, [fn_id], []) foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub @@ -202,4 +218,3 @@ closure_ptr :: Id -> SDoc closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" - diff --git a/GHC/HsToCore/Foreign/JavaScript.hs b/GHC/HsToCore/Foreign/JavaScript.hs --- a/GHC/HsToCore/Foreign/JavaScript.hs +++ b/GHC/HsToCore/Foreign/JavaScript.hs @@ -58,7 +58,6 @@ import GHC.Builtin.Names import GHC.Data.FastString -import GHC.Data.Pair import GHC.Data.Maybe import GHC.Utils.Outputable @@ -78,12 +77,11 @@ -> 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 let - ty = pSnd $ coercionKind co + ty = coercionRKind co (_tvs,sans_foralls) = tcSplitForAllTyVars ty (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls -- We must use tcSplits here, because we want to see @@ -115,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 @@ -158,14 +146,17 @@ idTag i = let (tag, u) = unpkUnique (getUnique i) in CHeader (char tag <> word64 u) + normal_args = map (\(nm,_ty,_,_) -> nm) arg_info + all_args + | isNothing maybe_target = text "stableptr_offset" : normal_args + | otherwise = normal_args + fun_args | null arg_info = empty -- text "void" - | otherwise = hsep $ punctuate comma - $ map (\(nm,_ty,_,_) -> nm) arg_info + | otherwise = hsep $ punctuate comma all_args fun_proto - = text "async" <+> - text "function" <+> + = text "function" <+> (if isNothing maybe_target then text "h$" <> ftext c_nm else ftext c_nm) <> @@ -189,7 +180,7 @@ -- the target which will form the root of what we ask rts_evalIO to run the_cfun = case maybe_target of - Nothing -> text "h$deRefStablePtr(the_stableptr)" + Nothing -> text "h$deRefStablePtr(stableptr_offset)" Just hs_fn -> idClosureText hs_fn -- the expression we give to rts_eval @@ -211,8 +202,7 @@ $$ vcat [ lbrace , text "return" - <+> text "await" - <+> text "h$rts_eval" + <+> text "h$rts_eval_sync" <> parens ((if is_IO_res_ty then expr_to_run else text "h$rts_toIO" <> parens expr_to_run) @@ -241,8 +231,8 @@ -> Safety -> Maybe Header -> DsM ([Binding], CHeader, CStub) -dsJsImport id co (CLabel cid) cconv _ _ = do - let ty = pFst $ coercionKind co +dsJsImport id co (CLabel cid) _ _ _ = do + let ty = coercionLKind co fod = case tyConAppTyCon_maybe (dropForAlls ty) of Just tycon | tyConUnique tycon == funPtrTyConKey -> @@ -250,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) @@ -272,51 +261,43 @@ -> DsM ([Binding], CHeader, CStub) dsJsFExportDynamic id co0 cconv = do let - ty = pFst (coercionKind co0) + ty = coercionLKind co0 (tvs,sans_foralls) = tcSplitForAllTyVars ty - ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls - (io_tc, res_ty) = expectJust "dsJsFExportDynamic: IO type expected" + ([scaled_arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls + arg_ty = scaledThing scaled_arg_ty + (io_tc, res_ty) = expectJust -- 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 @@ -342,7 +323,7 @@ -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do let - ty = pFst $ coercionKind co + ty = coercionLKind co (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty (arg_tys, io_res_ty) = tcSplitFunTys rho @@ -434,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] ) @@ -445,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] @@ -468,13 +449,8 @@ (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys maybe_arg3_tycon = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3) - Just arg3_tycon = maybe_arg3_tycon -boxJsResult :: Type - -> DsM (Type, CoreExpr -> CoreExpr) -boxJsResult result_ty - | isRuntimeRepKindedTy result_ty = panic "boxJsResult: runtime rep ty" -- fixme -- Takes the result of the user-level ccall: -- either (IO t), -- or maybe just t for an side-effect-free call @@ -485,7 +461,7 @@ -- where t' is the unwrapped form of t. If t is simply (), then -- the result type will be -- State# RealWorld -> (# State# RealWorld #) - +boxJsResult :: Type -> DsM (Type, CoreExpr -> CoreExpr) boxJsResult result_ty | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty -- isIOType_maybe handles the case where the type is a @@ -501,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 @@ -536,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") @@ -548,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) @@ -563,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)) @@ -572,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 @@ -585,13 +557,12 @@ -- E.g. foreign import foo :: Int -> IO T -- Then resultWrapper deals with marshalling the 'T' part jsResultWrapper result_ty - | isRuntimeRepKindedTy result_ty = return (Nothing, id) -- fixme this seems like a hack -- Base case 1a: unboxed tuples | Just (tc, args) <- splitTyConApp_maybe result_ty , 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) @@ -616,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) @@ -678,6 +647,6 @@ mkJsCall u tgt args t = mkFCall u ccall args t where ccall = CCall $ CCallSpec - (StaticTarget NoSourceText tgt (Just primUnit) True) + (StaticTarget NoSourceText tgt (Just ghcInternalUnit) True) JavaScriptCallConv PlayRisky diff --git a/GHC/HsToCore/Foreign/Utils.hs b/GHC/HsToCore/Foreign/Utils.hs --- a/GHC/HsToCore/Foreign/Utils.hs +++ b/GHC/HsToCore/Foreign/Utils.hs @@ -27,7 +27,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out @@ -58,7 +57,7 @@ primTyDescChar !platform ty | ty `eqType` unitTy = 'v' | otherwise - = case typePrimRep1 (getPrimTyOf ty) of + = case typePrimRepU (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' diff --git a/GHC/HsToCore/Foreign/Wasm.hs b/GHC/HsToCore/Foreign/Wasm.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Wasm.hs @@ -0,0 +1,759 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.HsToCore.Foreign.Wasm + ( dsWasmJSImport, + dsWasmJSExport, + ) +where + +import Data.List + ( intercalate, + stripPrefix, + ) +import Data.List qualified +import Data.Maybe +import GHC.Builtin.Names +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Core +import GHC.Core.Coercion +import GHC.Core.DataCon +import GHC.Core.Make +import GHC.Core.Multiplicity +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Utils +import GHC.Data.FastString +import GHC.Hs +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Monad +import GHC.HsToCore.Types +import GHC.Iface.Env +import GHC.Prelude +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Types.ForeignCall +import GHC.Types.ForeignStubs +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.SourceText +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Unit +import GHC.Utils.Outputable +import GHC.Utils.Panic +import Language.Haskell.Syntax.Basic + +data Synchronicity = Sync | Async + deriving (Eq) + +dsWasmJSImport :: + Id -> + Coercion -> + CImportSpec -> + Safety -> + DsM ([Binding], CHeader, CStub, [Id]) +dsWasmJSImport id co (CFunction (StaticTarget _ js_src mUnitId _)) safety + | js_src == "wrapper" = dsWasmJSDynamicExport Async id co mUnitId + | js_src == "wrapper sync" = dsWasmJSDynamicExport Sync id co mUnitId + | otherwise = do + (bs, h, c) <- dsWasmJSStaticImport id co (unpackFS js_src) mUnitId sync + pure (bs, h, c, []) + where + sync = case safety of + PlayRisky -> Sync + _ -> Async +dsWasmJSImport _ _ _ _ = panic "dsWasmJSImport: unreachable" + +{- + +Note [Desugaring JSFFI dynamic export] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A JSFFI dynamic export wraps a Haskell function as a JavaScript +callback: + +foreign import javascript "wrapper" + mk_wrapper :: HsFuncType -> IO JSVal + +We desugar it to three bindings under the hood: + +1. The worker function + +mk_wrapper_worker :: StablePtr HsFuncType -> HsFuncType +mk_wrapper_worker sp = unsafeDupablePerformIO (deRefStablePtr sp) + +The worker function is marked as a JSFFI static export. It turns a +dynamic export to a static one by prepending a StablePtr to the +argument list. + +We don't actually generate a Core binding for the worker function +though; the JSFFI static export C stub generation logic would just +generate a function that doesn't need to refer to the worker Id's +closure. This is not just for convenience, it's actually required for +correctness, see #25473. + +2. The adjustor function + +foreign import javascript unsafe "(...args) => __exports.mk_wrapper_worker($1, ...args)" + mk_wrapper_adjustor :: StablePtr HsFuncType -> IO JSVal + +Now that mk_wrapper_worker is exported in __exports, we need to make a +JavaScript callback that invokes mk_wrapper_worker with the right +StablePtr as well as the rest of the arguments. + +3. The wrapper function + +mk_wrapper :: HsFuncType -> IO JSVal +mk_wrapper = mkJSCallback mk_wrapper_adjustor + +This is the user-facing mk_wrapper binding. It allocates a stable +pointer for the Haskell function closure, then calls the adjustor +function to fetch the JSVal that represents the JavaScript callback. +The JSVal as returned by the adjustor is not returned directly; it has +a StablePtr# field which is NULL by default, but for JSFFI dynamic +exports, it's set to the Haskell function's stable pointer. This way, +when we call freeJSVal, the Haskell function can be freed as well. + +By default, JSFFI exports are async JavaScript functions. One can use +"wrapper sync" instead of "wrapper" to indicate the Haskell function +is meant to be exported as a sync JavaScript function. All the +comments above still hold, with only only difference: +mk_wrapper_worker is exported as a sync function. See +Note [Desugaring JSFFI static export] for further details. + +-} + +dsWasmJSDynamicExport :: + Synchronicity -> + Id -> + Coercion -> + Maybe Unit -> + DsM ([Binding], CHeader, CStub, [Id]) +dsWasmJSDynamicExport sync fn_id co mUnitId = do + sp_tycon <- dsLookupTyCon stablePtrTyConName + let ty = coercionLKind co + (tv_bndrs, fun_ty) = tcSplitForAllTyVarBinders ty + ([Scaled ManyTy arg_ty], io_jsval_ty) = tcSplitFunTys fun_ty + sp_ty = mkTyConApp sp_tycon [arg_ty] + sp_id <- newSysLocalMDs sp_ty + work_export_name <- unpackFS <$> uniqueCFunName + deRefStablePtr_id <- + lookupGhcInternalVarId + "GHC.Internal.Stable" + "deRefStablePtr" + unsafeDupablePerformIO_id <- + lookupGhcInternalVarId + "GHC.Internal.IO.Unsafe" + "unsafeDupablePerformIO" + let work_rhs = + mkCoreLams ([tv | Bndr tv _ <- tv_bndrs] ++ [sp_id]) + $ mkApps + (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) <- + dsWasmJSExport' + sync + Nothing + (mkRepReflCo work_ty) + work_export_name + adjustor_uniq <- newUnique + let adjustor_id = + mkExportedVanillaId + ( mkExternalName + adjustor_uniq + (nameModule $ getName fn_id) + ( mkVarOcc + $ "jsffi_" + ++ occNameString (getOccName fn_id) + ++ "_adjustor" + ) + generatedSrcSpan + ) + adjustor_ty + adjustor_ty = mkForAllTys tv_bndrs $ mkVisFunTysMany [sp_ty] io_jsval_ty + adjustor_js_src = + "(...args) => __exports." ++ work_export_name ++ "($1, ...args)" + (adjustor_bs, adjustor_h, adjustor_c) <- + dsWasmJSStaticImport + adjustor_id + (mkRepReflCo adjustor_ty) + adjustor_js_src + mUnitId + Sync + mkJSCallback_id <- + lookupGhcInternalVarId + "GHC.Internal.Wasm.Prim.Exports" + "mkJSCallback" + let wrap_rhs = + mkCoreLams [tv | Bndr tv _ <- tv_bndrs] + $ mkApps + (Var mkJSCallback_id) + [ Type arg_ty, + mkApps + (Var adjustor_id) + [Type $ mkTyVarTy tv | Bndr tv _ <- tv_bndrs] + ] + pure + ( [(fn_id, Cast wrap_rhs co)] ++ work_bs ++ adjustor_bs, + work_h `mappend` adjustor_h, + work_c `mappend` adjustor_c, + work_ids + ) + +{- + +Note [Desugaring JSFFI import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The simplest case is JSFFI sync import, those marked as unsafe. It is +implemented on top of C FFI safe import. + +Unlike C FFI which generates a worker/wrapper pair that unboxes the +arguments and boxes the result in Haskell, we only desugar to a single +Haskell binding that case-binds the arguments to ensure they're +evaluated, then passes the boxed arguments directly to C and receive +the boxed result from C as well. + +This is slightly less efficient than how C FFI does it, and unboxed +FFI types aren't supported, but it's the simplest way to implement it, +especially since leaving all the boxing/unboxing business to C unifies +the implementation of JSFFI imports and exports +(rts_mkJSVal/rts_getJSVal). + +Now, each sync import calls a generated C function with a unique +symbol. The C function uses rts_get* to unbox the arguments, call into +JavaScript, then boxes the result with rts_mk* and returns it to +Haskell. But wait, how on earth is C able to call into JavaScript +here!? The secret is using a wasm import: + +__attribute__((import_module("ghc_wasm_jsffi"), import_name("my_js_func"))) +HsJSVal worker_func(HsInt a1, HsJSVal a2); + +Wasm imports live in the same namespace as other wasm functions, so +our C wrapper function can call into this imported worker function, +which will literally be the user written JavaScript function with +binders $1, $2, etc. + +So far so good, but how does the source code snippet go from Haskell +source files to the JavaScript module which provides the +ghc_wasm_jsffi imports to be used by the wasm module at runtime? The +secret is embedding the source code snippets in a wasm custom section +named ghc_wasm_jsffi: + +.section .custom_section.ghc_wasm_jsffi,"",@ +.asciz my_js_func +.asciz ($1, $2) +.asciz js_code_containing($1, $2) + +At link time, for all object files touched by wasm-ld, all +ghc_wasm_jsffi sections are concatenated into a single ghc_wasm_jsffi +section in the output wasm module. And then, a simple "post-linker" +program can parse the payload of that section and emit a JavaScript +module. Note that above is assembly source file, but we're only +generating a C stub, so we need to smuggle the assembly code into C +via __asm__. + +The C FFI import that calls the generated C function is always marked +as safe. There is some extra overhead, but this allows re-entrance by +Haskell -> JavaScript -> Haskell function calls with each call being a +synchronous one. It's possible to steal the "interruptible" keyword to +indicate async imports, "safe" for sync imports and "unsafe" for sync +imports sans the safe C FFI overhead, but it's simply not worth the +extra complexity. + +JSFFI async import is implemented on top of JSFFI sync import. We +still desugar it to a single Haskell binding that calls C, with some +subtle differences: + +- The C result type is always a boxed JSVal that represents the + JavaScript Promise, instead of the actual Haskell result type. +- In the custom section payload, we emit "async ($1, $2)" instead of + "($1, $2)". As you can see, it is the arrow function binder, and the + post-linker will respect the async binder and allow await in the + function body. + +Now we have the Promise JSVal, we apply stg_blockPromise to it to get +a thunk with the desired return type. When the thunk is forced, it +will block the forcing thread and wait for the Promise to resolve or +reject. See Note [stg_blockPromise] for detailed explanation of how it +works. + +-} + +dsWasmJSStaticImport :: + Id -> + Coercion -> + String -> + Maybe Unit -> + Synchronicity -> + DsM ([Binding], CHeader, CStub) +dsWasmJSStaticImport fn_id co js_src' mUnitId sync = do + cfun_name <- uniqueCFunName + let ty = coercionLKind co + (tvs, fun_ty) = tcSplitForAllInvisTyVars ty + (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty + (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of + Just (_, res_ty) -> (res_ty, True) + Nothing -> (orig_res_ty, False) + js_src + -- Just desugar it to a JSFFI import with source text "$1($2, + -- ...)", with the same type signature and safety annotation. + | js_src' == "dynamic" = + "$1(" + ++ intercalate "," ["$" ++ show i | i <- [2 .. length arg_tys]] + ++ ")" + | otherwise = + js_src' + case sync of + Sync -> do + rhs <- importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty id + pure + ( [(fn_id, Cast rhs co)], + CHeader commonCDecls, + importCStub Sync cfun_name (map scaledThing arg_tys) res_ty js_src + ) + Async -> do + err_msg <- mkStringExpr $ js_src + io_tycon <- dsLookupTyCon ioTyConName + jsval_ty <- + mkTyConTy + <$> lookupGhcInternalTyCon "GHC.Internal.Wasm.Prim.Types" "JSVal" + bindIO_id <- dsLookupGlobalId bindIOName + returnIO_id <- dsLookupGlobalId returnIOName + 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 + unsafeDupablePerformIO_id <- + lookupGhcInternalVarId + "GHC.Internal.IO.Unsafe" + "unsafeDupablePerformIO" + rhs <- + importBindingRHS + mUnitId + cfun_name + tvs + arg_tys + (mkTyConApp io_tycon [jsval_ty]) + $ ( if is_io + then id + else \m_res -> + mkApps (Var unsafeDupablePerformIO_id) [Type res_ty, m_res] + ) + -- (m_promise :: IO JSVal) >>= (\promise -> return (stg_blockPromise promise msgPromise)) + -- stg_blockPromise returns the thunk + . ( \m_promise -> + mkApps + (Var bindIO_id) + [ Type jsval_ty, + Type res_ty, + m_promise, + Lam promise_id + $ mkApps + (Var returnIO_id) + [ Type res_ty, + mkApps + (Var blockPromise_id) + [Type res_ty, err_msg, Var promise_id, Var msgPromise_id] + ] + ] + ) + pure + ( [(fn_id, Cast rhs co)], + CHeader commonCDecls, + importCStub Async cfun_name (map scaledThing arg_tys) jsval_ty js_src + ) + +uniqueCFunName :: DsM FastString +uniqueCFunName = do + cfun_num <- ds_next_wrapper_num <$> getGblEnv + mkWrapperName cfun_num "ghc_wasm_jsffi" "" + +importBindingRHS :: + Maybe Unit -> + FastString -> + [TyVar] -> + [Scaled Type] -> + Type -> + (CoreExpr -> CoreExpr) -> + DsM CoreExpr +importBindingRHS mUnitId cfun_name tvs arg_tys orig_res_ty res_trans = do + ccall_uniq <- newUnique + args_unevaled <- newSysLocalsDs arg_tys + args_evaled <- newSysLocalsDs arg_tys + -- ccall_action_ty: type of the_call, State# RealWorld -> (# State# RealWorld, a #) + -- 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 <- newSysLocalMDs realWorldStatePrimTy + s1_id <- newSysLocalMDs realWorldStatePrimTy + let io_data_con = tyConSingleDataCon io_tycon + toIOCon = dataConWorkId io_data_con + (ccall_res_ty, wrap) + | res_ty `eqType` unitTy = + ( mkTupleTy Unboxed [realWorldStatePrimTy], + \the_call -> + mkApps + (Var toIOCon) + [ Type res_ty, + Lam s0_id + $ mkWildCase + (App the_call (Var s0_id)) + (unrestricted ccall_res_ty) + (mkTupleTy Unboxed [realWorldStatePrimTy, unitTy]) + [ Alt + (DataAlt (tupleDataCon Unboxed 1)) + [s1_id] + (mkCoreUnboxedTuple [Var s1_id, unitExpr]) + ] + ] + ) + | otherwise = + ( mkTupleTy Unboxed [realWorldStatePrimTy, res_ty], + \the_call -> mkApps (Var toIOCon) [Type res_ty, the_call] + ) + pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + Nothing -> do + unsafeDupablePerformIO_id <- + lookupGhcInternalVarId + "GHC.Internal.IO.Unsafe" + "unsafeDupablePerformIO" + io_data_con <- dsLookupDataCon ioDataConName + let ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, orig_res_ty] + toIOCon = dataConWorkId io_data_con + wrap the_call = + mkApps + (Var unsafeDupablePerformIO_id) + [ Type orig_res_ty, + mkApps (Var toIOCon) [Type orig_res_ty, the_call] + ] + pure (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + let cfun_fcall = + CCall + ( CCallSpec + (StaticTarget NoSourceText cfun_name mUnitId True) + CCallConv + -- Same even for foreign import javascript unsafe, for + -- the sake of re-entrancy. + PlaySafe + ) + call_app = + mkFCall ccall_uniq cfun_fcall (map Var args_evaled) ccall_action_ty + rhs = + mkCoreLams (tvs ++ args_unevaled) + $ foldr + (\(arg_u, arg_e) acc -> mkDefaultCase (Var arg_u) arg_e acc) + -- res_trans transforms the result. When desugaring + -- JSFFI sync imports, the result is just (IO a) or a, + -- and res_trans is id; for async cases, the result is + -- always (IO JSVal), and res_trans will wrap it in a + -- thunk that has the original return type. This way, we + -- can reuse most of the RHS generation logic for both + -- sync/async imports. + (res_trans $ res_wrapper call_app) + (zip args_unevaled args_evaled) + pure rhs + +importCStub :: Synchronicity -> FastString -> [Type] -> Type -> String -> CStub +importCStub sync cfun_name arg_tys res_ty js_src = CStub c_doc [] [] + where + import_name = fromJust $ stripPrefix "ghczuwasmzujsffi" (unpackFS cfun_name) + import_asm = + text "__asm__" + <> parens + ( vcat + [ text (show l) + | l <- + [ ".section .custom_section.ghc_wasm_jsffi,\"\",@\n", + ".asciz \"" ++ import_name ++ "\"\n", + ".asciz \"" + ++ ( case sync of + Sync -> "(" + Async -> "async (" + ) + ++ intercalate "," ["$" ++ show i | i <- [1 .. length arg_tys]] + ++ ")\"\n", + ".asciz " ++ show js_src ++ "\n" + ] + ] + ) + <> semi + import_attr = + text "__attribute__" + <> parens + ( parens + ( hsep + ( punctuate + comma + [ text k <> parens (doubleQuotes (text v)) + | (k, v) <- + [("import_module", "ghc_wasm_jsffi"), ("import_name", import_name)] + ] + ) + ) + ) + import_proto = + import_res_ty <+> text import_name <> parens import_args <> semi + import_res_ty + | res_ty `eqType` unitTy = text "void" + | otherwise = text ("Hs" ++ ffiType res_ty) + import_arg_list = + [ text ("Hs" ++ ffiType arg_ty) <+> char 'a' <> int i + | (i, arg_ty) <- zip [1 ..] arg_tys + ] + import_args = case import_arg_list of + [] -> text "void" + _ -> hsep $ punctuate comma import_arg_list + cfun_proto = cfun_res_ty <+> ppr cfun_name <> parens cfun_args + cfun_ret + | res_ty `eqType` unitTy = cfun_call_import <> semi + | otherwise = text "return" <+> cfun_call_import <> semi + cfun_make_arg arg_ty arg_val = + text ("rts_get" ++ ffiType arg_ty) <> parens arg_val + cfun_make_ret ret_val + | res_ty `eqType` unitTy = ret_val + | otherwise = + text ("rts_mk" ++ ffiType res_ty) + -- We can cheat a little bit here since there's only + -- MainCapability in the single-threaded RTS anyway, so no + -- need to call rts_unsafeGetMyCapability(). + <> parens (hsep (punctuate comma [text "&MainCapability", ret_val])) + cfun_call_import = + cfun_make_ret + $ text import_name + <> parens + ( hsep + ( punctuate + comma + [ cfun_make_arg arg_ty (char 'a' <> int n) + | (arg_ty, n) <- zip arg_tys [1 ..] + ] + ) + ) + cfun_res_ty + | res_ty `eqType` unitTy = text "void" + | otherwise = text "HaskellObj" + cfun_arg_list = + [text "HaskellObj" <+> char 'a' <> int n | n <- [1 .. length arg_tys]] + cfun_args = case cfun_arg_list of + [] -> text "void" + _ -> hsep $ punctuate comma cfun_arg_list + c_doc = + commonCDecls + $+$ import_asm + $+$ import_attr + $+$ import_proto + $+$ cfun_proto + $+$ braces cfun_ret + +{- + +Note [Desugaring JSFFI static export] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A JSFFI static export wraps a top-level Haskell binding as a wasm +module export that can be called in JavaScript as an async/sync +function: + +foreign export javascript "plus" + (+) :: Int -> Int -> Int + +Just like generating C stub for a JSFFI import, we need to generate C +stub for a JSFFI export as well: + +__attribute__((export_name("plus"))) +HsJSVal plus(HsInt a1, HsInt a2) { ... } + +The generated C stub function would be exported as __exports.plus and +can be called in JavaScript. By default, it's exported as an async +function, so the C stub would always return an HsJSVal which +represents the result Promise; in case of a sync export (using "plus +sync" instead of "plus"), it returns the original result type. + +The C stub function body applies the function closure to arguments, +wrap it with a runIO/runNonIO top handler function, then schedules +Haskell computation to happen, then fetches the result. In case of an +async export, the top handler creates a JavaScript Promise that stands +for Haskell evaluation result, and the Promise will eventually be +resolved with the result or rejected with an exception. That Promise +is what we return in the C stub function. See +Note [Async JSFFI scheduler] for detailed explanation. + +At link time, you need to pass -optl-Wl,--export=plus,--export=... to +specify your entrypoint function symbols as roots of wasm-ld link-time +garbage collection. As for the auto-generated exports when desugaring +the JSFFI dynamic exports, they will be transitively included as well +due to the export_name attribute. + +-} + +dsWasmJSExport :: + Id -> + Coercion -> + CLabelString -> + DsM (CHeader, CStub, String, [Id], [Binding]) +dsWasmJSExport fn_id co str = dsWasmJSExport' sync (Just fn_id) co ext_name + where + (sync, ext_name) = case words $ unpackFS str of + [ext_name] -> (Async, ext_name) + [ext_name, "sync"] -> (Sync, ext_name) + _ -> panic "dsWasmJSExport: unrecognized label string" + +dsWasmJSExport' :: + Synchronicity -> + Maybe Id -> + Coercion -> + String -> + DsM (CHeader, CStub, String, [Id], [Binding]) +dsWasmJSExport' sync m_fn_id co ext_name = do + let ty = coercionRKind co + (_, fun_ty) = tcSplitForAllInvisTyVars ty + (arg_tys, orig_res_ty) = tcSplitFunTys fun_ty + (res_ty, is_io) = case tcSplitIOType_maybe orig_res_ty of + Just (_, res_ty) -> (res_ty, True) + Nothing -> (orig_res_ty, False) + res_ty_str = ffiType res_ty + top_handler_mod = case sync of + Sync -> "GHC.Internal.TopHandler" + Async -> "GHC.Internal.Wasm.Prim.Exports" + top_handler_name + | is_io = "runIO" + | otherwise = "runNonIO" + -- In case of sync export, we use the normal C FFI tophandler + -- functions. They would call flushStdHandles in case of uncaught + -- exception but not in normal cases, but we want flushStdHandles to + -- be called so that there are less run-time surprises for users, + -- and that's what our tophandler functions already do. + -- + -- So for each sync export, we first wrap the computation with a C + -- FFI tophandler, and then sequence it with flushStdHandles using + -- (<*) :: IO a -> IO b -> IO a. But it's trickier to call (<*) + -- using RTS API given type class dictionary is involved, so we'll + -- just use finally. + finally_id <- + lookupGhcInternalVarId + "GHC.Internal.Control.Exception.Base" + "finally" + flushStdHandles_id <- + lookupGhcInternalVarId + "GHC.Internal.TopHandler" + "flushStdHandles" + promiseRes_id <- + lookupGhcInternalVarId "GHC.Internal.Wasm.Prim.Exports" + $ "js_promiseResolve" + ++ res_ty_str + top_handler_id <- lookupGhcInternalVarId top_handler_mod top_handler_name + let ppr_closure c = ppr c <> text "_closure" + mk_extern_closure_decl c = + text "extern StgClosure" <+> ppr_closure c <> semi + gc_root_closures = maybeToList m_fn_id ++ case sync of + -- In case of C FFI top handlers, they are already declared in + -- RtsAPI.h and registered as GC roots in initBuiltinGcRoots. + -- flushStdHandles is already registered but somehow the C + -- stub can't access its declaration, won't hurt to declare it + -- again here. + Sync -> [finally_id, flushStdHandles_id] + Async -> [top_handler_id, promiseRes_id] + extern_closure_decls = vcat $ map mk_extern_closure_decl $ top_handler_id : gc_root_closures + cstub_attr = + text "__attribute__" + <> parens + (parens $ text "export_name" <> parens (doubleQuotes $ text ext_name)) + cstub_arg_list = + [ text ("Hs" ++ ffiType (scaledThing arg_ty)) <+> char 'a' <> int i + | (i, arg_ty) <- zip [1 ..] arg_tys + ] + cstub_args = case cstub_arg_list of + [] -> text "void" + _ -> hsep $ punctuate comma cstub_arg_list + cstub_proto + | Sync <- sync, + res_ty `eqType` unitTy = + text "void" <+> text ext_name <> parens cstub_args + | Sync <- sync = + text ("Hs" ++ res_ty_str) <+> text ext_name <> parens cstub_args + | Async <- sync = + text "HsJSVal" <+> text ext_name <> parens cstub_args + c_closure c = char '&' <> ppr_closure c + c_call fn args = text fn <> parens (hsep $ punctuate comma args) + c_rts_apply = + Data.List.foldl1' $ \fn arg -> c_call "rts_apply" [text "cap", fn, arg] + apply_top_handler expr = case sync of + Sync -> + c_rts_apply + [ c_closure finally_id, + c_rts_apply [c_closure top_handler_id, expr], + c_closure flushStdHandles_id + ] + Async -> + c_rts_apply [c_closure top_handler_id, c_closure promiseRes_id, expr] + cstub_ret + | Sync <- sync, res_ty `eqType` unitTy = empty + | Sync <- sync = text $ "return rts_get" ++ res_ty_str ++ "(ret);" + | Async <- sync = text "return rts_getJSVal(ret);" + (cstub_target, real_args) + | Just fn_id <- m_fn_id = (c_closure fn_id, zip [1 ..] arg_tys) + | otherwise = (text "(HaskellObj)deRefStablePtr(a1)", zip [2 ..] $ tail arg_tys) + cstub_body = + vcat + [ lbrace, + text "Capability *cap = rts_lock();", + text "HaskellObj ret;", + c_call + "rts_inCall" + [ text "&cap", + apply_top_handler + $ c_rts_apply + $ cstub_target + : [ c_call + ("rts_mk" ++ ffiType (scaledThing arg_ty)) + [text "cap", char 'a' <> int i] + | (i, arg_ty) <- real_args + ], + text "&ret" + ] + <> semi, + c_call "rts_checkSchedStatus" [doubleQuotes (text ext_name), text "cap"] + <> semi, + text "rts_unlock(cap);", + cstub_ret, + rbrace + ] + cstub = + commonCDecls + $+$ extern_closure_decls + $+$ cstub_attr + $+$ cstub_proto + $+$ cstub_body + pure (CHeader commonCDecls, CStub cstub [] [], "", gc_root_closures, []) + +lookupGhcInternalVarId :: FastString -> String -> DsM Id +lookupGhcInternalVarId m v = do + n <- lookupOrig (mkGhcInternalModule m) (mkVarOcc v) + dsLookupGlobalId n + +lookupGhcInternalTyCon :: FastString -> String -> DsM TyCon +lookupGhcInternalTyCon m t = do + n <- lookupOrig (mkGhcInternalModule m) (mkTcOcc t) + dsLookupTyCon n + +ffiType :: Type -> String +ffiType = occNameString . getOccName . fst . splitTyConApp + +commonCDecls :: SDoc +commonCDecls = + vcat + [ text "typedef __externref_t HsJSVal;", + text "HsJSVal rts_getJSVal(HaskellObj);", + text "HaskellObj rts_mkJSVal(Capability*, HsJSVal);" + ] diff --git a/GHC/HsToCore/GuardedRHSs.hs b/GHC/HsToCore/GuardedRHSs.hs --- a/GHC/HsToCore/GuardedRHSs.hs +++ b/GHC/HsToCore/GuardedRHSs.hs @@ -24,14 +24,12 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.Core.Type ( Type ) -import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Core.Multiplicity -import Control.Monad ( zipWithM ) -import Data.List.NonEmpty ( NonEmpty, toList ) +import Data.List.NonEmpty ( NonEmpty ) +import qualified GHC.Data.List.NonEmpty as NE {- @dsGuarded@ is used for GRHSs. @@ -55,7 +53,7 @@ -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. -dsGRHSs :: HsMatchContext GhcTc +dsGRHSs :: HsMatchContextRn -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs -> Type -- ^ Type of RHS -> NonEmpty Nablas -- ^ Refined pattern match checking @@ -63,9 +61,8 @@ -- one for each GRHS. -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas - = assert (notNull grhss) $ - do { match_results <- assert (length grhss == length rhss_nablas) $ - zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss + = do { match_results <- assert (length grhss == length rhss_nablas) $ + NE.zipWithM (dsGRHS hs_ctx rhs_ty) rhss_nablas grhss ; nablas <- getPmNablas -- We need to remember the Nablas from the particular match context we -- are in, which might be different to when dsLocalBinds is actually @@ -76,10 +73,11 @@ -- NB: nested dsLet inside matchResult ; return match_result2 } -dsGRHS :: HsMatchContext GhcTc -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) +dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs)) - = matchGuards (map unLoc guards) hs_ctx rhs_nablas rhs rhs_ty + = updPmNablas rhs_nablas $ + matchGuards (map unLoc guards) hs_ctx rhs rhs_ty {- ************************************************************************ @@ -90,8 +88,7 @@ -} matchGuards :: [GuardStmt GhcTc] -- Guard - -> HsMatchContext GhcTc -- Context - -> Nablas -- The RHS's covered set for PmCheck + -> HsMatchContextRn -- Context -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard -> DsM (MatchResult CoreExpr) @@ -99,8 +96,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 [] _ nablas rhs _ - = do { core_rhs <- updPmNablas nablas (dsLExpr rhs) +matchGuards [] _ rhs _ + = do { core_rhs <- dsLExpr rhs ; return (cantFailMatchResult core_rhs) } -- BodyStmts must be guards @@ -110,42 +107,50 @@ -- 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 nablas rhs rhs_ty +matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do - match_result <- matchGuards stmts ctx nablas rhs rhs_ty + match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result) -matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do - match_result <- matchGuards stmts ctx nablas rhs rhs_ty +matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do + match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr 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) +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) -- 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 nablas rhs rhs_ty = do +matchGuards (BindStmt _ pat bind_rhs : stmts) ctx 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 nablas rhs rhs_ty + match_result <- matchGuards stmts ctx 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" {- diff --git a/GHC/HsToCore/ListComp.hs b/GHC/HsToCore/ListComp.hs --- a/GHC/HsToCore/ListComp.hs +++ b/GHC/HsToCore/ListComp.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {- @@ -33,10 +33,11 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth ) +import Data.Foldable ( toList ) + {- List comprehensions may be desugared in one of two ways: ``ordinary'' (as you would expect if you read SLPJ's book) and ``with foldr/build @@ -244,13 +245,13 @@ = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs ; let (exps, qual_tys) = unzip exps_and_qual_tys - ; (zip_fn, zip_rhs) <- mkZipBind qual_tys + ; (zip_fn, zip_rhs) <- mkZipBind (toList qual_tys) -- Deal with [e | pat <- zip l1 .. ln] in example above - ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) (toList exps))) quals list } where - bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs] + bndrs_s = [bs | ParStmtBlock _ _ bs _ <- toList stmtss_w_bndrs] -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above pat = mkBigLHsPatTupId pats @@ -258,7 +259,7 @@ deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" -deListComp (ApplicativeStmt {} : _) _ = +deListComp (XStmtLR ApplicativeStmt {} : _) _ = panic "deListComp ApplicativeStmt" deBindComp :: LPat GhcTc @@ -285,7 +286,7 @@ letrec_body = App (Var h) core_list1 rest_expr <- deListComp quals core_fail - core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail + core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) ManyTy pat rest_expr core_fail let rhs = Lam u1 $ @@ -353,7 +354,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' @@ -366,14 +367,14 @@ 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 -- build the pattern match - core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp)) + core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp)) ManyTy pat core_rest (Var b) -- now build the outermost foldr, and return @@ -397,11 +398,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') @@ -436,13 +437,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)) @@ -542,7 +543,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' @@ -564,8 +565,11 @@ = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty) ; mzip_op' <- dsExpr mzip_op - ; let -- The pattern variables - pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks] + ; let parStmtBlockIds :: ParStmtBlock GhcTc GhcTc -> [Id] + parStmtBlockIds = \ case + ParStmtBlock _ _ bs _ -> bs + -- The pattern variables + pats = fmap (mkBigLHsVarPatTupId . parStmtBlockIds) blocks -- Pattern with tuples of variables -- [v1,v2,v3] => (v1, (v2, v3)) pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats @@ -581,7 +585,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 @@ -589,7 +593,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) } @@ -609,7 +613,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 @@ -647,9 +651,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) diff --git a/GHC/HsToCore/Match.hs b/GHC/HsToCore/Match.hs --- a/GHC/HsToCore/Match.hs +++ b/GHC/HsToCore/Match.hs @@ -25,18 +25,22 @@ import GHC.Prelude import GHC.Platform -import Language.Haskell.Syntax.Basic (Boxity(..)) - import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated, requiresPMC ) +import GHC.Types.Basic + import GHC.Types.SourceText + ( FractionalLit, + IntegralLit(il_value), + negateFractionalLit, + integralFractionalLit ) import GHC.Driver.DynFlags import GHC.Hs import GHC.Hs.Syn.Type import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc +import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.HsToCore.Monad import GHC.HsToCore.Binds @@ -68,14 +72,13 @@ import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM import Control.Monad ( zipWithM, unless ) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map {- @@ -191,15 +194,9 @@ -> [EquationInfo] -- ^ Info about patterns, etc. (type synonym below) -> DsM (MatchResult CoreExpr) -- ^ Desugared result! -match [] ty eqns - = assertPpr (not (null eqns)) (ppr ty) $ - return (foldr1 combineMatchResults match_results) - where - match_results = [ assert (null (eqn_pats eqn)) $ - eqn_rhs eqn - | eqn <- eqns ] +match [] ty eqns = maybe (assertPprPanic (ppr ty)) combineEqnRhss $ nonEmpty eqns -match (v:vs) ty eqns -- Eqns *can* be empty +match (v:vs) ty eqns -- Eqns can be empty, but each equation is nonempty = assertPpr (all (isInternalName . idName) vars) (ppr vars) $ do { dflags <- getDynFlags ; let platform = targetPlatform dflags @@ -222,12 +219,11 @@ dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo dropGroup = fmap snd - match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr)) - -- Result list of [MatchResult CoreExpr] is always non-empty + match_groups :: [NonEmpty (PatGroup,EquationInfoNE)] -> DsM (NonEmpty (MatchResult CoreExpr)) match_groups [] = matchEmpty v ty match_groups (g:gs) = mapM match_group $ g :| gs - match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr) + match_group :: NonEmpty (PatGroup,EquationInfoNE) -> DsM (MatchResult CoreExpr) match_group eqns@((group,_) :| _) = case group of PgCon {} -> matchConFamily vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns']) @@ -240,8 +236,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" @@ -267,32 +263,32 @@ mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty [Alt DEFAULT [] fail] -matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +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 EquationInfo -> DsM (MatchResult CoreExpr) +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) } -matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) -- Apply the coercion to the match variable and then match that -matchCoercion (var :| vars) ty (eqns@(eqn1 :| _)) +matchCoercion (var :| vars) ty eqns@(eqn1 :| _) = 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)) ; return (mkCoLetMatchResult bind match_result) } } -matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) -- Apply the view function to the match variable and then match that -matchView (var :| vars) ty (eqns@(eqn1 :| _)) +matchView (var :| vars) ty eqns@(eqn1 :| _) = do { -- we could pass in the expr from the PgView, -- but this needs to extract the pat anyway -- to figure out the type of the fresh variable @@ -300,19 +296,18 @@ -- 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 ; return (mkViewMatchResult var' - (mkCoreAppDs (text "matchView") viewExpr' (Var var)) + (mkCoreApp (text "matchView") viewExpr' (Var var)) match_result) } -- decompose the first pattern and leave the rest alone -decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo -decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats })) - = eqn { eqn_pats = extractpat pat : pats} -decomposeFirstPat _ _ = panic "decomposeFirstPat" +decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfoNE -> EquationInfoNE +decomposeFirstPat extract eqn@(EqnMatch { eqn_pat = pat }) = eqn{eqn_pat = fmap extract pat} +decomposeFirstPat _ (EqnDone {}) = panic "decomposeFirstPat" getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc getCoPat (XPat (CoPat _ pat _)) = pat @@ -405,15 +400,14 @@ -- POST CONDITION: head pattern in the EqnInfo is -- one of these for which patGroup is defined. -tidyEqnInfo _ (EqnInfo { eqn_pats = [] }) - = panic "tidyEqnInfo" +tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn) -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig }) - = do { (wrap, pat') <- tidy1 v orig pat - ; return (wrap, eqn { eqn_pats = pat' : pats }) } +tidyEqnInfo v eqn@(EqnMatch { eqn_pat = (L loc pat) }) = do + (wrap, pat') <- tidy1 v (not . isGoodSrcSpan . locA $ loc) pat + return (wrap, eqn{eqn_pat = L loc pat' }) tidy1 :: Id -- The Id being scrutinised - -> Origin -- Was this a pattern the user wrote? + -> Bool -- `True` if the pattern was generated, `False` if it was user-written -> Pat GhcTc -- The pattern against which it is to be matched -> DsM (DsWrapper, -- Extra bindings to do before the match Pat GhcTc) -- Equivalent pattern @@ -424,10 +418,10 @@ -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v o (ParPat _ _ pat _) = tidy1 v o (unLoc pat) -tidy1 v o (SigPat _ pat _) = tidy1 v o (unLoc pat) +tidy1 v g (ParPat _ pat) = tidy1 v g (unLoc pat) +tidy1 v g (SigPat _ pat _) = tidy1 v g (unLoc pat) tidy1 _ _ (WildPat ty) = return (idDsWrapper, WildPat ty) -tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p +tidy1 v g (BangPat _ (L l p)) = tidy_bang_pat v g l p -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } @@ -436,8 +430,8 @@ -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (L _ var) _ pat) - = do { (wrap, pat') <- tidy1 v o (unLoc pat) +tidy1 v g (AsPat _ (L _ var) pat) + = do { (wrap, pat') <- tidy1 v g (unLoc pat) ; return (wrapBind var v . wrap, pat') } {- now, here we handle lazy patterns: @@ -455,13 +449,13 @@ -- This is a convenient place to check for unlifted types under a lazy pattern. -- Doing this check during type-checking is unsatisfactory because we may -- not fully know the zonked types yet. We sure do here. - = do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) + = putSrcSpanDs (getLocA pat) $ + do { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat) -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType ; unless (null unlifted_bndrs) $ - putSrcSpanDs (getLocA pat) $ diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) - ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v) + ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v) ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs] ; return (mkCoreLets sel_binds, WildPat (idType v)) } @@ -489,53 +483,83 @@ -- See Note [Unboxed tuple RuntimeRep vars] in TyCon -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (LitPat _ lit) - = do { unless (isGenerated o) $ +tidy1 _ g (LitPat _ lit) + = do { unless g $ warnAboutOverflowedLit lit ; return (idDsWrapper, tidyLitPat lit) } -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) - = do { unless (isGenerated o) $ +tidy1 _ g (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq) + = do { unless g $ let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v } | otherwise = lit in warnAboutOverflowedOverLit lit' ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) } -- NPlusKPat: we may want to warn about the literals -tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) - = do { unless (isGenerated o) $ do +tidy1 _ g n@(NPlusKPat _ _ (L _ lit1) lit2 _ _) + = do { unless g $ do warnAboutOverflowedOverLit lit1 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 $ mkHsVar (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) -------------------- -tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc +tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc) -- Discard par/sig under a bang -tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p -tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p +tidy_bang_pat v g _ (ParPat _ (L l p)) = tidy_bang_pat v g l p +tidy_bang_pat v g _ (SigPat _ (L l p) _) = tidy_bang_pat v g l p -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v o l (AsPat x v' at p) - = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p))) -tidy_bang_pat v o l (XPat (CoPat w p t)) - = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t) +tidy_bang_pat v g l (AsPat x v' p) + = 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 o _ p@(LitPat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(ListPat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(TuplePat {}) = tidy1 v o p -tidy_bang_pat v o _ p@(SumPat {}) = tidy1 v o p +tidy_bang_pat v g _ p@(LitPat {}) = tidy1 v g p +tidy_bang_pat v g _ p@(ListPat {}) = tidy1 v g p +tidy_bang_pat v g _ p@(TuplePat {}) = tidy1 v g p +tidy_bang_pat v g _ p@(SumPat {}) = tidy1 v g p -- Data/newtype constructors -tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc) +tidy_bang_pat v g l p@(ConPat { pat_con = L _ (RealDataCon dc) , pat_args = args , pat_con_ext = ConPatTc { cpt_arg_tys = arg_tys @@ -544,8 +568,8 @@ -- Newtypes: push bang inwards (#9844) = if isNewTyCon (dataConTyCon dc) - then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) - else tidy1 v o p -- Data types: discard the bang + then tidy1 v g (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args }) + else tidy1 v g p -- Data types: discard the bang where (ty:_) = dataConInstArgTys dc arg_tys @@ -573,9 +597,9 @@ -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- See Note [Bang patterns and newtypes] -- We are transforming !(N p) into (N !p) -push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args)) +push_bang_into_newtype_arg l _ty (PrefixCon (arg:args)) = assert (null args) $ - PrefixCon ts [L l (BangPat noExtField arg)] + PrefixCon [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf) | HsRecFields { rec_flds = L lf fld : flds } <- rf , HsFieldBind { hfbRHS = arg } <- fld @@ -584,7 +608,7 @@ = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {}) | HsRecFields { rec_flds = [] } <- rf - = PrefixCon [] [L l (BangPat noExtField (noLocA (WildPat ty)))] + = PrefixCon [L l (BangPat noExtField (noLocA (WildPat ty)))] push_bang_into_newtype_arg _ _ cd = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -737,7 +761,7 @@ -- p2 q2 -> ... matchWrapper - :: HsMatchContext GhcTc -- ^ For shadowing warning messages + :: HsMatchContextRn -- ^ For shadowing warning messages -> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s) -- see Note [matchWrapper scrutinees] -> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared @@ -772,11 +796,10 @@ }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs - ; new_vars <- case matches of [] -> newSysLocalsDs arg_tys (m:_) -> - selectMatchVars (zipWithEqual "matchWrapper" + selectMatchVars (zipWithEqual (\a b -> (scaledMult a, unLoc b)) arg_tys (hsLMatchPats m)) @@ -784,12 +807,19 @@ -- Pattern match check warnings for /this match-group/. -- @rhss_nablas@ is a flat list of covered Nablas for each RHS. -- Each Match will split off one Nablas for its RHSs from this. + ; tracePm "matchWrapper" + (vcat [ ppr ctxt + , text "scrs" <+> ppr scrs + , text "matches group" <+> ppr matches + , text "matchPmChecked" <+> ppr (isMatchContextPmChecked dflags origin ctxt)]) ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt + -- See Note [Expanding HsDo with XXExprGhcRn] Part 1. Wrinkle 1 for + -- pmc for pattern synonyms -- See Note [Long-distance information] in GHC.HsToCore.Pmc then addHsScrutTmCs (concat scrs) new_vars $ - pmcMatches (DsMatchContext ctxt locn) new_vars matches + pmcMatches origin (DsMatchContext ctxt locn) new_vars matches -- When we're not doing PM checks on the match group, -- we still need to propagate long-distance information. @@ -806,18 +836,16 @@ 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 (unLoc . decideBangHood dflags) pats + ; let upats = map (decideBangHood dflags) pats -- pat_nablas is the covered set *after* matching the pattern, but -- before any of the GRHSs. We extend the environment with pat_nablas -- (via updPmNablas) so that the where-clause of 'grhss' can profit -- from that knowledge (#18533) ; match_result <- updPmNablas pat_nablas $ dsGRHSs ctxt grhss rhs_ty rhss_nablas - ; return EqnInfo { eqn_pats = upats - , eqn_orig = FromSource - , eqn_rhs = match_result } } + ; return $ mkEqnInfo upats match_result } discard_warnings_if_skip_pmc orig = if requiresPMC orig @@ -829,10 +857,7 @@ = map (\(L _ m) -> (ldi_nablas, initNablasGRHSs ldi_nablas (m_grhss m))) ms initNablasGRHSs :: Nablas -> GRHSs GhcTc b -> NonEmpty Nablas - initNablasGRHSs ldi_nablas m - = expectJust "GRHSs non-empty" - $ NEL.nonEmpty - $ replicate (length (grhssGRHSs m)) ldi_nablas + initNablasGRHSs ldi_nablas m = ldi_nablas <$ grhssGRHSs m {- Note [Long-distance information in matchWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -881,7 +906,7 @@ on the user-written case statement). -} -matchEquations :: HsMatchContext GhcTc +matchEquations :: HsMatchContextRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty @@ -895,7 +920,8 @@ -- situation where we want to match a single expression against a single -- pattern. It returns an expression. matchSimply :: CoreExpr -- ^ Scrutinee - -> HsMatchContext GhcTc -- ^ Match kind + -> HsMatchContextRn -- ^ Match kind + -> Mult -- ^ Scaling factor of the case expression -> LPat GhcTc -- ^ Pattern it should match -> CoreExpr -- ^ Return this if it matches -> CoreExpr -- ^ Return this if it doesn't @@ -909,15 +935,15 @@ -- match is awkward -- * And we still export 'matchSinglePatVar', so not much is gained if we -- don't also implement it in terms of 'matchWrapper' -matchSimply scrut hs_ctx pat result_expr fail_expr = do +matchSimply scrut hs_ctx mult pat result_expr fail_expr = do let match_result = cantFailMatchResult result_expr rhs_ty = exprType fail_expr -- Use exprType of fail_expr, because won't refine in the case of failure! - match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result + match_result' <- matchSinglePat scrut hs_ctx pat mult rhs_ty match_result extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext GhcTc -> LPat GhcTc +matchSinglePat :: CoreExpr -> HsMatchContextRn -> LPat GhcTc -> Mult -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar @@ -926,24 +952,19 @@ -- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine -matchSinglePat (Var var) ctx pat ty match_result +matchSinglePat (Var var) ctx pat _ ty match_result | not (isExternalName (idName var)) = matchSinglePatVar var Nothing ctx pat ty match_result -matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL ManyTy pat - -- matchSinglePat is only used in matchSimply, which - -- is used in list comprehension, arrow notation, - -- and to create field selectors. All of which only - -- bind unrestricted variables, hence the 'Many' - -- above. +matchSinglePat scrut hs_ctx pat mult ty match_result + = do { var <- selectSimpleMatchVarL mult pat ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result ; return $ bindNonRec var scrut <$> match_result' } matchSinglePatVar :: Id -- See Note [Match Ids] -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to - -> HsMatchContext GhcTc -> LPat GhcTc + -> HsMatchContextRn -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) matchSinglePatVar var mb_scrut ctx pat ty match_result = assertPpr (isInternalName (idName var)) (ppr var) $ @@ -958,10 +979,9 @@ pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) else getLdiNablas - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] - , eqn_orig = FromSource - , eqn_rhs = - updPmNablasMatchResult ldi_nablas match_result } + ; let eqn_info = EqnMatch { eqn_pat = decideBangHood dflags pat + , eqn_rest = + EqnDone $ updPmNablasMatchResult ldi_nablas match_result } -- See Note [Long-distance information in do notation] -- in GHC.HsToCore.Expr. @@ -999,6 +1019,13 @@ -- the LHsExpr is the expression e Type -- the Type is the type of p (equivalently, the result type of e) +instance Show PatGroup where + show PgAny = "PgAny" + show (PgCon _) = "PgCon" + show (PgLit _) = "PgLit" + show (PgView _ _) = "PgView" + show _ = "PgOther" + {- Note [Don't use Literal for PgN] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Previously we had, as PatGroup constructors @@ -1019,13 +1046,13 @@ for overloaded strings. -} -groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)] +groupEquations :: Platform -> [EquationInfoNE] -> [NonEmpty (PatGroup, EquationInfoNE)] -- If the result is of form [g1, g2, g3], -- (a) all the (pg,eq) pairs in g1 have the same pg -- (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 @@ -1044,11 +1071,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 @@ -1139,14 +1166,16 @@ exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool -- real comparison is on HsExpr's -- strip parens - exp (HsPar _ _ (L _ e) _) e' = exp e e' - exp e (HsPar _ _ (L _ e') _) = exp e e' + exp (HsPar _ (L _ e)) e' = exp e e' + exp e (HsPar _ (L _ e')) = exp e e' -- because the expressions do not necessarily have the same type, -- we have to compare the wrappers - exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap h' e'))) = + exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) = wrap h h' && exp e e' - exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) = - exp b b' + exp (XExpr (ExpandedThingTc o x)) (XExpr (ExpandedThingTc o' x')) + | isHsThingRnExpr o + , isHsThingRnExpr o' + = exp x x' exp (HsVar _ i) (HsVar _ i') = i == i' exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c' -- the instance for IPName derives using the id, so this works if the @@ -1163,8 +1192,8 @@ exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? - exp (OpApp _ l o ri) (OpApp _ l' o' ri') = - lexp l l' && lexp o o' && lexp ri ri' + exp (OpApp _ l g ri) (OpApp _ l' o' ri') = + lexp l l' && lexp g o' && lexp ri ri' exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n' exp (SectionL _ e1 e2) (SectionL _ e1' e2') = lexp e1 e1' && lexp e2 e2' @@ -1191,7 +1220,7 @@ , syn_arg_wraps = arg_wraps2 , syn_res_wrap = res_wrap2 }) = exp expr1 expr2 && - and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) && + and (zipWithEqual wrap arg_wraps1 arg_wraps2) && wrap res_wrap1 res_wrap2 syn_exp NoSyntaxExprTc NoSyntaxExprTc = True syn_exp _ _ = False @@ -1265,6 +1294,7 @@ _ -> pprPanic "patGroup NPlusKPat" (ppr oval) patGroup _ (ViewPat _ expr p) = PgView expr (hsPatType (unLoc p)) patGroup platform (LitPat _ lit) = PgLit (hsLitKey platform lit) +patGroup _ EmbTyPat{} = PgAny patGroup platform (XPat ext) = case ext of CoPat _ p _ -> PgCo (hsPatType p) -- Type of innelexp pattern ExpansionPat _ p -> patGroup platform p diff --git a/GHC/HsToCore/Match.hs-boot b/GHC/HsToCore/Match.hs-boot --- a/GHC/HsToCore/Match.hs-boot +++ b/GHC/HsToCore/Match.hs-boot @@ -5,7 +5,8 @@ import GHC.Tc.Utils.TcType ( Type ) import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr ) -import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr ) +import GHC.Hs ( LPat, MatchGroup, LHsExpr, Mult ) +import GHC.Hs.Expr ( HsMatchContextRn ) import GHC.Hs.Extension ( GhcTc ) match :: [Id] @@ -14,14 +15,15 @@ -> DsM (MatchResult CoreExpr) matchWrapper - :: HsMatchContext GhcTc + :: HsMatchContextRn -> Maybe [LHsExpr GhcTc] -> MatchGroup GhcTc (LHsExpr GhcTc) -> DsM ([Id], CoreExpr) matchSimply :: CoreExpr - -> HsMatchContext GhcTc + -> HsMatchContextRn + -> Mult -> LPat GhcTc -> CoreExpr -> CoreExpr @@ -30,7 +32,7 @@ matchSinglePatVar :: Id -> Maybe CoreExpr - -> HsMatchContext GhcTc + -> HsMatchContextRn -> LPat GhcTc -> Type -> MatchResult CoreExpr diff --git a/GHC/HsToCore/Match/Constructor.hs b/GHC/HsToCore/Match/Constructor.hs --- a/GHC/HsToCore/Match/Constructor.hs +++ b/GHC/HsToCore/Match/Constructor.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-} {- (c) The University of Glasgow 2006 @@ -20,7 +21,6 @@ import GHC.Hs import GHC.HsToCore.Binds import GHC.Core.ConLike -import GHC.Types.Basic import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity import GHC.HsToCore.Monad @@ -34,7 +34,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad(liftM) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE @@ -94,7 +93,7 @@ matchConFamily :: NonEmpty Id -> Type - -> NonEmpty (NonEmpty EquationInfo) + -> NonEmpty (NonEmpty EquationInfoNE) -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily (var :| vars) ty groups @@ -113,7 +112,7 @@ matchPatSyn :: NonEmpty Id -> Type - -> NonEmpty EquationInfo + -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns = do let mult = idMult var @@ -129,7 +128,7 @@ matchOneConLike :: [Id] -> Type -> Mult - -> NonEmpty EquationInfo + -> NonEmpty EquationInfoNE -> DsM (CaseAlt ConLike) matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single constructor = do { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $ @@ -143,7 +142,7 @@ -- and returns the types of the *value* args, which is what we want match_group :: [Id] - -> NonEmpty (ConArgPats, EquationInfo) + -> NonEmpty (ConArgPats, EquationInfoNE) -> DsM (MatchResult CoreExpr) -- All members of the group have compatible ConArgPats match_group arg_vars arg_eqn_prs @@ -153,24 +152,21 @@ ; return $ foldr1 (.) wraps <$> match_result } - shift (_, eqn@(EqnInfo - { eqn_pats = ConPat - { pat_args = args - , pat_con_ext = ConPatTc - { cpt_tvs = tvs - , cpt_dicts = ds - , cpt_binds = bind - } - } : pats - })) + shift (_, EqnMatch { + eqn_pat = L _ (ConPat + { pat_args = args + , pat_con_ext = ConPatTc + { cpt_tvs = tvs + , cpt_dicts = ds + , cpt_binds = bind }}) + , eqn_rest = rest }) = do dsTcEvBinds bind $ \ds_bind -> return ( wrapBinds (tvs `zip` tvs1) . wrapBinds (ds `zip` dicts1) . mkCoreLets ds_bind - , eqn { eqn_orig = Generated SkipPmc - , eqn_pats = conArgPats val_arg_tys args ++ pats } + , prependPats (conArgPats val_arg_tys args) rest ) - shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) + shift (_, eqn) = pprPanic "matchOneCon/shift" (ppr eqn) ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys -- The 'val_arg_tys' are taken from the data type definition, they -- do not take into account the context multiplicity, therefore we @@ -184,9 +180,9 @@ -- suggestions for the new variables -- Divide into sub-groups; see Note [Record patterns] - ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo)) + ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfoNE)) groups = NE.groupBy1 compatible_pats - $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns) + $ fmap (\eqn -> (con_pat_args (firstPat eqn), eqn)) (eqn1 :| eqns) ; match_results <- mapM (match_group arg_vars) groups @@ -195,6 +191,10 @@ alt_wrapper = wrapper1, alt_result = foldr1 combineMatchResults match_results } } where + con_pat_args :: Pat GhcTc -> HsConPatDetails GhcTc + con_pat_args (ConPat { pat_args = args }) = args + con_pat_args p = pprPanic "matchOneConLike" (ppr p) -- All patterns are ConPats + ConPat { pat_con = L _ con1 , pat_args = args1 , pat_con_ext = ConPatTc @@ -221,7 +221,7 @@ | otherwise = arg_vars where - fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars + fld_var_env = mkNameEnv $ zipEqual fields1 arg_vars lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env (idName (hsRecFieldId rpat)) @@ -247,23 +247,23 @@ selectConMatchVars arg_tys con = case con of RecCon {} -> newSysLocalsDs arg_tys - PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps) + PrefixCon ps -> selectMatchVars (zipMults arg_tys ps) InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2]) where - zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b)) + zipMults = zipWithEqual (\a b -> (scaledMult a, unLoc b)) conArgPats :: [Scaled Type]-- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway -> ConArgPats - -> [Pat GhcTc] -conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps -conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] + -> [LPat GhcTc] +conArgPats _arg_tys (PrefixCon ps) = ps +conArgPats _arg_tys (InfixCon p1 p2) = [p1, p2] conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats })) - | null rpats = map WildPat (map scaledThing arg_tys) + | null rpats = map (noLocA . WildPat . scaledThing) arg_tys -- Important special case for C {}, which can be used for a -- datacon that isn't declared to have fields at all - | otherwise = map (unLoc . hfbRHS . unLoc) rpats + | otherwise = map (hfbRHS . unLoc) rpats {- Note [Record patterns] diff --git a/GHC/HsToCore/Match/Literal.hs b/GHC/HsToCore/Match/Literal.hs --- a/GHC/HsToCore/Match/Literal.hs +++ b/GHC/HsToCore/Match/Literal.hs @@ -18,7 +18,7 @@ ( dsLit, dsOverLit, hsLitKey , tidyLitPat, tidyNPat , matchLiterals, matchNPlusKPats, matchNPats - , warnAboutIdentities + , numericConversionNames , warnAboutOverflowedOverLit, warnAboutOverflowedLit , warnAboutEmptyEnumerations ) @@ -61,17 +61,15 @@ import GHC.Driver.DynFlags import GHC.Utils.Outputable as Outputable -import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Unique (sameUnique) import GHC.Data.FastString +import qualified GHC.Data.List.NonEmpty as NEL import Control.Monad import Data.Int import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL import Data.Word import GHC.Real ( Ratio(..), numerator, denominator ) @@ -98,7 +96,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. -} -dsLit :: HsLit GhcRn -> DsM CoreExpr +dsLit :: forall p. IsPass p => HsLit (GhcPass p) -> DsM CoreExpr dsLit l = do dflags <- getDynFlags let platform = targetPlatform dflags @@ -122,9 +120,12 @@ HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl))) HsChar _ c -> return (mkCharExpr c) HsString _ str -> mkStringExprFS str - HsInteger _ i _ -> return (mkIntegerExpr platform i) + HsMultilineString _ str -> mkStringExprFS str HsInt _ i -> return (mkIntExpr platform (il_value i)) - HsRat _ fl ty -> dsFractionalLitToRational fl ty + XLit x -> case ghcPass @p of + GhcTc -> case x of + HsInteger _ i _ -> return (mkIntegerExpr platform i) + HsRat fl ty -> dsFractionalLitToRational fl ty {- Note [FractionalLit representation] @@ -275,23 +276,13 @@ same. Then it's probably (albeit not definitely) the identity -} -warnAboutIdentities :: DynFlags -> Id -> Type -> DsM () -warnAboutIdentities dflags conv_fn type_of_conv - | wopt Opt_WarnIdentities dflags - , idName conv_fn `elem` conversionNames - , Just (_, _, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv - , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv) -warnAboutIdentities _ _ _ = return () - -conversionNames :: [Name] -conversionNames +numericConversionNames :: [Name] +numericConversionNames = [ toIntegerName, toRationalName , fromIntegralName, realToFracName ] -- We can't easily add fromIntegerName, fromRationalName, -- because they are generated by literals - -- | Emit warnings on overloaded integral literals which overflow the bounds -- implied by their type. warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM () @@ -438,7 +429,7 @@ -- ^ See if the expression is an 'Integral' literal. getLHsIntegralLit (L _ e) = go e where - go (HsPar _ _ e _) = getLHsIntegralLit e + go (HsPar _ e) = getLHsIntegralLit e go (HsOverLit _ over_lit) = getIntegralLit over_lit go (HsLit _ lit) = getSimpleIntegralLit lit @@ -447,7 +438,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. @@ -460,29 +451,30 @@ -- | If 'Integral', extract the value and type of the non-overloaded literal. getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type) getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy) -getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy) -getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy) -getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy) -getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy) -getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy) -getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy) -getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy) -getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy) -getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy) -getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) -getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) +getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTy) +getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTy) +getSimpleIntegralLit (HsInt8Prim _ i) = Just (i, int8PrimTy) +getSimpleIntegralLit (HsInt16Prim _ i) = Just (i, int16PrimTy) +getSimpleIntegralLit (HsInt32Prim _ i) = Just (i, int32PrimTy) +getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTy) +getSimpleIntegralLit (HsWord8Prim _ i) = Just (i, word8PrimTy) +getSimpleIntegralLit (HsWord16Prim _ i) = Just (i, word16PrimTy) +getSimpleIntegralLit (HsWord32Prim _ i) = Just (i, word32PrimTy) +getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) +getSimpleIntegralLit (XLit (HsInteger _ i ty)) = Just (i, ty) getSimpleIntegralLit HsChar{} = Nothing getSimpleIntegralLit HsCharPrim{} = Nothing getSimpleIntegralLit HsString{} = Nothing +getSimpleIntegralLit HsMultilineString{} = Nothing getSimpleIntegralLit HsStringPrim{} = Nothing -getSimpleIntegralLit HsRat{} = Nothing +getSimpleIntegralLit (XLit (HsRat{})) = Nothing getSimpleIntegralLit HsFloatPrim{} = Nothing getSimpleIntegralLit HsDoublePrim{} = Nothing -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char -getLHsCharLit (L _ (HsPar _ _ e _)) = getLHsCharLit e +getLHsCharLit (L _ (HsPar _ e)) = getLHsCharLit e getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c getLHsCharLit (L _ (XExpr (HsTick _ e))) = getLHsCharLit e getLHsCharLit (L _ (XExpr (HsBinTick _ _ e))) = getLHsCharLit e @@ -607,7 +599,7 @@ matchLiterals :: NonEmpty Id -> Type -- ^ Type of the whole case expression - -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits + -> NonEmpty (NonEmpty EquationInfoNE) -- ^ All PgLits -> DsM (MatchResult CoreExpr) matchLiterals (var :| vars) ty sub_groups @@ -625,11 +617,11 @@ return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts) } where - match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr) - match_group eqns@(firstEqn :| _) + match_group :: NonEmpty EquationInfoNE -> DsM (Literal, MatchResult CoreExpr) + match_group eqns = do { dflags <- getDynFlags ; let platform = targetPlatform dflags - ; let LitPat _ hs_lit = firstPat firstEqn + ; let EqnMatch { eqn_pat = L _ (LitPat _ hs_lit) } = NEL.head eqns ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns) ; return (hsLitKey platform hs_lit, match_result) } @@ -682,7 +674,7 @@ ************************************************************************ -} -matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) matchNPats (var :| vars) ty (eqn1 :| eqns) -- All for the same literal = do { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1 ; lit_expr <- dsOverLit lit @@ -711,7 +703,7 @@ \end{verbatim} -} -matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) -- All NPlusKPats, for the *same* literal k matchNPlusKPats (var :| vars) ty (eqn1 :| eqns) = do { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus @@ -720,14 +712,14 @@ ; lit2_expr <- dsOverLit lit2 ; pred_expr <- dsSyntaxExpr ge [Var var, lit1_expr] ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr] - ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) - ; match_result <- match vars ty eqns' + ; let (wraps, eqns') = NEL.mapAndUnzip (shift n1) (eqn1:|eqns) + ; match_result <- match vars ty (NEL.toList eqns') ; return (mkGuardedMatchResult pred_expr $ mkCoLetMatchResult (NonRec n1 minusk_expr) $ fmap (foldr1 (.) wraps) $ match_result) } where - shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats }) - = (wrapBind n n1, eqn { eqn_pats = pats }) + shift n1 (EqnMatch { eqn_pat = L _ (NPlusKPat _ (L _ n) _ _ _ _), eqn_rest = rest }) + = (wrapBind n n1, rest) -- The wrapBind is a no-op for the first equation shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e) diff --git a/GHC/HsToCore/Monad.hs b/GHC/HsToCore/Monad.hs --- a/GHC/HsToCore/Monad.hs +++ b/GHC/HsToCore/Monad.hs @@ -19,14 +19,14 @@ 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, UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, + getGhcModeDs, dsGetFamInstEnvs, dsGetGlobalRdrEnv, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, getCCIndexDsM, @@ -37,7 +37,7 @@ getPmNablas, updPmNablas, -- Tracking evidence variable coherence - addUnspecables, getUnspecables, + addUnspecables, getUnspecables, zapUnspecables, -- Get COMPLETE sets of a TyCon dsGetCompleteMatches, @@ -48,7 +48,8 @@ -- Data types DsMatchContext(..), - EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, + EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult, + MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -- Trace injection pprRuntimeTrace @@ -91,10 +92,10 @@ import GHC.Unit.Module.ModGuts import GHC.Types.Name.Reader -import GHC.Types.Basic ( Origin ) import GHC.Types.SourceFile import GHC.Types.Id -import GHC.Types.Var (EvId) +import GHC.Types.Var (EvVar) +import GHC.Types.Var.Set( VarSet, emptyVarSet, extendVarSetList ) import GHC.Types.SrcLoc import GHC.Types.TypeEnv import GHC.Types.Unique.Supply @@ -105,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 @@ -113,7 +118,7 @@ import Data.IORef import GHC.Driver.Env.KnotVars -import qualified Data.Set as S +import GHC.IO.Unsafe (unsafeInterleaveIO) {- ************************************************************************ @@ -124,34 +129,50 @@ -} data DsMatchContext - = DsMatchContext (HsMatchContext GhcTc) SrcSpan + = DsMatchContext HsMatchContextRn SrcSpan deriving () instance Outputable DsMatchContext where ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match data EquationInfo - = EqnInfo { eqn_pats :: [Pat GhcTc] - -- ^ The patterns for an equation - -- - -- NB: We have /already/ applied 'decideBangHood' to - -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils" + = EqnMatch { eqn_pat :: LPat GhcTc + -- ^ The first pattern of the equation + -- + -- NB: The location info is used to determine whether the + -- pattern is generated or not. + -- This helps us avoid warnings on patterns that GHC elaborated. + -- + -- NB: We have /already/ applied 'decideBangHood' to this + -- pattern. See Note [decideBangHood] in "GHC.HsToCore.Utils" - , eqn_orig :: Origin - -- ^ Was this equation present in the user source? - -- - -- This helps us avoid warnings on patterns that GHC elaborated. - -- - -- For instance, the pattern @-1 :: Word@ gets desugared into - -- @W# -1## :: Word@, but we shouldn't warn about an overflowed - -- literal for /both/ of these cases. + , eqn_rest :: EquationInfo } + -- ^ The rest of the equation after its first pattern - , eqn_rhs :: MatchResult CoreExpr - -- ^ What to do after match - } + | EqnDone + -- The empty tail of an equation having no more patterns + (MatchResult CoreExpr) + -- ^ What to do after match +type EquationInfoNE = EquationInfo +-- An EquationInfo which has at least one pattern +-- i.e. it's an EqnMatch, not EqnDone + +prependPats :: [LPat GhcTc] -> EquationInfo -> EquationInfo +prependPats [] eqn = eqn +prependPats (pat:pats) eqn = EqnMatch { eqn_pat = pat, eqn_rest = prependPats pats eqn } + +mkEqnInfo :: [LPat GhcTc] -> MatchResult CoreExpr -> EquationInfo +mkEqnInfo pats = prependPats pats . EqnDone + +eqnMatchResult :: EquationInfo -> MatchResult CoreExpr +eqnMatchResult (EqnDone rhs) = rhs +eqnMatchResult (EqnMatch { eqn_rest = eq }) = eqnMatchResult eq + instance Outputable EquationInfo where - ppr (EqnInfo pats _ _) = ppr pats + ppr = ppr . allEqnPats where + allEqnPats (EqnDone {}) = [] + allEqnPats (EqnMatch { eqn_pat = pat, eqn_rest = eq }) = unLoc pat : allEqnPats eq type DsWrapper = CoreExpr -> CoreExpr idDsWrapper :: DsWrapper @@ -243,15 +264,48 @@ 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 + tcg_comp_env = tcg_complete_match_env tcg_env + + ; ds_complete_matches <- + liftIO $ unsafeInterleaveIO $ + -- Note [Lazily loading COMPLETE pragmas] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- This call to 'unsafeInterleaveIO' ensures we only do this work + -- when we need to look at the COMPLETE pragmas, avoiding doing work + -- when we don't need them. + -- + -- Relevant test case: MultiLayerModulesTH_Make, which regresses + -- in allocations by ~5% if we don't do this. + traverse (lookupCompleteMatch type_env hsc_env) =<< + localAndImportedCompleteMatches tcg_comp_env eps ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc - msg_var cc_st_var next_wrapper_num_var 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 @@ -279,17 +333,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 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 } @@ -307,16 +359,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 @@ -329,7 +381,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 @@ -357,7 +409,7 @@ lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span , dsl_nablas = initNablas - , dsl_unspecables = mempty + , dsl_unspecables = Just emptyVarSet } in (gbl_env, lcl_env) @@ -389,12 +441,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 @@ -413,10 +472,17 @@ updPmNablas :: Nablas -> DsM a -> DsM a updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) -addUnspecables :: S.Set EvId -> DsM a -> DsM a -addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env }) +addUnspecables :: [EvVar] -> DsM a -> DsM a +addUnspecables new_unspecables + = updLclEnv (\env -> case dsl_unspecables env of + Nothing -> env + Just us -> env { dsl_unspecables + = Just (us `extendVarSetList` new_unspecables) }) -getUnspecables :: DsM (S.Set EvId) +zapUnspecables :: DsM a -> DsM a +zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = Nothing }) + +getUnspecables :: DsM (Maybe VarSet) getUnspecables = dsl_unspecables <$> getLclEnv getSrcSpanDs :: DsM SrcSpan @@ -429,7 +495,7 @@ putSrcSpanDs (RealSrcSpan real_span _) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside -putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a +putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) -- | Emit a diagnostic for the current source location. In case the diagnostic is a warning, @@ -498,8 +564,11 @@ dsGetMetaEnv :: DsM (NameEnv DsMetaVal) dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } +dsGetGlobalRdrEnv :: DsM GlobalRdrEnv +dsGetGlobalRdrEnv = ds_gbl_rdr_env <$> getGblEnv + -- | The @COMPLETE@ pragmas that are in scope. -dsGetCompleteMatches :: DsM CompleteMatches +dsGetCompleteMatches :: DsM DsCompleteMatches dsGetCompleteMatches = ds_complete_matches <$> getGblEnv dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) diff --git a/GHC/HsToCore/Pmc.hs b/GHC/HsToCore/Pmc.hs --- a/GHC/HsToCore/Pmc.hs +++ b/GHC/HsToCore/Pmc.hs @@ -35,11 +35,12 @@ -- 'ldiMatch'. See Section 4.1 of the paper. module GHC.HsToCore.Pmc ( -- Checking and printing - pmcPatBind, pmcMatches, pmcGRHSs, + pmcPatBind, pmcMatches, pmcGRHSs, pmcRecSel, isMatchContextPmChecked, isMatchContextPmChecked_SinglePat, -- See Note [Long-distance information] - addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas + addTyCs, addCoreScrutTmCs, addHsScrutTmCs, getLdiNablas, + getNFirstUncovered ) where import GHC.Prelude @@ -50,8 +51,8 @@ import GHC.HsToCore.Pmc.Desugar import GHC.HsToCore.Pmc.Check import GHC.HsToCore.Pmc.Solver -import GHC.Types.Basic (Origin(..)) -import GHC.Core (CoreExpr) +import GHC.Types.Basic (Origin(..), isDoExpansionGenerated) +import GHC.Core import GHC.Driver.DynFlags import GHC.Hs import GHC.Types.Id @@ -59,21 +60,20 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Var (EvVar) +import GHC.Types.Var (EvVar, Var (..)) +import GHC.Types.Id.Info import GHC.Tc.Utils.TcType (evVarPred) -import GHC.Tc.Utils.Monad (updTopFlags) import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr) import GHC.HsToCore.Monad import GHC.Data.Bag -import GHC.Data.IOEnv (unsafeInterleaveM) import GHC.Data.OrdList -import GHC.Utils.Monad (mapMaybeM) -import Control.Monad (when, forM_) +import Control.Monad (when, unless, forM_) import qualified Data.Semigroup as Semi import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import Data.Coerce +import GHC.Tc.Utils.Monad -- -- * Exported entry points to the checker @@ -118,6 +118,7 @@ then id else discardWarningsDs want_pmc PatBindRhs = True + want_pmc LazyPatCtx = True want_pmc (StmtCtxt stmt_ctxt) = case stmt_ctxt of PatGuard {} -> False @@ -127,12 +128,12 @@ -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs. pmcGRHSs - :: HsMatchContext GhcTc -- ^ Match context, for warning messages + :: HsMatchContextRn -- ^ Match context, for warning messages -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check -> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long -- distance info pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do - let combined_loc = foldl1 combineSrcSpans (map getLocA grhss) + let combined_loc = foldl1 combineSrcSpans (NE.map getLocA grhss) ctxt = DsMatchContext hs_ctxt combined_loc !missing <- getLdiNablas matches <- noCheckDs $ desugarGRHSs combined_loc empty guards @@ -161,20 +162,21 @@ -- checks an @-XEmptyCase@ with only a single match variable. -- See Note [Checking EmptyCase]. pmcMatches - :: DsMatchContext -- ^ Match context, for warnings messages + :: Origin + -> DsMatchContext -- ^ Match context, for warnings messages -> [Id] -- ^ Match variables, i.e. x and y above -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and -- GRHS, for long distance info. -pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do +pmcMatches origin ctxt vars matches = {-# SCC "pmcMatches" #-} do -- We have to force @missing@ before printing out the trace message, -- otherwise we get interleaved output from the solver. This function -- should be strict in @missing@ anyway! !missing <- getLdiNablas tracePm "pmcMatches {" $ - hang (vcat [ppr ctxt, ppr vars, text "Matches:"]) + hang (vcat [ppr origin, ppr ctxt, ppr vars, text "Matches:"]) 2 - (vcat (map ppr matches) $$ ppr missing) + ((ppr matches) $$ (text "missing:" <+> ppr missing)) case NE.nonEmpty matches of Nothing -> do -- This must be an -XEmptyCase. See Note [Checking EmptyCase] @@ -187,12 +189,209 @@ 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)) - {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result + unless (isDoExpansionGenerated origin) -- Do expansion generated code shouldn't emit overlapping warnings + ({-# SCC "formatReportWarnings" #-} + formatReportWarnings ReportMatchGroup ctxt vars result) return (NE.toList (ldiMatchGroup (cr_ret result))) +{- +Note [Detecting incomplete record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes the implementation of +GHC proposal 516 "Add warning for incomplete record selectors". + +A **partial field** is a field that does not belong to every constructor of the +corresponding datatype. +A **partial selector occurrence** is a use of a record selector for a partial +field, either as a selector function in an expression, or as the solution to a +HasField constraint. + +Partial selector occurrences desugar to case expressions which may crash at +runtime: + + data T a where + T1 :: T Int + T2 {sel :: Int} :: T Bool + + urgh :: T a -> Int + urgh x = sel x + ===> + urgh x = case x of + T1 -> error "no record field sel" + T2 f -> f + +As such, it makes sense to warn about such potential crashes. +We do so whenever -Wincomplete-record-selectors is present, and we utilise +the pattern-match coverage checker for precise results, because there are many +uses of selectors for partial fields which are in fact dynamically safe. + +Pmc can detect two very common safe uses for which we will not warn: + + (LDI) Ambient pattern-matches unleash Note [Long-distance information] that + render a naively flagged partial selector occurrence safe, as in + ldi :: T a -> Int + ldi T1 = 0 + ldi arg = sel arg + We should not warn here, because `arg` cannot be `T1`. + + (RES) Constraining the result type of a GADT such as T might render + naively flagged partial selector occurrences safe, as in + resTy :: T Bool -> Int + resTy = sel + Here, `T1 :: T Int` is ruled out because it has the wrong result type. + +Additionally, we want to support incomplete -XOverloadedRecordDot access as +well, in either the (LDI) use case or the (RES) use case: + + data Dot = No | Yes { sel2 :: Int } + dot d = d.sel2 -- should warn + ldiDot No = 0 + ldiDot d = d.sel2 -- should not warn + resTyDot :: T Bool -> Int + resTyDot x = x.sel -- should not warn + +From a user's point of view, function `ldiDot` looks very like example `ldi` and +`resTyDot` looks very like `resTy`. But from an /implementation/ point of view +they are very different: both `ldiDot` and `resTyDot` simply emit `HasField` +constraints, and it is those constraints that the implementation must use to +determine incompleteness. + +Furthermore, HasField constraints allow to delay the completeness check from +the field access site to a caller, as in test cases TcIncompleteRecSel and T24891: + + accessDot :: HasField "sel2" t Int => t -> Int + accessDot x = x.sel2 -- getField @Symbol @"sel2" @t @Int x + solveDot :: Dot -> Int + solveDot = accessDot + +We should warn in `solveDot`, but not in `accessDot`. + +Here is how we achieve all this in the implementation: + +(IRS1) When renaming a record selector in `mkOneRecordSelector`, + we precompute the constructors the selector succeeds on. + That would be `T2` for `sel` because `sel (T2 42)` succeeds, + and `Yes` for `sel2` because `sel2 (Yes 13)` succeeds. + We store this information in the `sel_cons` field of `RecSelId`. + (Remember, the same field may occur in several constructors of the data + type; hence the selector may succeed on more than one constructor.) + +We generate warnings for incomplete record selectors in two places: +* Mainly: in GHC.HsToCore.Expr.ds_app (see (IRS2-5) below) +* Plus: in GHC.Tc.Instance.Class.matchHassField (see (IRS6-7) below) + +(IRS2) In function `ldi`, we have a record selector application `sel arg`. + This situation is detected `GHC.HsToCore.Expr.ds_app_rec_sel`, when the + record selector is applied to at least one argument. We call out to the + pattern-match checker to determine whether use of the selector is safe, + by calling GHC.HsToCore.Pmc.pmcRecSel, passing the `RecSelId` `sel` as + well as `arg`. + + The pattern-match checker reduces the partial-selector-occurrence problem to + a complete-match problem by adding a negative constructor constraint such as + `arg /~ T2` for every constructor in the precomputed `rsi_def . sel_cons` of + `sel`. (Recall that these were exactly the constructors which define a field + `sel`.) `pmcRecSel` then tests + case arg of {} + for completeness. Any incomplete match, such as in the original `urgh`, must + reference a constructor that does not have field `sel`, such as `T1`. + + In case of `urgh`, `T1` is indeed the case that we report as inexhaustive. + + However, in function `ldi`, we have *both* the result type of + `arg::T a` (boring, but see (IRS3)) as well as Note [Long-distance information] + about `arg` from the ambient match, and the latter lists the constraint + `arg /~ T1`. Consequently, since `arg` is neither `T1` nor `T2` in the + reduced problem, the match is exhaustive and the use of the record selector + safe. + +(IRS3) In function `resTy`, the record selector is unsaturated, but the result type + ensures a safe use of the selector. + + This situation is also detected in `GHC.HsToCore.Expr.ds_app_rec_sel`. + THe selector is elaborated with its type arguments; we simply match on + desugared Core `sel @Bool :: T Bool -> Int` to learn the result type `T Bool`. + We again call `pmcRecSel`, but this time with a fresh dummy Id `ds::T Bool`. + +(IRS4) In case of an unsaturated record selector that is *not* applied to any type + argument after elaboration (e.g. in `urgh2 = sel2 :: Dot -> Int`), we simply + produce a warning about all `sel_cons`; no need to call `pmcRecSel`. + This happens in `ds_app_rec_sel` + +Finally, there are two more items addressing -XOverloadedRecordDot: + +(IRS5) With -XOverloadedDot, all occurrences of (r.x), such as in `ldiDot` and + `accessDot` above, are warned about as follows. `r.x` is parsed as + `HsGetField` in `HsExpr`; which is then expanded (in `rnExpr`) to a call to + `getField`. For example, consider: + ldiDot No = 0 + ldiDot x = x.sel2 -- should not warn + The `d.sel2` in the RHS generates + getField @GHC.Types.Symbol @"sel2" @Dot @Int + ($dHasField :: HasField "sel2" Dot Int) x + where + $dHasField = sel2 |> (co :: Dot -> Int ~R# HasField "sel2" Dot Int) + We spot this `getField` application in `GHC.HsToCore.Expr.ds_app_var`, + and treat it exactly like (IRS2) and (IRS3). + + Note carefully that doing this in the desugarer allows us to account for the + long-distance info about `x`; even though `sel2` is partial, we don't want + to warn about `x.sel2` in this example. + +(IRS6) Finally we have + solveDot :: Dot -> Int + solveDot = accessDot + No field-accesses or selectors in sight! From the RHS we get the constraint + [W] HasField @"sel2" @Dot @Int` + The only time we can generate a warning is when we solve this constraint, + in `GHC.Tc.Instance.Class.matchHasField`, generating a call to the (partial) + selector. We have no hope of exploiting long-distance info here. + +(IRS7) BUT, look back at `ldiDot`. Doesn't `matchHasField` /also/ generate a + warning for the `HasField` constraint arising from `x.sel2`? We don't + want that, because the desugarer will catch it: see (IRS5). So we suppress + the (IRS6) warning in the typechecker for a `HasField` constraint that + arises from a record-dot HsGetField occurrence. Happily, this is easy to do + by looking at its `CtOrigin`. Tested in T24891. +-} + +pmcRecSel :: Id -- ^ Id of the selector + -> CoreExpr -- ^ Core expression of the argument to the selector + -> DsM () +-- See (IRS2,3) in Note [Detecting incomplete record selectors] +pmcRecSel sel_id arg + | RecSelId{ sel_cons = rec_sel_info } <- idDetails sel_id + , RSI { rsi_def = cons_w_field, rsi_undef = cons_wo_field } <- rec_sel_info + , not (null cons_wo_field) + = do { !missing <- getLdiNablas + + ; tracePm "pmcRecSel {" (ppr sel_id) + ; CheckResult{ cr_ret = PmRecSel{ pr_arg_var = arg_id }, cr_uncov = uncov_nablas } + <- unCA (checkRecSel (PmRecSel () arg cons_w_field)) missing + ; tracePm "}: " $ ppr uncov_nablas + + ; inhabited <- isInhabited uncov_nablas + ; when inhabited $ warn_incomplete arg_id uncov_nablas } + + | otherwise + = return () + + where + sel_name = varName sel_id + warn_incomplete arg_id uncov_nablas = do + dflags <- getDynFlags + let maxPatterns = maxUncoveredPatterns dflags + unc_examples <- getNFirstUncovered MinimalCover [arg_id] (maxPatterns + 1) uncov_nablas + let cons = [con | unc_example <- unc_examples + , Just (PACA (PmAltConLike con) _ _) <- [lookupSolution unc_example arg_id]] + tracePm "unc-ex" (ppr cons $$ ppr unc_examples) + diagnosticDs $ DsIncompleteRecordSelector sel_name cons maxPatterns + + {- Note [pmcPatBind doesn't warn on pattern guards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @pmcPatBind@'s main purpose is to check vanilla pattern bindings, like @@ -425,8 +624,8 @@ -- | Locally update 'dsl_nablas' with the given action, but defer evaluation -- with 'unsafeInterleaveM' in order not to do unnecessary work. -locallyExtendPmNablas :: (Nablas -> DsM Nablas) -> DsM a -> DsM a -locallyExtendPmNablas ext k = do +locallyExtendPmNablas :: DsM a -> (Nablas -> DsM Nablas) -> DsM a +locallyExtendPmNablas k ext = do nablas <- getLdiNablas nablas' <- unsafeInterleaveM $ ext nablas updPmNablas nablas' k @@ -434,12 +633,15 @@ -- | Add in-scope type constraints if the coverage checker might run and then -- run the given action. addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a -addTyCs origin ev_vars m = do - dflags <- getDynFlags - applyWhen (needToRunPmCheck dflags origin) - (locallyExtendPmNablas $ \nablas -> - addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars)) - m +addTyCs origin ev_vars thing_inside + | isEmptyBag ev_vars + = thing_inside -- Very common fast path + | otherwise + = do { dflags <- getDynFlags + ; if needToRunPmCheck dflags origin + then locallyExtendPmNablas thing_inside $ \nablas -> + addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars) + else thing_inside } -- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment, -- e.g. when checking a case expression: @@ -450,8 +652,8 @@ -- to be added for multiple scrutinees rather than just one. addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a addCoreScrutTmCs [] _ k = k -addCoreScrutTmCs (scr:scrs) (x:xs) k = - flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas -> +addCoreScrutTmCs (scr:scrs) (x:xs) k + = locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas -> addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr)) addCoreScrutTmCs _ _ _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ" diff --git a/GHC/HsToCore/Pmc/Check.hs b/GHC/HsToCore/Pmc/Check.hs --- a/GHC/HsToCore/Pmc/Check.hs +++ b/GHC/HsToCore/Pmc/Check.hs @@ -19,7 +19,7 @@ -- "GHC.HsToCore.Pmc.Solver". module GHC.HsToCore.Pmc.Check ( CheckAction(..), - checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase + checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase, checkRecSel ) where import GHC.Prelude @@ -33,32 +33,47 @@ import GHC.Utils.Outputable import GHC.Tc.Utils.TcType (evVarPred) import GHC.Data.OrdList +import GHC.Data.Bag import qualified Data.Semigroup as Semi import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import Data.Coerce +import GHC.Types.Var +import GHC.Core +import GHC.Core.Utils -- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'. 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: @@ -91,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! @@ -148,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] @@ -185,6 +221,20 @@ checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post) checkPatBind = coerce checkGRHS +checkRecSel :: PmRecSel () -> CheckAction (PmRecSel Id) +-- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc +checkRecSel pr@(PmRecSel { pr_arg = arg, pr_cons = cons }) = CA $ \inc -> do + arg_id <- case arg of + Var arg_id -> return arg_id + _ -> mkPmId $ exprType arg + + let con_cts = map (PhiNotConCt arg_id . PmAltConLike) cons + arg_ct = PhiCoreCt arg_id arg + phi_cts = listToBag (arg_ct : con_cts) + unc <- addPhiCtsNablas inc phi_cts + pure CheckResult { cr_ret = pr{ pr_arg_var = arg_id }, cr_uncov = unc, cr_approx = mempty } + + {- Note [Checking EmptyCase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -XEmptyCase is useful for matching on empty data types like 'Void'. For example, @@ -252,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 @@ -275,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] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/HsToCore/Pmc/Desugar.hs b/GHC/HsToCore/Pmc/Desugar.hs --- a/GHC/HsToCore/Pmc/Desugar.hs +++ b/GHC/HsToCore/Pmc/Desugar.hs @@ -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 @@ -45,20 +44,16 @@ 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) import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -- 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 +61,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,46 +97,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 + ParPat _ p -> desugarLPat x p + 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 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 @@ -155,24 +154,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 @@ -224,57 +219,60 @@ Just l -> l Nothing -> pprPanic "failed to detect OverLit" (ppr olit) let lit' = case mb_neg of - Just _ -> expectJust "failed to negate lit" (negatePmLit lit) + Just _ -> expectJust (negatePmLit lit) Nothing -> lit mkPmLitGrds x lit' LitPat _ lit -> do - core_expr <- dsLit (convertLit lit) - let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr) + core_expr <- dsLit lit + let lit = expectJust (coreExprAsPmLit core_expr) mkPmLitGrds x lit TuplePat _tys pats boxity -> do (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) + PrefixCon ps -> go_field_pats (zip [0..] ps) + InfixCon p1 p2 -> go_field_pats (zip [0..] [p1,p2]) + RecCon (HsRecFields NoExtField fs _) -> go_field_pats (rec_field_ps fs) where -- The actual argument types (instantiated) arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs) @@ -287,7 +285,7 @@ -- Unfortunately the label info is empty when the DataCon wasn't defined -- with record field labels, hence we desugar to field index. orig_lbls = map flSelector $ conLikeFieldLabels con - lbl_to_index lbl = expectJust "lbl_to_index" $ elemIndex lbl orig_lbls + lbl_to_index lbl = expectJust $ elemIndex lbl orig_lbls go_field_pats tagged_pats = do -- The fields that appear might not be in the correct order. So @@ -312,15 +310,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 } @@ -333,23 +331,20 @@ -- 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 lcls <- desugarLocalBinds (grhssLocalBinds grhss) - grhss' <- traverse (desugarLGRHS match_loc pp_pats) - . expectJust "desugarGRHSs" - . NE.nonEmpty - $ grhssGRHSs grhss - return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' } + grhss' <- traverse (desugarLGRHS match_loc pp_pats) (grhssGRHSs grhss) + return PmGRHSs { pgs_lcls = lcls, pgs_grhss = grhss' } -- | Desugar a guarded right-hand side to a single 'GrdTree' desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre) @@ -362,11 +357,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 @@ -375,24 +370,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 - , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do + | 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 @@ -408,14 +406,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; @ -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 @@ -423,24 +421,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/HsToCore/Pmc/Ppr.hs b/GHC/HsToCore/Pmc/Ppr.hs --- a/GHC/HsToCore/Pmc/Ppr.hs +++ b/GHC/HsToCore/Pmc/Ppr.hs @@ -20,7 +20,6 @@ import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad.Trans.RWS.CPS import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList) diff --git a/GHC/HsToCore/Pmc/Solver.hs b/GHC/HsToCore/Pmc/Solver.hs --- a/GHC/HsToCore/Pmc/Solver.hs +++ b/GHC/HsToCore/Pmc/Solver.hs @@ -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 @@ -43,7 +44,6 @@ import GHC.Utils.Misc import GHC.Utils.Monad (allM) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.CompleteMatch @@ -52,16 +52,19 @@ 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 ) import GHC.Core.Map.Expr -import GHC.Core.Predicate (typeDeterminesValue) +import GHC.Core.Predicate (typeDeterminesValue, mkNomEqPred) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr) @@ -92,13 +95,13 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.Coerce -import Data.Either (partitionEithers) -import Data.Foldable (foldlM, minimumBy, toList) +import Data.Foldable (foldlM, toList) import Data.Monoid (Any(..)) import Data.List (sortBy, find) import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) + -- -- * Main exports -- @@ -129,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 @@ -144,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. @@ -194,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: @@ -361,7 +363,7 @@ eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys) is_closed_or_data_family :: Type -> Bool - is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty + is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyApp ty -- For efficiency, represent both lists as difference lists. -- comb performs the concatenation, for both lists. @@ -609,7 +611,7 @@ inhabitationTest initFuel (nabla_ty_st nabla) nabla'' partitionPhiCts :: PhiCts -> ([PredType], [PhiCt]) -partitionPhiCts = partitionEithers . map to_either . toList +partitionPhiCts = partitionWith to_either . toList where to_either (PhiTyCt pred_ty) = Left pred_ty to_either ct = Right ct @@ -677,7 +679,7 @@ filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args = - [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con) + [ arg | (arg, bang) <- zipEqual args (pmAltConImplBangs con) , isBanged bang || definitelyUnliftedType (idType arg) ] -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ @@ -784,7 +786,7 @@ let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs) nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts) let add_var_ct nabla (a, b) = addVarCt nabla a b - foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args + foldlM add_var_ct nabla' $ zipEqual args other_args Nothing -> do let pos' = PACA alt tvs args : pos let nabla_with bot' = @@ -801,8 +803,8 @@ equateTys :: [Type] -> [Type] -> [PhiCt] equateTys ts us = - [ PhiTyCt (mkPrimEqPred t u) - | (t, u) <- zipEqual "equateTys" ts us + [ PhiTyCt (mkNomEqPred t u) + | (t, u) <- zipEqual ts us -- The following line filters out trivial Refl constraints, so that we don't -- need to initialise the type oracle that often , not (eqType t u) @@ -1411,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 @@ -1424,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 @@ -1468,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, @@ -1962,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 @@ -1982,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 @@ -2005,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 diff --git a/GHC/HsToCore/Pmc/Solver/Types.hs b/GHC/HsToCore/Pmc/Solver/Types.hs --- a/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/GHC/HsToCore/Pmc/Solver/Types.hs @@ -63,9 +63,9 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim -import GHC.Tc.Solver.InertSet (InertSet, emptyInert) -import GHC.Tc.Utils.TcType (isStringTy) -import GHC.Types.CompleteMatch (CompleteMatch(..)) +import GHC.Tc.Solver.InertSet (InertSet, emptyInertSet) +import GHC.Tc.Utils.TcType (isStringTy, topTcLevel) +import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit , fractionalLitFromRational , FractionalExponentBase(..)) @@ -129,7 +129,7 @@ ppr (TySt n inert) = ppr n <+> ppr inert initTyState :: TyState -initTyState = TySt 0 emptyInert +initTyState = TySt 0 (emptyInertSet topTcLevel) -- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These -- entries are possibly shared when we figure out that two variables must be @@ -258,19 +258,19 @@ -- See also Note [Implementation of COMPLETE pragmas] data ResidualCompleteMatches = RCM - { rcm_vanilla :: !(Maybe CompleteMatch) + { rcm_vanilla :: !(Maybe DsCompleteMatch) -- ^ The residual set for the vanilla COMPLETE set from the data defn. -- Tracked separately from 'rcm_pragmas', because it might only be -- known much later (when we have enough type information to see the 'TyCon' -- of the match), or not at all even. Until that happens, it is 'Nothing'. - , rcm_pragmas :: !(Maybe [CompleteMatch]) + , rcm_pragmas :: !(Maybe DsCompleteMatches) -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are -- visible when compiling this module. Querying that set with -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing' -- until first needed in a 'DsM' context. } -getRcm :: ResidualCompleteMatches -> [CompleteMatch] +getRcm :: ResidualCompleteMatches -> DsCompleteMatches getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas isRcmInitialised :: ResidualCompleteMatches -> Bool @@ -325,6 +325,11 @@ go _ = Nothing trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla) +{-# INLINE trvVarInfo #-} +-- This function is called a lot and we want to specilise it, not only +-- for the type class, but also for its 'f' function argument. +-- Before the INLINE pragma it sometimes inlined and sometimes didn't, +-- depending delicately on GHC's optimisations. Better to use a pragma. trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x = set_vi <$> f (lookupVarInfo ts x) where diff --git a/GHC/HsToCore/Pmc/Types.hs b/GHC/HsToCore/Pmc/Types.hs --- a/GHC/HsToCore/Pmc/Types.hs +++ b/GHC/HsToCore/Pmc/Types.hs @@ -18,10 +18,13 @@ -- * LYG syntax -- ** Guard language - SrcInfo(..), PmGrd(..), GrdVec(..), + SrcInfo(..), PmGrd(..), GrdDag(..), + consGrdDag, gdSeq, sequencePmGrds, sequenceGrdDags, + alternativesGrdDags, -- ** Guard tree language - PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..), + PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), + PmPatBind(..), PmEmptyCase(..), PmRecSel(..), -- * Coverage Checking types RedSets (..), Precision (..), CheckResult (..), @@ -43,6 +46,7 @@ import GHC.Types.Var (EvVar) import GHC.Types.SrcLoc import GHC.Utils.Outputable +import GHC.Core.ConLike import GHC.Core.Type import GHC.Core @@ -101,9 +105,52 @@ -- location. newtype SrcInfo = SrcInfo (Located SDoc) --- | A sequence of 'PmGrd's. -newtype GrdVec = GrdVec [PmGrd] +-- | A series-parallel graph of 'PmGrd's, so very nearly a guard tree, if +-- it weren't for or-patterns/'GdAlt'! +-- The implicit "source" corresponds to "before the match" and the implicit +-- "sink" corresponds to "after a successful match". +-- +-- * 'GdEnd' is a 'GrdDag' that always matches. +-- * 'GdOne' is a 'GrdDag' that matches iff its 'PmGrd' matches. +-- * @'GdSeq' g1 g2@ corresponds to matching guards @g1@ and then @g2@ +-- if matching @g1@ succeeded. +-- Example: The Haskell guard @| x > 1, x < 10 = ...@ will test @x > 1@ +-- before @x < 10@, failing if either test fails. +-- * @'GdAlt' g1 g2@ is far less common than 'GdSeq' and corresponds to +-- matching an or-pattern @(LT; EQ)@, succeeding if the +-- match variable matches /either/ 'LT' or 'EQ'. +-- See Note [Implementation of OrPatterns] for a larger example. +-- +data GrdDag + = GdEnd + | GdOne !PmGrd + | GdSeq !GrdDag !GrdDag + | GdAlt !GrdDag !GrdDag +-- | Sequentially compose a list of 'PmGrd's into a 'GrdDag'. +sequencePmGrds :: [PmGrd] -> GrdDag +sequencePmGrds = sequenceGrdDags . map GdOne + +-- | Sequentially compose a list of 'GrdDag's. +sequenceGrdDags :: [GrdDag] -> GrdDag +sequenceGrdDags xs = foldr gdSeq GdEnd xs + +-- | Sequentially compose a 'PmGrd' in front of a 'GrdDag'. +consGrdDag :: PmGrd -> GrdDag -> GrdDag +consGrdDag g d = gdSeq (GdOne g) d + +-- | Sequentially compose two 'GrdDag's. A smart constructor for `GdSeq` that +-- eliminates `GdEnd`s. +gdSeq :: GrdDag -> GrdDag -> GrdDag +gdSeq g1 GdEnd = g1 +gdSeq GdEnd g2 = g2 +gdSeq g1 g2 = g1 `GdSeq` g2 + +-- | Parallel composition of a list of 'GrdDag's. +-- Needs a non-empty list as 'GdAlt' does not have a neutral element. +alternativesGrdDags :: NonEmpty GrdDag -> GrdDag +alternativesGrdDags xs = foldr1 GdAlt xs + -- | A guard tree denoting 'MatchGroup'. newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p)) @@ -130,14 +177,22 @@ -- rather than on the pattern bindings. PmPatBind (PmGRHS p) +-- A guard tree denoting a record selector application +data PmRecSel v = PmRecSel { pr_arg_var :: v, pr_arg :: CoreExpr, pr_cons :: [ConLike] } instance Outputable SrcInfo where ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss) ppr (SrcInfo (L s _)) = ppr s -- | Format LYG guards as @| True <- x, let x = 42, !z@ -instance Outputable GrdVec where - ppr (GrdVec []) = empty - ppr (GrdVec (g:gs)) = fsep (char '|' <+> ppr g : map ((comma <+>) . ppr) gs) +instance Outputable GrdDag where + ppr GdEnd = empty + ppr (GdOne g) = ppr g + ppr (GdSeq d1 d2) = ppr d1 <> comma <+> ppr d2 + ppr d0@GdAlt{} = parens $ fsep (ppr d : map ((semi <+>) . ppr) ds) + where + d NE.:| ds = collect d0 + collect (GdAlt d1 d2) = collect d1 Semi.<> collect d2 + collect d = NE.singleton d -- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as -- @{ ; ...; }@ @@ -232,7 +287,7 @@ -- -- | Used as tree payload pre-checking. The LYG guards to check. -type Pre = GrdVec +type Pre = GrdDag -- | Used as tree payload post-checking. The redundancy info we elaborated. type Post = RedSets diff --git a/GHC/HsToCore/Pmc/Utils.hs b/GHC/HsToCore/Pmc/Utils.hs --- a/GHC/HsToCore/Pmc/Utils.hs +++ b/GHC/HsToCore/Pmc/Utils.hs @@ -61,16 +61,17 @@ , Opt_WarnIncompleteUniPatterns , Opt_WarnIncompletePatternsRecUpd , Opt_WarnOverlappingPatterns + , Opt_WarnIncompleteRecordSelectors ] -- | Check whether the redundancy checker should run (redundancy only) -overlapping :: DynFlags -> HsMatchContext id -> Bool +overlapping :: DynFlags -> HsMatchContext fn -> Bool -- See Note [Inaccessible warnings for record updates] overlapping _ RecUpd = False overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags -- | Check whether the exhaustiveness checker should run (exhaustiveness only) -exhaustive :: DynFlags -> HsMatchContext id -> Bool +exhaustive :: DynFlags -> HsMatchContext fn -> Bool exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag -- | Check whether unnecessary bangs should be warned about @@ -80,16 +81,17 @@ -- | Denotes whether an exhaustiveness check is supported, and if so, -- via which 'WarningFlag' it's controlled. -- Returns 'Nothing' if check is not supported. -exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag +exhaustiveWarningFlag :: HsMatchContext fn -> Maybe WarningFlag exhaustiveWarningFlag FunRhs{} = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns -exhaustiveWarningFlag LamCaseAlt{} = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns -exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag (LamAlt LamSingle) = Just Opt_WarnIncompleteUniPatterns +exhaustiveWarningFlag (LamAlt _case) = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd +exhaustiveWarningFlag LazyPatCtx = Just Opt_WarnIncompleteUniPatterns exhaustiveWarningFlag ThPatSplice = Nothing exhaustiveWarningFlag PatSyn = Nothing exhaustiveWarningFlag ThPatQuote = Nothing @@ -99,22 +101,22 @@ arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag arrowMatchContextExhaustiveWarningFlag = \ case - ProcExpr -> Just Opt_WarnIncompleteUniPatterns - ArrowCaseAlt -> Just Opt_WarnIncompletePatterns - ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns - KappaExpr -> Just Opt_WarnIncompleteUniPatterns + ProcExpr -> Just Opt_WarnIncompleteUniPatterns + ArrowCaseAlt -> Just Opt_WarnIncompletePatterns + ArrowLamAlt LamSingle -> Just Opt_WarnIncompleteUniPatterns + ArrowLamAlt _ -> Just Opt_WarnIncompletePatterns -- | Check whether any part of pattern match checking is enabled for this -- 'HsMatchContext' (does not matter whether it is the redundancy check or the -- exhaustiveness check). -isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool +isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext fn -> Bool isMatchContextPmChecked dflags origin ctxt = requiresPMC origin && (overlapping dflags ctxt || exhaustive dflags ctxt) -- | Check whether exhaustivity checks are enabled for this 'HsMatchContext', -- when dealing with a single pattern (using the 'matchSinglePatVar' function). -isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext id -> LPat GhcTc -> Bool +isMatchContextPmChecked_SinglePat :: DynFlags -> Origin -> HsMatchContext fn -> LPat GhcTc -> Bool isMatchContextPmChecked_SinglePat dflags origin ctxt pat | not (needToRunPmCheck dflags origin) = False diff --git a/GHC/HsToCore/Quote.hs b/GHC/HsToCore/Quote.hs --- a/GHC/HsToCore/Quote.hs +++ b/GHC/HsToCore/Quote.hs @@ -12,8 +12,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2006 @@ -42,13 +40,13 @@ 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.Boot.TH.Syntax as TH import GHC.Hs import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence +import GHC.Tc.TyCl ( IsPrefixConGADT(..), unannotatedMultIsLinear ) import GHC.Core.Class import GHC.Core.DataCon @@ -61,18 +59,18 @@ import GHC.Builtin.Names import GHC.Builtin.Names.TH import GHC.Builtin.Types +import GHC.Builtin.Types.Prim import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad -import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.Maybe +import qualified GHC.Data.List.NonEmpty as NE import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique @@ -100,7 +98,7 @@ import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import GHC.Types.Name.Reader (RdrName(..)) +import GHC.Types.Name.Reader (RdrName(..), WithUserRdr (..)) data MetaWrappers = MetaWrappers { -- Applies its argument to a type argument `m` and dictionary `Quote m` @@ -122,15 +120,15 @@ -- to be used to construct the monadWrapper. quote_tc <- dsLookupTyCon quoteClassName monad_tc <- dsLookupTyCon monadClassName - let Just cls = tyConClass_maybe quote_tc - Just monad_cls = tyConClass_maybe monad_tc + let cls = expectJust $ tyConClass_maybe quote_tc + monad_cls = expectJust $ tyConClass_maybe monad_tc -- Quote m -> Monad m monad_sel = classSCSelId cls 0 -- Only used for the defensive assertion that the selector has -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) - expected_ty = mkInvisForAllTys tyvars $ + expected_ty = mkForAllTys tyvars $ mkFunTy invisArgConstraintLike ManyTy (mkClassPred cls (mkTyVarTys (binderVars tyvars))) (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) @@ -178,7 +176,7 @@ DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } DecBrL {} -> panic "dsUntypedBracket: unexpected DecBrL" where - Just wrap = mb_wrap -- Not used in VarBr case + wrap = expectJust mb_wrap -- Not used in VarBr case -- In the overloaded case we have to get given a wrapper, it is just -- the VarBr case that there is no wrapper, because they -- have a simple type. @@ -286,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 ; @@ -551,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) @@ -694,21 +690,21 @@ ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys ; t1' <- repLTy t1 ; t2' <- repLTy t2 ; repTyArgs (repTInfix t1' tc t2') args } ; rhs1 <- repLTy rhs ; repTySynEqn mb_exp_bndrs tys1 rhs1 } } where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _:HsValArg _:_) = return tys + checkTys tys@(HsValArg _ _:HsValArg _ _:_) = return tys checkTys _ = panic "repTyFamEqn:checkTys" repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type)) repTyArgs f [] = f -repTyArgs f (HsValArg ty : as) = do { f' <- f - ; ty' <- repLTy ty - ; repTyArgs (repTapp f' ty') as } +repTyArgs f (HsValArg _ ty : as) = do { f' <- f + ; ty' <- repLTy ty + ; repTyArgs (repTapp f' ty') as } repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f ; ki' <- repLTy ki ; repTyArgs (repTappKind f' ki') as } @@ -725,14 +721,14 @@ ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs -> do { tys1 <- case fixity of Prefix -> repTyArgs (repNamedTyCon tc) tys - Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + Infix -> do { (HsValArg _ t1: HsValArg _ t2: args) <- checkTys tys ; t1' <- repLTy t1 ; t2' <- repLTy t2 ; repTyArgs (repTInfix t1' tc t2') args } ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } } where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn] - checkTys tys@(HsValArg _: HsValArg _: _) = return tys + checkTys tys@(HsValArg _ _: HsValArg _ _: _) = return tys checkTys _ = panic "repDataFamInstD:checkTys" repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) @@ -782,50 +778,59 @@ 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 _ 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 -> infixLDName - InfixR -> infixRDName - InfixN -> infixNDName + InfixL -> infixLWithSpecDName + InfixR -> infixRWithSpecDName + InfixN -> infixNWithSpecDName ; let do_one name = do { MkC name' <- lookupLOcc name - ; dec <- rep2 rep_fn [prec', name'] + ; MkC ns_spec' <- repNamespaceSpecifier ns_spec + ; dec <- rep2 rep_fn [prec', ns_spec', name'] ; return (loc,dec) } ; 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 , rd_act = act - , rd_tyvs = m_ty_bndrs - , rd_tmvs = tm_bndrs + , rd_bndrs = bndrs , rd_lhs = lhs , rd_rhs = rhs })) + = fmap (locA loc, ) <$> + repRuleBinders bndrs $ \ ty_bndrs' tm_bndrs' -> + do { n' <- coreStringLit $ unLoc n + ; act' <- repPhases act + ; lhs' <- repLE lhs + ; rhs' <- repLE rhs + ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } + +repRuleBinders :: RuleBndrs GhcRn + -> (Core (Maybe [M (TH.TyVarBndr ())]) -> Core [M TH.RuleBndr] -> MetaM (Core (M a))) + -> MetaM (Core (M a)) +repRuleBinders (RuleBndrs { rb_tyvs = m_ty_bndrs, rb_tmvs = tm_bndrs }) thing_inside = do { let ty_bndrs = fromMaybe [] m_ty_bndrs - ; rule <- addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs -> - do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs - ; ss <- mkGenSyms tm_bndr_names - ; rule <- addBinds ss $ - do { elt_ty <- wrapName tyVarBndrUnitTyConName - ; ty_bndrs' <- return $ case m_ty_bndrs of - Nothing -> coreNothing' (mkListTy elt_ty) - Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs - ; tm_bndrs' <- repListM ruleBndrTyConName - repRuleBndr - tm_bndrs - ; n' <- coreStringLit $ unLoc n - ; act' <- repPhases act - ; lhs' <- repLE lhs - ; rhs' <- repLE rhs - ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } - ; wrapGenSyms ss rule } - ; return (locA loc, rule) } + ; addHsTyVarBinds FreshNamesOnly ty_bndrs $ \ ex_bndrs -> + do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs + ; ss <- mkGenSyms tm_bndr_names + ; x <- addBinds ss $ + do { elt_ty <- wrapName tyVarBndrUnitTyConName + ; ty_bndrs' <- return $ case m_ty_bndrs of + Nothing -> coreNothing' (mkListTy elt_ty) + Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs + ; tm_bndrs' <- repListM ruleBndrTyConName + repRuleBndr + tm_bndrs + ; thing_inside ty_bndrs' tm_bndrs' + } + ; wrapGenSyms ss x } + } ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n)) = [unLoc n] @@ -886,29 +891,46 @@ else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } -repC (L _ (ConDeclGADT { con_names = cons - , con_bndrs = L _ outer_bndrs +repC (L l (ConDeclGADT { con_names = cons + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs , con_mb_cxt = mcxt , con_g_args = args , con_res_ty = res_ty })) - | null_outer_imp_tvs && null_outer_exp_tvs - -- No implicit or explicit variables - , Nothing <- mcxt -- No context - -- ==> no need for a forall - = repGadtDataCons cons args res_ty + | no_explicit_forall, no_context + -- No explicit variables, no context ==> No need for a ForallC + -- See Note [Don't quantify implicit type variables in quotes] + = addSimpleTyVarBinds FreshNamesOnly (hsOuterTyVarNames outer_bndrs) $ + repGadtDataCons cons args res_ty - | otherwise + | Just invis_inner_bndrs <- m_invis_inner_bndrs = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' -> - -- See Note [Don't quantify implicit type variables in quotes] - do { c' <- repGadtDataCons cons args res_ty - ; ctxt' <- repMbContext mcxt - ; if null_outer_exp_tvs && isNothing mcxt - then return c' - else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) } + -- the context is attached to the innermost ForallC + let loop last_bndrs' [] = do + ctxt' <- repMbContext mcxt + c' <- repGadtDataCons cons args res_ty + rep2 forallCName ([unC last_bndrs', unC ctxt', unC c']) + loop last_bndrs' (bndrs : bndrs_s) = + addHsTyVarBinds FreshNamesOnly bndrs $ \bndrs' -> do + body_c' <- loop bndrs' bndrs_s + ctxt' <- repContext [] + rep2 forallCName [unC last_bndrs', unC ctxt', unC body_c'] + in loop outer_bndrs' invis_inner_bndrs + + | Nothing <- m_invis_inner_bndrs + = notHandledL (locA l) ThDataConVisibleForall + where - null_outer_imp_tvs = nullOuterImplicit outer_bndrs - null_outer_exp_tvs = nullOuterExplicit outer_bndrs + no_explicit_forall = nullOuterExplicit outer_bndrs && null inner_bndrs + no_context = isNothing mcxt + m_invis_inner_bndrs :: Maybe [[LHsTyVarBndr Specificity GhcRn]] + m_invis_inner_bndrs = traverse get_invis_bndrs inner_bndrs + + get_invis_bndrs :: HsForAllTelescope GhcRn -> Maybe [LHsTyVarBndr Specificity GhcRn] + get_invis_bndrs HsForAllVis{} = Nothing + get_invis_bndrs HsForAllInvis { hsf_invis_bndrs = tvbs } = Just tvbs + repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) repMbContext Nothing = repContext [] repMbContext (Just (L _ cxt)) = repContext cxt @@ -923,17 +945,13 @@ repSrcStrictness SrcStrict = rep2 sourceStrictName [] repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] -repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType)) -repBangTy ty = do - MkC u <- repSrcUnpackedness su' - MkC s <- repSrcStrictness ss' +repConDeclField :: HsConDeclField GhcRn -> MetaM (Core (M TH.BangType)) +repConDeclField (CDF { cdf_unpack, cdf_bang, cdf_type }) = do + MkC u <- repSrcUnpackedness cdf_unpack + MkC s <- repSrcStrictness cdf_bang MkC b <- rep2 bangName [u, s] - MkC t <- repLTy ty' + MkC t <- repLTy cdf_type rep2 bangTypeName [b, t] - where - (su', ss', ty') = case unLoc ty of - HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) - _ -> (NoSrcUnpack, NoSrcStrict, ty) ------------------------------------------------------- -- Deriving clauses @@ -996,9 +1014,12 @@ rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys -rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc) -rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas -rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas +rep_sig (L loc (SpecSigE _nm bndrs expr ispec)) + = fmap (\ d -> [(locA loc, d)]) $ + rep_specialiseE bndrs expr ispec +rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc) +rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas +rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc) rep_sig (L loc (CompleteMatchSig _ cls mty)) = rep_complete_sig cls mty (locA loc) rep_sig d@(L _ (XSig {})) = pprPanic "rep_sig IdSig" (ppr d) @@ -1008,7 +1029,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 +1039,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}) = @@ -1098,23 +1119,38 @@ ; return [(loc, pragma)] } +rep_inline_phases :: InlinePragma -> MetaM (Maybe (Core TH.Inline), Core TH.Phases) +rep_inline_phases (InlinePragma { inl_act = act, inl_inline = inl }) + = do { phases <- repPhases act + ; inl <- if noUserInlineSpec inl + -- SPECIALISE + then return Nothing + -- SPECIALISE INLINE + else Just <$> repInline inl + ; return (inl, phases) } + rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialise nm ty ispec loc + -- Old form SPECIALISE pragmas = do { nm1 <- lookupLOcc nm ; ty1 <- repHsSigType ty - ; phases <- repPhases $ inl_act ispec - ; let inline = inl_inline ispec - ; pragma <- if noUserInlineSpec inline - then -- SPECIALISE - repPragSpec nm1 ty1 phases - else -- SPECIALISE INLINE - do { inline1 <- repInline inline - ; repPragSpecInl nm1 ty1 inline1 phases } + ; (inl, phases) <- rep_inline_phases ispec + ; pragma <- repPragSpec nm1 ty1 inl phases ; return [(loc, pragma)] } +rep_specialiseE :: RuleBndrs GhcRn -> LHsExpr GhcRn -> InlinePragma + -> MetaM (Core (M TH.Dec)) +rep_specialiseE bndrs e ispec + -- New form SPECIALISE pragmas + = repRuleBinders bndrs $ \ ty_bndrs tm_bndrs -> + do { (inl, phases) <- rep_inline_phases ispec + ; exp <- repLE e + ; repPragSpecE ty_bndrs tm_bndrs exp inl phases + } + rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialiseInst ty loc @@ -1122,6 +1158,21 @@ ; pragma <- repPragSpecInst ty1 ; return [(loc, pragma)] } +rep_sccFun :: LocatedN Name + -> Maybe (XRec GhcRn StringLiteral) + -> SrcSpan + -> MetaM [(SrcSpan, Core (M TH.Dec))] +rep_sccFun nm Nothing loc = do + nm1 <- lookupLOcc nm + scc <- repPragSCCFun nm1 + return [(loc, scc)] + +rep_sccFun nm (Just (L _ str)) loc = do + nm1 <- lookupLOcc nm + str1 <- coreStringLit (sl_fs str) + scc <- repPragSCCFunNamed nm1 str1 + return [(loc, scc)] + repInline :: InlineSpec -> MetaM (Core TH.Inline) repInline (NoInline _ ) = dataCon noInlineDataConName -- There is a mismatch between the TH and GHC representation because @@ -1144,11 +1195,11 @@ ; dataCon' fromPhaseDataConName [arg] } repPhases _ = dataCon allPhasesDataConName -rep_complete_sig :: Located [LocatedN Name] +rep_complete_sig :: [LocatedN Name] -> Maybe (LocatedN Name) -> SrcSpan -> MetaM [(SrcSpan, Core (M TH.Dec))] -rep_complete_sig (L _ cls) mty loc +rep_complete_sig cls mty loc = do { mty' <- repMaybe nameTyConName lookupLOcc mty ; cls' <- repList nameTyConName lookupLOcc cls ; sig <- repPragComplete cls' mty' @@ -1188,12 +1239,12 @@ ; rep2 kindedBndrTVName [nm, vis', ki] } rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis) -rep_bndr_vis HsBndrRequired = rep2_nw bndrReqName [] +rep_bndr_vis (HsBndrRequired _) = rep2_nw bndrReqName [] rep_bndr_vis (HsBndrInvisible _) = rep2_nw bndrInvisName [] 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 @@ -1207,7 +1258,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} -> @@ -1216,17 +1267,6 @@ HsOuterExplicit{hso_bndrs = exp_bndrs} -> addHsTyVarBinds FreshNamesOnly exp_bndrs thing_inside --- | If a type implicitly quantifies its outermost type variables, return --- 'True' if the list of implicitly bound type variables is empty. If a type --- explicitly quantifies its outermost type variables, always return 'True'. --- --- This is used in various places to determine if a Template Haskell 'Type' --- should be headed by a 'ForallT' or not. -nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool -nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs -nullOuterImplicit (HsOuterExplicit{}) = True - -- Vacuously true, as there is no implicit quantification - -- | If a type explicitly quantifies its outermost type variables, return -- 'True' if the list of explicitly bound type variables is empty. If a type -- implicitly quantifies its outermost type variables, always return 'True'. @@ -1321,14 +1361,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)) @@ -1382,39 +1430,42 @@ repTForallVis bndrs body1 repTy ty@(HsQualTy {}) = repForallT ty -repTy (HsTyVar _ _ (L _ n)) +repTy (HsTyVar _ _ (L _ (WithUserRdr _ n))) | n `hasKey` liftedTypeKindTyConKey = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon | n `hasKey` fUNTyConKey = repMulArrowTyCon - | isTvOcc occ = do tv1 <- lookupOcc n - repTvar tv1 - | isDataOcc occ = do tc1 <- lookupOcc n - repPromotedDataCon tc1 - | n == eqTyConName = repTequality - | otherwise = do tc1 <- lookupOcc n - repNamedTyCon tc1 + | n `hasKey` eqTyConKey = repTequality + | isVarNameSpace ns = do tv1 <- lookupOcc n + repTvar tv1 + | isDataConNameSpace ns = do dc1 <- lookupOcc n + repPromotedDataCon dc1 + | isTcClsNameSpace ns = do tc1 <- lookupOcc n + repNamedTyCon tc1 + | otherwise = panic "repTy: HsTyVar: unknown namespace" where occ = nameOccName n + ns = occNameSpace occ repTy (HsAppTy _ f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 -repTy (HsAppKindTy _ ty _ ki) = do +repTy (HsAppKindTy _ ty ki) = do ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1 -repTy (HsFunTy _ w f a) | isUnrestricted w = do - f1 <- repLTy f - a1 <- repLTy a +repTy (HsFunTy _ w f a) = do + f1 <- repLTy f + a1 <- repLTy a + case multAnnToHsType w of + Nothing -> do tcon <- repArrowTyCon repTapps tcon [f1, a1] -repTy (HsFunTy _ w f a) = do w1 <- repLTy (arrowToHsType w) - f1 <- repLTy f - a1 <- repLTy a - tcon <- repMulArrowTyCon - repTapps tcon [w1, f1, a1] + Just m -> do + w1 <- repLTy m + tcon <- repMulArrowTyCon + repTapps tcon [w1, f1, a1] repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon @@ -1429,7 +1480,7 @@ repTy (HsSumTy _ tys) = do tys1 <- repLTys tys tcon <- repUnboxedSumTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1) +repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (getName n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy _ t) = repLTy t repTy (HsStarTy _ _) = repTStar @@ -1442,7 +1493,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 @@ -1511,7 +1562,7 @@ repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e) repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) -repE (HsVar _ (L _ x)) = +repE (HsVar _ (L _ (WithUserRdr _ x))) = do { mb_val <- lift $ dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- lift $ globalVar x @@ -1519,28 +1570,30 @@ Just (DsBound y) -> repVarOrCon x (coreVar y) Just (DsSplice e) -> do { e' <- lift $ dsExpr e ; return (MkC e') } } +repE (HsHole (HoleVar (L _ uv))) = do + name <- repRdrName uv + repUnboundVar name +repE (HsHole HoleError) = panic "repE: HoleError" repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar -repE (HsOverLabel _ _ s) = repOverLabel s +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 repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l) = do { a <- repLiteral l; repLit a } -repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m -repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e) -repE (HsLamCase _ LamCase (MG { mg_alts = (L _ ms) })) +repE (HsLam _ LamSingle (MG { mg_alts = L _ [m] })) = repLambda m +repE e@(HsLam _ LamSingle (MG { mg_alts = L _ _ })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e) +repE (HsLam _ LamCase (MG { mg_alts = L _ ms })) = do { ms' <- mapM repMatchTup ms ; core_ms <- coreListM matchTyConName ms' ; repLamCase core_ms } -repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) })) +repE (HsLam _ LamCases (MG { mg_alts = (L _ ms) })) = do { ms' <- mapM repClauseTup ms ; core_ms <- coreListM matchTyConName ms' ; repLamCases core_ms } repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} -repE (HsAppType _ e _ t) - = do { a <- repLE e +repE (HsAppType _ e t) = do { a <- repLE e ; s <- repLTy (hswc_body t) ; repAppType a s } @@ -1553,7 +1606,7 @@ a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -repE (HsPar _ _ x _) = repLE x +repE (HsPar _ x) = repLE x repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase _ e (MG { mg_alts = (L _ ms) })) @@ -1567,13 +1620,13 @@ c <- repLE z repCond a b c repE (HsMultiIf _ alts) - = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts - ; expr' <- repMultiIf (nonEmptyCoreList alts') + = do { (binds, alts') <- NE.unzip <$> mapM repLGRHS alts + ; expr' <- repMultiIf (nonEmptyCoreList' alts') ; wrapGenSyms (concat binds) expr' } -repE (HsLet _ _ bs _ e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repLE e) - ; z <- repLetE ds e2 - ; wrapGenSyms ss z } +repE (HsLet _ bs e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repLE e) + ; z <- repLetE ds e2 + ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet repE e@(HsDo _ ctxt (L _ sts)) @@ -1617,7 +1670,7 @@ ; repUnboxedSum e1 alt arity } repE (RecordCon { rcon_con = c, rcon_flds = flds }) - = do { x <- lookupLOcc c; + = do { x <- lookupWithUserRdrLOcc c; fs <- repFields flds; repRecCon x fs } repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } }) @@ -1655,27 +1708,66 @@ ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsTypedSplice n _) = rep_splice n +repE (HsTypedSplice (HsTypedSpliceNested n) _) = rep_splice n repE (HsUntypedSplice (HsUntypedSpliceNested n) _) = rep_splice n repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e) +repE e@(HsTypedSplice HsTypedSpliceTop _) = pprPanic "repE: top level splice" (ppr e) repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC -repE (HsUnboundVar _ uv) = do - name <- repRdrName uv - repUnboundVar name repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do e1 <- repLE e repGetField e1 f -repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs) -repE (XExpr (HsExpanded orig_expr ds_expr)) +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 <- repFunArrMult 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 ; if rebindable_on -- See Note [Quotation and rebindable syntax] - then repE ds_expr - else repE orig_expr } + then repE x + else repE e } + | otherwise + = notHandled (ThExpressionForm e) + +repE (XExpr (PopErrCtxt (L _ e))) = repE e +repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x)) + repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e) repE e@(HsTypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsProc{}) = notHandled (ThExpressionForm e) +repFunArrMult :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> MetaM (Core (M TH.Exp)) +repFunArrMult mult = case multAnnToHsExpr mult of + Nothing -> repConName unrestrictedFunTyConName + Just e -> do { fun <- repConName fUNTyConName + ; mult' <- repLE e + ; repApp fun mult' } + +repConName :: Name -> MetaM (Core (M TH.Exp)) +repConName n = do + core_name <- lift $ globalVar n + repCon core_name + {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1696,14 +1788,14 @@ a type error from the splice. We consult the module-wide RebindableSyntax flag here. We could instead record -the choice in HsExpanded, but it seems simpler to consult the flag (again). +the choice in ExpandedThingRn, but it seems simpler to consult the flag (again). -} ----------------------------------------------------------------------------- -- 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 { @@ -1713,10 +1805,10 @@ ; gs <- repGuards guards ; match <- repMatch p1 gs ds ; wrapGenSyms (ss1++ss2) match }}} -repMatchTup _ = panic "repMatchTup: case alt with more than one arg" +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 { @@ -1727,13 +1819,13 @@ ; clause <- repClause ps1 gs ds ; wrapGenSyms (ss1++ss2) clause }}} -repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> MetaM (Core (M TH.Body)) -repGuards [L _ (GRHS _ [] e)] +repGuards :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> MetaM (Core (M TH.Body)) +repGuards (L _ (GRHS _ [] e) :| []) = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM repLGRHS other - ; let (xs, ys) = unzip zs - ; gd <- repGuarded (nonEmptyCoreList ys) + ; let (xs, ys) = NE.unzip zs + ; gd <- repGuarded (nonEmptyCoreList' ys) ; wrapGenSyms (concat xs) gd } repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) @@ -1761,11 +1853,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 + } @@ -1818,8 +1918,8 @@ ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } repSts (ParStmt _ stmt_blocks _ _ : ss) = - do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks - ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 + do { (ss_s, stmt_blocks1) <- unzip <$> traverse rep_stmt_block stmt_blocks + ; let stmt_blocks2 = nonEmptyCoreList' stmt_blocks1 ss1 = concat ss_s ; z <- repParSt stmt_blocks2 ; (ss2, zs) <- addBinds ss1 (repSts ss) @@ -1891,14 +1991,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 @@ -1910,7 +2010,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 @@ -1964,11 +2064,11 @@ -- their pattern-only bound right hand sides have different names, -- we want to treat them the same in TH. This is the reason why we -- need an adjusted mkGenArgSyms in the `RecCon` case below. - mkGenArgSyms (PrefixCon _ args) = mkGenSyms (map unLoc args) + mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] mkGenArgSyms (RecCon fields) = do { let pats = map (unLoc . recordPatSynPatVar) fields - sels = map (foExt . recordPatSynField) fields + sels = map (unLoc . foLabel . recordPatSynField) fields ; ss <- mkGenSyms sels ; return $ replaceNames (zip sels pats) ss } @@ -1992,7 +2092,7 @@ = rep2 patSynDName [syn, args, dir, pat] repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs)) -repPatSynArgs (PrefixCon _ args) +repPatSynArgs (PrefixCon args) = do { args' <- repList nameTyConName lookupLOcc args ; repPrefixPatSynArgs args' } repPatSynArgs (InfixCon arg1 arg2) @@ -2000,7 +2100,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 @@ -2050,8 +2150,8 @@ -- (\ p1 .. pn -> exp) by causing an error. repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) -repLambda (L _ (Match { m_pats = ps - , m_grhss = GRHSs _ [L _ (GRHS _ [] e)] +repLambda (L _ (Match { m_pats = L _ ps + , m_grhss = GRHSs _ (L _ (GRHS _ [] e) :| []) (EmptyLocalBinds _) } )) = do { let bndrs = collectPatsBinders CollNoDictBinders ps ; ; ss <- mkGenSyms bndrs @@ -2073,6 +2173,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) @@ -2082,9 +2185,9 @@ repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat _ x _ p) = do { x' <- lookupNBinder x; p1 <- repLP p +repP (AsPat _ x p) = do { x' <- lookupNBinder x; p1 <- repLP p ; repPaspat x' p1 } -repP (ParPat _ _ p _) = repLP p +repP (ParPat _ p) = repLP p repP (ListPat _ ps) = do { qs <- repLPs ps; repPlist qs } repP (TuplePat _ ps boxed) | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } @@ -2092,12 +2195,11 @@ repP (SumPat _ p alt arity) = do { p1 <- repLP p ; repPunboxedSum p1 alt arity } repP (ConPat NoExtField dc details) - = do { con_str <- lookupLOcc dc + = do { con_str <- lookupWithUserRdrLOcc dc ; case details of - PrefixCon tyargs ps -> do { qs <- repLPs ps - ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hsps_body t) - ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs - ; repPcon con_str ts qs } + PrefixCon ps -> do { ts' <- repListM typeTyConName (repTy . unLoc . hstp_body) (takeHsConPatTyArgs ps) + ; ps' <- repLPs (dropHsConPatTyArgs ps) + ; repPcon con_str ts' ps' } RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) ; repPrec con_str fps } InfixCon p1 p2 -> do { p1' <- repLP p1; @@ -2123,6 +2225,11 @@ repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } +repP (EmbTyPat _ t) = do { t' <- repLTy (hstp_body t) + ; 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) @@ -2190,6 +2297,9 @@ -- Use the in-scope bindings if they exist lookupLOcc n = lookupOcc (unLoc n) +lookupWithUserRdrLOcc :: GenLocated l (WithUserRdr Name) -> MetaM (Core TH.Name) +lookupWithUserRdrLOcc (L _loc (WithUserRdr _rdr n)) = lookupOcc n + lookupOcc :: Name -> MetaM (Core TH.Name) lookupOcc = lift . lookupOccDsM @@ -2376,9 +2486,18 @@ 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] +repPtype :: Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPtype (MkC t) = rep2 typePName [t] + +repPinvis :: Core (M TH.Type) -> MetaM (Core (M TH.Pat)) +repPinvis (MkC t) = rep2 invisPName [t] + --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp)) repVarOrCon vc str @@ -2399,6 +2518,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] @@ -2634,6 +2756,12 @@ just = coreJust overlapTyConName +repNamespaceSpecifier :: NamespaceSpecifier -> MetaM (Core (TH.NamespaceSpecifier)) +repNamespaceSpecifier ns_spec = case ns_spec of + NoNamespaceSpecifier{} -> dataCon noNamespaceSpecifierDataConName + TypeNamespaceSpecifier{} -> dataCon typeNamespaceSpecifierDataConName + DataNamespaceSpecifier{} -> dataCon dataNamespaceSpecifierDataConName + repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> Core [TH.FunDep] -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) @@ -2654,15 +2782,26 @@ repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec)) repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm] -repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases +repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Maybe (Core (TH.Inline)) + -> Core TH.Phases -> MetaM (Core (M TH.Dec)) -repPragSpec (MkC nm) (MkC ty) (MkC phases) - = rep2 pragSpecDName [nm, ty, phases] +repPragSpec (MkC nm) (MkC ty) mb_inl (MkC phases) + = case mb_inl of + Nothing -> + rep2 pragSpecDName [nm, ty, phases] + Just (MkC inl) -> + rep2 pragSpecInlDName [nm, ty, inl, phases] -repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline - -> Core TH.Phases -> MetaM (Core (M TH.Dec)) -repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) - = rep2 pragSpecInlDName [nm, ty, inline, phases] +repPragSpecE :: Core (Maybe [M (TH.TyVarBndr ())]) -> Core [(M TH.RuleBndr)] + -> Core (M TH.Exp) + -> Maybe (Core TH.Inline) -> Core TH.Phases + -> MetaM (Core (M TH.Dec)) +repPragSpecE (MkC ty_bndrs) (MkC tm_bndrs) (MkC expr) mb_inl (MkC phases) + = case mb_inl of + Nothing -> + rep2 pragSpecEDName [ty_bndrs, tm_bndrs, expr, phases] + Just (MkC inl) -> + rep2 pragSpecInlEDName [ty_bndrs, tm_bndrs, expr, inl, phases] repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec)) repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] @@ -2679,6 +2818,12 @@ repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec)) repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] +repPragSCCFun :: Core TH.Name -> MetaM (Core (M TH.Dec)) +repPragSCCFun (MkC nm) = rep2 pragSCCFunDName [nm] + +repPragSCCFunNamed :: Core TH.Name -> Core String -> MetaM (Core (M TH.Dec)) +repPragSCCFunNamed (MkC nm) (MkC str) = rep2 pragSCCFunNamedDName [nm, str] + repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec)) repTySynInst (MkC eqn) = rep2 tySynInstDName [eqn] @@ -2731,13 +2876,13 @@ repH98DataCon con details = do con' <- lookupLOcc con -- See Note [Binders and occurrences] case details of - PrefixCon _ ps -> do - arg_tys <- repPrefixConArgs ps + PrefixCon ps -> do + arg_tys <- repPrefixConArgs IsNotPrefixConGADT ps rep2 normalCName [unC con', unC arg_tys] InfixCon st1 st2 -> do - verifyLinearFields [st1, st2] - arg1 <- repBangTy (hsScaledThing st1) - arg2 <- repBangTy (hsScaledThing st2) + verifyLinearFields IsNotPrefixConGADT [st1, st2] + arg1 <- repConDeclField st1 + arg2 <- repConDeclField st2 rep2 infixCName [unC arg1, unC con', unC arg2] RecCon ips -> do arg_vtys <- repRecConArgs ips @@ -2750,11 +2895,11 @@ repGadtDataCons cons details res_ty = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] case details of - PrefixConGADT ps -> do - arg_tys <- repPrefixConArgs ps + PrefixConGADT _ ps -> do + arg_tys <- repPrefixConArgs IsPrefixConGADT ps res_ty' <- repLTy res_ty rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] - RecConGADT ips _ -> do + RecConGADT _ ips -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys, @@ -2763,36 +2908,37 @@ -- TH currently only supports linear constructors. -- We also accept the (->) arrow when -XLinearTypes is off, because this -- denotes a linear field. --- This check is not performed in repRecConArgs, since the GADT record --- syntax currently does not have a way to mark fields as nonlinear. -verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM () -verifyLinearFields ps = do - linear <- lift $ xoptM LangExt.LinearTypes - let allGood = all (\st -> case hsMult st of - HsUnrestrictedArrow _ -> not linear - HsLinearArrow _ -> True - _ -> False) ps +verifyLinearFields :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM () +verifyLinearFields isPrefixConGADT ps = do + linear <- lift $ unannotatedMultIsLinear isPrefixConGADT + let allGood = all (hsMultIsLinear linear . cdf_multiplicity) ps unless allGood $ notHandled ThNonLinearDataCon + where + hsMultIsLinear linear HsUnannotated{} = linear + hsMultIsLinear _ HsLinearAnn{} = True + hsMultIsLinear _ (HsExplicitMult _ (L _ (HsTyVar _ _ (L _ n)))) = getName n == oneDataConName + hsMultIsLinear _ _ = False -- Desugar the arguments in a data constructor declared with prefix syntax. -repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)] - -> MetaM (Core [M TH.BangType]) -repPrefixConArgs ps = do - verifyLinearFields ps - repListM bangTypeTyConName repBangTy (map hsScaledThing ps) +repPrefixConArgs :: IsPrefixConGADT -> [HsConDeclField GhcRn] -> MetaM (Core [M TH.BangType]) +repPrefixConArgs isPrefixConGADT ps = do + verifyLinearFields isPrefixConGADT ps + repListM bangTypeTyConName repConDeclField ps -- Desugar the arguments in a data constructor declared with record syntax. -repRecConArgs :: LocatedL [LConDeclField GhcRn] +repRecConArgs :: LocatedL [LHsConDeclRecField GhcRn] -> MetaM (Core [M TH.VarBangType]) -repRecConArgs ips = do - args <- concatMapM rep_ip (unLoc ips) +repRecConArgs lips = do + let ips = map unLoc (unLoc lips) + verifyLinearFields IsNotPrefixConGADT (map cdrf_spec ips) + args <- concatMapM rep_ip ips coreListM varBangTypeTyConName args where - rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) + rep_ip ip = mapM (rep_one_ip (cdrf_spec ip)) (cdrf_names ip) - rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) - rep_one_ip t n = do { MkC v <- lookupOcc (foExt $ unLoc n) - ; MkC ty <- repBangTy t + rep_one_ip :: HsConDeclField GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType)) + rep_one_ip t n = do { MkC v <- lookupOcc (unLoc . foLabel $ unLoc n) + ; MkC ty <- repConDeclField t ; rep2 varBangTypeName [v,ty] } ------------ Types ------------------- @@ -2909,7 +3055,7 @@ ---------------------------------------------------------- -- Literals -repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) +repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) repLiteral (HsStringPrim _ bs) = do word8_ty <- lookupType word8TyConName let w8s = unpack bs @@ -2918,20 +3064,19 @@ rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit = do lit' <- case lit of - HsIntPrim _ i -> mk_integer i - HsWordPrim _ w -> mk_integer w - HsInt _ i -> mk_integer (il_value i) - HsFloatPrim _ r -> mk_rational r - HsDoublePrim _ r -> mk_rational r - HsCharPrim _ c -> mk_char c - _ -> return lit - lit_expr <- lift $ dsLit lit' + HsIntPrim _ i -> lift . dsLit <$> mk_integer i + HsWordPrim _ w -> lift . dsLit <$> mk_integer w + HsInt _ i -> lift . dsLit <$> mk_integer (il_value i) + HsFloatPrim _ r -> lift . dsLit <$> mk_rational r + HsDoublePrim _ r -> lift . dsLit <$> mk_rational r + HsCharPrim _ c -> lift . dsLit <$> mk_char c + _ -> return . lift . dsLit $ lit + lit_expr <- lit' case mb_lit_name of Just lit_name -> rep2_nw lit_name [lit_expr] Nothing -> notHandled (ThExoticLiteral lit) where mb_lit_name = case lit of - HsInteger _ _ _ -> Just integerLName HsInt _ _ -> Just integerLName HsIntPrim _ _ -> Just intPrimLName HsWordPrim _ _ -> Just wordPrimLName @@ -2940,15 +3085,16 @@ HsChar _ _ -> Just charLName HsCharPrim _ _ -> Just charPrimLName HsString _ _ -> Just stringLName - HsRat _ _ _ -> Just rationalLName + HsMultilineString _ _ -> Just stringLName _ -> Nothing -mk_integer :: Integer -> MetaM (HsLit GhcRn) -mk_integer i = return $ HsInteger NoSourceText i integerTy +mk_integer :: Integer -> MetaM (HsLit GhcTc) +mk_integer i = return $ XLit $ HsInteger NoSourceText i integerTy -mk_rational :: FractionalLit -> MetaM (HsLit GhcRn) +mk_rational :: FractionalLit -> MetaM (HsLit GhcTc) mk_rational r = do rat_ty <- lookupType rationalTyConName - return $ HsRat noExtField r rat_ty + return $ XLit $ HsRat r rat_ty + mk_string :: FastString -> MetaM (HsLit GhcRn) mk_string s = return $ HsString NoSourceText s @@ -2957,16 +3103,26 @@ repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) - = do { lit <- mk_lit val; repLiteral lit } - -- The type Rational will be in the environment, because - -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, - -- and rationalL is sucked in when any TH stuff is used + = repOverLiteralVal val + -- The type Rational will be in the environment, because + -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, + -- and rationalL is sucked in when any TH stuff is used -mk_lit :: OverLitVal -> MetaM (HsLit GhcRn) -mk_lit (HsIntegral i) = mk_integer (il_value i) -mk_lit (HsFractional f) = mk_rational f -mk_lit (HsIsString _ s) = mk_string s +repOverLiteralVal :: OverLitVal -> MetaM (Core TH.Lit) +repOverLiteralVal lit = do + lit' <- case lit of + (HsIntegral i) -> lift . dsLit <$> mk_integer (il_value i) + (HsFractional f) -> lift . dsLit <$> mk_rational f + (HsIsString _ s) -> lift . dsLit <$> mk_string s + lit_expr <- lit' + let lit_name = case lit of + (HsIntegral _ ) -> integerLName + (HsFractional _) -> rationalLName + (HsIsString _ _) -> stringLName + + rep2_nw lit_name [lit_expr] + repRdrName :: RdrName -> MetaM (Core TH.Name) repRdrName rdr_name = do case rdr_name of @@ -3036,6 +3192,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 diff --git a/GHC/HsToCore/Ticks.hs b/GHC/HsToCore/Ticks.hs --- a/GHC/HsToCore/Ticks.hs +++ b/GHC/HsToCore/Ticks.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) Galois, 2006 (c) University of Glasgow, 2007 +(c) Florian Ragwitz, 2025 -} module GHC.HsToCore.Ticks @@ -28,7 +27,6 @@ import GHC.Data.Maybe import GHC.Data.FastString -import GHC.Data.Bag import GHC.Data.SizedSeq import GHC.Driver.Flags (DumpFlag(..)) @@ -39,7 +37,9 @@ import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name import GHC.Types.CostCentre @@ -49,10 +49,12 @@ import Control.Monad import Data.List (isSuffixOf, intersperse) +import Data.Foldable (toList) import Trace.Hpc.Mix import Data.Bifunctor (second) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Set (Set) import qualified Data.Set as Set @@ -87,7 +89,6 @@ , tick_label :: BoxLabel -- ^ Label for the tick counter } - addTicksToBinds :: Logger -> TicksConfig @@ -124,6 +125,7 @@ , density = mkDensity tickish $ ticks_profAuto cfg , this_mod = mod , tickishType = tickish + , recSelBinds = emptyVarEnv } (binds',_,st') = unTM (addTickLHsBinds binds) env st in (binds', st') @@ -219,14 +221,13 @@ -- 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 , abs_exports = abs_exports }))) = - withEnv add_exports $ - withEnv add_inlines $ do + withEnv (add_rec_sels . add_inlines . add_exports) $ do binds' <- addTickLHsBinds binds return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where @@ -248,7 +249,13 @@ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports , isInlinePragma (idInlinePragma pid) ] } -addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do + add_rec_sels env = + env{ recSelBinds = recSelBinds env `extendVarEnvList` + [ (abe_mono, abe_poly) + | ABE{ abe_poly, abe_mono } <- abs_exports + , RecSelId{} <- [idDetails abe_poly] ] } + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id, fun_matches = matches }))) = do let name = getOccString id decl_path <- getPathEntry density <- getDensity @@ -262,10 +269,14 @@ tickish <- tickishType `liftM` getEnv case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + -- See Note [Record-selector ticks] + selTick <- recSelTick id + case selTick of { Just tick -> tick_rec_sel tick; _ -> do + (fvs, mg) <- getFreeVars $ addPathEntry name $ - addTickMatchGroup False (fun_matches funBind) + addTickMatchGroup False matches blackListed <- isBlackListed (locA pos) exported_names <- liftM exports getEnv @@ -273,7 +284,9 @@ -- We don't want to generate code for blacklisted positions -- We don't want redundant ticks on simple pattern bindings -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = isSimplePatBind funBind + let simple = matchGroupArity matches == 0 + -- A binding is a "simple pattern binding" if it is a + -- funbind with zero patterns toplev = null decl_path exported = idName id `elemNameSet` exported_names @@ -287,24 +300,52 @@ let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg , fun_ext = second (tick `mbCons`) (fun_ext funBind) } - } + } } + where + -- See Note [Record-selector ticks] + tick_rec_sel tick = + pure $ L pos $ funBind { fun_ext = second (tick :) (fun_ext funBind) } - where - -- a binding is a simple pattern binding if it is a funbind with - -- zero patterns - isSimplePatBind :: HsBind GhcTc -> Bool - isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 +-- Note [Record-selector ticks] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Users expect (see #17834) that accessing a record field by its name using +-- NamedFieldPuns or RecordWildCards will mark it as covered. This is very +-- reasonable, because otherwise the use of those two language features will +-- produce unnecessary noise in coverage reports, distracting from real +-- coverage problems. +-- +-- Because of that, GHC chooses to treat record selectors specially for +-- coverage purposes to improve the developer experience. +-- +-- This is done by keeping track of which 'Id's are effectively bound to +-- record fields (using NamedFieldPuns or RecordWildCards) in 'TickTransEnv's +-- 'recSelBinds', and making 'HsVar's corresponding to those fields tick the +-- appropriate box when executed. +-- +-- To enable that, we also treat 'FunBind's for record selector functions +-- specially. We only create a TopLevelBox for the record selector function, +-- skipping the ExpBox that'd normally be created. This simplifies the re-use +-- of ticks for the same record selector, and is done by not recursing into +-- the fun_matches match group for record selector functions. +-- +-- This scheme could be extended further in the future, making coverage for +-- constructor fields (named or even positional) mean that the field was +-- accessed at run-time. For the time being, we only cover NamedFieldPuns and +-- RecordWildCards binds to cover most practical use-cases while keeping it +-- simple. + -- TODO: Revisit this addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs - , pat_rhs = rhs }))) = do + , pat_rhs = rhs + , pat_ext = (grhs_ty, initial_ticks)}))) = do let simplePatId = isSimplePat lhs -- TODO: better name for rhs's for non-simple patterns? let name = maybe "(...)" getOccString simplePatId - (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False False rhs let pat' = pat { pat_rhs = rhs'} -- Should create ticks here? @@ -315,15 +356,13 @@ then return (L pos pat') else do - let mbCons = maybe id (:) - - let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat' - -- Allocate the ticks - rhs_tick <- bindTick density name (locA pos) fvs - let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks + let mbCons = maybe id (:) + (initial_rhs_ticks, initial_patvar_tickss) = initial_ticks + rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks + patvar_tickss <- case simplePatId of Just{} -> return initial_patvar_tickss Nothing -> do @@ -333,7 +372,7 @@ (zipWith mbCons patvar_ticks (initial_patvar_tickss ++ repeat [])) - return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') } + return $ L pos $ pat' { pat_ext = (grhs_ty, (rhs_ticks, patvar_tickss)) } -- Only internal stuff, not from source, uses VarBind, so we ignore it. addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind @@ -375,7 +414,9 @@ d <- getDensity case d of TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage -> tick_it + TickForCoverage | XExpr (ExpandedThingTc OrigStmt{} _) <- e0 -- expansion ticks are handled separately + -> dont_tick_it + | otherwise -> tick_it TickCallSites | isCallSite e0 -> tick_it _other -> dont_tick_it where @@ -426,6 +467,8 @@ _other -> addTickLHsExprEvalInner e where tick_it = allocTickBox (ExpBox False) False False (locA pos) + -- don't allow duplicates of this forced bp + $ withBlackListed (locA pos) $ addTickHsExpr e0 dont_tick_it = addTickLHsExprNever e @@ -440,28 +483,31 @@ -- General heuristic: expressions which are calls (do not denote -- values) are good break points. isGoodBreakExpr :: HsExpr GhcTc -> Bool +isGoodBreakExpr (XExpr (ExpandedThingTc (OrigStmt{}) _)) = False isGoodBreakExpr e = isCallSite e isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True isCallSite HsAppType{} = True -isCallSite (XExpr (ExpansionExpr (HsExpanded _ e))) - = isCallSite e +isCallSite HsCase{} = True +isCallSite (XExpr (ExpandedThingTc _ e)) + = isCallSite e + -- NB: OpApp, SectionL, SectionR are all expanded out isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprOptAlt oneOfMany (L pos e0) +addTickLHsExprOptAlt oneOfMany e@(L pos e0) = ifDensity TickForCoverage (allocTickBox (ExpBox oneOfMany) False False (locA pos) - $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) + $ addTickHsExpr e0) + (addTickLHsExpr e) addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (L pos e0) +addBinTickLHsExpr boxLabel e@(L pos e0) = ifDensity TickForCoverage (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) + (addTickLHsExpr e) -- ----------------------------------------------------------------------------- @@ -470,23 +516,26 @@ -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e -addTickHsExpr e@(HsUnboundVar {}) = return e -addTickHsExpr e@(HsRecSel _ (FieldOcc id _)) = do freeVar id; return e - +-- See Note [Record-selector ticks] +addTickHsExpr e@(HsVar _ (L _ id)) = + freeVar id >> recSelTick id >>= pure . maybe e wrap + where wrap tick = XExpr . HsTick tick . noLocA $ e addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e addTickHsExpr e@(HsLit {}) = return e -addTickHsExpr (HsLam x mg) = liftM (HsLam x) +addTickHsExpr e@(HsEmbTy {}) = return e +addTickHsExpr e@(HsHole {}) = 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 (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant) - (addTickMatchGroup True mgs) addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) (addTickLHsExpr e2) -addTickHsExpr (HsAppType x e at ty) = do +addTickHsExpr (HsAppType x e ty) = do e' <- addTickLHsExprNever e - return (HsAppType x e' at ty) + return (HsAppType x e' ty) addTickHsExpr (OpApp fix e1 e2 e3) = liftM4 OpApp (return fix) @@ -497,9 +546,9 @@ liftM2 (NegApp x) (addTickLHsExpr e) (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar x lpar e rpar) = do +addTickHsExpr (HsPar x e) = do e' <- addTickLHsExprEvalInner e - return (HsPar x lpar e' rpar) + return (HsPar x e') addTickHsExpr (SectionL x e1 e2) = liftM2 (SectionL x) (addTickLHsExpr e1) @@ -520,27 +569,21 @@ (addTickLHsExpr e) -- not an EvalInner; e might not necessarily -- be evaluated. (addTickMatchGroup False mgs) + addTickHsExpr (HsIf x e1 e2 e3) = liftM3 (HsIf x) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsExprOptAlt True e2) (addTickLHsExprOptAlt True e3) addTickHsExpr (HsMultiIf ty alts) - = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts + = do { let isOneOfMany = case alts of { (_ :| []) -> False; _ -> True; } + ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False False) alts ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x tkLet binds tkIn e) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ do +addTickHsExpr (HsLet x binds e) = + bindLocals binds $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. e' <- addTickLHsExprLetBody e - return (HsLet x tkLet binds' tkIn e') -addTickHsExpr (HsDo srcloc cxt (L l stmts)) - = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) - ; return (HsDo srcloc cxt (L l stmts')) } - where - forQual = case cxt of - ListComp -> Just $ BinBox QualBinBox - _ -> Nothing + return (HsLet x binds' e') addTickHsExpr (ExplicitList ty es) = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es) @@ -585,15 +628,14 @@ addTickHsExpr e@(HsGetField {}) = return e addTickHsExpr e@(HsProjection {}) = return e addTickHsExpr (HsProc x pat cmdtop) = + bindLocals pat $ 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 (ExpansionExpr (HsExpanded a b))) = - liftM (XExpr . ExpansionExpr . HsExpanded a) $ - (addTickHsExpr b) +addTickHsExpr (XExpr (ExpandedThingTc o e)) = addTickHsExpanded o e addTickHsExpr e@(XExpr (ConLikeTc {})) = return e -- We used to do a freeVar on a pat-syn builder, but actually @@ -606,6 +648,35 @@ addTickHsExpr (XExpr (HsBinTick t0 t1 e)) = liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e) +addTickHsExpr e@(XExpr (HsRecSelTc (FieldOcc _ id))) = do freeVar (unLoc id); return e + +addTickHsExpr (HsDo srcloc cxt (L l stmts)) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo srcloc cxt (L l stmts')) } + where + forQual = case cxt of + ListComp -> Just $ BinBox QualBinBox + _ -> Nothing + +addTickHsExpanded :: HsThingRn -> HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpanded o e = liftM (XExpr . ExpandedThingTc o) $ case o of + -- We always want statements to get a tick, so we can step over each one. + -- To avoid duplicates we blacklist SrcSpans we already inserted here. + OrigStmt (L pos _) -> do_tick_black pos + _ -> skip + where + skip = addTickHsExpr e + do_tick_black pos = do + d <- getDensity + case d of + TickForCoverage -> tick_it_black pos + TickForBreakPoints -> tick_it_black pos + _ -> skip + tick_it_black pos = + unLoc <$> allocTickBox (ExpBox False) False False (locA pos) + (withBlackListed (locA pos) $ + addTickHsExpr e) + addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e ; return (Present x e') } @@ -614,41 +685,49 @@ addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches, mg_ext = ctxt }) = do let isOneOfMany = matchesOneOfMany matches - matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam)) matches + isDoExp = isDoExpansionGenerated $ mg_origin ctxt + matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam isDoExp)) matches return $ mg { mg_alts = L l matches' } -addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc) +addTickMatch :: Bool -> Bool -> Bool {-Is this Do Expansion-} -> Match GhcTc (LHsExpr GhcTc) -> TM (Match GhcTc (LHsExpr GhcTc)) -addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats - , m_grhss = gRHSs }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do - gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs +addTickMatch isOneOfMany isLambda isDoExp match@(Match { m_pats = L _ pats + , m_grhss = gRHSs }) = + bindLocals pats $ do + gRHSs' <- addTickGRHSs isOneOfMany isLambda isDoExp gRHSs return $ match { m_grhss = gRHSs' } -addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) +addTickGRHSs :: Bool -> Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) = - bindLocals binders $ do +addTickGRHSs isOneOfMany isLambda isDoExp (GRHSs x guarded local_binds) = + bindLocals local_binds $ do local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda)) guarded + guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda isDoExp)) guarded return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds -addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) +addTickGRHS :: Bool -> Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do +addTickGRHS isOneOfMany isLambda isDoExp (GRHS x stmts expr) = do (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts - (addTickGRHSBody isOneOfMany isLambda expr) + (addTickGRHSBody isOneOfMany isLambda isDoExp expr) return $ GRHS x stmts' expr' -addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do +addTickGRHSBody :: Bool -> Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickGRHSBody isOneOfMany isLambda isDoExp expr@(L pos e0) = do d <- getDensity case d of - TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr + TickForBreakPoints + | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded` + -> addTickLHsExprNever expr + | otherwise + -> addTickLHsExprRHS expr + TickForCoverage + | isDoExp -- ticks for do-expansions are handled by `addTickHsExpanded` + -> addTickLHsExprNever expr + | otherwise + -> addTickLHsExprOptAlt isOneOfMany expr TickAllFunctions | isLambda -> addPathEntry "\\" $ allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ @@ -665,7 +744,7 @@ addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ + = bindLocals lstmts $ do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts ; a <- res ; return (lstmts', a) } @@ -678,6 +757,7 @@ (pure noret) (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt xbs pat e) = + bindLocals pat $ liftM4 (\b f -> BindStmt $ XBindStmtTc { xbstc_bindOp = b , xbstc_boundResultType = xbstc_boundResultType xbs @@ -701,9 +781,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 @@ -726,6 +803,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 @@ -737,17 +818,19 @@ liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) where addTickArg (ApplicativeArgOne m_fail pat expr isBody) = - ApplicativeArgOne - <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail - <*> addTickLPat pat - <*> addTickLHsExpr expr - <*> pure isBody + bindLocals pat $ + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = - (ApplicativeArgMany x) - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) - <*> addTickLPat pat - <*> pure ctxt + bindLocals pat $ + ApplicativeArgMany x + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) + <*> addTickLPat pat + <*> pure ctxt addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc -> TM (ParStmtBlock GhcTc GhcTc) @@ -813,8 +896,8 @@ return $ L pos c1 addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam x matchgroup) = - liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdLam x lam_variant mgs) = + liftM (HsCmdLam x lam_variant) (addTickCmdMatchGroup mgs) addTickHsCmd (HsCmdApp x c e) = liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) {- @@ -825,25 +908,23 @@ (return fix) (addTickLHsCmd c3) -} -addTickHsCmd (HsCmdPar x lpar e rpar) = do +addTickHsCmd (HsCmdPar x e) = do e' <- addTickLHsCmd e - return (HsCmdPar x lpar e' rpar) + return (HsCmdPar x e') addTickHsCmd (HsCmdCase x e mgs) = liftM2 (HsCmdCase x) (addTickLHsExpr e) (addTickCmdMatchGroup mgs) -addTickHsCmd (HsCmdLamCase x lc_variant mgs) = - liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs) addTickHsCmd (HsCmdIf x cnd e1 c2 c3) = liftM3 (HsCmdIf x cnd) (addBinTickLHsExpr (BinBox CondBinBox) e1) (addTickLHsCmd c2) (addTickLHsCmd c3) -addTickHsCmd (HsCmdLet x tkLet binds tkIn c) = - bindLocals (collectLocalBinders CollNoDictBinders binds) $ do +addTickHsCmd (HsCmdLet x binds c) = + bindLocals binds $ do binds' <- addTickHsLocalBinds binds -- to think about: !patterns. c' <- addTickLHsCmd c - return (HsCmdLet x tkLet binds' tkIn c') + return (HsCmdLet x binds' c') addTickHsCmd (HsCmdDo srcloc (L l stmts)) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) ; return (HsCmdDo srcloc (L l stmts')) } @@ -855,11 +936,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)) = @@ -876,19 +956,17 @@ 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 }) = - bindLocals (collectPatsBinders CollNoDictBinders pats) $ do +addTickCmdMatch match@(Match { m_pats = L _ pats, m_grhss = gRHSs }) = + bindLocals pats $ do gRHSs' <- addTickCmdGRHSs gRHSs return $ match { m_grhss = gRHSs' } addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) addTickCmdGRHSs (GRHSs x guarded local_binds) = - bindLocals binders $ do + bindLocals local_binds $ do local_binds' <- addTickHsLocalBinds local_binds guarded' <- mapM (traverse addTickCmdGRHS) guarded return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is @@ -907,15 +985,14 @@ addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) addTickLCmdStmts' lstmts res - = bindLocals binders $ do + = bindLocals lstmts $ do lstmts' <- mapM (traverse addTickCmdStmt) lstmts a <- res return (lstmts', a) - where - binders = collectLStmtsBinders CollNoDictBinders lstmts addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) addTickCmdStmt (BindStmt x pat c) = + bindLocals pat $ liftM2 (BindStmt x) (addTickLPat pat) (addTickLHsCmd c) @@ -939,16 +1016,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)) @@ -976,11 +1053,13 @@ data TickTransState = TT { ticks :: !(SizedSeq Tick) , ccIndices :: !CostCentreState + , recSelTicks :: !(IdEnv CoreTickish) } initTTState :: TickTransState initTTState = TT { ticks = emptySS , ccIndices = newCostCentreState + , recSelTicks = emptyVarEnv } addMixEntry :: Tick -> TM Int @@ -991,6 +1070,10 @@ } return c +addRecSelTick :: Id -> CoreTickish -> TM () +addRecSelTick sel tick = + setState $ \s -> s{ recSelTicks = extendVarEnv (recSelTicks s) sel tick } + data TickTransEnv = TTE { fileName :: FastString , density :: TickDensity , tte_countEntries :: !Bool @@ -1003,6 +1086,7 @@ , blackList :: Set RealSrcSpan , this_mod :: Module , tickishType :: TickishType + , recSelBinds :: IdEnv Id } -- deriving Show @@ -1060,6 +1144,7 @@ (r2,fv2,st2) -> (r2, fv1 `plusOccEnv` fv2, st2) + -- | Get the next HPC cost centre index for a given centre name getCCIndexM :: FastString -> TM CostCentreIndex getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ @@ -1115,20 +1200,26 @@ tickish <- tickishType `liftM` getEnv let need_same_file = tickSameFileOnly tickish same_file = Just file_name == srcSpanFileName_maybe pos - return (isGoodSrcSpan' pos && (not need_same_file || same_file)) + isBL <- isBlackListed pos + return (isGoodSrcSpan' pos && not isBL && (not need_same_file || same_file)) ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a ifGoodTickSrcSpan pos then_code else_code = do good <- isGoodTickSrcSpan pos if good then then_code else else_code -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] +bindLocals :: (CollectBinders bndr, CollectFldBinders bndr) => bndr -> TM a -> TM a +bindLocals from (TM m) = TM $ \env st -> + case m (with_bnds env) st of + (r, fv, st') -> (r, fv `delListFromOccEnv` (map (nameOccName . idName) new_bnds), st') + where with_bnds e = e{ inScope = inScope e `extendVarSetList` new_bnds + , recSelBinds = recSelBinds e `plusVarEnv` collectFldBinds from } + new_bnds = collectBinds from +withBlackListed :: SrcSpan -> TM a -> TM a +withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) +withBlackListed (UnhelpfulSpan _) = id + isBlackListed :: SrcSpan -> TM Bool isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) isBlackListed (UnhelpfulSpan _) = return False @@ -1137,17 +1228,30 @@ -- expression argument to support nested box allocations allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) -> TM (LHsExpr GhcTc) -allocTickBox boxLabel countEntries topOnly pos m = - ifGoodTickSrcSpan pos (do - (fvs, e) <- getFreeVars m - env <- getEnv - tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)) - ) (do - e <- m - return (L (noAnnSrcSpan pos) e) - ) +allocTickBox boxLabel countEntries topOnly pos m + = ifGoodTickSrcSpan pos good_case skip_case + where + this_loc = L (noAnnSrcSpan pos) + skip_case = do + e <- m + return (this_loc e) + good_case = do + (fvs, e) <- getFreeVars m + env <- getEnv + tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) + return (this_loc (XExpr $ HsTick tickish $ this_loc e)) +recSelTick :: Id -> TM (Maybe CoreTickish) +recSelTick id = ifDensity TickForCoverage maybe_tick (pure Nothing) + where + maybe_tick = getEnv >>= + maybe (pure Nothing) tick . (`lookupVarEnv` id) . recSelBinds + tick sel = getState >>= + maybe (alloc sel) (pure . Just) . (`lookupVarEnv` sel) . recSelTicks + alloc sel = allocATickBox (box sel) False False (getSrcSpan sel) noFVs + >>= traverse (\t -> t <$ addRecSelTick sel t) + box sel = TopLevelBox [getOccString sel] + -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars @@ -1195,7 +1299,9 @@ count = countEntries && tte_countEntries env return $ ProfNote cc count True{-scopes-} - Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids + Breakpoints -> do + i <- addMixEntry me + pure (Breakpoint noExtField (BreakpointId (this_mod env) i) ids) SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' $ LexicalFastString cc_name @@ -1248,3 +1354,98 @@ matchCount :: LMatch GhcTc body -> Int matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) = length grhss + +-- | Convenience class used by 'bindLocals' to collect new bindings from +-- various parts of he AST. Just delegates to +-- 'collect{Pat,Pats,Local,LStmts}Binders' from 'GHC.Hs.Utils' as appropriate. +class CollectBinders a where + collectBinds :: a -> [Id] + +-- | Variant of 'CollectBinders' which collects information on which locals +-- are bound to record fields (currently only via 'RecordWildCards' or +-- 'NamedFieldPuns') to enable better coverage support for record selectors. +-- +-- See Note [Record-selector ticks]. +class CollectFldBinders a where + collectFldBinds :: a -> IdEnv Id + +instance CollectBinders (LocatedA (Pat GhcTc)) where + collectBinds = collectPatBinders CollNoDictBinders +instance CollectBinders [LocatedA (Pat GhcTc)] where + collectBinds = collectPatsBinders CollNoDictBinders +instance CollectBinders (HsLocalBinds GhcTc) where + collectBinds = collectLocalBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsExpr GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders +instance CollectBinders [LocatedA (Stmt GhcTc (LocatedA (HsCmd GhcTc)))] where + collectBinds = collectLStmtsBinders CollNoDictBinders + +instance (CollectFldBinders a) => CollectFldBinders [a] where + collectFldBinds = foldr (flip plusVarEnv . collectFldBinds) emptyVarEnv +instance (CollectFldBinders e) => CollectFldBinders (GenLocated l e) where + collectFldBinds = collectFldBinds . unLoc +instance CollectFldBinders (Pat GhcTc) where + collectFldBinds ConPat{ pat_args = RecCon HsRecFields{ rec_flds, rec_dotdot } } = + collectFldBinds rec_flds `plusVarEnv` plusVarEnvList (zipWith fld_bnds [0..] rec_flds) + where n_explicit | Just (L _ (RecFieldsDotDot n)) <- rec_dotdot = n + | otherwise = length rec_flds + fld_bnds n (L _ HsFieldBind{ hfbLHS = L _ FieldOcc{ foLabel = L _ sel } + , hfbRHS = L _ (VarPat _ (L _ var)) + , hfbPun }) + | hfbPun || n >= n_explicit = unitVarEnv var sel + fld_bnds _ _ = emptyVarEnv + collectFldBinds ConPat{ pat_args = PrefixCon pats } = collectFldBinds pats + collectFldBinds ConPat{ pat_args = InfixCon p1 p2 } = collectFldBinds [p1, p2] + collectFldBinds (LazyPat _ pat) = collectFldBinds pat + collectFldBinds (BangPat _ pat) = collectFldBinds pat + collectFldBinds (AsPat _ _ pat) = collectFldBinds pat + collectFldBinds (ViewPat _ _ pat) = collectFldBinds pat + collectFldBinds (ParPat _ pat) = collectFldBinds pat + collectFldBinds (ListPat _ pats) = collectFldBinds pats + collectFldBinds (TuplePat _ pats _) = collectFldBinds pats + collectFldBinds (SumPat _ pats _ _) = collectFldBinds pats + collectFldBinds (SigPat _ pat _) = collectFldBinds pat + collectFldBinds (XPat exp) = collectFldBinds exp + collectFldBinds VarPat{} = emptyVarEnv + collectFldBinds WildPat{} = emptyVarEnv + collectFldBinds OrPat{} = emptyVarEnv + collectFldBinds LitPat{} = emptyVarEnv + collectFldBinds NPat{} = emptyVarEnv + collectFldBinds NPlusKPat{} = emptyVarEnv + collectFldBinds SplicePat{} = emptyVarEnv + collectFldBinds EmbTyPat{} = emptyVarEnv + collectFldBinds InvisPat{} = emptyVarEnv +instance (CollectFldBinders r) => CollectFldBinders (HsFieldBind l r) where + collectFldBinds = collectFldBinds . hfbRHS +instance CollectFldBinders XXPatGhcTc where + collectFldBinds (CoPat _ pat _) = collectFldBinds pat + collectFldBinds (ExpansionPat _ pat) = collectFldBinds pat +instance CollectFldBinders (HsLocalBinds GhcTc) where + collectFldBinds (HsValBinds _ bnds) = collectFldBinds bnds + collectFldBinds HsIPBinds{} = emptyVarEnv + collectFldBinds EmptyLocalBinds{} = emptyVarEnv +instance CollectFldBinders (HsValBinds GhcTc) where + collectFldBinds (ValBinds _ bnds _) = collectFldBinds bnds + collectFldBinds (XValBindsLR (NValBinds bnds _)) = collectFldBinds (map snd bnds) +instance CollectFldBinders (HsBind GhcTc) where + collectFldBinds PatBind{ pat_lhs } = collectFldBinds pat_lhs + collectFldBinds (XHsBindsLR AbsBinds{ abs_exports, abs_binds }) = + mkVarEnv [ (abe_poly, sel) + | ABE{ abe_poly, abe_mono } <- abs_exports + , Just sel <- [lookupVarEnv monos abe_mono] ] + where monos = collectFldBinds abs_binds + collectFldBinds VarBind{} = emptyVarEnv + collectFldBinds FunBind{} = emptyVarEnv + collectFldBinds PatSynBind{} = emptyVarEnv +instance CollectFldBinders (Stmt GhcTc e) where + collectFldBinds (BindStmt _ pat _) = collectFldBinds pat + collectFldBinds (LetStmt _ bnds) = collectFldBinds bnds + collectFldBinds (ParStmt _ xs _ _) = collectFldBinds [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss] + collectFldBinds TransStmt{ trS_stmts } = collectFldBinds trS_stmts + collectFldBinds RecStmt{ recS_stmts } = collectFldBinds recS_stmts + collectFldBinds (XStmtLR (ApplicativeStmt _ args _)) = collectFldBinds (map snd args) + collectFldBinds LastStmt{} = emptyVarEnv + collectFldBinds BodyStmt{} = emptyVarEnv +instance CollectFldBinders (ApplicativeArg GhcTc) where + collectFldBinds ApplicativeArgOne{ app_arg_pattern } = collectFldBinds app_arg_pattern + collectFldBinds ApplicativeArgMany{ bv_pattern } = collectFldBinds bv_pattern diff --git a/GHC/HsToCore/Types.hs b/GHC/HsToCore/Types.hs --- a/GHC/HsToCore/Types.hs +++ b/GHC/HsToCore/Types.hs @@ -14,26 +14,34 @@ import GHC.Prelude (Int) import Data.IORef -import qualified Data.Set as S import GHC.Types.CostCentre.State import GHC.Types.Error import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var +import GHC.Types.Var.Set import GHC.Types.Name.Reader (GlobalRdrEnv) + import GHC.Hs (LForeignDecl, HsExpr, GhcTc) -import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) + +import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv) + import GHC.HsToCore.Pmc.Types (Nablas) import GHC.HsToCore.Errors.Types + import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook) import GHC.Data.OrdList (OrdList) + import GHC.Types.ForeignStubs (ForeignStubs) +import GHC.Types.CompleteMatch +import Data.Maybe( Maybe ) + {- ************************************************************************ * * @@ -52,14 +60,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 @@ -79,9 +87,11 @@ -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc". -- The set of reaching values Nablas is augmented as we walk inwards, refined -- through each pattern match in turn - , dsl_unspecables :: S.Set EvVar - -- ^ See Note [Desugaring non-canonical evidence]: this field collects - -- all un-specialisable evidence variables in scope. + + , dsl_unspecables :: Maybe VarSet + -- ^ See Note [Desugaring non-canonical evidence] + -- This field collects all un-specialisable evidence variables in scope. + -- Nothing <=> don't collect this info (used for the LHS of Rules) } -- Inside [| |] brackets, the desugarer looks diff --git a/GHC/HsToCore/Usage.hs b/GHC/HsToCore/Usage.hs --- a/GHC/HsToCore/Usage.hs +++ b/GHC/HsToCore/Usage.hs @@ -1,7 +1,3 @@ - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.HsToCore.Usage ( -- * Dependency/fingerprinting code (used by GHC.Iface.Make) mkUsageInfo, mkUsedNames, @@ -23,8 +19,10 @@ import GHC.Utils.Panic import GHC.Utils.Monad +import GHC.Types.Avail import GHC.Types.Name -import GHC.Types.Name.Set ( NameSet, allUses ) +import GHC.Types.Name.Reader (ImpDeclSpec(..)) +import GHC.Types.Name.Set ( NameSet, allUses, emptyNameSet, unionNameSet ) import GHC.Types.Unique.Set import GHC.Unit @@ -42,15 +40,16 @@ 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 import GHC.Types.Unique.DFM import GHC.Driver.Plugins +import qualified GHC.Unit.Home.Graph as HUG {- Note [Module self-dependency] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in its own dep_orphs or dep_finsts. However, if we aren't careful this can occur in the presence of hs-boot files: Consider that we have two modules, A and B, @@ -74,19 +73,23 @@ { uc_safe_implicit_imps_req :: !Bool -- ^ Are all implicit imports required to be safe for this Safe Haskell mode? } -mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> NameSet -> [FilePath] - -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IfG [Usage] -mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs +mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv + -> Module -> ImportedMods -> [ImportUserSpec] -> NameSet + -> [FilePath] -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded + -> IfG [Usage] +mkUsageInfo uc plugins fc unit_env + this_mod dir_imp_mods imp_decls used_names + dependent_files merged needed_links needed_pkgs = do eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env)) hashes <- liftIO $ mapM getFileHash dependent_files - let hu = unsafeGetHomeUnit unit_env + let hu = ue_unsafeHomeUnit unit_env hug = ue_home_unit_graph unit_env -- Dependencies on object files due to TH and plugins object_usages <- liftIO $ mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs - let all_home_ids = ue_all_home_unit_ids unit_env + let all_home_ids = HUG.allUnits (ue_home_unit_graph unit_env) mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod - dir_imp_mods used_names + dir_imp_mods imp_decls used_names let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f , usg_file_hash = hash , usg_file_label = Nothing } @@ -103,8 +106,7 @@ -- the entire collection of Ifaces. {- Note [Plugin dependencies] - ~~~~~~~~~~~~~~~~~~~~~~~~~~ - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Modules for which plugins were used in the compilation process, should be recompiled whenever one of those plugins changes. But how do we know if a plugin changed from the previous time a module was compiled? @@ -166,28 +168,28 @@ -- 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 -- home package ifaces in the PIT. - let miface = lookupIfaceByModule hug pit m + miface <- lookupIfaceByModule hug pit m case miface of Nothing -> pprPanic "mkObjectUsage" (ppr m) Just iface -> - return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash (mi_final_exts iface)) + return $ UsageHomeModuleInterface (moduleName m) (toUnitId $ moduleUnit m) (mi_iface_hash iface) librarySpecToUsage :: LibrarySpec -> IO [Usage] librarySpecToUsage (Objects os) = traverse (fing Nothing) os @@ -200,15 +202,16 @@ -> Set.Set UnitId -> Module -> ImportedMods + -> [ImportUserSpec] -> NameSet -> IfG [Usage] -mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names +mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports imp_decls used_names = mapMaybeM mkUsageM usage_mods where safe_implicit_imps_req = uc_safe_implicit_imps_req uc 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 @@ -235,7 +238,7 @@ else mod -- This lambda function is really just a -- specialised (++); originally came about to - -- avoid quadratic behaviour (trac #2680) + -- avoid quadratic behaviour (#2680) in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] where occ = nameOccName name @@ -263,7 +266,7 @@ -- for package modules, we record the module hash only | (null used_occs - && isNothing export_hash + && isNothing imported_exports && not is_direct_import && not finsts_mod) = Nothing -- Record no usage info @@ -276,20 +279,29 @@ usg_mod_name = moduleName mod, usg_unit_id = toUnitId (moduleUnit mod), usg_mod_hash = mod_hash, - usg_exports = export_hash, + usg_exports = imported_exports, usg_entities = Map.toList ent_hashs, usg_safe = imp_safe } where - finsts_mod = mi_finsts (mi_final_exts iface) - hash_env = mi_hash_fn (mi_final_exts iface) - mod_hash = mi_mod_hash (mi_final_exts iface) - export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface)) - | otherwise = Nothing + finsts_mod = mi_finsts iface + hash_env = mi_hash_fn iface + mod_hash = mi_mod_hash iface + imported_exports + = if not depend_on_exports + then Nothing + else + Just $ + HomeModImport + { hmiu_orphanLikeHash + = mi_orphan_like_hash iface + , hmiu_importedAvails + = moduleImportedAvails mod (mi_export_avails_hash iface) imp_decls + } by_is_safe (ImportedByUser imv) = imv_is_safe imv by_is_safe _ = False (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 @@ -333,9 +345,30 @@ one-shot mode), but that's even more bogus! -} -{- -Note [Internal used_names] -~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- | Compute the avails that we are importing from a home module. +-- +-- See 'HomeModImportedAvails'. +moduleImportedAvails :: Module -> Fingerprint -> [ImportUserSpec] -> HomeModImportedAvails +moduleImportedAvails mod vis_exp_hash = go [] emptyNameSet + where + go :: Avails -> NameSet -> [ImportUserSpec] -> HomeModImportedAvails + go avails_acc parents_acc [] = + HMIA_Explicit + { hmia_imported_avails = sortAvails avails_acc + , hmia_parents_with_implicits = parents_acc + } + go avails_acc parents_acc (ImpUserSpec (ImpDeclSpec { is_mod = mod' }) decl : imp_decls) + | mod' == mod + = case decl of + ImpUserExplicit avails parents_of_implicits + -> go (avails ++ avails_acc) (parents_acc `unionNameSet` parents_of_implicits) + imp_decls + _ -> HMIA_Implicit vis_exp_hash + | otherwise + = go avails_acc parents_acc imp_decls + +{- Note [Internal used_names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most of the used_names are External Names, but we can have System Names too. Two examples: diff --git a/GHC/HsToCore/Utils.hs b/GHC/HsToCore/Utils.hs --- a/GHC/HsToCore/Utils.hs +++ b/GHC/HsToCore/Utils.hs @@ -15,7 +15,7 @@ -- | Utility functions for constructing Core syntax, principally for desugaring module GHC.HsToCore.Utils ( EquationInfo(..), - firstPat, shiftEqns, + firstPat, shiftEqns, combineEqnRhss, MatchResult (..), CaseAlt(..), cantFailMatchResult, alwaysFailMatchResult, @@ -28,8 +28,7 @@ mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult, wrapBind, wrapBinds, - mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, - mkFailExpr, + mkErrorAppDs, mkCastDs, mkFailExpr, seqVar, @@ -41,7 +40,7 @@ selectSimpleMatchVarL, selectMatchVars, selectMatchVar, mkOptTickBox, mkBinaryTickBox, decideBangHood, - isTrueLHsExpr + isTrueLHsExpr, ) where import GHC.Prelude @@ -66,16 +65,15 @@ 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 import GHC.Types.Unique.Supply import GHC.Unit.Module import GHC.Builtin.Names -import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc @@ -83,6 +81,7 @@ import GHC.Driver.Ppr import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Env ( irrefutableConLikeTc ) import GHC.Tc.Types.Evidence import Control.Monad ( zipWithM ) @@ -132,7 +131,7 @@ -- Postcondition: the returned Id has an Internal Name selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat) selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat) -selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat) +selectMatchVar w (ParPat _ pat) = selectMatchVar w (unLoc pat) selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -- @@ -141,8 +140,8 @@ -- multiplicity stored within the variable -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. -selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (localiseId (unLoc var))) -selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) +selectMatchVar _w (AsPat _ var _) = assert (isManyTy _w ) (return (localiseId (unLoc var))) +selectMatchVar w other_pat = newSysLocalDs (Scaled w (hsPatType other_pat)) {- Note [Localise pattern binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -194,13 +193,20 @@ worthy of a type synonym and a few handy functions. -} -firstPat :: EquationInfo -> Pat GhcTc -firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn) +firstPat :: EquationInfoNE -> Pat GhcTc +firstPat (EqnMatch { eqn_pat = pat }) = unLoc pat +firstPat (EqnDone {}) = error "firstPat: no patterns" -shiftEqns :: Functor f => f EquationInfo -> f EquationInfo +shiftEqns :: Functor f => f EquationInfoNE -> f EquationInfo -- Drop the first pattern in each equation -shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) } +shiftEqns = fmap shift + where + shift (EqnMatch { eqn_rest = rest }) = rest + shift eqn@(EqnDone {}) = pprPanic "shiftEqns" (ppr eqn) +combineEqnRhss :: NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) +combineEqnRhss = pure . foldr1 combineMatchResults . fmap eqnMatchResult + -- Functions on MatchResult CoreExprs matchCanFail :: MatchResult a -> Bool @@ -247,6 +253,9 @@ | new==old = body -- variables, type variables or coercion variables | otherwise = Let (NonRec new (varToCoreExpr old)) body +-- Used to force variables when desugaring strict binders. It's crucial that the +-- variable is shadowed by the case binder. See Wrinkle 1 in +-- Note [Desugar Strict binds] in GHC.HsToCore.Binds. seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = mkDefaultCase (Var var) var body @@ -325,7 +334,7 @@ matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher_id [getRuntimeRep ty, ty] cont <- mkCoreLams bndrs <$> runMatchResult fail match_result - return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + return $ mkCoreApps matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] where MkCaseAlt{ alt_pat = psyn, alt_bndrs = bndrs, @@ -453,106 +462,10 @@ is disabled. -} -mkFailExpr :: HsMatchContext GhcTc -> Type -> DsM CoreExpr +mkFailExpr :: HsMatchContextRn -> Type -> DsM CoreExpr mkFailExpr ctxt ty = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) -{- -'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'. - -Note [Desugaring seq] -~~~~~~~~~~~~~~~~~~~~~ - -There are a few subtleties in the desugaring of `seq`: - - 1. (as described in #1031) - - Consider, - f x y = x `seq` (y `seq` (# x,y #)) - - Because the argument to the outer 'seq' has an unlifted type, we'll use - call-by-value, and compile it as if we had - - f x y = case (y `seq` (# x,y #)) of v -> x `seq` v - - But that is bad, because we now evaluate y before x! - - Seq is very, very special! So we recognise it right here, and desugar to - case x of _ -> case y of _ -> (# x,y #) - - 2. (as described in #2273) - - Consider - let chp = case b of { True -> fst x; False -> 0 } - in chp `seq` ...chp... - Here the seq is designed to plug the space leak of retaining (snd x) - for too long. - - If we rely on the ordinary inlining of seq, we'll get - let chp = case b of { True -> fst x; False -> 0 } - case chp of _ { I# -> ...chp... } - - But since chp is cheap, and the case is an alluring context, we'll - inline chp into the case scrutinee. Now there is only one use of chp, - so we'll inline a second copy. Alas, we've now ruined the purpose of - the seq, by re-introducing the space leak: - case (case b of {True -> fst x; False -> 0}) of - I# _ -> ...case b of {True -> fst x; False -> 0}... - - We can try to avoid doing this by ensuring that the binder-swap in the - case happens, so we get this at an early stage: - case chp of chp2 { I# -> ...chp2... } - But this is fragile. The real culprit is the source program. Perhaps we - should have said explicitly - let !chp2 = chp in ...chp2... - - But that's painful. So the code here does a little hack to make seq - more robust: a saturated application of 'seq' is turned *directly* into - the case expression, thus: - x `seq` e2 ==> case x of x -> e2 -- Note shadowing! - e1 `seq` e2 ==> case x of _ -> e2 - - So we desugar our example to: - let chp = case b of { True -> fst x; False -> 0 } - case chp of chp { I# -> ...chp... } - And now all is well. - - The reason it's a hack is because if you define mySeq=seq, the hack - won't work on mySeq. - - 3. (as described in #2409) - - The isInternalName ensures that we don't turn - True `seq` e - into - case True of True { ... } - which stupidly tries to bind the datacon 'True'. --} - --- NB: Make sure the argument is not representation-polymorphic -mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2 - | f `hasKey` seqIdKey -- Note [Desugaring seq], points (1) and (2) - = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2] - where - case_bndr = case arg1 of - Var v1 | isInternalName (idName v1) - -> v1 -- Note [Desugaring seq], points (2) and (3) - _ -> mkWildValBinder ManyTy ty1 - -mkCoreAppDs _ (Var f `App` Type _r) arg - | f `hasKey` noinlineIdKey -- See Note [noinlineId magic] in GHC.Types.Id.Make - , (fun, args) <- collectArgs arg - , not (null args) - = (Var f `App` Type (exprType fun) `App` fun) - `mkCoreApps` args - -mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in GHC.Core.Make - --- NB: No argument can be representation-polymorphic -mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args - mkCastDs :: CoreExpr -> Coercion -> CoreExpr -- We define a desugarer-specific version of GHC.Core.Utils.mkCast, -- because in the immediate output of the desugarer, we can have @@ -594,8 +507,13 @@ in a binding group: let { ...; p = e; ... } in body where p binds x,y (this list of binders can be empty). -There are two cases. +mkSelectorBinds is also used to desugar irrefutable patterns, which is the +pattern syntax equivalent of a lazy pattern binding: + f (~(a:as)) = rhs ==> f x = let (a:as) = x in rhs + +There are three cases. + ------ Special case (A) ------- For a pattern that is just a variable, let !x = e in body @@ -631,7 +549,7 @@ Note that (C) /includes/ the situation where * The pattern binds exactly one variable - let !(Just (Just x) = e in body + let !(Just (Just x)) = e in body ==> let { t = case e of Just (Just v) -> Solo v ; v = case t of Solo v -> v } @@ -639,7 +557,7 @@ The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types Note that forcing 't' makes the pattern match happen, but does not force 'v'. That's why we call `mkBigCoreVarTupSolo` - in `mkSeletcorBinds` + in `mkSelectorBinds` * The pattern binds no variables let !(True,False) = e in body @@ -723,26 +641,27 @@ -} -- Remark: pattern selectors only occur in unrestricted patterns so we are free -- to select Many as the multiplicity of every let-expression introduced. -mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly - -> LPat GhcTc -- ^ The pattern - -> CoreExpr -- ^ Expression to which the pattern is bound +mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly + -> LPat GhcTc -- ^ The pattern + -> HsMatchContextRn -- ^ Where the pattern occurs + -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) -- ^ Id the rhs is bound to, for desugaring strict -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds") -- and all the desugared binds -mkSelectorBinds ticks pat val_expr +mkSelectorBinds ticks pat ctx val_expr | L _ (VarPat _ (L _ v)) <- pat' -- Special case (A) = return (v, [(v, val_expr)]) | 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 } -- Remember, 'pat' binds 'bv' - = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat' + = do { rhs_expr <- matchSimply (Var val_var) ctx ManyTy pat' (Var bndr_var) (Var bndr_var) -- Neat hack -- Neat hack: since 'pat' can't fail, the @@ -755,9 +674,9 @@ ; 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 PatBindRhs pat + ; tuple_expr <- matchSimply val_expr ctx ManyTy pat local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ @@ -779,7 +698,7 @@ strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) -- Remove outermost bangs and parens -strip_bangs (L _ (ParPat _ _ p _)) = strip_bangs p +strip_bangs (L _ (ParPat _ p)) = strip_bangs p strip_bangs (L _ (BangPat _ p)) = strip_bangs p strip_bangs lp = lp @@ -788,7 +707,7 @@ is_flat_prod_lpat = is_flat_prod_pat . unLoc is_flat_prod_pat :: Pat GhcTc -> Bool -is_flat_prod_pat (ParPat _ _ p _) = is_flat_prod_lpat p +is_flat_prod_pat (ParPat _ p) = is_flat_prod_lpat p is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps is_flat_prod_pat (ConPat { pat_con = L _ pcon , pat_args = ps}) @@ -805,7 +724,7 @@ is_triv_pat :: Pat (GhcPass p) -> Bool is_triv_pat (VarPat {}) = True is_triv_pat (WildPat{}) = True -is_triv_pat (ParPat _ _ p _) = is_triv_lpat p +is_triv_pat (ParPat _ p) = is_triv_lpat p is_triv_pat _ = False @@ -909,11 +828,11 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression -> DsM (CoreBind, -- Binds the newly-created fail variable -- to \ _ -> expression - CoreExpr) -- Fail variable applied to realWorld# + 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) } @@ -957,25 +876,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 @@ -1046,7 +976,7 @@ where go lp@(L l p) = case p of - ParPat x lpar p rpar -> L l (ParPat x lpar (go p) rpar) + ParPat x p -> L l (ParPat x (go p)) LazyPat _ lp' -> lp' BangPat _ _ -> lp _ -> L l (BangPat noExtField lp) @@ -1078,5 +1008,5 @@ this_mod <- getModule return (Tick (HpcTick this_mod ixT) e)) -isTrueLHsExpr (L _ (HsPar _ _ e _)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing +isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e +isTrueLHsExpr _ = Nothing diff --git a/GHC/Iface/Binary.hs b/GHC/Iface/Binary.hs --- a/GHC/Iface/Binary.hs +++ b/GHC/Iface/Binary.hs @@ -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 @@ -45,16 +49,22 @@ import GHC.Types.SrcLoc import GHC.Platform import GHC.Settings.Constants -import GHC.Utils.Fingerprint +import GHC.Iface.Type (IfaceType(..), getIfaceType, putIfaceType, ifaceTypeSharedByte) +import Control.Monad 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 +76,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 +113,7 @@ -> CheckHiWay -> TraceBinIFace -> FilePath - -> IO (Fingerprint, BinHandle) + -> IO ReadBinHandle readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do let platform = profilePlatform profile @@ -117,10 +155,11 @@ when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file profile tag" tag check_tag - src_hash <- get bh - pure (src_hash, bh) + pure bh -- | Read an interface file. +-- +-- See Note [Deduplication during iface binary serialisation] for details. readBinIface :: Profile -> NameCache @@ -129,24 +168,35 @@ -> FilePath -> IO ModIface readBinIface profile name_cache checkHiWay traceBinIface hi_path = do - (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path + bh <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path - extFields_p <- get bh + mod_iface <- getIfaceWithExtFields name_cache bh - mod_iface <- getWithUserData name_cache bh + return $ mod_iface - 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 +204,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) @@ -182,28 +256,32 @@ put_ bh (show hiVersion) let tag = profileBuildTag profile 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 +290,70 @@ <+> 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'. + -- + -- Similar to how 'getTables' calls 'addReaderToUserData', here we + -- call 'addWriterToUserData' instead of 'setWriterUserData', to + -- avoid overwriting existing writers of other types in bh'. + let bh = + addWriterToUserData fsWriter + $ addWriterToUserData nameWriter + -- We sometimes serialise binding and non-binding names differently, but + -- not during 'ModIface' serialisation. Here, we serialise both to the same + -- deduplication table. + -- + -- See Note [Binary UserData] + $ addWriterToUserData + (mkWriter $ \bh name -> putEntry nameWriter bh $ getBindingName name) + $ addWriterToUserData ifaceTypeWriter bh' - 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 +365,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 +658,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 +679,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 +703,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 +728,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 +747,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 - } - diff --git a/GHC/Iface/Decl.hs b/GHC/Iface/Decl.hs --- a/GHC/Iface/Decl.hs +++ b/GHC/Iface/Decl.hs @@ -13,7 +13,6 @@ module GHC.Iface.Decl ( coAxiomToIfaceDecl , tyThingToIfaceDecl -- Converting things to their Iface equivalents - , toIfaceBooleanFormula ) where @@ -32,7 +31,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Multiplicity - +import GHC.Core.TyCo.Tidy import GHC.Types.Id import GHC.Types.Var.Env @@ -40,15 +39,11 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Types.TyThing -import GHC.Types.SrcLoc import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Data.BooleanFormula - import Data.List ( findIndex, mapAccumL ) {- @@ -121,7 +116,7 @@ , ifaxbRHS = toIfaceType rhs , ifaxbIncomps = iface_incomps } where - iface_incomps = map (expectJust "iface_incomps" + iface_incomps = map (expectJust . flip findIndex lhs_s . eqTypes . coAxBranchLHS) incomps @@ -147,7 +142,7 @@ | Just fam_flav <- famTyConFlav_maybe tycon = ( tc_env1 , IfaceFamily { ifName = getName tycon, - ifResVar = if_res_var, + ifResVar = mkIfLclName <$> if_res_var, ifFamFlav = to_if_fam_flav fam_flav, ifBinders = if_binders, ifResKind = if_res_kind, @@ -210,18 +205,20 @@ ibr = map (coAxBranchToIfaceBranch tycon lhss) defs axn = coAxiomName ax - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data }) = IfDataTyCon type_data (map ifaceConDecl cons) - ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon False [ifaceConDecl con] - ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon False (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The AbstractTyCon case happens when a TyCon has been trimmed - -- during tidying. - -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module - -- for GHCi, when browsing a module, in which case the - -- AbstractTyCon and TupleTyCon cases are perfectly sensible. - -- (Tuple declarations are not serialised into interface files.) + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (UnaryClassTyCon { data_con = con}) = IfDataTyCon False [ifaceConDecl con] + ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon False [ifaceConDecl con] + ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon False (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The AbstractTyCon case happens when a TyCon has been trimmed during tidying. + -- + -- NB: TupleTyCon/SumTyCon/UnaryClassTyCon are never serialised into interface files + -- But tyThingToIfaceDecl is also used in GHC.Tc.Module + -- for GHCi, when browsing a module, in which case the + -- AbstractTyCon, TupleTyCon, SumTyCon are perfectly sensible. + -- (Not sure about UnaryClassTyCon, but easier to treat it uniformly.) ifaceConDecl data_con = IfCon { ifConName = dataConName data_con, @@ -251,7 +248,7 @@ -- we know that the type variables will line up -- The latter (b) is important because we pretty-print type constructors -- by converting to Iface syntax and pretty-printing that - con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) + con_env1 = (fst tc_env1, mkVarEnv (zipEqual univ_tvs tc_tyvars)) -- A bit grimy, perhaps, but it's simple! (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs @@ -265,7 +262,7 @@ -- tidying produced. Therefore, tidying the user-written tyvars is a -- simple matter of looking up each variable in the substitution, -- which tidyTyCoVarOcc accomplishes. - tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder + tidyUserForAllTyBinder :: TidyEnv -> TyVarBinder -> TyVarBinder tidyUserForAllTyBinder env (Bndr tv vis) = Bndr (tidyTyCoVarOcc env tv) vis @@ -288,7 +285,8 @@ ifClassCtxt = tidyToIfaceContext env1 sc_theta, ifATs = map toIfaceAT clas_ats, ifSigs = map toIfaceClassOp op_stuff, - ifMinDef = toIfaceBooleanFormula $ fmap getOccFS (classMinimalDef clas) + ifMinDef = toIfaceBooleanFormula (classMinimalDef clas), + ifUnary = isUnaryClassTyCon tycon } (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) @@ -334,12 +332,5 @@ tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) tidyTyConBinders = mapAccumL tidyTyConBinder -tidyTyVar :: TidyEnv -> TyVar -> FastString +tidyTyVar :: TidyEnv -> TyVar -> IfLclName tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) - -toIfaceBooleanFormula :: BooleanFormula IfLclName -> IfaceBooleanFormula -toIfaceBooleanFormula = \case - Var nm -> IfVar nm - And bfs -> IfAnd (map (toIfaceBooleanFormula . unLoc) bfs) - Or bfs -> IfOr (map (toIfaceBooleanFormula . unLoc) bfs) - Parens bf -> IfParens (toIfaceBooleanFormula . unLoc $ bf) diff --git a/GHC/Iface/Env.hs b/GHC/Iface/Env.hs --- a/GHC/Iface/Env.hs +++ b/GHC/Iface/Env.hs @@ -15,7 +15,7 @@ ifaceExportNames, - trace_if, trace_hi_diffs, + trace_if, trace_hi_diffs, trace_hi_diffs_io, -- Name-cache stuff allocateGlobalBinder, @@ -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 @@ -270,9 +269,15 @@ | (occ,uniq) <- occs `zip` uniqs] } trace_if :: Logger -> SDoc -> IO () -{-# INLINE trace_if #-} +{-# INLINE trace_if #-} -- see Note [INLINE conditional tracing utilities] trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc +trace_hi_diffs_io :: Logger -> IO SDoc -> IO () +{-# INLINE trace_hi_diffs_io #-} -- see Note [INLINE conditional tracing utilities] +trace_hi_diffs_io logger doc = + when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ + doc >>= putMsg logger + trace_hi_diffs :: Logger -> SDoc -> IO () -{-# INLINE trace_hi_diffs #-} -trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc +{-# INLINE trace_hi_diffs #-} -- see Note [INLINE conditional tracing utilities] +trace_hi_diffs logger doc = trace_hi_diffs_io logger (pure doc) diff --git a/GHC/Iface/Errors.hs b/GHC/Iface/Errors.hs --- a/GHC/Iface/Errors.hs +++ b/GHC/Iface/Errors.hs @@ -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" @@ -86,7 +87,7 @@ cannotFindModule' :: UnitEnv -> Profile -> ModuleName -> FindResult -> MissingInterfaceError cannotFindModule' unit_env profile mod res = - CantFindErr (ue_units unit_env) FindingModule $ + CantFindErr (ue_homeUnitState unit_env) FindingModule $ cantFindErr unit_env profile mod @@ -130,7 +131,7 @@ | otherwise -> GenericMissing - (map ((\uid -> (uid, lookupUnit (ue_units unit_env) uid))) pkg_hiddens) + (map ((\uid -> (uid, lookupUnit (ue_homeUnitState unit_env) uid))) pkg_hiddens) mod_hiddens unusables files _ -> panic "cantFindErr" diff --git a/GHC/Iface/Errors/Ppr.hs b/GHC/Iface/Errors/Ppr.hs --- a/GHC/Iface/Errors/Ppr.hs +++ b/GHC/Iface/Errors/Ppr.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage {-# LANGUAGE InstanceSigs #-} module GHC.Iface.Errors.Ppr @@ -31,7 +31,7 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr () -- Outputable GhcHint -import GHC.Types.Error.Codes ( constructorCode ) +import GHC.Types.Error.Codes import GHC.Types.Name import GHC.Types.TyThing @@ -59,7 +59,7 @@ diagnosticHints = interfaceErrorHints - diagnosticCode = constructorCode + diagnosticCode = constructorCode @GHC interfaceErrorHints :: IfaceMessage -> [GhcHint] interfaceErrorHints = \ case @@ -336,8 +336,9 @@ ] ] | otherwise = - -- ToDo: This will fail to have enough qualification when the package IDs - -- are the same + -- Display fully qualified unit names. Otherwise we may not have enough + -- qualification and the printed names could look exactly the same. + pprRawUnitIds $ withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, -- so reset the NamePprCtx setting. @@ -345,7 +346,6 @@ , ppr requested_mod , text "differs from name found in the interface file" , ppr read_mod - , parens (text "if these names look the same, try again with -dppr-debug") ] dynamicHashMismatchError :: Module -> ModLocation -> SDoc diff --git a/GHC/Iface/Ext/Ast.hs b/GHC/Iface/Ext/Ast.hs --- a/GHC/Iface/Ext/Ast.hs +++ b/GHC/Iface/Ext/Ast.hs @@ -12,8 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- For the HasLoc instances {- Main functions for .hie file generation @@ -31,21 +32,21 @@ 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 import GHC.Hs import GHC.Hs.Syn.Type import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) ) +import GHC.Utils.FV ( fvVarList, filterFV ) import GHC.Types.Id ( isDataConId_maybe ) -import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) +import GHC.Types.Name ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) -import GHC.Types.Name.Reader ( RecFieldInfo(..) ) +import GHC.Types.Name.Reader ( RecFieldInfo(..), WithUserRdr(..) ) import GHC.Types.SrcLoc -import GHC.Core.Type ( Type ) -import GHC.Core.Predicate +import GHC.Core.Type ( Type, ForAllTyFlag(..) ) +import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.InstEnv +import GHC.Core.Predicate ( isEvId ) import GHC.Tc.Types import GHC.Tc.Types.Evidence import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) @@ -53,11 +54,10 @@ import GHC.Builtin.Uniques import GHC.Iface.Make ( mkIfaceExports ) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString import qualified GHC.Data.Strict as Strict +import GHC.Data.Pair import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils @@ -80,6 +80,9 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Class ( lift ) import Control.Applicative ( (<|>) ) +import GHC.Types.TypeEnv ( TypeEnv ) +import Control.Arrow ( second ) +import Data.Traversable ( mapAccumR ) {- Note [Updating HieAst for changes in the GHC AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -209,7 +212,8 @@ -- These synonyms match those defined in compiler/GHC.hs type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)] - , Maybe (LHsDoc GhcRn) ) + , Maybe (LHsDoc GhcRn) + , Maybe (XRec GhcRn ModuleName) ) type TypecheckedSource = LHsBinds GhcTc @@ -227,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 () @@ -258,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 @@ -285,7 +305,7 @@ -> TcGblEnv -> RenamedSource -> m HieFile mkHieFile ms ts rs = do - let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms) + let src_file = expectJust (ml_hs_file $ ms_location ms) src <- liftIO $ BS.readFile src_file pure $ mkHieFileWithSource src_file src ms ts rs @@ -300,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 @@ -310,18 +331,21 @@ -- 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) 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 imps <- toHie $ filter (not . ideclImplicit . ideclExt . unLoc) imports @@ -343,7 +367,8 @@ (realSrcSpanEnd $ nodeSpan (NE.last children)) flat_asts = concat - [ tasts + [ modName + , tasts , rasts , imps , exps @@ -398,22 +423,23 @@ , toHie $ hs_docs grp ] -getRealSpanA :: SrcSpanAnn' ann -> Maybe Span +getRealSpanA :: EpAnn ann -> Maybe Span getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns) +grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs) +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (NE.map getLocA xs) bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure [] 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) @@ -466,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] ~~~~~~~~~~~~~~~~~~~ @@ -482,36 +508,19 @@ -- things to its right, ala RScoped -- | Each element scopes over the elements to the right -listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)] -listScopes _ [] = [] -listScopes rhsScope [pat] = [RS rhsScope pat] -listScopes rhsScope (pat : pats) = RS sc pat : pats' - where - pats'@((RS scope p):_) = listScopes rhsScope pats - sc = combineScopes scope $ mkScope $ getLocA p +listScopes :: Traversable f => Scope -> f (LocatedA a) -> f (RScoped (LocatedA a)) +listScopes = fmap snd . mapAccumR (\ (scope :: Scope) pat -> let scope' = combineScopes scope $ mkScope $ getLocA pat in (scope', RS scope pat)) -- | 'listScopes' specialised to 'PScoped' things patScopes - :: Maybe Span + :: Traversable f + => Maybe Span -> Scope -> Scope - -> [LPat (GhcPass p)] - -> [PScoped (LPat (GhcPass p))] -patScopes rsp useScope patScope xs = - map (\(RS sc a) -> PS rsp useScope sc a) $ - listScopes patScope xs - --- | 'listScopes' specialised to 'HsConPatTyArg' -taScopes - :: Scope - -> Scope - -> [HsConPatTyArg (GhcPass a)] - -> [TScoped (HsPatSigType (GhcPass a))] -taScopes scope rhsScope xs = - map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $ - listScopes rhsScope (map (\(HsConPatTyArg _ hsps) -> L (getLoc $ hsps_body hsps) hsps) xs) - -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType. - -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS. + -> f (LPat (GhcPass p)) + -> f (PScoped (LPat (GhcPass p))) +patScopes rsp useScope patScope = + fmap (\(RS sc a) -> PS rsp useScope sc a) . listScopes patScope -- | 'listScopes' specialised to 'TVScoped' things tvScopes @@ -541,43 +550,26 @@ This case in handled in the instance for HsPatSigType -} -class HasLoc a where - -- ^ conveniently calculate locations for things without locations attached - loc :: a -> SrcSpan - instance HasLoc thing => HasLoc (PScoped thing) where - loc (PS _ _ _ a) = loc a - -instance HasLoc (Located a) where - loc (L l _) = l - -instance HasLoc (LocatedA a) where - loc (L la _) = locA la - -instance HasLoc (LocatedN a) where - loc (L la _) = locA la - -instance HasLoc a => HasLoc [a] where - loc [] = noSrcSpan - loc xs = foldl1' combineSrcSpans $ map loc xs + getHasLoc (PS _ _ _ a) = getHasLoc a instance HasLoc a => HasLoc (DataDefnCons a) where - loc = loc . toList + getHasLoc = getHasLocList . toList instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where - loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of + getHasLoc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of HsOuterImplicit{} -> - foldl1' combineSrcSpans [loc a, loc b, loc c] + foldl1' combineSrcSpans (getHasLoc a :| getHasLocList b : getHasLoc c : []) HsOuterExplicit{hso_bndrs = tvs} -> - foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c] + foldl1' combineSrcSpans (getHasLoc a :| getHasLocList tvs : getHasLocList b : getHasLoc c : []) -instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg p tm ty) where - loc (HsValArg tm) = loc tm - loc (HsTypeArg _ ty) = loc ty - loc (HsArgPar sp) = sp +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg (GhcPass p) tm ty) where + getHasLoc (HsValArg _ tm) = getHasLoc tm + getHasLoc (HsTypeArg _ ty) = getHasLoc ty + getHasLoc (HsArgPar sp) = sp instance HasLoc (HsDataDefn GhcRn) where - loc def@(HsDataDefn{}) = loc $ dd_cons def + getHasLoc def@(HsDataDefn{}) = getHasLoc $ dd_cons def -- Only used for data family instances, so we only need rhs -- Most probably the rest will be unhelpful anyway @@ -610,9 +602,9 @@ toHie = maybe (pure []) toHie instance ToHie (IEContext (LocatedA ModuleName)) where - toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do + 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 [] @@ -637,6 +629,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 [] $ @@ -661,6 +656,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 [] $ @@ -671,25 +669,22 @@ []] _ -> pure [] -evVarsOfTermList :: EvTerm -> [EvId] -evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e -evVarsOfTermList (EvTypeable _ ev) = - case ev of - EvTypeableTyCon _ e -> concatMap evVarsOfTermList e - EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] - EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] - EvTypeableTyLit e -> evVarsOfTermList e -evVarsOfTermList (EvFun{}) = [] +instance ToHie (Context (Located (WithUserRdr Name))) where + toHie (C c (L l (WithUserRdr _ n))) = toHie $ C c (L l n) +hieEvIdsOfTerm :: EvTerm -> [EvId] +-- Returns only EvIds satisfying relevantEvId +hieEvIdsOfTerm tm = fvVarList (filterFV isEvId (evTermFVs tm)) + instance ToHie (EvBindContext (LocatedA TcEvBinds)) where toHie (EvBindContext sc sp (L span (EvBinds bs))) = concatMapM go $ bagToList bs where go evbind = do - let evDeps = evVarsOfTermList $ eb_rhs evbind + let evDeps = hieEvIdsOfTerm $ eb_rhs evbind depNames = EvBindDeps $ map varName evDeps concatM $ - [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScopeA span)) sp) + [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) (L span $ eb_lhs evbind)) , toHie $ map (C EvidenceVarUse . L span) $ evDeps ] @@ -698,16 +693,16 @@ instance ToHie (LocatedA HsWrapper) where toHie (L osp wrap) = case wrap of - (WpLet bs) -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs) + (WpLet bs) -> toHie $ EvBindContext (mkScope osp) (getRealSpanA osp) (L osp bs) (WpCompose a b) -> concatM $ [toHie (L osp a), toHie (L osp b)] (WpFun a b _) -> concatM $ [toHie (L osp a), toHie (L osp b)] (WpEvLam a) -> - toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp)) + toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpanA osp)) $ L osp a (WpEvApp a) -> - concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a + concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a _ -> pure [] instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where @@ -752,15 +747,17 @@ HsApp{} -> Nothing HsAppType{} -> Nothing NegApp{} -> Nothing - HsPar _ _ e _ -> computeLType e + HsPar _ e -> computeLType e ExplicitTuple{} -> Nothing HsIf _ _ t f -> computeLType t <|> computeLType f - HsLet _ _ _ _ body -> computeLType body + HsLet _ _ body -> computeLType body RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e - XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax - XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e + XExpr (ExpandedThingTc thing e) + | OrigExpr (HsGetField{}) <- thing -- for record-dot-syntax + -> Just (hsExprType e) + | otherwise -> computeType e XExpr (HsTick _ e) -> computeLType e XExpr (HsBinTick _ _ e) -> computeLType e e -> Just (hsExprType e) @@ -811,16 +808,20 @@ , 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)) + , Data (HsTypedSplice (GhcPass p)) , Data (HsLocalBinds (GhcPass p)) , Data (FieldOcc (GhcPass p)) , Data (HsTupArg (GhcPass p)) , Data (IPBind (GhcPass p)) , ToHie (Context (Located (IdGhcP p))) + , ToHie (Context (Located (IdOccGhcP p))) , Anno (IdGhcP p) ~ SrcSpanAnnN + , Anno (IdOccGhcP p) ~ SrcSpanAnnN + , Typeable p + , IsPass p ) => HiePass p where hiePass :: HiePassEv p @@ -837,9 +838,9 @@ = ( 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)))) - ~ SrcAnn NoEpAnns + ~ EpAnn NoEpAnns , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA , Data (body (GhcPass p)) @@ -866,9 +867,6 @@ [ toHie expr ] XHsBindsLR ext -> case hiePass @p of -#if __GLASGOW_HASKELL__ < 811 - HieRn -> dataConCantHappen ext -#endif HieTc | AbsBinds{ abs_exports = xs, abs_binds = binds , abs_ev_binds = ev_binds @@ -878,11 +876,11 @@ (toHie $ fmap (BC context scope) binds) , toHie $ map (L span . abe_wrap) xs , toHie $ - map (EvBindContext (mkScopeA span) (getRealSpanA span) + map (EvBindContext (mkScope span) (getRealSpanA span) . L span) ev_binds , toHie $ map (C (EvidenceVarBind EvSigBind - (mkScopeA span) + (mkScope span) (getRealSpanA span)) . L span) ev_vars ] @@ -918,21 +916,24 @@ ] where lhsScope = combineScopes varScope detScope - varScope = mkLScopeN var - patScope = mkScopeA $ getLoc pat + varScope = mkScope var + patScope = mkScope $ getLoc pat detScope = case dets of - (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScopeN args - (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b) + (PrefixCon args) -> foldr combineScopes NoScope $ map mkScope args + (InfixCon a b) -> combineScopes (mkScope a) (mkScope b) (RecCon r) -> foldr go NoScope r - go (RecordPatSynField a b) c = combineScopes c - $ combineScopes (mkLScopeN (foLabel a)) (mkLScopeN b) + go (RecordPatSynField (a :: FieldOcc (GhcPass p)) b) c = combineScopes c + $ combineScopes (mkScope (foLabel a)) (mkScope b) detSpan = case detScope of LocalScope a -> Just a _ -> Nothing - toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args + toBind (PrefixCon args) = PrefixCon $ map (C Use) args toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) toBind (RecCon r) = RecCon $ map (PSC detSpan) r +instance ToHie a => ToHie (WithUserRdr a) where + toHie (WithUserRdr _ a) = toHie a + instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where toHie dir = case dir of ExplicitBidirectional mg -> toHie mg @@ -944,33 +945,41 @@ , 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 } -> - [ toHie mctx + 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 , toHie grhss ] -instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where - toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name' - where +toHieHsMatchContext :: forall p. HiePass p => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> HieM [HieAST Type] +toHieHsMatchContext ctxt + = case ctxt of + FunRhs{mc_fun=name} -> toHie $ C MatchBind (get_name name) + StmtCtxt a -> toHieHsStmtContext @p a + _ -> pure [] + where -- See a paragraph about Haddock in #20415. - name' :: LocatedN Name - name' = case hiePass @p of - HieRn -> name - HieTc -> name - toHie (StmtCtxt a) = toHie a - toHie _ = pure [] + get_name :: LIdP (NoGhcTc (GhcPass p)) -> LocatedN Name + get_name name = case hiePass @p of + HieRn -> name + HieTc -> name -instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where - toHie (PatGuard a) = toHie a - toHie (ParStmtCtxt a) = toHie a - toHie (TransStmtCtxt a) = toHie a - toHie _ = pure [] +toHieHsStmtContext :: forall p. HiePass p => HsStmtContext (LIdP (NoGhcTc (GhcPass p))) + -> HieM [HieAST Type] +toHieHsStmtContext ctxt + = case ctxt of + PatGuard a -> toHieHsMatchContext @p a + ParStmtCtxt a -> toHieHsStmtContext @p a + TransStmtCtxt a -> toHieHsStmtContext @p a + _ -> pure [] 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 -> @@ -979,14 +988,14 @@ LazyPat _ p -> [ toHie $ PS rsp scope pscope p ] - AsPat _ lname _ pat -> + AsPat _ lname pat -> [ toHie $ C (PatternBind scope - (combineScopes (mkLScopeA pat) pscope) + (combineScopes (mkScope pat) pscope) rsp) lname , toHie $ PS rsp scope pscope pat ] - ParPat _ _ pat _ -> + ParPat _ pat -> [ toHie $ PS rsp scope pscope pat ] BangPat _ pat -> @@ -1009,7 +1018,7 @@ , let ev_binds = cpt_binds ext ev_vars = cpt_dicts ext wrap = cpt_wrap ext - evscope = mkScopeA ospan `combineScopes` scope `combineScopes` pscope + evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds , toHie $ L ospan wrap , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp) @@ -1017,7 +1026,7 @@ ] ] HieRn -> - [ toHie $ C Use con + [ toHie $ C Use (fmap getName con) , toHie $ contextify dets ] ViewPat _ expr pat -> @@ -1029,20 +1038,30 @@ ] LitPat _ _ -> [] - NPat _ _ _ _ -> - [] - NPlusKPat _ n _ _ _ _ -> + NPat _ (L loc lit) _ eq -> + [ toHie $ L (l2l loc :: SrcSpanAnnA) lit + , toHieSyntax (L ospan eq) + ] + NPlusKPat _ n (L loc lit) _ ord _ -> [ toHie $ C (PatternBind scope pscope rsp) n + , toHie $ L (l2l loc :: SrcSpanAnnA) lit + , toHieSyntax (L ospan ord) ] SigPat _ pat sig -> [ toHie $ PS rsp scope pscope pat , case hiePass @p of HieTc -> - let cscope = mkLScopeA pat in + let cscope = mkScope pat in toHie $ TS (ResolvedScopes [cscope, scope, pscope]) sig HieRn -> pure [] ] + EmbTyPat _ tp -> + [ toHie $ TS (ResolvedScopes [scope, pscope]) tp + ] + InvisPat _ tp -> + [ toHie $ TS (ResolvedScopes [scope, pscope]) tp + ] XPat e -> case hiePass @p of HieRn -> case e of @@ -1054,16 +1073,14 @@ ] ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] where - contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsConPatTyArg GhcRn) a (HsRecFields (GhcPass p) a) - -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) - contextify (PrefixCon tyargs args) = - PrefixCon (taScopes scope argscope tyargs) - (patScopes rsp scope pscope args) - where argscope = foldr combineScopes NoScope $ map mkLScopeA args + contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a) + -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a))) + contextify (PrefixCon args) = + PrefixCon (patScopes rsp scope pscope args) contextify (InfixCon a b) = InfixCon a' b' - where [a', b'] = patScopes rsp scope pscope [a,b] + where Pair a' b' = patScopes rsp scope pscope (Pair a b) contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r - contextify_rec (HsRecFields 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 @@ -1071,13 +1088,36 @@ L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun scoped_fds = listScopes pscope fds +toHieSyntax :: forall p. HiePass p => LocatedA (SyntaxExpr (GhcPass p)) -> HieM [HieAST Type] +toHieSyntax s = local (const GeneratedInfo) $ case hiePass @p of + HieRn -> toHie s + HieTc -> toHie s + +instance ToHie (LocatedA SyntaxExprRn) where + toHie (L mspan (SyntaxExprRn expr)) = toHie (L mspan expr) + toHie (L _ NoSyntaxExprRn) = pure [] + +instance ToHie (LocatedA SyntaxExprTc) where + toHie (L mspan (SyntaxExprTc expr w1 w2)) = concatM + [ toHie (L mspan expr) + , concatMapM (toHie . L mspan) w1 + , toHie (L mspan w2) + ] + toHie (L _ NoSyntaxExprTc) = pure [] + instance ToHie (TScoped (HsPatSigType GhcRn)) where toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $ - [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs) + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs) , toHie body ] -- See Note [Scoping Rules for SigPat] +instance ToHie (TScoped (HsTyPat GhcRn)) where + toHie (TS sc (HsTP (HsTPRn wcs imp_tvs exp_tvs) body@(L span _))) = concatM $ + [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs ++ imp_tvs ++ exp_tvs) + , toHie body + ] + instance ( ToHie (LocatedA (body (GhcPass p))) , HiePass p , AnnoBody p body @@ -1094,35 +1134,74 @@ ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where toHie (L span g) = concatM $ makeNodeA g span : case g of GRHS _ guards body -> - [ toHie $ listScopes (mkLScopeA body) guards + [ toHie $ listScopes (mkScope body) guards , toHie body ] +{- +Note [Source locations for implicit function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While calls to e.g. 'fromString' with -XOverloadedStrings do not actually +appear in the source code, giving their HsWrapper the location of the +overloaded bit of syntax that triggered them is useful for assigning +their type class evidence uses to the right location in the HIE AST. +Without this, we only get type class instance information under the +expected top-level node if the type had to be inferred. (#23540) + +We currently handle the following constructors with this in mind, +all largely in the renamer as their locations are normally inherited by +the typechecker: + + * HsOverLit, where we assign the SrcSpan of the overloaded literal + to ol_from_fun. + * HsDo, where we give the SrcSpan of the entire do block to each + ApplicativeStmt. + * Expanded (via ExpandedThingRn) ExplicitList{}, where we give the SrcSpan of the original + list expression to the 'fromListN' call. + +In order for the implicit function calls to not be confused for actual +occurrences of functions in the source code, most of this extra information +is put under 'GeneratedInfo'. +-} + +whenPostTc :: forall p t m. (HiePass p, Applicative t, Monoid m) => ((p ~ 'Typechecked) => t m) -> t m +whenPostTc a = case hiePass @p of + HieTc -> a + HieRn -> pure mempty + +-- | Helper function for a common pattern where we are only interested in +-- implicit evidence information: runs only post-typecheck and marks the +-- current 'NodeOrigin' as generated. +whenPostTcGen :: forall p. HiePass p => ((p ~ 'Typechecked) => HieM [HieAST Type]) -> HieM [HieAST Type] +whenPostTcGen a = local (const GeneratedInfo) $ whenPostTc @p a + +instance HiePass p => ToHie (LocatedA (HsOverLit (GhcPass p))) where + toHie (L span (OverLit x _)) = whenPostTcGen @p $ concatM $ case x of + OverLitTc _ witness _ -> + [ toHie (L span witness) + ] + -- See Note [Source locations for implicit function calls] + instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of HsVar _ (L _ var) -> [ toHie $ C Use (L mspan var) -- Patch up var location since typechecker removes it ] - HsUnboundVar _ _ -> [] -- there is an unbound name here, but that causes trouble - HsRecSel _ fld -> - [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld) - ] HsOverLabel {} -> [] HsIPVar _ _ -> [] - HsOverLit _ _ -> [] - HsLit _ _ -> [] - HsLam _ mg -> - [ toHie mg + HsOverLit _ o -> + [ toHie (L mspan o) ] - HsLamCase _ _ mg -> + HsLit _ _ -> [] + HsLam _ _ mg -> [ toHie mg ] HsApp _ a b -> [ toHie a , toHie b ] - HsAppType _ expr _ sig -> + HsAppType _ expr sig -> [ toHie expr , toHie $ TS (ResolvedScopes []) sig ] @@ -1134,7 +1213,7 @@ NegApp _ a _ -> [ toHie a ] - HsPar _ _ a _ -> + HsPar _ a -> [ toHie a ] SectionL _ a b -> @@ -1163,8 +1242,8 @@ HsMultiIf _ grhss -> [ toHie grhss ] - HsLet _ _ binds _ expr -> - [ toHie $ RS (mkLScopeA expr) binds + HsLet _ binds expr -> + [ toHie $ RS (mkScope expr) binds , toHie expr ] HsDo _ _ (L ispan stmts) -> @@ -1181,12 +1260,14 @@ where con_name :: LocatedN Name con_name = case hiePass @p of -- Like ConPat - HieRn -> con + HieRn -> fmap getName con HieTc -> fmap conLikeName con RecordUpd { rupd_expr = expr , rupd_flds = RegularRecUpdFields { recUpdFields = upds } }-> [ 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 {} }-> @@ -1194,21 +1275,41 @@ ] ExprWithTySig _ expr sig -> [ toHie expr - , toHie $ TS (ResolvedScopes [mkLScopeA expr]) sig + , toHie $ TS (ResolvedScopes [mkScope expr]) sig ] - ArithSeq _ _ info -> + ArithSeq enum _ info -> [ toHie info + , whenPostTcGen @p $ toHie (L mspan enum) ] HsPragE _ _ expr -> [ toHie expr ] HsProc _ pat cmdtop -> - [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat + [ toHie $ PS Nothing (mkScope cmdtop) NoScope pat , toHie cmdtop ] HsStatic _ expr -> [ toHie expr ] + 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 (multAnnToHsExpr mult) + , toHie arg + , toHie res + ] + HieTc -> dataConCantHappen x HsTypedBracket xbracket b -> case hiePass @p of HieRn -> [ toHie b @@ -1227,30 +1328,37 @@ , toHie p ] HsTypedSplice _ x -> - [ toHie x + [ toHie $ L mspan x ] HsUntypedSplice _ x -> [ toHie $ L mspan x ] HsGetField {} -> [] HsProjection {} -> [] - XExpr x - | HieTc <- hiePass @p - -> case x of - WrapExpr (HsWrap w a) - -> [ toHie $ L mspan a - , toHie (L mspan w) ] - ExpansionExpr (HsExpanded _ b) - -> [ toHie (L mspan b) ] - ConLikeTc con _ _ - -> [ toHie $ C Use $ L mspan $ conLikeName con ] - HsTick _ expr - -> [ toHie expr - ] - HsBinTick _ _ expr - -> [ toHie expr - ] - | otherwise -> [] + HsHole _ -> [] -- there is a hole here, but that causes trouble + 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 @@ -1268,15 +1376,16 @@ LastStmt _ body _ _ -> [ toHie body ] - BindStmt _ pat body -> + BindStmt monad pat body -> [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat , toHie body - ] - ApplicativeStmt _ stmts _ -> - [ concatMapM (toHie . RS scope . snd) stmts + , whenPostTcGen @p $ + toHieSyntax $ L span (xbstc_bindOp monad) ] - BodyStmt _ body _ _ -> + BodyStmt _ body monad alternative -> [ toHie body + , whenPostTc @p $ + concatMapM (toHieSyntax . L span) [monad, alternative] ] LetStmt _ binds -> [ toHie $ RS scope binds @@ -1294,10 +1403,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 @@ -1323,19 +1442,19 @@ = foldr combineScopes NoScope (bsScope ++ sigsScope) where bsScope :: [Scope] - bsScope = map (mkScopeA . 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 (mkScopeA . getLoc) $ concatMap (bagToList . snd) bs + bsScope = map (mkScope . getLoc) $ concatMap snd bs sigsScope :: [Scope] sigsScope = map (mkScope . getLocA) sigs scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) - = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs) + = foldr combineScopes NoScope (map (mkScope . getLoc) bs) scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where @@ -1356,13 +1475,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 @@ -1370,27 +1489,22 @@ ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of HsFieldBind _ label expr _ -> - [ toHie $ RFC c (getRealSpan $ loc expr) label + [ toHie $ RFC c (getRealSpan $ getHasLoc expr) label , toHie expr ] -instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (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)] +instance HiePass p => ToHie (RFContext (LocatedA (FieldOcc (GhcPass p)))) where + 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 (LocatedAn NoEpAnns (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 @@ -1402,14 +1516,14 @@ , toHie $ PS Nothing sc NoScope pat ] -instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where - toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ] +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args toHie (RecCon rec) = toHie rec toHie (InfixCon a b) = concatM [ toHie a, toHie b] instance ToHie (HsConDeclGADTDetails GhcRn) where - toHie (PrefixConGADT args) = toHie args - toHie (RecConGADT rec _) = toHie rec + toHie (PrefixConGADT _ args) = toHie args + toHie (RecConGADT _ rec) = toHie rec instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where toHie (L span top) = concatM $ makeNodeA top span : case top of @@ -1423,7 +1537,7 @@ [ toHie a , toHie b ] - HsCmdArrForm _ a _ _ cmdtops -> + HsCmdArrForm _ a _ cmdtops -> [ toHie a , toHie cmdtops ] @@ -1431,17 +1545,14 @@ [ toHie a , toHie b ] - HsCmdLam _ mg -> - [ toHie mg - ] - HsCmdPar _ _ a _ -> + HsCmdPar _ a -> [ toHie a ] HsCmdCase _ expr alts -> [ toHie expr , toHie alts ] - HsCmdLamCase _ _ alts -> + HsCmdLam _ _ alts -> [ toHie alts ] HsCmdIf _ _ a b c -> @@ -1449,8 +1560,8 @@ , toHie b , toHie c ] - HsCmdLet _ _ binds _ cmd' -> - [ toHie $ RS (mkLScopeA cmd') binds + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkScope cmd') binds , toHie cmd' ] HsCmdDo _ (L ispan stmts) -> @@ -1487,11 +1598,11 @@ , toHie defn ] where - quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn + quant_scope = mkScope $ fromMaybe (noLocA []) $ dd_ctxt defn rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc - sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_cons defn - deriv_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_derivs defn + sig_sc = maybe NoScope mkScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ mkScope <$> dd_cons defn + deriv_sc = foldr combineScopes NoScope $ mkScope <$> dd_derivs defn ClassDecl { tcdCtxt = context , tcdLName = name , tcdTyVars = vars @@ -1512,9 +1623,9 @@ , toHie deftyps ] where - context_scope = mkLScopeA $ fromMaybe (noLocA []) context - rhs_scope = foldl1' combineScopes $ map mkScope - [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + context_scope = mkScope $ fromMaybe (noLocA []) context + rhs_scope = foldl1' combineScopes $ NE.map mkScope + ( getHasLocList deps :| getHasLocList sigs : getHasLocList meths : getHasLocList typs : getHasLocList deftyps : []) instance ToHie (LocatedA (FamilyDecl GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of @@ -1536,7 +1647,7 @@ , toHie $ map go eqns ] where - go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib toHie _ = pure [] instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where @@ -1567,14 +1678,14 @@ instance (ToHie rhs, HasLoc rhs) => ToHie (FamEqn GhcRn rhs) where toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $ - [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + [ toHie $ C (Decl InstDec $ getRealSpan $ getHasLoc fe) var , toHie $ TVS (ResolvedScopes []) scope outer_bndrs , toHie pats , toHie rhs ] where scope = combineScopes patsScope rhsScope - patsScope = mkScope (loc pats) - rhsScope = mkScope (loc rhs) + patsScope = mkScope (getHasLocList pats) + rhsScope = mkScope (getHasLoc rhs) instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where toHie (L span ann) = concatM $ makeNodeA ann span : case ann of @@ -1600,7 +1711,7 @@ instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where toHie (L span cl) = concatM $ makeNodeA cl span : case cl of HsDerivingClause _ strat dct -> - [ toHie (RS (mkLScopeA dct) <$> strat) + [ toHie (RS (mkScope dct) <$> strat) , toHie dct ] @@ -1619,21 +1730,20 @@ instance ToHie (LocatedP OverlapMode) where toHie (L span _) = locOnly (locA span) -instance ToHie a => ToHie (HsScaled GhcRn a) where - toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] - instance ToHie (LocatedA (ConDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of - ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs - , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ + ConDeclGADT { con_names = names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = ctx + , con_g_args = args + , con_res_ty = typ , con_doc = doc} -> [ toHie $ C (Decl ConDec $ getRealSpanA span) <$> names - , case outer_bndrs of - HsOuterImplicit{hso_ximplicit = imp_vars} -> - bindingsOnly $ map (C $ TyVarBind (mkScopeA outer_bndrs_loc) resScope) - imp_vars - HsOuterExplicit{hso_bndrs = exp_bndrs} -> - toHie $ tvScopes resScope NoScope exp_bndrs + , bindingsOnly $ -- implicit forall + map (C $ TyVarBind (mkScope outer_bndrs_loc) (ResolvedScopes [sigmaScope])) + imp_vars + , toHie $ tvScopes (ResolvedScopes [phiScope]) NoScope exp_bndrs , toHie ctx , toHie args , toHie typ @@ -1641,12 +1751,19 @@ ] where rhsScope = combineScopes argsScope tyScope - ctxScope = maybe NoScope mkLScopeA ctx + ctxScope = maybe NoScope mkScope ctx argsScope = case args of - PrefixConGADT xs -> scaled_args_scope xs - RecConGADT x _ -> mkLScopeA x - tyScope = mkLScopeA typ - resScope = ResolvedScopes [ctxScope, rhsScope] + PrefixConGADT _ xs -> scaled_args_scope xs + RecConGADT _ x -> mkScope x + tyScope = mkScope typ + phiScope = combineScopes ctxScope rhsScope + sigmaScope = foldr combineScopes phiScope (map (mkScope . getLoc) exp_bndrs) + imp_vars = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_vars} -> imp_vars + HsOuterExplicit{} -> [] + exp_bndrs = + [ L l (updateHsTyVarBndrFlag Invisible b) | L l b <- hsOuterExplicitBndrs outer_bndrs ] + ++ concatMap hsForAllTelescopeBndrs inner_bndrs ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets , con_doc = doc} -> @@ -1658,33 +1775,40 @@ ] where rhsScope = combineScopes ctxScope argsScope - ctxScope = maybe NoScope mkLScopeA ctx + ctxScope = maybe NoScope mkScope ctx argsScope = case dets of - PrefixCon _ xs -> scaled_args_scope xs - InfixCon a b -> scaled_args_scope [a, b] - RecCon x -> mkLScopeA x - where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope - scaled_args_scope = foldr combineScopes NoScope . map (mkLScopeA . hsScaledThing) + PrefixCon xs -> scaled_args_scope xs + InfixCon a b -> scaled_args_scope [a, b] + RecCon x -> mkScope x + where scaled_args_scope :: [HsConDeclField GhcRn] -> Scope + scaled_args_scope = foldr combineScopes NoScope . map (mkScope . cdf_type) -instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where +instance ToHie (LocatedL [LocatedA (HsConDeclRecField GhcRn)]) where toHie (L span decls) = concatM $ [ locOnly (locA span) , toHie decls ] +instance ToHie (HsConDeclField GhcRn) where + toHie (CDF { cdf_multiplicity, cdf_type, cdf_doc }) = concatM + [ toHie (multAnnToHsType cdf_multiplicity) + , toHie cdf_type + , toHie cdf_doc + ] + instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where toHie (TS sc (HsWC names a)) = concatM $ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names , toHie $ TS sc a ] - where span = loc a + where span = getHasLoc a instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where toHie (TS sc (HsWC names a)) = concatM $ [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names , toHie a ] - where span = loc a + where span = getHasLoc a instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig] @@ -1725,6 +1849,10 @@ [ toHie $ (C Use) name , toHie $ map (TS (ResolvedScopes [])) typs ] + SpecSigE _ bndrs spec_e _ -> + [ toHieRuleBndrs (locA sp) (mkScope spec_e) bndrs + , toHie spec_e + ] SpecInstSig _ typ -> [ toHie $ TS (ResolvedScopes []) typ ] @@ -1735,16 +1863,15 @@ [ toHie $ (C Use) name , maybe (pure []) (locOnly . getLocA) mtxt ] - CompleteMatchSig _ (L ispan names) typ -> - [ locOnly ispan - , toHie $ map (C Use) names + CompleteMatchSig _ names typ -> + [ toHie $ map (C Use) names , toHie $ fmap (C Use) typ ] XSig _ -> [] instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span : - [ toHie (TVS tsc (mkScopeA span) bndrs) + [ toHie (TVS tsc (mkScope span) bndrs) , toHie body ] @@ -1754,15 +1881,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 -> @@ -1776,12 +1904,12 @@ [ toHie a , toHie b ] - HsAppKindTy _ ty _ ki -> + HsAppKindTy _ ty ki -> [ toHie ty , toHie ki ] HsFunTy _ w a b -> - [ toHie (arrowToHsType w) + [ toHie (multAnnToHsType w) , toHie a , toHie b ] @@ -1817,16 +1945,10 @@ [ toHie a , toHie doc ] - HsBangTy _ _ ty -> - [ toHie ty - ] - HsRecTy _ fields -> - [ toHie fields - ] HsExplicitListTy _ _ tys -> [ toHie tys ] - HsExplicitTupleTy _ tys -> + HsExplicitTupleTy _ _ tys -> [ toHie tys ] HsTyLit _ _ -> [] @@ -1834,20 +1956,21 @@ HsStarTy _ _ -> [] XHsType _ -> [] -instance (ToHie tm, ToHie ty) => ToHie (HsArg p tm ty) where - toHie (HsValArg tm) = toHie tm +instance (ToHie tm, ToHie ty) => ToHie (HsArg (GhcPass p) tm ty) where + toHie (HsValArg _ tm) = toHie tm toHie (HsTypeArg _ ty) = toHie ty 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 $ @@ -1855,7 +1978,7 @@ , toHie $ tvScopes sc NoScope vars ] where - varLoc = loc vars + varLoc = getHasLocList vars bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where @@ -1864,12 +1987,17 @@ , toHie tys ] -instance ToHie (LocatedA (ConDeclField GhcRn)) where +instance HiePass p => ToHie (LocatedC [LocatedA (HsExpr (GhcPass p))]) where + toHie (L span exprs) = concatM $ + [ locOnly (locA span) + , toHie exprs + ] + +instance ToHie (LocatedA (HsConDeclRecField GhcRn)) where toHie (L span field) = concatM $ makeNode field (locA span) : case field of - ConDeclField _ fields typ doc -> - [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + HsConDeclRecField _ fields typ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ getHasLoc $ cdf_type typ)) fields , toHie typ - , toHie doc ] instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where @@ -1902,14 +2030,23 @@ toHie (TypBr _ ty) = toHie ty toHie (VarBr {} ) = pure [] -instance ToHie PendingRnSplice where - toHie (PendingRnSplice _ _ e) = toHie e +instance forall pass . HiePass pass => ToHie (HsUntypedSplice (GhcPass pass)) where + toHie (HsUntypedSpliceExpr _ext e) = toHie e + toHie (HsQuasiQuote _ext quoter _ispanFs) = toHie (C Use quoter) + toHie (XUntypedSplice ext) = + case ghcPass @pass of + GhcRn -> case ext of + HsImplicitLiftSplice _ _ _ lid -> toHie (C Use lid) instance ToHie PendingTcSplice where toHie (PendingTcSplice _ e) = toHie e -instance ToHie (LBooleanFormula (LocatedN Name)) where - toHie (L span form) = concatM $ makeNode form (locA span) : case form of +instance ToHie PendingRnSplice where + toHie (PendingRnSplice _ e) = toHie e + +instance (HiePass p, Data (IdGhcP p)) + => ToHie (GenLocated SrcSpanAnnL (BooleanFormula (GhcPass p))) where + toHie (L span form) = concatM $ makeNode form (locA span) : case form of Var a -> [ toHie $ C Use a ] @@ -1926,7 +2063,7 @@ instance ToHie (LocatedAn NoEpAnns HsIPName) where toHie (L span e) = makeNodeA e span -instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where +instance (HiePass p) => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where toHie (L span sp) = concatM $ makeNodeA sp span : case sp of HsUntypedSpliceExpr _ expr -> [ toHie expr @@ -1934,7 +2071,28 @@ HsQuasiQuote _ _ ispanFs -> [ locOnly (getLocA ispanFs) ] + XUntypedSplice x -> + case ghcPass @p of + GhcRn -> case x of + HsImplicitLiftSplice _ _ _ lid -> + [ toHie $ C Use lid + ] +instance HiePass p => ToHie (LocatedA (HsTypedSplice (GhcPass p))) where + toHie (L span sp) = concatM $ makeNodeA sp span : case sp of + HsTypedSpliceExpr _ expr -> + [ toHie expr + ] + XTypedSplice x -> + case ghcPass @p of + GhcRn -> case x of + HsImplicitLiftSplice _ _ _ lid -> + [ toHie $ C Use lid + ] + + + + instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where toHie (L span annot) = concatM $ makeNodeA annot span : case annot of RoleAnnotDecl _ var roles -> @@ -1956,7 +2114,7 @@ instance ToHie (LocatedA (ClsInstDecl GhcRn)) where toHie (L span decl) = concatM - [ toHie $ TS (ResolvedScopes [mkScopeA span]) $ cid_poly_ty decl + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl @@ -1967,15 +2125,14 @@ ] instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where - toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where - toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d + 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) instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where toHie (PSC sp (RecordPatSynField a b)) = concatM $ @@ -1987,7 +2144,7 @@ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of DerivDecl _ typ strat overlap -> [ toHie $ TS (ResolvedScopes []) typ - , toHie $ (RS (mkScopeA span) <$> strat) + , toHie $ (RS (mkScope span) <$> strat) , toHie overlap ] @@ -1999,8 +2156,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 @@ -2018,15 +2176,15 @@ instance ToHie (ForeignImport GhcRn) where toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $ - [ locOnly a - , locOnly b - , locOnly c + [ locOnlyE a + , locOnlyE b + , locOnlyE c ] instance ToHie (ForeignExport GhcRn) where toHie (CExport (L b _) (L a _)) = concatM $ - [ locOnly a - , locOnly b + [ locOnlyE a + , locOnlyE b ] instance ToHie (LocatedA (WarnDecls GhcRn)) where @@ -2060,19 +2218,26 @@ ] instance ToHie (LocatedA (RuleDecl GhcRn)) where - toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + toHie (L span r@(HsRule { rd_name = rname, rd_bndrs = bndrs + , rd_lhs = exprA, rd_rhs = exprB })) + = concatM [ makeNodeA r span , locOnly $ getLocA rname - , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs - , toHie $ map (RS $ mkScope (locA span)) bndrs + , toHieRuleBndrs (locA span) scope bndrs , toHie exprA , toHie exprB ] - where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc - bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs) - exprA_sc = mkLScopeA exprA - exprB_sc = mkLScopeA exprB + where + scope = mkScope exprA `combineScopes` mkScope exprB +toHieRuleBndrs :: SrcSpan -> Scope -> RuleBndrs GhcRn -> HieM [HieAST Type] +toHieRuleBndrs span body_sc (RuleBndrs { rb_tyvs = tybndrs, rb_tmvs = bndrs }) + = concatM [ toHie $ fmap (tvScopes (ResolvedScopes []) full_sc) tybndrs + , toHie $ map (RS $ mkScope (locA span)) bndrs ] + where + full_sc = bndrs_sc `combineScopes` body_sc + bndrs_sc = maybe NoScope mkScope (listToMaybe bndrs) + instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of RuleBndr _ var -> @@ -2105,16 +2270,16 @@ instance ToHie (IEContext (LocatedA (IE GhcRn))) where toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of - IEVar _ n -> + IEVar _ n _ -> [ toHie $ IEC c n ] - IEThingAbs _ n -> + IEThingAbs _ n _ -> [ toHie $ IEC c n ] - IEThingAll _ n -> + IEThingAll _ n _ -> [ toHie $ IEC c n ] - IEThingWith _ n _ ns -> + IEThingWith _ n _ ns _ -> [ toHie $ IEC c n , toHie $ map (IEC c) ns ] @@ -2127,6 +2292,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) ] @@ -2134,6 +2302,9 @@ [ toHie $ C (IEThing c) (L l p) ] IEType _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) + ] + IEData _ (L l n) -> [ toHie $ C (IEThing c) (L l n) ] diff --git a/GHC/Iface/Ext/Binary.hs b/GHC/Iface/Ext/Binary.hs --- a/GHC/Iface/Ext/Binary.hs +++ b/GHC/Iface/Ext/Binary.hs @@ -1,8 +1,6 @@ {- Binary serialization for .hie files. -} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} module GHC.Iface.Ext.Binary ( readHieFile @@ -17,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 @@ -40,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 @@ -69,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 @@ -86,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 @@ -183,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 @@ -192,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) @@ -215,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) @@ -277,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 @@ -335,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) @@ -346,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 diff --git a/GHC/Iface/Ext/Fields.hs b/GHC/Iface/Ext/Fields.hs --- a/GHC/Iface/Ext/Fields.hs +++ b/GHC/Iface/Ext/Fields.hs @@ -33,16 +33,16 @@ -- for a payload pointer after each name: header_entries <- forM (Map.toList fs) $ \(name, dat) -> do put_ bh name - field_p_p <- tellBin bh + field_p_p <- tellBinWriter bh put_ bh field_p_p return (field_p_p, dat) -- Now put the payloads and use the reserved space -- to point to the start of each payload: forM_ header_entries $ \(field_p_p, dat) -> do - field_p <- tellBin bh - putAt bh field_p_p field_p - seekBin bh field_p + field_p <- tellBinWriter bh + putAtRel bh field_p_p field_p + seekBinWriter bh field_p put_ bh dat get bh = do @@ -50,11 +50,11 @@ -- Get the names and field pointers: header_entries <- replicateM n $ - (,) <$> get bh <*> get bh + (,) <$> get bh <*> getRelBin bh -- Seek to and get each field's payload: fields <- forM header_entries $ \(name, field_p) -> do - seekBin bh field_p + seekBinReaderRel bh field_p dat <- get bh return (name, dat) @@ -72,7 +72,7 @@ readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a) readField name = readFieldWith name get -readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a) +readFieldWith :: FieldName -> (ReadBinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a) readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$> Map.lookup name (getExtensibleFields fields) @@ -82,7 +82,7 @@ writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields writeField name x = writeFieldWith name (`put_` x) -writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields +writeFieldWith :: FieldName -> (WriteBinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields writeFieldWith name write fields = do bh <- openBinMem (1024 * 1024) write bh diff --git a/GHC/Iface/Ext/Types.hs b/GHC/Iface/Ext/Types.hs --- a/GHC/Iface/Ext/Types.hs +++ b/GHC/Iface/Ext/Types.hs @@ -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 diff --git a/GHC/Iface/Ext/Utils.hs b/GHC/Iface/Ext/Utils.hs --- a/GHC/Iface/Ext/Utils.hs +++ b/GHC/Iface/Ext/Utils.hs @@ -107,8 +107,14 @@ , evidenceSpan :: RealSrcSpan , evidenceType :: a , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span) - } deriving (Eq,Ord,Functor) + } deriving (Eq, Functor) +instance Ord a => Ord (EvidenceInfo a) where + compare (EvidenceInfo name span typ dets) (EvidenceInfo name' span' typ' dets') = + case stableNameCmp name name' of + EQ -> compare (span, typ, dets) (span', typ', dets') + r -> r + instance (Outputable a) => Outputable (EvidenceInfo a) where ppr (EvidenceInfo name span typ dets) = hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $ @@ -156,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 "" + go HCoercionTy = IfaceTyVar (mkIfLclName "") go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) -- This isn't fully faithful - we can't produce the 'Inferred' case @@ -527,21 +533,14 @@ pure [Node e span []] locOnly _ = pure [] -mkScopeA :: SrcSpanAnn' ann -> Scope -mkScopeA l = mkScope (locA l) - -mkScope :: SrcSpan -> Scope -mkScope (RealSrcSpan sp _) = LocalScope sp -mkScope _ = NoScope - -mkLScope :: Located a -> Scope -mkLScope = mkScope . getLoc - -mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope -mkLScopeA = mkScope . locA . getLoc +locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a] +locOnlyE (EpaSpan s) = locOnly s +locOnlyE _ = pure [] -mkLScopeN :: LocatedN a -> Scope -mkLScopeN = mkScope . getLocA +mkScope :: (HasLoc a) => a -> Scope +mkScope a = case getHasLoc a of + (RealSrcSpan sp _) -> LocalScope sp + _ -> NoScope combineScopes :: Scope -> Scope -> Scope combineScopes ModuleScope _ = ModuleScope @@ -557,8 +556,8 @@ {-# INLINEABLE makeNodeA #-} makeNodeA :: (Monad m, Data a) - => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') - -> SrcSpanAnn' ann -- ^ return an empty list if this is unhelpful + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> EpAnn ann -- ^ return an empty list if this is unhelpful -> ReaderT NodeOrigin m [HieAST b] makeNodeA x spn = makeNode x (locA spn) diff --git a/GHC/Iface/Flags.hs b/GHC/Iface/Flags.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Flags.hs @@ -0,0 +1,194 @@ +-- | Datatype definitions for the flag representation stored in interface files +module GHC.Iface.Flags ( + IfaceDynFlags(..) + , IfaceGeneralFlag(..) + , IfaceProfAuto(..) + , IfaceExtension(..) + , IfaceLanguage(..) + , IfaceCppOptions(..) + , pprIfaceDynFlags + , missingExtraFlagInfo + ) where + +import GHC.Prelude + +import GHC.Utils.Outputable +import Control.DeepSeq +import GHC.Utils.Fingerprint +import GHC.Utils.Binary + +import GHC.Driver.DynFlags +import GHC.Types.SafeHaskell +import GHC.Core.Opt.CallerCC.Types + +import qualified GHC.LanguageExtensions as LangExt + +-- The part of DynFlags which recompilation information needs +data IfaceDynFlags = IfaceDynFlags + { ifaceMainIs :: Maybe (Maybe String) + , ifaceSafeMode :: IfaceTrustInfo + , ifaceLang :: Maybe IfaceLanguage + , ifaceExts :: [IfaceExtension] + , ifaceCppOptions :: IfaceCppOptions + , ifaceJsOptions :: IfaceCppOptions + , ifaceCmmOptions :: IfaceCppOptions + , ifacePaths :: [String] + , ifaceProf :: Maybe IfaceProfAuto + , ifaceTicky :: [IfaceGeneralFlag] + , ifaceCodeGen :: [IfaceGeneralFlag] + , ifaceFatIface :: Bool + , ifaceDebugLevel :: Int + , ifaceCallerCCFilters :: [CallerCcFilter] + } + +pprIfaceDynFlags :: IfaceDynFlags -> SDoc +pprIfaceDynFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = + vcat [ text "main-is:" <+> (ppr $ fmap (fmap (text @SDoc)) a1) + , text "safe-mode:" <+> ppr a2 + , text "lang:" <+> ppr a3 + , text "exts:" <+> ppr a4 + , text "cpp-options:" + , nest 2 $ ppr a5 + , text "js-options:" + , nest 2 $ ppr a6 + , text "cmm-options:" + , nest 2 $ ppr a7 + , text "paths:" <+> hcat (map text a8) + , text "prof:" <+> ppr a9 + , text "ticky:" + , nest 2 $ vcat (map ppr a10) + , text "codegen:" + , nest 2 $ vcat (map ppr a11) + , text "fat-iface:" <+> ppr a12 + , text "debug-level:" <+> ppr a13 + , text "caller-cc-filters:" <+> ppr a14 + ] + +missingExtraFlagInfo :: SDoc +missingExtraFlagInfo = text "flags: no detailed info, recompile with -fwrite-if-self-recomp-flags" + where + -- If you modify the name of this flag, you have to modify this string. + _placeholder = Opt_WriteSelfRecompFlags + +instance Binary IfaceDynFlags where + put_ bh (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + put_ bh a11 + put_ bh a12 + put_ bh a13 + put_ bh a14 + get bh = IfaceDynFlags <$> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + +instance NFData IfaceDynFlags where + rnf (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) = + rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + `seq` rnf a7 + `seq` rnf a8 + `seq` rnf a9 + `seq` rnf a10 + `seq` rnf a11 + `seq` rnf a12 + `seq` rnf a13 + `seq` rnf a14 + +newtype IfaceGeneralFlag = IfaceGeneralFlag GeneralFlag + +instance NFData IfaceGeneralFlag where + rnf (IfaceGeneralFlag !_) = () + +instance Binary IfaceGeneralFlag where + put_ bh (IfaceGeneralFlag f) = put_ bh (fromEnum f) + get bh = IfaceGeneralFlag . toEnum <$> get bh + +instance Outputable IfaceGeneralFlag where + ppr (IfaceGeneralFlag f) = text (show f) + +newtype IfaceProfAuto = IfaceProfAuto ProfAuto + +instance NFData IfaceProfAuto where + rnf (IfaceProfAuto !_) = () + +instance Binary IfaceProfAuto where + put_ bh (IfaceProfAuto f) = put_ bh (fromEnum f) + get bh = IfaceProfAuto . toEnum <$> get bh + +instance Outputable IfaceProfAuto where + ppr (IfaceProfAuto f) = text (show f) + + +newtype IfaceExtension = IfaceExtension LangExt.Extension + +instance NFData IfaceExtension where + rnf (IfaceExtension !_) = () + +instance Binary IfaceExtension where + put_ bh (IfaceExtension f) = put_ bh (fromEnum f) + get bh = IfaceExtension . toEnum <$> get bh + +instance Outputable IfaceExtension where + ppr (IfaceExtension f) = text (show f) + +newtype IfaceLanguage = IfaceLanguage Language + +instance NFData IfaceLanguage where + rnf (IfaceLanguage !_) = () + +instance Binary IfaceLanguage where + put_ bh (IfaceLanguage f) = put_ bh (fromEnum f) + get bh = IfaceLanguage . toEnum <$> get bh + +instance Outputable IfaceLanguage where + ppr (IfaceLanguage f) = text (show f) + +data IfaceCppOptions = IfaceCppOptions { ifaceCppIncludes :: [FilePath] + , ifaceCppOpts :: [String] + , ifaceCppSig :: ([String], Fingerprint) + } + +instance NFData IfaceCppOptions where + rnf (IfaceCppOptions is os s) = rnf is `seq` rnf os `seq` rnf s + +instance Binary IfaceCppOptions where + put_ bh (IfaceCppOptions is os s) = do + put_ bh is + put_ bh os + put_ bh s + get bh = IfaceCppOptions <$> get bh <*> get bh <*> get bh + +instance Outputable IfaceCppOptions where + ppr (IfaceCppOptions is os (wos, fp)) = + vcat [text "includes:" + , nest 2 $ hcat (map text is) + , text "opts:" + , nest 2 $ hcat (map text os) + , text "signature:" + , nest 2 $ parens (ppr fp) <+> ppr (map (text @SDoc) wos) + + ] diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs --- a/GHC/Iface/Load.hs +++ b/GHC/Iface/Load.hs @@ -4,10 +4,9 @@ -} -{-# LANGUAGE BangPatterns, NondecreasingIndentation #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE ViewPatterns #-} @@ -27,6 +26,7 @@ loadInterface, loadSysInterface, loadUserInterface, loadPluginInterface, findAndReadIface, readIface, writeIface, + flagsToIfCompression, moduleFreeHolesPrecise, needWiredInHomeIface, loadWiredInHomeIface, @@ -35,6 +35,8 @@ pprModIfaceSimple, ifaceStats, pprModIface, showIface, + getGhcPrimIface, + module Iface_Errors -- avoids boot files in Ppr modules ) where @@ -44,15 +46,15 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst - , tcIfaceAnnotations, tcIfaceCompleteMatches ) + , tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceDefaults) -import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Errors.Types import GHC.Driver.DynFlags 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 @@ -67,7 +69,6 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger @@ -75,14 +76,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 @@ -91,7 +90,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 @@ -102,11 +100,12 @@ 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 import GHC.Unit.Home -import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable import GHC.Unit.Finder import GHC.Unit.Env @@ -117,7 +116,11 @@ 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 ((&)) +import GHC.Unit.Module.Graph +import qualified GHC.Unit.Home.Graph as HUG {- ************************************************************************ @@ -442,12 +445,9 @@ -- Check whether we have the interface already ; hsc_env <- getTopEnv ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env) - ; case lookupIfaceByModule hug (eps_PIT eps) mod of { + ; liftIO (lookupIfaceByModule hug (eps_PIT eps) mod) >>= \case { Just iface -> return (Succeeded iface) ; -- Already loaded - -- The (src_imp == mi_boot iface) test checks that the already-loaded - -- interface isn't a boot iface. This can conceivably happen, - -- if an earlier import had a before we got to real imports. I think. _ -> do { -- READ THE MODULE IN @@ -478,7 +478,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) $ @@ -507,30 +507,44 @@ ((isOneShot (ghcMode (hsc_dflags hsc_env))) || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env || mod == gHC_PRIM) - (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) + (text "Attempting to load home package interface into the EPS" $$ ppr (HUG.allUnits hug) $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod)) ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- tcIfaceDecls ignore_prags (mi_decls iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_defaults <- tcIfaceDefaults mod (mi_defaults iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; 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_defaults (panic "No mi_defaults 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_simplified_core (panic "No mi_simplified_core 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 @@ -542,6 +556,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 @@ -564,7 +579,9 @@ eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) (length new_eps_insts) - (length new_eps_rules) } + (length new_eps_rules), + eps_defaults = extendModuleEnv (eps_defaults eps) mod new_eps_defaults + } ; -- invoke plugins with *full* interface, not final_iface, to ensure -- that plugins have access to declarations, etc. @@ -575,7 +592,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. @@ -638,38 +655,55 @@ | otherwise = gbl_env { if_rec_types = emptyKnotVars } cleanTopEnv hsc_env = - let - !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env) - | otherwise = Nothing - -- wrinkle: when we're typechecking in --backpack mode, the - -- instantiation of a signature might reside in the HPT, so - -- this case breaks the assumption that EPS interfaces only - -- refer to other EPS interfaces. - -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it - -- contains any hole modules. - -- Quite a few tests in testsuite/tests/backpack break without this - -- tweak. - old_unit_env = hsc_unit_env hsc_env - keepFor20509 hmi - | isHoleModule (mi_semantic_module (hm_iface hmi)) = True - | otherwise = False - pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } - !unit_env - = old_unit_env - { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env - else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) - } - in - hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets" - , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" - , hsc_IC = panic "cleanTopEnv: hsc_IC" - , hsc_type_env_vars = case maybe_type_vars of - Just vars -> vars - Nothing -> panic "cleanTopEnv: hsc_type_env_vars" - , hsc_unit_env = unit_env - } + let + !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env) + | otherwise = Nothing + -- wrinkle: when we're typechecking in --backpack mode, the + -- instantiation of a signature might reside in the HPT, so + -- this case breaks the assumption that EPS interfaces only + -- refer to other EPS interfaces. + -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it + -- contains any hole modules. + -- Quite a few tests in testsuite/tests/backpack break without this + -- tweak. + old_unit_env = hsc_unit_env hsc_env + keepFor20509 + -- oneshot mode does not support backpack + -- and we want to avoid prodding the hsc_mod_graph thunk + | isOneShot (ghcMode (hsc_dflags hsc_env)) = False + | mgHasHoles (ue_module_graph old_unit_env) = True + | otherwise = False + pruneHomeUnitEnv hme = do + -- NB: These are empty HPTs because Iface/Load first consults the HPT + emptyHPT <- liftIO emptyHomePackageTable + return $! hme{ homeUnitEnv_hpt = emptyHPT } + unit_env_io + | keepFor20509 + = return old_unit_env + | otherwise + = do + hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph old_unit_env) + let !new_mod_graph = emptyMG { mg_mss = panic "cleanTopEnv: mg_mss" + , mg_graph = panic "cleanTopEnv: mg_graph" + , mg_has_holes = keepFor20509 } + return old_unit_env + { ue_home_unit_graph = hug' + , ue_module_graph = new_mod_graph + } + in do + !unit_env <- unit_env_io + -- mg_has_holes will be checked again, but nothing else about the module graph + pure $ + hsc_env + { hsc_targets = panic "cleanTopEnv: hsc_targets" + , hsc_IC = panic "cleanTopEnv: hsc_IC" + , hsc_type_env_vars = case maybe_type_vars of + Just vars -> vars + Nothing -> panic "cleanTopEnv: hsc_type_env_vars" + , hsc_unit_env = unit_env + } - updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do + updTopEnvIO cleanTopEnv $ updGblEnv cleanGblEnv $ do !_ <- getTopEnv -- force the updTopEnv !_ <- getGblEnv thing_inside @@ -704,7 +738,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 @@ -744,13 +778,14 @@ liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> text "to compute precise free module holes") (eps, hpt) <- getEpsAndHug - case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of - Just r -> return (Succeeded r) - Nothing -> readAndCache imod insts + result <- tryEpsAndHpt eps hpt + case result `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts (_, Nothing) -> return (Succeeded emptyUniqDSet) where tryEpsAndHpt eps hpt = - fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod) + fmap mi_free_holes <$> liftIO (lookupIfaceByModule hpt (eps_PIT eps) mod) tryDepsCache eps imod insts = case lookupInstalledModuleEnv (eps_free_holes eps) imod of Just ifhs -> Just (renameFreeHoles ifhs insts) @@ -851,18 +886,16 @@ -- 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 unit_state = hsc_units hsc_env - fc = hsc_FC hsc_env name_cache = hsc_NC hsc_env mhome_unit = hsc_home_unit_maybe hsc_env dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env hooks = hsc_hooks hsc_env - other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) trace_if logger (sep [hsep [text "Reading", @@ -873,66 +906,53 @@ ppr mod <> semi], nest 4 (text "reason:" <+> doc_str)]) - -- Check for GHC.Prim, and return its static interface - -- See Note [GHC.Prim] in primops.txt.pp. - -- TODO: make this check a function - if mod `installedModuleEq` gHC_PRIM - then do - let iface = case ghcPrimIfaceHook hooks of - Nothing -> ghcPrimIface - Just h -> h - return (Succeeded (iface, "")) - else do - let fopts = initFinderOpts dflags - -- Look for the file - mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod) - case mb_found of - InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do - -- See Note [Home module load error] - case mhome_unit of - Just home_unit - | isHomeInstalledModule home_unit mod - , not (isOneShot (ghcMode dflags)) - -> return (Failed (HomeModError mod loc)) - _ -> do - r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) - case r of - Failed err - -> return (Failed $ BadIfaceFile err) - Succeeded (iface,_fp) - -> do - r2 <- load_dynamic_too_maybe logger name_cache unit_state - (setDynamicNow dflags) wanted_mod - iface loc - case r2 of - Failed sdoc -> return (Failed sdoc) - Succeeded {} -> return $ Succeeded (iface,_fp) - err -> do - trace_if logger (text "...not found") - return $ Failed $ cannotFindInterface - unit_state - mhome_unit - profile - (moduleName mod) - err + -- Look for the file + mb_found <- liftIO (findExactModule hsc_env mod hi_boot_file) + case mb_found of + InstalledFound loc -> do + -- See Note [Home module load error] + if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env) + && not (isOneShot (ghcMode dflags)) + then return (Failed (HomeModError mod loc)) + else do + r <- read_file hooks logger name_cache unit_state dflags wanted_mod (ml_hi_file loc) + case r of + Failed err + -> return (Failed $ BadIfaceFile err) + Succeeded (iface,_fp) + -> do + r2 <- load_dynamic_too_maybe hooks logger name_cache unit_state + (setDynamicNow dflags) wanted_mod + iface loc + case r2 of + Failed sdoc -> return (Failed sdoc) + Succeeded {} -> return $ Succeeded (iface, loc) + err -> do + trace_if logger (text "...not found") + return $ Failed $ cannotFindInterface + unit_state + mhome_unit + profile + (moduleName mod) + err -- | Check if we need to try the dynamic interface for -dynamic-too -load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc +load_dynamic_too_maybe hooks logger name_cache unit_state dflags wanted_mod iface loc -- Indefinite interfaces are ALWAYS non-dynamic. | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ()) - | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc + | gopt Opt_BuildDynamicToo dflags = load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc | otherwise = return (Succeeded ()) -load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags +load_dynamic_too :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr MissingInterfaceError ()) -load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do - read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case +load_dynamic_too hooks logger name_cache unit_state dflags wanted_mod iface loc = do + read_file hooks logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case Succeeded (dynIface, _) - | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) + | mi_mod_hash iface == mi_mod_hash dynIface -> return (Succeeded ()) | otherwise -> do return $ (Failed $ DynamicHashMismatchError wanted_mod loc) @@ -944,11 +964,10 @@ -read_file :: Logger -> NameCache -> UnitState -> DynFlags +read_file :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) -read_file logger name_cache unit_state dflags wanted_mod file_path = do - trace_if logger (text "readIFace" <+> text file_path) +read_file hooks logger name_cache unit_state dflags wanted_mod file_path = do -- Figure out what is recorded in mi_module. If this is -- a fully definite interface, it'll match exactly, but @@ -959,7 +978,7 @@ (_, Just indef_mod) -> instModuleToModule unit_state (uninstantiateInstantiatedModule indef_mod) - read_result <- readIface dflags name_cache wanted_mod' file_path + read_result <- readIface hooks logger dflags name_cache wanted_mod' file_path case read_result of Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) @@ -967,23 +986,34 @@ -- | 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 -- Succeeded iface <=> successfully found and parsed readIface - :: DynFlags + :: Hooks + -> Logger + -> DynFlags -> NameCache -> Module -> FilePath -> IO (MaybeErr ReadInterfaceError ModIface) -readIface dflags name_cache wanted_mod file_path = do +readIface hooks logger dflags name_cache wanted_mod file_path = do + trace_if logger (text "readIFace" <+> text file_path) let profile = targetProfile dflags res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path case res of @@ -992,9 +1022,14 @@ -- critical for correctness of recompilation checking -- (it lets us tell when -this-unit-id has changed.) | wanted_mod == actual_mod - -> return (Succeeded iface) + -> return (Succeeded final_iface) | otherwise -> return (Failed err) where + final_iface + -- Check for GHC.Prim, and return its static interface + -- See Note [GHC.Prim] in primops.txt.pp. + | wanted_mod == gHC_PRIM = getGhcPrimIface hooks + | otherwise = iface actual_mod = mi_module iface err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod @@ -1011,22 +1046,20 @@ -- 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_fix_fn (mkIfaceFixCache ghcPrimFixities) + & set_mi_decl_warn_fn (mkIfaceDeclWarnCache ghcPrimWarns) + & set_mi_export_warn_fn (mkIfaceExportWarnCache ghcPrimWarns) + & set_mi_fix_fn (mkIfaceFixCache ghcPrimFixities) + & set_mi_docs (Just ghcPrimDeclDocs) -- See Note [GHC.Prim Docs] in GHC.Builtin.Utils + & set_mi_warns (toIfaceWarnings ghcPrimWarns) -- See Note [GHC.Prim Deprecations] in GHC.Builtin.Utils + 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 - {- ********************************************************* * * @@ -1064,7 +1097,7 @@ all names that don't originate in the current module. In order to keep visual noise as low as possible, we keep local names unqualified. -For some background on this choice see trac #15269. +For some background on this choice see #15269. -} -- | Read binary interface, and print it out @@ -1078,7 +1111,7 @@ iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename let -- See Note [Name qualification with --show-iface] - qualifyImportedNames mod _ + qualifyImportedNames mod _user_qual _ | mod == mi_module iface = NameUnqual | otherwise = NameNotInScope1 name_ppr_ctx = QueryQualify qualifyImportedNames @@ -1101,36 +1134,37 @@ -- -- The UnitState is used to pretty-print units pprModIface :: UnitState -> ModIface -> SDoc -pprModIface unit_state iface@ModIface{ mi_final_exts = exts } - = vcat [ text "interface" +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) - <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty) - <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) + <+> (withSelfRecomp iface empty $ \_ -> text "[self-recomp]") + <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty) <+> integer hiVersion - , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts)) - , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts)) - , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts)) - , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts)) - , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts)) - , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) - , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) - , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) - , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface)) + , nest 2 (text "export avails hash:" <+> ppr (mi_export_avails_hash iface)) + , nest 2 (text "orphan-like hash:" <+> ppr (mi_orphan_like_hash iface)) + , withSelfRecomp iface empty ppr + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) - , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (text "where") , text "exports:" , nest 2 (vcat (map pprExport (mi_exports iface))) + , text "defaults:" + , nest 2 (vcat (map ppr (mi_defaults iface))) , pprDeps unit_state (mi_deps iface) - , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] - , case mi_extra_decls iface of + , case mi_simplified_core iface of Nothing -> empty - Just eds -> text "extra decls:" - $$ nest 2 (vcat ([ppr bs | bs <- eds])) + Just (IfaceSimplifiedCore eds fs) -> + vcat [ text "extra decls:" + $$ nest 2 (vcat ([ppr bs | bs <- eds])) + , text "foreign stubs:" + $$ nest 2 (ppr fs) + ] , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) @@ -1142,10 +1176,12 @@ , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface)) ] where + pp_hsc_src HsBootFile = text "[boot]" pp_hsc_src HsigFile = text "[hsig]" pp_hsc_src HsSrcFile = Outputable.empty + {- When printing export lists, we print like this: Avail f f @@ -1165,34 +1201,7 @@ pp_export [] = Outputable.empty pp_export names = braces (hsep (map ppr names)) -pprUsage :: Usage -> SDoc -pprUsage usage@UsagePackageModule{} - = pprUsageImport usage usg_mod -pprUsage usage@UsageHomeModule{} - = pprUsageImport usage (\u -> mkModule (usg_unit_id u) (usg_mod_name u)) $$ - nest 2 ( - maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ - vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] - ) -pprUsage usage@UsageFile{} - = hsep [text "addDependentFile", - doubleQuotes (ftext (usg_file_path usage)), - ppr (usg_file_hash usage)] -pprUsage usage@UsageMergedRequirement{} - = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] -pprUsage usage@UsageHomeModuleInterface{} - = hsep [text "implementation", ppr (usg_mod_name usage) - , ppr (usg_unit_id usage) - , ppr (usg_iface_hash usage)] -pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc -pprUsageImport usage usg_mod' - = hsep [text "import", safe, ppr (usg_mod' usage), - ppr (usg_mod_hash usage)] - where - safe | usg_safe usage = text "safe" - | otherwise = text " -/ " - pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities [] = Outputable.empty pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes @@ -1230,3 +1239,13 @@ ppr ImportByPlugin = text "{- PLUGIN -}" +-- | Get gHC_PRIM interface file +-- +-- This is a helper function that takes into account the hook allowing ghc-prim +-- interface to be extended via the ghc-api. Afaik it was introduced for GHCJS +-- so that it can add its own primitive types. +getGhcPrimIface :: Hooks -> ModIface +getGhcPrimIface hooks = + case ghcPrimIfaceHook hooks of + Nothing -> ghcPrimIface + Just h -> h diff --git a/GHC/Iface/Make.hs b/GHC/Iface/Make.hs --- a/GHC/Iface/Make.hs +++ b/GHC/Iface/Make.hs @@ -13,6 +13,7 @@ ( mkPartialIface , mkFullIface , mkIfaceTc + , mkRecompUsageInfo , mkIfaceExports ) where @@ -21,12 +22,13 @@ import GHC.Hs -import GHC.Stg.InferTags.TagSig (StgCgInfos) +import GHC.Stg.EnforceEpt.TagSig (StgCgInfos) import GHC.StgToCmm.Types (CmmCgInfos (..)) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad +import GHC.Iface.Warnings import GHC.Iface.Decl import GHC.Iface.Syntax import GHC.Iface.Recomp @@ -39,20 +41,19 @@ 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 -import GHC.Driver.Backend import GHC.Driver.DynFlags import GHC.Driver.Plugins 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 @@ -60,19 +61,19 @@ 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.Panic.Plain import GHC.Utils.Logger +import GHC.Utils.Binary +import GHC.Iface.Binary import GHC.Data.FastString import GHC.Data.Maybe @@ -87,12 +88,13 @@ import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps +import GHC.Unit.Module.WholeCoreBindings (encodeIfaceForeign, emptyIfaceForeign) import Data.Function import Data.List ( sortBy ) import Data.Ord import Data.IORef - +import Data.Traversable {- ************************************************************************ @@ -106,24 +108,25 @@ -> CoreProgram -> ModDetails -> ModSummary + -> [ImportUserSpec] -> ModGuts - -> PartialModIface -mkPartialIface hsc_env core_prog mod_details mod_summary + -> IO PartialModIface +mkPartialIface hsc_env core_prog mod_details mod_summary import_decls ModGuts{ mg_module = this_mod , mg_hsc_src = hsc_src , mg_usages = usages - , mg_used_th = used_th , mg_deps = deps , mg_rdr_env = rdr_env , mg_fix_env = fix_env , mg_warns = warns - , mg_hpc_info = hpc_info , mg_safe_haskell = safe_mode , mg_trust_pkg = self_trust , mg_docs = docs } - = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust - safe_mode usages docs mod_summary mod_details + = do + self_recomp <- traverse (mkSelfRecomp hsc_env this_mod (ms_hs_hash mod_summary)) usages + return $ mkIface_ hsc_env this_mod core_prog hsc_src deps rdr_env import_decls fix_env warns self_trust + safe_mode self_recomp docs mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information. @@ -131,25 +134,62 @@ -- 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] + mi_simplified_core <- for (mi_simplified_core partial_iface) $ \simpl_core -> do + fs <- encodeIfaceForeign (hsc_logger hsc_env) (hsc_dflags hsc_env) stubs foreign_files + return $ (simpl_core { mi_sc_foreign = fs }) + full_iface <- {-# SCC "addFingerprints" #-} - addFingerprints hsc_env partial_iface{ mi_decls = decls } + addFingerprints hsc_env $ set_mi_simplified_core mi_simplified_core $ set_mi_decls decls partial_iface -- Debug printing let unit_state = hsc_units hsc_env 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 + forceModIface res + return res +-- | 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,67 +234,81 @@ 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, - tcg_warns = warns, - tcg_hpc = other_hpc_info, - tcg_th_splice_used = tc_splice_used, - tcg_dependent_files = dependent_files + tcg_warns = warns } = do - let used_names = mkUsedNames tc_result let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) let home_unit = hsc_home_unit hsc_env let deps = mkDependencies home_unit (tcg_mod tc_result) (tcg_imports tc_result) (map mi_module pluginModules) - let hpc_info = emptyHpcInfo other_hpc_info - used_th <- readIORef tc_splice_used - dep_files <- (readIORef dependent_files) - (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result) - let uc = initUsageConfig hsc_env - plugins = hsc_plugins hsc_env - fc = hsc_FC hsc_env - unit_env = hsc_unit_env hsc_env - -- Do NOT use semantic module here; this_mod in mkUsageInfo - -- is used solely to decide if we should record a dependency - -- or not. When we instantiate a signature, the semantic - -- module is something we want to record dependencies for, - -- but if you pass that in here, we'll decide it's the local - -- module and does not need to be recorded as a dependency. - -- See Note [Identity versus semantic module] - usages <- initIfaceLoad hsc_env $ mkUsageInfo uc plugins fc unit_env this_mod (imp_mods imports) used_names - dep_files merged needed_links needed_pkgs + usage <- mkRecompUsageInfo hsc_env tc_result docs <- extractDocs (ms_hspp_opts mod_summary) tc_result + self_recomp <- traverse (mkSelfRecomp hsc_env this_mod (ms_hs_hash mod_summary)) usage let partial_iface = mkIface_ hsc_env this_mod (fromMaybe [] mb_program) hsc_src - used_th deps rdr_env - fix_env warns hpc_info - (imp_trust_own_pkg imports) safe_mode usages - docs mod_summary + deps rdr_env import_decls + fix_env warns + (imp_trust_own_pkg imports) safe_mode self_recomp + docs mod_details - mkFullIface hsc_env partial_iface Nothing Nothing + mkFullIface hsc_env partial_iface Nothing Nothing NoStubs [] +mkRecompUsageInfo :: HscEnv -> TcGblEnv -> IO (Maybe [Usage]) +mkRecompUsageInfo hsc_env tc_result = do + let dflags = hsc_dflags hsc_env + if not (gopt Opt_WriteSelfRecompInfo dflags) + then return Nothing + else do + let used_names = mkUsedNames tc_result + dep_files <- (readIORef (tcg_dependent_files tc_result)) + (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result) + let uc = initUsageConfig hsc_env + plugins = hsc_plugins hsc_env + fc = hsc_FC hsc_env + unit_env = hsc_unit_env hsc_env + + -- Do NOT use semantic module here; this_mod in mkUsageInfo + -- is used solely to decide if we should record a dependency + -- or not. When we instantiate a signature, the semantic + -- module is something we want to record dependencies for, + -- but if you pass that in here, we'll decide it's the local + -- module and does not need to be recorded as a dependency. + -- See Note [Identity versus semantic module] + usages <- initIfaceLoad hsc_env $ + mkUsageInfo uc plugins fc unit_env + (tcg_mod tc_result) + (imp_mods (tcg_imports tc_result)) + (tcg_import_decls tc_result) + used_names + dep_files + (tcg_merged tc_result) + needed_links + needed_pkgs + return (Just usages) + mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource - -> Bool -> Dependencies -> GlobalRdrEnv - -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo + -> Dependencies -> GlobalRdrEnv -> [ImportUserSpec] + -> NameEnv FixItem -> Warnings GhcRn -> Bool -> SafeHaskellMode - -> [Usage] + -> Maybe IfaceSelfRecomp -> Maybe Docs - -> ModSummary -> ModDetails -> PartialModIface mkIface_ hsc_env - this_mod core_prog hsc_src used_th deps rdr_env fix_env src_warns - hpc_info pkg_trust_req safe_mode usages - docs mod_summary - ModDetails{ md_insts = insts, + this_mod core_prog hsc_src deps rdr_env import_decls fix_env src_warns + pkg_trust_req safe_mode self_recomp + docs + ModDetails{ md_defaults = defaults, + md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, md_anns = anns, @@ -272,8 +326,8 @@ entities = typeEnvElts type_env show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env) - extra_decls = if gopt Opt_WriteIfSimplifiedCore dflags then Just [ toIfaceTopBind b | b <- core_prog ] - else Nothing + simplified_core = if gopt Opt_WriteIfSimplifiedCore dflags then Just (IfaceSimplifiedCore [ toIfaceTopBind b | b <- core_prog ] emptyIfaceForeign) + else Nothing decls = [ tyThingToIfaceDecl show_linear_types entity | entity <- entities, let name = getName entity, @@ -300,42 +354,41 @@ trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns icomplete_matches = map mkIfaceCompleteMatch complete_matches - !rdrs = maybeGlobalRdrEnv rdr_env + !rdrs = mkIfaceTopEnv 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_self_recomp self_recomp + & set_mi_deps deps + & 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_decls decls + & set_mi_simplified_core simplified_core + & set_mi_trust trust_info + & set_mi_trust_pkg pkg_trust_req + & set_mi_complete_matches (icomplete_matches) + & set_mi_docs docs + & set_mi_abi_hashes () + & set_mi_ext_fields emptyExtensibleFields + & set_mi_hi_bytes PartialIfaceBinHandle + where cmp_rule = lexicalCompareFS `on` ifRuleName -- Compare these lexicographically by OccName, *not* by unique, @@ -345,29 +398,38 @@ 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 rdr_env - | backendWantsGlobalBindings (backend dflags) - = Just $! forceGlobalRdrEnv rdr_env - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. - | otherwise - = Nothing + mkIfaceTopEnv :: GlobalRdrEnv -> IfaceTopEnv + mkIfaceTopEnv rdr_env + = let !exports = sortAvails $ gresToAvailInfo $ globalRdrEnvElts $ globalRdrEnvLocal rdr_env + !imports = mkIfaceImports import_decls + in IfaceTopEnv exports imports ifFamInstTcName = ifFamInstFam +-------------------------- +defaultsToIfaceDefaults :: DefaultEnv -> [IfaceDefault] +defaultsToIfaceDefaults = map toIface . defaultList + where + toIface ClassDefaults { cd_class = cls + , cd_types = tys + , cd_warn = warn } + = IfaceDefault { ifDefaultCls = className cls + , ifDefaultTys = map toIfaceType tys + , ifDefaultWarn = fmap toIfaceWarningTxt warn } -------------------------- instanceToIfaceInst :: ClsInst -> IfaceClsInst instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag , is_cls_nm = cls_name, is_cls = cls , is_tcs = rough_tcs - , is_orphan = orph }) + , is_orphan = orph + , is_warn = warn }) = assert (cls_name == className cls) $ IfaceClsInst { ifDFun = idName dfun_id , ifOFlag = oflag @@ -375,7 +437,8 @@ , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs -- N.B. Drop the class name from the rough match template -- It is put back by GHC.Core.InstEnv.mkImportedClsInst - , ifInstOrph = orph } + , ifInstOrph = orph + , ifInstWarn = fmap toIfaceWarningTxt warn } -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst @@ -395,23 +458,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) (unLoc src) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt (unLoc 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. @@ -451,7 +497,9 @@ mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch mkIfaceCompleteMatch (CompleteMatch cls mtc) = - IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc) + -- NB: Sorting here means that COMPLETE {P, Q} and COMPLETE {Q, P} are + -- considered identical, in particular for recompilation checking. + IfaceCompleteMatch (sortBy stableNameCmp $ uniqDSetToList cls) mtc {- @@ -470,20 +518,19 @@ 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 parents_of_implicits)) + = IfaceImport decl (ImpIfaceExplicit (sortAvails env) (nameSetElemsStable parents_of_implicits)) + go (ImpUserSpec decl (ImpUserEverythingBut ns)) + = IfaceImport decl (ImpIfaceEverythingBut (nameSetElemsStable ns)) +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical +mkIfaceExports as = case sortAvails as of DefinitelyDeterministicAvails sas -> sas + {- Note [Original module] ~~~~~~~~~~~~~~~~~~~~~ @@ -499,4 +546,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. -} diff --git a/GHC/Iface/Recomp.hs b/GHC/Iface/Recomp.hs --- a/GHC/Iface/Recomp.hs +++ b/GHC/Iface/Recomp.hs @@ -15,1647 +15,1990 @@ , CompileReason(..) , recompileRequired , addFingerprints - ) -where - -import GHC.Prelude -import GHC.Data.FastString - -import GHC.Driver.Backend -import GHC.Driver.Config.Finder -import GHC.Driver.Env -import GHC.Driver.DynFlags -import GHC.Driver.Ppr -import GHC.Driver.Plugins - -import GHC.Iface.Syntax -import GHC.Iface.Recomp.Binary -import GHC.Iface.Load -import GHC.Iface.Recomp.Flags -import GHC.Iface.Env - -import GHC.Core -import GHC.Tc.Utils.Monad -import GHC.Hs - -import GHC.Data.Graph.Directed -import GHC.Data.Maybe - -import GHC.Utils.Error -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Misc as Utils -import GHC.Utils.Binary -import GHC.Utils.Fingerprint -import GHC.Utils.Exception -import GHC.Utils.Logger -import GHC.Utils.Constants (debugIsOn) - -import GHC.Types.Annotations -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.SrcLoc -import GHC.Types.Unique.Set -import GHC.Types.Fixity.Env -import GHC.Types.Unique.Map -import GHC.Unit.External -import GHC.Unit.Finder -import GHC.Unit.State -import GHC.Unit.Home -import GHC.Unit.Module -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.Warnings -import GHC.Unit.Module.Deps - -import Control.Monad -import Data.List (sortBy, sort, sortOn) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Word (Word64) -import Data.Either - ---Qualified import so we can define a Semigroup instance --- but it doesn't clash with Outputable.<> -import qualified Data.Semigroup -import GHC.List (uncons) -import Data.Ord -import Data.Containers.ListUtils -import Data.Bifunctor -import GHC.Iface.Errors.Ppr - -{- - ----------------------------------------------- - Recompilation checking - ----------------------------------------------- - -A complete description of how recompilation checking works can be -found in the wiki commentary: - - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance - -Please read the above page for a top-down description of how this all -works. Notes below cover specific issues related to the implementation. - -Basic idea: - - * In the mi_usages information in an interface, we record the - fingerprint of each free variable of the module - - * In mkIface, we compute the fingerprint of each exported thing A.f. - For each external thing that A.f refers to, we include the fingerprint - of the external reference when computing the fingerprint of A.f. So - if anything that A.f depends on changes, then A.f's fingerprint will - change. - Also record any dependent files added with - * addDependentFile - * #include - * -optP-include - - * In checkOldIface we compare the mi_usages for the module with - the actual fingerprint for all each thing recorded in mi_usages --} - -data RecompileRequired - -- | everything is up to date, recompilation is not required - = UpToDate - -- | Need to compile the module - | NeedsRecompile !CompileReason - deriving (Eq) - -needsRecompileBecause :: RecompReason -> RecompileRequired -needsRecompileBecause = NeedsRecompile . RecompBecause - -data MaybeValidated a - -- | The item contained is validated to be up to date - = UpToDateItem a - -- | The item is are absent altogether or out of date, for the reason given. - | OutOfDateItem - !CompileReason - -- ^ the reason we need to recompile. - (Maybe a) - -- ^ The old item, if it exists - deriving (Functor) - -instance Outputable a => Outputable (MaybeValidated a) where - ppr (UpToDateItem a) = text "UpToDate" <+> ppr a - ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r - -outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a -outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item - -data CompileReason - -- | The .hs file has been touched, or the .o/.hi file does not exist - = MustCompile - -- | The .o/.hi files are up to date, but something else has changed - -- to force recompilation; the String says what (one-line summary) - | RecompBecause !RecompReason - deriving (Eq) - -instance Outputable RecompileRequired where - ppr UpToDate = text "UpToDate" - ppr (NeedsRecompile reason) = ppr reason - -instance Outputable CompileReason where - ppr MustCompile = text "MustCompile" - ppr (RecompBecause r) = text "RecompBecause" <+> ppr r - -instance Semigroup RecompileRequired where - UpToDate <> r = r - mc <> _ = mc - -instance Monoid RecompileRequired where - mempty = UpToDate - -data RecompReason - = UnitDepRemoved UnitId - | ModulePackageChanged FastString - | SourceFileChanged - | ThisUnitIdChanged - | ImpurePlugin - | PluginsChanged - | PluginFingerprintChanged - | ModuleInstChanged - | HieMissing - | HieOutdated - | SigsMergeChanged - | ModuleChanged ModuleName - | ModuleRemoved (UnitId, ModuleName) - | ModuleAdded (UnitId, ModuleName) - | ModuleChangedRaw ModuleName - | ModuleChangedIface ModuleName - | FileChanged FilePath - | CustomReason String - | FlagsChanged - | OptimFlagsChanged - | HpcFlagsChanged - | MissingBytecode - | MissingObjectFile - | MissingDynObjectFile - | MissingDynHiFile - | MismatchedDynHiFile - | ObjectsChanged - | LibraryChanged - | THWithJS - deriving (Eq) - -instance Outputable RecompReason where - ppr = \case - UnitDepRemoved uid -> ppr uid <+> text "removed" - ModulePackageChanged s -> ftext s <+> text "package changed" - SourceFileChanged -> text "Source file changed" - ThisUnitIdChanged -> text "-this-unit-id changed" - ImpurePlugin -> text "Impure plugin forced recompilation" - PluginsChanged -> text "Plugins changed" - PluginFingerprintChanged -> text "Plugin fingerprint changed" - ModuleInstChanged -> text "Implementing module changed" - HieMissing -> text "HIE file is missing" - HieOutdated -> text "HIE file is out of date" - SigsMergeChanged -> text "Signatures to merge in changed" - ModuleChanged m -> ppr m <+> text "changed" - ModuleChangedRaw m -> ppr m <+> text "changed (raw)" - ModuleChangedIface m -> ppr m <+> text "changed (interface)" - ModuleRemoved (_uid, m) -> ppr m <+> text "removed" - ModuleAdded (_uid, m) -> ppr m <+> text "added" - FileChanged fp -> text fp <+> text "changed" - CustomReason s -> text s - FlagsChanged -> text "Flags changed" - OptimFlagsChanged -> text "Optimisation flags changed" - HpcFlagsChanged -> text "HPC flags changed" - MissingBytecode -> text "Missing bytecode" - MissingObjectFile -> text "Missing object file" - MissingDynObjectFile -> text "Missing dynamic object file" - MissingDynHiFile -> text "Missing dynamic interface file" - MismatchedDynHiFile -> text "Mismatched dynamic interface file" - ObjectsChanged -> text "Objects changed" - LibraryChanged -> text "Library changed" - THWithJS -> text "JS backend always recompiles modules using Template Haskell for now (#23013)" - -recompileRequired :: RecompileRequired -> Bool -recompileRequired UpToDate = False -recompileRequired _ = True - -recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired -recompThen ma mb = ma >>= \case - UpToDate -> mb - rr@(NeedsRecompile _) -> pure rr - -checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired -checkList = \case - [] -> return UpToDate - (check : checks) -> check `recompThen` checkList checks - ----------------------- - --- | Top level function to check if the version of an old interface file --- is equivalent to the current source file the user asked us to compile. --- If the same, we can avoid recompilation. --- --- We return on the outside whether the interface file is up to date, providing --- evidence that is with a `ModIface`. In the case that it isn't, we may also --- return a found or provided `ModIface`. Why we don't always return the old --- one, if it exists, is unclear to me, except that I tried it and some tests --- failed (see #18205). -checkOldIface - :: HscEnv - -> ModSummary - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (MaybeValidated ModIface) - -checkOldIface hsc_env mod_summary maybe_iface - = do let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - showPass logger $ - "Checking old interface for " ++ - (showPpr dflags $ ms_mod mod_summary) ++ - " (use -ddump-hi-diffs for more details)" - initIfaceCheck (text "checkOldIface") hsc_env $ - check_old_iface hsc_env mod_summary maybe_iface - -check_old_iface - :: HscEnv - -> ModSummary - -> Maybe ModIface - -> IfG (MaybeValidated ModIface) - -check_old_iface hsc_env mod_summary maybe_iface - = let dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - getIface = - case maybe_iface of - Just _ -> do - trace_if logger (text "We already have the old interface for" <+> - ppr (ms_mod mod_summary)) - return maybe_iface - Nothing -> loadIface dflags (msHiFilePath mod_summary) - - loadIface read_dflags iface_path = do - let ncu = hsc_NC hsc_env - read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path - case read_result of - Failed err -> do - let msg = readInterfaceErrorDiagnostic err - trace_if logger - $ vcat [ text "FYI: cannot read old interface file:" - , nest 4 msg ] - trace_hi_diffs logger $ - vcat [ text "Old interface file was invalid:" - , nest 4 msg ] - return Nothing - Succeeded iface -> do - trace_if logger (text "Read the interface file" <+> text iface_path) - return $ Just iface - check_dyn_hi :: ModIface - -> IfG (MaybeValidated ModIface) - -> IfG (MaybeValidated ModIface) - check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do - res <- recomp_check - case res of - UpToDateItem _ -> do - maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary) - case maybe_dyn_iface of - Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing - Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface) - /= mi_iface_hash (mi_final_exts normal_iface) - -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing - Just {} -> return res - _ -> return res - check_dyn_hi _ recomp_check = recomp_check - - - src_changed - | gopt Opt_ForceRecomp dflags = True - | otherwise = False - in do - when src_changed $ - liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off") - - case src_changed of - -- If the source has changed and we're in interactive mode, - -- avoid reading an interface; just return the one we might - -- have been supplied with. - True | not (backendWritesFiles $ backend dflags) -> - return $ OutOfDateItem MustCompile maybe_iface - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - True -> do - maybe_iface' <- liftIO $ getIface - return $ OutOfDateItem MustCompile maybe_iface' - - False -> do - maybe_iface' <- liftIO $ getIface - case maybe_iface' of - -- We can't retrieve the iface - Nothing -> return $ OutOfDateItem MustCompile Nothing - - -- We have got the old iface; check its versions - -- even in the SourceUnmodifiedAndStable case we - -- should check versions because some packages - -- might have changed or gone away. - Just iface -> - check_dyn_hi iface $ checkVersions hsc_env mod_summary iface - --- | Check if a module is still the same 'version'. --- --- This function is called in the recompilation checker after we have --- determined that the module M being checked hasn't had any changes --- to its source file since we last compiled M. So at this point in general --- two things may have changed that mean we should recompile M: --- * The interface export by a dependency of M has changed. --- * The compiler flags specified this time for M have changed --- in a manner that is significant for recompilation. --- We return not just if we should recompile the object file but also --- if we should rebuild the interface file. -checkVersions :: HscEnv - -> ModSummary - -> ModIface -- Old interface - -> IfG (MaybeValidated ModIface) -checkVersions hsc_env mod_summary iface - = do { liftIO $ trace_hi_diffs logger - (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) - - -- readIface will have verified that the UnitId matches, - -- but we ALSO must make sure the instantiation matches up. See - -- test case bkpcabal04! - ; hsc_env <- getTopEnv - ; if mi_src_hash iface /= ms_hs_hash mod_summary - then return $ outOfDateItemBecause SourceFileChanged Nothing else do { - ; if not (isHomeModule home_unit (mi_module iface)) - then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do { - ; recomp <- liftIO $ checkFlagHash hsc_env iface - `recompThen` checkOptimHash hsc_env iface - `recompThen` checkHpcHash hsc_env iface - `recompThen` checkMergedSignatures hsc_env mod_summary iface - `recompThen` checkHsig logger home_unit mod_summary iface - `recompThen` pure (checkHie dflags mod_summary) - ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { - ; recomp <- checkDependencies hsc_env mod_summary iface - ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { - ; recomp <- checkPlugins (hsc_plugins hsc_env) iface - ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { - - - -- Source code unchanged and no errors yet... carry on - -- - -- First put the dependent-module info, read from the old - -- interface, into the envt, so that when we look for - -- interfaces we look for the right one (.hi or .hi-boot) - -- - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - - when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { - ; updateEps_ $ \eps -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) } - } - ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u - | u <- mi_usages iface] - ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { - ; return $ UpToDateItem iface - }}}}}}} - where - logger = hsc_logger hsc_env - dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - - - --- | Check if any plugins are requesting recompilation -checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired -checkPlugins plugins iface = liftIO $ do - recomp <- recompPlugins plugins - let new_fingerprint = fingerprintPluginRecompile recomp - let old_fingerprint = mi_plugin_hash (mi_final_exts iface) - return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp - -recompPlugins :: Plugins -> IO PluginRecompile -recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins) - -fingerprintPlugins :: Plugins -> IO Fingerprint -fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins - -fingerprintPluginRecompile :: PluginRecompile -> Fingerprint -fingerprintPluginRecompile recomp = case recomp of - NoForceRecompile -> fingerprintString "NoForceRecompile" - ForceRecompile -> fingerprintString "ForceRecompile" - -- is the chance of collision worth worrying about? - -- An alternative is to fingerprintFingerprints [fingerprintString - -- "maybeRecompile", fp] - MaybeRecompile fp -> fp - - -pluginRecompileToRecompileRequired - :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired -pluginRecompileToRecompileRequired old_fp new_fp pr - | old_fp == new_fp = - case pr of - NoForceRecompile -> UpToDate - - -- we already checked the fingerprint above so a mismatch is not possible - -- here, remember that: `fingerprint (MaybeRecomp x) == x`. - MaybeRecompile _ -> UpToDate - - -- when we have an impure plugin in the stack we have to unconditionally - -- recompile since it might integrate all sorts of crazy IO results into - -- its compilation output. - ForceRecompile -> needsRecompileBecause ImpurePlugin - - | old_fp `elem` magic_fingerprints || - new_fp `elem` magic_fingerprints - -- The fingerprints do not match either the old or new one is a magic - -- fingerprint. This happens when non-pure plugins are added for the first - -- time or when we go from one recompilation strategy to another: (force -> - -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) - -- - -- For example when we go from ForceRecomp to NoForceRecomp - -- recompilation is triggered since the old impure plugins could have - -- changed the build output which is now back to normal. - = needsRecompileBecause PluginsChanged - - | otherwise = - case pr of - -- even though a plugin is forcing recompilation the fingerprint changed - -- which would cause recompilation anyways so we report the fingerprint - -- change instead. - ForceRecompile -> needsRecompileBecause PluginFingerprintChanged - - _ -> needsRecompileBecause PluginFingerprintChanged - - where - magic_fingerprints = - [ fingerprintString "NoForceRecompile" - , fingerprintString "ForceRecompile" - ] - - --- | Check if an hsig file needs recompilation because its --- implementing module has changed. -checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired -checkHsig logger home_unit mod_summary iface = do - let outer_mod = ms_mod mod_summary - inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) - massert (isHomeModule home_unit outer_mod) - case inner_mod == mi_semantic_module iface of - True -> up_to_date logger (text "implementing module unchanged") - False -> return $ needsRecompileBecause ModuleInstChanged - --- | Check if @.hie@ file is out of date or missing. -checkHie :: DynFlags -> ModSummary -> RecompileRequired -checkHie dflags mod_summary = - let hie_date_opt = ms_hie_date mod_summary - hi_date = ms_iface_date mod_summary - in if not (gopt Opt_WriteHie dflags) - then UpToDate - else case (hie_date_opt, hi_date) of - (Nothing, _) -> needsRecompileBecause HieMissing - (Just hie_date, Just hi_date) - | hie_date < hi_date - -> needsRecompileBecause HieOutdated - _ -> UpToDate - --- | Check the flags haven't changed -checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired -checkFlagHash hsc_env iface = do - let logger = hsc_logger hsc_env - let old_hash = mi_flag_hash (mi_final_exts iface) - new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally - case old_hash == new_hash of - True -> up_to_date logger (text "Module flags unchanged") - False -> out_of_date_hash logger FlagsChanged - (text " Module flags have changed") - old_hash new_hash - --- | Check the optimisation flags haven't changed -checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired -checkOptimHash hsc_env iface = do - let logger = hsc_logger hsc_env - let old_hash = mi_opt_hash (mi_final_exts iface) - new_hash <- fingerprintOptFlags (hsc_dflags hsc_env) - putNameLiterally - if | old_hash == new_hash - -> up_to_date logger (text "Optimisation flags unchanged") - | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) - -> up_to_date logger (text "Optimisation flags changed; ignoring") - | otherwise - -> out_of_date_hash logger OptimFlagsChanged - (text " Optimisation flags have changed") - old_hash new_hash - --- | Check the HPC flags haven't changed -checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired -checkHpcHash hsc_env iface = do - let logger = hsc_logger hsc_env - let old_hash = mi_hpc_hash (mi_final_exts iface) - new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env) - putNameLiterally - if | old_hash == new_hash - -> up_to_date logger (text "HPC flags unchanged") - | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) - -> up_to_date logger (text "HPC flags changed; ignoring") - | otherwise - -> out_of_date_hash logger HpcFlagsChanged - (text " HPC flags have changed") - old_hash new_hash - --- Check that the set of signatures we are merging in match. --- If the -unit-id flags change, this can change too. -checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired -checkMergedSignatures hsc_env mod_summary iface = do - let logger = hsc_logger hsc_env - let unit_state = hsc_units hsc_env - let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] - new_merged = case lookupUniqMap (requirementContext unit_state) - (ms_mod_name mod_summary) of - Nothing -> [] - Just r -> sort $ map (instModuleToModule unit_state) r - if old_merged == new_merged - then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) - else return $ needsRecompileBecause SigsMergeChanged - --- If the direct imports of this module are resolved to targets that --- are not among the dependencies of the previous interface file, --- then we definitely need to recompile. This catches cases like --- - an exposed package has been upgraded --- - we are compiling with different package flags --- - a home module that was shadowing a package module has been removed --- - a new home module has been added that shadows a package module --- See bug #1372. --- --- Returns (RecompBecause ) if recompilation is required. -checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired -checkDependencies hsc_env summary iface - = do - res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary) - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary) - case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of - Left recomp -> return $ NeedsRecompile recomp - Right es -> do - let (hs, ps) = partitionEithers es - liftIO $ - check_mods (sort hs) prev_dep_mods - `recompThen` - let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps) - in check_packages allPkgDeps prev_dep_pkgs - where - - classify_import :: (ModuleName -> t -> IO FindResult) - -> [(t, GenLocated l ModuleName)] - -> IfG - [Either - CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))] - classify_import find_import imports = - liftIO $ traverse (\(mb_pkg, L _ mod) -> - let reason = ModuleChanged mod - in classify reason <$> find_import mod mb_pkg) - imports - dflags = hsc_dflags hsc_env - fopts = initFinderOpts dflags - logger = hsc_logger hsc_env - fc = hsc_FC hsc_env - mhome_unit = hsc_home_unit_maybe hsc_env - all_home_units = hsc_all_home_unit_ids hsc_env - units = hsc_units hsc_env - prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface) - prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface)) - (dep_plugin_pkgs (mi_deps iface))) - - 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. - fake_ghc_prim_import = case mhome_unit of - Just home_unit - | homeUnitId home_unit == primUnitId - -> Left (primUnitId, mkModuleName "GHC.Prim") - _ -> Right (fsLit "GHC.Prim", primUnitId) - - - classify _ (Found _ mod) - | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod)) - | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) - classify reason _ = Left (RecompBecause reason) - - check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired - check_mods [] [] = return UpToDate - check_mods [] (old:_) = do - -- This case can happen when a module is change from HPT to package import - trace_hi_diffs logger $ - text "module no longer" <+> quotes (ppr old) <+> - text "in dependencies" - - return $ needsRecompileBecause $ ModuleRemoved old - check_mods (new:news) olds - | Just (old, olds') <- uncons olds - , new == old = check_mods (dropWhile (== new) news) olds' - | otherwise = do - trace_hi_diffs logger $ - text "imported module " <> quotes (ppr new) <> - text " not among previous dependencies" - return $ needsRecompileBecause $ ModuleAdded new - - check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired - check_packages [] [] = return UpToDate - check_packages [] (old:_) = do - trace_hi_diffs logger $ - text "package " <> quotes (ppr old) <> - text "no longer in dependencies" - return $ needsRecompileBecause $ UnitDepRemoved old - check_packages ((new_name, new_unit):news) olds - | Just (old, olds') <- uncons olds - , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds' - | otherwise = do - trace_hi_diffs logger $ - text "imported package" <+> ftext new_name <+> ppr new_unit <+> - text "not among previous dependencies" - return $ needsRecompileBecause $ ModulePackageChanged new_name - - -needInterface :: Module -> (ModIface -> IO RecompileRequired) - -> IfG RecompileRequired -needInterface mod continue - = do - mb_recomp <- tryGetModIface - "need version info for" - mod - case mb_recomp of - Nothing -> return $ NeedsRecompile MustCompile - Just iface -> liftIO $ continue iface - -tryGetModIface :: String -> Module -> IfG (Maybe ModIface) -tryGetModIface doc_msg mod - = do -- Load the imported interface if possible - logger <- getLogger - let doc_str = sep [text doc_msg, ppr mod] - liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod)) - - mb_iface <- loadInterface doc_str mod ImportBySystem - -- Load the interface, but don't complain on failure; - -- Instead, get an Either back which we can test - - case mb_iface of - Failed _ -> do - liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod]) - return Nothing - -- Couldn't find or parse a module mentioned in the - -- old interface file. Don't complain: it might - -- just be that the current module doesn't need that - -- import and it's been deleted - Succeeded iface -> pure $ Just iface - --- | Given the usage information extracted from the old --- M.hi file for the module being compiled, figure out --- whether M needs to be recompiled. -checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired -checkModUsage _ UsagePackageModule{ - usg_mod = mod, - usg_mod_hash = old_mod_hash } = do - logger <- getLogger - needInterface mod $ \iface -> do - let reason = ModuleChanged (moduleName mod) - checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) - -- We only track the ABI hash of package modules, rather than - -- individual entity usages, so if the ABI hash changes we must - -- recompile. This is safe but may entail more recompilation when - -- a dependent package has changed. - -checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do - logger <- getLogger - needInterface mod $ \iface -> do - let reason = ModuleChangedRaw (moduleName mod) - checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) -checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name - , usg_unit_id = uid - , usg_iface_hash = old_mod_hash } = do - let mod = mkModule (RealUnit (Definite uid)) mod_name - logger <- getLogger - needInterface mod $ \iface -> do - let reason = ModuleChangedIface mod_name - checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface)) - -checkModUsage _ UsageHomeModule{ - usg_mod_name = mod_name, - usg_unit_id = uid, - usg_mod_hash = old_mod_hash, - usg_exports = maybe_old_export_hash, - usg_entities = old_decl_hash } - = do - let mod = mkModule (RealUnit (Definite uid)) mod_name - logger <- getLogger - needInterface mod $ \iface -> do - let - new_mod_hash = mi_mod_hash (mi_final_exts iface) - new_decl_hash = mi_hash_fn (mi_final_exts iface) - new_export_hash = mi_exp_hash (mi_final_exts iface) - - reason = ModuleChanged (moduleName mod) - - liftIO $ do - -- CHECK MODULE - recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash - if not (recompileRequired recompile) - then return UpToDate - else checkList - [ -- CHECK EXPORT LIST - checkMaybeHash logger reason maybe_old_export_hash new_export_hash - (text " Export list changed") - , -- CHECK ITEMS ONE BY ONE - checkList [ checkEntityUsage logger reason new_decl_hash u - | u <- old_decl_hash] - , up_to_date logger (text " Great! The bits I use are up to date") - ] - -checkModUsage fc UsageFile{ usg_file_path = file, - usg_file_hash = old_hash, - usg_file_label = mlabel } = - liftIO $ - handleIO handler $ do - new_hash <- lookupFileCache fc $ unpackFS file - if (old_hash /= new_hash) - then return recomp - else return UpToDate - where - reason = FileChanged $ unpackFS file - recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel - handler = if debugIsOn - then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp - else \_ -> return recomp -- if we can't find the file, just recompile, don't fail - ------------------------- -checkModuleFingerprint - :: Logger - -> RecompReason - -> Fingerprint - -> Fingerprint - -> IO RecompileRequired -checkModuleFingerprint logger reason old_mod_hash new_mod_hash - | new_mod_hash == old_mod_hash - = up_to_date logger (text "Module fingerprint unchanged") - - | otherwise - = out_of_date_hash logger reason (text " Module fingerprint has changed") - old_mod_hash new_mod_hash - -checkIfaceFingerprint - :: Logger - -> RecompReason - -> Fingerprint - -> Fingerprint - -> IO RecompileRequired -checkIfaceFingerprint logger reason old_mod_hash new_mod_hash - | new_mod_hash == old_mod_hash - = up_to_date logger (text "Iface fingerprint unchanged") - - | otherwise - = out_of_date_hash logger reason (text " Iface fingerprint has changed") - old_mod_hash new_mod_hash - ------------------------- -checkMaybeHash - :: Logger - -> RecompReason - -> Maybe Fingerprint - -> Fingerprint - -> SDoc - -> IO RecompileRequired -checkMaybeHash logger reason maybe_old_hash new_hash doc - | Just hash <- maybe_old_hash, hash /= new_hash - = out_of_date_hash logger reason doc hash new_hash - | otherwise - = return UpToDate - ------------------------- -checkEntityUsage :: Logger - -> RecompReason - -> (OccName -> Maybe (OccName, Fingerprint)) - -> (OccName, Fingerprint) - -> IO RecompileRequired -checkEntityUsage logger reason new_hash (name,old_hash) = do - case new_hash name of - -- We used it before, but it ain't there now - Nothing -> out_of_date logger reason (sep [text "No longer exported:", ppr name]) - -- It's there, but is it up to date? - Just (_, new_hash) - | new_hash == old_hash - -> do trace_hi_diffs logger (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) - return UpToDate - | otherwise - -> out_of_date_hash logger reason (text " Out of date:" <+> ppr name) old_hash new_hash - -up_to_date :: Logger -> SDoc -> IO RecompileRequired -up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate - -out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired -out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason) - -out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired -out_of_date_hash logger reason msg old_hash new_hash - = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) - --- --------------------------------------------------------------------------- --- Compute fingerprints for the interface - -{- -Note [Fingerprinting IfaceDecls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The general idea here is that we first examine the 'IfaceDecl's and determine -the recursive groups of them. We then walk these groups in dependency order, -serializing each contained 'IfaceDecl' to a "Binary" buffer which we then -hash using MD5 to produce a fingerprint for the group. - -However, the serialization that we use is a bit funny: we override the @putName@ -operation with our own which serializes the hash of a 'Name' instead of the -'Name' itself. This ensures that the fingerprint of a decl changes if anything -in its transitive closure changes. This trick is why we must be careful about -traversing in dependency order: we need to ensure that we have hashes for -everything referenced by the decl which we are fingerprinting. - -Moreover, we need to be careful to distinguish between serialization of binding -Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls -field of a IfaceClsInst): only in the non-binding case should we include the -fingerprint; in the binding case we shouldn't since it is merely the name of the -thing that we are currently fingerprinting. - - -Note [Fingerprinting recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The fingerprinting of a single recursive group is a rather subtle affair, as -seen in #18733. - -How not to fingerprint ----------------------- - -Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a -group in hash environment `hash_env0`: - - 1. extend hash_env0, giving each declaration in the group the fingerprint 0 - 2. use this environment to hash the declarations' ABIs, resulting in - group_fingerprint - 3. produce the final hash environment by extending hash_env0, mapping each - declaration of the group to group_fingerprint - -However, this is wrong. Consider, for instance, a program like: - - data A = ARecu B | ABase String deriving (Show) - data B = BRecu A | BBase Int deriving (Show) - - info :: B - info = BBase 1 - -A consequence of (3) is that A and B will have the same fingerprint. This means -that if the user changes `info` to: - - info :: A - info = ABase "hello" - -The program's ABI fingerprint will not change despite `info`'s type, and -therefore ABI, being clearly different. - -However, the incorrectness doesn't end there: (1) means that all recursive -occurrences of names within the group will be given the same fingerprint. This -means that the group's fingerprint won't change if we change an occurrence of A -to B. - -Surprisingly, this bug (#18733) lurked for many years before being uncovered. - -How we now fingerprint ----------------------- - -As seen above, the fingerprinting function must ensure that a groups -fingerprint captures the structure of within-group occurrences. The scheme that -we use is: - - 0. To ensure determinism, sort the declarations into a stable order by - declaration name - - 1. Extend hash_env0, giving each declaration in the group a sequential - fingerprint (e.g. 0, 1, 2, ...). - - 2. Use this environment to hash the declarations' ABIs, resulting in - group_fingerprint. - - Since we included the sequence number in step (1) programs identical up to - transposition of recursive occurrences are distinguishable, avoiding the - second issue mentioned above. - - 3. Produce the final environment by extending hash_env, mapping each - declaration of the group to the hash of (group_fingerprint, i), where - i is the position of the declaration in the stable ordering. - - Including i in the hash ensures that the first issue noted above is - avoided. - --} - --- | Add fingerprints for top-level declarations to a 'ModIface'. --- --- See Note [Fingerprinting IfaceDecls] -addFingerprints - :: HscEnv - -> PartialModIface - -> IO ModIface -addFingerprints hsc_env iface0 - = do - eps <- hscEPS hsc_env - let - decls = mi_decls iface0 - decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings $ mi_warns iface0) - export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ mi_warns iface0) - fix_fn = mkIfaceFixCache (mi_fixities iface0) - - -- The ABI of a declaration represents everything that is made - -- visible about the declaration that a client can depend on. - -- see IfaceDeclABI below. - declABI :: IfaceDecl -> IfaceDeclABI - -- TODO: I'm not sure if this should be semantic_mod or this_mod. - -- See also Note [Identity versus semantic module] - declABI decl = (this_mod, decl, extras) - where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts - non_orph_fis top_lvl_name_env decl - - -- This is used for looking up the Name of a default method - -- from its OccName. See Note [default method Name] - top_lvl_name_env = - mkOccEnv [ (nameOccName nm, nm) - | IfaceId { ifName = nm } <- decls ] - - -- Dependency edges between declarations in the current module. - -- This is computed by finding the free external names of each - -- declaration, including IfaceDeclExtras (things that a - -- declaration implicitly depends on). - edges :: [ Node OccName IfaceDeclABI ] - edges = [ DigraphNode abi (getOccName decl) out - | decl <- decls - , let abi = declABI decl - , let out = localOccs $ freeNamesDeclABI abi - ] - - name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n) - localOccs = - map (getParent . getOccName) - -- NB: names always use semantic module, so - -- filtering must be on the semantic module! - -- See Note [Identity versus semantic module] - . filter ((== semantic_mod) . name_module) - . nonDetEltsUniqSet - -- It's OK to use nonDetEltsUFM as localOccs is only - -- used to construct the edges and - -- stronglyConnCompFromEdgedVertices is deterministic - -- even with non-deterministic order of edges as - -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. - where getParent :: OccName -> OccName - getParent occ = lookupOccEnv parent_map occ `orElse` occ - - -- maps OccNames to their parents in the current module. - -- e.g. a reference to a constructor must be turned into a reference - -- to the TyCon for the purposes of calculating dependencies. - parent_map :: OccEnv OccName - parent_map = foldl' extend emptyOccEnv decls - where extend env d = - extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] - where n = getOccName d - - -- Strongly-connected groups of declarations, in dependency order - groups :: [SCC IfaceDeclABI] - groups = stronglyConnCompFromEdgedVerticesOrd edges - - global_hash_fn = mkHashFun hsc_env eps - - -- How to output Names when generating the data to fingerprint. - -- Here we want to output the fingerprint for each top-level - -- Name, whether it comes from the current module or another - -- module. In this way, the fingerprint for a declaration will - -- change if the fingerprint for anything it refers to (transitively) - -- changes. - mk_put_name :: OccEnv (OccName,Fingerprint) - -> BinHandle -> Name -> IO () - mk_put_name local_env bh name - | isWiredInName name = putNameLiterally bh name - -- wired-in names don't have fingerprints - | otherwise - = assertPpr (isExternalName name) (ppr name) $ - let hash | nameModule name /= semantic_mod = global_hash_fn name - -- Get it from the REAL interface!! - -- This will trigger when we compile an hsig file - -- and we know a backing impl for it. - -- See Note [Identity versus semantic module] - | semantic_mod /= this_mod - , not (isHoleModule semantic_mod) = global_hash_fn name - | otherwise = return (snd (lookupOccEnv local_env (getOccName name) - `orElse` pprPanic "urk! lookup local fingerprint" - (ppr name $$ ppr local_env))) - -- This panic indicates that we got the dependency - -- analysis wrong, because we needed a fingerprint for - -- an entity that wasn't in the environment. To debug - -- it, turn the panic into a trace, uncomment the - -- pprTraces below, run the compile again, and inspect - -- the output and the generated .hi file with - -- --show-iface. - in hash >>= put_ bh - - -- take a strongly-connected group of declarations and compute - -- its fingerprint. - - fingerprint_group :: (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) - -> SCC IfaceDeclABI - -> IO (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) - - fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) - = do let hash_fn = mk_put_name local_env - decl = abiDecl abi - --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do - hash <- computeFingerprint hash_fn abi - env' <- extend_hash_env local_env (hash,decl) - return (env', (hash,decl) : decls_w_hashes) - - fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) - = do let stable_abis = sortBy cmp_abiNames abis - stable_decls = map abiDecl stable_abis - local_env1 <- foldM extend_hash_env local_env - (zip (map mkRecFingerprint [0..]) stable_decls) - -- See Note [Fingerprinting recursive groups] - let hash_fn = mk_put_name local_env1 - -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do - -- put the cycle in a canonical order - hash <- computeFingerprint hash_fn stable_abis - let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls - -- See Note [Fingerprinting recursive groups] - local_env2 <- foldM extend_hash_env local_env pairs - return (local_env2, pairs ++ decls_w_hashes) - - -- Make a fingerprint from the ordinal position of a binding in its group. - mkRecFingerprint :: Word64 -> Fingerprint - mkRecFingerprint i = Fingerprint 0 i - - bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint - bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ] - - -- we have fingerprinted the whole declaration, but we now need - -- to assign fingerprints to all the OccNames that it binds, to - -- use when referencing those OccNames in later declarations. - -- - extend_hash_env :: OccEnv (OccName,Fingerprint) - -> (Fingerprint,IfaceDecl) - -> IO (OccEnv (OccName,Fingerprint)) - extend_hash_env env0 (hash,d) = - return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 - (ifaceDeclFingerprints hash d)) - - -- - (local_env, decls_w_hashes) <- - foldM fingerprint_group (emptyOccEnv, []) groups - - -- when calculating fingerprints, we always need to use canonical ordering - -- for lists of things. The mi_deps has various lists of modules and - -- suchlike, which are stored in canonical order: - let sorted_deps :: Dependencies - sorted_deps = mi_deps iface0 - - -- The export hash of a module depends on the orphan hashes of the - -- orphan modules below us in the dependency tree. This is the way - -- that changes in orphans get propagated all the way up the - -- dependency tree. - -- - -- Note [A bad dep_orphs optimization] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- In a previous version of this code, we filtered out orphan modules which - -- were not from the home package, justifying it by saying that "we'd - -- pick up the ABI hashes of the external module instead". This is wrong. - -- Suppose that we have: - -- - -- module External where - -- instance Show (a -> b) - -- - -- module Home1 where - -- import External - -- - -- module Home2 where - -- import Home1 - -- - -- The export hash of Home1 needs to reflect the orphan instances of - -- External. It's true that Home1 will get rebuilt if the orphans - -- of External, but we also need to make sure Home2 gets rebuilt - -- as well. See #12733 for more details. - let orph_mods - = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] - $ dep_orphs sorted_deps - dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods - - -- Note [Do not update EPS with your own hi-boot] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- (See also #10182). When your hs-boot file includes an orphan - -- instance declaration, you may find that the dep_orphs of a module you - -- import contains reference to yourself. DO NOT actually load this module - -- or add it to the orphan hashes: you're going to provide the orphan - -- instances yourself, no need to consult hs-boot; if you do load the - -- interface into EPS, you will see a duplicate orphan instance. - - orphan_hash <- computeFingerprint (mk_put_name local_env) - (map ifDFun orph_insts, orph_rules, orph_fis) - - -- Hash of the transitive things in dependencies - dep_hash <- computeFingerprint putNameLiterally - (dep_sig_mods (mi_deps iface0), - dep_boot_mods (mi_deps iface0), - -- Trusted packages are like orphans - dep_trusted_pkgs (mi_deps iface0), - -- See Note [Export hash depends on non-orphan family instances] - dep_finsts (mi_deps iface0) ) - - -- the export list hash doesn't depend on the fingerprints of - -- the Names it mentions, only the Names themselves, hence putNameLiterally. - export_hash <- computeFingerprint putNameLiterally - (mi_exports iface0, - orphan_hash, - dep_hash, - dep_orphan_hashes, - mi_trust iface0) - -- Make sure change of Safe Haskell mode causes recomp. - - -- Note [Export hash depends on non-orphan family instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- Suppose we have: - -- - -- module A where - -- type instance F Int = Bool - -- - -- module B where - -- import A - -- - -- module C where - -- import B - -- - -- The family instance consistency check for C depends on the dep_finsts of - -- B. If we rename module A to A2, when the dep_finsts of B changes, we need - -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of - -- the exports of B, because C always considers them when checking - -- consistency. - -- - -- A full discussion is in #12723. - -- - -- We do NOT need to hash dep_orphs, because this is implied by - -- dep_orphan_hashes, and we do not need to hash ordinary class instances, - -- because there is no eager consistency check as there is with type families - -- (also we didn't store it anywhere!) - -- - - -- put the declarations in a canonical order, sorted by OccName - let sorted_decls :: [(Fingerprint, IfaceDecl)] - sorted_decls = Map.elems $ Map.fromList $ - [(getOccName d, e) | e@(_, d) <- decls_w_hashes] - - -- This key is safe because mi_extra_decls contains tidied things. - getOcc (IfGblTopBndr b) = getOccName b - getOcc (IfLclTopBndr fs _ _ details) = - case details of - IfRecSelId { ifRecSelFirstCon = first_con } - -> mkRecFieldOccFS (getOccFS first_con) fs - _ -> mkVarOccFS fs - - binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) () - binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs) - - sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] - sorted_extra_decls = sortOn binding_key <$> mi_extra_decls iface0 - - -- the flag hash depends on: - -- - (some of) dflags - -- it returns two hashes, one that shouldn't change - -- the abi hash and one that should - flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally - - opt_hash <- fingerprintOptFlags dflags putNameLiterally - - hpc_hash <- fingerprintHpcFlags dflags putNameLiterally - - plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env) - - -- the ABI hash depends on: - -- - decls - -- - export list - -- - orphans - -- - deprecations - -- - flag abi hash - mod_hash <- computeFingerprint putNameLiterally - (map fst sorted_decls, - export_hash, -- includes orphan_hash - mi_warns iface0) - - -- The interface hash depends on: - -- - the ABI hash, plus - -- - the source file hash, - -- - the module level annotations, - -- - usages - -- - deps (home and external packages, dependent files) - -- - hpc - iface_hash <- computeFingerprint putNameLiterally - (mod_hash, - mi_src_hash iface0, - ann_fn (mkVarOccFS (fsLit "module")), -- See mkIfaceAnnCache - mi_usages iface0, - sorted_deps, - mi_hpc iface0) - - let - final_iface_exts = ModIfaceBackend - { mi_iface_hash = iface_hash - , mi_mod_hash = mod_hash - , mi_flag_hash = flag_hash - , mi_opt_hash = opt_hash - , mi_hpc_hash = hpc_hash - , mi_plugin_hash = plugin_hash - , mi_orphan = not ( all ifRuleAuto orph_rules - -- See Note [Orphans and auto-generated rules] - && null orph_insts - && null orph_fis) - , mi_finsts = not (null (mi_fam_insts iface0)) - , mi_exp_hash = export_hash - , mi_orphan_hash = orphan_hash - , mi_decl_warn_fn = decl_warn_fn - , mi_export_warn_fn = export_warn_fn - , mi_fix_fn = fix_fn - , mi_hash_fn = lookupOccEnv local_env - } - final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts } - -- - return final_iface - - where - this_mod = mi_module iface0 - semantic_mod = mi_semantic_module iface0 - dflags = hsc_dflags hsc_env - (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) - (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) - (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) - ann_fn = mkIfaceAnnCache (mi_anns iface0) - --- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules --- (in particular, the orphan modules which are transitively imported by the --- current module). --- --- Q: Why do we need the hash at all, doesn't the list of transitively --- imported orphan modules suffice? --- --- A: If one of our transitive imports adds a new orphan instance, our --- export hash must change so that modules which import us rebuild. If we just --- hashed the [Module], the hash would not change even when a new instance was --- added to a module that already had an orphan instance. --- --- Q: Why don't we just hash the orphan hashes of our direct dependencies? --- Why the full transitive closure? --- --- A: Suppose we have these modules: --- --- module A where --- instance Show (a -> b) where --- module B where --- import A -- ** --- module C where --- import A --- import B --- --- Whether or not we add or remove the import to A in B affects the --- orphan hash of B. But it shouldn't really affect the orphan hash --- of C. If we hashed only direct dependencies, there would be no --- way to tell that the net effect was a wash, and we'd be forced --- to recompile C and everything else. -getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] -getOrphanHashes hsc_env mods = do - let - dflags = hsc_dflags hsc_env - ctx = initSDocContext dflags defaultUserStyle - get_orph_hash mod = do - iface <- initIfaceLoad hsc_env . withIfaceErr ctx - $ loadInterface (text "getOrphanHashes") mod ImportBySystem - return (mi_orphan_hash (mi_final_exts iface)) - - mapM get_orph_hash mods - - -{- -************************************************************************ -* * - The ABI of an IfaceDecl -* * -************************************************************************ - -Note [The ABI of an IfaceDecl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The ABI of a declaration consists of: - - (a) the full name of the identifier (inc. module and package, - because these are used to construct the symbol name by which - the identifier is known externally). - - (b) the declaration itself, as exposed to clients. That is, the - definition of an Id is included in the fingerprint only if - it is made available as an unfolding in the interface. - - (c) the fixity of the identifier (if it exists) - (d) for Ids: rules - (e) for classes: instances, fixity & rules for methods - (f) for datatypes: instances, fixity & rules for constrs - -Items (c)-(f) are not stored in the IfaceDecl, but instead appear -elsewhere in the interface file. But they are *fingerprinted* with -the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, -and fingerprinting that as part of the declaration. --} - -type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) - -data IfaceDeclExtras - = IfaceIdExtras IfaceIdExtras - - | IfaceDataExtras - (Maybe Fixity) -- Fixity of the tycon itself (if it exists) - [IfaceInstABI] -- Local class and family instances of this tycon - -- See Note [Orphans] in GHC.Core.InstEnv - [AnnPayload] -- Annotations of the type itself - [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations - - | IfaceClassExtras - (Maybe Fixity) -- Fixity of the class itself (if it exists) - [IfaceInstABI] -- Local instances of this class *or* - -- of its associated data types - -- See Note [Orphans] in GHC.Core.InstEnv - [AnnPayload] -- Annotations of the type itself - [IfaceIdExtras] -- For each class method: fixity, RULES and annotations - [IfExtName] -- Default methods. If a module - -- mentions a class, then it can - -- instantiate the class and thereby - -- use the default methods, so we must - -- include these in the fingerprint of - -- a class. - - | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] - - | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] - - | IfaceOtherDeclExtras - -data IfaceIdExtras - = IdExtras - (Maybe Fixity) -- Fixity of the Id (if it exists) - [IfaceRule] -- Rules for the Id - [AnnPayload] -- Annotations for the Id - --- When hashing a class or family instance, we hash only the --- DFunId or CoAxiom, because that depends on all the --- information about the instance. --- -type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance - -abiDecl :: IfaceDeclABI -> IfaceDecl -abiDecl (_, decl, _) = decl - -cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering -cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` - getOccName (abiDecl abi2) - -freeNamesDeclABI :: IfaceDeclABI -> NameSet -freeNamesDeclABI (_mod, decl, extras) = - freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras - -freeNamesDeclExtras :: IfaceDeclExtras -> NameSet -freeNamesDeclExtras (IfaceIdExtras id_extras) - = freeNamesIdExtras id_extras -freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) - = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) -freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms) - = unionNameSets $ - mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs -freeNamesDeclExtras (IfaceSynonymExtras _ _) - = emptyNameSet -freeNamesDeclExtras (IfaceFamilyExtras _ insts _) - = mkNameSet insts -freeNamesDeclExtras IfaceOtherDeclExtras - = emptyNameSet - -freeNamesIdExtras :: IfaceIdExtras -> NameSet -freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules) - -instance Outputable IfaceDeclExtras where - ppr IfaceOtherDeclExtras = Outputable.empty - ppr (IfaceIdExtras extras) = ppr_id_extras extras - ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] - ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] - ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, - ppr_id_extras_s stuff] - ppr (IfaceClassExtras fix insts anns stuff defms) = - vcat [ppr fix, ppr_insts insts, ppr anns, - ppr_id_extras_s stuff, ppr defms] - -ppr_insts :: [IfaceInstABI] -> SDoc -ppr_insts _ = text "" - -ppr_id_extras_s :: [IfaceIdExtras] -> SDoc -ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) - -ppr_id_extras :: IfaceIdExtras -> SDoc -ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) - --- This instance is used only to compute fingerprints -instance Binary IfaceDeclExtras where - get _bh = panic "no get for IfaceDeclExtras" - put_ bh (IfaceIdExtras extras) = do - putByte bh 1; put_ bh extras - put_ bh (IfaceDataExtras fix insts anns cons) = do - putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons - put_ bh (IfaceClassExtras fix insts anns methods defms) = do - putByte bh 3 - put_ bh fix - put_ bh insts - put_ bh anns - put_ bh methods - put_ bh defms - put_ bh (IfaceSynonymExtras fix anns) = do - putByte bh 4; put_ bh fix; put_ bh anns - put_ bh (IfaceFamilyExtras fix finsts anns) = do - putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns - put_ bh IfaceOtherDeclExtras = putByte bh 6 - -instance Binary IfaceIdExtras where - get _bh = panic "no get for IfaceIdExtras" - put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } - -declExtras :: (OccName -> Maybe Fixity) - -> (OccName -> [AnnPayload]) - -> OccEnv [IfaceRule] - -> OccEnv [IfaceClsInst] - -> OccEnv [IfaceFamInst] - -> OccEnv IfExtName -- lookup default method names - -> IfaceDecl - -> IfaceDeclExtras - -declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl - = case decl of - IfaceId{} -> IfaceIdExtras (id_extras n) - IfaceData{ifCons=cons} -> - IfaceDataExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ - map ifDFun (lookupOccEnvL inst_env n)) - (ann_fn n) - (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) - IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> - IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms - where - insts = (map ifDFun $ (concatMap at_extras ats) - ++ lookupOccEnvL inst_env n) - -- Include instances of the associated types - -- as well as instances of the class (#5147) - meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] - -- Names of all the default methods (see Note [default method Name]) - defms = [ dmName - | IfaceClassOp bndr _ (Just _) <- sigs - , let dmOcc = mkDefaultMethodOcc (nameOccName bndr) - , Just dmName <- [lookupOccEnv dm_env dmOcc] ] - IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) - (ann_fn n) - IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) - (map ifFamInstAxiom (lookupOccEnvL fi_env n)) - (ann_fn n) - _other -> IfaceOtherDeclExtras - where - n = getOccName decl - id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) - at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) - - -{- Note [default method Name] (see also #15970) - ~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The Names for the default methods aren't available in Iface syntax. - -* We originally start with a DefMethInfo from the class, contain a - Name for the default method - -* We turn that into Iface syntax as a DefMethSpec which lacks a Name - entirely. Why? Because the Name can be derived from the method name - (in GHC.IfaceToCore), so doesn't need to be serialised into the interface - file. - -But now we have to get the Name back, because the class declaration's -fingerprint needs to depend on it (this was the bug in #15970). This -is done in a slightly convoluted way: - -* Then, in addFingerprints we build a map that maps OccNames to Names - -* We pass that map to declExtras which laboriously looks up in the map - (using the derived occurrence name) to recover the Name we have just - thrown away. --} - -lookupOccEnvL :: OccEnv [v] -> OccName -> [v] -lookupOccEnvL env k = lookupOccEnv env k `orElse` [] - -{- --- for testing: use the md5sum command to generate fingerprints and --- compare the results against our built-in version. - fp' <- oldMD5 dflags bh - if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') - else return fp - -oldMD5 dflags bh = do - tmp <- newTempName dflags CurrentModule "bin" - writeBinMem bh tmp - tmp2 <- newTempName dflags CurrentModule "md5" - let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 - r <- system cmd - case r of - ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) - ExitSuccess -> do - hash_str <- readFile tmp2 - return $! readHexFingerprint hash_str --} - ----------------------- --- mkOrphMap partitions instance decls or rules into --- (a) an OccEnv for ones that are not orphans, --- mapping the local OccName to a list of its decls --- (b) a list of orphan decls -mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl - -> [decl] -- Sorted into canonical order - -> (OccEnv [decl], -- Non-orphan decls associated with their key; - -- each sublist in canonical order - [decl]) -- Orphan decls; in canonical order -mkOrphMap get_key decls - = foldl' go (emptyOccEnv, []) decls - where - go (non_orphs, orphs) d - | NotOrphan occ <- get_key d - = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs) - | otherwise = (non_orphs, d:orphs) - --- ----------------------------------------------------------------------------- --- Look up parents and versions of Names - --- This is like a global version of the mi_hash_fn field in each ModIface. --- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get --- the parent and version info. - -mkHashFun - :: HscEnv -- needed to look up versions - -> ExternalPackageState -- ditto - -> (Name -> IO Fingerprint) -mkHashFun hsc_env eps name - | isHoleModule orig_mod - = lookup (mkHomeModule home_unit (moduleName orig_mod)) - | otherwise - = lookup orig_mod - where - home_unit = hsc_home_unit hsc_env - dflags = hsc_dflags hsc_env - hpt = hsc_HUG hsc_env - pit = eps_PIT eps - ctx = initSDocContext dflags defaultUserStyle - occ = nameOccName name - orig_mod = nameModule name - lookup mod = do - massertPpr (isExternalName name) (ppr name) - iface <- case lookupIfaceByModule hpt pit mod of - Just iface -> return iface - Nothing -> - -- This can occur when we're writing out ifaces for - -- requirements; we didn't do any /real/ typechecking - -- so there's no guarantee everything is loaded. - -- Kind of a heinous hack. - initIfaceLoad hsc_env . withIfaceErr ctx - $ withoutDynamicNow - -- If you try and load interfaces when dynamic-too - -- enabled then it attempts to load the dyn_hi and hi - -- interface files. Backpack doesn't really care about - -- dynamic object files as it isn't doing any code - -- generation so -dynamic-too is turned off. - -- Some tests fail without doing this (such as T16219), - -- but they fail because dyn_hi files are not found for - -- one of the dependencies (because they are deliberately turned off) - -- Why is this check turned off here? That is unclear but - -- just one of the many horrible hacks in the backpack - -- implementation. - $ loadInterface (text "lookupVers2") mod ImportBySystem - return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr occ)) - - --- | Creates cached lookup for the 'mi_anns' field of ModIface --- Hackily, we use "module" as the OccName for any module-level annotations -mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload] -mkIfaceAnnCache anns - = \n -> lookupOccEnv env n `orElse` [] - where - pair (IfaceAnnotation target value) = - (case target of - NamedTarget occn -> occn - ModuleTarget _ -> mkVarOccFS (fsLit "module") - , [value]) - -- flipping (++), so the first argument is always short - env = mkOccEnv_C (flip (++)) (map pair anns) + , mkSelfRecomp + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Driver.Backend +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Plugins + + +import GHC.Iface.Syntax +import GHC.Iface.Recomp.Binary +import GHC.Iface.Recomp.Types +import GHC.Iface.Load +import GHC.Iface.Recomp.Flags +import GHC.Iface.Env + +import GHC.Core +import GHC.Tc.Utils.Monad +import GHC.Hs + +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Binary +import GHC.Utils.Fingerprint +import GHC.Utils.Exception +import GHC.Utils.Logger +import GHC.Utils.Constants (debugIsOn) + +import GHC.Types.Annotations +import GHC.Types.Avail +import GHC.Types.Basic ( ImportLevel(..) ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Types.Unique.Set +import GHC.Types.Fixity.Env +import GHC.Types.Unique.Map +import GHC.Unit.External +import GHC.Unit.Finder +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.Deps + +import Control.Monad +import Control.Monad.Trans.State +import Data.List (sortBy, sort, sortOn) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import Data.Either + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup +import GHC.List (uncons) +import Data.Ord +import Data.Containers.ListUtils +import GHC.Iface.Errors.Ppr +import Data.Functor +import Data.Bifunctor (first) +import GHC.Types.PkgQual + +{- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- + +A complete description of how recompilation checking works can be +found in the wiki commentary: + + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +Please read the above page for a top-down description of how this all +works. Notes below cover specific issues related to the implementation. + +Basic idea: + + * In the mi_usages information in an interface, we record the + fingerprint of each free variable of the module + + * In mkIface, we compute the fingerprint of each exported thing A.f. + For each external thing that A.f refers to, we include the fingerprint + of the external reference when computing the fingerprint of A.f. So + if anything that A.f depends on changes, then A.f's fingerprint will + change. + Also record any dependent files added with + * addDependentFile + * #include + * -optP-include + + * In checkOldIface we compare the mi_usages for the module with + the actual fingerprint for all each thing recorded in mi_usages +-} + +data RecompileRequired + -- | everything is up to date, recompilation is not required + = UpToDate + -- | Need to compile the module + | NeedsRecompile !CompileReason + deriving (Eq) + +needsRecompileBecause :: RecompReason -> RecompileRequired +needsRecompileBecause = NeedsRecompile . RecompBecause + +data MaybeValidated a + -- | The item contained is validated to be up to date + = UpToDateItem a + -- | The item is are absent altogether or out of date, for the reason given. + | OutOfDateItem + !CompileReason + -- ^ the reason we need to recompile. + (Maybe a) + -- ^ The old item, if it exists + deriving (Functor) + +instance Outputable a => Outputable (MaybeValidated a) where + ppr (UpToDateItem a) = text "UpToDate" <+> ppr a + ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r + +outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a +outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item + +data CompileReason + -- | The .hs file has been touched, or the .o/.hi file does not exist + = MustCompile + -- | The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + | RecompBecause !RecompReason + deriving (Eq) + +instance Outputable RecompileRequired where + ppr UpToDate = text "UpToDate" + ppr (NeedsRecompile reason) = ppr reason + +instance Outputable CompileReason where + ppr MustCompile = text "MustCompile" + ppr (RecompBecause r) = text "RecompBecause" <+> ppr r + +instance Semigroup RecompileRequired where + UpToDate <> r = r + mc <> _ = mc + +instance Monoid RecompileRequired where + mempty = UpToDate + +data RecompReason + = UnitDepRemoved (ImportLevel, UnitId) + | ModulePackageChanged FastString + | SourceFileChanged + | NoSelfRecompInfo + | ThisUnitIdChanged + | ImpurePlugin + | PluginsChanged + | PluginFingerprintChanged + | ModuleInstChanged + | HieMissing + | HieOutdated + | SigsMergeChanged + | ModuleChanged ModuleName + | ModuleRemoved (ImportLevel, UnitId, ModuleName) + | ModuleAdded (ImportLevel, UnitId, ModuleName) + | ModuleChangedRaw ModuleName + | ModuleChangedIface ModuleName + | FileChanged FilePath + | CustomReason String + | FlagsChanged + | LinkFlagsChanged + | OptimFlagsChanged + | HpcFlagsChanged + | MissingBytecode + | MissingObjectFile + | MissingDynObjectFile + | MissingDynHiFile + | MismatchedDynHiFile + | ObjectsChanged + | LibraryChanged + | THWithJS + deriving (Eq) + + +instance Outputable RecompReason where + ppr = \case + UnitDepRemoved (_lvl, uid) -> ppr uid <+> text "removed" + ModulePackageChanged s -> ftext s <+> text "package changed" + SourceFileChanged -> text "Source file changed" + NoSelfRecompInfo -> text "Old interface lacks recompilation info" + ThisUnitIdChanged -> text "-this-unit-id changed" + ImpurePlugin -> text "Impure plugin forced recompilation" + PluginsChanged -> text "Plugins changed" + PluginFingerprintChanged -> text "Plugin fingerprint changed" + ModuleInstChanged -> text "Implementing module changed" + HieMissing -> text "HIE file is missing" + HieOutdated -> text "HIE file is out of date" + SigsMergeChanged -> text "Signatures to merge in changed" + ModuleChanged m -> ppr m <+> text "changed" + ModuleChangedRaw m -> ppr m <+> text "changed (raw)" + ModuleChangedIface m -> ppr m <+> text "changed (interface)" + ModuleRemoved (_st, _uid, m) -> ppr m <+> text "removed" + ModuleAdded (_st, _uid, m) -> ppr m <+> text "added" + FileChanged fp -> text fp <+> text "changed" + CustomReason s -> text s + FlagsChanged -> text "Flags changed" + LinkFlagsChanged -> text "Flags changed" + OptimFlagsChanged -> text "Optimisation flags changed" + HpcFlagsChanged -> text "HPC flags changed" + MissingBytecode -> text "Missing bytecode" + MissingObjectFile -> text "Missing object file" + MissingDynObjectFile -> text "Missing dynamic object file" + MissingDynHiFile -> text "Missing dynamic interface file" + MismatchedDynHiFile -> text "Mismatched dynamic interface file" + ObjectsChanged -> text "Objects changed" + LibraryChanged -> text "Library changed" + THWithJS -> text "JS backend always recompiles modules using Template Haskell for now (#23013)" + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + +recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired +recompThen ma mb = ma >>= \case + UpToDate -> mb + rr@(NeedsRecompile _) -> pure rr + +checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired +checkList = \case + [] -> return UpToDate + (check : checks) -> check `recompThen` checkList checks + +---------------------- + +-- | Top level function to check if the version of an old interface file +-- is equivalent to the current source file the user asked us to compile. +-- If the same, we can avoid recompilation. +-- +-- We return on the outside whether the interface file is up to date, providing +-- evidence that is with a `ModIface`. In the case that it isn't, we may also +-- return a found or provided `ModIface`. Why we don't always return the old +-- one, if it exists, is unclear to me, except that I tried it and some tests +-- failed (see #18205). +checkOldIface + :: HscEnv + -> ModSummary + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (MaybeValidated ModIface) + +checkOldIface hsc_env mod_summary maybe_iface + = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + showPass logger $ + "Checking old interface for " ++ + (showPpr dflags $ ms_mod mod_summary) ++ + " (use -ddump-hi-diffs for more details)" + initIfaceCheck (text "checkOldIface") hsc_env $ + check_old_iface hsc_env mod_summary maybe_iface + +check_old_iface + :: HscEnv + -> ModSummary + -> Maybe ModIface + -> IfG (MaybeValidated ModIface) + +check_old_iface hsc_env mod_summary maybe_iface + = let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + getIface = + case maybe_iface of + Just {} -> do + trace_if logger (text "We already have the old interface for" <+> + ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> loadIface dflags (msHiFilePath mod_summary) + + loadIface read_dflags iface_path = do + let ncu = hsc_NC hsc_env + read_result <- readIface (hsc_hooks hsc_env) logger read_dflags ncu (ms_mod mod_summary) iface_path + case read_result of + Failed err -> do + let msg = readInterfaceErrorDiagnostic err + trace_if logger + $ vcat [ text "FYI: cannot read old interface file:" + , nest 4 msg ] + trace_hi_diffs logger $ + vcat [ text "Old interface file was invalid:" + , nest 4 msg ] + return Nothing + Succeeded iface -> do + trace_if logger (text "Read the interface file" <+> text iface_path) + return $ Just iface + check_dyn_hi :: ModIface + -> IfG (MaybeValidated ModIface) + -> IfG (MaybeValidated ModIface) + check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do + res <- recomp_check + case res of + UpToDateItem _ -> do + maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary) + case maybe_dyn_iface of + Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing + Just dyn_iface | mi_iface_hash dyn_iface + /= mi_iface_hash normal_iface + -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing + Just {} -> return res + _ -> return res + check_dyn_hi _ recomp_check = recomp_check + + + src_changed + | gopt Opt_ForceRecomp dflags = True + | otherwise = False + in do + when src_changed $ + liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off") + + case src_changed of + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + True | not (backendWritesFiles $ backend dflags) -> + return $ OutOfDateItem MustCompile maybe_iface + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + True -> do + maybe_iface' <- liftIO $ getIface + return $ OutOfDateItem MustCompile maybe_iface' + + False -> do + maybe_iface' <- liftIO $ getIface + case maybe_iface' of + -- We can't retrieve the iface + Nothing -> return $ OutOfDateItem MustCompile Nothing + + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + Just iface -> + case mi_self_recomp_info iface of + Nothing -> return $ outOfDateItemBecause NoSelfRecompInfo Nothing + Just sr_info -> check_dyn_hi iface $ checkVersions hsc_env mod_summary iface sr_info + +-- | Check if a module is still the same 'version'. +-- +-- This function is called in the recompilation checker after we have +-- determined that the module M being checked hasn't had any changes +-- to its source file since we last compiled M. So at this point in general +-- two things may have changed that mean we should recompile M: +-- * The interface export by a dependency of M has changed. +-- * The compiler flags specified this time for M have changed +-- in a manner that is significant for recompilation. +-- We return not just if we should recompile the object file but also +-- if we should rebuild the interface file. +checkVersions :: HscEnv + -> ModSummary + -> ModIface -- Old interface + -> IfaceSelfRecomp + -> IfG (MaybeValidated ModIface) +checkVersions hsc_env mod_summary iface self_recomp + = do { liftIO $ trace_hi_diffs logger + (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) + + -- readIface will have verified that the UnitId matches, + -- but we ALSO must make sure the instantiation matches up. See + -- test case bkpcabal04! + ; hsc_env <- getTopEnv + ; if mi_sr_src_hash self_recomp /= ms_hs_hash mod_summary + then return $ outOfDateItemBecause SourceFileChanged Nothing else do { + ; if not (isHomeModule home_unit (mi_module iface)) + then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do { + ; recomp <- liftIO $ checkFlagHash hsc_env (mi_module iface) self_recomp + `recompThen` checkOptimHash hsc_env self_recomp + `recompThen` checkHpcHash hsc_env self_recomp + `recompThen` checkMergedSignatures hsc_env mod_summary self_recomp + `recompThen` checkHsig logger home_unit mod_summary iface + `recompThen` pure (checkHie dflags mod_summary) + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { + ; recomp <- checkDependencies hsc_env mod_summary iface + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { + ; recomp <- checkPlugins (hsc_plugins hsc_env) self_recomp + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do { + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + + when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { + ; updateEps_ $ \eps -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) } + } + ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) u + | u <- mi_sr_usages self_recomp] + ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do { + ; return $ UpToDateItem iface + }}}}}}} + where + logger = hsc_logger hsc_env + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + + + +-- | Check if any plugins are requesting recompilation +checkPlugins :: Plugins -> IfaceSelfRecomp -> IfG RecompileRequired +checkPlugins plugins self_recomp = liftIO $ do + recomp <- recompPlugins plugins + let new_fingerprint = fingerprintPluginRecompile recomp + let old_fingerprint = mi_sr_plugin_hash self_recomp + return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp + +recompPlugins :: Plugins -> IO PluginRecompile +recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins) + +fingerprintPlugins :: Plugins -> IO Fingerprint +fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins + +fingerprintPluginRecompile :: PluginRecompile -> Fingerprint +fingerprintPluginRecompile recomp = case recomp of + NoForceRecompile -> fingerprintString "NoForceRecompile" + ForceRecompile -> fingerprintString "ForceRecompile" + -- is the chance of collision worth worrying about? + -- An alternative is to fingerprintFingerprints [fingerprintString + -- "maybeRecompile", fp] + MaybeRecompile fp -> fp + + +pluginRecompileToRecompileRequired + :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired +pluginRecompileToRecompileRequired old_fp new_fp pr + | old_fp == new_fp = + case pr of + NoForceRecompile -> UpToDate + + -- we already checked the fingerprint above so a mismatch is not possible + -- here, remember that: `fingerprint (MaybeRecomp x) == x`. + MaybeRecompile _ -> UpToDate + + -- when we have an impure plugin in the stack we have to unconditionally + -- recompile since it might integrate all sorts of crazy IO results into + -- its compilation output. + ForceRecompile -> needsRecompileBecause ImpurePlugin + + | old_fp `elem` magic_fingerprints || + new_fp `elem` magic_fingerprints + -- The fingerprints do not match either the old or new one is a magic + -- fingerprint. This happens when non-pure plugins are added for the first + -- time or when we go from one recompilation strategy to another: (force -> + -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) + -- + -- For example when we go from ForceRecomp to NoForceRecomp + -- recompilation is triggered since the old impure plugins could have + -- changed the build output which is now back to normal. + = needsRecompileBecause PluginsChanged + + | otherwise = + case pr of + -- even though a plugin is forcing recompilation the fingerprint changed + -- which would cause recompilation anyways so we report the fingerprint + -- change instead. + ForceRecompile -> needsRecompileBecause PluginFingerprintChanged + + _ -> needsRecompileBecause PluginFingerprintChanged + + where + magic_fingerprints = + [ fingerprintString "NoForceRecompile" + , fingerprintString "ForceRecompile" + ] + + +-- | Check if an hsig file needs recompilation because its +-- implementing module has changed. +checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired +checkHsig logger home_unit mod_summary iface = do + let outer_mod = ms_mod mod_summary + inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod) + massert (isHomeModule home_unit outer_mod) + case inner_mod == mi_semantic_module iface of + True -> up_to_date logger (text "implementing module unchanged") + False -> return $ needsRecompileBecause ModuleInstChanged + +-- | Check if @.hie@ file is out of date or missing. +checkHie :: DynFlags -> ModSummary -> RecompileRequired +checkHie dflags mod_summary = + let hie_date_opt = ms_hie_date mod_summary + hi_date = ms_iface_date mod_summary + in if not (gopt Opt_WriteHie dflags) + then UpToDate + else case (hie_date_opt, hi_date) of + (Nothing, _) -> needsRecompileBecause HieMissing + (Just hie_date, Just hi_date) + | hie_date < hi_date + -> needsRecompileBecause HieOutdated + _ -> UpToDate + +-- | Check the flags haven't changed +checkFlagHash :: HscEnv -> Module -> IfaceSelfRecomp -> IO RecompileRequired +checkFlagHash hsc_env iface_mod self_recomp = do + let logger = hsc_logger hsc_env + let FingerprintWithValue old_fp old_flags = mi_sr_flag_hash self_recomp + let (new_fp, new_flags) = fingerprintDynFlags hsc_env iface_mod putNameLiterally + if old_fp == new_fp + then up_to_date logger (text "Module flags unchanged") + else do + -- Do not perform this computation unless -ddump-hi-diffs is on + let diffs = case old_flags of + Nothing -> pure [missingExtraFlagInfo] + Just old_flags -> checkIfaceFlags old_flags new_flags + out_of_date logger FlagsChanged (fmap vcat diffs) + + +checkIfaceFlags :: IfaceDynFlags -> IfaceDynFlags -> IO [SDoc] +checkIfaceFlags (IfaceDynFlags a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) + (IfaceDynFlags b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14) = + flip execStateT [] $ do + check_one "main is" (ppr . fmap (fmap (text @SDoc))) a1 b1 + check_one_simple "safemode" a2 b2 + check_one_simple "lang" a3 b3 + check_one_simple "exts" a4 b4 + check_one_simple "cpp option" a5 b5 + check_one_simple "js option" a6 b6 + check_one_simple "cmm option" a7 b7 + check_one "paths" (ppr . map (text @SDoc)) a8 b8 + check_one_simple "prof" a9 b9 + check_one_simple "ticky" a10 b10 + check_one_simple "codegen" a11 b11 + check_one_simple "fat iface" a12 b12 + check_one_simple "debug level" a13 b13 + check_one_simple "caller cc filter" a14 b14 + where + diffSimple p a b = vcat [text "before:" <+> p a + , text "after:" <+> p b ] + + check_one_simple s a b = check_one s ppr a b + + check_one s p a b = do + let a' = computeFingerprint putNameLiterally a + let b' = computeFingerprint putNameLiterally b + if a' == b' then pure () else modify (([ text s <+> text "flags changed"] ++ [diffSimple p a b]) ++) + +-- | Check the optimisation flags haven't changed +checkOptimHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired +checkOptimHash hsc_env iface = do + let logger = hsc_logger hsc_env + let old_hash = mi_sr_opt_hash iface + let !new_hash = fingerprintOptFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date logger (text "Optimisation flags unchanged") + | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) + -> up_to_date logger (text "Optimisation flags changed; ignoring") + | otherwise + -> out_of_date_hash logger OptimFlagsChanged + (text " Optimisation flags have changed") + old_hash new_hash + +-- | Check the HPC flags haven't changed +checkHpcHash :: HscEnv -> IfaceSelfRecomp -> IO RecompileRequired +checkHpcHash hsc_env self_recomp = do + let logger = hsc_logger hsc_env + let old_hash = mi_sr_hpc_hash self_recomp + let !new_hash = fingerprintHpcFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date logger (text "HPC flags unchanged") + | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) + -> up_to_date logger (text "HPC flags changed; ignoring") + | otherwise + -> out_of_date_hash logger HpcFlagsChanged + (text " HPC flags have changed") + old_hash new_hash + +-- Check that the set of signatures we are merging in match. +-- If the -unit-id flags change, this can change too. +checkMergedSignatures :: HscEnv -> ModSummary -> IfaceSelfRecomp -> IO RecompileRequired +checkMergedSignatures hsc_env mod_summary self_recomp = do + let logger = hsc_logger hsc_env + let unit_state = hsc_units hsc_env + let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_sr_usages self_recomp ] + new_merged = case lookupUniqMap (requirementContext unit_state) + (ms_mod_name mod_summary) of + Nothing -> [] + Just r -> sort $ map (instModuleToModule unit_state) r + if old_merged == new_merged + then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged) + else return $ needsRecompileBecause SigsMergeChanged + +-- If the direct imports of this module are resolved to targets that +-- are not among the dependencies of the previous interface file, +-- then we definitely need to recompile. This catches cases like +-- - an exposed package has been upgraded +-- - we are compiling with different package flags +-- - a home module that was shadowing a package module has been removed +-- - a new home module has been added that shadows a package module +-- See bug #1372. +-- +-- Returns (RecompBecause ) if recompilation is required. +checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired +checkDependencies hsc_env summary iface + = do + res_normal <- classify_import (findImportedModule hsc_env) + ([(st, p, m) | (st, p, m) <- (ms_textual_imps summary)] + ++ + [(NormalLevel, NoPkgQual, m) | m <- ms_srcimps summary ]) + res_plugin <- classify_import (\mod _ -> findPluginModule hsc_env mod) + [(st, p, m) | (st, p, m) <- (ms_plugin_imps summary) ] + case sequence (res_normal ++ res_plugin) of + Left recomp -> return $ NeedsRecompile recomp + Right es -> do + let (hs, ps) = partitionEithers es + liftIO $ + check_mods (sort hs) prev_dep_mods + `recompThen` + let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd ps + in check_packages allPkgDeps prev_dep_pkgs + where + + classify_import :: (ModuleName -> t -> IO FindResult) + -> [(ImportLevel, t, GenLocated l ModuleName)] + -> IfG + [Either + CompileReason (Either (ImportLevel, UnitId, ModuleName) (FastString, (ImportLevel, UnitId)))] + classify_import find_import imports = + liftIO $ traverse (\(st, mb_pkg, L _ mod) -> + let reason = ModuleChanged mod + in classify st reason <$> find_import mod mb_pkg) + imports + logger = hsc_logger hsc_env + all_home_units = hsc_all_home_unit_ids hsc_env + prev_dep_mods = map (\(IfaceImportLevel s,u, a) -> (s, u, gwib_mod a)) $ Set.toAscList $ dep_direct_mods (mi_deps iface) + prev_dep_pkgs = Set.toAscList (Set.union (Set.map (first tcImportLevel) (dep_direct_pkgs (mi_deps iface))) + (Set.map ((SpliceLevel),) (dep_plugin_pkgs (mi_deps iface)))) + + classify st _ (Found _ mod) + | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((st, toUnitId $ moduleUnit mod, moduleName mod))) + | otherwise = Right (Right (moduleNameFS (moduleName mod), (st, toUnitId $ moduleUnit mod))) + classify _ reason _ = Left (RecompBecause reason) + + check_mods :: [(ImportLevel, UnitId, ModuleName)] -> [(ImportLevel, UnitId, ModuleName)] -> IO RecompileRequired + check_mods [] [] = return UpToDate + check_mods [] (old:_) = do + -- This case can happen when a module is change from HPT to package import + trace_hi_diffs logger $ + text "module no longer" <+> quotes (ppr old) <+> + text "in dependencies" + + return $ needsRecompileBecause $ ModuleRemoved old + check_mods (new:news) olds + | Just (old, olds') <- uncons olds + , new == old = check_mods (dropWhile (== new) news) olds' + | otherwise = do + trace_hi_diffs logger $ + text "imported module " <> quotes (ppr new) <> + text " not among previous dependencies" + return $ needsRecompileBecause $ ModuleAdded new + + check_packages :: [(FastString, (ImportLevel, UnitId))] -> [(ImportLevel, UnitId)] -> IO RecompileRequired + check_packages [] [] = return UpToDate + check_packages [] (old:_) = do + trace_hi_diffs logger $ + text "package " <> quotes (ppr old) <> + text "no longer in dependencies" + return $ needsRecompileBecause $ UnitDepRemoved old + check_packages ((new_name, (new_unit)):news) olds + | Just (old, olds') <- uncons olds + , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds' + | otherwise = do + trace_hi_diffs logger $ + text "imported package" <+> ftext new_name <+> ppr new_unit <+> + text "not among previous dependencies" + return $ needsRecompileBecause $ ModulePackageChanged new_name + + +needInterface :: Module -> (ModIface -> IO RecompileRequired) + -> IfG RecompileRequired +needInterface mod continue + = do + mb_recomp <- tryGetModIface + "need version info for" + mod + case mb_recomp of + Nothing -> return $ NeedsRecompile MustCompile + Just iface -> liftIO $ continue iface + +tryGetModIface :: String -> Module -> IfG (Maybe ModIface) +tryGetModIface doc_msg mod + = do -- Load the imported interface if possible + logger <- getLogger + let doc_str = sep [text doc_msg, ppr mod] + liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod <+> ppr (moduleUnit mod)) + + mb_iface <- loadInterface doc_str mod ImportBySystem + -- Load the interface, but don't complain on failure; + -- Instead, get an Either back which we can test + + case mb_iface of + Failed _ -> do + liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod]) + return Nothing + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain: it might + -- just be that the current module doesn't need that + -- import and it's been deleted + Succeeded iface -> pure $ Just iface + +-- | Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. +checkModUsage :: FinderCache -> Usage -> IfG RecompileRequired +checkModUsage _ UsagePackageModule{ + usg_mod = mod, + usg_mod_hash = old_mod_hash } = do + logger <- getLogger + needInterface mod $ \iface -> do + let reason = ModuleChanged (moduleName mod) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) + -- We only track the ABI hash of package modules, rather than + -- individual entity usages, so if the ABI hash changes we must + -- recompile. This is safe but may entail more recompilation when + -- a dependent package has changed. + +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do + logger <- getLogger + needInterface mod $ \iface -> do + let reason = ModuleChangedRaw (moduleName mod) + checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash iface) +checkModUsage _ UsageHomeModuleInterface{ usg_mod_name = mod_name + , usg_unit_id = uid + , usg_iface_hash = old_mod_hash } = do + let mod = mkModule (RealUnit (Definite uid)) mod_name + logger <- getLogger + needInterface mod $ \iface -> do + let reason = ModuleChangedIface mod_name + checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash iface) + +checkModUsage _ UsageHomeModule{ + usg_mod_name = mod_name, + usg_unit_id = uid, + usg_mod_hash = old_mod_hash, + usg_exports = maybe_imported_exports, + usg_entities = old_decl_hash } + = do + let mod = mkModule (RealUnit (Definite uid)) mod_name + logger <- getLogger + needInterface mod $ \iface -> do + let + new_mod_hash = mi_mod_hash iface + new_decl_hash = mi_hash_fn iface + reason = ModuleChanged (moduleName mod) + + liftIO $ do + -- CHECK MODULE + recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) + then return UpToDate + else checkList + [ -- CHECK EXPORT LIST; see Note [When to recompile when export lists change?] + checkHomeModImport logger reason maybe_imported_exports iface + , -- CHECK USED ITEMS ONE BY ONE + checkList [ checkEntityUsage logger reason new_decl_hash u + | u <- old_decl_hash] + , up_to_date logger (text " Great! The bits I use are up to date") + ] + +checkModUsage fc UsageFile{ usg_file_path = file, + usg_file_hash = old_hash, + usg_file_label = mlabel } = + liftIO $ + handleIO handler $ do + new_hash <- lookupFileCache fc $ unpackFS file + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + reason = FileChanged $ unpackFS file + recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel + handler = if debugIsOn + then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp + else \_ -> return recomp -- if we can't find the file, just recompile, don't fail + +-- | We are importing a module whose exports have changed. +-- Does this require recompilation? +-- +-- See Note [When to recompile when export lists change?] +checkHomeModImport :: Logger -> RecompReason -> Maybe HomeModImport -> ModIface -> IO RecompileRequired +checkHomeModImport _ _ Nothing _ = return UpToDate +checkHomeModImport logger reason + (Just (HomeModImport old_orphan_like_hash old_avails)) + iface + -- (1) Orphans (of the module we are importing or of its dependencies) + -- have changed: recompilation is required. + -- + -- See Note [Orphan-like hash]. + | old_orphan_like_hash /= new_orphan_like_hash + = out_of_date_hash logger reason (text " Orphan-likes changed") + old_orphan_like_hash new_orphan_like_hash + | otherwise + -- (2) Is there a change in the set of entities we are importing? + = case old_avails of + -- (a) Whole module import: recompile if the export hash + -- of the module we are importing has changed. + HMIA_Implicit old_avails_hash + | old_avails_hash /= new_avails_hash + -> out_of_date_hash logger reason (text " Export list changed") + old_orphan_like_hash new_orphan_like_hash + | otherwise + -> return UpToDate + -- (b) Explicit imports: recompile if there is a change in the + -- set of imported items. + HMIA_Explicit + { hmia_imported_avails = DetOrdAvails imps + , hmia_parents_with_implicits = parents_of_implicits + } -> + case checkNewExportedAvails new_exports parents_of_implicits imps of + [] -> return UpToDate + changes@(_:_) -> + do trace_hi_diffs logger $ + hang (text "Export list changed") + 2 (ppr changes) + return $ needsRecompileBecause reason + where + new_orphan_like_hash = mi_orphan_like_hash iface + new_avails_hash = mi_export_avails_hash iface + new_exports = mi_exports iface + +-- | The exported avails of a module have changed. Should this cause recompilation +-- of a module that imports it? +-- +-- This is only about export/import lists; checking for changes in the definitions +-- of used identifiers is done later (see 'checkEntityUsage'). +-- +-- See Note [When to recompile when export lists change?]. +checkNewExportedAvails :: [AvailInfo] -> NameSet -> [AvailInfo] -> [AvailInfo] +checkNewExportedAvails new_avails parents_of_implicits imported_avails + = concatMap go imported_avails + where + go a@(Avail n) = + case lookupNameEnv env n of + Nothing -> [a] + Just {} -> [] + go a@(AvailTC n ns) = + case lookupNameEnv env n of + Nothing -> [a] + Just a' -> + case a' of + Avail {} -> [a] + AvailTC _ ns' + | n `elemNameSet` parents_of_implicits + -> + -- We are dealing with an export item of the form @T(..)@. + -- If the set of subordinate names has changed at all, we must + -- recompile. + if mkNameSet ns == mkNameSet ns' + then [] + else [a] + | otherwise + -> + -- We are dealing with an import item of the form @T(K,x,y)@. + -- Just check that all the names we are explicitly importing + -- continue to be exported. It's OK if T has more children + -- than it used to. + if all (`elem` ns') ns + then [] + else [a] + + env = availsToNameEnv new_avails + +{- Note [When to recompile when export lists change?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose module N imports module M, and the exports of M change. Does this +require recompiling N? + +Suppose for example that we have: + + module M (foo) where + foo = 3 + + module N where + import M + bar = foo + 1 + baz = 2 * bar + +If we add an identifier to the export list of M, we must recompile N because +this might introduce name clashes, e.g. changing M to: + + module M (foo, bar) where + foo = 3 + bar = 7 + +will cause N to no longer compile because of a name clash involving 'bar'. + +However, if N had an explicit import list: + + module N where + import M(foo) + bar = foo + 1 + baz = 2 * bar + +then it *does not matter* that 'M' starts exporting 'bar'; 'N' is unaffected. + +This justifies the following approach for deciding whether a change in exports +should lead to recompilation. + + (1) If the orphan instances exported by M change, or if the orphans of + dependencies of M change, we must recompile N. + See Note [Orphan-like hash] + + (2) Otherwise, look at all the import declarations that import M. + + (a) If there is a whole module import, or an "import hiding" import, + then we must recompile N when the avails exported from M change + (such a change is detected by using the 'mi_export_avails_hash'). + + (b) Otherwise, all imports are explicit imports, but not every identifier + is necessarily explicitly imported, as we might have an import of + the form @import M(T(..))@. + + We proceed by comparing what we are importing from M against the + new exports of M. We recompile unless the following two conditions + are both satisfied: + + C1. Every explicitly imported identifier continues to be exported. + C2. For every parent P in an import item of the form @P(..)@, + the set of subordinates exported by P has not changed. + +Note that this import check is done purely on the basis of the Names involved, +unlike the subsequent recompilation check done in 'checkEntityUsage' which +checks that the definitions of used identifiers have not changed. + +Note [Orphan-like hash] +~~~~~~~~~~~~~~~~~~~~~~~ +The orphan-like hash extends the orphan hash to include other entities that +also cause recompilation downstream upon changing. + +The hash includes: + + (1) orphan class and family instances + (2) exported named defaults (these are very similar to orphan instances) + (3) non-orphan type family instances, including those of dependencies + (4) the Safe Haskell safety of the module + +Why do we need to do this? For (3), suppose we have: + + module A where + type instance F Int = Bool + + module B where + import A + + module C where + import B + +The family instance consistency check for C depends on the dep_finsts of +B. If we rename module A to A2, when the dep_finsts of B changes, we need +to make sure that C gets rebuilt. Effectively, the dep_finsts are part of +the exports of B, because C always considers them when checking +consistency. + +A full discussion is in #12723. + +We do NOT need to hash dep_orphs, because this is implied by +dep_orphan_hashes, and we do not need to hash ordinary (non-orphan) class +instances, because there is no eager consistency check as there is with type +families. For this reason, we don't currently store a hash of non-orphan class +instances. +-} + +------------------------ +checkModuleFingerprint + :: Logger + -> RecompReason + -> Fingerprint + -> Fingerprint + -> IO RecompileRequired +checkModuleFingerprint logger reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date logger (text "Module fingerprint unchanged") + + | otherwise + = out_of_date_hash logger reason (text " Module fingerprint has changed") + old_mod_hash new_mod_hash + +checkIfaceFingerprint + :: Logger + -> RecompReason + -> Fingerprint + -> Fingerprint + -> IO RecompileRequired +checkIfaceFingerprint logger reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date logger (text "Iface fingerprint unchanged") + + | otherwise + = out_of_date_hash logger reason (text " Iface fingerprint has changed") + old_mod_hash new_mod_hash + +------------------------ +checkEntityUsage :: Logger + -> RecompReason + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName, Fingerprint) + -> IO RecompileRequired +checkEntityUsage logger reason new_hash (name,old_hash) = do + case new_hash name of + -- We used it before, but it ain't there now + Nothing -> out_of_date logger reason (pure $ sep [text "No longer exported:", ppr name]) + -- It's there, but is it up to date? + Just (_, new_hash) + | new_hash == old_hash + -> do trace_hi_diffs logger (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + return UpToDate + | otherwise + -> out_of_date_hash logger reason (text " Out of date:" <+> ppr name) old_hash new_hash + +up_to_date :: Logger -> SDoc -> IO RecompileRequired +up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate + +out_of_date :: Logger -> RecompReason -> IO SDoc -> IO RecompileRequired +out_of_date logger reason msg = trace_hi_diffs_io logger msg >> return (needsRecompileBecause reason) + +out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired +out_of_date_hash logger reason msg old_hash new_hash + = out_of_date logger reason (pure $ hsep [msg, ppr old_hash, text "->", ppr new_hash]) + +-- --------------------------------------------------------------------------- +-- Compute fingerprints for the interface + +{- Note [Fingerprinting IfaceDecls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The general idea here is that we first examine the 'IfaceDecl's and determine +the recursive groups of them. We then walk these groups in dependency order, +serializing each contained 'IfaceDecl' to a "Binary" buffer which we then +hash using MD5 to produce a fingerprint for the group. + +However, the serialization that we use is a bit funny: we override the @putName@ +operation with our own which serializes the hash of a 'Name' instead of the +'Name' itself. This ensures that the fingerprint of a decl changes if anything +in its transitive closure changes. This trick is why we must be careful about +traversing in dependency order: we need to ensure that we have hashes for +everything referenced by the decl which we are fingerprinting. + +Moreover, we need to be careful to distinguish between serialization of binding +Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls +field of a IfaceClsInst): only in the non-binding case should we include the +fingerprint; in the binding case we shouldn't since it is merely the name of the +thing that we are currently fingerprinting. + + +Note [Fingerprinting recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The fingerprinting of a single recursive group is a rather subtle affair, as +seen in #18733. + +How not to fingerprint +---------------------- + +Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a +group in hash environment `hash_env0`: + + 1. extend hash_env0, giving each declaration in the group the fingerprint 0 + 2. use this environment to hash the declarations' ABIs, resulting in + group_fingerprint + 3. produce the final hash environment by extending hash_env0, mapping each + declaration of the group to group_fingerprint + +However, this is wrong. Consider, for instance, a program like: + + data A = ARecu B | ABase String deriving (Show) + data B = BRecu A | BBase Int deriving (Show) + + info :: B + info = BBase 1 + +A consequence of (3) is that A and B will have the same fingerprint. This means +that if the user changes `info` to: + + info :: A + info = ABase "hello" + +The program's ABI fingerprint will not change despite `info`'s type, and +therefore ABI, being clearly different. + +However, the incorrectness doesn't end there: (1) means that all recursive +occurrences of names within the group will be given the same fingerprint. This +means that the group's fingerprint won't change if we change an occurrence of A +to B. + +Surprisingly, this bug (#18733) lurked for many years before being uncovered. + +How we now fingerprint +---------------------- + +As seen above, the fingerprinting function must ensure that a groups +fingerprint captures the structure of within-group occurrences. The scheme that +we use is: + + 0. To ensure determinism, sort the declarations into a stable order by + declaration name + + 1. Extend hash_env0, giving each declaration in the group a sequential + fingerprint (e.g. 0, 1, 2, ...). + + 2. Use this environment to hash the declarations' ABIs, resulting in + group_fingerprint. + + Since we included the sequence number in step (1) programs identical up to + transposition of recursive occurrences are distinguishable, avoiding the + second issue mentioned above. + + 3. Produce the final environment by extending hash_env, mapping each + declaration of the group to the hash of (group_fingerprint, i), where + i is the position of the declaration in the stable ordering. + + Including i in the hash ensures that the first issue noted above is + avoided. + +-} + +-- | Compute the information needed for self-recompilation checking. This +-- information can be computed before the backend phase. +mkSelfRecomp :: HscEnv -> Module -> Fingerprint -> [Usage] -> IO IfaceSelfRecomp +mkSelfRecomp hsc_env this_mod src_hash usages = do + let dflags = hsc_dflags hsc_env + + let dyn_flags_info = fingerprintDynFlags hsc_env this_mod putNameLiterally + + let opt_hash = fingerprintOptFlags dflags putNameLiterally + + let hpc_hash = fingerprintHpcFlags dflags putNameLiterally + + plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env) + + let include_detailed_flags (flag_hash, flags) = + if gopt Opt_WriteSelfRecompFlags dflags + then FingerprintWithValue flag_hash (Just flags) + else FingerprintWithValue flag_hash Nothing + + return (IfaceSelfRecomp + { mi_sr_flag_hash = include_detailed_flags dyn_flags_info + , mi_sr_hpc_hash = hpc_hash + , mi_sr_opt_hash = opt_hash + , mi_sr_plugin_hash = plugin_hash + , mi_sr_src_hash = src_hash + , mi_sr_usages = usages }) + +-- | Add fingerprints for top-level declarations to a 'ModIface'. +-- +-- See Note [Fingerprinting IfaceDecls] +addFingerprints + :: HscEnv + -> PartialModIface + -> IO ModIface +addFingerprints hsc_env iface0 = do + (abiHashes, caches, decls_w_hashes) <- addAbiHashes hsc_env (mi_mod_info iface0) (mi_public iface0) (mi_deps iface0) + + -- put the declarations in a canonical order, sorted by OccName + let sorted_decls :: [(Fingerprint, IfaceDecl)] + sorted_decls = Map.elems $ Map.fromList $ + [(getOccName d, e) | e@(_, d) <- decls_w_hashes] + + -- This key is safe because mi_extra_decls contains tidied things. + getOcc (IfGblTopBndr b) = getOccName b + getOcc (IfLclTopBndr fs _ _ details) = + case details of + IfRecSelId { ifRecSelFirstCon = first_con } + -> mkRecFieldOccFS (getOccFS first_con) (ifLclNameFS fs) + _ -> mkVarOccFS (ifLclNameFS fs) + + binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) () + binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs) + + sorted_extra_decls :: Maybe IfaceSimplifiedCore + sorted_extra_decls = mi_simplified_core iface0 <&> \simpl_core -> + IfaceSimplifiedCore (sortOn binding_key (mi_sc_extra_decls simpl_core)) (mi_sc_foreign simpl_core) + + -- The interface hash depends on: + -- - the ABI hash, plus + -- - the things which can affect whether a module is recompiled + -- - the module level annotations, + -- - deps (home and external packages, dependent files) + let !iface_hash = computeFingerprint putNameLiterally + (mi_abi_mod_hash abiHashes, + mi_self_recomp_info iface0, + mi_deps iface0) + + let final_iface = completePartialModIface iface0 iface_hash + sorted_decls sorted_extra_decls abiHashes caches + -- + return final_iface + + + +-- The ABI hash should depend on everything in IfacePublic +-- This is however computed in a very convoluted way, so be careful your +-- addition ends up in the right place. In essence all this function does is +-- compute a hash of the arguments. +-- +-- Why the convoluted way? Hashing individual declarations allows us to do fine-grained +-- recompilation checking for home package modules, which record precisely what they use +-- from each module. +addAbiHashes :: HscEnv -> IfaceModInfo -> PartialIfacePublic -> Dependencies -> IO (IfaceAbiHashes, IfaceCache, [(Fingerprint, IfaceDecl)]) +addAbiHashes hsc_env info + iface_public + deps = do + eps <- hscEPS hsc_env + let + -- If you have arrived here by accident then congratulations, + -- you have discovered the ABI hash. Your reward is to update the ABI hash to + -- account for your change to the interface file. Omitting your field using a + -- wildcard may lead to some unfortunate consequences. + IfacePublic + exports fixities warns anns decls + defaults insts fam_insts rules + trust _trust_pkg -- TODO: trust_pkg ignored + complete + _cache + () + = iface_public + -- And these fields of deps should be in IfacePublic, but in good time. + Dependencies _ _ _ sig_mods trusted_pkgs boot_mods orph_mods fis_mods = deps + decl_warn_fn = mkIfaceDeclWarnCache (fromIfaceWarnings warns) + export_warn_fn = mkIfaceExportWarnCache (fromIfaceWarnings $ warns) + fix_fn = mkIfaceFixCache fixities + + this_mod = mi_mod_info_module info + semantic_mod = mi_mod_info_semantic_module info + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph insts + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph rules + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph fam_insts + complete_matches = mkIfaceCompleteMap complete + ann_fn = mkIfaceAnnCache anns + + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. + declABI :: IfaceDecl -> IfaceDeclABI + -- TODO: I'm not sure if this should be semantic_mod or this_mod. + -- See also Note [Identity versus semantic module] + declABI decl = (this_mod, decl, extras) + where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts + non_orph_fis top_lvl_name_env complete_matches decl + + -- This is used for looking up the Name of a default method + -- from its OccName. See Note [default method Name] + top_lvl_name_env = + mkOccEnv [ (nameOccName nm, nm) + | IfaceId { ifName = nm } <- decls ] + + -- Dependency edges between declarations in the current module. + -- This is computed by finding the free external names of each + -- declaration, including IfaceDeclExtras (things that a + -- declaration implicitly depends on). + edges :: [ Node OccName IfaceDeclABI ] + edges = [ DigraphNode abi (getOccName decl) out + | decl <- decls + , let abi = declABI decl + , let out = localOccs $ freeNamesDeclABI abi + ] + + name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n) + localOccs = + map (getParent . getOccName) + -- NB: names always use semantic module, so + -- filtering must be on the semantic module! + -- See Note [Identity versus semantic module] + . filter ((== semantic_mod) . name_module) + . nonDetEltsUniqSet + -- It's OK to use nonDetEltsUFM as localOccs is only + -- used to construct the edges and + -- stronglyConnCompFromEdgedVertices is deterministic + -- even with non-deterministic order of edges as + -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed. + where getParent :: OccName -> OccName + getParent occ = lookupOccEnv parent_map occ `orElse` occ + + -- maps OccNames to their parents in the current module. + -- e.g. a reference to a constructor must be turned into a reference + -- to the TyCon for the purposes of calculating dependencies. + parent_map :: OccEnv OccName + parent_map = foldl' extend emptyOccEnv decls + where extend env d = + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] + where n = getOccName d + + -- Strongly-connected groups of declarations, in dependency order + groups :: [SCC IfaceDeclABI] + groups = stronglyConnCompFromEdgedVerticesOrd edges + + global_hash_fn = mkHashFun hsc_env eps + + -- How to output Names when generating the data to fingerprint. + -- Here we want to output the fingerprint for each top-level + -- Name, whether it comes from the current module or another + -- module. In this way, the fingerprint for a declaration will + -- change if the fingerprint for anything it refers to (transitively) + -- changes. + mk_put_name :: OccEnv (OccName,Fingerprint) + -> WriteBinHandle -> Name -> IO () + mk_put_name local_env bh name + | isWiredInName name = putNameLiterally bh name + -- wired-in names don't have fingerprints + | otherwise + = assertPpr (isExternalName name) (ppr name) $ + let hash | nameModule name /= semantic_mod = global_hash_fn name + -- Get it from the REAL interface!! + -- This will trigger when we compile an hsig file + -- and we know a backing impl for it. + -- See Note [Identity versus semantic module] + | semantic_mod /= this_mod + , not (isHoleModule semantic_mod) = global_hash_fn name + | otherwise = return (snd (lookupOccEnv local_env (getOccName name) + `orElse` pprPanic "urk! lookup local fingerprint" + (ppr name $$ ppr local_env))) + -- This panic indicates that we got the dependency + -- analysis wrong, because we needed a fingerprint for + -- an entity that wasn't in the environment. To debug + -- it, turn the panic into a trace, uncomment the + -- pprTraces below, run the compile again, and inspect + -- the output and the generated .hi file with + -- --show-iface. + in hash >>= put_ bh + + -- take a strongly-connected group of declarations and compute + -- its fingerprint. + + fingerprint_group :: (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + -> SCC IfaceDeclABI + -> IO (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + + fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) + = do let hash_fn = mk_put_name local_env + decl = abiDecl abi + --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do + let !hash = computeFingerprint hash_fn abi + env' <- extend_hash_env local_env (hash,decl) + return (env', (hash,decl) : decls_w_hashes) + + fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) + = do let stable_abis = sortBy cmp_abiNames abis + stable_decls = map abiDecl stable_abis + local_env1 <- foldM extend_hash_env local_env + (zip (map mkRecFingerprint [0..]) stable_decls) + -- See Note [Fingerprinting recursive groups] + let hash_fn = mk_put_name local_env1 + -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do + -- put the cycle in a canonical order + let !hash = computeFingerprint hash_fn stable_abis + let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls + -- See Note [Fingerprinting recursive groups] + local_env2 <- foldM extend_hash_env local_env pairs + return (local_env2, pairs ++ decls_w_hashes) + + -- Make a fingerprint from the ordinal position of a binding in its group. + mkRecFingerprint :: Word64 -> Fingerprint + mkRecFingerprint i = Fingerprint 0 i + + bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint + bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ] + + -- we have fingerprinted the whole declaration, but we now need + -- to assign fingerprints to all the OccNames that it binds, to + -- use when referencing those OccNames in later declarations. + -- + extend_hash_env :: OccEnv (OccName,Fingerprint) + -> (Fingerprint,IfaceDecl) + -> IO (OccEnv (OccName,Fingerprint)) + extend_hash_env env0 (hash,d) = + return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 + (ifaceDeclFingerprints hash d)) + + -- + (local_env, decls_w_hashes) <- + foldM fingerprint_group (emptyOccEnv, []) groups + + -- The export hash of a module depends on the orphan hashes of the + -- orphan modules below us in the dependency tree. This is the way + -- that changes in orphans get propagated all the way up the + -- dependency tree. + -- + -- NB: do not filter out non-home-package modules! + -- See Note [Take into account non-home package orphan modules]. + let orph_mods_no_self + = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] + $ orph_mods + dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods_no_self + + let !orphan_hash = computeFingerprint (mk_put_name local_env) + (map ifDFun orph_insts, orph_rules, orph_fis) + + -- Hash of the transitive things in dependencies + let !dep_hash = computeFingerprint putNameLiterally + ( sig_mods, boot_mods + , trusted_pkgs -- Trusted packages are like orphans + , fis_mods -- See Note [Orphan-like hash] + ) + + -- The export list hash doesn't depend on the fingerprints of + -- the Names it mentions, only the Names themselves, hence putNameLiterally. + -- + -- As per Note [When to recompile when export lists change?], there are two + -- separate considerations: + -- + -- (1) If there is a change in exported orphan instances, we must recompile. + -- + -- In fact, we must include slightly more items here than only the orphan + -- instances defined in the current module; see Note [Orphan-like hash]. + -- + -- (2) If there is a change in the exported avails, this may or may not + -- require recompilation downstream, depending on what is imported. + -- In the case that the downstream module has a whole module import, + -- then we recompile when any exports change, by looking at export_hash. + let + -- (1) Orphan-like information, see Note [Orphan-like hash]. + !orphan_like_hash = + computeFingerprint putNameLiterally + ( orphan_hash, dep_hash, dep_orphan_hashes + , defaults -- Changes in exported named defaults cause recompilation + , trust -- Change of Safe Haskell mode causes recompilation + ) + -- (2) Exported avails + !exported_avails_hash = computeFingerprint putNameLiterally exports + + -- the ABI hash depends on: + -- - decls + -- - export list + -- - orphans + -- - deprecations + -- - flag abi hash + let !mod_hash = computeFingerprint putNameLiterally + (sort (map fst decls_w_hashes), + exported_avails_hash, + orphan_like_hash, -- includes orphan_hash + ann_fn AnnModule, + warns) + + -- Surely the ABI depends on "module" annotations? + -- Also named defaults + + + + let + final_iface_exts = IfaceAbiHashes + { mi_abi_mod_hash = mod_hash + , mi_abi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_abi_finsts = not (null fam_insts) + , mi_abi_export_avails_hash = exported_avails_hash + , mi_abi_orphan_like_hash = orphan_like_hash + , mi_abi_orphan_hash = orphan_hash + } + + caches = IfaceCache + { mi_cache_decl_warn_fn = decl_warn_fn + , mi_cache_export_warn_fn = export_warn_fn + , mi_cache_fix_fn = fix_fn + , mi_cache_hash_fn = lookupOccEnv local_env + } + return (final_iface_exts, caches, decls_w_hashes) + where + +{- Note [Take into account non-home package orphan modules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to take into account all orphan modules, not just those that are from +the home package. + +Historically, we filtered out orphan modules which were not from the home +package, justifying it by saying that "we'd pick up the ABI hashes of the +external module instead". This is wrong. + +Suppose that we have: + + module External where + instance Show (a -> b) + + module Home1 where + import External + + module Home2 where + import Home1 + +The export hash of Home1 needs to reflect the orphan instances of +External. It's true that Home1 will get rebuilt if the orphans +of External, but we also need to make sure Home2 gets rebuilt +as well. See #12733 for more details. + +Note [Do not update EPS with your own hi-boot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When your hs-boot file includes an orphan instance declaration, you may find +that the dep_orphs of a module you import contains reference to yourself. +DO NOT actually load this module or add it to the orphan hashes: you're going +to provide the orphan instances yourself, no need to consult hs-boot; if you do +load the interface into EPS, you will see a duplicate orphan instance. + +See also #10182. +-} + +-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules +-- (in particular, the orphan modules which are transitively imported by the +-- current module). +-- +-- Q: Why do we need the hash at all, doesn't the list of transitively +-- imported orphan modules suffice? +-- +-- A: If one of our transitive imports adds a new orphan instance, our +-- export hash must change so that modules which import us rebuild. If we just +-- hashed the [Module], the hash would not change even when a new instance was +-- added to a module that already had an orphan instance. +-- +-- Q: Why don't we just hash the orphan hashes of our direct dependencies? +-- Why the full transitive closure? +-- +-- A: Suppose we have these modules: +-- +-- module A where +-- instance Show (a -> b) where +-- module B where +-- import A -- ** +-- module C where +-- import A +-- import B +-- +-- Whether or not we add or remove the import to A in B affects the +-- orphan hash of B. But it shouldn't really affect the orphan hash +-- of C. If we hashed only direct dependencies, there would be no +-- way to tell that the net effect was a wash, and we'd be forced +-- to recompile C and everything else. +getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] +getOrphanHashes hsc_env mods = do + let + dflags = hsc_dflags hsc_env + ctx = initSDocContext dflags defaultUserStyle + get_orph_hash mod = do + iface <- initIfaceLoad hsc_env . withIfaceErr ctx + $ loadInterface (text "getOrphanHashes") mod ImportBySystem + return (mi_orphan_hash iface) + + mapM get_orph_hash mods + + +{- +************************************************************************ +* * + The ABI of an IfaceDecl +* * +************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as an unfolding in the interface. + + (c) the fixity of the identifier (if it exists) + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the declaration. +-} + +type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) + +data IfaceDeclExtras + = IfaceIdExtras IfaceIdExtras + + | IfaceDataExtras + (Maybe Fixity) -- Fixity of the tycon itself (if it exists) + [IfaceInstABI] -- Local class and family instances of this tycon + -- See Note [Orphans] in GHC.Core.InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations + + | IfaceClassExtras + (Maybe Fixity) -- Fixity of the class itself (if it exists) + [IfaceInstABI] -- Local instances of this class *or* + -- of its associated data types + -- See Note [Orphans] in GHC.Core.InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each class method: fixity, RULES and annotations + [IfExtName] -- Default methods. If a module + -- mentions a class, then it can + -- instantiate the class and thereby + -- use the default methods, so we must + -- include these in the fingerprint of + -- a class. + + | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] + + | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] + + | IfacePatSynExtras (Maybe Fixity) [IfaceCompleteMatchABI] -- ^ COMPLETE pragmas that this PatSyn appears in + + | IfaceOtherDeclExtras + +data IfaceIdExtras + = IdExtras + (Maybe Fixity) -- Fixity of the Id (if it exists) + [IfaceRule] -- Rules for the Id + [AnnPayload] -- Annotations for the Id + [IfaceCompleteMatchABI] -- See Note [Fingerprinting complete matches] for why this is in IdExtras + +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + +-- See Note [Fingerprinting complete matches] +type IfaceCompleteMatchABI = (Fingerprint, Maybe IfExtName) + +abiDecl :: IfaceDeclABI -> IfaceDecl +abiDecl (_, decl, _) = decl + +cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering +cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` + getOccName (abiDecl abi2) + +freeNamesDeclABI :: IfaceDeclABI -> NameSet +freeNamesDeclABI (_mod, decl, extras) = + freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras + +freeNamesDeclExtras :: IfaceDeclExtras -> NameSet +freeNamesDeclExtras (IfaceIdExtras id_extras) + = freeNamesIdExtras id_extras +freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) + = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) +freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms) + = unionNameSets $ + mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs +freeNamesDeclExtras (IfaceSynonymExtras _ _) + = emptyNameSet +freeNamesDeclExtras (IfaceFamilyExtras _ insts _) + = mkNameSet insts +freeNamesDeclExtras (IfacePatSynExtras _ complete) + = unionNameSets (map freeNamesIfaceCompleteABI complete) +freeNamesDeclExtras IfaceOtherDeclExtras + = emptyNameSet + +freeNamesIdExtras :: IfaceIdExtras -> NameSet +freeNamesIdExtras (IdExtras _ rules _ complete) = + unionNameSets (map freeNamesIfRule rules ++ map freeNamesIfaceCompleteABI complete) + +-- | Extract free names from a COMPLETE pragma ABI +freeNamesIfaceCompleteABI :: IfaceCompleteMatchABI -> NameSet +freeNamesIfaceCompleteABI (_, mb_ty) = case mb_ty of + Nothing -> emptyNameSet + Just ty -> unitNameSet ty + + +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = Outputable.empty + ppr (IfaceIdExtras extras) = ppr_id_extras extras + ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] + ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] + ppr (IfaceDataExtras fix insts anns stuff) + = vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts anns stuff defms) = + vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff, ppr defms] + ppr (IfacePatSynExtras fix complete) = vcat [ppr fix, ppr complete] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = text "" + +ppr_id_extras_s :: [IfaceIdExtras] -> SDoc +ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) + +ppr_id_extras :: IfaceIdExtras -> SDoc +ppr_id_extras (IdExtras fix rules anns complete) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) $$ vcat (map ppr complete) + +-- This instance is used only to compute fingerprints +instance Binary IfaceDeclExtras where + get _bh = panic "no get for IfaceDeclExtras" + put_ bh (IfaceIdExtras extras) = do + putByte bh 1; put_ bh extras + put_ bh (IfaceDataExtras fix insts anns cons) = do + putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons + put_ bh (IfaceClassExtras fix insts anns methods defms) = do + putByte bh 3 + put_ bh fix + put_ bh insts + put_ bh anns + put_ bh methods + put_ bh defms + put_ bh (IfaceSynonymExtras fix anns) = do + putByte bh 4; put_ bh fix; put_ bh anns + put_ bh (IfaceFamilyExtras fix finsts anns) = do + putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns + put_ bh (IfacePatSynExtras fix complete) = do + putByte bh 6; put_ bh fix; put_ bh complete + put_ bh IfaceOtherDeclExtras = putByte bh 7 + +instance Binary IfaceIdExtras where + get _bh = panic "no get for IfaceIdExtras" + put_ bh (IdExtras fix rules anns complete) = do { put_ bh fix; put_ bh rules; put_ bh anns; put_ bh complete } + +declExtras :: (OccName -> Maybe Fixity) + -> (AnnCacheKey -> [AnnPayload]) + -> OccEnv [IfaceRule] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] + -> OccEnv IfExtName -- lookup default method names + -> OccEnv [IfaceCompleteMatchABI] -- lookup complete matches + -> IfaceDecl + -> IfaceDeclExtras + +declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env complete_env decl + = case decl of + IfaceId{} -> IfaceIdExtras (id_extras n) + IfaceData{ifCons=cons} -> + IfaceDataExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) + (ann_fn (AnnOccName n)) + (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) + IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> + IfaceClassExtras (fix_fn n) insts (ann_fn (AnnOccName n)) meths defms + where + insts = (map ifDFun $ (concatMap at_extras ats) + ++ lookupOccEnvL inst_env n) + -- Include instances of the associated types + -- as well as instances of the class (#5147) + meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] + -- Names of all the default methods (see Note [default method Name]) + defms = [ dmName + | IfaceClassOp bndr _ (Just _) <- sigs + , let dmOcc = mkDefaultMethodOcc (nameOccName bndr) + , Just dmName <- [lookupOccEnv dm_env dmOcc] ] + IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) + (ann_fn (AnnOccName n)) + IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) + (ann_fn (AnnOccName n)) + IfacePatSyn{} -> IfacePatSynExtras (fix_fn n) (lookup_complete_match n) + _other -> IfaceOtherDeclExtras + where + n = getOccName decl + id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn (AnnOccName occ)) (lookup_complete_match occ) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) + + lookup_complete_match occ = lookupOccEnvL complete_env occ + +{- Note [default method Name] (see also #15970) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Names for the default methods aren't available in Iface syntax. + +* We originally start with a DefMethInfo from the class, contain a + Name for the default method + +* We turn that into Iface syntax as a DefMethSpec which lacks a Name + entirely. Why? Because the Name can be derived from the method name + (in GHC.IfaceToCore), so doesn't need to be serialised into the interface + file. + +But now we have to get the Name back, because the class declaration's +fingerprint needs to depend on it (this was the bug in #15970). This +is done in a slightly convoluted way: + +* Then, in addFingerprints we build a map that maps OccNames to Names + +* We pass that map to declExtras which laboriously looks up in the map + (using the derived occurrence name) to recover the Name we have just + thrown away. +-} + +lookupOccEnvL :: OccEnv [v] -> OccName -> [v] +lookupOccEnvL env k = lookupOccEnv env k `orElse` [] + +{- +-- for testing: use the md5sum command to generate fingerprints and +-- compare the results against our built-in version. + fp' <- oldMD5 dflags bh + if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') + else return fp + +oldMD5 dflags bh = do + tmp <- newTempName dflags CurrentModule "bin" + writeBinMem bh tmp + tmp2 <- newTempName dflags CurrentModule "md5" + let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 + r <- system cmd + case r of + ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) + ExitSuccess -> do + hash_str <- readFile tmp2 + return $! readHexFingerprint hash_str +-} + +---------------------- +-- mkOrphMap partitions instance decls or rules into +-- (a) an OccEnv for ones that are not orphans, +-- mapping the local OccName to a list of its decls +-- (b) a list of orphan decls +mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order +mkOrphMap get_key decls + = foldl' go (emptyOccEnv, []) decls + where + go (non_orphs, orphs) d + | NotOrphan occ <- get_key d + = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs) + | otherwise = (non_orphs, d:orphs) + +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names + +-- This is like a global version of the mi_hash_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get +-- the parent and version info. + +mkHashFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> IO Fingerprint) +mkHashFun hsc_env eps name + | isHoleModule orig_mod + = lookup (mkHomeModule home_unit (moduleName orig_mod)) + | otherwise + = lookup orig_mod + where + home_unit = hsc_home_unit hsc_env + dflags = hsc_dflags hsc_env + hpt = hsc_HUG hsc_env + pit = eps_PIT eps + ctx = initSDocContext dflags defaultUserStyle + occ = nameOccName name + orig_mod = nameModule name + lookup mod = do + massertPpr (isExternalName name) (ppr name) + iface <- lookupIfaceByModule hpt pit mod >>= \case + Just iface -> return iface + Nothing -> + -- This can occur when we're writing out ifaces for + -- requirements; we didn't do any /real/ typechecking + -- so there's no guarantee everything is loaded. + -- Kind of a heinous hack. + initIfaceLoad hsc_env . withIfaceErr ctx + $ withoutDynamicNow + -- If you try and load interfaces when dynamic-too + -- enabled then it attempts to load the dyn_hi and hi + -- interface files. Backpack doesn't really care about + -- dynamic object files as it isn't doing any code + -- generation so -dynamic-too is turned off. + -- Some tests fail without doing this (such as T16219), + -- but they fail because dyn_hi files are not found for + -- one of the dependencies (because they are deliberately turned off) + -- Why is this check turned off here? That is unclear but + -- just one of the many horrible hacks in the backpack + -- implementation. + $ loadInterface (text "lookupVers2") mod ImportBySystem + return $ snd (mi_hash_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + +{- Note [Fingerprinting complete matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The presence or absence of COMPLETE pragmas influences the programs we generate, +and not just error messages, because pattern fallibility information feeds into +the desugaring of do notation (e.g. whether to use 'fail' from 'MonadFail'). + +As far as recompilation checking is concerned, there are two questions we need +to answer: + + Usage: When is a COMPLETE pragma used? + Fingerprinting: What is the Fingerprint of a COMPLETE pragma, i.e. when + do we consider a COMPLETE pragma to have changed? + +Usage + + There isn't a straightforward way to compute which COMPLETE pragmas are + "used" during pattern-match checking. So we have to come up with a conservative + approximation. + + The most conservative option is to consider a COMPLETE pragma to always be + used, much like we treat orphan class instances today. This means that any + change at all would require recompilation. + + A slightly finer grained option, which is what is currently implemented, is to + consider a COMPLETE pragma to be used only when the importing module actually + mentions at least one of the constructors in the COMPLETE pragma. + + Tested in: RecompCompletePragma + +Fingerprinting + + Most conservatively, the fingerprint of a COMPLETE pragma would be the hash of + all the constructors it mentions (together with the hash of the result TyCon, + if any). + + However, for the purposes of the pattern-match checker, we only really care + about the Names of the constructors in a COMPLETE pragma; it doesn't matter + what the definitions of the constructors are. The above criterion would + pessimistically lead to recompilation in the following scenario: + + module M where + pattern MyJust :: a -> Maybe a + pattern MyJust a = Just a + pattern MyNothing :: Maybe a + pattern MyNothing = Nothing + {-# COMPLETE MyJust, MyNothing #-} + + module N where + import M + f :: Maybe Int -> Int + f (MyJust x) = x; f _ = 0 + + In this example, if we change the definition of the 'MyNothing' pattern, then + we will recompile 'M', because 'N' uses the 'MyJust' constructor, 'MyJust' + appears in the imported {-# COMPLETE MyJust, MyNothing #-} pragma, and + 'MyNothing' has changed. + + However, this is needless: the RHS of the pattern synonym declaration for + 'MyNothing' is completely irrelevant to 'N'. So, to avoid this extraneous + recompilation, we implement the following finer-grained criterion: the + Fingerprint of a COMPLETE pragma is the hash of the 'Name's of the mentioned + constructors (hashed together with the Fingerprint of the result TyCon, if any). + + Tested in: RecompCompleteIndependence. +-} + +-- | Make a map from OccNames of pattern synonyms or data constructors to a list +-- of COMPLETE pragmas relevant for that OccName. +-- See Note [Fingerprinting complete matches] +mkIfaceCompleteMap :: [IfaceCompleteMatch] -> OccEnv [IfaceCompleteMatchABI] +mkIfaceCompleteMap complete = + mkOccEnv_C (++) $ + concatMap (\m@(IfaceCompleteMatch syns _) -> + let complete_abi = mkIfaceCompleteMatchABI m + in [(getOccName syn, [complete_abi]) | syn <- syns] + ) complete + where + mkIfaceCompleteMatchABI (IfaceCompleteMatch syns ty) = + (computeFingerprint putNameLiterally syns, ty) + +data AnnCacheKey = AnnModule | AnnOccName OccName + +-- | Creates cached lookup for the 'mi_anns' field of ModIface +mkIfaceAnnCache :: [IfaceAnnotation] -> AnnCacheKey -> [AnnPayload] +mkIfaceAnnCache anns + = \n -> case n of + AnnModule -> module_anns + AnnOccName occn -> lookupOccEnv env occn `orElse` [] + where + (module_anns, occ_anns) = partitionEithers $ map classify anns + classify (IfaceAnnotation target value) = + case target of + NamedTarget occn -> Right (occn, [value]) + ModuleTarget _ -> Left value + + -- flipping (++), so the first argument is always short + env = mkOccEnv_C (flip (++)) occ_anns diff --git a/GHC/Iface/Recomp/Binary.hs b/GHC/Iface/Recomp/Binary.hs --- a/GHC/Iface/Recomp/Binary.hs +++ b/GHC/Iface/Recomp/Binary.hs @@ -14,8 +14,10 @@ import GHC.Utils.Binary import GHC.Types.Name import GHC.Utils.Panic.Plain +import GHC.Iface.Type (putIfaceType) +import System.IO.Unsafe (unsafePerformIO) -fingerprintBinMem :: BinHandle -> IO Fingerprint +fingerprintBinMem :: WriteBinHandle -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f where f bs = @@ -26,20 +28,24 @@ in fp `seq` return fp computeFingerprint :: (Binary a) - => (BinHandle -> Name -> IO ()) + => (WriteBinHandle -> Name -> IO ()) -> a - -> IO Fingerprint -computeFingerprint put_nonbinding_name a = do + -> Fingerprint +computeFingerprint put_nonbinding_name a = unsafePerformIO $ do bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block put_ bh a fingerprintBinMem bh where - set_user_data bh = - setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS + set_user_data bh = setWriterUserData bh $ mkWriterUserData + [ mkSomeBinaryWriter $ mkWriter putIfaceType + , mkSomeBinaryWriter $ mkWriter put_nonbinding_name + , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally + , mkSomeBinaryWriter $ mkWriter putFS + ] -- | Used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to. -putNameLiterally :: BinHandle -> Name -> IO () +putNameLiterally :: WriteBinHandle -> Name -> IO () putNameLiterally bh name = assert (isExternalName name) $ do put_ bh $! nameModule name put_ bh $! nameOccName name diff --git a/GHC/Iface/Recomp/Flags.hs b/GHC/Iface/Recomp/Flags.hs --- a/GHC/Iface/Recomp/Flags.hs +++ b/GHC/Iface/Recomp/Flags.hs @@ -19,11 +19,14 @@ import GHC.Types.SafeHaskell import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary -import GHC.Core.Opt.CallerCC () -- for Binary instances +import GHC.Iface.Flags import GHC.Data.EnumSet as EnumSet import System.FilePath (normalise) +import Data.Maybe +-- The subset of DynFlags which is used by the recompilation checker. + -- | Produce a fingerprint of a @DynFlags@ value. We only base -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. @@ -31,8 +34,8 @@ -- 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 ()) - -> IO Fingerprint + -> (WriteBinHandle -> Name -> IO ()) + -> (Fingerprint, IfaceDynFlags) fingerprintDynFlags hsc_env this_mod nameio = let dflags@DynFlags{..} = hsc_dflags hsc_env @@ -43,40 +46,59 @@ -- oflags = sort $ filter filterOFlags $ flags dflags -- all the extension flags and the language - lang = (fmap fromEnum language, - map fromEnum $ EnumSet.toList extensionFlags) + lang = fmap IfaceLanguage language + exts = map IfaceExtension $ EnumSet.toList extensionFlags -- avoid fingerprinting the absolute path to the directory of the source file -- see Note [Implicit include paths] includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] } - -- -I, -D and -U flags affect CPP - cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit + -- -I, -D and -U flags affect Haskell C/CPP Preprocessor + cpp = IfaceCppOptions + { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , ifaceCppOpts = picPOpts dflags + , ifaceCppSig = opt_P_signature dflags + } + -- See Note [Repeated -optP hashing] + + + -- -I, -D and -U flags affect JavaScript C/CPP Preprocessor + js = IfaceCppOptions + { ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit -- normalise: eliminate spurious differences due to "./foo" vs "foo" - , picPOpts dflags - , opt_P_signature dflags) + , ifaceCppOpts = picPOpts dflags + , ifaceCppSig = opt_JSP_signature dflags + } -- See Note [Repeated -optP hashing] + -- -I, -D and -U flags affect C-- CPP Preprocessor + cmm = IfaceCppOptions { + ifaceCppIncludes = map normalise $ flattenIncludes includePathsMinusImplicit + -- normalise: eliminate spurious differences due to "./foo" vs "foo" + , ifaceCppOpts = picPOpts dflags + , ifaceCppSig = ([], opt_CmmP_signature dflags) + } + -- Note [path flags and recompilation] paths = [ hcSuf ] -- -fprof-auto etc. - prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0 + prof = if sccProfilingEnabled dflags then Just (IfaceProfAuto profAuto) else Nothing -- Ticky ticky = - map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] + mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag] -- Other flags which affect code generation - codegen = map (`gopt` dflags) (EnumSet.toList codeGenFlags) + codegen = mapMaybe (\f -> (if f `gopt` dflags then Just (IfaceGeneralFlag f) else Nothing)) (EnumSet.toList codeGenFlags) -- Did we include core for all bindings? fat_iface = gopt Opt_WriteIfSimplifiedCore dflags - flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, codegen, debugLevel, callerCcFilters, fat_iface)) + f = IfaceDynFlags mainis safeHs lang exts cpp js cmm paths prof ticky codegen fat_iface debugLevel callerCcFilters - in -- pprTrace "flags" (ppr flags) $ - computeFingerprint nameio flags + in (computeFingerprint nameio f, f) -- Fingerprint the optimisation info. We keep this separate from the rest of -- the flags because GHCi users (especially) may wish to ignore changes in @@ -84,8 +106,8 @@ -- object files as they can. -- See Note [Ignoring some flag changes] fingerprintOptFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint + -> (WriteBinHandle -> Name -> IO ()) + -> Fingerprint fingerprintOptFlags DynFlags{..} nameio = let -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 @@ -102,8 +124,8 @@ -- file compiled for HPC when not actually using HPC. -- See Note [Ignoring some flag changes] fingerprintHpcFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint + -> (WriteBinHandle -> Name -> IO ()) + -> Fingerprint fingerprintHpcFlags dflags@DynFlags{..} nameio = let -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 diff --git a/GHC/Iface/Recomp/Types.hs b/GHC/Iface/Recomp/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Recomp/Types.hs @@ -0,0 +1,156 @@ +module GHC.Iface.Recomp.Types ( + IfaceSelfRecomp(..), + IfaceDynFlags(..), + pprIfaceDynFlags, + missingExtraFlagInfo, +) where + +import GHC.Prelude +import GHC.Fingerprint +import GHC.Utils.Outputable +import GHC.Iface.Flags +import GHC.Types.SafeHaskell +import GHC.Unit.Module.Deps +import GHC.Unit.Module + +import GHC.Utils.Binary + +import Control.DeepSeq + +{- +Note [Self recompilation information in interface files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag -fwrite-if-self-recomp controls whether +interface files contain the information necessary to answer the +question: + + Is the interface file up-to-date, relative to: + * the source file it corresponds to, + * the flags passed to the GHC invocation to compile it, + * its dependencies (e.g. imported items, watched files added by addDependentFile, ...) + +If there is no self-recompilation information stored, then we always re-generate +the interface file from scratch. + +Why? Most packages are only built once either by a distribution or cabal +and then placed into an immutable store, after which we will never ask +this question. Therefore we can derive two benefits from omitting this +information. + +* Primary motivation: It vastly reduces the surface area for creating + non-deterministic interface files. See issue #10424 which motivated a + proper fix to that issue. Distributions have long contained versions + of GHC which just have broken self-recompilation checking (in order to + get deterministic interface files). + +* Secondary motivation: This reduces the size of interface files + slightly.. the `mi_usages` field can be quite big but probably this + isn't such a great benefit. + +* Third motivation: Conceptually clarity about which parts of an + interface file are used in order to **communicate** with subsequent + packages about the **interface** for a module. And which parts are + used to self-communicate during recompilation checking. + +The main tracking issue is #22188 but fixes issues such as #10424 in a +proper way. + +-} + +-- | The information for a module which is only used when deciding whether to recompile +-- itself. +-- +-- See Note [Self recompilation information in interface files] +data IfaceSelfRecomp = + IfaceSelfRecomp { mi_sr_src_hash :: !Fingerprint + -- ^ Hash of the .hs source, used for recompilation checking. + , mi_sr_usages :: [Usage] + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + , mi_sr_flag_hash :: !(FingerprintWithValue IfaceDynFlags) + -- ^ Hash of the important flags used when compiling the module, excluding + -- optimisation flags + , mi_sr_opt_hash :: !Fingerprint + -- ^ Hash of optimisation flags + , mi_sr_hpc_hash :: !Fingerprint + -- ^ Hash of hpc flags + , mi_sr_plugin_hash :: !Fingerprint + -- ^ Hash of plugins + } + + +instance Binary IfaceSelfRecomp where + put_ bh (IfaceSelfRecomp{mi_sr_src_hash, mi_sr_usages, mi_sr_flag_hash, mi_sr_opt_hash, mi_sr_hpc_hash, mi_sr_plugin_hash}) = do + put_ bh mi_sr_src_hash + lazyPut bh mi_sr_usages + put_ bh mi_sr_flag_hash + put_ bh mi_sr_opt_hash + put_ bh mi_sr_hpc_hash + put_ bh mi_sr_plugin_hash + + get bh = do + src_hash <- get bh + usages <- lazyGet bh + flag_hash <- get bh + opt_hash <- get bh + hpc_hash <- get bh + plugin_hash <- get bh + return $ IfaceSelfRecomp { mi_sr_src_hash = src_hash, mi_sr_usages = usages, mi_sr_flag_hash = flag_hash, mi_sr_opt_hash = opt_hash, mi_sr_hpc_hash = hpc_hash, mi_sr_plugin_hash = plugin_hash } + +instance Outputable IfaceSelfRecomp where + ppr (IfaceSelfRecomp{mi_sr_src_hash, mi_sr_usages, mi_sr_flag_hash, mi_sr_opt_hash, mi_sr_hpc_hash, mi_sr_plugin_hash}) + = vcat [text "Self-Recomp" + , nest 2 (vcat [ text "src hash:" <+> ppr mi_sr_src_hash + , text "flags:" <+> pprFingerprintWithValue missingExtraFlagInfo (fmap pprIfaceDynFlags mi_sr_flag_hash) + , text "opt hash:" <+> ppr mi_sr_opt_hash + , text "hpc hash:" <+> ppr mi_sr_hpc_hash + , text "plugin hash:" <+> ppr mi_sr_plugin_hash + , text "usages:" <+> ppr (map pprUsage mi_sr_usages) + ])] + +instance NFData IfaceSelfRecomp where + rnf (IfaceSelfRecomp src_hash usages flag_hash opt_hash hpc_hash plugin_hash) + = rnf src_hash `seq` rnf usages `seq` rnf flag_hash `seq` rnf opt_hash `seq` rnf hpc_hash `seq` rnf plugin_hash `seq` () + +pprFingerprintWithValue :: SDoc -> FingerprintWithValue SDoc -> SDoc +pprFingerprintWithValue missingInfo (FingerprintWithValue fp mflags) + = vcat $ + [ text "fingerprint:" <+> (ppr fp) + ] + ++ case mflags of + Nothing -> [missingInfo] + Just doc -> [doc] + +pprUsage :: Usage -> SDoc +pprUsage UsagePackageModule{ usg_mod = mod, usg_mod_hash = hash, usg_safe = safe } + = pprUsageImport mod hash safe +pprUsage UsageHomeModule{ usg_unit_id = unit_id, usg_mod_name = mod_name + , usg_mod_hash = hash, usg_safe = safe + , usg_exports = exports, usg_entities = entities } + = pprUsageImport (mkModule unit_id mod_name) hash safe $$ + nest 2 ( + maybe empty (\v -> text "exports: " <> ppr v) exports $$ + vcat [ ppr n <+> ppr v | (n,v) <- entities ] + ) +pprUsage usage@UsageFile{} + = hsep [text "addDependentFile", + doubleQuotes (ftext (usg_file_path usage)), + ppr (usg_file_hash usage)] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] +pprUsage usage@UsageHomeModuleInterface{} + = hsep [text "implementation", ppr (usg_mod_name usage) + , ppr (usg_unit_id usage) + , ppr (usg_iface_hash usage)] + +pprUsageImport :: Outputable mod => mod -> Fingerprint -> IsSafeImport -> SDoc +pprUsageImport mod hash safe + = hsep [ text "import", pp_safe, ppr mod + , ppr hash ] + where + pp_safe | safe = text "safe" + | otherwise = text " -/ " diff --git a/GHC/Iface/Rename.hs b/GHC/Iface/Rename.hs --- a/GHC/Iface/Rename.hs +++ b/GHC/Iface/Rename.hs @@ -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 @@ -106,15 +107,18 @@ insts <- mapM rnIfaceClsInst (mi_insts iface) fams <- mapM rnIfaceFamInst (mi_fam_insts iface) deps <- rnDependencies (mi_deps iface) + defaults <- mapM rnIfaceDefault (mi_defaults 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 + & set_mi_defaults defaults -- | Rename just the exports of a 'ModIface'. Useful when we're doing -- shaping prior to signature merging. @@ -403,6 +407,14 @@ , ifDFun = dfun } +rnIfaceDefault :: Rename IfaceDefault +rnIfaceDefault cls_inst = do + n <- rnIfaceGlobal (ifDefaultCls cls_inst) + tys <- mapM rnIfaceType (ifDefaultTys cls_inst) + return cls_inst { ifDefaultCls = n + , ifDefaultTys = tys + } + rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon) rnRoughMatchTyCon Nothing = return Nothing rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc @@ -659,36 +671,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 (IfaceForAllCo bndr co1 co2) - = IfaceForAllCo <$> 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 (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 (IfaceUnivCo s r t1 t2 deps) + = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 <*> mapM rnIfaceCo deps rnIfaceTyCon :: Rename IfaceTyCon rnIfaceTyCon (IfaceTyCon n info) diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs --- a/GHC/Iface/Syntax.hs +++ b/GHC/Iface/Syntax.hs @@ -12,12 +12,12 @@ IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding, + IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding, IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..), IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..), - IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceDefault(..), IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceClassBody(..), IfaceBooleanFormula(..), IfaceBang(..), IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), @@ -25,6 +25,9 @@ IfaceTyConParent(..), IfaceCompleteMatch(..), IfaceLFInfo(..), IfaceTopBndrInfo(..), + IfaceImport(..), + ifImpModule, + ImpIfaceList(..), IfaceExport, -- * Binding names IfaceTopBndr, @@ -33,9 +36,8 @@ -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, ifaceDeclFingerprints, - fromIfaceBooleanFormula, fromIfaceWarnings, - + fromIfaceWarningTxt, -- Free Names freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, freeNamesIfConDecls, @@ -48,7 +50,10 @@ import GHC.Prelude +import GHC.Builtin.Names(mkUnboundName) import GHC.Data.FastString +import GHC.Data.BooleanFormula (pprBooleanFormula, isTrue) + import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, constraintKindTyConKey ) import GHC.Types.Unique ( hasKey ) @@ -59,24 +64,26 @@ import GHC.Types.Cpr import GHC.Core.Class import GHC.Types.FieldLabel -import GHC.Types.Name.Set import GHC.Core.Coercion.Axiom ( BranchIndex ) import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Reader import GHC.Types.CostCentre import GHC.Types.Literal +import GHC.Types.Avail import GHC.Types.ForeignCall import GHC.Types.Annotations( AnnPayload, AnnTarget ) import GHC.Types.Basic +import GHC.Types.Tickish import GHC.Unit.Module import GHC.Unit.Module.Warnings import GHC.Types.SrcLoc import GHC.Types.SourceText -import GHC.Data.BooleanFormula ( BooleanFormula(..), pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders, visArgTypeLike ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) -import GHC.Stg.InferTags.TagSig +import GHC.Stg.EnforceEpt.TagSig import GHC.Parser.Annotation (noLocA) import GHC.Hs.Extension ( GhcRn ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -84,15 +91,18 @@ import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint import GHC.Utils.Binary -import GHC.Utils.Binary.Typeable () +import GHC.Utils.Binary.Typeable () -- instance Binary AnnPayload import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, - seqList, zipWithEqual ) + zipWithEqual ) +import Language.Haskell.Syntax.BooleanFormula(BooleanFormula(..)) + import Control.Monad -import System.IO.Unsafe import Control.DeepSeq +import Data.Proxy +import qualified Data.Set as Set infixl 3 &&& @@ -104,6 +114,53 @@ ************************************************************************ -} +type IfaceExport = AvailInfo + +data IfaceImport = IfaceImport ImpDeclSpec ImpIfaceList + +data ImpIfaceList + = ImpIfaceAll -- ^ no user import list + | ImpIfaceExplicit + { iil_avails :: !DetOrdAvails + , iil_non_explicit_parents :: ![Name] + } + | ImpIfaceEverythingBut ![Name] + +-- | Extract the imported module from an IfaceImport +ifImpModule :: IfaceImport -> Module +ifImpModule (IfaceImport declSpec _) = is_mod declSpec + +instance Binary IfaceImport where + put_ bh (IfaceImport declSpec ifaceList) = do + put_ bh declSpec + put_ bh ifaceList + get bh = do + declSpec <- get bh + ifaceList <- get bh + return (IfaceImport declSpec ifaceList) + +instance Binary ImpIfaceList where + put_ bh ImpIfaceAll = putByte bh 0 + put_ bh (ImpIfaceExplicit env implicit_parents) = do + putByte bh 1 + put_ bh env + put_ bh implicit_parents + put_ bh (ImpIfaceEverythingBut ns) = do + putByte bh 2 + put_ @[Name] bh ns + get bh = do + tag <- getByte bh + case tag of + 0 -> return ImpIfaceAll + 1 -> do + env <- get bh + implicit_parents <- get bh + return $ ImpIfaceExplicit env implicit_parents + 2 -> do + ns <- get @[Name] bh + return $ ImpIfaceEverythingBut ns + _ -> fail $ "instance Binary ImpIfaceList: Invalid tag " ++ show tag + -- | A binding top-level 'Name' in an interface file (e.g. the name of an -- 'IfaceDecl'). type IfaceTopBndr = Name @@ -117,16 +174,15 @@ -- We don't serialise the namespace onto the disk though; rather we -- drop it when serialising and add it back in when deserialising. -getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr +getIfaceTopBndr :: ReadBinHandle -> IO IfaceTopBndr getIfaceTopBndr bh = get bh -putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () +putIfaceTopBndr :: WriteBinHandle -> IfaceTopBndr -> IO () putIfaceTopBndr bh name = - case getUserData bh of - UserData{ ud_put_binding_name = put_binding_name } -> + case findUserDataWriter (Proxy @BindingName) bh of + tbl -> --pprTrace "putIfaceTopBndr" (ppr name) $ - put_binding_name bh name - + putEntry tbl bh (BindingName name) data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, @@ -199,21 +255,24 @@ ifClassCtxt :: IfaceContext, -- Super classes ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures - ifMinDef :: IfaceBooleanFormula -- Minimal complete definition + ifMinDef :: IfaceBooleanFormula, -- Minimal complete definition + ifUnary :: Bool -- This is a unary class + -- NB: in principle ifUnary is redundant; it can be deduced from + -- the number and types of class ops. In practice, in interface + -- files those types are knot tied, and it's very easy to get a + -- black hole. Easiest thing: let the definition module decide if + -- it is a unary class, and communicate that through IfaceClassBody + -- See (UCM12) in Note [Unary class magic] in GHC.Core.TyCon } +-- See also 'BooleanFormula' data IfaceBooleanFormula = IfVar IfLclName | IfAnd [IfaceBooleanFormula] | IfOr [IfaceBooleanFormula] | IfParens IfaceBooleanFormula + deriving Eq -fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula IfLclName -fromIfaceBooleanFormula = \case - IfVar nm -> Var nm - IfAnd ibfs -> And (map (noLocA . fromIfaceBooleanFormula) ibfs) - IfOr ibfs -> Or (map (noLocA . fromIfaceBooleanFormula) ibfs) - IfParens ibf -> Parens (noLocA . fromIfaceBooleanFormula $ ibf) data IfaceTyConParent = IfNoParent @@ -282,7 +341,7 @@ -- So this guarantee holds for IfaceConDecl, but *not* for DataCon ifConExTCvs :: [IfaceBndr], -- Existential ty/covars - ifConUserTvBinders :: [IfaceForAllSpecBndr], + ifConUserTvBinders :: [IfaceForAllBndr], -- The tyvars, in the order the user wrote them -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the -- set of tyvars (*not* covars) of ifConExTCvs, unioned @@ -310,12 +369,23 @@ data IfaceSrcBang = IfSrcBang SrcUnpackedness SrcStrictness +-- See Note [Named default declarations] in GHC.Tc.Gen.Default +-- | Exported named defaults +data IfaceDefault + = IfaceDefault { ifDefaultCls :: IfExtName, -- Defaulted class + ifDefaultTys :: [IfaceType], -- List of defaults + ifDefaultWarn :: Maybe IfaceWarningTxt } + data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst ifDFun :: IfExtName, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: IsOrphan } -- See Note [Orphans] in GHC.Core.InstEnv + ifInstOrph :: IsOrphan, -- See Note [Orphans] in GHC.Core.InstEnv + ifInstWarn :: Maybe IfaceWarningTxt } + -- Warning emitted when the instance is used + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -364,7 +434,7 @@ type IfaceAnnTarget = AnnTarget OccName -data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfaceTyCon) +data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfExtName) instance Outputable IfaceCompleteMatch where ppr (IfaceCompleteMatch cls mtc) = text "COMPLETE" <> colon <+> ppr cls <+> case mtc of @@ -480,6 +550,14 @@ 4 -> pure IfLFUnlifted _ -> panic "Invalid byte" +instance NFData IfaceLFInfo where + rnf = \case + IfLFReEntrant arity -> rnf arity + IfLFThunk updatable mb_fun -> rnf updatable `seq` rnf mb_fun + IfLFCon con -> rnf con + IfLFUnknown fun_flag -> rnf fun_flag + IfLFUnlifted -> () + {- Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -531,9 +609,7 @@ ifSigs = sigs, ifATs = ats }}) - = -- (possibly) newtype coercion - co_occs ++ - -- data constructor (DataCon namespace) + = -- data constructor (DataCon namespace) -- data worker (Id namespace) -- no wrapper (class dictionaries never have a wrapper) [dc_occ, dcww_occ] ++ @@ -546,12 +622,8 @@ where cls_tc_occ = occName cls_tc_name n_ctxt = length sc_ctxt - n_sigs = length sigs - co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] - | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ dc_occ = mkClassDataConOcc cls_tc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) ifaceDeclImplicitBndrs _ = [] @@ -578,9 +650,7 @@ [ (occ, computeFingerprint' (hash,occ)) | occ <- ifaceDeclImplicitBndrs decl ] where - computeFingerprint' = - unsafeDupablePerformIO - . computeFingerprint (panic "ifaceDeclFingerprints") + computeFingerprint' = computeFingerprint (panic "ifaceDeclFingerprints") fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn fromIfaceWarnings = \case @@ -590,8 +660,8 @@ fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt mb_cat src strs -> WarningTxt (noLoc . fromWarningCategory <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names) @@ -626,18 +696,19 @@ | IfaceFCall ForeignCall IfaceType | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + data IfaceTickish - = IfaceHpcTick Module Int -- from HpcTick x - | IfaceSCC CostCentre Bool Bool -- from ProfNote - | IfaceSource RealSrcSpan FastString -- from SourceNote - -- no breakpoints: we never export these into interface files + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + | IfaceSource RealSrcSpan FastString -- from SourceNote + | IfaceBreakpoint BreakpointId [IfaceExpr] -- from Breakpoint data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr -- Note: IfLclName, not IfaceBndr (and same with the case binder) -- We reconstruct the kind/type of the thing from the context -- thus saving bulk in interface files -data IfaceConAlt = IfaceDefault +data IfaceConAlt = IfaceDefaultAlt | IfaceDataAlt IfExtName | IfaceLitAlt Literal @@ -651,7 +722,7 @@ -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings] -data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails | IfGblTopBndr IfaceTopBndr @@ -659,9 +730,6 @@ -- See Note [Interface File with Core: Sharing RHSs] data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr -data IfaceJoinInfo = IfaceNotJoinPoint - | IfaceJoinPoint JoinArity - {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -834,10 +902,13 @@ everything unqualified, so we can just print the OccName directly. -} +-- | Show a declaration but not its RHS. showToHeader :: ShowSub showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing , ss_forall = ShowForAllWhen } +-- | Show declaration and its RHS, including GHc-internal information (e.g. +-- for @--show-iface@). showToIface :: ShowSub showToIface = ShowSub { ss_how_much = ShowIface , ss_forall = ShowForAllWhen } @@ -848,18 +919,20 @@ -- show if all sub-components or the complete interface is shown ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition] -ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc -ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc -ppShowAllSubs _ _ = Outputable.empty +ppShowAllSubs (ShowSub { ss_how_much = ShowSome Nothing _ }) doc + = doc +ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowAllSubs _ _ = Outputable.empty ppShowRhs :: ShowSub -> SDoc -> SDoc ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty ppShowRhs _ doc = doc showSub :: HasOccName n => ShowSub -> n -> Bool -showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False -showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing -showSub (ShowSub { ss_how_much = _ }) _ = True +showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (Just f) _ }) thing + = f (occName thing) +showSub (ShowSub { ss_how_much = _ }) _ = True ppr_trim :: [Maybe SDoc] -> [SDoc] -- Collapse a group of Nothings to a single "..." @@ -889,15 +962,226 @@ constraintIfaceKind = IfaceTyConApp (IfaceTyCon constraintKindTyConName (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil +{- Note [Print invisible binders in interface declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Starting from GHC 9.8 it is possible to write invisible @-binders +in type-level declarations. That feature introduced several challenges +in interface declaration pretty printing (e.g. using the :info command +inside GHCi) to overcome. + +Consider this example with a redundant type variable `a`: + + type Id :: forall a b. b -> b + type Id x = x + +GHC will create system binders for kinds there to meet typechecking +and compilation needs and that will turn that declaration into a less +straightforward form with multiple @-binders: + + type Id :: forall {k} (a :: k) b. b -> b + type Id @{k} @a @b x = x :: b + +This information isn't required for understanding in most cases, +so GHC will hide it unless -fprint-explicit-kinds flag is supplied by the user. +And here is what we get: + + type Id :: forall {k} (a :: k) b. b -> b + type Id x = x + +However, there are several cases involving user-written @-binders +when it is cruicial to show them to provide understanding of what's going on. +First of all it can plainly appear on the right-hand side: + + type T :: forall (a :: Type). Type + type T @x = Tuple2 x x + +Not only that, an invisible binder can be unused by itself, but have an +impact on invisible binder positioning, e.g.: + + type T :: forall (a :: Type) (b :: Type). Type + type T @x @y = Tuple2 y y + +Here `x` is unused, but it is required to display, as `y` corresponds +to `b` in the standalone kind signature. + +The last problem is related to non-generative type declarations (type +synonyms and type families) only. It is not possible to partially +apply them, hence it's important to understand what parts of a declaration's +kind are related to the declaration itself. Here is a simple example: + + type T1 :: forall k. k -> Maybe k + type T1 = Just + + type T2 :: forall k. k -> Maybe k + type T2 @k = Just + +Both these type synonyms have the same kind signature, but they aren't +the same! `T1` can be used in strictly more cases, for example, as +an argument for a higher-order type: + + type F :: (forall k. k -> Maybe k) -> Type + + type R1 = F T1 -- Yes! + type R2 = F T2 -- No, that will not compile :( + +User-written invisible binders and "system" binders introduced by GHC +are indistinguishable at this stage, hence we try to only print +semantically significant binders by default. + +An invisible binder is considered significant when it meets at least +one of the following two criteria: + - It visibly occurs in the declaration's body (See more about that below) + - It is followed by a significant binder, + so it affects positioning +For non-generative type declarations (type synonyms and type families), +there is one additional criterion: + - It is not followed by a visible binder, so it + affects the arity of a type declaration + +The overall solution consists of three functions: +- `iface_decl_non_generative` decides whether the current declaration is + generative or not + +- `iface_decl_mentioned_vars` gives a Set of variables that + visibly occur in the declaration's body + +- `suppressIfaceInvisibles` uses information provided + by the first two functions to actually filter out insignificant + @-binders + +Here is what we consider "visibly occurs" in general and for +each declaration type: + +- Variables that visibly occur in IfaceType are collected by the + `visibleTypeVarOccurencies` function. + +- Variables that visibly occur in IfaceAT are collected by `iface_at_mentioned_vars` + function. It accounts visible binders for associated data and type + families and for type families only, it counts invisible binders. + Associated types can't have definitions, so it's safe to drop all other + binders. + +- None of the type variables in IfaceData declared using GADT syntax doesn't are considered + as visibe occurrences. This is because each constructor has its own variables, e.g.: + + type D :: forall (a :: Type). Type + data D @a where + MkD :: D @b + -- This is shorthand for: + -- MkD :: forall b. D @b + +- For IfaceData declared using Haskell98 syntax, a variable is considered visible + if it visibly occurs in at least one argument's type in at least one constructor. + +- For IfaceSynonym, a variable is considered visible if it visibly occurs + in the RHS type. + +- For IfaceFamily, a variable is considered visible if i occurs inside + an injectivity annotation, e.g. + + type family F @a = r | r -> a + +- For IfaceClass, a variable is considered visible if it occurs at least + once inside a functional dependency annotation or in at least one method's + type signature, or if it visibly occurs in at least one associated type's + declaration (Visible occurrences in associated types are described above.) + +- IfacePatSyn, IfaceId and IfaceAxiom are irrelevant to this problem. +-} + +iface_decl_generative :: IfaceDecl -> Bool +iface_decl_generative IfaceSynonym{} = False +iface_decl_generative IfaceFamily{ifFamFlav = rhs} + | IfaceDataFamilyTyCon <- rhs = True + | otherwise = False +iface_decl_generative IfaceData{} = True +iface_decl_generative IfaceId{} = True +iface_decl_generative IfaceClass{} = True +iface_decl_generative IfaceAxiom{} = True +iface_decl_generative IfacePatSyn{} = True + +iface_at_mentioned_vars :: IfaceAT -> Set.Set IfLclName +iface_at_mentioned_vars (IfaceAT decl _) + = Set.fromList . map ifTyConBinderName . suppress_vars $ binders + where + -- ifBinders is not total, so we assume here that associated types + -- cannot be IfaceId, IfaceAxiom or IfacePatSyn + binders = case decl of + IfaceFamily {ifBinders} -> ifBinders + IfaceData{ifBinders} -> ifBinders + IfaceSynonym{ifBinders} -> ifBinders + IfaceClass{ifBinders} -> ifBinders + IfaceId{} -> panic "IfaceId shoudn't be an associated type!" + IfaceAxiom{} -> panic "IfaceAxiom shoudn't be an associated type!" + IfacePatSyn {} -> panic "IfacePatSyn shoudn't be an associated type!" + + suppress_arity = not (iface_decl_generative decl) + + suppress_vars binders = + suppressIfaceInvisibles + -- We need to count trailing invisible binders for type families + (MkPrintArityInvisibles suppress_arity) + -- But this setting will simply count all invisible binderss + (PrintExplicitKinds False) + -- ...and associated types can't have a RHS + mempty + binders binders + +-- See Note [Print invisible binders in interface declarations] +-- in particular, the parts about collecting visible occurrences +iface_decl_mentioned_vars :: IfaceDecl -> Set.Set IfLclName +iface_decl_mentioned_vars (IfaceData { ifCons = condecls, ifGadtSyntax = gadt }) + | gadt = mempty + -- Get visible occurrences in each constructor in each alternative + | otherwise = Set.unions (map mentioned_con_vars cons) + where + mentioned_con_vars = Set.unions . map (visibleTypeVarOccurencies . snd) . ifConArgTys + cons = visibleIfConDecls condecls + +iface_decl_mentioned_vars (IfaceClass { ifFDs = fds, ifBody = IfAbstractClass }) + = Set.unions (map fundep_names fds) + where + fundep_names fd = Set.fromList (fst fd) `Set.union` Set.fromList (snd fd) + +iface_decl_mentioned_vars + (IfaceClass { ifFDs = fds + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs + }}) + = Set.unions + [ Set.unions (map fundep_names fds) + , Set.unions (map iface_at_mentioned_vars ats) + , Set.unions (map (visibleTypeVarOccurencies . class_op_type) sigs) + ] + where + class_op_type (IfaceClassOp _bndr ty _default) = ty + + fundep_names fd = Set.fromList (fst fd) `Set.union` Set.fromList (snd fd) + +iface_decl_mentioned_vars (IfaceSynonym {ifSynRhs = poly_ty}) + = visibleTypeVarOccurencies poly_ty + +-- Consider a binder to be a visible occurrence if it occurs inside an injectivity annotation. +iface_decl_mentioned_vars (IfaceFamily { ifBinders = binders, ifResVar = res_var, ifFamInj = inj }) + | Just{} <- res_var + , Injective injectivity <- inj + = Set.fromList . map (ifTyConBinderName . snd) . filter fst $ zip injectivity binders + | otherwise = mempty + +iface_decl_mentioned_vars IfacePatSyn{} = mempty +iface_decl_mentioned_vars IfaceId{} = mempty +iface_decl_mentioned_vars IfaceAxiom{} = mempty + pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi -- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr -pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, - ifCtxt = context, ifResKind = kind, - ifRoles = roles, ifCons = condecls, - ifParent = parent, - ifGadtSyntax = gadt, - ifBinders = binders }) +pprIfaceDecl ss decl@(IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifResKind = kind, + ifRoles = roles, ifCons = condecls, + ifParent = parent, + ifGadtSyntax = gadt, + ifBinders = binders }) | gadt = vcat [ pp_roles , pp_ki_sig @@ -920,16 +1204,13 @@ cons = visibleIfConDecls condecls pp_where = ppWhen (gadt && not (null cons)) $ text "where" pp_cons = ppr_trim (map show_con cons) :: [SDoc] - pp_kind = ppUnless (if ki_sig_printable - then isIfaceRhoType kind - -- Even in the presence of a standalone kind signature, a non-tau - -- result kind annotation cannot be discarded as it determines the arity. - -- See Note [Arity inference in kcCheckDeclHeader_sig] in GHC.Tc.Gen.HsType - else isIfaceLiftedTypeKind kind) + pp_kind = ppUnless (ki_sig_printable || isIfaceLiftedTypeKind kind) (dcolon <+> ppr kind) + decl_head = pprIfaceDeclHead decl suppress_bndr_sig context ss tycon binders + pp_lhs = case parent of - IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders + IfNoParent -> decl_head IfDataInstance{} -> text "instance" <+> pp_data_inst_forall <+> pprIfaceTyConParent parent @@ -976,36 +1257,40 @@ pp_extra = vcat [pprCType ctype] -pprIfaceDecl ss (IfaceClass { ifName = clas - , ifRoles = roles - , ifFDs = fds - , ifBinders = binders - , ifBody = IfAbstractClass }) +pprIfaceDecl ss decl@(IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfAbstractClass }) = vcat [ pprClassRoles ss clas binders roles , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) - , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ] + , text "class" <+> decl_head <+> pprFundeps fds ] where + decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss clas binders + -- See Note [Suppressing binder signatures] in GHC.Iface.Type suppress_bndr_sig = SuppressBndrSig True -pprIfaceDecl ss (IfaceClass { ifName = clas - , ifRoles = roles - , ifFDs = fds - , ifBinders = binders - , ifBody = IfConcreteClass { - ifATs = ats, - ifSigs = sigs, - ifClassCtxt = context, - ifMinDef = minDef - }}) +pprIfaceDecl ss decl@(IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs, + ifClassCtxt = context, + ifMinDef = minDef + }}) = vcat [ pprClassRoles ss clas binders roles , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) - , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where + , text "class" <+> decl_head <+> pprFundeps fds <+> pp_where , nest 2 (vcat [ vcat asocs, vcat dsigs , ppShowAllSubs ss (pprMinDef $ fromIfaceBooleanFormula minDef)])] where pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") + decl_head = pprIfaceDeclHead decl suppress_bndr_sig context ss clas binders + asocs = ppr_trim $ map maybeShowAssoc ats dsigs = ppr_trim $ map maybeShowSig sigs @@ -1019,29 +1304,38 @@ | showSub ss sg = Just $ pprIfaceClassOp ss sg | otherwise = Nothing - pprMinDef :: BooleanFormula IfLclName -> SDoc + pprMinDef :: BooleanFormula GhcRn -> SDoc pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions text "{-# MINIMAL" <+> pprBooleanFormula - (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> + (\_ def -> let fs = getOccFS def in cparen (isLexSym fs) (ppr fs)) 0 minDef <+> text "#-}" + fromIfaceBooleanFormula :: IfaceBooleanFormula -> BooleanFormula GhcRn + -- `mkUnboundName` here is fine because the Name generated is only used for pretty printing and nothing else. + fromIfaceBooleanFormula (IfVar nm ) = Var $ noLocA . mkUnboundName . mkVarOccFS . ifLclNameFS $ nm + fromIfaceBooleanFormula (IfAnd bfs ) = And $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfOr bfs ) = Or $ map (noLocA . fromIfaceBooleanFormula) bfs + fromIfaceBooleanFormula (IfParens bf) = Parens $ (noLocA . fromIfaceBooleanFormula) bf + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type suppress_bndr_sig = SuppressBndrSig True -pprIfaceDecl ss (IfaceSynonym { ifName = tc - , ifBinders = binders - , ifSynRhs = mono_ty - , ifResKind = res_kind}) +pprIfaceDecl ss decl@(IfaceSynonym { ifName = tc + , ifBinders = binders + , ifSynRhs = poly_ty + , ifResKind = res_kind}) = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) - , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals) - 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau - , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) + , hang (text "type" <+> decl_head <+> equals) + 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr_tau ]) ] where - (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + (tvs, theta, tau) = splitIfaceSigmaTy poly_ty name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) + decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss tc binders + -- See Note [Printing type abbreviations] in GHC.Iface.Type ppr_tau | tc `hasKey` liftedTypeKindTyConKey || tc `hasKey` unrestrictedFunTyConKey || @@ -1052,27 +1346,28 @@ -- See Note [Suppressing binder signatures] in GHC.Iface.Type suppress_bndr_sig = SuppressBndrSig True -pprIfaceDecl ss (IfaceFamily { ifName = tycon - , ifFamFlav = rhs, ifBinders = binders - , ifResKind = res_kind - , ifResVar = res_var, ifFamInj = inj }) +pprIfaceDecl ss decl@(IfaceFamily { ifName = tycon + , ifFamFlav = rhs, ifBinders = binders + , ifResKind = res_kind + , ifResVar = res_var, ifFamInj = inj }) | IfaceDataFamilyTyCon <- rhs = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) - , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders + , text "data family" <+> decl_head ] | otherwise = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) - , hang (text "type family" - <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders + , hang (text "type family" <+> decl_head <+> pp_inj res_var inj <+> ppShowRhs ss (pp_where rhs)) - 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) + 2 (ppShowRhs ss (pp_rhs rhs)) $$ nest 2 (ppShowRhs ss (pp_branches rhs)) ] where name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + decl_head = pprIfaceDeclHead decl suppress_bndr_sig [] ss tycon binders + pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" pp_where _ = empty @@ -1084,7 +1379,7 @@ pp_inj_cond res inj = case filterByList inj binders of [] -> empty - tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] + tvs -> hsep [vbar, ppr res, arrow, interppSP (map ifTyConBinderName tvs)] pp_rhs IfaceDataFamilyTyCon = ppShowIface ss (text "data") @@ -1161,12 +1456,17 @@ -> [Role] -> SDoc pprRoles suppress_if tyCon bndrs roles = sdocOption sdocPrintExplicitKinds $ \print_kinds -> - let froles = suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs roles + let froles = + suppressIfaceInvisibles + (MkPrintArityInvisibles False) + (PrintExplicitKinds print_kinds) + mempty + bndrs roles in ppUnless (all suppress_if froles || null froles) $ text "type role" <+> tyCon <+> hsep (map ppr froles) pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc -pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty +pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> dcolon <+> ppr ty pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name @@ -1218,16 +1518,25 @@ pprIfaceTyConParent (IfDataInstance _ tc tys) = pprIfaceTypeApp topPrec tc tys -pprIfaceDeclHead :: SuppressBndrSig +pprIfaceDeclHead :: IfaceDecl + -> SuppressBndrSig -> IfaceContext -> ShowSub -> Name -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression -> SDoc -pprIfaceDeclHead suppress_sig context ss tc_occ bndrs +pprIfaceDeclHead decl suppress_sig context ss tc_occ bndrs = sdocOption sdocPrintExplicitKinds $ \print_kinds -> sep [ pprIfaceContextArr context , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) <+> pprIfaceTyConBinders suppress_sig - (suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs bndrs) ] + (suppressIfaceInvisibles + (MkPrintArityInvisibles print_arity) + (PrintExplicitKinds print_kinds) + mentioned_vars + bndrs bndrs) ] + where + -- See Note [Print invisible binders in interface declarations] + mentioned_vars = iface_decl_mentioned_vars decl + print_arity = not (iface_decl_generative decl) pprIfaceConDecl :: ShowSub -> Bool -> IfaceTopBndr @@ -1262,15 +1571,15 @@ -- the visibilities of the existential tyvar binders, we can simply drop -- the universal tyvar binders from user_tvbs. ex_tvbs = dropList tc_binders user_tvbs - ppr_ex_quant = pprIfaceForAllPartMust (ifaceForAllSpecToBndrs ex_tvbs) ctxt + ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt pp_gadt_res_ty = mk_user_con_res_ty eq_spec - ppr_gadt_ty = pprIfaceForAllPart (ifaceForAllSpecToBndrs user_tvbs) ctxt pp_tau + ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName pp_tau | null fields = case pp_args ++ [pp_gadt_res_ty] of - (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d) + (t:ts) -> fsep (t : zipWithEqual (\(w,_) d -> ppr_arr w <+> d) arg_tys ts) [] -> panic "pp_con_taus" | otherwise @@ -1285,9 +1594,9 @@ ppr_bang IfNoBang = whenPprDebug $ char '_' ppr_bang IfStrict = char '!' - ppr_bang IfUnpack = text "{-# UNPACK #-}" - ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> - pprParendIfaceCoercion co + ppr_bang IfUnpack = text "{-# UNPACK #-} !" + ppr_bang (IfUnpackCo co) = text "{-# UNPACK #-} !" <> + whenPprDebug (pprParendIfaceCoercion co) pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc -- If using record syntax, the only reason one would need to parenthesize @@ -1396,6 +1705,10 @@ where pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot +instance Outputable IfaceDefault where + ppr (IfaceDefault { ifDefaultCls = cls, ifDefaultTys = tcs }) + = text "default" <+> ppr cls <+> parens (pprWithCommas ppr tcs) + instance Outputable IfaceClsInst where ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag , ifInstCls = cls, ifInstTys = mb_tcs @@ -1537,6 +1850,8 @@ = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names) = braces (pprUserRealSpan True src) +pprIfaceTickish (IfaceBreakpoint (BreakpointId m ix) fvs) + = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs) ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc @@ -1546,7 +1861,7 @@ ------------------ instance Outputable IfaceConAlt where - ppr IfaceDefault = text "DEFAULT" + ppr IfaceDefaultAlt = text "DEFAULT" ppr (IfaceLitAlt l) = ppr l ppr (IfaceDataAlt d) = ppr d @@ -1572,10 +1887,6 @@ ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig -instance Outputable IfaceJoinInfo where - ppr IfaceNotJoinPoint = empty - ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) - instance Outputable IfaceUnfolding where ppr (IfCoreUnfold src _ guide e) = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ] @@ -1764,15 +2075,13 @@ = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceAppCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceForAllCo _ kind_co co) +freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co) = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet -freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) - = unitNameSet ax &&& fnList freeNamesIfCoercion cos -freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) - = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2 cos) + = freeNamesIfType t1 &&& freeNamesIfType t2 &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceSymCo c) = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) @@ -1787,15 +2096,13 @@ = freeNamesIfCoercion c freeNamesIfCoercion (IfaceSubCo co) = freeNamesIfCoercion co -freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) - -- the axiom is just a string, so we don't count it as a name. - = fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAxiomCo ax cos) + = fnAxRule ax &&& fnList freeNamesIfCoercion cos -freeNamesIfProv :: IfaceUnivCoProv -> NameSet -freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co -freeNamesIfProv (IfacePluginProv _) = emptyNameSet -freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet +fnAxRule :: IfaceAxiomRule -> NameSet +fnAxRule (IfaceAR_X _) = emptyNameSet -- the axiom is just a string, so we don't count it as a name. +fnAxRule (IfaceAR_U n) = unitNameSet n +fnAxRule (IfaceAR_B n _) = unitNameSet n freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr @@ -1845,7 +2152,7 @@ freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co -freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e +freeNamesIfExpr (IfaceTick t e) = freeNamesIfTickish t &&& freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts) = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts @@ -1855,7 +2162,7 @@ -- Depend on the data constructors. Just one will do! -- Note [Tracking data constructors] fn_cons [] = emptyNameSet - fn_cons (IfaceAlt IfaceDefault _ _ : xs) = fn_cons xs + fn_cons (IfaceAlt IfaceDefaultAlt _ _ : xs) = fn_cons xs fn_cons (IfaceAlt (IfaceDataAlt con) _ _ : _ ) = unitNameSet con fn_cons (_ : _ ) = emptyNameSet @@ -1892,6 +2199,11 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys) = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys +freeNamesIfTickish :: IfaceTickish -> NameSet +freeNamesIfTickish (IfaceBreakpoint _ fvs) = + fnList freeNamesIfExpr fvs +freeNamesIfTickish _ = emptyNameSet + -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSet @@ -1984,9 +2296,10 @@ ifFDs = a5, ifBody = IfConcreteClass { ifClassCtxt = a1, - ifATs = a6, - ifSigs = a7, - ifMinDef = a8 + ifATs = a6, + ifSigs = a7, + ifMinDef = a8, + ifUnary = a9 }}) = do putByte bh 5 put_ bh a1 @@ -1997,6 +2310,7 @@ put_ bh a6 put_ bh a7 put_ bh a8 + put_ bh a9 put_ bh (IfaceAxiom a1 a2 a3 a4) = do putByte bh 6 @@ -2070,6 +2384,7 @@ a6 <- get bh a7 <- get bh a8 <- get bh + a9 <- get bh return (IfaceClass { ifName = a2, ifRoles = a3, @@ -2077,9 +2392,10 @@ ifFDs = a5, ifBody = IfConcreteClass { ifClassCtxt = a1, - ifATs = a6, - ifSigs = a7, - ifMinDef = a8 + ifATs = a6, + ifSigs = a7, + ifMinDef = a8, + ifUnary = a9 }}) 6 -> do a1 <- getIfaceTopBndr bh a2 <- get bh @@ -2273,20 +2589,33 @@ a2 <- get bh return (IfSrcBang a1 a2) +instance Binary IfaceDefault where + put_ bh (IfaceDefault cls tys warn) = do + put_ bh cls + put_ bh tys + put_ bh warn + get bh = do + cls <- get bh + tys <- get bh + warn <- get bh + return (IfaceDefault cls tys warn) + instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh (IfaceClsInst cls tys dfun flag orph warn) = do put_ bh cls put_ bh tys put_ bh dfun put_ bh flag put_ bh orph + put_ bh warn get bh = do cls <- get bh tys <- get bh dfun <- get bh flag <- get bh orph <- get bh - return (IfaceClsInst cls tys dfun flag orph) + warn <- get bh + return (IfaceClsInst cls tys dfun flag orph warn) instance Binary IfaceFamInst where put_ bh (IfaceFamInst fam tys name orph) = do @@ -2437,13 +2766,13 @@ c <- get bh return (IfWhen a b c) -putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO () +putUnfoldingCache :: WriteBinHandle -> IfUnfoldingCache -> IO () putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike , uf_is_work_free = wf, uf_expandable = exp }) = do let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp putByte bh b -getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache +getUnfoldingCache :: ReadBinHandle -> IO IfUnfoldingCache getUnfoldingCache bh = do b <- getByte bh let hnf = testBit b 3 @@ -2453,9 +2782,14 @@ return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike , uf_is_work_free = wf, uf_expandable = exp }) +seqUnfoldingCache :: IfUnfoldingCache -> () +seqUnfoldingCache (UnfoldingCache hnf conlike wf exp) = + rnf hnf `seq` rnf conlike `seq` rnf wf `seq` rnf exp `seq` () + infixl 9 .<<|. -(.<<|.) :: (Bits a) => a -> Bool -> a +(.<<|.) :: (Num a, Bits a) => a -> Bool -> a x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1) +{-# INLINE (.<<|.) #-} instance Binary IfaceAlt where put_ bh (IfaceAlt a b c) = do @@ -2522,12 +2856,10 @@ putByte bh 13 put_ bh a put_ bh b - put_ bh (IfaceLitRubbish TypeLike r) = do + put_ bh (IfaceLitRubbish torc r) = do putByte bh 14 put_ bh r - put_ bh (IfaceLitRubbish ConstraintLike r) = do - putByte bh 15 - put_ bh r + put_ bh torc get bh = do h <- getByte bh case h of @@ -2571,9 +2903,8 @@ b <- get bh return (IfaceECase a b) 14 -> do r <- get bh - return (IfaceLitRubbish TypeLike r) - 15 -> do r <- get bh - return (IfaceLitRubbish ConstraintLike r) + torc <- get bh + return (IfaceLitRubbish torc r) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceTickish where @@ -2594,6 +2925,11 @@ put_ bh (srcSpanEndLine src) put_ bh (srcSpanEndCol src) put_ bh name + put_ bh (IfaceBreakpoint (BreakpointId m ix) fvs) = do + putByte bh 3 + put_ bh m + put_ bh ix + put_ bh fvs get bh = do h <- getByte bh @@ -2614,16 +2950,20 @@ end = mkRealSrcLoc file el ec name <- get bh return (IfaceSource (mkRealSrcSpan start end) name) + 3 -> do m <- get bh + ix <- get bh + fvs <- get bh + return (IfaceBreakpoint (BreakpointId m ix) fvs) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 + put_ bh IfaceDefaultAlt = putByte bh 0 put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac get bh = do h <- getByte bh case h of - 0 -> return IfaceDefault + 0 -> return IfaceDefaultAlt 1 -> liftM IfaceDataAlt $ get bh _ -> liftM IfaceLitAlt $ get bh @@ -2678,19 +3018,6 @@ 1 -> IfRhs <$> get bh _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) - - -instance Binary IfaceJoinInfo where - put_ bh IfaceNotJoinPoint = putByte bh 0 - put_ bh (IfaceJoinPoint ar) = do - putByte bh 1 - put_ bh ar - get bh = do - h <- getByte bh - case h of - 0 -> return IfaceNotJoinPoint - _ -> liftM IfaceJoinPoint $ get bh - instance Binary IfaceTyConParent where put_ bh IfNoParent = putByte bh 0 put_ bh (IfDataInstance ax pr ty) = do @@ -2722,42 +3049,50 @@ ************************************************************************ -} +instance NFData IfaceImport where + rnf (IfaceImport a b) = rnf a `seq` rnf b + +instance NFData ImpIfaceList where + rnf ImpIfaceAll = () + rnf (ImpIfaceEverythingBut ns) = rnf ns + rnf (ImpIfaceExplicit gre explicit) = rnf gre `seq` rnf explicit + instance NFData IfaceDecl where rnf = \case IfaceId f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> - f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 IfaceSynonym f1 f2 f3 f4 f5 -> - rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 IfaceFamily f1 f2 f3 f4 f5 f6 -> - rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` () IfaceClass f1 f2 f3 f4 f5 -> - rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 IfaceAxiom nm tycon role ax -> rnf nm `seq` rnf tycon `seq` - role `seq` + rnf role `seq` rnf ax IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` - rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` () instance NFData IfaceAxBranch where rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 instance NFData IfaceClassBody where rnf = \case IfAbstractClass -> () - IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` () + IfConcreteClass f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` () instance NFData IfaceBooleanFormula where rnf = \case @@ -2770,7 +3105,7 @@ rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 instance NFData IfaceClassOp where - rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () + rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` () instance NFData IfaceTyConParent where rnf = \case @@ -2785,19 +3120,22 @@ instance NFData IfaceConDecl where rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` - rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` rnf f11 instance NFData IfaceSrcBang where - rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () + rnf (IfSrcBang f1 f2) = rnf f1 `seq` rnf f2 `seq` () instance NFData IfaceBang where - rnf x = x `seq` () + rnf IfNoBang = () + rnf IfStrict = () + rnf IfUnpack = () + rnf (IfUnpackCo co) = rnf co instance NFData IfaceIdDetails where rnf = \case IfVanillaId -> () - IfWorkerLikeId dmds -> dmds `seqList` () + IfWorkerLikeId dmds -> rnf dmds `seq` () IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d IfDFunId -> () @@ -2806,23 +3144,22 @@ rnf = \case HsArity a -> rnf a HsDmdSig str -> seqDmdSig str - HsInline p -> p `seq` () -- TODO: seq further? + HsInline p -> rnf p `seq` () HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () - HsCprSig cpr -> cpr `seq` () - HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further? - HsTagSig sig -> sig `seq` () + HsCprSig cpr -> seqCprSig cpr `seq` () + HsLFInfo lf_info -> rnf lf_info `seq` () + HsTagSig sig -> seqTagSig sig `seq` () instance NFData IfGuidance where rnf = \case IfNoGuidance -> () - IfWhen a b c -> a `seq` b `seq` c `seq` () + IfWhen a b c -> rnf a `seq` rnf b `seq` rnf c `seq` () instance NFData IfaceUnfolding where rnf = \case - IfCoreUnfold src cache guidance expr -> src `seq` cache `seq` rnf guidance `seq` rnf expr + IfCoreUnfold src cache guidance expr -> rnf src `seq` seqUnfoldingCache cache `seq` rnf guidance `seq` rnf expr IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs - -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache instance NFData IfaceExpr where rnf = \case @@ -2830,16 +3167,16 @@ IfaceExt nm -> rnf nm IfaceType ty -> rnf ty IfaceCo co -> rnf co - IfaceTuple sort exprs -> sort `seq` rnf exprs + IfaceTuple sort exprs -> rnf sort `seq` rnf exprs IfaceLam bndr expr -> rnf bndr `seq` rnf expr IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 - IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts + IfaceCase e nm alts -> rnf e `seq` rnf nm `seq` rnf alts IfaceECase e ty -> rnf e `seq` rnf ty IfaceLet bind e -> rnf bind `seq` rnf e IfaceCast e co -> rnf e `seq` rnf co - IfaceLit l -> l `seq` () -- FIXME - IfaceLitRubbish tc r -> tc `seq` rnf r `seq` () - IfaceFCall fc ty -> fc `seq` rnf ty + IfaceLit l -> rnf l `seq` () + IfaceLitRubbish tc r -> rnf tc `seq` rnf r `seq` () + IfaceFCall fc ty -> rnf fc `seq` rnf ty IfaceTick tick e -> rnf tick `seq` rnf e instance NFData IfaceAlt where @@ -2851,7 +3188,7 @@ IfaceRec binds -> rnf binds instance NFData IfaceTopBndrInfo where - rnf (IfGblTopBndr n) = n `seq` () + rnf (IfGblTopBndr n) = rnf n `seq` () rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` () instance NFData IfaceMaybeRhs where @@ -2870,35 +3207,37 @@ IfaceAbstractClosedSynFamilyTyCon -> () IfaceBuiltInSynFamTyCon -> () -instance NFData IfaceJoinInfo where - rnf x = x `seq` () - instance NFData IfaceTickish where rnf = \case IfaceHpcTick m i -> rnf m `seq` rnf i - IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 - IfaceSource src str -> src `seq` rnf str + IfaceSCC cc b1 b2 -> rnf cc `seq` rnf b1 `seq` rnf b2 + IfaceSource src str -> rnf src `seq` rnf str + IfaceBreakpoint i fvs -> rnf i `seq` rnf fvs instance NFData IfaceConAlt where rnf = \case - IfaceDefault -> () + IfaceDefaultAlt -> () IfaceDataAlt nm -> rnf nm - IfaceLitAlt lit -> lit `seq` () + IfaceLitAlt lit -> rnf lit `seq` () instance NFData IfaceCompleteMatch where rnf (IfaceCompleteMatch f1 mtc) = rnf f1 `seq` rnf mtc instance NFData IfaceRule where rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = - rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` () +instance NFData IfaceDefault where + rnf (IfaceDefault f1 f2 f3) = + rnf f1 `seq` rnf f2 `seq` rnf f3 + instance NFData IfaceFamInst where rnf (IfaceFamInst f1 f2 f3 f4) = - rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` () instance NFData IfaceClsInst where - rnf (IfaceClsInst f1 f2 f3 f4 f5) = - f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () + rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 instance NFData IfaceWarnings where rnf = \case @@ -2906,12 +3245,12 @@ IfWarnSome vs ds -> rnf vs `seq` rnf ds instance NFData IfaceWarningTxt where - rnf = \case - IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 - IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2 + rnf = \case + IfWarningTxt f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfDeprecatedTxt f1 f2 -> rnf f1 `seq` rnf f2 instance NFData IfaceStringLiteral where - rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2 + rnf (IfStringLiteral f1 f2) = rnf f1 `seq` rnf f2 instance NFData IfaceAnnotation where - rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () + rnf (IfaceAnnotation f1 f2) = rnf f1 `seq` rnf f2 `seq` () diff --git a/GHC/Iface/Tidy.hs b/GHC/Iface/Tidy.hs --- a/GHC/Iface/Tidy.hs +++ b/GHC/Iface/Tidy.hs @@ -1,14 +1,39 @@ {-# LANGUAGE DeriveFunctor #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE NamedFieldPuns #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} --- | Tidying up Core +{-| Tidying up Core + +This module's purpose is to prepare the Core program for two distinct purposes: +* To be serialised into the module's interface file +* To feed to the code generator + +The most important tasks are: +* Determine which `Name`s should ultimately be `Internal` and `External` + (which may differ to whether they were originally `Internal` or `External`). + See `Note [About the NameSorts]` in GHC.Types.Name. + For example, in: + module M where + f x = x + y + where y = factorial 4 + could be optimized during the Core pass to: + module M where + y = factorial 4 + f x = x + y + in which case `y` would be changed from `Internal` to `External`. + +* Rename local identifiers to avoid name clashes, so that unfoldings etc can + be serialialised using the OccName, without Uniques. + + For example (`x_5` means `x` with a `Unique` of `5`): + f x_12 x_23 = x_12 + would be changed to: + f x_12 x1_23 = x_12 +-} module GHC.Iface.Tidy ( TidyOpts (..) , UnfoldingExposure (..) @@ -24,16 +49,14 @@ import GHC.Core import GHC.Core.Unfold --- import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq ( seqBinds ) import GHC.Core.Opt.Arity ( exprArity, typeArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv -import GHC.Core.Type ( Type, tidyTopType ) -import GHC.Core.DataCon +import GHC.Core.Type import GHC.Core.TyCon -import GHC.Core.Class +import GHC.Core.TyCo.Tidy import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Iface.Tidy.StaticPtrTable @@ -50,16 +73,17 @@ import GHC.Types.Var.Set import GHC.Types.Var import GHC.Types.Id -import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig ) import GHC.Types.Basic +import GHC.Types.TyThing( implicitTyConThings ) import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache 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 @@ -149,7 +173,8 @@ tcg_insts = insts, tcg_fam_insts = fam_insts, tcg_complete_matches = complete_matches, - tcg_mod = this_mod + tcg_mod = this_mod, + tcg_default_exports = default_exports } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process. @@ -157,6 +182,7 @@ (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ return (ModDetails { md_types = type_env' + , md_defaults = default_exports , md_insts = insts' , md_fam_insts = fam_insts , md_rules = [] @@ -340,7 +366,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) @@ -357,12 +385,14 @@ -- ^ Are rules exposed or not? , opt_static_ptr_opts :: !(Maybe StaticPtrOpts) -- ^ Options for generated static pointers, if enabled (/= Nothing). + , opt_keep_auto_rules :: !Bool } tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails) 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 @@ -373,16 +403,12 @@ , 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 - let implicit_binds = concatMap getImplicitBinds tcs - all_binds = implicit_binds ++ binds - - (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod all_binds imp_rules - let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env + (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod tcs binds imp_rules + let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds @@ -391,6 +417,8 @@ Nothing -> pure ([], Nothing, tidy_binds) Just sopts -> sptCreateStaticBinds sopts mod tidy_binds + -- pprTraceM "trimmed_rules" (ppr trimmed_rules) + let all_foreign_stubs = case mcstub of Nothing -> foreign_stubs Just cstub -> foreign_stubs `appendStubC` cstub @@ -443,13 +471,16 @@ , cg_ccs = S.toList local_ccs , cg_foreign = all_foreign_stubs , cg_foreign_files = foreign_files - , cg_dep_pkgs = dep_direct_pkgs deps - , cg_hpc_info = hpc_info + -- TODO: Check whether we need to account for levels here. + -- It seems that this field just gets used to write a comment + -- in C codegen, so it's value doesn't affect an important result. + , cg_dep_pkgs = S.map snd (dep_direct_pkgs deps) , cg_modBreaks = modBreaks , cg_spt_entries = spt_entries } , 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 @@ -493,7 +524,6 @@ do_binder cs b = maybe cs (go cs) (get_unf b) - -- Unfoldings may have cost centres that in the original definion are -- optimized away, see #5889. get_unf = maybeUnfoldingTemplate . realIdUnfolding @@ -555,80 +585,8 @@ modest cost in interface file growth, which is limited to the bits reqd to describe those data constructors. -************************************************************************ -* * - Implicit bindings -* * -************************************************************************ - -Note [Injecting implicit bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We inject the implicit bindings right at the end, in GHC.Core.Tidy. -Some of these bindings, notably record selectors, are not -constructed in an optimised form. E.g. record selector for - data T = MkT { x :: {-# UNPACK #-} !Int } -Then the unfolding looks like - x = \t. case t of MkT x1 -> let x = I# x1 in x -This generates bad code unless it's first simplified a bit. That is -why GHC.Core.Unfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of -optimisation first. (Only matters when the selector is used curried; -eg map x ys.) See #2070. - -[Oct 09: in fact, record selectors are no longer implicit Ids at all, -because we really do want to optimise them properly. They are treated -much like any other Id. But doing "light" optimisation on an implicit -Id still makes sense.] - -At one time I tried injecting the implicit bindings *early*, at the -beginning of SimplCore. But that gave rise to real difficulty, -because GlobalIds are supposed to have *fixed* IdInfo, but the -simplifier and other core-to-core passes mess with IdInfo all the -time. The straw that broke the camels back was when a class selector -got the wrong arity -- ie the simplifier gave it arity 2, whereas -importing modules were expecting it to have arity 1 (#2844). -It's much safer just to inject them right at the end, after tidying. - -Oh: two other reasons for injecting them late: - - - If implicit Ids are already in the bindings when we start tidying, - we'd have to be careful not to treat them as external Ids (in - the sense of chooseExternalIds); else the Ids mentioned in *their* - RHSs will be treated as external and you get an interface file - saying a18 = - but nothing referring to a18 (because the implicit Id is the - one that does, and implicit Ids don't appear in interface files). - - - More seriously, the tidied type-envt will include the implicit - Id replete with a18 in its unfolding; but we won't take account - of a18 when computing a fingerprint for the class; result chaos. - -There is one sort of implicit binding that is injected still later, -namely those for data constructor workers. Reason (I think): it's -really just a code generation trick.... binding itself makes no sense. -See Note [Data constructor workers] in "GHC.CoreToStg.Prep". -} -getImplicitBinds :: TyCon -> [CoreBind] -getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc - where - cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) - -getTyConImplicitBinds :: TyCon -> [CoreBind] -getTyConImplicitBinds tc - | isDataTyCon tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) - | otherwise = [] - -- The 'otherwise' includes family TyCons of course, but also (less obviously) - -- * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make - -- * type data: we don't want any code for type-only stuff (#24620) - -getClassImplicitBinds :: Class -> [CoreBind] -getClassImplicitBinds cls - = [ NonRec op (mkDictSelRhs cls val_index) - | (op, val_index) <- classAllSelIds cls `zip` [0..] ] - -get_defn :: Id -> CoreBind -get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) - {- ************************************************************************ * * @@ -648,12 +606,13 @@ chooseExternalIds :: TidyOpts -> Module + -> [TyCon] -> [CoreBind] -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds opts mod binds imp_id_rules +chooseExternalIds opts mod tcs binds imp_id_rules = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders ; tidy_internal internal_ids unfold_env1 occ_env1 } @@ -684,17 +643,16 @@ binders = map fst $ flattenBinds binds binder_set = mkVarSet binders - avoids = [getOccName name | bndr <- binders, - let name = idName bndr, - isExternalName name ] + avoids = [ getOccName name | bndr <- binders, + let name = idName bndr, + isExternalName name ] + ++ [ getOccName thing | tc <- tcs + , thing <- implicitTyConThings tc ] -- In computing our "avoids" list, we must include -- all implicit Ids -- all things with global names (assigned once and for -- all by the renamer) -- since their names are "taken". - -- The type environment is a convenient source of such things. - -- In particular, the set of binders doesn't include - -- implicit Ids at this stage. -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl @@ -763,6 +721,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 @@ -770,30 +732,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. +-} + {- ************************************************************************ * * @@ -965,12 +984,18 @@ This stuff is the only reason for the ru_auto field in a Rule. -NB: In #18532 we looked at keeping auto-rules and it turned out to just make -compiler performance worse while increasing code sizes at the same time. The impact -varied. Compiling Cabal got ~3% slower, allocated ~3% more and wrote 15% more code to disk. -Nofib only saw 0.7% more compiler allocations and executable file size growth. But given -there was no difference in runtime for these benchmarks it turned out to be flat out worse. -See the ticket for more details. +We discard auto-rules by default, but keep them if -fkeep-auto-rules is on. + +* Discard by default: in #18532 we looked at keeping auto-rules and it turned out to just make + compiler performance worse while increasing code sizes at the same time. The + impact varied. Compiling Cabal got ~3% slower, allocated ~3% more and wrote 15% + more code to disk. Nofib only saw 0.7% more compiler allocations and executable + file size growth. But given there was no difference in runtime for these + benchmarks it turned out to be flat out worse. See the ticket for more details. + +* Keep with -fkeep-auto-rules: in #21917 we found cases where we get a lot code + duplication when we discard specialisations. Agda is a case in point. Having + a flag gives us control over the rule-trimming decision. -} findExternalRules :: TidyOpts @@ -982,11 +1007,12 @@ findExternalRules opts binds imp_id_rules unfold_env = (trimmed_binds, filter keep_rule all_rules) where - imp_rules | (opt_expose_rules opts) = filter expose_rule imp_id_rules - | otherwise = [] + imp_rules | opt_expose_rules opts = filter expose_rule imp_id_rules + | otherwise = [] imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules - user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet + user_rule_rhs_fvs rule | isAutoRule rule && not (opt_keep_auto_rules opts) + = emptyVarSet | otherwise = ruleRhsFreeVars rule (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds @@ -1047,7 +1073,7 @@ -- In needed_fvs', we don't bother to delete binders from the fv set local_rules = [ rule - | (opt_expose_rules opts) + | opt_expose_rules opts , id <- bndrs , is_external_id id -- Only collect rules for external Ids , rule <- idCoreRules id @@ -1083,11 +1109,9 @@ -- See #19619 let new_local_name = occ' `seq` mkInternalName uniq occ' loc return (occ_env', new_local_name) - -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we externalise the name later, in the code generator - -- - -- Similarly, we must make sure it has a system-wide Unique, because - -- the byte-code generator builds a system-wide Name->BCO symbol table + -- Even local, internal names must get a unique occurrence. + -- This is necessary because the byte-code generator the byte-code + -- generator builds a system-wide Name->BCO symbol table. | local && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc return (occ_env', new_external_name) @@ -1209,7 +1233,9 @@ (bndr1, rhs1) where - Just (name',show_unfold) = lookupVarEnv unfold_env bndr + (name',show_unfold) = case lookupVarEnv unfold_env bndr of + Just stuff -> stuff + Nothing -> pprPanic "tidyTopPair" (ppr bndr) !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs bndr1 = mkGlobalId details name' ty' idinfo' details = idDetails cbv_bndr -- Preserve the IdDetails @@ -1261,7 +1287,7 @@ sig = dmdSigInfo idinfo final_sig | not (isNopSig sig) - = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig + = warnPprTrace (bottom_hidden sig) "tidyTopIdInfo" (ppr name <+> ppr sig) sig -- No demand signature, so try a -- cheap-and-cheerful bottom analyser @@ -1277,7 +1303,7 @@ | otherwise = cpr - _bottom_hidden id_sig + bottom_hidden id_sig = case mb_bot_str of Nothing -> False Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity) @@ -1461,4 +1487,3 @@ exported_con con = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) -} - diff --git a/GHC/Iface/Tidy/StaticPtrTable.hs b/GHC/Iface/Tidy/StaticPtrTable.hs --- a/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/GHC/Iface/Tidy/StaticPtrTable.hs @@ -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 diff --git a/GHC/Iface/Type.hs b/GHC/Iface/Type.hs --- a/GHC/Iface/Type.hs +++ b/GHC/Iface/Type.hs @@ -7,19 +7,14 @@ -} -{-# LANGUAGE FlexibleInstances #-} - -- FlexibleInstances for Binary (DefMethSpec IfaceType) -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} - module GHC.Iface.Type ( - IfExtName, IfLclName, + IfExtName, + IfLclName(..), mkIfLclName, ifLclNameFS, IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), - IfaceMCoercion(..), - IfaceUnivCoProv(..), + IfaceAxiomRule(..),IfaceMCoercion(..), IfaceMult, IfaceTyCon(..), IfaceTyConInfo(..), mkIfaceTyConInfo, @@ -37,6 +32,8 @@ ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, ifTyConBinderVar, ifTyConBinderName, + -- Binary utilities + putIfaceType, getIfaceType, ifaceTypeSharedByte, -- Equality testing isIfaceLiftedTypeKind, @@ -47,6 +44,7 @@ SuppressBndrSig(..), UseBndrParens(..), PrintExplicitKinds(..), + PrintArityInvisibles(..), pprIfaceType, pprParendIfaceType, pprPrecIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, @@ -59,6 +57,7 @@ isIfaceRhoType, suppressIfaceInvisibles, + visibleTypeVarOccurencies, stripIfaceInvisVars, stripInvisArgs, @@ -75,9 +74,10 @@ , tupleTyConName , tupleDataConName , manyDataConTyCon - , liftedRepTyCon, liftedDataConTyCon ) + , liftedRepTyCon, liftedDataConTyCon + , sumTyCon ) import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy, funTyFlagTyCon ) -import GHC.Core.TyCo.Rep( CoSel ) +import GHC.Core.TyCo.Rep( CoSel, UnivCoProvenance(..) ) import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom @@ -93,9 +93,16 @@ import GHC.Utils.Panic import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar ) -import Data.Maybe( isJust ) +import Data.Maybe (isJust) +import Data.Proxy import qualified Data.Semigroup as Semi +import Data.Word (Word8) +import Control.Arrow (first) import Control.DeepSeq +import Control.Monad ((<$!>)) +import Data.List (dropWhileEnd) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set {- ************************************************************************ @@ -105,15 +112,26 @@ ************************************************************************ -} -type IfLclName = FastString -- A local name in iface syntax +-- | A local name in iface syntax +newtype IfLclName = IfLclName + { getIfLclName :: LexicalFastString + } deriving (Eq, Ord, Show) +ifLclNameFS :: IfLclName -> FastString +ifLclNameFS = getLexicalFastString . getIfLclName + +mkIfLclName :: FastString -> IfLclName +mkIfLclName = IfLclName . LexicalFastString + type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax -- (However Internal or System Names never should) data IfaceBndr -- Local (non-top-level) binders = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr + deriving (Eq, Ord) + type IfaceIdBndr = (IfaceType, IfLclName, IfaceType) type IfaceTvBndr = (IfLclName, IfaceKind) @@ -134,7 +152,7 @@ type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy" - = IfaceNoOneShot -- and Note [The oneShot function] in "GHC.Types.Id.Make" + = IfaceNoOneShot -- and Note [oneShot magic] in "GHC.Types.Id.Make" | IfaceOneShot instance Outputable IfaceOneShot where @@ -157,7 +175,7 @@ -- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' -- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" data IfaceType - = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] + = IfaceFreeTyVar TyVar -- See Note [Free TyVars and CoVars in IfaceType] | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceLitTy IfaceTyLit | IfaceAppTy IfaceType IfaceAppArgs @@ -181,7 +199,36 @@ -- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression -- in interface file size (in GHC's boot libraries). -- See !3987. + deriving (Eq, Ord) + -- See Note [Ord instance of IfaceType] +{- +Note [Ord instance of IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need an 'Ord' instance to have a 'Map' keyed by 'IfaceType'. This 'Map' is +required for implementing the deduplication table during interface file +serialisation. +See Note [Deduplication during iface binary serialisation] for the implementation details. + +We experimented with a 'TrieMap' based implementation, but it seems to be +slower than using a straight-forward 'Map IfaceType'. +The experiments loaded the full agda library into a ghci session with the +following scenarios: + +* normal: a plain ghci session. +* cold: a ghci session that uses '-fwrite-if-simplified-core -fforce-recomp', + forcing a cold-cache. +* warm: a subsequent ghci session that uses a warm cache for + '-fwrite-if-simplified-core', e.g. nothing needs to be recompiled. + +The implementation was up to 5% slower in some execution runs. However, on +'lib:Cabal', the performance difference between 'Map IfaceType' and +'TrieMap IfaceType' was negligible. + +We share our implementation of the 'TrieMap' in the ticket #24816, so that +further performance analysis and improvements don't need to start from scratch. +-} + type IfaceMult = IfaceType type IfacePredType = IfaceType @@ -189,9 +236,9 @@ data IfaceTyLit = IfaceNumTyLit Integer - | IfaceStrTyLit FastString + | IfaceStrTyLit LexicalFastString | IfaceCharTyLit Char - deriving (Eq) + deriving (Eq, Ord) type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis type IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag @@ -233,6 +280,7 @@ -- arguments in @{...}. IfaceAppArgs -- The rest of the arguments + deriving (Eq, Ord) instance Semi.Semigroup IfaceAppArgs where IA_Nil <> xs = xs @@ -247,8 +295,19 @@ -- We have to tag them in order to pretty print them -- properly. data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName - , ifaceTyConInfo :: IfaceTyConInfo } - deriving (Eq) + , ifaceTyConInfo :: !IfaceTyConInfo + -- ^ We add a bang to this field as heap analysis + -- showed that this constructor retains a thunk to + -- a value that is usually shared. + -- + -- See !12200 for how this bang saved ~10% residency + -- when loading 'mi_extra_decls' on the agda + -- code base. + -- + -- See Note [Sharing IfaceTyConInfo] for why + -- sharing is so important for 'IfaceTyConInfo'. + } + deriving (Eq, Ord) -- | The various types of TyCons which have special, built-in syntax. data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon @@ -268,7 +327,7 @@ -- that is actually being applied to two types -- of the same kind. This affects pretty-printing -- only: see Note [Equality predicates in IfaceType] - deriving (Eq) + deriving (Eq, Ord) instance Outputable IfaceTyConSort where ppr IfaceNormalTyCon = text "normal" @@ -276,7 +335,7 @@ ppr (IfaceSumTyCon n) = text "sum:" <> ppr n ppr IfaceEqualityTyCon = text "equality" -{- Note [Free tyvars in IfaceType] +{- Note [Free TyVars and CoVars in IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an IfaceType and pretty printing that. This eliminates a lot of @@ -362,18 +421,57 @@ -- should be printed as 'D to distinguish it from -- an existing type constructor D. , ifaceTyConSort :: IfaceTyConSort } - deriving (Eq) + deriving (Eq, Ord) --- This smart constructor allows sharing of the two most common --- cases. See #19194 +-- | This smart constructor allows sharing of the two most common +-- cases. See Note [Sharing IfaceTyConInfo] mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo -mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = IfaceTyConInfo IsPromoted IfaceNormalTyCon -mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon -mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort +mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo +mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo +mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort +{-# NOINLINE promotedNormalTyConInfo #-} +-- | See Note [Sharing IfaceTyConInfo] +promotedNormalTyConInfo :: IfaceTyConInfo +promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon + +{-# NOINLINE notPromotedNormalTyConInfo #-} +-- | See Note [Sharing IfaceTyConInfo] +notPromotedNormalTyConInfo :: IfaceTyConInfo +notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon + +{- +Note [Sharing IfaceTyConInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example. +But almost all of them are + + IfaceTyConInfo IsPromoted IfaceNormalTyCon + IfaceTyConInfo NotPromoted IfaceNormalTyCon. + +The smart constructor `mkIfaceTyConInfo` arranges to share these instances, +thus: + + promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon + notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon + + mkIfaceTyConInfo IsPromoted IfaceNormalTyCon = promotedNormalTyConInfo + mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo + mkIfaceTyConInfo prom sort = IfaceTyConInfo prom sort + +But ALAS, the (nested) CPR transform can lose this sharing, completely +negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326. + +Sticking-plaster solution: add a NOINLINE pragma to those top-level constants. +When we fix the CPR bug we can remove the NOINLINE pragmas. + +This one change leads to an 15% reduction in residency for GHC when embedding +'mi_extra_decls': see !12222. +-} + data IfaceMCoercion = IfaceMRefl - | IfaceMCo IfaceCoercion + | IfaceMCo IfaceCoercion deriving (Eq, Ord) data IfaceCoercion = IfaceReflCo IfaceType @@ -381,14 +479,13 @@ | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceAppCo IfaceCoercion IfaceCoercion - | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceCoercion IfaceCoercion | IfaceCoVarCo IfLclName - | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] - | IfaceAxiomRuleCo IfLclName [IfaceCoercion] - -- There are only a fixed number of CoAxiomRules, so it suffices + | IfaceAxiomCo IfaceAxiomRule [IfaceCoercion] + -- ^ There are only a fixed number of CoAxiomRules, so it suffices -- to use an IfaceLclName to distinguish them. -- See Note [Adding built-in type families] in GHC.Builtin.Types.Literals - | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType + | IfaceUnivCo UnivCoProvenance Role IfaceType IfaceType [IfaceCoercion] | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion | IfaceSelCo CoSel IfaceCoercion @@ -396,14 +493,16 @@ | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion | IfaceSubCo IfaceCoercion - | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] + | IfaceFreeCoVar CoVar -- ^ See Note [Free TyVars and CoVars in IfaceType] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] + deriving (Eq, Ord) + -- Why Ord? See Note [Ord instance of IfaceType] -data IfaceUnivCoProv - = IfacePhantomProv IfaceCoercion - | IfaceProofIrrelProv IfaceCoercion - | IfacePluginProv String - | IfaceCorePrepProv Bool -- See defn of CorePrepProv +data IfaceAxiomRule + = IfaceAR_X IfLclName -- Built-in + | IfaceAR_B IfExtName BranchIndex -- Branched + | IfaceAR_U IfExtName -- Unbranched + deriving (Eq, Ord) {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -515,9 +614,21 @@ = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } splitIfaceReqForallTy rho = ([], rho) -suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a] -suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs -suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs +newtype PrintArityInvisibles = MkPrintArityInvisibles Bool + +-- See Note [Print invisible binders in interface declarations] +-- for the definition of what binders are considered insignificant +suppressIfaceInvisibles :: PrintArityInvisibles + -> PrintExplicitKinds + -> Set.Set IfLclName + -> [IfaceTyConBinder] + -> [a] + -> [a] +suppressIfaceInvisibles _ (PrintExplicitKinds True) _ _tys xs = xs + +suppressIfaceInvisibles -- This case is semantically the same as the third case, but it should be way f + (MkPrintArityInvisibles False) (PrintExplicitKinds False) mentioned_vars tys xs + | Set.null mentioned_vars = suppress tys xs where suppress _ [] = [] suppress [] a = a @@ -525,6 +636,44 @@ | isInvisibleTyConBinder k = suppress ks xs | otherwise = x : suppress ks xs +suppressIfaceInvisibles + (MkPrintArityInvisibles arity_invisibles) + (PrintExplicitKinds False) mentioned_vars tys xs + = map snd (suppress (zip tys xs)) + where + -- Consider this example: + -- type T :: forall k1 k2. Type + -- type T @a @b = b + -- `@a` is not mentioned on the RHS. However, we can't just + -- drop it because implicit argument positioning matters. + -- + -- Hence just drop the end + only_mentioned_binders = dropWhileEnd (not . is_binder_mentioned) + + is_binder_mentioned (bndr, _) = ifTyConBinderName bndr `Set.member` mentioned_vars + + suppress_invisibles group = + applyWhen invis_group only_mentioned_binders bndrs + where + bndrs = NonEmpty.toList group + invis_group = is_invisible_bndr (NonEmpty.head group) + + suppress_invisible_groups [] = [] + suppress_invisible_groups [group] = + if arity_invisibles + then NonEmpty.toList group -- the last group affects arity + else suppress_invisibles group + suppress_invisible_groups (group : groups) + = suppress_invisibles group ++ suppress_invisible_groups groups + + suppress + = suppress_invisible_groups -- Filter out insignificant invisible binders + . NonEmpty.groupWith is_invisible_bndr -- Find chunks of @-binders + . filterOut is_inferred_bndr -- We don't want to display @{binders} + + is_inferred_bndr = isInferredTyConBinder . fst + is_invisible_bndr = isInvisibleTyConBinder . fst + stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder] -> [IfaceTyConBinder] stripIfaceInvisVars (PrintExplicitKinds True) tyvars = tyvars stripIfaceInvisVars (PrintExplicitKinds False) tyvars @@ -565,6 +714,29 @@ go_args IA_Nil = True go_args (IA_Arg arg _ args) = go arg && go_args args +visibleTypeVarOccurencies :: IfaceType -> Set.Set IfLclName +-- Returns True if the type contains this name. Doesn't count +-- invisible application +-- Just used to control pretty printing +visibleTypeVarOccurencies = go + where + (<>) = Set.union + + go (IfaceTyVar var) = Set.singleton var + go (IfaceFreeTyVar {}) = mempty + go (IfaceAppTy fun args) = go fun <> go_args args + go (IfaceFunTy _ w arg res) = go w <> go arg <> go res + go (IfaceForAllTy bndr ty) = go (ifaceBndrType $ binderVar bndr) <> go ty + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = mempty + go (IfaceCastTy {}) = mempty -- Safe + go (IfaceCoercionTy {}) = mempty -- Safe + + go_args IA_Nil = mempty + go_args (IA_Arg arg Required args) = go arg <> go_args args + go_args (IA_Arg _arg _ args) = go_args args + {- Note [Substitution on IfaceType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Substitutions on IfaceType are done only during pretty-printing to @@ -575,11 +747,11 @@ mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst -- See Note [Substitution on IfaceType] -mkIfaceTySubst eq_spec = mkFsEnv eq_spec +mkIfaceTySubst eq_spec = mkFsEnv (map (first ifLclNameFS) eq_spec) inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool -- See Note [Substitution on IfaceType] -inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) +inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst (ifLclNameFS fs)) substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType -- See Note [Substitution on IfaceType] @@ -609,8 +781,7 @@ go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv go_co (IfaceHoleCo cv) = IfaceHoleCo cv - go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) - go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) + go_co (IfaceUnivCo p r t1 t2 ds) = IfaceUnivCo p r (go t1) (go t2) (go_cos ds) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) go_co (IfaceSelCo n co) = IfaceSelCo n (go_co co) @@ -618,15 +789,10 @@ go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) go_co (IfaceKindCo co) = IfaceKindCo (go_co co) go_co (IfaceSubCo co) = IfaceSubCo (go_co co) - go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) + go_co (IfaceAxiomCo n cos) = IfaceAxiomCo n (go_cos cos) go_cos = map go_co - go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) - go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) - go_prov co@(IfacePluginProv _) = co - go_prov co@(IfaceCorePrepProv _) = co - substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args = go args @@ -636,7 +802,7 @@ substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType substIfaceTyVar env tv - | Just ty <- lookupFsEnv env tv = ty + | Just ty <- lookupFsEnv env (ifLclNameFS tv) = ty | otherwise = IfaceTyVar tv @@ -682,6 +848,12 @@ | isVisibleForAllTyFlag argf = go (n+1) rest | otherwise = go n rest +ifaceAppArgsLength :: IfaceAppArgs -> Int +ifaceAppArgsLength = go 0 + where + go !n IA_Nil = n + go !n (IA_Arg _ _ ts) = go (n + 1) ts + {- Note [Suppressing invisible arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -849,7 +1021,7 @@ Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) `CONSTRAINT 'LiftedRep` as `Constraint` - `FUN 'Many` as `(->)`. + `FUN 'Many` as `(->)` This way, error messages don't refer to representation polymorphism or linearity if it is not necessary. Normally we'd would represent these types using their synonyms (see GHC.Core.Type @@ -972,9 +1144,9 @@ | not (isIfaceRhoType ty) = ppr_sigma ShowForAllMust ctxt_prec ty ppr_ty _ (IfaceForAllTy {}) = panic "ppr_ty" -- Covered by not.isIfaceRhoType ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! -ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free tyvars in IfaceType] +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType] ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys -ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated +ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n -- Function types @@ -1137,9 +1309,9 @@ -> IfaceType go subs True (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) | isInvisibleForAllTyFlag argf -- Don't default *visible* quantification - -- or we get the mess in #13963 + -- or we get the mess in #13963 , Just substituted_ty <- check_substitution var_kind - = let subs' = extendFsEnv subs var substituted_ty + = let subs' = extendFsEnv subs (ifLclNameFS var) substituted_ty -- Record that we should replace it with LiftedRep/Lifted/Many, -- and recurse, discarding the forall in go subs' True ty @@ -1147,7 +1319,7 @@ go subs rank1 (IfaceForAllTy bndr ty) = IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty) - go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of + go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of Just s -> s Nothing -> ty @@ -1282,7 +1454,8 @@ pprIfaceForAllPartMust tvs ctxt sdoc = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] + -> SDoc -> SDoc pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs, sdoc ] @@ -1321,11 +1494,11 @@ | otherwise = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCo [] = empty pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc @@ -1340,9 +1513,15 @@ -- See Note [Suppressing binder signatures] suppress_sig = SuppressBndrSig False -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc -pprIfaceForAllCoBndr (tv, kind_co) - = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co, visL, visR) + = parens (ppr tv <> pp_vis <+> dcolon <+> pprIfaceCoercion kind_co) + where + pp_vis | visL == coreTyLamForAllTyFlag + , visR == coreTyLamForAllTyFlag + = empty + | otherwise + = ppr visL <> char '~' <> ppr visR -- "[spec]~[reqd]" -- | Show forall flag -- @@ -1361,21 +1540,18 @@ newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) data ShowHowMuch - = ShowHeader AltPpr -- ^Header information only, not rhs - | ShowSome [OccName] AltPpr - -- ^ Show only some sub-components. Specifically, - -- - -- [@\[\]@] Print all sub-components. - -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; - -- elide other sub-components to @...@ - -- May 14: the list is max 1 element long at the moment + = ShowHeader AltPpr -- ^ Header information only, not rhs + | ShowSome (Maybe (OccName -> Bool)) AltPpr + -- ^ Show the declaration and its RHS. The @Maybe@ predicate + -- allows filtering of the sub-components which should be printing; + -- any sub-components filtered out will be elided with @...@. | ShowIface - -- ^Everything including GHC-internal information (used in --show-iface) + -- ^ Everything including GHC-internal information (used in --show-iface) instance Outputable ShowHowMuch where - ppr (ShowHeader _) = text "ShowHeader" - ppr ShowIface = text "ShowIface" - ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs + ppr (ShowHeader _) = text "ShowHeader" + ppr ShowIface = text "ShowIface" + ppr (ShowSome _ _) = text "ShowSome" pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty @@ -1571,19 +1747,19 @@ , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) Required (IA_Arg ty Required IA_Nil) <- tys -> maybeParen ctxt_prec funPrec - $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty + $ char '?' <> ftext (getLexicalFastString n) <> dcolon <> ppr_ty topPrec ty | IfaceTupleTyCon arity sort <- ifaceTyConSort info , not debug , arity == ifaceVisAppArgsLength tys - -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys - -- NB: pprTuple requires a saturated tuple. + -> ppr_tuple ctxt_prec sort (ifaceTyConIsPromoted info) tys + -- NB: ppr_tuple requires a saturated tuple. | IfaceSumTyCon arity <- ifaceTyConSort info , not debug , arity == ifaceVisAppArgsLength tys - -> pprSum (ifaceTyConIsPromoted info) tys - -- NB: pprSum requires a saturated unboxed sum. + -> ppr_sum ctxt_prec (ifaceTyConIsPromoted info) tys + -- NB: ppr_sum requires a saturated unboxed sum. | tc `ifaceTyConHasKey` consDataConKey , False <- print_kinds @@ -1740,81 +1916,116 @@ | tc `ifaceTyConHasKey` liftedTypeKindTyConKey -> ppr_kind_type ctxt_prec - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - -> pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + | isSymOcc (nameOccName (ifaceTyConName tc)) - | [ ty1@(_, Required), ty2@(_, Required) ] <- tys + , [ ty1@(_, Required), ty2@(_, Required) ] <- tys -- Infix, two visible arguments (we know nothing of precedence though). -- Don't apply this special case if one of the arguments is invisible, -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). - -> pprIfaceInfixApp ctxt_prec (ppr tc) (pp opPrec ty1) (pp opPrec ty2) + -> pprIfaceInfixApp ctxt_prec (pprIfaceTyCon tc) (pp opPrec ty1) (pp opPrec ty2) | otherwise - -> pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + -> pprIfacePrefixApp ctxt_prec (pprParendIfaceTyCon tc) (map (pp appPrec) tys) --- | Pretty-print an unboxed sum type. The sum should be saturated: --- as many visible arguments as the arity of the sum. --- --- NB: this always strips off the invisible 'RuntimeRep' arguments, --- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. -pprSum :: PromotionFlag -> IfaceAppArgs -> SDoc -pprSum is_promoted args - = -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - let tys = appArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - in pprPromotionQuoteI is_promoted - <> sumParens (pprWithBars (ppr_ty topPrec) args') +data TupleOrSum = IsSum | IsTuple TupleSort + deriving (Eq) --- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple). --- The tuple should be saturated: as many visible arguments as the arity of --- the tuple. +-- | Pretty-print a boxed tuple datacon in regular tuple syntax. +-- Used when -XListTuplePuns is disabled. +ppr_tuple_no_pun :: PprPrec -> [IfaceType] -> SDoc +ppr_tuple_no_pun ctxt_prec = \case + [t] -> maybeParen ctxt_prec appPrec (text "MkSolo" <+> pprPrecIfaceType appPrec t) + tys -> tupleParens BoxedTuple (pprWithCommas pprIfaceType tys) + +-- | Pretty-print an unboxed tuple or sum type in its parenthesized, punned, form. +-- Used when -XListTuplePuns is enabled. -- +-- The tycon should be saturated: +-- as many visible arguments as the arity of the sum or tuple. +-- -- NB: this always strips off the invisible 'RuntimeRep' arguments, -- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`. -pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc -pprTuple ctxt_prec sort promoted args = - case promoted of - IsPromoted - -> let tys = appArgsIfaceTypes args - args' = drop (length tys `div` 2) tys - in ppr_tuple_app args' $ - pprPromotionQuoteI IsPromoted <> - tupleParens sort (spaceIfSingleQuote (pprWithCommas pprIfaceType args')) +ppr_tuple_sum_pun :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceType -> Arity -> [IfaceType] -> SDoc +ppr_tuple_sum_pun ctxt_prec sort promoted tc arity tys + | IsSum <- sort + = sumParens (pprWithBars (ppr_ty topPrec) tys) - NotPromoted - | ConstraintTuple <- sort - , IA_Nil <- args - -> maybeParen ctxt_prec sigPrec $ - text "() :: Constraint" + | IsTuple ConstraintTuple <- sort + , NotPromoted <- promoted + , arity == 0 + = maybeParen ctxt_prec sigPrec $ + text "() :: Constraint" - | otherwise - -> -- drop the RuntimeRep vars. - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - let tys = appArgsIfaceTypes args - args' = case sort of - UnboxedTuple -> drop (length tys `div` 2) tys - _ -> tys - in - ppr_tuple_app args' $ - pprPromotionQuoteI promoted <> - tupleParens sort (pprWithCommas pprIfaceType args') + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Solo x`, not `(x)` + | IsTuple BoxedTuple <- sort + , arity == 1 + = pprPrecIfaceType ctxt_prec tc + + | IsTuple tupleSort <- sort + = pprPromotionQuoteI promoted <> + tupleParens tupleSort (quote_space (pprWithCommas pprIfaceType tys)) where - ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc - ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens - -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Solo x`, not `(x)` - | [_] <- args_wo_runtime_reps - , BoxedTuple <- sort - = let solo_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon - tupleName = case promoted of - IsPromoted -> tupleDataConName (tupleSortBoxity sort) - NotPromoted -> tupleTyConName sort - solo_tc = IfaceTyCon (tupleName 1) solo_tc_info in - pprPrecIfaceType ctxt_prec $ IfaceTyConApp solo_tc args + quote_space = case promoted of + IsPromoted -> spaceIfSingleQuote + NotPromoted -> id + +-- | Pretty-print an unboxed tuple or sum type either in the punned or unpunned form, +-- depending on whether -XListTuplePuns is enabled. +ppr_tuple_sum :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceAppArgs -> SDoc +ppr_tuple_sum ctxt_prec sort is_promoted args = + sdocOption sdocListTuplePuns $ \case + True -> ppr_tuple_sum_pun ctxt_prec sort is_promoted prefix_tc arity non_rep_tys + False + | IsPromoted <- is_promoted + , IsTuple BoxedTuple <- sort + -> ppr_tuple_no_pun ctxt_prec non_rep_tys | otherwise - = ppr_args_w_parens + -> pprPrecIfaceType ctxt_prec prefix_tc + where + -- This tycon is used to print in prefix notation for the punned Solo + -- case and the unabbreviated case. + prefix_tc = IfaceTyConApp (IfaceTyCon (mk_name arity) info) args + info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon + + mk_name = case (sort, is_promoted) of + (IsTuple BoxedTuple, IsPromoted) -> tupleDataConName Boxed + (IsTuple s, _) -> tupleTyConName s + (IsSum, _) -> tyConName . sumTyCon + + -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + non_rep_tys = if strip_reps then drop arity all_tys else all_tys + + arity = if strip_reps then count `div` 2 else count + + count = length all_tys + + all_tys = appArgsIfaceTypes args + + strip_reps = case is_promoted of + IsPromoted -> True + NotPromoted -> strip_reps_sort + + strip_reps_sort = case sort of + IsTuple BoxedTuple -> False + IsTuple UnboxedTuple -> True + IsTuple ConstraintTuple -> False + IsSum -> True + +-- | Pretty-print an unboxed sum type. +-- The sum should be saturated: as many visible arguments as the arity of +-- the sum. +ppr_sum :: PprPrec -> PromotionFlag -> IfaceAppArgs -> SDoc +ppr_sum ctxt_prec = ppr_tuple_sum ctxt_prec IsSum + +-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple). +-- The tuple should be saturated: as many visible arguments as the arity of +-- the tuple. +ppr_tuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc +ppr_tuple ctxt_prec sort = ppr_tuple_sum ctxt_prec (IsTuple sort) + pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n) @@ -1853,36 +2064,35 @@ ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo {}) = maybeParen ctxt_prec funPrec $ + -- FIXME: collect and pretty-print visibility info? pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) where (tvs, inner_co) = split_co co - split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') - split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co') - = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co (IfaceForAllCo (IfaceTvBndr (name, _)) visL visR kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'') + split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) visL visR kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'') split_co co' = ([], co') --- Why these three? See Note [Free tyvars in IfaceType] +-- Why these three? See Note [Free TyVars and CoVars in IfaceType] ppr_co _ (IfaceFreeCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) -ppr_co _ (IfaceUnivCo prov role ty1 ty2) +ppr_co _ (IfaceUnivCo prov role ty1 ty2 ds) = text "Univ" <> (parens $ - sep [ ppr role <+> pprIfaceUnivCoProv prov + sep [ ppr role <+> ppr prov <> ppr ds , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) ppr_co ctxt_prec (IfaceInstCo co ty) = maybeParen ctxt_prec appPrec $ - text "Inst" <+> pprParendIfaceCoercion co - <+> pprParendIfaceCoercion ty - -ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) - = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) + text "Inst" <+> sep [ pprParendIfaceCoercion co + , pprParendIfaceCoercion ty ] -ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) - = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos +ppr_co ctxt_prec (IfaceAxiomCo ax cos) + | null cos = pprIfAxRule ax -- Don't add parens + | otherwise = ppr_special_co ctxt_prec (pprIfAxRule ax) cos ppr_co ctxt_prec (IfaceSymCo co) = ppr_special_co ctxt_prec (text "Sym") [co] ppr_co ctxt_prec (IfaceTransCo co1 co2) @@ -1905,6 +2115,11 @@ = maybeParen ctxt_prec appPrec (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) +pprIfAxRule :: IfaceAxiomRule -> SDoc +pprIfAxRule (IfaceAR_X n) = ppr n +pprIfAxRule (IfaceAR_U n) = ppr n +pprIfAxRule (IfaceAR_B n i) = ppr n <> brackets (int i) + ppr_role :: Role -> SDoc ppr_role r = underscore <> pp_role where pp_role = case r of @@ -1912,21 +2127,24 @@ Representational -> char 'R' Phantom -> char 'P' ------------------- -pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc -pprIfaceUnivCoProv (IfacePhantomProv co) - = text "phantom" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfaceProofIrrelProv co) - = text "irrel" <+> pprParendIfaceCoercion co -pprIfaceUnivCoProv (IfacePluginProv s) - = text "plugin" <+> doubleQuotes (text s) -pprIfaceUnivCoProv (IfaceCorePrepProv _) - = text "CorePrep" - ------------------- +instance Outputable IfLclName where + ppr = ppr . ifLclNameFS + instance Outputable IfaceTyCon where - ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + ppr = pprIfaceTyCon +-- | Print an `IfaceTyCon` with a promotion tick if needed, without parens, +-- suitable for use in infix contexts +pprIfaceTyCon :: IfaceTyCon -> SDoc +pprIfaceTyCon tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +-- | Print an `IfaceTyCon` with a promotion tick if needed, possibly with parens, +-- suitable for use in prefix contexts +pprParendIfaceTyCon :: IfaceTyCon -> SDoc +pprParendIfaceTyCon tc = pprPromotionQuote tc <> pprPrefixVar (isSymOcc (nameOccName tc_name)) (ppr tc_name) + where tc_name = ifaceTyConName tc + instance Outputable IfaceTyConInfo where ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom , ifaceTyConSort = sort }) @@ -1954,11 +2172,12 @@ ppr = pprIfaceCoercion instance Binary IfaceTyCon where - put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i - get bh = do n <- get bh - i <- get bh - return (IfaceTyCon n i) + get bh = do + n <- get bh + i <- get bh + return (IfaceTyCon n i) instance Binary IfaceTyConSort where put_ bh IfaceNormalTyCon = putByte bh 0 @@ -1977,7 +2196,13 @@ instance Binary IfaceTyConInfo where put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s - get bh = mkIfaceTyConInfo <$> get bh <*> get bh + get bh = mkIfaceTyConInfo <$!> get bh <*> get bh + -- We want to make sure, when reading from disk, as the most common case + -- is supposed to be shared. Any thunk adds an additional indirection + -- making sharing less useful. + -- + -- See !12200 for how this bang and the one in 'IfaceTyCon' reduces the + -- residency by ~10% when loading 'mi_extra_decls' from disk. instance Outputable IfaceTyLit where ppr = pprIfaceTyLit @@ -1999,21 +2224,27 @@ _ -> panic ("get IfaceTyLit " ++ show tag) instance Binary IfaceAppArgs where - put_ bh tk = - case tk of - IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts - IA_Nil -> putByte bh 1 + put_ bh tk = do + -- Int is variable length encoded so only + -- one byte for small lists. + put_ bh (ifaceAppArgsLength tk) + go tk + where + go IA_Nil = pure () + go (IA_Arg a b t) = do + put_ bh a + put_ bh b + go t - get bh = - do c <- getByte bh - case c of - 0 -> do - t <- get bh - a <- get bh - ts <- get bh - return $! IA_Arg t a ts - 1 -> return IA_Nil - _ -> panic ("get IfaceAppArgs " ++ show c) + get bh = do + n <- get bh :: IO Int + go n + where + go 0 = return IA_Nil + go c = do + a <- get bh + b <- get bh + IA_Arg a b <$> go (c - 1) ------------------- @@ -2068,38 +2299,80 @@ ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where - put_ _ (IfaceFreeTyVar tv) - = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) + put_ bh ty = + case findUserDataWriter Proxy bh of + tbl -> putEntry tbl bh ty - put_ bh (IfaceForAllTy aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (IfaceAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (IfaceFunTy af aw ag ah) = do - putByte bh 3 - put_ bh af - put_ bh aw - put_ bh ag - put_ bh ah - put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 5; put_ bh tc; put_ bh tys } - put_ bh (IfaceCastTy a b) - = do { putByte bh 6; put_ bh a; put_ bh b } - put_ bh (IfaceCoercionTy a) - = do { putByte bh 7; put_ bh a } - put_ bh (IfaceTupleTy s i tys) - = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } - put_ bh (IfaceLitTy n) - = do { putByte bh 9; put_ bh n } + get bh = getIfaceTypeShared bh - get bh = do +-- | This is the byte tag we expect to read when the next +-- value is not an 'IfaceType' value, but an offset into a +-- lookup table. +-- See Note [Deduplication during iface binary serialisation]. +-- +-- Must not overlap with any byte tag in 'getIfaceType'. +ifaceTypeSharedByte :: Word8 +ifaceTypeSharedByte = 99 + +-- | Like 'getIfaceType' but checks for a specific byte tag +-- that indicates that we won't be able to read a 'IfaceType' value +-- but rather an offset into a lookup table. Consequentially, +-- we look up the value for the 'IfaceType' in the look up table. +-- +-- See Note [Deduplication during iface binary serialisation] +-- for details. +getIfaceTypeShared :: ReadBinHandle -> IO IfaceType +getIfaceTypeShared bh = do + start <- tellBinReader bh + tag <- getByte bh + if ifaceTypeSharedByte == tag + then case findUserDataReader Proxy bh of + tbl -> getEntry tbl bh + else seekBinReader bh start >> getIfaceType bh + +-- | Serialises an 'IfaceType' to the given 'WriteBinHandle'. +-- +-- Serialising inner 'IfaceType''s uses the 'Binary.put' of 'IfaceType' which may be using +-- a deduplication table. See Note [Deduplication during iface binary serialisation]. +putIfaceType :: WriteBinHandle -> IfaceType -> IO () +putIfaceType _ (IfaceFreeTyVar tv) + = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) + -- See Note [Free TyVars and CoVars in IfaceType] + +putIfaceType bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab +putIfaceType bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad +putIfaceType bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af +putIfaceType bh (IfaceFunTy af aw ag ah) = do + putByte bh 3 + put_ bh af + put_ bh aw + put_ bh ag + put_ bh ah +putIfaceType bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } +putIfaceType bh (IfaceCastTy a b) + = do { putByte bh 6; put_ bh a; put_ bh b } +putIfaceType bh (IfaceCoercionTy a) + = do { putByte bh 7; put_ bh a } +putIfaceType bh (IfaceTupleTy s i tys) + = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } +putIfaceType bh (IfaceLitTy n) + = do { putByte bh 9; put_ bh n } + +-- | Deserialises an 'IfaceType' from the given 'ReadBinHandle'. +-- +-- Reading inner 'IfaceType''s uses the 'Binary.get' of 'IfaceType' which may be using +-- a deduplication table. See Note [Deduplication during iface binary serialisation]. +getIfaceType :: HasCallStack => ReadBinHandle -> IO IfaceType +getIfaceType bh = do h <- getByte bh case h of 0 -> do aa <- get bh @@ -2127,6 +2400,13 @@ _ -> do n <- get bh return (IfaceLitTy n) +instance Binary IfLclName where + put_ bh = put_ bh . ifLclNameFS + + get bh = do + fs <- get bh + pure $ IfLclName $ LexicalFastString fs + instance Binary IfaceMCoercion where put_ bh IfaceMRefl = putByte bh 1 @@ -2166,25 +2446,23 @@ putByte bh 5 put_ bh a put_ bh b - put_ bh (IfaceForAllCo a b c) = do + put_ bh (IfaceForAllCo a visL visR b c) = do putByte bh 6 put_ bh a + put_ bh visL + put_ bh visR put_ bh b put_ bh c put_ bh (IfaceCoVarCo a) = do putByte bh 7 put_ bh a - put_ bh (IfaceAxiomInstCo a b c) = do - putByte bh 8 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceUnivCo a b c d) = do + put_ bh (IfaceUnivCo a b c d deps) = do putByte bh 9 put_ bh a put_ bh b put_ bh c put_ bh d + put_ bh deps put_ bh (IfaceSymCo a) = do putByte bh 10 put_ bh a @@ -2210,15 +2488,16 @@ put_ bh (IfaceSubCo a) = do putByte bh 16 put_ bh a - put_ bh (IfaceAxiomRuleCo a b) = do + put_ bh (IfaceAxiomCo a b) = do putByte bh 17 put_ bh a put_ bh b put_ _ (IfaceFreeCoVar cv) = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) + -- See Note [Free TyVars and CoVars in IfaceType] put_ _ (IfaceHoleCo cv) = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) - -- See Note [Holes in IfaceCoercion] + -- See Note [Holes in IfaceCoercion] get bh = do tag <- getByte bh @@ -2242,20 +2521,19 @@ b <- get bh return $ IfaceAppCo a b 6 -> do a <- get bh + visL <- get bh + visR <- get bh b <- get bh c <- get bh - return $ IfaceForAllCo a b c + return $ IfaceForAllCo a visL visR b c 7 -> do a <- get bh return $ IfaceCoVarCo a - 8 -> do a <- get bh - b <- get bh - c <- get bh - return $ IfaceAxiomInstCo a b c 9 -> do a <- get bh b <- get bh c <- get bh d <- get bh - return $ IfaceUnivCo a b c d + deps <- get bh + return $ IfaceUnivCo a b c d deps 10-> do a <- get bh return $ IfaceSymCo a 11-> do a <- get bh @@ -2276,36 +2554,19 @@ return $ IfaceSubCo a 17-> do a <- get bh b <- get bh - return $ IfaceAxiomRuleCo a b + return $ IfaceAxiomCo a b _ -> panic ("get IfaceCoercion " ++ show tag) -instance Binary IfaceUnivCoProv where - put_ bh (IfacePhantomProv a) = do - putByte bh 1 - put_ bh a - put_ bh (IfaceProofIrrelProv a) = do - putByte bh 2 - put_ bh a - put_ bh (IfacePluginProv a) = do - putByte bh 3 - put_ bh a - put_ bh (IfaceCorePrepProv a) = do - putByte bh 4 - put_ bh a - - get bh = do - tag <- getByte bh - case tag of - 1 -> do a <- get bh - return $ IfacePhantomProv a - 2 -> do a <- get bh - return $ IfaceProofIrrelProv a - 3 -> do a <- get bh - return $ IfacePluginProv a - 4 -> do a <- get bh - return (IfaceCorePrepProv a) - _ -> panic ("get IfaceUnivCoProv " ++ show tag) +instance Binary IfaceAxiomRule where + put_ bh (IfaceAR_X n) = putByte bh 0 >> put_ bh n + put_ bh (IfaceAR_U n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceAR_B n i) = putByte bh 2 >> put_ bh n >> put_ bh i + get bh = do h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceAR_X n) } + 1 -> do { n <- get bh; return (IfaceAR_U n) } + _ -> do { n <- get bh; i <- get bh; return (IfaceAR_B n i) } instance Binary (DefMethSpec IfaceType) where put_ bh VanillaDM = putByte bh 0 @@ -2316,18 +2577,23 @@ 0 -> return VanillaDM _ -> do { t <- get bh; return (GenericDM t) } +instance NFData (DefMethSpec IfaceType) where + rnf = \case + VanillaDM -> () + GenericDM t -> rnf t + instance NFData IfaceType where rnf = \case IfaceFreeTyVar f1 -> f1 `seq` () IfaceTyVar f1 -> rnf f1 IfaceLitTy f1 -> rnf f1 IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 - IfaceFunTy f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 - IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 + IfaceFunTy f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + IfaceForAllTy f1 f2 -> rnf f1 `seq` rnf f2 IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 IfaceCoercionTy f1 -> rnf f1 - IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3 + IfaceTupleTy f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 instance NFData IfaceTyLit where rnf = \case @@ -2338,43 +2604,54 @@ instance NFData IfaceCoercion where rnf = \case IfaceReflCo f1 -> rnf f1 - IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 - IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 - IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 IfaceCoVarCo f1 -> rnf f1 - IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 - IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 + IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps IfaceSymCo f1 -> rnf f1 IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceSelCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceLRCo f1 f2 -> f1 `seq` rnf f2 + IfaceLRCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceKindCo f1 -> rnf f1 IfaceSubCo f1 -> rnf f1 + -- These are not deeply forced because they are not used in ModIface, + -- these constructors are for pretty-printing. + -- See Note [Free TyVars and CoVars in IfaceType] + -- See Note [Holes in IfaceCoercion] IfaceFreeCoVar f1 -> f1 `seq` () IfaceHoleCo f1 -> f1 `seq` () -instance NFData IfaceUnivCoProv where - rnf x = seq x () +instance NFData IfaceAxiomRule where + rnf = \case + IfaceAR_X n -> rnf n + IfaceAR_U n -> rnf n + IfaceAR_B n i -> rnf n `seq` rnf i instance NFData IfaceMCoercion where - rnf x = seq x () + rnf IfaceMRefl = () + rnf (IfaceMCo c) = rnf c instance NFData IfaceOneShot where - rnf x = seq x () + rnf IfaceOneShot = () + rnf IfaceNoOneShot = () instance NFData IfaceTyConSort where rnf = \case IfaceNormalTyCon -> () - IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` () + IfaceTupleTyCon arity sort -> rnf arity `seq` rnf sort `seq` () IfaceSumTyCon arity -> rnf arity IfaceEqualityTyCon -> () +instance NFData IfLclName where + rnf (IfLclName lfs) = rnf lfs + instance NFData IfaceTyConInfo where - rnf (IfaceTyConInfo f s) = f `seq` rnf s + rnf (IfaceTyConInfo f s) = rnf f `seq` rnf s instance NFData IfaceTyCon where rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info @@ -2387,4 +2664,4 @@ instance NFData IfaceAppArgs where rnf = \case IA_Nil -> () - IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 + IA_Arg f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 diff --git a/GHC/Iface/Type.hs-boot b/GHC/Iface/Type.hs-boot --- a/GHC/Iface/Type.hs-boot +++ b/GHC/Iface/Type.hs-boot @@ -6,7 +6,7 @@ where -- Empty import to influence the compilation ordering. --- See Note [Depend on GHC.Num.Integer] in GHC.Base +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base import GHC.Base () data IfaceAppArgs diff --git a/GHC/Iface/Warnings.hs b/GHC/Iface/Warnings.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Warnings.hs @@ -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 + diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs --- a/GHC/IfaceToCore.hs +++ b/GHC/IfaceToCore.hs @@ -13,6 +13,7 @@ {-# LANGUAGE RecursiveDo #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} @@ -20,6 +21,7 @@ tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, typecheckWholeCoreBindings, + tcIfaceDefaults, typecheckIfacesForMerging, typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceDecls, @@ -28,9 +30,11 @@ tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal, tcIfaceOneShot, tcTopIfaceBindings, + tcIfaceImport, hydrateCgBreakInfo ) where + import GHC.Prelude import GHC.ByteCode.Types @@ -42,7 +46,6 @@ import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Builtin.Types -import GHC.Iface.Decl (toIfaceBooleanFormula) import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env @@ -54,6 +57,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 @@ -71,23 +75,23 @@ import GHC.Core.Lint import GHC.Core.Make import GHC.Core.Class +import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.Ppr -import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo +import qualified GHC.Unit.Home.Graph as HUG import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger @@ -102,6 +106,7 @@ import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Types.CompleteMatch import GHC.Types.SrcLoc +import GHC.Types.Avail import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Unique.DSet ( mkUniqDSet ) @@ -112,7 +117,9 @@ import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Name +import GHC.Types.Name.Set import GHC.Types.Name.Env +import GHC.Types.DefaultEnv ( ClassDefaults(..), DefaultEnv, mkDefaultEnv, DefaultProvenance(..) ) import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Id.Info @@ -120,18 +127,25 @@ import GHC.Types.TyThing import GHC.Types.Error +import GHC.Parser.Annotation (noLocA) + +import GHC.Hs.Extension ( GhcRn ) + import GHC.Fingerprint -import qualified GHC.Data.BooleanFormula as BF import Control.Monad -import GHC.Parser.Annotation import GHC.Driver.Env.KnotVars import GHC.Unit.Module.WholeCoreBindings import Data.IORef import Data.Foldable +import Data.List(nub) import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) import GHC.Iface.Errors.Types +import Language.Haskell.Syntax.BooleanFormula (BooleanFormula) +import Language.Haskell.Syntax.BooleanFormula qualified as BF(BooleanFormula(..)) +import Language.Haskell.Syntax.Extension (NoExtField (NoExtField)) + {- This module takes @@ -205,7 +219,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 +235,7 @@ ; let type_env = mkNameEnv names_w_things -- Now do those rules, instances and annotations + ; defaults <- tcIfaceDefaults 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 +254,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 = defaults , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules @@ -248,9 +265,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 {- @@ -287,14 +304,38 @@ plusNameEnv_C mergeIfaceClassOp (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) + in d1 { ifBody = (ifBody d1) { ifSigs = ops, - ifMinDef = toIfaceBooleanFormula . BF.mkOr . map (noLocA . fromIfaceBooleanFormula) $ [bf1, bf2] + ifMinDef = mkOr [ bf1, bf2] } } `withRolesFrom` d2 -- It doesn't matter; we'll check for consistency later when -- we merge, see 'mergeSignatures' | otherwise = d1 `withRolesFrom` d2 + where + -- The reason we need to duplicate mkOr here, instead of + -- using BooleanFormula's mkOr and just doing the loop like: + -- `toIfaceBooleanFormula . mkOr . fromIfaceBooleanFormula` + -- is quite subtle. Say we have the following minimal pragma: + -- {-# MINIMAL f | g #-}. If we use fromIfaceBooleanFormula + -- first, we will end up doing + -- `nub [Var (mkUnboundName f), Var (mkUnboundName g)]`, + -- which might seem fine, but Name equallity is decided by + -- their Unique, which will be identical since mkUnboundName + -- just stuffs the mkUnboundKey unqiue into both. + -- So the result will be {-# MINIMAL f #-}, oopsie. + -- Duplication it is. + mkOr :: [IfaceBooleanFormula] -> IfaceBooleanFormula + mkOr = maybe (IfAnd []) (mkOr' . nub . concat) . mapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr bf = case bf of + (IfOr xs) -> Just xs + (IfAnd []) -> Nothing + _ -> Just [bf] + mkOr' [x] = x + mkOr' xs = IfOr xs -- Note [Role merging] -- ~~~~~~~~~~~~~~~~~~~ @@ -343,7 +384,7 @@ = d1 { ifRoles = mergeRoles roles1 roles2 } | otherwise = d1 where - mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2 + mergeRoles roles1 roles2 = zipWithEqual max roles1 roles2 isRepInjectiveIfaceDecl :: IfaceDecl -> Bool isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon{} } = True @@ -445,6 +486,7 @@ -- But note that we use this type_env to typecheck references to DFun -- in 'IfaceInst' setImplicitEnvM type_env $ do + defaults <- tcIfaceDefaults (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 +494,7 @@ exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env + , md_defaults = defaults , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules @@ -472,10 +515,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 +528,7 @@ return (mkNameEnv decls) -- See Note [rnIfaceNeverExported] setImplicitEnvM type_env $ do + defaults <- tcIfaceDefaults 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 +536,7 @@ exports <- ifaceExportNames (mi_exports iface) complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env + , md_defaults = defaults , md_insts = mkInstEnv insts , md_fam_insts = fam_insts , md_rules = rules @@ -564,10 +610,11 @@ -- And that's fine, because if M's ModInfo is in the HPT, then -- it's been compiled once, and we don't need to check the boot iface then do { (_, hug) <- getEpsAndHug - ; case lookupHugByModule mod hug of + ; liftIO $ + HUG.lookupHugByModule mod hug >>= pure . \case Just info | mi_boot (hm_iface info) == IsBoot - -> return $ SelfBoot { sb_mds = hm_details info } - _ -> return NoSelfBoot } + -> SelfBoot { sb_mds = hm_details info } + _ -> NoSelfBoot } else do -- OK, so we're in one-shot mode. @@ -704,11 +751,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 +779,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 +791,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 @@ -761,7 +807,7 @@ ifBody = IfAbstractClass}) = bindIfaceTyConBinders binders $ \ binders' -> do { fds <- mapM tc_fd rdr_fds - ; cls <- buildClass tc_name binders' roles fds Nothing + ; cls <- buildAbstractClass tc_name binders' roles fds ; return (ATyCon (classTyCon cls)) } tc_iface_decl _parent ignore_prags @@ -772,7 +818,7 @@ ifBody = IfConcreteClass { ifClassCtxt = rdr_ctxt, ifATs = rdr_ats, ifSigs = rdr_sigs, - ifMinDef = if_mindef + ifMinDef = if_mindef, ifUnary = unary }}) = bindIfaceTyConBinders binders $ \ binders' -> do { traceIf (text "tc-iface-class1" <+> ppr tc_name) @@ -781,12 +827,11 @@ ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; traceIf (text "tc-iface-class3" <+> ppr tc_name) - ; let mindef_occ = fromIfaceBooleanFormula if_mindef - ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ + ; mindef <- tc_boolean_formula if_mindef ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_name) - ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) } + ; buildClass tc_name binders' roles fds ctxt ats sigs mindef unary } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -831,6 +876,12 @@ -- e.g. type AT a; type AT b = AT [b] #8002 return (ATI tc mb_def) + tc_boolean_formula :: IfaceBooleanFormula -> IfL (BooleanFormula GhcRn) + tc_boolean_formula (IfAnd ibfs ) = BF.And . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfOr ibfs ) = BF.Or . map noLocA <$> traverse tc_boolean_formula ibfs + tc_boolean_formula (IfParens ibf) = BF.Parens . noLocA <$> tc_boolean_formula ibf + tc_boolean_formula (IfVar nm ) = BF.Var . noLocA <$> (lookupIfaceTop . mkVarOccFS . ifLclNameFS $ nm) + mk_sc_doc pred = text "Superclass" <+> ppr pred mk_at_doc tc = text "Associated type" <+> ppr tc mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] @@ -890,11 +941,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 +987,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 +1007,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 @@ -1224,25 +1277,90 @@ tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc) tcRoughTyCon Nothing = RM_WildCard +{- Note [Tricky rehydrating IfaceDefaults loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a potential circular dependency when rehydrating IfaceDefaults into +a DefaultEnv (a map from class names to defaults): + +1. To construct a DefaultEnv, we need the Class objects corresponding to + the class names in the IfaceDefault + +2. If a class is defined in the current module, rehydrating it requires + looking into the ModDetails we're currently building + +3. But that ModDetails needs the DefaultEnv we're trying to create! + +This creates a circular dependency: + - DefaultEnv needs Class objects + - Class objects (for current module) need ModDetails + - ModDetails needs DefaultEnv + +Our solution is to break this loop by using just the class name from +IfaceDefault, rather than trying to fully resolve the Class. Since +DefaultEnv is keyed by Name anyway, we don't need the full Class object +for the map construction - we only need it for the map values. + +In tcIfaceDefault we create ClassDefaults records containing the actual +Class objects, but we do this *after* creating the DefaultEnv keyed by Name. + +This approach allows us to tie the knot properly without causing a loop. +-} + +-- | 'tcIfaceDefaults' rehydrates a list of default declarations +-- lazily, and returns a DefaultEnv. +tcIfaceDefaults :: Module -> [IfaceDefault] -> IfL DefaultEnv +tcIfaceDefaults this_mod defaults = do + defaults <- mapM do_one defaults + return $ mkDefaultEnv defaults + where + do_one idf = do + -- Invariant: (className class_default) == name + -- see Note [Tricky rehydrating IfaceDefaults loop] + let name = ifDefaultCls idf + + -- Now look up the Class and the default types. + -- We must use forkM here, as these may be knot-tied (see #25858). + -- See Note [Rehydrating Modules] in GHC.Driver.Make + -- as well as Note [Knot-tying typecheckIface] in GHC.IfaceToCore. + class_default <- forkM (text "tcIfaceDefault" <+> ppr name) $ tcIfaceDefault this_mod idf + return (name, class_default) + +tcIfaceDefault :: Module -> IfaceDefault -> IfL ClassDefaults +tcIfaceDefault this_mod IfaceDefault { ifDefaultCls = cls_name + , ifDefaultTys = tys + , ifDefaultWarn = iface_warn } + = do { cls <- fmap tyThingConClass (tcIfaceImplicit cls_name) + ; tys' <- traverse tcIfaceType tys + ; let warn = fmap fromIfaceWarningTxt iface_warn + ; return ClassDefaults { cd_class = cls + , cd_types = tys' + , cd_provenance = DP_Imported this_mod + , cd_warn = warn } } + where + tyThingConClass :: TyThing -> Class + tyThingConClass th = case tyConClass_maybe $ tyThingTyCon th of + Just cls -> cls + Nothing -> pprPanic "tcIfaceDefault, expected class" (ppr th) + tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag , ifInstCls = cls, ifInstTys = mb_tcs - , ifInstOrph = orph }) + , ifInstOrph = orph, ifInstWarn = iface_warn }) = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ fmap tyThingId (tcIfaceImplicit dfun_name) ; let mb_tcs' = map tcRoughTyCon mb_tcs - ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph) } + warn = fmap fromIfaceWarningTxt iface_warn + ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph warn) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs , 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) } {- ************************************************************************ @@ -1355,12 +1473,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1440,7 +1554,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) {- @@ -1462,13 +1576,15 @@ go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2 go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 - go (IfaceForAllCo tv k c) = do { k' <- go k + go (IfaceForAllCo tv visL visR k c) = do { k' <- go k ; bindIfaceBndr tv $ \ tv' -> - ForAllCo tv' 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 + ForAllCo tv' visL visR k' <$> go c } + 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 @@ -1479,20 +1595,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 -tcIfaceUnivCoProv (IfaceCorePrepProv b) = return $ CorePrepProv b - {- ************************************************************************ * * @@ -1561,7 +1671,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,12 +1690,12 @@ 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 ; let id = mkLocalIdWithInfo name ManyTy ty' id_info - `asJoinId_maybe` tcJoinInfo ji + `asJoinId_maybe` ji ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) ; return (Let (NonRec id rhs') body') } @@ -1598,9 +1708,9 @@ ; 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` tcJoinInfo ji) } + ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) } tc_pair (IfLetBndr _ _ info _, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} @@ -1619,10 +1729,13 @@ return (Tick tickish' expr') ------------------------- -tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish +tcIfaceTickish :: IfaceTickish -> IfL CoreTickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name)) +tcIfaceTickish (IfaceBreakpoint bid fvs) = do + fvs' <- mapM tcIfaceExpr fvs + return (Breakpoint NoExtField bid [f | Var f <- fvs']) ------------------------- tcIfaceLit :: Literal -> IfL Literal @@ -1632,7 +1745,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') @@ -1652,12 +1765,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 $ @@ -1673,10 +1786,9 @@ -} tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ IfVanillaId = return VanillaId tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds -tcIdDetails _ ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) +tcIdDetails _ ty IfDFunId = return (DFunId (isUnaryClass cls)) where (_, _, cls, _) = tcSplitDFunTy ty @@ -1684,7 +1796,15 @@ = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) tc - ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty, sel_fieldLabel = fl { flSelector = nm } }) } + ; let all_cons = recSelParentCons tc' + cons_partitioned = conLikesRecSelInfo all_cons [flLabel fl] + ; return (RecSelId + { sel_tycon = tc' + , sel_naughty = naughty + , sel_fieldLabel = fl { flSelector = nm } + , sel_cons = cons_partitioned } + -- Reconstructed here since we don't want Uniques in the Iface file + ) } where tyThingPatSyn (AConLike (PatSynCon ps)) = ps tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" @@ -1731,10 +1851,6 @@ | otherwise = info ; return (info1 `setUnfoldingInfo` unf) } -tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity -tcJoinInfo (IfaceJoinPoint ar) = Just ar -tcJoinInfo IfaceNotJoinPoint = Nothing - tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo tcLFInfo lfi = case lfi of IfLFReEntrant rep_arity -> @@ -1774,7 +1890,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 @@ -2012,34 +2128,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 @@ -2067,7 +2184,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' @@ -2110,7 +2227,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) } @@ -2168,3 +2285,13 @@ 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 :: IfaceImport -> ImportUserSpec +tcIfaceImport (IfaceImport spec ImpIfaceAll) + = ImpUserSpec spec ImpUserAll +tcIfaceImport (IfaceImport spec (ImpIfaceEverythingBut ns)) + = ImpUserSpec spec (ImpUserEverythingBut (mkNameSet ns)) +tcIfaceImport (IfaceImport spec (ImpIfaceExplicit gre implicit_parents)) + = ImpUserSpec spec (ImpUserExplicit (getDetOrdAvails gre) $ mkNameSet implicit_parents) diff --git a/GHC/IfaceToCore.hs-boot b/GHC/IfaceToCore.hs-boot --- a/GHC/IfaceToCore.hs-boot +++ b/GHC/IfaceToCore.hs-boot @@ -1,7 +1,7 @@ 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 ) @@ -10,13 +10,17 @@ import GHC.Core ( CoreRule ) import GHC.Types.CompleteMatch import GHC.Types.Annotations ( Annotation ) +import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Name +import GHC.Unit.Types ( Module ) import GHC.Fingerprint.Type + tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceDefaults :: Module -> [IfaceDefault] -> IfL DefaultEnv 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)] diff --git a/GHC/JS/Ident.hs b/GHC/JS/Ident.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Ident.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ident +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.Ident defines identifiers for the JS backend. We keep this module +-- separate to prevent coupling between GHC and the backend and between +-- unrelated modules is the JS backend. +-- +-- * Consumers +-- +-- The entire JavaScript Backend consumes this module including modules in +-- GHC.JS.\* and modules in GHC.StgToJS.\* +-- +-- * Additional Notes +-- +-- This module should be kept as small as possible. Anything added to it +-- will be coupled to the JS backend EDSL and the JS Backend including the +-- linker and rts. You have been warned. +-- +----------------------------------------------------------------------------- + +module GHC.JS.Ident + ( Ident(..) + , name + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Types.Unique +import GHC.Utils.Outputable + +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- + +-- | A newtype wrapper around 'FastString' for JS identifiers. +newtype Ident = TxtI { identFS :: FastString } + deriving stock (Show, Eq) + deriving newtype (Uniquable, Outputable) + +-- | To give a thing a name is to have power over it. This smart constructor +-- serves two purposes: first, it isolates the JS backend from the rest of GHC. +-- The backend should not explicitly use types provided by GHC but instead +-- should wrap them such as we do here. Second it creates a symbol in the JS +-- backend, but it does not yet give that symbols meaning. Giving the symbol +-- meaning only occurs once it is used with a combinator from @GHC.JS.Make@. +name :: FastString -> Ident +name = TxtI diff --git a/GHC/JS/JStg/Monad.hs b/GHC/JS/JStg/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/JStg/Monad.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.JStg.Monad +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.JStg.Monad defines the computational environment for the eDSL that +-- we use to write the JS Backend's RTS. Its purpose is to ensure unique +-- identifiers are generated throughout the backend and that we can use the +-- host language to ensure references are not mixed. +-- +-- * Strategy +-- +-- The monad is a straightforward state monad which holds an environment +-- holds a pointer to a prefix to tag identifiers with and an infinite +-- stream of identifiers. +-- +-- * Usage +-- +-- One should almost never need to directly use the functions in this +-- module. Instead one should opt to use the combinators in 'GHC.JS.Make', +-- the sole exception to this is the @withTag@ function which is used to +-- change the prefix of identifiers for a given computation. For example, +-- the rts uses this function to tag all identifiers generated by the RTS +-- code as RTS_N, where N is some unique. +----------------------------------------------------------------------------- +module GHC.JS.JStg.Monad + ( runJSM + , JSM + , withTag + , newIdent + , initJSM + ) where + +import Prelude + +import GHC.JS.Ident + +import GHC.Types.Unique +import GHC.Types.Unique.Supply +import Control.Monad.Trans.State.Strict +import GHC.Data.FastString + +-------------------------------------------------------------------------------- +-- JSM Monad +-------------------------------------------------------------------------------- + +-- | Environment for the JSM Monad. We maintain the prefix of each ident in the +-- environment to allow consumers to tag idents with a new prefix. See @withTag@ +data JEnv = JEnv { prefix :: !FastString -- ^ prefix for generated names, e.g., + -- prefix = "RTS" will generate names + -- such as 'h$RTS_jUt' + , ids :: UniqSupply -- ^ The supply of uniques for names + -- generated by the JSM monad. + } + +type JSM a = State JEnv a + +runJSM :: JEnv -> JSM a -> a +runJSM env m = evalState m env + +-- | create a new environment using the input tag. +initJSMState :: FastString -> UniqSupply -> JEnv +initJSMState tag supply = JEnv { prefix = tag + , ids = supply + } +initJSM :: IO JEnv +initJSM = do supply <- mkSplitUniqSupply 'j' + return (initJSMState "js" supply) + +update_stream :: UniqSupply -> JSM () +update_stream new = modify' $ \env -> env {ids = new} + +-- | generate a fresh Ident +newIdent :: JSM Ident +newIdent = do env <- get + let tag = prefix env + supply = ids env + (id,rest) = takeUniqFromSupply supply + update_stream rest + return $ mk_ident tag id + +mk_ident :: FastString -> Unique -> Ident +mk_ident t i = name (mconcat [t, "_", mkFastString (show i)]) + +-- | Set the tag for @Ident@s for all remaining computations. +tag_names :: FastString -> JSM () +tag_names tag = modify' (\env -> env {prefix = tag}) + +-- | tag the name generater with a prefix for the monadic action. +withTag + :: FastString -- ^ new name to tag with + -> JSM a -- ^ action to run with new tags + -> JSM a -- ^ result +withTag tag go = do + old <- gets prefix + tag_names tag + result <- go + tag_names old + return result diff --git a/GHC/JS/JStg/Syntax.hs b/GHC/JS/JStg/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/JStg/Syntax.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.JStg.Syntax +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Domain and Purpose +-- +-- GHC.JS.JStg.Syntax defines the eDSL that the JS backend's runtime system +-- is written in. Nothing fancy, its just a straightforward deeply embedded +-- DSL. +-- +-- In general, one should not use these constructors explicitly in the JS +-- backend. Instead, prefer using the combinators in GHC.JS.Make, if those +-- are suitable then prefer using the patterns exported from this module + +----------------------------------------------------------------------------- +module GHC.JS.JStg.Syntax + ( -- * Deeply embedded JS datatypes + JStgStat(..) + , JStgExpr(..) + , JVal(..) + , Op(..) + , AOp(..) + , UOp(..) + , JsLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern Var + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Utility + , SaneDouble(..) + , pattern Func + , global + , local + ) where + +import GHC.Prelude +import GHC.Utils.Outputable + +import GHC.JS.Ident + +import Control.DeepSeq + +import Data.Data +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Data.FastString +import GHC.Types.Unique.Map +import GHC.Types.SaneDouble + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStgStat + = DeclStat !Ident !(Maybe JStgExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JStgExpr -- ^ Return + | IfStat JStgExpr JStgStat JStgStat -- ^ If + | WhileStat Bool JStgExpr JStgStat -- ^ While, bool is "do" when True + | ForStat JStgStat JStgExpr JStgStat JStgStat -- ^ For + | ForInStat Bool Ident JStgExpr JStgStat -- ^ For-in, bool is "each' when True + | SwitchStat JStgExpr [(JStgExpr, JStgStat)] JStgStat -- ^ Switch + | TryStat JStgStat Ident JStgStat JStgStat -- ^ Try + | BlockStat [JStgStat] -- ^ Blocks + | ApplStat JStgExpr [JStgExpr] -- ^ Application + | UOpStat UOp JStgExpr -- ^ Unary operators + | AssignStat JStgExpr AOp JStgExpr -- ^ Binding form: @foo = bar@ + | LabelStat JsLabel JStgStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JsLabel) -- ^ Break + | ContinueStat (Maybe JsLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStgStat -- ^ an explicit function definition + deriving (Eq, Generic) + +-- | A Label used for 'JStgStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JsLabel = LexicalFastString + +instance Semigroup JStgStat where + (<>) = appendJStgStat + +instance Monoid JStgStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStgStat' only returns a +-- 'JStgStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStgStat :: JStgStat -> JStgStat -> JStgStat +appendJStgStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys + (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $ xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JStgExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JStgExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JStgExpr JStgExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr Op JStgExpr JStgExpr -- ^ Infix Expressions, see 'JStgExpr' pattern synonyms + | UOpExpr UOp JStgExpr -- ^ Unary Expressions + | IfExpr JStgExpr JStgExpr JStgExpr -- ^ If-expression + | ApplExpr JStgExpr [JStgExpr] -- ^ Application + deriving (Eq, Generic) + +instance Outputable JStgExpr where + ppr x = case x of + ValExpr _ -> text ("ValExpr" :: String) + SelExpr x' _ -> text ("SelExpr" :: String) <+> ppr x' + IdxExpr x' y' -> text ("IdxExpr" :: String) <+> ppr (x', y') + InfixExpr _ x' y' -> text ("InfixExpr" :: String) <+> ppr (x', y') + UOpExpr _ x' -> text ("UOpExpr" :: String) <+> ppr x' + IfExpr p t e -> text ("IfExpr" :: String) <+> ppr (p, t, e) + ApplExpr x' xs -> text ("ApplExpr" :: String) <+> ppr (x', xs) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @UOp@ and @Op@ into a @JStgExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JStgExpr -> JStgExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JStgExpr -> JStgExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JStgExpr -> JStgExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JStgExpr -> JStgExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JStgExpr -> JStgExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JStgExpr -> JStgExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JStgExpr -> JStgExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JStgExpr -> JStgExpr -> JStgExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JStgExpr -> JStgExpr -> JStgExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JStgExpr -> JStgExpr -> JStgExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JStgExpr -> JStgExpr -> JStgExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JStgExpr -> JStgExpr -> JStgExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JStgExpr -> JStgExpr -> JStgExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JStgExpr -> JStgExpr -> JStgExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JStgExpr -> JStgExpr -> JStgExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JStgExpr -> JStgExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JStgExpr -> JStgExpr -> JStgExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JStgExpr -> JStgExpr -> JStgExpr +pattern LAnd x y = InfixExpr LAndOp x y + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JStgExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JStgExpr +pattern String x = ValExpr (JStr x) + +-- | pattern synonym to create a local variable reference +pattern Var :: Ident -> JStgExpr +pattern Var x = ValExpr (JVar x) + +-- | pattern synonym to create an anonymous function +pattern Func :: [Ident] -> JStgStat -> JStgExpr +pattern Func args body = ValExpr (JFunc args body) + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JStgExpr] -- ^ A JavaScript list, or what JS + -- calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JBool Bool -- ^ A Boolean + | JHash (UniqMap FastString JStgExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStgStat -- ^ A function + deriving (Eq, Generic) + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data Op + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData Op + +-- | JS Unary Operators +data UOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData UOp + +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Generic) + +instance NFData AOp + +-- | construct a JS reference, intended to refer to a global name +global :: FastString -> JStgExpr +global = Var . name + +-- | construct a JS reference, intended to refer to a local name +local :: FastString -> JStgExpr +local = Var . name diff --git a/GHC/JS/Make.hs b/GHC/JS/Make.hs --- a/GHC/JS/Make.hs +++ b/GHC/JS/Make.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr +{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JStgExpr ----------------------------------------------------------------------------- -- | @@ -41,15 +43,14 @@ -- * /Introduction/ functions -- -- We define various primitive helpers which /introduce/ terms in the --- EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. Notice --- that the type of each of these functions have the domain @isSat a --- => a -> ...@; indicating that they each take something that /can/ --- be injected into the EDSL domain, and the range 'JExpr' or 'JStat'; --- indicating the corresponding value in the EDSL domain. Similarly --- this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr' --- injects values as a JS expression into the EDSL. 'ToSat' ensures --- that terms introduced into the EDSL carry identifier information so --- terms in the EDSL must have meaning. +-- EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. +-- Similarly this module exports four typeclasses 'ToExpr', 'ToStat', +-- 'JVarMagic', 'JSArgument'. 'ToExpr' injects values as a JS +-- expression into the EDSL. 'ToStat' injects values as JS statements +-- into the EDSL. @JVarMagic@ provides a polymorphic way to introduce +-- a new name into the EDSL and @JSArgument@ provides a polymorphic +-- way to bind variable names for use in JS functions with different +-- arities. -- -- * /Combinator/ functions -- @@ -73,24 +74,30 @@ -- the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo -- = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results -- in the JS code @var foo; foo = bar;@ when compiled. +-- +-- In most cases functions prefixed with a 'j' are monadic because the +-- observably allocate. Notable exceptions are `jwhenS`, 'jString' and the +-- helpers for HashMaps. ----------------------------------------------------------------------------- module GHC.JS.Make ( -- * Injection Type classes -- $classes ToJExpr(..) , ToStat(..) + , JVarMagic(..) + , JSArgument(..) -- * Introduction functions -- $intro_funcs - , var , jString - , jLam, jFun, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally + , jLam, jLam', jFunction, jFunctionSized, jFunction' + , jVar, jVars, jFor, jForIn, jForEachIn, jTryCatchFinally -- * Combinators -- $combinators , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) , (.>.), (.>=.), (.<.), (.<=.) , (.<<.), (.>>.), (.>>>.) , (.|.), (.||.), (.&&.) - , if_, if10, if01, ifS, ifBlockS + , if_, if10, if01, ifS, ifBlockS, jBlock, jIf , jwhenS , app, appS, returnS , loop, loopBlockS @@ -99,11 +106,10 @@ , off8, off16, off32, off64 , mask8, mask16 , signExtend8, signExtend16 - , typeof + , typeOf , returnStack, assignAllEqual, assignAll, assignAllReverseOrder , declAssignAll , nullStat, (.^) - , trace -- ** Hash combinators , jhEmpty , jhSingle @@ -123,22 +129,28 @@ -- $math , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, - math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround + math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround, + math_min, math_max -- * Statement helpers + , Solo(..) , decl ) where import GHC.Prelude hiding ((.|.)) -import GHC.JS.Unsat.Syntax +import GHC.JS.Ident +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Transform import Control.Arrow ((***)) +import Control.Monad (replicateM) +import Data.Tuple import qualified Data.Map as M import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc import GHC.Types.Unique.Map @@ -152,22 +164,22 @@ -- | Things that can be marshalled into javascript values. -- Instantiate for any necessary data structures. class ToJExpr a where - toJExpr :: a -> JExpr - toJExprFromList :: [a] -> JExpr + toJExpr :: a -> JStgExpr + toJExprFromList :: [a] -> JStgExpr toJExprFromList = ValExpr . JList . map toJExpr instance ToJExpr a => ToJExpr [a] where toJExpr = toJExprFromList -instance ToJExpr JExpr where +instance ToJExpr JStgExpr where toJExpr = id instance ToJExpr () where toJExpr _ = ValExpr $ JList [] instance ToJExpr Bool where - toJExpr True = var "true" - toJExpr False = var "false" + toJExpr True = global "true" + toJExpr False = global "false" instance ToJExpr JVal where toJExpr = ValExpr @@ -217,20 +229,29 @@ -- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data -- structures. class ToStat a where - toStat :: a -> JStat + toStat :: a -> JStgStat -instance ToStat JStat where +instance ToStat JStgStat where toStat = id -instance ToStat [JStat] where +instance ToStat [JStgStat] where toStat = BlockStat -instance ToStat JExpr where +instance ToStat JStgExpr where toStat = expr2stat -instance ToStat [JExpr] where +instance ToStat [JStgExpr] where toStat = BlockStat . map expr2stat +-- | Convert A JS expression to a JS statement where applicable. This only +-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary +-- expression; 'UOpExpr'. +expr2stat :: JStgExpr -> JStgStat +expr2stat (ApplExpr x y) = (ApplStat x y) +expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) +expr2stat (UOpExpr o x) = UOpStat o x +expr2stat _ = nullStat + -------------------------------------------------------------------------------- -- Introduction Functions -------------------------------------------------------------------------------- @@ -244,52 +265,90 @@ -- -- > jLam $ \x -> jVar x + one_ -- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x))) -jLam :: ToSat a => a -> JExpr -jLam f = ValExpr . UnsatVal . IS $ do - (block,is) <- runIdentSupply $ toSat_ f [] - return $ JFunc is block +jLam :: JSArgument args => (args -> JSM JStgStat) -> JSM JStgExpr +jLam body = do xs <- args + ValExpr . JFunc (argList xs) <$> body xs --- | Create a new function. The result is a 'GHC.JS.Syntax.JStat'. --- Usage: +-- | Special case of @jLam@ where the anonymous function requires no fresh +-- arguments. +jLam' :: JStgStat -> JStgExpr +jLam' body = ValExpr $ JFunc mempty body + +-- | Introduce only one new variable into scope for the duration of the +-- enclosed expression. The result is a block statement. Usage: -- --- > jFun fun_name $ \x -> ... -jFun :: ToSat a => Ident -> a -> JStat -jFun n f = UnsatBlock . IS $ do - (block,is) <- runIdentSupply $ toSat_ f [] - return $ FuncStat n is block +-- 'jVar $ \x -> mconcat [jVar x ||= one_, ...' +jVar :: (JVarMagic t, ToJExpr t) => (t -> JSM JStgStat) -> JSM JStgStat +jVar f = jVars $ \(MkSolo only_one) -> f only_one --- | Introduce a new variable into scope for the duration --- of the enclosed expression. The result is a block statement. +-- | Introduce one or many new variables into scope for the duration of the +-- enclosed expression. This function reifies the number of arguments based on +-- the container of the input function. We intentionally avoid lists and instead +-- opt for tuples because lists are not sized in general. The result is a block +-- statement. Usage: +-- +-- @jVars $ \(x,y) -> mconcat [ x |= one_, y |= two_, x + y]@ +jVars :: (JSArgument args) => (args -> JSM JStgStat) -> JSM JStgStat +jVars f = do as <- args + body <- f as + return $ mconcat $ fmap decl (argList as) ++ [body] + +-- | Construct a top-level function subject to JS hoisting. This combinator is +-- polymorphic over function arity so you can you use to define a JS syntax +-- object in Haskell, which is a function in JS that takes 2 or 4 or whatever +-- arguments. For a singleton function use the @Solo@ constructor @MkSolo@. -- Usage: -- --- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@ -jVar :: ToSat a => a -> JStat -jVar f = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let addDecls (BlockStat ss) = - BlockStat $ map decl is ++ ss - addDecls x = x - return $ addDecls block +-- an example from the Rts that defines a 1-arity JS function +-- > jFunction (global "h$getReg") (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty) +-- +-- an example of a two argument function from the Rts +-- > jFunction (global "h$bh_lne") (\(x, frameSize) -> bhLneStats s x frameSize) +jFunction + :: (JSArgument args) + => Ident -- ^ global name + -> (args -> JSM JStgStat) -- ^ function body, input is locally unique generated variables + -> JSM JStgStat +jFunction name body = do + func_args <- args + FuncStat name (argList func_args) <$> (body func_args) -jFunction :: Ident -> [Ident] -> JStat -> JStat -jFunction name args body = FuncStat name args body +-- | Construct a top-level function subject to JS hoisting. Special case where +-- the arity cannot be deduced from the 'args' parameter (atleast not without +-- dependent types). +jFunctionSized + :: Ident -- ^ global name + -> Int -- ^ Arity + -> ([JStgExpr] -> JSM JStgStat) -- ^ function body, input is locally unique generated variables + -> JSM JStgStat +jFunctionSized name arity body = do + func_args <- replicateM arity newIdent + FuncStat name func_args <$> (body $ toJExpr <$> func_args) +-- | Construct a top-level function subject to JS hoisting. Special case where +-- the function binds no parameters +jFunction' + :: Ident -- ^ global name + -> JSM JStgStat -- ^ function body, input is locally unique generated variables + -> JSM JStgStat +jFunction' name body = FuncStat name mempty <$> body + +jBlock :: Monoid a => [JSM a] -> JSM a +jBlock = fmap mconcat . sequence + -- | Create a 'for in' statement. -- Usage: -- -- @jForIn {expression} $ \x -> {block involving x}@ -jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat -jForIn e f = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let i = head is - return $ decl i `mappend` ForInStat False i e block +jForIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat +jForIn e f = do + i <- newIdent + return $ decl i `mappend` ForInStat False i e (f (ValExpr $! JVar i)) -- | As with "jForIn" but creating a \"for each in\" statement. -jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat -jForEachIn e f = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let i = head is - return $ decl i `mappend` ForInStat True i e block +jForEachIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat +jForEachIn e f = do i <- newIdent + return $ decl i `mappend` ForInStat True i e (f (ValExpr $! JVar i)) -- | Create a 'for' statement given a function for initialization, a predicate -- to step to, a step and a body @@ -298,53 +357,47 @@ -- @ jFor (|= zero_) (.<. Int 65536) preIncrS -- (\j -> ...something with the counter j...)@ -- -jFor :: (JExpr -> JStat) - -> (JExpr -> JExpr) - -> (JExpr -> JStat) - -> (JExpr -> JStat) - -> JStat -jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i) - -jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat -jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body +jFor :: (JStgExpr -> JStgStat) -- ^ initialization function + -> (JStgExpr -> JStgExpr) -- ^ predicate + -> (JStgExpr -> JStgStat) -- ^ step function + -> (JStgExpr -> JStgStat) -- ^ body + -> JSM JStgStat +jFor init pred step body = do id <- newIdent + let i = ValExpr (JVar id) + return + $ decl id `mappend` ForStat (init i) (pred i) (step i) (body i) -- | As with "jForIn" but creating a \"for each in\" statement. -jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat -jTryCatchFinally s f s2 = UnsatBlock . IS $ do - (block, is) <- runIdentSupply $ toSat_ f [] - let i = head is - return $ TryStat s i block s2 - --- | construct a JS variable reference -var :: FastString -> JExpr -var = ValExpr . JVar . TxtI +jTryCatchFinally :: (Ident -> JStgStat) -> (Ident -> JStgStat) -> (Ident -> JStgStat) -> JSM JStgStat +jTryCatchFinally c f f2 = do i <- newIdent + return $ TryStat (c i) i (f i) (f2 i) --- | Convert a ShortText to a Javascript String -jString :: FastString -> JExpr +-- | Convert a FastString to a Javascript String +jString :: FastString -> JStgExpr jString = toJExpr -- | construct a js declaration with the given identifier -decl :: Ident -> JStat +decl :: Ident -> JStgStat decl i = DeclStat i Nothing -- | The empty JS HashMap -jhEmpty :: M.Map k JExpr +jhEmpty :: M.Map k JStgExpr jhEmpty = M.empty -- | A singleton JS HashMap -jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr +jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr jhSingle k v = jhAdd k v jhEmpty -- | insert a key-value pair into a JS HashMap -jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr +jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr -> M.Map k JStgExpr jhAdd k v m = M.insert k (toJExpr v) m -- | Construct a JS HashMap from a list of key-value pairs -jhFromList :: [(FastString, JExpr)] -> JVal +jhFromList :: [(FastString, JStgExpr)] -> JVal jhFromList = JHash . listToUniqMap -- | The empty JS statement -nullStat :: JStat +nullStat :: JStgStat nullStat = BlockStat [] @@ -356,7 +409,7 @@ -- EDSL domain. -- | JS infix Equality operators -(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr +(.==.), (.===.), (.!=.), (.!==.) :: JStgExpr -> JStgExpr -> JStgExpr (.==.) = InfixExpr EqOp (.===.) = InfixExpr StrictEqOp (.!=.) = InfixExpr NeqOp @@ -365,7 +418,7 @@ infixl 6 .==., .===., .!=., .!==. -- | JS infix Ord operators -(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr +(.>.), (.>=.), (.<.), (.<=.) :: JStgExpr -> JStgExpr -> JStgExpr (.>.) = InfixExpr GtOp (.>=.) = InfixExpr GeOp (.<.) = InfixExpr LtOp @@ -374,7 +427,7 @@ infixl 7 .>., .>=., .<., .<=. -- | JS infix bit operators -(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.), (.||.), (.&&.) :: JStgExpr -> JStgExpr -> JStgExpr (.|.) = InfixExpr BOrOp (.||.) = InfixExpr LOrOp (.&&.) = InfixExpr LAndOp @@ -382,146 +435,157 @@ infixl 8 .||., .&&. -- | JS infix bit shift operators -(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr +(.<<.), (.>>.), (.>>>.) :: JStgExpr -> JStgExpr -> JStgExpr (.<<.) = InfixExpr LeftShiftOp (.>>.) = InfixExpr RightShiftOp (.>>>.) = InfixExpr ZRightShiftOp infixl 9 .<<., .>>., .>>>. --- | Given a 'JExpr', return the its type. -typeof :: JExpr -> JExpr -typeof = UOpExpr TypeofOp +-- | Given a 'JStgExpr', return the its type. +typeOf :: JStgExpr -> JStgExpr +typeOf = UOpExpr TypeofOp -- | JS if-expression -- -- > if_ e1 e2 e3 ==> e1 ? e2 : e3 -if_ :: JExpr -> JExpr -> JExpr -> JExpr +if_ :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr if_ e1 e2 e3 = IfExpr e1 e2 e3 -- | If-expression which returns statements, see related 'ifBlockS' -- -- > if e s1 s2 ==> if(e) { s1 } else { s2 } -ifS :: JExpr -> JStat -> JStat -> JStat +ifS :: JStgExpr -> JStgStat -> JStgStat -> JStgStat ifS e s1 s2 = IfStat e s1 s2 + +-- | Version of a JS if-expression which admits monadic actions in its branches +jIf :: JStgExpr -> JSM JStgStat -> JSM JStgStat -> JSM JStgStat +jIf e ma mb = do + !a <- ma + !b <- mb + pure $ IfStat e a b + -- | A when-statement as syntactic sugar via `ifS` -- -- > jwhenS cond block ==> if(cond) { block } else { } -jwhenS :: JExpr -> JStat -> JStat -jwhenS cond block = ifS cond block mempty +jwhenS :: JStgExpr -> JStgStat -> JStgStat +jwhenS cond block = IfStat cond block mempty -- | If-expression which returns blocks -- -- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 } -ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat +ifBlockS :: JStgExpr -> [JStgStat] -> [JStgStat] -> JStgStat ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2) -- | if-expression that returns 1 if condition <=> true, 0 otherwise -- -- > if10 e ==> e ? 1 : 0 -if10 :: JExpr -> JExpr +if10 :: JStgExpr -> JStgExpr if10 e = IfExpr e one_ zero_ -- | if-expression that returns 0 if condition <=> true, 1 otherwise -- -- > if01 e ==> e ? 0 : 1 -if01 :: JExpr -> JExpr +if01 :: JStgExpr -> JStgExpr if01 e = IfExpr e zero_ one_ --- | an expression application, see related 'appS' +-- | an application expression, see related 'appS' -- -- > app f xs ==> f(xs) -app :: FastString -> [JExpr] -> JExpr -app f xs = ApplExpr (var f) xs +app :: FastString -> [JStgExpr] -> JStgExpr +app f xs = ApplExpr (global f) xs -- | A statement application, see the expression form 'app' -appS :: FastString -> [JExpr] -> JStat -appS f xs = ApplStat (var f) xs +appS :: FastString -> [JStgExpr] -> JStgStat +appS f xs = ApplStat (global f) xs --- | Return a 'JExpr' -returnS :: JExpr -> JStat +-- | Return a 'JStgExpr' +returnS :: JStgExpr -> JStgStat returnS e = ReturnStat e -- | "for" loop with increment at end of body -loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat -loop initial test body = jVar $ \i -> - mconcat [ i |= initial - , WhileStat False (test i) (body i) - ] +loop :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat +loop initial test body_ = jVar $ \i -> + do body <- body_ i + return $ + mconcat [ i |= initial + , WhileStat False (test i) body + ] -- | "for" loop with increment at end of body -loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat +loopBlockS :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> [JStgStat]) -> JSM JStgStat loopBlockS initial test body = jVar $ \i -> + return $ mconcat [ i |= initial , WhileStat False (test i) (mconcat (body i)) ] --- | Prefix-increment a 'JExpr' -preIncrS :: JExpr -> JStat +-- | Prefix-increment a 'JStgExpr' +preIncrS :: JStgExpr -> JStgStat preIncrS x = UOpStat PreIncOp x --- | Postfix-increment a 'JExpr' -postIncrS :: JExpr -> JStat +-- | Postfix-increment a 'JStgExpr' +postIncrS :: JStgExpr -> JStgStat postIncrS x = UOpStat PostIncOp x --- | Prefix-decrement a 'JExpr' -preDecrS :: JExpr -> JStat +-- | Prefix-decrement a 'JStgExpr' +preDecrS :: JStgExpr -> JStgStat preDecrS x = UOpStat PreDecOp x --- | Postfix-decrement a 'JExpr' -postDecrS :: JExpr -> JStat +-- | Postfix-decrement a 'JStgExpr' +postDecrS :: JStgExpr -> JStgStat postDecrS x = UOpStat PostDecOp x -- | Byte indexing of o with a 64-bit offset -off64 :: JExpr -> JExpr -> JExpr +off64 :: JStgExpr -> JStgExpr -> JStgExpr off64 o i = Add o (i .<<. three_) -- | Byte indexing of o with a 32-bit offset -off32 :: JExpr -> JExpr -> JExpr +off32 :: JStgExpr -> JStgExpr -> JStgExpr off32 o i = Add o (i .<<. two_) -- | Byte indexing of o with a 16-bit offset -off16 :: JExpr -> JExpr -> JExpr +off16 :: JStgExpr -> JStgExpr -> JStgExpr off16 o i = Add o (i .<<. one_) -- | Byte indexing of o with a 8-bit offset -off8 :: JExpr -> JExpr -> JExpr +off8 :: JStgExpr -> JStgExpr -> JStgExpr off8 o i = Add o i -- | a bit mask to retrieve the lower 8-bits -mask8 :: JExpr -> JExpr +mask8 :: JStgExpr -> JStgExpr mask8 x = BAnd x (Int 0xFF) -- | a bit mask to retrieve the lower 16-bits -mask16 :: JExpr -> JExpr +mask16 :: JStgExpr -> JStgExpr mask16 x = BAnd x (Int 0xFFFF) -- | Sign-extend/narrow a 8-bit value -signExtend8 :: JExpr -> JExpr +signExtend8 :: JStgExpr -> JStgExpr signExtend8 x = (BAnd x (Int 0x7F )) `Sub` (BAnd x (Int 0x80)) -- | Sign-extend/narrow a 16-bit value -signExtend16 :: JExpr -> JExpr +signExtend16 :: JStgExpr -> JStgExpr signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000)) -- | Select a property 'prop', from and object 'obj' -- -- > obj .^ prop ==> obj.prop -(.^) :: JExpr -> FastString -> JExpr -obj .^ prop = SelExpr obj (TxtI prop) +(.^) :: JStgExpr -> FastString -> JStgExpr +obj .^ prop = SelExpr obj (name prop) infixl 8 .^ -- | Assign a variable to an expression -- -- > foo |= expr ==> var foo = expr; -(|=) :: JExpr -> JExpr -> JStat -(|=) = AssignStat +(|=) :: JStgExpr -> JStgExpr -> JStgStat +(|=) l r = AssignStat l AssignOp r -- | Declare a variable and then Assign the variable to an expression -- -- > foo |= expr ==> var foo; foo = expr; -(||=) :: Ident -> JExpr -> JStat +(||=) :: Ident -> JStgExpr -> JStgStat i ||= ex = DeclStat i (Just ex) infixl 2 ||=, |= @@ -529,27 +593,24 @@ -- | return the expression at idx of obj -- -- > obj .! idx ==> obj[idx] -(.!) :: JExpr -> JExpr -> JExpr +(.!) :: JStgExpr -> JStgExpr -> JStgExpr (.!) = IdxExpr infixl 8 .! -assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat -assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys) +assignAllEqual :: HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat +assignAllEqual xs ys = mconcat (zipWithEqual (|=) xs ys) -assignAll :: [JExpr] -> [JExpr] -> JStat +assignAll :: [JStgExpr] -> [JStgExpr] -> JStgStat assignAll xs ys = mconcat (zipWith (|=) xs ys) -assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat +assignAllReverseOrder :: [JStgExpr] -> [JStgExpr] -> JStgStat assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) -declAssignAll :: [Ident] -> [JExpr] -> JStat +declAssignAll :: [Ident] -> [JStgExpr] -> JStgStat declAssignAll xs ys = mconcat (zipWith (||=) xs ys) -trace :: ToJExpr a => a -> JStat -trace ex = appS "h$log" [toJExpr ex] - -------------------------------------------------------------------------------- -- Literals -------------------------------------------------------------------------------- @@ -558,39 +619,39 @@ -- helper values and never change -- | The JS literal 'null' -null_ :: JExpr -null_ = var "null" +null_ :: JStgExpr +null_ = global "null" -- | The JS literal 0 -zero_ :: JExpr +zero_ :: JStgExpr zero_ = Int 0 -- | The JS literal 1 -one_ :: JExpr +one_ :: JStgExpr one_ = Int 1 -- | The JS literal 2 -two_ :: JExpr +two_ :: JStgExpr two_ = Int 2 -- | The JS literal 3 -three_ :: JExpr +three_ :: JStgExpr three_ = Int 3 -- | The JS literal 'undefined' -undefined_ :: JExpr -undefined_ = var "undefined" +undefined_ :: JStgExpr +undefined_ = global "undefined" -- | The JS literal 'true' -true_ :: JExpr -true_ = var "true" +true_ :: JStgExpr +true_ = ValExpr (JBool True) -- | The JS literal 'false' -false_ :: JExpr -false_ = var "false" +false_ :: JStgExpr +false_ = ValExpr (JBool False) -returnStack :: JStat -returnStack = ReturnStat (ApplExpr (var "h$rs") []) +returnStack :: JStgStat +returnStack = ReturnStat (ApplExpr (global "h$rs") []) -------------------------------------------------------------------------------- @@ -600,16 +661,17 @@ -- Math functions in the EDSL are literals, with the exception of 'math_' which -- is the sole math introduction function. -math :: JExpr -math = var "Math" +math :: JStgExpr +math = global "Math" -math_ :: FastString -> [JExpr] -> JExpr +math_ :: FastString -> [JStgExpr] -> JStgExpr math_ op args = ApplExpr (math .^ op) args math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign, - math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround - :: [JExpr] -> JExpr + math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround, + math_min, math_max + :: [JStgExpr] -> JStgExpr math_log = math_ "log" math_sin = math_ "sin" math_cos = math_ "cos" @@ -631,8 +693,10 @@ math_expm1 = math_ "expm1" math_log1p = math_ "log1p" math_fround = math_ "fround" +math_min = math_ "min" +math_max = math_ "max" -instance Num JExpr where +instance Num JStgExpr where x + y = InfixExpr AddOp x y x - y = InfixExpr SubOp x y x * y = InfixExpr MulOp x y @@ -641,52 +705,132 @@ signum x = math_sign [x] fromInteger x = ValExpr (JInt x) -instance Fractional JExpr where +instance Fractional JStgExpr where x / y = InfixExpr DivOp x y fromRational x = ValExpr (JDouble (realToFrac x)) + -------------------------------------------------------------------------------- -- New Identifiers -------------------------------------------------------------------------------- --- | The 'ToSat' class is heavily used in the Introduction function. It ensures --- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'. -class ToSat a where - toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident]) +-- | Type class that generates fresh @a@'s for the JS backend. You should almost +-- never need to use this directly. Instead use @JSArgument@, for examples of +-- how to employ these classes please see @jVar@, @jFunction@ and call sites in +-- the Rts. +class JVarMagic a where + fresh :: JSM a -instance ToSat [JStat] where - toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) +-- | Type class that finds the form of arguments required for a JS syntax +-- object. This class gives us a single interface to generate variables for +-- functions that have different arities. Thus with it, we can have only one +-- @jFunction@ which is polymorphic over its arity, instead of 'jFunction2', +-- 'jFunction3' and so on. +class JSArgument args where + argList :: args -> [Ident] + args :: JSM args -instance ToSat JStat where - toSat_ f vs = IS $ return $ (f, reverse vs) +instance JVarMagic Ident where + fresh = newIdent -instance ToSat JExpr where - toSat_ f vs = IS $ return $ (toStat f, reverse vs) +instance JVarMagic JVal where + fresh = JVar <$> fresh -instance ToSat [JExpr] where - toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs) +instance JVarMagic JStgExpr where + fresh = do i <- fresh + return $ ValExpr $ JVar i -instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where - toSat_ f vs = IS $ do - x <- takeOneIdent - runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs) +instance (JVarMagic a, ToJExpr a) => JSArgument (Solo a) where + argList (MkSolo a) = concatMap identsE [toJExpr a] + args = do i <- fresh + return $ MkSolo i --- | Convert A JS expression to a JS statement where applicable. This only --- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary --- expression; 'UOpExpr'. -expr2stat :: JExpr -> JStat -expr2stat (ApplExpr x y) = (ApplStat x y) -expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z) -expr2stat (UOpExpr o x) = UOpStat o x -expr2stat _ = nullStat +instance (JVarMagic a, JVarMagic b, ToJExpr a, ToJExpr b) => JSArgument (a,b) where + argList (a,b) = concatMap identsE [toJExpr a , toJExpr b] + args = (,) <$> fresh <*> fresh -takeOneIdent :: State [Ident] Ident -takeOneIdent = do - xxs <- get - case xxs of - (x:xs) -> do - put xs - return x - _ -> error "takeOneIdent: empty list" +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + ) => JSArgument (a,b,c) where + argList (a,b,c) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c] + args = (,,) <$> fresh <*> fresh <*> fresh +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + ) => JSArgument (a,b,c,d) where + argList (a,b,c,d) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d] + args = (,,,) <$> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + ) => JSArgument (a,b,c,d,e) where + argList (a,b,c,d,e) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e] + args = (,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + ) => JSArgument (a,b,c,d,e,f) where + argList (a,b,c,d,e,f) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] + args = (,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + ) => JSArgument (a,b,c,d,e,f,g) where + argList (a,b,c,d,e,f,g) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g] + args = (,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + , JVarMagic h, ToJExpr h + ) => JSArgument (a,b,c,d,e,f,g,h) where + argList (a,b,c,d,e,f,g,h) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h] + args = (,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + , JVarMagic h, ToJExpr h + , JVarMagic i, ToJExpr i + ) => JSArgument (a,b,c,d,e,f,g,h,i) where + argList (a,b,c,d,e,f,g,h,i) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i] + args = (,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh + + +instance ( JVarMagic a, ToJExpr a + , JVarMagic b, ToJExpr b + , JVarMagic c, ToJExpr c + , JVarMagic d, ToJExpr d + , JVarMagic e, ToJExpr e + , JVarMagic f, ToJExpr f + , JVarMagic g, ToJExpr g + , JVarMagic h, ToJExpr h + , JVarMagic i, ToJExpr i + , JVarMagic j, ToJExpr j + ) => JSArgument (a,b,c,d,e,f,g,h,i,j) where + argList (a,b,c,d,e,f,g,h,i,j) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i, toJExpr j] + args = (,,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh diff --git a/GHC/JS/Opt/Expr.hs b/GHC/JS/Opt/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Opt/Expr.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Opt.Expr +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- This module contains a simple expression optimizer that performs constant +-- folding and some boolean expression optimizations. +----------------------------------------------------------------------------- + +module GHC.JS.Opt.Expr (optExprs) where + +import GHC.Prelude hiding (shiftL, shiftR) + +import GHC.JS.Syntax + +import Data.Bifunctor (second) +import Data.Bits (shiftL, shiftR, (.^.)) +import Data.Int (Int32) + +{- + Optimize expressions in a statement. + + This is best done after running the simple optimizer in GHC.JS.Opt.Simple, + which eliminates redundant assignments and produces expressions that can be + optimized more effectively. + -} +optExprs :: JStat -> JStat +optExprs s = go s + where + go (DeclStat v mb_e) = DeclStat v (fmap opt mb_e) + go (AssignStat lhs op rhs) = AssignStat (opt lhs) op (opt rhs) + go (ReturnStat e) = ReturnStat (opt e) + go (BlockStat ss) = BlockStat (map go ss) + go (IfStat e s1 s2) = IfStat (optCond e) (go s1) (go s2) + go (WhileStat b e s) = WhileStat b (optCond e) (go s) + go (ForStat s1 e s2 s3) = ForStat (go s1) (optCond e) (go s2) (go s3) + go (ForInStat b v e s) = ForInStat b v (opt e) (go s) + go (SwitchStat e cases s) = SwitchStat (opt e) + (map (second go) cases) + (go s) + go (TryStat s1 v s2 s3) = TryStat (go s1) v (go s2) (go s3) + go (ApplStat e es) = ApplStat (opt e) (map opt es) + go (UOpStat op e) = UOpStat op (opt e) + go (LabelStat lbl s) = LabelStat lbl (go s) + go s@(BreakStat{}) = s + go s@(ContinueStat{}) = s + go (FuncStat n vs s) = FuncStat n vs (go s) + + -- remove double negation if we're using the expression in a loop/if condition +optCond :: JExpr -> JExpr +optCond e = let f (UOpExpr NotOp (UOpExpr NotOp e')) = f e' + f e' = e' + in f (opt e) + +opt :: JExpr -> JExpr +opt (ValExpr v) = ValExpr v +opt (SelExpr e i) = SelExpr (opt e) i +opt (IdxExpr e1 e2) = IdxExpr (opt e1) (opt e2) +-- ((c_e ? 1 : 0) === 1) ==> !!c_e +-- ((c_e ? 1 : 0) === 0) ==> !c_e +opt(InfixExpr StrictEqOp (IfExpr c_e (opt -> t_e) (opt -> f_e)) (opt -> e)) + | ValExpr t_v <- t_e + , ValExpr v <- e + , eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e) + | ValExpr f_v <- f_e + , ValExpr v <- e + , eqVal f_v v = UOpExpr NotOp (opt c_e) + | otherwise = InfixExpr StrictEqOp (IfExpr c_e t_e f_e) e +-- (1 === (c_e ? 1 : 0)) ==> !!c_e +-- (0 === (c_e ? 1 : 0)) ==> !c_e +opt(InfixExpr StrictEqOp (opt -> e) (IfExpr (opt -> c_e) (opt -> t_e) (opt -> f_e))) + | ValExpr t_v <- t_e + , ValExpr v <- e + , eqVal t_v v = UOpExpr NotOp (UOpExpr NotOp c_e) + | ValExpr f_v <- f_e + , ValExpr v <- e + , eqVal f_v v = UOpExpr NotOp c_e + | otherwise = InfixExpr StrictEqOp e (IfExpr c_e t_e f_e) +opt (InfixExpr op (opt -> e1) (opt -> e2)) + | (ValExpr (JInt n1)) <- e1 + , (ValExpr (JInt n2)) <- e2 + , Just v <- optInt op n1 n2 = ValExpr v + | (ValExpr (JBool b1)) <- e1 + , (ValExpr (JBool b2)) <- e2 + , Just v <- optBool op b1 b2 = ValExpr v + | otherwise = InfixExpr op e1 e2 +opt (UOpExpr op e) = UOpExpr op (opt e) +opt (IfExpr e1 e2 e3) = IfExpr (optCond e1) (opt e2) (opt e3) +opt (ApplExpr e es) = ApplExpr (opt e) (map opt es) + +{- + Optimizations for operations on two known boolean values + -} +optBool :: Op -> Bool -> Bool -> Maybe JVal +optBool LAndOp x y = Just (JBool (x && y)) +optBool LOrOp x y = Just (JBool (x || y)) +optBool EqOp x y = Just (JBool (x == y)) +optBool StrictEqOp x y = Just (JBool (x == y)) +optBool NeqOp x y = Just (JBool (x /= y)) +optBool StrictNeqOp x y = Just (JBool (x /= y)) +optBool _ _ _ = Nothing + +{- + Optimizations for operations on two known integer values + -} +optInt :: Op -> Integer -> Integer -> Maybe JVal +optInt ZRightShiftOp n m = Just $ + JInt (toInteger $ (n .&. 0xffffffff) `shiftR` fromInteger (m .&. 0x1f)) +optInt BOrOp n m = Just (truncOp (.|.) n m) +optInt BAndOp n m = Just (truncOp (.&.) n m) +optInt BXorOp n m = Just (truncOp (.^.) n m) +optInt RightShiftOp n m = Just (shiftOp shiftR n m) +optInt LeftShiftOp n m = Just (shiftOp shiftL n m) +optInt AddOp n m = smallIntOp (+) n m +optInt SubOp n m = smallIntOp (-) n m +optInt MulOp n m = smallIntOp (*) n m +optInt op n m + | Just cmp <- getCmpOp op, isSmall52 n && isSmall52 m + = Just (JBool (cmp n m)) +optInt _ _ _ = Nothing + +smallIntOp :: (Integer -> Integer -> Integer) + -> Integer -> Integer -> Maybe JVal +smallIntOp op n m + | isSmall52 n && isSmall52 m && isSmall52 r = Just (JInt r) + | otherwise = Nothing + where + r = op n m + +getCmpOp :: Op -> Maybe (Integer -> Integer -> Bool) +getCmpOp EqOp = Just (==) +getCmpOp StrictEqOp = Just (==) +getCmpOp NeqOp = Just (/=) +getCmpOp StrictNeqOp = Just (/=) +getCmpOp GtOp = Just (>) +getCmpOp GeOp = Just (>=) +getCmpOp LtOp = Just (<) +getCmpOp LeOp = Just (<=) +getCmpOp _ = Nothing + +shiftOp :: (Int32 -> Int -> Int32) -> Integer -> Integer -> JVal +shiftOp op n m = JInt $ toInteger + (fromInteger n `op` (fromInteger m .&. 0x1f)) + +{- + JavaScript bitwise operations truncate numbers to 32 bit signed integers. + Here we do the same when constant folding with this kind of operators. + -} +truncOp :: (Int32 -> Int32 -> Int32) -> Integer -> Integer -> JVal +truncOp op n m = JInt $ toInteger + (fromInteger n `op` fromInteger m) + +{- + JavaScript numbers are IEEE 754 double precision floats, which have a + 52-bit mantissa. This returns True if the given integer can definitely + be represented without loss of precision in a JavaScript number. + -} +isSmall52 :: Integer -> Bool +isSmall52 n = n >= -0x10000000000000 && n <= 0xfffffffffffff + +{- + In JavaScript, e1 === e2 is not always true even if expressions e1 and e2 + are syntactically equal, examples: + + - NaN !== NaN (NaN is not equal to itself) + - [1] !== [1] (different arrays allocated) + - f() !== f() + + This returns True if the values are definitely equal in JavaScript + -} +eqVal :: JVal -> JVal -> Bool +eqVal (JInt n1) (JInt n2) = n1 == n2 +eqVal (JStr s1) (JStr s2) = s1 == s2 +eqVal (JBool b1) (JBool b2) = b1 == b2 +eqVal (JDouble (SaneDouble d1)) (JDouble (SaneDouble d2)) + | not (isNaN d1) && not (isNaN d2) = d1 == d2 +eqVal _ _ = False diff --git a/GHC/JS/Opt/Simple.hs b/GHC/JS/Opt/Simple.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Opt/Simple.hs @@ -0,0 +1,607 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Opt.Simple +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- * Simple optimizer for the JavaScript IR +-- +-- This is a simple optimizer for the JavaScript IR. It is intended to be +-- the first optimization pass after generating the JavaScript IR. +-- +-- * Design +-- +-- The optimizer is invoked on the top-level JStat. It leaves the top-level +-- scope alone, but traverses into each function body and optimizes it. +-- Nested functions are mostly left alone, since they are uncommon in +-- generated code. +-- +-- The optimizations are: +-- +-- - rename local variables to shorter names +-- - remove unused variables +-- - remove trivial assignments: x = x +-- - "float" expressions without side effects: +-- - var x = 1; var y = x + 1; -> var y = 1 + 1; +-- +-- * Limitations +-- +-- The simple optimization pass is intended to be fast and applicable to +-- almost all generated JavaScript code. Limitations are: +-- +-- - optimization is disabled if an `eval` statement is encountered +-- - variables declared in nested scopes are not renamed +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +module GHC.JS.Opt.Simple (simpleOpt) where + +import GHC.Prelude + +import GHC.JS.Opt.Expr +import GHC.JS.Syntax + +import GHC.Data.FastString +import qualified GHC.Types.Unique.Map as UM +import GHC.Types.Unique.Map (UniqMap) +import qualified GHC.Types.Unique.Set as US + +import Control.Monad +import Data.Function +import Data.List (sortBy) +import Data.Maybe +import qualified Data.Semigroup as Semi + + +data Multiplicity = Zero | One | Many + deriving (Eq, Ord, Show) + +data VarValue = Unassigned + | AssignedOnce + | AssignedOnceKnown !JExpr + | AssignedMany + +data VarDecl = NoDecl -- not declared in analyzed scope (possibly deeper or global) + | ArgDecl !Int -- argument in analyzed scope + | LocalDecl !Int -- local variable in analyzed scope + deriving (Eq, Show) + +isLocalOrArg :: VarDecl -> Bool +isLocalOrArg (LocalDecl {}) = True +isLocalOrArg (ArgDecl {}) = True +isLocalOrArg _ = False + +isDecl :: VarDecl -> Bool +isDecl NoDecl = False +isDecl _ = True + +instance Semi.Semigroup VarDecl where + NoDecl <> x = x + x <> NoDecl = x + ArgDecl n <> ArgDecl m = ArgDecl (min n m) + LocalDecl n <> LocalDecl m = LocalDecl (min n m) + ArgDecl n <> _ = ArgDecl n + _ <> ArgDecl n = ArgDecl n + +instance Ord VarDecl where + compare NoDecl NoDecl = EQ + compare NoDecl _ = LT + compare _ NoDecl = GT + compare (ArgDecl n) (ArgDecl m) = compare n m + compare (ArgDecl {}) _ = LT + compare _ (ArgDecl {}) = GT + compare (LocalDecl n) (LocalDecl m) = compare n m + +data JFunction = JFunction [Ident] JStat + +instance Semi.Semigroup VarValue where + Unassigned <> x = x + x <> Unassigned = x + _ <> _ = AssignedMany + +instance Monoid VarValue where + mempty = Unassigned + mappend = (Semi.<>) + +instance Semigroup Multiplicity where + Zero <> x = x + x <> Zero = x + _ <> _ = Many + +instance Monoid Multiplicity where + mempty = Zero + mappend = (Semi.<>) + +data VarUsage = VarUsage + { varUsed :: !Multiplicity + , varAssigned :: !VarValue + , varDeclared :: !VarDecl + , varDeepDeclared :: !Bool + } + +assignedMultiple :: VarUsage -> Bool +assignedMultiple VarUsage { varAssigned = AssignedMany } = True +assignedMultiple _ = False + +data SimpleRewrite = SimpleRewrite + { renameVar :: UniqMap Ident Ident + , varUsage :: UniqMap Ident VarUsage + } + +instance Semigroup VarUsage where + x <> y = VarUsage + { varUsed = varUsed x Semi.<> varUsed y + , varAssigned = varAssigned x Semi.<> varAssigned y + , varDeclared = varDeclared x Semi.<> varDeclared y + , varDeepDeclared = varDeepDeclared x || varDeepDeclared y + } + +instance Monoid VarUsage where + mempty = VarUsage Zero Unassigned NoDecl False + +disableOpt :: Bool +-- disableOpt = True +disableOpt = False + +simpleOpt :: JStat -> JStat +simpleOpt x | disableOpt = x +simpleOpt (BlockStat xs) = BlockStat (map simpleOpt xs) +simpleOpt (AssignStat lhs AssignOp (ValExpr (JFunc args body))) = + let JFunction args' body' = simpleOptFunction (JFunction args body) + in AssignStat lhs AssignOp (ValExpr (JFunc args' body')) +simpleOpt (FuncStat name args body) = + let JFunction args' body' = simpleOptFunction (JFunction args body) + in FuncStat name args' body' +simpleOpt s = s + +simpleOptFunction :: JFunction -> JFunction +simpleOptFunction jf = s_opt + where + -- we need to run it twice since floating in the first pass can + -- cause unused variables that can be removed in the second pass + s_opt = functionOptExprs $ maybe jf (`simpleRewrite` s_opt0) mb_rw + mb_rw = mkRewrite True (simpleAnalyze s_opt0) + s_opt0 = functionOptExprs $ maybe jf (`simpleRewrite` jf) mb_rw0 + mb_rw0 = mkRewrite False (simpleAnalyze jf) + +functionOptExprs :: JFunction -> JFunction +functionOptExprs (JFunction args s) = JFunction args (optExprs s) + +newLocals :: [Ident] +newLocals = filter (not . isReserved ) $ + map (TxtI . mkFastString) $ + map (:[]) chars0 ++ concatMap mkIdents [1..] + where + mkIdents n = [c0:cs | c0 <- chars0, cs <- replicateM n chars] + chars0 = ['a'..'z']++['A'..'Z'] + chars = chars0++['0'..'9'] + isReserved (TxtI i) = i `US.elementOfUniqSet` reservedSet + reservedSet = US.mkUniqSet reserved + reserved = [ -- reserved words + "abstract", "arguments", "await", "boolean" + , "break", "byte", "case", "catch" + , "char", "class", "const", "continue" + , "debugger", "default", "delete", "do" + , "double", "else", "enum", "eval" + , "export", "extends", "false", "final" + , "finally", "float", "for", "function" + , "goto", "if", "implements", "import" + , "in", "instanceof", "int", "interface" + , "let", "long", "native", "new" + , "null", "package", "private", "protected" + , "public", "return", "short", "static" + , "super", "switch", "synchronized", "this" + , "throw", "throws", "transient", "true" + , "try", "typeof", "var", "void" + , "volatile", "while", "with", "yield" + -- some special values + , "as", "async", "from", "get" + , "of", "NaN", "prototype", "undefined" + ] + +mkRewrite :: Bool -> AnalysisResult -> Maybe SimpleRewrite +mkRewrite do_rename a + | arBailout a = Nothing + | otherwise = Just $ + SimpleRewrite { renameVar = if do_rename + then UM.listToUniqMap (zip localVars newVars) + else UM.emptyUniqMap + , varUsage = vu + } + where + vu :: UM.UniqMap Ident VarUsage + vu = arVarUsage a + + -- local variables in the order that they were declared + localVars :: [Ident] + localVars = + map fst + -- recover original order and remove non-determinism + . sortBy (compare `on` snd) + . map (\(v, u) -> (v, varDeclared u)) + . filter (isDecl . varDeclared . snd) + -- non-determinism is removed by sorting afterwards + $ UM.nonDetUniqMapToList vu + -- we can't rename variables that are used in the global scope + blockedNames :: US.UniqSet Ident + blockedNames = + US.mkUniqSet $ + map fst ( + filter (\(_k,v) -> (not . isDecl) (varDeclared v) || varDeepDeclared v) + (UM.nonDetUniqMapToList vu)) + + + newVars :: [Ident] + newVars = filter (not . (`US.elementOfUniqSet` blockedNames)) newLocals + +simpleRewrite :: SimpleRewrite -> JFunction -> JFunction +simpleRewrite rw (JFunction args stat)= JFunction (map varReplace args) (go stat) + where + zeroUsed :: JExpr -> Bool + zeroUsed (ValExpr (JVar v)) = + maybe True ((== Zero) . varUsed) (UM.lookupUniqMap (varUsage rw) v) && + maybe False (isDecl . varDeclared) (UM.lookupUniqMap (varUsage rw) v) + zeroUsed _ = False + + varReplace :: Ident -> Ident + varReplace v = fromMaybe v (UM.lookupUniqMap (renameVar rw) v) + + {- + We can sometimes float down an expression to avoid an assignment: + + var x = e; + f(x); + ==> + f(e); + + This can only be done if the expression has no side effects and x is + only used once. + + Heap object property lookups cannot be floated just yet, since we + don't know whether an object is mutable or not. For example a thunk + can be blackholed, which would change the result if we float the lookup + after the blackholing. + -} + + mayBeFloated :: JExpr -> Bool + mayBeFloated (ValExpr v) = mayBeFloatedV v + mayBeFloated (SelExpr _e _) = False + mayBeFloated (IdxExpr _e1 _e2) = False + mayBeFloated (InfixExpr _ e1 e2)= mayBeFloated e1 && mayBeFloated e2 + mayBeFloated (UOpExpr _ _e) = False + mayBeFloated (IfExpr e1 e2 e3) = mayBeFloated e1 && + mayBeFloated e2 && + mayBeFloated e3 + mayBeFloated (ApplExpr e es) + | ValExpr (JVar (TxtI i)) <- e, isClosureAllocator i = all mayBeFloated es + | otherwise = False + + mayBeFloatedV :: JVal -> Bool + mayBeFloatedV (JVar v) + | Just vu <- UM.lookupUniqMap (varUsage rw) v + = isDecl (varDeclared vu) && not (assignedMultiple vu) + | otherwise = False + mayBeFloatedV (JList es) = all mayBeFloated es + mayBeFloatedV (JDouble {}) = True + mayBeFloatedV (JInt {}) = True + mayBeFloatedV (JStr {}) = True + mayBeFloatedV (JRegEx {}) = True + mayBeFloatedV (JBool {}) = True + mayBeFloatedV (JHash ps) = all (mayBeFloated . snd) + (UM.nonDetUniqMapToList ps) + mayBeFloatedV (JFunc {}) = False + + {- + we allow small literals and local variables and arguments to be + duplicated, since they tend to take up little space. + -} + mayDuplicate :: JExpr -> Bool + mayDuplicate (ValExpr (JVar i)) + | Just vu <- (UM.lookupUniqMap (varUsage rw) i) + = isLocalOrArg (varDeclared vu) + mayDuplicate (ValExpr (JInt n)) = abs n < 1000000 + mayDuplicate (ValExpr (JDouble {})) = True + mayDuplicate _ = False + + zeroAssigned :: Ident -> Bool + zeroAssigned v + | Just vu <- UM.lookupUniqMap (varUsage rw) v + = case varAssigned vu of + Unassigned -> True + _ -> False + | otherwise = False + + assignedAtMostOnce :: Ident -> Bool + assignedAtMostOnce v + | Just vu <- UM.lookupUniqMap (varUsage rw) v = + case varAssigned vu of + Unassigned -> True + AssignedOnce -> True + AssignedOnceKnown {} -> True + AssignedMany -> False + | otherwise = False + + go :: JStat -> JStat + go (DeclStat v mb_e) + | zeroUsed (ValExpr (JVar v)) = + case mb_e of + Nothing | zeroAssigned v -> BlockStat [] + | otherwise -> DeclStat (varReplace v) Nothing + Just e | not (mayHaveSideEffects e) && assignedAtMostOnce v + -> BlockStat [] + | otherwise -> DeclStat (varReplace v) (Just (goE True e)) + | otherwise = DeclStat (varReplace v) (fmap (goE True) mb_e) + go (AssignStat lhs aop e) + | ValExpr (JVar i) <- lhs, isTrivialAssignment i aop e = BlockStat [] + | zeroUsed lhs && not (mayHaveSideEffects e) = BlockStat [] + | zeroUsed lhs = AssignStat (goE False lhs) aop (goE True e) + | otherwise = AssignStat (goE False lhs) aop (goE True e) + go (ReturnStat e) = ReturnStat (goE True e) + go (BlockStat ss) = flattenBlock (map go ss) + go (IfStat e s1 s2) = IfStat (goE True e) (go s1) (go s2) + go (WhileStat b e s) = WhileStat b (goE True e) (go s) + go (ForStat s1 e s2 s3) = ForStat (go s1) (goE True e) (go s2) (go s3) + go (ForInStat b v e s) = ForInStat b (varReplace v) (goE True e) (go s) + go (SwitchStat e cases s) = SwitchStat (goE True e) + (map (\(c,cs) -> (c, go cs)) cases) + (go s) + go (TryStat s1 v s2 s3) = TryStat (go s1) (varReplace v) (go s2) (go s3) + go (ApplStat e es) = ApplStat (goE True e) (map (goE True) es) + go (UOpStat uop e) = UOpStat uop (goE False e) + go (LabelStat lbl s) = LabelStat lbl (go s) + go s@(BreakStat {}) = s + go s@(ContinueStat {}) = s + go (FuncStat i args s) = FuncStat i (map varReplace args) (go s) + + goE :: Bool -> JExpr -> JExpr + goE rhs (ValExpr (JVar v)) + | rhs + , Just vu <- UM.lookupUniqMap (varUsage rw) v + , AssignedOnceKnown ee <- varAssigned vu + , varUsed vu == One || mayDuplicate ee + , isDecl (varDeclared vu) + , mayBeFloated ee + = goE rhs ee + goE _rhs (ValExpr v) = ValExpr (goV v) + goE rhs (SelExpr e i) = SelExpr (goE rhs e) i + goE rhs (IdxExpr e1 e2) = IdxExpr (goE rhs e1) (goE rhs e2) + goE rhs (InfixExpr op e1 e2) = InfixExpr op (goE rhs e1) (goE rhs e2) + goE rhs (UOpExpr op e) = UOpExpr op (goE rhs e) + goE rhs (IfExpr e1 e2 e3) = IfExpr (goE rhs e1) (goE rhs e2) (goE rhs e3) + goE rhs (ApplExpr e es) = ApplExpr (goE rhs e) (map (goE rhs) es) + + goV :: JVal -> JVal + goV (JVar v) = JVar (varReplace v) + goV (JList es) = JList (map (goE True) es) + goV (JHash ps) = JHash (fmap (goE True) ps) + goV v@(JFunc {}) = v + goV v@(JDouble {}) = v + goV v@(JInt {}) = v + goV v@(JStr {}) = v + goV v@(JRegEx {}) = v + goV v@(JBool {}) = v + +flattenBlock :: [JStat] -> JStat +flattenBlock stats = + case filter (/= BlockStat []) stats of + [] -> BlockStat [] + [s] -> s + ss -> BlockStat ss + +data AnalysisResult = AnalysisResult + { arBailout :: !Bool + , arVarUsage :: !(UniqMap Ident VarUsage) + , arDeclaredCount :: !Int + } + +simpleAnalyze :: JFunction -> AnalysisResult +simpleAnalyze (JFunction args body) = go False (AnalysisResult False start 0) body + where + start :: UniqMap Ident VarUsage + start = UM.listToUniqMap + $ zipWith (\n v -> (v, VarUsage Zero Unassigned (ArgDecl n) False)) + [0..] + args + + add :: Ident -> VarUsage -> AnalysisResult -> AnalysisResult + add i vu m = m { arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu } + + + declare :: Bool -> Ident -> Maybe JExpr -> AnalysisResult -> AnalysisResult + declare True i _assign m = -- declaration in deeper scope + let vu = VarUsage Zero AssignedMany NoDecl True + in m { arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu} + declare False i assign m = -- declaration in analyzed scope + let count = arDeclaredCount m + !newCount + | Just (VarUsage _ _ (LocalDecl _) _) <- + UM.lookupUniqMap (arVarUsage m) i = count -- already declared + | otherwise = count + 1 + vassign | Just e <- assign = AssignedOnceKnown e + | otherwise = Unassigned + !vu = VarUsage Zero vassign (LocalDecl count) False + in m { arDeclaredCount = newCount + , arVarUsage = UM.addToUniqMap_C (Semi.<>) (arVarUsage m) i vu + } + + go :: Bool -> AnalysisResult -> JStat -> AnalysisResult + go deep u (DeclStat v mb_e) = + case mb_e of + Nothing -> declare deep v mb_e u + Just e -> declare deep v mb_e (goE u e) + go _deep u (AssignStat (ValExpr (JVar v)) aop e) = + let use = case aop of + AssignOp -> Zero + _ -> One + in add v (VarUsage use (AssignedOnceKnown e) NoDecl False) (goE u e) + go _deep u (AssignStat lhs _aop rhs) = goE (goE u lhs) rhs + go _deep u (ReturnStat e) = goE u e + go deep u (BlockStat ss) = foldl' (go deep) u ss + go deep u (IfStat e s1 s2) = go deep (go deep (goE u e) s1) s2 + go deep u (WhileStat _b e s) = go deep (goE u e) s + go deep u (ForStat s1 e s2 s3) + = go deep (go deep (goE (go deep u s1) e) s2) s3 + go deep u (ForInStat b v e s) = + let !u' = if b then declare deep v Nothing u else u + in add v (VarUsage Zero AssignedMany NoDecl True) + (go deep (go deep (goE u' e) s) s) + go deep u (SwitchStat e cases s) + = go deep (goE (foldl' (go deep) u (map snd cases)) e) s + go deep u (TryStat s1 v s2 s3) + = add v (VarUsage Zero AssignedMany NoDecl True) + (go deep (go deep (go deep u s1) s2) s3) + go _deep u (ApplStat e es) + | (ValExpr (JVar (TxtI i))) <- e, i == "eval" = u { arBailout = True } + | otherwise = foldl' goE (goE u e) es + go _deep u (UOpStat op e) + | ValExpr (JVar v) <- e + , op `elem` [PreIncOp, PostIncOp, PreDecOp, PostDecOp] = + add v (VarUsage One AssignedOnce NoDecl False) u + | otherwise = goE u e + go deep u (LabelStat _ s) = go deep u s + go _deep u (BreakStat _) = u + go _deep u (ContinueStat _) = u + go _deep u (FuncStat _ vs s) + = go True (foldl' (\u v -> add v (VarUsage Zero AssignedOnce NoDecl True) u) u vs) s + + goE :: AnalysisResult -> JExpr -> AnalysisResult + goE u (ValExpr v) = goV u v + goE u (SelExpr e _i) = goE u e + goE u (IdxExpr e1 e2) = goE (goE u e1) e2 + goE u (InfixExpr _ e1 e2) = goE (goE u e1) e2 + goE u (UOpExpr _ e) = goE u e + goE u (IfExpr e1 e2 e3) = goE (goE (goE u e1) e2) e3 + goE u (ApplExpr e es) + | (ValExpr (JVar (TxtI i))) <- e, i == "eval" = u { arBailout = True } + | otherwise = foldl' goE (goE u e) es + + goV :: AnalysisResult -> JVal -> AnalysisResult + goV u (JVar v) = add v (VarUsage One Unassigned NoDecl False) u + goV u (JList es) = foldl' goE u es + goV u (JDouble _) = u + goV u (JInt _) = u + goV u (JStr _) = u + goV u (JRegEx _) = u + goV u (JBool _) = u + goV u (JHash ps) = foldl' goE u (map snd $ UM.nonDetUniqMapToList ps) + goV u (JFunc vs s) + = go True (foldl (\u v -> add v (VarUsage Zero AssignedOnce NoDecl True) u) u vs) s + +-- | A trivial assignment is an assignment of a variable to itself: x = x +isTrivialAssignment :: Ident -> AOp -> JExpr -> Bool +isTrivialAssignment v AssignOp (ValExpr (JVar v')) = v == v' +isTrivialAssignment _ _ _ = False + +-- | Does the expression have side effects? +-- +-- This only returns False if the expression definitely does not have side +-- effects, i.e. it can be removed without changing the semantics if the +-- result is not used. +-- +-- Note: We have some assumptions here about Haskell RTS related values, which +-- may not be true for all JavaScript code. We should really replace +-- these with explicit nodes or annotations in the AST. +-- +mayHaveSideEffects :: JExpr -> Bool +-- special cases for Haskell things. These should really be special operations +-- in the AST: +-- 1. stack indexing does not have side effects +mayHaveSideEffects (IdxExpr (ValExpr (JVar (TxtI i))) e) + | i == "h$stack" = mayHaveSideEffects e +-- 2. we assume that x.d1, x.d2, ... are heap object property lookups, +-- which do not have side effects +mayHaveSideEffects (SelExpr e (TxtI i)) + | isHeapObjectProperty i = mayHaveSideEffects e + +-- general cases (no Haskell RTS specific assumptions here): +mayHaveSideEffects (ValExpr v) = mayHaveSideEffectsV v +mayHaveSideEffects (SelExpr {}) = True +mayHaveSideEffects (IdxExpr {}) = True +mayHaveSideEffects (UOpExpr uop e) = uo || mayHaveSideEffects e + where + uo = case uop of + NotOp -> False + BNotOp -> False + NegOp -> False + PlusOp -> False + TypeofOp -> False + _ -> True +mayHaveSideEffects (InfixExpr _o e1 e2) = + mayHaveSideEffects e1 || mayHaveSideEffects e2 +mayHaveSideEffects (IfExpr e1 e2 e3) = + mayHaveSideEffects e1 || mayHaveSideEffects e2 || mayHaveSideEffects e3 +mayHaveSideEffects (ApplExpr {}) = True + +mayHaveSideEffectsV :: JVal -> Bool +mayHaveSideEffectsV (JVar {}) = False +mayHaveSideEffectsV (JList es) = any mayHaveSideEffects es +mayHaveSideEffectsV (JDouble {}) = False +mayHaveSideEffectsV (JInt {}) = False +mayHaveSideEffectsV (JStr {}) = False +mayHaveSideEffectsV (JRegEx {}) = False +mayHaveSideEffectsV (JBool {}) = False +mayHaveSideEffectsV (JHash ps) = UM.anyUniqMap mayHaveSideEffects ps +mayHaveSideEffectsV (JFunc {}) = True + +isHeapObjectProperty :: FastString -> Bool +isHeapObjectProperty "d1" = True +isHeapObjectProperty "d2" = True +isHeapObjectProperty "d3" = True +isHeapObjectProperty "d4" = True +isHeapObjectProperty "d5" = True +isHeapObjectProperty "d6" = True +isHeapObjectProperty "d7" = True +isHeapObjectProperty "d8" = True +isHeapObjectProperty "d9" = True +isHeapObjectProperty "d10" = True +isHeapObjectProperty "d11" = True +isHeapObjectProperty "d12" = True +isHeapObjectProperty "d13" = True +isHeapObjectProperty "d14" = True +isHeapObjectProperty "d15" = True +isHeapObjectProperty "d16" = True +isHeapObjectProperty "d17" = True +isHeapObjectProperty "d18" = True +isHeapObjectProperty "d19" = True +isHeapObjectProperty "d20" = True +isHeapObjectProperty "d21" = True +isHeapObjectProperty "d22" = True +isHeapObjectProperty "d23" = True +isHeapObjectProperty "d24" = True + +isHeapObjectProperty _ = False + +isClosureAllocator :: FastString -> Bool +isClosureAllocator "h$c1" = True +isClosureAllocator "h$c2" = True +isClosureAllocator "h$c3" = True +isClosureAllocator "h$c4" = True +isClosureAllocator "h$c5" = True +isClosureAllocator "h$c6" = True +isClosureAllocator "h$c7" = True +isClosureAllocator "h$c8" = True +isClosureAllocator "h$c9" = True +isClosureAllocator "h$c10" = True +isClosureAllocator "h$c11" = True +isClosureAllocator "h$c12" = True +isClosureAllocator "h$c13" = True +isClosureAllocator "h$c14" = True +isClosureAllocator "h$c15" = True +isClosureAllocator "h$c16" = True +isClosureAllocator "h$c17" = True +isClosureAllocator "h$c18" = True +isClosureAllocator "h$c19" = True +isClosureAllocator "h$c20" = True +isClosureAllocator "h$c21" = True +isClosureAllocator "h$c22" = True +isClosureAllocator "h$c23" = True +isClosureAllocator "h$c24" = True +isClosureAllocator _ = False diff --git a/GHC/JS/Optimizer.hs b/GHC/JS/Optimizer.hs --- a/GHC/JS/Optimizer.hs +++ b/GHC/JS/Optimizer.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, OverloadedStrings #-} ----------------------------------------------------------------------------- -- | @@ -46,6 +46,8 @@ import Control.Arrow +import qualified GHC.JS.Opt.Simple as Simple + {- Note [Unsafe JavaScript optimizations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -85,9 +87,12 @@ -- Top level Driver -------------------------------------------------------------------------------- jsOptimize :: JStat -> JStat -jsOptimize = go +jsOptimize s0 = jsOptimizeStat (Simple.simpleOpt s0) + +jsOptimizeStat :: JStat -> JStat +jsOptimizeStat s0 = go s0 where - p_opt = jsOptimize + p_opt = jsOptimizeStat opt = jsOptimize' e_opt = jExprOptimize -- base case @@ -147,7 +152,7 @@ -- | drive optimizations to anonymous functions and over expressions jValOptimize :: JVal -> JVal -- base case -jValOptimize (JFunc args body) = JFunc args (jsOptimize body) +jValOptimize (JFunc args body) = JFunc args (jsOptimizeStat body) -- recursive cases jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) @@ -157,6 +162,7 @@ jValOptimize x@JInt{} = x jValOptimize x@JStr{} = x jValOptimize x@JRegEx{} = x +jValOptimize x@JBool{} = x -- | A block transformation is a function from a stream of syntax to another -- stream @@ -193,11 +199,7 @@ -- this call to jsOptimize is required or else the optimizer will not -- properly recur down JStat. See the 'deadCodeElim' test for examples which -- were failing before this change - (x:xs) -> next (jsOptimize x : loop xs) - --------------------------------------------------------------------------------- --- Single Slot Optimizations --------------------------------------------------------------------------------- + (x:xs) -> next (jsOptimizeStat x : loop xs) {- | Catch modify and assign operators: @@ -212,9 +214,26 @@ -} combineOps :: BlockOpt combineOps = BlockOpt $ \loop next -> - \case - -- find a op pattern, and rerun the optimizer on its result unless there is + -- find an op pattern, and rerun the optimizer on its result unless there is -- nothing to optimize, in which case call the next optimization + \case + -- var x = expr; return x; ==> return expr; + (DeclStat i (Just e) : ReturnStat (ValExpr (JVar i')) : xs) + | i == i' -> loop $ ReturnStat e : xs + + -- x = expr; return x; ==> return expr; + (AssignStat (ValExpr (JVar i)) AssignOp e : ReturnStat (ValExpr (JVar i')) : xs) + | i == i' -> loop $ ReturnStat e : xs + + -- h$sp -= 2; h$sp += 5; ==> h$sp += 3; + (op1 : op2 : xs) + | Just s1 <- isStackAdjust op1 + , Just s2 <- isStackAdjust op2 -> loop $ mkStackAdjust (s1 + s2) ++ xs + + -- x = x + 1; ==> ++x; + -- x = x - 1; ==> --x; + -- x = x + n; ==> x += n; + -- x = x - n; ==> x -= n; (unchanged@(AssignStat ident@(ValExpr (JVar i)) AssignOp @@ -232,18 +251,13 @@ (InfixExpr op e (ValExpr (JVar i')))) : xs) | i == i' -> case (op, e) of (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs - (SubOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreDecOp ident : xs (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs - (SubOp, e') -> loop $ AssignStat ident SubAssignOp e' : xs _ -> next $ unchanged : xs -- general case, we had nothing to optimize in this case so call the next -- optimization xs -> next xs --------------------------------------------------------------------------------- --- Dual Slot Optimizations --------------------------------------------------------------------------------- -- | Catch 'var i; i = q;' ==> 'var i = q;' declareAssign :: BlockOpt declareAssign = BlockOpt $ @@ -268,3 +282,30 @@ flattenBlocks (BlockStat y : ys) = flattenBlocks y ++ flattenBlocks ys flattenBlocks (x:xs) = x : flattenBlocks xs flattenBlocks [] = [] + +-- | stack adjustments +sp :: JExpr +sp = ValExpr (JVar (TxtI "h$sp")) + +isStackAdjust :: JStat -> Maybe Integer +isStackAdjust (UOpStat op (ValExpr (JVar (TxtI "h$sp")))) + | op == PreIncOp || op == PostIncOp = Just 1 +isStackAdjust (UOpStat op (ValExpr (JVar (TxtI "h$sp")))) + | op == PreDecOp || op == PostDecOp = Just (-1) +isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) op (ValExpr (JInt n))) + | op == AddAssignOp = Just n + | op == SubAssignOp = Just (-n) +isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) AssignOp (InfixExpr op (ValExpr (JVar (TxtI "h$sp"))) (ValExpr (JInt n)))) + | op == AddOp = Just n + | op == SubOp = Just (-n) +isStackAdjust (AssignStat (ValExpr (JVar (TxtI "h$sp"))) AssignOp (InfixExpr AddOp (ValExpr (JInt n)) (ValExpr (JVar (TxtI "h$sp"))))) + = Just n +isStackAdjust _ = Nothing + +mkStackAdjust :: Integer -> [JStat] +mkStackAdjust 0 = [] +mkStackAdjust 1 = [UOpStat PostIncOp sp] +mkStackAdjust (-1) = [UOpStat PostDecOp sp] +mkStackAdjust x + | x < 0 = [AssignStat sp AssignOp (InfixExpr SubOp sp (ValExpr (JInt (-x))))] + | otherwise = [AssignStat sp AssignOp (InfixExpr AddOp sp (ValExpr (JInt x)))] diff --git a/GHC/JS/Ppr.hs b/GHC/JS/Ppr.hs --- a/GHC/JS/Ppr.hs +++ b/GHC/JS/Ppr.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE TypeApplications #-} -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-} @@ -34,7 +33,7 @@ -- * Design -- -- This module follows the architecture and style of the other backends in --- GHC: it intances Outputable for the relevant types, creates a class that +-- GHC: it instances Outputable for the relevant types, creates a class that -- describes a morphism from the IR domain to JavaScript concrete Syntax and -- then generates that syntax on a case by case basis. -- @@ -67,15 +66,15 @@ import GHC.Prelude +import GHC.JS.Ident import GHC.JS.Syntax -import GHC.JS.Transform - import Data.Char (isControl, ord) import Data.List (sortOn) import Numeric(showHex) +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Unique.Map @@ -117,10 +116,10 @@ -- | Render a syntax tree as a pretty-printable document, using a given prefix -- to all generated names. Use this with distinct prefixes to ensure distinct -- generated names between independent calls to render(Prefix)Js. -renderPrefixJs :: (JsToDoc a, JMacro a) => a -> SDoc +renderPrefixJs :: (JsToDoc a) => a -> SDoc renderPrefixJs = renderPrefixJs' defaultRenderJs -renderPrefixJs' :: (JsToDoc a, JMacro a, JsRender doc) => RenderJs doc -> a -> doc +renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc renderPrefixJs' r = jsToDocR r -------------------------------------------------------------------------------- @@ -172,7 +171,7 @@ SwitchStat e l d -> hangBrace (text "switch" <+?> parens (jsToDocR r e)) cases where l' = map (\(c,s) -> (text "case" <+?> parens (jsToDocR r c) <> colon) $$$ jnest (optBlock r s)) l ++ [(text "default:") $$$ jnest (optBlock r d)] - cases = foldl1 ($$$) l' + cases = foldl1 ($$$) $ expectNonEmpty l' ReturnStat e -> text "return" <+> jsToDocR r e ApplStat e es -> jsToDocR r e <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) es) FuncStat i is b -> hangBrace (text "function" <+> jsToDocR r i @@ -237,6 +236,7 @@ | otherwise -> integer i JStr s -> pprStringLit s JRegEx s -> char '/' <> ftext s <> char '/' + JBool b -> text (if b then "true" else "false") JHash m | isNullUniqMap m -> text "{}" | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma . @@ -247,7 +247,7 @@ JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc -defRenderJsI _ (TxtI t) = ftext t +defRenderJsI _ t = ftext (identFS t) aOpText :: AOp -> FastString aOpText = \case diff --git a/GHC/JS/Syntax.hs b/GHC/JS/Syntax.hs --- a/GHC/JS/Syntax.hs +++ b/GHC/JS/Syntax.hs @@ -37,7 +37,7 @@ -- -- * Strategy -- --- Nothing fancy in this module, this is a classic deeply embeded AST for +-- Nothing fancy in this module, this is a classic deeply embedded AST for -- JS. We define numerous ADTs and pattern synonyms to make pattern matching -- and constructing ASTs easier. -- @@ -62,40 +62,41 @@ , Ident(..) , JLabel -- * pattern synonyms over JS operators - , pattern JNew - , pattern JNot - , pattern JNegate - , pattern JAdd - , pattern JSub - , pattern JMul - , pattern JDiv - , pattern JMod - , pattern JBOr - , pattern JBAnd - , pattern JBXor - , pattern JBNot - , pattern JLOr - , pattern JLAnd - , pattern SatInt - , pattern JString - , pattern JPreInc - , pattern JPostInc - , pattern JPreDec - , pattern JPostDec + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern Var + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec -- * Utility , SaneDouble(..) - , jassignAll - , jassignAllEqual - , jvar + , var + , true_ + , false_ ) where import GHC.Prelude -import GHC.JS.Unsat.Syntax (Ident(..)) +import GHC.JS.Ident + import GHC.Data.FastString import GHC.Types.Unique.Map import GHC.Types.SaneDouble -import GHC.Utils.Misc import Control.DeepSeq @@ -128,7 +129,7 @@ | BreakStat (Maybe JLabel) -- ^ Break | ContinueStat (Maybe JLabel) -- ^ Continue | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition - deriving (Eq, Typeable, Generic) + deriving (Eq, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of -- course 'LabelStat' @@ -167,93 +168,96 @@ | UOpExpr UOp JExpr -- ^ Unary Expressions | IfExpr JExpr JExpr JExpr -- ^ If-expression | ApplExpr JExpr [JExpr] -- ^ Application - deriving (Eq, Typeable, Generic) + deriving (Eq, Generic) -- * Useful pattern synonyms to ease programming with the deeply embedded JS --- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and +-- AST. Each pattern wraps @UOp@ and @Op@ into a @JExpr@s to save typing and -- for convienience. In addition we include a string wrapper for JS string -- and Integer literals. -- | pattern synonym for a unary operator new -pattern JNew :: JExpr -> JExpr -pattern JNew x = UOpExpr NewOp x +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x -- | pattern synonym for prefix increment @++x@ -pattern JPreInc :: JExpr -> JExpr -pattern JPreInc x = UOpExpr PreIncOp x +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x -- | pattern synonym for postfix increment @x++@ -pattern JPostInc :: JExpr -> JExpr -pattern JPostInc x = UOpExpr PostIncOp x +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x -- | pattern synonym for prefix decrement @--x@ -pattern JPreDec :: JExpr -> JExpr -pattern JPreDec x = UOpExpr PreDecOp x +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x -- | pattern synonym for postfix decrement @--x@ -pattern JPostDec :: JExpr -> JExpr -pattern JPostDec x = UOpExpr PostDecOp x +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x -- | pattern synonym for logical not @!@ -pattern JNot :: JExpr -> JExpr -pattern JNot x = UOpExpr NotOp x +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x -- | pattern synonym for unary negation @-@ -pattern JNegate :: JExpr -> JExpr -pattern JNegate x = UOpExpr NegOp x +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x -- | pattern synonym for addition @+@ -pattern JAdd :: JExpr -> JExpr -> JExpr -pattern JAdd x y = InfixExpr AddOp x y +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y -- | pattern synonym for subtraction @-@ -pattern JSub :: JExpr -> JExpr -> JExpr -pattern JSub x y = InfixExpr SubOp x y +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y -- | pattern synonym for multiplication @*@ -pattern JMul :: JExpr -> JExpr -> JExpr -pattern JMul x y = InfixExpr MulOp x y +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y -- | pattern synonym for division @*@ -pattern JDiv :: JExpr -> JExpr -> JExpr -pattern JDiv x y = InfixExpr DivOp x y +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y -- | pattern synonym for remainder @%@ -pattern JMod :: JExpr -> JExpr -> JExpr -pattern JMod x y = InfixExpr ModOp x y +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y -- | pattern synonym for Bitwise Or @|@ -pattern JBOr :: JExpr -> JExpr -> JExpr -pattern JBOr x y = InfixExpr BOrOp x y +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y -- | pattern synonym for Bitwise And @&@ -pattern JBAnd :: JExpr -> JExpr -> JExpr -pattern JBAnd x y = InfixExpr BAndOp x y +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y -- | pattern synonym for Bitwise XOr @^@ -pattern JBXor :: JExpr -> JExpr -> JExpr -pattern JBXor x y = InfixExpr BXorOp x y +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y -- | pattern synonym for Bitwise Not @~@ -pattern JBNot :: JExpr -> JExpr -pattern JBNot x = UOpExpr BNotOp x +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x -- | pattern synonym for logical Or @||@ -pattern JLOr :: JExpr -> JExpr -> JExpr -pattern JLOr x y = InfixExpr LOrOp x y +pattern LOr :: JExpr -> JExpr -> JExpr +pattern LOr x y = InfixExpr LOrOp x y -- | pattern synonym for logical And @&&@ -pattern JLAnd :: JExpr -> JExpr -> JExpr -pattern JLAnd x y = InfixExpr LAndOp x y +pattern LAnd :: JExpr -> JExpr -> JExpr +pattern LAnd x y = InfixExpr LAndOp x y -- | pattern synonym to create integer values -pattern SatInt :: Integer -> JExpr -pattern SatInt x = ValExpr (JInt x) +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) -- | pattern synonym to create string values -pattern JString :: FastString -> JExpr -pattern JString x = ValExpr (JStr x) +pattern String :: FastString -> JExpr +pattern String x = ValExpr (JStr x) +-- | pattern synonym to create a local variable reference +pattern Var :: Ident -> JExpr +pattern Var x = ValExpr (JVar x) -------------------------------------------------------------------------------- -- Values @@ -267,9 +271,10 @@ | JInt Integer -- ^ A BigInt | JStr FastString -- ^ A String | JRegEx FastString -- ^ A Regex + | JBool Bool -- ^ A Boolean | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ | JFunc [Ident] JStat -- ^ A function - deriving (Eq, Typeable, Generic) + deriving (Eq, Generic) -------------------------------------------------------------------------------- @@ -302,7 +307,7 @@ | LOrOp -- ^ Logical Or: || | InstanceofOp -- ^ @instanceof@ | InOp -- ^ @in@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Enum, Data, Generic) instance NFData Op @@ -321,7 +326,7 @@ | PostIncOp -- ^ Postfix Increment: @x++@ | PreDecOp -- ^ Prefix Decrement: @--x@ | PostDecOp -- ^ Postfix Decrement: @x--@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Enum, Data, Generic) instance NFData UOp @@ -330,22 +335,18 @@ = AssignOp -- ^ Vanilla Assignment: = | AddAssignOp -- ^ Addition Assignment: += | SubAssignOp -- ^ Subtraction Assignment: -= - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Enum, Data, Generic) instance NFData AOp --------------------------------------------------------------------------------- --- Helper Functions --------------------------------------------------------------------------------- - -jassignAllEqual :: [JExpr] -> [JExpr] -> JStat -jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys) - where go l r = AssignStat l AssignOp r - -jassignAll :: [JExpr] -> [JExpr] -> JStat -jassignAll xs ys = mconcat $ zipWith go xs ys - where go l r = AssignStat l AssignOp r +-- | construct a JS variable reference +var :: FastString -> JExpr +var = Var . name -jvar :: FastString -> JExpr -jvar = ValExpr . JVar . TxtI +-- | The JS literal 'true' +true_ :: JExpr +true_ = ValExpr (JBool True) +-- | The JS literal 'false' +false_ :: JExpr +false_ = ValExpr (JBool False) diff --git a/GHC/JS/Transform.hs b/GHC/JS/Transform.hs --- a/GHC/JS/Transform.hs +++ b/GHC/JS/Transform.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,298 +11,168 @@ ( identsS , identsV , identsE - -- * Saturation - , satJStat - , satJExpr - -- * Generic traversal (via compos) - , JMacro(..) - , JMGadt(..) - , Compos(..) - , composOp - , composOpM - , composOpM_ - , composOpFold + , jStgExprToJS + , jStgStatToJS ) where import GHC.Prelude -import qualified GHC.JS.Syntax as Sat -import GHC.JS.Unsat.Syntax +import GHC.JS.Ident +import GHC.JS.JStg.Syntax +import qualified GHC.JS.Syntax as JS -import Data.Functor.Identity -import Control.Monad import Data.List (sortBy) import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map import GHC.Types.Unique.FM {-# INLINE identsS #-} -identsS :: Sat.JStat -> [Ident] +identsS :: JStgStat -> [Ident] identsS = \case - Sat.DeclStat i e -> [i] ++ maybe [] identsE e - Sat.ReturnStat e -> identsE e - Sat.IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 - Sat.WhileStat _ e s -> identsE e ++ identsS s - Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body - Sat.ForInStat _ i e s -> [i] ++ identsE e ++ identsS s - Sat.SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s - where traverseCase (e,s) = identsE e ++ identsS s - Sat.TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 - Sat.BlockStat xs -> concatMap identsS xs - Sat.ApplStat e es -> identsE e ++ concatMap identsE es - Sat.UOpStat _op e -> identsE e - Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2 - Sat.LabelStat _l s -> identsS s - Sat.BreakStat{} -> [] - Sat.ContinueStat{} -> [] - Sat.FuncStat i args body -> [i] ++ args ++ identsS body + DeclStat i e -> [i] ++ maybe [] identsE e + ReturnStat e -> identsE e + IfStat e s1 s2 -> identsE e ++ identsS s1 ++ identsS s2 + WhileStat _ e s -> identsE e ++ identsS s + ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body + ForInStat _ i e s -> [i] ++ identsE e ++ identsS s + SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s + where traverseCase (e,s) = identsE e ++ identsS s + TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 + BlockStat xs -> concatMap identsS xs + ApplStat e es -> identsE e ++ concatMap identsE es + UOpStat _op e -> identsE e + AssignStat e1 _op e2 -> identsE e1 ++ identsE e2 + LabelStat _l s -> identsS s + BreakStat{} -> [] + ContinueStat{} -> [] + FuncStat i args body -> [i] ++ args ++ identsS body {-# INLINE identsE #-} -identsE :: Sat.JExpr -> [Ident] +identsE :: JStgExpr -> [Ident] identsE = \case - Sat.ValExpr v -> identsV v - Sat.SelExpr e _i -> identsE e -- do not rename properties - Sat.IdxExpr e1 e2 -> identsE e1 ++ identsE e2 - Sat.InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 - Sat.UOpExpr _ e -> identsE e - Sat.IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 - Sat.ApplExpr e es -> identsE e ++ concatMap identsE es + ValExpr v -> identsV v + SelExpr e _i -> identsE e -- do not rename properties + IdxExpr e1 e2 -> identsE e1 ++ identsE e2 + InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 + UOpExpr _ e -> identsE e + IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 + ApplExpr e es -> identsE e ++ concatMap identsE es {-# INLINE identsV #-} -identsV :: Sat.JVal -> [Ident] +identsV :: JVal -> [Ident] identsV = \case - Sat.JVar i -> [i] - Sat.JList xs -> concatMap identsE xs - Sat.JDouble{} -> [] - Sat.JInt{} -> [] - Sat.JStr{} -> [] - Sat.JRegEx{} -> [] - Sat.JHash m -> concatMap identsE (nonDetEltsUniqMap m) - Sat.JFunc args s -> args ++ identsS s - - -{-------------------------------------------------------------------- - Compos ---------------------------------------------------------------------} --- | Compos and ops for generic traversal as defined over --- the JMacro ADT. - --- | Utility class to coerce the ADT into a regular structure. - -class JMacro a where - jtoGADT :: a -> JMGadt a - jfromGADT :: JMGadt a -> a - -instance JMacro Ident where - jtoGADT = JMGId - jfromGADT (JMGId x) = x - -instance JMacro JStat where - jtoGADT = JMGStat - jfromGADT (JMGStat x) = x - -instance JMacro JExpr where - jtoGADT = JMGExpr - jfromGADT (JMGExpr x) = x - -instance JMacro JVal where - jtoGADT = JMGVal - jfromGADT (JMGVal x) = x - --- | Union type to allow regular traversal by compos. -data JMGadt a where - JMGId :: Ident -> JMGadt Ident - JMGStat :: JStat -> JMGadt JStat - JMGExpr :: JExpr -> JMGadt JExpr - JMGVal :: JVal -> JMGadt JVal - -composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b -composOp f = runIdentity . composOpM (Identity . f) - -composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b) -composOpM = compos return ap - -composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m () -composOpM_ = composOpFold (return ()) (>>) - -composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b -composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f) - -newtype C b a = C { unC :: b } - -class Compos t where - compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) - -> (forall a. t a -> m (t a)) -> t c -> m (t c) - -instance Compos JMGadt where - compos = jmcompos - -jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c) -jmcompos ret app f' v = - case v of - JMGId _ -> ret v - JMGStat v' -> ret JMGStat `app` case v' of - DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e - ReturnStat i -> ret ReturnStat `app` f i - IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' - WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s - ForStat init p step body -> ret ForStat `app` f init `app` f p - `app` f step `app` f body - ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s - SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d - where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l - BlockStat xs -> ret BlockStat `app` mapM' f xs - ApplStat e xs -> ret ApplStat `app` f e `app` mapM' f xs - TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2 - UOpStat o e -> ret (UOpStat o) `app` f e - AssignStat e e' -> ret AssignStat `app` f e `app` f e' - UnsatBlock _ -> ret v' - ContinueStat l -> ret (ContinueStat l) - FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body - BreakStat l -> ret (BreakStat l) - LabelStat l s -> ret (LabelStat l) `app` f s - JMGExpr v' -> ret JMGExpr `app` case v' of - ValExpr e -> ret ValExpr `app` f e - SelExpr e e' -> ret SelExpr `app` f e `app` f e' - IdxExpr e e' -> ret IdxExpr `app` f e `app` f e' - InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e' - UOpExpr o e -> ret (UOpExpr o) `app` f e - IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e'' - ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs - UnsatExpr _ -> ret v' - JMGVal v' -> ret JMGVal `app` case v' of - JVar i -> ret JVar `app` f i - JList xs -> ret JList `app` mapM' f xs - JDouble _ -> ret v' - JInt _ -> ret v' - JStr _ -> ret v' - JRegEx _ -> ret v' - JHash m -> ret JHash `app` m' - -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the - -- elements are treated independently before being re-added to a UniqMap - where (ls, vs) = unzip (nonDetUniqMapToList m) - m' = ret (listToUniqMap . zip ls) `app` mapM' f vs - JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s - UnsatVal _ -> ret v' - - where - mapM' :: forall a. (a -> m a) -> [a] -> m [a] - mapM' g = foldr (app . app (ret (:)) . g) (ret []) - mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a) - mapMaybeM' g = \case - Nothing -> ret Nothing - Just a -> app (ret Just) (g a) - f :: forall b. JMacro b => b -> m b - f x = ret jfromGADT `app` f' (jtoGADT x) - -{-------------------------------------------------------------------- - Saturation ---------------------------------------------------------------------} - --- | Given an optional prefix, fills in all free variable names with a supply --- of names generated by the prefix. -satJStat :: Maybe FastString -> JStat -> Sat.JStat -satJStat str x = evalState (jsSaturateS x) (newIdentSupply str) - -satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr -satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str) + JVar i -> [i] + JList xs -> concatMap identsE xs + JDouble{} -> [] + JInt{} -> [] + JStr{} -> [] + JRegEx{} -> [] + JBool{} -> [] + JHash m -> concatMap identsE (nonDetEltsUniqMap m) + JFunc args s -> args ++ identsS s -jsSaturateS :: JStat -> State [Ident] Sat.JStat -jsSaturateS = \case - DeclStat i rhs -> Sat.DeclStat i <$> mapM jsSaturateE rhs - ReturnStat e -> Sat.ReturnStat <$> jsSaturateE e - IfStat c t e -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e - WhileStat is_do c e -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e - ForStat init p step body -> Sat.ForStat <$> jsSaturateS init <*> jsSaturateE p - <*> jsSaturateS step <*> jsSaturateS body - ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body - SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct - <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps - <*> jsSaturateS def - TryStat t i c f -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f - BlockStat bs -> fmap Sat.BlockStat $! mapM jsSaturateS bs - ApplStat rator rand -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand - UOpStat rator rand -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand - AssignStat lhs rhs -> Sat.AssignStat <$> jsSaturateE lhs <*> pure Sat.AssignOp <*> jsSaturateE rhs - LabelStat lbl stmt -> Sat.LabelStat lbl <$> jsSaturateS stmt - BreakStat m_l -> return $ Sat.BreakStat $! m_l - ContinueStat m_l -> return $ Sat.ContinueStat $! m_l - FuncStat i args body -> Sat.FuncStat i args <$> jsSaturateS body - UnsatBlock us -> jsSaturateS =<< runIdentSupply us +-------------------------------------------------------------------------------- +-- Translation +-- +-------------------------------------------------------------------------------- +jStgStatToJS :: JStgStat -> JS.JStat +jStgStatToJS = \case + DeclStat i rhs -> JS.DeclStat i $ fmap jStgExprToJS rhs + ReturnStat e -> JS.ReturnStat $ jStgExprToJS e + IfStat c t e -> JS.IfStat (jStgExprToJS c) (jStgStatToJS t) (jStgStatToJS e) + WhileStat is_do c e -> JS.WhileStat is_do (jStgExprToJS c) (jStgStatToJS e) + ForStat init p step body -> JS.ForStat (jStgStatToJS init) (jStgExprToJS p) + (jStgStatToJS step) (jStgStatToJS body) + ForInStat is_each i iter body -> JS.ForInStat (is_each) i (jStgExprToJS iter) (jStgStatToJS body) + SwitchStat struct ps def -> JS.SwitchStat + (jStgExprToJS struct) + (map (\(p1, p2) -> (jStgExprToJS p1, jStgStatToJS p2)) ps) + (jStgStatToJS def) + TryStat t i c f -> JS.TryStat (jStgStatToJS t) i (jStgStatToJS c) (jStgStatToJS f) + BlockStat bs -> JS.BlockStat $ map jStgStatToJS bs + ApplStat rator rand -> JS.ApplStat (jStgExprToJS rator) $ map jStgExprToJS rand + UOpStat rator rand -> JS.UOpStat (jStgUOpToJS rator) (jStgExprToJS rand) + AssignStat lhs op rhs -> JS.AssignStat (jStgExprToJS lhs) (jStgAOpToJS op) (jStgExprToJS rhs) + LabelStat lbl stmt -> JS.LabelStat lbl (jStgStatToJS stmt) + BreakStat m_l -> JS.BreakStat $! m_l + ContinueStat m_l -> JS.ContinueStat $! m_l + FuncStat i args body -> JS.FuncStat i args $ jStgStatToJS body -jsSaturateE :: JExpr -> State [Ident] Sat.JExpr -jsSaturateE = \case - ValExpr v -> Sat.ValExpr <$> jsSaturateV v - SelExpr obj i -> Sat.SelExpr <$> jsSaturateE obj <*> pure i - IdxExpr o i -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i - InfixExpr op l r -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r - UOpExpr op r -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r - IfExpr c t e -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e - ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands - UnsatExpr us -> jsSaturateE =<< runIdentSupply us +jStgExprToJS :: JStgExpr -> JS.JExpr +jStgExprToJS = \case + ValExpr v -> JS.ValExpr $ jStgValToJS v + SelExpr obj i -> JS.SelExpr (jStgExprToJS obj) i + IdxExpr o i -> JS.IdxExpr (jStgExprToJS o) (jStgExprToJS i) + InfixExpr op l r -> JS.InfixExpr (jStgOpToJS op) (jStgExprToJS l) (jStgExprToJS r) + UOpExpr op r -> JS.UOpExpr (jStgUOpToJS op) (jStgExprToJS r) + IfExpr c t e -> JS.IfExpr (jStgExprToJS c) (jStgExprToJS t) (jStgExprToJS e) + ApplExpr rator rands -> JS.ApplExpr (jStgExprToJS rator) $ map jStgExprToJS rands -jsSaturateV :: JVal -> State [Ident] Sat.JVal -jsSaturateV = \case - JVar i -> return $ Sat.JVar i - JList xs -> Sat.JList <$> mapM jsSaturateE xs - JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d)) - JInt i -> return $ Sat.JInt i - JStr s -> return $ Sat.JStr s - JRegEx f -> return $ Sat.JRegEx f - JHash m -> Sat.JHash <$> mapUniqMapM satHash m +jStgValToJS :: JVal -> JS.JVal +jStgValToJS = \case + JVar i -> JS.JVar i + JList xs -> JS.JList $ map jStgExprToJS xs + JDouble d -> JS.JDouble d + JInt i -> JS.JInt i + JStr s -> JS.JStr s + JRegEx f -> JS.JRegEx f + JBool b -> JS.JBool b + JHash m -> JS.JHash $ mapUniqMapM satHash m where - satHash (i, x) = (i,) . (i,) <$> jsSaturateE x + satHash (i, x) = (i,) . (i,) $ jStgExprToJS x compareHash (i,_) (j,_) = lexicalCompareFS i j -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided - mapUniqMapM f (UniqMap m) = UniqMap . listToUFM <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m) - JFunc args body -> Sat.JFunc args <$> jsSaturateS body - UnsatVal us -> jsSaturateV =<< runIdentSupply us + mapUniqMapM f (UniqMap m) = UniqMap . listToUFM $ (map f . sortBy compareHash $ nonDetEltsUFM m) + JFunc args body -> JS.JFunc args $ jStgStatToJS body -satJOp :: JOp -> Sat.Op -satJOp = go +jStgOpToJS :: Op -> JS.Op +jStgOpToJS = go where - go EqOp = Sat.EqOp - go StrictEqOp = Sat.StrictEqOp - go NeqOp = Sat.NeqOp - go StrictNeqOp = Sat.StrictNeqOp - go GtOp = Sat.GtOp - go GeOp = Sat.GeOp - go LtOp = Sat.LtOp - go LeOp = Sat.LeOp - go AddOp = Sat.AddOp - go SubOp = Sat.SubOp - go MulOp = Sat.MulOp - go DivOp = Sat.DivOp - go ModOp = Sat.ModOp - go LeftShiftOp = Sat.LeftShiftOp - go RightShiftOp = Sat.RightShiftOp - go ZRightShiftOp = Sat.ZRightShiftOp - go BAndOp = Sat.BAndOp - go BOrOp = Sat.BOrOp - go BXorOp = Sat.BXorOp - go LAndOp = Sat.LAndOp - go LOrOp = Sat.LOrOp - go InstanceofOp = Sat.InstanceofOp - go InOp = Sat.InOp + go EqOp = JS.EqOp + go StrictEqOp = JS.StrictEqOp + go NeqOp = JS.NeqOp + go StrictNeqOp = JS.StrictNeqOp + go GtOp = JS.GtOp + go GeOp = JS.GeOp + go LtOp = JS.LtOp + go LeOp = JS.LeOp + go AddOp = JS.AddOp + go SubOp = JS.SubOp + go MulOp = JS.MulOp + go DivOp = JS.DivOp + go ModOp = JS.ModOp + go LeftShiftOp = JS.LeftShiftOp + go RightShiftOp = JS.RightShiftOp + go ZRightShiftOp = JS.ZRightShiftOp + go BAndOp = JS.BAndOp + go BOrOp = JS.BOrOp + go BXorOp = JS.BXorOp + go LAndOp = JS.LAndOp + go LOrOp = JS.LOrOp + go InstanceofOp = JS.InstanceofOp + go InOp = JS.InOp -satJUOp :: JUOp -> Sat.UOp -satJUOp = go +jStgUOpToJS :: UOp -> JS.UOp +jStgUOpToJS = go where - go NotOp = Sat.NotOp - go BNotOp = Sat.BNotOp - go NegOp = Sat.NegOp - go PlusOp = Sat.PlusOp - go NewOp = Sat.NewOp - go TypeofOp = Sat.TypeofOp - go DeleteOp = Sat.DeleteOp - go YieldOp = Sat.YieldOp - go VoidOp = Sat.VoidOp - go PreIncOp = Sat.PreIncOp - go PostIncOp = Sat.PostIncOp - go PreDecOp = Sat.PreDecOp - go PostDecOp = Sat.PostDecOp + go NotOp = JS.NotOp + go BNotOp = JS.BNotOp + go NegOp = JS.NegOp + go PlusOp = JS.PlusOp + go NewOp = JS.NewOp + go TypeofOp = JS.TypeofOp + go DeleteOp = JS.DeleteOp + go YieldOp = JS.YieldOp + go VoidOp = JS.VoidOp + go PreIncOp = JS.PreIncOp + go PostIncOp = JS.PostIncOp + go PreDecOp = JS.PreDecOp + go PostDecOp = JS.PostDecOp +jStgAOpToJS :: AOp -> JS.AOp +jStgAOpToJS AssignOp = JS.AssignOp +jStgAOpToJS AddAssignOp = JS.AddAssignOp +jStgAOpToJS SubAssignOp = JS.SubAssignOp diff --git a/GHC/JS/Unsat/Syntax.hs b/GHC/JS/Unsat/Syntax.hs deleted file mode 100644 --- a/GHC/JS/Unsat/Syntax.hs +++ /dev/null @@ -1,375 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE PatternSynonyms #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.JS.Unsat.Syntax --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Josh Meredith --- Stability : experimental --- --- --- * Domain and Purpose --- --- GHC.JS.Unsat.Syntax defines the Syntax for the JS backend in GHC. It --- comports with the [ECMA-262](https://tc39.es/ecma262/) although not every --- production rule of the standard is represented. Code in this module is a --- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 --- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's --- constraints. --- --- --- * Strategy --- --- Nothing fancy in this module, this is a classic deeply embeded AST for --- JS. We define numerous ADTs and pattern synonyms to make pattern matching --- and constructing ASTs easier. --- --- --- * Consumers --- --- The entire JS backend consumes this module, e.g., the modules in --- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides --- helper functions that use the deeply embedded DSL defined in this module --- to provide some of the benefits of a shallow embedding. ------------------------------------------------------------------------------ -module GHC.JS.Unsat.Syntax - ( -- * Deeply embedded JS datatypes - JStat(..) - , JExpr(..) - , JVal(..) - , JOp(..) - , JUOp(..) - , Ident(..) - , identFS - , JsLabel - -- * pattern synonyms over JS operators - , pattern New - , pattern Not - , pattern Negate - , pattern Add - , pattern Sub - , pattern Mul - , pattern Div - , pattern Mod - , pattern BOr - , pattern BAnd - , pattern BXor - , pattern BNot - , pattern LOr - , pattern LAnd - , pattern Int - , pattern String - , pattern PreInc - , pattern PostInc - , pattern PreDec - , pattern PostDec - -- * Ident supply - , IdentSupply(..) - , newIdentSupply - , pseudoSaturate - -- * Utility - , SaneDouble(..) - ) where - -import GHC.Prelude - -import Control.DeepSeq - -import Data.Function -import Data.Data -import Data.Word -import qualified Data.Semigroup as Semigroup - -import GHC.Generics - -import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Types.Unique -import GHC.Types.Unique.Map -import GHC.Types.SaneDouble - --- | A supply of identifiers, possibly empty -newtype IdentSupply a - = IS {runIdentSupply :: State [Ident] a} - deriving Typeable - -instance NFData (IdentSupply a) where rnf IS{} = () - -inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b -inIdentSupply f x = IS $ f (runIdentSupply x) - -instance Functor IdentSupply where - fmap f x = inIdentSupply (fmap f) x - -newIdentSupply :: Maybe FastString -> [Ident] -newIdentSupply Nothing = newIdentSupply (Just "jmId") -newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) - | x <- [(0::Word64)..] - ] - --- | Given a Pseudo-saturate a value with garbage @<>@ identifiers. -pseudoSaturate :: IdentSupply a -> a -pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<>") - -instance Eq a => Eq (IdentSupply a) where - (==) = (==) `on` pseudoSaturate -instance Ord a => Ord (IdentSupply a) where - compare = compare `on` pseudoSaturate -instance Show a => Show (IdentSupply a) where - show x = "(" ++ show (pseudoSaturate x) ++ ")" - - --------------------------------------------------------------------------------- --- Statements --------------------------------------------------------------------------------- --- | JavaScript statements, see the [ECMA262 --- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) --- for details -data JStat - = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] - | ReturnStat JExpr -- ^ Return - | IfStat JExpr JStat JStat -- ^ If - | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True - | ForStat JStat JExpr JStat JStat -- ^ For - | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True - | SwitchStat JExpr [(JExpr, JStat)] JStat -- ^ Switch - | TryStat JStat Ident JStat JStat -- ^ Try - | BlockStat [JStat] -- ^ Blocks - | ApplStat JExpr [JExpr] -- ^ Application - | UOpStat JUOp JExpr -- ^ Unary operators - | AssignStat JExpr JExpr -- ^ Binding form: @foo = bar@ - | UnsatBlock (IdentSupply JStat) -- ^ /Unsaturated/ blocks see 'pseudoSaturate' - | LabelStat JsLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic - | BreakStat (Maybe JsLabel) -- ^ Break - | ContinueStat (Maybe JsLabel) -- ^ Continue - | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition - deriving (Eq, Typeable, Generic) - --- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of --- course 'LabelStat' -type JsLabel = LexicalFastString - -instance Semigroup JStat where - (<>) = appendJStat - -instance Monoid JStat where - mempty = BlockStat [] - --- | Append a statement to another statement. 'appendJStat' only returns a --- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty --- 'BlockStat'. That is: --- > (BlockStat [] , y ) = y --- > (x , BlockStat []) = x -appendJStat :: JStat -> JStat -> JStat -appendJStat mx my = case (mx,my) of - (BlockStat [] , y ) -> y - (x , BlockStat []) -> x - (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys - (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] - (xs , BlockStat ys) -> BlockStat $ xs : ys - (xs , ys ) -> BlockStat [xs,ys] - - --------------------------------------------------------------------------------- --- Expressions --------------------------------------------------------------------------------- --- | JavaScript Expressions -data JExpr - = ValExpr JVal -- ^ All values are trivially expressions - | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' - | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' - | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' - -- pattern synonyms - | UOpExpr JUOp JExpr -- ^ Unary Expressions - | IfExpr JExpr JExpr JExpr -- ^ If-expression - | ApplExpr JExpr [JExpr] -- ^ Application - | UnsatExpr (IdentSupply JExpr) -- ^ An /Saturated/ expression. - -- See 'pseudoSaturate' - deriving (Eq, Typeable, Generic) - --- * Useful pattern synonyms to ease programming with the deeply embedded JS --- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and --- for convienience. In addition we include a string wrapper for JS string --- and Integer literals. - --- | pattern synonym for a unary operator new -pattern New :: JExpr -> JExpr -pattern New x = UOpExpr NewOp x - --- | pattern synonym for prefix increment @++x@ -pattern PreInc :: JExpr -> JExpr -pattern PreInc x = UOpExpr PreIncOp x - --- | pattern synonym for postfix increment @x++@ -pattern PostInc :: JExpr -> JExpr -pattern PostInc x = UOpExpr PostIncOp x - --- | pattern synonym for prefix decrement @--x@ -pattern PreDec :: JExpr -> JExpr -pattern PreDec x = UOpExpr PreDecOp x - --- | pattern synonym for postfix decrement @--x@ -pattern PostDec :: JExpr -> JExpr -pattern PostDec x = UOpExpr PostDecOp x - --- | pattern synonym for logical not @!@ -pattern Not :: JExpr -> JExpr -pattern Not x = UOpExpr NotOp x - --- | pattern synonym for unary negation @-@ -pattern Negate :: JExpr -> JExpr -pattern Negate x = UOpExpr NegOp x - --- | pattern synonym for addition @+@ -pattern Add :: JExpr -> JExpr -> JExpr -pattern Add x y = InfixExpr AddOp x y - --- | pattern synonym for subtraction @-@ -pattern Sub :: JExpr -> JExpr -> JExpr -pattern Sub x y = InfixExpr SubOp x y - --- | pattern synonym for multiplication @*@ -pattern Mul :: JExpr -> JExpr -> JExpr -pattern Mul x y = InfixExpr MulOp x y - --- | pattern synonym for division @*@ -pattern Div :: JExpr -> JExpr -> JExpr -pattern Div x y = InfixExpr DivOp x y - --- | pattern synonym for remainder @%@ -pattern Mod :: JExpr -> JExpr -> JExpr -pattern Mod x y = InfixExpr ModOp x y - --- | pattern synonym for Bitwise Or @|@ -pattern BOr :: JExpr -> JExpr -> JExpr -pattern BOr x y = InfixExpr BOrOp x y - --- | pattern synonym for Bitwise And @&@ -pattern BAnd :: JExpr -> JExpr -> JExpr -pattern BAnd x y = InfixExpr BAndOp x y - --- | pattern synonym for Bitwise XOr @^@ -pattern BXor :: JExpr -> JExpr -> JExpr -pattern BXor x y = InfixExpr BXorOp x y - --- | pattern synonym for Bitwise Not @~@ -pattern BNot :: JExpr -> JExpr -pattern BNot x = UOpExpr BNotOp x - --- | pattern synonym for logical Or @||@ -pattern LOr :: JExpr -> JExpr -> JExpr -pattern LOr x y = InfixExpr LOrOp x y - --- | pattern synonym for logical And @&&@ -pattern LAnd :: JExpr -> JExpr -> JExpr -pattern LAnd x y = InfixExpr LAndOp x y - - --- | pattern synonym to create integer values -pattern Int :: Integer -> JExpr -pattern Int x = ValExpr (JInt x) - --- | pattern synonym to create string values -pattern String :: FastString -> JExpr -pattern String x = ValExpr (JStr x) - - --------------------------------------------------------------------------------- --- Values --------------------------------------------------------------------------------- --- | JavaScript values -data JVal - = JVar Ident -- ^ A variable reference - | JList [JExpr] -- ^ A JavaScript list, or what JS - -- calls an Array - | JDouble SaneDouble -- ^ A Double - | JInt Integer -- ^ A BigInt - | JStr FastString -- ^ A String - | JRegEx FastString -- ^ A Regex - | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ - | JFunc [Ident] JStat -- ^ A function - | UnsatVal (IdentSupply JVal) -- ^ An /Saturated/ value, see 'pseudoSaturate' - deriving (Eq, Typeable, Generic) - --------------------------------------------------------------------------------- --- Operators --------------------------------------------------------------------------------- --- | JS Binary Operators. We do not deeply embed the comma operator and the --- assignment operators -data JOp - = EqOp -- ^ Equality: `==` - | StrictEqOp -- ^ Strict Equality: `===` - | NeqOp -- ^ InEquality: `!=` - | StrictNeqOp -- ^ Strict InEquality `!==` - | GtOp -- ^ Greater Than: `>` - | GeOp -- ^ Greater Than or Equal: `>=` - | LtOp -- ^ Less Than:  < - | LeOp -- ^ Less Than or Equal: <= - | AddOp -- ^ Addition: + - | SubOp -- ^ Subtraction: - - | MulOp -- ^ Multiplication \* - | DivOp -- ^ Division: \/ - | ModOp -- ^ Remainder: % - | LeftShiftOp -- ^ Left Shift: \<\< - | RightShiftOp -- ^ Right Shift: \>\> - | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> - | BAndOp -- ^ Bitwise And: & - | BOrOp -- ^ Bitwise Or: | - | BXorOp -- ^ Bitwise XOr: ^ - | LAndOp -- ^ Logical And: && - | LOrOp -- ^ Logical Or: || - | InstanceofOp -- ^ @instanceof@ - | InOp -- ^ @in@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) - -instance NFData JOp - --- | JS Unary Operators -data JUOp - = NotOp -- ^ Logical Not: @!@ - | BNotOp -- ^ Bitwise Not: @~@ - | NegOp -- ^ Negation: @-@ - | PlusOp -- ^ Unary Plus: @+x@ - | NewOp -- ^ new x - | TypeofOp -- ^ typeof x - | DeleteOp -- ^ delete x - | YieldOp -- ^ yield x - | VoidOp -- ^ void x - | PreIncOp -- ^ Prefix Increment: @++x@ - | PostIncOp -- ^ Postfix Increment: @x++@ - | PreDecOp -- ^ Prefix Decrement: @--x@ - | PostDecOp -- ^ Postfix Decrement: @x--@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) - -instance NFData JUOp - --------------------------------------------------------------------------------- --- Identifiers --------------------------------------------------------------------------------- --- We use FastString for identifiers in JS backend - --- | A newtype wrapper around 'FastString' for JS identifiers. -newtype Ident = TxtI { itxt :: FastString } - deriving stock (Show, Eq) - deriving newtype (Uniquable) - -identFS :: Ident -> FastString -identFS = \case - TxtI fs -> fs diff --git a/GHC/Linker.hs b/GHC/Linker.hs deleted file mode 100644 --- a/GHC/Linker.hs +++ /dev/null @@ -1,36 +0,0 @@ -module GHC.Linker - ( - ) -where - -import GHC.Prelude () - -- We need this dummy dependency for the make build system. Otherwise it - -- tries to load GHC.Types which may not be built yet. - --- Note [Linkers and loaders] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- Linkers are used to produce linked objects (.so, executables); loaders are --- used to link in memory (e.g., in GHCi) with the already loaded libraries --- (ghc-lib, rts, etc.). --- --- Linking can usually be done with an external linker program ("ld"), but --- loading is more tricky: --- --- * Fully dynamic: --- when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.) --- and the modules to load are also compiled for dynamic linking, a --- solution is to fully rely on external tools: --- --- 1) link a .so with the external linker --- 2) load the .so with POSIX's "dlopen" --- --- * When GHC is built as a static program or when libraries we want to load --- aren't compiled for dynamic linking, GHC uses its own loader ("runtime --- linker"). The runtime linker is part of the rts (rts/Linker.c). --- --- Note that within GHC's codebase we often use the word "linker" to refer to --- the static object loader in the runtime system. --- --- Loading can be delegated to an external interpreter ("iserv") when --- -fexternal-interpreter is used. diff --git a/GHC/Linker/Config.hs b/GHC/Linker/Config.hs --- a/GHC/Linker/Config.hs +++ b/GHC/Linker/Config.hs @@ -2,12 +2,26 @@ module GHC.Linker.Config ( FrameworkOpts(..) - ) where + , LinkerConfig(..) + ) +where import GHC.Prelude +import GHC.Utils.TmpFs +import GHC.Utils.CliOption -- used on darwin only data FrameworkOpts = FrameworkOpts { foFrameworkPaths :: [String] , foCmdlineFrameworks :: [String] } + +-- | External linker configuration +data LinkerConfig = LinkerConfig + { linkerProgram :: String -- ^ Linker program + , linkerOptionsPre :: [Option] -- ^ Linker options (before user options) + , linkerOptionsPost :: [Option] -- ^ Linker options (after user options) + , linkerTempDir :: TempDir -- ^ Temporary directory to use + , linkerFilter :: [String] -> [String] -- ^ Output filter + } + diff --git a/GHC/Linker/Deps.hs b/GHC/Linker/Deps.hs --- a/GHC/Linker/Deps.hs +++ b/GHC/Linker/Deps.hs @@ -4,10 +4,8 @@ {-# OPTIONS_GHC -fspec-constr-threshold=10000 #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections, RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} module GHC.Linker.Deps ( LinkDepsOpts (..) @@ -24,57 +22,45 @@ import GHC.Linker.Types -import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.Module -import GHC.Unit.Module.ModIface import GHC.Unit.Module.WholeCoreBindings -import GHC.Unit.Module.Deps -import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo import GHC.Iface.Errors.Types -import GHC.Iface.Errors.Ppr import GHC.Utils.Misc -import GHC.Unit.Home +import qualified GHC.Unit.Home.Graph as HUG import GHC.Data.Maybe -import Control.Monad import Control.Applicative -import qualified Data.Set as Set -import qualified Data.Map as M import Data.List (isSuffixOf) -import Data.Either import System.FilePath import System.Directory - data LinkDepsOpts = LinkDepsOpts { ldObjSuffix :: !String -- ^ Suffix of .o files - , ldOneShotMode :: !Bool -- ^ Is the driver in one-shot mode? - , ldModuleGraph :: !ModuleGraph -- ^ Module graph - , ldUnitEnv :: !UnitEnv -- ^ Unit environment + , ldForceDyn :: !Bool -- ^ Always use .dyn_o? + , 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 + , ldLoadByteCode :: !(Module -> IO (Maybe Linkable)) + , ldGetDependencies :: !([Module] -> IO ([Module], UniqDSet UnitId)) } data LinkDeps = LinkDeps @@ -107,7 +93,6 @@ get_link_deps opts pls maybe_normal_osuf span mods - get_link_deps :: LinkDepsOpts -> LoaderState @@ -116,31 +101,25 @@ -> [Module] -> IO LinkDeps get_link_deps opts pls maybe_normal_osuf span mods = do - -- 1. Find the dependent home-pkg-modules/packages from each iface + + -- Three step process: + + -- 1. Find the dependent home-pkg-modules/packages from each iface -- (omitting modules from the interactive package, which is already linked) - (mods_s, pkgs_s) <- - -- Why two code paths here? There is a significant amount of repeated work - -- performed calculating transitive dependencies - -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests) - if ldOneShotMode opts - then follow_deps (filterOut isInteractiveModule mods) - emptyUniqDSet emptyUniqDSet; - else do - (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods - return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs)) + (mods_s, pkgs_s) <- ldGetDependencies opts relevant_mods let -- 2. Exclude ones already linked -- Main reason: avoid findModule calls in get_linkable - (mods_needed, links_got) = partitionEithers (map split_mods mods_s) - pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls + (mods_needed, links_got) = partitionWith split_mods mods_s + pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls - split_mods mod = - let is_linked = lookupModuleEnv (objs_loaded pls) mod - <|> lookupModuleEnv (bcos_loaded pls) mod - in case is_linked of - Just linkable -> Right linkable - Nothing -> Left mod + split_mods mod = + let is_linked = lookupModuleEnv (objs_loaded pls) mod + <|> lookupModuleEnv (bcos_loaded pls) mod + in case is_linked of + Just linkable -> Right linkable + Nothing -> Left mod -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot @@ -154,106 +133,8 @@ , ldNeededUnits = pkgs_s } where - mod_graph = ldModuleGraph opts - unit_env = ldUnitEnv opts - - -- This code is used in `--make` mode to calculate the home package and unit dependencies - -- for a set of modules. - -- - -- It is significantly more efficient to use the shared transitive dependency - -- calculation than to compute the transitive dependency set in the same manner as oneShot mode. - - -- It is also a matter of correctness to use the module graph so that dependencies between home units - -- is resolved correctly. - make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey) - make_deps_loop found [] = found - make_deps_loop found@(found_units, found_mods) (nk:nexts) - | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts - | otherwise = - case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of - Just trans_deps -> - let deps = Set.insert (NodeKey_Module nk) trans_deps - -- See #936 and the ghci.prog007 test for why we have to continue traversing through - -- boot modules. - todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps] - in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts) - Nothing -> - let (ModNodeKeyWithUid _ uid) = nk - in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts - - mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) - (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods) - - all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps] - - get_mod_info (ModNodeKeyWithUid gwib uid) = - case lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) of - Just hmi -> - let iface = (hm_iface hmi) - mmod = case mi_hsc_src iface of - HsBootFile -> link_boot_mod_error (mi_module iface) - _ -> return $ Just (mi_module iface) - - in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$> mmod - Nothing -> throwProgramError opts $ - text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid - - - -- This code is used in one-shot mode to traverse downwards through the HPT - -- to find all link dependencies. - -- The ModIface contains the transitive closure of the module dependencies - -- within the current package, *except* for boot modules: if we encounter - -- a boot module, we have to find its real interface and discover the - -- dependencies of that. Hence we need to traverse the dependency - -- tree recursively. See bug #936, testcase ghci/prog007. - follow_deps :: [Module] -- modules to follow - -> UniqDSet Module -- accum. module dependencies - -> UniqDSet UnitId -- accum. package dependencies - -> IO ([Module], UniqDSet UnitId) -- result - follow_deps [] acc_mods acc_pkgs - = return (uniqDSetToList acc_mods, acc_pkgs) - follow_deps (mod:mods) acc_mods acc_pkgs - = do - mb_iface <- ldLoadIface opts msg mod - iface <- case mb_iface of - Failed err -> throwProgramError opts $ - missingInterfaceErrorDiagnostic (ldMsgOpts opts) err - Succeeded iface -> return iface - - when (mi_boot iface == IsBoot) $ link_boot_mod_error mod - - let - pkg = moduleUnit mod - deps = mi_deps iface - - pkg_deps = dep_direct_pkgs deps - (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $ - \case - (_, GWIB m IsBoot) -> Left m - (_, GWIB m NotBoot) -> Right m - - mod_deps' = case ue_homeUnit unit_env of - Nothing -> [] - Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps)) - acc_mods' = case ue_homeUnit unit_env of - Nothing -> acc_mods - Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps) - acc_pkgs' = addListToUniqDSet acc_pkgs (Set.toList pkg_deps) - - case ue_homeUnit unit_env of - Just home_unit | isHomeUnit home_unit pkg -> follow_deps (mod_deps' ++ mods) - acc_mods' acc_pkgs' - _ -> follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg)) - where - msg = text "need to link module" <+> ppr mod <+> - text "due to use of Template Haskell" - - - - link_boot_mod_error :: Module -> IO a - link_boot_mod_error mod = throwProgramError opts $ - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module" + unit_env = ldUnitEnv opts + relevant_mods = filterOut isInteractiveModule mods no_obj :: Outputable a => a -> IO b no_obj mod = dieWith opts span $ @@ -272,39 +153,40 @@ else homeModInfoObject hmi <|> homeModInfoByteCode hmi get_linkable osuf mod -- A home-package module - | Just mod_info <- lookupHugByModule mod (ue_home_unit_graph unit_env) - = adjust_linkable (expectJust "getLinkDeps" (homeModLinkable mod_info)) - | otherwise - = do -- It's not in the HPT because we are in one shot mode, - -- so use the Finder to get a ModLocation... - case ue_homeUnit unit_env of - Nothing -> no_obj mod - Just home_unit -> do - - 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) + = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case + Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info)) + Nothing -> do + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + case ue_homeUnit unit_env of + Nothing -> no_obj mod + Just home_unit -> do + from_bc <- ldLoadByteCode opts mod + maybe (fallback_no_bytecode home_unit mod) pure from_bc where - 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 @@ -313,19 +195,22 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The `-fprefer-byte-code` flag allows a user to specify that they want to use -byte code (if availble) rather than object code for home module dependenices +byte code (if available) rather than object code for home module dependencies when executing Template Haskell splices. Why might you want to use byte code rather than object code? @@ -336,14 +221,13 @@ So we allow the user to choose to use byte code rather than object files if they want to avoid these two pitfalls. -When using `-fprefer-byte-code` you have to arrange to have the byte code availble. +When using `-fprefer-byte-code` you have to arrange to have the byte code available. In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`. See Note [Home module build products] for some more information about that. The only other place where the flag is consulted is when enabling code generation with `-fno-code`, which does so to anticipate what decision we will make at the splice point about what we would prefer. - -} dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a @@ -354,6 +238,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 @@ -380,7 +274,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 $ @@ -390,10 +284,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 @@ -412,5 +308,5 @@ Normal -> "the normal way" Prof -> "with -prof" Dyn -> "with -dynamic" + ProfDyn -> "with -prof and -dynamic" #endif - diff --git a/GHC/Linker/Dynamic.hs b/GHC/Linker/Dynamic.hs --- a/GHC/Linker/Dynamic.hs +++ b/GHC/Linker/Dynamic.hs @@ -21,7 +21,7 @@ import GHC.Unit.State import GHC.Linker.MacOS import GHC.Linker.Unit -import GHC.SysTools.Tasks +import GHC.Linker.External import GHC.Utils.Logger import GHC.Utils.TmpFs @@ -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 @@ -99,6 +105,8 @@ pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs) let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform + let linker_config = initLinkerConfig dflags + case os of OSMinGW32 -> do ------------------------------------------------------------- @@ -108,7 +116,7 @@ Just s -> s Nothing -> "HSdll.dll" - runLink logger tmpfs dflags ( + runLink logger tmpfs linker_config ( map Option verbFlags ++ [ Option "-o" , FileOption "" output_fn @@ -142,10 +150,6 @@ -- (and should) do without this for all libraries except -- the RTS; all we need to do is to pass the correct -- HSfoo_dyn.dylib files to the link command. - -- This feature requires Mac OS X 10.3 or later; there is - -- a similar feature, -flat_namespace -undefined suppress, - -- which works on earlier versions, but it has other - -- disadvantages. -- -single_module -- Build the dynamic library as a single "module", i.e. no -- dynamic binding nonsense when referring to symbols from @@ -171,7 +175,7 @@ instName <- case dylibInstallName dflags of Just n -> return n Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink logger tmpfs dflags ( + runLink logger tmpfs linker_config ( map Option verbFlags ++ [ Option "-dynamiclib" , Option "-o" @@ -217,9 +221,10 @@ -- 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 dflags ( + runLink logger tmpfs linker_config ( map Option verbFlags ++ libmLinkOpts platform ++ [ Option "-o" @@ -230,7 +235,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 diff --git a/GHC/Linker/External.hs b/GHC/Linker/External.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/External.hs @@ -0,0 +1,26 @@ +-- | External ("system") linker +module GHC.Linker.External + ( LinkerConfig(..) + , runLink + ) +where + +import GHC.Prelude +import GHC.Utils.TmpFs +import GHC.Utils.Logger +import GHC.Utils.Error +import GHC.Utils.CliOption +import GHC.SysTools.Process +import GHC.Linker.Config + +-- | Run the external linker +runLink :: Logger -> TmpFs -> LinkerConfig -> [Option] -> IO () +runLink logger tmpfs cfg args = traceSystoolCommand logger "linker" $ do + let all_args = linkerOptionsPre cfg ++ args ++ linkerOptionsPost cfg + + -- on Windows, mangle environment variables to account for a bug in Windows + -- Vista + mb_env <- getGccEnv all_args + + runSomethingResponseFile logger tmpfs (linkerTempDir cfg) (linkerFilter cfg) + "Linker" (linkerProgram cfg) all_args mb_env diff --git a/GHC/Linker/ExtraObj.hs b/GHC/Linker/ExtraObj.hs --- a/GHC/Linker/ExtraObj.hs +++ b/GHC/Linker/ExtraObj.hs @@ -12,7 +12,6 @@ , mkNoteObjsToLinkIntoBinary , checkLinkInfo , getLinkInfo - , getCompilerInfo , ghcLinkInfoSectionName , ghcLinkInfoNoteName , platformSupportsSavingLinkOpts @@ -40,10 +39,8 @@ import GHC.SysTools.Elf import GHC.SysTools.Tasks -import GHC.SysTools.Info import GHC.Linker.Unit -import Control.Monad.IO.Class import Control.Monad import Data.Maybe @@ -52,7 +49,6 @@ = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o" writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo logger dflags runCc Nothing logger tmpfs dflags ([Option "-c", FileOption "" cFile, @@ -60,7 +56,7 @@ FileOption "" oFile] ++ if extn /= "s" then cOpts - else asmOpts ccInfo) + else []) return oFile where -- Pass a different set of options to the C compiler depending one whether @@ -70,14 +66,6 @@ ++ map (FileOption "-I" . ST.unpack) (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit) - -- When compiling assembler code, we drop the usual C options, and if the - -- compiler is Clang, we add an extra argument to tell Clang to ignore - -- unused command line options. See trac #11684. - asmOpts ccInfo = - if any (ccInfo ==) [Clang, AppleClang, AppleClang51] - then [Option "-Qunused-arguments"] - else [] - -- When linking a binary, we need to create a C main() function that -- starts everything off. This used to be compiled statically as part -- of the RTS, but that made it hard to change the -rtsopts setting, @@ -171,7 +159,7 @@ else return [] where - unit_state = ue_units unit_env + unit_state = ue_homeUnitState unit_env platform = ue_platform unit_env link_opts info = hcat [ -- "link info" section (see Note [LinkInfo section]) diff --git a/GHC/Linker/Loader.hs b/GHC/Linker/Loader.hs --- a/GHC/Linker/Loader.hs +++ b/GHC/Linker/Loader.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections, RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} -- @@ -18,7 +17,6 @@ , showLoaderState , getLoaderState -- * Load & Unload - , loadExpr , loadDecls , loadPackages , loadModule @@ -30,10 +28,11 @@ , extendLoadedEnv , deleteFromLoadedEnv -- * Internals + , allocateBreakArrays , rmDupLinkables , modifyLoaderState , initLinkDepsOpts - , partitionLinkable + , getGccSearchDirectory ) where @@ -54,14 +53,17 @@ import GHC.Tc.Utils.Monad import GHC.Runtime.Interpreter +import GHCi.BreakArray import GHCi.RemoteTypes import GHC.Iface.Load -import GHCi.Message (LoadedDLL) +import GHCi.Message (ConInfoTable(..), LoadedDLL) +import GHC.ByteCode.Breakpoints import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types +import GHC.Stack.CCS import GHC.SysTools import GHC.Types.Basic @@ -78,7 +80,12 @@ import GHC.Utils.TmpFs import GHC.Unit.Env +import GHC.Unit.Home.ModInfo +import GHC.Unit.External (ExternalPackageState (..)) import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModIface import GHC.Unit.State as Packages import qualified GHC.Data.ShortText as ST @@ -92,13 +99,18 @@ -- Standard libraries import Control.Monad +import Data.Array +import Data.ByteString (ByteString) import qualified Data.Set as Set import Data.Char (isSpace) +import qualified Data.Foldable as Foldable import Data.IORef import Data.List (intercalate, isPrefixOf, nub, partition) import Data.Maybe +import Data.Either import Control.Concurrent.MVar import qualified Control.Monad.Catch as MC +import qualified Data.List.NonEmpty as NE import System.FilePath import System.Directory @@ -110,7 +122,41 @@ #endif import GHC.Utils.Exception +import GHC.Unit.Home.Graph (lookupHug, unitEnv_foldWithKey) +import GHC.Driver.Downsweep +import qualified GHC.Runtime.Interpreter as GHCi +import qualified Data.IntMap.Strict as IM +import qualified Data.Map.Strict as M +import Foreign.Ptr (nullPtr) +-- Note [Linkers and loaders] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Linkers are used to produce linked objects (.so, executables); loaders are +-- used to link in memory (e.g., in GHCi) with the already loaded libraries +-- (ghc-lib, rts, etc.). +-- +-- Linking can usually be done with an external linker program ("ld"), but +-- loading is more tricky: +-- +-- * Fully dynamic: +-- when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.) +-- and the modules to load are also compiled for dynamic linking, a +-- solution is to fully rely on external tools: +-- +-- 1) link a .so with the external linker +-- 2) load the .so with POSIX's "dlopen" +-- +-- * When GHC is built as a static program or when libraries we want to load +-- aren't compiled for dynamic linking, GHC uses its own loader ("runtime +-- linker"). The runtime linker is part of the rts (rts/Linker.c). +-- +-- Note that within GHC's codebase we often use the word "linker" to refer to +-- the static object loader in the runtime system. +-- +-- Loading can be delegated to an external interpreter ("iserv") when +-- -fexternal-interpreter is used. + uninitialised :: a uninitialised = panic "Loader not initialised" @@ -140,6 +186,10 @@ , bcos_loaded = emptyModuleEnv , objs_loaded = emptyModuleEnv , temp_sos = [] + , linked_breaks = LinkedBreaks + { breakarray_env = emptyModuleEnv + , ccs_env = emptyModuleEnv + } } -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. @@ -180,12 +230,12 @@ case lookupNameEnv (closure_env (linker_env pls)) name of Just (_,aa) -> return (pls,(aa, links, pkgs)) Nothing -> assertPpr (isExternalName name) (ppr name) $ - do let sym_to_find = nameToCLabel name "closure" - m <- lookupClosure interp (unpackFS sym_to_find) + do let sym_to_find = IClosureSymbol name + m <- lookupClosure interp sym_to_find r <- case m of Just hvref -> mkFinalizedHValue interp hvref Nothing -> linkFail "GHC.Linker.Loader.loadName" - (unpackFS sym_to_find) + (ppr sym_to_find) return (pls,(r, links, pkgs)) loadDependencies @@ -537,7 +587,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 @@ -546,7 +596,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 @@ -559,107 +609,121 @@ , "Try using a dynamic library instead." ] - -{- ********************************************************************** - - Link a byte-code expression - - ********************************************************************* -} - --- | Load a single expression, /including/ first loading packages and --- modules that this expression depends on. --- --- Raises an IO exception ('ProgramError') if it can't find a compiled --- version of the dependents to load. --- -loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue -loadExpr interp hsc_env span root_ul_bco = do - -- Initialise the linker (if it's not been done already) - initLoaderState interp hsc_env - - -- Take lock for the actual work. - modifyLoaderState interp $ \pls0 -> do - -- Load the packages and modules required - (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods - if failed ok - then throwGhcExceptionIO (ProgramError "") - else do - -- Load the expression itself - -- Load the necessary packages and linkables - let le = linker_env pls - nobreakarray = error "no break array" - bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix nobreakarray root_ul_bco - [root_hvref] <- createBCOs interp [resolved] - fhv <- mkFinalizedHValue interp root_hvref - return (pls, fhv) - where - free_names = uniqDSetToList (bcoFreeNames root_ul_bco) - - needed_mods :: [Module] - needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) - -- Exclude wired-in names because we may not have read - -- their interface files, so getLinkDeps will fail - -- All wired-in names are in the base package, which we link - -- by default, so we can safely ignore them here. - initLinkDepsOpts :: HscEnv -> LinkDepsOpts initLinkDepsOpts hsc_env = opts where opts = LinkDepsOpts { ldObjSuffix = objectSuf dflags - , ldOneShotMode = isOneShot (ghcMode dflags) - , ldModuleGraph = hsc_mod_graph hsc_env + , ldForceDyn = sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags , 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 + , ldGetDependencies = get_reachable_nodes hsc_env + , ldLoadByteCode } dflags = hsc_dflags hsc_env - load_iface msg mod = initIfaceCheck (text "loader") hsc_env - $ loadInterface msg mod (ImportByUser NotBoot) + ldLoadByteCode mod = do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "get_reachable_nodes" <+> parens (ppr mod)) + mod ImportBySystem + EPS {eps_iface_bytecode} <- hscEPS hsc_env + sequence (lookupModuleEnv eps_iface_bytecode mod) +get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) +get_reachable_nodes hsc_env mods + + -- Fallback case if the ModuleGraph has not been initialised by the user. + -- This can happen if is the user is loading plugins or doing something else very + -- early in the compiler pipeline. + | isEmptyMG (hsc_mod_graph hsc_env) + = do + mg <- downsweepInstalledModules hsc_env mods + go mg + + | otherwise + = go (hsc_mod_graph hsc_env) + + where + unit_env = hsc_unit_env hsc_env + mkModuleNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m) + + hmgModKey mg m + | let k = NodeKey_Module (mkModuleNk m) + , mgMember mg k = k + | otherwise = NodeKey_ExternalUnit (moduleUnitId m) + + -- The main driver for getting dependencies, which calls the given + -- functions to compute the reachable nodes. + go :: ModuleGraph -> IO ([Module], UniqDSet UnitId) + go mg = do + let mod_keys = map (hmgModKey mg) mods + all_reachable = mod_keys ++ map mkNodeKey (mgReachableLoop mg mod_keys) + (mods_s, pkgs_s) <- partitionEithers <$> mapMaybeM get_mod_info all_reachable + return (mods_s, mkUniqDSet pkgs_s) + + get_mod_info :: NodeKey -> IO (Maybe (Either Module UnitId)) + get_mod_info (NodeKey_Module m@(ModNodeKeyWithUid gwib uid)) = + lookupHug (ue_home_unit_graph unit_env) uid (gwib_mod gwib) >>= \case + Just hmi -> return $ Just (Left (mi_module (hm_iface hmi))) + Nothing -> return (Just (Left (mnkToModule m))) + get_mod_info (NodeKey_ExternalUnit uid) = return (Just (Right uid)) + get_mod_info _ = return Nothing + + {- ********************************************************************** Loading a Decls statement ********************************************************************* -} -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 } + let lb = linked_breaks pls + le2_itbl_env <- linkITbls interp (itbl_env le) (concat $ map bc_itbls cbcs) + le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs + le2_breakarray_env <- allocateBreakArrays interp (breakarray_env lb) (catMaybes $ map bc_breaks cbcs) + le2_ccs_env <- allocateCCS interp (ccs_env lb) (catMaybes $ map bc_breaks cbcs) + let le2 = le { itbl_env = le2_itbl_env + , addr_env = le2_addr_env } + let lb2 = lb { breakarray_env = le2_breakarray_env + , ccs_env = le2_ccs_env } -- Link the necessary packages and linkables - new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc] + new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let ce2 = extendClosureEnv (closure_env le2) nms_fhvs - !pls2 = pls { linker_env = le2 { closure_env = ce2 } } + !pls2 = pls { linker_env = le2 { closure_env = ce2 } + , linked_breaks = lb2 } return (pls2, (nms_fhvs, links_needed, units_needed)) where + cbcs = linkableBCOs linkable + 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, @@ -698,8 +762,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 @@ -709,20 +776,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 @@ -749,8 +806,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 @@ -812,16 +868,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 @@ -834,7 +894,7 @@ m <- loadDLL interp soFile case m of Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } - Left err -> linkFail msg err + Left err -> linkFail msg (text err) where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -862,19 +922,24 @@ 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 - ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs) - ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) - le2 = le1 { itbl_env = ie2, addr_env = ae2 } + lb1 = linked_breaks pls + ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) + ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs + be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs) + ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs) + let le2 = le1 { itbl_env = ie2, addr_env = ae2 } + let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 } - names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs + names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -885,33 +950,31 @@ new_binds <- makeForeignNamedHValueRefs interp to_add let ce2 = extendClosureEnv (closure_env le2) new_binds - return $! pls1 { linker_env = le2 { closure_env = ce2 } } + return $! pls1 { linker_env = le2 { closure_env = ce2 } + , linked_breaks = lb2 } -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp -> PkgsLoaded -> LinkerEnv + -> LinkedBreaks -> [CompiledByteCode] -> IO [(Name,HValueRef)] -- The returned HValueRefs are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods [] +linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = - case bc_breaks of - Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum) - Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray -> - inner ((breakarray, bc_bcos) : accum) + inner (Foldable.toList bc_bcos : accum) do_link [] = return [] do_link mods = do - let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] - names = map (unlinkedBCOName . snd) flat + let flat = [ bco | bcos <- mods, bco <- bcos ] + names = map unlinkedBCOName flat bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix breakarray bco - | (breakarray, bco) <- flat ] + resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -921,6 +984,11 @@ makeForeignNamedHValueRefs interp bindings = mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings +linkITbls :: Interp -> ItblEnv -> [(Name, ConInfoTable)] -> IO ItblEnv +linkITbls interp = foldlM $ \env (nm, itbl) -> do + r <- interpCmd interp $ MkConInfoTable itbl + evaluate $ extendNameEnv env nm (nm, ItblPtr r) + {- ********************************************************************** Unload some object modules @@ -977,7 +1045,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' @@ -1004,10 +1072,14 @@ keep_name n = isExternalName n && nameModule n `elemModuleEnv` remaining_bcos_loaded - !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env, - bcos_loaded = remaining_bcos_loaded, - objs_loaded = remaining_objs_loaded } + keep_mod :: Module -> Bool + keep_mod m = m `elemModuleEnv` remaining_bcos_loaded + !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env, + linked_breaks = filterLinkedBreaks keep_mod linked_breaks, + bcos_loaded = remaining_bcos_loaded, + objs_loaded = remaining_objs_loaded } + return new_pls where unloadObjs :: Linkable -> IO () @@ -1018,9 +1090,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 @@ -1367,7 +1439,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) @@ -1469,12 +1541,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) @@ -1507,7 +1578,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 @@ -1578,3 +1649,84 @@ maybePutStrLn :: Logger -> String -> IO () maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n") + +-- | see Note [Generating code for top-level string literal bindings] +allocateTopStrings :: + Interp -> [(Name, ByteString)] -> AddrEnv -> IO AddrEnv +allocateTopStrings interp topStrings prev_env = do + let (bndrs, strings) = unzip topStrings + ptrs <- interpCmd interp $ MallocStrings strings + evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs) + where + mk_entry nm ptr = (nm, (nm, AddrPtr ptr)) + +-- | Given a list of 'InternalModBreaks' collected from a list of +-- 'CompiledByteCode', allocate the 'BreakArray' used to trigger breakpoints. +allocateBreakArrays :: + Interp -> + ModuleEnv (ForeignRef BreakArray) -> + [InternalModBreaks] -> + IO (ModuleEnv (ForeignRef BreakArray)) +allocateBreakArrays interp = + foldlM + ( \be0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks {..}} -> do + -- If no BreakArray is assigned to this module yet, create one + if not $ elemModuleEnv modBreaks_module be0 then do + let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo + breakArray <- GHCi.newBreakArray interp count + evaluate $ extendModuleEnv be0 modBreaks_module breakArray + else + return be0 + ) + +-- | Given a list of 'InternalModBreaks' collected from a list +-- of 'CompiledByteCode', allocate the 'CostCentre' arrays when profiling is +-- enabled. +-- +-- Note that the resulting arrays are indexed by 'BreakInfoIndex' (internal +-- breakpoint index), not by tick index +allocateCCS :: + Interp -> + ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre)) -> + [InternalModBreaks] -> + IO (ModuleEnv (Array BreakInfoIndex (RemotePtr CostCentre))) +allocateCCS interp ce mbss + | interpreterProfiled interp = do + -- 1. Create a mapping from source BreakpointId to CostCentre ptr + ccss <- M.unions <$> mapM + ( \InternalModBreaks{imodBreaks_modBreaks=ModBreaks{..}} -> do + ccs <- {- one ccs ptr per tick index -} + mkCostCentres + interp + (moduleNameString $ moduleName modBreaks_module) + (elems modBreaks_ccs) + return $ M.fromList $ + zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..] + ) + mbss + -- 2. Create an array with one element for every InternalBreakpointId, + -- where every element has the CCS for the corresponding BreakpointId + foldlM + (\ce0 InternalModBreaks{imodBreaks_breakInfo, imodBreaks_modBreaks=ModBreaks{..}} -> do + if not $ elemModuleEnv modBreaks_module ce then do + let count = maybe 0 ((+1) . fst) $ IM.lookupMax imodBreaks_breakInfo + let ccs = IM.map + (\info -> + fromMaybe (toRemotePtr nullPtr) + (M.lookup (either internalBreakLoc id (cgb_tick_id info)) ccss) + ) + imodBreaks_breakInfo + assertPpr (count == length ccs) + (text "expected CgBreakInfo map to have one entry per valid ix") $ + evaluate $ + extendModuleEnv ce0 modBreaks_module $ + listArray + (0, count) + (IM.elems ccs) + else + return ce0 + ) + ce + mbss + + | otherwise = pure ce diff --git a/GHC/Linker/Static.hs b/GHC/Linker/Static.hs --- a/GHC/Linker/Static.hs +++ b/GHC/Linker/Static.hs @@ -26,6 +26,7 @@ import GHC.Linker.Unit import GHC.Linker.Dynamic import GHC.Linker.ExtraObj +import GHC.Linker.External import GHC.Linker.Windows import GHC.Linker.Static.Utils @@ -70,13 +71,23 @@ linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do let platform = ue_platform unit_env - unit_state = ue_units unit_env + unit_state = ue_homeUnitState unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags arch_os = platformArchOS platform 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 @@ -155,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, contained in other_flags -- needs to be put before -l, -- otherwise Solaris linker fails linking @@ -181,14 +192,12 @@ OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn _ -> return [] - let link dflags args | platformOS platform == OSDarwin - = do - GHC.SysTools.runLink logger tmpfs dflags args - -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 - when (gopt Opt_RPath dflags) $ - GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn - | otherwise - = GHC.SysTools.runLink logger tmpfs dflags args + let linker_config = initLinkerConfig dflags + let link dflags args = do + runLink logger tmpfs linker_config args + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (platformOS platform == OSDarwin && gopt Opt_RPath dflags) $ + GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn link dflags ( map GHC.SysTools.Option verbFlags @@ -220,25 +229,13 @@ 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? ++ (if toolSettings_ldIsGnuLd toolSettings' && not (gopt Opt_WholeArchiveHsLibs dflags) then ["-Wl,--gc-sections"] @@ -253,6 +250,13 @@ ++ pkg_lib_path_opts ++ extraLinkObj ++ noteLinkObjs + -- See Note [RTS/ghc-internal interface] + -- (-u must come before -lghc-internal...!) + ++ (if ghcInternalUnitId `elem` map unitId pkgs + then [concat [ "-Wl,-u," + , ['_' | platformLeadingUnderscore platform] + , "init_ghc_hs_iface" ]] + else []) ++ pkg_link_opts ++ pkg_framework_opts ++ (if platformOS platform == OSDarwin diff --git a/GHC/Linker/Types.hs b/GHC/Linker/Types.hs --- a/GHC/Linker/Types.hs +++ b/GHC/Linker/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- -- -- Types for the linkers and the loader @@ -5,7 +8,6 @@ -- (c) The University of Glasgow 2019 -- ----------------------------------------------------------------------------- -{-# LANGUAGE TypeApplications #-} module GHC.Linker.Types ( Loader (..) , LoaderState (..) @@ -16,47 +18,62 @@ , ClosureEnv , emptyClosureEnv , extendClosureEnv - , Linkable(..) + , LinkedBreaks(..) + , filterLinkedBreaks , LinkableSet , mkLinkableSet , unionLinkableSet , ObjFile - , Unlinked(..) , SptEntry(..) - , isObjectLinkable - , linkableObjs - , isObject - , nameOfObject - , nameOfObject_maybe - , isInterpretable - , byteCodeOfObject , LibrarySpec(..) , LoadedPkgInfo(..) , PkgsLoaded + + -- * Linkable + , Linkable(..) + , LinkablePart(..) + , LinkableObjectSort (..) + , linkableIsNativeCodeOnly + , linkableObjs + , linkableLibs + , linkableFiles + , linkableBCOs + , linkableNativeParts + , linkablePartitionParts + , linkablePartPath + , linkablePartAllBCOs + , isNativeCode + , isNativeLib + , linkableFilterByteCode + , linkableFilterNative + , partitionLinkables ) where import GHC.Prelude import GHC.Unit ( UnitId, Module ) -import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) -import GHC.Fingerprint.Type ( Fingerprint ) -import GHCi.RemoteTypes ( ForeignHValue, RemotePtr ) +import GHC.ByteCode.Types +import GHCi.BreakArray +import GHCi.RemoteTypes import GHCi.Message ( LoadedDLL ) -import GHC.Types.Var ( Id ) +import GHC.Stack.CCS import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) import GHC.Types.Name ( Name ) +import GHC.Types.SptEntry import GHC.Utils.Outputable -import GHC.Utils.Panic import Control.Concurrent.MVar +import Data.Array import Data.Time ( UTCTime ) -import Data.Maybe import GHC.Unit.Module.Env import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM import GHC.Unit.Module.WholeCoreBindings +import Data.Maybe (mapMaybe) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.List.NonEmpty as NE {- ********************************************************************** @@ -144,6 +161,9 @@ , temp_sos :: ![(FilePath, String)] -- ^ We need to remember the name of previous temporary DLL/.so -- libraries so we can link them (see #10322) + + , linked_breaks :: !LinkedBreaks + -- ^ Mapping from loaded modules to their breakpoint arrays } uninitializedLoader :: IO Loader @@ -162,7 +182,7 @@ , itbl_env :: !ItblEnv -- ^ The current global mapping from RdrNames of DataCons to -- info table addresses. - -- When a new Unlinked is linked into the running image, or an existing + -- When a new LinkablePart is linked into the running image, or an existing -- module in the image is replaced, the itbl_env must be updated -- appropriately. @@ -172,10 +192,10 @@ } filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv -filterLinkerEnv f le = LinkerEnv - { closure_env = filterNameEnv (f . fst) (closure_env le) - , itbl_env = filterNameEnv (f . fst) (itbl_env le) - , addr_env = filterNameEnv (f . fst) (addr_env le) +filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv + { closure_env = filterNameEnv (f . fst) closure_e + , itbl_env = filterNameEnv (f . fst) itbl_e + , addr_env = filterNameEnv (f . fst) addr_e } type ClosureEnv = NameEnv (Name, ForeignHValue) @@ -187,6 +207,29 @@ extendClosureEnv cl_env pairs = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] +-- | 'BreakArray's and CCSs are allocated per-module at link-time. +-- +-- Specifically, a module's 'BreakArray' is allocated either: +-- - When a BCO for that module is linked +-- - When :break is used on a given module *before* the BCO has been linked. +-- +-- We keep this structure in the 'LoaderState' +data LinkedBreaks + = LinkedBreaks + { breakarray_env :: !(ModuleEnv (ForeignRef BreakArray)) + -- ^ Each 'Module's remote pointer of 'BreakArray'. + + , ccs_env :: !(ModuleEnv (Array BreakTickIndex (RemotePtr CostCentre))) + -- ^ Each 'Module's array of remote pointers of 'CostCentre'. + -- Untouched when not profiling. + } + +filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks +filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks + { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e + , ccs_env = filterModuleEnv (\m _ -> f m) ccs_e + } + type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo data LoadedPkgInfo @@ -208,15 +251,17 @@ -- | Information we can use to dynamically link modules into the compiler -data Linkable = LM { - linkableTime :: !UTCTime, -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) - linkableModule :: !Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] - -- ^ Those files and chunks of code we have yet to link. - -- - -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. +data Linkable = Linkable + { linkableTime :: !UTCTime + -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + + , linkableModule :: !Module + -- ^ The linkable module itself + + , linkableParts :: NonEmpty LinkablePart + -- ^ Files and chunks of code to link. } type LinkableSet = ModuleEnv Linkable @@ -224,6 +269,9 @@ mkLinkableSet :: [Linkable] -> LinkableSet mkLinkableSet ls = mkModuleEnv [(linkableModule l, l) | l <- ls] +-- | Union of LinkableSets. +-- +-- In case of conflict, keep the most recent Linkable (as per linkableTime) unionLinkableSet :: LinkableSet -> LinkableSet -> LinkableSet unionLinkableSet = plusModuleEnv_C go where @@ -232,85 +280,200 @@ | otherwise = l2 instance Outputable Linkable where - ppr (LM when_made mod unlinkeds) - = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) - $$ nest 3 (ppr unlinkeds) + ppr (Linkable when_made mod parts) + = (text "Linkable" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr parts) type ObjFile = FilePath +-- | Classify the provenance of @.o@ products. +data LinkableObjectSort = + -- | The object is the final product for a module. + -- When linking splices, its file extension will be adapted to the + -- interpreter's way if needed. + ModuleObject + | + -- | The object was created from generated code for foreign stubs or foreign + -- sources added by the user. + -- Its file extension must be preserved, since there are no objects for + -- alternative ways available. + ForeignObject + -- | Objects which have yet to be linked by the compiler -data Unlinked - = DotO ObjFile -- ^ An object file (.o) - | DotA FilePath -- ^ Static archive file (.a) - | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | CoreBindings WholeCoreBindings -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend - -- See Note [Interface Files with Core Definitions] - | LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid - -- being too strict. +data LinkablePart + = DotO + ObjFile + -- ^ An object file (.o) + LinkableObjectSort + -- ^ Whether the object is an internal, intermediate build product that + -- should not be adapted to the interpreter's way. Used for foreign stubs + -- loaded from interfaces. + + | DotA FilePath + -- ^ Static archive file (.a) + + | DotDLL FilePath + -- ^ Dynamically linked library file (.so, .dll, .dylib) + + | CoreBindings WholeCoreBindings + -- ^ Serialised core which we can turn into BCOs (or object files), or + -- used by some other backend See Note [Interface Files with Core + -- Definitions] + + | LazyBCOs + CompiledByteCode + -- ^ Some BCOs generated on-demand when forced. This is used for + -- WholeCoreBindings, see Note [Interface Files with Core Definitions] + [FilePath] + -- ^ Objects containing foreign stubs and files + | BCOs CompiledByteCode - [SptEntry] -- ^ A byte-code object, lives only in memory. Also - -- carries some static pointer table entries which - -- should be loaded along with the BCOs. - -- See Note [Grand plan for static forms] in - -- "GHC.Iface.Tidy.StaticPtrTable". + -- ^ A byte-code object, lives only in memory. -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt - ppr (LoadedBCOs{}) = text "LoadedBCOs" - ppr (CoreBindings {}) = text "FI" +instance Outputable LinkablePart where + ppr (DotO path sort) = text "DotO" <+> text path <+> pprSort sort + where + pprSort = \case + ModuleObject -> empty + ForeignObject -> brackets (text "foreign") + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bco) = text "BCOs" <+> ppr bco + ppr (LazyBCOs{}) = text "LazyBCOs" + ppr (CoreBindings {}) = text "CoreBindings" --- | An entry to be inserted into a module's static pointer table. --- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -data SptEntry = SptEntry Id Fingerprint +-- | Return true if the linkable only consists of native code (no BCO) +linkableIsNativeCodeOnly :: Linkable -> Bool +linkableIsNativeCodeOnly l = all isNativeCode (NE.toList (linkableParts l)) -instance Outputable SptEntry where - ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr +-- | List the BCOs parts of a linkable. +-- +-- This excludes the LazyBCOs and the CoreBindings parts +linkableBCOs :: Linkable -> [CompiledByteCode] +linkableBCOs l = [ cbc | BCOs cbc <- NE.toList (linkableParts l) ] +-- | List the native linkable parts (.o/.so/.dll) of a linkable +linkableNativeParts :: Linkable -> [LinkablePart] +linkableNativeParts l = NE.filter isNativeCode (linkableParts l) -isObjectLinkable :: Linkable -> Bool -isObjectLinkable l = not (null unlinked) && all isObject unlinked - where unlinked = linkableUnlinked l - -- A linkable with no Unlinked's is treated as a BCO. We can - -- generate a linkable with no Unlinked's as a result of - -- compiling a module in NoBackend mode, and this choice - -- happens to work well with checkStability in module GHC. +-- | Split linkable parts into (native code parts, BCOs parts) +linkablePartitionParts :: Linkable -> ([LinkablePart],[LinkablePart]) +linkablePartitionParts l = NE.partition isNativeCode (linkableParts l) +-- | List the native objects (.o) of a linkable linkableObjs :: Linkable -> [FilePath] -linkableObjs l = [ f | DotO f <- linkableUnlinked l ] +linkableObjs l = concatMap linkablePartObjectPaths (linkableParts l) +-- | List the native libraries (.so/.dll) of a linkable +linkableLibs :: Linkable -> [LinkablePart] +linkableLibs l = NE.filter isNativeLib (linkableParts l) + +-- | List the paths of the native objects and libraries (.o/.so/.dll) +linkableFiles :: Linkable -> [FilePath] +linkableFiles l = concatMap linkablePartNativePaths (NE.toList (linkableParts l)) + ------------------------------------------- --- | Is this an actual file on disk we can link in somehow? -isObject :: Unlinked -> Bool -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False +-- | Is the part a native object or library? (.o/.so/.dll) +isNativeCode :: LinkablePart -> Bool +isNativeCode = \case + DotO {} -> True + DotA {} -> True + DotDLL {} -> True + BCOs {} -> False + LazyBCOs{} -> False + CoreBindings {} -> False --- | Is this a bytecode linkable with no file on disk? -isInterpretable :: Unlinked -> Bool -isInterpretable = not . isObject +-- | Is the part a native library? (.so/.dll) +isNativeLib :: LinkablePart -> Bool +isNativeLib = \case + DotO {} -> False + DotA {} -> True + DotDLL {} -> True + BCOs {} -> False + LazyBCOs{} -> False + CoreBindings {} -> False -nameOfObject_maybe :: Unlinked -> Maybe FilePath -nameOfObject_maybe (DotO fn) = Just fn -nameOfObject_maybe (DotA fn) = Just fn -nameOfObject_maybe (DotDLL fn) = Just fn -nameOfObject_maybe (CoreBindings {}) = Nothing -nameOfObject_maybe (LoadedBCOs{}) = Nothing -nameOfObject_maybe (BCOs {}) = Nothing +-- | Get the FilePath of linkable part (if applicable) +linkablePartPath :: LinkablePart -> Maybe FilePath +linkablePartPath = \case + DotO fn _ -> Just fn + DotA fn -> Just fn + DotDLL fn -> Just fn + CoreBindings {} -> Nothing + LazyBCOs {} -> Nothing + BCOs {} -> Nothing --- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object -nameOfObject :: Unlinked -> FilePath -nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o) +-- | Return the paths of all object code files (.o, .a, .so) contained in this +-- 'LinkablePart'. +linkablePartNativePaths :: LinkablePart -> [FilePath] +linkablePartNativePaths = \case + DotO fn _ -> [fn] + DotA fn -> [fn] + DotDLL fn -> [fn] + CoreBindings {} -> [] + LazyBCOs _ fos -> fos + BCOs {} -> [] --- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> [CompiledByteCode] -byteCodeOfObject (BCOs bc _) = [bc] -byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) +-- | Return the paths of all object files (.o) contained in this 'LinkablePart'. +linkablePartObjectPaths :: LinkablePart -> [FilePath] +linkablePartObjectPaths = \case + DotO fn _ -> [fn] + DotA _ -> [] + DotDLL _ -> [] + CoreBindings {} -> [] + LazyBCOs _ fos -> fos + BCOs {} -> [] + +-- | Retrieve the compiled byte-code from the linkable part. +-- +-- Contrary to linkableBCOs, this includes byte-code from LazyBCOs. +linkablePartAllBCOs :: LinkablePart -> [CompiledByteCode] +linkablePartAllBCOs = \case + BCOs bco -> [bco] + LazyBCOs bcos _ -> [bcos] + _ -> [] + +linkableFilter :: (LinkablePart -> [LinkablePart]) -> Linkable -> Maybe Linkable +linkableFilter f linkable = do + new <- nonEmpty (concatMap f (linkableParts linkable)) + Just linkable {linkableParts = new} + +linkablePartNative :: LinkablePart -> [LinkablePart] +linkablePartNative = \case + u@DotO {} -> [u] + u@DotA {} -> [u] + u@DotDLL {} -> [u] + LazyBCOs _ os -> [DotO f ForeignObject | f <- os] + _ -> [] + +linkablePartByteCode :: LinkablePart -> [LinkablePart] +linkablePartByteCode = \case + u@BCOs {} -> [u] + LazyBCOs bcos _ -> [BCOs bcos] + _ -> [] + +-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only +-- object code files (.o, .a, .so) without 'LazyBCOs'. +-- If no 'LinkablePart' remains, return 'Nothing'. +linkableFilterNative :: Linkable -> Maybe Linkable +linkableFilterNative = linkableFilter linkablePartNative + +-- | Transform the 'LinkablePart' list in this 'Linkable' to contain only byte +-- code without 'LazyBCOs'. +-- If no 'LinkablePart' remains, return 'Nothing'. +linkableFilterByteCode :: Linkable -> Maybe Linkable +linkableFilterByteCode = linkableFilter linkablePartByteCode + +-- | Split the 'LinkablePart' lists in each 'Linkable' into only object code +-- files (.o, .a, .so) and only byte code, without 'LazyBCOs', and return two +-- lists containing the nonempty 'Linkable's for each. +partitionLinkables :: [Linkable] -> ([Linkable], [Linkable]) +partitionLinkables linkables = + ( + mapMaybe linkableFilterNative linkables, + mapMaybe linkableFilterByteCode linkables + ) {- ********************************************************************** diff --git a/GHC/Linker/Unit.hs b/GHC/Linker/Unit.hs --- a/GHC/Linker/Unit.hs +++ b/GHC/Linker/Unit.hs @@ -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 = diff --git a/GHC/Llvm.hs b/GHC/Llvm.hs --- a/GHC/Llvm.hs +++ b/GHC/Llvm.hs @@ -42,6 +42,10 @@ -- ** Metadata types MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..), + -- *** Module flags + ModuleFlagBehavior(..), + ModuleFlag(..), + moduleFlagToMetaExpr, -- ** Operations on the type system. isGlobal, getLitType, getVarType, diff --git a/GHC/Llvm/MetaData.hs b/GHC/Llvm/MetaData.hs --- a/GHC/Llvm/MetaData.hs +++ b/GHC/Llvm/MetaData.hs @@ -1,6 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module GHC.Llvm.MetaData where +module GHC.Llvm.MetaData + ( MetaId(..) + , ppMetaId + , MetaExpr(..) + , MetaAnnot(..) + , MetaDecl(..) + -- * Module flags + , ModuleFlagBehavior(..) + , ModuleFlag(..) + , moduleFlagToMetaExpr + ) where import GHC.Prelude @@ -73,6 +83,7 @@ -- | LLVM metadata expressions data MetaExpr = MetaStr !LMString + | MetaLit !LlvmLit | MetaNode !MetaId | MetaVar !LlvmVar | MetaStruct [MetaExpr] @@ -91,3 +102,42 @@ -- | Metadata node declaration. -- ('!0 = metadata !{ \ }' form). | MetaUnnamed !MetaId !MetaExpr + +---------------------------------------------------------------- +-- Module flags +---------------------------------------------------------------- +data ModuleFlagBehavior + = MFBError + | MFBWarning + | MFBRequire + | MFBOverride + | MFBAppend + | MFBAppendUnique + | MFBMax + | MFBMin + +moduleFlagBehaviorToMetaExpr :: ModuleFlagBehavior -> MetaExpr +moduleFlagBehaviorToMetaExpr mfb = + MetaLit $ LMIntLit n i32 + where + n = case mfb of + MFBError -> 1 + MFBWarning -> 2 + MFBRequire -> 3 + MFBOverride -> 4 + MFBAppend -> 5 + MFBAppendUnique -> 6 + MFBMax -> 7 + MFBMin -> 8 + +data ModuleFlag = ModuleFlag { mfBehavior :: ModuleFlagBehavior + , mfName :: LMString + , mfValue :: MetaExpr + } + +moduleFlagToMetaExpr :: ModuleFlag -> MetaExpr +moduleFlagToMetaExpr flag = MetaStruct + [ moduleFlagBehaviorToMetaExpr (mfBehavior flag) + , MetaStr (mfName flag) + , mfValue flag + ] diff --git a/GHC/Llvm/Ppr.hs b/GHC/Llvm/Ppr.hs --- a/GHC/Llvm/Ppr.hs +++ b/GHC/Llvm/Ppr.hs @@ -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 @@ -297,6 +298,7 @@ ppMetaExpr opts = \case MetaVar (LMLitVar (LMNullLit _)) -> text "null" MetaStr s -> char '!' <> doubleQuotes (ftext s) + MetaLit l -> ppTypeLit opts l MetaNode n -> ppMetaId n MetaVar v -> ppVar opts v MetaStruct es -> char '!' <> braces (ppCommaJoin (ppMetaExpr opts) es) @@ -576,6 +578,15 @@ {-# 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 = ppLlvmExpression opts expr <> ppMetaAnnots opts meta @@ -658,9 +669,7 @@ {-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ppTypeLit' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> doc -ppTypeLit' attrs opts l = case l of - LMVectorLit {} -> ppLit opts l - _ -> ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l +ppTypeLit' attrs opts l = ppLlvmType (getLitType l) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppLit opts l {-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc #-} {-# SPECIALIZE ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/GHC/Llvm/Syntax.hs b/GHC/Llvm/Syntax.hs --- a/GHC/Llvm/Syntax.hs +++ b/GHC/Llvm/Syntax.hs @@ -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 diff --git a/GHC/Llvm/Types.hs b/GHC/Llvm/Types.hs --- a/GHC/Llvm/Types.hs +++ b/GHC/Llvm/Types.hs @@ -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 @@ -230,7 +239,7 @@ pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c pVarLift (LMLocalVar s t ) = LMLocalVar s (pLift t) pVarLift (LMNLocalVar s t ) = LMNLocalVar s (pLift t) -pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!" +pVarLift (LMLitVar _ ) = error $ "Can't lift a literal type!" -- | Remove the pointer indirection of the supplied type. Only 'LMPointer' -- constructors can be lowered. diff --git a/GHC/Parser.hs b/GHC/Parser.hs --- a/GHC/Parser.hs +++ b/GHC/Parser.hs @@ -9,13326 +9,14059 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} - --- | This module provides the generated Happy parser for Haskell. It exports --- a number of parsers which may be used in any library that uses the GHC API. --- A common usage pattern is to initialize the parser state with a given string --- and then parse that string: --- --- @ --- runParser :: ParserOpts -> String -> P a -> ParseResult a --- runParser opts str parser = unP parser parseState --- where --- filename = "\" --- location = mkRealSrcLoc (mkFastString filename) 1 1 --- buffer = stringToStringBuffer str --- parseState = initParserState opts buffer location --- @ -module GHC.Parser - ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack - , parseDeclaration, parseExpression, parsePattern - , parseTypeSignature - , parseStmt, parseIdentifier - , parseType, parseHeader - , parseModuleNoHaddock - ) -where - --- base -import Control.Monad ( unless, liftM, when, (<=<) ) -import GHC.Exts -import Data.Maybe ( maybeToList ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import qualified Prelude -- for happy-generated code - -import GHC.Hs - -import GHC.Driver.Backpack.Syntax - -import GHC.Unit.Info -import GHC.Unit.Module -import GHC.Unit.Module.Warnings - -import GHC.Data.OrdList -import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue ) -import GHC.Data.FastString -import GHC.Data.Maybe ( orElse ) - -import GHC.Utils.Outputable -import GHC.Utils.Error -import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) -import GHC.Utils.Panic -import GHC.Prelude -import qualified GHC.Data.Strict as Strict - -import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS) -import GHC.Types.SrcLoc -import GHC.Types.Basic -import GHC.Types.Error ( GhcHint(..) ) -import GHC.Types.Fixity -import GHC.Types.ForeignCall -import GHC.Types.SourceFile -import GHC.Types.SourceText -import GHC.Types.PkgQual - -import GHC.Core.Type ( Specificity(..) ) -import GHC.Core.Class ( FunDep ) -import GHC.Core.DataCon ( DataCon, dataConName ) - -import GHC.Parser.PostProcess -import GHC.Parser.PostProcess.Haddock -import GHC.Parser.Lexer -import GHC.Parser.HaddockLex -import GHC.Parser.Annotation -import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr () - -import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon, - tupleTyCon, tupleDataCon, nilDataCon, - unboxedUnitTyCon, unboxedUnitDataCon, - listTyCon_RDR, consDataCon_RDR, - unrestrictedFunTyCon ) - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import qualified Data.Semigroup as Semi -import qualified Data.Array as Happy_Data_Array -import qualified Data.Bits as Bits -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) -import Control.Monad (ap) - --- parser produced by Happy Version 1.20.1.1 - -newtype HappyAbsSyn = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -newtype HappyWrap16 = HappyWrap16 (LocatedN RdrName) -happyIn16 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -newtype HappyWrap17 = HappyWrap17 ([LHsUnit PackageName]) -happyIn17 :: ([LHsUnit PackageName]) -> (HappyAbsSyn ) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -newtype HappyWrap18 = HappyWrap18 (OrdList (LHsUnit PackageName)) -happyIn18 :: (OrdList (LHsUnit PackageName)) -> (HappyAbsSyn ) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -newtype HappyWrap19 = HappyWrap19 (LHsUnit PackageName) -happyIn19 :: (LHsUnit PackageName) -> (HappyAbsSyn ) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -newtype HappyWrap20 = HappyWrap20 (LHsUnitId PackageName) -happyIn20 :: (LHsUnitId PackageName) -> (HappyAbsSyn ) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -newtype HappyWrap21 = HappyWrap21 (OrdList (LHsModuleSubst PackageName)) -happyIn21 :: (OrdList (LHsModuleSubst PackageName)) -> (HappyAbsSyn ) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -newtype HappyWrap22 = HappyWrap22 (LHsModuleSubst PackageName) -happyIn22 :: (LHsModuleSubst PackageName) -> (HappyAbsSyn ) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -newtype HappyWrap23 = HappyWrap23 (LHsModuleId PackageName) -happyIn23 :: (LHsModuleId PackageName) -> (HappyAbsSyn ) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -newtype HappyWrap24 = HappyWrap24 (Located PackageName) -happyIn24 :: (Located PackageName) -> (HappyAbsSyn ) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -newtype HappyWrap25 = HappyWrap25 (Located FastString) -happyIn25 :: (Located FastString) -> (HappyAbsSyn ) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -newtype HappyWrap26 = HappyWrap26 ([AddEpAnn]) -happyIn26 :: ([AddEpAnn]) -> (HappyAbsSyn ) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -newtype HappyWrap27 = HappyWrap27 (Located FastString) -happyIn27 :: (Located FastString) -> (HappyAbsSyn ) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -newtype HappyWrap28 = HappyWrap28 (Maybe [LRenaming]) -happyIn28 :: (Maybe [LRenaming]) -> (HappyAbsSyn ) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -newtype HappyWrap29 = HappyWrap29 (OrdList LRenaming) -happyIn29 :: (OrdList LRenaming) -> (HappyAbsSyn ) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -newtype HappyWrap30 = HappyWrap30 (LRenaming) -happyIn30 :: (LRenaming) -> (HappyAbsSyn ) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -newtype HappyWrap31 = HappyWrap31 (OrdList (LHsUnitDecl PackageName)) -happyIn31 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -newtype HappyWrap32 = HappyWrap32 (OrdList (LHsUnitDecl PackageName)) -happyIn32 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -newtype HappyWrap33 = HappyWrap33 (LHsUnitDecl PackageName) -happyIn33 :: (LHsUnitDecl PackageName) -> (HappyAbsSyn ) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -newtype HappyWrap34 = HappyWrap34 (Located (HsModule GhcPs)) -happyIn34 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -newtype HappyWrap35 = HappyWrap35 (Located (HsModule GhcPs)) -happyIn35 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -newtype HappyWrap36 = HappyWrap36 (()) -happyIn36 :: (()) -> (HappyAbsSyn ) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -newtype HappyWrap37 = HappyWrap37 (()) -happyIn37 :: (()) -> (HappyAbsSyn ) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -newtype HappyWrap38 = HappyWrap38 (Maybe (LocatedP (WarningTxt GhcPs))) -happyIn38 :: (Maybe (LocatedP (WarningTxt GhcPs))) -> (HappyAbsSyn ) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -newtype HappyWrap39 = HappyWrap39 (([TrailingAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo GhcPs)) -happyIn39 :: (([TrailingAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo GhcPs)) -> (HappyAbsSyn ) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -newtype HappyWrap40 = HappyWrap40 (([TrailingAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo GhcPs)) -happyIn40 :: (([TrailingAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo GhcPs)) -> (HappyAbsSyn ) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -newtype HappyWrap41 = HappyWrap41 (([TrailingAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -happyIn41 :: (([TrailingAnn] - ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (HappyAbsSyn ) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -newtype HappyWrap42 = HappyWrap42 (([LImportDecl GhcPs], [LHsDecl GhcPs])) -happyIn42 :: (([LImportDecl GhcPs], [LHsDecl GhcPs])) -> (HappyAbsSyn ) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -newtype HappyWrap43 = HappyWrap43 (Located (HsModule GhcPs)) -happyIn43 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -newtype HappyWrap44 = HappyWrap44 ([LImportDecl GhcPs]) -happyIn44 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -newtype HappyWrap45 = HappyWrap45 ([LImportDecl GhcPs]) -happyIn45 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -newtype HappyWrap46 = HappyWrap46 ([LImportDecl GhcPs]) -happyIn46 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -newtype HappyWrap47 = HappyWrap47 ([LImportDecl GhcPs]) -happyIn47 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -newtype HappyWrap48 = HappyWrap48 ((Maybe (LocatedL [LIE GhcPs]))) -happyIn48 :: ((Maybe (LocatedL [LIE GhcPs]))) -> (HappyAbsSyn ) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -newtype HappyWrap49 = HappyWrap49 (([AddEpAnn], OrdList (LIE GhcPs))) -happyIn49 :: (([AddEpAnn], OrdList (LIE GhcPs))) -> (HappyAbsSyn ) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -newtype HappyWrap50 = HappyWrap50 (OrdList (LIE GhcPs)) -happyIn50 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -newtype HappyWrap51 = HappyWrap51 (OrdList (LIE GhcPs)) -happyIn51 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -newtype HappyWrap52 = HappyWrap52 (Maybe (LocatedP (WarningTxt GhcPs))) -happyIn52 :: (Maybe (LocatedP (WarningTxt GhcPs))) -> (HappyAbsSyn ) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -newtype HappyWrap53 = HappyWrap53 (Located ([AddEpAnn],ImpExpSubSpec)) -happyIn53 :: (Located ([AddEpAnn],ImpExpSubSpec)) -> (HappyAbsSyn ) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -newtype HappyWrap54 = HappyWrap54 (([AddEpAnn], [LocatedA ImpExpQcSpec])) -happyIn54 :: (([AddEpAnn], [LocatedA ImpExpQcSpec])) -> (HappyAbsSyn ) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -newtype HappyWrap55 = HappyWrap55 (([AddEpAnn], [LocatedA ImpExpQcSpec])) -happyIn55 :: (([AddEpAnn], [LocatedA ImpExpQcSpec])) -> (HappyAbsSyn ) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -newtype HappyWrap56 = HappyWrap56 (Located ([AddEpAnn], LocatedA ImpExpQcSpec)) -happyIn56 :: (Located ([AddEpAnn], LocatedA ImpExpQcSpec)) -> (HappyAbsSyn ) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -newtype HappyWrap57 = HappyWrap57 (LocatedA ImpExpQcSpec) -happyIn57 :: (LocatedA ImpExpQcSpec) -> (HappyAbsSyn ) -happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 -happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut57 #-} -newtype HappyWrap58 = HappyWrap58 (LocatedN RdrName) -happyIn58 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 -happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut58 #-} -newtype HappyWrap59 = HappyWrap59 (Located [TrailingAnn]) -happyIn59 :: (Located [TrailingAnn]) -> (HappyAbsSyn ) -happyIn59 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap59 x) -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> HappyWrap59 -happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut59 #-} -newtype HappyWrap60 = HappyWrap60 ([TrailingAnn]) -happyIn60 :: ([TrailingAnn]) -> (HappyAbsSyn ) -happyIn60 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap60 x) -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn ) -> HappyWrap60 -happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut60 #-} -newtype HappyWrap61 = HappyWrap61 ([LImportDecl GhcPs]) -happyIn61 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) -happyIn61 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap61 x) -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn ) -> HappyWrap61 -happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut61 #-} -newtype HappyWrap62 = HappyWrap62 ([LImportDecl GhcPs]) -happyIn62 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) -happyIn62 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap62 x) -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn ) -> HappyWrap62 -happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut62 #-} -newtype HappyWrap63 = HappyWrap63 (LImportDecl GhcPs) -happyIn63 :: (LImportDecl GhcPs) -> (HappyAbsSyn ) -happyIn63 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap63 x) -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn ) -> HappyWrap63 -happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut63 #-} -newtype HappyWrap64 = HappyWrap64 (((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface)) -happyIn64 :: (((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface)) -> (HappyAbsSyn ) -happyIn64 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap64 x) -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn ) -> HappyWrap64 -happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut64 #-} -newtype HappyWrap65 = HappyWrap65 ((Maybe EpaLocation,Bool)) -happyIn65 :: ((Maybe EpaLocation,Bool)) -> (HappyAbsSyn ) -happyIn65 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap65 x) -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn ) -> HappyWrap65 -happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut65 #-} -newtype HappyWrap66 = HappyWrap66 ((Maybe EpaLocation, RawPkgQual)) -happyIn66 :: ((Maybe EpaLocation, RawPkgQual)) -> (HappyAbsSyn ) -happyIn66 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap66 x) -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn ) -> HappyWrap66 -happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut66 #-} -newtype HappyWrap67 = HappyWrap67 (Located (Maybe EpaLocation)) -happyIn67 :: (Located (Maybe EpaLocation)) -> (HappyAbsSyn ) -happyIn67 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap67 x) -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn ) -> HappyWrap67 -happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut67 #-} -newtype HappyWrap68 = HappyWrap68 ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName)))) -happyIn68 :: ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName)))) -> (HappyAbsSyn ) -happyIn68 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap68 x) -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn ) -> HappyWrap68 -happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut68 #-} -newtype HappyWrap69 = HappyWrap69 (Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]))) -happyIn69 :: (Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]))) -> (HappyAbsSyn ) -happyIn69 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap69 x) -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn ) -> HappyWrap69 -happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut69 #-} -newtype HappyWrap70 = HappyWrap70 (Located (ImportListInterpretation, LocatedL [LIE GhcPs])) -happyIn70 :: (Located (ImportListInterpretation, LocatedL [LIE GhcPs])) -> (HappyAbsSyn ) -happyIn70 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap70 x) -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn ) -> HappyWrap70 -happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut70 #-} -newtype HappyWrap71 = HappyWrap71 (([AddEpAnn], OrdList (LIE GhcPs))) -happyIn71 :: (([AddEpAnn], OrdList (LIE GhcPs))) -> (HappyAbsSyn ) -happyIn71 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap71 x) -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn ) -> HappyWrap71 -happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut71 #-} -newtype HappyWrap72 = HappyWrap72 (OrdList (LIE GhcPs)) -happyIn72 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) -happyIn72 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap72 x) -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn ) -> HappyWrap72 -happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut72 #-} -newtype HappyWrap73 = HappyWrap73 (OrdList (LIE GhcPs)) -happyIn73 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) -happyIn73 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap73 x) -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn ) -> HappyWrap73 -happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut73 #-} -newtype HappyWrap74 = HappyWrap74 (Maybe (Located (SourceText,Int))) -happyIn74 :: (Maybe (Located (SourceText,Int))) -> (HappyAbsSyn ) -happyIn74 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap74 x) -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn ) -> HappyWrap74 -happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut74 #-} -newtype HappyWrap75 = HappyWrap75 (Located FixityDirection) -happyIn75 :: (Located FixityDirection) -> (HappyAbsSyn ) -happyIn75 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap75 x) -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn ) -> HappyWrap75 -happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut75 #-} -newtype HappyWrap76 = HappyWrap76 (Located (OrdList (LocatedN RdrName))) -happyIn76 :: (Located (OrdList (LocatedN RdrName))) -> (HappyAbsSyn ) -happyIn76 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap76 x) -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn ) -> HappyWrap76 -happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut76 #-} -newtype HappyWrap77 = HappyWrap77 (OrdList (LHsDecl GhcPs)) -happyIn77 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) -happyIn77 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap77 x) -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn ) -> HappyWrap77 -happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut77 #-} -newtype HappyWrap78 = HappyWrap78 (OrdList (LHsDecl GhcPs)) -happyIn78 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) -happyIn78 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap78 x) -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn ) -> HappyWrap78 -happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut78 #-} -newtype HappyWrap79 = HappyWrap79 (OrdList (LHsDecl GhcPs)) -happyIn79 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) -happyIn79 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap79 x) -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn ) -> HappyWrap79 -happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut79 #-} -newtype HappyWrap80 = HappyWrap80 (OrdList (LHsDecl GhcPs)) -happyIn80 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) -happyIn80 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap80 x) -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn ) -> HappyWrap80 -happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut80 #-} -newtype HappyWrap81 = HappyWrap81 (LHsDecl GhcPs) -happyIn81 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn81 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap81 x) -{-# INLINE happyIn81 #-} -happyOut81 :: (HappyAbsSyn ) -> HappyWrap81 -happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut81 #-} -newtype HappyWrap82 = HappyWrap82 (LHsDecl GhcPs) -happyIn82 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn82 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap82 x) -{-# INLINE happyIn82 #-} -happyOut82 :: (HappyAbsSyn ) -> HappyWrap82 -happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut82 #-} -newtype HappyWrap83 = HappyWrap83 (LTyClDecl GhcPs) -happyIn83 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) -happyIn83 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap83 x) -{-# INLINE happyIn83 #-} -happyOut83 :: (HappyAbsSyn ) -> HappyWrap83 -happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut83 #-} -newtype HappyWrap84 = HappyWrap84 (LTyClDecl GhcPs) -happyIn84 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) -happyIn84 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap84 x) -{-# INLINE happyIn84 #-} -happyOut84 :: (HappyAbsSyn ) -> HappyWrap84 -happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut84 #-} -newtype HappyWrap85 = HappyWrap85 (LStandaloneKindSig GhcPs) -happyIn85 :: (LStandaloneKindSig GhcPs) -> (HappyAbsSyn ) -happyIn85 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap85 x) -{-# INLINE happyIn85 #-} -happyOut85 :: (HappyAbsSyn ) -> HappyWrap85 -happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut85 #-} -newtype HappyWrap86 = HappyWrap86 (Located [LocatedN RdrName]) -happyIn86 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn86 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap86 x) -{-# INLINE happyIn86 #-} -happyOut86 :: (HappyAbsSyn ) -> HappyWrap86 -happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut86 #-} -newtype HappyWrap87 = HappyWrap87 (LInstDecl GhcPs) -happyIn87 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) -happyIn87 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap87 x) -{-# INLINE happyIn87 #-} -happyOut87 :: (HappyAbsSyn ) -> HappyWrap87 -happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut87 #-} -newtype HappyWrap88 = HappyWrap88 (Maybe (LocatedP OverlapMode)) -happyIn88 :: (Maybe (LocatedP OverlapMode)) -> (HappyAbsSyn ) -happyIn88 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap88 x) -{-# INLINE happyIn88 #-} -happyOut88 :: (HappyAbsSyn ) -> HappyWrap88 -happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut88 #-} -newtype HappyWrap89 = HappyWrap89 (LDerivStrategy GhcPs) -happyIn89 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) -happyIn89 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap89 x) -{-# INLINE happyIn89 #-} -happyOut89 :: (HappyAbsSyn ) -> HappyWrap89 -happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut89 #-} -newtype HappyWrap90 = HappyWrap90 (LDerivStrategy GhcPs) -happyIn90 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) -happyIn90 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap90 x) -{-# INLINE happyIn90 #-} -happyOut90 :: (HappyAbsSyn ) -> HappyWrap90 -happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut90 #-} -newtype HappyWrap91 = HappyWrap91 (Maybe (LDerivStrategy GhcPs)) -happyIn91 :: (Maybe (LDerivStrategy GhcPs)) -> (HappyAbsSyn ) -happyIn91 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap91 x) -{-# INLINE happyIn91 #-} -happyOut91 :: (HappyAbsSyn ) -> HappyWrap91 -happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut91 #-} -newtype HappyWrap92 = HappyWrap92 (Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs))) -happyIn92 :: (Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs))) -> (HappyAbsSyn ) -happyIn92 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap92 x) -{-# INLINE happyIn92 #-} -happyOut92 :: (HappyAbsSyn ) -> HappyWrap92 -happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut92 #-} -newtype HappyWrap93 = HappyWrap93 (LInjectivityAnn GhcPs) -happyIn93 :: (LInjectivityAnn GhcPs) -> (HappyAbsSyn ) -happyIn93 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap93 x) -{-# INLINE happyIn93 #-} -happyOut93 :: (HappyAbsSyn ) -> HappyWrap93 -happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut93 #-} -newtype HappyWrap94 = HappyWrap94 (Located [LocatedN RdrName]) -happyIn94 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn94 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap94 x) -{-# INLINE happyIn94 #-} -happyOut94 :: (HappyAbsSyn ) -> HappyWrap94 -happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut94 #-} -newtype HappyWrap95 = HappyWrap95 (Located ([AddEpAnn],FamilyInfo GhcPs)) -happyIn95 :: (Located ([AddEpAnn],FamilyInfo GhcPs)) -> (HappyAbsSyn ) -happyIn95 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap95 x) -{-# INLINE happyIn95 #-} -happyOut95 :: (HappyAbsSyn ) -> HappyWrap95 -happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut95 #-} -newtype HappyWrap96 = HappyWrap96 (Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs])) -happyIn96 :: (Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs])) -> (HappyAbsSyn ) -happyIn96 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap96 x) -{-# INLINE happyIn96 #-} -happyOut96 :: (HappyAbsSyn ) -> HappyWrap96 -happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut96 #-} -newtype HappyWrap97 = HappyWrap97 (Located [LTyFamInstEqn GhcPs]) -happyIn97 :: (Located [LTyFamInstEqn GhcPs]) -> (HappyAbsSyn ) -happyIn97 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap97 x) -{-# INLINE happyIn97 #-} -happyOut97 :: (HappyAbsSyn ) -> HappyWrap97 -happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut97 #-} -newtype HappyWrap98 = HappyWrap98 (LTyFamInstEqn GhcPs) -happyIn98 :: (LTyFamInstEqn GhcPs) -> (HappyAbsSyn ) -happyIn98 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap98 x) -{-# INLINE happyIn98 #-} -happyOut98 :: (HappyAbsSyn ) -> HappyWrap98 -happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut98 #-} -newtype HappyWrap99 = HappyWrap99 (LHsDecl GhcPs) -happyIn99 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn99 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap99 x) -{-# INLINE happyIn99 #-} -happyOut99 :: (HappyAbsSyn ) -> HappyWrap99 -happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut99 #-} -newtype HappyWrap100 = HappyWrap100 ([AddEpAnn]) -happyIn100 :: ([AddEpAnn]) -> (HappyAbsSyn ) -happyIn100 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap100 x) -{-# INLINE happyIn100 #-} -happyOut100 :: (HappyAbsSyn ) -> HappyWrap100 -happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut100 #-} -newtype HappyWrap101 = HappyWrap101 ([AddEpAnn]) -happyIn101 :: ([AddEpAnn]) -> (HappyAbsSyn ) -happyIn101 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap101 x) -{-# INLINE happyIn101 #-} -happyOut101 :: (HappyAbsSyn ) -> HappyWrap101 -happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut101 #-} -newtype HappyWrap102 = HappyWrap102 (LInstDecl GhcPs) -happyIn102 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) -happyIn102 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap102 x) -{-# INLINE happyIn102 #-} -happyOut102 :: (HappyAbsSyn ) -> HappyWrap102 -happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut102 #-} -newtype HappyWrap103 = HappyWrap103 (Located ([AddEpAnn], Bool, NewOrData)) -happyIn103 :: (Located ([AddEpAnn], Bool, NewOrData)) -> (HappyAbsSyn ) -happyIn103 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap103 x) -{-# INLINE happyIn103 #-} -happyOut103 :: (HappyAbsSyn ) -> HappyWrap103 -happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut103 #-} -newtype HappyWrap104 = HappyWrap104 (Located (AddEpAnn, NewOrData)) -happyIn104 :: (Located (AddEpAnn, NewOrData)) -> (HappyAbsSyn ) -happyIn104 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap104 x) -{-# INLINE happyIn104 #-} -happyOut104 :: (HappyAbsSyn ) -> HappyWrap104 -happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut104 #-} -newtype HappyWrap105 = HappyWrap105 (Located ([AddEpAnn], Maybe (LHsKind GhcPs))) -happyIn105 :: (Located ([AddEpAnn], Maybe (LHsKind GhcPs))) -> (HappyAbsSyn ) -happyIn105 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap105 x) -{-# INLINE happyIn105 #-} -happyOut105 :: (HappyAbsSyn ) -> HappyWrap105 -happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut105 #-} -newtype HappyWrap106 = HappyWrap106 (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -happyIn106 :: (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) -happyIn106 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap106 x) -{-# INLINE happyIn106 #-} -happyOut106 :: (HappyAbsSyn ) -> HappyWrap106 -happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut106 #-} -newtype HappyWrap107 = HappyWrap107 (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -happyIn107 :: (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) -happyIn107 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap107 x) -{-# INLINE happyIn107 #-} -happyOut107 :: (HappyAbsSyn ) -> HappyWrap107 -happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut107 #-} -newtype HappyWrap108 = HappyWrap108 (Located ([AddEpAnn], ( LFamilyResultSig GhcPs - , Maybe (LInjectivityAnn GhcPs)))) -happyIn108 :: (Located ([AddEpAnn], ( LFamilyResultSig GhcPs - , Maybe (LInjectivityAnn GhcPs)))) -> (HappyAbsSyn ) -happyIn108 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap108 x) -{-# INLINE happyIn108 #-} -happyOut108 :: (HappyAbsSyn ) -> HappyWrap108 -happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut108 #-} -newtype HappyWrap109 = HappyWrap109 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) -happyIn109 :: (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) -> (HappyAbsSyn ) -happyIn109 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap109 x) -{-# INLINE happyIn109 #-} -happyOut109 :: (HappyAbsSyn ) -> HappyWrap109 -happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut109 #-} -newtype HappyWrap110 = HappyWrap110 (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -happyIn110 :: (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -> (HappyAbsSyn ) -happyIn110 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap110 x) -{-# INLINE happyIn110 #-} -happyOut110 :: (HappyAbsSyn ) -> HappyWrap110 -happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut110 #-} -newtype HappyWrap111 = HappyWrap111 (Maybe (LocatedP CType)) -happyIn111 :: (Maybe (LocatedP CType)) -> (HappyAbsSyn ) -happyIn111 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap111 x) -{-# INLINE happyIn111 #-} -happyOut111 :: (HappyAbsSyn ) -> HappyWrap111 -happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut111 #-} -newtype HappyWrap112 = HappyWrap112 (LDerivDecl GhcPs) -happyIn112 :: (LDerivDecl GhcPs) -> (HappyAbsSyn ) -happyIn112 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap112 x) -{-# INLINE happyIn112 #-} -happyOut112 :: (HappyAbsSyn ) -> HappyWrap112 -happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut112 #-} -newtype HappyWrap113 = HappyWrap113 (LRoleAnnotDecl GhcPs) -happyIn113 :: (LRoleAnnotDecl GhcPs) -> (HappyAbsSyn ) -happyIn113 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap113 x) -{-# INLINE happyIn113 #-} -happyOut113 :: (HappyAbsSyn ) -> HappyWrap113 -happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut113 #-} -newtype HappyWrap114 = HappyWrap114 (Located [Located (Maybe FastString)]) -happyIn114 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) -happyIn114 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap114 x) -{-# INLINE happyIn114 #-} -happyOut114 :: (HappyAbsSyn ) -> HappyWrap114 -happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut114 #-} -newtype HappyWrap115 = HappyWrap115 (Located [Located (Maybe FastString)]) -happyIn115 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) -happyIn115 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap115 x) -{-# INLINE happyIn115 #-} -happyOut115 :: (HappyAbsSyn ) -> HappyWrap115 -happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut115 #-} -newtype HappyWrap116 = HappyWrap116 (Located (Maybe FastString)) -happyIn116 :: (Located (Maybe FastString)) -> (HappyAbsSyn ) -happyIn116 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap116 x) -{-# INLINE happyIn116 #-} -happyOut116 :: (HappyAbsSyn ) -> HappyWrap116 -happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut116 #-} -newtype HappyWrap117 = HappyWrap117 (LHsDecl GhcPs) -happyIn117 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn117 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap117 x) -{-# INLINE happyIn117 #-} -happyOut117 :: (HappyAbsSyn ) -> HappyWrap117 -happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut117 #-} -newtype HappyWrap118 = HappyWrap118 ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -happyIn118 :: ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -> (HappyAbsSyn ) -happyIn118 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap118 x) -{-# INLINE happyIn118 #-} -happyOut118 :: (HappyAbsSyn ) -> HappyWrap118 -happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut118 #-} -newtype HappyWrap119 = HappyWrap119 ([LocatedN RdrName]) -happyIn119 :: ([LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn119 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap119 x) -{-# INLINE happyIn119 #-} -happyOut119 :: (HappyAbsSyn ) -> HappyWrap119 -happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut119 #-} -newtype HappyWrap120 = HappyWrap120 ([RecordPatSynField GhcPs]) -happyIn120 :: ([RecordPatSynField GhcPs]) -> (HappyAbsSyn ) -happyIn120 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap120 x) -{-# INLINE happyIn120 #-} -happyOut120 :: (HappyAbsSyn ) -> HappyWrap120 -happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut120 #-} -newtype HappyWrap121 = HappyWrap121 (LocatedL (OrdList (LHsDecl GhcPs))) -happyIn121 :: (LocatedL (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn121 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap121 x) -{-# INLINE happyIn121 #-} -happyOut121 :: (HappyAbsSyn ) -> HappyWrap121 -happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut121 #-} -newtype HappyWrap122 = HappyWrap122 (LSig GhcPs) -happyIn122 :: (LSig GhcPs) -> (HappyAbsSyn ) -happyIn122 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap122 x) -{-# INLINE happyIn122 #-} -happyOut122 :: (HappyAbsSyn ) -> HappyWrap122 -happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut122 #-} -newtype HappyWrap123 = HappyWrap123 (LocatedN RdrName) -happyIn123 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn123 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap123 x) -{-# INLINE happyIn123 #-} -happyOut123 :: (HappyAbsSyn ) -> HappyWrap123 -happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut123 #-} -newtype HappyWrap124 = HappyWrap124 (LHsDecl GhcPs) -happyIn124 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn124 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap124 x) -{-# INLINE happyIn124 #-} -happyOut124 :: (HappyAbsSyn ) -> HappyWrap124 -happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut124 #-} -newtype HappyWrap125 = HappyWrap125 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -happyIn125 :: (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn125 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap125 x) -{-# INLINE happyIn125 #-} -happyOut125 :: (HappyAbsSyn ) -> HappyWrap125 -happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut125 #-} -newtype HappyWrap126 = HappyWrap126 (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs) - , LayoutInfo GhcPs)) -happyIn126 :: (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs) - , LayoutInfo GhcPs)) -> (HappyAbsSyn ) -happyIn126 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap126 x) -{-# INLINE happyIn126 #-} -happyOut126 :: (HappyAbsSyn ) -> HappyWrap126 -happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut126 #-} -newtype HappyWrap127 = HappyWrap127 (Located ([AddEpAnn] - ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo GhcPs)) -happyIn127 :: (Located ([AddEpAnn] - ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo GhcPs)) -> (HappyAbsSyn ) -happyIn127 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap127 x) -{-# INLINE happyIn127 #-} -happyOut127 :: (HappyAbsSyn ) -> HappyWrap127 -happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut127 #-} -newtype HappyWrap128 = HappyWrap128 (Located (OrdList (LHsDecl GhcPs))) -happyIn128 :: (Located (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn128 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap128 x) -{-# INLINE happyIn128 #-} -happyOut128 :: (HappyAbsSyn ) -> HappyWrap128 -happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut128 #-} -newtype HappyWrap129 = HappyWrap129 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -happyIn129 :: (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn129 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap129 x) -{-# INLINE happyIn129 #-} -happyOut129 :: (HappyAbsSyn ) -> HappyWrap129 -happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut129 #-} -newtype HappyWrap130 = HappyWrap130 (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs))) -happyIn130 :: (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn130 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap130 x) -{-# INLINE happyIn130 #-} -happyOut130 :: (HappyAbsSyn ) -> HappyWrap130 -happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut130 #-} -newtype HappyWrap131 = HappyWrap131 (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs))) -happyIn131 :: (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn131 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap131 x) -{-# INLINE happyIn131 #-} -happyOut131 :: (HappyAbsSyn ) -> HappyWrap131 -happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut131 #-} -newtype HappyWrap132 = HappyWrap132 (Located ([TrailingAnn], OrdList (LHsDecl GhcPs))) -happyIn132 :: (Located ([TrailingAnn], OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) -happyIn132 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap132 x) -{-# INLINE happyIn132 #-} -happyOut132 :: (HappyAbsSyn ) -> HappyWrap132 -happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut132 #-} -newtype HappyWrap133 = HappyWrap133 (Located (AnnList,Located (OrdList (LHsDecl GhcPs)))) -happyIn133 :: (Located (AnnList,Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) -happyIn133 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap133 x) -{-# INLINE happyIn133 #-} -happyOut133 :: (HappyAbsSyn ) -> HappyWrap133 -happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut133 #-} -newtype HappyWrap134 = HappyWrap134 (Located (HsLocalBinds GhcPs)) -happyIn134 :: (Located (HsLocalBinds GhcPs)) -> (HappyAbsSyn ) -happyIn134 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap134 x) -{-# INLINE happyIn134 #-} -happyOut134 :: (HappyAbsSyn ) -> HappyWrap134 -happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut134 #-} -newtype HappyWrap135 = HappyWrap135 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -happyIn135 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (HappyAbsSyn ) -happyIn135 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap135 x) -{-# INLINE happyIn135 #-} -happyOut135 :: (HappyAbsSyn ) -> HappyWrap135 -happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut135 #-} -newtype HappyWrap136 = HappyWrap136 ([LRuleDecl GhcPs]) -happyIn136 :: ([LRuleDecl GhcPs]) -> (HappyAbsSyn ) -happyIn136 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap136 x) -{-# INLINE happyIn136 #-} -happyOut136 :: (HappyAbsSyn ) -> HappyWrap136 -happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut136 #-} -newtype HappyWrap137 = HappyWrap137 (LRuleDecl GhcPs) -happyIn137 :: (LRuleDecl GhcPs) -> (HappyAbsSyn ) -happyIn137 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap137 x) -{-# INLINE happyIn137 #-} -happyOut137 :: (HappyAbsSyn ) -> HappyWrap137 -happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut137 #-} -newtype HappyWrap138 = HappyWrap138 (([AddEpAnn],Maybe Activation)) -happyIn138 :: (([AddEpAnn],Maybe Activation)) -> (HappyAbsSyn ) -happyIn138 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap138 x) -{-# INLINE happyIn138 #-} -happyOut138 :: (HappyAbsSyn ) -> HappyWrap138 -happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut138 #-} -newtype HappyWrap139 = HappyWrap139 ([AddEpAnn]) -happyIn139 :: ([AddEpAnn]) -> (HappyAbsSyn ) -happyIn139 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap139 x) -{-# INLINE happyIn139 #-} -happyOut139 :: (HappyAbsSyn ) -> HappyWrap139 -happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut139 #-} -newtype HappyWrap140 = HappyWrap140 (([AddEpAnn] - ,Activation)) -happyIn140 :: (([AddEpAnn] - ,Activation)) -> (HappyAbsSyn ) -happyIn140 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap140 x) -{-# INLINE happyIn140 #-} -happyOut140 :: (HappyAbsSyn ) -> HappyWrap140 -happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut140 #-} -newtype HappyWrap141 = HappyWrap141 (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs])) -happyIn141 :: (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs])) -> (HappyAbsSyn ) -happyIn141 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap141 x) -{-# INLINE happyIn141 #-} -happyOut141 :: (HappyAbsSyn ) -> HappyWrap141 -happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut141 #-} -newtype HappyWrap142 = HappyWrap142 ([LRuleTyTmVar]) -happyIn142 :: ([LRuleTyTmVar]) -> (HappyAbsSyn ) -happyIn142 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap142 x) -{-# INLINE happyIn142 #-} -happyOut142 :: (HappyAbsSyn ) -> HappyWrap142 -happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut142 #-} -newtype HappyWrap143 = HappyWrap143 (LRuleTyTmVar) -happyIn143 :: (LRuleTyTmVar) -> (HappyAbsSyn ) -happyIn143 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap143 x) -{-# INLINE happyIn143 #-} -happyOut143 :: (HappyAbsSyn ) -> HappyWrap143 -happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut143 #-} -newtype HappyWrap144 = HappyWrap144 (Maybe (Located InWarningCategory)) -happyIn144 :: (Maybe (Located InWarningCategory)) -> (HappyAbsSyn ) -happyIn144 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap144 x) -{-# INLINE happyIn144 #-} -happyOut144 :: (HappyAbsSyn ) -> HappyWrap144 -happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut144 #-} -newtype HappyWrap145 = HappyWrap145 (OrdList (LWarnDecl GhcPs)) -happyIn145 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) -happyIn145 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap145 x) -{-# INLINE happyIn145 #-} -happyOut145 :: (HappyAbsSyn ) -> HappyWrap145 -happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut145 #-} -newtype HappyWrap146 = HappyWrap146 (OrdList (LWarnDecl GhcPs)) -happyIn146 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) -happyIn146 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap146 x) -{-# INLINE happyIn146 #-} -happyOut146 :: (HappyAbsSyn ) -> HappyWrap146 -happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut146 #-} -newtype HappyWrap147 = HappyWrap147 (OrdList (LWarnDecl GhcPs)) -happyIn147 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) -happyIn147 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap147 x) -{-# INLINE happyIn147 #-} -happyOut147 :: (HappyAbsSyn ) -> HappyWrap147 -happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut147 #-} -newtype HappyWrap148 = HappyWrap148 (OrdList (LWarnDecl GhcPs)) -happyIn148 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) -happyIn148 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap148 x) -{-# INLINE happyIn148 #-} -happyOut148 :: (HappyAbsSyn ) -> HappyWrap148 -happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut148 #-} -newtype HappyWrap149 = HappyWrap149 (Located ([AddEpAnn],[Located StringLiteral])) -happyIn149 :: (Located ([AddEpAnn],[Located StringLiteral])) -> (HappyAbsSyn ) -happyIn149 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap149 x) -{-# INLINE happyIn149 #-} -happyOut149 :: (HappyAbsSyn ) -> HappyWrap149 -happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut149 #-} -newtype HappyWrap150 = HappyWrap150 (Located (OrdList (Located StringLiteral))) -happyIn150 :: (Located (OrdList (Located StringLiteral))) -> (HappyAbsSyn ) -happyIn150 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap150 x) -{-# INLINE happyIn150 #-} -happyOut150 :: (HappyAbsSyn ) -> HappyWrap150 -happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut150 #-} -newtype HappyWrap151 = HappyWrap151 (LHsDecl GhcPs) -happyIn151 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn151 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap151 x) -{-# INLINE happyIn151 #-} -happyOut151 :: (HappyAbsSyn ) -> HappyWrap151 -happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut151 #-} -newtype HappyWrap152 = HappyWrap152 (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs)) -happyIn152 :: (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs)) -> (HappyAbsSyn ) -happyIn152 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap152 x) -{-# INLINE happyIn152 #-} -happyOut152 :: (HappyAbsSyn ) -> HappyWrap152 -happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut152 #-} -newtype HappyWrap153 = HappyWrap153 (Located CCallConv) -happyIn153 :: (Located CCallConv) -> (HappyAbsSyn ) -happyIn153 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap153 x) -{-# INLINE happyIn153 #-} -happyOut153 :: (HappyAbsSyn ) -> HappyWrap153 -happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut153 #-} -newtype HappyWrap154 = HappyWrap154 (Located Safety) -happyIn154 :: (Located Safety) -> (HappyAbsSyn ) -happyIn154 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap154 x) -{-# INLINE happyIn154 #-} -happyOut154 :: (HappyAbsSyn ) -> HappyWrap154 -happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut154 #-} -newtype HappyWrap155 = HappyWrap155 (Located ([AddEpAnn] - ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -happyIn155 :: (Located ([AddEpAnn] - ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -> (HappyAbsSyn ) -happyIn155 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap155 x) -{-# INLINE happyIn155 #-} -happyOut155 :: (HappyAbsSyn ) -> HappyWrap155 -happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut155 #-} -newtype HappyWrap156 = HappyWrap156 (Maybe (AddEpAnn, LHsType GhcPs)) -happyIn156 :: (Maybe (AddEpAnn, LHsType GhcPs)) -> (HappyAbsSyn ) -happyIn156 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap156 x) -{-# INLINE happyIn156 #-} -happyOut156 :: (HappyAbsSyn ) -> HappyWrap156 -happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut156 #-} -newtype HappyWrap157 = HappyWrap157 (([AddEpAnn], Maybe (LocatedN RdrName))) -happyIn157 :: (([AddEpAnn], Maybe (LocatedN RdrName))) -> (HappyAbsSyn ) -happyIn157 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap157 x) -{-# INLINE happyIn157 #-} -happyOut157 :: (HappyAbsSyn ) -> HappyWrap157 -happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut157 #-} -newtype HappyWrap158 = HappyWrap158 (LHsSigType GhcPs) -happyIn158 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) -happyIn158 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap158 x) -{-# INLINE happyIn158 #-} -happyOut158 :: (HappyAbsSyn ) -> HappyWrap158 -happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut158 #-} -newtype HappyWrap159 = HappyWrap159 (LHsSigType GhcPs) -happyIn159 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) -happyIn159 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap159 x) -{-# INLINE happyIn159 #-} -happyOut159 :: (HappyAbsSyn ) -> HappyWrap159 -happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut159 #-} -newtype HappyWrap160 = HappyWrap160 (Located [LocatedN RdrName]) -happyIn160 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn160 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap160 x) -{-# INLINE happyIn160 #-} -happyOut160 :: (HappyAbsSyn ) -> HappyWrap160 -happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut160 #-} -newtype HappyWrap161 = HappyWrap161 (OrdList (LHsSigType GhcPs)) -happyIn161 :: (OrdList (LHsSigType GhcPs)) -> (HappyAbsSyn ) -happyIn161 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap161 x) -{-# INLINE happyIn161 #-} -happyOut161 :: (HappyAbsSyn ) -> HappyWrap161 -happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut161 #-} -newtype HappyWrap162 = HappyWrap162 (Located UnpackednessPragma) -happyIn162 :: (Located UnpackednessPragma) -> (HappyAbsSyn ) -happyIn162 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap162 x) -{-# INLINE happyIn162 #-} -happyOut162 :: (HappyAbsSyn ) -> HappyWrap162 -happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut162 #-} -newtype HappyWrap163 = HappyWrap163 (Located (HsForAllTelescope GhcPs)) -happyIn163 :: (Located (HsForAllTelescope GhcPs)) -> (HappyAbsSyn ) -happyIn163 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap163 x) -{-# INLINE happyIn163 #-} -happyOut163 :: (HappyAbsSyn ) -> HappyWrap163 -happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut163 #-} -newtype HappyWrap164 = HappyWrap164 (LHsType GhcPs) -happyIn164 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn164 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap164 x) -{-# INLINE happyIn164 #-} -happyOut164 :: (HappyAbsSyn ) -> HappyWrap164 -happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut164 #-} -newtype HappyWrap165 = HappyWrap165 (LHsType GhcPs) -happyIn165 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn165 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap165 x) -{-# INLINE happyIn165 #-} -happyOut165 :: (HappyAbsSyn ) -> HappyWrap165 -happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut165 #-} -newtype HappyWrap166 = HappyWrap166 (LHsContext GhcPs) -happyIn166 :: (LHsContext GhcPs) -> (HappyAbsSyn ) -happyIn166 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap166 x) -{-# INLINE happyIn166 #-} -happyOut166 :: (HappyAbsSyn ) -> HappyWrap166 -happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut166 #-} -newtype HappyWrap167 = HappyWrap167 (LHsType GhcPs) -happyIn167 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn167 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap167 x) -{-# INLINE happyIn167 #-} -happyOut167 :: (HappyAbsSyn ) -> HappyWrap167 -happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut167 #-} -newtype HappyWrap168 = HappyWrap168 (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs)) -happyIn168 :: (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs)) -> (HappyAbsSyn ) -happyIn168 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap168 x) -{-# INLINE happyIn168 #-} -happyOut168 :: (HappyAbsSyn ) -> HappyWrap168 -happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut168 #-} -newtype HappyWrap169 = HappyWrap169 (LHsType GhcPs) -happyIn169 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn169 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap169 x) -{-# INLINE happyIn169 #-} -happyOut169 :: (HappyAbsSyn ) -> HappyWrap169 -happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut169 #-} -newtype HappyWrap170 = HappyWrap170 (forall b. DisambTD b => PV (LocatedA b)) -happyIn170 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn ) -happyIn170 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap170 x) -{-# INLINE happyIn170 #-} -happyOut170 :: (HappyAbsSyn ) -> HappyWrap170 -happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut170 #-} -newtype HappyWrap171 = HappyWrap171 (forall b. DisambTD b => PV (LocatedA b)) -happyIn171 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn ) -happyIn171 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap171 x) -{-# INLINE happyIn171 #-} -happyOut171 :: (HappyAbsSyn ) -> HappyWrap171 -happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut171 #-} -newtype HappyWrap172 = HappyWrap172 (LHsType GhcPs) -happyIn172 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn172 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap172 x) -{-# INLINE happyIn172 #-} -happyOut172 :: (HappyAbsSyn ) -> HappyWrap172 -happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut172 #-} -newtype HappyWrap173 = HappyWrap173 ((LocatedN RdrName, PromotionFlag)) -happyIn173 :: ((LocatedN RdrName, PromotionFlag)) -> (HappyAbsSyn ) -happyIn173 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap173 x) -{-# INLINE happyIn173 #-} -happyOut173 :: (HappyAbsSyn ) -> HappyWrap173 -happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut173 #-} -newtype HappyWrap174 = HappyWrap174 (LHsType GhcPs) -happyIn174 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn174 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap174 x) -{-# INLINE happyIn174 #-} -happyOut174 :: (HappyAbsSyn ) -> HappyWrap174 -happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut174 #-} -newtype HappyWrap175 = HappyWrap175 (LHsSigType GhcPs) -happyIn175 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) -happyIn175 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap175 x) -{-# INLINE happyIn175 #-} -happyOut175 :: (HappyAbsSyn ) -> HappyWrap175 -happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut175 #-} -newtype HappyWrap176 = HappyWrap176 ([LHsSigType GhcPs]) -happyIn176 :: ([LHsSigType GhcPs]) -> (HappyAbsSyn ) -happyIn176 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap176 x) -{-# INLINE happyIn176 #-} -happyOut176 :: (HappyAbsSyn ) -> HappyWrap176 -happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut176 #-} -newtype HappyWrap177 = HappyWrap177 ([LHsType GhcPs]) -happyIn177 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) -happyIn177 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap177 x) -{-# INLINE happyIn177 #-} -happyOut177 :: (HappyAbsSyn ) -> HappyWrap177 -happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut177 #-} -newtype HappyWrap178 = HappyWrap178 ([LHsType GhcPs]) -happyIn178 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) -happyIn178 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap178 x) -{-# INLINE happyIn178 #-} -happyOut178 :: (HappyAbsSyn ) -> HappyWrap178 -happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut178 #-} -newtype HappyWrap179 = HappyWrap179 ([LHsType GhcPs]) -happyIn179 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) -happyIn179 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap179 x) -{-# INLINE happyIn179 #-} -happyOut179 :: (HappyAbsSyn ) -> HappyWrap179 -happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut179 #-} -newtype HappyWrap180 = HappyWrap180 ([LHsTyVarBndr Specificity GhcPs]) -happyIn180 :: ([LHsTyVarBndr Specificity GhcPs]) -> (HappyAbsSyn ) -happyIn180 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap180 x) -{-# INLINE happyIn180 #-} -happyOut180 :: (HappyAbsSyn ) -> HappyWrap180 -happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut180 #-} -newtype HappyWrap181 = HappyWrap181 (LHsTyVarBndr Specificity GhcPs) -happyIn181 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn ) -happyIn181 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap181 x) -{-# INLINE happyIn181 #-} -happyOut181 :: (HappyAbsSyn ) -> HappyWrap181 -happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut181 #-} -newtype HappyWrap182 = HappyWrap182 (LHsTyVarBndr Specificity GhcPs) -happyIn182 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn ) -happyIn182 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap182 x) -{-# INLINE happyIn182 #-} -happyOut182 :: (HappyAbsSyn ) -> HappyWrap182 -happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut182 #-} -newtype HappyWrap183 = HappyWrap183 (Located ([AddEpAnn],[LHsFunDep GhcPs])) -happyIn183 :: (Located ([AddEpAnn],[LHsFunDep GhcPs])) -> (HappyAbsSyn ) -happyIn183 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap183 x) -{-# INLINE happyIn183 #-} -happyOut183 :: (HappyAbsSyn ) -> HappyWrap183 -happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut183 #-} -newtype HappyWrap184 = HappyWrap184 (Located [LHsFunDep GhcPs]) -happyIn184 :: (Located [LHsFunDep GhcPs]) -> (HappyAbsSyn ) -happyIn184 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap184 x) -{-# INLINE happyIn184 #-} -happyOut184 :: (HappyAbsSyn ) -> HappyWrap184 -happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut184 #-} -newtype HappyWrap185 = HappyWrap185 (LHsFunDep GhcPs) -happyIn185 :: (LHsFunDep GhcPs) -> (HappyAbsSyn ) -happyIn185 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap185 x) -{-# INLINE happyIn185 #-} -happyOut185 :: (HappyAbsSyn ) -> HappyWrap185 -happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut185 #-} -newtype HappyWrap186 = HappyWrap186 (Located [LocatedN RdrName]) -happyIn186 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn186 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap186 x) -{-# INLINE happyIn186 #-} -happyOut186 :: (HappyAbsSyn ) -> HappyWrap186 -happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut186 #-} -newtype HappyWrap187 = HappyWrap187 (LHsKind GhcPs) -happyIn187 :: (LHsKind GhcPs) -> (HappyAbsSyn ) -happyIn187 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap187 x) -{-# INLINE happyIn187 #-} -happyOut187 :: (HappyAbsSyn ) -> HappyWrap187 -happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut187 #-} -newtype HappyWrap188 = HappyWrap188 (Located ([AddEpAnn] - ,[LConDecl GhcPs])) -happyIn188 :: (Located ([AddEpAnn] - ,[LConDecl GhcPs])) -> (HappyAbsSyn ) -happyIn188 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap188 x) -{-# INLINE happyIn188 #-} -happyOut188 :: (HappyAbsSyn ) -> HappyWrap188 -happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut188 #-} -newtype HappyWrap189 = HappyWrap189 (Located [LConDecl GhcPs]) -happyIn189 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) -happyIn189 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap189 x) -{-# INLINE happyIn189 #-} -happyOut189 :: (HappyAbsSyn ) -> HappyWrap189 -happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut189 #-} -newtype HappyWrap190 = HappyWrap190 (LConDecl GhcPs) -happyIn190 :: (LConDecl GhcPs) -> (HappyAbsSyn ) -happyIn190 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap190 x) -{-# INLINE happyIn190 #-} -happyOut190 :: (HappyAbsSyn ) -> HappyWrap190 -happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut190 #-} -newtype HappyWrap191 = HappyWrap191 (Located ([AddEpAnn],[LConDecl GhcPs])) -happyIn191 :: (Located ([AddEpAnn],[LConDecl GhcPs])) -> (HappyAbsSyn ) -happyIn191 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap191 x) -{-# INLINE happyIn191 #-} -happyOut191 :: (HappyAbsSyn ) -> HappyWrap191 -happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut191 #-} -newtype HappyWrap192 = HappyWrap192 (Located [LConDecl GhcPs]) -happyIn192 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) -happyIn192 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap192 x) -{-# INLINE happyIn192 #-} -happyOut192 :: (HappyAbsSyn ) -> HappyWrap192 -happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut192 #-} -newtype HappyWrap193 = HappyWrap193 (LConDecl GhcPs) -happyIn193 :: (LConDecl GhcPs) -> (HappyAbsSyn ) -happyIn193 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap193 x) -{-# INLINE happyIn193 #-} -happyOut193 :: (HappyAbsSyn ) -> HappyWrap193 -happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut193 #-} -newtype HappyWrap194 = HappyWrap194 (Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs])) -happyIn194 :: (Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs])) -> (HappyAbsSyn ) -happyIn194 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap194 x) -{-# INLINE happyIn194 #-} -happyOut194 :: (HappyAbsSyn ) -> HappyWrap194 -happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut194 #-} -newtype HappyWrap195 = HappyWrap195 (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) -happyIn195 :: (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) -> (HappyAbsSyn ) -happyIn195 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap195 x) -{-# INLINE happyIn195 #-} -happyOut195 :: (HappyAbsSyn ) -> HappyWrap195 -happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut195 #-} -newtype HappyWrap196 = HappyWrap196 ([LConDeclField GhcPs]) -happyIn196 :: ([LConDeclField GhcPs]) -> (HappyAbsSyn ) -happyIn196 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap196 x) -{-# INLINE happyIn196 #-} -happyOut196 :: (HappyAbsSyn ) -> HappyWrap196 -happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut196 #-} -newtype HappyWrap197 = HappyWrap197 ([LConDeclField GhcPs]) -happyIn197 :: ([LConDeclField GhcPs]) -> (HappyAbsSyn ) -happyIn197 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap197 x) -{-# INLINE happyIn197 #-} -happyOut197 :: (HappyAbsSyn ) -> HappyWrap197 -happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut197 #-} -newtype HappyWrap198 = HappyWrap198 (LConDeclField GhcPs) -happyIn198 :: (LConDeclField GhcPs) -> (HappyAbsSyn ) -happyIn198 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap198 x) -{-# INLINE happyIn198 #-} -happyOut198 :: (HappyAbsSyn ) -> HappyWrap198 -happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut198 #-} -newtype HappyWrap199 = HappyWrap199 (Located (HsDeriving GhcPs)) -happyIn199 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn ) -happyIn199 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap199 x) -{-# INLINE happyIn199 #-} -happyOut199 :: (HappyAbsSyn ) -> HappyWrap199 -happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut199 #-} -newtype HappyWrap200 = HappyWrap200 (Located (HsDeriving GhcPs)) -happyIn200 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn ) -happyIn200 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap200 x) -{-# INLINE happyIn200 #-} -happyOut200 :: (HappyAbsSyn ) -> HappyWrap200 -happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut200 #-} -newtype HappyWrap201 = HappyWrap201 (LHsDerivingClause GhcPs) -happyIn201 :: (LHsDerivingClause GhcPs) -> (HappyAbsSyn ) -happyIn201 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap201 x) -{-# INLINE happyIn201 #-} -happyOut201 :: (HappyAbsSyn ) -> HappyWrap201 -happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut201 #-} -newtype HappyWrap202 = HappyWrap202 (LDerivClauseTys GhcPs) -happyIn202 :: (LDerivClauseTys GhcPs) -> (HappyAbsSyn ) -happyIn202 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap202 x) -{-# INLINE happyIn202 #-} -happyOut202 :: (HappyAbsSyn ) -> HappyWrap202 -happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut202 #-} -newtype HappyWrap203 = HappyWrap203 (LHsDecl GhcPs) -happyIn203 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn203 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap203 x) -{-# INLINE happyIn203 #-} -happyOut203 :: (HappyAbsSyn ) -> HappyWrap203 -happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut203 #-} -newtype HappyWrap204 = HappyWrap204 (LHsDecl GhcPs) -happyIn204 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn204 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap204 x) -{-# INLINE happyIn204 #-} -happyOut204 :: (HappyAbsSyn ) -> HappyWrap204 -happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut204 #-} -newtype HappyWrap205 = HappyWrap205 (Located (GRHSs GhcPs (LHsExpr GhcPs))) -happyIn205 :: (Located (GRHSs GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) -happyIn205 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap205 x) -{-# INLINE happyIn205 #-} -happyOut205 :: (HappyAbsSyn ) -> HappyWrap205 -happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut205 #-} -newtype HappyWrap206 = HappyWrap206 (Located [LGRHS GhcPs (LHsExpr GhcPs)]) -happyIn206 :: (Located [LGRHS GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) -happyIn206 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap206 x) -{-# INLINE happyIn206 #-} -happyOut206 :: (HappyAbsSyn ) -> HappyWrap206 -happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut206 #-} -newtype HappyWrap207 = HappyWrap207 (LGRHS GhcPs (LHsExpr GhcPs)) -happyIn207 :: (LGRHS GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) -happyIn207 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap207 x) -{-# INLINE happyIn207 #-} -happyOut207 :: (HappyAbsSyn ) -> HappyWrap207 -happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut207 #-} -newtype HappyWrap208 = HappyWrap208 (LHsDecl GhcPs) -happyIn208 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn208 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap208 x) -{-# INLINE happyIn208 #-} -happyOut208 :: (HappyAbsSyn ) -> HappyWrap208 -happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut208 #-} -newtype HappyWrap209 = HappyWrap209 (([AddEpAnn],Maybe Activation)) -happyIn209 :: (([AddEpAnn],Maybe Activation)) -> (HappyAbsSyn ) -happyIn209 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap209 x) -{-# INLINE happyIn209 #-} -happyOut209 :: (HappyAbsSyn ) -> HappyWrap209 -happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut209 #-} -newtype HappyWrap210 = HappyWrap210 (([AddEpAnn],Activation)) -happyIn210 :: (([AddEpAnn],Activation)) -> (HappyAbsSyn ) -happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x) -{-# INLINE happyIn210 #-} -happyOut210 :: (HappyAbsSyn ) -> HappyWrap210 -happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut210 #-} -newtype HappyWrap211 = HappyWrap211 (Located (HsUntypedSplice GhcPs)) -happyIn211 :: (Located (HsUntypedSplice GhcPs)) -> (HappyAbsSyn ) -happyIn211 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap211 x) -{-# INLINE happyIn211 #-} -happyOut211 :: (HappyAbsSyn ) -> HappyWrap211 -happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut211 #-} -newtype HappyWrap212 = HappyWrap212 (ECP) -happyIn212 :: (ECP) -> (HappyAbsSyn ) -happyIn212 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap212 x) -{-# INLINE happyIn212 #-} -happyOut212 :: (HappyAbsSyn ) -> HappyWrap212 -happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut212 #-} -newtype HappyWrap213 = HappyWrap213 (ECP) -happyIn213 :: (ECP) -> (HappyAbsSyn ) -happyIn213 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap213 x) -{-# INLINE happyIn213 #-} -happyOut213 :: (HappyAbsSyn ) -> HappyWrap213 -happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut213 #-} -newtype HappyWrap214 = HappyWrap214 (ECP) -happyIn214 :: (ECP) -> (HappyAbsSyn ) -happyIn214 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap214 x) -{-# INLINE happyIn214 #-} -happyOut214 :: (HappyAbsSyn ) -> HappyWrap214 -happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut214 #-} -newtype HappyWrap215 = HappyWrap215 (ECP) -happyIn215 :: (ECP) -> (HappyAbsSyn ) -happyIn215 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap215 x) -{-# INLINE happyIn215 #-} -happyOut215 :: (HappyAbsSyn ) -> HappyWrap215 -happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut215 #-} -newtype HappyWrap216 = HappyWrap216 ((Maybe EpaLocation,Bool)) -happyIn216 :: ((Maybe EpaLocation,Bool)) -> (HappyAbsSyn ) -happyIn216 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap216 x) -{-# INLINE happyIn216 #-} -happyOut216 :: (HappyAbsSyn ) -> HappyWrap216 -happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut216 #-} -newtype HappyWrap217 = HappyWrap217 (Located (HsPragE GhcPs)) -happyIn217 :: (Located (HsPragE GhcPs)) -> (HappyAbsSyn ) -happyIn217 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap217 x) -{-# INLINE happyIn217 #-} -happyOut217 :: (HappyAbsSyn ) -> HappyWrap217 -happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut217 #-} -newtype HappyWrap218 = HappyWrap218 (ECP) -happyIn218 :: (ECP) -> (HappyAbsSyn ) -happyIn218 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap218 x) -{-# INLINE happyIn218 #-} -happyOut218 :: (HappyAbsSyn ) -> HappyWrap218 -happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut218 #-} -newtype HappyWrap219 = HappyWrap219 (ECP) -happyIn219 :: (ECP) -> (HappyAbsSyn ) -happyIn219 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap219 x) -{-# INLINE happyIn219 #-} -happyOut219 :: (HappyAbsSyn ) -> HappyWrap219 -happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut219 #-} -newtype HappyWrap220 = HappyWrap220 (ECP) -happyIn220 :: (ECP) -> (HappyAbsSyn ) -happyIn220 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap220 x) -{-# INLINE happyIn220 #-} -happyOut220 :: (HappyAbsSyn ) -> HappyWrap220 -happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut220 #-} -newtype HappyWrap221 = HappyWrap221 (ECP) -happyIn221 :: (ECP) -> (HappyAbsSyn ) -happyIn221 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap221 x) -{-# INLINE happyIn221 #-} -happyOut221 :: (HappyAbsSyn ) -> HappyWrap221 -happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut221 #-} -newtype HappyWrap222 = HappyWrap222 (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -happyIn222 :: (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -> (HappyAbsSyn ) -happyIn222 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap222 x) -{-# INLINE happyIn222 #-} -happyOut222 :: (HappyAbsSyn ) -> HappyWrap222 -happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut222 #-} -newtype HappyWrap223 = HappyWrap223 (LHsExpr GhcPs) -happyIn223 :: (LHsExpr GhcPs) -> (HappyAbsSyn ) -happyIn223 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap223 x) -{-# INLINE happyIn223 #-} -happyOut223 :: (HappyAbsSyn ) -> HappyWrap223 -happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut223 #-} -newtype HappyWrap224 = HappyWrap224 (Located (HsUntypedSplice GhcPs)) -happyIn224 :: (Located (HsUntypedSplice GhcPs)) -> (HappyAbsSyn ) -happyIn224 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap224 x) -{-# INLINE happyIn224 #-} -happyOut224 :: (HappyAbsSyn ) -> HappyWrap224 -happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut224 #-} -newtype HappyWrap225 = HappyWrap225 (Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs)) -happyIn225 :: (Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs)) -> (HappyAbsSyn ) -happyIn225 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap225 x) -{-# INLINE happyIn225 #-} -happyOut225 :: (HappyAbsSyn ) -> HappyWrap225 -happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut225 #-} -newtype HappyWrap226 = HappyWrap226 ([LHsCmdTop GhcPs]) -happyIn226 :: ([LHsCmdTop GhcPs]) -> (HappyAbsSyn ) -happyIn226 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap226 x) -{-# INLINE happyIn226 #-} -happyOut226 :: (HappyAbsSyn ) -> HappyWrap226 -happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut226 #-} -newtype HappyWrap227 = HappyWrap227 (LHsCmdTop GhcPs) -happyIn227 :: (LHsCmdTop GhcPs) -> (HappyAbsSyn ) -happyIn227 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap227 x) -{-# INLINE happyIn227 #-} -happyOut227 :: (HappyAbsSyn ) -> HappyWrap227 -happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut227 #-} -newtype HappyWrap228 = HappyWrap228 (([AddEpAnn],[LHsDecl GhcPs])) -happyIn228 :: (([AddEpAnn],[LHsDecl GhcPs])) -> (HappyAbsSyn ) -happyIn228 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap228 x) -{-# INLINE happyIn228 #-} -happyOut228 :: (HappyAbsSyn ) -> HappyWrap228 -happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut228 #-} -newtype HappyWrap229 = HappyWrap229 ([LHsDecl GhcPs]) -happyIn229 :: ([LHsDecl GhcPs]) -> (HappyAbsSyn ) -happyIn229 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap229 x) -{-# INLINE happyIn229 #-} -happyOut229 :: (HappyAbsSyn ) -> HappyWrap229 -happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut229 #-} -newtype HappyWrap230 = HappyWrap230 (ECP) -happyIn230 :: (ECP) -> (HappyAbsSyn ) -happyIn230 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap230 x) -{-# INLINE happyIn230 #-} -happyOut230 :: (HappyAbsSyn ) -> HappyWrap230 -happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut230 #-} -newtype HappyWrap231 = HappyWrap231 (forall b. DisambECP b => PV (SumOrTuple b)) -happyIn231 :: (forall b. DisambECP b => PV (SumOrTuple b)) -> (HappyAbsSyn ) -happyIn231 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap231 x) -{-# INLINE happyIn231 #-} -happyOut231 :: (HappyAbsSyn ) -> HappyWrap231 -happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut231 #-} -newtype HappyWrap232 = HappyWrap232 (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)])) -happyIn232 :: (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)])) -> (HappyAbsSyn ) -happyIn232 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap232 x) -{-# INLINE happyIn232 #-} -happyOut232 :: (HappyAbsSyn ) -> HappyWrap232 -happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut232 #-} -newtype HappyWrap233 = HappyWrap233 (forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)]) -happyIn233 :: (forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)]) -> (HappyAbsSyn ) -happyIn233 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap233 x) -{-# INLINE happyIn233 #-} -happyOut233 :: (HappyAbsSyn ) -> HappyWrap233 -happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut233 #-} -newtype HappyWrap234 = HappyWrap234 (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b)) -happyIn234 :: (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b)) -> (HappyAbsSyn ) -happyIn234 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap234 x) -{-# INLINE happyIn234 #-} -happyOut234 :: (HappyAbsSyn ) -> HappyWrap234 -happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut234 #-} -newtype HappyWrap235 = HappyWrap235 (forall b. DisambECP b => PV [LocatedA b]) -happyIn235 :: (forall b. DisambECP b => PV [LocatedA b]) -> (HappyAbsSyn ) -happyIn235 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap235 x) -{-# INLINE happyIn235 #-} -happyOut235 :: (HappyAbsSyn ) -> HappyWrap235 -happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut235 #-} -newtype HappyWrap236 = HappyWrap236 (Located [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn236 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) -happyIn236 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap236 x) -{-# INLINE happyIn236 #-} -happyOut236 :: (HappyAbsSyn ) -> HappyWrap236 -happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut236 #-} -newtype HappyWrap237 = HappyWrap237 (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) -happyIn237 :: (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) -> (HappyAbsSyn ) -happyIn237 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap237 x) -{-# INLINE happyIn237 #-} -happyOut237 :: (HappyAbsSyn ) -> HappyWrap237 -happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut237 #-} -newtype HappyWrap238 = HappyWrap238 (Located [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn238 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) -happyIn238 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap238 x) -{-# INLINE happyIn238 #-} -happyOut238 :: (HappyAbsSyn ) -> HappyWrap238 -happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut238 #-} -newtype HappyWrap239 = HappyWrap239 (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -happyIn239 :: (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) -happyIn239 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap239 x) -{-# INLINE happyIn239 #-} -happyOut239 :: (HappyAbsSyn ) -> HappyWrap239 -happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut239 #-} -newtype HappyWrap240 = HappyWrap240 (Located [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn240 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) -happyIn240 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap240 x) -{-# INLINE happyIn240 #-} -happyOut240 :: (HappyAbsSyn ) -> HappyWrap240 -happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut240 #-} -newtype HappyWrap241 = HappyWrap241 (Located [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn241 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) -happyIn241 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap241 x) -{-# INLINE happyIn241 #-} -happyOut241 :: (HappyAbsSyn ) -> HappyWrap241 -happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut241 #-} -newtype HappyWrap242 = HappyWrap242 (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -happyIn242 :: (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -> (HappyAbsSyn ) -happyIn242 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap242 x) -{-# INLINE happyIn242 #-} -happyOut242 :: (HappyAbsSyn ) -> HappyWrap242 -happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut242 #-} -newtype HappyWrap243 = HappyWrap243 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -happyIn243 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -> (HappyAbsSyn ) -happyIn243 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap243 x) -{-# INLINE happyIn243 #-} -happyOut243 :: (HappyAbsSyn ) -> HappyWrap243 -happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut243 #-} -newtype HappyWrap244 = HappyWrap244 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -happyIn244 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -> (HappyAbsSyn ) -happyIn244 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap244 x) -{-# INLINE happyIn244 #-} -happyOut244 :: (HappyAbsSyn ) -> HappyWrap244 -happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut244 #-} -newtype HappyWrap245 = HappyWrap245 (Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -happyIn245 :: (Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -> (HappyAbsSyn ) -happyIn245 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap245 x) -{-# INLINE happyIn245 #-} -happyOut245 :: (HappyAbsSyn ) -> HappyWrap245 -happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut245 #-} -newtype HappyWrap246 = HappyWrap246 (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -happyIn246 :: (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -> (HappyAbsSyn ) -happyIn246 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap246 x) -{-# INLINE happyIn246 #-} -happyOut246 :: (HappyAbsSyn ) -> HappyWrap246 -happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut246 #-} -newtype HappyWrap247 = HappyWrap247 (LPat GhcPs) -happyIn247 :: (LPat GhcPs) -> (HappyAbsSyn ) -happyIn247 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap247 x) -{-# INLINE happyIn247 #-} -happyOut247 :: (HappyAbsSyn ) -> HappyWrap247 -happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut247 #-} -newtype HappyWrap248 = HappyWrap248 ([LPat GhcPs]) -happyIn248 :: ([LPat GhcPs]) -> (HappyAbsSyn ) -happyIn248 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap248 x) -{-# INLINE happyIn248 #-} -happyOut248 :: (HappyAbsSyn ) -> HappyWrap248 -happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut248 #-} -newtype HappyWrap249 = HappyWrap249 (LPat GhcPs) -happyIn249 :: (LPat GhcPs) -> (HappyAbsSyn ) -happyIn249 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap249 x) -{-# INLINE happyIn249 #-} -happyOut249 :: (HappyAbsSyn ) -> HappyWrap249 -happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut249 #-} -newtype HappyWrap250 = HappyWrap250 (LPat GhcPs) -happyIn250 :: (LPat GhcPs) -> (HappyAbsSyn ) -happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x) -{-# INLINE happyIn250 #-} -happyOut250 :: (HappyAbsSyn ) -> HappyWrap250 -happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut250 #-} -newtype HappyWrap251 = HappyWrap251 ([LPat GhcPs]) -happyIn251 :: ([LPat GhcPs]) -> (HappyAbsSyn ) -happyIn251 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap251 x) -{-# INLINE happyIn251 #-} -happyOut251 :: (HappyAbsSyn ) -> HappyWrap251 -happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut251 #-} -newtype HappyWrap252 = HappyWrap252 (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -happyIn252 :: (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -> (HappyAbsSyn ) -happyIn252 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap252 x) -{-# INLINE happyIn252 #-} -happyOut252 :: (HappyAbsSyn ) -> HappyWrap252 -happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut252 #-} -newtype HappyWrap253 = HappyWrap253 (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -happyIn253 :: (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) -happyIn253 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap253 x) -{-# INLINE happyIn253 #-} -happyOut253 :: (HappyAbsSyn ) -> HappyWrap253 -happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut253 #-} -newtype HappyWrap254 = HappyWrap254 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -happyIn254 :: (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) -happyIn254 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap254 x) -{-# INLINE happyIn254 #-} -happyOut254 :: (HappyAbsSyn ) -> HappyWrap254 -happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut254 #-} -newtype HappyWrap255 = HappyWrap255 (LStmt GhcPs (LHsExpr GhcPs)) -happyIn255 :: (LStmt GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) -happyIn255 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap255 x) -{-# INLINE happyIn255 #-} -happyOut255 :: (HappyAbsSyn ) -> HappyWrap255 -happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut255 #-} -newtype HappyWrap256 = HappyWrap256 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -happyIn256 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn ) -happyIn256 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap256 x) -{-# INLINE happyIn256 #-} -happyOut256 :: (HappyAbsSyn ) -> HappyWrap256 -happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut256 #-} -newtype HappyWrap257 = HappyWrap257 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -happyIn257 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn ) -happyIn257 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap257 x) -{-# INLINE happyIn257 #-} -happyOut257 :: (HappyAbsSyn ) -> HappyWrap257 -happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut257 #-} -newtype HappyWrap258 = HappyWrap258 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -happyIn258 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn ) -happyIn258 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap258 x) -{-# INLINE happyIn258 #-} -happyOut258 :: (HappyAbsSyn ) -> HappyWrap258 -happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut258 #-} -newtype HappyWrap259 = HappyWrap259 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -happyIn259 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn ) -happyIn259 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap259 x) -{-# INLINE happyIn259 #-} -happyOut259 :: (HappyAbsSyn ) -> HappyWrap259 -happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut259 #-} -newtype HappyWrap260 = HappyWrap260 (forall b. DisambECP b => PV (Fbind b)) -happyIn260 :: (forall b. DisambECP b => PV (Fbind b)) -> (HappyAbsSyn ) -happyIn260 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap260 x) -{-# INLINE happyIn260 #-} -happyOut260 :: (HappyAbsSyn ) -> HappyWrap260 -happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut260 #-} -newtype HappyWrap261 = HappyWrap261 (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -happyIn261 :: (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -> (HappyAbsSyn ) -happyIn261 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap261 x) -{-# INLINE happyIn261 #-} -happyOut261 :: (HappyAbsSyn ) -> HappyWrap261 -happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut261 #-} -newtype HappyWrap262 = HappyWrap262 (Located [LIPBind GhcPs]) -happyIn262 :: (Located [LIPBind GhcPs]) -> (HappyAbsSyn ) -happyIn262 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap262 x) -{-# INLINE happyIn262 #-} -happyOut262 :: (HappyAbsSyn ) -> HappyWrap262 -happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut262 #-} -newtype HappyWrap263 = HappyWrap263 (LIPBind GhcPs) -happyIn263 :: (LIPBind GhcPs) -> (HappyAbsSyn ) -happyIn263 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap263 x) -{-# INLINE happyIn263 #-} -happyOut263 :: (HappyAbsSyn ) -> HappyWrap263 -happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut263 #-} -newtype HappyWrap264 = HappyWrap264 (Located HsIPName) -happyIn264 :: (Located HsIPName) -> (HappyAbsSyn ) -happyIn264 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap264 x) -{-# INLINE happyIn264 #-} -happyOut264 :: (HappyAbsSyn ) -> HappyWrap264 -happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut264 #-} -newtype HappyWrap265 = HappyWrap265 (Located (SourceText, FastString)) -happyIn265 :: (Located (SourceText, FastString)) -> (HappyAbsSyn ) -happyIn265 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap265 x) -{-# INLINE happyIn265 #-} -happyOut265 :: (HappyAbsSyn ) -> HappyWrap265 -happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut265 #-} -newtype HappyWrap266 = HappyWrap266 (LBooleanFormula (LocatedN RdrName)) -happyIn266 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn ) -happyIn266 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap266 x) -{-# INLINE happyIn266 #-} -happyOut266 :: (HappyAbsSyn ) -> HappyWrap266 -happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut266 #-} -newtype HappyWrap267 = HappyWrap267 (LBooleanFormula (LocatedN RdrName)) -happyIn267 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn ) -happyIn267 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap267 x) -{-# INLINE happyIn267 #-} -happyOut267 :: (HappyAbsSyn ) -> HappyWrap267 -happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut267 #-} -newtype HappyWrap268 = HappyWrap268 (LBooleanFormula (LocatedN RdrName)) -happyIn268 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn ) -happyIn268 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap268 x) -{-# INLINE happyIn268 #-} -happyOut268 :: (HappyAbsSyn ) -> HappyWrap268 -happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut268 #-} -newtype HappyWrap269 = HappyWrap269 ([LBooleanFormula (LocatedN RdrName)]) -happyIn269 :: ([LBooleanFormula (LocatedN RdrName)]) -> (HappyAbsSyn ) -happyIn269 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap269 x) -{-# INLINE happyIn269 #-} -happyOut269 :: (HappyAbsSyn ) -> HappyWrap269 -happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut269 #-} -newtype HappyWrap270 = HappyWrap270 (LBooleanFormula (LocatedN RdrName)) -happyIn270 :: (LBooleanFormula (LocatedN RdrName)) -> (HappyAbsSyn ) -happyIn270 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap270 x) -{-# INLINE happyIn270 #-} -happyOut270 :: (HappyAbsSyn ) -> HappyWrap270 -happyOut270 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut270 #-} -newtype HappyWrap271 = HappyWrap271 (Located [LocatedN RdrName]) -happyIn271 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn271 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap271 x) -{-# INLINE happyIn271 #-} -happyOut271 :: (HappyAbsSyn ) -> HappyWrap271 -happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut271 #-} -newtype HappyWrap272 = HappyWrap272 (LocatedN RdrName) -happyIn272 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn272 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap272 x) -{-# INLINE happyIn272 #-} -happyOut272 :: (HappyAbsSyn ) -> HappyWrap272 -happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut272 #-} -newtype HappyWrap273 = HappyWrap273 (LocatedN RdrName) -happyIn273 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn273 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap273 x) -{-# INLINE happyIn273 #-} -happyOut273 :: (HappyAbsSyn ) -> HappyWrap273 -happyOut273 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut273 #-} -newtype HappyWrap274 = HappyWrap274 (LocatedN RdrName) -happyIn274 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn274 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap274 x) -{-# INLINE happyIn274 #-} -happyOut274 :: (HappyAbsSyn ) -> HappyWrap274 -happyOut274 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut274 #-} -newtype HappyWrap275 = HappyWrap275 (LocatedN RdrName) -happyIn275 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn275 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap275 x) -{-# INLINE happyIn275 #-} -happyOut275 :: (HappyAbsSyn ) -> HappyWrap275 -happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut275 #-} -newtype HappyWrap276 = HappyWrap276 (LocatedN RdrName) -happyIn276 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn276 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap276 x) -{-# INLINE happyIn276 #-} -happyOut276 :: (HappyAbsSyn ) -> HappyWrap276 -happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut276 #-} -newtype HappyWrap277 = HappyWrap277 (Located (NonEmpty (LocatedN RdrName))) -happyIn277 :: (Located (NonEmpty (LocatedN RdrName))) -> (HappyAbsSyn ) -happyIn277 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap277 x) -{-# INLINE happyIn277 #-} -happyOut277 :: (HappyAbsSyn ) -> HappyWrap277 -happyOut277 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut277 #-} -newtype HappyWrap278 = HappyWrap278 (Located [LocatedN RdrName]) -happyIn278 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn278 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap278 x) -{-# INLINE happyIn278 #-} -happyOut278 :: (HappyAbsSyn ) -> HappyWrap278 -happyOut278 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut278 #-} -newtype HappyWrap279 = HappyWrap279 (LocatedN DataCon) -happyIn279 :: (LocatedN DataCon) -> (HappyAbsSyn ) -happyIn279 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap279 x) -{-# INLINE happyIn279 #-} -happyOut279 :: (HappyAbsSyn ) -> HappyWrap279 -happyOut279 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut279 #-} -newtype HappyWrap280 = HappyWrap280 (LocatedN DataCon) -happyIn280 :: (LocatedN DataCon) -> (HappyAbsSyn ) -happyIn280 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap280 x) -{-# INLINE happyIn280 #-} -happyOut280 :: (HappyAbsSyn ) -> HappyWrap280 -happyOut280 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut280 #-} -newtype HappyWrap281 = HappyWrap281 (LocatedN RdrName) -happyIn281 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn281 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap281 x) -{-# INLINE happyIn281 #-} -happyOut281 :: (HappyAbsSyn ) -> HappyWrap281 -happyOut281 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut281 #-} -newtype HappyWrap282 = HappyWrap282 (LocatedN RdrName) -happyIn282 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn282 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap282 x) -{-# INLINE happyIn282 #-} -happyOut282 :: (HappyAbsSyn ) -> HappyWrap282 -happyOut282 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut282 #-} -newtype HappyWrap283 = HappyWrap283 (LocatedN RdrName) -happyIn283 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn283 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap283 x) -{-# INLINE happyIn283 #-} -happyOut283 :: (HappyAbsSyn ) -> HappyWrap283 -happyOut283 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut283 #-} -newtype HappyWrap284 = HappyWrap284 (LocatedN RdrName) -happyIn284 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn284 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap284 x) -{-# INLINE happyIn284 #-} -happyOut284 :: (HappyAbsSyn ) -> HappyWrap284 -happyOut284 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut284 #-} -newtype HappyWrap285 = HappyWrap285 (LocatedN RdrName) -happyIn285 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn285 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap285 x) -{-# INLINE happyIn285 #-} -happyOut285 :: (HappyAbsSyn ) -> HappyWrap285 -happyOut285 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut285 #-} -newtype HappyWrap286 = HappyWrap286 (LocatedN RdrName) -happyIn286 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn286 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap286 x) -{-# INLINE happyIn286 #-} -happyOut286 :: (HappyAbsSyn ) -> HappyWrap286 -happyOut286 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut286 #-} -newtype HappyWrap287 = HappyWrap287 (LocatedN RdrName) -happyIn287 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn287 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap287 x) -{-# INLINE happyIn287 #-} -happyOut287 :: (HappyAbsSyn ) -> HappyWrap287 -happyOut287 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut287 #-} -newtype HappyWrap288 = HappyWrap288 (LocatedN RdrName) -happyIn288 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn288 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap288 x) -{-# INLINE happyIn288 #-} -happyOut288 :: (HappyAbsSyn ) -> HappyWrap288 -happyOut288 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut288 #-} -newtype HappyWrap289 = HappyWrap289 (LocatedN RdrName) -happyIn289 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn289 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap289 x) -{-# INLINE happyIn289 #-} -happyOut289 :: (HappyAbsSyn ) -> HappyWrap289 -happyOut289 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut289 #-} -newtype HappyWrap290 = HappyWrap290 (LocatedN RdrName) -happyIn290 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn290 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap290 x) -{-# INLINE happyIn290 #-} -happyOut290 :: (HappyAbsSyn ) -> HappyWrap290 -happyOut290 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut290 #-} -newtype HappyWrap291 = HappyWrap291 (LocatedN RdrName) -happyIn291 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn291 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap291 x) -{-# INLINE happyIn291 #-} -happyOut291 :: (HappyAbsSyn ) -> HappyWrap291 -happyOut291 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut291 #-} -newtype HappyWrap292 = HappyWrap292 (LocatedN RdrName) -happyIn292 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn292 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap292 x) -{-# INLINE happyIn292 #-} -happyOut292 :: (HappyAbsSyn ) -> HappyWrap292 -happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut292 #-} -newtype HappyWrap293 = HappyWrap293 (LocatedN RdrName) -happyIn293 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn293 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap293 x) -{-# INLINE happyIn293 #-} -happyOut293 :: (HappyAbsSyn ) -> HappyWrap293 -happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut293 #-} -newtype HappyWrap294 = HappyWrap294 (LocatedN RdrName) -happyIn294 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn294 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap294 x) -{-# INLINE happyIn294 #-} -happyOut294 :: (HappyAbsSyn ) -> HappyWrap294 -happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut294 #-} -newtype HappyWrap295 = HappyWrap295 (forall b. DisambInfixOp b => PV (LocatedN b)) -happyIn295 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn ) -happyIn295 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap295 x) -{-# INLINE happyIn295 #-} -happyOut295 :: (HappyAbsSyn ) -> HappyWrap295 -happyOut295 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut295 #-} -newtype HappyWrap296 = HappyWrap296 (forall b. DisambInfixOp b => PV (LocatedN b)) -happyIn296 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn ) -happyIn296 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap296 x) -{-# INLINE happyIn296 #-} -happyOut296 :: (HappyAbsSyn ) -> HappyWrap296 -happyOut296 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut296 #-} -newtype HappyWrap297 = HappyWrap297 (forall b. DisambInfixOp b => PV (Located b)) -happyIn297 :: (forall b. DisambInfixOp b => PV (Located b)) -> (HappyAbsSyn ) -happyIn297 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap297 x) -{-# INLINE happyIn297 #-} -happyOut297 :: (HappyAbsSyn ) -> HappyWrap297 -happyOut297 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut297 #-} -newtype HappyWrap298 = HappyWrap298 (LocatedN RdrName) -happyIn298 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn298 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap298 x) -{-# INLINE happyIn298 #-} -happyOut298 :: (HappyAbsSyn ) -> HappyWrap298 -happyOut298 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut298 #-} -newtype HappyWrap299 = HappyWrap299 (LocatedN RdrName) -happyIn299 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn299 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap299 x) -{-# INLINE happyIn299 #-} -happyOut299 :: (HappyAbsSyn ) -> HappyWrap299 -happyOut299 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut299 #-} -newtype HappyWrap300 = HappyWrap300 (LocatedN RdrName) -happyIn300 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn300 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap300 x) -{-# INLINE happyIn300 #-} -happyOut300 :: (HappyAbsSyn ) -> HappyWrap300 -happyOut300 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut300 #-} -newtype HappyWrap301 = HappyWrap301 (LocatedN RdrName) -happyIn301 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn301 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap301 x) -{-# INLINE happyIn301 #-} -happyOut301 :: (HappyAbsSyn ) -> HappyWrap301 -happyOut301 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut301 #-} -newtype HappyWrap302 = HappyWrap302 (LocatedN RdrName) -happyIn302 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn302 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap302 x) -{-# INLINE happyIn302 #-} -happyOut302 :: (HappyAbsSyn ) -> HappyWrap302 -happyOut302 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut302 #-} -newtype HappyWrap303 = HappyWrap303 (LocatedN RdrName) -happyIn303 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn303 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap303 x) -{-# INLINE happyIn303 #-} -happyOut303 :: (HappyAbsSyn ) -> HappyWrap303 -happyOut303 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut303 #-} -newtype HappyWrap304 = HappyWrap304 (LocatedN RdrName) -happyIn304 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn304 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap304 x) -{-# INLINE happyIn304 #-} -happyOut304 :: (HappyAbsSyn ) -> HappyWrap304 -happyOut304 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut304 #-} -newtype HappyWrap305 = HappyWrap305 (LocatedN FieldLabelString) -happyIn305 :: (LocatedN FieldLabelString) -> (HappyAbsSyn ) -happyIn305 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap305 x) -{-# INLINE happyIn305 #-} -happyOut305 :: (HappyAbsSyn ) -> HappyWrap305 -happyOut305 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut305 #-} -newtype HappyWrap306 = HappyWrap306 (LocatedN RdrName) -happyIn306 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn306 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap306 x) -{-# INLINE happyIn306 #-} -happyOut306 :: (HappyAbsSyn ) -> HappyWrap306 -happyOut306 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut306 #-} -newtype HappyWrap307 = HappyWrap307 (LocatedN RdrName) -happyIn307 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn307 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap307 x) -{-# INLINE happyIn307 #-} -happyOut307 :: (HappyAbsSyn ) -> HappyWrap307 -happyOut307 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut307 #-} -newtype HappyWrap308 = HappyWrap308 (LocatedN RdrName) -happyIn308 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn308 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap308 x) -{-# INLINE happyIn308 #-} -happyOut308 :: (HappyAbsSyn ) -> HappyWrap308 -happyOut308 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut308 #-} -newtype HappyWrap309 = HappyWrap309 (LocatedN RdrName) -happyIn309 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn309 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap309 x) -{-# INLINE happyIn309 #-} -happyOut309 :: (HappyAbsSyn ) -> HappyWrap309 -happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut309 #-} -newtype HappyWrap310 = HappyWrap310 (LocatedN RdrName) -happyIn310 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn310 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap310 x) -{-# INLINE happyIn310 #-} -happyOut310 :: (HappyAbsSyn ) -> HappyWrap310 -happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut310 #-} -newtype HappyWrap311 = HappyWrap311 (LocatedN RdrName) -happyIn311 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn311 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap311 x) -{-# INLINE happyIn311 #-} -happyOut311 :: (HappyAbsSyn ) -> HappyWrap311 -happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut311 #-} -newtype HappyWrap312 = HappyWrap312 (LocatedN RdrName) -happyIn312 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn312 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap312 x) -{-# INLINE happyIn312 #-} -happyOut312 :: (HappyAbsSyn ) -> HappyWrap312 -happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut312 #-} -newtype HappyWrap313 = HappyWrap313 (Located FastString) -happyIn313 :: (Located FastString) -> (HappyAbsSyn ) -happyIn313 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap313 x) -{-# INLINE happyIn313 #-} -happyOut313 :: (HappyAbsSyn ) -> HappyWrap313 -happyOut313 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut313 #-} -newtype HappyWrap314 = HappyWrap314 (Located FastString) -happyIn314 :: (Located FastString) -> (HappyAbsSyn ) -happyIn314 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap314 x) -{-# INLINE happyIn314 #-} -happyOut314 :: (HappyAbsSyn ) -> HappyWrap314 -happyOut314 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut314 #-} -newtype HappyWrap315 = HappyWrap315 (LocatedN RdrName) -happyIn315 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn315 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap315 x) -{-# INLINE happyIn315 #-} -happyOut315 :: (HappyAbsSyn ) -> HappyWrap315 -happyOut315 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut315 #-} -newtype HappyWrap316 = HappyWrap316 (LocatedN RdrName) -happyIn316 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn316 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap316 x) -{-# INLINE happyIn316 #-} -happyOut316 :: (HappyAbsSyn ) -> HappyWrap316 -happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut316 #-} -newtype HappyWrap317 = HappyWrap317 (LocatedN RdrName) -happyIn317 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn317 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap317 x) -{-# INLINE happyIn317 #-} -happyOut317 :: (HappyAbsSyn ) -> HappyWrap317 -happyOut317 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut317 #-} -newtype HappyWrap318 = HappyWrap318 (LocatedN RdrName) -happyIn318 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn318 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap318 x) -{-# INLINE happyIn318 #-} -happyOut318 :: (HappyAbsSyn ) -> HappyWrap318 -happyOut318 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut318 #-} -newtype HappyWrap319 = HappyWrap319 (Located (HsLit GhcPs)) -happyIn319 :: (Located (HsLit GhcPs)) -> (HappyAbsSyn ) -happyIn319 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap319 x) -{-# INLINE happyIn319 #-} -happyOut319 :: (HappyAbsSyn ) -> HappyWrap319 -happyOut319 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut319 #-} -newtype HappyWrap320 = HappyWrap320 (()) -happyIn320 :: (()) -> (HappyAbsSyn ) -happyIn320 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap320 x) -{-# INLINE happyIn320 #-} -happyOut320 :: (HappyAbsSyn ) -> HappyWrap320 -happyOut320 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut320 #-} -newtype HappyWrap321 = HappyWrap321 (LocatedA ModuleName) -happyIn321 :: (LocatedA ModuleName) -> (HappyAbsSyn ) -happyIn321 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap321 x) -{-# INLINE happyIn321 #-} -happyOut321 :: (HappyAbsSyn ) -> HappyWrap321 -happyOut321 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut321 #-} -newtype HappyWrap322 = HappyWrap322 (([SrcSpan],Int)) -happyIn322 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) -happyIn322 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap322 x) -{-# INLINE happyIn322 #-} -happyOut322 :: (HappyAbsSyn ) -> HappyWrap322 -happyOut322 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut322 #-} -newtype HappyWrap323 = HappyWrap323 (([SrcSpan],Int)) -happyIn323 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) -happyIn323 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap323 x) -{-# INLINE happyIn323 #-} -happyOut323 :: (HappyAbsSyn ) -> HappyWrap323 -happyOut323 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut323 #-} -newtype HappyWrap324 = HappyWrap324 (([SrcSpan],Int)) -happyIn324 :: (([SrcSpan],Int)) -> (HappyAbsSyn ) -happyIn324 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap324 x) -{-# INLINE happyIn324 #-} -happyOut324 :: (HappyAbsSyn ) -> HappyWrap324 -happyOut324 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut324 #-} -newtype HappyWrap325 = HappyWrap325 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -happyIn325 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn ) -happyIn325 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap325 x) -{-# INLINE happyIn325 #-} -happyOut325 :: (HappyAbsSyn ) -> HappyWrap325 -happyOut325 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut325 #-} -newtype HappyWrap326 = HappyWrap326 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -happyIn326 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn ) -happyIn326 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap326 x) -{-# INLINE happyIn326 #-} -happyOut326 :: (HappyAbsSyn ) -> HappyWrap326 -happyOut326 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut326 #-} -newtype HappyWrap327 = HappyWrap327 (ECP) -happyIn327 :: (ECP) -> (HappyAbsSyn ) -happyIn327 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap327 x) -{-# INLINE happyIn327 #-} -happyOut327 :: (HappyAbsSyn ) -> HappyWrap327 -happyOut327 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut327 #-} -newtype HappyWrap328 = HappyWrap328 (ECP) -happyIn328 :: (ECP) -> (HappyAbsSyn ) -happyIn328 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap328 x) -{-# INLINE happyIn328 #-} -happyOut328 :: (HappyAbsSyn ) -> HappyWrap328 -happyOut328 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut328 #-} -newtype HappyWrap329 = HappyWrap329 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn329 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) -happyIn329 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap329 x) -{-# INLINE happyIn329 #-} -happyOut329 :: (HappyAbsSyn ) -> HappyWrap329 -happyOut329 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut329 #-} -newtype HappyWrap330 = HappyWrap330 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn330 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) -happyIn330 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap330 x) -{-# INLINE happyIn330 #-} -happyOut330 :: (HappyAbsSyn ) -> HappyWrap330 -happyOut330 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut330 #-} -newtype HappyWrap331 = HappyWrap331 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn331 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) -happyIn331 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap331 x) -{-# INLINE happyIn331 #-} -happyOut331 :: (HappyAbsSyn ) -> HappyWrap331 -happyOut331 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut331 #-} -newtype HappyWrap332 = HappyWrap332 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn332 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) -happyIn332 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap332 x) -{-# INLINE happyIn332 #-} -happyOut332 :: (HappyAbsSyn ) -> HappyWrap332 -happyOut332 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut332 #-} -newtype HappyWrap333 = HappyWrap333 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -happyIn333 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn ) -happyIn333 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap333 x) -{-# INLINE happyIn333 #-} -happyOut333 :: (HappyAbsSyn ) -> HappyWrap333 -happyOut333 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut333 #-} -newtype HappyWrap334 = HappyWrap334 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -happyIn334 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn ) -happyIn334 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap334 x) -{-# INLINE happyIn334 #-} -happyOut334 :: (HappyAbsSyn ) -> HappyWrap334 -happyOut334 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut334 #-} -happyInTok :: ((Located Token)) -> (HappyAbsSyn ) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn ) -> ((Located Token)) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyExpList :: HappyAddr -happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xdf\x7c\xd5\xff\xbf\xfc\xbf\x67\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xff\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x08\x88\x08\x01\x2a\xe8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x10\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x90\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x82\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x0b\x20\x2a\x70\x06\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2e\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x80\xb8\x10\xa2\xc3\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x82\x0b\x21\x6a\xfc\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x08\x80\x08\x01\x2a\xe8\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x0a\x67\xf8\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x88\x08\x01\x10\x84\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x1f\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x08\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x82\x07\x20\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\xc0\x01\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xe0\x8a\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x82\x0f\x03\xba\xfc\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x24\xf8\x10\xa0\xce\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x00\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\xaa\x70\x86\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x82\x0f\x03\xba\xfc\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x04\x42\xf0\xff\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x48\xf5\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x41\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x20\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x41\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\xf8\x01\x00\x88\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\xcb\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x82\x0f\x01\xaa\xf8\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x41\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x08\x80\x08\x01\x3a\xe4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x80\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x5c\x44\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x88\x08\x01\x00\x88\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x88\x00\x01\x10\x84\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x80\x98\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xff\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\xce\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x80\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x40\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x3a\xfc\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x01\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x82\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\x70\xf0\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x00\x04\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x04\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa4\x2a\x67\xfe\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xab\x72\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x40\xaa\x72\xe6\xff\xff\x7f\x7d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xb0\x2a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x4c\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xfc\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x1a\x67\xfe\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xdf\x7c\xd5\xff\xbf\xfc\xbf\x67\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x80\x08\x01\x00\x88\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\x8a\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x00\x01\x00\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x20\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x08\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x00\x01\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xdf\x7c\xd5\xff\xbf\xfc\xbf\x67\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x00\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x82\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x08\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x82\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x80\x88\x10\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x72\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x72\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\x8a\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x04\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\x70\xf0\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x4c\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\xc4\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x82\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xcd\x5c\x54\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xcc\x45\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xcc\x55\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc5\x5c\x55\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x80\x54\xff\x9f\xf4\x03\x00\x00\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x08\x01\x00\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x5c\x44\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x42\xf4\xf7\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x3a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\x8a\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\x70\xf0\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xcc\x45\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xcc\x55\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x0c\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\xc0\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x54\xff\x9f\xf0\x03\x00\x40\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x80\xb8\x10\xa2\xc3\xff\xe9\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x0e\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x48\xf5\xff\x49\x3f\x00\x00\x00\x00\x00\x00\x08\x64\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x54\xff\x9f\xf0\x03\x00\x40\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x80\x54\xff\x9f\xf4\x03\x00\x00\x00\x00\x00\x80\x40\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\x70\xf0\x09\x3f\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x48\xf5\xff\x49\x3f\x00\x00\x00\x00\x00\x00\x08\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -{-# NOINLINE happyExpListPerState #-} -happyExpListPerState st = - token_strs_expected - where token_strs = ["error","%dummy","%start_parseModuleNoHaddock","%start_parseSignature","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","HYPHEN","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","missing_module_keyword","implicit_top","maybemodwarning","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","export","maybeexportwarning","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","importlist","importlist1","import","prec","infix","ops","topdecls","topdecls_semi","topdecls_cs","topdecls_cs_semi","topdecl_cs","topdecl","cl_decl","ty_decl","standalone_kind_sig","sks_vars","inst_decl","overlap_pragma","deriv_strategy_no_via","deriv_strategy_via","deriv_standalone_strategy","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","opt_instance","at_decl_inst","type_data_or_newtype","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","datafam_inst_hdr","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","qvarcon","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_activation_marker","rule_explicit_activation","rule_foralls","rule_vars","rule_var","warning_category","warnings","warning","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_tyconsig","sigktype","sigtype","sig_vars","sigtypes1","unpackedness","forall_telescope","ktype","ctype","context","type","mult","btype","infixtype","ftype","tyarg","tyop","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","tv_bndr_no_braces","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","deriv_clause_types","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","activation","explicit_activation","quasiquote","exp","infixexp","exp10p","exp10","optSemi","prag_e","fexp","aexp","aexp1","aexp2","projection","splice_exp","splice_untyped","splice_typed","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","guardquals","guardquals1","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat","pats1","bindpat","apat","apats","stmtlist","stmts","maybe_stmt","e_stmt","stmt","qual","fbinds","fbinds1","fbind","fieldToUpdate","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon_nowiredlist","qcon","gen_qcon","con","con_list","qcon_list","sysdcon_nolist","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","tycon","qtyconsym","tyconsym","otycon","op","varop","qop","qopm","hole_op","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","field","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","altslist__apats__","altslist__pats1__","exp_prag__exp__","exp_prag__exp10p__","alts__apats__","alts__pats1__","alts1__apats__","alts1__pats1__","alt__apats__","alt__pats1__","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'via'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# OPAQUE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# SCC'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'lcases'","'|'","'<-'","'->'","'->.'","TIGHT_INFIX_AT","'=>'","'-'","PREFIX_TILDE","PREFIX_BANG","PREFIX_MINUS","'*'","'-<'","'>-'","'-<<'","'>>-'","'.'","PREFIX_PROJ","TIGHT_INFIX_PROJ","PREFIX_AT","PREFIX_PERCENT","'{'","'}'","vocurly","vccurly","'['","']'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","DO","MDO","IPDUPVARID","LABELVARID","CHAR","STRING","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMINTEGER8","PRIMINTEGER16","PRIMINTEGER32","PRIMINTEGER64","PRIMWORD8","PRIMWORD16","PRIMWORD32","PRIMWORD64","PRIMFLOAT","PRIMDOUBLE","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","PREFIX_DOLLAR","PREFIX_DOLLAR_DOLLAR","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] - bit_start = st Prelude.* 492 - bit_end = (st Prelude.+ 1) Prelude.* 492 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..491] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x91\x00\x3c\x00\xc4\x00\xf2\x1e\x74\x11\x03\x22\x03\x22\xd0\x18\xf2\x1e\xc4\x49\xe9\x35\x95\x00\x2f\x00\xc6\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x03\x00\x00\x00\x00\x00\x00\x0f\x01\x00\x00\x8b\x02\x8b\x02\x00\x00\x79\x00\x04\x01\x04\x01\x9e\x3b\xe9\x35\xe2\x00\x3f\x01\x52\x01\x00\x00\x2b\x0d\x00\x00\x4e\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x81\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x0b\x00\x00\x8c\x0c\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x62\x00\x00\x00\x00\x00\x00\xbc\x01\x05\x02\x00\x00\x00\x00\x21\x3c\x21\x3c\x00\x00\x00\x00\x01\x62\x5a\x34\xc3\x31\x48\x32\xf5\x4c\x2b\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x30\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x02\x61\x08\xf8\x02\x93\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\xca\x0d\x00\x00\x03\x22\x69\x0e\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\xa3\x02\x69\x02\x00\x00\x00\x00\x10\x0a\x00\x00\x00\x00\xc2\x02\x00\x00\x00\x00\x00\x00\x03\x22\xb8\x1d\xfc\x02\x81\x2f\x52\x03\x81\x2f\xf7\xff\x88\x27\xaa\x2d\x81\x2f\x81\x2f\x81\x2f\xe1\x1b\x22\x15\x96\x17\x81\x2f\x61\x4b\x52\x03\x52\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x22\x25\x28\xe9\x35\xb6\x03\x03\x22\x1e\x30\xaf\x0a\xa1\x02\x00\x00\x9f\x02\x92\x0f\xb7\x02\xe2\x02\x00\x00\x00\x00\x00\x00\xeb\x03\xdb\x02\x94\x4b\xc6\x4d\x2a\x4d\x56\x4d\xc6\x4d\x2d\x60\x23\x03\x22\x15\x00\x00\xae\x02\xae\x02\xae\x02\x00\x00\x00\x00\x00\x00\x00\x00\x14\x03\x57\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x9e\x3b\x5a\x00\x07\x03\x02\x03\xcf\x04\x5c\x03\x50\x33\x53\x02\x8a\x60\xf9\x02\xb6\x60\x39\x00\x01\x60\x15\x03\x00\x00\x15\x03\x87\x03\x30\x03\x1c\x03\x30\x03\x00\x00\x00\x00\x1c\x03\x00\x00\x74\x03\x77\x03\x04\x02\x00\x00\x00\x00\x76\x00\x04\x02\xc6\x03\xaf\x03\x81\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x2f\x06\x02\xc5\x02\xb6\x60\x6b\x01\x00\x00\x7b\x03\x73\x01\x00\x00\x9d\x00\x9b\x03\x78\x01\x00\x00\xc2\x28\xd4\x02\xc8\x61\xd8\x03\x6d\x00\x16\x02\x00\x00\xb8\x06\xb8\x06\xf0\xff\xdf\x03\xfb\x03\x1b\x00\x00\x00\x07\x39\x9e\x3b\x21\x02\xe9\x35\xe8\x03\xed\x03\xf2\x03\xfd\x03\x00\x00\x3c\x04\x00\x00\x00\x00\x00\x00\xe9\x35\xe9\x35\x9e\x3b\x06\x04\x27\x04\x00\x00\x90\x03\x00\x00\x03\x22\x00\x00\x00\x00\xe9\x35\x90\x4a\x1f\x04\x9e\x3b\x03\x04\x49\x04\x5c\x04\xda\x00\x94\x01\x38\x04\x00\x00\x5f\x29\x00\x00\x00\x00\x00\x00\x42\x04\x45\x04\x4a\x04\x54\x04\x6d\x19\x7e\x1c\x00\x00\xaa\x2d\x3e\x4f\x00\x00\x00\x00\x90\x4a\x4b\x04\x84\x04\x41\x01\x8c\x04\x00\x00\x99\x04\x00\x00\x7e\x04\x00\x00\xf9\x4d\x2d\x00\xc6\x4d\x00\x00\x26\x01\xc6\x4d\xe9\x35\xaa\x04\xf6\x4b\x8d\x04\x00\x00\xf9\x04\x0a\x1a\x0a\x1a\x01\x62\xe9\x35\x9b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x04\x73\x27\xa5\x01\x00\x00\x00\x00\x82\x04\x95\x04\x00\x00\x00\x00\xa4\x04\x4f\x02\xbc\x04\x00\x00\xf2\x1e\xf2\x1e\x00\x00\x00\x00\x00\x00\x13\x05\x00\x00\xd7\x01\xf7\x04\x00\x00\x00\x00\xa7\x1a\x00\x00\xd5\x04\x54\x01\x03\x05\x05\x05\x00\x00\x00\x00\x00\x00\x00\x00\x08\x0f\x00\x00\x81\x2f\x31\x05\x0c\x04\x29\x04\x47\x05\x4a\x05\x00\x00\x00\x00\x50\x05\x9b\x05\x3d\x05\x30\x00\x00\x00\x00\x00\xa0\x22\x6c\x05\xad\x05\x81\x2f\x3d\x23\x3e\x4f\x93\x4d\x00\x00\x21\x3c\x00\x00\xe9\x35\x3d\x23\x3d\x23\x3d\x23\x3d\x23\x57\x05\x5d\x05\x82\x03\x6d\x05\x7c\x05\xd5\x02\x8c\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x35\xd5\x33\xc9\x4c\xb9\x05\xc2\x05\x6f\x00\xb2\x05\xd2\x05\x97\x03\x15\x00\x00\x00\x8d\x03\xbb\x30\x9e\x03\xd9\x05\x00\x00\x2f\x02\x00\x00\x9f\x00\xe1\x05\x00\x00\xe0\x05\x00\x00\x71\x02\x00\x00\x67\x4c\x00\x00\x00\x00\x00\x00\xe6\x01\xc1\x62\x00\x00\x00\x00\x21\x63\x21\x63\xe9\x35\x21\x3c\x00\x00\x9e\x3b\x00\x00\x21\x3c\x14\x06\xe9\x35\xe9\x35\x21\x3c\xe9\x35\xe9\x35\x00\x00\x00\x00\xb9\x02\x00\x00\x3f\x47\x31\x00\x00\x00\xfa\x05\x04\x02\x04\x02\x00\x00\x03\x06\x9d\x00\x63\x06\x0b\x06\x00\x00\x00\x00\x70\x06\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x06\x6d\x06\xfb\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x35\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x79\x01\x00\x00\x00\x00\x00\x00\x22\x06\x01\x62\x00\x00\xe9\x35\x01\x62\x00\x00\xe9\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x35\xe9\x35\x00\x00\x00\x00\x2b\x06\x27\x06\x36\x06\x39\x06\x46\x06\x48\x06\x5f\x06\x76\x06\x7a\x06\x5d\x06\x6f\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x06\x00\x00\x79\x06\xa4\x06\x96\x06\x9b\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x04\x61\x01\xa1\x06\x8f\x06\x00\x00\x00\x00\x00\x00\xed\x06\x00\x00\x3d\x23\x3d\x23\x00\x00\x00\x00\x00\x00\xfc\x29\x45\x10\x00\x00\x55\x1e\xa7\x0f\x3d\x23\x00\x00\x1b\x1d\x00\x00\x3d\x23\x8f\x1f\x1b\x1d\x00\x00\x9e\x06\x00\x00\x00\x00\x00\x00\x33\x18\xc3\x06\x00\x00\x47\x2e\x48\x00\x00\x00\xc7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x74\x11\x76\x00\xba\x06\x00\x00\x00\x00\x00\x00\xbd\x06\x00\x00\xa9\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x61\x00\x00\x00\x00\xee\x00\x84\x00\x00\x00\x00\x00\x0e\x15\x00\x00\xbf\x15\x5c\x16\xa6\x00\x00\x00\xf9\x16\xdf\x02\xe8\x02\xdb\x02\xdd\x06\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x06\xeb\x06\xb9\x06\x00\x00\x00\x00\xd9\x06\x00\x07\x00\x00\x05\x07\xe6\x06\xe9\x06\x13\x61\x13\x61\x00\x00\x12\x07\xba\x03\xc0\x04\xec\x06\xf5\x06\x00\x00\x19\x07\xfe\x06\x76\x04\x00\x00\x00\x00\x3e\x4f\x00\x00\x3d\x23\x1b\x1d\xbf\x00\xe8\x04\x8c\x39\xe2\x03\x00\x00\x00\x00\x3d\x23\x00\x00\x00\x00\x2c\x00\x00\x00\x3d\x23\xda\x23\x9e\x3b\x5a\x07\x00\x00\x43\x07\x2a\x07\x00\x00\x00\x00\x50\x07\xcf\x04\x00\x00\x00\x00\x00\x00\x00\x00\x85\x07\x13\x00\xa1\x04\x10\x05\x00\x00\x54\x07\xc1\x62\xe9\x35\xe9\x35\x21\x02\x4a\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x46\x3e\x4f\x41\x07\xe9\x35\x00\x00\x3e\x4f\x01\x62\x77\x24\x77\x24\x99\x2a\x00\x00\x7a\x01\x00\x00\x39\x07\x3f\x61\x00\x00\x42\x07\x00\x00\x00\x00\x3f\x61\x00\x00\x00\x00\x3d\x00\x9d\x00\x00\x00\x81\x2f\x49\x02\x82\x07\x83\x07\x00\x00\xb7\x07\x00\x00\x63\x07\x00\x00\x63\x07\x00\x00\x00\x00\xc3\x07\x00\x00\x5f\x07\x00\x00\x74\x11\xbe\x07\x6e\x01\xc5\x07\x5e\x07\x00\x00\x00\x00\x00\x00\x75\x07\x9e\x07\x00\x00\x00\x00\x00\x00\x63\x02\x00\x00\x00\x00\x00\x00\x19\x01\x80\x07\x36\x2b\x2d\x62\xd2\x07\x00\x00\x87\x07\x7d\x07\x00\x00\x00\x00\x86\x07\x00\x00\x13\x47\x00\x00\xae\x07\xb0\x07\xb2\x07\xb3\x07\x61\x62\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x07\xe9\x35\xaf\x07\xe9\x35\xc1\x62\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x04\xe9\x35\xe9\x35\x00\x00\x00\x00\xe9\x35\x8f\x07\x00\x00\xb3\x4f\x00\x00\xd8\x04\x00\x00\xb6\x07\xeb\x07\x00\x00\x00\x00\xe7\x04\x00\x00\x87\x05\xbf\x07\x00\x00\xc1\x62\xec\x07\x00\x08\xe9\x35\xfa\x07\x00\x00\xd0\x07\x00\x00\x00\x00\x00\x00\xcb\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x35\x00\x00\xb4\x07\xe9\x35\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x07\x00\x00\x44\x1b\x77\x24\x00\x00\x00\x00\xe9\x35\x9b\x07\x00\x00\x00\x00\xbd\x07\x00\x00\x2c\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x14\x25\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x04\x00\x00\x76\x00\xc0\x07\x00\x00\xc9\x20\xbc\x07\x00\x00\x2d\x04\x00\x00\x76\x00\xc1\x07\x00\x00\xe4\x2e\xcd\x07\x00\x00\x00\x00\x00\x00\xb1\x25\x4e\x26\xeb\x26\x00\x00\x00\x00\x3e\x4f\x1b\x1d\x93\x4d\x00\x00\x00\x00\xe9\x35\x00\x00\x00\x00\xe5\x07\x00\x00\xd1\x07\xcf\x07\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x35\x00\x00\xe9\x35\x00\x00\xcb\x5f\x00\x00\x00\x00\x00\x00\xeb\x04\x00\x00\x1e\x08\x75\x01\xf3\x07\x25\x08\x19\x05\x00\x00\xf6\x07\x19\x05\x00\x00\x28\x02\x28\x02\x00\x00\xd4\x07\xdc\x07\x00\x00\x00\x00\xd9\x07\x00\x00\x00\x00\xc7\x01\x00\x00\x00\x00\x00\x00\xd5\x07\x00\x00\x00\x00\xd3\x2b\x00\x00\x00\x00\x2f\x08\xf8\x07\xeb\x26\x00\x00\x00\x00\xeb\x26\x00\x00\x00\x00\x21\x08\x11\x12\x66\x21\x66\x21\xeb\x26\x00\x00\xe2\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x07\xe4\x07\x0b\x08\x00\x00\x0e\x08\x00\x00\x07\x08\x00\x00\x9e\x3b\xc1\x62\x00\x00\x00\x00\x51\x08\x00\x00\xf3\x01\x51\x08\x59\x05\xfe\x07\x9e\x3b\x41\x08\x57\x08\x00\x00\x00\x00\xeb\x26\x00\x00\xae\x12\xae\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x13\x4b\x13\x00\x00\x00\x00\x00\x00\x47\x08\x21\x63\x00\x00\x9e\x3b\x15\x08\xe9\x35\x00\x00\x00\x00\x61\x62\x00\x00\x00\x00\x75\x05\x03\x08\x8d\x62\x00\x00\x3e\x4f\xb7\x04\x00\x00\x00\x00\xfb\x07\x00\x00\xed\x07\x00\x00\x00\x00\x19\x04\x00\x00\x80\x05\x02\x08\xf2\x07\x00\x00\xf8\x4a\x75\x01\x63\x08\x00\x00\x80\x05\x01\x08\x00\x00\x04\x08\x00\x00\x04\x08\x00\x00\x00\x00\x00\x00\x75\x01\x28\x08\x08\x08\x00\x00\x00\x00\x00\x00\x00\x00\x19\x04\x21\x02\xc0\x04\x32\x07\x1e\x00\x00\x00\x00\x00\x5e\x08\x00\x00\x00\x00\xeb\x26\x33\x08\x00\x00\x70\x2c\x44\x1b\x44\x1b\x00\x00\x00\x00\xe9\x35\x39\x08\x00\x00\x34\x08\x00\x00\xa5\x05\x00\x00\x77\x08\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x77\x08\xfa\x02\x00\x00\x21\x63\x00\x00\x00\x00\x0a\x01\x00\x00\x67\x08\x0d\x2d\xdf\x34\x19\x03\x00\x00\x00\x00\x83\x08\x00\x00\x9e\x3b\xd3\x04\xd3\x04\x00\x00\xa4\x02\x60\x08\x00\x00\x00\x00\x00\x00\x00\x00\x64\x35\x00\x00\x36\x08\x43\x08\x00\x00\x44\x08\x00\x00\x81\x08\x00\x00\x00\x00\xe9\x35\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x26\xeb\x26\xeb\x26\x00\x00\x00\x00\x00\x00\x00\x00\x93\x08\x1b\x1d\x3e\x4f\x00\x00\x00\x00\x00\x00\x22\x01\x00\x00\x66\x08\x19\x04\x5f\x47\x44\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x02\x32\x08\x3d\x08\x93\x47\xd1\x05\x19\x04\x00\x00\x00\x00\x00\x00\xeb\x26\x00\x00\x00\x00\x7a\x08\x00\x00\x00\x00\x9e\x3b\x00\x00\x37\x08\x3c\x08\x00\x00\x00\x00\x00\x00\x76\x00\x3a\x08\xdb\x02\x4b\x08\x5d\x08\x00\x00\x00\x00\x00\x00\xe8\x13\x00\x00\xf0\x05\x11\x3a\x9e\x3b\x82\x17\x9e\x3b\x00\x00\x00\x00\x00\x00\x85\x14\x11\x3a\x00\x00\x00\x00\x6a\x08\x00\x00\x6e\x36\xf3\x36\x21\x63\x78\x37\x00\x00\x53\x01\x55\x03\x8d\x62\x78\x37\x00\x00\xb2\x08\x00\x00\x52\x08\x53\x08\x56\x08\x00\x00\x00\x00\x00\x00\x00\x00\x29\x4c\x00\x00\x85\x08\x76\x00\x69\x08\x00\x00\x00\x00\x00\x00\x64\x08\x62\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x19\x04\x6b\x08\x72\x08\x00\x00\x00\x00\x00\x00\x21\x63\x00\x00\x58\x01\x00\x00\x76\x00\x56\x03\x70\x08\x96\x3a\x00\x00\x00\x00\x8e\x08\x78\x37\x10\x06\x00\x00\x00\x00\x78\x37\xfd\x37\x00\x00\x9e\x3b\x00\x00\x94\x08\xd3\x04\x00\x00\x00\x00\x82\x38\x00\x00\x00\x00\xeb\x26\x00\x00\x26\x06\x58\x08\x00\x00\x19\x04\x00\x00\x19\x04\x00\x00\xa5\x03\x00\x00\xe4\x08\x8a\x02\x00\x00\x0d\x00\xd2\x08\x84\x08\x00\x00\x00\x00\x00\x00\x82\x38\x00\x00\x9d\x08\xe3\x10\xcd\x32\x00\x00\x00\x00\xed\x62\x00\x00\x00\x00\x2d\x06\x00\x00\x00\x00\x1b\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x08\xbc\x4a\x29\x4c\x00\x00\x00\x00\x90\x08\x91\x08\x7e\x08\x00\x00\x19\x04\xc0\x04\x00\x00\xbc\x4a\x00\x00\xe3\x08\xf7\x08\x3e\x31\x21\x63\x00\x00\xe7\x08\xbc\x05\xad\x2f\x19\x04\x00\x00\x19\x04\x19\x04\x00\x00\x19\x04\x00\x00\x00\x00\x00\x00\x8b\x08\xb6\x08\x00\x00\x19\x04\x00\x00\xbc\x05\x00\x00\x00\x00\x00\x09\xa7\x08\x00\x00\x00\x00\x2d\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x08\x19\x04\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x8f\x03\x0a\x09\xee\x08\xe0\x53\x72\x01\x80\x57\xae\x56\xc9\x05\x28\x54\x01\x00\x05\x40\x0b\x01\xb3\x01\x88\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x05\x00\x00\x00\x00\x5a\x01\x00\x00\x00\x00\xef\x07\xf0\x07\xf2\x01\x00\x00\x7d\x06\x88\x06\xde\x3a\xdb\x42\x00\x00\x00\x00\x00\x00\x00\x00\x92\x08\x00\x00\xee\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\xb1\x00\x00\x00\x00\x00\x9b\xff\x3d\x40\xf9\x07\x91\x07\x4e\xff\x10\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x05\xfc\x07\xab\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x10\x00\x00\xc6\x57\x0d\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x58\x92\x55\x1c\x06\x1e\x64\x40\x08\x57\x64\x00\x00\x8a\x63\x17\x07\x90\x64\xa1\x64\xda\x64\x69\x4f\x0a\x4e\xf4\x4e\x13\x65\xe9\x11\x46\x08\x48\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x58\x98\x62\x71\x40\x54\x08\x98\x58\x21\x66\x4d\x05\xf5\x08\x00\x00\x00\x00\xac\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x06\x0c\x02\x02\x06\xa8\x03\x12\x06\x38\x06\x51\x04\x29\x08\x03\x02\x7f\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x02\x08\x01\x00\x00\x00\x00\x7c\x06\xed\x08\x00\x00\x48\x03\xae\x08\xa0\xff\xcd\x06\x2c\x01\x97\x05\xb1\x07\x00\x00\x00\x00\x00\x00\x08\x09\x00\x00\x11\x08\x00\x00\x7d\x01\x00\x00\x14\x08\xf5\x01\x00\x00\x45\x02\x31\x09\x00\x00\x00\x00\x1d\x08\x38\x09\x1e\x09\x00\x00\x24\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x65\x93\x01\x35\x03\xb0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x08\x00\x00\x00\x00\x00\x00\x37\x05\x00\x00\xa7\xff\x00\x00\x67\xff\xb3\x03\x00\x00\xc8\x08\xca\x08\x00\x00\x00\x00\xbc\x08\x00\x00\x00\x00\x43\x05\x2d\x08\x77\x02\xc7\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x38\x67\x3e\xd2\x44\xb0\x08\x00\x00\x00\x00\x71\x05\x00\x00\x81\x4d\x00\x00\x00\x00\x0a\x3d\xab\x04\xf9\x08\xf9\x06\x00\x00\x00\x00\x83\x12\x00\x00\xb7\x00\x00\x00\x00\x00\xa9\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x4f\xb6\x50\x00\x00\x17\x07\xf6\x02\x00\x00\x00\x00\x89\x05\x00\x00\xcc\x08\xcb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x06\x00\x00\x7d\x04\x00\x00\xe1\x08\xd6\x04\x18\x3c\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\xa8\x02\xf2\x02\xef\xff\x1d\x3d\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x01\xf1\x04\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x09\x00\x00\x00\x20\x13\x00\x00\x00\x00\x70\x54\xb8\x54\x00\x00\x00\x00\x00\x00\xde\x05\x95\x08\xb7\x00\x00\x00\x00\x00\x00\x00\xd8\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x65\x00\x00\x9b\x63\x00\x00\x2c\x08\x2e\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x08\x58\xff\x00\x00\x00\x00\xff\x54\x53\x05\x00\x00\xa7\x65\xde\x58\x16\x03\x8a\x01\x00\x00\xe1\x02\x00\x00\x1f\x43\x24\x59\x6a\x59\xb0\x59\xf6\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x3e\xe6\x07\x27\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x04\x00\x00\x18\x08\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x52\x02\x6e\x02\x32\x43\x1c\x05\x00\x00\xea\x45\x00\x00\x25\x05\x00\x00\x76\x43\x89\x43\xfd\x05\xcd\x43\x92\x40\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x35\x08\x00\x00\xb3\x02\x50\x09\x52\x09\x00\x00\x49\x09\xe8\x08\xef\x08\x4e\x09\x00\x00\x00\x00\x41\x09\x00\x00\x00\x00\x00\x00\x00\x00\x72\x09\x00\x00\x6c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x24\x44\x63\x01\x00\x00\xce\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x3f\x9d\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x08\x96\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x5a\x82\x5a\x00\x00\x00\x00\x00\x00\x3a\x48\xf3\x47\x00\x00\x1e\x47\xd4\x46\xc8\x5a\x00\x00\x25\x51\x00\x00\x0e\x5b\x50\x53\x94\x51\x00\x00\x5b\xff\x00\x00\x00\x00\x00\x00\x47\x50\x00\x00\x00\x00\xd4\x63\x4d\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x02\x5b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x02\x00\x00\x00\x00\x00\x00\x6e\x08\x00\x00\x00\x00\x6c\x02\x00\x00\x00\x00\x00\x00\x6f\x08\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x14\x20\x10\x00\x00\x00\x00\x4c\x06\x7a\x02\x00\x00\x00\x00\x00\x00\x50\x06\x00\x00\x20\x13\x00\x00\x00\x00\x60\x03\x00\x00\x81\x4d\x03\x52\x00\x00\xdf\xff\x3e\x07\x00\x00\x00\x00\x00\x00\xc4\x4d\x00\x00\x00\x00\xde\xff\x00\x00\x54\x5b\x46\x55\xe5\x44\x0f\x09\xa1\x05\x29\x09\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x15\x09\x45\x06\x4e\x06\x3f\x09\x00\x00\x00\x00\xf3\x00\xa5\x40\xbf\x39\x16\x04\x93\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\xff\x45\x03\x7b\x08\x61\x3d\x00\x00\xbf\xff\xca\xff\xf4\x56\x3a\x57\x2b\x09\x00\x00\x2e\x09\x00\x00\x2d\x09\xa6\x05\x00\x00\x24\x09\x00\x00\x00\x00\xb2\x01\x00\x00\x00\x00\xc0\x05\x26\x09\x00\x00\xe0\x65\x99\x08\x00\x00\x00\x00\x00\x00\x7a\x09\x00\x00\x8e\x09\x00\x00\x91\x09\x00\x00\x00\x00\x1a\x03\x00\x00\x87\x09\x00\x00\x27\x01\x00\x00\x64\x05\x00\x00\x81\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x63\xb0\xff\x4b\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x40\x69\x09\x42\x41\x77\x00\x00\x00\x53\x09\x00\x00\x00\x00\x00\x00\x00\x00\x44\x09\x5c\x3c\x71\x41\x00\x00\x00\x00\x93\x41\x00\x00\x00\x00\x7f\x02\x00\x00\x4a\x09\x00\x00\x00\x00\x48\x09\x00\x00\x00\x00\x11\x07\x00\x00\xfb\xff\x00\x00\x00\x00\x30\x01\x14\x09\x04\x06\xda\x41\x98\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x3c\x00\x00\x00\x00\xb3\x3c\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x06\x00\x00\xb7\x05\x9a\x5b\x00\x00\x00\x00\x74\x3d\xbb\x04\x00\x00\x00\x00\xa6\x09\x00\x00\xda\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x06\x00\x00\xe5\x08\x00\x00\x00\x00\x67\x47\x00\x00\x00\x00\x4f\x06\x00\x00\xe6\x08\x00\x00\x00\x00\x80\x48\x00\x00\x00\x00\x00\x00\x00\x00\x26\x5c\x68\x56\x6c\x5c\x00\x00\x00\x00\x46\x01\x72\x52\x9b\x01\x00\x00\x00\x00\xb0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x42\x00\x00\x43\x42\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\xc8\x09\x00\x00\x00\x00\x8f\x09\x00\x00\x00\x00\xff\x09\x00\x00\x00\x00\x00\x0a\x00\x00\x79\x07\x9a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x09\x00\x00\x00\x00\xaf\x48\x00\x00\x00\x00\xa7\x09\x39\x09\xb2\x5c\x00\x00\x00\x00\xb0\x47\x00\x00\x00\x00\x00\x00\x00\x00\x97\x53\x21\x56\xf8\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x44\x67\x01\x00\x00\x00\x00\x6a\x09\x00\x00\xc4\xff\xb4\x06\x00\x00\x00\x00\x29\x45\x76\x09\xc2\x06\x00\x00\x00\x00\x3e\x5d\x00\x00\x71\x03\xbb\x03\x00\x00\x7d\x09\x0b\x07\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xff\x32\x02\x00\x00\x00\x00\x00\x00\xdb\x09\xba\xff\x00\x00\x3c\x45\x00\x00\xb8\x3d\x00\x00\x00\x00\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\x4c\x03\x20\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x09\x00\x00\x22\x0a\x00\x00\x00\x00\x00\x00\x50\x00\xb9\x09\xc5\x09\x00\x00\x2f\x0a\x1c\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x02\x9c\x02\xc3\x09\x00\x00\x24\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x19\x09\x56\x04\xfe\x02\x17\x06\x95\x07\x00\x00\x00\x00\x18\x0a\x00\x00\x00\x00\x84\x5d\x00\x00\x00\x00\x00\x00\xfb\x04\x45\x05\x00\x00\x00\x00\xcb\x3d\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x09\x00\x00\xf8\x09\x00\x00\x20\x09\x00\x00\x00\x00\x00\x00\xfd\x09\x00\x00\x00\x00\x7f\x02\x00\x00\x00\x00\x21\x09\x00\x00\x01\x0a\x25\x63\x05\x06\x00\x00\x00\x00\x00\x00\xc6\x06\x00\x00\x8e\x44\x55\x01\x15\x02\x00\x00\x80\xff\x09\x0a\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x07\x00\x00\x00\x00\xc6\x3c\x00\x00\x00\x00\x00\x00\x00\x00\xca\x5d\x10\x5e\x56\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x52\xd3\x03\x00\x00\x00\x00\x00\x00\x27\x09\x00\x00\x26\x0a\x23\x09\x0e\x00\x00\x00\x00\x00\xdc\x02\xee\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x0a\x53\x0a\x00\x00\x14\x00\x4e\x0a\x45\x09\x00\x00\x00\x00\x00\x00\x9c\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x09\x00\x00\xdb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x04\x00\x00\x57\x0a\x64\x06\x80\x45\x20\x13\x93\x45\x00\x00\x00\x00\x00\x00\x3f\x04\x92\x06\x00\x00\x00\x00\x55\x0a\x00\x00\x87\x04\xde\x04\xbd\xff\x77\x42\x00\x00\x85\x09\x00\x00\xd4\xff\x37\x44\x00\x00\x86\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x8b\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x07\x8c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x02\x00\x00\x92\x09\x00\x00\x96\x09\x00\x00\x00\x00\x59\x07\x00\x00\x00\x00\x62\x0a\x0f\x3e\x65\x0a\x00\x00\x00\x00\x8a\x42\xd1\x3f\x00\x00\xd7\x45\x00\x00\x00\x00\x20\x02\x00\x00\x00\x00\x8d\x34\x00\x00\x00\x00\xe2\x5e\x00\x00\xa8\x0a\xa9\x0a\x00\x00\xff\xff\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x0a\x00\x00\x00\x00\x00\x00\x22\x3e\x00\x00\x00\x00\x00\x00\x4e\x08\x00\x00\x00\x00\x9d\xff\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\xb5\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xff\x2e\x00\x00\x00\x00\x00\xb7\x0a\x00\x00\x00\x00\x00\x00\xac\x09\x41\x03\x00\x00\x3a\x00\x00\x00\x38\x0a\xe1\x06\x00\x00\xbc\xff\x00\x00\x00\x00\xce\x0a\x08\x00\xb5\x09\x00\x00\x02\x00\xb6\x09\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x09\x00\x00\xd2\x0a\x00\x00\x00\x00\xfa\x06\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x09\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# -happyAdjustOffset off = off - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\xfd\x00\x00\x00\x00\xbf\xff\xc0\xff\x00\x00\xf2\xff\x09\xfd\x05\xfd\x02\xfd\xf2\xfc\xf0\xfc\xf1\xfc\xfe\xfc\xef\xfc\xee\xfc\xed\xfc\x00\xfd\xff\xfc\x01\xfd\xfd\xfc\xfc\xfc\xec\xfc\xeb\xfc\xea\xfc\xe9\xfc\xe8\xfc\xe7\xfc\xe6\xfc\xe5\xfc\xe4\xfc\xe3\xfc\xe1\xfc\xe2\xfc\x00\x00\x03\xfd\x04\xfd\x8c\xff\x00\x00\xb1\xff\x00\x00\x00\x00\x8c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xfe\x00\x00\x85\xfe\x83\xfe\x7e\xfe\x7d\xfe\x79\xfe\x7a\xfe\x63\xfe\x62\xfe\x00\x00\x70\xfe\x3d\xfd\x74\xfe\x37\xfd\x2e\xfd\x31\xfd\x2a\xfd\x6f\xfe\x73\xfe\x12\xfd\x0f\xfd\x59\xfe\x4d\xfe\x0d\xfd\x0c\xfd\x0e\xfd\x00\x00\x00\x00\x27\xfd\x26\xfd\x00\x00\x00\x00\x6e\xfe\x25\xfd\x30\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xfd\x2d\xfd\x28\xfd\x29\xfd\x58\xfe\x2f\xfd\x2b\xfd\x2c\xfd\x66\xfd\x5b\xfe\x5a\xfe\x5c\xfe\x00\x00\x06\xfe\x05\xfe\x00\x00\xf1\xff\x55\xfd\x46\xfd\x54\xfd\xef\xff\xf0\xff\x16\xfd\xfa\xfc\xfb\xfc\xf6\xfc\xf3\xfc\x53\xfd\xde\xfc\x42\xfd\xdb\xfc\xd8\xfc\xed\xff\xf5\xfc\xdf\xfc\xe0\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xfc\xf4\xfc\xd9\xfc\xdd\xfc\xf7\xfc\xda\xfc\xc3\xfd\x77\xfd\xff\xfd\xfd\xfd\x00\x00\xf8\xfd\xf0\xfd\xe1\xfd\xde\xfd\xcf\xfd\xce\xfd\x00\x00\x00\x00\x7d\xfd\x7a\xfd\xdb\xfd\xda\xfd\xdc\xfd\xdd\xfd\xd9\xfd\xfe\xfd\xd0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\xfd\xd7\xfc\xd6\xfc\xd8\xfd\xd7\xfd\xcb\xfc\xca\xfc\xd5\xfc\xd4\xfc\xd3\xfc\xd2\xfc\xd1\xfc\xd0\xfc\xcf\xfc\xce\xfc\xcd\xfc\xcc\xfc\xc9\xfc\xc8\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\xfd\x70\xff\x14\xfe\x00\x00\x00\x00\x00\x00\x05\xfd\x6e\xff\x6d\xff\x6c\xff\x00\x00\x00\x00\x0a\xfe\x00\x00\x0a\xfe\x0a\xfe\x00\x00\x63\xfd\x00\x00\x00\x00\x89\xfd\x00\x00\x00\x00\x00\x00\x62\xff\x61\xff\x60\xff\x5f\xff\x05\xff\x00\x00\x5e\xff\x5d\xff\x1f\xfe\x57\xff\x56\xff\x21\xfe\x55\xff\x00\x00\x1c\xff\x00\x00\x3a\xff\x43\xff\x1b\xff\x00\x00\x00\x00\x00\x00\xca\xfe\xb0\xfe\xb9\xfe\x00\x00\x00\x00\x7b\xfd\x00\x00\x86\xff\x00\x00\x00\x00\x00\x00\x8c\xff\xc1\xff\x00\x00\x8c\xff\x00\x00\x89\xff\xbc\xff\xc5\xfc\xc4\xfc\x00\x00\xbc\xff\x84\xff\x00\x00\x00\x00\x58\xfd\x4f\xfd\x59\xfd\x0b\xfd\x51\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xfe\x00\x00\x00\x00\xb1\xfe\x00\x00\x5b\xfd\x00\x00\xcb\xfe\xc8\xfe\x00\x00\x4e\xfd\x00\x00\x00\x00\x00\x00\x5b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x83\xfe\x3d\xfd\x1a\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\xff\x00\x00\x3c\xff\x3e\xff\x3d\xff\x00\x00\x53\xfe\x00\x00\x47\xfe\x00\x00\x0c\xff\x00\x00\x1c\xfd\x00\x00\x1b\xfd\x1d\xfd\x00\x00\x00\x00\x05\xff\x00\x00\x00\x00\xb4\xfd\xff\xfd\x00\x00\x00\x00\x00\x00\x19\xfd\x00\x00\x18\xfd\x1a\xfd\x14\xfd\xf8\xfc\x00\x00\xf9\xfc\x42\xfd\x00\x00\x00\x00\xbe\xfc\xf5\xfc\x00\x00\x4a\xfd\xc2\xfc\x00\x00\x4c\xfd\x97\xfe\x00\x00\x00\x00\x64\xfd\x62\xfd\x60\xfd\x5f\xfd\x5c\xfd\x00\x00\x00\x00\x00\x00\x09\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\xfd\xd2\xfe\x00\x00\xd5\xfe\xd5\xfe\x00\x00\x00\x00\x00\x00\x6f\xff\xca\xfd\x40\xfd\xcb\xfd\x00\x00\x00\x00\x00\x00\xbc\xfd\xdd\xfd\x00\x00\x00\x00\x67\xff\x67\xff\x00\x00\x00\x00\x00\x00\xe3\xfd\x7e\xfd\x7e\xfd\xe4\xfd\xcc\xfd\xcd\xfd\x00\x00\xba\xfd\x00\x00\x00\x00\xf8\xfc\xf9\xfc\x00\x00\x48\xfd\x00\x00\xa8\xfd\x00\x00\xa7\xfd\x45\xfd\xec\xfd\xed\xfd\xee\xfd\xf9\xfd\x86\xfd\x84\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xfd\x79\xfd\x00\x00\x76\xfd\xf6\xfd\x00\x00\xe6\xfd\x8d\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\xfd\xf3\xfd\x00\x00\xb5\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfd\x61\xfe\x57\xfd\x56\xfd\x72\xfe\x71\xfe\x5e\xfe\x1f\xfd\x53\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x52\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x68\xfe\x00\x00\x31\xfd\x00\x00\x00\x00\x6a\xfe\x00\x00\x38\xfd\x00\x00\x00\x00\x2f\xfe\x2d\xfe\x91\xfe\x00\x00\x6c\xfe\x00\x00\x6d\xfe\x8d\xfe\x8e\xfe\x00\x00\x4d\xfe\x4c\xfe\x49\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x78\xfe\x00\x00\x76\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\xfe\x7b\xfe\x00\x00\xe8\xff\x00\x00\x00\x00\xae\xff\x89\xff\xbc\xff\xbc\xff\xad\xff\xa8\xff\x00\x00\xb9\xfe\xa8\xff\xac\xff\xaa\xff\xab\xff\x8d\xff\xec\xff\xc6\xfc\xc7\xfc\xe9\xff\x00\x00\xd5\xff\xdc\xff\xd9\xff\xdb\xff\xda\xff\xdd\xff\xeb\xff\x40\xfe\x89\xfe\x87\xfe\x7f\xfe\x80\xfe\x82\xfe\x00\x00\x77\xfe\x7c\xfe\x75\xfe\x86\xfe\x00\x00\x00\x00\x4e\xfe\x8b\xfe\x8c\xfe\x00\x00\x00\x00\x6b\xfe\x00\x00\x00\x00\x65\xfe\x00\x00\x39\xfd\x3c\xfd\xc3\xfc\x36\xfd\x64\xfe\x00\x00\xbf\xfc\x3a\xfd\x3b\xfd\x66\xfe\x67\xfe\x00\x00\x00\x00\x11\xfd\x30\xfd\x00\x00\x00\x00\x27\xfd\x26\xfd\x6e\xfe\x25\xfd\x28\xfd\x29\xfd\x2c\xfd\x52\xfe\x00\x00\x54\xfe\xee\xff\x49\xfd\x52\xfd\x07\xfd\x47\xfd\x41\xfd\x15\xfd\x00\xfe\x01\xfe\x02\xfe\x03\xfe\x04\xfe\xf2\xfd\x00\x00\x75\xfd\x72\xfd\x6f\xfd\x00\x00\x05\xfd\x71\xfd\xdf\xfd\x06\xfd\x78\xfd\xef\xfd\x00\x00\x00\x00\x00\x00\x94\xfd\x92\xfd\x8e\xfd\x8b\xfd\x00\x00\xf7\xfd\x00\x00\x00\x00\xf5\xfd\xf4\xfd\xe8\xfd\x84\xfd\x00\x00\xe9\xfd\x00\x00\x00\x00\x00\x00\x85\xfd\x00\x00\xd1\xfd\xa6\xfd\x00\x00\x00\x00\x08\xfd\xaa\xfd\xaf\xfd\xd2\xfd\xb0\xfd\xa9\xfd\xae\xfd\xd3\xfd\x00\x00\x00\x00\x7f\xfd\x00\x00\xc8\xfd\xc5\xfd\xc6\xfd\xb5\xfd\xb6\xfd\x00\x00\x00\x00\xc4\xfd\xc7\xfd\x3e\xfd\x00\x00\x3f\xfd\x15\xfe\x21\xfd\x6a\xff\x22\xfd\x44\xfd\x20\xfd\x00\x00\x17\xfe\x93\xfe\x00\x00\x00\x00\x1e\xfe\xd6\xfe\x99\xfe\x1d\xfe\xbf\xfd\xbe\xfd\x00\x00\x68\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xee\xfe\xef\xfe\x11\xfe\x57\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\xc5\xfe\x00\x00\x00\x00\x10\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfd\xc0\xfc\x08\xfd\xb2\xfd\xd5\xfd\xd6\xfd\x00\x00\xd4\xfd\xb3\xfd\x00\x00\x00\x00\x17\xff\x00\x00\x93\xfe\xfc\xfd\xfb\xfd\x00\x00\xfa\xfd\x20\xfe\xce\xfe\x19\xfe\x00\x00\x00\x00\x00\x00\xe3\xfe\x42\xfe\x15\xff\x00\x00\x3f\xff\x95\xfe\x93\xfe\x43\xff\x44\xff\x45\xff\x47\xff\x46\xff\xd9\xfe\x02\xff\x00\x00\x13\xff\x4a\xff\x00\x00\x4d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xa3\xfe\xa2\xfe\xa1\xfe\xa0\xfe\x9f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfe\xf6\xfe\x00\x00\x00\x00\x00\x00\xbf\xfe\xc7\xfe\x00\x00\x58\xff\xcc\xfe\x00\x00\xaf\xfe\xaa\xfe\xae\xfe\x5a\xff\xb2\xfe\xba\xfe\x59\xff\xb9\xfe\x00\x00\x24\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x87\xff\x80\xff\x85\xff\xa8\xff\xb8\xff\xa8\xff\xb7\xff\xb4\xff\x64\xff\xb9\xff\x8b\xff\xb5\xff\xb6\xff\x00\x00\x9c\xff\x00\x00\x82\xff\x81\xff\xa9\xfe\xa7\xfe\x00\x00\x00\x00\xb4\xfe\xb8\xfe\xb3\xfe\x00\x00\xab\xfe\x5a\xfd\xcd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xfb\xfe\xfc\xfe\x00\x00\xf4\xfe\xf5\xfe\xf0\xfe\x00\x00\xf8\xfe\x00\x00\xa5\xfe\x00\x00\x9d\xfe\x9c\xfe\x9e\xfe\x00\x00\xa4\xfe\x4d\xff\x4e\xff\x53\xff\x00\x00\x00\x00\x39\xff\x00\x00\x00\x00\x03\xff\x01\xff\x00\xff\xfd\xfe\xfe\xfe\x4b\xff\x00\x00\x00\x00\x00\x00\x5c\xff\x4f\xff\x00\x00\x46\xfe\x44\xfe\x00\x00\x54\xff\x00\x00\x0d\xff\x00\x00\xce\xfe\x1b\xfe\x1a\xfe\x00\x00\xb4\xfc\x17\xff\x00\x00\x08\xff\x4d\xfe\x3d\xfe\x2b\xfe\x00\x00\x32\xfe\x06\xff\x00\x00\xb1\xfd\xc1\xfd\xad\xfd\xc1\xfc\x17\xfd\x13\xfd\x4b\xfd\x96\xfe\x13\xfe\x61\xfd\x5e\xfd\x50\xfd\x5d\xfd\x0f\xfe\x00\x00\x08\xfe\x00\x00\x00\x00\x0c\xfe\x12\xfe\x4d\xfd\xd1\xfe\x69\xfd\xd4\xfe\xd7\xfe\x00\x00\xd0\xfe\xd3\xfe\x00\x00\x00\x00\xb8\xfd\xb7\xfd\x69\xff\x83\xfd\x80\xfd\x82\xfd\xb9\xfd\xbb\xfd\xc2\xfd\xac\xfd\xab\xfd\xb4\xfd\xa0\xfd\xa2\xfd\x9f\xfd\x9d\xfd\x9a\xfd\x99\xfd\x00\x00\xa4\xfd\xa1\xfd\xeb\xfd\x88\xfd\x00\x00\xb6\xfc\x00\x00\xb1\xfc\xaa\xfc\x00\x00\x00\x00\xb7\xfc\x00\x00\xba\xfc\x00\x00\xb3\xfc\xad\xfc\x84\xfd\x00\x00\xbb\xfc\xe2\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x8c\xfd\xe5\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x5f\xfe\x00\x00\x1e\xfd\x51\xfe\x50\xfe\x4f\xfe\x00\x00\x00\x00\x92\xfe\x2c\xfe\x2e\xfe\x0a\xfd\x00\x00\x4b\xfe\x00\x00\x81\xfe\x00\x00\xd8\xff\xd7\xff\xd6\xff\x00\x00\xea\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\xd4\xff\x00\x00\x00\x00\x5d\xfe\x69\xfe\x00\x00\x73\xfd\x70\xfd\x6d\xfd\x6b\xfd\x8a\xfd\x93\xfd\xf6\xfd\xbd\xfc\xb2\xfc\xae\xfc\xbc\xfc\xa9\xfc\xce\xfe\x8f\xfd\x00\x00\xb9\xfc\xb0\xfc\xab\xfc\xb8\xfc\xa8\xfc\x98\xfd\xe7\xfc\x00\x00\x00\x00\xa5\xfd\x81\xfd\x68\xff\x8e\xff\x6b\xff\x16\xfe\x67\xfd\xd8\xfe\x6a\xfd\x00\x00\x90\xfe\x00\x00\x07\xfe\x00\x00\x07\xff\x38\xfe\x36\xfe\x00\x00\x4d\xfe\x16\xff\x51\xff\x2a\xfe\x28\xfe\x00\x00\x2b\xfe\x00\x00\x00\x00\x00\x00\x3d\xfe\x2b\xfe\xcf\xfe\x1c\xfe\x00\x00\xe4\xfe\xe7\xfe\xe7\xfe\x41\xfe\x42\xfe\x42\xfe\x14\xff\x94\xfe\x04\xff\xda\xfe\xdd\xfe\xdd\xfe\xff\xfe\x11\xff\x12\xff\x34\xff\x00\x00\x29\xff\x00\x00\x00\x00\x00\x00\xa6\xfe\x43\xfd\x00\x00\xf7\xfe\xfa\xfe\x00\x00\x00\x00\xbd\xfe\xbc\xfe\x00\x00\x00\x00\xc4\xfe\xc2\xfe\x00\x00\xad\xfe\x00\x00\xa8\xfe\x23\xfd\x00\x00\x83\xff\x00\x00\x00\x00\xa7\xff\xa2\xff\x00\x00\x00\x00\xb9\xfe\xa4\xff\x00\x00\x66\xff\x63\xff\x8a\xff\x8f\xff\x65\xff\xc2\xff\x8c\xff\x8c\xff\x00\x00\x00\x00\x9b\xff\x93\xff\x90\xff\x35\xfd\x91\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9c\xff\xa9\xff\xc3\xff\x80\xff\xac\xfe\xc3\xfe\x00\x00\x00\x00\xbe\xfe\xc0\xfe\xd5\xfe\xd5\xfe\xf3\xfe\x9a\xfe\x00\x00\x00\x00\x38\xff\x00\x00\x52\xff\x00\x00\xe2\xfe\x21\xff\xde\xfe\x00\x00\xe1\xfe\x19\xff\x18\xff\x21\xff\x00\x00\x45\xfe\x43\xfe\xed\xfe\xe8\xfe\x00\x00\xec\xfe\x23\xff\x00\x00\x00\x00\x00\x00\x18\xfe\x49\xff\x2b\xfe\x09\xff\x00\x00\x3a\xfe\x3a\xfe\x50\xff\x00\x00\x27\xfe\x24\xfe\x40\xff\x42\xff\x41\xff\x00\x00\x29\xfe\x00\x00\x00\x00\x84\xfe\x31\xfe\x34\xfe\x32\xfe\x0d\xfe\x0e\xfe\x00\x00\xa3\xfd\x9c\xfd\x9b\xfd\x9e\xfd\x00\x00\x00\x00\x00\x00\xac\xfc\x90\xfd\x91\xfd\xaf\xfc\x00\x00\x00\x00\x00\x00\x60\xfe\x4a\xfe\x48\xfe\x00\x00\xc8\xff\x86\xff\x00\x00\x00\x00\x00\x00\xb2\xff\x8c\xff\x8c\xff\xbd\xff\xb3\xff\xaf\xff\xb0\xff\xcc\xff\xc9\xff\xd3\xff\xe6\xff\xe1\xfc\xbc\xff\x00\x00\xcb\xff\x6c\xfd\x6e\xfd\x00\x00\x97\xfd\x96\xfd\x00\x00\x8f\xfe\x37\xfe\x00\x00\x33\xfe\x56\xfe\x00\x00\x23\xfe\x25\xfe\x26\xfe\x00\x00\x3b\xfe\x00\x00\x00\x00\x00\x00\x0a\xff\x48\xff\xe6\xfe\xe9\xfe\x25\xff\x10\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\xff\xe5\xfe\xdc\xfe\xdf\xfe\x00\x00\x20\xff\xdb\xfe\x05\xff\x33\xff\x2b\xff\x2b\xff\x00\x00\x00\x00\x9b\xfe\x00\x00\x00\x00\xbd\xfe\x00\x00\xc9\xfe\x7e\xff\xa3\xff\x00\x00\x00\x00\x00\x00\x9f\xff\x92\xff\xa0\xff\xa1\xff\x99\xff\x9e\xff\x00\x00\x00\x00\x00\x00\xbb\xff\xba\xff\x9d\xff\x00\x00\x98\xff\x96\xff\x95\xff\x94\xff\x34\xfd\x33\xfd\x32\xfd\x7c\xff\x00\x00\x00\x00\x00\x00\xf2\xfe\xf1\xfe\x2a\xff\x37\xff\x35\xff\x00\x00\x2c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x1f\xff\xe0\xfe\x15\xff\x00\x00\x10\xff\x24\xff\x27\xff\x00\x00\x00\x00\xea\xfe\x00\x00\x3f\xfe\x00\x00\x3a\xfe\x3e\xfe\x22\xfe\x00\x00\x31\xfe\x35\xfe\x00\x00\xe7\xfd\xbc\xff\xa8\xff\xc4\xff\x00\x00\xc5\xff\x00\x00\xca\xff\x00\x00\xcf\xff\xcd\xff\x00\x00\xe2\xff\x00\x00\x00\x00\xa8\xff\x95\xfd\x55\xfe\x3c\xfe\x00\x00\x0b\xff\x00\x00\x6f\xfe\x00\x00\x0f\xff\x26\xff\x00\x00\xeb\xfe\x28\xff\x17\xff\x30\xff\x32\xff\x2d\xff\x2f\xff\x31\xff\x36\xff\xc1\xfe\xbb\xfe\x7f\xff\x88\xff\x7d\xff\x00\x00\x78\xff\x00\x00\x9a\xff\x97\xff\x9b\xff\x00\x00\x79\xff\x74\xff\x00\x00\x00\x00\x76\xff\x78\xff\x2e\xff\x3d\xfe\x2b\xfe\x6f\xfe\x00\x00\x39\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xff\xe3\xff\x00\x00\xd2\xff\xd0\xff\xd1\xff\xce\xff\xe4\xff\x00\x00\x00\x00\xe1\xff\x00\x00\xc6\xff\x00\x00\x0e\xff\x1e\xff\x2b\xfe\x00\x00\x71\xff\x72\xff\x77\xff\x7b\xff\x73\xff\x75\xff\x7a\xff\x1d\xff\xc7\xff\x00\x00\x00\x00\xe0\xff\xde\xff\xdf\xff"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x66\x00\x4d\x00\x06\x00\x4d\x00\x3b\x00\x4e\x00\x04\x00\x49\x00\x67\x00\x07\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x01\x00\x0e\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x29\x00\x2a\x00\x08\x00\x09\x00\x8b\x00\x0b\x00\x08\x00\x09\x00\x09\x00\x0b\x00\x0b\x00\x56\x00\x67\x00\x58\x00\x37\x00\x38\x00\x39\x00\x90\x00\x8a\x00\x8b\x00\x7e\x00\x7f\x00\x00\x00\x00\x00\x68\x00\xd8\x00\x65\x00\x68\x00\x3d\x00\x3e\x00\x59\x00\x6a\x00\xba\x00\x4b\x00\x7e\x00\x7f\x00\xe6\x00\x70\x00\x71\x00\x12\x00\x9e\x00\xa6\x00\x18\x00\x0c\x00\x3d\x00\x3e\x00\x00\x00\x0c\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xb4\x00\xb5\x00\xb6\x00\x7e\x00\x7f\x00\x59\x00\x77\x00\x28\x00\x29\x00\x2a\x00\x4c\x00\x3c\x00\x3d\x00\x09\x00\x59\x00\x10\x01\x11\x01\x49\x00\x71\x00\x33\x00\x29\x00\x2a\x00\x50\x00\x4b\x00\xc3\x00\x8b\x00\x52\x00\x10\x00\x74\x00\x1e\x01\x29\x00\x2a\x00\x33\x00\x09\x01\x37\x00\x38\x00\x39\x00\xd0\x00\x48\x00\x00\x00\x29\x01\x81\x00\x29\x00\x2a\x00\x21\x00\x50\x00\x39\x00\xba\x00\x90\x00\x50\x00\x48\x00\x6d\x00\x76\x00\x00\x00\x48\x00\x90\x00\x74\x00\x30\x01\x6b\x00\xbb\x00\xbc\x00\x71\x00\x32\x01\xaf\x00\xc0\x00\x10\x01\x11\x01\xc3\x00\x64\x00\xc5\x00\x2e\x01\xc7\x00\x67\x00\x67\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbf\x00\xcf\x00\xd0\x00\xd1\x00\x70\x00\x3c\x00\x12\x00\x04\x01\x05\x01\x00\x00\x07\x01\x08\x01\x70\x00\xaf\x00\xb5\x00\xb6\x00\x70\x00\x81\x00\x67\x00\x0c\x01\x0d\x01\x1f\x01\xaf\x00\x10\x01\x11\x01\x23\x01\x4a\x00\x70\x00\x1c\x01\x1f\x01\x1e\x01\x29\x01\x6a\x00\x23\x01\x50\x00\x1c\x01\x1f\x01\x1e\x01\x23\x01\x29\x01\x23\x01\x29\x01\xf8\x00\xf9\x00\x29\x01\x23\x01\x29\x01\x2c\x01\x29\x01\xd5\x00\x0b\x00\x29\x01\x02\x01\x03\x01\x23\x01\x10\x01\x11\x01\x07\x01\x08\x01\x1e\x01\x29\x01\x1e\x01\x1e\x01\x00\x00\x67\x00\xd5\x00\x72\x00\x71\x00\x23\x01\x23\x01\x29\x01\x77\x00\x29\x01\x29\x01\x29\x01\x29\x01\x1f\x01\x4b\x00\x67\x00\x1f\x01\x23\x01\x1f\x01\x20\x01\x23\x01\x22\x01\x23\x01\x29\x01\x70\x00\x64\x00\x29\x01\x23\x01\x29\x01\x64\x00\x2b\x01\x2c\x01\x1f\x01\x29\x01\x2f\x01\x0e\x01\x23\x01\x10\x01\x11\x01\x02\x01\x03\x01\x68\x00\x29\x01\x48\x00\x07\x01\x08\x01\x00\x00\x0a\x01\x01\x00\x67\x00\x1f\x01\x00\x00\x71\x00\x20\x01\x23\x01\x22\x01\x23\x01\x1f\x01\x70\x00\x9e\x00\x29\x01\x23\x01\x29\x01\x1a\x01\xa5\x00\xa6\x00\x81\x00\x29\x01\x15\x00\x20\x01\x00\x00\x22\x01\x23\x01\x24\x01\x31\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x31\x01\x29\x01\x0e\x01\x31\x01\x10\x01\x11\x01\x32\x00\x29\x01\x31\x01\x4b\x00\x50\x00\x61\x00\x0e\x01\x29\x01\x10\x01\x11\x01\x81\x00\x29\x01\x29\x01\x67\x00\x20\x01\x6b\x00\x22\x01\x23\x01\x0e\x01\x6b\x00\x10\x01\x11\x01\x70\x00\x29\x01\x20\x01\x9e\x00\x22\x01\x23\x01\x0e\x01\x00\x00\x10\x01\x11\x01\x61\x00\x29\x01\x00\x00\x64\x00\x20\x01\x71\x00\x22\x01\x23\x01\x0e\x01\x71\x00\x10\x01\x11\x01\x3b\x00\x29\x01\x20\x01\x5d\x00\x22\x01\x23\x01\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x29\x01\x47\x00\x09\x01\x20\x01\x67\x00\x22\x01\x23\x01\xc3\x00\xa4\x00\xa5\x00\xa6\x00\x1e\x00\x29\x01\x70\x00\x15\x01\x16\x01\x57\x00\x57\x00\x58\x00\x9e\x00\xd0\x00\x69\x00\xa4\x00\xa5\x00\xa6\x00\x2c\x00\x60\x00\x61\x00\x67\x00\x4b\x00\x4a\x00\x65\x00\x27\x01\x28\x01\xd8\x00\x2a\x01\x6a\x00\x70\x00\x1c\x01\x2e\x01\x1e\x01\x19\x00\xa4\x00\xa5\x00\xa6\x00\x92\x00\x82\x00\x76\x00\x49\x00\x96\x00\x97\x00\x29\x01\x99\x00\x9a\x00\x9b\x00\x50\x00\x9d\x00\x9e\x00\x55\x00\x82\x00\x2c\x00\x3c\x00\x3d\x00\x6b\x00\x3b\x00\x87\x00\x83\x00\x84\x00\x50\x00\x71\x00\x48\x00\x42\x00\x43\x00\x44\x00\x45\x00\x77\x00\x47\x00\x67\x00\x48\x00\x7b\x00\x0c\x01\x0d\x01\x67\x00\x48\x00\x10\x01\x11\x01\x70\x00\x4b\x00\x71\x00\x65\x00\x14\x00\x70\x00\x57\x00\x58\x00\xc3\x00\x4b\x00\x1c\x01\x1b\x00\x1e\x01\x1d\x00\x57\x00\x60\x00\x61\x00\xa4\x00\xa5\x00\xa6\x00\x65\x00\xd0\x00\x6b\x00\x29\x01\x70\x00\x6a\x00\x68\x00\x65\x00\x71\x00\x02\x01\x03\x01\xbb\x00\x70\x00\x50\x00\x07\x01\x08\x01\xc0\x00\x70\x00\x32\x01\xc3\x00\x34\x01\xc5\x00\x1c\x01\xc7\x00\x1e\x01\x76\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x50\x00\x81\x00\xd0\x00\xd1\x00\x87\x00\x29\x01\x1c\x01\x82\x00\x1e\x01\x20\x01\x6b\x00\x22\x01\x23\x01\xad\x00\xae\x00\x48\x00\x71\x00\x13\x00\x29\x01\x29\x01\x2b\x01\x2c\x01\xa4\x00\xa5\x00\xa6\x00\x19\x00\x1c\x01\x1e\x00\x1e\x01\x6d\x00\x4c\x00\x0c\x01\x0d\x01\x71\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x29\x01\xc8\x00\x2c\x00\xf8\x00\xf9\x00\x2c\x00\x2f\x00\x30\x00\x1c\x01\x1d\x01\x1e\x01\x50\x00\x61\x00\x02\x01\x03\x01\xff\x00\x00\x01\xbb\x00\x07\x01\x08\x01\x04\x01\x29\x01\xc0\x00\x07\x01\x08\x01\xc3\x00\x84\x00\xc5\x00\x52\x00\xc7\x00\x12\x00\xf5\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x3c\x00\x3d\x00\xd0\x00\xd1\x00\x6d\x00\x5f\x00\x1f\x01\x20\x01\x71\x00\x22\x01\x23\x01\x1f\x01\x1c\x01\x48\x00\x1e\x01\x23\x01\x29\x01\x56\x00\x2b\x01\x2c\x01\x59\x00\x29\x01\x2f\x01\x9e\x00\x2c\x01\x29\x01\x3b\x00\x33\x00\x34\x00\x6a\x00\x0b\x00\x1a\x00\x4a\x00\x42\x00\x43\x00\x44\x00\x45\x00\x19\x00\x47\x00\x21\x01\x75\x00\x23\x01\xf8\x00\xf9\x00\x79\x00\x3b\x00\x1b\x00\x29\x01\x6a\x00\x76\x00\x2d\x00\x2e\x00\x02\x01\x03\x01\x57\x00\x58\x00\x2c\x00\x07\x01\x08\x01\x75\x00\xf2\x00\xf3\x00\xf4\x00\x60\x00\x61\x00\x6b\x00\x1f\x01\x1c\x01\x65\x00\x1e\x01\x23\x01\x71\x00\x56\x00\x6a\x00\x58\x00\x6a\x00\x29\x01\x77\x00\xf3\x00\xf4\x00\x29\x01\x1f\x01\x20\x01\x4a\x00\x22\x01\x23\x01\x75\x00\x65\x00\x69\x00\x4a\x00\x79\x00\x29\x01\x6a\x00\x2b\x01\x2c\x01\x56\x00\x71\x00\x2f\x01\x70\x00\x71\x00\x11\x01\x56\x00\x87\x00\x14\x01\x5f\x00\x5a\x00\x20\x01\x21\x01\x22\x01\x23\x01\x5f\x00\xff\x00\x00\x01\xff\x00\x00\x01\x29\x01\x04\x01\x19\x00\x04\x01\x07\x01\x08\x01\x07\x01\x08\x01\x20\x01\x21\x01\x22\x01\x23\x01\x76\x00\x77\x00\x72\x00\xad\x00\xae\x00\x29\x01\x76\x00\x77\x00\x56\x00\x2c\x00\x7a\x00\x7b\x00\x5a\x00\x69\x00\xad\x00\xae\x00\x1f\x01\x5f\x00\x1f\x01\x1f\x00\x23\x01\x71\x00\x23\x01\x12\x01\x13\x01\x69\x00\x29\x01\xbb\x00\x29\x01\x2c\x01\xc8\x00\x2c\x01\xc0\x00\x2d\x00\x2e\x00\xc3\x00\x3b\x00\xc5\x00\x96\x00\xc7\x00\x76\x00\xc8\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbb\x00\xbc\x00\xd0\x00\xd1\x00\x51\x00\xc0\x00\x69\x00\x51\x00\xc3\x00\x32\x01\xc5\x00\x8c\x00\xc7\x00\x1e\x00\x71\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x75\x00\xcf\x00\xd0\x00\xd1\x00\x79\x00\x02\x01\x03\x01\x9e\x00\x2c\x00\x06\x01\x07\x01\x08\x01\x1e\x00\x65\x00\x6a\x00\x4a\x00\x04\x01\x05\x01\x6a\x00\x07\x01\x08\x01\x13\x00\x54\x00\xf8\x00\xf9\x00\x75\x00\x2c\x00\x56\x00\x74\x00\x79\x00\x65\x00\x5a\x00\x4c\x00\x02\x01\x03\x01\x82\x00\x5f\x00\x51\x00\x07\x01\x08\x01\x71\x00\x70\x00\xf8\x00\xf9\x00\x65\x00\x3b\x00\x2b\x01\x2c\x01\x6b\x00\x2f\x00\x30\x00\x31\x00\x02\x01\x03\x01\x71\x00\x70\x00\x2c\x01\x07\x01\x08\x01\x76\x00\x77\x00\x9e\x00\x1f\x01\x20\x01\x6b\x00\x22\x01\x23\x01\x68\x00\x65\x00\x6a\x00\x71\x00\x6c\x00\x29\x01\x2f\x00\x2b\x01\x2c\x01\x9e\x00\x65\x00\x2f\x01\x70\x00\x75\x00\x1f\x01\x20\x01\x71\x00\x22\x01\x23\x01\x42\x00\x65\x00\x70\x00\x3f\x00\x40\x00\x29\x01\x6a\x00\x2b\x01\x2c\x01\x65\x00\x64\x00\x2f\x01\x66\x00\xbb\x00\xbc\x00\x6d\x00\x74\x00\x10\x00\xc0\x00\x71\x00\x70\x00\xc3\x00\x10\x00\xc5\x00\x1c\x01\xc7\x00\x1e\x01\x6a\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x0a\x01\xcf\x00\xd0\x00\xd1\x00\x81\x00\x29\x01\x02\x01\x03\x01\x65\x00\x9e\x00\x06\x01\x07\x01\x08\x01\x17\x01\x0d\x01\x19\x01\x1a\x01\x10\x01\x11\x01\x70\x00\x1c\x01\x68\x00\x1e\x01\x6a\x00\x46\x00\x6c\x00\x24\x01\x75\x00\x26\x01\x27\x01\x28\x01\x79\x00\x2a\x01\x29\x01\x75\x00\x2d\x01\x2e\x01\x1c\x01\x79\x00\x1e\x01\xf6\x00\xf7\x00\xf8\x00\xf9\x00\x13\x00\x14\x00\xc3\x00\x2b\x01\x2c\x01\x18\x00\x29\x01\x65\x00\x02\x01\x03\x01\x3b\x00\xbb\x00\xbc\x00\x07\x01\x08\x01\xd0\x00\xc0\x00\x9e\x00\x70\x00\xc3\x00\x64\x00\xc5\x00\x66\x00\xc7\x00\x65\x00\x65\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x39\x00\xcf\x00\xd0\x00\xd1\x00\x53\x00\x70\x00\x70\x00\x1f\x01\x20\x01\x23\x01\x22\x01\x23\x01\x56\x00\x1e\x01\x9e\x00\x29\x01\x5a\x00\x29\x01\x2c\x01\x2b\x01\x2c\x01\x5f\x00\x65\x00\x2f\x01\x29\x01\x65\x00\x92\x00\x6a\x00\x4c\x00\x6c\x00\x6d\x00\x97\x00\x50\x00\x99\x00\x9a\x00\x9b\x00\x1e\x00\x9d\x00\x9e\x00\x70\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\x76\x00\x0c\x01\x0d\x01\x6d\x00\x7a\x00\x10\x01\x11\x01\x71\x00\x02\x01\x03\x01\x3b\x00\x48\x00\x6b\x00\x07\x01\x08\x01\x00\x00\x81\x00\x1c\x01\x71\x00\x1e\x01\x02\x01\x03\x01\x07\x00\x1f\x01\x6d\x00\x07\x01\x08\x01\x23\x01\x71\x00\x6b\x00\x29\x01\xc3\x00\x71\x00\x29\x01\x53\x00\x71\x00\x6b\x00\x1f\x01\x20\x01\x18\x00\x22\x01\x23\x01\x71\x00\x21\x01\xd0\x00\x23\x01\x64\x00\x29\x01\x66\x00\x2b\x01\x2c\x01\x29\x01\x65\x00\x2f\x01\x68\x00\x4b\x00\x6a\x00\x6a\x00\x6c\x00\x6c\x00\x6d\x00\x2b\x01\x2c\x01\x4c\x00\xbb\x00\xbc\x00\x4c\x00\x75\x00\x48\x00\xc0\x00\x50\x00\x79\x00\xc3\x00\x48\x00\xc5\x00\x21\x01\xc7\x00\x23\x01\x48\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x29\x01\xcf\x00\xd0\x00\xd1\x00\x02\x01\x03\x01\x48\x00\x4b\x00\x4c\x00\x07\x01\x08\x01\x23\x01\x50\x00\x10\x00\x52\x00\x53\x00\x64\x00\x29\x01\x66\x00\x2b\x01\x2c\x01\x0c\x01\x0d\x01\x50\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x27\x01\x28\x01\x63\x00\x2a\x01\x65\x00\x42\x00\x67\x00\x2e\x01\x1c\x01\x1d\x01\x1e\x01\x32\x01\x23\x01\xf8\x00\xf9\x00\x70\x00\x2b\x01\x2c\x01\x29\x01\x23\x01\x64\x00\x29\x01\x66\x00\x02\x01\x03\x01\x29\x01\xbb\x00\xbc\x00\x07\x01\x08\x01\x3b\x00\xc0\x00\x55\x00\x50\x00\xc3\x00\x52\x00\xc5\x00\x21\x01\xc7\x00\x23\x01\x81\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x29\x01\xcf\x00\xd0\x00\xd1\x00\x64\x00\x75\x00\x66\x00\x1f\x01\x20\x01\x79\x00\x22\x01\x23\x01\x56\x00\x64\x00\x58\x00\x66\x00\x9e\x00\x29\x01\x52\x00\x2b\x01\x2c\x01\x04\x01\x05\x01\x2f\x01\x07\x01\x08\x01\x6b\x00\x65\x00\x49\x00\x4a\x00\x4b\x00\x20\x01\x6a\x00\x22\x01\x23\x01\x50\x00\x6b\x00\x52\x00\x70\x00\x6b\x00\x29\x01\x56\x00\xf8\x00\xf9\x00\x6b\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x71\x00\x02\x01\x03\x01\x6b\x00\x4a\x00\x65\x00\x07\x01\x08\x01\x3b\x00\x69\x00\x2c\x01\x6b\x00\x20\x01\x6d\x00\x22\x01\x23\x01\x56\x00\x71\x00\x72\x00\x4b\x00\x5a\x00\x29\x01\x76\x00\x77\x00\x48\x00\x5f\x00\x7a\x00\x7b\x00\x51\x00\x52\x00\x1f\x01\x20\x01\x53\x00\x22\x01\x23\x01\x04\x01\x05\x01\x2e\x01\x07\x01\x08\x01\x29\x01\x32\x01\x2b\x01\x2c\x01\x72\x00\x50\x00\x2f\x01\x4a\x00\x76\x00\x77\x00\x65\x00\x71\x00\x7a\x00\x7b\x00\x48\x00\x6a\x00\x21\x01\x6c\x00\x23\x01\x56\x00\x2d\x01\x2e\x01\xbb\x00\xbc\x00\x29\x01\x32\x01\x71\x00\xc0\x00\x5f\x00\x4a\x00\xc3\x00\x4c\x00\xc5\x00\x0c\x00\xc7\x00\x2c\x01\x69\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x56\x00\xcf\x00\xd0\x00\xd1\x00\x5a\x00\x43\x00\x44\x00\x45\x00\x46\x00\x5f\x00\x76\x00\x77\x00\x92\x00\x98\x00\x7a\x00\x7b\x00\x64\x00\x97\x00\x66\x00\x99\x00\x9a\x00\x9b\x00\x0d\x01\x9d\x00\x9e\x00\x10\x01\x11\x01\x68\x00\x72\x00\x6a\x00\x96\x00\x6c\x00\x76\x00\x77\x00\x51\x00\x52\x00\x7a\x00\x7b\x00\x4b\x00\x4c\x00\x75\x00\x3b\x00\xf8\x00\xf9\x00\x79\x00\x96\x00\x68\x00\x64\x00\x6a\x00\x66\x00\x6c\x00\x6b\x00\x02\x01\x03\x01\x70\x00\xbb\x00\xbc\x00\x07\x01\x08\x01\x75\x00\xc0\x00\xc3\x00\x64\x00\xc3\x00\x66\x00\xc5\x00\x64\x00\xc7\x00\x66\x00\x96\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xd0\x00\xcf\x00\xd0\x00\xd1\x00\x4b\x00\x4c\x00\x4a\x00\x1f\x01\x20\x01\x65\x00\x22\x01\x23\x01\x0d\x01\x6d\x00\x6a\x00\x10\x01\x11\x01\x29\x01\x56\x00\x2b\x01\x2c\x01\x69\x00\x5a\x00\x2f\x01\x74\x00\x92\x00\x20\x01\x5f\x00\x22\x01\x23\x01\x97\x00\x71\x00\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\x64\x00\x6b\x00\x66\x00\x3b\x00\xf8\x00\xf9\x00\x52\x00\x71\x00\x21\x00\x22\x00\x23\x00\x24\x00\x76\x00\x77\x00\x02\x01\x03\x01\x7a\x00\x7b\x00\x48\x00\x07\x01\x08\x01\x48\x00\x0c\x01\x0d\x01\x52\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x27\x01\x28\x01\x20\x01\x2a\x01\x22\x01\x23\x01\xc3\x00\x52\x00\x1c\x01\x1d\x01\x1e\x01\x29\x01\x0c\x00\x1f\x01\x20\x01\x65\x00\x22\x01\x23\x01\x70\x00\xd0\x00\x6a\x00\x29\x01\x7a\x00\x29\x01\x7c\x00\x2b\x01\x2c\x01\xbb\x00\xbc\x00\x2f\x01\x74\x00\x9e\x00\xc0\x00\x50\x00\x64\x00\xc3\x00\x66\x00\xc5\x00\x14\x00\xc7\x00\x9e\x00\x09\x01\xca\x00\xcb\x00\xcc\x00\xcd\x00\x72\x00\xcf\x00\xd0\x00\xd1\x00\x22\x01\x23\x01\x72\x00\x15\x01\x16\x01\x4b\x00\x4c\x00\x29\x01\x92\x00\x2b\x01\x2c\x01\x6b\x00\x64\x00\x97\x00\x66\x00\x99\x00\x9a\x00\x9b\x00\xc3\x00\x9d\x00\x9e\x00\x27\x01\x28\x01\x64\x00\x2a\x01\x66\x00\x6b\x00\xc3\x00\x2e\x01\x0c\x01\x0d\x01\xd0\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x3b\x00\xf8\x00\xf9\x00\xd0\x00\x20\x01\x6b\x00\x22\x01\x23\x01\x1c\x01\x1d\x01\x1e\x01\x02\x01\x03\x01\x29\x01\xbb\x00\xbc\x00\x07\x01\x08\x01\x3b\x00\xc0\x00\xc3\x00\x29\x01\xc3\x00\x64\x00\xc5\x00\x66\x00\xc7\x00\x3c\x00\x3d\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xd0\x00\xcf\x00\xd0\x00\xd1\x00\x80\x00\x81\x00\x82\x00\x1f\x01\x20\x01\x65\x00\x22\x01\x23\x01\x6d\x00\x64\x00\x6a\x00\x66\x00\x32\x01\x29\x01\x34\x01\x2b\x01\x2c\x01\x0c\x01\x0d\x01\x2f\x01\x72\x00\x10\x01\x11\x01\xbd\x00\xbe\x00\xbf\x00\x0c\x01\x0d\x01\x6a\x00\x72\x00\x10\x01\x11\x01\xe4\x00\x1c\x01\xe6\x00\x1e\x01\x4b\x00\x4c\x00\xf8\x00\xf9\x00\x6d\x00\x80\x00\x1c\x01\x82\x00\x1e\x01\x6b\x00\x29\x01\x65\x00\x02\x01\x03\x01\xa8\x00\xa9\x00\xaa\x00\x07\x01\x08\x01\x29\x01\x0c\x01\x0d\x01\x71\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x52\x00\x0b\x01\x0c\x01\x0d\x01\x4b\x00\x4c\x00\x10\x01\x11\x01\x1c\x01\x1d\x01\x1e\x01\x3c\x00\x3d\x00\x1f\x01\x20\x01\x52\x00\x22\x01\x23\x01\x1c\x01\x70\x00\x1e\x01\x29\x01\x6a\x00\x29\x01\x0c\x00\x2b\x01\x2c\x01\xbb\x00\xbc\x00\x2f\x01\x6a\x00\x29\x01\xc0\x00\x4b\x00\x4c\x00\xc3\x00\x0b\x00\xc5\x00\x32\x00\xc7\x00\x02\x00\x03\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x18\x00\xcf\x00\xd0\x00\xd1\x00\xc0\x00\x02\x00\x03\x00\xc3\x00\x6b\x00\xc5\x00\x4b\x00\xc7\x00\x75\x00\x76\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x71\x00\xd0\x00\xd1\x00\x9e\x00\x97\x00\x72\x00\x99\x00\x9a\x00\x9b\x00\x6b\x00\x9d\x00\x9e\x00\x6b\x00\xff\x00\x00\x01\x62\x00\x63\x00\x64\x00\x04\x01\x22\x01\x23\x01\x07\x01\x08\x01\xf8\x00\xf9\x00\x6b\x00\x29\x01\x6b\x00\x2b\x01\x2c\x01\x52\x00\x75\x00\x76\x00\x02\x01\x03\x01\xb7\x00\xb8\x00\xb9\x00\x07\x01\x08\x01\xc3\x00\xf8\x00\xf9\x00\xc1\x00\xc2\x00\x1f\x01\x4a\x00\x4b\x00\xc3\x00\x23\x01\x6b\x00\x02\x01\x03\x01\xd0\x00\x71\x00\x29\x01\x07\x01\x08\x01\x2c\x01\xc1\x00\xc2\x00\xd0\x00\x1f\x01\x20\x01\x69\x00\x22\x01\x23\x01\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x29\x01\x6b\x00\x2b\x01\x2c\x01\x52\x00\x6b\x00\x2f\x01\x65\x00\x1f\x01\x20\x01\x71\x00\x22\x01\x23\x01\x26\x01\x27\x01\x28\x01\x4c\x00\x2a\x01\x29\x01\x52\x00\x2b\x01\x2c\x01\x92\x00\x61\x00\x2f\x01\xc1\x00\xc2\x00\x97\x00\x61\x00\x99\x00\x9a\x00\x9b\x00\x71\x00\x9d\x00\x9e\x00\x16\x00\x26\x01\x27\x01\x28\x01\x52\x00\x2a\x01\x0c\x01\x0d\x01\x2d\x01\x2e\x01\x10\x01\x11\x01\x71\x00\x32\x01\x0c\x01\x0d\x01\x50\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x1c\x01\x71\x00\x1e\x01\xe2\x00\xe3\x00\xe4\x00\x65\x00\xe6\x00\x1c\x01\x1d\x01\x1e\x01\x92\x00\x48\x00\x29\x01\xc3\x00\x6b\x00\x97\x00\x48\x00\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\xe2\x00\xe3\x00\xe4\x00\xd0\x00\xe6\x00\x4b\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\x82\x00\x00\x01\x26\x01\x27\x01\x28\x01\x04\x01\x2a\x01\x69\x00\x07\x01\x08\x01\x78\x00\x79\x00\x92\x00\xb0\x00\xb1\x00\xb2\x00\x4b\x00\x97\x00\x48\x00\x99\x00\x9a\x00\x9b\x00\x6b\x00\x9d\x00\x9e\x00\x6b\x00\xc3\x00\x5d\x00\x0b\x01\x0c\x01\x0d\x01\x48\x00\x1f\x01\x10\x01\x11\x01\x72\x00\x23\x01\x12\x01\x13\x01\xd0\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x72\x00\x2c\x01\x50\x00\x2e\x01\xb7\x00\xb8\x00\xb9\x00\x32\x01\x71\x00\x0c\x01\x0d\x01\x18\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xc3\x00\xb7\x00\xb8\x00\xb9\x00\x4a\x00\xb7\x00\xb8\x00\xb9\x00\x1c\x01\x1d\x01\x1e\x01\x33\x01\x34\x01\xd0\x00\x75\x00\x76\x00\x56\x00\x10\x00\x11\x00\x92\x00\x5a\x00\x29\x01\x4b\x00\x96\x00\x97\x00\x5f\x00\x99\x00\x9a\x00\x9b\x00\x6b\x00\x9d\x00\x9e\x00\xb7\x00\xb8\x00\xb9\x00\x4b\x00\x5e\x00\x18\x00\x0c\x01\x0d\x01\x4c\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xf7\x00\xf8\x00\x76\x00\x77\x00\x10\x00\x11\x00\x7a\x00\x7b\x00\x1c\x01\x1d\x01\x1e\x01\xb7\x00\xb8\x00\xb9\x00\xa9\x00\xaa\x00\x75\x00\x5e\x00\x23\x00\x24\x00\x81\x00\x29\x01\xc3\x00\xb1\x00\xb2\x00\x35\x00\x36\x00\x0c\x01\x0d\x01\x81\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\x48\x00\x48\x00\x15\x00\x6a\x00\x0b\x00\x70\x00\x92\x00\x1c\x01\x1d\x01\x1e\x01\x96\x00\x97\x00\x18\x00\x99\x00\x9a\x00\x9b\x00\xc3\x00\x9d\x00\x9e\x00\x18\x00\x29\x01\x81\x00\x6b\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x4a\x00\x48\x00\xd0\x00\xd1\x00\x69\x00\x18\x00\x92\x00\x65\x00\x52\x00\x71\x00\x96\x00\x97\x00\x56\x00\x99\x00\x9a\x00\x9b\x00\x5a\x00\x9d\x00\x9e\x00\x72\x00\x4b\x00\x5f\x00\x4b\x00\x5f\x00\x4b\x00\x4b\x00\x50\x00\x71\x00\xc3\x00\x4c\x00\x18\x00\x18\x00\x0c\x01\x0d\x01\x07\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x72\x00\xd0\x00\xf8\x00\xf9\x00\x76\x00\x77\x00\x19\x00\x55\x00\x1c\x01\x1d\x01\x1e\x01\x48\x00\x02\x01\x03\x01\x50\x00\xc3\x00\x69\x00\x07\x01\x08\x01\x7e\x00\x65\x00\x29\x01\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xd0\x00\x99\x00\x9a\x00\x9b\x00\x70\x00\x9d\x00\x9e\x00\x70\x00\x70\x00\x65\x00\xa2\x00\xa3\x00\x50\x00\x18\x00\x20\x01\x69\x00\x22\x01\x23\x01\x48\x00\x6b\x00\x18\x00\x48\x00\x6b\x00\x29\x01\x65\x00\x2b\x01\x2c\x01\x6b\x00\x70\x00\x2f\x01\x18\x00\x50\x00\x4c\x00\x0c\x01\x0d\x01\x2b\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x70\x00\x48\x00\xc3\x00\x71\x00\x48\x00\x50\x00\x07\x00\x18\x00\x1c\x01\x1d\x01\x1e\x01\x5f\x00\x07\x00\x18\x00\x4b\x00\xd0\x00\x5f\x00\x71\x00\x69\x00\x0c\x01\x0d\x01\x29\x01\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x6b\x00\x81\x00\x0c\x00\x48\x00\x70\x00\x6a\x00\x15\x00\x70\x00\x1c\x01\x1d\x01\x1e\x01\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4b\x00\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\x4c\x00\x52\x00\x10\x00\x21\x00\xf8\x00\x07\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x31\x00\x99\x00\x9a\x00\x9b\x00\x5f\x00\x9d\x00\x9e\x00\x55\x00\x55\x00\x19\x00\x08\x00\x6a\x00\x0c\x01\x0d\x01\x39\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x68\x00\x2c\x00\x6b\x00\x71\x00\xc3\x00\x70\x00\x4a\x00\x42\x00\x1c\x01\x1d\x01\x1e\x01\x65\x00\x00\x01\x55\x00\x52\x00\x02\x00\x04\x01\xd0\x00\x56\x00\x07\x01\x08\x01\x29\x01\x5a\x00\xc3\x00\x6b\x00\x6b\x00\x92\x00\x5f\x00\x6b\x00\x6a\x00\x32\x01\x97\x00\x34\x01\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\x6b\x00\x48\x00\x65\x00\x6b\x00\x1f\x01\x5f\x00\x71\x00\x71\x00\x23\x01\x65\x00\x6b\x00\x76\x00\x77\x00\x4b\x00\x29\x01\x7a\x00\x7b\x00\x2c\x01\xf8\x00\x4b\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x02\x00\x99\x00\x9a\x00\x9b\x00\x18\x00\x9d\x00\x9e\x00\x50\x00\x6a\x00\x71\x00\xc3\x00\xf8\x00\x0c\x01\x0d\x01\x6a\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x6a\x00\x18\x00\x6b\x00\xd0\x00\x07\x00\x18\x00\x4a\x00\x76\x00\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\x07\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xc3\x00\x6b\x00\x2d\x01\x2e\x01\x1c\x01\x1d\x01\x1e\x01\x32\x01\x01\x01\x76\x00\x03\x01\x12\x00\x2f\x00\xd0\x00\x07\x01\x31\x01\x31\x01\x29\x01\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xd4\x00\x00\x01\x98\x00\x32\x01\xec\x00\x04\x01\x32\x01\x3a\x00\x07\x01\x08\x01\xec\x00\x5f\x00\xec\x00\x48\x00\x88\x00\x1f\x01\x30\x00\x0c\x01\x0d\x01\x23\x01\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x29\x01\x31\x01\x2b\x01\x2c\x01\x31\x01\xf8\x00\x16\x00\x1f\x01\x1c\x01\x1d\x01\x1e\x01\x23\x01\x30\x01\x16\x00\x31\x00\x85\x00\x89\x00\x29\x01\x89\x00\x98\x00\x2c\x01\x29\x01\xa7\x00\x5f\x00\x8d\x00\x0c\x01\x0d\x01\x7b\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x36\x01\x35\x01\xc8\x00\x30\x01\x16\x00\xd2\x00\x16\x00\x20\x00\x1c\x01\x1d\x01\x1e\x01\x85\x00\x20\x00\x80\x00\x2f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x03\x00\x0a\x00\x29\x01\x07\x00\x08\x00\x09\x00\x0a\x00\xe6\x00\x30\x01\x6f\x00\x36\x01\x32\x01\x10\x00\x11\x00\x5a\x00\x48\x00\x14\x00\x15\x00\x16\x00\x73\x00\x18\x00\x19\x00\x30\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x5b\x00\x2a\x00\x2b\x00\x2c\x00\x30\x01\x30\x01\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x79\x00\x2c\x01\x7d\x00\x7b\x00\x86\x00\x85\x00\x13\x01\x33\x00\x20\x00\x3e\x00\x3f\x00\x20\x00\x2b\x00\x32\x00\x69\x00\x4c\x00\x72\x00\x64\x00\x6e\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x77\x00\xac\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x2b\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x0f\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x85\x00\x30\x01\x30\x01\x07\x00\x08\x00\x09\x00\x0a\x00\x1c\x00\x1c\x00\xc8\x00\x77\x00\xe6\x00\x10\x00\x11\x00\xac\x00\xb9\x00\x14\x00\x15\x00\x16\x00\xaa\x00\x18\x00\x19\x00\x4f\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x17\x00\x2a\x00\x2b\x00\x2c\x00\x31\x01\x85\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x80\x00\x17\x00\x2b\x00\x85\x00\x25\x00\x31\x01\x33\x00\x50\x00\x55\x00\x3e\x00\x3f\x00\x30\x01\x30\x01\x55\x00\x4a\x00\x31\x01\x54\x00\x30\x00\x30\x01\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x11\x00\x0c\x00\x50\x00\x51\x00\x52\x00\x53\x00\x16\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x30\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x31\x01\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x5c\x00\x5f\x00\x30\x01\x07\x00\x08\x00\x09\x00\x0a\x00\x34\x00\x30\x01\x5a\x00\x31\x01\x16\x00\x10\x00\x11\x00\x5c\x00\x30\x01\x14\x00\x15\x00\x16\x00\x30\x01\x18\x00\x19\x00\x20\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x20\x00\x2a\x00\x2b\x00\x2c\x00\x25\x00\x31\x01\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xac\x00\x17\x00\x31\x01\x31\x01\x31\x01\x17\x00\xff\xff\x31\x01\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x67\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4a\x00\x4b\x00\x4c\x00\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x67\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x00\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\xff\x00\x01\x3e\x00\x3f\x00\xff\xff\x04\x01\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\x1f\x01\xff\xff\xff\xff\x5f\x00\x23\x01\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x29\x01\x67\x00\x68\x00\x2c\x01\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x99\x00\x09\x00\x0a\x00\x9c\x00\x9d\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\x40\x00\x41\x00\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x17\x01\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\xff\xff\x2a\x01\xff\xff\xff\xff\x2d\x01\x2e\x01\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x41\x00\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x17\x01\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\xff\xff\x2a\x01\xff\xff\xff\xff\x2d\x01\x2e\x01\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x17\x01\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\x28\x01\xff\xff\x2a\x01\xff\xff\xff\xff\x2d\x01\x2e\x01\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x5f\x00\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x72\x00\x5f\x00\x60\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\x00\x01\xff\xff\xff\xff\xff\xff\x04\x01\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x1f\x01\xff\xff\xff\xff\x5f\x00\x23\x01\x61\x00\x62\x00\xff\xff\x64\x00\xff\xff\x29\x01\xff\xff\x68\x00\x2c\x01\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x5f\x00\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x72\x00\x5f\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x9c\x00\x9d\x00\x9e\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xc3\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\x58\x00\x59\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x6a\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x01\x00\x02\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\x3e\x00\x3f\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x4a\x00\x9d\x00\x9e\x00\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xf8\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\x3e\x00\x3f\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x4a\x00\x9d\x00\x9e\x00\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xf8\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\x3e\x00\x3f\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x4a\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xf8\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8e\x00\x8f\x00\x3e\x00\x3f\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x4a\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xf8\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\x3e\x00\x3f\x00\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x9a\x00\x9b\x00\x4a\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xb3\x00\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x15\x00\xff\xff\x9c\x00\x9d\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\x92\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\x9a\x00\x9b\x00\x5f\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x01\x00\x02\x00\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x29\x01\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\x9f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xc3\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\xd0\x00\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\x9f\x00\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\x29\x01\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\x9f\x00\xff\xff\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x01\x01\xff\xff\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\xff\xff\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\x16\x01\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\xff\xff\x1f\x01\xff\xff\xff\xff\xc3\x00\x23\x01\x1c\x01\x1d\x01\x1e\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\xd0\x00\xff\xff\x29\x01\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x8f\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xf8\x00\xa1\x00\xa2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xd0\x00\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\xff\xff\xff\xff\xa1\x00\xa2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xa2\x00\xff\xff\xc3\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xc3\x00\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xa2\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xc3\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xf8\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xc3\x00\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xa2\x00\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xa2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xf8\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x0c\x01\x0d\x01\xa6\x00\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xc3\x00\xf8\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x29\x01\xff\xff\xc3\x00\xf8\x00\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xd0\x00\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xc3\x00\xf8\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xab\x00\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xc3\x00\xf8\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xc3\x00\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xab\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x92\x00\x93\x00\xc3\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xab\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xab\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\x29\x01\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xab\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xc3\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\x29\x01\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xab\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xc3\x00\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xab\x00\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xd0\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xab\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xf8\x00\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x92\x00\x93\x00\xf8\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xc3\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\x29\x01\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xf8\x00\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xb3\x00\xf8\x00\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\x97\x00\xff\xff\x99\x00\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9a\x00\x9b\x00\xff\xff\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\x02\x00\xc3\x00\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\x29\x01\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x01\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x81\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x09\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x74\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x81\x00\x02\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x09\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xe7\x00\xe8\x00\x2a\x00\xff\xff\xff\xff\x81\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\x81\x00\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\x30\x01\xe7\x00\xe8\x00\x74\x00\x75\x00\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\x3a\x01\xff\xff\x3c\x01\xff\xff\x3e\x01\xff\xff\x81\x00\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\x3a\x01\xff\xff\x3c\x01\xff\xff\x3e\x01\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe7\x00\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\x3a\x01\xff\xff\x3c\x01\xff\xff\x3e\x01\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xc3\x00\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xea\x00\xeb\x00\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\x3e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\x30\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x39\x01\xff\xff\x3b\x01\xff\xff\x3d\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x39\x01\xff\xff\x3b\x01\xff\xff\x3d\x01\xf8\x00\xf9\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x39\x01\xff\xff\x3b\x01\xff\xff\x3d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x15\x00\x2b\x01\x2c\x01\xff\xff\x19\x00\x2f\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x3d\x01\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\x02\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x79\x00\x15\x00\x7b\x00\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x6a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x71\x00\xff\xff\x02\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x02\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x09\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\x78\x00\x79\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\x09\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x6a\x00\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\x74\x00\x75\x00\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x09\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\xff\xff\x79\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\x78\x00\x79\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\x74\x00\x75\x00\x15\x00\xff\xff\xff\xff\x79\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x15\x00\xff\xff\xff\xff\x79\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x02\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x49\x00\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x02\x00\xff\xff\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xc3\x00\xff\xff\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x56\x00\xff\xff\xd0\x00\xd1\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xc3\x00\x07\x01\x08\x01\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x38\x01\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x38\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\x32\x01\xff\xff\x34\x01\xff\xff\x02\x00\x37\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x09\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd6\x00\xd7\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\x32\x01\x74\x00\x34\x01\xff\xff\x02\x00\x37\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x09\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd6\x00\xd7\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\x32\x01\x74\x00\x34\x01\xff\xff\xff\xff\x37\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xda\x00\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x18\x01\x19\x01\xff\xff\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\x29\x01\x2a\x01\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x2f\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\x37\x01\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdc\x00\xdd\x00\xde\x00\xdf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xdd\x00\xde\x00\xdf\x00\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xef\x00\xf0\x00\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\x37\x01\xf0\x00\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\x37\x01\xf0\x00\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\x37\x01\xf0\x00\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xe0\x00\xe1\x00\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xe0\x00\xe1\x00\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe4\x00\xe5\x00\xe6\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xf0\x00\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xdf\x00\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xe9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xf1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xe7\x00\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xe7\x00\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xe7\x00\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xc3\x00\xc4\x00\xc5\x00\xff\xff\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x01\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\x1b\x00\x1c\x00\x1d\x00\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\x20\x01\x02\x00\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x37\x01\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x74\x00\x75\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x74\x00\x75\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x74\x00\x75\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\x4c\x00\xff\xff\x15\x00\xff\xff\xff\xff\x51\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x64\x00\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x02\x00\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\x6a\x00\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xc5\x00\xff\xff\xc7\x00\xff\xff\x74\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xc5\x00\xff\xff\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xc3\x00\x2f\x01\xc5\x00\xff\xff\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xc5\x00\xff\xff\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xd3\x00\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xf8\x00\xf9\x00\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xcb\x00\xcc\x00\xcd\x00\x07\x01\x08\x01\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xc3\x00\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xf8\x00\xf9\x00\xff\xff\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x02\x01\x03\x01\xc3\x00\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xf8\x00\xf9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\x2f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x71\x00\x4f\x05\x50\x05\x52\x05\x53\x05\x2c\x01\x84\x04\x8e\x05\x95\x05\xd3\x00\x2b\x05\x90\x05\xa3\x04\x0b\x03\x91\x05\xd5\x04\x21\x02\xd4\x04\x22\x02\x61\x03\x8c\x05\xd5\x04\x21\x02\x4a\x05\x22\x02\x75\x05\x6c\x04\xd5\x04\x21\x02\x54\x03\x22\x02\x20\x02\x21\x02\x21\x02\x22\x02\xf0\x03\x88\x04\x49\x03\x89\x04\x76\x05\x77\x05\x78\x05\xec\x01\x4d\x03\x4e\x03\x4a\x04\x4b\x04\x1e\x02\x1e\x02\x47\x03\xa7\x03\xf2\x00\x80\x04\x9b\x02\x9c\x02\x79\x03\xd4\x00\xe8\x04\x00\x03\x7c\x04\x4b\x04\x77\x02\x8a\x04\x90\x04\x31\x00\xf4\x01\x5c\x05\x74\x03\x25\x01\x9b\x02\x9c\x02\x1e\x02\x25\x01\x1c\x05\x1d\x05\x1e\x05\x1f\x05\x6c\x04\xed\x01\xee\x01\xef\x01\x27\x05\x4b\x04\x2a\x04\x71\x03\x74\x05\x1f\x05\x6c\x04\x86\x05\x5e\x04\x5f\x04\x71\x05\x7e\x05\xdd\x01\x48\x00\x0f\x04\x01\x03\x32\x00\x75\x05\x6c\x04\x46\x02\x4c\xff\x41\x00\x44\x04\xdd\x02\x19\xff\xb3\x01\xde\x01\x75\x05\x6c\x04\x0a\x01\x08\x03\x98\x05\x77\x05\x78\x05\x42\x00\xc8\x02\x1e\x02\x4e\x00\xb4\x01\x6b\x04\x6c\x04\x49\x01\xea\x02\x9e\x05\xa4\x04\xad\x02\xbd\x01\xb5\xfe\x47\x02\x87\x05\x1e\x02\xb7\xfe\xec\x01\x62\x03\x78\x02\xa5\xff\xaf\x02\x8c\x04\x4c\xff\x91\x02\x7a\x03\xf5\x00\xa5\x04\x48\x00\x90\x00\x33\x00\xb1\x02\xa8\x02\x93\x00\x1f\x02\x1f\x02\x95\x00\x96\x00\x97\x00\x98\x00\x72\x03\xb2\x02\xb3\x02\xb4\x02\x20\x02\xa4\x02\x0e\x01\x2d\x01\x2e\x01\x1e\x02\x74\x00\x1a\x01\xb5\xfe\x2b\x04\xd9\x03\xef\x01\xb7\xfe\xc9\x02\x1f\x02\x44\x00\x45\x00\x4f\x03\x7f\x05\x47\x00\x48\x00\x1c\x01\x82\x00\xa2\x03\xfa\x01\xf0\x01\x4d\x00\x11\x00\x72\x05\x1c\x01\x4b\x02\x4b\x00\x4f\x03\x4d\x00\x2f\x01\x11\x00\x1c\x01\x4e\x00\x9f\x00\xa0\x00\x11\x00\x0c\x03\x11\x00\x1d\x01\x4e\x00\x9e\x02\x08\x01\x11\x00\xa1\x00\x73\x00\x4c\x04\xa5\x04\x48\x00\x74\x00\x75\x00\x85\x04\x11\x00\x85\x04\x2c\x05\x1e\x02\x1f\x02\x9d\x02\x0a\x03\x4c\x02\x4c\x04\x0c\x03\x4e\x00\x8d\x00\x4e\x00\x4e\x00\x11\x00\x11\x00\x48\x03\x3c\x02\x1f\x02\x48\x03\x1c\x01\xd7\x00\xa2\x00\x1c\x01\x0f\x00\xd8\x00\x11\x00\x98\x03\x0f\x01\x11\x00\x4c\x04\x11\x00\x36\x00\x7d\x00\x7e\x00\x4f\x03\x11\x00\xa3\x00\x6d\x04\x1c\x01\x6e\x04\x48\x00\x72\x00\x73\x00\x18\x03\x11\x00\x7e\x03\x74\x00\x75\x00\x1e\x02\x76\x00\x33\x00\x1f\x02\xf0\x01\xff\xff\x3d\x02\x6f\x04\x1c\x01\x0f\x00\x10\x00\xf0\x01\x96\x03\xff\xff\x11\x00\x1c\x01\x11\x00\x77\x00\x3c\x04\xf9\x01\x19\x03\x11\x00\x34\x00\x0e\x00\x1e\x02\x0f\x00\x10\x00\x78\x00\x51\x05\x79\x00\x7a\x00\x7b\x00\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x54\x05\x23\x02\x6d\x04\x54\x05\x6e\x04\x48\x00\x0e\x02\x23\x02\x51\x05\x9c\x03\x0d\x04\xda\x02\x6d\x04\x23\x02\x6e\x04\x48\x00\x7f\x03\x23\x02\x23\x02\x1f\x02\x6f\x04\xdb\x02\x0f\x00\x10\x00\x6d\x04\xbb\x02\x6e\x04\x48\x00\xfc\x04\x11\x00\x6f\x04\xf2\x01\x0f\x00\x10\x00\x6d\x04\x1e\x02\x6e\x04\x48\x00\xc2\x01\x11\x00\x1e\x02\xc3\x01\x6f\x04\x0e\x04\x0f\x00\x10\x00\x6d\x04\x3d\x02\x6e\x04\x48\x00\xd3\x00\x11\x00\x6f\x04\x49\x01\x0f\x00\x10\x00\x61\x04\x62\x04\xea\x00\xeb\x00\xec\x00\x11\x00\xed\x00\xa5\x02\x6f\x04\x1f\x02\x0f\x00\x10\x00\x41\x00\xf7\x01\xf8\x01\xf9\x01\x13\x02\x11\x00\xf2\x04\xa6\x02\xa7\x02\xc4\x02\xee\x00\xef\x00\xff\xff\x42\x00\x51\x04\x35\x02\xf8\x01\xf9\x01\x10\x02\xf0\x00\xf1\x00\x1f\x02\x09\x02\x82\x00\xf2\x00\xd9\x01\x7b\x00\x90\x02\x7c\x00\xd4\x00\xd4\x04\xfa\x01\xa8\x02\x4d\x00\x14\x01\x58\x03\xf8\x01\xf9\x01\x36\x00\x52\x04\xc5\x02\x8a\x02\x4a\x01\x4b\x01\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x8b\x02\x3f\x00\x40\x00\x08\x02\xc6\x02\x10\x01\x5e\x04\x5f\x04\x6a\x01\xd3\x00\xf3\x00\x25\x01\x26\x01\xbd\x01\x6b\x01\x1d\x03\xe9\x00\xea\x00\xeb\x00\xec\x00\x8d\x00\xed\x00\x1f\x02\x1a\x03\x90\x00\x44\x00\x45\x00\x1f\x02\x14\x03\x47\x00\x48\x00\x98\x03\xdc\x03\x8c\x02\xca\x03\x2d\x00\x68\x05\xee\x00\xef\x00\x41\x00\xfe\x01\x4b\x00\x2e\x00\x4d\x00\x2f\x00\xc4\x02\xf0\x00\xf1\x00\x28\x04\xf8\x01\xf9\x01\xf2\x00\x42\x00\xa6\xff\x4e\x00\x1e\x03\xd4\x00\x18\x03\xdd\x03\x60\x04\xbc\x02\x73\x00\xf4\x00\x1b\x03\x67\x01\x74\x00\x75\x00\xf5\x00\x15\x03\x91\x02\x90\x00\x92\x02\xf6\x00\xfa\x01\x93\x00\x4d\x00\xc5\x02\x95\x00\x96\x00\x97\x00\x98\x00\x67\x01\x19\x03\x99\x00\x9a\x00\xf3\x00\x4e\x00\xfa\x01\x43\x03\x4d\x00\xbd\x02\xd9\x02\x0f\x00\x10\x00\xec\x04\xea\x04\xf7\x01\x6b\x01\xa7\x04\x11\x00\x4e\x00\x7d\x00\x7e\x00\xab\x04\xf8\x01\xf9\x01\x0f\x01\xfa\x01\x0f\x02\x4d\x00\xa2\x02\xc1\x04\x44\x00\x45\x00\x6b\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4e\x00\xeb\x04\x10\x02\x9f\x00\xa0\x00\x10\x01\xa8\x04\xa9\x04\x4b\x00\x4c\x00\x4d\x00\x67\x01\xc2\x04\xa1\x00\x73\x00\x27\x01\x28\x01\xf4\x00\x74\x00\x75\x00\x19\x01\x4e\x00\xf5\x00\x74\x00\x1a\x01\x90\x00\x3c\x03\xf6\x00\x37\x02\x93\x00\xc8\x04\xf8\x03\x95\x00\x96\x00\x97\x00\x98\x00\x16\x02\x17\x02\x99\x00\x9a\x00\x94\x02\x38\x02\xd7\x00\xa2\x00\x6b\x01\x0f\x00\xd8\x00\x1b\x01\xfa\x01\xf6\x01\x4d\x00\x1c\x01\x11\x00\xe1\x03\x7d\x00\x7e\x00\xe2\x03\x11\x00\xa3\x00\xff\xff\x1d\x01\x4e\x00\xd3\x00\xc9\x04\xca\x04\xaa\x04\x33\x01\x2a\x03\x82\x00\x9f\x03\xea\x00\xeb\x00\xec\x00\x18\x05\xed\x00\xf9\x03\x64\x00\x6f\x02\x9f\x00\xa0\x00\x68\x00\xd3\x00\x34\x01\x11\x00\x22\x03\xe3\x03\x2b\x03\x2c\x03\xa1\x00\x73\x00\xee\x00\xef\x00\x10\x01\x74\x00\x75\x00\x64\x00\x67\x02\x68\x02\x69\x02\xf0\x00\xf1\x00\x6a\x01\xd7\x03\xfa\x01\xf2\x00\x4d\x00\x1c\x01\x6b\x01\x88\x04\xd4\x00\x89\x04\xfa\x02\x11\x00\x8d\x00\xf6\x03\x69\x02\x4e\x00\xd7\x00\xa2\x00\x57\x00\x0f\x00\xd8\x00\x64\x00\xf2\x00\x3e\x02\x82\x00\x68\x00\x11\x00\xd4\x00\x7d\x00\x7e\x00\x58\x00\x3f\x02\xa3\x00\x8a\x04\x8b\x04\x1f\x03\x84\x00\xf3\x00\x20\x03\x5c\x00\x85\x00\x6a\x02\x6b\x02\x0f\x00\x6c\x02\x86\x00\x1e\x03\x28\x01\x27\x01\x28\x01\x11\x00\x19\x01\x17\x05\x19\x01\x74\x00\x1a\x01\x74\x00\x1a\x01\x6a\x02\x6b\x02\x0f\x00\x6c\x02\x65\x00\x66\x00\x53\x01\xe9\x04\xea\x04\x11\x00\x8c\x00\x8d\x00\x84\x00\x10\x01\x8f\x00\x90\x00\x85\x00\x53\x04\x59\x05\xea\x04\x1b\x01\x86\x00\x1b\x01\x18\x02\x1c\x01\x54\x04\x1c\x01\xa2\x02\x4a\x00\xa9\x01\x11\x00\xf4\x00\x11\x00\x1d\x01\xeb\x04\x1d\x01\xf5\x00\x19\x02\x1a\x02\x90\x00\xd3\x00\xf6\x00\x9a\x02\x93\x00\x8c\x00\xeb\x04\x95\x00\x96\x00\x97\x00\x98\x00\xaf\x02\x8c\x04\x99\x00\x9a\x00\x87\xfd\xf5\x00\x88\x05\xc1\x01\x90\x00\xe7\x01\xb1\x02\x4c\x01\x93\x00\xd1\x04\x89\x05\x95\x00\x96\x00\x97\x00\x98\x00\x13\x01\xb2\x02\xb3\x02\xb4\x02\x14\x01\x6c\x01\x73\x00\xff\xff\x10\x02\x6d\x01\x74\x00\x75\x00\xd0\x04\xf2\x00\xaa\x04\x82\x00\x7e\x01\x2e\x01\xd4\x00\x74\x00\x1a\x01\x44\x01\xc0\x01\x9f\x00\xa0\x00\x64\x00\x10\x02\x84\x00\xb8\x02\x68\x00\x28\x02\x85\x00\x0f\x03\xa1\x00\x73\x00\x87\x01\x86\x00\x10\x03\x74\x00\x75\x00\x84\x01\x20\x02\x9f\x00\xa0\x00\xa1\x03\xd3\x00\x7d\x00\x7e\x00\x6a\x01\x45\x01\x46\x01\x47\x01\xa1\x00\x73\x00\x6b\x01\xa2\x03\x1d\x01\x74\x00\x75\x00\x8c\x00\x8d\x00\xff\xff\xd7\x00\xa2\x00\x5c\x02\x0f\x00\xd8\x00\x87\x00\x97\x03\x31\x01\x42\x02\x89\x00\x11\x00\x2e\x03\x7d\x00\x7e\x00\xff\xff\x95\x03\xa3\x00\x98\x03\x8b\x00\xd7\x00\xa2\x00\x0b\xfd\x0f\x00\xd8\x00\x56\x01\xf2\x00\x96\x03\x2f\x03\x30\x03\x11\x00\xd4\x00\x7d\x00\x7e\x00\xfb\x04\x82\x01\xa3\x00\x83\x01\xaf\x02\xb0\x02\xa4\x01\xae\x02\x54\x01\xf5\x00\x6b\x01\xfc\x04\x90\x00\x18\xff\xb1\x02\x34\x02\x93\x00\x4d\x00\x48\x01\x95\x00\x96\x00\x97\x00\x98\x00\x4d\x01\xb2\x02\xb3\x02\xb4\x02\x2c\x01\x4e\x00\x6c\x01\x73\x00\xf1\x04\x66\x02\x85\x03\x74\x00\x75\x00\x4e\x01\xf8\x02\x4f\x01\x50\x01\x47\x00\x48\x00\xf2\x04\x33\x02\x87\x00\x4d\x00\x6f\x01\x34\x01\x89\x00\x78\x00\x13\x01\x79\x00\x7a\x00\x7b\x00\x14\x01\x7c\x00\x4e\x00\x8b\x00\x7f\x00\x80\x00\x32\x04\x8e\x00\x4d\x00\xb9\x02\xb6\x02\xb7\x02\xa0\x00\x0a\x01\x0b\x01\x41\x00\x7d\x00\x7e\x00\x0c\x01\x4e\x00\xd3\x04\xa1\x00\x73\x00\xd3\x00\xaf\x02\xb0\x02\x74\x00\x75\x00\x42\x00\xf5\x00\xff\xff\xd4\x04\x90\x00\x98\x01\xb1\x02\x99\x01\x93\x00\x29\x05\x67\x05\x95\x00\x96\x00\x97\x00\x98\x00\x18\x01\xb2\x02\xb3\x02\xb4\x02\x93\x04\x98\x03\x68\x05\xd7\x00\xa2\x00\x4e\x02\x0f\x00\xd8\x00\x84\x00\x6a\x05\xff\xff\x11\x00\x85\x00\x11\x00\x4b\x03\x7d\x00\x7e\x00\x86\x00\xf2\x00\xa3\x00\x4e\x00\x2e\x03\x36\x00\xd4\x00\xe9\x02\x94\x04\x9a\x04\x35\x01\xea\x02\x36\x01\x3d\x00\x3e\x00\x27\x03\x3f\x00\x40\x00\x1c\x02\xb5\x02\xb6\x02\xb7\x02\xa0\x00\x8c\x00\x44\x00\x45\x00\x5f\x02\x8f\x00\x47\x00\x48\x00\x42\x02\xa1\x00\x73\x00\xd3\x00\x25\x03\x44\x02\x74\x00\x75\x00\x83\xfe\x1c\x03\x4b\x00\x45\x02\x4d\x00\x10\x05\x73\x00\x83\xfe\x42\x04\x48\x02\x74\x00\x75\x00\x1c\x01\x42\x02\x41\x02\x4e\x00\x41\x00\x16\x03\x11\x00\x93\x04\x42\x02\x8b\x05\xd7\x00\xa2\x00\x83\xfe\x0f\x00\xd8\x00\x8c\x05\xd3\x02\x42\x00\x6f\x02\x92\x01\x11\x00\x93\x01\x7d\x00\x7e\x00\x11\x00\xf2\x00\xa3\x00\x8b\x01\x0b\x03\x8c\x01\xd4\x00\x8d\x01\x94\x04\x95\x04\x7d\x00\x7e\x00\xff\x02\xaf\x02\x96\x04\x98\xfe\x64\x00\xf7\x02\xf5\x00\x98\xfe\x68\x00\x90\x00\xf6\x02\xb1\x02\x6e\x02\x93\x00\x6f\x02\xf5\x02\x95\x00\x96\x00\x97\x00\x98\x00\x11\x00\xb2\x02\xb3\x02\xb4\x02\x99\x05\x73\x00\xf4\x02\x83\xfe\x83\xfe\x74\x00\x75\x00\x4e\x02\x83\xfe\xf3\x02\x05\x02\x06\x02\x82\x01\x11\x00\x83\x01\xcc\x01\x7e\x00\x44\x00\x37\x01\xed\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x38\x02\x7b\x00\x07\x02\x7c\x00\x83\xfe\x56\x01\x83\xfe\xca\x02\x4b\x00\x4c\x00\x4d\x00\xd0\x01\x4c\x03\x9f\x00\xa0\x00\x83\xfe\x7d\x00\x7e\x00\x11\x00\x7b\x04\x84\x02\x4e\x00\x85\x02\xa1\x00\x73\x00\x11\x00\xaf\x02\x96\x04\x74\x00\x75\x00\xd3\x00\xf5\x00\xeb\x02\xbd\x01\x90\x00\x05\x04\xb1\x02\x80\x03\x93\x00\x6f\x02\xde\x02\x95\x00\x96\x00\x97\x00\x98\x00\x11\x00\xb2\x02\xb3\x02\xb4\x02\x81\x02\x13\x01\x82\x02\xd7\x00\xa2\x00\x14\x01\x0f\x00\xd8\x00\x88\x04\x84\x02\x89\x04\x85\x02\x83\xfe\x11\x00\xdd\x02\x7d\x00\x7e\x00\x7e\x01\x93\x03\xa3\x00\x74\x00\x1a\x01\xd8\x02\xf2\x00\xff\xfd\x82\x00\xc7\x01\x0e\x00\xd4\x00\x0f\x00\x10\x00\xff\xfd\x5e\x02\xff\xfd\x34\x05\xd6\x02\x11\x00\x84\x00\x9f\x00\xa0\x00\xf6\xfc\x85\x00\xc8\x01\xc9\x01\xca\x01\xcb\x01\x86\x00\xd1\x02\xa1\x00\x73\x00\x5d\x02\x82\x00\xff\xfd\x74\x00\x75\x00\xd3\x00\xff\xfd\x1d\x01\xff\xfd\x7c\x01\xff\xfd\x0f\x00\x10\x00\x84\x00\xff\xfd\x53\x01\xd0\x02\x85\x00\x11\x00\x8c\x00\x8d\x00\xce\x02\x86\x00\x8f\x00\x90\x00\x30\x05\x2e\x05\xd7\x00\xa2\x00\x93\x04\x0f\x00\xd8\x00\x7e\x01\x3f\x05\xca\x02\x74\x00\x1a\x01\x11\x00\xd0\x01\x7d\x00\x7e\x00\x53\x01\xcd\x02\xa3\x00\x57\x00\x8c\x00\x8d\x00\xf2\x00\xcc\x02\x8f\x00\x90\x00\xbf\x02\xd4\x00\xda\x04\x3c\x05\x6f\x02\x58\x00\xcf\x01\x80\x00\xaf\x02\x8c\x04\x11\x00\xd0\x01\xbb\x02\xf5\x00\x5c\x00\x82\x00\x90\x00\x7b\x04\xb1\x02\x7c\x02\x93\x00\x1d\x01\xec\x01\x95\x00\x96\x00\x97\x00\x98\x00\x84\x00\xb2\x02\xb3\x02\xb4\x02\x85\x00\x3e\x01\x3f\x01\x40\x01\x41\x01\x86\x00\x65\x00\x66\x00\x36\x00\xa1\x02\x69\x00\x6a\x00\x3a\x04\xfc\x02\x3b\x04\x36\x01\x3d\x00\x3e\x00\x55\x03\x3f\x00\x40\x00\x47\x00\x48\x00\x87\x00\x53\x01\x6f\x01\xa0\x02\x89\x00\x8c\x00\x8d\x00\x2d\x05\x2e\x05\x8f\x00\x90\x00\x7c\x03\x7d\x03\x8b\x00\xd3\x00\x9f\x00\xa0\x00\x8e\x00\x9b\x02\xf6\xfd\x31\x04\xf6\xfd\x32\x04\xf6\xfd\x8d\x02\xa1\x00\x73\x00\x7b\x02\xaf\x02\x96\x04\x74\x00\x75\x00\xf6\xfd\xf5\x00\x41\x00\x82\x01\x90\x00\x83\x01\xb1\x02\xef\x03\x93\x00\xf0\x03\x99\x02\x95\x00\x96\x00\x97\x00\x98\x00\x42\x00\xb2\x02\xb3\x02\xb4\x02\x5c\x03\x5d\x03\x82\x00\xd7\x00\xa2\x00\xf2\x00\x0f\x00\xd8\x00\x11\x05\x90\x02\xd4\x00\x47\x00\x48\x00\x11\x00\x84\x00\x7d\x00\x7e\x00\x89\x02\x85\x00\xa3\x00\x07\x05\x36\x00\x76\x01\x86\x00\x0f\x00\x10\x00\xfc\x02\x88\x02\x36\x01\x3d\x00\x3e\x00\x11\x00\x3f\x00\x40\x00\xcd\x04\x6a\x01\xce\x04\xd3\x00\x9f\x00\xa0\x00\x86\x02\x6b\x01\x59\x04\x5a\x04\x5b\x04\x5c\x04\x8c\x00\x8d\x00\xa1\x00\x73\x00\x8f\x00\x90\x00\x7f\x02\x74\x00\x75\x00\x7e\x02\x44\x00\x45\x00\xfb\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x38\x02\x7b\x00\xc6\x02\x7c\x00\x0f\x00\x10\x00\x41\x00\x7d\x02\x4b\x00\x4c\x00\x4d\x00\x11\x00\x7c\x02\xd7\x00\xa2\x00\xf2\x00\x0f\x00\xd8\x00\x7b\x02\x42\x00\xd4\x00\x4e\x00\x10\x03\x11\x00\x11\x03\x7d\x00\x7e\x00\xaf\x02\xb0\x02\xa3\x00\x06\x05\x31\x02\xf5\x00\xbd\x01\xa1\x04\x90\x00\xa2\x04\xb1\x02\x73\x02\x93\x00\x2f\x02\xa5\x02\x95\x00\x96\x00\x97\x00\x98\x00\x61\x02\xb2\x02\xb3\x02\xb4\x02\xcb\x01\x10\x00\x60\x02\x12\x04\xa7\x02\x7c\x03\x7d\x03\x11\x00\x36\x00\xcc\x01\x7e\x00\x5e\x02\x7f\x04\xfc\x02\x80\x04\x36\x01\x3d\x00\x3e\x00\x41\x00\x3f\x00\x40\x00\xd9\x01\x7b\x00\x68\x04\x7c\x00\x69\x04\x5d\x02\x41\x00\xa8\x02\x44\x00\x45\x00\x42\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xd3\x00\x9f\x00\xa0\x00\x42\x00\xc1\x02\x5b\x02\x0f\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\xa1\x00\x73\x00\x11\x00\xaf\x02\xb0\x02\x74\x00\x75\x00\xd3\x00\xf5\x00\x41\x00\x4e\x00\x90\x00\x02\x05\xb1\x02\x03\x05\x93\x00\x16\x02\x17\x02\x95\x00\x96\x00\x97\x00\x98\x00\x42\x00\xb2\x02\xb3\x02\xb4\x02\x21\x01\x22\x01\x23\x01\xd7\x00\xa2\x00\xf2\x00\x0f\x00\xd8\x00\x4a\x02\x68\x04\xd4\x00\x69\x04\xe2\x01\x11\x00\xe3\x01\x7d\x00\x7e\x00\x44\x00\x45\x00\xa3\x00\x4e\x02\x47\x00\x48\x00\xe5\x02\xe6\x02\xe7\x02\x44\x00\x45\x00\xd4\x00\x4d\x02\x47\x00\x48\x00\x73\x02\x4b\x00\xbb\x01\x4d\x00\x3b\x05\x3c\x05\x9f\x00\xa0\x00\x49\x02\x21\x01\x4b\x00\x3b\x03\x4d\x00\x40\x02\x4e\x00\x3b\x02\xa1\x00\x73\x00\x69\x03\x6a\x03\x6b\x03\x74\x00\x75\x00\x4e\x00\x44\x00\x45\x00\x3a\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xf2\x04\x87\x01\x88\x01\x45\x00\x3b\x05\x62\x05\x47\x00\x48\x00\x4b\x00\x4c\x00\x4d\x00\x16\x02\x17\x02\xd7\x00\xa2\x00\x2f\x02\x0f\x00\xd8\x00\x89\x01\x1c\x02\x4d\x00\x4e\x00\x33\x03\x11\x00\x25\x01\x7d\x00\x7e\x00\xaf\x02\x15\x04\xa3\x00\x33\x03\x4e\x00\xf5\x00\x7c\x03\x7d\x03\x90\x00\x08\x01\xb1\x02\x0e\x02\x93\x00\x0e\x02\x0c\x02\x95\x00\x96\x00\x97\x00\x98\x00\xe4\x03\xb2\x02\xb3\x02\xb4\x02\xd5\x00\x0b\x02\x0c\x02\x90\x00\xdb\x03\xd6\x00\xde\x03\x93\x00\x7f\x01\xb7\x01\x95\x00\x96\x00\x97\x00\x98\x00\x36\x00\xd1\x03\x99\x00\x9a\x00\x2b\x02\xf3\x04\xd2\x03\x36\x01\x3d\x00\x3e\x00\xd8\xfc\x3f\x00\x40\x00\xf5\xfc\x3f\x03\x28\x01\x5d\x03\x5e\x03\x5f\x03\x19\x01\xd1\x02\x10\x00\x74\x00\x1a\x01\x9f\x00\xa0\x00\xdf\xfc\x11\x00\xe0\xfc\xcc\x01\x7e\x00\x38\x05\x7f\x01\x80\x01\xa1\x00\x73\x00\x22\x04\x23\x04\x24\x04\x74\x00\x75\x00\x41\x00\x9f\x00\xa0\x00\x7d\x01\x78\x01\x1b\x01\x41\x01\x42\x01\x41\x00\x1c\x01\xf4\xfc\xa1\x00\x73\x00\x42\x00\x4c\x02\x11\x00\x74\x00\x75\x00\x1d\x01\x7a\x01\x78\x01\x42\x00\xd7\x00\xa2\x00\xd0\x03\x0f\x00\xd8\x00\x03\x03\x04\x03\x05\x03\x06\x03\x07\x03\x11\x00\xd9\xfc\x7d\x00\x7e\x00\x33\x05\xda\xfc\xa3\x00\xcf\x03\xd7\x00\xa2\x00\xce\x03\x0f\x00\xd8\x00\xce\x01\xa4\x01\x7b\x00\xcd\x03\x7c\x00\x11\x00\xc9\x03\x7d\x00\x7e\x00\x36\x00\xcc\x03\xa3\x00\x77\x01\x78\x01\xfc\x02\x06\xfd\x36\x01\x3d\x00\x3e\x00\xc8\x03\x3f\x00\x40\x00\xc7\x03\xce\x01\xa4\x01\x7b\x00\x7d\x05\x7c\x00\x44\x00\x45\x00\xcf\x01\x80\x00\x47\x00\x48\x00\x6b\x01\xd0\x01\x44\x00\x45\x00\x46\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x9d\x03\x4d\x00\x09\x04\x02\x04\x03\x04\x9e\x03\xbb\x01\x4b\x00\x4c\x00\x4d\x00\x36\x00\x93\x03\x4e\x00\x41\x00\x43\x02\xfc\x02\x92\x03\x36\x01\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x01\x04\x02\x04\x03\x04\x42\x00\xbb\x01\x91\x03\xc9\x02\x71\x01\x72\x01\x73\x01\x90\x03\x74\x01\xce\x01\xa4\x01\x7b\x00\x19\x01\x7c\x00\x8f\x03\x74\x00\x1a\x01\x29\x01\x2a\x01\x36\x00\x1d\x04\x1e\x04\x1f\x04\x8e\x03\xfc\x02\x8d\x03\x36\x01\x3d\x00\x3e\x00\x8c\x03\x3f\x00\x40\x00\x8b\x03\x41\x00\xde\x02\x86\x03\x88\x01\x45\x00\x88\x03\x1b\x01\x47\x00\x48\x00\x85\x03\x1c\x01\xa2\x02\x4a\x00\x42\x00\x38\x02\x7b\x00\x11\x00\x7c\x00\x84\x03\x1d\x01\x67\x01\xca\x02\xa2\x04\x23\x04\x24\x04\xd0\x01\x0a\xfd\x44\x00\x45\x00\x6e\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x9c\x04\x23\x04\x24\x04\x0e\x05\xef\x04\x23\x04\x24\x04\x4b\x00\x4c\x00\x4d\x00\x81\x03\x82\x03\x42\x00\x7f\x01\x2c\x04\x84\x00\xca\x04\xc6\x04\x36\x00\x85\x00\x4e\x00\x69\x03\x4a\x01\x4b\x01\x86\x00\x3c\x00\x3d\x00\x3e\x00\x67\x03\x3f\x00\x40\x00\x96\x05\x23\x04\x24\x04\x66\x03\x75\x03\x64\x03\x44\x00\x45\x00\x5a\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x16\x04\x17\x04\x8c\x00\x0f\x05\xc5\x04\xc6\x04\x8f\x00\x10\x05\x4b\x00\x4c\x00\x4d\x00\xa0\x05\x23\x04\x24\x04\x91\x04\x6b\x03\x8b\x00\x64\x05\x0c\x05\x5c\x04\x2c\x01\x4e\x00\x41\x00\xe1\x04\x1f\x04\x6e\x05\x6f\x05\x44\x00\x45\x00\x3f\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x38\x03\x37\x03\x36\x03\x33\x03\x08\x01\x12\x04\x36\x00\x4b\x00\x4c\x00\x4d\x00\x76\x03\x77\x03\x61\x04\x3c\x00\x3d\x00\x3e\x00\x90\x00\x3f\x00\x40\x00\x59\x04\x4e\x00\x58\x04\x56\x04\xac\x01\x96\x00\x97\x00\x98\x00\x82\x00\x55\x04\x99\x00\x9a\x00\x50\x04\x4a\x04\x36\x00\x48\x04\xaa\x02\x47\x04\x76\x03\x77\x03\x84\x00\x3c\x00\x3d\x00\x3e\x00\x85\x00\x3f\x00\x40\x00\x46\x04\x44\x04\x86\x00\x00\xfd\x42\x04\xff\xfc\x01\xfd\x40\x04\x35\x04\x41\x00\x2f\x04\x74\x03\x28\x04\x44\x00\x45\x00\x26\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xab\x02\x42\x00\x9f\x00\xa0\x00\x8c\x00\x8d\x00\x21\x04\x2a\x04\x4b\x00\x4c\x00\x4d\x00\x1d\x04\xa1\x00\x73\x00\x46\x02\x41\x00\x1b\x04\x74\x00\x75\x00\x6b\x00\x06\x04\x4e\x00\x36\x00\x37\x00\xdf\x01\x39\x00\x3a\x00\x3b\x00\x42\x00\x3c\x00\x3d\x00\x3e\x00\x12\x04\x3f\x00\x40\x00\x08\x04\x00\x04\xfe\x03\xe0\x01\xe1\x01\x4b\x02\xed\x03\xa2\x00\xf4\x03\x0f\x00\x10\x00\xeb\x03\xf5\x03\xea\x03\xcf\x04\xc5\x04\x11\x00\xc4\x04\x7d\x00\x7e\x00\xc3\x04\x7b\x02\xa3\x00\x74\x03\xbd\x01\x99\x03\x44\x00\x45\x00\xbb\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x65\x04\xb3\x04\x41\x00\xb4\x04\xb2\x04\xb1\x04\x26\x04\x28\x04\x4b\x00\x4c\x00\x4d\x00\xa0\x04\x26\x04\x88\x04\x83\x04\x42\x00\x7e\x04\x75\x04\x7a\x04\x44\x00\x45\x00\x4e\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x76\x04\x79\x04\x25\x01\x16\x05\x12\x04\x15\x05\x36\x03\x65\x04\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\x4f\x02\x39\x00\x3a\x00\x3b\x00\x0a\x05\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x05\x05\x04\x05\xfe\x04\xf9\x04\x43\x00\x26\x04\x36\x00\x37\x00\xe5\x01\x39\x00\x3a\x00\x3b\x00\x47\x01\x3c\x00\x3d\x00\x3e\x00\xe4\x04\x3f\x00\x40\x00\xe3\x04\x7e\xfe\x21\x04\xdd\x04\x4e\x05\x44\x00\x45\x00\x18\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4c\x05\x47\x05\x43\x05\x44\x05\x41\x00\x41\x05\x82\x00\x56\x01\x4b\x00\x4c\x00\x4d\x00\x3f\x05\x18\x01\x3e\x05\xd2\x01\x26\x05\x19\x01\x42\x00\x84\x00\x74\x00\x1a\x01\x4e\x00\x85\x00\x41\x00\x24\x05\x23\x05\x36\x00\x86\x00\x22\x05\x33\x03\xe2\x01\xfa\x02\xe3\x01\x36\x01\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x6a\x01\x1c\x05\x1a\x05\x74\x05\x1b\x01\x6c\x05\x6b\x01\x73\x05\x1c\x01\x66\x05\x6d\x05\x8c\x00\x8d\x00\x69\x03\x11\x00\x8f\x00\x90\x00\x1d\x01\x43\x00\x5b\x05\x36\x00\x37\x00\xe5\x01\x39\x00\x3a\x00\x3b\x00\x8a\x05\x3c\x00\x3d\x00\x3e\x00\x85\x05\x3f\x00\x40\x00\x82\x05\x33\x03\x9c\x05\x41\x00\x43\x00\x44\x00\x45\x00\x7d\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x15\x05\x28\x04\x9d\x05\x42\x00\x26\x04\x95\x05\xa4\x05\xa5\x05\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x26\x04\x46\x00\x47\x00\x48\x00\xe6\x01\x4a\x00\x38\x02\x7b\x00\x4e\x00\x7c\x00\x41\x00\xa0\x05\xcf\x01\x80\x00\x4b\x00\x4c\x00\x4d\x00\xd0\x01\xd3\x01\xa7\x05\xd4\x01\x08\x01\x06\x01\x42\x00\xd5\x01\x12\x02\x11\x02\x4e\x00\x6f\x01\x70\x01\x71\x01\x72\x01\x73\x01\x90\x01\x74\x01\x03\x02\xe7\x01\xb5\x01\x19\x01\xcd\x01\x85\x01\x74\x00\x1a\x01\x99\x01\x54\x01\x96\x01\x3c\x01\x31\x01\xd8\x01\x16\x01\x44\x00\x45\x00\x1c\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x11\x00\x15\x01\x7d\x00\x7e\x00\x11\x01\x43\x00\x29\x03\x1b\x01\x4b\x00\x4c\x00\x4d\x00\x1c\x01\x28\x03\x27\x03\x25\x03\x16\x03\x07\x03\x11\x00\x01\x03\x03\x02\x1d\x01\x4e\x00\xeb\x02\xdf\x02\xce\x02\x44\x00\x45\x00\xc2\x02\x46\x00\x47\x00\x48\x00\xe6\x01\x4a\x00\x82\x02\x7f\x02\x79\x02\x1c\x02\x17\x02\x94\x02\x14\x02\xe8\x03\x80\x05\x4c\x00\x4d\x00\xe7\x03\xe5\x03\xe6\x03\x2e\x03\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe4\x03\xdf\x03\x4e\x00\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x77\x02\xa2\x03\x6c\x03\xca\x03\xe7\x01\xe7\xfc\xe7\xfc\x67\x03\x64\x03\xe7\xfc\xe7\xfc\xe7\xfc\x62\x03\xe7\xfc\xe7\xfc\x9e\x03\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x5a\x03\xe7\xfc\xe7\xfc\xe7\xfc\x9a\x03\x99\x03\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x40\x03\x4b\x03\x43\x03\x41\x03\x3d\x03\x3a\x03\x38\x03\x34\x03\x33\x03\xe7\xfc\xe7\xfc\x31\x03\x63\x04\x56\x04\x48\x04\x3e\x04\x38\x04\x3b\x04\x2f\x04\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x2d\x04\x26\x04\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x10\x04\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xed\x03\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xeb\x03\x08\x04\x00\x04\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xcf\x04\xcb\x04\xbf\x04\xbd\x04\x77\x02\xdb\xfd\xdb\xfd\x9d\x04\xaa\x04\xdb\xfd\xdb\xfd\xdb\xfd\x92\x04\xdb\xfd\xdb\xfd\x86\x04\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x76\x04\xdb\xfd\xdb\xfd\xdb\xfd\x77\x04\x6a\x04\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x69\x04\x66\x04\x65\x04\x16\x05\x13\x05\x12\x05\x0b\x05\x00\x05\xff\x04\xdb\xfd\xdb\xfd\xfe\x04\xf9\x04\xfc\x04\xe7\x04\xd7\x04\xf7\x04\xd8\x04\xd9\x04\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x4e\x05\x4c\x05\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x49\x05\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x41\x05\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x48\x05\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xc9\xfd\xc9\xfd\x13\x00\xc9\xfd\x39\x05\x32\x05\x29\x05\xc9\xfd\xc9\xfd\x14\x00\xc9\xfd\x24\x05\x1a\x05\x63\x05\x6d\x05\x56\x05\xc9\xfd\xc9\xfd\x60\x05\x69\x05\xc9\xfd\x15\x00\xc9\xfd\x68\x05\xc9\xfd\xc9\xfd\x55\x05\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xc9\xfd\xc9\xfd\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xc9\xfd\x83\x05\x24\x00\xc9\xfd\xc9\xfd\x9d\x05\x9a\x05\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x97\x05\x93\x05\x8f\x05\x8d\x05\xa2\x05\xa1\x05\x00\x00\xa5\x05\x00\x00\xc9\xfd\xc9\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\x00\x00\x00\x00\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\x00\x00\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\x00\x00\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\x00\x00\xc9\xfd\x8b\x01\xc9\xfd\x8c\x01\xc9\xfd\x8d\x01\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\x63\x00\x64\x00\xc9\xfd\xc9\xfd\xc9\xfd\x68\x00\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\xc9\xfd\x7d\xfe\x50\x00\x13\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x14\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x15\x00\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x7d\xfe\x7d\xfe\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x7d\xfe\x00\x00\x24\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x57\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x58\x00\x59\x00\x5a\x00\x7d\xfe\x5b\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x5c\x00\x00\x00\x00\x00\x03\x02\x7d\xfe\x5d\x00\x7d\xfe\x00\x00\x7d\xfe\x5e\x00\x7d\xfe\x5f\x00\x7d\xfe\x60\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x6c\x00\x6d\x00\x6e\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x6f\x00\x7d\xfe\x7d\xfe\x70\x00\x71\x00\x7d\xfe\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x00\x00\x31\xfd\x31\xfd\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x00\x00\x00\x00\x00\x00\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\xfe\x83\xfe\x00\x00\x00\x00\x83\xfe\x83\xfe\x83\xfe\x00\x00\x83\xfe\x83\xfe\x00\x00\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x00\x00\x83\xfe\x83\xfe\x83\xfe\x00\x00\x00\x00\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x00\x00\x00\x00\x83\xfe\x83\xfe\x05\x02\x06\x02\x00\x00\x84\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x00\x00\x00\x00\x83\xfe\x07\x02\x00\x00\x83\xfe\x00\x00\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\x83\xfe\xff\xfd\xff\xfd\xff\xfd\xff\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xff\xfd\xff\xfd\xff\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xfd\x00\x00\x00\x00\xff\xfd\xff\xfd\xff\xfd\x00\x00\xff\xfd\xff\xfd\x00\x00\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\x00\x00\xff\xfd\xff\xfd\xff\xfd\x00\x00\x00\x00\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xfd\xff\xfd\x82\x00\xc7\x01\xff\xfd\xff\xfd\x00\x00\x00\x00\xff\xfd\xff\xfd\xff\xfd\x00\x00\x00\x00\x00\x00\x84\x00\xff\xfd\xff\xfd\xff\xfd\x85\x00\xc8\x01\xc9\x01\xca\x01\xcb\x01\x86\x00\x00\x00\x00\x00\xff\xfd\x00\x00\x00\x00\xff\xfd\x00\x00\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\x53\x01\xff\xfd\xff\xfd\xff\xfd\x8c\x00\x8d\x00\xff\xfd\xff\xfd\x8f\x00\x90\x00\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xff\xfd\xf8\xfd\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xfd\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\xf8\xfd\x15\x00\xf8\xfd\x00\x00\xf8\xfd\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\xf8\xfd\xf8\xfd\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xfd\xf8\xfd\xf8\xfd\xf8\xfd\xf8\xfd\xae\x00\x00\x00\x00\x00\xf8\xfd\xf8\xfd\xf8\xfd\x00\x00\x00\x00\x00\x00\xf8\xfd\xb0\x00\xb1\x00\xb2\x00\xf8\xfd\xf8\xfd\xf8\xfd\xf8\xfd\xf8\xfd\xf8\xfd\x00\x00\x00\x00\xc5\x01\x00\x00\x00\x00\xf8\xfd\x00\x00\xf8\xfd\xb3\x00\xf8\xfd\xb4\x00\xf8\xfd\xb5\x00\xf8\xfd\xb6\x00\xf8\xfd\xf8\xfd\xf8\xfd\xf8\xfd\xb7\x00\x2c\x00\x8b\x00\xf8\xfd\xf8\xfd\x2d\x00\x8e\x00\xf8\xfd\xf8\xfd\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xf8\xfd\xd1\x00\xf8\xfd\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xf8\xfd\xf9\xfd\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfd\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\xf9\xfd\x15\x00\xf9\xfd\x00\x00\xf9\xfd\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\xf9\xfd\xf9\xfd\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfd\xf9\xfd\xf9\xfd\xf9\xfd\xf9\xfd\xae\x00\x00\x00\x00\x00\xf9\xfd\xf9\xfd\xf9\xfd\x00\x00\x00\x00\x00\x00\xf9\xfd\xb0\x00\xb1\x00\xb2\x00\xf9\xfd\xf9\xfd\xf9\xfd\xf9\xfd\xf9\xfd\xf9\xfd\x00\x00\x00\x00\xc5\x01\x00\x00\x00\x00\xf9\xfd\x00\x00\xf9\xfd\xb3\x00\xf9\xfd\xb4\x00\xf9\xfd\xb5\x00\xf9\xfd\xb6\x00\xf9\xfd\xf9\xfd\xf9\xfd\xf9\xfd\xb7\x00\x2c\x00\x8b\x00\xf9\xfd\xf9\xfd\x2d\x00\x8e\x00\xf9\xfd\xf9\xfd\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xf9\xfd\xd1\x00\xf9\xfd\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xf9\xfd\x1e\x02\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x82\x00\x85\x01\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x53\x01\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x1f\x02\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xba\x03\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\x1e\x02\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x82\x00\x52\x01\x99\xfe\x00\x00\x00\x00\x00\x00\x99\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x84\xfd\x00\x00\x84\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x53\x01\x00\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x1f\x02\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xc2\x03\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x88\x03\x71\x01\x72\x01\x73\x01\x00\x00\x74\x01\x6f\xfe\x6f\xfe\x00\x00\x19\x01\x00\x00\x00\x00\x74\x00\x1a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x49\xfe\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x00\x00\x1b\x01\x00\x00\x00\x00\x6f\xfe\x1c\x01\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x11\x00\x6f\xfe\x6f\xfe\x1d\x01\x6f\xfe\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x13\x00\xa7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\x6f\xfe\x14\x00\xa8\x00\x6f\xfe\x6f\xfe\xda\x00\xdb\x00\xdc\x00\xfc\x00\xdd\x00\x00\x00\xfd\x00\x00\x00\x15\x00\x00\x00\xfe\x00\x00\x00\x16\x00\xff\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x01\x01\xe3\x00\x02\x01\x03\x01\x00\x00\x00\x00\x04\x01\xe4\x00\x4d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x4e\x01\x00\x00\x4f\x01\x50\x01\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x78\x00\x00\x00\x79\x00\x7a\x00\x7b\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x7f\x00\x80\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xe7\xfc\xe7\xfc\xe7\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xfc\xe7\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xfc\x00\x00\x00\x00\x00\x00\xe7\xfc\x00\x00\x00\x00\x00\x00\xe7\xfc\x00\x00\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x00\x00\xe7\xfc\xb9\x04\xba\x04\x00\x00\x00\x00\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xfc\xe7\xfc\x00\x00\xe7\xfc\x00\x00\x00\x00\xe7\xfc\x00\x00\x00\x00\x00\x00\xe7\xfc\x00\x00\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x00\x00\xe7\xfc\xe7\xfc\x00\x00\xe7\xfc\x00\x00\x00\x00\x00\x00\xe7\xfc\xe7\xfc\xe7\xfc\x00\x00\xe7\xfc\x00\x00\xe7\xfc\x00\x00\x00\x00\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\x00\x00\xe7\xfc\x00\x00\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xe7\xfc\xa6\x00\x13\x00\xa7\x00\x00\x00\x98\x04\x99\x04\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x9a\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x9a\x01\x73\x00\x00\x00\x00\x00\xe4\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x9b\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x8e\x04\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x8f\x04\x00\x00\x15\x00\x00\x00\x90\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x4d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\xdb\x02\x00\x00\x4f\x01\x50\x01\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x78\x00\x00\x00\x79\x00\x7a\x00\x7b\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x7f\x00\x80\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x98\x04\x99\x04\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x9a\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x4d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x4e\x01\x00\x00\x4f\x01\x50\x01\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x78\x00\x00\x00\x79\x00\x7a\x00\x7b\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x7f\x00\x80\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x8e\x04\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x8f\x04\x00\x00\x15\x00\x00\x00\x90\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x82\x00\x52\x01\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x82\x00\x86\x00\x00\x00\xae\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x01\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x53\x01\x86\x00\x69\x01\x00\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\xb3\x00\x00\x00\xb4\x00\x6a\x01\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x6b\x01\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xcf\xfd\xcf\xfd\xcf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfd\xcf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfd\x00\x00\x00\x00\x00\x00\xcf\xfd\x00\x00\x00\x00\x00\x00\xcf\xfd\x00\x00\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\x00\x00\xcf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x03\x73\x01\x00\x00\x74\x01\x00\x00\x00\x00\x00\x00\x19\x01\x00\x00\x00\x00\x74\x00\x1a\x01\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\x00\x00\x00\x00\xcf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\x00\x00\x1b\x01\x00\x00\x00\x00\xcf\xfd\x1c\x01\xcf\xfd\xcf\xfd\x00\x00\xcf\xfd\x00\x00\x11\x00\x00\x00\xcf\xfd\x1d\x01\xcf\xfd\x00\x00\xcf\xfd\x00\x00\xcf\xfd\x00\x00\x00\x00\x00\x00\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\x00\x00\xcf\xfd\x00\x00\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xcf\xfd\xce\xfd\xce\xfd\xce\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfd\xce\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfd\x00\x00\x00\x00\x00\x00\xce\xfd\x00\x00\x00\x00\x00\x00\xce\xfd\x00\x00\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\x00\x00\xce\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfd\xce\xfd\xce\xfd\xce\xfd\x00\x00\x00\x00\xce\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfd\x00\x00\xce\xfd\xce\xfd\x00\x00\xce\xfd\x00\x00\x00\x00\x00\x00\xce\xfd\x00\x00\xce\xfd\x00\x00\xce\xfd\x00\x00\xce\xfd\x00\x00\x00\x00\x00\x00\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\x00\x00\xce\xfd\x00\x00\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xce\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x99\x03\xdb\xfd\x00\x00\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\x00\x00\xdb\xfd\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x82\x00\x37\x05\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x82\x00\x86\x00\x00\x00\xae\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x53\x01\x86\x00\x00\x00\x00\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x8f\x00\x90\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xa4\x01\xb6\x00\x00\x00\x00\x00\x6b\x01\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\xa9\xfd\xb5\x00\xa9\xfd\xb6\x00\x00\x00\x00\x00\x42\x02\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\xde\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x5c\x02\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x42\x02\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x5f\x02\xb6\x00\x00\x00\x00\x00\x42\x02\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\xda\x00\xdb\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xe6\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xa9\x01\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x46\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x01\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\xff\x01\x00\x02\x01\x02\x6c\x01\xb7\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x41\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\xbd\x01\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x03\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xba\x03\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\xab\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\xb0\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\xab\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xba\x03\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\xb0\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x0c\x04\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x01\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\xae\x00\xb1\x01\xb2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x02\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x66\x00\x00\x00\x00\x00\x69\x00\x6a\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xc8\xfe\xc8\xfe\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfe\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfe\x00\x00\x00\x00\x00\x00\xc8\xfe\x00\x00\x00\x00\x00\x00\xc8\xfe\x00\x00\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\x00\x00\xc8\xfe\x00\x00\x00\x00\x00\x00\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x03\x00\x00\xc8\xfe\x00\x00\xc8\xfe\x00\x00\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfe\xc8\xfe\xc8\xfe\x00\x00\x00\x00\xc8\xfe\xc8\xfe\x00\x00\x00\x00\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\x00\x00\xc8\xfe\x00\x00\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xc8\xfe\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x03\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xc2\x03\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xbf\xfe\xbf\xfe\xbf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfe\xbf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfe\x00\x00\x00\x00\x00\x00\xbf\xfe\x00\x00\x00\x00\x00\x00\x45\x03\x00\x00\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\x00\x00\xbf\xfe\x00\x00\x00\x00\x00\x00\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfe\x00\x00\xbf\xfe\x00\x00\xbf\xfe\x00\x00\xbf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfe\xbf\xfe\xbf\xfe\x00\x00\x00\x00\xbf\xfe\xbf\xfe\x00\x00\x00\x00\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\x00\x00\xbf\xfe\x00\x00\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xbf\xfe\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x84\xfd\x00\x00\x84\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xc0\xfe\xc0\xfe\xc0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfe\xc0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfe\x00\x00\x00\x00\x00\x00\xc0\xfe\x00\x00\x00\x00\x00\x00\x09\x05\x00\x00\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\x00\x00\xc0\xfe\x00\x00\x00\x00\x00\x00\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfe\x00\x00\xc0\xfe\x00\x00\xc0\xfe\x00\x00\xc0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xfe\xc0\xfe\xc0\xfe\x00\x00\x00\x00\xc0\xfe\xc0\xfe\x00\x00\x00\x00\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\x00\x00\xc0\xfe\x00\x00\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xc0\xfe\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xac\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\xa6\x03\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xc2\x03\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xaa\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\xb8\x00\xb9\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x00\x00\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\xa6\x00\x13\x00\x25\x02\x26\x02\x93\x05\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x02\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xf2\x01\xd1\x00\x00\x00\x6f\x00\xd2\x00\xd3\x00\x70\x00\x71\x00\x31\xfd\x31\xfd\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x03\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x31\xfd\x00\x00\x31\xfd\x43\x02\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x31\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x31\xfd\x31\xfd\x31\xfd\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x31\xfd\x00\x00\x00\x00\x31\xfd\x31\xfd\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\xde\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x6f\xfe\x6f\xfe\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x15\x00\x00\x00\x6f\xfe\x6f\xfe\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x01\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\xea\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\xe5\x01\x00\x00\x00\x00\x00\x00\x6b\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x01\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\xea\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x39\x01\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6f\x00\x00\x00\x00\x00\x70\x00\x71\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x3b\x01\x3c\x01\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x04\xf0\x02\x55\x00\x56\x00\x36\x00\x37\x00\x00\x00\xf1\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x57\x00\x3f\x00\x40\x00\x00\x00\xe5\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x43\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x51\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x52\x02\x59\x00\x5a\x00\x00\x00\x53\x02\x00\x00\x00\x00\x00\x00\x00\x00\x54\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x6a\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x61\x00\x62\x00\x63\x00\x64\x00\x55\x02\x56\x02\x67\x00\x68\x00\x69\x00\x57\x02\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\xec\x01\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x04\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\xfe\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xf6\x04\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x04\xf0\x02\x55\x00\x56\x00\x36\x00\x37\x00\x00\x00\xf1\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x57\x00\x3f\x00\x40\x00\x00\x00\x58\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x43\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\xe7\x04\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\xfe\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x05\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\xfe\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x05\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x05\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x51\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\xfe\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x02\xf0\x02\x55\x00\x56\x00\x36\x00\x37\x00\x00\x00\xf1\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x57\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x79\x03\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x43\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\xfe\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x03\xf0\x02\x55\x00\x56\x00\x36\x00\x37\x00\x00\x00\xf1\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x57\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\x79\x03\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x43\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x55\x00\x56\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x05\x3e\x00\x57\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x45\x05\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x42\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x15\x00\x00\x00\x70\x00\x71\x00\xfe\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x36\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x0a\x02\x3e\x00\x5c\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x50\x00\x13\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6f\x00\x00\x00\x00\x00\x70\x00\x71\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x4e\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6f\x00\x00\x00\x00\x00\x70\x00\x71\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xbf\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xf7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x41\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x01\x63\x00\x64\x00\x42\x00\x00\x00\x67\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\xbf\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xc0\x02\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x70\x00\x71\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\xbf\x02\x00\x00\x00\x00\x36\x00\x37\x00\x4e\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x37\x04\x00\x00\x00\x00\x18\x04\x00\x00\x1b\x04\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\xd3\x01\x00\x00\xd4\x01\x00\x00\x00\x00\x00\x00\xd5\x01\x00\x00\x00\x00\xd6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\xd7\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x00\x00\xd8\x01\x00\x00\x00\x00\x41\x00\x1c\x01\x4b\x00\x4c\x00\x4d\x00\xd9\x01\x7b\x00\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x42\x00\x00\x00\x4e\x00\x18\x04\x00\x00\x19\x04\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x18\x04\x00\x00\xe0\x04\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\xab\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xe0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\xab\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x4a\x03\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x13\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x81\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x05\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x62\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x82\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xac\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x57\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x43\x00\xee\x02\x59\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x42\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\x57\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x58\x02\x59\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\x57\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xd6\x03\x00\x00\x41\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x57\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xd5\x03\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x41\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\xd3\x03\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x03\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x57\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xd2\x03\x00\x00\x00\x00\x36\x00\x37\x00\x57\x02\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\xf5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x43\x00\x00\x00\x36\x00\x37\x00\x40\x04\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x44\x00\x45\x00\x5c\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x41\x00\x43\x00\x00\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x41\x00\x43\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\xea\x01\x39\x00\x3a\x00\x3b\x00\x42\x00\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x05\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x93\x01\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x43\x00\x00\x00\x36\x00\x37\x00\x57\x03\x39\x00\x3a\x00\x3b\x00\x29\x02\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x41\x00\x43\x00\x00\x00\x36\x00\x37\x00\x40\x04\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x41\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x3d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x36\x00\x37\x00\x41\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x35\x04\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x4e\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x21\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x41\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x41\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xf1\x03\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x2a\x05\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x28\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x5f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x43\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x36\x00\x37\x00\x43\x00\x09\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x4e\x00\x65\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x32\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x2d\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x2c\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x2a\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xde\x03\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xd8\x03\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\x26\x05\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\xac\x04\x00\x00\x00\x00\xad\x04\xae\x04\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\xed\x04\xee\x04\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\xaf\x04\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x02\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x03\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x04\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x04\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x05\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x05\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x05\x00\x00\x36\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x02\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x13\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x03\x52\x03\x53\x03\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xf2\x01\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x54\x03\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x14\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\xf2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x2c\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\xd7\x04\x2a\x00\x54\x03\x13\x00\x00\x00\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x14\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x25\x02\x26\x02\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xb3\x03\xb4\x03\x24\x00\x00\x00\x00\x00\x27\x02\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x26\x02\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x27\x02\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xb5\x03\xb3\x03\xb4\x03\x25\x02\x26\x02\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\xb6\x03\x00\x00\xb7\x03\x00\x00\xb8\x03\x00\x00\x27\x02\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xb3\x03\xb4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\xba\x03\x00\x00\xb7\x03\x00\x00\xb8\x03\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xb3\x03\xb4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x06\x04\x00\x00\xb7\x03\x00\x00\xb8\x03\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x90\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\xae\x01\xbc\x03\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xbd\x03\xae\x01\xbc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x03\x00\x00\xbf\x03\x00\x00\xc0\x03\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xae\x01\xbc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xc2\x03\x00\x00\xbf\x03\x00\x00\xc0\x03\x9f\x00\xa0\x00\xad\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x01\xbc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\xfe\x03\x00\x00\xbf\x03\x00\x00\xc0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x15\x00\x7d\x00\x7e\x00\x00\x00\x16\x00\xa3\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xbe\x04\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x13\x00\x88\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x8a\x00\x00\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x02\x13\x00\xdb\x01\x00\x00\xdc\x01\x00\x00\x89\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x00\x00\x8e\x00\x15\x00\x90\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x05\x00\x00\x00\x00\x15\x00\x00\x00\x72\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x7b\x05\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x71\x04\x00\x00\x00\x00\x15\x00\x00\x00\x72\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x73\x04\x74\x04\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x7c\x05\x00\x00\x13\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x68\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x05\x00\x00\x00\x00\x15\x00\x00\x00\x72\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x7b\x05\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x74\x04\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x0a\xfe\x74\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x68\x00\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x0a\xfe\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x87\x00\x00\x00\x9d\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x7a\x01\x00\x00\x0a\xfe\x14\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x0a\xfe\x00\x00\x15\x00\x0a\xfe\x0a\xfe\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x72\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x87\x00\x00\x00\x9d\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x14\x00\x00\x00\x21\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x74\x04\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x00\x00\xdc\x01\x14\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x15\x00\x00\x00\x8e\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x15\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x01\x00\x00\x00\x00\x2c\x00\x8b\x00\x0a\xfe\x00\x00\x00\x00\x8e\x00\x0a\xfe\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x64\x00\x0a\xfe\x00\x00\x00\x00\x68\x00\x0a\xfe\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x01\x00\x00\x0a\xfe\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x7a\x01\x00\x00\x0a\xfe\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x13\x00\x00\x00\x0a\xfe\x00\x00\x00\x00\x00\x00\x0a\xfe\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x6e\x02\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x13\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x90\x00\x00\x00\x00\x00\xe1\x02\xe2\x02\x00\x00\xe3\x02\x95\x00\x96\x00\x97\x00\x98\x00\x84\x00\x00\x00\x99\x00\x9a\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x76\x01\x6a\x01\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x2c\x00\x8b\x00\x8c\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x90\x00\x74\x00\x75\x00\x74\x03\xe2\x02\x00\x00\xe3\x02\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x58\x01\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x01\x5a\x01\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x60\x01\xa4\x01\x62\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x63\x01\x80\x00\xa3\x00\x00\x00\x00\x00\x64\x01\x00\x00\x65\x01\x00\x00\x13\x00\xa4\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\x14\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x58\x01\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x15\x00\x00\x00\x59\x01\x5a\x01\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x60\x01\x61\x01\x62\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x63\x01\x80\x00\xa3\x00\x00\x00\x00\x00\x64\x01\x2c\x00\x65\x01\x00\x00\x13\x00\xa4\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\x14\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x15\x00\x00\x00\x9e\x01\x9f\x01\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\xa2\x01\x63\x00\x65\x01\x00\x00\x00\x00\xa4\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x01\x00\x00\x00\x00\x00\x00\xa6\x01\xa7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x02\x00\x00\x00\x00\x8e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x02\x00\x00\x00\x00\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\xa8\x03\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x56\x01\x57\x01\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\xa0\x01\x00\x00\xa1\x01\x11\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\xa3\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\xa4\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x03\xab\x03\xac\x03\xad\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\xb7\x04\xac\x03\xad\x03\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x04\x01\x05\x01\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\xa4\x00\x9d\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x97\x02\x00\x00\xa4\x00\x96\x02\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x95\x02\x00\x00\xa4\x00\x96\x02\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x74\x02\x75\x02\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x76\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x6f\x03\x75\x02\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x76\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xb8\x01\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xb9\x01\xba\x01\xbb\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x04\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xb5\x04\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xb6\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x90\x00\x91\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xfb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\xe7\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x46\x03\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xe6\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x45\x03\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xe8\x00\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xc5\x01\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xbe\x01\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x95\x01\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x8f\x01\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x70\x02\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x64\x02\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x63\x02\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x62\x02\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x61\x02\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xc5\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xc4\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xb2\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xb0\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x70\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x14\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x0a\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xfc\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xfa\x03\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xbc\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xb4\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x9b\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x0a\x05\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xdf\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xde\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\xdd\x04\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x47\x05\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x90\x00\x57\x05\x92\x00\x00\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x17\x00\x18\x00\x19\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\xa2\x00\x13\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x1f\x01\x00\x00\x00\x00\x15\x00\x00\x00\x20\x01\xa4\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x26\x02\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x21\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x87\x00\x00\x00\x76\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8b\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x31\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x87\x00\x00\x00\x21\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8b\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x76\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x87\x00\x00\x00\x21\x01\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8b\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8b\x00\x00\x00\x00\x00\xf6\xfe\x00\x00\x15\x00\x00\x00\x00\x00\xf6\xfe\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x0e\x03\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\xbb\x02\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xf2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x4e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xf2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x4e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\xfc\x01\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xfd\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xfd\x01\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x94\x01\x00\x00\x93\x00\x00\x00\x63\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\xd6\x02\x00\x00\x93\x00\x00\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x90\x00\xa3\x00\x4e\x04\x00\x00\x93\x00\x00\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf6\x04\x00\x00\x93\x00\x00\x00\x00\x00\x95\x00\x96\x00\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xad\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x01\xaf\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\xae\x01\x86\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\xa3\x03\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\xa4\x03\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\xc3\x01\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\xb4\x01\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\xab\x01\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x01\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\xa9\x01\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x9d\x01\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x03\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x22\x03\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\xc3\x01\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x02\x97\x00\x98\x00\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x39\x03\x97\x00\x98\x00\x74\x00\x75\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x90\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\xd2\x01\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x90\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x01\x00\x00\x00\x00\x99\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x73\x00\x00\x00\x00\x00\x00\x00\x74\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x8e\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7d\x00\x7e\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (13, 855) [ - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241), - (242 , happyReduce_242), - (243 , happyReduce_243), - (244 , happyReduce_244), - (245 , happyReduce_245), - (246 , happyReduce_246), - (247 , happyReduce_247), - (248 , happyReduce_248), - (249 , happyReduce_249), - (250 , happyReduce_250), - (251 , happyReduce_251), - (252 , happyReduce_252), - (253 , happyReduce_253), - (254 , happyReduce_254), - (255 , happyReduce_255), - (256 , happyReduce_256), - (257 , happyReduce_257), - (258 , happyReduce_258), - (259 , happyReduce_259), - (260 , happyReduce_260), - (261 , happyReduce_261), - (262 , happyReduce_262), - (263 , happyReduce_263), - (264 , happyReduce_264), - (265 , happyReduce_265), - (266 , happyReduce_266), - (267 , happyReduce_267), - (268 , happyReduce_268), - (269 , happyReduce_269), - (270 , happyReduce_270), - (271 , happyReduce_271), - (272 , happyReduce_272), - (273 , happyReduce_273), - (274 , happyReduce_274), - (275 , happyReduce_275), - (276 , happyReduce_276), - (277 , happyReduce_277), - (278 , happyReduce_278), - (279 , happyReduce_279), - (280 , happyReduce_280), - (281 , happyReduce_281), - (282 , happyReduce_282), - (283 , happyReduce_283), - (284 , happyReduce_284), - (285 , happyReduce_285), - (286 , happyReduce_286), - (287 , happyReduce_287), - (288 , happyReduce_288), - (289 , happyReduce_289), - (290 , happyReduce_290), - (291 , happyReduce_291), - (292 , happyReduce_292), - (293 , happyReduce_293), - (294 , happyReduce_294), - (295 , happyReduce_295), - (296 , happyReduce_296), - (297 , happyReduce_297), - (298 , happyReduce_298), - (299 , happyReduce_299), - (300 , happyReduce_300), - (301 , happyReduce_301), - (302 , happyReduce_302), - (303 , happyReduce_303), - (304 , happyReduce_304), - (305 , happyReduce_305), - (306 , happyReduce_306), - (307 , happyReduce_307), - (308 , happyReduce_308), - (309 , happyReduce_309), - (310 , happyReduce_310), - (311 , happyReduce_311), - (312 , happyReduce_312), - (313 , happyReduce_313), - (314 , happyReduce_314), - (315 , happyReduce_315), - (316 , happyReduce_316), - (317 , happyReduce_317), - (318 , happyReduce_318), - (319 , happyReduce_319), - (320 , happyReduce_320), - (321 , happyReduce_321), - (322 , happyReduce_322), - (323 , happyReduce_323), - (324 , happyReduce_324), - (325 , happyReduce_325), - (326 , happyReduce_326), - (327 , happyReduce_327), - (328 , happyReduce_328), - (329 , happyReduce_329), - (330 , happyReduce_330), - (331 , happyReduce_331), - (332 , happyReduce_332), - (333 , happyReduce_333), - (334 , happyReduce_334), - (335 , happyReduce_335), - (336 , happyReduce_336), - (337 , happyReduce_337), - (338 , happyReduce_338), - (339 , happyReduce_339), - (340 , happyReduce_340), - (341 , happyReduce_341), - (342 , happyReduce_342), - (343 , happyReduce_343), - (344 , happyReduce_344), - (345 , happyReduce_345), - (346 , happyReduce_346), - (347 , happyReduce_347), - (348 , happyReduce_348), - (349 , happyReduce_349), - (350 , happyReduce_350), - (351 , happyReduce_351), - (352 , happyReduce_352), - (353 , happyReduce_353), - (354 , happyReduce_354), - (355 , happyReduce_355), - (356 , happyReduce_356), - (357 , happyReduce_357), - (358 , happyReduce_358), - (359 , happyReduce_359), - (360 , happyReduce_360), - (361 , happyReduce_361), - (362 , happyReduce_362), - (363 , happyReduce_363), - (364 , happyReduce_364), - (365 , happyReduce_365), - (366 , happyReduce_366), - (367 , happyReduce_367), - (368 , happyReduce_368), - (369 , happyReduce_369), - (370 , happyReduce_370), - (371 , happyReduce_371), - (372 , happyReduce_372), - (373 , happyReduce_373), - (374 , happyReduce_374), - (375 , happyReduce_375), - (376 , happyReduce_376), - (377 , happyReduce_377), - (378 , happyReduce_378), - (379 , happyReduce_379), - (380 , happyReduce_380), - (381 , happyReduce_381), - (382 , happyReduce_382), - (383 , happyReduce_383), - (384 , happyReduce_384), - (385 , happyReduce_385), - (386 , happyReduce_386), - (387 , happyReduce_387), - (388 , happyReduce_388), - (389 , happyReduce_389), - (390 , happyReduce_390), - (391 , happyReduce_391), - (392 , happyReduce_392), - (393 , happyReduce_393), - (394 , happyReduce_394), - (395 , happyReduce_395), - (396 , happyReduce_396), - (397 , happyReduce_397), - (398 , happyReduce_398), - (399 , happyReduce_399), - (400 , happyReduce_400), - (401 , happyReduce_401), - (402 , happyReduce_402), - (403 , happyReduce_403), - (404 , happyReduce_404), - (405 , happyReduce_405), - (406 , happyReduce_406), - (407 , happyReduce_407), - (408 , happyReduce_408), - (409 , happyReduce_409), - (410 , happyReduce_410), - (411 , happyReduce_411), - (412 , happyReduce_412), - (413 , happyReduce_413), - (414 , happyReduce_414), - (415 , happyReduce_415), - (416 , happyReduce_416), - (417 , happyReduce_417), - (418 , happyReduce_418), - (419 , happyReduce_419), - (420 , happyReduce_420), - (421 , happyReduce_421), - (422 , happyReduce_422), - (423 , happyReduce_423), - (424 , happyReduce_424), - (425 , happyReduce_425), - (426 , happyReduce_426), - (427 , happyReduce_427), - (428 , happyReduce_428), - (429 , happyReduce_429), - (430 , happyReduce_430), - (431 , happyReduce_431), - (432 , happyReduce_432), - (433 , happyReduce_433), - (434 , happyReduce_434), - (435 , happyReduce_435), - (436 , happyReduce_436), - (437 , happyReduce_437), - (438 , happyReduce_438), - (439 , happyReduce_439), - (440 , happyReduce_440), - (441 , happyReduce_441), - (442 , happyReduce_442), - (443 , happyReduce_443), - (444 , happyReduce_444), - (445 , happyReduce_445), - (446 , happyReduce_446), - (447 , happyReduce_447), - (448 , happyReduce_448), - (449 , happyReduce_449), - (450 , happyReduce_450), - (451 , happyReduce_451), - (452 , happyReduce_452), - (453 , happyReduce_453), - (454 , happyReduce_454), - (455 , happyReduce_455), - (456 , happyReduce_456), - (457 , happyReduce_457), - (458 , happyReduce_458), - (459 , happyReduce_459), - (460 , happyReduce_460), - (461 , happyReduce_461), - (462 , happyReduce_462), - (463 , happyReduce_463), - (464 , happyReduce_464), - (465 , happyReduce_465), - (466 , happyReduce_466), - (467 , happyReduce_467), - (468 , happyReduce_468), - (469 , happyReduce_469), - (470 , happyReduce_470), - (471 , happyReduce_471), - (472 , happyReduce_472), - (473 , happyReduce_473), - (474 , happyReduce_474), - (475 , happyReduce_475), - (476 , happyReduce_476), - (477 , happyReduce_477), - (478 , happyReduce_478), - (479 , happyReduce_479), - (480 , happyReduce_480), - (481 , happyReduce_481), - (482 , happyReduce_482), - (483 , happyReduce_483), - (484 , happyReduce_484), - (485 , happyReduce_485), - (486 , happyReduce_486), - (487 , happyReduce_487), - (488 , happyReduce_488), - (489 , happyReduce_489), - (490 , happyReduce_490), - (491 , happyReduce_491), - (492 , happyReduce_492), - (493 , happyReduce_493), - (494 , happyReduce_494), - (495 , happyReduce_495), - (496 , happyReduce_496), - (497 , happyReduce_497), - (498 , happyReduce_498), - (499 , happyReduce_499), - (500 , happyReduce_500), - (501 , happyReduce_501), - (502 , happyReduce_502), - (503 , happyReduce_503), - (504 , happyReduce_504), - (505 , happyReduce_505), - (506 , happyReduce_506), - (507 , happyReduce_507), - (508 , happyReduce_508), - (509 , happyReduce_509), - (510 , happyReduce_510), - (511 , happyReduce_511), - (512 , happyReduce_512), - (513 , happyReduce_513), - (514 , happyReduce_514), - (515 , happyReduce_515), - (516 , happyReduce_516), - (517 , happyReduce_517), - (518 , happyReduce_518), - (519 , happyReduce_519), - (520 , happyReduce_520), - (521 , happyReduce_521), - (522 , happyReduce_522), - (523 , happyReduce_523), - (524 , happyReduce_524), - (525 , happyReduce_525), - (526 , happyReduce_526), - (527 , happyReduce_527), - (528 , happyReduce_528), - (529 , happyReduce_529), - (530 , happyReduce_530), - (531 , happyReduce_531), - (532 , happyReduce_532), - (533 , happyReduce_533), - (534 , happyReduce_534), - (535 , happyReduce_535), - (536 , happyReduce_536), - (537 , happyReduce_537), - (538 , happyReduce_538), - (539 , happyReduce_539), - (540 , happyReduce_540), - (541 , happyReduce_541), - (542 , happyReduce_542), - (543 , happyReduce_543), - (544 , happyReduce_544), - (545 , happyReduce_545), - (546 , happyReduce_546), - (547 , happyReduce_547), - (548 , happyReduce_548), - (549 , happyReduce_549), - (550 , happyReduce_550), - (551 , happyReduce_551), - (552 , happyReduce_552), - (553 , happyReduce_553), - (554 , happyReduce_554), - (555 , happyReduce_555), - (556 , happyReduce_556), - (557 , happyReduce_557), - (558 , happyReduce_558), - (559 , happyReduce_559), - (560 , happyReduce_560), - (561 , happyReduce_561), - (562 , happyReduce_562), - (563 , happyReduce_563), - (564 , happyReduce_564), - (565 , happyReduce_565), - (566 , happyReduce_566), - (567 , happyReduce_567), - (568 , happyReduce_568), - (569 , happyReduce_569), - (570 , happyReduce_570), - (571 , happyReduce_571), - (572 , happyReduce_572), - (573 , happyReduce_573), - (574 , happyReduce_574), - (575 , happyReduce_575), - (576 , happyReduce_576), - (577 , happyReduce_577), - (578 , happyReduce_578), - (579 , happyReduce_579), - (580 , happyReduce_580), - (581 , happyReduce_581), - (582 , happyReduce_582), - (583 , happyReduce_583), - (584 , happyReduce_584), - (585 , happyReduce_585), - (586 , happyReduce_586), - (587 , happyReduce_587), - (588 , happyReduce_588), - (589 , happyReduce_589), - (590 , happyReduce_590), - (591 , happyReduce_591), - (592 , happyReduce_592), - (593 , happyReduce_593), - (594 , happyReduce_594), - (595 , happyReduce_595), - (596 , happyReduce_596), - (597 , happyReduce_597), - (598 , happyReduce_598), - (599 , happyReduce_599), - (600 , happyReduce_600), - (601 , happyReduce_601), - (602 , happyReduce_602), - (603 , happyReduce_603), - (604 , happyReduce_604), - (605 , happyReduce_605), - (606 , happyReduce_606), - (607 , happyReduce_607), - (608 , happyReduce_608), - (609 , happyReduce_609), - (610 , happyReduce_610), - (611 , happyReduce_611), - (612 , happyReduce_612), - (613 , happyReduce_613), - (614 , happyReduce_614), - (615 , happyReduce_615), - (616 , happyReduce_616), - (617 , happyReduce_617), - (618 , happyReduce_618), - (619 , happyReduce_619), - (620 , happyReduce_620), - (621 , happyReduce_621), - (622 , happyReduce_622), - (623 , happyReduce_623), - (624 , happyReduce_624), - (625 , happyReduce_625), - (626 , happyReduce_626), - (627 , happyReduce_627), - (628 , happyReduce_628), - (629 , happyReduce_629), - (630 , happyReduce_630), - (631 , happyReduce_631), - (632 , happyReduce_632), - (633 , happyReduce_633), - (634 , happyReduce_634), - (635 , happyReduce_635), - (636 , happyReduce_636), - (637 , happyReduce_637), - (638 , happyReduce_638), - (639 , happyReduce_639), - (640 , happyReduce_640), - (641 , happyReduce_641), - (642 , happyReduce_642), - (643 , happyReduce_643), - (644 , happyReduce_644), - (645 , happyReduce_645), - (646 , happyReduce_646), - (647 , happyReduce_647), - (648 , happyReduce_648), - (649 , happyReduce_649), - (650 , happyReduce_650), - (651 , happyReduce_651), - (652 , happyReduce_652), - (653 , happyReduce_653), - (654 , happyReduce_654), - (655 , happyReduce_655), - (656 , happyReduce_656), - (657 , happyReduce_657), - (658 , happyReduce_658), - (659 , happyReduce_659), - (660 , happyReduce_660), - (661 , happyReduce_661), - (662 , happyReduce_662), - (663 , happyReduce_663), - (664 , happyReduce_664), - (665 , happyReduce_665), - (666 , happyReduce_666), - (667 , happyReduce_667), - (668 , happyReduce_668), - (669 , happyReduce_669), - (670 , happyReduce_670), - (671 , happyReduce_671), - (672 , happyReduce_672), - (673 , happyReduce_673), - (674 , happyReduce_674), - (675 , happyReduce_675), - (676 , happyReduce_676), - (677 , happyReduce_677), - (678 , happyReduce_678), - (679 , happyReduce_679), - (680 , happyReduce_680), - (681 , happyReduce_681), - (682 , happyReduce_682), - (683 , happyReduce_683), - (684 , happyReduce_684), - (685 , happyReduce_685), - (686 , happyReduce_686), - (687 , happyReduce_687), - (688 , happyReduce_688), - (689 , happyReduce_689), - (690 , happyReduce_690), - (691 , happyReduce_691), - (692 , happyReduce_692), - (693 , happyReduce_693), - (694 , happyReduce_694), - (695 , happyReduce_695), - (696 , happyReduce_696), - (697 , happyReduce_697), - (698 , happyReduce_698), - (699 , happyReduce_699), - (700 , happyReduce_700), - (701 , happyReduce_701), - (702 , happyReduce_702), - (703 , happyReduce_703), - (704 , happyReduce_704), - (705 , happyReduce_705), - (706 , happyReduce_706), - (707 , happyReduce_707), - (708 , happyReduce_708), - (709 , happyReduce_709), - (710 , happyReduce_710), - (711 , happyReduce_711), - (712 , happyReduce_712), - (713 , happyReduce_713), - (714 , happyReduce_714), - (715 , happyReduce_715), - (716 , happyReduce_716), - (717 , happyReduce_717), - (718 , happyReduce_718), - (719 , happyReduce_719), - (720 , happyReduce_720), - (721 , happyReduce_721), - (722 , happyReduce_722), - (723 , happyReduce_723), - (724 , happyReduce_724), - (725 , happyReduce_725), - (726 , happyReduce_726), - (727 , happyReduce_727), - (728 , happyReduce_728), - (729 , happyReduce_729), - (730 , happyReduce_730), - (731 , happyReduce_731), - (732 , happyReduce_732), - (733 , happyReduce_733), - (734 , happyReduce_734), - (735 , happyReduce_735), - (736 , happyReduce_736), - (737 , happyReduce_737), - (738 , happyReduce_738), - (739 , happyReduce_739), - (740 , happyReduce_740), - (741 , happyReduce_741), - (742 , happyReduce_742), - (743 , happyReduce_743), - (744 , happyReduce_744), - (745 , happyReduce_745), - (746 , happyReduce_746), - (747 , happyReduce_747), - (748 , happyReduce_748), - (749 , happyReduce_749), - (750 , happyReduce_750), - (751 , happyReduce_751), - (752 , happyReduce_752), - (753 , happyReduce_753), - (754 , happyReduce_754), - (755 , happyReduce_755), - (756 , happyReduce_756), - (757 , happyReduce_757), - (758 , happyReduce_758), - (759 , happyReduce_759), - (760 , happyReduce_760), - (761 , happyReduce_761), - (762 , happyReduce_762), - (763 , happyReduce_763), - (764 , happyReduce_764), - (765 , happyReduce_765), - (766 , happyReduce_766), - (767 , happyReduce_767), - (768 , happyReduce_768), - (769 , happyReduce_769), - (770 , happyReduce_770), - (771 , happyReduce_771), - (772 , happyReduce_772), - (773 , happyReduce_773), - (774 , happyReduce_774), - (775 , happyReduce_775), - (776 , happyReduce_776), - (777 , happyReduce_777), - (778 , happyReduce_778), - (779 , happyReduce_779), - (780 , happyReduce_780), - (781 , happyReduce_781), - (782 , happyReduce_782), - (783 , happyReduce_783), - (784 , happyReduce_784), - (785 , happyReduce_785), - (786 , happyReduce_786), - (787 , happyReduce_787), - (788 , happyReduce_788), - (789 , happyReduce_789), - (790 , happyReduce_790), - (791 , happyReduce_791), - (792 , happyReduce_792), - (793 , happyReduce_793), - (794 , happyReduce_794), - (795 , happyReduce_795), - (796 , happyReduce_796), - (797 , happyReduce_797), - (798 , happyReduce_798), - (799 , happyReduce_799), - (800 , happyReduce_800), - (801 , happyReduce_801), - (802 , happyReduce_802), - (803 , happyReduce_803), - (804 , happyReduce_804), - (805 , happyReduce_805), - (806 , happyReduce_806), - (807 , happyReduce_807), - (808 , happyReduce_808), - (809 , happyReduce_809), - (810 , happyReduce_810), - (811 , happyReduce_811), - (812 , happyReduce_812), - (813 , happyReduce_813), - (814 , happyReduce_814), - (815 , happyReduce_815), - (816 , happyReduce_816), - (817 , happyReduce_817), - (818 , happyReduce_818), - (819 , happyReduce_819), - (820 , happyReduce_820), - (821 , happyReduce_821), - (822 , happyReduce_822), - (823 , happyReduce_823), - (824 , happyReduce_824), - (825 , happyReduce_825), - (826 , happyReduce_826), - (827 , happyReduce_827), - (828 , happyReduce_828), - (829 , happyReduce_829), - (830 , happyReduce_830), - (831 , happyReduce_831), - (832 , happyReduce_832), - (833 , happyReduce_833), - (834 , happyReduce_834), - (835 , happyReduce_835), - (836 , happyReduce_836), - (837 , happyReduce_837), - (838 , happyReduce_838), - (839 , happyReduce_839), - (840 , happyReduce_840), - (841 , happyReduce_841), - (842 , happyReduce_842), - (843 , happyReduce_843), - (844 , happyReduce_844), - (845 , happyReduce_845), - (846 , happyReduce_846), - (847 , happyReduce_847), - (848 , happyReduce_848), - (849 , happyReduce_849), - (850 , happyReduce_850), - (851 , happyReduce_851), - (852 , happyReduce_852), - (853 , happyReduce_853), - (854 , happyReduce_854), - (855 , happyReduce_855) - ] - -happy_n_terms = 159 :: Prelude.Int -happy_n_nonterms = 319 :: Prelude.Int - -happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_13 = happySpecReduce_1 0# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn16 - (happy_var_1 - )} - -happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_14 = happySpecReduce_1 0# happyReduction_14 -happyReduction_14 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn16 - (happy_var_1 - )} - -happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_15 = happySpecReduce_1 0# happyReduction_15 -happyReduction_15 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn16 - (happy_var_1 - )} - -happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_16 = happySpecReduce_1 0# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn16 - (happy_var_1 - )} - -happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_17 = happyMonadReduce 3# 0# happyReduction_17 -happyReduction_17 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon) - (NameAnnRArrow (isUnicode happy_var_2) (Just $ glAA happy_var_1) (glAA happy_var_2) (Just $ glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn16 r)) - -happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_18 = happyMonadReduce 1# 0# happyReduction_18 -happyReduction_18 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( amsrn (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon) - (NameAnnRArrow (isUnicode happy_var_1) Nothing (glAA happy_var_1) Nothing []))}) - ) (\r -> happyReturn (happyIn16 r)) - -happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_19 = happySpecReduce_3 1# happyReduction_19 -happyReduction_19 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> - happyIn17 - (fromOL happy_var_2 - )} - -happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_20 = happySpecReduce_3 1# happyReduction_20 -happyReduction_20 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> - happyIn17 - (fromOL happy_var_2 - )} - -happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_21 = happySpecReduce_3 2# happyReduction_21 -happyReduction_21 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> - case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> - happyIn18 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_22 = happySpecReduce_2 2# happyReduction_22 -happyReduction_22 happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> - happyIn18 - (happy_var_1 - )} - -happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_23 = happySpecReduce_1 2# happyReduction_23 -happyReduction_23 happy_x_1 - = case happyOut19 happy_x_1 of { (HappyWrap19 happy_var_1) -> - happyIn18 - (unitOL happy_var_1 - )} - -happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_24 = happyReduce 4# 3# happyReduction_24 -happyReduction_24 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { (HappyWrap24 happy_var_2) -> - case happyOut31 happy_x_4 of { (HappyWrap31 happy_var_4) -> - happyIn19 - (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2 - , hsunitBody = fromOL happy_var_4 } - ) `HappyStk` happyRest}}} - -happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_25 = happySpecReduce_1 4# happyReduction_25 -happyReduction_25 happy_x_1 - = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> - happyIn20 - (sL1 happy_var_1 $ HsUnitId happy_var_1 [] - )} - -happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_26 = happyReduce 4# 4# happyReduction_26 -happyReduction_26 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> - case happyOut21 happy_x_3 of { (HappyWrap21 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn20 - (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_27 = happySpecReduce_3 5# happyReduction_27 -happyReduction_27 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> - case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> - happyIn21 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_28 = happySpecReduce_2 5# happyReduction_28 -happyReduction_28 happy_x_2 - happy_x_1 - = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> - happyIn21 - (happy_var_1 - )} - -happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_29 = happySpecReduce_1 5# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> - happyIn21 - (unitOL happy_var_1 - )} - -happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_30 = happySpecReduce_3 6# happyReduction_30 -happyReduction_30 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> - case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> - happyIn22 - (sLL (reLoc happy_var_1) happy_var_3 $ (reLoc happy_var_1, happy_var_3) - )}} - -happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_31 = happyReduce 4# 6# happyReduction_31 -happyReduction_31 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn22 - (sLL (reLoc happy_var_1) happy_var_4 $ (reLoc happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar (reLoc happy_var_3)) - ) `HappyStk` happyRest}}}} - -happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_32 = happySpecReduce_3 7# happyReduction_32 -happyReduction_32 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn23 - (sLL happy_var_1 happy_var_3 $ HsModuleVar (reLoc happy_var_2) - )}}} - -happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_33 = happySpecReduce_3 7# happyReduction_33 -happyReduction_33 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> - case happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> - happyIn23 - (sLL happy_var_1 (reLoc happy_var_3) $ HsModuleId happy_var_1 (reLoc happy_var_3) - )}} - -happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_34 = happySpecReduce_1 8# happyReduction_34 -happyReduction_34 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn24 - (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1) - )} - -happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_35 = happySpecReduce_1 8# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> - happyIn24 - (sL1 happy_var_1 $ PackageName (unLoc happy_var_1) - )} - -happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_36 = happySpecReduce_1 9# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn25 - (sL1 happy_var_1 $ getVARID happy_var_1 - )} - -happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_37 = happySpecReduce_1 9# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn25 - (sL1 happy_var_1 $ getCONID happy_var_1 - )} - -happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_38 = happySpecReduce_1 9# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> - happyIn25 - (happy_var_1 - )} - -happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_39 = happySpecReduce_1 10# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn26 - ([mj AnnMinus happy_var_1 ] - )} - -happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_40 = happySpecReduce_1 10# happyReduction_40 -happyReduction_40 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn26 - ([mj AnnMinus happy_var_1 ] - )} - -happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_41 = happyMonadReduce 1# 10# happyReduction_41 -happyReduction_41 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( if (getVARSYM happy_var_1 == fsLit "-") - then return [mj AnnMinus happy_var_1] - else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ PsErrExpectedHyphen - ; return [] })}) - ) (\r -> happyReturn (happyIn26 r)) - -happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_42 = happySpecReduce_1 11# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> - happyIn27 - (happy_var_1 - )} - -happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_43 = happySpecReduce_3 11# happyReduction_43 -happyReduction_43 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> - case happyOut27 happy_x_3 of { (HappyWrap27 happy_var_3) -> - happyIn27 - (sLL happy_var_1 happy_var_3 $ concatFS [unLoc happy_var_1, fsLit "-", (unLoc happy_var_3)] - )}} - -happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_44 = happySpecReduce_0 12# happyReduction_44 -happyReduction_44 = happyIn28 - (Nothing - ) - -happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_45 = happySpecReduce_3 12# happyReduction_45 -happyReduction_45 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_2 of { (HappyWrap29 happy_var_2) -> - happyIn28 - (Just (fromOL happy_var_2) - )} - -happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_46 = happySpecReduce_3 13# happyReduction_46 -happyReduction_46 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> - case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> - happyIn29 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_47 = happySpecReduce_2 13# happyReduction_47 -happyReduction_47 happy_x_2 - happy_x_1 - = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> - happyIn29 - (happy_var_1 - )} - -happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_48 = happySpecReduce_1 13# happyReduction_48 -happyReduction_48 happy_x_1 - = case happyOut30 happy_x_1 of { (HappyWrap30 happy_var_1) -> - happyIn29 - (unitOL happy_var_1 - )} - -happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_49 = happySpecReduce_3 14# happyReduction_49 -happyReduction_49 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> - case happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> - happyIn30 - (sLL (reLoc happy_var_1) (reLoc happy_var_3) $ Renaming (reLoc happy_var_1) (Just (reLoc happy_var_3)) - )}} - -happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_50 = happySpecReduce_1 14# happyReduction_50 -happyReduction_50 happy_x_1 - = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> - happyIn30 - (sL1 (reLoc happy_var_1) $ Renaming (reLoc happy_var_1) Nothing - )} - -happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_51 = happySpecReduce_3 15# happyReduction_51 -happyReduction_51 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> - happyIn31 - (happy_var_2 - )} - -happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_52 = happySpecReduce_3 15# happyReduction_52 -happyReduction_52 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> - happyIn31 - (happy_var_2 - )} - -happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_53 = happySpecReduce_3 16# happyReduction_53 -happyReduction_53 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> - case happyOut33 happy_x_3 of { (HappyWrap33 happy_var_3) -> - happyIn32 - (happy_var_1 `appOL` unitOL happy_var_3 - )}} - -happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_54 = happySpecReduce_2 16# happyReduction_54 -happyReduction_54 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> - happyIn32 - (happy_var_1 - )} - -happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_55 = happySpecReduce_1 16# happyReduction_55 -happyReduction_55 happy_x_1 - = case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> - happyIn32 - (unitOL happy_var_1 - )} - -happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_56 = happyReduce 7# 17# happyReduction_56 -happyReduction_56 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut64 happy_x_2 of { (HappyWrap64 happy_var_2) -> - case happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> - case happyOut38 happy_x_4 of { (HappyWrap38 happy_var_4) -> - case happyOut48 happy_x_5 of { (HappyWrap48 happy_var_5) -> - case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> - happyIn33 - (sL1 happy_var_1 $ DeclD - (case snd happy_var_2 of - NotBoot -> HsSrcFile - IsBoot -> HsBootFile) - (reLoc happy_var_3) - (sL1 happy_var_1 (HsModule (XModulePs noAnn (thdOf3 happy_var_7) happy_var_4 Nothing) (Just happy_var_3) happy_var_5 (fst $ sndOf3 happy_var_7) (snd $ sndOf3 happy_var_7))) - ) `HappyStk` happyRest}}}}}} - -happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_57 = happyReduce 6# 17# happyReduction_57 -happyReduction_57 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> - case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> - happyIn33 - (sL1 happy_var_1 $ DeclD - HsigFile - (reLoc happy_var_2) - (sL1 happy_var_1 (HsModule (XModulePs noAnn (thdOf3 happy_var_6) happy_var_3 Nothing) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) (snd $ sndOf3 happy_var_6))) - ) `HappyStk` happyRest}}}}} - -happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_58 = happySpecReduce_3 17# happyReduction_58 -happyReduction_58 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { (HappyWrap20 happy_var_2) -> - case happyOut28 happy_x_3 of { (HappyWrap28 happy_var_3) -> - happyIn33 - (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2 - , idModRenaming = happy_var_3 - , idSignatureInclude = False }) - )}}} - -happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_59 = happySpecReduce_3 17# happyReduction_59 -happyReduction_59 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_3 of { (HappyWrap20 happy_var_3) -> - happyIn33 - (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3 - , idModRenaming = Nothing - , idSignatureInclude = True }) - )}} - -happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_60 = happyMonadReduce 6# 18# happyReduction_60 -happyReduction_60 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> - ( fileSrcSpan >>= \ loc -> - acs (\cs-> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6) Nothing) cs) - (thdOf3 happy_var_6) happy_var_3 Nothing) - (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) - (snd $ sndOf3 happy_var_6))) - ))}}}}}}) - ) (\r -> happyReturn (happyIn34 r)) - -happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_61 = happyMonadReduce 6# 19# happyReduction_61 -happyReduction_61 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> - ( fileSrcSpan >>= \ loc -> - acsFinal (\cs eof -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6) eof) cs) - (thdOf3 happy_var_6) happy_var_3 Nothing) - (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) - (snd $ sndOf3 happy_var_6)) - )))}}}}}}) - ) (\r -> happyReturn (happyIn35 r)) - -happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_62 = happyMonadReduce 1# 19# happyReduction_62 -happyReduction_62 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> - ( fileSrcSpan >>= \ loc -> - acsFinal (\cs eof -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 happy_var_1) eof) cs) - (thdOf3 happy_var_1) Nothing Nothing) - Nothing Nothing - (fst $ sndOf3 happy_var_1) (snd $ sndOf3 happy_var_1)))))}) - ) (\r -> happyReturn (happyIn35 r)) - -happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_63 = happyMonadReduce 0# 20# happyReduction_63 -happyReduction_63 (happyRest) tk - = happyThen ((( pushModuleContext)) - ) (\r -> happyReturn (happyIn36 r)) - -happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_64 = happyMonadReduce 0# 21# happyReduction_64 -happyReduction_64 (happyRest) tk - = happyThen ((( pushModuleContext)) - ) (\r -> happyReturn (happyIn37 r)) - -happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_65 = happyMonadReduce 3# 22# happyReduction_65 -happyReduction_65 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut149 happy_x_2 of { (HappyWrap149 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 $ getDEPRECATED_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2)) - (AnnPragma (mo happy_var_1) (mc happy_var_3) (fst $ unLoc happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn38 r)) - -happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_66 = happyMonadReduce 4# 22# happyReduction_66 -happyReduction_66 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> - case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_4 $ WarningTxt happy_var_2 (sL1 happy_var_1 $ getWARNING_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3)) - (AnnPragma (mo happy_var_1) (mc happy_var_4) (fst $ unLoc happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn38 r)) - -happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_67 = happySpecReduce_0 22# happyReduction_67 -happyReduction_67 = happyIn38 - (Nothing - ) - -happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_68 = happySpecReduce_3 23# happyReduction_68 -happyReduction_68 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn39 - ((fst happy_var_2, snd happy_var_2, explicitBraces happy_var_1 happy_var_3) - )}}} - -happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_69 = happySpecReduce_3 23# happyReduction_69 -happyReduction_69 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> - happyIn39 - ((fst happy_var_2, snd happy_var_2, VirtualBraces (getVOCURLY happy_var_1)) - )}} - -happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_70 = happySpecReduce_3 24# happyReduction_70 -happyReduction_70 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn40 - ((fst happy_var_2, snd happy_var_2, explicitBraces happy_var_1 happy_var_3) - )}}} - -happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_71 = happySpecReduce_3 24# happyReduction_71 -happyReduction_71 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> - happyIn40 - (([], snd happy_var_2, VirtualBraces leftmostColumn) - )} - -happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_72 = happySpecReduce_2 25# happyReduction_72 -happyReduction_72 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> - case happyOut42 happy_x_2 of { (HappyWrap42 happy_var_2) -> - happyIn41 - ((reverse happy_var_1, happy_var_2) - )}} - -happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_73 = happySpecReduce_2 26# happyReduction_73 -happyReduction_73 happy_x_2 - happy_x_1 - = case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> - case happyOut80 happy_x_2 of { (HappyWrap80 happy_var_2) -> - happyIn42 - ((reverse happy_var_1, cvTopDecls happy_var_2) - )}} - -happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_74 = happySpecReduce_2 26# happyReduction_74 -happyReduction_74 happy_x_2 - happy_x_1 - = case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> - case happyOut79 happy_x_2 of { (HappyWrap79 happy_var_2) -> - happyIn42 - ((reverse happy_var_1, cvTopDecls happy_var_2) - )}} - -happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_75 = happySpecReduce_1 26# happyReduction_75 -happyReduction_75 happy_x_1 - = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> - happyIn42 - ((reverse happy_var_1, []) - )} - -happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_76 = happyMonadReduce 6# 27# happyReduction_76 -happyReduction_76 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut44 happy_x_6 of { (HappyWrap44 happy_var_6) -> - ( fileSrcSpan >>= \ loc -> - acs (\cs -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1,mj AnnWhere happy_var_5] [] Nothing) cs) - NoLayoutInfo happy_var_3 Nothing) - (Just happy_var_2) happy_var_4 happy_var_6 [] - ))))}}}}}}) - ) (\r -> happyReturn (happyIn43 r)) - -happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_77 = happyMonadReduce 6# 27# happyReduction_77 -happyReduction_77 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> - case happyOut48 happy_x_4 of { (HappyWrap48 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut44 happy_x_6 of { (HappyWrap44 happy_var_6) -> - ( fileSrcSpan >>= \ loc -> - acs (\cs -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1,mj AnnWhere happy_var_5] [] Nothing) cs) - NoLayoutInfo happy_var_3 Nothing) - (Just happy_var_2) happy_var_4 happy_var_6 [] - ))))}}}}}}) - ) (\r -> happyReturn (happyIn43 r)) - -happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_78 = happyMonadReduce 1# 27# happyReduction_78 -happyReduction_78 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut45 happy_x_1 of { (HappyWrap45 happy_var_1) -> - ( fileSrcSpan >>= \ loc -> - return (L loc (HsModule (XModulePs noAnn NoLayoutInfo Nothing Nothing) Nothing Nothing happy_var_1 [])))}) - ) (\r -> happyReturn (happyIn43 r)) - -happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_79 = happySpecReduce_2 28# happyReduction_79 -happyReduction_79 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> - happyIn44 - (happy_var_2 - )} - -happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_80 = happySpecReduce_2 28# happyReduction_80 -happyReduction_80 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> - happyIn44 - (happy_var_2 - )} - -happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_81 = happySpecReduce_2 29# happyReduction_81 -happyReduction_81 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> - happyIn45 - (happy_var_2 - )} - -happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_82 = happySpecReduce_2 29# happyReduction_82 -happyReduction_82 happy_x_2 - happy_x_1 - = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> - happyIn45 - (happy_var_2 - )} - -happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_83 = happySpecReduce_2 30# happyReduction_83 -happyReduction_83 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_2 of { (HappyWrap47 happy_var_2) -> - happyIn46 - (happy_var_2 - )} - -happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_84 = happySpecReduce_1 31# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> - happyIn47 - (happy_var_1 - )} - -happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_85 = happySpecReduce_1 31# happyReduction_85 -happyReduction_85 happy_x_1 - = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> - happyIn47 - (happy_var_1 - )} - -happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_86 = happyMonadReduce 3# 32# happyReduction_86 -happyReduction_86 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( fmap Just $ amsrl (sLL happy_var_1 happy_var_3 (fromOL $ snd happy_var_2)) - (AnnList Nothing (Just $ mop happy_var_1) (Just $ mcp happy_var_3) (fst happy_var_2) []))}}}) - ) (\r -> happyReturn (happyIn48 r)) - -happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_87 = happySpecReduce_0 32# happyReduction_87 -happyReduction_87 = happyIn48 - (Nothing - ) - -happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_88 = happySpecReduce_1 33# happyReduction_88 -happyReduction_88 happy_x_1 - = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> - happyIn49 - (([], happy_var_1) - )} - -happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_89 = happySpecReduce_0 33# happyReduction_89 -happyReduction_89 = happyIn49 - (([], nilOL) - ) - -happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_90 = happyMonadReduce 2# 33# happyReduction_90 -happyReduction_90 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( case happy_var_1 of - SnocOL hs t -> do - t' <- addTrailingCommaA t (gl happy_var_2) - return ([], snocOL hs t'))}}) - ) (\r -> happyReturn (happyIn49 r)) - -happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_91 = happySpecReduce_1 33# happyReduction_91 -happyReduction_91 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn49 - (([mj AnnComma happy_var_1], nilOL) - )} - -happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_92 = happyMonadReduce 3# 34# happyReduction_92 -happyReduction_92 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut51 happy_x_3 of { (HappyWrap51 happy_var_3) -> - ( let ls = happy_var_1 - in if isNilOL ls - then return (ls `appOL` happy_var_3) - else case ls of - SnocOL hs t -> do - t' <- addTrailingCommaA t (gl happy_var_2) - return (snocOL hs t' `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn50 r)) - -happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_93 = happySpecReduce_1 34# happyReduction_93 -happyReduction_93 happy_x_1 - = case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> - happyIn50 - (happy_var_1 - )} - -happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_94 = happyMonadReduce 3# 35# happyReduction_94 -happyReduction_94 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> - case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> - case happyOut53 happy_x_3 of { (HappyWrap53 happy_var_3) -> - ( do { let { span = (maybe comb2 (comb3 . reLoc) happy_var_1) (reLoc happy_var_2) happy_var_3 } - ; impExp <- mkModuleImpExp happy_var_1 (fst $ unLoc happy_var_3) happy_var_2 (snd $ unLoc happy_var_3) - ; return $ unitOL $ reLocA $ sL span $ impExp })}}}) - ) (\r -> happyReturn (happyIn51 r)) - -happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_95 = happyMonadReduce 3# 35# happyReduction_95 -happyReduction_95 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> - ( do { let { span = (maybe comb2 (comb3 . reLoc) happy_var_1) happy_var_2 (reLoc happy_var_3) - ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 (reLoc loc)) happy_var_1) happy_var_2 } - ; locImpExp <- acs (\cs -> sL span (IEModuleContents (happy_var_1, EpAnn anchor [mj AnnModule happy_var_2] cs) happy_var_3)) - ; return $ unitOL $ reLocA $ locImpExp })}}}) - ) (\r -> happyReturn (happyIn51 r)) - -happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_96 = happySpecReduce_3 35# happyReduction_96 -happyReduction_96 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut274 happy_x_3 of { (HappyWrap274 happy_var_3) -> - happyIn51 - (let span = (maybe comb2 (comb3 . reLoc) happy_var_1) happy_var_2 (reLoc happy_var_3) - in unitOL $ reLocA $ sL span $ IEVar happy_var_1 (sLLa happy_var_2 (reLocN happy_var_3) (IEPattern (glAA happy_var_2) happy_var_3)) - )}}} - -happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_97 = happyMonadReduce 3# 36# happyReduction_97 -happyReduction_97 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut149 happy_x_2 of { (HappyWrap149 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 $ getDEPRECATED_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2)) - (AnnPragma (mo happy_var_1) (mc happy_var_3) (fst $ unLoc happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn52 r)) - -happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_98 = happyMonadReduce 4# 36# happyReduction_98 -happyReduction_98 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> - case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_4 $ WarningTxt happy_var_2 (sL1 happy_var_1 $ getWARNING_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3)) - (AnnPragma (mo happy_var_1) (mc happy_var_4) (fst $ unLoc happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn52 r)) - -happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_99 = happySpecReduce_0 36# happyReduction_99 -happyReduction_99 = happyIn52 - (Nothing - ) - -happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_100 = happySpecReduce_0 37# happyReduction_100 -happyReduction_100 = happyIn53 - (sL0 ([],ImpExpAbs) - ) - -happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_101 = happyMonadReduce 3# 37# happyReduction_101 -happyReduction_101 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_2 of { (HappyWrap54 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( mkImpExpSubSpec (reverse (snd happy_var_2)) - >>= \(as,ie) -> return $ sLL happy_var_1 happy_var_3 - (as ++ [mop happy_var_1,mcp happy_var_3] ++ fst happy_var_2, ie))}}}) - ) (\r -> happyReturn (happyIn53 r)) - -happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_102 = happySpecReduce_0 38# happyReduction_102 -happyReduction_102 = happyIn54 - (([],[]) - ) - -happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_103 = happySpecReduce_1 38# happyReduction_103 -happyReduction_103 happy_x_1 - = case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> - happyIn54 - (happy_var_1 - )} - -happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_104 = happyMonadReduce 3# 39# happyReduction_104 -happyReduction_104 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut56 happy_x_3 of { (HappyWrap56 happy_var_3) -> - ( case (snd happy_var_1) of - (l@(L la ImpExpQcWildcard):t) -> - do { l' <- addTrailingCommaA l (gl happy_var_2) - ; return ([mj AnnDotdot (reLoc l), - mj AnnComma happy_var_2] - ,(snd (unLoc happy_var_3) : l' : t)) } - (l:t) -> - do { l' <- addTrailingCommaA l (gl happy_var_2) - ; return (fst happy_var_1 ++ fst (unLoc happy_var_3) - , snd (unLoc happy_var_3) : l' : t)})}}}) - ) (\r -> happyReturn (happyIn55 r)) - -happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_105 = happySpecReduce_1 39# happyReduction_105 -happyReduction_105 happy_x_1 - = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> - happyIn55 - ((fst (unLoc happy_var_1),[snd (unLoc happy_var_1)]) - )} - -happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_106 = happySpecReduce_1 40# happyReduction_106 -happyReduction_106 happy_x_1 - = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> - happyIn56 - (sL1A happy_var_1 ([],happy_var_1) - )} - -happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_107 = happySpecReduce_1 40# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn56 - (sL1 happy_var_1 ([mj AnnDotdot happy_var_1], sL1a happy_var_1 ImpExpQcWildcard) - )} - -happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_108 = happySpecReduce_1 41# happyReduction_108 -happyReduction_108 happy_x_1 - = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> - happyIn57 - (reLocA $ sL1N happy_var_1 (ImpExpQcName happy_var_1) - )} - -happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_109 = happyMonadReduce 2# 41# happyReduction_109 -happyReduction_109 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut285 happy_x_2 of { (HappyWrap285 happy_var_2) -> - ( do { n <- mkTypeImpExp happy_var_2 - ; return $ sLLa happy_var_1 (reLocN happy_var_2) (ImpExpQcType (glAA happy_var_1) n) })}}) - ) (\r -> happyReturn (happyIn57 r)) - -happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_110 = happySpecReduce_1 42# happyReduction_110 -happyReduction_110 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn58 - (happy_var_1 - )} - -happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_111 = happySpecReduce_1 42# happyReduction_111 -happyReduction_111 happy_x_1 - = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> - happyIn58 - (happy_var_1 - )} - -happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_112 = happySpecReduce_2 43# happyReduction_112 -happyReduction_112 happy_x_2 - happy_x_1 - = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn59 - (if isZeroWidthSpan (gl happy_var_2) then (sL1 happy_var_1 $ unLoc happy_var_1) else (sLL happy_var_1 happy_var_2 $ AddSemiAnn (glAA happy_var_2) : (unLoc happy_var_1)) - )}} - -happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_113 = happySpecReduce_1 43# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn59 - (case msemi happy_var_1 of - [] -> noLoc [] - ms -> sL1 happy_var_1 $ ms - )} - -happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_114 = happySpecReduce_2 44# happyReduction_114 -happyReduction_114 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn60 - (if isZeroWidthSpan (gl happy_var_2) then happy_var_1 else (AddSemiAnn (glAA happy_var_2) : happy_var_1) - )}} - -happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_115 = happySpecReduce_0 44# happyReduction_115 -happyReduction_115 = happyIn60 - ([] - ) - -happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_116 = happySpecReduce_2 45# happyReduction_116 -happyReduction_116 happy_x_2 - happy_x_1 - = case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> - case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> - happyIn61 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_117 = happyMonadReduce 3# 46# happyReduction_117 -happyReduction_117 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut62 happy_x_1 of { (HappyWrap62 happy_var_1) -> - case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> - case happyOut59 happy_x_3 of { (HappyWrap59 happy_var_3) -> - ( do { i <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) - ; return (i : happy_var_1)})}}}) - ) (\r -> happyReturn (happyIn62 r)) - -happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_118 = happySpecReduce_0 46# happyReduction_118 -happyReduction_118 = happyIn62 - ([] - ) - -happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_119 = happyMonadReduce 9# 47# happyReduction_119 -happyReduction_119 (happy_x_9 `HappyStk` - happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut64 happy_x_2 of { (HappyWrap64 happy_var_2) -> - case happyOut65 happy_x_3 of { (HappyWrap65 happy_var_3) -> - case happyOut67 happy_x_4 of { (HappyWrap67 happy_var_4) -> - case happyOut66 happy_x_5 of { (HappyWrap66 happy_var_5) -> - case happyOut321 happy_x_6 of { (HappyWrap321 happy_var_6) -> - case happyOut67 happy_x_7 of { (HappyWrap67 happy_var_7) -> - case happyOut68 happy_x_8 of { (HappyWrap68 happy_var_8) -> - case happyOut69 happy_x_9 of { (HappyWrap69 happy_var_9) -> - ( do { - ; let { ; mPreQual = unLoc happy_var_4 - ; mPostQual = unLoc happy_var_7 } - ; checkImportDecl mPreQual mPostQual - ; let anns - = EpAnnImportDecl - { importDeclAnnImport = glAA happy_var_1 - , importDeclAnnPragma = fst $ fst happy_var_2 - , importDeclAnnSafe = fst happy_var_3 - , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual - , importDeclAnnPackage = fst happy_var_5 - , importDeclAnnAs = fst happy_var_8 - } - ; fmap reLocA $ acs (\cs -> L (comb5 happy_var_1 (reLoc happy_var_6) happy_var_7 (snd happy_var_8) happy_var_9) $ - ImportDecl { ideclExt = XImportDeclPass (EpAnn (glR happy_var_1) anns cs) (snd $ fst happy_var_2) False - , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 - , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 - , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual - , ideclAs = unLoc (snd happy_var_8) - , ideclImportList = unLoc happy_var_9 }) - })}}}}}}}}}) - ) (\r -> happyReturn (happyIn63 r)) - -happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_120 = happySpecReduce_2 48# happyReduction_120 -happyReduction_120 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn64 - (((Just (glAA happy_var_1,glAA happy_var_2),getSOURCE_PRAGs happy_var_1) - , IsBoot) - )}} - -happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_121 = happySpecReduce_0 48# happyReduction_121 -happyReduction_121 = happyIn64 - (((Nothing,NoSourceText),NotBoot) - ) - -happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_122 = happySpecReduce_1 49# happyReduction_122 -happyReduction_122 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn65 - ((Just (glAA happy_var_1),True) - )} - -happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_123 = happySpecReduce_0 49# happyReduction_123 -happyReduction_123 = happyIn65 - ((Nothing, False) - ) - -happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_124 = happyMonadReduce 1# 50# happyReduction_124 -happyReduction_124 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( do { let { pkgFS = getSTRING happy_var_1 } - ; unless (looksLikePackageName (unpackFS pkgFS)) $ - addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ - (PsErrInvalidPackageName pkgFS) - ; return (Just (glAA happy_var_1), RawPkgQual (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })}) - ) (\r -> happyReturn (happyIn66 r)) - -happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_125 = happySpecReduce_0 50# happyReduction_125 -happyReduction_125 = happyIn66 - ((Nothing,NoRawPkgQual) - ) - -happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_126 = happySpecReduce_1 51# happyReduction_126 -happyReduction_126 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn67 - (sL1 happy_var_1 (Just (glAA happy_var_1)) - )} - -happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_127 = happySpecReduce_0 51# happyReduction_127 -happyReduction_127 = happyIn67 - (noLoc Nothing - ) - -happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_128 = happySpecReduce_2 52# happyReduction_128 -happyReduction_128 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - happyIn68 - ((Just (glAA happy_var_1) - ,sLL happy_var_1 (reLoc happy_var_2) (Just happy_var_2)) - )}} - -happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_129 = happySpecReduce_0 52# happyReduction_129 -happyReduction_129 = happyIn68 - ((Nothing,noLoc Nothing) - ) - -happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_130 = happyMonadReduce 1# 53# happyReduction_130 -happyReduction_130 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut70 happy_x_1 of { (HappyWrap70 happy_var_1) -> - ( let (b, ie) = unLoc happy_var_1 in - checkImportSpec ie - >>= \checkedIe -> - return (L (gl happy_var_1) (Just (b, checkedIe))))}) - ) (\r -> happyReturn (happyIn69 r)) - -happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_131 = happySpecReduce_0 53# happyReduction_131 -happyReduction_131 = happyIn69 - (noLoc Nothing - ) - -happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_132 = happyMonadReduce 3# 54# happyReduction_132 -happyReduction_132 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut71 happy_x_2 of { (HappyWrap71 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { es <- amsrl (sLL happy_var_1 happy_var_3 $ fromOL $ snd happy_var_2) - (AnnList Nothing (Just $ mop happy_var_1) (Just $ mcp happy_var_3) (fst happy_var_2) []) - ; return $ sLL happy_var_1 happy_var_3 (Exactly, es)})}}}) - ) (\r -> happyReturn (happyIn70 r)) - -happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_133 = happyMonadReduce 4# 54# happyReduction_133 -happyReduction_133 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut71 happy_x_3 of { (HappyWrap71 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( do { es <- amsrl (sLL happy_var_1 happy_var_4 $ fromOL $ snd happy_var_3) - (AnnList Nothing (Just $ mop happy_var_2) (Just $ mcp happy_var_4) (mj AnnHiding happy_var_1:fst happy_var_3) []) - ; return $ sLL happy_var_1 happy_var_4 (EverythingBut, es)})}}}}) - ) (\r -> happyReturn (happyIn70 r)) - -happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_134 = happySpecReduce_1 55# happyReduction_134 -happyReduction_134 happy_x_1 - = case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> - happyIn71 - (([], happy_var_1) - )} - -happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_135 = happySpecReduce_0 55# happyReduction_135 -happyReduction_135 = happyIn71 - (([], nilOL) - ) - -happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_136 = happyMonadReduce 2# 55# happyReduction_136 -happyReduction_136 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( case happy_var_1 of - SnocOL hs t -> do - t' <- addTrailingCommaA t (gl happy_var_2) - return ([], snocOL hs t'))}}) - ) (\r -> happyReturn (happyIn71 r)) - -happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_137 = happySpecReduce_1 55# happyReduction_137 -happyReduction_137 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn71 - (([mj AnnComma happy_var_1], nilOL) - )} - -happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_138 = happyMonadReduce 3# 56# happyReduction_138 -happyReduction_138 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut73 happy_x_3 of { (HappyWrap73 happy_var_3) -> - ( let ls = happy_var_1 - in if isNilOL ls - then return (ls `appOL` happy_var_3) - else case ls of - SnocOL hs t -> do - t' <- addTrailingCommaA t (gl happy_var_2) - return (snocOL hs t' `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn72 r)) - -happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_139 = happySpecReduce_1 56# happyReduction_139 -happyReduction_139 happy_x_1 - = case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> - happyIn72 - (happy_var_1 - )} - -happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_140 = happyMonadReduce 2# 57# happyReduction_140 -happyReduction_140 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> - case happyOut53 happy_x_2 of { (HappyWrap53 happy_var_2) -> - ( fmap (unitOL . reLocA . (sLL (reLoc happy_var_1) happy_var_2)) $ mkModuleImpExp Nothing (fst $ unLoc happy_var_2) happy_var_1 (snd $ unLoc happy_var_2))}}) - ) (\r -> happyReturn (happyIn73 r)) - -happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_141 = happyMonadReduce 2# 57# happyReduction_141 -happyReduction_141 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut321 happy_x_2 of { (HappyWrap321 happy_var_2) -> - ( fmap (unitOL . reLocA) $ acs (\cs -> sLL happy_var_1 (reLoc happy_var_2) (IEModuleContents (Nothing, EpAnn (glR happy_var_1) [mj AnnModule happy_var_1] cs) happy_var_2)))}}) - ) (\r -> happyReturn (happyIn73 r)) - -happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_142 = happySpecReduce_2 57# happyReduction_142 -happyReduction_142 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut274 happy_x_2 of { (HappyWrap274 happy_var_2) -> - happyIn73 - (unitOL $ reLocA $ sLL happy_var_1 (reLocN happy_var_2) $ IEVar Nothing (sLLa happy_var_1 (reLocN happy_var_2) (IEPattern (glAA happy_var_1) happy_var_2)) - )}} - -happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_143 = happySpecReduce_0 58# happyReduction_143 -happyReduction_143 = happyIn74 - (Nothing - ) - -happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_144 = happySpecReduce_1 58# happyReduction_144 -happyReduction_144 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn74 - (Just (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1)))) - )} - -happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_145 = happySpecReduce_1 59# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn75 - (sL1 happy_var_1 InfixN - )} - -happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_146 = happySpecReduce_1 59# happyReduction_146 -happyReduction_146 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn75 - (sL1 happy_var_1 InfixL - )} - -happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_147 = happySpecReduce_1 59# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn75 - (sL1 happy_var_1 InfixR - )} - -happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_148 = happyMonadReduce 3# 60# happyReduction_148 -happyReduction_148 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut293 happy_x_3 of { (HappyWrap293 happy_var_3) -> - ( case (unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingCommaN t (gl happy_var_2) - return (sLL happy_var_1 (reLocN happy_var_3) (snocOL hs t' `appOL` unitOL happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn76 r)) - -happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_149 = happySpecReduce_1 60# happyReduction_149 -happyReduction_149 happy_x_1 - = case happyOut293 happy_x_1 of { (HappyWrap293 happy_var_1) -> - happyIn76 - (sL1N happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_150 = happySpecReduce_2 61# happyReduction_150 -happyReduction_150 happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> - case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> - happyIn77 - (happy_var_1 `snocOL` happy_var_2 - )}} - -happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_151 = happyMonadReduce 3# 62# happyReduction_151 -happyReduction_151 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> - case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> - case happyOut59 happy_x_3 of { (HappyWrap59 happy_var_3) -> - ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) - ; return (happy_var_1 `snocOL` t) })}}}) - ) (\r -> happyReturn (happyIn78 r)) - -happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_152 = happySpecReduce_0 62# happyReduction_152 -happyReduction_152 = happyIn78 - (nilOL - ) - -happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_153 = happySpecReduce_2 63# happyReduction_153 -happyReduction_153 happy_x_2 - happy_x_1 - = case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> - case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> - happyIn79 - (happy_var_1 `snocOL` happy_var_2 - )}} - -happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_154 = happyMonadReduce 3# 64# happyReduction_154 -happyReduction_154 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> - case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> - case happyOut59 happy_x_3 of { (HappyWrap59 happy_var_3) -> - ( do { t <- amsAl happy_var_2 (comb2 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) - ; return (happy_var_1 `snocOL` t) })}}}) - ) (\r -> happyReturn (happyIn80 r)) - -happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_155 = happySpecReduce_0 64# happyReduction_155 -happyReduction_155 = happyIn80 - (nilOL - ) - -happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_156 = happyMonadReduce 1# 65# happyReduction_156 -happyReduction_156 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut82 happy_x_1 of { (HappyWrap82 happy_var_1) -> - ( commentsPA happy_var_1)}) - ) (\r -> happyReturn (happyIn81 r)) - -happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_157 = happySpecReduce_1 66# happyReduction_157 -happyReduction_157 happy_x_1 - = case happyOut83 happy_x_1 of { (HappyWrap83 happy_var_1) -> - happyIn82 - (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) - )} - -happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_158 = happySpecReduce_1 66# happyReduction_158 -happyReduction_158 happy_x_1 - = case happyOut84 happy_x_1 of { (HappyWrap84 happy_var_1) -> - happyIn82 - (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) - )} - -happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_159 = happySpecReduce_1 66# happyReduction_159 -happyReduction_159 happy_x_1 - = case happyOut85 happy_x_1 of { (HappyWrap85 happy_var_1) -> - happyIn82 - (sL1 happy_var_1 (KindSigD noExtField (unLoc happy_var_1)) - )} - -happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_160 = happySpecReduce_1 66# happyReduction_160 -happyReduction_160 happy_x_1 - = case happyOut87 happy_x_1 of { (HappyWrap87 happy_var_1) -> - happyIn82 - (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)) - )} - -happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_161 = happySpecReduce_1 66# happyReduction_161 -happyReduction_161 happy_x_1 - = case happyOut112 happy_x_1 of { (HappyWrap112 happy_var_1) -> - happyIn82 - (sL1 happy_var_1 (DerivD noExtField (unLoc happy_var_1)) - )} - -happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_162 = happySpecReduce_1 66# happyReduction_162 -happyReduction_162 happy_x_1 - = case happyOut113 happy_x_1 of { (HappyWrap113 happy_var_1) -> - happyIn82 - (sL1 happy_var_1 (RoleAnnotD noExtField (unLoc happy_var_1)) - )} - -happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_163 = happyMonadReduce 4# 66# happyReduction_163 -happyReduction_163 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut177 happy_x_3 of { (HappyWrap177 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_4 - (DefD noExtField (DefaultDecl (EpAnn (glR happy_var_1) [mj AnnDefault happy_var_1,mop happy_var_2,mcp happy_var_4] cs) happy_var_3))))}}}}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_164 = happyMonadReduce 2# 66# happyReduction_164 -happyReduction_164 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut152 happy_x_2 of { (HappyWrap152 happy_var_2) -> - ( acsA (\cs -> sLL happy_var_1 happy_var_2 ((snd $ unLoc happy_var_2) (EpAnn (glR happy_var_1) (mj AnnForeign happy_var_1:(fst $ unLoc happy_var_2)) cs))))}}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_165 = happyMonadReduce 3# 66# happyReduction_165 -happyReduction_165 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings ((EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs), (getDEPRECATED_PRAGs happy_var_1)) (fromOL happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_166 = happyMonadReduce 3# 66# happyReduction_166 -happyReduction_166 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut145 happy_x_2 of { (HappyWrap145 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings ((EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs), (getWARNING_PRAGs happy_var_1)) (fromOL happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_167 = happyMonadReduce 3# 66# happyReduction_167 -happyReduction_167 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ RuleD noExtField (HsRules ((EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs), (getRULES_PRAGs happy_var_1)) (reverse happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_168 = happySpecReduce_1 66# happyReduction_168 -happyReduction_168 happy_x_1 - = case happyOut151 happy_x_1 of { (HappyWrap151 happy_var_1) -> - happyIn82 - (happy_var_1 - )} - -happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_169 = happySpecReduce_1 66# happyReduction_169 -happyReduction_169 happy_x_1 - = case happyOut203 happy_x_1 of { (HappyWrap203 happy_var_1) -> - happyIn82 - (happy_var_1 - )} - -happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_170 = happyMonadReduce 1# 66# happyReduction_170 -happyReduction_170 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - do { d <- mkSpliceDecl happy_var_1 - ; commentsPA d })}) - ) (\r -> happyReturn (happyIn82 r)) - -happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_171 = happyMonadReduce 4# 67# happyReduction_171 -happyReduction_171 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut109 happy_x_2 of { (HappyWrap109 happy_var_2) -> - case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> - case happyOut127 happy_x_4 of { (HappyWrap127 happy_var_4) -> - ( (mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (sndOf3 $ unLoc happy_var_4) (thdOf3 $ unLoc happy_var_4)) - (mj AnnClass happy_var_1:(fst $ unLoc happy_var_3)++(fstOf3 $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn83 r)) - -happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_172 = happyMonadReduce 4# 68# happyReduction_172 -happyReduction_172 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut167 happy_x_2 of { (HappyWrap167 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut164 happy_x_4 of { (HappyWrap164 happy_var_4) -> - ( mkTySynonym (comb2A happy_var_1 happy_var_4) happy_var_2 happy_var_4 [mj AnnType happy_var_1,mj AnnEqual happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn84 r)) - -happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_173 = happyMonadReduce 6# 68# happyReduction_173 -happyReduction_173 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut167 happy_x_3 of { (HappyWrap167 happy_var_3) -> - case happyOut107 happy_x_4 of { (HappyWrap107 happy_var_4) -> - case happyOut92 happy_x_5 of { (HappyWrap92 happy_var_5) -> - case happyOut95 happy_x_6 of { (HappyWrap95 happy_var_6) -> - ( mkFamDecl (comb5 happy_var_1 (reLoc happy_var_3) happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_6) TopLevel happy_var_3 - (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) - (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4) - ++ (fst $ unLoc happy_var_5) ++ (fst $ unLoc happy_var_6)))}}}}}}) - ) (\r -> happyReturn (happyIn84 r)) - -happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_174 = happyMonadReduce 5# 68# happyReduction_174 -happyReduction_174 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut103 happy_x_1 of { (HappyWrap103 happy_var_1) -> - case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) -> - case happyOut109 happy_x_3 of { (HappyWrap109 happy_var_3) -> - case happyOut191 happy_x_4 of { (HappyWrap191 happy_var_4) -> - case happyOut199 happy_x_5 of { (HappyWrap199 happy_var_5) -> - ( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (sndOf3 $ unLoc happy_var_1) (thdOf3 $ unLoc happy_var_1) happy_var_2 happy_var_3 - Nothing (reverse (snd $ unLoc happy_var_4)) - (fmap reverse happy_var_5) - ((fstOf3 $ unLoc happy_var_1)++(fst $ unLoc happy_var_4)))}}}}}) - ) (\r -> happyReturn (happyIn84 r)) - -happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_175 = happyMonadReduce 6# 68# happyReduction_175 -happyReduction_175 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut103 happy_x_1 of { (HappyWrap103 happy_var_1) -> - case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) -> - case happyOut109 happy_x_3 of { (HappyWrap109 happy_var_3) -> - case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> - case happyOut188 happy_x_5 of { (HappyWrap188 happy_var_5) -> - case happyOut199 happy_x_6 of { (HappyWrap199 happy_var_6) -> - ( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (sndOf3 $ unLoc happy_var_1) (thdOf3 $ unLoc happy_var_1) happy_var_2 happy_var_3 - (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) - (fmap reverse happy_var_6) - ((fstOf3 $ unLoc happy_var_1)++(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))}}}}}}) - ) (\r -> happyReturn (happyIn84 r)) - -happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_176 = happyMonadReduce 4# 68# happyReduction_176 -happyReduction_176 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut167 happy_x_3 of { (HappyWrap167 happy_var_3) -> - case happyOut106 happy_x_4 of { (HappyWrap106 happy_var_4) -> - ( mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily TopLevel happy_var_3 - (snd $ unLoc happy_var_4) Nothing - (mj AnnData happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))}}}}) - ) (\r -> happyReturn (happyIn84 r)) - -happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_177 = happyMonadReduce 4# 69# happyReduction_177 -happyReduction_177 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut86 happy_x_2 of { (HappyWrap86 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut158 happy_x_4 of { (HappyWrap158 happy_var_4) -> - ( mkStandaloneKindSig (comb2A happy_var_1 happy_var_4) (L (gl happy_var_2) $ unLoc happy_var_2) happy_var_4 - [mj AnnType happy_var_1,mu AnnDcolon happy_var_3])}}}}) - ) (\r -> happyReturn (happyIn85 r)) - -happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_178 = happyMonadReduce 3# 70# happyReduction_178 -happyReduction_178 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut86 happy_x_1 of { (HappyWrap86 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut285 happy_x_3 of { (HappyWrap285 happy_var_3) -> - ( case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingCommaN h (gl happy_var_2) - return (sLL happy_var_1 (reLocN happy_var_3) (happy_var_3 : h' : t)))}}}) - ) (\r -> happyReturn (happyIn86 r)) - -happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_179 = happySpecReduce_1 70# happyReduction_179 -happyReduction_179 happy_x_1 - = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> - happyIn86 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_180 = happyMonadReduce 4# 71# happyReduction_180 -happyReduction_180 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut88 happy_x_2 of { (HappyWrap88 happy_var_2) -> - case happyOut175 happy_x_3 of { (HappyWrap175 happy_var_3) -> - case happyOut131 happy_x_4 of { (HappyWrap131 happy_var_4) -> - ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4) - ; let anns = (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4)) - ; let cid cs = ClsInstDecl - { cid_ext = (EpAnn (glR happy_var_1) anns cs, NoAnnSortKey) - , cid_poly_ty = happy_var_3, cid_binds = binds - , cid_sigs = mkClassOpSigs sigs - , cid_tyfam_insts = ats - , cid_overlap_mode = happy_var_2 - , cid_datafam_insts = adts } - ; acsA (\cs -> L (comb3 happy_var_1 (reLoc happy_var_3) happy_var_4) - (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs })) - })}}}}) - ) (\r -> happyReturn (happyIn87 r)) - -happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_181 = happyMonadReduce 3# 71# happyReduction_181 -happyReduction_181 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { (HappyWrap98 happy_var_3) -> - ( mkTyFamInst (comb2A happy_var_1 happy_var_3) (unLoc happy_var_3) - (mj AnnType happy_var_1:mj AnnInstance happy_var_2:[]))}}}) - ) (\r -> happyReturn (happyIn87 r)) - -happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_182 = happyMonadReduce 6# 71# happyReduction_182 -happyReduction_182 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> - case happyOut110 happy_x_4 of { (HappyWrap110 happy_var_4) -> - case happyOut191 happy_x_5 of { (HappyWrap191 happy_var_5) -> - case happyOut199 happy_x_6 of { (HappyWrap199 happy_var_6) -> - ( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) - Nothing (reverse (snd $ unLoc happy_var_5)) - (fmap reverse happy_var_6) - ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_5)))}}}}}}) - ) (\r -> happyReturn (happyIn87 r)) - -happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_183 = happyMonadReduce 7# 71# happyReduction_183 -happyReduction_183 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> - case happyOut110 happy_x_4 of { (HappyWrap110 happy_var_4) -> - case happyOut105 happy_x_5 of { (HappyWrap105 happy_var_5) -> - case happyOut188 happy_x_6 of { (HappyWrap188 happy_var_6) -> - case happyOut199 happy_x_7 of { (HappyWrap199 happy_var_7) -> - ( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) - (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) - (fmap reverse happy_var_7) - ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2 - :(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}}) - ) (\r -> happyReturn (happyIn87 r)) - -happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_184 = happyMonadReduce 2# 72# happyReduction_184 -happyReduction_184 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1))) - (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_185 = happyMonadReduce 2# 72# happyReduction_185 -happyReduction_185 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1))) - (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_186 = happyMonadReduce 2# 72# happyReduction_186 -happyReduction_186 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1))) - (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_187 = happyMonadReduce 2# 72# happyReduction_187 -happyReduction_187 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1))) - (AnnPragma (mo happy_var_1) (mc happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn88 r)) - -happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_188 = happySpecReduce_0 72# happyReduction_188 -happyReduction_188 = happyIn88 - (Nothing - ) - -happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_189 = happyMonadReduce 1# 73# happyReduction_189 -happyReduction_189 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( acsA (\cs -> sL1 happy_var_1 (StockStrategy (EpAnn (glR happy_var_1) [mj AnnStock happy_var_1] cs))))}) - ) (\r -> happyReturn (happyIn89 r)) - -happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_190 = happyMonadReduce 1# 73# happyReduction_190 -happyReduction_190 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( acsA (\cs -> sL1 happy_var_1 (AnyclassStrategy (EpAnn (glR happy_var_1) [mj AnnAnyclass happy_var_1] cs))))}) - ) (\r -> happyReturn (happyIn89 r)) - -happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_191 = happyMonadReduce 1# 73# happyReduction_191 -happyReduction_191 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( acsA (\cs -> sL1 happy_var_1 (NewtypeStrategy (EpAnn (glR happy_var_1) [mj AnnNewtype happy_var_1] cs))))}) - ) (\r -> happyReturn (happyIn89 r)) - -happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_192 = happyMonadReduce 2# 74# happyReduction_192 -happyReduction_192 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> - ( acsA (\cs -> sLLlA happy_var_1 happy_var_2 (ViaStrategy (XViaStrategyPs (EpAnn (glR happy_var_1) [mj AnnVia happy_var_1] cs) - happy_var_2))))}}) - ) (\r -> happyReturn (happyIn90 r)) - -happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_193 = happyMonadReduce 1# 75# happyReduction_193 -happyReduction_193 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( fmap Just $ acsA (\cs -> sL1 happy_var_1 (StockStrategy (EpAnn (glR happy_var_1) [mj AnnStock happy_var_1] cs))))}) - ) (\r -> happyReturn (happyIn91 r)) - -happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_194 = happyMonadReduce 1# 75# happyReduction_194 -happyReduction_194 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( fmap Just $ acsA (\cs -> sL1 happy_var_1 (AnyclassStrategy (EpAnn (glR happy_var_1) [mj AnnAnyclass happy_var_1] cs))))}) - ) (\r -> happyReturn (happyIn91 r)) - -happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_195 = happyMonadReduce 1# 75# happyReduction_195 -happyReduction_195 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( fmap Just $ acsA (\cs -> sL1 happy_var_1 (NewtypeStrategy (EpAnn (glR happy_var_1) [mj AnnNewtype happy_var_1] cs))))}) - ) (\r -> happyReturn (happyIn91 r)) - -happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_196 = happySpecReduce_1 75# happyReduction_196 -happyReduction_196 happy_x_1 - = case happyOut90 happy_x_1 of { (HappyWrap90 happy_var_1) -> - happyIn91 - (Just happy_var_1 - )} - -happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_197 = happySpecReduce_0 75# happyReduction_197 -happyReduction_197 = happyIn91 - (Nothing - ) - -happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_198 = happySpecReduce_0 76# happyReduction_198 -happyReduction_198 = happyIn92 - (noLoc ([], Nothing) - ) - -happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_199 = happySpecReduce_2 76# happyReduction_199 -happyReduction_199 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> - happyIn92 - (sLL happy_var_1 (reLoc happy_var_2) ([mj AnnVbar happy_var_1] - , Just (happy_var_2)) - )}} - -happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_200 = happyMonadReduce 3# 77# happyReduction_200 -happyReduction_200 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut94 happy_x_3 of { (HappyWrap94 happy_var_3) -> - ( acsA (\cs -> sLL (reLocN happy_var_1) happy_var_3 (InjectivityAnn (EpAnn (glNR happy_var_1) [mu AnnRarrow happy_var_2] cs) happy_var_1 (reverse (unLoc happy_var_3)))))}}}) - ) (\r -> happyReturn (happyIn93 r)) - -happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_201 = happySpecReduce_2 78# happyReduction_201 -happyReduction_201 happy_x_2 - happy_x_1 - = case happyOut94 happy_x_1 of { (HappyWrap94 happy_var_1) -> - case happyOut302 happy_x_2 of { (HappyWrap302 happy_var_2) -> - happyIn94 - (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_202 = happySpecReduce_1 78# happyReduction_202 -happyReduction_202 happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn94 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_203 = happySpecReduce_0 79# happyReduction_203 -happyReduction_203 = happyIn95 - (noLoc ([],OpenTypeFamily) - ) - -happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_204 = happySpecReduce_2 79# happyReduction_204 -happyReduction_204 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut96 happy_x_2 of { (HappyWrap96 happy_var_2) -> - happyIn95 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) - ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2)) - )}} - -happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_205 = happySpecReduce_3 80# happyReduction_205 -happyReduction_205 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn96 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] - ,Just (unLoc happy_var_2)) - )}}} - -happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_206 = happySpecReduce_3 80# happyReduction_206 -happyReduction_206 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - happyIn96 - (let (L loc _) = happy_var_2 in - L loc ([],Just (unLoc happy_var_2)) - )} - -happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_207 = happySpecReduce_3 80# happyReduction_207 -happyReduction_207 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn96 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2 - ,mcc happy_var_3],Nothing) - )}}} - -happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_208 = happySpecReduce_3 80# happyReduction_208 -happyReduction_208 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn96 - (let (L loc _) = happy_var_2 in - L loc ([mj AnnDotdot happy_var_2],Nothing) - )} - -happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_209 = happyMonadReduce 3# 81# happyReduction_209 -happyReduction_209 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut97 happy_x_1 of { (HappyWrap97 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { (HappyWrap98 happy_var_3) -> - ( let (L loc eqn) = happy_var_3 in - case unLoc happy_var_1 of - [] -> return (sLLlA happy_var_1 happy_var_3 (L loc eqn : unLoc happy_var_1)) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLLlA happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) - ) (\r -> happyReturn (happyIn97 r)) - -happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_210 = happyMonadReduce 2# 81# happyReduction_210 -happyReduction_210 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut97 happy_x_1 of { (HappyWrap97 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( case unLoc happy_var_1 of - [] -> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (h':t)))}}) - ) (\r -> happyReturn (happyIn97 r)) - -happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_211 = happySpecReduce_1 81# happyReduction_211 -happyReduction_211 happy_x_1 - = case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> - happyIn97 - (sLLAA happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_212 = happySpecReduce_0 81# happyReduction_212 -happyReduction_212 = happyIn97 - (noLoc [] - ) - -happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_213 = happyMonadReduce 6# 82# happyReduction_213 -happyReduction_213 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut167 happy_x_4 of { (HappyWrap167 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut164 happy_x_6 of { (HappyWrap164 happy_var_6) -> - ( do { hintExplicitForall happy_var_1 - ; tvbs <- fromSpecTyVarBndrs happy_var_2 - ; let loc = comb2A happy_var_1 happy_var_6 - ; cs <- getCommentsFor loc - ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1, mj AnnDot happy_var_3) cs) tvbs) happy_var_4 happy_var_6 [mj AnnEqual happy_var_5] })}}}}}}) - ) (\r -> happyReturn (happyIn98 r)) - -happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_214 = happyMonadReduce 3# 82# happyReduction_214 -happyReduction_214 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> - ( mkTyFamInstEqn (comb2A (reLoc happy_var_1) happy_var_3) mkHsOuterImplicit happy_var_1 happy_var_3 (mj AnnEqual happy_var_2:[]))}}}) - ) (\r -> happyReturn (happyIn98 r)) - -happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_215 = happyMonadReduce 4# 83# happyReduction_215 -happyReduction_215 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut100 happy_x_2 of { (HappyWrap100 happy_var_2) -> - case happyOut167 happy_x_3 of { (HappyWrap167 happy_var_3) -> - case happyOut106 happy_x_4 of { (HappyWrap106 happy_var_4) -> - ( liftM mkTyClD (mkFamDecl (comb3 happy_var_1 (reLoc happy_var_3) happy_var_4) DataFamily NotTopLevel happy_var_3 - (snd $ unLoc happy_var_4) Nothing - (mj AnnData happy_var_1:happy_var_2++(fst $ unLoc happy_var_4))))}}}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_216 = happyMonadReduce 3# 83# happyReduction_216 -happyReduction_216 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut167 happy_x_2 of { (HappyWrap167 happy_var_2) -> - case happyOut108 happy_x_3 of { (HappyWrap108 happy_var_3) -> - ( liftM mkTyClD - (mkFamDecl (comb3 happy_var_1 (reLoc happy_var_2) happy_var_3) OpenTypeFamily NotTopLevel happy_var_2 - (fst . snd $ unLoc happy_var_3) - (snd . snd $ unLoc happy_var_3) - (mj AnnType happy_var_1:(fst $ unLoc happy_var_3)) ))}}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_217 = happyMonadReduce 4# 83# happyReduction_217 -happyReduction_217 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut167 happy_x_3 of { (HappyWrap167 happy_var_3) -> - case happyOut108 happy_x_4 of { (HappyWrap108 happy_var_4) -> - ( liftM mkTyClD - (mkFamDecl (comb3 happy_var_1 (reLoc happy_var_3) happy_var_4) OpenTypeFamily NotTopLevel happy_var_3 - (fst . snd $ unLoc happy_var_4) - (snd . snd $ unLoc happy_var_4) - (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4))))}}}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_218 = happyMonadReduce 2# 83# happyReduction_218 -happyReduction_218 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut98 happy_x_2 of { (HappyWrap98 happy_var_2) -> - ( liftM mkInstD (mkTyFamInst (comb2A happy_var_1 happy_var_2) (unLoc happy_var_2) - [mj AnnType happy_var_1]))}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_219 = happyMonadReduce 3# 83# happyReduction_219 -happyReduction_219 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut98 happy_x_3 of { (HappyWrap98 happy_var_3) -> - ( liftM mkInstD (mkTyFamInst (comb2A happy_var_1 happy_var_3) (unLoc happy_var_3) - (mj AnnType happy_var_1:mj AnnInstance happy_var_2:[]) ))}}}) - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_220 = happySpecReduce_0 84# happyReduction_220 -happyReduction_220 = happyIn100 - ([] - ) - -happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_221 = happySpecReduce_1 84# happyReduction_221 -happyReduction_221 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn100 - ([mj AnnFamily happy_var_1] - )} - -happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_222 = happySpecReduce_0 85# happyReduction_222 -happyReduction_222 = happyIn101 - ([] - ) - -happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_223 = happySpecReduce_1 85# happyReduction_223 -happyReduction_223 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn101 - ([mj AnnInstance happy_var_1] - )} - -happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_224 = happyMonadReduce 3# 86# happyReduction_224 -happyReduction_224 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut101 happy_x_2 of { (HappyWrap101 happy_var_2) -> - case happyOut98 happy_x_3 of { (HappyWrap98 happy_var_3) -> - ( mkTyFamInst (comb2A happy_var_1 happy_var_3) (unLoc happy_var_3) - (mj AnnType happy_var_1:happy_var_2))}}}) - ) (\r -> happyReturn (happyIn102 r)) - -happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_225 = happyMonadReduce 6# 86# happyReduction_225 -happyReduction_225 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> - case happyOut101 happy_x_2 of { (HappyWrap101 happy_var_2) -> - case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> - case happyOut110 happy_x_4 of { (HappyWrap110 happy_var_4) -> - case happyOut191 happy_x_5 of { (HappyWrap191 happy_var_5) -> - case happyOut199 happy_x_6 of { (HappyWrap199 happy_var_6) -> - ( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) - Nothing (reverse (snd $ unLoc happy_var_5)) - (fmap reverse happy_var_6) - ((fst $ unLoc happy_var_1):happy_var_2++(fst $ unLoc happy_var_5)))}}}}}}) - ) (\r -> happyReturn (happyIn102 r)) - -happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_226 = happyMonadReduce 7# 86# happyReduction_226 -happyReduction_226 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> - case happyOut101 happy_x_2 of { (HappyWrap101 happy_var_2) -> - case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> - case happyOut110 happy_x_4 of { (HappyWrap110 happy_var_4) -> - case happyOut105 happy_x_5 of { (HappyWrap105 happy_var_5) -> - case happyOut188 happy_x_6 of { (HappyWrap188 happy_var_6) -> - case happyOut199 happy_x_7 of { (HappyWrap199 happy_var_7) -> - ( mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 - (unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) - (fmap reverse happy_var_7) - ((fst $ unLoc happy_var_1):happy_var_2++(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))}}}}}}}) - ) (\r -> happyReturn (happyIn102 r)) - -happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_227 = happySpecReduce_1 87# happyReduction_227 -happyReduction_227 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn103 - (sL1 happy_var_1 ([mj AnnData happy_var_1], False,DataType) - )} - -happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_228 = happySpecReduce_1 87# happyReduction_228 -happyReduction_228 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn103 - (sL1 happy_var_1 ([mj AnnNewtype happy_var_1], False,NewType) - )} - -happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_229 = happySpecReduce_2 87# happyReduction_229 -happyReduction_229 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn103 - (sL1 happy_var_1 ([mj AnnType happy_var_1, mj AnnData happy_var_2],True ,DataType) - )}} - -happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_230 = happySpecReduce_1 88# happyReduction_230 -happyReduction_230 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn104 - (sL1 happy_var_1 (mj AnnData happy_var_1,DataType) - )} - -happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_231 = happySpecReduce_1 88# happyReduction_231 -happyReduction_231 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn104 - (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType) - )} - -happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_232 = happySpecReduce_0 89# happyReduction_232 -happyReduction_232 = happyIn105 - (noLoc ([] , Nothing) - ) - -happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_233 = happySpecReduce_2 89# happyReduction_233 -happyReduction_233 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut187 happy_x_2 of { (HappyWrap187 happy_var_2) -> - happyIn105 - (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_234 = happySpecReduce_0 90# happyReduction_234 -happyReduction_234 = happyIn106 - (noLoc ([] , noLocA (NoSig noExtField) ) - ) - -happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_235 = happySpecReduce_2 90# happyReduction_235 -happyReduction_235 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut187 happy_x_2 of { (HappyWrap187 happy_var_2) -> - happyIn106 - (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], sLLa happy_var_1 (reLoc happy_var_2) (KindSig noExtField happy_var_2)) - )}} - -happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_236 = happySpecReduce_0 91# happyReduction_236 -happyReduction_236 = happyIn107 - (noLoc ([] , noLocA (NoSig noExtField) ) - ) - -happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_237 = happySpecReduce_2 91# happyReduction_237 -happyReduction_237 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut187 happy_x_2 of { (HappyWrap187 happy_var_2) -> - happyIn107 - (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], sLLa happy_var_1 (reLoc happy_var_2) (KindSig noExtField happy_var_2)) - )}} - -happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_238 = happyMonadReduce 2# 91# happyReduction_238 -happyReduction_238 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> - ( do { tvb <- fromSpecTyVarBndr happy_var_2 - ; return $ sLL happy_var_1 (reLoc happy_var_2) ([mj AnnEqual happy_var_1], sLLa happy_var_1 (reLoc happy_var_2) (TyVarSig noExtField tvb))})}}) - ) (\r -> happyReturn (happyIn107 r)) - -happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_239 = happySpecReduce_0 92# happyReduction_239 -happyReduction_239 = happyIn108 - (noLoc ([], (noLocA (NoSig noExtField), Nothing)) - ) - -happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_240 = happySpecReduce_2 92# happyReduction_240 -happyReduction_240 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut187 happy_x_2 of { (HappyWrap187 happy_var_2) -> - happyIn108 - (sLL happy_var_1 (reLoc happy_var_2) ( [mu AnnDcolon happy_var_1] - , (sL1a (reLoc happy_var_2) (KindSig noExtField happy_var_2), Nothing)) - )}} - -happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_241 = happyMonadReduce 4# 92# happyReduction_241 -happyReduction_241 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut93 happy_x_4 of { (HappyWrap93 happy_var_4) -> - ( do { tvb <- fromSpecTyVarBndr happy_var_2 - ; return $ sLL happy_var_1 (reLoc happy_var_4) ([mj AnnEqual happy_var_1, mj AnnVbar happy_var_3] - , (sLLa happy_var_1 (reLoc happy_var_2) (TyVarSig noExtField tvb), Just happy_var_4))})}}}}) - ) (\r -> happyReturn (happyIn108 r)) - -happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_242 = happyMonadReduce 3# 93# happyReduction_242 -happyReduction_242 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut167 happy_x_3 of { (HappyWrap167 happy_var_3) -> - ( acs (\cs -> (sLLAA happy_var_1 happy_var_3 (Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), happy_var_3))))}}}) - ) (\r -> happyReturn (happyIn109 r)) - -happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_243 = happySpecReduce_1 93# happyReduction_243 -happyReduction_243 happy_x_1 - = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> - happyIn109 - (sL1A happy_var_1 (Nothing, happy_var_1) - )} - -happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_244 = happyMonadReduce 6# 94# happyReduction_244 -happyReduction_244 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut166 happy_x_4 of { (HappyWrap166 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut167 happy_x_6 of { (HappyWrap167 happy_var_6) -> - ( hintExplicitForall happy_var_1 - >> fromSpecTyVarBndrs happy_var_2 - >>= \tvbs -> - (acs (\cs -> (sLL happy_var_1 (reLoc happy_var_6) - (Just ( addTrailingDarrowC happy_var_4 happy_var_5 cs) - , mkHsOuterExplicit (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1, mj AnnDot happy_var_3) emptyComments) tvbs, happy_var_6)))))}}}}}}) - ) (\r -> happyReturn (happyIn110 r)) - -happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_245 = happyMonadReduce 4# 94# happyReduction_245 -happyReduction_245 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut167 happy_x_4 of { (HappyWrap167 happy_var_4) -> - ( do { hintExplicitForall happy_var_1 - ; tvbs <- fromSpecTyVarBndrs happy_var_2 - ; let loc = comb2 happy_var_1 (reLoc happy_var_4) - ; cs <- getCommentsFor loc - ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1, mj AnnDot happy_var_3) cs) tvbs, happy_var_4)) - })}}}}) - ) (\r -> happyReturn (happyIn110 r)) - -happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_246 = happyMonadReduce 3# 94# happyReduction_246 -happyReduction_246 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut167 happy_x_3 of { (HappyWrap167 happy_var_3) -> - ( acs (\cs -> (sLLAA happy_var_1 happy_var_3(Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), mkHsOuterImplicit, happy_var_3))))}}}) - ) (\r -> happyReturn (happyIn110 r)) - -happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_247 = happySpecReduce_1 94# happyReduction_247 -happyReduction_247 happy_x_1 - = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> - happyIn110 - (sL1A happy_var_1 (Nothing, mkHsOuterImplicit, happy_var_1) - )} - -happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_248 = happyMonadReduce 4# 95# happyReduction_248 -happyReduction_248 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2))) - (getSTRINGs happy_var_3,getSTRING happy_var_3))) - (AnnPragma (mo happy_var_1) (mc happy_var_4) [mj AnnHeader happy_var_2,mj AnnVal happy_var_3]))}}}}) - ) (\r -> happyReturn (happyIn111 r)) - -happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_249 = happyMonadReduce 3# 95# happyReduction_249 -happyReduction_249 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2))) - (AnnPragma (mo happy_var_1) (mc happy_var_3) [mj AnnVal happy_var_2]))}}}) - ) (\r -> happyReturn (happyIn111 r)) - -happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_250 = happySpecReduce_0 95# happyReduction_250 -happyReduction_250 = happyIn111 - (Nothing - ) - -happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_251 = happyMonadReduce 5# 96# happyReduction_251 -happyReduction_251 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut91 happy_x_2 of { (HappyWrap91 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut88 happy_x_4 of { (HappyWrap88 happy_var_4) -> - case happyOut175 happy_x_5 of { (HappyWrap175 happy_var_5) -> - ( do { let { err = text "in the stand-alone deriving instance" - <> colon <+> quotes (ppr happy_var_5) } - ; acsA (\cs -> sLL happy_var_1 (reLoc happy_var_5) - (DerivDecl (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1, mj AnnInstance happy_var_3] cs) (mkHsWildCardBndrs happy_var_5) happy_var_2 happy_var_4)) })}}}}}) - ) (\r -> happyReturn (happyIn112 r)) - -happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_252 = happyMonadReduce 4# 97# happyReduction_252 -happyReduction_252 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut285 happy_x_3 of { (HappyWrap285 happy_var_3) -> - case happyOut114 happy_x_4 of { (HappyWrap114 happy_var_4) -> - ( mkRoleAnnotDecl (comb3N happy_var_1 happy_var_4 happy_var_3) happy_var_3 (reverse (unLoc happy_var_4)) - [mj AnnType happy_var_1,mj AnnRole happy_var_2])}}}}) - ) (\r -> happyReturn (happyIn113 r)) - -happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_253 = happySpecReduce_0 98# happyReduction_253 -happyReduction_253 = happyIn114 - (noLoc [] - ) - -happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_254 = happySpecReduce_1 98# happyReduction_254 -happyReduction_254 happy_x_1 - = case happyOut115 happy_x_1 of { (HappyWrap115 happy_var_1) -> - happyIn114 - (happy_var_1 - )} - -happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_255 = happySpecReduce_1 99# happyReduction_255 -happyReduction_255 happy_x_1 - = case happyOut116 happy_x_1 of { (HappyWrap116 happy_var_1) -> - happyIn115 - (sLL happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_256 = happySpecReduce_2 99# happyReduction_256 -happyReduction_256 happy_x_2 - happy_x_1 - = case happyOut115 happy_x_1 of { (HappyWrap115 happy_var_1) -> - case happyOut116 happy_x_2 of { (HappyWrap116 happy_var_2) -> - happyIn115 - (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 - )}} - -happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_257 = happySpecReduce_1 100# happyReduction_257 -happyReduction_257 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn116 - (sL1 happy_var_1 $ Just $ getVARID happy_var_1 - )} - -happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_258 = happySpecReduce_1 100# happyReduction_258 -happyReduction_258 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn116 - (sL1 happy_var_1 Nothing - )} - -happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_259 = happyMonadReduce 4# 101# happyReduction_259 -happyReduction_259 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut247 happy_x_4 of { (HappyWrap247 happy_var_4) -> - ( let (name, args, as ) = happy_var_2 in - acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) . ValD noExtField $ mkPatSynBind name args happy_var_4 - ImplicitBidirectional - (EpAnn (glR happy_var_1) (as ++ [mj AnnPattern happy_var_1, mj AnnEqual happy_var_3]) cs)))}}}}) - ) (\r -> happyReturn (happyIn117 r)) - -happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_260 = happyMonadReduce 4# 101# happyReduction_260 -happyReduction_260 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut247 happy_x_4 of { (HappyWrap247 happy_var_4) -> - ( let (name, args, as) = happy_var_2 in - acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) . ValD noExtField $ mkPatSynBind name args happy_var_4 Unidirectional - (EpAnn (glR happy_var_1) (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]) cs)))}}}}) - ) (\r -> happyReturn (happyIn117 r)) - -happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_261 = happyMonadReduce 5# 101# happyReduction_261 -happyReduction_261 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut247 happy_x_4 of { (HappyWrap247 happy_var_4) -> - case happyOut121 happy_x_5 of { (HappyWrap121 happy_var_5) -> - ( do { let (name, args, as) = happy_var_2 - ; mg <- mkPatSynMatchGroup name happy_var_5 - ; acsA (\cs -> sLL happy_var_1 (reLoc happy_var_5) . ValD noExtField $ - mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg) - (EpAnn (glR happy_var_1) (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]) cs)) - })}}}}}) - ) (\r -> happyReturn (happyIn117 r)) - -happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_262 = happySpecReduce_2 102# happyReduction_262 -happyReduction_262 happy_x_2 - happy_x_1 - = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - case happyOut119 happy_x_2 of { (HappyWrap119 happy_var_2) -> - happyIn118 - ((happy_var_1, PrefixCon noTypeArgs happy_var_2, []) - )}} - -happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_263 = happySpecReduce_3 102# happyReduction_263 -happyReduction_263 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - case happyOut281 happy_x_2 of { (HappyWrap281 happy_var_2) -> - case happyOut307 happy_x_3 of { (HappyWrap307 happy_var_3) -> - happyIn118 - ((happy_var_2, InfixCon happy_var_1 happy_var_3, []) - )}}} - -happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_264 = happyReduce 4# 102# happyReduction_264 -happyReduction_264 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut120 happy_x_3 of { (HappyWrap120 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn118 - ((happy_var_1, RecCon happy_var_3, [moc happy_var_2, mcc happy_var_4] ) - ) `HappyStk` happyRest}}}} - -happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_265 = happySpecReduce_0 103# happyReduction_265 -happyReduction_265 = happyIn119 - ([] - ) - -happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_266 = happySpecReduce_2 103# happyReduction_266 -happyReduction_266 happy_x_2 - happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - case happyOut119 happy_x_2 of { (HappyWrap119 happy_var_2) -> - happyIn119 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_267 = happySpecReduce_1 104# happyReduction_267 -happyReduction_267 happy_x_1 - = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - happyIn120 - ([RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1] - )} - -happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_268 = happyMonadReduce 3# 104# happyReduction_268 -happyReduction_268 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut120 happy_x_3 of { (HappyWrap120 happy_var_3) -> - ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; return ((RecordPatSynField (mkFieldOcc h) h) : happy_var_3 )})}}}) - ) (\r -> happyReturn (happyIn120 r)) - -happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_269 = happyMonadReduce 4# 105# happyReduction_269 -happyReduction_269 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut132 happy_x_3 of { (HappyWrap132 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( amsrl (sLL happy_var_1 happy_var_4 (snd $ unLoc happy_var_3)) - (AnnList (Just $ glR happy_var_3) (Just $ moc happy_var_2) (Just $ mcc happy_var_4) [mj AnnWhere happy_var_1] (fst $ unLoc happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn121 r)) - -happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_270 = happyMonadReduce 4# 105# happyReduction_270 -happyReduction_270 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut132 happy_x_3 of { (HappyWrap132 happy_var_3) -> - ( amsrl (sLL happy_var_1 happy_var_3 (snd $ unLoc happy_var_3)) - (AnnList (Just $ glR happy_var_3) Nothing Nothing [mj AnnWhere happy_var_1] (fst $ unLoc happy_var_3)))}}) - ) (\r -> happyReturn (happyIn121 r)) - -happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_271 = happyMonadReduce 4# 106# happyReduction_271 -happyReduction_271 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> - ( acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) - $ PatSynSig (EpAnn (glR happy_var_1) (AnnSig (mu AnnDcolon happy_var_3) [mj AnnPattern happy_var_1]) cs) - (toList $ unLoc happy_var_2) happy_var_4))}}}}) - ) (\r -> happyReturn (happyIn122 r)) - -happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_272 = happySpecReduce_1 107# happyReduction_272 -happyReduction_272 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn123 - (happy_var_1 - )} - -happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_273 = happySpecReduce_1 107# happyReduction_273 -happyReduction_273 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn123 - (happy_var_1 - )} - -happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_274 = happySpecReduce_1 108# happyReduction_274 -happyReduction_274 happy_x_1 - = case happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> - happyIn124 - (happy_var_1 - )} - -happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_275 = happySpecReduce_1 108# happyReduction_275 -happyReduction_275 happy_x_1 - = case happyOut204 happy_x_1 of { (HappyWrap204 happy_var_1) -> - happyIn124 - (happy_var_1 - )} - -happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_276 = happyMonadReduce 4# 108# happyReduction_276 -happyReduction_276 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - do { v <- checkValSigLhs happy_var_2 - ; let err = text "in default signature" <> colon <+> - quotes (ppr happy_var_2) - ; acsA (\cs -> sLL happy_var_1 (reLoc happy_var_4) $ SigD noExtField $ ClassOpSig (EpAnn (glR happy_var_1) (AnnSig (mu AnnDcolon happy_var_3) [mj AnnDefault happy_var_1]) cs) True [v] happy_var_4) })}}}}) - ) (\r -> happyReturn (happyIn124 r)) - -happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_277 = happyMonadReduce 3# 109# happyReduction_277 -happyReduction_277 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut125 happy_x_1 of { (HappyWrap125 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut124 happy_x_3 of { (HappyWrap124 happy_var_3) -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLLlA happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - , unitOL happy_var_3)) - else case (snd $ unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (sLLlA happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 - , snocOL hs t' `appOL` unitOL happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn125 r)) - -happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_278 = happyMonadReduce 2# 109# happyReduction_278 -happyReduction_278 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut125 happy_x_1 of { (HappyWrap125 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 ( (fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - ,snd $ unLoc happy_var_1)) - else case (snd $ unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 - , snocOL hs t')))}}) - ) (\r -> happyReturn (happyIn125 r)) - -happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_279 = happySpecReduce_1 109# happyReduction_279 -happyReduction_279 happy_x_1 - = case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> - happyIn125 - (sL1A happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_280 = happySpecReduce_0 109# happyReduction_280 -happyReduction_280 = happyIn125 - (noLoc ([],nilOL) - ) - -happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_281 = happySpecReduce_3 110# happyReduction_281 -happyReduction_281 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn126 - (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) - ,snd $ unLoc happy_var_2, explicitBraces happy_var_1 happy_var_3) - )}}} - -happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_282 = happySpecReduce_3 110# happyReduction_282 -happyReduction_282 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> - happyIn126 - (let { L l (anns, decls) = happy_var_2 } - in L l (anns, decls, VirtualBraces (getVOCURLY happy_var_1)) - )}} - -happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_283 = happySpecReduce_2 111# happyReduction_283 -happyReduction_283 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { (HappyWrap126 happy_var_2) -> - happyIn127 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fstOf3 $ unLoc happy_var_2) - ,sndOf3 $ unLoc happy_var_2,thdOf3 $ unLoc happy_var_2) - )}} - -happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_284 = happySpecReduce_0 111# happyReduction_284 -happyReduction_284 = happyIn127 - (noLoc ([],nilOL,NoLayoutInfo) - ) - -happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_285 = happySpecReduce_1 112# happyReduction_285 -happyReduction_285 happy_x_1 - = case happyOut102 happy_x_1 of { (HappyWrap102 happy_var_1) -> - happyIn128 - (sL1A happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)))) - )} - -happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_286 = happySpecReduce_1 112# happyReduction_286 -happyReduction_286 happy_x_1 - = case happyOut204 happy_x_1 of { (HappyWrap204 happy_var_1) -> - happyIn128 - (sL1A happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_287 = happyMonadReduce 3# 113# happyReduction_287 -happyReduction_287 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut129 happy_x_1 of { (HappyWrap129 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut128 happy_x_3 of { (HappyWrap128 happy_var_3) -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - , unLoc happy_var_3)) - else case (snd $ unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 - , snocOL hs t' `appOL` unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn129 r)) - -happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_288 = happyMonadReduce 2# 113# happyReduction_288 -happyReduction_288 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut129 happy_x_1 of { (HappyWrap129 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - ,snd $ unLoc happy_var_1)) - else case (snd $ unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 - , snocOL hs t')))}}) - ) (\r -> happyReturn (happyIn129 r)) - -happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_289 = happySpecReduce_1 113# happyReduction_289 -happyReduction_289 happy_x_1 - = case happyOut128 happy_x_1 of { (HappyWrap128 happy_var_1) -> - happyIn129 - (sL1 happy_var_1 ([],unLoc happy_var_1) - )} - -happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_290 = happySpecReduce_0 113# happyReduction_290 -happyReduction_290 = happyIn129 - (noLoc ([],nilOL) - ) - -happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_291 = happySpecReduce_3 114# happyReduction_291 -happyReduction_291 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn130 - (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) - )}}} - -happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_292 = happySpecReduce_3 114# happyReduction_292 -happyReduction_292 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> - happyIn130 - (L (gl happy_var_2) (unLoc happy_var_2) - )} - -happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_293 = happySpecReduce_2 115# happyReduction_293 -happyReduction_293 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> - happyIn131 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) - ,(snd $ unLoc happy_var_2)) - )}} - -happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_294 = happySpecReduce_0 115# happyReduction_294 -happyReduction_294 = happyIn131 - (noLoc ([],nilOL) - ) - -happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_295 = happyMonadReduce 3# 116# happyReduction_295 -happyReduction_295 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut132 happy_x_1 of { (HappyWrap132 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut204 happy_x_3 of { (HappyWrap204 happy_var_3) -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLLlA happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ (msemi happy_var_2) - , unitOL happy_var_3)) - else case (snd $ unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - let { this = unitOL happy_var_3; - rest = snocOL hs t'; - these = rest `appOL` this } - return (rest `seq` this `seq` these `seq` - (sLLlA happy_var_1 happy_var_3 (fst $ unLoc happy_var_1, these))))}}}) - ) (\r -> happyReturn (happyIn132 r)) - -happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_296 = happyMonadReduce 2# 116# happyReduction_296 -happyReduction_296 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut132 happy_x_1 of { (HappyWrap132 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL (snd $ unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_2 (((fst $ unLoc happy_var_1) ++ (msemi happy_var_2) - ,snd $ unLoc happy_var_1))) - else case (snd $ unLoc happy_var_1) of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 - , snocOL hs t')))}}) - ) (\r -> happyReturn (happyIn132 r)) - -happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_297 = happySpecReduce_1 116# happyReduction_297 -happyReduction_297 happy_x_1 - = case happyOut204 happy_x_1 of { (HappyWrap204 happy_var_1) -> - happyIn132 - (sL1A happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_298 = happySpecReduce_0 116# happyReduction_298 -happyReduction_298 = happyIn132 - (noLoc ([],nilOL) - ) - -happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_299 = happySpecReduce_3 117# happyReduction_299 -happyReduction_299 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut132 happy_x_2 of { (HappyWrap132 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn133 - (sLL happy_var_1 happy_var_3 (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (fst $ unLoc happy_var_2) - ,sL1 happy_var_2 $ snd $ unLoc happy_var_2) - )}}} - -happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_300 = happySpecReduce_3 117# happyReduction_300 -happyReduction_300 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut132 happy_x_2 of { (HappyWrap132 happy_var_2) -> - happyIn133 - (L (gl happy_var_2) (AnnList (Just $ glR happy_var_2) Nothing Nothing [] (fst $ unLoc happy_var_2) - ,sL1 happy_var_2 $ snd $ unLoc happy_var_2) - )} - -happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_301 = happyMonadReduce 1# 118# happyReduction_301 -happyReduction_301 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut133 happy_x_1 of { (HappyWrap133 happy_var_1) -> - ( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1) - ; cs <- getCommentsFor (gl happy_var_1) - ; return (sL1 happy_var_1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR happy_var_1) (fst $ unLoc happy_var_1) cs) val_binds)})}) - ) (\r -> happyReturn (happyIn134 r)) - -happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_302 = happyMonadReduce 3# 118# happyReduction_302 -happyReduction_302 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut262 happy_x_2 of { (HappyWrap262 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acs (\cs -> (L (comb3 happy_var_1 happy_var_2 happy_var_3) - $ HsIPBinds (EpAnn (glR happy_var_1) (AnnList (Just$ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}}) - ) (\r -> happyReturn (happyIn134 r)) - -happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_303 = happyMonadReduce 3# 118# happyReduction_303 -happyReduction_303 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut262 happy_x_2 of { (HappyWrap262 happy_var_2) -> - ( acs (\cs -> (L (gl happy_var_2) - $ HsIPBinds (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}) - ) (\r -> happyReturn (happyIn134 r)) - -happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_304 = happyMonadReduce 2# 119# happyReduction_304 -happyReduction_304 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> - ( do { r <- acs (\cs -> - (sLL happy_var_1 happy_var_2 (annBinds (mj AnnWhere happy_var_1) cs (unLoc happy_var_2)))) - ; return $ Just r})}}) - ) (\r -> happyReturn (happyIn135 r)) - -happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_305 = happySpecReduce_0 119# happyReduction_305 -happyReduction_305 = happyIn135 - (Nothing - ) - -happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_306 = happyMonadReduce 3# 120# happyReduction_306 -happyReduction_306 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut136 happy_x_1 of { (HappyWrap136 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut137 happy_x_3 of { (HappyWrap137 happy_var_3) -> - ( case happy_var_1 of - [] -> return (happy_var_3:happy_var_1) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (happy_var_3:h':t))}}}) - ) (\r -> happyReturn (happyIn136 r)) - -happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_307 = happyMonadReduce 2# 120# happyReduction_307 -happyReduction_307 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut136 happy_x_1 of { (HappyWrap136 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( case happy_var_1 of - [] -> return happy_var_1 - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (h':t))}}) - ) (\r -> happyReturn (happyIn136 r)) - -happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_308 = happySpecReduce_1 120# happyReduction_308 -happyReduction_308 happy_x_1 - = case happyOut137 happy_x_1 of { (HappyWrap137 happy_var_1) -> - happyIn136 - ([happy_var_1] - )} - -happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_309 = happySpecReduce_0 120# happyReduction_309 -happyReduction_309 = happyIn136 - ([] - ) - -happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_310 = happyMonadReduce 6# 121# happyReduction_310 -happyReduction_310 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> - case happyOut141 happy_x_3 of { (HappyWrap141 happy_var_3) -> - case happyOut213 happy_x_4 of { (HappyWrap213 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut212 happy_x_6 of { (HappyWrap212 happy_var_6) -> - (runPV (unECP happy_var_4) >>= \ happy_var_4 -> - runPV (unECP happy_var_6) >>= \ happy_var_6 -> - acsA (\cs -> (sLLlA happy_var_1 happy_var_6 $ HsRule - { rd_ext = (EpAnn (glR happy_var_1) ((fstOf3 happy_var_3) (mj AnnEqual happy_var_5 : (fst happy_var_2))) cs, getSTRINGs happy_var_1) - , rd_name = L (noAnnSrcSpan $ gl happy_var_1) (getSTRING happy_var_1) - , rd_act = (snd happy_var_2) `orElse` AlwaysActive - , rd_tyvs = sndOf3 happy_var_3, rd_tmvs = thdOf3 happy_var_3 - , rd_lhs = happy_var_4, rd_rhs = happy_var_6 })))}}}}}}) - ) (\r -> happyReturn (happyIn137 r)) - -happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_311 = happySpecReduce_0 122# happyReduction_311 -happyReduction_311 = happyIn138 - (([],Nothing) - ) - -happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_312 = happySpecReduce_1 122# happyReduction_312 -happyReduction_312 happy_x_1 - = case happyOut140 happy_x_1 of { (HappyWrap140 happy_var_1) -> - happyIn138 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_313 = happySpecReduce_1 123# happyReduction_313 -happyReduction_313 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn139 - ([mj AnnTilde happy_var_1] - )} - -happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_314 = happyMonadReduce 1# 123# happyReduction_314 -happyReduction_314 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( if (getVARSYM happy_var_1 == fsLit "~") - then return [mj AnnTilde happy_var_1] - else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ - PsErrInvalidRuleActivationMarker - ; return [] })}) - ) (\r -> happyReturn (happyIn139 r)) - -happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_315 = happySpecReduce_3 124# happyReduction_315 -happyReduction_315 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn140 - (([mos happy_var_1,mj AnnVal happy_var_2,mcs happy_var_3] - ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) - )}}} - -happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_316 = happyReduce 4# 124# happyReduction_316 -happyReduction_316 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut139 happy_x_2 of { (HappyWrap139 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn140 - ((happy_var_2++[mos happy_var_1,mj AnnVal happy_var_3,mcs happy_var_4] - ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) - ) `HappyStk` happyRest}}}} - -happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_317 = happySpecReduce_3 124# happyReduction_317 -happyReduction_317 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut139 happy_x_2 of { (HappyWrap139 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn140 - ((happy_var_2++[mos happy_var_1,mcs happy_var_3] - ,NeverActive) - )}}} - -happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_318 = happyMonadReduce 6# 125# happyReduction_318 -happyReduction_318 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut142 happy_x_2 of { (HappyWrap142 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut142 happy_x_5 of { (HappyWrap142 happy_var_5) -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( let tyvs = mkRuleTyVarBndrs happy_var_2 - in hintExplicitForall happy_var_1 - >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs happy_var_2) - >> return (\anns -> HsRuleAnn - (Just (mu AnnForall happy_var_1,mj AnnDot happy_var_3)) - (Just (mu AnnForall happy_var_4,mj AnnDot happy_var_6)) - anns, - Just (mkRuleTyVarBndrs happy_var_2), mkRuleBndrs happy_var_5))}}}}}}) - ) (\r -> happyReturn (happyIn141 r)) - -happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_319 = happySpecReduce_3 125# happyReduction_319 -happyReduction_319 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut142 happy_x_2 of { (HappyWrap142 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn141 - ((\anns -> HsRuleAnn Nothing (Just (mu AnnForall happy_var_1,mj AnnDot happy_var_3)) anns, - Nothing, mkRuleBndrs happy_var_2) - )}}} - -happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_320 = happySpecReduce_0 125# happyReduction_320 -happyReduction_320 = happyIn141 - ((\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) - ) - -happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_321 = happySpecReduce_2 126# happyReduction_321 -happyReduction_321 happy_x_2 - happy_x_1 - = case happyOut143 happy_x_1 of { (HappyWrap143 happy_var_1) -> - case happyOut142 happy_x_2 of { (HappyWrap142 happy_var_2) -> - happyIn142 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_322 = happySpecReduce_0 126# happyReduction_322 -happyReduction_322 = happyIn142 - ([] - ) - -happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_323 = happySpecReduce_1 127# happyReduction_323 -happyReduction_323 happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn143 - (sL1l happy_var_1 (RuleTyTmVar noAnn happy_var_1 Nothing) - )} - -happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_324 = happyMonadReduce 5# 127# happyReduction_324 -happyReduction_324 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_2 of { (HappyWrap307 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut165 happy_x_4 of { (HappyWrap165 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_5 (RuleTyTmVar (EpAnn (glR happy_var_1) [mop happy_var_1,mu AnnDcolon happy_var_3,mcp happy_var_5] cs) happy_var_2 (Just happy_var_4))))}}}}}) - ) (\r -> happyReturn (happyIn143 r)) - -happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_325 = happySpecReduce_2 128# happyReduction_325 -happyReduction_325 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn144 - (Just (sLL happy_var_1 happy_var_2 $ InWarningCategory (hsTok' happy_var_1) (getSTRINGs happy_var_2) - (sL1 happy_var_2 $ mkWarningCategory (getSTRING happy_var_2))) - )}} - -happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_326 = happySpecReduce_0 128# happyReduction_326 -happyReduction_326 = happyIn144 - (Nothing - ) - -happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_327 = happyMonadReduce 3# 129# happyReduction_327 -happyReduction_327 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut145 happy_x_1 of { (HappyWrap145 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> - ( if isNilOL happy_var_1 - then return (happy_var_1 `appOL` happy_var_3) - else case happy_var_1 of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (snocOL hs t' `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn145 r)) - -happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_328 = happyMonadReduce 2# 129# happyReduction_328 -happyReduction_328 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut145 happy_x_1 of { (HappyWrap145 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL happy_var_1 - then return happy_var_1 - else case happy_var_1 of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (snocOL hs t'))}}) - ) (\r -> happyReturn (happyIn145 r)) - -happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_329 = happySpecReduce_1 129# happyReduction_329 -happyReduction_329 happy_x_1 - = case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> - happyIn145 - (happy_var_1 - )} - -happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_330 = happySpecReduce_0 129# happyReduction_330 -happyReduction_330 = happyIn145 - (nilOL - ) - -happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_331 = happyMonadReduce 3# 130# happyReduction_331 -happyReduction_331 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut144 happy_x_1 of { (HappyWrap144 happy_var_1) -> - case happyOut271 happy_x_2 of { (HappyWrap271 happy_var_2) -> - case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> - ( fmap unitOL $ acsA (\cs -> L (comb3M happy_var_1 happy_var_2 happy_var_3) - (Warning (EpAnn (glMR happy_var_1 happy_var_2) (fst $ unLoc happy_var_3) cs) (unLoc happy_var_2) - (WarningTxt happy_var_1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3))))}}}) - ) (\r -> happyReturn (happyIn146 r)) - -happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_332 = happyMonadReduce 3# 131# happyReduction_332 -happyReduction_332 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut147 happy_x_1 of { (HappyWrap147 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut148 happy_x_3 of { (HappyWrap148 happy_var_3) -> - ( if isNilOL happy_var_1 - then return (happy_var_1 `appOL` happy_var_3) - else case happy_var_1 of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (snocOL hs t' `appOL` happy_var_3))}}}) - ) (\r -> happyReturn (happyIn147 r)) - -happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_333 = happyMonadReduce 2# 131# happyReduction_333 -happyReduction_333 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut147 happy_x_1 of { (HappyWrap147 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( if isNilOL happy_var_1 - then return happy_var_1 - else case happy_var_1 of - SnocOL hs t -> do - t' <- addTrailingSemiA t (gl happy_var_2) - return (snocOL hs t'))}}) - ) (\r -> happyReturn (happyIn147 r)) - -happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_334 = happySpecReduce_1 131# happyReduction_334 -happyReduction_334 happy_x_1 - = case happyOut148 happy_x_1 of { (HappyWrap148 happy_var_1) -> - happyIn147 - (happy_var_1 - )} - -happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_335 = happySpecReduce_0 131# happyReduction_335 -happyReduction_335 = happyIn147 - (nilOL - ) - -happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_336 = happyMonadReduce 2# 132# happyReduction_336 -happyReduction_336 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> - case happyOut149 happy_x_2 of { (HappyWrap149 happy_var_2) -> - ( fmap unitOL $ acsA (\cs -> sLL happy_var_1 happy_var_2 $ (Warning (EpAnn (glR happy_var_1) (fst $ unLoc happy_var_2) cs) (unLoc happy_var_1) - (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2))))}}) - ) (\r -> happyReturn (happyIn148 r)) - -happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_337 = happySpecReduce_1 133# happyReduction_337 -happyReduction_337 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn149 - (sL1 happy_var_1 ([],[L (gl happy_var_1) (getStringLiteral happy_var_1)]) - )} - -happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_338 = happySpecReduce_3 133# happyReduction_338 -happyReduction_338 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut150 happy_x_2 of { (HappyWrap150 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn149 - (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) - )}}} - -happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_339 = happyMonadReduce 3# 134# happyReduction_339 -happyReduction_339 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut150 happy_x_1 of { (HappyWrap150 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( if isNilOL (unLoc happy_var_1) - then return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` - (L (gl happy_var_3) (getStringLiteral happy_var_3)))) - else case (unLoc happy_var_1) of - SnocOL hs t -> do - let { t' = addTrailingCommaS t (glAA happy_var_2) } - return (sLL happy_var_1 happy_var_3 (snocOL hs t' `snocOL` - (L (gl happy_var_3) (getStringLiteral happy_var_3)))))}}}) - ) (\r -> happyReturn (happyIn150 r)) - -happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_340 = happySpecReduce_1 134# happyReduction_340 -happyReduction_340 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn150 - (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getStringLiteral happy_var_1))) - )} - -happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_341 = happySpecReduce_0 134# happyReduction_341 -happyReduction_341 = happyIn150 - (noLoc nilOL - ) - -happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_342 = happyMonadReduce 4# 135# happyReduction_342 -happyReduction_342 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> - case happyOut219 happy_x_3 of { (HappyWrap219 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> - acsA (\cs -> sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation - ((EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_4) []) cs), - (getANN_PRAGs happy_var_1)) - (ValueAnnProvenance happy_var_2) happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn151 r)) - -happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_343 = happyMonadReduce 5# 135# happyReduction_343 -happyReduction_343 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut292 happy_x_3 of { (HappyWrap292 happy_var_3) -> - case happyOut219 happy_x_4 of { (HappyWrap219 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> - acsA (\cs -> sLL happy_var_1 happy_var_5 (AnnD noExtField $ HsAnnotation - ((EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_5) [mj AnnType happy_var_2]) cs), - (getANN_PRAGs happy_var_1)) - (TypeAnnProvenance happy_var_3) happy_var_4)))}}}}}) - ) (\r -> happyReturn (happyIn151 r)) - -happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_344 = happyMonadReduce 4# 135# happyReduction_344 -happyReduction_344 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut219 happy_x_3 of { (HappyWrap219 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> - acsA (\cs -> sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation - ((EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_4) [mj AnnModule happy_var_2]) cs), - (getANN_PRAGs happy_var_1)) - ModuleAnnProvenance happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn151 r)) - -happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_345 = happyMonadReduce 4# 136# happyReduction_345 -happyReduction_345 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> - case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> - case happyOut155 happy_x_4 of { (HappyWrap155 happy_var_4) -> - ( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) >>= \i -> - return (sLL happy_var_1 happy_var_4 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_4),i)))}}}}) - ) (\r -> happyReturn (happyIn152 r)) - -happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_346 = happyMonadReduce 3# 136# happyReduction_346 -happyReduction_346 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> - case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> - ( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3); - return (sLL happy_var_1 happy_var_3 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_3),d)) })}}}) - ) (\r -> happyReturn (happyIn152 r)) - -happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_347 = happyMonadReduce 3# 136# happyReduction_347 -happyReduction_347 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> - case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> - ( mkExport happy_var_2 (snd $ unLoc happy_var_3) >>= \i -> - return (sLL happy_var_1 happy_var_3 (mj AnnExport happy_var_1 : (fst $ unLoc happy_var_3),i) ))}}}) - ) (\r -> happyReturn (happyIn152 r)) - -happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_348 = happySpecReduce_1 137# happyReduction_348 -happyReduction_348 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn153 - (sLL happy_var_1 happy_var_1 StdCallConv - )} - -happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_349 = happySpecReduce_1 137# happyReduction_349 -happyReduction_349 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn153 - (sLL happy_var_1 happy_var_1 CCallConv - )} - -happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_350 = happySpecReduce_1 137# happyReduction_350 -happyReduction_350 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn153 - (sLL happy_var_1 happy_var_1 CApiConv - )} - -happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_351 = happySpecReduce_1 137# happyReduction_351 -happyReduction_351 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn153 - (sLL happy_var_1 happy_var_1 PrimCallConv - )} - -happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_352 = happySpecReduce_1 137# happyReduction_352 -happyReduction_352 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn153 - (sLL happy_var_1 happy_var_1 JavaScriptCallConv - )} - -happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_353 = happySpecReduce_1 138# happyReduction_353 -happyReduction_353 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn154 - (sLL happy_var_1 happy_var_1 PlayRisky - )} - -happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_354 = happySpecReduce_1 138# happyReduction_354 -happyReduction_354 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn154 - (sLL happy_var_1 happy_var_1 PlaySafe - )} - -happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_355 = happySpecReduce_1 138# happyReduction_355 -happyReduction_355 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn154 - (sLL happy_var_1 happy_var_1 PlayInterruptible - )} - -happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_356 = happyReduce 4# 139# happyReduction_356 -happyReduction_356 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> - happyIn155 - (sLL happy_var_1 (reLoc happy_var_4) ([mu AnnDcolon happy_var_3] - ,(L (getLoc happy_var_1) - (getStringLiteral happy_var_1), happy_var_2, happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_357 = happySpecReduce_3 139# happyReduction_357 -happyReduction_357 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - happyIn155 - (sLL (reLocN happy_var_1) (reLoc happy_var_3) ([mu AnnDcolon happy_var_2] - ,(noLoc (StringLiteral NoSourceText nilFS Nothing), happy_var_1, happy_var_3)) - )}}} - -happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_358 = happySpecReduce_0 140# happyReduction_358 -happyReduction_358 = happyIn156 - (Nothing - ) - -happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_359 = happySpecReduce_2 140# happyReduction_359 -happyReduction_359 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut165 happy_x_2 of { (HappyWrap165 happy_var_2) -> - happyIn156 - (Just (mu AnnDcolon happy_var_1, happy_var_2) - )}} - -happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_360 = happySpecReduce_0 141# happyReduction_360 -happyReduction_360 = happyIn157 - (([], Nothing) - ) - -happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_361 = happySpecReduce_2 141# happyReduction_361 -happyReduction_361 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut283 happy_x_2 of { (HappyWrap283 happy_var_2) -> - happyIn157 - (([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_362 = happySpecReduce_1 142# happyReduction_362 -happyReduction_362 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn158 - (happy_var_1 - )} - -happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_363 = happyMonadReduce 3# 142# happyReduction_363 -happyReduction_363 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut187 happy_x_3 of { (HappyWrap187 happy_var_3) -> - ( acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ mkHsImplicitSigType $ - sLLa (reLoc happy_var_1) (reLoc happy_var_3) $ HsKindSig (EpAnn (glAR happy_var_1) [mu AnnDcolon happy_var_2] cs) happy_var_1 happy_var_3))}}}) - ) (\r -> happyReturn (happyIn158 r)) - -happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_364 = happySpecReduce_1 143# happyReduction_364 -happyReduction_364 happy_x_1 - = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - happyIn159 - (hsTypeToHsSigType happy_var_1 - )} - -happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_365 = happyMonadReduce 3# 144# happyReduction_365 -happyReduction_365 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut303 happy_x_3 of { (HappyWrap303 happy_var_3) -> - ( case unLoc happy_var_1 of - [] -> return (sLL happy_var_1 (reLocN happy_var_3) (happy_var_3 : unLoc happy_var_1)) - (h:t) -> do - h' <- addTrailingCommaN h (gl happy_var_2) - return (sLL happy_var_1 (reLocN happy_var_3) (happy_var_3 : h' : t)))}}}) - ) (\r -> happyReturn (happyIn160 r)) - -happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_366 = happySpecReduce_1 144# happyReduction_366 -happyReduction_366 happy_x_1 - = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - happyIn160 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_367 = happySpecReduce_1 145# happyReduction_367 -happyReduction_367 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn161 - (unitOL happy_var_1 - )} - -happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_368 = happyMonadReduce 3# 145# happyReduction_368 -happyReduction_368 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> - ( do { st <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return $ unitOL st `appOL` happy_var_3 })}}}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_369 = happySpecReduce_2 146# happyReduction_369 -happyReduction_369 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn162 - (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getUNPACK_PRAGs happy_var_1) SrcUnpack) - )}} - -happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_370 = happySpecReduce_2 146# happyReduction_370 -happyReduction_370 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn162 - (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getNOUNPACK_PRAGs happy_var_1) SrcNoUnpack) - )}} - -happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_371 = happyMonadReduce 3# 147# happyReduction_371 -happyReduction_371 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { hintExplicitForall happy_var_1 - ; acs (\cs -> (sLL happy_var_1 happy_var_3 $ - mkHsForAllInvisTele (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1,mu AnnDot happy_var_3) cs) happy_var_2 )) })}}}) - ) (\r -> happyReturn (happyIn163 r)) - -happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_372 = happyMonadReduce 3# 147# happyReduction_372 -happyReduction_372 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { hintExplicitForall happy_var_1 - ; req_tvbs <- fromSpecTyVarBndrs happy_var_2 - ; acs (\cs -> (sLL happy_var_1 happy_var_3 $ - mkHsForAllVisTele (EpAnn (glR happy_var_1) (mu AnnForall happy_var_1,mu AnnRarrow happy_var_3) cs) req_tvbs )) })}}}) - ) (\r -> happyReturn (happyIn163 r)) - -happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_373 = happySpecReduce_1 148# happyReduction_373 -happyReduction_373 happy_x_1 - = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - happyIn164 - (happy_var_1 - )} - -happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_374 = happyMonadReduce 3# 148# happyReduction_374 -happyReduction_374 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut187 happy_x_3 of { (HappyWrap187 happy_var_3) -> - ( acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsKindSig (EpAnn (glAR happy_var_1) [mu AnnDcolon happy_var_2] cs) happy_var_1 happy_var_3))}}}) - ) (\r -> happyReturn (happyIn164 r)) - -happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_375 = happySpecReduce_2 149# happyReduction_375 -happyReduction_375 happy_x_2 - happy_x_1 - = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> - case happyOut165 happy_x_2 of { (HappyWrap165 happy_var_2) -> - happyIn165 - (reLocA $ sLL happy_var_1 (reLoc happy_var_2) $ - HsForAllTy { hst_tele = unLoc happy_var_1 - , hst_xforall = noExtField - , hst_body = happy_var_2 } - )}} - -happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_376 = happyMonadReduce 3# 149# happyReduction_376 -happyReduction_376 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - ( acsA (\cs -> (sLL (reLoc happy_var_1) (reLoc happy_var_3) $ - HsQualTy { hst_ctxt = addTrailingDarrowC happy_var_1 happy_var_2 cs - , hst_xqual = NoExtField - , hst_body = happy_var_3 })))}}}) - ) (\r -> happyReturn (happyIn165 r)) - -happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_377 = happyMonadReduce 3# 149# happyReduction_377 -happyReduction_377 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - ( acsA (\cs -> sLL happy_var_1 (reLoc happy_var_3) (HsIParamTy (EpAnn (glR happy_var_1) [mu AnnDcolon happy_var_2] cs) (reLocA happy_var_1) happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn165 r)) - -happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_378 = happySpecReduce_1 149# happyReduction_378 -happyReduction_378 happy_x_1 - = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> - happyIn165 - (happy_var_1 - )} - -happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_379 = happyMonadReduce 1# 150# happyReduction_379 -happyReduction_379 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - ( checkContext happy_var_1)}) - ) (\r -> happyReturn (happyIn166 r)) - -happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_380 = happySpecReduce_1 151# happyReduction_380 -happyReduction_380 happy_x_1 - = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - happyIn167 - (happy_var_1 - )} - -happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_381 = happyMonadReduce 3# 151# happyReduction_381 -happyReduction_381 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - ( acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_3) - $ HsFunTy (EpAnn (glAR happy_var_1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok happy_var_2)) happy_var_1 happy_var_3))}}}) - ) (\r -> happyReturn (happyIn167 r)) - -happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_382 = happyMonadReduce 4# 151# happyReduction_382 -happyReduction_382 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut165 happy_x_4 of { (HappyWrap165 happy_var_4) -> - ( hintLinear (getLoc happy_var_2) - >> let arr = (unLoc happy_var_2) (hsUniTok happy_var_3) - in acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_4) - $ HsFunTy (EpAnn (glAR happy_var_1) NoEpAnns cs) arr happy_var_1 happy_var_4))}}}}) - ) (\r -> happyReturn (happyIn167 r)) - -happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_383 = happyMonadReduce 3# 151# happyReduction_383 -happyReduction_383 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - ( hintLinear (getLoc happy_var_2) >> - acsA (\cs -> sLL (reLoc happy_var_1) (reLoc happy_var_3) - $ HsFunTy (EpAnn (glAR happy_var_1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok happy_var_2))) happy_var_1 happy_var_3))}}}) - ) (\r -> happyReturn (happyIn167 r)) - -happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_384 = happySpecReduce_2 152# happyReduction_384 -happyReduction_384 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - happyIn168 - (sLL happy_var_1 (reLoc happy_var_2) (mkMultTy (hsTok happy_var_1) happy_var_2) - )}} - -happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_385 = happyMonadReduce 1# 153# happyReduction_385 -happyReduction_385 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> - ( runPV happy_var_1)}) - ) (\r -> happyReturn (happyIn169 r)) - -happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_386 = happySpecReduce_1 154# happyReduction_386 -happyReduction_386 happy_x_1 - = case happyOut171 happy_x_1 of { (HappyWrap171 happy_var_1) -> - happyIn170 - (happy_var_1 - )} - -happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_387 = happySpecReduce_3 154# happyReduction_387 -happyReduction_387 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut171 happy_x_1 of { (HappyWrap171 happy_var_1) -> - case happyOut173 happy_x_2 of { (HappyWrap173 happy_var_2) -> - case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> - happyIn170 - (happy_var_1 >>= \ happy_var_1 -> - happy_var_3 >>= \ happy_var_3 -> - do { let (op, prom) = happy_var_2 - ; when (looksLikeMult happy_var_1 op happy_var_3) $ hintLinear (getLocA op) - ; mkHsOpTyPV prom happy_var_1 op happy_var_3 } - )}}} - -happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_388 = happySpecReduce_2 154# happyReduction_388 -happyReduction_388 happy_x_2 - happy_x_1 - = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> - case happyOut170 happy_x_2 of { (HappyWrap170 happy_var_2) -> - happyIn170 - (happy_var_2 >>= \ happy_var_2 -> - mkUnpackednessPV happy_var_1 happy_var_2 - )}} - -happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_389 = happySpecReduce_1 155# happyReduction_389 -happyReduction_389 happy_x_1 - = case happyOut174 happy_x_1 of { (HappyWrap174 happy_var_1) -> - happyIn171 - (mkHsAppTyHeadPV happy_var_1 - )} - -happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_390 = happySpecReduce_1 155# happyReduction_390 -happyReduction_390 happy_x_1 - = case happyOut173 happy_x_1 of { (HappyWrap173 happy_var_1) -> - happyIn171 - (failOpFewArgs (fst happy_var_1) - )} - -happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_391 = happySpecReduce_2 155# happyReduction_391 -happyReduction_391 happy_x_2 - happy_x_1 - = case happyOut171 happy_x_1 of { (HappyWrap171 happy_var_1) -> - case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> - happyIn171 - (happy_var_1 >>= \ happy_var_1 -> - mkHsAppTyPV happy_var_1 happy_var_2 - )}} - -happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_392 = happySpecReduce_3 155# happyReduction_392 -happyReduction_392 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut171 happy_x_1 of { (HappyWrap171 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut174 happy_x_3 of { (HappyWrap174 happy_var_3) -> - happyIn171 - (happy_var_1 >>= \ happy_var_1 -> - mkHsAppKindTyPV happy_var_1 (hsTok happy_var_2) happy_var_3 - )}}} - -happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_393 = happySpecReduce_1 156# happyReduction_393 -happyReduction_393 happy_x_1 - = case happyOut174 happy_x_1 of { (HappyWrap174 happy_var_1) -> - happyIn172 - (happy_var_1 - )} - -happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_394 = happyMonadReduce 2# 156# happyReduction_394 -happyReduction_394 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> - case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - ( addUnpackednessP happy_var_1 happy_var_2)}}) - ) (\r -> happyReturn (happyIn172 r)) - -happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_395 = happySpecReduce_1 157# happyReduction_395 -happyReduction_395 happy_x_1 - = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> - happyIn173 - ((happy_var_1, NotPromoted) - )} - -happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_396 = happySpecReduce_1 157# happyReduction_396 -happyReduction_396 happy_x_1 - = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - happyIn173 - ((happy_var_1, NotPromoted) - )} - -happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_397 = happyMonadReduce 2# 157# happyReduction_397 -happyReduction_397 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut282 happy_x_2 of { (HappyWrap282 happy_var_2) -> - ( do { op <- amsrn (sLL happy_var_1 (reLoc happy_var_2) (unLoc happy_var_2)) - (NameAnnQuote (glAA happy_var_1) (gl happy_var_2) []) - ; return (op, IsPromoted) })}}) - ) (\r -> happyReturn (happyIn173 r)) - -happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_398 = happyMonadReduce 2# 157# happyReduction_398 -happyReduction_398 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> - ( do { op <- amsrn (sLL happy_var_1 (reLoc happy_var_2) (unLoc happy_var_2)) - (NameAnnQuote (glAA happy_var_1) (gl happy_var_2) []) - ; return (op, IsPromoted) })}}) - ) (\r -> happyReturn (happyIn173 r)) - -happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_399 = happyMonadReduce 1# 158# happyReduction_399 -happyReduction_399 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> - ( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_400 = happyMonadReduce 1# 158# happyReduction_400 -happyReduction_400 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> - ( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_401 = happyMonadReduce 1# 158# happyReduction_401 -happyReduction_401 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( do { warnStarIsType (getLoc happy_var_1) - ; return $ reLocA $ sL1 happy_var_1 (HsStarTy noExtField (isUnicode happy_var_1)) })}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_402 = happyMonadReduce 2# 158# happyReduction_402 -happyReduction_402 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - ( acsA (\cs -> sLLlA happy_var_1 happy_var_2 (mkBangTy (EpAnn (glR happy_var_1) [mj AnnTilde happy_var_1] cs) SrcLazy happy_var_2)))}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_403 = happyMonadReduce 2# 158# happyReduction_403 -happyReduction_403 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - ( acsA (\cs -> sLLlA happy_var_1 happy_var_2 (mkBangTy (EpAnn (glR happy_var_1) [mj AnnBang happy_var_1] cs) SrcStrict happy_var_2)))}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_404 = happyMonadReduce 3# 158# happyReduction_404 -happyReduction_404 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { decls <- acsA (\cs -> (sLL happy_var_1 happy_var_3 $ HsRecTy (EpAnn (glR happy_var_1) (AnnList (Just $ listAsAnchor happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] []) cs) happy_var_2)) - ; checkRecordSyntax decls })}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_405 = happyMonadReduce 2# 158# happyReduction_405 -happyReduction_405 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_2 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParens (glAA happy_var_1) (glAA happy_var_2)) cs) - HsBoxedOrConstraintTuple []))}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_406 = happyMonadReduce 5# 158# happyReduction_406 -happyReduction_406 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut178 happy_x_4 of { (HappyWrap178 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( do { h <- addTrailingCommaA happy_var_2 (gl happy_var_3) - ; acsA (\cs -> sLL happy_var_1 happy_var_5 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParens (glAA happy_var_1) (glAA happy_var_5)) cs) - HsBoxedOrConstraintTuple (h : happy_var_4)) })}}}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_407 = happyMonadReduce 2# 158# happyReduction_407 -happyReduction_407 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_2 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_2)) cs) HsUnboxedTuple []))}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_408 = happyMonadReduce 3# 158# happyReduction_408 -happyReduction_408 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut178 happy_x_2 of { (HappyWrap178 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsTupleTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_3)) cs) HsUnboxedTuple happy_var_2))}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_409 = happyMonadReduce 3# 158# happyReduction_409 -happyReduction_409 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsSumTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_410 = happyMonadReduce 3# 158# happyReduction_410 -happyReduction_410 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsListTy (EpAnn (glR happy_var_1) (AnnParen AnnParensSquare (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_411 = happyMonadReduce 3# 158# happyReduction_411 -happyReduction_411 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsParTy (EpAnn (glR happy_var_1) (AnnParen AnnParens (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_412 = happySpecReduce_1 158# happyReduction_412 -happyReduction_412 happy_x_1 - = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> - happyIn174 - (mapLocA (HsSpliceTy noExtField) happy_var_1 - )} - -happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_413 = happySpecReduce_1 158# happyReduction_413 -happyReduction_413 happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - happyIn174 - (mapLocA (HsSpliceTy noExtField) happy_var_1 - )} - -happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_414 = happyMonadReduce 2# 158# happyReduction_414 -happyReduction_414 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut273 happy_x_2 of { (HappyWrap273 happy_var_2) -> - ( acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsTyVar (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mjN AnnName happy_var_2] cs) IsPromoted happy_var_2))}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_415 = happyMonadReduce 6# 158# happyReduction_415 -happyReduction_415 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut178 happy_x_5 of { (HappyWrap178 happy_var_5) -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( do { h <- addTrailingCommaA happy_var_3 (gl happy_var_4) - ; acsA (\cs -> sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6] cs) (h : happy_var_5)) })}}}}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_416 = happyMonadReduce 4# 158# happyReduction_416 -happyReduction_416 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut177 happy_x_3 of { (HappyWrap177 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_4 $ HsExplicitListTy (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4] cs) IsPromoted happy_var_3))}}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_417 = happyMonadReduce 2# 158# happyReduction_417 -happyReduction_417 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> - ( acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsTyVar (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1,mjN AnnName happy_var_2] cs) IsPromoted happy_var_2))}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_418 = happyMonadReduce 5# 158# happyReduction_418 -happyReduction_418 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut178 happy_x_4 of { (HappyWrap178 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( do { h <- addTrailingCommaA happy_var_2 (gl happy_var_3) - ; acsA (\cs -> sLL happy_var_1 happy_var_5 $ HsExplicitListTy (EpAnn (glR happy_var_1) [mos happy_var_1,mcs happy_var_5] cs) NotPromoted (h:happy_var_4)) })}}}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_419 = happySpecReduce_1 158# happyReduction_419 -happyReduction_419 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn174 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) - (il_value (getINTEGER happy_var_1)) - )} - -happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_420 = happySpecReduce_1 158# happyReduction_420 -happyReduction_420 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn174 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsCharTy (getCHARs happy_var_1) - (getCHAR happy_var_1) - )} - -happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_421 = happySpecReduce_1 158# happyReduction_421 -happyReduction_421 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn174 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) - (getSTRING happy_var_1) - )} - -happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_422 = happySpecReduce_1 158# happyReduction_422 -happyReduction_422 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn174 - (reLocA $ sL1 happy_var_1 $ mkAnonWildCardTy - )} - -happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_423 = happyMonadReduce 1# 158# happyReduction_423 -happyReduction_423 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( let qname = mkQual tvName (getQVARID happy_var_1) - in acsa (\cs -> sL1a happy_var_1 (HsTyVar (EpAnn (glR happy_var_1) [] cs) NotPromoted (sL1n happy_var_1 $ qname))))}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_424 = happySpecReduce_1 159# happyReduction_424 -happyReduction_424 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn175 - (happy_var_1 - )} - -happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_425 = happySpecReduce_1 160# happyReduction_425 -happyReduction_425 happy_x_1 - = case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - happyIn176 - ([happy_var_1] - )} - -happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_426 = happyMonadReduce 3# 160# happyReduction_426 -happyReduction_426 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut176 happy_x_3 of { (HappyWrap176 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn176 r)) - -happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_427 = happySpecReduce_1 161# happyReduction_427 -happyReduction_427 happy_x_1 - = case happyOut178 happy_x_1 of { (HappyWrap178 happy_var_1) -> - happyIn177 - (happy_var_1 - )} - -happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_428 = happySpecReduce_0 161# happyReduction_428 -happyReduction_428 = happyIn177 - ([] - ) - -happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_429 = happySpecReduce_1 162# happyReduction_429 -happyReduction_429 happy_x_1 - = case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - happyIn178 - ([happy_var_1] - )} - -happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_430 = happyMonadReduce 3# 162# happyReduction_430 -happyReduction_430 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut178 happy_x_3 of { (HappyWrap178 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn178 r)) - -happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_431 = happyMonadReduce 3# 163# happyReduction_431 -happyReduction_431 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> - ( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; return [h,happy_var_3] })}}}) - ) (\r -> happyReturn (happyIn179 r)) - -happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_432 = happyMonadReduce 3# 163# happyReduction_432 -happyReduction_432 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut179 happy_x_3 of { (HappyWrap179 happy_var_3) -> - ( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn179 r)) - -happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_433 = happySpecReduce_2 164# happyReduction_433 -happyReduction_433 happy_x_2 - happy_x_1 - = case happyOut181 happy_x_1 of { (HappyWrap181 happy_var_1) -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - happyIn180 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_434 = happySpecReduce_0 164# happyReduction_434 -happyReduction_434 = happyIn180 - ([] - ) - -happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_435 = happySpecReduce_1 165# happyReduction_435 -happyReduction_435 happy_x_1 - = case happyOut182 happy_x_1 of { (HappyWrap182 happy_var_1) -> - happyIn181 - (happy_var_1 - )} - -happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_436 = happyMonadReduce 3# 165# happyReduction_436 -happyReduction_436 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 (UserTyVar (EpAnn (glR happy_var_1) [moc happy_var_1, mcc happy_var_3] cs) InferredSpec happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn181 r)) - -happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_437 = happyMonadReduce 5# 165# happyReduction_437 -happyReduction_437 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut187 happy_x_4 of { (HappyWrap187 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_5 (KindedTyVar (EpAnn (glR happy_var_1) [moc happy_var_1,mu AnnDcolon happy_var_3 ,mcc happy_var_5] cs) InferredSpec happy_var_2 happy_var_4)))}}}}}) - ) (\r -> happyReturn (happyIn181 r)) - -happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_438 = happyMonadReduce 1# 166# happyReduction_438 -happyReduction_438 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> - ( acsA (\cs -> (sL1 (reLocN happy_var_1) (UserTyVar (EpAnn (glNR happy_var_1) [] cs) SpecifiedSpec happy_var_1))))}) - ) (\r -> happyReturn (happyIn182 r)) - -happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_439 = happyMonadReduce 5# 166# happyReduction_439 -happyReduction_439 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut187 happy_x_4 of { (HappyWrap187 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - ( acsA (\cs -> (sLL happy_var_1 happy_var_5 (KindedTyVar (EpAnn (glR happy_var_1) [mop happy_var_1,mu AnnDcolon happy_var_3 ,mcp happy_var_5] cs) SpecifiedSpec happy_var_2 happy_var_4))))}}}}}) - ) (\r -> happyReturn (happyIn182 r)) - -happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_440 = happySpecReduce_0 167# happyReduction_440 -happyReduction_440 = happyIn183 - (noLoc ([],[]) - ) - -happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_441 = happySpecReduce_2 167# happyReduction_441 -happyReduction_441 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut184 happy_x_2 of { (HappyWrap184 happy_var_2) -> - happyIn183 - ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] - ,reverse (unLoc happy_var_2))) - )}} - -happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_442 = happyMonadReduce 3# 168# happyReduction_442 -happyReduction_442 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut185 happy_x_3 of { (HappyWrap185 happy_var_3) -> - ( - do { let (h:t) = unLoc happy_var_1 -- Safe from fds1 rules - ; h' <- addTrailingCommaA h (gl happy_var_2) - ; return (sLLlA happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}}) - ) (\r -> happyReturn (happyIn184 r)) - -happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_443 = happySpecReduce_1 168# happyReduction_443 -happyReduction_443 happy_x_1 - = case happyOut185 happy_x_1 of { (HappyWrap185 happy_var_1) -> - happyIn184 - (sL1A happy_var_1 [happy_var_1] - )} - -happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_444 = happyMonadReduce 3# 169# happyReduction_444 -happyReduction_444 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut186 happy_x_1 of { (HappyWrap186 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut186 happy_x_3 of { (HappyWrap186 happy_var_3) -> - ( acsA (\cs -> L (comb3 happy_var_1 happy_var_2 happy_var_3) - (FunDep (EpAnn (glR happy_var_1) [mu AnnRarrow happy_var_2] cs) - (reverse (unLoc happy_var_1)) - (reverse (unLoc happy_var_3)))))}}}) - ) (\r -> happyReturn (happyIn185 r)) - -happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_445 = happySpecReduce_0 170# happyReduction_445 -happyReduction_445 = happyIn186 - (noLoc [] - ) - -happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_446 = happySpecReduce_2 170# happyReduction_446 -happyReduction_446 happy_x_2 - happy_x_1 - = case happyOut186 happy_x_1 of { (HappyWrap186 happy_var_1) -> - case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> - happyIn186 - (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : (unLoc happy_var_1)) - )}} - -happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_447 = happySpecReduce_1 171# happyReduction_447 -happyReduction_447 happy_x_1 - = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - happyIn187 - (happy_var_1 - )} - -happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_448 = happyMonadReduce 4# 172# happyReduction_448 -happyReduction_448 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut189 happy_x_3 of { (HappyWrap189 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( checkEmptyGADTs $ - L (comb2 happy_var_1 happy_var_3) - ([mj AnnWhere happy_var_1 - ,moc happy_var_2 - ,mcc happy_var_4] - , unLoc happy_var_3))}}}}) - ) (\r -> happyReturn (happyIn188 r)) - -happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_449 = happyMonadReduce 4# 172# happyReduction_449 -happyReduction_449 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut189 happy_x_3 of { (HappyWrap189 happy_var_3) -> - ( checkEmptyGADTs $ - L (comb2 happy_var_1 happy_var_3) - ([mj AnnWhere happy_var_1] - , unLoc happy_var_3))}}) - ) (\r -> happyReturn (happyIn188 r)) - -happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_450 = happySpecReduce_0 172# happyReduction_450 -happyReduction_450 = happyIn188 - (noLoc ([],[]) - ) - -happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_451 = happyMonadReduce 3# 173# happyReduction_451 -happyReduction_451 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut190 happy_x_1 of { (HappyWrap190 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut189 happy_x_3 of { (HappyWrap189 happy_var_3) -> - ( do { h <- addTrailingSemiA happy_var_1 (gl happy_var_2) - ; return (L (comb2 (reLoc happy_var_1) happy_var_3) (h : unLoc happy_var_3)) })}}}) - ) (\r -> happyReturn (happyIn189 r)) - -happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_452 = happySpecReduce_1 173# happyReduction_452 -happyReduction_452 happy_x_1 - = case happyOut190 happy_x_1 of { (HappyWrap190 happy_var_1) -> - happyIn189 - (L (glA happy_var_1) [happy_var_1] - )} - -happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_453 = happySpecReduce_0 173# happyReduction_453 -happyReduction_453 = happyIn189 - (noLoc [] - ) - -happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_454 = happyMonadReduce 4# 174# happyReduction_454 -happyReduction_454 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> - ( mkGadtDecl (comb2A happy_var_2 happy_var_4) (unLoc happy_var_2) (hsUniTok happy_var_3) happy_var_4)}}}) - ) (\r -> happyReturn (happyIn190 r)) - -happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_455 = happySpecReduce_2 175# happyReduction_455 -happyReduction_455 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut192 happy_x_2 of { (HappyWrap192 happy_var_2) -> - happyIn191 - (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1],unLoc happy_var_2) - )}} - -happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_456 = happyMonadReduce 3# 176# happyReduction_456 -happyReduction_456 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut193 happy_x_3 of { (HappyWrap193 happy_var_3) -> - ( do { let (h:t) = unLoc happy_var_1 - ; h' <- addTrailingVbarA h (gl happy_var_2) - ; return (sLLlA happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}}) - ) (\r -> happyReturn (happyIn192 r)) - -happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_457 = happySpecReduce_1 176# happyReduction_457 -happyReduction_457 happy_x_1 - = case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> - happyIn192 - (sL1A happy_var_1 [happy_var_1] - )} - -happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_458 = happyMonadReduce 4# 177# happyReduction_458 -happyReduction_458 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut194 happy_x_1 of { (HappyWrap194 happy_var_1) -> - case happyOut166 happy_x_2 of { (HappyWrap166 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut195 happy_x_4 of { (HappyWrap195 happy_var_4) -> - ( acsA (\cs -> let (con,details) = unLoc happy_var_4 in - (L (comb4 happy_var_1 (reLoc happy_var_2) happy_var_3 happy_var_4) (mkConDeclH98 - (EpAnn (spanAsAnchor (comb4 happy_var_1 (reLoc happy_var_2) happy_var_3 happy_var_4)) - (mu AnnDarrow happy_var_3:(fst $ unLoc happy_var_1)) cs) - con - (snd $ unLoc happy_var_1) - (Just happy_var_2) - details))))}}}}) - ) (\r -> happyReturn (happyIn193 r)) - -happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_459 = happyMonadReduce 2# 177# happyReduction_459 -happyReduction_459 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut194 happy_x_1 of { (HappyWrap194 happy_var_1) -> - case happyOut195 happy_x_2 of { (HappyWrap195 happy_var_2) -> - ( acsA (\cs -> let (con,details) = unLoc happy_var_2 in - (L (comb2 happy_var_1 happy_var_2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 happy_var_1 happy_var_2)) (fst $ unLoc happy_var_1) cs) - con - (snd $ unLoc happy_var_1) - Nothing -- No context - details))))}}) - ) (\r -> happyReturn (happyIn193 r)) - -happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_460 = happySpecReduce_3 178# happyReduction_460 -happyReduction_460 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn194 - (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2) - )}}} - -happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_461 = happySpecReduce_0 178# happyReduction_461 -happyReduction_461 = happyIn194 - (noLoc ([], Nothing) - ) - -happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_462 = happyMonadReduce 1# 179# happyReduction_462 -happyReduction_462 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> - ( fmap (reLoc. (fmap (\b -> (dataConBuilderCon b, - dataConBuilderDetails b)))) - (runPV happy_var_1))}) - ) (\r -> happyReturn (happyIn195 r)) - -happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_463 = happySpecReduce_0 180# happyReduction_463 -happyReduction_463 = happyIn196 - ([] - ) - -happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_464 = happySpecReduce_1 180# happyReduction_464 -happyReduction_464 happy_x_1 - = case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> - happyIn196 - (happy_var_1 - )} - -happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_465 = happyMonadReduce 3# 181# happyReduction_465 -happyReduction_465 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut197 happy_x_3 of { (HappyWrap197 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn197 r)) - -happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_466 = happySpecReduce_1 181# happyReduction_466 -happyReduction_466 happy_x_1 - = case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> - happyIn197 - ([happy_var_1] - )} - -happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_467 = happyMonadReduce 3# 182# happyReduction_467 -happyReduction_467 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - ( acsA (\cs -> L (comb2 happy_var_1 (reLoc happy_var_3)) - (ConDeclField (EpAnn (glR happy_var_1) [mu AnnDcolon happy_var_2] cs) - (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc happy_var_1))) happy_var_3 Nothing)))}}}) - ) (\r -> happyReturn (happyIn198 r)) - -happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_468 = happySpecReduce_0 183# happyReduction_468 -happyReduction_468 = happyIn199 - (noLoc [] - ) - -happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_469 = happySpecReduce_1 183# happyReduction_469 -happyReduction_469 happy_x_1 - = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> - happyIn199 - (happy_var_1 - )} - -happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_470 = happySpecReduce_2 184# happyReduction_470 -happyReduction_470 happy_x_2 - happy_x_1 - = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> - case happyOut201 happy_x_2 of { (HappyWrap201 happy_var_2) -> - happyIn200 - (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_471 = happySpecReduce_1 184# happyReduction_471 -happyReduction_471 happy_x_1 - = case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> - happyIn200 - (sL1 (reLoc happy_var_1) [happy_var_1] - )} - -happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_472 = happyMonadReduce 2# 185# happyReduction_472 -happyReduction_472 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut202 happy_x_2 of { (HappyWrap202 happy_var_2) -> - ( let { full_loc = comb2A happy_var_1 happy_var_2 } - in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1] cs) Nothing happy_var_2))}}) - ) (\r -> happyReturn (happyIn201 r)) - -happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_473 = happyMonadReduce 3# 185# happyReduction_473 -happyReduction_473 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut89 happy_x_2 of { (HappyWrap89 happy_var_2) -> - case happyOut202 happy_x_3 of { (HappyWrap202 happy_var_3) -> - ( let { full_loc = comb2A happy_var_1 happy_var_3 } - in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1] cs) (Just happy_var_2) happy_var_3))}}}) - ) (\r -> happyReturn (happyIn201 r)) - -happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_474 = happyMonadReduce 3# 185# happyReduction_474 -happyReduction_474 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut202 happy_x_2 of { (HappyWrap202 happy_var_2) -> - case happyOut90 happy_x_3 of { (HappyWrap90 happy_var_3) -> - ( let { full_loc = comb2 happy_var_1 (reLoc happy_var_3) } - in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR happy_var_1) [mj AnnDeriving happy_var_1] cs) (Just happy_var_3) happy_var_2))}}}) - ) (\r -> happyReturn (happyIn201 r)) - -happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_475 = happySpecReduce_1 186# happyReduction_475 -happyReduction_475 happy_x_1 - = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> - happyIn202 - (let { tc = sL1 (reLocL happy_var_1) $ mkHsImplicitSigType $ - sL1 (reLocL happy_var_1) $ HsTyVar noAnn NotPromoted happy_var_1 } in - sL1 (reLocC happy_var_1) (DctSingle noExtField tc) - )} - -happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_476 = happyMonadReduce 2# 186# happyReduction_476 -happyReduction_476 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrc (sLL happy_var_1 happy_var_2 (DctMulti noExtField [])) - (AnnContext Nothing [glAA happy_var_1] [glAA happy_var_2]))}}) - ) (\r -> happyReturn (happyIn202 r)) - -happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_477 = happyMonadReduce 3# 186# happyReduction_477 -happyReduction_477 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut176 happy_x_2 of { (HappyWrap176 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrc (sLL happy_var_1 happy_var_3 (DctMulti noExtField happy_var_2)) - (AnnContext Nothing [glAA happy_var_1] [glAA happy_var_3]))}}}) - ) (\r -> happyReturn (happyIn202 r)) - -happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_478 = happySpecReduce_1 187# happyReduction_478 -happyReduction_478 happy_x_1 - = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - happyIn203 - (happy_var_1 - )} - -happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_479 = happyMonadReduce 3# 187# happyReduction_479 -happyReduction_479 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOut156 happy_x_2 of { (HappyWrap156 happy_var_2) -> - case happyOut205 happy_x_3 of { (HappyWrap205 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - do { let { l = comb2Al happy_var_1 happy_var_3 } - ; r <- checkValDef l happy_var_1 happy_var_2 happy_var_3; - -- Depending upon what the pattern looks like we might get either - -- a FunBind or PatBind back from checkValDef. See Note - -- [FunBind vs PatBind] - ; cs <- getCommentsFor l - ; return $! (sL (commentsA l cs) $ ValD noExtField r) })}}}) - ) (\r -> happyReturn (happyIn203 r)) - -happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_480 = happySpecReduce_1 187# happyReduction_480 -happyReduction_480 happy_x_1 - = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> - happyIn203 - (happy_var_1 - )} - -happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_481 = happySpecReduce_1 188# happyReduction_481 -happyReduction_481 happy_x_1 - = case happyOut203 happy_x_1 of { (HappyWrap203 happy_var_1) -> - happyIn204 - (happy_var_1 - )} - -happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_482 = happyMonadReduce 1# 188# happyReduction_482 -happyReduction_482 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> - ( mkSpliceDecl happy_var_1)}) - ) (\r -> happyReturn (happyIn204 r)) - -happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_483 = happyMonadReduce 3# 189# happyReduction_483 -happyReduction_483 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - case happyOut135 happy_x_3 of { (HappyWrap135 happy_var_3) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - do { let L l (bs, csw) = adaptWhereBinds happy_var_3 - ; let loc = (comb3 happy_var_1 (reLoc happy_var_2) (L l bs)) - ; acs (\cs -> - sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual happy_var_1)) cs) loc happy_var_2) - bs)) })}}}) - ) (\r -> happyReturn (happyIn205 r)) - -happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_484 = happyMonadReduce 2# 189# happyReduction_484 -happyReduction_484 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - case happyOut135 happy_x_2 of { (HappyWrap135 happy_var_2) -> - ( do { let {L l (bs, csw) = adaptWhereBinds happy_var_2} - ; acs (\cs -> sL (comb2 happy_var_1 (L l bs)) - (GRHSs (cs Semi.<> csw) (reverse (unLoc happy_var_1)) bs)) })}}) - ) (\r -> happyReturn (happyIn205 r)) - -happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_485 = happySpecReduce_2 190# happyReduction_485 -happyReduction_485 happy_x_2 - happy_x_1 - = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - happyIn206 - (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_486 = happySpecReduce_1 190# happyReduction_486 -happyReduction_486 happy_x_1 - = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - happyIn206 - (sL1 (reLoc happy_var_1) [happy_var_1] - )} - -happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_487 = happyMonadReduce 4# 191# happyReduction_487 -happyReduction_487 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> - acsA (\cs -> sL (comb2A happy_var_1 happy_var_4) $ GRHS (EpAnn (glR happy_var_1) (GrhsAnn (Just $ glAA happy_var_1) (mj AnnEqual happy_var_3)) cs) (unLoc happy_var_2) happy_var_4))}}}}) - ) (\r -> happyReturn (happyIn207 r)) - -happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_488 = happyMonadReduce 3# 192# happyReduction_488 -happyReduction_488 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - ( do { happy_var_1 <- runPV (unECP happy_var_1) - ; v <- checkValSigLhs happy_var_1 - ; acsA (\cs -> (sLLAl happy_var_1 (reLoc happy_var_3) $ SigD noExtField $ - TypeSig (EpAnn (glAR happy_var_1) (AnnSig (mu AnnDcolon happy_var_2) []) cs) [v] (mkHsWildCardBndrs happy_var_3)))})}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_489 = happyMonadReduce 5# 192# happyReduction_489 -happyReduction_489 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut160 happy_x_3 of { (HappyWrap160 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut159 happy_x_5 of { (HappyWrap159 happy_var_5) -> - ( do { v <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; let sig cs = TypeSig (EpAnn (glNR happy_var_1) (AnnSig (mu AnnDcolon happy_var_4) []) cs) (v : reverse (unLoc happy_var_3)) - (mkHsWildCardBndrs happy_var_5) - ; acsA (\cs -> sLL (reLocN happy_var_1) (reLoc happy_var_5) $ SigD noExtField (sig cs) ) })}}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_490 = happyMonadReduce 3# 192# happyReduction_490 -happyReduction_490 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut75 happy_x_1 of { (HappyWrap75 happy_var_1) -> - case happyOut74 happy_x_2 of { (HappyWrap74 happy_var_2) -> - case happyOut76 happy_x_3 of { (HappyWrap76 happy_var_3) -> - ( do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 happy_var_3 - ; pure (mj AnnVal l2) }) - happy_var_2 - ; let (fixText, fixPrec) = case happy_var_2 of - -- If an explicit precedence isn't supplied, - -- it defaults to maxPrecedence - Nothing -> (NoSourceText, maxPrecedence) - Just l2 -> (fst $ unLoc l2, snd $ unLoc l2) - ; acsA (\cs -> sLL happy_var_1 happy_var_3 $ SigD noExtField - (FixSig (EpAnn (glR happy_var_1) (mj AnnInfix happy_var_1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc happy_var_3) - (Fixity fixText fixPrec (unLoc happy_var_1))))) - })}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_491 = happySpecReduce_1 192# happyReduction_491 -happyReduction_491 happy_x_1 - = case happyOut122 happy_x_1 of { (HappyWrap122 happy_var_1) -> - happyIn208 - (sL1 happy_var_1 . SigD noExtField . unLoc $ happy_var_1 - )} - -happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_492 = happyMonadReduce 4# 192# happyReduction_492 -happyReduction_492 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut278 happy_x_2 of { (HappyWrap278 happy_var_2) -> - case happyOut157 happy_x_3 of { (HappyWrap157 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( let (dcolon, tc) = happy_var_3 - in acsA - (\cs -> sLL happy_var_1 happy_var_4 - (SigD noExtField (CompleteMatchSig ((EpAnn (glR happy_var_1) ([ mo happy_var_1 ] ++ dcolon ++ [mc happy_var_4]) cs), (getCOMPLETE_PRAGs happy_var_1)) happy_var_2 tc))))}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_493 = happyMonadReduce 4# 192# happyReduction_493 -happyReduction_493 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> - case happyOut123 happy_x_3 of { (HappyWrap123 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( acsA (\cs -> (sLL happy_var_1 happy_var_4 $ SigD noExtField (InlineSig (EpAnn (glR happy_var_1) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]) cs) happy_var_3 - (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) - (snd happy_var_2))))))}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_494 = happyMonadReduce 3# 192# happyReduction_494 -happyReduction_494 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> (sLL happy_var_1 happy_var_3 $ SigD noExtField (InlineSig (EpAnn (glR happy_var_1) [mo happy_var_1, mc happy_var_3] cs) happy_var_2 - (mkOpaquePragma (getOPAQUE_PRAGs happy_var_1))))))}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_495 = happyMonadReduce 3# 192# happyReduction_495 -happyReduction_495 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 (SigD noExtField (SCCFunSig ((EpAnn (glR happy_var_1) [mo happy_var_1, mc happy_var_3] cs), (getSCC_PRAGs happy_var_1)) happy_var_2 Nothing))))}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_496 = happyMonadReduce 4# 192# happyReduction_496 -happyReduction_496 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( do { scc <- getSCC happy_var_3 - ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc Nothing - ; acsA (\cs -> sLL happy_var_1 happy_var_4 (SigD noExtField (SCCFunSig ((EpAnn (glR happy_var_1) [mo happy_var_1, mc happy_var_4] cs), (getSCC_PRAGs happy_var_1)) happy_var_2 (Just ( sL1a happy_var_3 str_lit))))) })}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_497 = happyMonadReduce 6# 192# happyReduction_497 -happyReduction_497 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> - case happyOut304 happy_x_3 of { (HappyWrap304 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut161 happy_x_5 of { (HappyWrap161 happy_var_5) -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( acsA (\cs -> - let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) - (NoUserInlinePrag, FunLike) (snd happy_var_2) - in sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig (EpAnn (glR happy_var_1) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)) cs) happy_var_3 (fromOL happy_var_5) inl_prag)))}}}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_498 = happyMonadReduce 6# 192# happyReduction_498 -happyReduction_498 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> - case happyOut304 happy_x_3 of { (HappyWrap304 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut161 happy_x_5 of { (HappyWrap161 happy_var_5) -> - case happyOutTok happy_x_6 of { happy_var_6 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig (EpAnn (glR happy_var_1) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)) cs) happy_var_3 (fromOL happy_var_5) - (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) - (getSPEC_INLINE happy_var_1) (snd happy_var_2)))))}}}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_499 = happyMonadReduce 4# 192# happyReduction_499 -happyReduction_499 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut175 happy_x_3 of { (HappyWrap175 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_4 - $ SigD noExtField (SpecInstSig ((EpAnn (glR happy_var_1) [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4] cs), (getSPEC_PRAGs happy_var_1)) happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_500 = happyMonadReduce 3# 192# happyReduction_500 -happyReduction_500 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acsA (\cs -> sLL happy_var_1 happy_var_3 $ SigD noExtField (MinimalSig ((EpAnn (glR happy_var_1) [mo happy_var_1,mc happy_var_3] cs), (getMINIMAL_PRAGs happy_var_1)) happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn208 r)) - -happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_501 = happySpecReduce_0 193# happyReduction_501 -happyReduction_501 = happyIn209 - (([],Nothing) - ) - -happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_502 = happySpecReduce_1 193# happyReduction_502 -happyReduction_502 happy_x_1 - = case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> - happyIn209 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_503 = happySpecReduce_3 194# happyReduction_503 -happyReduction_503 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn210 - (([mj AnnOpenS happy_var_1,mj AnnVal happy_var_2,mj AnnCloseS happy_var_3] - ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) - )}}} - -happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_504 = happyReduce 4# 194# happyReduction_504 -happyReduction_504 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut139 happy_x_2 of { (HappyWrap139 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn210 - ((happy_var_2++[mj AnnOpenS happy_var_1,mj AnnVal happy_var_3,mj AnnCloseS happy_var_4] - ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) - ) `HappyStk` happyRest}}}} - -happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_505 = happySpecReduce_1 195# happyReduction_505 -happyReduction_505 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 - (let { loc = getLoc happy_var_1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 - ; quoterId = mkUnqual varName quoter } - in sL1 happy_var_1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) - )} - -happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_506 = happySpecReduce_1 195# happyReduction_506 -happyReduction_506 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 - (let { loc = getLoc happy_var_1 - ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc happy_var_1 - ; quoterId = mkQual varName (qual, quoter) } - in sL1 happy_var_1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) - )} - -happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_507 = happySpecReduce_3 196# happyReduction_507 -happyReduction_507 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - happyIn212 - (ECP $ - unECP happy_var_1 >>= \ happy_var_1 -> - rejectPragmaPV happy_var_1 >> - mkHsTySigPV (noAnnSrcSpan $ comb2Al happy_var_1 (reLoc happy_var_3)) happy_var_1 happy_var_3 - [(mu AnnDcolon happy_var_2)] - )}}} - -happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_508 = happyMonadReduce 3# 196# happyReduction_508 -happyReduction_508 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - runPV (unECP happy_var_3) >>= \ happy_var_3 -> - fmap ecpFromCmd $ - acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu Annlarrowtail happy_var_2) cs) happy_var_1 happy_var_3 - HsFirstOrderApp True))}}}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_509 = happyMonadReduce 3# 196# happyReduction_509 -happyReduction_509 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - runPV (unECP happy_var_3) >>= \ happy_var_3 -> - fmap ecpFromCmd $ - acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu Annrarrowtail happy_var_2) cs) happy_var_3 happy_var_1 - HsFirstOrderApp False))}}}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_510 = happyMonadReduce 3# 196# happyReduction_510 -happyReduction_510 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - runPV (unECP happy_var_3) >>= \ happy_var_3 -> - fmap ecpFromCmd $ - acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu AnnLarrowtail happy_var_2) cs) happy_var_1 happy_var_3 - HsHigherOrderApp True))}}}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_511 = happyMonadReduce 3# 196# happyReduction_511 -happyReduction_511 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - runPV (unECP happy_var_3) >>= \ happy_var_3 -> - fmap ecpFromCmd $ - acsA (\cs -> sLLAA happy_var_1 happy_var_3 $ HsCmdArrApp (EpAnn (glAR happy_var_1) (mu AnnRarrowtail happy_var_2) cs) happy_var_3 happy_var_1 - HsHigherOrderApp False))}}}) - ) (\r -> happyReturn (happyIn212 r)) - -happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_512 = happySpecReduce_1 196# happyReduction_512 -happyReduction_512 happy_x_1 - = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - happyIn212 - (happy_var_1 - )} - -happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_513 = happySpecReduce_1 196# happyReduction_513 -happyReduction_513 happy_x_1 - = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> - happyIn212 - (happy_var_1 - )} - -happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_514 = happySpecReduce_1 197# happyReduction_514 -happyReduction_514 happy_x_1 - = case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> - happyIn213 - (happy_var_1 - )} - -happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_515 = happySpecReduce_3 197# happyReduction_515 -happyReduction_515 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> - case happyOut214 happy_x_3 of { (HappyWrap214 happy_var_3) -> - happyIn213 - (ECP $ - superInfixOp $ - happy_var_2 >>= \ happy_var_2 -> - unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - rejectPragmaPV happy_var_1 >> - (mkHsOpAppPV (comb2A (reLoc happy_var_1) happy_var_3) happy_var_1 happy_var_2 happy_var_3) - )}}} - -happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_516 = happySpecReduce_1 198# happyReduction_516 -happyReduction_516 happy_x_1 - = case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> - happyIn214 - (happy_var_1 - )} - -happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_517 = happySpecReduce_1 198# happyReduction_517 -happyReduction_517 happy_x_1 - = case happyOut328 happy_x_1 of { (HappyWrap328 happy_var_1) -> - happyIn214 - (happy_var_1 - )} - -happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_518 = happySpecReduce_2 199# happyReduction_518 -happyReduction_518 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> - happyIn215 - (ECP $ - unECP happy_var_2 >>= \ happy_var_2 -> - mkHsNegAppPV (comb2A happy_var_1 happy_var_2) happy_var_2 - [mj AnnMinus happy_var_1] - )}} - -happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_519 = happySpecReduce_1 199# happyReduction_519 -happyReduction_519 happy_x_1 - = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - happyIn215 - (happy_var_1 - )} - -happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_520 = happySpecReduce_1 200# happyReduction_520 -happyReduction_520 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 - ((msemim happy_var_1,True) - )} - -happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_521 = happySpecReduce_0 200# happyReduction_521 -happyReduction_521 = happyIn216 - ((Nothing,False) - ) - -happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_522 = happyMonadReduce 3# 201# happyReduction_522 -happyReduction_522 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( do { scc <- getSCC happy_var_2 - ; acs (\cs -> (sLL happy_var_1 happy_var_3 - (HsPragSCC - ((EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_3) [mj AnnValStr happy_var_2]) cs), - (getSCC_PRAGs happy_var_1)) - (StringLiteral (getSTRINGs happy_var_2) scc Nothing))))})}}}) - ) (\r -> happyReturn (happyIn217 r)) - -happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_523 = happyMonadReduce 3# 201# happyReduction_523 -happyReduction_523 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( acs (\cs -> (sLL happy_var_1 happy_var_3 - (HsPragSCC - ((EpAnn (glR happy_var_1) (AnnPragma (mo happy_var_1) (mc happy_var_3) [mj AnnVal happy_var_2]) cs), - (getSCC_PRAGs happy_var_1)) - (StringLiteral NoSourceText (getVARID happy_var_2) Nothing)))))}}}) - ) (\r -> happyReturn (happyIn217 r)) - -happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_524 = happySpecReduce_2 202# happyReduction_524 -happyReduction_524 happy_x_2 - happy_x_1 - = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - happyIn218 - (ECP $ - superFunArg $ - unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_2 >>= \ happy_var_2 -> - mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc happy_var_1) happy_var_2) happy_var_1 happy_var_2 - )}} - -happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_525 = happySpecReduce_3 202# happyReduction_525 -happyReduction_525 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut174 happy_x_3 of { (HappyWrap174 happy_var_3) -> - happyIn218 - (ECP $ - unECP happy_var_1 >>= \ happy_var_1 -> - mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc happy_var_1) (reLoc happy_var_3)) happy_var_1 (hsTok happy_var_2) happy_var_3 - )}}} - -happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_526 = happyMonadReduce 2# 202# happyReduction_526 -happyReduction_526 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 (reLoc happy_var_2) $ HsStatic (EpAnn (glR happy_var_1) [mj AnnStatic happy_var_1] cs) happy_var_2))}}) - ) (\r -> happyReturn (happyIn218 r)) - -happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_527 = happySpecReduce_1 202# happyReduction_527 -happyReduction_527 happy_x_1 - = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - happyIn218 - (happy_var_1 - )} - -happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_528 = happySpecReduce_3 203# happyReduction_528 -happyReduction_528 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut219 happy_x_3 of { (HappyWrap219 happy_var_3) -> - happyIn219 - (ECP $ - unECP happy_var_3 >>= \ happy_var_3 -> - mkHsAsPatPV (comb2 (reLocN happy_var_1) (reLoc happy_var_3)) happy_var_1 (hsTok happy_var_2) happy_var_3 - )}}} - -happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_529 = happySpecReduce_2 203# happyReduction_529 -happyReduction_529 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - happyIn219 - (ECP $ - unECP happy_var_2 >>= \ happy_var_2 -> - mkHsLazyPatPV (comb2 happy_var_1 (reLoc happy_var_2)) happy_var_2 [mj AnnTilde happy_var_1] - )}} - -happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_530 = happySpecReduce_2 203# happyReduction_530 -happyReduction_530 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - happyIn219 - (ECP $ - unECP happy_var_2 >>= \ happy_var_2 -> - mkHsBangPatPV (comb2 happy_var_1 (reLoc happy_var_2)) happy_var_2 [mj AnnBang happy_var_1] - )}} - -happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_531 = happySpecReduce_2 203# happyReduction_531 -happyReduction_531 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - happyIn219 - (ECP $ - unECP happy_var_2 >>= \ happy_var_2 -> - mkHsNegAppPV (comb2A happy_var_1 happy_var_2) happy_var_2 [mj AnnMinus happy_var_1] - )}} - -happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_532 = happyReduce 4# 203# happyReduction_532 -happyReduction_532 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - happyIn219 - (ECP $ - unECP happy_var_4 >>= \ happy_var_4 -> - mkHsLamPV (comb2 happy_var_1 (reLoc happy_var_4)) (\cs -> mkMatchGroup FromSource - (reLocA $ sLLlA happy_var_1 happy_var_4 - [reLocA $ sLLlA happy_var_1 happy_var_4 - $ Match { m_ext = EpAnn (glR happy_var_1) [mj AnnLam happy_var_1] cs - , m_ctxt = LambdaExpr - , m_pats = happy_var_2 - , m_grhss = unguardedGRHSs (comb2 happy_var_3 (reLoc happy_var_4)) happy_var_4 (EpAnn (glR happy_var_3) (GrhsAnn Nothing (mu AnnRarrow happy_var_3)) emptyComments) }])) - ) `HappyStk` happyRest}}}} - -happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_533 = happyReduce 4# 203# happyReduction_533 -happyReduction_533 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - happyIn219 - (ECP $ - unECP happy_var_4 >>= \ happy_var_4 -> - mkHsLetPV (comb2A happy_var_1 happy_var_4) (hsTok happy_var_1) (unLoc happy_var_2) (hsTok happy_var_3) happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_534 = happySpecReduce_3 203# happyReduction_534 -happyReduction_534 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut326 happy_x_3 of { (HappyWrap326 happy_var_3) -> - happyIn219 - (ECP $ happy_var_3 >>= \ happy_var_3 -> - mkHsLamCasePV (comb2 happy_var_1 (reLoc happy_var_3)) LamCase happy_var_3 [mj AnnLam happy_var_1,mj AnnCase happy_var_2] - )}}} - -happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_535 = happySpecReduce_3 203# happyReduction_535 -happyReduction_535 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut325 happy_x_3 of { (HappyWrap325 happy_var_3) -> - happyIn219 - (ECP $ happy_var_3 >>= \ happy_var_3 -> - mkHsLamCasePV (comb2 happy_var_1 (reLoc happy_var_3)) LamCases happy_var_3 [mj AnnLam happy_var_1,mj AnnCases happy_var_2] - )}}} - -happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_536 = happyMonadReduce 8# 203# happyReduction_536 -happyReduction_536 (happy_x_8 `HappyStk` - happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - case happyOut216 happy_x_3 of { (HappyWrap216 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut212 happy_x_5 of { (HappyWrap212 happy_var_5) -> - case happyOut216 happy_x_6 of { (HappyWrap216 happy_var_6) -> - case happyOutTok happy_x_7 of { happy_var_7 -> - case happyOut212 happy_x_8 of { (HappyWrap212 happy_var_8) -> - ( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) -> - return $ ECP $ - unECP happy_var_5 >>= \ happy_var_5 -> - unECP happy_var_8 >>= \ happy_var_8 -> - mkHsIfPV (comb2A happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8 - (AnnsIf - { aiIf = glAA happy_var_1 - , aiThen = glAA happy_var_4 - , aiElse = glAA happy_var_7 - , aiThenSemi = fst happy_var_3 - , aiElseSemi = fst happy_var_6}))}}}}}}}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_537 = happyMonadReduce 2# 203# happyReduction_537 -happyReduction_537 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> - ( hintMultiWayIf (getLoc happy_var_1) >>= \_ -> - fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 happy_var_2 $ HsMultiIf (EpAnn (glR happy_var_1) (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)) cs) - (reverse $ snd $ unLoc happy_var_2)))}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_538 = happyMonadReduce 4# 203# happyReduction_538 -happyReduction_538 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut326 happy_x_4 of { (HappyWrap326 happy_var_4) -> - ( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) -> - return $ ECP $ - happy_var_4 >>= \ happy_var_4 -> - mkHsCasePV (comb3 happy_var_1 happy_var_3 (reLoc happy_var_4)) happy_var_2 happy_var_4 - (EpAnnHsCase (glAA happy_var_1) (glAA happy_var_3) []))}}}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_539 = happyMonadReduce 2# 203# happyReduction_539 -happyReduction_539 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut252 happy_x_2 of { (HappyWrap252 happy_var_2) -> - ( do - hintQualifiedDo happy_var_1 - return $ ECP $ - happy_var_2 >>= \ happy_var_2 -> - mkHsDoPV (comb2A happy_var_1 happy_var_2) - (fmap mkModuleNameFS (getDO happy_var_1)) - happy_var_2 - (AnnList (Just $ glAR happy_var_2) Nothing Nothing [mj AnnDo happy_var_1] []))}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_540 = happyMonadReduce 2# 203# happyReduction_540 -happyReduction_540 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut252 happy_x_2 of { (HappyWrap252 happy_var_2) -> - ( hintQualifiedDo happy_var_1 >> runPV happy_var_2 >>= \ happy_var_2 -> - fmap ecpFromExp $ - acsA (\cs -> L (comb2A happy_var_1 happy_var_2) - (mkHsDoAnns (MDoExpr $ - fmap mkModuleNameFS (getMDO happy_var_1)) - happy_var_2 - (EpAnn (glR happy_var_1) (AnnList (Just $ glAR happy_var_2) Nothing Nothing [mj AnnMdo happy_var_1] []) cs) )))}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_541 = happyMonadReduce 4# 203# happyReduction_541 -happyReduction_541 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - ( (checkPattern <=< runPV) (unECP happy_var_2) >>= \ p -> - runPV (unECP happy_var_4) >>= \ happy_var_4@cmd -> - fmap ecpFromExp $ - acsA (\cs -> sLLlA happy_var_1 happy_var_4 $ HsProc (EpAnn (glR happy_var_1) [mj AnnProc happy_var_1,mu AnnRarrow happy_var_3] cs) p (sLLa happy_var_1 (reLoc happy_var_4) $ HsCmdTop noExtField cmd)))}}}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_542 = happySpecReduce_1 203# happyReduction_542 -happyReduction_542 happy_x_1 - = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> - happyIn219 - (happy_var_1 - )} - -happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_543 = happyReduce 4# 204# happyReduction_543 -happyReduction_543 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut258 happy_x_3 of { (HappyWrap258 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn220 - (ECP $ - getBit OverloadedRecordUpdateBit >>= \ overloaded -> - unECP happy_var_1 >>= \ happy_var_1 -> - happy_var_3 >>= \ happy_var_3 -> - mkHsRecordPV overloaded (comb2 (reLoc happy_var_1) happy_var_4) (comb2 happy_var_2 happy_var_4) happy_var_1 happy_var_3 - [moc happy_var_2,mcc happy_var_4] - ) `HappyStk` happyRest}}}} - -happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_544 = happyMonadReduce 3# 204# happyReduction_544 -happyReduction_544 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut305 happy_x_3 of { (HappyWrap305 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - fmap ecpFromExp $ acsa (\cs -> - let fl = sLLa happy_var_2 (reLoc happy_var_3) (DotFieldOcc ((EpAnn (glR happy_var_2) (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments)) happy_var_3) in - mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc happy_var_1) (reLoc happy_var_3)) happy_var_1 fl (EpAnn (glAR happy_var_1) NoEpAnns cs)))}}}) - ) (\r -> happyReturn (happyIn220 r)) - -happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_545 = happySpecReduce_1 204# happyReduction_545 -happyReduction_545 happy_x_1 - = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> - happyIn220 - (happy_var_1 - )} - -happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_546 = happySpecReduce_1 205# happyReduction_546 -happyReduction_546 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn221 - (ECP $ mkHsVarPV $! happy_var_1 - )} - -happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_547 = happySpecReduce_1 205# happyReduction_547 -happyReduction_547 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn221 - (ECP $ mkHsVarPV $! happy_var_1 - )} - -happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_548 = happyMonadReduce 1# 205# happyReduction_548 -happyReduction_548 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> - ( acsExpr (\cs -> sL1a happy_var_1 (HsIPVar (comment (glRR happy_var_1) cs) $! unLoc happy_var_1)))}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_549 = happyMonadReduce 1# 205# happyReduction_549 -happyReduction_549 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> - ( acsExpr (\cs -> sL1a happy_var_1 (HsOverLabel (comment (glRR happy_var_1) cs) (fst $! unLoc happy_var_1) (snd $! unLoc happy_var_1))))}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_550 = happySpecReduce_1 205# happyReduction_550 -happyReduction_550 happy_x_1 - = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> - happyIn221 - (ECP $ pvA (mkHsLitPV $! happy_var_1) - )} - -happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_551 = happySpecReduce_1 205# happyReduction_551 -happyReduction_551 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn221 - (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsIntegral (getINTEGER happy_var_1)) - )} - -happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_552 = happySpecReduce_1 205# happyReduction_552 -happyReduction_552 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn221 - (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1)) - )} - -happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_553 = happySpecReduce_3 205# happyReduction_553 -happyReduction_553 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn221 - (ECP $ - unECP happy_var_2 >>= \ happy_var_2 -> - mkHsParPV (comb2 happy_var_1 happy_var_3) (hsTok happy_var_1) happy_var_2 (hsTok happy_var_3) - )}}} - -happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_554 = happySpecReduce_3 205# happyReduction_554 -happyReduction_554 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut231 happy_x_2 of { (HappyWrap231 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn221 - (ECP $ - happy_var_2 >>= \ happy_var_2 -> - mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Boxed happy_var_2 - [mop happy_var_1,mcp happy_var_3] - )}}} - -happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_555 = happySpecReduce_3 205# happyReduction_555 -happyReduction_555 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut222 happy_x_2 of { (HappyWrap222 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn221 - (ECP $ - acsA (\cs -> sLL happy_var_1 happy_var_3 $ mkRdrProjection (NE.reverse (unLoc happy_var_2)) (EpAnn (glR happy_var_1) (AnnProjection (glAA happy_var_1) (glAA happy_var_3)) cs)) - >>= ecpFromExp' - )}}} - -happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_556 = happySpecReduce_3 205# happyReduction_556 -happyReduction_556 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn221 - (ECP $ - unECP happy_var_2 >>= \ happy_var_2 -> - mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed (Tuple [Right happy_var_2]) - [moh happy_var_1,mch happy_var_3] - )}}} - -happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_557 = happySpecReduce_3 205# happyReduction_557 -happyReduction_557 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut231 happy_x_2 of { (HappyWrap231 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn221 - (ECP $ - happy_var_2 >>= \ happy_var_2 -> - mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed happy_var_2 - [moh happy_var_1,mch happy_var_3] - )}}} - -happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_558 = happySpecReduce_3 205# happyReduction_558 -happyReduction_558 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut234 happy_x_2 of { (HappyWrap234 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn221 - (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) (mos happy_var_1,mcs happy_var_3) - )}}} - -happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_559 = happySpecReduce_1 205# happyReduction_559 -happyReduction_559 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn221 - (ECP $ pvA $ mkHsWildCardPV (getLoc happy_var_1) - )} - -happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_560 = happySpecReduce_1 205# happyReduction_560 -happyReduction_560 happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - happyIn221 - (ECP $ pvA $ mkHsSplicePV happy_var_1 - )} - -happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_561 = happySpecReduce_1 205# happyReduction_561 -happyReduction_561 happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - happyIn221 - (ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA happy_var_1) - )} - -happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_562 = happyMonadReduce 2# 205# happyReduction_562 -happyReduction_562 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> - ( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1] cs) (VarBr noExtField True happy_var_2)))}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_563 = happyMonadReduce 2# 205# happyReduction_563 -happyReduction_563 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut274 happy_x_2 of { (HappyWrap274 happy_var_2) -> - ( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnSimpleQuote happy_var_1] cs) (VarBr noExtField True happy_var_2)))}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_564 = happyMonadReduce 2# 205# happyReduction_564 -happyReduction_564 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut300 happy_x_2 of { (HappyWrap300 happy_var_2) -> - ( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnThTyQuote happy_var_1 ] cs) (VarBr noExtField False happy_var_2)))}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_565 = happyMonadReduce 2# 205# happyReduction_565 -happyReduction_565 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut283 happy_x_2 of { (HappyWrap283 happy_var_2) -> - ( fmap ecpFromExp $ acsA (\cs -> sLL happy_var_1 (reLocN happy_var_2) $ HsUntypedBracket (EpAnn (glR happy_var_1) [mj AnnThTyQuote happy_var_1 ] cs) (VarBr noExtField False happy_var_2)))}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_566 = happyMonadReduce 1# 205# happyReduction_566 -happyReduction_566 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( reportEmptyDoubleQuotes (getLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_567 = happyMonadReduce 3# 205# happyReduction_567 -happyReduction_567 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1, mu AnnCloseQ happy_var_3] - else [mu AnnOpenEQ happy_var_1,mu AnnCloseQ happy_var_3]) cs) (ExpBr noExtField happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_568 = happyMonadReduce 3# 205# happyReduction_568 -happyReduction_568 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsTypedBracket (EpAnn (glR happy_var_1) (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1,mc happy_var_3] else [mo happy_var_1,mc happy_var_3]) cs) happy_var_2))}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_569 = happyMonadReduce 3# 205# happyReduction_569 -happyReduction_569 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) [mo happy_var_1,mu AnnCloseQ happy_var_3] cs) (TypBr noExtField happy_var_2)))}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_570 = happyMonadReduce 3# 205# happyReduction_570 -happyReduction_570 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( (checkPattern <=< runPV) (unECP happy_var_2) >>= \p -> - fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) [mo happy_var_1,mu AnnCloseQ happy_var_3] cs) (PatBr noExtField p)))}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_571 = happyMonadReduce 3# 205# happyReduction_571 -happyReduction_571 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( fmap ecpFromExp $ - acsA (\cs -> sLL happy_var_1 happy_var_3 $ HsUntypedBracket (EpAnn (glR happy_var_1) (mo happy_var_1:mu AnnCloseQ happy_var_3:fst happy_var_2) cs) (DecBrL noExtField (snd happy_var_2))))}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_572 = happySpecReduce_1 205# happyReduction_572 -happyReduction_572 happy_x_1 - = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> - happyIn221 - (ECP $ pvA $ mkHsSplicePV happy_var_1 - )} - -happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_573 = happyMonadReduce 4# 205# happyReduction_573 -happyReduction_573 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { (HappyWrap219 happy_var_2) -> - case happyOut226 happy_x_3 of { (HappyWrap226 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - fmap ecpFromCmd $ - acsA (\cs -> sLL happy_var_1 happy_var_4 $ HsCmdArrForm (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_1) (Just $ mu AnnOpenB happy_var_1) (Just $ mu AnnCloseB happy_var_4) [] []) cs) happy_var_2 Prefix - Nothing (reverse happy_var_3)))}}}}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_574 = happyMonadReduce 3# 206# happyReduction_574 -happyReduction_574 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut305 happy_x_3 of { (HappyWrap305 happy_var_3) -> - ( acs (\cs -> sLL happy_var_1 (reLoc happy_var_3) ((sLLa happy_var_2 (reLoc happy_var_3) $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_2)) cs) happy_var_3) `NE.cons` unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn222 r)) - -happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_575 = happyMonadReduce 2# 206# happyReduction_575 -happyReduction_575 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut305 happy_x_2 of { (HappyWrap305 happy_var_2) -> - ( acs (\cs -> sLL happy_var_1 (reLoc happy_var_2) ((sLLa happy_var_1 (reLoc happy_var_2) $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_1)) cs) happy_var_2) :| [])))}}) - ) (\r -> happyReturn (happyIn222 r)) - -happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_576 = happySpecReduce_1 207# happyReduction_576 -happyReduction_576 happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - happyIn223 - (fmap (HsUntypedSplice noAnn) (reLocA happy_var_1) - )} - -happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_577 = happySpecReduce_1 207# happyReduction_577 -happyReduction_577 happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - happyIn223 - (fmap (uncurry HsTypedSplice) (reLocA happy_var_1) - )} - -happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_578 = happyMonadReduce 2# 208# happyReduction_578 -happyReduction_578 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - acs (\cs -> sLLlA happy_var_1 happy_var_2 $ HsUntypedSpliceExpr (EpAnn (glR happy_var_1) [mj AnnDollar happy_var_1] cs) happy_var_2))}}) - ) (\r -> happyReturn (happyIn224 r)) - -happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_579 = happyMonadReduce 2# 209# happyReduction_579 -happyReduction_579 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - acs (\cs -> sLLlA happy_var_1 happy_var_2 $ ((noAnn, EpAnn (glR happy_var_1) [mj AnnDollarDollar happy_var_1] cs), happy_var_2)))}}) - ) (\r -> happyReturn (happyIn225 r)) - -happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_580 = happySpecReduce_2 210# happyReduction_580 -happyReduction_580 happy_x_2 - happy_x_1 - = case happyOut226 happy_x_1 of { (HappyWrap226 happy_var_1) -> - case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> - happyIn226 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_581 = happySpecReduce_0 210# happyReduction_581 -happyReduction_581 = happyIn226 - ([] - ) - -happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_582 = happyMonadReduce 1# 211# happyReduction_582 -happyReduction_582 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - ( runPV (unECP happy_var_1) >>= \ (cmd :: LHsCmd GhcPs) -> - runPV (checkCmdBlockArguments cmd) >>= \ _ -> - return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd))}) - ) (\r -> happyReturn (happyIn227 r)) - -happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_583 = happySpecReduce_3 212# happyReduction_583 -happyReduction_583 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut229 happy_x_2 of { (HappyWrap229 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn228 - (([mj AnnOpenC happy_var_1 - ,mj AnnCloseC happy_var_3],happy_var_2) - )}}} - -happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_584 = happySpecReduce_3 212# happyReduction_584 -happyReduction_584 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut229 happy_x_2 of { (HappyWrap229 happy_var_2) -> - happyIn228 - (([],happy_var_2) - )} - -happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_585 = happySpecReduce_1 213# happyReduction_585 -happyReduction_585 happy_x_1 - = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> - happyIn229 - (cvTopDecls happy_var_1 - )} - -happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_586 = happySpecReduce_1 213# happyReduction_586 -happyReduction_586 happy_x_1 - = case happyOut77 happy_x_1 of { (HappyWrap77 happy_var_1) -> - happyIn229 - (cvTopDecls happy_var_1 - )} - -happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_587 = happySpecReduce_1 214# happyReduction_587 -happyReduction_587 happy_x_1 - = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - happyIn230 - (happy_var_1 - )} - -happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_588 = happyMonadReduce 2# 214# happyReduction_588 -happyReduction_588 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - runPV (rejectPragmaPV happy_var_1) >> - runPV happy_var_2 >>= \ happy_var_2 -> - return $ ecpFromExp $ - reLocA $ sLL (reLoc happy_var_1) (reLocN happy_var_2) $ SectionL noAnn happy_var_1 (n2l happy_var_2))}}) - ) (\r -> happyReturn (happyIn230 r)) - -happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_589 = happySpecReduce_2 214# happyReduction_589 -happyReduction_589 happy_x_2 - happy_x_1 - = case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - happyIn230 - (ECP $ - superInfixOp $ - unECP happy_var_2 >>= \ happy_var_2 -> - happy_var_1 >>= \ happy_var_1 -> - pvA $ mkHsSectionR_PV (comb2 (reLocN happy_var_1) (reLoc happy_var_2)) (n2l happy_var_1) happy_var_2 - )}} - -happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_590 = happySpecReduce_3 214# happyReduction_590 -happyReduction_590 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> - happyIn230 - (ECP $ - unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - mkHsViewPatPV (comb2 (reLoc happy_var_1) (reLoc happy_var_3)) happy_var_1 happy_var_3 [mu AnnRarrow happy_var_2] - )}}} - -happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_591 = happySpecReduce_2 215# happyReduction_591 -happyReduction_591 happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> - happyIn231 - (unECP happy_var_1 >>= \ happy_var_1 -> - happy_var_2 >>= \ happy_var_2 -> - do { t <- amsA happy_var_1 [AddCommaAnn (srcSpan2e $ fst happy_var_2)] - ; return (Tuple (Right t : snd happy_var_2)) } - )}} - -happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_592 = happySpecReduce_2 215# happyReduction_592 -happyReduction_592 happy_x_2 - happy_x_1 - = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> - case happyOut233 happy_x_2 of { (HappyWrap233 happy_var_2) -> - happyIn231 - (happy_var_2 >>= \ happy_var_2 -> - do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (srcSpan2e ll) emptyComments))) (fst happy_var_1) } - ; return (Tuple (cos ++ happy_var_2)) } - )}} - -happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_593 = happySpecReduce_2 215# happyReduction_593 -happyReduction_593 happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> - happyIn231 - (unECP happy_var_1 >>= \ happy_var_1 -> return $ - (Sum 1 (snd happy_var_2 + 1) happy_var_1 [] (map srcSpan2e $ fst happy_var_2)) - )}} - -happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_594 = happySpecReduce_3 215# happyReduction_594 -happyReduction_594 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> - case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> - case happyOut323 happy_x_3 of { (HappyWrap323 happy_var_3) -> - happyIn231 - (unECP happy_var_2 >>= \ happy_var_2 -> return $ - (Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2 - (map srcSpan2e $ fst happy_var_1) - (map srcSpan2e $ fst happy_var_3)) - )}}} - -happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_595 = happySpecReduce_2 216# happyReduction_595 -happyReduction_595 happy_x_2 - happy_x_1 - = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> - case happyOut233 happy_x_2 of { (HappyWrap233 happy_var_2) -> - happyIn232 - (happy_var_2 >>= \ happy_var_2 -> - do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (srcSpan2e l) emptyComments))) (tail $ fst happy_var_1) } - ; return ((head $ fst happy_var_1, cos ++ happy_var_2)) } - )}} - -happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_596 = happySpecReduce_2 217# happyReduction_596 -happyReduction_596 happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> - happyIn233 - (unECP happy_var_1 >>= \ happy_var_1 -> - happy_var_2 >>= \ happy_var_2 -> - do { t <- amsA happy_var_1 [AddCommaAnn (srcSpan2e $ fst happy_var_2)] - ; return (Right t : snd happy_var_2) } - )}} - -happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_597 = happySpecReduce_1 217# happyReduction_597 -happyReduction_597 happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - happyIn233 - (unECP happy_var_1 >>= \ happy_var_1 -> - return [Right happy_var_1] - )} - -happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_598 = happySpecReduce_0 217# happyReduction_598 -happyReduction_598 = happyIn233 - (return [Left noAnn] - ) - -happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_599 = happySpecReduce_1 218# happyReduction_599 -happyReduction_599 happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - happyIn234 - (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> - mkHsExplicitListPV loc [happy_var_1] (AnnList Nothing (Just ao) (Just ac) [] []) - )} - -happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_600 = happySpecReduce_1 218# happyReduction_600 -happyReduction_600 happy_x_1 - = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> - happyIn234 - (\loc (ao,ac) -> happy_var_1 >>= \ happy_var_1 -> - mkHsExplicitListPV loc (reverse happy_var_1) (AnnList Nothing (Just ao) (Just ac) [] []) - )} - -happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_601 = happySpecReduce_2 218# happyReduction_601 -happyReduction_601 happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn234 - (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot happy_var_2,ac] cs) Nothing (From happy_var_1)) - >>= ecpFromExp' - )}} - -happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_602 = happyReduce 4# 218# happyReduction_602 -happyReduction_602 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn234 - (\loc (ao,ac) -> - unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma happy_var_2,mj AnnDotdot happy_var_4,ac] cs) Nothing (FromThen happy_var_1 happy_var_3)) - >>= ecpFromExp' - ) `HappyStk` happyRest}}}} - -happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_603 = happySpecReduce_3 218# happyReduction_603 -happyReduction_603 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - happyIn234 - (\loc (ao,ac) -> - unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot happy_var_2,ac] cs) Nothing (FromTo happy_var_1 happy_var_3)) - >>= ecpFromExp' - )}}} - -happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_604 = happyReduce 5# 218# happyReduction_604 -happyReduction_604 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut212 happy_x_5 of { (HappyWrap212 happy_var_5) -> - happyIn234 - (\loc (ao,ac) -> - unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - unECP happy_var_5 >>= \ happy_var_5 -> - acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma happy_var_2,mj AnnDotdot happy_var_4,ac] cs) Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5)) - >>= ecpFromExp' - ) `HappyStk` happyRest}}}}} - -happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_605 = happySpecReduce_3 218# happyReduction_605 -happyReduction_605 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut236 happy_x_3 of { (HappyWrap236 happy_var_3) -> - happyIn234 - (\loc (ao,ac) -> - checkMonadComp >>= \ ctxt -> - unECP happy_var_1 >>= \ happy_var_1 -> do { t <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc happy_var_3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs)) - >>= ecpFromExp' } - )}}} - -happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_606 = happySpecReduce_3 219# happyReduction_606 -happyReduction_606 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> - happyIn235 - (happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - case happy_var_1 of - (h:t) -> do - h' <- addTrailingCommaA h (gl happy_var_2) - return (((:) $! happy_var_3) $! (h':t)) - )}}} - -happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_607 = happySpecReduce_3 219# happyReduction_607 -happyReduction_607 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> - happyIn235 - (unECP happy_var_1 >>= \ happy_var_1 -> - unECP happy_var_3 >>= \ happy_var_3 -> - do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return [happy_var_3,h] } - )}}} - -happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_608 = happySpecReduce_1 220# happyReduction_608 -happyReduction_608 happy_x_1 - = case happyOut237 happy_x_1 of { (HappyWrap237 happy_var_1) -> - happyIn236 - (case (unLoc happy_var_1) of - [qs] -> sL1 happy_var_1 qs - -- We just had one thing in our "parallel" list so - -- we simply return that thing directly - - qss -> sL1 happy_var_1 [sL1a happy_var_1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | - qs <- qss] - noExpr noSyntaxExpr] - -- We actually found some actual parallel lists so - -- we wrap them into as a ParStmt - )} - -happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_609 = happyMonadReduce 3# 221# happyReduction_609 -happyReduction_609 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut237 happy_x_3 of { (HappyWrap237 happy_var_3) -> - ( case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingVbarA h (gl happy_var_2) - return (sLL happy_var_1 happy_var_3 (reverse (h':t) : unLoc happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn237 r)) - -happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_610 = happySpecReduce_1 221# happyReduction_610 -happyReduction_610 happy_x_1 - = case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - happyIn237 - (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)] - )} - -happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_611 = happyMonadReduce 3# 222# happyReduction_611 -happyReduction_611 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut239 happy_x_3 of { (HappyWrap239 happy_var_3) -> - ( case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingCommaA h (gl happy_var_2) - return (sLL happy_var_1 happy_var_3 [sLLa happy_var_1 happy_var_3 ((unLoc happy_var_3) (glRR happy_var_1) (reverse (h':t)))]))}}}) - ) (\r -> happyReturn (happyIn238 r)) - -happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_612 = happyMonadReduce 3# 222# happyReduction_612 -happyReduction_612 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut257 happy_x_3 of { (HappyWrap257 happy_var_3) -> - ( runPV happy_var_3 >>= \ happy_var_3 -> - case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingCommaA h (gl happy_var_2) - return (sLL happy_var_1 (reLoc happy_var_3) (happy_var_3 : (h':t))))}}}) - ) (\r -> happyReturn (happyIn238 r)) - -happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_613 = happyMonadReduce 1# 222# happyReduction_613 -happyReduction_613 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut239 happy_x_1 of { (HappyWrap239 happy_var_1) -> - ( return (sLL happy_var_1 happy_var_1 [L (getLocAnn happy_var_1) ((unLoc happy_var_1) (glRR happy_var_1) [])]))}) - ) (\r -> happyReturn (happyIn238 r)) - -happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_614 = happyMonadReduce 1# 222# happyReduction_614 -happyReduction_614 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 [happy_var_1])}) - ) (\r -> happyReturn (happyIn238 r)) - -happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_615 = happyMonadReduce 2# 223# happyReduction_615 -happyReduction_615 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - acs (\cs-> - sLLlA happy_var_1 happy_var_2 (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen happy_var_1] cs) ss happy_var_2))))}}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_616 = happyMonadReduce 4# 223# happyReduction_616 -happyReduction_616 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - runPV (unECP happy_var_4) >>= \ happy_var_4 -> - acs (\cs -> sLLlA happy_var_1 happy_var_4 ( - \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen happy_var_1,mj AnnBy happy_var_3] cs) ss happy_var_2 happy_var_4))))}}}}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_617 = happyMonadReduce 4# 223# happyReduction_617 -happyReduction_617 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> - acs (\cs -> sLLlA happy_var_1 happy_var_4 ( - \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnUsing happy_var_3] cs) ss happy_var_4))))}}}}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_618 = happyMonadReduce 6# 223# happyReduction_618 -happyReduction_618 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut212 happy_x_6 of { (HappyWrap212 happy_var_6) -> - ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> - runPV (unECP happy_var_6) >>= \ happy_var_6 -> - acs (\cs -> sLLlA happy_var_1 happy_var_6 ( - \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnBy happy_var_3,mj AnnUsing happy_var_5] cs) ss happy_var_4 happy_var_6))))}}}}}}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_619 = happySpecReduce_1 224# happyReduction_619 -happyReduction_619 happy_x_1 - = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> - happyIn240 - (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) - )} - -happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_620 = happyMonadReduce 3# 225# happyReduction_620 -happyReduction_620 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut257 happy_x_3 of { (HappyWrap257 happy_var_3) -> - ( runPV happy_var_3 >>= \ happy_var_3 -> - case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingCommaA h (gl happy_var_2) - return (sLL happy_var_1 (reLoc happy_var_3) (happy_var_3 : (h':t))))}}}) - ) (\r -> happyReturn (happyIn241 r)) - -happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_621 = happyMonadReduce 1# 225# happyReduction_621 -happyReduction_621 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 [happy_var_1])}) - ) (\r -> happyReturn (happyIn241 r)) - -happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_622 = happySpecReduce_2 226# happyReduction_622 -happyReduction_622 happy_x_2 - happy_x_1 - = case happyOut243 happy_x_1 of { (HappyWrap243 happy_var_1) -> - case happyOut135 happy_x_2 of { (HappyWrap135 happy_var_2) -> - happyIn242 - (happy_var_1 >>= \alt -> - do { let {L l (bs, csw) = adaptWhereBinds happy_var_2} - ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) } - )}} - -happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_623 = happySpecReduce_2 227# happyReduction_623 -happyReduction_623 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - happyIn243 - (unECP happy_var_2 >>= \ happy_var_2 -> - acs (\cs -> sLLlA happy_var_1 happy_var_2 (unguardedRHS (EpAnn (glR happy_var_1) (GrhsAnn Nothing (mu AnnRarrow happy_var_1)) cs) (comb2 happy_var_1 (reLoc happy_var_2)) happy_var_2)) - )}} - -happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_624 = happySpecReduce_1 227# happyReduction_624 -happyReduction_624 happy_x_1 - = case happyOut244 happy_x_1 of { (HappyWrap244 happy_var_1) -> - happyIn243 - (happy_var_1 >>= \gdpats -> - return $ sL1 gdpats (reverse (unLoc gdpats)) - )} - -happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_625 = happySpecReduce_2 228# happyReduction_625 -happyReduction_625 happy_x_2 - happy_x_1 - = case happyOut244 happy_x_1 of { (HappyWrap244 happy_var_1) -> - case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> - happyIn244 - (happy_var_1 >>= \gdpats -> - happy_var_2 >>= \gdpat -> - return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) - )}} - -happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_626 = happySpecReduce_1 228# happyReduction_626 -happyReduction_626 happy_x_1 - = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> - happyIn244 - (happy_var_1 >>= \gdpat -> return $ sL1A gdpat [gdpat] - )} - -happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_627 = happyMonadReduce 3# 229# happyReduction_627 -happyReduction_627 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut244 happy_x_2 of { (HappyWrap244 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( runPV happy_var_2 >>= \ happy_var_2 -> - return $ sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3],unLoc happy_var_2))}}}) - ) (\r -> happyReturn (happyIn245 r)) - -happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_628 = happyMonadReduce 2# 229# happyReduction_628 -happyReduction_628 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut244 happy_x_1 of { (HappyWrap244 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1 happy_var_1 ([],unLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn245 r)) - -happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_629 = happyReduce 4# 230# happyReduction_629 -happyReduction_629 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut212 happy_x_4 of { (HappyWrap212 happy_var_4) -> - happyIn246 - (unECP happy_var_4 >>= \ happy_var_4 -> - acsA (\cs -> sL (comb2A happy_var_1 happy_var_4) $ GRHS (EpAnn (glR happy_var_1) (GrhsAnn (Just $ glAA happy_var_1) (mu AnnRarrow happy_var_3)) cs) (unLoc happy_var_2) happy_var_4) - ) `HappyStk` happyRest}}}} - -happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_630 = happyMonadReduce 1# 231# happyReduction_630 -happyReduction_630 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - ( (checkPattern <=< runPV) (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn247 r)) - -happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_631 = happySpecReduce_1 232# happyReduction_631 -happyReduction_631 happy_x_1 - = case happyOut247 happy_x_1 of { (HappyWrap247 happy_var_1) -> - happyIn248 - ([ happy_var_1 ] - )} - -happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_632 = happyMonadReduce 1# 233# happyReduction_632 -happyReduction_632 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - ( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess - checkPattern_details incompleteDoBlock - (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn249 r)) - -happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_633 = happyMonadReduce 1# 234# happyReduction_633 -happyReduction_633 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - ( (checkPattern <=< runPV) (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn250 r)) - -happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_634 = happySpecReduce_2 235# happyReduction_634 -happyReduction_634 happy_x_2 - happy_x_1 - = case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> - case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> - happyIn251 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_635 = happySpecReduce_0 235# happyReduction_635 -happyReduction_635 = happyIn251 - ([] - ) - -happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_636 = happySpecReduce_3 236# happyReduction_636 -happyReduction_636 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn252 - (happy_var_2 >>= \ happy_var_2 -> - amsrl (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ stmtsAnchor happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fromOL $ fst $ unLoc happy_var_2) []) - )}}} - -happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_637 = happySpecReduce_3 236# happyReduction_637 -happyReduction_637 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> - happyIn252 - (happy_var_2 >>= \ happy_var_2 -> amsrl - (L (stmtsLoc happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ stmtsAnchor happy_var_2) Nothing Nothing (fromOL $ fst $ unLoc happy_var_2) []) - )} - -happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_638 = happySpecReduce_3 237# happyReduction_638 -happyReduction_638 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut253 happy_x_1 of { (HappyWrap253 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut256 happy_x_3 of { (HappyWrap256 happy_var_3) -> - happyIn253 - (happy_var_1 >>= \ happy_var_1 -> - happy_var_3 >>= \ (happy_var_3 :: LStmt GhcPs (LocatedA b)) -> - case (snd $ unLoc happy_var_1) of - [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) `snocOL` (mj AnnSemi happy_var_2) - ,happy_var_3 : (snd $ unLoc happy_var_1))) - (h:t) -> do - { h' <- addTrailingSemiA h (gl happy_var_2) - ; return $ sLL happy_var_1 (reLoc happy_var_3) (fst $ unLoc happy_var_1,happy_var_3 :(h':t)) } - )}}} - -happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_639 = happySpecReduce_2 237# happyReduction_639 -happyReduction_639 happy_x_2 - happy_x_1 - = case happyOut253 happy_x_1 of { (HappyWrap253 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn253 - (happy_var_1 >>= \ happy_var_1 -> - case (snd $ unLoc happy_var_1) of - [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) `snocOL` (mj AnnSemi happy_var_2),snd $ unLoc happy_var_1)) - (h:t) -> do - { h' <- addTrailingSemiA h (gl happy_var_2) - ; return $ sL1 happy_var_1 (fst $ unLoc happy_var_1,h':t) } - )}} - -happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_640 = happySpecReduce_1 237# happyReduction_640 -happyReduction_640 happy_x_1 - = case happyOut256 happy_x_1 of { (HappyWrap256 happy_var_1) -> - happyIn253 - (happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 (nilOL,[happy_var_1]) - )} - -happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_641 = happySpecReduce_0 237# happyReduction_641 -happyReduction_641 = happyIn253 - (return $ noLoc (nilOL,[]) - ) - -happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_642 = happyMonadReduce 1# 238# happyReduction_642 -happyReduction_642 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut256 happy_x_1 of { (HappyWrap256 happy_var_1) -> - ( fmap Just (runPV happy_var_1))}) - ) (\r -> happyReturn (happyIn254 r)) - -happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_643 = happySpecReduce_0 238# happyReduction_643 -happyReduction_643 = happyIn254 - (Nothing - ) - -happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_644 = happyMonadReduce 1# 239# happyReduction_644 -happyReduction_644 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut256 happy_x_1 of { (HappyWrap256 happy_var_1) -> - ( runPV happy_var_1)}) - ) (\r -> happyReturn (happyIn255 r)) - -happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_645 = happySpecReduce_1 240# happyReduction_645 -happyReduction_645 happy_x_1 - = case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> - happyIn256 - (happy_var_1 - )} - -happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_646 = happySpecReduce_2 240# happyReduction_646 -happyReduction_646 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut252 happy_x_2 of { (HappyWrap252 happy_var_2) -> - happyIn256 - (happy_var_2 >>= \ happy_var_2 -> - acsA (\cs -> (sLL happy_var_1 (reLoc happy_var_2) $ mkRecStmt - (EpAnn (glR happy_var_1) (hsDoAnn happy_var_1 happy_var_2 AnnRec) cs) - happy_var_2)) - )}} - -happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_647 = happySpecReduce_3 241# happyReduction_647 -happyReduction_647 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - happyIn257 - (unECP happy_var_3 >>= \ happy_var_3 -> - acsA (\cs -> sLLlA (reLoc happy_var_1) happy_var_3 - $ mkPsBindStmt (EpAnn (glAR happy_var_1) [mu AnnLarrow happy_var_2] cs) happy_var_1 happy_var_3) - )}}} - -happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_648 = happySpecReduce_1 241# happyReduction_648 -happyReduction_648 happy_x_1 - = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - happyIn257 - (unECP happy_var_1 >>= \ happy_var_1 -> - return $ sL1 happy_var_1 $ mkBodyStmt happy_var_1 - )} - -happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_649 = happySpecReduce_2 241# happyReduction_649 -happyReduction_649 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> - happyIn257 - (acsA (\cs -> (sLL happy_var_1 happy_var_2 - $ mkLetStmt (EpAnn (glR happy_var_1) [mj AnnLet happy_var_1] cs) (unLoc happy_var_2))) - )}} - -happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_650 = happySpecReduce_1 242# happyReduction_650 -happyReduction_650 happy_x_1 - = case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> - happyIn258 - (happy_var_1 - )} - -happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_651 = happySpecReduce_0 242# happyReduction_651 -happyReduction_651 = happyIn258 - (return ([], Nothing) - ) - -happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_652 = happySpecReduce_3 243# happyReduction_652 -happyReduction_652 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut260 happy_x_1 of { (HappyWrap260 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut259 happy_x_3 of { (HappyWrap259 happy_var_3) -> - happyIn259 - (happy_var_1 >>= \ happy_var_1 -> - happy_var_3 >>= \ happy_var_3 -> do - h <- addTrailingCommaFBind happy_var_1 (gl happy_var_2) - return (case happy_var_3 of (flds, dd) -> (h : flds, dd)) - )}}} - -happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_653 = happySpecReduce_1 243# happyReduction_653 -happyReduction_653 happy_x_1 - = case happyOut260 happy_x_1 of { (HappyWrap260 happy_var_1) -> - happyIn259 - (happy_var_1 >>= \ happy_var_1 -> - return ([happy_var_1], Nothing) - )} - -happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_654 = happySpecReduce_1 243# happyReduction_654 -happyReduction_654 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn259 - (return ([], Just (getLoc happy_var_1)) - )} - -happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_655 = happySpecReduce_3 244# happyReduction_655 -happyReduction_655 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> - happyIn260 - (unECP happy_var_3 >>= \ happy_var_3 -> - fmap Left $ acsA (\cs -> sLL (reLocN happy_var_1) (reLoc happy_var_3) $ HsFieldBind (EpAnn (glNR happy_var_1) [mj AnnEqual happy_var_2] cs) (sL1l happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) - )}}} - -happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_656 = happySpecReduce_1 244# happyReduction_656 -happyReduction_656 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn260 - (placeHolderPunRhs >>= \rhs -> - fmap Left $ acsa (\cs -> sL1a (reLocN happy_var_1) $ HsFieldBind (EpAnn (glNR happy_var_1) [] cs) (sL1l happy_var_1 $ mkFieldOcc happy_var_1) rhs True) - )} - -happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_657 = happyReduce 5# 244# happyReduction_657 -happyReduction_657 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut261 happy_x_3 of { (HappyWrap261 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut230 happy_x_5 of { (HappyWrap230 happy_var_5) -> - happyIn260 - (do - let top = sL1 (la2la happy_var_1) $ DotFieldOcc noAnn happy_var_1 - ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) - lf' = comb2 happy_var_2 (reLoc $ L lf ()) - fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t - final = last fields - l = comb2 (reLoc happy_var_1) happy_var_3 - isPun = False - happy_var_5 <- unECP happy_var_5 - fmap Right $ mkHsProjUpdatePV (comb2 (reLoc happy_var_1) (reLoc happy_var_5)) (L l fields) happy_var_5 isPun - [mj AnnEqual happy_var_4] - ) `HappyStk` happyRest}}}}} - -happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_658 = happySpecReduce_3 244# happyReduction_658 -happyReduction_658 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut261 happy_x_3 of { (HappyWrap261 happy_var_3) -> - happyIn260 - (do - let top = sL1 (la2la happy_var_1) $ DotFieldOcc noAnn happy_var_1 - ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) - lf' = comb2 happy_var_2 (reLoc $ L lf ()) - fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments) f) : t - final = last fields - l = comb2 (reLoc happy_var_1) happy_var_3 - isPun = True - var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final)) - fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun [] - )}}} - -happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_659 = happyMonadReduce 3# 245# happyReduction_659 -happyReduction_659 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut305 happy_x_3 of { (HappyWrap305 happy_var_3) -> - ( getCommentsFor (getLocA happy_var_3) >>= \cs -> - return (sLL happy_var_1 (reLoc happy_var_3) ((sLLa happy_var_2 (reLoc happy_var_3) (DotFieldOcc (EpAnn (glR happy_var_2) (AnnFieldLabel $ Just $ glAA happy_var_2) cs) happy_var_3)) : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn261 r)) - -happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_660 = happyMonadReduce 1# 245# happyReduction_660 -happyReduction_660 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> - ( getCommentsFor (getLocA happy_var_1) >>= \cs -> - return (sL1 (reLoc happy_var_1) [sL1a (reLoc happy_var_1) (DotFieldOcc (EpAnn (glNR happy_var_1) (AnnFieldLabel Nothing) cs) happy_var_1)]))}) - ) (\r -> happyReturn (happyIn261 r)) - -happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_661 = happyMonadReduce 3# 246# happyReduction_661 -happyReduction_661 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut263 happy_x_3 of { (HappyWrap263 happy_var_3) -> - ( case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (let { this = happy_var_3; rest = h':t } - in rest `seq` this `seq` sLL happy_var_1 (reLoc happy_var_3) (this : rest)))}}}) - ) (\r -> happyReturn (happyIn262 r)) - -happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_662 = happyMonadReduce 2# 246# happyReduction_662 -happyReduction_662 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( case unLoc happy_var_1 of - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (h':t)))}}) - ) (\r -> happyReturn (happyIn262 r)) - -happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_663 = happySpecReduce_1 246# happyReduction_663 -happyReduction_663 happy_x_1 - = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> - happyIn262 - (let this = happy_var_1 in this `seq` (sL1 (reLoc happy_var_1) [this]) - )} - -happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_664 = happyMonadReduce 3# 247# happyReduction_664 -happyReduction_664 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> - ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> - acsA (\cs -> sLLlA happy_var_1 happy_var_3 (IPBind (EpAnn (glR happy_var_1) [mj AnnEqual happy_var_2] cs) (reLocA happy_var_1) happy_var_3)))}}}) - ) (\r -> happyReturn (happyIn263 r)) - -happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_665 = happySpecReduce_1 248# happyReduction_665 -happyReduction_665 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn264 - (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) - )} - -happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_666 = happySpecReduce_1 249# happyReduction_666 -happyReduction_666 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn265 - (sL1 happy_var_1 (getLABELVARIDs happy_var_1, getLABELVARID happy_var_1) - )} - -happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_667 = happySpecReduce_1 250# happyReduction_667 -happyReduction_667 happy_x_1 - = case happyOut267 happy_x_1 of { (HappyWrap267 happy_var_1) -> - happyIn266 - (happy_var_1 - )} - -happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_668 = happySpecReduce_0 250# happyReduction_668 -happyReduction_668 = happyIn266 - (noLocA mkTrue - ) - -happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_669 = happySpecReduce_1 251# happyReduction_669 -happyReduction_669 happy_x_1 - = case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> - happyIn267 - (happy_var_1 - )} - -happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_670 = happyMonadReduce 3# 251# happyReduction_670 -happyReduction_670 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut267 happy_x_3 of { (HappyWrap267 happy_var_3) -> - ( do { h <- addTrailingVbarL happy_var_1 (gl happy_var_2) - ; return (reLocA $ sLLAA happy_var_1 happy_var_3 (Or [h,happy_var_3])) })}}}) - ) (\r -> happyReturn (happyIn267 r)) - -happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_671 = happySpecReduce_1 252# happyReduction_671 -happyReduction_671 happy_x_1 - = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - happyIn268 - (reLocA $ sLLAA (head happy_var_1) (last happy_var_1) (And (happy_var_1)) - )} - -happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_672 = happySpecReduce_1 253# happyReduction_672 -happyReduction_672 happy_x_1 - = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - happyIn269 - ([happy_var_1] - )} - -happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_673 = happyMonadReduce 3# 253# happyReduction_673 -happyReduction_673 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut269 happy_x_3 of { (HappyWrap269 happy_var_3) -> - ( do { h <- addTrailingCommaL happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn269 r)) - -happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_674 = happyMonadReduce 3# 254# happyReduction_674 -happyReduction_674 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut267 happy_x_2 of { (HappyWrap267 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrl (sLL happy_var_1 happy_var_3 (Parens happy_var_2)) - (AnnList Nothing (Just (mop happy_var_1)) (Just (mcp happy_var_3)) [] []))}}}) - ) (\r -> happyReturn (happyIn270 r)) - -happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_675 = happySpecReduce_1 254# happyReduction_675 -happyReduction_675 happy_x_1 - = case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> - happyIn270 - (reLocA $ sL1N happy_var_1 (Var happy_var_1) - )} - -happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_676 = happySpecReduce_1 255# happyReduction_676 -happyReduction_676 happy_x_1 - = case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> - happyIn271 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_677 = happyMonadReduce 3# 255# happyReduction_677 -happyReduction_677 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { (HappyWrap271 happy_var_3) -> - ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; return (sLL (reLocN happy_var_1) happy_var_3 (h : unLoc happy_var_3)) })}}}) - ) (\r -> happyReturn (happyIn271 r)) - -happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_678 = happySpecReduce_1 256# happyReduction_678 -happyReduction_678 happy_x_1 - = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - happyIn272 - (happy_var_1 - )} - -happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_679 = happySpecReduce_1 256# happyReduction_679 -happyReduction_679 happy_x_1 - = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - happyIn272 - (happy_var_1 - )} - -happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_680 = happySpecReduce_1 257# happyReduction_680 -happyReduction_680 happy_x_1 - = case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> - happyIn273 - (happy_var_1 - )} - -happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_681 = happySpecReduce_1 257# happyReduction_681 -happyReduction_681 happy_x_1 - = case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> - happyIn273 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_682 = happySpecReduce_1 258# happyReduction_682 -happyReduction_682 happy_x_1 - = case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> - happyIn274 - (happy_var_1 - )} - -happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_683 = happySpecReduce_1 258# happyReduction_683 -happyReduction_683 happy_x_1 - = case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> - happyIn274 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_684 = happySpecReduce_1 259# happyReduction_684 -happyReduction_684 happy_x_1 - = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> - happyIn275 - (happy_var_1 - )} - -happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_685 = happyMonadReduce 3# 259# happyReduction_685 -happyReduction_685 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn275 r)) - -happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_686 = happySpecReduce_1 260# happyReduction_686 -happyReduction_686 happy_x_1 - = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> - happyIn276 - (happy_var_1 - )} - -happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_687 = happyMonadReduce 3# 260# happyReduction_687 -happyReduction_687 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn276 r)) - -happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_688 = happySpecReduce_1 260# happyReduction_688 -happyReduction_688 happy_x_1 - = case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> - happyIn276 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_689 = happySpecReduce_1 261# happyReduction_689 -happyReduction_689 happy_x_1 - = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - happyIn277 - (sL1N happy_var_1 (pure happy_var_1) - )} - -happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_690 = happyMonadReduce 3# 261# happyReduction_690 -happyReduction_690 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut277 happy_x_3 of { (HappyWrap277 happy_var_3) -> - ( sLL (reLocN happy_var_1) happy_var_3 . (:| toList (unLoc happy_var_3)) <$> addTrailingCommaN happy_var_1 (gl happy_var_2))}}}) - ) (\r -> happyReturn (happyIn277 r)) - -happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_691 = happySpecReduce_1 262# happyReduction_691 -happyReduction_691 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn278 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_692 = happyMonadReduce 3# 262# happyReduction_692 -happyReduction_692 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut278 happy_x_3 of { (HappyWrap278 happy_var_3) -> - ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; return (sLL (reLocN happy_var_1) happy_var_3 (h : unLoc happy_var_3)) })}}}) - ) (\r -> happyReturn (happyIn278 r)) - -happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_693 = happyMonadReduce 2# 263# happyReduction_693 -happyReduction_693 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 unitDataCon) (NameAnnOnly NameParens (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn279 r)) - -happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_694 = happyMonadReduce 3# 263# happyReduction_694 -happyReduction_694 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) - (NameAnnCommas NameParens (glAA happy_var_1) (map srcSpan2e (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn279 r)) - -happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_695 = happyMonadReduce 2# 263# happyReduction_695 -happyReduction_695 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn279 r)) - -happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_696 = happyMonadReduce 3# 263# happyReduction_696 -happyReduction_696 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) - (NameAnnCommas NameParensHash (glAA happy_var_1) (map srcSpan2e (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn279 r)) - -happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_697 = happySpecReduce_1 264# happyReduction_697 -happyReduction_697 happy_x_1 - = case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> - happyIn280 - (happy_var_1 - )} - -happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_698 = happyMonadReduce 2# 264# happyReduction_698 -happyReduction_698 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 nilDataCon) (NameAnnOnly NameSquare (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn280 r)) - -happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_699 = happySpecReduce_1 265# happyReduction_699 -happyReduction_699 happy_x_1 - = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> - happyIn281 - (happy_var_1 - )} - -happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_700 = happyMonadReduce 3# 265# happyReduction_700 -happyReduction_700 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn281 r)) - -happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_701 = happySpecReduce_1 266# happyReduction_701 -happyReduction_701 happy_x_1 - = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> - happyIn282 - (happy_var_1 - )} - -happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_702 = happyMonadReduce 3# 266# happyReduction_702 -happyReduction_702 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn282 r)) - -happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_703 = happySpecReduce_1 267# happyReduction_703 -happyReduction_703 happy_x_1 - = case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> - happyIn283 - (happy_var_1 - )} - -happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_704 = happyMonadReduce 2# 267# happyReduction_704 -happyReduction_704 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) - (NameAnnOnly NameParens (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn283 r)) - -happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_705 = happyMonadReduce 2# 267# happyReduction_705 -happyReduction_705 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) - (NameAnnOnly NameParensHash (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn283 r)) - -happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_706 = happySpecReduce_1 268# happyReduction_706 -happyReduction_706 happy_x_1 - = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> - happyIn284 - (happy_var_1 - )} - -happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_707 = happyMonadReduce 3# 268# happyReduction_707 -happyReduction_707 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Boxed - (snd happy_var_2 + 1))) - (NameAnnCommas NameParens (glAA happy_var_1) (map srcSpan2e (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn284 r)) - -happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_708 = happyMonadReduce 3# 268# happyReduction_708 -happyReduction_708 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut322 happy_x_2 of { (HappyWrap322 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Unboxed - (snd happy_var_2 + 1))) - (NameAnnCommas NameParensHash (glAA happy_var_1) (map srcSpan2e (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn284 r)) - -happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_709 = happyMonadReduce 3# 268# happyReduction_709 -happyReduction_709 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (sumTyCon (snd happy_var_2 + 1))) - (NameAnnBars NameParensHash (glAA happy_var_1) (map srcSpan2e (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn284 r)) - -happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_710 = happyMonadReduce 3# 268# happyReduction_710 -happyReduction_710 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon) - (NameAnnRArrow (isUnicode happy_var_2) (Just $ glAA happy_var_1) (glAA happy_var_2) (Just $ glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn284 r)) - -happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_711 = happyMonadReduce 2# 268# happyReduction_711 -happyReduction_711 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) - (NameAnnOnly NameSquare (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn284 r)) - -happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_712 = happySpecReduce_1 269# happyReduction_712 -happyReduction_712 happy_x_1 - = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> - happyIn285 - (happy_var_1 - )} - -happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_713 = happyMonadReduce 3# 269# happyReduction_713 -happyReduction_713 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut290 happy_x_2 of { (HappyWrap290 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn285 r)) - -happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_714 = happySpecReduce_1 270# happyReduction_714 -happyReduction_714 happy_x_1 - = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> - happyIn286 - (happy_var_1 - )} - -happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_715 = happyMonadReduce 3# 270# happyReduction_715 -happyReduction_715 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( let { name :: Located RdrName - ; name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) } - in amsrn (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn286 r)) - -happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_716 = happyMonadReduce 3# 270# happyReduction_716 -happyReduction_716 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( let { name :: Located RdrName - ; name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) } - in amsrn (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn286 r)) - -happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_717 = happyMonadReduce 3# 270# happyReduction_717 -happyReduction_717 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( let { name :: Located RdrName - ; name = sL1 happy_var_2 $! consDataCon_RDR } - in amsrn (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn286 r)) - -happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_718 = happySpecReduce_1 271# happyReduction_718 -happyReduction_718 happy_x_1 - = case happyOut290 happy_x_1 of { (HappyWrap290 happy_var_1) -> - happyIn287 - (happy_var_1 - )} - -happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_719 = happyMonadReduce 3# 271# happyReduction_719 -happyReduction_719 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut288 happy_x_2 of { (HappyWrap288 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn287 r)) - -happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_720 = happySpecReduce_1 272# happyReduction_720 -happyReduction_720 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn288 - (sL1n happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) - )} - -happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_721 = happySpecReduce_1 272# happyReduction_721 -happyReduction_721 happy_x_1 - = case happyOut289 happy_x_1 of { (HappyWrap289 happy_var_1) -> - happyIn288 - (happy_var_1 - )} - -happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_722 = happySpecReduce_1 273# happyReduction_722 -happyReduction_722 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn289 - (sL1n happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) - )} - -happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_723 = happySpecReduce_1 274# happyReduction_723 -happyReduction_723 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn290 - (sL1n happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) - )} - -happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_724 = happySpecReduce_1 274# happyReduction_724 -happyReduction_724 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn290 - (sL1n happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) - )} - -happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_725 = happySpecReduce_1 274# happyReduction_725 -happyReduction_725 happy_x_1 - = case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> - happyIn290 - (happy_var_1 - )} - -happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_726 = happySpecReduce_1 275# happyReduction_726 -happyReduction_726 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn291 - (sL1n happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) - )} - -happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_727 = happySpecReduce_1 275# happyReduction_727 -happyReduction_727 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn291 - (sL1n happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) - )} - -happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_728 = happySpecReduce_1 275# happyReduction_728 -happyReduction_728 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn291 - (sL1n happy_var_1 $! consDataCon_RDR - )} - -happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_729 = happySpecReduce_1 275# happyReduction_729 -happyReduction_729 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn291 - (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit "-") - )} - -happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_730 = happySpecReduce_1 275# happyReduction_730 -happyReduction_730 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn291 - (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit ".") - )} - -happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_731 = happySpecReduce_1 276# happyReduction_731 -happyReduction_731 happy_x_1 - = case happyOut289 happy_x_1 of { (HappyWrap289 happy_var_1) -> - happyIn292 - (happy_var_1 - )} - -happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_732 = happyMonadReduce 3# 276# happyReduction_732 -happyReduction_732 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut291 happy_x_2 of { (HappyWrap291 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn292 r)) - -happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_733 = happySpecReduce_1 277# happyReduction_733 -happyReduction_733 happy_x_1 - = case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> - happyIn293 - (happy_var_1 - )} - -happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_734 = happySpecReduce_1 277# happyReduction_734 -happyReduction_734 happy_x_1 - = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> - happyIn293 - (happy_var_1 - )} - -happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_735 = happyMonadReduce 1# 277# happyReduction_735 -happyReduction_735 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( amsrn (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon) - (NameAnnRArrow (isUnicode happy_var_1) Nothing (glAA happy_var_1) Nothing []))}) - ) (\r -> happyReturn (happyIn293 r)) - -happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_736 = happySpecReduce_1 278# happyReduction_736 -happyReduction_736 happy_x_1 - = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> - happyIn294 - (happy_var_1 - )} - -happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_737 = happyMonadReduce 3# 278# happyReduction_737 -happyReduction_737 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut307 happy_x_2 of { (HappyWrap307 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn294 r)) - -happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_738 = happySpecReduce_1 279# happyReduction_738 -happyReduction_738 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn295 - (mkHsVarOpPV happy_var_1 - )} - -happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_739 = happySpecReduce_1 279# happyReduction_739 -happyReduction_739 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn295 - (mkHsConOpPV happy_var_1 - )} - -happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_740 = happySpecReduce_1 279# happyReduction_740 -happyReduction_740 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn295 - (pvN happy_var_1 - )} - -happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_741 = happySpecReduce_1 280# happyReduction_741 -happyReduction_741 happy_x_1 - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - happyIn296 - (mkHsVarOpPV happy_var_1 - )} - -happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_742 = happySpecReduce_1 280# happyReduction_742 -happyReduction_742 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn296 - (mkHsConOpPV happy_var_1 - )} - -happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_743 = happySpecReduce_1 280# happyReduction_743 -happyReduction_743 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn296 - (pvN happy_var_1 - )} - -happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_744 = happySpecReduce_3 281# happyReduction_744 -happyReduction_744 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn297 - (mkHsInfixHolePV (comb2 happy_var_1 happy_var_3) - (\cs -> EpAnn (glR happy_var_1) (EpAnnUnboundVar (glAA happy_var_1, glAA happy_var_3) (glAA happy_var_2)) cs) - )}}} - -happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_745 = happySpecReduce_1 282# happyReduction_745 -happyReduction_745 happy_x_1 - = case happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> - happyIn298 - (happy_var_1 - )} - -happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_746 = happyMonadReduce 3# 282# happyReduction_746 -happyReduction_746 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut306 happy_x_2 of { (HappyWrap306 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn298 r)) - -happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_747 = happySpecReduce_1 283# happyReduction_747 -happyReduction_747 happy_x_1 - = case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> - happyIn299 - (happy_var_1 - )} - -happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_748 = happyMonadReduce 3# 283# happyReduction_748 -happyReduction_748 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut306 happy_x_2 of { (HappyWrap306 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn299 r)) - -happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_749 = happySpecReduce_1 284# happyReduction_749 -happyReduction_749 happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn300 - (happy_var_1 - )} - -happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_750 = happyMonadReduce 3# 285# happyReduction_750 -happyReduction_750 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut302 happy_x_2 of { (HappyWrap302 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn301 r)) - -happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_751 = happySpecReduce_1 286# happyReduction_751 -happyReduction_751 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) - )} - -happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_752 = happySpecReduce_1 286# happyReduction_752 -happyReduction_752 happy_x_1 - = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) - )} - -happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_753 = happySpecReduce_1 286# happyReduction_753 -happyReduction_753 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "unsafe") - )} - -happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_754 = happySpecReduce_1 286# happyReduction_754 -happyReduction_754 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "safe") - )} - -happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_755 = happySpecReduce_1 286# happyReduction_755 -happyReduction_755 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "interruptible") - )} - -happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_756 = happySpecReduce_1 287# happyReduction_756 -happyReduction_756 happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn303 - (happy_var_1 - )} - -happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_757 = happyMonadReduce 3# 287# happyReduction_757 -happyReduction_757 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut311 happy_x_2 of { (HappyWrap311 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn303 r)) - -happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_758 = happySpecReduce_1 288# happyReduction_758 -happyReduction_758 happy_x_1 - = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> - happyIn304 - (happy_var_1 - )} - -happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_759 = happyMonadReduce 3# 288# happyReduction_759 -happyReduction_759 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut311 happy_x_2 of { (HappyWrap311 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn304 r)) - -happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_760 = happyMonadReduce 3# 288# happyReduction_760 -happyReduction_760 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut310 happy_x_2 of { (HappyWrap310 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn304 r)) - -happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_761 = happySpecReduce_1 289# happyReduction_761 -happyReduction_761 happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn305 - (fmap (FieldLabelString . occNameFS . rdrNameOcc) happy_var_1 - )} - -happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_762 = happySpecReduce_1 290# happyReduction_762 -happyReduction_762 happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn306 - (happy_var_1 - )} - -happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_763 = happySpecReduce_1 290# happyReduction_763 -happyReduction_763 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn306 - (sL1n happy_var_1 $! mkQual varName (getQVARID happy_var_1) - )} - -happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_764 = happySpecReduce_1 291# happyReduction_764 -happyReduction_764 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (getVARID happy_var_1) - )} - -happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_765 = happySpecReduce_1 291# happyReduction_765 -happyReduction_765 happy_x_1 - = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (unLoc happy_var_1) - )} - -happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_766 = happySpecReduce_1 291# happyReduction_766 -happyReduction_766 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "unsafe") - )} - -happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_767 = happySpecReduce_1 291# happyReduction_767 -happyReduction_767 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "safe") - )} - -happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_768 = happySpecReduce_1 291# happyReduction_768 -happyReduction_768 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "interruptible") - )} - -happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_769 = happySpecReduce_1 291# happyReduction_769 -happyReduction_769 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "forall") - )} - -happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_770 = happySpecReduce_1 291# happyReduction_770 -happyReduction_770 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "family") - )} - -happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_771 = happySpecReduce_1 291# happyReduction_771 -happyReduction_771 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "role") - )} - -happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_772 = happySpecReduce_1 292# happyReduction_772 -happyReduction_772 happy_x_1 - = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> - happyIn308 - (happy_var_1 - )} - -happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_773 = happySpecReduce_1 292# happyReduction_773 -happyReduction_773 happy_x_1 - = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> - happyIn308 - (happy_var_1 - )} - -happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_774 = happySpecReduce_1 293# happyReduction_774 -happyReduction_774 happy_x_1 - = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> - happyIn309 - (happy_var_1 - )} - -happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_775 = happySpecReduce_1 293# happyReduction_775 -happyReduction_775 happy_x_1 - = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> - happyIn309 - (happy_var_1 - )} - -happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_776 = happySpecReduce_1 294# happyReduction_776 -happyReduction_776 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn310 - (sL1n happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) - )} - -happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_777 = happySpecReduce_1 295# happyReduction_777 -happyReduction_777 happy_x_1 - = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> - happyIn311 - (happy_var_1 - )} - -happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_778 = happySpecReduce_1 295# happyReduction_778 -happyReduction_778 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn311 - (sL1n happy_var_1 $ mkUnqual varName (fsLit "-") - )} - -happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_779 = happySpecReduce_1 296# happyReduction_779 -happyReduction_779 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn312 - (sL1n happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) - )} - -happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_780 = happySpecReduce_1 296# happyReduction_780 -happyReduction_780 happy_x_1 - = case happyOut314 happy_x_1 of { (HappyWrap314 happy_var_1) -> - happyIn312 - (sL1n happy_var_1 $ mkUnqual varName (unLoc happy_var_1) - )} - -happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_781 = happySpecReduce_1 297# happyReduction_781 -happyReduction_781 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "as") - )} - -happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_782 = happySpecReduce_1 297# happyReduction_782 -happyReduction_782 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "qualified") - )} - -happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_783 = happySpecReduce_1 297# happyReduction_783 -happyReduction_783 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "hiding") - )} - -happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_784 = happySpecReduce_1 297# happyReduction_784 -happyReduction_784 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "export") - )} - -happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_785 = happySpecReduce_1 297# happyReduction_785 -happyReduction_785 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "label") - )} - -happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_786 = happySpecReduce_1 297# happyReduction_786 -happyReduction_786 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "dynamic") - )} - -happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_787 = happySpecReduce_1 297# happyReduction_787 -happyReduction_787 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "stdcall") - )} - -happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_788 = happySpecReduce_1 297# happyReduction_788 -happyReduction_788 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "ccall") - )} - -happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_789 = happySpecReduce_1 297# happyReduction_789 -happyReduction_789 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "capi") - )} - -happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_790 = happySpecReduce_1 297# happyReduction_790 -happyReduction_790 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "prim") - )} - -happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_791 = happySpecReduce_1 297# happyReduction_791 -happyReduction_791 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "javascript") - )} - -happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_792 = happySpecReduce_1 297# happyReduction_792 -happyReduction_792 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "group") - )} - -happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_793 = happySpecReduce_1 297# happyReduction_793 -happyReduction_793 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "stock") - )} - -happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_794 = happySpecReduce_1 297# happyReduction_794 -happyReduction_794 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "anyclass") - )} - -happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_795 = happySpecReduce_1 297# happyReduction_795 -happyReduction_795 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "via") - )} - -happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_796 = happySpecReduce_1 297# happyReduction_796 -happyReduction_796 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "unit") - )} - -happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_797 = happySpecReduce_1 297# happyReduction_797 -happyReduction_797 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "dependency") - )} - -happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_798 = happySpecReduce_1 297# happyReduction_798 -happyReduction_798 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 (fsLit "signature") - )} - -happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_799 = happySpecReduce_1 298# happyReduction_799 -happyReduction_799 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 (fsLit ".") - )} - -happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_800 = happySpecReduce_1 298# happyReduction_800 -happyReduction_800 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 (starSym (isUnicode happy_var_1)) - )} - -happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_801 = happySpecReduce_1 299# happyReduction_801 -happyReduction_801 happy_x_1 - = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> - happyIn315 - (happy_var_1 - )} - -happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_802 = happySpecReduce_1 299# happyReduction_802 -happyReduction_802 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn315 - (sL1n happy_var_1 $! mkQual dataName (getQCONID happy_var_1) - )} - -happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_803 = happySpecReduce_1 300# happyReduction_803 -happyReduction_803 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn316 - (sL1n happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) - )} - -happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_804 = happySpecReduce_1 301# happyReduction_804 -happyReduction_804 happy_x_1 - = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> - happyIn317 - (happy_var_1 - )} - -happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_805 = happySpecReduce_1 301# happyReduction_805 -happyReduction_805 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn317 - (sL1n happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) - )} - -happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_806 = happySpecReduce_1 302# happyReduction_806 -happyReduction_806 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn318 - (sL1n happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) - )} - -happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_807 = happySpecReduce_1 302# happyReduction_807 -happyReduction_807 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn318 - (sL1n happy_var_1 $ consDataCon_RDR - )} - -happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_808 = happySpecReduce_1 303# happyReduction_808 -happyReduction_808 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 - )} - -happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_809 = happySpecReduce_1 303# happyReduction_809 -happyReduction_809 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) - $ getSTRING happy_var_1 - )} - -happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_810 = happySpecReduce_1 303# happyReduction_810 -happyReduction_810 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) - $ getPRIMINTEGER happy_var_1 - )} - -happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_811 = happySpecReduce_1 303# happyReduction_811 -happyReduction_811 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) - $ getPRIMWORD happy_var_1 - )} - -happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_812 = happySpecReduce_1 303# happyReduction_812 -happyReduction_812 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsInt8Prim (getPRIMINTEGER8s happy_var_1) - $ getPRIMINTEGER8 happy_var_1 - )} - -happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_813 = happySpecReduce_1 303# happyReduction_813 -happyReduction_813 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsInt16Prim (getPRIMINTEGER16s happy_var_1) - $ getPRIMINTEGER16 happy_var_1 - )} - -happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_814 = happySpecReduce_1 303# happyReduction_814 -happyReduction_814 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsInt32Prim (getPRIMINTEGER32s happy_var_1) - $ getPRIMINTEGER32 happy_var_1 - )} - -happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_815 = happySpecReduce_1 303# happyReduction_815 -happyReduction_815 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsInt64Prim (getPRIMINTEGER64s happy_var_1) - $ getPRIMINTEGER64 happy_var_1 - )} - -happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_816 = happySpecReduce_1 303# happyReduction_816 -happyReduction_816 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsWord8Prim (getPRIMWORD8s happy_var_1) - $ getPRIMWORD8 happy_var_1 - )} - -happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_817 = happySpecReduce_1 303# happyReduction_817 -happyReduction_817 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsWord16Prim (getPRIMWORD16s happy_var_1) - $ getPRIMWORD16 happy_var_1 - )} - -happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_818 = happySpecReduce_1 303# happyReduction_818 -happyReduction_818 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsWord32Prim (getPRIMWORD32s happy_var_1) - $ getPRIMWORD32 happy_var_1 - )} - -happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_819 = happySpecReduce_1 303# happyReduction_819 -happyReduction_819 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsWord64Prim (getPRIMWORD64s happy_var_1) - $ getPRIMWORD64 happy_var_1 - )} - -happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_820 = happySpecReduce_1 303# happyReduction_820 -happyReduction_820 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) - $ getPRIMCHAR happy_var_1 - )} - -happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_821 = happySpecReduce_1 303# happyReduction_821 -happyReduction_821 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) - $ getPRIMSTRING happy_var_1 - )} - -happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_822 = happySpecReduce_1 303# happyReduction_822 -happyReduction_822 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsFloatPrim noExtField $ getPRIMFLOAT happy_var_1 - )} - -happyReduce_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_823 = happySpecReduce_1 303# happyReduction_823 -happyReduction_823 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn319 - (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE happy_var_1 - )} - -happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_824 = happySpecReduce_1 304# happyReduction_824 -happyReduction_824 happy_x_1 - = happyIn320 - (() - ) - -happyReduce_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_825 = happyMonadReduce 1# 304# happyReduction_825 -happyReduction_825 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( popContext)) - ) (\r -> happyReturn (happyIn320 r)) - -happyReduce_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_826 = happySpecReduce_1 305# happyReduction_826 -happyReduction_826 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn321 - (sL1a happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) - )} - -happyReduce_827 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_827 = happySpecReduce_1 305# happyReduction_827 -happyReduction_827 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn321 - (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in - mkModuleNameFS - (concatFS [mod, fsLit ".", c]) - )} - -happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_828 = happySpecReduce_2 306# happyReduction_828 -happyReduction_828 happy_x_2 - happy_x_1 - = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn322 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) - )}} - -happyReduce_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_829 = happySpecReduce_1 306# happyReduction_829 -happyReduction_829 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn322 - (([gl happy_var_1],1) - )} - -happyReduce_830 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_830 = happySpecReduce_1 307# happyReduction_830 -happyReduction_830 happy_x_1 - = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> - happyIn323 - (happy_var_1 - )} - -happyReduce_831 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_831 = happySpecReduce_0 307# happyReduction_831 -happyReduction_831 = happyIn323 - (([], 0) - ) - -happyReduce_832 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_832 = happySpecReduce_2 308# happyReduction_832 -happyReduction_832 happy_x_2 - happy_x_1 - = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn324 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) - )}} - -happyReduce_833 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_833 = happySpecReduce_1 308# happyReduction_833 -happyReduction_833 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn324 - (([gl happy_var_1],1) - )} - -happyReduce_834 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_834 = happySpecReduce_3 309# happyReduction_834 -happyReduction_834 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn325 - (happy_var_2 >>= \ happy_var_2 -> amsrl - (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2))) - (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fst $ unLoc happy_var_2) []) - )}}} - -happyReduce_835 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_835 = happySpecReduce_3 309# happyReduction_835 -happyReduction_835 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> - happyIn325 - (happy_var_2 >>= \ happy_var_2 -> amsrl - (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2))) - (AnnList (Just $ glR happy_var_2) Nothing Nothing (fst $ unLoc happy_var_2) []) - )} - -happyReduce_836 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_836 = happySpecReduce_2 309# happyReduction_836 -happyReduction_836 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn325 - (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] []) - )}} - -happyReduce_837 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_837 = happySpecReduce_2 309# happyReduction_837 -happyReduction_837 happy_x_2 - happy_x_1 - = happyIn325 - (return $ noLocA [] - ) - -happyReduce_838 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_838 = happySpecReduce_3 310# happyReduction_838 -happyReduction_838 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut330 happy_x_2 of { (HappyWrap330 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn326 - (happy_var_2 >>= \ happy_var_2 -> amsrl - (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2))) - (AnnList (Just $ glR happy_var_2) (Just $ moc happy_var_1) (Just $ mcc happy_var_3) (fst $ unLoc happy_var_2) []) - )}}} - -happyReduce_839 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_839 = happySpecReduce_3 310# happyReduction_839 -happyReduction_839 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut330 happy_x_2 of { (HappyWrap330 happy_var_2) -> - happyIn326 - (happy_var_2 >>= \ happy_var_2 -> amsrl - (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2))) - (AnnList (Just $ glR happy_var_2) Nothing Nothing (fst $ unLoc happy_var_2) []) - )} - -happyReduce_840 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_840 = happySpecReduce_2 310# happyReduction_840 -happyReduction_840 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn326 - (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] []) - )}} - -happyReduce_841 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_841 = happySpecReduce_2 310# happyReduction_841 -happyReduction_841 happy_x_2 - happy_x_1 - = happyIn326 - (return $ noLocA [] - ) - -happyReduce_842 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_842 = happyMonadReduce 2# 311# happyReduction_842 -happyReduction_842 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - fmap ecpFromExp $ - return $ (reLocA $ sLLlA happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) - ) (\r -> happyReturn (happyIn327 r)) - -happyReduce_843 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_843 = happyMonadReduce 2# 312# happyReduction_843 -happyReduction_843 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> - case happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - fmap ecpFromExp $ - return $ (reLocA $ sLLlA happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) - ) (\r -> happyReturn (happyIn328 r)) - -happyReduce_844 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_844 = happySpecReduce_1 313# happyReduction_844 -happyReduction_844 happy_x_1 - = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> - happyIn329 - (happy_var_1 >>= \ happy_var_1 -> return $ - sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) - )} - -happyReduce_845 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_845 = happySpecReduce_2 313# happyReduction_845 -happyReduction_845 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> - happyIn329 - (happy_var_2 >>= \ happy_var_2 -> return $ - sLL happy_var_1 happy_var_2 (((mz AnnSemi happy_var_1) ++ (fst $ unLoc happy_var_2) ) - ,snd $ unLoc happy_var_2) - )}} - -happyReduce_846 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_846 = happySpecReduce_1 314# happyReduction_846 -happyReduction_846 happy_x_1 - = case happyOut332 happy_x_1 of { (HappyWrap332 happy_var_1) -> - happyIn330 - (happy_var_1 >>= \ happy_var_1 -> return $ - sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) - )} - -happyReduce_847 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_847 = happySpecReduce_2 314# happyReduction_847 -happyReduction_847 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut330 happy_x_2 of { (HappyWrap330 happy_var_2) -> - happyIn330 - (happy_var_2 >>= \ happy_var_2 -> return $ - sLL happy_var_1 happy_var_2 (((mz AnnSemi happy_var_1) ++ (fst $ unLoc happy_var_2) ) - ,snd $ unLoc happy_var_2) - )}} - -happyReduce_848 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_848 = happySpecReduce_3 315# happyReduction_848 -happyReduction_848 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut333 happy_x_3 of { (HappyWrap333 happy_var_3) -> - happyIn331 - (happy_var_1 >>= \ happy_var_1 -> - happy_var_3 >>= \ happy_var_3 -> - case snd $ unLoc happy_var_1 of - [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - ,[happy_var_3])) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLL happy_var_1 (reLoc happy_var_3) (fst $ unLoc happy_var_1,happy_var_3 : h' : t)) - )}}} - -happyReduce_849 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_849 = happySpecReduce_2 315# happyReduction_849 -happyReduction_849 happy_x_2 - happy_x_1 - = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn331 - (happy_var_1 >>= \ happy_var_1 -> - case snd $ unLoc happy_var_1 of - [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - ,[])) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t)) - )}} - -happyReduce_850 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_850 = happySpecReduce_1 315# happyReduction_850 -happyReduction_850 happy_x_1 - = case happyOut333 happy_x_1 of { (HappyWrap333 happy_var_1) -> - happyIn331 - (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1]) - )} - -happyReduce_851 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_851 = happySpecReduce_3 316# happyReduction_851 -happyReduction_851 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut332 happy_x_1 of { (HappyWrap332 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> - happyIn332 - (happy_var_1 >>= \ happy_var_1 -> - happy_var_3 >>= \ happy_var_3 -> - case snd $ unLoc happy_var_1 of - [] -> return (sLL happy_var_1 (reLoc happy_var_3) ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - ,[happy_var_3])) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLL happy_var_1 (reLoc happy_var_3) (fst $ unLoc happy_var_1,happy_var_3 : h' : t)) - )}}} - -happyReduce_852 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_852 = happySpecReduce_2 316# happyReduction_852 -happyReduction_852 happy_x_2 - happy_x_1 - = case happyOut332 happy_x_1 of { (HappyWrap332 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn332 - (happy_var_1 >>= \ happy_var_1 -> - case snd $ unLoc happy_var_1 of - [] -> return (sLL happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ (mz AnnSemi happy_var_2) - ,[])) - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t)) - )}} - -happyReduce_853 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_853 = happySpecReduce_1 316# happyReduction_853 -happyReduction_853 happy_x_1 - = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> - happyIn332 - (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1]) - )} - -happyReduce_854 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_854 = happySpecReduce_2 317# happyReduction_854 -happyReduction_854 happy_x_2 - happy_x_1 - = case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> - happyIn333 - (happy_var_2 >>= \ happy_var_2 -> - acsA (\cs -> sLLAsl happy_var_1 happy_var_2 - (Match { m_ext = EpAnn (listAsAnchor happy_var_1) [] cs - , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing - , m_pats = happy_var_1 - , m_grhss = unLoc happy_var_2 })) - )}} - -happyReduce_855 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_855 = happySpecReduce_2 318# happyReduction_855 -happyReduction_855 happy_x_2 - happy_x_1 - = case happyOut248 happy_x_1 of { (HappyWrap248 happy_var_1) -> - case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> - happyIn334 - (happy_var_2 >>= \ happy_var_2 -> - acsA (\cs -> sLLAsl happy_var_1 happy_var_2 - (Match { m_ext = EpAnn (listAsAnchor happy_var_1) [] cs - , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing - , m_pats = happy_var_1 - , m_grhss = unLoc happy_var_2 })) - )}} - -happyNewToken action sts stk - = (lexer True)(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - L _ ITeof -> happyDoAction 158# tk action sts stk; - L _ ITunderscore -> cont 1#; - L _ ITas -> cont 2#; - L _ ITcase -> cont 3#; - L _ ITclass -> cont 4#; - L _ ITdata -> cont 5#; - L _ ITdefault -> cont 6#; - L _ ITderiving -> cont 7#; - L _ ITelse -> cont 8#; - L _ IThiding -> cont 9#; - L _ ITif -> cont 10#; - L _ ITimport -> cont 11#; - L _ ITin -> cont 12#; - L _ ITinfix -> cont 13#; - L _ ITinfixl -> cont 14#; - L _ ITinfixr -> cont 15#; - L _ ITinstance -> cont 16#; - L _ ITlet -> cont 17#; - L _ ITmodule -> cont 18#; - L _ ITnewtype -> cont 19#; - L _ ITof -> cont 20#; - L _ ITqualified -> cont 21#; - L _ ITthen -> cont 22#; - L _ ITtype -> cont 23#; - L _ ITwhere -> cont 24#; - L _ (ITforall _) -> cont 25#; - L _ ITforeign -> cont 26#; - L _ ITexport -> cont 27#; - L _ ITlabel -> cont 28#; - L _ ITdynamic -> cont 29#; - L _ ITsafe -> cont 30#; - L _ ITinterruptible -> cont 31#; - L _ ITunsafe -> cont 32#; - L _ ITfamily -> cont 33#; - L _ ITrole -> cont 34#; - L _ ITstdcallconv -> cont 35#; - L _ ITccallconv -> cont 36#; - L _ ITcapiconv -> cont 37#; - L _ ITprimcallconv -> cont 38#; - L _ ITjavascriptcallconv -> cont 39#; - L _ ITproc -> cont 40#; - L _ ITrec -> cont 41#; - L _ ITgroup -> cont 42#; - L _ ITby -> cont 43#; - L _ ITusing -> cont 44#; - L _ ITpattern -> cont 45#; - L _ ITstatic -> cont 46#; - L _ ITstock -> cont 47#; - L _ ITanyclass -> cont 48#; - L _ ITvia -> cont 49#; - L _ ITunit -> cont 50#; - L _ ITsignature -> cont 51#; - L _ ITdependency -> cont 52#; - L _ (ITinline_prag _ _ _) -> cont 53#; - L _ (ITopaque_prag _) -> cont 54#; - L _ (ITspec_prag _) -> cont 55#; - L _ (ITspec_inline_prag _ _) -> cont 56#; - L _ (ITsource_prag _) -> cont 57#; - L _ (ITrules_prag _) -> cont 58#; - L _ (ITscc_prag _) -> cont 59#; - L _ (ITdeprecated_prag _) -> cont 60#; - L _ (ITwarning_prag _) -> cont 61#; - L _ (ITunpack_prag _) -> cont 62#; - L _ (ITnounpack_prag _) -> cont 63#; - L _ (ITann_prag _) -> cont 64#; - L _ (ITminimal_prag _) -> cont 65#; - L _ (ITctype _) -> cont 66#; - L _ (IToverlapping_prag _) -> cont 67#; - L _ (IToverlappable_prag _) -> cont 68#; - L _ (IToverlaps_prag _) -> cont 69#; - L _ (ITincoherent_prag _) -> cont 70#; - L _ (ITcomplete_prag _) -> cont 71#; - L _ ITclose_prag -> cont 72#; - L _ ITdotdot -> cont 73#; - L _ ITcolon -> cont 74#; - L _ (ITdcolon _) -> cont 75#; - L _ ITequal -> cont 76#; - L _ ITlam -> cont 77#; - L _ ITlcase -> cont 78#; - L _ ITlcases -> cont 79#; - L _ ITvbar -> cont 80#; - L _ (ITlarrow _) -> cont 81#; - L _ (ITrarrow _) -> cont 82#; - L _ ITlolly -> cont 83#; - L _ ITat -> cont 84#; - L _ (ITdarrow _) -> cont 85#; - L _ ITminus -> cont 86#; - L _ ITtilde -> cont 87#; - L _ ITbang -> cont 88#; - L _ ITprefixminus -> cont 89#; - L _ (ITstar _) -> cont 90#; - L _ (ITlarrowtail _) -> cont 91#; - L _ (ITrarrowtail _) -> cont 92#; - L _ (ITLarrowtail _) -> cont 93#; - L _ (ITRarrowtail _) -> cont 94#; - L _ ITdot -> cont 95#; - L _ (ITproj True) -> cont 96#; - L _ (ITproj False) -> cont 97#; - L _ ITtypeApp -> cont 98#; - L _ ITpercent -> cont 99#; - L _ ITocurly -> cont 100#; - L _ ITccurly -> cont 101#; - L _ ITvocurly -> cont 102#; - L _ ITvccurly -> cont 103#; - L _ ITobrack -> cont 104#; - L _ ITcbrack -> cont 105#; - L _ IToparen -> cont 106#; - L _ ITcparen -> cont 107#; - L _ IToubxparen -> cont 108#; - L _ ITcubxparen -> cont 109#; - L _ (IToparenbar _) -> cont 110#; - L _ (ITcparenbar _) -> cont 111#; - L _ ITsemi -> cont 112#; - L _ ITcomma -> cont 113#; - L _ ITbackquote -> cont 114#; - L _ ITsimpleQuote -> cont 115#; - L _ (ITvarid _) -> cont 116#; - L _ (ITconid _) -> cont 117#; - L _ (ITvarsym _) -> cont 118#; - L _ (ITconsym _) -> cont 119#; - L _ (ITqvarid _) -> cont 120#; - L _ (ITqconid _) -> cont 121#; - L _ (ITqvarsym _) -> cont 122#; - L _ (ITqconsym _) -> cont 123#; - L _ (ITdo _) -> cont 124#; - L _ (ITmdo _) -> cont 125#; - L _ (ITdupipvarid _) -> cont 126#; - L _ (ITlabelvarid _ _) -> cont 127#; - L _ (ITchar _ _) -> cont 128#; - L _ (ITstring _ _) -> cont 129#; - L _ (ITinteger _) -> cont 130#; - L _ (ITrational _) -> cont 131#; - L _ (ITprimchar _ _) -> cont 132#; - L _ (ITprimstring _ _) -> cont 133#; - L _ (ITprimint _ _) -> cont 134#; - L _ (ITprimword _ _) -> cont 135#; - L _ (ITprimint8 _ _) -> cont 136#; - L _ (ITprimint16 _ _) -> cont 137#; - L _ (ITprimint32 _ _) -> cont 138#; - L _ (ITprimint64 _ _) -> cont 139#; - L _ (ITprimword8 _ _) -> cont 140#; - L _ (ITprimword16 _ _) -> cont 141#; - L _ (ITprimword32 _ _) -> cont 142#; - L _ (ITprimword64 _ _) -> cont 143#; - L _ (ITprimfloat _) -> cont 144#; - L _ (ITprimdouble _) -> cont 145#; - L _ (ITopenExpQuote _ _) -> cont 146#; - L _ ITopenPatQuote -> cont 147#; - L _ ITopenTypQuote -> cont 148#; - L _ ITopenDecQuote -> cont 149#; - L _ (ITcloseQuote _) -> cont 150#; - L _ (ITopenTExpQuote _) -> cont 151#; - L _ ITcloseTExpQuote -> cont 152#; - L _ ITdollar -> cont 153#; - L _ ITdollardollar -> cont 154#; - L _ ITtyQuote -> cont 155#; - L _ (ITquasiQuote _) -> cont 156#; - L _ (ITqQuasiQuote _) -> cont 157#; - _ -> happyError' (tk, []) - }) - -happyError_ explist 158# tk = happyError' (tk, explist) -happyError_ explist _ tk = happyError' (tk, explist) - -happyThen :: () => P a -> (a -> P b) -> P b -happyThen = (>>=) -happyReturn :: () => a -> P a -happyReturn = (return) -happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn ) - -happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) - -happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) - -happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )) - -happyThen1 :: () => P a -> (a -> P b) -> P b -happyThen1 = happyThen -happyReturn1 :: () => a -> P a -happyReturn1 = happyReturn -happyError' :: () => (((Located Token)), [Prelude.String]) -> P a -happyError' tk = (\(tokens, explist) -> happyError) tk -parseModuleNoHaddock = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap35 x') = happyOut35 x} in x')) - -parseSignature = happySomeParser where - happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (let {(HappyWrap34 x') = happyOut34 x} in x')) - -parseImport = happySomeParser where - happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (let {(HappyWrap63 x') = happyOut63 x} in x')) - -parseStatement = happySomeParser where - happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (let {(HappyWrap255 x') = happyOut255 x} in x')) - -parseDeclaration = happySomeParser where - happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (let {(HappyWrap82 x') = happyOut82 x} in x')) - -parseExpression = happySomeParser where - happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (let {(HappyWrap212 x') = happyOut212 x} in x')) - -parsePattern = happySomeParser where - happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap247 x') = happyOut247 x} in x')) - -parseTypeSignature = happySomeParser where - happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap208 x') = happyOut208 x} in x')) - -parseStmt = happySomeParser where - happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap254 x') = happyOut254 x} in x')) - -parseIdentifier = happySomeParser where - happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (let {(HappyWrap16 x') = happyOut16 x} in x')) - -parseType = happySomeParser where - happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (let {(HappyWrap164 x') = happyOut164 x} in x')) - -parseBackpack = happySomeParser where - happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (let {(HappyWrap17 x') = happyOut17 x} in x')) - -parseHeader = happySomeParser where - happySomeParser = happyThen (happyParse 12#) (\x -> happyReturn (let {(HappyWrap43 x') = happyOut43 x} in x')) - -happySeq = happyDoSeq - - -happyError :: P a -happyError = srcParseFail - -getVARID (L _ (ITvarid x)) = x -getCONID (L _ (ITconid x)) = x -getVARSYM (L _ (ITvarsym x)) = x -getCONSYM (L _ (ITconsym x)) = x -getDO (L _ (ITdo x)) = x -getMDO (L _ (ITmdo x)) = x -getQVARID (L _ (ITqvarid x)) = x -getQCONID (L _ (ITqconid x)) = x -getQVARSYM (L _ (ITqvarsym x)) = x -getQCONSYM (L _ (ITqconsym x)) = x -getIPDUPVARID (L _ (ITdupipvarid x)) = x -getLABELVARID (L _ (ITlabelvarid _ x)) = x -getCHAR (L _ (ITchar _ x)) = x -getSTRING (L _ (ITstring _ x)) = x -getINTEGER (L _ (ITinteger x)) = x -getRATIONAL (L _ (ITrational x)) = x -getPRIMCHAR (L _ (ITprimchar _ x)) = x -getPRIMSTRING (L _ (ITprimstring _ x)) = x -getPRIMINTEGER (L _ (ITprimint _ x)) = x -getPRIMWORD (L _ (ITprimword _ x)) = x -getPRIMINTEGER8 (L _ (ITprimint8 _ x)) = x -getPRIMINTEGER16 (L _ (ITprimint16 _ x)) = x -getPRIMINTEGER32 (L _ (ITprimint32 _ x)) = x -getPRIMINTEGER64 (L _ (ITprimint64 _ x)) = x -getPRIMWORD8 (L _ (ITprimword8 _ x)) = x -getPRIMWORD16 (L _ (ITprimword16 _ x)) = x -getPRIMWORD32 (L _ (ITprimword32 _ x)) = x -getPRIMWORD64 (L _ (ITprimword64 _ x)) = x -getPRIMFLOAT (L _ (ITprimfloat x)) = x -getPRIMDOUBLE (L _ (ITprimdouble x)) = x -getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) -getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) -getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) -getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x -getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l - -getINTEGERs (L _ (ITinteger (IL src _ _))) = src -getCHARs (L _ (ITchar src _)) = src -getSTRINGs (L _ (ITstring src _)) = src -getPRIMCHARs (L _ (ITprimchar src _)) = src -getPRIMSTRINGs (L _ (ITprimstring src _)) = src -getPRIMINTEGERs (L _ (ITprimint src _)) = src -getPRIMWORDs (L _ (ITprimword src _)) = src -getPRIMINTEGER8s (L _ (ITprimint8 src _)) = src -getPRIMINTEGER16s (L _ (ITprimint16 src _)) = src -getPRIMINTEGER32s (L _ (ITprimint32 src _)) = src -getPRIMINTEGER64s (L _ (ITprimint64 src _)) = src -getPRIMWORD8s (L _ (ITprimword8 src _)) = src -getPRIMWORD16s (L _ (ITprimword16 src _)) = src -getPRIMWORD32s (L _ (ITprimword32 src _)) = src -getPRIMWORD64s (L _ (ITprimword64 src _)) = src - -getLABELVARIDs (L _ (ITlabelvarid src _)) = src - --- See Note [Pragma source text] in "GHC.Types.SourceText" for the following -getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl -getOPAQUE_PRAGs (L _ (ITopaque_prag src)) = src -getSPEC_PRAGs (L _ (ITspec_prag src)) = src -getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src -getSOURCE_PRAGs (L _ (ITsource_prag src)) = src -getRULES_PRAGs (L _ (ITrules_prag src)) = src -getWARNING_PRAGs (L _ (ITwarning_prag src)) = src -getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src -getSCC_PRAGs (L _ (ITscc_prag src)) = src -getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src -getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src -getANN_PRAGs (L _ (ITann_prag src)) = src -getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src -getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src -getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src -getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src -getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src -getCTYPEs (L _ (ITctype src)) = src - -getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing - -isUnicode :: Located Token -> Bool -isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax -isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax -isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax -isUnicode (L _ ITlolly) = True -isUnicode _ = False - -hasE :: Located Token -> Bool -hasE (L _ (ITopenExpQuote HasE _)) = True -hasE (L _ (ITopenTExpQuote HasE)) = True -hasE _ = False - -getSCC :: Located Token -> P FastString -getSCC lt = do let s = getSTRING lt - -- We probably actually want to be more restrictive than this - if ' ' `elem` unpackFS s - then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC - else return s - -stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs) -stringLiteralToHsDocWst = lexStringLiteral parseIdentifier - --- Utilities for combining source spans -comb2 :: Located a -> Located b -> SrcSpan -comb2 a b = a `seq` b `seq` combineLocs a b - --- Utilities for combining source spans -comb2A :: Located a -> LocatedAn t b -> SrcSpan -comb2A a b = a `seq` b `seq` combineLocs a (reLoc b) - -comb2N :: Located a -> LocatedN b -> SrcSpan -comb2N a b = a `seq` b `seq` combineLocs a (reLocN b) - -comb2Al :: LocatedAn t a -> Located b -> SrcSpan -comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b - -comb3 :: Located a -> Located b -> Located c -> SrcSpan -comb3 a b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) - -comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan -comb3A a b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c)) - -comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan -comb3N a b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c)) - -comb3M :: Maybe (Located a) -> Located b -> Located c -> SrcSpan -comb3M (Just a) b c = a `seq` b `seq` c `seq` - combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) -comb3M Nothing b c = b `seq` c `seq` - (combineSrcSpans (getLoc b) (getLoc c)) - -comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan -comb4 a b c d = a `seq` b `seq` c `seq` d `seq` - (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) (getLoc d)) - -comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan -comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq` - (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ - combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e)) - --- strict constructor version: -{-# INLINE sL #-} -sL :: l -> a -> GenLocated l a -sL loc a = loc `seq` a `seq` L loc a - --- See Note [Adding location info] for how these utility functions are used - --- replaced last 3 CPP macros in this file -{-# INLINE sL0 #-} -sL0 :: a -> Located a -sL0 = L noSrcSpan -- #define L0 L noSrcSpan - -{-# INLINE sL1 #-} -sL1 :: GenLocated l a -> b -> GenLocated l b -sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sL1A #-} -sL1A :: LocatedAn t a -> b -> Located b -sL1A x = sL (getLocA x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sL1N #-} -sL1N :: LocatedN a -> b -> Located b -sL1N x = sL (getLocA x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sL1a #-} -sL1a :: Located a -> b -> LocatedAn t b -sL1a x = sL (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sL1l #-} -sL1l :: LocatedAn t a -> b -> LocatedAn u b -sL1l x = sL (l2l $ getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sL1n #-} -sL1n :: Located a -> b -> LocatedN b -sL1n x = L (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1) - -{-# INLINE sLL #-} -sLL :: Located a -> Located b -> c -> Located c -sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) - -{-# INLINE sLLa #-} -sLLa :: Located a -> Located b -> c -> LocatedAn t c -sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) - -{-# INLINE sLLlA #-} -sLLlA :: Located a -> LocatedAn t b -> c -> Located c -sLLlA x y = sL (comb2A x y) -- #define LL sL (comb2 $1 $>) - -{-# INLINE sLLAl #-} -sLLAl :: LocatedAn t a -> Located b -> c -> Located c -sLLAl x y = sL (comb2A y x) -- #define LL sL (comb2 $1 $>) - -{-# INLINE sLLAsl #-} -sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c -sLLAsl [] = sL1 -sLLAsl (x:_) = sLLAl x - -{-# INLINE sLLAA #-} -sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c -sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL sL (comb2 $1 $>) - - -{- Note [Adding location info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -This is done using the three functions below, sL0, sL1 -and sLL. Note that these functions were mechanically -converted from the three macros that used to exist before, -namely L0, L1 and LL. - -They each add a SrcSpan to their argument. - - sL0 adds 'noSrcSpan', used for empty productions - -- This doesn't seem to work anymore -=chak - - sL1 for a production with a single token on the lhs. Grabs the SrcSpan - from that token. - - sLL for a production with >1 token on the lhs. Makes up a SrcSpan from - the first and last tokens. - -These suffice for the majority of cases. However, we must be -especially careful with empty productions: sLL won't work if the first -or last token on the lhs can represent an empty span. In these cases, -we have to calculate the span using more of the tokens from the lhs, eg. - - | 'newtype' tycl_hdr '=' newconstr deriving - { L (comb3 $1 $4 $5) - (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } - -We provide comb3 and comb4 functions which are useful in such cases. - -Be careful: there's no checking that you actually got this right, the -only symptom will be that the SrcSpans of your syntax will be -incorrect. - --} - --- Make a source location for the file. We're a bit lazy here and just --- make a point SrcSpan at line 1, column 0. Strictly speaking we should --- try to find the span of the whole file (ToDo). -fileSrcSpan :: P SrcSpan -fileSrcSpan = do - l <- getRealSrcLoc; - let loc = mkSrcLoc (srcLocFile l) 1 1; - return (mkSrcSpan loc loc) - --- Hint about linear types -hintLinear :: MonadP m => SrcSpan -> m () -hintLinear span = do - linearEnabled <- getBit LinearTypesBit - unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction - --- Does this look like (a %m)? -looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool -looksLikeMult ty1 l_op ty2 - | Unqual op_name <- unLoc l_op - , occNameFS op_name == fsLit "%" - , Strict.Just ty1_pos <- getBufSpan (getLocA ty1) - , Strict.Just pct_pos <- getBufSpan (getLocA l_op) - , Strict.Just ty2_pos <- getBufSpan (getLocA ty2) - , bufSpanEnd ty1_pos /= bufSpanStart pct_pos - , bufSpanEnd pct_pos == bufSpanStart ty2_pos - = True - | otherwise = False - --- Hint about the MultiWayIf extension -hintMultiWayIf :: SrcSpan -> P () -hintMultiWayIf span = do - mwiEnabled <- getBit MultiWayIfBit - unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf - --- Hint about explicit-forall -hintExplicitForall :: Located Token -> P () -hintExplicitForall tok = do - forall <- getBit ExplicitForallBit - rulePrag <- getBit InRulePragBit - unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ - (PsErrExplicitForall (isUnicode tok)) - --- Hint about qualified-do -hintQualifiedDo :: Located Token -> P () -hintQualifiedDo tok = do - qualifiedDo <- getBit QualifiedDoBit - case maybeQDoDoc of - Just qdoDoc | not qualifiedDo -> - addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ - (PsErrIllegalQualifiedDo qdoDoc) - _ -> return () - where - maybeQDoDoc = case unLoc tok of - ITdo (Just m) -> Just $ ftext m <> text ".do" - ITmdo (Just m) -> Just $ ftext m <> text ".mdo" - t -> Nothing - --- When two single quotes don't followed by tyvar or gtycon, we report the --- error as empty character literal, or TH quote that missing proper type --- variable or constructor. See #13450. -reportEmptyDoubleQuotes :: SrcSpan -> P a -reportEmptyDoubleQuotes span = do - thQuotes <- getBit ThQuotesBit - addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ - -For the general principles of the following routines, see Note [exact print annotations] -in GHC.Parser.Annotation - --} - --- |Construct an AddEpAnn from the annotation keyword and the location --- of the keyword itself -mj :: AnnKeywordId -> Located e -> AddEpAnn -mj a l = AddEpAnn a (srcSpan2e $ gl l) - -mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn -mjN a l = AddEpAnn a (srcSpan2e $ glN l) - --- |Construct an AddEpAnn from the annotation keyword and the location --- of the keyword itself, provided the span is not zero width -mz :: AnnKeywordId -> Located e -> [AddEpAnn] -mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)] - -msemi :: Located e -> [TrailingAnn] -msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)] - -msemim :: Located e -> Maybe EpaLocation -msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l) - --- |Construct an AddEpAnn from the annotation keyword and the Located Token. If --- the token has a unicode equivalent and this has been used, provide the --- unicode variant of the annotation. -mu :: AnnKeywordId -> Located Token -> AddEpAnn -mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l) - --- | If the 'Token' is using its unicode variant return the unicode variant of --- the annotation -toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId -toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a - -toUnicode :: Located Token -> IsUnicodeSyntax -toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax - -gl :: GenLocated l a -> l -gl = getLoc - -glA :: LocatedAn t a -> SrcSpan -glA = getLocA - -glN :: LocatedN a -> SrcSpan -glN = getLocA - -glR :: Located a -> Anchor -glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor - -glMR :: Maybe (Located a) -> Located b -> Anchor -glMR (Just la) _ = glR la -glMR _ la = glR la - -glAA :: Located a -> EpaLocation -glAA = srcSpan2e . getLoc - -glRR :: Located a -> RealSrcSpan -glRR = realSrcSpan . getLoc - -glAR :: LocatedAn t a -> Anchor -glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor - -glNR :: LocatedN a -> Anchor -glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor - -glNRR :: LocatedN a -> EpaLocation -glNRR = srcSpan2e . getLocA - -anc :: RealSrcSpan -> Anchor -anc r = Anchor r UnchangedAnchor - -acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a) -acs a = do - let (L l _) = a emptyComments - cs <- getCommentsFor l - return (a cs) - --- Called at the very end to pick up the EOF position, as well as any comments not allocated yet. -acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a) -acsFinal a = do - let (L l _) = a emptyComments Nothing - cs <- getCommentsFor l - csf <- getFinalCommentsFor l - meof <- getEofPos - let ce = case meof of - Strict.Nothing -> Nothing - Strict.Just (pos `Strict.And` gap) -> Just (pos,gap) - return (a (cs Semi.<> csf) ce) - - -acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a) -acsa a = do - let (L l _) = a emptyComments - cs <- getCommentsFor (locA l) - return (a cs) - -acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a) -acsA a = reLocA <$> acs a - -acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP -acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a - ; return (ecpFromExp $ expr) } - -amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) -amsA (L l a) bs = do - cs <- getCommentsFor (locA l) - return (L (addAnnsA l bs cs) a) - -amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a) -amsAl (L l a) loc bs = do - cs <- getCommentsFor loc - return (L (addAnnsA l bs cs) a) - -amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a) -amsrc a@(L l _) bs = do - cs <- getCommentsFor l - return (reAnnC bs cs a) - -amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a) -amsrl a@(L l _) bs = do - cs <- getCommentsFor l - return (reAnnL bs cs a) - -amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a) -amsrp a@(L l _) bs = do - cs <- getCommentsFor l - return (reAnnL bs cs a) - -amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a) -amsrn (L l a) an = do - cs <- getCommentsFor l - let ann = (EpAnn (spanAsAnchor l) an cs) - return (L (SrcSpanAnn ann l) a) - --- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose -mo,mc :: Located Token -> AddEpAnn -mo ll = mj AnnOpen ll -mc ll = mj AnnClose ll - -moc,mcc :: Located Token -> AddEpAnn -moc ll = mj AnnOpenC ll -mcc ll = mj AnnCloseC ll - -mop,mcp :: Located Token -> AddEpAnn -mop ll = mj AnnOpenP ll -mcp ll = mj AnnCloseP ll - -moh,mch :: Located Token -> AddEpAnn -moh ll = mj AnnOpenPH ll -mch ll = mj AnnClosePH ll - -mos,mcs :: Located Token -> AddEpAnn -mos ll = mj AnnOpenS ll -mcs ll = mj AnnCloseS ll - -pvA :: MonadP m => m (Located a) -> m (LocatedAn t a) -pvA a = do { av <- a - ; return (reLocA av) } - -pvN :: MonadP m => m (Located a) -> m (LocatedN a) -pvN a = do { (L l av) <- a - ; return (L (noAnnSrcSpan l) av) } - -pvL :: MonadP m => m (LocatedAn t a) -> m (Located a) -pvL a = do { av <- a - ; return (reLoc av) } - --- | Parse a Haskell module with Haddock comments. --- This is done in two steps: --- --- * 'parseModuleNoHaddock' to build the AST --- * 'addHaddockToModule' to insert Haddock comments into it --- --- This is the only parser entry point that deals with Haddock comments. --- The other entry points ('parseDeclaration', 'parseExpression', etc) do --- not insert them into the AST. -parseModule :: P (Located (HsModule GhcPs)) -parseModule = parseModuleNoHaddock >>= addHaddockToModule - -commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann) -commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc - --- | Instead of getting the *enclosed* comments, this includes the --- *preceding* ones. It is used at the top level to get comments --- between top level declarations. -commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a) -commentsPA la@(L l a) = do - cs <- getPriorCommentsFor (getLocA la) - return (L (addCommentsToSrcAnn l cs) a) - -rs :: SrcSpan -> RealSrcSpan -rs (RealSrcSpan l _) = l -rs _ = panic "Parser should only have RealSrcSpan" - -hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList -hsDoAnn (L l _) (L ll _) kw - = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] [] - -listAsAnchor :: [LocatedAn t a] -> Anchor -listAsAnchor [] = spanAsAnchor noSrcSpan -listAsAnchor (L l _:_) = spanAsAnchor (locA l) - -hsTok :: Located Token -> LHsToken tok GhcPs -hsTok (L l _) = L (mkTokenLocation l) HsTok - -hsTok' :: Located Token -> Located (HsToken tok) -hsTok' (L l _) = L l HsTok - -hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs -hsUniTok t@(L l _) = - L (mkTokenLocation l) - (if isUnicode t then HsUnicodeTok else HsNormalTok) - -explicitBraces :: Located Token -> Located Token -> LayoutInfo GhcPs -explicitBraces t1 t2 = ExplicitBraces (hsTok t1) (hsTok t2) - --- ------------------------------------- - -addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b) -addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l) -addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l) - -addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) -addTrailingVbarA la span = addTrailingAnnA la span AddVbarAnn - -addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) -addTrailingSemiA la span = addTrailingAnnA la span AddSemiAnn - -addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) -addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn - -addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a) -addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do - -- cs <- getCommentsFor l - let cs = emptyComments - -- AZ:TODO: generalise updating comments into an annotation - let - anns' = if isZeroWidthSpan ss - then anns - else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns - return (L (SrcSpanAnn anns' l) a) - --- ------------------------------------- - -addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span)) - -addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span)) - -addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) -addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do - cs <- getCommentsFor l - let anns' = addTrailingAnnToL l ta cs anns - return (L (SrcSpanAnn anns' l) a) - --- ------------------------------------- - --- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation -addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) -addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do - -- cs <- getCommentsFor l - let cs = emptyComments - -- AZ:TODO: generalise updating comments into an annotation - let anns' = if isZeroWidthSpan span - then anns - else addTrailingCommaToN l anns (srcSpan2e span) - return (L (SrcSpanAnn anns' l) a) - -addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral -addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) }) - --- ------------------------------------- - -addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a -addTrailingDarrowC (L (SrcSpanAnn EpAnnNotUsed l) a) lt cs = - let - u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax - in L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a -addTrailingDarrowC (L (SrcSpanAnn (EpAnn lr (AnnContext _ o c) csc) l) a) lt cs = - let - u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax - in L (SrcSpanAnn (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a - --- ------------------------------------- - --- We need a location for the where binds, when computing the SrcSpan --- for the AST element using them. Where there is a span, we return --- it, else noLoc, which is ignored in the comb2 call. -adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments)) - -> Located (HsLocalBinds GhcPs, EpAnnComments) -adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments) -adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc) +{-# LANGUAGE MonadComprehensions #-} + +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: ParserOpts -> String -> P a -> ParseResult a +-- runParser opts str parser = unP parser parseState +-- where +-- filename = "\" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = initParserState opts buffer location +-- @ +module GHC.Parser + ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack + , parseDeclaration, parseExpression, parsePattern + , parseTypeSignature + , parseStmt, parseIdentifier + , parseType, parseHeader + , parseModuleNoHaddock + ) +where + +-- base +import Control.Monad ( unless, liftM, when, (<=<) ) +import GHC.Exts +import Data.Maybe ( maybeToList ) +import Data.List.NonEmpty ( NonEmpty(..), head, init, last, tail ) +import qualified Data.List.NonEmpty as NE +import qualified Prelude -- for happy-generated code + +import GHC.Hs + +import GHC.Driver.Backpack.Syntax + +import GHC.Unit.Info +import GHC.Unit.Module +import GHC.Unit.Module.Warnings + +import GHC.Data.OrdList +import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue ) +import GHC.Data.FastString +import GHC.Data.Maybe ( orElse ) + +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) +import GHC.Utils.Panic +import GHC.Prelude hiding ( head, init, last, tail ) +import qualified GHC.Data.Strict as Strict + +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOccFS) +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error ( GhcHint(..) ) +import GHC.Types.Fixity +import GHC.Types.ForeignCall +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.PkgQual + +import GHC.Core.Type ( Specificity(..) ) +import GHC.Core.Class ( FunDep ) +import GHC.Core.DataCon ( DataCon, dataConName ) + +import GHC.Parser.PostProcess +import GHC.Parser.PostProcess.Haddock +import GHC.Parser.Lexer +import GHC.Parser.HaddockLex +import GHC.Parser.Annotation +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () + +import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon, + tupleTyCon, tupleDataCon, nilDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + listTyCon_RDR, consDataCon_RDR, + unrestrictedFunTyCon ) + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Semigroup as Semi +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.20.1.1 + +newtype HappyAbsSyn = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +newtype HappyWrap16 = HappyWrap16 (LocatedN RdrName) +happyIn16 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x) +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn ) -> HappyWrap16 +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +newtype HappyWrap17 = HappyWrap17 ([LHsUnit PackageName]) +happyIn17 :: ([LHsUnit PackageName]) -> (HappyAbsSyn ) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x) +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn ) -> HappyWrap17 +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +newtype HappyWrap18 = HappyWrap18 (OrdList (LHsUnit PackageName)) +happyIn18 :: (OrdList (LHsUnit PackageName)) -> (HappyAbsSyn ) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x) +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn ) -> HappyWrap18 +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +newtype HappyWrap19 = HappyWrap19 (LHsUnit PackageName) +happyIn19 :: (LHsUnit PackageName) -> (HappyAbsSyn ) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x) +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn ) -> HappyWrap19 +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +newtype HappyWrap20 = HappyWrap20 (LHsUnitId PackageName) +happyIn20 :: (LHsUnitId PackageName) -> (HappyAbsSyn ) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x) +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn ) -> HappyWrap20 +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +newtype HappyWrap21 = HappyWrap21 (OrdList (LHsModuleSubst PackageName)) +happyIn21 :: (OrdList (LHsModuleSubst PackageName)) -> (HappyAbsSyn ) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x) +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn ) -> HappyWrap21 +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +newtype HappyWrap22 = HappyWrap22 (LHsModuleSubst PackageName) +happyIn22 :: (LHsModuleSubst PackageName) -> (HappyAbsSyn ) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x) +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn ) -> HappyWrap22 +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +newtype HappyWrap23 = HappyWrap23 (LHsModuleId PackageName) +happyIn23 :: (LHsModuleId PackageName) -> (HappyAbsSyn ) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x) +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn ) -> HappyWrap23 +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +newtype HappyWrap24 = HappyWrap24 (Located PackageName) +happyIn24 :: (Located PackageName) -> (HappyAbsSyn ) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x) +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn ) -> HappyWrap24 +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +newtype HappyWrap25 = HappyWrap25 (Located FastString) +happyIn25 :: (Located FastString) -> (HappyAbsSyn ) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x) +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn ) -> HappyWrap25 +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +newtype HappyWrap26 = HappyWrap26 (()) +happyIn26 :: (()) -> (HappyAbsSyn ) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x) +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn ) -> HappyWrap26 +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +newtype HappyWrap27 = HappyWrap27 (Located FastString) +happyIn27 :: (Located FastString) -> (HappyAbsSyn ) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x) +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn ) -> HappyWrap27 +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +newtype HappyWrap28 = HappyWrap28 (Maybe [LRenaming]) +happyIn28 :: (Maybe [LRenaming]) -> (HappyAbsSyn ) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x) +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn ) -> HappyWrap28 +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +newtype HappyWrap29 = HappyWrap29 (OrdList LRenaming) +happyIn29 :: (OrdList LRenaming) -> (HappyAbsSyn ) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x) +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn ) -> HappyWrap29 +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +newtype HappyWrap30 = HappyWrap30 (LRenaming) +happyIn30 :: (LRenaming) -> (HappyAbsSyn ) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x) +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn ) -> HappyWrap30 +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +newtype HappyWrap31 = HappyWrap31 (OrdList (LHsUnitDecl PackageName)) +happyIn31 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x) +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn ) -> HappyWrap31 +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +newtype HappyWrap32 = HappyWrap32 (OrdList (LHsUnitDecl PackageName)) +happyIn32 :: (OrdList (LHsUnitDecl PackageName)) -> (HappyAbsSyn ) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x) +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn ) -> HappyWrap32 +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +newtype HappyWrap33 = HappyWrap33 (LHsUnitDecl PackageName) +happyIn33 :: (LHsUnitDecl PackageName) -> (HappyAbsSyn ) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x) +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn ) -> HappyWrap33 +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +newtype HappyWrap34 = HappyWrap34 (Located (HsModule GhcPs)) +happyIn34 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x) +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn ) -> HappyWrap34 +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +newtype HappyWrap35 = HappyWrap35 (Located (HsModule GhcPs)) +happyIn35 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x) +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn ) -> HappyWrap35 +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +newtype HappyWrap36 = HappyWrap36 (()) +happyIn36 :: (()) -> (HappyAbsSyn ) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x) +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn ) -> HappyWrap36 +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +newtype HappyWrap37 = HappyWrap37 (()) +happyIn37 :: (()) -> (HappyAbsSyn ) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x) +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn ) -> HappyWrap37 +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +newtype HappyWrap38 = HappyWrap38 (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) +happyIn38 :: (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) -> (HappyAbsSyn ) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x) +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn ) -> HappyWrap38 +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +newtype HappyWrap39 = HappyWrap39 (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) +happyIn39 :: (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]) + ,EpLayout)) -> (HappyAbsSyn ) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x) +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn ) -> HappyWrap39 +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +newtype HappyWrap40 = HappyWrap40 (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) +happyIn40 :: (([TrailingAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) -> (HappyAbsSyn ) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x) +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn ) -> HappyWrap40 +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +newtype HappyWrap41 = HappyWrap41 (([LImportDecl GhcPs], [LHsDecl GhcPs])) +happyIn41 :: (([LImportDecl GhcPs], [LHsDecl GhcPs])) -> (HappyAbsSyn ) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x) +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn ) -> HappyWrap41 +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +newtype HappyWrap42 = HappyWrap42 (Located (HsModule GhcPs)) +happyIn42 :: (Located (HsModule GhcPs)) -> (HappyAbsSyn ) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x) +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn ) -> HappyWrap42 +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +newtype HappyWrap43 = HappyWrap43 ([LImportDecl GhcPs]) +happyIn43 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x) +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn ) -> HappyWrap43 +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +newtype HappyWrap44 = HappyWrap44 ([LImportDecl GhcPs]) +happyIn44 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x) +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn ) -> HappyWrap44 +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +newtype HappyWrap45 = HappyWrap45 ([LImportDecl GhcPs]) +happyIn45 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x) +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn ) -> HappyWrap45 +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +newtype HappyWrap46 = HappyWrap46 ([LImportDecl GhcPs]) +happyIn46 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x) +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn ) -> HappyWrap46 +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +newtype HappyWrap47 = HappyWrap47 ((Maybe (LocatedLI [LIE GhcPs]))) +happyIn47 :: ((Maybe (LocatedLI [LIE GhcPs]))) -> (HappyAbsSyn ) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x) +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn ) -> HappyWrap47 +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +newtype HappyWrap48 = HappyWrap48 (([EpToken ","], OrdList (LIE GhcPs))) +happyIn48 :: (([EpToken ","], OrdList (LIE GhcPs))) -> (HappyAbsSyn ) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x) +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn ) -> HappyWrap48 +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +newtype HappyWrap49 = HappyWrap49 (OrdList (LIE GhcPs)) +happyIn49 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x) +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn ) -> HappyWrap49 +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +newtype HappyWrap50 = HappyWrap50 (OrdList (LIE GhcPs)) +happyIn50 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x) +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn ) -> HappyWrap50 +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +newtype HappyWrap51 = HappyWrap51 (LIE GhcPs) +happyIn51 :: (LIE GhcPs) -> (HappyAbsSyn ) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x) +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn ) -> HappyWrap51 +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +newtype HappyWrap52 = HappyWrap52 (Located ((EpToken "(", EpToken ")"), ImpExpSubSpec)) +happyIn52 :: (Located ((EpToken "(", EpToken ")"), ImpExpSubSpec)) -> (HappyAbsSyn ) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x) +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn ) -> HappyWrap52 +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +newtype HappyWrap53 = HappyWrap53 ([LocatedA ImpExpQcSpec]) +happyIn53 :: ([LocatedA ImpExpQcSpec]) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x) +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> HappyWrap53 +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +newtype HappyWrap54 = HappyWrap54 ([LocatedA ImpExpQcSpec]) +happyIn54 :: ([LocatedA ImpExpQcSpec]) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x) +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> HappyWrap54 +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +newtype HappyWrap55 = HappyWrap55 (LocatedA ImpExpQcSpec) +happyIn55 :: (LocatedA ImpExpQcSpec) -> (HappyAbsSyn ) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x) +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn ) -> HappyWrap55 +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +newtype HappyWrap56 = HappyWrap56 (LocatedA ImpExpQcSpec) +happyIn56 :: (LocatedA ImpExpQcSpec) -> (HappyAbsSyn ) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x) +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn ) -> HappyWrap56 +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +newtype HappyWrap57 = HappyWrap57 (LocatedN RdrName) +happyIn57 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x) +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn ) -> HappyWrap57 +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +newtype HappyWrap58 = HappyWrap58 (Located [TrailingAnn]) +happyIn58 :: (Located [TrailingAnn]) -> (HappyAbsSyn ) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x) +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn ) -> HappyWrap58 +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +newtype HappyWrap59 = HappyWrap59 ([TrailingAnn]) +happyIn59 :: ([TrailingAnn]) -> (HappyAbsSyn ) +happyIn59 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap59 x) +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn ) -> HappyWrap59 +happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut59 #-} +newtype HappyWrap60 = HappyWrap60 ([LImportDecl GhcPs]) +happyIn60 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn60 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap60 x) +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn ) -> HappyWrap60 +happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut60 #-} +newtype HappyWrap61 = HappyWrap61 ([LImportDecl GhcPs]) +happyIn61 :: ([LImportDecl GhcPs]) -> (HappyAbsSyn ) +happyIn61 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap61 x) +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn ) -> HappyWrap61 +happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut61 #-} +newtype HappyWrap62 = HappyWrap62 (LImportDecl GhcPs) +happyIn62 :: (LImportDecl GhcPs) -> (HappyAbsSyn ) +happyIn62 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap62 x) +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn ) -> HappyWrap62 +happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut62 #-} +newtype HappyWrap63 = HappyWrap63 (((Maybe (EpaLocation,EpToken "#-}"),SourceText),IsBootInterface)) +happyIn63 :: (((Maybe (EpaLocation,EpToken "#-}"),SourceText),IsBootInterface)) -> (HappyAbsSyn ) +happyIn63 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap63 x) +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn ) -> HappyWrap63 +happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut63 #-} +newtype HappyWrap64 = HappyWrap64 ((Maybe (EpToken "safe"),Bool)) +happyIn64 :: ((Maybe (EpToken "safe"),Bool)) -> (HappyAbsSyn ) +happyIn64 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap64 x) +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn ) -> HappyWrap64 +happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut64 #-} +newtype HappyWrap65 = HappyWrap65 ((Maybe EpAnnLevel)) +happyIn65 :: ((Maybe EpAnnLevel)) -> (HappyAbsSyn ) +happyIn65 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap65 x) +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn ) -> HappyWrap65 +happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut65 #-} +newtype HappyWrap66 = HappyWrap66 ((Maybe EpaLocation, RawPkgQual)) +happyIn66 :: ((Maybe EpaLocation, RawPkgQual)) -> (HappyAbsSyn ) +happyIn66 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap66 x) +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn ) -> HappyWrap66 +happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut66 #-} +newtype HappyWrap67 = HappyWrap67 (Maybe (EpToken "qualified")) +happyIn67 :: (Maybe (EpToken "qualified")) -> (HappyAbsSyn ) +happyIn67 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap67 x) +{-# INLINE happyIn67 #-} +happyOut67 :: (HappyAbsSyn ) -> HappyWrap67 +happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut67 #-} +newtype HappyWrap68 = HappyWrap68 ((Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName)))) +happyIn68 :: ((Maybe (EpToken "as"),Located (Maybe (LocatedA ModuleName)))) -> (HappyAbsSyn ) +happyIn68 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap68 x) +{-# INLINE happyIn68 #-} +happyOut68 :: (HappyAbsSyn ) -> HappyWrap68 +happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut68 #-} +newtype HappyWrap69 = HappyWrap69 (Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]))) +happyIn69 :: (Located (Maybe (ImportListInterpretation, LocatedLI [LIE GhcPs]))) -> (HappyAbsSyn ) +happyIn69 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap69 x) +{-# INLINE happyIn69 #-} +happyOut69 :: (HappyAbsSyn ) -> HappyWrap69 +happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut69 #-} +newtype HappyWrap70 = HappyWrap70 (Located (ImportListInterpretation, LocatedLI [LIE GhcPs])) +happyIn70 :: (Located (ImportListInterpretation, LocatedLI [LIE GhcPs])) -> (HappyAbsSyn ) +happyIn70 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap70 x) +{-# INLINE happyIn70 #-} +happyOut70 :: (HappyAbsSyn ) -> HappyWrap70 +happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut70 #-} +newtype HappyWrap71 = HappyWrap71 (([EpToken ","], OrdList (LIE GhcPs))) +happyIn71 :: (([EpToken ","], OrdList (LIE GhcPs))) -> (HappyAbsSyn ) +happyIn71 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap71 x) +{-# INLINE happyIn71 #-} +happyOut71 :: (HappyAbsSyn ) -> HappyWrap71 +happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut71 #-} +newtype HappyWrap72 = HappyWrap72 (OrdList (LIE GhcPs)) +happyIn72 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn72 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap72 x) +{-# INLINE happyIn72 #-} +happyOut72 :: (HappyAbsSyn ) -> HappyWrap72 +happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut72 #-} +newtype HappyWrap73 = HappyWrap73 (OrdList (LIE GhcPs)) +happyIn73 :: (OrdList (LIE GhcPs)) -> (HappyAbsSyn ) +happyIn73 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap73 x) +{-# INLINE happyIn73 #-} +happyOut73 :: (HappyAbsSyn ) -> HappyWrap73 +happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut73 #-} +newtype HappyWrap74 = HappyWrap74 (Maybe (Located (SourceText,Int))) +happyIn74 :: (Maybe (Located (SourceText,Int))) -> (HappyAbsSyn ) +happyIn74 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap74 x) +{-# INLINE happyIn74 #-} +happyOut74 :: (HappyAbsSyn ) -> HappyWrap74 +happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut74 #-} +newtype HappyWrap75 = HappyWrap75 (Located FixityDirection) +happyIn75 :: (Located FixityDirection) -> (HappyAbsSyn ) +happyIn75 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap75 x) +{-# INLINE happyIn75 #-} +happyOut75 :: (HappyAbsSyn ) -> HappyWrap75 +happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut75 #-} +newtype HappyWrap76 = HappyWrap76 (Located (OrdList (LocatedN RdrName))) +happyIn76 :: (Located (OrdList (LocatedN RdrName))) -> (HappyAbsSyn ) +happyIn76 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap76 x) +{-# INLINE happyIn76 #-} +happyOut76 :: (HappyAbsSyn ) -> HappyWrap76 +happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut76 #-} +newtype HappyWrap77 = HappyWrap77 (OrdList (LHsDecl GhcPs)) +happyIn77 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn77 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap77 x) +{-# INLINE happyIn77 #-} +happyOut77 :: (HappyAbsSyn ) -> HappyWrap77 +happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut77 #-} +newtype HappyWrap78 = HappyWrap78 (OrdList (LHsDecl GhcPs)) +happyIn78 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn78 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap78 x) +{-# INLINE happyIn78 #-} +happyOut78 :: (HappyAbsSyn ) -> HappyWrap78 +happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut78 #-} +newtype HappyWrap79 = HappyWrap79 (OrdList (LHsDecl GhcPs)) +happyIn79 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn79 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap79 x) +{-# INLINE happyIn79 #-} +happyOut79 :: (HappyAbsSyn ) -> HappyWrap79 +happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut79 #-} +newtype HappyWrap80 = HappyWrap80 (OrdList (LHsDecl GhcPs)) +happyIn80 :: (OrdList (LHsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn80 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap80 x) +{-# INLINE happyIn80 #-} +happyOut80 :: (HappyAbsSyn ) -> HappyWrap80 +happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut80 #-} +newtype HappyWrap81 = HappyWrap81 (LHsDecl GhcPs) +happyIn81 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn81 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap81 x) +{-# INLINE happyIn81 #-} +happyOut81 :: (HappyAbsSyn ) -> HappyWrap81 +happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut81 #-} +newtype HappyWrap82 = HappyWrap82 (LHsDecl GhcPs) +happyIn82 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn82 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap82 x) +{-# INLINE happyIn82 #-} +happyOut82 :: (HappyAbsSyn ) -> HappyWrap82 +happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut82 #-} +newtype HappyWrap83 = HappyWrap83 (LTyClDecl GhcPs) +happyIn83 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) +happyIn83 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap83 x) +{-# INLINE happyIn83 #-} +happyOut83 :: (HappyAbsSyn ) -> HappyWrap83 +happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut83 #-} +newtype HappyWrap84 = HappyWrap84 (LDefaultDecl GhcPs) +happyIn84 :: (LDefaultDecl GhcPs) -> (HappyAbsSyn ) +happyIn84 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap84 x) +{-# INLINE happyIn84 #-} +happyOut84 :: (HappyAbsSyn ) -> HappyWrap84 +happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut84 #-} +newtype HappyWrap85 = HappyWrap85 (LTyClDecl GhcPs) +happyIn85 :: (LTyClDecl GhcPs) -> (HappyAbsSyn ) +happyIn85 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap85 x) +{-# INLINE happyIn85 #-} +happyOut85 :: (HappyAbsSyn ) -> HappyWrap85 +happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut85 #-} +newtype HappyWrap86 = HappyWrap86 (LStandaloneKindSig GhcPs) +happyIn86 :: (LStandaloneKindSig GhcPs) -> (HappyAbsSyn ) +happyIn86 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap86 x) +{-# INLINE happyIn86 #-} +happyOut86 :: (HappyAbsSyn ) -> HappyWrap86 +happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut86 #-} +newtype HappyWrap87 = HappyWrap87 (Located [LocatedN RdrName]) +happyIn87 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn87 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap87 x) +{-# INLINE happyIn87 #-} +happyOut87 :: (HappyAbsSyn ) -> HappyWrap87 +happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut87 #-} +newtype HappyWrap88 = HappyWrap88 (LInstDecl GhcPs) +happyIn88 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) +happyIn88 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap88 x) +{-# INLINE happyIn88 #-} +happyOut88 :: (HappyAbsSyn ) -> HappyWrap88 +happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut88 #-} +newtype HappyWrap89 = HappyWrap89 (Maybe (LocatedP OverlapMode)) +happyIn89 :: (Maybe (LocatedP OverlapMode)) -> (HappyAbsSyn ) +happyIn89 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap89 x) +{-# INLINE happyIn89 #-} +happyOut89 :: (HappyAbsSyn ) -> HappyWrap89 +happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut89 #-} +newtype HappyWrap90 = HappyWrap90 (LDerivStrategy GhcPs) +happyIn90 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) +happyIn90 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap90 x) +{-# INLINE happyIn90 #-} +happyOut90 :: (HappyAbsSyn ) -> HappyWrap90 +happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut90 #-} +newtype HappyWrap91 = HappyWrap91 (LDerivStrategy GhcPs) +happyIn91 :: (LDerivStrategy GhcPs) -> (HappyAbsSyn ) +happyIn91 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap91 x) +{-# INLINE happyIn91 #-} +happyOut91 :: (HappyAbsSyn ) -> HappyWrap91 +happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut91 #-} +newtype HappyWrap92 = HappyWrap92 (Maybe (LDerivStrategy GhcPs)) +happyIn92 :: (Maybe (LDerivStrategy GhcPs)) -> (HappyAbsSyn ) +happyIn92 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap92 x) +{-# INLINE happyIn92 #-} +happyOut92 :: (HappyAbsSyn ) -> HappyWrap92 +happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut92 #-} +newtype HappyWrap93 = HappyWrap93 (Maybe (LIdP GhcPs)) +happyIn93 :: (Maybe (LIdP GhcPs)) -> (HappyAbsSyn ) +happyIn93 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap93 x) +{-# INLINE happyIn93 #-} +happyOut93 :: (HappyAbsSyn ) -> HappyWrap93 +happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut93 #-} +newtype HappyWrap94 = HappyWrap94 (Located (EpToken "|", Maybe (LInjectivityAnn GhcPs))) +happyIn94 :: (Located (EpToken "|", Maybe (LInjectivityAnn GhcPs))) -> (HappyAbsSyn ) +happyIn94 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap94 x) +{-# INLINE happyIn94 #-} +happyOut94 :: (HappyAbsSyn ) -> HappyWrap94 +happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut94 #-} +newtype HappyWrap95 = HappyWrap95 (LInjectivityAnn GhcPs) +happyIn95 :: (LInjectivityAnn GhcPs) -> (HappyAbsSyn ) +happyIn95 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap95 x) +{-# INLINE happyIn95 #-} +happyOut95 :: (HappyAbsSyn ) -> HappyWrap95 +happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut95 #-} +newtype HappyWrap96 = HappyWrap96 (Located [LocatedN RdrName]) +happyIn96 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn96 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap96 x) +{-# INLINE happyIn96 #-} +happyOut96 :: (HappyAbsSyn ) -> HappyWrap96 +happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut96 #-} +newtype HappyWrap97 = HappyWrap97 (Located ((EpToken "where", (EpToken "{", EpToken "..", EpToken "}")),FamilyInfo GhcPs)) +happyIn97 :: (Located ((EpToken "where", (EpToken "{", EpToken "..", EpToken "}")),FamilyInfo GhcPs)) -> (HappyAbsSyn ) +happyIn97 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap97 x) +{-# INLINE happyIn97 #-} +happyOut97 :: (HappyAbsSyn ) -> HappyWrap97 +happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut97 #-} +newtype HappyWrap98 = HappyWrap98 (Located ((EpToken "{", EpToken "..", EpToken "}"),Maybe [LTyFamInstEqn GhcPs])) +happyIn98 :: (Located ((EpToken "{", EpToken "..", EpToken "}"),Maybe [LTyFamInstEqn GhcPs])) -> (HappyAbsSyn ) +happyIn98 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap98 x) +{-# INLINE happyIn98 #-} +happyOut98 :: (HappyAbsSyn ) -> HappyWrap98 +happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut98 #-} +newtype HappyWrap99 = HappyWrap99 (Located [LTyFamInstEqn GhcPs]) +happyIn99 :: (Located [LTyFamInstEqn GhcPs]) -> (HappyAbsSyn ) +happyIn99 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap99 x) +{-# INLINE happyIn99 #-} +happyOut99 :: (HappyAbsSyn ) -> HappyWrap99 +happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut99 #-} +newtype HappyWrap100 = HappyWrap100 (LTyFamInstEqn GhcPs) +happyIn100 :: (LTyFamInstEqn GhcPs) -> (HappyAbsSyn ) +happyIn100 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap100 x) +{-# INLINE happyIn100 #-} +happyOut100 :: (HappyAbsSyn ) -> HappyWrap100 +happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut100 #-} +newtype HappyWrap101 = HappyWrap101 (LHsDecl GhcPs) +happyIn101 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn101 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap101 x) +{-# INLINE happyIn101 #-} +happyOut101 :: (HappyAbsSyn ) -> HappyWrap101 +happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut101 #-} +newtype HappyWrap102 = HappyWrap102 (EpToken "family") +happyIn102 :: (EpToken "family") -> (HappyAbsSyn ) +happyIn102 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap102 x) +{-# INLINE happyIn102 #-} +happyOut102 :: (HappyAbsSyn ) -> HappyWrap102 +happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut102 #-} +newtype HappyWrap103 = HappyWrap103 (EpToken "instance") +happyIn103 :: (EpToken "instance") -> (HappyAbsSyn ) +happyIn103 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap103 x) +{-# INLINE happyIn103 #-} +happyOut103 :: (HappyAbsSyn ) -> HappyWrap103 +happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut103 #-} +newtype HappyWrap104 = HappyWrap104 (LInstDecl GhcPs) +happyIn104 :: (LInstDecl GhcPs) -> (HappyAbsSyn ) +happyIn104 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap104 x) +{-# INLINE happyIn104 #-} +happyOut104 :: (HappyAbsSyn ) -> HappyWrap104 +happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut104 #-} +newtype HappyWrap105 = HappyWrap105 (Located ((EpToken "data", EpToken "newtype", EpToken "type") + , Bool, NewOrData)) +happyIn105 :: (Located ((EpToken "data", EpToken "newtype", EpToken "type") + , Bool, NewOrData)) -> (HappyAbsSyn ) +happyIn105 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap105 x) +{-# INLINE happyIn105 #-} +happyOut105 :: (HappyAbsSyn ) -> HappyWrap105 +happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut105 #-} +newtype HappyWrap106 = HappyWrap106 (Located ((EpToken "data", EpToken "newtype"), NewOrData)) +happyIn106 :: (Located ((EpToken "data", EpToken "newtype"), NewOrData)) -> (HappyAbsSyn ) +happyIn106 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap106 x) +{-# INLINE happyIn106 #-} +happyOut106 :: (HappyAbsSyn ) -> HappyWrap106 +happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut106 #-} +newtype HappyWrap107 = HappyWrap107 (Located (TokDcolon, Maybe (LHsKind GhcPs))) +happyIn107 :: (Located (TokDcolon, Maybe (LHsKind GhcPs))) -> (HappyAbsSyn ) +happyIn107 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap107 x) +{-# INLINE happyIn107 #-} +happyOut107 :: (HappyAbsSyn ) -> HappyWrap107 +happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut107 #-} +newtype HappyWrap108 = HappyWrap108 (Located (TokDcolon, LFamilyResultSig GhcPs)) +happyIn108 :: (Located (TokDcolon, LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) +happyIn108 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap108 x) +{-# INLINE happyIn108 #-} +happyOut108 :: (HappyAbsSyn ) -> HappyWrap108 +happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut108 #-} +newtype HappyWrap109 = HappyWrap109 (Located ((TokDcolon, EpToken "="), LFamilyResultSig GhcPs)) +happyIn109 :: (Located ((TokDcolon, EpToken "="), LFamilyResultSig GhcPs)) -> (HappyAbsSyn ) +happyIn109 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap109 x) +{-# INLINE happyIn109 #-} +happyOut109 :: (HappyAbsSyn ) -> HappyWrap109 +happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut109 #-} +newtype HappyWrap110 = HappyWrap110 (Located ((TokDcolon, EpToken "=", EpToken "|"), ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))) +happyIn110 :: (Located ((TokDcolon, EpToken "=", EpToken "|"), ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))) -> (HappyAbsSyn ) +happyIn110 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap110 x) +{-# INLINE happyIn110 #-} +happyOut110 :: (HappyAbsSyn ) -> HappyWrap110 +happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut110 #-} +newtype HappyWrap111 = HappyWrap111 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) +happyIn111 :: (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) -> (HappyAbsSyn ) +happyIn111 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap111 x) +{-# INLINE happyIn111 #-} +happyOut111 :: (HappyAbsSyn ) -> HappyWrap111 +happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut111 #-} +newtype HappyWrap112 = HappyWrap112 (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) +happyIn112 :: (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -> (HappyAbsSyn ) +happyIn112 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap112 x) +{-# INLINE happyIn112 #-} +happyOut112 :: (HappyAbsSyn ) -> HappyWrap112 +happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut112 #-} +newtype HappyWrap113 = HappyWrap113 (Maybe (LocatedP CType)) +happyIn113 :: (Maybe (LocatedP CType)) -> (HappyAbsSyn ) +happyIn113 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap113 x) +{-# INLINE happyIn113 #-} +happyOut113 :: (HappyAbsSyn ) -> HappyWrap113 +happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut113 #-} +newtype HappyWrap114 = HappyWrap114 (LDerivDecl GhcPs) +happyIn114 :: (LDerivDecl GhcPs) -> (HappyAbsSyn ) +happyIn114 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap114 x) +{-# INLINE happyIn114 #-} +happyOut114 :: (HappyAbsSyn ) -> HappyWrap114 +happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut114 #-} +newtype HappyWrap115 = HappyWrap115 (LRoleAnnotDecl GhcPs) +happyIn115 :: (LRoleAnnotDecl GhcPs) -> (HappyAbsSyn ) +happyIn115 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap115 x) +{-# INLINE happyIn115 #-} +happyOut115 :: (HappyAbsSyn ) -> HappyWrap115 +happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut115 #-} +newtype HappyWrap116 = HappyWrap116 (Located [Located (Maybe FastString)]) +happyIn116 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) +happyIn116 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap116 x) +{-# INLINE happyIn116 #-} +happyOut116 :: (HappyAbsSyn ) -> HappyWrap116 +happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut116 #-} +newtype HappyWrap117 = HappyWrap117 (Located [Located (Maybe FastString)]) +happyIn117 :: (Located [Located (Maybe FastString)]) -> (HappyAbsSyn ) +happyIn117 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap117 x) +{-# INLINE happyIn117 #-} +happyOut117 :: (HappyAbsSyn ) -> HappyWrap117 +happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut117 #-} +newtype HappyWrap118 = HappyWrap118 (Located (Maybe FastString)) +happyIn118 :: (Located (Maybe FastString)) -> (HappyAbsSyn ) +happyIn118 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap118 x) +{-# INLINE happyIn118 #-} +happyOut118 :: (HappyAbsSyn ) -> HappyWrap118 +happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut118 #-} +newtype HappyWrap119 = HappyWrap119 (LHsDecl GhcPs) +happyIn119 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn119 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap119 x) +{-# INLINE happyIn119 #-} +happyOut119 :: (HappyAbsSyn ) -> HappyWrap119 +happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut119 #-} +newtype HappyWrap120 = HappyWrap120 ((LocatedN RdrName, HsPatSynDetails GhcPs, (Maybe (EpToken "{"), Maybe (EpToken "}")))) +happyIn120 :: ((LocatedN RdrName, HsPatSynDetails GhcPs, (Maybe (EpToken "{"), Maybe (EpToken "}")))) -> (HappyAbsSyn ) +happyIn120 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap120 x) +{-# INLINE happyIn120 #-} +happyOut120 :: (HappyAbsSyn ) -> HappyWrap120 +happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut120 #-} +newtype HappyWrap121 = HappyWrap121 ([LocatedN RdrName]) +happyIn121 :: ([LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn121 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap121 x) +{-# INLINE happyIn121 #-} +happyOut121 :: (HappyAbsSyn ) -> HappyWrap121 +happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut121 #-} +newtype HappyWrap122 = HappyWrap122 ([RecordPatSynField GhcPs]) +happyIn122 :: ([RecordPatSynField GhcPs]) -> (HappyAbsSyn ) +happyIn122 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap122 x) +{-# INLINE happyIn122 #-} +happyOut122 :: (HappyAbsSyn ) -> HappyWrap122 +happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut122 #-} +newtype HappyWrap123 = HappyWrap123 (LocatedLW (OrdList (LHsDecl GhcPs))) +happyIn123 :: (LocatedLW (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn123 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap123 x) +{-# INLINE happyIn123 #-} +happyOut123 :: (HappyAbsSyn ) -> HappyWrap123 +happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut123 #-} +newtype HappyWrap124 = HappyWrap124 (LSig GhcPs) +happyIn124 :: (LSig GhcPs) -> (HappyAbsSyn ) +happyIn124 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap124 x) +{-# INLINE happyIn124 #-} +happyOut124 :: (HappyAbsSyn ) -> HappyWrap124 +happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut124 #-} +newtype HappyWrap125 = HappyWrap125 (LocatedN RdrName) +happyIn125 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn125 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap125 x) +{-# INLINE happyIn125 #-} +happyOut125 :: (HappyAbsSyn ) -> HappyWrap125 +happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut125 #-} +newtype HappyWrap126 = HappyWrap126 (LHsDecl GhcPs) +happyIn126 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn126 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap126 x) +{-# INLINE happyIn126 #-} +happyOut126 :: (HappyAbsSyn ) -> HappyWrap126 +happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut126 #-} +newtype HappyWrap127 = HappyWrap127 (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) +happyIn127 :: (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn127 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap127 x) +{-# INLINE happyIn127 #-} +happyOut127 :: (HappyAbsSyn ) -> HappyWrap127 +happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut127 #-} +newtype HappyWrap128 = HappyWrap128 (Located ((EpToken "{", [EpToken ";"], EpToken "}") + , OrdList (LHsDecl GhcPs) + , EpLayout)) +happyIn128 :: (Located ((EpToken "{", [EpToken ";"], EpToken "}") + , OrdList (LHsDecl GhcPs) + , EpLayout)) -> (HappyAbsSyn ) +happyIn128 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap128 x) +{-# INLINE happyIn128 #-} +happyOut128 :: (HappyAbsSyn ) -> HappyWrap128 +happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut128 #-} +newtype HappyWrap129 = HappyWrap129 (Located ((EpToken "where", (EpToken "{", [EpToken ";"], EpToken "}")) + ,(OrdList (LHsDecl GhcPs)) -- Reversed + ,EpLayout)) +happyIn129 :: (Located ((EpToken "where", (EpToken "{", [EpToken ";"], EpToken "}")) + ,(OrdList (LHsDecl GhcPs)) -- Reversed + ,EpLayout)) -> (HappyAbsSyn ) +happyIn129 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap129 x) +{-# INLINE happyIn129 #-} +happyOut129 :: (HappyAbsSyn ) -> HappyWrap129 +happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut129 #-} +newtype HappyWrap130 = HappyWrap130 (Located (OrdList (LHsDecl GhcPs))) +happyIn130 :: (Located (OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn130 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap130 x) +{-# INLINE happyIn130 #-} +happyOut130 :: (HappyAbsSyn ) -> HappyWrap130 +happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut130 #-} +newtype HappyWrap131 = HappyWrap131 (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) +happyIn131 :: (Located ([EpToken ";"],OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn131 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap131 x) +{-# INLINE happyIn131 #-} +happyOut131 :: (HappyAbsSyn ) -> HappyWrap131 +happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut131 #-} +newtype HappyWrap132 = HappyWrap132 (Located ((EpToken "{", EpToken "}", [EpToken ";"]) + , OrdList (LHsDecl GhcPs))) +happyIn132 :: (Located ((EpToken "{", EpToken "}", [EpToken ";"]) + , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn132 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap132 x) +{-# INLINE happyIn132 #-} +happyOut132 :: (HappyAbsSyn ) -> HappyWrap132 +happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut132 #-} +newtype HappyWrap133 = HappyWrap133 (Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken ";"])) + , OrdList (LHsDecl GhcPs))) +happyIn133 :: (Located ((EpToken "where", (EpToken "{", EpToken "}", [EpToken ";"])) + , OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn133 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap133 x) +{-# INLINE happyIn133 #-} +happyOut133 :: (HappyAbsSyn ) -> HappyWrap133 +happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut133 #-} +newtype HappyWrap134 = HappyWrap134 (Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs))) +happyIn134 :: (Located (EpaLocation, [EpToken ";"], OrdList (LHsDecl GhcPs))) -> (HappyAbsSyn ) +happyIn134 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap134 x) +{-# INLINE happyIn134 #-} +happyOut134 :: (HappyAbsSyn ) -> HappyWrap134 +happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut134 #-} +newtype HappyWrap135 = HappyWrap135 (Located (AnnList (),Located (OrdList (LHsDecl GhcPs)))) +happyIn135 :: (Located (AnnList (),Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) +happyIn135 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap135 x) +{-# INLINE happyIn135 #-} +happyOut135 :: (HappyAbsSyn ) -> HappyWrap135 +happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut135 #-} +newtype HappyWrap136 = HappyWrap136 (Located (HsLocalBinds GhcPs)) +happyIn136 :: (Located (HsLocalBinds GhcPs)) -> (HappyAbsSyn ) +happyIn136 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap136 x) +{-# INLINE happyIn136 #-} +happyOut136 :: (HappyAbsSyn ) -> HappyWrap136 +happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut136 #-} +newtype HappyWrap137 = HappyWrap137 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) +happyIn137 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (HappyAbsSyn ) +happyIn137 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap137 x) +{-# INLINE happyIn137 #-} +happyOut137 :: (HappyAbsSyn ) -> HappyWrap137 +happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut137 #-} +newtype HappyWrap138 = HappyWrap138 ([LRuleDecl GhcPs]) +happyIn138 :: ([LRuleDecl GhcPs]) -> (HappyAbsSyn ) +happyIn138 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap138 x) +{-# INLINE happyIn138 #-} +happyOut138 :: (HappyAbsSyn ) -> HappyWrap138 +happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut138 #-} +newtype HappyWrap139 = HappyWrap139 (LRuleDecl GhcPs) +happyIn139 :: (LRuleDecl GhcPs) -> (HappyAbsSyn ) +happyIn139 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap139 x) +{-# INLINE happyIn139 #-} +happyOut139 :: (HappyAbsSyn ) -> HappyWrap139 +happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut139 #-} +newtype HappyWrap140 = HappyWrap140 ((ActivationAnn, Maybe Activation)) +happyIn140 :: ((ActivationAnn, Maybe Activation)) -> (HappyAbsSyn ) +happyIn140 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap140 x) +{-# INLINE happyIn140 #-} +happyOut140 :: (HappyAbsSyn ) -> HappyWrap140 +happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut140 #-} +newtype HappyWrap141 = HappyWrap141 ((Maybe (EpToken "~"))) +happyIn141 :: ((Maybe (EpToken "~"))) -> (HappyAbsSyn ) +happyIn141 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap141 x) +{-# INLINE happyIn141 #-} +happyOut141 :: (HappyAbsSyn ) -> HappyWrap141 +happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut141 #-} +newtype HappyWrap142 = HappyWrap142 (( ActivationAnn + , Activation)) +happyIn142 :: (( ActivationAnn + , Activation)) -> (HappyAbsSyn ) +happyIn142 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap142 x) +{-# INLINE happyIn142 #-} +happyOut142 :: (HappyAbsSyn ) -> HappyWrap142 +happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut142 #-} +newtype HappyWrap143 = HappyWrap143 (Maybe (RuleBndrs GhcPs)) +happyIn143 :: (Maybe (RuleBndrs GhcPs)) -> (HappyAbsSyn ) +happyIn143 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap143 x) +{-# INLINE happyIn143 #-} +happyOut143 :: (HappyAbsSyn ) -> HappyWrap143 +happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut143 #-} +newtype HappyWrap144 = HappyWrap144 ([LRuleTyTmVar]) +happyIn144 :: ([LRuleTyTmVar]) -> (HappyAbsSyn ) +happyIn144 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap144 x) +{-# INLINE happyIn144 #-} +happyOut144 :: (HappyAbsSyn ) -> HappyWrap144 +happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut144 #-} +newtype HappyWrap145 = HappyWrap145 (LRuleTyTmVar) +happyIn145 :: (LRuleTyTmVar) -> (HappyAbsSyn ) +happyIn145 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap145 x) +{-# INLINE happyIn145 #-} +happyOut145 :: (HappyAbsSyn ) -> HappyWrap145 +happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut145 #-} +newtype HappyWrap146 = HappyWrap146 (Maybe (LWarningTxt GhcPs)) +happyIn146 :: (Maybe (LWarningTxt GhcPs)) -> (HappyAbsSyn ) +happyIn146 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap146 x) +{-# INLINE happyIn146 #-} +happyOut146 :: (HappyAbsSyn ) -> HappyWrap146 +happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut146 #-} +newtype HappyWrap147 = HappyWrap147 (Maybe (LocatedE InWarningCategory)) +happyIn147 :: (Maybe (LocatedE InWarningCategory)) -> (HappyAbsSyn ) +happyIn147 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap147 x) +{-# INLINE happyIn147 #-} +happyOut147 :: (HappyAbsSyn ) -> HappyWrap147 +happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut147 #-} +newtype HappyWrap148 = HappyWrap148 (OrdList (LWarnDecl GhcPs)) +happyIn148 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn148 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap148 x) +{-# INLINE happyIn148 #-} +happyOut148 :: (HappyAbsSyn ) -> HappyWrap148 +happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut148 #-} +newtype HappyWrap149 = HappyWrap149 (OrdList (LWarnDecl GhcPs)) +happyIn149 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn149 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap149 x) +{-# INLINE happyIn149 #-} +happyOut149 :: (HappyAbsSyn ) -> HappyWrap149 +happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut149 #-} +newtype HappyWrap150 = HappyWrap150 (Located NamespaceSpecifier) +happyIn150 :: (Located NamespaceSpecifier) -> (HappyAbsSyn ) +happyIn150 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap150 x) +{-# INLINE happyIn150 #-} +happyOut150 :: (HappyAbsSyn ) -> HappyWrap150 +happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut150 #-} +newtype HappyWrap151 = HappyWrap151 (OrdList (LWarnDecl GhcPs)) +happyIn151 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn151 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap151 x) +{-# INLINE happyIn151 #-} +happyOut151 :: (HappyAbsSyn ) -> HappyWrap151 +happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut151 #-} +newtype HappyWrap152 = HappyWrap152 (OrdList (LWarnDecl GhcPs)) +happyIn152 :: (OrdList (LWarnDecl GhcPs)) -> (HappyAbsSyn ) +happyIn152 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap152 x) +{-# INLINE happyIn152 #-} +happyOut152 :: (HappyAbsSyn ) -> HappyWrap152 +happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut152 #-} +newtype HappyWrap153 = HappyWrap153 (Located ((EpToken "[", EpToken "]"),[Located StringLiteral])) +happyIn153 :: (Located ((EpToken "[", EpToken "]"),[Located StringLiteral])) -> (HappyAbsSyn ) +happyIn153 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap153 x) +{-# INLINE happyIn153 #-} +happyOut153 :: (HappyAbsSyn ) -> HappyWrap153 +happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut153 #-} +newtype HappyWrap154 = HappyWrap154 (Located (OrdList (Located StringLiteral))) +happyIn154 :: (Located (OrdList (Located StringLiteral))) -> (HappyAbsSyn ) +happyIn154 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap154 x) +{-# INLINE happyIn154 #-} +happyOut154 :: (HappyAbsSyn ) -> HappyWrap154 +happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut154 #-} +newtype HappyWrap155 = HappyWrap155 (LHsDecl GhcPs) +happyIn155 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn155 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap155 x) +{-# INLINE happyIn155 #-} +happyOut155 :: (HappyAbsSyn ) -> HappyWrap155 +happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut155 #-} +newtype HappyWrap156 = HappyWrap156 (Located (EpToken "foreign" -> HsDecl GhcPs)) +happyIn156 :: (Located (EpToken "foreign" -> HsDecl GhcPs)) -> (HappyAbsSyn ) +happyIn156 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap156 x) +{-# INLINE happyIn156 #-} +happyOut156 :: (HappyAbsSyn ) -> HappyWrap156 +happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut156 #-} +newtype HappyWrap157 = HappyWrap157 (Located CCallConv) +happyIn157 :: (Located CCallConv) -> (HappyAbsSyn ) +happyIn157 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap157 x) +{-# INLINE happyIn157 #-} +happyOut157 :: (HappyAbsSyn ) -> HappyWrap157 +happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut157 #-} +newtype HappyWrap158 = HappyWrap158 (Located Safety) +happyIn158 :: (Located Safety) -> (HappyAbsSyn ) +happyIn158 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap158 x) +{-# INLINE happyIn158 #-} +happyOut158 :: (HappyAbsSyn ) -> HappyWrap158 +happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut158 #-} +newtype HappyWrap159 = HappyWrap159 (Located (TokDcolon + ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) +happyIn159 :: (Located (TokDcolon + ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -> (HappyAbsSyn ) +happyIn159 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap159 x) +{-# INLINE happyIn159 #-} +happyOut159 :: (HappyAbsSyn ) -> HappyWrap159 +happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut159 #-} +newtype HappyWrap160 = HappyWrap160 (Maybe (EpUniToken "::" "\8759", LHsType GhcPs)) +happyIn160 :: (Maybe (EpUniToken "::" "\8759", LHsType GhcPs)) -> (HappyAbsSyn ) +happyIn160 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap160 x) +{-# INLINE happyIn160 #-} +happyOut160 :: (HappyAbsSyn ) -> HappyWrap160 +happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut160 #-} +newtype HappyWrap161 = HappyWrap161 ((Maybe (EpUniToken "::" "\8759"), Maybe (LocatedN RdrName))) +happyIn161 :: ((Maybe (EpUniToken "::" "\8759"), Maybe (LocatedN RdrName))) -> (HappyAbsSyn ) +happyIn161 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap161 x) +{-# INLINE happyIn161 #-} +happyOut161 :: (HappyAbsSyn ) -> HappyWrap161 +happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut161 #-} +newtype HappyWrap162 = HappyWrap162 (LHsSigType GhcPs) +happyIn162 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) +happyIn162 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap162 x) +{-# INLINE happyIn162 #-} +happyOut162 :: (HappyAbsSyn ) -> HappyWrap162 +happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut162 #-} +newtype HappyWrap163 = HappyWrap163 (LHsSigType GhcPs) +happyIn163 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) +happyIn163 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap163 x) +{-# INLINE happyIn163 #-} +happyOut163 :: (HappyAbsSyn ) -> HappyWrap163 +happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut163 #-} +newtype HappyWrap164 = HappyWrap164 (Located [LocatedN RdrName]) +happyIn164 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn164 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap164 x) +{-# INLINE happyIn164 #-} +happyOut164 :: (HappyAbsSyn ) -> HappyWrap164 +happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut164 #-} +newtype HappyWrap165 = HappyWrap165 (Located (OrdList (LHsSigType GhcPs))) +happyIn165 :: (Located (OrdList (LHsSigType GhcPs))) -> (HappyAbsSyn ) +happyIn165 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap165 x) +{-# INLINE happyIn165 #-} +happyOut165 :: (HappyAbsSyn ) -> HappyWrap165 +happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut165 #-} +newtype HappyWrap166 = HappyWrap166 (Located UnpackednessPragma) +happyIn166 :: (Located UnpackednessPragma) -> (HappyAbsSyn ) +happyIn166 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap166 x) +{-# INLINE happyIn166 #-} +happyOut166 :: (HappyAbsSyn ) -> HappyWrap166 +happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut166 #-} +newtype HappyWrap167 = HappyWrap167 (Located (HsForAllTelescope GhcPs)) +happyIn167 :: (Located (HsForAllTelescope GhcPs)) -> (HappyAbsSyn ) +happyIn167 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap167 x) +{-# INLINE happyIn167 #-} +happyOut167 :: (HappyAbsSyn ) -> HappyWrap167 +happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut167 #-} +newtype HappyWrap168 = HappyWrap168 (LHsType GhcPs) +happyIn168 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn168 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap168 x) +{-# INLINE happyIn168 #-} +happyOut168 :: (HappyAbsSyn ) -> HappyWrap168 +happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut168 #-} +newtype HappyWrap169 = HappyWrap169 (LHsType GhcPs) +happyIn169 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn169 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap169 x) +{-# INLINE happyIn169 #-} +happyOut169 :: (HappyAbsSyn ) -> HappyWrap169 +happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut169 #-} +newtype HappyWrap170 = HappyWrap170 (LHsContext GhcPs) +happyIn170 :: (LHsContext GhcPs) -> (HappyAbsSyn ) +happyIn170 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap170 x) +{-# INLINE happyIn170 #-} +happyOut170 :: (HappyAbsSyn ) -> HappyWrap170 +happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut170 #-} +newtype HappyWrap171 = HappyWrap171 (forall b. DisambECP b => PV (LocatedC [LocatedA b])) +happyIn171 :: (forall b. DisambECP b => PV (LocatedC [LocatedA b])) -> (HappyAbsSyn ) +happyIn171 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap171 x) +{-# INLINE happyIn171 #-} +happyOut171 :: (HappyAbsSyn ) -> HappyWrap171 +happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut171 #-} +newtype HappyWrap172 = HappyWrap172 (LHsType GhcPs) +happyIn172 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn172 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap172 x) +{-# INLINE happyIn172 #-} +happyOut172 :: (HappyAbsSyn ) -> HappyWrap172 +happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut172 #-} +newtype HappyWrap173 = HappyWrap173 (Located (EpUniToken "->" "\8594" -> HsMultAnn GhcPs)) +happyIn173 :: (Located (EpUniToken "->" "\8594" -> HsMultAnn GhcPs)) -> (HappyAbsSyn ) +happyIn173 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap173 x) +{-# INLINE happyIn173 #-} +happyOut173 :: (HappyAbsSyn ) -> HappyWrap173 +happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut173 #-} +newtype HappyWrap174 = HappyWrap174 (forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsMultAnnOf (LocatedA b) GhcPs))) +happyIn174 :: (forall b. DisambECP b => PV (Located (EpUniToken "->" "\8594" -> HsMultAnnOf (LocatedA b) GhcPs))) -> (HappyAbsSyn ) +happyIn174 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap174 x) +{-# INLINE happyIn174 #-} +happyOut174 :: (HappyAbsSyn ) -> HappyWrap174 +happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut174 #-} +newtype HappyWrap175 = HappyWrap175 (LHsType GhcPs) +happyIn175 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn175 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap175 x) +{-# INLINE happyIn175 #-} +happyOut175 :: (HappyAbsSyn ) -> HappyWrap175 +happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut175 #-} +newtype HappyWrap176 = HappyWrap176 (forall b. DisambTD b => PV (LocatedA b)) +happyIn176 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn ) +happyIn176 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap176 x) +{-# INLINE happyIn176 #-} +happyOut176 :: (HappyAbsSyn ) -> HappyWrap176 +happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut176 #-} +newtype HappyWrap177 = HappyWrap177 (forall b. DisambTD b => PV (LocatedA b)) +happyIn177 :: (forall b. DisambTD b => PV (LocatedA b)) -> (HappyAbsSyn ) +happyIn177 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap177 x) +{-# INLINE happyIn177 #-} +happyOut177 :: (HappyAbsSyn ) -> HappyWrap177 +happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut177 #-} +newtype HappyWrap178 = HappyWrap178 (LHsType GhcPs) +happyIn178 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn178 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap178 x) +{-# INLINE happyIn178 #-} +happyOut178 :: (HappyAbsSyn ) -> HappyWrap178 +happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut178 #-} +newtype HappyWrap179 = HappyWrap179 ((LocatedN RdrName, PromotionFlag)) +happyIn179 :: ((LocatedN RdrName, PromotionFlag)) -> (HappyAbsSyn ) +happyIn179 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap179 x) +{-# INLINE happyIn179 #-} +happyOut179 :: (HappyAbsSyn ) -> HappyWrap179 +happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut179 #-} +newtype HappyWrap180 = HappyWrap180 (LHsType GhcPs) +happyIn180 :: (LHsType GhcPs) -> (HappyAbsSyn ) +happyIn180 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap180 x) +{-# INLINE happyIn180 #-} +happyOut180 :: (HappyAbsSyn ) -> HappyWrap180 +happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut180 #-} +newtype HappyWrap181 = HappyWrap181 (LHsSigType GhcPs) +happyIn181 :: (LHsSigType GhcPs) -> (HappyAbsSyn ) +happyIn181 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap181 x) +{-# INLINE happyIn181 #-} +happyOut181 :: (HappyAbsSyn ) -> HappyWrap181 +happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut181 #-} +newtype HappyWrap182 = HappyWrap182 ([LHsSigType GhcPs]) +happyIn182 :: ([LHsSigType GhcPs]) -> (HappyAbsSyn ) +happyIn182 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap182 x) +{-# INLINE happyIn182 #-} +happyOut182 :: (HappyAbsSyn ) -> HappyWrap182 +happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut182 #-} +newtype HappyWrap183 = HappyWrap183 ([LHsType GhcPs]) +happyIn183 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) +happyIn183 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap183 x) +{-# INLINE happyIn183 #-} +happyOut183 :: (HappyAbsSyn ) -> HappyWrap183 +happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut183 #-} +newtype HappyWrap184 = HappyWrap184 ([LHsType GhcPs]) +happyIn184 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) +happyIn184 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap184 x) +{-# INLINE happyIn184 #-} +happyOut184 :: (HappyAbsSyn ) -> HappyWrap184 +happyOut184 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut184 #-} +newtype HappyWrap185 = HappyWrap185 ([LHsType GhcPs]) +happyIn185 :: ([LHsType GhcPs]) -> (HappyAbsSyn ) +happyIn185 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap185 x) +{-# INLINE happyIn185 #-} +happyOut185 :: (HappyAbsSyn ) -> HappyWrap185 +happyOut185 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut185 #-} +newtype HappyWrap186 = HappyWrap186 ([LHsTyVarBndr Specificity GhcPs]) +happyIn186 :: ([LHsTyVarBndr Specificity GhcPs]) -> (HappyAbsSyn ) +happyIn186 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap186 x) +{-# INLINE happyIn186 #-} +happyOut186 :: (HappyAbsSyn ) -> HappyWrap186 +happyOut186 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut186 #-} +newtype HappyWrap187 = HappyWrap187 (LHsTyVarBndr Specificity GhcPs) +happyIn187 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn ) +happyIn187 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap187 x) +{-# INLINE happyIn187 #-} +happyOut187 :: (HappyAbsSyn ) -> HappyWrap187 +happyOut187 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut187 #-} +newtype HappyWrap188 = HappyWrap188 (LHsTyVarBndr Specificity GhcPs) +happyIn188 :: (LHsTyVarBndr Specificity GhcPs) -> (HappyAbsSyn ) +happyIn188 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap188 x) +{-# INLINE happyIn188 #-} +happyOut188 :: (HappyAbsSyn ) -> HappyWrap188 +happyOut188 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut188 #-} +newtype HappyWrap189 = HappyWrap189 (Located (HsBndrVar GhcPs)) +happyIn189 :: (Located (HsBndrVar GhcPs)) -> (HappyAbsSyn ) +happyIn189 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap189 x) +{-# INLINE happyIn189 #-} +happyOut189 :: (HappyAbsSyn ) -> HappyWrap189 +happyOut189 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut189 #-} +newtype HappyWrap190 = HappyWrap190 (Located (EpToken "|",[LHsFunDep GhcPs])) +happyIn190 :: (Located (EpToken "|",[LHsFunDep GhcPs])) -> (HappyAbsSyn ) +happyIn190 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap190 x) +{-# INLINE happyIn190 #-} +happyOut190 :: (HappyAbsSyn ) -> HappyWrap190 +happyOut190 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut190 #-} +newtype HappyWrap191 = HappyWrap191 (Located [LHsFunDep GhcPs]) +happyIn191 :: (Located [LHsFunDep GhcPs]) -> (HappyAbsSyn ) +happyIn191 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap191 x) +{-# INLINE happyIn191 #-} +happyOut191 :: (HappyAbsSyn ) -> HappyWrap191 +happyOut191 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut191 #-} +newtype HappyWrap192 = HappyWrap192 (LHsFunDep GhcPs) +happyIn192 :: (LHsFunDep GhcPs) -> (HappyAbsSyn ) +happyIn192 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap192 x) +{-# INLINE happyIn192 #-} +happyOut192 :: (HappyAbsSyn ) -> HappyWrap192 +happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut192 #-} +newtype HappyWrap193 = HappyWrap193 (Located [LocatedN RdrName]) +happyIn193 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn193 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap193 x) +{-# INLINE happyIn193 #-} +happyOut193 :: (HappyAbsSyn ) -> HappyWrap193 +happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut193 #-} +newtype HappyWrap194 = HappyWrap194 (LHsKind GhcPs) +happyIn194 :: (LHsKind GhcPs) -> (HappyAbsSyn ) +happyIn194 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap194 x) +{-# INLINE happyIn194 #-} +happyOut194 :: (HappyAbsSyn ) -> HappyWrap194 +happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut194 #-} +newtype HappyWrap195 = HappyWrap195 (Located ((EpToken "where", EpToken "{", EpToken "}") + ,[LConDecl GhcPs])) +happyIn195 :: (Located ((EpToken "where", EpToken "{", EpToken "}") + ,[LConDecl GhcPs])) -> (HappyAbsSyn ) +happyIn195 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap195 x) +{-# INLINE happyIn195 #-} +happyOut195 :: (HappyAbsSyn ) -> HappyWrap195 +happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut195 #-} +newtype HappyWrap196 = HappyWrap196 (Located [LConDecl GhcPs]) +happyIn196 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) +happyIn196 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap196 x) +{-# INLINE happyIn196 #-} +happyOut196 :: (HappyAbsSyn ) -> HappyWrap196 +happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut196 #-} +newtype HappyWrap197 = HappyWrap197 (LConDecl GhcPs) +happyIn197 :: (LConDecl GhcPs) -> (HappyAbsSyn ) +happyIn197 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap197 x) +{-# INLINE happyIn197 #-} +happyOut197 :: (HappyAbsSyn ) -> HappyWrap197 +happyOut197 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut197 #-} +newtype HappyWrap198 = HappyWrap198 (Located (EpToken "=",[LConDecl GhcPs])) +happyIn198 :: (Located (EpToken "=",[LConDecl GhcPs])) -> (HappyAbsSyn ) +happyIn198 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap198 x) +{-# INLINE happyIn198 #-} +happyOut198 :: (HappyAbsSyn ) -> HappyWrap198 +happyOut198 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut198 #-} +newtype HappyWrap199 = HappyWrap199 (Located [LConDecl GhcPs]) +happyIn199 :: (Located [LConDecl GhcPs]) -> (HappyAbsSyn ) +happyIn199 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap199 x) +{-# INLINE happyIn199 #-} +happyOut199 :: (HappyAbsSyn ) -> HappyWrap199 +happyOut199 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut199 #-} +newtype HappyWrap200 = HappyWrap200 (LConDecl GhcPs) +happyIn200 :: (LConDecl GhcPs) -> (HappyAbsSyn ) +happyIn200 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap200 x) +{-# INLINE happyIn200 #-} +happyOut200 :: (HappyAbsSyn ) -> HappyWrap200 +happyOut200 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut200 #-} +newtype HappyWrap201 = HappyWrap201 (Located ((TokForall, EpToken "."), Maybe [LHsTyVarBndr Specificity GhcPs])) +happyIn201 :: (Located ((TokForall, EpToken "."), Maybe [LHsTyVarBndr Specificity GhcPs])) -> (HappyAbsSyn ) +happyIn201 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap201 x) +{-# INLINE happyIn201 #-} +happyOut201 :: (HappyAbsSyn ) -> HappyWrap201 +happyOut201 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut201 #-} +newtype HappyWrap202 = HappyWrap202 (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) +happyIn202 :: (Located (LocatedN RdrName, HsConDeclH98Details GhcPs)) -> (HappyAbsSyn ) +happyIn202 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap202 x) +{-# INLINE happyIn202 #-} +happyOut202 :: (HappyAbsSyn ) -> HappyWrap202 +happyOut202 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut202 #-} +newtype HappyWrap203 = HappyWrap203 ((LHsType GhcPs, Int, Int)) +happyIn203 :: ((LHsType GhcPs, Int, Int)) -> (HappyAbsSyn ) +happyIn203 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap203 x) +{-# INLINE happyIn203 #-} +happyOut203 :: (HappyAbsSyn ) -> HappyWrap203 +happyOut203 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut203 #-} +newtype HappyWrap204 = HappyWrap204 ([LHsConDeclRecField GhcPs]) +happyIn204 :: ([LHsConDeclRecField GhcPs]) -> (HappyAbsSyn ) +happyIn204 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap204 x) +{-# INLINE happyIn204 #-} +happyOut204 :: (HappyAbsSyn ) -> HappyWrap204 +happyOut204 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut204 #-} +newtype HappyWrap205 = HappyWrap205 ([LHsConDeclRecField GhcPs]) +happyIn205 :: ([LHsConDeclRecField GhcPs]) -> (HappyAbsSyn ) +happyIn205 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap205 x) +{-# INLINE happyIn205 #-} +happyOut205 :: (HappyAbsSyn ) -> HappyWrap205 +happyOut205 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut205 #-} +newtype HappyWrap206 = HappyWrap206 (LHsConDeclRecField GhcPs) +happyIn206 :: (LHsConDeclRecField GhcPs) -> (HappyAbsSyn ) +happyIn206 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap206 x) +{-# INLINE happyIn206 #-} +happyOut206 :: (HappyAbsSyn ) -> HappyWrap206 +happyOut206 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut206 #-} +newtype HappyWrap207 = HappyWrap207 (Located (HsDeriving GhcPs)) +happyIn207 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn ) +happyIn207 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap207 x) +{-# INLINE happyIn207 #-} +happyOut207 :: (HappyAbsSyn ) -> HappyWrap207 +happyOut207 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut207 #-} +newtype HappyWrap208 = HappyWrap208 (Located (HsDeriving GhcPs)) +happyIn208 :: (Located (HsDeriving GhcPs)) -> (HappyAbsSyn ) +happyIn208 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap208 x) +{-# INLINE happyIn208 #-} +happyOut208 :: (HappyAbsSyn ) -> HappyWrap208 +happyOut208 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut208 #-} +newtype HappyWrap209 = HappyWrap209 (LHsDerivingClause GhcPs) +happyIn209 :: (LHsDerivingClause GhcPs) -> (HappyAbsSyn ) +happyIn209 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap209 x) +{-# INLINE happyIn209 #-} +happyOut209 :: (HappyAbsSyn ) -> HappyWrap209 +happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut209 #-} +newtype HappyWrap210 = HappyWrap210 (LDerivClauseTys GhcPs) +happyIn210 :: (LDerivClauseTys GhcPs) -> (HappyAbsSyn ) +happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x) +{-# INLINE happyIn210 #-} +happyOut210 :: (HappyAbsSyn ) -> HappyWrap210 +happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut210 #-} +newtype HappyWrap211 = HappyWrap211 (LHsDecl GhcPs) +happyIn211 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn211 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap211 x) +{-# INLINE happyIn211 #-} +happyOut211 :: (HappyAbsSyn ) -> HappyWrap211 +happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut211 #-} +newtype HappyWrap212 = HappyWrap212 (LHsDecl GhcPs) +happyIn212 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn212 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap212 x) +{-# INLINE happyIn212 #-} +happyOut212 :: (HappyAbsSyn ) -> HappyWrap212 +happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut212 #-} +newtype HappyWrap213 = HappyWrap213 (Located (GRHSs GhcPs (LHsExpr GhcPs))) +happyIn213 :: (Located (GRHSs GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) +happyIn213 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap213 x) +{-# INLINE happyIn213 #-} +happyOut213 :: (HappyAbsSyn ) -> HappyWrap213 +happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut213 #-} +newtype HappyWrap214 = HappyWrap214 (Located (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) +happyIn214 :: (Located (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) -> (HappyAbsSyn ) +happyIn214 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap214 x) +{-# INLINE happyIn214 #-} +happyOut214 :: (HappyAbsSyn ) -> HappyWrap214 +happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut214 #-} +newtype HappyWrap215 = HappyWrap215 (LGRHS GhcPs (LHsExpr GhcPs)) +happyIn215 :: (LGRHS GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) +happyIn215 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap215 x) +{-# INLINE happyIn215 #-} +happyOut215 :: (HappyAbsSyn ) -> HappyWrap215 +happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut215 #-} +newtype HappyWrap216 = HappyWrap216 (LHsDecl GhcPs) +happyIn216 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) +happyIn216 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap216 x) +{-# INLINE happyIn216 #-} +happyOut216 :: (HappyAbsSyn ) -> HappyWrap216 +happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut216 #-} +newtype HappyWrap217 = HappyWrap217 (Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))) +happyIn217 :: (Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs)))) -> (HappyAbsSyn ) +happyIn217 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap217 x) +{-# INLINE happyIn217 #-} +happyOut217 :: (HappyAbsSyn ) -> HappyWrap217 +happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut217 #-} +newtype HappyWrap218 = HappyWrap218 ((ActivationAnn,Maybe Activation)) +happyIn218 :: ((ActivationAnn,Maybe Activation)) -> (HappyAbsSyn ) +happyIn218 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap218 x) +{-# INLINE happyIn218 #-} +happyOut218 :: (HappyAbsSyn ) -> HappyWrap218 +happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut218 #-} +newtype HappyWrap219 = HappyWrap219 ((ActivationAnn, Activation)) +happyIn219 :: ((ActivationAnn, Activation)) -> (HappyAbsSyn ) +happyIn219 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap219 x) +{-# INLINE happyIn219 #-} +happyOut219 :: (HappyAbsSyn ) -> HappyWrap219 +happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut219 #-} +newtype HappyWrap220 = HappyWrap220 (Located (HsUntypedSplice GhcPs)) +happyIn220 :: (Located (HsUntypedSplice GhcPs)) -> (HappyAbsSyn ) +happyIn220 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap220 x) +{-# INLINE happyIn220 #-} +happyOut220 :: (HappyAbsSyn ) -> HappyWrap220 +happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut220 #-} +newtype HappyWrap221 = HappyWrap221 (ECP) +happyIn221 :: (ECP) -> (HappyAbsSyn ) +happyIn221 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap221 x) +{-# INLINE happyIn221 #-} +happyOut221 :: (HappyAbsSyn ) -> HappyWrap221 +happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut221 #-} +newtype HappyWrap222 = HappyWrap222 (ECP) +happyIn222 :: (ECP) -> (HappyAbsSyn ) +happyIn222 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap222 x) +{-# INLINE happyIn222 #-} +happyOut222 :: (HappyAbsSyn ) -> HappyWrap222 +happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut222 #-} +newtype HappyWrap223 = HappyWrap223 (ECP) +happyIn223 :: (ECP) -> (HappyAbsSyn ) +happyIn223 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap223 x) +{-# INLINE happyIn223 #-} +happyOut223 :: (HappyAbsSyn ) -> HappyWrap223 +happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut223 #-} +newtype HappyWrap224 = HappyWrap224 (ECP) +happyIn224 :: (ECP) -> (HappyAbsSyn ) +happyIn224 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap224 x) +{-# INLINE happyIn224 #-} +happyOut224 :: (HappyAbsSyn ) -> HappyWrap224 +happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut224 #-} +newtype HappyWrap225 = HappyWrap225 (ECP) +happyIn225 :: (ECP) -> (HappyAbsSyn ) +happyIn225 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap225 x) +{-# INLINE happyIn225 #-} +happyOut225 :: (HappyAbsSyn ) -> HappyWrap225 +happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut225 #-} +newtype HappyWrap226 = HappyWrap226 (ECP) +happyIn226 :: (ECP) -> (HappyAbsSyn ) +happyIn226 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap226 x) +{-# INLINE happyIn226 #-} +happyOut226 :: (HappyAbsSyn ) -> HappyWrap226 +happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut226 #-} +newtype HappyWrap227 = HappyWrap227 ((Maybe (EpToken ";"),Bool)) +happyIn227 :: ((Maybe (EpToken ";"),Bool)) -> (HappyAbsSyn ) +happyIn227 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap227 x) +{-# INLINE happyIn227 #-} +happyOut227 :: (HappyAbsSyn ) -> HappyWrap227 +happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut227 #-} +newtype HappyWrap228 = HappyWrap228 (Located (HsPragE GhcPs)) +happyIn228 :: (Located (HsPragE GhcPs)) -> (HappyAbsSyn ) +happyIn228 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap228 x) +{-# INLINE happyIn228 #-} +happyOut228 :: (HappyAbsSyn ) -> HappyWrap228 +happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut228 #-} +newtype HappyWrap229 = HappyWrap229 (ECP) +happyIn229 :: (ECP) -> (HappyAbsSyn ) +happyIn229 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap229 x) +{-# INLINE happyIn229 #-} +happyOut229 :: (HappyAbsSyn ) -> HappyWrap229 +happyOut229 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut229 #-} +newtype HappyWrap230 = HappyWrap230 (ECP) +happyIn230 :: (ECP) -> (HappyAbsSyn ) +happyIn230 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap230 x) +{-# INLINE happyIn230 #-} +happyOut230 :: (HappyAbsSyn ) -> HappyWrap230 +happyOut230 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut230 #-} +newtype HappyWrap231 = HappyWrap231 (ECP) +happyIn231 :: (ECP) -> (HappyAbsSyn ) +happyIn231 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap231 x) +{-# INLINE happyIn231 #-} +happyOut231 :: (HappyAbsSyn ) -> HappyWrap231 +happyOut231 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut231 #-} +newtype HappyWrap232 = HappyWrap232 (ECP) +happyIn232 :: (ECP) -> (HappyAbsSyn ) +happyIn232 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap232 x) +{-# INLINE happyIn232 #-} +happyOut232 :: (HappyAbsSyn ) -> HappyWrap232 +happyOut232 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut232 #-} +newtype HappyWrap233 = HappyWrap233 (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) +happyIn233 :: (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -> (HappyAbsSyn ) +happyIn233 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap233 x) +{-# INLINE happyIn233 #-} +happyOut233 :: (HappyAbsSyn ) -> HappyWrap233 +happyOut233 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut233 #-} +newtype HappyWrap234 = HappyWrap234 (LHsExpr GhcPs) +happyIn234 :: (LHsExpr GhcPs) -> (HappyAbsSyn ) +happyIn234 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap234 x) +{-# INLINE happyIn234 #-} +happyOut234 :: (HappyAbsSyn ) -> HappyWrap234 +happyOut234 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut234 #-} +newtype HappyWrap235 = HappyWrap235 (Located (HsUntypedSplice GhcPs)) +happyIn235 :: (Located (HsUntypedSplice GhcPs)) -> (HappyAbsSyn ) +happyIn235 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap235 x) +{-# INLINE happyIn235 #-} +happyOut235 :: (HappyAbsSyn ) -> HappyWrap235 +happyOut235 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut235 #-} +newtype HappyWrap236 = HappyWrap236 (Located (HsTypedSplice GhcPs)) +happyIn236 :: (Located (HsTypedSplice GhcPs)) -> (HappyAbsSyn ) +happyIn236 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap236 x) +{-# INLINE happyIn236 #-} +happyOut236 :: (HappyAbsSyn ) -> HappyWrap236 +happyOut236 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut236 #-} +newtype HappyWrap237 = HappyWrap237 ([LHsCmdTop GhcPs]) +happyIn237 :: ([LHsCmdTop GhcPs]) -> (HappyAbsSyn ) +happyIn237 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap237 x) +{-# INLINE happyIn237 #-} +happyOut237 :: (HappyAbsSyn ) -> HappyWrap237 +happyOut237 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut237 #-} +newtype HappyWrap238 = HappyWrap238 (LHsCmdTop GhcPs) +happyIn238 :: (LHsCmdTop GhcPs) -> (HappyAbsSyn ) +happyIn238 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap238 x) +{-# INLINE happyIn238 #-} +happyOut238 :: (HappyAbsSyn ) -> HappyWrap238 +happyOut238 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut238 #-} +newtype HappyWrap239 = HappyWrap239 (((EpToken "{", EpToken "}"),[LHsDecl GhcPs])) +happyIn239 :: (((EpToken "{", EpToken "}"),[LHsDecl GhcPs])) -> (HappyAbsSyn ) +happyIn239 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap239 x) +{-# INLINE happyIn239 #-} +happyOut239 :: (HappyAbsSyn ) -> HappyWrap239 +happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut239 #-} +newtype HappyWrap240 = HappyWrap240 ([LHsDecl GhcPs]) +happyIn240 :: ([LHsDecl GhcPs]) -> (HappyAbsSyn ) +happyIn240 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap240 x) +{-# INLINE happyIn240 #-} +happyOut240 :: (HappyAbsSyn ) -> HappyWrap240 +happyOut240 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut240 #-} +newtype HappyWrap241 = HappyWrap241 (ECP) +happyIn241 :: (ECP) -> (HappyAbsSyn ) +happyIn241 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap241 x) +{-# INLINE happyIn241 #-} +happyOut241 :: (HappyAbsSyn ) -> HappyWrap241 +happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut241 #-} +newtype HappyWrap242 = HappyWrap242 (forall b. DisambECP b => PV (SumOrTuple b)) +happyIn242 :: (forall b. DisambECP b => PV (SumOrTuple b)) -> (HappyAbsSyn ) +happyIn242 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap242 x) +{-# INLINE happyIn242 #-} +happyOut242 :: (HappyAbsSyn ) -> HappyWrap242 +happyOut242 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut242 #-} +newtype HappyWrap243 = HappyWrap243 (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)])) +happyIn243 :: (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)])) -> (HappyAbsSyn ) +happyIn243 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap243 x) +{-# INLINE happyIn243 #-} +happyOut243 :: (HappyAbsSyn ) -> HappyWrap243 +happyOut243 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut243 #-} +newtype HappyWrap244 = HappyWrap244 (forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)]) +happyIn244 :: (forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)]) -> (HappyAbsSyn ) +happyIn244 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap244 x) +{-# INLINE happyIn244 #-} +happyOut244 :: (HappyAbsSyn ) -> HappyWrap244 +happyOut244 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut244 #-} +newtype HappyWrap245 = HappyWrap245 (forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b)) +happyIn245 :: (forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV (LocatedA b)) -> (HappyAbsSyn ) +happyIn245 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap245 x) +{-# INLINE happyIn245 #-} +happyOut245 :: (HappyAbsSyn ) -> HappyWrap245 +happyOut245 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut245 #-} +newtype HappyWrap246 = HappyWrap246 (forall b. DisambECP b => PV [LocatedA b]) +happyIn246 :: (forall b. DisambECP b => PV [LocatedA b]) -> (HappyAbsSyn ) +happyIn246 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap246 x) +{-# INLINE happyIn246 #-} +happyOut246 :: (HappyAbsSyn ) -> HappyWrap246 +happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut246 #-} +newtype HappyWrap247 = HappyWrap247 (Located [LStmt GhcPs (LHsExpr GhcPs)]) +happyIn247 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) +happyIn247 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap247 x) +{-# INLINE happyIn247 #-} +happyOut247 :: (HappyAbsSyn ) -> HappyWrap247 +happyOut247 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut247 #-} +newtype HappyWrap248 = HappyWrap248 (Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)])) +happyIn248 :: (Located (NonEmpty [LStmt GhcPs (LHsExpr GhcPs)])) -> (HappyAbsSyn ) +happyIn248 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap248 x) +{-# INLINE happyIn248 #-} +happyOut248 :: (HappyAbsSyn ) -> HappyWrap248 +happyOut248 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut248 #-} +newtype HappyWrap249 = HappyWrap249 (Located (NonEmpty (LStmt GhcPs (LHsExpr GhcPs)))) +happyIn249 :: (Located (NonEmpty (LStmt GhcPs (LHsExpr GhcPs)))) -> (HappyAbsSyn ) +happyIn249 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap249 x) +{-# INLINE happyIn249 #-} +happyOut249 :: (HappyAbsSyn ) -> HappyWrap249 +happyOut249 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut249 #-} +newtype HappyWrap250 = HappyWrap250 (Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) +happyIn250 :: (Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) +happyIn250 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap250 x) +{-# INLINE happyIn250 #-} +happyOut250 :: (HappyAbsSyn ) -> HappyWrap250 +happyOut250 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut250 #-} +newtype HappyWrap251 = HappyWrap251 (Located [LStmt GhcPs (LHsExpr GhcPs)]) +happyIn251 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) +happyIn251 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap251 x) +{-# INLINE happyIn251 #-} +happyOut251 :: (HappyAbsSyn ) -> HappyWrap251 +happyOut251 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut251 #-} +newtype HappyWrap252 = HappyWrap252 (Located [LStmt GhcPs (LHsExpr GhcPs)]) +happyIn252 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (HappyAbsSyn ) +happyIn252 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap252 x) +{-# INLINE happyIn252 #-} +happyOut252 :: (HappyAbsSyn ) -> HappyWrap252 +happyOut252 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut252 #-} +newtype HappyWrap253 = HappyWrap253 (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) +happyIn253 :: (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -> (HappyAbsSyn ) +happyIn253 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap253 x) +{-# INLINE happyIn253 #-} +happyOut253 :: (HappyAbsSyn ) -> HappyWrap253 +happyOut253 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut253 #-} +newtype HappyWrap254 = HappyWrap254 (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) +happyIn254 :: (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) -> (HappyAbsSyn ) +happyIn254 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap254 x) +{-# INLINE happyIn254 #-} +happyOut254 :: (HappyAbsSyn ) -> HappyWrap254 +happyOut254 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut254 #-} +newtype HappyWrap255 = HappyWrap255 (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) +happyIn255 :: (forall b. DisambECP b => PV (Located (NonEmpty (LGRHS GhcPs (LocatedA b))))) -> (HappyAbsSyn ) +happyIn255 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap255 x) +{-# INLINE happyIn255 #-} +happyOut255 :: (HappyAbsSyn ) -> HappyWrap255 +happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut255 #-} +newtype HappyWrap256 = HappyWrap256 (Located ((EpToken "{", EpToken "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) +happyIn256 :: (Located ((EpToken "{", EpToken "}"), NonEmpty (LGRHS GhcPs (LHsExpr GhcPs)))) -> (HappyAbsSyn ) +happyIn256 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap256 x) +{-# INLINE happyIn256 #-} +happyOut256 :: (HappyAbsSyn ) -> HappyWrap256 +happyOut256 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut256 #-} +newtype HappyWrap257 = HappyWrap257 (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) +happyIn257 :: (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn257 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap257 x) +{-# INLINE happyIn257 #-} +happyOut257 :: (HappyAbsSyn ) -> HappyWrap257 +happyOut257 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut257 #-} +newtype HappyWrap258 = HappyWrap258 (LPat GhcPs) +happyIn258 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn258 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap258 x) +{-# INLINE happyIn258 #-} +happyOut258 :: (HappyAbsSyn ) -> HappyWrap258 +happyOut258 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut258 #-} +newtype HappyWrap259 = HappyWrap259 (LPat GhcPs) +happyIn259 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn259 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap259 x) +{-# INLINE happyIn259 #-} +happyOut259 :: (HappyAbsSyn ) -> HappyWrap259 +happyOut259 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut259 #-} +newtype HappyWrap260 = HappyWrap260 ([LPat GhcPs]) +happyIn260 :: ([LPat GhcPs]) -> (HappyAbsSyn ) +happyIn260 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap260 x) +{-# INLINE happyIn260 #-} +happyOut260 :: (HappyAbsSyn ) -> HappyWrap260 +happyOut260 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut260 #-} +newtype HappyWrap261 = HappyWrap261 (LPat GhcPs) +happyIn261 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn261 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap261 x) +{-# INLINE happyIn261 #-} +happyOut261 :: (HappyAbsSyn ) -> HappyWrap261 +happyOut261 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut261 #-} +newtype HappyWrap262 = HappyWrap262 (LPat GhcPs) +happyIn262 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn262 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap262 x) +{-# INLINE happyIn262 #-} +happyOut262 :: (HappyAbsSyn ) -> HappyWrap262 +happyOut262 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut262 #-} +newtype HappyWrap263 = HappyWrap263 ([LPat GhcPs]) +happyIn263 :: ([LPat GhcPs]) -> (HappyAbsSyn ) +happyIn263 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap263 x) +{-# INLINE happyIn263 #-} +happyOut263 :: (HappyAbsSyn ) -> HappyWrap263 +happyOut263 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut263 #-} +newtype HappyWrap264 = HappyWrap264 (LPat GhcPs) +happyIn264 :: (LPat GhcPs) -> (HappyAbsSyn ) +happyIn264 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap264 x) +{-# INLINE happyIn264 #-} +happyOut264 :: (HappyAbsSyn ) -> HappyWrap264 +happyOut264 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut264 #-} +newtype HappyWrap265 = HappyWrap265 (forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))])) +happyIn265 :: (forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))])) -> (HappyAbsSyn ) +happyIn265 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap265 x) +{-# INLINE happyIn265 #-} +happyOut265 :: (HappyAbsSyn ) -> HappyWrap265 +happyOut265 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut265 #-} +newtype HappyWrap266 = HappyWrap266 (forall b. DisambECP b => PV (Located (OrdList (EpToken ";"),[LStmt GhcPs (LocatedA b)]))) +happyIn266 :: (forall b. DisambECP b => PV (Located (OrdList (EpToken ";"),[LStmt GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn266 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap266 x) +{-# INLINE happyIn266 #-} +happyOut266 :: (HappyAbsSyn ) -> HappyWrap266 +happyOut266 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut266 #-} +newtype HappyWrap267 = HappyWrap267 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) +happyIn267 :: (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -> (HappyAbsSyn ) +happyIn267 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap267 x) +{-# INLINE happyIn267 #-} +happyOut267 :: (HappyAbsSyn ) -> HappyWrap267 +happyOut267 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut267 #-} +newtype HappyWrap268 = HappyWrap268 (LStmt GhcPs (LHsExpr GhcPs)) +happyIn268 :: (LStmt GhcPs (LHsExpr GhcPs)) -> (HappyAbsSyn ) +happyIn268 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap268 x) +{-# INLINE happyIn268 #-} +happyOut268 :: (HappyAbsSyn ) -> HappyWrap268 +happyOut268 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut268 #-} +newtype HappyWrap269 = HappyWrap269 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) +happyIn269 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn269 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap269 x) +{-# INLINE happyIn269 #-} +happyOut269 :: (HappyAbsSyn ) -> HappyWrap269 +happyOut269 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut269 #-} +newtype HappyWrap270 = HappyWrap270 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) +happyIn270 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn270 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap270 x) +{-# INLINE happyIn270 #-} +happyOut270 :: (HappyAbsSyn ) -> HappyWrap270 +happyOut270 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut270 #-} +newtype HappyWrap271 = HappyWrap271 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) +happyIn271 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn ) +happyIn271 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap271 x) +{-# INLINE happyIn271 #-} +happyOut271 :: (HappyAbsSyn ) -> HappyWrap271 +happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut271 #-} +newtype HappyWrap272 = HappyWrap272 (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) +happyIn272 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (HappyAbsSyn ) +happyIn272 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap272 x) +{-# INLINE happyIn272 #-} +happyOut272 :: (HappyAbsSyn ) -> HappyWrap272 +happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut272 #-} +newtype HappyWrap273 = HappyWrap273 (forall b. DisambECP b => PV (Fbind b)) +happyIn273 :: (forall b. DisambECP b => PV (Fbind b)) -> (HappyAbsSyn ) +happyIn273 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap273 x) +{-# INLINE happyIn273 #-} +happyOut273 :: (HappyAbsSyn ) -> HappyWrap273 +happyOut273 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut273 #-} +newtype HappyWrap274 = HappyWrap274 (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) +happyIn274 :: (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -> (HappyAbsSyn ) +happyIn274 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap274 x) +{-# INLINE happyIn274 #-} +happyOut274 :: (HappyAbsSyn ) -> HappyWrap274 +happyOut274 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut274 #-} +newtype HappyWrap275 = HappyWrap275 (Located [LIPBind GhcPs]) +happyIn275 :: (Located [LIPBind GhcPs]) -> (HappyAbsSyn ) +happyIn275 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap275 x) +{-# INLINE happyIn275 #-} +happyOut275 :: (HappyAbsSyn ) -> HappyWrap275 +happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut275 #-} +newtype HappyWrap276 = HappyWrap276 (LIPBind GhcPs) +happyIn276 :: (LIPBind GhcPs) -> (HappyAbsSyn ) +happyIn276 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap276 x) +{-# INLINE happyIn276 #-} +happyOut276 :: (HappyAbsSyn ) -> HappyWrap276 +happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut276 #-} +newtype HappyWrap277 = HappyWrap277 (Located HsIPName) +happyIn277 :: (Located HsIPName) -> (HappyAbsSyn ) +happyIn277 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap277 x) +{-# INLINE happyIn277 #-} +happyOut277 :: (HappyAbsSyn ) -> HappyWrap277 +happyOut277 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut277 #-} +newtype HappyWrap278 = HappyWrap278 (Located (SourceText, FastString)) +happyIn278 :: (Located (SourceText, FastString)) -> (HappyAbsSyn ) +happyIn278 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap278 x) +{-# INLINE happyIn278 #-} +happyOut278 :: (HappyAbsSyn ) -> HappyWrap278 +happyOut278 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut278 #-} +newtype HappyWrap279 = HappyWrap279 (LBooleanFormula GhcPs) +happyIn279 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn279 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap279 x) +{-# INLINE happyIn279 #-} +happyOut279 :: (HappyAbsSyn ) -> HappyWrap279 +happyOut279 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut279 #-} +newtype HappyWrap280 = HappyWrap280 (LBooleanFormula GhcPs) +happyIn280 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn280 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap280 x) +{-# INLINE happyIn280 #-} +happyOut280 :: (HappyAbsSyn ) -> HappyWrap280 +happyOut280 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut280 #-} +newtype HappyWrap281 = HappyWrap281 (LBooleanFormula GhcPs) +happyIn281 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn281 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap281 x) +{-# INLINE happyIn281 #-} +happyOut281 :: (HappyAbsSyn ) -> HappyWrap281 +happyOut281 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut281 #-} +newtype HappyWrap282 = HappyWrap282 (NonEmpty (LBooleanFormula GhcPs)) +happyIn282 :: (NonEmpty (LBooleanFormula GhcPs)) -> (HappyAbsSyn ) +happyIn282 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap282 x) +{-# INLINE happyIn282 #-} +happyOut282 :: (HappyAbsSyn ) -> HappyWrap282 +happyOut282 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut282 #-} +newtype HappyWrap283 = HappyWrap283 (LBooleanFormula GhcPs) +happyIn283 :: (LBooleanFormula GhcPs) -> (HappyAbsSyn ) +happyIn283 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap283 x) +{-# INLINE happyIn283 #-} +happyOut283 :: (HappyAbsSyn ) -> HappyWrap283 +happyOut283 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut283 #-} +newtype HappyWrap284 = HappyWrap284 (Located [LocatedN RdrName]) +happyIn284 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn284 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap284 x) +{-# INLINE happyIn284 #-} +happyOut284 :: (HappyAbsSyn ) -> HappyWrap284 +happyOut284 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut284 #-} +newtype HappyWrap285 = HappyWrap285 (LocatedN RdrName) +happyIn285 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn285 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap285 x) +{-# INLINE happyIn285 #-} +happyOut285 :: (HappyAbsSyn ) -> HappyWrap285 +happyOut285 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut285 #-} +newtype HappyWrap286 = HappyWrap286 (LocatedN RdrName) +happyIn286 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn286 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap286 x) +{-# INLINE happyIn286 #-} +happyOut286 :: (HappyAbsSyn ) -> HappyWrap286 +happyOut286 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut286 #-} +newtype HappyWrap287 = HappyWrap287 (LocatedN RdrName) +happyIn287 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn287 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap287 x) +{-# INLINE happyIn287 #-} +happyOut287 :: (HappyAbsSyn ) -> HappyWrap287 +happyOut287 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut287 #-} +newtype HappyWrap288 = HappyWrap288 (LocatedN RdrName) +happyIn288 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn288 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap288 x) +{-# INLINE happyIn288 #-} +happyOut288 :: (HappyAbsSyn ) -> HappyWrap288 +happyOut288 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut288 #-} +newtype HappyWrap289 = HappyWrap289 (Located (NonEmpty (LocatedN RdrName))) +happyIn289 :: (Located (NonEmpty (LocatedN RdrName))) -> (HappyAbsSyn ) +happyIn289 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap289 x) +{-# INLINE happyIn289 #-} +happyOut289 :: (HappyAbsSyn ) -> HappyWrap289 +happyOut289 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut289 #-} +newtype HappyWrap290 = HappyWrap290 ([LocatedN RdrName]) +happyIn290 :: ([LocatedN RdrName]) -> (HappyAbsSyn ) +happyIn290 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap290 x) +{-# INLINE happyIn290 #-} +happyOut290 :: (HappyAbsSyn ) -> HappyWrap290 +happyOut290 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut290 #-} +newtype HappyWrap291 = HappyWrap291 (LocatedN DataCon) +happyIn291 :: (LocatedN DataCon) -> (HappyAbsSyn ) +happyIn291 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap291 x) +{-# INLINE happyIn291 #-} +happyOut291 :: (HappyAbsSyn ) -> HappyWrap291 +happyOut291 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut291 #-} +newtype HappyWrap292 = HappyWrap292 (LocatedN RdrName) +happyIn292 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn292 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap292 x) +{-# INLINE happyIn292 #-} +happyOut292 :: (HappyAbsSyn ) -> HappyWrap292 +happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut292 #-} +newtype HappyWrap293 = HappyWrap293 (LocatedN DataCon) +happyIn293 :: (LocatedN DataCon) -> (HappyAbsSyn ) +happyIn293 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap293 x) +{-# INLINE happyIn293 #-} +happyOut293 :: (HappyAbsSyn ) -> HappyWrap293 +happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut293 #-} +newtype HappyWrap294 = HappyWrap294 (LocatedN RdrName) +happyIn294 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn294 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap294 x) +{-# INLINE happyIn294 #-} +happyOut294 :: (HappyAbsSyn ) -> HappyWrap294 +happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut294 #-} +newtype HappyWrap295 = HappyWrap295 (LocatedN RdrName) +happyIn295 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn295 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap295 x) +{-# INLINE happyIn295 #-} +happyOut295 :: (HappyAbsSyn ) -> HappyWrap295 +happyOut295 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut295 #-} +newtype HappyWrap296 = HappyWrap296 (LocatedN RdrName) +happyIn296 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn296 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap296 x) +{-# INLINE happyIn296 #-} +happyOut296 :: (HappyAbsSyn ) -> HappyWrap296 +happyOut296 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut296 #-} +newtype HappyWrap297 = HappyWrap297 (LocatedN RdrName) +happyIn297 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn297 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap297 x) +{-# INLINE happyIn297 #-} +happyOut297 :: (HappyAbsSyn ) -> HappyWrap297 +happyOut297 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut297 #-} +newtype HappyWrap298 = HappyWrap298 (LocatedN RdrName) +happyIn298 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn298 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap298 x) +{-# INLINE happyIn298 #-} +happyOut298 :: (HappyAbsSyn ) -> HappyWrap298 +happyOut298 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut298 #-} +newtype HappyWrap299 = HappyWrap299 (LocatedN RdrName) +happyIn299 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn299 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap299 x) +{-# INLINE happyIn299 #-} +happyOut299 :: (HappyAbsSyn ) -> HappyWrap299 +happyOut299 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut299 #-} +newtype HappyWrap300 = HappyWrap300 (LocatedN RdrName) +happyIn300 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn300 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap300 x) +{-# INLINE happyIn300 #-} +happyOut300 :: (HappyAbsSyn ) -> HappyWrap300 +happyOut300 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut300 #-} +newtype HappyWrap301 = HappyWrap301 (LocatedN RdrName) +happyIn301 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn301 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap301 x) +{-# INLINE happyIn301 #-} +happyOut301 :: (HappyAbsSyn ) -> HappyWrap301 +happyOut301 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut301 #-} +newtype HappyWrap302 = HappyWrap302 (LocatedN RdrName) +happyIn302 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn302 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap302 x) +{-# INLINE happyIn302 #-} +happyOut302 :: (HappyAbsSyn ) -> HappyWrap302 +happyOut302 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut302 #-} +newtype HappyWrap303 = HappyWrap303 (LocatedN RdrName) +happyIn303 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn303 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap303 x) +{-# INLINE happyIn303 #-} +happyOut303 :: (HappyAbsSyn ) -> HappyWrap303 +happyOut303 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut303 #-} +newtype HappyWrap304 = HappyWrap304 (LocatedN RdrName) +happyIn304 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn304 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap304 x) +{-# INLINE happyIn304 #-} +happyOut304 :: (HappyAbsSyn ) -> HappyWrap304 +happyOut304 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut304 #-} +newtype HappyWrap305 = HappyWrap305 (LocatedN RdrName) +happyIn305 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn305 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap305 x) +{-# INLINE happyIn305 #-} +happyOut305 :: (HappyAbsSyn ) -> HappyWrap305 +happyOut305 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut305 #-} +newtype HappyWrap306 = HappyWrap306 (LocatedN RdrName) +happyIn306 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn306 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap306 x) +{-# INLINE happyIn306 #-} +happyOut306 :: (HappyAbsSyn ) -> HappyWrap306 +happyOut306 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut306 #-} +newtype HappyWrap307 = HappyWrap307 (LocatedN RdrName) +happyIn307 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn307 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap307 x) +{-# INLINE happyIn307 #-} +happyOut307 :: (HappyAbsSyn ) -> HappyWrap307 +happyOut307 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut307 #-} +newtype HappyWrap308 = HappyWrap308 (forall b. DisambInfixOp b => PV (LocatedN b)) +happyIn308 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn ) +happyIn308 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap308 x) +{-# INLINE happyIn308 #-} +happyOut308 :: (HappyAbsSyn ) -> HappyWrap308 +happyOut308 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut308 #-} +newtype HappyWrap309 = HappyWrap309 (forall b. DisambInfixOp b => PV (LocatedN b)) +happyIn309 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (HappyAbsSyn ) +happyIn309 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap309 x) +{-# INLINE happyIn309 #-} +happyOut309 :: (HappyAbsSyn ) -> HappyWrap309 +happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut309 #-} +newtype HappyWrap310 = HappyWrap310 (LocatedN RdrName) +happyIn310 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn310 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap310 x) +{-# INLINE happyIn310 #-} +happyOut310 :: (HappyAbsSyn ) -> HappyWrap310 +happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut310 #-} +newtype HappyWrap311 = HappyWrap311 (LocatedN RdrName) +happyIn311 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn311 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap311 x) +{-# INLINE happyIn311 #-} +happyOut311 :: (HappyAbsSyn ) -> HappyWrap311 +happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut311 #-} +newtype HappyWrap312 = HappyWrap312 (LocatedN RdrName) +happyIn312 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn312 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap312 x) +{-# INLINE happyIn312 #-} +happyOut312 :: (HappyAbsSyn ) -> HappyWrap312 +happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut312 #-} +newtype HappyWrap313 = HappyWrap313 (LocatedN RdrName) +happyIn313 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn313 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap313 x) +{-# INLINE happyIn313 #-} +happyOut313 :: (HappyAbsSyn ) -> HappyWrap313 +happyOut313 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut313 #-} +newtype HappyWrap314 = HappyWrap314 (LocatedN RdrName) +happyIn314 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn314 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap314 x) +{-# INLINE happyIn314 #-} +happyOut314 :: (HappyAbsSyn ) -> HappyWrap314 +happyOut314 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut314 #-} +newtype HappyWrap315 = HappyWrap315 (LocatedN RdrName) +happyIn315 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn315 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap315 x) +{-# INLINE happyIn315 #-} +happyOut315 :: (HappyAbsSyn ) -> HappyWrap315 +happyOut315 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut315 #-} +newtype HappyWrap316 = HappyWrap316 (LocatedN RdrName) +happyIn316 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn316 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap316 x) +{-# INLINE happyIn316 #-} +happyOut316 :: (HappyAbsSyn ) -> HappyWrap316 +happyOut316 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut316 #-} +newtype HappyWrap317 = HappyWrap317 (LocatedN RdrName) +happyIn317 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn317 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap317 x) +{-# INLINE happyIn317 #-} +happyOut317 :: (HappyAbsSyn ) -> HappyWrap317 +happyOut317 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut317 #-} +newtype HappyWrap318 = HappyWrap318 (LocatedN FieldLabelString) +happyIn318 :: (LocatedN FieldLabelString) -> (HappyAbsSyn ) +happyIn318 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap318 x) +{-# INLINE happyIn318 #-} +happyOut318 :: (HappyAbsSyn ) -> HappyWrap318 +happyOut318 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut318 #-} +newtype HappyWrap319 = HappyWrap319 (LocatedN RdrName) +happyIn319 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn319 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap319 x) +{-# INLINE happyIn319 #-} +happyOut319 :: (HappyAbsSyn ) -> HappyWrap319 +happyOut319 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut319 #-} +newtype HappyWrap320 = HappyWrap320 (LocatedN RdrName) +happyIn320 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn320 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap320 x) +{-# INLINE happyIn320 #-} +happyOut320 :: (HappyAbsSyn ) -> HappyWrap320 +happyOut320 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut320 #-} +newtype HappyWrap321 = HappyWrap321 (LocatedN RdrName) +happyIn321 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn321 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap321 x) +{-# INLINE happyIn321 #-} +happyOut321 :: (HappyAbsSyn ) -> HappyWrap321 +happyOut321 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut321 #-} +newtype HappyWrap322 = HappyWrap322 (LocatedN RdrName) +happyIn322 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn322 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap322 x) +{-# INLINE happyIn322 #-} +happyOut322 :: (HappyAbsSyn ) -> HappyWrap322 +happyOut322 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut322 #-} +newtype HappyWrap323 = HappyWrap323 (LocatedN RdrName) +happyIn323 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn323 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap323 x) +{-# INLINE happyIn323 #-} +happyOut323 :: (HappyAbsSyn ) -> HappyWrap323 +happyOut323 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut323 #-} +newtype HappyWrap324 = HappyWrap324 (LocatedN RdrName) +happyIn324 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn324 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap324 x) +{-# INLINE happyIn324 #-} +happyOut324 :: (HappyAbsSyn ) -> HappyWrap324 +happyOut324 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut324 #-} +newtype HappyWrap325 = HappyWrap325 (LocatedN RdrName) +happyIn325 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn325 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap325 x) +{-# INLINE happyIn325 #-} +happyOut325 :: (HappyAbsSyn ) -> HappyWrap325 +happyOut325 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut325 #-} +newtype HappyWrap326 = HappyWrap326 (Located FastString) +happyIn326 :: (Located FastString) -> (HappyAbsSyn ) +happyIn326 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap326 x) +{-# INLINE happyIn326 #-} +happyOut326 :: (HappyAbsSyn ) -> HappyWrap326 +happyOut326 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut326 #-} +newtype HappyWrap327 = HappyWrap327 (Located FastString) +happyIn327 :: (Located FastString) -> (HappyAbsSyn ) +happyIn327 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap327 x) +{-# INLINE happyIn327 #-} +happyOut327 :: (HappyAbsSyn ) -> HappyWrap327 +happyOut327 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut327 #-} +newtype HappyWrap328 = HappyWrap328 (LocatedN RdrName) +happyIn328 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn328 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap328 x) +{-# INLINE happyIn328 #-} +happyOut328 :: (HappyAbsSyn ) -> HappyWrap328 +happyOut328 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut328 #-} +newtype HappyWrap329 = HappyWrap329 (LocatedN RdrName) +happyIn329 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn329 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap329 x) +{-# INLINE happyIn329 #-} +happyOut329 :: (HappyAbsSyn ) -> HappyWrap329 +happyOut329 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut329 #-} +newtype HappyWrap330 = HappyWrap330 (LocatedN RdrName) +happyIn330 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn330 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap330 x) +{-# INLINE happyIn330 #-} +happyOut330 :: (HappyAbsSyn ) -> HappyWrap330 +happyOut330 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut330 #-} +newtype HappyWrap331 = HappyWrap331 (LocatedN RdrName) +happyIn331 :: (LocatedN RdrName) -> (HappyAbsSyn ) +happyIn331 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap331 x) +{-# INLINE happyIn331 #-} +happyOut331 :: (HappyAbsSyn ) -> HappyWrap331 +happyOut331 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut331 #-} +newtype HappyWrap332 = HappyWrap332 (Located (HsLit GhcPs)) +happyIn332 :: (Located (HsLit GhcPs)) -> (HappyAbsSyn ) +happyIn332 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap332 x) +{-# INLINE happyIn332 #-} +happyOut332 :: (HappyAbsSyn ) -> HappyWrap332 +happyOut332 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut332 #-} +newtype HappyWrap333 = HappyWrap333 (()) +happyIn333 :: (()) -> (HappyAbsSyn ) +happyIn333 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap333 x) +{-# INLINE happyIn333 #-} +happyOut333 :: (HappyAbsSyn ) -> HappyWrap333 +happyOut333 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut333 #-} +newtype HappyWrap334 = HappyWrap334 (LocatedA ModuleName) +happyIn334 :: (LocatedA ModuleName) -> (HappyAbsSyn ) +happyIn334 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap334 x) +{-# INLINE happyIn334 #-} +happyOut334 :: (HappyAbsSyn ) -> HappyWrap334 +happyOut334 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut334 #-} +newtype HappyWrap335 = HappyWrap335 ((NonEmpty SrcSpan,Int)) +happyIn335 :: ((NonEmpty SrcSpan,Int)) -> (HappyAbsSyn ) +happyIn335 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap335 x) +{-# INLINE happyIn335 #-} +happyOut335 :: (HappyAbsSyn ) -> HappyWrap335 +happyOut335 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut335 #-} +newtype HappyWrap336 = HappyWrap336 (([EpToken "|"],Int)) +happyIn336 :: (([EpToken "|"],Int)) -> (HappyAbsSyn ) +happyIn336 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap336 x) +{-# INLINE happyIn336 #-} +happyOut336 :: (HappyAbsSyn ) -> HappyWrap336 +happyOut336 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut336 #-} +newtype HappyWrap337 = HappyWrap337 (([EpToken "|"],Int)) +happyIn337 :: (([EpToken "|"],Int)) -> (HappyAbsSyn ) +happyIn337 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap337 x) +{-# INLINE happyIn337 #-} +happyOut337 :: (HappyAbsSyn ) -> HappyWrap337 +happyOut337 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut337 #-} +newtype HappyWrap338 = HappyWrap338 (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) +happyIn338 :: (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn ) +happyIn338 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap338 x) +{-# INLINE happyIn338 #-} +happyOut338 :: (HappyAbsSyn ) -> HappyWrap338 +happyOut338 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut338 #-} +newtype HappyWrap339 = HappyWrap339 (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) +happyIn339 :: (forall b. DisambECP b => PV (LocatedLW [LMatch GhcPs (LocatedA b)])) -> (HappyAbsSyn ) +happyIn339 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap339 x) +{-# INLINE happyIn339 #-} +happyOut339 :: (HappyAbsSyn ) -> HappyWrap339 +happyOut339 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut339 #-} +newtype HappyWrap340 = HappyWrap340 (ECP) +happyIn340 :: (ECP) -> (HappyAbsSyn ) +happyIn340 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap340 x) +{-# INLINE happyIn340 #-} +happyOut340 :: (HappyAbsSyn ) -> HappyWrap340 +happyOut340 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut340 #-} +newtype HappyWrap341 = HappyWrap341 (ECP) +happyIn341 :: (ECP) -> (HappyAbsSyn ) +happyIn341 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap341 x) +{-# INLINE happyIn341 #-} +happyOut341 :: (HappyAbsSyn ) -> HappyWrap341 +happyOut341 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut341 #-} +newtype HappyWrap342 = HappyWrap342 (ECP) +happyIn342 :: (ECP) -> (HappyAbsSyn ) +happyIn342 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap342 x) +{-# INLINE happyIn342 #-} +happyOut342 :: (HappyAbsSyn ) -> HappyWrap342 +happyOut342 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut342 #-} +newtype HappyWrap343 = HappyWrap343 (Located (NonEmpty (LPat GhcPs))) +happyIn343 :: (Located (NonEmpty (LPat GhcPs))) -> (HappyAbsSyn ) +happyIn343 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap343 x) +{-# INLINE happyIn343 #-} +happyOut343 :: (HappyAbsSyn ) -> HappyWrap343 +happyOut343 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut343 #-} +newtype HappyWrap344 = HappyWrap344 (Located (NonEmpty (LPat GhcPs))) +happyIn344 :: (Located (NonEmpty (LPat GhcPs))) -> (HappyAbsSyn ) +happyIn344 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap344 x) +{-# INLINE happyIn344 #-} +happyOut344 :: (HappyAbsSyn ) -> HappyWrap344 +happyOut344 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut344 #-} +newtype HappyWrap345 = HappyWrap345 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn345 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn345 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap345 x) +{-# INLINE happyIn345 #-} +happyOut345 :: (HappyAbsSyn ) -> HappyWrap345 +happyOut345 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut345 #-} +newtype HappyWrap346 = HappyWrap346 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn346 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn346 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap346 x) +{-# INLINE happyIn346 #-} +happyOut346 :: (HappyAbsSyn ) -> HappyWrap346 +happyOut346 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut346 #-} +newtype HappyWrap347 = HappyWrap347 (ECP) +happyIn347 :: (ECP) -> (HappyAbsSyn ) +happyIn347 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap347 x) +{-# INLINE happyIn347 #-} +happyOut347 :: (HappyAbsSyn ) -> HappyWrap347 +happyOut347 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut347 #-} +newtype HappyWrap348 = HappyWrap348 (ECP) +happyIn348 :: (ECP) -> (HappyAbsSyn ) +happyIn348 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap348 x) +{-# INLINE happyIn348 #-} +happyOut348 :: (HappyAbsSyn ) -> HappyWrap348 +happyOut348 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut348 #-} +newtype HappyWrap349 = HappyWrap349 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn349 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn349 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap349 x) +{-# INLINE happyIn349 #-} +happyOut349 :: (HappyAbsSyn ) -> HappyWrap349 +happyOut349 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut349 #-} +newtype HappyWrap350 = HappyWrap350 (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) +happyIn350 :: (forall b. DisambECP b => PV (Located ([EpToken ";"],[LMatch GhcPs (LocatedA b)]))) -> (HappyAbsSyn ) +happyIn350 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap350 x) +{-# INLINE happyIn350 #-} +happyOut350 :: (HappyAbsSyn ) -> HappyWrap350 +happyOut350 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut350 #-} +newtype HappyWrap351 = HappyWrap351 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) +happyIn351 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn351 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap351 x) +{-# INLINE happyIn351 #-} +happyOut351 :: (HappyAbsSyn ) -> HappyWrap351 +happyOut351 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut351 #-} +newtype HappyWrap352 = HappyWrap352 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) +happyIn352 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (HappyAbsSyn ) +happyIn352 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap352 x) +{-# INLINE happyIn352 #-} +happyOut352 :: (HappyAbsSyn ) -> HappyWrap352 +happyOut352 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut352 #-} +happyInTok :: ((Located Token)) -> (HappyAbsSyn ) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn ) -> ((Located Token)) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyExpList :: HappyAddr +happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x1f\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x37\x5f\xe5\xff\x2f\xff\xbf\x67\x10\x04\x78\x00\xa1\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\xb9\x08\xfe\x7f\xf9\xff\x09\x82\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe3\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x10\x10\x11\x02\x54\xd0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x08\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x14\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x00\x40\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x2c\x80\xa8\xc0\x19\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0b\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc4\x85\x10\x1d\xfe\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x82\x0b\x21\x6a\xfc\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x00\x00\x00\xc0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x20\x00\x22\x04\xa8\xa0\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\xaa\x70\x86\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x20\x22\x04\x40\x10\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xff\x27\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x10\x3f\x00\x00\x31\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfc\xff\xc2\x3f\x00\x00\x40\x00\x07\x08\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x12\x3c\x00\x51\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x60\x01\x44\x05\xce\xc0\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x04\xff\xbf\xf0\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfc\xff\xc2\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf0\xff\x0b\xff\x00\x00\x00\x07\x1c\x20\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x38\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfc\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x82\xff\x5f\xf8\x07\x00\x00\x08\xe0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x04\xff\xbf\xf0\x0f\x00\x00\x10\xc0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\xa8\xfe\x7f\xf1\x1f\x08\x00\x24\xc0\x87\x00\x57\xfc\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x48\x8a\x0f\x03\xba\xfc\xff\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xfa\xff\xc5\x7f\x20\x00\x90\x04\x1f\x02\xd4\xf9\xff\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf0\xff\x0b\xff\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x80\xe0\xff\x13\xfe\x01\x00\x00\x00\x00\x00\x50\x01\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x55\x38\xc3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x54\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xea\xff\x17\xff\x81\x00\x40\x52\x7c\x18\xd0\xe5\xff\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x20\x42\x00\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x22\x10\x82\xff\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xc3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x90\xe2\xff\x13\xfe\x01\x00\x00\x00\x00\x00\x50\x01\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\xc5\x7f\x00\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\xa8\x80\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\x85\x7f\x00\x00\x80\x00\x0e\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x44\x08\x80\x20\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x40\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x40\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x80\x00\x00\x00\x41\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xc3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\x87\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\xff\x00\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x26\x42\x04\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\xa8\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x20\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfe\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd5\xff\x2f\xfe\x03\x01\x80\x04\xf8\x10\xa0\xcb\xff\xff\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\xaa\xff\x5f\xfc\x07\x02\x00\x49\xf0\x21\x40\x15\xff\xff\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfe\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x40\x00\x00\x80\x20\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x20\x20\x22\x04\xe8\x90\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x20\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\xa8\x80\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x5c\x04\xff\xbf\xfc\xff\x04\x41\x10\xe0\x01\x84\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\xb9\x08\xfe\x7f\xf9\xff\x09\x82\x20\xc0\x03\x08\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x88\x00\x01\x10\x84\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x11\x02\x00\x10\x33\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x3f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x7f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\xa8\xfe\x7f\xf1\x1f\x08\x00\x24\xc0\x87\x00\x75\xfe\xff\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\x85\x7f\x00\x00\x80\x00\x0e\x10\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x40\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x0b\x20\x2a\x70\x06\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x10\x00\x00\x00\x20\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x00\x00\x00\xb0\x00\xa2\x02\x67\xe0\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x74\xf8\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x40\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x84\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x00\x00\x04\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x60\x01\x44\x05\xce\xc0\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x60\x01\x44\x05\xce\xc0\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xc1\x27\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x00\x00\x00\x16\x40\x54\xe0\x0c\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x24\x55\x39\xf3\xff\xff\x7f\x7d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x11\xfc\xff\xc2\x3f\x00\x00\x40\x00\x07\x08\xab\x72\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa9\xca\x99\xff\xff\xff\xeb\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x58\x95\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x54\xff\xbf\xf8\x0f\x04\x00\x12\xe0\x43\x80\x2a\xfe\xff\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xe2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x20\x01\x3e\x04\xa8\xe2\xff\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x48\x80\x0f\x01\xaa\xfc\xff\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x00\x50\x8d\x33\xff\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x9b\xaf\xf2\xff\x97\xff\xdf\x33\x08\x02\x3c\x80\x50\x85\x33\xff\xff\xff\xd7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x80\x88\x10\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x44\x08\x00\x40\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xff\x27\xfc\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\x22\xf8\xff\xc5\x7f\x00\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x80\x0a\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x30\x11\x22\x00\x10\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc1\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\xa2\xff\x5f\xfc\x07\x00\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xfa\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xea\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\xaa\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x0f\x00\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x04\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\x87\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x01\x02\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x00\x00\x04\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x10\x40\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x04\x10\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x04\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x40\x05\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x80\x00\x01\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x44\x08\x00\x40\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xe6\xab\xfc\xff\xe5\xff\xf7\x0c\x82\x00\x0f\x20\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x82\xff\x5f\xfc\x07\x00\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x04\x10\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\xff\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\x00\x00\x00\x00\x00\x10\x04\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x01\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x00\x80\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xd3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xd1\xff\x2f\xfe\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x22\x04\x00\x20\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7f\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x11\x02\x00\x10\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x73\x11\xfc\xff\xf2\xff\x13\x04\x41\x80\x07\x10\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\xff\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x28\xfe\x7f\xf1\x1f\x08\x00\x20\xc0\x03\x00\x55\x39\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x83\x81\x08\xfe\x7f\xe1\x1f\x00\x00\x20\x80\x03\x04\x55\x39\xf3\xff\xff\x7f\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x20\x8a\xff\x5f\xfc\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x20\x01\x3e\x04\xa8\xe2\xff\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x80\xe0\xff\x13\xfe\x01\x00\x20\x00\x00\x00\x40\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x7a\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x07\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x02\xe0\x42\x88\x0a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xfe\x01\x00\x00\x02\x38\x40\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x71\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xe2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf5\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x22\x42\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x70\x21\x44\x05\xff\xd3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x00\x20\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x01\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xf8\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x14\xff\xbf\xf8\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x73\x51\xfc\xff\xf2\xff\x13\x04\x41\x80\x07\x10\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xe6\xa2\xf8\xff\xe5\xff\x27\x08\x82\x00\x0f\x20\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xff\x09\xff\x00\x00\x00\x00\x00\x00\x20\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x20\x42\x00\x00\x62\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x29\xfe\x3f\xe9\x1f\x00\x00\x00\x00\x00\x00\x04\x30\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x08\xfe\x3f\xe1\x1f\x00\x00\x00\x00\x00\x00\x15\x30\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x88\x10\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x17\xc1\xff\x2f\xff\x3f\x41\x10\x04\x78\x00\xa1\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x60\x2e\x82\xff\x5f\xfe\x7f\x82\x20\x08\xf0\x00\x42\x15\xce\xfc\xff\xff\x5f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x73\x55\xfc\xff\xf2\xff\x13\x04\x41\x80\x07\x10\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\xe6\xaa\xf8\xff\xe5\xff\x27\x08\x82\x00\x0f\x20\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x82\x9f\x4f\xf8\x07\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe0\xff\x17\xff\x01\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x08\xd1\xdf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x83\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x10\x5c\x08\x51\xe3\xff\xf4\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\xff\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x02\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfc\xff\xe2\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x06\xa2\xf8\xff\xc5\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\xff\xff\xff\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf1\xff\x8b\xff\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\xff\xff\xff\xeb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x03\x51\xfd\xff\xe2\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\xff\xff\xff\xff\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x20\xf8\xff\x84\x7f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\x70\xf0\x09\xff\x00\x00\x00\x00\x00\x00\x00\x80\x01\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x07\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x00\x18\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x30\x10\xc5\xff\x2f\xfe\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\xff\xaf\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\x3f\x9f\xf0\x0f\x60\x00\x82\xe0\x42\x88\x1a\xfe\xa7\x07\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x08\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xcd\x5c\x14\xff\xbf\xfc\xff\x04\x41\x10\xe0\x01\x84\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf0\xf3\x09\xff\x00\x06\x20\x00\x2e\x84\xa8\xe0\x7f\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x44\x08\x00\x40\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xc1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe1\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x18\x00\x17\x42\x54\xf0\x3f\x3c\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xf3\x09\xff\x00\x06\x30\x00\x2e\x84\xa8\xe0\x7f\x78\x00\x00\x20\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x80\xe0\xe7\x13\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x22\x00\x8a\xff\x4f\xf8\x07\x00\x80\x00\x00\x00\x00\x01\xcc\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x04\x3f\x9f\xf0\x0f\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc5\x5c\x15\xff\xbf\xfc\xff\x04\x41\x10\xe0\x01\x84\x2a\x9c\xf9\xff\xff\xbf\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x10\x00\xd1\xcf\x27\xfc\x03\x18\x80\x00\xb8\x10\xa2\x82\xff\xe9\x01\x00\x80\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x20\xfa\xf9\x84\x7f\x00\x03\x10\x00\x17\x42\x54\xf0\x3f\x3d\x00\x00\x90\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x81\x00\x88\x7e\x3e\xe1\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4f\x0f\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x18\x88\xe2\xff\x17\xff\x81\x00\x00\x02\x3c\x00\x50\x85\x33\xff\xff\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x20\x00\xa2\x9f\x4f\xf8\x07\x30\x00\x01\x71\x21\x44\x87\xff\xd3\x03\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfc\x7c\xc2\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x08\x80\xe8\xe7\x13\xfe\x01\x0c\x40\x00\x5c\x08\x51\xc1\xff\xf0\x00\x00\x40\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x10\xfd\x7c\xc2\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1f\x1e\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x22\x00\x8a\xff\x4f\xf8\x07\x00\x80\x00\x00\x00\x00\x01\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xc1\xcf\x27\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\x1c\x7c\xc2\x3f\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x29\xfe\x3f\xe9\x1f\x00\x00\x00\x00\x00\x00\x04\x32\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x05\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x29\xfe\x3f\xe9\x1f\x00\x00\x00\x00\x00\x00\x04\x32\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x11\x20\xc5\xff\x27\xfd\x03\x00\x00\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_parseModuleNoHaddock","%start_parseSignatureNoHaddock","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","HYPHEN","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","missing_module_keyword","implicit_top","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","export_cs","export","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_splice","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","importlist","importlist1","import","prec","infix","ops","topdecls","topdecls_semi","topdecls_cs","topdecls_cs_semi","topdecl_cs","topdecl","cl_decl","default_decl","ty_decl","standalone_kind_sig","sks_vars","inst_decl","overlap_pragma","deriv_strategy_no_via","deriv_strategy_via","deriv_standalone_strategy","opt_class","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","opt_instance","at_decl_inst","type_data_or_newtype","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","datafam_inst_hdr","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","qvarcon","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_activation_marker","rule_explicit_activation","rule_foralls","rule_vars","rule_var","maybe_warning_pragma","warning_category","warnings","warning","namespace_spec","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_tyconsig","sigktype","sigtype","sig_vars","sigtypes1","unpackedness","forall_telescope","ktype","ctype","context","expcontext","type","mult","expmult","btype","infixtype","ftype","tyarg","tyop","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","tv_bndr_no_braces","tyvar_wc","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","usum_constr","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","deriv_clause_types","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","sigtypes_maybe","activation","explicit_activation","quasiquote","exp","exp2","infixexp2","infixexp","exp10p","exp10","optSemi","prag_e","fexp","aexp","aexp1","aexp2","projection","splice_exp","splice_untyped","splice_typed","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","guardquals","guardquals1","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat_syn_pat","pat","pats1","bindpat","argpat","argpats","apat","stmtlist","stmts","maybe_stmt","e_stmt","stmt","qual","fbinds","fbinds1","fbind","fieldToUpdate","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon","gen_qcon","con","con_list","qcon_list","sysdcon_nolist","syscon","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","tycon","qtyconsym","tyconsym","otycon","op","varop","qop","qopm","hole_op","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","field","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","altslist__argpats__","altslist__pats1__","exp_gen__infixexp__","exp_gen__infixexp2__","exp_prag__exp10p__","orpats__exp__","orpats__exp2__","alts__argpats__","alts__pats1__","exp_prag__exp_gen__infixexp2____","exp_prag__exp_gen__infixexp____","alts1__argpats__","alts1__pats1__","alt__argpats__","alt__pats1__","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'via'","'splice'","'quote'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# OPAQUE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# SCC'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'lcases'","'|'","'<-'","'->'","'->.'","TIGHT_INFIX_AT","'=>'","'-'","PREFIX_TILDE","PREFIX_BANG","PREFIX_MINUS","'*'","'-<'","'>-'","'-<<'","'>>-'","'.'","PREFIX_PROJ","TIGHT_INFIX_PROJ","PREFIX_AT","PREFIX_PERCENT","'{'","'}'","vocurly","vccurly","'['","']'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","DO","MDO","IPDUPVARID","LABELVARID","CHAR","STRING","STRING_MULTI","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMINTEGER8","PRIMINTEGER16","PRIMINTEGER32","PRIMINTEGER64","PRIMWORD8","PRIMWORD16","PRIMWORD32","PRIMWORD64","PRIMFLOAT","PRIMDOUBLE","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","PREFIX_DOLLAR","PREFIX_DOLLAR_DOLLAR","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] + bit_start = st Prelude.* 513 + bit_end = (st Prelude.+ 1) Prelude.* 513 + read_bit = readArrayBit happyExpList + bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] + bits_indexed = Prelude.zip bits [0..512] + token_strs_expected = Prelude.concatMap f bits_indexed + f (Prelude.False, _) = [] + f (Prelude.True, nr) = [token_strs Prelude.!! nr] + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x25\x00\x1b\x00\xa6\x00\xf1\x35\xd1\x28\x31\x3c\x31\x3c\x71\x33\xf1\x35\x75\x6d\x7f\x55\xb6\x00\x47\x01\x70\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\xa3\x01\xa3\x01\x00\x00\xa7\x00\x0b\x02\x0b\x02\x55\x5b\x7f\x55\xda\x00\xf9\x01\x06\x02\x00\x00\x4e\x1a\x00\x00\x0a\x19\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x19\x00\x00\xc6\x17\x00\x00\x00\x00\x00\x00\x68\x18\x45\x75\x00\x00\x00\x00\x00\x00\x62\x01\x57\x02\x00\x00\x00\x00\xf3\x5d\xf3\x5d\x00\x00\x00\x00\x7e\x76\xe7\x53\xb9\x50\x41\x51\x06\x72\xde\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x4f\x00\x00\x00\x00\x15\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x02\x63\x08\x46\x03\x9c\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x02\xf0\x1a\x00\x00\x31\x3c\x92\x1b\x00\x00\xbd\x02\x00\x00\x00\x00\x00\x00\x7f\x02\x72\x02\x00\x00\x00\x00\x82\x16\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x31\x3c\xb1\x34\xa5\x04\xf3\x5d\xf1\x4e\xf7\x04\xf1\x4e\xf6\x00\x11\x43\x11\x4d\xf1\x4e\xf1\x4e\xf1\x4e\x91\x31\x11\x2a\x31\x2d\xf1\x4e\x0c\x70\xf7\x04\xf7\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x3c\x31\x4b\x7f\x55\x08\x05\x31\x3c\x91\x4f\x24\x17\xc3\x02\x00\x00\x05\x03\x56\x09\x0d\x03\x16\x03\x00\x00\x00\x00\x00\x00\x20\x05\xe0\x03\x70\x70\x70\x72\xd1\x3c\xb1\x43\x70\x72\x74\x73\xdd\x02\x11\x2a\xa2\x01\x12\x03\x00\x00\x12\x03\x12\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x03\xbe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x0d\x55\x5b\xea\x01\x79\x03\x65\x02\xae\x00\xca\x03\x4f\x52\x2a\x02\xd1\x73\x5d\x03\x2d\x00\x4e\x00\x17\x73\xf3\x5d\x73\x03\x00\x00\x73\x03\xb2\x03\x7a\x03\x30\x04\x7a\x03\x00\x00\x00\x00\x30\x04\x00\x00\xd9\x03\xbb\x03\xae\x00\x00\x00\x00\x00\x33\x00\xae\x00\xc7\x02\xe6\x03\x31\x4b\x38\x71\xf1\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x4e\xca\x01\xc2\x04\x6a\x01\x1e\x00\x00\x00\xf0\x03\x2e\x74\x9f\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x51\x44\xa3\x03\x44\x76\x00\x04\x14\x01\x85\x02\x00\x00\x49\x06\x49\x06\xac\x00\x1b\x04\xe7\x02\x29\x01\x00\x00\xaf\x58\x55\x5b\xda\x02\xf1\x04\x04\x00\x75\x04\x00\x00\x9c\x04\x00\x00\x00\x00\x00\x00\x7f\x55\x45\x04\x00\x00\x55\x5b\x6b\x04\x80\x04\x00\x00\x64\x04\x00\x00\xf1\x44\x00\x00\x00\x00\x7f\x55\x45\x6e\x9f\x04\x55\x5b\x73\x04\x71\x3d\x91\x45\xb3\x04\x81\x04\xcb\x1c\x7d\x4f\x91\x36\x94\x02\x59\x01\xb0\x04\x00\x00\x31\x4b\x00\x00\x00\x00\x00\x00\xfc\x04\x0e\x05\x18\x05\x1e\x05\x71\x2e\x31\x32\x00\x00\x35\x05\x00\x00\xf3\x5d\x00\x00\x43\x05\x11\x4d\xd7\x77\x00\x00\x00\x00\x45\x6e\xad\x04\xc5\x04\xe7\x03\xce\x04\x00\x00\x6c\x05\x00\x00\x46\x05\x00\x00\xae\x72\xfc\xff\x31\x46\x00\x00\x3e\x01\x31\x46\x7f\x55\x86\x05\xd4\x70\x6b\x05\x00\x00\xdd\x05\xd1\x32\xd1\x32\x7e\x76\x7f\x55\x6a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x05\xb6\x06\xd1\x01\x00\x00\x00\x00\x5e\x05\x73\x05\x00\x00\x00\x00\x78\x05\x3b\x06\x7b\x05\x00\x00\x31\x37\x31\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x02\x95\x05\x00\x00\x00\x00\x11\x2f\x00\x00\xb0\x05\x77\x00\xc0\x05\xbb\x05\x00\x00\x00\x00\x00\x00\x00\x00\x34\x1c\x00\x00\xb1\x4d\xe6\x05\x00\x00\x5c\x05\x5f\x05\xf3\x5d\x02\x06\x1e\x06\x00\x00\x00\x00\x22\x06\x00\x00\x37\x06\x18\x06\x43\x00\x00\x00\x00\x00\x11\x3e\x54\x06\x87\x06\xf1\x4e\xb1\x3e\xd7\x77\x3b\x72\x00\x00\xf3\x5d\x00\x00\x7f\x55\xb1\x3e\xb1\x3e\xb1\x3e\xb1\x3e\x35\x06\x4f\x06\x5e\x04\x29\x06\x5c\x06\x11\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\xd7\x52\xd1\x71\x59\x06\x7c\x06\x78\x01\x61\x06\x75\x06\xb9\x04\xfa\x01\x00\x00\x68\x02\x31\x50\xef\x02\x72\x06\x00\x00\xdf\x02\x00\x00\x64\x01\xb1\x06\x00\x00\xa8\x06\x00\x00\xa4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x01\x45\x75\x00\x00\x00\x00\x00\x00\x00\x00\x46\x78\x6f\x28\x7f\x55\xf3\x5d\x00\x00\x55\x5b\x00\x00\xf3\x5d\xc9\x06\x7f\x55\x7f\x55\xf3\x5d\x7f\x55\x7f\x55\x00\x00\x00\x00\x53\x02\x00\x00\x3c\x61\x30\x00\x00\x00\xaf\x06\x33\x03\x33\x03\x00\x00\xc4\x06\xc4\x06\x00\x00\x00\x00\x1f\x07\x00\x00\x00\x00\x00\x00\x00\x00\x05\x07\x28\x07\x33\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x06\x1b\x01\x00\x00\x00\x00\x00\x00\xdb\x06\x7e\x76\x00\x00\x7f\x55\xf3\x5d\x7e\x76\x00\x00\x7f\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x7f\x55\x00\x00\x00\x00\xdf\x06\xdc\x06\xee\x06\xf2\x06\x04\x07\x11\x07\x00\x00\x15\x07\x16\x07\x17\x07\xf3\x06\x1a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x07\x00\x00\x1c\x07\x44\x07\x30\x07\x31\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x05\xdb\x01\x46\x07\x25\x07\x00\x00\x00\x00\x00\x00\x8c\x07\x00\x00\xb1\x3e\xb1\x3e\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x46\x77\x1d\x00\x00\x51\x35\xd6\x1c\xb1\x3e\x00\x00\x11\x34\x00\x00\xd1\x37\x71\x38\x11\x34\x00\x00\x2d\x07\x00\x00\x00\x00\x00\x00\xd1\x2d\x53\x07\x00\x00\x51\x4e\x4f\x00\x00\x00\xb0\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x28\x33\x00\x3c\x07\x00\x00\x00\x00\x00\x00\x3d\x07\x00\x00\x00\x00\x7f\x05\x00\x00\x00\x00\x55\x01\x5b\x00\x00\x00\x00\x00\xfa\x0e\x00\x00\xb1\x2f\x51\x30\x67\x00\x00\x00\xf1\x30\xd1\x02\x55\x03\xe0\x03\x61\x07\x00\x00\x00\x00\x00\x00\x00\x00\x62\x07\x31\x4b\xb3\x76\x2b\x07\x00\x00\x00\x00\x42\x07\x31\x4b\x00\x00\x69\x07\x48\x07\x49\x07\x8b\x74\x8b\x74\x00\x00\x6a\x07\xab\x04\x92\x05\x4b\x07\x4f\x07\x00\x00\x00\x00\x00\x00\x00\x00\x67\x07\x54\x07\xfd\x04\x00\x00\x00\x00\xd7\x77\x00\x00\x7d\x4f\x00\x00\x6e\x07\x71\x47\x11\x48\x11\x48\xf1\x4e\x7f\x55\x11\x39\x11\x39\x11\x39\x11\x39\x11\x39\x11\x48\x00\x00\x00\x00\xfe\xff\x44\x04\x37\x59\xff\x04\x00\x00\x00\x00\xb1\x48\x00\x00\x00\x00\xc7\x00\x00\x00\xb1\x3e\x51\x3f\x55\x5b\xae\x07\x00\x00\x7b\x07\x7f\x55\x00\x00\x00\x00\x7f\x07\x67\x04\x04\x00\x88\x07\x55\x07\x00\x00\x7f\x55\x8d\x07\x8f\x07\x91\x07\x92\x07\x2b\x00\x90\x02\xf3\x04\x00\x00\x93\x07\x45\x75\x7f\x55\x7f\x55\xda\x02\x5e\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x60\xd7\x77\x00\x00\x66\x07\x7f\x55\x00\x00\xd7\x77\xf1\x76\xf1\x3f\xf1\x3f\x51\x49\x00\x00\x7a\x01\x00\x00\x5c\x07\x00\x00\xa9\x01\x04\x00\x6f\x07\x00\x00\x00\x00\x51\x00\xe8\x74\x00\x00\xf1\x4e\x9d\x01\x9d\x07\x9e\x07\xc8\x0f\x00\x00\xcd\x07\x00\x00\x00\x00\x80\x07\x00\x00\x80\x07\x00\x00\x00\x00\xe2\x07\x00\x00\x7d\x07\x00\x00\xd1\x28\xd8\x07\x14\x02\xd9\x07\xde\x07\x00\x00\x45\x05\x7f\x55\x00\x00\x00\x00\x89\x07\xab\x07\x04\x00\x00\x00\xe8\x74\x00\x00\x00\x00\x00\x00\xec\x01\x95\x07\x31\x4b\x00\x00\xe5\x07\x00\x00\x9a\x07\x87\x07\x00\x00\x00\x00\x8e\x07\x00\x00\xd1\x60\x00\x00\xb6\x07\xb7\x07\xb8\x07\xb9\x07\xf1\x76\xf1\x76\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x07\x7f\x55\xbe\x07\x7f\x55\x45\x75\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x07\x41\x03\x00\x00\x00\x00\xc1\x07\xf1\x04\x7f\x55\xa4\x07\x00\x00\x7f\x55\x9f\x07\x00\x00\x0c\x78\x00\x00\x80\x05\x00\x00\xc7\x07\xfe\x07\x00\x00\x00\x00\x8c\x05\x00\x00\x09\x05\xc0\x07\x00\x00\x45\x75\x00\x08\x12\x08\x7f\x55\x02\x08\x00\x00\xd4\x07\x00\x00\x93\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x49\x00\x00\x00\x00\xd5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x0f\x00\x00\xb4\x07\xcf\x07\x26\x77\x00\x00\xd7\x77\xe2\x0f\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x07\x00\x00\xd1\x32\xf1\x3f\x00\x00\x00\x00\x7f\x55\xc3\x07\x00\x00\x00\x00\x00\x00\x00\x00\x83\x75\x00\x00\x00\x00\xc2\x07\x00\x00\xb1\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x07\x00\x00\x00\x00\x00\x00\xbb\x01\x00\x00\x00\x00\x91\x40\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x33\x00\xc5\x07\x00\x00\x51\x3a\xd1\x07\x00\x00\x2c\x00\x00\x00\x33\x00\xce\x07\x00\x00\xd1\x4b\xd2\x07\x00\x00\x00\x00\x00\x00\x31\x41\xd1\x41\x71\x42\x00\x00\x00\x00\xd7\x77\x11\x34\x3b\x72\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\xed\x07\x00\x00\xd6\x07\xdd\x07\x00\x00\xf4\x07\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x7f\x55\x00\x00\x38\x6d\x00\x00\x00\x00\x00\x00\xa2\x05\x00\x00\x34\x08\x35\x08\x1a\x06\x1a\x06\x00\x00\x3f\x00\x3f\x00\x00\x00\xe7\x07\xee\x07\x7f\x55\x00\x00\x00\x00\xea\x07\x00\x00\x00\x00\x56\x01\x00\x00\x00\x00\x00\x00\xe8\x07\x00\x00\x00\x00\x91\x4a\x00\x00\x00\x00\x44\x08\x0b\x08\x71\x42\x00\x00\x00\x00\x71\x42\x00\x00\x00\x00\x3c\x08\x71\x29\xf1\x3a\xf1\x3a\x91\x3b\x00\x00\xf6\x07\x00\x00\x7f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x11\x08\x22\x08\x7f\x55\x23\x08\x00\x00\x56\x08\x00\x00\x29\x08\x00\x00\x00\x00\x27\x08\x00\x00\xdb\x5b\xbb\x75\x00\x00\x00\x00\x75\x08\x00\x00\x5f\x01\x75\x08\x1d\x06\x1c\x08\x61\x5c\x67\x08\x79\x08\x00\x00\x00\x00\x71\x42\x00\x00\xb1\x2a\xb1\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x55\x00\x00\x00\x00\x03\x08\x00\x00\x2a\x06\x00\x00\x00\x00\x00\x00\x6d\x08\x46\x78\x00\x00\x61\x5c\x3b\x08\x3e\x08\x7f\x55\x00\x00\x00\x00\x64\x77\x00\x00\x00\x00\x5e\x06\xc9\x03\x00\x00\x00\x00\x1e\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x08\x00\x00\x64\x06\x20\x08\x1f\x08\x00\x00\x00\x00\xf9\x6e\x00\x00\x64\x06\x25\x08\x00\x00\x26\x08\x00\x00\x26\x08\x00\x00\x00\x00\x00\x00\x2d\x08\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x70\x25\x05\x26\x05\xda\x02\x92\x05\x7c\x04\x87\x00\x00\x00\x00\x00\x26\x05\x00\x00\x00\x00\x71\x42\xd1\x32\xd1\x32\x00\x00\x00\x00\x7f\x55\x7f\x55\x43\x08\x00\x00\x41\x08\x00\x00\x76\x06\x00\x00\x51\x2b\x51\x2b\x00\x00\x00\x00\x00\x00\x46\x78\x00\x00\x00\x00\x8e\x00\x00\x00\x7a\x08\x71\x4c\x6f\x54\x5f\x03\x00\x00\x00\x00\x93\x08\x00\x00\x61\x5c\x80\x03\x80\x03\x00\x00\xea\x02\x6b\x08\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x54\x00\x00\x3d\x08\x46\x08\x00\x00\x49\x08\x00\x00\x41\x51\x89\x08\x00\x00\x99\x77\x7f\x55\x38\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x42\x71\x42\x71\x42\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x08\x11\x34\xd7\x77\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x01\x00\x00\x73\x08\x26\x05\x71\x61\x66\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x45\x08\x48\x08\xa6\x61\xa4\x05\x26\x05\x00\x00\x00\x00\x00\x00\x71\x42\x00\x00\x00\x00\x84\x08\x7f\x55\x4b\x08\x55\x08\x00\x00\xbc\x01\x4a\x08\x5f\x53\xe7\x5c\x00\x00\x47\x08\x4f\x08\x00\x00\x00\x00\x00\x00\x33\x00\x50\x08\xe0\x03\x5a\x08\x66\x08\x00\x00\x00\x00\x00\x00\xf1\x2b\x00\x00\xe7\x05\xbf\x59\x6d\x5d\x36\x10\x6d\x5d\x00\x00\x00\x00\x00\x00\xb3\x08\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\xb3\x08\x76\x03\x00\x00\x07\x56\x8f\x56\x46\x78\x17\x57\x00\x00\x00\x00\x5c\x01\x77\x03\x00\x00\xf3\x05\x00\x00\x58\x08\x64\x08\x65\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x6f\x33\x00\x60\x08\x00\x00\x00\x00\x68\x08\x61\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x08\x00\x00\x00\x00\x00\x00\x46\x78\x00\x00\x66\x01\x00\x00\x33\x00\xa1\x03\x70\x08\x00\x00\x91\x2c\xbf\x59\x00\x00\x00\x00\x99\x08\x91\x08\x17\x57\xf2\x05\x00\x00\x00\x00\x17\x57\x9f\x57\x00\x00\x6d\x5d\x00\x00\x94\x08\x80\x03\x00\x00\x00\x00\x27\x58\x00\x00\x00\x00\x90\x08\x00\x00\x9a\x08\x27\x58\x00\x00\x00\x00\x00\x00\x71\x42\x00\x00\x11\x06\x7f\x08\x00\x00\x26\x05\x00\x00\x26\x05\x00\x00\x01\x03\x00\x00\xeb\x08\xd8\x03\x00\x00\xf1\xff\xd6\x08\x83\x08\x00\x00\x00\x00\x00\x00\x00\x00\x27\x58\x00\x00\x9e\x08\x18\x1e\x9e\x1e\xc9\x51\x00\x00\x00\x00\x0f\x76\x00\x00\x00\x00\x47\x5a\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x5a\x00\x00\x00\x00\x00\x00\xef\x08\xce\x6f\x00\x00\x00\x00\x28\x00\x26\x05\x00\x00\xfa\x05\x46\x78\x00\x00\xda\x08\x85\x06\x06\x61\x26\x05\x00\x00\x26\x05\x26\x05\x00\x00\x26\x05\x00\x00\x00\x00\x00\x00\x80\x08\xaa\x08\x00\x00\x26\x05\x00\x00\x85\x06\x00\x00\xdf\x08\xf2\x08\x00\x00\x00\x00\x00\x00\x8e\x08\x2e\x6f\x96\x08\x8f\x08\x9b\x08\x00\x00\x26\x05\x92\x05\x00\x00\x2e\x6f\x00\x00\x02\x09\x00\x00\x95\x08\x26\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x08\x00\x00\x00\x00\x99\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\xc8\x04\x00\x09\xe5\x08\xb5\x61\x9e\x01\xa0\x65\x85\x64\x0e\x07\xff\x61\x01\x00\xa2\x20\x6e\x02\x87\x04\x9f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x03\x00\x00\x00\x00\x31\x00\x00\x00\x00\x00\xe6\x07\xe9\x07\xc5\x02\x00\x00\x57\x06\x60\x06\xb0\x0f\x72\x24\x00\x00\x00\x00\x00\x00\x00\x00\x86\x08\x00\x00\x8a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x01\xab\x02\x00\x00\x00\x00\xf9\xff\xe9\x20\x1e\x10\xd2\x0f\xf3\x01\xeb\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x03\xe1\x07\x2b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x0f\x00\x00\x3b\x6b\xbe\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x66\x8d\x63\x28\x06\x5b\x05\xcf\x79\x2c\x08\x04\x7a\x00\x00\x7b\x77\x1c\x21\x44\x7a\x79\x7a\x8a\x7a\xb2\x09\x2f\x08\x31\x09\xbf\x7a\x65\x0b\x39\x08\x3a\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x66\xc1\x77\xfc\x20\x4e\x08\x97\x66\x00\x7c\x76\x08\xf4\x08\x00\x00\x00\x00\xad\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x06\x8a\x02\xef\x05\xd3\x03\x36\x06\x4b\x06\x8b\x04\x12\x0a\x81\x03\xb0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\xff\x13\x05\x00\x00\xb9\xff\x8a\x06\xb4\x08\x00\x00\x1e\x01\xab\x08\x9f\xff\xad\x06\x47\x05\x94\x05\x1f\x09\x50\x06\x00\x00\x00\x00\x00\x00\x09\x09\x00\x00\xfb\x07\x00\x00\x38\x01\x00\x00\xfc\x07\x5a\x02\x00\x00\x02\x03\xb9\x08\x00\x00\x00\x00\xff\x07\xbd\x08\x0f\x09\x00\x00\xed\x77\x27\x02\xff\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x7b\x97\x00\xc6\x03\xbb\x08\x00\x00\x00\x00\x00\x00\xab\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x03\x00\x00\xb5\xff\x00\x00\x2f\xff\x76\x04\x00\x00\xb8\x08\xbc\x08\x00\x00\x00\x00\xaf\x08\x00\x00\x00\x00\x6e\x03\x30\x0c\xea\x03\xff\x08\xc4\x08\xcb\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x11\x00\x00\x00\x00\xa2\x0c\xa1\x08\x00\x00\x00\x00\x72\x05\x00\x00\xb3\x6d\x00\x00\x00\x00\x48\x13\x2b\x04\xf0\x08\x58\x07\x00\x00\x0a\x65\x92\x10\x00\x00\x00\x00\x00\x00\x70\x02\xd9\x0d\x00\x00\xc4\xff\x00\x00\x00\x00\x33\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x0a\x08\x0b\x00\x00\x00\x00\x00\x00\x70\x06\x00\x00\x00\x00\x1c\x21\x0e\x03\x00\x00\x00\x00\xe6\x04\x00\x00\xbf\x08\xc8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x3c\x00\x00\xd3\x08\x00\x00\xd9\x08\xd4\x08\x4d\x12\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x23\x03\x9a\x03\x17\x00\x5b\x13\xd2\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x32\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\x15\x00\x00\x00\xad\x0f\x00\x00\x00\x00\x4a\x62\x95\x62\x00\x00\x00\x00\x00\x00\x7d\x08\x00\x00\xc4\xff\x00\x00\x00\x00\x00\x00\x24\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x7b\x00\x00\x5f\x78\x00\x00\x00\x00\x18\x08\x1b\x08\x76\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x08\x70\xff\x00\x00\x00\x00\x08\x63\xf9\x05\x00\x00\x7a\x7b\xa8\x66\x37\x03\x03\x01\x00\x00\x80\x09\x00\x00\x92\x24\x4c\x6b\xbf\x6b\xd0\x6b\x43\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x1e\xf0\x0f\xb1\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x01\x61\xff\xd9\x24\xed\x09\x00\x00\x8f\x20\x00\x00\x5f\x0a\x00\x00\x30\x25\x77\x25\x68\x0a\x8a\x25\x43\x21\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x30\x08\x00\x00\xed\x02\xea\x08\xed\x08\x00\x00\x52\x09\x53\x09\x00\x00\x00\x00\x45\x09\x00\x00\x00\x00\x00\x00\x00\x00\x72\x09\x00\x00\x6c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\xe4\x25\xda\x0a\x40\x02\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x1f\xe1\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x08\x87\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x67\x2c\x67\x00\x00\x00\x00\x00\x00\x00\x00\x74\x22\xf1\x5e\x00\x00\xd9\x5d\xad\x5d\x9f\x67\x00\x00\x7a\x0b\x00\x00\x53\x0d\x21\x61\xec\x0b\x00\x00\x37\xff\x00\x00\x00\x00\x00\x00\x96\x0a\x00\x00\x00\x00\x57\x79\x40\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x02\x4d\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\xff\x00\x00\x00\x00\x00\x00\x59\x08\x00\x00\x00\x00\x97\xff\x00\x00\x00\x00\x00\x00\x5c\x08\x00\x00\x00\x00\x00\x00\x00\x00\xab\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x78\xaa\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x78\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x07\x94\x06\x00\x00\x00\x00\xe9\x04\x99\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x05\x00\x00\xad\x0f\x00\x00\x00\x00\x6c\x03\x00\x00\xe5\x02\x00\x00\x00\x00\xb3\x6d\xa8\x10\xbe\x10\xba\x7b\x2b\x26\x4b\x0e\x5c\x0e\xce\x0e\xe2\x0e\x42\x0d\x39\x11\x00\x00\x00\x00\x00\x00\xd2\xff\xaf\x07\x00\x00\x00\x00\x00\x00\xc4\x6d\x00\x00\x00\x00\xf2\xff\x00\x00\xb0\x67\x7b\x63\xdf\x26\x0a\x09\x71\x05\x25\x09\x98\x1e\x00\x00\x00\x00\x00\x00\x0b\x09\x0c\x09\x00\x00\x16\x09\x00\x00\x94\x12\x00\x00\x00\x00\x00\x00\x00\x00\x16\x06\x2d\x06\x47\x09\x00\x00\x00\x00\xfd\x01\x9d\x21\x3a\x12\x2a\x04\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x2e\xff\x00\x00\x6c\x08\xa2\x13\x00\x00\xc0\xff\xcc\xff\x1c\x65\x8f\x65\x27\x09\x00\x00\x2d\x09\x00\x00\x30\x09\x00\x00\x6b\x06\x24\x09\x00\x00\x00\x00\x00\x00\x78\x06\x43\x10\x00\x00\xef\x7b\x98\x08\x00\x00\x00\x00\x6b\x01\x00\x00\x7f\x09\x00\x00\x00\x00\x91\x09\x00\x00\x92\x09\x00\x00\x00\x00\x26\x00\x00\x00\x89\x09\x00\x00\x50\x01\x00\x00\x85\x01\x00\x00\x86\x09\x00\x00\xb8\x05\x3e\x26\x00\x00\x00\x00\x00\x00\x00\x00\x32\x09\x00\x00\x90\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x79\x00\x00\x4f\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x02\xff\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x21\x6e\x09\xf7\x21\xc0\x01\x00\x00\x5a\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x79\x09\x3e\x22\x00\x00\x00\x00\x95\x22\x00\x00\x00\x00\x6a\x02\x00\x00\x59\x09\x00\x00\x00\x00\x4d\x09\x00\x00\x00\x00\xbe\x06\x00\x00\xd9\xff\x00\x00\x00\x00\x03\x03\x18\x09\xf1\x05\xdc\x22\x09\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x05\x00\x00\x00\x00\x00\x00\xae\xff\x00\x00\x5c\x02\xf5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x06\x00\x00\xf9\x06\x23\x68\x00\x00\x00\x00\xb5\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x03\x00\x00\x00\x00\xa3\x09\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x68\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x00\x00\x97\x08\x00\x00\x00\x00\x5e\x5e\x00\x00\x00\x00\x67\x05\x00\x00\x9c\x08\x00\x00\x00\x00\x12\x23\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x68\x97\x64\xb8\x68\x00\x00\x00\x00\x32\x01\x5e\x0c\xaf\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x23\x00\x00\x7a\x23\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\xc1\x09\x00\x00\x00\x00\x00\x00\xb6\x09\xbc\x09\x00\x00\x45\x07\x51\x07\x00\x00\x00\x00\x00\x00\x85\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x09\x00\x00\x00\x00\x3c\x5f\x00\x00\x00\x00\x62\x09\xfc\x08\x2b\x69\x00\x00\x00\x00\x8a\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x61\x12\x64\xc5\x0d\x00\x00\x00\x00\x00\x00\x5d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x0b\x38\x03\x00\x00\x00\x00\x1b\x09\x00\x00\xd1\xff\x19\x06\x00\x00\x00\x00\xf2\x26\x2b\x09\x44\x06\x00\x00\x00\x00\x3c\x69\x00\x00\x16\x04\x90\x04\x00\x00\x3d\x09\xb3\x06\x00\x00\x00\x00\x00\x00\xee\x12\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x09\x00\x00\x00\x00\x00\x00\x9f\x09\xbb\xff\x00\x00\x39\x27\x00\x00\x00\x00\xfc\x13\x00\x00\x00\x00\xdd\xff\x00\x00\x00\x00\x00\x00\xad\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x09\x00\x00\xdd\x09\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\xde\x09\xcc\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x02\xb4\x02\xd3\x09\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x01\x4a\x06\xc0\x08\x5a\x04\x0f\x03\x29\x05\x3d\x00\x00\x00\x00\x00\xc6\x08\x00\x00\x00\x00\xaf\x69\x0b\x06\x82\x06\x00\x00\x00\x00\x0f\x14\x56\x14\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x09\x00\x00\xce\xff\xa3\x02\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\x00\x00\xc5\x08\x00\x00\xa4\x09\x43\x79\x14\x04\x00\x00\x00\x00\x00\x00\x47\x06\x00\x00\xbe\x0b\xa4\x01\x0a\x02\x00\x00\x52\xff\xb1\x09\x00\x00\x00\x00\x00\x00\x00\x00\x87\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x0f\xbf\x06\x00\x00\xd8\xff\x98\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x69\x33\x6a\x44\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x0c\xf1\x03\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x08\x00\x00\xdc\x09\xd1\x08\x0e\x00\x00\x00\x00\x00\x07\x03\x22\x03\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x09\x04\x0a\x00\x00\x14\x00\x8f\x09\xd7\x08\x00\x00\x00\x00\x00\x00\xb7\x6a\x00\x00\x00\x00\x00\x00\x01\x13\x00\x00\x00\x00\x00\x00\xd5\x08\x00\x00\x9a\x23\x9d\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x08\x00\x00\xc1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x05\x00\x00\xb9\x09\x70\x04\x4c\x27\xad\x0f\x93\x27\x00\x00\x00\x00\x00\x00\xbd\x09\x00\x00\xde\x08\x00\x00\x00\x00\x00\x00\xc5\x09\x00\x00\x00\x00\x31\x01\xa1\x02\xbd\xff\xda\x23\x00\x00\x00\x00\xe2\x08\x00\x00\x00\x00\xf1\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\xe8\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x09\x00\x00\x00\x00\x00\x00\x09\x03\x00\x00\xf1\x08\x00\x00\xf3\x08\x00\x00\x00\x00\x00\x00\x15\x05\x6f\x05\x00\x00\x00\x00\xd0\x09\xd9\x09\x69\x14\xda\x09\x00\x00\x00\x00\x32\x24\xe2\x1e\x00\x00\xa6\x27\x00\x00\x00\x00\x31\x02\x00\x00\x00\x00\xf3\x11\x00\x00\x00\x00\x2b\x06\x00\x00\x00\x00\x48\x20\x00\x00\x00\x00\x00\x00\xc8\x6a\x00\x00\xb7\x09\x1b\x0a\x00\x00\xff\xff\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0a\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x14\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x08\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\xca\x07\x00\x00\x00\x00\x00\x00\x00\x00\x56\x06\x00\x00\x00\x00\x00\x00\x08\x0a\x2e\x00\x00\x00\x00\x00\x47\x07\x03\x09\x00\x00\xe7\xff\xbc\xff\x00\x00\x00\x00\x27\x0a\x08\x00\x04\x09\x00\x00\x02\x00\x05\x09\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x09\x00\x00\x28\x0a\x00\x00\x94\x09\x65\x06\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x26\x0a\x00\x00\x00\x00\x00\x00\x12\x09\x6f\x04\x00\x00\x44\x00\x00\x00\x7e\x06\x00\x00\x00\x00\x13\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# +happyAdjustOffset off = off + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xc1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xfd\x00\x00\x00\x00\xc0\xff\xc1\xff\x00\x00\xf2\xff\xed\xfc\xe9\xfc\xe6\xfc\xd7\xfc\xd5\xfc\xd6\xfc\xd4\xfc\xd3\xfc\xd2\xfc\xe4\xfc\xe3\xfc\xe5\xfc\xe2\xfc\xe1\xfc\xd1\xfc\xd0\xfc\xcf\xfc\xce\xfc\xcd\xfc\xcc\xfc\xcb\xfc\xca\xfc\xc9\xfc\xc4\xfc\xc5\xfc\xc8\xfc\xc6\xfc\xc7\xfc\x00\x00\xe7\xfc\xe8\xfc\x90\xff\x00\x00\xb5\xff\x00\x00\x00\x00\x90\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\xfe\x00\x00\x7c\xfe\x79\xfe\x73\xfe\x72\xfe\x6e\xfe\x6f\xfe\x50\xfe\x4f\xfe\x00\x00\x65\xfe\x20\xfd\x69\xfe\x1b\xfd\x12\xfd\x15\xfd\x0e\xfd\x64\xfe\x68\xfe\xf6\xfc\xf3\xfc\x63\xfe\x3e\xfe\xf1\xfc\xf0\xfc\xf2\xfc\x00\x00\x00\x00\x0b\xfd\x0a\xfd\x00\x00\x00\x00\x62\xfe\x09\xfd\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xfc\x11\xfd\x0c\xfd\x0d\xfd\x49\xfe\x13\xfd\x0f\xfd\x10\xfd\x4a\xfd\x4c\xfe\x4b\xfe\x4a\xfe\x4d\xfe\x00\x00\xee\xfd\xed\xfd\x00\x00\xf1\xff\x3b\xfd\x2b\xfd\x3a\xfd\x2d\xfd\xef\xff\xf0\xff\xfa\xfc\xdf\xfc\xe0\xfc\xdb\xfc\xd8\xfc\x39\xfd\xc1\xfc\x26\xfd\xbe\xfc\xbb\xfc\xee\xff\xda\xfc\xc2\xfc\xc3\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xfc\xd9\xfc\xbc\xfc\xc0\xfc\xdc\xfc\xbd\xfc\xa9\xfd\x5b\xfd\x92\xfc\xe4\xfd\x00\x00\xdf\xfd\xd7\xfd\xc8\xfd\xc5\xfd\xb5\xfd\xb4\xfd\x00\x00\x00\x00\x61\xfd\x5e\xfd\xc2\xfd\xc1\xfd\xc3\xfd\xc4\xfd\xc0\xfd\xec\xfd\x91\xfc\xb6\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\xfd\xba\xfc\xb9\xfc\xb8\xfc\xbf\xfd\xbe\xfd\xad\xfc\xac\xfc\xb7\xfc\xb6\xfc\xb5\xfc\xb4\xfc\xb3\xfc\xb2\xfc\xb1\xfc\xb0\xfc\xaf\xfc\xae\xfc\xab\xfc\xaa\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\x71\xff\xfe\xfd\x00\x00\x00\x00\x00\x00\xe9\xfc\x6f\xff\x6e\xff\x6d\xff\x00\x00\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x47\xfd\x00\x00\x00\x00\x86\xfc\x00\x00\x6f\xfd\x00\x00\x00\x00\x63\xff\x5d\xff\x62\xff\x61\xff\x60\xff\x03\xff\x00\x00\x5f\xff\x5e\xff\x09\xfe\x58\xff\x57\xff\x0c\xfe\x56\xff\x00\x00\x1a\xff\x39\xff\x3a\xff\xb6\xfe\x19\xff\x00\x00\x00\x00\x00\x00\xc8\xfe\xac\xfe\xb4\xfe\x00\x00\x00\x00\x00\x00\x5f\xfd\x00\x00\x8a\xff\x00\x00\x00\x00\x00\x00\x90\xff\xc2\xff\x00\x00\x90\xff\x00\x00\x8d\xff\xb6\xfe\xa7\xfc\xa6\xfc\x00\x00\xb6\xfe\x85\xff\x00\x00\x00\x00\x00\x00\x00\x00\x3c\xfd\x35\xfd\x3d\xfd\xef\xfc\x37\xfd\x00\x00\x00\x00\x00\x00\xac\xfe\x00\x00\xb1\xfe\x00\x00\x00\x00\x00\x00\xa9\xfe\xad\xfe\xae\xfe\x00\x00\xc9\xfe\xc6\xfe\x00\x00\x34\xfd\x00\x00\x00\x00\x00\x00\x5c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x20\xfd\x18\xff\x00\x00\x00\x00\x00\x00\x43\xff\x00\x00\xb4\xfe\x3b\xff\x00\x00\x3c\xff\x3e\xff\x3d\xff\x00\x00\x00\x00\x38\xff\x00\x00\x36\xfe\x00\x00\x0a\xff\x00\x00\x00\xfd\x00\x00\xff\xfc\x01\xfd\x00\x00\x00\x00\x03\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\xfd\x8a\xfc\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfc\x00\x00\xfc\xfc\xfe\xfc\xf8\xfc\xdd\xfc\x00\x00\xde\xfc\x26\xfd\x00\x00\x00\x00\xeb\xfd\x00\x00\x89\xfc\x00\x00\xa0\xfc\x00\x00\xda\xfc\x00\x00\x2a\xfd\xa4\xfc\x00\x00\x32\xfd\x8e\xfe\x00\x00\x00\x00\x48\xfd\x46\xfd\x44\xfd\x43\xfd\x40\xfd\x00\x00\x00\x00\xbd\xfe\xf1\xfd\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x34\xfd\xd0\xfe\x00\x00\xd3\xfe\xd3\xfe\x00\x00\x00\x00\xac\xfe\x70\xff\xb0\xfd\x24\xfd\xb1\xfd\x00\x00\x00\x00\x00\x00\xa2\xfd\xc4\xfd\x00\x00\x00\x00\x68\xff\x68\xff\x00\x00\x00\x00\x00\x00\xca\xfd\x62\xfd\x62\xfd\xcb\xfd\xb2\xfd\xb3\xfd\xa0\xfd\x9a\xfd\x00\x00\x00\x00\xdd\xfc\xde\xfc\x00\x00\x2f\xfd\x00\x00\x8f\xfd\x00\x00\x8e\xfd\x29\xfd\xd3\xfd\xd4\xfd\xd5\xfd\xe0\xfd\x68\xfd\x69\xfd\x00\x00\x6c\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\x5d\xfd\x00\x00\x90\xfc\x5a\xfd\xdd\xfd\x00\x00\xcd\xfd\x74\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\xfd\xda\xfd\x00\x00\x7d\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\xfd\x56\xfe\x55\xfe\x67\xfe\x66\xfe\x51\xfe\x03\xfd\x44\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xfe\x00\x00\x15\xfd\x00\x00\x00\x00\x5e\xfe\x00\x00\x53\xfe\x00\x00\x00\x00\x1b\xfe\x19\xfe\x88\xfe\x00\x00\x60\xfe\x61\xfe\x84\xfe\x85\xfe\x00\x00\x3e\xfe\x3d\xfe\x3a\xfe\x38\xfe\x37\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6d\xfe\x00\x00\x6b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xfe\x70\xfe\x00\x00\xe9\xff\x00\x00\x00\x00\xb2\xff\x8d\xff\xb6\xfe\xb6\xfe\xb1\xff\xac\xff\xac\xff\xb0\xff\xae\xff\xaf\xff\x91\xff\xed\xff\xa8\xfc\xa9\xfc\xea\xff\x00\x00\xd6\xff\xdd\xff\xda\xff\xdc\xff\xdb\xff\xde\xff\xec\xff\x2f\xfe\x80\xfe\x7e\xfe\x75\xfe\x76\xfe\x78\xfe\x00\x00\x6c\xfe\x71\xfe\x6a\xfe\x7d\xfe\x00\x00\x00\x00\x3f\xfe\x82\xfe\x83\xfe\x00\x00\x00\x00\x5f\xfe\x00\x00\x00\x00\x00\x00\x59\xfe\x00\x00\x1c\xfd\x1f\xfd\xa5\xfc\x1a\xfd\x58\xfe\x00\x00\xa1\xfc\x1d\xfd\x1e\xfd\x5a\xfe\x5b\xfe\x00\x00\x00\x00\xf5\xfc\x14\xfd\x00\x00\x00\x00\x0b\xfd\x0a\xfd\x62\xfe\x09\xfd\x57\xfe\x0c\xfd\x0d\xfd\x10\xfd\x43\xfe\x00\x00\x45\xfe\x30\xfd\x38\xfd\xeb\xfc\x2e\xfd\x25\xfd\xf9\xfc\x93\xfc\x94\xfc\x95\xfc\x96\xfc\x97\xfc\xd9\xfd\x00\x00\x59\xfd\x56\xfd\x53\xfd\x00\x00\xe9\xfc\x55\xfd\xc6\xfd\xea\xfc\x5c\xfd\xd6\xfd\x00\x00\x00\x00\x00\x00\x7b\xfd\x79\xfd\x75\xfd\x72\xfd\x00\x00\xde\xfd\x00\x00\x00\x00\xdc\xfd\xdb\xfd\x6b\xfd\xcf\xfd\x69\xfd\x00\x00\xd0\xfd\x00\x00\x00\x00\x00\x00\x6a\xfd\x00\x00\xb7\xfd\x8d\xfd\x00\x00\x00\x00\xec\xfc\x91\xfd\x96\xfd\xb8\xfd\x97\xfd\x90\xfd\x95\xfd\xb9\xfd\x00\x00\x00\x00\x63\xfd\x00\x00\xae\xfd\xab\xfd\xac\xfd\x9b\xfd\x9c\xfd\x00\x00\x00\x00\xaa\xfd\xad\xfd\x22\xfd\x00\x00\x23\xfd\x21\xfd\x00\x00\x01\xfe\x8a\xfe\x00\x00\x00\x00\x08\xfe\xd4\xfe\x90\xfe\x07\xfe\xa5\xfd\xa4\xfd\x00\x00\x4c\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xec\xfe\xed\xfe\xfb\xfd\x48\xfe\x00\x00\x00\x00\xbb\xfe\x00\x00\xc4\xfe\xc3\xfe\x00\x00\x00\x00\xfa\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xfd\x2c\xfd\x88\xfc\xbb\xfd\xa2\xfc\xec\xfc\x98\xfd\xbc\xfd\xbd\xfd\x00\x00\xba\xfd\xea\xfd\x7e\xfc\x00\x00\x99\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xfd\x85\xfc\x00\x00\x15\xff\x00\x00\x8a\xfe\xe3\xfd\xe2\xfd\x00\x00\xe1\xfd\x0b\xfe\xcc\xfe\x03\xfe\x00\x00\x00\x00\x00\x00\xe1\xfe\x31\xfe\x13\xff\x44\xfe\x3f\xff\x8c\xfe\x8a\xfe\xb6\xfe\x00\x00\x00\x00\xa2\xfe\xa6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x11\xff\x4a\xff\x00\x00\x3e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x9b\xfe\x9a\xfe\x99\xfe\x98\xfe\x97\xfe\x00\x00\x00\x00\x28\xfd\x00\x00\x00\x00\xf7\xfe\xf4\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xc5\xfe\x00\x00\x59\xff\xca\xfe\x5b\xff\xac\xfe\x00\x00\x3f\xfd\xb5\xfe\x5a\xff\xb4\xfe\x00\x00\x08\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x90\xfe\x8b\xff\x88\xff\x87\xff\x86\xff\xac\xff\xbc\xff\xac\xff\xbb\xff\xb8\xff\x65\xff\xbd\xff\x8f\xff\xb9\xff\xba\xff\x00\x00\xb6\xfe\x00\x00\x81\xff\x89\xff\x00\x00\x00\x00\xa1\xfe\x9f\xfe\x00\x00\x00\x00\x00\x00\xb3\xfe\x00\x00\xa7\xfe\xab\xfe\xcb\xfe\x00\x00\x00\x00\x00\x00\x70\xfd\xf9\xfe\xfa\xfe\x00\x00\xf2\xfe\xf3\xfe\xee\xfe\x00\x00\xf6\xfe\x00\x00\x9d\xfe\x00\x00\x95\xfe\x94\xfe\x96\xfe\x00\x00\x00\x00\x9c\xfe\x4d\xff\x4e\xff\x53\xff\x00\x00\x00\x00\x37\xff\x00\x00\x00\x00\x01\xff\xff\xfe\xfe\xfe\xfb\xfe\xfc\xfe\x44\xff\x45\xff\x47\xff\x46\xff\xd7\xfe\x00\x00\xa3\xfe\xb8\xfe\x00\x00\x43\xff\x00\x00\x00\x00\x4f\xff\x00\x00\x35\xfe\x33\xfe\x00\x00\x55\xff\x00\x00\x0b\xff\x00\x00\xcc\xfe\x05\xfe\x04\xfe\x00\x00\x87\xfc\x15\xff\x00\x00\x06\xff\x3e\xfe\x2c\xfe\x16\xfe\x00\x00\x21\xfe\x04\xff\x00\x00\xe6\xfd\x84\xfc\x83\xfc\x8b\xfc\x8c\xfc\x8d\xfc\x8e\xfc\x8f\xfc\x74\xfe\xe7\xfd\xe9\xfd\x00\x00\xa7\xfd\x94\xfd\xa3\xfc\xfb\xfc\xf7\xfc\x31\xfd\x8d\xfe\xfd\xfd\x45\xfd\x42\xfd\x36\xfd\x41\xfd\xf9\xfd\xf3\xfd\xf0\xfd\x00\x00\x00\x00\xbb\xfe\xba\xfe\x00\x00\xf3\xfd\xf6\xfd\xfc\xfd\x33\xfd\xcf\xfe\x4d\xfd\xd2\xfe\xd5\xfe\x00\x00\xce\xfe\xd1\xfe\x00\x00\xff\xfd\x05\xfd\x6b\xff\x06\xfd\x04\xfd\x00\x00\x9e\xfd\x9d\xfd\x6a\xff\x67\xfd\x64\xfd\x66\xfd\x9f\xfd\xa1\xfd\xa8\xfd\x93\xfd\x92\xfd\x9a\xfd\x87\xfd\x89\xfd\x86\xfd\x84\xfd\x81\xfd\x80\xfd\x00\x00\x8b\xfd\x88\xfd\xd1\xfd\x6e\xfd\x00\x00\x98\xfc\x00\x00\x80\xfc\x77\xfc\x00\x00\x00\x00\x99\xfc\x00\x00\x9c\xfc\x00\x00\x82\xfc\x7a\xfc\x69\xfd\x00\x00\x9d\xfc\xc9\xfd\xd2\xfd\x00\x00\x00\x00\x00\x00\x73\xfd\xcc\xfd\x00\x00\x00\x00\x00\x00\xc7\xfd\x52\xfe\x00\x00\x02\xfd\x42\xfe\x41\xfe\x40\xfe\x00\x00\x00\x00\x89\xfe\x00\x00\x18\xfe\x1a\xfe\xee\xfc\x00\x00\x3c\xfe\x00\x00\x77\xfe\x00\x00\xd9\xff\xd8\xff\xd7\xff\x00\x00\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x4e\xfe\x5d\xfe\x00\x00\x57\xfd\x54\xfd\x51\xfd\x4f\xfd\x71\xfd\x7a\xfd\xdd\xfd\x9f\xfc\x81\xfc\x7b\xfc\x9e\xfc\x76\xfc\xcc\xfe\x76\xfd\x00\x00\x9b\xfc\x7f\xfc\x78\xfc\x9a\xfc\x75\xfc\x7f\xfd\xcc\xfc\x00\x00\x00\x00\x8c\xfd\x65\xfd\x69\xff\x92\xff\x00\x00\x00\xfe\x4b\xfd\xd6\xfe\x4e\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xbc\xfe\xbe\xfe\xef\xfd\x00\x00\xe8\xfd\x05\xff\x27\xfe\x25\xfe\x00\x00\x3e\xfe\x14\xff\x51\xff\x15\xfe\x13\xfe\x00\x00\x16\xfe\x00\x00\x00\x00\x00\x00\x2c\xfe\x16\xfe\xcd\xfe\x06\xfe\x00\x00\xe2\xfe\xe5\xfe\xe5\xfe\x30\xfe\x31\xfe\x31\xfe\x12\xff\x54\xff\x8b\xfe\x00\x00\xb7\xfe\xa5\xfe\x00\x00\x4b\xff\x00\x00\xfd\xfe\x0f\xff\x10\xff\x32\xff\x00\x00\x27\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9e\xfe\x27\xfd\x00\x00\xf5\xfe\xf8\xfe\x00\x00\x00\x00\xc2\xfe\xc0\xfe\x00\x00\x3e\xfd\xaf\xfe\xa0\xfe\x07\xfd\x8f\xfe\x0a\xfe\x83\xff\x82\xff\x00\x00\x00\x00\xab\xff\xa6\xff\xa5\xff\x00\x00\xa8\xff\x00\x00\x67\xff\x64\xff\x8e\xff\x93\xff\x66\xff\xc3\xff\x90\xff\x90\xff\xa0\xff\x98\xff\x94\xff\x19\xfd\x95\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xfe\xad\xff\xc4\xff\x00\x00\x84\xff\xc1\xfe\x00\x00\xd3\xfe\xd3\xfe\xf1\xfe\x91\xfe\x00\x00\x00\x00\x00\x00\x36\xff\x00\x00\x52\xff\x00\x00\xd8\xfe\xdb\xfe\xdb\xfe\xa4\xfe\x02\xff\x34\xfe\x32\xfe\xeb\xfe\xe6\xfe\x00\x00\xea\xfe\x21\xff\x00\x00\x00\x00\x00\x00\x02\xfe\x49\xff\x16\xfe\x07\xff\x00\x00\x29\xfe\x29\xfe\x50\xff\x00\x00\x12\xfe\x0f\xfe\x40\xff\x42\xff\x41\xff\x00\x00\x14\xfe\x00\x00\x00\x00\x7b\xfe\x20\xfe\x23\xfe\x00\x00\x21\xfe\xf7\xfd\xbb\xfe\x00\x00\x87\xfe\xf4\xfd\xf8\xfd\x6c\xff\x8a\xfd\x83\xfd\x82\xfd\x85\xfd\x00\x00\x00\x00\x00\x00\x79\xfc\x77\xfd\x78\xfd\x7c\xfc\x00\x00\x00\x00\x00\x00\x54\xfe\x17\xfe\x3b\xfe\x39\xfe\x00\x00\xc9\xff\x8a\xff\x00\x00\x00\x00\x00\x00\xb6\xff\x90\xff\x90\xff\xb7\xff\xb3\xff\xb4\xff\xcd\xff\xca\xff\xd4\xff\xe7\xff\xc6\xfc\xb6\xfe\x00\x00\xcc\xff\x50\xfd\x52\xfd\x00\x00\x7e\xfd\x7d\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x26\xfe\x43\xfe\x00\x00\x00\x00\x00\x00\x22\xfe\x47\xfe\x00\x00\x0e\xfe\x10\xfe\x11\xfe\x00\x00\x2a\xfe\x00\x00\x00\x00\x00\x00\x08\xff\x48\xff\xe4\xfe\xe7\xfe\x23\xff\x0e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x20\xff\xe3\xfe\xe0\xfe\x1f\xff\xdc\xfe\x00\x00\xdf\xfe\x17\xff\x16\xff\x1f\xff\x00\x00\x31\xff\x29\xff\x29\xff\x00\x00\x00\x00\x92\xfe\x93\xfe\x00\x00\x00\x00\xc7\xfe\x85\xff\xa7\xff\x00\x00\x00\x00\x00\x00\xa2\xff\x97\xff\xa3\xff\xa1\xff\x96\xff\xa4\xff\x9e\xff\x00\x00\x00\x00\xbf\xff\xbe\xff\x00\x00\x9d\xff\x9b\xff\x9a\xff\x99\xff\x18\xfd\x17\xfd\x16\xfd\x81\xff\xf0\xfe\xef\xfe\x28\xff\x35\xff\x33\xff\x00\x00\x2a\xff\x00\x00\x00\x00\x00\x00\xda\xfe\xdd\xfe\x00\x00\x1e\xff\xd9\xfe\x03\xff\x13\xff\x00\x00\x0e\xff\x22\xff\x25\xff\x00\x00\x00\x00\xe8\xfe\x00\x00\x2e\xfe\x00\x00\x29\xfe\x2d\xfe\x0d\xfe\x00\x00\x20\xfe\x24\xfe\xa2\xfc\x1f\xfe\x1e\xfe\xa0\xfc\xbf\xfe\xb9\xfe\x86\xfe\x00\x00\xce\xfd\xb6\xfe\xac\xff\xc5\xff\x00\x00\xc6\xff\x00\x00\xcb\xff\x00\x00\xd0\xff\xce\xff\x00\x00\xe3\xff\x00\x00\x00\x00\xac\xff\x7c\xfd\x1d\xfe\x46\xfe\x2b\xfe\x00\x00\x09\xff\x00\x00\x64\xfe\x63\xfe\x00\x00\x0d\xff\x24\xff\x00\x00\xe9\xfe\x26\xff\x00\x00\x1d\xff\xde\xfe\x2e\xff\x30\xff\x2b\xff\x2d\xff\x2f\xff\x34\xff\x7f\xff\x00\x00\x9f\xff\x9c\xff\x7d\xff\x00\x00\x2c\xff\x15\xff\x00\x00\x28\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xe4\xff\x00\x00\xd3\xff\xd1\xff\xd2\xff\xcf\xff\xe5\xff\x00\x00\x00\x00\xe2\xff\x00\x00\xc7\xff\x00\x00\x0c\xff\x2c\xfe\x16\xfe\x80\xff\x8c\xff\x7e\xff\x00\x00\x79\xff\xa0\xff\x00\x00\x7a\xff\x75\xff\x00\x00\x00\x00\x77\xff\x79\xff\x1c\xff\x16\xfe\xc8\xff\x00\x00\x00\x00\xe1\xff\xdf\xff\xe0\xff\x1b\xff\x00\x00\x72\xff\x73\xff\x78\xff\x7c\xff\x74\xff\x76\xff\x7b\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x0e\x00\x05\x00\x06\x00\x4d\x00\x68\x00\x06\x00\x3b\x00\x4f\x00\x4f\x00\x04\x00\x50\x00\xad\x00\x07\x00\x08\x00\x09\x00\x04\x00\x0b\x00\xc2\x00\x0e\x00\x08\x00\x09\x00\x04\x00\x0b\x00\xe3\x00\x4a\x00\x08\x00\x09\x00\x69\x00\x0b\x00\x08\x00\x09\x00\x09\x00\x0b\x00\x0b\x00\x3c\x00\x58\x00\x90\x00\x5a\x00\x69\x00\x80\x00\x81\x00\x01\x00\x5b\x00\x80\x00\x81\x00\x00\x00\x09\x00\x05\x00\x00\x00\x5b\x00\x67\x00\x6a\x00\x12\x00\x3d\x00\x3e\x00\x6c\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x4e\x00\x72\x00\x73\x00\x5b\x00\x00\x00\x17\x00\x16\x01\x4a\x00\x6a\x00\x4a\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x1d\x00\x00\x00\x35\x00\x12\x00\x3d\x00\x3e\x00\x2e\x00\x27\x00\x28\x00\x29\x00\x80\x00\x81\x00\x0c\x00\x00\x00\x2b\x00\x0c\x00\x30\x01\x22\x00\x23\x00\xf1\x00\x28\x00\x29\x00\x36\x01\x3f\x00\x40\x00\x00\x00\x4a\x00\x78\x00\x3b\x01\x79\x00\x28\x00\x29\x00\x6a\x00\x1d\x01\x1e\x01\x37\x00\x38\x00\x39\x00\x35\x00\x36\x00\x3f\x01\x4a\x00\x28\x00\x29\x00\x8f\x00\x37\x00\x38\x00\x39\x00\x52\x00\x83\x00\x54\x00\x83\x00\x28\x00\x29\x00\x8e\x00\x8f\x00\x8f\x00\x83\x00\xb6\x00\x39\x00\x29\x01\x66\x00\x2b\x01\x94\x00\x00\x00\xb6\x00\x72\x00\xc3\x00\xc4\x00\xc2\x00\x6c\x00\x52\x00\xc8\x00\x36\x01\x4a\x00\x69\x00\xcc\x00\x4a\x00\x69\x00\xb6\x00\xd0\x00\x72\x00\xd2\x00\x76\x00\x72\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xe3\x00\xda\x00\xdb\x00\xdc\x00\x94\x00\x69\x00\x3d\x01\x17\x01\x10\x01\x11\x01\x0b\x00\x13\x01\x14\x01\x15\x01\xbc\x00\xbd\x00\xbe\x00\x69\x00\xc7\x00\x29\x01\x24\x01\x2b\x01\x26\x01\x27\x01\x82\x00\x72\x00\x72\x00\x4b\x00\x72\x00\x69\x00\x3e\x00\x3f\x00\x36\x01\x31\x01\x52\x00\x33\x01\x34\x01\x35\x01\x72\x00\x37\x01\x30\x01\x69\x00\x3a\x01\x3b\x01\x05\x01\x06\x01\x36\x01\x1d\x01\x1e\x01\x39\x01\x72\x00\x30\x01\xe0\x00\x0e\x01\x0f\x01\x30\x01\x18\x00\x36\x01\x13\x01\x14\x01\x15\x01\x36\x01\x30\x01\x2b\x01\x2b\x01\x2b\x01\x4a\x00\x73\x00\x36\x01\x3e\x00\x3f\x00\x1d\x01\x1e\x01\x30\x01\x36\x01\x36\x01\x36\x01\x6d\x00\xe0\x00\x36\x01\x69\x00\x2c\x01\x4d\x00\x2c\x01\x2d\x01\x30\x01\x2f\x01\x30\x01\x16\x01\x72\x00\x94\x00\x36\x01\x3f\x01\x36\x01\x41\x01\x38\x01\x39\x01\x30\x01\x2c\x01\x3c\x01\x22\x01\x23\x01\x30\x01\x36\x01\x0e\x01\x0f\x01\x72\x00\x00\x00\x36\x01\x13\x01\x14\x01\x15\x01\x2c\x01\x17\x01\x52\x00\x00\x00\x30\x01\x66\x00\x34\x01\x35\x01\x73\x00\x37\x01\x36\x01\x2c\x01\x2c\x01\x3b\x01\x2c\x01\x30\x01\x30\x01\x27\x01\x30\x01\xbd\x00\xbe\x00\x36\x01\x36\x01\x2d\x01\x36\x01\x2f\x01\x30\x01\x31\x01\x3e\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3e\x01\x36\x01\x1b\x01\x3e\x01\x1d\x01\x1e\x01\x2c\x01\x36\x01\x3e\x01\x6d\x00\x30\x01\xa1\x00\x1b\x01\x36\x01\x1d\x01\x1e\x01\x36\x01\x36\x01\x36\x01\x18\x00\x2d\x01\x00\x00\x2f\x01\x30\x01\x1b\x01\x4a\x00\x1d\x01\x1e\x01\x12\x00\x36\x01\x2d\x01\x00\x00\x2f\x01\x30\x01\x1b\x01\x4c\x00\x1d\x01\x1e\x01\x2b\x00\x36\x01\x47\x00\x00\x00\x2d\x01\x4d\x00\x2f\x01\x30\x01\x1b\x01\x76\x00\x1d\x01\x1e\x01\x05\x00\x36\x01\x2d\x01\x13\x00\x2f\x01\x30\x01\x1b\x01\x4d\x00\x1d\x01\x1e\x01\x83\x00\x36\x01\xa1\x00\x35\x00\x2d\x01\x72\x00\x2f\x01\x30\x01\x17\x00\x67\x00\x69\x00\x53\x00\x54\x00\x36\x01\x2d\x01\x74\x00\x2f\x01\x30\x01\x3b\x00\x72\x00\x79\x00\x2f\x00\x30\x00\x36\x01\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x59\x00\x48\x00\x2c\x01\xac\x00\xad\x00\x73\x00\x30\x01\xaa\x00\xab\x00\xac\x00\xad\x00\x4d\x00\x36\x01\x4e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x59\x00\x5a\x00\x52\x00\x4a\x00\x66\x00\x05\x00\x00\x01\x01\x01\x4d\x00\x62\x00\x63\x00\x96\x00\x1e\x01\x78\x00\x67\x00\x21\x01\x63\x00\x9c\x00\x69\x00\x6c\x00\x9f\x00\xa0\x00\xa1\x00\x17\x00\xa3\x00\xa4\x00\x85\x00\x72\x00\x69\x00\x6d\x00\x96\x00\x73\x00\x65\x00\x52\x00\x6c\x00\x73\x00\x9c\x00\x72\x00\x69\x00\x9f\x00\xa0\x00\xa1\x00\x59\x00\xa3\x00\xa4\x00\x77\x00\x73\x00\x72\x00\x3b\x00\x7b\x00\x8b\x00\x2d\x01\x2e\x01\x2f\x01\x30\x01\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x36\x01\x48\x00\x0e\x01\x0f\x01\x4c\x00\xcc\x00\x73\x00\x13\x01\x14\x01\x15\x01\x54\x00\x1f\x01\x20\x01\x78\x00\x4a\x00\x52\x00\x58\x00\x54\x00\x59\x00\x5a\x00\xdb\x00\x10\x00\x90\x00\x61\x00\xcc\x00\x61\x00\x85\x00\x62\x00\x63\x00\xff\x00\x00\x01\x01\x01\x67\x00\x2d\x01\x82\x00\x2f\x01\x30\x01\x6c\x00\x21\x00\xdb\x00\x52\x00\x52\x00\x36\x01\x3f\x01\x38\x01\x39\x01\xc3\x00\x72\x00\x78\x00\x79\x00\x29\x01\xc8\x00\x2b\x01\x77\x00\x72\x00\xcc\x00\x29\x01\x7b\x00\x2b\x01\xd0\x00\x6d\x00\xd2\x00\x52\x00\x36\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x8b\x00\x36\x01\xdb\x00\xdc\x00\x52\x00\x73\x00\x73\x00\x2d\x01\x2e\x01\x2f\x01\x30\x01\x02\x01\x0b\x00\x6c\x00\x19\x01\x1a\x01\x36\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x34\x00\x6f\x00\x77\x00\x67\x00\xa1\x00\x73\x00\x1b\x00\x4d\x00\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\x52\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x3e\x00\x3f\x00\x36\x01\x05\x01\x06\x01\x6b\x00\xb4\x00\xb5\x00\x29\x01\x2a\x01\x2b\x01\x57\x00\x0e\x01\x0f\x01\x2e\x01\xc3\x00\x30\x01\x13\x01\x14\x01\x15\x01\xc8\x00\x36\x01\x36\x01\x6f\x00\xcc\x00\xab\x00\xac\x00\xad\x00\xd0\x00\x01\x00\xd2\x00\x85\x00\x18\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd3\x00\x13\x00\xdb\x00\xdc\x00\x4d\x00\x2c\x01\x2d\x01\x6d\x00\x2f\x01\x30\x01\x6d\x00\x17\x01\x15\x00\x73\x00\x2b\x00\x36\x01\x73\x00\x38\x01\x39\x01\x6b\x00\x58\x00\x3c\x01\xa4\x00\x5b\x00\x24\x01\x3b\x00\x26\x01\x27\x01\x52\x00\x2f\x00\x30\x00\x31\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x31\x01\x48\x00\x33\x01\x34\x01\x35\x01\x4a\x00\x37\x01\x05\x01\x06\x01\x3a\x01\x3b\x01\xaa\x00\xab\x00\xac\x00\xad\x00\x78\x00\x0e\x01\x0f\x01\x59\x00\x5a\x00\x6f\x00\x13\x01\x14\x01\x15\x01\x73\x00\xcc\x00\xa1\x00\x62\x00\x63\x00\x29\x01\x67\x00\x2b\x01\x67\x00\x18\x00\xb4\x00\xb5\x00\x53\x00\x6c\x00\x0e\x01\x0f\x01\xdb\x00\x72\x00\x36\x01\x13\x01\x14\x01\x15\x01\x2c\x01\x2d\x01\x18\x00\x2f\x01\x30\x01\x58\x00\x2b\x00\x4c\x00\x53\x00\x5c\x00\x36\x01\x6d\x00\x38\x01\x39\x01\x61\x00\x54\x00\x3c\x01\x73\x00\x4c\x00\xd3\x00\x3b\x00\x2b\x00\x8b\x00\x2d\x01\x1d\x00\x2f\x01\x30\x01\xb4\x00\xb5\x00\x00\x00\x58\x00\x29\x01\x36\x01\x2b\x01\x38\x01\x39\x01\x07\x00\x78\x00\x2b\x00\x61\x00\x6d\x00\x7c\x00\x53\x00\x54\x00\x36\x01\x63\x00\x73\x00\x32\x00\x33\x00\x58\x00\x58\x00\x5a\x00\x79\x00\x18\x00\x5c\x00\x6d\x00\x19\x01\x1a\x01\xd3\x00\x61\x00\x1d\x01\x1e\x01\x78\x00\x79\x00\x67\x00\x1e\x00\x7c\x00\x7d\x00\x9e\x00\x6c\x00\x1d\x01\x1e\x01\x29\x01\xa1\x00\x2b\x01\x72\x00\x73\x00\x67\x00\xc3\x00\x2c\x00\x2d\x00\x19\x00\x78\x00\xc8\x00\x2b\x01\x36\x01\x63\x00\xcc\x00\x72\x00\x66\x00\x1d\x00\xd0\x00\x29\x01\xd2\x00\x2b\x01\x36\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x2c\x00\x2d\x00\xdb\x00\xdc\x00\x2b\x00\x36\x01\x4d\x00\x4e\x00\x0f\x01\x96\x00\x67\x00\x52\x00\x13\x01\x54\x00\x55\x00\x9c\x00\x56\x00\x1d\x00\x9f\x00\xa0\x00\xa1\x00\x72\x00\xa3\x00\xa4\x00\x6c\x00\x6a\x00\x85\x00\x6c\x00\x6b\x00\x6e\x00\x65\x00\x2b\x00\x67\x00\xa4\x00\x69\x00\x77\x00\x73\x00\x2c\x01\x77\x00\x7b\x00\x6c\x00\x30\x01\x7b\x00\x72\x00\x05\x01\x06\x01\x6d\x00\x36\x01\x3b\x00\x38\x01\x39\x01\x77\x00\x73\x00\x0e\x01\x0f\x01\x7b\x00\xc3\x00\xc4\x00\x13\x01\x14\x01\x15\x01\xc8\x00\x2c\x01\xcc\x00\x6d\x00\xcc\x00\x30\x01\x3e\x00\x3f\x00\xd0\x00\x73\x00\xd2\x00\x36\x01\xcc\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xdb\x00\xda\x00\xdb\x00\xdc\x00\x73\x00\x2c\x01\x2d\x01\x9e\x00\x2f\x01\x30\x01\xdb\x00\x17\x01\xa1\x00\x73\x00\x67\x00\x36\x01\x30\x01\x38\x01\x39\x01\x6c\x00\x44\x00\x3c\x01\x36\x01\x29\x01\x24\x01\x2b\x01\x26\x01\x27\x01\x2c\x01\x76\x00\x10\x01\x11\x01\x30\x01\x13\x01\x14\x01\x15\x01\x36\x01\x31\x01\x36\x01\x33\x01\x34\x01\x35\x01\xa1\x00\x37\x01\x05\x01\x06\x01\x3a\x01\x3b\x01\x6b\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x0e\x01\x0f\x01\xa1\x00\x73\x00\x6f\x00\x13\x01\x14\x01\x15\x01\x73\x00\x19\x01\x1a\x01\x67\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x54\x00\x39\x01\x19\x01\x1a\x01\x67\x00\x72\x00\x1d\x01\x1e\x01\x29\x01\x2a\x01\x2b\x01\x67\x00\x10\x00\x2c\x01\x2d\x01\x72\x00\x2f\x01\x30\x01\x29\x01\x3b\x00\x2b\x01\x36\x01\x72\x00\x36\x01\x10\x00\x38\x01\x39\x01\x67\x00\x67\x00\x3c\x01\x83\x00\x36\x01\xaa\x00\xab\x00\xac\x00\xad\x00\xc3\x00\xc4\x00\x72\x00\x72\x00\x6a\x00\xc8\x00\x6c\x00\x3b\x00\x6e\x00\xcc\x00\x77\x00\x4e\x00\x72\x00\xd0\x00\x7b\x00\xd2\x00\x53\x00\x77\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x17\x01\xda\x00\xdb\x00\xdc\x00\x6d\x00\x67\x00\x3a\x01\x3b\x01\x96\x00\x72\x00\x6c\x00\x3f\x01\x67\x00\x24\x01\x9c\x00\x26\x01\x27\x01\x9f\x00\xa0\x00\xa1\x00\x76\x00\xa3\x00\xa4\x00\x72\x00\xa1\x00\x4c\x00\x31\x01\x4e\x00\x33\x01\x34\x01\x35\x01\xa1\x00\x37\x01\x0e\x01\x0f\x01\x3a\x01\x3b\x01\x58\x00\x13\x01\x14\x01\x15\x01\x5c\x00\x03\x01\x04\x01\x05\x01\x06\x01\x61\x00\x2c\x01\x29\x01\x72\x00\x2b\x01\x30\x01\x4a\x00\x0e\x01\x0f\x01\x4c\x00\x2b\x01\x36\x01\x13\x01\x14\x01\x15\x01\x36\x01\xcc\x00\x54\x00\x2e\x01\x74\x00\x30\x01\x36\x01\x67\x00\x78\x00\x79\x00\x6b\x00\x36\x01\x7c\x00\x7d\x00\x38\x01\x39\x01\xdb\x00\x6a\x00\x73\x00\x6c\x00\x4d\x00\x6e\x00\x2c\x01\x2d\x01\x3b\x00\x2f\x01\x30\x01\x6d\x00\x34\x01\x35\x01\x77\x00\x37\x01\x36\x01\x73\x00\x38\x01\x39\x01\xc3\x00\xc4\x00\x3c\x01\x79\x00\x29\x01\xc8\x00\x2b\x01\x7d\x00\x2e\x01\xcc\x00\x30\x01\x54\x00\x4e\x00\xd0\x00\x55\x00\xd2\x00\x36\x01\x36\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x83\x00\xda\x00\xdb\x00\xdc\x00\x33\x01\x34\x01\x35\x01\x7c\x00\x37\x01\x7e\x00\x67\x00\x3a\x01\x3b\x01\x30\x01\x0c\x00\x6c\x00\x3f\x01\x6e\x00\x6f\x00\x36\x01\x19\x01\x1a\x01\x39\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x0e\x01\x0f\x01\x4d\x00\x4e\x00\x12\x01\x13\x01\x14\x01\x15\x01\x29\x01\x2a\x01\x2b\x01\x2e\x01\x14\x00\x30\x01\x03\x01\x04\x01\x05\x01\x06\x01\x1a\x00\x36\x01\x1c\x00\x36\x01\x3e\x00\x3f\x00\x77\x00\x0e\x01\x0f\x01\x96\x00\x7b\x00\x10\x00\x13\x01\x14\x01\x15\x01\x9c\x00\x6c\x00\x4e\x00\x9f\x00\xa0\x00\xa1\x00\x52\x00\xa3\x00\xa4\x00\x38\x01\x39\x01\x10\x01\x11\x01\x52\x00\x13\x01\x14\x01\x15\x01\x33\x01\x34\x01\x35\x01\x54\x00\x37\x01\x2c\x01\x2d\x01\x4c\x00\x2f\x01\x30\x01\x3b\x00\x2d\x01\x6f\x00\x2f\x01\x30\x01\x36\x01\x73\x00\x38\x01\x39\x01\x58\x00\x36\x01\x3c\x01\x57\x00\x5c\x00\xc3\x00\xc4\x00\x13\x00\x14\x00\x61\x00\xc8\x00\x17\x00\xcc\x00\x30\x01\xcc\x00\x44\x00\x39\x01\x55\x00\xd0\x00\x36\x01\xd2\x00\x38\x01\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xdb\x00\xda\x00\xdb\x00\xdc\x00\x72\x00\x78\x00\x79\x00\x83\x00\x67\x00\x7c\x00\x7d\x00\x34\x01\x35\x01\x6c\x00\x37\x01\x6e\x00\x6f\x00\x2d\x01\x3b\x01\x2f\x01\x30\x01\x1a\x01\x3f\x01\x96\x00\x1d\x01\x1e\x01\x36\x01\x57\x00\x66\x00\x9c\x00\x68\x00\x4c\x00\x9f\x00\xa0\x00\xa1\x00\x4d\x00\xa3\x00\xa4\x00\x6a\x00\x54\x00\x6c\x00\x4a\x00\x6e\x00\x58\x00\x05\x01\x06\x01\x6d\x00\x5c\x00\x2e\x01\x73\x00\x30\x01\x77\x00\x61\x00\x0e\x01\x0f\x01\x7b\x00\x36\x01\x6f\x00\x13\x01\x14\x01\x15\x01\x73\x00\x19\x01\x1a\x01\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x73\x00\x45\x00\x46\x00\x47\x00\x48\x00\x78\x00\x79\x00\xcc\x00\x29\x01\x2a\x01\x2b\x01\x4d\x00\x4e\x00\x2c\x01\x2d\x01\x1a\x01\x2f\x01\x30\x01\x1d\x01\x1e\x01\x4c\x00\x36\x01\xdb\x00\x36\x01\x4e\x00\x38\x01\x39\x01\x3b\x00\x52\x00\x3c\x01\xc3\x00\xc4\x00\x58\x00\x4d\x00\x4e\x00\xc8\x00\x5c\x00\x2f\x01\x30\x01\xcc\x00\x66\x00\x61\x00\x68\x00\xd0\x00\x36\x01\xd2\x00\x38\x01\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x6d\x00\xda\x00\xdb\x00\xdc\x00\x58\x00\x66\x00\x5a\x00\x68\x00\x74\x00\x5f\x00\x16\x01\x1a\x01\x78\x00\x79\x00\x1d\x01\x1e\x01\x7c\x00\x7d\x00\x6d\x00\x67\x00\x0e\x01\x0f\x01\x22\x01\x23\x01\x6c\x00\x13\x01\x14\x01\x15\x01\x6d\x00\x66\x00\x72\x00\x68\x00\x19\x01\x1a\x01\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x34\x01\x35\x01\x4e\x00\x37\x01\x05\x01\x06\x01\x52\x00\x3b\x01\x29\x01\x2a\x01\x2b\x01\x77\x00\x77\x00\x0e\x01\x0f\x01\x7b\x00\x7b\x00\x6d\x00\x13\x01\x14\x01\x15\x01\x36\x01\x38\x01\x39\x01\x96\x00\xed\x00\xee\x00\xef\x00\x9a\x00\xf1\x00\x9c\x00\x6d\x00\x3b\x01\x9f\x00\xa0\x00\xa1\x00\x3f\x01\xa3\x00\xa4\x00\x2d\x01\x73\x00\x2f\x01\x30\x01\x2c\x01\x2d\x01\x52\x00\x2f\x01\x30\x01\x36\x01\x66\x00\x54\x00\x68\x00\x66\x00\x36\x01\x68\x00\x38\x01\x39\x01\x3b\x00\x4c\x00\x3c\x01\x86\x00\x87\x00\x88\x00\x4a\x00\x10\x01\x11\x01\x54\x00\x13\x01\x14\x01\x15\x01\x58\x00\xc3\x00\xc4\x00\x66\x00\x5c\x00\x68\x00\xc8\x00\x73\x00\xcc\x00\x61\x00\xcc\x00\x3e\x00\x3f\x00\x55\x00\xd0\x00\x66\x00\xd2\x00\x68\x00\x0c\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xdb\x00\xda\x00\xdb\x00\xdc\x00\x66\x00\x74\x00\x68\x00\x6b\x00\x67\x00\x78\x00\x79\x00\x9b\x00\x39\x01\x6c\x00\x6a\x00\x6e\x00\x6c\x00\xa4\x00\x6e\x00\x18\x01\x19\x01\x1a\x01\x6f\x00\x96\x00\x1d\x01\x1e\x01\x66\x00\x77\x00\x68\x00\x9c\x00\x99\x00\x7b\x00\x9f\x00\xa0\x00\xa1\x00\x99\x00\xa3\x00\xa4\x00\x99\x00\x2f\x01\x30\x01\x83\x00\x84\x00\x85\x00\x05\x01\x06\x01\x36\x01\x6d\x00\x38\x01\x39\x01\xaf\x00\xb0\x00\xb1\x00\x0e\x01\x0f\x01\x32\x00\x33\x00\xcc\x00\x13\x01\x14\x01\x15\x01\x6b\x00\x19\x01\x1a\x01\x73\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x4d\x00\x4e\x00\xdb\x00\xc5\x00\xc6\x00\xc7\x00\x54\x00\xcc\x00\x29\x01\x2a\x01\x2b\x01\x4d\x00\x4e\x00\x2c\x01\x2d\x01\x0c\x00\x2f\x01\x30\x01\x3b\x00\x4d\x00\x4e\x00\x36\x01\xdb\x00\x36\x01\x4a\x00\x38\x01\x39\x01\x3e\x00\x3f\x00\x3c\x01\xc3\x00\xc4\x00\xed\x00\xee\x00\xef\x00\xc8\x00\xf1\x00\x02\x00\x03\x00\xcc\x00\x33\x01\x34\x01\x35\x01\xd0\x00\x37\x01\xd2\x00\x02\x00\x03\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4a\x00\xda\x00\xdb\x00\xdc\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x3f\x01\x67\x00\x41\x01\x19\x01\x1a\x01\x54\x00\x6c\x00\x1d\x01\x1e\x01\x64\x00\x65\x00\x66\x00\xc5\x00\xc6\x00\xc7\x00\x66\x00\x76\x00\x68\x00\x66\x00\x29\x01\x68\x00\x2b\x01\x4c\x00\x19\x01\x1a\x01\x72\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x66\x00\x36\x01\x68\x00\x58\x00\x05\x01\x06\x01\x6d\x00\x5c\x00\x29\x01\x2a\x01\x2b\x01\x14\x00\x61\x00\x0e\x01\x0f\x01\x77\x00\x78\x00\xc9\x00\x13\x01\x14\x01\x15\x01\x36\x01\x52\x00\x0e\x01\x0f\x01\x74\x00\x54\x00\x12\x01\x13\x01\x14\x01\x15\x01\x74\x00\xbf\x00\xc0\x00\xc1\x00\x78\x00\x79\x00\x77\x00\x78\x00\x7c\x00\x7d\x00\xca\x00\xcb\x00\x2c\x01\x2d\x01\x3b\x00\x2f\x01\x30\x01\xb7\x00\xb8\x00\xb9\x00\x74\x00\x66\x00\x36\x01\x68\x00\x38\x01\x39\x01\x6d\x00\x66\x00\x3c\x01\x68\x00\x74\x00\xc3\x00\xc4\x00\x6f\x00\x38\x01\x39\x01\xc8\x00\x99\x00\x4b\x00\x4c\x00\xcc\x00\xbf\x00\xc0\x00\xc1\x00\xd0\x00\x66\x00\xd2\x00\x68\x00\x6d\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x6f\x00\xda\x00\xdb\x00\xdc\x00\xef\x00\x67\x00\xf1\x00\x66\x00\x96\x00\x68\x00\x6c\x00\x17\x01\x74\x00\x86\x00\x9c\x00\x88\x00\xa4\x00\x9f\x00\xa0\x00\xa1\x00\x76\x00\xa3\x00\xa4\x00\x83\x00\x24\x01\x85\x00\x26\x01\x27\x01\xca\x00\xcb\x00\x4c\x00\xbf\x00\xc0\x00\xc1\x00\xbf\x00\xc0\x00\xc1\x00\x31\x01\x54\x00\x33\x01\x34\x01\x35\x01\x58\x00\x37\x01\x05\x01\x06\x01\x3a\x01\x3b\x01\xa4\x00\xca\x00\xcb\x00\x61\x00\x67\x00\x0e\x01\x0f\x01\x73\x00\xcc\x00\x54\x00\x13\x01\x14\x01\x15\x01\x72\x00\xcc\x00\x6d\x00\xbf\x00\xc0\x00\xc1\x00\x7a\x00\x7b\x00\x73\x00\x0b\x00\xdb\x00\x40\x01\x41\x01\x78\x00\x79\x00\x6c\x00\xdb\x00\x7c\x00\x7d\x00\x3b\x00\x77\x00\x78\x00\x2c\x01\x2d\x01\x34\x00\x2f\x01\x30\x01\xcc\x00\xbf\x00\xc0\x00\xc1\x00\x18\x00\x36\x01\x4d\x00\x38\x01\x39\x01\xc3\x00\xc4\x00\x3c\x01\x6d\x00\x3b\x00\xc8\x00\xdb\x00\x1f\x01\x20\x01\xcc\x00\x73\x00\x04\x01\x05\x01\xd0\x00\x74\x00\xd2\x00\x10\x00\x11\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x6d\x00\xda\x00\xdb\x00\xdc\x00\x6d\x00\x67\x00\x10\x00\x11\x00\xb0\x00\xb1\x00\x6c\x00\x73\x00\x1d\x01\x1e\x01\x19\x01\x1a\x01\x40\x01\x41\x01\x1d\x01\x1e\x01\x19\x01\x1a\x01\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xb8\x00\xb9\x00\x29\x01\x6c\x00\x2b\x01\x35\x00\x36\x00\x6d\x00\x29\x01\x2a\x01\x2b\x01\x6d\x00\x6d\x00\x6d\x00\x6b\x00\x36\x01\x05\x01\x06\x01\x19\x01\x1a\x01\x67\x00\x36\x01\x1d\x01\x1e\x01\x73\x00\x0e\x01\x0f\x01\x4e\x00\x63\x00\x63\x00\x13\x01\x14\x01\x15\x01\x73\x00\x29\x01\x54\x00\x2b\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\x73\x00\x0d\x01\x16\x00\x67\x00\x10\x01\x52\x00\x36\x01\x13\x01\x14\x01\x15\x01\x6d\x00\x4a\x00\x4a\x00\x6b\x00\x2c\x01\x2d\x01\x85\x00\x2f\x01\x30\x01\x4a\x00\x4a\x00\x6d\x00\x6d\x00\x5f\x00\x36\x01\x52\x00\x38\x01\x39\x01\xc3\x00\xc4\x00\x3c\x01\x74\x00\x2c\x01\xc8\x00\x54\x00\x74\x00\x30\x01\xcc\x00\x18\x00\x73\x00\x4d\x00\xd0\x00\x36\x01\xd2\x00\x4d\x00\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4a\x00\xda\x00\xdb\x00\xdc\x00\xc8\x00\x4a\x00\x83\x00\x4a\x00\xcc\x00\x4a\x00\x4a\x00\x77\x00\xd0\x00\x83\x00\xd2\x00\x4e\x00\x73\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4a\x00\x4a\x00\xdb\x00\xdc\x00\x1e\x00\x6c\x00\x0b\x00\x96\x00\x72\x00\x18\x00\x18\x00\x9a\x00\x15\x00\x9c\x00\x4a\x00\x6d\x00\x9f\x00\xa0\x00\xa1\x00\x73\x00\xa3\x00\xa4\x00\x18\x00\x05\x01\x06\x01\x6b\x00\x67\x00\x74\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x0e\x01\x0f\x01\x61\x00\x18\x00\x4a\x00\x13\x01\x14\x01\x15\x01\x60\x00\x52\x00\x6d\x00\x73\x00\x05\x01\x06\x01\x4e\x00\x18\x00\x57\x00\x18\x00\x07\x00\xa4\x00\x19\x00\x0e\x01\x0f\x01\x4a\x00\x6b\x00\x96\x00\x13\x01\x14\x01\x15\x01\xcc\x00\x2c\x01\x2d\x01\x52\x00\x2f\x01\x30\x01\x60\x00\x4b\x00\xa2\x00\xa3\x00\xa4\x00\x36\x01\x61\x00\x38\x01\x39\x01\xdb\x00\x72\x00\x3c\x01\x73\x00\x72\x00\x67\x00\x67\x00\x2c\x01\x2d\x01\x80\x00\x2f\x01\x30\x01\x52\x00\x72\x00\x4d\x00\xcc\x00\x6d\x00\x36\x01\x96\x00\x38\x01\x39\x01\x6b\x00\x9a\x00\x3c\x01\x9c\x00\x18\x00\x18\x00\x9f\x00\xa0\x00\xa1\x00\xdb\x00\xa3\x00\xa4\x00\x6d\x00\x67\x00\xcc\x00\x6d\x00\x0a\x01\x0b\x01\x72\x00\x0d\x01\x18\x00\x52\x00\x10\x01\x4e\x00\x96\x00\x13\x01\x14\x01\x15\x01\x9a\x00\xdb\x00\x9c\x00\x2b\x00\x72\x00\x9f\x00\xa0\x00\xa1\x00\x4a\x00\xa3\x00\xa4\x00\x19\x00\x4d\x00\x19\x01\x1a\x01\x4a\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x52\x00\x2c\x01\xcc\x00\x07\x00\x61\x00\x30\x01\x18\x00\x07\x00\x29\x01\x2a\x01\x2b\x01\x36\x01\x18\x00\x83\x00\x39\x01\x4d\x00\x6b\x00\xdb\x00\x4d\x00\x83\x00\x6d\x00\x36\x01\x19\x01\x1a\x01\x4e\x00\x73\x00\x1d\x01\x1e\x01\x54\x00\xcc\x00\x72\x00\x72\x00\x6c\x00\x07\x00\x21\x00\x31\x00\x57\x00\x61\x00\x29\x01\x57\x00\x2b\x01\x19\x00\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x73\x00\x36\x01\x08\x00\x3b\x00\x4c\x00\x2c\x00\x6c\x00\x6a\x00\x29\x01\x2a\x01\x2b\x01\x61\x00\x54\x00\x6d\x00\x6f\x00\x73\x00\x58\x00\x6d\x00\x57\x00\xc9\x00\x5c\x00\x36\x01\x67\x00\x72\x00\x10\x00\x61\x00\x6d\x00\x97\x00\x67\x00\x19\x01\x1a\x01\x9b\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x6d\x00\x6d\x00\x6d\x00\x15\x00\x73\x00\x6d\x00\x73\x00\x67\x00\x29\x01\x2a\x01\x2b\x01\x78\x00\x79\x00\x44\x00\x4d\x00\x7c\x00\x7d\x00\x4d\x00\x52\x00\x19\x01\x1a\x01\x36\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x6c\x00\x52\x00\x02\x00\x18\x00\x6c\x00\x52\x00\x02\x00\x18\x00\x29\x01\x2a\x01\x2b\x01\x4c\x00\x18\x00\x78\x00\x07\x00\x6c\x00\xcc\x00\x6d\x00\xce\x00\xcf\x00\xd0\x00\x36\x01\xd2\x00\x6c\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x07\x00\xdb\x00\xdc\x00\x17\x01\x78\x00\x73\x00\x6d\x00\xe1\x00\xe2\x00\x12\x00\x2e\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x24\x01\x9c\x00\x26\x01\x27\x01\x9f\x00\xa0\x00\xa1\x00\x3f\x01\xa3\x00\xa4\x00\x9d\x00\x3e\x01\xf9\x00\x31\x01\x3e\x01\x33\x01\x34\x01\x35\x01\xad\x00\x37\x01\xdf\x00\x3a\x00\x3a\x01\x3b\x01\x61\x00\xf9\x00\xf9\x00\x05\x01\x06\x01\x82\x00\x8c\x00\x2f\x00\x3e\x01\x3e\x01\x82\x00\x3d\x01\x0e\x01\x0f\x01\x82\x00\x31\x00\x86\x00\x13\x01\x14\x01\x15\x01\x8d\x00\x17\x01\x97\x00\x49\x00\x8d\x00\xcc\x00\x9b\x00\x9d\x00\x89\x00\x83\x00\xae\x00\x91\x00\x61\x00\x7f\x00\x7f\x00\x25\x01\x26\x01\x7d\x00\x28\x01\x86\x00\xdb\x00\xdd\x00\x43\x01\x2d\x01\x42\x01\x2f\x01\x30\x01\xd3\x00\x32\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\x82\x00\x3d\x01\x3f\x01\x82\x00\x41\x01\x1f\x00\x1f\x00\x2e\x00\x45\x01\x03\x00\x0a\x00\x48\x01\xf1\x00\x43\x01\x4b\x01\x71\x00\xcc\x00\x3d\x01\xce\x00\xcf\x00\xd0\x00\x5c\x00\xd2\x00\x05\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x3d\x01\xdb\x00\xdc\x00\x82\x00\x18\x01\x19\x01\x1a\x01\xe1\x00\xe2\x00\x1d\x01\x1e\x01\x89\x00\x3d\x01\x19\x01\x1a\x01\x3d\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x29\x01\x8a\x00\x2b\x01\x4c\x00\x4d\x00\x5d\x00\x39\x01\x7f\x00\x29\x01\x2a\x01\x2b\x01\x7d\x00\x7b\x00\x36\x01\x89\x00\x58\x00\x30\x00\x1f\x00\x1f\x00\x5c\x00\x2a\x00\x36\x01\x05\x01\x06\x01\x61\x00\x20\x01\x33\x00\x6b\x00\x89\x00\x4e\x00\x3f\x01\x0e\x01\x0f\x01\x66\x00\x75\x00\x49\x00\x13\x01\x14\x01\x15\x01\x79\x00\x17\x01\x97\x00\x70\x00\x74\x00\xb3\x00\x9b\x00\x2a\x00\x78\x00\x79\x00\x0f\x00\x1b\x00\x7c\x00\x7d\x00\x3d\x01\x25\x01\x26\x01\x1b\x00\x28\x01\x3d\x01\xd3\x00\x79\x00\xc1\x00\x2d\x01\xb3\x00\x2f\x01\x30\x01\x74\x00\x32\x01\x33\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xf1\x00\xb1\x00\x3f\x01\x51\x00\x41\x01\x32\x00\x16\x00\x16\x00\x45\x01\x2a\x00\x24\x00\x48\x01\x52\x00\x56\x00\x4b\x01\x4b\x00\xcc\x00\x3e\x01\xce\x00\xcf\x00\xd0\x00\x3d\x01\xd2\x00\x3e\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x3d\x01\x2f\x00\xdb\x00\xdc\x00\x11\x00\x3e\x01\x0c\x00\x82\x00\xe1\x00\xe2\x00\x57\x00\x3e\x01\x41\x01\x5e\x00\x3d\x01\x92\x00\x93\x00\x3d\x01\x57\x00\x96\x00\x97\x00\x3d\x01\x99\x00\x9a\x00\x31\x00\x9c\x00\xa4\x00\x3d\x01\x9f\x00\xa0\x00\xa1\x00\x33\x00\xa3\x00\xa4\x00\x0d\x01\xa6\x00\x3d\x01\x10\x01\x3d\x01\x61\x00\x13\x01\x14\x01\x15\x01\x5c\x00\x05\x01\x06\x01\x5e\x00\x82\x00\x1f\x00\x1f\x00\x34\x00\x16\x00\x16\x00\x0e\x01\x0f\x01\x3e\x01\x3e\x01\x3e\x01\x13\x01\x14\x01\x15\x01\xb3\x00\x17\x01\x97\x00\x24\x00\x2c\x01\xcc\x00\x9b\x00\x3e\x01\x30\x01\x3e\x01\x3e\x01\xff\xff\xcc\x00\xff\xff\x36\x01\x25\x01\x26\x01\x39\x01\x28\x01\xff\xff\xdb\x00\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xdb\x00\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xff\xff\x3f\x01\xff\xff\x41\x01\xff\xff\xff\xff\xff\xff\x45\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\x05\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xa4\x00\xff\xff\xe1\x00\xff\xff\xff\xff\xff\xff\xe5\x00\xe6\x00\x19\x01\x1a\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\x29\x01\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\x36\x01\x05\x01\x06\x01\xcc\x00\xff\xff\x97\x00\xff\xff\x36\x01\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xdb\x00\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xa4\x00\xff\xff\xe1\x00\x19\x01\x1a\x01\xe4\x00\xff\xff\x1d\x01\x1e\x01\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\x07\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\xff\xff\x0d\x01\xff\xff\xff\xff\x10\x01\x36\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xcc\x00\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xdb\x00\x17\x01\xff\xff\xff\xff\x2c\x01\xff\xff\xff\xff\xff\xff\x30\x01\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x25\x01\x26\x01\x39\x01\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe1\x00\x19\x01\x1a\x01\xe4\x00\xff\xff\x1d\x01\x1e\x01\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\xff\xff\x29\x01\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\x9a\x00\xff\xff\xff\xff\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\xff\xff\x2b\x01\xba\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\x29\x01\x2a\x01\x2b\x01\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\x96\x00\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xe1\x00\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xcc\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x17\x01\xff\xff\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x26\x01\xff\xff\x28\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x32\x01\x33\x01\xff\xff\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x0e\x01\x0f\x01\x61\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\x74\x00\x13\x01\x14\x01\x15\x01\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x2d\x01\x97\x00\x2f\x01\x30\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\x45\x01\xff\xff\x36\x01\x48\x01\x38\x01\x39\x01\x4b\x01\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\x0c\x01\x0d\x01\xff\xff\xff\xff\x10\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\x2c\x01\x13\x01\x14\x01\x15\x01\x30\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x36\x01\x97\x00\xff\xff\x39\x01\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x2d\x01\x97\x00\x2f\x01\x30\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x45\x01\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x4b\x01\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x0e\x01\x0f\x01\x61\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\x74\x00\x13\x01\x14\x01\x15\x01\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x2d\x01\x97\x00\x2f\x01\x30\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\x45\x01\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x4b\x01\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\x45\x01\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4b\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\x06\x01\xff\xff\xa8\x00\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xbb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xcc\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xdb\x00\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x45\x01\x4c\x00\x4d\x00\xff\xff\xff\xff\x36\x01\x4b\x01\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x45\x01\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x4b\x01\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\x74\x00\xff\xff\x5c\x00\xff\xff\x78\x00\x79\x00\xff\xff\x61\x00\x7c\x00\x7d\x00\x96\x00\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x74\x00\x29\x01\x2a\x01\x2b\x01\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x3f\x01\x9c\x00\x41\x01\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xa9\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\x58\x00\x9f\x00\xa0\x00\xa1\x00\x5c\x00\xa3\x00\xa4\x00\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xdb\x00\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xcc\x00\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x05\x01\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x31\x01\xff\xff\x33\x01\x34\x01\x35\x01\xff\xff\x37\x01\xff\xff\x36\x01\x3a\x01\x3b\x01\xff\xff\xcc\x00\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x3f\x01\xff\xff\x41\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x34\x01\x35\x01\x36\x01\x37\x01\xff\xff\x97\x00\x3a\x01\x3b\x01\xff\xff\x9b\x00\xff\xff\x3f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x01\x0d\x01\xff\xff\xff\xff\x10\x01\x36\x01\x97\x00\x13\x01\x14\x01\x15\x01\x9b\x00\xff\xff\xff\xff\xff\xff\x3f\x01\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\x2c\x01\xff\xff\xff\xff\xff\xff\x30\x01\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\x36\x01\xd2\x00\xff\xff\x39\x01\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\x97\x00\x13\x01\x14\x01\x15\x01\x9b\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x97\x00\xff\xff\x3c\x01\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xff\xff\xff\xff\xcf\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xdb\x00\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x92\x00\x93\x00\x3c\x01\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xa6\x00\xff\xff\xff\xff\x0c\x01\x0d\x01\x05\x01\xff\xff\x10\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x2c\x01\xff\xff\xff\xff\xcc\x00\x30\x01\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\x36\x01\xff\xff\xff\xff\x39\x01\xff\xff\xff\xff\x92\x00\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\xff\xff\xff\xff\xff\xff\x17\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x23\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\x2c\x01\xff\xff\xcc\x00\xff\xff\x30\x01\x29\x01\x2a\x01\x2b\x01\x34\x01\x35\x01\x36\x01\x37\x01\x38\x01\x39\x01\x3a\x01\x3b\x01\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xa5\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xa5\x00\x93\x00\xff\xff\x95\x00\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x93\x00\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xba\x00\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\x36\x01\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x14\x00\x15\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\x67\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\x4b\x00\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x00\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\x00\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\x40\x00\x41\x00\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xa7\x00\xa8\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\x67\x00\xff\xff\x69\x00\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xcc\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xdb\x00\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\x9c\x00\xa3\x00\xa4\x00\x9f\x00\xa0\x00\xa7\x00\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xac\x00\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\x05\x01\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\x36\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\xff\xff\xff\xff\xa8\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xb2\x00\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\x05\x01\x06\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x19\x01\x1a\x01\x3c\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x01\x29\x01\x2a\x01\x2b\x01\x4d\x01\xff\xff\x4f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\x05\x01\x06\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x19\x01\x1a\x01\x3c\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x01\x29\x01\x2a\x01\x2b\x01\x4d\x01\xff\xff\x4f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x36\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xdb\x00\x9c\x00\xff\xff\x36\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xdb\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\x05\x01\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x96\x00\x97\x00\x36\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\x97\x00\xff\xff\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\x97\x00\x05\x01\x99\x00\x9a\x00\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\x05\x01\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x96\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xa3\x00\xa4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xdb\x00\x36\x01\x01\x00\x02\x00\xcc\x00\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdb\x00\x36\x01\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x19\x01\x1a\x01\xff\xff\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\xff\xff\xff\xff\x36\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x29\x01\x2a\x01\x2b\x01\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\x09\x00\x0a\x00\x36\x01\xff\xff\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x13\x00\x76\x00\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\x42\x00\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\x13\x00\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\x0d\x00\x0e\x00\x0f\x00\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\x16\x00\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x08\x01\x09\x01\x0a\x01\x0b\x01\xff\xff\x0d\x01\xff\xff\xff\xff\x10\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x2c\x01\xff\xff\xff\xff\xff\xff\x30\x01\xff\xff\xff\xff\xff\xff\x34\x01\x35\x01\x36\x01\x37\x01\xff\xff\x39\x01\x6a\x00\x3b\x01\x6c\x00\xff\xff\x6e\x00\x3f\x01\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\x72\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\x71\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x4b\x00\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x79\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x10\x00\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\x80\x00\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x15\x00\xff\xff\x9f\x00\xa0\x00\x19\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x82\x00\x83\x00\x84\x00\x85\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\x9f\x00\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\x3d\x01\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\x4a\x01\xff\xff\x4c\x01\xff\xff\x4e\x01\xff\xff\x50\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\x4a\x01\xff\xff\x4c\x01\xff\xff\x4e\x01\xff\xff\x50\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\x4a\x01\xff\xff\x4c\x01\xff\xff\x4e\x01\xff\xff\x50\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\x44\x01\xff\xff\xff\xff\x47\x01\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\xff\xff\x50\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\x3d\x01\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x01\xff\xff\xff\xff\xff\xff\x4d\x01\xff\xff\x4f\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\x15\x00\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x4f\x01\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x84\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x84\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x83\x00\x84\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x76\x00\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x83\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x83\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\x83\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xe8\x00\xe9\x00\xea\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x83\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xe8\x00\xe9\x00\xea\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xfc\x00\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xfb\x00\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\x44\x01\xfa\x00\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\x44\x01\xfa\x00\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\x4c\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xd8\x00\x38\x01\x39\x01\xdb\x00\xdc\x00\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xeb\x00\xec\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xfe\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xeb\x00\xec\x00\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfe\x00\xff\xff\xff\xff\xef\x00\xf0\x00\xf1\x00\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xea\x00\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xfe\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xf5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xfe\x00\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\x44\x01\xff\xff\xff\xff\x47\x01\x36\x01\xff\xff\x38\x01\x39\x01\x4c\x01\xff\xff\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x4c\x01\x3c\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\x44\x01\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x4c\x01\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\x1b\x00\x1c\x00\x1d\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\x09\x00\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x01\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x01\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x02\x00\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x74\x00\xff\xff\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\x76\x00\x77\x00\x78\x00\x79\x00\xff\xff\x7b\x00\x15\x00\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xd2\x00\xff\xff\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\x46\x01\x36\x01\x02\x00\x38\x01\x39\x01\x05\x00\x06\x00\x3c\x01\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x01\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\x73\x00\x09\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\x09\x00\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\x09\x00\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\x15\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x15\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\x7a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x76\x00\xff\xff\xff\xff\xff\xff\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\x02\x00\x6c\x00\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\x09\x00\x73\x00\xff\xff\xff\xff\x76\x00\x77\x00\x78\x00\x79\x00\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x66\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x76\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\x76\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x15\x00\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x66\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\xff\xff\x73\x00\xff\xff\xff\xff\x76\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x02\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\xff\xff\x09\x00\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\x76\x00\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xf8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xd6\x00\xd7\x00\xd8\x00\x05\x01\x06\x01\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xde\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x0e\x01\x0f\x01\x3c\x01\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xcc\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xcc\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xcc\x00\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xd6\x00\xd7\x00\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\x0e\x01\x0f\x01\xdb\x00\xdc\x00\xcc\x00\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd8\x00\xff\xff\xff\xff\xdb\x00\xdc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\x05\x01\x06\x01\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\x05\x01\x06\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0e\x01\x0f\x01\xff\xff\xff\xff\xff\xff\x13\x01\x14\x01\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\x2d\x01\xff\xff\x2f\x01\x30\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x01\xff\xff\x38\x01\x39\x01\xff\xff\xff\xff\x3c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x73\x00\xa4\x05\xa5\x05\xa7\x05\xa8\x05\x51\x01\x38\x01\xd9\x05\xd9\x00\xcb\x04\xe0\x05\xdb\x05\x76\x05\x48\x02\xdc\x05\x1d\x05\x36\x02\x1c\x05\x37\x02\x35\x05\xd7\x05\x1d\x05\x36\x02\x9f\x05\x37\x02\xed\x03\xe6\x04\x1d\x05\x36\x02\x34\x03\x37\x02\x35\x02\x36\x02\x36\x02\x37\x02\x33\x04\xdd\x03\x47\x05\x57\x01\x48\x05\x73\x03\xcd\x03\xce\x03\x8c\x03\xab\x03\x5f\x04\xce\x03\x33\x02\xe7\x05\x34\x01\x33\x02\x72\x04\xfa\x00\x71\x03\x17\x01\xb2\x02\xb3\x02\xda\x00\x0c\x02\x0d\x02\x0e\x02\x0f\x02\xd1\x05\x49\x05\x4f\x05\xe1\x05\x33\x02\x35\x01\x30\x03\xdb\x02\xc6\x04\xb0\x03\x6a\x05\x6b\x05\x6c\x05\x6d\x05\xb3\x04\x2a\x02\x33\x02\x13\x01\x11\x05\xb2\x02\xb3\x02\x57\x03\xc7\x05\x6d\x05\xb3\x04\x2a\x05\xce\x03\x30\x01\x33\x02\x27\x02\x30\x01\x76\x03\x5b\x05\xa6\x04\x8d\x02\xe8\x05\xb3\x04\x11\x00\x58\x03\x59\x03\x33\x02\x44\x03\xd2\x05\x31\x03\xa3\x03\xe8\x05\xb3\x04\x1a\x03\xe8\x04\x49\x00\xe9\x05\xea\x05\xeb\x05\x12\x05\x13\x05\xa8\x02\xa8\xfe\xe8\x05\xb3\x04\x7f\x03\xf9\x05\xea\x05\xeb\x05\xd5\x01\xdc\x02\x49\x04\xb1\x03\xb2\x04\xb3\x04\x77\x03\x78\x03\x90\x04\x1b\x03\xac\x03\xff\x05\x10\x02\x18\x01\x4e\x00\x02\x02\x33\x02\x73\x04\x45\x03\xc1\x02\x4b\x05\xe7\x04\xe8\x05\xd5\x01\xfd\x00\x4f\x00\xb0\xfe\x34\x02\x93\x00\xb2\xfe\x34\x02\xe2\x05\xc3\x02\xa8\xfe\x96\x00\x8d\x03\x35\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\xa7\x02\xc4\x02\xc5\x02\xc6\x02\xbf\x02\x34\x02\x8e\x02\x58\x01\x39\x01\x3a\x01\x11\x01\x76\x00\x25\x01\x78\x00\x03\x02\x04\x02\x05\x02\x34\x02\xa4\x03\x10\x02\x59\x01\x4e\x00\x5a\x01\x5b\x01\xa7\x04\xb0\xfe\xe8\x03\xa1\x02\xb2\xfe\x34\x02\x4a\x01\x4b\x01\x4f\x00\x7b\x00\xa2\x02\x7c\x00\x7d\x00\x7e\x00\xd9\x03\x7f\x00\x3b\x01\x34\x02\x82\x00\x83\x00\xa2\x00\xa3\x00\x11\x00\x52\x01\x49\x00\x28\x01\xd7\x03\xcf\x03\xb5\x02\xa4\x00\x75\x00\xcf\x03\xa6\x03\x11\x00\x76\x00\x77\x00\x78\x00\x11\x00\x35\x03\xcc\x04\xcc\x04\x77\x05\x3f\x03\xa3\x02\x11\x00\x4a\x01\x4b\x01\xe8\x04\x49\x00\x35\x03\x4f\x00\x4f\x00\x4f\x00\xa9\xff\xb4\x02\x11\x00\x34\x02\x72\x03\x28\x03\xdd\x00\xa5\x00\x27\x01\x0f\x00\xde\x00\xde\x03\x3f\x05\x02\x02\x11\x00\xa8\x02\x11\x00\xa9\x02\x80\x00\x81\x00\xcf\x03\x72\x03\xa6\x00\xdf\x03\xe0\x03\x27\x01\x11\x00\x74\x00\x75\x00\x40\x03\xff\xff\x11\x00\x76\x00\x77\x00\x78\x00\x79\x03\x79\x00\x0e\x03\x33\x02\x27\x01\x37\x00\xef\x01\x7e\x00\x29\x03\x7f\x00\x11\x00\x79\x03\x79\x03\x31\x03\x06\x02\x27\x01\x27\x01\x7a\x00\x27\x01\x20\x04\x05\x02\x11\x00\x11\x00\x0e\x00\x11\x00\x0f\x00\x10\x00\x7b\x00\xa6\x05\x7c\x00\x7d\x00\x7e\x00\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa9\x05\x38\x02\xb4\x04\xa9\x05\xb5\x04\x49\x00\x06\x02\x38\x02\xa6\x05\xcd\x02\x27\x01\xff\xff\xb4\x04\x38\x02\xb5\x04\x49\x00\x11\x00\x38\x02\x38\x02\x1d\x01\xb6\x04\x33\x02\x0f\x00\x10\x00\xb4\x04\x3d\x03\xb5\x04\x49\x00\x32\x00\x11\x00\xb6\x04\x33\x02\x0f\x00\x10\x00\xb4\x04\x85\x00\xb5\x04\x49\x00\x19\x01\x11\x00\x40\x01\x33\x02\xb6\x04\x23\x04\x0f\x00\x10\x00\xb4\x04\xca\x01\xb5\x04\x49\x00\x34\x01\x11\x00\xb6\x04\xea\x04\x0f\x00\x10\x00\xb4\x04\x4c\xff\xb5\x04\x49\x00\xcb\x01\x11\x00\xff\xff\x33\x00\xb6\x04\x3e\x03\x0f\x00\x10\x00\x35\x01\x24\x04\x34\x02\x7b\x05\x79\x05\x11\x00\xb6\x04\x33\x03\x0f\x00\x10\x00\xd9\x00\x1c\x05\x90\x00\xeb\x04\xec\x04\x11\x00\xaa\x04\xab\x04\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xd7\x02\xf5\x00\x06\x02\xb2\x05\x0f\x02\x4c\xff\x27\x01\x4a\x02\x0d\x02\x0e\x02\x0f\x02\xdd\x03\x11\x00\x09\x05\xa3\x04\xa4\x04\xa5\x04\xa6\x04\xf6\x00\xf7\x00\x7b\x01\x0c\x02\x34\x00\x34\x01\x3a\x04\x7f\x02\x51\x02\xf8\x00\xf9\x00\x37\x00\x46\x03\xd8\x02\xfa\x00\x47\x03\x0a\x05\x41\x01\x34\x02\xda\x00\x42\x01\x3e\x00\x3f\x00\x35\x01\x40\x00\x41\x00\xd9\x02\x7f\x05\x34\x02\xef\x02\x37\x00\x53\x02\x52\x02\x61\x02\xed\x04\x80\x01\x24\x03\xd9\x03\x34\x02\x42\x01\x3e\x00\x3f\x00\xd7\x02\x40\x00\x41\x00\x65\x00\x53\x02\xc1\x05\xd9\x00\x69\x00\xfb\x00\x80\x02\x81\x02\x0f\x00\x82\x02\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x11\x00\xf5\x00\xce\x02\x75\x00\x58\x00\x42\x00\x62\x02\x76\x00\x77\x00\x78\x00\x4c\x02\xb9\x02\x4b\x00\xd8\x02\xaa\xfe\x86\xfc\x59\x00\x86\xfc\xf6\x00\xf7\x00\x43\x00\x17\xff\x5f\x03\x4d\x02\x42\x00\x5d\x00\x6d\x03\xf8\x00\xf9\x00\x7d\x02\x7e\x02\x7f\x02\xfa\x00\xcf\x02\xa7\x04\x0f\x00\x10\x00\xda\x00\x54\x01\x43\x00\x51\x04\x98\x05\x11\x00\xfd\x01\x80\x00\x81\x00\xfc\x00\x62\x01\x66\x00\x67\x00\x10\x02\xfd\x00\x4e\x00\x1c\x01\xaa\xfe\x93\x00\x10\x02\x1d\x01\x4e\x00\xfe\x00\x63\x05\x96\x00\x7b\x01\x4f\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xfb\x00\x4f\x00\x9c\x00\x9d\x00\xd5\x01\x52\x04\x62\x02\x80\x02\x81\x02\x0f\x00\x82\x02\x3c\x04\x3f\x01\x49\x03\x45\x00\x43\x01\x11\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x25\x02\xb9\x02\x65\x00\x10\x04\x86\xfc\x80\x01\x40\x01\x20\x02\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x5c\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4a\x01\x4b\x01\x4f\x00\xa2\x00\xa3\x00\x99\x04\x39\x05\x37\x05\x4c\x00\x4d\x00\x4e\x00\x1f\x02\xa4\x00\x75\x00\x3d\x04\xfc\x00\x85\x02\x76\x00\x77\x00\x78\x00\xfd\x00\x4f\x00\x11\x00\x5d\x02\x93\x00\x87\x04\x0e\x02\x0f\x02\xfe\x00\x34\x00\x96\x00\x9a\x04\x18\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x38\x05\x4e\x01\x9c\x00\x9d\x00\x15\x02\xdd\x00\xa5\x00\x72\x02\x0f\x00\xde\x00\xaa\xff\x58\x01\x35\x00\x58\x02\x19\x01\x11\x00\xa9\x04\x80\x00\x81\x00\xbe\x01\x28\x04\xa6\x00\x09\x02\x29\x04\x59\x01\xd9\x00\x5a\x01\x5b\x01\x7b\x01\x4f\x01\x50\x01\x51\x01\xe5\x03\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x7b\x00\xf5\x00\x7c\x00\x7d\x00\x7e\x00\x0b\x02\x7f\x00\xa2\x00\xa3\x00\x82\x00\x83\x00\x83\x03\x0d\x02\x0e\x02\x0f\x02\x2a\x04\xa4\x00\x75\x00\xf6\x00\xf7\x00\xab\x02\x76\x00\x77\x00\x78\x00\x80\x01\x42\x00\xff\xff\xf8\x00\xf9\x00\x49\x02\x3d\x02\x4e\x00\xfa\x00\x67\x05\x36\x05\x37\x05\x6d\xfd\xda\x00\xce\x02\x75\x00\x43\x00\x35\x02\x4f\x00\x76\x00\x77\x00\x78\x00\xdd\x00\xa5\x00\x66\x05\x0f\x00\xde\x00\x87\x00\x19\x01\x85\x00\xd9\x01\x88\x00\x11\x00\x5a\x02\x80\x00\x81\x00\x89\x00\x7c\x01\xa6\x00\x5b\x02\x58\x00\x38\x05\xd9\x00\x19\x01\xfb\x00\xcf\x02\x26\x02\x0f\x00\x10\x00\xaf\x05\x37\x05\x79\xfe\x59\x00\x10\x02\x11\x00\x4e\x00\x80\x00\x81\x00\x79\xfe\x8f\x00\x27\x02\x5d\x00\x7f\x01\x92\x00\x78\x05\x79\x05\x4f\x00\xf0\x02\x80\x01\x4f\x03\x50\x03\x47\x05\x87\x00\x48\x05\x90\x00\x79\xfe\x88\x00\xf1\x02\x45\x00\x46\x00\x38\x05\x89\x00\x48\x00\x49\x00\x66\x00\x67\x00\xfa\x00\x2d\x02\x6a\x00\x6b\x00\xf3\x02\xda\x00\xf3\x01\x49\x00\x4c\x00\xff\xff\x4e\x00\x49\x05\x4a\x05\xe7\x03\xfc\x00\x2e\x02\x2f\x02\x53\x03\x8f\x00\xfd\x00\xf4\x01\x4f\x00\xda\x01\x93\x00\xe8\x03\xdb\x01\x19\x05\xfe\x00\x10\x02\x96\x00\x4e\x00\x4f\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x54\x03\x55\x03\x9c\x00\x9d\x00\x27\x02\x4f\x00\x79\xfe\x79\xfe\xea\x01\x37\x00\xd8\x03\x79\xfe\xeb\x01\x1c\x02\x1d\x02\x24\x03\xd8\x01\x18\x05\x42\x01\x3e\x00\x3f\x00\xd9\x03\x40\x00\x41\x00\x22\x03\x8a\x00\x9c\x01\x84\x01\x54\x02\x8c\x00\x1e\x02\x27\x02\x79\xfe\x08\x02\x79\xfe\x65\x00\x55\x02\xee\x01\x8e\x00\x69\x00\xed\x04\x27\x01\x91\x00\x79\xfe\xa2\x00\xa3\x00\x57\x02\x11\x00\xd9\x00\x80\x00\x81\x00\x65\x00\x58\x02\xa4\x00\x75\x00\x69\x00\xc1\x02\x4b\x05\x76\x00\x77\x00\x78\x00\xfd\x00\x1d\x04\x42\x00\xd6\x05\x93\x00\x27\x01\x4a\x01\x4b\x01\xc3\x02\xd7\x05\x96\x00\x11\x00\x42\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x00\xc4\x02\xc5\x02\xc6\x02\x99\x01\xdd\x00\xa5\x00\xf3\x02\x0f\x00\xde\x00\x43\x00\x58\x01\x79\xfe\xef\xfc\xfa\x00\x11\x00\x5e\x04\x80\x00\x81\x00\xda\x00\x61\x01\xa6\x00\x11\x00\x7a\x04\xf4\x02\x4e\x00\x5a\x01\x5b\x01\x8e\x04\xca\x02\x93\x01\x3a\x01\x27\x01\x76\x00\x25\x01\x78\x00\x4f\x00\x7b\x00\x11\x00\x7c\x00\x7d\x00\x7e\x00\xff\xff\x7f\x00\xa2\x00\xa3\x00\x82\x00\x83\x00\x83\x04\x70\x04\x0d\x02\x0e\x02\x0f\x02\xa4\x00\x75\x00\xff\xff\x84\x04\xb9\x01\x76\x00\x77\x00\x78\x00\x80\x01\x45\x00\x46\x00\xd6\x03\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x23\x03\x28\x01\x45\x00\x46\x00\x3e\x05\xd7\x03\x48\x00\x49\x00\x4c\x00\x4d\x00\x4e\x00\x1b\x05\x5f\x01\xdd\x00\xa5\x00\x3f\x05\x0f\x00\xde\x00\x4c\x00\xd9\x00\x4e\x00\x4f\x00\x1c\x05\x11\x00\x16\xff\x80\x00\x81\x00\x7e\x05\x74\x05\xa6\x00\x38\x01\x4f\x00\xee\x04\x0d\x02\x0e\x02\x0f\x02\xc1\x02\xc2\x02\x7f\x05\xd9\x03\xdd\xfd\xfd\x00\xdd\xfd\x21\x01\xdd\xfd\x93\x00\x65\x00\x38\x03\x91\x02\xc3\x02\x69\x00\x96\x00\x39\x03\xdd\xfd\x98\x00\x99\x00\x9a\x00\x9b\x00\x58\x01\xc4\x02\xc5\x02\xc6\x02\x84\xfc\xfa\x00\xe7\x01\x83\x00\x37\x00\xfe\x02\xda\x00\xe8\x01\xc0\x05\x59\x01\x24\x03\x5a\x01\x5b\x01\x42\x01\x3e\x00\x3f\x00\xc0\x02\x40\x00\x41\x00\xc1\x05\xff\xff\x85\x00\x7b\x00\xc4\x04\x7c\x00\x7d\x00\x7e\x00\xff\xff\x7f\x00\x5f\x05\x75\x00\x82\x00\x83\x00\x87\x00\x76\x00\x77\x00\x78\x00\x88\x00\xcb\x02\xc8\x02\xc9\x02\xa3\x00\x89\x00\x8d\x04\x10\x02\x31\x02\x4e\x00\x27\x01\x4d\x03\xa4\x00\x75\x00\x85\x00\xc3\x05\x11\x00\x76\x00\x77\x00\x78\x00\x4f\x00\x42\x00\x7c\x01\xe6\x02\x5e\x01\x85\x02\x4f\x00\x57\x03\x8f\x00\x90\x00\xd3\x05\x11\x00\x92\x00\x93\x00\x80\x00\x81\x00\x43\x00\x8a\x00\xd4\x05\x3d\x01\x34\x03\x8c\x00\xdd\x00\xa5\x00\xd9\x00\x0f\x00\xde\x00\x7f\x01\x4d\x02\x7e\x00\x8e\x00\x7f\x00\x11\x00\x80\x01\x80\x00\x81\x00\xc1\x02\xc2\x02\xa6\x00\x90\x00\x10\x02\xfd\x00\x4e\x00\x93\x00\x84\x02\x93\x00\x85\x02\x3f\x05\x27\x03\xc3\x02\xd6\x04\x96\x00\x11\x00\x4f\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x03\xc4\x02\xc5\x02\xc6\x02\xe6\x01\xb9\x01\x7e\x00\x39\x03\x7f\x00\x3a\x03\xfa\x00\xe7\x01\x83\x00\x64\x02\x30\x01\xda\x00\xe8\x01\xd7\x04\xdd\x04\x11\x00\x45\x00\x46\x00\x75\x03\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x81\x01\x75\x00\xae\x03\xaf\x03\x82\x01\x76\x00\x77\x00\x78\x00\x4c\x00\x4d\x00\x4e\x00\xbd\x03\x2e\x00\x85\x02\xc7\x02\xc8\x02\xc9\x02\xa3\x00\x2f\x00\x11\x00\x30\x00\x4f\x00\x4a\x01\x4b\x01\x1c\x01\xa4\x00\x75\x00\x37\x00\x1d\x01\x17\x03\x76\x00\x77\x00\x78\x00\x40\x05\x13\x03\x0d\x03\x42\x01\x3e\x00\x3f\x00\x0e\x03\x40\x00\x41\x00\x80\x00\x81\x00\x93\x01\xd4\x03\x11\x03\x76\x00\x25\x01\x78\x00\xe6\x01\xb9\x01\x7e\x00\x86\x05\x7f\x00\xdd\x00\xa5\x00\x5d\x05\x0f\x00\xde\x00\xd9\x00\x0e\x00\x75\x02\x0f\x00\x10\x00\x11\x00\x58\x02\x80\x00\x81\x00\x87\x00\x11\x00\xa6\x00\x0f\x03\x88\x00\xc1\x02\xd9\x04\x13\x01\x14\x01\x89\x00\xfd\x00\x15\x01\x42\x00\x64\x02\x93\x00\x61\x01\x28\x01\xd6\x04\xc3\x02\x11\x00\x96\x00\xe4\x01\x81\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x00\xc4\x02\xc5\x02\xc6\x02\xfe\x02\x8f\x00\x5e\x05\x02\x03\xfa\x00\x92\x00\x5f\x05\x4d\x02\x7e\x00\xda\x00\x7f\x00\xd7\x04\xd8\x04\x91\x01\xdd\x02\x0f\x00\x10\x00\x20\x03\xe8\x01\x37\x00\x48\x00\x49\x00\x11\x00\xff\x02\x97\x01\x24\x03\x98\x01\x85\x00\x42\x01\x3e\x00\x3f\x00\xe3\x02\x40\x00\x41\x00\xa0\x01\x7c\x01\xa1\x01\xe1\x02\xa2\x01\x87\x00\xa2\x00\xa3\x00\xee\x02\x88\x00\x22\x05\xe4\x02\x85\x02\x65\x00\x89\x00\xa4\x00\x75\x00\x69\x00\x11\x00\x5e\x02\x76\x00\x77\x00\x78\x00\x58\x02\x45\x00\x46\x00\x7f\x01\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x80\x01\x1d\x03\x1e\x03\x1f\x03\x20\x03\x8f\x00\x90\x00\x42\x00\x4c\x00\x4d\x00\x4e\x00\x87\x03\x88\x03\xdd\x00\xa5\x00\x80\x03\x0f\x00\xde\x00\x48\x00\x49\x00\x85\x00\x4f\x00\x43\x00\x11\x00\x8f\xfe\x80\x00\x81\x00\xd9\x00\x8f\xfe\xa6\x00\xc1\x02\xd9\x04\x87\x00\xae\x03\xaf\x03\xfd\x00\x88\x00\xe3\x01\x10\x00\x93\x00\xad\x01\x89\x00\xae\x01\xc3\x02\x11\x00\x96\x00\xe4\x01\x81\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x74\x02\xc4\x02\xc5\x02\xc6\x02\x47\x05\xa7\x01\x48\x05\xa8\x01\x5e\x01\x54\x01\xde\x03\x60\x05\x8f\x00\x90\x00\x48\x00\x49\x00\x92\x00\x93\x00\xec\x02\xfa\x00\xfa\x05\x75\x00\xfb\x04\xe0\x03\xda\x00\x76\x00\x77\x00\x78\x00\xdb\xfc\x97\x01\xbd\x05\x98\x01\x45\x00\x46\x00\x73\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xef\x01\x7e\x00\x0d\x03\x7f\x00\xa2\x00\xa3\x00\x0e\x03\x31\x03\x4c\x00\x4d\x00\x4e\x00\x65\x00\x1c\x01\xa4\x00\x75\x00\x69\x00\x1d\x01\xea\x02\x76\x00\x77\x00\x78\x00\x4f\x00\x80\x00\x81\x00\x37\x00\x4d\x04\x46\x04\x47\x04\x55\x01\xd3\x01\x56\x01\xe8\x02\xdd\x02\x3d\x00\x3e\x00\x3f\x00\xe8\x01\x40\x00\x41\x00\x8b\x01\xdf\x02\x0f\x00\x10\x00\xdd\x00\xa5\x00\xe0\x02\x0f\x00\xde\x00\x11\x00\x9b\x02\xbc\x05\x9c\x02\x98\x02\x11\x00\x99\x02\x80\x00\x81\x00\xd9\x00\x85\x00\xa6\x00\x30\x01\x31\x01\x32\x01\xd1\x02\x93\x01\x8d\x05\xe2\x03\x76\x00\x25\x01\x78\x00\x87\x00\xc1\x02\x4b\x05\x9b\x02\x88\x00\x9c\x02\xfd\x00\xcd\x02\x42\x00\x89\x00\x93\x00\x4a\x01\x4b\x01\xd6\x04\xc3\x02\x79\x04\x96\x00\x7a\x04\x92\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x43\x00\xc4\x02\xc5\x02\xc6\x02\x97\x01\xe3\x03\x98\x01\xbc\x02\xfa\x00\x8f\x00\x90\x00\xb8\x02\x28\x01\xda\x00\x8a\x00\x8a\x05\x84\x01\xce\x01\x8c\x00\xc3\x03\x9d\x01\x46\x00\xa7\x02\x37\x00\x48\x00\x49\x00\x32\x04\x8e\x00\x33\x04\x24\x03\xb7\x02\x91\x00\x42\x01\x3e\x00\x3f\x00\xb2\x02\x40\x00\x41\x00\xb0\x02\xe4\x02\x10\x00\x2c\x01\x2d\x01\x2e\x01\xa2\x00\xa3\x00\x11\x00\xa4\x02\xe4\x01\x81\x00\x9b\x03\x9c\x03\x9d\x03\xa4\x00\x75\x00\x4f\x03\x50\x03\x42\x00\x76\x00\x77\x00\x78\x00\xa0\x02\x45\x00\x46\x00\x9f\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x89\x05\x8a\x05\x43\x00\x09\x03\x0a\x03\x0b\x03\x9d\x02\x42\x00\x4c\x00\x4d\x00\x4e\x00\x89\x05\xb9\x05\xdd\x00\xa5\x00\x92\x02\x0f\x00\xde\x00\xd9\x00\xae\x03\xaf\x03\x4f\x00\x43\x00\x11\x00\x95\x02\x80\x00\x81\x00\x4a\x01\x4b\x01\xa6\x00\xc1\x02\xd9\x04\x45\x04\x46\x04\x47\x04\xfd\x00\xd3\x01\x25\x02\x23\x02\x93\x00\xe6\x01\xb9\x01\x7e\x00\xc3\x02\x7f\x00\x96\x00\x22\x02\x23\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x94\x02\xc4\x02\xc5\x02\xc6\x02\x2b\x03\x2c\x03\x2d\x03\x2e\x03\x2f\x03\xf8\x01\xfa\x00\xf9\x01\x45\x00\x46\x00\x93\x02\xda\x00\x48\x00\x49\x00\x88\x03\x89\x03\x8a\x03\x9f\x04\x0a\x03\x0b\x03\x16\x05\x58\x05\x17\x05\xe4\x04\x4c\x00\xe5\x04\x4e\x00\x85\x00\x45\x00\x46\x00\x91\x02\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xd1\x04\x4f\x00\xd2\x04\x87\x00\xa2\x00\xa3\x00\x74\x02\x88\x00\x4c\x00\x4d\x00\x4e\x00\x89\x02\x89\x00\xa4\x00\x75\x00\x94\x01\xcf\x01\x62\x04\x76\x00\x77\x00\x78\x00\x4f\x00\xd5\x01\x81\x01\x75\x00\x77\x02\xca\x05\xc2\x03\x76\x00\x77\x00\x78\x00\x5e\x01\x6a\x04\x6b\x04\x6c\x04\x8f\x00\x90\x00\x94\x01\x95\x01\x92\x00\x93\x00\x92\x01\x8d\x01\xdd\x00\xa5\x00\xd9\x00\x0f\x00\xde\x00\x65\x04\x66\x04\x67\x04\x76\x02\xc5\x04\x11\x00\xc6\x04\x80\x00\x81\x00\x73\x02\xb1\x04\xa6\x00\xb2\x04\x64\x02\xc1\x02\xc2\x02\x60\x02\x80\x00\x81\x00\xfd\x00\xb1\x02\x4b\x01\x4c\x01\x93\x00\xe5\x04\x6b\x04\x6c\x04\xc3\x02\x52\x05\x96\x00\x53\x05\x56\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x5f\x02\xc4\x02\xc5\x02\xc6\x02\x89\x02\xfa\x00\xd3\x01\xb1\x04\x37\x00\xb2\x04\xda\x00\x58\x01\x63\x02\x30\x01\x24\x03\x69\x03\x21\x01\x42\x01\x3e\x00\x3f\x00\x57\x05\x40\x00\x41\x00\x2c\x01\x59\x01\x66\x03\x5a\x01\x5b\x01\x8f\x01\x8d\x01\x58\x00\xdf\x04\x6b\x04\x6c\x04\x3c\x05\x6b\x04\x6c\x04\x7b\x00\xff\x01\x7c\x00\x7d\x00\x7e\x00\x59\x00\x7f\x00\xa2\x00\xa3\x00\x82\x00\x83\x00\xe8\x02\x8c\x01\x8d\x01\x5d\x00\x50\x02\xa4\x00\x75\x00\x4f\x02\x42\x00\x44\x02\x76\x00\x77\x00\x78\x00\x31\x02\x42\x00\xbb\x02\xf0\x05\x6b\x04\x6c\x04\x35\x01\x36\x01\x80\x01\x11\x01\x43\x00\xbe\x03\xbf\x03\x66\x00\x67\x00\x5c\x03\x43\x00\x6a\x00\x6b\x00\xd9\x00\x94\x01\x74\x04\xdd\x00\xa5\x00\x25\x02\x0f\x00\xde\x00\x42\x00\xf8\x05\x6b\x04\x6c\x04\x2b\x04\x11\x00\x25\x04\x80\x00\x81\x00\xc1\x02\xc2\x02\xa6\x00\x22\x04\xd9\x00\xfd\x00\x43\x00\xb9\x02\x4b\x00\x93\x00\x17\x04\x5a\x04\x5b\x04\xc3\x02\x18\x04\x96\x00\x13\x05\x0f\x05\x98\x00\x99\x00\x9a\x00\x9b\x00\xbb\xfc\xc4\x02\xc5\x02\xc6\x02\xda\xfc\xfa\x00\x0e\x05\x0f\x05\xd4\x04\x9d\x03\xda\x00\x62\x02\x62\x05\x49\x00\x45\x00\x46\x00\xad\x05\xbf\x03\x48\x00\x49\x00\x45\x00\x46\x00\xc2\xfc\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x2b\x05\x67\x04\x4c\x00\xda\x00\x4e\x00\xe4\x05\xe5\x05\xc3\xfc\x4c\x00\x4d\x00\x4e\x00\xd9\xfc\xbc\xfc\xbd\xfc\x16\x04\x4f\x00\xa2\x00\xa3\x00\x45\x00\x46\x00\x15\x04\x4f\x00\x48\x00\x49\x00\x14\x04\xa4\x00\x75\x00\x13\x04\x12\x04\xea\xfc\x76\x00\x77\x00\x78\x00\x0e\x04\x4c\x00\x0f\x04\x4e\x00\xc5\x03\x86\x01\x87\x01\x88\x01\x80\x01\x89\x01\x0d\x04\xe4\x03\x24\x01\x5c\x02\x4f\x00\x76\x00\x25\x01\x78\x00\x59\x02\xd4\x03\xd3\x03\xcc\x03\xdd\x00\xa5\x00\xcd\x03\x0f\x00\xde\x00\xca\x03\xc5\x03\xc9\x03\xc8\x03\x02\x03\x11\x00\x7b\x01\x80\x00\x81\x00\xc1\x02\x59\x04\xa6\x00\xc2\x03\x26\x01\xfd\x00\xbd\x03\xc1\x03\x27\x01\x93\x00\xa0\x03\xee\xfc\x9b\x03\xc3\x02\x11\x00\x96\x00\x98\x03\x28\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x95\x03\xc4\x02\xc5\x02\xc6\x02\xdb\x00\x91\x03\x94\x03\x90\x03\x93\x00\x8f\x03\x8e\x03\x8e\x00\xdc\x00\x38\x01\x96\x00\x85\x03\x68\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x63\x03\x62\x03\x9c\x00\x9d\x00\x5f\x03\x5c\x03\x11\x01\x37\x00\x56\x04\xaa\x04\xa3\x04\x55\x01\xa2\x04\x56\x01\x9d\x04\x9e\x04\x3d\x00\x3e\x00\x3f\x00\x93\x04\x40\x00\x41\x00\x96\x04\xa2\x00\xa3\x00\x98\x04\x94\x04\x92\x04\x90\x04\xe4\xfc\xe3\xfc\xe5\xfc\xa4\x00\x75\x00\x8d\x04\x86\x04\x82\x04\x76\x00\x77\x00\x78\x00\xa7\x03\x8b\x04\x7f\x04\x7d\x04\xa2\x00\xa3\x00\x77\x04\xa6\x03\x72\x04\x70\x04\x6e\x04\x95\x02\x69\x04\xa4\x00\x75\x00\x65\x04\x62\x04\x15\x02\x76\x00\x77\x00\x78\x00\x42\x00\xdd\x00\xa5\x00\x5c\x02\x0f\x00\xde\x00\xcb\x05\x53\x04\x16\x02\x17\x02\x18\x02\x11\x00\x61\x04\x80\x00\x81\x00\x43\x00\x56\x04\xa6\x00\x57\x04\x4c\x04\x4a\x04\x42\x04\xdd\x00\xa5\x00\x6c\x00\x0f\x00\xde\x00\x61\x02\x44\x04\x37\x04\x42\x00\x39\x04\x11\x00\x37\x00\x80\x00\x81\x00\x38\x04\xa8\x03\xa6\x00\xa9\x03\x30\x04\x2f\x04\x3d\x00\x3e\x00\x3f\x00\x43\x00\x40\x00\x41\x00\x0e\x05\x0d\x05\x42\x00\x0b\x05\xc6\x03\x88\x01\x91\x02\x89\x01\xa6\x03\xd5\x01\x24\x01\xda\x03\x37\x00\x76\x00\x25\x01\x78\x00\xa8\x03\x43\x00\xa9\x03\x03\x05\xae\x04\x3d\x00\x3e\x00\x3f\x00\xfb\x04\x40\x00\x41\x00\xf7\x04\xf8\x04\x45\x00\x46\x00\xf6\x04\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xf5\x04\x26\x01\x42\x00\x6e\x04\xe3\x04\x27\x01\x70\x04\x6e\x04\x4c\x00\x4d\x00\x4e\x00\x11\x00\xcf\x04\xd3\x04\x28\x01\xca\x04\xc3\x04\x43\x00\xc9\x04\xc2\x04\xbf\x04\x4f\x00\x45\x00\x46\x00\x55\x05\xbe\x04\x48\x00\x49\x00\x54\x05\x42\x00\x56\x04\xae\x04\x66\x05\x6e\x04\x46\x05\x51\x01\x30\x05\x31\x05\x4c\x00\x73\xfe\x4e\x00\x69\x04\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x29\x05\x4f\x00\x25\x05\x21\x01\x85\x00\x9c\x05\xa3\x05\xa1\x05\x4c\x00\x4d\x00\x4e\x00\x99\x05\x7c\x01\x9a\x05\x96\x05\x92\x05\x87\x00\x91\x05\x8c\x05\x5c\x04\x88\x00\x4f\x00\x8d\x05\x8f\x05\x81\x05\x89\x00\x72\x05\x62\x01\x69\x05\x45\x00\x46\x00\x63\x01\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x7f\x01\x71\x05\x70\x05\xa2\x04\xc6\x05\xc7\x05\x80\x01\xbf\x05\x4c\x00\x4d\x00\x4e\x00\x8f\x00\x90\x00\x61\x01\x9b\x03\x92\x00\x93\x00\xb1\x05\x7b\x01\x45\x00\x46\x00\x4f\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x5c\x03\x5c\x02\xd5\x05\xd0\x05\x5c\x03\xcd\x05\xca\x05\xe0\x05\x4c\x00\x4d\x00\x4e\x00\xf5\x05\x70\x04\xf6\x05\x6e\x04\xf0\x05\x93\x00\xfe\x05\x64\x01\x65\x01\x66\x01\x4f\x00\x96\x00\x66\x05\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x68\x01\x6e\x04\x9c\x00\x9d\x00\x58\x01\xf8\x05\xfd\x05\x01\x06\x69\x01\x6a\x01\x11\x01\x0f\x01\x37\x00\x38\x00\xfb\x01\x3a\x00\x3b\x00\x59\x01\x3c\x00\x5a\x01\x5b\x01\x3d\x00\x3e\x00\x3f\x00\xe5\x01\x40\x00\x41\x00\x1a\x02\x29\x02\xcc\x01\x7b\x00\x28\x02\x7c\x00\x7d\x00\x7e\x00\x48\x02\x7f\x00\xa5\x01\x9a\x01\x82\x00\x83\x00\x5f\x01\xae\x01\xab\x01\xa2\x00\xa3\x00\x48\x01\x3d\x01\x1f\x01\x1e\x01\x1a\x01\x52\x03\x51\x03\xa4\x00\x75\x00\x50\x03\x4d\x03\x45\x03\x76\x00\x77\x00\x78\x00\x2f\x03\x6b\x01\x62\x01\x1b\x03\x29\x03\x42\x00\x63\x01\x1a\x02\x18\x03\x17\x03\x0f\x03\xe1\x02\x03\x03\xd9\x02\xd3\x02\x6c\x01\x6d\x01\xd5\x02\x6e\x01\xbc\x02\x43\x00\xab\x02\x99\x02\xa5\x00\x96\x02\x0f\x00\x10\x00\x8f\x02\x6f\x01\x70\x01\xb9\x01\x72\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x73\x01\x83\x00\xa6\x00\x2c\x02\x31\x02\x74\x01\x2b\x02\x75\x01\x2d\x04\x2c\x04\x57\x03\x76\x01\x2b\x04\x26\x04\x77\x01\x8d\x02\x10\x04\x78\x01\x9e\x03\x93\x00\xe8\x03\x64\x01\x65\x01\x66\x01\x99\x03\x96\x00\x44\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x68\x01\xe4\x03\x9c\x00\x9d\x00\x96\x03\x9c\x01\x9d\x01\x46\x00\x69\x01\x6a\x01\x48\x00\x49\x00\x95\x03\xdb\x03\x45\x00\x46\x00\xda\x03\x47\x00\x48\x00\x49\x00\xfc\x01\x4b\x00\x9e\x01\x92\x03\x4e\x00\x85\x00\x9a\x01\x85\x03\x75\x03\x6d\x03\xb3\x05\x4d\x00\x4e\x00\x6b\x03\x6a\x03\x4f\x00\x68\x03\x87\x00\x5d\x03\x5c\x03\x5a\x03\x88\x00\xac\x04\x4f\x00\xa2\x00\xa3\x00\x89\x00\x63\x03\xa0\x04\x94\x04\x9b\x04\x89\x04\xfd\x01\xa4\x00\x75\x00\x86\x04\x84\x04\x80\x04\x76\x00\x77\x00\x78\x00\x75\x04\x6b\x01\x62\x01\x77\x04\x5e\x01\x6e\x04\x63\x01\x54\x04\x8f\x00\x90\x00\x30\x04\x17\x05\x92\x00\x93\x00\x4c\x04\x6c\x01\x6d\x01\x14\x05\x6e\x01\x44\x04\x07\x05\x05\x05\xed\x04\xa5\x00\xe0\x04\x0f\x00\x10\x00\xcf\x04\x6f\x01\x70\x01\x71\x01\x72\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x73\x01\x83\x00\xa6\x00\x8d\x02\xd5\x04\x74\x01\xcd\x04\x75\x01\xc0\x04\xbf\x04\xaf\x04\x76\x01\xae\x04\x64\x05\x77\x01\x50\x05\x44\x05\x78\x01\x34\x05\x93\x00\x61\x05\xb2\x01\x65\x01\x66\x01\x46\x05\x96\x00\x5a\x05\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x21\x05\x20\x05\x9c\x00\x9d\x00\xa3\x05\x1f\x05\xa1\x05\x9e\x05\xb3\x01\xb4\x01\x82\x05\x9d\x05\x96\x05\x87\x05\x8f\x05\x31\x05\x14\x03\x81\x05\x7f\x05\x37\x00\x38\x00\x74\x05\x15\x03\x3b\x00\x72\x05\x3c\x00\x7c\x02\x69\x05\x3d\x00\x3e\x00\x3f\x00\xc4\x05\x40\x00\x41\x00\x23\x01\x32\x05\xc2\x05\x24\x01\xc1\x05\xbb\x05\x76\x00\x25\x01\x78\x00\xba\x05\xa2\x00\xa3\x00\xb7\x05\xab\x05\xaa\x05\xce\x05\xc8\x05\xde\x05\xf2\x05\xa4\x00\x75\x00\xe3\x05\xda\x05\xd8\x05\x76\x00\x77\x00\x78\x00\xf1\x05\x6b\x01\x62\x01\xfe\x05\x26\x01\x42\x00\x63\x01\xf3\x05\x27\x01\xfb\x05\xf6\x05\x00\x00\x42\x00\x00\x00\x11\x00\x6c\x01\x6d\x01\x28\x01\x6e\x01\x00\x00\x43\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x43\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x00\x00\xb7\x01\x00\x00\x75\x01\x00\x00\x00\x00\x00\x00\x76\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x01\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x44\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x46\x02\x00\x00\xba\x01\x00\x00\x00\x00\x00\x00\xbb\x01\xbc\x01\x45\x00\x46\x00\x00\x00\x00\x00\x48\x00\x49\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4f\x00\xa2\x00\xa3\x00\x42\x00\x00\x00\x62\x01\x00\x00\x4f\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x43\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x44\x02\x00\x00\xa4\x02\x45\x00\x46\x00\xa5\x02\x00\x00\x48\x00\x49\x00\x40\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x84\x01\x85\x01\x86\x01\x87\x01\x88\x01\x00\x00\x89\x01\x00\x00\x00\x00\x24\x01\x4f\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\xa2\x00\xa3\x00\x42\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x43\x00\x6b\x01\x00\x00\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x6c\x01\x6d\x01\x28\x01\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x45\x00\x46\x00\xec\x03\x00\x00\x48\x00\x49\x00\x1e\x04\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x00\x00\x48\x00\x49\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\xef\x04\x00\x00\x00\x00\xea\x02\x00\x00\xf0\x04\xf1\x04\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x00\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x4e\x00\xf2\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\x3a\x05\x00\x00\x3b\x05\xf7\x03\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x01\x75\x00\x4c\x00\x4d\x00\x4e\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\xb0\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xee\x03\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x22\x03\xef\x03\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x37\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x11\x03\x3b\x04\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x42\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x01\x65\x01\x66\x01\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x4f\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x6d\x01\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x6f\x01\xb5\x01\x00\x00\xb6\x01\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xb2\x03\x65\x01\xf1\x02\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\xf6\x03\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x5d\x01\x90\xfe\x00\x00\x00\x00\x00\x00\x90\xfe\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x89\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x5e\x01\x76\x00\x77\x00\x78\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\xa5\x00\x62\x01\x0f\x00\x10\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x76\x01\x00\x00\x11\x00\xb3\x03\x80\x00\x81\x00\x78\x01\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\xfc\x04\x65\x01\xf1\x02\x00\x00\x96\x00\x76\x01\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x40\x03\x41\x03\x00\x00\x00\x00\x24\x01\x00\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x26\x01\x76\x00\x77\x00\x78\x00\x27\x01\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x11\x00\x62\x01\x00\x00\x28\x01\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x62\x01\x0f\x00\x10\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x76\x01\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x78\x01\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\xf2\x02\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x89\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\xa4\x00\x75\x00\x00\x00\x00\x00\x5e\x01\x76\x00\x77\x00\x78\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\xa5\x00\x62\x01\x0f\x00\x10\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\xb7\x03\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x78\x01\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\xb6\x03\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x78\x01\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x65\x01\xf1\x02\x00\x00\x96\x00\x00\x00\x67\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x2c\x05\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xa2\x00\xa3\x00\x00\x00\xf6\x01\xf7\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x2d\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x42\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x43\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xb5\x03\x85\x00\x61\x03\x00\x00\x00\x00\x11\x00\x78\x01\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\xb4\x03\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x78\x01\x85\x00\x5e\x04\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x5e\x01\x00\x00\x88\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x89\x00\x92\x00\x93\x00\x37\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x21\x02\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x5e\x01\x4c\x00\x4d\x00\x4e\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\xf5\x01\x3a\x00\x3b\x00\xf8\x01\x3c\x00\x2e\x05\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\xf6\x01\xf7\x01\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x05\x00\x00\x00\x00\x37\x00\x38\x00\x65\x02\x3a\x00\x3b\x00\x43\x00\x3c\x00\x00\x00\x87\x00\x3d\x00\x3e\x00\x3f\x00\x88\x00\x40\x00\x41\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x00\x00\x00\x00\x43\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\x37\x00\x38\x00\xfb\x01\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x42\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x58\x01\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x59\x01\x00\x00\x5a\x01\x5b\x01\x00\x00\x00\x00\x44\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x7c\x00\x7d\x00\x7e\x00\x00\x00\x7f\x00\x00\x00\x4f\x00\x82\x00\x83\x00\x00\x00\x42\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xf8\x01\x00\x00\xf9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x4d\x02\x7e\x00\x4f\x00\x7f\x00\x00\x00\x62\x01\xe7\x01\x83\x00\x00\x00\x63\x01\x00\x00\xe8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\xfc\x01\x4b\x00\x62\x01\x00\x00\x00\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x03\x41\x03\x00\x00\x00\x00\x24\x01\x4f\x00\x62\x01\x76\x00\x25\x01\x78\x00\x63\x01\x00\x00\x00\x00\x00\x00\xfd\x01\x93\x00\x00\x00\x00\x00\xff\x02\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x93\x00\x00\x00\x00\x00\xbb\x03\xf1\x02\x11\x00\x96\x00\x00\x00\x28\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\xba\x03\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x62\x01\x76\x00\x77\x00\x78\x00\x63\x01\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x62\x01\x00\x00\xa6\x00\x00\x00\x63\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\xb1\x03\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x00\x00\x00\x00\x63\x04\xf1\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x13\x03\x14\x03\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x15\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x43\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x31\x05\x14\x03\xa6\x00\x00\x00\x37\x00\x38\x00\x00\x00\x15\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xae\x05\x00\x00\x00\x00\x9a\x04\x41\x03\x44\x00\x00\x00\x24\x01\x00\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x26\x01\x00\x00\x00\x00\x42\x00\x27\x01\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x11\x00\x00\x00\x00\x00\x28\x01\x00\x00\x00\x00\x81\x03\x14\x03\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x15\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xd1\x02\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xd2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\xea\x01\x00\x00\x00\x00\x00\x00\xeb\x01\x00\x00\x00\x00\x00\x00\xec\x01\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\xed\x01\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\xee\x01\x00\x00\x42\x00\x00\x00\x27\x01\x4c\x00\x4d\x00\x4e\x00\xef\x01\x7e\x00\x11\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\xd1\x02\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x91\x03\xf8\x04\x00\x00\xf9\x04\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x02\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xd3\x04\xf8\x04\x00\x00\x9a\x05\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x02\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x04\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xbd\x02\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x03\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x57\x04\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x04\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x56\x05\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x05\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xb9\x05\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x92\x05\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xcd\x05\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xbe\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x93\x05\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x4f\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xaf\xfd\xaf\xfd\x13\x00\xaf\xfd\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\x14\x00\xaf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\x00\x00\x00\x00\xaf\xfd\x15\x00\xaf\xfd\x00\x00\xaf\xfd\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\xaf\xfd\xaf\xfd\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\xfd\x00\x00\x23\x00\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x00\x00\xaf\xfd\xa0\x01\xaf\xfd\xa1\x01\xaf\xfd\xa2\x01\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x64\x00\x65\x00\xaf\xfd\xaf\xfd\xaf\xfd\x69\x00\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\xaf\xfd\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x72\xfe\x51\x00\x13\x00\x72\xfe\x00\x00\x00\x00\x00\x00\x72\xfe\x72\xfe\x14\x00\x72\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\xfe\x72\xfe\x00\x00\x00\x00\x72\xfe\x15\x00\x72\xfe\x00\x00\x72\xfe\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x72\xfe\x72\xfe\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x72\xfe\x00\x00\x23\x00\x72\xfe\x72\xfe\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\xfe\x72\xfe\x58\x00\x72\xfe\x72\xfe\x72\xfe\x00\x00\x00\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x00\x00\x72\xfe\x59\x00\x5a\x00\x5b\x00\x72\xfe\x5c\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x5d\x00\x00\x00\x00\x00\x1a\x02\x72\xfe\x5e\x00\x72\xfe\x00\x00\x72\xfe\x5f\x00\x72\xfe\x60\x00\x72\xfe\x61\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x6d\x00\x6e\x00\x6f\x00\x70\x00\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x72\xfe\x71\x00\x72\xfe\x72\xfe\x72\x00\x73\x00\x72\xfe\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x00\x00\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x79\xfe\x1c\x02\x1d\x02\x00\x00\x7b\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x00\x00\x00\x00\x79\xfe\x1e\x02\x00\x00\x79\xfe\x00\x00\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x79\xfe\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x00\x00\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\xfc\x92\xfc\x85\x00\xdf\x01\x92\xfc\x92\xfc\x00\x00\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x00\x00\x92\xfc\x87\x00\x92\xfc\x92\xfc\x92\xfc\x88\x00\xe0\x01\xe1\x01\xe2\x01\xe3\x01\x89\x00\x00\x00\x00\x00\x92\xfc\x92\xfc\x00\x00\x92\xfc\x00\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x5e\x01\x92\xfc\x92\xfc\x92\xfc\x8f\x00\x90\x00\x92\xfc\x92\xfc\x92\x00\x93\x00\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\x92\xfc\xdf\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xfd\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\xdf\xfd\x15\x00\xdf\xfd\x00\x00\xdf\xfd\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\xdf\xfd\xdf\xfd\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xb3\x00\x00\x00\x00\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\x00\x00\xdf\xfd\xdf\xfd\xb5\x00\xb6\x00\xb7\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\x00\x00\x00\x00\xdd\x01\xdf\xfd\x00\x00\xdf\xfd\x00\x00\xdf\xfd\xb8\x00\xdf\xfd\xb9\x00\xdf\xfd\xba\x00\xdf\xfd\xbb\x00\xdf\xfd\xdf\xfd\xdf\xfd\xdf\xfd\xbc\x00\x2d\x00\x8e\x00\xdf\xfd\xdf\xfd\x2e\x00\x91\x00\xdf\xfd\xdf\xfd\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xdf\xfd\xd7\x00\xdf\xfd\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xdf\xfd\xe0\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\xe0\xfd\x15\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xb3\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\xb5\x00\xb6\x00\xb7\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\xdd\x01\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xb8\x00\xe0\xfd\xb9\x00\xe0\xfd\xba\x00\xe0\xfd\xbb\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xbc\x00\x2d\x00\x8e\x00\xe0\xfd\xe0\xfd\x2e\x00\x91\x00\xe0\xfd\xe0\xfd\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xe0\xfd\xd7\x00\xe0\xfd\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xe0\xfd\x33\x02\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x8a\xfc\x00\x00\xf9\x02\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\xfa\x02\xfb\x02\xfc\x02\xfd\x02\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x8a\xfc\x00\x00\x00\x00\x00\x00\x8a\xfc\x00\x00\x8a\xfc\x00\x00\x8a\xfc\x00\x00\x00\x00\x8a\xfc\x8a\xfc\x34\x02\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\x33\x02\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x69\xfd\x00\x00\x69\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x34\x02\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x08\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x38\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x38\xfe\x00\x00\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x00\x00\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x64\xfe\x64\xfe\x64\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x64\xfe\x00\x00\x00\x00\x64\xfe\x64\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x63\xfe\x63\xfe\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x6f\x02\x70\x02\x63\xfe\x37\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x37\xfe\x00\x00\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x00\x00\x63\xfe\x63\xfe\x63\xfe\x42\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x43\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x63\xfe\x63\xfe\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x63\xfe\x40\x00\x41\x00\x63\xfe\x63\xfe\x98\x03\x70\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x37\x00\x38\x00\x8b\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x05\x0f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x44\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x1b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x05\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x37\x00\x38\x00\x19\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x43\x00\x3c\x00\x00\x00\x4f\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x18\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x6e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x44\x00\x00\x00\x00\x00\x39\x04\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x19\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x45\x02\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\xa8\x01\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\xc1\x01\x99\x00\x9a\x00\x9b\x00\x3e\x02\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x4f\x00\x37\x00\x38\x00\x82\x03\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x8b\x04\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x7d\x04\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\xa2\x00\xa3\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x45\x00\x46\x00\xa6\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x4c\x00\x4d\x00\x4e\x00\x05\x04\x00\x00\x06\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x35\x04\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\xa2\x00\xa3\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x04\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x94\x05\x3a\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x45\x00\x46\x00\xa6\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x04\x4c\x00\x4d\x00\x4e\x00\x05\x04\x00\x00\x06\x04\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x75\x05\x3a\x00\x3b\x00\x43\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x3d\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x4f\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x20\x02\x3b\x00\x43\x00\x3c\x00\x00\x00\x4f\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x7b\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x43\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x00\x00\x47\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x44\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x42\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x37\x00\x38\x00\x4f\x00\x41\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x00\x00\x3f\x02\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x25\x04\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\x1f\x04\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\xb8\x03\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\x9e\x04\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x38\x00\x00\x00\x0b\x05\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x38\x00\x44\x00\x29\x05\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x03\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\xe1\x04\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x04\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x05\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x05\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x05\x00\x00\x00\x00\x42\x01\x3e\x00\x3f\x00\x00\x00\x40\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x43\x00\x4f\x00\x12\x02\x13\x00\x42\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x4f\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\xaa\x00\x13\x00\xab\x00\x00\x01\x01\x01\x02\x01\x03\x01\x00\x00\x14\x00\xac\x00\x4f\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x04\x01\xe3\x00\x00\x00\x05\x01\x64\x00\x15\x00\x00\x00\x06\x01\x00\x00\x00\x00\x07\x01\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x09\x01\xe9\x00\x0a\x01\x0b\x01\x00\x00\x00\x00\x0c\x01\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x01\x05\x02\x05\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\xcc\xfc\x00\x00\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\x00\x00\xcc\xfc\x00\x00\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xcc\xfc\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x7c\x01\x00\x00\x00\x00\x00\x00\x7d\x01\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x7e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x7f\x01\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x80\x01\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\xdb\x04\xdc\x04\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xdd\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x4d\x05\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x4e\x05\x00\x00\x15\x00\x00\x00\x4f\x05\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\xdb\x04\xdc\x04\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xdd\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x4d\x05\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x4e\x05\x00\x00\x15\x00\x00\x00\x4f\x05\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\xb9\x01\xbb\x00\x00\x00\x00\x00\x80\x01\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x90\xfd\xba\x00\x90\xfd\xbb\x00\x00\x00\x00\x00\x58\x02\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x72\x02\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x58\x02\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x75\x02\xbb\x00\x00\x00\x00\x00\x58\x02\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\xb5\xfd\xb5\xfd\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\xb5\xfd\x00\x00\xb5\xfd\x00\x00\xb5\xfd\x00\x00\xb5\xfd\x00\x00\x00\x00\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\x00\x00\xb5\xfd\x00\x00\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb5\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\xb4\xfd\xb4\xfd\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\xb4\xfd\x00\x00\xb4\xfd\x00\x00\xb4\xfd\x00\x00\xb4\xfd\x00\x00\x00\x00\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\x00\x00\xb4\xfd\x00\x00\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xb4\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xda\x03\xc2\xfd\x00\x00\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\x00\x00\xc2\xfd\x00\x00\xc2\xfd\x00\x00\xc2\xfd\x00\x00\x00\x00\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\x00\x00\xc2\xfd\x00\x00\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xc2\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xbe\x01\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x5c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x08\x01\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\xe0\x00\xe1\x00\xe2\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\xe4\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xec\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x81\x01\xbc\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\xd5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x01\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x04\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\xb0\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\xb0\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\xf6\x03\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\xb0\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\xf6\x03\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x7a\x01\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xdc\x02\x86\x01\x87\x01\x88\x01\x00\x00\x89\x01\x00\x00\x00\x00\x24\x01\x00\x00\x00\x00\x76\x00\x25\x01\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x00\x00\x00\x00\x4d\x02\x7e\x00\x11\x00\x7f\x00\x00\x00\x28\x01\x8f\x01\xdd\x02\xf2\xfd\x00\x00\xf2\xfd\xe8\x01\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xc7\x01\xc8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x01\x00\x00\xf2\xfd\x00\x00\xf2\xfd\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\xf2\xfd\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x03\x00\x00\xc6\xfe\x00\x00\xc6\xfe\x00\x00\xc6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\x00\x00\xc6\xfe\xc6\xfe\x00\x00\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\x00\x00\xc6\xfe\x00\x00\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xc6\xfe\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xd5\x02\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x0a\x04\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x08\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xd5\x02\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\x00\x00\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\x00\x00\xbd\xfe\x00\x00\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xbd\xfe\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x69\xfd\x00\x00\x69\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x08\x04\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\xec\x03\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xaf\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb6\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\xbd\x00\xbe\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\xaa\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xea\xfd\x85\x00\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xf6\x02\xf7\x02\x00\x00\x7a\xfe\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x89\x00\x00\x00\x00\x00\x00\x00\xf8\x02\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\x00\x00\xea\xfd\xea\xfd\x5e\x01\x00\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x92\x00\x93\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x00\x00\xd7\x00\x00\x00\x71\x00\xd8\x00\xd9\x00\x72\x00\x73\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x15\xfd\x00\x00\x15\xfd\x59\x02\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\xfd\x15\xfd\x15\xfd\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xfd\x15\x00\x00\x00\x15\xfd\x15\xfd\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x02\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\xfb\x01\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\xb5\x05\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x01\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x02\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x45\x01\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x01\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x47\x01\x48\x01\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x02\x5a\x00\x5b\x00\x00\x00\x69\x02\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x6b\x02\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x62\x00\x63\x00\x64\x00\x65\x00\x6c\x02\x6d\x02\x68\x00\x69\x00\x6a\x00\x6e\x02\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x5d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x02\x02\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x05\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x43\x05\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x34\x05\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x05\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x05\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\xb5\x05\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\xb6\x05\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x52\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\xab\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\xab\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x15\x00\x00\x00\x72\x00\x73\x00\x26\x03\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\xf4\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\xf4\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x00\x00\x51\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x01\x64\x00\x65\x00\x00\x00\x00\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x00\x00\x72\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\xfb\x03\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\xfc\x03\x00\x00\xa8\x00\x00\x00\xfd\x03\x00\x00\xfe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x04\x00\x00\xa8\x00\x00\x00\xfd\x03\x00\x00\xfe\x03\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x03\xfa\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x4a\x04\x00\x00\xa8\x00\x00\x00\xfd\x03\x00\x00\xfe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x03\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x03\x04\x00\x00\x00\x00\x00\x00\xc3\x01\x02\x04\xc5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x05\x04\x00\x00\x06\x04\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x15\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x06\x05\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x7b\x03\x7c\x03\x7d\x03\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x7f\x03\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x08\x02\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x7f\x03\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x7e\x03\x7f\x03\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x3a\x02\x3b\x02\xde\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x3c\x02\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x1f\x05\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x3c\x02\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x3c\x02\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x03\xf1\x03\xf2\x03\xf3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\xf4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x3c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xff\x04\xf2\x03\xf3\x03\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\xf4\x03\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x0d\x01\x0e\x01\xa1\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x9f\x00\x00\x00\xa0\x00\xa1\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xae\x02\x00\x00\x00\x00\xad\x02\xa1\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xac\x02\x00\x00\x00\x00\xad\x02\xa1\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\xe9\x01\x80\x00\x81\x00\x9c\x00\x9d\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x02\x8b\x02\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x8c\x02\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa3\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\xd0\x01\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa1\x03\x8b\x02\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x02\x00\x00\x00\x00\xd1\x01\xd2\x01\xd3\x01\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x04\x53\x04\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\xfe\x04\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x3f\x04\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xee\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xec\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x93\x00\x6e\x03\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x03\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x03\x11\x00\x00\x00\x80\x00\x81\x00\xa8\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x6e\x03\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xef\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xd6\x01\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xaa\x01\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xa4\x01\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x86\x02\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x0b\x04\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x0a\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\xf8\x03\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xa2\x03\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x58\x04\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x4e\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x40\x04\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x3e\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x04\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xde\x04\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x59\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x27\x05\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x26\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x25\x05\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x9c\x05\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\xac\x05\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\xa7\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x7a\x02\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x79\x02\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\xa8\x00\xa6\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x95\x00\x78\x02\x96\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa8\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x16\x00\x17\x00\x18\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x14\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x02\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x3a\x02\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x13\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x8d\x00\x00\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x2e\x00\x91\x00\x92\x00\x93\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x02\x13\x00\xf1\x01\x00\x00\xf2\x01\x00\x00\x8c\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\xf3\x01\x00\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x00\x00\x91\x00\x15\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x03\x06\x03\x00\x00\x07\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x03\x06\x03\x00\x00\x07\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x03\x11\x00\x13\x00\x80\x00\x81\x00\xb8\x04\xb9\x04\xa6\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x03\xba\x04\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xbc\x04\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\xb8\x04\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x05\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xee\x05\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xbd\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x13\x00\x00\x00\x00\x00\xb8\x04\x00\x00\x00\x00\xef\x05\x14\x00\x00\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x00\x00\xed\x05\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\xee\x05\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\xb8\x04\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xbb\x04\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xbd\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x14\x00\x00\x00\x00\x00\x00\x00\x6f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x2d\x00\x65\x00\x00\x00\x00\x00\x2e\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\xf2\xfd\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\xf2\xfd\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x8f\x01\x00\x00\xf2\xfd\x14\x00\xf2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xfd\xf2\xfd\x00\x00\x15\x00\xf2\xfd\xf2\xfd\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x14\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x15\x00\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\xf1\x01\x00\x00\xf2\x01\x14\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x15\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x2e\x00\x91\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x64\x00\x65\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x15\x00\x84\x02\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x01\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x13\x00\x8b\x01\x7f\x01\x8c\x00\x00\x00\x00\x00\x00\x00\x14\x00\x80\x01\x00\x00\x00\x00\x2d\x00\x8e\x00\x8f\x00\x90\x00\x00\x00\x2a\x01\x00\x00\x00\x00\x15\x00\x00\x00\x2b\x01\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x2c\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x3d\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x2c\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x8b\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x2c\x01\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x13\x02\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x14\x02\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x64\x00\x12\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x02\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x02\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x14\x02\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x64\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x14\x02\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xfe\x15\x00\x00\x00\x00\x00\x00\x00\xf4\xfe\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x37\x03\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x00\x00\xcd\x02\x00\x00\x00\x00\x2d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x13\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x14\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x04\x16\x00\x17\x00\x18\x00\x53\x00\x54\x00\x55\x00\x00\x00\x00\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x00\x00\x23\x00\xc3\x01\xc4\x01\xc5\x01\x00\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa9\x01\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x64\x00\x4b\x03\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xec\x02\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x01\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x01\x9d\x02\xc5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xd1\x03\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xca\x03\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\x96\x04\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x43\x05\x00\x00\x96\x00\x00\x00\x00\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xa2\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xe9\x03\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\xea\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa4\x00\x75\x00\xa6\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\xdb\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x01\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xc0\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x01\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x93\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x01\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x4a\x03\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x03\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x93\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x01\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x93\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x02\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xb9\x03\x9a\x00\x9b\x00\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x03\x9a\x00\x9b\x00\xa4\x00\x75\x00\x9c\x00\x9d\x00\x93\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\xa2\x00\xa3\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x75\x00\x00\x00\x00\x00\x00\x00\x76\x00\x77\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa3\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x80\x00\x81\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (13, 906) [ + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188), + (189 , happyReduce_189), + (190 , happyReduce_190), + (191 , happyReduce_191), + (192 , happyReduce_192), + (193 , happyReduce_193), + (194 , happyReduce_194), + (195 , happyReduce_195), + (196 , happyReduce_196), + (197 , happyReduce_197), + (198 , happyReduce_198), + (199 , happyReduce_199), + (200 , happyReduce_200), + (201 , happyReduce_201), + (202 , happyReduce_202), + (203 , happyReduce_203), + (204 , happyReduce_204), + (205 , happyReduce_205), + (206 , happyReduce_206), + (207 , happyReduce_207), + (208 , happyReduce_208), + (209 , happyReduce_209), + (210 , happyReduce_210), + (211 , happyReduce_211), + (212 , happyReduce_212), + (213 , happyReduce_213), + (214 , happyReduce_214), + (215 , happyReduce_215), + (216 , happyReduce_216), + (217 , happyReduce_217), + (218 , happyReduce_218), + (219 , happyReduce_219), + (220 , happyReduce_220), + (221 , happyReduce_221), + (222 , happyReduce_222), + (223 , happyReduce_223), + (224 , happyReduce_224), + (225 , happyReduce_225), + (226 , happyReduce_226), + (227 , happyReduce_227), + (228 , happyReduce_228), + (229 , happyReduce_229), + (230 , happyReduce_230), + (231 , happyReduce_231), + (232 , happyReduce_232), + (233 , happyReduce_233), + (234 , happyReduce_234), + (235 , happyReduce_235), + (236 , happyReduce_236), + (237 , happyReduce_237), + (238 , happyReduce_238), + (239 , happyReduce_239), + (240 , happyReduce_240), + (241 , happyReduce_241), + (242 , happyReduce_242), + (243 , happyReduce_243), + (244 , happyReduce_244), + (245 , happyReduce_245), + (246 , happyReduce_246), + (247 , happyReduce_247), + (248 , happyReduce_248), + (249 , happyReduce_249), + (250 , happyReduce_250), + (251 , happyReduce_251), + (252 , happyReduce_252), + (253 , happyReduce_253), + (254 , happyReduce_254), + (255 , happyReduce_255), + (256 , happyReduce_256), + (257 , happyReduce_257), + (258 , happyReduce_258), + (259 , happyReduce_259), + (260 , happyReduce_260), + (261 , happyReduce_261), + (262 , happyReduce_262), + (263 , happyReduce_263), + (264 , happyReduce_264), + (265 , happyReduce_265), + (266 , happyReduce_266), + (267 , happyReduce_267), + (268 , happyReduce_268), + (269 , happyReduce_269), + (270 , happyReduce_270), + (271 , happyReduce_271), + (272 , happyReduce_272), + (273 , happyReduce_273), + (274 , happyReduce_274), + (275 , happyReduce_275), + (276 , happyReduce_276), + (277 , happyReduce_277), + (278 , happyReduce_278), + (279 , happyReduce_279), + (280 , happyReduce_280), + (281 , happyReduce_281), + (282 , happyReduce_282), + (283 , happyReduce_283), + (284 , happyReduce_284), + (285 , happyReduce_285), + (286 , happyReduce_286), + (287 , happyReduce_287), + (288 , happyReduce_288), + (289 , happyReduce_289), + (290 , happyReduce_290), + (291 , happyReduce_291), + (292 , happyReduce_292), + (293 , happyReduce_293), + (294 , happyReduce_294), + (295 , happyReduce_295), + (296 , happyReduce_296), + (297 , happyReduce_297), + (298 , happyReduce_298), + (299 , happyReduce_299), + (300 , happyReduce_300), + (301 , happyReduce_301), + (302 , happyReduce_302), + (303 , happyReduce_303), + (304 , happyReduce_304), + (305 , happyReduce_305), + (306 , happyReduce_306), + (307 , happyReduce_307), + (308 , happyReduce_308), + (309 , happyReduce_309), + (310 , happyReduce_310), + (311 , happyReduce_311), + (312 , happyReduce_312), + (313 , happyReduce_313), + (314 , happyReduce_314), + (315 , happyReduce_315), + (316 , happyReduce_316), + (317 , happyReduce_317), + (318 , happyReduce_318), + (319 , happyReduce_319), + (320 , happyReduce_320), + (321 , happyReduce_321), + (322 , happyReduce_322), + (323 , happyReduce_323), + (324 , happyReduce_324), + (325 , happyReduce_325), + (326 , happyReduce_326), + (327 , happyReduce_327), + (328 , happyReduce_328), + (329 , happyReduce_329), + (330 , happyReduce_330), + (331 , happyReduce_331), + (332 , happyReduce_332), + (333 , happyReduce_333), + (334 , happyReduce_334), + (335 , happyReduce_335), + (336 , happyReduce_336), + (337 , happyReduce_337), + (338 , happyReduce_338), + (339 , happyReduce_339), + (340 , happyReduce_340), + (341 , happyReduce_341), + (342 , happyReduce_342), + (343 , happyReduce_343), + (344 , happyReduce_344), + (345 , happyReduce_345), + (346 , happyReduce_346), + (347 , happyReduce_347), + (348 , happyReduce_348), + (349 , happyReduce_349), + (350 , happyReduce_350), + (351 , happyReduce_351), + (352 , happyReduce_352), + (353 , happyReduce_353), + (354 , happyReduce_354), + (355 , happyReduce_355), + (356 , happyReduce_356), + (357 , happyReduce_357), + (358 , happyReduce_358), + (359 , happyReduce_359), + (360 , happyReduce_360), + (361 , happyReduce_361), + (362 , happyReduce_362), + (363 , happyReduce_363), + (364 , happyReduce_364), + (365 , happyReduce_365), + (366 , happyReduce_366), + (367 , happyReduce_367), + (368 , happyReduce_368), + (369 , happyReduce_369), + (370 , happyReduce_370), + (371 , happyReduce_371), + (372 , happyReduce_372), + (373 , happyReduce_373), + (374 , happyReduce_374), + (375 , happyReduce_375), + (376 , happyReduce_376), + (377 , happyReduce_377), + (378 , happyReduce_378), + (379 , happyReduce_379), + (380 , happyReduce_380), + (381 , happyReduce_381), + (382 , happyReduce_382), + (383 , happyReduce_383), + (384 , happyReduce_384), + (385 , happyReduce_385), + (386 , happyReduce_386), + (387 , happyReduce_387), + (388 , happyReduce_388), + (389 , happyReduce_389), + (390 , happyReduce_390), + (391 , happyReduce_391), + (392 , happyReduce_392), + (393 , happyReduce_393), + (394 , happyReduce_394), + (395 , happyReduce_395), + (396 , happyReduce_396), + (397 , happyReduce_397), + (398 , happyReduce_398), + (399 , happyReduce_399), + (400 , happyReduce_400), + (401 , happyReduce_401), + (402 , happyReduce_402), + (403 , happyReduce_403), + (404 , happyReduce_404), + (405 , happyReduce_405), + (406 , happyReduce_406), + (407 , happyReduce_407), + (408 , happyReduce_408), + (409 , happyReduce_409), + (410 , happyReduce_410), + (411 , happyReduce_411), + (412 , happyReduce_412), + (413 , happyReduce_413), + (414 , happyReduce_414), + (415 , happyReduce_415), + (416 , happyReduce_416), + (417 , happyReduce_417), + (418 , happyReduce_418), + (419 , happyReduce_419), + (420 , happyReduce_420), + (421 , happyReduce_421), + (422 , happyReduce_422), + (423 , happyReduce_423), + (424 , happyReduce_424), + (425 , happyReduce_425), + (426 , happyReduce_426), + (427 , happyReduce_427), + (428 , happyReduce_428), + (429 , happyReduce_429), + (430 , happyReduce_430), + (431 , happyReduce_431), + (432 , happyReduce_432), + (433 , happyReduce_433), + (434 , happyReduce_434), + (435 , happyReduce_435), + (436 , happyReduce_436), + (437 , happyReduce_437), + (438 , happyReduce_438), + (439 , happyReduce_439), + (440 , happyReduce_440), + (441 , happyReduce_441), + (442 , happyReduce_442), + (443 , happyReduce_443), + (444 , happyReduce_444), + (445 , happyReduce_445), + (446 , happyReduce_446), + (447 , happyReduce_447), + (448 , happyReduce_448), + (449 , happyReduce_449), + (450 , happyReduce_450), + (451 , happyReduce_451), + (452 , happyReduce_452), + (453 , happyReduce_453), + (454 , happyReduce_454), + (455 , happyReduce_455), + (456 , happyReduce_456), + (457 , happyReduce_457), + (458 , happyReduce_458), + (459 , happyReduce_459), + (460 , happyReduce_460), + (461 , happyReduce_461), + (462 , happyReduce_462), + (463 , happyReduce_463), + (464 , happyReduce_464), + (465 , happyReduce_465), + (466 , happyReduce_466), + (467 , happyReduce_467), + (468 , happyReduce_468), + (469 , happyReduce_469), + (470 , happyReduce_470), + (471 , happyReduce_471), + (472 , happyReduce_472), + (473 , happyReduce_473), + (474 , happyReduce_474), + (475 , happyReduce_475), + (476 , happyReduce_476), + (477 , happyReduce_477), + (478 , happyReduce_478), + (479 , happyReduce_479), + (480 , happyReduce_480), + (481 , happyReduce_481), + (482 , happyReduce_482), + (483 , happyReduce_483), + (484 , happyReduce_484), + (485 , happyReduce_485), + (486 , happyReduce_486), + (487 , happyReduce_487), + (488 , happyReduce_488), + (489 , happyReduce_489), + (490 , happyReduce_490), + (491 , happyReduce_491), + (492 , happyReduce_492), + (493 , happyReduce_493), + (494 , happyReduce_494), + (495 , happyReduce_495), + (496 , happyReduce_496), + (497 , happyReduce_497), + (498 , happyReduce_498), + (499 , happyReduce_499), + (500 , happyReduce_500), + (501 , happyReduce_501), + (502 , happyReduce_502), + (503 , happyReduce_503), + (504 , happyReduce_504), + (505 , happyReduce_505), + (506 , happyReduce_506), + (507 , happyReduce_507), + (508 , happyReduce_508), + (509 , happyReduce_509), + (510 , happyReduce_510), + (511 , happyReduce_511), + (512 , happyReduce_512), + (513 , happyReduce_513), + (514 , happyReduce_514), + (515 , happyReduce_515), + (516 , happyReduce_516), + (517 , happyReduce_517), + (518 , happyReduce_518), + (519 , happyReduce_519), + (520 , happyReduce_520), + (521 , happyReduce_521), + (522 , happyReduce_522), + (523 , happyReduce_523), + (524 , happyReduce_524), + (525 , happyReduce_525), + (526 , happyReduce_526), + (527 , happyReduce_527), + (528 , happyReduce_528), + (529 , happyReduce_529), + (530 , happyReduce_530), + (531 , happyReduce_531), + (532 , happyReduce_532), + (533 , happyReduce_533), + (534 , happyReduce_534), + (535 , happyReduce_535), + (536 , happyReduce_536), + (537 , happyReduce_537), + (538 , happyReduce_538), + (539 , happyReduce_539), + (540 , happyReduce_540), + (541 , happyReduce_541), + (542 , happyReduce_542), + (543 , happyReduce_543), + (544 , happyReduce_544), + (545 , happyReduce_545), + (546 , happyReduce_546), + (547 , happyReduce_547), + (548 , happyReduce_548), + (549 , happyReduce_549), + (550 , happyReduce_550), + (551 , happyReduce_551), + (552 , happyReduce_552), + (553 , happyReduce_553), + (554 , happyReduce_554), + (555 , happyReduce_555), + (556 , happyReduce_556), + (557 , happyReduce_557), + (558 , happyReduce_558), + (559 , happyReduce_559), + (560 , happyReduce_560), + (561 , happyReduce_561), + (562 , happyReduce_562), + (563 , happyReduce_563), + (564 , happyReduce_564), + (565 , happyReduce_565), + (566 , happyReduce_566), + (567 , happyReduce_567), + (568 , happyReduce_568), + (569 , happyReduce_569), + (570 , happyReduce_570), + (571 , happyReduce_571), + (572 , happyReduce_572), + (573 , happyReduce_573), + (574 , happyReduce_574), + (575 , happyReduce_575), + (576 , happyReduce_576), + (577 , happyReduce_577), + (578 , happyReduce_578), + (579 , happyReduce_579), + (580 , happyReduce_580), + (581 , happyReduce_581), + (582 , happyReduce_582), + (583 , happyReduce_583), + (584 , happyReduce_584), + (585 , happyReduce_585), + (586 , happyReduce_586), + (587 , happyReduce_587), + (588 , happyReduce_588), + (589 , happyReduce_589), + (590 , happyReduce_590), + (591 , happyReduce_591), + (592 , happyReduce_592), + (593 , happyReduce_593), + (594 , happyReduce_594), + (595 , happyReduce_595), + (596 , happyReduce_596), + (597 , happyReduce_597), + (598 , happyReduce_598), + (599 , happyReduce_599), + (600 , happyReduce_600), + (601 , happyReduce_601), + (602 , happyReduce_602), + (603 , happyReduce_603), + (604 , happyReduce_604), + (605 , happyReduce_605), + (606 , happyReduce_606), + (607 , happyReduce_607), + (608 , happyReduce_608), + (609 , happyReduce_609), + (610 , happyReduce_610), + (611 , happyReduce_611), + (612 , happyReduce_612), + (613 , happyReduce_613), + (614 , happyReduce_614), + (615 , happyReduce_615), + (616 , happyReduce_616), + (617 , happyReduce_617), + (618 , happyReduce_618), + (619 , happyReduce_619), + (620 , happyReduce_620), + (621 , happyReduce_621), + (622 , happyReduce_622), + (623 , happyReduce_623), + (624 , happyReduce_624), + (625 , happyReduce_625), + (626 , happyReduce_626), + (627 , happyReduce_627), + (628 , happyReduce_628), + (629 , happyReduce_629), + (630 , happyReduce_630), + (631 , happyReduce_631), + (632 , happyReduce_632), + (633 , happyReduce_633), + (634 , happyReduce_634), + (635 , happyReduce_635), + (636 , happyReduce_636), + (637 , happyReduce_637), + (638 , happyReduce_638), + (639 , happyReduce_639), + (640 , happyReduce_640), + (641 , happyReduce_641), + (642 , happyReduce_642), + (643 , happyReduce_643), + (644 , happyReduce_644), + (645 , happyReduce_645), + (646 , happyReduce_646), + (647 , happyReduce_647), + (648 , happyReduce_648), + (649 , happyReduce_649), + (650 , happyReduce_650), + (651 , happyReduce_651), + (652 , happyReduce_652), + (653 , happyReduce_653), + (654 , happyReduce_654), + (655 , happyReduce_655), + (656 , happyReduce_656), + (657 , happyReduce_657), + (658 , happyReduce_658), + (659 , happyReduce_659), + (660 , happyReduce_660), + (661 , happyReduce_661), + (662 , happyReduce_662), + (663 , happyReduce_663), + (664 , happyReduce_664), + (665 , happyReduce_665), + (666 , happyReduce_666), + (667 , happyReduce_667), + (668 , happyReduce_668), + (669 , happyReduce_669), + (670 , happyReduce_670), + (671 , happyReduce_671), + (672 , happyReduce_672), + (673 , happyReduce_673), + (674 , happyReduce_674), + (675 , happyReduce_675), + (676 , happyReduce_676), + (677 , happyReduce_677), + (678 , happyReduce_678), + (679 , happyReduce_679), + (680 , happyReduce_680), + (681 , happyReduce_681), + (682 , happyReduce_682), + (683 , happyReduce_683), + (684 , happyReduce_684), + (685 , happyReduce_685), + (686 , happyReduce_686), + (687 , happyReduce_687), + (688 , happyReduce_688), + (689 , happyReduce_689), + (690 , happyReduce_690), + (691 , happyReduce_691), + (692 , happyReduce_692), + (693 , happyReduce_693), + (694 , happyReduce_694), + (695 , happyReduce_695), + (696 , happyReduce_696), + (697 , happyReduce_697), + (698 , happyReduce_698), + (699 , happyReduce_699), + (700 , happyReduce_700), + (701 , happyReduce_701), + (702 , happyReduce_702), + (703 , happyReduce_703), + (704 , happyReduce_704), + (705 , happyReduce_705), + (706 , happyReduce_706), + (707 , happyReduce_707), + (708 , happyReduce_708), + (709 , happyReduce_709), + (710 , happyReduce_710), + (711 , happyReduce_711), + (712 , happyReduce_712), + (713 , happyReduce_713), + (714 , happyReduce_714), + (715 , happyReduce_715), + (716 , happyReduce_716), + (717 , happyReduce_717), + (718 , happyReduce_718), + (719 , happyReduce_719), + (720 , happyReduce_720), + (721 , happyReduce_721), + (722 , happyReduce_722), + (723 , happyReduce_723), + (724 , happyReduce_724), + (725 , happyReduce_725), + (726 , happyReduce_726), + (727 , happyReduce_727), + (728 , happyReduce_728), + (729 , happyReduce_729), + (730 , happyReduce_730), + (731 , happyReduce_731), + (732 , happyReduce_732), + (733 , happyReduce_733), + (734 , happyReduce_734), + (735 , happyReduce_735), + (736 , happyReduce_736), + (737 , happyReduce_737), + (738 , happyReduce_738), + (739 , happyReduce_739), + (740 , happyReduce_740), + (741 , happyReduce_741), + (742 , happyReduce_742), + (743 , happyReduce_743), + (744 , happyReduce_744), + (745 , happyReduce_745), + (746 , happyReduce_746), + (747 , happyReduce_747), + (748 , happyReduce_748), + (749 , happyReduce_749), + (750 , happyReduce_750), + (751 , happyReduce_751), + (752 , happyReduce_752), + (753 , happyReduce_753), + (754 , happyReduce_754), + (755 , happyReduce_755), + (756 , happyReduce_756), + (757 , happyReduce_757), + (758 , happyReduce_758), + (759 , happyReduce_759), + (760 , happyReduce_760), + (761 , happyReduce_761), + (762 , happyReduce_762), + (763 , happyReduce_763), + (764 , happyReduce_764), + (765 , happyReduce_765), + (766 , happyReduce_766), + (767 , happyReduce_767), + (768 , happyReduce_768), + (769 , happyReduce_769), + (770 , happyReduce_770), + (771 , happyReduce_771), + (772 , happyReduce_772), + (773 , happyReduce_773), + (774 , happyReduce_774), + (775 , happyReduce_775), + (776 , happyReduce_776), + (777 , happyReduce_777), + (778 , happyReduce_778), + (779 , happyReduce_779), + (780 , happyReduce_780), + (781 , happyReduce_781), + (782 , happyReduce_782), + (783 , happyReduce_783), + (784 , happyReduce_784), + (785 , happyReduce_785), + (786 , happyReduce_786), + (787 , happyReduce_787), + (788 , happyReduce_788), + (789 , happyReduce_789), + (790 , happyReduce_790), + (791 , happyReduce_791), + (792 , happyReduce_792), + (793 , happyReduce_793), + (794 , happyReduce_794), + (795 , happyReduce_795), + (796 , happyReduce_796), + (797 , happyReduce_797), + (798 , happyReduce_798), + (799 , happyReduce_799), + (800 , happyReduce_800), + (801 , happyReduce_801), + (802 , happyReduce_802), + (803 , happyReduce_803), + (804 , happyReduce_804), + (805 , happyReduce_805), + (806 , happyReduce_806), + (807 , happyReduce_807), + (808 , happyReduce_808), + (809 , happyReduce_809), + (810 , happyReduce_810), + (811 , happyReduce_811), + (812 , happyReduce_812), + (813 , happyReduce_813), + (814 , happyReduce_814), + (815 , happyReduce_815), + (816 , happyReduce_816), + (817 , happyReduce_817), + (818 , happyReduce_818), + (819 , happyReduce_819), + (820 , happyReduce_820), + (821 , happyReduce_821), + (822 , happyReduce_822), + (823 , happyReduce_823), + (824 , happyReduce_824), + (825 , happyReduce_825), + (826 , happyReduce_826), + (827 , happyReduce_827), + (828 , happyReduce_828), + (829 , happyReduce_829), + (830 , happyReduce_830), + (831 , happyReduce_831), + (832 , happyReduce_832), + (833 , happyReduce_833), + (834 , happyReduce_834), + (835 , happyReduce_835), + (836 , happyReduce_836), + (837 , happyReduce_837), + (838 , happyReduce_838), + (839 , happyReduce_839), + (840 , happyReduce_840), + (841 , happyReduce_841), + (842 , happyReduce_842), + (843 , happyReduce_843), + (844 , happyReduce_844), + (845 , happyReduce_845), + (846 , happyReduce_846), + (847 , happyReduce_847), + (848 , happyReduce_848), + (849 , happyReduce_849), + (850 , happyReduce_850), + (851 , happyReduce_851), + (852 , happyReduce_852), + (853 , happyReduce_853), + (854 , happyReduce_854), + (855 , happyReduce_855), + (856 , happyReduce_856), + (857 , happyReduce_857), + (858 , happyReduce_858), + (859 , happyReduce_859), + (860 , happyReduce_860), + (861 , happyReduce_861), + (862 , happyReduce_862), + (863 , happyReduce_863), + (864 , happyReduce_864), + (865 , happyReduce_865), + (866 , happyReduce_866), + (867 , happyReduce_867), + (868 , happyReduce_868), + (869 , happyReduce_869), + (870 , happyReduce_870), + (871 , happyReduce_871), + (872 , happyReduce_872), + (873 , happyReduce_873), + (874 , happyReduce_874), + (875 , happyReduce_875), + (876 , happyReduce_876), + (877 , happyReduce_877), + (878 , happyReduce_878), + (879 , happyReduce_879), + (880 , happyReduce_880), + (881 , happyReduce_881), + (882 , happyReduce_882), + (883 , happyReduce_883), + (884 , happyReduce_884), + (885 , happyReduce_885), + (886 , happyReduce_886), + (887 , happyReduce_887), + (888 , happyReduce_888), + (889 , happyReduce_889), + (890 , happyReduce_890), + (891 , happyReduce_891), + (892 , happyReduce_892), + (893 , happyReduce_893), + (894 , happyReduce_894), + (895 , happyReduce_895), + (896 , happyReduce_896), + (897 , happyReduce_897), + (898 , happyReduce_898), + (899 , happyReduce_899), + (900 , happyReduce_900), + (901 , happyReduce_901), + (902 , happyReduce_902), + (903 , happyReduce_903), + (904 , happyReduce_904), + (905 , happyReduce_905), + (906 , happyReduce_906) + ] + +happy_n_terms = 162 :: Prelude.Int +happy_n_nonterms = 337 :: Prelude.Int + +happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_13 = happySpecReduce_1 0# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_14 = happySpecReduce_1 0# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_15 = happySpecReduce_1 0# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_16 = happySpecReduce_1 0# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> + happyIn16 + (happy_var_1 + )} + +happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_17 = happyMonadReduce 1# 0# happyReduction_17 +happyReduction_17 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsr (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow Nothing (epUniTok happy_var_1) Nothing []))}) + ) (\r -> happyReturn (happyIn16 r)) + +happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_18 = happySpecReduce_3 1# happyReduction_18 +happyReduction_18 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> + happyIn17 + (fromOL happy_var_2 + )} + +happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_19 = happySpecReduce_3 1# happyReduction_19 +happyReduction_19 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_2 of { (HappyWrap18 happy_var_2) -> + happyIn17 + (fromOL happy_var_2 + )} + +happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_20 = happySpecReduce_3 2# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> + happyIn18 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_21 = happySpecReduce_2 2# happyReduction_21 +happyReduction_21 happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> + happyIn18 + (happy_var_1 + )} + +happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_22 = happySpecReduce_1 2# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOut19 happy_x_1 of { (HappyWrap19 happy_var_1) -> + happyIn18 + (unitOL happy_var_1 + )} + +happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_23 = happyReduce 4# 3# happyReduction_23 +happyReduction_23 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_2 of { (HappyWrap24 happy_var_2) -> + case happyOut31 happy_x_4 of { (HappyWrap31 happy_var_4) -> + happyIn19 + (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2 + , hsunitBody = fromOL happy_var_4 } + ) `HappyStk` happyRest}}} + +happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_24 = happySpecReduce_1 4# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> + happyIn20 + (sL1 happy_var_1 $ HsUnitId happy_var_1 [] + )} + +happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_25 = happyReduce 4# 4# happyReduction_25 +happyReduction_25 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut24 happy_x_1 of { (HappyWrap24 happy_var_1) -> + case happyOut21 happy_x_3 of { (HappyWrap21 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn20 + (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3) + ) `HappyStk` happyRest}}} + +happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_26 = happySpecReduce_3 5# happyReduction_26 +happyReduction_26 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> + case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> + happyIn21 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_27 = happySpecReduce_2 5# happyReduction_27 +happyReduction_27 happy_x_2 + happy_x_1 + = case happyOut21 happy_x_1 of { (HappyWrap21 happy_var_1) -> + happyIn21 + (happy_var_1 + )} + +happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_28 = happySpecReduce_1 5# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> + happyIn21 + (unitOL happy_var_1 + )} + +happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_29 = happySpecReduce_3 6# happyReduction_29 +happyReduction_29 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> + happyIn22 + (sLL happy_var_1 happy_var_3 $ (reLoc happy_var_1, happy_var_3) + )}} + +happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_30 = happyReduce 4# 6# happyReduction_30 +happyReduction_30 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn22 + (sLL happy_var_1 happy_var_4 $ (reLoc happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar (reLoc happy_var_3)) + ) `HappyStk` happyRest}}}} + +happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_31 = happySpecReduce_3 7# happyReduction_31 +happyReduction_31 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn23 + (sLL happy_var_1 happy_var_3 $ HsModuleVar (reLoc happy_var_2) + )}}} + +happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_32 = happySpecReduce_3 7# happyReduction_32 +happyReduction_32 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + happyIn23 + (sLL happy_var_1 happy_var_3 $ HsModuleId happy_var_1 (reLoc happy_var_3) + )}} + +happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_33 = happySpecReduce_1 8# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn24 + (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1) + )} + +happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_34 = happySpecReduce_1 8# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> + happyIn24 + (sL1 happy_var_1 $ PackageName (unLoc happy_var_1) + )} + +happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_35 = happySpecReduce_1 9# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn25 + (sL1 happy_var_1 $ getVARID happy_var_1 + )} + +happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_36 = happySpecReduce_1 9# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn25 + (sL1 happy_var_1 $ getCONID happy_var_1 + )} + +happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_37 = happySpecReduce_1 9# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> + happyIn25 + (happy_var_1 + )} + +happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_38 = happySpecReduce_1 10# happyReduction_38 +happyReduction_38 happy_x_1 + = happyIn26 + (() + ) + +happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_39 = happySpecReduce_1 10# happyReduction_39 +happyReduction_39 happy_x_1 + = happyIn26 + (() + ) + +happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_40 = happySpecReduce_1 10# happyReduction_40 +happyReduction_40 happy_x_1 + = happyIn26 + (() + ) + +happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_41 = happySpecReduce_1 11# happyReduction_41 +happyReduction_41 happy_x_1 + = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> + happyIn27 + (happy_var_1 + )} + +happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_42 = happySpecReduce_3 11# happyReduction_42 +happyReduction_42 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> + case happyOut27 happy_x_3 of { (HappyWrap27 happy_var_3) -> + happyIn27 + (sLL happy_var_1 happy_var_3 $ concatFS [unLoc happy_var_1, fsLit "-", (unLoc happy_var_3)] + )}} + +happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_43 = happySpecReduce_0 12# happyReduction_43 +happyReduction_43 = happyIn28 + (Nothing + ) + +happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_44 = happySpecReduce_3 12# happyReduction_44 +happyReduction_44 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_2 of { (HappyWrap29 happy_var_2) -> + happyIn28 + (Just (fromOL happy_var_2) + )} + +happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_45 = happySpecReduce_3 13# happyReduction_45 +happyReduction_45 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> + case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> + happyIn29 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_46 = happySpecReduce_2 13# happyReduction_46 +happyReduction_46 happy_x_2 + happy_x_1 + = case happyOut29 happy_x_1 of { (HappyWrap29 happy_var_1) -> + happyIn29 + (happy_var_1 + )} + +happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_47 = happySpecReduce_1 13# happyReduction_47 +happyReduction_47 happy_x_1 + = case happyOut30 happy_x_1 of { (HappyWrap30 happy_var_1) -> + happyIn29 + (unitOL happy_var_1 + )} + +happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_48 = happySpecReduce_3 14# happyReduction_48 +happyReduction_48 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + happyIn30 + (sLL happy_var_1 happy_var_3 $ Renaming (reLoc happy_var_1) (Just (reLoc happy_var_3)) + )}} + +happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_49 = happySpecReduce_1 14# happyReduction_49 +happyReduction_49 happy_x_1 + = case happyOut334 happy_x_1 of { (HappyWrap334 happy_var_1) -> + happyIn30 + (sL1 happy_var_1 $ Renaming (reLoc happy_var_1) Nothing + )} + +happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_50 = happySpecReduce_3 15# happyReduction_50 +happyReduction_50 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> + happyIn31 + (happy_var_2 + )} + +happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_51 = happySpecReduce_3 15# happyReduction_51 +happyReduction_51 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> + happyIn31 + (happy_var_2 + )} + +happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_52 = happySpecReduce_3 16# happyReduction_52 +happyReduction_52 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> + case happyOut33 happy_x_3 of { (HappyWrap33 happy_var_3) -> + happyIn32 + (happy_var_1 `appOL` unitOL happy_var_3 + )}} + +happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_53 = happySpecReduce_2 16# happyReduction_53 +happyReduction_53 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> + happyIn32 + (happy_var_1 + )} + +happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_54 = happySpecReduce_1 16# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> + happyIn32 + (unitOL happy_var_1 + )} + +happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_55 = happyReduce 7# 17# happyReduction_55 +happyReduction_55 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + case happyOut146 happy_x_4 of { (HappyWrap146 happy_var_4) -> + case happyOut47 happy_x_5 of { (HappyWrap47 happy_var_5) -> + case happyOut38 happy_x_7 of { (HappyWrap38 happy_var_7) -> + happyIn33 + (sL1 happy_var_1 $ DeclD + (case snd happy_var_2 of + NotBoot -> HsSrcFile + IsBoot -> HsBootFile) + (reLoc happy_var_3) + (sL1 happy_var_1 (HsModule (XModulePs noAnn (thdOf3 happy_var_7) happy_var_4 Nothing) (Just happy_var_3) happy_var_5 (fst $ sndOf3 happy_var_7) (snd $ sndOf3 happy_var_7))) + ) `HappyStk` happyRest}}}}}} + +happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_56 = happyReduce 6# 17# happyReduction_56 +happyReduction_56 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> + happyIn33 + (sL1 happy_var_1 $ DeclD + HsigFile + (reLoc happy_var_2) + (sL1 happy_var_1 (HsModule (XModulePs noAnn (thdOf3 happy_var_6) happy_var_3 Nothing) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) (snd $ sndOf3 happy_var_6))) + ) `HappyStk` happyRest}}}}} + +happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_57 = happySpecReduce_3 17# happyReduction_57 +happyReduction_57 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_2 of { (HappyWrap20 happy_var_2) -> + case happyOut28 happy_x_3 of { (HappyWrap28 happy_var_3) -> + happyIn33 + (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2 + , idModRenaming = happy_var_3 + , idSignatureInclude = False }) + )}}} + +happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_58 = happySpecReduce_3 17# happyReduction_58 +happyReduction_58 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_3 of { (HappyWrap20 happy_var_3) -> + happyIn33 + (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3 + , idModRenaming = Nothing + , idSignatureInclude = True }) + )}} + +happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_59 = happyMonadReduce 6# 18# happyReduction_59 +happyReduction_59 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acs loc (\loc cs-> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule (epTok happy_var_1) NoEpTok (epTok happy_var_5) (fstOf3 happy_var_6) [] Nothing) cs) + (thdOf3 happy_var_6) happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) + (snd $ sndOf3 happy_var_6))) + ))}}}}}}) + ) (\r -> happyReturn (happyIn34 r)) + +happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_60 = happyMonadReduce 6# 19# happyReduction_60 +happyReduction_60 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acsFinal (\cs eof -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok happy_var_1) (epTok happy_var_5) (fstOf3 happy_var_6) [] eof) cs) + (thdOf3 happy_var_6) happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) + (snd $ sndOf3 happy_var_6)) + )))}}}}}}) + ) (\r -> happyReturn (happyIn35 r)) + +happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_61 = happyMonadReduce 1# 19# happyReduction_61 +happyReduction_61 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> + ( fileSrcSpan >>= \ loc -> + acsFinal (\cs eof -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok NoEpTok NoEpTok (fstOf3 happy_var_1) [] eof) cs) + (thdOf3 happy_var_1) Nothing Nothing) + Nothing Nothing + (fst $ sndOf3 happy_var_1) (snd $ sndOf3 happy_var_1)))))}) + ) (\r -> happyReturn (happyIn35 r)) + +happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_62 = happyMonadReduce 0# 20# happyReduction_62 +happyReduction_62 (happyRest) tk + = happyThen ((( pushModuleContext)) + ) (\r -> happyReturn (happyIn36 r)) + +happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_63 = happyMonadReduce 0# 21# happyReduction_63 +happyReduction_63 (happyRest) tk + = happyThen ((( pushModuleContext)) + ) (\r -> happyReturn (happyIn37 r)) + +happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_64 = happySpecReduce_3 22# happyReduction_64 +happyReduction_64 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn38 + ((fst happy_var_2, snd happy_var_2, epExplicitBraces happy_var_1 happy_var_3) + )}}} + +happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_65 = happySpecReduce_3 22# happyReduction_65 +happyReduction_65 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + happyIn38 + ((fst happy_var_2, snd happy_var_2, EpVirtualBraces (getVOCURLY happy_var_1)) + )}} + +happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_66 = happySpecReduce_3 23# happyReduction_66 +happyReduction_66 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn39 + ((fst happy_var_2, snd happy_var_2, epExplicitBraces happy_var_1 happy_var_3) + )}}} + +happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_67 = happySpecReduce_3 23# happyReduction_67 +happyReduction_67 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> + happyIn39 + (([], snd happy_var_2, EpVirtualBraces leftmostColumn) + )} + +happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_68 = happySpecReduce_2 24# happyReduction_68 +happyReduction_68 happy_x_2 + happy_x_1 + = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> + case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> + happyIn40 + ((reverse happy_var_1, happy_var_2) + )}} + +happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_69 = happySpecReduce_2 25# happyReduction_69 +happyReduction_69 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut80 happy_x_2 of { (HappyWrap80 happy_var_2) -> + happyIn41 + ((reverse happy_var_1, cvTopDecls happy_var_2) + )}} + +happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_70 = happySpecReduce_2 25# happyReduction_70 +happyReduction_70 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut79 happy_x_2 of { (HappyWrap79 happy_var_2) -> + happyIn41 + ((reverse happy_var_1, cvTopDecls happy_var_2) + )}} + +happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_71 = happySpecReduce_1 25# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> + happyIn41 + ((reverse happy_var_1, []) + )} + +happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_72 = happyMonadReduce 6# 26# happyReduction_72 +happyReduction_72 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut43 happy_x_6 of { (HappyWrap43 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acs loc (\loc cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok happy_var_1) (epTok happy_var_5) [] [] Nothing) cs) + EpNoLayout happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 happy_var_6 [] + ))))}}}}}}) + ) (\r -> happyReturn (happyIn42 r)) + +happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_73 = happyMonadReduce 6# 26# happyReduction_73 +happyReduction_73 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + case happyOut146 happy_x_3 of { (HappyWrap146 happy_var_3) -> + case happyOut47 happy_x_4 of { (HappyWrap47 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut43 happy_x_6 of { (HappyWrap43 happy_var_6) -> + ( fileSrcSpan >>= \ loc -> + acs loc (\loc cs -> (L loc (HsModule (XModulePs + (EpAnn (spanAsAnchor loc) (AnnsModule NoEpTok (epTok happy_var_1) (epTok happy_var_5) [] [] Nothing) cs) + EpNoLayout happy_var_3 Nothing) + (Just happy_var_2) happy_var_4 happy_var_6 [] + ))))}}}}}}) + ) (\r -> happyReturn (happyIn42 r)) + +happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_74 = happyMonadReduce 1# 26# happyReduction_74 +happyReduction_74 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> + ( fileSrcSpan >>= \ loc -> + return (L loc (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing happy_var_1 [])))}) + ) (\r -> happyReturn (happyIn42 r)) + +happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_75 = happySpecReduce_2 27# happyReduction_75 +happyReduction_75 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn43 + (happy_var_2 + )} + +happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_76 = happySpecReduce_2 27# happyReduction_76 +happyReduction_76 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn43 + (happy_var_2 + )} + +happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_77 = happySpecReduce_2 28# happyReduction_77 +happyReduction_77 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn44 + (happy_var_2 + )} + +happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_78 = happySpecReduce_2 28# happyReduction_78 +happyReduction_78 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_2 of { (HappyWrap45 happy_var_2) -> + happyIn44 + (happy_var_2 + )} + +happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_79 = happySpecReduce_2 29# happyReduction_79 +happyReduction_79 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_2 of { (HappyWrap46 happy_var_2) -> + happyIn45 + (happy_var_2 + )} + +happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_80 = happySpecReduce_1 30# happyReduction_80 +happyReduction_80 happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + happyIn46 + (happy_var_1 + )} + +happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_81 = happySpecReduce_1 30# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOut60 happy_x_1 of { (HappyWrap60 happy_var_1) -> + happyIn46 + (happy_var_1 + )} + +happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_82 = happyMonadReduce 3# 31# happyReduction_82 +happyReduction_82 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_2 of { (HappyWrap48 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_3 (fromOL $ snd happy_var_2)) + (AnnList Nothing (ListParens (epTok happy_var_1) (epTok happy_var_3)) [] (noAnn,fst happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn47 r)) + +happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_83 = happySpecReduce_0 31# happyReduction_83 +happyReduction_83 = happyIn47 + (Nothing + ) + +happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_84 = happySpecReduce_1 32# happyReduction_84 +happyReduction_84 happy_x_1 + = case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> + happyIn48 + (([], happy_var_1) + )} + +happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_85 = happySpecReduce_0 32# happyReduction_85 +happyReduction_85 = happyIn48 + (([], nilOL) + ) + +happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_86 = happyMonadReduce 2# 32# happyReduction_86 +happyReduction_86 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return ([], snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn48 r)) + +happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_87 = happySpecReduce_1 32# happyReduction_87 +happyReduction_87 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn48 + (([epTok happy_var_1], nilOL) + )} + +happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_88 = happyMonadReduce 3# 33# happyReduction_88 +happyReduction_88 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut49 happy_x_1 of { (HappyWrap49 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut50 happy_x_3 of { (HappyWrap50 happy_var_3) -> + ( let ls = happy_var_1 + in if isNilOL ls + then return (ls `appOL` happy_var_3) + else case ls of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn49 r)) + +happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_89 = happySpecReduce_1 33# happyReduction_89 +happyReduction_89 happy_x_1 + = case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> + happyIn49 + (happy_var_1 + )} + +happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_90 = happyMonadReduce 1# 34# happyReduction_90 +happyReduction_90 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> + ( return (unitOL happy_var_1))}) + ) (\r -> happyReturn (happyIn50 r)) + +happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_91 = happyMonadReduce 3# 35# happyReduction_91 +happyReduction_91 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOut56 happy_x_2 of { (HappyWrap56 happy_var_2) -> + case happyOut52 happy_x_3 of { (HappyWrap52 happy_var_3) -> + ( do { let { span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 } + ; impExp <- mkModuleImpExp happy_var_1 (fst $ unLoc happy_var_3) happy_var_2 (snd $ unLoc happy_var_3) + ; return $ reLoc $ sL span $ impExp })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_92 = happyMonadReduce 3# 35# happyReduction_92 +happyReduction_92 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut334 happy_x_3 of { (HappyWrap334 happy_var_3) -> + ( do { let { span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 + ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) happy_var_1) happy_var_2 } + ; locImpExp <- return (sL span (IEModuleContents (happy_var_1, (epTok happy_var_2)) happy_var_3)) + ; return $ reLoc $ locImpExp })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_93 = happyMonadReduce 3# 35# happyReduction_93 +happyReduction_93 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut286 happy_x_3 of { (HappyWrap286 happy_var_3) -> + ( do { warnPatternNamespaceSpecifier (getLoc happy_var_2) + ; let span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 + ; return $ reLoc $ sL span $ IEVar happy_var_1 (sLLa happy_var_2 happy_var_3 (IEPattern (epTok happy_var_2) happy_var_3)) Nothing })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_94 = happyMonadReduce 3# 35# happyReduction_94 +happyReduction_94 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> + ( do { let { span = (maybe comb2 comb3 happy_var_1) happy_var_2 happy_var_3 } + ; locImpExp <- return (sL span (IEThingAbs happy_var_1 (sLLa happy_var_2 happy_var_3 (IEDefault (epTok happy_var_2) happy_var_3)) Nothing)) + ; return $ reLoc $ locImpExp })}}}) + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_95 = happySpecReduce_0 36# happyReduction_95 +happyReduction_95 = happyIn52 + (sL0 (noAnn,ImpExpAbs) + ) + +happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_96 = happyMonadReduce 3# 36# happyReduction_96 +happyReduction_96 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { (HappyWrap53 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( mkImpExpSubSpec (reverse happy_var_2) + >>= \ie -> return $ sLL happy_var_1 happy_var_3 + ((epTok happy_var_1, epTok happy_var_3), ie))}}}) + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_97 = happySpecReduce_0 37# happyReduction_97 +happyReduction_97 = happyIn53 + ([] + ) + +happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_98 = happySpecReduce_1 37# happyReduction_98 +happyReduction_98 happy_x_1 + = case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> + happyIn53 + (happy_var_1 + )} + +happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_99 = happyMonadReduce 3# 38# happyReduction_99 +happyReduction_99 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> + ( case happy_var_1 of + ((L la (ImpExpQcWildcard tok _)):t) -> + do { return (happy_var_3 : L la (ImpExpQcWildcard tok (epTok happy_var_2)) : t) } + (l:t) -> + do { l' <- addTrailingCommaA l (epTok happy_var_2) + ; return (happy_var_3 : l' : t)})}}}) + ) (\r -> happyReturn (happyIn54 r)) + +happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_100 = happySpecReduce_1 38# happyReduction_100 +happyReduction_100 happy_x_1 + = case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> + happyIn54 + ([happy_var_1] + )} + +happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_101 = happySpecReduce_1 39# happyReduction_101 +happyReduction_101 happy_x_1 + = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + happyIn55 + (happy_var_1 + )} + +happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_102 = happySpecReduce_1 39# happyReduction_102 +happyReduction_102 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn55 + (sL1a happy_var_1 (ImpExpQcWildcard (epTok happy_var_1) NoEpTok) + )} + +happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_103 = happySpecReduce_1 40# happyReduction_103 +happyReduction_103 happy_x_1 + = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> + happyIn56 + (sL1a happy_var_1 (mkPlainImpExp happy_var_1) + )} + +happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_104 = happyMonadReduce 2# 40# happyReduction_104 +happyReduction_104 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> + ( do { imp_exp <- mkTypeImpExp (epTok happy_var_1) happy_var_2 + ; return $ sLLa happy_var_1 happy_var_2 imp_exp })}}) + ) (\r -> happyReturn (happyIn56 r)) + +happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_105 = happyMonadReduce 2# 40# happyReduction_105 +happyReduction_105 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> + ( do { imp_exp <- mkDataImpExp (epTok happy_var_1) happy_var_2 + ; return $ sLLa happy_var_1 happy_var_2 imp_exp })}}) + ) (\r -> happyReturn (happyIn56 r)) + +happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_106 = happySpecReduce_1 41# happyReduction_106 +happyReduction_106 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn57 + (happy_var_1 + )} + +happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_107 = happySpecReduce_1 41# happyReduction_107 +happyReduction_107 happy_x_1 + = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> + happyIn57 + (happy_var_1 + )} + +happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_108 = happySpecReduce_2 42# happyReduction_108 +happyReduction_108 happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn58 + (if isZeroWidthSpan (gl happy_var_2) then (sL1 happy_var_1 $ unLoc happy_var_1) else (sLL happy_var_1 happy_var_2 $ AddSemiAnn (epTok happy_var_2) : (unLoc happy_var_1)) + )}} + +happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_109 = happySpecReduce_1 42# happyReduction_109 +happyReduction_109 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn58 + (case msemi happy_var_1 of + [] -> noLoc [] + ms -> sL1 happy_var_1 $ ms + )} + +happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_110 = happySpecReduce_2 43# happyReduction_110 +happyReduction_110 happy_x_2 + happy_x_1 + = case happyOut59 happy_x_1 of { (HappyWrap59 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn59 + (if isZeroWidthSpan (gl happy_var_2) then happy_var_1 else (AddSemiAnn (epTok happy_var_2) : happy_var_1) + )}} + +happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_111 = happySpecReduce_0 43# happyReduction_111 +happyReduction_111 = happyIn59 + ([] + ) + +happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_112 = happySpecReduce_2 44# happyReduction_112 +happyReduction_112 happy_x_2 + happy_x_1 + = case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> + happyIn60 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_113 = happyMonadReduce 3# 45# happyReduction_113 +happyReduction_113 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> + case happyOut62 happy_x_2 of { (HappyWrap62 happy_var_2) -> + case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> + ( do { i <- amsAl happy_var_2 (comb2 happy_var_2 happy_var_3) (reverse $ unLoc happy_var_3) + ; return (i : happy_var_1)})}}}) + ) (\r -> happyReturn (happyIn61 r)) + +happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_114 = happySpecReduce_0 45# happyReduction_114 +happyReduction_114 = happyIn61 + ([] + ) + +happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_115 = happyMonadReduce 11# 46# happyReduction_115 +happyReduction_115 (happy_x_11 `HappyStk` + happy_x_10 `HappyStk` + happy_x_9 `HappyStk` + happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> + case happyOut65 happy_x_3 of { (HappyWrap65 happy_var_3) -> + case happyOut64 happy_x_4 of { (HappyWrap64 happy_var_4) -> + case happyOut67 happy_x_5 of { (HappyWrap67 happy_var_5) -> + case happyOut66 happy_x_6 of { (HappyWrap66 happy_var_6) -> + case happyOut334 happy_x_7 of { (HappyWrap334 happy_var_7) -> + case happyOut65 happy_x_8 of { (HappyWrap65 happy_var_8) -> + case happyOut67 happy_x_9 of { (HappyWrap67 happy_var_9) -> + case happyOut68 happy_x_10 of { (HappyWrap68 happy_var_10) -> + case happyOut69 happy_x_11 of { (HappyWrap69 happy_var_11) -> + ( do { + ; let { ; mPreQual = happy_var_5 + ; mPostQual = happy_var_9 + ; mPreLevel = happy_var_3 + ; mPostLevel = happy_var_8 } + ; (qualSpec, levelSpec) <- checkImportDecl mPreQual mPostQual mPreLevel mPostLevel + ; let anns + = EpAnnImportDecl + { importDeclAnnImport = epTok happy_var_1 + , importDeclAnnPragma = fst $ fst happy_var_2 + , importDeclAnnLevel = fst $ levelSpec + , importDeclAnnSafe = fst happy_var_4 + , importDeclAnnQualified = fst $ qualSpec + , importDeclAnnPackage = fst happy_var_6 + , importDeclAnnAs = fst happy_var_10 + } + ; let loc = (comb6 happy_var_1 happy_var_7 happy_var_8 happy_var_9 (snd happy_var_10) happy_var_11); + ; fmap reLoc $ acs loc (\loc cs -> L loc $ + ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst happy_var_2) False + , ideclName = happy_var_7, ideclPkgQual = snd happy_var_6 + , ideclSource = snd happy_var_2 + , ideclLevelSpec = snd $ levelSpec + , ideclSafe = snd happy_var_4 + , ideclQualified = snd $ qualSpec + , ideclAs = unLoc (snd happy_var_10) + , ideclImportList = unLoc happy_var_11 }) + })}}}}}}}}}}}) + ) (\r -> happyReturn (happyIn62 r)) + +happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_116 = happySpecReduce_2 47# happyReduction_116 +happyReduction_116 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn63 + (((Just (glR happy_var_1,epTok happy_var_2),getSOURCE_PRAGs happy_var_1) + , IsBoot) + )}} + +happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_117 = happySpecReduce_0 47# happyReduction_117 +happyReduction_117 = happyIn63 + (((Nothing,NoSourceText),NotBoot) + ) + +happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_118 = happySpecReduce_1 48# happyReduction_118 +happyReduction_118 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn64 + ((Just (epTok happy_var_1),True) + )} + +happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_119 = happySpecReduce_0 48# happyReduction_119 +happyReduction_119 = happyIn64 + ((Nothing, False) + ) + +happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_120 = happySpecReduce_1 49# happyReduction_120 +happyReduction_120 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn65 + ((Just (EpAnnLevelSplice (epTok happy_var_1))) + )} + +happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_121 = happySpecReduce_1 49# happyReduction_121 +happyReduction_121 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn65 + ((Just (EpAnnLevelQuote (epTok happy_var_1))) + )} + +happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_122 = happySpecReduce_0 49# happyReduction_122 +happyReduction_122 = happyIn65 + ((Nothing) + ) + +happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_123 = happyMonadReduce 1# 50# happyReduction_123 +happyReduction_123 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( do { let { pkgFS = getSTRING happy_var_1 } + ; unless (looksLikePackageName (unpackFS pkgFS)) $ + addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ + (PsErrInvalidPackageName pkgFS) + ; return (Just (glR happy_var_1), RawPkgQual (StringLiteral (getSTRINGs happy_var_1) pkgFS Nothing)) })}) + ) (\r -> happyReturn (happyIn66 r)) + +happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_124 = happySpecReduce_0 50# happyReduction_124 +happyReduction_124 = happyIn66 + ((Nothing,NoRawPkgQual) + ) + +happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_125 = happySpecReduce_1 51# happyReduction_125 +happyReduction_125 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn67 + (Just (epTok happy_var_1) + )} + +happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_126 = happySpecReduce_0 51# happyReduction_126 +happyReduction_126 = happyIn67 + (Nothing + ) + +happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_127 = happySpecReduce_2 52# happyReduction_127 +happyReduction_127 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + happyIn68 + ((Just (epTok happy_var_1) + ,sLL happy_var_1 happy_var_2 (Just happy_var_2)) + )}} + +happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_128 = happySpecReduce_0 52# happyReduction_128 +happyReduction_128 = happyIn68 + ((Nothing,noLoc Nothing) + ) + +happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_129 = happyMonadReduce 1# 53# happyReduction_129 +happyReduction_129 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut70 happy_x_1 of { (HappyWrap70 happy_var_1) -> + ( let (b, ie) = unLoc happy_var_1 in + checkImportSpec ie + >>= \checkedIe -> + return (L (gl happy_var_1) (Just (b, checkedIe))))}) + ) (\r -> happyReturn (happyIn69 r)) + +happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_130 = happySpecReduce_0 53# happyReduction_130 +happyReduction_130 = happyIn69 + (noLoc Nothing + ) + +happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_131 = happyMonadReduce 3# 54# happyReduction_131 +happyReduction_131 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut71 happy_x_2 of { (HappyWrap71 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { es <- amsr (sLL happy_var_1 happy_var_3 $ fromOL $ snd happy_var_2) + (AnnList Nothing (ListParens (epTok happy_var_1) (epTok happy_var_3)) [] (noAnn,fst happy_var_2) []) + ; return $ sLL happy_var_1 happy_var_3 (Exactly, es)})}}}) + ) (\r -> happyReturn (happyIn70 r)) + +happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_132 = happyMonadReduce 4# 54# happyReduction_132 +happyReduction_132 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut71 happy_x_3 of { (HappyWrap71 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { es <- amsr (sLL happy_var_1 happy_var_4 $ fromOL $ snd happy_var_3) + (AnnList Nothing (ListParens (epTok happy_var_2) (epTok happy_var_4)) [] (epTok happy_var_1,fst happy_var_3) []) + ; return $ sLL happy_var_1 happy_var_4 (EverythingBut, es)})}}}}) + ) (\r -> happyReturn (happyIn70 r)) + +happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_133 = happySpecReduce_1 55# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> + happyIn71 + (([], happy_var_1) + )} + +happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_134 = happySpecReduce_0 55# happyReduction_134 +happyReduction_134 = happyIn71 + (([], nilOL) + ) + +happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_135 = happyMonadReduce 2# 55# happyReduction_135 +happyReduction_135 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return ([], snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn71 r)) + +happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_136 = happySpecReduce_1 55# happyReduction_136 +happyReduction_136 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn71 + (([epTok happy_var_1], nilOL) + )} + +happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_137 = happyMonadReduce 3# 56# happyReduction_137 +happyReduction_137 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut72 happy_x_1 of { (HappyWrap72 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut73 happy_x_3 of { (HappyWrap73 happy_var_3) -> + ( let ls = happy_var_1 + in if isNilOL ls + then return (ls `appOL` happy_var_3) + else case ls of + SnocOL hs t -> do + t' <- addTrailingCommaA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn72 r)) + +happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_138 = happySpecReduce_1 56# happyReduction_138 +happyReduction_138 happy_x_1 + = case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> + happyIn72 + (happy_var_1 + )} + +happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_139 = happyMonadReduce 2# 57# happyReduction_139 +happyReduction_139 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> + case happyOut52 happy_x_2 of { (HappyWrap52 happy_var_2) -> + ( fmap (unitOL . reLoc . (sLL happy_var_1 happy_var_2)) $ mkModuleImpExp Nothing (fst $ unLoc happy_var_2) happy_var_1 (snd $ unLoc happy_var_2))}}) + ) (\r -> happyReturn (happyIn73 r)) + +happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_140 = happyMonadReduce 2# 57# happyReduction_140 +happyReduction_140 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut334 happy_x_2 of { (HappyWrap334 happy_var_2) -> + ( fmap (unitOL . reLoc) $ return (sLL happy_var_1 happy_var_2 (IEModuleContents (Nothing, (epTok happy_var_1)) happy_var_2)))}}) + ) (\r -> happyReturn (happyIn73 r)) + +happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_141 = happyMonadReduce 2# 57# happyReduction_141 +happyReduction_141 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut286 happy_x_2 of { (HappyWrap286 happy_var_2) -> + ( do { warnPatternNamespaceSpecifier (getLoc happy_var_1) + ; return $ unitOL $ reLoc $ sLL happy_var_1 happy_var_2 $ IEVar Nothing (sLLa happy_var_1 happy_var_2 (IEPattern (epTok happy_var_1) happy_var_2)) Nothing })}}) + ) (\r -> happyReturn (happyIn73 r)) + +happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_142 = happySpecReduce_0 58# happyReduction_142 +happyReduction_142 = happyIn74 + (Nothing + ) + +happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_143 = happySpecReduce_1 58# happyReduction_143 +happyReduction_143 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn74 + (Just (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1)))) + )} + +happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_144 = happySpecReduce_1 59# happyReduction_144 +happyReduction_144 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn75 + (sL1 happy_var_1 InfixN + )} + +happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_145 = happySpecReduce_1 59# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn75 + (sL1 happy_var_1 InfixL + )} + +happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_146 = happySpecReduce_1 59# happyReduction_146 +happyReduction_146 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn75 + (sL1 happy_var_1 InfixR + )} + +happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_147 = happyMonadReduce 3# 60# happyReduction_147 +happyReduction_147 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut306 happy_x_3 of { (HappyWrap306 happy_var_3) -> + ( case (unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingCommaN t (gl happy_var_2) + return (sLL happy_var_1 happy_var_3 (snocOL hs t' `appOL` unitOL happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn76 r)) + +happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_148 = happySpecReduce_1 60# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> + happyIn76 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_149 = happySpecReduce_2 61# happyReduction_149 +happyReduction_149 happy_x_2 + happy_x_1 + = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> + case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> + happyIn77 + (happy_var_1 `snocOL` happy_var_2 + )}} + +happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_150 = happyMonadReduce 3# 62# happyReduction_150 +happyReduction_150 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> + case happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> + case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> + ( do { t <- amsAl happy_var_2 (comb2 happy_var_2 happy_var_3) (reverse $ unLoc happy_var_3) + ; return (happy_var_1 `snocOL` t) })}}}) + ) (\r -> happyReturn (happyIn78 r)) + +happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_151 = happySpecReduce_0 62# happyReduction_151 +happyReduction_151 = happyIn78 + (nilOL + ) + +happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_152 = happySpecReduce_2 63# happyReduction_152 +happyReduction_152 happy_x_2 + happy_x_1 + = case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> + case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> + happyIn79 + (happy_var_1 `snocOL` happy_var_2 + )}} + +happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_153 = happyMonadReduce 3# 64# happyReduction_153 +happyReduction_153 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> + case happyOut81 happy_x_2 of { (HappyWrap81 happy_var_2) -> + case happyOut58 happy_x_3 of { (HappyWrap58 happy_var_3) -> + ( do { t <- amsAl happy_var_2 (comb2 happy_var_2 happy_var_3) (reverse $ unLoc happy_var_3) + ; return (happy_var_1 `snocOL` t) })}}}) + ) (\r -> happyReturn (happyIn80 r)) + +happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_154 = happySpecReduce_0 64# happyReduction_154 +happyReduction_154 = happyIn80 + (nilOL + ) + +happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_155 = happyMonadReduce 1# 65# happyReduction_155 +happyReduction_155 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut82 happy_x_1 of { (HappyWrap82 happy_var_1) -> + ( commentsPA happy_var_1)}) + ) (\r -> happyReturn (happyIn81 r)) + +happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_156 = happySpecReduce_1 66# happyReduction_156 +happyReduction_156 happy_x_1 + = case happyOut83 happy_x_1 of { (HappyWrap83 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (TyClD noExtField (unLoc happy_var_1)) + )} + +happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_157 = happySpecReduce_1 66# happyReduction_157 +happyReduction_157 happy_x_1 + = case happyOut85 happy_x_1 of { (HappyWrap85 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (TyClD noExtField (unLoc happy_var_1)) + )} + +happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_158 = happySpecReduce_1 66# happyReduction_158 +happyReduction_158 happy_x_1 + = case happyOut86 happy_x_1 of { (HappyWrap86 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (KindSigD noExtField (unLoc happy_var_1)) + )} + +happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_159 = happySpecReduce_1 66# happyReduction_159 +happyReduction_159 happy_x_1 + = case happyOut88 happy_x_1 of { (HappyWrap88 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (InstD noExtField (unLoc happy_var_1)) + )} + +happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_160 = happySpecReduce_1 66# happyReduction_160 +happyReduction_160 happy_x_1 + = case happyOut114 happy_x_1 of { (HappyWrap114 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (DerivD noExtField (unLoc happy_var_1)) + )} + +happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_161 = happySpecReduce_1 66# happyReduction_161 +happyReduction_161 happy_x_1 + = case happyOut115 happy_x_1 of { (HappyWrap115 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (RoleAnnotD noExtField (unLoc happy_var_1)) + )} + +happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_162 = happySpecReduce_1 66# happyReduction_162 +happyReduction_162 happy_x_1 + = case happyOut84 happy_x_1 of { (HappyWrap84 happy_var_1) -> + happyIn82 + (L (getLoc happy_var_1) (DefD noExtField (unLoc happy_var_1)) + )} + +happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_163 = happyMonadReduce 2# 66# happyReduction_163 +happyReduction_163 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut156 happy_x_2 of { (HappyWrap156 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 ((unLoc happy_var_2) (epTok happy_var_1))))}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_164 = happyMonadReduce 3# 66# happyReduction_164 +happyReduction_164 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut151 happy_x_2 of { (HappyWrap151 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings ((glR happy_var_1,epTok happy_var_3), (getDEPRECATED_PRAGs happy_var_1)) (fromOL happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_165 = happyMonadReduce 3# 66# happyReduction_165 +happyReduction_165 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut148 happy_x_2 of { (HappyWrap148 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ WarningD noExtField (Warnings ((glR happy_var_1,epTok happy_var_3), (getWARNING_PRAGs happy_var_1)) (fromOL happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_166 = happyMonadReduce 3# 66# happyReduction_166 +happyReduction_166 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ RuleD noExtField (HsRules ((glR happy_var_1,epTok happy_var_3), (getRULES_PRAGs happy_var_1)) (reverse happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_167 = happySpecReduce_1 66# happyReduction_167 +happyReduction_167 happy_x_1 + = case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> + happyIn82 + (happy_var_1 + )} + +happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_168 = happySpecReduce_1 66# happyReduction_168 +happyReduction_168 happy_x_1 + = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> + happyIn82 + (happy_var_1 + )} + +happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_169 = happyMonadReduce 1# 66# happyReduction_169 +happyReduction_169 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + commentsPA $ mkSpliceDecl happy_var_1)}) + ) (\r -> happyReturn (happyIn82 r)) + +happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_170 = happyMonadReduce 4# 67# happyReduction_170 +happyReduction_170 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) -> + case happyOut190 happy_x_3 of { (HappyWrap190 happy_var_3) -> + case happyOut129 happy_x_4 of { (HappyWrap129 happy_var_4) -> + ( do { let {(wtok, (oc,semis,cc)) = fstOf3 $ unLoc happy_var_4} + ; mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (sndOf3 $ unLoc happy_var_4) (thdOf3 $ unLoc happy_var_4) + (AnnClassDecl (epTok happy_var_1) [] [] (fst $ unLoc happy_var_3) wtok oc cc semis) })}}}}) + ) (\r -> happyReturn (happyIn83 r)) + +happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_171 = happyMonadReduce 5# 68# happyReduction_171 +happyReduction_171 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut183 happy_x_4 of { (HappyWrap183 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 (DefaultDecl (epTok happy_var_1,epTok happy_var_3,epTok happy_var_5) happy_var_2 happy_var_4)))}}}}}) + ) (\r -> happyReturn (happyIn84 r)) + +happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_172 = happyMonadReduce 4# 69# happyReduction_172 +happyReduction_172 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut168 happy_x_4 of { (HappyWrap168 happy_var_4) -> + ( mkTySynonym (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4 (epTok happy_var_1) (epTok happy_var_3))}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_173 = happyMonadReduce 6# 69# happyReduction_173 +happyReduction_173 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut109 happy_x_4 of { (HappyWrap109 happy_var_4) -> + case happyOut94 happy_x_5 of { (HappyWrap94 happy_var_5) -> + case happyOut97 happy_x_6 of { (HappyWrap97 happy_var_6) -> + ( do { let { (tdcolon, tequal) = fst $ unLoc happy_var_4 } + ; let { tvbar = fst $ unLoc happy_var_5 } + ; let { (twhere, (toc, tdd, tcc)) = fst $ unLoc happy_var_6 } + ; mkFamDecl (comb5 happy_var_1 happy_var_3 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_6) TopLevel happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) + (AnnFamilyDecl [] [] (epTok happy_var_1) noAnn (epTok happy_var_2) tdcolon tequal tvbar twhere toc tdd tcc) })}}}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_174 = happyMonadReduce 5# 69# happyReduction_174 +happyReduction_174 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut105 happy_x_1 of { (HappyWrap105 happy_var_1) -> + case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> + case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> + case happyOut198 happy_x_4 of { (HappyWrap198 happy_var_4) -> + case happyOut207 happy_x_5 of { (HappyWrap207 happy_var_5) -> + ( do { let { (tdata, tnewtype, ttype) = fstOf3 $ unLoc happy_var_1} + ; let { tequal = fst $ unLoc happy_var_4 } + ; mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (sndOf3 $ unLoc happy_var_1) (thdOf3 $ unLoc happy_var_1) happy_var_2 happy_var_3 + Nothing (reverse (snd $ unLoc happy_var_4)) + (fmap reverse happy_var_5) + (AnnDataDefn [] [] ttype tnewtype tdata NoEpTok NoEpUniTok NoEpTok NoEpTok NoEpTok tequal) + })}}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_175 = happyMonadReduce 6# 69# happyReduction_175 +happyReduction_175 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut105 happy_x_1 of { (HappyWrap105 happy_var_1) -> + case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> + case happyOut111 happy_x_3 of { (HappyWrap111 happy_var_3) -> + case happyOut107 happy_x_4 of { (HappyWrap107 happy_var_4) -> + case happyOut195 happy_x_5 of { (HappyWrap195 happy_var_5) -> + case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> + ( do { let { (tdata, tnewtype, ttype) = fstOf3 $ unLoc happy_var_1} + ; let { tdcolon = fst $ unLoc happy_var_4 } + ; let { (twhere, oc, cc) = fst $ unLoc happy_var_5 } + ; mkTyData (comb5 happy_var_1 happy_var_3 happy_var_4 happy_var_5 happy_var_6) (sndOf3 $ unLoc happy_var_1) (thdOf3 $ unLoc happy_var_1) happy_var_2 happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) + (fmap reverse happy_var_6) + (AnnDataDefn [] [] ttype tnewtype tdata NoEpTok tdcolon twhere oc cc NoEpTok)})}}}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_176 = happyMonadReduce 4# 69# happyReduction_176 +happyReduction_176 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut108 happy_x_4 of { (HappyWrap108 happy_var_4) -> + ( do { let { tdcolon = fst $ unLoc happy_var_4 } + ; mkFamDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) DataFamily TopLevel happy_var_3 + (snd $ unLoc happy_var_4) Nothing + (AnnFamilyDecl [] [] noAnn (epTok happy_var_1) (epTok happy_var_2) tdcolon noAnn noAnn noAnn noAnn noAnn noAnn) })}}}}) + ) (\r -> happyReturn (happyIn85 r)) + +happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_177 = happyMonadReduce 4# 70# happyReduction_177 +happyReduction_177 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut87 happy_x_2 of { (HappyWrap87 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut162 happy_x_4 of { (HappyWrap162 happy_var_4) -> + ( mkStandaloneKindSig (comb2 happy_var_1 happy_var_4) (L (gl happy_var_2) $ unLoc happy_var_2) happy_var_4 + (epTok happy_var_1,epUniTok happy_var_3))}}}}) + ) (\r -> happyReturn (happyIn86 r)) + +happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_178 = happyMonadReduce 3# 71# happyReduction_178 +happyReduction_178 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut87 happy_x_1 of { (HappyWrap87 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> + ( case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingCommaN h (gl happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) + ) (\r -> happyReturn (happyIn87 r)) + +happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_179 = happySpecReduce_1 71# happyReduction_179 +happyReduction_179 happy_x_1 + = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> + happyIn87 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_180 = happyMonadReduce 5# 72# happyReduction_180 +happyReduction_180 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut146 happy_x_2 of { (HappyWrap146 happy_var_2) -> + case happyOut89 happy_x_3 of { (HappyWrap89 happy_var_3) -> + case happyOut181 happy_x_4 of { (HappyWrap181 happy_var_4) -> + case happyOut133 happy_x_5 of { (HappyWrap133 happy_var_5) -> + ( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_5) + ; let (twhere, (openc, closec, semis)) = fst $ unLoc happy_var_5 + ; let anns = AnnClsInstDecl (epTok happy_var_1) twhere openc semis closec + ; let cid = ClsInstDecl + { cid_ext = (happy_var_2, anns, NoAnnSortKey) + , cid_poly_ty = happy_var_4, cid_binds = binds + , cid_sigs = mkClassOpSigs sigs + , cid_tyfam_insts = ats + , cid_overlap_mode = happy_var_3 + , cid_datafam_insts = adts } + ; amsA' (L (comb3 happy_var_1 happy_var_4 happy_var_5) + (ClsInstD { cid_d_ext = noExtField, cid_inst = cid })) + })}}}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_181 = happyMonadReduce 3# 72# happyReduction_181 +happyReduction_181 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( mkTyFamInst (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) + (epTok happy_var_1) (epTok happy_var_2))}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_182 = happyMonadReduce 6# 72# happyReduction_182 +happyReduction_182 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut198 happy_x_5 of { (HappyWrap198 happy_var_5) -> + case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { tequal = fst $ unLoc happy_var_5 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) + Nothing (reverse (snd $ unLoc happy_var_5)) + (fmap reverse happy_var_6) + (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok happy_var_2) NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)})}}}}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_183 = happyMonadReduce 7# 72# happyReduction_183 +happyReduction_183 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut107 happy_x_5 of { (HappyWrap107 happy_var_5) -> + case happyOut195 happy_x_6 of { (HappyWrap195 happy_var_6) -> + case happyOut207 happy_x_7 of { (HappyWrap207 happy_var_7) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { dcolon = fst $ unLoc happy_var_5 } + ; let { (twhere, oc, cc) = fst $ unLoc happy_var_6 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) + (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) + (fmap reverse happy_var_7) + (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok happy_var_2) dcolon twhere oc cc NoEpTok)})}}}}}}}) + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_184 = happyMonadReduce 2# 73# happyReduction_184 +happyReduction_184 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_185 = happyMonadReduce 2# 73# happyReduction_185 +happyReduction_185 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_186 = happyMonadReduce 2# 73# happyReduction_186 +happyReduction_186 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_187 = happyMonadReduce 2# 73# happyReduction_187 +happyReduction_187 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1))) + (AnnPragma (glR happy_var_1) (epTok happy_var_2) noAnn noAnn noAnn noAnn noAnn))}}) + ) (\r -> happyReturn (happyIn89 r)) + +happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_188 = happySpecReduce_0 73# happyReduction_188 +happyReduction_188 = happyIn89 + (Nothing + ) + +happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_189 = happyMonadReduce 1# 74# happyReduction_189 +happyReduction_189 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsA' (sL1 happy_var_1 (StockStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_190 = happyMonadReduce 1# 74# happyReduction_190 +happyReduction_190 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsA' (sL1 happy_var_1 (AnyclassStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_191 = happyMonadReduce 1# 74# happyReduction_191 +happyReduction_191 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsA' (sL1 happy_var_1 (NewtypeStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn90 r)) + +happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_192 = happyMonadReduce 2# 75# happyReduction_192 +happyReduction_192 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut162 happy_x_2 of { (HappyWrap162 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 (ViaStrategy (XViaStrategyPs (epTok happy_var_1) happy_var_2))))}}) + ) (\r -> happyReturn (happyIn91 r)) + +happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_193 = happyMonadReduce 1# 76# happyReduction_193 +happyReduction_193 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( fmap Just $ amsA' (sL1 happy_var_1 (StockStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn92 r)) + +happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_194 = happyMonadReduce 1# 76# happyReduction_194 +happyReduction_194 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( fmap Just $ amsA' (sL1 happy_var_1 (AnyclassStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn92 r)) + +happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_195 = happyMonadReduce 1# 76# happyReduction_195 +happyReduction_195 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( fmap Just $ amsA' (sL1 happy_var_1 (NewtypeStrategy (epTok happy_var_1))))}) + ) (\r -> happyReturn (happyIn92 r)) + +happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_196 = happySpecReduce_1 76# happyReduction_196 +happyReduction_196 happy_x_1 + = case happyOut91 happy_x_1 of { (HappyWrap91 happy_var_1) -> + happyIn92 + (Just happy_var_1 + )} + +happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_197 = happySpecReduce_0 76# happyReduction_197 +happyReduction_197 = happyIn92 + (Nothing + ) + +happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_198 = happySpecReduce_0 77# happyReduction_198 +happyReduction_198 = happyIn93 + (Nothing + ) + +happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_199 = happyMonadReduce 1# 77# happyReduction_199 +happyReduction_199 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + ( fmap Just $ amsA' (reLoc happy_var_1))}) + ) (\r -> happyReturn (happyIn93 r)) + +happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_200 = happySpecReduce_0 78# happyReduction_200 +happyReduction_200 = happyIn94 + (noLoc (noAnn, Nothing) + ) + +happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_201 = happySpecReduce_2 78# happyReduction_201 +happyReduction_201 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { (HappyWrap95 happy_var_2) -> + happyIn94 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1) + , Just (happy_var_2)) + )}} + +happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_202 = happyMonadReduce 3# 79# happyReduction_202 +happyReduction_202 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut96 happy_x_3 of { (HappyWrap96 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 (InjectivityAnn (epUniTok happy_var_2) happy_var_1 (reverse (unLoc happy_var_3)))))}}}) + ) (\r -> happyReturn (happyIn95 r)) + +happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_203 = happySpecReduce_2 80# happyReduction_203 +happyReduction_203 happy_x_2 + happy_x_1 + = case happyOut96 happy_x_1 of { (HappyWrap96 happy_var_1) -> + case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> + happyIn96 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_204 = happySpecReduce_1 80# happyReduction_204 +happyReduction_204 happy_x_1 + = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> + happyIn96 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_205 = happySpecReduce_0 81# happyReduction_205 +happyReduction_205 = happyIn97 + (noLoc (noAnn,OpenTypeFamily) + ) + +happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_206 = happySpecReduce_2 81# happyReduction_206 +happyReduction_206 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut98 happy_x_2 of { (HappyWrap98 happy_var_2) -> + happyIn97 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1,(fst $ unLoc happy_var_2)) + ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2)) + )}} + +happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_207 = happySpecReduce_3 82# happyReduction_207 +happyReduction_207 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut99 happy_x_2 of { (HappyWrap99 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn98 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1,noAnn, epTok happy_var_3) + ,Just (unLoc happy_var_2)) + )}}} + +happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_208 = happySpecReduce_3 82# happyReduction_208 +happyReduction_208 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut99 happy_x_2 of { (HappyWrap99 happy_var_2) -> + happyIn98 + (let (L loc _) = happy_var_2 in + L loc (noAnn,Just (unLoc happy_var_2)) + )} + +happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_209 = happySpecReduce_3 82# happyReduction_209 +happyReduction_209 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn98 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1,epTok happy_var_2 ,epTok happy_var_3),Nothing) + )}}} + +happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_210 = happySpecReduce_3 82# happyReduction_210 +happyReduction_210 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn98 + (let (L loc _) = happy_var_2 in + L loc ((noAnn,epTok happy_var_2, noAnn),Nothing) + )} + +happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_211 = happyMonadReduce 3# 83# happyReduction_211 +happyReduction_211 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( let (L loc eqn) = happy_var_3 in + case unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 (L loc eqn : unLoc happy_var_1)) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) + ) (\r -> happyReturn (happyIn99 r)) + +happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_212 = happyMonadReduce 2# 83# happyReduction_212 +happyReduction_212 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case unLoc happy_var_1 of + [] -> return (sLZ happy_var_1 happy_var_2 (unLoc happy_var_1)) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (h':t)))}}) + ) (\r -> happyReturn (happyIn99 r)) + +happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_213 = happySpecReduce_1 83# happyReduction_213 +happyReduction_213 happy_x_1 + = case happyOut100 happy_x_1 of { (HappyWrap100 happy_var_1) -> + happyIn99 + (sLL happy_var_1 happy_var_1 [happy_var_1] + )} + +happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_214 = happySpecReduce_0 83# happyReduction_214 +happyReduction_214 = happyIn99 + (noLoc [] + ) + +happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_215 = happyMonadReduce 6# 84# happyReduction_215 +happyReduction_215 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut172 happy_x_4 of { (HappyWrap172 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut168 happy_x_6 of { (HappyWrap168 happy_var_6) -> + ( do { hintExplicitForall happy_var_1 + ; tvbs <- fromSpecTyVarBndrs happy_var_2 + ; let loc = comb2 happy_var_1 happy_var_6 + ; !cs <- getCommentsFor loc + ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1, epTok happy_var_3) cs) tvbs) happy_var_4 happy_var_6 (epTok happy_var_5) })}}}}}}) + ) (\r -> happyReturn (happyIn100 r)) + +happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_216 = happyMonadReduce 3# 84# happyReduction_216 +happyReduction_216 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> + ( mkTyFamInstEqn (comb2 happy_var_1 happy_var_3) mkHsOuterImplicit happy_var_1 happy_var_3 (epTok happy_var_2))}}}) + ) (\r -> happyReturn (happyIn100 r)) + +happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_217 = happyMonadReduce 4# 85# happyReduction_217 +happyReduction_217 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut102 happy_x_2 of { (HappyWrap102 happy_var_2) -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut108 happy_x_4 of { (HappyWrap108 happy_var_4) -> + ( do { let { tdcolon = fst $ unLoc happy_var_4 } + ; liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) DataFamily NotTopLevel happy_var_3 + (snd $ unLoc happy_var_4) Nothing + (AnnFamilyDecl [] [] noAnn (epTok happy_var_1) happy_var_2 tdcolon noAnn noAnn noAnn noAnn noAnn noAnn)) })}}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_218 = happyMonadReduce 3# 85# happyReduction_218 +happyReduction_218 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut172 happy_x_2 of { (HappyWrap172 happy_var_2) -> + case happyOut110 happy_x_3 of { (HappyWrap110 happy_var_3) -> + ( do { let { (tdcolon, tequal, tvbar) = fst $ unLoc happy_var_3 } + ; liftM mkTyClD + (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_3) OpenTypeFamily NotTopLevel happy_var_2 + (fst . snd $ unLoc happy_var_3) + (snd . snd $ unLoc happy_var_3) + (AnnFamilyDecl [] [] (epTok happy_var_1) noAnn noAnn tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) })}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_219 = happyMonadReduce 4# 85# happyReduction_219 +happyReduction_219 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + case happyOut110 happy_x_4 of { (HappyWrap110 happy_var_4) -> + ( do { let { (tdcolon, tequal, tvbar) = fst $ unLoc happy_var_4 } + ; liftM mkTyClD + (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) OpenTypeFamily NotTopLevel happy_var_3 + (fst . snd $ unLoc happy_var_4) + (snd . snd $ unLoc happy_var_4) + (AnnFamilyDecl [] [] (epTok happy_var_1) noAnn (epTok happy_var_2) tdcolon tequal tvbar noAnn noAnn noAnn noAnn)) })}}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_220 = happyMonadReduce 2# 85# happyReduction_220 +happyReduction_220 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { (HappyWrap100 happy_var_2) -> + ( liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) + (epTok happy_var_1) NoEpTok))}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_221 = happyMonadReduce 3# 85# happyReduction_221 +happyReduction_221 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) + (epTok happy_var_1) (epTok happy_var_2) ))}}}) + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_222 = happySpecReduce_0 86# happyReduction_222 +happyReduction_222 = happyIn102 + (noAnn + ) + +happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_223 = happySpecReduce_1 86# happyReduction_223 +happyReduction_223 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn102 + ((epTok happy_var_1) + )} + +happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_224 = happySpecReduce_0 87# happyReduction_224 +happyReduction_224 = happyIn103 + (NoEpTok + ) + +happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_225 = happySpecReduce_1 87# happyReduction_225 +happyReduction_225 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn103 + (epTok happy_var_1 + )} + +happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_226 = happyMonadReduce 3# 88# happyReduction_226 +happyReduction_226 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> + case happyOut100 happy_x_3 of { (HappyWrap100 happy_var_3) -> + ( mkTyFamInst (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) + (epTok happy_var_1) happy_var_2)}}}) + ) (\r -> happyReturn (happyIn104 r)) + +happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_227 = happyMonadReduce 6# 88# happyReduction_227 +happyReduction_227 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut198 happy_x_5 of { (HappyWrap198 happy_var_5) -> + case happyOut207 happy_x_6 of { (HappyWrap207 happy_var_6) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { tequal = fst $ unLoc happy_var_5 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (unLoc happy_var_4) + Nothing (reverse (snd $ unLoc happy_var_5)) + (fmap reverse happy_var_6) + (AnnDataDefn [] [] NoEpTok tnewtype tdata happy_var_2 NoEpUniTok NoEpTok NoEpTok NoEpTok tequal)})}}}}}}) + ) (\r -> happyReturn (happyIn104 r)) + +happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_228 = happyMonadReduce 7# 88# happyReduction_228 +happyReduction_228 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut106 happy_x_1 of { (HappyWrap106 happy_var_1) -> + case happyOut103 happy_x_2 of { (HappyWrap103 happy_var_2) -> + case happyOut113 happy_x_3 of { (HappyWrap113 happy_var_3) -> + case happyOut112 happy_x_4 of { (HappyWrap112 happy_var_4) -> + case happyOut107 happy_x_5 of { (HappyWrap107 happy_var_5) -> + case happyOut195 happy_x_6 of { (HappyWrap195 happy_var_6) -> + case happyOut207 happy_x_7 of { (HappyWrap207 happy_var_7) -> + ( do { let { (tdata, tnewtype) = fst $ unLoc happy_var_1 } + ; let { dcolon = fst $ unLoc happy_var_5 } + ; let { (twhere, oc, cc) = fst $ unLoc happy_var_6 } + ; mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 + (unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) + (fmap reverse happy_var_7) + (AnnDataDefn [] [] NoEpTok tnewtype tdata happy_var_2 dcolon twhere oc cc NoEpTok)})}}}}}}}) + ) (\r -> happyReturn (happyIn104 r)) + +happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_229 = happySpecReduce_1 89# happyReduction_229 +happyReduction_229 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sL1 happy_var_1 ((epTok happy_var_1, NoEpTok, NoEpTok), False,DataType) + )} + +happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_230 = happySpecReduce_1 89# happyReduction_230 +happyReduction_230 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn105 + (sL1 happy_var_1 ((NoEpTok, epTok happy_var_1, NoEpTok), False,NewType) + )} + +happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_231 = happySpecReduce_2 89# happyReduction_231 +happyReduction_231 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn105 + (sL1 happy_var_1 ((epTok happy_var_2, NoEpTok, epTok happy_var_1), True ,DataType) + )}} + +happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_232 = happySpecReduce_1 90# happyReduction_232 +happyReduction_232 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn106 + (sL1 happy_var_1 ((epTok happy_var_1, NoEpTok), DataType) + )} + +happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_233 = happySpecReduce_1 90# happyReduction_233 +happyReduction_233 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn106 + (sL1 happy_var_1 ((NoEpTok, epTok happy_var_1),NewType) + )} + +happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_234 = happySpecReduce_0 91# happyReduction_234 +happyReduction_234 = happyIn107 + (noLoc (NoEpUniTok , Nothing) + ) + +happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_235 = happySpecReduce_2 91# happyReduction_235 +happyReduction_235 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn107 + (sLL happy_var_1 happy_var_2 (epUniTok happy_var_1, Just happy_var_2) + )}} + +happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_236 = happySpecReduce_0 92# happyReduction_236 +happyReduction_236 = happyIn108 + (noLoc (noAnn, noLocA (NoSig noExtField) ) + ) + +happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_237 = happySpecReduce_2 92# happyReduction_237 +happyReduction_237 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn108 + (sLL happy_var_1 happy_var_2 (epUniTok happy_var_1, sLLa happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) + )}} + +happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_238 = happySpecReduce_0 93# happyReduction_238 +happyReduction_238 = happyIn109 + (noLoc (noAnn , noLocA (NoSig noExtField) ) + ) + +happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_239 = happySpecReduce_2 93# happyReduction_239 +happyReduction_239 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn109 + (sLL happy_var_1 happy_var_2 ((epUniTok happy_var_1, noAnn), sLLa happy_var_1 happy_var_2 (KindSig noExtField happy_var_2)) + )}} + +happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_240 = happyMonadReduce 2# 93# happyReduction_240 +happyReduction_240 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut187 happy_x_2 of { (HappyWrap187 happy_var_2) -> + ( do { tvb <- fromSpecTyVarBndr happy_var_2 + ; return $ sLL happy_var_1 happy_var_2 ((noAnn, epTok happy_var_1), sLLa happy_var_1 happy_var_2 (TyVarSig noExtField tvb))})}}) + ) (\r -> happyReturn (happyIn109 r)) + +happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_241 = happySpecReduce_0 94# happyReduction_241 +happyReduction_241 = happyIn110 + (noLoc (noAnn, (noLocA (NoSig noExtField), Nothing)) + ) + +happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_242 = happySpecReduce_2 94# happyReduction_242 +happyReduction_242 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut194 happy_x_2 of { (HappyWrap194 happy_var_2) -> + happyIn110 + (sLL happy_var_1 happy_var_2 ( (epUniTok happy_var_1, noAnn, noAnn) + , (sL1a happy_var_2 (KindSig noExtField happy_var_2), Nothing)) + )}} + +happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_243 = happyMonadReduce 4# 94# happyReduction_243 +happyReduction_243 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { (HappyWrap188 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut95 happy_x_4 of { (HappyWrap95 happy_var_4) -> + ( do { tvb <- fromSpecTyVarBndr happy_var_2 + ; return $ sLL happy_var_1 happy_var_4 ((noAnn, epTok happy_var_1, epTok happy_var_3) + , (sLLa happy_var_1 happy_var_2 (TyVarSig noExtField tvb), Just happy_var_4))})}}}}) + ) (\r -> happyReturn (happyIn110 r)) + +happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_244 = happyMonadReduce 3# 95# happyReduction_244 +happyReduction_244 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + ( acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc (Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn111 r)) + +happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_245 = happySpecReduce_1 95# happyReduction_245 +happyReduction_245 happy_x_1 + = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + happyIn111 + (sL1 happy_var_1 (Nothing, happy_var_1) + )} + +happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_246 = happyMonadReduce 6# 96# happyReduction_246 +happyReduction_246 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut170 happy_x_4 of { (HappyWrap170 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut172 happy_x_6 of { (HappyWrap172 happy_var_6) -> + ( hintExplicitForall happy_var_1 + >> fromSpecTyVarBndrs happy_var_2 + >>= \tvbs -> + (acs (comb2 happy_var_1 happy_var_6) (\loc cs -> (L loc + (Just ( addTrailingDarrowC happy_var_4 happy_var_5 cs) + , mkHsOuterExplicit (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1, epTok happy_var_3) emptyComments) tvbs, happy_var_6)))))}}}}}}) + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_247 = happyMonadReduce 4# 96# happyReduction_247 +happyReduction_247 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut172 happy_x_4 of { (HappyWrap172 happy_var_4) -> + ( do { hintExplicitForall happy_var_1 + ; tvbs <- fromSpecTyVarBndrs happy_var_2 + ; let loc = comb2 happy_var_1 happy_var_4 + ; !cs <- getCommentsFor loc + ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1, epTok happy_var_3) cs) tvbs, happy_var_4)) + })}}}}) + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_248 = happyMonadReduce 3# 96# happyReduction_248 +happyReduction_248 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> + ( acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc (Just (addTrailingDarrowC happy_var_1 happy_var_2 cs), mkHsOuterImplicit, happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_249 = happySpecReduce_1 96# happyReduction_249 +happyReduction_249 happy_x_1 + = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + happyIn112 + (sL1 happy_var_1 (Nothing, mkHsOuterImplicit, happy_var_1) + )} + +happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_250 = happyMonadReduce 4# 97# happyReduction_250 +happyReduction_250 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2))) + (getSTRINGs happy_var_3,getSTRING happy_var_3))) + (AnnPragma (glR happy_var_1) (epTok happy_var_4) noAnn (glR happy_var_2) (glR happy_var_3) noAnn noAnn))}}}}) + ) (\r -> happyReturn (happyIn113 r)) + +happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_251 = happyMonadReduce 3# 97# happyReduction_251 +happyReduction_251 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2))) + (AnnPragma (glR happy_var_1) (epTok happy_var_3) noAnn noAnn (glR happy_var_2) noAnn noAnn))}}}) + ) (\r -> happyReturn (happyIn113 r)) + +happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_252 = happySpecReduce_0 97# happyReduction_252 +happyReduction_252 = happyIn113 + (Nothing + ) + +happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_253 = happyMonadReduce 6# 98# happyReduction_253 +happyReduction_253 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut92 happy_x_2 of { (HappyWrap92 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut146 happy_x_4 of { (HappyWrap146 happy_var_4) -> + case happyOut89 happy_x_5 of { (HappyWrap89 happy_var_5) -> + case happyOut181 happy_x_6 of { (HappyWrap181 happy_var_6) -> + ( do { let { err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr happy_var_6) } + ; amsA' (sLL happy_var_1 happy_var_6 + (DerivDecl (happy_var_4, (epTok happy_var_1, epTok happy_var_3)) (mkHsWildCardBndrs happy_var_6) happy_var_2 happy_var_5)) })}}}}}}) + ) (\r -> happyReturn (happyIn114 r)) + +happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_254 = happyMonadReduce 4# 99# happyReduction_254 +happyReduction_254 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> + case happyOut116 happy_x_4 of { (HappyWrap116 happy_var_4) -> + ( mkRoleAnnotDecl (comb3 happy_var_1 happy_var_4 happy_var_3) happy_var_3 (reverse (unLoc happy_var_4)) + (epTok happy_var_1,epTok happy_var_2))}}}}) + ) (\r -> happyReturn (happyIn115 r)) + +happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_255 = happySpecReduce_0 100# happyReduction_255 +happyReduction_255 = happyIn116 + (noLoc [] + ) + +happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_256 = happySpecReduce_1 100# happyReduction_256 +happyReduction_256 happy_x_1 + = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> + happyIn116 + (happy_var_1 + )} + +happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_257 = happySpecReduce_1 101# happyReduction_257 +happyReduction_257 happy_x_1 + = case happyOut118 happy_x_1 of { (HappyWrap118 happy_var_1) -> + happyIn117 + (sLL happy_var_1 happy_var_1 [happy_var_1] + )} + +happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_258 = happySpecReduce_2 101# happyReduction_258 +happyReduction_258 happy_x_2 + happy_x_1 + = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> + case happyOut118 happy_x_2 of { (HappyWrap118 happy_var_2) -> + happyIn117 + (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 + )}} + +happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_259 = happySpecReduce_1 102# happyReduction_259 +happyReduction_259 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn118 + (sL1 happy_var_1 $ Just $ getVARID happy_var_1 + )} + +happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_260 = happySpecReduce_1 102# happyReduction_260 +happyReduction_260 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn118 + (sL1 happy_var_1 Nothing + )} + +happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_261 = happyMonadReduce 4# 103# happyReduction_261 +happyReduction_261 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut258 happy_x_4 of { (HappyWrap258 happy_var_4) -> + ( let (name, args, (mo, mc) ) = happy_var_2 in + amsA' (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 + ImplicitBidirectional + (AnnPSB (epTok happy_var_1) mo mc Nothing (Just (epTok happy_var_3)))))}}}}) + ) (\r -> happyReturn (happyIn119 r)) + +happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_262 = happyMonadReduce 4# 103# happyReduction_262 +happyReduction_262 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut258 happy_x_4 of { (HappyWrap258 happy_var_4) -> + ( let (name, args, (mo,mc)) = happy_var_2 in + amsA' (sLL happy_var_1 happy_var_4 . ValD noExtField $ mkPatSynBind name args happy_var_4 Unidirectional + (AnnPSB (epTok happy_var_1) mo mc (Just (epUniTok happy_var_3)) Nothing)))}}}}) + ) (\r -> happyReturn (happyIn119 r)) + +happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_263 = happyMonadReduce 5# 103# happyReduction_263 +happyReduction_263 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut258 happy_x_4 of { (HappyWrap258 happy_var_4) -> + case happyOut123 happy_x_5 of { (HappyWrap123 happy_var_5) -> + ( do { let (name, args, (mo,mc)) = happy_var_2 + ; mg <- mkPatSynMatchGroup name happy_var_5 + ; amsA' (sLL happy_var_1 happy_var_5 . ValD noExtField $ + mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg) + (AnnPSB (epTok happy_var_1) mo mc (Just (epUniTok happy_var_3)) Nothing)) + })}}}}}) + ) (\r -> happyReturn (happyIn119 r)) + +happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_264 = happySpecReduce_2 104# happyReduction_264 +happyReduction_264 happy_x_2 + happy_x_1 + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> + happyIn120 + ((happy_var_1, PrefixCon happy_var_2, noAnn) + )}} + +happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_265 = happySpecReduce_3 104# happyReduction_265 +happyReduction_265 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> + case happyOut320 happy_x_3 of { (HappyWrap320 happy_var_3) -> + happyIn120 + ((happy_var_2, InfixCon happy_var_1 happy_var_3, noAnn) + )}}} + +happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_266 = happyReduce 4# 104# happyReduction_266 +happyReduction_266 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut122 happy_x_3 of { (HappyWrap122 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn120 + ((happy_var_1, RecCon happy_var_3, (Just (epTok happy_var_2), Just (epTok happy_var_4))) + ) `HappyStk` happyRest}}}} + +happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_267 = happySpecReduce_0 105# happyReduction_267 +happyReduction_267 = happyIn121 + ([] + ) + +happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_268 = happySpecReduce_2 105# happyReduction_268 +happyReduction_268 happy_x_2 + happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> + happyIn121 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_269 = happySpecReduce_1 106# happyReduction_269 +happyReduction_269 happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + happyIn122 + ([RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1] + )} + +happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_270 = happyMonadReduce 3# 106# happyReduction_270 +happyReduction_270 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut122 happy_x_3 of { (HappyWrap122 happy_var_3) -> + ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; return ((RecordPatSynField (mkFieldOcc h) h) : happy_var_3 )})}}}) + ) (\r -> happyReturn (happyIn122 r)) + +happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_271 = happyMonadReduce 4# 107# happyReduction_271 +happyReduction_271 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut134 happy_x_3 of { (HappyWrap134 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsr (sLL happy_var_1 happy_var_4 (thdOf3 $ unLoc happy_var_3)) + (AnnList (Just (fstOf3 $ unLoc happy_var_3)) (ListBraces (epTok happy_var_2) (epTok happy_var_4)) (sndOf3 $ unLoc happy_var_3) (epTok happy_var_1) []))}}}}) + ) (\r -> happyReturn (happyIn123 r)) + +happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_272 = happyMonadReduce 4# 107# happyReduction_272 +happyReduction_272 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut134 happy_x_3 of { (HappyWrap134 happy_var_3) -> + ( amsr (sLL happy_var_1 happy_var_3 (thdOf3 $ unLoc happy_var_3)) + (AnnList (Just (fstOf3 $ unLoc happy_var_3)) ListNone (sndOf3 $ unLoc happy_var_3) (epTok happy_var_1) []))}}) + ) (\r -> happyReturn (happyIn123 r)) + +happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_273 = happyMonadReduce 4# 108# happyReduction_273 +happyReduction_273 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + ( amsA' (sLL happy_var_1 happy_var_4 + $ PatSynSig (AnnSig (epUniTok happy_var_3) (Just (epTok happy_var_1)) Nothing) + (toList $ unLoc happy_var_2) happy_var_4))}}}}) + ) (\r -> happyReturn (happyIn124 r)) + +happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_274 = happySpecReduce_1 109# happyReduction_274 +happyReduction_274 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn125 + (happy_var_1 + )} + +happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_275 = happySpecReduce_1 109# happyReduction_275 +happyReduction_275 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn125 + (happy_var_1 + )} + +happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_276 = happySpecReduce_1 110# happyReduction_276 +happyReduction_276 happy_x_1 + = case happyOut101 happy_x_1 of { (HappyWrap101 happy_var_1) -> + happyIn126 + (happy_var_1 + )} + +happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_277 = happySpecReduce_1 110# happyReduction_277 +happyReduction_277 happy_x_1 + = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> + happyIn126 + (happy_var_1 + )} + +happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_278 = happyMonadReduce 4# 110# happyReduction_278 +happyReduction_278 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + do { v <- checkValSigLhs happy_var_2 + ; let err = text "in default signature" <> colon <+> + quotes (ppr happy_var_2) + ; amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField $ ClassOpSig (AnnSig (epUniTok happy_var_3) Nothing (Just (epTok happy_var_1))) True [v] happy_var_4) })}}}}) + ) (\r -> happyReturn (happyIn126 r)) + +happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_279 = happyMonadReduce 3# 111# happyReduction_279 +happyReduction_279 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut126 happy_x_3 of { (HappyWrap126 happy_var_3) -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + , unitOL happy_var_3)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + , snocOL hs t' `appOL` unitOL happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn127 r)) + +happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_280 = happyMonadReduce 2# 111# happyReduction_280 +happyReduction_280 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut127 happy_x_1 of { (HappyWrap127 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLZ happy_var_1 happy_var_2 ( (fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,snd $ unLoc happy_var_1)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 + , snocOL hs t')))}}) + ) (\r -> happyReturn (happyIn127 r)) + +happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_281 = happySpecReduce_1 111# happyReduction_281 +happyReduction_281 happy_x_1 + = case happyOut126 happy_x_1 of { (HappyWrap126 happy_var_1) -> + happyIn127 + (sL1 happy_var_1 ([], unitOL happy_var_1) + )} + +happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_282 = happySpecReduce_0 111# happyReduction_282 +happyReduction_282 = happyIn127 + (noLoc ([],nilOL) + ) + +happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_283 = happySpecReduce_3 112# happyReduction_283 +happyReduction_283 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn128 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1, fst $ unLoc happy_var_2, epTok happy_var_3) + ,snd $ unLoc happy_var_2, epExplicitBraces happy_var_1 happy_var_3) + )}}} + +happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_284 = happySpecReduce_3 112# happyReduction_284 +happyReduction_284 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> + happyIn128 + (let { L l (anns, decls) = happy_var_2 } + in L l ((NoEpTok, anns, NoEpTok), decls, EpVirtualBraces (getVOCURLY happy_var_1)) + )}} + +happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_285 = happySpecReduce_2 113# happyReduction_285 +happyReduction_285 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_2 of { (HappyWrap128 happy_var_2) -> + happyIn129 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1,fstOf3 $ unLoc happy_var_2) + ,sndOf3 $ unLoc happy_var_2,thdOf3 $ unLoc happy_var_2) + )}} + +happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_286 = happySpecReduce_0 113# happyReduction_286 +happyReduction_286 = happyIn129 + (noLoc ((noAnn, noAnn),nilOL,EpNoLayout) + ) + +happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_287 = happySpecReduce_1 114# happyReduction_287 +happyReduction_287 happy_x_1 + = case happyOut104 happy_x_1 of { (HappyWrap104 happy_var_1) -> + happyIn130 + (sL1 happy_var_1 (unitOL (sL1a happy_var_1 (InstD noExtField (unLoc happy_var_1)))) + )} + +happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_288 = happySpecReduce_1 114# happyReduction_288 +happyReduction_288 happy_x_1 + = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> + happyIn130 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_289 = happyMonadReduce 3# 115# happyReduction_289 +happyReduction_289 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut131 happy_x_1 of { (HappyWrap131 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut130 happy_x_3 of { (HappyWrap130 happy_var_3) -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + , unLoc happy_var_3)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + , snocOL hs t' `appOL` unLoc happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn131 r)) + +happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_290 = happyMonadReduce 2# 115# happyReduction_290 +happyReduction_290 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut131 happy_x_1 of { (HappyWrap131 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (snd $ unLoc happy_var_1) + then return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,snd $ unLoc happy_var_1)) + else case (snd $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1 + , snocOL hs t')))}}) + ) (\r -> happyReturn (happyIn131 r)) + +happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_291 = happySpecReduce_1 115# happyReduction_291 +happyReduction_291 happy_x_1 + = case happyOut130 happy_x_1 of { (HappyWrap130 happy_var_1) -> + happyIn131 + (sL1 happy_var_1 ([],unLoc happy_var_1) + )} + +happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_292 = happySpecReduce_0 115# happyReduction_292 +happyReduction_292 = happyIn131 + (noLoc ([],nilOL) + ) + +happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_293 = happySpecReduce_3 116# happyReduction_293 +happyReduction_293 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn132 + (sLL happy_var_1 happy_var_3 ((epTok happy_var_1,epTok happy_var_3,fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) + )}}} + +happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_294 = happySpecReduce_3 116# happyReduction_294 +happyReduction_294 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> + happyIn132 + (L (gl happy_var_2) ((noAnn,noAnn,fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) + )} + +happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_295 = happySpecReduce_2 117# happyReduction_295 +happyReduction_295 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut132 happy_x_2 of { (HappyWrap132 happy_var_2) -> + happyIn133 + (sLL happy_var_1 happy_var_2 ((epTok happy_var_1,(fst $ unLoc happy_var_2)) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_296 = happySpecReduce_0 117# happyReduction_296 +happyReduction_296 = happyIn133 + (noLoc (noAnn,nilOL) + ) + +happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_297 = happyMonadReduce 3# 118# happyReduction_297 +happyReduction_297 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut134 happy_x_1 of { (HappyWrap134 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut212 happy_x_3 of { (HappyWrap212 happy_var_3) -> + ( if isNilOL (thdOf3 $ unLoc happy_var_1) + then return (sLL happy_var_2 happy_var_3 (glR happy_var_3, (sndOf3 $ unLoc happy_var_1) ++ (msemiA happy_var_2) + , unitOL happy_var_3)) + else case (thdOf3 $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + let { this = unitOL happy_var_3; + rest = snocOL hs t'; + these = rest `appOL` this } + return (rest `seq` this `seq` these `seq` + (sLL happy_var_1 happy_var_3 (glEE (fstOf3 $ unLoc happy_var_1) happy_var_3, sndOf3 $ unLoc happy_var_1, these))))}}}) + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_298 = happyMonadReduce 2# 118# happyReduction_298 +happyReduction_298 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut134 happy_x_1 of { (HappyWrap134 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL (thdOf3 $ unLoc happy_var_1) + then return (sLZ happy_var_1 happy_var_2 (glR happy_var_2, (sndOf3 $ unLoc happy_var_1) ++ (msemiA happy_var_2) + ,thdOf3 $ unLoc happy_var_1)) + else case (thdOf3 $ unLoc happy_var_1) of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (glEEz happy_var_1 happy_var_2, sndOf3 $ unLoc happy_var_1, snocOL hs t')))}}) + ) (\r -> happyReturn (happyIn134 r)) + +happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_299 = happySpecReduce_1 118# happyReduction_299 +happyReduction_299 happy_x_1 + = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> + happyIn134 + (sL1 happy_var_1 (glR happy_var_1, [], unitOL happy_var_1) + )} + +happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_300 = happySpecReduce_0 118# happyReduction_300 +happyReduction_300 = happyIn134 + (noLoc (noAnn, [],nilOL) + ) + +happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_301 = happySpecReduce_3 119# happyReduction_301 +happyReduction_301 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn135 + (sLL happy_var_1 happy_var_3 (AnnList (Just (fstOf3 $ unLoc happy_var_2)) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (sndOf3 $ unLoc happy_var_2) noAnn [] + ,sL1 happy_var_2 $ thdOf3 $ unLoc happy_var_2) + )}}} + +happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_302 = happySpecReduce_3 119# happyReduction_302 +happyReduction_302 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> + happyIn135 + (sL1 happy_var_2 (AnnList (Just (fstOf3 $ unLoc happy_var_2)) ListNone (sndOf3 $ unLoc happy_var_2) noAnn [] + ,sL1 happy_var_2 $ thdOf3 $ unLoc happy_var_2) + )} + +happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_303 = happyMonadReduce 1# 120# happyReduction_303 +happyReduction_303 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut135 happy_x_1 of { (HappyWrap135 happy_var_1) -> + ( do { let { (AnnList anc p s _ t, decls) = unLoc happy_var_1 } + ; val_binds <- cvBindGroup (unLoc $ decls) + ; !cs <- getCommentsFor (gl happy_var_1) + ; return (sL1 happy_var_1 $ HsValBinds (EpAnn (glR happy_var_1) (AnnList anc p s noAnn t) cs) val_binds)})}) + ) (\r -> happyReturn (happyIn136 r)) + +happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_304 = happyMonadReduce 3# 120# happyReduction_304 +happyReduction_304 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( acs (comb3 happy_var_1 happy_var_2 happy_var_3) (\loc cs -> (L loc + $ HsIPBinds (EpAnn (spanAsAnchor (comb3 happy_var_1 happy_var_2 happy_var_3)) (AnnList (Just$ glR happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}}) + ) (\r -> happyReturn (happyIn136 r)) + +happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_305 = happyMonadReduce 3# 120# happyReduction_305 +happyReduction_305 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> + ( acs (gl happy_var_2) (\loc cs -> (L loc + $ HsIPBinds (EpAnn (glR happy_var_1) (AnnList (Just $ glR happy_var_2) ListNone [] noAnn []) cs) (IPBinds noExtField (reverse $ unLoc happy_var_2)))))}}) + ) (\r -> happyReturn (happyIn136 r)) + +happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_306 = happyMonadReduce 2# 121# happyReduction_306 +happyReduction_306 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> + ( do { r <- acs (comb2 happy_var_1 happy_var_2) (\loc cs -> + (L loc (annBinds (epTok happy_var_1) cs (unLoc happy_var_2)))) + ; return $ Just r})}}) + ) (\r -> happyReturn (happyIn137 r)) + +happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_307 = happySpecReduce_0 121# happyReduction_307 +happyReduction_307 = happyIn137 + (Nothing + ) + +happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_308 = happyMonadReduce 3# 122# happyReduction_308 +happyReduction_308 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut139 happy_x_3 of { (HappyWrap139 happy_var_3) -> + ( case happy_var_1 of + [] -> return (happy_var_3:happy_var_1) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (happy_var_3:h':t))}}}) + ) (\r -> happyReturn (happyIn138 r)) + +happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_309 = happyMonadReduce 2# 122# happyReduction_309 +happyReduction_309 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case happy_var_1 of + [] -> return happy_var_1 + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (h':t))}}) + ) (\r -> happyReturn (happyIn138 r)) + +happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_310 = happySpecReduce_1 122# happyReduction_310 +happyReduction_310 happy_x_1 + = case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> + happyIn138 + ([happy_var_1] + )} + +happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_311 = happySpecReduce_0 122# happyReduction_311 +happyReduction_311 = happyIn138 + ([] + ) + +happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_312 = happyMonadReduce 6# 123# happyReduction_312 +happyReduction_312 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut140 happy_x_2 of { (HappyWrap140 happy_var_2) -> + case happyOut143 happy_x_3 of { (HappyWrap143 happy_var_3) -> + case happyOut224 happy_x_4 of { (HappyWrap224 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut221 happy_x_6 of { (HappyWrap221 happy_var_6) -> + (runPV (unECP happy_var_4) >>= \ happy_var_4 -> + runPV (unECP happy_var_6) >>= \ happy_var_6 -> + amsA' (sLL happy_var_1 happy_var_6 $ HsRule + { rd_ext =((fst happy_var_2, epTok happy_var_5), getSTRINGs happy_var_1) + , rd_name = L (noAnnSrcSpan $ gl happy_var_1) (getSTRING happy_var_1) + , rd_act = snd happy_var_2 `orElse` AlwaysActive + , rd_bndrs = ruleBndrsOrDef happy_var_3 + , rd_lhs = happy_var_4, rd_rhs = happy_var_6 }))}}}}}}) + ) (\r -> happyReturn (happyIn139 r)) + +happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_313 = happySpecReduce_0 124# happyReduction_313 +happyReduction_313 = happyIn140 + ((noAnn, Nothing) + ) + +happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_314 = happySpecReduce_1 124# happyReduction_314 +happyReduction_314 happy_x_1 + = case happyOut142 happy_x_1 of { (HappyWrap142 happy_var_1) -> + happyIn140 + ((fst happy_var_1,Just (snd happy_var_1)) + )} + +happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_315 = happySpecReduce_1 125# happyReduction_315 +happyReduction_315 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn141 + ((Just (epTok happy_var_1)) + )} + +happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_316 = happyMonadReduce 1# 125# happyReduction_316 +happyReduction_316 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( if (getVARSYM happy_var_1 == fsLit "~") + then return (Just (epTok happy_var_1)) + else do { addError $ mkPlainErrorMsgEnvelope (getLoc happy_var_1) $ + PsErrInvalidRuleActivationMarker + ; return Nothing })}) + ) (\r -> happyReturn (happyIn141 r)) + +happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_317 = happySpecReduce_3 126# happyReduction_317 +happyReduction_317 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn142 + (( ActivationAnn (epTok happy_var_1) (epTok happy_var_3) Nothing (Just (glR happy_var_2)) + , ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) + )}}} + +happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_318 = happyReduce 4# 126# happyReduction_318 +happyReduction_318 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn142 + (( ActivationAnn (epTok happy_var_1) (epTok happy_var_4) happy_var_2 (Just (glR happy_var_3)) + , ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) + ) `HappyStk` happyRest}}}} + +happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_319 = happySpecReduce_3 126# happyReduction_319 +happyReduction_319 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn142 + (( ActivationAnn (epTok happy_var_1) (epTok happy_var_3) happy_var_2 Nothing + , NeverActive) + )}}} + +happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_320 = happyMonadReduce 6# 127# happyReduction_320 +happyReduction_320 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut144 happy_x_5 of { (HappyWrap144 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( hintExplicitForall happy_var_1 + >> checkRuleTyVarBndrNames happy_var_2 + >> let ann = HsRuleBndrsAnn + (Just (epUniTok happy_var_1,epTok happy_var_3)) + (Just (epUniTok happy_var_4,epTok happy_var_6)) + in return (Just (mkRuleBndrs ann (Just happy_var_2) happy_var_5)))}}}}}}) + ) (\r -> happyReturn (happyIn143 r)) + +happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_321 = happySpecReduce_3 127# happyReduction_321 +happyReduction_321 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn143 + (Just (mkRuleBndrs (HsRuleBndrsAnn Nothing (Just (epUniTok happy_var_1,epTok happy_var_3))) + Nothing happy_var_2) + )}}} + +happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_322 = happySpecReduce_0 127# happyReduction_322 +happyReduction_322 = happyIn143 + (Nothing + ) + +happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_323 = happySpecReduce_2 128# happyReduction_323 +happyReduction_323 happy_x_2 + happy_x_1 + = case happyOut145 happy_x_1 of { (HappyWrap145 happy_var_1) -> + case happyOut144 happy_x_2 of { (HappyWrap144 happy_var_2) -> + happyIn144 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_324 = happySpecReduce_0 128# happyReduction_324 +happyReduction_324 = happyIn144 + ([] + ) + +happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_325 = happySpecReduce_1 129# happyReduction_325 +happyReduction_325 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn145 + (sL1a happy_var_1 (RuleTyTmVar noAnn happy_var_1 Nothing) + )} + +happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_326 = happyMonadReduce 5# 129# happyReduction_326 +happyReduction_326 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut169 happy_x_4 of { (HappyWrap169 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 (RuleTyTmVar (AnnTyVarBndr [glR happy_var_1] [glR happy_var_5] noAnn (epUniTok happy_var_3)) happy_var_2 (Just happy_var_4))))}}}}}) + ) (\r -> happyReturn (happyIn145 r)) + +happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_327 = happyMonadReduce 3# 130# happyReduction_327 +happyReduction_327 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut153 happy_x_2 of { (HappyWrap153 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (getDEPRECATED_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2)) + (AnnPragma (glR happy_var_1) (epTok happy_var_3) (fst $ unLoc happy_var_2) noAnn noAnn noAnn noAnn))}}}) + ) (\r -> happyReturn (happyIn146 r)) + +happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_328 = happyMonadReduce 4# 130# happyReduction_328 +happyReduction_328 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut147 happy_x_2 of { (HappyWrap147 happy_var_2) -> + case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( fmap Just $ amsr (sLL happy_var_1 happy_var_4 $ WarningTxt happy_var_2 (getWARNING_PRAGs happy_var_1) (map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3)) + (AnnPragma (glR happy_var_1) (epTok happy_var_4) (fst $ unLoc happy_var_3) noAnn noAnn noAnn noAnn))}}}}) + ) (\r -> happyReturn (happyIn146 r)) + +happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_329 = happySpecReduce_0 130# happyReduction_329 +happyReduction_329 = happyIn146 + (Nothing + ) + +happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_330 = happySpecReduce_2 131# happyReduction_330 +happyReduction_330 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn147 + (Just (reLoc $ sLL happy_var_1 happy_var_2 $ InWarningCategory (epTok happy_var_1) (getSTRINGs happy_var_2) + (reLoc $ sL1 happy_var_2 $ mkWarningCategory (getSTRING happy_var_2))) + )}} + +happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_331 = happySpecReduce_0 131# happyReduction_331 +happyReduction_331 = happyIn147 + (Nothing + ) + +happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_332 = happyMonadReduce 3# 132# happyReduction_332 +happyReduction_332 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut148 happy_x_1 of { (HappyWrap148 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> + ( if isNilOL happy_var_1 + then return (happy_var_1 `appOL` happy_var_3) + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn148 r)) + +happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_333 = happyMonadReduce 2# 132# happyReduction_333 +happyReduction_333 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut148 happy_x_1 of { (HappyWrap148 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL happy_var_1 + then return happy_var_1 + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn148 r)) + +happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_334 = happySpecReduce_1 132# happyReduction_334 +happyReduction_334 happy_x_1 + = case happyOut149 happy_x_1 of { (HappyWrap149 happy_var_1) -> + happyIn148 + (happy_var_1 + )} + +happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_335 = happySpecReduce_0 132# happyReduction_335 +happyReduction_335 = happyIn148 + (nilOL + ) + +happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_336 = happyMonadReduce 4# 133# happyReduction_336 +happyReduction_336 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut147 happy_x_1 of { (HappyWrap147 happy_var_1) -> + case happyOut150 happy_x_2 of { (HappyWrap150 happy_var_2) -> + case happyOut284 happy_x_3 of { (HappyWrap284 happy_var_3) -> + case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> + ( fmap unitOL $ amsA' (L (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) + (Warning (unLoc happy_var_2, fst $ unLoc happy_var_4) (unLoc happy_var_3) + (WarningTxt happy_var_1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_4))))}}}}) + ) (\r -> happyReturn (happyIn149 r)) + +happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_337 = happySpecReduce_1 134# happyReduction_337 +happyReduction_337 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn150 + (sL1 happy_var_1 $ TypeNamespaceSpecifier (epTok happy_var_1) + )} + +happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_338 = happySpecReduce_1 134# happyReduction_338 +happyReduction_338 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn150 + (sL1 happy_var_1 $ DataNamespaceSpecifier (epTok happy_var_1) + )} + +happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_339 = happySpecReduce_0 134# happyReduction_339 +happyReduction_339 = happyIn150 + (sL0 $ NoNamespaceSpecifier + ) + +happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_340 = happyMonadReduce 3# 135# happyReduction_340 +happyReduction_340 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut151 happy_x_1 of { (HappyWrap151 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut152 happy_x_3 of { (HappyWrap152 happy_var_3) -> + ( if isNilOL happy_var_1 + then return (happy_var_1 `appOL` happy_var_3) + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t' `appOL` happy_var_3))}}}) + ) (\r -> happyReturn (happyIn151 r)) + +happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_341 = happyMonadReduce 2# 135# happyReduction_341 +happyReduction_341 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut151 happy_x_1 of { (HappyWrap151 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( if isNilOL happy_var_1 + then return happy_var_1 + else case happy_var_1 of + SnocOL hs t -> do + t' <- addTrailingSemiA t (epTok happy_var_2) + return (snocOL hs t'))}}) + ) (\r -> happyReturn (happyIn151 r)) + +happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_342 = happySpecReduce_1 135# happyReduction_342 +happyReduction_342 happy_x_1 + = case happyOut152 happy_x_1 of { (HappyWrap152 happy_var_1) -> + happyIn151 + (happy_var_1 + )} + +happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_343 = happySpecReduce_0 135# happyReduction_343 +happyReduction_343 = happyIn151 + (nilOL + ) + +happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_344 = happyMonadReduce 3# 136# happyReduction_344 +happyReduction_344 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut150 happy_x_1 of { (HappyWrap150 happy_var_1) -> + case happyOut284 happy_x_2 of { (HappyWrap284 happy_var_2) -> + case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> + ( fmap unitOL $ amsA' (sL (comb3 happy_var_1 happy_var_2 happy_var_3) $ (Warning (unLoc happy_var_1, fst $ unLoc happy_var_3) (unLoc happy_var_2) + (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn152 r)) + +happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_345 = happySpecReduce_1 137# happyReduction_345 +happyReduction_345 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn153 + (sL1 happy_var_1 (noAnn,[L (gl happy_var_1) (getStringLiteral happy_var_1)]) + )} + +happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_346 = happySpecReduce_3 137# happyReduction_346 +happyReduction_346 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut154 happy_x_2 of { (HappyWrap154 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn153 + (sLL happy_var_1 happy_var_3 $ ((epTok happy_var_1,epTok happy_var_3),fromOL (unLoc happy_var_2)) + )}}} + +happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_347 = happyMonadReduce 3# 138# happyReduction_347 +happyReduction_347 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( if isNilOL (unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` + (L (gl happy_var_3) (getStringLiteral happy_var_3)))) + else case (unLoc happy_var_1) of + SnocOL hs t -> do + let { t' = addTrailingCommaS t (glR happy_var_2) } + return (sLL happy_var_1 happy_var_3 (snocOL hs t' `snocOL` + (L (gl happy_var_3) (getStringLiteral happy_var_3)))))}}}) + ) (\r -> happyReturn (happyIn154 r)) + +happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_348 = happySpecReduce_1 138# happyReduction_348 +happyReduction_348 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn154 + (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getStringLiteral happy_var_1))) + )} + +happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_349 = happySpecReduce_0 138# happyReduction_349 +happyReduction_349 = happyIn154 + (noLoc nilOL + ) + +happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_350 = happyMonadReduce 4# 139# happyReduction_350 +happyReduction_350 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut285 happy_x_2 of { (HappyWrap285 happy_var_2) -> + case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation + (AnnPragma (glR happy_var_1) (epTok happy_var_4) noAnn noAnn noAnn noAnn noAnn, + (getANN_PRAGs happy_var_1)) + (ValueAnnProvenance happy_var_2) happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_351 = happyMonadReduce 5# 139# happyReduction_351 +happyReduction_351 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut305 happy_x_3 of { (HappyWrap305 happy_var_3) -> + case happyOut230 happy_x_4 of { (HappyWrap230 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + amsA' (sLL happy_var_1 happy_var_5 (AnnD noExtField $ HsAnnotation + (AnnPragma (glR happy_var_1) (epTok happy_var_5) noAnn noAnn noAnn (epTok happy_var_2) noAnn, + (getANN_PRAGs happy_var_1)) + (TypeAnnProvenance happy_var_3) happy_var_4)))}}}}}) + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_352 = happyMonadReduce 4# 139# happyReduction_352 +happyReduction_352 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_4 (AnnD noExtField $ HsAnnotation + (AnnPragma (glR happy_var_1) (epTok happy_var_4) noAnn noAnn noAnn noAnn (epTok happy_var_2), + (getANN_PRAGs happy_var_1)) + ModuleAnnProvenance happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn155 r)) + +happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_353 = happyMonadReduce 4# 140# happyReduction_353 +happyReduction_353 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> + case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> + case happyOut159 happy_x_4 of { (HappyWrap159 happy_var_4) -> + ( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) (epTok happy_var_1, fst $ unLoc happy_var_4) >>= \i -> + return (sLL happy_var_1 happy_var_4 i))}}}}) + ) (\r -> happyReturn (happyIn156 r)) + +happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_354 = happyMonadReduce 3# 140# happyReduction_354 +happyReduction_354 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> + case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> + ( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3) (epTok happy_var_1, fst $ unLoc happy_var_3); + return (sLL happy_var_1 happy_var_3 d) })}}}) + ) (\r -> happyReturn (happyIn156 r)) + +happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_355 = happyMonadReduce 3# 140# happyReduction_355 +happyReduction_355 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> + case happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> + ( mkExport happy_var_2 (snd $ unLoc happy_var_3) (epTok happy_var_1, fst $ unLoc happy_var_3) >>= \i -> + return (sLL happy_var_1 happy_var_3 i ))}}}) + ) (\r -> happyReturn (happyIn156 r)) + +happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_356 = happySpecReduce_1 141# happyReduction_356 +happyReduction_356 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 StdCallConv + )} + +happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_357 = happySpecReduce_1 141# happyReduction_357 +happyReduction_357 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 CCallConv + )} + +happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_358 = happySpecReduce_1 141# happyReduction_358 +happyReduction_358 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 CApiConv + )} + +happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_359 = happySpecReduce_1 141# happyReduction_359 +happyReduction_359 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 PrimCallConv + )} + +happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_360 = happySpecReduce_1 141# happyReduction_360 +happyReduction_360 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn157 + (sLL happy_var_1 happy_var_1 JavaScriptCallConv + )} + +happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_361 = happySpecReduce_1 142# happyReduction_361 +happyReduction_361 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (sLL happy_var_1 happy_var_1 PlayRisky + )} + +happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_362 = happySpecReduce_1 142# happyReduction_362 +happyReduction_362 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (sLL happy_var_1 happy_var_1 PlaySafe + )} + +happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_363 = happySpecReduce_1 142# happyReduction_363 +happyReduction_363 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn158 + (sLL happy_var_1 happy_var_1 PlayInterruptible + )} + +happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_364 = happyReduce 4# 143# happyReduction_364 +happyReduction_364 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + happyIn159 + (sLL happy_var_1 happy_var_4 (epUniTok happy_var_3 + ,(L (getLoc happy_var_1) + (getStringLiteral happy_var_1), happy_var_2, happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_365 = happyReduce 4# 143# happyReduction_365 +happyReduction_365 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + happyIn159 + (sLL happy_var_1 happy_var_4 (epUniTok happy_var_3 + ,(L (getLoc happy_var_1) + (getStringMultiLiteral happy_var_1), happy_var_2, happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_366 = happySpecReduce_3 143# happyReduction_366 +happyReduction_366 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut163 happy_x_3 of { (HappyWrap163 happy_var_3) -> + happyIn159 + (sLL happy_var_1 happy_var_3 (epUniTok happy_var_2 + ,(noLoc (StringLiteral NoSourceText nilFS Nothing), happy_var_1, happy_var_3)) + )}}} + +happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_367 = happySpecReduce_0 144# happyReduction_367 +happyReduction_367 = happyIn160 + (Nothing + ) + +happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_368 = happySpecReduce_2 144# happyReduction_368 +happyReduction_368 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut169 happy_x_2 of { (HappyWrap169 happy_var_2) -> + happyIn160 + (Just (epUniTok happy_var_1, happy_var_2) + )}} + +happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_369 = happySpecReduce_0 145# happyReduction_369 +happyReduction_369 = happyIn161 + ((Nothing, Nothing) + ) + +happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_370 = happySpecReduce_2 145# happyReduction_370 +happyReduction_370 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> + happyIn161 + ((Just (epUniTok happy_var_1), Just happy_var_2) + )}} + +happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_371 = happySpecReduce_1 146# happyReduction_371 +happyReduction_371 happy_x_1 + = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + happyIn162 + (happy_var_1 + )} + +happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_372 = happyMonadReduce 3# 146# happyReduction_372 +happyReduction_372 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut194 happy_x_3 of { (HappyWrap194 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 $ mkHsImplicitSigType $ + sLLa happy_var_1 happy_var_3 $ HsKindSig (epUniTok happy_var_2) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn162 r)) + +happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_373 = happySpecReduce_1 147# happyReduction_373 +happyReduction_373 happy_x_1 + = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + happyIn163 + (hsTypeToHsSigType happy_var_1 + )} + +happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_374 = happyMonadReduce 3# 148# happyReduction_374 +happyReduction_374 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut316 happy_x_3 of { (HappyWrap316 happy_var_3) -> + ( case unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)) + (h:t) -> do + h' <- addTrailingCommaN h (gl happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)))}}}) + ) (\r -> happyReturn (happyIn164 r)) + +happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_375 = happySpecReduce_1 148# happyReduction_375 +happyReduction_375 happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + happyIn164 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_376 = happySpecReduce_1 149# happyReduction_376 +happyReduction_376 happy_x_1 + = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + happyIn165 + (sL1 happy_var_1 (unitOL happy_var_1) + )} + +happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_377 = happyMonadReduce 3# 149# happyReduction_377 +happyReduction_377 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> + ( do { st <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return $ sLL happy_var_1 happy_var_3 (unitOL st `appOL` unLoc happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn165 r)) + +happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_378 = happySpecReduce_2 150# happyReduction_378 +happyReduction_378 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn166 + (sLL happy_var_1 happy_var_2 (UnpackednessPragma (glR happy_var_1, epTok happy_var_2) (getUNPACK_PRAGs happy_var_1) SrcUnpack) + )}} + +happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_379 = happySpecReduce_2 150# happyReduction_379 +happyReduction_379 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn166 + (sLL happy_var_1 happy_var_2 (UnpackednessPragma (glR happy_var_1, epTok happy_var_2) (getNOUNPACK_PRAGs happy_var_1) SrcNoUnpack) + )}} + +happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_380 = happyMonadReduce 3# 151# happyReduction_380 +happyReduction_380 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { hintExplicitForall happy_var_1 + ; acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc $ + mkHsForAllInvisTele (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1,epTok happy_var_3) cs) happy_var_2 )) })}}}) + ) (\r -> happyReturn (happyIn167 r)) + +happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_381 = happyMonadReduce 3# 151# happyReduction_381 +happyReduction_381 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { hintExplicitForall happy_var_1 + ; req_tvbs <- fromSpecTyVarBndrs happy_var_2 + ; acs (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc $ + mkHsForAllVisTele (EpAnn (glEE happy_var_1 happy_var_3) (epUniTok happy_var_1,epUniTok happy_var_3) cs) req_tvbs )) })}}}) + ) (\r -> happyReturn (happyIn167 r)) + +happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_382 = happySpecReduce_1 152# happyReduction_382 +happyReduction_382 happy_x_1 + = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + happyIn168 + (happy_var_1 + )} + +happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_383 = happyMonadReduce 3# 152# happyReduction_383 +happyReduction_383 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut194 happy_x_3 of { (HappyWrap194 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 $ HsKindSig (epUniTok happy_var_2) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn168 r)) + +happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_384 = happySpecReduce_2 153# happyReduction_384 +happyReduction_384 happy_x_2 + happy_x_1 + = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> + case happyOut169 happy_x_2 of { (HappyWrap169 happy_var_2) -> + happyIn169 + (sLLa happy_var_1 happy_var_2 $ + HsForAllTy { hst_tele = unLoc happy_var_1 + , hst_xforall = noExtField + , hst_body = happy_var_2 } + )}} + +happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_385 = happyMonadReduce 3# 153# happyReduction_385 +happyReduction_385 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut170 happy_x_1 of { (HappyWrap170 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( acsA (comb2 happy_var_1 happy_var_3) (\loc cs -> (L loc $ + HsQualTy { hst_ctxt = addTrailingDarrowC happy_var_1 happy_var_2 cs + , hst_xqual = NoExtField + , hst_body = happy_var_3 })))}}}) + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_386 = happyMonadReduce 3# 153# happyReduction_386 +happyReduction_386 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 (HsIParamTy (epUniTok happy_var_2) (reLoc happy_var_1) happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn169 r)) + +happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_387 = happySpecReduce_1 153# happyReduction_387 +happyReduction_387 happy_x_1 + = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> + happyIn169 + (happy_var_1 + )} + +happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_388 = happyMonadReduce 1# 154# happyReduction_388 +happyReduction_388 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + ( checkContext happy_var_1)}) + ) (\r -> happyReturn (happyIn170 r)) + +happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_389 = happySpecReduce_1 155# happyReduction_389 +happyReduction_389 happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + happyIn171 + (unECP happy_var_1 >>= \ happy_var_1 -> + checkContextPV happy_var_1 + )} + +happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_390 = happySpecReduce_1 156# happyReduction_390 +happyReduction_390 happy_x_1 + = case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + happyIn172 + (happy_var_1 + )} + +happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_391 = happyMonadReduce 3# 156# happyReduction_391 +happyReduction_391 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( amsA' (sLL happy_var_1 happy_var_3 + $ HsFunTy noExtField (HsUnannotated (EpArrow (epUniTok happy_var_2))) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn172 r)) + +happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_392 = happyMonadReduce 4# 156# happyReduction_392 +happyReduction_392 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + case happyOut173 happy_x_2 of { (HappyWrap173 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut169 happy_x_4 of { (HappyWrap169 happy_var_4) -> + ( hintLinear (getLoc happy_var_2) + >> let arr = (unLoc happy_var_2) (epUniTok happy_var_3) + in amsA' (sLL happy_var_1 happy_var_4 $ HsFunTy noExtField arr happy_var_1 happy_var_4))}}}}) + ) (\r -> happyReturn (happyIn172 r)) + +happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_393 = happyMonadReduce 3# 156# happyReduction_393 +happyReduction_393 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( hintLinear (getLoc happy_var_2) >> + amsA' (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField (HsLinearAnn (EpLolly (epTok happy_var_2))) happy_var_1 happy_var_3))}}}) + ) (\r -> happyReturn (happyIn172 r)) + +happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_394 = happySpecReduce_2 157# happyReduction_394 +happyReduction_394 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn173 + (sLL happy_var_1 happy_var_2 (mkMultAnn (epTok happy_var_1) happy_var_2 . EpArrow) + )}} + +happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_395 = happySpecReduce_2 158# happyReduction_395 +happyReduction_395 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn174 + (unECP happy_var_2 >>= \ happy_var_2 -> + fmap (sLL happy_var_1 happy_var_2) (mkHsMultPV (epTok happy_var_1) happy_var_2) + )}} + +happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_396 = happyMonadReduce 1# 159# happyReduction_396 +happyReduction_396 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> + ( runPV happy_var_1)}) + ) (\r -> happyReturn (happyIn175 r)) + +happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_397 = happySpecReduce_1 160# happyReduction_397 +happyReduction_397 happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + happyIn176 + (happy_var_1 + )} + +happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_398 = happySpecReduce_3 160# happyReduction_398 +happyReduction_398 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> + case happyOut176 happy_x_3 of { (HappyWrap176 happy_var_3) -> + happyIn176 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + do { let (op, prom) = happy_var_2 + ; when (looksLikeMult happy_var_1 op happy_var_3) $ hintLinear (getLocA op) + ; mkHsOpTyPV prom happy_var_1 op happy_var_3 } + )}}} + +happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_399 = happySpecReduce_2 160# happyReduction_399 +happyReduction_399 happy_x_2 + happy_x_1 + = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> + case happyOut176 happy_x_2 of { (HappyWrap176 happy_var_2) -> + happyIn176 + (happy_var_2 >>= \ happy_var_2 -> + mkUnpackednessPV happy_var_1 happy_var_2 + )}} + +happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_400 = happySpecReduce_1 161# happyReduction_400 +happyReduction_400 happy_x_1 + = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> + happyIn177 + (mkHsAppTyHeadPV happy_var_1 + )} + +happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_401 = happySpecReduce_1 161# happyReduction_401 +happyReduction_401 happy_x_1 + = case happyOut179 happy_x_1 of { (HappyWrap179 happy_var_1) -> + happyIn177 + (failOpFewArgs (fst happy_var_1) + )} + +happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_402 = happySpecReduce_2 161# happyReduction_402 +happyReduction_402 happy_x_2 + happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + case happyOut178 happy_x_2 of { (HappyWrap178 happy_var_2) -> + happyIn177 + (happy_var_1 >>= \ happy_var_1 -> + mkHsAppTyPV happy_var_1 happy_var_2 + )}} + +happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_403 = happySpecReduce_3 161# happyReduction_403 +happyReduction_403 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> + happyIn177 + (happy_var_1 >>= \ happy_var_1 -> + mkHsAppKindTyPV happy_var_1 (epTok happy_var_2) happy_var_3 + )}}} + +happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_404 = happySpecReduce_1 162# happyReduction_404 +happyReduction_404 happy_x_1 + = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> + happyIn178 + (happy_var_1 + )} + +happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_405 = happyMonadReduce 2# 162# happyReduction_405 +happyReduction_405 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + ( addUnpackednessP happy_var_1 happy_var_2)}}) + ) (\r -> happyReturn (happyIn178 r)) + +happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_406 = happySpecReduce_1 163# happyReduction_406 +happyReduction_406 happy_x_1 + = case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> + happyIn179 + ((happy_var_1, NotPromoted) + )} + +happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_407 = happySpecReduce_1 163# happyReduction_407 +happyReduction_407 happy_x_1 + = case happyOut314 happy_x_1 of { (HappyWrap314 happy_var_1) -> + happyIn179 + ((happy_var_1, NotPromoted) + )} + +happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_408 = happyMonadReduce 2# 163# happyReduction_408 +happyReduction_408 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> + ( do { op <- amsr (sLL happy_var_1 happy_var_2 (unLoc happy_var_2)) + (NameAnnQuote (epTok happy_var_1) (gl happy_var_2) []) + ; return (op, IsPromoted) })}}) + ) (\r -> happyReturn (happyIn179 r)) + +happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_409 = happyMonadReduce 2# 163# happyReduction_409 +happyReduction_409 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut307 happy_x_2 of { (HappyWrap307 happy_var_2) -> + ( do { op <- amsr (sLL happy_var_1 happy_var_2 (unLoc happy_var_2)) + (NameAnnQuote (epTok happy_var_1) (gl happy_var_2) []) + ; return (op, IsPromoted) })}}) + ) (\r -> happyReturn (happyIn179 r)) + +happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_410 = happyMonadReduce 1# 164# happyReduction_410 +happyReduction_410 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> + ( amsA' (sL1 happy_var_1 (HsTyVar noAnn NotPromoted happy_var_1)))}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_411 = happyMonadReduce 1# 164# happyReduction_411 +happyReduction_411 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> + ( amsA' (sL1 happy_var_1 (HsTyVar noAnn NotPromoted happy_var_1)))}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_412 = happySpecReduce_1 164# happyReduction_412 +happyReduction_412 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sL1a happy_var_1 $ mkAnonWildCardTy (epTok happy_var_1) + )} + +happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_413 = happyMonadReduce 1# 164# happyReduction_413 +happyReduction_413 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( do { warnStarIsType (getLoc happy_var_1) + ; return $ sL1a happy_var_1 (HsStarTy noExtField (isUnicode happy_var_1)) })}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_414 = happyMonadReduce 2# 164# happyReduction_414 +happyReduction_414 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 (mkBangTy (glR happy_var_1) SrcLazy happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_415 = happyMonadReduce 2# 164# happyReduction_415 +happyReduction_415 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 (mkBangTy (glR happy_var_1) SrcStrict happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_416 = happyMonadReduce 3# 164# happyReduction_416 +happyReduction_416 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { decls <- amsA' (sLL happy_var_1 happy_var_3 $ XHsType $ HsRecTy (AnnList (listAsAnchorM happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) [] noAnn []) happy_var_2) + ; checkRecordSyntax decls })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_417 = happyMonadReduce 2# 164# happyReduction_417 +happyReduction_417 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsA' . sLL happy_var_1 happy_var_2 =<< (mkTupleSyntaxTy (epTok happy_var_1) [] (epTok happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_418 = happyMonadReduce 5# 164# happyReduction_418 +happyReduction_418 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut184 happy_x_4 of { (HappyWrap184 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( do { h <- addTrailingCommaA happy_var_2 (epTok happy_var_3) + ; amsA' . sLL happy_var_1 happy_var_5 =<< (mkTupleSyntaxTy (epTok happy_var_1) (h : happy_var_4) (epTok happy_var_5)) })}}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_419 = happyMonadReduce 2# 164# happyReduction_419 +happyReduction_419 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( do { requireLTPuns PEP_TupleSyntaxType happy_var_1 happy_var_2 + ; amsA' (sLL happy_var_1 happy_var_2 $ HsTupleTy (AnnParensHash (epTok happy_var_1) (epTok happy_var_2)) HsUnboxedTuple []) })}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_420 = happyMonadReduce 3# 164# happyReduction_420 +happyReduction_420 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut184 happy_x_2 of { (HappyWrap184 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_TupleSyntaxType happy_var_1 happy_var_3 + ; amsA' (sLL happy_var_1 happy_var_3 $ HsTupleTy (AnnParensHash (epTok happy_var_1) (epTok happy_var_3)) HsUnboxedTuple happy_var_2) })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_421 = happyMonadReduce 3# 164# happyReduction_421 +happyReduction_421 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut185 happy_x_2 of { (HappyWrap185 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_SumSyntaxType happy_var_1 happy_var_3 + ; amsA' (sLL happy_var_1 happy_var_3 $ HsSumTy (AnnParensHash (epTok happy_var_1) (epTok happy_var_3)) happy_var_2) })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_422 = happyMonadReduce 3# 164# happyReduction_422 +happyReduction_422 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' . sLL happy_var_1 happy_var_3 =<< (mkListSyntaxTy1 (epTok happy_var_1) happy_var_2 (epTok happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_423 = happyMonadReduce 3# 164# happyReduction_423 +happyReduction_423 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ HsParTy (epTok happy_var_1, epTok happy_var_3) happy_var_2))}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_424 = happyMonadReduce 3# 164# happyReduction_424 +happyReduction_424 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 happy_var_3 + ; amsA' (sLL happy_var_1 happy_var_3 $ HsExplicitTupleTy (epTok happy_var_1,epTok happy_var_2,epTok happy_var_3) IsPromoted []) })}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_425 = happyMonadReduce 2# 164# happyReduction_425 +happyReduction_425 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut287 happy_x_2 of { (HappyWrap287 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 $ HsTyVar (epTok happy_var_1) IsPromoted happy_var_2))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_426 = happyMonadReduce 2# 164# happyReduction_426 +happyReduction_426 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut291 happy_x_2 of { (HappyWrap291 happy_var_2) -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 (reLoc happy_var_2) + ; amsA' (sLL happy_var_1 happy_var_2 $ HsTyVar (epTok happy_var_1) IsPromoted (L (getLoc happy_var_2) $ nameRdrName (dataConName (unLoc happy_var_2)))) })}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_427 = happyMonadReduce 6# 164# happyReduction_427 +happyReduction_427 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut184 happy_x_5 of { (HappyWrap184 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 happy_var_6 + ; h <- addTrailingCommaA happy_var_3 (epTok happy_var_4) + ; amsA' (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy (epTok happy_var_1,epTok happy_var_2,epTok happy_var_6) IsPromoted (h : happy_var_5)) })}}}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_428 = happyMonadReduce 2# 164# happyReduction_428 +happyReduction_428 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( withCombinedComments happy_var_1 happy_var_2 (mkListSyntaxTy0 (epTok happy_var_1) (epTok happy_var_2)))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_429 = happyMonadReduce 4# 164# happyReduction_429 +happyReduction_429 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { requireLTPuns PEP_QuoteDisambiguation happy_var_1 happy_var_4 + ; amsA' (sLL happy_var_1 happy_var_4 $ HsExplicitListTy (epTok happy_var_1, epTok happy_var_2, epTok happy_var_4) IsPromoted happy_var_3) })}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_430 = happyMonadReduce 2# 164# happyReduction_430 +happyReduction_430 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> + ( amsA' (sLL happy_var_1 happy_var_2 $ HsTyVar (epTok happy_var_1) IsPromoted happy_var_2))}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_431 = happySpecReduce_1 164# happyReduction_431 +happyReduction_431 happy_x_1 + = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> + happyIn180 + (mapLocA (HsSpliceTy noExtField) happy_var_1 + )} + +happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_432 = happySpecReduce_1 164# happyReduction_432 +happyReduction_432 happy_x_1 + = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> + happyIn180 + (mapLocA (HsSpliceTy noExtField) happy_var_1 + )} + +happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_433 = happyMonadReduce 5# 164# happyReduction_433 +happyReduction_433 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut184 happy_x_4 of { (HappyWrap184 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( do { h <- addTrailingCommaA happy_var_2 (epTok happy_var_3) + ; amsA' (sLL happy_var_1 happy_var_5 $ HsExplicitListTy (NoEpTok,epTok happy_var_1,epTok happy_var_5) NotPromoted (h:happy_var_4)) })}}}}}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_434 = happySpecReduce_1 164# happyReduction_434 +happyReduction_434 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) + (il_value (getINTEGER happy_var_1)) + )} + +happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_435 = happySpecReduce_1 164# happyReduction_435 +happyReduction_435 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsCharTy (getCHARs happy_var_1) + (getCHAR happy_var_1) + )} + +happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_436 = happySpecReduce_1 164# happyReduction_436 +happyReduction_436 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) + (getSTRING happy_var_1) + )} + +happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_437 = happySpecReduce_1 164# happyReduction_437 +happyReduction_437 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn180 + (sLLa happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGMULTIs happy_var_1) + (getSTRINGMULTI happy_var_1) + )} + +happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_438 = happyMonadReduce 1# 164# happyReduction_438 +happyReduction_438 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( let qname = mkQual tvName (getQVARID happy_var_1) + in amsA' (sL1 happy_var_1 (HsTyVar noAnn NotPromoted (sL1n happy_var_1 $ qname))))}) + ) (\r -> happyReturn (happyIn180 r)) + +happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_439 = happySpecReduce_1 165# happyReduction_439 +happyReduction_439 happy_x_1 + = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> + happyIn181 + (happy_var_1 + )} + +happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_440 = happySpecReduce_1 166# happyReduction_440 +happyReduction_440 happy_x_1 + = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> + happyIn182 + ([happy_var_1] + )} + +happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_441 = happyMonadReduce 3# 166# happyReduction_441 +happyReduction_441 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut182 happy_x_3 of { (HappyWrap182 happy_var_3) -> + ( do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn182 r)) + +happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_442 = happySpecReduce_1 167# happyReduction_442 +happyReduction_442 happy_x_1 + = case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> + happyIn183 + (happy_var_1 + )} + +happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_443 = happySpecReduce_0 167# happyReduction_443 +happyReduction_443 = happyIn183 + ([] + ) + +happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_444 = happySpecReduce_1 168# happyReduction_444 +happyReduction_444 happy_x_1 + = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + happyIn184 + ([happy_var_1] + )} + +happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_445 = happyMonadReduce 3# 168# happyReduction_445 +happyReduction_445 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut184 happy_x_3 of { (HappyWrap184 happy_var_3) -> + ( do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn184 r)) + +happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_446 = happyMonadReduce 3# 169# happyReduction_446 +happyReduction_446 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> + ( do { h <- addTrailingVbarA happy_var_1 (epTok happy_var_2) + ; return [h,happy_var_3] })}}}) + ) (\r -> happyReturn (happyIn185 r)) + +happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_447 = happyMonadReduce 3# 169# happyReduction_447 +happyReduction_447 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut185 happy_x_3 of { (HappyWrap185 happy_var_3) -> + ( do { h <- addTrailingVbarA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn185 r)) + +happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_448 = happySpecReduce_2 170# happyReduction_448 +happyReduction_448 happy_x_2 + happy_x_1 + = case happyOut187 happy_x_1 of { (HappyWrap187 happy_var_1) -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + happyIn186 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_449 = happySpecReduce_0 170# happyReduction_449 +happyReduction_449 = happyIn186 + ([] + ) + +happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_450 = happySpecReduce_1 171# happyReduction_450 +happyReduction_450 happy_x_1 + = case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> + happyIn187 + (happy_var_1 + )} + +happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_451 = happyMonadReduce 3# 171# happyReduction_451 +happyReduction_451 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 + (HsTvb { tvb_ext = AnnTyVarBndr [glR happy_var_1] [glR happy_var_3] noAnn noAnn + , tvb_flag = InferredSpec + , tvb_var = HsBndrVar noExtField happy_var_2 + , tvb_kind = HsBndrNoKind noExtField })))}}}) + ) (\r -> happyReturn (happyIn187 r)) + +happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_452 = happyMonadReduce 5# 171# happyReduction_452 +happyReduction_452 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut194 happy_x_4 of { (HappyWrap194 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 + (HsTvb { tvb_ext = AnnTyVarBndr [glR happy_var_1] [glR happy_var_5] noAnn (epUniTok happy_var_3) + , tvb_flag = InferredSpec + , tvb_var = HsBndrVar noExtField happy_var_2 + , tvb_kind = HsBndrKind noExtField happy_var_4 })))}}}}}) + ) (\r -> happyReturn (happyIn187 r)) + +happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_453 = happyMonadReduce 1# 172# happyReduction_453 +happyReduction_453 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut189 happy_x_1 of { (HappyWrap189 happy_var_1) -> + ( amsA' (sL1 happy_var_1 + (HsTvb { tvb_ext = noAnn + , tvb_flag = SpecifiedSpec + , tvb_var = unLoc happy_var_1 + , tvb_kind = HsBndrNoKind noExtField })))}) + ) (\r -> happyReturn (happyIn188 r)) + +happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_454 = happyMonadReduce 5# 172# happyReduction_454 +happyReduction_454 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut189 happy_x_2 of { (HappyWrap189 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut194 happy_x_4 of { (HappyWrap194 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + ( amsA' (sLL happy_var_1 happy_var_5 + (HsTvb { tvb_ext = AnnTyVarBndr [glR happy_var_1] [glR happy_var_5] noAnn (epUniTok happy_var_3) + , tvb_flag = SpecifiedSpec + , tvb_var = unLoc happy_var_2 + , tvb_kind = HsBndrKind noExtField happy_var_4 })))}}}}}) + ) (\r -> happyReturn (happyIn188 r)) + +happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_455 = happySpecReduce_1 173# happyReduction_455 +happyReduction_455 happy_x_1 + = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> + happyIn189 + (sL1 happy_var_1 (HsBndrVar noExtField happy_var_1) + )} + +happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_456 = happySpecReduce_1 173# happyReduction_456 +happyReduction_456 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn189 + (sL1 happy_var_1 (HsBndrWildCard (epTok happy_var_1)) + )} + +happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_457 = happySpecReduce_0 174# happyReduction_457 +happyReduction_457 = happyIn190 + (noLoc (NoEpTok,[]) + ) + +happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_458 = happySpecReduce_2 174# happyReduction_458 +happyReduction_458 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut191 happy_x_2 of { (HappyWrap191 happy_var_2) -> + happyIn190 + ((sLL happy_var_1 happy_var_2 (epTok happy_var_1 ,reverse (unLoc happy_var_2))) + )}} + +happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_459 = happyMonadReduce 3# 175# happyReduction_459 +happyReduction_459 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut191 happy_x_1 of { (HappyWrap191 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut192 happy_x_3 of { (HappyWrap192 happy_var_3) -> + ( + do { let (h:t) = unLoc happy_var_1 -- Safe from fds1 rules + ; h' <- addTrailingCommaA h (epTok happy_var_2) + ; return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}}) + ) (\r -> happyReturn (happyIn191 r)) + +happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_460 = happySpecReduce_1 175# happyReduction_460 +happyReduction_460 happy_x_1 + = case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> + happyIn191 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_461 = happyMonadReduce 3# 176# happyReduction_461 +happyReduction_461 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut193 happy_x_3 of { (HappyWrap193 happy_var_3) -> + ( amsA' (L (comb3 happy_var_1 happy_var_2 happy_var_3) + (FunDep (epUniTok happy_var_2) + (reverse (unLoc happy_var_1)) + (reverse (unLoc happy_var_3)))))}}}) + ) (\r -> happyReturn (happyIn192 r)) + +happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_462 = happySpecReduce_0 177# happyReduction_462 +happyReduction_462 = happyIn193 + (noLoc [] + ) + +happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_463 = happySpecReduce_2 177# happyReduction_463 +happyReduction_463 happy_x_2 + happy_x_1 + = case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + happyIn193 + (sLL happy_var_1 happy_var_2 (happy_var_2 : (unLoc happy_var_1)) + )}} + +happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_464 = happySpecReduce_1 178# happyReduction_464 +happyReduction_464 happy_x_1 + = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> + happyIn194 + (happy_var_1 + )} + +happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_465 = happyMonadReduce 4# 179# happyReduction_465 +happyReduction_465 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( checkEmptyGADTs $ + L (comb2 happy_var_1 happy_var_4) + ((epTok happy_var_1 + ,epTok happy_var_2 + ,epTok happy_var_4) + , unLoc happy_var_3))}}}}) + ) (\r -> happyReturn (happyIn195 r)) + +happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_466 = happyMonadReduce 4# 179# happyReduction_466 +happyReduction_466 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> + ( checkEmptyGADTs $ + L (comb2 happy_var_1 happy_var_3) + ((epTok happy_var_1, NoEpTok, NoEpTok) + , unLoc happy_var_3))}}) + ) (\r -> happyReturn (happyIn195 r)) + +happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_467 = happySpecReduce_0 179# happyReduction_467 +happyReduction_467 = happyIn195 + (noLoc (noAnn,[]) + ) + +happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_468 = happyMonadReduce 3# 180# happyReduction_468 +happyReduction_468 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut196 happy_x_3 of { (HappyWrap196 happy_var_3) -> + ( do { h <- addTrailingSemiA happy_var_1 (epTok happy_var_2) + ; return (L (comb2 happy_var_1 happy_var_3) (h : unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn196 r)) + +happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_469 = happySpecReduce_1 180# happyReduction_469 +happyReduction_469 happy_x_1 + = case happyOut197 happy_x_1 of { (HappyWrap197 happy_var_1) -> + happyIn196 + (L (glA happy_var_1) [happy_var_1] + )} + +happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_470 = happySpecReduce_0 180# happyReduction_470 +happyReduction_470 = happyIn196 + (noLoc [] + ) + +happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_471 = happyMonadReduce 4# 181# happyReduction_471 +happyReduction_471 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut163 happy_x_4 of { (HappyWrap163 happy_var_4) -> + ( mkGadtDecl (comb2 happy_var_2 happy_var_4) (unLoc happy_var_2) (epUniTok happy_var_3) happy_var_4)}}}) + ) (\r -> happyReturn (happyIn197 r)) + +happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_472 = happySpecReduce_2 182# happyReduction_472 +happyReduction_472 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut199 happy_x_2 of { (HappyWrap199 happy_var_2) -> + happyIn198 + (sLL happy_var_1 happy_var_2 (epTok happy_var_1,unLoc happy_var_2) + )}} + +happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_473 = happyMonadReduce 3# 183# happyReduction_473 +happyReduction_473 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut199 happy_x_1 of { (HappyWrap199 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut200 happy_x_3 of { (HappyWrap200 happy_var_3) -> + ( do { let (h:t) = unLoc happy_var_1 + ; h' <- addTrailingVbarA h (epTok happy_var_2) + ; return (sLL happy_var_1 happy_var_3 (happy_var_3 : h' : t)) })}}}) + ) (\r -> happyReturn (happyIn199 r)) + +happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_474 = happySpecReduce_1 183# happyReduction_474 +happyReduction_474 happy_x_1 + = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> + happyIn199 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_475 = happyMonadReduce 4# 184# happyReduction_475 +happyReduction_475 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> + case happyOut170 happy_x_2 of { (HappyWrap170 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut202 happy_x_4 of { (HappyWrap202 happy_var_4) -> + ( amsA' (let (con,details) = unLoc happy_var_4 in + (L (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) (mkConDeclH98 + (epUniTok happy_var_3,(fst $ unLoc happy_var_1)) + con + (snd $ unLoc happy_var_1) + (Just happy_var_2) + details))))}}}}) + ) (\r -> happyReturn (happyIn200 r)) + +happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_476 = happyMonadReduce 2# 184# happyReduction_476 +happyReduction_476 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> + case happyOut202 happy_x_2 of { (HappyWrap202 happy_var_2) -> + ( amsA' (let (con,details) = unLoc happy_var_2 in + (L (comb2 happy_var_1 happy_var_2) (mkConDeclH98 (noAnn, fst $ unLoc happy_var_1) + con + (snd $ unLoc happy_var_1) + Nothing -- No context + details))))}}) + ) (\r -> happyReturn (happyIn200 r)) + +happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_477 = happySpecReduce_3 185# happyReduction_477 +happyReduction_477 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut186 happy_x_2 of { (HappyWrap186 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn201 + (sLL happy_var_1 happy_var_3 ((epUniTok happy_var_1,epTok happy_var_3), Just happy_var_2) + )}}} + +happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_478 = happySpecReduce_0 185# happyReduction_478 +happyReduction_478 = happyIn201 + (noLoc (noAnn, Nothing) + ) + +happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_479 = happyMonadReduce 1# 186# happyReduction_479 +happyReduction_479 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> + ( do { b <- runPV happy_var_1 + ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) })}) + ) (\r -> happyReturn (happyIn202 r)) + +happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_480 = happyMonadReduce 3# 186# happyReduction_480 +happyReduction_480 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let (t, tag, arity) = happy_var_2 in pure (sLL happy_var_1 happy_var_3 $ mkUnboxedSumCon t tag arity))}}}) + ) (\r -> happyReturn (happyIn202 r)) + +happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_481 = happySpecReduce_2 187# happyReduction_481 +happyReduction_481 happy_x_2 + happy_x_1 + = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> + case happyOut337 happy_x_2 of { (HappyWrap337 happy_var_2) -> + happyIn203 + ((happy_var_1, 1, (snd happy_var_2 + 1)) + )}} + +happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_482 = happySpecReduce_3 187# happyReduction_482 +happyReduction_482 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOut336 happy_x_3 of { (HappyWrap336 happy_var_3) -> + happyIn203 + ((happy_var_2, snd happy_var_1 + 1, snd happy_var_1 + snd happy_var_3 + 1) + )}}} + +happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_483 = happySpecReduce_0 188# happyReduction_483 +happyReduction_483 = happyIn204 + ([] + ) + +happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_484 = happySpecReduce_1 188# happyReduction_484 +happyReduction_484 happy_x_1 + = case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> + happyIn204 + (happy_var_1 + )} + +happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_485 = happyMonadReduce 3# 189# happyReduction_485 +happyReduction_485 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut205 happy_x_3 of { (HappyWrap205 happy_var_3) -> + ( do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn205 r)) + +happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_486 = happySpecReduce_1 189# happyReduction_486 +happyReduction_486 happy_x_1 + = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> + happyIn205 + ([happy_var_1] + )} + +happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_487 = happyMonadReduce 3# 190# happyReduction_487 +happyReduction_487 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + ( amsA' (L (comb2 happy_var_1 happy_var_3) + (HsConDeclRecField noExtField + (reverse (map (\ln@(L l n) + -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc happy_var_1))) + (mkConDeclField (HsUnannotated (EpColon (epUniTok happy_var_2))) happy_var_3))))}}}) + ) (\r -> happyReturn (happyIn206 r)) + +happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_488 = happyMonadReduce 5# 190# happyReduction_488 +happyReduction_488 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut169 happy_x_5 of { (HappyWrap169 happy_var_5) -> + ( amsA' (L (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_5) + (HsConDeclRecField noExtField + (reverse (map (\ln@(L l n) + -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc happy_var_1))) + (mkMultField (epTok happy_var_2) happy_var_3 (epUniTok happy_var_4) happy_var_5))))}}}}}) + ) (\r -> happyReturn (happyIn206 r)) + +happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_489 = happySpecReduce_0 191# happyReduction_489 +happyReduction_489 = happyIn207 + (noLoc [] + ) + +happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_490 = happySpecReduce_1 191# happyReduction_490 +happyReduction_490 happy_x_1 + = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> + happyIn207 + (happy_var_1 + )} + +happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_491 = happySpecReduce_2 192# happyReduction_491 +happyReduction_491 happy_x_2 + happy_x_1 + = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> + case happyOut209 happy_x_2 of { (HappyWrap209 happy_var_2) -> + happyIn208 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + )}} + +happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_492 = happySpecReduce_1 192# happyReduction_492 +happyReduction_492 happy_x_1 + = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> + happyIn208 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_493 = happyMonadReduce 2# 193# happyReduction_493 +happyReduction_493 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> + ( let { full_loc = comb2 happy_var_1 happy_var_2 } + in amsA' (L full_loc $ HsDerivingClause (epTok happy_var_1) Nothing happy_var_2))}}) + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_494 = happyMonadReduce 3# 193# happyReduction_494 +happyReduction_494 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut90 happy_x_2 of { (HappyWrap90 happy_var_2) -> + case happyOut210 happy_x_3 of { (HappyWrap210 happy_var_3) -> + ( let { full_loc = comb2 happy_var_1 happy_var_3 } + in amsA' (L full_loc $ HsDerivingClause (epTok happy_var_1) (Just happy_var_2) happy_var_3))}}}) + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_495 = happyMonadReduce 3# 193# happyReduction_495 +happyReduction_495 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut210 happy_x_2 of { (HappyWrap210 happy_var_2) -> + case happyOut91 happy_x_3 of { (HappyWrap91 happy_var_3) -> + ( let { full_loc = comb2 happy_var_1 happy_var_3 } + in amsA' (L full_loc $ HsDerivingClause (epTok happy_var_1) (Just happy_var_3) happy_var_2))}}}) + ) (\r -> happyReturn (happyIn209 r)) + +happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_496 = happySpecReduce_1 194# happyReduction_496 +happyReduction_496 happy_x_1 + = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + happyIn210 + (let { tc = sL1a happy_var_1 $ mkHsImplicitSigType $ + sL1a happy_var_1 $ HsTyVar noAnn NotPromoted happy_var_1 } in + sL1a happy_var_1 (DctSingle noExtField tc) + )} + +happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_497 = happyMonadReduce 2# 194# happyReduction_497 +happyReduction_497 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 (DctMulti noExtField [])) + (AnnContext Nothing [epTok happy_var_1] [epTok happy_var_2]))}}) + ) (\r -> happyReturn (happyIn210 r)) + +happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_498 = happyMonadReduce 3# 194# happyReduction_498 +happyReduction_498 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (DctMulti noExtField happy_var_2)) + (AnnContext Nothing [epTok happy_var_1] [epTok happy_var_3]))}}}) + ) (\r -> happyReturn (happyIn210 r)) + +happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_499 = happySpecReduce_1 195# happyReduction_499 +happyReduction_499 happy_x_1 + = case happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> + happyIn211 + (happy_var_1 + )} + +happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_500 = happyMonadReduce 3# 195# happyReduction_500 +happyReduction_500 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut160 happy_x_2 of { (HappyWrap160 happy_var_2) -> + case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + do { let { l = comb2 happy_var_1 happy_var_3 } + ; r <- checkValDef l happy_var_1 (HsUnannotated EpPatBind, happy_var_2) happy_var_3; + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + ; !cs <- getCommentsFor l + ; return $! (sL (commentsA l cs) $ ValD noExtField r) })}}}) + ) (\r -> happyReturn (happyIn211 r)) + +happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_501 = happyMonadReduce 5# 195# happyReduction_501 +happyReduction_501 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> + case happyOut160 happy_x_4 of { (HappyWrap160 happy_var_4) -> + case happyOut213 happy_x_5 of { (HappyWrap213 happy_var_5) -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + do { let { l = comb2 happy_var_1 happy_var_5 } + ; r <- checkValDef l happy_var_3 (mkMultAnn (epTok happy_var_1) happy_var_2 EpPatBind, happy_var_4) happy_var_5; + -- parses bindings of the form %p x or + -- %p x :: sig + -- + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + ; !cs <- getCommentsFor l + ; return $! (sL (commentsA l cs) $ ValD noExtField r) })}}}}}) + ) (\r -> happyReturn (happyIn211 r)) + +happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_502 = happySpecReduce_1 195# happyReduction_502 +happyReduction_502 happy_x_1 + = case happyOut119 happy_x_1 of { (HappyWrap119 happy_var_1) -> + happyIn211 + (happy_var_1 + )} + +happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_503 = happySpecReduce_1 196# happyReduction_503 +happyReduction_503 happy_x_1 + = case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> + happyIn212 + (happy_var_1 + )} + +happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_504 = happySpecReduce_1 196# happyReduction_504 +happyReduction_504 happy_x_1 + = case happyOut234 happy_x_1 of { (HappyWrap234 happy_var_1) -> + happyIn212 + (mkSpliceDecl happy_var_1 + )} + +happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_505 = happyMonadReduce 3# 197# happyReduction_505 +happyReduction_505 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOut137 happy_x_3 of { (HappyWrap137 happy_var_3) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + do { let L l (bs, csw) = adaptWhereBinds happy_var_3 + ; let loc = (comb3 happy_var_1 happy_var_2 (L l bs)) + ; let locg = (comb2 happy_var_1 happy_var_2) + ; acs loc (\loc cs -> + sL loc (GRHSs csw (unguardedRHS (EpAnn (spanAsAnchor locg) (GrhsAnn Nothing (Left $ epTok happy_var_1)) cs) locg happy_var_2) + bs)) })}}}) + ) (\r -> happyReturn (happyIn213 r)) + +happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_506 = happyMonadReduce 2# 197# happyReduction_506 +happyReduction_506 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> + case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> + ( do { let {L l (bs, csw) = adaptWhereBinds happy_var_2} + ; acs (comb2 happy_var_1 (L l bs)) (\loc cs -> L loc + (GRHSs (cs Semi.<> csw) (NE.reverse (unLoc happy_var_1)) bs)) })}}) + ) (\r -> happyReturn (happyIn213 r)) + +happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_507 = happySpecReduce_2 198# happyReduction_507 +happyReduction_507 happy_x_2 + happy_x_1 + = case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> + case happyOut215 happy_x_2 of { (HappyWrap215 happy_var_2) -> + happyIn214 + (sLL happy_var_1 happy_var_2 (happy_var_2 NE.<| unLoc happy_var_1) + )}} + +happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_508 = happySpecReduce_1 198# happyReduction_508 +happyReduction_508 happy_x_1 + = case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> + happyIn214 + (sL1 happy_var_1 (NE.singleton happy_var_1) + )} + +happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_509 = happyMonadReduce 4# 199# happyReduction_509 +happyReduction_509 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + acsA (comb2 happy_var_1 happy_var_4) (\loc cs -> L loc $ GRHS (EpAnn (glEE happy_var_1 happy_var_4) (GrhsAnn (Just $ epTok happy_var_1) (Left $ epTok happy_var_3)) cs) (unLoc happy_var_2) happy_var_4))}}}}) + ) (\r -> happyReturn (happyIn215 r)) + +happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_510 = happyMonadReduce 3# 200# happyReduction_510 +happyReduction_510 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut163 happy_x_3 of { (HappyWrap163 happy_var_3) -> + ( do { happy_var_1 <- runPV (unECP happy_var_1) + ; v <- checkValSigLhs happy_var_1 + ; amsA' (sLL happy_var_1 happy_var_3 $ SigD noExtField $ + TypeSig (AnnSig (epUniTok happy_var_2) Nothing Nothing) [v] (mkHsWildCardBndrs happy_var_3))})}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_511 = happyMonadReduce 5# 200# happyReduction_511 +happyReduction_511 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut163 happy_x_5 of { (HappyWrap163 happy_var_5) -> + ( do { v <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; let sig = TypeSig (AnnSig (epUniTok happy_var_4) Nothing Nothing) (v : reverse (unLoc happy_var_3)) + (mkHsWildCardBndrs happy_var_5) + ; amsA' (sLL happy_var_1 happy_var_5 $ SigD noExtField sig ) })}}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_512 = happyMonadReduce 4# 200# happyReduction_512 +happyReduction_512 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut75 happy_x_1 of { (HappyWrap75 happy_var_1) -> + case happyOut74 happy_x_2 of { (HappyWrap74 happy_var_2) -> + case happyOut150 happy_x_3 of { (HappyWrap150 happy_var_3) -> + case happyOut76 happy_x_4 of { (HappyWrap76 happy_var_4) -> + ( do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 happy_var_4 + ; pure (glR l2) }) + happy_var_2 + ; let (fixText, fixPrec) = case happy_var_2 of + -- If an explicit precedence isn't supplied, + -- it defaults to maxPrecedence + Nothing -> (NoSourceText, maxPrecedence) + Just l2 -> (fst $ unLoc l2, snd $ unLoc l2) + ; amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField + (FixSig ((glR happy_var_1, mbPrecAnn), fixText) (FixitySig (unLoc happy_var_3) (fromOL $ unLoc happy_var_4) + (Fixity fixPrec (unLoc happy_var_1))))) + })}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_513 = happySpecReduce_1 200# happyReduction_513 +happyReduction_513 happy_x_1 + = case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> + happyIn216 + (L (getLoc happy_var_1) . SigD noExtField . unLoc $ happy_var_1 + )} + +happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_514 = happyMonadReduce 4# 200# happyReduction_514 +happyReduction_514 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut290 happy_x_2 of { (HappyWrap290 happy_var_2) -> + case happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( let (dcolon, tc) = happy_var_3 + in amsA' (sLL happy_var_1 happy_var_4 + (SigD noExtField (CompleteMatchSig ((glR happy_var_1,dcolon,epTok happy_var_4), (getCOMPLETE_PRAGs happy_var_1)) happy_var_2 tc))))}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_515 = happyMonadReduce 4# 200# happyReduction_515 +happyReduction_515 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> + case happyOut125 happy_x_3 of { (HappyWrap125 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField (InlineSig (glR happy_var_1, epTok happy_var_4, fst happy_var_2) happy_var_3 + (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) + (snd happy_var_2)))))}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_516 = happyMonadReduce 3# 200# happyReduction_516 +happyReduction_516 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ SigD noExtField (InlineSig (glR happy_var_1, epTok happy_var_3, noAnn) happy_var_2 + (mkOpaquePragma (getOPAQUE_PRAGs happy_var_1)))))}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_517 = happyMonadReduce 3# 200# happyReduction_517 +happyReduction_517 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 (SigD noExtField (SCCFunSig ((glR happy_var_1, epTok happy_var_3), (getSCC_PRAGs happy_var_1)) happy_var_2 Nothing))))}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_518 = happyMonadReduce 4# 200# happyReduction_518 +happyReduction_518 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( do { scc <- getSCC happy_var_3 + ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc Nothing + ; amsA' (sLL happy_var_1 happy_var_4 (SigD noExtField (SCCFunSig ((glR happy_var_1, epTok happy_var_4), (getSCC_PRAGs happy_var_1)) happy_var_2 (Just ( sL1a happy_var_3 str_lit))))) })}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_519 = happyMonadReduce 6# 200# happyReduction_519 +happyReduction_519 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> + case happyOut143 happy_x_3 of { (HappyWrap143 happy_var_3) -> + case happyOut224 happy_x_4 of { (HappyWrap224 happy_var_4) -> + case happyOut217 happy_x_5 of { (HappyWrap217 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> do + let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) + (NoUserInlinePrag, FunLike) + (snd happy_var_2) + spec <- mkSpecSig inl_prag (AnnSpecSig (glR happy_var_1) (epTok happy_var_6) Nothing (fst happy_var_2)) happy_var_3 happy_var_4 happy_var_5 + amsA' $ sLL happy_var_1 happy_var_6 $ SigD noExtField spec)}}}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_520 = happyMonadReduce 6# 200# happyReduction_520 +happyReduction_520 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut218 happy_x_2 of { (HappyWrap218 happy_var_2) -> + case happyOut143 happy_x_3 of { (HappyWrap143 happy_var_3) -> + case happyOut224 happy_x_4 of { (HappyWrap224 happy_var_4) -> + case happyOut217 happy_x_5 of { (HappyWrap217 happy_var_5) -> + case happyOutTok happy_x_6 of { happy_var_6 -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> do + let inl_prag = mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) + (getSPEC_INLINE happy_var_1) + (snd happy_var_2) + spec <- mkSpecSig inl_prag (AnnSpecSig (glR happy_var_1) (epTok happy_var_6) Nothing (fst happy_var_2)) happy_var_3 happy_var_4 happy_var_5 + amsA' $ sLL happy_var_1 happy_var_6 $ SigD noExtField spec)}}}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_521 = happyMonadReduce 4# 200# happyReduction_521 +happyReduction_521 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut181 happy_x_3 of { (HappyWrap181 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( amsA' (sLL happy_var_1 happy_var_4 $ SigD noExtField (SpecInstSig ((glR happy_var_1,epTok happy_var_2,epTok happy_var_4), (getSPEC_PRAGs happy_var_1)) happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_522 = happyMonadReduce 3# 200# happyReduction_522 +happyReduction_522 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut279 happy_x_2 of { (HappyWrap279 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsA' (sLL happy_var_1 happy_var_3 $ SigD noExtField (MinimalSig ((glR happy_var_1,epTok happy_var_3), (getMINIMAL_PRAGs happy_var_1)) happy_var_2)))}}}) + ) (\r -> happyReturn (happyIn216 r)) + +happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_523 = happySpecReduce_2 201# happyReduction_523 +happyReduction_523 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut165 happy_x_2 of { (HappyWrap165 happy_var_2) -> + happyIn217 + (Just (sLL happy_var_1 happy_var_2 (epUniTok happy_var_1, unLoc happy_var_2)) + )}} + +happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_524 = happySpecReduce_0 201# happyReduction_524 +happyReduction_524 = happyIn217 + (Nothing + ) + +happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_525 = happySpecReduce_0 202# happyReduction_525 +happyReduction_525 = happyIn218 + ((noAnn ,Nothing) + ) + +happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_526 = happySpecReduce_1 202# happyReduction_526 +happyReduction_526 happy_x_1 + = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> + happyIn218 + ((fst happy_var_1,Just (snd happy_var_1)) + )} + +happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_527 = happySpecReduce_3 203# happyReduction_527 +happyReduction_527 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn219 + ((ActivationAnn (epTok happy_var_1) (epTok happy_var_3) Nothing (Just (glR happy_var_2)) + ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) + )}}} + +happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_528 = happyReduce 4# 203# happyReduction_528 +happyReduction_528 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut141 happy_x_2 of { (HappyWrap141 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn219 + ((ActivationAnn (epTok happy_var_1) (epTok happy_var_4) happy_var_2 (Just (glR happy_var_3)) + ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) + ) `HappyStk` happyRest}}}} + +happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_529 = happySpecReduce_1 204# happyReduction_529 +happyReduction_529 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn220 + (let { loc = getLoc happy_var_1 + ; ITquasiQuote (quoter, quoterSpan, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = L (noAnnSrcSpan (mkSrcSpanPs quoterSpan)) (mkUnqual varName quoter) } + in sL1 happy_var_1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) + )} + +happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_530 = happySpecReduce_1 204# happyReduction_530 +happyReduction_530 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn220 + (let { loc = getLoc happy_var_1 + ; ITqQuasiQuote (qual, quoter, quoterSpan, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = L (noAnnSrcSpan (mkSrcSpanPs quoterSpan)) (mkQual varName (qual, quoter)) } + in sL1 happy_var_1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) + )} + +happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_531 = happySpecReduce_1 205# happyReduction_531 +happyReduction_531 happy_x_1 + = case happyOut340 happy_x_1 of { (HappyWrap340 happy_var_1) -> + happyIn221 + (happy_var_1 + )} + +happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_532 = happySpecReduce_1 206# happyReduction_532 +happyReduction_532 happy_x_1 + = case happyOut341 happy_x_1 of { (HappyWrap341 happy_var_1) -> + happyIn222 + (happy_var_1 + )} + +happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_533 = happySpecReduce_1 207# happyReduction_533 +happyReduction_533 happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + happyIn223 + (happy_var_1 + )} + +happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_534 = happySpecReduce_3 207# happyReduction_534 +happyReduction_534 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut223 happy_x_3 of { (HappyWrap223 happy_var_3) -> + happyIn223 + (ECP $ + withArrowParsingMode' $ \mode -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + let arr = HsUnannotated (EpArrow (epUniTok happy_var_2)) + in mkHsArrowPV (comb2 happy_var_1 happy_var_3) mode happy_var_1 arr happy_var_3 + )}}} + +happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_535 = happyReduce 4# 207# happyReduction_535 +happyReduction_535 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut223 happy_x_4 of { (HappyWrap223 happy_var_4) -> + happyIn223 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_2 >>= \ happy_var_2 -> + unECP happy_var_4 >>= \ happy_var_4 -> + hintLinear (getLoc happy_var_2) >> + let arr = (unLoc happy_var_2) (epUniTok happy_var_3) + in mkHsArrowPV (comb2 happy_var_1 happy_var_4) ArrowIsFunType happy_var_1 arr happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_536 = happySpecReduce_3 207# happyReduction_536 +happyReduction_536 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut223 happy_x_3 of { (HappyWrap223 happy_var_3) -> + happyIn223 + (ECP $ + hintLinear (getLoc happy_var_2) >> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + let arr = HsLinearAnn (EpLolly (epTok happy_var_2)) + in mkHsArrowPV (comb2 happy_var_1 happy_var_3) ArrowIsFunType happy_var_1 arr happy_var_3 + )}}} + +happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_537 = happySpecReduce_3 207# happyReduction_537 +happyReduction_537 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut171 happy_x_1 of { (HappyWrap171 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut223 happy_x_3 of { (HappyWrap223 happy_var_3) -> + happyIn223 + (ECP $ + happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + mkQualPV (comb2 happy_var_1 happy_var_3) (addTrailingDarrowC happy_var_1 happy_var_2 emptyComments) happy_var_3 + )}}} + +happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_538 = happySpecReduce_2 207# happyReduction_538 +happyReduction_538 happy_x_2 + happy_x_1 + = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> + case happyOut223 happy_x_2 of { (HappyWrap223 happy_var_2) -> + happyIn223 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsForallPV (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) happy_var_2 + )}} + +happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_539 = happySpecReduce_1 208# happyReduction_539 +happyReduction_539 happy_x_1 + = case happyOut226 happy_x_1 of { (HappyWrap226 happy_var_1) -> + happyIn224 + (happy_var_1 + )} + +happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_540 = happySpecReduce_3 208# happyReduction_540 +happyReduction_540 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut308 happy_x_2 of { (HappyWrap308 happy_var_2) -> + case happyOut225 happy_x_3 of { (HappyWrap225 happy_var_3) -> + happyIn224 + (ECP $ + superInfixOp $ + happy_var_2 >>= \ happy_var_2 -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + rejectPragmaPV happy_var_1 >> + (mkHsOpAppPV (comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_2 happy_var_3) + )}}} + +happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_541 = happySpecReduce_1 209# happyReduction_541 +happyReduction_541 happy_x_1 + = case happyOut226 happy_x_1 of { (HappyWrap226 happy_var_1) -> + happyIn225 + (happy_var_1 + )} + +happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_542 = happySpecReduce_1 209# happyReduction_542 +happyReduction_542 happy_x_1 + = case happyOut342 happy_x_1 of { (HappyWrap342 happy_var_1) -> + happyIn225 + (happy_var_1 + )} + +happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_543 = happySpecReduce_2 210# happyReduction_543 +happyReduction_543 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut229 happy_x_2 of { (HappyWrap229 happy_var_2) -> + happyIn226 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsNegAppPV (comb2 happy_var_1 happy_var_2) happy_var_2 + (epTok happy_var_1) + )}} + +happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_544 = happySpecReduce_1 210# happyReduction_544 +happyReduction_544 happy_x_1 + = case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> + happyIn226 + (happy_var_1 + )} + +happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_545 = happySpecReduce_1 211# happyReduction_545 +happyReduction_545 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn227 + ((msemim happy_var_1,True) + )} + +happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_546 = happySpecReduce_0 211# happyReduction_546 +happyReduction_546 = happyIn227 + ((Nothing,False) + ) + +happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_547 = happyMonadReduce 3# 212# happyReduction_547 +happyReduction_547 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { scc <- getSCC happy_var_2 + ; return (sLL happy_var_1 happy_var_3 + (HsPragSCC + (AnnPragma (glR happy_var_1) (epTok happy_var_3) noAnn (glR happy_var_2) noAnn noAnn noAnn, + (getSCC_PRAGs happy_var_1)) + (StringLiteral (getSTRINGs happy_var_2) scc Nothing)))})}}}) + ) (\r -> happyReturn (happyIn228 r)) + +happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_548 = happySpecReduce_3 212# happyReduction_548 +happyReduction_548 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn228 + (sLL happy_var_1 happy_var_3 + (HsPragSCC + (AnnPragma (glR happy_var_1) (epTok happy_var_3) noAnn (glR happy_var_2) noAnn noAnn noAnn, + (getSCC_PRAGs happy_var_1)) + (StringLiteral NoSourceText (getVARID happy_var_2) Nothing)) + )}}} + +happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_549 = happySpecReduce_2 213# happyReduction_549 +happyReduction_549 happy_x_2 + happy_x_1 + = case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn229 + (ECP $ + superFunArg $ + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_2 >>= \ happy_var_2 -> + spanWithComments (comb2 happy_var_1 happy_var_2) >>= \l -> + mkHsAppPV l happy_var_1 happy_var_2 + )}} + +happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_550 = happySpecReduce_3 213# happyReduction_550 +happyReduction_550 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut180 happy_x_3 of { (HappyWrap180 happy_var_3) -> + happyIn229 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + mkHsAppTypePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) happy_var_1 (epTok happy_var_2) happy_var_3 + )}}} + +happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_551 = happyMonadReduce 2# 213# happyReduction_551 +happyReduction_551 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_2 $ HsStatic (epTok happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn229 r)) + +happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_552 = happySpecReduce_1 213# happyReduction_552 +happyReduction_552 happy_x_1 + = case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> + happyIn229 + (happy_var_1 + )} + +happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_553 = happySpecReduce_3 214# happyReduction_553 +happyReduction_553 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> + happyIn230 + (ECP $ + unECP happy_var_3 >>= \ happy_var_3 -> + mkHsAsPatPV (comb2 happy_var_1 happy_var_3) happy_var_1 (epTok happy_var_2) happy_var_3 + )}}} + +happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_554 = happySpecReduce_2 214# happyReduction_554 +happyReduction_554 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn230 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsLazyPatPV (comb2 happy_var_1 happy_var_2) happy_var_2 (epTok happy_var_1) + )}} + +happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_555 = happySpecReduce_2 214# happyReduction_555 +happyReduction_555 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn230 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsBangPatPV (comb2 happy_var_1 happy_var_2) happy_var_2 (epTok happy_var_1) + )}} + +happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_556 = happySpecReduce_2 214# happyReduction_556 +happyReduction_556 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + happyIn230 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsNegAppPV (comb2 happy_var_1 happy_var_2) happy_var_2 (epTok happy_var_1) + )}} + +happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_557 = happyReduce 4# 214# happyReduction_557 +happyReduction_557 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + happyIn230 + (ECP $ + unECP happy_var_4 >>= \ happy_var_4 -> + mkHsLetPV (comb2 happy_var_1 happy_var_4) (epTok happy_var_1) (unLoc happy_var_2) (epTok happy_var_3) happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_558 = happyReduce 4# 214# happyReduction_558 +happyReduction_558 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut263 happy_x_2 of { (HappyWrap263 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + happyIn230 + (ECP $ + unECP happy_var_4 >>= \ happy_var_4 -> + mkHsLamPV (comb2 happy_var_1 happy_var_4) LamSingle + (sLLld happy_var_1 happy_var_4 + [sLLa happy_var_1 happy_var_4 + $ Match { m_ext = noExtField + , m_ctxt = LamAlt LamSingle + , m_pats = L (listLocation happy_var_2) happy_var_2 + , m_grhss = unguardedGRHSs (comb2 happy_var_3 happy_var_4) happy_var_4 (EpAnn (glR happy_var_3) (GrhsAnn Nothing (Right $ epUniTok happy_var_3)) emptyComments) }]) + (EpAnnLam (epTok happy_var_1) Nothing) + ) `HappyStk` happyRest}}}} + +happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_559 = happySpecReduce_3 214# happyReduction_559 +happyReduction_559 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut339 happy_x_3 of { (HappyWrap339 happy_var_3) -> + happyIn230 + (ECP $ happy_var_3 >>= \ happy_var_3 -> + mkHsLamPV (comb3 happy_var_1 happy_var_2 happy_var_3) LamCase happy_var_3 (EpAnnLam (epTok happy_var_1) (Just (glR happy_var_2))) + )}}} + +happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_560 = happySpecReduce_3 214# happyReduction_560 +happyReduction_560 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut338 happy_x_3 of { (HappyWrap338 happy_var_3) -> + happyIn230 + (ECP $ happy_var_3 >>= \ happy_var_3 -> + mkHsLamPV (comb3 happy_var_1 happy_var_2 happy_var_3) LamCases happy_var_3 (EpAnnLam (epTok happy_var_1) (Just (glR happy_var_2))) + )}}} + +happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_561 = happyMonadReduce 8# 214# happyReduction_561 +happyReduction_561 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOut227 happy_x_3 of { (HappyWrap227 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut221 happy_x_5 of { (HappyWrap221 happy_var_5) -> + case happyOut227 happy_x_6 of { (HappyWrap227 happy_var_6) -> + case happyOutTok happy_x_7 of { happy_var_7 -> + case happyOut221 happy_x_8 of { (HappyWrap221 happy_var_8) -> + ( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) -> + return $ ECP $ + unECP happy_var_5 >>= \ happy_var_5 -> + unECP happy_var_8 >>= \ happy_var_8 -> + mkHsIfPV (comb2 happy_var_1 happy_var_8) happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8 + (AnnsIf + { aiIf = epTok happy_var_1 + , aiThen = epTok happy_var_4 + , aiElse = epTok happy_var_7 + , aiThenSemi = fst happy_var_3 + , aiElseSemi = fst happy_var_6}))}}}}}}}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_562 = happyMonadReduce 2# 214# happyReduction_562 +happyReduction_562 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut256 happy_x_2 of { (HappyWrap256 happy_var_2) -> + ( hintMultiWayIf (getLoc happy_var_1) >>= \_ -> + fmap ecpFromExp $ + do { let (L _ ((o,c),_)) = happy_var_2 + ; amsA' (sLL happy_var_1 happy_var_2 $ HsMultiIf (epTok happy_var_1, o, c) + (NE.reverse $ snd $ unLoc happy_var_2)) })}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_563 = happyMonadReduce 4# 214# happyReduction_563 +happyReduction_563 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut339 happy_x_4 of { (HappyWrap339 happy_var_4) -> + ( runPV (unECP happy_var_2) >>= \ (happy_var_2 :: LHsExpr GhcPs) -> + return $ ECP $ + happy_var_4 >>= \ happy_var_4 -> + mkHsCasePV (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_2 happy_var_4 + (EpAnnHsCase (epTok happy_var_1) (epTok happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_564 = happyMonadReduce 2# 214# happyReduction_564 +happyReduction_564 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut265 happy_x_2 of { (HappyWrap265 happy_var_2) -> + ( do + hintQualifiedDo happy_var_1 + return $ ECP $ + happy_var_2 >>= \ happy_var_2 -> + mkHsDoPV (comb2 happy_var_1 happy_var_2) + (fmap mkModuleNameFS (getDO happy_var_1)) + happy_var_2 + (glR happy_var_1) + (glR happy_var_2))}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_565 = happyMonadReduce 2# 214# happyReduction_565 +happyReduction_565 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut265 happy_x_2 of { (HappyWrap265 happy_var_2) -> + ( hintQualifiedDo happy_var_1 >> runPV happy_var_2 >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (L (comb2 happy_var_1 happy_var_2) + (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO happy_var_1)) + happy_var_2 + (glR happy_var_1) + (glR happy_var_2))))}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_566 = happyMonadReduce 4# 214# happyReduction_566 +happyReduction_566 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( (checkPattern <=< runPV) (unECP happy_var_2) >>= \ p -> + runPV (unECP happy_var_4) >>= \ happy_var_4@cmd -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_4 $HsProc (epTok happy_var_1, epUniTok happy_var_3) p (sLLa happy_var_1 happy_var_4 $ HsCmdTop noExtField cmd)))}}}}) + ) (\r -> happyReturn (happyIn230 r)) + +happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_567 = happySpecReduce_1 214# happyReduction_567 +happyReduction_567 happy_x_1 + = case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> + happyIn230 + (happy_var_1 + )} + +happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_568 = happyReduce 4# 215# happyReduction_568 +happyReduction_568 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut271 happy_x_3 of { (HappyWrap271 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn231 + (ECP $ + getBit OverloadedRecordUpdateBit >>= \ overloaded -> + unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + mkHsRecordPV overloaded (comb2 happy_var_1 happy_var_4) (comb2 happy_var_2 happy_var_4) happy_var_1 happy_var_3 + (Just (epTok happy_var_2), Just (epTok happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_569 = happyMonadReduce 3# 215# happyReduction_569 +happyReduction_569 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + fmap ecpFromExp $ amsA' ( + let fl = sLLa happy_var_2 happy_var_3 (DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) happy_var_3) in + sLL happy_var_1 happy_var_3 $ mkRdrGetField happy_var_1 fl))}}}) + ) (\r -> happyReturn (happyIn231 r)) + +happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_570 = happySpecReduce_1 215# happyReduction_570 +happyReduction_570 happy_x_1 + = case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> + happyIn231 + (happy_var_1 + )} + +happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_571 = happySpecReduce_1 216# happyReduction_571 +happyReduction_571 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn232 + (ECP $ mkHsVarPV $! happy_var_1 + )} + +happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_572 = happySpecReduce_1 216# happyReduction_572 +happyReduction_572 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn232 + (ECP $ mkHsVarPV $! happy_var_1 + )} + +happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_573 = happyMonadReduce 1# 216# happyReduction_573 +happyReduction_573 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> + ( fmap ecpFromExp + (ams1 happy_var_1 (HsIPVar NoExtField $! unLoc happy_var_1)))}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_574 = happyMonadReduce 1# 216# happyReduction_574 +happyReduction_574 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> + ( fmap ecpFromExp + (ams1 happy_var_1 (HsOverLabel (fst $! unLoc happy_var_1) (snd $! unLoc happy_var_1))))}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_575 = happySpecReduce_1 216# happyReduction_575 +happyReduction_575 happy_x_1 + = case happyOut332 happy_x_1 of { (HappyWrap332 happy_var_1) -> + happyIn232 + (ECP $ mkHsLitPV $! happy_var_1 + )} + +happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_576 = happySpecReduce_1 216# happyReduction_576 +happyReduction_576 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsIntegral (getINTEGER happy_var_1)) + )} + +happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_577 = happySpecReduce_1 216# happyReduction_577 +happyReduction_577 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1)) + )} + +happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_578 = happySpecReduce_3 216# happyReduction_578 +happyReduction_578 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkHsParPV (comb2 happy_var_1 happy_var_3) (epTok happy_var_1) happy_var_2 (epTok happy_var_3) + )}}} + +happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_579 = happySpecReduce_3 216# happyReduction_579 +happyReduction_579 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + happy_var_2 >>= \ happy_var_2 -> + mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Boxed happy_var_2 + (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_580 = happyMonadReduce 3# 216# happyReduction_580 +happyReduction_580 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut344 happy_x_2 of { (HappyWrap344 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do + { pat <- hintOrPats (sL1a happy_var_2 (OrPat NoExtField (unLoc happy_var_2))) + ; fmap ecpFromPat + (amsA' (sLL happy_var_1 happy_var_3 (ParPat (epTok happy_var_1, epTok happy_var_3) pat))) })}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_581 = happySpecReduce_3 216# happyReduction_581 +happyReduction_581 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut233 happy_x_2 of { (HappyWrap233 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + amsA' (sLL happy_var_1 happy_var_3 $ mkRdrProjection (NE.reverse (unLoc happy_var_2)) (AnnProjection (epTok happy_var_1) (epTok happy_var_3)) ) + >>= ecpFromExp' + )}}} + +happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_582 = happySpecReduce_3 216# happyReduction_582 +happyReduction_582 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + unECP happy_var_2 >>= \ happy_var_2 -> + mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed (Tuple [Right happy_var_2]) + (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_583 = happySpecReduce_3 216# happyReduction_583 +happyReduction_583 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut242 happy_x_2 of { (HappyWrap242 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ + happy_var_2 >>= \ happy_var_2 -> + mkSumOrTuplePV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) Unboxed happy_var_2 + (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_584 = happySpecReduce_3 216# happyReduction_584 +happyReduction_584 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn232 + (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) (glR happy_var_1,glR happy_var_3) + )}}} + +happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_585 = happySpecReduce_1 216# happyReduction_585 +happyReduction_585 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn232 + (ECP $ mkHsWildCardPV (getLoc happy_var_1) + )} + +happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_586 = happySpecReduce_1 216# happyReduction_586 +happyReduction_586 happy_x_1 + = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> + happyIn232 + (ECP $ mkHsSplicePV happy_var_1 + )} + +happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_587 = happySpecReduce_1 216# happyReduction_587 +happyReduction_587 happy_x_1 + = case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> + happyIn232 + (ecpFromExp $ fmap (HsTypedSplice noExtField) (reLoc happy_var_1) + )} + +happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_588 = happyMonadReduce 2# 216# happyReduction_588 +happyReduction_588 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut317 happy_x_2 of { (HappyWrap317 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) True happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_589 = happyMonadReduce 2# 216# happyReduction_589 +happyReduction_589 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut286 happy_x_2 of { (HappyWrap286 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) True happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_590 = happyMonadReduce 2# 216# happyReduction_590 +happyReduction_590 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut313 happy_x_2 of { (HappyWrap313 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) False happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_591 = happyMonadReduce 2# 216# happyReduction_591 +happyReduction_591 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut296 happy_x_2 of { (HappyWrap296 happy_var_2) -> + ( fmap ecpFromExp $ amsA' (sLL happy_var_1 happy_var_2 $ HsUntypedBracket noExtField (VarBr (glR happy_var_1) False happy_var_2)))}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_592 = happyMonadReduce 1# 216# happyReduction_592 +happyReduction_592 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( reportEmptyDoubleQuotes (getLoc happy_var_1))}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_593 = happyMonadReduce 3# 216# happyReduction_593 +happyReduction_593 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (ExpBr (if (hasE happy_var_1) then (BracketHasE (epTok happy_var_1), epUniTok happy_var_3) + else (BracketNoE (epUniTok happy_var_1), epUniTok happy_var_3)) happy_var_2)))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_594 = happyMonadReduce 3# 216# happyReduction_594 +happyReduction_594 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsTypedBracket (if (hasE happy_var_1) then (BracketHasE (epTok happy_var_1),epTok happy_var_3) else (BracketNoE (epTok happy_var_1),epTok happy_var_3)) happy_var_2))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_595 = happyMonadReduce 3# 216# happyReduction_595 +happyReduction_595 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (TypBr (epTok happy_var_1,epUniTok happy_var_3) happy_var_2)))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_596 = happyMonadReduce 3# 216# happyReduction_596 +happyReduction_596 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( (checkPattern <=< runPV) (unECP happy_var_2) >>= \p -> + fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (PatBr (epTok happy_var_1,epUniTok happy_var_3) p)))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_597 = happyMonadReduce 3# 216# happyReduction_597 +happyReduction_597 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut239 happy_x_2 of { (HappyWrap239 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( fmap ecpFromExp $ + amsA' (sLL happy_var_1 happy_var_3 $ HsUntypedBracket noExtField (DecBrL (epTok happy_var_1,epUniTok happy_var_3, fst happy_var_2) (snd happy_var_2))))}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_598 = happySpecReduce_1 216# happyReduction_598 +happyReduction_598 happy_x_1 + = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> + happyIn232 + (ECP $ mkHsSplicePV happy_var_1 + )} + +happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_599 = happyMonadReduce 4# 216# happyReduction_599 +happyReduction_599 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut230 happy_x_2 of { (HappyWrap230 happy_var_2) -> + case happyOut237 happy_x_3 of { (HappyWrap237 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_4 $ HsCmdArrForm (AnnList (glRM happy_var_1) (ListBanana (epUniTok happy_var_1) (epUniTok happy_var_4)) [] noAnn []) happy_var_2 Prefix + (reverse happy_var_3)))}}}}) + ) (\r -> happyReturn (happyIn232 r)) + +happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_600 = happySpecReduce_3 217# happyReduction_600 +happyReduction_600 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> + happyIn233 + (sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 $ DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) happy_var_3) `NE.cons` unLoc happy_var_1) + )}}} + +happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_601 = happySpecReduce_2 217# happyReduction_601 +happyReduction_601 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> + happyIn233 + (sLL happy_var_1 happy_var_2 ((sLLa happy_var_1 happy_var_2 $ DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_1)) happy_var_2) :| []) + )}} + +happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_602 = happySpecReduce_1 218# happyReduction_602 +happyReduction_602 happy_x_1 + = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> + happyIn234 + (fmap (HsUntypedSplice noExtField) (reLoc happy_var_1) + )} + +happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_603 = happySpecReduce_1 218# happyReduction_603 +happyReduction_603 happy_x_1 + = case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> + happyIn234 + (fmap (HsTypedSplice noExtField) (reLoc happy_var_1) + )} + +happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_604 = happyMonadReduce 2# 219# happyReduction_604 +happyReduction_604 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + return (sLL happy_var_1 happy_var_2 $ HsUntypedSpliceExpr (epTok happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn235 r)) + +happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_605 = happyMonadReduce 2# 220# happyReduction_605 +happyReduction_605 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut232 happy_x_2 of { (HappyWrap232 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + return (sLL happy_var_1 happy_var_2 $ (HsTypedSpliceExpr (epTok happy_var_1) happy_var_2)))}}) + ) (\r -> happyReturn (happyIn236 r)) + +happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_606 = happySpecReduce_2 221# happyReduction_606 +happyReduction_606 happy_x_2 + happy_x_1 + = case happyOut237 happy_x_1 of { (HappyWrap237 happy_var_1) -> + case happyOut238 happy_x_2 of { (HappyWrap238 happy_var_2) -> + happyIn237 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_607 = happySpecReduce_0 221# happyReduction_607 +happyReduction_607 = happyIn237 + ([] + ) + +happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_608 = happyMonadReduce 1# 222# happyReduction_608 +happyReduction_608 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> + ( runPV (unECP happy_var_1) >>= \ (cmd :: LHsCmd GhcPs) -> + runPV (checkCmdBlockArguments cmd) >>= \ _ -> + return (sL1a cmd $ HsCmdTop noExtField cmd))}) + ) (\r -> happyReturn (happyIn238 r)) + +happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_609 = happySpecReduce_3 223# happyReduction_609 +happyReduction_609 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn239 + (((epTok happy_var_1 ,epTok happy_var_3),happy_var_2) + )}}} + +happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_610 = happySpecReduce_3 223# happyReduction_610 +happyReduction_610 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> + happyIn239 + (((NoEpTok, NoEpTok),happy_var_2) + )} + +happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_611 = happySpecReduce_1 224# happyReduction_611 +happyReduction_611 happy_x_1 + = case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> + happyIn240 + (cvTopDecls happy_var_1 + )} + +happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_612 = happySpecReduce_1 224# happyReduction_612 +happyReduction_612 happy_x_1 + = case happyOut77 happy_x_1 of { (HappyWrap77 happy_var_1) -> + happyIn240 + (cvTopDecls happy_var_1 + )} + +happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_613 = happySpecReduce_1 225# happyReduction_613 +happyReduction_613 happy_x_1 + = case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> + happyIn241 + (happy_var_1 + )} + +happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_614 = happyMonadReduce 2# 225# happyReduction_614 +happyReduction_614 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOut308 happy_x_2 of { (HappyWrap308 happy_var_2) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (rejectPragmaPV happy_var_1) >> + runPV happy_var_2 >>= \ happy_var_2 -> + return $ ecpFromExp $ + sLLa happy_var_1 happy_var_2 $ SectionL noExtField happy_var_1 (n2l happy_var_2))}}) + ) (\r -> happyReturn (happyIn241 r)) + +happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_615 = happySpecReduce_2 225# happyReduction_615 +happyReduction_615 happy_x_2 + happy_x_1 + = case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> + case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> + happyIn241 + (ECP $ + superInfixOp $ + unECP happy_var_2 >>= \ happy_var_2 -> + happy_var_1 >>= \ happy_var_1 -> + mkHsSectionR_PV (comb2 happy_var_1 happy_var_2) (n2l happy_var_1) happy_var_2 + )}} + +happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_616 = happySpecReduce_2 226# happyReduction_616 +happyReduction_616 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOut243 happy_x_2 of { (HappyWrap243 happy_var_2) -> + happyIn242 + (unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_2 >>= \ happy_var_2 -> + do { t <- amsA happy_var_1 [AddCommaAnn (EpTok $ srcSpan2e $ fst happy_var_2)] + ; return (Tuple (Right t : snd happy_var_2)) } + )}} + +happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_617 = happySpecReduce_2 226# happyReduction_617 +happyReduction_617 happy_x_2 + happy_x_1 + = case happyOut335 happy_x_1 of { (HappyWrap335 happy_var_1) -> + case happyOut244 happy_x_2 of { (HappyWrap244 happy_var_2) -> + happyIn242 + (happy_var_2 >>= \ happy_var_2 -> + do { let {cos = NE.map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst happy_var_1) } + ; return (Tuple (toList cos ++ happy_var_2)) } + )}} + +happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_618 = happySpecReduce_2 226# happyReduction_618 +happyReduction_618 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOut337 happy_x_2 of { (HappyWrap337 happy_var_2) -> + happyIn242 + (unECP happy_var_1 >>= \ happy_var_1 -> return $ + (Sum 1 (snd happy_var_2 + 1) happy_var_1 [] (fst happy_var_2)) + )}} + +happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_619 = happySpecReduce_3 226# happyReduction_619 +happyReduction_619 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> + case happyOut336 happy_x_3 of { (HappyWrap336 happy_var_3) -> + happyIn242 + (unECP happy_var_2 >>= \ happy_var_2 -> return $ + (Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2 (fst happy_var_1) (fst happy_var_3)) + )}}} + +happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_620 = happySpecReduce_2 227# happyReduction_620 +happyReduction_620 happy_x_2 + happy_x_1 + = case happyOut335 happy_x_1 of { (HappyWrap335 happy_var_1) -> + case happyOut244 happy_x_2 of { (HappyWrap244 happy_var_2) -> + happyIn243 + (happy_var_2 >>= \ happy_var_2 -> + do { let {cos = map (\l -> (Left (EpAnn (spanAsAnchor l) True emptyComments))) (tail $ fst happy_var_1) } + ; return ((head $ fst happy_var_1, cos ++ happy_var_2)) } + )}} + +happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_621 = happySpecReduce_2 228# happyReduction_621 +happyReduction_621 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOut243 happy_x_2 of { (HappyWrap243 happy_var_2) -> + happyIn244 + (unECP happy_var_1 >>= \ happy_var_1 -> + happy_var_2 >>= \ happy_var_2 -> + do { t <- amsA happy_var_1 [AddCommaAnn (EpTok $ srcSpan2e $ fst happy_var_2)] + ; return (Right t : snd happy_var_2) } + )}} + +happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_622 = happySpecReduce_1 228# happyReduction_622 +happyReduction_622 happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + happyIn244 + (unECP happy_var_1 >>= \ happy_var_1 -> + return [Right happy_var_1] + )} + +happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_623 = happySpecReduce_0 228# happyReduction_623 +happyReduction_623 = happyIn244 + (return [Left noAnn] + ) + +happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_624 = happySpecReduce_1 229# happyReduction_624 +happyReduction_624 happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + happyIn245 + (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> + mkHsExplicitListPV loc [happy_var_1] (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []) + )} + +happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_625 = happySpecReduce_1 229# happyReduction_625 +happyReduction_625 happy_x_1 + = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> + happyIn245 + (\loc (ao,ac) -> happy_var_1 >>= \ happy_var_1 -> + mkHsExplicitListPV loc (reverse happy_var_1) (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn []) + )} + +happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_626 = happySpecReduce_2 229# happyReduction_626 +happyReduction_626 happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn245 + (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok happy_var_2) (EpTok ac)) Nothing (From happy_var_1)) + >>= ecpFromExp' + )}} + +happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_627 = happyReduce 4# 229# happyReduction_627 +happyReduction_627 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { (HappyWrap222 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + happyIn245 + (\loc (ao,ac) -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) (Just (epTok happy_var_2)) (epTok happy_var_4) (EpTok ac)) Nothing (FromThen happy_var_1 happy_var_3)) + >>= ecpFromExp' + ) `HappyStk` happyRest}}}} + +happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_628 = happySpecReduce_3 229# happyReduction_628 +happyReduction_628 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { (HappyWrap222 happy_var_3) -> + happyIn245 + (\loc (ao,ac) -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) Nothing (epTok happy_var_2) (EpTok ac)) Nothing (FromTo happy_var_1 happy_var_3)) + >>= ecpFromExp' + )}}} + +happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_629 = happyReduce 5# 229# happyReduction_629 +happyReduction_629 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut222 happy_x_3 of { (HappyWrap222 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut222 happy_x_5 of { (HappyWrap222 happy_var_5) -> + happyIn245 + (\loc (ao,ac) -> + unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + unECP happy_var_5 >>= \ happy_var_5 -> + amsA' (L loc $ ArithSeq (AnnArithSeq (EpTok ao) (Just (epTok happy_var_2)) (epTok happy_var_4) (EpTok ac)) Nothing (FromThenTo happy_var_1 happy_var_3 happy_var_5)) + >>= ecpFromExp' + ) `HappyStk` happyRest}}}}} + +happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_630 = happySpecReduce_3 229# happyReduction_630 +happyReduction_630 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut247 happy_x_3 of { (HappyWrap247 happy_var_3) -> + happyIn245 + (\loc (ao,ac) -> + checkMonadComp >>= \ ctxt -> + unECP happy_var_1 >>= \ happy_var_1 -> do { t <- addTrailingVbarA happy_var_1 (epTok happy_var_2) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc happy_var_3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [] noAnn [])) + >>= ecpFromExp' } + )}}} + +happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_631 = happySpecReduce_3 230# happyReduction_631 +happyReduction_631 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut241 happy_x_3 of { (HappyWrap241 happy_var_3) -> + happyIn246 + (happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + case happy_var_1 of + (h:t) -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (((:) $! happy_var_3) $! (h':t)) + )}}} + +happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_632 = happySpecReduce_3 230# happyReduction_632 +happyReduction_632 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut241 happy_x_3 of { (HappyWrap241 happy_var_3) -> + happyIn246 + (unECP happy_var_1 >>= \ happy_var_1 -> + unECP happy_var_3 >>= \ happy_var_3 -> + do { h <- addTrailingCommaA happy_var_1 (epTok happy_var_2) + ; return [happy_var_3,h] } + )}}} + +happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_633 = happySpecReduce_1 231# happyReduction_633 +happyReduction_633 happy_x_1 + = case happyOut248 happy_x_1 of { (HappyWrap248 happy_var_1) -> + happyIn247 + (case unLoc happy_var_1 of + qs:|[] -> sL1 happy_var_1 qs + -- We just had one thing in our "parallel" list so + -- we simply return that thing directly + + qss -> sL1 happy_var_1 [sL1a happy_var_1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr | + qs <- qss] + noExpr noSyntaxExpr] + -- We actually found some actual parallel lists so + -- we wrap them into as a ParStmt + )} + +happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_634 = happyMonadReduce 3# 232# happyReduction_634 +happyReduction_634 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut248 happy_x_3 of { (HappyWrap248 happy_var_3) -> + ( case unLoc happy_var_1 of + h:|t -> do + h' <- addTrailingVbarA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (reverse (h':t) NE.<| unLoc happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn248 r)) + +happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_635 = happySpecReduce_1 232# happyReduction_635 +happyReduction_635 happy_x_1 + = case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + happyIn248 + (L (getLoc happy_var_1) (NE.singleton (reverse (toList (unLoc happy_var_1)))) + )} + +happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_636 = happyMonadReduce 3# 233# happyReduction_636 +happyReduction_636 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut250 happy_x_3 of { (HappyWrap250 happy_var_3) -> + ( case unLoc happy_var_1 of + h:|t -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (NE.singleton (sLLa happy_var_1 happy_var_3 ((unLoc happy_var_3) (reverse (h':t)))))))}}}) + ) (\r -> happyReturn (happyIn249 r)) + +happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_637 = happyMonadReduce 3# 233# happyReduction_637 +happyReduction_637 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut249 happy_x_1 of { (HappyWrap249 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut270 happy_x_3 of { (HappyWrap270 happy_var_3) -> + ( runPV happy_var_3 >>= \ happy_var_3 -> + case unLoc happy_var_1 of + h:|t -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 :| (h':t))))}}}) + ) (\r -> happyReturn (happyIn249 r)) + +happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_638 = happySpecReduce_1 233# happyReduction_638 +happyReduction_638 happy_x_1 + = case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> + happyIn249 + (sLL happy_var_1 happy_var_1 (NE.singleton (L (getLocAnn happy_var_1) ((unLoc happy_var_1) []))) + )} + +happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_639 = happyMonadReduce 1# 233# happyReduction_639 +happyReduction_639 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> + ( runPV happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 (NE.singleton happy_var_1))}) + ) (\r -> happyReturn (happyIn249 r)) + +happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_640 = happyMonadReduce 2# 234# happyReduction_640 +happyReduction_640 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + return ( + sLL happy_var_1 happy_var_2 (\ss -> (mkTransformStmt (AnnTransStmt (epTok happy_var_1) noAnn noAnn noAnn) ss happy_var_2))))}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_641 = happyMonadReduce 4# 234# happyReduction_641 +happyReduction_641 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + runPV (unECP happy_var_4) >>= \ happy_var_4 -> + return (sLL happy_var_1 happy_var_4 (\ss -> (mkTransformByStmt (AnnTransStmt (epTok happy_var_1) noAnn (Just (epTok happy_var_3)) noAnn) ss happy_var_2 happy_var_4))))}}}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_642 = happyMonadReduce 4# 234# happyReduction_642 +happyReduction_642 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + return (sLL happy_var_1 happy_var_4 (\ss -> (mkGroupUsingStmt (AnnTransStmt (epTok happy_var_1) (Just (epTok happy_var_2)) noAnn (Just (epTok happy_var_3))) ss happy_var_4))))}}}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_643 = happyMonadReduce 6# 234# happyReduction_643 +happyReduction_643 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + case happyOutTok happy_x_5 of { happy_var_5 -> + case happyOut221 happy_x_6 of { (HappyWrap221 happy_var_6) -> + ( runPV (unECP happy_var_4) >>= \ happy_var_4 -> + runPV (unECP happy_var_6) >>= \ happy_var_6 -> + return (sLL happy_var_1 happy_var_6 (\ss -> (mkGroupByUsingStmt (AnnTransStmt (epTok happy_var_1) (Just (epTok happy_var_2)) (Just (epTok happy_var_3)) (Just (epTok happy_var_5))) ss happy_var_4 happy_var_6))))}}}}}}) + ) (\r -> happyReturn (happyIn250 r)) + +happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_644 = happySpecReduce_1 235# happyReduction_644 +happyReduction_644 happy_x_1 + = case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> + happyIn251 + (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) + )} + +happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_645 = happyMonadReduce 3# 236# happyReduction_645 +happyReduction_645 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut270 happy_x_3 of { (HappyWrap270 happy_var_3) -> + ( runPV happy_var_3 >>= \ happy_var_3 -> + case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingCommaA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (happy_var_3 : (h':t))))}}}) + ) (\r -> happyReturn (happyIn252 r)) + +happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_646 = happyMonadReduce 1# 236# happyReduction_646 +happyReduction_646 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> + ( runPV happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 [happy_var_1])}) + ) (\r -> happyReturn (happyIn252 r)) + +happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_647 = happySpecReduce_2 237# happyReduction_647 +happyReduction_647 happy_x_2 + happy_x_1 + = case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> + case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> + happyIn253 + (happy_var_1 >>= \alt -> + do { let {L l (bs, csw) = adaptWhereBinds happy_var_2} + ; acs (comb2 alt (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) } + )}} + +happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_648 = happySpecReduce_2 238# happyReduction_648 +happyReduction_648 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> + happyIn254 + (unECP happy_var_2 >>= \ happy_var_2 -> + acs (comb2 happy_var_1 happy_var_2) (\loc cs -> L loc (unguardedRHS (EpAnn (spanAsAnchor $ comb2 happy_var_1 happy_var_2) (GrhsAnn Nothing (Right $ epUniTok happy_var_1)) cs) (comb2 happy_var_1 happy_var_2) happy_var_2)) + )}} + +happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_649 = happySpecReduce_1 238# happyReduction_649 +happyReduction_649 happy_x_1 + = case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> + happyIn254 + (happy_var_1 >>= \gdpats -> + return $ sL1 gdpats (NE.reverse (unLoc gdpats)) + )} + +happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_650 = happySpecReduce_2 239# happyReduction_650 +happyReduction_650 happy_x_2 + happy_x_1 + = case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> + case happyOut257 happy_x_2 of { (HappyWrap257 happy_var_2) -> + happyIn255 + (happy_var_1 >>= \gdpats -> + happy_var_2 >>= \gdpat -> + return $ sLL gdpats gdpat (gdpat NE.<| unLoc gdpats) + )}} + +happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_651 = happySpecReduce_1 239# happyReduction_651 +happyReduction_651 happy_x_1 + = case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> + happyIn255 + (happy_var_1 >>= \gdpat -> return $ sL1 gdpat (NE.singleton gdpat) + )} + +happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_652 = happyMonadReduce 3# 240# happyReduction_652 +happyReduction_652 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut255 happy_x_2 of { (HappyWrap255 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( runPV happy_var_2 >>= \ happy_var_2 -> + return $ sLL happy_var_1 happy_var_3 ((epTok happy_var_1,epTok happy_var_3),unLoc happy_var_2))}}}) + ) (\r -> happyReturn (happyIn256 r)) + +happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_653 = happyMonadReduce 2# 240# happyReduction_653 +happyReduction_653 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> + ( runPV happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 ((NoEpTok, NoEpTok),unLoc happy_var_1))}) + ) (\r -> happyReturn (happyIn256 r)) + +happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_654 = happyReduce 4# 241# happyReduction_654 +happyReduction_654 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut251 happy_x_2 of { (HappyWrap251 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + case happyOut221 happy_x_4 of { (HappyWrap221 happy_var_4) -> + happyIn257 + (unECP happy_var_4 >>= \ happy_var_4 -> + acsA (comb2 happy_var_1 happy_var_4) (\loc cs -> sL loc $ GRHS (EpAnn (glEE happy_var_1 happy_var_4) (GrhsAnn (Just $ epTok happy_var_1) (Right $ epUniTok happy_var_3)) cs) (unLoc happy_var_2) happy_var_4) + ) `HappyStk` happyRest}}}} + +happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_655 = happyMonadReduce 1# 242# happyReduction_655 +happyReduction_655 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + ( (checkPattern <=< runPV) (unECP happy_var_1))}) + ) (\r -> happyReturn (happyIn258 r)) + +happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_656 = happyMonadReduce 1# 243# happyReduction_656 +happyReduction_656 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut343 happy_x_1 of { (HappyWrap343 happy_var_1) -> + ( case unLoc happy_var_1 of + pat :| [] -> return pat + pats -> hintOrPats (sL1a happy_var_1 (OrPat NoExtField pats)))}) + ) (\r -> happyReturn (happyIn259 r)) + +happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_657 = happySpecReduce_1 244# happyReduction_657 +happyReduction_657 happy_x_1 + = case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> + happyIn260 + ([ happy_var_1 ] + )} + +happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_658 = happyMonadReduce 1# 245# happyReduction_658 +happyReduction_658 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + ( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess + checkPattern_details incompleteDoBlock + (unECP happy_var_1))}) + ) (\r -> happyReturn (happyIn261 r)) + +happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_659 = happySpecReduce_1 246# happyReduction_659 +happyReduction_659 happy_x_1 + = case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> + happyIn262 + (happy_var_1 + )} + +happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_660 = happySpecReduce_2 246# happyReduction_660 +happyReduction_660 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn262 + (sLLa happy_var_1 happy_var_2 (InvisPat (epTok happy_var_1, SpecifiedSpec) (mkHsTyPat happy_var_2)) + )}} + +happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_661 = happySpecReduce_2 247# happyReduction_661 +happyReduction_661 happy_x_2 + happy_x_1 + = case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> + case happyOut263 happy_x_2 of { (HappyWrap263 happy_var_2) -> + happyIn263 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_662 = happySpecReduce_0 247# happyReduction_662 +happyReduction_662 = happyIn263 + ([] + ) + +happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_663 = happyMonadReduce 1# 248# happyReduction_663 +happyReduction_663 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> + ( (checkPattern <=< runPV) (unECP happy_var_1))}) + ) (\r -> happyReturn (happyIn264 r)) + +happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_664 = happySpecReduce_3 249# happyReduction_664 +happyReduction_664 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn265 + (happy_var_2 >>= \ happy_var_2 -> + amsr (sLL happy_var_1 happy_var_3 (reverse $ snd $ unLoc happy_var_2)) (AnnList (stmtsAnchor happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (fromOL $ fst $ unLoc happy_var_2) noAnn []) + )}}} + +happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_665 = happySpecReduce_3 249# happyReduction_665 +happyReduction_665 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> + happyIn265 + (happy_var_2 >>= \ happy_var_2 -> amsr + (L (stmtsLoc happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (stmtsAnchor happy_var_2) ListNone (fromOL $ fst $ unLoc happy_var_2) noAnn []) + )} + +happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_666 = happySpecReduce_3 250# happyReduction_666 +happyReduction_666 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut269 happy_x_3 of { (HappyWrap269 happy_var_3) -> + happyIn266 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ (happy_var_3 :: LStmt GhcPs (LocatedA b)) -> + case (snd $ unLoc happy_var_1) of + [] -> return (sLL happy_var_1 happy_var_3 ( (fst $ unLoc happy_var_1) `snocOL` (epTok happy_var_2) + , happy_var_3 : (snd $ unLoc happy_var_1))) + (h:t) -> do + { h' <- addTrailingSemiA h (epTok happy_var_2) + ; return $ sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 :(h':t)) } + )}}} + +happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_667 = happySpecReduce_2 250# happyReduction_667 +happyReduction_667 happy_x_2 + happy_x_1 + = case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn266 + (happy_var_1 >>= \ happy_var_1 -> + case (snd $ unLoc happy_var_1) of + [] -> return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) `snocOL` (epTok happy_var_2),snd $ unLoc happy_var_1)) + (h:t) -> do + { h' <- addTrailingSemiA h (epTok happy_var_2) + ; return $ sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1,h':t) } + )}} + +happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_668 = happySpecReduce_1 250# happyReduction_668 +happyReduction_668 happy_x_1 + = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> + happyIn266 + (happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 (nilOL,[happy_var_1]) + )} + +happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_669 = happySpecReduce_0 250# happyReduction_669 +happyReduction_669 = happyIn266 + (return $ noLoc (nilOL,[]) + ) + +happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_670 = happyMonadReduce 1# 251# happyReduction_670 +happyReduction_670 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> + ( fmap Just (runPV happy_var_1))}) + ) (\r -> happyReturn (happyIn267 r)) + +happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_671 = happySpecReduce_0 251# happyReduction_671 +happyReduction_671 = happyIn267 + (Nothing + ) + +happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_672 = happyMonadReduce 1# 252# happyReduction_672 +happyReduction_672 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> + ( runPV happy_var_1)}) + ) (\r -> happyReturn (happyIn268 r)) + +happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_673 = happySpecReduce_1 253# happyReduction_673 +happyReduction_673 happy_x_1 + = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> + happyIn269 + (happy_var_1 + )} + +happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_674 = happySpecReduce_2 253# happyReduction_674 +happyReduction_674 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut265 happy_x_2 of { (HappyWrap265 happy_var_2) -> + happyIn269 + (happy_var_2 >>= \ happy_var_2 -> + amsA' (sLL happy_var_1 happy_var_2 $ mkRecStmt (hsDoAnn (epTok happy_var_1) happy_var_2) happy_var_2) + )}} + +happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_675 = happySpecReduce_3 254# happyReduction_675 +happyReduction_675 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_3 of { (HappyWrap221 happy_var_3) -> + happyIn270 + (unECP happy_var_3 >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_3 $ mkPsBindStmt (epUniTok happy_var_2) happy_var_1 happy_var_3) + )}}} + +happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_676 = happySpecReduce_1 254# happyReduction_676 +happyReduction_676 happy_x_1 + = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + happyIn270 + (unECP happy_var_1 >>= \ happy_var_1 -> + return $ sL1a happy_var_1 $ mkBodyStmt happy_var_1 + )} + +happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_677 = happySpecReduce_2 254# happyReduction_677 +happyReduction_677 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut136 happy_x_2 of { (HappyWrap136 happy_var_2) -> + happyIn270 + (amsA' (sLL happy_var_1 happy_var_2 $ mkLetStmt (epTok happy_var_1) (unLoc happy_var_2)) + )}} + +happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_678 = happySpecReduce_1 255# happyReduction_678 +happyReduction_678 happy_x_1 + = case happyOut272 happy_x_1 of { (HappyWrap272 happy_var_1) -> + happyIn271 + (happy_var_1 + )} + +happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_679 = happySpecReduce_0 255# happyReduction_679 +happyReduction_679 = happyIn271 + (return ([], Nothing) + ) + +happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_680 = happySpecReduce_3 256# happyReduction_680 +happyReduction_680 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut272 happy_x_3 of { (HappyWrap272 happy_var_3) -> + happyIn272 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> do + h <- addTrailingCommaFBind happy_var_1 (epTok happy_var_2) + return (case happy_var_3 of (flds, dd) -> (h : flds, dd)) + )}}} + +happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_681 = happySpecReduce_1 256# happyReduction_681 +happyReduction_681 happy_x_1 + = case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> + happyIn272 + (happy_var_1 >>= \ happy_var_1 -> + return ([happy_var_1], Nothing) + )} + +happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_682 = happySpecReduce_1 256# happyReduction_682 +happyReduction_682 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn272 + (return ([], Just (getLoc happy_var_1)) + )} + +happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_683 = happySpecReduce_3 257# happyReduction_683 +happyReduction_683 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut241 happy_x_3 of { (HappyWrap241 happy_var_3) -> + happyIn273 + (unECP happy_var_3 >>= \ happy_var_3 -> + fmap Left $ amsA' (sLL happy_var_1 happy_var_3 $ HsFieldBind (Just (epTok happy_var_2)) (sL1a happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) + )}}} + +happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_684 = happySpecReduce_1 257# happyReduction_684 +happyReduction_684 happy_x_1 + = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> + happyIn273 + (placeHolderPunRhs >>= \rhs -> + fmap Left $ amsA' (sL1 happy_var_1 $ HsFieldBind Nothing (sL1a happy_var_1 $ mkFieldOcc happy_var_1) rhs True) + )} + +happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_685 = happyReduce 5# 257# happyReduction_685 +happyReduction_685 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut274 happy_x_3 of { (HappyWrap274 happy_var_3) -> + case happyOutTok happy_x_4 of { happy_var_4 -> + case happyOut241 happy_x_5 of { (HappyWrap241 happy_var_5) -> + happyIn273 + (do + let top = sL1a happy_var_1 $ DotFieldOcc noAnn happy_var_1 + ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) + lf' = comb2 happy_var_2 (L lf ()) + fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) f) : t + final = last fields + l = comb2 happy_var_1 happy_var_3 + isPun = False + happy_var_5 <- unECP happy_var_5 + fmap Right $ mkHsProjUpdatePV (comb2 happy_var_1 happy_var_5) (L l fields) happy_var_5 isPun + (Just (epTok happy_var_4)) + ) `HappyStk` happyRest}}}}} + +happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_686 = happySpecReduce_3 257# happyReduction_686 +happyReduction_686 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut274 happy_x_3 of { (HappyWrap274 happy_var_3) -> + happyIn273 + (do + let top = sL1a happy_var_1 $ DotFieldOcc noAnn happy_var_1 + ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc happy_var_3) + lf' = comb2 happy_var_2 (L lf ()) + fields = top :| L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ epTok happy_var_2)) f) : t + final = last fields + l = comb2 happy_var_1 happy_var_3 + isPun = True + var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final)) + fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun Nothing + )}}} + +happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_687 = happySpecReduce_3 258# happyReduction_687 +happyReduction_687 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> + happyIn274 + (sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 (DotFieldOcc (AnnFieldLabel $ Just $ epTok happy_var_2) happy_var_3)) : unLoc happy_var_1) + )}}} + +happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_688 = happySpecReduce_1 258# happyReduction_688 +happyReduction_688 happy_x_1 + = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> + happyIn274 + (sL1 happy_var_1 [sL1a happy_var_1 (DotFieldOcc (AnnFieldLabel Nothing) happy_var_1)] + )} + +happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_689 = happyMonadReduce 3# 259# happyReduction_689 +happyReduction_689 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut276 happy_x_3 of { (HappyWrap276 happy_var_3) -> + ( case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (let { this = happy_var_3; rest = h':t } + in rest `seq` this `seq` sLL happy_var_1 happy_var_3 (this : rest)))}}}) + ) (\r -> happyReturn (happyIn275 r)) + +happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_690 = happyMonadReduce 2# 259# happyReduction_690 +happyReduction_690 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( case unLoc happy_var_1 of + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (h':t)))}}) + ) (\r -> happyReturn (happyIn275 r)) + +happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_691 = happySpecReduce_1 259# happyReduction_691 +happyReduction_691 happy_x_1 + = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> + happyIn275 + (let this = happy_var_1 in this `seq` (sL1 happy_var_1 [this]) + )} + +happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_692 = happyMonadReduce 3# 260# happyReduction_692 +happyReduction_692 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_3 of { (HappyWrap221 happy_var_3) -> + ( runPV (unECP happy_var_3) >>= \ happy_var_3 -> + amsA' (sLL happy_var_1 happy_var_3 (IPBind (epTok happy_var_2) (reLoc happy_var_1) happy_var_3)))}}}) + ) (\r -> happyReturn (happyIn276 r)) + +happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_693 = happySpecReduce_1 261# happyReduction_693 +happyReduction_693 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn277 + (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) + )} + +happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_694 = happySpecReduce_1 262# happyReduction_694 +happyReduction_694 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn278 + (sL1 happy_var_1 (getLABELVARIDs happy_var_1, getLABELVARID happy_var_1) + )} + +happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_695 = happySpecReduce_1 263# happyReduction_695 +happyReduction_695 happy_x_1 + = case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> + happyIn279 + (happy_var_1 + )} + +happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_696 = happySpecReduce_0 263# happyReduction_696 +happyReduction_696 = happyIn279 + (noLocA mkTrue + ) + +happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_697 = happySpecReduce_1 264# happyReduction_697 +happyReduction_697 happy_x_1 + = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> + happyIn280 + (happy_var_1 + )} + +happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_698 = happyMonadReduce 3# 264# happyReduction_698 +happyReduction_698 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut280 happy_x_3 of { (HappyWrap280 happy_var_3) -> + ( do { h <- addTrailingVbarL happy_var_1 (epTok happy_var_2) + ; return (sLLa happy_var_1 happy_var_3 (Or [h,happy_var_3])) })}}}) + ) (\r -> happyReturn (happyIn280 r)) + +happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_699 = happySpecReduce_1 265# happyReduction_699 +happyReduction_699 happy_x_1 + = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> + happyIn281 + (sLLa (head happy_var_1) (last happy_var_1) (And (toList happy_var_1)) + )} + +happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_700 = happySpecReduce_1 266# happyReduction_700 +happyReduction_700 happy_x_1 + = case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> + happyIn282 + (NE.singleton happy_var_1 + )} + +happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_701 = happyMonadReduce 3# 266# happyReduction_701 +happyReduction_701 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut282 happy_x_3 of { (HappyWrap282 happy_var_3) -> + ( do { h <- addTrailingCommaL happy_var_1 (epTok happy_var_2) + ; return (h NE.<| happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn282 r)) + +happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_702 = happyMonadReduce 3# 267# happyReduction_702 +happyReduction_702 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut280 happy_x_2 of { (HappyWrap280 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (Parens happy_var_2)) + (AnnList Nothing (ListParens (epTok happy_var_1) (epTok happy_var_3)) [] noAnn []))}}}) + ) (\r -> happyReturn (happyIn283 r)) + +happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_703 = happySpecReduce_1 267# happyReduction_703 +happyReduction_703 happy_x_1 + = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> + happyIn283 + (sL1a happy_var_1 (Var happy_var_1) + )} + +happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_704 = happySpecReduce_1 268# happyReduction_704 +happyReduction_704 happy_x_1 + = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> + happyIn284 + (sL1 happy_var_1 [happy_var_1] + )} + +happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_705 = happyMonadReduce 3# 268# happyReduction_705 +happyReduction_705 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut284 happy_x_3 of { (HappyWrap284 happy_var_3) -> + ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; return (sLL happy_var_1 happy_var_3 (h : unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn284 r)) + +happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_706 = happySpecReduce_1 269# happyReduction_706 +happyReduction_706 happy_x_1 + = case happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> + happyIn285 + (happy_var_1 + )} + +happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_707 = happySpecReduce_1 269# happyReduction_707 +happyReduction_707 happy_x_1 + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + happyIn285 + (happy_var_1 + )} + +happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_708 = happySpecReduce_1 270# happyReduction_708 +happyReduction_708 happy_x_1 + = case happyOut287 happy_x_1 of { (HappyWrap287 happy_var_1) -> + happyIn286 + (happy_var_1 + )} + +happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_709 = happySpecReduce_1 270# happyReduction_709 +happyReduction_709 happy_x_1 + = case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> + happyIn286 + (happy_var_1 + )} + +happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_710 = happySpecReduce_1 271# happyReduction_710 +happyReduction_710 happy_x_1 + = case happyOut328 happy_x_1 of { (HappyWrap328 happy_var_1) -> + happyIn287 + (happy_var_1 + )} + +happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_711 = happyMonadReduce 3# 271# happyReduction_711 +happyReduction_711 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut330 happy_x_2 of { (HappyWrap330 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn287 r)) + +happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_712 = happySpecReduce_1 272# happyReduction_712 +happyReduction_712 happy_x_1 + = case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> + happyIn288 + (happy_var_1 + )} + +happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_713 = happyMonadReduce 3# 272# happyReduction_713 +happyReduction_713 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut331 happy_x_2 of { (HappyWrap331 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn288 r)) + +happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_714 = happySpecReduce_1 272# happyReduction_714 +happyReduction_714 happy_x_1 + = case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> + happyIn288 + (happy_var_1 + )} + +happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_715 = happySpecReduce_1 273# happyReduction_715 +happyReduction_715 happy_x_1 + = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + happyIn289 + (sL1 happy_var_1 (pure happy_var_1) + )} + +happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_716 = happyMonadReduce 3# 273# happyReduction_716 +happyReduction_716 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut289 happy_x_3 of { (HappyWrap289 happy_var_3) -> + ( sLL happy_var_1 happy_var_3 . (:| toList (unLoc happy_var_3)) <$> addTrailingCommaN happy_var_1 (gl happy_var_2))}}}) + ) (\r -> happyReturn (happyIn289 r)) + +happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_717 = happySpecReduce_1 274# happyReduction_717 +happyReduction_717 happy_x_1 + = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + happyIn290 + ([happy_var_1] + )} + +happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_718 = happyMonadReduce 3# 274# happyReduction_718 +happyReduction_718 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut290 happy_x_3 of { (HappyWrap290 happy_var_3) -> + ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) + ; return (h : happy_var_3) })}}}) + ) (\r -> happyReturn (happyIn290 r)) + +happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_719 = happyMonadReduce 3# 275# happyReduction_719 +happyReduction_719 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) + (NameAnnCommas (NameParens (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []))}}}) + ) (\r -> happyReturn (happyIn291 r)) + +happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_720 = happyMonadReduce 2# 275# happyReduction_720 +happyReduction_720 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) (NameAnnOnly (NameParensHash (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn291 r)) + +happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_721 = happyMonadReduce 3# 275# happyReduction_721 +happyReduction_721 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) + (NameAnnCommas (NameParensHash (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []))}}}) + ) (\r -> happyReturn (happyIn291 r)) + +happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_722 = happySpecReduce_1 276# happyReduction_722 +happyReduction_722 happy_x_1 + = case happyOut293 happy_x_1 of { (HappyWrap293 happy_var_1) -> + happyIn292 + (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) + )} + +happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_723 = happyMonadReduce 3# 276# happyReduction_723 +happyReduction_723 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (Just $ epTok happy_var_1) (epUniTok happy_var_2) (Just $ epTok happy_var_3) []))}}}) + ) (\r -> happyReturn (happyIn292 r)) + +happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_724 = happySpecReduce_1 277# happyReduction_724 +happyReduction_724 happy_x_1 + = case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> + happyIn293 + (happy_var_1 + )} + +happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_725 = happyMonadReduce 2# 277# happyReduction_725 +happyReduction_725 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 unitDataCon) (NameAnnOnly (NameParens (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn293 r)) + +happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_726 = happyMonadReduce 2# 277# happyReduction_726 +happyReduction_726 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 nilDataCon) (NameAnnOnly (NameSquare (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn293 r)) + +happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_727 = happySpecReduce_1 278# happyReduction_727 +happyReduction_727 happy_x_1 + = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> + happyIn294 + (happy_var_1 + )} + +happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_728 = happyMonadReduce 3# 278# happyReduction_728 +happyReduction_728 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut329 happy_x_2 of { (HappyWrap329 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn294 r)) + +happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_729 = happySpecReduce_1 279# happyReduction_729 +happyReduction_729 happy_x_1 + = case happyOut330 happy_x_1 of { (HappyWrap330 happy_var_1) -> + happyIn295 + (happy_var_1 + )} + +happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_730 = happyMonadReduce 3# 279# happyReduction_730 +happyReduction_730 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut328 happy_x_2 of { (HappyWrap328 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn295 r)) + +happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_731 = happySpecReduce_1 280# happyReduction_731 +happyReduction_731 happy_x_1 + = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> + happyIn296 + (happy_var_1 + )} + +happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_732 = happyMonadReduce 2# 280# happyReduction_732 +happyReduction_732 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) + (NameAnnOnly (NameParens (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn296 r)) + +happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_733 = happyMonadReduce 2# 280# happyReduction_733 +happyReduction_733 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) + (NameAnnOnly (NameParensHash (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn296 r)) + +happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_734 = happyMonadReduce 2# 280# happyReduction_734 +happyReduction_734 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + ( amsr (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) + (NameAnnOnly (NameSquare (epTok happy_var_1) (epTok happy_var_2)) []))}}) + ) (\r -> happyReturn (happyIn296 r)) + +happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_735 = happySpecReduce_1 281# happyReduction_735 +happyReduction_735 happy_x_1 + = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> + happyIn297 + (happy_var_1 + )} + +happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_736 = happyMonadReduce 3# 281# happyReduction_736 +happyReduction_736 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { n <- mkTupleSyntaxTycon Boxed (snd happy_var_2 + 1) + ; amsr (sLL happy_var_1 happy_var_3 n) (NameAnnCommas (NameParens (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []) })}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_737 = happyMonadReduce 3# 281# happyReduction_737 +happyReduction_737 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut335 happy_x_2 of { (HappyWrap335 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { n <- mkTupleSyntaxTycon Unboxed (snd happy_var_2 + 1) + ; amsr (sLL happy_var_1 happy_var_3 n) (NameAnnCommas (NameParensHash (epTok happy_var_1) (epTok happy_var_3)) (map (EpTok . srcSpan2e) (toList $ fst happy_var_2)) []) })}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_738 = happyMonadReduce 3# 281# happyReduction_738 +happyReduction_738 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut337 happy_x_2 of { (HappyWrap337 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( do { requireLTPuns PEP_SumSyntaxType happy_var_1 happy_var_3 + ; amsr (sLL happy_var_1 happy_var_3 $ (getRdrName (sumTyCon (snd happy_var_2 + 1)))) + (NameAnnBars (epTok happy_var_1, epTok happy_var_3) (toList $ fst happy_var_2) []) })}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_739 = happyMonadReduce 3# 281# happyReduction_739 +happyReduction_739 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow (Just $ epTok happy_var_1) (epUniTok happy_var_2) (Just $ epTok happy_var_3) []))}}}) + ) (\r -> happyReturn (happyIn297 r)) + +happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_740 = happySpecReduce_1 282# happyReduction_740 +happyReduction_740 happy_x_1 + = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + happyIn298 + (happy_var_1 + )} + +happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_741 = happyMonadReduce 3# 282# happyReduction_741 +happyReduction_741 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut303 happy_x_2 of { (HappyWrap303 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn298 r)) + +happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_742 = happySpecReduce_1 283# happyReduction_742 +happyReduction_742 happy_x_1 + = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> + happyIn299 + (happy_var_1 + )} + +happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_743 = happyMonadReduce 3# 283# happyReduction_743 +happyReduction_743 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) } + in amsr (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn299 r)) + +happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_744 = happyMonadReduce 3# 283# happyReduction_744 +happyReduction_744 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) } + in amsr (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn299 r)) + +happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_745 = happyMonadReduce 3# 283# happyReduction_745 +happyReduction_745 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! consDataCon_RDR } + in amsr (sLL happy_var_1 happy_var_3 (unLoc name)) (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn299 r)) + +happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_746 = happySpecReduce_1 284# happyReduction_746 +happyReduction_746 happy_x_1 + = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> + happyIn300 + (happy_var_1 + )} + +happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_747 = happyMonadReduce 3# 284# happyReduction_747 +happyReduction_747 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn300 r)) + +happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_748 = happySpecReduce_1 285# happyReduction_748 +happyReduction_748 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn301 + (sL1n happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) + )} + +happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_749 = happySpecReduce_1 285# happyReduction_749 +happyReduction_749 happy_x_1 + = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> + happyIn301 + (happy_var_1 + )} + +happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_750 = happySpecReduce_1 286# happyReduction_750 +happyReduction_750 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn302 + (sL1n happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) + )} + +happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_751 = happySpecReduce_1 287# happyReduction_751 +happyReduction_751 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn303 + (sL1n happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) + )} + +happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_752 = happySpecReduce_1 287# happyReduction_752 +happyReduction_752 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn303 + (sL1n happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) + )} + +happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_753 = happySpecReduce_1 287# happyReduction_753 +happyReduction_753 happy_x_1 + = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> + happyIn303 + (happy_var_1 + )} + +happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_754 = happySpecReduce_1 288# happyReduction_754 +happyReduction_754 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) + )} + +happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_755 = happySpecReduce_1 288# happyReduction_755 +happyReduction_755 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) + )} + +happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_756 = happySpecReduce_1 288# happyReduction_756 +happyReduction_756 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! consDataCon_RDR + )} + +happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_757 = happySpecReduce_1 288# happyReduction_757 +happyReduction_757 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit "-") + )} + +happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_758 = happySpecReduce_1 288# happyReduction_758 +happyReduction_758 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn304 + (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit ".") + )} + +happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_759 = happySpecReduce_1 289# happyReduction_759 +happyReduction_759 happy_x_1 + = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> + happyIn305 + (happy_var_1 + )} + +happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_760 = happyMonadReduce 3# 289# happyReduction_760 +happyReduction_760 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut304 happy_x_2 of { (HappyWrap304 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn305 r)) + +happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_761 = happySpecReduce_1 290# happyReduction_761 +happyReduction_761 happy_x_1 + = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> + happyIn306 + (happy_var_1 + )} + +happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_762 = happySpecReduce_1 290# happyReduction_762 +happyReduction_762 happy_x_1 + = case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> + happyIn306 + (happy_var_1 + )} + +happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_763 = happyMonadReduce 1# 290# happyReduction_763 +happyReduction_763 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + ( amsr (sLL happy_var_1 happy_var_1 $ getRdrName unrestrictedFunTyCon) + (NameAnnRArrow Nothing (epUniTok happy_var_1) Nothing []))}) + ) (\r -> happyReturn (happyIn306 r)) + +happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_764 = happySpecReduce_1 291# happyReduction_764 +happyReduction_764 happy_x_1 + = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> + happyIn307 + (happy_var_1 + )} + +happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_765 = happyMonadReduce 3# 291# happyReduction_765 +happyReduction_765 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut320 happy_x_2 of { (HappyWrap320 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn307 r)) + +happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_766 = happySpecReduce_1 292# happyReduction_766 +happyReduction_766 happy_x_1 + = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> + happyIn308 + (mkHsVarOpPV happy_var_1 + )} + +happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_767 = happySpecReduce_1 292# happyReduction_767 +happyReduction_767 happy_x_1 + = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> + happyIn308 + (mkHsConOpPV happy_var_1 + )} + +happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_768 = happySpecReduce_1 292# happyReduction_768 +happyReduction_768 happy_x_1 + = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> + happyIn308 + (mkHsInfixHolePV happy_var_1 + )} + +happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_769 = happySpecReduce_1 293# happyReduction_769 +happyReduction_769 happy_x_1 + = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> + happyIn309 + (mkHsVarOpPV happy_var_1 + )} + +happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_770 = happySpecReduce_1 293# happyReduction_770 +happyReduction_770 happy_x_1 + = case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> + happyIn309 + (mkHsConOpPV happy_var_1 + )} + +happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_771 = happySpecReduce_1 293# happyReduction_771 +happyReduction_771 happy_x_1 + = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> + happyIn309 + (mkHsInfixHolePV happy_var_1 + )} + +happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_772 = happyMonadReduce 3# 294# happyReduction_772 +happyReduction_772 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (mkUnqual varName (fsLit "_"))) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn310 r)) + +happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_773 = happySpecReduce_1 295# happyReduction_773 +happyReduction_773 happy_x_1 + = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> + happyIn311 + (happy_var_1 + )} + +happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_774 = happyMonadReduce 3# 295# happyReduction_774 +happyReduction_774 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn311 r)) + +happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_775 = happySpecReduce_1 296# happyReduction_775 +happyReduction_775 happy_x_1 + = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> + happyIn312 + (happy_var_1 + )} + +happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_776 = happyMonadReduce 3# 296# happyReduction_776 +happyReduction_776 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn312 r)) + +happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_777 = happySpecReduce_1 297# happyReduction_777 +happyReduction_777 happy_x_1 + = case happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> + happyIn313 + (happy_var_1 + )} + +happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_778 = happyMonadReduce 3# 298# happyReduction_778 +happyReduction_778 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut315 happy_x_2 of { (HappyWrap315 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameBackquotes (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn314 r)) + +happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_779 = happySpecReduce_1 299# happyReduction_779 +happyReduction_779 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) + )} + +happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_780 = happySpecReduce_1 299# happyReduction_780 +happyReduction_780 happy_x_1 + = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) + )} + +happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_781 = happySpecReduce_1 299# happyReduction_781 +happyReduction_781 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (fsLit "unsafe") + )} + +happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_782 = happySpecReduce_1 299# happyReduction_782 +happyReduction_782 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (fsLit "safe") + )} + +happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_783 = happySpecReduce_1 299# happyReduction_783 +happyReduction_783 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn315 + (sL1n happy_var_1 $! mkUnqual tvName (fsLit "interruptible") + )} + +happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_784 = happySpecReduce_1 300# happyReduction_784 +happyReduction_784 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn316 + (happy_var_1 + )} + +happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_785 = happyMonadReduce 3# 300# happyReduction_785 +happyReduction_785 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn316 r)) + +happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_786 = happySpecReduce_1 301# happyReduction_786 +happyReduction_786 happy_x_1 + = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> + happyIn317 + (happy_var_1 + )} + +happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_787 = happyMonadReduce 3# 301# happyReduction_787 +happyReduction_787 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn317 r)) + +happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_788 = happyMonadReduce 3# 301# happyReduction_788 +happyReduction_788 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + ( amsr (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + (NameAnn (NameParens (epTok happy_var_1) (epTok happy_var_3)) (glR happy_var_2) []))}}}) + ) (\r -> happyReturn (happyIn317 r)) + +happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_789 = happySpecReduce_1 302# happyReduction_789 +happyReduction_789 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn318 + (fmap (FieldLabelString . occNameFS . rdrNameOcc) happy_var_1 + )} + +happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_790 = happySpecReduce_1 303# happyReduction_790 +happyReduction_790 happy_x_1 + = case happyOut320 happy_x_1 of { (HappyWrap320 happy_var_1) -> + happyIn319 + (happy_var_1 + )} + +happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_791 = happySpecReduce_1 303# happyReduction_791 +happyReduction_791 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn319 + (sL1n happy_var_1 $! mkQual varName (getQVARID happy_var_1) + )} + +happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_792 = happySpecReduce_1 304# happyReduction_792 +happyReduction_792 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (getVARID happy_var_1) + )} + +happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_793 = happySpecReduce_1 304# happyReduction_793 +happyReduction_793 happy_x_1 + = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (unLoc happy_var_1) + )} + +happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_794 = happySpecReduce_1 304# happyReduction_794 +happyReduction_794 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "unsafe") + )} + +happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_795 = happySpecReduce_1 304# happyReduction_795 +happyReduction_795 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "safe") + )} + +happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_796 = happySpecReduce_1 304# happyReduction_796 +happyReduction_796 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "interruptible") + )} + +happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_797 = happySpecReduce_1 304# happyReduction_797 +happyReduction_797 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "family") + )} + +happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_798 = happySpecReduce_1 304# happyReduction_798 +happyReduction_798 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn320 + (sL1n happy_var_1 $! mkUnqual varName (fsLit "role") + )} + +happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_799 = happySpecReduce_1 305# happyReduction_799 +happyReduction_799 happy_x_1 + = case happyOut324 happy_x_1 of { (HappyWrap324 happy_var_1) -> + happyIn321 + (happy_var_1 + )} + +happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_800 = happySpecReduce_1 305# happyReduction_800 +happyReduction_800 happy_x_1 + = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> + happyIn321 + (happy_var_1 + )} + +happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_801 = happySpecReduce_1 306# happyReduction_801 +happyReduction_801 happy_x_1 + = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> + happyIn322 + (happy_var_1 + )} + +happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_802 = happySpecReduce_1 306# happyReduction_802 +happyReduction_802 happy_x_1 + = case happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> + happyIn322 + (happy_var_1 + )} + +happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_803 = happySpecReduce_1 307# happyReduction_803 +happyReduction_803 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn323 + (sL1n happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) + )} + +happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_804 = happySpecReduce_1 308# happyReduction_804 +happyReduction_804 happy_x_1 + = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> + happyIn324 + (happy_var_1 + )} + +happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_805 = happySpecReduce_1 308# happyReduction_805 +happyReduction_805 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn324 + (sL1n happy_var_1 $ mkUnqual varName (fsLit "-") + )} + +happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_806 = happySpecReduce_1 309# happyReduction_806 +happyReduction_806 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn325 + (sL1n happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) + )} + +happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_807 = happySpecReduce_1 309# happyReduction_807 +happyReduction_807 happy_x_1 + = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> + happyIn325 + (sL1n happy_var_1 $ mkUnqual varName (unLoc happy_var_1) + )} + +happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_808 = happySpecReduce_1 310# happyReduction_808 +happyReduction_808 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "as") + )} + +happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_809 = happySpecReduce_1 310# happyReduction_809 +happyReduction_809 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "qualified") + )} + +happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_810 = happySpecReduce_1 310# happyReduction_810 +happyReduction_810 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "hiding") + )} + +happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_811 = happySpecReduce_1 310# happyReduction_811 +happyReduction_811 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "export") + )} + +happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_812 = happySpecReduce_1 310# happyReduction_812 +happyReduction_812 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "label") + )} + +happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_813 = happySpecReduce_1 310# happyReduction_813 +happyReduction_813 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "dynamic") + )} + +happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_814 = happySpecReduce_1 310# happyReduction_814 +happyReduction_814 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "stdcall") + )} + +happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_815 = happySpecReduce_1 310# happyReduction_815 +happyReduction_815 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "ccall") + )} + +happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_816 = happySpecReduce_1 310# happyReduction_816 +happyReduction_816 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "capi") + )} + +happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_817 = happySpecReduce_1 310# happyReduction_817 +happyReduction_817 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "prim") + )} + +happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_818 = happySpecReduce_1 310# happyReduction_818 +happyReduction_818 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "javascript") + )} + +happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_819 = happySpecReduce_1 310# happyReduction_819 +happyReduction_819 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "group") + )} + +happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_820 = happySpecReduce_1 310# happyReduction_820 +happyReduction_820 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "stock") + )} + +happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_821 = happySpecReduce_1 310# happyReduction_821 +happyReduction_821 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "anyclass") + )} + +happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_822 = happySpecReduce_1 310# happyReduction_822 +happyReduction_822 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "via") + )} + +happyReduce_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_823 = happySpecReduce_1 310# happyReduction_823 +happyReduction_823 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "unit") + )} + +happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_824 = happySpecReduce_1 310# happyReduction_824 +happyReduction_824 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "dependency") + )} + +happyReduce_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_825 = happySpecReduce_1 310# happyReduction_825 +happyReduction_825 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "signature") + )} + +happyReduce_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_826 = happySpecReduce_1 310# happyReduction_826 +happyReduction_826 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "quote") + )} + +happyReduce_827 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_827 = happySpecReduce_1 310# happyReduction_827 +happyReduction_827 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn326 + (sL1 happy_var_1 (fsLit "splice") + )} + +happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_828 = happySpecReduce_1 311# happyReduction_828 +happyReduction_828 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn327 + (sL1 happy_var_1 (fsLit ".") + )} + +happyReduce_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_829 = happySpecReduce_1 311# happyReduction_829 +happyReduction_829 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn327 + (sL1 happy_var_1 (starSym (isUnicode happy_var_1)) + )} + +happyReduce_830 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_830 = happySpecReduce_1 312# happyReduction_830 +happyReduction_830 happy_x_1 + = case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> + happyIn328 + (happy_var_1 + )} + +happyReduce_831 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_831 = happySpecReduce_1 312# happyReduction_831 +happyReduction_831 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn328 + (sL1n happy_var_1 $! mkQual dataName (getQCONID happy_var_1) + )} + +happyReduce_832 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_832 = happySpecReduce_1 313# happyReduction_832 +happyReduction_832 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn329 + (sL1n happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) + )} + +happyReduce_833 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_833 = happySpecReduce_1 314# happyReduction_833 +happyReduction_833 happy_x_1 + = case happyOut331 happy_x_1 of { (HappyWrap331 happy_var_1) -> + happyIn330 + (happy_var_1 + )} + +happyReduce_834 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_834 = happySpecReduce_1 314# happyReduction_834 +happyReduction_834 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn330 + (sL1n happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) + )} + +happyReduce_835 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_835 = happySpecReduce_1 315# happyReduction_835 +happyReduction_835 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn331 + (sL1n happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) + )} + +happyReduce_836 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_836 = happySpecReduce_1 315# happyReduction_836 +happyReduction_836 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn331 + (sL1n happy_var_1 $ consDataCon_RDR + )} + +happyReduce_837 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_837 = happySpecReduce_1 316# happyReduction_837 +happyReduction_837 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 + )} + +happyReduce_838 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_838 = happySpecReduce_1 316# happyReduction_838 +happyReduction_838 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) + $ getSTRING happy_var_1 + )} + +happyReduce_839 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_839 = happySpecReduce_1 316# happyReduction_839 +happyReduction_839 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsMultilineString (getSTRINGMULTIs happy_var_1) + $ getSTRINGMULTI happy_var_1 + )} + +happyReduce_840 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_840 = happySpecReduce_1 316# happyReduction_840 +happyReduction_840 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) + $ getPRIMINTEGER happy_var_1 + )} + +happyReduce_841 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_841 = happySpecReduce_1 316# happyReduction_841 +happyReduction_841 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) + $ getPRIMWORD happy_var_1 + )} + +happyReduce_842 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_842 = happySpecReduce_1 316# happyReduction_842 +happyReduction_842 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt8Prim (getPRIMINTEGER8s happy_var_1) + $ getPRIMINTEGER8 happy_var_1 + )} + +happyReduce_843 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_843 = happySpecReduce_1 316# happyReduction_843 +happyReduction_843 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt16Prim (getPRIMINTEGER16s happy_var_1) + $ getPRIMINTEGER16 happy_var_1 + )} + +happyReduce_844 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_844 = happySpecReduce_1 316# happyReduction_844 +happyReduction_844 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt32Prim (getPRIMINTEGER32s happy_var_1) + $ getPRIMINTEGER32 happy_var_1 + )} + +happyReduce_845 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_845 = happySpecReduce_1 316# happyReduction_845 +happyReduction_845 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsInt64Prim (getPRIMINTEGER64s happy_var_1) + $ getPRIMINTEGER64 happy_var_1 + )} + +happyReduce_846 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_846 = happySpecReduce_1 316# happyReduction_846 +happyReduction_846 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord8Prim (getPRIMWORD8s happy_var_1) + $ getPRIMWORD8 happy_var_1 + )} + +happyReduce_847 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_847 = happySpecReduce_1 316# happyReduction_847 +happyReduction_847 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord16Prim (getPRIMWORD16s happy_var_1) + $ getPRIMWORD16 happy_var_1 + )} + +happyReduce_848 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_848 = happySpecReduce_1 316# happyReduction_848 +happyReduction_848 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord32Prim (getPRIMWORD32s happy_var_1) + $ getPRIMWORD32 happy_var_1 + )} + +happyReduce_849 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_849 = happySpecReduce_1 316# happyReduction_849 +happyReduction_849 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsWord64Prim (getPRIMWORD64s happy_var_1) + $ getPRIMWORD64 happy_var_1 + )} + +happyReduce_850 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_850 = happySpecReduce_1 316# happyReduction_850 +happyReduction_850 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) + $ getPRIMCHAR happy_var_1 + )} + +happyReduce_851 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_851 = happySpecReduce_1 316# happyReduction_851 +happyReduction_851 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) + $ getPRIMSTRING happy_var_1 + )} + +happyReduce_852 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_852 = happySpecReduce_1 316# happyReduction_852 +happyReduction_852 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsFloatPrim noExtField $ getPRIMFLOAT happy_var_1 + )} + +happyReduce_853 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_853 = happySpecReduce_1 316# happyReduction_853 +happyReduction_853 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn332 + (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE happy_var_1 + )} + +happyReduce_854 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_854 = happySpecReduce_1 317# happyReduction_854 +happyReduction_854 happy_x_1 + = happyIn333 + (() + ) + +happyReduce_855 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_855 = happyMonadReduce 1# 317# happyReduction_855 +happyReduction_855 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((( popContext)) + ) (\r -> happyReturn (happyIn333 r)) + +happyReduce_856 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_856 = happySpecReduce_1 318# happyReduction_856 +happyReduction_856 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn334 + (sL1a happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) + )} + +happyReduce_857 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_857 = happySpecReduce_1 318# happyReduction_857 +happyReduction_857 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn334 + (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in + mkModuleNameFS + (concatFS [mod, fsLit ".", c]) + )} + +happyReduce_858 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_858 = happySpecReduce_2 319# happyReduction_858 +happyReduction_858 happy_x_2 + happy_x_1 + = case happyOut335 happy_x_1 of { (HappyWrap335 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn335 + ((foldr (NE.<|) (NE.singleton $ gl happy_var_2) (fst happy_var_1) ,snd happy_var_1 + 1) + )}} + +happyReduce_859 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_859 = happySpecReduce_1 319# happyReduction_859 +happyReduction_859 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn335 + ((NE.singleton $ gl happy_var_1, 1) + )} + +happyReduce_860 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_860 = happySpecReduce_1 320# happyReduction_860 +happyReduction_860 happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + happyIn336 + (happy_var_1 + )} + +happyReduce_861 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_861 = happySpecReduce_0 320# happyReduction_861 +happyReduction_861 = happyIn336 + (([], 0) + ) + +happyReduce_862 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_862 = happySpecReduce_2 321# happyReduction_862 +happyReduction_862 happy_x_2 + happy_x_1 + = case happyOut337 happy_x_1 of { (HappyWrap337 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn337 + (((fst happy_var_1)++[epTok happy_var_2],snd happy_var_1 + 1) + )}} + +happyReduce_863 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_863 = happySpecReduce_1 321# happyReduction_863 +happyReduction_863 happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + happyIn337 + (([epTok happy_var_1],1) + )} + +happyReduce_864 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_864 = happySpecReduce_3 322# happyReduction_864 +happyReduction_864 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut345 happy_x_2 of { (HappyWrap345 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn338 + (happy_var_2 >>= \ happy_var_2 -> amsr + (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (fst $ unLoc happy_var_2) noAnn []) + )}}} + +happyReduce_865 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_865 = happySpecReduce_3 322# happyReduction_865 +happyReduction_865 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut345 happy_x_2 of { (HappyWrap345 happy_var_2) -> + happyIn338 + (happy_var_2 >>= \ happy_var_2 -> amsr + (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) ListNone (fst $ unLoc happy_var_2) noAnn []) + )} + +happyReduce_866 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_866 = happySpecReduce_2 322# happyReduction_866 +happyReduction_866 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn338 + (amsr (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (ListBraces (epTok happy_var_1) (epTok happy_var_2)) [] noAnn []) + )}} + +happyReduce_867 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_867 = happySpecReduce_2 322# happyReduction_867 +happyReduction_867 happy_x_2 + happy_x_1 + = happyIn338 + (return $ noLocA [] + ) + +happyReduce_868 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_868 = happySpecReduce_3 323# happyReduction_868 +happyReduction_868 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut346 happy_x_2 of { (HappyWrap346 happy_var_2) -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn339 + (happy_var_2 >>= \ happy_var_2 -> amsr + (sLL happy_var_1 happy_var_3 (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) (ListBraces (epTok happy_var_1) (epTok happy_var_3)) (fst $ unLoc happy_var_2) noAnn []) + )}}} + +happyReduce_869 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_869 = happySpecReduce_3 323# happyReduction_869 +happyReduction_869 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut346 happy_x_2 of { (HappyWrap346 happy_var_2) -> + happyIn339 + (happy_var_2 >>= \ happy_var_2 -> amsr + (L (getLoc happy_var_2) (reverse (snd $ unLoc happy_var_2))) + (AnnList (Just $ glR happy_var_2) ListNone (fst $ unLoc happy_var_2) noAnn []) + )} + +happyReduce_870 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_870 = happySpecReduce_2 323# happyReduction_870 +happyReduction_870 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn339 + (amsr (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (ListBraces (epTok happy_var_1) (epTok happy_var_2)) [] noAnn []) + )}} + +happyReduce_871 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_871 = happySpecReduce_2 323# happyReduction_871 +happyReduction_871 happy_x_2 + happy_x_1 + = happyIn339 + (return $ noLocA [] + ) + +happyReduce_872 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_872 = happySpecReduce_3 324# happyReduction_872 +happyReduction_872 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + happyIn340 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + rejectPragmaPV happy_var_1 >> + mkHsTySigPV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3 + (epUniTok happy_var_2) + )}}} + +happyReduce_873 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_873 = happyMonadReduce 3# 324# happyReduction_873 +happyReduction_873 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsFirstOrderApp True))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_874 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_874 = happyMonadReduce 3# 324# happyReduction_874 +happyReduction_874 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsFirstOrderApp False))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_875 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_875 = happyMonadReduce 3# 324# happyReduction_875 +happyReduction_875 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsHigherOrderApp True))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_876 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_876 = happyMonadReduce 3# 324# happyReduction_876 +happyReduction_876 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut340 happy_x_3 of { (HappyWrap340 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsHigherOrderApp False))}}}) + ) (\r -> happyReturn (happyIn340 r)) + +happyReduce_877 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_877 = happySpecReduce_1 324# happyReduction_877 +happyReduction_877 happy_x_1 + = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> + happyIn340 + (happy_var_1 + )} + +happyReduce_878 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_878 = happySpecReduce_1 324# happyReduction_878 +happyReduction_878 happy_x_1 + = case happyOut348 happy_x_1 of { (HappyWrap348 happy_var_1) -> + happyIn340 + (happy_var_1 + )} + +happyReduce_879 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_879 = happySpecReduce_2 324# happyReduction_879 +happyReduction_879 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn340 + (ECP $ mkHsEmbTyPV (comb2 happy_var_1 happy_var_2) (epTok happy_var_1) happy_var_2 + )}} + +happyReduce_880 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_880 = happySpecReduce_3 325# happyReduction_880 +happyReduction_880 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> + happyIn341 + (ECP $ + unECP happy_var_1 >>= \ happy_var_1 -> + rejectPragmaPV happy_var_1 >> + mkHsTySigPV (noAnnSrcSpan $ comb2 happy_var_1 happy_var_3) happy_var_1 happy_var_3 + (epUniTok happy_var_2) + )}}} + +happyReduce_881 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_881 = happyMonadReduce 3# 325# happyReduction_881 +happyReduction_881 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsFirstOrderApp True))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_882 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_882 = happyMonadReduce 3# 325# happyReduction_882 +happyReduction_882 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsFirstOrderApp False))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_883 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_883 = happyMonadReduce 3# 325# happyReduction_883 +happyReduction_883 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_1 happy_var_3 + HsHigherOrderApp True))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_884 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_884 = happyMonadReduce 3# 325# happyReduction_884 +happyReduction_884 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut341 happy_x_3 of { (HappyWrap341 happy_var_3) -> + ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> + runPV (unECP happy_var_3) >>= \ happy_var_3 -> + fmap ecpFromCmd $ + amsA' (sLL happy_var_1 happy_var_3 $ HsCmdArrApp (isUnicodeSyntax happy_var_2, glR happy_var_2) happy_var_3 happy_var_1 + HsHigherOrderApp False))}}}) + ) (\r -> happyReturn (happyIn341 r)) + +happyReduce_885 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_885 = happySpecReduce_1 325# happyReduction_885 +happyReduction_885 happy_x_1 + = case happyOut223 happy_x_1 of { (HappyWrap223 happy_var_1) -> + happyIn341 + (happy_var_1 + )} + +happyReduce_886 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_886 = happySpecReduce_1 325# happyReduction_886 +happyReduction_886 happy_x_1 + = case happyOut347 happy_x_1 of { (HappyWrap347 happy_var_1) -> + happyIn341 + (happy_var_1 + )} + +happyReduce_887 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_887 = happySpecReduce_2 325# happyReduction_887 +happyReduction_887 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut180 happy_x_2 of { (HappyWrap180 happy_var_2) -> + happyIn341 + (ECP $ mkHsEmbTyPV (comb2 happy_var_1 happy_var_2) (epTok happy_var_1) happy_var_2 + )}} + +happyReduce_888 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_888 = happyMonadReduce 2# 326# happyReduction_888 +happyReduction_888 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> + case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' $ (sLL happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn342 r)) + +happyReduce_889 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_889 = happyMonadReduce 1# 327# happyReduction_889 +happyReduction_889 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; return (sL1 pat (NE.singleton pat)) })}) + ) (\r -> happyReturn (happyIn343 r)) + +happyReduce_890 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_890 = happyMonadReduce 3# 327# happyReduction_890 +happyReduction_890 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut343 happy_x_3 of { (HappyWrap343 happy_var_3) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; pat <- addTrailingSemiA pat (epTok happy_var_2) + ; return (sLL pat happy_var_3 (pat NE.<| unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn343 r)) + +happyReduce_891 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_891 = happyMonadReduce 1# 328# happyReduction_891 +happyReduction_891 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; return (sL1 pat (NE.singleton pat)) })}) + ) (\r -> happyReturn (happyIn344 r)) + +happyReduce_892 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_892 = happyMonadReduce 3# 328# happyReduction_892 +happyReduction_892 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut222 happy_x_1 of { (HappyWrap222 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut344 happy_x_3 of { (HappyWrap344 happy_var_3) -> + ( do + { pat <- (checkPattern <=< runPV) (unECP happy_var_1) + ; pat <- addTrailingSemiA pat (epTok happy_var_2) + ; return (sLL pat happy_var_3 (pat NE.<| unLoc happy_var_3)) })}}}) + ) (\r -> happyReturn (happyIn344 r)) + +happyReduce_893 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_893 = happySpecReduce_1 329# happyReduction_893 +happyReduction_893 happy_x_1 + = case happyOut349 happy_x_1 of { (HappyWrap349 happy_var_1) -> + happyIn345 + (happy_var_1 >>= \ happy_var_1 -> return $ + sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) + )} + +happyReduce_894 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_894 = happySpecReduce_2 329# happyReduction_894 +happyReduction_894 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut345 happy_x_2 of { (HappyWrap345 happy_var_2) -> + happyIn345 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_2 (((mzEpTok happy_var_1) : (fst $ unLoc happy_var_2) ) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_895 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_895 = happySpecReduce_1 330# happyReduction_895 +happyReduction_895 happy_x_1 + = case happyOut350 happy_x_1 of { (HappyWrap350 happy_var_1) -> + happyIn346 + (happy_var_1 >>= \ happy_var_1 -> return $ + sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) + )} + +happyReduce_896 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_896 = happySpecReduce_2 330# happyReduction_896 +happyReduction_896 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut346 happy_x_2 of { (HappyWrap346 happy_var_2) -> + happyIn346 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_2 (((mzEpTok happy_var_1) : (fst $ unLoc happy_var_2) ) + ,snd $ unLoc happy_var_2) + )}} + +happyReduce_897 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_897 = happyMonadReduce 2# 331# happyReduction_897 +happyReduction_897 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> + case happyOut341 happy_x_2 of { (HappyWrap341 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' $ (sLL happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn347 r)) + +happyReduce_898 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_898 = happyMonadReduce 2# 332# happyReduction_898 +happyReduction_898 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen ((case happyOut228 happy_x_1 of { (HappyWrap228 happy_var_1) -> + case happyOut340 happy_x_2 of { (HappyWrap340 happy_var_2) -> + ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> + fmap ecpFromExp $ + amsA' $ (sLL happy_var_1 happy_var_2 $ HsPragE noExtField (unLoc happy_var_1) happy_var_2))}}) + ) (\r -> happyReturn (happyIn348 r)) + +happyReduce_899 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_899 = happySpecReduce_3 333# happyReduction_899 +happyReduction_899 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut349 happy_x_1 of { (HappyWrap349 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut351 happy_x_3 of { (HappyWrap351 happy_var_3) -> + happyIn349 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[happy_var_3])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 : h' : t)) + )}}} + +happyReduce_900 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_900 = happySpecReduce_2 333# happyReduction_900 +happyReduction_900 happy_x_2 + happy_x_1 + = case happyOut349 happy_x_1 of { (HappyWrap349 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn349 + (happy_var_1 >>= \ happy_var_1 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t)) + )}} + +happyReduce_901 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_901 = happySpecReduce_1 333# happyReduction_901 +happyReduction_901 happy_x_1 + = case happyOut351 happy_x_1 of { (HappyWrap351 happy_var_1) -> + happyIn349 + (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) + )} + +happyReduce_902 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_902 = happySpecReduce_3 334# happyReduction_902 +happyReduction_902 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut350 happy_x_1 of { (HappyWrap350 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + case happyOut352 happy_x_3 of { (HappyWrap352 happy_var_3) -> + happyIn350 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLL happy_var_1 happy_var_3 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[happy_var_3])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 : h' : t)) + )}}} + +happyReduce_903 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_903 = happySpecReduce_2 334# happyReduction_903 +happyReduction_903 happy_x_2 + happy_x_1 + = case happyOut350 happy_x_1 of { (HappyWrap350 happy_var_1) -> + case happyOutTok happy_x_2 of { happy_var_2 -> + happyIn350 + (happy_var_1 >>= \ happy_var_1 -> + case snd $ unLoc happy_var_1 of + [] -> return (sLZ happy_var_1 happy_var_2 ((fst $ unLoc happy_var_1) ++ [mzEpTok happy_var_2] + ,[])) + (h:t) -> do + h' <- addTrailingSemiA h (epTok happy_var_2) + return (sLZ happy_var_1 happy_var_2 (fst $ unLoc happy_var_1, h' : t)) + )}} + +happyReduce_904 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_904 = happySpecReduce_1 334# happyReduction_904 +happyReduction_904 happy_x_1 + = case happyOut352 happy_x_1 of { (HappyWrap352 happy_var_1) -> + happyIn350 + (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) + )} + +happyReduce_905 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_905 = happySpecReduce_2 335# happyReduction_905 +happyReduction_905 happy_x_2 + happy_x_1 + = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> + case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> + happyIn351 + (happy_var_2 >>= \ happy_var_2 -> + amsA' (sLLAsl happy_var_1 happy_var_2 + (Match { m_ext = noExtField + , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing + , m_pats = L (listLocation happy_var_1) happy_var_1 + , m_grhss = unLoc happy_var_2 })) + )}} + +happyReduce_906 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_906 = happySpecReduce_2 336# happyReduction_906 +happyReduction_906 happy_x_2 + happy_x_1 + = case happyOut260 happy_x_1 of { (HappyWrap260 happy_var_1) -> + case happyOut253 happy_x_2 of { (HappyWrap253 happy_var_2) -> + happyIn352 + (happy_var_2 >>= \ happy_var_2 -> + amsA' (sLLAsl happy_var_1 happy_var_2 + (Match { m_ext = noExtField + , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing + , m_pats = L (listLocation happy_var_1) happy_var_1 + , m_grhss = unLoc happy_var_2 })) + )}} + +happyNewToken action sts stk + = (lexer True)(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ ITeof -> happyDoAction 161# tk action sts stk; + L _ ITunderscore -> cont 1#; + L _ ITas -> cont 2#; + L _ ITcase -> cont 3#; + L _ ITclass -> cont 4#; + L _ ITdata -> cont 5#; + L _ ITdefault -> cont 6#; + L _ ITderiving -> cont 7#; + L _ ITelse -> cont 8#; + L _ IThiding -> cont 9#; + L _ ITif -> cont 10#; + L _ ITimport -> cont 11#; + L _ ITin -> cont 12#; + L _ ITinfix -> cont 13#; + L _ ITinfixl -> cont 14#; + L _ ITinfixr -> cont 15#; + L _ ITinstance -> cont 16#; + L _ ITlet -> cont 17#; + L _ ITmodule -> cont 18#; + L _ ITnewtype -> cont 19#; + L _ ITof -> cont 20#; + L _ ITqualified -> cont 21#; + L _ ITthen -> cont 22#; + L _ ITtype -> cont 23#; + L _ ITwhere -> cont 24#; + L _ (ITforall _) -> cont 25#; + L _ ITforeign -> cont 26#; + L _ ITexport -> cont 27#; + L _ ITlabel -> cont 28#; + L _ ITdynamic -> cont 29#; + L _ ITsafe -> cont 30#; + L _ ITinterruptible -> cont 31#; + L _ ITunsafe -> cont 32#; + L _ ITfamily -> cont 33#; + L _ ITrole -> cont 34#; + L _ ITstdcallconv -> cont 35#; + L _ ITccallconv -> cont 36#; + L _ ITcapiconv -> cont 37#; + L _ ITprimcallconv -> cont 38#; + L _ ITjavascriptcallconv -> cont 39#; + L _ ITproc -> cont 40#; + L _ ITrec -> cont 41#; + L _ ITgroup -> cont 42#; + L _ ITby -> cont 43#; + L _ ITusing -> cont 44#; + L _ ITpattern -> cont 45#; + L _ ITstatic -> cont 46#; + L _ ITstock -> cont 47#; + L _ ITanyclass -> cont 48#; + L _ ITvia -> cont 49#; + L _ ITsplice -> cont 50#; + L _ ITquote -> cont 51#; + L _ ITunit -> cont 52#; + L _ ITsignature -> cont 53#; + L _ ITdependency -> cont 54#; + L _ (ITinline_prag _ _ _) -> cont 55#; + L _ (ITopaque_prag _) -> cont 56#; + L _ (ITspec_prag _) -> cont 57#; + L _ (ITspec_inline_prag _ _) -> cont 58#; + L _ (ITsource_prag _) -> cont 59#; + L _ (ITrules_prag _) -> cont 60#; + L _ (ITscc_prag _) -> cont 61#; + L _ (ITdeprecated_prag _) -> cont 62#; + L _ (ITwarning_prag _) -> cont 63#; + L _ (ITunpack_prag _) -> cont 64#; + L _ (ITnounpack_prag _) -> cont 65#; + L _ (ITann_prag _) -> cont 66#; + L _ (ITminimal_prag _) -> cont 67#; + L _ (ITctype _) -> cont 68#; + L _ (IToverlapping_prag _) -> cont 69#; + L _ (IToverlappable_prag _) -> cont 70#; + L _ (IToverlaps_prag _) -> cont 71#; + L _ (ITincoherent_prag _) -> cont 72#; + L _ (ITcomplete_prag _) -> cont 73#; + L _ ITclose_prag -> cont 74#; + L _ ITdotdot -> cont 75#; + L _ ITcolon -> cont 76#; + L _ (ITdcolon _) -> cont 77#; + L _ ITequal -> cont 78#; + L _ ITlam -> cont 79#; + L _ ITlcase -> cont 80#; + L _ ITlcases -> cont 81#; + L _ ITvbar -> cont 82#; + L _ (ITlarrow _) -> cont 83#; + L _ (ITrarrow _) -> cont 84#; + L _ ITlolly -> cont 85#; + L _ ITat -> cont 86#; + L _ (ITdarrow _) -> cont 87#; + L _ ITminus -> cont 88#; + L _ ITtilde -> cont 89#; + L _ ITbang -> cont 90#; + L _ ITprefixminus -> cont 91#; + L _ (ITstar _) -> cont 92#; + L _ (ITlarrowtail _) -> cont 93#; + L _ (ITrarrowtail _) -> cont 94#; + L _ (ITLarrowtail _) -> cont 95#; + L _ (ITRarrowtail _) -> cont 96#; + L _ ITdot -> cont 97#; + L _ (ITproj True) -> cont 98#; + L _ (ITproj False) -> cont 99#; + L _ ITtypeApp -> cont 100#; + L _ ITpercent -> cont 101#; + L _ ITocurly -> cont 102#; + L _ ITccurly -> cont 103#; + L _ ITvocurly -> cont 104#; + L _ ITvccurly -> cont 105#; + L _ ITobrack -> cont 106#; + L _ ITcbrack -> cont 107#; + L _ IToparen -> cont 108#; + L _ ITcparen -> cont 109#; + L _ IToubxparen -> cont 110#; + L _ ITcubxparen -> cont 111#; + L _ (IToparenbar _) -> cont 112#; + L _ (ITcparenbar _) -> cont 113#; + L _ ITsemi -> cont 114#; + L _ ITcomma -> cont 115#; + L _ ITbackquote -> cont 116#; + L _ ITsimpleQuote -> cont 117#; + L _ (ITvarid _) -> cont 118#; + L _ (ITconid _) -> cont 119#; + L _ (ITvarsym _) -> cont 120#; + L _ (ITconsym _) -> cont 121#; + L _ (ITqvarid _) -> cont 122#; + L _ (ITqconid _) -> cont 123#; + L _ (ITqvarsym _) -> cont 124#; + L _ (ITqconsym _) -> cont 125#; + L _ (ITdo _) -> cont 126#; + L _ (ITmdo _) -> cont 127#; + L _ (ITdupipvarid _) -> cont 128#; + L _ (ITlabelvarid _ _) -> cont 129#; + L _ (ITchar _ _) -> cont 130#; + L _ (ITstring _ _) -> cont 131#; + L _ (ITstringMulti _ _) -> cont 132#; + L _ (ITinteger _) -> cont 133#; + L _ (ITrational _) -> cont 134#; + L _ (ITprimchar _ _) -> cont 135#; + L _ (ITprimstring _ _) -> cont 136#; + L _ (ITprimint _ _) -> cont 137#; + L _ (ITprimword _ _) -> cont 138#; + L _ (ITprimint8 _ _) -> cont 139#; + L _ (ITprimint16 _ _) -> cont 140#; + L _ (ITprimint32 _ _) -> cont 141#; + L _ (ITprimint64 _ _) -> cont 142#; + L _ (ITprimword8 _ _) -> cont 143#; + L _ (ITprimword16 _ _) -> cont 144#; + L _ (ITprimword32 _ _) -> cont 145#; + L _ (ITprimword64 _ _) -> cont 146#; + L _ (ITprimfloat _) -> cont 147#; + L _ (ITprimdouble _) -> cont 148#; + L _ (ITopenExpQuote _ _) -> cont 149#; + L _ ITopenPatQuote -> cont 150#; + L _ ITopenTypQuote -> cont 151#; + L _ ITopenDecQuote -> cont 152#; + L _ (ITcloseQuote _) -> cont 153#; + L _ (ITopenTExpQuote _) -> cont 154#; + L _ ITcloseTExpQuote -> cont 155#; + L _ ITdollar -> cont 156#; + L _ ITdollardollar -> cont 157#; + L _ ITtyQuote -> cont 158#; + L _ (ITquasiQuote _) -> cont 159#; + L _ (ITqQuasiQuote _) -> cont 160#; + _ -> happyError' (tk, []) + }) + +happyError_ explist 161# tk = happyError' (tk, explist) +happyError_ explist _ tk = happyError' (tk, explist) + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn ) + +happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) + +happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) + +happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )) + +happyThen1 :: () => P a -> (a -> P b) -> P b +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => (((Located Token)), [Prelude.String]) -> P a +happyError' tk = (\(tokens, explist) -> happyError) tk +parseModuleNoHaddock = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap35 x') = happyOut35 x} in x')) + +parseSignatureNoHaddock = happySomeParser where + happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (let {(HappyWrap34 x') = happyOut34 x} in x')) + +parseImport = happySomeParser where + happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (let {(HappyWrap62 x') = happyOut62 x} in x')) + +parseStatement = happySomeParser where + happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (let {(HappyWrap268 x') = happyOut268 x} in x')) + +parseDeclaration = happySomeParser where + happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (let {(HappyWrap82 x') = happyOut82 x} in x')) + +parseExpression = happySomeParser where + happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (let {(HappyWrap221 x') = happyOut221 x} in x')) + +parsePattern = happySomeParser where + happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap259 x') = happyOut259 x} in x')) + +parseTypeSignature = happySomeParser where + happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap216 x') = happyOut216 x} in x')) + +parseStmt = happySomeParser where + happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap267 x') = happyOut267 x} in x')) + +parseIdentifier = happySomeParser where + happySomeParser = happyThen (happyParse 9#) (\x -> happyReturn (let {(HappyWrap16 x') = happyOut16 x} in x')) + +parseType = happySomeParser where + happySomeParser = happyThen (happyParse 10#) (\x -> happyReturn (let {(HappyWrap168 x') = happyOut168 x} in x')) + +parseBackpack = happySomeParser where + happySomeParser = happyThen (happyParse 11#) (\x -> happyReturn (let {(HappyWrap17 x') = happyOut17 x} in x')) + +parseHeader = happySomeParser where + happySomeParser = happyThen (happyParse 12#) (\x -> happyReturn (let {(HappyWrap42 x') = happyOut42 x} in x')) + +happySeq = happyDoSeq + + +happyError :: P a +happyError = srcParseFail + +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getDO (L _ (ITdo x)) = x +getMDO (L _ (ITmdo x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getLABELVARID (L _ (ITlabelvarid _ x)) = x +getCHAR (L _ (ITchar _ x)) = x +getSTRING (L _ (ITstring _ x)) = x +getSTRINGMULTI (L _ (ITstringMulti _ x)) = x +getINTEGER (L _ (ITinteger x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar _ x)) = x +getPRIMSTRING (L _ (ITprimstring _ x)) = x +getPRIMINTEGER (L _ (ITprimint _ x)) = x +getPRIMWORD (L _ (ITprimword _ x)) = x +getPRIMINTEGER8 (L _ (ITprimint8 _ x)) = x +getPRIMINTEGER16 (L _ (ITprimint16 _ x)) = x +getPRIMINTEGER32 (L _ (ITprimint32 _ x)) = x +getPRIMINTEGER64 (L _ (ITprimint64 _ x)) = x +getPRIMWORD8 (L _ (ITprimword8 _ x)) = x +getPRIMWORD16 (L _ (ITprimword16 _ x)) = x +getPRIMWORD32 (L _ (ITprimword32 _ x)) = x +getPRIMWORD64 (L _ (ITprimword64 _ x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getINLINE (L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (L _ (ITspec_inline_prag src True)) = (Inline src,FunLike) +getSPEC_INLINE (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike) +getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x +getVOCURLY (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l + +getINTEGERs (L _ (ITinteger (IL src _ _))) = src +getCHARs (L _ (ITchar src _)) = src +getSTRINGs (L _ (ITstring src _)) = src +getSTRINGMULTIs (L _ (ITstringMulti src _)) = src +getPRIMCHARs (L _ (ITprimchar src _)) = src +getPRIMSTRINGs (L _ (ITprimstring src _)) = src +getPRIMINTEGERs (L _ (ITprimint src _)) = src +getPRIMWORDs (L _ (ITprimword src _)) = src +getPRIMINTEGER8s (L _ (ITprimint8 src _)) = src +getPRIMINTEGER16s (L _ (ITprimint16 src _)) = src +getPRIMINTEGER32s (L _ (ITprimint32 src _)) = src +getPRIMINTEGER64s (L _ (ITprimint64 src _)) = src +getPRIMWORD8s (L _ (ITprimword8 src _)) = src +getPRIMWORD16s (L _ (ITprimword16 src _)) = src +getPRIMWORD32s (L _ (ITprimword32 src _)) = src +getPRIMWORD64s (L _ (ITprimword64 src _)) = src + +getLABELVARIDs (L _ (ITlabelvarid src _)) = src + +-- See Note [Pragma source text] in "GHC.Types.SourceText" for the following +getINLINE_PRAGs (L _ (ITinline_prag _ inl _)) = inlineSpecSource inl +getOPAQUE_PRAGs (L _ (ITopaque_prag src)) = src +getSPEC_PRAGs (L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (L _ (ITsource_prag src)) = src +getRULES_PRAGs (L _ (ITrules_prag src)) = src +getWARNING_PRAGs (L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (L _ (ITscc_prag src)) = src +getUNPACK_PRAGs (L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (L _ (ITnounpack_prag src)) = src +getANN_PRAGs (L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src +getCTYPEs (L _ (ITctype src)) = src + +getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing +getStringMultiLiteral l = StringLiteral (getSTRINGMULTIs l) (getSTRINGMULTI l) Nothing + +isUnicode :: Located Token -> Bool +isUnicode (L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode (L _ ITlolly) = True +isUnicode _ = False + +hasE :: Located Token -> Bool +hasE (L _ (ITopenExpQuote HasE _)) = True +hasE (L _ (ITopenTExpQuote HasE)) = True +hasE _ = False + +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC + else return s + +stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs) +stringLiteralToHsDocWst sl = reLoc $ lexStringLiteral parseIdentifier sl + +-- Utilities for combining source spans +comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan +comb2 !a !b = combineHasLocs a b + +comb3 :: (HasLoc a, HasLoc b, HasLoc c) => a -> b -> c -> SrcSpan +comb3 !a !b !c = combineSrcSpans (getHasLoc a) (combineHasLocs b c) + +comb4 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d) => a -> b -> c -> d -> SrcSpan +comb4 !a !b !c !d = + combineSrcSpans (getHasLoc a) $ + combineSrcSpans (getHasLoc b) $ + combineSrcSpans (getHasLoc c) (getHasLoc d) + +comb5 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e) => a -> b -> c -> d -> e -> SrcSpan +comb5 !a !b !c !d !e = + combineSrcSpans (getHasLoc a) $ + combineSrcSpans (getHasLoc b) $ + combineSrcSpans (getHasLoc c) $ + combineSrcSpans (getHasLoc d) (getHasLoc e) + +comb6 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e, HasLoc f) => a -> b -> c -> d -> e -> f -> SrcSpan +comb6 !a !b !c !d !e !f = + combineSrcSpans (getHasLoc a) $ + combineSrcSpans (getHasLoc b) $ + combineSrcSpans (getHasLoc c) $ + combineSrcSpans (getHasLoc d) $ + combineSrcSpans (getHasLoc e) (getHasLoc f) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: l -> a -> GenLocated l a +sL !loc !a = L loc a + +-- See Note [Adding location info] for how these utility functions are used + +-- replaced last 3 CPP macros in this file +{-# INLINE sL0 #-} +sL0 :: a -> Located a +sL0 = L noSrcSpan -- #define L0 L noSrcSpan + +{-# INLINE sL1 #-} +sL1 :: HasLoc a => a -> b -> Located b +sL1 !x = sL (getHasLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1a #-} +sL1a :: (HasLoc a, HasAnnotation t) => a -> b -> GenLocated t b +sL1a !x = sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sL1n #-} +sL1n :: HasLoc a => a -> b -> LocatedN b +sL1n !x = L (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sLL #-} +sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c +sLL !x !y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLa #-} +sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c +sLLa !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLl #-} +sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c +sLLl !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLld #-} +sLLld :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedLW c +sLLld !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>) + +{-# INLINE sLLAsl #-} +sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c +sLLAsl [] = sL1 +sLLAsl (!x:_) = sLL x + +{-# INLINE sLZ #-} +sLZ :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c +sLZ !x !y = if isZeroWidthSpan (getHasLoc y) + then sL (getHasLoc x) + else sL (comb2 x y) + +{- Note [Adding location info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This is done using the three functions below, sL0, sL1 +and sLL. Note that these functions were mechanically +converted from the three macros that used to exist before, +namely L0, L1 and LL. + +They each add a SrcSpan to their argument. + + sL0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak + + sL1 for a production with a single token on the lhs. Grabs the SrcSpan + from that token. + + sLL for a production with >1 token on the lhs. Makes up a SrcSpan from + the first and last tokens. + +These suffice for the majority of cases. However, we must be +especially careful with empty productions: sLL won't work if the first +or last token on the lhs can represent an empty span. In these cases, +we have to calculate the span using more of the tokens from the lhs, eg. + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } + +We provide comb3 and comb4 functions which are useful in such cases. + +Be careful: there's no checking that you actually got this right, the +only symptom will be that the SrcSpans of your syntax will be +incorrect. + +-} + +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). +fileSrcSpan :: P SrcSpan +fileSrcSpan = do + l <- getRealSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 1; + return (mkSrcSpan loc loc) + +-- Hint about linear types +hintLinear :: MonadP m => SrcSpan -> m () +hintLinear span = do + linearEnabled <- getBit LinearTypesBit + unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction + +-- Does this look like (a %m)? +looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool +looksLikeMult ty1 l_op ty2 + | Unqual op_name <- unLoc l_op + , occNameFS op_name == fsLit "%" + , Strict.Just ty1_pos <- getBufSpan (getLocA ty1) + , Strict.Just pct_pos <- getBufSpan (getLocA l_op) + , Strict.Just ty2_pos <- getBufSpan (getLocA ty2) + , bufSpanEnd ty1_pos /= bufSpanStart pct_pos + , bufSpanEnd pct_pos == bufSpanStart ty2_pos + = True + | otherwise = False + +-- Hint about or-patterns +hintOrPats :: MonadP m => LPat GhcPs -> m (LPat GhcPs) +hintOrPats pat = do + orPatsEnabled <- getBit OrPatternsBit + unless orPatsEnabled $ addError $ mkPlainErrorMsgEnvelope (locA (getLoc pat)) $ PsErrIllegalOrPat pat + return pat + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- getBit MultiWayIfBit + unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf + +-- Hint about explicit-forall +hintExplicitForall :: Located Token -> P () +hintExplicitForall tok = do + explicit_forall_enabled <- getBit ExplicitForallBit + in_rule_prag <- getBit InRulePragBit + unless (explicit_forall_enabled || in_rule_prag) $ + addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ + PsErrExplicitForall (isUnicode tok) + +-- Hint about qualified-do +hintQualifiedDo :: Located Token -> P () +hintQualifiedDo tok = do + qualifiedDo <- getBit QualifiedDoBit + case maybeQDoDoc of + Just qdoDoc | not qualifiedDo -> + addError $ mkPlainErrorMsgEnvelope (getLoc tok) $ + (PsErrIllegalQualifiedDo qdoDoc) + _ -> return () + where + maybeQDoDoc = case unLoc tok of + ITdo (Just m) -> Just $ ftext m <> text ".do" + ITmdo (Just m) -> Just $ ftext m <> text ".mdo" + t -> Nothing + +-- When two single quotes don't followed by tyvar or gtycon, we report the +-- error as empty character literal, or TH quote that missing proper type +-- variable or constructor. See #13450. +reportEmptyDoubleQuotes :: SrcSpan -> P a +reportEmptyDoubleQuotes span = do + thQuotes <- getBit ThQuotesBit + addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ + +For the general principles of the following routines, see Note [exact print annotations] +in GHC.Parser.Annotation + +-} + +msemi :: Located Token -> [TrailingAnn] +msemi !l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (epTok l)] + +msemiA :: Located Token -> [EpToken ";"] +msemiA !l = if isZeroWidthSpan (gl l) then [] else [epTok l] + +msemim :: Located Token -> Maybe (EpToken ";") +msemim !l = if isZeroWidthSpan (gl l) then Nothing else Just (epTok l) + +toUnicode :: Located Token -> IsUnicodeSyntax +toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax + +-- ------------------------------------- + +gl :: GenLocated l a -> l +gl = getLoc + +glA :: HasLoc a => a -> SrcSpan +glA = getHasLoc + +glR :: HasLoc a => a -> EpaLocation +glR !la = EpaSpan (getHasLoc la) + +glEE :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation +glEE !x !y = spanAsAnchor $ comb2 x y + +glEEz :: (HasLoc a, HasLoc b) => a -> b -> EpaLocation +glEEz !x !y = if isZeroWidthSpan (getHasLoc y) + then spanAsAnchor (getHasLoc x) + else spanAsAnchor $ comb2 x y + +glRM :: Located a -> Maybe EpaLocation +glRM (L !l _) = Just $ spanAsAnchor l + +n2l :: LocatedN a -> LocatedA a +n2l (L !la !a) = L (l2l la) a + +-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet. +acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a) +acsFinal a = do + let (L l _) = a emptyComments Nothing + !cs <- getCommentsFor l + csf <- getFinalCommentsFor l + meof <- getEofPos + let ce = case meof of + Strict.Nothing -> Nothing + Strict.Just (pos `Strict.And` gap) -> Just (pos,gap) + return (a (cs Semi.<> csf) ce) + +acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a) +acs !l a = do + !cs <- getCommentsFor (locA l) + return (a l cs) + +acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a) +acsA !l a = do + !cs <- getCommentsFor (locA l) + return $ reLoc (a l cs) + +ams1 :: MonadP m => Located a -> b -> m (LocatedA b) +ams1 (L l a) b = do + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) b) + +amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a) +amsA' (L l a) = do + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) a) + +amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a) +amsA (L !l a) bs = do + !cs <- getCommentsFor (locA l) + return (L (addAnnsA l bs cs) a) + +amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a) +amsAl (L l a) loc bs = do + !cs <- getCommentsFor loc + return (L (addAnnsA l bs cs) a) + +amsr :: MonadP m => Located a -> an -> m (LocatedAn an a) +amsr (L l a) an = do + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) an cs) a) + +-- | Parse a Haskell module with Haddock comments. This is done in two steps: +-- +-- * 'parseModuleNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This and the signature module parser are the only parser entry points that +-- deal with Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. +parseModule :: P (Located (HsModule GhcPs)) +parseModule = parseModuleNoHaddock >>= addHaddockToModule + +-- | Parse a Haskell signature module with Haddock comments. This is done in two +-- steps: +-- +-- * 'parseSignatureNoHaddock' to build the AST +-- * 'addHaddockToModule' to insert Haddock comments into it +-- +-- This and the module parser are the only parser entry points that deal with +-- Haddock comments. The other entry points ('parseDeclaration', +-- 'parseExpression', etc) do not insert them into the AST. +parseSignature :: P (Located (HsModule GhcPs)) +parseSignature = parseSignatureNoHaddock >>= addHaddockToModule + +commentsA :: (NoAnn ann) => SrcSpan -> EpAnnComments -> EpAnn ann +commentsA loc cs = EpAnn (EpaSpan loc) noAnn cs + +spanWithComments :: (NoAnn ann, MonadP m) => SrcSpan -> m (EpAnn ann) +spanWithComments l = do + !cs <- getCommentsFor l + return (commentsA l cs) + +-- | Instead of getting the *enclosed* comments, this includes the +-- *preceding* ones. It is used at the top level to get comments +-- between top level declarations. +commentsPA :: (NoAnn ann) => LocatedAn ann a -> P (LocatedAn ann a) +commentsPA la@(L l a) = do + !cs <- getPriorCommentsFor (getLocA la) + return (L (addCommentsToEpAnn l cs) a) + +hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec") +hsDoAnn tok (L ll _) + = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok [] + +listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation +listAsAnchorM [] = Nothing +listAsAnchorM (L l _:_) = + case locA l of + RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll + _ -> Nothing + +epTok :: Located Token -> EpToken tok +epTok (L !l _) = EpTok (EpaSpan l) + +epUniTok :: Located Token -> EpUniToken tok utok +epUniTok t@(L !l _) = EpUniTok (EpaSpan l) u + where + u = if isUnicode t then UnicodeSyntax else NormalSyntax + +-- |Construct an EpToken from the location of the token, provided the span is not zero width +mzEpTok :: Located Token -> EpToken tok +mzEpTok !l = if isZeroWidthSpan (gl l) then NoEpTok else (epTok l) + +epExplicitBraces :: Located Token -> Located Token -> EpLayout +epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2) + +-- ------------------------------------- + +addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b) +addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l) +addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l) + +addTrailingVbarA :: MonadP m => LocatedA a -> EpToken "|" -> m (LocatedA a) +addTrailingVbarA la tok = addTrailingAnnA la tok AddVbarAnn + +addTrailingSemiA :: MonadP m => LocatedA a -> EpToken ";" -> m (LocatedA a) +addTrailingSemiA la span = addTrailingAnnA la span AddSemiAnn + +addTrailingCommaA :: MonadP m => LocatedA a -> EpToken "," -> m (LocatedA a) +addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn + +addTrailingAnnA :: (MonadP m, HasLoc tok) => LocatedA a -> tok -> (tok -> TrailingAnn) -> m (LocatedA a) +addTrailingAnnA (L anns a) tok ta = do + let cs = emptyComments + -- AZ:TODO: generalise updating comments into an annotation + let + anns' = if isZeroWidthSpan (getHasLoc tok) + then anns + else addTrailingAnnToA (ta tok) cs anns + return (L anns' a) + +-- ------------------------------------- + +addTrailingVbarL :: MonadP m => LocatedL a -> EpToken "|" -> m (LocatedL a) +addTrailingVbarL la tok = addTrailingAnnL la (AddVbarAnn tok) + +addTrailingCommaL :: MonadP m => LocatedL a -> EpToken "," -> m (LocatedL a) +addTrailingCommaL la tok = addTrailingAnnL la (AddCommaAnn tok) + +addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) +addTrailingAnnL (L anns a) ta = do + !cs <- getCommentsFor (locA anns) + let anns' = addTrailingAnnToL ta cs anns + return (L anns' a) + +-- ------------------------------------- + +-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation +addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) +addTrailingCommaN (L anns a) span = do + let cs = emptyComments + -- AZ:TODO: generalise updating comments into an annotation + let anns' = if isZeroWidthSpan span + then anns + else addTrailingCommaToN anns (srcSpan2e span) + return (L anns' a) + +addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral +addTrailingCommaS (L l sl) span + = L (widenSpanL l [span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) }) + +-- ------------------------------------- + +addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a +addTrailingDarrowC (L (EpAnn lr (AnnContext _ o c) csc) a) lt cs = + let + u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax + in L (EpAnn lr (AnnContext (Just (epUniTok lt)) o c) (cs Semi.<> csc)) a + +-- ------------------------------------- + +isUnicodeSyntax :: Located Token -> IsUnicodeSyntax +isUnicodeSyntax lt = if isUnicode lt then UnicodeSyntax else NormalSyntax + +-- We need a location for the where binds, when computing the SrcSpan +-- for the AST element using them. Where there is a span, we return +-- it, else noLoc, which is ignored in the comb2 call. +adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments)) + -> Located (HsLocalBinds GhcPs, EpAnnComments) +adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments) +adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc) + +combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan +combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b) + +fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA +fromTrailingN (EpAnn anc ann cs) + = EpAnn anc (AnnListItem (nann_trailing ann)) cs {-# LINE 1 "templates/GenericTemplate.hs" #-} -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ diff --git a/GHC/Parser/Annotation.hs b/GHC/Parser/Annotation.hs --- a/GHC/Parser/Annotation.hs +++ b/GHC/Parser/Annotation.hs @@ -1,1306 +1,1271 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} - -module GHC.Parser.Annotation ( - -- * Core Exact Print Annotation types - AnnKeywordId(..), - EpaComment(..), EpaCommentTok(..), - IsUnicodeSyntax(..), - unicodeAnn, - HasE(..), - - -- * In-tree Exact Print Annotations - AddEpAnn(..), - EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn, - TokenLocation(..), - getTokenSrcSpan, - DeltaPos(..), deltaPos, getDeltaLine, - - EpAnn(..), Anchor(..), AnchorOperation(..), - spanAsAnchor, realSpanAsAnchor, - noAnn, - - -- ** Comments in Annotations - - EpAnnComments(..), LEpaComment, emptyComments, - getFollowingComments, setFollowingComments, setPriorComments, - EpAnnCO, - - -- ** Annotations in 'GenLocated' - LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP, - SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, - SrcSpanAnn'(..), SrcAnn, - - -- ** Annotation data types used in 'GenLocated' - - AnnListItem(..), AnnList(..), - AnnParen(..), ParenType(..), parenTypeKws, - AnnPragma(..), - AnnContext(..), - NameAnn(..), NameAdornment(..), - NoEpAnns(..), - AnnSortKey(..), - - -- ** Trailing annotations in lists - TrailingAnn(..), trailingAnnToAddEpAnn, - addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN, - - -- ** Utilities for converting between different 'GenLocated' when - -- ** we do not care about the annotations. - la2na, na2la, n2l, l2n, l2l, la2la, - reLoc, reLocA, reLocL, reLocC, reLocN, - - srcSpan2e, la2e, realSrcSpan, - - -- ** Building up annotations - extraToAnnList, reAnn, - reAnnL, reAnnC, - addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorR, widenLocatedAn, - - -- ** Querying annotations - getLocAnn, - epAnnAnns, epAnnAnnsL, - annParen2AddEpAnn, - epAnnComments, - - -- ** Working with locations of annotations - sortLocatedA, - mapLocA, - combineLocsA, - combineSrcSpansA, - addCLocA, addCLocAA, - - -- ** Constructing 'GenLocated' annotation types when we do not care - -- about annotations. - noLocA, getLocA, - noSrcSpanA, - noAnnSrcSpan, - - -- ** Working with comments in annotations - noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn, - addCommentsToEpAnn, setCommentsEpAnn, - transferAnnsA, commentsOnlyA, removeCommentsA, - - placeholderRealSpan, - ) where - -import GHC.Prelude - -import Data.Data -import Data.Function (on) -import Data.List (sortBy) -import Data.Semigroup -import GHC.Data.FastString -import GHC.Types.Name -import GHC.Types.SrcLoc -import GHC.Hs.DocString -import GHC.Utils.Outputable hiding ( (<>) ) -import GHC.Utils.Panic -import qualified GHC.Data.Strict as Strict - -{- -Note [exact print annotations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a parse tree of a Haskell module, how can we reconstruct -the original Haskell source code, retaining all whitespace and -source code comments? We need to track the locations of all -elements from the original source: this includes keywords such as -'let' / 'in' / 'do' etc as well as punctuation such as commas and -braces, and also comments. We collectively refer to this -metadata as the "exact print annotations". - -NON-COMMENT ELEMENTS - -Intuitively, every AST element directly contains a bag of keywords -(keywords can show up more than once in a node: a semicolon i.e. newline -can show up multiple times before the next AST element), each of which -needs to be associated with its location in the original source code. - -These keywords are recorded directly in the AST element in which they -occur, for the GhcPs phase. - -For any given element in the AST, there is only a set number of -keywords that are applicable for it (e.g., you'll never see an -'import' keyword associated with a let-binding.) The set of allowed -keywords is documented in a comment associated with the constructor -of a given AST element, although the ground truth is in GHC.Parser -and GHC.Parser.PostProcess (which actually add the annotations). - -COMMENT ELEMENTS - -We associate comments with the lowest (most specific) AST element -enclosing them - -PARSER STATE - -There are three fields in PState (the parser state) which play a role -with annotation comments. - -> comment_q :: [LEpaComment], -> header_comments :: Maybe [LEpaComment], -> eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token - -The 'comment_q' field captures comments as they are seen in the token stream, -so that when they are ready to be allocated via the parser they are -available. - -The 'header_comments' capture the comments coming at the top of the -source file. They are moved there from the `comment_q` when comments -are allocated for the first top-level declaration. - -The 'eof_pos' captures the final location in the file, and the -location of the immediately preceding token to the last location, so -that the exact-printer can work out how far to advance to add the -trailing whitespace. - -PARSER EMISSION OF ANNOTATIONS - -The parser interacts with the lexer using the functions - -> getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments - -The 'getCommentsFor' function is the one used most often. It takes -the AST element SrcSpan and removes and returns any comments in the -'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is -responsible for making sure we only return comments that actually fit -in the 'SrcSpan'. - -The 'getPriorCommentsFor' function is used for top-level declarations, -and removes and returns any comments in the 'comment_q' that either -precede or are included in the given SrcSpan. This is to ensure that -preceding documentation comments are kept together with the -declaration they belong to. - -The 'getFinalCommentsFor' function is called right at the end when EOF -is hit. This drains the 'comment_q' completely, and returns the -'header_comments', remaining 'comment_q' entries and the -'eof_pos'. These values are inserted into the 'HsModule' AST element. - -The wiki page describing this feature is -https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations - --} - --- -------------------------------------------------------------------- - --- | Exact print annotations exist so that tools can perform source to --- source conversions of Haskell code. They are used to keep track of --- the various syntactic keywords that are not otherwise captured in the --- AST. --- --- The wiki page describing this feature is --- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations --- https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow/in-tree-api-annotations --- --- Note: in general the names of these are taken from the --- corresponding token, unless otherwise noted --- See Note [exact print annotations] above for details of the usage -data AnnKeywordId - = AnnAnyclass - | AnnAs - | AnnBang -- ^ '!' - | AnnBackquote -- ^ '`' - | AnnBy - | AnnCase -- ^ case or lambda case - | AnnCases -- ^ lambda cases - | AnnClass - | AnnClose -- ^ '\#)' or '\#-}' etc - | AnnCloseB -- ^ '|)' - | AnnCloseBU -- ^ '|)', unicode variant - | AnnCloseC -- ^ '}' - | AnnCloseQ -- ^ '|]' - | AnnCloseQU -- ^ '|]', unicode variant - | AnnCloseP -- ^ ')' - | AnnClosePH -- ^ '\#)' - | AnnCloseS -- ^ ']' - | AnnColon - | AnnComma -- ^ as a list separator - | AnnCommaTuple -- ^ in a RdrName for a tuple - | AnnDarrow -- ^ '=>' - | AnnDarrowU -- ^ '=>', unicode variant - | AnnData - | AnnDcolon -- ^ '::' - | AnnDcolonU -- ^ '::', unicode variant - | AnnDefault - | AnnDeriving - | AnnDo - | AnnDot -- ^ '.' - | AnnDotdot -- ^ '..' - | AnnElse - | AnnEqual - | AnnExport - | AnnFamily - | AnnForall - | AnnForallU -- ^ Unicode variant - | AnnForeign - | AnnFunId -- ^ for function name in matches where there are - -- multiple equations for the function. - | AnnGroup - | AnnHeader -- ^ for CType - | AnnHiding - | AnnIf - | AnnImport - | AnnIn - | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' - | AnnInstance - | AnnLam - | AnnLarrow -- ^ '<-' - | AnnLarrowU -- ^ '<-', unicode variant - | AnnLet - | AnnLollyU -- ^ The '⊸' unicode arrow - | AnnMdo - | AnnMinus -- ^ '-' - | AnnModule - | AnnNewtype - | AnnName -- ^ where a name loses its location in the AST, this carries it - | AnnOf - | AnnOpen -- ^ '{-\# DEPRECATED' etc. Opening of pragmas where - -- the capitalisation of the string can be changed by - -- the user. The actual text used is stored in a - -- 'SourceText' on the relevant pragma item. - | AnnOpenB -- ^ '(|' - | AnnOpenBU -- ^ '(|', unicode variant - | AnnOpenC -- ^ '{' - | AnnOpenE -- ^ '[e|' or '[e||' - | AnnOpenEQ -- ^ '[|' - | AnnOpenEQU -- ^ '[|', unicode variant - | AnnOpenP -- ^ '(' - | AnnOpenS -- ^ '[' - | AnnOpenPH -- ^ '(\#' - | AnnDollar -- ^ prefix '$' -- TemplateHaskell - | AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell - | AnnPackageName - | AnnPattern - | AnnPercent -- ^ '%' -- for HsExplicitMult - | AnnPercentOne -- ^ '%1' -- for HsLinearArrow - | AnnProc - | AnnQualified - | AnnRarrow -- ^ '->' - | AnnRarrowU -- ^ '->', unicode variant - | AnnRec - | AnnRole - | AnnSafe - | AnnSemi -- ^ ';' - | AnnSimpleQuote -- ^ ''' - | AnnSignature - | AnnStatic -- ^ 'static' - | AnnStock - | AnnThen - | AnnThTyQuote -- ^ double ''' - | AnnTilde -- ^ '~' - | AnnType - | AnnUnit -- ^ '()' for types - | AnnUsing - | AnnVal -- ^ e.g. INTEGER - | AnnValStr -- ^ String value, will need quotes when output - | AnnVbar -- ^ '|' - | AnnVia -- ^ 'via' - | AnnWhere - | Annlarrowtail -- ^ '-<' - | AnnlarrowtailU -- ^ '-<', unicode variant - | Annrarrowtail -- ^ '->' - | AnnrarrowtailU -- ^ '->', unicode variant - | AnnLarrowtail -- ^ '-<<' - | AnnLarrowtailU -- ^ '-<<', unicode variant - | AnnRarrowtail -- ^ '>>-' - | AnnRarrowtailU -- ^ '>>-', unicode variant - deriving (Eq, Ord, Data, Show) - -instance Outputable AnnKeywordId where - ppr x = text (show x) - --- | Certain tokens can have alternate representations when unicode syntax is --- enabled. This flag is attached to those tokens in the lexer so that the --- original source representation can be reproduced in the corresponding --- 'EpAnnotation' -data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax - deriving (Eq, Ord, Data, Show) - --- | Convert a normal annotation into its unicode equivalent one -unicodeAnn :: AnnKeywordId -> AnnKeywordId -unicodeAnn AnnForall = AnnForallU -unicodeAnn AnnDcolon = AnnDcolonU -unicodeAnn AnnLarrow = AnnLarrowU -unicodeAnn AnnRarrow = AnnRarrowU -unicodeAnn AnnDarrow = AnnDarrowU -unicodeAnn Annlarrowtail = AnnlarrowtailU -unicodeAnn Annrarrowtail = AnnrarrowtailU -unicodeAnn AnnLarrowtail = AnnLarrowtailU -unicodeAnn AnnRarrowtail = AnnRarrowtailU -unicodeAnn AnnOpenB = AnnOpenBU -unicodeAnn AnnCloseB = AnnCloseBU -unicodeAnn AnnOpenEQ = AnnOpenEQU -unicodeAnn AnnCloseQ = AnnCloseQU -unicodeAnn ann = ann - - --- | Some template haskell tokens have two variants, one with an `e` the other --- not: --- --- > [| or [e| --- > [|| or [e|| --- --- This type indicates whether the 'e' is present or not. -data HasE = HasE | NoE - deriving (Eq, Ord, Data, Show) - --- --------------------------------------------------------------------- - -data EpaComment = - EpaComment - { ac_tok :: EpaCommentTok - , ac_prior_tok :: RealSrcSpan - -- ^ The location of the prior token, used in exact printing. The - -- 'EpaComment' appears as an 'LEpaComment' containing its - -- location. The difference between the end of the prior token - -- and the start of this location is used for the spacing when - -- exact printing the comment. - } - deriving (Eq, Data, Show) - -data EpaCommentTok = - -- Documentation annotations - EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString - | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) - | EpaLineComment String -- ^ comment starting by "--" - | EpaBlockComment String -- ^ comment in {- -} - | EpaEofComment -- ^ empty comment, capturing - -- location of EOF - - -- See #19697 for a discussion of EpaEofComment's use and how it - -- should be removed in favour of capturing it in the location for - -- 'Located HsModule' in the parser. - - deriving (Eq, Data, Show) --- Note: these are based on the Token versions, but the Token type is --- defined in GHC.Parser.Lexer and bringing it in here would create a loop - -instance Outputable EpaComment where - ppr x = text (show x) - --- --------------------------------------------------------------------- - --- | Captures an annotation, storing the @'AnnKeywordId'@ and its --- location. The parser only ever inserts @'EpaLocation'@ fields with a --- RealSrcSpan being the original location of the annotation in the --- source file. --- The @'EpaLocation'@ can also store a delta position if the AST has been --- modified and needs to be pretty printed again. --- The usual way an 'AddEpAnn' is created is using the 'mj' ("make --- jump") function, and then it can be inserted into the appropriate --- annotation. -data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) - --- | The anchor for an @'AnnKeywordId'@. The Parser inserts the --- @'EpaSpan'@ variant, giving the exact location of the original item --- in the parsed source. This can be replaced by the @'EpaDelta'@ --- version, to provide a position for the item relative to the end of --- the previous item in the source. This is useful when editing an --- AST prior to exact printing the changed one. The list of comments --- in the @'EpaDelta'@ variant captures any comments between the prior --- output and the thing being marked here, since we cannot otherwise --- sort the relative order. -data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) - | EpaDelta !DeltaPos ![LEpaComment] - deriving (Data,Eq) - --- | Tokens embedded in the AST have an EpaLocation, unless they come from --- generated code (e.g. by TH). -data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation - deriving (Data,Eq) - -getTokenSrcSpan :: TokenLocation -> SrcSpan -getTokenSrcSpan NoTokenLoc = noSrcSpan -getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan -getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos - -instance Outputable a => Outputable (GenLocated TokenLocation a) where - ppr (L _ x) = ppr x - --- | Spacing between output items when exact printing. It captures --- the spacing from the current print position on the page to the --- position required for the thing about to be printed. This is --- either on the same line in which case is is simply the number of --- spaces to emit, or it is some number of lines down, with a given --- column offset. The exact printing algorithm keeps track of the --- column offset pertaining to the current anchor position, so the --- `deltaColumn` is the additional spaces to add in this case. See --- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for --- details. -data DeltaPos - = SameLine { deltaColumn :: !Int } - | DifferentLine - { deltaLine :: !Int, -- ^ deltaLine should always be > 0 - deltaColumn :: !Int - } deriving (Show,Eq,Ord,Data) - --- | Smart constructor for a 'DeltaPos'. It preserves the invariant --- that for the 'DifferentLine' constructor 'deltaLine' is always > 0. -deltaPos :: Int -> Int -> DeltaPos -deltaPos l c = case l of - 0 -> SameLine c - _ -> DifferentLine l c - -getDeltaLine :: DeltaPos -> Int -getDeltaLine (SameLine _) = 0 -getDeltaLine (DifferentLine r _) = r - --- | Used in the parser only, extract the 'RealSrcSpan' from an --- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the --- partial function is safe. -epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan -epaLocationRealSrcSpan (EpaSpan r _) = r -epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan" - -epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation -epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing -epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing - -instance Outputable EpaLocation where - ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r - ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs - -instance Outputable AddEpAnn where - ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss - --- --------------------------------------------------------------------- - --- | The exact print annotations (EPAs) are kept in the HsSyn AST for --- the GhcPs phase. We do not always have EPAs though, only for code --- that has been parsed as they do not exist for generated --- code. This type captures that they may be missing. --- --- A goal of the annotations is that an AST can be edited, including --- moving subtrees from one place to another, duplicating them, and so --- on. This means that each fragment must be self-contained. To this --- end, each annotated fragment keeps track of the anchor position it --- was originally captured at, being simply the start span of the --- topmost element of the ast fragment. This gives us a way to later --- re-calculate all Located items in this layer of the AST, as well as --- any annotations captured. The comments associated with the AST --- fragment are also captured here. --- --- The 'ann' type parameter allows this general structure to be --- specialised to the specific set of locations of original exact --- print annotation elements. So for 'HsLet' we have --- --- type instance XLet GhcPs = EpAnn AnnsLet --- data AnnsLet --- = AnnsLet { --- alLet :: EpaLocation, --- alIn :: EpaLocation --- } deriving Data --- --- The spacing between the items under the scope of a given EpAnn is --- normally derived from the original 'Anchor'. But if a sub-element --- is not in its original position, the required spacing can be --- directly captured in the 'anchor_op' field of the 'entry' Anchor. --- This allows us to freely move elements around, and stitch together --- new AST fragments out of old ones, and have them still printed out --- in a precise way. -data EpAnn ann - = EpAnn { entry :: !Anchor - -- ^ Base location for the start of the syntactic element - -- holding the annotations. - , anns :: !ann -- ^ Annotations added by the Parser - , comments :: !EpAnnComments - -- ^ Comments enclosed in the SrcSpan of the element - -- this `EpAnn` is attached to - } - | EpAnnNotUsed -- ^ No Annotation for generated code, - -- e.g. from TH, deriving, etc. - deriving (Data, Eq, Functor) - --- | An 'Anchor' records the base location for the start of the --- syntactic element holding the annotations, and is used as the point --- of reference for calculating delta positions for contained --- annotations. --- It is also normally used as the reference point for the spacing of --- the element relative to its container. If it is moved, that --- relationship is tracked in the 'anchor_op' instead. - -data Anchor = Anchor { anchor :: RealSrcSpan - -- ^ Base location for the start of - -- the syntactic element holding - -- the annotations. - , anchor_op :: AnchorOperation } - deriving (Data, Eq, Show) - --- | If tools modify the parsed source, the 'MovedAnchor' variant can --- directly provide the spacing for this item relative to the previous --- one when printing. This allows AST fragments with a particular --- anchor to be freely moved, without worrying about recalculating the --- appropriate anchor span. -data AnchorOperation = UnchangedAnchor - | MovedAnchor DeltaPos - deriving (Data, Eq, Show) - - -spanAsAnchor :: SrcSpan -> Anchor -spanAsAnchor s = Anchor (realSrcSpan s) UnchangedAnchor - -realSpanAsAnchor :: RealSrcSpan -> Anchor -realSpanAsAnchor s = Anchor s UnchangedAnchor - --- --------------------------------------------------------------------- - --- | When we are parsing we add comments that belong a particular AST --- element, and print them together with the element, interleaving --- them into the output stream. But when editing the AST to move --- fragments around it is useful to be able to first separate the --- comments into those occurring before the AST element and those --- following it. The 'EpaCommentsBalanced' constructor is used to do --- this. The GHC parser will only insert the 'EpaComments' form. -data EpAnnComments = EpaComments - { priorComments :: ![LEpaComment] } - | EpaCommentsBalanced - { priorComments :: ![LEpaComment] - , followingComments :: ![LEpaComment] } - deriving (Data, Eq) - -type LEpaComment = GenLocated Anchor EpaComment - -emptyComments :: EpAnnComments -emptyComments = EpaComments [] - --- --------------------------------------------------------------------- --- Annotations attached to a 'SrcSpan'. --- --------------------------------------------------------------------- - --- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with --- an extra annotation type. This is mapped to a specific `GenLocated` --- usage in the AST through the `XRec` and `Anno` type families. - --- Important that the fields are strict as these live inside L nodes which --- are live for a long time. -data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan } - deriving (Data, Eq) --- See Note [XRec and Anno in the AST] - --- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\'' -type SrcAnn ann = SrcSpanAnn' (EpAnn ann) - -type LocatedA = GenLocated SrcSpanAnnA -type LocatedN = GenLocated SrcSpanAnnN - -type LocatedL = GenLocated SrcSpanAnnL -type LocatedP = GenLocated SrcSpanAnnP -type LocatedC = GenLocated SrcSpanAnnC - -type SrcSpanAnnA = SrcAnn AnnListItem -type SrcSpanAnnN = SrcAnn NameAnn - -type SrcSpanAnnL = SrcAnn AnnList -type SrcSpanAnnP = SrcAnn AnnPragma -type SrcSpanAnnC = SrcAnn AnnContext - --- | General representation of a 'GenLocated' type carrying a --- parameterised annotation type. -type LocatedAn an = GenLocated (SrcAnn an) - -{- -Note [XRec and Anno in the AST] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The exact print annotations are captured directly inside the AST, using -TTG extension points. However certain annotations need to be captured -on the Located versions too. While there is a general form for these, -captured in the type SrcSpanAnn', there are also specific usages in -different contexts. - -Some of the particular use cases are - -1) RdrNames, which can have additional items such as backticks or parens - -2) Items which occur in lists, and the annotation relates purely -to its usage inside a list. - -See the section above this note for the rest. - -The Anno type family maps the specific SrcSpanAnn' variant for a given -item. - -So - - type instance XRec (GhcPass p) a = GenLocated (Anno a) a - type instance Anno RdrName = SrcSpanAnnN - type LocatedN = GenLocated SrcSpanAnnN - -meaning we can have type LocatedN RdrName - --} - --- --------------------------------------------------------------------- --- Annotations for items in a list --- --------------------------------------------------------------------- - --- | Captures the location of punctuation occurring between items, --- normally in a list. It is captured as a trailing annotation. -data TrailingAnn - = AddSemiAnn EpaLocation -- ^ Trailing ';' - | AddCommaAnn EpaLocation -- ^ Trailing ',' - | AddVbarAnn EpaLocation -- ^ Trailing '|' - deriving (Data, Eq) - -instance Outputable TrailingAnn where - ppr (AddSemiAnn ss) = text "AddSemiAnn" <+> ppr ss - ppr (AddCommaAnn ss) = text "AddCommaAnn" <+> ppr ss - ppr (AddVbarAnn ss) = text "AddVbarAnn" <+> ppr ss - --- | Annotation for items appearing in a list. They can have one or --- more trailing punctuations items, such as commas or semicolons. -data AnnListItem - = AnnListItem { - lann_trailing :: [TrailingAnn] - } - deriving (Data, Eq) - --- --------------------------------------------------------------------- --- Annotations for the context of a list of items --- --------------------------------------------------------------------- - --- | Annotation for the "container" of a list. This captures --- surrounding items such as braces if present, and introductory --- keywords such as 'where'. -data AnnList - = AnnList { - al_anchor :: Maybe Anchor, -- ^ start point of a list having layout - al_open :: Maybe AddEpAnn, - al_close :: Maybe AddEpAnn, - al_rest :: [AddEpAnn], -- ^ context, such as 'where' keyword - al_trailing :: [TrailingAnn] -- ^ items appearing after the - -- list, such as '=>' for a - -- context - } deriving (Data,Eq) - --- --------------------------------------------------------------------- --- Annotations for parenthesised elements, such as tuples, lists --- --------------------------------------------------------------------- - --- | exact print annotation for an item having surrounding "brackets", such as --- tuples or lists -data AnnParen - = AnnParen { - ap_adornment :: ParenType, - ap_open :: EpaLocation, - ap_close :: EpaLocation - } deriving (Data) - --- | Detail of the "brackets" used in an 'AnnParen' exact print annotation. -data ParenType - = AnnParens -- ^ '(', ')' - | AnnParensHash -- ^ '(#', '#)' - | AnnParensSquare -- ^ '[', ']' - deriving (Eq, Ord, Data) - --- | Maps the 'ParenType' to the related opening and closing --- AnnKeywordId. Used when actually printing the item. -parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId) -parenTypeKws AnnParens = (AnnOpenP, AnnCloseP) -parenTypeKws AnnParensHash = (AnnOpenPH, AnnClosePH) -parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS) - --- --------------------------------------------------------------------- - --- | Exact print annotation for the 'Context' data type. -data AnnContext - = AnnContext { - ac_darrow :: Maybe (IsUnicodeSyntax, EpaLocation), - -- ^ location and encoding of the '=>', if present. - ac_open :: [EpaLocation], -- ^ zero or more opening parentheses. - ac_close :: [EpaLocation] -- ^ zero or more closing parentheses. - } deriving (Data) - - --- --------------------------------------------------------------------- --- Annotations for names --- --------------------------------------------------------------------- - --- | exact print annotations for a 'RdrName'. There are many kinds of --- adornment that can be attached to a given 'RdrName'. This type --- captures them, as detailed on the individual constructors. -data NameAnn - -- | Used for a name with an adornment, so '`foo`', '(bar)' - = NameAnn { - nann_adornment :: NameAdornment, - nann_open :: EpaLocation, - nann_name :: EpaLocation, - nann_close :: EpaLocation, - nann_trailing :: [TrailingAnn] - } - -- | Used for @(,,,)@, or @(#,,,#)# - | NameAnnCommas { - nann_adornment :: NameAdornment, - nann_open :: EpaLocation, - nann_commas :: [EpaLocation], - nann_close :: EpaLocation, - nann_trailing :: [TrailingAnn] - } - -- | Used for @(# | | #)@ - | NameAnnBars { - nann_adornment :: NameAdornment, - nann_open :: EpaLocation, - nann_bars :: [EpaLocation], - nann_close :: EpaLocation, - nann_trailing :: [TrailingAnn] - } - -- | Used for @()@, @(##)@, @[]@ - | NameAnnOnly { - nann_adornment :: NameAdornment, - nann_open :: EpaLocation, - nann_close :: EpaLocation, - nann_trailing :: [TrailingAnn] - } - -- | Used for @->@, as an identifier - | NameAnnRArrow { - nann_unicode :: Bool, - nann_mopen :: Maybe EpaLocation, - nann_name :: EpaLocation, - nann_mclose :: Maybe EpaLocation, - nann_trailing :: [TrailingAnn] - } - -- | Used for an item with a leading @'@. The annotation for - -- unquoted item is stored in 'nann_quoted'. - | NameAnnQuote { - nann_quote :: EpaLocation, - nann_quoted :: SrcSpanAnnN, - nann_trailing :: [TrailingAnn] - } - -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN' - -- which has no Api Annotation (via the 'EpAnnNotUsed' constructor. - | NameAnnTrailing { - nann_trailing :: [TrailingAnn] - } - deriving (Data, Eq) - --- | A 'NameAnn' can capture the locations of surrounding adornments, --- such as parens or backquotes. This data type identifies what --- particular pair are being used. -data NameAdornment - = NameParens -- ^ '(' ')' - | NameParensHash -- ^ '(#' '#)' - | NameBackquotes -- ^ '`' - | NameSquare -- ^ '[' ']' - deriving (Eq, Ord, Data) - --- --------------------------------------------------------------------- - --- | exact print annotation used for capturing the locations of --- annotations in pragmas. -data AnnPragma - = AnnPragma { - apr_open :: AddEpAnn, - apr_close :: AddEpAnn, - apr_rest :: [AddEpAnn] - } deriving (Data,Eq) - --- --------------------------------------------------------------------- --- | Captures the sort order of sub elements. This is needed when the --- sub-elements have been split (as in a HsLocalBind which holds separate --- binds and sigs) or for infix patterns where the order has been --- re-arranged. It is captured explicitly so that after the Delta phase a --- SrcSpan is used purely as an index into the annotations, allowing --- transformations of the AST including the introduction of new Located --- items or re-arranging existing ones. -data AnnSortKey - = NoAnnSortKey - | AnnSortKey [RealSrcSpan] - deriving (Data, Eq) - --- --------------------------------------------------------------------- - --- | Convert a 'TrailingAnn' to an 'AddEpAnn' -trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn -trailingAnnToAddEpAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss -trailingAnnToAddEpAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss -trailingAnnToAddEpAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss - --- | Helper function used in the parser to add a 'TrailingAnn' items --- to an existing annotation. -addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments - -> EpAnn AnnList -> EpAnn AnnList -addTrailingAnnToL s t cs EpAnnNotUsed - = EpAnn (spanAsAnchor s) (AnnList (Just $ spanAsAnchor s) Nothing Nothing [] [t]) cs -addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n) - , comments = comments n <> cs } - where - -- See Note [list append in addTrailing*] - addTrailing n = n { al_trailing = al_trailing n ++ [t]} - --- | Helper function used in the parser to add a 'TrailingAnn' items --- to an existing annotation. -addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments - -> EpAnn AnnListItem -> EpAnn AnnListItem -addTrailingAnnToA s t cs EpAnnNotUsed - = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs -addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n) - , comments = comments n <> cs } - where - -- See Note [list append in addTrailing*] - addTrailing n = n { lann_trailing = lann_trailing n ++ [t] } - --- | Helper function used in the parser to add a comma location to an --- existing annotation. -addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn -addTrailingCommaToN s EpAnnNotUsed l - = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments -addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l } - where - -- See Note [list append in addTrailing*] - addTrailing :: NameAnn -> EpaLocation -> NameAnn - addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]} - -{- -Note [list append in addTrailing*] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN -functions are used to add a separator for an item when it occurs in a -list. So they are used to capture a comma, vbar, semicolon and similar. - -In general, a given element will have zero or one of these. In -extreme (test) cases, there may be multiple semicolons. - -In exact printing we sometimes convert the EpaLocation variant for an -trailing annotation to the EpaDelta variant, which cannot be sorted. - -Hence it is critical that these annotations are captured in the order -they appear in the original source file. - -And so we use the less efficient list append to preserve the order, -knowing that in most cases the original list is empty. --} - --- --------------------------------------------------------------------- - --- |Helper function (temporary) during transition of names --- Discards any annotations -l2n :: LocatedAn a1 a2 -> LocatedN a2 -l2n (L la a) = L (noAnnSrcSpan (locA la)) a - -n2l :: LocatedN a -> LocatedA a -n2l (L la a) = L (na2la la) a - --- |Helper function (temporary) during transition of names --- Discards any annotations -la2na :: SrcSpanAnn' a -> SrcSpanAnnN -la2na l = noAnnSrcSpan (locA l) - --- |Helper function (temporary) during transition of names --- Discards any annotations -la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2 -la2la (L la a) = L (noAnnSrcSpan (locA la)) a - -l2l :: SrcSpanAnn' a -> SrcAnn ann -l2l l = noAnnSrcSpan (locA l) - --- |Helper function (temporary) during transition of names --- Discards any annotations -na2la :: SrcSpanAnn' a -> SrcAnn ann -na2la l = noAnnSrcSpan (locA l) - -reLoc :: LocatedAn a e -> Located e -reLoc (L (SrcSpanAnn _ l) a) = L l a - -reLocA :: Located e -> LocatedAn ann e -reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a) - -reLocL :: LocatedN e -> LocatedA e -reLocL (L l a) = (L (na2la l) a) - -reLocC :: LocatedN e -> LocatedC e -reLocC (L l a) = (L (na2la l) a) - -reLocN :: LocatedN a -> Located a -reLocN (L (SrcSpanAnn _ l) a) = L l a - --- --------------------------------------------------------------------- - -realSrcSpan :: SrcSpan -> RealSrcSpan -realSrcSpan (RealSrcSpan s _) = s -realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary - where - l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1) - -srcSpan2e :: SrcSpan -> EpaLocation -srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb -srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing - -la2e :: SrcSpanAnn' a -> EpaLocation -la2e = srcSpan2e . locA - -extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList -extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t - -reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a -reAnn anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem anns) cs) l) a - -reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a -reAnnC anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a - -reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e -reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a - -getLocAnn :: Located a -> SrcSpanAnnA -getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l - - -getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan -getLocA (L (SrcSpanAnn _ l) _) = l - -noLocA :: a -> LocatedAn an a -noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan) - -noAnnSrcSpan :: SrcSpan -> SrcAnn ann -noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l - -noSrcSpanA :: SrcAnn ann -noSrcSpanA = noAnnSrcSpan noSrcSpan - --- | Short form for 'EpAnnNotUsed' -noAnn :: EpAnn a -noAnn = EpAnnNotUsed - - -addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] -addAnns (EpAnn l as1 cs) as2 cs2 - = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2) -addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed -addAnns EpAnnNotUsed [] (EpaCommentsBalanced [] []) = EpAnnNotUsed -addAnns EpAnnNotUsed as cs = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) as cs - --- AZ:TODO use widenSpan here too -addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA -addAnnsA (SrcSpanAnn (EpAnn l as1 cs) loc) as2 cs2 - = SrcSpanAnn (EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)) loc -addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaComments []) - = SrcSpanAnn EpAnnNotUsed loc -addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaCommentsBalanced [] []) - = SrcSpanAnn EpAnnNotUsed loc -addAnnsA (SrcSpanAnn EpAnnNotUsed loc) as cs - = SrcSpanAnn (EpAnn (spanAsAnchor loc) (AnnListItem as) cs) loc - --- | The annotations need to all come after the anchor. Make sure --- this is the case. -widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan -widenSpan s as = foldl combineSrcSpans s (go as) - where - go [] = [] - go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest - go (AddEpAnn _ (EpaDelta _ _):rest) = go rest - --- | The annotations need to all come after the anchor. Make sure --- this is the case. -widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan -widenRealSpan s as = foldl combineRealSrcSpans s (go as) - where - go [] = [] - go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest - go (AddEpAnn _ (EpaDelta _ _):rest) = go rest - -widenAnchor :: Anchor -> [AddEpAnn] -> Anchor -widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op - -widenAnchorR :: Anchor -> RealSrcSpan -> Anchor -widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op - -widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an -widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as) - -epAnnAnnsL :: EpAnn a -> [a] -epAnnAnnsL EpAnnNotUsed = [] -epAnnAnnsL (EpAnn _ anns _) = [anns] - -epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -epAnnAnns EpAnnNotUsed = [] -epAnnAnns (EpAnn _ anns _) = anns - -annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn] -annParen2AddEpAnn EpAnnNotUsed = [] -annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _) - = [AddEpAnn ai o, AddEpAnn ac c] - where - (ai,ac) = parenTypeKws pt - -epAnnComments :: EpAnn an -> EpAnnComments -epAnnComments EpAnnNotUsed = EpaComments [] -epAnnComments (EpAnn _ _ cs) = cs - --- --------------------------------------------------------------------- --- sortLocatedA :: [LocatedA a] -> [LocatedA a] -sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e] -sortLocatedA = sortBy (leftmost_smallest `on` getLocA) - -mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b -mapLocA f (L l a) = L (noAnnSrcSpan l) (f a) - --- AZ:TODO: move this somewhere sane - -combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a -combineLocsA (L a _) (L b _) = combineSrcSpansA a b - -combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a -combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb) - = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of - SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l - SrcSpanAnn (EpAnn anc an cs) l -> - SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l - --- | Combine locations from two 'Located' things and add them to a third thing -addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3 -addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c - -addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3 -addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c - --- --------------------------------------------------------------------- --- Utilities for manipulating EpAnnComments --- --------------------------------------------------------------------- - -getFollowingComments :: EpAnnComments -> [LEpaComment] -getFollowingComments (EpaComments _) = [] -getFollowingComments (EpaCommentsBalanced _ cs) = cs - -setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments -setFollowingComments (EpaComments ls) cs = EpaCommentsBalanced ls cs -setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs - -setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments -setPriorComments (EpaComments _) cs = EpaComments cs -setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts - --- --------------------------------------------------------------------- --- Comment-only annotations --- --------------------------------------------------------------------- - -type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only - -data NoEpAnns = NoEpAnns - deriving (Data,Eq,Ord) - -noComments ::EpAnnCO -noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments - --- TODO:AZ get rid of this -placeholderRealSpan :: RealSrcSpan -placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) - -comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO -comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs - --- --------------------------------------------------------------------- --- Utilities for managing comments in an `EpAnn a` structure. --- --------------------------------------------------------------------- - --- | Add additional comments to a 'SrcAnn', used for manipulating the --- AST prior to exact printing the changed one. -addCommentsToSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann -addCommentsToSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs - = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc -addCommentsToSrcAnn (SrcSpanAnn (EpAnn a an cs) loc) cs' - = SrcSpanAnn (EpAnn a an (cs <> cs')) loc - --- | Replace any existing comments on a 'SrcAnn', used for manipulating the --- AST prior to exact printing the changed one. -setCommentsSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann -setCommentsSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs - = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc -setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs - = SrcSpanAnn (EpAnn a an cs) loc - --- | Add additional comments, used for manipulating the --- AST prior to exact printing the changed one. -addCommentsToEpAnn :: (Monoid a) - => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a -addCommentsToEpAnn loc EpAnnNotUsed cs - = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs -addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs) - --- | Replace any existing comments, used for manipulating the --- AST prior to exact printing the changed one. -setCommentsEpAnn :: (Monoid a) - => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a -setCommentsEpAnn loc EpAnnNotUsed cs - = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs -setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs - --- | Transfer comments and trailing items from the annotations in the --- first 'SrcSpanAnnA' argument to those in the second. -transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) -transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to) -transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to - = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to') - where - to' = case to of - (SrcSpanAnn EpAnnNotUsed loc) - -> SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc - (SrcSpanAnn (EpAnn a an' cs') loc) - -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc - --- | Remove the exact print annotations payload, leaving only the --- anchor and comments. -commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann -commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc -commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc) - --- | Remove the comments, leaving the exact print annotations payload -removeCommentsA :: SrcAnn ann -> SrcAnn ann -removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc -removeCommentsA (SrcSpanAnn (EpAnn a an _) loc) - = (SrcSpanAnn (EpAnn a an emptyComments) loc) - --- --------------------------------------------------------------------- --- Semigroup instances, to allow easy combination of annotaion elements --- --------------------------------------------------------------------- - -instance (Semigroup an) => Semigroup (SrcSpanAnn' an) where - (SrcSpanAnn a1 l1) <> (SrcSpanAnn a2 l2) = SrcSpanAnn (a1 <> a2) (combineSrcSpans l1 l2) - -- The critical part about the location is its left edge, and all - -- annotations must follow it. So we combine them which yields the - -- largest span - -instance (Semigroup a) => Semigroup (EpAnn a) where - EpAnnNotUsed <> x = x - x <> EpAnnNotUsed = x - (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2) - -- The critical part about the anchor is its left edge, and all - -- annotations must follow it. So we combine them which yields the - -- largest span - -instance Ord Anchor where - compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2 - -instance Semigroup Anchor where - Anchor r1 o1 <> Anchor r2 _ = Anchor (combineRealSrcSpans r1 r2) o1 - -instance Semigroup EpAnnComments where - EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2) - EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2 - EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1 - EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2) - - -instance (Monoid a) => Monoid (EpAnn a) where - mempty = EpAnnNotUsed - -instance Semigroup NoEpAnns where - _ <> _ = NoEpAnns - -instance Semigroup AnnListItem where - (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) - -instance Monoid AnnListItem where - mempty = AnnListItem [] - - -instance Semigroup AnnList where - (AnnList a1 o1 c1 r1 t1) <> (AnnList a2 o2 c2 r2 t2) - = AnnList (a1 <> a2) (c o1 o2) (c c1 c2) (r1 <> r2) (t1 <> t2) - where - -- Left biased combination for the open and close annotations - c Nothing x = x - c x Nothing = x - c f _ = f - -instance Monoid AnnList where - mempty = AnnList Nothing Nothing Nothing [] [] - -instance Semigroup NameAnn where - _ <> _ = panic "semigroup nameann" - -instance Monoid NameAnn where - mempty = NameAnnTrailing [] - - -instance Semigroup AnnSortKey where - NoAnnSortKey <> x = x - x <> NoAnnSortKey = x - AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2) - -instance Monoid AnnSortKey where - mempty = NoAnnSortKey - -instance (Outputable a) => Outputable (EpAnn a) where - ppr (EpAnn l a c) = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c - ppr EpAnnNotUsed = text "EpAnnNotUsed" - -instance Outputable NoEpAnns where - ppr NoEpAnns = text "NoEpAnns" - -instance Outputable Anchor where - ppr (Anchor a o) = text "Anchor" <+> ppr a <+> ppr o - -instance Outputable AnchorOperation where - ppr UnchangedAnchor = text "UnchangedAnchor" - ppr (MovedAnchor d) = text "MovedAnchor" <+> ppr d - -instance Outputable DeltaPos where - ppr (SameLine c) = text "SameLine" <+> ppr c - ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c - -instance Outputable (GenLocated Anchor EpaComment) where - ppr (L l c) = text "L" <+> ppr l <+> ppr c - -instance Outputable EpAnnComments where - ppr (EpaComments cs) = text "EpaComments" <+> ppr cs - ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts - -instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where - getName (L l a) = getName (L (locA l) a) - -instance Outputable AnnContext where - ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c - -instance Outputable AnnSortKey where - ppr NoAnnSortKey = text "NoAnnSortKey" - ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls - -instance Outputable IsUnicodeSyntax where - ppr = text . show - -instance (Outputable a) => Outputable (SrcSpanAnn' a) where - ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l - -instance (Outputable a, Outputable e) - => Outputable (GenLocated (SrcSpanAnn' a) e) where - ppr = pprLocated - -instance (Outputable a, OutputableBndr e) - => OutputableBndr (GenLocated (SrcSpanAnn' a) e) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprPrefixOcc . unLoc - -instance Outputable AnnListItem where - ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts - -instance Outputable NameAdornment where - ppr NameParens = text "NameParens" - ppr NameParensHash = text "NameParensHash" - ppr NameBackquotes = text "NameBackquotes" - ppr NameSquare = text "NameSquare" - -instance Outputable NameAnn where - ppr (NameAnn a o n c t) - = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t - ppr (NameAnnCommas a o n c t) - = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t - ppr (NameAnnBars a o n b t) - = text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t - ppr (NameAnnOnly a o c t) - = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t - ppr (NameAnnRArrow u o n c t) - = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t - ppr (NameAnnQuote q n t) - = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t - ppr (NameAnnTrailing t) - = text "NameAnnTrailing" <+> ppr t - -instance Outputable AnnList where - ppr (AnnList a o c r t) - = text "AnnList" <+> ppr a <+> ppr o <+> ppr c <+> ppr r <+> ppr t - -instance Outputable AnnPragma where - ppr (AnnPragma o c r) = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr r +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} + +module GHC.Parser.Annotation ( + -- * Core Exact Print Annotation types + EpToken(..), EpUniToken(..), + getEpTokenSrcSpan, + getEpTokenBufSpan, + getEpTokenLocs, getEpTokenLoc, getEpUniTokenLoc, + TokDcolon, TokDarrow, TokRarrow, TokForall, + EpLayout(..), + EpaComment(..), EpaCommentTok(..), + IsUnicodeSyntax(..), + HasE(..), + + -- * In-tree Exact Print Annotations + EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan, + DeltaPos(..), deltaPos, getDeltaLine, + + EpAnn(..), + spanAsAnchor, realSpanAsAnchor, + noSpanAnchor, + NoAnn(..), + + -- ** Comments in Annotations + + EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments, + epaToNoCommentsLocation, noCommentsToEpaLocation, + getFollowingComments, setFollowingComments, setPriorComments, + EpAnnCO, + + -- ** Annotations in 'GenLocated' + LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP, + LocatedLC, LocatedLS, LocatedLW, LocatedLI, + SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN, + SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, SrcSpanAnnLI, + LocatedE, + + -- ** Annotation data types used in 'GenLocated' + + AnnListItem(..), AnnList(..), AnnListBrackets(..), + AnnParen(..), + AnnPragma(..), + AnnContext(..), + NameAnn(..), NameAdornment(..), + NoEpAnns(..), + AnnSortKey(..), DeclTag(..), BindTag(..), + + -- ** Trailing annotations in lists + TrailingAnn(..), ta_location, + addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN, + noTrailingN, + + -- ** Utilities for converting between different 'GenLocated' when + -- ** we do not care about the annotations. + l2l, la2la, + reLoc, + HasLoc(..), getHasLocList, + + srcSpan2e, realSrcSpan, + + -- ** Building up annotations + addAnnsA, widenSpanL, widenSpanT, widenAnchorT, widenAnchorS, + widenLocatedAnL, + listLocation, + + -- ** Querying annotations + getLocAnn, + epAnnComments, + + -- ** Working with locations of annotations + sortLocatedA, + mapLocA, + combineLocsA, + combineSrcSpansA, + addCLocA, + + -- ** Constructing 'GenLocated' annotation types when we do not care + -- about annotations. + HasAnnotation(..), + locA, + noLocA, + getLocA, + noSrcSpanA, + + -- ** Working with comments in annotations + noComments, comment, addCommentsToEpAnn, setCommentsEpAnn, + transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA, + transferPriorCommentsA, transferFollowingA, + + placeholderRealSpan, + ) where + +import GHC.Prelude + +import Data.Data +import Data.Function (on) +import Data.List (sortBy) +import Data.Semigroup +import GHC.Data.FastString +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Hs.DocString +import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ( (<>) ) +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict +import GHC.Types.SourceText (SourceText (NoSourceText)) + +{- +Note [exact print annotations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a parse tree of a Haskell module, how can we reconstruct +the original Haskell source code, retaining all whitespace and +source code comments? We need to track the locations of all +elements from the original source: this includes keywords such as +'let' / 'in' / 'do' etc as well as punctuation such as commas and +braces, and also comments. We collectively refer to this +metadata as the "exact print annotations". + +NON-COMMENT ELEMENTS + +Intuitively, every AST element directly contains a bag of keywords +(keywords can show up more than once in a node: a semicolon i.e. newline +can show up multiple times before the next AST element), each of which +needs to be associated with its location in the original source code. + +These keywords are recorded directly in the AST element in which they +occur, for the GhcPs phase. + +For any given element in the AST, there is only a set number of +keywords that are applicable for it (e.g., you'll never see an +'import' keyword associated with a let-binding.) The set of allowed +keywords is documented in a comment associated with the constructor +of a given AST element, although the ground truth is in GHC.Parser +and GHC.Parser.PostProcess (which actually add the annotations). + +COMMENT ELEMENTS + +We associate comments with the lowest (most specific) AST element +enclosing them + +PARSER STATE + +There are three fields in PState (the parser state) which play a role +with annotation comments. + +> comment_q :: [LEpaComment], +> header_comments :: Maybe [LEpaComment], +> eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token + +The 'comment_q' field captures comments as they are seen in the token stream, +so that when they are ready to be allocated via the parser they are +available. + +The 'header_comments' capture the comments coming at the top of the +source file. They are moved there from the `comment_q` when comments +are allocated for the first top-level declaration. + +The 'eof_pos' captures the final location in the file, and the +location of the immediately preceding token to the last location, so +that the exact-printer can work out how far to advance to add the +trailing whitespace. + +PARSER EMISSION OF ANNOTATIONS + +The parser interacts with the lexer using the functions + +> getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments + +The 'getCommentsFor' function is the one used most often. It takes +the AST element SrcSpan and removes and returns any comments in the +'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is +responsible for making sure we only return comments that actually fit +in the 'SrcSpan'. + +The 'getPriorCommentsFor' function is used for top-level declarations, +and removes and returns any comments in the 'comment_q' that either +precede or are included in the given SrcSpan. This is to ensure that +preceding documentation comments are kept together with the +declaration they belong to. + +The 'getFinalCommentsFor' function is called right at the end when EOF +is hit. This drains the 'comment_q' completely, and returns the +'header_comments', remaining 'comment_q' entries and the +'eof_pos'. These values are inserted into the 'HsModule' AST element. + +The wiki page describing this feature is +https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations + +-} + +-- -------------------------------------------------------------------- + +-- | Certain tokens can have alternate representations when unicode syntax is +-- enabled. This flag is attached to those tokens in the lexer so that the +-- original source representation can be reproduced in the corresponding +-- 'EpAnnotation' +data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax + deriving (Eq, Ord, Data, Show) + +-- | Some template haskell tokens have two variants, one with an `e` the other +-- not: +-- +-- > [| or [e| +-- > [|| or [e|| +-- +-- This type indicates whether the 'e' is present or not. +data HasE = HasE | NoE + deriving (Eq, Ord, Data, Show) + +-- --------------------------------------------------------------------- + +-- | A token stored in the syntax tree. For example, when parsing a +-- let-expression, we store @EpToken "let"@ and @EpToken "in"@. +-- The locations of those tokens can be used to faithfully reproduce +-- (exactprint) the original program text. +data EpToken (tok :: Symbol) + = NoEpTok + | EpTok !EpaLocation + +instance KnownSymbol tok => Outputable (EpToken tok) where + ppr _ = text (symbolVal (Proxy @tok)) + +-- | With @UnicodeSyntax@, there might be multiple ways to write the same +-- token. For example an arrow could be either @->@ or @→@. This choice must be +-- recorded in order to exactprint such tokens, so instead of @EpToken "->"@ we +-- introduce @EpUniToken "->" "→"@. +data EpUniToken (tok :: Symbol) (utok :: Symbol) + = NoEpUniTok + | EpUniTok !EpaLocation !IsUnicodeSyntax + +deriving instance Eq (EpToken tok) +deriving instance Eq (EpUniToken tok utok) +deriving instance KnownSymbol tok => Data (EpToken tok) +deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok) + +instance (KnownSymbol tok, KnownSymbol utok) => Outputable (EpUniToken tok utok) where + ppr NoEpUniTok = text $ symbolVal (Proxy @tok) + ppr (EpUniTok _ NormalSyntax) = text $ symbolVal (Proxy @tok) + ppr (EpUniTok _ UnicodeSyntax) = text $ symbolVal (Proxy @utok) + +getEpTokenSrcSpan :: EpToken tok -> SrcSpan +getEpTokenSrcSpan NoEpTok = noSrcSpan +getEpTokenSrcSpan (EpTok EpaDelta{}) = noSrcSpan +getEpTokenSrcSpan (EpTok (EpaSpan span)) = span + +getEpTokenBufSpan :: EpToken tok -> Strict.Maybe BufSpan +getEpTokenBufSpan NoEpTok = Strict.Nothing +getEpTokenBufSpan (EpTok EpaDelta{}) = Strict.Nothing +getEpTokenBufSpan (EpTok (EpaSpan span)) = getBufSpan span + +getEpTokenLocs :: [EpToken tok] -> [EpaLocation] +getEpTokenLocs ls = concatMap go ls + where + go NoEpTok = [] + go (EpTok l) = [l] + +getEpTokenLoc :: EpToken tok -> EpaLocation +getEpTokenLoc NoEpTok = noAnn +getEpTokenLoc (EpTok l) = l + +getEpUniTokenLoc :: EpUniToken tok toku -> EpaLocation +getEpUniTokenLoc NoEpUniTok = noAnn +getEpUniTokenLoc (EpUniTok l _) = l + +-- TODO:AZ: check we have all of the unicode tokens +type TokDcolon = EpUniToken "::" "∷" +type TokDarrow = EpUniToken "=>" "⇒" +type TokRarrow = EpUniToken "->" "→" +type TokForall = EpUniToken "forall" "∀" + +-- | Layout information for declarations. +data EpLayout = + + -- | Explicit braces written by the user. + -- + -- @ + -- class C a where { foo :: a; bar :: a } + -- @ + EpExplicitBraces !(EpToken "{") !(EpToken "}") + | + -- | Virtual braces inserted by the layout algorithm. + -- + -- @ + -- class C a where + -- foo :: a + -- bar :: a + -- @ + EpVirtualBraces + !Int -- ^ Layout column (indentation level, begins at 1) + | + -- | Empty or compiler-generated blocks do not have layout information + -- associated with them. + EpNoLayout + +deriving instance Data EpLayout + +-- --------------------------------------------------------------------- + +data EpaComment = + EpaComment + { ac_tok :: EpaCommentTok + , ac_prior_tok :: RealSrcSpan + -- ^ The location of the prior token, used in exact printing. The + -- 'EpaComment' appears as an 'LEpaComment' containing its + -- location. The difference between the end of the prior token + -- and the start of this location is used for the spacing when + -- exact printing the comment. + } + deriving (Eq, Data, Show) + +data EpaCommentTok = + -- Documentation annotations + EpaDocComment HsDocString -- ^ a docstring that can be pretty printed using pprHsDocString + | EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc) + | EpaLineComment String -- ^ comment starting by "--" + | EpaBlockComment String -- ^ comment in {- -} + deriving (Eq, Data, Show) +-- Note: these are based on the Token versions, but the Token type is +-- defined in GHC.Parser.Lexer and bringing it in here would create a loop + +instance Outputable EpaComment where + ppr x = text (show x) + +-- --------------------------------------------------------------------- + +type EpaLocation = EpaLocation' [LEpaComment] + +epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation +epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss +epaToNoCommentsLocation (EpaDelta ss dp []) = EpaDelta ss dp NoComments +epaToNoCommentsLocation (EpaDelta _ _ _ ) = panic "epaToNoCommentsLocation" + +noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation +noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss +noCommentsToEpaLocation (EpaDelta ss dp NoComments) = EpaDelta ss dp [] + +-- | Used in the parser only, extract the 'RealSrcSpan' from an +-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the +-- partial function is safe. +epaLocationRealSrcSpan :: EpaLocation' a -> RealSrcSpan +epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r +epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan" + +-- --------------------------------------------------------------------- + +-- | The exact print annotations (EPAs) are kept in the HsSyn AST for +-- the GhcPs phase. They are usually inserted into the AST by the parser, +-- and in case of generated code (e.g. by TemplateHaskell) they are usually +-- initialized using 'NoAnn' type class. +-- +-- A goal of the annotations is that an AST can be edited, including +-- moving subtrees from one place to another, duplicating them, and so +-- on. This means that each fragment must be self-contained. To this +-- end, each annotated fragment keeps track of the anchor position it +-- was originally captured at, being simply the start span of the +-- topmost element of the ast fragment. This gives us a way to later +-- re-calculate all Located items in this layer of the AST, as well as +-- any annotations captured. The comments associated with the AST +-- fragment are also captured here. +-- +-- The 'ann' type parameter allows this general structure to be +-- specialised to the specific set of locations of original exact +-- print annotation elements. For example +-- +-- @ +-- type SrcSpannAnnA = EpAnn AnnListItem +-- @ +-- +-- is a commonly used type alias that specializes the 'ann' type parameter to +-- 'AnnListItem'. +-- +-- The spacing between the items under the scope of a given EpAnn is +-- normally derived from the original 'Anchor'. But if a sub-element +-- is not in its original position, the required spacing can be +-- captured using an appropriate 'EpaDelta' value for the 'entry' Anchor. +-- This allows us to freely move elements around, and stitch together +-- new AST fragments out of old ones, and have them still printed out +-- in a precise way. +data EpAnn ann + = EpAnn { entry :: !EpaLocation + -- ^ Base location for the start of the syntactic element + -- holding the annotations. + , anns :: !ann -- ^ Annotations added by the Parser + , comments :: !EpAnnComments + -- ^ Comments enclosed in the SrcSpan of the element + -- this `EpAnn` is attached to + } + deriving (Data, Eq, Functor) +-- See Note [XRec and Anno in the AST] + + +spanAsAnchor :: SrcSpan -> (EpaLocation' a) +spanAsAnchor ss = EpaSpan ss + +realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a) +realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) + +noSpanAnchor :: (NoAnn a) => EpaLocation' a +noSpanAnchor = EpaDelta noSrcSpan (SameLine 0) noAnn + +-- --------------------------------------------------------------------- + +-- | When we are parsing we add comments that belong to a particular AST +-- element, and print them together with the element, interleaving +-- them into the output stream. But when editing the AST to move +-- fragments around it is useful to be able to first separate the +-- comments into those occurring before the AST element and those +-- following it. The 'EpaCommentsBalanced' constructor is used to do +-- this. The GHC parser will only insert the 'EpaComments' form. +data EpAnnComments = EpaComments + { priorComments :: ![LEpaComment] } + | EpaCommentsBalanced + { priorComments :: ![LEpaComment] + , followingComments :: ![LEpaComment] } + deriving (Data, Eq) + +type LEpaComment = GenLocated NoCommentsLocation EpaComment + +emptyComments :: EpAnnComments +emptyComments = EpaComments [] + +-- --------------------------------------------------------------------- +-- Annotations attached to a 'SrcSpan'. +-- --------------------------------------------------------------------- + +type LocatedA = GenLocated SrcSpanAnnA +type LocatedN = GenLocated SrcSpanAnnN + +type LocatedL = GenLocated SrcSpanAnnL +type LocatedLC = GenLocated SrcSpanAnnLC +type LocatedLS = GenLocated SrcSpanAnnLS +type LocatedLW = GenLocated SrcSpanAnnLW +type LocatedLI = GenLocated SrcSpanAnnLI +type LocatedP = GenLocated SrcSpanAnnP +type LocatedC = GenLocated SrcSpanAnnC + +type SrcSpanAnnA = EpAnn AnnListItem +type SrcSpanAnnN = EpAnn NameAnn + +type SrcSpanAnnL = EpAnn (AnnList ()) +type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","]) +type SrcSpanAnnLS = EpAnn (AnnList ()) +type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where")) +type SrcSpanAnnLI = EpAnn (AnnList (EpToken "hiding", [EpToken ","])) +type SrcSpanAnnP = EpAnn AnnPragma +type SrcSpanAnnC = EpAnn AnnContext + +type LocatedE = GenLocated EpaLocation + +-- | General representation of a 'GenLocated' type carrying a +-- parameterised annotation type. +type LocatedAn an = GenLocated (EpAnn an) + +{- +Note [XRec and Anno in the AST] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The exact print annotations are captured directly inside the AST, using +TTG extension points. However certain annotations need to be captured +on the Located versions too. There is a general form for these, +captured in the type 'EpAnn ann' with the specific usage captured in +the 'ann' parameter in different contexts. + +Some of the particular use cases are + +1) RdrNames, which can have additional items such as backticks or parens + +2) Items which occur in lists, and the annotation relates purely +to its usage inside a list. + +See the section above this note for the rest. + +The Anno type family maps to the specific EpAnn variant for a given +item. + +So + + type instance XRec (GhcPass p) a = XRecGhc a + type XRecGhc a = GenLocated (Anno a) a + + type instance Anno RdrName = SrcSpanAnnN + type LocatedN = GenLocated SrcSpanAnnN + +meaning we can have type LocatedN RdrName + +-} + +-- --------------------------------------------------------------------- +-- Annotations for items in a list +-- --------------------------------------------------------------------- + +-- | Captures the location of punctuation occurring between items, +-- normally in a list. It is captured as a trailing annotation. +data TrailingAnn + = AddSemiAnn (EpToken ";") -- ^ Trailing ';' + | AddCommaAnn (EpToken ",") -- ^ Trailing ',' + | AddVbarAnn (EpToken "|") -- ^ Trailing '|' + | AddDarrowAnn TokDarrow -- ^ Trailing '=>' / '⇒' + deriving (Data, Eq) + +ta_location :: TrailingAnn -> EpaLocation +ta_location (AddSemiAnn tok) = getEpTokenLoc tok +ta_location (AddCommaAnn tok) = getEpTokenLoc tok +ta_location (AddVbarAnn tok) = getEpTokenLoc tok +ta_location (AddDarrowAnn tok) = getEpUniTokenLoc tok + + +instance Outputable TrailingAnn where + ppr (AddSemiAnn tok) = text "AddSemiAnn" <+> ppr tok + ppr (AddCommaAnn tok) = text "AddCommaAnn" <+> ppr tok + ppr (AddVbarAnn tok) = text "AddVbarAnn" <+> ppr tok + ppr (AddDarrowAnn tok) = text "AddDarrowAnn" <+> ppr tok + +-- | Annotation for items appearing in a list. They can have one or +-- more trailing punctuations items, such as commas or semicolons. +data AnnListItem + = AnnListItem { + lann_trailing :: [TrailingAnn] + } + deriving (Data, Eq) + +-- --------------------------------------------------------------------- +-- Annotations for the context of a list of items +-- --------------------------------------------------------------------- + +-- | Annotation for the "container" of a list. This captures +-- surrounding items such as braces if present, and introductory +-- keywords such as 'where'. +data AnnList a + = AnnList { + al_anchor :: !(Maybe EpaLocation), -- ^ start point of a list having layout + al_brackets :: !AnnListBrackets, + al_semis :: [EpToken ";"], -- decls + al_rest :: !a, + al_trailing :: ![TrailingAnn] -- ^ items appearing after the + -- list, such as '=>' for a + -- context + } deriving (Data,Eq) + +data AnnListBrackets + = ListParens (EpToken "(") (EpToken ")") + | ListBraces (EpToken "{") (EpToken "}") + | ListSquare (EpToken "[") (EpToken "]") + | ListBanana (EpUniToken "(|" "⦇") (EpUniToken "|)" "⦈") + | ListNone + deriving (Data,Eq) + +-- --------------------------------------------------------------------- +-- Annotations for parenthesised elements, such as tuples, lists +-- --------------------------------------------------------------------- + +-- | exact print annotation for an item having surrounding "brackets", such as +-- tuples or lists +data AnnParen + = AnnParens (EpToken "(") (EpToken ")") -- ^ '(', ')' + | AnnParensHash (EpToken "(#") (EpToken "#)") -- ^ '(#', '#)' + | AnnParensSquare (EpToken "[") (EpToken "]") -- ^ '[', ']' + deriving Data + +-- --------------------------------------------------------------------- + +-- | Exact print annotation for the 'Context' data type. +data AnnContext + = AnnContext { + ac_darrow :: Maybe TokDarrow, + -- ^ location of the '=>', if present. + ac_open :: [EpToken "("], -- ^ zero or more opening parentheses. + ac_close :: [EpToken ")"] -- ^ zero or more closing parentheses. + } deriving (Data) + + +-- --------------------------------------------------------------------- +-- Annotations for names +-- --------------------------------------------------------------------- + +-- | exact print annotations for a 'RdrName'. There are many kinds of +-- adornment that can be attached to a given 'RdrName'. This type +-- captures them, as detailed on the individual constructors. +data NameAnn + -- | Used for a name with an adornment, so '`foo`', '(bar)' + = NameAnn { + nann_adornment :: NameAdornment, + nann_name :: EpaLocation, + nann_trailing :: [TrailingAnn] + } + -- | Used for @(,,,)@, or @(#,,,#)@ + | NameAnnCommas { + nann_adornment :: NameAdornment, + nann_commas :: [EpToken ","], + nann_trailing :: [TrailingAnn] + } + -- | Used for @(# | | #)@ + | NameAnnBars { + nann_parensh :: (EpToken "(#", EpToken "#)"), + nann_bars :: [EpToken "|"], + nann_trailing :: [TrailingAnn] + } + -- | Used for @()@, @(##)@, @[]@ + | NameAnnOnly { + nann_adornment :: NameAdornment, + nann_trailing :: [TrailingAnn] + } + -- | Used for @->@, as an identifier + | NameAnnRArrow { + nann_mopen :: Maybe (EpToken "("), + nann_arrow :: TokRarrow, + nann_mclose :: Maybe (EpToken ")"), + nann_trailing :: [TrailingAnn] + } + -- | Used for an item with a leading @'@. The annotation for + -- unquoted item is stored in 'nann_quoted'. + | NameAnnQuote { + nann_quote :: EpToken "'", + nann_quoted :: SrcSpanAnnN, + nann_trailing :: [TrailingAnn] + } + -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN' + -- which has no Api Annotation. + | NameAnnTrailing { + nann_trailing :: [TrailingAnn] + } + deriving (Data, Eq) + +-- | A 'NameAnn' can capture the locations of surrounding adornments, +-- such as parens or backquotes. This data type identifies what +-- particular pair are being used. +data NameAdornment + = NameParens (EpToken "(") (EpToken ")") + | NameParensHash (EpToken "(#") (EpToken "#)") + | NameBackquotes (EpToken "`") (EpToken "`") + | NameSquare (EpToken "[") (EpToken "]") + | NameNoAdornment + deriving (Eq, Data) + + +-- --------------------------------------------------------------------- + +-- | exact print annotation used for capturing the locations of +-- annotations in pragmas. +data AnnPragma + = AnnPragma { + apr_open :: EpaLocation, + apr_close :: EpToken "#-}", + apr_squares :: (EpToken "[", EpToken "]"), + apr_loc1 :: EpaLocation, + apr_loc2 :: EpaLocation, + apr_type :: EpToken "type", + apr_module :: EpToken "module" + } deriving (Data,Eq) + +-- --------------------------------------------------------------------- + +-- | Captures the sort order of sub elements for `ValBinds`, +-- `ClassDecl`, `ClsInstDecl` +data AnnSortKey tag + -- See Note [AnnSortKey] below + = NoAnnSortKey + | AnnSortKey [tag] + deriving (Data, Eq) + +-- | Used to track of interleaving of binds and signatures for ValBind +data BindTag + -- See Note [AnnSortKey] below + = BindTag + | SigDTag + deriving (Eq,Data,Ord,Show) + +-- | Used to track interleaving of class methods, class signatures, +-- associated types and associate type defaults in `ClassDecl` and +-- `ClsInstDecl`. +data DeclTag + -- See Note [AnnSortKey] below + = ClsMethodTag + | ClsSigTag + | ClsAtTag + | ClsAtdTag + deriving (Eq,Data,Ord,Show) + +{- +Note [AnnSortKey] +~~~~~~~~~~~~~~~~~ + +For some constructs in the ParsedSource we have mixed lists of items +that can be freely intermingled. + +An example is the binds in a where clause, captured in + + ValBinds + (XValBinds idL idR) + (LHsBindsLR idL idR) [LSig idR] + +This keeps separate ordered collections of LHsBind GhcPs and LSig GhcPs. + +But there is no constraint on the original source code as to how these +should appear, so they can have all the signatures first, then their +binds, or grouped with a signature preceding each bind. + + fa :: Int + fa = 1 + + fb :: Char + fb = 'c' + +Or + + fa :: Int + fb :: Char + + fb = 'c' + fa = 1 + +When exact printing these, we need to restore the original order. As +initially parsed we have the SrcSpan, and can sort on those. But if we +have modified the AST prior to printing, we cannot rely on the +SrcSpans for order any more. + +The bag of LHsBind GhcPs is physically ordered, as is the list of LSig +GhcPs. So in effect we have a list of binds in the order we care +about, and a list of sigs in the order we care about. The only problem +is to know how to merge the lists. + +This is where AnnSortKey comes in, which we store in the TTG extension +point for ValBinds. + + data AnnSortKey tag + = NoAnnSortKey + | AnnSortKey [tag] + +When originally parsed, with SrcSpans we can rely on, we do not need +any extra information, so we tag it with NoAnnSortKey. + +If the binds and signatures are updated in any way, such that we can +no longer rely on their SrcSpans (e.g. they are copied from elsewhere, +parsed from scratch for insertion, have a fake SrcSpan), we use +`AnnSortKey [BindTag]` to keep track. + + data BindTag + = BindTag + | SigDTag + +We use it as a merge selector, and have one entry for each bind and +signature. + +So for the first example we have + + binds: fa = 1 , fb = 'c' + sigs: fa :: Int, fb :: Char + tags: SigDTag, BindTag, SigDTag, BindTag + +so we draw first from the signatures, then the binds, and same again. + +For the second example we have + + binds: fb = 'c', fa = 1 + sigs: fa :: Int, fb :: Char + tags: SigDTag, SigDTag, BindTag, BindTag + +so we draw two signatures, then two binds. + +We do similar for ClassDecl and ClsInstDecl, but we have four +different lists we must manage. For this we use DeclTag. + +-} + +-- --------------------------------------------------------------------- + +-- | Helper function used in the parser to add a 'TrailingAnn' items +-- to an existing annotation. +addTrailingAnnToL :: TrailingAnn -> EpAnnComments + -> EpAnn (AnnList a) -> EpAnn (AnnList a) +addTrailingAnnToL t cs n = n { anns = addTrailing (anns n) + , comments = comments n <> cs } + where + -- See Note [list append in addTrailing*] + addTrailing n = n { al_trailing = al_trailing n ++ [t]} + +-- | Helper function used in the parser to add a 'TrailingAnn' items +-- to an existing annotation. +addTrailingAnnToA :: TrailingAnn -> EpAnnComments + -> EpAnn AnnListItem -> EpAnn AnnListItem +addTrailingAnnToA t cs n = n { anns = addTrailing (anns n) + , comments = comments n <> cs } + where + -- See Note [list append in addTrailing*] + addTrailing n = n { lann_trailing = lann_trailing n ++ [t] } + +-- | Helper function used in the parser to add a comma location to an +-- existing annotation. +addTrailingCommaToN :: EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn +addTrailingCommaToN n l = n { anns = addTrailing (anns n) l } + where + -- See Note [list append in addTrailing*] + addTrailing :: NameAnn -> EpaLocation -> NameAnn + addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn (EpTok l)]} + +noTrailingN :: SrcSpanAnnN -> SrcSpanAnnN +noTrailingN s = s { anns = (anns s) { nann_trailing = [] } } + +{- +Note [list append in addTrailing*] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN +functions are used to add a separator for an item when it occurs in a +list. So they are used to capture a comma, vbar, semicolon and similar. + +In general, a given element will have zero or one of these. In +extreme (test) cases, there may be multiple semicolons. + +In exact printing we sometimes convert the EpaLocation variant for an +trailing annotation to the EpaDelta variant, which cannot be sorted. + +Hence it is critical that these annotations are captured in the order +they appear in the original source file. + +And so we use the less efficient list append to preserve the order, +knowing that in most cases the original list is empty. +-} + +-- --------------------------------------------------------------------- + +-- |Helper function for converting annotation types. +-- Discards any annotations +l2l :: (HasLoc a, HasAnnotation b) => a -> b +l2l a = noAnnSrcSpan (getHasLoc a) + +-- |Helper function for converting annotation types. +-- Discards any annotations +la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a +la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a + +locA :: (HasLoc a) => a -> SrcSpan +locA = getHasLoc + +reLoc :: (HasLoc (GenLocated a e), HasAnnotation b) + => GenLocated a e -> GenLocated b e +reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a + + +-- --------------------------------------------------------------------- + +class HasAnnotation e where + noAnnSrcSpan :: SrcSpan -> e + +instance HasAnnotation SrcSpan where + noAnnSrcSpan l = l + +instance HasAnnotation EpaLocation where + noAnnSrcSpan l = EpaSpan l + +instance (NoAnn ann) => HasAnnotation (EpAnn ann) where + noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments + +noLocA :: (HasAnnotation e) => a -> GenLocated e a +noLocA = L (noAnnSrcSpan noSrcSpan) + +getLocA :: (HasLoc a) => GenLocated a e -> SrcSpan +getLocA = getHasLoc + +noSrcSpanA :: (HasAnnotation e) => e +noSrcSpanA = noAnnSrcSpan noSrcSpan + +-- --------------------------------------------------------------------- + +class NoAnn a where + -- | equivalent of `mempty`, but does not need Semigroup + noAnn :: a + +-- --------------------------------------------------------------------- + +class HasLoc a where + -- ^ conveniently calculate locations for things without locations attached + getHasLoc :: a -> SrcSpan + +instance (HasLoc l) => HasLoc (GenLocated l a) where + getHasLoc (L l _) = getHasLoc l + +instance HasLoc SrcSpan where + getHasLoc l = l + +instance (HasLoc a) => (HasLoc (Maybe a)) where + getHasLoc (Just a) = getHasLoc a + getHasLoc Nothing = noSrcSpan + +instance HasLoc (EpAnn a) where + getHasLoc (EpAnn l _ _) = getHasLoc l + +instance HasLoc EpaLocation where + getHasLoc (EpaSpan l) = l + getHasLoc (EpaDelta l _ _) = l + +instance HasLoc (EpToken tok) where + getHasLoc = getEpTokenSrcSpan + +instance HasLoc (EpUniToken tok utok) where + getHasLoc NoEpUniTok = noSrcSpan + getHasLoc (EpUniTok l _) = getHasLoc l + +getHasLocList :: HasLoc a => [a] -> SrcSpan +getHasLocList = foldl1WithDefault' noSrcSpan combineSrcSpans . map getHasLoc + +-- --------------------------------------------------------------------- + +realSrcSpan :: SrcSpan -> RealSrcSpan +realSrcSpan (RealSrcSpan s _) = s +realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary + where + l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1) + +srcSpan2e :: SrcSpan -> EpaLocation +srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss +srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing) + +getLocAnn :: Located a -> SrcSpanAnnA +getLocAnn (L l _) = noAnnSrcSpan l + +-- AZ:TODO use widenSpan here too +addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA +addAnnsA (EpAnn l as1 cs) as2 cs2 + = EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2) + +-- | The annotations need to all come after the anchor. Make sure +-- this is the case. +widenSpanL :: SrcSpan -> [EpaLocation] -> SrcSpan +widenSpanL s as = foldl combineSrcSpans s (go as) + where + go [] = [] + go ((EpaSpan (RealSrcSpan s mb):rest)) = RealSrcSpan s mb : go rest + go ((EpaSpan _):rest) = go rest + go ((EpaDelta _ _ _):rest) = go rest + +widenSpanT :: SrcSpan -> EpToken tok -> SrcSpan +widenSpanT l (EpTok loc) = widenSpanL l [loc] +widenSpanT l NoEpTok = l + +listLocation :: [LocatedAn an a] -> EpaLocation +listLocation as = EpaSpan (go noSrcSpan as) + where + combine l r = combineSrcSpans l r + + go acc [] = acc + go acc (L (EpAnn (EpaSpan s) _ _) _:rest) = go (combine acc s) rest + go acc (_:rest) = go acc rest + +widenAnchorT :: EpaLocation -> EpToken tok -> EpaLocation +widenAnchorT (EpaSpan ss) (EpTok l) = widenAnchorS l ss +widenAnchorT ss _ = ss + +widenAnchorS :: EpaLocation -> SrcSpan -> EpaLocation +widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr) + = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr)) +widenAnchorS (EpaSpan us) _ = EpaSpan us +widenAnchorS EpaDelta{} (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb) +widenAnchorS anc _ = anc + +widenLocatedAnL :: EpAnn an -> [EpaLocation] -> EpAnn an +widenLocatedAnL (EpAnn (EpaSpan l) a cs) as = EpAnn (spanAsAnchor l') a cs + where + l' = widenSpanL l as +widenLocatedAnL (EpAnn anc a cs) _as = EpAnn anc a cs + +epAnnComments :: EpAnn an -> EpAnnComments +epAnnComments (EpAnn _ _ cs) = cs + +-- --------------------------------------------------------------------- +sortLocatedA :: (HasLoc (EpAnn a)) => [GenLocated (EpAnn a) e] -> [GenLocated (EpAnn a) e] +sortLocatedA = sortBy (leftmost_smallest `on` getLocA) + +mapLocA :: (NoAnn ann) => (a -> b) -> GenLocated SrcSpan a -> GenLocated (EpAnn ann) b +mapLocA f (L l a) = L (noAnnSrcSpan l) (f a) + +-- AZ:TODO: move this somewhere sane +combineLocsA :: Semigroup a => GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a +combineLocsA (L a _) (L b _) = combineSrcSpansA a b + +combineSrcSpansA :: Semigroup a => EpAnn a -> EpAnn a -> EpAnn a +combineSrcSpansA aa ab = aa <> ab + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLocA :: (HasLoc a, HasLoc b, HasAnnotation l) + => a -> b -> c -> GenLocated l c +addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (getHasLoc a) (getHasLoc b)) c + +-- --------------------------------------------------------------------- +-- Utilities for manipulating EpAnnComments +-- --------------------------------------------------------------------- + +getFollowingComments :: EpAnnComments -> [LEpaComment] +getFollowingComments (EpaComments _) = [] +getFollowingComments (EpaCommentsBalanced _ cs) = cs + +setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments +setFollowingComments (EpaComments ls) cs = EpaCommentsBalanced ls cs +setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs + +setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments +setPriorComments (EpaComments _) cs = EpaComments cs +setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts + +-- --------------------------------------------------------------------- +-- Comment-only annotations +-- --------------------------------------------------------------------- + +type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only + +data NoEpAnns = NoEpAnns + deriving (Data,Eq,Ord) + +noComments ::EpAnnCO +noComments = EpAnn noSpanAnchor NoEpAnns emptyComments + +-- TODO:AZ get rid of this +placeholderRealSpan :: RealSrcSpan +placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1)) + +comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO +comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs + +-- --------------------------------------------------------------------- +-- Utilities for managing comments in an `EpAnn a` structure. +-- --------------------------------------------------------------------- + +-- | Add additional comments to a 'EpAnn', used for manipulating the +-- AST prior to exact printing the changed one. +addCommentsToEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann +addCommentsToEpAnn (EpAnn a an cs) cs' = EpAnn a an (cs <> cs') + +-- | Replace any existing comments on a 'EpAnn', used for manipulating the +-- AST prior to exact printing the changed one. +setCommentsEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann +setCommentsEpAnn (EpAnn a an _) cs = (EpAnn a an cs) + +-- | Transfer comments and trailing items from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferAnnsA (EpAnn a an cs) (EpAnn a' an' cs') + = (EpAnn a noAnn emptyComments, EpAnn a' (an' <> an) (cs' <> cs)) + +-- | Transfer trailing items but not comments from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferFollowingA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferFollowingA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2) + = (EpAnn a1 noAnn cs1', EpAnn a2 (an1 <> an2) cs2') + where + pc = priorComments cs1 + fc = getFollowingComments cs1 + cs1' = setPriorComments emptyComments pc + cs2' = setFollowingComments cs2 fc + +-- | Transfer trailing items from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs') + = (EpAnn a noAnn cs, EpAnn a' (an' <> an) cs') + +-- | Transfer comments from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b) +transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs') + = (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs')) + +-- | Transfer prior comments only from the annotations in the +-- first 'SrcSpanAnnA' argument to those in the second. +transferPriorCommentsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA) +transferPriorCommentsA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2) + = (EpAnn a1 an1 cs1', EpAnn a2 an2 cs2') + where + pc = priorComments cs1 + fc = getFollowingComments cs1 + cs1' = setFollowingComments emptyComments fc + cs2' = setPriorComments cs2 (priorComments cs2 <> pc) + +-- --------------------------------------------------------------------- +-- Semigroup instances, to allow easy combination of annotation elements +-- --------------------------------------------------------------------- + +instance (Semigroup a) => Semigroup (EpAnn a) where + (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2) + -- The critical part about the anchor is its left edge, and all + -- annotations must follow it. So we combine them which yields the + -- largest span + +instance Semigroup EpaLocation where + EpaSpan s1 <> EpaSpan s2 = EpaSpan (combineSrcSpans s1 s2) + EpaSpan s1 <> _ = EpaSpan s1 + _ <> EpaSpan s2 = EpaSpan s2 + EpaDelta s1 dp1 cs1 <> EpaDelta s2 _dp2 cs2 = EpaDelta (combineSrcSpans s1 s2) dp1 (cs1<>cs2) + +instance Semigroup EpAnnComments where + EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2) + EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2 + EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1 + EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2) + +instance Semigroup AnnListItem where + (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) + +instance Semigroup (AnnSortKey tag) where + NoAnnSortKey <> x = x + x <> NoAnnSortKey = x + AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2) + +instance Monoid (AnnSortKey tag) where + mempty = NoAnnSortKey + +-- --------------------------------------------------------------------- +-- NoAnn instances +-- --------------------------------------------------------------------- + +instance NoAnn EpaLocation where + noAnn = EpaDelta noSrcSpan (SameLine 0) [] + +instance NoAnn [a] where + noAnn = [] + +instance NoAnn (Maybe a) where + noAnn = Nothing + +instance NoAnn a => NoAnn (Either a b) where + noAnn = Left noAnn + +instance (NoAnn a, NoAnn b) => NoAnn (a, b) where + noAnn = (noAnn, noAnn) + +instance (NoAnn a, NoAnn b, NoAnn c) => NoAnn (a, b, c) where + noAnn = (noAnn, noAnn, noAnn) + +instance (NoAnn a, NoAnn b, NoAnn c, NoAnn d) => NoAnn (a, b, c, d) where + noAnn = (noAnn, noAnn, noAnn, noAnn) + +instance NoAnn Bool where + noAnn = False + +instance NoAnn () where + noAnn = () + +instance (NoAnn ann) => NoAnn (EpAnn ann) where + noAnn = EpAnn noSpanAnchor noAnn emptyComments + +instance NoAnn NoEpAnns where + noAnn = NoEpAnns + +instance NoAnn AnnListItem where + noAnn = AnnListItem [] + +instance NoAnn AnnContext where + noAnn = AnnContext Nothing [] [] + +instance NoAnn a => NoAnn (AnnList a) where + noAnn = AnnList Nothing ListNone noAnn noAnn [] + +instance NoAnn NameAnn where + noAnn = NameAnnTrailing [] + +instance NoAnn AnnPragma where + noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn + +instance NoAnn AnnParen where + noAnn = AnnParens noAnn noAnn + +instance NoAnn (EpToken s) where + noAnn = NoEpTok + +instance NoAnn (EpUniToken s t) where + noAnn = NoEpUniTok + +instance NoAnn SourceText where + noAnn = NoSourceText + +-- --------------------------------------------------------------------- + +instance (Outputable a) => Outputable (EpAnn a) where + ppr (EpAnn l a c) = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c + +instance Outputable NoEpAnns where + ppr NoEpAnns = text "NoEpAnns" + +instance Outputable (GenLocated NoCommentsLocation EpaComment) where + ppr (L l c) = text "L" <+> ppr l <+> ppr c + +instance Outputable EpAnnComments where + ppr (EpaComments cs) = text "EpaComments" <+> ppr cs + ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts + +instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where + getName (L l a) = getName (L (locA l) a) + +instance Outputable AnnContext where + ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c + +instance Outputable BindTag where + ppr tag = text $ show tag + +instance Outputable DeclTag where + ppr tag = text $ show tag + +instance Outputable tag => Outputable (AnnSortKey tag) where + ppr NoAnnSortKey = text "NoAnnSortKey" + ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls + +instance Outputable IsUnicodeSyntax where + ppr = text . show + +instance (Outputable a, Outputable e) + => Outputable (GenLocated (EpAnn a) e) where + ppr = pprLocated + +instance (Outputable a, OutputableBndr e) + => OutputableBndr (GenLocated (EpAnn a) e) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc + +instance (Outputable e) + => Outputable (GenLocated EpaLocation e) where + ppr = pprLocated + +instance Outputable AnnParen where + ppr (AnnParens o c) = text "AnnParens" <+> ppr o <+> ppr c + ppr (AnnParensHash o c) = text "AnnParensHash" <+> ppr o <+> ppr c + ppr (AnnParensSquare o c) = text "AnnParensSquare" <+> ppr o <+> ppr c + +instance Outputable AnnListItem where + ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts + +instance Outputable NameAdornment where + ppr (NameParens o c) = text "NameParens" <+> ppr o <+> ppr c + ppr (NameParensHash o c) = text "NameParensHash" <+> ppr o <+> ppr c + ppr (NameBackquotes o c) = text "NameBackquotes" <+> ppr o <+> ppr c + ppr (NameSquare o c) = text "NameSquare" <+> ppr o <+> ppr c + ppr NameNoAdornment = text "NameNoAdornment" + +instance Outputable NameAnn where + ppr (NameAnn a n t) + = text "NameAnn" <+> ppr a <+> ppr n <+> ppr t + ppr (NameAnnCommas a n t) + = text "NameAnnCommas" <+> ppr a <+> ppr n <+> ppr t + ppr (NameAnnBars a n t) + = text "NameAnnBars" <+> ppr a <+> ppr n <+> ppr t + ppr (NameAnnOnly a t) + = text "NameAnnOnly" <+> ppr a <+> ppr t + ppr (NameAnnRArrow o n c t) + = text "NameAnnRArrow" <+> ppr o <+> ppr n <+> ppr c <+> ppr t + ppr (NameAnnQuote q n t) + = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t + ppr (NameAnnTrailing t) + = text "NameAnnTrailing" <+> ppr t + +instance (Outputable a) => Outputable (AnnList a) where + ppr (AnnList anc p s a t) + = text "AnnList" <+> ppr anc <+> ppr p <+> ppr s <+> ppr a <+> ppr t + +instance Outputable AnnListBrackets where + ppr (ListParens o c) = text "ListParens" <+> ppr o <+> ppr c + ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c + ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c + ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c + ppr ListNone = text "ListNone" + +instance Outputable AnnPragma where + ppr (AnnPragma o c s l ca t m) + = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l + <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m diff --git a/GHC/Parser/CharClass.hs b/GHC/Parser/CharClass.hs --- a/GHC/Parser/CharClass.hs +++ b/GHC/Parser/CharClass.hs @@ -36,7 +36,7 @@ {-# INLINABLE is_ctype #-} is_ctype :: Word8 -> Char -> Bool -is_ctype mask c = (charType c .&. mask) /= 0 +is_ctype mask c = c <= '\127' && (charType c .&. mask) /= 0 is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, is_alphanum :: Char -> Bool diff --git a/GHC/Parser/Errors/Ppr.hs b/GHC/Parser/Errors/Ppr.hs --- a/GHC/Parser/Errors/Ppr.hs +++ b/GHC/Parser/Errors/Ppr.hs @@ -7,6 +7,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -22,25 +23,27 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc -import GHC.Types.Error.Codes ( constructorCode ) +import GHC.Types.Error.Codes import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Data.FastString import GHC.Data.Maybe (catMaybes) -import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword) -import GHC.Hs.Type (pprLHsContext) +import GHC.Hs.Expr (prependQualified, HsExpr(..), HsLamVariant(..), lamCaseKeyword) +import GHC.Hs.Type (pprLHsContext, pprHsArrow, pprHsForAll) import GHC.Builtin.Names (allNameStringList) -import GHC.Builtin.Types (filterCTuple) import qualified GHC.LanguageExtensions as LangExt import Data.List.NonEmpty (NonEmpty((:|))) +import GHC.Hs.Pat (Pat(..), LPat) +import GHC.Hs.Extension +import GHC.Parser.Annotation (noAnn) instance Diagnostic PsMessage where type DiagnosticOpts PsMessage = NoDiagnosticOpts diagnosticMessage opts = \case - PsUnknownMessage (UnknownDiagnostic f m) + PsUnknownMessage (UnknownDiagnostic f _ m) -> diagnosticMessage (f opts) m PsHeaderMessage m @@ -120,7 +123,32 @@ -> mkSimpleDecorated $ text "Found" <+> quotes (text "qualified") <+> text "in prepositive position" + PsWarnViewPatternSignatures old new + -> mkDecorated $ + [ text "Found an unparenthesized pattern signature on the RHS of a view pattern." + , vcat [ text "This code might stop working in a future GHC release" + , text "due to a planned change to the precedence of view patterns," + , text "unless the view function is an endofunction." ] + , nest 2 $ + vcat [ text "Current parse:" <+> quotes (ppr (add_parens_sig old)) + , text "Future parse:" <+> quotes (ppr (add_parens_view new)) ] + ] + where + add_parens_sig :: LPat GhcPs -> LPat GhcPs + add_parens_sig = go + where go (L l (ViewPat x e p)) = L l (ViewPat x e (go p)) + go (L l (SigPat x p sig)) = par_pat (L l (SigPat x p sig)) + go p = p + add_parens_view :: LPat GhcPs -> LPat GhcPs + add_parens_view = go + where go (L l (ViewPat x e p)) = par_pat (L l (ViewPat x e p)) + go (L l (SigPat x p sig)) = L l (SigPat x (go p) sig) + go p = p + + par_pat :: LPat GhcPs -> LPat GhcPs + par_pat p = L noAnn (ParPat noAnn p) + PsErrLexer err kind -> mkSimpleDecorated $ hcat [ case err of @@ -128,8 +156,6 @@ LexUnknownPragma -> text "unknown pragma" LexErrorInPragma -> text "lexical error in pragma" LexNumEscapeRange -> text "numeric escape sequence out of range" - LexStringCharLit -> text "lexical error in string/character literal" - LexStringCharLitEOF -> text "unexpected end-of-file in string/character literal" LexUnterminatedComment -> text "unterminated `{-'" LexUnterminatedOptions -> text "unterminated OPTIONS pragma" LexUnterminatedQQ -> text "unterminated quasiquotation" @@ -201,7 +227,7 @@ NumUnderscore_Integral -> "Illegal underscores in integer literals" NumUnderscore_Float -> "Illegal underscores in floating literals" PsErrIllegalBangPattern e - -> mkSimpleDecorated $ text "Illegal bang-pattern" $$ ppr e + -> mkSimpleDecorated $ text "Illegal bang-pattern or strict binding" $$ ppr e PsErrOverloadedRecordDotInvalid -> mkSimpleDecorated $ text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)" @@ -247,10 +273,15 @@ 2 (pprWithCommas ppr vs) , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] - PsErrIllegalExplicitNamespace + PsErrIllegalExplicitNamespace kw -> mkSimpleDecorated $ - text "Illegal keyword 'type'" + text "Illegal keyword" <+> quotes kw_doc + where + kw_doc = case kw of + ExplicitTypeNamespace{} -> text "type" + ExplicitDataNamespace{} -> text "data" + PsErrUnallowedPragma prag -> mkSimpleDecorated $ hang (text "A pragma is not allowed in this position:") 2 @@ -261,6 +292,8 @@ <+> text "in postpositive position. " PsErrImportQualifiedTwice -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'" + PsErrSpliceOrQuoteTwice + -> mkSimpleDecorated $ text "Multiple occurrences of a splice or quote keyword" PsErrIllegalImportBundleForm -> mkSimpleDecorated $ text "Illegal import form, this syntax can only be used to bundle" @@ -327,16 +360,12 @@ -> mkSimpleDecorated $ text "do-notation in pattern" PsErrIfThenElseInPat -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern" - (PsErrLambdaCaseInPat lc_variant) - -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern" PsErrCaseInPat -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern" PsErrLetInPat -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern" - PsErrLambdaInPat - -> mkSimpleDecorated $ - text "Lambda-syntax in pattern." - $$ text "Pattern matching on functions is not possible." + PsErrLambdaInPat lam_variant + -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword lam_variant <> text "-syntax in pattern" PsErrArrowExprInPat e -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e PsErrArrowCmdInPat c @@ -347,18 +376,16 @@ [ text "Arrow command found where an expression was expected:" , nest 2 (ppr c) ] - PsErrViewPatInExpr a b + PsErrOrPatInExpr p -> mkSimpleDecorated $ - sep [ text "View pattern in expression context:" - , nest 4 (ppr a <+> text "->" <+> ppr b) + sep [ text "Or pattern in expression context:" + , nest 4 (ppr p) ] - PsErrLambdaCmdInFunAppCmd a - -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a PsErrCaseCmdInFunAppCmd a -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a - PsErrLambdaCaseCmdInFunAppCmd lc_variant a + PsErrLambdaCmdInFunAppCmd lam_variant a -> mkSimpleDecorated $ - pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a + pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "command") a PsErrIfCmdInFunAppCmd a -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a PsErrLetCmdInFunAppCmd a @@ -369,12 +396,10 @@ -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a PsErrMDoInFunAppExpr m a -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a - PsErrLambdaInFunAppExpr a - -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a PsErrCaseInFunAppExpr a -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a - PsErrLambdaCaseInFunAppExpr lc_variant a - -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a + PsErrLambdaInFunAppExpr lam_variant a + -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "expression") a PsErrLetInFunAppExpr a -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a PsErrIfInFunAppExpr a @@ -394,7 +419,8 @@ -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'" PsErrSuffixAT -> mkSimpleDecorated $ - text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace." + text "The symbol '@' occurs as a suffix." $$ + text "For an as-pattern, there must not be any whitespace surrounding '@'." PsErrPrecedenceOutOfRange i -> mkSimpleDecorated $ text "Precedence out of range: " <> int i PsErrSemiColonsInCondExpr c st t se e @@ -442,12 +468,6 @@ -> let msg = parse_error_in_pat body = case details of PEIP_NegApp -> text "-" <> ppr s - PEIP_TypeArgs peipd_tyargs - | not (null peipd_tyargs) -> ppr s <+> vcat [ - hsep (map ppr peipd_tyargs) - , text "Type applications in patterns are only allowed on data constructors." - ] - | otherwise -> ppr s PEIP_OtherPatDetails (ParseContext (Just fun) _) -> ppr s <+> text "In a function binding for the" <+> quotes (ppr fun) @@ -462,28 +482,29 @@ PsErrIllegalRoleName role _nearby -> mkSimpleDecorated $ text "Illegal role name" <+> quotes (ppr role) - PsErrInvalidTypeSignature lhs - -> mkSimpleDecorated $ - text "Invalid type signature:" - <+> ppr lhs - <+> text ":: ..." + PsErrInvalidTypeSignature reason lhs + -> mkSimpleDecorated $ case reason of + PsErrInvalidTypeSig_DataCon -> text "Invalid data constructor" <+> quotes (ppr lhs) <+> + text "in type signature" <> colon $$ + text "You can only define data constructors in data type declarations." + PsErrInvalidTypeSig_Qualified -> text "Invalid qualified name in type signature." + PsErrInvalidTypeSig_Other -> text "Invalid type signature" <> colon $$ + text "A type signature should be of form" <+> + placeHolder "variables" <+> dcolon <+> placeHolder "type" <> + dot + where placeHolder = angleBrackets . text PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where -> mkSimpleDecorated $ vcat [ text "Unexpected type" <+> quotes (ppr t) , text "In the" <+> what - <+> text "declaration for" <+> quotes tc' + <+> text "declaration for" <+> quotes (ppr tc) , vcat[ (text "A" <+> what <+> text "declaration should have form") , nest 2 (what - <+> tc' + <+> ppr tc <+> hsep (map text (takeList tparms allNameStringList)) <+> equals_or_where) ] ] - where - -- Avoid printing a constraint tuple in the error message. Print - -- a plain old tuple instead (since that's what the user probably - -- wrote). See #14907 - tc' = ppr $ filterCTuple tc PsErrInvalidPackageName pkg -> mkSimpleDecorated $ vcat [ text "Parse error" <> colon <+> quotes (ftext pkg) @@ -514,7 +535,50 @@ , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma , text "but it is not" ] - diagnosticReason = \case + PsErrInvalidPun PEP_QuoteDisambiguation + -> mkSimpleDecorated $ vcat + [ text "Disambiguating data constructors of tuples and lists is disabled." + , text "Remove the quote to use the data constructor." + ] + + PsErrInvalidPun PEP_TupleSyntaxType + -> mkSimpleDecorated $ vcat + [ text "Unboxed tuple data constructors are not supported in types." + , text "Use" <+> quotes (text "Tuple# a b c ...") <+> text "to refer to the type constructor." + ] + + PsErrInvalidPun PEP_SumSyntaxType + -> mkSimpleDecorated $ vcat + [ text "Unboxed sum data constructors are not supported in types." + , text "Use" <+> quotes (text "Sum# a b c ...") <+> text "to refer to the type constructor." + ] + PsErrTypeSyntaxInPat ctx + -> mkSimpleDecorated $ vcat + [ text "Illegal" <+> text what <+> "in pattern:" <+> quotes ctx' + , text "Type syntax in patterns isn't supported at the time"] + where + (what, ctx') = case ctx of + PETS_FunctionArrow arg arr res -> ("function arrow", ppr arg <+> pprHsArrow arr <+> ppr res) + PETS_Multiplicity tok p -> ("multiplicity annotation", ppr tok <> ppr p) + PETS_ForallTelescope tele body -> ("forall telescope", pprHsForAll tele Nothing <+> ppr body) + PETS_ConstraintContext ctx -> ("constraint context", ppr ctx) + + PsErrIllegalOrPat pat + -> mkSimpleDecorated $ vcat [text "Illegal or-pattern:" <+> ppr (unLoc pat)] + + PsErrSpecExprMultipleTypeAscription + -> mkSimpleDecorated $ + text "SPECIALISE expression doesn't support multiple type ascriptions" + + PsWarnSpecMultipleTypeAscription + -> mkSimpleDecorated $ + text "SPECIALISE pragmas with multiple type ascriptions are deprecated, and will be removed in GHC 9.18" + + PsWarnPatternNamespaceSpecifier _explicit_namespaces + -> mkSimpleDecorated $ + text "The" <+> quotes (text "pattern") <+> "namespace specifier is deprecated." + + diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters @@ -529,6 +593,7 @@ PsWarnUnrecognisedPragma{} -> WarningWithFlag Opt_WarnUnrecognisedPragmas PsWarnMisplacedPragma{} -> WarningWithFlag Opt_WarnMisplacedPragmas PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule + PsWarnViewPatternSignatures{} -> WarningWithFlag Opt_WarnViewPatternSignatures PsErrLexer{} -> ErrorWithoutFlag PsErrCmmLexer -> ErrorWithoutFlag PsErrCmmParser{} -> ErrorWithoutFlag @@ -559,10 +624,11 @@ PsErrNoSingleWhereBindInPatSynDecl{} -> ErrorWithoutFlag PsErrDeclSpliceNotAtTopLevel{} -> ErrorWithoutFlag PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag - PsErrIllegalExplicitNamespace -> ErrorWithoutFlag + PsErrIllegalExplicitNamespace{} -> ErrorWithoutFlag PsErrUnallowedPragma{} -> ErrorWithoutFlag PsErrImportPostQualified -> ErrorWithoutFlag PsErrImportQualifiedTwice -> ErrorWithoutFlag + PsErrSpliceOrQuoteTwice -> ErrorWithoutFlag PsErrIllegalImportBundleForm -> ErrorWithoutFlag PsErrInvalidRuleActivationMarker -> ErrorWithoutFlag PsErrMissingBlock -> ErrorWithoutFlag @@ -584,17 +650,15 @@ PsErrIllegalUnboxedFloatingLitInPat{} -> ErrorWithoutFlag PsErrDoNotationInPat{} -> ErrorWithoutFlag PsErrIfThenElseInPat -> ErrorWithoutFlag - PsErrLambdaCaseInPat{} -> ErrorWithoutFlag PsErrCaseInPat -> ErrorWithoutFlag PsErrLetInPat -> ErrorWithoutFlag - PsErrLambdaInPat -> ErrorWithoutFlag + PsErrLambdaInPat{} -> ErrorWithoutFlag PsErrArrowExprInPat{} -> ErrorWithoutFlag PsErrArrowCmdInPat{} -> ErrorWithoutFlag PsErrArrowCmdInExpr{} -> ErrorWithoutFlag - PsErrViewPatInExpr{} -> ErrorWithoutFlag - PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrOrPatInExpr{} -> ErrorWithoutFlag PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag - PsErrLambdaCaseCmdInFunAppCmd{} -> ErrorWithoutFlag + PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag @@ -602,7 +666,6 @@ PsErrMDoInFunAppExpr{} -> ErrorWithoutFlag PsErrLambdaInFunAppExpr{} -> ErrorWithoutFlag PsErrCaseInFunAppExpr{} -> ErrorWithoutFlag - PsErrLambdaCaseInFunAppExpr{} -> ErrorWithoutFlag PsErrLetInFunAppExpr{} -> ErrorWithoutFlag PsErrIfInFunAppExpr{} -> ErrorWithoutFlag PsErrProcInFunAppExpr{} -> ErrorWithoutFlag @@ -631,6 +694,12 @@ PsErrInvalidCApiImport {} -> ErrorWithoutFlag PsErrMultipleConForNewtype {} -> ErrorWithoutFlag PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag + PsErrInvalidPun {} -> ErrorWithoutFlag + PsErrIllegalOrPat{} -> ErrorWithoutFlag + PsErrTypeSyntaxInPat{} -> ErrorWithoutFlag + PsErrSpecExprMultipleTypeAscription{} -> ErrorWithoutFlag + PsWarnSpecMultipleTypeAscription{} -> WarningWithFlag Opt_WarnDeprecatedPragmas + PsWarnPatternNamespaceSpecifier{} -> WarningWithFlag Opt_WarnPatternNamespaceSpecifier diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m @@ -653,6 +722,7 @@ PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader] PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName , suggestExtension LangExt.ImportQualifiedPost] + PsWarnViewPatternSignatures{} -> [SuggestParenthesizePatternRHS] PsErrLexer{} -> noHints PsErrCmmLexer -> noHints PsErrCmmParser{} -> noHints @@ -684,10 +754,8 @@ PsErrOverloadedRecordDotInvalid{} -> noHints PsErrIllegalPatSynExport -> [suggestExtension LangExt.PatternSynonyms] PsErrOverloadedRecordUpdateNoQualifiedFields -> noHints - PsErrExplicitForall is_unicode -> - let info = text "or a similar language extension to enable explicit-forall syntax:" <+> - forallSym is_unicode <+> text ". " - in [ suggestExtensionWithInfo info LangExt.RankNTypes ] + PsErrExplicitForall is_unicode -> [useExtensionInOrderTo info LangExt.ExplicitForAll] + where info = "to enable syntax:" <+> forallSym is_unicode <+> angleBrackets "tvs" <> dot <+> angleBrackets "type" PsErrIllegalQualifiedDo{} -> [suggestExtension LangExt.QualifiedDo] PsErrQualifiedDoInCmd{} -> noHints PsErrRecordSyntaxInPatSynDecl{} -> noHints @@ -696,10 +764,11 @@ PsErrNoSingleWhereBindInPatSynDecl{} -> noHints PsErrDeclSpliceNotAtTopLevel{} -> noHints PsErrMultipleNamesInStandaloneKindSignature{} -> noHints - PsErrIllegalExplicitNamespace -> [suggestExtension LangExt.ExplicitNamespaces] + PsErrIllegalExplicitNamespace{} -> [suggestExtension LangExt.ExplicitNamespaces] PsErrUnallowedPragma{} -> noHints PsErrImportPostQualified -> [suggestExtension LangExt.ImportQualifiedPost] PsErrImportQualifiedTwice -> noHints + PsErrSpliceOrQuoteTwice -> noHints PsErrIllegalImportBundleForm -> noHints PsErrInvalidRuleActivationMarker -> noHints PsErrMissingBlock -> noHints @@ -722,17 +791,15 @@ PsErrIllegalUnboxedFloatingLitInPat{} -> noHints PsErrDoNotationInPat{} -> noHints PsErrIfThenElseInPat -> noHints - PsErrLambdaCaseInPat{} -> noHints PsErrCaseInPat -> noHints PsErrLetInPat -> noHints - PsErrLambdaInPat -> noHints + PsErrLambdaInPat{} -> noHints PsErrArrowExprInPat{} -> noHints PsErrArrowCmdInPat{} -> noHints PsErrArrowCmdInExpr{} -> noHints - PsErrViewPatInExpr{} -> noHints + PsErrOrPatInExpr{} -> noHints PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs - PsErrLambdaCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs @@ -740,14 +807,11 @@ PsErrMDoInFunAppExpr{} -> suggestParensAndBlockArgs PsErrLambdaInFunAppExpr{} -> suggestParensAndBlockArgs PsErrCaseInFunAppExpr{} -> suggestParensAndBlockArgs - PsErrLambdaCaseInFunAppExpr{} -> suggestParensAndBlockArgs PsErrLetInFunAppExpr{} -> suggestParensAndBlockArgs PsErrIfInFunAppExpr{} -> suggestParensAndBlockArgs PsErrProcInFunAppExpr{} -> suggestParensAndBlockArgs PsErrMalformedTyOrClDecl{} -> noHints - PsErrIllegalWhereInDataDecl -> - [ suggestExtensionWithInfo (text "or a similar language extension to enable syntax: data T where") - LangExt.GADTs ] + PsErrIllegalWhereInDataDecl -> [useExtensionInOrderTo "to enable syntax: data T where" LangExt.GADTSyntax] PsErrIllegalDataTypeContext{} -> [suggestExtension LangExt.DatatypeContexts] PsErrPrimStringInvalidChar -> noHints PsErrSuffixAT -> noHints @@ -773,15 +837,17 @@ sug_missingdo _ = Nothing PsErrParseRightOpSectionInPat{} -> noHints PsErrIllegalRoleName _ nearby -> [SuggestRoles nearby] - PsErrInvalidTypeSignature lhs -> + PsErrInvalidTypeSignature reason lhs -> if | foreign_RDR `looks_like` lhs -> [suggestExtension LangExt.ForeignFunctionInterface] | default_RDR `looks_like` lhs -> [suggestExtension LangExt.DefaultSignatures] | pattern_RDR `looks_like` lhs -> [suggestExtension LangExt.PatternSynonyms] + | PsErrInvalidTypeSig_Qualified <- reason + -> [SuggestTypeSignatureRemoveQualifier] | otherwise - -> [SuggestTypeSignatureForm] + -> [] where -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf #3805 @@ -801,8 +867,19 @@ PsErrInvalidCApiImport {} -> noHints PsErrMultipleConForNewtype {} -> noHints PsErrUnicodeCharLooksLike{} -> noHints + PsErrInvalidPun {} -> [suggestExtension LangExt.ListTuplePuns] + PsErrIllegalOrPat{} -> [suggestExtension LangExt.OrPatterns] + PsErrTypeSyntaxInPat{} -> noHints + PsErrSpecExprMultipleTypeAscription {} -> [SuggestSplittingIntoSeveralSpecialisePragmas] + PsWarnSpecMultipleTypeAscription{} -> [SuggestSplittingIntoSeveralSpecialisePragmas] + PsWarnPatternNamespaceSpecifier explicit_namespaces + | explicit_namespaces -> [SuggestDataKeyword] + | otherwise -> + let info = text "and replace" <+> quotes (text "pattern") + <+> text "with" <+> quotes (text "data") <> "." + in [useExtensionInOrderTo info LangExt.ExplicitNamespaces] - diagnosticCode = constructorCode + diagnosticCode = constructorCode @GHC psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc psHeaderMessageDiagnostic = \case diff --git a/GHC/Parser/Errors/Types.hs b/GHC/Parser/Errors/Types.hs --- a/GHC/Parser/Errors/Types.hs +++ b/GHC/Parser/Errors/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} module GHC.Parser.Errors.Types where @@ -68,7 +69,7 @@ arbitrary messages to be embedded. The typical use case would be GHC plugins willing to emit custom diagnostics. -} - PsUnknownMessage (UnknownDiagnostic (DiagnosticOpts PsMessage)) + PsUnknownMessage (UnknownDiagnosticFor PsMessage) {-| A group of parser messages emitted in 'GHC.Parser.Header'. See Note [Messages from GHC.Parser.Header]. @@ -141,6 +142,23 @@ | PsWarnOperatorWhitespace !FastString !OperatorWhitespaceOccurrence + {- | PsWarnViewPatternSignatures is a warning triggered by view patterns whose + RHS is an unparenthesised pattern signature. It warns on code that is + highly likely to break when the precedence of view patterns relative to + pattern signatures is changed per GHC Proposal #281. The suggested fix + is to add parentheses. + + Example: + f1 (isJust -> True :: Bool) = () + + Suggested fix: + f1 (isJust -> (True :: Bool)) = () + + Test cases: + T24159_viewpat + -} + | PsWarnViewPatternSignatures !(LPat GhcPs) !(LPat GhcPs) + -- | LambdaCase syntax used without the extension enabled | PsErrLambdaCase @@ -189,11 +207,14 @@ -- | Import: multiple occurrences of 'qualified' | PsErrImportQualifiedTwice + -- | Multiple occurrences of a splice or quote keyword + | PsErrSpliceOrQuoteTwice + -- | Post qualified import without 'ImportQualifiedPost' | PsErrImportPostQualified -- | Explicit namespace keyword without 'ExplicitNamespaces' - | PsErrIllegalExplicitNamespace + | PsErrIllegalExplicitNamespace !ExplicitNamespaceKeyword -- | Expecting a type constructor but found a variable | PsErrVarForTyCon !RdrName @@ -249,8 +270,8 @@ -- | If-then-else syntax in pattern | PsErrIfThenElseInPat - -- | Lambda-case in pattern - | PsErrLambdaCaseInPat LamCaseVariant + -- | Lambda or Lambda-case in pattern + | PsErrLambdaInPat HsLamVariant -- | case..of in pattern | PsErrCaseInPat @@ -258,9 +279,6 @@ -- | let-syntax in pattern | PsErrLetInPat - -- | Lambda-syntax in pattern - | PsErrLambdaInPat - -- | Arrow expression-syntax in pattern | PsErrArrowExprInPat !(HsExpr GhcPs) @@ -270,8 +288,8 @@ -- | Arrow command-syntax in expression | PsErrArrowCmdInExpr !(HsCmd GhcPs) - -- | View-pattern in expression - | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs) + -- | Or-pattern in expression + | PsErrOrPatInExpr !(LPat GhcPs) -- | Type-application without space before '@' | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs) @@ -310,14 +328,11 @@ -- | @-operator in a pattern position | PsErrAtInPatPos - -- | Unexpected lambda command in function application - | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs) - -- | Unexpected case command in function application | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) - -- | Unexpected \case(s) command in function application - | PsErrLambdaCaseCmdInFunAppCmd !LamCaseVariant !(LHsCmd GhcPs) + -- | Unexpected lambda or \case(s) command in function application + | PsErrLambdaCmdInFunAppCmd !HsLamVariant !(LHsCmd GhcPs) -- | Unexpected if command in function application | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs) @@ -334,14 +349,11 @@ -- | Unexpected mdo block in function application | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) - -- | Unexpected lambda expression in function application - | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs) - -- | Unexpected case expression in function application | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) - -- | Unexpected \case(s) expression in function application - | PsErrLambdaCaseInFunAppExpr !LamCaseVariant !(LHsExpr GhcPs) + -- | Unexpected lambda or \case(s) expression in function application + | PsErrLambdaInFunAppExpr !HsLamVariant !(LHsExpr GhcPs) -- | Unexpected let expression in function application | PsErrLetInFunAppExpr !(LHsExpr GhcPs) @@ -398,7 +410,7 @@ | PsErrIllegalRoleName !FastString [Role] -- | Invalid type signature - | PsErrInvalidTypeSignature !(LHsExpr GhcPs) + | PsErrInvalidTypeSignature !PsInvalidTypeSignature !(LHsExpr GhcPs) -- | Unexpected type in declaration | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) @@ -457,7 +469,7 @@ | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs) -- | Illegal linear arrow or multiplicity annotation in GADT record syntax - | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) + | PsErrIllegalGadtRecordMultiplicity !(HsMultAnn GhcPs) | PsErrInvalidCApiImport @@ -468,6 +480,41 @@ Char -- ^ the character it looks like String -- ^ the name of the character that it looks like + | PsErrInvalidPun !PsErrPunDetails + + -- | Or pattern used without -XOrPatterns + | PsErrIllegalOrPat (LPat GhcPs) + + -- | Temporary error until GHC gains support for type syntax in patterns. + -- Test cases: T24159_pat_parse_error_1 + -- T24159_pat_parse_error_2 + -- T24159_pat_parse_error_3 + -- T24159_pat_parse_error_4 + -- T24159_pat_parse_error_5 + -- T24159_pat_parse_error_6 + | PsErrTypeSyntaxInPat !PsErrTypeSyntaxDetails + + -- | 'PsErrSpecExprMultipleTypeAscription' is an error that occurs when + -- a user attempts to use the new form SPECIALISE pragma syntax with + -- multiple type signatures, e.g. + -- + -- @{-# SPECIALISE foo 3 :: Float -> Float; Double -> Double #-} + | PsErrSpecExprMultipleTypeAscription + + -- | 'PsWarnSpecMultipleTypeAscription' is a warning that occurs when + -- a user uses the old-form SPECIALISE pragma syntax with + -- multiple type signatures, e.g. + -- + -- @{-# SPECIALISE bar :: Float -> Float; Double -> Double #-} + -- + -- This constructor is deprecated and will be removed in GHC 9.18. + | PsWarnSpecMultipleTypeAscription + + -- | The deprecated ``pattern`` namespace specifier was used in an import or + -- export list. Suggested fix: use the ``data`` keyword instead. + | PsWarnPatternNamespaceSpecifier + !Bool -- ^ Is ExplicitNamespaces on? + deriving Generic -- | Extra details about a parse error, which helps @@ -487,6 +534,11 @@ -- ^ Did we parse a \"pattern\" keyword? } +data PsInvalidTypeSignature + = PsErrInvalidTypeSig_Qualified + | PsErrInvalidTypeSig_DataCon + | PsErrInvalidTypeSig_Other + -- | Is the parsed pattern recursive? data PatIsRecursive = YesPatIsRecursive @@ -511,13 +563,29 @@ data PsErrInPatDetails = PEIP_NegApp -- ^ Negative application pattern? - | PEIP_TypeArgs [HsConPatTyArg GhcPs] - -- ^ The list of type arguments for the pattern | PEIP_RecPattern [LPat GhcPs] -- ^ The pattern arguments !PatIsRecursive -- ^ Is the parsed pattern recursive? !ParseContext | PEIP_OtherPatDetails !ParseContext +data PsErrPunDetails + = PEP_QuoteDisambiguation + | PEP_TupleSyntaxType + | PEP_SumSyntaxType + +data PsErrTypeSyntaxDetails + = PETS_FunctionArrow + !(LocatedA (PatBuilder GhcPs)) + !(HsMultAnnOf (LocatedA (PatBuilder GhcPs)) GhcPs) + !(LocatedA (PatBuilder GhcPs)) + | PETS_Multiplicity + !(EpToken "%") + !(LocatedA (PatBuilder GhcPs)) + | PETS_ForallTelescope + !(HsForAllTelescope GhcPs) + !(LocatedA (PatBuilder GhcPs)) + | PETS_ConstraintContext !(LocatedA (PatBuilder GhcPs)) + noParseContext :: ParseContext noParseContext = ParseContext Nothing NoIncompleteDoBlock @@ -533,6 +601,7 @@ | NumUnderscore_Float deriving (Show,Eq,Ord) + data LexErrKind = LexErrKind_EOF -- ^ End of input | LexErrKind_UTF8 -- ^ UTF-8 decoding error @@ -544,11 +613,10 @@ | LexUnknownPragma -- ^ Unknown pragma | LexErrorInPragma -- ^ Lexical error in pragma | LexNumEscapeRange -- ^ Numeric escape sequence out of range - | LexStringCharLit -- ^ Lexical error in string/character literal - | LexStringCharLitEOF -- ^ Unexpected end-of-file in string/character literal | LexUnterminatedComment -- ^ Unterminated `{-' | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma | LexUnterminatedQQ -- ^ Unterminated quasiquotation + deriving (Show,Eq,Ord) -- | Errors from the Cmm parser data CmmParserError diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,9 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.8.4-src/ghc-9.8.4/compiler/GHC/Parser/HaddockLex.x" #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LINE 1 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/HaddockLex.x" #-} {-# OPTIONS_GHC -funbox-strict-fields #-} module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where @@ -13,6 +11,7 @@ import GHC.Data.FastString import GHC.Hs.Doc import GHC.Parser.Lexer +import GHC.Parser.Lexer.Interface (adjustChar) import GHC.Parser.Annotation import GHC.Types.SrcLoc import GHC.Types.SourceText @@ -109,113 +108,6 @@ , (0,alex_action_1) ] -{-# LINE 86 "_build/source-dist/ghc-9.8.4-src/ghc-9.8.4/compiler/GHC/Parser/HaddockLex.x" #-} -data AlexInput = AlexInput - { alexInput_position :: !RealSrcLoc - , alexInput_string :: !ByteString - } - --- NB: As long as we don't use a left-context we don't need to track the --- previous input character. -alexInputPrevChar :: AlexInput -> Word8 -alexInputPrevChar = error "Left-context not supported" - -alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) -alexGetByte (AlexInput p s) = case utf8UnconsByteString s of - Nothing -> Nothing - Just (c,bs) -> Just (adjustChar c, AlexInput (advanceSrcLoc p c) bs) - -alexScanTokens :: RealSrcLoc -> ByteString -> [(RealSrcSpan, ByteString)] -alexScanTokens start str0 = go (AlexInput start str0) - where go inp@(AlexInput pos str) = - case alexScan inp 0 of - AlexSkip inp' _ln -> go inp' - AlexToken inp'@(AlexInput _ str') _ act -> act pos (BS.length str - BS.length str') str : go inp' - AlexEOF -> [] - AlexError (AlexInput p _) -> error $ "lexical error at " ++ show p - --------------------------------------------------------------------------------- - --- | Extract identifier from Alex state. -getIdentifier :: Int -- ^ adornment length - -> RealSrcLoc - -> Int - -- ^ Token length - -> ByteString - -- ^ The remaining input beginning with the found token - -> (RealSrcSpan, ByteString) -getIdentifier !i !loc0 !len0 !s0 = - (mkRealSrcSpan loc1 loc2, ident) - where - (adornment, s1) = BS.splitAt i s0 - ident = BS.take (len0 - 2*i) s1 - loc1 = advanceSrcLocBS loc0 adornment - loc2 = advanceSrcLocBS loc1 ident - -advanceSrcLocBS :: RealSrcLoc -> ByteString -> RealSrcLoc -advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of - Nothing -> loc - Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs' - --- | Lex 'StringLiteral' for warning messages -lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser - -> Located StringLiteral - -> Located (WithHsDocIdentifiers StringLiteral GhcPs) -lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) - = L l (WithHsDocIdentifiers sl idents) - where - bs = bytesFS fs - - idents = mapMaybe (uncurry (validateIdentWith identParser)) plausibleIdents - - plausibleIdents :: [(SrcSpan,ByteString)] - plausibleIdents = case l of - RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] - UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] - - fakeLoc = mkRealSrcLoc nilFS 0 0 - --- | Lex identifiers from a docstring. -lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser - -> HsDocString - -> HsDoc GhcPs -lexHsDoc identParser doc = - WithHsDocIdentifiers doc idents - where - docStrings = docStringChunks doc - idents = concat [mapMaybe maybeDocIdentifier (plausibleIdents doc) | doc <- docStrings] - - maybeDocIdentifier :: (SrcSpan, ByteString) -> Maybe (Located RdrName) - maybeDocIdentifier = uncurry (validateIdentWith identParser) - - plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)] - plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s)) - = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] - plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) - = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason - - fakeLoc = mkRealSrcLoc nilFS 0 0 - -validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) -validateIdentWith identParser mloc str0 = - let -- These ParserFlags should be as "inclusive" as possible, allowing - -- identifiers defined with any language extension. - pflags = mkParserOpts - (EnumSet.fromList [LangExt.MagicHash]) - dopts - [] - False False False False - dopts = emptyDiagOpts - buffer = stringBufferFromByteString str0 - realSrcLc = case mloc of - RealSrcSpan loc _ -> realSrcSpanStart loc - UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 - pstate = initParserState pflags buffer realSrcLc - in case unP identParser pstate of - POk _ name -> Just $ case mloc of - RealSrcSpan _ _ -> reLoc name - UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason - _ -> Nothing alex_action_0 = getIdentifier 1 alex_action_1 = getIdentifier 2 @@ -385,9 +277,10 @@ let base = alexIndexInt32OffAddr alex_base s offset = PLUS(base,ord_c) - check = alexIndexInt16OffAddr alex_check offset - new_s = if GTE(offset,ILIT(0)) && EQ(check,ord_c) + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in @@ -460,3 +353,109 @@ -- match when checking the right context, just -- the first match will do. #endif +{-# LINE 85 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/HaddockLex.x" #-} +data AlexInput = AlexInput + { alexInput_position :: !RealSrcLoc + , alexInput_string :: !ByteString + } + +-- NB: As long as we don't use a left-context we don't need to track the +-- previous input character. +alexInputPrevChar :: AlexInput -> Word8 +alexInputPrevChar = error "Left-context not supported" + +alexGetByte :: AlexInput -> Maybe (Word8, AlexInput) +alexGetByte (AlexInput p s) = case utf8UnconsByteString s of + Nothing -> Nothing + Just (c,bs) -> Just (adjustChar c, AlexInput (advanceSrcLoc p c) bs) + +alexScanTokens :: RealSrcLoc -> ByteString -> [(RealSrcSpan, ByteString)] +alexScanTokens start str0 = go (AlexInput start str0) + where go inp@(AlexInput pos str) = + case alexScan inp 0 of + AlexSkip inp' _ln -> go inp' + AlexToken inp'@(AlexInput _ str') _ act -> act pos (BS.length str - BS.length str') str : go inp' + AlexEOF -> [] + AlexError (AlexInput p _) -> error $ "lexical error at " ++ show p + +-------------------------------------------------------------------------------- + +-- | Extract identifier from Alex state. +getIdentifier :: Int -- ^ adornment length + -> RealSrcLoc + -> Int + -- ^ Token length + -> ByteString + -- ^ The remaining input beginning with the found token + -> (RealSrcSpan, ByteString) +getIdentifier !i !loc0 !len0 !s0 = + (mkRealSrcSpan loc1 loc2, ident) + where + (adornment, s1) = BS.splitAt i s0 + ident = BS.take (len0 - 2*i) s1 + loc1 = advanceSrcLocBS loc0 adornment + loc2 = advanceSrcLocBS loc1 ident + +advanceSrcLocBS :: RealSrcLoc -> ByteString -> RealSrcLoc +advanceSrcLocBS !loc bs = case utf8UnconsByteString bs of + Nothing -> loc + Just (c, bs') -> advanceSrcLocBS (advanceSrcLoc loc c) bs' + +-- | Lex 'StringLiteral' for warning messages +lexStringLiteral :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> Located StringLiteral + -> Located (WithHsDocIdentifiers StringLiteral GhcPs) +lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) + = L l (WithHsDocIdentifiers sl idents) + where + bs = bytesFS fs + + idents = mapMaybe (uncurry (validateIdentWith identParser)) plausibleIdents + + plausibleIdents :: [(SrcSpan,ByteString)] + plausibleIdents = case l of + RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] + UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + + fakeLoc = mkRealSrcLoc nilFS 0 0 + +-- | Lex identifiers from a docstring. +lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser + -> HsDocString + -> HsDoc GhcPs +lexHsDoc identParser doc = + WithHsDocIdentifiers doc idents + where + docStrings = docStringChunks doc + idents = concat [mapMaybe maybeDocIdentifier (plausibleIdents doc) | doc <- docStrings] + + maybeDocIdentifier :: (SrcSpan, ByteString) -> Maybe (Located RdrName) + maybeDocIdentifier = uncurry (validateIdentWith identParser) + + plausibleIdents :: LHsDocStringChunk -> [(SrcSpan,ByteString)] + plausibleIdents (L (RealSrcSpan span _) (HsDocStringChunk s)) + = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] + plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) + = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + + fakeLoc = mkRealSrcLoc nilFS 0 0 + +validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) +validateIdentWith identParser mloc str0 = + let -- These ParserFlags should be as "inclusive" as possible, allowing + -- identifiers defined with any language extension. + pflags = mkParserOpts + (EnumSet.fromList [LangExt.MagicHash]) + dopts + False False False False + dopts = emptyDiagOpts + buffer = stringBufferFromByteString str0 + realSrcLc = case mloc of + RealSrcSpan loc _ -> realSrcSpanStart loc + UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 + pstate = initParserState pflags buffer realSrcLc + in case unP identParser pstate of + POk _ name -> Just $ case mloc of + RealSrcSpan _ _ -> reLoc name + UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> Nothing diff --git a/GHC/Parser/Header.hs b/GHC/Parser/Header.hs --- a/GHC/Parser/Header.hs +++ b/GHC/Parser/Header.hs @@ -31,7 +31,6 @@ import GHC.Parser.Lexer import GHC.Hs -import GHC.Unit.Module import GHC.Builtin.Names import GHC.Types.Error @@ -39,6 +38,7 @@ import GHC.Types.SourceError import GHC.Types.SourceText import GHC.Types.PkgQual +import GHC.Types.Basic (ImportLevel(..), convImportLevel) import GHC.Utils.Misc import GHC.Utils.Panic @@ -74,9 +74,8 @@ -- in the function result) -> IO (Either (Messages PsMessage) - ([(RawPkgQual, Located ModuleName)], - [(RawPkgQual, Located ModuleName)], - Bool, -- Is GHC.Prim imported or not + ([Located ModuleName], + [(ImportLevel, RawPkgQual, Located ModuleName)], Located ModuleName)) -- ^ The source imports and normal imports (with optional package -- names from -XPackageImports), and the module name. @@ -101,21 +100,17 @@ mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps - -- GHC.Prim doesn't exist physically, so don't go looking for it. - (ordinary_imps, ghc_prim_import) - = partition ((/= moduleName gHC_PRIM) . unLoc - . ideclName . unLoc) - ord_idecls - implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps - convImport (L _ i) = (ideclPkgQual i, reLoc $ ideclName i) + convImport (L _ (i :: ImportDecl GhcPs)) = (convImportLevel (ideclLevelSpec i), ideclPkgQual i, reLoc $ ideclName i) + convImport_src (L _ (i :: ImportDecl GhcPs)) = (reLoc $ ideclName i) in - return (map convImport src_idecls - , map convImport (implicit_imports ++ ordinary_imps) - , not (null ghc_prim_import) + return (map convImport_src src_idecls + , map convImport (implicit_imports ++ ord_idecls) , reLoc mod) + + mkPrelImports :: ModuleName -> SrcSpan -- Attribute the "import Prelude" to this location -> Bool -> [LImportDecl GhcPs] @@ -134,12 +129,17 @@ where explicit_prelude_import = any is_prelude_import import_decls - is_prelude_import (L _ decl) = + is_prelude_import (L _ (decl::ImportDecl GhcPs)) = unLoc (ideclName decl) == pRELUDE_NAME - -- allow explicit "base" package qualifier (#19082, #17045) + -- See #17045, package qualified imports are never counted as + -- explicit prelude imports && case ideclPkgQual decl of NoRawPkgQual -> True - RawPkgQual b -> sl_fs b == unitIdFS baseUnitId + RawPkgQual {} -> False + -- Only a "normal" level import will override the implicit prelude import. + && case ideclLevelSpec decl of + NotLevelled -> True + _ -> False loc' = noAnnSrcSpan loc @@ -156,6 +156,7 @@ ideclSafe = False, -- Not a safe import ideclQualified = NotQualified, ideclAs = Nothing, + ideclLevelSpec = NotLevelled, ideclImportList = Nothing } -------------------------------------------------------------- @@ -166,14 +167,15 @@ -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) getOptionsFromFile :: ParserOpts + -> [String] -- ^ Supported LANGUAGE pragmas -> FilePath -- ^ Input file -> IO (Messages PsMessage, [Located String]) -- ^ Parsed options, if any. -getOptionsFromFile opts filename +getOptionsFromFile opts supported filename = Exception.bracket (openBinaryFile filename ReadMode) (hClose) (\handle -> do - (warns, opts) <- fmap (getOptions' opts) + (warns, opts) <- fmap (getOptions' opts supported) (lazyGetToks opts' filename handle) seqList opts $ seqList (bagToList $ getMessages warns) @@ -247,20 +249,22 @@ -- -- Throws a 'SourceError' if flag parsing fails (including unsupported flags.) getOptions :: ParserOpts + -> [String] -- ^ Supported LANGUAGE pragmas -> StringBuffer -- ^ Input Buffer -> FilePath -- ^ Source filename. Used for location info. -> (Messages PsMessage,[Located String]) -- ^ warnings and parsed options. -getOptions opts buf filename - = getOptions' opts (getToks opts filename buf) +getOptions opts supported buf filename + = getOptions' opts supported (getToks opts filename buf) -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error. -- We want to extract options before the buffer is passed through -- CPP, so we can't use the same trick as 'getImports'. getOptions' :: ParserOpts + -> [String] -> [Located Token] -- Input buffer -> (Messages PsMessage,[Located String]) -- Options. -getOptions' opts toks +getOptions' opts supported toks = parseToks toks where parseToks (open:close:xs) @@ -272,7 +276,7 @@ Right args -> fmap (args ++) (parseToks xs) where src_span = getLoc open - real_src_span = expectJust "getOptions'" (srcSpanToRealSrcSpan src_span) + real_src_span = expectJust (srcSpanToRealSrcSpan src_span) starting_loc = realSrcSpanStart real_src_span parseToks (open:close:xs) | ITinclude_prag str <- unLoc open @@ -294,7 +298,7 @@ parseToks xs = (unionManyMessages $ mapMaybe mkMessage xs ,[]) parseLanguage ((L loc (ITconid fs)):rest) - = fmap (checkExtension opts (L loc fs) :) $ + = fmap (checkExtension supported (L loc fs) :) $ case rest of (L _loc ITcomma):more -> parseLanguage more (L _loc ITclose_prag):more -> parseToks more @@ -444,13 +448,13 @@ ----------------------------------------------------------------------------- -checkExtension :: ParserOpts -> Located FastString -> Located String -checkExtension opts (L l ext) +checkExtension :: [String] -> Located FastString -> Located String +checkExtension supported (L l ext) -- Checks if a given extension is valid, and if so returns -- its corresponding flag. Otherwise it throws an exception. - = if ext' `elem` (pSupportedExts opts) + = if ext' `elem` supported then L l ("-X"++ext') - else unsupportedExtnError opts l ext' + else unsupportedExtnError supported l ext' where ext' = unpackFS ext @@ -458,9 +462,9 @@ languagePragParseError loc = throwErr loc $ PsErrParseLanguagePragma -unsupportedExtnError :: ParserOpts -> SrcSpan -> String -> a -unsupportedExtnError opts loc unsup = - throwErr loc $ PsErrUnsupportedExt unsup (pSupportedExts opts) +unsupportedExtnError :: [String] -> SrcSpan -> String -> a +unsupportedExtnError supported loc unsup = + throwErr loc $ PsErrUnsupportedExt unsup supported optionsParseError :: String -> SrcSpan -> a -- #15053 optionsParseError str loc = diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,4304 +1,4028 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.8.4-src/ghc-9.8.4/compiler/GHC/Parser/Lexer.x" #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UnboxedSums #-} -{-# LANGUAGE UnliftedNewtypes #-} -{-# LANGUAGE PatternSynonyms #-} - - -{-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Parser.Lexer ( - Token(..), lexer, lexerDbg, - ParserOpts(..), mkParserOpts, - PState (..), initParserState, initPragState, - P(..), ParseResult(POk, PFailed), - allocateComments, allocatePriorComments, allocateFinalComments, - MonadP(..), - getRealSrcLoc, getPState, - failMsgP, failLocMsgP, srcParseFail, - getPsErrorMessages, getPsMessages, - popContext, pushModuleContext, setLastToken, setSrcLoc, - activeContext, nextIsEOF, - getLexState, popLexState, pushLexState, - ExtBits(..), - xtest, xunset, xset, - disableHaddock, - lexTokenStream, - mkParensEpAnn, - getCommentsFor, getPriorCommentsFor, getFinalCommentsFor, - getEofPos, - commentToAnnotation, - HdkComment(..), - warnopt, - adjustChar, - addPsMessage - ) where - -import GHC.Prelude -import qualified GHC.Data.Strict as Strict - --- base -import Control.Monad -import Control.Applicative -import Data.Char -import Data.List (stripPrefix, isInfixOf, partition) -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import Data.Maybe -import Data.Word -import Debug.Trace (trace) - -import GHC.Data.EnumSet as EnumSet - --- ghc-boot -import qualified GHC.LanguageExtensions as LangExt - --- bytestring -import Data.ByteString (ByteString) - --- containers -import Data.Map (Map) -import qualified Data.Map as Map - --- compiler -import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.StringBuffer -import GHC.Data.FastString -import GHC.Types.Error -import GHC.Types.Unique.FM -import GHC.Data.Maybe -import GHC.Data.OrdList -import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) - -import GHC.Types.SrcLoc -import GHC.Types.SourceText -import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) -import GHC.Hs.Doc - -import GHC.Parser.CharClass - -import GHC.Parser.Annotation -import GHC.Driver.Flags -import GHC.Parser.Errors.Basic -import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr () -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array.Base (unsafeAt) -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xf7\x00\x00\x00\x05\x01\x00\x00\x2f\x01\x00\x00\x4b\x01\x00\x00\x86\x01\x00\x00\x75\x00\x00\x00\xd4\x01\x00\x00\xeb\x01\x00\x00\x64\x01\x00\x00\x2c\x02\x00\x00\x6d\x02\x00\x00\xe4\xff\xff\xff\x84\x02\x00\x00\x84\x01\x00\x00\xc5\x02\x00\x00\x0c\x02\x00\x00\x4d\x02\x00\x00\xa5\x02\x00\x00\xe8\x02\x00\x00\x06\x03\x00\x00\x1e\x03\x00\x00\x28\x03\x00\x00\x37\x03\x00\x00\x70\x03\x00\x00\x4b\x03\x00\x00\x58\x03\x00\x00\xc8\x03\x00\x00\xd2\x03\x00\x00\x16\x04\x00\x00\xec\x00\x00\x00\x64\x02\x00\x00\x3b\x04\x00\x00\x65\x00\x00\x00\x7e\x00\x00\x00\x84\x04\x00\x00\x9c\x04\x00\x00\xc1\x04\x00\x00\xfa\x04\x00\x00\xbc\x03\x00\x00\x7b\x04\x00\x00\x1f\x05\x00\x00\x82\x00\x00\x00\xbb\x00\x00\x00\x68\x05\x00\x00\x80\x05\x00\x00\xbd\x05\x00\x00\xf2\x05\x00\x00\x38\x06\x00\x00\x5b\x06\x00\x00\x83\x06\x00\x00\xe1\x06\x00\x00\x3d\x07\x00\x00\x62\x07\x00\x00\xbe\x07\x00\x00\xe1\x07\x00\x00\xde\xff\xff\xff\xe1\xff\xff\xff\x21\x08\x00\x00\xe5\xff\xff\xff\x9b\x08\x00\x00\x15\x09\x00\x00\xe6\xff\xff\xff\xed\xff\xff\xff\x8f\x09\x00\x00\x09\x0a\x00\x00\x83\x0a\x00\x00\xfd\x0a\x00\x00\x77\x0b\x00\x00\xf1\x0b\x00\x00\x6b\x0c\x00\x00\xc5\x0c\x00\x00\x43\x0d\x00\x00\xef\xff\xff\xff\xbd\x0d\x00\x00\x37\x0e\x00\x00\xb1\x0e\x00\x00\x2b\x0f\x00\x00\xa5\x0f\x00\x00\x1f\x10\x00\x00\x99\x10\x00\x00\x13\x11\x00\x00\x00\x00\x00\x00\xf1\xff\xff\xff\xf2\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x11\x00\x00\x43\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x12\x00\x00\x00\x00\x00\x00\x39\x13\x00\x00\x00\x00\x00\x00\xb5\x13\x00\x00\x00\x00\x00\x00\x31\x14\x00\x00\x00\x00\x00\x00\xad\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x15\x00\x00\x97\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\xff\xff\x78\x00\x00\x00\x00\x00\x00\x00\xa5\x15\x00\x00\x23\x01\x00\x00\x1f\x16\x00\x00\x55\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x99\x16\x00\x00\x13\x17\x00\x00\xd8\x04\x00\x00\x6a\x01\x00\x00\x9f\x05\x00\x00\x5f\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x15\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x00\x00\xe2\x04\x00\x00\x89\x17\x00\x00\xa0\x01\x00\x00\xc9\x17\x00\x00\x47\x18\x00\x00\xb5\x00\x00\x00\xcb\x00\x00\x00\x8f\x03\x00\x00\x8a\x00\x00\x00\x8f\x00\x00\x00\xc5\x18\x00\x00\xd4\x05\x00\x00\x3b\x19\x00\x00\x1e\x04\x00\x00\x7b\x19\x00\x00\xf9\x19\x00\x00\x77\x1a\x00\x00\xf1\x1a\x00\x00\x6b\x1b\x00\x00\xe5\x1b\x00\x00\x5f\x1c\x00\x00\x49\x01\x00\x00\xd9\x1c\x00\x00\x53\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x7c\x04\x00\x00\x7c\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x46\x00\x00\x00\x49\x00\x00\x00\x6b\x00\x00\x00\x7f\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\xd2\x00\x00\x00\x7d\x00\x00\x00\x81\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x4f\x02\x00\x00\x02\x04\x00\x00\xca\x1d\x00\x00\xf2\x1d\x00\x00\x35\x1e\x00\x00\x5d\x1e\x00\x00\xc3\x00\x00\x00\xa0\x1e\x00\x00\xc8\x1e\x00\x00\xe7\x00\x00\x00\xeb\x00\x00\x00\xed\x00\x00\x00\xef\x00\x00\x00\xf0\x00\x00\x00\xf4\x00\x00\x00\x03\x01\x00\x00\xd4\x00\x00\x00\x48\x05\x00\x00\x00\x00\x00\x00\x23\x04\x00\x00\x0d\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x01\x00\x00\xa1\x00\x00\x00\x94\x00\x00\x00\x98\x00\x00\x00\x22\x02\x00\x00\xa4\x00\x00\x00\x97\x00\x00\x00\x9d\x00\x00\x00\xba\x02\x00\x00\xaf\x00\x00\x00\xa2\x00\x00\x00\xa6\x00\x00\x00\xbb\x02\x00\x00\xb2\x00\x00\x00\xa7\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\x00\x00\x00\x00\x02\x01\x00\x00\x00\x00\x00\x00\x09\x01\x00\x00\x00\x00\x00\x00\x07\x01\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x13\x01\x00\x00\x00\x00\x00\x00\x14\x01\x00\x00\x00\x00\x00\x00\x16\x01\x00\x00\x00\x00\x00\x00\x18\x01\x00\x00\x00\x00\x00\x00\x1c\x01\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\xda\x00\x00\x00\xf1\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x02\x00\x00\xe5\x00\x00\x00\xfc\x00\x00\x00\xdc\x02\x00\x00\xea\x00\x00\x00\x0b\x01\x00\x00\xfb\x02\x00\x00\x06\x01\x00\x00\x0e\x01\x00\x00\x10\x03\x00\x00\x0a\x01\x00\x00\x15\x01\x00\x00\xe9\x03\x00\x00\x11\x01\x00\x00\x1b\x01\x00\x00\x09\x04\x00\x00\x1a\x01\x00\x00\x30\x01\x00\x00\x2c\x04\x00\x00\x2c\x01\x00\x00\x33\x01\x00\x00\x32\x04\x00\x00\x2e\x01\x00\x00\x35\x01\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x00\x00\x00\x00\x29\x01\x00\x00\x00\x00\x00\x00\x3c\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x47\x01\x00\x00\x00\x00\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x70\x01\x00\x00\x00\x00\x00\x00\x74\x01\x00\x00\x00\x00\x00\x00\x7e\x01\x00\x00\x00\x00\x00\x00\x7f\x01\x00\x00\x00\x00\x00\x00\xe6\x1e\x00\x00\x60\x1f\x00\x00\x8c\x01\x00\x00\x00\x00\x00\x00\x8d\x01\x00\x00\x00\x00\x00\x00\x92\x01\x00\x00\x00\x00\x00\x00\xb0\x01\x00\x00\x00\x00\x00\x00\xb2\x01\x00\x00\x00\x00\x00\x00\xd0\x01\x00\x00\x00\x00\x00\x00\xd8\x01\x00\x00\x00\x00\x00\x00\xd9\x01\x00\x00\x00\x00\x00\x00\xda\x01\x00\x00\x00\x00\x00\x00\xda\x1f\x00\x00\x14\x20\x00\x00\xdb\x01\x00\x00\x00\x00\x00\x00\xdc\x01\x00\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x00\x00\x00\x00\xde\x01\x00\x00\x00\x00\x00\x00\xef\x01\x00\x00\x8e\x20\x00\x00\x08\x21\x00\x00\x82\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x02\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x01\x00\x00\xe0\x01\x00\x00\xe1\x01\x00\x00\xe2\x01\x00\x00\x1d\x03\x00\x00\x97\x06\x00\x00\xb9\x06\x00\x00\xfc\x07\x00\x00\x76\x08\x00\x00\x6f\x17\x00\x00\x73\x07\x00\x00\x7e\x07\x00\x00\xf0\x08\x00\x00\x55\x03\x00\x00\x56\x03\x00\x00\xcd\x21\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x3e\x00\x4c\x00\x51\x00\x44\x00\x3a\x00\xd6\x00\xc0\x00\x3f\x00\x44\x00\xd5\x00\xa8\x00\xd6\x00\xd6\x00\xd6\x00\x14\x00\x45\x00\x14\x00\x4f\x00\x75\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x7f\x00\xd4\x00\x7a\x00\xd6\x00\x3a\x00\xd8\x00\x39\x00\x3a\x00\x3a\x00\x3a\x00\xd9\x00\x62\x00\x61\x00\x3a\x00\x3a\x00\x5d\x00\x35\x00\x3a\x00\x3a\x00\x2f\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x34\x00\x5c\x00\x3a\x00\x3a\x00\x3a\x00\x3b\x00\x3a\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x5f\x00\x3a\x00\x5e\x00\x3a\x00\x58\x01\x5b\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x59\x00\x37\x00\x58\x00\x3a\x00\xd6\x00\xc2\x00\x82\x00\x83\x00\xd5\x00\xbf\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xc2\x00\x65\x00\x8a\x00\xd5\x00\x8b\x00\xd6\x00\xd6\x00\xd6\x00\x8f\x00\x8d\x00\xff\xff\x28\x00\x28\x00\xca\x00\x68\x01\xff\xff\xa5\x00\xad\x00\x7d\x00\xaf\x00\xba\x00\xb0\x00\xb2\x00\x6b\x01\x7d\x00\xb4\x00\xd6\x00\xd6\x00\xc2\x00\xb5\x00\xc9\x00\xd5\x00\xab\x00\xd6\x00\xd6\x00\xd6\x00\x28\x00\x28\x00\xb6\x00\xc9\x00\x31\x00\x31\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x21\x01\xff\xff\xd6\x00\xd6\x00\xc2\x00\x06\x01\x27\x00\xd5\x00\xab\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xc2\x00\xe9\x00\xc9\x00\xd5\x00\xab\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xc2\x00\xff\xff\x7d\x00\xd5\x00\xb7\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x27\x00\x77\x01\x06\x01\xb8\x00\x30\x00\xd2\x00\xb9\x00\x6a\x00\xd6\x00\xbc\x00\x8f\x00\x06\x01\xc9\x00\xbe\x00\x31\x00\x31\x00\xff\xff\xd6\x00\xbd\x00\xca\x00\xff\xff\xc9\x00\xb1\x00\x7d\x00\xff\xff\xd3\x00\xff\xff\xc7\x00\xff\xff\xff\xff\xc9\x00\xd6\x00\xc2\x00\xff\xff\xd3\x00\xd5\x00\xa5\x00\xd6\x00\xd6\x00\xd6\x00\xda\x00\xdb\x00\xdc\x00\xde\x00\xdf\x00\x97\x00\xc1\x00\xe0\x00\xff\xff\x98\x00\xff\xff\x97\x00\x97\x00\x97\x00\xe2\x00\xe3\x00\xe4\x00\xe6\x00\xd6\x00\xe8\x00\xe7\x00\x30\x00\xac\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\xc9\x00\x97\x00\x9a\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\xea\x00\x96\x00\xec\x00\xd6\x00\xc2\x00\xee\x00\xac\x00\xd5\x00\xf2\x00\xd6\x00\xd6\x00\xd6\x00\xf0\x00\xbb\x00\xf4\x00\xac\x00\xa9\x00\xb3\x00\x7c\x00\xf6\x00\xf8\x00\x80\x00\x7d\x00\x03\x01\xd3\x00\xfa\x00\x24\x00\xfc\x00\x7d\x00\xfe\x00\xd6\x00\xd6\x00\xc2\x00\x00\x01\xaa\x00\xd5\x00\x05\x01\xd6\x00\xd6\x00\xd6\x00\x0a\x01\x04\x01\x22\x01\xc9\x00\x24\x01\x0d\x01\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x7c\x00\x0b\x01\xd6\x00\xa6\x00\x7d\x00\x8c\x00\x87\x00\x26\x01\x28\x01\xd3\x00\x7d\x00\x87\x00\x87\x00\x87\x00\x87\x00\x8e\x00\x0e\x01\x10\x01\x2a\x01\x11\x01\xfb\x00\x13\x01\xf3\x00\x95\x00\x7d\x00\xeb\x00\x14\x01\x02\x01\x16\x01\x2c\x01\x50\x00\x42\x00\x17\x01\x87\x00\xd6\x00\xc2\x00\x89\x00\x19\x01\xd5\x00\xa8\x00\xd6\x00\xd6\x00\xd6\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x1a\x01\x7d\x00\x1c\x01\x1d\x01\x1f\x01\x20\x01\x2e\x01\x92\x00\xd6\x00\x7d\x00\x30\x01\x81\x00\xd3\x00\x92\x00\x92\x00\x92\x00\x63\x00\x61\x00\x32\x01\x34\x01\x5d\x00\xc9\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x36\x01\x3a\x01\x92\x00\x5c\x00\x93\x00\xd7\x00\x3c\x01\x7d\x00\xd3\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x60\x00\x3e\x01\x5e\x00\x40\x01\x42\x00\x5b\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x5a\x00\x42\x01\x58\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x44\x01\x46\x01\x48\x01\x4a\x01\x4e\x01\x50\x01\x52\x01\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x54\x01\x61\x01\x63\x01\x0c\x01\x0f\x01\x12\x01\x15\x01\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\xd7\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x01\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\xfd\x00\x00\x00\xf5\x00\x00\x00\x00\x00\xed\x00\xff\xff\x07\x01\xd7\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x01\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\xce\x00\x1b\x00\x00\x00\x12\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x6a\x01\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x12\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\xce\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x12\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\xff\x00\x01\x01\xf7\x00\xf9\x00\x00\x00\xef\x00\xf1\x00\x08\x01\x09\x01\x12\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x45\x01\x47\x01\x33\x01\x35\x01\x00\x00\x23\x01\x25\x01\x59\x01\x5a\x01\x12\x00\x73\x01\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x10\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x49\x01\x17\x00\x39\x01\x00\x00\x00\x00\x27\x01\x00\x00\x5b\x01\x00\x00\x12\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x65\x01\x4d\x01\x00\x00\x3b\x01\x00\x00\x00\x00\x29\x01\x71\x01\x5c\x01\x00\x00\x00\x00\x62\x01\x00\x00\x17\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x20\x00\x00\x00\x20\x00\x1a\x00\x18\x01\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x51\x00\x51\x00\x51\x00\xdd\x00\x00\x00\x00\x00\x51\x00\x66\x01\x67\x01\x00\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x00\x00\x1a\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x44\x00\x97\x00\x00\x00\x00\x00\x51\x00\x00\x00\xff\xff\x97\x00\x97\x00\x97\x00\x00\x00\x1b\x01\x1e\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x1f\x00\x00\x00\xe1\x00\xe5\x00\x00\x00\x97\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x56\x01\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x56\x01\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x64\x01\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x00\x00\x4f\x01\x2d\x00\x3d\x01\x00\x00\x00\x00\x2b\x01\x00\x00\x5d\x01\xd7\x00\x9d\x00\x00\x00\x00\x00\xcd\x00\x1f\x00\xd6\x00\x9d\x00\x9d\x00\x9d\x00\xcd\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\x22\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x69\x01\x51\x01\x00\x00\x3f\x01\x00\x00\x9d\x00\x2d\x01\x9e\x00\x5e\x01\xd7\x00\xd6\x00\x0d\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x53\x01\x6c\x01\x41\x01\xcd\x00\x00\x00\x2f\x01\x55\x01\x5f\x01\x43\x01\xd7\x00\x00\x00\x31\x01\x73\x01\x60\x01\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x22\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x27\x00\xcd\x00\x00\x00\x17\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xd6\x00\xd6\x00\xd6\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\xd6\x00\x27\x00\x76\x01\xae\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x2e\x00\x22\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x73\x01\x00\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x00\x00\x6d\x01\x00\x00\x00\x00\x2b\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x11\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x90\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x6f\x01\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x13\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x30\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x12\x00\x7e\x00\x7d\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x0c\x00\x87\x00\x00\x00\x7d\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x1d\x00\x6f\x01\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x34\x00\x89\x00\x00\x00\x7d\x00\x1d\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x32\x00\x34\x00\x34\x00\x34\x00\x34\x00\x00\x00\x1d\x00\x00\x00\x34\x00\x34\x00\x00\x00\x34\x00\x34\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x34\x00\x00\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x34\x00\x00\x00\x34\x00\x3a\x00\x3a\x00\x00\x00\xc5\x00\x3a\x00\x3a\x00\x26\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x34\x00\xd7\x00\x34\x00\x3a\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x69\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x3a\x00\x83\x00\x3a\x00\x3a\x00\x79\x00\x3a\x00\x64\x01\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x3a\x00\x78\x00\x3a\x00\x67\x00\x67\x00\x67\x00\x3a\x00\x00\x00\x00\x00\x67\x00\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x00\x00\x00\x00\x00\x00\x70\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x66\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x67\x00\x00\x00\x64\x00\x3a\x00\x3a\x00\x00\x00\x36\x00\x3a\x00\x3a\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x67\x00\x3a\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x68\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x68\x00\x3c\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x74\x01\x3a\x00\x3c\x00\x3a\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3d\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3c\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3c\x00\x3d\x00\x00\x00\x3d\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x70\x01\x00\x00\x3d\x00\x00\x00\x3d\x00\x00\x00\x1d\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x71\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x75\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x4a\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x48\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x4b\x00\x4b\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4c\x00\x4c\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4b\x00\x49\x00\x00\x00\x3d\x00\x4c\x00\x00\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x4c\x00\x3d\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x00\x00\x3d\x00\x00\x00\x3d\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x4e\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x46\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x3d\x00\x00\x00\x3d\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x47\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x01\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x01\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x57\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x56\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x38\x01\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x71\x00\x76\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x73\x00\x6d\x00\x6d\x00\x6d\x00\x6f\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x7b\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x67\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x6b\x00\x6b\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x00\x00\x6c\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6e\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x70\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x72\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x74\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x77\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\xa0\x00\x00\x00\xa1\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x85\x00\x85\x00\x85\x00\x00\x00\x84\x00\x00\x00\x85\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x92\x00\x00\x00\x00\x00\x00\x00\x62\x01\x00\x00\x92\x00\x92\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x72\x01\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x93\x00\x93\x00\x93\x00\x75\x01\x93\x00\x93\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x93\x00\x93\x00\x94\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x00\x00\x93\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x93\x00\x94\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x9a\x00\x00\x00\xa4\x00\x00\x00\x00\x00\xa6\x00\x9a\x00\x9a\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x9d\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x00\x00\x9e\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x9e\x00\x9e\x00\x9f\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x00\x00\x9e\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9e\x00\x9f\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\x9e\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\xa0\x00\x00\x00\xa1\x00\x00\x00\x00\x00\xa0\x00\xa0\x00\xa0\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x84\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa1\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\xa2\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xa2\x00\xa2\x00\xa2\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x84\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa3\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa4\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\xa6\x00\x00\x00\xa7\x00\x00\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\xc6\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x00\x00\xc6\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\xc8\x00\x99\x00\x99\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x99\x00\x3a\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x00\x00\xc8\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x6b\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\xcb\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\xff\xff\x6b\x00\xff\xff\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x52\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x54\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x53\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x4b\x01\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x20\x00\x00\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x01\x00\x00\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x56\x01\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x56\x01\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x57\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x01\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x01\x00\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\x23\x00\x01\x00\x02\x00\x23\x00\x04\x00\x05\x00\x06\x00\x23\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2b\x00\x23\x00\x2d\x00\x23\x00\x7c\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2d\x00\x2d\x00\x7c\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x06\x00\x2d\x00\x7d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x23\x00\x2d\x00\x09\x00\x7d\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x2d\x00\x0a\x00\x30\x00\x31\x00\x2d\x00\x23\x00\x0a\x00\x2d\x00\x20\x00\x24\x00\x21\x00\x23\x00\x0a\x00\x0a\x00\x23\x00\x2a\x00\x72\x00\x20\x00\x05\x00\x06\x00\x61\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x67\x00\x2d\x00\x30\x00\x31\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x49\x00\x0a\x00\x20\x00\x05\x00\x06\x00\x23\x00\x5f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x57\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x0a\x00\x5e\x00\x09\x00\x6d\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x5f\x00\x23\x00\x23\x00\x61\x00\x5f\x00\x2d\x00\x0a\x00\x7c\x00\x20\x00\x69\x00\x7d\x00\x23\x00\x2d\x00\x65\x00\x30\x00\x31\x00\x0a\x00\x20\x00\x6e\x00\x2d\x00\x0a\x00\x2d\x00\x21\x00\x7c\x00\x0a\x00\x7b\x00\x0a\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x05\x00\x06\x00\x0a\x00\x7b\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x64\x00\x72\x00\x6f\x00\x64\x00\x72\x00\x05\x00\x06\x00\x6f\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x64\x00\x72\x00\x6f\x00\x64\x00\x20\x00\x6f\x00\x72\x00\x5f\x00\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x2d\x00\x20\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x34\x00\x2d\x00\x34\x00\x05\x00\x06\x00\x34\x00\x7b\x00\x09\x00\x32\x00\x0b\x00\x0c\x00\x0d\x00\x34\x00\x6c\x00\x32\x00\x7b\x00\x7c\x00\x70\x00\x20\x00\x32\x00\x32\x00\x23\x00\x24\x00\x6e\x00\x7b\x00\x36\x00\x5f\x00\x36\x00\x2a\x00\x36\x00\x20\x00\x05\x00\x06\x00\x36\x00\x65\x00\x09\x00\x6c\x00\x0b\x00\x0c\x00\x0d\x00\x74\x00\x69\x00\x34\x00\x2d\x00\x34\x00\x74\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x6e\x00\x20\x00\x23\x00\x24\x00\x23\x00\x05\x00\x34\x00\x34\x00\x7b\x00\x2a\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x6e\x00\x74\x00\x34\x00\x6e\x00\x31\x00\x74\x00\x33\x00\x7b\x00\x5e\x00\x36\x00\x6e\x00\x38\x00\x74\x00\x34\x00\x01\x00\x02\x00\x6e\x00\x20\x00\x05\x00\x06\x00\x23\x00\x74\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x6e\x00\x7c\x00\x74\x00\x6e\x00\x74\x00\x6e\x00\x34\x00\x05\x00\x20\x00\x5e\x00\x34\x00\x23\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x28\x00\x29\x00\x32\x00\x32\x00\x2c\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x32\x00\x32\x00\x20\x00\x3b\x00\x22\x00\x5f\x00\x32\x00\x7c\x00\x7b\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x32\x00\x5d\x00\x32\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x32\x00\x7d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x36\x00\x23\x00\x23\x00\x49\x00\x49\x00\x49\x00\x49\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x31\x00\xff\xff\x33\x00\xff\xff\xff\xff\x36\x00\x0a\x00\x38\x00\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x2a\x00\x2d\x00\xff\xff\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x7c\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x31\x00\x31\x00\x33\x00\x33\x00\xff\xff\x36\x00\x36\x00\x38\x00\x38\x00\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x31\x00\x31\x00\x33\x00\x33\x00\xff\xff\x36\x00\x36\x00\x38\x00\x38\x00\x50\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x31\x00\x45\x00\x33\x00\xff\xff\xff\xff\x36\x00\xff\xff\x38\x00\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\x31\x00\xff\xff\x33\x00\xff\xff\xff\xff\x36\x00\x5f\x00\x38\x00\xff\xff\xff\xff\x23\x00\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2b\x00\xff\xff\x2d\x00\x5f\x00\x49\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\x03\x00\x57\x00\xff\xff\xff\xff\x07\x00\x23\x00\x23\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\x05\x00\xff\xff\xff\xff\x27\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x49\x00\x49\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x57\x00\x57\x00\xff\xff\x20\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x31\x00\x5f\x00\x33\x00\xff\xff\xff\xff\x36\x00\xff\xff\x38\x00\x50\x00\x05\x00\xff\xff\xff\xff\x24\x00\x5f\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\x31\x00\xff\xff\x33\x00\xff\xff\x20\x00\x36\x00\x22\x00\x38\x00\x70\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x31\x00\x23\x00\x33\x00\x5e\x00\xff\xff\x36\x00\x31\x00\x38\x00\x33\x00\x50\x00\xff\xff\x36\x00\x2e\x00\x38\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x42\x00\x7c\x00\xff\xff\x45\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x0b\x00\x0c\x00\x0d\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x20\x00\x62\x00\x23\x00\x23\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x5f\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x70\x00\x23\x00\x24\x00\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\x05\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x45\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x04\x00\x23\x00\xff\xff\x7c\x00\x45\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\x5f\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x65\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\xff\xff\x5e\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x7c\x00\x2d\x00\x7e\x00\x04\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5c\x00\x5d\x00\x5e\x00\x23\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\xff\xff\x07\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x02\x00\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x5f\x00\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\x45\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x5f\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x5f\x00\x7e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xaf\x00\xff\xff\xb1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xd1\x00\xd1\x00\xd0\x00\xcc\x00\xd0\x00\xcc\x00\xff\xff\xd0\x00\xcc\x00\xcc\x00\xcf\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 376) - [ AlexAccNone - , AlexAcc 249 - , AlexAccNone - , AlexAcc 248 - , AlexAcc 247 - , AlexAcc 246 - , AlexAcc 245 - , AlexAcc 244 - , AlexAcc 243 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 242 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 241 (ifExtension HexFloatLiteralsBit `alexAndPred` - negLitPred)(AlexAccNone) - , AlexAccPred 240 (ifExtension HexFloatLiteralsBit `alexAndPred` - negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 239 (ifExtension HexFloatLiteralsBit)(AlexAccNone) - , AlexAccPred 238 (ifExtension HexFloatLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 237 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAcc 236 - , AlexAccNone - , AlexAccNone - , AlexAcc 235 - , AlexAccNone - , AlexAccPred 234 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccPred 233 (negLitPred)(AlexAccNone) - , AlexAccPred 232 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccPred 231 (negLitPred `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 230 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAcc 229 - , AlexAccNone - , AlexAcc 228 - , AlexAcc 227 - , AlexAccNone - , AlexAccPred 226 (ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAcc 225 - , AlexAcc 224 - , AlexAcc 223 - , AlexAcc 222 - , AlexAcc 221 - , AlexAcc 220 - , AlexAcc 219 - , AlexAcc 218 - , AlexAcc 217 - , AlexAcc 216 - , AlexAcc 215 - , AlexAccPred 214 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 213 (ifExtension MagicHashBit)(AlexAccPred 212 (ifExtension MagicHashBit)(AlexAccNone)) - , AlexAcc 211 - , AlexAccPred 210 (ifExtension MagicHashBit)(AlexAccPred 209 (ifExtension MagicHashBit)(AlexAccNone)) - , AlexAcc 208 - , AlexAcc 207 - , AlexAccPred 206 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 205 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAcc 204 - , AlexAcc 203 - , AlexAccPred 202 (ifExtension RecursiveDoBit)(AlexAcc 201) - , AlexAcc 200 - , AlexAcc 199 - , AlexAcc 198 - , AlexAcc 197 - , AlexAccNone - , AlexAcc 196 - , AlexAccPred 195 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAcc 194 - , AlexAcc 193 - , AlexAcc 192 - , AlexAcc 191 - , AlexAcc 190 - , AlexAcc 189 - , AlexAccPred 188 (ifExtension RecursiveDoBit)(AlexAcc 187) - , AlexAcc 186 - , AlexAcc 185 - , AlexAcc 184 - , AlexAcc 183 - , AlexAcc 182 - , AlexAcc 181 - , AlexAcc 180 - , AlexAcc 179 - , AlexAcc 178 - , AlexAcc 177 - , AlexAcc 176 - , AlexAcc 175 - , AlexAcc 174 - , AlexAccPred 173 (ifExtension UnboxedParensBit)(AlexAccNone) - , AlexAccPred 172 (ifExtension UnboxedParensBit)(AlexAccNone) - , AlexAccPred 171 (ifExtension OverloadedLabelsBit)(AlexAccNone) - , AlexAccPred 170 (ifExtension OverloadedLabelsBit)(AlexAccNone) - , AlexAccPred 169 (ifExtension IpBit)(AlexAccNone) - , AlexAccPred 168 (ifExtension ArrowsBit)(AlexAccNone) - , AlexAccPred 167 (ifExtension ArrowsBit `alexAndPred` - notFollowedBySymbol)(AlexAccNone) - , AlexAccNone - , AlexAccPred 166 (ifExtension QqBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 165 (ifExtension QqBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 164 (ifExtension ThQuotesBit)(AlexAccPred 163 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 162 (ifExtension ThQuotesBit)(AlexAccPred 161 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 160 (ifExtension ThQuotesBit)(AlexAccPred 159 (ifExtension QqBit)(AlexAccNone)) - , AlexAccPred 158 (ifExtension ThQuotesBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 157 (ifExtension ThQuotesBit)(AlexAccPred 156 (ifExtension QqBit)(AlexAccNone)) - , AlexAcc 155 - , AlexAcc 154 - , AlexAcc 153 - , AlexAcc 152 - , AlexAccNone - , AlexAccPred 151 (ifExtension HaddockBit)(AlexAccNone) - , AlexAcc 150 - , AlexAccPred 149 (isNormalComment)(AlexAccNone) - , AlexAcc 148 - , AlexAccNone - , AlexAccNone - , AlexAcc 147 - , AlexAccNone - , AlexAccPred 146 (known_pragma twoWordPrags)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 145 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 144 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 143 - , AlexAcc 142 - , AlexAcc 141 - , AlexAccSkip - , AlexAcc 140 - , AlexAcc 139 - , AlexAcc 138 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 137 - , AlexAccNone - , AlexAccPred 136 (known_pragma linePrags)(AlexAccPred 135 (known_pragma oneWordPrags)(AlexAccPred 134 (known_pragma ignoredPrags)(AlexAccPred 133 (known_pragma fileHeaderPrags)(AlexAcc 132)))) - , AlexAccNone - , AlexAccPred 131 (known_pragma linePrags)(AlexAccPred 130 (known_pragma oneWordPrags)(AlexAccPred 129 (known_pragma ignoredPrags)(AlexAccPred 128 (known_pragma fileHeaderPrags)(AlexAcc 127)))) - , AlexAccPred 126 (known_pragma linePrags)(AlexAcc 125) - , AlexAccPred 124 (isNormalComment)(AlexAccNone) - , AlexAccNone - , AlexAccPred 123 (known_pragma linePrags)(AlexAccNone) - , AlexAcc 122 - , AlexAccPred 121 (notFollowedBySymbol)(AlexAccNone) - , AlexAccPred 120 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccSkip - , AlexAccPred 119 (notFollowedBy '-')(AlexAccNone) - , AlexAccSkip - , AlexAccNone - , AlexAccNone - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccNone - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 118 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 117 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccSkip - , AlexAccPred 116 (isSmartQuote)(AlexAccPred 115 (ifCurrentChar '⟦' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit)(AlexAccPred 114 (ifCurrentChar '⟧' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit)(AlexAccPred 113 (ifCurrentChar '⦇' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit)(AlexAccPred 112 (ifCurrentChar '⦈' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit)(AlexAccNone))))) - , AlexAccPred 111 (isSmartQuote)(AlexAcc 110) - , AlexAccPred 109 (isSmartQuote)(AlexAccNone) - , AlexAccPred 108 (atEOL)(AlexAcc 107) - , AlexAccPred 106 (atEOL)(AlexAccNone) - , AlexAccPred 105 (atEOL)(AlexAcc 104) - , AlexAccPred 103 (atEOL)(AlexAcc 102) - , AlexAccPred 101 (atEOL)(AlexAcc 100) - , AlexAccPred 99 (atEOL)(AlexAcc 98) - , AlexAccNone - , AlexAccPred 97 (atEOL)(AlexAccNone) - , AlexAccPred 96 (atEOL)(AlexAccNone) - , AlexAcc 95 - , AlexAccPred 94 (alexNotPred (ifExtension HaddockBit))(AlexAccPred 93 (ifExtension HaddockBit)(AlexAccNone)) - , AlexAccPred 92 (alexNotPred (ifExtension HaddockBit))(AlexAcc 91) - , AlexAccPred 90 (alexNotPred (ifExtension HaddockBit))(AlexAccNone) - , AlexAcc 89 - , AlexAcc 88 - , AlexAccPred 87 (isNormalComment)(AlexAcc 86) - , AlexAccNone - , AlexAccPred 85 (isNormalComment)(AlexAccNone) - , AlexAcc 84 - , AlexAccSkip - , AlexAccNone - , AlexAcc 83 - , AlexAcc 82 - , AlexAccPred 81 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 80 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 79 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 78 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 77 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 76 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 75 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 74 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 73 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 72 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 71 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 70 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 69 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 68 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 67 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 66 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 65 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 64 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 63 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 62 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 61 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 60 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 59 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 58 (negHashLitPred ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 57 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 56 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 55 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 54 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 53 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 52 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 51 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 50 (negHashLitPred ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 49 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 48 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 47 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 46 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 45 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 44 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 43 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 42 (negHashLitPred ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 41 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 40 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 39 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 38 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 37 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 36 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 35 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 34 (negHashLitPred ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 33 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAcc 32 - , AlexAccNone - , AlexAccNone - , AlexAccPred 31 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 30 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 29 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 28 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAcc 27 - , AlexAcc 26 - , AlexAcc 25 - , AlexAccPred 24 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 23 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 22 (negHashLitPred ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 21 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 20 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 19 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 18 (ifExtension ExtendedLiteralsBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 17 (ifExtension ExtendedLiteralsBit)(AlexAccNone) - , AlexAccPred 16 (negHashLitPred MagicHashBit)(AlexAccNone) - , AlexAccPred 15 (negHashLitPred MagicHashBit)(AlexAccNone) - , AlexAccPred 14 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 13 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 12 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 11 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 10 (ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 9 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 8 (negHashLitPred MagicHashBit)(AlexAccNone) - , AlexAccPred 7 (negHashLitPred MagicHashBit)(AlexAccNone) - , AlexAccPred 6 (negHashLitPred MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 5 (negHashLitPred MagicHashBit)(AlexAccNone) - , AlexAccPred 4 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAcc 3 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 2 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 1 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 0 (ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - ] - -alex_actions = array (0 :: Int, 250) - [ (249,alex_action_16) - , (248,alex_action_22) - , (247,alex_action_23) - , (246,alex_action_21) - , (245,alex_action_24) - , (244,alex_action_28) - , (243,alex_action_29) - , (242,alex_action_100) - , (241,alex_action_99) - , (240,alex_action_99) - , (239,alex_action_98) - , (238,alex_action_98) - , (237,alex_action_97) - , (236,alex_action_78) - , (235,alex_action_96) - , (234,alex_action_95) - , (233,alex_action_94) - , (232,alex_action_92) - , (231,alex_action_93) - , (230,alex_action_92) - , (229,alex_action_91) - , (228,alex_action_90) - , (227,alex_action_88) - , (226,alex_action_89) - , (225,alex_action_88) - , (224,alex_action_87) - , (223,alex_action_86) - , (222,alex_action_86) - , (221,alex_action_86) - , (220,alex_action_86) - , (219,alex_action_86) - , (218,alex_action_86) - , (217,alex_action_86) - , (216,alex_action_85) - , (215,alex_action_84) - , (214,alex_action_83) - , (213,alex_action_82) - , (212,alex_action_113) - , (211,alex_action_78) - , (210,alex_action_82) - , (209,alex_action_112) - , (208,alex_action_78) - , (207,alex_action_78) - , (206,alex_action_82) - , (205,alex_action_81) - , (204,alex_action_76) - , (203,alex_action_74) - , (202,alex_action_75) - , (201,alex_action_76) - , (200,alex_action_76) - , (199,alex_action_76) - , (198,alex_action_77) - , (197,alex_action_79) - , (196,alex_action_76) - , (195,alex_action_80) - , (194,alex_action_79) - , (193,alex_action_78) - , (192,alex_action_77) - , (191,alex_action_76) - , (190,alex_action_76) - , (189,alex_action_76) - , (188,alex_action_75) - , (187,alex_action_76) - , (186,alex_action_74) - , (185,alex_action_73) - , (184,alex_action_72) - , (183,alex_action_72) - , (182,alex_action_71) - , (181,alex_action_70) - , (180,alex_action_69) - , (179,alex_action_68) - , (178,alex_action_67) - , (177,alex_action_67) - , (176,alex_action_66) - , (175,alex_action_65) - , (174,alex_action_65) - , (173,alex_action_64) - , (172,alex_action_63) - , (171,alex_action_62) - , (170,alex_action_61) - , (169,alex_action_60) - , (168,alex_action_57) - , (167,alex_action_56) - , (166,alex_action_53) - , (165,alex_action_52) - , (164,alex_action_51) - , (163,alex_action_52) - , (162,alex_action_50) - , (161,alex_action_52) - , (160,alex_action_49) - , (159,alex_action_52) - , (158,alex_action_48) - , (157,alex_action_47) - , (156,alex_action_52) - , (155,alex_action_46) - , (154,alex_action_45) - , (153,alex_action_44) - , (152,alex_action_43) - , (151,alex_action_42) - , (150,alex_action_40) - , (149,alex_action_2) - , (148,alex_action_40) - , (147,alex_action_36) - , (146,alex_action_33) - , (145,alex_action_32) - , (144,alex_action_31) - , (143,alex_action_30) - , (142,alex_action_29) - , (141,alex_action_29) - , (140,alex_action_1) - , (139,alex_action_29) - , (138,alex_action_29) - , (137,alex_action_27) - , (136,alex_action_26) - , (135,alex_action_34) - , (134,alex_action_35) - , (133,alex_action_38) - , (132,alex_action_39) - , (131,alex_action_26) - , (130,alex_action_34) - , (129,alex_action_35) - , (128,alex_action_37) - , (127,alex_action_39) - , (126,alex_action_26) - , (125,alex_action_29) - , (124,alex_action_2) - , (123,alex_action_26) - , (122,alex_action_25) - , (121,alex_action_20) - , (120,alex_action_19) - , (119,alex_action_17) - , (118,alex_action_12) - , (117,alex_action_11) - , (116,alex_action_9) - , (115,alex_action_54) - , (114,alex_action_55) - , (113,alex_action_58) - , (112,alex_action_59) - , (111,alex_action_9) - , (110,alex_action_29) - , (109,alex_action_9) - , (108,alex_action_8) - , (107,alex_action_29) - , (106,alex_action_8) - , (105,alex_action_7) - , (104,alex_action_86) - , (103,alex_action_7) - , (102,alex_action_86) - , (101,alex_action_7) - , (100,alex_action_29) - , (99,alex_action_7) - , (98,alex_action_29) - , (97,alex_action_7) - , (96,alex_action_7) - , (95,alex_action_6) - , (94,alex_action_5) - , (93,alex_action_41) - , (92,alex_action_5) - , (91,alex_action_29) - , (90,alex_action_5) - , (89,alex_action_4) - , (88,alex_action_3) - , (87,alex_action_2) - , (86,alex_action_29) - , (85,alex_action_2) - , (84,alex_action_1) - , (83,alex_action_177) - , (82,alex_action_176) - , (81,alex_action_175) - , (80,alex_action_174) - , (79,alex_action_173) - , (78,alex_action_172) - , (77,alex_action_171) - , (76,alex_action_170) - , (75,alex_action_169) - , (74,alex_action_168) - , (73,alex_action_167) - , (72,alex_action_166) - , (71,alex_action_165) - , (70,alex_action_164) - , (69,alex_action_163) - , (68,alex_action_162) - , (67,alex_action_161) - , (66,alex_action_160) - , (65,alex_action_159) - , (64,alex_action_19) - , (63,alex_action_158) - , (62,alex_action_157) - , (61,alex_action_156) - , (60,alex_action_155) - , (59,alex_action_154) - , (58,alex_action_153) - , (57,alex_action_152) - , (56,alex_action_151) - , (55,alex_action_150) - , (54,alex_action_149) - , (53,alex_action_148) - , (52,alex_action_147) - , (51,alex_action_146) - , (50,alex_action_145) - , (49,alex_action_144) - , (48,alex_action_143) - , (47,alex_action_142) - , (46,alex_action_141) - , (45,alex_action_140) - , (44,alex_action_139) - , (43,alex_action_138) - , (42,alex_action_137) - , (41,alex_action_136) - , (40,alex_action_135) - , (39,alex_action_134) - , (38,alex_action_133) - , (37,alex_action_132) - , (36,alex_action_131) - , (35,alex_action_130) - , (34,alex_action_129) - , (33,alex_action_128) - , (32,alex_action_76) - , (31,alex_action_127) - , (30,alex_action_126) - , (29,alex_action_125) - , (28,alex_action_124) - , (27,alex_action_78) - , (26,alex_action_78) - , (25,alex_action_78) - , (24,alex_action_123) - , (23,alex_action_122) - , (22,alex_action_121) - , (21,alex_action_120) - , (20,alex_action_119) - , (19,alex_action_118) - , (18,alex_action_117) - , (17,alex_action_116) - , (16,alex_action_115) - , (15,alex_action_114) - , (14,alex_action_113) - , (13,alex_action_112) - , (12,alex_action_111) - , (11,alex_action_110) - , (10,alex_action_109) - , (9,alex_action_108) - , (8,alex_action_107) - , (7,alex_action_106) - , (6,alex_action_105) - , (5,alex_action_104) - , (4,alex_action_103) - , (3,alex_action_96) - , (2,alex_action_97) - , (1,alex_action_102) - , (0,alex_action_101) - ] - -{-# LINE 794 "_build/source-dist/ghc-9.8.4-src/ghc-9.8.4/compiler/GHC/Parser/Lexer.x" #-} --- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. -data OpWs - = OpWsPrefix -- a !b - | OpWsSuffix -- a! b - | OpWsTightInfix -- a!b - | OpWsLooseInfix -- a ! b - deriving Show - --- ----------------------------------------------------------------------------- --- The token type - -data Token - = ITas -- Haskell keywords - | ITcase - | ITclass - | ITdata - | ITdefault - | ITderiving - | ITdo (Maybe FastString) - | ITelse - | IThiding - | ITforeign - | ITif - | ITimport - | ITin - | ITinfix - | ITinfixl - | ITinfixr - | ITinstance - | ITlet - | ITmodule - | ITnewtype - | ITof - | ITqualified - | ITthen - | ITtype - | ITwhere - - | ITforall IsUnicodeSyntax -- GHC extension keywords - | ITexport - | ITlabel - | ITdynamic - | ITsafe - | ITinterruptible - | ITunsafe - | ITstdcallconv - | ITccallconv - | ITcapiconv - | ITprimcallconv - | ITjavascriptcallconv - | ITmdo (Maybe FastString) - | ITfamily - | ITrole - | ITgroup - | ITby - | ITusing - | ITpattern - | ITstatic - | ITstock - | ITanyclass - | ITvia - - -- Backpack tokens - | ITunit - | ITsignature - | ITdependency - | ITrequires - - -- Pragmas, see Note [Pragma source text] in "GHC.Types.SourceText" - | ITinline_prag SourceText InlineSpec RuleMatchInfo - | ITopaque_prag SourceText - | ITspec_prag SourceText -- SPECIALISE - | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) - | ITsource_prag SourceText - | ITrules_prag SourceText - | ITwarning_prag SourceText - | ITdeprecated_prag SourceText - | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' - | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' - | ITscc_prag SourceText - | ITunpack_prag SourceText - | ITnounpack_prag SourceText - | ITann_prag SourceText - | ITcomplete_prag SourceText - | ITclose_prag - | IToptions_prag String - | ITinclude_prag String - | ITlanguage_prag - | ITminimal_prag SourceText - | IToverlappable_prag SourceText -- instance overlap mode - | IToverlapping_prag SourceText -- instance overlap mode - | IToverlaps_prag SourceText -- instance overlap mode - | ITincoherent_prag SourceText -- instance overlap mode - | ITctype SourceText - | ITcomment_line_prag -- See Note [Nested comment line pragmas] - - | ITdotdot -- reserved symbols - | ITcolon - | ITdcolon IsUnicodeSyntax - | ITequal - | ITlam - | ITlcase - | ITlcases - | ITvbar - | ITlarrow IsUnicodeSyntax - | ITrarrow IsUnicodeSyntax - | ITdarrow IsUnicodeSyntax - | ITlolly -- The (⊸) arrow (for LinearTypes) - | ITminus -- See Note [Minus tokens] - | ITprefixminus -- See Note [Minus tokens] - | ITbang -- Prefix (!) only, e.g. f !x = rhs - | ITtilde -- Prefix (~) only, e.g. f ~x = rhs - | ITat -- Tight infix (@) only, e.g. f x@pat = rhs - | ITtypeApp -- Prefix (@) only, e.g. f @t - | ITpercent -- Prefix (%) only, e.g. a %1 -> b - | ITstar IsUnicodeSyntax - | ITdot - | ITproj Bool -- Extension: OverloadedRecordDotBit - - | ITbiglam -- GHC-extension symbols - - | ITocurly -- special symbols - | ITccurly - | ITvocurly - | ITvccurly - | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParallelArrays - | ITcpabrack -- :], for parallel arrays with -XParallelArrays - | ITcbrack - | IToparen - | ITcparen - | IToubxparen - | ITcubxparen - | ITsemi - | ITcomma - | ITunderscore - | ITbackquote - | ITsimpleQuote -- ' - - | ITvarid FastString -- identifiers - | ITconid FastString - | ITvarsym FastString - | ITconsym FastString - | ITqvarid (FastString,FastString) - | ITqconid (FastString,FastString) - | ITqvarsym (FastString,FastString) - | ITqconsym (FastString,FastString) - - | ITdupipvarid FastString -- GHC extension: implicit param: ?x - | ITlabelvarid SourceText FastString -- Overloaded label: #x - -- The SourceText is required because we can - -- have a string literal as a label - -- Note [Literal source text] in "GHC.Types.SourceText" - - | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText" - | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText" - | ITinteger IntegralLit -- Note [Literal source text] in "GHC.Types.SourceText" - | ITrational FractionalLit - - | ITprimchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimint SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimword SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimint8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimint16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimint32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimint64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimword8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimword16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimword32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimword64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" - | ITprimfloat FractionalLit - | ITprimdouble FractionalLit - - -- Template Haskell extension tokens - | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote IsUnicodeSyntax -- |] - | ITopenTExpQuote HasE -- [|| or [e|| - | ITcloseTExpQuote -- ||] - | ITdollar -- prefix $ - | ITdollardollar -- prefix $$ - | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,PsSpan) - -- ITquasiQuote(quoter, quote, loc) - -- represents a quasi-quote of the form - -- [quoter| quote |] - | ITqQuasiQuote (FastString,FastString,FastString,PsSpan) - -- ITqQuasiQuote(Qual, quoter, quote, loc) - -- represents a qualified quasi-quote of the form - -- [Qual.quoter| quote |] - - -- Arrow notation extension - | ITproc - | ITrec - | IToparenbar IsUnicodeSyntax -- ^ @(|@ - | ITcparenbar IsUnicodeSyntax -- ^ @|)@ - | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ - | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ - | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ - | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ - - | ITunknown String -- ^ Used when the lexer can't make sense of it - | ITeof -- ^ end of file token - - -- Documentation annotations. See Note [PsSpan in Comments] - | ITdocComment HsDocString PsSpan -- ^ The HsDocString contains more details about what - -- this is and how to pretty print it - | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) - | ITlineComment String PsSpan -- ^ comment starting by "--" - | ITblockComment String PsSpan -- ^ comment in {- -} - - deriving Show - -instance Outputable Token where - ppr x = text (show x) - -{- Note [PsSpan in Comments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When using the Api Annotations to exact print a modified AST, managing -the space before a comment is important. The PsSpan in the comment -token allows this to happen, and this location is tracked in prev_loc -in PState. This only tracks physical tokens, so is not updated for -zero-width ones. - -We also use this to track the space before the end-of-file marker. --} - -{- Note [Minus tokens] -~~~~~~~~~~~~~~~~~~~~~~ -A minus sign can be used in prefix form (-x) and infix form (a - b). - -When LexicalNegation is on: - * ITprefixminus represents the prefix form - * ITvarsym "-" represents the infix form - * ITminus is not used - -When LexicalNegation is off: - * ITminus represents all forms - * ITprefixminus is not used - * ITvarsym "-" is not used --} - -{- Note [Why not LexicalNegationBit] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -One might wonder why we define NoLexicalNegationBit instead of -LexicalNegationBit. The problem lies in the following line in reservedSymsFM: - - ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) - -We want to generate ITminus only when LexicalNegation is off. How would one -do it if we had LexicalNegationBit? I (int-index) tried to use bitwise -complement: - - ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit)) - -This did not work, so I opted for NoLexicalNegationBit instead. --} - - --- the bitmap provided as the third component indicates whether the --- corresponding extension keyword is valid under the extension options --- provided to the compiler; if the extension corresponding to *any* of the --- bits set in the bitmap is enabled, the keyword is valid (this setup --- facilitates using a keyword in two different extensions that can be --- activated independently) --- -reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap) -reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "cases", ITlcases, xbit LambdaCaseBit ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo Nothing, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - - ( "forall", ITforall NormalSyntax, 0), - ( "mdo", ITmdo Nothing, xbit RecursiveDoBit), - -- See Note [Lexing type pseudo-keywords] - ( "family", ITfamily, 0 ), - ( "role", ITrole, 0 ), - ( "pattern", ITpattern, xbit PatternSynonymsBit), - ( "static", ITstatic, xbit StaticPointersBit ), - ( "stock", ITstock, 0 ), - ( "anyclass", ITanyclass, 0 ), - ( "via", ITvia, 0 ), - ( "group", ITgroup, xbit TransformComprehensionsBit), - ( "by", ITby, xbit TransformComprehensionsBit), - ( "using", ITusing, xbit TransformComprehensionsBit), - - ( "foreign", ITforeign, xbit FfiBit), - ( "export", ITexport, xbit FfiBit), - ( "label", ITlabel, xbit FfiBit), - ( "dynamic", ITdynamic, xbit FfiBit), - ( "safe", ITsafe, xbit FfiBit .|. - xbit SafeHaskellBit), - ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), - ( "unsafe", ITunsafe, xbit FfiBit), - ( "stdcall", ITstdcallconv, xbit FfiBit), - ( "ccall", ITccallconv, xbit FfiBit), - ( "capi", ITcapiconv, xbit CApiFfiBit), - ( "prim", ITprimcallconv, xbit FfiBit), - ( "javascript", ITjavascriptcallconv, xbit FfiBit), - - ( "unit", ITunit, 0 ), - ( "dependency", ITdependency, 0 ), - ( "signature", ITsignature, 0 ), - - ( "rec", ITrec, xbit ArrowsBit .|. - xbit RecursiveDoBit), - ( "proc", ITproc, xbit ArrowsBit) - ] - -{----------------------------------- -Note [Lexing type pseudo-keywords] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -One might think that we wish to treat 'family' and 'role' as regular old -varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. -But, there is no need to do so. These pseudo-keywords are not stolen syntax: -they are only used after the keyword 'type' at the top-level, where varids are -not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that -type families and role annotations are never declared without their extensions -on. In fact, by unconditionally lexing these pseudo-keywords as special, we -can get better error messages. - -Also, note that these are included in the `varid` production in the parser -- -a key detail to make all this work. --------------------------------------} - -reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap) -reservedSymsFM = listToUFM $ - map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) - [ ("..", ITdotdot, NormalSyntax, 0 ) - -- (:) is a reserved op, meaning only list cons - ,(":", ITcolon, NormalSyntax, 0 ) - ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) - ,("=", ITequal, NormalSyntax, 0 ) - ,("\\", ITlam, NormalSyntax, 0 ) - ,("|", ITvbar, NormalSyntax, 0 ) - ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) - ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) - ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) - ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) - - ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) - - ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) - - ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) - ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) - ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) - ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) - ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) - - ,("⊸", ITlolly, UnicodeSyntax, 0) - - ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) - - ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) - - -- ToDo: ideally, → and ∷ should be "specials", so that they cannot - -- form part of a large operator. This would let us have a better - -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). - ] - --- ----------------------------------------------------------------------------- --- Lexer actions - -type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token) - -special :: Token -> Action -special tok span _buf _len _buf2 = return (L span tok) - -token, layout_token :: Token -> Action -token t span _buf _len _buf2 = return (L span t) -layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t) - -idtoken :: (StringBuffer -> Int -> Token) -> Action -idtoken f span buf len _buf2 = return (L span $! (f buf len)) - -qdo_token :: (Maybe FastString -> Token) -> Action -qdo_token con span buf len _buf2 = do - maybe_layout token - return (L span $! token) - where - !token = con $! Just $! fst $! splitQualName buf len False - -skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len _buf2 - = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) - -skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action -skip_one_varid_src f span buf len _buf2 - = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1)) - (lexemeToFastString (stepOn buf) (len-1))) - -skip_two_varid :: (FastString -> Token) -> Action -skip_two_varid f span buf len _buf2 - = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) - -strtoken :: (String -> Token) -> Action -strtoken f span buf len _buf2 = - return (L span $! (f $! lexemeToString buf len)) - -fstrtoken :: (FastString -> Token) -> Action -fstrtoken f span buf len _buf2 = - return (L span $! (f $! lexemeToFastString buf len)) - -begin :: Int -> Action -begin code _span _str _len _buf2 = do pushLexState code; lexToken - -pop :: Action -pop _span _buf _len _buf2 = - do _ <- popLexState - lexToken --- See Note [Nested comment line pragmas] -failLinePrag1 :: Action -failLinePrag1 span _buf _len _buf2 = do - b <- getBit InNestedCommentBit - if b then return (L span ITcomment_line_prag) - else lexError LexErrorInPragma - --- See Note [Nested comment line pragmas] -popLinePrag1 :: Action -popLinePrag1 span _buf _len _buf2 = do - b <- getBit InNestedCommentBit - if b then return (L span ITcomment_line_prag) else do - _ <- popLexState - lexToken - -hopefully_open_brace :: Action -hopefully_open_brace span buf len buf2 - = do relaxed <- getBit RelaxedLayoutBit - ctx <- getContext - (AI l _) <- getInput - let offset = srcLocCol (psRealLoc l) - isOK = relaxed || - case ctx of - Layout prev_off _ : _ -> prev_off < offset - _ -> True - if isOK then pop_and open_brace span buf len buf2 - else addFatalError $ - mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock - -pop_and :: Action -> Action -pop_and act span buf len buf2 = - do _ <- popLexState - act span buf len buf2 - --- See Note [Whitespace-sensitive operator parsing] -followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap -followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf -precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf - --- The input is the buffer *after* the token. -followedByOpeningToken' :: StringBuffer -> Bool -followedByOpeningToken' buf - | atEnd buf = False - | otherwise = - case nextChar buf of - ('{', buf') -> nextCharIsNot buf' (== '-') - ('(', _) -> True - ('[', _) -> True - ('\"', _) -> True - ('\'', _) -> True - ('_', _) -> True - ('⟦', _) -> True - ('⦇', _) -> True - (c, _) -> isAlphaNum c - --- The input is the buffer *before* the token. -precededByClosingToken' :: StringBuffer -> Bool -precededByClosingToken' buf = - case prevChar buf '\n' of - '}' -> decodePrevNChars 1 buf /= "-" - ')' -> True - ']' -> True - '\"' -> True - '\'' -> True - '_' -> True - '⟧' -> True - '⦈' -> True - c -> isAlphaNum c - -get_op_ws :: StringBuffer -> StringBuffer -> OpWs -get_op_ws buf1 buf2 = - mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2) - where - mk_op_ws False True = OpWsPrefix - mk_op_ws True False = OpWsSuffix - mk_op_ws True True = OpWsTightInfix - mk_op_ws False False = OpWsLooseInfix - -{-# INLINE with_op_ws #-} -with_op_ws :: (OpWs -> Action) -> Action -with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2 - -{-# INLINE nextCharIs #-} -nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIs buf p = not (atEnd buf) && p (currentChar buf) - -{-# INLINE nextCharIsNot #-} -nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool -nextCharIsNot buf p = not (nextCharIs buf p) - -notFollowedBy :: Char -> AlexAccPred ExtsBitmap -notFollowedBy char _ _ _ (AI _ buf) - = nextCharIsNot buf (== char) - -notFollowedBySymbol :: AlexAccPred ExtsBitmap -notFollowedBySymbol _ _ _ (AI _ buf) - = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") - -followedByDigit :: AlexAccPred ExtsBitmap -followedByDigit _ _ _ (AI _ buf) - = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) - -ifCurrentChar :: Char -> AlexAccPred ExtsBitmap -ifCurrentChar char _ (AI _ buf) _ _ - = nextCharIs buf (== char) - --- We must reject doc comments as being ordinary comments everywhere. --- In some cases the doc comment will be selected as the lexeme due to --- maximal munch, but not always, because the nested comment rule is --- valid in all states, but the doc-comment rules are only valid in --- the non-layout states. -isNormalComment :: AlexAccPred ExtsBitmap -isNormalComment bits _ _ (AI _ buf) - | HaddockBit `xtest` bits = notFollowedByDocOrPragma - | otherwise = nextCharIsNot buf (== '#') - where - notFollowedByDocOrPragma - = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) - -afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool -afterOptionalSpace buf p - = if nextCharIs buf (== ' ') - then p (snd (nextChar buf)) - else p buf - -atEOL :: AlexAccPred ExtsBitmap -atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' - --- Check if we should parse a negative literal (e.g. -123) as a single token. -negLitPred :: AlexAccPred ExtsBitmap -negLitPred = - prefix_minus `alexAndPred` - (negative_literals `alexOrPred` lexical_negation) - where - negative_literals = ifExtension NegativeLiteralsBit - - lexical_negation = - -- See Note [Why not LexicalNegationBit] - alexNotPred (ifExtension NoLexicalNegationBit) - - prefix_minus = - -- Note [prefix_minus in negLitPred and negHashLitPred] - alexNotPred precededByClosingToken - --- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token. -negHashLitPred :: ExtBits -> AlexAccPred ExtsBitmap -negHashLitPred ext = prefix_minus `alexAndPred` magic_hash - where - magic_hash = ifExtension ext -- Either MagicHashBit or ExtendedLiteralsBit - prefix_minus = - -- Note [prefix_minus in negLitPred and negHashLitPred] - alexNotPred precededByClosingToken - -{- Note [prefix_minus in negLitPred and negHashLitPred] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to parse -1 as a single token, but x-1 as three tokens. -So in negLitPred (and negHashLitPred) we require that we have a prefix -occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing] -for a detailed definition of a prefix occurrence. - -The condition for a prefix occurrence of an operator is: - - not precededByClosingToken && followedByOpeningToken - -but we don't check followedByOpeningToken when parsing a negative literal. -It holds simply because we immediately lex a literal after the minus. --} - -ifExtension :: ExtBits -> AlexAccPred ExtsBitmap -ifExtension extBits bits _ _ _ = extBits `xtest` bits - -alexNotPred p userState in1 len in2 - = not (p userState in1 len in2) - -alexOrPred p1 p2 userState in1 len in2 - = p1 userState in1 len in2 || p2 userState in1 len in2 - -multiline_doc_comment :: Action -multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker - where - worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input - where - go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of - Just ('\n', input') - | checkNextLine -> case checkIfCommentLine input' of - Just input@(AI next_start _) -> go next_start "" (locatedLine : prevLines) input -- Start a new line - Nothing -> endComment - | otherwise -> endComment - Just (c, input) -> go start_loc (c:curLine) prevLines input - Nothing -> endComment - where - lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc - locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine) - commentLines = NE.reverse $ locatedLine :| prevLines - endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span - - -- Check if the next line of input belongs to this doc comment as well. - -- A doc comment continues onto the next line when the following - -- conditions are met: - -- * The line starts with "--" - -- * The line doesn't start with "---". - -- * The line doesn't start with "-- $", because that would be the - -- start of a /new/ named haddock chunk (#10398). - checkIfCommentLine :: AlexInput -> Maybe AlexInput - checkIfCommentLine input = check (dropNonNewlineSpace input) - where - check input = do - ('-', input) <- alexGetChar' input - ('-', input) <- alexGetChar' input - (c, after_c) <- alexGetChar' input - case c of - '-' -> Nothing - ' ' -> case alexGetChar' after_c of - Just ('$', _) -> Nothing - _ -> Just input - _ -> Just input - - dropNonNewlineSpace input = case alexGetChar' input of - Just (c, input') - | isSpace c && c /= '\n' -> dropNonNewlineSpace input' - | otherwise -> input - Nothing -> input - -lineCommentToken :: Action -lineCommentToken span buf len buf2 = do - b <- getBit RawTokenStreamBit - if b then do - lt <- getLastLocIncludingComments - strtoken (\s -> ITlineComment s lt) span buf len buf2 - else lexToken - - -{- - nested comments require traversing by hand, they can't be parsed - using regular expressions. --} -nested_comment :: Action -nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do - l <- getLastLocIncludingComments - let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span - input <- getInput - -- Include decorator in comment - let start_decorator = reverse $ lexemeToString buf len - nested_comment_logic endComment start_decorator input span - -nested_doc_comment :: Action -nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker - where - worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span)) - where - endComment input lcomment - = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span - - dropTrailingDec [] = [] - dropTrailingDec "-}" = "" - dropTrailingDec (x:xs) = x:dropTrailingDec xs - -{-# INLINE nested_comment_logic #-} --- | Includes the trailing '-}' decorators --- drop the last two elements with the callback if you don't want them to be included -nested_comment_logic - :: (AlexInput -> Located String -> P (PsLocated Token)) -- ^ Continuation that gets the rest of the input and the lexed comment - -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment - -> AlexInput - -> PsSpan - -> P (PsLocated Token) -nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input - where - go commentAcc 0 input@(AI end_loc _) = do - let comment = reverse commentAcc - cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc - lcomment = L cspan comment - endComment input lcomment - go commentAcc n input = case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('-',input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' - Just (_,_) -> go ('-':commentAcc) n input - Just ('\123',input) -> case alexGetChar' input of -- '{' char - Nothing -> errBrace input (psRealSpan span) - Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input - Just (_,_) -> go ('\123':commentAcc) n input - -- See Note [Nested comment line pragmas] - Just ('\n',input) -> case alexGetChar' input of - Nothing -> errBrace input (psRealSpan span) - Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input - go (parsedAcc ++ '\n':commentAcc) n input - Just (_,_) -> go ('\n':commentAcc) n input - Just (c,input) -> go (c:commentAcc) n input - --- See Note [Nested comment line pragmas] -parseNestedPragma :: AlexInput -> P (String,AlexInput) -parseNestedPragma input@(AI _ buf) = do - origInput <- getInput - setInput input - setExts (.|. xbit InNestedCommentBit) - pushLexState bol - lt <- lexToken - _ <- popLexState - setExts (.&. complement (xbit InNestedCommentBit)) - postInput@(AI _ postBuf) <- getInput - setInput origInput - case unLoc lt of - ITcomment_line_prag -> do - let bytes = byteDiff buf postBuf - diff = lexemeToString buf bytes - return (reverse diff, postInput) - lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) - -{- -Note [Nested comment line pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to ignore cpp-preprocessor-generated #line pragmas if they were inside -nested comments. - -Now, when parsing a nested comment, if we encounter a line starting with '#' we -call parseNestedPragma, which executes the following: -1. Save the current lexer input (loc, buf) for later -2. Set the current lexer input to the beginning of the line starting with '#' -3. Turn the 'InNestedComment' extension on -4. Push the 'bol' lexer state -5. Lex a token. Due to (2), (3), and (4), this should always lex a single line - or less and return the ITcomment_line_prag token. This may set source line - and file location if a #line pragma is successfully parsed -6. Restore lexer input and state to what they were before we did all this -7. Return control to the function parsing a nested comment, informing it of - what the lexer parsed - -Regarding (5) above: -Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) -checks if the 'InNestedComment' extension is set. If it is, that function will -return control to parseNestedPragma by returning the ITcomment_line_prag token. - -See #314 for more background on the bug this fixes. --} - -{-# INLINE withLexedDocType #-} -withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) - -> P (PsLocated Token) -withLexedDocType lexDocComment = do - input@(AI _ buf) <- getInput - l <- getLastLocIncludingComments - case prevChar buf ' ' of - -- The `Bool` argument to lexDocComment signals whether or not the next - -- line of input might also belong to this doc comment. - '|' -> lexDocComment input (mkHdkCommentNext l) True - '^' -> lexDocComment input (mkHdkCommentPrev l) True - '$' -> case lexDocName input of - Nothing -> do setInput input; lexToken -- eof reached, lex it normally - Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True - '*' -> lexDocSection l 1 input - _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection l n input = case alexGetChar' input of - Just ('*', input) -> lexDocSection l (n+1) input - Just (_, _) -> lexDocComment input (mkHdkCommentSection l n) False - Nothing -> do setInput input; lexToken -- eof reached, lex it normally - - lexDocName :: AlexInput -> Maybe (String, AlexInput) - lexDocName = go "" - where - go acc input = case alexGetChar' input of - Just (c, input') - | isSpace c -> Just (reverse acc, input) - | otherwise -> go (c:acc) input' - Nothing -> Nothing - -mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) -mkHdkCommentNext loc mkDS = (HdkCommentNext ds,ITdocComment ds loc) - where ds = mkDS HsDocStringNext -mkHdkCommentPrev loc mkDS = (HdkCommentPrev ds,ITdocComment ds loc) - where ds = mkDS HsDocStringPrevious - -mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) -mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc) - where ds = mkDS (HsDocStringNamed name) - -mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) -mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc) - where ds = mkDS (HsDocStringGroup n) - --- RULES pragmas turn on the forall and '.' keywords, and we turn them --- off again at the end of the pragma. -rulePrag :: Action -rulePrag span buf len _buf2 = do - setExts (.|. xbit InRulePragBit) - let !src = lexemeToFastString buf len - return (L span (ITrules_prag (SourceText src))) - --- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead --- of updating the position in 'PState' -linePrag :: Action -linePrag span buf len buf2 = do - usePosPrags <- getBit UsePosPragsBit - if usePosPrags - then begin line_prag2 span buf len buf2 - else let !src = lexemeToFastString buf len - in return (L span (ITline_prag (SourceText src))) - --- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead --- of updating the position in 'PState' -columnPrag :: Action -columnPrag span buf len buf2 = do - usePosPrags <- getBit UsePosPragsBit - if usePosPrags - then begin column_prag span buf len buf2 - else let !src = lexemeToFastString buf len - in return (L span (ITcolumn_prag (SourceText src))) - -endPrag :: Action -endPrag span _buf _len _buf2 = do - setExts (.&. complement (xbit InRulePragBit)) - return (L span ITclose_prag) - --- docCommentEnd -------------------------------------------------------------------------------- --- This function is quite tricky. We can't just return a new token, we also --- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so --- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. - -{-# INLINE commentEnd #-} -commentEnd :: P (PsLocated Token) - -> AlexInput - -> (Maybe HdkComment, Token) - -> StringBuffer - -> PsSpan - -> P (PsLocated Token) -commentEnd cont input (m_hdk_comment, hdk_token) buf span = do - setInput input - let (AI loc nextBuf) = input - span' = mkPsSpan (psSpanStart span) loc - last_len = byteDiff buf nextBuf - span `seq` setLastToken span' last_len - whenIsJust m_hdk_comment $ \hdk_comment -> - P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) () - b <- getBit RawTokenStreamBit - if b then return (L span' hdk_token) - else cont - -{-# INLINE docCommentEnd #-} -docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer -> - PsSpan -> P (PsLocated Token) -docCommentEnd input (hdk_comment, tok) buf span - = commentEnd lexToken input (Just hdk_comment, tok) buf span - -errBrace :: AlexInput -> RealSrcSpan -> P a -errBrace (AI end _) span = - failLocMsgP (realSrcSpanStart span) - (psRealLoc end) - (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) - -open_brace, close_brace :: Action -open_brace span _str _len _buf2 = do - ctx <- getContext - setContext (NoLayout:ctx) - return (L span ITocurly) -close_brace span _str _len _buf2 = do - popContext - return (L span ITccurly) - -qvarid, qconid :: StringBuffer -> Int -> Token -qvarid buf len = ITqvarid $! splitQualName buf len False -qconid buf len = ITqconid $! splitQualName buf len False - -splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) --- takes a StringBuffer and a length, and returns the module name --- and identifier parts of a qualified name. Splits at the *last* dot, --- because of hierarchical module names. --- --- Throws an error if the name is not qualified. -splitQualName orig_buf len parens = split orig_buf orig_buf - where - split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf - where - (c,buf') = nextChar buf - - -- careful, we might get names like M.... - -- so, if the character after the dot is not upper-case, this is - -- the end of the qualifier part. - found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf - where - (c,buf') = nextChar buf - - done dot_buf - | qual_size < 1 = error "splitQualName got an unqualified named" - | otherwise = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) - then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) - else lexemeToFastString dot_buf (len - qual_size)) - where - qual_size = orig_buf `byteDiff` dot_buf - -varid :: Action -varid span buf len _buf2 = - case lookupUFM reservedWordsFM fs of - Just (ITcase, _) -> do - lastTk <- getLastTk - keyword <- case lastTk of - Strict.Just (L _ ITlam) -> do - lambdaCase <- getBit LambdaCaseBit - unless lambdaCase $ do - pState <- getPState - addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase - return ITlcase - _ -> return ITcase - maybe_layout keyword - return $ L span keyword - Just (ITlcases, _) -> do - lastTk <- getLastTk - lambdaCase <- getBit LambdaCaseBit - token <- case lastTk of - Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases - _ -> return $ ITvarid fs - maybe_layout token - return $ L span token - Just (keyword, 0) -> do - maybe_layout keyword - return $ L span keyword - Just (keyword, i) -> do - exts <- getExts - if exts .&. i /= 0 - then do - maybe_layout keyword - return $ L span keyword - else - return $ L span $ ITvarid fs - Nothing -> - return $ L span $ ITvarid fs - where - !fs = lexemeToFastString buf len - -conid :: StringBuffer -> Int -> Token -conid buf len = ITconid $! lexemeToFastString buf len - -qvarsym, qconsym :: StringBuffer -> Int -> Token -qvarsym buf len = ITqvarsym $! splitQualName buf len False -qconsym buf len = ITqconsym $! splitQualName buf len False - --- See Note [Whitespace-sensitive operator parsing] -varsym :: OpWs -> Action -varsym opws@OpWsPrefix = sym $ \span exts s -> - let warnExtConflict errtok = - do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) - ; return (ITvarsym s) } - in - if | s == fsLit "@" -> - return ITtypeApp -- regardless of TypeApplications for better error messages - | s == fsLit "%" -> - if xtest LinearTypesBit exts - then return ITpercent - else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent - | s == fsLit "$" -> - if xtest ThQuotesBit exts - then return ITdollar - else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar - | s == fsLit "$$" -> - if xtest ThQuotesBit exts - then return ITdollardollar - else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar - | s == fsLit "-" -> - return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus - -- and don't hit this code path. See Note [Minus tokens] - | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> - return (ITproj True) -- e.g. '(.x)' - | s == fsLit "." -> return ITdot - | s == fsLit "!" -> return ITbang - | s == fsLit "~" -> return ITtilde - | otherwise -> - do { warnOperatorWhitespace opws span s - ; return (ITvarsym s) } -varsym opws@OpWsSuffix = sym $ \span _ s -> - if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT) - | s == fsLit "." -> return ITdot - | otherwise -> - do { warnOperatorWhitespace opws span s - ; return (ITvarsym s) } -varsym opws@OpWsTightInfix = sym $ \span exts s -> - if | s == fsLit "@" -> return ITat - | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) - | s == fsLit "." -> return ITdot - | otherwise -> - do { warnOperatorWhitespace opws span s - ; return (ITvarsym s) } -varsym OpWsLooseInfix = sym $ \_ _ s -> - if | s == fsLit "." - -> return ITdot - | otherwise - -> return $ ITvarsym s - -consym :: OpWs -> Action -consym opws = sym $ \span _exts s -> - do { warnOperatorWhitespace opws span s - ; return (ITconsym s) } - -warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P () -warnOperatorWhitespace opws span s = - whenIsJust (check_unusual_opws opws) $ \opws' -> - addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s opws') - --- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix). --- This determines if -Woperator-whitespace is triggered. -check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence -check_unusual_opws opws = - case opws of - OpWsPrefix -> Just OperatorWhitespaceOccurrence_Prefix - OpWsSuffix -> Just OperatorWhitespaceOccurrence_Suffix - OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix - OpWsLooseInfix -> Nothing - -sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action -sym con span buf len _buf2 = - case lookupUFM reservedSymsFM fs of - Just (keyword, NormalSyntax, 0) -> - return $ L span keyword - Just (keyword, NormalSyntax, i) -> do - exts <- getExts - if exts .&. i /= 0 - then return $ L span keyword - else L span <$!> con span exts fs - Just (keyword, UnicodeSyntax, 0) -> do - exts <- getExts - if xtest UnicodeSyntaxBit exts - then return $ L span keyword - else L span <$!> con span exts fs - Just (keyword, UnicodeSyntax, i) -> do - exts <- getExts - if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts - then return $ L span keyword - else L span <$!> con span exts fs - Nothing -> do - exts <- getExts - L span <$!> con span exts fs - where - !fs = lexemeToFastString buf len - --- Variations on the integral numeric literal. -tok_integral :: (SourceText -> Integer -> Token) - -> (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char -> Int)) - -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len _buf2 = do - numericUnderscores <- getBit NumericUnderscoresBit -- #14473 - let src = lexemeToFastString buf len - when ((not numericUnderscores) && ('_' `elem` unpackFS src)) $ do - pState <- getPState - let msg = PsErrNumUnderscores NumUnderscore_Integral - addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg - return $ L span $ itint (SourceText src) - $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int - -tok_num :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_num = tok_integral $ \case - st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True) - st@(SourceText _) -> itint st (const False) - st@NoSourceText -> itint st (< 0) - where - itint :: SourceText -> (Integer -> Bool) -> Integer -> Token - itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) - -tok_primint :: (Integer -> Integer) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primint = tok_integral ITprimint - - -tok_primword :: Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_primword = tok_integral ITprimword positive -positive, negative :: (Integer -> Integer) -positive = id -negative = negate -decimal, octal, hexadecimal :: (Integer, Char -> Int) -decimal = (10,octDecDigit) -binary = (2,octDecDigit) -octal = (8,octDecDigit) -hexadecimal = (16,hexDigit) - --- | Helper for defining @IntX@ primitive literal parsers (specifically for --- the ExtendedLiterals extension, such as @123#Int8@). -tok_primintX :: (SourceText -> Integer -> Token) - -> Int - -> (Integer -> Integer) - -> Int - -> (Integer, (Char->Int)) -> Action -tok_primintX itint addlen transint transbuf = - tok_integral itint transint transbuf (transbuf+addlen) - -tok_primint8, tok_primint16, tok_primint32, tok_primint64 - :: (Integer -> Integer) - -> Int -> (Integer, (Char->Int)) -> Action -tok_primint8 = tok_primintX ITprimint8 5 -tok_primint16 = tok_primintX ITprimint16 6 -tok_primint32 = tok_primintX ITprimint32 6 -tok_primint64 = tok_primintX ITprimint64 6 - --- | Helper for defining @WordX@ primitive literal parsers (specifically for --- the ExtendedLiterals extension, such as @234#Word8@). -tok_primwordX :: (SourceText -> Integer -> Token) - -> Int - -> Int - -> (Integer, (Char->Int)) -> Action -tok_primwordX itint addlen transbuf = - tok_integral itint positive transbuf (transbuf+addlen) - -tok_primword8, tok_primword16, tok_primword32, tok_primword64 - :: Int -> (Integer, (Char->Int)) -> Action -tok_primword8 = tok_primwordX ITprimword8 6 -tok_primword16 = tok_primwordX ITprimword16 7 -tok_primword32 = tok_primwordX ITprimword32 7 -tok_primword64 = tok_primwordX ITprimword64 7 - --- readSignificandExponentPair can understand negative rationals, exponents, everything. -tok_frac :: Int -> (String -> Token) -> Action -tok_frac drop f span buf len _buf2 = do - numericUnderscores <- getBit NumericUnderscoresBit -- #14473 - let src = lexemeToString buf (len-drop) - when ((not numericUnderscores) && ('_' `elem` src)) $ do - pState <- getPState - let msg = PsErrNumUnderscores NumUnderscore_Float - addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg - return (L span $! (f $! src)) - -tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readFractionalLit str -tok_hex_float str = ITrational $! readHexFractionalLit str -tok_primfloat str = ITprimfloat $! readFractionalLit str -tok_primdouble str = ITprimdouble $! readFractionalLit str - -readFractionalLit, readHexFractionalLit :: String -> FractionalLit -readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2 -readFractionalLit = readFractionalLitX readSignificandExponentPair Base10 - -readFractionalLitX :: (String -> (Integer, Integer)) - -> FractionalExponentBase - -> String -> FractionalLit -readFractionalLitX readStr b str = - mkSourceFractionalLit str is_neg i e b - where - is_neg = case str of - '-' : _ -> True - _ -> False - (i, e) = readStr str - --- ----------------------------------------------------------------------------- --- Layout processing - --- we're at the first token on a line, insert layout tokens if necessary -do_bol :: Action -do_bol span _str _len _buf2 = do - -- See Note [Nested comment line pragmas] - b <- getBit InNestedCommentBit - if b then return (L span ITcomment_line_prag) else do - (pos, gen_semic) <- getOffside - case pos of - LT -> do - --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ | gen_semic -> do - --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - _ -> do - _ <- popLexState - lexToken - --- certain keywords put us in the "layout" state, where we might --- add an opening curly brace. -maybe_layout :: Token -> P () -maybe_layout t = do -- If the alternative layout rule is enabled then - -- we never create an implicit layout context here. - -- Layout is handled XXX instead. - -- The code for closing implicit contexts, or - -- inserting implicit semi-colons, is therefore - -- irrelevant as it only applies in an implicit - -- context. - alr <- getBit AlternativeLayoutRuleBit - unless alr $ f t - where f (ITdo _) = pushLexState layout_do - f (ITmdo _) = pushLexState layout_do - f ITof = pushLexState layout - f ITlcase = pushLexState layout - f ITlcases = pushLexState layout - f ITlet = pushLexState layout - f ITwhere = pushLexState layout - f ITrec = pushLexState layout - f ITif = pushLexState layout_if - f _ = return () - --- Pushing a new implicit layout context. If the indentation of the --- next token is not greater than the previous layout context, then --- Haskell 98 says that the new layout context should be empty; that is --- the lexer must generate {}. --- --- We are slightly more lenient than this: when the new context is started --- by a 'do', then we allow the new context to be at the same indentation as --- the previous context. This is what the 'strict' argument is for. -new_layout_context :: Bool -> Bool -> Token -> Action -new_layout_context strict gen_semic tok span _buf len _buf2 = do - _ <- popLexState - (AI l _) <- getInput - let offset = srcLocCol (psRealLoc l) - len - ctx <- getContext - nondecreasing <- getBit NondecreasingIndentationBit - let strict' = strict || not nondecreasing - case ctx of - Layout prev_off _ : _ | - (strict' && prev_off >= offset || - not strict' && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span tok) - _ -> do setContext (Layout offset gen_semic : ctx) - return (L span tok) - -do_layout_left :: Action -do_layout_left span _buf _len _buf2 = do - _ <- popLexState - pushLexState bol -- we must be at the start of a line - return (L span ITvccurly) - --- ----------------------------------------------------------------------------- --- LINE pragmas - -setLineAndFile :: Int -> Action -setLineAndFile code (PsSpan span _) buf len _buf2 = do - let src = lexemeToString buf (len - 1) -- drop trailing quotation mark - linenumLen = length $ head $ words src - linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit - file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src - -- skip everything through first quotation mark to get to the filename - where go ('\\':c:cs) = c : go cs - go (c:cs) = c : go cs - go [] = [] - -- decode escapes in the filename. e.g. on Windows - -- when our filenames have backslashes in, gcc seems to - -- escape the backslashes. One symptom of not doing this - -- is that filenames in error messages look a bit strange: - -- C:\\foo\bar.hs - -- only the first backslash is doubled, because we apply - -- System.FilePath.normalise before printing out - -- filenames and it does not remove duplicate - -- backslashes after the drive letter (should it?). - resetAlrLastLoc file - setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) - -- subtract one: the line number refers to the *following* line - addSrcFile file - _ <- popLexState - pushLexState code - lexToken - -setColumn :: Action -setColumn (PsSpan span _) buf len _buf2 = do - let column = - case reads (lexemeToString buf len) of - [(column, _)] -> column - _ -> error "setColumn: expected integer" -- shouldn't happen - setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) - (fromIntegral (column :: Integer))) - _ <- popLexState - lexToken - -alrInitialLoc :: FastString -> RealSrcSpan -alrInitialLoc file = mkRealSrcSpan loc loc - where -- This is a hack to ensure that the first line in a file - -- looks like it is after the initial location: - loc = mkRealSrcLoc file (-1) (-1) - --- ----------------------------------------------------------------------------- --- Options, includes and language pragmas. - - -lex_string_prag :: (String -> Token) -> Action -lex_string_prag mkTok = lex_string_prag_comment mkTok' - where - mkTok' s _ = mkTok s - -lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action -lex_string_prag_comment mkTok span _buf _len _buf2 - = do input <- getInput - start <- getParsedLoc - l <- getLastLocIncludingComments - tok <- go l [] input - end <- getParsedLoc - return (L (mkPsSpan start end) tok) - where go l acc input - = if isString input "#-}" - then do setInput input - return (mkTok (reverse acc) l) - else case alexGetChar input of - Just (c,i) -> go l (c:acc) i - Nothing -> err input - isString _ [] = True - isString i (x:xs) - = case alexGetChar i of - Just (c,i') | c == x -> isString i' xs - _other -> False - err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) - (psRealLoc end) - (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF) - --- ----------------------------------------------------------------------------- --- Strings & Chars - --- This stuff is horrible. I hates it. - -lex_string_tok :: Action -lex_string_tok span buf _len _buf2 = do - lexed <- lex_string - (AI end bufEnd) <- getInput - let - tok = case lexed of - LexedPrimString s -> ITprimstring (SourceText src) (unsafeMkByteString s) - LexedRegularString s -> ITstring (SourceText src) (mkFastString s) - src = lexemeToFastString buf (cur bufEnd - cur buf) - return $ L (mkPsSpan (psSpanStart span) end) tok - - -lex_quoted_label :: Action -lex_quoted_label span buf _len _buf2 = do - start <- getInput - s <- lex_string_helper "" start - (AI end bufEnd) <- getInput - let - token = ITlabelvarid (SourceText src) (mkFastString s) - src = lexemeToFastString (stepOn buf) (cur bufEnd - cur buf - 1) - start = psSpanStart span - - return $ L (mkPsSpan start end) token - - -data LexedString = LexedRegularString String | LexedPrimString String - -lex_string :: P LexedString -lex_string = do - start <- getInput - s <- lex_string_helper "" start - magicHash <- getBit MagicHashBit - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - when (any (> '\xFF') s) $ do - pState <- getPState - let msg = PsErrPrimStringInvalidChar - let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg - addError err - return $ LexedPrimString s - _other -> - return $ LexedRegularString s - else - return $ LexedRegularString s - - -lex_string_helper :: String -> AlexInput -> P String -lex_string_helper s start = do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i - - Just ('"',i) -> do - setInput i - return (reverse s) - - Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string_helper s start - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do - -- is_space only works for <= '\x7f' (#3751, #5425) - setInput i; lex_stringgap s start - where next = alexGetChar' i - - Just (c, i1) -> do - case c of - '\\' -> do setInput i1; c' <- lex_escape; lex_string_helper (c':s) start - c | isAny c -> do setInput i1; lex_string_helper (c:s) start - _other | any isDoubleSmartQuote s -> do - -- if the built-up string s contains a smart double quote character, it was - -- likely the reason why the string literal was not lexed correctly - setInput start -- rewind to the first character in the string literal - -- so we can find the smart quote character's location - advance_to_smart_quote_character - i2@(AI loc _) <- getInput - case alexGetChar' i2 of - Just (c, _) -> do add_nonfatal_smart_quote_error c loc; lit_error i - Nothing -> lit_error i -- should never get here - _other -> lit_error i - - -lex_stringgap :: String -> AlexInput -> P String -lex_stringgap s start = do - i <- getInput - c <- getCharOrFail i - case c of - '\\' -> lex_string_helper s start - c | c <= '\x7f' && is_space c -> lex_stringgap s start - -- is_space only works for <= '\x7f' (#3751, #5425) - _other -> lit_error i - - -lex_char_tok :: Action --- Here we are basically parsing character literals, such as 'x' or '\n' --- but we additionally spot 'x and ''T, returning ITsimpleQuote and --- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part --- (the parser does that). --- So we have to do two characters of lookahead: when we see 'x we need to --- see if there's a trailing quote -lex_char_tok span buf _len _buf2 = do -- We've seen ' - i1 <- getInput -- Look ahead to first character - let loc = psSpanStart span - case alexGetChar' i1 of - Nothing -> lit_error i1 - - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - setInput i2 - return (L (mkPsSpan loc end2) ITtyQuote) - - Just ('\\', i2@(AI end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape - i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok buf loc lit_ch - else if isSingleSmartQuote mc then add_smart_quote_error mc end2 - else lit_error i3 - - Just (c, i2@(AI end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> - - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok buf loc c - Just (c, _) | isSingleSmartQuote c -> add_smart_quote_error c end2 - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- Just parse the quote only - let (AI end _) = i1 - return (L (mkPsSpan loc end) ITsimpleQuote) - -finish_char_tok :: StringBuffer -> PsLoc -> Char -> P (PsLocated Token) -finish_char_tok buf loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- getBit MagicHashBit - i@(AI end bufEnd) <- getInput - let src = lexemeToFastString buf (cur bufEnd - cur buf) - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end bufEnd')) -> do - setInput i - -- Include the trailing # in SourceText - let src' = lexemeToFastString buf (cur bufEnd' - cur buf) - return (L (mkPsSpan loc end) - (ITprimchar (SourceText src') ch)) - _other -> - return (L (mkPsSpan loc end) - (ITchar (SourceText src) ch)) - else do - return (L (mkPsSpan loc end) (ITchar (SourceText src) ch)) - -isAny :: Char -> Bool -isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c - -lex_escape :: P Char -lex_escape = do - i0@(AI loc _) <- getInput - c <- getCharOrFail i0 - case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - -- the next two patterns build up a Unicode smart quote error (#21843) - smart_double_quote | isDoubleSmartQuote smart_double_quote -> - add_smart_quote_error smart_double_quote loc - smart_single_quote | isSingleSmartQuote smart_single_quote -> - add_smart_quote_error smart_single_quote loc - '^' -> do i1 <- getInput - c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> - case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 - -readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char -readNum is_digit base conv = do - i <- getInput - c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i - -readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char -readNum2 is_digit base conv i = do - input <- getInput - read i input - where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do - let i' = i*base + conv c - if i' > 0x10ffff - then setInput input >> lexError LexNumEscapeRange - else read i' input' - _other -> do - setInput input; return (chr i) - - -silly_escape_chars :: [(String, Char)] -silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] - --- before calling lit_error, ensure that the current input is pointing to --- the position of the error in the buffer. This is so that we can report --- a correct location to the user, but also so we can detect UTF-8 decoding --- errors if they occur. -lit_error :: AlexInput -> P a -lit_error i = do setInput i; lexError LexStringCharLit - -getCharOrFail :: AlexInput -> P Char -getCharOrFail i = do - case alexGetChar' i of - Nothing -> lexError LexStringCharLitEOF - Just (c,i) -> do setInput i; return c - --- ----------------------------------------------------------------------------- --- QuasiQuote - -lex_qquasiquote_tok :: Action -lex_qquasiquote_tok span buf len _buf2 = do - let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False - quoteStart <- getParsedLoc - quote <- lex_quasiquote (psRealLoc quoteStart) "" - end <- getParsedLoc - return (L (mkPsSpan (psSpanStart span) end) - (ITqQuasiQuote (qual, - quoter, - mkFastString (reverse quote), - mkPsSpan quoteStart end))) - -lex_quasiquote_tok :: Action -lex_quasiquote_tok span buf len _buf2 = do - let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getParsedLoc - quote <- lex_quasiquote (psRealLoc quoteStart) "" - end <- getParsedLoc - return (L (mkPsSpan (psSpanStart span) end) - (ITquasiQuote (mkFastString quoter, - mkFastString (reverse quote), - mkPsSpan quoteStart end))) - -lex_quasiquote :: RealSrcLoc -> String -> P String -lex_quasiquote start s = do - i <- getInput - case alexGetChar' i of - Nothing -> quasiquote_error start - - -- NB: The string "|]" terminates the quasiquote, - -- with absolutely no escaping. See the extensive - -- discussion on #5348 for why there is no - -- escape handling. - Just ('|',i) - | Just (']',i) <- alexGetChar' i - -> do { setInput i; return s } - - Just (c, i) -> do - setInput i; lex_quasiquote start (c : s) - -quasiquote_error :: RealSrcLoc -> P a -quasiquote_error start = do - (AI end buf) <- getInput - reportLexError start (psRealLoc end) buf - (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) - --- ----------------------------------------------------------------------------- --- Unicode Smart Quote detection (#21843) - -isDoubleSmartQuote :: Char -> Bool -isDoubleSmartQuote '“' = True -isDoubleSmartQuote '”' = True -isDoubleSmartQuote _ = False - -isSingleSmartQuote :: Char -> Bool -isSingleSmartQuote '‘' = True -isSingleSmartQuote '’' = True -isSingleSmartQuote _ = False - -isSmartQuote :: AlexAccPred ExtsBitmap -isSmartQuote _ _ _ (AI _ buf) = let c = prevChar buf ' ' in isSingleSmartQuote c || isDoubleSmartQuote c - -smart_quote_error_message :: Char -> PsLoc -> MsgEnvelope PsMessage -smart_quote_error_message c loc = - let (correct_char, correct_char_name) = - if isSingleSmartQuote c then ('\'', "Single Quote") else ('"', "Quotation Mark") - err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (mkPsSpan loc loc)) $ - PsErrUnicodeCharLooksLike c correct_char correct_char_name in - err - -smart_quote_error :: Action -smart_quote_error span buf _len _buf2 = do - let c = currentChar buf - addFatalError (smart_quote_error_message c (psSpanStart span)) - -add_smart_quote_error :: Char -> PsLoc -> P a -add_smart_quote_error c loc = addFatalError (smart_quote_error_message c loc) - -add_nonfatal_smart_quote_error :: Char -> PsLoc -> P () -add_nonfatal_smart_quote_error c loc = addError (smart_quote_error_message c loc) - -advance_to_smart_quote_character :: P () -advance_to_smart_quote_character = do - i <- getInput - case alexGetChar' i of - Just (c, _) | isDoubleSmartQuote c -> return () - Just (_, i2) -> do setInput i2; advance_to_smart_quote_character - Nothing -> return () -- should never get here - --- ----------------------------------------------------------------------------- --- Warnings - -warnTab :: Action -warnTab srcspan _buf _len _buf2 = do - addTabWarning (psRealSpan srcspan) - lexToken - -warnThen :: PsMessage -> Action -> Action -warnThen warning action srcspan buf len buf2 = do - addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning - action srcspan buf len buf2 - --- ----------------------------------------------------------------------------- --- The Parse Monad - --- | Do we want to generate ';' layout tokens? In some cases we just want to --- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates --- alternatives (unlike a `case` expression where we need ';' to as a separator --- between alternatives). -type GenSemic = Bool - -generateSemic, dontGenerateSemic :: GenSemic -generateSemic = True -dontGenerateSemic = False - -data LayoutContext - = NoLayout - | Layout !Int !GenSemic - deriving Show - --- | The result of running a parser. -newtype ParseResult a = PR (# (# PState, a #) | PState #) - --- | The parser has consumed a (possibly empty) prefix of the input and produced --- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal --- errors. --- --- The carried parsing state can be used to resume parsing. -pattern POk :: PState -> a -> ParseResult a -pattern POk s a = PR (# (# s , a #) | #) - --- | The parser has consumed a (possibly empty) prefix of the input and failed. --- --- The carried parsing state can be used to resume parsing. It is the state --- right before failure, including the fatal parse error. 'getPsMessages' and --- 'getPsErrorMessages' must return a non-empty bag of errors. -pattern PFailed :: PState -> ParseResult a -pattern PFailed s = PR (# | s #) - -{-# COMPLETE POk, PFailed #-} - --- | Test whether a 'WarningFlag' is set -warnopt :: WarningFlag -> ParserOpts -> Bool -warnopt f options = f `EnumSet.member` pWarningFlags options - --- | Parser options. --- --- See 'mkParserOpts' to construct this. -data ParserOpts = ParserOpts - { pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions - , pDiagOpts :: !DiagOpts - -- ^ Options to construct diagnostic messages. - , pSupportedExts :: [String] - -- ^ supported extensions (only used for suggestions in error messages) - } - -pWarningFlags :: ParserOpts -> EnumSet WarningFlag -pWarningFlags opts = diag_warning_flags (pDiagOpts opts) - --- | Haddock comment as produced by the lexer. These are accumulated in 'PState' --- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the --- 'HsDocString's spans over the contents of the docstring - i.e. it does not --- include the decorator ("-- |", "{-|" etc.) -data HdkComment - = HdkCommentNext HsDocString - | HdkCommentPrev HsDocString - | HdkCommentNamed String HsDocString - | HdkCommentSection Int HsDocString - deriving Show - -data PState = PState { - buffer :: StringBuffer, - options :: ParserOpts, - warnings :: Messages PsMessage, - errors :: Messages PsMessage, - tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file - tab_count :: !Word, -- number of tab warnings in the file - last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token - prev_loc :: PsSpan, -- pos of previous non-virtual token, including comments, - last_loc :: PsSpan, -- pos of current token - last_len :: !Int, -- len of current token - loc :: PsLoc, -- current loc (end of prev token + 1) - context :: [LayoutContext], - lex_state :: [Int], - srcfiles :: [FastString], - -- Used in the alternative layout rule: - -- These tokens are the next ones to be sent out. They are - -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [PsLocated Token], - -- This is the next token to be considered or, if it is Nothing, - -- we need to get the next token from the input stream: - alr_next_token :: Maybe (PsLocated Token), - -- This is what we consider to be the location of the last token - -- emitted: - alr_last_loc :: PsSpan, - -- The stack of layout contexts: - alr_context :: [ALRContext], - -- Are we expecting a '{'? If it's Just, then the ALRLayout tells - -- us what sort of layout the '{' will open: - alr_expecting_ocurly :: Maybe ALRLayout, - -- Have we just had the '}' for a let block? If so, than an 'in' - -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool, - - -- The next three are used to implement Annotations giving the - -- locations of 'noise' tokens in the source, so that users of - -- the GHC API can do source to source conversions. - -- See Note [exact print annotations] in GHC.Parser.Annotation - eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token - header_comments :: Strict.Maybe [LEpaComment], - comment_q :: [LEpaComment], - - -- Haddock comments accumulated in ascending order of their location - -- (BufPos). We use OrdList to get O(1) snoc. - -- - -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock - hdk_comments :: OrdList (PsLocated HdkComment) - } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). - - -- AZ question: setLastToken which sets last_loc and last_len - -- is called when processing AlexToken, immediately prior to - -- calling the action in the token. So from the perspective - -- of the action, it is the *current* token. Do I understand - -- correctly? - -data ALRContext = ALRNoLayout Bool{- does it contain commas? -} - Bool{- is it a 'let' block? -} - | ALRLayout ALRLayout Int -data ALRLayout = ALRLayoutLet - | ALRLayoutWhere - | ALRLayoutOf - | ALRLayoutDo - --- | The parsing monad, isomorphic to @StateT PState Maybe@. -newtype P a = P { unP :: PState -> ParseResult a } - -instance Functor P where - fmap = liftM - -instance Applicative P where - pure = returnP - (<*>) = ap - -instance Monad P where - (>>=) = thenP - -returnP :: a -> P a -returnP a = a `seq` (P $ \s -> POk s a) - -thenP :: P a -> (a -> P b) -> P b -(P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed s1 -> PFailed s1 - -failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a -failMsgP f = do - pState <- getPState - addFatalError (f (mkSrcSpanPs (last_loc pState))) - -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a -failLocMsgP loc1 loc2 f = - addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) - -getPState :: P PState -getPState = P $ \s -> POk s s - -getExts :: P ExtsBitmap -getExts = P $ \s -> POk s (pExtsBitmap . options $ s) - -setExts :: (ExtsBitmap -> ExtsBitmap) -> P () -setExts f = P $ \s -> POk s { - options = - let p = options s - in p { pExtsBitmap = f (pExtsBitmap p) } - } () - -setSrcLoc :: RealSrcLoc -> P () -setSrcLoc new_loc = - P $ \s@(PState{ loc = PsLoc _ buf_loc }) -> - POk s{ loc = PsLoc new_loc buf_loc } () - -getRealSrcLoc :: P RealSrcLoc -getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc) - -getParsedLoc :: P PsLoc -getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc - -addSrcFile :: FastString -> P () -addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () - -setEofPos :: RealSrcSpan -> RealSrcSpan -> P () -setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } () - -setLastToken :: PsSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, - last_len=len - } () - -setLastTk :: PsLocated Token -> P () -setLastTk tk@(L l _) = P $ \s -> - if isPointRealSpan (psRealSpan l) - then POk s { last_tk = Strict.Just tk } () - else POk s { last_tk = Strict.Just tk - , prev_loc = l } () - -setLastComment :: PsLocated Token -> P () -setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } () - -getLastTk :: P (Strict.Maybe (PsLocated Token)) -getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk - --- see Note [PsSpan in Comments] -getLastLocIncludingComments :: P PsSpan -getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc - -getLastLoc :: P PsSpan -getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc - -data AlexInput = AI !PsLoc !StringBuffer - -{- -Note [Unicode in Alex] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Although newer versions of Alex support unicode, this grammar is processed with -the old style '--latin1' behaviour. This means that when implementing the -functions - - alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) - alexInputPrevChar :: AlexInput -> Char - -which Alex uses to take apart our 'AlexInput', we must - - * return a latin1 character in the 'Word8' that 'alexGetByte' expects - * return a latin1 character in 'alexInputPrevChar'. - -We handle this in 'adjustChar' by squishing entire classes of unicode -characters into single bytes. --} - -{-# INLINE adjustChar #-} -adjustChar :: Char -> Word8 -adjustChar c = fromIntegral $ ord adj_c - where non_graphic = '\x00' - upper = '\x01' - lower = '\x02' - digit = '\x03' - symbol = '\x04' - space = '\x05' - other_graphic = '\x06' - uniidchar = '\x07' - - adj_c - | c <= '\x07' = non_graphic - | c <= '\x7f' = c - -- Alex doesn't handle Unicode, so when Unicode - -- character is encountered we output these values - -- with the actual character value hidden in the state. - | otherwise = - -- NB: The logic behind these definitions is also reflected - -- in "GHC.Utils.Lexeme" - -- Any changes here should likely be reflected there. - - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> uniidchar -- see #10196 - OtherLetter -> lower -- see #1103 - NonSpacingMark -> uniidchar -- see #7650 - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> digit - OtherNumber -> digit -- see #4373 - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic - --- Getting the previous 'Char' isn't enough here - we need to convert it into --- the same format that 'alexGetByte' would have produced. --- --- See Note [Unicode in Alex] and #13986. -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc)) - where pc = prevChar buf '\n' - --- backwards compatibility for Alex 2.x -alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar inp = case alexGetByte inp of - Nothing -> Nothing - Just (b,i) -> c `seq` Just (c,i) - where c = chr $ fromIntegral b - --- See Note [Unicode in Alex] -alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) -alexGetByte (AI loc s) - | atEnd s = Nothing - | otherwise = byte `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (byte, (AI loc' s')) - where (c,s') = nextChar s - loc' = advancePsLoc loc c - byte = adjustChar c - -{-# INLINE alexGetChar' #-} --- This version does not squash unicode characters, it is used when --- lexing strings. -alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) - | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) - where (c,s') = nextChar s - loc' = advancePsLoc loc c - -getInput :: P AlexInput -getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) - -setInput :: AlexInput -> P () -setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () - -nextIsEOF :: P Bool -nextIsEOF = do - AI _ s <- getInput - return $ atEnd s - -pushLexState :: Int -> P () -pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () - -popLexState :: P Int -popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls - -getLexState :: P Int -getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls - -popNextToken :: P (Maybe (PsLocated Token)) -popNextToken - = P $ \s@PState{ alr_next_token = m } -> - POk (s {alr_next_token = Nothing}) m - -activeContext :: P Bool -activeContext = do - ctxt <- getALRContext - expc <- getAlrExpectingOCurly - impt <- implicitTokenPending - case (ctxt,expc) of - ([],Nothing) -> return impt - _other -> return True - -resetAlrLastLoc :: FastString -> P () -resetAlrLastLoc file = - P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) -> - POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } () - -setAlrLastLoc :: PsSpan -> P () -setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () - -getAlrLastLoc :: P PsSpan -getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l - -getALRContext :: P [ALRContext] -getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs - -setALRContext :: [ALRContext] -> P () -setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () - -getJustClosedExplicitLetBlock :: P Bool -getJustClosedExplicitLetBlock - = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b - -setJustClosedExplicitLetBlock :: Bool -> P () -setJustClosedExplicitLetBlock b - = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () - -setNextToken :: PsLocated Token -> P () -setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () - -implicitTokenPending :: P Bool -implicitTokenPending - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s False - _ -> POk s True - -popPendingImplicitToken :: P (Maybe (PsLocated Token)) -popPendingImplicitToken - = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> - case ts of - [] -> POk s Nothing - (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) - -setPendingImplicitTokens :: [PsLocated Token] -> P () -setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () - -getAlrExpectingOCurly :: P (Maybe ALRLayout) -getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b - -setAlrExpectingOCurly :: Maybe ALRLayout -> P () -setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () - --- | For reasons of efficiency, boolean parsing flags (eg, language extensions --- or whether we are currently in a @RULE@ pragma) are represented by a bitmap --- stored in a @Word64@. -type ExtsBitmap = Word64 - -xbit :: ExtBits -> ExtsBitmap -xbit = bit . fromEnum - -xtest :: ExtBits -> ExtsBitmap -> Bool -xtest ext xmap = testBit xmap (fromEnum ext) - -xset :: ExtBits -> ExtsBitmap -> ExtsBitmap -xset ext xmap = setBit xmap (fromEnum ext) - -xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap -xunset ext xmap = clearBit xmap (fromEnum ext) - --- | Various boolean flags, mostly language extensions, that impact lexing and --- parsing. Note that a handful of these can change during lexing/parsing. -data ExtBits - -- Flags that are constant once parsing starts - = FfiBit - | InterruptibleFfiBit - | CApiFfiBit - | ArrowsBit - | ThBit - | ThQuotesBit - | IpBit - | OverloadedLabelsBit -- #x overloaded labels - | ExplicitForallBit -- the 'forall' keyword - | BangPatBit -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) - | PatternSynonymsBit -- pattern synonyms - | HaddockBit-- Lex and parse Haddock comments - | MagicHashBit -- "#" in both functions and operators - | RecursiveDoBit -- mdo - | QualifiedDoBit -- .do and .mdo - | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc - | UnboxedParensBit -- (# and #) - | DatatypeContextsBit - | MonadComprehensionsBit - | TransformComprehensionsBit - | QqBit -- enable quasiquoting - | RawTokenStreamBit -- producing a token stream with all comments included - | AlternativeLayoutRuleBit - | ALRTransitionalBit - | RelaxedLayoutBit - | NondecreasingIndentationBit - | SafeHaskellBit - | TraditionalRecordSyntaxBit - | ExplicitNamespacesBit - | LambdaCaseBit - | BinaryLiteralsBit - | NegativeLiteralsBit - | HexFloatLiteralsBit - | StaticPointersBit - | NumericUnderscoresBit - | StarIsTypeBit - | BlockArgumentsBit - | NPlusKPatternsBit - | DoAndIfThenElseBit - | MultiWayIfBit - | GadtSyntaxBit - | ImportQualifiedPostBit - | LinearTypesBit - | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] - | OverloadedRecordDotBit - | OverloadedRecordUpdateBit - | ExtendedLiteralsBit - - -- Flags that are updated once parsing starts - | InRulePragBit - | InNestedCommentBit -- See Note [Nested comment line pragmas] - | UsePosPragsBit - -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' - -- update the internal position. Otherwise, those pragmas are lexed as - -- tokens of their own. - deriving Enum - -{-# INLINE mkParserOpts #-} -mkParserOpts - :: EnumSet LangExt.Extension -- ^ permitted language extensions enabled - -> DiagOpts -- ^ diagnostic options - -> [String] -- ^ Supported Languages and Extensions - -> Bool -- ^ are safe imports on? - -> Bool -- ^ keeping Haddock comment tokens - -> Bool -- ^ keep regular comment tokens - - -> Bool - -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update - -- the internal position kept by the parser. Otherwise, those pragmas are - -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. - - -> ParserOpts --- ^ Given exactly the information needed, set up the 'ParserOpts' -mkParserOpts extensionFlags diag_opts supported - safeImports isHaddock rawTokStream usePosPrags = - ParserOpts { - pDiagOpts = diag_opts - , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits - , pSupportedExts = supported - } - where - safeHaskellBit = SafeHaskellBit `setBitIf` safeImports - langExtBits = - FfiBit `xoptBit` LangExt.ForeignFunctionInterface - .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI - .|. CApiFfiBit `xoptBit` LangExt.CApiFFI - .|. ArrowsBit `xoptBit` LangExt.Arrows - .|. ThBit `xoptBit` LangExt.TemplateHaskell - .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes - .|. QqBit `xoptBit` LangExt.QuasiQuotes - .|. IpBit `xoptBit` LangExt.ImplicitParams - .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels - .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll - .|. BangPatBit `xoptBit` LangExt.BangPatterns - .|. MagicHashBit `xoptBit` LangExt.MagicHash - .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo - .|. QualifiedDoBit `xoptBit` LangExt.QualifiedDo - .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax - .|. UnboxedParensBit `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums] - .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts - .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp - .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions - .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule - .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional - .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout - .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation - .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax - .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces - .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase - .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals - .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals - .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals - .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms - .|. StaticPointersBit `xoptBit` LangExt.StaticPointers - .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores - .|. StarIsTypeBit `xoptBit` LangExt.StarIsType - .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments - .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns - .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse - .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf - .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax - .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost - .|. LinearTypesBit `xoptBit` LangExt.LinearTypes - .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] - .|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot - .|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information). - .|. ExtendedLiteralsBit `xoptBit` LangExt.ExtendedLiterals - optBits = - HaddockBit `setBitIf` isHaddock - .|. RawTokenStreamBit `setBitIf` rawTokStream - .|. UsePosPragsBit `setBitIf` usePosPrags - - xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags - xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags) - - orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts - - setBitIf :: ExtBits -> Bool -> ExtsBitmap - b `setBitIf` cond | cond = xbit b - | otherwise = 0 - -disableHaddock :: ParserOpts -> ParserOpts -disableHaddock opts = upd_bitmap (xunset HaddockBit) - where - upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) } - - --- | Set parser options for parsing OPTIONS pragmas -initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState -initPragState options buf loc = (initParserState options buf loc) - { lex_state = [bol, option_prags, 0] - } - --- | Creates a parse state from a 'ParserOpts' value -initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState -initParserState options buf loc = - PState { - buffer = buf, - options = options, - errors = emptyMessages, - warnings = emptyMessages, - tab_first = Strict.Nothing, - tab_count = 0, - last_tk = Strict.Nothing, - prev_loc = mkPsSpan init_loc init_loc, - last_loc = mkPsSpan init_loc init_loc, - last_len = 0, - loc = init_loc, - context = [], - lex_state = [bol, 0], - srcfiles = [], - alr_pending_implicit_tokens = [], - alr_next_token = Nothing, - alr_last_loc = PsSpan (alrInitialLoc (fsLit "")) (BufSpan (BufPos 0) (BufPos 0)), - alr_context = [], - alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False, - eof_pos = Strict.Nothing, - header_comments = Strict.Nothing, - comment_q = [], - hdk_comments = nilOL - } - where init_loc = PsLoc loc (BufPos 0) - --- | An mtl-style class for monads that support parsing-related operations. --- For example, sometimes we make a second pass over the parsing results to validate, --- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume --- input but can report parsing errors, check for extension bits, and accumulate --- parsing annotations. Both P and PV are instances of MonadP. --- --- MonadP grants us convenient overloading. The other option is to have separate operations --- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on. --- -class Monad m => MonadP m where - -- | Add a non-fatal error. Use this when the parser can produce a result - -- despite the error. - -- - -- For example, when GHC encounters a @forall@ in a type, - -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ - -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to - -- the accumulator. - -- - -- Control flow wise, non-fatal errors act like warnings: they are added - -- to the accumulator and parsing continues. This allows GHC to report - -- more than one parse error per file. - -- - addError :: MsgEnvelope PsMessage -> m () - - -- | Add a warning to the accumulator. - -- Use 'getPsMessages' to get the accumulated warnings. - addWarning :: MsgEnvelope PsMessage -> m () - - -- | Add a fatal error. This will be the last error reported by the parser, and - -- the parser will not produce any result, ending in a 'PFailed' state. - addFatalError :: MsgEnvelope PsMessage -> m a - - -- | Check if a given flag is currently set in the bitmap. - getBit :: ExtBits -> m Bool - -- | Go through the @comment_q@ in @PState@ and remove all comments - -- that belong within the given span - allocateCommentsP :: RealSrcSpan -> m EpAnnComments - -- | Go through the @comment_q@ in @PState@ and remove all comments - -- that come before or within the given span - allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments - -- | Go through the @comment_q@ in @PState@ and remove all comments - -- that come after the given span - allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments - -instance MonadP P where - addError err - = P $ \s -> POk s { errors = err `addMessage` errors s} () - - -- If the warning is meant to be suppressed, GHC will assign - -- a `SevIgnore` severity and the message will be discarded, - -- so we can simply add it no matter what. - addWarning w - = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) () - - addFatalError err = - addError err >> P PFailed - - getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) - in b `seq` POk s b - allocateCommentsP ss = P $ \s -> - let (comment_q', newAnns) = allocateComments ss (comment_q s) in - POk s { - comment_q = comment_q' - } (EpaComments newAnns) - allocatePriorCommentsP ss = P $ \s -> - let (header_comments', comment_q', newAnns) - = allocatePriorComments ss (comment_q s) (header_comments s) in - POk s { - header_comments = header_comments', - comment_q = comment_q' - } (EpaComments newAnns) - allocateFinalCommentsP ss = P $ \s -> - let (header_comments', comment_q', newAnns) - = allocateFinalComments ss (comment_q s) (header_comments s) in - POk s { - header_comments = header_comments', - comment_q = comment_q' - } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) - -getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -getCommentsFor (RealSrcSpan l _) = allocateCommentsP l -getCommentsFor _ = return emptyComments - -getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l -getPriorCommentsFor _ = return emptyComments - -getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments -getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l -getFinalCommentsFor _ = return emptyComments - -getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) -getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos - -addPsMessage :: SrcSpan -> PsMessage -> P () -addPsMessage srcspan msg = do - diag_opts <- (pDiagOpts . options) <$> getPState - addWarning (mkPlainMsgEnvelope diag_opts srcspan msg) - -addTabWarning :: RealSrcSpan -> P () -addTabWarning srcspan - = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> - let tf' = tf <|> Strict.Just srcspan - tc' = tc + 1 - s' = if warnopt Opt_WarnTabs o - then s{tab_first = tf', tab_count = tc'} - else s - in POk s' () - --- | Get a bag of the errors that have been accumulated so far. --- Does not take -Werror into account. -getPsErrorMessages :: PState -> Messages PsMessage -getPsErrorMessages p = errors p - --- | Get the warnings and errors accumulated so far. --- Does not take -Werror into account. -getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage) -getPsMessages p = - let ws = warnings p - diag_opts = pDiagOpts (options p) - -- we add the tabulation warning on the fly because - -- we count the number of occurrences of tab characters - ws' = case tab_first p of - Strict.Nothing -> ws - Strict.Just tf -> - let msg = mkPlainMsgEnvelope diag_opts - (RealSrcSpan tf Strict.Nothing) - (PsWarnTab (tab_count p)) - in msg `addMessage` ws - in (ws', errors p) - -getContext :: P [LayoutContext] -getContext = P $ \s@PState{context=ctx} -> POk s ctx - -setContext :: [LayoutContext] -> P () -setContext ctx = P $ \s -> POk s{context=ctx} () - -popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, - last_len = len, last_loc = last_loc }) -> - case ctx of - (_:tl) -> - POk s{ context = tl } () - [] -> - unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s - --- Push a new layout context at the indentation of the last token read. -pushCurrentContext :: GenSemic -> P () -pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} () - --- This is only used at the outer level of a module when the 'module' keyword is --- missing. -pushModuleContext :: P () -pushModuleContext = pushCurrentContext generateSemic - -getOffside :: P (Ordering, Bool) -getOffside = P $ \s@PState{last_loc=loc, context=stk} -> - let offs = srcSpanStartCol (psRealSpan loc) in - let ord = case stk of - Layout n gen_semic : _ -> - --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ - (compare offs n, gen_semic) - _ -> - (GT, dontGenerateSemic) - in POk s ord - --- --------------------------------------------------------------------------- --- Construct a parse error - -srcParseErr - :: ParserOpts - -> StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token - -> SrcSpan - -> MsgEnvelope PsMessage -srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details) - where - token = lexemeToString (offsetBytes (-len) buf) len - pattern_ = decodePrevNChars 8 buf - last100 = decodePrevNChars 100 buf - doInLast100 = "do" `isInfixOf` last100 - mdoInLast100 = "mdo" `isInfixOf` last100 - th_enabled = ThQuotesBit `xtest` pExtsBitmap options - ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options - details = PsErrParseDetails { - ped_th_enabled = th_enabled - , ped_do_in_last_100 = doInLast100 - , ped_mdo_in_last_100 = mdoInLast100 - , ped_pat_syn_enabled = ps_enabled - , ped_pattern_parsed = pattern_ == "pattern " - } - --- Report a parse failure, giving the span of the previous token as --- the location of the error. This is the entry point for errors --- detected during parsing. -srcParseFail :: P a -srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, - last_loc = last_loc } -> - unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s - --- A lexical error is reported at a particular position in the source file, --- not over a token range. -lexError :: LexErr -> P a -lexError e = do - loc <- getRealSrcLoc - (AI end buf) <- getInput - reportLexError loc (psRealLoc end) buf - (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k) - --- ----------------------------------------------------------------------------- --- This is the top-level function: called from the parser each time a --- new token is to be read from the input. - -lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a - -lexer queueComments cont = do - alr <- getBit AlternativeLayoutRuleBit - let lexTokenFun = if alr then lexTokenAlr else lexToken - (L span tok) <- lexTokenFun - --trace ("token: " ++ show tok) $ do - - if (queueComments && isComment tok) - then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont - else cont (L (mkSrcSpanPs span) tok) - --- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging. -lexerDbg queueComments cont = lexer queueComments contDbg - where - contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok) - -lexTokenAlr :: P (PsLocated Token) -lexTokenAlr = do mPending <- popPendingImplicitToken - t <- case mPending of - Nothing -> - do mNext <- popNextToken - t <- case mNext of - Nothing -> lexToken - Just next -> return next - alternativeLayoutRuleToken t - Just t -> - return t - setAlrLastLoc (getLoc t) - case unLoc t of - ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) - ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) - ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf) - ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) - ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) - _ -> return () - return t - -alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token) -alternativeLayoutRuleToken t - = do context <- getALRContext - lastLoc <- getAlrLastLoc - mExpectingOCurly <- getAlrExpectingOCurly - transitional <- getBit ALRTransitionalBit - justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock - setJustClosedExplicitLetBlock False - let thisLoc = getLoc t - thisCol = srcSpanStartCol (psRealSpan thisLoc) - newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc) - case (unLoc t, context, mExpectingOCurly) of - -- This case handles a GHC extension to the original H98 - -- layout rule... - (ITocurly, _, Just alrLayout) -> - do setAlrExpectingOCurly Nothing - let isLet = case alrLayout of - ALRLayoutLet -> True - _ -> False - setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) - return t - -- ...and makes this case unnecessary - {- - -- I think our implicit open-curly handling is slightly - -- different to John's, in how it interacts with newlines - -- and "in" - (ITocurly, _, Just _) -> - do setAlrExpectingOCurly Nothing - setNextToken t - lexTokenAlr - -} - (_, ALRLayout _ col : _ls, Just expectingOCurly) - | (thisCol > col) || - (thisCol == col && - isNonDecreasingIndentation expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITvocurly) - | otherwise -> - do setAlrExpectingOCurly Nothing - setPendingImplicitTokens [L lastLoc ITvccurly] - setNextToken t - return (L lastLoc ITvocurly) - (_, _, Just expectingOCurly) -> - do setAlrExpectingOCurly Nothing - setALRContext (ALRLayout expectingOCurly thisCol : context) - setNextToken t - return (L thisLoc ITvocurly) - -- We do the [] cases earlier than in the spec, as we - -- have an actual EOF token - (ITeof, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - (ITeof, _, _) -> - return t - -- the other ITeof case omitted; general case below covers it - (ITin, _, _) - | justClosedExplicitLetBlock -> - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) - | newLine -> - do setPendingImplicitTokens [t] - setALRContext ls - return (L thisLoc ITvccurly) - -- This next case is to handle a transitional issue: - (ITwhere, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addPsMessage - (mkSrcSpanPs thisLoc) - (PsWarnTransitionalLayout TransLayout_Where) - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITvccurly) - -- This next case is to handle a transitional issue: - (ITvbar, ALRLayout _ col : ls, _) - | newLine && thisCol == col && transitional -> - do addPsMessage - (mkSrcSpanPs thisLoc) - (PsWarnTransitionalLayout TransLayout_Pipe) - setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITvccurly) - (_, ALRLayout _ col : ls, _) - | newLine && thisCol == col -> - do setNextToken t - let loc = psSpanStart thisLoc - zeroWidthLoc = mkPsSpan loc loc - return (L zeroWidthLoc ITsemi) - | newLine && thisCol < col -> - do setALRContext ls - setNextToken t - -- Note that we use lastLoc, as we may need to close - -- more layouts, or give a semicolon - return (L lastLoc ITvccurly) - -- We need to handle close before open, as 'then' is both - -- an open and a close - (u, _, _) - | isALRclose u -> - case context of - ALRLayout _ _ : ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - ALRNoLayout _ isLet : ls -> - do let ls' = if isALRopen u - then ALRNoLayout (containsCommas u) False : ls - else ls - setALRContext ls' - when isLet $ setJustClosedExplicitLetBlock True - return t - [] -> - do let ls = if isALRopen u - then [ALRNoLayout (containsCommas u) False] - else [] - setALRContext ls - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) False : context) - return t - (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITvccurly) - (ITin, ALRLayout _ _ : ls, _) -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - -- the other ITin case omitted; general case below covers it - (ITcomma, ALRLayout _ _ : ls, _) - | topNoLayoutContainsCommas ls -> - do setALRContext ls - setNextToken t - return (L thisLoc ITvccurly) - (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> - do setALRContext ls - setPendingImplicitTokens [t] - return (L thisLoc ITvccurly) - -- the other ITwhere case omitted; general case below covers it - (_, _, _) -> return t - -isALRopen :: Token -> Bool -isALRopen ITcase = True -isALRopen ITif = True -isALRopen ITthen = True -isALRopen IToparen = True -isALRopen ITobrack = True -isALRopen ITocurly = True --- GHC Extensions: -isALRopen IToubxparen = True -isALRopen _ = False - -isALRclose :: Token -> Bool -isALRclose ITof = True -isALRclose ITthen = True -isALRclose ITelse = True -isALRclose ITcparen = True -isALRclose ITcbrack = True -isALRclose ITccurly = True --- GHC Extensions: -isALRclose ITcubxparen = True -isALRclose _ = False - -isNonDecreasingIndentation :: ALRLayout -> Bool -isNonDecreasingIndentation ALRLayoutDo = True -isNonDecreasingIndentation _ = False - -containsCommas :: Token -> Bool -containsCommas IToparen = True -containsCommas ITobrack = True --- John doesn't have {} as containing commas, but records contain them, --- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs --- (defaultInstallDirs). -containsCommas ITocurly = True --- GHC Extensions: -containsCommas IToubxparen = True -containsCommas _ = False - -topNoLayoutContainsCommas :: [ALRContext] -> Bool -topNoLayoutContainsCommas [] = False -topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls -topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b - -lexToken :: P (PsLocated Token) -lexToken = do - inp@(AI loc1 buf) <- getInput - sc <- getLexState - exts <- getExts - case alexScanUser exts inp sc of - AlexEOF -> do - let span = mkPsSpan loc1 loc1 - lc <- getLastLocIncludingComments - setEofPos (psRealSpan span) (psRealSpan lc) - setLastToken span 0 - return (L span ITeof) - AlexError (AI loc2 buf) -> - reportLexError (psRealLoc loc1) (psRealLoc loc2) buf - (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k) - AlexSkip inp2 _ -> do - setInput inp2 - lexToken - AlexToken inp2@(AI end buf2) _ t -> do - setInput inp2 - let span = mkPsSpan loc1 end - let bytes = byteDiff buf buf2 - span `seq` setLastToken span bytes - lt <- t span buf bytes buf2 - let lt' = unLoc lt - if (isComment lt') then setLastComment lt else setLastTk lt - return lt - -reportLexError :: RealSrcLoc - -> RealSrcLoc - -> StringBuffer - -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage) - -> P a -reportLexError loc1 loc2 buf f - | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) - | otherwise = - let c = fst (nextChar buf) - in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (f LexErrKind_UTF8) - else failLocMsgP loc1 loc2 (f (LexErrKind_Char c)) - -lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token] -lexTokenStream opts buf loc = unP go initState{ options = opts' } - where - new_exts = xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens - $ xset RawTokenStreamBit -- include comments - $ pExtsBitmap opts - opts' = opts { pExtsBitmap = new_exts } - initState = initParserState opts' buf loc - go = do - ltok <- lexer False return - case ltok of - L _ ITeof -> return [] - _ -> liftM (ltok:) go - -linePrags = Map.singleton "line" linePrag - -fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), - ("options_ghc", lex_string_prag IToptions_prag), - ("options_haddock", lex_string_prag_comment ITdocOptions), - ("language", token ITlanguage_prag), - ("include", lex_string_prag ITinclude_prag)]) - -ignoredPrags = Map.fromList (map ignored pragmas) - where ignored opt = (opt, nested_comment) - impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] - options_pragmas = map ("options_" ++) impls - -- CFILES is a hugs-only thing. - pragmas = options_pragmas ++ ["cfiles", "contract"] - -oneWordPrags = Map.fromList [ - ("rules", rulePrag), - ("inline", - fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))), - ("inlinable", - fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), - ("inlineable", - fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), - -- Spelling variant - ("notinline", - fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))), - ("opaque", fstrtoken (\s -> ITopaque_prag (SourceText s))), - ("specialize", fstrtoken (\s -> ITspec_prag (SourceText s))), - ("source", fstrtoken (\s -> ITsource_prag (SourceText s))), - ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))), - ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))), - ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))), - ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))), - ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))), - ("ann", fstrtoken (\s -> ITann_prag (SourceText s))), - ("minimal", fstrtoken (\s -> ITminimal_prag (SourceText s))), - ("overlaps", fstrtoken (\s -> IToverlaps_prag (SourceText s))), - ("overlappable", fstrtoken (\s -> IToverlappable_prag (SourceText s))), - ("overlapping", fstrtoken (\s -> IToverlapping_prag (SourceText s))), - ("incoherent", fstrtoken (\s -> ITincoherent_prag (SourceText s))), - ("ctype", fstrtoken (\s -> ITctype (SourceText s))), - ("complete", fstrtoken (\s -> ITcomplete_prag (SourceText s))), - ("column", columnPrag) - ] - -twoWordPrags = Map.fromList [ - ("inline conlike", - fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))), - ("notinline conlike", - fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))), - ("specialize inline", - fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))), - ("specialize notinline", - fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False))) - ] - -dispatch_pragmas :: Map String Action -> Action -dispatch_pragmas prags span buf len buf2 = - case Map.lookup (clean_pragma (lexemeToString buf len)) prags of - Just found -> found span buf len buf2 - Nothing -> lexError LexUnknownPragma - -known_pragma :: Map String Action -> AlexAccPred ExtsBitmap -known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) - = isKnown && nextCharIsNot curbuf pragmaNameChar - where l = lexemeToString startbuf (byteDiff startbuf curbuf) - isKnown = isJust $ Map.lookup (clean_pragma l) prags - pragmaNameChar c = isAlphaNum c || c == '_' - -clean_pragma :: String -> String -clean_pragma prag = canon_ws (map toLower (unprefix prag)) - where unprefix prag' = case stripPrefix "{-#" prag' of - Just rest -> rest - Nothing -> prag' - canonical prag' = case prag' of - "noinline" -> "notinline" - "specialise" -> "specialize" - "constructorlike" -> "conlike" - _ -> prag' - canon_ws s = unwords (map canonical (words s)) - -warn_unknown_prag :: Map String Action -> Action -warn_unknown_prag prags span buf len buf2 = do - let uppercase = map toUpper - unknown_prag = uppercase (clean_pragma (lexemeToString buf len)) - suggestions = map uppercase (Map.keys prags) - addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $ - PsWarnUnrecognisedPragma unknown_prag suggestions - nested_comment span buf len buf2 - -{- -%************************************************************************ -%* * - Helper functions for generating annotations in the parser -%* * -%************************************************************************ --} - - --- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate --- 'AddEpAnn' values for the opening and closing bordering on the start --- and end of the span -mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn) -mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing)) - where - f = srcSpanFile ss - sl = srcSpanStartLine ss - sc = srcSpanStartCol ss - el = srcSpanEndLine ss - ec = srcSpanEndCol ss - lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) - lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) - -queueComment :: RealLocated Token -> P() -queueComment c = P $ \s -> POk s { - comment_q = commentToAnnotation c : comment_q s - } () - -allocateComments - :: RealSrcSpan - -> [LEpaComment] - -> ([LEpaComment], [LEpaComment]) -allocateComments ss comment_q = - let - (before,rest) = break (\(L l _) -> isRealSubspanOf (anchor l) ss) comment_q - (middle,after) = break (\(L l _) -> not (isRealSubspanOf (anchor l) ss)) rest - comment_q' = before ++ after - newAnns = middle - in - (comment_q', reverse newAnns) - --- Comments appearing without a line-break before the first --- declaration are associated with the declaration -splitPriorComments - :: RealSrcSpan - -> [LEpaComment] - -> ([LEpaComment], [LEpaComment]) -splitPriorComments ss prior_comments = - let - -- True if there is only one line between the earlier and later span, - -- And the token preceding the comment is on a different line - cmp :: RealSrcSpan -> LEpaComment -> Bool - cmp later (L l c) - = srcSpanStartLine later - srcSpanEndLine (anchor l) == 1 - && srcSpanEndLine (ac_prior_tok c) /= srcSpanStartLine (anchor l) - - go :: [LEpaComment] -> RealSrcSpan -> [LEpaComment] - -> ([LEpaComment], [LEpaComment]) - go decl_comments _ [] = ([],decl_comments) - go decl_comments r (c@(L l _):cs) = if cmp r c - then go (c:decl_comments) (anchor l) cs - else (reverse (c:cs), decl_comments) - in - go [] ss prior_comments - -allocatePriorComments - :: RealSrcSpan - -> [LEpaComment] - -> Strict.Maybe [LEpaComment] - -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) -allocatePriorComments ss comment_q mheader_comments = - let - cmp (L l _) = anchor l <= ss - (newAnns,after) = partition cmp comment_q - comment_q'= after - (prior_comments, decl_comments) = splitPriorComments ss newAnns - in - case mheader_comments of - Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments) - Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns) - -allocateFinalComments - :: RealSrcSpan - -> [LEpaComment] - -> Strict.Maybe [LEpaComment] - -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) -allocateFinalComments _ss comment_q mheader_comments = - -- We ignore the RealSrcSpan as the parser currently provides a - -- point span at (1,1). - case mheader_comments of - Strict.Nothing -> (Strict.Just (reverse comment_q), [], []) - Strict.Just _ -> (mheader_comments, [], reverse comment_q) - -commentToAnnotation :: RealLocated Token -> LEpaComment -commentToAnnotation (L l (ITdocComment s ll)) = mkLEpaComment l ll (EpaDocComment s) -commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) -commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) -commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) -commentToAnnotation _ = panic "commentToAnnotation" - --- see Note [PsSpan in Comments] -mkLEpaComment :: RealSrcSpan -> PsSpan -> EpaCommentTok -> LEpaComment -mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll)) - --- --------------------------------------------------------------------- - -isComment :: Token -> Bool -isComment (ITlineComment _ _) = True -isComment (ITblockComment _ _) = True -isComment (ITdocComment _ _) = True -isComment (ITdocOptions _ _) = True -isComment _ = False - -bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag2,line_prag2a,option_prags :: Int -bol = 1 -column_prag = 2 -layout = 3 -layout_do = 4 -layout_if = 5 -layout_left = 6 -line_prag1 = 7 -line_prag1a = 8 -line_prag2 = 9 -line_prag2a = 10 -option_prags = 11 -alex_action_1 = warnTab -alex_action_2 = nested_comment -alex_action_3 = lineCommentToken -alex_action_4 = lineCommentToken -alex_action_5 = lineCommentToken -alex_action_6 = lineCommentToken -alex_action_7 = lineCommentToken -alex_action_8 = lineCommentToken -alex_action_9 = smart_quote_error -alex_action_11 = begin line_prag1 -alex_action_12 = begin line_prag1 -alex_action_16 = do_bol -alex_action_17 = hopefully_open_brace -alex_action_19 = begin line_prag1 -alex_action_20 = new_layout_context True dontGenerateSemic ITvbar -alex_action_21 = pop -alex_action_22 = new_layout_context True generateSemic ITvocurly -alex_action_23 = new_layout_context False generateSemic ITvocurly -alex_action_24 = do_layout_left -alex_action_25 = begin bol -alex_action_26 = dispatch_pragmas linePrags -alex_action_27 = setLineAndFile line_prag1a -alex_action_28 = failLinePrag1 -alex_action_29 = popLinePrag1 -alex_action_30 = setLineAndFile line_prag2a -alex_action_31 = pop -alex_action_32 = setColumn -alex_action_33 = dispatch_pragmas twoWordPrags -alex_action_34 = dispatch_pragmas oneWordPrags -alex_action_35 = dispatch_pragmas ignoredPrags -alex_action_36 = endPrag -alex_action_37 = dispatch_pragmas fileHeaderPrags -alex_action_38 = nested_comment -alex_action_39 = warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) -alex_action_40 = warn_unknown_prag Map.empty -alex_action_41 = multiline_doc_comment -alex_action_42 = nested_doc_comment -alex_action_43 = token (ITopenExpQuote NoE NormalSyntax) -alex_action_44 = token (ITopenTExpQuote NoE) -alex_action_45 = token (ITcloseQuote NormalSyntax) -alex_action_46 = token ITcloseTExpQuote -alex_action_47 = token (ITopenExpQuote HasE NormalSyntax) -alex_action_48 = token (ITopenTExpQuote HasE) -alex_action_49 = token ITopenPatQuote -alex_action_50 = layout_token ITopenDecQuote -alex_action_51 = token ITopenTypQuote -alex_action_52 = lex_quasiquote_tok -alex_action_53 = lex_qquasiquote_tok -alex_action_54 = token (ITopenExpQuote NoE UnicodeSyntax) -alex_action_55 = token (ITcloseQuote UnicodeSyntax) -alex_action_56 = special (IToparenbar NormalSyntax) -alex_action_57 = special (ITcparenbar NormalSyntax) -alex_action_58 = special (IToparenbar UnicodeSyntax) -alex_action_59 = special (ITcparenbar UnicodeSyntax) -alex_action_60 = skip_one_varid ITdupipvarid -alex_action_61 = skip_one_varid_src ITlabelvarid -alex_action_62 = lex_quoted_label -alex_action_63 = token IToubxparen -alex_action_64 = token ITcubxparen -alex_action_65 = special IToparen -alex_action_66 = special ITcparen -alex_action_67 = special ITobrack -alex_action_68 = special ITcbrack -alex_action_69 = special ITcomma -alex_action_70 = special ITsemi -alex_action_71 = special ITbackquote -alex_action_72 = open_brace -alex_action_73 = close_brace -alex_action_74 = qdo_token ITdo -alex_action_75 = qdo_token ITmdo -alex_action_76 = idtoken qvarid -alex_action_77 = idtoken qconid -alex_action_78 = varid -alex_action_79 = idtoken conid -alex_action_80 = idtoken qvarid -alex_action_81 = idtoken qconid -alex_action_82 = varid -alex_action_83 = idtoken conid -alex_action_84 = idtoken qvarsym -alex_action_85 = idtoken qconsym -alex_action_86 = with_op_ws varsym -alex_action_87 = with_op_ws consym -alex_action_88 = tok_num positive 0 0 decimal -alex_action_89 = tok_num positive 2 2 binary -alex_action_90 = tok_num positive 2 2 octal -alex_action_91 = tok_num positive 2 2 hexadecimal -alex_action_92 = tok_num negative 1 1 decimal -alex_action_93 = tok_num negative 3 3 binary -alex_action_94 = tok_num negative 3 3 octal -alex_action_95 = tok_num negative 3 3 hexadecimal -alex_action_96 = tok_frac 0 tok_float -alex_action_97 = tok_frac 0 tok_float -alex_action_98 = tok_frac 0 tok_hex_float -alex_action_99 = tok_frac 0 tok_hex_float -alex_action_100 = tok_primint positive 0 1 decimal -alex_action_101 = tok_primint positive 2 3 binary -alex_action_102 = tok_primint positive 2 3 octal -alex_action_103 = tok_primint positive 2 3 hexadecimal -alex_action_104 = tok_primint negative 1 2 decimal -alex_action_105 = tok_primint negative 3 4 binary -alex_action_106 = tok_primint negative 3 4 octal -alex_action_107 = tok_primint negative 3 4 hexadecimal -alex_action_108 = tok_primword 0 2 decimal -alex_action_109 = tok_primword 2 4 binary -alex_action_110 = tok_primword 2 4 octal -alex_action_111 = tok_primword 2 4 hexadecimal -alex_action_112 = tok_frac 1 tok_primfloat -alex_action_113 = tok_frac 2 tok_primdouble -alex_action_114 = tok_frac 1 tok_primfloat -alex_action_115 = tok_frac 2 tok_primdouble -alex_action_116 = tok_primint8 positive 0 decimal -alex_action_117 = tok_primint8 positive 2 binary -alex_action_118 = tok_primint8 positive 2 octal -alex_action_119 = tok_primint8 positive 2 hexadecimal -alex_action_120 = tok_primint8 negative 1 decimal -alex_action_121 = tok_primint8 negative 3 binary -alex_action_122 = tok_primint8 negative 3 octal -alex_action_123 = tok_primint8 negative 3 hexadecimal -alex_action_124 = tok_primint16 positive 0 decimal -alex_action_125 = tok_primint16 positive 2 binary -alex_action_126 = tok_primint16 positive 2 octal -alex_action_127 = tok_primint16 positive 2 hexadecimal -alex_action_128 = tok_primint16 negative 1 decimal -alex_action_129 = tok_primint16 negative 3 binary -alex_action_130 = tok_primint16 negative 3 octal -alex_action_131 = tok_primint16 negative 3 hexadecimal -alex_action_132 = tok_primint32 positive 0 decimal -alex_action_133 = tok_primint32 positive 2 binary -alex_action_134 = tok_primint32 positive 2 octal -alex_action_135 = tok_primint32 positive 2 hexadecimal -alex_action_136 = tok_primint32 negative 1 decimal -alex_action_137 = tok_primint32 negative 3 binary -alex_action_138 = tok_primint32 negative 3 octal -alex_action_139 = tok_primint32 negative 3 hexadecimal -alex_action_140 = tok_primint64 positive 0 decimal -alex_action_141 = tok_primint64 positive 2 binary -alex_action_142 = tok_primint64 positive 2 octal -alex_action_143 = tok_primint64 positive 2 hexadecimal -alex_action_144 = tok_primint64 negative 1 decimal -alex_action_145 = tok_primint64 negative 3 binary -alex_action_146 = tok_primint64 negative 3 octal -alex_action_147 = tok_primint64 negative 3 hexadecimal -alex_action_148 = tok_primint positive 0 4 decimal -alex_action_149 = tok_primint positive 2 6 binary -alex_action_150 = tok_primint positive 2 6 octal -alex_action_151 = tok_primint positive 2 6 hexadecimal -alex_action_152 = tok_primint negative 1 5 decimal -alex_action_153 = tok_primint negative 3 7 binary -alex_action_154 = tok_primint negative 3 7 octal -alex_action_155 = tok_primint negative 3 7 hexadecimal -alex_action_156 = tok_primword8 0 decimal -alex_action_157 = tok_primword8 2 binary -alex_action_158 = tok_primword8 2 octal -alex_action_159 = tok_primword8 2 hexadecimal -alex_action_160 = tok_primword16 0 decimal -alex_action_161 = tok_primword16 2 binary -alex_action_162 = tok_primword16 2 octal -alex_action_163 = tok_primword16 2 hexadecimal -alex_action_164 = tok_primword32 0 decimal -alex_action_165 = tok_primword32 2 binary -alex_action_166 = tok_primword32 2 octal -alex_action_167 = tok_primword32 2 hexadecimal -alex_action_168 = tok_primword64 0 decimal -alex_action_169 = tok_primword64 2 binary -alex_action_170 = tok_primword64 2 octal -alex_action_171 = tok_primword64 2 hexadecimal -alex_action_172 = tok_primword 0 5 decimal -alex_action_173 = tok_primword 2 7 binary -alex_action_174 = tok_primword 2 7 octal -alex_action_175 = tok_primword 2 7 hexadecimal -alex_action_176 = lex_char_tok -alex_action_177 = lex_string_tok - -#define ALEX_GHC 1 -#define ALEX_LATIN1 1 --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - -#ifdef ALEX_GHC -# define ILIT(n) n# -# define IBOX(n) (I# (n)) -# define FAST_INT Int# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -# if __GLASGOW_HASKELL__ > 706 -# define GTE(n,m) (tagToEnum# (n >=# m)) -# define EQ(n,m) (tagToEnum# (n ==# m)) -# else -# define GTE(n,m) (n >=# m) -# define EQ(n,m) (n ==# m) -# endif -# define PLUS(n,m) (n +# m) -# define MINUS(n,m) (n -# m) -# define TIMES(n,m) (n *# m) -# define NEGATE(n) (negateInt# (n)) -# define IF_GHC(x) (x) -#else -# define ILIT(n) (n) -# define IBOX(n) (n) -# define FAST_INT Int -# define GTE(n,m) (n >= m) -# define EQ(n,m) (n == m) -# define PLUS(n,m) (n + m) -# define MINUS(n,m) (n - m) -# define TIMES(n,m) (n * m) -# define NEGATE(n) (negate (n)) -# define IF_GHC(x) -#endif - -#ifdef ALEX_GHC -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else -#if __GLASGOW_HASKELL__ >= 901 - int16ToInt# -#endif - (indexInt16OffAddr# arr off) -#endif -#else -alexIndexInt16OffAddr arr off = arr ! off -#endif - -#ifdef ALEX_GHC -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else -#if __GLASGOW_HASKELL__ >= 901 - int32ToInt# -#endif - (indexInt32OffAddr# arr off) -#endif -#else -alexIndexInt32OffAddr arr off = arr ! off -#endif - -#ifdef ALEX_GHC - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif -#else -quickIndex arr i = arr ! i -#endif - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ IBOX(sc) - = alexScanUser undefined input__ IBOX(sc) - -alexScanUser user__ input__ IBOX(sc) - = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> -#ifdef ALEX_DEBUG - trace ("End of input.") $ -#endif - AlexEOF - Just _ -> -#ifdef ALEX_DEBUG - trace ("Error.") $ -#endif - AlexError input__' - - (AlexLastSkip input__'' len, _) -> -#ifdef ALEX_DEBUG - trace ("Skipping.") $ -#endif - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> -#ifdef ALEX_DEBUG - trace ("Accept.") $ -#endif - AlexToken input__''' len (alex_actions ! k) - - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> -#ifdef ALEX_DEBUG - trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ -#endif - case fromIntegral c of { IBOX(ord_c) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = PLUS(base,ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,ILIT(0)) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - ILIT(-1) -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input -#ifdef ALEX_LATIN1 - PLUS(len,ILIT(1)) - -- issue 119: in the latin1 encoding, *each* byte is one character -#else - (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) -#endif - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) - check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) -#ifndef ALEX_NOPRED - check_accs (AlexAccPred a predx rest) - | predx user__ orig_input IBOX(len) input__ - = AlexLastAcc a input__ IBOX(len) - | otherwise - = check_accs rest - check_accs (AlexAccSkipPred predx rest) - | predx user__ orig_input IBOX(len) input__ - = AlexLastSkip input__ IBOX(len) - | otherwise - = check_accs rest -#endif - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip -#ifndef ALEX_NOPRED - | AlexAccPred Int (AlexAccPred user) (AlexAcc user) - | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) - -type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool - --- ----------------------------------------------------------------------------- --- Predicates on a rule - -alexAndPred p1 p2 user__ in1 len in2 - = p1 user__ in1 len in2 && p2 user__ in1 len in2 - ---alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ - -alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) - ---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ - ---alexRightContext :: Int -> AlexAccPred _ -alexRightContext IBOX(sc) user__ _ _ input__ = - case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of - (AlexNone, _) -> False - _ -> True - -- TODO: there's no need to find the longest - -- match when checking the right context, just - -- the first match will do. -#endif +{-# LINE 43 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer.x" #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnliftedNewtypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DataKinds #-} + + +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.Parser.Lexer ( + Token(..), lexer, lexerDbg, + ParserOpts(..), mkParserOpts, + PState (..), initParserState, initPragState, + P(..), ParseResult(POk, PFailed), + allocateComments, allocatePriorComments, allocateFinalComments, + MonadP(..), getBit, + getRealSrcLoc, getPState, + failMsgP, failLocMsgP, srcParseFail, + getPsErrorMessages, getPsMessages, + popContext, pushModuleContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, + getLexState, popLexState, pushLexState, + ExtBits(..), + xtest, xunset, xset, + disableHaddock, + lexTokenStream, + mkParensEpToks, + mkParensLocs, + getCommentsFor, getPriorCommentsFor, getFinalCommentsFor, + getEofPos, + commentToAnnotation, + HdkComment(..), + warnopt, + addPsMessage + ) where + +import GHC.Prelude +import qualified GHC.Data.Strict as Strict + +-- base +import Control.Monad +import Control.Applicative +import Data.Char +import Data.List (stripPrefix, isInfixOf, partition) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe +import Data.Word +import Debug.Trace (trace) + +import GHC.Data.EnumSet as EnumSet + +-- ghc-boot +import qualified GHC.LanguageExtensions as LangExt + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import Data.Map (Map) +import qualified Data.Map as Map + +-- compiler +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.StringBuffer +import GHC.Data.FastString +import GHC.Types.Error +import GHC.Types.Unique.FM +import GHC.Data.Maybe +import GHC.Data.OrdList +import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) + +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) +import GHC.Hs.Doc + +import GHC.Parser.CharClass + +import GHC.Parser.Annotation +import GHC.Driver.Flags +import GHC.Parser.Errors.Basic +import GHC.Parser.Errors.Types +import GHC.Parser.Errors.Ppr () +import GHC.Parser.Lexer.Interface +import qualified GHC.Parser.Lexer.String as Lexer.String +import GHC.Parser.String +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xf7\x00\x00\x00\x05\x01\x00\x00\x2f\x01\x00\x00\x4b\x01\x00\x00\x86\x01\x00\x00\x85\xff\xff\xff\xfe\x01\x00\x00\x3d\x02\x00\x00\x86\x02\x00\x00\xdf\xff\xff\xff\xad\x02\x00\x00\x0c\x03\x00\x00\x46\x03\x00\x00\xc2\xff\xff\xff\xc6\xff\xff\xff\xa0\x03\x00\x00\xc3\xff\xff\xff\x45\x00\x00\x00\x47\x00\x00\x00\xcb\xff\xff\xff\xca\xff\xff\xff\x41\x00\x00\x00\xc5\xff\xff\xff\xd8\xff\xff\xff\xc4\xff\xff\xff\x13\x01\x00\x00\x00\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x04\x00\x00\xa1\xff\xff\xff\x78\x00\x00\x00\x00\x00\x00\x00\xb8\x04\x00\x00\xf1\xff\xff\xff\xc3\x00\x00\x00\x32\x05\x00\x00\xac\x05\x00\x00\x08\x06\x00\x00\xf2\xff\xff\xff\xa3\xff\xff\xff\x00\x00\x00\x00\x48\x06\x00\x00\xc2\x06\x00\x00\x3b\x04\x00\x00\x56\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x17\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x3c\x07\x00\x00\xb6\x07\x00\x00\x64\x01\x00\x00\x2c\x08\x00\x00\x39\x01\x00\x00\x6c\x08\x00\x00\xea\x08\x00\x00\x97\x00\x00\x00\xa8\x00\x00\x00\x68\x09\x00\x00\x00\x02\x00\x00\xc2\x09\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x85\x01\x00\x00\x38\x0a\x00\x00\x0e\x02\x00\x00\x78\x0a\x00\x00\xf6\x0a\x00\x00\x74\x0b\x00\x00\xee\x0b\x00\x00\x68\x0c\x00\x00\xe2\x0c\x00\x00\x5c\x0d\x00\x00\xd6\x0d\x00\x00\x50\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x02\x00\x00\x1b\x02\x00\x00\x21\x08\x00\x00\x9d\x06\x00\x00\x17\x07\x00\x00\x9d\x02\x00\x00\x2d\x0a\x00\x00\x91\x07\x00\x00\x6a\x00\x00\x00\x11\x02\x00\x00\x7c\x00\x00\x00\xbc\x03\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x31\x00\x00\x00\x46\x00\x00\x00\x48\x00\x00\x00\x43\x00\x00\x00\x4d\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x63\x00\x00\x00\x51\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x49\x01\x00\x00\x97\x04\x00\x00\xa4\x0e\x00\x00\xfd\x03\x00\x00\x10\x05\x00\x00\xbb\x0e\x00\x00\x29\x0e\x00\x00\x35\x02\x00\x00\x6e\x01\x00\x00\x27\x0d\x00\x00\x9f\x00\x00\x00\x9c\x00\x00\x00\x9a\x00\x00\x00\x9e\x00\x00\x00\xc4\x00\x00\x00\xa5\x00\x00\x00\xa4\x00\x00\x00\x94\x00\x00\x00\xb4\x00\x00\x00\xb0\x00\x00\x00\x98\x00\x00\x00\xa1\x00\x00\x00\x07\x0f\x00\x00\x2f\x0f\x00\x00\x72\x0f\x00\x00\x9a\x0f\x00\x00\xd1\x00\x00\x00\xdd\x0f\x00\x00\x05\x10\x00\x00\xfb\x00\x00\x00\xfd\x00\x00\x00\xfe\x00\x00\x00\x09\x01\x00\x00\x0b\x01\x00\x00\x0c\x01\x00\x00\x19\x01\x00\x00\xbe\x00\x00\x00\x31\x01\x00\x00\xd4\x00\x00\x00\x35\x01\x00\x00\xe1\x00\x00\x00\xd8\x00\x00\x00\xc1\x01\x00\x00\xd5\x00\x00\x00\xde\x00\x00\x00\x54\x01\x00\x00\x10\x01\x00\x00\xb8\x02\x00\x00\x00\x00\x00\x00\x64\x10\x00\x00\x00\x00\x00\x00\x81\x02\x00\x00\xe2\x10\x00\x00\x5e\x11\x00\x00\x00\x00\x00\x00\xdc\x11\x00\x00\x5a\x12\x00\x00\xc7\x03\x00\x00\xeb\x00\x00\x00\xf6\x00\x00\x00\xf3\x00\x00\x00\x28\x01\x00\x00\xfa\x00\x00\x00\x06\x01\x00\x00\x2c\x01\x00\x00\x17\x01\x00\x00\x0f\x01\x00\x00\x18\x01\x00\x00\x2e\x01\x00\x00\x99\x12\x00\x00\xf1\x02\x00\x00\xbb\x10\x00\x00\xf4\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x13\x00\x00\x00\x00\x00\x00\x52\x01\x00\x00\x55\x01\x00\x00\x26\x01\x00\x00\x2a\x01\x00\x00\x49\x02\x00\x00\x36\x01\x00\x00\x6a\x01\x00\x00\x59\x02\x00\x00\x3d\x01\x00\x00\xf4\x01\x00\x00\x40\x01\x00\x00\xd5\x01\x00\x00\x00\x00\x00\x00\x89\x01\x00\x00\x00\x00\x00\x00\x8e\x01\x00\x00\xa3\x13\x00\x00\x00\x00\x00\x00\x8a\x01\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x00\x00\x9f\x01\x00\x00\x21\x14\x00\x00\x9b\x14\x00\x00\x15\x15\x00\x00\x8f\x15\x00\x00\x09\x16\x00\x00\x83\x16\x00\x00\xfd\x16\x00\x00\x77\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x17\x00\x00\x6b\x18\x00\x00\xe5\x18\x00\x00\x5f\x19\x00\x00\xd9\x19\x00\x00\x53\x1a\x00\x00\xcd\x1a\x00\x00\x47\x1b\x00\x00\x29\x06\x00\x00\x9f\x1b\x00\x00\x2f\x04\x00\x00\xe0\x1b\x00\x00\xa9\x04\x00\x00\xfa\x13\x00\x00\x21\x1c\x00\x00\x49\x09\x00\x00\x65\x1c\x00\x00\x23\x05\x00\x00\xa6\x1c\x00\x00\x87\x05\x00\x00\x74\x14\x00\x00\xe7\x1c\x00\x00\x55\x0b\x00\x00\x91\x05\x00\x00\x0a\x08\x00\x00\x18\x10\x00\x00\x16\x0a\x00\x00\xf0\x14\x00\x00\x3a\x06\x00\x00\xcf\x0b\x00\x00\xa7\x06\x00\x00\x46\x0c\x00\x00\xb6\x06\x00\x00\x2b\x1d\x00\x00\x6c\x1d\x00\x00\xc3\x0c\x00\x00\x0a\x06\x00\x00\x02\x02\x00\x00\xf6\x01\x00\x00\x85\x1d\x00\x00\xa6\x1d\x00\x00\x43\x01\x00\x00\x1f\x01\x00\x00\x5b\x01\x00\x00\x3e\x07\x00\x00\x76\x01\x00\x00\xef\x1d\x00\x00\x30\x1e\x00\x00\xb7\x0d\x00\x00\xc3\x09\x00\x00\x08\x03\x00\x00\x28\x02\x00\x00\x49\x1e\x00\x00\x6a\x1e\x00\x00\xad\x1e\x00\x00\xe2\x1e\x00\x00\x28\x1f\x00\x00\x4b\x1f\x00\x00\x6e\x1f\x00\x00\xe1\x01\x00\x00\xee\x01\x00\x00\xef\x01\x00\x00\xf5\x01\x00\x00\x07\x02\x00\x00\x0c\x02\x00\x00\xae\x1f\x00\x00\x28\x20\x00\x00\xa2\x20\x00\x00\x1c\x21\x00\x00\x96\x21\x00\x00\x10\x22\x00\x00\x8a\x22\x00\x00\x04\x23\x00\x00\x7e\x23\x00\x00\xf8\x23\x00\x00\x32\x24\x00\x00\xac\x24\x00\x00\x26\x25\x00\x00\xa0\x25\x00\x00\x1a\x26\x00\x00\x94\x26\x00\x00\x0e\x27\x00\x00\x88\x27\x00\x00\x02\x28\x00\x00\x7c\x28\x00\x00\xd2\x12\x00\x00\x82\x09\x00\x00\xf6\x28\x00\x00\x70\x29\x00\x00\xea\x29\x00\x00\x00\x00\x00\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x00\x00\x00\x00\x00\x00\x64\x2a\x00\x00\xe3\x01\x00\x00\xf2\x01\x00\x00\x90\x02\x00\x00\xf9\x01\x00\x00\x3c\x02\x00\x00\x83\x07\x00\x00\xfa\x01\x00\x00\x94\x02\x00\x00\x13\x02\x00\x00\x73\x02\x00\x00\xe2\x2a\x00\x00\x5c\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x2b\x00\x00\x00\x00\x00\x00\x52\x2c\x00\x00\x00\x00\x00\x00\xce\x2c\x00\x00\x00\x00\x00\x00\x4a\x2d\x00\x00\x00\x00\x00\x00\xc6\x2d\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x6e\x01\x2f\x01\x3c\x00\x55\x01\x26\x01\xaf\x00\x78\x00\x55\x01\x55\x01\xac\x00\x56\x00\xaf\x00\xaf\x00\xaf\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x59\x01\x55\x01\x24\x00\x2b\x00\x30\x00\x31\x00\xaf\x00\x26\x01\xd9\x00\x2d\x00\x26\x01\x26\x01\x26\x01\xb1\x00\x53\x01\x4f\x01\x26\x01\x26\x01\x4c\x01\x25\x01\x26\x01\x26\x01\x23\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x24\x01\x4b\x01\x26\x01\x26\x01\x26\x01\x16\x00\x26\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x25\x00\x26\x01\x4d\x01\x26\x01\x32\x01\x4a\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x2a\x00\x22\x00\x48\x01\x26\x01\xaf\x00\x7a\x00\x1b\x00\x36\x00\xac\x00\x77\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x7a\x00\x55\x01\x1a\x00\xac\x00\x37\x00\xaf\x00\xaf\x00\xaf\x00\x39\x00\x55\x01\x3b\x00\xff\xff\xff\xff\x1a\x01\x55\x01\x67\x00\x55\x01\x63\x00\x28\x00\x66\x00\x72\x00\x97\x00\x6a\x00\xff\xff\x28\x00\x6c\x00\xaf\x00\xaf\x00\x7a\x00\x6d\x00\x96\x00\xac\x00\x59\x00\xaf\x00\xaf\x00\xaf\x00\x70\x00\x6e\x00\x6f\x00\x96\x00\xff\xff\x71\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x68\x00\x75\x00\xaf\x00\xaf\x00\x7a\x00\x1b\x01\xa9\x00\xac\x00\x59\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x7a\x00\x74\x00\x96\x00\xac\x00\x59\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x7a\x00\x94\x00\x28\x00\xac\x00\x76\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xff\xff\xca\x00\x1b\x01\xca\x00\xca\x00\xca\x00\x27\x00\xca\x00\xaf\x00\x2c\x00\x28\x00\x1b\x01\x96\x00\x8c\x00\xc9\x00\xca\x00\x28\x00\xaf\x00\x3b\x00\xca\x00\xca\x00\x96\x00\xce\x00\x28\x00\x8d\x00\xaa\x00\xca\x00\xca\x00\xca\x00\xff\xff\x96\x00\xaf\x00\x7a\x00\x97\x00\xaa\x00\xac\x00\xb4\x00\xaf\x00\xaf\x00\xaf\x00\xff\xff\xca\x00\xff\xff\xff\xff\x73\x00\x46\x00\x79\x00\xca\x00\x6b\x00\x48\x00\xff\xff\x46\x00\x46\x00\x46\x00\xff\xff\x9b\x00\xff\xff\xff\xff\xaf\x00\x20\x00\xb4\x00\x9b\x00\x62\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x28\x00\xa5\x00\xb4\x00\x96\x00\x46\x00\xb4\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\xb4\x00\x44\x00\x20\x00\xaf\x00\x7a\x00\xbb\x00\x62\x00\xac\x00\xa5\x00\xaf\x00\xaf\x00\xaf\x00\x1a\x01\x40\x00\x28\x00\x62\x00\x57\x00\x40\x00\xb4\x00\x40\x00\x40\x00\x40\x00\xb4\x00\xb4\x00\xaa\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x9b\x00\xaf\x00\xaf\x00\x7a\x00\xb4\x00\xff\xff\xac\x00\xb4\x00\xaf\x00\xaf\x00\xaf\x00\x40\x00\xb4\x00\x41\x00\x96\x00\xb4\x00\xff\xff\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\xba\x00\xb4\x00\xaf\x00\x9b\x00\x9a\x00\x38\x00\x55\x01\xb4\x00\xbb\x00\xaa\x00\x9a\x00\x9f\x00\xc8\x00\xbb\x00\x45\x00\x3a\x00\xca\x00\xb4\x00\xca\x00\xc9\x00\xa2\x00\xb4\x00\xb4\x00\x43\x00\xca\x00\xca\x00\xca\x00\xb4\x00\xb4\x00\xb4\x00\x30\x01\x31\x01\xb6\x00\xbf\x00\xaf\x00\x7a\x00\x17\x01\xba\x00\xac\x00\x56\x00\xaf\x00\xaf\x00\xaf\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\xaf\x00\x9a\x00\x58\x00\x2f\x00\xaa\x00\xce\x00\xd5\x00\xda\x00\x50\x01\x4f\x01\xd7\x00\xd5\x00\x4c\x01\x96\x00\xdc\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x8c\x00\xde\x00\x4b\x01\xe0\x00\x3e\x00\x18\x01\x9a\x00\xaa\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x4e\x01\x19\x01\x4d\x01\x4a\x00\x31\x01\x4a\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x49\x01\x26\x01\x48\x01\x29\x01\x46\x00\xca\x00\xca\x00\xca\x00\xca\x00\xff\xff\x46\x00\x46\x00\x46\x00\xb4\x00\xa7\x00\xb8\x00\x2c\x01\x2a\x01\x4c\x00\xa0\x00\xc0\x00\xaf\x00\x4c\x00\x2c\x01\x4c\x00\x4c\x00\x4c\x00\xaf\x00\xaf\x00\xaf\x00\x26\x01\x46\x00\x26\x01\x26\x01\x26\x01\x26\x01\xf0\x00\x13\x01\x13\x01\x26\x01\x26\x01\x2d\x01\x26\x01\x26\x01\x26\x01\x4c\x00\x2e\x01\x4d\x00\xaf\x00\x13\x01\x13\x01\x64\x00\xab\x00\x55\x01\xd4\x00\x26\x01\x8c\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x55\x01\xd1\x00\x52\x01\x20\x00\x55\x01\x55\x01\x00\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x14\x01\x55\x01\x00\x00\x20\x01\x20\x01\x26\x01\x21\x00\x26\x01\x20\x00\x00\x00\x55\x01\x00\x00\x14\x01\x00\x00\x55\x01\x55\x01\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x59\x01\x1e\x00\x19\x00\x1c\x00\x5d\x01\x58\x01\x18\x00\x56\x01\x1d\x00\xaf\x00\x21\x01\x00\x00\x17\x00\x00\x00\x5a\x01\xaf\x00\xaf\x00\xaf\x00\x56\x01\x5b\x01\x1a\x00\x56\x01\x1d\x00\x83\x00\x00\x00\xca\x00\xcc\x00\x90\x00\x55\x01\x63\x01\x11\x00\xd3\x00\x86\x00\x55\x01\x55\x01\x00\x00\xaf\x00\xca\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x8a\x00\xca\x00\x00\x00\x55\x01\x10\x00\x91\x00\x87\x00\x55\x01\x00\x00\x55\x01\x8d\x00\x55\x01\x00\x00\x0f\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x5f\x01\x27\x00\x1a\x00\x00\x00\x29\x00\x28\x00\x55\x01\x57\x01\x1d\x00\x5c\x01\x00\x00\x28\x00\x5e\x01\x14\x00\x00\x00\x00\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x28\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\xf4\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x28\x00\x00\x00\x00\x00\x00\x00\x20\x01\x20\x01\x13\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x5a\x00\x12\x00\x65\x01\x00\x00\x00\x00\x00\x00\x0e\x01\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x21\x01\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x61\x01\x00\x00\x26\x01\x65\x01\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\xb5\x00\x26\x01\x26\x01\x26\x01\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x61\x01\x26\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x65\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\xb4\x00\xc9\x00\x62\x01\x26\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x00\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x7f\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x12\x00\x67\x01\x00\x00\x44\x01\x00\x00\x00\x00\x00\x00\x44\x01\x44\x01\x44\x01\x44\x01\x44\x01\x00\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x23\x00\x26\x01\x44\x01\x83\x00\x00\x00\x35\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x00\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x69\x00\x26\x01\x00\x00\x00\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x43\x01\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x6b\x01\xb0\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x6d\x01\x67\x01\x67\x01\x67\x01\x69\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x26\x00\x52\x00\x52\x00\x52\x00\x00\x00\x51\x00\xc9\x00\x52\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\xf8\x00\x00\x00\x51\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x50\x00\x50\x00\x50\x00\x00\x00\x4f\x00\x00\x00\x50\x00\x00\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x60\x01\x60\x01\x60\x01\x26\x01\x00\x00\xff\x00\x60\x01\xff\x00\x00\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x26\x01\x55\x01\x26\x01\x26\x01\x26\x01\x26\x01\x60\x01\x00\x00\x51\x01\x26\x01\x26\x01\x00\x00\x2e\x00\x26\x01\x26\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x26\x01\x00\x00\x26\x01\x60\x01\x26\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x33\x00\x33\x00\x33\x00\xdb\x00\x32\x00\x00\x00\x33\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\xf6\x00\x00\x00\x26\x01\x05\x01\x26\x01\x05\x01\x32\x00\x12\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x26\x01\x31\x00\x26\x01\x00\x00\x69\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0c\x01\x0e\x01\x0c\x01\x00\x00\x00\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x27\x00\x2c\x01\x00\x00\x54\x00\x28\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x28\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x28\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x00\x00\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x55\x01\x00\x00\x00\x00\x0a\x01\x1f\x00\x15\x00\x2c\x01\x00\x00\x00\x00\x1b\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x40\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x40\x00\x40\x00\x40\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x0e\x01\x00\x00\x00\x00\x06\x01\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x41\x00\x41\x00\x42\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x42\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x53\x00\x53\x00\x53\x00\xdd\x00\x45\x00\x00\x00\x53\x00\x00\x00\x45\x00\x54\x00\x45\x00\x45\x00\x45\x00\x00\x00\x00\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x01\x45\x00\x00\x00\x00\x00\x44\x01\x44\x01\x44\x01\x44\x01\x44\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x44\x01\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x65\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x37\x01\x3d\x01\x00\x00\x28\x01\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x28\x01\x00\x00\x00\x00\x00\x00\x28\x01\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x00\x00\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x00\x00\x27\x01\x00\x00\x28\x01\x28\x01\x28\x01\x28\x01\x28\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x00\x00\x28\x01\x00\x00\x28\x01\x3d\x01\x1f\x01\x3d\x01\x3d\x01\x3d\x01\x3e\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3f\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x4c\x00\x28\x01\x00\x00\x28\x01\x4c\x00\x00\x00\x4c\x00\x4c\x00\x4c\x00\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x00\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x0a\x01\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4d\x00\x4d\x00\x4e\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x00\x00\x4d\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x4d\x00\x4e\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x4d\x00\x50\x00\x50\x00\x50\x00\xdf\x00\x4f\x00\x00\x00\x50\x00\x00\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\xe1\x00\x32\x00\x00\x00\x50\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x52\x00\x52\x00\x52\x00\x00\x00\x51\x00\x00\x00\x52\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\xef\x00\x32\x00\x00\x00\x52\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x11\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\xff\xff\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x55\x00\x55\x00\x55\x00\xf3\x00\x54\x00\x00\x00\x55\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x1e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x01\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x81\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\x26\x01\x93\x00\x26\x01\x26\x01\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x26\x01\x00\x00\x93\x00\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x49\x00\x95\x00\x49\x00\x49\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x49\x00\x26\x01\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x49\x00\x00\x00\x95\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x49\x00\x49\x00\x49\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x98\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x98\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x00\x00\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xae\x00\xae\x00\xae\x00\xae\x00\x00\x00\xae\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\x00\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x0c\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xb2\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xc7\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb3\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xd6\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xc4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb3\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xd6\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xc4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb5\x00\xc5\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x43\x01\x00\x00\x00\x00\x00\x00\xb7\x00\xbc\x00\xb9\x00\xa1\x00\xa6\x00\xbd\x00\xa8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xa4\x00\xc6\x00\x00\x00\x00\x00\xa8\x00\xa3\x00\x00\x00\xa8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xc1\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\xb4\x00\xc2\x00\xca\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\x00\x00\xc3\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x7d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x8b\x00\x8e\x00\xd2\x00\xcd\x00\x89\x00\xcb\x00\x90\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcb\x00\xd0\x00\x00\x00\xcb\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x85\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb3\x00\xb4\x00\xca\x00\x84\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\x00\x00\xca\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xd8\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xc4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x07\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x09\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x01\x00\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xfe\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\xfb\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x5f\x00\x00\x00\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x0a\x01\x10\x01\x00\x00\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x0f\x01\x00\x00\x5f\x00\x00\x00\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x14\x01\x00\x00\x0a\x01\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x14\x01\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x5b\x00\x00\x00\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x0e\x01\x1d\x01\x00\x00\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x1c\x01\x00\x00\x5b\x00\x00\x00\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x21\x01\x00\x00\x0e\x01\x0e\x01\x00\x00\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x21\x01\x00\x00\x24\x01\x0e\x01\x24\x01\x24\x01\x24\x01\x24\x01\x00\x00\x00\x00\x00\x00\x24\x01\x24\x01\x1f\x01\x24\x01\x24\x01\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x01\x00\x00\x00\x00\x00\x00\x26\x01\x24\x01\x00\x00\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x24\x01\x00\x00\x24\x01\x26\x01\x26\x01\x00\x00\x92\x00\x26\x01\x26\x01\x16\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x15\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x01\x00\x00\x24\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x27\x01\x00\x00\x00\x00\x26\x01\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x26\x01\x00\x00\x26\x01\x26\x01\x26\x01\x26\x01\x26\x01\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x27\x01\x27\x01\x27\x01\x27\x01\x28\x01\x00\x00\x00\x00\x27\x01\x27\x01\x00\x00\x27\x01\x27\x01\x27\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x27\x01\x26\x01\x27\x01\x27\x01\x27\x01\x27\x01\x27\x01\x00\x00\x00\x00\x00\x00\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x28\x01\x00\x00\x00\x00\x00\x00\x28\x01\x28\x01\x00\x00\x28\x01\x28\x01\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x01\x00\x00\x26\x01\x27\x01\x28\x01\x27\x01\x28\x01\x28\x01\x28\x01\x28\x01\x28\x01\x2f\x01\x2f\x01\x2f\x01\x00\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x01\x00\x00\x27\x01\x28\x01\x00\x00\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x29\x01\x00\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x00\x00\x00\x00\x28\x01\x00\x00\x28\x01\x00\x00\x00\x00\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x30\x01\x30\x01\x30\x01\x00\x00\x00\x00\x00\x00\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\x00\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x30\x01\x00\x00\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x30\x01\x31\x01\x31\x01\x31\x01\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x31\x01\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x01\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x01\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x36\x01\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x01\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x0c\x01\x00\x00\x00\x00\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x33\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x37\x01\x37\x01\x37\x01\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x01\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x37\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x01\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x38\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x38\x01\x00\x00\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x38\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3b\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3c\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x46\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x41\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x47\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x45\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x40\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x42\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3a\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x01\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x01\x00\x00\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x3d\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x55\x01\x54\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x0e\x00\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x55\x01\x60\x01\x60\x01\x60\x01\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x00\x00\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x60\x01\x61\x01\x61\x01\x61\x01\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x61\x01\x65\x01\x65\x01\x65\x01\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x00\x00\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x65\x01\x00\x00\x64\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x66\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x68\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x6a\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x67\x01\x00\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x7c\x00\x01\x00\x02\x00\x42\x00\x04\x00\x05\x00\x06\x00\x42\x00\x46\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x4c\x00\x4e\x00\x54\x00\x58\x00\x43\x00\x58\x00\x7c\x00\x2d\x00\x2d\x00\x7d\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x06\x00\x41\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x46\x00\x45\x00\x09\x00\x7d\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x52\x00\x7d\x00\x0a\x00\x0a\x00\x2d\x00\x53\x00\x0a\x00\x53\x00\x20\x00\x24\x00\x21\x00\x23\x00\x2d\x00\x0a\x00\x0a\x00\x2a\x00\x72\x00\x20\x00\x05\x00\x06\x00\x61\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x61\x00\x67\x00\x6d\x00\x2d\x00\x0a\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x21\x00\x6e\x00\x20\x00\x05\x00\x06\x00\x23\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x69\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x2d\x00\x5e\x00\x09\x00\x65\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x0a\x00\x42\x00\x23\x00\x46\x00\x42\x00\x4e\x00\x20\x00\x46\x00\x20\x00\x23\x00\x24\x00\x23\x00\x2d\x00\x45\x00\x27\x00\x54\x00\x2a\x00\x20\x00\x7d\x00\x4c\x00\x53\x00\x2d\x00\x43\x00\x7c\x00\x41\x00\x7b\x00\x58\x00\x53\x00\x58\x00\x0a\x00\x2d\x00\x05\x00\x06\x00\x2d\x00\x7b\x00\x09\x00\x43\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x52\x00\x0a\x00\x0a\x00\x6c\x00\x05\x00\x06\x00\x48\x00\x70\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x24\x00\x0a\x00\x0a\x00\x20\x00\x05\x00\x45\x00\x2a\x00\x7b\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x5e\x00\x41\x00\x4b\x00\x2d\x00\x20\x00\x51\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x53\x00\x2d\x00\x20\x00\x05\x00\x06\x00\x55\x00\x7b\x00\x09\x00\x43\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x05\x00\x7c\x00\x7b\x00\x7c\x00\x09\x00\x58\x00\x0b\x00\x0c\x00\x0d\x00\x54\x00\x4e\x00\x7b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x5e\x00\x20\x00\x05\x00\x06\x00\x4c\x00\x0a\x00\x09\x00\x46\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x42\x00\x22\x00\x2d\x00\x46\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x41\x00\x53\x00\x20\x00\x7c\x00\x24\x00\x23\x00\x5c\x00\x42\x00\x45\x00\x7b\x00\x2a\x00\x43\x00\x23\x00\x45\x00\x23\x00\x2d\x00\x53\x00\x52\x00\x51\x00\x27\x00\x4c\x00\x49\x00\x53\x00\x7b\x00\x4b\x00\x45\x00\x43\x00\x4f\x00\x50\x00\x58\x00\x01\x00\x02\x00\x54\x00\x55\x00\x05\x00\x06\x00\x6e\x00\x59\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\x5e\x00\x65\x00\x23\x00\x7b\x00\x41\x00\x23\x00\x23\x00\x28\x00\x29\x00\x22\x00\x23\x00\x2c\x00\x2d\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x55\x00\x23\x00\x3b\x00\x23\x00\x5f\x00\x69\x00\x7c\x00\x7b\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x6c\x00\x5d\x00\x5f\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x04\x00\x7d\x00\x23\x00\x05\x00\x31\x00\x32\x00\x33\x00\x34\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x4d\x00\x4e\x00\x4f\x00\x23\x00\x23\x00\x05\x00\x53\x00\x54\x00\x05\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x21\x00\x20\x00\x23\x00\x24\x00\x25\x00\x26\x00\x23\x00\x30\x00\x31\x00\x2a\x00\x2b\x00\x23\x00\x2d\x00\x2e\x00\x2f\x00\x20\x00\x23\x00\x22\x00\x20\x00\x30\x00\x31\x00\x23\x00\x2d\x00\x53\x00\x43\x00\x3a\x00\x45\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x45\x00\x4c\x00\x23\x00\x05\x00\x51\x00\x4b\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\x43\x00\xff\xff\x30\x00\x31\x00\x5c\x00\x5d\x00\x5e\x00\x20\x00\xff\xff\x22\x00\xff\xff\x5f\x00\xff\xff\x26\x00\x27\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x41\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x05\x00\x5f\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\x0b\x00\x0c\x00\x0d\x00\x52\x00\x53\x00\x55\x00\x55\x00\x56\x00\x5f\x00\xff\xff\x4d\x00\x4e\x00\x4f\x00\x5c\x00\x7c\x00\x5e\x00\x53\x00\x54\x00\x61\x00\x62\x00\xff\xff\x20\x00\x49\x00\x66\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4f\x00\x50\x00\xff\xff\x6e\x00\x6f\x00\x54\x00\x55\x00\x72\x00\xff\xff\x74\x00\x59\x00\x76\x00\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x43\x00\x20\x00\x45\x00\xff\xff\x23\x00\x24\x00\x4d\x00\x4e\x00\x4f\x00\x4c\x00\xff\xff\x2a\x00\x53\x00\x54\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x5e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\x23\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5f\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x05\x00\x2d\x00\x2e\x00\x2f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x5f\x00\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\x27\x00\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\x20\x00\x5f\x00\xff\xff\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x5f\x00\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x27\x00\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x2b\x00\x07\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x5c\x00\x2b\x00\x5e\x00\x2d\x00\x20\x00\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2b\x00\x45\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\x20\x00\x23\x00\xff\xff\x23\x00\x24\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\x45\x00\x54\x00\x55\x00\x23\x00\xff\xff\xff\xff\x59\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\x20\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x5f\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\x7c\x00\xff\xff\x7e\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x45\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x05\x00\x06\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\x06\x00\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\x6e\x00\x6f\x00\x27\x00\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x45\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\x65\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\x45\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\x65\x00\x45\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\x21\x00\x65\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x6f\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\x04\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\xff\xff\x5e\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x49\x00\x49\x00\x49\x00\xff\xff\x49\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\x9e\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9d\x00\x99\x00\x9d\x00\x99\x00\xff\xff\x9d\x00\x99\x00\x99\x00\x9c\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 366) + [ AlexAccNone + , AlexAcc 210 + , AlexAccNone + , AlexAcc 209 + , AlexAcc 208 + , AlexAcc 207 + , AlexAcc 206 + , AlexAcc 205 + , AlexAcc 204 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 203 (ifExtension ThQuotesBit)(AlexAccPred 202 (ifExtension QqBit)(AlexAccNone)) + , AlexAcc 201 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 200 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 199 + , AlexAcc 198 + , AlexAcc 197 + , AlexAcc 196 + , AlexAcc 195 + , AlexAcc 194 + , AlexAccNone + , AlexAccPred 193 (ifExtension HaddockBit)(AlexAccNone) + , AlexAcc 192 + , AlexAcc 191 + , AlexAccPred 190 (isNormalComment)(AlexAccNone) + , AlexAcc 189 + , AlexAcc 188 + , AlexAcc 187 + , AlexAccNone + , AlexAccNone + , AlexAcc 186 + , AlexAccNone + , AlexAccPred 185 (known_pragma twoWordPrags)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 184 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 183 + , AlexAcc 182 + , AlexAcc 181 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 180 + , AlexAcc 179 + , AlexAcc 178 + , AlexAcc 177 + , AlexAccSkip + , AlexAccNone + , AlexAcc 176 + , AlexAcc 175 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 174 + , AlexAccNone + , AlexAccPred 173 (known_pragma linePrags)(AlexAccPred 172 (known_pragma oneWordPrags)(AlexAccPred 171 (known_pragma ignoredPrags)(AlexAccPred 170 (known_pragma fileHeaderPrags)(AlexAcc 169)))) + , AlexAccNone + , AlexAccPred 168 (known_pragma linePrags)(AlexAccPred 167 (known_pragma oneWordPrags)(AlexAccPred 166 (known_pragma ignoredPrags)(AlexAccPred 165 (known_pragma fileHeaderPrags)(AlexAcc 164)))) + , AlexAccPred 163 (known_pragma linePrags)(AlexAcc 162) + , AlexAccNone + , AlexAccPred 161 (known_pragma linePrags)(AlexAccNone) + , AlexAcc 160 + , AlexAccPred 159 (notFollowedBySymbol)(AlexAccNone) + , AlexAccPred 158 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkip + , AlexAccNone + , AlexAccNone + , AlexAcc 157 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 156 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccPred 155 (notFollowedBy '-')(AlexAccNone) + , AlexAccSkip + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccPred 154 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 153 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkip + , AlexAccPred 152 (isSmartQuote)(AlexAccPred 151 (ifCurrentChar '⟦' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit)(AlexAccPred 150 (ifCurrentChar '⟧' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit)(AlexAccPred 149 (ifCurrentChar '⦇' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit)(AlexAccPred 148 (ifCurrentChar '⦈' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit)(AlexAccNone))))) + , AlexAccPred 147 (isSmartQuote)(AlexAcc 146) + , AlexAccPred 145 (isSmartQuote)(AlexAccNone) + , AlexAccPred 144 (atEOL)(AlexAcc 143) + , AlexAccPred 142 (atEOL)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 141 (atEOL)(AlexAcc 140) + , AlexAccPred 139 (atEOL)(AlexAcc 138) + , AlexAccPred 137 (atEOL)(AlexAcc 136) + , AlexAccPred 135 (atEOL)(AlexAcc 134) + , AlexAccNone + , AlexAccPred 133 (atEOL)(AlexAccNone) + , AlexAccPred 132 (atEOL)(AlexAccNone) + , AlexAcc 131 + , AlexAccPred 130 (alexNotPred (ifExtension HaddockBit))(AlexAccPred 129 (ifExtension HaddockBit)(AlexAccNone)) + , AlexAccPred 128 (alexNotPred (ifExtension HaddockBit))(AlexAcc 127) + , AlexAccPred 126 (alexNotPred (ifExtension HaddockBit))(AlexAccNone) + , AlexAcc 125 + , AlexAcc 124 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 123 (isNormalComment)(AlexAcc 122) + , AlexAccNone + , AlexAccPred 121 (isNormalComment)(AlexAccNone) + , AlexAcc 120 + , AlexAccNone + , AlexAccSkip + , AlexAccSkip + , AlexAccNone + , AlexAccPred 119 (alexRightContext 173)(AlexAccNone) + , AlexAcc 118 + , AlexAccPred 117 (isSmartQuote)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 116 (isSmartQuote)(AlexAccNone) + , AlexAccPred 115 (isSmartQuote)(AlexAccNone) + , AlexAccNone + , AlexAccPred 114 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAcc 113 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 112 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAcc 111 + , AlexAccPred 110 (ifExtension MultilineStringsBit)(AlexAccNone) + , AlexAcc 109 + , AlexAccNone + , AlexAccPred 108 (ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 107 (ifExtension HexFloatLiteralsBit `alexAndPred` negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 106 (ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccPred 105 (ifExtension MagicHashBit `alexAndPred` ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccPred 104 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 103 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 102 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 101 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 100 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 99 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 98 (negHashLitPred ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 97 (negHashLitPred ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 96 (ifExtension ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 95 (ifExtension ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 94 (ifExtension ExtendedLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 93 (ifExtension ExtendedLiteralsBit)(AlexAccNone) + , AlexAccPred 92 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 91 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 90 (ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 89 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 88 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 87 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 86 (negHashLitPred MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 85 (negHashLitPred MagicHashBit)(AlexAccNone) + , AlexAccPred 84 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 83 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 82 (ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccPred 81 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 80 (ifExtension HexFloatLiteralsBit `alexAndPred` + negLitPred)(AlexAccNone) + , AlexAccPred 79 (ifExtension HexFloatLiteralsBit `alexAndPred` + negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 78 (ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccPred 77 (ifExtension HexFloatLiteralsBit)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 76 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 75 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 74 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccPred 73 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccPred 72 (negLitPred `alexAndPred` + ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccNone + , AlexAccPred 71 (negLitPred)(AlexAccNone) + , AlexAccPred 70 (negLitPred)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 69 (isNormalComment)(AlexAccNone) + , AlexAccPred 68 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAcc 67 + , AlexAccNone + , AlexAcc 66 + , AlexAccNone + , AlexAccPred 65 (ifExtension BinaryLiteralsBit)(AlexAccNone) + , AlexAccNone + , AlexAcc 64 + , AlexAcc 63 + , AlexAcc 62 + , AlexAcc 61 + , AlexAcc 60 + , AlexAcc 59 + , AlexAcc 58 + , AlexAccPred 57 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 56 (ifExtension MagicHashBit)(AlexAccPred 55 (ifExtension MagicHashBit)(AlexAccNone)) + , AlexAccPred 54 (ifExtension MagicHashBit)(AlexAccPred 53 (ifExtension MagicHashBit)(AlexAccNone)) + , AlexAccPred 52 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 51 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAccPred 50 (ifExtension MagicHashBit)(AlexAccNone) + , AlexAcc 49 + , AlexAcc 48 + , AlexAcc 47 + , AlexAcc 46 + , AlexAcc 45 + , AlexAcc 44 + , AlexAcc 43 + , AlexAcc 42 + , AlexAcc 41 + , AlexAcc 40 + , AlexAccNone + , AlexAcc 39 + , AlexAcc 38 + , AlexAcc 37 + , AlexAcc 36 + , AlexAcc 35 + , AlexAcc 34 + , AlexAccPred 33 (ifExtension RecursiveDoBit)(AlexAcc 32) + , AlexAcc 31 + , AlexAccPred 30 (ifExtension RecursiveDoBit)(AlexAcc 29) + , AlexAccNone + , AlexAccNone + , AlexAcc 28 + , AlexAcc 27 + , AlexAcc 26 + , AlexAcc 25 + , AlexAcc 24 + , AlexAcc 23 + , AlexAcc 22 + , AlexAcc 21 + , AlexAcc 20 + , AlexAcc 19 + , AlexAcc 18 + , AlexAcc 17 + , AlexAccPred 16 (ifExtension UnboxedParensBit)(AlexAccNone) + , AlexAccPred 15 (ifExtension UnboxedParensBit)(AlexAccNone) + , AlexAcc 14 + , AlexAccPred 13 (ifExtension OverloadedLabelsBit)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccPred 12 (ifExtension OverloadedLabelsBit)(AlexAccNone) + , AlexAccPred 11 (ifExtension IpBit)(AlexAccNone) + , AlexAccPred 10 (ifExtension ArrowsBit)(AlexAccNone) + , AlexAccPred 9 (ifExtension ArrowsBit `alexAndPred` + notFollowedBySymbol)(AlexAccNone) + , AlexAccPred 8 (ifExtension QqBit)(AlexAccNone) + , AlexAccNone + , AlexAccPred 7 (ifExtension QqBit)(AlexAccNone) + , AlexAccNone + , AlexAccPred 6 (ifExtension ThQuotesBit)(AlexAccPred 5 (ifExtension QqBit)(AlexAccNone)) + , AlexAccNone + , AlexAccPred 4 (ifExtension ThQuotesBit)(AlexAccPred 3 (ifExtension QqBit)(AlexAccNone)) + , AlexAccNone + , AlexAccPred 2 (ifExtension ThQuotesBit)(AlexAccPred 1 (ifExtension QqBit)(AlexAccNone)) + , AlexAccNone + , AlexAccPred 0 (ifExtension ThQuotesBit)(AlexAccNone) + ] + +alex_actions = array (0 :: Int, 211) + [ (210,alex_action_16) + , (209,alex_action_22) + , (208,alex_action_23) + , (207,alex_action_21) + , (206,alex_action_24) + , (205,alex_action_28) + , (204,alex_action_29) + , (203,alex_action_47) + , (202,alex_action_52) + , (201,alex_action_86) + , (200,alex_action_86) + , (199,alex_action_46) + , (198,alex_action_86) + , (197,alex_action_45) + , (196,alex_action_44) + , (195,alex_action_67) + , (194,alex_action_43) + , (193,alex_action_42) + , (192,alex_action_40) + , (191,alex_action_72) + , (190,alex_action_2) + , (189,alex_action_40) + , (188,alex_action_86) + , (187,alex_action_86) + , (186,alex_action_36) + , (185,alex_action_33) + , (184,alex_action_32) + , (183,alex_action_31) + , (182,alex_action_78) + , (181,alex_action_78) + , (180,alex_action_30) + , (179,alex_action_29) + , (178,alex_action_29) + , (177,alex_action_29) + , (176,alex_action_1) + , (175,alex_action_29) + , (174,alex_action_27) + , (173,alex_action_26) + , (172,alex_action_34) + , (171,alex_action_35) + , (170,alex_action_38) + , (169,alex_action_39) + , (168,alex_action_26) + , (167,alex_action_34) + , (166,alex_action_35) + , (165,alex_action_37) + , (164,alex_action_39) + , (163,alex_action_26) + , (162,alex_action_29) + , (161,alex_action_26) + , (160,alex_action_25) + , (159,alex_action_20) + , (158,alex_action_19) + , (157,alex_action_96) + , (156,alex_action_97) + , (155,alex_action_17) + , (154,alex_action_12) + , (153,alex_action_11) + , (152,alex_action_9) + , (151,alex_action_54) + , (150,alex_action_55) + , (149,alex_action_58) + , (148,alex_action_59) + , (147,alex_action_9) + , (146,alex_action_29) + , (145,alex_action_9) + , (144,alex_action_8) + , (143,alex_action_29) + , (142,alex_action_8) + , (141,alex_action_7) + , (140,alex_action_86) + , (139,alex_action_7) + , (138,alex_action_86) + , (137,alex_action_7) + , (136,alex_action_29) + , (135,alex_action_7) + , (134,alex_action_29) + , (133,alex_action_7) + , (132,alex_action_7) + , (131,alex_action_6) + , (130,alex_action_5) + , (129,alex_action_41) + , (128,alex_action_5) + , (127,alex_action_29) + , (126,alex_action_5) + , (125,alex_action_4) + , (124,alex_action_3) + , (123,alex_action_2) + , (122,alex_action_29) + , (121,alex_action_2) + , (120,alex_action_1) + , (119,alex_action_137) + , (118,alex_action_136) + , (117,alex_action_135) + , (116,alex_action_134) + , (115,alex_action_133) + , (114,alex_action_132) + , (113,alex_action_131) + , (112,alex_action_130) + , (111,alex_action_129) + , (110,alex_action_128) + , (109,alex_action_129) + , (108,alex_action_127) + , (107,alex_action_126) + , (106,alex_action_125) + , (105,alex_action_124) + , (104,alex_action_123) + , (103,alex_action_122) + , (102,alex_action_121) + , (101,alex_action_120) + , (100,alex_action_119) + , (99,alex_action_118) + , (98,alex_action_117) + , (97,alex_action_116) + , (96,alex_action_115) + , (95,alex_action_114) + , (94,alex_action_113) + , (93,alex_action_112) + , (92,alex_action_111) + , (91,alex_action_110) + , (90,alex_action_109) + , (89,alex_action_108) + , (88,alex_action_107) + , (87,alex_action_106) + , (86,alex_action_105) + , (85,alex_action_104) + , (84,alex_action_103) + , (83,alex_action_102) + , (82,alex_action_101) + , (81,alex_action_100) + , (80,alex_action_99) + , (79,alex_action_99) + , (78,alex_action_98) + , (77,alex_action_98) + , (76,alex_action_97) + , (75,alex_action_96) + , (74,alex_action_95) + , (73,alex_action_94) + , (72,alex_action_93) + , (71,alex_action_92) + , (70,alex_action_92) + , (69,alex_action_2) + , (68,alex_action_19) + , (67,alex_action_91) + , (66,alex_action_90) + , (65,alex_action_89) + , (64,alex_action_88) + , (63,alex_action_88) + , (62,alex_action_87) + , (61,alex_action_86) + , (60,alex_action_86) + , (59,alex_action_85) + , (58,alex_action_84) + , (57,alex_action_83) + , (56,alex_action_82) + , (55,alex_action_121) + , (54,alex_action_82) + , (53,alex_action_120) + , (52,alex_action_82) + , (51,alex_action_81) + , (50,alex_action_80) + , (49,alex_action_79) + , (48,alex_action_79) + , (47,alex_action_78) + , (46,alex_action_78) + , (45,alex_action_78) + , (44,alex_action_78) + , (43,alex_action_78) + , (42,alex_action_78) + , (41,alex_action_77) + , (40,alex_action_77) + , (39,alex_action_76) + , (38,alex_action_76) + , (37,alex_action_76) + , (36,alex_action_76) + , (35,alex_action_76) + , (34,alex_action_76) + , (33,alex_action_75) + , (32,alex_action_76) + , (31,alex_action_76) + , (30,alex_action_75) + , (29,alex_action_76) + , (28,alex_action_76) + , (27,alex_action_74) + , (26,alex_action_74) + , (25,alex_action_73) + , (24,alex_action_72) + , (23,alex_action_71) + , (22,alex_action_70) + , (21,alex_action_69) + , (20,alex_action_68) + , (19,alex_action_67) + , (18,alex_action_66) + , (17,alex_action_65) + , (16,alex_action_64) + , (15,alex_action_63) + , (14,alex_action_65) + , (13,alex_action_62) + , (12,alex_action_61) + , (11,alex_action_60) + , (10,alex_action_57) + , (9,alex_action_56) + , (8,alex_action_53) + , (7,alex_action_52) + , (6,alex_action_51) + , (5,alex_action_52) + , (4,alex_action_50) + , (3,alex_action_52) + , (2,alex_action_49) + , (1,alex_action_52) + , (0,alex_action_48) + ] + + +bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag2,line_prag2a,option_prags :: Int +bol = 1 +column_prag = 2 +layout = 3 +layout_do = 4 +layout_if = 5 +layout_left = 6 +line_prag1 = 7 +line_prag1a = 8 +line_prag2 = 9 +line_prag2a = 10 +option_prags = 11 +alex_action_1 = warnTab +alex_action_2 = nested_comment +alex_action_3 = lineCommentToken +alex_action_4 = lineCommentToken +alex_action_5 = lineCommentToken +alex_action_6 = lineCommentToken +alex_action_7 = lineCommentToken +alex_action_8 = lineCommentToken +alex_action_9 = smart_quote_error +alex_action_11 = begin line_prag1 +alex_action_12 = begin line_prag1 +alex_action_16 = do_bol +alex_action_17 = hopefully_open_brace +alex_action_19 = begin line_prag1 +alex_action_20 = new_layout_context True dontGenerateSemic ITvbar +alex_action_21 = pop +alex_action_22 = new_layout_context True generateSemic ITvocurly +alex_action_23 = new_layout_context False generateSemic ITvocurly +alex_action_24 = do_layout_left +alex_action_25 = begin bol +alex_action_26 = dispatch_pragmas linePrags +alex_action_27 = setLineAndFile line_prag1a +alex_action_28 = failLinePrag1 +alex_action_29 = popLinePrag1 +alex_action_30 = setLineAndFile line_prag2a +alex_action_31 = pop +alex_action_32 = setColumn +alex_action_33 = dispatch_pragmas twoWordPrags +alex_action_34 = dispatch_pragmas oneWordPrags +alex_action_35 = dispatch_pragmas ignoredPrags +alex_action_36 = endPrag +alex_action_37 = dispatch_pragmas fileHeaderPrags +alex_action_38 = nested_comment +alex_action_39 = warn_unknown_prag (Map.unions [ oneWordPrags, fileHeaderPrags, ignoredPrags, linePrags ]) +alex_action_40 = warn_unknown_prag Map.empty +alex_action_41 = multiline_doc_comment +alex_action_42 = nested_doc_comment +alex_action_43 = token (ITopenExpQuote NoE NormalSyntax) +alex_action_44 = token (ITopenTExpQuote NoE) +alex_action_45 = token (ITcloseQuote NormalSyntax) +alex_action_46 = token ITcloseTExpQuote +alex_action_47 = token (ITopenExpQuote HasE NormalSyntax) +alex_action_48 = token (ITopenTExpQuote HasE) +alex_action_49 = token ITopenPatQuote +alex_action_50 = layout_token ITopenDecQuote +alex_action_51 = token ITopenTypQuote +alex_action_52 = lex_quasiquote_tok +alex_action_53 = lex_qquasiquote_tok +alex_action_54 = token (ITopenExpQuote NoE UnicodeSyntax) +alex_action_55 = token (ITcloseQuote UnicodeSyntax) +alex_action_56 = special (IToparenbar NormalSyntax) +alex_action_57 = special (ITcparenbar NormalSyntax) +alex_action_58 = special (IToparenbar UnicodeSyntax) +alex_action_59 = special (ITcparenbar UnicodeSyntax) +alex_action_60 = skip_one_varid ITdupipvarid +alex_action_61 = skip_one_varid_src ITlabelvarid +alex_action_62 = tok_quoted_label +alex_action_63 = token IToubxparen +alex_action_64 = token ITcubxparen +alex_action_65 = special IToparen +alex_action_66 = special ITcparen +alex_action_67 = special ITobrack +alex_action_68 = special ITcbrack +alex_action_69 = special ITcomma +alex_action_70 = special ITsemi +alex_action_71 = special ITbackquote +alex_action_72 = open_brace +alex_action_73 = close_brace +alex_action_74 = qdo_token ITdo +alex_action_75 = qdo_token ITmdo +alex_action_76 = idtoken qvarid +alex_action_77 = idtoken qconid +alex_action_78 = varid +alex_action_79 = idtoken conid +alex_action_80 = idtoken qvarid +alex_action_81 = idtoken qconid +alex_action_82 = varid +alex_action_83 = idtoken conid +alex_action_84 = idtoken qvarsym +alex_action_85 = idtoken qconsym +alex_action_86 = with_op_ws varsym +alex_action_87 = with_op_ws consym +alex_action_88 = tok_num positive 0 0 decimal +alex_action_89 = tok_num positive 2 2 binary +alex_action_90 = tok_num positive 2 2 octal +alex_action_91 = tok_num positive 2 2 hexadecimal +alex_action_92 = tok_num negative 1 1 decimal +alex_action_93 = tok_num negative 3 3 binary +alex_action_94 = tok_num negative 3 3 octal +alex_action_95 = tok_num negative 3 3 hexadecimal +alex_action_96 = tok_frac 0 tok_float +alex_action_97 = tok_frac 0 tok_float +alex_action_98 = tok_frac 0 tok_hex_float +alex_action_99 = tok_frac 0 tok_hex_float +alex_action_100 = tok_primint positive 0 1 decimal +alex_action_101 = tok_primint positive 2 3 binary +alex_action_102 = tok_primint positive 2 3 octal +alex_action_103 = tok_primint positive 2 3 hexadecimal +alex_action_104 = tok_primint negative 1 2 decimal +alex_action_105 = tok_primint negative 3 4 binary +alex_action_106 = tok_primint negative 3 4 octal +alex_action_107 = tok_primint negative 3 4 hexadecimal +alex_action_108 = tok_primword 0 2 decimal +alex_action_109 = tok_primword 2 4 binary +alex_action_110 = tok_primword 2 4 octal +alex_action_111 = tok_primword 2 4 hexadecimal +alex_action_112 = tok_prim_num_ext positive 0 decimal +alex_action_113 = tok_prim_num_ext positive 2 binary +alex_action_114 = tok_prim_num_ext positive 2 octal +alex_action_115 = tok_prim_num_ext positive 2 hexadecimal +alex_action_116 = tok_prim_num_ext negative 1 decimal +alex_action_117 = tok_prim_num_ext negative 3 binary +alex_action_118 = tok_prim_num_ext negative 3 octal +alex_action_119 = tok_prim_num_ext negative 3 hexadecimal +alex_action_120 = tok_frac 1 tok_primfloat +alex_action_121 = tok_frac 2 tok_primdouble +alex_action_122 = tok_frac 1 tok_primfloat +alex_action_123 = tok_frac 2 tok_primdouble +alex_action_124 = tok_frac 1 tok_prim_hex_float +alex_action_125 = tok_frac 2 tok_prim_hex_double +alex_action_126 = tok_frac 1 tok_prim_hex_float +alex_action_127 = tok_frac 2 tok_prim_hex_double +alex_action_128 = tok_string_multi +alex_action_129 = tok_string +alex_action_130 = tok_string +alex_action_131 = tok_char +alex_action_132 = tok_char +alex_action_133 = smart_quote_error +alex_action_134 = smart_quote_error +alex_action_135 = smart_quote_error +alex_action_136 = token ITtyQuote +alex_action_137 = token ITsimpleQuote + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 762 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer.x" #-} +-- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. +data OpWs + = OpWsPrefix -- a !b + | OpWsSuffix -- a! b + | OpWsTightInfix -- a!b + | OpWsLooseInfix -- a ! b + deriving Show + +-- ----------------------------------------------------------------------------- +-- The token type + +data Token + = ITas -- Haskell keywords + | ITcase + | ITclass + | ITdata + | ITdefault + | ITderiving + | ITdo (Maybe FastString) + | ITelse + | IThiding + | ITforeign + | ITif + | ITimport + | ITin + | ITinfix + | ITinfixl + | ITinfixr + | ITinstance + | ITlet + | ITmodule + | ITnewtype + | ITof + | ITqualified + | ITthen + | ITtype + | ITwhere + + | ITforall IsUnicodeSyntax -- GHC extension keywords + | ITexport + | ITlabel + | ITdynamic + | ITsafe + | ITinterruptible + | ITunsafe + | ITstdcallconv + | ITccallconv + | ITcapiconv + | ITprimcallconv + | ITjavascriptcallconv + | ITmdo (Maybe FastString) + | ITfamily + | ITrole + | ITgroup + | ITby + | ITusing + | ITpattern + | ITstatic + | ITstock + | ITanyclass + | ITvia + + -- Backpack tokens + | ITunit + | ITsignature + | ITdependency + | ITrequires + + -- Pragmas, see Note [Pragma source text] in "GHC.Types.SourceText" + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITopaque_prag SourceText + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText + | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITscc_prag SourceText + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText + | ITcomplete_prag SourceText + | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText + | ITcomment_line_prag -- See Note [Nested comment line pragmas] + + | ITdotdot -- reserved symbols + | ITcolon + | ITdcolon IsUnicodeSyntax + | ITequal + | ITlam + | ITlcase + | ITlcases + | ITvbar + | ITlarrow IsUnicodeSyntax + | ITrarrow IsUnicodeSyntax + | ITdarrow IsUnicodeSyntax + | ITlolly -- The (⊸) arrow (for LinearTypes) + | ITminus -- See Note [Minus tokens] + | ITprefixminus -- See Note [Minus tokens] + | ITbang -- Prefix (!) only, e.g. f !x = rhs + | ITtilde -- Prefix (~) only, e.g. f ~x = rhs + | ITat -- Tight infix (@) only, e.g. f x@pat = rhs + | ITtypeApp -- Prefix (@) only, e.g. f @t + | ITpercent -- Prefix (%) only, e.g. a %1 -> b + | ITstar IsUnicodeSyntax + | ITdot + | ITproj Bool -- Extension: OverloadedRecordDotBit + + | ITbiglam -- GHC-extension symbols + + | ITocurly -- special symbols + | ITccurly + | ITvocurly + | ITvccurly + | ITobrack + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITcbrack + | IToparen + | ITcparen + | IToubxparen + | ITcubxparen + | ITsemi + | ITcomma + | ITunderscore + | ITbackquote + | ITsimpleQuote -- ' + + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITlabelvarid SourceText FastString -- Overloaded label: #x + -- The SourceText is required because we can + -- have a string literal as a label + -- Note [Literal source text] in "GHC.Types.SourceText" + + | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText" + | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText" + | ITstringMulti SourceText FastString -- Note [Literal source text] in "GHC.Types.SourceText" + | ITinteger IntegralLit -- Note [Literal source text] in "GHC.Types.SourceText" + | ITrational FractionalLit + + | ITprimchar SourceText Char -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimint64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword8 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword16 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword32 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimword64 SourceText Integer -- Note [Literal source text] in "GHC.Types.SourceText" + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit + + -- Template Haskell extension tokens + | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote IsUnicodeSyntax -- |] + | ITopenTExpQuote HasE -- [|| or [e|| + | ITcloseTExpQuote -- ||] + | ITdollar -- prefix $ + | ITdollardollar -- prefix $$ + | ITtyQuote -- '' + | ITquasiQuote (FastString, PsSpan, FastString, PsSpan) + -- ITquasiQuote(quoter, quoter_loc, quote, quote_loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,PsSpan, FastString, PsSpan) + -- ITqQuasiQuote(Qual, quoter, quoter_loc, quote, quote_loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] + + | ITsplice + | ITquote + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar IsUnicodeSyntax -- ^ @(|@ + | ITcparenbar IsUnicodeSyntax -- ^ @|)@ + | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ + | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ + | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ + | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ + + | ITunknown String -- ^ Used when the lexer can't make sense of it + | ITeof -- ^ end of file token + + -- Documentation annotations. See Note [PsSpan in Comments] + | ITdocComment HsDocString PsSpan -- ^ The HsDocString contains more details about what + -- this is and how to pretty print it + | ITdocOptions String PsSpan -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String PsSpan -- ^ comment starting by "--" + | ITblockComment String PsSpan -- ^ comment in {- -} + + deriving Show + +instance Outputable Token where + ppr x = text (show x) + +{- Note [PsSpan in Comments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When using the Api Annotations to exact print a modified AST, managing +the space before a comment is important. The PsSpan in the comment +token allows this to happen, and this location is tracked in prev_loc +in PState. This only tracks physical tokens, so is not updated for +zero-width ones. + +We also use this to track the space before the end-of-file marker. +-} + +{- Note [Minus tokens] +~~~~~~~~~~~~~~~~~~~~~~ +A minus sign can be used in prefix form (-x) and infix form (a - b). + +When LexicalNegation is on: + * ITprefixminus represents the prefix form + * ITvarsym "-" represents the infix form + * ITminus is not used + +When LexicalNegation is off: + * ITminus represents all forms + * ITprefixminus is not used + * ITvarsym "-" is not used +-} + +{- Note [Why not LexicalNegationBit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +One might wonder why we define NoLexicalNegationBit instead of +LexicalNegationBit. The problem lies in the following line in reservedSymsFM: + + ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) + +We want to generate ITminus only when LexicalNegation is off. How would one +do it if we had LexicalNegationBit? I (int-index) tried to use bitwise +complement: + + ,("-", ITminus, NormalSyntax, complement (xbit LexicalNegationBit)) + +This did not work, so I opted for NoLexicalNegationBit instead. +-} + + +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- +reservedWordsFM :: UniqFM FastString (Token, ExtsBitmap) +reservedWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "cases", ITlcases, xbit LambdaCaseBit ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo Nothing, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + + ( "forall", ITforall NormalSyntax, 0), + ( "mdo", ITmdo Nothing, xbit RecursiveDoBit), + -- See Note [Lexing type pseudo-keywords] + ( "family", ITfamily, 0 ), + ( "role", ITrole, 0 ), + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "static", ITstatic, xbit StaticPointersBit ), + ( "stock", ITstock, 0 ), + ( "anyclass", ITanyclass, 0 ), + ( "via", ITvia, 0 ), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "unit", ITunit, 0 ), + ( "dependency", ITdependency, 0 ), + ( "signature", ITsignature, 0 ), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit), + ( "splice", ITsplice, xbit LevelImportsBit), + ( "quote", ITquote, xbit LevelImportsBit) + ] + +{----------------------------------- +Note [Lexing type pseudo-keywords] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One might think that we wish to treat 'family' and 'role' as regular old +varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. +But, there is no need to do so. These pseudo-keywords are not stolen syntax: +they are only used after the keyword 'type' at the top-level, where varids are +not allowed. Furthermore, checks further downstream (GHC.Tc.TyCl) ensure that +type families and role annotations are never declared without their extensions +on. In fact, by unconditionally lexing these pseudo-keywords as special, we +can get better error messages. + +Also, note that these are included in the `varid` production in the parser -- +a key detail to make all this work. +-------------------------------------} + +reservedSymsFM :: UniqFM FastString (Token, IsUnicodeSyntax, ExtsBitmap) +reservedSymsFM = listToUFM $ + map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) + [ ("..", ITdotdot, NormalSyntax, 0 ) + -- (:) is a reserved op, meaning only list cons + ,(":", ITcolon, NormalSyntax, 0 ) + ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) + ,("=", ITequal, NormalSyntax, 0 ) + ,("\\", ITlam, NormalSyntax, 0 ) + ,("|", ITvbar, NormalSyntax, 0 ) + ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) + ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) + ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) + ,("-", ITminus, NormalSyntax, xbit NoLexicalNegationBit) + + ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) + + ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + + ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) + ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) + ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) + + ,("⊸", ITlolly, UnicodeSyntax, 0) + + ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + + ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) + + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot + -- form part of a large operator. This would let us have a better + -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). + ] + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = PsSpan -> StringBuffer -> Int -> StringBuffer -> P (PsLocated Token) + +special :: Token -> Action +special tok span _buf _len _buf2 = return (L span tok) + +token, layout_token :: Token -> Action +token t span _buf _len _buf2 = return (L span t) +layout_token t span _buf _len _buf2 = pushLexState layout >> return (L span t) + +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len _buf2 = return (L span $! (f buf len)) + +qdo_token :: (Maybe FastString -> Token) -> Action +qdo_token con span buf len _buf2 = do + maybe_layout token + return (L span $! token) + where + !token = con $! Just $! fst $! splitQualName buf len False + +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len _buf2 + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) + +skip_one_varid_src :: (SourceText -> FastString -> Token) -> Action +skip_one_varid_src f span buf len _buf2 + = return (L span $! f (SourceText $ lexemeToFastString (stepOn buf) (len-1)) + (lexemeToFastString (stepOn buf) (len-1))) + +skip_two_varid :: (FastString -> Token) -> Action +skip_two_varid f span buf len _buf2 + = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) + +strtoken :: (String -> Token) -> Action +strtoken f span buf len _buf2 = + return (L span $! (f $! lexemeToString buf len)) + +fstrtoken :: (FastString -> Token) -> Action +fstrtoken f span buf len _buf2 = + return (L span $! (f $! lexemeToFastString buf len)) + +begin :: Int -> Action +begin code _span _str _len _buf2 = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len _buf2 = + do _ <- popLexState + lexToken +-- See Note [Nested comment line pragmas] +failLinePrag1 :: Action +failLinePrag1 span _buf _len _buf2 = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) + else lexError LexErrorInPragma + +-- See Note [Nested comment line pragmas] +popLinePrag1 :: Action +popLinePrag1 span _buf _len _buf2 = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + _ <- popLexState + lexToken + +hopefully_open_brace :: Action +hopefully_open_brace span buf len buf2 + = do relaxed <- getBit RelaxedLayoutBit + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol (psRealLoc l) + isOK = relaxed || + case ctx of + Layout prev_off _ : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len buf2 + else addFatalError $ + mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock + +pop_and :: Action -> Action +pop_and act span buf len buf2 = + do _ <- popLexState + act span buf len buf2 + +-- See Note [Whitespace-sensitive operator parsing] +followedByOpeningToken, precededByClosingToken :: AlexAccPred ExtsBitmap +followedByOpeningToken _ _ _ (AI _ buf) = followedByOpeningToken' buf +precededByClosingToken _ (AI _ buf) _ _ = precededByClosingToken' buf + +-- The input is the buffer *after* the token. +followedByOpeningToken' :: StringBuffer -> Bool +followedByOpeningToken' buf + | atEnd buf = False + | otherwise = + case nextChar buf of + ('{', buf') -> nextCharIsNot buf' (== '-') + ('(', _) -> True + ('[', _) -> True + ('\"', _) -> True + ('\'', _) -> True + ('_', _) -> True + ('⟦', _) -> True + ('⦇', _) -> True + (c, _) -> isAlphaNum c + +-- The input is the buffer *before* the token. +precededByClosingToken' :: StringBuffer -> Bool +precededByClosingToken' buf = + case prevChar buf '\n' of + '}' -> decodePrevNChars 1 buf /= "-" + ')' -> True + ']' -> True + '\"' -> True + '\'' -> True + '_' -> True + '⟧' -> True + '⦈' -> True + c -> isAlphaNum c + +get_op_ws :: StringBuffer -> StringBuffer -> OpWs +get_op_ws buf1 buf2 = + mk_op_ws (precededByClosingToken' buf1) (followedByOpeningToken' buf2) + where + mk_op_ws False True = OpWsPrefix + mk_op_ws True False = OpWsSuffix + mk_op_ws True True = OpWsTightInfix + mk_op_ws False False = OpWsLooseInfix + +{-# INLINE with_op_ws #-} +with_op_ws :: (OpWs -> Action) -> Action +with_op_ws act span buf len buf2 = act (get_op_ws buf buf2) span buf len buf2 + +{-# INLINE nextCharIs #-} +nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIs buf p = not (atEnd buf) && p (currentChar buf) + +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + +notFollowedBy :: Char -> AlexAccPred ExtsBitmap +notFollowedBy char _ _ _ (AI _ buf) + = nextCharIsNot buf (== char) + +notFollowedBySymbol :: AlexAccPred ExtsBitmap +notFollowedBySymbol _ _ _ (AI _ buf) + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") + +followedByDigit :: AlexAccPred ExtsBitmap +followedByDigit _ _ _ (AI _ buf) + = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) + +ifCurrentChar :: Char -> AlexAccPred ExtsBitmap +ifCurrentChar char _ (AI _ buf) _ _ + = nextCharIs buf (== char) + +-- We must reject doc comments as being ordinary comments everywhere. +-- In some cases the doc comment will be selected as the lexeme due to +-- maximal munch, but not always, because the nested comment rule is +-- valid in all states, but the doc-comment rules are only valid in +-- the non-layout states. +isNormalComment :: AlexAccPred ExtsBitmap +isNormalComment bits _ _ (AI _ buf) + | HaddockBit `xtest` bits = notFollowedByDocOrPragma + | otherwise = nextCharIsNot buf (== '#') + where + notFollowedByDocOrPragma + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) + +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf + +atEOL :: AlexAccPred ExtsBitmap +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' + +-- Check if we should parse a negative literal (e.g. -123) as a single token. +negLitPred :: AlexAccPred ExtsBitmap +negLitPred = + prefix_minus `alexAndPred` + (negative_literals `alexOrPred` lexical_negation) + where + negative_literals = ifExtension NegativeLiteralsBit + + lexical_negation = + -- See Note [Why not LexicalNegationBit] + alexNotPred (ifExtension NoLexicalNegationBit) + + prefix_minus = + -- Note [prefix_minus in negLitPred and negHashLitPred] + alexNotPred precededByClosingToken + +-- Check if we should parse an unboxed negative literal (e.g. -123#) as a single token. +negHashLitPred :: ExtBits -> AlexAccPred ExtsBitmap +negHashLitPred ext = prefix_minus `alexAndPred` magic_hash + where + magic_hash = ifExtension ext -- Either MagicHashBit or ExtendedLiteralsBit + prefix_minus = + -- Note [prefix_minus in negLitPred and negHashLitPred] + alexNotPred precededByClosingToken + +{- Note [prefix_minus in negLitPred and negHashLitPred] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to parse -1 as a single token, but x-1 as three tokens. +So in negLitPred (and negHashLitPred) we require that we have a prefix +occurrence of the minus sign. See Note [Whitespace-sensitive operator parsing] +for a detailed definition of a prefix occurrence. + +The condition for a prefix occurrence of an operator is: + + not precededByClosingToken && followedByOpeningToken + +but we don't check followedByOpeningToken when parsing a negative literal. +It holds simply because we immediately lex a literal after the minus. +-} + +ifExtension :: ExtBits -> AlexAccPred ExtsBitmap +ifExtension extBits bits _ _ _ = extBits `xtest` bits + +alexNotPred p userState in1 len in2 + = not (p userState in1 len in2) + +alexOrPred p1 p2 userState in1 len in2 + = p1 userState in1 len in2 || p2 userState in1 len in2 + +multiline_doc_comment :: Action +multiline_doc_comment span buf _len _buf2 = {-# SCC "multiline_doc_comment" #-} withLexedDocType worker + where + worker input@(AI start_loc _) docType checkNextLine = go start_loc "" [] input + where + go start_loc curLine prevLines input@(AI end_loc _) = case alexGetChar' input of + Just ('\n', input') + | checkNextLine -> case checkIfCommentLine input' of + Just input@(AI next_start _) -> go next_start "" (locatedLine : prevLines) input -- Start a new line + Nothing -> endComment + | otherwise -> endComment + Just (c, input) -> go start_loc (c:curLine) prevLines input + Nothing -> endComment + where + lineSpan = mkSrcSpanPs $ mkPsSpan start_loc end_loc + locatedLine = L lineSpan (mkHsDocStringChunk $ reverse curLine) + commentLines = NE.reverse $ locatedLine :| prevLines + endComment = docCommentEnd input (docType (\dec -> MultiLineDocString dec commentLines)) buf span + + -- Check if the next line of input belongs to this doc comment as well. + -- A doc comment continues onto the next line when the following + -- conditions are met: + -- * The line starts with "--" + -- * The line doesn't start with "---". + -- * The line doesn't start with "-- $", because that would be the + -- start of a /new/ named haddock chunk (#10398). + checkIfCommentLine :: AlexInput -> Maybe AlexInput + checkIfCommentLine input = check (dropNonNewlineSpace input) + where + check input = do + ('-', input) <- alexGetChar' input + ('-', input) <- alexGetChar' input + (c, after_c) <- alexGetChar' input + case c of + '-' -> Nothing + ' ' -> case alexGetChar' after_c of + Just ('$', _) -> Nothing + _ -> Just input + _ -> Just input + + dropNonNewlineSpace input = case alexGetChar' input of + Just (c, input') + | isSpace c && c /= '\n' -> dropNonNewlineSpace input' + | otherwise -> input + Nothing -> input + +lineCommentToken :: Action +lineCommentToken span buf len buf2 = do + b <- getBit RawTokenStreamBit + if b then do + lt <- getLastLocIncludingComments + strtoken (\s -> ITlineComment s lt) span buf len buf2 + else lexToken + + +{- + nested comments require traversing by hand, they can't be parsed + using regular expressions. +-} +nested_comment :: Action +nested_comment span buf len _buf2 = {-# SCC "nested_comment" #-} do + l <- getLastLocIncludingComments + let endComment input (L _ comment) = commentEnd lexToken input (Nothing, ITblockComment comment l) buf span + input <- getInput + -- Include decorator in comment + let start_decorator = reverse $ lexemeToString buf len + nested_comment_logic endComment start_decorator input span + +nested_doc_comment :: Action +nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker + where + worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span)) + where + endComment input lcomment + = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span + + dropTrailingDec [] = [] + dropTrailingDec "-}" = "" + dropTrailingDec (x:xs) = x:dropTrailingDec xs + +{-# INLINE nested_comment_logic #-} +-- | Includes the trailing '-}' decorators +-- drop the last two elements with the callback if you don't want them to be included +nested_comment_logic + :: (AlexInput -> Located String -> P (PsLocated Token)) -- ^ Continuation that gets the rest of the input and the lexed comment + -> String -- ^ starting value for accumulator (reversed) - When we want to include a decorator '{-' in the comment + -> AlexInput + -> PsSpan + -> P (PsLocated Token) +nested_comment_logic endComment commentAcc input span = go commentAcc (1::Int) input + where + go commentAcc 0 input@(AI end_loc _) = do + let comment = reverse commentAcc + cspan = mkSrcSpanPs $ mkPsSpan (psSpanStart span) end_loc + lcomment = L cspan comment + endComment input lcomment + go commentAcc n input = case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' + Just (_,_) -> go ('-':commentAcc) n input + Just ('\123',input) -> case alexGetChar' input of -- '{' char + Nothing -> errBrace input (psRealSpan span) + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + -- See Note [Nested comment line pragmas] + Just ('\n',input) -> case alexGetChar' input of + Nothing -> errBrace input (psRealSpan span) + Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input + go (parsedAcc ++ '\n':commentAcc) n input + Just (_,_) -> go ('\n':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input + +-- See Note [Nested comment line pragmas] +parseNestedPragma :: AlexInput -> P (String,AlexInput) +parseNestedPragma input@(AI _ buf) = do + origInput <- getInput + setInput input + setExts (.|. xbit InNestedCommentBit) + pushLexState bol + lt <- lexToken + _ <- popLexState + setExts (.&. complement (xbit InNestedCommentBit)) + postInput@(AI _ postBuf) <- getInput + setInput origInput + case unLoc lt of + ITcomment_line_prag -> do + let bytes = byteDiff buf postBuf + diff = lexemeToString buf bytes + return (reverse diff, postInput) + lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) + +{- +Note [Nested comment line pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to ignore cpp-preprocessor-generated #line pragmas if they were inside +nested comments. + +Now, when parsing a nested comment, if we encounter a line starting with '#' we +call parseNestedPragma, which executes the following: +1. Save the current lexer input (loc, buf) for later +2. Set the current lexer input to the beginning of the line starting with '#' +3. Turn the 'InNestedComment' extension on +4. Push the 'bol' lexer state +5. Lex a token. Due to (2), (3), and (4), this should always lex a single line + or less and return the ITcomment_line_prag token. This may set source line + and file location if a #line pragma is successfully parsed +6. Restore lexer input and state to what they were before we did all this +7. Return control to the function parsing a nested comment, informing it of + what the lexer parsed + +Regarding (5) above: +Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) +checks if the 'InNestedComment' extension is set. If it is, that function will +return control to parseNestedPragma by returning the ITcomment_line_prag token. + +See #314 for more background on the bug this fixes. +-} + +{-# INLINE withLexedDocType #-} +withLexedDocType :: (AlexInput -> ((HsDocStringDecorator -> HsDocString) -> (HdkComment, Token)) -> Bool -> P (PsLocated Token)) + -> P (PsLocated Token) +withLexedDocType lexDocComment = do + input@(AI _ buf) <- getInput + l <- getLastLocIncludingComments + case prevChar buf ' ' of + -- The `Bool` argument to lexDocComment signals whether or not the next + -- line of input might also belong to this doc comment. + '|' -> lexDocComment input (mkHdkCommentNext l) True + '^' -> lexDocComment input (mkHdkCommentPrev l) True + '$' -> case lexDocName input of + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + Just (name, input) -> lexDocComment input (mkHdkCommentNamed l name) True + '*' -> lexDocSection l 1 input + _ -> panic "withLexedDocType: Bad doc type" + where + lexDocSection l n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection l (n+1) input + Just (_, _) -> lexDocComment input (mkHdkCommentSection l n) False + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + + lexDocName :: AlexInput -> Maybe (String, AlexInput) + lexDocName = go "" + where + go acc input = case alexGetChar' input of + Just (c, input') + | isSpace c -> Just (reverse acc, input) + | otherwise -> go (c:acc) input' + Nothing -> Nothing + +mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNext loc mkDS = (HdkCommentNext ds,ITdocComment ds loc) + where ds = mkDS HsDocStringNext +mkHdkCommentPrev loc mkDS = (HdkCommentPrev ds,ITdocComment ds loc) + where ds = mkDS HsDocStringPrevious + +mkHdkCommentNamed :: PsSpan -> String -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentNamed loc name mkDS = (HdkCommentNamed name ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringNamed name) + +mkHdkCommentSection :: PsSpan -> Int -> (HsDocStringDecorator -> HsDocString) -> (HdkComment, Token) +mkHdkCommentSection loc n mkDS = (HdkCommentSection n ds, ITdocComment ds loc) + where ds = mkDS (HsDocStringGroup n) + +-- RULES pragmas turn on the forall and '.' keywords, and we turn them +-- off again at the end of the pragma. +rulePrag :: Action +rulePrag span buf len _buf2 = do + setExts (.|. xbit InRulePragBit) + let !src = lexemeToFastString buf len + return (L span (ITrules_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +linePrag :: Action +linePrag span buf len buf2 = do + usePosPrags <- getBit UsePosPragsBit + if usePosPrags + then begin line_prag2 span buf len buf2 + else let !src = lexemeToFastString buf len + in return (L span (ITline_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +columnPrag :: Action +columnPrag span buf len buf2 = do + usePosPrags <- getBit UsePosPragsBit + if usePosPrags + then begin column_prag span buf len buf2 + else let !src = lexemeToFastString buf len + in return (L span (ITcolumn_prag (SourceText src))) + +endPrag :: Action +endPrag span _buf _len _buf2 = do + setExts (.&. complement (xbit InRulePragBit)) + return (L span ITclose_prag) + +-- docCommentEnd +------------------------------------------------------------------------------- +-- This function is quite tricky. We can't just return a new token, we also +-- need to update the state of the parser. Why? Because the token is longer +-- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- it writes the wrong token length to the parser state. This function is +-- called afterwards, so it can just update the state. + +{-# INLINE commentEnd #-} +commentEnd :: P (PsLocated Token) + -> AlexInput + -> (Maybe HdkComment, Token) + -> StringBuffer + -> PsSpan + -> P (PsLocated Token) +commentEnd cont input (m_hdk_comment, hdk_token) buf span = do + setInput input + let (AI loc nextBuf) = input + span' = mkPsSpan (psSpanStart span) loc + last_len = byteDiff buf nextBuf + span `seq` setLastToken span' last_len + whenIsJust m_hdk_comment $ \hdk_comment -> + P $ \s -> POk (s {hdk_comments = hdk_comments s `snocOL` L span' hdk_comment}) () + b <- getBit RawTokenStreamBit + if b then return (L span' hdk_token) + else cont + +{-# INLINE docCommentEnd #-} +docCommentEnd :: AlexInput -> (HdkComment, Token) -> StringBuffer -> + PsSpan -> P (PsLocated Token) +docCommentEnd input (hdk_comment, tok) buf span + = commentEnd lexToken input (Just hdk_comment, tok) buf span + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = + failLocMsgP (realSrcSpanStart span) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedComment LexErrKind_EOF)) + +open_brace, close_brace :: Action +open_brace span _str _len _buf2 = do + ctx <- getContext + setContext (NoLayout:ctx) + return (L span ITocurly) +close_brace span _str _len _buf2 = do + popContext + return (L span ITccurly) + +qvarid, qconid :: StringBuffer -> Int -> Token +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False + +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) +-- takes a StringBuffer and a length, and returns the module name +-- and identifier parts of a qualified name. Splits at the *last* dot, +-- because of hierarchical module names. +-- +-- Throws an error if the name is not qualified. +splitQualName orig_buf len parens = split orig_buf orig_buf + where + split buf dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf + where + (c,buf') = nextChar buf + + -- careful, we might get names like M.... + -- so, if the character after the dot is not upper-case, this is + -- the end of the qualifier part. + found_dot buf -- buf points after the '.' + | isUpper c = split buf' buf + | otherwise = done buf + where + (c,buf') = nextChar buf + + done dot_buf + | qual_size < 1 = error "splitQualName got an unqualified named" + | otherwise = + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) + where + qual_size = orig_buf `byteDiff` dot_buf + +varid :: Action +varid span buf len _buf2 = + case lookupUFM reservedWordsFM fs of + Just (ITcase, _) -> do + lastTk <- getLastTk + keyword <- case lastTk of + Strict.Just (L _ ITlam) -> do + lambdaCase <- getBit LambdaCaseBit + unless lambdaCase $ do + pState <- getPState + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) PsErrLambdaCase + return ITlcase + _ -> return ITcase + maybe_layout keyword + return $ L span keyword + Just (ITlcases, _) -> do + lastTk <- getLastTk + lambdaCase <- getBit LambdaCaseBit + token <- case lastTk of + Strict.Just (L _ ITlam) | lambdaCase -> return ITlcases + _ -> return $ ITvarid fs + maybe_layout token + return $ L span token + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, i) -> do + exts <- getExts + if exts .&. i /= 0 + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs + where + !fs = lexemeToFastString buf len + +conid :: StringBuffer -> Int -> Token +conid buf len = ITconid $! lexemeToFastString buf len + +qvarsym, qconsym :: StringBuffer -> Int -> Token +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False + + +errSuffixAt :: PsSpan -> P a +errSuffixAt span = do + input <- getInput + failLocMsgP start (go input start) (\srcSpan -> mkPlainErrorMsgEnvelope srcSpan $ PsErrSuffixAT) + where + start = psRealLoc (psSpanStart span) + go inp loc + | Just (c, i) <- alexGetChar inp + , let next = advanceSrcLoc loc c = + if c == ' ' + then go i next + else next + | otherwise = loc + +-- See Note [Whitespace-sensitive operator parsing] +varsym :: OpWs -> Action +varsym opws@OpWsPrefix = sym $ \span exts s -> + let warnExtConflict errtok = + do { addPsMessage (mkSrcSpanPs span) (PsWarnOperatorWhitespaceExtConflict errtok) + ; return (ITvarsym s) } + in + if | s == fsLit "@" -> + return ITtypeApp -- regardless of TypeApplications for better error messages + | s == fsLit "%" -> + if xtest LinearTypesBit exts + then return ITpercent + else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent + | s == fsLit "$" -> + if xtest ThQuotesBit exts + then return ITdollar + else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar + | s == fsLit "$$" -> + if xtest ThQuotesBit exts + then return ITdollardollar + else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar + | s == fsLit "-" -> + return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus + -- and don't hit this code path. See Note [Minus tokens] + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> + return (ITproj True) -- e.g. '(.x)' + | s == fsLit "." -> return ITdot + | s == fsLit "!" -> return ITbang + | s == fsLit "~" -> return ITtilde + | otherwise -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym opws@OpWsSuffix = sym $ \span _ s -> + if | s == fsLit "@" -> errSuffixAt span + | s == fsLit "." -> return ITdot + | otherwise -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym opws@OpWsTightInfix = sym $ \span exts s -> + if | s == fsLit "@" -> return ITat + | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) + | s == fsLit "." -> return ITdot + | otherwise -> + do { warnOperatorWhitespace opws span s + ; return (ITvarsym s) } +varsym OpWsLooseInfix = sym $ \_ _ s -> + if | s == fsLit "." + -> return ITdot + | otherwise + -> return $ ITvarsym s + +consym :: OpWs -> Action +consym opws = sym $ \span _exts s -> + do { warnOperatorWhitespace opws span s + ; return (ITconsym s) } + +warnOperatorWhitespace :: OpWs -> PsSpan -> FastString -> P () +warnOperatorWhitespace opws span s = + whenIsJust (check_unusual_opws opws) $ \opws' -> + addPsMessage + (mkSrcSpanPs span) + (PsWarnOperatorWhitespace s opws') + +-- Check an operator occurrence for unusual whitespace (prefix, suffix, tight infix). +-- This determines if -Woperator-whitespace is triggered. +check_unusual_opws :: OpWs -> Maybe OperatorWhitespaceOccurrence +check_unusual_opws opws = + case opws of + OpWsPrefix -> Just OperatorWhitespaceOccurrence_Prefix + OpWsSuffix -> Just OperatorWhitespaceOccurrence_Suffix + OpWsTightInfix -> Just OperatorWhitespaceOccurrence_TightInfix + OpWsLooseInfix -> Nothing + +sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action +sym con span buf len _buf2 = + case lookupUFM reservedSymsFM fs of + Just (keyword, NormalSyntax, 0) -> + return $ L span keyword + Just (keyword, NormalSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 + then return $ L span keyword + else L span <$!> con span exts fs + Just (keyword, UnicodeSyntax, 0) -> do + exts <- getExts + if xtest UnicodeSyntaxBit exts + then return $ L span keyword + else L span <$!> con span exts fs + Just (keyword, UnicodeSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts + then return $ L span keyword + else L span <$!> con span exts fs + Nothing -> do + exts <- getExts + L span <$!> con span exts fs + where + !fs = lexemeToFastString buf len + +-- Variations on the integral numeric literal. +tok_integral + :: (SourceText -> Integer -> Token) -- ^ token constructor + -> (Integer -> Integer) -- ^ value transformation (e.g. negate) + -> Int -- ^ Offset of the unsigned value (e.g. 1 when we parsed "-", 2 for "0x", etc.) + -> Int -- ^ Number of non-numeric characters parsed (e.g. 6 in "-12#Int8") + -> (Integer, (Char -> Int)) -- ^ (radix, char_to_int parsing function) + -> Action +tok_integral mk_token transval offset translen (radix,char_to_int) span buf len _buf2 = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToFastString buf len + when ((not numericUnderscores) && ('_' `elem` unpackFS src)) $ do + pState <- getPState + let msg = PsErrNumUnderscores NumUnderscore_Integral + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + return $ L span $ mk_token (SourceText src) + $! transval $ parseUnsignedInteger + (offsetBytes offset buf) (subtract translen len) radix char_to_int + +-- | Helper to parse ExtendedLiterals (e.g. -0x10#Word32) +-- +-- This function finds the offset of the "#" character and checks that the +-- suffix is valid. Then it calls tok_integral with the appropriate suffix +-- length taken into account. +tok_prim_num_ext + :: (Integer -> Integer) -- ^ value transformation (e.g. negate) + -> Int -- ^ Offset of the unsigned value (e.g. 1 when we parsed "-", 2 for "0x", etc.) + -> (Integer, (Char -> Int)) -- ^ (radix, char_to_int parsing function) + -> Action +tok_prim_num_ext transval offset (radix,char_to_int) span buf len buf2 = do + let !suffix_offset = findHashOffset buf + 1 + let !suffix_len = len - suffix_offset + let !suffix = lexemeToFastString (offsetBytes suffix_offset buf) suffix_len + + mk_token <- if + | suffix == fsLit "Word" -> pure ITprimword + | suffix == fsLit "Word8" -> pure ITprimword8 + | suffix == fsLit "Word16" -> pure ITprimword16 + | suffix == fsLit "Word32" -> pure ITprimword32 + | suffix == fsLit "Word64" -> pure ITprimword64 + | suffix == fsLit "Int" -> pure ITprimint + | suffix == fsLit "Int8" -> pure ITprimint8 + | suffix == fsLit "Int16" -> pure ITprimint16 + | suffix == fsLit "Int32" -> pure ITprimint32 + | suffix == fsLit "Int64" -> pure ITprimint64 + | otherwise -> srcParseFail + + let !translen = suffix_len+offset+1 + tok_integral mk_token transval offset translen (radix,char_to_int) span buf len buf2 + + + +tok_num :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_num = tok_integral $ \case + st@(SourceText (unconsFS -> Just ('-',_))) -> itint st (const True) + st@(SourceText _) -> itint st (const False) + st@NoSourceText -> itint st (< 0) + where + itint :: SourceText -> (Integer -> Bool) -> Integer -> Token + itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) + +tok_primint :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primint = tok_integral ITprimint + + +tok_primword :: Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primword = tok_integral ITprimword positive + +positive, negative :: (Integer -> Integer) +positive = id +negative = negate + +binary, octal, decimal, hexadecimal :: (Integer, Char -> Int) +binary = (2,octDecDigit) +octal = (8,octDecDigit) +decimal = (10,octDecDigit) +hexadecimal = (16,hexDigit) + +-- readSignificandExponentPair can understand negative rationals, exponents, everything. +tok_frac :: Int -> (String -> Token) -> Action +tok_frac drop f span buf len _buf2 = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToString buf (len-drop) + when ((not numericUnderscores) && ('_' `elem` src)) $ do + pState <- getPState + let msg = PsErrNumUnderscores NumUnderscore_Float + addError $ mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + return (L span $! (f $! src)) + +tok_float, tok_primfloat, tok_primdouble, tok_prim_hex_float, tok_prim_hex_double :: String -> Token +tok_float str = ITrational $! readFractionalLit str +tok_hex_float str = ITrational $! readHexFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str +tok_prim_hex_float str = ITprimfloat $! readHexFractionalLit str +tok_prim_hex_double str = ITprimdouble $! readHexFractionalLit str + +readFractionalLit, readHexFractionalLit :: String -> FractionalLit +readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2 +readFractionalLit = readFractionalLitX readSignificandExponentPair Base10 + +readFractionalLitX :: (String -> (Integer, Integer)) + -> FractionalExponentBase + -> String -> FractionalLit +readFractionalLitX readStr b str = + mkSourceFractionalLit str is_neg i e b + where + is_neg = case str of + '-' : _ -> True + _ -> False + (i, e) = readStr str + +-- ----------------------------------------------------------------------------- +-- Layout processing + +-- we're at the first token on a line, insert layout tokens if necessary +do_bol :: Action +do_bol span _str _len _buf2 = do + -- See Note [Nested comment line pragmas] + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + (pos, gen_semic) <- getOffside + case pos of + LT -> do + --trace "layout: inserting '}'" $ do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ | gen_semic -> do + --trace "layout: inserting ';'" $ do + _ <- popLexState + return (L span ITsemi) + _ -> do + _ <- popLexState + lexToken + +-- certain keywords put us in the "layout" state, where we might +-- add an opening curly brace. +maybe_layout :: Token -> P () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- getBit AlternativeLayoutRuleBit + unless alr $ f t + where f (ITdo _) = pushLexState layout_do + f (ITmdo _) = pushLexState layout_do + f ITof = pushLexState layout + f ITlcase = pushLexState layout + f ITlcases = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f ITif = pushLexState layout_if + f _ = return () + +-- Pushing a new implicit layout context. If the indentation of the +-- next token is not greater than the previous layout context, then +-- Haskell 98 says that the new layout context should be empty; that is +-- the lexer must generate {}. +-- +-- We are slightly more lenient than this: when the new context is started +-- by a 'do', then we allow the new context to be at the same indentation as +-- the previous context. This is what the 'strict' argument is for. +new_layout_context :: Bool -> Bool -> Token -> Action +new_layout_context strict gen_semic tok span _buf len _buf2 = do + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol (psRealLoc l) - len + ctx <- getContext + nondecreasing <- getBit NondecreasingIndentationBit + let strict' = strict || not nondecreasing + case ctx of + Layout prev_off _ : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span tok) + _ -> do setContext (Layout offset gen_semic : ctx) + return (L span tok) + +do_layout_left :: Action +do_layout_left span _buf _len _buf2 = do + _ <- popLexState + pushLexState bol -- we must be at the start of a line + return (L span ITvccurly) + +-- ----------------------------------------------------------------------------- +-- LINE pragmas + +setLineAndFile :: Int -> Action +setLineAndFile code (PsSpan span _) buf len _buf2 = do + let src = lexemeToString buf (len - 1) -- drop trailing quotation mark + linenumLen = length $ head $ words src + linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit + file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src + -- skip everything through first quotation mark to get to the filename + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). + resetAlrLastLoc file + setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) + -- subtract one: the line number refers to the *following* line + addSrcFile file + _ <- popLexState + pushLexState code + lexToken + +setColumn :: Action +setColumn (PsSpan span _) buf len _buf2 = do + let column = + case reads (lexemeToString buf len) of + [(column, _)] -> column + _ -> error "setColumn: expected integer" -- shouldn't happen + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) + (fromIntegral (column :: Integer))) + _ <- popLexState + lexToken + +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok = lex_string_prag_comment mkTok' + where + mkTok' s _ = mkTok s + +lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action +lex_string_prag_comment mkTok span _buf _len _buf2 + = do input <- getInput + start <- getParsedLoc + l <- getLastLocIncludingComments + tok <- go l [] input + end <- getParsedLoc + return (L (mkPsSpan start end) tok) + where go l acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc) l) + else case alexGetChar input of + Just (c,i) -> go l (c:acc) i + Nothing -> err input + isString _ [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) + (psRealLoc end) + (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexUnterminatedOptions LexErrKind_EOF) + +-- ----------------------------------------------------------------------------- +-- Strings & Chars + +tok_string :: Action +tok_string span buf len _buf2 = do + s <- lex_chars ("\"", "\"") span buf (if endsInHash then len - 1 else len) + + if endsInHash + then do + when (any (> '\xFF') s) $ do + pState <- getPState + let msg = PsErrPrimStringInvalidChar + let err = mkPlainErrorMsgEnvelope (mkSrcSpanPs (last_loc pState)) msg + addError err + pure $ L span (ITprimstring src (unsafeMkByteString s)) + else + pure $ L span (ITstring src (mkFastString s)) + where + src = SourceText $ lexemeToFastString buf len + endsInHash = currentChar (offsetBytes (len - 1) buf) == '#' + +{- Note [Lexing multiline strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ideally, we would lex multiline strings completely with Alex syntax, like +normal strings. However, we can't because: + + 1. The multiline string should all be one lexical token, not multiple + 2. We need to allow bare quotes, which can't be done with one regex + +Instead, we'll lex them with a hybrid solution in tok_string_multi by manually +invoking lex states. This allows us to get the performance of native Alex +syntax as much as possible, and just gluing the pieces together outside of +Alex. + +Implemented in string_multi_content in GHC/Parser/Lexer/String.x +-} + +-- | See Note [Lexing multiline strings] +tok_string_multi :: Action +tok_string_multi startSpan startBuf _len _buf2 = do + -- advance to the end of the multiline string + let startLoc = psSpanStart startSpan + let i@(AI _ contentStartBuf) = + case lexDelim $ AI startLoc startBuf of + Just i -> i + Nothing -> panic "tok_string_multi did not start with a delimiter" + (AI _ contentEndBuf, i'@(AI endLoc endBuf)) <- goContent i + + -- build the values pertaining to the entire multiline string, including delimiters + let span = mkPsSpan startLoc endLoc + let len = byteDiff startBuf endBuf + let src = SourceText $ lexemeToFastString startBuf len + + -- load the content of the multiline string + let contentLen = byteDiff contentStartBuf contentEndBuf + s <- + either (throwStringLexError (AI startLoc startBuf)) pure $ + lexMultilineString contentLen contentStartBuf + + setInput i' + pure $ L span $ ITstringMulti src (mkFastString s) + where + goContent i0 = + case Lexer.String.alexScan i0 Lexer.String.string_multi_content of + Lexer.String.AlexToken i1 len _ + | Just i2 <- lexDelim i1 -> pure (i1, i2) + | isEOF i1 -> checkSmartQuotes >> setInput i1 >> lexError LexError + -- Can happen if no patterns match, e.g. an unterminated gap + | len == 0 -> setInput i1 >> lexError LexError + | otherwise -> goContent i1 + Lexer.String.AlexSkip i1 _ -> goContent i1 + _ -> setInput i0 >> lexError LexError + + lexDelim = + let go 0 i = Just i + go n i = + case alexGetChar' i of + Just ('"', i') -> go (n - 1) i' + _ -> Nothing + in go (3 :: Int) + + -- See Note [Bare smart quote error] + checkSmartQuotes = do + let findSmartQuote i0@(AI loc _) = + case alexGetChar' i0 of + Just ('\\', i1) | Just (_, i2) <- alexGetChar' i1 -> findSmartQuote i2 + Just (c, i1) + | isDoubleSmartQuote c -> Just (c, loc) + | otherwise -> findSmartQuote i1 + _ -> Nothing + case findSmartQuote (AI (psSpanStart startSpan) startBuf) of + Just (c, loc) -> throwSmartQuoteError c loc + Nothing -> pure () + +lex_chars :: (String, String) -> PsSpan -> StringBuffer -> Int -> P String +lex_chars (startDelim, endDelim) span buf len = + either (throwStringLexError i0) pure $ + lexString contentLen contentBuf + where + i0@(AI _ contentBuf) = advanceInputBytes (length startDelim) $ AI (psSpanStart span) buf + + -- assumes delimiters are ASCII, with 1 byte per Char + contentLen = len - length startDelim - length endDelim + +throwStringLexError :: AlexInput -> StringLexError -> P a +throwStringLexError i (StringLexError e pos) = setInput (advanceInputTo pos i) >> lexError e + + +tok_quoted_label :: Action +tok_quoted_label span buf len _buf2 = do + s <- lex_chars ("#\"", "\"") span buf len + pure $ L span (ITlabelvarid src (mkFastString s)) + where + -- skip leading '#' + src = SourceText . mkFastString . drop 1 $ lexemeToString buf len + + +tok_char :: Action +tok_char span buf len _buf2 = do + c <- lex_chars ("'", "'") span buf (if endsInHash then len - 1 else len) >>= \case + [c] -> pure c + s -> panic $ "tok_char expected exactly one character, got: " ++ show s + pure . L span $ + if endsInHash + then ITprimchar src c + else ITchar src c + where + src = SourceText $ lexemeToFastString buf len + endsInHash = currentChar (offsetBytes (len - 1) buf) == '#' + + +-- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len _buf2 = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getParsedLoc + let quoter_span_start = advancePsLoc (psSpanStart span) '[' + quoter_span_end = foldl' advancePsLoc quoter_span_start + (take (len - 2) (repeat 'a')) + quoter_span = mkPsSpan quoter_span_start quoter_span_end + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + quoter_span, + mkFastString (reverse quote), + mkPsSpan quoteStart end))) + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len _buf2 = do + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getParsedLoc + let quoter_span_start = advancePsLoc (psSpanStart span) '[' + quoter_span_end = foldl' advancePsLoc quoter_span_start quoter + quoter_span = mkPsSpan quoter_span_start quoter_span_end + quote <- lex_quasiquote (psRealLoc quoteStart) "" + end <- getParsedLoc + return (L (mkPsSpan (psSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + quoter_span, + mkFastString (reverse quote), + mkPsSpan quoteStart end))) + +lex_quasiquote :: RealSrcLoc -> String -> P String +lex_quasiquote start s = do + i <- getInput + case alexGetChar' i of + Nothing -> quasiquote_error start + + -- NB: The string "|]" terminates the quasiquote, + -- with absolutely no escaping. See the extensive + -- discussion on #5348 for why there is no + -- escape handling. + Just ('|',i) + | Just (']',i) <- alexGetChar' i + -> do { setInput i; return s } + + Just (c, i) -> do + setInput i; lex_quasiquote start (c : s) + +quasiquote_error :: RealSrcLoc -> P a +quasiquote_error start = do + (AI end buf) <- getInput + reportLexError start (psRealLoc end) buf + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc (PsErrLexer LexUnterminatedQQ k)) + +-- ----------------------------------------------------------------------------- +-- Unicode Smart Quote detection (#21843) + +isSmartQuote :: AlexAccPred ExtsBitmap +isSmartQuote _ _ _ (AI _ buf) = let c = prevChar buf ' ' in isSingleSmartQuote c || isDoubleSmartQuote c + +throwSmartQuoteError :: Char -> PsLoc -> P a +throwSmartQuoteError c loc = addFatalError err + where + err = + mkPlainErrorMsgEnvelope (mkSrcSpanPs (mkPsSpan loc loc)) $ + PsErrUnicodeCharLooksLike c correct_char correct_char_name + (correct_char, correct_char_name) = + if isSingleSmartQuote c + then ('\'', "Single Quote") + else ('"', "Quotation Mark") + +-- | Throw a smart quote error, where the smart quote was the last character lexed +smart_quote_error :: Action +smart_quote_error span _ _ buf2 = do + let c = prevChar buf2 (panic "smart_quote_error unexpectedly called on beginning of input") + throwSmartQuoteError c (psSpanStart span) + +-- Note [Bare smart quote error] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A smart quote inside of a string is allowed, but if a complete valid string +-- couldn't be lexed, we want to see if there's a smart quote that the user +-- thought ended the string, but in fact didn't. + +-- ----------------------------------------------------------------------------- +-- Warnings + +warnTab :: Action +warnTab srcspan _buf _len _buf2 = do + addTabWarning (psRealSpan srcspan) + lexToken + +warnThen :: PsMessage -> Action -> Action +warnThen warning action srcspan buf len buf2 = do + addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning + action srcspan buf len buf2 + +-- ----------------------------------------------------------------------------- +-- The Parse Monad + +-- | Do we want to generate ';' layout tokens? In some cases we just want to +-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates +-- alternatives (unlike a `case` expression where we need ';' to as a separator +-- between alternatives). +type GenSemic = Bool + +generateSemic, dontGenerateSemic :: GenSemic +generateSemic = True +dontGenerateSemic = False + +data LayoutContext + = NoLayout + | Layout !Int !GenSemic + deriving Show + +-- | The result of running a parser. +newtype ParseResult a = PR (# (# PState, a #) | PState #) + +-- | The parser has consumed a (possibly empty) prefix of the input and produced +-- a result. Use 'getPsMessages' to check for accumulated warnings and non-fatal +-- errors. +-- +-- The carried parsing state can be used to resume parsing. +pattern POk :: PState -> a -> ParseResult a +pattern POk s a = PR (# (# s , a #) | #) + +-- | The parser has consumed a (possibly empty) prefix of the input and failed. +-- +-- The carried parsing state can be used to resume parsing. It is the state +-- right before failure, including the fatal parse error. 'getPsMessages' and +-- 'getPsErrorMessages' must return a non-empty bag of errors. +pattern PFailed :: PState -> ParseResult a +pattern PFailed s = PR (# | s #) + +{-# COMPLETE POk, PFailed #-} + +-- | Test whether a 'WarningFlag' is set +warnopt :: WarningFlag -> ParserOpts -> Bool +warnopt f options = f `EnumSet.member` pWarningFlags options + +-- | Parser options. +-- +-- See 'mkParserOpts' to construct this. +data ParserOpts = ParserOpts + { pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions + , pDiagOpts :: !DiagOpts + -- ^ Options to construct diagnostic messages. + } + +pWarningFlags :: ParserOpts -> EnumSet WarningFlag +pWarningFlags opts = diag_warning_flags (pDiagOpts opts) + +-- | Haddock comment as produced by the lexer. These are accumulated in 'PState' +-- and then processed in "GHC.Parser.PostProcess.Haddock". The location of the +-- 'HsDocString's spans over the contents of the docstring - i.e. it does not +-- include the decorator ("-- |", "{-|" etc.) +data HdkComment + = HdkCommentNext HsDocString + | HdkCommentPrev HsDocString + | HdkCommentNamed String HsDocString + | HdkCommentSection Int HsDocString + deriving Show + +data PState = PState { + buffer :: StringBuffer, + options :: ParserOpts, + warnings :: Messages PsMessage, + errors :: Messages PsMessage, + tab_first :: Strict.Maybe RealSrcSpan, -- pos of first tab warning in the file + tab_count :: !Word, -- number of tab warnings in the file + last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token + prev_loc :: PsSpan, -- pos of previous non-virtual token, including comments, + last_loc :: PsSpan, -- pos of current token + last_len :: !Int, -- len of current token + loc :: PsLoc, -- current loc (end of prev token + 1) + context :: [LayoutContext], + lex_state :: [Int], + srcfiles :: [FastString], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [PsLocated Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (PsLocated Token), + -- This is what we consider to be the location of the last token + -- emitted: + alr_last_loc :: PsSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool, + + -- The next three are used to implement Annotations giving the + -- locations of 'noise' tokens in the source, so that users of + -- the GHC API can do source to source conversions. + -- See Note [exact print annotations] in GHC.Parser.Annotation + eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token + header_comments :: Strict.Maybe [LEpaComment], + comment_q :: [LEpaComment], + + -- Haddock comments accumulated in ascending order of their location + -- (BufPos). We use OrdList to get O(1) snoc. + -- + -- See Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock + hdk_comments :: OrdList (PsLocated HdkComment) + } + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). + + -- AZ question: setLastToken which sets last_loc and last_len + -- is called when processing AlexToken, immediately prior to + -- calling the action in the token. So from the perspective + -- of the action, it is the *current* token. Do I understand + -- correctly? + +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + +-- | The parsing monad, isomorphic to @StateT PState Maybe@. +newtype P a = P { unP :: PState -> ParseResult a } + +instance Functor P where + fmap = liftM + +instance Applicative P where + pure = returnP + (<*>) = ap + +instance Monad P where + (>>=) = thenP + +returnP :: a -> P a +returnP a = a `seq` (P $ \s -> POk s a) + +thenP :: P a -> (a -> P b) -> P b +(P m) `thenP` k = P $ \ s -> + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed s1 -> PFailed s1 + +failMsgP :: (SrcSpan -> MsgEnvelope PsMessage) -> P a +failMsgP f = do + pState <- getPState + addFatalError (f (mkSrcSpanPs (last_loc pState))) + +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> MsgEnvelope PsMessage) -> P a +failLocMsgP loc1 loc2 f = + addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing)) + +getPState :: P PState +getPState = P $ \s -> POk s s + +getExts :: P ExtsBitmap +getExts = P $ \s -> POk s (pExtsBitmap . options $ s) + +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () +setExts f = P $ \s -> POk s { + options = + let p = options s + in p { pExtsBitmap = f (pExtsBitmap p) } + } () + +setSrcLoc :: RealSrcLoc -> P () +setSrcLoc new_loc = + P $ \s@(PState{ loc = PsLoc _ buf_loc }) -> + POk s{ loc = PsLoc new_loc buf_loc } () + +getRealSrcLoc :: P RealSrcLoc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s (psRealLoc loc) + +getParsedLoc :: P PsLoc +getParsedLoc = P $ \s@(PState{ loc=loc }) -> POk s loc + +addSrcFile :: FastString -> P () +addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () + +setEofPos :: RealSrcSpan -> RealSrcSpan -> P () +setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } () + +setLastToken :: PsSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, + last_len=len + } () + +setLastTk :: PsLocated Token -> P () +setLastTk tk@(L l _) = P $ \s -> + if isPointRealSpan (psRealSpan l) + then POk s { last_tk = Strict.Just tk } () + else POk s { last_tk = Strict.Just tk + , prev_loc = l } () + +setLastComment :: PsLocated Token -> P () +setLastComment (L l _) = P $ \s -> POk s { prev_loc = l } () + +getLastTk :: P (Strict.Maybe (PsLocated Token)) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + +-- see Note [PsSpan in Comments] +getLastLocIncludingComments :: P PsSpan +getLastLocIncludingComments = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc + +getLastLoc :: P PsSpan +getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc + +{-# INLINE alexGetChar' #-} +-- This version does not squash unicode characters, it is used when +-- lexing strings. +alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar' (AI loc s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) + where (c,s') = nextChar s + loc' = advancePsLoc loc c + +-- | Advance the given input N bytes. +advanceInputBytes :: Int -> AlexInput -> AlexInput +advanceInputBytes n i0@(AI _ buf0) = advanceInputTo (cur buf0 + n) i0 + +-- | Advance the given input to the given position. +advanceInputTo :: Int -> AlexInput -> AlexInput +advanceInputTo pos = go + where + go i@(AI _ buf) + | cur buf >= pos = i + | Just (_, i') <- alexGetChar' i = go i' + | otherwise = i -- reached the end, just return the last input + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) + +setInput :: AlexInput -> P () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () + +nextIsEOF :: P Bool +nextIsEOF = isEOF <$> getInput + +isEOF :: AlexInput -> Bool +isEOF (AI _ buf) = atEnd buf + +pushLexState :: Int -> P () +pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () + +popLexState :: P Int +popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls + +getLexState :: P Int +getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls + +popNextToken :: P (Maybe (PsLocated Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +resetAlrLastLoc :: FastString -> P () +resetAlrLastLoc file = + P $ \s@(PState {alr_last_loc = PsSpan _ buf_span}) -> + POk s{ alr_last_loc = PsSpan (alrInitialLoc file) buf_span } () + +setAlrLastLoc :: PsSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P PsSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + +setNextToken :: PsLocated Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (PsLocated Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [PsLocated Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + +-- | For reasons of efficiency, boolean parsing flags (eg, language extensions +-- or whether we are currently in a @RULE@ pragma) are represented by a bitmap +-- stored in a @Word64@. +type ExtsBitmap = Word64 + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +xset :: ExtBits -> ExtsBitmap -> ExtsBitmap +xset ext xmap = setBit xmap (fromEnum ext) + +xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap +xunset ext xmap = clearBit xmap (fromEnum ext) + +-- | Various boolean flags, mostly language extensions, that impact lexing and +-- parsing. Note that a handful of these can change during lexing/parsing. +data ExtBits + -- Flags that are constant once parsing starts + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ArrowsBit + | ThBit + | ThQuotesBit + | IpBit + | OverloadedLabelsBit -- #x overloaded labels + | ExplicitForallBit -- the 'forall' keyword + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | RecursiveDoBit -- mdo + | QualifiedDoBit -- .do and .mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedParensBit -- (# and #) + | DatatypeContextsBit + | MonadComprehensionsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | RawTokenStreamBit -- producing a token stream with all comments included + | AlternativeLayoutRuleBit + | ALRTransitionalBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + | HexFloatLiteralsBit + | StaticPointersBit + | NumericUnderscoresBit + | StarIsTypeBit + | BlockArgumentsBit + | NPlusKPatternsBit + | DoAndIfThenElseBit + | MultiWayIfBit + | GadtSyntaxBit + | ImportQualifiedPostBit + | LinearTypesBit + | NoLexicalNegationBit -- See Note [Why not LexicalNegationBit] + | OverloadedRecordDotBit + | OverloadedRecordUpdateBit + | OrPatternsBit + | ExtendedLiteralsBit + | ListTuplePunsBit + | ViewPatternsBit + | RequiredTypeArgumentsBit + | MultilineStringsBit + | LevelImportsBit + + -- Flags that are updated once parsing starts + | InRulePragBit + | InNestedCommentBit -- See Note [Nested comment line pragmas] + | UsePosPragsBit + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' + -- update the internal position. Otherwise, those pragmas are lexed as + -- tokens of their own. + deriving Enum + +{-# INLINE mkParserOpts #-} +mkParserOpts + :: EnumSet LangExt.Extension -- ^ permitted language extensions enabled + -> DiagOpts -- ^ diagnostic options + -> Bool -- ^ are safe imports on? + -> Bool -- ^ keeping Haddock comment tokens + -> Bool -- ^ keep regular comment tokens + + -> Bool + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update + -- the internal position kept by the parser. Otherwise, those pragmas are + -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. + + -> ParserOpts +-- ^ Given exactly the information needed, set up the 'ParserOpts' +mkParserOpts extensionFlags diag_opts + safeImports isHaddock rawTokStream usePosPrags = + ParserOpts { + pDiagOpts = diag_opts + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + } + where + safeHaskellBit = SafeHaskellBit `setBitIf` safeImports + langExtBits = + FfiBit `xoptBit` LangExt.ForeignFunctionInterface + .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI + .|. CApiFfiBit `xoptBit` LangExt.CApiFFI + .|. ArrowsBit `xoptBit` LangExt.Arrows + .|. ThBit `xoptBit` LangExt.TemplateHaskell + .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes + .|. QqBit `xoptBit` LangExt.QuasiQuotes + .|. IpBit `xoptBit` LangExt.ImplicitParams + .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels + .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll + .|. BangPatBit `xoptBit` LangExt.BangPatterns + .|. MagicHashBit `xoptBit` LangExt.MagicHash + .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo + .|. QualifiedDoBit `xoptBit` LangExt.QualifiedDo + .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax + .|. UnboxedParensBit `orXoptsBit` [LangExt.UnboxedTuples, LangExt.UnboxedSums] + .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts + .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp + .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions + .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule + .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional + .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout + .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation + .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax + .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces + .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase + .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals + .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals + .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals + .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms + .|. StaticPointersBit `xoptBit` LangExt.StaticPointers + .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores + .|. StarIsTypeBit `xoptBit` LangExt.StarIsType + .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments + .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns + .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse + .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf + .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax + .|. ImportQualifiedPostBit `xoptBit` LangExt.ImportQualifiedPost + .|. LinearTypesBit `xoptBit` LangExt.LinearTypes + .|. NoLexicalNegationBit `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit] + .|. OverloadedRecordDotBit `xoptBit` LangExt.OverloadedRecordDot + .|. OverloadedRecordUpdateBit `xoptBit` LangExt.OverloadedRecordUpdate -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information). + .|. OrPatternsBit `xoptBit` LangExt.OrPatterns + .|. ExtendedLiteralsBit `xoptBit` LangExt.ExtendedLiterals + .|. ListTuplePunsBit `xoptBit` LangExt.ListTuplePuns + .|. ViewPatternsBit `xoptBit` LangExt.ViewPatterns + .|. RequiredTypeArgumentsBit `xoptBit` LangExt.RequiredTypeArguments + .|. MultilineStringsBit `xoptBit` LangExt.MultilineStrings + .|. LevelImportsBit `xoptBit` LangExt.ExplicitLevelImports + optBits = + HaddockBit `setBitIf` isHaddock + .|. RawTokenStreamBit `setBitIf` rawTokStream + .|. UsePosPragsBit `setBitIf` usePosPrags + + xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags + xoptNotBit bit ext = bit `setBitIf` not (EnumSet.member ext extensionFlags) + + orXoptsBit bit exts = bit `setBitIf` any (`EnumSet.member` extensionFlags) exts + + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 + +disableHaddock :: ParserOpts -> ParserOpts +disableHaddock opts = upd_bitmap (xunset HaddockBit) + where + upd_bitmap f = opts { pExtsBitmap = f (pExtsBitmap opts) } + + +-- | Set parser options for parsing OPTIONS pragmas +initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState +initPragState options buf loc = (initParserState options buf loc) + { lex_state = [bol, option_prags, 0] + } + +-- | Creates a parse state from a 'ParserOpts' value +initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState +initParserState options buf loc = + PState { + buffer = buf, + options = options, + errors = emptyMessages, + warnings = emptyMessages, + tab_first = Strict.Nothing, + tab_count = 0, + last_tk = Strict.Nothing, + prev_loc = mkPsSpan init_loc init_loc, + last_loc = mkPsSpan init_loc init_loc, + last_len = 0, + loc = init_loc, + context = [], + lex_state = [bol, 0], + srcfiles = [], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = PsSpan (alrInitialLoc (fsLit "")) (BufSpan (BufPos 0) (BufPos 0)), + alr_context = [], + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + eof_pos = Strict.Nothing, + header_comments = Strict.Nothing, + comment_q = [], + hdk_comments = nilOL + } + where init_loc = PsLoc loc (BufPos 0) + +-- | An mtl-style class for monads that support parsing-related operations. +-- For example, sometimes we make a second pass over the parsing results to validate, +-- disambiguate, or rearrange them, and we do so in the PV monad which cannot consume +-- input but can report parsing errors, check for extension bits, and accumulate +-- parsing annotations. Both P and PV are instances of MonadP. +-- +-- MonadP grants us convenient overloading. The other option is to have separate operations +-- for each monad: addErrorP vs addErrorPV, getBitP vs getBitPV, and so on. +-- +class Monad m => MonadP m where + -- | Add a non-fatal error. Use this when the parser can produce a result + -- despite the error. + -- + -- For example, when GHC encounters a @forall@ in a type, + -- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ + -- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to + -- the accumulator. + -- + -- Control flow wise, non-fatal errors act like warnings: they are added + -- to the accumulator and parsing continues. This allows GHC to report + -- more than one parse error per file. + -- + addError :: MsgEnvelope PsMessage -> m () + + -- | Add a warning to the accumulator. + -- Use 'getPsMessages' to get the accumulated warnings. + addWarning :: MsgEnvelope PsMessage -> m () + + -- | Add a fatal error. This will be the last error reported by the parser, and + -- the parser will not produce any result, ending in a 'PFailed' state. + addFatalError :: MsgEnvelope PsMessage -> m a + + -- | Get parser options + getParserOpts :: m ParserOpts + + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that belong within the given span + allocateCommentsP :: RealSrcSpan -> m EpAnnComments + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that come before or within the given span + allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments + -- | Go through the @comment_q@ in @PState@ and remove all comments + -- that come after the given span + allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments + +instance MonadP P where + addError err + = P $ \s -> POk s { errors = err `addMessage` errors s} () + + -- If the warning is meant to be suppressed, GHC will assign + -- a `SevIgnore` severity and the message will be discarded, + -- so we can simply add it no matter what. + addWarning w + = P $ \s -> POk (s { warnings = w `addMessage` warnings s }) () + + addFatalError err = + addError err >> P PFailed + + getParserOpts = P $ \s -> POk s $! options s + + allocateCommentsP ss = P $ \s -> + if null (comment_q s) then POk s emptyComments else -- fast path + let (comment_q', newAnns) = allocateComments ss (comment_q s) in + POk s { + comment_q = comment_q' + } (EpaComments newAnns) + allocatePriorCommentsP ss = P $ \s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (comment_q s) (header_comments s) in + POk s { + header_comments = header_comments', + comment_q = comment_q' + } (EpaComments newAnns) + allocateFinalCommentsP ss = P $ \s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (comment_q s) (header_comments s) in + POk s { + header_comments = header_comments', + comment_q = comment_q' + } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) + +-- | Check if a given flag is currently set in the bitmap. +getBit :: MonadP m => ExtBits -> m Bool +getBit ext = (\opts -> ext `xtest` pExtsBitmap opts) <$> getParserOpts + +getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +getCommentsFor (RealSrcSpan l _) = allocateCommentsP l +getCommentsFor _ = return emptyComments + +getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l +getPriorCommentsFor _ = return emptyComments + +getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments +getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l +getFinalCommentsFor _ = return emptyComments + +getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan)) +getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos + +addPsMessage :: MonadP m => SrcSpan -> PsMessage -> m () +addPsMessage srcspan msg = do + diag_opts <- pDiagOpts <$> getParserOpts + addWarning (mkPlainMsgEnvelope diag_opts srcspan msg) + +addTabWarning :: RealSrcSpan -> P () +addTabWarning srcspan + = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> + let tf' = tf <|> Strict.Just srcspan + tc' = tc + 1 + s' = if warnopt Opt_WarnTabs o + then s{tab_first = tf', tab_count = tc'} + else s + in POk s' () + +-- | Get a bag of the errors that have been accumulated so far. +-- Does not take -Werror into account. +getPsErrorMessages :: PState -> Messages PsMessage +getPsErrorMessages p = errors p + +-- | Get the warnings and errors accumulated so far. +-- Does not take -Werror into account. +getPsMessages :: PState -> (Messages PsMessage, Messages PsMessage) +getPsMessages p = + let ws = warnings p + diag_opts = pDiagOpts (options p) + -- we add the tabulation warning on the fly because + -- we count the number of occurrences of tab characters + ws' = case tab_first p of + Strict.Nothing -> ws + Strict.Just tf -> + let msg = mkPlainMsgEnvelope diag_opts + (RealSrcSpan tf Strict.Nothing) + (PsWarnTab (tab_count p)) + in msg `addMessage` ws + in (ws', errors p) + +getContext :: P [LayoutContext] +getContext = P $ \s@PState{context=ctx} -> POk s ctx + +setContext :: [LayoutContext] -> P () +setContext ctx = P $ \s -> POk s{context=ctx} () + +popContext :: P () +popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, + last_len = len, last_loc = last_loc }) -> + case ctx of + (_:tl) -> + POk s{ context = tl } () + [] -> + unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s + +-- Push a new layout context at the indentation of the last token read. +pushCurrentContext :: GenSemic -> P () +pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol (psRealSpan loc)) gen_semic : ctx} () + +-- This is only used at the outer level of a module when the 'module' keyword is +-- missing. +pushModuleContext :: P () +pushModuleContext = pushCurrentContext generateSemic + +getOffside :: P (Ordering, Bool) +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol (psRealSpan loc) in + let ord = case stk of + Layout n gen_semic : _ -> + --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + (compare offs n, gen_semic) + _ -> + (GT, dontGenerateSemic) + in POk s ord + +-- --------------------------------------------------------------------------- +-- Construct a parse error + +srcParseErr + :: ParserOpts + -> StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token + -> SrcSpan + -> MsgEnvelope PsMessage +srcParseErr options buf len loc = mkPlainErrorMsgEnvelope loc (PsErrParse token details) + where + token = lexemeToString (offsetBytes (-len) buf) len + pattern_ = decodePrevNChars 8 buf + last100 = decodePrevNChars 100 buf + doInLast100 = "do" `isInfixOf` last100 + mdoInLast100 = "mdo" `isInfixOf` last100 + th_enabled = ThQuotesBit `xtest` pExtsBitmap options + ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options + details = PsErrParseDetails { + ped_th_enabled = th_enabled + , ped_do_in_last_100 = doInLast100 + , ped_mdo_in_last_100 = mdoInLast100 + , ped_pat_syn_enabled = ps_enabled + , ped_pattern_parsed = pattern_ == "pattern " + } + +-- Report a parse failure, giving the span of the previous token as +-- the location of the error. This is the entry point for errors +-- detected during parsing. +srcParseFail :: P a +srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, + last_loc = last_loc } -> + unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s + +-- A lexical error is reported at a particular position in the source file, +-- not over a token range. +lexError :: LexErr -> P a +lexError e = do + loc <- getRealSrcLoc + (AI end buf) <- getInput + reportLexError loc (psRealLoc end) buf + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer e k) + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +lexer, lexerDbg :: Bool -> (Located Token -> P a) -> P a + +lexer queueComments cont = do + alr <- getBit AlternativeLayoutRuleBit + let lexTokenFun = if alr then lexTokenAlr else lexToken + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + + if (queueComments && isComment tok) + then queueComment (L (psRealSpan span) tok) >> lexer queueComments cont + else cont (L (mkSrcSpanPs span) tok) + +-- Use this instead of 'lexer' in GHC.Parser to dump the tokens for debugging. +lexerDbg queueComments cont = lexer queueComments contDbg + where + contDbg tok = trace ("token: " ++ show (unLoc tok)) (cont tok) + +lexTokenAlr :: P (PsLocated Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getLoc t) + case unLoc t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITlcases -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo _ -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: PsLocated Token -> P (PsLocated Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + transitional <- getBit ALRTransitionalBit + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + let thisLoc = getLoc t + thisCol = srcSpanStartCol (psRealSpan thisLoc) + newLine = srcSpanStartLine (psRealSpan thisLoc) > srcSpanEndLine (psRealSpan lastLoc) + case (unLoc t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just alrLayout) -> + do setAlrExpectingOCurly Nothing + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : _ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIndentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITvccurly] + setNextToken t + return (L lastLoc ITvocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Where) + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addPsMessage + (mkSrcSpanPs thisLoc) + (PsWarnTransitionalLayout TransLayout_Pipe) + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + let loc = psSpanStart thisLoc + zeroWidthLoc = mkPsSpan loc loc + return (L zeroWidthLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- We need to handle close before open, as 'then' is both + -- an open and a close + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True + return t + [] -> + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else [] + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITelse = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIndentation :: ALRLayout -> Bool +isNonDecreasingIndentation ALRLayoutDo = True +isNonDecreasingIndentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b + +#ifdef MIN_TOOL_VERSION_alex +#if !MIN_TOOL_VERSION_alex(3,5,2) +-- If the generated alexScan/alexScanUser functions are called multiple times +-- in this file, alexScanUser gets broken out into a separate function and +-- increases memory usage. Make sure GHC inlines this function and optimizes it. +-- https://github.com/haskell/alex/pull/262 +{-# INLINE alexScanUser #-} +#endif +#endif + +lexToken :: P (PsLocated Token) +lexToken = do + inp@(AI loc1 buf) <- getInput + sc <- getLexState + exts <- getExts + case alexScanUser exts inp sc of + AlexEOF -> do + let span = mkPsSpan loc1 loc1 + lc <- getLastLocIncludingComments + setEofPos (psRealSpan span) (psRealSpan lc) + setLastToken span 0 + return (L span ITeof) + AlexError (AI loc2 buf) -> + reportLexError (psRealLoc loc1) (psRealLoc loc2) buf + (\k srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrLexer LexError k) + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(AI end buf2) _ t -> do + setInput inp2 + let span = mkPsSpan loc1 end + let bytes = byteDiff buf buf2 + span `seq` setLastToken span bytes + lt <- t span buf bytes buf2 + let lt' = unLoc lt + if (isComment lt') then setLastComment lt else setLastTk lt + return lt + +reportLexError :: RealSrcLoc + -> RealSrcLoc + -> StringBuffer + -> (LexErrKind -> SrcSpan -> MsgEnvelope PsMessage) + -> P a +reportLexError loc1 loc2 buf f + | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF) + | otherwise = + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (f LexErrKind_UTF8) + else failLocMsgP loc1 loc2 (f (LexErrKind_Char c)) + +lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token] +lexTokenStream opts buf loc = unP go initState{ options = opts' } + where + new_exts = xunset UsePosPragsBit -- parse LINE/COLUMN pragmas as tokens + $ xset RawTokenStreamBit -- include comments + $ pExtsBitmap opts + opts' = opts { pExtsBitmap = new_exts } + initState = initParserState opts' buf loc + go = do + ltok <- lexer False return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + +linePrags = Map.singleton "line" linePrag + +fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), + ("options_ghc", lex_string_prag IToptions_prag), + ("options_haddock", lex_string_prag_comment ITdocOptions), + ("language", token ITlanguage_prag), + ("include", lex_string_prag ITinclude_prag)]) + +ignoredPrags = Map.fromList (map ignored pragmas) + where ignored opt = (opt, nested_comment) + impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] + options_pragmas = map ("options_" ++) impls + -- CFILES is a hugs-only thing. + pragmas = options_pragmas ++ ["cfiles", "contract"] + +oneWordPrags = Map.fromList [ + ("rules", rulePrag), + ("inline", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))), + ("inlinable", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), + ("inlineable", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), + -- Spelling variant + ("notinline", + fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))), + ("opaque", fstrtoken (\s -> ITopaque_prag (SourceText s))), + ("specialize", fstrtoken (\s -> ITspec_prag (SourceText s))), + ("source", fstrtoken (\s -> ITsource_prag (SourceText s))), + ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))), + ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))), + ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))), + ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))), + ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))), + ("ann", fstrtoken (\s -> ITann_prag (SourceText s))), + ("minimal", fstrtoken (\s -> ITminimal_prag (SourceText s))), + ("overlaps", fstrtoken (\s -> IToverlaps_prag (SourceText s))), + ("overlappable", fstrtoken (\s -> IToverlappable_prag (SourceText s))), + ("overlapping", fstrtoken (\s -> IToverlapping_prag (SourceText s))), + ("incoherent", fstrtoken (\s -> ITincoherent_prag (SourceText s))), + ("ctype", fstrtoken (\s -> ITctype (SourceText s))), + ("complete", fstrtoken (\s -> ITcomplete_prag (SourceText s))), + ("column", columnPrag) + ] + +twoWordPrags = Map.fromList [ + ("inline conlike", + fstrtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))), + ("notinline conlike", + fstrtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))), + ("specialize inline", + fstrtoken (\s -> (ITspec_inline_prag (SourceText s) True))), + ("specialize notinline", + fstrtoken (\s -> (ITspec_inline_prag (SourceText s) False))) + ] + +dispatch_pragmas :: Map String Action -> Action +dispatch_pragmas prags span buf len buf2 = + case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len buf2 + Nothing -> lexError LexUnknownPragma + +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' + +clean_pragma :: String -> String +clean_pragma prag = canon_ws (map toLower (unprefix prag)) + where unprefix prag' = case stripPrefix "{-#" prag' of + Just rest -> rest + Nothing -> prag' + canonical prag' = case prag' of + "noinline" -> "notinline" + "specialise" -> "specialize" + "constructorlike" -> "conlike" + _ -> prag' + canon_ws s = unwords (map canonical (words s)) + +warn_unknown_prag :: Map String Action -> Action +warn_unknown_prag prags span buf len buf2 = do + let uppercase = map toUpper + unknown_prag = uppercase (clean_pragma (lexemeToString buf len)) + suggestions = map uppercase (Map.keys prags) + addPsMessage (RealSrcSpan (psRealSpan span) Strict.Nothing) $ + PsWarnUnrecognisedPragma unknown_prag suggestions + nested_comment span buf len buf2 + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ +-} + +-- TODO:AZ: we should have only mkParensEpToks. Delee mkParensEpAnn, mkParensLocs + +-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'EpToken' values for the opening and closing bordering on the start +-- and end of the span +mkParensEpToks :: RealSrcSpan -> (EpToken "(", EpToken ")") +mkParensEpToks ss = (EpTok (EpaSpan (RealSrcSpan lo Strict.Nothing)), + EpTok (EpaSpan (RealSrcSpan lc Strict.Nothing))) + where + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) + lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) + + +-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'EpaLocation' values for the opening and closing bordering on the start +-- and end of the span +mkParensLocs :: RealSrcSpan -> (EpaLocation, EpaLocation) +mkParensLocs ss = (EpaSpan (RealSrcSpan lo Strict.Nothing), + EpaSpan (RealSrcSpan lc Strict.Nothing)) + where + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1)) + lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss) + +queueComment :: RealLocated Token -> P() +queueComment c = P $ \s -> POk s { + comment_q = commentToAnnotation c : comment_q s + } () + +allocateComments + :: RealSrcSpan + -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) +allocateComments ss comment_q = + let + (before,rest) = break (\(L l _) -> isRealSubspanOf (epaLocationRealSrcSpan l) ss) comment_q + (middle,after) = break (\(L l _) -> not (isRealSubspanOf (epaLocationRealSrcSpan l) ss)) rest + comment_q' = before ++ after + newAnns = middle + in + (comment_q', reverse newAnns) + +-- Comments appearing without a line-break before the first +-- declaration are associated with the declaration +splitPriorComments + :: RealSrcSpan + -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) +splitPriorComments ss prior_comments = + let + -- True if there is only one line between the earlier and later span, + -- And the token preceding the comment is on a different line + cmp :: RealSrcSpan -> LEpaComment -> Bool + cmp later (L l c) + = srcSpanStartLine later - srcSpanEndLine (epaLocationRealSrcSpan l) == 1 + && srcSpanEndLine (ac_prior_tok c) /= srcSpanStartLine (epaLocationRealSrcSpan l) + + go :: [LEpaComment] -> RealSrcSpan -> [LEpaComment] + -> ([LEpaComment], [LEpaComment]) + go decl_comments _ [] = ([],decl_comments) + go decl_comments r (c@(L l _):cs) = if cmp r c + then go (c:decl_comments) (epaLocationRealSrcSpan l) cs + else (reverse (c:cs), decl_comments) + in + go [] ss prior_comments + +allocatePriorComments + :: RealSrcSpan + -> [LEpaComment] + -> Strict.Maybe [LEpaComment] + -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) +allocatePriorComments ss comment_q mheader_comments = + let + cmp (L l _) = epaLocationRealSrcSpan l <= ss + (newAnns,after) = partition cmp comment_q + comment_q'= after + (prior_comments, decl_comments) = splitPriorComments ss newAnns + in + case mheader_comments of + Strict.Nothing -> (Strict.Just prior_comments, comment_q', decl_comments) + Strict.Just _ -> (mheader_comments, comment_q', reverse newAnns) + +allocateFinalComments + :: RealSrcSpan + -> [LEpaComment] + -> Strict.Maybe [LEpaComment] + -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) +allocateFinalComments _ss comment_q mheader_comments = + -- We ignore the RealSrcSpan as the parser currently provides a + -- point span at (1,1). + case mheader_comments of + Strict.Nothing -> (Strict.Just (reverse comment_q), [], []) + Strict.Just _ -> (mheader_comments, [], reverse comment_q) + +commentToAnnotation :: RealLocated Token -> LEpaComment +commentToAnnotation (L l (ITdocComment s ll)) = mkLEpaComment l ll (EpaDocComment s) +commentToAnnotation (L l (ITdocOptions s ll)) = mkLEpaComment l ll (EpaDocOptions s) +commentToAnnotation (L l (ITlineComment s ll)) = mkLEpaComment l ll (EpaLineComment s) +commentToAnnotation (L l (ITblockComment s ll)) = mkLEpaComment l ll (EpaBlockComment s) +commentToAnnotation _ = panic "commentToAnnotation" + +-- see Note [PsSpan in Comments] +mkLEpaComment :: RealSrcSpan -> PsSpan -> EpaCommentTok -> LEpaComment +mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll)) + +-- --------------------------------------------------------------------- + +isComment :: Token -> Bool +isComment (ITlineComment _ _) = True +isComment (ITblockComment _ _) = True +isComment (ITdocComment _ _) = True +isComment (ITdocOptions _ _) = True +isComment _ = False diff --git a/GHC/Parser/Lexer/Interface.hs b/GHC/Parser/Lexer/Interface.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Lexer/Interface.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE MagicHash #-} + +{- | +This module defines the types and functions necessary for an Alex-generated +lexer. + +https://haskell-alex.readthedocs.io/en/latest/api.html# +-} +module GHC.Parser.Lexer.Interface ( + AlexInput (..), + alexGetByte, + alexInputPrevChar, + + -- * Helpers + alexGetChar, + adjustChar, +) where + +import GHC.Prelude + +import Data.Char (GeneralCategory (..), generalCategory, ord) +import Data.Word (Word8) +import GHC.Data.StringBuffer (StringBuffer, atEnd, nextChar, prevChar) +import GHC.Exts +import GHC.Types.SrcLoc (PsLoc, advancePsLoc) + +data AlexInput = AI !PsLoc !StringBuffer deriving (Show) + +-- See Note [Unicode in Alex] +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (AI loc s) + | atEnd s = Nothing + | otherwise = byte `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (byte, (AI loc' s')) + where (c,s') = nextChar s + loc' = advancePsLoc loc c + byte = adjustChar c + +-- Getting the previous 'Char' isn't enough here - we need to convert it into +-- the same format that 'alexGetByte' would have produced. +-- +-- See Note [Unicode in Alex] and #13986. +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI _ buf) = unsafeChr (fromIntegral (adjustChar pc)) + where pc = prevChar buf '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = unsafeChr $ fromIntegral b + +unsafeChr :: Int -> Char +unsafeChr (I# c) = GHC.Exts.C# (GHC.Exts.chr# c) + +{- +Note [Unicode in Alex] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although newer versions of Alex support unicode, this grammar is processed with +the old style '--latin1' behaviour. This means that when implementing the +functions + + alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) + alexInputPrevChar :: AlexInput -> Char + +which Alex uses to take apart our 'AlexInput', we must + + * return a latin1 character in the 'Word8' that 'alexGetByte' expects + * return a latin1 character in 'alexInputPrevChar'. + +We handle this in 'adjustChar' by squishing entire classes of unicode +characters into single bytes. +-} + +{-# INLINE adjustChar #-} +adjustChar :: Char -> Word8 +adjustChar c = adj_c + where non_graphic = 0x00 + upper = 0x01 + lower = 0x02 + digit = 0x03 + symbol = 0x04 + space = 0x05 + other_graphic = 0x06 + uniidchar = 0x07 + + adj_c + | c <= '\x07' = non_graphic + | c <= '\x7f' = fromIntegral (ord c) + -- Alex doesn't handle Unicode, so when Unicode + -- character is encountered we output these values + -- with the actual character value hidden in the state. + | otherwise = + -- NB: The logic behind these definitions is also reflected + -- in "GHC.Utils.Lexeme" + -- Any changes here should likely be reflected there. + + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> uniidchar -- see #10196 + OtherLetter -> lower -- see #1103 + NonSpacingMark -> uniidchar -- see #7650 + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> digit + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic diff --git a/GHC/Parser/Lexer/String.hs b/GHC/Parser/Lexer/String.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/Lexer/String.hs @@ -0,0 +1,353 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LINE 1 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer/String.x" #-} +{- | +This module defines lex states for strings. + +This needs to be separate from the normal lexer because the normal lexer +automatically includes rules like skipping whitespace or lexing comments, +which we don't want in these contexts. +-} +module GHC.Parser.Lexer.String ( + AlexReturn (..), + alexScan, + string_multi_content, +) where + +import GHC.Prelude + +import GHC.Parser.Lexer.Interface +import GHC.Utils.Panic (panic) +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array.Base (unsafeAt) +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x00\x00\x00\x00\x01\x00\x00\x00\x40\x00\x00\x00\xdf\xff\xff\xff\x70\x00\x00\x00\xb7\x00\x00\x00\x2f\x01\x00\x00\xe7\xff\xff\xff\xe6\xff\xff\xff\xbe\xff\xff\xff\xc5\xff\xff\xff\x76\x00\x00\x00\xcb\xff\xff\xff\xd0\xff\xff\xff\x6a\x00\x00\x00\xcc\xff\xff\xff\xc9\xff\xff\xff\xad\x01\x00\x00\xfc\xff\xff\xff\x84\x00\x00\x00\x00\x00\x00\x00\x27\x02\x00\x00\xc7\xff\xff\xff\x67\x00\x00\x00\x57\x00\x00\x00\x7a\x00\x00\x00\x5e\x00\x00\x00\x61\x00\x00\x00\x75\x00\x00\x00\x87\x00\x00\x00\x68\x00\x00\x00\x30\x02\x00\x00\x5e\x02\x00\x00\x6d\x00\x00\x00\x8c\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x14\x00\x11\x00\x06\x00\x0d\x00\x06\x00\x06\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\xff\xff\x11\x00\x1b\x00\x11\x00\x11\x00\x07\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x05\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x0d\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x0f\x00\x18\x00\x1b\x00\x1a\x00\x15\x00\x09\x00\x22\x00\x11\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x11\x00\x11\x00\x08\x00\x11\x00\x1b\x00\x16\x00\x21\x00\x11\x00\x11\x00\x11\x00\x1a\x00\x0a\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x15\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x19\x00\x13\x00\x0e\x00\x1d\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x10\x00\x0b\x00\x00\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x02\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x03\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x04\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x06\x00\x06\x00\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x20\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x06\x00\x00\x00\x06\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x05\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x15\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x11\x00\x00\x00\x00\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x1c\x00\x19\x00\x13\x00\x0e\x00\x1d\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x10\x00\x0b\x00\x00\x00\x10\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x02\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x03\x00\x00\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x11\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x43\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x22\x00\x45\x00\x0a\x00\x41\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x31\x00\x32\x00\x33\x00\x34\x00\x4b\x00\x53\x00\x51\x00\x22\x00\x58\x00\x55\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x43\x00\x54\x00\x4e\x00\x4c\x00\x46\x00\x42\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x4d\x00\x4e\x00\x4f\x00\x45\x00\x41\x00\x05\x00\x53\x00\x54\x00\x49\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x4f\x00\x50\x00\x43\x00\x53\x00\x45\x00\x54\x00\x55\x00\x52\x00\x46\x00\x42\x00\x59\x00\x4c\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x20\x00\xff\xff\x22\x00\x53\x00\xff\xff\xff\xff\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\x09\x00\x0a\x00\xff\xff\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\x5c\x00\x26\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\x6f\x00\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\x76\x00\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 34) + [ AlexAccSkip + , AlexAcc 4 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 3 + , AlexAccPred 2 (alexRightContext 18)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAcc 1 + , AlexAccNone + , AlexAccNone + , AlexAccPred 0 (alexRightContext 18)(AlexAccNone) + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + ] + +alex_actions = array (0 :: Int, 5) + [ (4,alex_action_1) + , (3,alex_action_1) + , (2,alex_action_2) + , (1,alex_action_1) + , (0,alex_action_2) + ] + + +string_multi_content :: Int +string_multi_content = 1 +alex_action_1 = string_multi_content_action +alex_action_2 = string_multi_content_action + +#define ALEX_GHC 1 +#define ALEX_LATIN1 1 +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + +#ifdef ALEX_GHC +# define ILIT(n) n# +# define IBOX(n) (I# (n)) +# define FAST_INT Int# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +# if __GLASGOW_HASKELL__ > 706 +# define GTE(n,m) (tagToEnum# (n >=# m)) +# define EQ(n,m) (tagToEnum# (n ==# m)) +# else +# define GTE(n,m) (n >=# m) +# define EQ(n,m) (n ==# m) +# endif +# define PLUS(n,m) (n +# m) +# define MINUS(n,m) (n -# m) +# define TIMES(n,m) (n *# m) +# define NEGATE(n) (negateInt# (n)) +# define IF_GHC(x) (x) +#else +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Int +# define GTE(n,m) (n >= m) +# define EQ(n,m) (n == m) +# define PLUS(n,m) (n + m) +# define MINUS(n,m) (n - m) +# define TIMES(n,m) (n * m) +# define NEGATE(n) (negate (n)) +# define IF_GHC(x) +#endif + +#ifdef ALEX_GHC +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else +#if __GLASGOW_HASKELL__ >= 901 + int16ToInt# +#endif + (indexInt16OffAddr# arr off) +#endif +#else +alexIndexInt16OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else +#if __GLASGOW_HASKELL__ >= 901 + int32ToInt# +#endif + (indexInt32OffAddr# arr off) +#endif +#else +alexIndexInt32OffAddr arr off = arr ! off +#endif + +#ifdef ALEX_GHC + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif +#else +quickIndex arr i = arr ! i +#endif + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ IBOX(sc) + = alexScanUser undefined input__ IBOX(sc) + +alexScanUser user__ input__ IBOX(sc) + = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> +#ifdef ALEX_DEBUG + trace ("End of input.") $ +#endif + AlexEOF + Just _ -> +#ifdef ALEX_DEBUG + trace ("Error.") $ +#endif + AlexError input__' + + (AlexLastSkip input__'' len, _) -> +#ifdef ALEX_DEBUG + trace ("Skipping.") $ +#endif + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> +#ifdef ALEX_DEBUG + trace ("Accept.") $ +#endif + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` IBOX(s))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> +#ifdef ALEX_DEBUG + trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $ +#endif + case fromIntegral c of { IBOX(ord_c) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = PLUS(base,ord_c) + + new_s = if GTE(offset,ILIT(0)) + && let check = alexIndexInt16OffAddr alex_check offset + in EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + ILIT(-1) -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input +#ifdef ALEX_LATIN1 + PLUS(len,ILIT(1)) + -- issue 119: in the latin1 encoding, *each* byte is one character +#else + (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) +#endif + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ IBOX(len) + check_accs (AlexAccSkip) = AlexLastSkip input__ IBOX(len) +#ifndef ALEX_NOPRED + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastAcc a input__ IBOX(len) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input IBOX(len) input__ + = AlexLastSkip input__ IBOX(len) + | otherwise + = check_accs rest +#endif + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip +#ifndef ALEX_NOPRED + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext IBOX(sc) user__ _ _ input__ = + case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. +#endif +{-# LINE 91 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Parser/Lexer/String.x" #-} +-- | Dummy action that should never be called. Should only be used in lex states +-- that are manually lexed in tok_string_multi. +string_multi_content_action :: a +string_multi_content_action = panic "string_multi_content_action unexpectedly invoked" diff --git a/GHC/Parser/PostProcess.hs b/GHC/Parser/PostProcess.hs --- a/GHC/Parser/PostProcess.hs +++ b/GHC/Parser/PostProcess.hs @@ -1,3193 +1,3787 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DataKinds #-} - --- --- (c) The University of Glasgow 2002-2006 --- - --- Functions over HsSyn specialised to RdrName. - -module GHC.Parser.PostProcess ( - mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot - mkHsOpApp, - mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkSpliceDecl, - mkRoleAnnotDecl, - mkClassDecl, - mkTyData, mkDataFamInst, - mkTySynonym, mkTyFamInstEqn, - mkStandaloneKindSig, - mkTyFamInst, - mkFamDecl, - mkInlinePragma, - mkOpaquePragma, - mkPatSynMatchGroup, - mkRecConstrOrUpdate, - mkTyClD, mkInstD, - mkRdrRecordCon, mkRdrRecordUpd, - setRdrNameSpace, - fromSpecTyVarBndr, fromSpecTyVarBndrs, - annBinds, - fixValbindsAnn, - stmtsAnchor, stmtsLoc, - - cvBindGroup, - cvBindsAndSigs, - cvTopDecls, - placeHolderPunRhs, - - -- Stuff to do with Foreign declarations - mkImport, - parseCImport, - mkExport, - mkExtName, -- RdrName -> CLabelString - mkGadtDecl, -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName - mkConDeclH98, - - -- Bunch of functions in the parser monad for - -- checking and constructing values - checkImportDecl, - checkExpBlockArguments, checkCmdBlockArguments, - checkPrecP, -- Int -> P Int - checkContext, -- HsType -> P HsContext - checkPattern, -- HsExp -> P HsPat - checkPattern_details, - incompleteDoBlock, - ParseContext(..), - checkMonadComp, -- P (HsStmtContext GhcPs) - checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - checkValSigLhs, - LRuleTyTmVar, RuleTyTmVar(..), - mkRuleBndrs, mkRuleTyVarBndrs, - checkRuleTyVarBndrNames, - checkRecordSyntax, - checkEmptyGADTs, - addFatalError, hintBangPat, - mkBangTy, - UnpackednessPragma(..), - mkMultTy, - - -- Token location - mkTokenLocation, - - -- Help with processing exports - ImpExpSubSpec(..), - ImpExpQcSpec(..), - mkModuleImpExp, - mkTypeImpExp, - mkImpExpSubSpec, - checkImportSpec, - - -- Token symbols - starSym, - - -- Warnings and errors - warnStarIsType, - warnPrepositiveQualifiedModule, - failOpFewArgs, - failNotEnabledImportQualifiedPost, - failImportQualifiedTwice, - - SumOrTuple (..), - - -- Expression/command/pattern ambiguity resolution - PV, - runPV, - ECP(ECP, unECP), - DisambInfixOp(..), - DisambECP(..), - ecpFromExp, - ecpFromCmd, - PatBuilder, - - -- Type/datacon ambiguity resolution - DisambTD(..), - addUnpackednessP, - dataConBuilderCon, - dataConBuilderDetails, - ) where - -import GHC.Prelude -import GHC.Hs -- Lots of it -import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) -import GHC.Core.DataCon ( DataCon, dataConTyCon ) -import GHC.Core.ConLike ( ConLike(..) ) -import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) -import GHC.Types.Name.Reader -import GHC.Types.Name -import GHC.Types.Basic -import GHC.Types.Error -import GHC.Types.Fixity -import GHC.Types.Hint -import GHC.Types.SourceText -import GHC.Parser.Types -import GHC.Parser.Lexer -import GHC.Parser.Errors.Types -import GHC.Parser.Errors.Ppr () -import GHC.Utils.Lexeme ( okConOcc ) -import GHC.Types.TyThing -import GHC.Core.Type ( Specificity(..) ) -import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, - nilDataConName, nilDataConKey, - listTyConName, listTyConKey, - unrestrictedFunTyCon ) -import GHC.Types.ForeignCall -import GHC.Types.SrcLoc -import GHC.Types.Unique ( hasKey ) -import GHC.Data.OrdList -import GHC.Utils.Outputable as Outputable -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Utils.Error -import GHC.Utils.Misc -import Data.Either -import Data.List ( findIndex ) -import Data.Foldable -import qualified Data.Semigroup as Semi -import GHC.Unit.Module.Warnings -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import qualified GHC.Data.Strict as Strict - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Control.Monad -import Text.ParserCombinators.ReadP as ReadP -import Data.Char -import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) -import Data.Kind ( Type ) -import Data.List.NonEmpty (NonEmpty) - -{- ********************************************************************** - - Construction functions for Rdr stuff - - ********************************************************************* -} - --- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and --- datacon by deriving them from the name of the class. We fill in the names --- for the tycon and datacon corresponding to the class, by deriving them --- from the name of the class itself. This saves recording the names in the --- interface file (which would be equally good). - --- Similarly for mkConDecl, mkClassOpSig and default-method names. - --- *** See Note [The Naming story] in GHC.Hs.Decls **** - -mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkTyClD (L loc d) = L loc (TyClD noExtField d) - -mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) -mkInstD (L loc d) = L loc (InstD noExtField d) - -mkClassDecl :: SrcSpan - -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) - -> Located (a,[LHsFunDep GhcPs]) - -> OrdList (LHsDecl GhcPs) - -> LayoutInfo GhcPs - -> [AddEpAnn] - -> P (LTyClDecl GhcPs) - -mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn - = do { let loc = noAnnSrcSpan loc' - ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls - ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; tyvars <- checkTyVars (text "class") whereDots cls tparams - ; cs <- getCommentsFor (locA loc) -- Get any remaining comments - ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs - ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey) - , tcdLayout = layoutInfo - , tcdCtxt = mcxt - , tcdLName = cls, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdFDs = snd (unLoc fds) - , tcdSigs = mkClassOpSigs sigs - , tcdMeths = binds - , tcdATs = ats, tcdATDefs = at_defs - , tcdDocs = docs })) } - -mkTyData :: SrcSpan - -> Bool - -> NewOrData - -> Maybe (LocatedP CType) - -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) - -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] - -> Located (HsDeriving GhcPs) - -> [AddEpAnn] - -> P (LTyClDecl GhcPs) -mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) - ksig data_cons (L _ maybe_deriv) annsIn - = do { let loc = noAnnSrcSpan loc' - ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams - ; cs <- getCommentsFor (locA loc) -- Get any remaining comments - ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs - ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons - ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv - ; return (L loc (DataDecl { tcdDExt = anns', - tcdLName = tc, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn })) } - -mkDataDefn :: Maybe (LocatedP CType) - -> Maybe (LHsContext GhcPs) - -> Maybe (LHsKind GhcPs) - -> DataDefnCons (LConDecl GhcPs) - -> HsDeriving GhcPs - -> P (HsDataDefn GhcPs) -mkDataDefn cType mcxt ksig data_cons maybe_deriv - = do { checkDatatypeContext mcxt - ; return (HsDataDefn { dd_ext = noExtField - , dd_cType = cType - , dd_ctxt = mcxt - , dd_cons = data_cons - , dd_kindSig = ksig - , dd_derivs = maybe_deriv }) } - -mkTySynonym :: SrcSpan - -> LHsType GhcPs -- LHS - -> LHsType GhcPs -- RHS - -> [AddEpAnn] - -> P (LTyClDecl GhcPs) -mkTySynonym loc lhs rhs annsIn - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; tyvars <- checkTyVars (text "type") equalsDots tc tparams - ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2) - ; return (L (noAnnSrcSpan loc) (SynDecl - { tcdSExt = anns' - , tcdLName = tc, tcdTyVars = tyvars - , tcdFixity = fixity - , tcdRhs = rhs })) } - -mkStandaloneKindSig - :: SrcSpan - -> Located [LocatedN RdrName] -- LHS - -> LHsSigType GhcPs -- RHS - -> [AddEpAnn] - -> P (LStandaloneKindSig GhcPs) -mkStandaloneKindSig loc lhs rhs anns = - do { vs <- mapM check_lhs_name (unLoc lhs) - ; v <- check_singular_lhs (reverse vs) - ; cs <- getCommentsFor loc - ; return $ L (noAnnSrcSpan loc) - $ StandaloneKindSig (EpAnn (spanAsAnchor loc) anns cs) v rhs } - where - check_lhs_name v@(unLoc->name) = - if isUnqual name && isTcOcc (rdrNameOcc name) - then return v - else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $ - (PsErrUnexpectedQualifiedConstructor (unLoc v)) - check_singular_lhs vs = - case vs of - [] -> panic "mkStandaloneKindSig: empty left-hand side" - [v] -> return v - _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $ - (PsErrMultipleNamesInStandaloneKindSignature vs) - -mkTyFamInstEqn :: SrcSpan - -> HsOuterFamEqnTyVarBndrs GhcPs - -> LHsType GhcPs - -> LHsType GhcPs - -> [AddEpAnn] - -> P (LTyFamInstEqn GhcPs) -mkTyFamInstEqn loc bndrs lhs rhs anns - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; cs <- getCommentsFor loc - ; return (L (noAnnSrcSpan loc) $ FamEqn - { feqn_ext = EpAnn (spanAsAnchor loc) (anns `mappend` ann) cs - , feqn_tycon = tc - , feqn_bndrs = bndrs - , feqn_pats = tparams - , feqn_fixity = fixity - , feqn_rhs = rhs })} - -mkDataFamInst :: SrcSpan - -> NewOrData - -> Maybe (LocatedP CType) - -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs - , LHsType GhcPs) - -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] - -> Located (HsDeriving GhcPs) - -> [AddEpAnn] - -> P (LInstDecl GhcPs) -mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) - ksig data_cons (L _ maybe_deriv) anns - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan - ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments - ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons - ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv - ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl - (FamEqn { feqn_ext = fam_eqn_ans - , feqn_tycon = tc - , feqn_bndrs = bndrs - , feqn_pats = tparams - , feqn_fixity = fixity - , feqn_rhs = defn })))) } - --- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) --- ksig data_cons (L _ maybe_deriv) anns --- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr --- ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan --- ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments --- ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv --- ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl --- (FamEqn { feqn_ext = anns' --- , feqn_tycon = tc --- , feqn_bndrs = bndrs --- , feqn_pats = tparams --- , feqn_fixity = fixity --- , feqn_rhs = defn })))) } - - - -mkTyFamInst :: SrcSpan - -> TyFamInstEqn GhcPs - -> [AddEpAnn] - -> P (LInstDecl GhcPs) -mkTyFamInst loc eqn anns = do - cs <- getCommentsFor loc - return (L (noAnnSrcSpan loc) (TyFamInstD noExtField - (TyFamInstDecl (EpAnn (spanAsAnchor loc) anns cs) eqn))) - -mkFamDecl :: SrcSpan - -> FamilyInfo GhcPs - -> TopLevelFlag - -> LHsType GhcPs -- LHS - -> LFamilyResultSig GhcPs -- Optional result signature - -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation - -> [AddEpAnn] - -> P (LTyClDecl GhcPs) -mkFamDecl loc info topLevel lhs ksig injAnn annsIn - = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams - ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2) - ; return (L (noAnnSrcSpan loc) (FamDecl noExtField - (FamilyDecl - { fdExt = anns' - , fdTopLevel = topLevel - , fdInfo = info, fdLName = tc - , fdTyVars = tyvars - , fdFixity = fixity - , fdResultSig = ksig - , fdInjectivityAnn = injAnn }))) } - where - equals_or_where = case info of - DataFamily -> empty - OpenTypeFamily -> empty - ClosedTypeFamily {} -> whereDots - -mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs) --- If the user wrote --- [pads| ... ] then return a QuasiQuoteD --- $(e) then return a SpliceD --- but if they wrote, say, --- f x then behave as if they'd written $(f x) --- ie a SpliceD --- --- Typed splices are not allowed at the top level, thus we do not represent them --- as spliced declaration. See #10945 -mkSpliceDecl lexpr@(L loc expr) - | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do - cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) - - | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do - cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) - - | otherwise = do - cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField - (L loc (HsUntypedSpliceExpr noAnn lexpr)) - BareSplice) - -mkRoleAnnotDecl :: SrcSpan - -> LocatedN RdrName -- type being annotated - -> [Located (Maybe FastString)] -- roles - -> [AddEpAnn] - -> P (LRoleAnnotDecl GhcPs) -mkRoleAnnotDecl loc tycon roles anns - = do { roles' <- mapM parse_role roles - ; cs <- getCommentsFor loc - ; return $ L (noAnnSrcSpan loc) - $ RoleAnnotDecl (EpAnn (spanAsAnchor loc) anns cs) tycon roles' } - where - role_data_type = dataTypeOf (undefined :: Role) - all_roles = map fromConstr $ dataTypeConstrs role_data_type - possible_roles = [(fsFromRole role, role) | role <- all_roles] - - parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing - parse_role (L loc_role (Just role)) - = case lookup role possible_roles of - Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role - Nothing -> - let nearby = fuzzyLookup (unpackFS role) - (mapFst unpackFS possible_roles) - in - addFatalError $ mkPlainErrorMsgEnvelope loc_role $ - (PsErrIllegalRoleName role nearby) - --- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to --- binders without annotations. Only accepts specified variables, and errors if --- any of the provided binders has an 'InferredSpec' annotation. -fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs] -fromSpecTyVarBndrs = mapM fromSpecTyVarBndr - --- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without --- annotations. Only accepts specified variables, and errors if the provided --- binder has an 'InferredSpec' annotation. -fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs) -fromSpecTyVarBndr bndr = case bndr of - (L loc (UserTyVar xtv flag idp)) -> (check_spec flag loc) - >> return (L loc $ UserTyVar xtv () idp) - (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc) - >> return (L loc $ KindedTyVar xtv () idp k) - where - check_spec :: Specificity -> SrcSpanAnnA -> P () - check_spec SpecifiedSpec _ = return () - check_spec InferredSpec loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - PsErrInferredTypeVarNotAllowed - --- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ -annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs - -> (HsLocalBinds GhcPs, Maybe EpAnnComments) -annBinds a cs (HsValBinds an bs) = (HsValBinds (add_where a an cs) bs, Nothing) -annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing) -annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) - -add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList -add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2 - | valid_anchor (anchor a) - = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2) - | otherwise - = EpAnn (patch_anchor rs a) - (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2) -add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs - = EpAnn (Anchor rs UnchangedAnchor) - (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs -add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where" - -- EpaDelta should only be used for transformations - -valid_anchor :: RealSrcSpan -> Bool -valid_anchor r = srcSpanStartLine r >= 0 - --- If the decl list for where binds is empty, the anchor ends up --- invalid. In this case, use the parent one -patch_anchor :: RealSrcSpan -> Anchor -> Anchor -patch_anchor r1 (Anchor r0 op) = Anchor r op - where - r = if srcSpanStartLine r0 < 0 then r1 else r0 - -fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList -fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed -fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) - = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs) - --- | The 'Anchor' for a stmtlist is based on either the location or --- the first semicolon annotion. -stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor -stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _)) - = widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r -stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor - -stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan -stmtsLoc (L l ((ConsOL aa _), _)) - = widenSpan l [aa] -stmtsLoc (L l _) = l - -{- ********************************************************************** - - #cvBinds-etc# Converting to @HsBinds@, etc. - - ********************************************************************* -} - --- | Function definitions are restructured here. Each is assumed to be recursive --- initially, and non recursive definitions are discovered by the dependency --- analyser. - - --- | Groups together bindings for a single function -cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] -cvTopDecls decls = getMonoBindAll (fromOL decls) - --- Declaration list may only contain value bindings and signatures. -cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) -cvBindGroup binding - = do { (mbs, sigs, fam_ds, tfam_insts - , dfam_insts, _) <- cvBindsAndSigs binding - ; massert (null fam_ds && null tfam_insts && null dfam_insts) - ; return $ ValBinds NoAnnSortKey mbs sigs } - -cvBindsAndSigs :: OrdList (LHsDecl GhcPs) - -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] - , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) --- Input decls contain just value bindings and signatures --- and in case of class or instance declarations also --- associated type declarations. They might also contain Haddock comments. -cvBindsAndSigs fb = do - fb' <- drop_bad_decls (fromOL fb) - return (partitionBindsAndSigs (getMonoBindAll fb')) - where - -- cvBindsAndSigs is called in several places in the parser, - -- and its items can be produced by various productions: - -- - -- * decl (when parsing a where clause or a let-expression) - -- * decl_inst (when parsing an instance declaration) - -- * decl_cls (when parsing a class declaration) - -- - -- partitionBindsAndSigs can handle almost all declaration forms produced - -- by the aforementioned productions, except for SpliceD, which we filter - -- out here (in drop_bad_decls). - -- - -- We're not concerned with every declaration form possible, such as those - -- produced by the topdecl parser production, because cvBindsAndSigs is not - -- called on top-level declarations. - drop_bad_decls [] = return [] - drop_bad_decls (L l (SpliceD _ d) : ds) = do - addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d - drop_bad_decls ds - drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds - ------------------------------------------------------------------------------ --- Group function bindings into equation groups - -getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] - -> (LHsBind GhcPs, [LHsDecl GhcPs]) --- Suppose (b',ds') = getMonoBind b ds --- ds is a list of parsed bindings --- b is a MonoBinds that has just been read off the front - --- Then b' is the result of grouping more equations from ds that --- belong with b into a single MonoBinds, and ds' is the depleted --- list of parsed bindings. --- --- All Haddock comments between equations inside the group are --- discarded. --- --- No AndMonoBinds or EmptyMonoBinds here; just single equations - -getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) - , fun_matches = - MG { mg_alts = (L _ m1@[L _ mtchs1]) } })) - binds - | has_args m1 - = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds [] - where - go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA - -> [LHsDecl GhcPs] -> [LHsDecl GhcPs] - -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ - go mtchs loc - ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) - , fun_matches = - MG { mg_alts = (L _ [L lm2 mtchs2]) } }))) - : binds) _ - | f1 == f2 = - let (loc2', lm2') = transferAnnsA loc2 lm2 - in go (L lm2' mtchs2 : mtchs) - (combineSrcSpansA loc loc2') binds [] - go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls - = let doc_decls' = doc_decl : doc_decls - in go mtchs (combineSrcSpansA loc loc2) binds doc_decls' - go mtchs loc binds doc_decls - = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs)) - , (reverse doc_decls) ++ binds) - -- Reverse the final matches, to get it back in the right order - -- Do the same thing with the trailing doc comments - -getMonoBind bind binds = (bind, binds) - --- Group together adjacent FunBinds for every function. -getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] -getMonoBindAll [] = [] -getMonoBindAll (L l (ValD _ b) : ds) = - let (L l' b', ds') = getMonoBind (L l b) ds - in L l' (ValD noExtField b') : getMonoBindAll ds' -getMonoBindAll (d : ds) = d : getMonoBindAll ds - -has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool -has_args [] = panic "GHC.Parser.PostProcess.has_args" -has_args (L _ (Match { m_pats = args }) : _) = not (null args) - -- Don't group together FunBinds if they have - -- no arguments. This is necessary now that variable bindings - -- with no arguments are now treated as FunBinds rather - -- than pattern bindings (tests/rename/should_fail/rnfail002). - -{- ********************************************************************** - - #PrefixToHS-utils# Utilities for conversion - - ********************************************************************* -} - -{- Note [Parsing data constructors is hard] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The problem with parsing data constructors is that they look a lot like types. -Compare: - - (s1) data T = C t1 t2 - (s2) type T = C t1 t2 - -Syntactically, there's little difference between these declarations, except in -(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. - -This similarity would pose no problem if we knew ahead of time if we are -parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple -(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing -data constructors, and in other contexts (e.g. 'type' declarations) assume we -are parsing type constructors. - -This simple rule does not work because of two problematic cases: - - (p1) data T = C t1 t2 :+ t3 - (p2) data T = C t1 t2 => t3 - -In (p1) we encounter (:+) and it turns out we are parsing an infix data -declaration, so (C t1 t2) is a type and 'C' is a type constructor. -In (p2) we encounter (=>) and it turns out we are parsing an existential -context, so (C t1 t2) is a constraint and 'C' is a type constructor. - -As the result, in order to determine whether (C t1 t2) declares a data -constructor, a type, or a context, we would need unlimited lookahead which -'happy' is not so happy with. --} - --- | Reinterpret a type constructor, including type operators, as a data --- constructor. --- See Note [Parsing data constructors is hard] -tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) -tyConToDataCon (L loc tc) - | okConOcc (occNameString occ) - = return (L loc (setRdrNameSpace tc srcDataName)) - - | otherwise - = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc) - where - occ = rdrNameOcc tc - -mkPatSynMatchGroup :: LocatedN RdrName - -> LocatedL (OrdList (LHsDecl GhcPs)) - -> P (MatchGroup GhcPs (LHsExpr GhcPs)) -mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = - do { matches <- mapM fromDecl (fromOL decls) - ; when (null matches) (wrongNumberErr (locA loc)) - ; return $ mkMatchGroup FromSource (L ld matches) } - where - fromDecl (L loc decl@(ValD _ (PatBind _ - -- AZ: where should these anns come from? - pat@(L _ (ConPat noAnn ln@(L _ name) details)) - rhs))) = - do { unless (name == patsyn_name) $ - wrongNameBindingErr (locA loc) decl - ; match <- case details of - PrefixCon _ pats -> return $ Match { m_ext = noAnn - , m_ctxt = ctxt, m_pats = pats - , m_grhss = rhs } - where - ctxt = FunRhs { mc_fun = ln - , mc_fixity = Prefix - , mc_strictness = NoSrcStrict } - - InfixCon p1 p2 -> return $ Match { m_ext = noAnn - , m_ctxt = ctxt - , m_pats = [p1, p2] - , m_grhss = rhs } - where - ctxt = FunRhs { mc_fun = ln - , mc_fixity = Infix - , mc_strictness = NoSrcStrict } - - RecCon{} -> recordPatSynErr (locA loc) pat - ; return $ L loc match } - fromDecl (L loc decl) = extraDeclErr (locA loc) decl - - extraDeclErr loc decl = - addFatalError $ mkPlainErrorMsgEnvelope loc $ - (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) - - wrongNameBindingErr loc decl = - addFatalError $ mkPlainErrorMsgEnvelope loc $ - (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) - - wrongNumberErr loc = - addFatalError $ mkPlainErrorMsgEnvelope loc $ - (PsErrEmptyWhereInPatSynDecl patsyn_name) - -recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a -recordPatSynErr loc pat = - addFatalError $ mkPlainErrorMsgEnvelope loc $ - (PsErrRecordSyntaxInPatSynDecl pat) - -mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] - -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs - -> ConDecl GhcPs - -mkConDeclH98 ann name mb_forall mb_cxt args - = ConDeclH98 { con_ext = ann - , con_name = name - , con_forall = isJust mb_forall - , con_ex_tvs = mb_forall `orElse` [] - , con_mb_cxt = mb_cxt - , con_args = args - , con_doc = Nothing } - --- | Construct a GADT-style data constructor from the constructor names and --- their type. Some interesting aspects of this function: --- --- * This splits up the constructor type into its quantified type variables (if --- provided), context (if provided), argument types, and result type, and --- records whether this is a prefix or record GADT constructor. See --- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. -mkGadtDecl :: SrcSpan - -> NonEmpty (LocatedN RdrName) - -> LHsUniToken "::" "∷" GhcPs - -> LHsSigType GhcPs - -> P (LConDecl GhcPs) -mkGadtDecl loc names dcol ty = do - cs <- getCommentsFor loc - let l = noAnnSrcSpan loc - - (args, res_ty, annsa, csa) <- - case body_ty of - L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do - let an' = addCommentsToEpAnn (locA loc') an (comments af) - arr <- case hsArr of - HsUnrestrictedArrow arr -> return arr - _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ - (PsErrIllegalGadtRecordMultiplicity hsArr) - return noHsUniTok - - return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty - , [], epAnnComments (ann ll)) - _ -> do - let (anns, cs, arg_types, res_type) = splitHsFunType body_ty - return (PrefixConGADT arg_types, res_type, anns, cs) - - let an = EpAnn (spanAsAnchor loc) annsa (cs Semi.<> csa) - - pure $ L l ConDeclGADT - { con_g_ext = an - , con_names = names - , con_dcolon = dcol - , con_bndrs = L (getLoc ty) outer_bndrs - , con_mb_cxt = mcxt - , con_g_args = args - , con_res_ty = res_ty - , con_doc = Nothing } - where - (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty - -setRdrNameSpace :: RdrName -> NameSpace -> RdrName --- ^ This rather gruesome function is used mainly by the parser. --- When parsing: --- --- > data T a = T | T1 Int --- --- we parse the data constructors as /types/ because of parser ambiguities, --- so then we need to change the /type constr/ to a /data constr/ --- --- The exact-name case /can/ occur when parsing: --- --- > data [] a = [] | a : [a] --- --- For the exact-name case we return an original name. -setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) -setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) -setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns - | Just thing <- wiredInNameTyThing_maybe n - = setWiredInNameSpace thing ns - -- Preserve Exact Names for wired-in things, - -- notably tuples and lists - - | isExternalName n - = Orig (nameModule n) occ - - | otherwise -- This can happen when quoting and then - -- splicing a fixity declaration for a type - = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) - where - occ = setOccNameSpace ns (nameOccName n) - -setWiredInNameSpace :: TyThing -> NameSpace -> RdrName -setWiredInNameSpace (ATyCon tc) ns - | isDataConNameSpace ns - = ty_con_data_con tc - | isTcClsNameSpace ns - = Exact (getName tc) -- No-op - -setWiredInNameSpace (AConLike (RealDataCon dc)) ns - | isTcClsNameSpace ns - = data_con_ty_con dc - | isDataConNameSpace ns - = Exact (getName dc) -- No-op - -setWiredInNameSpace thing ns - = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) - -ty_con_data_con :: TyCon -> RdrName -ty_con_data_con tc - | isTupleTyCon tc - , Just dc <- tyConSingleDataCon_maybe tc - = Exact (getName dc) - - | tc `hasKey` listTyConKey - = Exact nilDataConName - - | otherwise -- See Note [setRdrNameSpace for wired-in names] - = Unqual (setOccNameSpace srcDataName (getOccName tc)) - -data_con_ty_con :: DataCon -> RdrName -data_con_ty_con dc - | let tc = dataConTyCon dc - , isTupleTyCon tc - = Exact (getName tc) - - | dc `hasKey` nilDataConKey - = Exact listTyConName - - | otherwise -- See Note [setRdrNameSpace for wired-in names] - = Unqual (setOccNameSpace tcClsName (getOccName dc)) - - - -{- Note [setRdrNameSpace for wired-in names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC.Types, which declares (:), we have - infixr 5 : -The ambiguity about which ":" is meant is resolved by parsing it as a -data constructor, but then using dataTcOccs to try the type constructor too; -and that in turn calls setRdrNameSpace to change the name-space of ":" to -tcClsName. There isn't a corresponding ":" type constructor, but it's painful -to make setRdrNameSpace partial, so we just make an Unqual name instead. It -really doesn't matter! --} - -eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a --- Adapts the Either monad to the P monad -eitherToP (Left err) = addFatalError err -eitherToP (Right thing) = return thing - -checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs] - -> P (LHsQTyVars GhcPs) -- the synthesized type variables --- ^ Check whether the given list of type parameters are all type variables --- (possibly with a kind signature). -checkTyVars pp_what equals_or_where tc tparms - = do { tvs <- mapM check tparms - ; return (mkHsQTvs tvs) } - where - check (HsTypeArg at ki) = chkParens [] [] emptyComments (HsBndrInvisible at) ki - check (HsValArg ty) = chkParens [] [] emptyComments HsBndrRequired ty - check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ - (PsErrMalformedDecl pp_what (unLoc tc)) - -- Keep around an action for adjusting the annotations of extra parens - chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs - -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) - chkParens ops cps cs bvis (L l (HsParTy an ty)) - = let - (o,c) = mkParensEpAnn (realSrcSpan $ locA l) - in - chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) bvis ty - chkParens ops cps cs bvis ty = chk ops cps cs bvis ty - - -- Check that the name space is correct! - chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) - chk ops cps cs bvis (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k)) - | isRdrTyVar tv - = let - an = (reverse ops) ++ cps - in - return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an)) - (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs) - bvis (L lv tv) k)) - chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv))) - | isRdrTyVar tv - = let - an = (reverse ops) ++ cps - in - return (L (widenLocatedAn l (for_widening bvis:an)) - (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs) - bvis (L ltv tv))) - chk _ _ _ _ t@(L loc _) - = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) - - -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used. - for_widening :: HsBndrVis GhcPs -> AddEpAnn - for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc - for_widening _ = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) []) - - for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn] - for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments - for_widening_ann _ = EpAnnNotUsed - - -whereDots, equalsDots :: SDoc --- Second argument to checkTyVars -whereDots = text "where ..." -equalsDots = text "= ..." - -checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () -checkDatatypeContext Nothing = return () -checkDatatypeContext (Just c) - = do allowed <- getBit DatatypeContextsBit - unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $ - (PsErrIllegalDataTypeContext c) - -type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar -data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) --- ^ Essentially a wrapper for a @RuleBndr GhcPs@ - --- turns RuleTyTmVars into RuleBnrs - this is straightforward -mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] -mkRuleBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v - cvt_one (RuleTyTmVar ann v (Just sig)) = - RuleBndrSig ann v (mkHsPatSigType noAnn sig) - --- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting -mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] -mkRuleTyVarBndrs = fmap cvt_one - where cvt_one (L l (RuleTyTmVar ann v Nothing)) - = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v)) - cvt_one (L l (RuleTyTmVar ann v (Just sig))) - = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig) - -- takes something in namespace 'varName' to something in namespace 'tvName' - tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) - tm_to_ty _ = panic "mkRuleTyVarBndrs" - --- See Note [Parsing explicit foralls in Rules] in Parser.y -checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () -checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) - where check (L loc (Unqual occ)) = - when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"]) - (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrParseErrorOnInput occ)) - check _ = panic "checkRuleTyVarBndrNames" - -checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) -checkRecordSyntax lr@(L loc r) - = do allowed <- getBit TraditionalRecordSyntaxBit - unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrIllegalTraditionalRecordSyntax (ppr r)) - return lr - --- | Check if the gadt_constrlist is empty. Only raise parse error for --- `data T where` to avoid affecting existing error message, see #8258. -checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs]) - -> P (Located ([AddEpAnn], [LConDecl GhcPs])) -checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. - = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax - unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $ - PsErrIllegalWhereInDataDecl - return gadts -checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. - -checkTyClHdr :: Bool -- True <=> class header - -- False <=> type header - -> LHsType GhcPs - -> P (LocatedN RdrName, -- the head symbol (type or class name) - [LHsTypeArg GhcPs], -- parameters of head symbol - LexicalFixity, -- the declaration is in infix format - [AddEpAnn]) -- API Annotation for HsParTy - -- when stripping parens --- Well-formedness check and decomposition of type and class heads. --- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) --- Int :*: Bool into (:*:, [Int, Bool]) --- returning the pieces -checkTyClHdr is_cls ty - = goL ty [] [] [] Prefix - where - goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix - - -- workaround to define '*' despite StarIsType - go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix - = do { addPsMessage (locA l) PsWarnStarBinder - ; let name = mkOccNameFS tcClsName (starSym isUni) - ; let a' = newAnns l an - ; return (L a' (Unqual name), acc, fix - , (reverse ops') ++ cps') } - - go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix - | isRdrTc tc = return (ltc, acc, fix, (reverse ops) ++ cps) - go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix - | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps) - go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix - where - (o,c) = mkParensEpAnn (realSrcSpan l) - go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix - go _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix - go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix - = return (L (noAnnSrcSpan l) (nameRdrName tup_name) - , map HsValArg ts, fix, (reverse ops)++cps) - where - arity = length ts - tup_name | is_cls = cTupleTyConName arity - | otherwise = getName (tupleTyCon Boxed arity) - -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) - go l _ _ _ _ _ - = addFatalError $ mkPlainErrorMsgEnvelope l $ - (PsErrMalformedTyOrClDecl ty) - - -- Combine the annotations from the HsParTy and HsStarTy into a - -- new one for the LocatedN RdrName - newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN - newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) = - let - lr = combineRealSrcSpans (realSrcSpan l) (anchor as) - an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs) - in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) - newAnns _ EpAnnNotUsed = panic "missing AnnParen" - newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) = - let - lr = combineRealSrcSpans (anchor ap) (anchor as) - an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs)) - in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing) - --- | Yield a parse error if we have a function applied directly to a do block --- etc. and BlockArguments is not enabled. -checkExpBlockArguments :: LHsExpr GhcPs -> PV () -checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) - where - checkExpr :: LHsExpr GhcPs -> PV () - checkExpr expr = case unLoc expr of - HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr - HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr - HsLam {} -> check PsErrLambdaInFunAppExpr expr - HsCase {} -> check PsErrCaseInFunAppExpr expr - HsLamCase _ lc_variant _ -> check (PsErrLambdaCaseInFunAppExpr lc_variant) expr - HsLet {} -> check PsErrLetInFunAppExpr expr - HsIf {} -> check PsErrIfInFunAppExpr expr - HsProc {} -> check PsErrProcInFunAppExpr expr - _ -> return () - - checkCmd :: LHsCmd GhcPs -> PV () - checkCmd cmd = case unLoc cmd of - HsCmdLam {} -> check PsErrLambdaCmdInFunAppCmd cmd - HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd - HsCmdLamCase _ lc_variant _ -> check (PsErrLambdaCaseCmdInFunAppCmd lc_variant) cmd - HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd - HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd - HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd - _ -> return () - - check err a = do - blockArguments <- getBit BlockArgumentsBit - unless blockArguments $ - addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a) - --- | Validate the context constraints and break up a context into a list --- of predicates. --- --- @ --- (Eq a, Ord b) --> [Eq a, Ord b] --- Eq a --> [Eq a] --- (Eq a) --> [Eq a] --- (((Eq a))) --> [Eq a] --- @ -checkContext :: LHsType GhcPs -> P (LHsContext GhcPs) -checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) = - check ([],[],emptyComments) orig_t - where - check :: ([EpaLocation],[EpaLocation],EpAnnComments) - -> LHsType GhcPs -> P (LHsContext GhcPs) - check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts)) - -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can - -- be used as context constraints. - -- Ditto () - = do - let (op,cp,cs') = case ann' of - EpAnnNotUsed -> ([],[],emptyComments) - EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs) - return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) - -- Append parens so that the original order in the source is maintained - (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts) - - check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty)) - -- to be sure HsParTy doesn't get into the way - = do - let (op,cp,cs') = case ann' of - EpAnnNotUsed -> ([],[],emptyComments) - EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs) - check (op++opi,cp++cpi,cs' Semi.<> csi) ty - - -- No need for anns, returning original - check (_opi,_cpi,_csi) _t = - return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) emptyComments) l) [orig_t]) - -checkImportDecl :: Maybe EpaLocation - -> Maybe EpaLocation - -> P () -checkImportDecl mPre mPost = do - let whenJust mg f = maybe (pure ()) f mg - - importQualifiedPostEnabled <- getBit ImportQualifiedPostBit - - -- Error if 'qualified' found in postpositive position and - -- 'ImportQualifiedPost' is not in effect. - whenJust mPost $ \post -> - when (not importQualifiedPostEnabled) $ - failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) - - -- Error if 'qualified' occurs in both pre and postpositive - -- positions. - whenJust mPost $ \post -> - when (isJust mPre) $ - failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) - - -- Warn if 'qualified' found in prepositive position and - -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. - whenJust mPre $ \pre -> - warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing) - --- ------------------------------------------------------------------------- --- Checking Patterns. - --- We parse patterns as expressions and check for valid patterns below, --- converting the expression into a pattern at the same time. - -checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) -checkPattern = runPV . checkLPat - -checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) -checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) - -checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) -checkLPat e@(L l _) = checkPat l e [] [] - -checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs] - -> PV (LPat GhcPs) -checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args - | isRdrDataCon c = return . L loc $ ConPat - { pat_con_ext = noAnn -- AZ: where should this come from? - , pat_con = L ln c - , pat_args = PrefixCon tyargs args - } - | not (null tyargs) = - patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs - | (not (null args) && patIsRec c) = do - ctx <- askParseContext - patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx -checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args = - checkPat loc f (HsConPatTyArg at t : tyargs) args -checkPat loc (L _ (PatBuilderApp f e)) [] args = do - p <- checkLPat e - checkPat loc f [] (p : args) -checkPat loc (L l e) [] [] = do - p <- checkAPat loc e - return (L l p) -checkPat loc e _ _ = do - details <- fromParseContext <$> askParseContext - patFail (locA loc) (PsErrInPat (unLoc e) details) - -checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) -checkAPat loc e0 = do - nPlusKPatterns <- getBit NPlusKPatternsBit - case e0 of - PatBuilderPat p -> return p - PatBuilderVar x -> return (VarPat noExtField x) - - -- Overloaded numeric patterns (e.g. f 0 x = x) - -- Negation is recorded separately, so that the literal is zero or +ve - -- NB. Negative *primitive* literals are already handled by the lexer - PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn) - - -- n+k patterns - PatBuilderOpApp - (L _ (PatBuilderVar (L nloc n))) - (L l plus) - (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - (EpAnn anc _ cs) - | nPlusKPatterns && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit) - (EpAnn anc (epaLocationFromSrcAnn l) cs)) - - -- Improve error messages for the @-operator when the user meant an @-pattern - PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do - addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos - return (WildPat noExtField) - - PatBuilderOpApp l (L cl c) r anns - | isRdrDataCon c -> do - l <- checkLPat l - r <- checkLPat r - return $ ConPat - { pat_con_ext = anns - , pat_con = L cl c - , pat_args = InfixCon l r - } - - PatBuilderPar lpar e rpar -> do - p <- checkLPat e - return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar) - - _ -> do - details <- fromParseContext <$> askParseContext - patFail (locA loc) (PsErrInPat e0 details) - -placeHolderPunRhs :: DisambECP b => PV (LocatedA b) --- The RHS of a punned record field will be filled in by the renamer --- It's better not to make it an error, in case we want to print it when --- debugging -placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR) - -plus_RDR, pun_RDR :: RdrName -plus_RDR = mkUnqual varName (fsLit "+") -- Hack -pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") - -checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) - -> PV (LHsRecField GhcPs (LPat GhcPs)) -checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld) - return (L l (fld { hfbRHS = p })) - -patFail :: SrcSpan -> PsMessage -> PV a -patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg - -patIsRec :: RdrName -> Bool -patIsRec e = e == mkUnqual varName (fsLit "rec") - ---------------------------------------------------------------------------- --- Check Equation Syntax - -checkValDef :: SrcSpan - -> LocatedA (PatBuilder GhcPs) - -> Maybe (AddEpAnn, LHsType GhcPs) - -> Located (GRHSs GhcPs (LHsExpr GhcPs)) - -> P (HsBind GhcPs) - -checkValDef loc lhs (Just (sigAnn, sig)) grhss - -- x :: ty = rhs parses as a *pattern* binding - = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn] - >>= checkLPat - checkPatBind loc [] lhs' grhss - -checkValDef loc lhs Nothing g - = do { mb_fun <- isFunLhs lhs - ; case mb_fun of - Just (fun, is_infix, pats, ann) -> - checkFunBind NoSrcStrict loc ann - fun is_infix pats g - Nothing -> do - lhs' <- checkPattern lhs - checkPatBind loc [] lhs' g } - -checkFunBind :: SrcStrictness - -> SrcSpan - -> [AddEpAnn] - -> LocatedN RdrName - -> LexicalFixity - -> [LocatedA (PatBuilder GhcPs)] - -> Located (GRHSs GhcPs (LHsExpr GhcPs)) - -> P (HsBind GhcPs) -checkFunBind strictness locF ann fun is_infix pats (L _ grhss) - = do ps <- runPV_details extraDetails (mapM checkLPat pats) - let match_span = noAnnSrcSpan $ locF - cs <- getCommentsFor locF - return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span) - [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs - , m_ctxt = FunRhs - { mc_fun = fun - , mc_fixity = is_infix - , mc_strictness = strictness } - , m_pats = ps - , m_grhss = grhss })])) - -- The span of the match covers the entire equation. - -- That isn't quite right, but it'll do for now. - where - extraDetails - | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock - | otherwise = noParseContext - -makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)] - -> HsBind GhcPs --- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too -makeFunBind fn ms - = FunBind { fun_ext = noExtField, - fun_id = fn, - fun_matches = mkMatchGroup FromSource ms } - --- See Note [FunBind vs PatBind] -checkPatBind :: SrcSpan - -> [AddEpAnn] - -> LPat GhcPs - -> Located (GRHSs GhcPs (LHsExpr GhcPs)) - -> P (HsBind GhcPs) -checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v)))) - (L _match_span grhss) - = return (makeFunBind v (L (noAnnSrcSpan loc) - [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)])) - where - m a v = Match { m_ext = a - , m_ctxt = FunRhs { mc_fun = v - , mc_fixity = Prefix - , mc_strictness = SrcStrict } - , m_pats = [] - , m_grhss = grhss } - -checkPatBind loc annsIn lhs (L _ grhss) = do - cs <- getCommentsFor loc - return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss) - -checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) -checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) - | isUnqual v - , not (isDataOcc (rdrNameOcc v)) - = return lrdr - -checkValSigLhs lhs@(L l _) - = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs - -checkDoAndIfThenElse - :: (Outputable a, Outputable b, Outputable c) - => (a -> Bool -> b -> Bool -> c -> PsMessage) - -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () -checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr - | semiThen || semiElse = do - doAndIfThenElse <- getBit DoAndIfThenElseBit - let e = err (unLoc guardExpr) - semiThen (unLoc thenExpr) - semiElse (unLoc elseExpr) - loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) - - unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e) - | otherwise = return () - -isFunLhs :: LocatedA (PatBuilder GhcPs) - -> P (Maybe (LocatedN RdrName, LexicalFixity, - [LocatedA (PatBuilder GhcPs)],[AddEpAnn])) --- A variable binding is parsed as a FunBind. --- Just (fun, is_infix, arg_pats) if e is a function LHS -isFunLhs e = go e [] [] [] - where - go (L _ (PatBuilderVar (L loc f))) es ops cps - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps)) - go (L _ (PatBuilderApp f e)) es ops cps = go f (e:es) ops cps - go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps - = let - (o,c) = mkParensEpAnn (realSrcSpan $ locA l) - in - go e es (o:ops) (c:cps) - go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps - | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps))) - | otherwise -- Infix data con; keep going - = do { mb_l <- go l es ops cps - ; case mb_l of - Just (op', Infix, j : k : es', anns') - -> return (Just (op', Infix, j : op_app : es', anns')) - where - op_app = L loc (PatBuilderOpApp k - (L loc' op) r (EpAnn loca (reverse ops++cps) cs)) - _ -> return Nothing } - go _ _ _ _ = return Nothing - -mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs -mkBangTy anns strictness = - HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness) - --- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@. -data UnpackednessPragma = - UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness - --- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma. -addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs) -addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do - let l' = combineSrcSpans lprag (getLocA ty) - cs <- getCommentsFor l' - let an = EpAnn (spanAsAnchor l') anns cs - t' = addUnpackedness an ty - return (L (noAnnSrcSpan l') t') - where - -- If we have a HsBangTy that only has a strictness annotation, - -- such as ~T or !T, then add the pragma to the existing HsBangTy. - -- - -- Otherwise, wrap the type in a new HsBangTy constructor. - addUnpackedness an (L _ (HsBangTy x bang t)) - | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang - = HsBangTy (addAnns an (epAnnAnns x) (epAnnComments x)) (HsSrcBang prag unpk strictness) t - addUnpackedness an t - = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t - ---------------------------------------------------------------------------- --- | Check for monad comprehensions --- --- If the flag MonadComprehensions is set, return a 'MonadComp' context, --- otherwise use the usual 'ListComp' context - -checkMonadComp :: PV HsDoFlavour -checkMonadComp = do - monadComprehensions <- getBit MonadComprehensionsBit - return $ if monadComprehensions - then MonadComp - else ListComp - --- ------------------------------------------------------------------------- --- Expression/command/pattern ambiguity. --- See Note [Ambiguous syntactic categories] --- - --- See Note [Ambiguous syntactic categories] --- --- This newtype is required to avoid impredicative types in monadic --- productions. That is, in a production that looks like --- --- | ... {% return (ECP ...) } --- --- we are dealing with --- P ECP --- whereas without a newtype we would be dealing with --- P (forall b. DisambECP b => PV (Located b)) --- -newtype ECP = - ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) } - -ecpFromExp :: LHsExpr GhcPs -> ECP -ecpFromExp a = ECP (ecpFromExp' a) - -ecpFromCmd :: LHsCmd GhcPs -> ECP -ecpFromCmd a = ECP (ecpFromCmd' a) - --- The 'fbinds' parser rule produces values of this type. See Note --- [RecordDotSyntax field updates]. -type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b)) - --- | Disambiguate infix operators. --- See Note [Ambiguous syntactic categories] -class DisambInfixOp b where - mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) - mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) - mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b) - -instance DisambInfixOp (HsExpr GhcPs) where - mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) - mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) - mkHsInfixHolePV l ann = do - cs <- getCommentsFor l - return $ L l (hsHoleExpr (ann cs)) - -instance DisambInfixOp RdrName where - mkHsConOpPV (L l v) = return $ L l v - mkHsVarOpPV (L l v) = return $ L l v - mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole - -type AnnoBody b - = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn NoEpAnns - , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL - , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA - , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA - , Anno [LocatedA (StmtLR GhcPs GhcPs - (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL - ) - --- | Disambiguate constructs that may appear when we do not know ahead of time whether we are --- parsing an expression, a command, or a pattern. --- See Note [Ambiguous syntactic categories] -class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where - -- | See Note [Body in DisambECP] - type Body b :: Type -> Type - -- | Return a command without ambiguity, or fail in a non-command context. - ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) - -- | Return an expression without ambiguity, or fail in a non-expression context. - ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b) - mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] - -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b)) - -- | Disambiguate "\... -> ..." (lambda) - mkHsLamPV - :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b) - -- | Disambiguate "let ... in ..." - mkHsLetPV - :: SrcSpan - -> LHsToken "let" GhcPs - -> HsLocalBinds GhcPs - -> LHsToken "in" GhcPs - -> LocatedA b - -> PV (LocatedA b) - -- | Infix operator representation - type InfixOp b - -- | Bring superclass constraints on InfixOp into scope. - -- See Note [UndecidableSuperClasses for associated types] - superInfixOp - :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b) - -- | Disambiguate "f # x" (infix operator) - mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b - -> PV (LocatedA b) - -- | Disambiguate "case ... of ..." - mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)]) - -> EpAnnHsCase -> PV (LocatedA b) - -- | Disambiguate "\case" and "\cases" - mkHsLamCasePV :: SrcSpan -> LamCaseVariant - -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn] - -> PV (LocatedA b) - -- | Function argument representation - type FunArg b - -- | Bring superclass constraints on FunArg into scope. - -- See Note [UndecidableSuperClasses for associated types] - superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b) - -- | Disambiguate "f x" (function application) - mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) - -- | Disambiguate "f @t" (visible type application) - mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) - -- | Disambiguate "if ... then ... else ..." - mkHsIfPV :: SrcSpan - -> LHsExpr GhcPs - -> Bool -- semicolon? - -> LocatedA b - -> Bool -- semicolon? - -> LocatedA b - -> AnnsIf - -> PV (LocatedA b) - -- | Disambiguate "do { ... }" (do notation) - mkHsDoPV :: - SrcSpan -> - Maybe ModuleName -> - LocatedL [LStmt GhcPs (LocatedA b)] -> - AnnList -> - PV (LocatedA b) - -- | Disambiguate "( ... )" (parentheses) - mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b) - -- | Disambiguate a variable "f" or a data constructor "MkF". - mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) - -- | Disambiguate a monomorphic literal - mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b) - -- | Disambiguate an overloaded literal - mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b) - -- | Disambiguate a wildcard - mkHsWildCardPV :: SrcSpan -> PV (Located b) - -- | Disambiguate "a :: t" (type annotation) - mkHsTySigPV - :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b) - -- | Disambiguate "[a,b,c]" (list syntax) - mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) - -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) - mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (Located b) - -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) - mkHsRecordPV :: - Bool -> -- Is OverloadedRecordUpdate in effect? - SrcSpan -> - SrcSpan -> - LocatedA b -> - ([Fbind b], Maybe SrcSpan) -> - [AddEpAnn] -> - PV (LocatedA b) - -- | Disambiguate "-a" (negation) - mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) - -- | Disambiguate "(# a)" (right operator section) - mkHsSectionR_PV - :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b) - -- | Disambiguate "(a -> b)" (view pattern) - mkHsViewPatPV - :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) - -- | Disambiguate "a@b" (as-pattern) - mkHsAsPatPV - :: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b) - -- | Disambiguate "~a" (lazy pattern) - mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) - -- | Disambiguate "!a" (bang pattern) - mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) - -- | Disambiguate tuple sections and unboxed sums - mkSumOrTuplePV - :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b) - -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas - rejectPragmaPV :: LocatedA b -> PV () - -{- Note [UndecidableSuperClasses for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(This Note is about the code in GHC, not about the user code that we are parsing) - -Assume we have a class C with an associated type T: - - class C a where - type T a - ... - -If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: - - {-# LANGUAGE UndecidableSuperClasses #-} - class C (T a) => C a where - type T a - ... - -Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes -making GHC loop. The workaround is to bring this constraint into scope -manually with a helper method: - - class C a where - type T a - superT :: (C (T a) => r) -> r - -In order to avoid ambiguous types, 'r' must mention 'a'. - -For consistency, we use this approach for all constraints on associated types, -even when -XUndecidableSuperClasses are not required. --} - -{- Note [Body in DisambECP] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that -require their argument to take a form of (body GhcPs) for some (body :: Type -> -*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the -superclass constraints of DisambECP. - -The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop -this requirement. It is possible and would allow removing the type index of -PatBuilder, but leads to worse type inference, breaking some code in the -typechecker. --} - -instance DisambECP (HsCmd GhcPs) where - type Body (HsCmd GhcPs) = HsCmd - ecpFromCmd' = return - ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) - mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ - PsErrOverloadedRecordDotInvalid - mkHsLamPV l mg = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs)) - mkHsLetPV l tkLet bs tkIn e = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e) - type InfixOp (HsCmd GhcPs) = HsExpr GhcPs - superInfixOp m = m - mkHsOpAppPV l c1 op c2 = do - let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2] - mkHsCasePV l c (L lm m) anns = do - cs <- getCommentsFor l - let mg = mkMatchGroup FromSource (L lm m) - return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg) - mkHsLamCasePV l lc_variant (L lm m) anns = do - cs <- getCommentsFor l - let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m) - return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg) - type FunArg (HsCmd GhcPs) = HsExpr GhcPs - superFunArg m = m - mkHsAppPV l c e = do - cs <- getCommentsFor (locA l) - checkCmdBlockArguments c - checkExpBlockArguments e - return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e) - mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) - mkHsIfPV l c semi1 a semi2 b anns = do - checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (EpAnn (spanAsAnchor l) anns cs)) - mkHsDoPV l Nothing stmts anns = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts) - mkHsDoPV l (Just m) _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m - mkHsParPV l lpar c rpar = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar) - mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) - mkHsLitPV (L l a) = cmdFail l (ppr a) - mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a) - mkHsWildCardPV l = cmdFail l (text "_") - mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) - mkHsExplicitListPV l xs _ = cmdFail l $ - brackets (pprWithCommas ppr xs) - mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp) - mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do - let (fs, ps) = partitionEithers fbinds - if not (null ps) - then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid - else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) - mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) - mkHsSectionR_PV l op c = cmdFail l $ - let pp_op = fromMaybe (panic "cannot print infix operator") - (ppr_infix_expr (unLoc op)) - in pp_op <> ppr c - mkHsViewPatPV l a b _ = cmdFail l $ - ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v _ c = cmdFail l $ - pprPrefixOcc (unLoc v) <> text "@" <> ppr c - mkHsLazyPatPV l c _ = cmdFail l $ - text "~" <> ppr c - mkHsBangPatPV l c _ = cmdFail l $ - text "!" <> ppr c - mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a) - rejectPragmaPV _ = return () - -cmdFail :: SrcSpan -> SDoc -> PV a -cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e - -checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV () -checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do - when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda -checkLamMatchGroup _ _ = return () - -instance DisambECP (HsExpr GhcPs) where - type Body (HsExpr GhcPs) = HsExpr - ecpFromCmd' (L l c) = do - addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c - return (L l (hsHoleExpr noAnn)) - ecpFromExp' = return - mkHsProjUpdatePV l fields arg isPun anns = do - cs <- getCommentsFor l - return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs) - mkHsLamPV l mg = do - cs <- getCommentsFor l - let mg' = mg cs - checkLamMatchGroup l mg' - return $ L (noAnnSrcSpan l) (HsLam NoExtField mg') - mkHsLetPV l tkLet bs tkIn c = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c) - type InfixOp (HsExpr GhcPs) = HsExpr GhcPs - superInfixOp m = m - mkHsOpAppPV l e1 op e2 = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2 - mkHsCasePV l e (L lm m) anns = do - cs <- getCommentsFor l - let mg = mkMatchGroup FromSource (L lm m) - return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg) - mkHsLamCasePV l lc_variant (L lm m) anns = do - cs <- getCommentsFor l - let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m) - return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg) - type FunArg (HsExpr GhcPs) = HsExpr GhcPs - superFunArg m = m - mkHsAppPV l e1 e2 = do - cs <- getCommentsFor (locA l) - checkExpBlockArguments e1 - checkExpBlockArguments e2 - return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) - mkHsAppTypePV l e at t = do - checkExpBlockArguments e - return $ L l (HsAppType noExtField e at (mkHsWildCardBndrs t)) - mkHsIfPV l c semi1 a semi2 b anns = do - checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (mkHsIf c a b (EpAnn (spanAsAnchor l) anns cs)) - mkHsDoPV l mod stmts anns = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts) - mkHsParPV l lpar e rpar = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar) - mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v) - mkHsLitPV (L l a) = do - cs <- getCommentsFor l - return $ L l (HsLit (comment (realSrcSpan l) cs) a) - mkHsOverLitPV (L l a) = do - cs <- getCommentsFor (locA l) - return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a) - mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) - mkHsTySigPV l a sig anns = do - cs <- getCommentsFor (locA l) - return $ L l (ExprWithTySig (EpAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig)) - mkHsExplicitListPV l xs anns = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs) - mkHsSplicePV sp@(L l _) = do - cs <- getCommentsFor l - return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp - mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do - cs <- getCommentsFor l - r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs) - checkRecordSyntax (L (noAnnSrcSpan l) r) - mkHsNegAppPV l a anns = do - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr) - mkHsSectionR_PV l op e = do - cs <- getCommentsFor l - return $ L l (SectionR (comment (realSrcSpan l) cs) op e) - mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b) - >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) - >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) - >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e) - >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn)) - mkSumOrTuplePV = mkSumOrTupleExpr - rejectPragmaPV (L _ (OpApp _ _ _ e)) = - -- assuming left-associative parsing of operators - rejectPragmaPV e - rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $ - (PsErrUnallowedPragma prag) - rejectPragmaPV _ = return () - -hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs -hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_"))) - -instance DisambECP (PatBuilder GhcPs) where - type Body (PatBuilder GhcPs) = PatBuilder - ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c - ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e - mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat - mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat - mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid - type InfixOp (PatBuilder GhcPs) = RdrName - superInfixOp m = m - mkHsOpAppPV l p1 op p2 = do - cs <- getCommentsFor l - let anns = EpAnn (spanAsAnchor l) [] cs - return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns - mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat - mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant) - type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs - superFunArg m = m - mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) - mkHsAppTypePV l p at t = do - cs <- getCommentsFor (locA l) - let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs - return $ L l (PatBuilderAppType p at (mkHsPatSigType anns t)) - mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat - mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat - mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) - mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v) - mkHsLitPV lit@(L l a) = do - checkUnboxedLitPat lit - return $ L l (PatBuilderPat (LitPat noExtField a)) - mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) - mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField)) - mkHsTySigPV l b sig anns = do - p <- checkLPat b - cs <- getCommentsFor (locA l) - return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig))) - mkHsExplicitListPV l xs anns = do - ps <- traverse checkLPat xs - cs <- getCommentsFor l - return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps))) - mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp)) - mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do - let (fs, ps) = partitionEithers fbinds - if not (null ps) - then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid - else do - cs <- getCommentsFor l - r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs) - checkRecordSyntax (L (noAnnSrcSpan l) r) - mkHsNegAppPV l (L lp p) anns = do - lit <- case p of - PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit) - _ -> patFail l $ PsErrInPat p PEIP_NegApp - cs <- getCommentsFor l - let an = EpAnn (spanAsAnchor l) anns cs - return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an)) - mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) - mkHsViewPatPV l a b anns = do - p <- checkLPat b - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p)) - mkHsAsPatPV l v at e = do - p <- checkLPat e - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) NoEpAnns cs) v at p)) - mkHsLazyPatPV l e a = do - p <- checkLPat e - cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (EpAnn (spanAsAnchor l) a cs) p)) - mkHsBangPatPV l e an = do - p <- checkLPat e - cs <- getCommentsFor l - let pb = BangPat (EpAnn (spanAsAnchor l) an cs) p - hintBangPat l pb - return $ L (noAnnSrcSpan l) (PatBuilderPat pb) - mkSumOrTuplePV = mkSumOrTuplePat - rejectPragmaPV _ = return () - --- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#. -checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV () -checkUnboxedLitPat (L loc lit) = - case lit of - -- Don't allow primitive string literal patterns. - -- See #13260. - HsStringPrim {} - -> addError $ mkPlainErrorMsgEnvelope loc $ - (PsErrIllegalUnboxedStringInPat lit) - - -- Don't allow Float#/Double# literal patterns. - -- See #9238 and Note [Rules for floating-point comparisons] - -- in GHC.Core.Opt.ConstantFold. - _ | is_floating_lit lit - -> addError $ mkPlainErrorMsgEnvelope loc $ - (PsErrIllegalUnboxedFloatingLitInPat lit) - - | otherwise - -> return () - - where - is_floating_lit :: HsLit GhcPs -> Bool - is_floating_lit (HsFloatPrim {}) = True - is_floating_lit (HsDoublePrim {}) = True - is_floating_lit _ = False - -mkPatRec :: - LocatedA (PatBuilder GhcPs) -> - HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> - EpAnn [AddEpAnn] -> - PV (PatBuilder GhcPs) -mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns - | isRdrDataCon (unLoc c) - = do fs <- mapM checkPatField fs - return $ PatBuilderPat $ ConPat - { pat_con_ext = anns - , pat_con = c - , pat_args = RecCon (HsRecFields fs dd) - } -mkPatRec p _ _ = - addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ - (PsErrInvalidRecordCon (unLoc p)) - --- | Disambiguate constructs that may appear when we do not know --- ahead of time whether we are parsing a type or a newtype/data constructor. --- --- See Note [Ambiguous syntactic categories] for the general idea. --- --- See Note [Parsing data constructors is hard] for the specific issue this --- particular class is solving. --- -class DisambTD b where - -- | Process the head of a type-level function/constructor application, - -- i.e. the @H@ in @H a b c@. - mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b) - -- | Disambiguate @f x@ (function application or prefix data constructor). - mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) - -- | Disambiguate @f \@t@ (visible kind application) - mkHsAppKindTyPV :: LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) - -- | Disambiguate @f \# x@ (infix operator) - mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) - -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) - mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) - -instance DisambTD (HsType GhcPs) where - mkHsAppTyHeadPV = return - mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) - mkHsAppKindTyPV t at ki = return (mkHsAppKindTy t at ki) - mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2) - mkUnpackednessPV = addUnpackednessP - -dataConBuilderCon :: DataConBuilder -> LocatedN RdrName -dataConBuilderCon (PrefixDataConBuilder _ dc) = dc -dataConBuilderCon (InfixDataConBuilder _ dc _) = dc - -dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs - --- Detect when the record syntax is used: --- data T = MkT { ... } -dataConBuilderDetails (PrefixDataConBuilder flds _) - | [L l_t (HsRecTy an fields)] <- toList flds - = RecCon (L (SrcSpanAnn an (locA l_t)) fields) - --- Normal prefix constructor, e.g. data T = MkT A B C -dataConBuilderDetails (PrefixDataConBuilder flds _) - = PrefixCon noTypeArgs (map hsLinear (toList flds)) - --- Infix constructor, e.g. data T = Int :! Bool -dataConBuilderDetails (InfixDataConBuilder lhs _ rhs) - = InfixCon (hsLinear lhs) (hsLinear rhs) - -instance DisambTD DataConBuilder where - mkHsAppTyHeadPV = tyToDataConBuilder - - mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t = - return $ - L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t)) - (PrefixDataConBuilder (flds `snocOL` t) fn) - mkHsAppTyPV (L _ InfixDataConBuilder{}) _ = - -- This case is impossible because of the way - -- the grammar in Parser.y is written (see infixtype/ftype). - panic "mkHsAppTyPV: InfixDataConBuilder" - - mkHsAppKindTyPV lhs at ki = - addFatalError $ mkPlainErrorMsgEnvelope (getTokenSrcSpan (getLoc at)) $ - (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) - - mkHsOpTyPV prom lhs tc rhs = do - check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative - data_con <- eitherToP $ tyConToDataCon tc - checkNotPromotedDataCon prom data_con - return $ L l (InfixDataConBuilder lhs data_con rhs) - where - l = combineLocsA lhs rhs - check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) - check_no_ops (HsOpTy{}) = - addError $ mkPlainErrorMsgEnvelope (locA l) $ - (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) - check_no_ops _ = return () - - mkUnpackednessPV unpk constr_stuff - | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff - = -- When the user writes data T = {-# UNPACK #-} Int :+ Bool - -- we apply {-# UNPACK #-} to the LHS - do lhs' <- addUnpackednessP unpk lhs - let l = combineLocsA (reLocA unpk) constr_stuff - return $ L l (InfixDataConBuilder lhs' data_con rhs) - | otherwise = - do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon - return constr_stuff - -tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) -tyToDataConBuilder (L l (HsTyVar _ prom v)) = do - data_con <- eitherToP $ tyConToDataCon v - checkNotPromotedDataCon prom data_con - return $ L l (PrefixDataConBuilder nilOL data_con) -tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do - let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) - return $ L l (PrefixDataConBuilder (toOL ts) data_con) -tyToDataConBuilder t = - addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $ - (PsErrInvalidDataCon (unLoc t)) - --- | Rejects declarations such as @data T = 'MkT@ (note the leading tick). -checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV () -checkNotPromotedDataCon NotPromoted _ = return () -checkNotPromotedDataCon IsPromoted (L l name) = - addError $ mkPlainErrorMsgEnvelope (locA l) $ - PsErrIllegalPromotionQuoteDataCon name - -{- Note [Ambiguous syntactic categories] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are places in the grammar where we do not know whether we are parsing an -expression or a pattern without unlimited lookahead (which we do not have in -'happy'): - -View patterns: - - f (Con a b ) = ... -- 'Con a b' is a pattern - f (Con a b -> x) = ... -- 'Con a b' is an expression - -do-notation: - - do { Con a b <- x } -- 'Con a b' is a pattern - do { Con a b } -- 'Con a b' is an expression - -Guards: - - x | True <- p && q = ... -- 'True' is a pattern - x | True = ... -- 'True' is an expression - -Top-level value/function declarations (FunBind/PatBind): - - f ! a -- TH splice - f ! a = ... -- function declaration - - Until we encounter the = sign, we don't know if it's a top-level - TemplateHaskell splice where ! is used, or if it's a function declaration - where ! is bound. - -There are also places in the grammar where we do not know whether we are -parsing an expression or a command: - - proc x -> do { (stuff) -< x } -- 'stuff' is an expression - proc x -> do { (stuff) } -- 'stuff' is a command - - Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' - as an expression or a command. - -In fact, do-notation is subject to both ambiguities: - - proc x -> do { (stuff) -< x } -- 'stuff' is an expression - proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern - proc x -> do { (stuff) } -- 'stuff' is a command - -There are many possible solutions to this problem. For an overview of the ones -we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] - -The solution that keeps basic definitions (such as HsExpr) clean, keeps the -concerns local to the parser, and does not require duplication of hsSyn types, -or an extra pass over the entire AST, is to parse into an overloaded -parser-validator (a so-called tagless final encoding): - - class DisambECP b where ... - instance DisambECP (HsCmd GhcPs) where ... - instance DisambECP (HsExp GhcPs) where ... - instance DisambECP (PatBuilder GhcPs) where ... - -The 'DisambECP' class contains functions to build and validate 'b'. For example, -to add parentheses we have: - - mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) - -'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for -expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, -see Note [PatBuilder]). - -Consider the 'alts' production used to parse case-of alternatives: - - alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -We abstract over LHsExpr GhcPs, and it becomes: - - alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) } - : alts1 { $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -Compared to the initial definition, the added bits are: - - forall b. DisambECP b => PV ( ... ) -- in the type signature - $1 >>= \ $1 -> return $ -- in one reduction rule - $2 >>= \ $2 -> return $ -- in another reduction rule - -The overhead is constant relative to the size of the rest of the reduction -rule, so this approach scales well to large parser productions. - -Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding -position and shadows the previous $1. We can do this because internally -'happy' desugars $n to happy_var_n, and the rationale behind this idiom -is to be able to write (sLL $1 $>) later on. The alternative would be to -write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer -to the last fresh name as $>. - -Finally, we instantiate the polymorphic type to a concrete one, and run the -parser-validator, for example: - - stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } - e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } - : stmt {% runPV $1 } - -In e_stmt, three things happen: - - 1. we instantiate: b ~ HsExpr GhcPs - 2. we embed the PV computation into P by using runPV - 3. we run validation by using a monadic production, {% ... } - -At this point the ambiguity is resolved. --} - - -{- Note [Resolving parsing ambiguities: non-taken alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Alternative I, extra constructors in GHC.Hs.Expr ------------------------------------------------- -We could add extra constructors to HsExpr to represent command-specific and -pattern-specific syntactic constructs. Under this scheme, we parse patterns -and commands as expressions and rejig later. This is what GHC used to do, and -it polluted 'HsExpr' with irrelevant constructors: - - * for commands: 'HsArrForm', 'HsArrApp' - * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' - -(As of now, we still do that for patterns, but we plan to fix it). - -There are several issues with this: - - * The implementation details of parsing are leaking into hsSyn definitions. - - * Code that uses HsExpr has to panic on these impossible-after-parsing cases. - - * HsExpr is arbitrarily selected as the extension basis. Why not extend - HsCmd or HsPat with extra constructors instead? - -Alternative II, extra constructors in GHC.Hs.Expr for GhcPs ------------------------------------------------------------ -We could address some of the problems with Alternative I by using Trees That -Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to -the output of parsing, not to its intermediate results, so we wouldn't want -them there either. - -Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs ---------------------------------------------------------------- -We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. -Unfortunately, creating a new pass would significantly bloat conversion code -and slow down the compiler by adding another linear-time pass over the entire -AST. For example, in order to build HsExpr GhcPrePs, we would need to build -HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds -GhcPrePs. - - -Alternative IV, sum type and bottom-up data flow ------------------------------------------------- -Expressions and commands are disjoint. There are no user inputs that could be -interpreted as either an expression or a command depending on outer context: - - 5 -- definitely an expression - x -< y -- definitely a command - -Even though we have both 'HsLam' and 'HsCmdLam', we can look at -the body to disambiguate: - - \p -> 5 -- definitely an expression - \p -> x -< y -- definitely a command - -This means we could use a bottom-up flow of information to determine -whether we are parsing an expression or a command, using a sum type -for intermediate results: - - Either (LHsExpr GhcPs) (LHsCmd GhcPs) - -There are two problems with this: - - * We cannot handle the ambiguity between expressions and - patterns, which are not disjoint. - - * Bottom-up flow of information leads to poor error messages. Consider - - if ... then 5 else (x -< y) - - Do we report that '5' is not a valid command or that (x -< y) is not a - valid expression? It depends on whether we want the entire node to be - 'HsIf' or 'HsCmdIf', and this information flows top-down, from the - surrounding parsing context (are we in 'proc'?) - -Alternative V, backtracking with parser combinators ---------------------------------------------------- -One might think we could sidestep the issue entirely by using a backtracking -parser and doing something along the lines of (try pExpr <|> pPat). - -Turns out, this wouldn't work very well, as there can be patterns inside -expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns -(e.g. view patterns). To handle this, we would need to backtrack while -backtracking, and unbound levels of backtracking lead to very fragile -performance. - -Alternative VI, an intermediate data type ------------------------------------------ -There are common syntactic elements of expressions, commands, and patterns -(e.g. all of them must have balanced parentheses), and we can capture this -common structure in an intermediate data type, Frame: - -data Frame - = FrameVar RdrName - -- ^ Identifier: Just, map, BS.length - | FrameTuple [LTupArgFrame] Boxity - -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) - | FrameTySig LFrame (LHsSigWcType GhcPs) - -- ^ Type signature: x :: ty - | FramePar (SrcSpan, SrcSpan) LFrame - -- ^ Parentheses - | FrameIf LFrame LFrame LFrame - -- ^ If-expression: if p then x else y - | FrameCase LFrame [LFrameMatch] - -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } - | FrameDo (HsStmtContext GhcRn) [LFrameStmt] - -- ^ Do-expression: do { s1; a <- s2; s3 } - ... - | FrameExpr (HsExpr GhcPs) -- unambiguously an expression - | FramePat (HsPat GhcPs) -- unambiguously a pattern - | FrameCommand (HsCmd GhcPs) -- unambiguously a command - -To determine which constructors 'Frame' needs to have, we take the union of -intersections between HsExpr, HsCmd, and HsPat. - -The intersection between HsPat and HsExpr: - - HsPat = VarPat | TuplePat | SigPat | ParPat | ... - HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... - ------------------------------------------------------------------- - Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... - -The intersection between HsCmd and HsExpr: - - HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar - HsExpr = HsIf | HsCase | HsDo | HsPar - ------------------------------------------------ - Frame = FrameIf | FrameCase | FrameDo | FramePar - -The intersection between HsCmd and HsPat: - - HsPat = ParPat | ... - HsCmd = HsCmdPar | ... - ----------------------- - Frame = FramePar | ... - -Take the union of each intersection and this yields the final 'Frame' data -type. The problem with this approach is that we end up duplicating a good -portion of hsSyn: - - Frame for HsExpr, HsPat, HsCmd - TupArgFrame for HsTupArg - FrameMatch for Match - FrameStmt for StmtLR - FrameGRHS for GRHS - FrameGRHSs for GRHSs - ... - -Alternative VII, a product type -------------------------------- -We could avoid the intermediate representation of Alternative VI by parsing -into a product of interpretations directly: - - type ExpCmdPat = ( PV (LHsExpr GhcPs) - , PV (LHsCmd GhcPs) - , PV (LHsPat GhcPs) ) - -This means that in positions where we do not know whether to produce -expression, a pattern, or a command, we instead produce a parser-validator for -each possible option. - -Then, as soon as we have parsed far enough to resolve the ambiguity, we pick -the appropriate component of the product, discarding the rest: - - checkExpOf3 (e, _, _) = e -- interpret as an expression - checkCmdOf3 (_, c, _) = c -- interpret as a command - checkPatOf3 (_, _, p) = p -- interpret as a pattern - -We can easily define ambiguities between arbitrary subsets of interpretations. -For example, when we know ahead of type that only an expression or a command is -possible, but not a pattern, we can use a smaller type: - - type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) - - checkExpOf2 (e, _) = e -- interpret as an expression - checkCmdOf2 (_, c) = c -- interpret as a command - -However, there is a slight problem with this approach, namely code duplication -in parser productions. Consider the 'alts' production used to parse case-of -alternatives: - - alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -Under the new scheme, we have to completely duplicate its type signature and -each reduction rule: - - alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression - , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command - ) } - : alts1 - { ( checkExpOf2 $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) - , checkCmdOf2 $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) - ) } - | ';' alts - { ( checkExpOf2 $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) - , checkCmdOf2 $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) - ) } - -And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', -'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! - -Alternative VIII, a function from a GADT ----------------------------------------- -We could avoid code duplication of the Alternative VII by representing the product -as a function from a GADT: - - data ExpCmdG b where - ExpG :: ExpCmdG HsExpr - CmdG :: ExpCmdG HsCmd - - type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) - - checkExp :: ExpCmd -> PV (LHsExpr GhcPs) - checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) - checkExp f = f ExpG -- interpret as an expression - checkCmd f = f CmdG -- interpret as a command - -Consider the 'alts' production used to parse case-of alternatives: - - alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } - : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -We abstract over LHsExpr, and it becomes: - - alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) } - : alts1 - { \tag -> $1 tag >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts - { \tag -> $2 tag >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -Note that 'ExpCmdG' is a singleton type, the value is completely -determined by the type: - - when (b~HsExpr), tag = ExpG - when (b~HsCmd), tag = CmdG - -This is a clear indication that we can use a class to pass this value behind -the scenes: - - class ExpCmdI b where expCmdG :: ExpCmdG b - instance ExpCmdI HsExpr where expCmdG = ExpG - instance ExpCmdI HsCmd where expCmdG = CmdG - -And now the 'alts' production is simplified, as we no longer need to -thread 'tag' explicitly: - - alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) } - : alts1 { $1 >>= \ $1 -> - return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } - | ';' alts { $2 >>= \ $2 -> - return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } - -This encoding works well enough, but introduces an extra GADT unlike the -tagless final encoding, and there's no need for this complexity. - --} - -{- Note [PatBuilder] -~~~~~~~~~~~~~~~~~~~~ -Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms, -so we introduce the notion of a PatBuilder. - -Consider a pattern like this: - - Con a b c - -We parse arguments to "Con" one at a time in the fexp aexp parser production, -building the result with mkHsAppPV, so the intermediate forms are: - - 1. Con - 2. Con a - 3. Con a b - 4. Con a b c - -In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like -this (pseudocode): - - 1. "Con" - 2. HsApp "Con" "a" - 3. HsApp (HsApp "Con" "a") "b" - 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" - -Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have -instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for -the intermediate forms. - -We also need an intermediate representation to postpone disambiguation between -FunBind and PatBind. Consider: - - a `Con` b = ... - a `fun` b = ... - -How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We -learn this by inspecting an intermediate representation in 'isFunLhs' and -seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate -representation capable of representing both a FunBind and a PatBind, so Pat is -insufficient. - -PatBuilder is an extension of Pat that is capable of representing intermediate -parsing results for patterns and function bindings: - - data PatBuilder p - = PatBuilderPat (Pat p) - | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) - | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p)) - ... - -It can represent any pattern via 'PatBuilderPat', but it also has a variety of -other constructors which were added by following a simple principle: we never -pattern match on the pattern stored inside 'PatBuilderPat'. --} - ---------------------------------------------------------------------------- --- Miscellaneous utilities - --- | Check if a fixity is valid. We support bypassing the usual bound checks --- for some special operators. -checkPrecP - :: Located (SourceText,Int) -- ^ precedence - -> Located (OrdList (LocatedN RdrName)) -- ^ operators - -> P () -checkPrecP (L l (_,i)) (L _ ol) - | 0 <= i, i <= maxPrecedence = pure () - | all specialOp ol = pure () - | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i) - where - -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs - specialOp op = unLoc op == getRdrName unrestrictedFunTyCon - -mkRecConstrOrUpdate - :: Bool - -> LHsExpr GhcPs - -> SrcSpan - -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) - -> EpAnn [AddEpAnn] - -> PV (HsExpr GhcPs) -mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns - | isRdrDataCon c - = do - let (fs, ps) = partitionEithers fbinds - case ps of - p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ - PsErrOverloadedRecordDotInvalid - _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) -mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns - | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $ - PsErrDotsInRecordUpdate - | otherwise = mkRdrRecordUpd overloaded_update exp fs anns - -mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs) -mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do - -- We do not need to know if OverloadedRecordDot is in effect. We do - -- however need to know if OverloadedRecordUpdate (passed in - -- overloaded_on) is in effect because it affects the Left/Right nature - -- of the RecordUpd value we calculate. - let (fs, ps) = partitionEithers fbinds - fs' :: [LHsRecUpdField GhcPs GhcPs] - fs' = map (fmap mk_rec_upd_field) fs - case overloaded_on of - False | not $ null ps -> - -- A '.' was found in an update and OverloadedRecordUpdate isn't on. - addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled - False -> - -- This is just a regular record update. - return RecordUpd { - rupd_ext = anns - , rupd_expr = exp - , rupd_flds = - RegularRecUpdFields - { xRecUpdFields = noExtField - , recUpdFields = fs' } } - -- This is a RecordDotSyntax update. - True -> do - let qualifiedFields = - [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' - , isQual . ambiguousFieldOccRdrName $ lbl - ] - case qualifiedFields of - qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ - PsErrOverloadedRecordUpdateNoQualifiedFields - _ -> return $ - RecordUpd - { rupd_ext = anns - , rupd_expr = exp - , rupd_flds = - OverloadedRecUpdFields - { xOLRecUpdFields = noExtField - , olRecUpdFields = toProjUpdates fbinds } } - where - toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] - toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) - - -- Convert a top-level field update like {foo=2} or {bar} (punned) - -- to a projection update. - recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs - recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = - -- The idea here is to convert the label to a singleton [FastString]. - let f = occNameFS . rdrNameOcc $ rdr - fl = DotFieldOcc noAnn (L loc (FieldLabelString f)) - lf = locA loc - in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns - where - -- If punning, compute HsVar "f" otherwise just arg. This - -- has the effect that sentinel HsVar "pun-rhs" is replaced - -- by HsVar "f" here, before the update is written to a - -- setField expressions. - punnedVar :: FastString -> LHsExpr GhcPs - punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f - -mkRdrRecordCon - :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs -mkRdrRecordCon con flds anns - = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } - -mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg -mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } -mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs - , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) } - -mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs -mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) - = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun - -mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation - -> InlinePragma --- The (Maybe Activation) is because the user can omit --- the activation spec (and usually does) -mkInlinePragma src (inl, match_info) mb_act - = InlinePragma { inl_src = src -- Note [Pragma source text] in "GHC.Types.SourceText" - , inl_inline = inl - , inl_sat = Nothing - , inl_act = act - , inl_rule = match_info } - where - act = case mb_act of - Just act -> act - Nothing -> -- No phase specified - case inl of - NoInline _ -> NeverActive - Opaque _ -> NeverActive - _other -> AlwaysActive - -mkOpaquePragma :: SourceText -> InlinePragma -mkOpaquePragma src - = InlinePragma { inl_src = src - , inl_inline = Opaque src - , inl_sat = Nothing - -- By marking the OPAQUE pragma NeverActive we stop - -- (constructor) specialisation on OPAQUE things. - -- - -- See Note [OPAQUE pragma] - , inl_act = NeverActive - , inl_rule = FunLike - } - -checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] - -> P (DataDefnCons (LConDecl GhcPs)) -checkNewOrData span name is_type_data = curry $ \ case - (NewType, [a]) -> pure $ NewTypeCon a - (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as) - (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as) - where - -- In a "type data" declaration, the constructors are in the type/class - -- namespace rather than the data constructor namespace. - -- See Note [Type data declarations] in GHC.Rename.Module. - handle_type_data - | is_type_data = map (fmap promote_constructor) - | otherwise = id - - promote_constructor (dc@ConDeclGADT { con_names = cons }) - = dc { con_names = fmap (fmap promote_name) cons } - promote_constructor (dc@ConDeclH98 { con_name = con }) - = dc { con_name = fmap promote_name con } - promote_constructor dc = dc - - promote_name name = fromMaybe name (promoteRdrName name) - ------------------------------------------------------------------------------ --- utilities for foreign declarations - --- construct a foreign import declaration --- -mkImport :: Located CCallConv - -> Located Safety - -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) - -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) -mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = - case unLoc cconv of - CCallConv -> returnSpec =<< mkCImport - CApiConv -> do - imp <- mkCImport - if isCWrapperImport imp - then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport - else returnSpec imp - StdCallConv -> returnSpec =<< mkCImport - PrimCallConv -> mkOtherImport - JavaScriptCallConv -> mkOtherImport - where - -- Parse a C-like entity string of the following form: - -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" - -- If 'cid' is missing, the function name 'v' is used instead as symbol - -- name (cf section 8.5.1 in Haskell 2010 report). - mkCImport = do - let e = unpackFS entity - case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of - Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ - PsErrMalformedEntityString - Just importSpec -> return importSpec - - isCWrapperImport (CImport _ _ _ _ CWrapper) = True - isCWrapperImport _ = False - - -- currently, all the other import conventions only support a symbol name in - -- the entity string. If it is missing, we use the function name instead. - mkOtherImport = returnSpec importSpec - where - entity' = if nullFS entity - then mkExtName (unLoc v) - else entity - funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget - - returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport - { fd_i_ext = ann - , fd_name = v - , fd_sig_ty = ty - , fd_fi = spec - } - - - --- the string "foo" is ambiguous: either a header or a C identifier. The --- C identifier case comes first in the alternatives below, so we pick --- that one. -parseCImport :: Located CCallConv -> Located Safety -> FastString -> String - -> Located SourceText - -> Maybe (ForeignImport (GhcPass p)) -parseCImport cconv safety nm str sourceText = - listToMaybe $ map fst $ filter (null.snd) $ - readP_to_S parse str - where - parse = do - skipSpaces - r <- choice [ - string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), - string "wrapper" >> return (mk Nothing CWrapper), - do optional (token "static" >> skipSpaces) - ((mk Nothing <$> cimp nm) +++ - (do h <- munch1 hdr_char - skipSpaces - let src = mkFastString h - mk (Just (Header (SourceText src) src)) - <$> cimp nm)) - ] - skipSpaces - return r - - token str = do _ <- string str - toks <- look - case toks of - c : _ - | id_char c -> pfail - _ -> return () - - mk h n = CImport sourceText cconv safety h n - - hdr_char c = not (isSpace c) - -- header files are filenames, which can contain - -- pretty much any char (depending on the platform), - -- so just accept any non-space character - id_first_char c = isAlpha c || c == '_' - id_char c = isAlphaNum c || c == '_' - - cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) - +++ (do isFun <- case unLoc cconv of - CApiConv -> - option True - (do token "value" - skipSpaces - return False) - _ -> return True - cid' <- cid - return (CFunction (StaticTarget NoSourceText cid' - Nothing isFun))) - where - cid = return nm +++ - (do c <- satisfy id_first_char - cs <- many (satisfy id_char) - return (mkFastString (c:cs))) - - --- construct a foreign export declaration --- -mkExport :: Located CCallConv - -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) - -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) -mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) - = return $ \ann -> ForD noExtField $ - ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty - , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) } - where - entity' | nullFS entity = mkExtName (unLoc v) - | otherwise = entity - --- Supplying the ext_name in a foreign decl is optional; if it --- isn't there, the Haskell name is assumed. Note that no transformation --- of the Haskell name is then performed, so if you foreign export (++), --- it's external name will be "++". Too bad; it's important because we don't --- want z-encoding (e.g. names with z's in them shouldn't be doubled) --- -mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm) - --------------------------------------------------------------------------------- --- Help with module system imports/exports - -data ImpExpSubSpec = ImpExpAbs - | ImpExpAll - | ImpExpList [LocatedA ImpExpQcSpec] - | ImpExpAllWith [LocatedA ImpExpQcSpec] - -data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) - | ImpExpQcType EpaLocation (LocatedN RdrName) - | ImpExpQcWildcard - -mkModuleImpExp :: Maybe (LocatedP (WarningTxt GhcPs)) -> [AddEpAnn] -> LocatedA ImpExpQcSpec - -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp warning anns (L l specname) subs = do - cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments - let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs - case subs of - ImpExpAbs - | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar warning - (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs (warning, ann) . L l <$> nameT - ImpExpAll -> IEThingAll (warning, ann) . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith (warning, ann) (L l newName) - NoIEWildcard (wrapped xs)) <$> nameT - ImpExpAllWith xs -> - do allowed <- getBit PatternSynonymsBit - if allowed - then - let withs = map unLoc xs - pos = maybe NoIEWildcard IEWildcard - (findIndex isImpExpQcWildcard withs) - ies :: [LocatedA (IEWrappedName GhcPs)] - ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs - in (\newName - -> IEThingWith (warning, ann) (L l newName) pos ies) - <$> nameT - else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ - PsErrIllegalPatSynExport - where - name = ieNameVal specname - nameT = - if isVarNameSpace (rdrNameSpace name) - then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ - (PsErrVarForTyCon name) - else return $ ieNameFromSpec specname - - ieNameVal (ImpExpQcName ln) = unLoc ln - ieNameVal (ImpExpQcType _ ln) = unLoc ln - ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - - ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs - ieNameFromSpec (ImpExpQcName (L l n)) = IEName noExtField (L l n) - ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n) - ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" - - wrapped = map (fmap ieNameFromSpec) - -mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space - -> P (LocatedN RdrName) -mkTypeImpExp name = - do allowed <- getBit ExplicitNamespacesBit - unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $ - PsErrIllegalExplicitNamespace - return (fmap (`setRdrNameSpace` tcClsName) name) - -checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs]) -checkImportSpec ie@(L _ specs) = - case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of - [] -> return ie - (l:_) -> importSpecError (locA l) - where - importSpecError l = - addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm - --- In the correct order -mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec) -mkImpExpSubSpec [] = return ([], ImpExpList []) -mkImpExpSubSpec [L la ImpExpQcWildcard] = - return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll) -mkImpExpSubSpec xs = - if (any (isImpExpQcWildcard . unLoc) xs) - then return $ ([], ImpExpAllWith xs) - else return $ ([], ImpExpList xs) - -isImpExpQcWildcard :: ImpExpQcSpec -> Bool -isImpExpQcWildcard ImpExpQcWildcard = True -isImpExpQcWildcard _ = False - ------------------------------------------------------------------------------ --- Warnings and failures - -warnPrepositiveQualifiedModule :: SrcSpan -> P () -warnPrepositiveQualifiedModule span = - addPsMessage span PsWarnImportPreQualified - -failNotEnabledImportQualifiedPost :: SrcSpan -> P () -failNotEnabledImportQualifiedPost loc = - addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified - -failImportQualifiedTwice :: SrcSpan -> P () -failImportQualifiedTwice loc = - addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice - -warnStarIsType :: SrcSpan -> P () -warnStarIsType span = addPsMessage span PsWarnStarIsType - -failOpFewArgs :: MonadP m => LocatedN RdrName -> m a -failOpFewArgs (L loc op) = - do { star_is_type <- getBit StarIsTypeBit - ; let is_star_type = if star_is_type then StarIsType else StarIsNotType - ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrOpFewArgs is_star_type op) } - ------------------------------------------------------------------------------ --- Misc utils - -data PV_Context = - PV_Context - { pv_options :: ParserOpts - , pv_details :: ParseContext -- See Note [Parser-Validator Details] - } - -data PV_Accum = - PV_Accum - { pv_warnings :: Messages PsMessage - , pv_errors :: Messages PsMessage - , pv_header_comments :: Strict.Maybe [LEpaComment] - , pv_comment_q :: [LEpaComment] - } - -data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum - deriving (Foldable, Functor, Traversable) - --- During parsing, we make use of several monadic effects: reporting parse errors, --- accumulating warnings, adding API annotations, and checking for extensions. These --- effects are captured by the 'MonadP' type class. --- --- Sometimes we need to postpone some of these effects to a later stage due to --- ambiguities described in Note [Ambiguous syntactic categories]. --- We could use two layers of the P monad, one for each stage: --- --- abParser :: forall x. DisambAB x => P (P x) --- --- The outer layer of P consumes the input and builds the inner layer, which --- validates the input. But this type is not particularly helpful, as it obscures --- the fact that the inner layer of P never consumes any input. --- --- For clarity, we introduce the notion of a parser-validator: a parser that does --- not consume any input, but may fail or use other effects. Thus we have: --- --- abParser :: forall x. DisambAB x => P (PV x) --- -newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } - deriving (Functor) - -instance Applicative PV where - pure a = a `seq` PV (\_ acc -> PV_Ok acc a) - (<*>) = ap - -instance Monad PV where - m >>= f = PV $ \ctx acc -> - case unPV m ctx acc of - PV_Ok acc' a -> unPV (f a) ctx acc' - PV_Failed acc' -> PV_Failed acc' - -runPV :: PV a -> P a -runPV = runPV_details noParseContext - -askParseContext :: PV ParseContext -askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details - -runPV_details :: ParseContext -> PV a -> P a -runPV_details details m = - P $ \s -> - let - pv_ctx = PV_Context - { pv_options = options s - , pv_details = details } - pv_acc = PV_Accum - { pv_warnings = warnings s - , pv_errors = errors s - , pv_header_comments = header_comments s - , pv_comment_q = comment_q s } - mkPState acc' = - s { warnings = pv_warnings acc' - , errors = pv_errors acc' - , comment_q = pv_comment_q acc' } - in - case unPV m pv_ctx pv_acc of - PV_Ok acc' a -> POk (mkPState acc') a - PV_Failed acc' -> PFailed (mkPState acc') - -instance MonadP PV where - addError err = - PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} () - addWarning w = - PV $ \_ctx acc -> - -- No need to check for the warning flag to be set, GHC will correctly discard suppressed - -- diagnostics. - PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} () - addFatalError err = - addError err >> PV (const PV_Failed) - getBit ext = - PV $ \ctx acc -> - let b = ext `xtest` pExtsBitmap (pv_options ctx) in - PV_Ok acc $! b - allocateCommentsP ss = PV $ \_ s -> - let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in - PV_Ok s { - pv_comment_q = comment_q' - } (EpaComments newAnns) - allocatePriorCommentsP ss = PV $ \_ s -> - let (header_comments', comment_q', newAnns) - = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in - PV_Ok s { - pv_header_comments = header_comments', - pv_comment_q = comment_q' - } (EpaComments newAnns) - allocateFinalCommentsP ss = PV $ \_ s -> - let (header_comments', comment_q', newAnns) - = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in - PV_Ok s { - pv_header_comments = header_comments', - pv_comment_q = comment_q' - } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) - -{- Note [Parser-Validator Details] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set -depending on validation context. We use this in checkPattern to fix #984. - -Consider this example, where the user has forgotten a 'do': - - f _ = do - x <- computation - case () of - _ -> - result <- computation - case () of () -> undefined - -GHC parses it as follows: - - f _ = do - x <- computation - (case () of - _ -> - result) <- computation - case () of () -> undefined - -Note that this fragment is parsed as a pattern: - - case () of - _ -> - result - -We attempt to detect such cases and add a hint to the diagnostic messages: - - T984.hs:6:9: - Parse error in pattern: case () of { _ -> result } - Possibly caused by a missing 'do'? - -The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed -out of the 'ParseContext', which are read by functions like 'patFail' when -constructing the 'PsParseErrorInPatDetails' data structure. When validating in a -context other than 'bindpat' (a pattern to the left of <-), we set the -details to 'noParseContext' and it has no effect on the diagnostic messages. - --} - --- | Hint about bang patterns, assuming @BangPatterns@ is off. -hintBangPat :: SrcSpan -> Pat GhcPs -> PV () -hintBangPat span e = do - bang_on <- getBit BangPatBit - unless bang_on $ - addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e - -mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) - -> [AddEpAnn] - -> PV (LHsExpr GhcPs) - --- Tuple -mkSumOrTupleExpr l boxity (Tuple es) anns = do - cs <- getCommentsFor (locA l) - return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity) - where - toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs - toTupArg (Left ann) = missingTupArg ann - toTupArg (Right a) = Present noAnn a - --- Sum --- mkSumOrTupleExpr l Unboxed (Sum alt arity e) = --- return $ L l (ExplicitSum noExtField alt arity e) -mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do - let an = case anns of - [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] -> - AnnExplicitSum o barsp barsa c - _ -> panic "mkSumOrTupleExpr" - cs <- getCommentsFor (locA l) - return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e) -mkSumOrTupleExpr l Boxed a@Sum{} _ = - addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a - -mkSumOrTuplePat - :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn] - -> PV (LocatedA (PatBuilder GhcPs)) - --- Tuple -mkSumOrTuplePat l boxity (Tuple ps) anns = do - ps' <- traverse toTupPat ps - cs <- getCommentsFor (locA l) - return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity)) - where - toTupPat :: Either (EpAnn EpaLocation) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) - -- Ignore the element location so that the error message refers to the - -- entire tuple. See #19504 (and the discussion) for details. - toTupPat p = case p of - Left _ -> addFatalError $ - mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat - Right p' -> checkLPat p' - --- Sum -mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do - p' <- checkLPat p - cs <- getCommentsFor (locA l) - let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs - return $ L l (PatBuilderPat (SumPat an p' alt arity)) -mkSumOrTuplePat l Boxed a@Sum{} _ = - addFatalError $ - mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a - -mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs -mkLHsOpTy prom x op y = - let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y - in L loc (mkHsOpTy prom x op y) - -mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs -mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr - -- See #18888 for the use of (SourceText "1") above - = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr) - where - -- The location of "%" combined with the location of "1". - locOfPct1 :: TokenLocation - locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t)) -mkMultTy pct t arr = HsExplicitMult pct t arr - -mkTokenLocation :: SrcSpan -> TokenLocation -mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc -mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb) - --- Precondition: the TokenLocation has EpaSpan, never EpaDelta. -token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation -token_location_widenR NoTokenLoc _ = NoTokenLoc -token_location_widenR tl (UnhelpfulSpan _) = tl -token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) = - (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2))) -token_location_widenR (TokenLoc (EpaDelta _ _)) _ = - -- Never happens because the parser does not produce EpaDelta. - panic "token_location_widenR: EpaDelta" - - ------------------------------------------------------------------------------ --- Token symbols - -starSym :: Bool -> FastString -starSym True = fsLit "★" -starSym False = fsLit "*" - ------------------------------------------ --- Bits and pieces for RecordDotSyntax. - -mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) - -> EpAnnCO -> LHsExpr GhcPs -mkRdrGetField loc arg field anns = - L loc HsGetField { - gf_ext = anns - , gf_expr = arg - , gf_field = field - } - -mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs -mkRdrProjection flds anns = - HsProjection { - proj_ext = anns - , proj_flds = flds - } - -mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] - -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn] - -> LHsRecProj GhcPs (LHsExpr GhcPs) -mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" -mkRdrProjUpdate loc (L l flds) arg isPun anns = - L loc HsFieldBind { - hfbAnn = anns - , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds) - , hfbRHS = arg - , hfbPun = isPun - } +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- Functions over HsSyn specialised to RdrName. + +module GHC.Parser.PostProcess ( + mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot + mkHsOpApp, + mkHsIntegral, mkHsFractional, mkHsIsString, + mkHsDo, mkMDo, mkSpliceDecl, + mkRoleAnnotDecl, + mkClassDecl, + mkTyData, mkDataFamInst, + mkTySynonym, mkTyFamInstEqn, + mkStandaloneKindSig, + mkTyFamInst, + mkFamDecl, + mkInlinePragma, + mkOpaquePragma, + mkPatSynMatchGroup, + mkRecConstrOrUpdate, + mkTyClD, mkInstD, + mkRdrRecordCon, mkRdrRecordUpd, + setRdrNameSpace, + fromSpecTyVarBndr, fromSpecTyVarBndrs, + annBinds, + stmtsAnchor, stmtsLoc, + + cvBindGroup, + cvBindsAndSigs, + cvTopDecls, + placeHolderPunRhs, + + -- Stuff to do with Foreign declarations + mkImport, + parseCImport, + mkExport, + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName + mkConDeclH98, + + -- Bunch of functions in the parser monad for + -- checking and constructing values + checkImportDecl, + checkExpBlockArguments, checkCmdBlockArguments, + checkPrecP, -- Int -> P Int + checkContext, -- HsType -> P HsContext + checkPattern, -- HsExp -> P HsPat + checkPattern_details, + incompleteDoBlock, + ParseContext(..), + checkMonadComp, + checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkValSigLhs, + LRuleTyTmVar, RuleTyTmVar(..), + mkRuleBndrs, + ruleBndrsOrDef, + checkRuleTyVarBndrNames, + mkSpecSig, + checkRecordSyntax, + checkEmptyGADTs, + addFatalError, hintBangPat, + mkBangTy, + UnpackednessPragma(..), + mkMultAnn, + mkMultField, + mkConDeclField, + + -- Help with processing exports + ImpExpSubSpec(..), + ImpExpQcSpec(..), + mkModuleImpExp, + mkPlainImpExp, + mkTypeImpExp, + mkDataImpExp, + mkImpExpSubSpec, + checkImportSpec, + warnPatternNamespaceSpecifier, + + -- Token symbols + starSym, + + -- Warnings and errors + warnStarIsType, + warnPrepositiveQualifiedModule, + failOpFewArgs, + failNotEnabledImportQualifiedPost, + failImportQualifiedTwice, + failSpliceOrQuoteTwice, + + SumOrTuple (..), + + -- Expression/command/pattern ambiguity resolution + PV, + runPV, + ECP(ECP, unECP), + DisambInfixOp(..), + DisambECP(..), + ecpFromExp, + ecpFromCmd, + ecpFromPat, + ArrowParsingMode(..), + withArrowParsingMode, withArrowParsingMode', + setTelescopeBndrsNameSpace, + PatBuilder, + + -- Type/datacon ambiguity resolution + DisambTD(..), + addUnpackednessP, + dataConBuilderCon, + dataConBuilderDetails, + mkUnboxedSumCon, + + -- ListTuplePuns related parsers + mkTupleSyntaxTy, + mkTupleSyntaxTycon, + mkListSyntaxTy0, + mkListSyntaxTy1, + withCombinedComments, + requireLTPuns, + ) where + +import GHC.Prelude +import GHC.Hs -- Lots of it +import GHC.Core.TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, dataConName ) +import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.Error +import GHC.Types.Fixity +import GHC.Types.Hint +import GHC.Types.SourceText +import GHC.Parser.Types +import GHC.Parser.Lexer +import GHC.Parser.Errors.Types +import GHC.Utils.Lexeme ( okConOcc ) +import GHC.Types.TyThing +import GHC.Core.Type ( Specificity(..) ) +import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, + nilDataConName, nilDataConKey, + listTyConName, listTyConKey, sumDataCon, + unrestrictedFunTyCon , listTyCon_RDR, unitDataCon ) +import GHC.Types.ForeignCall +import GHC.Types.SrcLoc +import GHC.Types.Unique ( hasKey ) +import GHC.Data.OrdList +import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Utils.Error +import GHC.Utils.Misc +import GHC.Utils.Monad (unlessM) +import Data.Either +import Data.List ( findIndex ) +import Data.Foldable +import qualified Data.Semigroup as Semi +import GHC.Unit.Module.Warnings +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import Text.ParserCombinators.ReadP as ReadP +import Data.Char +import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) +import Data.Kind ( Type ) +import Data.List.NonEmpty ( NonEmpty (..) ) + +{- ********************************************************************** + + Construction functions for Rdr stuff + + ********************************************************************* -} + +-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and +-- datacon by deriving them from the name of the class. We fill in the names +-- for the tycon and datacon corresponding to the class, by deriving them +-- from the name of the class itself. This saves recording the names in the +-- interface file (which would be equally good). + +-- Similarly for mkConDecl, mkClassOpSig and default-method names. + +-- *** See Note [The Naming story] in GHC.Hs.Decls **** + +mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkTyClD (L loc d) = L loc (TyClD noExtField d) + +mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkInstD (L loc d) = L loc (InstD noExtField d) + +mkClassDecl :: SrcSpan + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Located (a,[LHsFunDep GhcPs]) + -> OrdList (LHsDecl GhcPs) + -> EpLayout + -> AnnClassDecl + -> P (LTyClDecl GhcPs) + +mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn + = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls + ; (cls, tparams, fixity, ops, cps, cs) <- checkTyClHdr True tycl_hdr + ; tyvars <- checkTyVars (text "class") whereDots cls tparams + ; let anns' = annsIn { acd_openp = ops, acd_closep = cps} + ; let loc = EpAnn (spanAsAnchor loc') noAnn cs + ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey) + , tcdCtxt = mcxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } + +mkTyData :: SrcSpan + -> Bool + -> NewOrData + -> Maybe (LocatedP CType) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> Located (HsDeriving GhcPs) + -> AnnDataDefn + -> P (LTyClDecl GhcPs) +mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) + ksig data_cons (L _ maybe_deriv) annsIn + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr + ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams + ; let anns = annsIn {andd_openp = ops, andd_closep = cps} + ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns + ; !cs' <- getCommentsFor loc' + ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs) + ; return (L loc (DataDecl { tcdDExt = noExtField, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } + +mkDataDefn :: Maybe (LocatedP CType) + -> Maybe (LHsContext GhcPs) + -> Maybe (LHsKind GhcPs) + -> DataDefnCons (LConDecl GhcPs) + -> HsDeriving GhcPs + -> AnnDataDefn + -> P (HsDataDefn GhcPs) +mkDataDefn cType mcxt ksig data_cons maybe_deriv anns + = do { checkDatatypeContext mcxt + ; return (HsDataDefn { dd_ext = anns + , dd_cType = cType + , dd_ctxt = mcxt + , dd_cons = data_cons + , dd_kindSig = ksig + , dd_derivs = maybe_deriv }) } + +mkTySynonym :: SrcSpan + -> LHsType GhcPs -- LHS + -> LHsType GhcPs -- RHS + -> EpToken "type" + -> EpToken "=" + -> P (LTyClDecl GhcPs) +mkTySynonym loc lhs rhs antype aneq + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs + ; tyvars <- checkTyVars (text "type") equalsDots tc tparams + ; let anns = AnnSynDecl ops cps antype aneq + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; return (L loc' (SynDecl { tcdSExt = anns + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } + +mkStandaloneKindSig + :: SrcSpan + -> Located [LocatedN RdrName] -- LHS + -> LHsSigType GhcPs -- RHS + -> (EpToken "type", TokDcolon) + -> P (LStandaloneKindSig GhcPs) +mkStandaloneKindSig loc lhs rhs anns = + do { vs <- mapM check_lhs_name (unLoc lhs) + ; v <- check_singular_lhs (reverse vs) + ; return $ L (noAnnSrcSpan loc) + $ StandaloneKindSig anns v rhs } + where + check_lhs_name v@(unLoc->name) = + if isUnqual name && isTcOcc (rdrNameOcc name) + then return v + else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $ + (PsErrUnexpectedQualifiedConstructor (unLoc v)) + check_singular_lhs vs = + case vs of + [] -> panic "mkStandaloneKindSig: empty left-hand side" + [v] -> return v + _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $ + (PsErrMultipleNamesInStandaloneKindSignature vs) + +mkTyFamInstEqn :: SrcSpan + -> HsOuterFamEqnTyVarBndrs GhcPs + -> LHsType GhcPs + -> LHsType GhcPs + -> EpToken "=" + -> P (LTyFamInstEqn GhcPs) +mkTyFamInstEqn loc bndrs lhs rhs annEq + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; return (L loc' $ FamEqn + { feqn_ext = (ops, cps, annEq) + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = rhs })} + +mkDataFamInst :: SrcSpan + -> NewOrData + -> Maybe (LocatedP CType) + -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs + , LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> Located (HsDeriving GhcPs) + -> AnnDataDefn + -> P (LInstDecl GhcPs) +mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) + ksig data_cons (L _ maybe_deriv) anns + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False tycl_hdr + ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons + ; let anns' = anns {andd_openp = ops, andd_closep = cps} + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv anns' + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl + (FamEqn { feqn_ext = ([], [], NoEpTok) + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = defn })))) } + + + +mkTyFamInst :: SrcSpan + -> TyFamInstEqn GhcPs + -> EpToken "type" + -> EpToken "instance" + -> P (LInstDecl GhcPs) +mkTyFamInst loc eqn t i = do + return (L (noAnnSrcSpan loc) (TyFamInstD noExtField + (TyFamInstDecl (t,i) eqn))) + +mkFamDecl :: SrcSpan + -> FamilyInfo GhcPs + -> TopLevelFlag + -> LHsType GhcPs -- LHS + -> LFamilyResultSig GhcPs -- Optional result signature + -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> AnnFamilyDecl + -> P (LTyClDecl GhcPs) +mkFamDecl loc info topLevel lhs ksig injAnn annsIn + = do { (tc, tparams, fixity, ops, cps, cs) <- checkTyClHdr False lhs + ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams + ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs + ; let anns' = annsIn { afd_openp = ops, afd_closep = cps } + ; return (L loc' (FamDecl noExtField (FamilyDecl + { fdExt = anns' + , fdTopLevel = topLevel + , fdInfo = info, fdLName = tc + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = ksig + , fdInjectivityAnn = injAnn }))) } + where + equals_or_where = case info of + DataFamily -> empty + OpenTypeFamily -> empty + ClosedTypeFamily {} -> whereDots + +mkSpliceDecl :: LHsExpr GhcPs -> (LHsDecl GhcPs) +-- If the user wrote +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if they wrote, say, +-- f x then behave as if they'd written $(f x) +-- ie a SpliceD +-- +-- Typed splices are not allowed at the top level, thus we do not represent them +-- as spliced declaration. See #10945 +mkSpliceDecl lexpr@(L loc expr) + | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr + = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice) + + | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr + = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice) + + | otherwise + = L loc $ SpliceD noExtField (SpliceDecl noExtField + (L (l2l loc) (HsUntypedSpliceExpr noAnn (la2la lexpr))) + BareSplice) + +mkRoleAnnotDecl :: SrcSpan + -> LocatedN RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> (EpToken "type", EpToken "role") + -> P (LRoleAnnotDecl GhcPs) +mkRoleAnnotDecl loc tycon roles anns + = do { roles' <- mapM parse_role roles + ; !cs <- getCommentsFor loc + ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs) + $ RoleAnnotDecl anns tycon roles' } + where + role_data_type = dataTypeOf (undefined :: Role) + all_roles = map fromConstr $ dataTypeConstrs role_data_type + possible_roles = [(fsFromRole role, role) | role <- all_roles] + + parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing + parse_role (L loc_role (Just role)) + = case lookup role possible_roles of + Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role + Nothing -> + let nearby = fuzzyLookup (unpackFS role) + (mapFst unpackFS possible_roles) + in + addFatalError $ mkPlainErrorMsgEnvelope loc_role $ + (PsErrIllegalRoleName role nearby) + +mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs +mkMDo ctxt stmts tok loc + = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok []) + +-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to +-- binders without annotations. Only accepts specified variables, and errors if +-- any of the provided binders has an 'InferredSpec' annotation. +fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs] +fromSpecTyVarBndrs = mapM fromSpecTyVarBndr + +-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without +-- annotations. Only accepts specified variables, and errors if the provided +-- binder has an 'InferredSpec' annotation. +fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs) +fromSpecTyVarBndr (L loc (HsTvb xtv flag idp k)) = do + case flag of + SpecifiedSpec -> return () + InferredSpec -> addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + PsErrInferredTypeVarNotAllowed + return $ L loc (HsTvb xtv () idp k) + +-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@ +annBinds :: EpToken "where" -> EpAnnComments -> HsLocalBinds GhcPs + -> (HsLocalBinds GhcPs, Maybe EpAnnComments) +annBinds w cs (HsValBinds an bs) = (HsValBinds (add_where w an cs) bs, Nothing) +annBinds w cs (HsIPBinds an bs) = (HsIPBinds (add_where w an cs) bs, Nothing) +annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs) + +add_where :: EpToken "where" -> EpAnn (AnnList (EpToken "where")) -> EpAnnComments -> EpAnn (AnnList (EpToken "where")) +add_where w@(EpTok (EpaSpan (RealSrcSpan rs _))) (EpAnn a al cs) cs2 + | valid_anchor a + = EpAnn (widenAnchorT a w) (al { al_rest = w}) (cs Semi.<> cs2) + | otherwise + = EpAnn (patch_anchor rs a) + (al { al_anchor = (fmap (patch_anchor rs) (al_anchor al)) + , al_rest = w}) + (cs Semi.<> cs2) +add_where _ _ _ = panic "add_where" + -- EpaDelta should only be used for transformations + +valid_anchor :: EpaLocation -> Bool +valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0 +valid_anchor _ = False + +-- If the decl list for where binds is empty, the anchor ends up +-- invalid. In this case, use the parent one +patch_anchor :: RealSrcSpan -> EpaLocation -> EpaLocation +patch_anchor r EpaDelta{} = EpaSpan (RealSrcSpan r Strict.Nothing) +patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb) + where + r = if srcSpanStartLine r0 < 0 then r1 else r0 +patch_anchor _ (EpaSpan ss) = EpaSpan ss + +-- | The anchor for a stmtlist is based on either the location or +-- the first semicolon annotion. +stmtsAnchor :: Located (OrdList (EpToken tok),a) -> Maybe EpaLocation +stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (EpTok (EpaSpan (RealSrcSpan r rb))) _), _)) + = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb) +stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb) +stmtsAnchor _ = Nothing + +stmtsLoc :: Located (OrdList (EpToken tok),a) -> SrcSpan +stmtsLoc (L l ((ConsOL aa _), _)) + = widenSpanT l aa +stmtsLoc (L l _) = l + +{- ********************************************************************** + + #cvBinds-etc# Converting to @HsBinds@, etc. + + ********************************************************************* -} + +-- | Function definitions are restructured here. Each is assumed to be recursive +-- initially, and non recursive definitions are discovered by the dependency +-- analyser. + + +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] +cvTopDecls decls = getMonoBindAll (fromOL decls) + +-- Declaration list may only contain value bindings and signatures. +cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) +cvBindGroup binding + = do { (mbs, sigs, fam_ds, tfam_insts + , dfam_insts, _) <- cvBindsAndSigs binding + ; massert (null fam_ds && null tfam_insts && null dfam_insts) + ; return $ ValBinds NoAnnSortKey mbs sigs } + +cvBindsAndSigs :: OrdList (LHsDecl GhcPs) + -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigs fb = do + fb' <- drop_bad_decls (fromOL fb) + return (partitionBindsAndSigs (getMonoBindAll fb')) + where + -- cvBindsAndSigs is called in several places in the parser, + -- and its items can be produced by various productions: + -- + -- * decl (when parsing a where clause or a let-expression) + -- * decl_inst (when parsing an instance declaration) + -- * decl_cls (when parsing a class declaration) + -- + -- partitionBindsAndSigs can handle almost all declaration forms produced + -- by the aforementioned productions, except for SpliceD, which we filter + -- out here (in drop_bad_decls). + -- + -- We're not concerned with every declaration form possible, such as those + -- produced by the topdecl parser production, because cvBindsAndSigs is not + -- called on top-level declarations. + drop_bad_decls [] = return [] + drop_bad_decls (L l (SpliceD _ d) : ds) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d + drop_bad_decls ds + drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] + -> (LHsBind GhcPs, [LHsDecl GhcPs]) +-- Suppose (b',ds') = getMonoBind b ds +-- ds is a list of parsed bindings +-- b is a MonoBinds that has just been read off the front + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- All Haddock comments between equations inside the group are +-- discarded. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1) + , fun_matches = + MG { mg_alts = (L _ m1@[L _ mtchs1]) } })) + binds + | has_args m1 + = go [L loc1 mtchs1] (noAnnSrcSpan $ locA loc1) binds [] + where + -- See Note [Exact Print Annotations for FunBind] + go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun + -> SrcSpanAnnA -- current top level loc + -> [LHsDecl GhcPs] -- Any docbinds seen + -> [LHsDecl GhcPs] -- rest of decls to be processed + -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls + go mtchs loc + ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2) + , fun_matches = + MG { mg_alts = (L _ [L lm2 mtchs2]) } }))) + : binds) _ + | f1 == f2 = + let (loc2', lm2') = transferAnnsA loc2 lm2 + in go (L lm2' mtchs2 : mtchs) + (combineSrcSpansA loc loc2') binds [] + go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go mtchs (combineSrcSpansA loc loc2) binds doc_decls' + go mtchs loc binds doc_decls + = let + L llm last_m = head mtchs -- Guaranteed at least one + (llm',loc') = transferAnnsOnlyA llm loc -- Keep comments, transfer trailing + + matches' = reverse (L llm' last_m:tail mtchs) + L lfm first_m = head matches' + (lfm', loc'') = transferCommentsOnlyA lfm loc' + in + ( L loc'' (makeFunBind fun_id1 (mkLocatedList $ (L lfm' first_m:tail matches'))) + , (reverse doc_decls) ++ binds) + -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments + +getMonoBind bind binds = (bind, binds) + +{- Note [Exact Print Annotations for FunBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +An individual Match that ends up in a FunBind MatchGroup is initially +parsed as a LHsDecl. This takes the form + + L loc (ValD NoExtField (FunBind ... [L lm (Match ..)])) + +The loc contains the annotations, in particular comments, which are to +precede the declaration when printed, and [TrailingAnn] which are to +follow it. The [TrailingAnn] captures semicolons that may appear after +it when using the braces and semis style of coding. + +The match location (lm) has only a location in it at this point, no +annotations. Its location is the same as the top level location in +loc. + +What getMonoBind does it to take a sequence of FunBind LHsDecls that +belong to the same function and group them into a single function with +the component declarations all combined into the single MatchGroup as +[LMatch GhcPs]. + +Given that when exact printing a FunBind the exact printer simply +iterates over all the matches and prints each in turn, the simplest +behaviour would be to simply take the top level annotations (loc) for +each declaration, and use them for the individual component matches +(lm). + +The problem is the exact printer first has to deal with the top level +LHsDecl, which means annotations for the loc. This needs to be able to +be exact printed in the context of surrounding declarations, and if +some refactor decides to move the declaration elsewhere, the leading +comments and trailing semicolons need to be handled at that level. + +So the solution is to combine all the matches into one, pushing the +annotations into the LMatch's, and then at the end extract the +comments from the first match and [TrailingAnn] from the last to go in +the top level LHsDecl. +-} + +-- Group together adjacent FunBinds for every function. +getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +getMonoBindAll [] = [] +getMonoBindAll (L l (ValD _ b) : ds) = + let (L l' b', ds') = getMonoBind (L l b) ds + in L l' (ValD noExtField b') : getMonoBindAll ds' +getMonoBindAll (d : ds) = d : getMonoBindAll ds + +has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool +has_args [] = panic "GHC.Parser.PostProcess.has_args" +has_args (L _ (Match { m_pats = L _ args }) : _) = not (null args) + -- Don't group together FunBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). + +{- ********************************************************************** + + #PrefixToHS-utils# Utilities for conversion + + ********************************************************************* -} + +{- Note [Parsing data constructors is hard] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The problem with parsing data constructors is that they look a lot like types. +Compare: + + (s1) data T = C t1 t2 + (s2) type T = C t1 t2 + +Syntactically, there's little difference between these declarations, except in +(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. + +This similarity would pose no problem if we knew ahead of time if we are +parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple +(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing +data constructors, and in other contexts (e.g. 'type' declarations) assume we +are parsing type constructors. + +This simple rule does not work because of two problematic cases: + + (p1) data T = C t1 t2 :+ t3 + (p2) data T = C t1 t2 => t3 + +In (p1) we encounter (:+) and it turns out we are parsing an infix data +declaration, so (C t1 t2) is a type and 'C' is a type constructor. +In (p2) we encounter (=>) and it turns out we are parsing an existential +context, so (C t1 t2) is a constraint and 'C' is a type constructor. + +As the result, in order to determine whether (C t1 t2) declares a data +constructor, a type, or a context, we would need unlimited lookahead which +'happy' is not so happy with. +-} + +-- | Reinterpret a type constructor, including type operators, as a data +-- constructor. +-- See Note [Parsing data constructors is hard] +tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName) +tyConToDataCon (L loc tc) + | okConOcc (occNameString occ) + = return (L loc (setRdrNameSpace tc srcDataName)) + + | otherwise + = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc) + where + occ = rdrNameOcc tc + +mkPatSynMatchGroup :: LocatedN RdrName + -> LocatedLW (OrdList (LHsDecl GhcPs)) + -> P (MatchGroup GhcPs (LHsExpr GhcPs)) +mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; when (null matches) (wrongNumberErr (locA loc)) + ; return $ mkMatchGroup FromSource (L ld matches) } + where + fromDecl (L loc decl@(ValD _ (PatBind _ + pat@(L _ (ConPat _conAnn ln@(L _ name) details)) + _ rhs))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr (locA loc) decl + -- conAnn should only be AnnOpenP, AnnCloseP, so the rest should be empty + ; let ann_fun = mk_ann_funrhs [] [] + ; match <- case details of + PrefixCon pats -> return $ Match { m_ext = noExtField + , m_ctxt = ctxt, m_pats = L l pats + , m_grhss = rhs } + where + l = listLocation pats + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict + , mc_an = ann_fun } + + InfixCon p1 p2 -> return $ Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = L l [p1, p2] + , m_grhss = rhs } + where + l = listLocation [p1, p2] + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Infix + , mc_strictness = NoSrcStrict + , mc_an = ann_fun } + + RecCon{} -> recordPatSynErr (locA loc) pat + ; return $ L loc match } + fromDecl (L loc decl) = extraDeclErr (locA loc) decl + + extraDeclErr loc decl = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) + + wrongNameBindingErr loc decl = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) + + wrongNumberErr loc = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrEmptyWhereInPatSynDecl patsyn_name) + +recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a +recordPatSynErr loc pat = + addFatalError $ mkPlainErrorMsgEnvelope loc $ + (PsErrRecordSyntaxInPatSynDecl pat) + +mkConDeclH98 :: (TokDarrow, (TokForall, EpToken ".")) -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] + -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs + -> ConDecl GhcPs + +mkConDeclH98 (tdarrow, (tforall,tdot)) name mb_forall mb_cxt args + = ConDeclH98 { con_ext = AnnConDeclH98 tforall tdot tdarrow + , con_name = name + , con_forall = isJust mb_forall + , con_ex_tvs = mb_forall `orElse` [] + , con_mb_cxt = mb_cxt + , con_args = args + , con_doc = Nothing } + +-- | Construct a GADT-style data constructor from the constructor names and +-- their type. Some interesting aspects of this function: +-- +-- * This splits up the constructor type into its quantified type variables (if +-- provided), context (if provided), argument types, and result type, and +-- records whether this is a prefix or record GADT constructor. See +-- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. +mkGadtDecl :: SrcSpan + -> NonEmpty (LocatedN RdrName) + -> TokDcolon + -> LHsSigType GhcPs + -> P (LConDecl GhcPs) +mkGadtDecl loc names dcol ty = do + + (args, res_ty, (ops, cps), csa) <- + case body_ty of + L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (XHsType (HsRecTy an rf))) res_ty) -> do + arr <- case hsArr of + HsUnannotated (EpArrow arr) -> return arr + _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $ + (PsErrIllegalGadtRecordMultiplicity hsArr) + return noAnn + + return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty + , ([], []), epAnnComments ll) + _ -> do + let ((ops, cps), cs, arg_types, res_type) = splitHsFunType body_ty + return (PrefixConGADT noExtField arg_types, res_type, (ops,cps), cs) + + let l = EpAnn (spanAsAnchor loc) noAnn csa + + pure $ L l ConDeclGADT + { con_g_ext = AnnConDeclGADT ops cps dcol + , con_names = names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = mcxt + , con_g_args = args + , con_res_ty = res_ty + , con_doc = Nothing } + where + (outer_bndrs, inner_bndrs, mcxt, body_ty) = splitLHsGadtTy ty + outer_bndrs_loc = case outer_bndrs of + HsOuterImplicit{} -> getLoc ty + HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments + + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- ^ This rather gruesome function is used mainly by the parser. +-- +-- Case #1. When parsing: +-- +-- > data T a = T | T1 Int +-- +-- we parse the data constructors as /types/ because of parser ambiguities, +-- so then we need to change the /type constr/ to a /data constr/ +-- +-- The exact-name case /can/ occur when parsing: +-- +-- > data [] a = [] | a : [a] +-- +-- For the exact-name case we return an original name. +-- +-- Case #2. When parsing: +-- +-- > x = fn (forall a. a) -- RequiredTypeArguments +-- +-- we use setRdrNameSpace to set the namespace of forall-bound variables. +-- +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns + | Just thing <- wiredInNameTyThing_maybe n + = setWiredInNameSpace thing ns + -- Preserve Exact Names for wired-in things, + -- notably tuples and lists + + | isExternalName n + = Orig (nameModule n) occ + + | otherwise -- This can happen when quoting and then + -- splicing a fixity declaration for a type + = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + where + occ = setOccNameSpace ns (nameOccName n) + +setWiredInNameSpace :: TyThing -> NameSpace -> RdrName +setWiredInNameSpace (ATyCon tc) ns + | isDataConNameSpace ns + = ty_con_data_con tc + | isTcClsNameSpace ns + = Exact (getName tc) -- No-op + +setWiredInNameSpace (AConLike (RealDataCon dc)) ns + | isTcClsNameSpace ns + = data_con_ty_con dc + | isDataConNameSpace ns + = Exact (getName dc) -- No-op + +setWiredInNameSpace thing ns + = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) + +ty_con_data_con :: TyCon -> RdrName +ty_con_data_con tc + | isTupleTyCon tc + , Just dc <- tyConSingleDataCon_maybe tc + = Exact (getName dc) + + | tc `hasKey` listTyConKey + = Exact nilDataConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace srcDataName (getOccName tc)) + +data_con_ty_con :: DataCon -> RdrName +data_con_ty_con dc + | let tc = dataConTyCon dc + , isTupleTyCon tc + = Exact (getName tc) + + | dc `hasKey` nilDataConKey + = Exact listTyConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace tcClsName (getOccName dc)) + + + +{- Note [setRdrNameSpace for wired-in names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Types, which declares (:), we have + infixr 5 : +The ambiguity about which ":" is meant is resolved by parsing it as a +data constructor, but then using dataTcOccs to try the type constructor too; +and that in turn calls setRdrNameSpace to change the name-space of ":" to +tcClsName. There isn't a corresponding ":" type constructor, but it's painful +to make setRdrNameSpace partial, so we just make an Unqual name instead. It +really doesn't matter! +-} + +eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a +-- Adapts the Either monad to the P monad +eitherToP (Left err) = addFatalError err +eitherToP (Right thing) = return thing + +checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs] + -> P (LHsQTyVars GhcPs) -- the synthesized type variables +-- ^ Check whether the given list of type parameters are all type variables +-- (possibly with a kind signature). +checkTyVars pp_what equals_or_where tc tparms + = do { tvs <- mapM check tparms + ; return (mkHsQTvs tvs) } + where + check (HsTypeArg at ki) = chkParens [] [] (HsBndrInvisible at) ki + check (HsValArg _ ty) = chkParens [] [] (HsBndrRequired noExtField) ty + check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $ + (PsErrMalformedDecl pp_what (unLoc tc)) + -- Keep around an action for adjusting the annotations of extra parens + chkParens :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs + -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) + chkParens ops cps bvis (L l (HsParTy _ (L lt ty))) + = let + (o,c) = mkParensLocs (realSrcSpan $ locA l) + (_,lt') = transferCommentsOnlyA l lt + in + chkParens (o:ops) (c:cps) bvis (L lt' ty) + chkParens ops cps bvis ty = chk ops cps bvis ty + + -- Check that the name space is correct! + chk :: [EpaLocation] -> [EpaLocation] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs) + chk ops cps bvis (L l (HsKindSig tok_dc (L annt t) k)) + | Just (ann, bvar) <- match_bndr_var t + = let + bkind = HsBndrKind noExtField k + an = (reverse ops) ++ cps + in + return (L (widenLocatedAnL (l Semi.<> annt) (for_widening bvis:an)) + (HsTvb (AnnTyVarBndr (reverse ops) cps ann tok_dc) bvis bvar bkind)) + chk ops cps bvis (L l t) + | Just (ann, bvar) <- match_bndr_var t + = let + bkind = HsBndrNoKind noExtField + an = (reverse ops) ++ cps + in + return (L (widenLocatedAnL l (for_widening bvis:an)) + (HsTvb (AnnTyVarBndr (reverse ops) cps ann noAnn) bvis bvar bkind)) + chk _ _ _ t@(L loc _) + = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) + + match_bndr_var :: HsType GhcPs -> Maybe (EpToken "'", HsBndrVar GhcPs) + match_bndr_var (HsTyVar ann _ tv) | isRdrTyVar (unLoc tv) + = Just (ann, HsBndrVar noExtField tv) + match_bndr_var (HsWildCardTy tok) + = Just (noAnn, HsBndrWildCard tok) + match_bndr_var _ = Nothing + + -- Return a EpaLocation for use in widenLocatedAnL. + for_widening :: HsBndrVis GhcPs -> EpaLocation + for_widening (HsBndrInvisible (EpTok loc)) = loc + for_widening _ = noAnn + + +whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars +whereDots = text "where ..." +equalsDots = text "= ..." + +checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just c) + = do allowed <- getBit DatatypeContextsBit + unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $ + (PsErrIllegalDataTypeContext c) + +type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar +data RuleTyTmVar = RuleTyTmVar AnnTyVarBndr (LocatedN RdrName) (Maybe (LHsType GhcPs)) +-- ^ Essentially a wrapper for a @RuleBndr GhcPs@ + +ruleBndrsOrDef :: Maybe (RuleBndrs GhcPs) -> RuleBndrs GhcPs +ruleBndrsOrDef (Just bndrs) = bndrs +ruleBndrsOrDef Nothing = mkRuleBndrs noAnn Nothing [] + +mkRuleBndrs :: HsRuleBndrsAnn -> Maybe [LRuleTyTmVar] -> [LRuleTyTmVar] -> RuleBndrs GhcPs +mkRuleBndrs ann tvbs tmbs + = RuleBndrs { rb_ext = ann + , rb_tyvs = fmap (fmap (setLHsTyVarBndrNameSpace tvName . cvt_tv)) tvbs + , rb_tmvs = fmap (fmap cvt_tm) tmbs } + where + -- cvt_tm turns RuleTyTmVars into RuleBnrs - this is straightforward + cvt_tm (RuleTyTmVar ann v Nothing) = RuleBndr ann v + cvt_tm (RuleTyTmVar ann v (Just sig)) = RuleBndrSig ann v (mkHsPatSigType noAnn sig) + + -- cvt_tv turns RuleTyTmVars into HsTyVarBndrs - this is more interesting + cvt_tv (L l (RuleTyTmVar ann v msig)) + = L (l2l l) (HsTvb ann () (HsBndrVar noExtField v) (cvt_sig msig)) + cvt_sig Nothing = HsBndrNoKind noExtField + cvt_sig (Just sig) = HsBndrKind noExtField sig + +checkRuleTyVarBndrNames :: [LRuleTyTmVar] -> P () +-- See Note [Parsing explicit foralls in Rules] in Parser.y +checkRuleTyVarBndrNames bndrs + = sequence_ [ check lname | L _ (RuleTyTmVar _ lname _) <- bndrs ] + where + check (L loc (Unqual occ)) = + when (occNameFS occ `elem` [fsLit "family",fsLit "role"]) $ + addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + PsErrParseErrorOnInput occ + check _ = panic "checkRuleTyVarBndrNames" + +-- | Deal with both old-form and new-form specialise pragmas, using the new +-- 'SpecSigE' form unless there are multiple comma-separated type signatures, +-- in which case we use the old-form. +-- +-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig. +mkSpecSig :: InlinePragma + -> AnnSpecSig + -> Maybe (RuleBndrs GhcPs) + -> LHsExpr GhcPs + -> Maybe (Located (TokDcolon, OrdList (LHsSigType GhcPs))) + -> P (Sig GhcPs) +mkSpecSig inl_prag activation_anns m_rule_binds expr m_sigtypes_ascr + = case m_sigtypes_ascr of + Nothing + -- New form, no trailing type signature, e.g {-# SPECIALISE f @Int #-} + -> pure $ + SpecSigE activation_anns + (ruleBndrsOrDef m_rule_binds) expr inl_prag + + Just (L lt (colon_ann, sigtype_ol)) + + -- Singleton, e.g. {-# SPECIALISE f :: ty #-} + -- Use the SpecSigE route + | [sigtype] <- sigtype_list + -> pure $ + SpecSigE activation_anns + (ruleBndrsOrDef m_rule_binds) + (L ((combineSrcSpansA (getLoc expr) (noAnnSrcSpan lt))) + (ExprWithTySig colon_ann expr (mkHsWildCardBndrs sigtype))) + inl_prag + + -- So we must have the old form {# SPECIALISE f :: ty1, ty2, ty3 #-} + -- Use the old SpecSig route + | Nothing <- m_rule_binds + , L _ (HsVar _ var) <- expr + -> do addPsMessage sigs_loc PsWarnSpecMultipleTypeAscription + pure $ + SpecSig (activation_anns {ass_dcolon = Just colon_ann }) + var sigtype_list inl_prag + + | otherwise -> + addFatalError $ + mkPlainErrorMsgEnvelope sigs_loc PsErrSpecExprMultipleTypeAscription + + where + sigtype_list = fromOL sigtype_ol + sigs_loc = + getHasLoc colon_ann `combineSrcSpans` getHasLoc (last sigtype_list) + +checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a) +checkRecordSyntax lr@(L loc r) + = do allowed <- getBit TraditionalRecordSyntaxBit + unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrIllegalTraditionalRecordSyntax (ppr r)) + return lr + +-- | Check if the gadt_constrlist is empty. Only raise parse error for +-- `data T where` to avoid affecting existing error message, see #8258. +checkEmptyGADTs :: Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs]) + -> P (Located ((EpToken "where", EpToken "{", EpToken "}"), [LConDecl GhcPs])) +checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. + = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax + unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $ + PsErrIllegalWhereInDataDecl + return gadts +checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. + +checkTyClHdr :: Bool -- True <=> class header + -- False <=> type header + -> LHsType GhcPs + -> P (LocatedN RdrName, -- the head symbol (type or class name) + [LHsTypeArg GhcPs], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format + [EpToken "("], -- API Annotation for HsParTy + [EpToken ")"], -- when stripping parens + EpAnnComments) -- Accumulated comments from re-arranging +-- Well-formedness check and decomposition of type and class heads. +-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) +-- Int :*: Bool into (:*:, [Int, Bool]) +-- returning the pieces +checkTyClHdr is_cls ty + = goL emptyComments ty [] [] [] Prefix + where + goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix + + -- workaround to define '*' despite StarIsType + go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix + = do { addPsMessage (locA l) PsWarnStarBinder + ; let name = mkOccNameFS tcClsName (starSym isUni) + ; let a' = newAnns ll l an + ; return (L a' (Unqual name), acc, fix + , (reverse ops'), cps', cs) } + + go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix + | isRdrTc tc = return (ltc, acc, fix, (reverse ops), cps, cs Semi.<> comments l) + go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix + | isRdrTc tc = return (ltc, lhs:rhs:acc, Infix, (reverse ops), cps, cs Semi.<> comments l) + where lhs = HsValArg noExtField t1 + rhs = HsValArg noExtField t2 + go cs l (HsParTy (o,c) ty) acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix + go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix + go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix + go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix + = return (L (l2l l) (nameRdrName tup_name) + , map (HsValArg noExtField) ts, fix, (reverse ops), cps, cs Semi.<> comments l) + where + arity = length ts + tup_name | is_cls = cTupleTyConName arity + | otherwise = getName (tupleTyCon Boxed arity) + -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) + go _ l _ _ _ _ _ + = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrMalformedTyOrClDecl ty) + + -- Combine the annotations from the HsParTy and HsStarTy into a + -- new one for the LocatedN RdrName + newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> (EpToken "(", EpToken ")") -> SrcSpanAnnN + newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (o,c) = + let + lr = combineSrcSpans (locA l1) (locA l) + in + EpAnn (EpaSpan lr) (NameAnn (NameParens o c) ap ta) (csp0 Semi.<> csp) + +-- | Yield a parse error if we have a function applied directly to a do block +-- etc. and BlockArguments is not enabled. +checkExpBlockArguments :: LHsExpr GhcPs -> PV () +checkCmdBlockArguments :: LHsCmd GhcPs -> PV () +(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) + where + checkExpr :: LHsExpr GhcPs -> PV () + checkExpr expr = case unLoc expr of + HsDo _ (DoExpr m) _ -> check (PsErrDoInFunAppExpr m) expr + HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m) expr + HsCase {} -> check PsErrCaseInFunAppExpr expr + HsLam _ lam_variant _ -> check (PsErrLambdaInFunAppExpr lam_variant) expr + HsLet {} -> check PsErrLetInFunAppExpr expr + HsIf {} -> check PsErrIfInFunAppExpr expr + HsProc {} -> check PsErrProcInFunAppExpr expr + _ -> return () + + checkCmd :: LHsCmd GhcPs -> PV () + checkCmd cmd = case unLoc cmd of + HsCmdLam _ lam_variant _ -> check (PsErrLambdaCmdInFunAppCmd lam_variant) cmd + HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd cmd + HsCmdIf {} -> check PsErrIfCmdInFunAppCmd cmd + HsCmdLet {} -> check PsErrLetCmdInFunAppCmd cmd + HsCmdDo {} -> check PsErrDoCmdInFunAppCmd cmd + _ -> return () + + check err a = do + blockArguments <- getBit BlockArgumentsBit + unless blockArguments $ + addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a) + +-- | Validate the context constraints and break up a context into a list +-- of predicates. +-- +-- @ +-- (Eq a, Ord b) --> [Eq a, Ord b] +-- Eq a --> [Eq a] +-- (Eq a) --> [Eq a] +-- (((Eq a))) --> [Eq a] +-- @ +checkContext :: LHsType GhcPs -> P (LHsContext GhcPs) +checkContext orig_t@(L (EpAnn l _ cs) _orig_t) = + check ([],[],cs) orig_t + where + check :: ([EpToken "("],[EpToken ")"],EpAnnComments) + -> LHsType GhcPs -> P (LHsContext GhcPs) + check (oparens,cparens,cs) (L _l (HsTupleTy (AnnParens o c) HsBoxedOrConstraintTuple ts)) + -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can + -- be used as context constraints. + -- Ditto () + = mkCTuple (oparens ++ [o], c : cparens, cs) ts + + -- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure + -- downstream. + -- This converts them just like when they are parsed as types in the punned case. + check (oparens,cparens,cs) (L _l (HsExplicitTupleTy (q,o,c) _ ts)) + = punsAllowed >>= \case + True -> unprocessed + False -> do + let + (op, cp) = case q of + EpTok ql -> ([EpTok ql], [c]) + _ -> ([o], [c]) + mkCTuple (oparens ++ op, cp ++ cparens, cs) ts + check (opi,cpi,csi) (L _lp1 (HsParTy (o,c) ty)) + -- to be sure HsParTy doesn't get into the way + = check (o:opi, c:cpi, csi) ty + + -- No need for anns, returning original + check (_opi,_cpi,_csi) _t = unprocessed + + unprocessed = + return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_t]) + + + mkCTuple (oparens, cparens, cs) ts = + -- Append parens so that the original order in the source is maintained + return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts) + +-- | The same as `checkContext`, but for expressions. +-- +-- Validate the context constraints and break up a context into a list +-- of predicates. +-- +-- @ +-- (Eq a, Ord b) --> [Eq a, Ord b] +-- Eq a --> [Eq a] +-- (Eq a) --> [Eq a] +-- (((Eq a))) --> [Eq a] +-- @ +checkContextExpr :: LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs]) +checkContextExpr orig_expr@(L (EpAnn l _ cs) _) = + check ([],[], cs) orig_expr + where + check :: ([EpToken "("],[EpToken ")"],EpAnnComments) + -> LHsExpr GhcPs -> PV (LocatedC [LHsExpr GhcPs]) + check (oparens,cparens,cs) (L _ (ExplicitTuple (ap_open, ap_close) tup_args boxity)) + -- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be a context + | isBoxed boxity + , Just es <- tupArgsPresent_maybe tup_args + = mkCTuple (oparens ++ [EpTok ap_open], EpTok ap_close : cparens, cs) es + check (opi, cpi, csi) (L _ (HsPar (open_tok, close_tok) expr)) + = check (opi ++ [open_tok], close_tok : cpi, csi) expr + check (oparens,cparens,cs) (L _ (HsVar _ (L (EpAnn _ (NameAnnOnly (NameParens open closed) []) _) name))) + | name == nameRdrName (dataConName unitDataCon) + = mkCTuple (oparens ++ [open], closed : cparens, cs) [] + check _ _ = unprocessed + + unprocessed = + return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_expr]) + + mkCTuple (oparens, cparens, cs) ts = + -- Append parens so that the original order in the source is maintained + return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts) + +checkImportDecl :: Maybe (EpToken "qualified") + -> Maybe (EpToken "qualified") + -> Maybe EpAnnLevel + -> Maybe EpAnnLevel + -> P ((Maybe (EpToken "qualified"), ImportDeclQualifiedStyle) + , (Maybe EpAnnLevel, ImportDeclLevelStyle)) +checkImportDecl mPre mPost preLevel postLevel = do + let whenJust mg f = maybe (pure ()) f mg + tokenSpan tok = RealSrcSpan (epaLocationRealSrcSpan $ getEpTokenLoc tok) Strict.Nothing + + importQualifiedPostEnabled <- getBit ImportQualifiedPostBit + + -- Error if 'qualified' found in postpositive position and + -- 'ImportQualifiedPost' is not in effect. + whenJust mPost $ \post -> + when (not importQualifiedPostEnabled) $ + failNotEnabledImportQualifiedPost (tokenSpan post) + + -- Error if 'qualified' occurs in both pre and postpositive + -- positions. + qualSpec <- importDeclQualifiedStyle mPre mPost + levelSpec <- importDeclLevelStyle preLevel postLevel + + -- Warn if 'qualified' found in prepositive position and + -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. + whenJust mPre $ \pre -> + warnPrepositiveQualifiedModule (tokenSpan pre) + + return (qualSpec, levelSpec) + +-- | Given two possible located 'qualified' tokens, compute a style +-- (in a conforming Haskell program only one of the two can be not +-- 'Nothing'). This is called from "GHC.Parser". +importDeclQualifiedStyle :: Maybe (EpToken "qualified") + -> Maybe (EpToken "qualified") + -> P (Maybe (EpToken "qualified"), ImportDeclQualifiedStyle) +importDeclQualifiedStyle mPre mPost = + case (mPre, mPost) of + (Just {}, Just post) -> failImportQualifiedTwice (getEpTokenSrcSpan post) + >> return (Just post, QualifiedPost) + (Nothing, Just post) -> pure (Just post, QualifiedPost) + (Just pre, Nothing) -> pure (Just pre, QualifiedPre) + (Nothing, Nothing) -> pure (Nothing, NotQualified) + +importDeclLevelStyle :: (Maybe EpAnnLevel) + -> (Maybe EpAnnLevel) + -> P (Maybe EpAnnLevel, ImportDeclLevelStyle) +importDeclLevelStyle preImportLevel postImportLevel = + case (preImportLevel, postImportLevel) of + (Just {}, Just tok) -> failSpliceOrQuoteTwice tok + >> return (Just tok, LevelStylePost (tokToLevel tok)) + (Nothing, Just post) -> pure (Just post, LevelStylePost (tokToLevel post)) + (Just pre, Nothing) -> pure (Just pre, LevelStylePre (tokToLevel pre)) + (Nothing, Nothing) -> pure (Nothing, NotLevelled) + where + tokToLevel tok = case tok of + EpAnnLevelSplice {} -> ImportDeclSplice + EpAnnLevelQuote {} -> ImportDeclQuote + + + +-- ------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) +checkPattern = runPV . checkLPat + +checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat) + +checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) +checkLPat (L l@(EpAnn anc an _) p) = do + (L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) [] + return (L (addCommentsToEpAnn l' cs) p') + +checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [LPat GhcPs] + -> PV (LPat GhcPs, EpAnnComments) +-- SG: I think this function checks what Haskell2010 calls the `pat` and `lpat` +-- productions +checkPat loc cs (L l e@(PatBuilderVar (L ln c))) args + | isRdrDataCon c || isRdrTc c + = return (L loc $ ConPat + { pat_con_ext = noAnn -- AZ: where should this come from? + , pat_con = L ln c + , pat_args = PrefixCon args + }, comments l Semi.<> cs) + | (not (null args) && patIsRec c) = do + ctx <- askParseContext + patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx +checkPat loc cs (L la (PatBuilderAppType f at t)) args = + checkPat loc (cs Semi.<> comments la) f (mkInvisLPat at t : args) +checkPat loc cs (L la (PatBuilderApp f e)) args = do + p <- checkLPat e + checkPat loc (cs Semi.<> comments la) f (p : args) +checkPat loc cs (L l e) [] = do + p <- checkAPat loc e + return (L l p, cs) +checkPat loc _ e _ = do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat (unLoc e) details) + +mkInvisLPat :: EpToken "@" -> HsTyPat GhcPs -> LPat GhcPs +mkInvisLPat tok ty_pat = L l invis_pat + where + HsTP _ (L (EpAnn anc _ _) _) = ty_pat + l = EpAnn (widenAnchorT anc tok) noAnn emptyComments + invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat + +checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs) +checkAPat loc e0 = do + nPlusKPatterns <- getBit NPlusKPatternsBit + case e0 of + PatBuilderPat p -> return p + PatBuilderVar x -> return (VarPat noExtField x) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by the lexer + PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn) + + -- n+k patterns + PatBuilderOpApp + (L _ (PatBuilderVar (L nloc n))) + (L l plus) + (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}}))) + _ + | nPlusKPatterns && (plus == plus_RDR) + -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit) + (EpTok $ entry l)) + + -- Improve error messages for the @-operator when the user meant an @-pattern + PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do + addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos + return (WildPat noExtField) + + PatBuilderOpApp l (L cl c) r (_os,_cs) + | isRdrDataCon c || isRdrTc c -> do + l <- checkLPat l + r <- checkLPat r + return $ ConPat + { pat_con_ext = noAnn + , pat_con = L cl c + , pat_args = InfixCon l r + } + + PatBuilderPar lpar e rpar -> do + p <- checkLPat e + return (ParPat (lpar, rpar) p) + + _ -> do + details <- fromParseContext <$> askParseContext + patFail (locA loc) (PsErrInPat e0 details) + +placeHolderPunRhs :: DisambECP b => PV (LocatedA b) +-- The RHS of a punned record field will be filled in by the renamer +-- It's better not to make it an error, in case we want to print it when +-- debugging +placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR) + +plus_RDR, pun_RDR :: RdrName +plus_RDR = mkUnqual varName (fsLit "+") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") + +checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs)) + -> PV (LHsRecField GhcPs (LPat GhcPs)) +checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld) + return (L l (fld { hfbRHS = p })) + +patFail :: SrcSpan -> PsMessage -> PV a +patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg + +patIsRec :: RdrName -> Bool +patIsRec e = e == mkUnqual varName (fsLit "rec") + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef :: SrcSpan + -> LocatedA (PatBuilder GhcPs) + -> (HsMultAnn GhcPs, Maybe (TokDcolon, LHsType GhcPs)) + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) + +checkValDef loc lhs (mult, Just (sigAnn, sig)) grhss + -- x :: ty = rhs parses as a *pattern* binding + = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig sigAnn + >>= checkLPat + checkPatBind loc lhs' grhss mult + +checkValDef loc lhs (mult_ann, Nothing) grhss + | HsUnannotated{} <- mult_ann + = do { mb_fun <- isFunLhs lhs + ; case mb_fun of + Just (fun, is_infix, pats, ops, cps) -> do + let ann_fun = mk_ann_funrhs ops cps + let l = listLocation pats + checkFunBind loc ann_fun + fun is_infix (L l pats) grhss + Nothing -> do + lhs' <- checkPattern lhs + checkPatBind loc lhs' grhss mult_ann } + +checkValDef loc lhs (mult_ann, Nothing) ghrss + -- %p x = rhs parses as a *pattern* binding + = do lhs' <- checkPattern lhs + checkPatBind loc lhs' ghrss mult_ann + +mk_ann_funrhs :: [EpToken "("] -> [EpToken ")"] -> AnnFunRhs +mk_ann_funrhs ops cps = AnnFunRhs NoEpTok ops cps + +checkFunBind :: SrcSpan + -> AnnFunRhs + -> LocatedN RdrName + -> LexicalFixity + -> LocatedE [LocatedA (PatBuilder GhcPs)] + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P (HsBind GhcPs) +checkFunBind locF ann_fun (L lf fun) is_infix (L lp pats) (L _ grhss) + = do ps <- runPV_details extraDetails (mapM checkLPat pats) + let match_span = noAnnSrcSpan $ locF + return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span) + [L match_span (Match { m_ext = noExtField + , m_ctxt = FunRhs + { mc_fun = L lf fun + , mc_fixity = is_infix + , mc_strictness = NoSrcStrict + , mc_an = ann_fun } + , m_pats = L lp ps + , m_grhss = grhss })])) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. + where + extraDetails + | Infix <- is_infix = ParseContext (Just fun) NoIncompleteDoBlock + | otherwise = noParseContext + +makeFunBind :: LocatedN RdrName -> LocatedLW [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too +makeFunBind fn ms + = FunBind { fun_ext = noExtField, + fun_id = fn, + fun_matches = mkMatchGroup FromSource ms } + +-- See Note [FunBind vs PatBind] +checkPatBind :: SrcSpan + -> LPat GhcPs + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> HsMultAnn GhcPs + -> P (HsBind GhcPs) +checkPatBind loc (L _ (BangPat an (L _ (VarPat _ v)))) + (L _match_span grhss) (HsUnannotated _) + = return (makeFunBind v (L (noAnnSrcSpan loc) + [L (noAnnSrcSpan loc) (m an v)])) + where + m a v = Match { m_ext = noExtField + , m_ctxt = FunRhs { mc_fun = v + , mc_fixity = Prefix + , mc_strictness = SrcStrict + , mc_an = AnnFunRhs a [] [] } + , m_pats = noLocA [] + , m_grhss = grhss } + +checkPatBind _loc lhs (L _ grhss) mult = do + return (PatBind noExtField lhs mult grhss) + + +checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) +checkValSigLhs lhs@(L l lhs_expr) = + case lhs_expr of + HsVar _ lrdr@(L _ v) -> check_var v lrdr + _ -> make_err PsErrInvalidTypeSig_Other + where + check_var v lrdr + | not (isUnqual v) = make_err PsErrInvalidTypeSig_Qualified + | isDataOcc occ_n = make_err PsErrInvalidTypeSig_DataCon + | otherwise = pure lrdr + where occ_n = rdrNameOcc v + make_err reason = addFatalError $ + mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs) + + +checkDoAndIfThenElse + :: (Outputable a, Outputable b, Outputable c) + => (a -> Bool -> b -> Bool -> c -> PsMessage) + -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV () +checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse = do + doAndIfThenElse <- getBit DoAndIfThenElseBit + let e = err (unLoc guardExpr) + semiThen (unLoc thenExpr) + semiElse (unLoc elseExpr) + loc = combineLocs (reLoc guardExpr) (reLoc elseExpr) + + unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e) + | otherwise = return () + +isFunLhs :: LocatedA (PatBuilder GhcPs) + -> P (Maybe (LocatedN RdrName, LexicalFixity, + [LocatedA (PatBuilder GhcPs)],[EpToken "("],[EpToken ")"])) +-- A variable binding is parsed as a FunBind. +-- Just (fun, is_infix, arg_pats) if e is a function LHS +isFunLhs e = go e [] [] [] + where + go (L l (PatBuilderVar (L loc f))) es ops cps + | not (isRdrDataCon f) = do + let (_l, loc') = transferCommentsOnlyA l loc + return (Just (L loc' f, Prefix, es, (reverse ops), cps)) + go (L l (PatBuilderApp (L lf f) e)) es ops cps = do + let (_l, lf') = transferCommentsOnlyA l lf + go (L lf' f) (e:es) ops cps + go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps) + -- NB: es@(_:_) means that there must be an arg after the parens for the + -- LHS to be a function LHS. This corresponds to the Haskell Report's definition + -- of funlhs. + where + (_l, le') = transferCommentsOnlyA l le + (o,c) = mkParensEpToks (realSrcSpan $ locA l) + go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r (os,cs))) es ops cps + | not (isRdrDataCon op) -- We have found the function! + = do { let (_l, ll') = transferCommentsOnlyA loc ll + ; return (Just (L loc' op, Infix, ((L ll' l):r:es), (os ++ reverse ops), (cs ++ cps))) } + | otherwise -- Infix data con; keep going + = do { let (_l, ll') = transferCommentsOnlyA loc ll + ; mb_l <- go (L ll' l) es ops cps + ; return (reassociate =<< mb_l) } + where + reassociate (op', Infix, j : L k_loc k : es', ops', cps') + = Just (op', Infix, j : op_app : es', ops', cps') + where + op_app = L loc (PatBuilderOpApp (L k_loc k) + (L loc' op) r (reverse ops, cps)) + reassociate _other = Nothing + go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps + = go (L lp' pat) (L (EpAnn anc' ann cs) (PatBuilderPat invis_pat) : es) ops cps + where invis_pat = InvisPat (tok, SpecifiedSpec) ty_pat + anc' = widenAnchorT anc tok + (_l, lp') = transferCommentsOnlyA l lp + go _ _ _ _ = return Nothing + +mkBangTy :: EpaLocation -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy tok_loc strictness lty = + XHsType (HsBangTy (noAnn, noAnn, tok_loc) (HsSrcBang NoSourceText NoSrcUnpack strictness) lty) + +-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@. +data UnpackednessPragma = + UnpackednessPragma (EpaLocation, EpToken "#-}") SourceText SrcUnpackedness + +-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma. +addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs) +addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do + let l' = combineSrcSpans lprag (getLocA ty) + let t' = addUnpackedness anns ty + return (L (noAnnSrcSpan l') t') + where + -- If we have a HsBangTy that only has a strictness annotation, + -- such as ~T or !T, then add the pragma to the existing HsBangTy. + -- + -- Otherwise, wrap the type in a new HsBangTy constructor. + addUnpackedness (o,c) (L _ (XHsType (HsBangTy (_,_,tl) bang t))) + | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang + = XHsType (HsBangTy (o,c,tl) (HsSrcBang prag unpk strictness) t) + addUnpackedness (o,c) t + = XHsType (HsBangTy (o,c,noAnn) (HsSrcBang prag unpk NoSrcStrict) t) + +--------------------------------------------------------------------------- +-- | Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a 'MonadComp' context, +-- otherwise use the usual 'ListComp' context + +checkMonadComp :: PV HsDoFlavour +checkMonadComp = do + monadComprehensions <- getBit MonadComprehensionsBit + return $ if monadComprehensions + then MonadComp + else ListComp + +-- ------------------------------------------------------------------------- +-- Expression/command/pattern ambiguity. +-- See Note [Ambiguous syntactic categories] +-- + +-- See Note [Ambiguous syntactic categories] +-- +-- This newtype is required to avoid impredicative types in monadic +-- productions. That is, in a production that looks like +-- +-- | ... {% return (ECP ...) } +-- +-- we are dealing with +-- P ECP +-- whereas without a newtype we would be dealing with +-- P (forall b. DisambECP b => PV (Located b)) +-- +newtype ECP = + ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) } + +ecpFromExp :: LHsExpr GhcPs -> ECP +ecpFromExp a = ECP (ecpFromExp' a) + +ecpFromCmd :: LHsCmd GhcPs -> ECP +ecpFromCmd a = ECP (ecpFromCmd' a) + +ecpFromPat :: LPat GhcPs -> ECP +ecpFromPat a = ECP (ecpFromPat' a) + +-- The 'fbinds' parser rule produces values of this type. See Note +-- [RecordDotSyntax field updates]. +type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b)) + +-- | Disambiguate infix operators. +-- See Note [Ambiguous syntactic categories] +class DisambInfixOp b where + mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) + mkHsInfixHolePV :: LocatedN RdrName -> PV (LocatedN b) + +instance DisambInfixOp (HsExpr GhcPs) where + mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v) + mkHsInfixHolePV v = return $ L (getLoc v) (HsHole (HoleVar v)) + +instance DisambInfixOp RdrName where + mkHsConOpPV (L l v) = return $ L l v + mkHsVarOpPV (L l v) = return $ L l v + mkHsInfixHolePV (L l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole + +type AnnoBody b + = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO + , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnLW + , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA + , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA + , Anno [LocatedA (StmtLR GhcPs GhcPs + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW + ) + +-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are +-- parsing an expression, a command, or a pattern. +-- See Note [Ambiguous syntactic categories] +class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where + -- | See Note [Body in DisambECP] + type Body b :: Type -> Type + -- | Return a command without ambiguity, or fail in a non-command context. + ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) + -- | Return an expression without ambiguity, or fail in a non-expression context. + ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b) + -- | Return a pattern without ambiguity, or fail in a non-pattern context. + ecpFromPat' :: LPat GhcPs -> PV (LocatedA b) + mkHsProjUpdatePV :: SrcSpan -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) + -> LocatedA b -> Bool -> Maybe (EpToken "=") -> PV (LHsRecProj GhcPs (LocatedA b)) + -- | Disambiguate "let ... in ..." + mkHsLetPV + :: SrcSpan + -> EpToken "let" + -> HsLocalBinds GhcPs + -> EpToken "in" + -> LocatedA b + -> PV (LocatedA b) + -- | Infix operator representation + type InfixOp b + -- | Bring superclass constraints on InfixOp into scope. + -- See Note [UndecidableSuperClasses for associated types] + superInfixOp + :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b) + -- | Disambiguate "f # x" (infix operator) + mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b + -> PV (LocatedA b) + -- | Disambiguate "case ... of ..." + mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedLW [LMatch GhcPs (LocatedA b)]) + -> EpAnnHsCase -> PV (LocatedA b) + -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases" + mkHsLamPV :: SrcSpan -> HsLamVariant + -> (LocatedLW [LMatch GhcPs (LocatedA b)]) -> EpAnnLam + -> PV (LocatedA b) + -- | Function argument representation + type FunArg b + -- | Bring superclass constraints on FunArg into scope. + -- See Note [UndecidableSuperClasses for associated types] + superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b) + -- | Disambiguate "f x" (function application) + mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b) + -- | Disambiguate "f @t" (visible type application) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate "if ... then ... else ..." + mkHsIfPV :: SrcSpan + -> LHsExpr GhcPs + -> Bool -- semicolon? + -> LocatedA b + -> Bool -- semicolon? + -> LocatedA b + -> AnnsIf + -> PV (LocatedA b) + -- | Disambiguate "do { ... }" (do notation) + mkHsDoPV :: + SrcSpan -> + Maybe ModuleName -> + LocatedLW [LStmt GhcPs (LocatedA b)] -> + EpaLocation -> -- Token + EpaLocation -> -- Anchor + PV (LocatedA b) + -- | Disambiguate "( ... )" (parentheses) + mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b) + -- | Disambiguate a variable "f" or a data constructor "MkF". + mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b) + -- | Disambiguate a monomorphic literal + mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b) + -- | Disambiguate an overloaded literal + mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b) + -- | Disambiguate a wildcard + mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b) + -- | Disambiguate "a :: t" (type annotation) + mkHsTySigPV + :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> TokDcolon -> PV (LocatedA b) + -- | Disambiguate "[a,b,c]" (list syntax) + mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList () -> PV (LocatedA b) + -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) + mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b) + -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) + mkHsRecordPV :: + Bool -> -- Is OverloadedRecordUpdate in effect? + SrcSpan -> + SrcSpan -> + LocatedA b -> + ([Fbind b], Maybe SrcSpan) -> + (Maybe (EpToken "{"), Maybe (EpToken "}")) -> + PV (LocatedA b) + -- | Disambiguate "-a" (negation) + mkHsNegAppPV :: SrcSpan -> LocatedA b -> EpToken "-" -> PV (LocatedA b) + -- | Disambiguate "(# a)" (right operator section) + mkHsSectionR_PV + :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "(a -> b)" (view pattern or function type arrow) + mkHsArrowPV + :: SrcSpan -> ArrowParsingMode lhs b -> LocatedA lhs -> HsMultAnnOf (LocatedA b) GhcPs -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "%m" to the left of "->" (multiplicity) + mkHsMultPV + :: EpToken "%" -> LocatedA b -> PV (TokRarrow -> HsMultAnnOf (LocatedA b) GhcPs) + -- | Disambiguate "forall a. b" and "forall a -> b" (forall telescope) + mkHsForallPV :: SrcSpan -> HsForAllTelescope GhcPs -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "(a,b,c)" to the left of "=>" (constraint list) + checkContextPV :: LocatedA b -> PV (LocatedC [LocatedA b]) + -- | Disambiguate "a => b" (constraint context) + mkQualPV :: SrcSpan -> LocatedC [LocatedA b] -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "a@b" (as-pattern) + mkHsAsPatPV + :: SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b) + -- | Disambiguate "~a" (lazy pattern) + mkHsLazyPatPV :: SrcSpan -> LocatedA b -> EpToken "~" -> PV (LocatedA b) + -- | Disambiguate "!a" (bang pattern) + mkHsBangPatPV :: SrcSpan -> LocatedA b -> EpToken "!" -> PV (LocatedA b) + -- | Disambiguate tuple sections and unboxed sums + mkSumOrTuplePV + :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> (EpaLocation, EpaLocation) -> PV (LocatedA b) + -- | Disambiguate "type t" (embedded type) + mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b) + -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas + rejectPragmaPV :: LocatedA b -> PV () + +{- Note [UndecidableSuperClasses for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(This Note is about the code in GHC, not about the user code that we are parsing) + +Assume we have a class C with an associated type T: + + class C a where + type T a + ... + +If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses: + + {-# LANGUAGE UndecidableSuperClasses #-} + class C (T a) => C a where + type T a + ... + +Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes +making GHC loop. The workaround is to bring this constraint into scope +manually with a helper method: + + class C a where + type T a + superT :: (C (T a) => r) -> r + +In order to avoid ambiguous types, 'r' must mention 'a'. + +For consistency, we use this approach for all constraints on associated types, +even when -XUndecidableSuperClasses are not required. +-} + +{- Note [Body in DisambECP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that +require their argument to take a form of (body GhcPs) for some (body :: Type -> +*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the +superclass constraints of DisambECP. + +The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop +this requirement. It is possible and would allow removing the type index of +PatBuilder, but leads to worse type inference, breaking some code in the +typechecker. +-} + +instance DisambECP (HsCmd GhcPs) where + type Body (HsCmd GhcPs) = HsCmd + ecpFromCmd' = return + ecpFromExp' (L l e) = cmdFail (locA l) (ppr e) + ecpFromPat' (L l p) = cmdFail (locA l) (ppr p) + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ + PsErrOverloadedRecordDotInvalid + mkHsLamPV l lam_variant (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg) + + mkHsLetPV l tkLet bs tkIn e = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e) + + type InfixOp (HsCmd GhcPs) = HsExpr GhcPs + + superInfixOp m = m + + mkHsOpAppPV l c1 op c2 = do + let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm noAnn (reLoc op) Infix [cmdArg c1, cmdArg c2] + + mkHsCasePV l c (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg) + + type FunArg (HsCmd GhcPs) = HsExpr GhcPs + superFunArg m = m + mkHsAppPV l c e = do + checkCmdBlockArguments c + checkExpBlockArguments e + return $ L l (HsCmdApp noExtField c e) + mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t) + mkHsIfPV l c semi1 a semi2 b anns = do + checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) + mkHsDoPV l Nothing stmts tok_loc anc = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts) + mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + mkHsParPV l lpar c rpar = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) + mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) + mkHsLitPV (L l a) = cmdFail l (ppr a) + mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a) + mkHsWildCardPV l = cmdFail l (text "_") + mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> dcolon <+> ppr sig) + mkHsExplicitListPV l xs _ = cmdFail l $ + brackets (pprWithCommas ppr xs) + mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp) + mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid + else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc) + mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a) + mkHsSectionR_PV l op c = cmdFail l $ + let pp_op = fromMaybe (panic "cannot print infix operator") + (ppr_infix_expr (unLoc op)) + in pp_op <> ppr c + mkHsArrowPV l mode a arr b = cmdFail l $ + case mode of -- matching on the mode brings Outputable instances into scope + ArrowIsViewPat -> ppr a <+> pprHsArrow arr <+> ppr b + ArrowIsFunType -> ppr a <+> pprHsArrow arr <+> ppr b + mkHsMultPV pct mult = cmdFail l $ + ppr pct <> ppr mult + where l = getHasLoc pct `combineSrcSpans` getHasLoc mult + mkHsForallPV l tele cmd = cmdFail l $ + pprHsForAll tele Nothing <+> ppr cmd + checkContextPV ctxt = cmdFail (getLocA ctxt) $ ppr ctxt + mkQualPV l ctxt cmd = cmdFail l $ + ppr ctxt <+> text "=>" <+> ppr cmd + mkHsAsPatPV l v _ c = cmdFail l $ + pprPrefixOcc (unLoc v) <> text "@" <> ppr c + mkHsLazyPatPV l c _ = cmdFail l $ + text "~" <> ppr c + mkHsBangPatPV l c _ = cmdFail l $ + text "!" <> ppr c + mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a) + mkHsEmbTyPV l _ ty = cmdFail l (text "type" <+> ppr ty) + rejectPragmaPV _ = return () + +cmdFail :: SrcSpan -> SDoc -> PV a +cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e + +checkLamMatchGroup :: SrcSpan -> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV () +checkLamMatchGroup l LamSingle (MG { mg_alts = (L _ (matches:_))}) = do + when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda +checkLamMatchGroup _ _ _ = return () + +instance DisambECP (HsExpr GhcPs) where + type Body (HsExpr GhcPs) = HsExpr + ecpFromCmd' (L l c) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c + return (L l parseError) + ecpFromExp' = return + ecpFromPat' p@(L l _) = do + addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrOrPatInExpr p + return (L l parseError) + mkHsProjUpdatePV l fields arg isPun anns = do + !cs <- getCommentsFor l + return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns + mkHsLetPV l tkLet bs tkIn c = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c) + type InfixOp (HsExpr GhcPs) = HsExpr GhcPs + superInfixOp m = m + mkHsOpAppPV l e1 op e2 = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp noExtField e1 (reLoc op) e2 + mkHsCasePV l e (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkMatchGroup FromSource (L lm m) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg) + mkHsLamPV l lam_variant (L lm m) anns = do + !cs <- getCommentsFor l + let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m) + checkLamMatchGroup l lam_variant mg + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg) + type FunArg (HsExpr GhcPs) = HsExpr GhcPs + superFunArg m = m + mkHsAppPV l e1 e2 = do + checkExpBlockArguments e1 + checkExpBlockArguments e2 + return $ L l (HsApp noExtField e1 e2) + mkHsAppTypePV l e at t = do + checkExpBlockArguments e + return $ L l (HsAppType at e (mkHsWildCardBndrs t)) + mkHsIfPV l c semi1 a semi2 b anns = do + checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) + mkHsDoPV l mod stmts loc_tok anc = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts) + mkHsParPV l lpar e rpar = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) + mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do + !cs <- getCommentsFor (getHasLoc l) + return $ L (EpAnn anc noAnn cs) (HsVar noExtField v) + mkHsLitPV (L l a) = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a) + mkHsOverLitPV (L (EpAnn l an csIn) a) = do + !cs <- getCommentsFor (locA l) + return $ L (EpAnn l an (cs Semi.<> csIn)) (HsOverLit NoExtField a) + mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (HsHole (HoleVar (L (noAnnSrcSpan l) (mkUnqual varName (fsLit "_"))))) + mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do + !cs <- getCommentsFor (locA l) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig)) + mkHsExplicitListPV l xs anns = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs) + mkHsSplicePV (L l a) = do + !cs <- getCommentsFor l + return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a) + mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do + !cs <- getCommentsFor l + r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns + checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) + mkHsNegAppPV l a anns = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr) + mkHsSectionR_PV l op e = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e) + mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e) + >> return (L (noAnnSrcSpan l) parseError) + mkHsLazyPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e) + >> return (L (noAnnSrcSpan l) parseError) + mkHsBangPatPV l e _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e) + >> return (L (noAnnSrcSpan l) parseError) + mkSumOrTuplePV = mkSumOrTupleExpr + mkHsEmbTyPV l toktype ty = + return $ L (noAnnSrcSpan l) $ + HsEmbTy toktype (mkHsWildCardBndrs ty) + mkHsArrowPV l mode arg arr res = + -- In expressions, (e1 -> e2) is always parsed as a function type, + -- even if ViewPatterns are enabled. + exprArrowParsingMode mode $ + return $ L (noAnnSrcSpan l) $ + HsFunArr noExtField arr arg res + mkHsMultPV pct t = + return $ mkMultExpr pct t + mkHsForallPV l telescope ty = + return $ L (noAnnSrcSpan l) $ + HsForAll noExtField (setTelescopeBndrsNameSpace varName telescope) ty + checkContextPV = checkContextExpr + mkQualPV l qual ty = + return $ L (noAnnSrcSpan l) $ + HsQual noExtField qual ty + rejectPragmaPV (L _ (OpApp _ _ _ e)) = + -- assuming left-associative parsing of operators + rejectPragmaPV e + rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrUnallowedPragma prag) + rejectPragmaPV _ = return () + +instance DisambECP (PatBuilder GhcPs) where + type Body (PatBuilder GhcPs) = PatBuilder + ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c + ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e + ecpFromPat' (L l p) = return $ L l (PatBuilderPat p) + mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat + mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid + type InfixOp (PatBuilder GhcPs) = RdrName + superInfixOp m = m + mkHsOpAppPV l p1 op p2 = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 ([],[]) + + mkHsLamPV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant) + + mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat + type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs + superFunArg m = m + mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) + mkHsAppTypePV l p at t = do + !cs <- getCommentsFor (locA l) + return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) + mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat + mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) + mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) + mkHsLitPV lit@(L l a) = do + checkUnboxedLitPat lit + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a)) + mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a) + mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField)) + mkHsTySigPV l p t anns = do + p' <- checkLPat p + let sig = mkHsPatSigType noAnn t + sig_pat <- addSigPatP l p' sig anns + return $ fmap PatBuilderPat sig_pat + mkHsExplicitListPV l xs anns = do + ps <- traverse checkLPat xs + !cs <- getCommentsFor l + return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps))) + mkHsSplicePV (L l sp) = do + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp)) + mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do + let (fs, ps) = partitionEithers fbinds + if not (null ps) + then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid + else do + !cs <- getCommentsFor l + r <- mkPatRec a (mk_rec_fields fs ddLoc) anns + checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r) + mkHsNegAppPV l (L lp p) anns = do + lit <- case p of + PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit) + _ -> patFail l $ PsErrInPat p PEIP_NegApp + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns)) + mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p)) + mkHsArrowPV l ArrowIsViewPat a arr b = do + p <- checkLPat b + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat tok a p)) + where + tok :: TokRarrow + tok = case arr of + HsUnannotated (EpArrow x) -> x + _ -> -- unreachable case because in Parser.y the reduction rules for + -- (a %m -> b) and (a ->. b) use ArrowIsFunType + panic "mkHsArrowPV ArrowIsViewPat: expected HsUnannotated" + mkHsArrowPV l ArrowIsFunType a arr b = + patFail l (PsErrTypeSyntaxInPat (PETS_FunctionArrow a arr b)) + mkHsMultPV tok arg = + let l = getHasLoc tok `combineSrcSpans` getLocA arg in + patFail l (PsErrTypeSyntaxInPat (PETS_Multiplicity tok arg)) + mkHsForallPV l tele body = patFail l (PsErrTypeSyntaxInPat (PETS_ForallTelescope tele body)) + checkContextPV ctx = patFail (getLocA ctx) (PsErrTypeSyntaxInPat (PETS_ConstraintContext ctx)) + mkQualPV _ _ _ = -- unreachable because mkQualPV is only called on the result + -- of checkContextPV, which fails in patterns + panic "mkQualPV in a pattern" + mkHsAsPatPV l v at e = do + p <- checkLPat e + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p)) + mkHsLazyPatPV l e a = do + p <- checkLPat e + !cs <- getCommentsFor l + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p)) + mkHsBangPatPV l e an = do + p <- checkLPat e + !cs <- getCommentsFor l + let pb = BangPat an p + hintBangPat l pb + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb) + mkSumOrTuplePV = mkSumOrTuplePat + mkHsEmbTyPV l toktype ty = + return $ L (noAnnSrcSpan l) $ + PatBuilderPat (EmbTyPat toktype (mkHsTyPat ty)) + rejectPragmaPV _ = return () + +-- For reasons of backwards compatibility, we can't simply add the pattern +-- signature if the inner pattern is a view pattern. Consider: +-- (f -> p :: t) +-- There are two ways to parse it +-- (f -> (p :: t)) -- legacy parse +-- ((f -> p) :: t) -- future parse +-- The grammar in Parser.y is structured in such a way that we get the +-- future parse by default. Until we're ready to make the breaking change, +-- we need to do some extra work here to push the signature under the view +-- pattern (and emit a warning). +addSigPatP :: SrcSpanAnnA -> LPat GhcPs -> HsPatSigType GhcPs -> TokDcolon -> PV (LPat GhcPs) +addSigPatP l viewpat@(L _ ViewPat{}) sig anns = + -- Test case: T24159_viewpat + do { let futureParse = L l (SigPat anns viewpat sig) + ; legacyParse <- go viewpat + ; addPsMessage (locA l) (PsWarnViewPatternSignatures legacyParse futureParse) + ; return legacyParse } + where + sig_loc_no_comments :: SrcSpan + sig_loc_no_comments = getLocA (hsps_body sig) + + -- Test case for comments and locations preservation: Test24159 + go :: LPat GhcPs -> PV (LPat GhcPs) + go (L (EpAnn (EpaSpan view_pat_loc) anns cs1) (ViewPat anns' e' p')) = do + sig' <- go p' + let new_loc = view_pat_loc `combineSrcSpans` sig_loc_no_comments + cs2 <- getCommentsFor new_loc + let ep_ann_loc = EpAnn (spanAsAnchor new_loc) anns (cs1 Semi.<> cs2) + pure (L ep_ann_loc (ViewPat anns' e' sig')) + + go p = pure $ L new_loc (SigPat anns p sig) + where new_loc = noAnnSrcSpan ((getLocA p) `combineSrcSpans` sig_loc_no_comments) + +addSigPatP l p sig anns = do + return $ L l (SigPat anns p sig) + +{- Note [Arrow parsing mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example: + f (K (a -> b)) = () + +A pattern of the form (a -> b) could be parsed in one of two ways: + * a view pattern `viewfn -> pat` (with ViewPatterns) + * a function type `t1 -> t2` (with RequiredTypeArguments) + +This depends on the enabled extensions: + NoViewPatterns, RequiredTypeArguments => function type + NoViewPatterns, NoRequiredTypeArguments => error (suggest ViewPatterns) + ViewPatterns, RequiredTypeArguments => view pattern + ViewPatterns, NoRequiredTypeArguments => view pattern + +The decision how to parse arrow patterns (p1 -> p2) is captured by the +`ArrowParsingMode` data type, produced in `withArrowParsingMode` and +consumed in `mkHsArrowPV`. + +Naively, one might expect to see the following definition: + + -- a simple (but insufficient) definition + data ArrowParsingMode = ArrowIsViewPat | ArrowIsFunType + +However, there is a slight complication that leads us to parameterize these +constructor with GADT type indices. In a pattern (p1 -> p2), what is the AST +type to represent the LHS `p1`? It depends: + * if (p1 -> p2) is a view pattern, `p1` is an HsExpr + * if (p1 -> p2) is a function type, `p1` is a Pat (PatBuilder) + +And since the decision how to parse `p1` depends on the arrow parsing mode, we +could try to encode the LHS type as a GADT index: + + -- a less simple (but still insufficient) definition + data ArrowParsingMode lhs where + ArrowIsViewPat :: ArrowParsingMode (PatBuilder GhcPs) + ArrowIsFunType :: ArrowParsingMode (HsExpr GhcPs) + +This definition would suffice for parsing patterns, but remember that +expressions, commands, and patterns are all parsed using a unified framework +`DisambECP`, as described in Note [Ambiguous syntactic categories]. + +In an expression (e1 -> e2), the LHS is always represented by an HsExpr. +We can account for this with a further refinement of the definition: + + -- actual definition + data ArrowParsingMode lhs rhs where + ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b + ArrowIsFunType :: ArrowParsingMode b b + +So when parsing a view pattern, the LHS is an HsExpr; and when parsing a +function type, the type of the LHS is assumed to match the type of the RHS, +which works out just right both for expressions and patterns. +-} + +-- The arrow parsing mode is selected depending on the enabled extensions and +-- determines how we parse patterns of the form (p1 -> p2). See Note [Arrow parsing mode] +data ArrowParsingMode lhs rhs where + ArrowIsViewPat :: ArrowParsingMode (HsExpr GhcPs) b -- the LHS is always of type HsExpr + ArrowIsFunType :: ArrowParsingMode b b -- the LHS is of the same type as RHS + +-- When parsing an expression (e1 -> e2), the LHS `e1` is an HsExpr regardless of +-- the arrow parsing mode. `exprArrowParsingMode` proves this to the type checker. +-- See Note [Arrow parsing mode] +exprArrowParsingMode :: ArrowParsingMode lhs (HsExpr GhcPs) -> (lhs ~ HsExpr GhcPs => r) -> r +exprArrowParsingMode ArrowIsViewPat k = k +exprArrowParsingMode ArrowIsFunType k = k + +-- Check the enabled extensions and select the appropriate ArrowParsingMode, +-- then pass it to a continuation. See Note [Arrow parsing mode] +withArrowParsingMode :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV r) -> PV r +withArrowParsingMode cont = do + vpEnabled <- getBit ViewPatternsBit + rtaEnabled <- getBit RequiredTypeArgumentsBit + if | vpEnabled -> cont ArrowIsViewPat + | rtaEnabled -> cont ArrowIsFunType + | otherwise -> cont ArrowIsViewPat -- Error message should suggest ViewPatterns in patterns + +-- Type-restricted variant of `withArrowParsingMode` to aid type inference (#25103) +withArrowParsingMode' :: DisambECP b => (forall lhs. DisambECP lhs => ArrowParsingMode lhs b -> PV (LocatedA b)) -> PV (LocatedA b) +withArrowParsingMode' = withArrowParsingMode + +-- When a forall-type occurs in term syntax, forall-bound variables should +-- inhabit the term namespace `varName` rather than the usual `tvName`. +-- See Note [Types in terms]. +-- +-- Since type variable binders in a `HsForAllTelescope` produced by the +-- `forall_telescope` nonterminal have their namespaces set to `tvName`, +-- we use `setTelescopeBndrsNameSpace` to fix them up. +setTelescopeBndrsNameSpace :: NameSpace -> HsForAllTelescope GhcPs -> HsForAllTelescope GhcPs +setTelescopeBndrsNameSpace ns forall_telescope = + case forall_telescope of + HsForAllInvis x bndrs -> HsForAllInvis x (set_bndrs_ns bndrs) + HsForAllVis x bndrs -> HsForAllVis x (set_bndrs_ns bndrs) + where + set_bndrs_ns :: [LHsTyVarBndr flag GhcPs] -> [LHsTyVarBndr flag GhcPs] + set_bndrs_ns = map (setLHsTyVarBndrNameSpace ns) + +setLHsTyVarBndrNameSpace :: NameSpace -> LHsTyVarBndr flag GhcPs -> LHsTyVarBndr flag GhcPs +setLHsTyVarBndrNameSpace ns (L l tvb) = L l tvb' + where tvb' = tvb { tvb_var = setHsBndrVarNameSpace ns (tvb_var tvb) } + +setHsBndrVarNameSpace :: NameSpace -> HsBndrVar GhcPs -> HsBndrVar GhcPs +setHsBndrVarNameSpace ns (HsBndrVar x (L l rdr)) = HsBndrVar x (L l rdr') + where rdr' = setRdrNameSpace rdr ns +setHsBndrVarNameSpace _ (HsBndrWildCard x) = HsBndrWildCard x + +-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#. +checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV () +checkUnboxedLitPat (L loc lit) = + case lit of + -- Don't allow primitive string literal patterns. + -- See #13260. + HsStringPrim {} + -> addError $ mkPlainErrorMsgEnvelope loc $ + (PsErrIllegalUnboxedStringInPat lit) + + -- Don't allow Float#/Double# literal patterns. + -- See #9238 and Note [Rules for floating-point comparisons] + -- in GHC.Core.Opt.ConstantFold. + _ | is_floating_lit lit + -> addError $ mkPlainErrorMsgEnvelope loc $ + (PsErrIllegalUnboxedFloatingLitInPat lit) + + | otherwise + -> return () + + where + is_floating_lit :: HsLit GhcPs -> Bool + is_floating_lit (HsFloatPrim {}) = True + is_floating_lit (HsDoublePrim {}) = True + is_floating_lit _ = False + +mkPatRec :: + LocatedA (PatBuilder GhcPs) -> + HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> + (Maybe (EpToken "{"), Maybe (EpToken "}")) -> + PV (PatBuilder GhcPs) +mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields x fs dd) anns + | isRdrDataCon (unLoc c) + = do fs <- mapM checkPatField fs + return $ PatBuilderPat $ ConPat + { pat_con_ext = anns + , pat_con = c + , pat_args = RecCon (HsRecFields x fs dd) + } +mkPatRec p _ _ = + addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + (PsErrInvalidRecordCon (unLoc p)) + +-- | Disambiguate constructs that may appear when we do not know +-- ahead of time whether we are parsing a type or a newtype/data constructor. +-- +-- See Note [Ambiguous syntactic categories] for the general idea. +-- +-- See Note [Parsing data constructors is hard] for the specific issue this +-- particular class is solving. +-- +class DisambTD b where + -- | Process the head of a type-level function/constructor application, + -- i.e. the @H@ in @H a b c@. + mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @f x@ (function application or prefix data constructor). + mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @f \@t@ (visible kind application) + mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @f \# x@ (infix operator) + mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b) + -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma) + mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b) + +instance DisambTD (HsType GhcPs) where + mkHsAppTyHeadPV = return + mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2) + mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki) + mkHsOpTyPV prom t1 op t2 = do + let (L l ty) = mkLHsOpTy prom t1 op t2 + !cs <- getCommentsFor (locA l) + return (L (addCommentsToEpAnn l cs) ty) + mkUnpackednessPV = addUnpackednessP + +dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName +dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc +dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc + +dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs + +-- Detect when the record syntax is used: +-- data T = MkT { ... } +dataConBuilderDetails (L _ (PrefixDataConBuilder flds _)) + | [L (EpAnn anc _ cs) (XHsType (HsRecTy an fields))] <- toList flds + = RecCon (L (EpAnn anc an cs) fields) + +-- Normal prefix constructor, e.g. data T = MkT A B C +dataConBuilderDetails (L _ (PrefixDataConBuilder flds _)) + = PrefixCon (map hsPlainTypeField (toList flds)) + +-- Infix constructor, e.g. data T = Int :! Bool +dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs)) + = InfixCon (hsPlainTypeField (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsPlainTypeField rhs) + + +instance DisambTD DataConBuilder where + mkHsAppTyHeadPV = tyToDataConBuilder + + mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t = + return $ + L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t)) + (PrefixDataConBuilder (flds `snocOL` t) fn) + mkHsAppTyPV (L _ InfixDataConBuilder{}) _ = + -- This case is impossible because of the way + -- the grammar in Parser.y is written (see infixtype/ftype). + panic "mkHsAppTyPV: InfixDataConBuilder" + + mkHsAppKindTyPV lhs at ki = + addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $ + (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) + + mkHsOpTyPV prom lhs tc rhs = do + check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative + data_con <- eitherToP $ tyConToDataCon tc + !cs <- getCommentsFor (locA l) + checkNotPromotedDataCon prom data_con + return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs) + where + l = combineLocsA lhs rhs + check_no_ops (XHsType (HsBangTy _ _ t)) = check_no_ops (unLoc t) + check_no_ops (HsOpTy{}) = + addError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) + check_no_ops _ = return () + + mkUnpackednessPV unpk constr_stuff + | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff + = -- When the user writes data T = {-# UNPACK #-} Int :+ Bool + -- we apply {-# UNPACK #-} to the LHS + do lhs' <- addUnpackednessP unpk lhs + let l = combineLocsA (reLoc unpk) constr_stuff + return $ L l (InfixDataConBuilder lhs' data_con rhs) + | otherwise = + do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon + return constr_stuff + +tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder) +tyToDataConBuilder (L l (HsTyVar _ prom v)) = do + data_con <- eitherToP $ tyConToDataCon v + checkNotPromotedDataCon prom data_con + return $ L l (PrefixDataConBuilder nilOL data_con) +tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do + let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts))) + return $ L l (PrefixDataConBuilder (toOL ts) data_con) +tyToDataConBuilder (L l (HsTupleTy _ HsUnboxedTuple ts)) = do + let data_con = L (l2l l) (getRdrName (tupleDataCon Unboxed (length ts))) + return $ L l (PrefixDataConBuilder (toOL ts) data_con) +tyToDataConBuilder t = + addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $ + (PsErrInvalidDataCon (unLoc t)) + +-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick). +checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV () +checkNotPromotedDataCon NotPromoted _ = return () +checkNotPromotedDataCon IsPromoted (L l name) = + addError $ mkPlainErrorMsgEnvelope (locA l) $ + PsErrIllegalPromotionQuoteDataCon name + +mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs) +mkUnboxedSumCon t tag arity = + (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon [hsPlainTypeField t]) + +{- Note [Ambiguous syntactic categories] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are places in the grammar where we do not know whether we are parsing an +expression or a pattern without unlimited lookahead (which we do not have in +'happy'): + +View patterns: + + f (Con a b ) = ... -- 'Con a b' is a pattern + f (Con a b -> x) = ... -- 'Con a b' is an expression + +do-notation: + + do { Con a b <- x } -- 'Con a b' is a pattern + do { Con a b } -- 'Con a b' is an expression + +Guards: + + x | True <- p && q = ... -- 'True' is a pattern + x | True = ... -- 'True' is an expression + +Top-level value/function declarations (FunBind/PatBind): + + f ! a -- TH splice + f ! a = ... -- function declaration + + Until we encounter the = sign, we don't know if it's a top-level + TemplateHaskell splice where ! is used, or if it's a function declaration + where ! is bound. + +There are also places in the grammar where we do not know whether we are +parsing an expression or a command: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) } -- 'stuff' is a command + + Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' + as an expression or a command. + +In fact, do-notation is subject to both ambiguities: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern + proc x -> do { (stuff) } -- 'stuff' is a command + +There are many possible solutions to this problem. For an overview of the ones +we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] + +The solution that keeps basic definitions (such as HsExpr) clean, keeps the +concerns local to the parser, and does not require duplication of hsSyn types, +or an extra pass over the entire AST, is to parse into an overloaded +parser-validator (a so-called tagless final encoding): + + class DisambECP b where ... + instance DisambECP (HsCmd GhcPs) where ... + instance DisambECP (HsExp GhcPs) where ... + instance DisambECP (PatBuilder GhcPs) where ... + +The 'DisambECP' class contains functions to build and validate 'b'. For example, +to add parentheses we have: + + mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b) + +'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for +expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat, +see Note [PatBuilder]). + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr GhcPs, and it becomes: + + alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Compared to the initial definition, the added bits are: + + forall b. DisambECP b => PV ( ... ) -- in the type signature + $1 >>= \ $1 -> return $ -- in one reduction rule + $2 >>= \ $2 -> return $ -- in another reduction rule + +The overhead is constant relative to the size of the rest of the reduction +rule, so this approach scales well to large parser productions. + +Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding +position and shadows the previous $1. We can do this because internally +'happy' desugars $n to happy_var_n, and the rationale behind this idiom +is to be able to write (sLL $1 $>) later on. The alternative would be to +write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer +to the last fresh name as $>. + +Finally, we instantiate the polymorphic type to a concrete one, and run the +parser-validator, for example: + + stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) } + e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } + : stmt {% runPV $1 } + +In e_stmt, three things happen: + + 1. we instantiate: b ~ HsExpr GhcPs + 2. we embed the PV computation into P by using runPV + 3. we run validation by using a monadic production, {% ... } + +At this point the ambiguity is resolved. +-} + + +{- Note [Resolving parsing ambiguities: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I, extra constructors in GHC.Hs.Expr +------------------------------------------------ +We could add extra constructors to HsExpr to represent command-specific and +pattern-specific syntactic constructs. Under this scheme, we parse patterns +and commands as expressions and rejig later. This is what GHC used to do, and +it polluted 'HsExpr' with irrelevant constructors: + + * for commands: 'HsArrForm', 'HsArrApp' + * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' + +(As of now, we still do that for patterns, but we plan to fix it). + +There are several issues with this: + + * The implementation details of parsing are leaking into hsSyn definitions. + + * Code that uses HsExpr has to panic on these impossible-after-parsing cases. + + * HsExpr is arbitrarily selected as the extension basis. Why not extend + HsCmd or HsPat with extra constructors instead? + +Alternative II, extra constructors in GHC.Hs.Expr for GhcPs +----------------------------------------------------------- +We could address some of the problems with Alternative I by using Trees That +Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to +the output of parsing, not to its intermediate results, so we wouldn't want +them there either. + +Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs +--------------------------------------------------------------- +We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. +Unfortunately, creating a new pass would significantly bloat conversion code +and slow down the compiler by adding another linear-time pass over the entire +AST. For example, in order to build HsExpr GhcPrePs, we would need to build +HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds +GhcPrePs. + + +Alternative IV, sum type and bottom-up data flow +------------------------------------------------ +Expressions and commands are disjoint. There are no user inputs that could be +interpreted as either an expression or a command depending on outer context: + + 5 -- definitely an expression + x -< y -- definitely a command + +Even though we have both 'HsLam' and 'HsCmdLam', we can look at +the body to disambiguate: + + \p -> 5 -- definitely an expression + \p -> x -< y -- definitely a command + +This means we could use a bottom-up flow of information to determine +whether we are parsing an expression or a command, using a sum type +for intermediate results: + + Either (LHsExpr GhcPs) (LHsCmd GhcPs) + +There are two problems with this: + + * We cannot handle the ambiguity between expressions and + patterns, which are not disjoint. + + * Bottom-up flow of information leads to poor error messages. Consider + + if ... then 5 else (x -< y) + + Do we report that '5' is not a valid command or that (x -< y) is not a + valid expression? It depends on whether we want the entire node to be + 'HsIf' or 'HsCmdIf', and this information flows top-down, from the + surrounding parsing context (are we in 'proc'?) + +Alternative V, backtracking with parser combinators +--------------------------------------------------- +One might think we could sidestep the issue entirely by using a backtracking +parser and doing something along the lines of (try pExpr <|> pPat). + +Turns out, this wouldn't work very well, as there can be patterns inside +expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns +(e.g. view patterns). To handle this, we would need to backtrack while +backtracking, and unbound levels of backtracking lead to very fragile +performance. + +Alternative VI, an intermediate data type +----------------------------------------- +There are common syntactic elements of expressions, commands, and patterns +(e.g. all of them must have balanced parentheses), and we can capture this +common structure in an intermediate data type, Frame: + +data Frame + = FrameVar RdrName + -- ^ Identifier: Just, map, BS.length + | FrameTuple [LTupArgFrame] Boxity + -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) + | FrameTySig LFrame (LHsSigWcType GhcPs) + -- ^ Type signature: x :: ty + | FramePar (SrcSpan, SrcSpan) LFrame + -- ^ Parentheses + | FrameIf LFrame LFrame LFrame + -- ^ If-expression: if p then x else y + | FrameCase LFrame [LFrameMatch] + -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } + | FrameDo HsStmtContextRn [LFrameStmt] + -- ^ Do-expression: do { s1; a <- s2; s3 } + ... + | FrameExpr (HsExpr GhcPs) -- unambiguously an expression + | FramePat (HsPat GhcPs) -- unambiguously a pattern + | FrameCommand (HsCmd GhcPs) -- unambiguously a command + +To determine which constructors 'Frame' needs to have, we take the union of +intersections between HsExpr, HsCmd, and HsPat. + +The intersection between HsPat and HsExpr: + + HsPat = VarPat | TuplePat | SigPat | ParPat | ... + HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... + ------------------------------------------------------------------- + Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... + +The intersection between HsCmd and HsExpr: + + HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar + HsExpr = HsIf | HsCase | HsDo | HsPar + ------------------------------------------------ + Frame = FrameIf | FrameCase | FrameDo | FramePar + +The intersection between HsCmd and HsPat: + + HsPat = ParPat | ... + HsCmd = HsCmdPar | ... + ----------------------- + Frame = FramePar | ... + +Take the union of each intersection and this yields the final 'Frame' data +type. The problem with this approach is that we end up duplicating a good +portion of hsSyn: + + Frame for HsExpr, HsPat, HsCmd + TupArgFrame for HsTupArg + FrameMatch for Match + FrameStmt for StmtLR + FrameGRHS for GRHS + FrameGRHSs for GRHSs + ... + +Alternative VII, a product type +------------------------------- +We could avoid the intermediate representation of Alternative VI by parsing +into a product of interpretations directly: + + type ExpCmdPat = ( PV (LHsExpr GhcPs) + , PV (LHsCmd GhcPs) + , PV (LHsPat GhcPs) ) + +This means that in positions where we do not know whether to produce +expression, a pattern, or a command, we instead produce a parser-validator for +each possible option. + +Then, as soon as we have parsed far enough to resolve the ambiguity, we pick +the appropriate component of the product, discarding the rest: + + checkExpOf3 (e, _, _) = e -- interpret as an expression + checkCmdOf3 (_, c, _) = c -- interpret as a command + checkPatOf3 (_, _, p) = p -- interpret as a pattern + +We can easily define ambiguities between arbitrary subsets of interpretations. +For example, when we know ahead of type that only an expression or a command is +possible, but not a pattern, we can use a smaller type: + + type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) + + checkExpOf2 (e, _) = e -- interpret as an expression + checkCmdOf2 (_, c) = c -- interpret as a command + +However, there is a slight problem with this approach, namely code duplication +in parser productions. Consider the 'alts' production used to parse case-of +alternatives: + + alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Under the new scheme, we have to completely duplicate its type signature and +each reduction rule: + + alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression + , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command + ) } + : alts1 + { ( checkExpOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + , checkCmdOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + ) } + | ';' alts + { ( checkExpOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + , checkCmdOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + ) } + +And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', +'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! + +Alternative VIII, a function from a GADT +---------------------------------------- +We could avoid code duplication of the Alternative VII by representing the product +as a function from a GADT: + + data ExpCmdG b where + ExpG :: ExpCmdG HsExpr + CmdG :: ExpCmdG HsCmd + + type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) + + checkExp :: ExpCmd -> PV (LHsExpr GhcPs) + checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) + checkExp f = f ExpG -- interpret as an expression + checkCmd f = f CmdG -- interpret as a command + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr, and it becomes: + + alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 + { \tag -> $1 tag >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts + { \tag -> $2 tag >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Note that 'ExpCmdG' is a singleton type, the value is completely +determined by the type: + + when (b~HsExpr), tag = ExpG + when (b~HsCmd), tag = CmdG + +This is a clear indication that we can use a class to pass this value behind +the scenes: + + class ExpCmdI b where expCmdG :: ExpCmdG b + instance ExpCmdI HsExpr where expCmdG = ExpG + instance ExpCmdI HsCmd where expCmdG = CmdG + +And now the 'alts' production is simplified, as we no longer need to +thread 'tag' explicitly: + + alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +This encoding works well enough, but introduces an extra GADT unlike the +tagless final encoding, and there's no need for this complexity. + +-} + +{- Note [PatBuilder] +~~~~~~~~~~~~~~~~~~~~ +Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms, +so we introduce the notion of a PatBuilder. + +Consider a pattern like this: + + Con a b c + +We parse arguments to "Con" one at a time in the fexp aexp parser production, +building the result with mkHsAppPV, so the intermediate forms are: + + 1. Con + 2. Con a + 3. Con a b + 4. Con a b c + +In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like +this (pseudocode): + + 1. "Con" + 2. HsApp "Con" "a" + 3. HsApp (HsApp "Con" "a") "b" + 3. HsApp (HsApp (HsApp "Con" "a") "b") "c" + +Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have +instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for +the intermediate forms. + +We also need an intermediate representation to postpone disambiguation between +FunBind and PatBind. Consider: + + a `Con` b = ... + a `fun` b = ... + +How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We +learn this by inspecting an intermediate representation in 'isFunLhs' and +seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate +representation capable of representing both a FunBind and a PatBind, so Pat is +insufficient. + +PatBuilder is an extension of Pat that is capable of representing intermediate +parsing results for patterns and function bindings: + + data PatBuilder p + = PatBuilderPat (Pat p) + | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) + | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p)) + ... + +It can represent any pattern via 'PatBuilderPat', but it also has a variety of +other constructors which were added by following a simple principle: we never +pattern match on the pattern stored inside 'PatBuilderPat'. +-} + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +-- | Check if a fixity is valid. We support bypassing the usual bound checks +-- for some special operators. +checkPrecP + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (LocatedN RdrName)) -- ^ operators + -> P () +checkPrecP (L l (_,i)) (L _ ol) + | 0 <= i, i <= maxPrecedence = pure () + | all specialOp ol = pure () + | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i) + where + -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs + specialOp op = unLoc op == getRdrName unrestrictedFunTyCon + +mkRecConstrOrUpdate + :: Bool + -> LHsExpr GhcPs + -> SrcSpan + -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) + -> (Maybe (EpToken "{"), Maybe (EpToken "}")) + -> PV (HsExpr GhcPs) +mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns + | isRdrDataCon c + = do + let (fs, ps) = partitionEithers fbinds + case ps of + p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $ + PsErrOverloadedRecordDotInvalid + _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) +mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns + | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $ + PsErrDotsInRecordUpdate + | otherwise = mkRdrRecordUpd overloaded_update exp fs anns + +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> (Maybe (EpToken "{"), Maybe (EpToken "}")) + -> PV (HsExpr GhcPs) +mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do + -- We do not need to know if OverloadedRecordDot is in effect. We do + -- however need to know if OverloadedRecordUpdate (passed in + -- overloaded_on) is in effect because it affects the Left/Right nature + -- of the RecordUpd value we calculate. + let (fs, ps) = partitionEithers fbinds + fs' :: [LHsRecUpdField GhcPs GhcPs] + fs' = map (fmap mk_rec_upd_field) fs + case overloaded_on of + False | not $ null ps -> + -- A '.' was found in an update and OverloadedRecordUpdate isn't on. + addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled + False -> + -- This is just a regular record update. + return RecordUpd { + rupd_ext = anns + , rupd_expr = exp + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = fs' } } + -- This is a RecordDotSyntax update. + True -> do + let qualifiedFields = + [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' + , isQual . fieldOccRdrName $ lbl + ] + case qualifiedFields of + qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ + PsErrOverloadedRecordUpdateNoQualifiedFields + _ -> return $ + RecordUpd + { rupd_ext = anns + , rupd_expr = exp + , rupd_flds = + OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = toProjUpdates fbinds } } + where + toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs] + toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f }) + + -- Convert a top-level field update like {foo=2} or {bar} (punned) + -- to a projection update. + recFieldToProjUpdate :: LHsRecField GhcPs (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs + recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = + -- The idea here is to convert the label to a singleton [FastString]. + let f = occNameFS . rdrNameOcc $ rdr + fl = DotFieldOcc noAnn (L loc (FieldLabelString f)) + lf = locA loc + in mkRdrProjUpdate l (L lf (L (l2l loc) fl :| [])) (punnedVar f) pun anns + where + -- If punning, compute HsVar "f" otherwise just arg. This + -- has the effect that sentinel HsVar "pun-rhs" is replaced + -- by HsVar "f" here, before the update is written to a + -- setField expressions. + punnedVar :: FastString -> LHsExpr GhcPs + punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f + +mkRdrRecordCon + :: LocatedN RdrName -> HsRecordBinds GhcPs -> (Maybe (EpToken "{"), Maybe (EpToken "}")) -> HsExpr GhcPs +mkRdrRecordCon con flds anns + = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } + +mk_rec_fields :: [LocatedA (HsRecField GhcPs arg)] -> Maybe SrcSpan -> HsRecFields GhcPs arg +mk_rec_fields fs Nothing = HsRecFields { rec_ext = noExtField, rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs (Just s) = HsRecFields { rec_ext = noExtField, rec_flds = fs + , rec_dotdot = Just (L (l2l s) (RecFieldsDotDot $ length fs)) } + +mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs +mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) + = HsFieldBind noAnn (L loc (FieldOcc noExtField rdr)) arg pun + +mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation + -> InlinePragma +-- The (Maybe Activation) is because the user can omit +-- the activation spec (and usually does) +mkInlinePragma src (inl, match_info) mb_act + = InlinePragma { inl_src = src -- See Note [Pragma source text] in "GHC.Types.SourceText" + , inl_inline = inl + , inl_sat = Nothing + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing -> -- No phase specified + case inl of + NoInline _ -> NeverActive + Opaque _ -> NeverActive + _other -> AlwaysActive + +mkOpaquePragma :: SourceText -> InlinePragma +mkOpaquePragma src + = InlinePragma { inl_src = src + , inl_inline = Opaque src + , inl_sat = Nothing + -- By marking the OPAQUE pragma NeverActive we stop + -- (constructor) specialisation on OPAQUE things. + -- + -- See Note [OPAQUE pragma] + , inl_act = NeverActive + , inl_rule = FunLike + } + +checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] + -> P (DataDefnCons (LConDecl GhcPs)) +checkNewOrData span name is_type_data = curry $ \ case + (NewType, [a]) -> pure $ NewTypeCon a + (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as) + (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as) + where + -- In a "type data" declaration, the constructors are in the type/class + -- namespace rather than the data constructor namespace. + -- See Note [Type data declarations] in GHC.Rename.Module. + handle_type_data + | is_type_data = map (fmap promote_constructor) + | otherwise = id + + promote_constructor (dc@ConDeclGADT { con_names = cons }) + = dc { con_names = fmap (fmap promote_name) cons } + promote_constructor (dc@ConDeclH98 { con_name = con }) + = dc { con_name = fmap promote_name con } + promote_constructor dc = dc + + promote_name name = fromMaybe name (promoteRdrName name) + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- construct a foreign import declaration +-- +mkImport :: Located CCallConv + -> Located Safety + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> (EpToken "import", TokDcolon) + -> P (EpToken "foreign" -> HsDecl GhcPs) +mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) (timport, td) = + case unLoc cconv of + CCallConv -> returnSpec =<< mkCImport + CApiConv -> do + imp <- mkCImport + if isCWrapperImport imp + then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport + else returnSpec imp + StdCallConv -> returnSpec =<< mkCImport + PrimCallConv -> mkOtherImport + JavaScriptCallConv -> mkOtherImport + where + -- Parse a C-like entity string of the following form: + -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" + -- If 'cid' is missing, the function name 'v' is used instead as symbol + -- name (cf section 8.5.1 in Haskell 2010 report). + mkCImport = do + let e = unpackFS entity + case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of + Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $ + PsErrMalformedEntityString + Just importSpec -> return importSpec + + isCWrapperImport (CImport _ _ _ _ CWrapper) = True + isCWrapperImport _ = False + + -- currently, all the other import conventions only support a symbol name in + -- the entity string. If it is missing, we use the function name instead. + mkOtherImport = returnSpec importSpec + where + entity' = if nullFS entity + then mkExtName (unLoc v) + else entity + funcTarget = CFunction (StaticTarget esrc entity' Nothing True) + importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget + + returnSpec spec = return $ \tforeign -> ForD noExtField $ ForeignImport + { fd_i_ext = (tforeign, timport, td) + , fd_name = v + , fd_sig_ty = ty + , fd_fi = spec + } + + + +-- the string "foo" is ambiguous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String + -> Located SourceText + -> Maybe (ForeignImport (GhcPass p)) +parseCImport cconv safety nm str sourceText = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = do + skipSpaces + r <- choice [ + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + let src = mkFastString h + mk (Just (Header (SourceText src) src)) + <$> cimp nm)) + ] + skipSpaces + return r + + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + + mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n + + hdr_char c = not (isSpace c) + -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ (do isFun <- case unLoc cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget NoSourceText cid' + Nothing isFun))) + where + cid = return nm +++ + (do c <- satisfy id_first_char + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + + +-- construct a foreign export declaration +-- +mkExport :: Located CCallConv + -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) + -> ( EpToken "export", TokDcolon) + -> P (EpToken "foreign" -> HsDecl GhcPs) +mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) (texport, td) + = return $ \tforeign -> ForD noExtField $ + ForeignExport { fd_e_ext = (tforeign, texport, td), fd_name = v, fd_sig_ty = ty + , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) } + where + entity' | nullFS entity = mkExtName (unLoc v) + | otherwise = entity + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm) + +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +data ImpExpSubSpec = ImpExpAbs + | ImpExpAll (EpToken "..") + | ImpExpList [LocatedA ImpExpQcSpec] + | ImpExpAllWith [LocatedA ImpExpQcSpec] + +data ImpExpQcSpec = ImpExpQcName (Maybe ExplicitNamespaceKeyword) (LocatedN RdrName) + | ImpExpQcWildcard (EpToken "..") (EpToken ",") + +mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec + -> ImpExpSubSpec -> P (IE GhcPs) +mkModuleImpExp warning (top, tcp) (L l specname) subs = do + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) + -> return $ IEVar warning + (L l (ieNameFromSpec specname)) Nothing + | otherwise -> IEThingAbs warning . L l <$> nameT <*> pure noExportDoc + ImpExpAll tok -> IEThingAll (warning, (top, tok, tcp)) . L l <$> nameT <*> pure noExportDoc + ImpExpList xs -> + (\newName -> IEThingWith (warning, (top,NoEpTok,NoEpTok,tcp)) (L l newName) + NoIEWildcard (wrapped xs)) <$> nameT <*> pure noExportDoc + ImpExpAllWith xs -> + do allowed <- getBit PatternSynonymsBit + if allowed + then + let withs = map unLoc xs + pos = maybe NoIEWildcard IEWildcard + (findIndex isImpExpQcWildcard withs) + (td,tc) = case find isImpExpQcWildcard withs of + Just (ImpExpQcWildcard td tc) -> (td,tc) + _ -> (NoEpTok, NoEpTok) + ies :: [LocatedA (IEWrappedName GhcPs)] + ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs + in (\newName + -> IEThingWith (warning, (top,td,tc,tcp)) (L l newName) pos ies) + <$> nameT <*> pure noExportDoc + else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + PsErrIllegalPatSynExport + where + noExportDoc :: Maybe (LHsDoc GhcPs) + noExportDoc = Nothing + + name = ieNameVal specname + nameT = + if isVarNameSpace (rdrNameSpace name) + then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ + (PsErrVarForTyCon name) + else return $ ieNameFromSpec specname + + ieNameVal (ImpExpQcName _ ln) = unLoc ln + ieNameVal ImpExpQcWildcard{} = panic "ieNameVal got wildcard" + + ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs + ieNameFromSpec (ImpExpQcName m_kw name) = case m_kw of + Nothing -> IEName noExtField name + Just (ExplicitTypeNamespace tok) -> IEType tok name + Just (ExplicitDataNamespace tok) -> IEData tok name + ieNameFromSpec ImpExpQcWildcard{} = panic "ieNameFromSpec got wildcard" + + wrapped = map (fmap ieNameFromSpec) + +mkPlainImpExp :: LocatedN RdrName -> ImpExpQcSpec +mkPlainImpExp name = ImpExpQcName Nothing name + +mkTypeImpExp :: EpToken "type" + -> LocatedN RdrName -- TcCls or Var name space + -> P ImpExpQcSpec +mkTypeImpExp tok name = do + let name' = fmap (`setRdrNameSpace` tcClsName) name + ns_kw = ExplicitTypeNamespace tok + requireExplicitNamespaces ns_kw + return (ImpExpQcName (Just ns_kw) name') + +mkDataImpExp :: EpToken "data" + -> LocatedN RdrName + -> P ImpExpQcSpec +mkDataImpExp tok name = do + let ns_kw = ExplicitDataNamespace tok + requireExplicitNamespaces ns_kw + return (ImpExpQcName (Just ns_kw) name) + +checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs]) +checkImportSpec ie@(L _ specs) = + case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of + [] -> return ie + (l:_) -> importSpecError (locA l) + where + importSpecError l = + addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm + +-- In the correct order +mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ImpExpSubSpec +mkImpExpSubSpec [] = return (ImpExpList []) +mkImpExpSubSpec [L _ (ImpExpQcWildcard td _tc)] = + return (ImpExpAll td) +mkImpExpSubSpec xs = + if (any (isImpExpQcWildcard . unLoc) xs) + then return $ (ImpExpAllWith xs) + else return $ (ImpExpList xs) + +isImpExpQcWildcard :: ImpExpQcSpec -> Bool +isImpExpQcWildcard (ImpExpQcWildcard _ _) = True +isImpExpQcWildcard _ = False + +----------------------------------------------------------------------------- +-- Warnings and failures + +warnPrepositiveQualifiedModule :: SrcSpan -> P () +warnPrepositiveQualifiedModule span = + addPsMessage span PsWarnImportPreQualified + +failNotEnabledImportQualifiedPost :: SrcSpan -> P () +failNotEnabledImportQualifiedPost loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified + +failImportQualifiedTwice :: SrcSpan -> P () +failImportQualifiedTwice loc = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice + +failSpliceOrQuoteTwice :: EpAnnLevel -> P () +failSpliceOrQuoteTwice lvl = + addError $ mkPlainErrorMsgEnvelope loc $ PsErrSpliceOrQuoteTwice + where + loc = case lvl of + EpAnnLevelSplice tok -> getEpTokenSrcSpan tok + EpAnnLevelQuote tok -> getEpTokenSrcSpan tok + +warnStarIsType :: SrcSpan -> P () +warnStarIsType span = addPsMessage span PsWarnStarIsType + +failOpFewArgs :: MonadP m => LocatedN RdrName -> m a +failOpFewArgs (L loc op) = + do { star_is_type <- getBit StarIsTypeBit + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ + (PsErrOpFewArgs is_star_type op) } + +requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m () +requireExplicitNamespaces kw = do + allowed <- getBit ExplicitNamespacesBit + unless allowed $ + addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalExplicitNamespace kw + where + loc = case kw of + ExplicitTypeNamespace tok -> getEpTokenSrcSpan tok + ExplicitDataNamespace tok -> getEpTokenSrcSpan tok + +warnPatternNamespaceSpecifier :: MonadP m => SrcSpan -> m () +warnPatternNamespaceSpecifier l = do + explicit_namespaces <- getBit ExplicitNamespacesBit + addPsMessage l (PsWarnPatternNamespaceSpecifier explicit_namespaces) + +----------------------------------------------------------------------------- +-- Misc utils + +data PV_Context = + PV_Context + { pv_options :: ParserOpts + , pv_details :: ParseContext -- See Note [Parser-Validator Details] + } + +data PV_Accum = + PV_Accum + { pv_warnings :: Messages PsMessage + , pv_errors :: Messages PsMessage + , pv_header_comments :: Strict.Maybe [LEpaComment] + , pv_comment_q :: [LEpaComment] + } + +data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum + deriving (Foldable, Functor, Traversable) + +-- During parsing, we make use of several monadic effects: reporting parse errors, +-- accumulating warnings, adding API annotations, and checking for extensions. These +-- effects are captured by the 'MonadP' type class. +-- +-- Sometimes we need to postpone some of these effects to a later stage due to +-- ambiguities described in Note [Ambiguous syntactic categories]. +-- We could use two layers of the P monad, one for each stage: +-- +-- abParser :: forall x. DisambAB x => P (P x) +-- +-- The outer layer of P consumes the input and builds the inner layer, which +-- validates the input. But this type is not particularly helpful, as it obscures +-- the fact that the inner layer of P never consumes any input. +-- +-- For clarity, we introduce the notion of a parser-validator: a parser that does +-- not consume any input, but may fail or use other effects. Thus we have: +-- +-- abParser :: forall x. DisambAB x => P (PV x) +-- +newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } + deriving (Functor) + +instance Applicative PV where + pure a = a `seq` PV (\_ acc -> PV_Ok acc a) + (<*>) = ap + +instance Monad PV where + m >>= f = PV $ \ctx acc -> + case unPV m ctx acc of + PV_Ok acc' a -> unPV (f a) ctx acc' + PV_Failed acc' -> PV_Failed acc' + +runPV :: PV a -> P a +runPV = runPV_details noParseContext + +askParseContext :: PV ParseContext +askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details + +runPV_details :: ParseContext -> PV a -> P a +runPV_details details m = + P $ \s -> + let + pv_ctx = PV_Context + { pv_options = options s + , pv_details = details } + pv_acc = PV_Accum + { pv_warnings = warnings s + , pv_errors = errors s + , pv_header_comments = header_comments s + , pv_comment_q = comment_q s } + mkPState acc' = + s { warnings = pv_warnings acc' + , errors = pv_errors acc' + , comment_q = pv_comment_q acc' } + in + case unPV m pv_ctx pv_acc of + PV_Ok acc' a -> POk (mkPState acc') a + PV_Failed acc' -> PFailed (mkPState acc') + +instance MonadP PV where + addError err = + PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} () + addWarning w = + PV $ \_ctx acc -> + -- No need to check for the warning flag to be set, GHC will correctly discard suppressed + -- diagnostics. + PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} () + addFatalError err = + addError err >> PV (const PV_Failed) + getParserOpts = PV $ \ctx acc -> PV_Ok acc $! pv_options ctx + allocateCommentsP ss = PV $ \_ s -> + if null (pv_comment_q s) then PV_Ok s emptyComments else -- fast path + let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in + PV_Ok s { + pv_comment_q = comment_q' + } (EpaComments newAnns) + allocatePriorCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (EpaComments newAnns) + allocateFinalCommentsP ss = PV $ \_ s -> + let (header_comments', comment_q', newAnns) + = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in + PV_Ok s { + pv_header_comments = header_comments', + pv_comment_q = comment_q' + } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns) + +{- Note [Parser-Validator Details] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set +depending on validation context. We use this in checkPattern to fix #984. + +Consider this example, where the user has forgotten a 'do': + + f _ = do + x <- computation + case () of + _ -> + result <- computation + case () of () -> undefined + +GHC parses it as follows: + + f _ = do + x <- computation + (case () of + _ -> + result) <- computation + case () of () -> undefined + +Note that this fragment is parsed as a pattern: + + case () of + _ -> + result + +We attempt to detect such cases and add a hint to the diagnostic messages: + + T984.hs:6:9: + Parse error in pattern: case () of { _ -> result } + Possibly caused by a missing 'do'? + +The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed +out of the 'ParseContext', which are read by functions like 'patFail' when +constructing the 'PsParseErrorInPatDetails' data structure. When validating in a +context other than 'bindpat' (a pattern to the left of <-), we set the +details to 'noParseContext' and it has no effect on the diagnostic messages. + +-} + +-- | Hint about bang patterns, assuming @BangPatterns@ is off. +hintBangPat :: SrcSpan -> Pat GhcPs -> PV () +hintBangPat span e = do + bang_on <- getBit BangPatBit + unless bang_on $ + addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e + +mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs) + -> (EpaLocation, EpaLocation) + -> PV (LHsExpr GhcPs) + +-- Tuple +mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do + !cs <- getCommentsFor (locA l) + return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity) + where + toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs + toTupArg (Left ann) = missingTupArg ann + toTupArg (Right a) = Present noExtField a + +-- Sum +-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) = +-- return $ L l (ExplicitSum noExtField alt arity e) +mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) (o, c) = do + let an = AnnExplicitSum o barsp barsa c + !cs <- getCommentsFor (locA l) + return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e) +mkSumOrTupleExpr l Boxed a@Sum{} _ = + addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a + +mkSumOrTuplePat + :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> (EpaLocation, EpaLocation) + -> PV (LocatedA (PatBuilder GhcPs)) + +-- Tuple +mkSumOrTuplePat l boxity (Tuple ps) anns = do + ps' <- traverse toTupPat ps + return $ L l (PatBuilderPat (TuplePat anns ps' boxity)) + where + toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) + -- Ignore the element location so that the error message refers to the + -- entire tuple. See #19504 (and the discussion) for details. + toTupPat p = case p of + Left _ -> addFatalError $ + mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat + Right p' -> checkLPat p' + +-- Sum +mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do + p' <- checkLPat p + let an = EpAnnSumPat anns barsb barsa + return $ L l (PatBuilderPat (SumPat an p' alt arity)) +mkSumOrTuplePat l Boxed a@Sum{} _ = + addFatalError $ + mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a + +mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy prom x op y = + let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y + in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y) + +mkMultExpr :: EpToken "%" -> LHsExpr GhcPs -> TokRarrow -> HsMultAnnOf (LHsExpr GhcPs) GhcPs +mkMultExpr pct t@(L _ (HsOverLit _ (OverLit _ (HsIntegral (IL (SourceText (unpackFS -> "1")) _ 1))))) arr + -- See #18888 for the use of (SourceText "1") above + = HsLinearAnn (EpPct1 pct1 (EpArrow arr)) + where + -- The location of "%" combined with the location of "1". + pct1 :: EpToken "%1" + pct1 = epTokenWidenR pct (locA (getLoc t)) +mkMultExpr pct t arr = HsExplicitMult (pct, EpArrow arr) t + +mkMultAnn :: EpToken "%" -> LHsType GhcPs -> EpArrowOrColon -> HsMultAnn GhcPs +mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) ep + -- See #18888 for the use of (SourceText "1") above + = HsLinearAnn (EpPct1 pct1 ep) + where + -- The location of "%" combined with the location of "1". + pct1 :: EpToken "%1" + pct1 = epTokenWidenR pct (locA (getLoc t)) +mkMultAnn pct t ep = HsExplicitMult (pct, ep) t + +mkMultField :: EpToken "%" -> LHsType GhcPs -> TokDcolon -> LHsType GhcPs -> HsConDeclField GhcPs +mkMultField pct mult col t = mkConDeclField (mkMultAnn pct mult (EpColon col)) t + +-- Precondition: the EpToken has EpaSpan, never EpaDelta. +epTokenWidenR :: EpToken tok -> SrcSpan -> EpToken tok' +epTokenWidenR NoEpTok _ = NoEpTok +epTokenWidenR (EpTok l) (UnhelpfulSpan _) = EpTok l +epTokenWidenR (EpTok (EpaSpan s1)) s2 = EpTok (EpaSpan (combineSrcSpans s1 s2)) +epTokenWidenR (EpTok EpaDelta{}) _ = + -- Never happens because the parser does not produce EpaDelta. + panic "epTokenWidenR: EpaDelta" + +----------------------------------------------------------------------------- +-- Token symbols + +starSym :: Bool -> FastString +starSym True = fsLit "★" +starSym False = fsLit "*" + +----------------------------------------- +-- Bits and pieces for RecordDotSyntax. + +mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) + -> HsExpr GhcPs +mkRdrGetField arg field = + HsGetField { + gf_ext = NoExtField + , gf_expr = arg + , gf_field = field + } + +mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs +mkRdrProjection flds anns = + HsProjection { + proj_ext = anns + , proj_flds = fmap unLoc flds + } + +mkRdrProjUpdate :: SrcSpanAnnA -> Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) + -> LHsExpr GhcPs -> Bool -> Maybe (EpToken "=") + -> LHsRecProj GhcPs (LHsExpr GhcPs) +mkRdrProjUpdate loc (L l flds) arg isPun anns = + L loc HsFieldBind { + hfbAnn = anns + , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds) + , hfbRHS = arg + , hfbPun = isPun + } + +----------------------------------------------------------------------------- +-- Tuple and list punning + +punsAllowed :: P Bool +punsAllowed = getBit ListTuplePunsBit + +-- | Check whether @ListTuplePuns@ is enabled and return the first arg if it is, +-- the second arg otherwise. +punsIfElse :: a -> a -> P a +punsIfElse enabled disabled = do + allowed <- punsAllowed + pure (if allowed then enabled else disabled) + +-- | Emit an error of type 'PsErrInvalidPun' with a location from @start@ to +-- @end@ if the extension @ListTuplePuns@ is disabled. +-- +-- This is used in Parser.y to guard rules that require punning. +requireLTPuns :: PsErrPunDetails -> Located a -> Located b -> P () +requireLTPuns err start end = + unlessM punsAllowed $ do + addError (mkPlainErrorMsgEnvelope loc (PsErrInvalidPun err)) + where + loc = (combineSrcSpans (getLoc start) (getLoc end)) + +-- | Call a parser with a span and its comments given by a start and end token. +withCombinedComments :: + HasLoc l1 => + HasLoc l2 => + l1 -> + l2 -> + (SrcSpan -> P a) -> + P (LocatedA a) +withCombinedComments start end use = do + cs <- getCommentsFor fullSpan + a <- use fullSpan + pure (L (EpAnn (spanAsAnchor fullSpan) noAnn cs) a) + where + fullSpan = combineSrcSpans (getHasLoc start) (getHasLoc end) + +-- | Decide whether to parse tuple syntax @(Int, Double)@ in a type as a +-- type or data constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'(Int, Double)@, is handled +-- by 'mkExplicitTupleTy'. +mkTupleSyntaxTy :: EpToken "(" + -> [LocatedA (HsType GhcPs)] + -> EpToken ")" + -> P (HsType GhcPs) +mkTupleSyntaxTy parOpen args parClose = + punsIfElse enabled disabled + where + enabled = + HsTupleTy annParen HsBoxedOrConstraintTuple args + disabled = + HsExplicitTupleTy annsKeyword NotPromoted args + + annParen = AnnParens parOpen parClose + annsKeyword = (NoEpTok, parOpen, parClose) + +-- | Decide whether to parse tuple con syntax @(,)@ in a type as a +-- type or data constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'(,)@, is handled +-- by the rule @SIMPLEQUOTE sysdcon_nolist@ in @atype@. +mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName +mkTupleSyntaxTycon boxity n = + punsIfElse + (getRdrName (tupleTyCon boxity n)) + (getRdrName (tupleDataCon boxity n)) + +-- | Decide whether to parse list tycon syntax @[]@ in a type as a type or data +-- constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'[]@, is handled by +-- 'mkExplicitListTy'. +mkListSyntaxTy0 :: EpToken "[" + -> EpToken "]" + -> SrcSpan + -> P (HsType GhcPs) +mkListSyntaxTy0 brkOpen brkClose span = + punsIfElse enabled disabled + where + enabled = HsTyVar noAnn NotPromoted rn + + -- attach the comments only to the RdrName since it's the innermost AST node + rn = L (EpAnn fullLoc rdrNameAnn emptyComments) listTyCon_RDR + + disabled = + HsExplicitListTy annsKeyword NotPromoted [] + + rdrNameAnn = NameAnnOnly (NameSquare brkOpen brkClose) [] + annsKeyword = (NoEpTok, brkOpen, brkClose) + fullLoc = EpaSpan span + +-- | Decide whether to parse list type syntax @[Int]@ in a type as a +-- type or data constructor, based on the extension @ListTuplePuns@. +-- The case with an explicit promotion quote, @'[Int]@, is handled +-- by 'mkExplicitListTy'. +mkListSyntaxTy1 :: EpToken "[" + -> LocatedA (HsType GhcPs) + -> EpToken "]" + -> P (HsType GhcPs) +mkListSyntaxTy1 brkOpen t brkClose = + punsIfElse enabled disabled + where + enabled = HsListTy annParen t + + disabled = + HsExplicitListTy annsKeyword NotPromoted [t] + + annsKeyword = (NoEpTok, brkOpen, brkClose) + annParen = AnnParensSquare brkOpen brkClose + +parseError :: HsExpr GhcPs +parseError = HsHole HoleError diff --git a/GHC/Parser/PostProcess/Haddock.hs b/GHC/Parser/PostProcess/Haddock.hs --- a/GHC/Parser/PostProcess/Haddock.hs +++ b/GHC/Parser/PostProcess/Haddock.hs @@ -53,27 +53,21 @@ import GHC.Hs import GHC.Types.SrcLoc -import GHC.Utils.Panic -import GHC.Data.Bag import Data.Semigroup import Data.Foldable import Data.Traversable -import Data.Maybe -import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE -import Control.Monad +import Control.Applicative import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer import Data.Functor.Identity -import qualified Data.Monoid import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types -import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) +import GHC.Utils.Misc (mergeListsBy, filterOut, (<&&>)) import qualified GHC.Data.Strict as Strict {- Note [Adding Haddock comments to the syntax tree] @@ -220,9 +214,8 @@ -- But having a single name for all of them is just easier to read, and makes it clear -- that they all are of the form t -> HdkA t for some t. -- --- If you need to handle a more complicated scenario that doesn't fit this --- pattern, it's always possible to define separate functions outside of this --- class, as is done in case of e.g. addHaddockConDeclField. +-- If you need to handle a more complicated scenario that doesn't fit this pattern, +-- it's always possible to define separate functions outside of this class. -- -- See Note [Adding Haddock comments to the syntax tree]. class HasHaddock a where @@ -243,6 +236,8 @@ -- instance HasHaddock (Located (HsModule GhcPs)) where addHaddock (L l_mod mod) = do + let mod_anns = anns (hsmodAnn (hsmodExt mod)) + -- Step 1, get the module header documentation comment: -- -- -- | Module header comment @@ -250,14 +245,19 @@ -- -- Only do this when the module header exists. headerDocs <- - for @Maybe (hsmodName mod) $ \(L l_name _) -> - extendHdkA (locA l_name) $ liftHdkA $ do - -- todo: register keyword location of 'module', see Note [Register keyword location] - docs <- - inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $ - takeHdkComments mkDocNext - dc <- selectDocString docs - pure $ lexLHsDocString <$> dc + case hsmodName mod of + Nothing -> pure Nothing + Just (L l_name _) -> do + let modspan = + getEpTokenBufSpan (am_mod mod_anns) <> + getEpTokenBufSpan (am_sig mod_anns) <> + getBufSpan (locA l_name) + HdkA modspan $ do + docs <- + inLocRange (locRangeTo (fmap bufSpanStart modspan)) $ + takeHdkComments mkDocNext + dc <- selectDocString docs + pure $ lexLHsDocString <$> dc -- Step 2, process documentation comments in the export list: -- @@ -289,13 +289,13 @@ -- data C = MkC -- ^ Comment on MkC -- -- ^ Comment on C -- - let layout_info = hsmodLayout (hsmodExt mod) - hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod) + let layout = hsmodLayout (hsmodExt mod) + hsmodDecls' <- addHaddockInterleaveItems layout (mkDocHsDecl layout) (hsmodDecls mod) pure $ L l_mod $ mod { hsmodExports = hsmodExports' , hsmodDecls = hsmodDecls' - , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } } + , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = headerDocs } } lexHsDocString :: HsDocString -> HsDoc GhcPs lexHsDocString = lexHsDoc parseIdentifier @@ -303,22 +303,34 @@ lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs lexLHsDocString = fmap lexHsDocString --- Only for module exports, not module imports. +-- | Only for module exports, not module imports. -- -- module M (a, b, c) where -- use on this [LIE GhcPs] -- import I (a, b, c) -- do not use here! -- -- Imports cannot have documentation comments anyway. -instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where +instance HasHaddock (LocatedLI [LocatedA (IE GhcPs)]) where addHaddock (L l_exports exports) = extendHdkA (locA l_exports) $ do - exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports + exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis pure $ L l_exports exports' -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. instance HasHaddock (LocatedA (IE GhcPs)) where - addHaddock a = a <$ registerHdkA a + addHaddock (L l_export ie ) = + extendHdkA (locA l_export) $ liftHdkA $ do + docs <- inLocRange (locRangeFrom (getBufPos (srcSpanEnd (locA l_export)))) $ + takeHdkComments mkDocPrev + mb_doc <- selectDocString docs + let mb_ldoc = lexLHsDocString <$> mb_doc + let ie' = case ie of + IEVar ext nm _ -> IEVar ext nm mb_ldoc + IEThingAbs ext nm _ -> IEThingAbs ext nm mb_ldoc + IEThingAll ext nm _ -> IEThingAll ext nm mb_ldoc + IEThingWith ext nm wild subs _ -> IEThingWith ext nm wild subs mb_ldoc + x -> x + pure $ L l_export ie' {- Add Haddock items to a list of non-Haddock items. Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl). @@ -340,10 +352,10 @@ The inputs to addHaddockInterleaveItems are: - * layout_info :: LayoutInfo GhcPs + * layout :: EpLayout In the example above, note that the indentation level inside the module is - 2 spaces. It would be represented as layout_info = VirtualBraces 2. + 2 spaces. It would be represented as layout = EpVirtualBraces 2. It is used to delimit the search space for comments when processing declarations. Here, we restrict indentation levels to >=(2+1), so that when @@ -352,7 +364,7 @@ * get_doc_item :: PsLocated HdkComment -> Maybe a This is the function used to look up documentation comments. - In the above example, get_doc_item = mkDocHsDecl layout_info, + In the above example, get_doc_item = mkDocHsDecl layout, and it will produce the following parts of the output: DocD (DocCommentNext "Comment on D") @@ -372,25 +384,25 @@ addHaddockInterleaveItems :: forall a. HasHaddock a - => LayoutInfo GhcPs + => EpLayout -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item -> [a] -- Unprocessed (non-documentation) items -> HdkA [a] -- Documentation items & processed non-documentation items -addHaddockInterleaveItems layout_info get_doc_item = go +addHaddockInterleaveItems layout get_doc_item = go where go :: [a] -> HdkA [a] go [] = liftHdkA (takeHdkComments get_doc_item) go (item : items) = do docItems <- liftHdkA (takeHdkComments get_doc_item) - item' <- with_layout_info (addHaddock item) + item' <- with_layout (addHaddock item) other_items <- go items pure $ docItems ++ item':other_items - with_layout_info :: HdkA a -> HdkA a - with_layout_info = case layout_info of - NoLayoutInfo -> id - ExplicitBraces{} -> id - VirtualBraces n -> + with_layout :: HdkA a -> HdkA a + with_layout = case layout of + EpNoLayout -> id + EpExplicitBraces{} -> id + EpVirtualBraces n -> let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) @@ -498,18 +510,18 @@ -- -- ^ Comment on the second method -- addHaddock (TyClD _ decl) - | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout, + | ClassDecl { tcdCExt = (x, layout, NoAnnSortKey), tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl = do registerHdkA tcdLName - -- todo: register keyword location of 'where', see Note [Register keyword location] + registerEpTokenHdkA (acd_where x) where_cls' <- - addHaddockInterleaveItems tcdLayout (mkDocHsDecl tcdLayout) $ + addHaddockInterleaveItems layout (mkDocHsDecl layout) $ flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) pure $ let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' - decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout + decl' = ClassDecl { tcdCExt = (x, layout, NoAnnSortKey) , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs , tcdSigs = tcdSigs' , tcdMeths = tcdMeths' @@ -548,7 +560,6 @@ | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl = do registerHdkA tcdLName - -- todo: register keyword location of '=', see Note [Register keyword location] tcdRhs' <- addHaddock tcdRhs pure $ TyClD noExtField (SynDecl { @@ -578,7 +589,7 @@ -- data D :: Type -> Type where ... -- data instance D Bool :: Type where ... traverse_ @Maybe registerHdkA (dd_kindSig defn) - -- todo: register keyword location of '=' or 'where', see Note [Register keyword location] + registerEpTokenHdkA (andd_where (dd_ext defn)) -- Process the data constructors: -- @@ -698,202 +709,102 @@ addHaddock (L l_con_decl con_decl) = extendHdkA (locA l_con_decl) $ case con_decl of - ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do - -- discardHasInnerDocs is ok because we don't need this info for GADTs. - con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names)) + ConDeclGADT { con_g_ext, con_names, con_outer_bndrs, con_inner_bndrs + , con_mb_cxt, con_g_args, con_res_ty } -> do + con_doc' <- getConDoc (getLocA (NE.head con_names)) con_g_args' <- case con_g_args of - PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts - RecConGADT (L l_rec flds) arr -> do - -- discardHasInnerDocs is ok because we don't need this info for GADTs. - flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds - pure $ RecConGADT (L l_rec flds') arr + PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts + RecConGADT arr (L l_rec flds) -> do + flds' <- traverse addHaddock flds + pure $ RecConGADT arr (L l_rec flds') con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ - ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, + ConDeclGADT { con_g_ext, con_names, + con_outer_bndrs, con_inner_bndrs, con_mb_cxt, con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> - addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $ - case con_args of - PrefixCon _ ts -> do - con_doc' <- getConDoc (getLocA con_name) - ts' <- traverse addHaddockConDeclFieldTy ts - pure $ L l_con_decl $ - ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = lexLHsDocString <$> con_doc', - con_args = PrefixCon noTypeArgs ts' } - InfixCon t1 t2 -> do - t1' <- addHaddockConDeclFieldTy t1 - con_doc' <- getConDoc (getLocA con_name) - t2' <- addHaddockConDeclFieldTy t2 - pure $ L l_con_decl $ - ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = lexLHsDocString <$> con_doc', - con_args = InfixCon t1' t2' } - RecCon (L l_rec flds) -> do - con_doc' <- getConDoc (getLocA con_name) - flds' <- traverse addHaddockConDeclField flds - pure $ L l_con_decl $ - ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, - con_doc = lexLHsDocString <$> con_doc', - con_args = RecCon (L l_rec flds') } - --- Keep track of documentation comments on the data constructor or any of its --- fields. --- --- See Note [Trailing comment on constructor declaration] -type ConHdkA = WriterT HasInnerDocs HdkA + let + -- See Note [Leading and trailing comments on H98 constructors] + getTrailingLeading :: HdkM (LocatedA (ConDecl GhcPs)) + getTrailingLeading = do + con_doc' <- getPrevNextDoc (locA l_con_decl) + return $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args + , con_doc = lexLHsDocString <$> con_doc' } --- Does the data constructor declaration have any inner (non-trailing) --- documentation comments? --- --- Example when HasInnerDocs is True: --- --- data X = --- MkX -- ^ inner comment --- Field1 -- ^ inner comment --- Field2 -- ^ inner comment --- Field3 -- ^ trailing comment --- --- Example when HasInnerDocs is False: --- --- data Y = MkY Field1 Field2 Field3 -- ^ trailing comment --- --- See Note [Trailing comment on constructor declaration] -newtype HasInnerDocs = HasInnerDocs Bool - deriving (Semigroup, Monoid) via Data.Monoid.Any + -- See Note [Leading and trailing comments on H98 constructors] + getMixed :: HdkA (LocatedA (ConDecl GhcPs)) + getMixed = + case con_args of + PrefixCon ts -> do + con_doc' <- getConDoc (getLocA con_name) + ts' <- traverse addHaddock ts + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_args = PrefixCon ts' } + InfixCon t1 t2 -> do + t1' <- addHaddock t1 + con_doc' <- getConDoc (getLocA con_name) + t2' <- addHaddock t2 + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_args = InfixCon t1' t2' } + RecCon (L l_rec flds) -> do + con_doc' <- getConDoc (getLocA con_name) + flds' <- traverse addHaddock flds + pure $ L l_con_decl $ + ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, + con_doc = lexLHsDocString <$> con_doc', + con_args = RecCon (L l_rec flds') } + in + hoistHdkA + (\m -> do { a <- onlyTrailingOrLeading (locA l_con_decl) + ; if a then getTrailingLeading else m }) + getMixed --- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it. --- --- We only do this when processing data declarations that use GADT syntax, --- because only the H98 syntax declarations have special treatment for the --- trailing documentation comment. --- --- See Note [Trailing comment on constructor declaration] -discardHasInnerDocs :: ConHdkA a -> HdkA a -discardHasInnerDocs = fmap fst . runWriterT +-- See Note [Leading and trailing comments on H98 constructors] +onlyTrailingOrLeading :: SrcSpan -> HdkM Bool +onlyTrailingOrLeading l = peekHdkM $ do + leading <- + inLocRange (locRangeTo (getBufPos (srcSpanStart l))) $ + takeHdkComments mkDocNext + inner <- + inLocRange (locRangeIn (getBufSpan l)) $ + takeHdkComments (\x -> mkDocNext x <|> mkDocPrev x) + trailing <- + inLocRange (locRangeFrom (getBufPos (srcSpanEnd l))) $ + takeHdkComments mkDocPrev + return $ case (leading, inner, trailing) of + (_:_, [], []) -> True -- leading comment only + ([], [], _:_) -> True -- trailing comment only + _ -> False -- Get the documentation comment associated with the data constructor in a -- data/newtype declaration. getConDoc :: SrcSpan -- Location of the data constructor - -> ConHdkA (Maybe (Located HsDocString)) -getConDoc l = - WriterT $ extendHdkA l $ liftHdkA $ do - mDoc <- getPrevNextDoc l - return (mDoc, HasInnerDocs (isJust mDoc)) - --- Add documentation comment to a data constructor field. --- Used for PrefixCon and InfixCon. -addHaddockConDeclFieldTy - :: HsScaled GhcPs (LHsType GhcPs) - -> ConHdkA (HsScaled GhcPs (LHsType GhcPs)) -addHaddockConDeclFieldTy (HsScaled mult (L l t)) = - WriterT $ extendHdkA (locA l) $ liftHdkA $ do - mDoc <- getPrevNextDoc (locA l) - return (HsScaled mult (mkLHsDocTy (L l t) mDoc), - HasInnerDocs (isJust mDoc)) - --- Add documentation comment to a data constructor field. --- Used for RecCon. -addHaddockConDeclField - :: LConDeclField GhcPs - -> ConHdkA (LConDeclField GhcPs) -addHaddockConDeclField (L l_fld fld) = - WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do - cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld) - return (L l_fld (fld { cd_fld_doc }), - HasInnerDocs (isJust cd_fld_doc)) + -> HdkA (Maybe (Located HsDocString)) +getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l --- 1. Process a H98-syntax data constructor declaration in a context with no --- access to the trailing documentation comment (by running the provided --- ConHdkA computation). --- --- 2. Then grab the trailing comment (if it exists) and attach it where --- appropriate: either to the data constructor itself or to its last field, --- depending on HasInnerDocs. --- --- See Note [Trailing comment on constructor declaration] -addConTrailingDoc - :: SrcLoc -- The end of a data constructor declaration. - -- Any docprev comment past this point is considered trailing. - -> ConHdkA (LConDecl GhcPs) - -> HdkA (LConDecl GhcPs) -addConTrailingDoc l_sep = - hoistHdkA add_trailing_doc . runWriterT - where - add_trailing_doc - :: HdkM (LConDecl GhcPs, HasInnerDocs) - -> HdkM (LConDecl GhcPs) - add_trailing_doc m = do - (L l con_decl, HasInnerDocs has_inner_docs) <- - inLocRange (locRangeTo (getBufPos l_sep)) m - -- inLocRange delimits the context so that the inner computation - -- will not consume the trailing documentation comment. - case con_decl of - ConDeclH98{} -> do - trailingDocs <- - inLocRange (locRangeFrom (getBufPos l_sep)) $ - takeHdkComments mkDocPrev - if null trailingDocs - then return (L l con_decl) - else do - if has_inner_docs then do - let mk_doc_ty :: HsScaled GhcPs (LHsType GhcPs) - -> HdkM (HsScaled GhcPs (LHsType GhcPs)) - mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) = - -- Happens in the following case: - -- - -- data T = - -- MkT - -- -- | Comment on SomeField - -- SomeField - -- -- ^ Another comment on SomeField? (rejected) - -- - -- See tests/.../haddockExtraDocs.hs - x <$ reportExtraDocs trailingDocs - mk_doc_ty (HsScaled mult (L l' t)) = do - doc <- selectDocString trailingDocs - return $ HsScaled mult (mkLHsDocTy (L l' t) doc) - let mk_doc_fld :: LConDeclField GhcPs - -> HdkM (LConDeclField GhcPs) - mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) = - -- Happens in the following case: - -- - -- data T = - -- MkT { - -- -- | Comment on SomeField - -- someField :: SomeField - -- } -- ^ Another comment on SomeField? (rejected) - -- - -- See tests/.../haddockExtraDocs.hs - x <$ reportExtraDocs trailingDocs - mk_doc_fld (L l' con_fld) = do - doc <- selectDocString trailingDocs - return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc }) - con_args' <- case con_args con_decl of - x@(PrefixCon _ ts) -> case nonEmpty ts of - Nothing -> x <$ reportExtraDocs trailingDocs - Just ts -> PrefixCon noTypeArgs . toList <$> mapLastM mk_doc_ty ts - x@(RecCon (L l_rec flds)) -> case nonEmpty flds of - Nothing -> x <$ reportExtraDocs trailingDocs - Just flds -> RecCon . L l_rec . toList <$> mapLastM mk_doc_fld flds - InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2 - return $ L l (con_decl{ con_args = con_args' }) - else do - con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs)) - return $ L l (con_decl{ con_doc = con_doc' }) - _ -> panic "addConTrailingDoc: non-H98 ConDecl" +instance HasHaddock (LocatedA (HsConDeclRecField GhcPs)) where + addHaddock (L l_fld (HsConDeclRecField ext nms cfs)) = + extendHdkA (locA l_fld) $ liftHdkA $ do + cdf_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld) + return $ L l_fld (HsConDeclRecField ext nms (cfs { cdf_doc })) -{- Note [Trailing comment on constructor declaration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Leading and trailing comments on H98 constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The trailing comment after a constructor declaration is associated with the -constructor itself when there are no other comments inside the declaration: +constructor itself when it is the only comment: data T = MkT A B -- ^ Comment on MkT data T = MkT { x :: A } -- ^ Comment on MkT + data T = A `MkT` B -- ^ Comment on MkT When there are other comments, the trailing comment applies to the last field: @@ -906,7 +817,58 @@ , b :: B -- ^ Comment on b , c :: C } -- ^ Comment on c -This makes the trailing comment context-sensitive. Example: + data T = + A -- ^ Comment on A + `MkT` -- ^ Comment on MkT + B -- ^ Comment on B + +When it comes to the leading comment, there is no such ambiguity in /prefix/ +constructor declarations (plain or record syntax): + + data T = + -- | Comment on MkT + MkT A B + + data T = + -- | Comment on MkT + MkT + -- | Comment on A + A + -- | Comment on B + B + + data T = + -- | Comment on MkT + MkT { x :: A } + + data T = + -- | Comment on MkT + MkT { + -- | Comment on a + a :: A, + -- | Comment on b + b :: B, + -- | Comment on c + c :: C + } + +However, in /infix/ constructor declarations the leading comment is associated +with the constructor itself if it is the only comment, and with the first +field if there are other comments: + + data T = + -- | Comment on MkT + A `MkT` B + + data T = + -- | Comment on A + A + -- | Comment on MkT + `MkT` + -- | Comment on B + B + +This makes the leading and trailing comments context-sensitive. Example: data T = -- | comment 1 MkT Int Bool -- ^ comment 2 @@ -920,21 +882,28 @@ We implement this in two steps: - 1. Process the data constructor declaration in a delimited context where the - trailing documentation comment is not visible. Delimiting the context is done - in addConTrailingDoc. + 1. Gather information about available comments using `onlyTrailingOrLeading`. + It inspects available comments but does not consume them, and returns a + boolean that tells us what algorithm we should use + True <=> expect a single leading/trailing comment + False <=> expect inner comments or more than one comment - When processing the declaration, track whether the constructor or any of - its fields have a documentation comment associated with them. - This is done using WriterT HasInnerDocs, see ConHdkA. + 2. Collect the comments using the algorithm determined in the previous step - 2. Depending on whether HasInnerDocs is True or False, attach the - trailing documentation comment to the data constructor itself - or to its last field. + a) `getTrailingLeading`: + a single leading/trailing comment is applied to the entire + constructor declaration as a whole; see the `con_doc` field + b) `getMixed`: + comments apply to individual parts of a constructor declaration, + including its field types -} -instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where - addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a +instance HasHaddock (HsConDeclField GhcPs) where + addHaddock cfs = do + cdf_type <- addHaddock (cdf_type cfs) + return $ case cdf_type of + L _ (HsDocTy _ ty doc) -> cfs { cdf_type = ty, cdf_doc = Just doc } + _ -> cfs { cdf_type } instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t @@ -1155,9 +1124,16 @@ -- A small wrapper over registerLocHdkA. -- -- See Note [Adding Haddock comments to the syntax tree]. -registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA () +registerHdkA :: GenLocated (EpAnn a) e -> HdkA () registerHdkA a = registerLocHdkA (getLocA a) +-- Let the neighbours know about a token at this location. +-- Similar to registerLocHdkA and registerHdkA. +-- +-- See Note [Adding Haddock comments to the syntax tree]. +registerEpTokenHdkA :: EpToken tok -> HdkA () +registerEpTokenHdkA tok = HdkA (getEpTokenBufSpan tok) (pure ()) + -- Modify the action of a HdkA computation. hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b hoistHdkA f (HdkA l m) = HdkA l (f m) @@ -1266,6 +1242,13 @@ Just item -> (item : items, other_hdk_comments) Nothing -> (items, hdk_comment : other_hdk_comments) +-- Run a HdkM action and restore the original state. +peekHdkM :: HdkM a -> HdkM a +peekHdkM m = + HdkM $ \r s -> + case unHdkM m r s of + (a, _) -> (a, s) + -- Get the docnext or docprev comment for an AST node at the given source span. getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) getPrevNextDoc l = do @@ -1290,15 +1273,6 @@ reportExtraDocs extra_docs return (Just doc) -selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a)) -selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc) - where - select [] = return Nothing - select [doc] = return (Just doc) - select (doc : extra_docs) = do - reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs - return (Just doc) - reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs = traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc)) @@ -1309,11 +1283,11 @@ * * ********************************************************************* -} -mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) -mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a +mkDocHsDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl layout a = fmap (DocD noExtField) <$> mkDocDecl layout a -mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) -mkDocDecl layout_info (L l_comment hdk_comment) +mkDocDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) +mkDocDecl layout (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = Just $ L (noAnnSrcSpan span) $ @@ -1344,10 +1318,10 @@ -- class C a where -- f :: a -> a -- -- ^ indent mismatch - indent_mismatch = case layout_info of - NoLayoutInfo -> False - ExplicitBraces{} -> False - VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) + indent_mismatch = case layout of + EpNoLayout -> False + EpExplicitBraces{} -> False + EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) = @@ -1355,7 +1329,7 @@ HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc) HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s) HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) - _ -> Nothing + HdkCommentPrev doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc) where l = noAnnSrcSpan span span = mkSrcSpanPs l_comment @@ -1398,6 +1372,13 @@ locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l } locRangeTo Strict.Nothing = mempty +-- The location range within the specified span. +locRangeIn :: Strict.Maybe BufSpan -> LocRange +locRangeIn (Strict.Just l) = + mempty { loc_range_from = StartLoc (bufSpanStart l) + , loc_range_to = EndLoc (bufSpanEnd l) } +locRangeIn Strict.Nothing = mempty + -- Represents a predicate on BufPos: -- -- LowerLocBound | BufPos -> Bool @@ -1482,7 +1463,7 @@ mkLHsDocTy :: LHsType GhcPs -> Maybe (Located HsDocString) -> LHsType GhcPs mkLHsDocTy t Nothing = t -mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t $ lexLHsDocString doc) +mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t $ lexLHsDocString doc) getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele = @@ -1509,7 +1490,7 @@ -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan' -- - 'partitionBindsAndSigs' does not discard this 'BufSpan' mergeListsBy cmpBufSpanA [ - mapLL (\b -> ValD noExtField b) (bagToList all_bs), + mapLL (\b -> ValD noExtField b) all_bs, mapLL (\s -> SigD noExtField s) all_ss, mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts, mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis, @@ -1517,7 +1498,7 @@ mapLL (\d -> DocD noExtField d) all_docs ] -cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering +cmpBufSpanA :: GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b) {- ********************************************************************* @@ -1525,10 +1506,6 @@ * General purpose utilities * * * ********************************************************************* -} - --- Cons an element to a list, if exists. -mcons :: Maybe a -> [a] -> [a] -mcons = maybe id (:) -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] diff --git a/GHC/Parser/String.hs b/GHC/Parser/String.hs new file mode 100644 --- /dev/null +++ b/GHC/Parser/String.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Parser.String ( + StringLexError (..), + lexString, + lexMultilineString, + + -- * Unicode smart quote helpers + isDoubleSmartQuote, + isSingleSmartQuote, +) where + +import GHC.Prelude hiding (getChar) + +import Control.Arrow ((>>>)) +import Control.Monad (when) +import Data.Char (chr, ord) +import qualified Data.Foldable1 as Foldable1 +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (listToMaybe, mapMaybe) +import GHC.Data.StringBuffer (StringBuffer) +import qualified GHC.Data.StringBuffer as StringBuffer +import GHC.Parser.CharClass ( + hexDigit, + is_decdigit, + is_hexdigit, + is_octdigit, + is_space, + octDecDigit, + ) +import GHC.Parser.Errors.Types (LexErr (..)) +import GHC.Utils.Panic (panic) + +type BufPos = Int +data StringLexError = StringLexError LexErr BufPos + deriving (Show, Eq) + +lexString :: Int -> StringBuffer -> Either StringLexError String +lexString = lexStringWith processChars processChars + where + processChars :: HasChar c => [c] -> Either (c, LexErr) [c] + processChars = + collapseGaps + >>> resolveEscapes + +-- ----------------------------------------------------------------------------- +-- Lexing interface + +{- +Note [Lexing strings] +~~~~~~~~~~~~~~~~~~~~~ + +After verifying if a string is lexically valid with Alex, we still need to do +some post processing of the string, namely: +1. Collapse string gaps +2. Resolve escape characters + +The problem: 'lexemeToString' is more performant than manually reading +characters from the StringBuffer. However, that completely erases the position +of each character, which we need in order to report the correct position for +error messages (e.g. when resolving escape characters). + +So what we'll do is do two passes. The first pass is optimistic; just convert +to a plain String and process it. If this results in an error, we do a second +pass, this time where each character is annotated with its position. Now, the +error has all the information it needs. + +Ideally, lexStringWith would take a single (forall c. HasChar c => ...) function, +but to help the specializer, we pass it in twice to concretize it for the two +types we actually use. +-} + +-- | See Note [Lexing strings] +lexStringWith :: + ([Char] -> Either (Char, LexErr) [Char]) + -> ([CharPos] -> Either (CharPos, LexErr) [CharPos]) + -> Int + -> StringBuffer + -> Either StringLexError String +lexStringWith processChars processCharsPos len buf = + case processChars $ bufferChars buf len of + Right s -> Right s + Left _ -> + case processCharsPos $ bufferLocatedChars buf len of + Right _ -> panic "expected lex error on second pass" + Left ((_, pos), e) -> Left $ StringLexError e pos + +class HasChar c where + getChar :: c -> Char + setChar :: Char -> c -> c + +instance HasChar Char where + getChar = id + setChar = const + +instance HasChar (Char, x) where + getChar = fst + setChar c (_, x) = (c, x) + +pattern Char :: HasChar c => Char -> c +pattern Char c <- (getChar -> c) +{-# COMPLETE Char #-} + +bufferChars :: StringBuffer -> Int -> [Char] +bufferChars = StringBuffer.lexemeToString + +type CharPos = (Char, BufPos) + +bufferLocatedChars :: StringBuffer -> Int -> [CharPos] +bufferLocatedChars initialBuf len = go initialBuf + where + go buf + | atEnd buf = [] + | otherwise = + let (c, buf') = StringBuffer.nextChar buf + in (c, StringBuffer.cur buf) : go buf' + + atEnd buf = StringBuffer.byteDiff initialBuf buf >= len + +-- ----------------------------------------------------------------------------- +-- Lexing phases + +-- | Collapse all string gaps in the given input. +-- +-- Iterates through the input in `go` until we encounter a backslash. The +-- @stringchar Alex regex only allows backslashes in two places: escape codes +-- and string gaps. +-- +-- * If the next character is a space, it has to be the start of a string gap +-- AND it must end, since the @gap Alex regex will only match if it ends. +-- Collapse the gap and continue the main iteration loop. +-- +-- * Otherwise, this is an escape code. If it's an escape code, there are +-- ONLY three possibilities (see the @escape Alex regex): +-- 1. The escape code is "\\" +-- 2. The escape code is "\^\" +-- 3. The escape code does not have a backslash, other than the initial +-- backslash +-- +-- In the first two possibilities, just skip them and continue the main +-- iteration loop ("skip" as in "keep in the list as-is"). In the last one, +-- we can just skip the backslash, then continue the main iteration loop. +-- the rest of the escape code will be skipped as normal characters in the +-- string; no need to fully parse a proper escape code. +collapseGaps :: HasChar c => [c] -> [c] +collapseGaps = go + where + go = \case + -- Match the start of a string gap + drop gap + -- #25784: string gaps are semantically equivalent to "\&" + c1@(Char '\\') : Char c : cs + | is_space c -> c1 : setChar '&' c1 : go (dropGap cs) + -- Match all possible escape characters that include a backslash + c1@(Char '\\') : c2@(Char '\\') : cs + -> c1 : c2 : go cs + c1@(Char '\\') : c2@(Char '^') : c3@(Char '\\') : cs + -> c1 : c2 : c3 : go cs + -- Otherwise, just keep looping + c : cs -> c : go cs + [] -> [] + + dropGap = \case + Char '\\' : cs -> cs + _ : cs -> dropGap cs + -- Unreachable since gaps must end; see docstring + [] -> panic "gap unexpectedly ended" + +resolveEscapes :: HasChar c => [c] -> Either (c, LexErr) [c] +resolveEscapes = go dlistEmpty + where + go !acc = \case + [] -> pure $ dlistToList acc + Char '\\' : Char '&' : cs -> go acc cs + backslash@(Char '\\') : cs -> + case resolveEscapeChar cs of + Right (esc, cs') -> go (acc `dlistSnoc` setChar esc backslash) cs' + Left (c, e) -> Left (c, e) + c : cs -> go (acc `dlistSnoc` c) cs + +-- ----------------------------------------------------------------------------- +-- Escape characters + +-- | Resolve a escape character, after having just lexed a backslash. +-- Assumes escape character is valid. +resolveEscapeChar :: HasChar c => [c] -> Either (c, LexErr) (Char, [c]) +resolveEscapeChar = \case + Char 'a' : cs -> pure ('\a', cs) + Char 'b' : cs -> pure ('\b', cs) + Char 'f' : cs -> pure ('\f', cs) + Char 'n' : cs -> pure ('\n', cs) + Char 'r' : cs -> pure ('\r', cs) + Char 't' : cs -> pure ('\t', cs) + Char 'v' : cs -> pure ('\v', cs) + Char '\\' : cs -> pure ('\\', cs) + Char '"' : cs -> pure ('\"', cs) + Char '\'' : cs -> pure ('\'', cs) + -- escape codes + Char 'x' : cs -> parseNum is_hexdigit 16 hexDigit cs + Char 'o' : cs -> parseNum is_octdigit 8 octDecDigit cs + cs@(Char c : _) | is_decdigit c -> parseNum is_decdigit 10 octDecDigit cs + -- control characters (e.g. '\^M') + Char '^' : Char c : cs -> pure (chr $ ord c - ord '@', cs) + -- long form escapes (e.g. '\NUL') + cs | Just (esc, cs') <- parseLongEscape cs -> pure (esc, cs') + -- shouldn't happen + Char c : _ -> panic $ "found unexpected escape character: " ++ show c + [] -> panic "escape character unexpectedly ended" + where + parseNum isDigit base toDigit = + let go x = \case + ch@(Char c) : cs | isDigit c -> do + let x' = x * base + toDigit c + when (x' > 0x10ffff) $ Left (ch, LexNumEscapeRange) + go x' cs + cs -> pure (chr x, cs) + in go 0 + +parseLongEscape :: HasChar c => [c] -> Maybe (Char, [c]) +parseLongEscape cs = listToMaybe (mapMaybe tryParse longEscapeCodes) + where + tryParse (code, esc) = + case splitAt (length code) cs of + (pre, cs') | map getChar pre == code -> Just (esc, cs') + _ -> Nothing + + longEscapeCodes = + [ ("NUL", '\NUL') + , ("SOH", '\SOH') + , ("STX", '\STX') + , ("ETX", '\ETX') + , ("EOT", '\EOT') + , ("ENQ", '\ENQ') + , ("ACK", '\ACK') + , ("BEL", '\BEL') + , ("BS" , '\BS' ) + , ("HT" , '\HT' ) + , ("LF" , '\LF' ) + , ("VT" , '\VT' ) + , ("FF" , '\FF' ) + , ("CR" , '\CR' ) + , ("SO" , '\SO' ) + , ("SI" , '\SI' ) + , ("DLE", '\DLE') + , ("DC1", '\DC1') + , ("DC2", '\DC2') + , ("DC3", '\DC3') + , ("DC4", '\DC4') + , ("NAK", '\NAK') + , ("SYN", '\SYN') + , ("ETB", '\ETB') + , ("CAN", '\CAN') + , ("EM" , '\EM' ) + , ("SUB", '\SUB') + , ("ESC", '\ESC') + , ("FS" , '\FS' ) + , ("GS" , '\GS' ) + , ("RS" , '\RS' ) + , ("US" , '\US' ) + , ("SP" , '\SP' ) + , ("DEL", '\DEL') + ] + +-- ----------------------------------------------------------------------------- +-- Unicode Smart Quote detection (#21843) + +isDoubleSmartQuote :: Char -> Bool +isDoubleSmartQuote = \case + '“' -> True + '”' -> True + _ -> False + +isSingleSmartQuote :: Char -> Bool +isSingleSmartQuote = \case + '‘' -> True + '’' -> True + _ -> False + +-- ----------------------------------------------------------------------------- +-- Multiline strings + +-- | See Note [Multiline string literals] +-- +-- Assumes string is lexically valid. Skips the steps about splitting +-- and rejoining lines, and instead manually find newline characters, +-- for performance. +lexMultilineString :: Int -> StringBuffer -> Either StringLexError String +lexMultilineString = lexStringWith processChars processChars + where + processChars :: HasChar c => [c] -> Either (c, LexErr) [c] + processChars = + collapseGaps -- Step 1 + >>> normalizeEOL + >>> expandLeadingTabs -- Step 3 + >>> rmCommonWhitespacePrefix -- Step 4 + >>> collapseOnlyWsLines -- Step 5 + >>> rmFirstNewline -- Step 7a + >>> rmLastNewline -- Step 7b + >>> resolveEscapes -- Step 8 + + -- Normalize line endings to LF. The spec dictates that lines should be + -- split on newline characters and rejoined with ``\n``. But because we + -- aren't actually splitting/rejoining, we'll manually normalize here + normalizeEOL :: HasChar c => [c] -> [c] + normalizeEOL = + let go = \case + Char '\r' : c@(Char '\n') : cs -> c : go cs + c@(Char '\r') : cs -> setChar '\n' c : go cs + c@(Char '\f') : cs -> setChar '\n' c : go cs + c : cs -> c : go cs + [] -> [] + in go + + -- expands all tabs, since the lexer will verify that tabs can only appear + -- as leading indentation + expandLeadingTabs :: HasChar c => [c] -> [c] + expandLeadingTabs = + let go !col = \case + c@(Char '\t') : cs -> + let fill = 8 - (col `mod` 8) + in replicate fill (setChar ' ' c) ++ go (col + fill) cs + c : cs -> c : go (if getChar c == '\n' then 0 else col + 1) cs + [] -> [] + in go 0 + + rmCommonWhitespacePrefix :: HasChar c => [c] -> [c] + rmCommonWhitespacePrefix cs0 = + let commonWSPrefix = getCommonWsPrefix (map getChar cs0) + go = \case + c@(Char '\n') : cs -> c : go (dropLine commonWSPrefix cs) + c : cs -> c : go cs + [] -> [] + -- drop x characters from the string, or up to a newline, whichever + -- comes first + dropLine !x = \case + cs | x <= 0 -> cs + cs@(Char '\n' : _) -> cs + _ : cs -> dropLine (x - 1) cs + [] -> [] + in go cs0 + + collapseOnlyWsLines :: HasChar c => [c] -> [c] + collapseOnlyWsLines = + let go = \case + c@(Char '\n') : cs | Just cs' <- checkAllWs cs -> c : go cs' + c : cs -> c : go cs + [] -> [] + checkAllWs = \case + -- got all the way to a newline or the end of the string, return + cs@(Char '\n' : _) -> Just cs + cs@[] -> Just cs + -- found whitespace, continue + Char c : cs | is_space c -> checkAllWs cs + -- anything else, stop + _ -> Nothing + in go + + rmFirstNewline :: HasChar c => [c] -> [c] + rmFirstNewline = \case + Char '\n' : cs -> cs + cs -> cs + + rmLastNewline :: HasChar c => [c] -> [c] + rmLastNewline = + let go = \case + [] -> [] + [Char '\n'] -> [] + c : cs -> c : go cs + in go + +-- | See step 4 in Note [Multiline string literals] +-- +-- Assumes tabs have already been expanded. +getCommonWsPrefix :: String -> Int +getCommonWsPrefix s = + case NonEmpty.nonEmpty includedLines of + Nothing -> 0 + Just ls -> Foldable1.minimum $ NonEmpty.map (length . takeWhile is_space) ls + where + includedLines = + filter (not . all is_space) -- ignore whitespace-only lines + . drop 1 -- ignore first line in calculation + $ lines s + +{- +Note [Multiline string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Multiline string literals were added following the acceptance of the +proposal: https://github.com/ghc-proposals/ghc-proposals/pull/569 + +Multiline string literals are syntax sugar for normal string literals, +with an extra post processing step. This all happens in the Lexer; that +is, HsMultilineString will contain the post-processed string. This matches +the same behavior as HsString, which contains the normalized string +(see Note [Literal source text]). + +The canonical steps for post processing a multiline string are: +1. Collapse string gaps +2. Split the string by newlines +3. Convert leading tabs into spaces + * In each line, any tabs preceding non-whitespace characters are replaced with spaces up to the next tab stop +4. Remove common whitespace prefix in every line except the first (see below) +5. If a line contains only whitespace, remove all of the whitespace +6. Join the string back with `\n` delimiters +7a. If the first character of the string is a newline, remove it +7b. If the last character of the string is a newline, remove it +8. Interpret escaped characters + +The common whitespace prefix can be informally defined as "The longest +prefix of whitespace shared by all lines in the string, excluding the +first line and any whitespace-only lines". + +It's more precisely defined with the following algorithm: + +1. Take a list representing the lines in the string +2. Ignore the following elements in the list: + * The first line (we want to ignore everything before the first newline) + * Empty lines + * Lines with only whitespace characters +3. Calculate the longest prefix of whitespace shared by all lines in the remaining list +-} + +-- ----------------------------------------------------------------------------- +-- DList + +newtype DList a = DList ([a] -> [a]) + +dlistEmpty :: DList a +dlistEmpty = DList id + +dlistToList :: DList a -> [a] +dlistToList (DList f) = f [] + +dlistSnoc :: DList a -> a -> DList a +dlistSnoc (DList f) x = DList (f . (x :)) diff --git a/GHC/Parser/Types.hs b/GHC/Parser/Types.hs --- a/GHC/Parser/Types.hs +++ b/GHC/Parser/Types.hs @@ -8,6 +8,7 @@ , pprSumOrTuple , PatBuilder(..) , DataConBuilder(..) + , ExplicitNamespaceKeyword(..) ) where @@ -27,9 +28,9 @@ import Language.Haskell.Syntax data SumOrTuple b - = Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation] + = Sum ConTag Arity (LocatedA b) [EpToken "|"] [EpToken "|"] -- ^ Last two are the locations of the '|' before and after the payload - | Tuple [Either (EpAnn EpaLocation) (LocatedA b)] + | Tuple [Either (EpAnn Bool) (LocatedA b)] pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc pprSumOrTuple boxity = \case @@ -53,17 +54,17 @@ -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p = PatBuilderPat (Pat p) - | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p) + | PatBuilderPar (EpToken "(") (LocatedA (PatBuilder p)) (EpToken ")") | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) - | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs) + | PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) - (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) + (LocatedA (PatBuilder p)) ([EpToken "("], [EpToken ")"]) | PatBuilderVar (LocatedN RdrName) | PatBuilderOverLit (HsOverLit GhcPs) -- These instances are here so that they are not orphans -type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns -type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL +type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = EpAnnCO +type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA @@ -110,4 +111,8 @@ ppr (InfixDataConBuilder lhs data_con rhs) = ppr lhs <+> ppr data_con <+> ppr rhs -type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL +type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW + +data ExplicitNamespaceKeyword + = ExplicitTypeNamespace !(EpToken "type") + | ExplicitDataNamespace !(EpToken "data") diff --git a/GHC/Platform.hs b/GHC/Platform.hs --- a/GHC/Platform.hs +++ b/GHC/Platform.hs @@ -17,6 +17,7 @@ , ByteOrder(..) , target32Bit , isARM + , isPPC , osElfTarget , osMachOTarget , osSubsectionsViaSymbols @@ -74,12 +75,15 @@ , platformHasGnuNonexecStack :: !Bool , platformHasIdentDirective :: !Bool , platformHasSubsectionsViaSymbols :: !Bool + -- ^ Enable Darwin .subsections_via_symbols directive + -- + -- See Note [Subsections Via Symbols] in GHC.CmmToAsm.X86.Ppr , platformIsCrossCompiling :: !Bool , platformLeadingUnderscore :: !Bool -- ^ Symbols need underscore prefix , platformTablesNextToCode :: !Bool -- ^ Determines whether we will be compiling info tables that reside just -- before the entry code, or with an indirection to the entry code. See - -- TABLES_NEXT_TO_CODE in rts/include/rts/storage/InfoTables.h. + -- TABLES_NEXT_TO_CODE in @rts/include/rts/storage/InfoTables.h@. , platformHasLibm :: !Bool -- ^ Some platforms require that we explicitly link against @libm@ if any -- math-y things are used (which we assume to include all programs). See @@ -180,11 +184,6 @@ platformOS platform = case platformArchOS platform of ArchOS _ os -> os -isARM :: Arch -> Bool -isARM (ArchARM {}) = True -isARM ArchAArch64 = True -isARM _ = False - -- | This predicate tells us whether the platform is 32-bit. target32Bit :: Platform -> Bool target32Bit p = @@ -192,34 +191,6 @@ PW4 -> True PW8 -> False --- | This predicate tells us whether the OS supports ELF-like shared libraries. -osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSDragonFly = True -osElfTarget OSOpenBSD = True -osElfTarget OSNetBSD = True -osElfTarget OSSolaris2 = True -osElfTarget OSDarwin = False -osElfTarget OSMinGW32 = False -osElfTarget OSKFreeBSD = True -osElfTarget OSHaiku = True -osElfTarget OSQNXNTO = False -osElfTarget OSAIX = False -osElfTarget OSHurd = True -osElfTarget OSWasi = False -osElfTarget OSGhcjs = False -osElfTarget OSUnknown = False - -- Defaulting to False is safe; it means don't rely on any - -- ELF-specific functionality. It is important to have a default for - -- portability, otherwise we have to answer this question for every - -- new platform we compile on (even unreg). - --- | This predicate tells us whether the OS support Mach-O shared libraries. -osMachOTarget :: OS -> Bool -osMachOTarget OSDarwin = True -osMachOTarget _ = False - osUsesFrameworks :: OS -> Bool osUsesFrameworks OSDarwin = True osUsesFrameworks _ = False @@ -283,10 +254,8 @@ ArchPPC_64 ELF_V1 -> False -- powerpc64 ArchPPC_64 ELF_V2 -> False -- powerpc64le ArchS390X -> False - ArchRISCV64 -> False ArchLoongArch64 -> False ArchJavaScript -> False - ArchWasm32 -> False _ -> True @@ -300,6 +269,7 @@ = SSE1 | SSE2 | SSE3 + | SSSE3 | SSE4 | SSE42 deriving (Eq, Ord) @@ -320,6 +290,7 @@ , platformMisc_ghcWithInterpreter :: Bool , platformMisc_libFFI :: Bool , platformMisc_llvmTarget :: String + , platformMisc_targetRTSLinkerOnlySupportsSharedLibs :: Bool } platformSOName :: Platform -> FilePath -> FilePath diff --git a/GHC/Platform/LA64.hs b/GHC/Platform/LA64.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/LA64.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.LA64 where + +import GHC.Prelude + +#define MACHREGS_NO_REGS 0 +#define MACHREGS_loongarch64 1 +#include "CodeGen.Platform.h" diff --git a/GHC/Platform/LoongArch64.hs b/GHC/Platform/LoongArch64.hs deleted file mode 100644 --- a/GHC/Platform/LoongArch64.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE CPP #-} - -module GHC.Platform.LoongArch64 where - -import GHC.Prelude - -#define MACHREGS_NO_REGS 0 -#define MACHREGS_loongarch64 1 -#include "CodeGen.Platform.h" diff --git a/GHC/Platform/Reg.hs b/GHC/Platform/Reg.hs --- a/GHC/Platform/Reg.hs +++ b/GHC/Platform/Reg.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash #-} + -- | An architecture independent description of a register. -- This needs to stay architecture independent because it is used -- by NCGMonad and the register allocators, which are shared @@ -27,12 +29,17 @@ where import GHC.Prelude +import GHC.Exts ( Int(I#), dataToTag# ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Unique import GHC.Builtin.Uniques 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.Platform.ArchOS -- | An identifier for a primitive real machine register. type RegNo @@ -53,72 +60,68 @@ -- Virtual regs can be of either class, so that info is attached. -- data VirtualReg - = VirtualRegI {-# UNPACK #-} !Unique - | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register - | VirtualRegF {-# UNPACK #-} !Unique - | VirtualRegD {-# UNPACK #-} !Unique - - deriving (Eq, Show) + -- | Integer virtual register + = VirtualRegI { virtualRegUnique :: {-# UNPACK #-} !Unique } + -- | High part of 2-word virtual register + | VirtualRegHi { virtualRegUnique :: {-# UNPACK #-} !Unique } + -- | Double virtual register + | VirtualRegD { virtualRegUnique :: {-# UNPACK #-} !Unique } + -- | 128-bit wide vector virtual register + | VirtualRegV128 { virtualRegUnique :: {-# UNPACK #-} !Unique } + deriving (Eq, Show) --- This is laborious, but necessary. We can't derive Ord because --- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the --- implementation. See Note [No Ord for Unique] +-- We can't derive Ord, because Unique doesn't have an Ord instance. +-- Note nonDetCmpUnique in the implementation. See Note [No Ord for Unique]. -- This is non-deterministic but we do not currently support deterministic -- code-generation. See Note [Unique Determinism and code generation] instance Ord VirtualReg where - compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b - compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b - compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b - compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b - - compare VirtualRegI{} _ = LT - compare _ VirtualRegI{} = GT - compare VirtualRegHi{} _ = LT - compare _ VirtualRegHi{} = GT - compare VirtualRegF{} _ = LT - compare _ VirtualRegF{} = GT - - + compare vr1 vr2 = + case compare (I# (dataToTag# vr1)) (I# (dataToTag# vr2)) of + LT -> LT + GT -> GT + EQ -> nonDetCmpUnique (virtualRegUnique vr1) (virtualRegUnique vr2) instance Uniquable VirtualReg where - getUnique reg - = case reg of - VirtualRegI u -> u - VirtualRegHi u -> u - VirtualRegF u -> u - VirtualRegD u -> u + getUnique = virtualRegUnique instance Outputable VirtualReg where ppr reg = case reg of - VirtualRegI u -> text "%vI_" <> pprUniqueAlways u - VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u - -- this code is kinda wrong on x86 - -- because float and double occupy the same register set - -- namely SSE2 register xmm0 .. xmm15 - VirtualRegF u -> text "%vFloat_" <> pprUniqueAlways u - VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u - + VirtualRegI u -> text "%vI_" <> pprUniqueAlways u + VirtualRegHi u -> text "%vHi_" <> pprUniqueAlways u + VirtualRegD u -> text "%vDouble_" <> pprUniqueAlways u + VirtualRegV128 u -> text "%vV128_" <> pprUniqueAlways u renameVirtualReg :: Unique -> VirtualReg -> VirtualReg -renameVirtualReg u r - = case r of - VirtualRegI _ -> VirtualRegI u - VirtualRegHi _ -> VirtualRegHi u - VirtualRegF _ -> VirtualRegF u - VirtualRegD _ -> VirtualRegD u - - -classOfVirtualReg :: VirtualReg -> RegClass -classOfVirtualReg vr - = case vr of - VirtualRegI{} -> RcInteger - VirtualRegHi{} -> RcInteger - VirtualRegF{} -> RcFloat - VirtualRegD{} -> RcDouble - +renameVirtualReg u r = r { virtualRegUnique = u } +classOfVirtualReg :: Arch -> VirtualReg -> RegClass +classOfVirtualReg arch vr + = case vr of + VirtualRegI{} -> + case regArch of + Unified -> Unified.RcInteger + Separate -> Separate.RcInteger + NoVectors -> NoVectors.RcInteger + VirtualRegHi{} -> + case regArch of + Unified -> Unified.RcInteger + Separate -> Separate.RcInteger + NoVectors -> NoVectors.RcInteger + VirtualRegD{} -> + case regArch of + Unified -> Unified.RcFloatOrVector + Separate -> Separate.RcFloat + NoVectors -> NoVectors.RcFloat + VirtualRegV128{} -> + case regArch of + Unified -> Unified.RcFloatOrVector + Separate -> Separate.RcVector + NoVectors -> pprPanic "classOfVirtualReg VirtualRegV128" + ( text "arch:" <+> text ( show arch ) ) + where + regArch = registerArch arch -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform -- when supplied with the vreg for the lower-half of the quantity. diff --git a/GHC/Platform/Reg/Class.hs b/GHC/Platform/Reg/Class.hs --- a/GHC/Platform/Reg/Class.hs +++ b/GHC/Platform/Reg/Class.hs @@ -1,33 +1,56 @@ --- | An architecture independent description of a register's class. +{-# LANGUAGE LambdaCase #-} module GHC.Platform.Reg.Class - ( RegClass (..) ) - + ( RegClass (..), RegArch(..), registerArch ) where import GHC.Prelude -import GHC.Utils.Outputable as Outputable import GHC.Types.Unique -import GHC.Builtin.Uniques +import GHC.Builtin.Uniques ( mkRegClassUnique ) +import GHC.Platform.ArchOS +import GHC.Utils.Outputable ( Outputable(ppr), text ) -- | The class of a register. -- Used in the register allocator. -- We treat all registers in a class as being interchangeable. -- -data RegClass - = RcInteger - | RcFloat - | RcDouble - deriving Eq - +newtype RegClass = RegClass Int + deriving ( Eq, Ord, Show ) instance Uniquable RegClass where - getUnique RcInteger = mkRegClassUnique 0 - getUnique RcFloat = mkRegClassUnique 1 - getUnique RcDouble = mkRegClassUnique 2 + getUnique ( RegClass i ) = mkRegClassUnique i +-- | This instance is just used for the graph colouring register allocator. +-- Prefer using either 'GHC.Platform.Reg.Class.Separate.pprRegClass' +-- or 'GHC.Platform.Reg.Class.Unified.pprRegClass', which is more informative. instance Outputable RegClass where - ppr RcInteger = Outputable.text "I" - ppr RcFloat = Outputable.text "F" - ppr RcDouble = Outputable.text "D" + ppr (RegClass i) = ppr i + +-- | The register architecture of a given machine. +data RegArch + -- | Floating-point and vector registers are unified (e.g. X86, AArch64). + = Unified + -- | Floating-point and vector registers are separate (e.g. RISC-V). + | Separate + -- | No vector registers. + | NoVectors + deriving ( Eq, Ord, Show ) + +instance Outputable RegArch where + ppr regArch = text (show regArch) + +-- | What is the register architecture of the given architecture? +registerArch :: Arch -> RegArch +registerArch arch = + case arch of + ArchX86 -> Unified + ArchX86_64 -> Unified + ArchPPC -> Unified + ArchPPC_64 {} -> Unified + ArchAArch64 -> Unified + -- Support for vector registers not yet implemented for RISC-V + -- see panic in `getFreeRegs`. + --ArchRISCV64 -> Separate + ArchRISCV64 -> NoVectors + _ -> NoVectors diff --git a/GHC/Platform/Reg/Class/NoVectors.hs b/GHC/Platform/Reg/Class/NoVectors.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class/NoVectors.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Register classes for architectures which don't have any vector registers. +module GHC.Platform.Reg.Class.NoVectors + ( RegClass ( RcInteger, RcFloat ) + , pprRegClass, allRegClasses + ) + +where + +import GHC.Utils.Outputable ( SDoc, text ) +import GHC.Platform.Reg.Class ( RegClass(..) ) + +pattern RcInteger, RcFloat :: RegClass +pattern RcInteger = RegClass 0 +pattern RcFloat = RegClass 1 +{-# COMPLETE RcInteger, RcFloat #-} + +pprRegClass :: RegClass -> SDoc +pprRegClass = \case + RcInteger -> text "I" + RcFloat -> text "F" + +allRegClasses :: [RegClass] +allRegClasses = [RcInteger, RcFloat] diff --git a/GHC/Platform/Reg/Class/Separate.hs b/GHC/Platform/Reg/Class/Separate.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class/Separate.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Register classes for architectures which have registers +-- for scalar floating-point values that are separate from all vector registers. +module GHC.Platform.Reg.Class.Separate + ( RegClass ( RcInteger, RcFloat, RcVector ) + , pprRegClass, allRegClasses + ) + +where + +import GHC.Utils.Outputable ( SDoc, text ) +import GHC.Platform.Reg.Class ( RegClass(..) ) + +pattern RcInteger, RcFloat, RcVector :: RegClass +pattern RcInteger = RegClass 0 +pattern RcFloat = RegClass 1 +pattern RcVector = RegClass 2 +{-# COMPLETE RcInteger, RcFloat, RcVector #-} + +pprRegClass :: RegClass -> SDoc +pprRegClass = \case + RcInteger -> text "I" + RcFloat -> text "F" + RcVector -> text "V" + +allRegClasses :: [RegClass] +allRegClasses = [RcInteger, RcFloat, RcVector] diff --git a/GHC/Platform/Reg/Class/Unified.hs b/GHC/Platform/Reg/Class/Unified.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/Reg/Class/Unified.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Register classes for architectures which don't have separate registers +-- for scalar floating-point values separate from vector registers. +module GHC.Platform.Reg.Class.Unified + ( RegClass ( RcInteger, RcFloatOrVector ) + , pprRegClass, allRegClasses + ) + +where + +import GHC.Utils.Outputable ( SDoc, text ) +import GHC.Platform.Reg.Class ( RegClass(..) ) + +pattern RcInteger, RcFloatOrVector :: RegClass +pattern RcInteger = RegClass 0 +pattern RcFloatOrVector = RegClass 1 +{-# COMPLETE RcInteger, RcFloatOrVector #-} + +pprRegClass :: RegClass -> SDoc +pprRegClass = \case + RcInteger -> text "I" + RcFloatOrVector -> text "F" + +allRegClasses :: [RegClass] +allRegClasses = [RcInteger, RcFloatOrVector] diff --git a/GHC/Platform/Regs.hs b/GHC/Platform/Regs.hs --- a/GHC/Platform/Regs.hs +++ b/GHC/Platform/Regs.hs @@ -16,7 +16,7 @@ import qualified GHC.Platform.X86_64 as X86_64 import qualified GHC.Platform.RISCV64 as RISCV64 import qualified GHC.Platform.Wasm32 as Wasm32 -import qualified GHC.Platform.LoongArch64 as LoongArch64 +import qualified GHC.Platform.LA64 as LA64 import qualified GHC.Platform.NoRegs as NoRegs -- | Returns 'True' if this global register is stored in a caller-saves @@ -34,7 +34,7 @@ ArchAArch64 -> AArch64.callerSaves ArchRISCV64 -> RISCV64.callerSaves ArchWasm32 -> Wasm32.callerSaves - ArchLoongArch64 -> LoongArch64.callerSaves + ArchLoongArch64 -> LA64.callerSaves arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.callerSaves @@ -58,7 +58,7 @@ ArchAArch64 -> AArch64.activeStgRegs ArchRISCV64 -> RISCV64.activeStgRegs ArchWasm32 -> Wasm32.activeStgRegs - ArchLoongArch64 -> LoongArch64.activeStgRegs + ArchLoongArch64 -> LA64.activeStgRegs arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.activeStgRegs @@ -77,7 +77,7 @@ ArchAArch64 -> AArch64.haveRegBase ArchRISCV64 -> RISCV64.haveRegBase ArchWasm32 -> Wasm32.haveRegBase - ArchLoongArch64 -> LoongArch64.haveRegBase + ArchLoongArch64 -> LA64.haveRegBase arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.haveRegBase @@ -96,7 +96,7 @@ ArchAArch64 -> AArch64.globalRegMaybe ArchRISCV64 -> RISCV64.globalRegMaybe ArchWasm32 -> Wasm32.globalRegMaybe - ArchLoongArch64 -> LoongArch64.globalRegMaybe + ArchLoongArch64 -> LA64.globalRegMaybe arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.globalRegMaybe @@ -112,10 +112,21 @@ ArchX86_64 -> X86_64.freeReg ArchS390X -> S390X.freeReg ArchARM {} -> ARM.freeReg - ArchAArch64 -> AArch64.freeReg + ArchAArch64 -> + -- See Note [Aarch64 Register x18 at Darwin and Windows]. + -- It already has `freeReg 18 = False` but that line does not work for cross-compile when + -- we use host not from the list (darwin_HOST_OS, ios_HOST_OS, mingw32_HOST_OS) i.e. Linux + if platformOS platform == OSMinGW32 || platformOS platform == OSDarwin + then + let + x18Check :: RegNo -> Bool + x18Check 18 = False + x18Check a = AArch64.freeReg a + in x18Check + else AArch64.freeReg ArchRISCV64 -> RISCV64.freeReg ArchWasm32 -> Wasm32.freeReg - ArchLoongArch64 -> LoongArch64.freeReg + ArchLoongArch64 -> LA64.freeReg arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.freeReg diff --git a/GHC/Platform/Ways.hs b/GHC/Platform/Ways.hs --- a/GHC/Platform/Ways.hs +++ b/GHC/Platform/Ways.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} -- | Ways -- @@ -31,6 +30,7 @@ , wayGeneralFlags , wayUnsetGeneralFlags , wayOptc + , wayOptcxx , wayOptl , wayOptP , wayDesc @@ -177,6 +177,9 @@ wayOptc _ WayDyn = [] wayOptc _ WayProf = ["-DPROFILING"] +wayOptcxx :: Platform -> Way -> [String] +wayOptcxx = wayOptc -- Use the same flags as C + -- | Pass these options to linker when enabling this way wayOptl :: Platform -> Way -> [String] wayOptl _ (WayCustom {}) = [] @@ -216,8 +219,6 @@ foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int --- we need this until the bootstrap GHC is always recent enough -#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) -- | Consult the RTS to find whether it is threaded. hostIsThreaded :: Bool @@ -238,18 +239,6 @@ foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int -#else - -hostIsThreaded :: Bool -hostIsThreaded = False - -hostIsDebugged :: Bool -hostIsDebugged = False - -hostIsTracing :: Bool -hostIsTracing = False - -#endif -- | Host ways. diff --git a/GHC/Plugins.hs b/GHC/Plugins.hs --- a/GHC/Plugins.hs +++ b/GHC/Plugins.hs @@ -156,7 +156,7 @@ import GHC.Types.Error ( Messages ) import GHC.Hs ( HsParsedModule ) -import qualified Language.Haskell.TH as TH +import qualified GHC.Boot.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 -} @@ -202,7 +202,8 @@ -- ensures everything in that session will get the same name cache. thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name) thNameToGhcNameIO cache th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + = do { let listTuplePuns = True -- conservative assumption + ; names <- mapMaybeM lookup (thRdrNameGuesses listTuplePuns th_name) -- Pick the first that works -- E.g. reify (mkName "A") will pick the class A in preference -- to the data constructor A diff --git a/GHC/Prelude/Basic.hs b/GHC/Prelude/Basic.hs --- a/GHC/Prelude/Basic.hs +++ b/GHC/Prelude/Basic.hs @@ -13,16 +13,20 @@ -- Every module in GHC -- * Is compiled with -XNoImplicitPrelude --- * Explicitly imports GHC.BasicPrelude or GHC.Prelude +-- * Explicitly imports GHC.Prelude.Basic or GHC.Prelude -- * The later provides some functionality with within ghc itself -- like pprTrace. module GHC.Prelude.Basic - (module X - ,Applicative (..) - ,module Bits - ,shiftL, shiftR - ,head, tail + ( module X + , Applicative (..) + , module Bits + , bit + , shiftL, shiftR + , setBit, clearBit + , head, tail, unzip + + , strictGenericLength ) where @@ -55,30 +59,25 @@ -} import qualified Prelude -import Prelude as X hiding ((<>), Applicative(..), head, tail) +import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail, unzip) import Control.Applicative (Applicative(..)) -import Data.Foldable as X (foldl') +import Data.Foldable as X (Foldable (elem, foldMap, foldl, foldl', foldr, length, null, product, sum)) +import Data.Foldable1 as X hiding (head, last) +import qualified Data.List as List +import qualified GHC.Data.List.NonEmpty as NE import GHC.Stack.Types (HasCallStack) -#if MIN_VERSION_base(4,16,0) -import GHC.Bits as Bits hiding (shiftL, shiftR) +import GHC.Bits as Bits hiding (bit, shiftL, shiftR, setBit, clearBit) # if defined(DEBUG) import qualified GHC.Bits as Bits (shiftL, shiftR) # endif -#else ---base <4.15 -import Data.Bits as Bits hiding (shiftL, shiftR) -# if defined(DEBUG) -import qualified Data.Bits as Bits (shiftL, shiftR) -# endif -#endif {- Note [Default to unsafe shifts inside GHC] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The safe shifts can introduce branches which come at the cost of performance. We still want the additional -debugability for debug builds. So we define it as one or the +debuggability for debug builds. So we define it as one or the other depending on the DEBUG setting. Why do we then continue on to re-export the rest of Data.Bits? @@ -109,6 +108,16 @@ shiftR = Bits.unsafeShiftR #endif +{-# INLINE bit #-} +bit :: (Num a, Bits.Bits a) => Int -> a +bit = \ i -> 1 `shiftL` i +{-# INLINE setBit #-} +setBit :: (Num a, Bits.Bits a) => a -> Int -> a +setBit = \ x i -> x Bits..|. bit i +{-# INLINE clearBit #-} +clearBit :: (Num a, Bits.Bits a) => a -> Int -> a +clearBit = \ x i -> x Bits..&. Bits.complement (bit i) + {- Note [Proxies for head and tail] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Prelude.head and Prelude.tail have recently acquired {-# WARNING in "x-partial" #-}, @@ -126,3 +135,22 @@ tail :: HasCallStack => [a] -> [a] tail = Prelude.tail {-# INLINE tail #-} + +{- | +The 'genericLength' function defined in base can't be specialised due to the +NOINLINE pragma. + +It is also not strict in the accumulator, and strictGenericLength is not exported. + +See #25706 for why it is important to use a strict, specialised version. + +-} +strictGenericLength :: Num a => [x] -> a +strictGenericLength = fromIntegral . length + +-- This is `Data.Functor.unzip`. Unfortunately, that function lacks the RULES for specialization. +unzip :: Functor f => f (a, b) -> (f a, f b) +unzip = \ xs -> (fmap fst xs, fmap snd xs) +{-# NOINLINE [1] unzip #-} +{-# RULES "unzip/List" unzip = List.unzip #-} +{-# RULES "unzip/NonEmpty" unzip = NE.unzip #-} diff --git a/GHC/Rename/Bind.hs b/GHC/Rename/Bind.hs --- a/GHC/Rename/Bind.hs +++ b/GHC/Rename/Bind.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -23,13 +20,16 @@ rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, -- Other bindings - rnMethodBinds, renameSigs, + rnMethodBinds, renameSigs, bindRuleBndrs, rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, - makeMiniFixityEnv, MiniFixityEnv, + makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv, HsSigCtxt(..), -- Utility for hs-boot files - rejectBootDecls + rejectBootDecls, + + -- Utility for COMPLETE pragmas + localCompletePragmas ) where import GHC.Prelude @@ -44,33 +44,37 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( mapFvRn - , checkDupRdrNames - , warnUnusedLocalBinds - , warnForallIdentifier - , checkUnusedRecordWildcard - , checkDupAndShadowedNames, bindLocalNamesFV - , addNoNestedForallsContextsErr, checkInferredVars ) +import GHC.Rename.Utils import GHC.Driver.DynFlags -import GHC.Unit.Module + +import GHC.Data.BooleanFormula ( bfTraverse ) +import GHC.Data.Graph.Directed ( SCC(..) ) +import GHC.Data.Maybe ( orElse, mapMaybe ) +import GHC.Data.OrdList +import GHC.Data.List.SetOps ( findDupsEq ) + + import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Types.Name.Reader ( RdrName, rdrNameOcc ) +import GHC.Types.Name.Reader import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Data.List.SetOps ( findDupsEq ) import GHC.Types.Basic ( RecFlag(..), TypeOrKind(..) ) -import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Data.Bag + +import GHC.Types.CompleteMatch +import GHC.Types.Hint ( SigLike(..) ) +import GHC.Types.Unique.DSet ( mkUniqDSet ) +import GHC.Types.Unique.Set + +import GHC.Unit.Module + import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Unique.Set -import GHC.Data.Maybe ( orElse ) -import GHC.Data.OrdList + import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -203,8 +207,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 @@ -312,7 +316,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 @@ -330,7 +334,13 @@ 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 + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags }) $ + do { binds_w_dus <- mapM (rnLBind (mkScopedTvFn sigs')) mbinds ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ @@ -348,7 +358,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) @@ -397,7 +407,7 @@ -- Insert fake uses for variables introduced implicitly by -- wildcards (#4404) rec_uses = hsValBindsImplicits binds' - implicit_uses = mkNameSet $ concatMap snd + implicit_uses = mkNameSet $ concatMap (concatMap implFlBndr_binders . snd) $ rec_uses ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc real_uses (Just ns)) @@ -443,11 +453,12 @@ -- (i.e., any free variables of the pattern) -> RnM (HsBindLR GhcRn GhcPs) -rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat, pat_mult = pat_mult }) = do -- we don't actually use the FV processing of rnPatsAndThen here (pat',pat'_fvs) <- rnBindPat name_maker pat - return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) + (pat_mult', mult'_fvs) <- rnHsMultAnnWith (rnLHsType PatCtx) pat_mult + return (bind { pat_lhs = pat', pat_ext = pat'_fvs `plusFV` mult'_fvs, pat_mult = pat_mult' }) -- We temporarily store the pat's FVs in bind_fvs; -- gets updated to the FVs of the whole bind -- when doing the RHS below @@ -459,9 +470,9 @@ rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker - = do { addLocMA checkConName rdrname + = do { addLocM checkConName rdrname ; name <- - lookupLocatedTopConstructorRnN rdrname -- Should be in scope already + lookupLocatedTopBndrRnN WL_ConLike rdrname -- Should be in scope already ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) } | otherwise -- Pattern synonym, not at top level @@ -521,7 +532,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' @@ -571,9 +582,10 @@ -- Recursive cases BangPat _ lp -> lpatternContainsSplice lp LazyPat _ lp -> lpatternContainsSplice lp - AsPat _ _ _ lp -> lpatternContainsSplice lp - ParPat _ _ lp _ -> lpatternContainsSplice lp + 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 @@ -581,6 +593,12 @@ ConPat _ _ cpd -> any lpatternContainsSplice (hsConPatArgs cpd) XPat (HsPatExpanded _orig new) -> patternContainsSplice new + -- The behavior of this case is unimportant, as GHC will throw an error shortly + -- after reaching this case for other reasons (see TcRnIllegalTypePattern). + EmbTyPat{} -> True + + InvisPat{} -> True + {- Note [Pattern bindings that bind no variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally, we want to warn about pattern bindings like @@ -614,7 +632,7 @@ The reason is that trim is sometimes something like \xs -> intersectNameSet (mkNameSet bound_names) xs and we don't want to retain the list bound_names. This showed up in -trac ticket #1136. +ticket #1136. -} {- ********************************************************************* @@ -623,7 +641,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 @@ -634,10 +652,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) @@ -684,30 +702,48 @@ makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv -makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls +makeMiniFixityEnv decls = foldlM add_one_sig emptyMiniFixityEnv decls where add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv - add_one_sig env (L loc (FixitySig _ names fixity)) = - foldlM add_one env [ (locA loc,locA name_loc,name,fixity) + add_one_sig env (L loc (FixitySig ns_spec names fixity)) = + foldlM add_one env [ (locA loc,locA name_loc,name,fixity, ns_spec) | L name_loc name <- names ] - add_one env (loc, name_loc, name,fixity) = do + add_one env (loc, name_loc, name, fixity, ns_spec) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because -- definitions of non-local will be caught elsewhere) let { fs = occNameFS (rdrNameOcc name) - ; fix_item = L loc fixity }; + ; fix_item = L loc fixity}; - case lookupFsEnv env fs of - Nothing -> return $ extendFsEnv env fs fix_item + case search_for_dups ns_spec env fs of + Nothing -> return $ extend_mini_fixity_env ns_spec env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ addErrAt name_loc (TcRnMultipleFixityDecls loc' name) ; return env} } + search_for_dups ns_spec MFE{mfe_data_level_names, mfe_type_level_names} fs + = case ns_spec of + NoNamespaceSpecifier -> case lookupFsEnv mfe_data_level_names fs of + -- We only need to find a single duplicate to emit an error about + -- multiple fixity decls. Therefore, if we find a duplicate in the + -- term-level namespace, then there is no need to look in the type-level namespace. + Nothing -> lookupFsEnv mfe_type_level_names fs + just_dup -> just_dup + TypeNamespaceSpecifier{} -> lookupFsEnv mfe_type_level_names fs + DataNamespaceSpecifier{} -> lookupFsEnv mfe_data_level_names fs + extend_mini_fixity_env ns_spec env@MFE{mfe_data_level_names, mfe_type_level_names} fs fix_item + = case ns_spec of + NoNamespaceSpecifier -> MFE { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item) + , mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)} + TypeNamespaceSpecifier{} -> env { mfe_type_level_names = (extendFsEnv mfe_type_level_names fs fix_item)} + + DataNamespaceSpecifier{} -> env { mfe_data_level_names = (extendFsEnv mfe_data_level_names fs fix_item)} + {- ********************************************************************* * * Pattern synonym bindings @@ -732,10 +768,10 @@ -- so that the binding locations are reported -- from the left-hand side case details of - PrefixCon _ vars -> + PrefixCon vars -> do { checkDupRdrNames vars ; names <- mapM lookupPatSynBndr vars - ; return ( (pat', PrefixCon noTypeArgs names) + ; return ( (pat', PrefixCon names) , mkFVs (map unLoc names)) } InfixCon var1 var2 -> do { checkDupRdrNames [var1, var2] @@ -746,7 +782,7 @@ , mkFVs (map unLoc [name1, name2])) } RecCon vars -> do { checkDupRdrNames (map (foLabel . recordPatSynField) vars) - ; fls <- lookupConstructorFields name + ; fls <- lookupConstructorFields $ noUserRdr name ; let fld_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] ; let rnRecordPatSynField (RecordPatSynField { recordPatSynField = visible @@ -764,7 +800,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) } @@ -781,7 +817,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] @@ -903,7 +939,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 @@ -912,22 +948,29 @@ ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds') sig_ctxt | is_cls_decl = ClsDeclCtxt cls - | otherwise = InstDeclCtxt bound_nms + | otherwise = InstDeclCtxt (mkOccEnv [ (nameOccName n, n) + | n <- nonDetEltsUniqSet bound_nms ]) ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $ renameSigs sig_ctxt other_sigs + ; 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 + , tcg_complete_match_env = tcg_complete_match_env gblEnv ++ localCompletePrags}) $ + do { -- Rename the bindings RHSs. Again there's an issue about whether the -- type variables from the class/instance head are in scope. -- 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -974,10 +1017,10 @@ -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest = setSrcSpanA loc $ do - do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name + do { sel_name <- wrapLocMA (lookupInstDeclBndr cls MethodOfClass) name -- We use the selector name as the binder ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } - ; return (L loc bind' `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 @@ -1022,19 +1065,10 @@ ; return (good_sigs, sig_fvs) } ---------------------- --- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory --- because this won't work for: --- instance Foo T where --- {-# INLINE op #-} --- Baz.op = ... --- We'll just rename the INLINE prag to refer to whatever other 'op' --- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) --- Doesn't seem worth much trouble to sort this. - renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) renameSig ctxt sig@(TypeSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs - ; let doc = TypeSigCtx (ppr_sig_bndrs vs) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; let doc = TypeSigCtx vs ; (new_ty, fvs) <- rnHsSigWcType doc ty ; return (TypeSig noAnn new_vs new_ty, fvs) } @@ -1042,14 +1076,12 @@ = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ addErr (TcRnUnexpectedDefaultSig sig) - ; mapM_ warnForallIdentifier vs - ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs + ; new_v <- mapM (lookupSigOccRn ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) } where - (v1:_) = vs - ty_ctxt = GenericCtx (text "a class method signature for" - <+> quotes (ppr v1)) + v1:|_ = expectNonEmpty vs + ty_ctxt = ClassMethodSigCtx v1 renameSig _ (SpecInstSig (_, src) ty) = do { checkInferredVars doc ty @@ -1070,19 +1102,24 @@ -- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig ctxt sig@(SpecSig _ v tys inl) = do { new_v <- case ctxt of - TopSigCtxt {} -> lookupLocatedOccRn v - _ -> lookupSigOccRnN ctxt sig v + TopSigCtxt {} -> lookupLocatedOccRn WL_TermVariable v + _ -> lookupSigOccRn ctxt sig v ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys ; return (SpecSig noAnn new_v new_ty inl, fvs) } where - ty_ctxt = GenericCtx (text "a SPECIALISE signature for" - <+> quotes (ppr v)) do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty + = do { (new_ty, fvs_ty) <- rnHsSigType (SpecialiseSigCtx v) TypeLevel ty ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } +renameSig _ctxt (SpecSigE _ bndrs spec_e inl) + = do { fn_rdr <- checkSpecESigShape spec_e + ; fn_name <- lookupOccRn WL_TermVariable fn_rdr -- Checks that the head isn't forall-bound + ; bindRuleBndrs (SpecECtx fn_rdr) bndrs $ \_ bndrs' -> + do { (spec_e', fvs) <- rnLExpr spec_e + ; return (SpecSigE fn_name bndrs' spec_e' inl, fvs) } } + renameSig ctxt sig@(InlineSig _ v s) - = do { new_v <- lookupSigOccRnN ctxt sig v + = do { new_v <- lookupSigOccRn ctxt sig v ; return (InlineSig noAnn new_v s, emptyFVs) } renameSig ctxt (FixSig _ fsig) @@ -1090,35 +1127,50 @@ ; return (FixSig noAnn new_fsig, emptyFVs) } renameSig ctxt sig@(MinimalSig (_, s) (L l bf)) - = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf + = do new_bf <- bfTraverse (lookupSigOccRn ctxt sig) bf return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig _ vs ty) - = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty ; return (PatSynSig noAnn new_vs ty', fvs) } where - ty_ctxt = GenericCtx (text "a pattern synonym signature for" - <+> ppr_sig_bndrs vs) + ty_ctxt = PatSynSigCtx vs renameSig ctxt sig@(SCCFunSig (_, st) v s) - = do { new_v <- lookupSigOccRnN ctxt sig v + = do { new_v <- lookupSigOccRn ctxt sig v ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn -renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty) - = do new_bf <- traverse lookupLocatedOccRn bf - new_mty <- traverse lookupLocatedOccRn mty +renameSig _ctxt (CompleteMatchSig (_, s) bf mty) + = do new_bf <- traverse (lookupLocatedOccRn WL_ConLike) bf + new_mty <- traverse (lookupLocatedOccRn WL_TyCon) mty this_mod <- fmap tcg_mod getGblEnv + let rn_sig = CompleteMatchSig (noAnn, s) new_bf new_mty unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ -- Why 'any'? See Note [Orphan COMPLETE pragmas] - addErrCtxt (text "In" <+> ppr sig) $ failWithTc TcRnOrphanCompletePragma + addErrCtxt (SigCtxt rn_sig) $ failWithTc TcRnOrphanCompletePragma - return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs) + return (rn_sig, emptyFVs) +checkSpecESigShape :: LHsExpr GhcPs -> RnM RdrName +-- Checks the shape of a SPECIALISE +-- That it looks like (f a1 .. an [ :: ty ]) +checkSpecESigShape spec_e = go_l spec_e + where + go_l (L _ e) = go e + + go :: HsExpr GhcPs -> RnM RdrName + go (ExprWithTySig _ fn _) = go_l fn + go (HsApp _ fn _) = go_l fn + go (HsAppType _ fn _) = go_l fn + go (HsVar _ (L _ fn)) = return fn + go (HsPar _ e) = go_l e + go _ = failWithTc (TcRnSpecSigShape spec_e) + {- Note [Orphan COMPLETE pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1141,9 +1193,6 @@ complexity of supporting them properly doesn't seem worthwhile. -} -ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc -ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) - okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool okHsSig ctxt (L _ sig) = case (sig, ctxt) of @@ -1164,10 +1213,8 @@ (InlineSig {}, HsBootCtxt {}) -> False (InlineSig {}, _) -> True - (SpecSig {}, TopSigCtxt {}) -> True - (SpecSig {}, LocalBindCtxt {}) -> True - (SpecSig {}, InstDeclCtxt {}) -> True - (SpecSig {}, _) -> False + (SpecSig {}, ctxt) -> ok_spec_ctxt ctxt + (SpecSigE {}, ctxt) -> ok_spec_ctxt ctxt (SpecInstSig {}, InstDeclCtxt {}) -> True (SpecInstSig {}, _) -> False @@ -1185,6 +1232,12 @@ (XSig {}, InstDeclCtxt {}) -> True (XSig {}, _) -> False +ok_spec_ctxt ::HsSigCtxt -> Bool +-- Contexts where SPECIALISE can occur +ok_spec_ctxt (TopSigCtxt {}) = True +ok_spec_ctxt (LocalBindCtxt {}) = True +ok_spec_ctxt (InstDeclCtxt {}) = True +ok_spec_ctxt _ = False ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] @@ -1225,6 +1278,66 @@ 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. + +bindRuleBndrs :: HsDocContext -> RuleBndrs GhcPs + -> ([Name] -> RuleBndrs GhcRn -> RnM (a,FreeVars)) + -> RnM (a,FreeVars) +bindRuleBndrs doc (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs }) thing_inside + = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; bindRuleTyVars doc tyvs $ \ tyvs' -> + bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> + thing_inside names (RuleBndrs { rb_ext = noExtField + , rb_tyvs = tyvs', rb_tmvs = tmvs' }) } + where + get_var :: RuleBndr GhcPs -> LocatedN RdrName + get_var (RuleBndrSig _ v _) = v + get_var (RuleBndr _ v) = v + + +bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs + -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindRuleTmVars doc tyvs vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (L l (RuleBndr noAnn (L loc n)) : vars') + + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) + (n : ns) thing_inside + = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + + bind_free_tvs = case tyvs of Nothing -> AlwaysBind + Just _ -> NeverBind + +bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs] + -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindRuleTyVars doc (Just bndrs) thing_inside + = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just) +bindRuleTyVars _ _ thing_inside = thing_inside Nothing + {- ************************************************************************ * * @@ -1234,12 +1347,12 @@ -} 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))) ~ SrcAnn NoEpAnns - , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnCO + , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ EpAnnCO , Outputable (body GhcPs) ) @@ -1266,41 +1379,65 @@ -- \cases expressions or commands. In that case, or if we encounter an empty -- MatchGroup but -XEmptyCases is disabled, we add an error. -rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn +rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContextRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> MatchGroup GhcPs (LocatedA (body GhcPs)) -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin }) -- see Note [Empty MatchGroups] - = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (TcRnEmptyCase ctxt)) + = do { when (null ms) $ checkEmptyCase 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 - mustn't_be_empty = case ctxt of - LamCaseAlt LamCases -> return True - ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> return True - _ -> not <$> xoptM LangExt.EmptyCase + disallowed_ctxt = + case ctxt of + LamAlt LamCases -> True + ArrowMatchCtxt (ArrowLamAlt LamCases) -> True + _ -> False rnMatch :: AnnoBody body - => HsMatchContext GhcRn + => HsMatchContextRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> LMatch GhcPs (LocatedA (body GhcPs)) -> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody) rnMatch' :: (AnnoBody body) - => HsMatchContext GhcRn + => HsMatchContextRn -> (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 ) } @@ -1313,7 +1450,7 @@ -} rnGRHSs :: AnnoBody body - => HsMatchContext GhcRn + => HsMatchContextRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> GRHSs GhcPs (LocatedA (body GhcPs)) -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars) @@ -1323,13 +1460,13 @@ return (GRHSs emptyComments grhss' binds', fvGRHSs) rnGRHS :: AnnoBody body - => HsMatchContext GhcRn + => HsMatchContextRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> LGRHS GhcPs (LocatedA (body GhcPs)) -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody) -rnGRHS' :: HsMatchContext GhcRn +rnGRHS' :: HsMatchContextRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> GRHS GhcPs (LocatedA (body GhcPs)) -> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars) @@ -1369,18 +1506,20 @@ -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise -- return a fixity sig for each (slightly odd) - rn_decl (FixitySig _ fnames fixity) - = do names <- concatMapM lookup_one fnames - return (FixitySig noExtField names fixity) + rn_decl sig@(FixitySig ns_spec fnames fixity) + = do unlessXOptM LangExt.ExplicitNamespaces $ + when (ns_spec /= NoNamespaceSpecifier) $ + addErr (TcRnNamespacedFixitySigWithoutFlag sig) + names <- concatMapM (lookup_one ns_spec) fnames + return (FixitySig ns_spec names fixity) - lookup_one :: LocatedN RdrName -> RnM [LocatedN Name] - lookup_one (L name_loc rdr_name) + lookup_one :: NamespaceSpecifier -> LocatedN RdrName -> RnM [LocatedN Name] + lookup_one ns_spec (L name_loc rdr_name) = setSrcSpanA name_loc $ -- This lookup will fail if the name is not defined in the -- same binding group as this fixity declaration. - do names <- lookupLocalTcNames sig_ctxt what rdr_name + do names <- lookupLocalTcNames sig_ctxt SigLikeFixitySig ns_spec rdr_name return [ L name_loc name | (_, name) <- names ] - what = text "fixity signature" {- ************************************************************************ diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs --- a/GHC/Rename/Env.hs +++ b/GHC/Rename/Env.hs @@ -14,8 +14,7 @@ module GHC.Rename.Env ( newTopSrcBinder, - lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn, - lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, + lookupLocatedTopBndrRnN, lookupTopBndrRn, lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, lookupLocatedOccRnNone, @@ -23,7 +22,7 @@ lookupLocalOccRn_maybe, lookupInfoOccRn, lookupLocalOccThLvl_maybe, lookupLocalOccRn, lookupTypeOccRn, - lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupGlobalOccRn_maybe, lookupExprOccRn, lookupRecFieldOcc, @@ -34,13 +33,15 @@ ChildLookupResult(..), lookupSubBndrOcc_helper, - HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN, + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigCtxtOccRn, lookupInstDeclBndr, lookupFamInstName, lookupConstructorInfo, lookupConstructorFields, lookupGREInfo, + irrefutableConLikeRn, irrefutableConLikeTc, + lookupGreAvailRn, -- Rebindable Syntax @@ -49,8 +50,7 @@ lookupIfThenElse, -- QualifiedDo - lookupQualifiedDoExpr, lookupQualifiedDo, - lookupQualifiedDoName, lookupNameWithQualifier, + lookupQualifiedDo, lookupQualifiedDoName, lookupNameWithQualifier, -- Constructing usage information DeprecationWarnings(..), @@ -80,10 +80,8 @@ import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Types.Hint -import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Warnings ( WarningTxt(..) ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon @@ -93,10 +91,10 @@ 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 -import GHC.Utils.Panic.Plain (assert) import GHC.Data.Maybe import GHC.Driver.Env import GHC.Driver.Session @@ -106,6 +104,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 @@ -113,8 +112,7 @@ import Control.Monad import Data.Either ( partitionEithers ) import Data.Function ( on ) -import Data.List ( find, partition, groupBy, sortBy ) -import Data.Foldable ( for_ ) +import Data.List ( find, partition, sortBy ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semi import System.IO.Unsafe ( unsafePerformIO ) @@ -182,7 +180,7 @@ warning until you use the identifier further downstream. This would require adjusting addUsedGRE so that during signature compilation, we do not report deprecation warnings for LocalDef. See also -Note [Handling of deprecations] +Note [Handling of deprecations] in GHC.Rename.Utils -} newTopSrcBinder :: LocatedN RdrName -> RnM Name @@ -240,8 +238,8 @@ -- Binders should not be qualified; if they are, and with a different -- module name, we get a confusing "M.T is not in scope" error later - ; stage <- getStage - ; if isBrackStage stage then + ; level <- getThLevel + ; if isBrackLevel level then -- We are inside a TH bracket, so make an *Internal* name -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names do { uniq <- newUnique @@ -276,7 +274,7 @@ -- Can be made to not be exposed -- Only used unwrapped in rnAnnProvenance -lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name +lookupTopBndrRn :: WhatLooking -> RdrName -> RnM (WithUserRdr Name) -- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. -- For example, this is OK: @@ -288,7 +286,7 @@ -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. lookupTopBndrRn which_suggest rdr_name = - lookupExactOrOrig rdr_name greName $ + lookupExactOrOrig rdr_name (WithUserRdr rdr_name . greName) $ do { -- Check for operators in type or class declarations -- See Note [Type and class operator definitions] let occ = rdrNameOcc rdr_name @@ -296,24 +294,17 @@ (do { op_ok <- xoptM LangExt.TypeOperators ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) ; env <- getGlobalRdrEnv - ; case filter isLocalGRE (lookupGRE env $ LookupRdrName rdr_name $ RelevantGREsFOS WantNormal) of + ; WithUserRdr rdr_name <$> + case filter isLocalGRE (lookupGRE env $ LookupRdrName rdr_name $ RelevantGREsFOS WantNormal) of [gre] -> return (greName gre) _ -> do -- Ambiguous (can't happen) or unbound traceRn "lookupTopBndrRN fail" (ppr rdr_name) unboundName (LF which_suggest WL_LocalTop) rdr_name } -lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name) -lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor) - -lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name) -lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor) - -lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) -lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything) - -lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name) -lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything) +lookupLocatedTopBndrRnN :: WhatLooking -> LocatedN RdrName -> RnM (LocatedN Name) +lookupLocatedTopBndrRnN what_look = + wrapLocMA (fmap getName . lookupTopBndrRn what_look) -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see @@ -321,19 +312,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 } @@ -383,7 +376,7 @@ -- Ugh! See Note [Template Haskell ambiguity] } ----------------------------------------------- -lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name +lookupInstDeclBndr :: Name -> Subordinate -> RdrName -> RnM Name -- This is called on the method name on the left-hand side of an -- instance declaration binding. eg. instance Functor T where -- fmap = ... @@ -398,7 +391,7 @@ -- -- The "what" parameter says "method" or "associated type", -- depending on what we are looking up -lookupInstDeclBndr cls what rdr +lookupInstDeclBndr cls what_subordinate rdr = do { when (isQual rdr) (addErr (badQualBndrErr rdr)) -- In an instance decl you aren't allowed @@ -410,13 +403,11 @@ -- warnings when a deprecated class -- method is defined. We only warn -- when it's used - cls doc rdr + (ParentGRE cls (IAmTyCon ClassFlavour)) what_subordinate rdr ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr err) + Left err -> do { addErr $ TcRnNotInScope err rdr ; return (mkUnboundNameRdr rdr) } Right nm -> return nm } - where - doc = what <+> text "of class" <+> quotes (ppr cls) ----------------------------------------------- lookupFamInstName :: Maybe Name -> LocatedN RdrName @@ -424,21 +415,22 @@ -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind - = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr + = wrapLocMA (lookupInstDeclBndr cls AssociatedTypeOfClass) tc_rdr lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRnConstr tc_rdr + = lookupLocatedOccRn WL_TyCon tc_rdr ----------------------------------------------- -lookupConstructorFields :: HasDebugCallStack => Name -> RnM [FieldLabel] +lookupConstructorFields :: HasDebugCallStack => WithUserRdr Name -> RnM [FieldLabel] lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo -- | Look up the arity and record fields of a constructor. -lookupConstructorInfo :: HasDebugCallStack => Name -> RnM ConInfo -lookupConstructorInfo con_name +lookupConstructorInfo :: HasDebugCallStack => WithUserRdr Name -> RnM ConInfo +lookupConstructorInfo qcon@(WithUserRdr _ con_name) = do { info <- lookupGREInfo_GRE con_name ; case info of IAmConLike con_info -> return con_info - UnboundGRE -> return ConHasPositionalArgs + UnboundGRE -> return $ ConInfo (ConIsData []) ConHasPositionalArgs + IAmTyCon {} -> failIllegalTyCon WL_ConLike qcon _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ vcat [ text "name:" <+> ppr con_name ] } @@ -453,7 +445,7 @@ FoundExactOrOrig gre -> return $ res gre NotExactOrOrig -> k ExactOrOrigError e -> - do { addErr (mkTcRnNotInScope rdr_name e) + do { addErr $ TcRnNotInScope e rdr_name ; return $ res (mkUnboundGRERdr rdr_name) } } -- Variant of 'lookupExactOrOrig' that does not report an error @@ -525,18 +517,19 @@ -- If -XDisambiguateRecordFields is off, then we will pass 'Nothing' for the -- 'DataCon' 'Name', i.e. we don't use the data constructor for disambiguation. -- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. -lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual - -- Just con => use data con to disambiguate +lookupRecFieldOcc :: Maybe (WithUserRdr Name) + -- Nothing => just look it up as usual + -- Just con => use data con to disambiguate -> RdrName -> RnM Name lookupRecFieldOcc mb_con rdr_name - | Just con <- mb_con + | Just (WithUserRdr _ con) <- mb_con , isUnboundName con -- Avoid error cascade = return $ mk_unbound_rec_fld con - | Just con <- mb_con + | Just qcon@(WithUserRdr _ con) <- mb_con = do { let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) ; mb_nm <- lookupExactOrOrig rdr_name ensure_recfld $ -- See Note [Record field names and Template Haskell] - do { flds <- lookupConstructorFields con + do { flds <- lookupConstructorFields qcon ; env <- getGlobalRdrEnv ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds -- We have the label, now check it is in scope. If @@ -560,11 +553,18 @@ ; Just nm -> return nm } } | otherwise -- Can't use the data constructor to disambiguate - = lookupGlobalOccRn' (RelevantGREsFOS WantField) rdr_name - -- This use of Global is right as we are looking up a selector, - -- which can only be defined at the top level. - + = lookupExactOrOrig rdr_name greName $ + do { mb_gre <- lookupGlobalOccRn_base which_gres rdr_name + ; case mb_gre of + Just gre -> return (greName gre) + Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) + ; unboundName looking_for rdr_name } } where + which_gres = RelevantGREsFOS WantField + looking_for = LF { lf_which = WL_RecField, lf_where = WL_Global } + -- This use of Global is right as we are looking up a selector, + -- which can only be defined at the top level. + -- When lookup fails, make an unbound name with the right record field -- namespace, as that's what we expect to be returned -- from 'lookupRecFieldOcc'. See T14307. @@ -681,25 +681,24 @@ -} -- | Used in export lists to lookup the children. -lookupSubBndrOcc_helper :: Bool -> DeprecationWarnings - -> Name - -> RdrName -- ^ thing we are looking up - -> LookupChild -- ^ how to look it up (e.g. which - -- 'NameSpace's to look in) +lookupSubBndrOcc_helper :: Bool + -> DeprecationWarnings + -> ParentGRE -- ^ parent + -> RdrName -- ^ thing we are looking up -> RnM ChildLookupResult -lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name how_lkup - | isUnboundName parent +lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent_gre rdr_name + | isUnboundName (parentGRE_name parent_gre) -- Avoid an error cascade = return (FoundChild (mkUnboundGRERdr rdr_name)) | otherwise = do gre_env <- getGlobalRdrEnv - let original_gres = lookupGRE gre_env (LookupChildren (rdrNameOcc rdr_name) how_lkup) + let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name)) picked_gres = pick_gres original_gres -- The remaining GREs are things that we *could* export here. -- Note that this includes things which have `NoParent`; -- those are sorted in `checkPatSynParent`. - traceRn "parent" (ppr parent) + traceRn "parent" (ppr (parentGRE_name parent_gre)) traceRn "lookupExportChild original_gres:" (ppr original_gres) traceRn "lookupExportChild picked_gres:" (ppr picked_gres $$ ppr must_have_parent) case picked_gres of @@ -735,12 +734,12 @@ dup_fields_ok <- xoptM LangExt.DuplicateRecordFields case original_gres of [] -> return NameNotFound - [g] -> return $ IncorrectParent parent g + [g] -> return $ IncorrectParent parent_gre g [p | ParentIs p <- [greParent g]] gss@(g:gss'@(_:_)) -> if all isRecFldGRE gss && dup_fields_ok then return $ - IncorrectParent parent g + IncorrectParent parent_gre g [p | x <- gss, ParentIs p <- [greParent x]] else mkNameClashErr $ g NE.:| gss' @@ -750,22 +749,29 @@ return (FoundChild (NE.head gres)) pick_gres :: [GlobalRdrElt] -> DisambigInfo - -- For Unqual, find GREs that are in scope qualified or unqualified - -- For Qual, find GREs that are in scope with that qualification pick_gres gres | isUnqual rdr_name + -- The child is not qualified: find GREs that are in scope, whether + -- qualified or unqualified, as per the Haskell 2010 report, 5.2.2: + -- + -- - In all cases, the parent type constructor T must be in scope. + -- - A subordinate name is legal if and only if: + -- (a) it names a constructor or field of T, and + -- (b) the constructor or field is in scope, regardless of whether + -- it is in scope under a qualified or unqualified name. = mconcat (map right_parent gres) | otherwise + -- The child is qualified: find GREs that are in scope + -- with that qualification. = mconcat (map right_parent (pickGREs rdr_name gres)) right_parent :: GlobalRdrElt -> DisambigInfo right_parent gre = case greParent gre of ParentIs cur_parent - | parent == cur_parent -> DisambiguatedOccurrence gre + | parentGRE_name parent_gre == cur_parent -> DisambiguatedOccurrence gre | otherwise -> NoOccurrence NoParent -> UniqueOccurrence gre -{-# INLINEABLE lookupSubBndrOcc_helper #-} -- | This domain specific datatype is used to record why we decided it was -- possible that a GRE could be exported with a parent. @@ -817,44 +823,41 @@ -- | We couldn't find a suitable name = NameNotFound -- | The child has an incorrect parent - | IncorrectParent Name -- ^ parent - GlobalRdrElt -- ^ child we were looking for - [Name] -- ^ list of possible parents + | IncorrectParent ParentGRE -- ^ parent + GlobalRdrElt -- ^ child we were looking for + [Name] -- ^ list of possible parents -- | We resolved to a child | FoundChild GlobalRdrElt instance Outputable ChildLookupResult where ppr NameNotFound = text "NameNotFound" ppr (FoundChild n) = text "Found:" <+> ppr (greParent n) <+> ppr n - ppr (IncorrectParent p g ns) + ppr (IncorrectParent parent g ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr $ greName g, ppr ns] + <+> hsep [ppr (parentGRE_name parent), ppr $ greName g, ppr ns] lookupSubBndrOcc :: DeprecationWarnings - -> Name -- Parent - -> SDoc + -> ParentGRE + -> Subordinate -> RdrName -> RnM (Either NotInScopeError Name) -- ^ Find all the things the 'RdrName' maps to, -- and pick the one with the right 'Parent' 'Name'. -lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = +lookupSubBndrOcc warn_if_deprec the_parent what_subordinate rdr_name = lookupExactOrOrig rdr_name (Right . greName) $ -- This happens for built-in classes, see mod052 for example - do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name what_lkup + do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name ; return $ case child of FoundChild g -> Right (greName g) - NameNotFound -> Left (UnknownSubordinate doc) - IncorrectParent {} -> Left (UnknownSubordinate doc) } + NameNotFound -> Left unknown_sub + IncorrectParent {} -> Left unknown_sub } -- See [Mismatched class methods and associated type families] -- in TcInstDecls. where - what_lkup = LookupChild { wantedParent = the_parent - , lookupDataConFirst = False - , prioritiseParent = True -- See T23664. - } -{- -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + unknown_sub = UnknownSubordinate (parentGRE_name the_parent) what_subordinate + +{- Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider data family F a data instance F T = X1 | X2 @@ -989,21 +992,21 @@ -------------------------------------------------- -} - -lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRn = wrapLocMA lookupOccRn +lookupLocatedOccRn :: WhatLooking + -> GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRn what = wrapLocMA (lookupOccRn what) -lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr -lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRnRecField :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField -lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) +lookupLocatedOccRnNone :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) @@ -1012,40 +1015,71 @@ = do { local_env <- getLocalRdrEnv ; return (lookupLocalRdrEnv local_env rdr_name) } -lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) +lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevelIndex)) -- Just look in the local environment lookupLocalOccThLvl_maybe name = do { lcl_env <- getLclEnv ; return (lookupNameEnv (getLclEnvThBndrs lcl_env) name) } --- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to +-- | lookupOccRn looks up an occurrence of a RdrName, and uses its argument to -- determine what kind of suggestions should be displayed if it is not in scope -lookupOccRn' :: WhatLooking -> RdrName -> RnM Name -lookupOccRn' which_suggest rdr_name +lookupOccRn :: WhatLooking -> RdrName -> RnM Name +lookupOccRn which_suggest rdr_name = do { mb_gre <- lookupOccRn_maybe rdr_name ; case mb_gre of Just gre -> return $ greName gre - Nothing -> reportUnboundName' which_suggest rdr_name } - --- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if --- it is not in scope -lookupOccRn :: RdrName -> RnM Name -lookupOccRn = lookupOccRn' WL_Anything + Nothing -> reportUnboundName which_suggest rdr_name } --- lookupOccRnConstr looks up an occurrence of a RdrName and displays --- constructors and pattern synonyms as suggestions if it is not in scope +-- | Look up an occurrence of a 'RdrName'. +-- +-- Displays constructors and pattern synonyms as suggestions if +-- it is not in scope. +-- +-- See Note [lookupOccRnConstr] lookupOccRnConstr :: RdrName -> RnM Name -lookupOccRnConstr = lookupOccRn' WL_Constructor +lookupOccRnConstr rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> do + { mb_ty_gre <- lookup_promoted rdr_name + ; case mb_ty_gre of + Just gre -> return $ greName gre + Nothing -> + reportUnboundName WL_ConLike rdr_name + } } +{- Note [lookupOccRnConstr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupOccRnConstr looks up a data constructor or pattern synonym. Simple. + +However, there is a fallback to the type level when the lookup fails. +This is required to implement a pat-to-type transformation +(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat) + +Consider this example: + + data VisProxy a where VP :: forall a -> VisProxy a + + f :: VisProxy Int -> () + f (VP Int) = () + +Here `Int` is actually a type, but it occurs in a position in which we expect +a data constructor. + +In all other cases we just use this additional lookup for better +error messaging (See Note [Promotion]). +-} + -- lookupOccRnRecField looks up an occurrence of a RdrName and displays -- record fields as suggestions if it is not in scope lookupOccRnRecField :: RdrName -> RnM Name -lookupOccRnRecField = lookupOccRn' WL_RecField +lookupOccRnRecField = lookupOccRn WL_RecField -- lookupOccRnRecField looks up an occurrence of a RdrName and displays -- no suggestions if it is not in scope lookupOccRnNone :: RdrName -> RnM Name -lookupOccRnNone = lookupOccRn' WL_None +lookupOccRnNone = lookupOccRn WL_None -- Only used in one place, to rename pattern synonym binders. -- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind @@ -1054,16 +1088,13 @@ = do { mb_name <- lookupLocalOccRn_maybe rdr_name ; case mb_name of Just name -> return name - Nothing -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name } + Nothing -> unboundName (LF WL_TermVariable WL_LocalOnly) rdr_name } -- lookupTypeOccRn looks up an optionally promoted RdrName. -- Used for looking up type variables. lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] lookupTypeOccRn rdr_name - | (isVarOcc <||> isFieldOcc) (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise = do { mb_gre <- lookupOccRn_maybe rdr_name ; case mb_gre of Just gre -> return $ greName gre @@ -1086,9 +1117,10 @@ but emit appropriate warnings. -} +-- Used when looking up a term name (varName or dataName) in a type lookup_demoted :: RdrName -> RnM Name lookup_demoted rdr_name - | Just demoted_rdr <- demoteRdrName rdr_name + | Just demoted_rdr <- demoteRdrNameTcCls rdr_name -- Maybe it's the name of a *data* constructor = do { data_kinds <- xoptM LangExt.DataKinds ; star_is_type <- xoptM LangExt.StarIsType @@ -1111,16 +1143,111 @@ | otherwise = star_is_type_hints ; unboundNameX looking_for rdr_name suggestion } } - | Just demoted_rdr_name <- demoteRdrNameTv rdr_name, - isQual rdr_name + + | isQual rdr_name, + Just demoted_rdr_name <- demoteRdrNameTv rdr_name + -- Definitely an illegal term variable, as type variables are never exported. + -- See Note [Demotion of unqualified variables] (W2) = report_qualified_term_in_types rdr_name demoted_rdr_name + | isUnqual rdr_name, + Just demoted_rdr_name <- demoteRdrNameTv rdr_name + -- See Note [Demotion of unqualified variables] + = do { required_type_arguments <- xoptM LangExt.RequiredTypeArguments + ; if required_type_arguments + then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr_name + ; case mb_demoted_gre of + Nothing -> unboundName (LF WL_Anything WL_Anywhere) rdr_name + Just demoted_gre -> return $ greName demoted_gre } + else unboundName looking_for rdr_name } + | otherwise - = reportUnboundName' (lf_which looking_for) rdr_name + = unboundName looking_for rdr_name where - looking_for = LF WL_Constructor WL_Anywhere + looking_for = LF WL_Type WL_Anywhere +{- Note [Demotion of unqualified variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under RequiredTypeArguments, a term-level variable name (i.e. a name whose +`occNameSpace` is `varName` as opposed to `tvName`) does not necessarily denote +a term variable. It can actually stand for a type: + + {-# LANGUAGE RequiredTypeArguments #-} + idv :: forall a -> a -> a -- Note the "forall a ->" in the type + idv t (x :: t) = id @t x -- #23739 + -- ^ ^ ^ + -- varName tvName tvName -- NameSpace (GHC.Types.Name.Occurrence) + +The variable `t` is an alias for the type variable `a`, so it's valid to use it +in type-level contexts. The only problem is that the namespaces do not match. +Demotion allows us to connect the `tvName` usages to the `varName` binding. + +Demotion of an RdrName means that we change its namespace from tvName/tcClsName +to varName/dataName. Suppose we are looking up an occurrence of a variable `a` +in a type (in `lookupTypeOccRn`). The parser gave `a` a `tvName` occurrence, +so we try looking that up first. If that fails, and RequiredTypeArguments is +on, then "demote" it to the `varName` namespace with `demoteRdrNameTv` and look +that up instead. If that succeeds, use it. + +(W1) Wrinkle 1 + As a side effect of demotion, the renamer accepts all these examples: + t = True -- Ordinary term-level binding + x = Proxy @t -- (1) Bad usage in a HsExpr + type T = t -- (2) Bad usage in a TyClDecl + f :: t -> t -- (3) Bad usage in a SigDecl + + However, GHC doesn't promote arbitrary terms to types. See the "T2T-Mapping" + section of GHC Proposal #281: "In the type checking environment, the variable + must stand for a type variable". Even though the renamer accepts these + constructs, the type checker has to reject the uses of `t` shown above. + + All three examples are rejected with the `TermVariablePE` promotion error. + The error is generated by `tcTyVar` (GHC.Tc.Gen.HsType) + tcTyVar :: Name -> TcM (TcType, TcKind) + The first thing `tcTyVar` does is call the `tcLookup` helper (GHC.Tc.Utils.Env) + to find the variable in the type checking environment + tcLookup :: Name -> TcM TcTyThing + What happens next depends on the example in question. + + * In the HsExpr example (1), `tcLookup` finds `ATcId` that corresponds to + the `t = True` binding. The `ATcId` is then then turned into an error by + the following clause in `tcTyVar`: + ATcId{} -> promotionErr name TermVariablePE + + * In the TyClDecl example (2) and the SigDecl example (3), we don't have + `ATcId` in the environment just yet because type declarations and signatures + are type-checked /before/ term-level bindings. + + This means that `tcLookup` fails to find `t` in the local environment and + calls `tcLookupGlobal` (GHC.Tc.Utils.Env) + tcLookupGlobal :: Name -> TcM TyThing + + The global environment does not contain `t` either, so `tcLookupGlobal` + calls `notFound` (GHC.Tc.Utils.Env) + notFound :: Name -> TcM TyThing + + At this point GHC would normally generate a panic: if the variable is + neither in the local nor in the global environment, then it shouldn't have + passed the renamer. Unfortunately, this expectation is tiresome and + expensive to maintain, so we add a special case in `notFound` instead. + If the namespace of the variable is `varName`, the only explanation other + than a bug in GHC is that the user tried to use a term variable in a type + context. Hence the following clause in `notFound`: + _ | isTermVarOrFieldNameSpace (nameNameSpace name) -> + failWithTc $ TcRnUnpromotableThing name TermVariablePE + +(W2) Wrinkle 2 + Only unqualified variable names are demoted, e.g. `f` but not `M.f`. + The reason is that type variables are never bound to a qualified name: + they can't be bound at the top level of a module, nor can they be + exported or imported, so a qualified occurrence `M.f` must refer to a + term-level definition and is never legal at the type level. + Demotion of qualified names would not allow us to accept any new programs. + We use this fact to generate better suggestions in error messages, + see `report_qualified_term_in_types`. +-} + -- Report a qualified variable name in a type signature: -- badSig :: Prelude.head -- ^^^^^^^^^^^ @@ -1128,7 +1255,7 @@ report_qualified_term_in_types rdr_name demoted_rdr_name = do { mName <- lookupGlobalOccRn_maybe (RelevantGREsFOS WantNormal) demoted_rdr_name ; case mName of - (Just _) -> termNameInType looking_for rdr_name demoted_rdr_name [] + Just _ -> termNameInType looking_for rdr_name demoted_rdr_name [] Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name } where looking_for = LF WL_Constructor WL_Global @@ -1144,28 +1271,8 @@ | otherwise = return Nothing -badVarInType :: RdrName -> RnM Name -badVarInType rdr_name - = do { addErr (TcRnUnpromotableThing name TermVariablePE) - ; return name } - where - name = mkUnboundNameRdr rdr_name - -{- Note [Promoted variables in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#12686): - x = True - data Bad = Bad 'x - -The parser treats the quote in 'x as saying "use the term -namespace", so we'll get (Bad x{v}), with 'x' in the -VarName namespace. If we don't test for this, the renamer -will happily rename it to the x bound at top level, and then -the typecheck falls over because it doesn't have 'x' in scope -when kind-checking. - -Note [Demotion] -~~~~~~~~~~~~~~~ +{- Note [Demotion] +~~~~~~~~~~~~~~~~~~ When the user writes: data Nat = Zero | Succ Nat foo :: f Zero -> Int @@ -1211,11 +1318,11 @@ (see the functions promotedRdrName and lookup_promoted). In particular, we have the following error message - • Illegal term-level use of the type constructor ‘Int’ - imported from ‘Prelude’ (and originally defined in ‘GHC.Types’) - • In the first argument of ‘id’, namely ‘Int’ + • Illegal term-level use of the type constructor ‘Int' + imported from ‘Prelude' (and originally defined in ‘GHC.Types') + • In the first argument of ‘id' In the expression: id Int - In an equation for ‘x’: x = id Int + In an equation for ‘x': x = id Int when the user writes the following declaration @@ -1288,28 +1395,6 @@ lookupExactOrOrig_maybe rdr_name id $ lookupGlobalOccRn_base which_gres rdr_name -lookupGlobalOccRn :: RdrName -> RnM Name --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. Adds an error message if the RdrName is not in scope. --- You usually want to use "lookupOccRn" which also looks in the local --- environment. --- --- Used by exports_from_avail -lookupGlobalOccRn = lookupGlobalOccRn' (RelevantGREsFOS WantNormal) - -lookupGlobalOccRn' :: WhichGREs GREInfo -> RdrName -> RnM Name -lookupGlobalOccRn' which_gres rdr_name = - lookupExactOrOrig rdr_name greName $ do - mb_gre <- lookupGlobalOccRn_base which_gres rdr_name - case mb_gre of - Just gre -> return (greName gre) - Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) - ; unboundName (LF which_suggest WL_Global) rdr_name } - where which_suggest = case includeFieldSelectors which_gres of - WantBoth -> WL_RecField - WantField -> WL_RecField - WantNormal -> WL_Anything - -- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. -- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like @@ -1370,6 +1455,12 @@ do { let (env_fld_gres, env_var_gres) = partition isRecFldGRE $ lookupGRE env (LookupRdrName rdr (RelevantGREsFOS WantBoth)) + -- Make sure to use 'LookupRdrName': if a record update contains + -- a qualified field name, only look up GREs which are in scope + -- with that same qualification. + -- + -- See Wrinkle [Qualified names in record updates] + -- in Note [Disambiguating record updates] in GHC.Rename.Pat. -- Handle implicit qualified imports in GHCi. See T10439. ; ghci_gres <- lookupQualifiedNameGHCi WantBoth rdr @@ -1393,11 +1484,16 @@ -- Add an error if lookup failed. ; case res of - gre : gres -> return $ gre NE.:| gres - [] -> do { (imp_errs, hints) <- - unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr - ; failWithTc $ - TcRnNotInScope NotARecordField rdr imp_errs hints } } + { gre : gres -> return $ gre NE.:| gres + ; [] -> + do { show_helpful_errors <- goptM Opt_HelpfulErrors + ; (imp_errs, hints) <- + if show_helpful_errors + then unknownNameSuggestions emptyLocalRdrEnv WL_RecField rdr + else return ([], []) + ; err_msg <- unknownNameSuggestionsMessage (TcRnNotInScope NotARecordField rdr) imp_errs hints + ; failWithTc err_msg + } } } -- | Look up a 'RdrName', which might refer to an overloaded record field. -- @@ -1414,8 +1510,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. @@ -1442,10 +1538,10 @@ -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) lookupRecUpdFields flds -- See Note [Disambiguating record updates] in GHC.Rename.Pat. - = do { -- Retrieve the possible GlobalRdrElts that each field could refer to. + = do { -- (1) Retrieve the possible GlobalRdrElts that each field could refer to. ; gre_env <- getGlobalRdrEnv ; fld1_gres NE.:| other_flds_gres <- mapM (lookupFieldGREs gre_env . getFieldUpdLbl) flds - -- Take an intersection: we are only interested in constructors + -- (2) Take an intersection: we are only interested in constructors -- which have all of the fields. ; let possible_GREs = intersect_by_cons fld1_gres other_flds_gres @@ -1456,15 +1552,16 @@ ; case possible_GREs of - -- There is at least one parent: we can proceed. + -- (3) (a) There is at least one parent: we can proceed. -- The typechecker might be able to finish disambiguating. -- See Note [Type-directed record disambiguation] in GHC.Rename.Pat. { p1:ps -> return (p1 NE.:| ps) - -- There are no possible parents for the record update: compute - -- a minimum set of fields which does not belong to any data constructor, - -- to report an informative error to the user. - ; _ -> + -- (3) (b) There are no possible parents for the record update: + -- compute a minimal set of fields which does not belong to any + -- data constructor, to report an informative error to the user. + ; _ -> do + hsc_env <- getTopEnv let -- The constructors which have the first field. fld1_cons :: UniqSet ConLikeName @@ -1474,9 +1571,9 @@ -- The field labels of the constructors which have the first field. fld1_cons_fields :: UniqFM ConLikeName [FieldLabel] fld1_cons_fields - = fmap (lkp_con_fields gre_env) + = fmap (lkp_con_fields hsc_env gre_env) $ getUniqSet fld1_cons - in failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } + failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } where intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt @@ -1495,13 +1592,22 @@ , not $ isEmptyUniqSet both_cons ] - lkp_con_fields :: GlobalRdrEnv -> ConLikeName -> [FieldLabel] - lkp_con_fields gre_env con = + -- Look up all in-scope fields of a 'ConLike'. + lkp_con_fields :: HscEnv -> GlobalRdrEnv -> ConLikeName -> [FieldLabel] + lkp_con_fields hsc_env gre_env con = [ fl - | let nm = conLikeName_Name con - , gre <- maybeToList $ lookupGRE_Name gre_env nm - , con_info <- maybeToList $ recFieldConLike_maybe gre - , fl <- conInfoFields con_info ] + | let con_nm = conLikeName_Name con + gre_info = + (greInfo <$> lookupGRE_Name gre_env con_nm) + `orElse` + lookupGREInfo hsc_env con_nm + -- See Wrinkle [Out of scope constructors] + -- in Note [Disambiguating record updates] in GHC.Rename.Pat. + , IAmConLike con_info <- [ gre_info ] + , fl <- conInfoFields con_info + , isJust $ lookupGRE_FieldLabel gre_env fl + -- Ensure the fields are in scope. + ] {-********************************************************************** * * @@ -1509,10 +1615,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) @@ -1525,8 +1631,9 @@ -- aren't really relevant to the problem. -- -- NB: this error message should only be triggered when all the field names --- are in scope (i.e. each individual field name does belong to some --- constructor in scope). +-- are in scope. It's OK if the constructors themselves are not in scope +-- (see Wrinkle [Out of scope constructors] in Note [Disambiguating record updates] +-- in GHC.Rename.Pat). badFieldsUpd :: (OutputableBndrId p) => [LHsRecUpdField (GhcPass p) q] @@ -1559,7 +1666,7 @@ in -- Fields that don't change the membership status of the set -- are redundant and can be dropped. - map (fst . head) $ groupBy ((==) `on` snd) growingSets + map (fst . NE.head) $ NE.groupBy ((==) `on` snd) growingSets aMember = assert (not (null members) ) fst (head members) (members, nonMembers) = partition (or . snd) membership @@ -1673,18 +1780,18 @@ -- until we know which is meant (gre:others) -> return (MultipleNames (gre NE.:| others)) } -lookupGreAvailRn :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGreAvailRn :: WhatLooking -> RdrName -> RnM (Maybe GlobalRdrElt) -- Used in export lists -- If not found or ambiguous, add error message, and fake with UnboundName -- Uses addUsedRdrName to record use and deprecations -lookupGreAvailRn rdr_name +lookupGreAvailRn what_looking rdr_name = do mb_gre <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name ExportDeprecationWarnings case mb_gre of GreNotFound -> do traceRn "lookupGreAvailRn" (ppr rdr_name) - _ <- unboundName (LF WL_Anything WL_Global) rdr_name + _ <- unboundName (LF what_looking WL_Global) rdr_name return Nothing MultipleNames gres -> do @@ -1701,25 +1808,18 @@ * * ********************************************************* -Note [Handling of deprecations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We report deprecations at each *occurrence* of the deprecated thing - (see #5867 and #4879) - -* We do not report deprecations for locally-defined names. For a - start, we may be exporting a deprecated thing. Also we may use a - deprecated thing in the defn of another deprecated things. We may - even use a deprecated thing in the defn of a non-deprecated thing, - when changing a module's interface. +Note [Using isImportedGRE in addUsedGRE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In addUsedGRE, we want to add any used imported GREs to the tcg_used_gres field, +so that we can emit appropriate warnings (see GHC.Rename.Names.warnUnusedImportDecls). -* We also report deprecations at export sites, but only for names - deprecated with export deprecations (since those are not transitive as opposed - to regular name deprecations and are only reported at the importing module) +We want to do this for GREs that were brought into scope through imports. As per +Note [GlobalRdrElt provenance] in GHC.Types.Name.Reader, this means we should +check that gre_imp is non-empty. Checking that gre_lcl is False is INCORRECT, +because we might have obtained the GRE by an Exact or Orig direct reference, +in which case we have both gre_lcl = False and gre_imp = emptyBag. -* addUsedGREs: we do not report deprecations for sub-binders: - - the ".." completion for records - - the ".." in an export item 'T(..)' - - the things exported by a module export 'module M' +Geting this wrong can lead to panics in e.g. bestImport, see #23240. -} addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () @@ -1730,21 +1830,11 @@ | dc <- tyConDataCons tycon , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] --- | Whether to report deprecation warnings when registering a used GRE --- --- There is no option to only emit declaration warnings since everywhere --- we emit the declaration warnings we also emit export warnings --- (See Note [Handling of deprecations] for details) -data DeprecationWarnings - = NoDeprecationWarnings - | ExportDeprecationWarnings - | AllDeprecationWarnings - addUsedGRE :: DeprecationWarnings -> GlobalRdrElt -> RnM () -- Called for both local and imported things -- Add usage *and* warn if deprecated addUsedGRE warn_if_deprec gre - = do { condWarnIfDeprecated warn_if_deprec [gre] + = do { warnIfDeprecated warn_if_deprec [gre] ; when (isImportedGRE gre) $ -- See Note [Using isImportedGRE in addUsedGRE] do { env <- getGblEnv -- Do not report the GREInfo (#23424) @@ -1754,9 +1844,9 @@ addUsedGREs :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () -- Record uses of any *imported* GREs -- Used for recording used sub-bndrs --- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] in GHC.Rename.Utils addUsedGREs warn_if_deprec gres - = do { condWarnIfDeprecated warn_if_deprec gres + = do { warnIfDeprecated warn_if_deprec gres ; unless (null imp_gres) $ do { env <- getGblEnv -- Do not report the GREInfo (#23424) @@ -1766,86 +1856,6 @@ imp_gres = filter isImportedGRE gres -- See Note [Using isImportedGRE in addUsedGRE] -{- Note [Using isImportedGRE in addUsedGRE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In addUsedGRE, we want to add any used imported GREs to the tcg_used_gres field, -so that we can emit appropriate warnings (see GHC.Rename.Names.warnUnusedImportDecls). - -We want to do this for GREs that were brought into scope through imports. As per -Note [GlobalRdrElt provenance] in GHC.Types.Name.Reader, this means we should -check that gre_imp is non-empty. Checking that gre_lcl is False is INCORRECT, -because we might have obtained the GRE by an Exact or Orig direct reference, -in which case we have both gre_lcl = False and gre_imp = emptyBag. - -Geting this wrong can lead to panics in e.g. bestImport, see #23240. --} - -condWarnIfDeprecated :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () -condWarnIfDeprecated NoDeprecationWarnings _ = return () -condWarnIfDeprecated opt gres = do - this_mod <- getModule - let external_gres - = filterOut (nameIsLocalOrFrom this_mod . greName) gres - mapM_ (\gre -> warnIfExportDeprecated gre >> maybeWarnDeclDepr gre) external_gres - where - maybeWarnDeclDepr = case opt of - ExportDeprecationWarnings -> const $ return () - AllDeprecationWarnings -> warnIfDeclDeprecated - -warnIfDeclDeprecated :: GlobalRdrElt -> RnM () -warnIfDeclDeprecated gre@(GRE { gre_imp = iss }) - | Just imp_spec <- headMaybe iss - = do { dflags <- getDynFlags - ; when (wopt_any_custom dflags) $ - -- See Note [Handling of deprecations] - do { iface <- loadInterfaceForName doc name - ; case lookupImpDeclDeprec iface gre of - Just deprText -> addDiagnostic $ - TcRnPragmaWarning { - pragma_warning_occ = occ, - pragma_warning_msg = deprText, - pragma_warning_import_mod = importSpecModule imp_spec, - pragma_warning_defined_mod = Just definedMod - } - Nothing -> return () } } - | otherwise - = return () - where - occ = greOccName gre - name = greName gre - definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) - doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" - -lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) -lookupImpDeclDeprec iface gre - -- Bleat if the thing, or its parent, is warn'd - = mi_decl_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` - case greParent gre of - ParentIs p -> mi_decl_warn_fn (mi_final_exts iface) (nameOccName p) - NoParent -> Nothing - -warnIfExportDeprecated :: GlobalRdrElt -> RnM () -warnIfExportDeprecated gre@(GRE { gre_imp = iss }) - = do { mod_warn_mbs <- mapBagM process_import_spec iss - ; for_ (sequence mod_warn_mbs) $ mapM - $ \(importing_mod, warn_txt) -> addDiagnostic $ - TcRnPragmaWarning { - pragma_warning_occ = occ, - pragma_warning_msg = warn_txt, - pragma_warning_import_mod = importing_mod, - pragma_warning_defined_mod = Nothing - } } - where - occ = greOccName gre - name = greName gre - doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" - process_import_spec :: ImportSpec -> RnM (Maybe (ModuleName, WarningTxt GhcRn)) - process_import_spec is = do - let mod = is_mod $ is_decl is - iface <- loadInterfaceForModule doc mod - let mb_warn_txt = mi_export_warn_fn (mi_final_exts iface) name - return $ (moduleName mod, ) <$> mb_warn_txt - {- Note [Used names with interface not loaded] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1882,7 +1892,7 @@ `Data.List` as if the user had written `import qualified Data.List`. If we fail we just return Nothing, rather than bleating -about "attempting to use module ‘D’ (./D.hs) which is not loaded" +about "attempting to use module 'D' (./D.hs) which is not loaded" which is what loadSrcInterface does. It is enabled by default and disabled by the flag @@ -1985,7 +1995,13 @@ , 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_level = NormalLevel } is = ImpSpec { is_decl = spec, is_item = ImpAll } -- | Look up the 'GREInfo' associated with the given 'Name' @@ -1999,6 +2015,8 @@ -- and looks up the TyThing in the type environment. -- -- See Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. + -- Note: This function is very similar to 'tcIfaceGlobal', it would be better to + -- use that if possible. = case nameModule_maybe nm of Nothing -> UnboundGRE Just mod -> @@ -2008,8 +2026,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 {- @@ -2055,6 +2074,28 @@ f :: C a => a -> a -- No, not ok class C a where f :: a -> a + +Note [Signatures in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class C a where + op :: a -> a + nop :: a -> a + + instance C ty where + bop :: [a] -> [a] + bop x = x + + nop :: [a] -> [a] + +When renameing the `bop` binding we'll give it an UnboundName (still with +OccName "bop") because `bop` is not a method of C. Then + +* when doing lookupSigOcc on `bop :: blah` we want to find `bop`, even though it + is an UnboundName (failing to do this causes #16610, and #25437) + +* When doing lookupSigOcc on `nop :: blah` we want to complain that there + is no accompanying binding, even though `nop` is a class method -} data HsSigCtxt @@ -2062,8 +2103,8 @@ -- See Note [Signatures for top level things] | LocalBindCtxt NameSet -- In a local binding, binding these names | ClsDeclCtxt Name -- Class decl for this class - | InstDeclCtxt NameSet -- Instance decl whose user-written method - -- bindings are for these methods + | InstDeclCtxt (OccEnv Name) -- Instance decl whose user-written method + -- bindings are described by this OccEnv | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types -- in the group @@ -2078,46 +2119,42 @@ lookupSigOccRn :: HsSigCtxt -> Sig GhcPs - -> LocatedA RdrName -> RnM (LocatedA Name) -lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) - -lookupSigOccRnN :: HsSigCtxt - -> Sig GhcPs - -> LocatedN RdrName -> RnM (LocatedN Name) -lookupSigOccRnN ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) + -> GenLocated (EpAnn ann) RdrName + -> RnM (GenLocated (EpAnn ann) Name) +lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (SigLikeSig sig) -- | Lookup a name in relation to the names in a 'HsSigCtxt' lookupSigCtxtOccRn :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> GenLocated (SrcSpanAnn' ann) RdrName - -> RnM (GenLocated (SrcSpanAnn' ann) Name) + -> SigLike -- ^ what are we looking for, e.g. a type family + -> GenLocated (EpAnn ann) RdrName + -> RnM (GenLocated (EpAnn ann) Name) lookupSigCtxtOccRn ctxt what = wrapLocMA $ \ rdr_name -> do { let also_try_tycons = False - ; mb_names <- lookupBindGroupOcc ctxt what rdr_name also_try_tycons + ; mb_names <- lookupBindGroupOcc ctxt what rdr_name also_try_tycons NoNamespaceSpecifier ; case mb_names of Right name NE.:| rest -> do { massertPpr (null rest) $ vcat (text "lookupSigCtxtOccRn" <+> ppr name : map (either (pprScopeError rdr_name) ppr) rest) ; return name } Left err NE.:| _ -> - do { addErr (mkTcRnNotInScope rdr_name err) + do { addErr $ TcRnNotInScope err rdr_name ; return (mkUnboundNameRdr rdr_name) } } lookupBindGroupOcc :: HsSigCtxt - -> SDoc + -> SigLike -- ^ what kind of thing are we looking for? -> RdrName -- ^ what to look up -> Bool -- ^ if the 'RdrName' we are looking up is in -- a value 'NameSpace', should we also look up -- in the type constructor 'NameSpace'? + -> NamespaceSpecifier -> RnM (NE.NonEmpty (Either NotInScopeError Name)) -- ^ Looks up the 'RdrName', expecting it to resolve to one of the -- bound names currently in scope. If not, return an appropriate error message. -- -- See Note [Looking up signature names]. -lookupBindGroupOcc ctxt what rdr_name also_try_tycon_ns +lookupBindGroupOcc ctxt what rdr_name also_try_tycon_ns ns_spec | Just n <- isExact_maybe rdr_name = do { mb_gre <- lookupExactOcc_either n ; return $ case mb_gre of @@ -2132,36 +2169,43 @@ | otherwise = case ctxt of - HsBootCtxt ns -> lookup_top (`elemNameSet` ns) - TopSigCtxt ns -> lookup_top (`elemNameSet` ns) - RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) + HsBootCtxt ns -> lookup_top (elem_name_set_with_namespace ns) + TopSigCtxt ns -> lookup_top (elem_name_set_with_namespace ns) + RoleAnnotCtxt ns -> lookup_top (elem_name_set_with_namespace ns) LocalBindCtxt ns -> lookup_group ns ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 - then return $ NE.singleton $ Right $ mkUnboundNameRdr rdr_name - else lookup_top (`elemNameSet` ns) + InstDeclCtxt occ_env-> lookup_inst occ_env where + elem_name_set_with_namespace ns n = check_namespace n && (n `elemNameSet` ns) - ns = occNameSpace occ - occ = rdrNameOcc rdr_name - relevant_gres = - RelevantGREs - { includeFieldSelectors = WantBoth - , lookupVariablesForFields = True - , lookupTyConsAsWell = also_try_tycon_ns } - ok_gre = greIsRelevant relevant_gres ns + check_namespace = coveredByNamespaceSpecifier ns_spec . nameNameSpace + namespace = occNameSpace occ + occ = rdrNameOcc rdr_name + ok_gre = greIsRelevant relevant_gres namespace + relevant_gres = RelevantGREs { includeFieldSelectors = WantBoth + , lookupVariablesForFields = True + , lookupTyConsAsWell = also_try_tycon_ns } + finish err gre | ok_gre gre - = NE.singleton (Right $ greName gre) + = NE.singleton (Right (greName gre)) | otherwise = NE.singleton (Left err) + succeed_with n = return $ NE.singleton $ Right n + lookup_cls_op cls - = NE.singleton <$> lookupSubBndrOcc AllDeprecationWarnings cls doc rdr_name - where - doc = text "method of class" <+> quotes (ppr cls) + = NE.singleton <$> + lookupSubBndrOcc AllDeprecationWarnings + (ParentGRE cls (IAmTyCon ClassFlavour)) + MethodOfClass rdr_name + lookup_inst occ_env -- See Note [Signatures in instance decls] + = case lookupOccEnv occ_env occ of + Nothing -> bale_out_with [] + Just n -> succeed_with n + lookup_top keep_me = do { env <- getGlobalRdrEnv ; let occ = rdrNameOcc rdr_name @@ -2184,7 +2228,7 @@ ; let candidates_msg = candidates $ localRdrEnvElts env ; case mname of Just n - | n `elemNameSet` bound_names -> return $ NE.singleton $ Right n + | n `elemNameSet` bound_names -> succeed_with n | otherwise -> bale_out_with local_msg Nothing -> bale_out_with candidates_msg } @@ -2207,16 +2251,16 @@ --------------- -lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] +lookupLocalTcNames :: HsSigCtxt -> SigLike -> NamespaceSpecifier -> RdrName -> RnM [(RdrName, Name)] -- GHC extension: look up both the tycon and data con or variable. -- Used for top-level fixity signatures and deprecations. -- Complain if neither is in scope. -- See Note [Fixity signature lookup] -lookupLocalTcNames ctxt what rdr +lookupLocalTcNames ctxt what ns_spec rdr = do { this_mod <- getModule ; let also_try_tycon_ns = True ; nms_eithers <- fmap (guard_builtin_syntax this_mod rdr) <$> - lookupBindGroupOcc ctxt what rdr also_try_tycon_ns + lookupBindGroupOcc ctxt what rdr also_try_tycon_ns ns_spec ; let (errs, names) = partitionEithers (NE.toList nms_eithers) ; when (null names) $ addErr (head errs) -- Bleat about one only @@ -2224,13 +2268,13 @@ where -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 guard_builtin_syntax this_mod rdr (Right name) - | Just _ <- isBuiltInOcc_maybe (occName rdr) + | isBuiltInOcc (occName rdr) , this_mod /= nameModule name = Left $ TcRnIllegalBuiltinSyntax what rdr | otherwise = Right (rdr, name) guard_builtin_syntax _ _ (Left err) - = Left $ mkTcRnNotInScope rdr err + = Left $ TcRnNotInScope err rdr dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName @@ -2331,14 +2375,14 @@ -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name lookupSyntaxExpr std_name = do { (name, fvs) <- lookupSyntaxName std_name - ; return (nl_HsVar name, fvs) } + ; return (genHsVar name, fvs) } lookupSyntax :: Name -- The standard name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard -- name lookupSyntax std_name - = do { (expr, fvs) <- lookupSyntaxExpr std_name - ; return (mkSyntaxExpr expr, fvs) } + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (mkRnSyntaxExpr name, fvs) } lookupSyntaxNames :: [Name] -- Standard names -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames @@ -2346,11 +2390,11 @@ lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (map (HsVar noExtField . noLocA) std_names, emptyFVs) + return (map (mkHsVar . noLocA) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } } + ; return (map (mkHsVar . noLocA) usr_names, mkFVs usr_names) } } {- @@ -2368,18 +2412,9 @@ -- Lookup operations for a qualified do. If the context is not a qualified -- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. -lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars) -lookupQualifiedDoExpr ctxt std_name - = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name - --- Like lookupQualifiedDoExpr but for producing SyntaxExpr. --- See Note [QualifiedDo]. -lookupQualifiedDo - :: HsStmtContext p - -> Name - -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupQualifiedDo :: HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) lookupQualifiedDo ctxt std_name - = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name + = first mkRnSyntaxExpr <$> lookupQualifiedDoName ctxt std_name lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) lookupNameWithQualifier std_name modName @@ -2387,11 +2422,72 @@ ; return (qname, unitFV qname) } -- See Note [QualifiedDo]. -lookupQualifiedDoName - :: HsStmtContext p - -> Name - -> RnM (Name, FreeVars) +lookupQualifiedDoName :: HsStmtContext fn -> Name -> RnM (Name, FreeVars) lookupQualifiedDoName ctxt std_name = case qualifiedDoModuleName_maybe ctxt of - Nothing -> lookupSyntaxName std_name + Nothing -> lookupSyntaxName std_name Just modName -> lookupNameWithQualifier std_name modName + +-------------------------------------------------------------------------------- +-- 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 + -> WithUserRdr Name -- ^ the 'Name' of the 'ConLike' + -> Bool +irrefutableConLikeRn hsc_env rdr_env comps (WithUserRdr _ 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 + +-------------------------------------------------------------------------------- diff --git a/GHC/Rename/Expr.hs b/GHC/Rename/Expr.hs --- a/GHC/Rename/Expr.hs +++ b/GHC/Rename/Expr.hs @@ -2,6 +2,8 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -9,7 +11,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -24,37 +25,32 @@ -} module GHC.Rename.Expr ( - rnLExpr, rnExpr, rnStmts, mkExpandedExpr, + rnLExpr, rnExpr, rnStmts, AnnoBody, UnexpectedStatement(..) ) where -import GHC.Prelude -import GHC.Data.FastString - -import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS - , rnMatchGroup, rnGRHS, makeMiniFixityEnv) +import GHC.Prelude hiding (head, init, last, scanl, tail) import GHC.Hs + import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env ( isBrackStage ) +import GHC.Tc.Utils.Env ( isBrackLevel ) import GHC.Tc.Utils.Monad -import GHC.Unit.Module ( getModule, isInteractiveModule ) + +import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS + , rnMatchGroup, rnGRHS, makeMiniFixityEnv) import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames - , bindLocalNames - , mapMaybeFvRn, mapFvRn - , warnUnusedLocalBinds, typeAppErr - , checkUnusedRecordWildcard - , wrapGenSpan, genHsIntegralLit, genHsTyLit - , genHsVar, genLHsVar, genHsApp, genHsApps - , genAppType, isIrrefutableHsPatRn ) +import GHC.Rename.Utils import GHC.Rename.Unbound ( reportUnboundName ) -import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName ) +import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice + , rnUntypedSpliceExpr, checkThLocalNameWithLift, checkThLocalNameNoLift ) import GHC.Rename.HsType import GHC.Rename.Pat + import GHC.Driver.DynFlags import GHC.Builtin.Names import GHC.Builtin.Types ( nilDataConName ) +import GHC.Unit.Module ( getModule, isInteractiveModule ) import GHC.Types.Basic (TypeOrKind (TypeLevel)) import GHC.Types.FieldLabel @@ -66,40 +62,53 @@ import GHC.Types.Unique.Set import GHC.Types.SourceText import GHC.Types.SrcLoc + import GHC.Utils.Misc -import GHC.Data.List.SetOps ( removeDupsOn ) -import GHC.Data.Maybe +import qualified GHC.Data.List.NonEmpty as NE import GHC.Utils.Error import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable +import GHC.Data.FastString +import GHC.Data.List.SetOps ( removeDupsOn ) +import GHC.Data.Maybe + import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad -import Data.List (unzip4, minimumBy) -import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.Foldable as Partial (maximum) +import Data.List (unzip4) +import Data.List.NonEmpty ( NonEmpty(..), head, init, last, nonEmpty, scanl, tail ) import Control.Arrow (first) import Data.Ord import Data.Array -import qualified Data.List.NonEmpty as NE +import GHC.Driver.Env (HscEnv) +import Data.Foldable (toList) {- Note [Handling overloaded and rebindable constructs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Nomenclature +------------- +* Expansion (`HsExpr GhcRn -> HsExpr GhcRn`): expand between renaming and + typechecking, using the `XXExprGhcRn` constructor of `HsExpr`. +* Desugaring (`HsExpr GhcTc -> Core.Expr`): convert the typechecked `HsSyn` to Core. This is done in GHC.HsToCore + + For overloaded constructs (overloaded literals, lists, strings), and rebindable constructs (e.g. if-then-else), our general plan is this, using overloaded labels #foo as an example: * In the RENAMER: transform HsOverLabel "foo" - ==> XExpr (HsExpansion (HsOverLabel #foo) - (fromLabel `HsAppType` "foo")) + ==> XExpr (ExpandedThingRn (HsOverLabel #foo) + (fromLabel `HsAppType` "foo")) We write this more compactly in concrete-syntax form like this #foo ==> fromLabel @"foo" - Recall that in (HsExpansion orig expanded), 'orig' is the original term + Recall that in (ExpandedThingRn orig expanded), 'orig' is the original term the user wrote, and 'expanded' is the expanded or desugared version to be typechecked. @@ -108,7 +117,7 @@ The typechecker (and desugarer) will never see HsOverLabel In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr -Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion. +Note [Rebindable syntax and XXExprGhcRn], which describes the use of XXExprGhcRn. RebindableSyntax: If RebindableSyntax is off we use the built-in 'fromLabel', defined in @@ -134,7 +143,7 @@ * OverLabel (overloaded labels, #lbl) #lbl ==> fromLabel @"lbl" As ever, we use lookupSyntaxName to look up 'fromLabel' - See Note [Overloaded labels] + See Note [Overloaded labels] below * ExplicitList (explicit lists [a,b,c]) When (and only when) OverloadedLists is on @@ -148,13 +157,8 @@ where `leftSection` and `rightSection` are representation-polymorphic wired-in Ids. See Note [Left and right sections] -* It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion` - form, because the renamer does precedence rearrangement after name - resolution. So the renamer leaves an OpApp as an OpApp. - - The typechecker turns `OpApp` into a use of `HsExpansion` - on the fly, in GHC.Tc.Gen.Head.splitHsApps. RebindableSyntax - does not affect this. +* To understand why expansions for `OpApp` is done in `GHC.Tc.Gen.Head.splitHsApps` + see Note [Doing XXExprGhcRn in the Renamer vs Typechecker] below. * RecordUpd: we desugar record updates into case expressions, in GHC.Tc.Gen.Expr.tcExpr. @@ -176,21 +180,25 @@ See Note [Record Updates] in GHC.Tc.Gen.Expr for more details. - This is done in the typechecker, not the renamer, for two reasons: + To understand Why is this done in the typechecker, and not in the renamer + see Note [Doing XXExprGhcRn in the Renamer vs Typechecker] - - (Until we implement GHC proposal #366) - We need to know the type of the record to disambiguate its fields. +* HsDo: We expand `HsDo` statements in `Ghc.Tc.Gen.Do`. - - We use the type signature of the data constructor to provide IdSigs - to the let-bound variables (x', y' in the example above). This is - needed to accept programs such as + - For example, a user written code: - data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } - foo r = r { f = \ k -> (k 3, k 'x') } + do { x <- e1 ; g x ; return (f x) } - in which an updated field has a higher-rank type. - See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr. + is expanded to: + (>>=) e1 + (\x -> ((>>) (g x) + (return (f x)))) + + See Note [Expanding HsDo with XXExprGhcRn] in `Ghc.Tc.Gen.Do` for more details. + To understand why is this done in the typechecker and not in the renamer. + See Note [Doing XXExprGhcRn in the Renamer vs Typechecker] + Note [Overloaded labels] ~~~~~~~~~~~~~~~~~~~~~~~~ For overloaded labels, note that we /only/ apply `fromLabel` to the @@ -209,6 +217,66 @@ And those inferred kind quantifiers will indeed be instantiated when we typecheck the renamed-syntax call (fromLabel @"foo"). + +Note [Doing XXExprGhcRn in the Renamer vs Typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand some `HsExpr GhcRn` code at various places, usually, on the fly, +depending on when it is more convenient. It may be beneficial to have a +separate `HsExpr GhcRn -> HsExpr GhcRn` pass that does this expansion uniformly +in the future when we have enough cases to cater for. For the time being, +this note documents which language feature is expanded at which phase, +and the reasons for doing so. + + ** `HsIf` Expansions + -------------------- + `HsIf` expansions are expanded in the Renamer becuase it is more convinent + to do so there and then not worry about it in the later stage. + `-XRebindableSyntax` is used to decide whether we use the `HsIf` or user defined if + + + ** `OpApp` Expansions + --------------------- + The typechecker turns `OpApp` into a use of `XXExprGhcRn` + on the fly, in `GHC.Tc.Gen.Head.splitHsApps`. + The language extension `RebindableSyntax` does not affect this behaviour. + + It's a bit painful to transform `OpApp e1 op e2` to a `XXExprGhcRn` + form, because the renamer does precedence rearrangement after name + resolution. So the renamer leaves an `OpApp` as an `OpApp`. + + ** Record Update Syntax `RecordUpd` Expansions + ---------------------------------------------- + This is done in the typechecker on the fly (`GHC.Tc.Expr.tcExpr`), and not the renamer, for two reasons: + + - (Until we implement GHC proposal #366) + We need to know the type of the record to disambiguate its fields. + + - We use the type signature of the data constructor to provide `IdSigs` + to the let-bound variables (x', y' in the example of + Note [Handling overloaded and rebindable constructs] above). + This is needed to accept programs such as + + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } + + in which an updated field has a higher-rank type. + See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr. + + ** `HsDo` Statement Expansions + ----------------------------------- + The expansion for do block statements is done on the fly right before typechecking in `GHC.Tc.Gen.Expr` + using `GHC.Tc.Gen.Do.expandDoStmts`. There are 2 main reasons: + + - During the renaming phase, we may not have all the constructor details `HsConDetails` populated in the + data structure. This would result in an inaccurate irrefutability analysis causing + the continuation lambda body to be wrapped with `fail` alternatives when not needed. + See Part 1. of Note [Expanding HsDo with XXExprGhcRn] (test pattern-fails.hs) + + - If the expansion is done on the fly during renaming, expressions that + have explicit type applications using (-XTypeApplciations) will not work (cf. Let statements expansion) + as the name freshening happens from the root of the AST to the leaves, + but the expansion happens in the opposite direction (from leaves to the root), + causing the renamer to miss the scoped type variables. -} {- @@ -238,27 +306,19 @@ rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars) --- Separated from rnExpr because it's also used --- when renaming infix expressions -finishHsVar (L l name) - = do { this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod name) $ - checkThLocalName name - ; return (HsVar noExtField (L (la2na l) name), unitFV name) } - -rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) -rnUnboundVar v = do +rnUnboundVar :: SrcSpanAnnN -> RdrName -> RnM (HsExpr GhcRn, FreeVars) +rnUnboundVar l v = do deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables -- See Note [Reporting unbound names] for difference between qualified and unqualified names. - unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ()) - return (HsUnboundVar noExtField v, emptyFVs) + unless (isUnqual v || deferOutofScopeVariables) $ + void $ reportUnboundName WL_Term v + return (HsHole (HoleVar (L l v)), emptyFVs) rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags ; mb_gre <- lookupExprOccRn v ; case mb_gre of { - Nothing -> rnUnboundVar v ; + Nothing -> rnUnboundVar l v ; Just gre -> do { let nm = greName gre info = greInfo gre @@ -268,10 +328,8 @@ -- matching GRE and add a name clash error -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). -> do { let sel_name = flSelector $ recFieldLabel fld_info - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod sel_name) $ - checkThLocalName sel_name - ; return (HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) + ; checkThLocalNameNoLift (L (l2l l) (WithUserRdr v sel_name)) + ; return (XExpr (HsRecSelRn (FieldOcc v (L l sel_name))), unitFV sel_name) } | nm == nilDataConName -- Treat [] as an ExplicitList, so that @@ -281,43 +339,50 @@ -> rnExpr (ExplicitList noAnn []) | otherwise - -> finishHsVar (L (na2la l) nm) + -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm)) + ; return (res_expr, unitFV nm) } }}} + rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) -rnExpr (HsUnboundVar _ v) - = return (HsUnboundVar noExtField v, emptyFVs) +rnExpr (HsHole h) + = return (HsHole h, emptyFVs) -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] -rnExpr (HsOverLabel _ src v) +rnExpr (HsOverLabel src v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName - ; return ( mkExpandedExpr (HsOverLabel noAnn src v) $ - HsAppType noExtField (genLHsVar from_label) noHsTok hs_ty_arg + ; 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 - ; return (HsLit x(convertLit lit), emptyFVs) } + ; return (HsLit x (convertLit lit), emptyFVs) } rnExpr (HsOverLit x lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] ; case mb_neg of Nothing -> return (HsOverLit x lit', fvs) Just neg -> - return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit')) + return (HsApp noExtField (noLocA neg) (noLocA (HsOverLit x lit')) , fvs ) } rnExpr (HsApp x fun arg) @@ -325,12 +390,12 @@ ; (arg',fvArg) <- rnLExpr arg ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType _ fun at arg) +rnExpr (HsAppType _ fun arg) = do { type_app <- xoptM LangExt.TypeApplications ; unless type_app $ addErr $ typeAppErr TypeLevel $ hswc_body arg ; (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType NoExtField fun' at arg', fvFun `plusFV` fvArg) } + ; return (HsAppType noExtField fun' arg', fvFun `plusFV` fvArg) } rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -343,9 +408,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 _ (WithUserRdr _ n))) -> lookupFixityRn n + L _ (XExpr (HsRecSelRn f)) -> lookupFieldFixityRn f + _ -> return (Fixity minPrecedence InfixL) -- c.f. lookupFixity for unbound ; lexical_negation <- xoptM LangExt.LexicalNegation @@ -366,7 +431,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')) @@ -374,11 +439,11 @@ rnExpr (HsProjection _ fs) = do { (getField, fv_getField) <- lookupSyntaxName getFieldName - ; circ <- lookupOccRn compose_RDR - ; let fs' = fmap rnDotFieldOcc fs + ; circ <- lookupOccRn WL_TermVariable compose_RDR + ; 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) } ------------------------------------------ @@ -392,17 +457,17 @@ --------------------------------------------- -- Sections -- See Note [Parsing sections] in GHC.Parser -rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar) +rnExpr (HsPar _ (L loc (section@(SectionL {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar x lpar (L loc section') rpar, fvs) } + ; return (HsPar noExtField (L loc section'), fvs) } -rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar) +rnExpr (HsPar _ (L loc (section@(SectionR {})))) = do { (section', fvs) <- rnSection section - ; return (HsPar x lpar (L loc section') rpar, fvs) } + ; return (HsPar noExtField (L loc section'), fvs) } -rnExpr (HsPar x lpar e rpar) +rnExpr (HsPar _ e) = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar x lpar e' rpar, fvs_e) } + ; return (HsPar noExtField e', fvs_e) } rnExpr expr@(SectionL {}) = do { addErr (sectionErr expr); rnSection expr } @@ -417,23 +482,19 @@ rn_prag :: HsPragE GhcPs -> HsPragE GhcRn rn_prag (HsPragSCC x ann) = HsPragSCC x ann -rnExpr (HsLam x matches) - = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches - ; return (HsLam x matches', fvMatch) } - -rnExpr (HsLamCase x lc_variant matches) - = do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches - ; return (HsLamCase x lc_variant matches', fvs_ms) } +rnExpr (HsLam x lam_variant matches) + = do { (matches', fvs_ms) <- rnMatchGroup (LamAlt lam_variant) rnLExpr matches + ; return (HsLam x lam_variant matches', fvs_ms) } rnExpr (HsCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches ; return (HsCase CaseAlt new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet _ tkLet binds tkIn expr) +rnExpr (HsLet _ binds expr) = rnLocalBindsAndThen binds $ \binds' _ -> do { (expr',fvExpr) <- rnLExpr expr - ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) } + ; return (HsLet noExtField binds' expr', fvExpr) } rnExpr (HsDo _ do_or_lc (L l stmts)) = do { ((stmts1, _), fvs1) <- @@ -441,7 +502,6 @@ (\ _ -> return ((), emptyFVs)) ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1 ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) } - -- ExplicitList: see Note [Handling overloaded and rebindable constructs] rnExpr (ExplicitList _ exps) = do { (exps', fvs) <- rnExprs exps @@ -450,10 +510,11 @@ then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) hs_lit = genHsIntegralLit lit_n - exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list] + exp_list = genHsApps' (L (noAnnSrcSpan loc) from_list_n_name) [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } @@ -470,17 +531,19 @@ = do { (expr', fvs) <- rnLExpr expr ; return (ExplicitSum noExtField alt arity expr', fvs) } -rnExpr (RecordCon { rcon_con = con_id +rnExpr (RecordCon { rcon_con = con_rdr , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) - = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id - ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds + = do { L con_loc con_name <- lookupLocatedOccRnConstr con_rdr + ; let qcon = WithUserRdr (unLoc con_rdr) con_name + ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon qcon) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds - ; let rec_binds' = HsRecFields { rec_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' } + , rcon_con = L con_loc qcon + , rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n) + mk_hs_var l n = mkHsVarWithUserRdr (unLoc con_rdr) (L (noAnnSrcSpan l) n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld) ; return (L l (fld { hfbRHS = arg' }), fvs) } @@ -519,7 +582,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 @@ -530,24 +592,7 @@ -- HsIf: see Note [Handling overloaded and rebindable constructs] -- Because of the coverage checker it is most convenient /not/ to -- expand HsIf; unless we are in rebindable syntax. -rnExpr (HsIf _ p b1 b2) - = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; let fvs_if = plusFVs [fvP, fvB1, fvB2] - rn_if = HsIf noExtField p' b1' b2' - - -- Deal with rebindable syntax - -- See Note [Handling overloaded and rebindable constructs] - ; mb_ite <- lookupIfThenElse - ; case mb_ite of - Nothing -- Non rebindable-syntax case - -> return (rn_if, fvs_if) - - Just ite_name -- Rebindable-syntax case - -> do { let ds_if = genHsApps ite_name [p', b1', b2'] - fvs = plusFVs [fvs_if, unitFV ite_name] - ; return (mkExpandedExpr rn_if ds_if, fvs) } } +rnExpr (HsIf _ p b1 b2) = rnHsIf p b1 b2 rnExpr (HsMultiIf _ alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts @@ -564,6 +609,30 @@ else return (ArithSeq noExtField Nothing new_seq, fvs) } +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) <- rnHsMultAnnWith rnLExpr mult + ; (res', fvs3) <- rnLExpr res + ; checkTypeSyntaxExtension FunctionArrowSyntax + ; return (HsFunArr noExtField mult' arg' res', plusFVs [fvs1, fvs2, fvs3]) } + {- ************************************************************************ * * @@ -587,9 +656,9 @@ unlessXOptM LangExt.StaticPointers $ addErr $ TcRnIllegalStaticExpression e (expr',fvExpr) <- rnLExpr expr - stage <- getStage - case stage of - Splice _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e + level <- getThLevel + case level of + Splice _ _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e _ -> return () mod <- getModule let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr @@ -608,9 +677,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 * * ********************************************************************* -} @@ -639,9 +721,9 @@ -- Note [Left and right sections] ; let rn_section = SectionL x expr' op' ds_section - | postfix_ops = HsApp noAnn op' expr' + | postfix_ops = HsApp noExtField op' expr' | otherwise = genHsApps leftSectionName - [wrapGenSpan $ HsApp noAnn op' expr'] + [wrapGenSpan $ HsApp noExtField op' expr'] ; return ( mkExpandedExpr rn_section ds_section , fvs_op `plusFV` fvs_expr) } @@ -773,8 +855,8 @@ Note [Reporting unbound names] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Faced with an out-of-scope `RdrName` there are two courses of action -A. Report an error immediately (and return a HsUnboundVar). This will halt GHC after the renamer is complete -B. Return a HsUnboundVar without reporting an error. That will allow the typechecker to run, which in turn +A. Report an error immediately (and return a `HsHole (HoleVar ...)`). This will halt GHC after the renamer is complete +B. Return a `HsHole (HoleVar ...)` without reporting an error. That will allow the typechecker to run, which in turn can give a better error message, notably giving the type of the variable via the "typed holes" mechanism. When `-fdefer-out-of-scope-variables` is on we follow plan B. @@ -801,11 +883,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 (fmap (fmap rnDotFieldOcc) fls) {- ************************************************************************ @@ -856,21 +938,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) @@ -878,13 +949,14 @@ ; (arg',fvArg) <- rnLExpr arg ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam _ matches) - = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches - ; return (HsCmdLam noExtField matches', fvMatch) } +rnCmd (HsCmdLam x lam_variant matches) + = do { let ctxt = ArrowMatchCtxt $ ArrowLamAlt lam_variant + ; (new_matches, ms_fvs) <- rnMatchGroup ctxt rnLCmd matches + ; return (HsCmdLam x lam_variant new_matches, ms_fvs) } -rnCmd (HsCmdPar x lpar e rpar) +rnCmd (HsCmdPar _ e) = do { (e', fvs_e) <- rnLCmd e - ; return (HsCmdPar x lpar e' rpar, fvs_e) } + ; return (HsCmdPar noExtField e', fvs_e) } rnCmd (HsCmdCase _ expr matches) = do { (new_expr, e_fvs) <- rnLExpr expr @@ -892,11 +964,6 @@ ; return (HsCmdCase noExtField new_expr new_matches , e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdLamCase x lc_variant matches) - = do { (new_matches, ms_fvs) <- - rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches - ; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) } - rnCmd (HsCmdIf _ _ p b1 b2) = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 @@ -909,10 +976,10 @@ ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet _ tkLet binds tkIn cmd) +rnCmd (HsCmdLet _ binds cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd - ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) } + ; return (HsCmdLet noExtField binds' cmd', fvExpr) } rnCmd (HsCmdDo _ (L l stmts)) = do { ((stmts', _), fvs) <- @@ -935,20 +1002,18 @@ = unitFV appAName methodNamesCmd (HsCmdArrForm {}) = emptyFVs -methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c methodNamesCmd (HsCmdIf _ _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c -methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match -methodNamesCmd (HsCmdCase _ _ matches) - = methodNamesMatch matches `addOneFV` choiceAName -methodNamesCmd (HsCmdLamCase _ _ matches) - = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (HsCmdCase _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName +methodNamesCmd (HsCmdLam _ LamSingle matches) = methodNamesMatch matches +methodNamesCmd (HsCmdLam _ _ matches) = methodNamesMatch matches `addOneFV` choiceAName --methodNamesCmd _ = emptyFVs -- Other forms can't occur in commands, but it's not convenient @@ -965,7 +1030,8 @@ ------------------------------------------------- -- gaw 2004 methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars -methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) +methodNamesGRHSs (GRHSs _ grhss _) + = foldl' (flip plusFV) emptyFVs (NE.map methodNamesGRHS grhss) ------------------------------------------------- @@ -989,7 +1055,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 @@ -1058,7 +1124,7 @@ -- | Rename some Stmts rnStmts :: AnnoBody body - => HsStmtContext GhcRn + => HsStmtContextRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> [LStmt GhcPs (LocatedA (body GhcPs))] @@ -1086,7 +1152,7 @@ | otherwise = False -- don't apply the transformation inside TH brackets, because -- GHC.HsToCore.Quote does not handle ApplicativeDo. - ; in_th_bracket <- isBrackStage <$> getStage + ; in_th_bracket <- isBrackLevel <$> getThLevel ; if ado_is_on && is_do_expr && not in_th_bracket then do { traceRn "ppsfa" (ppr stmts) ; rearrangeForApplicativeDo ctxt stmts } @@ -1094,14 +1160,14 @@ -- | strip the FreeVars annotations from statements noPostProcessStmts - :: HsStmtContext GhcRn + :: HsStmtContextRn -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) rnStmtsWithFreeVars :: AnnoBody body - => HsStmtContext GhcRn + => HsStmtContextRn -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars)) -> [LStmt GhcPs (LocatedA (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) @@ -1164,7 +1230,7 @@ -} rnStmt :: AnnoBody body - => HsStmtContext GhcRn + => HsStmtContextRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -- ^ How to rename the body of the statement -> LStmt GhcPs (LocatedA (body GhcPs)) @@ -1183,7 +1249,7 @@ else return (noSyntaxExpr, emptyFVs) -- The 'return' in a LastStmt is used only -- for MonadComp; and we don't want to report - -- "non in scope: return" in other cases + -- "not in scope: return" in other cases -- #15607 ; (thing, fvs3) <- thing_inside [] @@ -1210,10 +1276,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), @@ -1306,50 +1371,53 @@ , 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. HsStmtContext GhcRn +rnParallelStmts :: forall thing. HsStmtContextRn -> SyntaxExpr GhcRn - -> [ParStmtBlock GhcPs GhcPs] + -> NonEmpty (ParStmtBlock GhcPs GhcPs) -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) + -> RnM ((NonEmpty (ParStmtBlock GhcRn GhcRn), thing), FreeVars) -- Note [Renaming parallel Stmts] rnParallelStmts ctxt return_op segs thing_inside = do { orig_lcl_env <- getLocalRdrEnv - ; rn_segs orig_lcl_env [] segs } + ; rn_segs (:|) orig_lcl_env [] segs } where - rn_segs :: LocalRdrEnv - -> [Name] -> [ParStmtBlock GhcPs GhcPs] - -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) - rn_segs _ bndrs_so_far [] - = do { let (bndrs', dups) = removeDupsOn nameOccName bndrs_so_far - ; mapM_ dupErr dups - ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') - ; return (([], thing), fvs) } - - rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) + -- The `cons` argument is how we cons the first `ParStmtBlock` onto the rest. + -- It is called with `cons = (:)` or `cons = (:|)`. + -- Thus, the return type `parStmtBlocks` is `[ParStmtBlock _ _]` or + -- `NonEmpty (ParStmtBlock _ _)`, in turn. + rn_segs :: (ParStmtBlock GhcRn GhcRn -> [ParStmtBlock GhcRn GhcRn] -> parStmtBlocks) + -> LocalRdrEnv + -> [Name] -> NonEmpty (ParStmtBlock GhcPs GhcPs) + -> RnM ((parStmtBlocks, thing), FreeVars) + rn_segs cons env bndrs_so_far (ParStmtBlock x stmts _ _ :| segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt rnExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do - { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs + { ((segs', thing), fvs) <- rn_segs1 env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } ; let seg' = ParStmtBlock x stmts' used_bndrs return_op - ; return ((seg':segs', thing), fvs) } + ; return ((cons seg' segs', thing), fvs) } + rn_segs1 _ bndrs [] = do + { let (bndrs', dups) = removeDupsOn nameOccName bndrs + ; mapM_ dupErr dups + ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') + ; return (([], thing), fvs) } + rn_segs1 env bndrs (x:xs) = rn_segs (:) env bndrs (x:|xs) + dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs) -lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupQualifiedDoStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupStmtName, but respects QualifiedDo lookupQualifiedDoStmtName ctxt n = case qualifiedDoModuleName_maybe ctxt of Nothing -> lookupStmtName ctxt n Just modName -> - first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName + first mkRnSyntaxExpr <$> lookupNameWithQualifier n modName -lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupStmtName :: HsStmtContextRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupSyntax, but respects contexts lookupStmtName ctxt n | rebindableContext ctxt @@ -1357,23 +1425,23 @@ | otherwise = return (mkRnSyntaxExpr n, emptyFVs) -lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupStmtNamePoly :: HsStmtContextRn -> Name -> RnM (HsExpr GhcRn, FreeVars) lookupStmtNamePoly ctxt name | rebindableContext ctxt = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on - then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar noExtField (noLocA fm), unitFV fm) } + then do { fm <- lookupOccRn WL_TermVariable (nameRdrName name) + ; return (mkHsVar (noLocA fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs) + not_rebindable = return (mkHsVar (noLocA name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable -- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows -rebindableContext :: HsStmtContext GhcRn -> Bool +rebindableContext :: HsStmtContextRn -> Bool rebindableContext ctxt = case ctxt of HsDoStmt flavour -> rebindableDoStmtContext flavour ArrowExpr -> False @@ -1429,7 +1497,7 @@ -- wrapper that does both the left- and right-hand sides rnRecStmtsAndThen :: AnnoBody body - => HsStmtContext GhcRn + => HsStmtContextRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [LStmt GhcPs (LocatedA (body GhcPs))] -- assumes that the FreeVars returned includes @@ -1448,7 +1516,7 @@ ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv) -- Fake uses of variables introduced implicitly (warning suppression, see #4404) rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) - implicit_uses = mkNameSet $ concatMap snd $ rec_uses + implicit_uses = mkNameSet $ concatMap (concatMap implFlBndr_binders . snd) $ rec_uses ; bindLocalNamesFV bound_names $ addLocalFixities fix_env bound_names $ do @@ -1512,9 +1580,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" @@ -1534,7 +1599,7 @@ -- right-hand-sides rn_rec_stmt :: AnnoBody body => - HsStmtContext GhcRn + HsStmtContextRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars) @@ -1589,11 +1654,8 @@ 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 - => HsStmtContext GhcRn + => HsStmtContextRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] @@ -1603,7 +1665,7 @@ ; return (concat segs_s) } --------------------------------------------- -segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn +segmentRecStmts :: SrcSpan -> HsStmtContextRn -> Stmt GhcRn (LocatedA (body GhcRn)) -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> (FreeVars, Bool) @@ -1743,9 +1805,9 @@ be used later. -} -glomSegments :: HsStmtContext GhcRn +glomSegments :: HsStmtContextRn -> [Segment (LStmt GhcRn body)] - -> [Segment [LStmt GhcRn body]] + -> [Segment (NonEmpty (LStmt GhcRn body))] -- Each segment has a non-empty list of Stmts -- See Note [Glomming segments] @@ -1761,7 +1823,7 @@ seg_defs = plusFVs ds `plusFV` defs seg_uses = plusFVs us `plusFV` uses seg_fwds = plusFVs fs `plusFV` fwds - seg_stmts = stmt : concat ss + seg_stmts = stmt :| concatMap toList ss grab :: NameSet -- The client -> [Segment a] @@ -1777,24 +1839,23 @@ ---------------------------------------------------- segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn)) -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]] + -> [Segment (NonEmpty (LStmt GhcRn (LocatedA (body GhcRn))))] -- Each Segment has a non-empty list of Stmts -> FreeVars -- Free vars used 'later' -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later - = assert (not (null ss)) - (new_stmt : later_stmts, later_uses `plusFV` uses) + = (new_stmt : later_stmts, later_uses `plusFV` uses) where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later new_stmt | non_rec = head ss | otherwise = L (getLoc (head ss)) rec_stmt - rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss + rec_stmt = empty_rec_stmt { recS_stmts = noLocA (toList ss) , recS_later_ids = nameSetElemsStable used_later , recS_rec_ids = nameSetElemsStable fwds } -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] - non_rec = isSingleton ss && isEmptyNameSet fwds + non_rec = NE.isSingleton ss && isEmptyNameSet fwds used_later = defs `intersectNameSet` later_uses -- The ones needed after the RecStmt @@ -1829,7 +1890,7 @@ (y,z) <- (,) <$> B x <*> C return (f x y z) -But this isn't enough! A and C were also independent, and this +But this isn't enough! If A and C were also independent, then this transformation loses the ability to do A and C in parallel. The algorithm works by first splitting the sequence of statements into @@ -1970,10 +2031,9 @@ rearrangeForApplicativeDo ctxt [(one,_)] = do (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName - let pure_expr = nl_HsVar pure_name let monad_names = MonadNames { return_name = return_name , pure_name = pure_name } - return $ case needJoin monad_names [one] (Just pure_expr) of + return $ case needJoin monad_names [one] (Just pure_name) of (False, one') -> (one', emptyNameSet) (True, _) -> ([one], emptyNameSet) rearrangeForApplicativeDo ctxt stmts0 = do @@ -2054,9 +2114,10 @@ case segments [ stmt_arr ! i | i <- [lo..hi] ] of [] -> panic "mkStmtTree" [_one] -> split lo hi - segs -> (StmtTreeApplicative trees, maximum costs) + segs -> (StmtTreeApplicative trees, Partial.maximum costs) where bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs + -- We know `costs` must be non-empty, as `length segs >= 2` here. (trees,costs) = unzip (map (uncurry split) (tail bounds)) -- find the best place to split the segment [lo..hi] @@ -2075,21 +2136,21 @@ -- in the case that these two have the same cost do we need -- to do the exhaustive search. -- - ((before,c1),(after,c2)) - | hi - lo == 1 - = ((StmtTreeOne (stmt_arr ! lo), 1), - (StmtTreeOne (stmt_arr ! hi), 1)) - | left_cost < right_cost - = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) - | left_cost > right_cost - = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) - | otherwise = minimumBy (comparing cost) alternatives + ((before,c1),(after,c2)) = case nonEmpty [lo .. hi-1] of + Nothing -> + ( (StmtTreeOne (stmt_arr ! lo), 1), + (StmtTreeOne (stmt_arr ! hi), 1) ) + Just ks + | left_cost < right_cost + -> ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) + | left_cost > right_cost + -> ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) + | otherwise -> minimumBy (comparing cost) + [ (arr ! (lo,k), arr ! (k+1,hi)) | k <- ks ] where (left, left_cost) = arr ! (lo,hi-1) (right, right_cost) = arr ! (lo+1,hi) cost ((_,c1),(_,c2)) = c1 + c2 - alternatives = [ (arr ! (lo,k), arr ! (k+1,hi)) - | k <- [lo .. hi-1] ] -- | Turn the ExprStmtTree back into a sequence of statements, using @@ -2114,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 @@ -2135,8 +2196,8 @@ }] False tail' stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_)) tail _tail_fvs = do - (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName - return $ case needJoin monad_names tail (Just pure_expr) of + (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName + return $ case needJoin monad_names tail (Just pure_name) of (False, tail') -> (let_stmt : tail', emptyNameSet) (True, _) -> (let_stmt : tail, emptyNameSet) @@ -2150,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 @@ -2186,13 +2250,13 @@ tup = mkBigLHsVarTup pvars noExtField (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset (mb_ret, fvs1) <- - if | L _ ApplicativeStmt{} <- last stmts' -> + if | Just (L _ (XStmtLR ApplicativeStmt{})) <- lastMaybe stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do -- Need 'pureAName' and not 'returnMName' here, so that it requires -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed). - (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName - let expr = HsApp noComments (noLocA ret) tup + (pure_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName + let expr = HsApp noExtField (noLocA (genHsVar pure_name)) tup return (expr, emptyFVs) return ( ApplicativeArgMany { xarg_app_arg_many = noExtField @@ -2237,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) @@ -2253,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] @@ -2275,42 +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{} -> True + InvisPat{} -> True + XPat ext -> case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> dataConCantHappen ext -#endif 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] @@ -2321,11 +2410,16 @@ -} -hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool -hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat - , is_body_stmt = False}) = - not (isIrrefutableHsPatRn 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 @@ -2365,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) @@ -2409,7 +2503,11 @@ ; return (Just join_op, fvs) } else return (Nothing, emptyNameSet) - ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField + -- We cannot really say where the ApplicativeStmt is located with more accuracy + -- 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) $ XStmtLR $ ApplicativeStmt noExtField (zip (fmap_op : repeat ap_op) args) mb_join ; return ( applicative_stmt : body_stmts @@ -2424,7 +2522,7 @@ -> [ExprLStmt GhcRn] -- If this is @Just pure@, replace return by pure -- If this is @Nothing@, strip the return/pure - -> Maybe (HsExpr GhcRn) + -> Maybe Name -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] _mb_pure = (False, []) -- we're in an ApplicativeArg needJoin monad_names [L loc (LastStmt _ e _ t)] mb_pure @@ -2445,30 +2543,30 @@ -> LHsExpr GhcRn -- If this is @Just pure@, replace return by pure -- If this is @Nothing@, strip the return/pure - -> Maybe (HsExpr GhcRn) + -> Maybe Name -> Maybe (LHsExpr GhcRn, Maybe Bool) -isReturnApp monad_names (L _ (HsPar _ _ expr _)) mb_pure = +isReturnApp monad_names (L _ (HsPar _ expr)) mb_pure = isReturnApp monad_names expr mb_pure isReturnApp monad_names (L loc e) mb_pure = case e of OpApp x l op r - | Just pure_expr <- mb_pure, is_return l, is_dollar op -> - Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing) + | Just pure_name <- mb_pure, is_return l, is_dollar op -> + Just (L loc (OpApp x (to_pure l pure_name) op r), Nothing) | is_return l, is_dollar op -> Just (r, Just True) HsApp x f arg - | Just pure_expr <- mb_pure, is_return f -> - Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing) + | Just pure_name <- mb_pure, is_return f -> + Just (L loc (HsApp x (to_pure f pure_name) arg), Nothing) | is_return f -> Just (arg, Just False) _otherwise -> Nothing where - is_var f (L _ (HsPar _ _ e _)) = is_var f e - is_var f (L _ (HsAppType _ e _ _)) = is_var f e - is_var f (L _ (HsVar _ (L _ r))) = f r + is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsAppType _ e _)) = is_var f e + is_var f (L _ (HsVar _ (L _ (WithUserRdr _q r)))) = f r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False is_return = is_var (\n -> n == return_name monad_names || n == pure_name monad_names) - to_pure (L loc _) pure_expr = L loc pure_expr + to_pure (L loc _) pure_name = L loc (genHsVar pure_name) is_dollar = is_var (`hasKey` dollarIdKey) {- @@ -2479,7 +2577,7 @@ ************************************************************************ -} -checkEmptyStmts :: HsStmtContext GhcRn -> RnM () +checkEmptyStmts :: HsStmtContextRn -> RnM () -- We've seen an empty sequence of Stmts... is that ok? checkEmptyStmts ctxt = mapM_ (addErr . TcRnEmptyStmtsGroup) mb_err @@ -2493,7 +2591,7 @@ ---------------------- checkLastStmt :: AnnoBody body - => HsStmtContext GhcRn + => HsStmtContextRn -> LStmt GhcPs (LocatedA (body GhcPs)) -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) @@ -2525,7 +2623,7 @@ -- Checking when a particular Stmt is ok checkStmt :: AnnoBody body - => HsStmtContext GhcRn + => HsStmtContextRn -> LStmt GhcPs (LocatedA (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) @@ -2541,7 +2639,7 @@ emptyInvalid = NotValid Nothing -- Invalid, and no extension to suggest okStmt, okDoStmt, okCompStmt, okParStmt - :: DynFlags -> HsStmtContext GhcRn + :: DynFlags -> HsStmtContextRn -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to a generic error message @@ -2555,7 +2653,7 @@ TransStmtCtxt ctxt -> okStmt dflags ctxt stmt okDoFlavourStmt - :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn + :: DynFlags -> HsDoFlavour -> HsStmtContextRn -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) okDoFlavourStmt dflags flavour ctxt stmt = case flavour of DoExpr{} -> okDoStmt dflags ctxt stmt @@ -2605,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 () @@ -2625,21 +2722,27 @@ --------- -monadFailOp :: LPat GhcPs - -> HsStmtContext GhcRn +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 | isIrrefutableHsPatRn 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] @@ -2677,7 +2780,7 @@ Nothing -> M.fail (fromString "Pattern match error") -} -getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op +getMonadFailOp :: HsStmtContext fn -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op getMonadFailOp ctxt = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags @@ -2689,16 +2792,16 @@ reallyGetMonadFailOp rebindableSyntax overloadedStrings | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do - (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName + (failName, failFvs) <- lookupQualifiedDoName ctxt failMName (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName let arg_lit = mkVarOccFS (fsLit "arg") arg_name <- newSysName arg_lit let arg_syn_expr = nlHsVar arg_name body :: LHsExpr GhcRn = - nlHsApp (noLocA failExpr) + nlHsApp (noLocA (genHsVar failName)) (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr) let failAfterFromStringExpr :: HsExpr GhcRn = - unLoc $ mkHsLam [noLocA $ 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) @@ -2707,20 +2810,32 @@ {- ********************************************************************* * * - Generating code for HsExpanded + Generating code for ExpandedThingRn See Note [Handling overloaded and rebindable constructs] * * ********************************************************************* -} --- | Build a 'HsExpansion' out of an extension constructor, --- and the two components of the expansion: original and --- desugared expressions. -mkExpandedExpr - :: HsExpr GhcRn -- ^ source expression - -> HsExpr GhcRn -- ^ expanded expression - -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion' -mkExpandedExpr a b = XExpr (HsExpanded a b) +-- | Expand `HsIf` if rebindable syntax is turned on +-- See Note [Handling overloaded and rebindable constructs] +rnHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnHsIf p b1 b2 + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; let fvs_if = plusFVs [fvP, fvB1, fvB2] + rn_if = HsIf noExtField p' b1' b2' + -- Deal with rebindable syntax + ; mb_ite <- lookupIfThenElse + ; case mb_ite of + Nothing -- Non rebindable-syntax case + -> return (rn_if, fvs_if) + + Just ite_name -- Rebindable-syntax case + -> do { let ds_if = genHsApps ite_name [p', b1', b2'] + fvs = plusFVs [fvs_if, unitFV ite_name] + ; return (mkExpandedExpr rn_if ds_if, fvs) } } + ----------------------------------------- -- Bits and pieces for RecordDotSyntax. -- @@ -2729,18 +2844,18 @@ -- mkGetField arg field calculates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn -mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field) +mkGetField get_field arg field = unLoc (head $ mkGet get_field (arg :| []) field) -- mkSetField a field b calculates a set_field @field expression. --- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b"). +-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' to a on b"). +-- NB: the order of aruments is specified by GHC Proposal 583: HasField redesign. mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn mkSetField set_field a (L _ (FieldLabelString field)) b = - genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b + genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) b) a -mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn] -mkGet get_field l@(r : _) (L _ (FieldLabelString field)) = - wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l -mkGet _ [] _ = panic "mkGet : The impossible has happened!" +mkGet :: Name -> NonEmpty (LHsExpr GhcRn) -> LocatedAn NoEpAnns FieldLabelString -> NonEmpty (LHsExpr GhcRn) +mkGet get_field l@(r :| _) (L _ (FieldLabelString field)) = + wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) NE.<| l mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc) @@ -2748,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. @@ -2763,10 +2878,10 @@ mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn) mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } )) = let { - ; flds = map (fmap (unLoc . dfoLabel)) flds' + ; flds = NE.map (fmap (unLoc . dfoLabel)) flds' ; final = last flds -- quux ; fields = init flds -- [foo, bar, baz] - ; getters = \a -> foldl' (mkGet get_field) [a] fields -- Ordered from deep to shallow. + ; getters = \a -> foldl' (mkGet get_field) (a :| []) fields -- Ordered from deep to shallow. -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a] ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow. -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)] diff --git a/GHC/Rename/Expr.hs-boot b/GHC/Rename/Expr.hs-boot --- a/GHC/Rename/Expr.hs-boot +++ b/GHC/Rename/Expr.hs-boot @@ -18,7 +18,7 @@ ) rnStmts :: --forall thing body. - AnnoBody body => HsStmtContext GhcRn + AnnoBody body => HsStmtContextRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [LStmt GhcPs (LocatedA (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) diff --git a/GHC/Rename/Fixity.hs b/GHC/Rename/Fixity.hs --- a/GHC/Rename/Fixity.hs +++ b/GHC/Rename/Fixity.hs @@ -4,8 +4,10 @@ -} module GHC.Rename.Fixity - ( MiniFixityEnv + ( MiniFixityEnv(..) , addLocalFixities + , lookupMiniFixityEnv + , emptyMiniFixityEnv , lookupFixityRn , lookupFixityRn_help , lookupFieldFixityRn @@ -25,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 @@ -63,32 +64,61 @@ -} -------------------------------- -type MiniFixityEnv = FastStringEnv (Located Fixity) - -- Mini fixity env for the names we're about - -- to bind, in a single binding group - -- - -- It is keyed by the *FastString*, not the *OccName*, because - -- the single fixity decl infix 3 T - -- affects both the data constructor T and the type constructor T - -- - -- We keep the location so that if we find - -- a duplicate, we can report it sensibly +-- | Mini fixity env for the names we're about +-- to bind, in a single binding group +-- +-- It is keyed by the *FastString*, not the *OccName*, because +-- the single fixity decl @infix 3 T@ +-- affects both the data constructor T and the type constructor T +-- +-- We keep the location so that if we find +-- a duplicate, we can report it sensibly +-- +-- Fixity declarations may influence names in a single namespace by using +-- a type or data specifier, e.g. in: +-- +-- > data a :*: b = a :*: b +-- > infix 3 type :*: +-- +-- To handle that correctly, MiniFixityEnv contains separate +-- fields for type-level and data-level names. +-- If no namespace specifier is provided, the declaration will +-- populate both the type-level and data-level fields. +data MiniFixityEnv = MFE + { mfe_data_level_names :: FastStringEnv (Located Fixity) + , mfe_type_level_names :: FastStringEnv (Located Fixity) + } + -------------------------------- -- Used for nested fixity decls to bind names along with their fixities. -- the fixities are given as a UFM from an OccName's FastString to a fixity decl addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a -addLocalFixities mini_fix_env names thing_inside +addLocalFixities env names thing_inside = extendFixityEnv (mapMaybe find_fixity names) thing_inside where - find_fixity name - = case lookupFsEnv mini_fix_env (occNameFS occ) of + find_fixity name = case lookupMiniFixityEnv env name of Just lfix -> Just (name, FixItem occ (unLoc lfix)) Nothing -> Nothing where occ = nameOccName name +lookupMiniFixityEnv :: MiniFixityEnv -> Name -> Maybe (Located Fixity) +lookupMiniFixityEnv MFE{mfe_data_level_names, mfe_type_level_names} name + | isValNameSpace namespace = find_fixity_in_env mfe_data_level_names name + | otherwise = find_fixity_in_env mfe_type_level_names name + where + namespace = nameNameSpace name + + find_fixity_in_env mini_fix_env name + = lookupFsEnv mini_fix_env (occNameFS occ) + where + occ = nameOccName name + +emptyMiniFixityEnv :: MiniFixityEnv +emptyMiniFixityEnv = MFE emptyFsEnv emptyFsEnv + {- -------------------------------- lookupFixity is a bit strange. @@ -116,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) @@ -153,7 +183,7 @@ -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. = do { iface <- loadInterfaceForName doc name - ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ + ; let mb_fix = mi_fix_fn iface occ ; let msg = case mb_fix of Nothing -> text "looking up name" <+> ppr name @@ -172,4 +202,4 @@ lookupTyFixityRn = lookupFixityRn . unLoc lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (FieldOcc n _) = lookupFixityRn n +lookupFieldFixityRn (FieldOcc _ n) = lookupFixityRn (unLoc n) diff --git a/GHC/Rename/HsType.hs b/GHC/Rename/HsType.hs --- a/GHC/Rename/HsType.hs +++ b/GHC/Rename/HsType.hs @@ -14,22 +14,23 @@ -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext, rnLHsKind, rnLHsTypeArgs, - rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars, - HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, + rnHsSigType, rnHsWcType, rnHsTyLit, rnHsMultAnnWith, + HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, rnHsPatSigKind, newTyVarNameRn, - rnConDeclFields, - lookupField, + rnHsConDeclRecFields, + lookupField, mkHsOpTyRn, rnLTyVar, - rnScaledLHsType, + rnHsConDeclField, -- Precence related stuff NegationHandling(..), - mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + mkOpAppRn, mkNegAppRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, -- Binding related stuff bindHsOuterTyVarBndrs, bindHsForAllTelescope, + bindHsForAllTelescopes, bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, filterInScopeM, @@ -37,26 +38,32 @@ extractHsTysRdrTyVars, extractRdrKindSigVars, extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars, - nubL, nubN + extractHsForAllTelescopes, + nubL, nubN, + + -- Error helpers + badKindSigErr ) where import GHC.Prelude -import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) +import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType, checkThLocalTyName ) import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) +import GHC.Core.TyCon ( isKindName ) import GHC.Hs import GHC.Rename.Env import GHC.Rename.Doc import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNames - , checkShadowedRdrNames, warnForallIdentifier ) + , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr ( pprHsDocContext ) import GHC.Tc.Utils.Monad +import GHC.Unit.Module ( getModule ) import GHC.Types.Name.Reader import GHC.Builtin.Names import GHC.Types.Hint ( UntickedPromotedThing(..) ) @@ -72,15 +79,12 @@ import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List (nubBy, partition) -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad {- @@ -138,7 +142,7 @@ ; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' ; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' -> - do { (wcs, body_ty', fvs) <- rnWcBody doc nwc_rdrs body_ty + do { (wcs, body_ty', fvs) <- rnWcBodyType doc nwc_rdrs body_ty ; pure ( HsWC { hswc_ext = wcs, hswc_body = L loc $ HsSig { sig_ext = noExtField , sig_bndrs = outer_bndrs', sig_body = body_ty' }} @@ -149,6 +153,21 @@ -> HsPatSigType GhcPs -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) +rnHsPatSigType = rnHsPatSigTyKi TypeLevel + +rnHsPatSigKind :: HsPatSigTypeScoping + -> HsDocContext + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnHsPatSigKind = rnHsPatSigTyKi KindLevel + +rnHsPatSigTyKi :: TypeOrKind + -> HsPatSigTypeScoping + -> HsDocContext + -> HsPatSigType GhcPs + -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Used for -- - Pattern type signatures, which are only allowed with ScopedTypeVariables -- - Signatures on binders in a RULE, which are allowed even if @@ -156,7 +175,7 @@ -- Wildcards are allowed -- -- See Note [Pattern signature binders and scoping] in GHC.Hs.Type -rnHsPatSigType scoping ctx sig_ty thing_inside +rnHsPatSigTyKi level scoping ctx sig_ty thing_inside = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty) ; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty) @@ -166,7 +185,7 @@ AlwaysBind -> tv_rdrs NeverBind -> [] ; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs -> - do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx nwc_rdrs pat_sig_ty + do { (nwcs, pat_sig_ty', fvs1) <- rnWcBodyTyKi level ctx nwc_rdrs pat_sig_ty ; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs } sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' } ; (res, fvs2) <- thing_inside sig_ty' @@ -179,59 +198,20 @@ = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty) ; (nwc_rdrs', _) <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' - ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty + ; (wcs, hs_ty', fvs) <- rnWcBodyType ctxt nwc_rdrs hs_ty ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } ; return (sig_ty', fvs) } --- Similar to rnHsWcType, but rather than requiring free variables in the type to --- already be in scope, we are going to require them not to be in scope, --- and we bind them. -rnHsPatSigTypeBindingVars :: HsDocContext - -> HsPatSigType GhcPs - -> (HsPatSigType GhcRn -> RnM (r, FreeVars)) - -> RnM (r, FreeVars) -rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of - (HsPS { hsps_body = hs_ty }) -> do - rdr_env <- getLocalRdrEnv - let (varsInScope, varsNotInScope) = - partition (inScope rdr_env . unLoc) (extractHsTyRdrTyVars hs_ty) - -- TODO: Resolve and remove this comment. - -- This next bit is in some contention. The original proposal #126 - -- (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0126-type-applications-in-patterns.rst) - -- says that in-scope variables are fine here: don't bind them, just use - -- the existing vars, like in type signatures. An amendment #291 - -- (https://github.com/ghc-proposals/ghc-proposals/pull/291) says that the - -- use of an in-scope variable should *shadow* an in-scope tyvar, like in - -- terms. In an effort to make forward progress, the current implementation - -- just rejects any use of an in-scope variable, meaning GHC will accept - -- a subset of programs common to both variants. If this comment still exists - -- in mid-to-late 2021 or thereafter, we have done a poor job on following - -- up on this point. - -- Example: - -- f :: forall a. ... - -- f (MkT @a ...) = ... - -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided, - -- so we currently reject. - when (not (null varsInScope)) $ - addErr $ TcRnBindVarAlreadyInScope varsInScope - (wcVars, ibVars) <- partition_nwcs varsNotInScope - rnImplicitTvBndrs ctxt Nothing ibVars $ \ ibVars' -> do - (wcVars', hs_ty', fvs) <- rnWcBody ctxt wcVars hs_ty - let sig_ty = HsPS - { hsps_body = hs_ty' - , hsps_ext = HsPSRn - { hsps_nwcs = wcVars' - , hsps_imp_tvs = ibVars' - } - } - (res, fvs') <- thing_inside sig_ty - return (res, fvs `plusFV` fvs') -rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs +rnWcBodyType :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) +rnWcBodyType = rnWcBodyTyKi TypeLevel + +rnWcBodyTyKi :: TypeOrKind -> HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs -> RnM ([Name], LHsType GhcRn, FreeVars) -rnWcBody ctxt nwc_rdrs hs_ty +rnWcBodyTyKi level ctxt nwc_rdrs hs_ty = do { nwcs <- mapM newLocalBndrRn nwc_rdrs - ; let env = RTKE { rtke_level = TypeLevel + ; let env = RTKE { rtke_level = level , rtke_what = RnTypeBody , rtke_nwcs = mkNameSet nwcs , rtke_ctxt = ctxt } @@ -422,32 +402,6 @@ sites. This is less precise, but more accurate. -} --- | Create fresh type variables for binders, disallowing multiple occurrences of the same variable. Similar to `rnImplicitTvOccs` except that duplicate occurrences will --- result in an error, and the source locations of the variables are not adjusted, as these variable occurrences are themselves the binding sites for the type variables, --- rather than the variables being implicitly bound by a signature. -rnImplicitTvBndrs :: HsDocContext - -> Maybe assoc - -- ^ @'Just' _@ => an associated type decl - -> FreeKiTyVars - -- ^ Surface-syntax free vars that we will implicitly bind. - -- Duplicate variables will cause a compile-time error regarding repeated bindings. - -> ([Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside - = do { implicit_vs <- forM (NE.groupAllWith unLoc $ implicit_vs_with_dups) $ \case - (x :| []) -> return x - (x :| _) -> do - addErr $ TcRnBindMultipleVariables ctx x - return x - - ; traceRn "rnImplicitTvBndrs" $ - vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ] - - ; vars <- mapM (newTyVarNameRn mb_assoc) implicit_vs - - ; bindLocalNamesFV vars $ - thing_inside vars } - {- ****************************************************** * * LHsType and HsType @@ -498,14 +452,19 @@ rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys -rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs) - -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars) -rnScaledLHsType doc (HsScaled w ty) = do - (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w - (ty', fvs) <- rnLHsType doc ty - return (HsScaled w' ty', fvs `plusFV` fvs_w) +rnHsConDeclField :: HsDocContext -> HsConDeclField GhcPs + -> RnM (HsConDeclField GhcRn, FreeVars) +rnHsConDeclField doc = rnHsConDeclFieldTyKi (mkTyKiEnv doc TypeLevel RnTypeBody) +rnHsConDeclFieldTyKi :: RnTyKiEnv -> HsConDeclField GhcPs + -> RnM (HsConDeclField GhcRn, FreeVars) +rnHsConDeclFieldTyKi env cdf@(CDF { cdf_multiplicity, cdf_type, cdf_doc }) = do + (w , fvs_w) <- rnHsMultAnnWith (rnLHsTyKi env) cdf_multiplicity + (ty, fvs) <- rnLHsTyKi env cdf_type + doc <- traverse rnLHsDoc cdf_doc + return (cdf { cdf_multiplicity = w, cdf_type = ty, cdf_doc = doc }, fvs `plusFV` fvs_w) + rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty @@ -515,12 +474,12 @@ -- renaming a type only, not a kind rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars) -rnLHsTypeArg ctxt (HsValArg ty) +rnLHsTypeArg ctxt (HsValArg _ ty) = do { (tys_rn, fvs) <- rnLHsType ctxt ty - ; return (HsValArg tys_rn, fvs) } -rnLHsTypeArg ctxt (HsTypeArg l ki) + ; return (HsValArg noExtField tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg _ ki) = do { (kis_rn, fvs) <- rnLHsKind ctxt ki - ; return (HsTypeArg l kis_rn, fvs) } + ; return (HsTypeArg noExtField kis_rn, fvs) } rnLHsTypeArg _ (HsArgPar sp) = return (HsArgPar sp, emptyFVs) @@ -577,7 +536,7 @@ , hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) +rnHsTyKi env tv@(HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ unlessXOptM LangExt.PolyKinds $ addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ @@ -585,19 +544,29 @@ -- Any type variable at the kind level is illegal without the use -- of PolyKinds (see #14710) ; name <- rnTyVar env rdr_name + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod name) $ + checkThLocalTyName name + ; when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not + -- specifically exempted by isKindName) is illegal without the use + -- of DataKinds. See Note [Checking for DataKinds] in + -- GHC.Tc.Validity. + checkDataKinds env tv ; when (isDataConName name && not (isPromoted ip)) $ -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar. addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name) - ; return (HsTyVar noAnn ip (L loc name), unitFV name) } + ; return (HsTyVar noAnn ip (L loc $ WithUserRdr rdr_name name), unitFV name) } rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2) = setSrcSpan (getLocA l_op) $ - do { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op + do { let op_rdr = unLoc l_op + ; (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op ; let op_name = unLoc l_op' ; fix <- lookupTyFixityRn l_op' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2 - ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2' + ; res_ty <- mkHsOpTyRn prom (fmap (WithUserRdr op_rdr) l_op') fix ty1' ty2' ; when (isDataConName op_name && not (isPromoted prom)) $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } @@ -606,46 +575,22 @@ = do { (ty', fvs) <- rnLHsTyKi env ty ; return (HsParTy noAnn ty', fvs) } -rnHsTyKi env (HsBangTy x b ty) - = do { (ty', fvs) <- rnLHsTyKi env ty - ; return (HsBangTy x b ty', fvs) } - -rnHsTyKi env ty@(HsRecTy _ flds) - = do { let ctxt = rtke_ctxt env - ; fls <- get_fields ctxt - ; (flds', fvs) <- rnConDeclFields ctxt fls flds - ; return (HsRecTy noExtField flds', fvs) } - where - get_fields (ConDeclCtx names) - = do res <- concatMapM (lookupConstructorFields . unLoc) names - if equalLength res names - -- Lookup can fail when the record syntax is incorrect, e.g. - -- data D = D Int { fld :: Bool }. See T7943. - then return res - else err - get_fields _ = err - - err = - do { addErr $ TcRnIllegalRecordSyntax (Left ty) - ; return [] } - rnHsTyKi env (HsFunTy u mult ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 - ; (mult', w_fvs) <- rnHsArrow env mult + ; (mult', w_fvs) <- rnHsMultAnnWith (rnLHsTyKi env) mult ; return (HsFunTy u mult' ty1' ty2' , plusFVs [fvs1, fvs2, w_fvs]) } rnHsTyKi env listTy@(HsListTy x ty) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env listTy)) + = do { when (isRnKindLevel env) $ + checkDataKinds env listTy ; (ty', fvs) <- rnLHsTyKi env ty ; return (HsListTy x ty', fvs) } rnHsTyKi env (HsKindSig x ty k) = do { kind_sigs_ok <- xoptM LangExt.KindSignatures - ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) + ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) k) ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k ; (ty', lhs_fvs) <- bindSigTyVarsFV (hsScopedKvs k') $ rnLHsTyKi env ty @@ -654,42 +599,34 @@ -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi env tupleTy@(HsTupleTy x tup_con tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env tupleTy)) + = do { when (isRnKindLevel env) $ + checkDataKinds env tupleTy ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; return (HsTupleTy x tup_con tys', fvs) } rnHsTyKi env sumTy@(HsSumTy x tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env sumTy)) + = do { when (isRnKindLevel env) $ + checkDataKinds env sumTy ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; return (HsSumTy x tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) rnHsTyKi env tyLit@(HsTyLit src t) - = do { data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env tyLit)) - ; when (negLit t) (addErr $ TcRnNegativeNumTypeLiteral tyLit) - ; return (HsTyLit src (rnHsTyLit t), emptyFVs) } - where - negLit :: HsTyLit (GhcPass p) -> Bool - negLit (HsStrTy _ _) = False - negLit (HsNumTy _ i) = i < 0 - negLit (HsCharTy _ _) = False + = do { checkDataKinds env tyLit + ; t' <- rnHsTyLit t + ; return (HsTyLit src t', emptyFVs) } rnHsTyKi env (HsAppTy _ ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1 ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsAppKindTy _ ty at k) +rnHsTyKi env (HsAppKindTy _ ty k) = do { kind_app <- xoptM LangExt.TypeApplications ; unless kind_app (addErr (typeAppErr KindLevel k)) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy noExtField ty' at k', fvs1 `plusFV` fvs2) } + ; return (HsAppKindTy noExtField ty' k', fvs1 `plusFV` fvs2) } rnHsTyKi env t@(HsIParamTy x n ty) = do { notInKinds env t @@ -708,7 +645,7 @@ ; return (HsDocTy x ty' haddock_doc', fvs) } -- See Note [Renaming HsCoreTys] -rnHsTyKi env (XHsType ty) +rnHsTyKi env (XHsType (HsCoreTy ty)) = do mapM_ (check_in_scope . nameRdrName) fvs_list return (XHsType ty, fvs) where @@ -721,39 +658,58 @@ when (isNothing mb_name) $ addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ - TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name [] [] + TcRnNotInScope (notInScopeErr WL_LocalOnly rdr_name) rdr_name +rnHsTyKi env ty@(XHsType (HsBangTy _ bang (L _ inner))) = do + -- While top-level bangs at this point are eliminated (eg !(Maybe Int)), + -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of + -- bangs are invalid, so fail. (#7210, #14761) + addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnUnexpectedAnnotation ty bang + rnHsTyKi env inner + +rnHsTyKi env ty@(XHsType (HsRecTy {})) = do + -- Record types (which only show up temporarily in constructor + -- signatures) should have been removed by now + addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnIllegalRecordSyntax ty + return (HsWildCardTy noExtField, emptyFVs) -- trick to avoid `failWithTc` + rnHsTyKi env ty@(HsExplicitListTy _ ip tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) + = do { checkDataKinds env ty ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys ; unless (isPromoted ip) $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList) ; return (HsExplicitListTy noExtField ip tys', fvs) } -rnHsTyKi env ty@(HsExplicitTupleTy _ tys) - = do { data_kinds <- xoptM LangExt.DataKinds - ; unless data_kinds (addErr (dataKindsErr env ty)) +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 ; return (HsWildCardTy noExtField, emptyFVs) } -rnHsTyLit :: HsTyLit GhcPs -> HsTyLit GhcRn -rnHsTyLit (HsStrTy x s) = HsStrTy x s -rnHsTyLit (HsNumTy x i) = HsNumTy x i -rnHsTyLit (HsCharTy x c) = HsCharTy x c +rnHsTyLit :: HsTyLit GhcPs -> RnM (HsTyLit GhcRn) +rnHsTyLit (HsStrTy x s) = pure (HsStrTy x s) +rnHsTyLit tyLit@(HsNumTy x i) = do + when (i < 0) $ + addErr $ TcRnNegativeNumTypeLiteral tyLit + pure (HsNumTy x i) +rnHsTyLit (HsCharTy x c) = pure (HsCharTy x c) -rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) -rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs) -rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs) -rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs) -rnHsArrow env (HsExplicitMult pct p arr) - = (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p +rnHsMultAnnWith :: (LocatedA (mult GhcPs) -> RnM (LocatedA (mult GhcRn), FreeVars)) + -> HsMultAnnOf (LocatedA (mult GhcPs)) GhcPs + -> RnM (HsMultAnnOf (LocatedA (mult GhcRn)) GhcRn, FreeVars) +rnHsMultAnnWith _rn (HsUnannotated _) = pure (HsUnannotated noExtField, emptyFVs) +rnHsMultAnnWith _rn (HsLinearAnn _) = pure (HsLinearAnn noExtField, emptyFVs) +rnHsMultAnnWith rn (HsExplicitMult _ p) + = (\(mult, fvs) -> (HsExplicitMult noExtField mult, fvs)) <$> rn p {- Note [Renaming HsCoreTys] @@ -866,6 +822,7 @@ ExprWithTySigCtx {} -> True PatCtx {} -> True RuleCtx {} -> True + SpecECtx {} -> True FamPatCtx {} -> True -- Not named wildcards though GHCiCtx {} -> True HsTypeCtx {} -> True @@ -916,7 +873,7 @@ --------------- bindHsQTyVars :: forall a b. HsDocContext - -> Maybe a -- Just _ => an associated type decl + -> Maybe (a, [Name]) -- Just _ => an associated type decl -> FreeKiTyVars -- Kind variables from scope -> LHsQTyVars GhcPs -> (LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars)) @@ -937,13 +894,19 @@ ; let -- See Note [bindHsQTyVars examples] for what -- all these various things are doing - bndrs, implicit_kvs :: [LocatedN RdrName] - bndrs = map hsLTyVarLocName hs_tv_bndrs - implicit_kvs = filterFreeVarsToBind bndrs $ + bndrs, all_implicit_kvs :: [LocatedN RdrName] + bndrs = mapMaybe hsLTyVarLocName hs_tv_bndrs + all_implicit_kvs = filterFreeVarsToBind bndrs $ bndr_kv_occs ++ body_kv_occs body_remaining = filterFreeVarsToBind bndr_kv_occs $ filterFreeVarsToBind bndrs body_kv_occs + ; implicit_kvs <- + case mb_assoc of + Nothing -> filterInScopeM all_implicit_kvs + Just (_, cls_tvs) -> filterInScopeNonClassM cls_tvs all_implicit_kvs + -- See Note [Class variables and filterInScope] + ; traceRn "checkMixedVars3" $ vcat [ text "bndrs" <+> ppr hs_tv_bndrs , text "bndr_kv_occs" <+> ppr bndr_kv_occs @@ -987,9 +950,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1016,8 +987,13 @@ That's one of the rules for a CUSK, so we pass that info on as the second argument to thing_inside. -* Order is not important in these lists. All we are doing is - bring Names into scope. +* Order is important in these lists. Consider + data T (a::k1) (b::k2) + We want implicit_kvs to be [k1,k2], not [k2,k1], so that the inferred kind for + T quantifies over kind variables in the user-specified order + T :: forall k1 k2. k1 -> k2 -> Type -- OK + T :: forall k2 k1. k1 -> k2 -> Type -- Bad + This matters with TypeApplications * bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All duplicate occurrences are removed when we bind them with rnImplicitTvOccs. @@ -1131,7 +1107,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' } @@ -1157,12 +1134,39 @@ 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' +bindHsForAllTelescopes :: HsDocContext + -> [HsForAllTelescope GhcPs] + -> ([HsForAllTelescope GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindHsForAllTelescopes _ [] thing_inside = + thing_inside [] +bindHsForAllTelescopes doc (tele:teles) thing_inside = + bindHsForAllTelescope doc tele $ \tele' -> + bindHsForAllTelescopes doc teles $ \teles' -> + thing_inside (tele':teles') + +-- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type +checkForAllTelescopeWildcardBndrs :: HsDocContext + -> [LHsTyVarBndr flag (GhcPass p)] + -> 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. @@ -1188,7 +1192,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' -> @@ -1206,23 +1210,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 @@ -1230,17 +1242,17 @@ -> 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 a no-op. We could use 'coerce' in an ideal world, --- but GHC can't crack this nut because type families are involved: --- HsBndrInvisible stores (LHsToken "@" pass), which is defined via XRec. +-- rnHsBndrVis is almost a no-op, it simply discards the token for "@". rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn -rnHsBndrVis HsBndrRequired = HsBndrRequired -rnHsBndrVis (HsBndrInvisible at) = HsBndrInvisible at +rnHsBndrVis (HsBndrRequired _) = HsBndrRequired noExtField +rnHsBndrVis (HsBndrInvisible _at) = HsBndrInvisible noExtField newTyVarNameRn, newTyVarNameRnImplicit :: Maybe a -- associated class @@ -1266,14 +1278,14 @@ Section 7.3: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0281-visible-forall.rst#73implicit-quantification Its purpose is to notify users when implicit quantification occurs that would -stop working under RequiredTypeArguments (a future GHC extension). Example: +stop working under RequiredTypeArguments. Example: a = 42 id :: a -> a As it stands, the `a` in the signature `id :: a -> a` is considered free and leads to implicit quantification, as if the user wrote `id :: forall a. a -> a`. -Under RequiredTypeArguments it will capture the term-level variable `a` (bound by `a = 42`), +Under RequiredTypeArguments it captures the term-level variable `a` (bound by `a = 42`), leading to a type error. `warn_term_var_capture` detects this by demoting the namespace of the @@ -1307,44 +1319,42 @@ {- ********************************************************* * * - ConDeclField + HsConDeclRecField * * ********************************************************* -When renaming a ConDeclField, we have to find the FieldLabel +When renaming a HsConDeclRecField, we have to find the FieldLabel associated with each field. But we already have all the FieldLabels available (since they were brought into scope by GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an argument, build a map and look them up. -} -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] - -> RnM ([LConDeclField GhcRn], FreeVars) +rnHsConDeclRecFields :: HsDocContext -> [FieldLabel] -> [LHsConDeclRecField GhcPs] + -> RnM ([LHsConDeclRecField GhcRn], FreeVars) -- Also called from GHC.Rename.Module -- No wildcards can appear in record fields -rnConDeclFields ctxt fls fields +rnHsConDeclRecFields ctxt fls fields = mapFvRn (rnField fl_env env) fields where env = mkTyKiEnv ctxt TypeLevel RnTypeBody fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs - -> RnM (LConDeclField GhcRn, FreeVars) -rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) - = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names - ; let new_names = map (fmap (lookupField fl_env)) names - ; (new_ty, fvs) <- rnLHsTyKi env ty - ; haddock_doc' <- traverse rnLHsDoc haddock_doc - ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc') +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LHsConDeclRecField GhcPs + -> RnM (LHsConDeclRecField GhcRn, FreeVars) +rnField fl_env env (L l (HsConDeclRecField _ names ty)) + = do { let new_names = map (fmap (lookupField fl_env)) names + ; (new_ty, fvs) <- rnHsConDeclFieldTyKi env ty + ; return (L l (HsConDeclRecField noExtField new_names new_ty) , fvs) } 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 - $ expectJust "lookupField" + $ expectJust $ lookupFsEnv fl_env lbl {- @@ -1379,19 +1389,19 @@ --------------- -- Building (ty1 `op1` (ty2a `op2` ty2b)) mkHsOpTyRn :: PromotionFlag - -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b)) - = do { fix2 <- lookupTyFixityRn op2 + = do { fix2 <- lookupTyFixityRn (fmap getName op2) ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangement - = return (HsOpTy noAnn prom1 ty1 op1 ty2) + = return (HsOpTy noExtField prom1 ty1 op1 ty2) --------------- -mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn - -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn +mk_hs_op_ty :: PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn + -> PromotionFlag -> LocatedN (WithUserRdr Name) -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpanAnnA -> RnM (HsType GhcRn) mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 @@ -1403,8 +1413,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 @@ -1464,12 +1474,12 @@ ---------------------------- get_op :: LHsExpr GhcRn -> OpName --- An unbound name could be either HsVar or HsUnboundVar +-- An unbound name could be either HsVar or (HsHole (HoleVar _, _)) -- See GHC.Rename.Expr.rnUnboundVar -get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) -get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv -get_op (L _ (HsRecSel _ fld)) = RecFldOp fld -get_op other = pprPanic "get_op" (ppr other) +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsHole (HoleVar (L _ uv)))) = UnboundOp uv +get_op (L _ (XExpr (HsRecSelRn fld))) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -1493,41 +1503,13 @@ 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 +mkConOpPatRn :: LocatedN (WithUserRdr Name) + -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn) mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2 - = do { fix1 <- lookupFixityRn (unLoc op1) + = do { fix1 <- lookupFixityRn (getName op1) ; let (nofix_error, associate_right) = compareFixity fix1 fix2 ; if nofix_error then do @@ -1535,7 +1517,7 @@ (NormalOp (unLoc op2),fix2) ; return $ ConPat { pat_con_ext = noExtField - , pat_con = op2 + , pat_con = op2 , pat_args = InfixCon p1 p2 } } @@ -1577,9 +1559,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 @@ -1595,15 +1577,15 @@ 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 (getName op1) let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && (op1_dir == InfixR && op_dir == InfixR && right || op1_dir == InfixL && op_dir == InfixL && not right)) - info = (NormalOp op, op_fix) + info = (NormalOp (noUserRdr op), op_fix) info1 = (NormalOp (unLoc op1), op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) unless inf_ok (precParseErr infol infor) @@ -1624,8 +1606,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) @@ -1633,12 +1615,11 @@ -- | Look up the fixity for an operator name. lookupFixityOp :: OpName -> RnM Fixity -lookupFixityOp (NormalOp n) = lookupFixityRn n +lookupFixityOp (NormalOp n) = lookupFixityRn (getName n) lookupFixityOp NegateOp = lookupFixityRn negateName lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u)) lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f - -- Precedence-related error messages precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () @@ -1656,7 +1637,7 @@ = addErr $ TcRnSectionPrecedenceError op arg_op section is_unbound :: OpName -> Bool -is_unbound (NormalOp n) = isUnboundName n +is_unbound (NormalOp n) = isUnboundName (getName n) is_unbound UnboundOp{} = True is_unbound _ = False @@ -1677,19 +1658,27 @@ TcRnWithHsDocContext doc $ TcRnKindSignaturesDisabled (Left ty) -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage -dataKindsErr env thing - = TcRnDataKindsError type_or_Kind thing +-- | Check for DataKinds violations in a type context, as well as \"obvious\" +-- violations in kind contexts. +-- See @Note [Checking for DataKinds]@ in "GHC.Tc.Validity" for more on this. +checkDataKinds :: RnTyKiEnv -> HsType GhcPs -> TcM () +checkDataKinds env thing + = do data_kinds <- xoptM LangExt.DataKinds + unless data_kinds $ + addErr $ TcRnDataKindsError type_or_kind $ Left thing where - type_or_Kind | isRnKindLevel env = KindLevel + type_or_kind | isRnKindLevel env = KindLevel | otherwise = TypeLevel 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 @@ -1764,6 +1753,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 @@ -1772,7 +1764,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 @@ -1856,25 +1848,136 @@ -- Note [Ordering of implicit variables]. type FreeKiTyVars = [LocatedN RdrName] +-- When renaming a type, do we want to capture or ignore term variables? +-- Suppose we have a variable binding `a` and we are renaming a type signature +-- that mentions `a`: +-- +-- f :: forall t -> ... +-- f a = ... +-- where g :: a -> Bool +-- +-- Does the `a` in the signature for `g` refer to the term variable or is it +-- implicitly quantified, as if the user wrote `g :: forall a. a -> Bool`? +-- `CaptureTermVars` selects the former behavior, `DontCaptureTermVars` the latter. +data TermVariableCapture = + CaptureTermVars + | DontCaptureTermVars + +getTermVariableCapture :: RnM TermVariableCapture +getTermVariableCapture + = do { required_type_arguments <- xoptM LangExt.RequiredTypeArguments + ; let tvc | required_type_arguments = CaptureTermVars + | otherwise = DontCaptureTermVars + ; return tvc } + -- | Filter out any type and kind variables that are already in scope in the -- the supplied LocalRdrEnv. Note that this includes named wildcards, which -- look like perfectly ordinary type variables at this point. -filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) +filterInScope :: TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars +filterInScope tvc envs = filterOut (inScope tvc envs . unLoc) +-- | Like 'filterInScope', but keep parent class variables intact. +-- Used with associated types. See Note [Class variables and filterInScope] +filterInScopeNonClass :: [Name] -> TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> FreeKiTyVars -> FreeKiTyVars +filterInScopeNonClass cls_tvs tvc envs = filterOut (in_scope_non_class . unLoc) + where + in_scope_non_class :: RdrName -> Bool + in_scope_non_class rdr + | occName rdr `elemOccSet` cls_tvs_set = False + | otherwise = inScope tvc envs rdr + + cls_tvs_set :: OccSet + cls_tvs_set = mkOccSet (map nameOccName cls_tvs) + -- | Filter out any type and kind variables that are already in scope in the -- the environment's LocalRdrEnv. Note that this includes named wildcards, -- which look like perfectly ordinary type variables at this point. filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars filterInScopeM vars - = do { rdr_env <- getLocalRdrEnv - ; return (filterInScope rdr_env vars) } + = do { tvc <- getTermVariableCapture + ; envs <- getRdrEnvs + ; return (filterInScope tvc envs vars) } -inScope :: LocalRdrEnv -> RdrName -> Bool -inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env +-- | Like 'filterInScopeM', but keep parent class variables intact. +-- Used with associated types. See Note [Class variables and filterInScope] +filterInScopeNonClassM :: [Name] -> FreeKiTyVars -> RnM FreeKiTyVars +filterInScopeNonClassM cls_tvs vars + = do { tvc <- getTermVariableCapture + ; envs <- getRdrEnvs + ; return (filterInScopeNonClass cls_tvs tvc envs vars) } +inScope :: TermVariableCapture -> (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Bool +inScope tvc (gbl, lcl) rdr = + case tvc of + DontCaptureTermVars -> rdr_in_scope + CaptureTermVars -> rdr_in_scope || demoted_rdr_in_scope + where + rdr_in_scope, demoted_rdr_in_scope :: Bool + rdr_in_scope = elem_lcl rdr + demoted_rdr_in_scope = maybe False (elem_lcl <||> elem_gbl) (demoteRdrNameTv rdr) + + elem_lcl, elem_gbl :: RdrName -> Bool + elem_lcl name = elemLocalRdrEnv name lcl + elem_gbl name = (not . null) (lookupGRE gbl (LookupRdrName name (RelevantGREsFOS WantBoth))) + +{- Note [Class variables and filterInScope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `bindHsQTyVars` free variables are collected and bound implicitly. Example: + type ElemKind (a :: Maybe k) = k +Both occurrences of `k` are usages, so GHC creates an implicit binding for `k`. +We can also bind it explicitly with the help of TypeAbstractions: + type ElemKind @k (a :: Maybe k) = k + +This is similar to implicit quantification that happens in type signatures + const :: a -> b -> a -- `a` and `b` bound implicitly + const :: forall a b. a -> b -> a -- `a` and `b` bound explicitly + +In both cases we need to compute the list of free variables to implicitly +quantify over (NB: list, not set, because order matters with TypeApplications) + * implicitly bound variables in ElemKind: [k] + * implicitly bound variables in const: [a, b] + +However, variables that are already in scope are captured. Example: + {-# LANGUAGE ScopedTypeVariables #-} + f (x :: a) = ... + where g :: a -> a + g _ = x +When we look at `g` in isolation, `a` is a free variable: + g :: a -> a +But due to ScopedTypeVariables, `a` is actually bound in the surrounding +context, namely the (x :: a) pattern. +It is important that we do /not/ insert an implicit forall in the type of `g` + g :: forall a. a -> a -- No! That would mean a different thing +The solution is to use `filterInScopeM` to remove variables already in scope +from candidates for implicit quantification. + +Using `filterInScopeM` is additionally important when RequiredTypeArguments is +in effect. Consider + import Prelude (id) + data T (a :: id) = MkT -- Test case T23740e + +With RequiredTypeArguments, variables in the term namespace can be referred to +at the type level, so `id` in the `:: id` kind signature ought to refer to `id` +from Prelude. Of course it is not a valid program, but we want a proper error +message rather than implicit quantification: + T23740e.hs:5:14: error: [GHC-45510] + • Term variable ‘id’ cannot be used here + (term variables cannot be promoted) + +This leads us to use `filterInScopeM` in `bindHsQTyVars`. +Unfortunately, associated types make matters more complex. Consider + class C (a::k1) (b::k2) (c::k3) where + type T (a::k1) b +When renaming `T`, we have to implicitly quantify over the class variable `k1`, +despite the fact that `k1` is in scope from the class header. The type checker +expects to find `k1` in `HsQTvsRn` (the `hsq_ext` field of `LHsQTyVars`). But it +won't find it there if it is filtered out by `filterInScopeM`. + +To account for that, we introduce another helper, `filterInScopeNonClassM`, +which acts much like `filterInScopeM` but leaves class variables intact. -} + extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars -extract_tyarg (HsValArg ty) acc = extract_lty ty acc +extract_tyarg (HsValArg _ ty) acc = extract_lty ty acc extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc extract_tyarg (HsArgPar _) acc = acc @@ -1925,8 +2028,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 @@ -1935,8 +2039,8 @@ extractConDeclGADTDetailsTyVars :: HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars extractConDeclGADTDetailsTyVars con_args = case con_args of - PrefixConGADT args -> extract_scaled_ltys args - RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds + PrefixConGADT _ args -> extract_scaled_ltys args + RecConGADT _ (L _ flds) -> extract_scaled_ltys $ map (cdrf_spec . unLoc) $ flds -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order: @@ -1952,13 +2056,14 @@ extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) -extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)] +extract_scaled_ltys :: [HsConDeclField GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_scaled_ltys args acc = foldr extract_scaled_lty acc args -extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs) +extract_scaled_lty :: HsConDeclField GhcPs -> FreeKiTyVars -> FreeKiTyVars -extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc +extract_scaled_lty (CDF { cdf_multiplicity, cdf_type }) acc + = extract_lty cdf_type $ extract_hs_mult_ann cdf_multiplicity acc extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys @@ -1967,29 +2072,25 @@ extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc - HsBangTy _ _ ty -> extract_lty ty acc - HsRecTy _ flds -> foldr (extract_lty - . cd_fld_type . unLoc) acc - flds HsAppTy _ ty1 ty2 -> extract_lty ty1 $ extract_lty ty2 acc - HsAppKindTy _ ty _ k -> extract_lty ty $ + HsAppKindTy _ ty k -> extract_lty ty $ extract_lty k acc 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_mult_ann 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 @@ -2020,10 +2121,9 @@ extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) = extractHsOuterTvBndrs outer_bndrs $ extract_lty body [] -extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> - FreeKiTyVars -extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc -extract_hs_arrow _ acc = acc +extract_hs_mult_ann :: HsMultAnn GhcPs -> FreeKiTyVars -> FreeKiTyVars +extract_hs_mult_ann (HsExplicitMult _ p) acc = extract_lty p acc +extract_hs_mult_ann _ acc = acc extract_hs_for_all_telescope :: HsForAllTelescope GhcPs -> FreeKiTyVars -- Accumulator @@ -2044,6 +2144,14 @@ HsOuterImplicit{} -> body_fvs HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs +extractHsForAllTelescopes :: [HsForAllTelescope GhcPs] + -> FreeKiTyVars -- Free in body + -> FreeKiTyVars -- Free in result +extractHsForAllTelescopes [] body_fvs = body_fvs +extractHsForAllTelescopes (tele:teles) body_fvs = + extract_hs_for_all_telescope tele [] $ + extractHsForAllTelescopes teles body_fvs + extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -- Accumulator -> FreeKiTyVars -- Free in body @@ -2060,7 +2168,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 @@ -2071,7 +2179,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 = diff --git a/GHC/Rename/Module.hs b/GHC/Rename/Module.hs --- a/GHC/Rename/Module.hs +++ b/GHC/Rename/Module.hs @@ -1,11 +1,16 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -13,7 +18,7 @@ -} module GHC.Rename.Module ( - rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt + rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt, rnLWarningTxt ) where import GHC.Prelude hiding ( head ) @@ -22,26 +27,23 @@ import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs -import GHC.Types.FieldLabel -import GHC.Types.Name.Reader + import GHC.Rename.HsType import GHC.Rename.Bind import GHC.Rename.Doc import GHC.Rename.Env import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNames, bindLocalNamesFV - , checkShadowedRdrNames, warnUnusedTypePatterns - , newLocalBndrsRn + , warnUnusedTypePatterns , noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier ) + , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names + import GHC.Tc.Errors.Types -import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin ( TypedThing(..) ) -import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Unit import GHC.Unit.Module.Warnings import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName @@ -49,22 +51,30 @@ , semigroupClassName, sappendName , monoidClassName, mappendName ) + +import GHC.Types.FieldLabel +import GHC.Types.Name.Reader +import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Utils.Outputable -import GHC.Data.Bag -import GHC.Types.Basic ( TypeOrKind(..) ) -import GHC.Data.FastString +import GHC.Types.Basic ( VisArity, TyConFlavour(..), TypeOrKind(..), RuleName ) +import GHC.Types.GREInfo (ConLikeInfo (..), ConInfo, mkConInfo, conInfoFields) +import GHC.Types.Hint (SigLike(..)) +import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc + import GHC.Driver.DynFlags -import GHC.Utils.Misc ( lengthExceeds, partitionWith ) -import GHC.Utils.Panic import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) + +import GHC.Utils.Misc ( lengthExceeds ) +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import GHC.Data.FastString import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses ) -import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) +import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) -import GHC.Types.Unique.Set import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt import GHC.Core.DataCon ( isSrcStrict ) @@ -72,11 +82,9 @@ import Control.Monad import Control.Arrow ( first ) import Data.Foldable ( toList, for_ ) -import Data.List ( mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty ) -import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) +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 +182,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 +217,14 @@ (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' + , tcg_complete_match_env = tcg_complete_match_env last_tcg_env0 ++ localCompletePragmas sigs'} + } ; -- (I) Compute the results and return let {rn_group = HsGroup { hs_ext = noExtField, hs_valds = rn_val_decls, @@ -273,45 +288,50 @@ rnSrcWarnDecls bndr_set decls' = do { -- check for duplicates - ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = fmap snd dups in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) warn_rdr_dups - ; pairs_s <- mapM (addLocMA rn_deprec) decls + ; pairs_s <- mapM (addLocM rn_deprec) decls ; return $ concat pairs_s } where decls = concatMap (wd_warnings . unLoc) decls' sig_ctxt = TopSigCtxt bndr_set - rn_deprec (Warning _ rdr_names txt) + rn_deprec w@(Warning (ns_spec, _) rdr_names txt) -- ensures that the names are defined locally - = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt SigLikeDeprecation ns_spec . unLoc) rdr_names + ; unlessXOptM LangExt.ExplicitNamespaces $ + when (ns_spec /= NoNamespaceSpecifier) $ + addErr (TcRnNamespacedWarningPragmaWithoutFlag w) ; txt' <- rnWarningTxt txt ; return [(nameOccName nm, txt') | (_, nm) <- names] } -- Use the OccName from the Name we looked up, rather than from the RdrName, -- as we might hit multiple different NameSpaces when looking up -- (e.g. deprecating both a variable and a record field). - what = text "deprecation" + warn_rdr_dups = find_dup_warning_names + $ concatMap (\(L _ (Warning (ns_spec, _) ns _)) -> (ns_spec,) <$> ns) decls - warn_rdr_dups = findDupRdrNames - $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls + find_dup_warning_names :: [(NamespaceSpecifier, LocatedN RdrName)] -> [NonEmpty (NamespaceSpecifier, LocatedN RdrName)] + find_dup_warning_names = findDupsEq (\ (spec1, x) -> \ (spec2, y) -> + overlappingNamespaceSpecifiers spec1 spec2 && + rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) rnWarningTxt (WarningTxt mb_cat st wst) = do forM_ mb_cat $ \(L _ (InWarningCategory _ _ (L loc cat))) -> unless (validWarningCategory cat) $ - addErrAt loc (TcRnInvalidWarningCategory cat) + addErrAt (locA loc) (TcRnInvalidWarningCategory cat) wst' <- traverse (traverse rnHsDoc) wst pure (WarningTxt mb_cat st wst') rnWarningTxt (DeprecatedTxt st wst) = do wst' <- traverse (traverse rnHsDoc) wst pure (DeprecatedTxt st wst') - -findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] -findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) +rnLWarningTxt :: LWarningTxt GhcPs -> RnM (LWarningTxt GhcRn) +rnLWarningTxt (L loc warn) = L loc <$> rnWarningTxt warn -- look for duplicates among the OccNames; -- we check that the names are defined above @@ -327,9 +347,10 @@ rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) rnAnnDecl ann@(HsAnnotation (_, s) provenance expr) - = addErrCtxt (annCtxt ann) $ + = addErrCtxt (AnnCtxt ann) $ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance - ; (expr', expr_fvs) <- setStage (Splice Untyped) $ + ; cur_level <- getThLevel + ; (expr', expr_fvs) <- setThLevel (Splice Untyped cur_level) $ rnLExpr expr ; return (HsAnnotation (noAnn, s) provenance' expr', provenance_fvs `plusFV` expr_fvs) } @@ -339,9 +360,9 @@ rnAnnProvenance provenance = do provenance' <- case provenance of ValueAnnProvenance n -> ValueAnnProvenance - <$> lookupLocatedTopBndrRnN n + <$> lookupLocatedTopBndrRnN WL_Term n TypeAnnProvenance n -> TypeAnnProvenance - <$> lookupLocatedTopConstructorRnN n + <$> lookupLocatedTopBndrRnN WL_Type n ModuleAnnProvenance -> return ModuleAnnProvenance return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -354,9 +375,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 WL_TyCon) mb_cls + ; (tys', ty_fvs) <- rnLHsTypes doc_str tys + ; return (DefaultDecl noExtField mb_cls' tys', ty_fvs) } where doc_str = DefaultDeclCtx @@ -371,8 +394,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv - ; warnForallIdentifier name - ; name' <- lookupLocatedTopBndrRnN name + ; name' <- lookupLocatedTopBndrRnN WL_TermVariable name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty -- Mark any PackageTarget style imports as coming from the current package @@ -384,7 +406,7 @@ , fd_fi = spec' }, fvs) } rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) - = do { name' <- lookupLocatedOccRn name + = do { name' <- lookupLocatedOccRn WL_TermVariable name ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty' @@ -475,7 +497,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 } @@ -488,7 +510,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 } @@ -517,7 +539,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 } @@ -527,7 +549,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 } @@ -541,11 +563,12 @@ -- 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 + | GRHSs _ (L _ (GRHS _ [] body) :| []) lbinds <- grhss , EmptyLocalBinds _ <- lbinds - , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) + , HsVar _ lrhsName <- unLoc body + = Just (getName lrhsName) isAliasMG _ = Nothing addWarnNonCanonicalMonoid reason = @@ -558,38 +581,64 @@ addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty) rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) -rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds +rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _) + , cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = oflag , cid_datafam_insts = adts }) - = do { checkInferredVars ctxt inst_ty - ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty - ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' - -- Check if there are any nested `forall`s or contexts, which are - -- illegal in the type of an instance declaration (see - -- Note [No nested foralls or contexts in instance types] in - -- GHC.Hs.Type)... - mb_nested_msg = noNestedForallsContextsErr - NFC_InstanceHead head_ty' - -- ...then check if the instance head is actually headed by a - -- class type constructor... - eith_cls = case hsTyGetAppHead_maybe head_ty' of - Just (L _ cls) -> Right cls - Nothing -> - Left - ( getLocA head_ty' - , TcRnIllegalInstance $ - IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $ - IllegalInstanceHead $ InstHeadNonClass Nothing - ) + = do { rec { let ctxt = ClassInstanceCtx head_ty' + ; checkInferredVars ctxt inst_ty + ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty + ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' + } + ; env <- getGlobalRdrEnv + ; let + -- Check if there are any nested `forall`s or contexts, which are + -- illegal in the type of an instance declaration (see + -- Note [No nested foralls or contexts in instance types] in + -- GHC.Hs.Type)... + mb_nested_msg = noNestedForallsContextsErr NFC_InstanceHead head_ty' + -- ...then check if the instance head is actually headed by a + -- class type constructor... + instance_head :: Either IllegalInstanceHeadReason Name + instance_head = + case hsTyGetAppHead_maybe head_ty' of + Just (L _ nm_with_rdr) -> + let nm = getName nm_with_rdr in + case lookupGRE_Name env nm of + Just (GRE { gre_info = IAmTyCon flav }) -> + if + | flav == ClassFlavour + -> Right nm + | flav == AbstractTypeFlavour + -> Left $ InstHeadAbstractClass nm_with_rdr + | otherwise + -> Left $ InstHeadNonClassHead $ InstNonClassTyCon nm_with_rdr flav + _ -> + -- The head of the instance head is out of scope; + -- we'll deal with that later. Continue for now. + Right nm + + Nothing -> + Left $ InstHeadNonClassHead InstNonTyCon + eith_cls = + case instance_head of + Right cls -> Right cls + Left illegal_head_reason -> + Left + ( getLocA head_ty' + , TcRnIllegalInstance $ + IllegalClassInstance (HsTypeRnThing $ unLoc head_ty') $ + IllegalInstanceHead illegal_head_reason + ) -- ...finally, attempt to retrieve the class type constructor, failing -- with an error message if there isn't one. To avoid excessive -- amounts of error messages, we will only report one of the errors -- from mb_nested_msg or eith_cls at a time. ; cls <- case (mb_nested_msg, eith_cls) of (Nothing, Right cls) -> pure cls - (Just err1, _) -> bail_out err1 - (_, Left err2) -> bail_out err2 + (Just err1, _) -> bail_out ctxt err1 + (_, Left err2) -> bail_out ctxt err2 -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -611,7 +660,8 @@ ; let all_fvs = meth_fvs `plusFV` more_fvs `plusFV` inst_fvs - ; return (ClsInstDecl { cid_ext = noExtField + ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps + ; return (ClsInstDecl { cid_ext = inst_warn_rn , cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_tyfam_insts = ats' , cid_overlap_mode = oflag @@ -628,14 +678,12 @@ -- strange, but should not matter (and it would be more work -- to remove the context). where - ctxt = GenericCtx $ text "an instance declaration" - -- The instance is malformed. We'd still like to make *some* progress -- (rather than failing outright), so we report an error and continue for -- as long as we can. Importantly, this error should be thrown before we -- reach the typechecker, lest we encounter different errors that are -- hopelessly confusing (such as the one in #16114). - bail_out (l, err_msg) = do + bail_out ctxt (l, err_msg) = do addErrAt l $ TcRnWithHsDocContext ctxt err_msg pure $ mkUnboundName (mkTcOccFS (fsLit "")) @@ -699,7 +747,7 @@ groups :: [NonEmpty (LocatedN RdrName)] groups = equivClasses cmpLocated pat_kity_vars - ; nms_dups <- mapM (lookupOccRn . unLoc) $ + ; nms_dups <- mapM (lookupOccRn WL_TyVar . unLoc) $ [ tv | (tv :| (_:_)) <- groups ] -- Add to the used variables -- a) any variables that appear *more than once* on the LHS @@ -851,10 +899,11 @@ -- Rename associated type family decl in class rnATDecls :: Name -- Class + -> [Name] -- Class variables. See Note [Class variables and filterInScope] in GHC.Rename.HsType -> [LFamilyDecl GhcPs] -> RnM ([LFamilyDecl GhcRn], FreeVars) -rnATDecls cls at_decls - = rnList (rnFamDecl (Just cls)) at_decls +rnATDecls cls cls_tvs at_decls + = rnList (rnFamDecl (Just (cls, cls_tvs))) at_decls rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames decl GhcPs -> -- an instance. rnTyFamInstDecl @@ -1107,7 +1156,7 @@ -} rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) -rnSrcDerivDecl (DerivDecl _ ty mds overlap) +rnSrcDerivDecl (DerivDecl (inst_warn_ps, ann) ty mds overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; unless standalone_deriv_ok (addErr TcRnUnexpectedStandaloneDerivingDecl) ; checkInferredVars ctxt nowc_ty @@ -1119,11 +1168,10 @@ ; addNoNestedForallsContextsErr ctxt NFC_StandaloneDerivedInstanceHead (getLHsInstDeclHead $ dropWildCards ty') - ; warnNoDerivStrat mds' loc - ; return (DerivDecl noAnn ty' mds' overlap, fvs) } + ; 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 {- @@ -1142,66 +1190,23 @@ , rds_rules = rn_rules }, fvs) } rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) -rnHsRuleDecl (HsRule { rd_ext = (_, st) - , rd_name = rule_name - , rd_act = act - , rd_tyvs = tyvs - , rd_tmvs = tmvs - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs - ; mapM_ warnForallIdentifier rdr_names_w_loc - ; checkDupRdrNames rdr_names_w_loc - ; checkShadowedRdrNames rdr_names_w_loc - ; names <- newLocalBndrsRn rdr_names_w_loc - ; let doc = RuleCtx (unLoc rule_name) - ; bindRuleTyVars doc tyvs $ \ tyvs' -> - bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> +rnHsRuleDecl (HsRule { rd_ext = (_, st) + , rd_name = lrule_name@(L _ rule_name) + , rd_act = act + , rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = bindRuleBndrs (RuleCtx rule_name) bndrs $ \tm_names bndrs' -> do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs - ; checkValidRule (unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st) - , rd_name = rule_name - , rd_act = act - , rd_tyvs = tyvs' - , rd_tmvs = tmvs' - , rd_lhs = lhs' - , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } - where - get_var :: RuleBndr GhcPs -> LocatedN RdrName - get_var (RuleBndrSig _ v _) = v - get_var (RuleBndr _ v) = v - -bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs - -> [LRuleBndr GhcPs] -> [Name] - -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -bindRuleTmVars doc tyvs vars names thing_inside - = go vars names $ \ vars' -> - bindLocalNamesFV names (thing_inside vars') - where - go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside - = go vars ns $ \ vars' -> - thing_inside (L l (RuleBndr noAnn (L loc n)) : vars') - - go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) - (n : ns) thing_inside - = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> - go vars ns $ \ vars' -> - thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars') - - go [] [] thing_inside = thing_inside [] - go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) - - bind_free_tvs = case tyvs of Nothing -> AlwaysBind - Just _ -> NeverBind - -bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs] - -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)) - -> RnM (b, FreeVars) -bindRuleTyVars doc (Just bndrs) thing_inside - = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just) -bindRuleTyVars _ _ thing_inside = thing_inside Nothing + ; checkValidRule rule_name tm_names lhs' fv_lhs' + ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st) + , rd_name = lrule_name + , rd_act = act + , rd_bndrs = bndrs' + , rd_lhs = lhs' + , rd_rhs = rhs' } + , fv_lhs' `plusFV` fv_rhs') } {- Note [Rule LHS validity checking] @@ -1217,9 +1222,18 @@ 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 () +checkValidRule :: RuleName -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs' = do { -- Check for the form of the LHS case (validRuleLhs ids lhs') of @@ -1241,9 +1255,11 @@ check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType _ e _ _) = checkl e + check (HsAppType _ e _) = checkl e check (HsVar _ lv) - | (unLoc lv) `notElem` foralls = Nothing + | getName lv `notElem` foralls = Nothing + -- See Note [Parens on the LHS of a RULE] + check (HsPar _ e) = checkl e check other = Just other -- Failure -- Check an argument @@ -1271,7 +1287,7 @@ = TcRnIllegalRuleLhs errReason name lhs bad_e where errReason = case bad_e of - HsUnboundVar _ uv -> + HsHole (HoleVar (L _ uv)) -> UnboundVariable uv $ notInScopeErr WL_Global uv _ -> IllegalExpression @@ -1294,13 +1310,12 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. -Note [Dependency analysis of type, class, and instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of -type/class/instance decls, together with the role annotations for the -type/class declarations. The renamer uses strongly connected -component analysis to build these groups. We do this for a number of -reasons: +Note [Dependency analysis of type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected component of type/class/instance +decls, together with the role annotations and standalone kind signatures for the +type/class declarations. The renamer uses strongly connected component analysis +to build these groups. We do this for a number of reasons: * Improve kind error messages. Consider @@ -1312,90 +1327,153 @@ inference together, you might get an error reported in S, which is jolly confusing. See #4875 - * Increase kind polymorphism. See GHC.Tc.TyCl Note [Grouping of type and class declarations] -Why do the instance declarations participate? At least two reasons +What about instances? Based on a number of tickets (#12088, #12239, #14668, +#15561, #16410, #16448, #16693, #19611, #20875, #21172, #22257, #25238, #25834, +etc) we concluded that we cannot handle them at this stage. -* Consider (#11348) +It is not possible, by looking at the free variables of a declaration, to +determine which instances a declaration depends on; furthermore, it is not +possible to discover dependencies between instances, for the same reason. - type family F a - type instance F Int = Bool +Previously GHC inserted instances at the earliest positions where their FVs are +bound, but it only helped with a subset of tickets. The current approach is to +accept that the dependency analysis here is incomplete and recover in the kind +checker with a retrying mechanism. See Note [Retrying TyClGroups] in GHC.Tc.TyCl - data R = MkR (F Int) +------------------------------------ +So much for why we want SCCs. What about how and when we construct them? - type Foo = 'MkR 'True +First, an overview: + (TCDEP1) Flatten TyClGroups from the parser + (TCDEP2) Rename the type/class declarations, standalone kind signatures, role + declarations, and instances individually + (TCDEP3) Preprocess FVs and build a dependency graph + (TCDEP4) Find strongly connected components (SCCs) of declarations + (TCDEP5) Attach roles and kind signatures to the appropriate SCC + (TCDEP6) Create one singleton "SCC" per instance and put them at the end - For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't - know that unless we've looked at the type instance declaration for F - before kind-checking Foo. +And now the deep dive: -* Another example is this (#3990). +(TCDEP1) We start with a `HsGroup GhcPs`, containing a `[TyClGroup GhcPs]`: + a big pile of declarations. It is not important how the parser distributes + declarations across those TyClGroups, as the first thing we do in `rnTyClDecls` + is flatten them using a few helpers: - data family Complex a - data instance Complex Double = CD {-# UNPACK #-} !Double - {-# UNPACK #-} !Double + tyClGroupTyClDecls = Data.List.concatMap group_tyclds + tyClGroupInstDecls = Data.List.concatMap group_instds + tyClGroupRoleDecls = Data.List.concatMap group_roles + tyClGroupKindSigs = Data.List.concatMap group_kisigs - data T = T {-# UNPACK #-} !(Complex Double) + In practice, the parser just puts all declarations in a single `TyClGroup`, + so the `concatMap` is a no-op. - Here, to generate the right kind of unpacked implementation for T, - we must have access to the 'data instance' declaration. +(TCDEP2) Rename each declaration separately, yielding the following lists + in `rnTyClDecls`: -* Things become more complicated when we introduce transitive - dependencies through imported definitions, like in this scenario: + tycls_w_fvs :: [(LTyClDecl GhcRn, FreeVars)] + instds_w_fvs :: [(LInstDecl GhcRn, FreeVars)] + kisigs_w_fvs :: [(LStandaloneKindSig GhcRn, FreeVars)] + role_annots :: [LRoleAnnotDecl GhcRn] - A.hs - type family Closed (t :: Type) :: Type where - Closed t = Open t + The `FreeVars` are the free type/data constructors of the decl. For example: - type family Open (t :: Type) :: Type + type family F (a :: k) -- FVs: {} + data X = MkX Char (Maybe X) -- FVs: {Char, Maybe, X} + data Y = MkY X (Maybe Y) -- FVs: {Maybe, Y, X} + type instance F MkX = X -- FVs: {F, MkX, X} + type instance F MkY = Int -- FVs: {F, MkY, Int} - B.hs - data Q where - Q :: Closed Bool -> Q +(TCDEP3) Build a graph where each node is a `TyClDecl` keyed by its name, and + its `FreeVars` give rise to edges. Happens in `depAnalTyClDecls`. Examples: - type instance Open Int = Bool + data A x = MkA x -- node `A`, edges: {} + data B x = MkB (A x) -- node `B`, edges: {B -> A} + data C = MkC (B C) -- node `C`, edges: {C -> B, C -> C} - type S = 'Q 'True + The `FreeVars` are not used "as is" to create the edges. They first undergo a + few transformations. - Somehow, we must ensure that the instance Open Int = Bool is checked before - the type synonym S. While we know that S depends upon 'Q depends upon Closed, - we have no idea that Closed depends upon Open! + (TCDEP3.fvs_kisig) If a standalone kind signature is present, add its free + variables to those of the declaration. Consider: - To accommodate for these situations, we ensure that an instance is checked - before every @TyClDecl@ on which it does not depend. That's to say, instances - are checked as early as possible in @tcTyAndClassDecls@. + data A = MkA + data B = MkB ------------------------------------- -So much for WHY. What about HOW? It's pretty easy: + type P :: A -> Type -- sig FVs: {A, Type} + data P x = MkP (Proxy MkB) -- decl FVs: {Proxy, MkB} -(1) Rename the type/class, instance, and role declarations - individually + By adding the sig and decl FVs together, we get {A, Type, Proxy, MkB}. + Then proceed to the next step. -(2) Do strongly-connected component analysis of the type/class decls, - We'll make a TyClGroup for each SCC + (TCDEP3.fvs_parent) Replace any mention of a (promoted) data constructor + with its parent TyCon. Consider the FVs from the previous step: - In this step we treat a reference to a (promoted) data constructor - K as a dependency on its parent type. Thus - data T = K1 | K2 - data S = MkS (Proxy 'K1) - Here S depends on 'K1 and hence on its parent T. + the name set {A, Type, Proxy, MkB} + turns into {A, Type, Proxy, B} - In this step we ignore instances; see - Note [No dependencies on data instances] + MkB does not get its own node in the graph, so an edge to it must actually + point to B. -(3) Attach roles to the appropriate SCC + (TCDEP3.fvs_nogbl) Filter out references to type constructors outside this + `HsGroup`. They just clutter things up: -(4) Attach instances to the appropriate SCC. - We add an instance decl to SCC when: - all its free types/classes are bound in this SCC or earlier ones + the name set {A, Type, Proxy, B} + turns into {A, B} -(5) We make an initial TyClGroup, with empty group_tyclds, for any - (orphan) instances that affect only imported types/classes + Note [Prepare TyClGroup FVs] describes these transformations in more detail. + Back to our `P` example, the final nodes and edges are as follows: -Steps (3) and (4) are done by the (mapAccumL mk_group) call. + data A = MkA -- node `A`, edges: {} + data B = MkB -- node `B`, edges: {} + type P :: A -> Type + data P x = MkP (Proxy MkB) -- node `P`, edges: {P -> A, P -> B} + +(TCDEP4) Find strongly connected components (SCCs) of `TyClDecl`s. + This happens immediately after building the dependency graph in + `depAnalTyClDecls`. As the result, in `rnTyClDecls` we get + + tycl_sccs :: [SCC (LTyClDecl GhcRn, NameSet)] + + These SCCs are topologically sorted, but only according to lexical + dependencies (i.e. dependencies that can be found by looking at the FVs). + Non-lexical dependencies (i.e. dependencies on instances) are ignored because + they can't be reliably found prior to type checking. + + More on that in Note [Retrying TyClGroups] in GHC.Tc.TyCl. + +(TCDEP5) For each SCC, create a `TyClGroup GhcRn`. Standalone kind signatures + and role annotations are looked up by name and included in the same + `TyClGroup` as the corresponding type/class declarations. + + The extension field `group_ext` of `TyClGroup GhcRn` contains the dependencies + of the SCC computed from FVs in step (TCDEP3), but /excluding/ the type + constructors bound by the group itself. Example: + + -- TyClGroup: binds {Z} + -- depends on {} + data Z = MkZ -- FVs: {} + + -- TyClGroup: binds {X, Y} + -- depends on {Z} rather than {X, Y, Z} + data X = MkX Y Z -- FVs: {Y, Z} + data Y = MkY X Z -- FVs: {X, Z} + + Reason: `isReadyTyClGroup` in GHC.Tc.TyCl is a function that checks whether + all of a TyClGroup's dependencies are present in the type checking env, and we + wouldn't want it to consider a group to be "blocked" on its own declarations. + +(TCDEP6) For each instance, create a singleton `TyClGroup GhcRn`, and put them + all at the end, where their lexical dependencies are surely satisfied. + More on that in Note [Put instances at the end]. + + The `group_ext` field in an instance TyClGroup is set to the FVs of the + instance, preprocessed much in the same way as declaration FVs in step + (TCDEP3). See Note [Prepare TyClGroup FVs] for details. + Note [No dependencies on data instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -1412,6 +1490,32 @@ Ugh. For now we simply don't allow promotion of data constructors for data instances. See Note [AFamDataCon: not promoting data family constructors] in GHC.Tc.Utils.Env + +Note [Put instances at the end] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point including type family instances or class instances in the +graph for SCC analysis because instances are not referred to by name. We cannot +discover, by looking at the free variables of a declaration, what instances it +depends on. + +Instead, we create one singleton "SCC" per instance using mkInstGroups and put +them at the end. This is simple and guarantees that the FVs of all instances are +bound in the preceding TyClGroups. + +The problem is that if there are any declarations that depend on instances, +they're going to fail kind checking, because instances come after the +declarations. To account for that, the kind checker goes through a multipass +ordeal described in Note [Retrying TyClGroups] in GHC.Tc.TyCl. + +One might ask, "why not insert instances at the earliest positions where their +FVs are bound?" Indeed, this sounds like a plausible solution, and GHC used to +do it at one point. However, there are many tickets (and now test cases) +demonstrating its inadequacy: #12088, #12239, #14668, #15561, #16410, #16448, +#16693, #19611, #20875, #21172, #22257, #25238, #25834, etc. + +As to why we put each instance in its own group, as opposed to using just one +group with all the instances, the reason is that an instance may depend on +another instance, so we better add them to the environment one by one. -} @@ -1419,7 +1523,8 @@ -> RnM ([TyClGroup GhcRn], FreeVars) -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds - = do { -- Rename the type/class, instance, and role declarations + = do { -- Flatten TyClGroups and rename each declaration individually. + -- Steps (TCDEP1) and (TCDEP2) of Note [Dependency analysis of type and class decls] ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds) ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) ; traceRn "rnTyClDecls" $ @@ -1429,61 +1534,47 @@ ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) - -- Do SCC analysis on the type/class decls + -- Do SCC analysis on the type/class declarations. + -- Steps (TCDEP3) and (TCDEP4) of Note [Dependency analysis of type and class decls] ; rdr_env <- getGlobalRdrEnv ; traceRn "rnTyClDecls SCC analysis" $ vcat [ text "rdr_env:" <+> ppr rdr_env ] - ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs - role_annot_env = mkRoleAnnotEnv role_annots + ; let tycl_sccs = depAnalTyClDecls rdr_env tc_names kisig_fv_env tycls_w_fvs (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs - - inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs - (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map + role_annot_env = mkRoleAnnotEnv role_annots - first_group - | null init_inst_ds = [] - | otherwise = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = init_inst_ds }] + -- Construct renamed TyClGroups. + -- Steps (TCDEP5) and (TCDEP6) of Note [Dependency analysis of type and class decls] + ; let tycl_groups = map (mk_group role_annot_env kisig_env) tycl_sccs + inst_groups = mkInstGroups rdr_env tc_names instds_w_fvs + all_groups = tycl_groups ++ inst_groups - (final_inst_ds, groups) - = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs + ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) - all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` + ; let all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` foldr (plusFV . snd) emptyFVs kisigs_w_fvs - all_groups = first_group ++ groups - - ; massertPpr (null final_inst_ds) - (ppr instds_w_fvs - $$ ppr inst_ds_map - $$ ppr (flattenSCCs tycl_sccs) - $$ ppr final_inst_ds) - - ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) ; return (all_groups, all_fvs) } where + -- Construct a type/class declaration TyClGroup. + -- Step (TCDEP5) of Note [Dependency analysis of type and class decls] mk_group :: RoleAnnotEnv -> KindSigEnv - -> InstDeclFreeVarsMap - -> SCC (LTyClDecl GhcRn) - -> (InstDeclFreeVarsMap, TyClGroup GhcRn) - mk_group role_env kisig_env inst_map scc - = (inst_map', group) + -> SCC (LTyClDecl GhcRn, NameSet) + -> TyClGroup GhcRn + mk_group role_env kisig_env scc = group where - tycl_ds = flattenSCC scc - bndrs = map (tcdName . unLoc) tycl_ds - roles = getRoleAnnots bndrs role_env - kisigs = getKindSigs bndrs kisig_env - (inst_ds, inst_map') = getInsts bndrs inst_map - group = TyClGroup { group_ext = noExtField + (tycl_ds, nodes_deps) = unzip (flattenSCC scc) + node_bndrs = map (tcdName . unLoc) tycl_ds + deps = delFVs node_bndrs (plusFVs nodes_deps) + -- (delFVs node_bndrs) removes the self-references. + -- See Note [Prepare TyClGroup FVs] + group = TyClGroup { group_ext = deps , group_tyclds = tycl_ds - , group_kisigs = kisigs - , group_roles = roles - , group_instds = inst_ds } + , group_kisigs = getKindSigs node_bndrs kisig_env + , group_roles = getRoleAnnots node_bndrs role_env + , group_instds = [] } -- | Free variables of standalone kind signatures. newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) @@ -1524,32 +1615,39 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures ; unless standalone_ki_sig_ok $ addErr TcRnUnexpectedStandaloneKindSig - ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v - ; let doc = StandaloneKindSigCtx (ppr v) - ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki + ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) SigLikeStandaloneKindSig v + ; (new_ki, fvs) <- rnHsSigType (StandaloneKindSigCtx v) KindLevel ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } +-- See Note [Dependency analysis of type and class decls] depAnalTyClDecls :: GlobalRdrEnv - -> KindSig_FV_Env + -> NameSet -- Names in the current HsGroup + -> KindSig_FV_Env -- FVs of standalone kind signatures -> [(LTyClDecl GhcRn, FreeVars)] - -> [SCC (LTyClDecl GhcRn)] --- See Note [Dependency analysis of type, class, and instance decls] -depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs + -> [SCC (LTyClDecl GhcRn, NameSet)] +depAnalTyClDecls rdr_env tc_names kisig_fv_env ds_w_fvs = stronglyConnCompFromEdgedVerticesUniq edges where - edges :: [ Node Name (LTyClDecl GhcRn) ] - edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) + -- Build a graph where each node is a `TyClDecl` keyed by its name, and + -- its `FreeVars` give rise to edges. + -- Step (TCDEP3) of Note [Dependency analysis of type and class decls] + edges :: [ Node Name (LTyClDecl GhcRn, NameSet) ] + edges = [ DigraphNode (d, deps) name (nonDetEltsUniqSet deps) + -- nonDetEltsUniqSet is OK to use here because the order of the edges + -- has no effect on the result of stronglyConnCompFromEdgedVerticesUniq. + -- See Note [Deterministic SCC] in GHC.Data.Graph.Directed. + | (d, fvs) <- ds_w_fvs, let { name = tcdName (unLoc d) ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name - ; deps = fvs `plusFV` kisig_fvs + ; node_fvs = fvs `plusFV` kisig_fvs -- (TCDEP3.fvs_kisig) + ; deps = toParents rdr_env node_fvs `intersectFVs` tc_names + -- (toParents rdr_env) maps datacons to parent tycons (TCDEP3.fvs_parent), + -- (`intersectFVs` tc_names) filters out imported names (TCDEP3.fvs_nogbl). + -- See also Note [Prepare TyClGroup FVs] } ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic - -- even if the edges are in nondeterministic order as explained - -- in Note [Deterministic SCC] in GHC.Data.Graph.Directed. toParents :: GlobalRdrEnv -> NameSet -> NameSet toParents rdr_env ns @@ -1567,7 +1665,82 @@ _ -> n Nothing -> n +{- Note [Prepare TyClGroup FVs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The renamer returns, alongside each renamed type/class declaration or instance, +the set of its free variables: + rnTyClDecl :: TyClDecl GhcPs -> RnM (TyClDecl GhcRn, FreeVars) + rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) + +For example: + + type family F (a :: k) -- FVs: {} + data X = MkX Char (Maybe X) -- FVs: {Char, Maybe, X} + data Y = MkY X (Maybe Y) -- FVs: {Maybe, Y, X} + type instance F MkX = X -- FVs: {F, MkX, X} + type instance F MkY = Int -- FVs: {F, MkY, Int} + +This is almost what we need for dependency analysis (i.e. to figure out in which +order to check the declarations), but first we apply a few transformations: + +* toParents rdr_env inst_fvs `intersectFVs` tc_names -- in mkInstGroups +* toParents rdr_env node_fvs `intersectFVs` tc_names -- in depAnalTyClDecls +* delFVs node_bndrs (plusFVs nodes_deps) -- in rnTyClGroups + +The cited lines of code are somewhat far apart; to see the big picture, refer +to Note [Dependency analysis of type and class decls], and more specifically +steps TCDEP3, TCDEP5, and TCDEP6. + +The cumulative effect of these transformations is as follows: + +* Data constructor names are replaced by the parent type constructors: + {MkX} ==> {X} + Part of the code: + toParents rdr_env + Reason: + MkX does not get its own node in the dependency graph, + so we cannot make an edge to it in `depAnalTyClDecls` + +* Names defined outside the current HsGroup are filtered out: + {Char,Maybe} ==> {} + Part of the code: + `intersectFVs` tc_names + Reason: + makes the NameSet smaller, so there are fewer subsequent lookups + in `graphFromEdgedVertices` (GHC.Data.Graph.Directed) + and in `isReadyTyClGroup` (GHC.Tc.TyCl) + +* Self-references are removed: + {A,B,C} ==> {C}, iff in the TyClGroup that defines {A,B} + Part of the code: + delFVs node_bndrs + Reason: + avoids the problem that `isReadyTyClGroup` would otherwise consider + a recursive TyClGroup to be blocked on itself + Note: + needs to happen after the SCC analysis because of + mutually-recursive data types + +These "prepared" FVs are the lexical dependencies of a TyClGroup that are stored +in the XCTyClGroup extension field: + + type family F (a :: k) -- XCTyClGroup: {} + data X = MkX Char (Maybe X) -- XCTyClGroup: {} + data Y = MkY X (Maybe Y) -- XCTyClGroup: {X} + type instance F MkX = X -- XCTyClGroup: {F, X} + type instance F MkY = Int -- XCTyClGroup: {F, Y} + +Before attempting to kind-check a TyClGroup, all of its lexical dependencies +need to be satisfied, i.e. there must be a TyThing in the TypeEnv for each of +these names. + +Imported names {Char,Maybe} don't need to be explicitly included in the set of +lexical dependencies because `isReadyTyClGroup` can safely assume those are +definitely already in the env. +-} + + {- ****************************************************** * * Role annotations @@ -1593,7 +1766,7 @@ = do { -- the name is an *occurrence*, but look it up only in the -- decls defined in this group (see #10263) tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) - (text "role annotation") + SigLikeRoleAnnotation tycon ; return $ RoleAnnotDecl noExtField tycon' roles } @@ -1631,43 +1804,27 @@ ****************************************************** -} ---------------------------------------------------------- --- | 'InstDeclFreeVarsMap is an association of an --- @InstDecl@ with @FreeVars@. The @FreeVars@ are --- the tycon names that are both --- a) free in the instance declaration --- b) bound by this group of type/class/instance decls -type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] - --- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the --- @FreeVars@ which are *not* the binders of a @TyClDecl@. -mkInstDeclFreeVarsMap :: GlobalRdrEnv - -> NameSet - -> [(LInstDecl GhcRn, FreeVars)] - -> InstDeclFreeVarsMap -mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs - = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) - | (inst_decl, fvs) <- inst_ds_fvs ] - --- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the --- @InstDeclFreeVarsMap@ with these entries removed. --- We call (getInsts tcs instd_map) when we've completed the declarations --- for 'tcs'. The call returns (inst_decls, instd_map'), where --- inst_decls are the instance declarations all of --- whose free vars are now defined --- instd_map' is the inst-decl map with 'tcs' removed from --- the free-var set -getInsts :: [Name] -> InstDeclFreeVarsMap - -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) -getInsts bndrs inst_decl_map - = partitionWith pick_me inst_decl_map +-- | Construct a @TyClGroup@ for each @InstDecl@. +-- Step (TCDEP6) of Note [Dependency analysis of type and class decls] +mkInstGroups :: GlobalRdrEnv + -> NameSet + -> [(LInstDecl GhcRn, FreeVars)] + -> [TyClGroup GhcRn] +mkInstGroups rdr_env tc_names inst_ds_fvs + = [ mk_inst_group deps inst_decl + | (inst_decl, inst_fvs) <- inst_ds_fvs + , let deps = toParents rdr_env inst_fvs `intersectFVs` tc_names ] + -- (toParents rdr_env) maps datacons to parent tycons, + -- (`intersectFVs` tc_names) filters out imported names. + -- See Note [Prepare TyClGroup FVs] where - pick_me :: (LInstDecl GhcRn, FreeVars) - -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) - pick_me (decl, fvs) - | isEmptyNameSet depleted_fvs = Left decl - | otherwise = Right (decl, depleted_fvs) - where - depleted_fvs = delFVs bndrs fvs + mk_inst_group :: NameSet -> LInstDecl GhcRn -> TyClGroup GhcRn + mk_inst_group deps inst_d = + TyClGroup { group_ext = deps + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [inst_d] } {- ****************************************************** * * @@ -1686,7 +1843,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs }) - = do { tycon' <- lookupLocatedTopConstructorRnN tycon + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon ; let kvs = extractHsTyRdrTyVarsKindVars rhs doc = TySynCtx tycon ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) @@ -1706,7 +1863,7 @@ { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} }) - = do { tycon' <- lookupLocatedTopConstructorRnN tycon + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon new_or_data = dataDefnConsNewOrData cons @@ -1723,13 +1880,12 @@ , tcdDataDefn = defn' , tcdDExt = rn_info }, fvs) } } -rnTyClDecl (ClassDecl { tcdLayout = layout, - tcdCtxt = context, tcdLName = lcls, +rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, tcdDocs = docs}) - = do { lcls' <- lookupLocatedTopConstructorRnN lcls + = do { lcls' <- lookupLocatedTopBndrRnN WL_TyCon lcls ; let cls' = unLoc lcls' kvs = [] -- No scoped kind vars except those in -- kind signatures on the tyvars @@ -1741,7 +1897,7 @@ { (context', cxt_fvs) <- rnMaybeContext cls_doc context ; fds' <- rnFds fds -- The fundeps have no free variables - ; (ats', fv_ats) <- rnATDecls cls' ats + ; (ats', fv_ats) <- rnATDecls cls' (hsAllLTyVarNames tyvars') ats ; let fvs = cxt_fvs `plusFV` fv_ats ; return ((tyvars', context', fds', ats'), fvs) } @@ -1778,8 +1934,7 @@ ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; docs' <- traverse rnLDocDecl docs - ; return (ClassDecl { tcdLayout = rnLayoutInfo layout, - tcdCtxt = context', tcdLName = lcls', + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', @@ -1788,11 +1943,6 @@ where cls_doc = ClassDeclCtx lcls -rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn -rnLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb -rnLayoutInfo (VirtualBraces n) = VirtualBraces n -rnLayoutInfo NoLayoutInfo = NoLayoutInfo - -- Does the data type declaration include a CUSK? data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do @@ -1862,7 +2012,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' } @@ -1885,7 +2035,7 @@ = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData ; unless (null (fromMaybeContext context)) $ failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts - ; mapM_ (addLocMA check_type_data_condecl) condecls + ; mapM_ (addLocM check_type_data_condecl) condecls ; unless (null derivs) $ failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses } @@ -1902,19 +2052,17 @@ } has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True - has_labelled_fields (ConDeclH98 { con_args = RecCon rec }) - = not (null (unLoc rec)) + has_labelled_fields (ConDeclH98 { con_args = RecCon flds }) + = not (null (unLoc flds)) has_labelled_fields _ = False has_strictness_flags condecl - = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl) - - is_strict (HsSrcBang _ _ s) = isSrcStrict s + = any isSrcStrict (con_arg_bangs condecl) - con_args (ConDeclGADT { con_g_args = PrefixConGADT args }) = args - con_args (ConDeclH98 { con_args = PrefixCon _ args }) = args - con_args (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [arg1, arg2] - con_args _ = [] + con_arg_bangs (ConDeclGADT { con_g_args = PrefixConGADT _ args }) = map cdf_bang args + con_arg_bangs (ConDeclH98 { con_args = PrefixCon args }) = map cdf_bang args + con_arg_bangs (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [cdf_bang arg1, cdf_bang arg2] + con_arg_bangs _ = [] {- Note [Type data declarations] @@ -2020,13 +2168,17 @@ with the data constructor, else (I1) is violated. See GHC.Core.Utils Note [Refine DEFAULT case alternatives] Exception 2 - (W2c) In `GHC.Core.Opt.ConstantFold.caseRules`, disable the rule for - `dataToTag#` in the case of `type data`. We do not want to transform - case dataToTag# x of t -> blah + (W2c) In `GHC.Core.Opt.ConstantFold.caseRules`, we do not want to transform + case dataToTagLarge# x of t -> blah into case x of { A -> ...; B -> .. } - because again that conjures up the type-level-only data contructors + because again that conjures up the type-level-only data constructors `A` and `B` in a pattern, violating (I1) (#23023). + So we check for "type data" TyCons before applying this + transformation. (In practice, this doesn't matter because + we also refuse to solve DataToTag instances at types + corresponding to type data declarations. See rule C1 from + Note [DataToTag overview] in GHC.Tc.Instance.Class.) The main parts of the implementation are: @@ -2077,7 +2229,7 @@ from `type data`, which do not use the distinguishing quote mark added to constructors promoted by DataKinds. -* GHC.Core.TyCon.isDataTyCon ignores types coming from a `type data` +* GHC.Core.TyCon.isBoxedDataTyCon ignores types coming from a `type data` declaration (by checking the `is_type_data` field), so that these do not contribute executable code such as constructor wrappers. @@ -2091,18 +2243,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 @@ -2112,7 +2252,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' }) @@ -2190,7 +2329,8 @@ (thing, fvs) <- thing_inside pure (ds, thing, fvs) -rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested +rnFamDecl :: Maybe (Name, [Name]) + -- Just (cls, cls_tvs) => this FamilyDecl is nested -- inside an *class decl* for cls -- used for associated types -> FamilyDecl GhcPs @@ -2200,7 +2340,7 @@ , fdFixity = fixity , fdInfo = info, fdResultSig = res_sig , fdInjectivityAnn = injectivity }) - = do { tycon' <- lookupLocatedTopConstructorRnN tycon + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon ; ((tyvars', res_sig', injectivity'), fv1) <- bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> do { let rn_sig = rnFamResultSig doc @@ -2250,15 +2390,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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2304,7 +2450,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 @@ -2314,8 +2460,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 @@ -2329,7 +2478,7 @@ ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid ; addErrAt (locA srcSpan) $ - TcRnUnknownTyVarsOnRhsOfInjCond errorVars } + TcRnUnknownTyVarsOnRhsOfInjCond errorVars } } } ; return injDecl' } @@ -2375,8 +2524,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = mcxt, con_args = args , con_doc = mb_doc, con_forall = forall_ }) - = do { _ <- addLocMA checkConName name - ; new_name <- lookupLocatedTopConstructorRnN name + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRnN WL_ConLike name -- We bind no implicit binders here; this is just like -- a nested HsForAllTy. E.g. consider @@ -2398,7 +2547,7 @@ , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) ; mb_doc' <- traverse rnLHsDoc mb_doc - ; return (decl { con_ext = noAnn + ; return (decl { con_ext = noExtField , con_name = new_name, con_ex_tvs = new_ex_tvs , con_mb_cxt = new_context, con_args = new_args , con_doc = mb_doc' @@ -2406,14 +2555,14 @@ all_fvs) }} rnConDecl (ConDeclGADT { con_names = names - , con_dcolon = dcol - , con_bndrs = L l outer_bndrs + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs + , con_inner_bndrs = inner_bndrs , con_mb_cxt = mcxt , con_g_args = args , con_res_ty = res_ty , con_doc = mb_doc }) - = do { mapM_ (addLocMA checkConName) names - ; new_names <- mapM (lookupLocatedTopConstructorRnN) names + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM (lookupLocatedTopBndrRnN WL_ConLike) names ; let -- We must ensure that we extract the free tkvs in left-to-right -- order of their appearance in the constructor type. @@ -2422,6 +2571,7 @@ -- See #14808. implicit_bndrs = extractHsOuterTvBndrs outer_bndrs $ + extractHsForAllTelescopes inner_bndrs $ extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] @@ -2429,6 +2579,7 @@ ; let ctxt = ConDeclCtx (toList new_names) ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> + bindHsForAllTelescopes ctxt inner_bndrs $ \inner_bndrs' -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty @@ -2442,11 +2593,12 @@ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 ; traceRn "rnConDecl (ConDeclGADT)" - (ppr names $$ ppr outer_bndrs') + (ppr names $$ ppr outer_bndrs' $$ ppr inner_bndrs') ; new_mb_doc <- traverse rnLHsDoc mb_doc - ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names - , con_dcolon = dcol - , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt + ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names + , con_outer_bndrs = L outer_bndrs_loc outer_bndrs' + , con_inner_bndrs = inner_bndrs' + , con_mb_cxt = new_cxt , con_g_args = new_args, con_res_ty = new_res_ty , con_doc = new_mb_doc }, all_fvs) } } @@ -2462,15 +2614,15 @@ -> HsDocContext -> HsConDeclH98Details GhcPs -> RnM (HsConDeclH98Details GhcRn, FreeVars) -rnConDeclH98Details _ doc (PrefixCon _ tys) - = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys - ; return (PrefixCon noTypeArgs new_tys, fvs) } +rnConDeclH98Details _ doc (PrefixCon tys) + = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys + ; return (PrefixCon new_tys, fvs) } rnConDeclH98Details _ doc (InfixCon ty1 ty2) - = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1 - ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 + = do { (new_ty1, fvs1) <- rnHsConDeclField doc ty1 + ; (new_ty2, fvs2) <- rnHsConDeclField doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } rnConDeclH98Details con doc (RecCon flds) - = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds + = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds ; return (RecCon new_flds, fvs) } rnConDeclGADTDetails :: @@ -2478,21 +2630,21 @@ -> HsDocContext -> HsConDeclGADTDetails GhcPs -> RnM (HsConDeclGADTDetails GhcRn, FreeVars) -rnConDeclGADTDetails _ doc (PrefixConGADT tys) - = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys - ; return (PrefixConGADT new_tys, fvs) } -rnConDeclGADTDetails con doc (RecConGADT flds arr) - = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds - ; return (RecConGADT new_flds arr, fvs) } +rnConDeclGADTDetails _ doc (PrefixConGADT _ tys) + = do { (new_tys, fvs) <- mapFvRn (rnHsConDeclField doc) tys + ; return (PrefixConGADT noExtField new_tys, fvs) } +rnConDeclGADTDetails con doc (RecConGADT _ flds) + = do { (new_flds, fvs) <- rnRecHsConDeclRecFields con doc flds + ; return (RecConGADT noExtField new_flds, fvs) } -rnRecConDeclFields :: +rnRecHsConDeclRecFields :: Name -> HsDocContext - -> LocatedL [LConDeclField GhcPs] - -> RnM (LocatedL [LConDeclField GhcRn], FreeVars) -rnRecConDeclFields con doc (L l fields) - = do { fls <- lookupConstructorFields con - ; (new_fields, fvs) <- rnConDeclFields doc fls fields + -> LocatedL [LHsConDeclRecField GhcPs] + -> RnM (LocatedL [LHsConDeclRecField GhcRn], FreeVars) +rnRecHsConDeclRecFields con doc (L l fields) + = do { fls <- lookupConstructorFields (noUserRdr con) + ; (new_fields, fvs) <- rnHsConDeclRecFields doc fls fields -- No need to check for duplicate fields -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn ; pure (L l new_fields, fvs) } @@ -2532,16 +2684,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 (conDetailsVisArity (RecCon as)) flds return ((PatSynName bnd_name, con_info) : names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind = do - bnd_name <- newTopSrcBinder (L (la2na bind_loc) n) - let con_info = mkConInfo (conDetailsArity length as) [] + bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) + let con_info = mkConInfo ConIsPatSyn (conDetailsVisArity as) [] return ((PatSynName bnd_name, con_info) : names) | otherwise = return names +conDetailsVisArity :: HsPatSynDetails (GhcPass p) -> VisArity +conDetailsVisArity = \case + PrefixCon args -> length args + RecCon flds -> length flds + InfixCon _ _ -> 2 + {- ********************************************************* * * @@ -2565,7 +2723,7 @@ rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) rnHsTyVar (L l tyvar) = do - tyvar' <- lookupOccRn tyvar + tyvar' <- lookupOccRn WL_TyVar tyvar return (L l tyvar') {- @@ -2662,8 +2820,8 @@ add gp l (DocD _ d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds -add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] +add_tycld :: LTyClDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] add_tycld d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [d] , group_kisigs = [] @@ -2674,8 +2832,8 @@ add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) = ds { group_tyclds = d : tyclds } : dss -add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] +add_instd :: LInstDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] add_instd d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [] , group_kisigs = [] @@ -2686,8 +2844,8 @@ add_instd d (ds@(TyClGroup { group_instds = instds }):dss) = ds { group_instds = d : instds } : dss -add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] - -> [TyClGroup (GhcPass p)] +add_role_annot :: LRoleAnnotDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] add_role_annot d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [] , group_kisigs = [] @@ -2698,8 +2856,8 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) = tycls { group_roles = d : roles } : rest -add_kisig :: LStandaloneKindSig (GhcPass p) - -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] +add_kisig :: LStandaloneKindSig GhcPs + -> [TyClGroup GhcPs] -> [TyClGroup GhcPs] add_kisig d [] = [TyClGroup { group_ext = noExtField , group_tyclds = [] , group_kisigs = [d] @@ -2711,7 +2869,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) diff --git a/GHC/Rename/Names.hs b/GHC/Rename/Names.hs --- a/GHC/Rename/Names.hs +++ b/GHC/Rename/Names.hs @@ -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 ) @@ -52,7 +54,7 @@ import GHC.Iface.Syntax ( fromIfaceWarnings ) import GHC.Builtin.Names import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Core.Type +import GHC.Core.TyCo.Tidy import GHC.Core.PatSyn import GHC.Core.TyCon ( TyCon, tyConName ) import qualified GHC.LanguageExtensions as LangExt @@ -72,12 +74,11 @@ import GHC.Types.Hint import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Types.Basic ( TopLevelFlag(..), TyConFlavour (..), convImportLevel ) import GHC.Types.SourceText import GHC.Types.Id -import GHC.Types.HpcInfo import GHC.Types.PkgQual -import GHC.Types.GREInfo (ConInfo(..)) +import GHC.Types.GREInfo (ConInfo(..), ConFieldInfo (..), ConLikeInfo (ConIsData)) import GHC.Unit import GHC.Unit.Module.Warnings @@ -92,6 +93,7 @@ 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 ) @@ -99,6 +101,8 @@ 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 @@ -200,25 +204,21 @@ -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary rnImports :: [(LImportDecl GhcPs, SDoc)] - -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) rnImports imports = do tcg_env <- getGblEnv -- NB: want an identity module here, because it's OK for a signature -- module to import from its implementor let this_mod = tcg_mod tcg_env let (source, ordinary) = partition (is_source_import . fst) imports - is_source_import d = ideclSource (unLoc d) == IsBoot + is_source_import (d::LImportDecl GhcPs) = ideclSource (unLoc d) == IsBoot stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary stuff2 <- mapAndReportM (rnImportDecl this_mod) source -- Safe Haskell: See Note [Tracking Trust Transitively] - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) + let (decls, imp_user_spec, rdr_env, imp_avails) = combine (stuff1 ++ stuff2) -- Update imp_boot_mods if imp_direct_mods mentions any of them let merged_import_avail = clobberSourceImports imp_avails - 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) where clobberSourceImports imp_avails = @@ -228,25 +228,24 @@ (imp_boot_mods imp_avails) (imp_direct_dep_mods imp_avails) - combJ (GWIB _ IsBoot) x = Just x - combJ r _ = Just r + combJ (GWIB _ IsBoot) (_, x) = Just x + combJ r _ = Just r -- See Note [Combining ImportAvails] - combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine :: [(LImportDecl GhcRn, ImportUserSpec, GlobalRdrEnv, ImportAvails)] + -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) combine ss = - let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr + let (decls, imp_user_spec, rdr_env, imp_avails, finsts) = foldr plus - ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) + ([], [], emptyGlobalRdrEnv, emptyImportAvails, emptyModuleSet) ss - in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, - hpc_usage) + in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }) - plus (decl, gbl_env1, imp_avails1, hpc_usage1) - (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) + plus (decl, us, gbl_env1, imp_avails1) + (decls, uss, gbl_env2, imp_avails2, finsts_set) = ( decl:decls, + us:uss, gbl_env1 `plusGlobalRdrEnv` gbl_env2, imp_avails1' `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2, extendModuleSetList finsts_set new_finsts ) where imp_avails1' = imp_avails1 { imp_finsts = [] } @@ -294,8 +293,6 @@ 23s before, and 11s after. -} - - -- | Given a located import declaration @decl@ from @this_mod@, -- calculate the following pieces of information: -- @@ -312,11 +309,13 @@ -- 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) rnImportDecl this_mod (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name , ideclPkgQual = raw_pkg_qual - , ideclSource = want_boot, ideclSafe = mod_safe + , ideclSource = want_boot + , ideclSafe = mod_safe + , ideclLevelSpec = import_level , ideclQualified = qual_style , ideclExt = XImportDeclPass { ideclImplicit = implicit } , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) @@ -393,18 +392,18 @@ 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, + is_level = convImportLevel import_level } -- 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? @@ -416,12 +415,13 @@ 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 , imv_all_exports = potential_gres , imv_qualified = qual_only + , imv_is_level = convImportLevel import_level } imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) @@ -430,9 +430,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 @@ -442,9 +439,10 @@ , ideclQualified = ideclQualified decl , ideclAs = ideclAs decl , ideclImportList = new_imp_details + , ideclLevelSpec = ideclLevelSpec decl } - 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) -- | Rename raw package imports @@ -465,7 +463,7 @@ | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names -> ThisPkg uid - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) + | Just uid <- resolvePackageImport unit_state mn (PackageName pkg_fs) -> OtherPkg uid | otherwise @@ -475,10 +473,10 @@ where home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps - units = ue_units unit_env + unit_state = ue_homeUnitState unit_env hpt_deps :: [UnitId] - hpt_deps = homeUnitDepends units + hpt_deps = homeUnitDepends unit_state -- | Calculate the 'ImportAvails' induced by an import of a particular @@ -493,8 +491,8 @@ calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by = let imp_mod = mi_module iface imp_sem_mod= mi_semantic_module iface - orph_iface = mi_orphan (mi_final_exts iface) - has_finsts = mi_finsts (mi_final_exts iface) + orph_iface = mi_orphan iface + has_finsts = mi_finsts iface deps = mi_deps iface trust = getSafeMode $ mi_trust iface trust_pkg = mi_trust_pkg iface @@ -554,14 +552,20 @@ dependent_pkgs = if toUnitId pkg `S.member` other_home_units then S.empty - else S.singleton ipkg + else S.singleton (lvl, ipkg) - direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units - then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot)) - else S.empty + lvl = case imported_by of + ImportedByUser imv -> imv_is_level imv + ImportedBySystem -> NormalLevel + + direct_mods = if toUnitId pkg `S.member` other_home_units + then mkPlusModDeps (moduleUnitId imp_mod) lvl (GWIB (moduleName imp_mod) want_boot) + else emptyInstalledModuleEnv + dep_boot_mods_map = mkModDeps (dep_boot_mods deps) + boot_mods -- If we are looking for a boot module, it must be HPT | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot) @@ -578,7 +582,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, @@ -597,32 +601,9 @@ imp_trust_own_pkg = pkg_trust_req } - --- | 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 ] +mkPlusModDeps :: UnitId -> ImportLevel -> ModuleNameWithIsBoot + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) +mkPlusModDeps uid st elt = extendInstalledModuleEnv emptyInstalledModuleEnv (mkModule uid (gwib_mod elt)) (S.singleton st, elt) {- ************************************************************************ @@ -654,7 +635,7 @@ See Note [GlobalRdrEnv shadowing] 3. We find out whether we are inside a [d| ... |] by testing the TH - stage. This is a slight hack, because the stage field was really + level. This is a slight hack, because the level field was really meant for the type checker, and here we are not interested in the fields of Brack, hence the error thunks in thRnBrack. -} @@ -670,18 +651,18 @@ extendGlobalRdrEnvRn new_gres new_fixities = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] do { (gbl_env, lcl_env) <- getEnvs - ; stage <- getStage + ; level <- getThLevel ; isGHCi <- getIsGHCi ; let rdr_env = tcg_rdr_env gbl_env fix_env = tcg_fix_env gbl_env th_bndrs = getLclEnvThBndrs lcl_env - th_lvl = thLevel stage + th_lvl = thLevelIndex level -- Delete new_occs from global and local envs -- If we are in a TemplateHaskell decl bracket, -- we are going to shadow them -- See Note [GlobalRdrEnv shadowing] - inBracket = isBrackStage stage + inBracket = isBrackLevel level lcl_env_TH = modifyLclCtxt (\lcl_env -> lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_gres_env }) lcl_env -- See Note [GlobalRdrEnv shadowing] @@ -711,7 +692,7 @@ -- If there is a fixity decl for the gre, add it to the fixity env extend_fix_env fix_env gre - | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) + | Just (L _ fi) <- lookupMiniFixityEnv new_fixities name = extendNameEnv fix_env name (FixItem occ fi) | otherwise = fix_env @@ -869,10 +850,10 @@ new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances = do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs (LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl - ; tycon_name <- newTopSrcBinder $ l2n main_bndr - ; at_names <- mapM (newTopSrcBinder . l2n . fst) at_bndrs - ; sig_names <- mapM (newTopSrcBinder . l2n) sig_bndrs - ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds + ; tycon_name <- newTopSrcBinder $ la2la main_bndr + ; at_names <- mapM (newTopSrcBinder . la2la . fst) at_bndrs + ; sig_names <- mapM (newTopSrcBinder . la2la) sig_bndrs + ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds ; mapM_ (add_dup_fld_errs flds') con_names_with_flds ; let tc_gre = mkLocalTyConGRE (fmap (const tycon_name) tc_flav) tycon_name @@ -898,9 +879,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 ] @@ -947,7 +928,7 @@ new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) = do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl) ; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid - ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds + ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds ; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds ; mapM_ (add_dup_fld_errs flds') sub_names ; let fld_env = mk_fld_env sub_names flds' @@ -1188,22 +1169,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 @@ -1213,20 +1199,20 @@ -- 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 gres = concatMap (gresFromIE decl_spec) items2 + gre_env = mkGlobalRdrEnv gres + implicit_parents = mkNameSet $ mapMaybe parentOfImplicitlyImportedGRE gres + in (gre_env, ImpUserExplicit (gresToAvailInfo $ globalRdrEnvElts $ gre_env) implicit_parents) EverythingBut -> let hidden_names = mkNameSet $ concatMap (map greName . snd) items2 - 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) @@ -1269,8 +1255,7 @@ lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])] lookup_lie (L loc ieRdr) = setSrcSpanA loc $ - do (stuff, warns) <- liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie ieRdr) + do (stuff, warns) <- run_lookup ([],[]) (lookup_ie ieRdr) mapM_ (addTcRnDiagnostic <=< warning_msg) warns return [ (L loc ie, gres) | (ie,gres) <- stuff ] where @@ -1280,32 +1265,30 @@ pure (TcRnDodgyImports (DodgyImportsEmptyParent n)) warning_msg MissingImportList = pure (TcRnMissingImportList ieRdr) - warning_msg (BadImportW ie) = do - -- 'BadImportW' is only constructed below in 'handle_bad_import', in - -- the 'EverythingBut' case, so that's what we pass to - -- 'badImportItemErr'. - reason <- badImportItemErr iface decl_spec ie IsNotSubordinate all_avails + warning_msg (BadImportW ie sub) = do + -- 'BadImportW' is only constructed below in 'bad_import_w', in + -- the 'EverythingBut' case, so here we assume a 'hiding' clause. + (reason :| _) <- badImportItemErr iface decl_spec ie sub all_avails pure (TcRnDodgyImports (DodgyImportsHiding reason)) warning_msg (DeprecatedExport n w) = - pure (TcRnPragmaWarning { - pragma_warning_occ = occName n - , pragma_warning_msg = w - , pragma_warning_import_mod = moduleName import_mod - , pragma_warning_defined_mod = Nothing - }) + pure $ TcRnPragmaWarning + PragmaWarningExport + { pwarn_occname = occName n + , pwarn_impmod = moduleName import_mod } + w - run_lookup :: IELookupM a -> TcRn (Maybe a) - run_lookup m = case m of + run_lookup :: a -> IELookupM a -> TcRn a + run_lookup def m = case m of Failed err -> do - msg <- lookup_err_msg err - addErr (TcRnImportLookup msg) - return Nothing - Succeeded a -> return (Just a) + msgs <- lookup_err_msgs err + forM_ msgs $ \msg -> addErr (TcRnImportLookup msg) + return def + Succeeded a -> return a - lookup_err_msg err = case err of + lookup_err_msgs err = case err of BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails - IllegalImport -> pure ImportLookupIllegal - QualImportError rdr -> pure (ImportLookupQualified rdr) + IllegalImport -> pure $ NE.singleton ImportLookupIllegal + QualImportError rdr -> pure $ NE.singleton (ImportLookupQualified rdr) -- For each import item, we convert its RdrNames to Names, -- and at the same time compute all the GlobalRdrElt corresponding @@ -1319,7 +1302,7 @@ -> IELookupM ([(IE GhcRn, [GlobalRdrElt])], [IELookupWarning]) lookup_ie ie = handle_bad_import $ case ie of - IEVar _ (L l n) -> do + IEVar _ (L l n) _ -> do -- See Note [Importing DuplicateRecordFields] xs <- lookup_names ie (ieWrappedName n) let gres = map imp_item $ NE.toList xs @@ -1327,14 +1310,19 @@ | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres | otherwise = [] - return ( [ (IEVar Nothing (L l (replaceWrappedName n name)), [gre]) + return ( [ (IEVar Nothing (L l (replaceWrappedName n name)) noDocstring, [gre]) | gre <- gres , let name = greName gre ] , export_depr_warns ) - IEThingAll _ (L l tc) -> do - ImpOccItem gre child_gres _ <- lookup_parent ie $ ieWrappedName tc + IEThingAll _ (L l tc) _ -> do + ImpOccItem { imp_item = gre + , imp_bundled = bundled_gres + , imp_is_parent = is_par + } + <- lookup_parent ie $ ieWrappedName tc let name = greName gre + child_gres = if is_par then bundled_gres else [] imp_list_warn | null child_gres @@ -1348,7 +1336,7 @@ | otherwise = [] - renamed_ie = IEThingAll (Nothing, noAnn) (L l (replaceWrappedName tc name)) + renamed_ie = IEThingAll (Nothing, noAnn) (L l (replaceWrappedName tc name)) noDocstring export_depr_warn | want_hiding == Exactly = maybeToList $ mk_depr_export_warning gre @@ -1361,7 +1349,7 @@ , imp_list_warn ++ export_depr_warn) - IEThingAbs _ (L l tc') + IEThingAbs _ (L l tc') _ | want_hiding == EverythingBut -- hiding ( C ) -- Here the 'C' can be a data constructor -- *or* a type/class, or even both @@ -1377,33 +1365,35 @@ return ( [mkIEThingAbs tc' l gre] , maybeToList $ mk_depr_export_warning gre) - IEThingWith (deprecation, ann) ltc@(L l rdr_tc) wc rdr_ns -> do + 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) (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 -- See Note [Importing DuplicateRecordFields] - case lookupChildren subnames rdr_ns of - - Failed rdrs -> failLookupWith $ - BadImport (IEThingWith (deprecation, ann) ltc wc rdrs) IsSubordinate - -- We are trying to import T( a,b,c,d ), and failed - -- to find 'b' and 'd'. So we make up an import item - -- to report as failing, namely T( b, d ). - -- c.f. #15412 + let (children_errs, childnames) = lookupChildren subnames rdr_ns - Succeeded childnames -> - return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' - ,gres)] - , export_depr_warns) + bad_import_warns <- + if null children_errs then return [] else + let items = map lce_wrapped_name children_errs + ie = IEThingWith (deprecation, ann) ltc wc items noDocstring + -- We are trying to import T( a,b,c,d ), and failed + -- to find 'b' and 'd'. So we make up an import item + -- to report as failing, namely T( b, d ). + -- c.f. #15413 + subordinate_err = mkSubordinateError gre children_errs + in bad_import_w ie subordinate_err - where name' = replaceWrappedName rdr_tc name - childnames' = map (to_ie_post_rn . fmap greName) childnames - gres = gre : map unLoc childnames - export_depr_warns - | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres - | otherwise = [] + let name' = replaceWrappedName rdr_tc name + childnames' = map (to_ie_post_rn . fmap greName) childnames + gres = gre : map unLoc childnames + export_depr_warns + | want_hiding == Exactly = mapMaybe mk_depr_export_warning gres + | otherwise = [] + return ([ (IEThingWith (Nothing, ann) (L l name') wc childnames' noDocstring + ,gres)] + , bad_import_warns ++ export_depr_warns) _other -> failLookupWith IllegalImport -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed... @@ -1411,35 +1401,65 @@ where mkIEThingAbs tc l gre - = (IEThingAbs (Nothing, noAnn) (L l (replaceWrappedName tc n)), [gre]) + = (IEThingAbs Nothing (L l (replaceWrappedName tc n)) noDocstring, [gre]) where n = greName gre - handle_bad_import m = catchIELookup m $ \err -> case err of - BadImport ie _ - | want_hiding == EverythingBut - -> return ([], [BadImportW ie]) - _ -> failLookupWith err + -- N.B. imports never have docstrings + noDocstring = Nothing + handle_bad_import m = catchIELookup m $ \case + BadImport ie sub -> do + ws <- bad_import_w ie sub + return ([], ws) + err -> failLookupWith err + + bad_import_w :: IE GhcPs -> IsSubordinateError -> IELookupM [IELookupWarning] + bad_import_w ie sub + | want_hiding == EverythingBut = return [BadImportW ie sub] + | otherwise = failLookupWith (BadImport ie sub) + mk_depr_export_warning gre - = DeprecatedExport name <$> mi_export_warn_fn (mi_final_exts iface) name + = DeprecatedExport name <$> mi_export_warn_fn iface name where name = greName gre type IELookupM = MaybeErr IELookupError data IELookupWarning - = BadImportW (IE GhcPs) + = BadImportW (IE GhcPs) IsSubordinateError | MissingImportList | DodgyImport GlobalRdrElt | DeprecatedExport Name (WarningTxt GhcRn) -- | Is this import/export item a subordinate or not? -data IsSubordinate - = IsSubordinate | IsNotSubordinate +data IsSubordinateError + = IsSubordinateError { subordinate_err_parent :: !GlobalRdrElt + , subordinate_err_unavailable :: [FastString] + , subordinate_err_nontype :: [GlobalRdrElt] + , subordinate_err_nondata :: [GlobalRdrElt] } + | IsNotSubordinate +mkSubordinateError :: GlobalRdrElt -> [LookupChildError] -> IsSubordinateError +mkSubordinateError gre children_errs = foldr add init_acc children_errs + where + init_acc :: IsSubordinateError + init_acc = IsSubordinateError gre [] [] [] + + add :: LookupChildError -> IsSubordinateError -> IsSubordinateError + add children_err sub@IsSubordinateError{} = + case children_err of + LookupChildNonType{lce_nontype_item = g} -> + sub { subordinate_err_nontype = g : subordinate_err_nontype sub } + LookupChildNonData{lce_nondata_item = g} -> + sub { subordinate_err_nondata = g : subordinate_err_nondata sub } + LookupChildNotFound (L _ wname) -> + let fs = (occNameFS . rdrNameOcc . ieWrappedName) wname + in sub { subordinate_err_unavailable = fs : subordinate_err_unavailable sub } + add _ IsNotSubordinate = panic "mkSubordinateError: IsNotSubordinate" + data IELookupError = QualImportError RdrName - | BadImport (IE GhcPs) IsSubordinate + | BadImport (IE GhcPs) IsSubordinateError | IllegalImport failLookupWith :: IELookupError -> IELookupM a @@ -1483,18 +1503,23 @@ mkImportOccEnv :: HscEnv -> ImpDeclSpec -> [IfaceExport] -> OccEnv (NameEnv ImpOccItem) mkImportOccEnv hsc_env decl_spec all_avails = mkOccEnv_C (plusNameEnv_C combine) - [ (occ, mkNameEnv [(nm, ImpOccItem g bundled is_parent)]) + [ (occ, mkNameEnv [(nm, item)]) | avail <- all_avails - , let gs = gresFromAvail hsc_env (Just hiding_spec) avail - , g <- gs - , let nm = greName g - occ = greOccName g + , let gres = gresFromAvail hsc_env (Just hiding_spec) avail + , gre <- gres + , let nm = greName gre + occ = greOccName gre (is_parent, bundled) = case avail of AvailTC c _ - -> if c == nm -- (Recall the AvailTC invariant) - then ( True, case gs of { g0 : gs' | greName g0 == nm -> gs'; _ -> gs } ) - else ( False, gs ) + | c == nm -- (Recall the AvailTC invariant from GHC.Types.AvailInfo) + -> ( True, drop 1 gres ) -- "drop 1": don't include the parent itself. + | otherwise + -> ( False, gres ) _ -> ( False, [] ) + item = ImpOccItem + { imp_item = gre + , imp_bundled = bundled + , imp_is_parent = is_parent } ] where @@ -1565,8 +1590,8 @@ = map set_gre_imp gres where is_explicit = case ie of - IEThingAll _ name -> \n -> n == lieWrappedName name - _ -> \_ -> True + IEThingAll _ name _ -> \n -> n == lieWrappedName name + _ -> \_ -> True prov_fn name = ImpSpec { is_decl = decl_spec, is_item = item_spec } where @@ -1575,9 +1600,25 @@ set_gre_imp gre@( GRE { gre_name = nm } ) = gre { gre_imp = unitBag $ prov_fn nm } -{- -Note [Children for duplicate record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +parentOfImplicitlyImportedGRE :: Outputable info => GlobalRdrEltX info -> Maybe Name +parentOfImplicitlyImportedGRE gre = + if any (explicit_import . is_item) $ gre_imp gre + then Nothing + else + case greParent gre of + NoParent -> + pprPanic "parentOfImplicitlyImportedGRE" $ + (text "implicitly imported GRE with no parent" <+> ppr gre) + ParentIs par -> + Just par + where + explicit_import :: ImpItemSpec -> Bool + explicit_import (ImpAll {}) = + pprPanic "parentOfImplicitlyImportedGRE: ImpAll" (ppr gre) + explicit_import (ImpSome { is_explicit }) = is_explicit + +{- Note [Children for duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the module {-# LANGUAGE DuplicateRecordFields #-} @@ -1601,45 +1642,103 @@ findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] +data LookupChildError + = LookupChildNotFound { lce_wrapped_name :: !(LIEWrappedName GhcPs) } + | LookupChildNonType { lce_wrapped_name :: !(LIEWrappedName GhcPs) + , lce_nontype_item :: !GlobalRdrElt } + | LookupChildNonData { lce_wrapped_name :: !(LIEWrappedName GhcPs) + , lce_nondata_item :: !GlobalRdrElt } + lookupChildren :: [GlobalRdrElt] -> [LIEWrappedName GhcPs] - -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed - [LocatedA GlobalRdrElt] + -> ( [LookupChildError] -- The ones for which the lookup failed + , [LocatedA GlobalRdrElt] ) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its --- corresponding Name all_kids, if the former exists +-- corresponding Name in all_kids, if the former exists -- The matching is done by FastString, not OccName, so that -- Cls( meth, AssocTy ) -- will correctly find AssocTy among the all_kids of Cls, even though -- the RdrName for AssocTy may have a (bogus) DataName namespace -- (Really the rdr_items should be FastStrings in the first place.) -lookupChildren all_kids rdr_items - | null fails - = Succeeded (concat oks) - -- This 'fmap concat' trickily applies concat to the /second/ component - -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]]) - | otherwise - = Failed fails +lookupChildren all_kids rdr_items = (fails, successes) where - mb_xs = map doOne rdr_items - fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] - oks = [ ok | Succeeded ok <- mb_xs ] - oks :: [[LocatedA GlobalRdrElt]] + mb_xs = map do_one rdr_items + fails = [ err | Failed err <- mb_xs ] + successes = [ ok | Succeeded oks <- mb_xs, ok <- NE.toList oks ] - doOne item@(L l r) - = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [g] - | not $ isRecFldGRE g - -> Succeeded [L l g] - Just gs - | all isRecFldGRE gs - -> Succeeded $ map (L l) gs - _ -> Failed item + do_one :: LIEWrappedName GhcPs -> MaybeErr LookupChildError (NonEmpty (LocatedA GlobalRdrElt)) + do_one item@(L l r) = + case r of + IEName{} + -- IEName (unadorned name) places no restriction on the namespace of + -- the imported entity, so we look in both `val_gres` and `typ_gres`. + -- In case of conflict (punning), the value namespace takes priority. + -- See Note [Prioritise the value namespace in subordinate import lists] + | (gre:gres) <- val_gres -> Succeeded $ fmap (L l) (gre:|gres) + | (gre:gres) <- typ_gres -> Succeeded $ fmap (L l) (gre:|gres) + | otherwise -> Failed $ LookupChildNotFound item + IEType{} + -- IEType ('type' namespace specifier) restricts the lookup to the + -- type namespace, i.e. to `typ_gres`. In case of failure, we check + -- `val_gres` to produce a more helpful error message. + | (gre:gres) <- typ_gres -> Succeeded $ fmap (L l) (gre:|gres) + | (gre:_) <- val_gres -> Failed $ LookupChildNonType item gre + | otherwise -> Failed $ LookupChildNotFound item + + IEData{} + -- IEData ('data' namespace specifier) restricts the lookup to the + -- data namespace, i.e. to `val_gres`. In case of failure, we check + -- `typ_gres` to produce a more helpful error message. + | (gre:gres) <- val_gres -> Succeeded $ fmap (L l) (gre:|gres) + | (gre:_) <- typ_gres -> Failed $ LookupChildNonData item gre + | otherwise -> Failed $ LookupChildNotFound item + + IEPattern{} -> panic "lookupChildren: IEPattern" -- Never happens (invalid syntax) + IEDefault{} -> panic "lookupChildren: IEDefault" -- Never happens (invalid syntax) + where + fs = (occNameFS . rdrNameOcc . ieWrappedName) r + gres = fromMaybe [] (lookupFsEnv kid_env fs) + (val_gres, typ_gres) = partition (isValNameSpace . greNameSpace) gres + -- See Note [Children for duplicate record fields] + kid_env :: FastStringEnv [GlobalRdrElt] kid_env = extendFsEnvList_C (++) emptyFsEnv [(occNameFS (occName x), [x]) | x <- all_kids] +{- Note [Prioritise the value namespace in subordinate import lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program that defines a class that has both an associated type +named (#) and a method named (#) + + module M_assoc where + class C a b where + type a # b + (#) :: a -> b -> () + module N_assoc where + import M_assoc( C((#)) ) + +In the import declaration, when we see the unadorned name (#) in the subordinate +import list of C, which children should we bring into scope? Our options are: + + a) only the method (#) + b) only the associated type (#) + c) both the method and the associated type + +To follow the precedent established by top-level items, we go with option (a). +Indeed, consider a slightly different program + + module M_top where + type family a # b + a # b = () + module N_top where + import M_top( (#) ) + +Here the import brings only the function (#) into scope, and one has to say +`type (#)` to get the type family. +-} + ------------------------------- {- @@ -1744,7 +1843,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 } @@ -1861,21 +1960,21 @@ -- srcSpanEnd: see Note [The ImportMap] `orElse` [] - used_names = mkNameSet (map greName used_gres) + used_gre_env = mkGlobalRdrEnv 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) -> - foldr (add_unused . unLoc) emptyNameSet imp_ies + let unused = foldr (add_unused . unLoc) (UnusedNames emptyNameSet emptyFsEnv) imp_ies + in collectUnusedNames unused _other -> emptyNameSet -- No explicit import list => no unused-name list - 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 :: 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 (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) where pn = lieWrappedName p xs = map lieWrappedName ns add_wc_all = case wc of @@ -1883,23 +1982,117 @@ IEWildcard _ -> add_unused_all pn add_unused _ acc = acc - 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_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_with p ns acc - | all (`elemNameSet` acc1) ns = add_unused_name p acc1 - | otherwise = acc1 + | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1 + | otherwise = acc1 where - 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. + 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. +-} + + {- Note [The ImportMap] ~~~~~~~~~~~~~~~~~~~~~~~ The ImportMap is a short-lived intermediate data structure records, for @@ -1964,12 +2157,15 @@ | null unused = return () - -- Only one import is unused, with `SrcSpan` covering only the unused item instead of - -- the whole import statement + -- Some imports are unused: make the `SrcSpan` cover only the unused + -- items instead of the whole import statement | Just (_, L _ imports) <- ideclImportList decl - , length unused == 1 - , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + , 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)) -- Some imports are unused | otherwise @@ -1978,7 +2174,7 @@ where -- In warning message, pretty-print identifiers unqualified unconditionally -- to improve the consistent for ambiguous/unambiguous identifiers. - -- See trac#14881. + -- See #14881. possible_field n = case lookupGRE_Name rdr_env n of Just (GRE { gre_par = par, gre_info = IAmRecField info }) -> @@ -2041,11 +2237,11 @@ -- to say "T(A,B,C)". So we have to find out what the module exports. to_ie rdr_env _ (Avail c) -- Note [Overloaded field import] = do { let - gre = expectJust "getMinimalImports Avail" $ lookupGRE_Name rdr_env c - ; return $ [IEVar Nothing (to_ie_post_rn $ noLocA $ greName gre)] } + gre = expectJust $ lookupGRE_Name rdr_env c + ; return $ [IEVar Nothing (to_ie_post_rn $ noLocA $ greName gre) Nothing] } to_ie _ _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else | availExportsDecl avail - = return [IEThingAbs (Nothing, noAnn) (to_ie_post_rn $ noLocA n)] + = 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 @@ -2053,23 +2249,23 @@ ] of [xs] | all_used xs - -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n)] + -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n) Nothing] | otherwise - -> do { let ns_gres = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs + -> do { let ns_gres = map (expectJust . lookupGRE_Name rdr_env) cs ns = map greName ns_gres ; return [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] } + (map (to_ie_post_rn . noLocA) (filter (/= n) ns)) Nothing] } -- Note [Overloaded field import] _other - -> do { let infos = map (expectJust "getMinimalImports AvailTC" . lookupGRE_Name rdr_env) cs + -> do { let infos = map (expectJust . lookupGRE_Name rdr_env) cs (ns_gres,fs_gres) = classifyGREs infos ns = map greName (ns_gres ++ fs_gres) fs = map fieldGREInfo fs_gres ; return $ if all_non_overloaded fs - then map (IEVar Nothing . to_ie_post_rn_var . noLocA) ns + then map (\nm -> IEVar Nothing (to_ie_post_rn_var $ noLocA nm) Nothing) ns else [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] } + (map (to_ie_post_rn . noLocA) (filter (/= n) ns)) Nothing] } where all_used avail_cs = all (`elem` cs) avail_cs @@ -2124,14 +2320,14 @@ to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n)) - | otherwise = L l (IEName noExtField (L (la2na 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 (la2e l) (L (la2na l) n)) - | otherwise = L l (IEName noExtField (L (la2na 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 {- @@ -2198,28 +2394,46 @@ -} badImportItemErr - :: ModIface -> ImpDeclSpec -> IE GhcPs -> IsSubordinate + :: ModIface -> ImpDeclSpec -> IE GhcPs + -> IsSubordinateError -> [AvailInfo] - -> TcRn ImportLookupReason + -> TcRn (NonEmpty ImportLookupReason) badImportItemErr iface decl_spec ie sub avails = do - patsyns_enabled <- xoptM LangExt.PatternSynonyms + exts <- importLookupExtensions + let import_lookup_bad :: BadImportKind -> ImportLookupReason + import_lookup_bad k = ImportLookupBad k iface decl_spec ie exts dflags <- getDynFlags hsc_env <- getTopEnv let rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just imp_spec) all_avails - pure (ImportLookupBad (importErrorKind dflags rdr_env) iface decl_spec ie patsyns_enabled) + pure $ fmap import_lookup_bad (importErrorKind dflags rdr_env) where + importErrorKind :: DynFlags -> GlobalRdrEnv -> NonEmpty BadImportKind importErrorKind dflags rdr_env | any checkIfTyCon avails = case sub of - IsNotSubordinate -> BadImportAvailTyCon - IsSubordinate -> BadImportNotExportedSubordinates unavailableChildren - | any checkIfVarName avails = BadImportAvailVar - | Just con <- find checkIfDataCon avails = BadImportAvailDataCon (availOccName con) - | otherwise = BadImportNotExported suggs + IsNotSubordinate -> NE.singleton BadImportAvailTyCon + IsSubordinateError { subordinate_err_parent = gre + , subordinate_err_unavailable = unavailable + , subordinate_err_nontype = nontype + , subordinate_err_nondata = nondata } + -> NE.fromList $ catMaybes $ + [ fmap (BadImportNotExportedSubordinates gre) (NE.nonEmpty unavailable) + , fmap (BadImportNonTypeSubordinates gre) (NE.nonEmpty nontype) + , fmap (BadImportNonDataSubordinates gre) (NE.nonEmpty nondata) ] + | any checkIfVarName avails = NE.singleton BadImportAvailVar + | Just con <- find checkIfDataCon avails = NE.singleton (BadImportAvailDataCon (availOccName con)) + | otherwise = NE.singleton (BadImportNotExported suggs) where suggs = similar_suggs ++ fieldSelectorSuggestions rdr_env rdr + what_look = case sub of + IsNotSubordinate -> WL_TyCon_or_TermVar + IsSubordinateError { subordinate_err_parent = gre } -> + case greInfo gre of + IAmTyCon ClassFlavour + -> WL_TyCon_or_TermVar + _ -> WL_Term similar_names = - similarNameSuggestions (Unbound.LF WL_Anything WL_Global) + similarNameSuggestions (Unbound.LF what_look WL_Global) dflags rdr_env emptyLocalRdrEnv rdr similar_suggs = case NE.nonEmpty $ mapMaybe imported_item $ similar_names of @@ -2252,10 +2466,13 @@ importedFS = occNameFS $ rdrNameOcc rdr imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } all_avails = mi_exports iface - unavailableChildren = case ie of - IEThingWith _ _ _ ns -> map (rdrNameOcc . ieWrappedName . unLoc) ns - _ -> panic "importedChildren failed pattern match: no children" +importLookupExtensions :: TcRn ImportLookupExtensions +importLookupExtensions = do + ile_pattern_synonyms <- xoptM LangExt.PatternSynonyms + ile_explicit_namespaces <- xoptM LangExt.ExplicitNamespaces + return ImportLookupExtensions{ile_pattern_synonyms, ile_explicit_namespaces} + addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () addDupDeclErr gres@(gre :| _) -- Report the error at the later location @@ -2281,3 +2498,4 @@ checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) + diff --git a/GHC/Rename/Pat.hs b/GHC/Rename/Pat.hs --- a/GHC/Rename/Pat.hs +++ b/GHC/Rename/Pat.hs @@ -1,13 +1,18 @@ - -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use camelCase" #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -42,49 +47,56 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat, rnSpliceTyPat ) import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType ( hsOverLitName ) +import GHC.Rename.Doc (rnLHsDoc) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames - , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) + , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, delLocalNames, typeAppErr ) import GHC.Rename.HsType import GHC.Builtin.Names +import GHC.Types.Hint +import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set - import GHC.Types.Basic import GHC.Types.SourceText -import GHC.Utils.Misc + import GHC.Data.FastString ( uniqCompareFS ) import GHC.Data.List.SetOps( removeDups ) -import GHC.Utils.Outputable + +import GHC.Utils.Misc import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) -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 ) import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( when, ap, guard ) +import Control.Monad ( when, ap, guard, unless ) import Data.Foldable import Data.Function ( on ) import Data.Functor.Identity ( Identity (..) ) import qualified Data.List.NonEmpty as NE -import Data.Maybe import Data.Ratio - +import Control.Monad.Trans.Writer.CPS +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.Functor ((<&>)) +import Data.Coerce {- ********************************************************* @@ -148,11 +160,12 @@ unCpsRn (fn a) $ \v -> k (L loc v)) -lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name) -lookupConCps con_rdr - = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr - ; (r, fvs) <- k con_name - ; return (r, addOneFV fvs (unLoc con_name)) }) +lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN (WithUserRdr Name)) +lookupConCps lcon_rdr@(L _ con_rdr) + = CpsRn $ \k -> + do { con_name <- lookupLocatedOccRnConstr lcon_rdr + ; (r, fvs) <- k (fmap (WithUserRdr con_rdr) con_name) + ; return (r, addOneFV fvs (unLoc con_name)) } -- We add the constructor name to the free vars -- See Note [Patterns are uses] @@ -215,7 +228,7 @@ localRecNameMaker :: MiniFixityEnv -> NameMaker localRecNameMaker fix_env = LetMk NotTopLevel fix_env -matchNameMaker :: HsMatchContext a -> NameMaker +matchNameMaker :: HsMatchContext fn -> NameMaker matchNameMaker ctxt = LamMk report_unused where -- Do not report unused names in interactive contexts @@ -235,16 +248,14 @@ newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name = CpsRn (\ thing_inside -> - do { warnForallIdentifier rdr_name - ; name <- newLocalBndrRn rdr_name + do { name <- newLocalBndrRn rdr_name ; (res, fvs) <- bindLocalNames [name] (thing_inside name) ; when report_unused $ warnUnusedMatches [name] fvs ; return (res, name `delFV` fvs) }) newPatName (LetMk is_top fix_env) rdr_name = CpsRn (\ thing_inside -> - do { warnForallIdentifier rdr_name - ; name <- case is_top of + do { name <- case is_top of NotTopLevel -> newLocalBndrRn rdr_name TopLevel -> newTopSrcBinder rdr_name ; bindLocalNames [name] $ @@ -302,9 +313,9 @@ Note [Handling overloaded and rebindable patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Overloaded paterns and rebindable patterns are desugared in the renamer +Overloaded patterns and rebindable patterns are desugared in the renamer using the HsPatExpansion mechanism detailed in: -Note [Rebindable syntax and HsExpansion] +Note [Rebindable syntax and XXExprGhcRn] The approach is similar to that of expressions, which is further detailed in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr. @@ -324,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] @@ -332,7 +343,7 @@ toList -> [p1, p2, p3] This happens directly in the renamer, using the HsPatExpansion mechanism -detailed in Note [Rebindable syntax and HsExpansion]. +detailed in Note [Rebindable syntax and XXExprGhcRn]. Note that we emit a special view pattern: we additionally keep track of an inverse to the pattern. @@ -341,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 #-} > @@ -366,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`. @@ -407,44 +421,61 @@ -- * local namemaker -- * unused and duplicate checking -- * no fixities -rnPats :: Traversable f - => HsMatchContext GhcRn -- for error messages - -> f (LPat GhcPs) - -> (f (LPat GhcRn) -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) -rnPats ctxt pats thing_inside - = do { envs_before <- getRdrEnvs - -- (1) rename the patterns, bringing into scope all of the term variables - -- (2) then do the thing inside. - ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do - { -- Check for duplicated and shadowed names - -- Must do this *after* renaming the patterns - -- See Note [Collect binders only after renaming] in GHC.Hs.Utils - -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... - -- - -- See Note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders CollNoDictBinders (toList pats') - ; addErrCtxt doc_pat $ - if isPatSynCtxt ctxt - then checkDupNames bndrs - else checkDupAndShadowedNames envs_before bndrs - ; thing_inside pats' } } +-- rn_pats_general is the generalisation of two functions: +-- rnPats, rnPat +-- Those are the only call sites, so we inline it for improved performance. +-- Kind of like a macro. +{-# INLINE rn_pats_general #-} +rn_pats_general :: Traversable f => HsMatchContextRn + -> f (LPat GhcPs) + -> (f (LPat GhcRn) -> RnM (r, FreeVars)) + -> RnM (r, FreeVars) +rn_pats_general ctxt pats thing_inside = do + envs_before <- getRdrEnvs + + -- (1) rename the patterns, bringing into scope all of the term variables + -- (2) then do the thing inside. + unCpsRn (rn_pats_fun (matchNameMaker ctxt) pats) $ \ pats' -> do + -- Check for duplicated and shadowed names + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + -- + -- See Note [Don't report shadowing for pattern synonyms] + let bndrs = collectPatsBinders CollVarTyVarBinders (toList pats') + addErrCtxt (MatchCtxt ctxt) $ + if isPatSynCtxt ctxt + then checkDupNames bndrs + else checkDupAndShadowedNames envs_before bndrs + thing_inside pats' where - doc_pat = text "In" <+> pprMatchContext ctxt -{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-} -{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-} -rnPat :: HsMatchContext GhcRn -- for error messages + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + -- + -- BTW, Or-patterns would be awesome here + rn_pats_fun = case ctxt of + FunRhs{} -> mapM . rnLArgPatAndThen + LamAlt LamSingle -> mapM . rnLArgPatAndThen + LamAlt LamCases -> mapM . rnLArgPatAndThen + _ -> mapM . rnLPatAndThen + +rnPats :: HsMatchContextRn -- For error messages and choosing if @-patterns are allowed + -> [LPat GhcPs] + -> ([LPat GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnPats = rn_pats_general + +rnPat :: forall a. HsMatchContextRn -- For error messages and choosing if @-patterns are allowed -> LPat GhcPs -> (LPat GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars -rnPat ctxt pat thing_inside - = rnPats ctxt (Identity pat) (thing_inside . runIdentity) +rnPat + = coerce (rn_pats_general @Identity @a) applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name) applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) @@ -473,14 +504,30 @@ ********************************************************* -} + +rnLArgPatAndThen :: NameMaker -> LocatedA (Pat GhcPs) -> CpsRn (LocatedA (Pat GhcRn)) +rnLArgPatAndThen mk = wrapSrcSpanCps rnArgPatAndThen where + + rnArgPatAndThen (InvisPat (_, spec) tp) = do + tp' <- rnHsTyPat HsTypePatCtx tp + liftCps $ unlessXOptM LangExt.TypeAbstractions $ + addErr (TcRnIllegalInvisibleTypePattern tp' InvisPatWithoutFlag) + pure (InvisPat spec tp') + rnArgPatAndThen p = rnPatAndThen mk p + -- ----------- Entry point 3: rnLPatAndThen ------------------- -- General version: parameterized by how you make new names rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn)) -rnLPatsAndThen mk = mapM (rnLPatAndThen mk) +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)) #-} +rnLArgPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] +rnLArgPatsAndThen mk = traverse (rnLArgPatAndThen mk) + -------------------- -- The workhorse rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) @@ -488,9 +535,9 @@ rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _ (WildPat _) = return (WildPat noExtField) -rnPatAndThen mk (ParPat x lpar pat rpar) = +rnPatAndThen mk (ParPat _ pat) = do { pat' <- rnLPatAndThen mk pat - ; return (ParPat x lpar pat' rpar) } + ; return (ParPat noExtField pat') } rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat ; return (LazyPat noExtField pat') } rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat @@ -546,7 +593,7 @@ ; return (NPat x (L l lit') mb_neg' eq') } rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ ) - = do { new_name <- newPatName mk (l2n rdr) + = do { new_name <- newPatName mk (la2la rdr) ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] -- We skip negateName as -- negative zero doesn't make @@ -557,10 +604,10 @@ (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat _ rdr at pat) +rnPatAndThen mk (AsPat _ rdr pat) = do { new_name <- newPatLName mk rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat noExtField new_name at pat') } + ; return (AsPat noExtField new_name pat') } rnPatAndThen mk p@(ViewPat _ expr pat) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns @@ -610,6 +657,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) @@ -623,56 +678,38 @@ (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed } +rnPatAndThen _ (EmbTyPat _ tp) + = do { tp' <- rnHsTyPat HsTypePatCtx tp + ; return (EmbTyPat noExtField tp') } +rnPatAndThen _ (InvisPat (_, spec) tp) + = do { -- Invisible patterns are handled in `rnLArgPatAndThen` + -- so unconditionally emit error here + ; tp' <- rnHsTyPat HsTypePatCtx tp + ; liftCps $ addErr (TcRnIllegalInvisibleTypePattern tp' InvisPatMisplaced) + ; return (InvisPat spec tp') + } + -------------------- rnConPatAndThen :: NameMaker -> LocatedN RdrName -- the constructor -> HsConPatDetails GhcPs -> CpsRn (Pat GhcRn) -rnConPatAndThen mk con (PrefixCon tyargs pats) +rnConPatAndThen mk con (PrefixCon pats) = do { con' <- lookupConCps con - ; liftCps check_lang_exts - ; tyargs' <- mapM rnConPatTyArg tyargs - ; pats' <- rnLPatsAndThen mk pats + ; pats' <- rnLArgPatsAndThen mk pats ; return $ ConPat { pat_con_ext = noExtField , pat_con = con' - , pat_args = PrefixCon tyargs' pats' + , pat_args = PrefixCon pats' } } - where - check_lang_exts :: RnM () - check_lang_exts = - for_ (listToMaybe tyargs) $ \ arg -> - do { type_abs <- xoptM LangExt.TypeAbstractions - ; type_app <- xoptM LangExt.TypeApplications - ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables - ; if | type_abs - -> return () - -- As per [GHC Proposal 604](https://github.com/ghc-proposals/ghc-proposals/pull/604/), - -- we allow type applications in constructor patterns when -XTypeApplications and - -- -XScopedTypeVariables are both enabled, but we emit a warning when doing so. - -- - -- This warning is scheduled to become an error in GHC 9.12, in - -- which case we will get the usual error (below), - -- which suggests enabling -XTypeAbstractions. - | type_app && scoped_tvs - -> addDiagnostic TcRnDeprecatedInvisTyArgInConPat - - | otherwise - -> addErrTc $ TcRnTypeApplicationsDisabled (TypeApplicationInPattern arg) - } - - rnConPatTyArg (HsConPatTyArg at t) = do - t' <- liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t - return (HsConPatTyArg at t') - rnConPatAndThen mk con (InfixCon pat1 pat2) = do { con' <- lookupConCps con ; pat1' <- rnLPatAndThen mk pat1 ; pat2' <- rnLPatAndThen mk pat2 - ; fixity <- liftCps $ lookupFixityRn (unLoc con') + ; fixity <- liftCps $ lookupFixityRn (getName con') ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } rnConPatAndThen mk con (RecCon rpats) @@ -680,20 +717,22 @@ ; rpats' <- rnHsRecPatsAndThen mk con' rpats ; return $ ConPat { pat_con_ext = noExtField - , pat_con = con' - , pat_args = RecCon rpats' + , pat_con = con' + , pat_args = RecCon rpats' } } - -checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn () +checkUnusedRecordWildcardCps :: SrcSpan + -> Maybe [ImplicitFieldBinders] + -> CpsRn () checkUnusedRecordWildcardCps loc dotdot_names = CpsRn (\thing -> do (r, fvs) <- thing () checkUnusedRecordWildcard loc fvs dotdot_names return (r, fvs) ) + -------------------- rnHsRecPatsAndThen :: NameMaker - -> LocatedN Name -- Constructor + -> LocatedN (WithUserRdr Name) -- constructor -> HsRecFields GhcPs (LPat GhcPs) -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) rnHsRecPatsAndThen mk (L _ con) @@ -701,20 +740,15 @@ = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields ; flds' <- mapM rn_field (flds `zip` [1..]) - ; check_unused_wildcard (implicit_binders flds' <$> dd) - ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } + ; check_unused_wildcard (lHsRecFieldsImplicits flds' <$> unLoc <$> 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') = do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld) ; return (L l (fld { hfbRHS = arg' })) } - loc = maybe noSrcSpan getLoc dd - - -- Get the arguments of the implicit binders - implicit_binders fs (unLoc -> RecFieldsDotDot n) = collectPatsBinders CollNoDictBinders implicit_pats - where - implicit_pats = map (hfbRHS . unLoc) (drop n fs) + loc = maybe noSrcSpan getLocA dd -- Don't warn for let P{..} = ... in ... check_unused_wildcard = case mk of @@ -753,8 +787,8 @@ -} data HsRecFieldContext - = HsRecFieldCon Name - | HsRecFieldPat Name + = HsRecFieldCon (WithUserRdr Name) + | HsRecFieldPat (WithUserRdr Name) | HsRecFieldUpd rnHsRecFields @@ -789,7 +823,9 @@ HsRecFieldPat con -> Just con HsRecFieldUpd -> Nothing - rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg) + rn_fld :: Bool + -> Maybe (WithUserRdr Name) + -> LHsRecField GhcPs (LocatedA arg) -> RnM (LHsRecField GhcRn (LocatedA arg)) rn_fld pun_ok parent (L l (HsFieldBind @@ -808,16 +844,16 @@ ; 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 } } - rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat - -> Maybe Name -- The constructor (Nothing for an - -- out of scope constructor) + rn_dotdot :: Maybe (LocatedE RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat + -> Maybe (WithUserRdr Name) + -- The constructor (Nothing for an out of scope constructor) -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields - -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in - rn_dotdot (Just (L loc (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match + -> RnM [LHsRecField GhcRn (LocatedA arg)] -- Field Labels we need to fill in + rn_dotdot (Just (L loc_e (RecFieldsDotDot n))) (Just qcon@(WithUserRdr _ con)) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We @@ -826,9 +862,9 @@ do { dd_flag <- xoptM LangExt.RecordWildCards ; 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) + ; conInfo <- lookupConstructorInfo qcon + ; 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; @@ -849,11 +885,12 @@ _other -> True ] ; addUsedGREs NoDeprecationWarnings dot_dot_gres + ; let loc = locA loc_e ; let locn = noAnnSrcSpan loc ; 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 @@ -943,27 +980,30 @@ -> 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)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (l2l loc) (HsVar noExtField (L (l2l loc) arg_rdr))) } + ; return (L (l2l loc) (mkHsVarWithUserRdr lbl (L (l2l loc) arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' - ; let lbl' :: 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 @@ -972,9 +1012,12 @@ getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (hsRecFieldSel . unLoc) flds -getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] +getFieldRdrs :: [LHsRecField GhcRn arg] -> [RdrName] +getFieldRdrs flds = map (foExt . unXRec @GhcRn . hfbLHS . unLoc) flds + +getFieldLbls :: [LHsRecField (GhcPass p) arg] -> [IdGhcP p] getFieldLbls flds - = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds + = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) flds needFlagDotDot :: HsRecFieldContext -> TcRnMessage needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart @@ -983,8 +1026,8 @@ dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt) toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart -toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor n -toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern n +toRecordFieldPart (HsRecFieldCon n) = RecordFieldConstructor (getName n) +toRecordFieldPart (HsRecFieldPat n) = RecordFieldPattern (getName n) toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate {- Note [Disambiguating record updates] @@ -1004,26 +1047,91 @@ the parent datatype by computing the parents (TyCon/PatSyn) which have at least one constructor (DataCon/PatSyn) with all of the fields. -For example, in the (non-overloaded) record update +To do this, given the (non-empty) set of fields in the record update, +lookupRecUpdFields proceeds as follows: - r { fld1 = 3, fld2 = 'x' } + (1) For each field, retrieve all the in-scope GREs that it could possibly + refer to. -only the TyCon R contains at least one DataCon which has both of the fields -being updated: in this case, MkR1 and MkR2 have both of the updated fields. -The TyCon S also has both fields fld1 and fld2, but no single constructor -has both of those fields, so S is not a valid parent for this record update. + (2) Take an intersection to compute the possible parent data constructors. + For example, for an update -Note that this check is namespace-aware, so that a record update such as + r { fld1 = 3, fld2 = 'x' } + the possible parents for each field are: + + fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1, MkS1 |> S.fld1] + fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2, MkS2 |> S.fld2] + + after intersecting by constructor, we get: + + fld1: [MkR1 |-> R.fld1, MkR2 |-> R.fld1] + fld2: [MkR1 |-> R.fld2, MkR2 |-> R.fld2] + + This reflects the fact that only the TyCon R contains at least one DataCon + which has both of the fields being updated: MkR1 and MkR2. + The TyCon S also has both fields fld1 and fld2, but no single constructor + has both of those fields, so S is not a valid parent for this record update. + + (3) + (a) + If there is at least one possible parent TyCon, succeed. The typechecker + might still be able to disambiguate if there remains more than one + candidate parent TyCon (see Note [Type-directed record disambiguation]). + (b) + Otherwise, report an error saying "No constructor has all these fields". + This is the job of GHC.Rename.Env.badFieldsUpd. This function tries + to report a minimal set of fields, so that in a record update like + + r { fld1 = x1, fld2 = x2, [...], fld99 = x99 } + + we don't report a massive error message saying "No constructor has all + the fields fld1, ..., fld99" and instead report e.g. "No constructor + has all the fields { fld3, fld17 }". + +Wrinkle [Qualified names in record updates] + + Note that we must take into account qualified names in (1), so that a record + update such as + import qualified M ( R (fld1, fld2) ) f r = r { M.fld1 = 3 } -is unambiguous, as only R contains the field fld1 in the M namespace. -(See however #22122 for issues relating to the usage of exact Names in -record fields.) + is unambiguous: only R contains the field fld1 with the M qualifier. -See also Note [Type-directed record disambiguation] in GHC.Tc.Gen.Expr. + The function that looks up the GREs for the record update is 'lookupFieldGREs', + which uses 'lookupGRE env (LookupRdrName ...)', ensuring that we correctly + filter the GREs with the correct module qualification (with 'pickGREs'). + (See however #22122 for issues relating to the usage of exact Names in + record fields.) + +Wrinkle [Out of scope constructors] + + For (3)(b), we have an invalid record update because no constructor has + all of the fields of the record update. The 'badFieldsUpd' then tries to + compute a minimal set of fields which are not children of any single + constructor. The way this is done is explained in + Note [Finding the conflicting fields] in GHC.Rename.Env, but in short that + function needs a mapping from ConLike to all of its fields to do its business. + (You may remark that we did not need such a mapping for step (2).) + + This means we need to look up each constructor and find its fields; this + information is stored in the GREInfo field of a constructor GRE. + We need this information even if the constructor itself is not in scope, so + we proceed as follows: + + 1. First look up the constructor in the GlobalRdrEnv, using lookupGRE_Name. + This handles constructors defined in the current module being renamed, + as well as in-scope imported constructors. + 2. If that fails (e.g. the field is imported but the constructor is not), + then look up the GREInfo of the constructor in the TypeEnv, using + lookupGREInfo. This makes sure we give the right error message even when + the constructors are not in scope (#26391). + + Note that we do need (1), as (2) does not handle constructors defined in the + current module being renamed (as those have not yet been added to the TypeEnv). + Note [Using PatSyn FreeVars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we are disambiguating a non-overloaded record update, as per @@ -1098,11 +1206,355 @@ } ; let std_name = hsOverLitName val ; (from_thing_name, fvs1) <- lookupSyntaxName std_name + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast ; let rebindable = from_thing_name /= std_name lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable - , ol_from_fun = noLocA from_thing_name } } + , ol_from_fun = L (noAnnSrcSpan loc) from_thing_name } } ; if isNegativeZeroOverLit lit' - then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName - ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) - , fvs1 `plusFV` fvs2) } + then do { (negate_expr, fvs2) <- lookupSyntaxExpr negateName + ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_expr) + , fvs1 `plusFV` fvs2) } else return ((lit', Nothing), fvs1) } + + +rnHsTyPat :: HsDocContext + -> HsTyPat GhcPs + -> CpsRn (HsTyPat GhcRn) +rnHsTyPat ctxt sigType = case sigType of + (HsTP { hstp_body = hs_ty }) -> do + (hs_ty', tpb) <- runTPRnM (rn_lty_pat hs_ty) ctxt + pure HsTP + { hstp_body = hs_ty' + , hstp_ext = buildHsTyPatRn tpb + } + +-- | Type pattern renaming monad +-- For the OccSet in the ReaderT, see Note [Locally bound names in type patterns] +-- For the HsTyPatRnBuilderRn in the WriterT, see Note [Implicit and explicit type variable binders] +-- For the CpsRn base monad, see Note [CpsRn monad] +-- For why we need CpsRn in TPRnM see Note [Left-to-right scoping of type patterns] +newtype TPRnM a = + MkTPRnM (ReaderT (HsDocContext, OccSet) (WriterT HsTyPatRnBuilder CpsRn) a) + deriving newtype (Functor, Applicative, Monad) + +runTPRnM :: TPRnM a -> HsDocContext -> CpsRn (a, HsTyPatRnBuilder) +runTPRnM (MkTPRnM thing_inside) doc_ctxt = runWriterT $ runReaderT thing_inside (doc_ctxt, emptyOccSet) + +askLocals :: TPRnM OccSet +askLocals = MkTPRnM (asks snd) + +askDocContext :: TPRnM HsDocContext +askDocContext = MkTPRnM (asks fst) + +tellTPB :: HsTyPatRnBuilder -> TPRnM () +tellTPB = MkTPRnM . lift . tell + +liftRnFV :: RnM (a, FreeVars) -> TPRnM a +liftRnFV = liftTPRnCps . liftCpsFV + +liftRn :: RnM a -> TPRnM a +liftRn = liftTPRnCps . liftCps + +liftRnWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> TPRnM b +liftRnWithCont cont = liftTPRnCps (liftCpsWithCont cont) + +liftTPRnCps :: CpsRn a -> TPRnM a +liftTPRnCps = MkTPRnM . lift . lift + +liftTPRnRaw :: + ( forall r . + HsDocContext -> + OccSet -> + ((a, HsTyPatRnBuilder) -> RnM (r, FreeVars)) -> + RnM (r, FreeVars) + ) -> TPRnM a +liftTPRnRaw cont = MkTPRnM $ ReaderT $ \(doc_ctxt, locals) -> writerT $ liftCpsWithCont (cont doc_ctxt locals) + +unTPRnRaw :: + TPRnM a -> + HsDocContext -> + OccSet -> + ((a, HsTyPatRnBuilder) -> RnM (r, FreeVars)) -> + RnM (r, FreeVars) +unTPRnRaw (MkTPRnM m) doc_ctxt locals = unCpsRn $ runWriterT $ runReaderT m (doc_ctxt, locals) + +wrapSrcSpanTPRnM :: (a -> TPRnM b) -> LocatedAn ann a -> TPRnM (LocatedAn ann b) +wrapSrcSpanTPRnM fn (L loc a) = do + a' <- fn a + pure (L loc a') + +lookupTypeOccTPRnM :: RdrName -> TPRnM Name +lookupTypeOccTPRnM rdr_name = liftRnFV $ do + name <- lookupTypeOccRn rdr_name + pure (name, unitFV name) + +rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn) +rn_lty_pat (L l hs_ty) = do + hs_ty' <- rn_ty_pat hs_ty + pure (L l hs_ty') + +rn_ty_pat_var :: LocatedN RdrName -> TPRnM (LocatedN (WithUserRdr Name)) +rn_ty_pat_var lrdr@(L l rdr) = do + locals <- askLocals + if isRdrTyVar rdr + && not (elemOccSet (occName rdr) locals) -- See Note [Locally bound names in type patterns] + + then do -- binder + name <- liftTPRnCps $ newPatName (LamMk True) lrdr + tellTPB (tpBuilderExplicitTV name) + pure (L l $ WithUserRdr rdr name) + + else do -- usage + name <- lookupTypeOccTPRnM rdr + pure (L l $ WithUserRdr rdr name) + +-- | Rename type patterns +-- +-- For the difference between `rn_ty_pat` and `rnHsTyKi` see Note [CpsRn monad] +-- and Note [Implicit and explicit type variable binders] +rn_ty_pat :: HsType GhcPs -> TPRnM (HsType GhcRn) +rn_ty_pat tv@(HsTyVar an prom lrdr) = do + L l (WithUserRdr _ name) <- rn_ty_pat_var lrdr + when (isDataConName name && not (isKindName name)) $ + -- Any use of a promoted data constructor name (that is not specifically + -- exempted by isKindName) is illegal without the use of DataKinds. + -- See Note [Checking for DataKinds] in GHC.Tc.Validity. + check_data_kinds tv + pure (HsTyVar an prom (L l $ WithUserRdr (unLoc lrdr) name)) + +rn_ty_pat (HsForAllTy an tele body) = liftTPRnRaw $ \ctxt locals thing_inside -> + bindHsForAllTelescope ctxt tele $ \tele' -> do + let + tele_names = hsForAllTelescopeNames tele' + locals' = locals `extendOccSetList` map occName tele_names + + unTPRnRaw (rn_lty_pat body) ctxt locals' $ \(body', tpb) -> + delLocalNames tele_names $ -- locally bound names do not scope over the continuation + thing_inside ((HsForAllTy an tele' body'), tpb) + +rn_ty_pat (HsQualTy an lctx body) = do + lctx' <- wrapSrcSpanTPRnM (mapM rn_lty_pat) lctx + body' <- rn_lty_pat body + pure (HsQualTy an lctx' body') + +rn_ty_pat (HsAppTy _ fun_ty arg_ty) = do + fun_ty' <- rn_lty_pat fun_ty + arg_ty' <- rn_lty_pat arg_ty + pure (HsAppTy noExtField fun_ty' arg_ty') + +rn_ty_pat (HsAppKindTy _ ty ki) = do + kind_app <- liftRn $ xoptM LangExt.TypeApplications + unless kind_app (liftRn $ addErr (typeAppErr KindLevel ki)) + ty' <- rn_lty_pat ty + ki' <- rn_lty_pat ki + pure (HsAppKindTy noExtField ty' ki') + +rn_ty_pat (HsFunTy an mult lhs rhs) = do + lhs' <- rn_lty_pat lhs + mult' <- rn_ty_pat_mult mult + rhs' <- rn_lty_pat rhs + pure (HsFunTy an mult' lhs' rhs') + +rn_ty_pat (HsListTy an ty) = do + ty' <- rn_lty_pat ty + pure (HsListTy an ty') + +rn_ty_pat (HsTupleTy an con tys) = do + tys' <- mapM rn_lty_pat tys + pure (HsTupleTy an con tys') + +rn_ty_pat (HsSumTy an tys) = do + tys' <- mapM rn_lty_pat tys + pure (HsSumTy an tys') + +rn_ty_pat (HsOpTy _ prom ty1 l_op ty2) = do + ty1' <- rn_lty_pat ty1 + l_op' <- rn_ty_pat_var l_op + ty2' <- rn_lty_pat ty2 + fix <- liftRn $ lookupTyFixityRn $ fmap getName l_op' + let op_name = getName l_op' + when (isDataConName op_name && not (isPromoted prom)) $ + liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name) + liftRn $ mkHsOpTyRn prom l_op' fix ty1' ty2' + +rn_ty_pat (HsParTy an ty) = do + ty' <- rn_lty_pat ty + pure (HsParTy an ty') + +rn_ty_pat (HsIParamTy an n ty) = do + ty' <- rn_lty_pat ty + pure (HsIParamTy an n ty') + +rn_ty_pat (HsStarTy an unicode) = + pure (HsStarTy an unicode) + +rn_ty_pat (HsDocTy an ty haddock_doc) = do + ty' <- rn_lty_pat ty + haddock_doc' <- liftRn $ rnLHsDoc haddock_doc + pure (HsDocTy an ty' haddock_doc') + +rn_ty_pat ty@(HsExplicitListTy _ prom tys) = do + check_data_kinds ty + + unless (isPromoted prom) $ + liftRn $ addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList) + + tys' <- mapM rn_lty_pat tys + pure (HsExplicitListTy noExtField prom tys') + +rn_ty_pat ty@(HsExplicitTupleTy _ prom tys) = do + check_data_kinds ty + tys' <- mapM rn_lty_pat tys + pure (HsExplicitTupleTy noExtField prom tys') + +rn_ty_pat tyLit@(HsTyLit src t) = do + check_data_kinds tyLit + t' <- liftRn $ rnHsTyLit t + pure (HsTyLit src t') + +rn_ty_pat (HsWildCardTy _) = + pure (HsWildCardTy noExtField) + +rn_ty_pat (HsKindSig an ty ki) = do + ctxt <- askDocContext + kind_sigs_ok <- liftRn $ xoptM LangExt.KindSignatures + unless kind_sigs_ok (liftRn $ badKindSigErr ctxt ki) + ~(HsPS hsps ki') <- liftRnWithCont $ + rnHsPatSigKind AlwaysBind ctxt (HsPS noAnn ki) + ty' <- rn_lty_pat ty + tellTPB (tpBuilderPatSig hsps) + pure (HsKindSig an ty' ki') + +rn_ty_pat (HsSpliceTy _ splice) = do + res <- liftRnFV $ rnSpliceTyPat splice + case res of + (rn_splice, HsUntypedSpliceTop mfs pat) -> do -- Splice was top-level and thus run, creating LHsType GhcPs + pat' <- rn_lty_pat pat + pure (HsSpliceTy (HsUntypedSpliceTop mfs (mb_paren pat')) rn_splice) + (rn_splice, HsUntypedSpliceNested splice_name) -> + pure (HsSpliceTy (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed + where + mb_paren :: LHsType GhcRn -> LHsType GhcRn + mb_paren lhs_ty@(L loc hs_ty) + | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty) + | otherwise = lhs_ty + +rn_ty_pat ty@(XHsType{}) = do + ctxt <- askDocContext + liftRnFV $ rnHsType ctxt ty + +rn_ty_pat_mult :: HsMultAnn GhcPs -> TPRnM (HsMultAnn GhcRn) +rn_ty_pat_mult (HsUnannotated _) = pure (HsUnannotated noExtField) +rn_ty_pat_mult (HsLinearAnn _) = pure (HsLinearAnn noExtField) +rn_ty_pat_mult (HsExplicitMult _ p) + = rn_lty_pat p <&> (\mult -> HsExplicitMult noExtField mult) + +check_data_kinds :: HsType GhcPs -> TPRnM () +check_data_kinds thing = liftRn $ do + data_kinds <- xoptM LangExt.DataKinds + unless data_kinds $ + addErr $ TcRnDataKindsError TypeLevel $ Left thing + +{- Note [Locally bound names in type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type patterns can bind local names using forall. Compare the following examples: + f (Proxy @(Either a b)) = ... + g (Proxy @(forall a . Either a b)) = ... + +In `f` both `a` and `b` are bound by the pattern and scope over the RHS of f. +In `g` only `b` is bound by the pattern, whereas `a` is locally bound in the pattern +and does not scope over the RHS of `g`. + +We track locally bound names in the `OccSet` in `TPRnM` monad, and use it to +decide whether occurrences of type variables are usages or bindings. + +The check is done in `rn_ty_pat_var` + +Note [Implicit and explicit type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type patterns are renamed differently from ordinary types. + * Types are renamed by `rnHsType` where all type variable occurrences are considered usages + * Type patterns are renamed by `rnHsTyPat` where some type variable occurrences are usages + and other are bindings + +Here is an example: + {-# LANGUAGE ScopedTypeVariables #-} + f :: forall b. Proxy _ -> ... + f (Proxy @(x :: (a, b))) = ... + +In the (x :: (a,b)) type pattern + * `x` is a type variable explicitly bound by type pattern + * `a` is a type variable implicitly bound in a pattern signature + * `b` is a usage of type variable bound by the outer forall + +This classification is clear to us in `rnHsTyPat`, but it is also useful in later passes, such +as `collectPatBinders` and `tcHsTyPat`, so we store it in the extension field of `HsTyPat`, namely +`HsTyPatRn`. + +To collect lists of those variables efficiently we use `HsTyPatRnBuilder` which is exactly like +`HsTyPatRn`, but uses Bags. + +Note [Left-to-right scoping of type patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In term-level patterns, we use continuation passing to implement left-to-right +scoping, see Note [CpsRn monad]. Left-to-right scoping manifests itself when +e.g. view patterns are involved: + + f (x, g x -> Just y) = ... + +Here the first occurrence of `x` is a binder, and the second occurrence is a +use of `x` in a view pattern. This example does not work if we swap the +components of the tuple: + + f (g x -> Just y, x) = ... + -- ^^^ + -- Variable not in scope: x + +In type patterns there are no view patterns, but there is a different feature +that is served well by left-to-right scoping: kind annotations. Compare: + + f (Proxy @(T k (a :: k))) = ... + g (Proxy @(T (a :: k) k)) = ... + +In `f`, the first occurrence of `k` is an explicit binder, + and the second occurrence is a usage. Simple. +In `g`, the first occurrence of `k` is an implicit binder, + and then the second occurrence is an explicit binder that shadows it. + +So we get two different results after renaming: + + f (Proxy @(T k1 (a :: k1))) = ... + g (Proxy @(T (a :: k1) k2)) = ... + +This makes GHC accept the first example but rejects the second example with an +error about duplicate binders. + +One could argue that we don't want order-sensitivity here. Historically, we +used a different principle when renaming types: collect all free variables, +bind them on the outside, and then rename all occurrences as usages. +This approach does not scale to multiple patterns. Consider: + + f' (MkP @k @(a :: k)) = ... + g' (MkP @(a :: k) @k) = ... + +Here a difference in behavior is inevitable, as we rename type patterns +one at a time. Could we perhaps concatenate the free variables from all +type patterns in a ConPat? But then we still get the same problem one level up, +when we have multiple patterns in a function LHS + + f'' (Proxy @k) (Proxy @(a :: k)) = ... + g'' (Proxy @(a :: k)) (Proxy @k) = ... + +And if we tried to avoid order sensitivity at this level, then we'd still be left +with lambdas: + + f''' (Proxy @k) = \(Proxy @(a :: k)) -> ... + g''' (Proxy @(a :: k)) = \(Proxy @k) -> ... + + +So we have at least three options where we could do free variable extraction: +HsTyPat, ConPat, or a Match (used to represent a function LHS). And none +of those would be general enough. Rather than make an arbitrary choice, we +embrace left-to-right scoping in types and implement it with CPS, just like +it's done for view patterns in terms. +-} diff --git a/GHC/Rename/Splice.hs b/GHC/Rename/Splice.hs --- a/GHC/Rename/Splice.hs +++ b/GHC/Rename/Splice.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Rename.Splice ( rnTopSpliceDecls, @@ -7,12 +8,13 @@ -- Typed splices rnTypedSplice, -- Untyped splices - rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceDecl, + rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceTyPat, rnSpliceDecl, -- Brackets rnTypedBracket, rnUntypedBracket, - checkThLocalName, traceSplice, SpliceInfo(..) + checkThLocalName, checkThLocalNameWithLift, checkThLocalNameNoLift, traceSplice, SpliceInfo(..), + checkThLocalTyName, ) where import GHC.Prelude @@ -42,14 +44,14 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy ) +import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Driver.Hooks -import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName +import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName , patQTyConName, quoteDecName, quoteExpName , quotePatName, quoteTypeName, typeQTyConName) @@ -65,9 +67,10 @@ import GHC.Tc.Zonk.Type import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) +import qualified GHC.Boot.TH.Syntax as TH (Q) import qualified GHC.LanguageExtensions as LangExt +import qualified Data.Set as Set {- ************************************************************************ @@ -83,17 +86,48 @@ unlessXOptM LangExt.TemplateHaskellQuotes $ failWith $ thSyntaxError $ IllegalTHQuotes e +{- + +Note [Untyped quotes in typed splices and vice versa] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this typed splice + $$(f [| x |]) + +Is there anything wrong with that /typed/ splice containing an /untyped/ +quote [| x |]? One could ask the same about an /untyped/ slice containing a +/typed/ quote. + +In fact, both are fine (#24190). Presumably f's type looks something like: + f :: Q Expr -> Code Q Int + +It is pretty hard for `f` to use its (untyped code) argument to build a typed +syntax tree, but not impossible: +* `f` could use `unsafeCodeCoerce :: Q Exp -> Code Q a` +* `f` could just perform case analysis on the tree + +But in the end all that matters is that in $$( e ), the expression `e` has the +right type. It doesn't matter how `e` is built. To put it another way, the +untyped quote `[| x |]` could also be written `varE 'x`, which is an ordinary +expression. + +Moreover the ticked variable, 'x :: Name, is itself treated as an untyped quote; +but it is a perfectly fine sub-expression to have in a typed splice. + +(Historical note: GHC used to unnecessarily check that a typed quote only +occurred in a typed splice: #24190.) + +-} + rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnTypedBracket e br_body - = addErrCtxt (typedQuotationCtxtDoc br_body) $ + = addErrCtxt (TypedTHBracketCtxt br_body) $ do { checkForTemplateHaskellQuotes e -- Check for nested brackets - ; cur_stage <- getStage - ; case cur_stage of - { Splice Typed -> return () - ; Splice Untyped -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Untyped IsBracket + ; cur_level <- getThLevel + ; case cur_level of + { Splice _ _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnTypedBracket: Renaming typed bracket when running a splice" @@ -107,23 +141,21 @@ ; recordThUse ; traceRn "Renaming typed TH bracket" empty - ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body - + ; (body', fvs_e) <- setThLevel (Brack cur_level RnPendingTyped) $ rnLExpr br_body ; return (HsTypedBracket noExtField body', fvs_e) } rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnUntypedBracket e br_body - = addErrCtxt (untypedQuotationCtxtDoc br_body) $ + = addErrCtxt (UntypedTHBracketCtxt br_body) $ do { checkForTemplateHaskellQuotes e -- Check for nested brackets - ; cur_stage <- getStage - ; case cur_stage of - { Splice Typed -> failWithTc $ thSyntaxError - $ MismatchedSpliceType Typed IsBracket - ; Splice Untyped -> return () + ; cur_level <- getThLevel + ; case cur_level of + { Splice _ _ -> return () + -- See Note [Untyped quotes in typed splices and vice versa] ; RunSplice _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice" @@ -141,49 +173,31 @@ ; (body', fvs_e) <- -- See Note [Rebindable syntax and Template Haskell] unsetXOptM LangExt.RebindableSyntax $ - setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ - rn_utbracket cur_stage br_body + setThLevel (UntypedBrack cur_level ps_var) $ + rn_utbracket br_body ; pendings <- readMutVar ps_var ; return (HsUntypedBracket pendings body', fvs_e) } -rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars) -rn_utbracket outer_stage br@(VarBr x flg rdr_name) - = do { name <- lookupOccRn (unLoc rdr_name) +rn_utbracket :: HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars) +rn_utbracket (VarBr _ flg rdr_name) + = do { name <- lookupOccRn (if flg then WL_Term else WL_Type) (unLoc rdr_name) + ; let res_name = L (l2l (locA rdr_name)) (WithUserRdr (unLoc rdr_name) name) + ; if flg then checkThLocalNameNoLift res_name else checkThLocalTyName name ; check_namespace flg name - ; this_mod <- getModule - - ; when (flg && nameIsLocalOrFrom this_mod name) $ - -- Type variables can be quoted in TH. See #5721. - do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name - ; case mb_bind_lvl of - { Nothing -> return () -- Can happen for data constructors, - -- but nothing needs to be done for them - - ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] - | isTopLevel top_lvl - -> when (isExternalName name) (keepAlive name) - | otherwise - -> do { traceRn "rn_utbracket VarBr" - (ppr name <+> ppr bind_lvl - <+> ppr outer_stage) - ; checkTc (thLevel outer_stage + 1 == bind_lvl) $ - TcRnTHError $ THNameError $ QuotedNameWrongStage br } - } - } - ; return (VarBr 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 } @@ -195,7 +209,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 @@ -209,7 +223,7 @@ } }} -rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG" +rn_utbracket (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG" -- | Ensure that we are not using a term-level name in a type-level namespace @@ -221,16 +235,6 @@ where ns = nameNameSpace nm -typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc -typedQuotationCtxtDoc br_body - = hang (text "In the Template Haskell typed quotation") - 2 (thTyBrackets . ppr $ br_body) - -untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc -untypedQuotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (ppr br_body) - {- ********************************************************* * * @@ -269,32 +273,33 @@ rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars)) -- Outside brackets, run splice - -> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a)) + -> (UntypedSpliceFlavour, HsUntypedSpliceResult z -> HsUntypedSplice GhcRn -> RnM a) -- Inside brackets, make it pending -> HsUntypedSplice GhcPs -> RnM (a, FreeVars) -rnUntypedSpliceGen run_splice pend_splice splice - = addErrCtxt (spliceCtxt splice) $ do - { stage <- getStage - ; case stage of - Brack _ RnPendingTyped +rnUntypedSpliceGen run_splice (flavour, run_pending) splice + = addErrCtxt (UntypedSpliceCtxt splice) $ do + { level <- getThLevel + ; case level of + TypedBrack {} -> failWithTc $ thSyntaxError $ MismatchedSpliceType Untyped IsSplice - Brack pop_stage (RnPendingUntyped ps_var) - -> do { (splice', fvs) <- setStage pop_stage $ - rnUntypedSplice splice + UntypedBrack pop_level ps_var + -> do { (splice', fvs) <- setThLevel pop_level $ + rnUntypedSplice splice flavour ; loc <- getSrcSpanM ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice) - ; let (pending_splice, result) = pend_splice splice_name splice' + ; result <- run_pending (HsUntypedSpliceNested splice_name) splice' ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pending_splice : ps) + ; writeMutVar ps_var (PendingRnSplice splice_name splice' : ps) ; return (result, fvs) } _ -> do { checkTopSpliceAllowed splice + ; cur_level <- getThLevel ; (splice', fvs1) <- checkNoErrs $ - setStage (Splice Untyped) $ - rnUntypedSplice splice + setThLevel (Splice Untyped cur_level) $ + rnUntypedSplice splice flavour -- checkNoErrs: don't attempt to run the splice if -- renaming it failed; otherwise we get a cascade of -- errors from e.g. unbound variables @@ -333,9 +338,11 @@ Nothing -> return splice Just h -> h splice + -- TODO: Should call tcUntypedSplice here ; let the_expr = case splice' of HsUntypedSpliceExpr _ e -> e HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str + XUntypedSplice {} -> pprPanic "runRnSplice: XUntypedSplice" (pprUntypedSplice False Nothing splice') -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -345,7 +352,7 @@ -- Run the expression ; mod_finalizers_ref <- newTcRef [] - ; result <- setStage (RunSplice mod_finalizers_ref) $ + ; result <- setThLevel (RunSplice mod_finalizers_ref) $ run_meta zonked_q_expr ; mod_finalizers <- readTcRef mod_finalizers_ref ; traceSplice (SpliceInfo { spliceDescription = what @@ -370,32 +377,36 @@ UntypedDeclSplice -> True _ -> False ------------------- -makePending :: UntypedSpliceFlavour - -> Name - -> HsUntypedSplice GhcRn - -> PendingRnSplice -makePending flavour n (HsUntypedSpliceExpr _ e) - = PendingRnSplice flavour n e -makePending flavour n (HsQuasiQuote _ quoter quote) - = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter quote) +-- See Note [Lifecycle of an untyped splice, and PendingRnSplice] +recordPendingSplice :: SplicePointName -> HsImplicitLiftSplice -> PendingStuff -> TcM (HsExpr GhcRn) +recordPendingSplice sp pn (RnPending ref) = do + let untyped_splice = XUntypedSplice pn + updTcRef ref (PendingRnSplice sp untyped_splice : ) + return (HsUntypedSplice (HsUntypedSpliceNested sp) untyped_splice) +-- Splices are not lifted for typed brackets +-- See Note [Lifecycle of an typed splice, and PendingTcSplice] +recordPendingSplice sp pn (RnPendingTyped) = do + let typed_splice = XTypedSplice pn + return (HsTypedSplice (HsTypedSpliceNested sp) typed_splice) +recordPendingSplice _ _ (TcPending _ _ _) = panic "impossible" + ------------------ -mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> LIdP GhcRn -> XRec GhcPs FastString -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter (L q_span' quote) - = L q_span $ HsApp noComments (L q_span - $ HsApp noComments (L q_span - (HsVar noExtField (L (la2na q_span) quote_selector))) + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span + (mkHsVar (L (l2l q_span) quote_selector))) quoterExpr) quoteExpr where q_span = noAnnSrcSpan (locA q_span') - quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter) - quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote + quoterExpr = L (l2l quoter) $! mkHsVar $! quoter + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -409,38 +420,44 @@ -- We use "spn" (which is arbitrary) because it is brief but grepable-for. unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn")) -rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars) +rnUntypedSplice :: HsUntypedSplice GhcPs + -> UntypedSpliceFlavour + -> RnM ( HsUntypedSplice GhcRn + , FreeVars) -- Not exported...used for all -rnUntypedSplice (HsUntypedSpliceExpr annCo expr) +rnUntypedSplice (HsUntypedSpliceExpr _ expr) flavour = do { (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSpliceExpr annCo expr', fvs) } + ; return (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr', fvs) } -rnUntypedSplice (HsQuasiQuote ext quoter quote) +rnUntypedSplice (HsQuasiQuote _ quoter quote) flavour = do { -- Rename the quoter; akin to the HsVar case of rnExpr - ; quoter' <- lookupOccRn quoter - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod quoter') $ - checkThLocalName quoter' - - ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') } + ; quoter' <- lookupLocatedOccRn WL_TermVariable quoter + ; let res_name = WithUserRdr (unLoc quoter) <$> quoter' + ; checkThLocalNameNoLift res_name + ; return (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter' quote, unitFV (unLoc quoter')) } --------------------- -rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression +rnTypedSplice :: HsTypedSplice GhcPs -- Typed splice expression -> RnM (HsExpr GhcRn, FreeVars) -rnTypedSplice expr - = addErrCtxt (hang (text "In the typed splice:") 2 (pprTypedSplice Nothing expr)) $ do - { stage <- getStage - ; case stage of - Brack pop_stage RnPendingTyped - -> setStage pop_stage rn_splice +rnTypedSplice sp@(HsTypedSpliceExpr _ expr) + = addErrCtxt (TypedSpliceCtxt Nothing sp) $ do + { level <- getThLevel + ; case level of + TypedBrack pop_level + -> do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice) + ; (e, fvs) <- setThLevel pop_level rn_splice + ; return (HsTypedSplice (HsTypedSpliceNested n') (HsTypedSpliceExpr noExtField e), fvs) + } - Brack _ (RnPendingUntyped _) + UntypedBrack {} -> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice _ -> do { unlessXOptM LangExt.TemplateHaskell (failWith $ thSyntaxError IllegalTHSplice) - ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_splice + ; cur_level <- getThLevel + ; (result, fvs1) <- checkNoErrs $ setThLevel (Splice Typed cur_level) rn_splice -- checkNoErrs: don't attempt to run the splice if -- renaming it failed; otherwise we get a cascade of -- errors from e.g. unbound variables @@ -456,37 +473,39 @@ lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) fvs2 = lcl_names `plusFV` gbl_names - ; return (result, fvs1 `plusFV` fvs2) } } + ; return (HsTypedSplice HsTypedSpliceTop (HsTypedSpliceExpr noExtField result), fvs1 `plusFV` fvs2) } } where - rn_splice :: RnM (HsExpr GhcRn, FreeVars) - rn_splice = - do { loc <- getSrcSpanM - -- The renamer allocates a splice-point name to every typed splice - -- (incl the top level ones for which it will not ultimately be used) - ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice) - ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice n' expr', fvs) } + rn_splice :: RnM (LHsExpr GhcRn, FreeVars) + rn_splice = rnLExpr expr rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnUntypedSpliceExpr splice = rnUntypedSpliceGen run_expr_splice pend_expr_splice splice where - pend_expr_splice :: Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) - pend_expr_splice name rn_splice - = (makePending UntypedExpSplice name rn_splice, HsUntypedSplice (HsUntypedSpliceNested name) rn_splice) + pend_expr_splice :: (UntypedSpliceFlavour, HsUntypedSpliceResult (HsExpr GhcRn) -> HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn)) + pend_expr_splice + = (UntypedExpSplice, \x y -> pure $ HsUntypedSplice x y) - run_expr_splice :: HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice = do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty - -- Run it here, see Note [Running splices in the Renamer] - ; (rn_expr, mod_finalizers) <- - runRnSplice UntypedExpSplice runMetaE ppr rn_splice - ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) - -- See Note [Delaying modFinalizers in untyped splices]. - ; let e = flip HsUntypedSplice rn_splice - . HsUntypedSpliceTop (ThModFinalizers mod_finalizers) - <$> lexpr3 - ; return (gHsPar e, fvs) + + -- Run the splice here, see Note [Running splices in the Renamer] + ; (expr_ps, mod_finalizers) + <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice + -- mod_finalizers: See Note [Delaying modFinalizers in untyped splices]. + + -- Rename the expanded expression + ; (L l expr_rn, fvs) <- checkNoErrs (rnLExpr expr_ps) + + -- rn_splice :: HsUntypedSplice GhcRn is the original TH expression, + -- before expansion + -- expr_ps :: LHsExpr GhcPs is the result of running the splice + -- expr_rn :: HsExpr GhcRn is the result of renaming ps_expr + ; let res :: HsUntypedSpliceResult (HsExpr GhcRn) + res = HsUntypedSpliceTop + { utsplice_result_finalizers = ThModFinalizers mod_finalizers + , utsplice_result = expr_rn } + ; return (gHsPar (L l (HsUntypedSplice res rn_splice)), fvs) } thSyntaxError :: THSyntaxError -> TcRnMessage @@ -637,7 +656,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' ...)) -} @@ -647,9 +666,9 @@ rnSpliceType splice = rnUntypedSpliceGen run_type_splice pend_type_splice splice where - pend_type_splice name rn_splice - = ( makePending UntypedTypeSplice name rn_splice - , HsSpliceTy (HsUntypedSpliceNested name) rn_splice) + pend_type_splice + = ( UntypedTypeSplice + , \x y -> pure $ HsSpliceTy x y) run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars) run_type_splice rn_splice @@ -727,9 +746,9 @@ rnSplicePat splice = rnUntypedSpliceGen run_pat_splice pend_pat_splice splice where - pend_pat_splice name rn_splice - = (makePending UntypedPatSplice name rn_splice - , (rn_splice, HsUntypedSpliceNested name)) -- Pat splice is nested and thus simply renamed + pend_pat_splice + = (UntypedPatSplice + , \x y -> pure (y, x)) -- Pat splice is nested and thus simply renamed run_pat_splice rn_splice = do { traceRn "rnSplicePat: untyped pattern splice" empty @@ -741,14 +760,34 @@ -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) +-- | Rename a splice type pattern. Much the same as `rnSplicePat`, but works with LHsType instead of LPat +rnSpliceTyPat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LHsType GhcPs)) + , FreeVars) +rnSpliceTyPat splice + = rnUntypedSpliceGen run_ty_pat_splice pend_ty_pat_splice splice + where + pend_ty_pat_splice + = (UntypedTypeSplice + , \x y -> pure (y, x)) + + run_ty_pat_splice rn_splice + = do { traceRn "rnSpliceTyPat: untyped pattern splice" empty + ; (ty, mod_finalizers) <- + runRnSplice UntypedTypeSplice runMetaT ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; let t = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) ty + ; return ((rn_splice, t), emptyFVs) } + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) rnSpliceDecl (SpliceDecl _ (L loc splice) flg) = rnUntypedSpliceGen run_decl_splice pend_decl_splice splice where - pend_decl_splice name rn_splice - = ( makePending UntypedDeclSplice name rn_splice - , SpliceDecl noExtField (L loc rn_splice) flg) + pend_decl_splice + = ( UntypedDeclSplice + , \_ y -> pure $ SpliceDecl noExtField (L loc y) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice) @@ -756,9 +795,10 @@ -- Declaration splice at the very top level of the module rnTopSpliceDecls splice = do { checkTopSpliceAllowed splice + ; cur_level <- getThLevel ; (rn_splice, fvs) <- checkNoErrs $ - setStage (Splice Untyped) $ - rnUntypedSplice splice + setThLevel (Splice Untyped cur_level) $ + rnUntypedSplice splice UntypedDeclSplice -- As always, be sure to checkNoErrs above lest we end up with -- holes making it to typechecking, hence #12584. -- @@ -821,14 +861,6 @@ or its splice point name if nested (HsUntypedSpliceNested) -} -spliceCtxt :: HsUntypedSplice GhcPs -> SDoc -spliceCtxt splice - = hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice) - where - what = case splice of - HsUntypedSpliceExpr {} -> text "untyped splice:" - HsQuasiQuote {} -> text "quasi-quotation:" - -- | The splice data to be logged data SpliceInfo = SpliceInfo @@ -875,78 +907,137 @@ = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -checkThLocalName :: Name -> RnM () -checkThLocalName name +checkThLocalTyName :: Name -> RnM () +checkThLocalTyName name | isUnboundName name -- Do not report two errors for = return () -- $(not_in_scope args) | otherwise - = do { traceRn "checkThLocalName" (ppr name) - ; mb_local_use <- getStageAndBindLevel name + = do { traceRn "checkThLocalTyName" (ppr name) + ; mb_local_use <- getCurrentAndBindLevel name ; case mb_local_use of { Nothing -> return () ; -- Not a locally-bound thing - Just (top_lvl, bind_lvl, use_stage) -> - do { let use_lvl = thLevel use_stage - ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl - ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl - <+> ppr use_stage - <+> ppr use_lvl) - ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } } + Just (top_lvl, bind_lvl, use_lvl) -> + do { let use_lvl_idx = thLevelIndex use_lvl + -- We don't check the well levelledness of name here. + -- this would break test for #20969 + -- + -- Consequently there is no check&restiction for top level splices. + -- But it's annoying anyway. + -- + -- Therefore checkCrossLevelLiftingTy shouldn't assume anything + -- about bind_lvl and use_lvl relation. + -- + ; traceRn "checkThLocalTyName" (ppr name <+> ppr bind_lvl + <+> ppr use_lvl + <+> ppr use_lvl) + ; dflags <- getDynFlags + ; checkCrossLevelLiftingTy dflags top_lvl bind_lvl use_lvl use_lvl_idx name } } } --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel - -> Name -> TcM () --- We are inside brackets, and (use_lvl > bind_lvl) --- Now we must check whether there's a cross-stage lift to do --- Examples \x -> [| x |] --- [| map |] --- --- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but --- this is only run on *untyped* brackets. +-- | Check whether we are allowed to use a Name in this context (for TH purposes) +-- In the case of a level incorrect program, attempt to fix it by using +-- a Lift constraint. +checkThLocalNameWithLift :: LIdOccP GhcRn -> RnM (HsExpr GhcRn) +checkThLocalNameWithLift = checkThLocalName True -checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name - | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets - , use_lvl > bind_lvl -- Cross-stage condition - = check_cross_stage_lifting top_lvl name ps_var +-- | Check whether we are allowed to use a Name in this context (for TH purposes) +-- In the case of a level incorrect program, do not attempt to fix it by using +-- a Lift constraint. +checkThLocalNameNoLift :: LIdOccP GhcRn -> RnM () +checkThLocalNameNoLift name = checkThLocalName False name >> return () + +-- | Implemenation of the level checks +-- See Note [Template Haskell levels] +checkThLocalName :: Bool -> LIdOccP GhcRn -> RnM (HsExpr GhcRn) +checkThLocalName allow_lifting name_var + -- Exact and Orig names are not imported, so presumed available at all levels. + | isExact (userRdrName (unLoc name_var)) || isOrig (userRdrName (unLoc name_var)) + = return (HsVar noExtField name_var) + | isUnboundName name -- Do not report two errors for + = return (HsVar noExtField name_var) -- $(not_in_scope args) + | isWiredInName name + = return (HsVar noExtField name_var) | otherwise - = return () + = do { + mb_local_use <- getCurrentAndBindLevel name + ; case mb_local_use of { + Nothing -> return (HsVar noExtField name_var) ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_lvl) -> + do { let use_lvl_idx = thLevelIndex use_lvl + ; cur_mod <- extractModule <$> getGblEnv + ; let is_local + | Just mod <- nameModule_maybe name = mod == cur_mod + | otherwise = True + ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl <+> ppr use_lvl <+> ppr use_lvl) + ; dflags <- getDynFlags + ; env <- getGlobalRdrEnv + ; let mgre = lookupGRE_Name env name + ; checkCrossLevelLifting dflags (LevelCheckSplice name mgre) top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var } } } + where + name = getName name_var -check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () -check_cross_stage_lifting top_lvl name ps_var +-------------------------------------- +checkCrossLevelLifting :: DynFlags + -> LevelCheckReason + -> TopLevelFlag + -> Bool + -> Bool + -> Set.Set ThLevelIndex + -> ThLevel + -> ThLevelIndex + -> LIdOccP GhcRn + -> TcM (HsExpr GhcRn) +checkCrossLevelLifting dflags reason top_lvl is_local allow_lifting bind_lvl use_lvl use_lvl_idx name_var + -- 1. If name is in-scope, at the correct level. + | use_lvl_idx `Set.member` bind_lvl = return (HsVar noExtField name_var) + -- 2. Name is imported with -XImplicitStagePersistence + | not is_local + , xopt LangExt.ImplicitStagePersistence dflags = return (HsVar noExtField name_var) + -- 3. Name is top-level, with -XImplicitStagePersistence, and needs + -- to be persisted into the future. | isTopLevel top_lvl - -- Top-level identifiers in this module, - -- (which have External Names) - -- are just like the imported case: - -- no need for the 'lifting' treatment - -- E.g. this is fine: - -- f x = x - -- g y = [| f 3 |] - = when (isExternalName name) (keepAlive name) - -- See Note [Keeping things alive for Template Haskell] + , is_local + , any (use_lvl_idx >=) (Set.toList bind_lvl) + , xopt LangExt.ImplicitStagePersistence dflags = when (isExternalName name) (keepAlive name) >> return (HsVar noExtField name_var) + -- 4. Name is in a bracket, and lifting is allowed + | Brack _ pending <- use_lvl + , any (use_lvl_idx >=) (Set.toList bind_lvl) + , allow_lifting + = do + let mgre = case reason of + LevelCheckSplice _ gre -> gre + _ -> Nothing + (splice_name :: Name) <- newLocalBndrRn (noLocA unqualSplice) + let pend_splice :: HsImplicitLiftSplice + pend_splice = HsImplicitLiftSplice bind_lvl use_lvl_idx mgre name_var + -- Warning for implicit lift (#17804) + addDetailedDiagnostic (TcRnImplicitLift name) - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [| h x |] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the SplicePointName, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same SplicePointName, but that doesn't - -- matter, although it's a mite untidy. - do { traceRn "checkCrossStageLifting" (ppr name) + -- Update the pending splices if we are renaming a typed bracket + recordPendingSplice splice_name pend_splice pending + -- Otherwise, we have a level error, report. + | otherwise = addErrTc (TcRnBadlyLevelled reason bind_lvl use_lvl_idx Nothing ErrorWithoutFlag ) >> return (HsVar noExtField name_var) + where + name = getName name_var - -- Construct the (lift x) expression - ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) - pend_splice = PendingRnSplice UntypedExpSplice name lift_expr +checkCrossLevelLiftingTy :: DynFlags -> TopLevelFlag -> Set.Set ThLevelIndex -> ThLevel -> ThLevelIndex -> Name -> TcM () +checkCrossLevelLiftingTy dflags top_lvl bind_lvl _use_lvl use_lvl_idx name + | isTopLevel top_lvl + , xopt LangExt.ImplicitStagePersistence dflags + = return () - -- Warning for implicit lift (#17804) - ; addDetailedDiagnostic (TcRnImplicitLift name) + -- There is no liftType (yet), so we could error, or more conservatively, just warn. + -- + -- For now, we check here for both untyped and typed splices, as we don't create splices. - -- Update the pending splices - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (pend_splice : ps) } + -- Can also happen for negative cases + -- See comment in checkThLocalTyName: + | use_lvl_idx `notElem` bind_lvl + = addDiagnostic $ TcRnBadlyLevelledType name bind_lvl use_lvl_idx + | otherwise + = return () + {- Note [Keeping things alive for Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -983,7 +1074,7 @@ Note [Quoting names] ~~~~~~~~~~~~~~~~~~~~ A quoted name 'n is a bit like a quoted expression [| n |], except that we -have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing +have no cross-level lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing the use-level to account for the brackets, the cases are: bind > use Error @@ -1002,7 +1093,7 @@ \x. f 'x -- Not ok (bind = 1, use = 1) -- (whereas \x. f [| x |] might have been ok, by - -- cross-stage lifting + -- cross-level lifting \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) diff --git a/GHC/Rename/Splice.hs-boot b/GHC/Rename/Splice.hs-boot --- a/GHC/Rename/Splice.hs-boot +++ b/GHC/Rename/Splice.hs-boot @@ -2,12 +2,17 @@ import GHC.Hs import GHC.Tc.Utils.Monad +import GHC.Types.Name (Name) import GHC.Types.Name.Set rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars) rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)) , FreeVars) +rnSpliceTyPat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LHsType GhcPs)) + , FreeVars) rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) + +checkThLocalTyName :: Name -> RnM () diff --git a/GHC/Rename/Unbound.hs b/GHC/Rename/Unbound.hs --- a/GHC/Rename/Unbound.hs +++ b/GHC/Rename/Unbound.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {- @@ -13,8 +14,8 @@ , mkUnboundGRERdr , isUnboundName , reportUnboundName - , reportUnboundName' , unknownNameSuggestions + , unknownNameSuggestionsMessage , similarNameSuggestions , fieldSelectorSuggestions , WhatLooking(..) @@ -25,7 +26,8 @@ , unboundTermNameInTypes , IsTermInTypes(..) , notInScopeErr - , nameSpacesRelated + , relevantNameSpace + , suggestionIsRelevant , termNameInType ) where @@ -34,10 +36,13 @@ import GHC.Driver.DynFlags import GHC.Driver.Ppr +import GHC.Driver.Env (hsc_units) +import GHC.Driver.Env.Types +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( getHoleFitDispConfig ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad -import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) +import GHC.Builtin.Names ( mkUnboundName, isUnboundName ) import GHC.Utils.Misc import GHC.Utils.Panic (panic) @@ -53,19 +58,21 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Types.Unique.DFM (udfmToList) import GHC.Unit.Module import GHC.Unit.Module.Imported -import GHC.Unit.Home.ModInfo +import GHC.Utils.Outputable +import GHC.Runtime.Context import GHC.Data.Bag -import GHC.Utils.Outputable (empty) +import Language.Haskell.Syntax.ImpExp -import Data.List (sortBy, partition, nub) +import Data.List (sortBy, partition) import Data.List.NonEmpty ( pattern (:|), NonEmpty ) +import qualified Data.List.NonEmpty as NE ( nonEmpty ) import Data.Function ( on ) import qualified Data.Semigroup as S +import qualified Data.Map as M {- ************************************************************************ @@ -75,19 +82,6 @@ ************************************************************************ -} --- What kind of suggestion are we looking for? #19843 -data WhatLooking = WL_Anything -- Any binding - | WL_Constructor -- Constructors and pattern synonyms - -- E.g. in K { f1 = True }, if K is not in scope, - -- suggest only constructors - | WL_RecField -- Record fields - -- E.g. in K { f1 = True, f2 = False }, if f2 is not in - -- scope, suggest only constructor fields - | WL_None -- No suggestions - -- WS_None is used for rebindable syntax, where there - -- is no point in suggesting alternative spellings - deriving Eq - data WhereLooking = WL_Anywhere -- Any binding | WL_Global -- Any top-level binding (local or imported) | WL_LocalTop -- Any top-level binding in this module @@ -112,11 +106,8 @@ mkUnboundGRERdr :: RdrName -> GlobalRdrElt mkUnboundGRERdr rdr = mkLocalGRE UnboundGRE NoParent $ mkUnboundNameRdr rdr -reportUnboundName' :: WhatLooking -> RdrName -> RnM Name -reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr - -reportUnboundName :: RdrName -> RnM Name -reportUnboundName = reportUnboundName' WL_Anything +reportUnboundName :: WhatLooking -> RdrName -> RnM Name +reportUnboundName what_look rdr = unboundName (LF what_look WL_Anywhere) rdr unboundName :: LookingFor -> RdrName -> RnM Name unboundName lf rdr = unboundNameX lf rdr [] @@ -140,17 +131,23 @@ = do { dflags <- getDynFlags ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags ; if not show_helpful_errors - then addErr $ make_error [] hints + then addErr =<< make_error [] hints else do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv ; impInfo <- getImports ; currmod <- getModule - ; hpt <- getHpt + ; ic <- hsc_IC <$> getTopEnv ; let (imp_errs, suggs) = unknownNameSuggestions_ looking_for - dflags hpt currmod global_env local_env impInfo + dflags ic currmod global_env local_env impInfo rdr_name - ; addErr $ + ; traceTc "unboundNameOrTermInType" $ + vcat [ text "rdr_name:" <+> ppr rdr_name + , text "what_looking:" <+> text (show $ lf_which looking_for) + , text "imp_errs:" <+> ppr imp_errs + , text "suggs:" <+> ppr suggs + ] + ; addErr =<< make_error imp_errs (hints ++ suggs) } ; return (mkUnboundNameRdr rdr_name) } where @@ -161,10 +158,28 @@ err = notInScopeErr (lf_where looking_for) name_to_search - make_error imp_errs hints = case if_term_in_type of - TermInTypes demoted_name -> TcRnTermNameInType demoted_name hints - _ -> TcRnNotInScope err name_to_search imp_errs hints + make_error imp_errs hints = + case if_term_in_type of + TermInTypes demoted_name -> + unknownNameSuggestionsMessage (TcRnTermNameInType demoted_name) + [] -- no import errors + hints + _ -> unknownNameSuggestionsMessage (TcRnNotInScope err name_to_search) + imp_errs hints +unknownNameSuggestionsMessage :: TcRnMessage -> [ImportError] -> [GhcHint] -> RnM TcRnMessage +unknownNameSuggestionsMessage msg imp_errs hints + = do { unit_state <- hsc_units <$> getTopEnv + ; hfdc <- getHoleFitDispConfig + ; let supp = case NE.nonEmpty imp_errs of + Nothing -> Nothing + Just ne_imp_errs -> + (Just (hfdc, [SupplementaryImportErrors ne_imp_errs])) + ; return $ + TcRnMessageWithInfo unit_state $ + mkDetailedMessage (ErrInfo [] supp hints) msg + } + notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError notInScopeErr where_look rdr_name | Just name <- isExact_maybe rdr_name @@ -178,17 +193,17 @@ unknownNameSuggestions :: LocalRdrEnv -> WhatLooking -> RdrName -> RnM ([ImportError], [GhcHint]) unknownNameSuggestions lcl_env what_look tried_rdr_name = do { dflags <- getDynFlags - ; hpt <- getHpt ; rdr_env <- getGlobalRdrEnv ; imp_info <- getImports ; curr_mod <- getModule + ; interactive_context <- hsc_IC <$> getTopEnv ; return $ unknownNameSuggestions_ (LF what_look WL_Anywhere) - dflags hpt curr_mod rdr_env lcl_env imp_info tried_rdr_name } + dflags interactive_context curr_mod rdr_env lcl_env imp_info tried_rdr_name } -unknownNameSuggestions_ :: LookingFor -> DynFlags - -> HomePackageTable -> Module +unknownNameSuggestions_ :: LookingFor -> DynFlags -> InteractiveContext + -> Module -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails -> RdrName -> ([ImportError], [GhcHint]) unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env @@ -200,7 +215,7 @@ , map (ImportSuggestion $ rdrNameOcc tried_rdr_name) imp_suggs , extensionSuggestions tried_rdr_name , fieldSelectorSuggestions global_env tried_rdr_name ] - (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name + (imp_errs, imp_suggs) = importSuggestions looking_for hpt curr_mod imports tried_rdr_name if_ne :: (NonEmpty a -> b) -> [a] -> [b] if_ne _ [] = [] @@ -233,12 +248,11 @@ tried_occ = rdrNameOcc tried_rdr_name tried_is_sym = isSymOcc tried_occ - tried_ns = occNameSpace tried_occ tried_is_qual = isQual tried_rdr_name - correct_name_space occ = - (nameSpacesRelated dflags what_look tried_ns (occNameSpace occ)) - && isSymOcc occ == tried_is_sym + is_relevant sugg_occ = + suggestionIsRelevant dflags what_look sugg_occ + && isSymOcc sugg_occ == tried_is_sym -- Treat operator and non-operators as non-matching -- This heuristic avoids things like -- Not in scope 'f'; perhaps you meant '+' (from Prelude) @@ -254,7 +268,8 @@ | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) | name <- localRdrEnvElts env , let occ = nameOccName name - , correct_name_space occ] + , is_relevant occ + ] global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)] global_possibilities global_env @@ -262,7 +277,7 @@ | gre <- globalRdrEnvElts global_env , isGreOk looking_for gre , let occ = greOccName gre - , correct_name_space occ + , is_relevant occ , (mod, how) <- qualsInScope gre , let rdr_qual = mkRdrQual mod occ ] @@ -271,7 +286,7 @@ , isGreOk looking_for gre , let occ = greOccName gre rdr_unqual = mkRdrUnqual occ - , correct_name_space occ + , is_relevant occ , sim <- case (unquals_in_scope gre, quals_only gre) of (how:_, _) -> [ SimilarRdrName rdr_unqual (Just how) ] ([], pr:_) -> [ pr ] -- See Note [Only-quals] @@ -307,21 +322,19 @@ -- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope. importSuggestions :: LookingFor - -> GlobalRdrEnv - -> HomePackageTable -> Module + -> InteractiveContext -> Module -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion]) -importSuggestions looking_for global_env hpt currMod imports rdr_name +importSuggestions looking_for ic currMod imports rdr_name | WL_LocalOnly <- lf_where looking_for = ([], []) | WL_LocalTop <- lf_where looking_for = ([], []) | not (isQual rdr_name || isUnqual rdr_name) = ([], []) - | null interesting_imports - , Just name <- mod_name + | Just name <- mod_name , show_not_imported_line name = ([MissingModule name], []) | is_qualified , null helpful_imports , (mod : mods) <- map fst interesting_imports - = ([ModulesDoNotExport (mod :| mods) occ_name], []) + = ([ModulesDoNotExport (mod :| mods) (lf_which looking_for) occ_name], []) | mod : mods <- helpful_imports_non_hiding = ([], [CouldImportFrom (mod :| mods)]) | mod : mods <- helpful_imports_hiding @@ -339,10 +352,21 @@ -- 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) ] + -- Choose the imports from the interactive context which might have provided + -- a module. + interactive_imports = + filter pick_interactive (ic_imports ic) + + pick_interactive :: InteractiveImport -> Bool + pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True + | mod_name == fmap unLoc (ideclAs d) = True + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True + pick_interactive _ = False + -- We want to keep only one for each original module; preferably one with an -- explicit import list (for no particularly good reason) pick :: [ImportedModsVal] -> Maybe ImportedModsVal @@ -368,17 +392,10 @@ -- See Note [When to show/hide the module-not-imported line] show_not_imported_line :: ModuleName -> Bool -- #15611 show_not_imported_line modnam - | modnam `elem` glob_mods = False -- #14225 -- 1 - | moduleName currMod == modnam = False -- 2.1 - | is_last_loaded_mod modnam hpt_uniques = False -- 2.2 + | not (null interactive_imports) = False -- 1 (interactive context) + | not (null interesting_imports) = False -- 1 (normal module import) + | moduleName currMod == modnam = False -- 2 | otherwise = True - where - hpt_uniques = map fst (udfmToList hpt) - is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam) - glob_mods = nub [ mod - | gre <- globalRdrEnvElts global_env - , (mod, _) <- qualsInScope gre - ] extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName @@ -413,41 +430,44 @@ WL_LocalOnly -> False _ -> True --- see Note [Related name spaces] -nameSpacesRelated :: DynFlags -- ^ to find out whether -XDataKinds is enabled - -> WhatLooking -- ^ What kind of name are we looking for - -> NameSpace -- ^ Name space of the original name - -> NameSpace -- ^ Name space of a name that might have been meant +-- | Is it OK to suggest an identifier in some other 'NameSpace', +-- given what we are looking for? +-- +-- See Note [Related name spaces] +suggestionIsRelevant + :: DynFlags -- ^ to find out whether -XDataKinds is enabled + -> WhatLooking -- ^ What kind of name are we looking for? + -> OccName -- ^ The suggestion + -- + -- We only look at the suggestion's 'NameSpace', + -- but passing the whole 'OccName' is convenient + -- for debugging. + -> Bool +suggestionIsRelevant dflags what_looking suggestion = + relevantNameSpace data_kinds what_looking suggestion_ns + where + suggestion_ns = occNameSpace suggestion + data_kinds = xopt LangExt.DataKinds dflags + +-- | Is a 'NameSpace' relevant for what we are looking for? +relevantNameSpace :: Bool -- ^ is @-XDataKinds@ enabled? + -> WhatLooking -- ^ what are we looking for? + -> NameSpace -- ^ is this 'NameSpace' relevant? -> Bool -nameSpacesRelated dflags what_looking ns ns' - | ns == ns' - = True - | otherwise - = or [ other_ns ns' - | (orig_ns, others) <- other_namespaces - , orig_ns ns - , (other_ns, wls) <- others - , what_looking `elem` WL_Anything : wls - ] - where - -- explanation: - -- [(orig_ns, [(other_ns, what_looking_possibilities)])] - -- A particular other_ns is related if the original namespace is orig_ns - -- and what_looking is either WL_Anything or is one of - -- what_looking_possibilities - other_namespaces = - [ (isVarNameSpace , [(isFieldNameSpace , [WL_RecField]) - ,(isDataConNameSpace, [WL_Constructor])]) - , (isDataConNameSpace , [(isVarNameSpace , [WL_RecField])]) - , (isTvNameSpace , (isTcClsNameSpace , [WL_Constructor]) - : promoted_datacons) - , (isTcClsNameSpace , (isTvNameSpace , []) - : promoted_datacons) - ] - -- If -XDataKinds is enabled, the data constructor name space is also - -- related to the type-level name spaces - data_kinds = xopt LangExt.DataKinds dflags - promoted_datacons = [(isDataConNameSpace, [WL_Constructor]) | data_kinds] +relevantNameSpace data_kinds = \case + WL_Anything -> const True + WL_TyCon -> isTcClsNameSpace + WL_TyCon_or_TermVar -> isTcClsNameSpace <||> isTermVarOrFieldNameSpace + WL_TyVar -> isTvNameSpace + WL_Constructor -> isTcClsNameSpace <||> isDataConNameSpace + WL_ConLike -> isDataConNameSpace + WL_RecField -> isFieldNameSpace + WL_Term -> isValNameSpace + WL_TermVariable -> isTermVarOrFieldNameSpace + WL_Type -> if data_kinds + then not . isTermVarOrFieldNameSpace + else not . isValNameSpace + WL_None -> const False {- Note [Related name spaces] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -477,13 +497,8 @@ Module X does not export Y No module named ‘X’ is imported: there are 2 cases, where we hide the last "no module is imported" line: -1. If the module X has been imported. -2. If the module X is the current module. There are 2 subcases: - 2.1 If the unknown module name is in a input source file, - then we can use the getModule function to get the current module name. - (See test T15611a) - 2.2 If the unknown module name has been entered by the user in GHCi, - then the getModule function returns something like "interactive:Ghci1", - and we have to check the current module in the last added entry of - the HomePackageTable. (See test T15611b) +1. If the module X has been imported (normally or via interactive context). +2. It is the current module we are trying to compile + then we can use the getModule function to get the current module name. + (See test T15611a) -} diff --git a/GHC/Rename/Utils.hs b/GHC/Rename/Utils.hs --- a/GHC/Rename/Utils.hs +++ b/GHC/Rename/Utils.hs @@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {- @@ -15,15 +17,18 @@ addFvRn, mapFvRn, mapMaybeFvRn, warnUnusedMatches, warnUnusedTypePatterns, warnUnusedTopBinds, warnUnusedLocalBinds, - warnForallIdentifier, + DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp, - genAppType, + wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, + genLHsApp, genAppType, genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, genSimpleFunBind, genFunBind, + genHsLamDoExp, genHsCaseAltDoExp, genSimpleMatch, genHsLet, + mkRnSyntaxExpr, + newLocalBndrRn, newLocalBndrsRn, bindLocalNames, bindLocalNamesFV, delLocalNames, @@ -31,15 +36,13 @@ addNameClashErrRn, mkNameClashErr, checkInferredVars, - noNestedForallsContextsErr, addNoNestedForallsContextsErr, - - isIrrefutableHsPatRn + noNestedForallsContextsErr, addNoNestedForallsContextsErr ) where -import GHC.Prelude hiding (unzip) +import GHC.Prelude import GHC.Core.Type import GHC.Hs @@ -56,17 +59,24 @@ import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Unit.Module.ModIface +import GHC.Utils.Panic import GHC.Types.Basic import GHC.Data.List.SetOps ( removeDupsOn ) import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.DynFlags import GHC.Data.FastString +import GHC.Data.Bag ( mapBagM, headMaybe ) import Control.Monad import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) +import GHC.Unit.Module +import GHC.Unit.Module.Warnings ( WarningTxt(..) ) +import GHC.Iface.Load import qualified GHC.LanguageExtensions as LangExt -import qualified Data.List as List import qualified Data.List.NonEmpty as NE +import Data.Foldable (for_) +import Data.Maybe {- @@ -96,7 +106,7 @@ bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names = updLclCtxt $ \ lcl_env -> - let th_level = thLevel (tcl_th_ctxt lcl_env) + let th_level = thLevelIndex (tcl_th_ctxt lcl_env) th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) [ (n, (NotTopLevel, th_level)) | n <- names ] rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names @@ -335,11 +345,6 @@ (ys, fvs_s) -> return (ys, foldl' (flip plusFV) emptyFVs fvs_s) {-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-} -unzip :: Functor f => f (a, b) -> (f a, f b) -unzip = \ xs -> (fmap fst xs, fmap snd xs) -{-# NOINLINE [1] unzip #-} -{-# RULES "unzip/List" unzip = List.unzip #-} - mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } @@ -362,7 +367,7 @@ _ -> False -- Don't warn about unused bindings with parents in -- .hs-boot files, as you are sometimes required to give - -- unused bindings (trac #3449). + -- unused bindings (#3449). -- HOWEVER, in a signature file, you are never obligated to put a -- definition in the main text. Thus, if you define something -- and forget to export it, we really DO want to warn. @@ -375,14 +380,17 @@ -- -Wredundant-record-wildcards checkUnusedRecordWildcard :: SrcSpan -> FreeVars - -> Maybe [Name] + -> Maybe [ImplicitFieldBinders] -> RnM () checkUnusedRecordWildcard _ _ Nothing = return () -checkUnusedRecordWildcard loc _ (Just []) = - -- Add a new warning if the .. pattern binds no variables - setSrcSpan loc $ warnRedundantRecordWildcard -checkUnusedRecordWildcard loc fvs (Just dotdot_names) = - setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs +checkUnusedRecordWildcard loc fvs (Just dotdot_fields_binders) + = setSrcSpan loc $ case concatMap implFlBndr_binders dotdot_fields_binders of + -- Add a new warning if the .. pattern binds no variables + [] -> warnRedundantRecordWildcard + dotdot_names + -> do + warnUnusedRecordWildcard dotdot_names fvs + deprecateUsedRecordWildcard dotdot_fields_binders fvs -- | Produce a warning when the `..` pattern binds no new @@ -415,6 +423,33 @@ traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) warnIf (null used) (TcRnUnusedRecordWildcard ns) +-- | Emit a deprecation message whenever one of the implicit record wild +-- card field binders was used in FreeVars. +-- +-- @ +-- module A where +-- data P = P { x :: Int, y :: Int } +-- {-# DEPRECATED x, y "depr msg" #-} +-- +-- module B where +-- import A +-- foo (P{..}) = x +-- @ +-- +-- Even though both `x` and `y` have deprecations, only `x` +-- will be deprecated since only its implicit variable is used in the RHS. +deprecateUsedRecordWildcard :: [ImplicitFieldBinders] + -> FreeVars -> RnM () +deprecateUsedRecordWildcard dotdot_fields_binders fvs + = mapM_ depr_field_binders dotdot_fields_binders + where + depr_field_binders (ImplicitFieldBinders {..}) + = when (mkFVs implFlBndr_binders `intersectsFVs` fvs) $ do + env <- getGlobalRdrEnv + let gre = fromJust $ lookupGRE_Name env implFlBndr_field + -- Must be in the env since it was instantiated + -- in the implicit binders + warnIfDeprecated AllDeprecationWarnings [gre] warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns @@ -427,13 +462,109 @@ check_unused prov bound_names used_names = warnUnused prov (filterOut (`elemNameSet` used_names) bound_names) -warnForallIdentifier :: LocatedN RdrName -> RnM () -warnForallIdentifier (L l rdr_name@(Unqual occ)) - | isKw (fsLit "forall") || isKw (fsLit "∀") - = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name) - where isKw = (occNameFS occ ==) -warnForallIdentifier _ = return () +{- +************************************************************************ +* * +\subsection{Custom deprecations utility functions} +* * +************************************************************************ +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see #5867 and #4879) + +* We do not report deprecations for locally-defined names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* We also report deprecations at export sites, but only for names + deprecated with export deprecations (since those are not transitive as opposed + to regular name deprecations and are only reported at the importing module) + +* addUsedGREs: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' +-} + +-- | Whether to report deprecation warnings when registering a used GRE +-- +-- There is no option to only emit declaration warnings since everywhere +-- we emit the declaration warnings we also emit export warnings +-- (See Note [Handling of deprecations] for details) +data DeprecationWarnings + = NoDeprecationWarnings + | ExportDeprecationWarnings + | AllDeprecationWarnings + +warnIfDeprecated :: DeprecationWarnings -> [GlobalRdrElt] -> RnM () +warnIfDeprecated NoDeprecationWarnings _ = return () +warnIfDeprecated opt gres = do + this_mod <- getModule + let external_gres + = filterOut (nameIsLocalOrFrom this_mod . greName) gres + mapM_ (\gre -> warnIfExportDeprecated gre >> maybeWarnDeclDepr gre) external_gres + where + maybeWarnDeclDepr = case opt of + ExportDeprecationWarnings -> const $ return () + AllDeprecationWarnings -> warnIfDeclDeprecated + +warnIfDeclDeprecated :: GlobalRdrElt -> RnM () +warnIfDeclDeprecated gre@(GRE { gre_imp = iss }) + | Just imp_spec <- headMaybe iss + = do { dflags <- getDynFlags + ; when (wopt_any_custom dflags) $ + -- See Note [Handling of deprecations] + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeclDeprec iface gre of + Just deprText -> addDiagnostic $ + TcRnPragmaWarning + PragmaWarningName + { pwarn_occname = occ + , pwarn_impmod = importSpecModule imp_spec + , pwarn_declmod = definedMod } + deprText + Nothing -> return () } } + | otherwise + = return () + where + occ = greOccName gre + name = greName gre + definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" + +lookupImpDeclDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) +lookupImpDeclDeprec iface gre + -- Bleat if the thing, or its parent, is warn'd + = mi_decl_warn_fn iface (greOccName gre) `mplus` + case greParent gre of + ParentIs p -> mi_decl_warn_fn iface (nameOccName p) + NoParent -> Nothing + +warnIfExportDeprecated :: GlobalRdrElt -> RnM () +warnIfExportDeprecated gre@(GRE { gre_imp = iss }) + = do { mod_warn_mbs <- mapBagM process_import_spec iss + ; for_ (sequence mod_warn_mbs) $ mapM + $ \(importing_mod, warn_txt) -> addDiagnostic $ + TcRnPragmaWarning + PragmaWarningExport + { pwarn_occname = occ + , pwarn_impmod = importing_mod } + warn_txt } + where + occ = greOccName gre + name = greName gre + doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" + process_import_spec :: ImportSpec -> RnM (Maybe (ModuleName, WarningTxt GhcRn)) + process_import_spec is = do + let mod = is_mod $ is_decl is + iface <- loadInterfaceForModule doc mod + let mb_warn_txt = mi_export_warn_fn iface name + return $ (moduleName mod, ) <$> mb_warn_txt + ------------------------- -- Helpers warnUnusedGREs :: [GlobalRdrElt] -> RnM () @@ -541,7 +672,7 @@ badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage -typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled (TypeApplication k what) +typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled k what badFieldConErr :: Name -> FieldLabelString -> TcRnMessage badFieldConErr con field = TcRnInvalidRecordField con field @@ -565,21 +696,37 @@ {- ********************************************************************* * * - Generating code for HsExpanded + Generating code for ExpandedThingRn See Note [Handling overloaded and rebindable constructs] * * ********************************************************************* -} -wrapGenSpan :: a -> LocatedAn an a +wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- Wrap something in a "generatedSrcSpan" --- See Note [Rebindable syntax and HsExpansion] +-- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x +-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the +-- renamer). +mkRnSyntaxExpr :: Name -> SyntaxExprRn +mkRnSyntaxExpr = SyntaxExprRn . genHsVar + +genHsVar :: Name -> HsExpr GhcRn +genHsVar n = mkHsVar (wrapGenSpan n) + genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn genHsApps fun args = foldl genHsApp (genHsVar fun) args +-- | Keeps the span given to the 'Name' for the application head only +genHsApps' :: LocatedN Name -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsApps' (L _ fun) [] = genHsVar fun +genHsApps' (L loc fun) (arg:args) = foldl genHsApp (unLoc $ mkHsApp (L (l2l loc) $ genHsVar fun) arg) args + +genHsExpApps :: HsExpr GhcRn -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsExpApps fun arg = foldl genHsApp fun arg + genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn -genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg +genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn genLHsApp fun arg = wrapGenSpan (genHsApp fun arg) @@ -587,16 +734,13 @@ genLHsVar :: Name -> LHsExpr GhcRn genLHsVar nm = wrapGenSpan $ genHsVar nm -genHsVar :: Name -> HsExpr GhcRn -genHsVar nm = HsVar noExtField $ wrapGenSpan nm - genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn -genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty)) +genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) (mkEmptyWildCardBndrs (wrapGenSpan ty)) -genLHsLit :: HsLit GhcRn -> LocatedAn an (HsExpr GhcRn) -genLHsLit = wrapGenSpan . HsLit noAnn +genLHsLit :: (NoAnn an) => HsLit GhcRn -> LocatedAn an (HsExpr GhcRn) +genLHsLit = wrapGenSpan . HsLit noExtField -genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) +genHsIntegralLit :: (NoAnn an) => IntegralLit -> LocatedAn an (HsExpr GhcRn) genHsIntegralLit = genLHsLit . HsInt noExtField genHsTyLit :: FastString -> HsType GhcRn @@ -606,8 +750,8 @@ -- The pattern (C p1 .. pn) genSimpleConPat con pats = wrapGenSpan $ ConPat { pat_con_ext = noExtField - , pat_con = wrapGenSpan con - , pat_args = PrefixCon [] pats } + , pat_con = wrapGenSpan $ noUserRdr con + , pat_args = PrefixCon pats } genVarPat :: Name -> LPat GhcRn genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n) @@ -618,21 +762,51 @@ genSimpleFunBind :: Name -> [LPat GhcRn] -> LHsExpr GhcRn -> LHsBind GhcRn genSimpleFunBind fun pats expr - = L gen $ genFunBind (L gen fun) - [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr + = noLocA $ genFunBind (noLocA fun) + [mkMatch (mkPrefixFunRhs (noLocA fun) noAnn) (noLocA pats) expr emptyLocalBinds] - where - gen = noAnnSrcSpan generatedSrcSpan genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn genFunBind fn ms = FunBind { fun_id = fn - , fun_matches = mkMatchGroup (Generated SkipPmc) (wrapGenSpan ms) + , fun_matches = mkMatchGroup (Generated OtherExpansion SkipPmc) (wrapGenSpan ms) , fun_ext = emptyNameSet } -isIrrefutableHsPatRn :: forall p. (OutputableBndrId p) - => DynFlags -> LPat (GhcPass p) -> Bool -isIrrefutableHsPatRn dflags = - isIrrefutableHsPat (xopt LangExt.Strict dflags) +genHsLet :: HsLocalBindsLR GhcRn GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn +genHsLet bindings body = HsLet noExtField bindings body + +genHsLamDoExp :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) + => HsDoFlavour + -> [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> LHsExpr (GhcPass p) +genHsLamDoExp doFlav pats body = mkHsPar (wrapGenSpan $ HsLam noAnn LamSingle matches) + where + matches = mkMatchGroup (doExpansionOrigin doFlav) + (wrapGenSpan [genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) pats' body]) + pats' = map (parenthesizePat appPrec) pats + + +genHsCaseAltDoExp :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnnCO, + Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA) + => HsDoFlavour -> LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) +genHsCaseAltDoExp doFlav pat expr + = genSimpleMatch (StmtCtxt (HsDoStmt doFlav)) [pat] expr + + +genSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ SrcSpanAnnA, + Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) + ~ EpAnnCO) + => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) + -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) + -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) +genSimpleMatch ctxt pats rhs + = wrapGenSpan $ + Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = noLocA pats + , m_grhss = unguardedGRHSs generatedSrcSpan rhs noAnn } diff --git a/GHC/Runtime/Context.hs b/GHC/Runtime/Context.hs --- a/GHC/Runtime/Context.hs +++ b/GHC/Runtime/Context.hs @@ -31,6 +31,7 @@ import GHC.Core.InstEnv import GHC.Core.Type +import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name @@ -114,6 +115,51 @@ modules. +Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'InteractiveContext' is used to store 'DynFlags', 'Plugins' and similar +information about the so-called interactive "home unit". We are using +quotes here, since, originally, GHC wasn't aware of more than one 'HomeUnitEnv's. +So the 'InteractiveContext' was a hack/solution to have 'DynFlags' and 'Plugins' +independent of the 'DynFlags' and 'Plugins' stored in 'HscEnv'. +Nowadays, GHC has support for multiple home units via the 'HomeUnitGraph', thus, +this part of the 'InteractiveContext' is strictly speaking redundant, as we +can simply manage one 'HomeUnitEnv' for the 'DynFlags' and 'Plugins' that are +currently stored in the 'InteractiveContext'. + +As a matter of fact, that's exactly what we do nowadays. +That means, we can also lift other restrictions in the future, for example +allowing @:seti@ commands to modify the package-flags, since we now have a +separate 'UnitState' for the interactive session. +However, we did not rip out 'ic_dflags' and 'ic_plugins', yet, as it makes +it easier to access them for functions that want to use the interactive 'DynFlags', +such as 'runInteractiveHsc' and 'mkInteractiveHscEnv', without having to look that +information up in the 'HomeUnitGraph'. +It is reasonable to change this in the future, and remove 'ic_dflags' and 'ic_plugins'. + +We keep 'ic_dflags' and 'ic_plugins' around, but we also store a 'HomeUnitEnv' +for the 'DynFlags' and 'Plugins' of the interactive session. + +It is important to keep the 'DynFlags' in these two places consistent. + +In other words, whenever you update the 'DynFlags' of the 'interactiveGhciUnitId' +in the 'HscEnv', then you also need to update the 'DynFlags' of the +'InteractiveContext'. +The easiest way to update them is via 'setInteractiveDynFlags'. +However, careful, footgun! It is very easy to call 'setInteractiveDynFlags' +and forget to call 'normaliseInteractiveDynFlags' on the 'DynFlags' in the +'HscEnv'! This is important, because you may, accidentally, have enabled +Language Extensions that are not supported in the interactive ghc session, +which we do not want. + +To summarise, the 'ic_dflags' and 'ic_plugins' are currently used to +conveniently cache them for easy access. +The 'ic_dflags' must be identical to the 'DynFlags' stored in the 'HscEnv' +for the 'HomeUnitEnv' identified by 'interactiveGhciUnitId'. + +See Note [Multiple Home Units aware GHCi] for the design and rationale for +the current 'interactiveGhciUnitId'. + Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Ids bound by previous Stmts in GHCi are currently @@ -269,8 +315,8 @@ ic_fix_env :: FixityEnv, -- ^ Fixities declared in let statements - ic_default :: Maybe [Type], - -- ^ The current default types, set by a 'default' declaration + ic_default :: DefaultEnv, + -- ^ The current default classes and types, set by 'default' declarations ic_resume :: [Resume], -- ^ The stack of breakpoint contexts @@ -295,7 +341,7 @@ -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule ModuleName + | IIModule Module -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. @@ -319,7 +365,7 @@ ic_fix_env = emptyNameEnv, ic_monad = ioTyConName, -- IO monad by default ic_int_print = printName, -- System.IO.print by default - ic_default = Nothing, + ic_default = emptyDefaultEnv, ic_resume = [], ic_cwd = Nothing, ic_plugins = emptyPlugins @@ -362,7 +408,7 @@ extendInteractiveContext :: InteractiveContext -> [TyThing] -> InstEnv -> [FamInst] - -> Maybe [Type] + -> DefaultEnv -> FixityEnv -> InteractiveContext extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env diff --git a/GHC/Runtime/Debugger.hs b/GHC/Runtime/Debugger.hs --- a/GHC/Runtime/Debugger.hs +++ b/GHC/Runtime/Debugger.hs @@ -16,6 +16,9 @@ import GHC +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Monad @@ -30,6 +33,7 @@ import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Core.Type +import GHC.Core.TyCo.Tidy( tidyOpenType ) import GHC.Utils.Outputable import GHC.Utils.Error @@ -48,7 +52,7 @@ import Control.Monad import Control.Monad.Catch as MC -import Data.List ( (\\), partition ) +import Data.List ( partition ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.IORef @@ -138,7 +142,7 @@ -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv -- forgets the ordering immediately by creating an env , getUniqSet $ env_tvs `intersectVarSet` my_tvs) - return $ mapTermType (snd . tidyOpenType tidyEnv) t + return $ mapTermType (tidyOpenType tidyEnv) t -- | Give names, and bind in the interactive environment, to all the suspensions -- included (inductively) in a term @@ -149,7 +153,7 @@ let ictxt = hsc_IC hsc_env prefix = "_t" alreadyUsedNames = map (occNameString . nameOccName . getName) inScope - availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames + availNames = (Inf.filter (`notElem` alreadyUsedNames) . fmap ((prefix++) . show)) (Inf.enumFrom (1::Int)) availNames_var <- liftIO $ newIORef availNames (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t let (names, tys, fhvs) = unzip3 stuff @@ -163,7 +167,7 @@ where -- Processing suspensions. Give names and collect info - nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] + nameSuspensionsAndGetInfos :: HscEnv -> IORef (Infinite String) -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) nameSuspensionsAndGetInfos hsc_env freeNames = TermFold { @@ -181,10 +185,10 @@ (term, names) <- t return (RefWrap ty term, names) } - doSuspension hsc_env freeNames ct ty hval _name = do - name <- atomicModifyIORef' freeNames (\x->(tail x, head x)) + doSuspension hsc_env freeNames ct ty hval _name ipe = do + name <- atomicModifyIORef' freeNames (\(Inf x xs)->(xs, x)) n <- newGrimName hsc_env name - return (Suspension ct ty hval (Just n), [(n,ty,hval)]) + return (Suspension ct ty hval (Just n) ipe, [(n,ty,hval)]) -- A custom Term printer to enable the use of Show instances diff --git a/GHC/Runtime/Debugger/Breakpoints.hs b/GHC/Runtime/Debugger/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Debugger/Breakpoints.hs @@ -0,0 +1,298 @@ + +-- | GHC API debugger module for finding and setting breakpoints. +-- +-- This module is user facing and is at least used by `GHCi` and `ghc-debugger` +-- to find and set breakpoints. +module GHC.Runtime.Debugger.Breakpoints where + +import GHC.Prelude + +import Control.Monad.Catch +import Control.Monad +import Data.Array +import Data.Function +import Data.List +import Data.Maybe +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as S + +import GHC.HsToCore.Breakpoints +import GHC.ByteCode.Breakpoints +import GHC.Driver.Env +import GHC.Driver.Monad +import GHC.Driver.Session.Inspect +import GHC.Runtime.Eval +import GHC.Runtime.Eval.Utils +import GHC.Types.Name +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Unit.Module.Graph +import GHC.Unit.Module.ModSummary +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict +import qualified Data.IntMap.Strict as IntMap +import qualified GHC.Unit.Home.Graph as HUG +import qualified GHC.Unit.Home.PackageTable as HPT + +-------------------------------------------------------------------------------- +-- Finding Module breakpoints +-------------------------------------------------------------------------------- + +-- | Find a breakpoint given a Module's 'TickArray' and the line number. +-- +-- When a line number is specified, the current policy for choosing +-- the best breakpoint is this: +-- - the leftmost complete subexpression on the specified line, or +-- - the leftmost subexpression starting on the specified line, or +-- - the rightmost subexpression enclosing the specified line +-- +findBreakByLine :: Int {-^ Line number -} -> TickArray -> Maybe (BreakTickIndex, RealSrcSpan) +findBreakByLine line arr + | not (inRange (bounds arr) line) = Nothing + | otherwise = + listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd) comp) `mplus` + listToMaybe (sortBy (compare `on` snd) incomp) `mplus` + listToMaybe (sortBy (flip compare `on` snd) ticks) + where + ticks = arr ! line + + starts_here = [ (ix,pan) | (ix, pan) <- ticks, + srcSpanStartLine pan == line ] + + (comp, incomp) = partition ends_here starts_here + where ends_here (_,pan) = srcSpanEndLine pan == line + +-- | Find a breakpoint in the 'TickArray' of a module, given a line number and a column coordinate. +findBreakByCoord :: (Int, Int) -> TickArray -> Maybe (BreakTickIndex, RealSrcSpan) +findBreakByCoord (line, col) arr + | not (inRange (bounds arr) line) = Nothing + | otherwise = + listToMaybe (sortBy (flip compare `on` snd) contains ++ + sortBy (compare `on` snd) after_here) + where + ticks = arr ! line + + -- the ticks that span this coordinate + contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col) ] + + after_here = [ tick | tick@(_,pan) <- ticks, + srcSpanStartLine pan == line, + srcSpanStartCol pan >= col ] + +leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering +leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) realSrcSpanEnd + +-- | Returns the span of the largest tick containing the srcspan given +enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan +enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan ticks (RealSrcSpan src _) = + assert (inRange (bounds ticks) line) $ + Data.List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans + where + line = srcSpanStartLine src + enclosing_spans = [ pan | (_,pan) <- ticks ! line + , realSrcSpanEnd pan >= realSrcSpanEnd src] + +-------------------------------------------------------------------------------- +-- Finding Function breakpoints +-------------------------------------------------------------------------------- + +-- | Process and validate the user string of form @[Module.]function@ into the +-- relevant module information and function name. +-- +-- Validation guarantees +-- 1. The module exists +-- 2. The identifier is in an interpreted module +-- 3. The identifier has a breakpoint entry in the module's 'ModBreaks' +-- +-- Returns either an error SDoc or the 'Module' and 'ModuleInfo' for the relevant module +-- paired with the function name +-- +-- See also Note [Setting Breakpoints by Id] +resolveFunctionBreakpoint :: GhcMonad m => String -> m (Either SDoc (Module, ModuleInfo, String)) +resolveFunctionBreakpoint inp = do + let (mod_str, top_level, fun_str) = splitIdent inp + mod_top_lvl = combineModIdent mod_str top_level + mb_mod <- catch (lookupModuleInscope mod_top_lvl) + (\(_ :: SomeException) -> lookupModuleInGraph mod_str) + -- If the top-level name is not in scope, `lookupModuleInscope` will + -- throw an exception, then lookup the module name in the module graph. + mb_err_msg <- validateBP mod_str fun_str mb_mod + case mb_err_msg of + Just err_msg -> pure . Left $ + text "Cannot set breakpoint on" <+> quotes (text inp) + <> text ":" <+> err_msg + Nothing -> do + -- No errors found, go and return the module info + let mod = fromMaybe (panic "resolveFunctionBreakpoint") mb_mod + mb_mod_info <- getModuleInfo mod + case mb_mod_info of + Nothing -> pure . Left $ + text "Could not find ModuleInfo of " <> ppr mod + Just mod_info -> pure $ Right (mod, mod_info, fun_str) + where + -- Try to lookup the module for an identifier that is in scope. + -- `parseName` throws an exception, if the identifier is not in scope + lookupModuleInscope :: GhcMonad m => String -> m (Maybe Module) + lookupModuleInscope mod_top_lvl = do + names <- parseName mod_top_lvl + pure $ Just $ NE.head $ nameModule <$> names + + -- Lookup the Module of a module name in the module graph + lookupModuleInGraph :: GhcMonad m => String -> m (Maybe Module) + lookupModuleInGraph mod_str = do + graph <- getModuleGraph + let hmods = ms_mod <$> mgModSummaries graph + pure $ find ((== mod_str) . moduleNameString . moduleName) hmods + + -- Check validity of an identifier to set a breakpoint: + -- 1. The module of the identifier must exist + -- 2. the identifier must be in an interpreted module + -- 3. the ModBreaks array for module `mod` must have an entry + -- for the function + validateBP :: GhcMonad m => String -> String -> Maybe Module + -> m (Maybe SDoc) + validateBP mod_str fun_str Nothing = pure $ Just $ quotes (text + (combineModIdent mod_str (takeWhile (/= '.') fun_str))) + <+> text "not in scope" + validateBP _ "" (Just _) = pure $ Just $ text "Function name is missing" + validateBP _ fun_str (Just modl) = do + isInterpr <- moduleIsInterpreted modl + mb_err_msg <- case isInterpr of + False -> pure $ Just $ text "Module" <+> quotes (ppr modl) <+> text "is not interpreted" + True -> do + mb_modbreaks <- getModBreak modl + let found = case mb_modbreaks of + Nothing -> False + Just mb -> fun_str `elem` (intercalate "." <$> elems (modBreaks_decls mb)) + if found + then pure Nothing + else pure $ Just $ text "No breakpoint found for" <+> quotes (text fun_str) + <+> text "in module" <+> quotes (ppr modl) + pure mb_err_msg + +-- | The aim of this function is to find the breakpoints for all the RHSs of +-- the equations corresponding to a binding. So we find all breakpoints +-- for +-- (a) this binder only (it maybe a top-level or a nested declaration) +-- (b) that do not have an enclosing breakpoint +findBreakForBind :: String {-^ Name of bind to break at -} -> ModBreaks -> [(BreakTickIndex, RealSrcSpan)] +findBreakForBind str_name modbreaks = filter (not . enclosed) ticks + where + ticks = [ (index, span) + | (index, decls) <- assocs (modBreaks_decls modbreaks), + str_name == intercalate "." decls, + RealSrcSpan span _ <- [modBreaks_locs modbreaks ! index] ] + enclosed (_,sp0) = any subspan ticks + where subspan (_,sp) = sp /= sp0 && + realSrcSpanStart sp <= realSrcSpanStart sp0 && + realSrcSpanEnd sp0 <= realSrcSpanEnd sp + +-------------------------------------------------------------------------------- +-- Mapping line numbers to ticks +-------------------------------------------------------------------------------- + +-- | Maps line numbers to the breakpoint ticks existing at that line for a module. +type TickArray = Array Int [(BreakTickIndex,RealSrcSpan)] + +-- | Construct the 'TickArray' for the given module. +makeModuleLineMap :: GhcMonad m => Module -> m (Maybe TickArray) +makeModuleLineMap m = do + mi <- getModuleInfo m + return $ mkTickArray . assocs . modBreaks_locs . imodBreaks_modBreaks <$> (modInfoModBreaks =<< mi) + where + mkTickArray :: [(BreakTickIndex, SrcSpan)] -> TickArray + mkTickArray ticks + = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,pan)) | (nm,RealSrcSpan pan _) <- ticks, line <- srcSpanLines pan ] + where + max_line = foldr max 0 [ srcSpanEndLine sp | (_, RealSrcSpan sp _) <- ticks ] + srcSpanLines pan = [ srcSpanStartLine pan .. srcSpanEndLine pan ] + +-- | Get the 'ModBreaks' of the given 'Module' when available +getModBreak :: GhcMonad m => Module -> m (Maybe ModBreaks) +getModBreak m = do + mod_info <- fromMaybe (panic "getModBreak") <$> getModuleInfo m + pure $ imodBreaks_modBreaks <$> modInfoModBreaks mod_info + +-------------------------------------------------------------------------------- +-- Mapping source-level BreakpointIds to IBI occurrences +-- (See Note [Breakpoint identifiers]) +-------------------------------------------------------------------------------- + +-- | A source-level breakpoint may have been inlined into many occurrences, now +-- referred by 'InternalBreakpointId'. When a breakpoint is set on a certain +-- source breakpoint, it means all *ocurrences* of that breakpoint across +-- modules should be stopped at -- hence we keep a trie from BreakpointId to +-- the list of internal break ids using it. +-- See also Note [Breakpoint identifiers] +type BreakpointOccurrences = ModuleEnv (IntMap.IntMap [InternalBreakpointId]) + +-- | Lookup all InternalBreakpointIds matching the given BreakpointId +-- Nothing if BreakpointId not in map +lookupBreakpointOccurrences :: BreakpointOccurrences -> BreakpointId -> Maybe [InternalBreakpointId] +lookupBreakpointOccurrences bmp (BreakpointId md tick) = + lookupModuleEnv bmp md >>= IntMap.lookup tick + +-- | Construct a mapping from Source 'BreakpointId's to 'InternalBreakpointId's from the given list of 'ModInfo's +mkBreakpointOccurrences :: forall m. GhcMonad m => m BreakpointOccurrences +mkBreakpointOccurrences = do + hug <- hsc_HUG <$> getSession + liftIO $ foldr go (pure emptyModuleEnv) hug + where + go :: HUG.HomeUnitEnv -> IO BreakpointOccurrences -> IO BreakpointOccurrences + go hue mbmp = do + bmp <- mbmp + ibrkss <- HPT.concatHpt (\hmi -> maybeToList (getModBreaks hmi)) + (HUG.homeUnitEnv_hpt hue) + return $ foldr addBreakToMap bmp ibrkss + + addBreakToMap :: InternalModBreaks -> BreakpointOccurrences -> BreakpointOccurrences + addBreakToMap ibrks bmp0 = do + let imod = modBreaks_module $ imodBreaks_modBreaks ibrks + IntMap.foldrWithKey (\info_ix cgi bmp -> do + let ibi = InternalBreakpointId imod info_ix + case cgb_tick_id cgi of + Right (BreakpointId tick_mod tick_ix) + -> extendModuleEnvWith (IntMap.unionWith (S.<>)) bmp tick_mod (IntMap.singleton tick_ix [ibi]) + Left _ + -- Do not include internal breakpoints in the visible breakpoint + -- occurrences! + -> bmp + ) bmp0 (imodBreaks_breakInfo ibrks) + +-------------------------------------------------------------------------------- +-- Getting current breakpoint information +-------------------------------------------------------------------------------- + +getCurrentBreakSpan :: GhcMonad m => m (Maybe SrcSpan) +getCurrentBreakSpan = do + hug <- hsc_HUG <$> getSession + resumes <- getResumeContext + case resumes of + [] -> return Nothing + (r:_) -> do + let ix = resumeHistoryIx r + if ix == 0 + then return (Just (resumeSpan r)) + else do + let hist = resumeHistory r !! (ix-1) + pan <- liftIO $ getHistorySpan hug hist + return (Just pan) + +getCurrentBreakModule :: GhcMonad m => m (Maybe Module) +getCurrentBreakModule = do + resumes <- getResumeContext + hug <- hsc_HUG <$> getSession + liftIO $ case resumes of + [] -> pure Nothing + (r:_) -> case resumeHistoryIx r of + 0 -> case resumeBreakpointId r of + Nothing -> pure Nothing + Just ibi -> do + brks <- readIModBreaks hug ibi + return $ Just $ getBreakSourceMod ibi brks + ix -> + Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) + diff --git a/GHC/Runtime/Eval.hs b/GHC/Runtime/Eval.hs --- a/GHC/Runtime/Eval.hs +++ b/GHC/Runtime/Eval.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} -- ----------------------------------------------------------------------------- -- @@ -20,11 +18,12 @@ abandon, abandonAll, getResumeContext, getHistorySpan, - getModBreaks, + getModBreaks, readIModBreaks, readIModModBreaks, getHistoryModule, setupBreakpoint, back, forward, setContext, getContext, + mkTopLevEnv, mkTopLevImportedEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -54,6 +53,8 @@ import GHC.Driver.Ppr import GHC.Driver.Config +import GHC.Rename.Names (importsFromIface, gresFromAvails) + import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Heap.Inspect @@ -63,6 +64,7 @@ import GHC.ByteCode.Types import GHC.Linker.Loader as Loader +import GHC.Linker.Types (LinkedBreaks (..)) import GHC.Hs @@ -71,16 +73,19 @@ import GHC.Core.InstEnv import GHC.Core.Predicate import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Tidy( tidyType, tidyOpenTypes ) import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) import qualified GHC.Core.Type as Type import GHC.Iface.Env ( newInteractiveBinder ) +import GHC.Iface.Load ( loadInterfaceForModule ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) +import GHC.Builtin.Names ( toDynName ) +import GHC.Builtin.Types ( pretendNameIsInScope ) import GHC.Data.Maybe import GHC.Data.FastString @@ -107,36 +112,31 @@ import GHC.Types.Unique.Supply import GHC.Types.Unique.DSet import GHC.Types.TyThing -import GHC.Types.BreakInfo import GHC.Types.Unique.Map +import GHC.Types.Avail import GHC.Unit import GHC.Unit.Module.Graph import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModSummary import GHC.Unit.Home.ModInfo -import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) +import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces ) import GHC.Tc.Solver (simplifyWantedsTcM) -import GHC.Tc.Utils.Env (tcGetInstEnvs, lookupGlobal) +import GHC.Tc.Utils.Env (tcGetInstEnvs) import GHC.Tc.Utils.Instantiate (instDFunType) import GHC.Tc.Utils.Monad -import GHC.Tc.Zonk.Env ( ZonkFlexi (SkolemiseFlexi) ) -import GHC.Unit.Env import GHC.IfaceToCore +import GHC.ByteCode.Breakpoints import Control.Monad -import Control.Monad.Catch as MC -import Data.Array import Data.Dynamic -import Data.Either import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.List (find,intercalate) import Data.List.NonEmpty (NonEmpty) -import System.Directory import Unsafe.Coerce ( unsafeCoerce ) +import qualified GHC.Unit.Home.Graph as HUG +import GHCi.BreakArray (BreakArray) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -144,29 +144,29 @@ getResumeContext :: GhcMonad m => m [Resume] getResumeContext = withSession (return . ic_resume . hsc_IC) -mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History -mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi) +mkHistory :: HUG.HomeUnitGraph -> ForeignHValue -> InternalBreakpointId -> IO History +mkHistory hug hval ibi = History hval ibi <$> findEnclosingDecls hug ibi -getHistoryModule :: History -> Module -getHistoryModule = breakInfo_module . historyBreakInfo +getHistoryModule :: HUG.HomeUnitGraph -> History -> IO Module +getHistoryModule hug hist = do + let ibi = historyBreakpointId hist + brks <- readIModBreaks hug ibi + return $ getBreakSourceMod ibi brks -getHistorySpan :: HscEnv -> History -> SrcSpan -getHistorySpan hsc_env History{..} = - let BreakInfo{..} = historyBreakInfo in - case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of - Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number - _ -> panic "getHistorySpan" +getHistorySpan :: HUG.HomeUnitGraph -> History -> IO SrcSpan +getHistorySpan hug hist = do + let ibi = historyBreakpointId hist + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks {- | Finds the enclosing top level function name -} -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecls :: HscEnv -> BreakInfo -> [String] -findEnclosingDecls hsc_env (BreakInfo modl ix) = - let hmi = expectJust "findEnclosingDecls" $ - lookupHugByModule modl (hsc_HUG hsc_env) - mb = getModBreaks hmi - in modBreaks_decls mb ! ix +findEnclosingDecls :: HUG.HomeUnitGraph -> InternalBreakpointId -> IO [String] +findEnclosingDecls hug ibi = do + brks <- readIModBreaks hug ibi + getBreakDecls (readIModModBreaks hug) ibi brks -- | Update fixity environment in the current interactive context. updateFixityEnv :: GhcMonad m => FixityEnv -> m () @@ -230,10 +230,9 @@ updateFixityEnv fix_env status <- - withVirtualCWD $ - liftIO $ do - let eval_opts = initEvalOpts idflags' (isStep execSingleStep) - evalStmt interp eval_opts (execWrap hval) + liftIO $ do + let eval_opts = initEvalOpts idflags' (enableGhcStepMode execSingleStep) + evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_gre_cache ic) @@ -280,38 +279,17 @@ See #11051 for more background and examples. -} -withVirtualCWD :: GhcMonad m => m a -> m a -withVirtualCWD m = do - hsc_env <- getSession - - -- a virtual CWD is only necessary when we're running interpreted code in - -- the same process as the compiler. - case interpInstance <$> hsc_interp hsc_env of - Just (ExternalInterp {}) -> m - _ -> do - let ic = hsc_IC hsc_env - let set_cwd = do - dir <- liftIO $ getCurrentDirectory - case ic_cwd ic of - Just dir -> liftIO $ setCurrentDirectory dir - Nothing -> return () - return dir - - reset_cwd orig_dir = do - virt_dir <- liftIO $ getCurrentDirectory - hsc_env <- getSession - let old_IC = hsc_IC hsc_env - setSession hsc_env{ hsc_IC = old_IC{ ic_cwd = Just virt_dir } } - liftIO $ setCurrentDirectory orig_dir - - MC.bracket set_cwd reset_cwd $ \_ -> m - parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs) parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr emptyHistory :: Int -> BoundedList History emptyHistory size = nilBL size +-- | Turn an 'EvalStatus_' result from interpreting Haskell into a GHCi 'ExecResult'. +-- +-- This function is responsible for resuming execution at an intermediate +-- breakpoint if we don't care about that breakpoint (e.g. if using :steplocal +-- or :stepmodule, rather than :step, we only care about certain breakpoints). handleRunStatus :: GhcMonad m => SingleStep -> String -> ResumeBindings @@ -320,95 +298,115 @@ -> BoundedList History -> m ExecResult -handleRunStatus step expr bindings final_ids status history - | RunAndLogSteps <- step = tracing - | otherwise = not_tracing - where - tracing - | EvalBreak is_exception apStack_ref ix mod_name resume_ctxt _ccs <- status - , not is_exception - = do - hsc_env <- getSession - let interp = hscInterp hsc_env - let dflags = hsc_dflags hsc_env - let hmi = expectJust "handleRunStatus" $ - lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) - modl = mi_module (hm_iface hmi) - breaks = getModBreaks hmi +handleRunStatus step expr bindings final_ids status history0 = do + hsc_env <- getSession + let + interp = hscInterp hsc_env + dflags = hsc_dflags hsc_env + case status of - b <- liftIO $ - breakpointStatus interp (modBreaks_flags breaks) ix - if b - then not_tracing - -- This breakpoint is explicitly enabled; we want to stop - -- instead of just logging it. - else do - apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref - let bi = BreakInfo modl ix - !history' = mkHistory hsc_env apStack_fhv bi `consBL` history - -- history is strict, otherwise our BoundedList is pointless. - fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - let eval_opts = initEvalOpts dflags True - status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv - handleRunStatus RunAndLogSteps expr bindings final_ids - status history' - | otherwise - = not_tracing + -- Completed successfully + EvalComplete allocs (EvalSuccess hvals) -> do + let + final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids + final_names = map getName final_ids + liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals) + hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} + setSession hsc_env' + return (ExecComplete (Right final_names) allocs) - not_tracing - -- Hit a breakpoint - | EvalBreak is_exception apStack_ref ix mod_name resume_ctxt ccs <- status - = do - hsc_env <- getSession - let interp = hscInterp hsc_env - resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref - let hmi = expectJust "handleRunStatus" $ - lookupHpt (hsc_HPT hsc_env) (mkModuleName mod_name) - modl = mi_module (hm_iface hmi) - bp | is_exception = Nothing - | otherwise = Just (BreakInfo modl ix) - (hsc_env1, names, span, decl) <- liftIO $ - bindLocalsAtBreakpoint hsc_env apStack_fhv bp - let - resume = Resume - { resumeStmt = expr, resumeContext = resume_ctxt_fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack_fhv - , resumeBreakInfo = bp - , resumeSpan = span, resumeHistory = toListBL history - , resumeDecl = decl - , resumeCCS = ccs - , resumeHistoryIx = 0 } - hsc_env2 = pushResume hsc_env1 resume + -- Completed with an exception + EvalComplete alloc (EvalException e) -> + return (ExecComplete (Left (fromSerializableException e)) alloc) - setSession hsc_env2 - return (ExecBreak names bp) + -- Nothing case: we stopped when an exception was raised, not at a breakpoint. + EvalBreak apStack_ref Nothing resume_ctxt ccs -> do + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt + apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref + let span = mkGeneralSrcSpan (fsLit "") + (hsc_env1, names) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack_fhv span Nothing + let + resume = Resume + { resumeStmt = expr + , resumeContext = resume_ctxt_fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack_fhv + , resumeBreakpointId = Nothing + , resumeSpan = span + , resumeHistory = toListBL history0 + , resumeDecl = "" + , resumeCCS = ccs + , resumeHistoryIx = 0 + } + hsc_env2 = pushResume hsc_env1 resume - -- Completed successfully - | EvalComplete allocs (EvalSuccess hvals) <- status - = do hsc_env <- getSession - let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids - final_names = map getName final_ids - interp = hscInterp hsc_env - liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals) - hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} - setSession hsc_env' - return (ExecComplete (Right final_names) allocs) + setSession hsc_env2 + return (ExecBreak names Nothing) - -- Completed with an exception - | EvalComplete alloc (EvalException e) <- status - = return (ExecComplete (Left (fromSerializableException e)) alloc) + -- EvalBreak (Just ...) case: the interpreter stopped at a breakpoint + -- + -- The interpreter yields on a breakpoint if: + -- - the breakpoint was explicitly enabled (in @BreakArray@) + -- - or one of the stepping options in @EvalOpts@ caused us to stop at one + EvalBreak apStack_ref (Just eval_break) resume_ctxt ccs -> do + let ibi = evalBreakpointToId eval_break + let hug = hsc_HUG hsc_env + info_brks <- liftIO $ readIModBreaks hug ibi + span <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks + decl <- liftIO $ intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "not_tracing" -- actually exhaustive, but GHC can't tell -#endif + -- Was this breakpoint explicitly enabled (ie. in @BreakArray@)? + bactive <- liftIO $ do + breakArray <- getBreakArray interp ibi info_brks + breakpointStatus interp breakArray (ibi_info_index ibi) + apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref + resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int + -- This breakpoint is enabled or we mean to break here; + -- we want to stop instead of just logging it. + if breakHere bactive step span then do + -- This function only returns control to ghci with 'ExecBreak' when it is really meant to break. + -- Specifically, for :steplocal or :stepmodule, don't return control + -- and simply resume execution from here until we hit a breakpoint we do want to stop at. + (hsc_env1, names) <- liftIO $ + bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) + let + resume = Resume + { resumeStmt = expr + , resumeContext = resume_ctxt_fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack_fhv + , resumeBreakpointId = Just ibi + , resumeSpan = span + , resumeHistory = toListBL history0 + , resumeDecl = decl + , resumeCCS = ccs + , resumeHistoryIx = 0 + } + hsc_env2 = pushResume hsc_env1 resume + setSession hsc_env2 + return (ExecBreak names (Just ibi)) + else do + -- resume with the same step type + let eval_opts = initEvalOpts dflags (enableGhcStepMode step) + status <- liftIO $ GHCi.resumeStmt interp eval_opts resume_ctxt_fhv + history <- if not tracing then pure history0 else do + history1 <- liftIO $ mkHistory hug apStack_fhv ibi + let !history' = history1 `consBL` history0 + -- history is strict, otherwise our BoundedList is pointless. + return history' + handleRunStatus step expr bindings final_ids status history + where + tracing | RunAndLogSteps <- step = True + | otherwise = False + +resumeExec :: GhcMonad m => SingleStep -> Maybe Int -> m ExecResult -resumeExec canLogSpan step mbCnt +resumeExec step mbCnt = do hsc_env <- getSession let ic = hsc_IC hsc_env @@ -438,46 +436,69 @@ liftIO $ Loader.deleteFromLoadedEnv interp new_names case r of - Resume { resumeStmt = expr, resumeContext = fhv - , resumeBindings = bindings, resumeFinalIds = final_ids - , resumeApStack = apStack, resumeBreakInfo = mb_brkpt + Resume { resumeStmt = expr + , resumeContext = fhv + , resumeBindings = bindings + , resumeFinalIds = final_ids + , resumeApStack = apStack + , resumeBreakpointId = mb_brkpt , resumeSpan = span , resumeHistory = hist } -> - withVirtualCWD $ do - when (isJust mb_brkpt && isJust mbCnt) $ do - setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt) - -- When the user specified a break ignore count, set it - -- in the interpreter - let eval_opts = initEvalOpts dflags (isStep step) + do + -- When the user specified a break ignore count, set it + -- in the interpreter + case (mb_brkpt, mbCnt) of + (Just brkpt, Just cnt) -> setupBreakpoint interp brkpt cnt + _ -> return () + + let eval_opts = initEvalOpts dflags (enableGhcStepMode step) status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist + hug = hsc_HUG hsc_env hist' = case mb_brkpt of - Nothing -> prevHistoryLst + Nothing -> pure prevHistoryLst Just bi - | not $ canLogSpan span -> prevHistoryLst - | otherwise -> mkHistory hsc_env apStack bi `consBL` - fromListBL 50 hist - handleRunStatus step expr bindings final_ids status hist' + | breakHere False step span -> do + hist1 <- liftIO (mkHistory hug apStack bi) + return $ hist1 `consBL` fromListBL 50 hist + | otherwise -> pure prevHistoryLst + handleRunStatus step expr bindings final_ids status =<< hist' -setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m () -- #19157 -setupBreakpoint hsc_env brkInfo cnt = do - let modl :: Module = breakInfo_module brkInfo - breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $ - lookupHpt (hsc_HPT hsc_env) (moduleName modl) - ix = breakInfo_number brkInfo - modBreaks = breaks hsc_env modl - breakarray = modBreaks_flags modBreaks - interp = hscInterp hsc_env - _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt - pure () +setupBreakpoint :: GhcMonad m => Interp -> InternalBreakpointId -> Int -> m () -- #19157 +setupBreakpoint interp ibi cnt = do + hug <- hsc_HUG <$> getSession + liftIO $ do + modBreaks <- readIModBreaks hug ibi + breakArray <- getBreakArray interp ibi modBreaks + GHCi.storeBreakpoint interp breakArray (ibi_info_index ibi) cnt -back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) +getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray) +getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do + breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp + case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of + Just ba -> return ba + Nothing -> do + modifyLoaderState interp $ \ld_st -> do + let lb = linked_breaks ld_st + + -- Recall that BreakArrays are allocated only at BCO link time, so if we + -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here. + ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs] + + let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} } + let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod + + return + ( ld_st' + , ba + ) +back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) back n = moveHist (+n) -forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) +forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan) forward n = moveHist (subtract n) -moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String) +moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan) moveHist fn = do hsc_env <- getSession case ic_resume (hsc_IC hsc_env) of @@ -495,15 +516,21 @@ let update_ic apStack mb_info = do - (hsc_env1, names, span, decl) <- - liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info + span <- case mb_info of + Nothing -> return $ mkGeneralSrcSpan (fsLit "") + Just ibi -> liftIO $ do + let hug = hsc_HUG hsc_env + brks <- readIModBreaks hug ibi + getBreakLoc (readIModModBreaks hug) ibi brks + (hsc_env1, names) <- + liftIO $ bindLocalsAtBreakpoint hsc_env apStack span mb_info let ic = hsc_IC hsc_env1 r' = r { resumeHistoryIx = new_ix } ic' = ic { ic_resume = r':rs } setSession hsc_env1{ hsc_IC = ic' } - return (names, new_ix, span, decl) + return (names, new_ix, span) -- careful: we want apStack to be the AP_STACK itself, not a thunk -- around it, hence the cases are carefully constructed below to @@ -511,11 +538,11 @@ if new_ix == 0 then case r of Resume { resumeApStack = apStack, - resumeBreakInfo = mb_brkpt } -> + resumeBreakpointId = mb_brkpt } -> update_ic apStack mb_brkpt else case history !! (new_ix - 1) of History{..} -> - update_ic historyApStack (Just historyBreakInfo) + update_ic historyApStack (Just historyBreakpointId) -- ----------------------------------------------------------------------------- @@ -527,16 +554,16 @@ bindLocalsAtBreakpoint :: HscEnv -> ForeignHValue - -> Maybe BreakInfo - -> IO (HscEnv, [Name], SrcSpan, String) + -> SrcSpan + -> Maybe InternalBreakpointId + -> IO (HscEnv, [Name]) -- Nothing case: we stopped when an exception was raised, not at a -- breakpoint. We have no location information or local variables to -- bind, all we can do is bind a local variable to the exception -- value. -bindLocalsAtBreakpoint hsc_env apStack Nothing = do +bindLocalsAtBreakpoint hsc_env apStack span Nothing = do let exn_occ = mkVarOccFS (fsLit "_exception") - span = mkGeneralSrcSpan (fsLit "") exn_name <- newInteractiveBinder hsc_env exn_occ span let e_fs = fsLit "e" @@ -549,29 +576,23 @@ interp = hscInterp hsc_env -- Loader.extendLoadedEnv interp [(exn_name, apStack)] - return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "") + return (hsc_env{ hsc_IC = ictxt1 }, [exn_name]) -- Just case: we stopped at a breakpoint, we have information about the location -- of the breakpoint and the free variables of the expression. -bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do - let - hmi = expectJust "bindLocalsAtBreakpoint" $ - lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) - interp = hscInterp hsc_env - breaks = getModBreaks hmi - info = expectJust "bindLocalsAtBreakpoint2" $ - IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks) - occs = modBreaks_vars breaks ! breakInfo_number - span = modBreaks_locs breaks ! breakInfo_number - decl = intercalate "." $ modBreaks_decls breaks ! breakInfo_number +bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do + let hug = hsc_HUG hsc_env + info_brks <- readIModBreaks hug ibi + let info = getInternalBreak ibi info_brks + interp = hscInterp hsc_env + occs <- getBreakVars (readIModModBreaks hug) ibi info_brks -- Rehydrate to understand the breakpoint info relative to the current environment. -- This design is critical to preventing leaks (#22530) (mbVars, result_ty) <- initIfaceLoad hsc_env - $ initIfaceLcl breakInfo_module (text "debugger") NotBoot + $ initIfaceLcl (ibi_info_mod ibi) (text "debugger") NotBoot $ hydrateCgBreakInfo info - let -- Filter out any unboxed ids by changing them to Nothings; @@ -596,8 +617,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 @@ -616,7 +637,7 @@ Loader.extendLoadedEnv interp (zip names fhvs) when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, if result_ok then result_name:names else names, span, decl) + return (hsc_env1, if result_ok then result_name:names else names) where -- We need a fresh Unique for each Id we bind, because the linker -- state is single-threaded and otherwise we'd spam old bindings @@ -653,7 +674,7 @@ syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs where joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)] - joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc + joinOccs = zipWithEqual joinOcc joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc rttiEnvironment :: HscEnv -> IO HscEnv @@ -668,7 +689,7 @@ noSkolems = noFreeVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do let tmp_ids = [id | AnId id <- ic_tythings ic] - Just id = find (\i -> idName i == name) tmp_ids + id = expectJust $ find (\i -> idName i == name) tmp_ids if noSkolems id then return hsc_env else do @@ -814,45 +835,63 @@ text "to context:" <+> text err findGlobalRdrEnv :: HscEnv -> [InteractiveImport] - -> IO (Either (ModuleName, String) GlobalRdrEnv) + -> IO (Either (Module, String) GlobalRdrEnv) -- Compute the GlobalRdrEnv for the interactive context findGlobalRdrEnv hsc_env imports = do { idecls_env <- hscRnImportDecls hsc_env idecls -- This call also loads any orphan modules - ; return $ case partitionEithers (map 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] idecls = [noLocA d | IIDecl d <- imports] - imods :: [ModuleName] + imods :: [Module] 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 = do + 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 - = case lookupHpt hpt modl of - Nothing -> Left "not a home module" +mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) +mkTopLevEnv hsc_env modl + = HUG.lookupHugByModule modl hug >>= \case + 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 + (IfaceTopEnv exports _imports) -> do + imports_env <- mkTopLevImportedEnv hsc_env details + let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports) + pure $ Right $ plusGlobalRdrEnv imports_env exports_env + where + hug = hsc_HUG hsc_env +-- | Make the top-level environment with all bindings imported by this module. +-- Exported bindings from this module are not included in the result. +mkTopLevImportedEnv :: HscEnv -> HomeModInfo -> IO GlobalRdrEnv +mkTopLevImportedEnv hsc_env details = do + runInteractiveHsc hsc_env + $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env + $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) + $ forM imports $ \iface_import -> do + let ImpUserSpec spec details = tcIfaceImport iface_import + iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) + pure $ case details of + ImpUserAll -> importsFromIface hsc_env iface spec Nothing + ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) + ImpUserExplicit x _parents_of_implicits -> + -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y). + -- It is only used for error messages. It seems dubious even to add an import context to these GREs as + -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that + -- the test case produce the same output as before. + let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } } + in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x + where + IfaceTopEnv _ imports = mi_top_env (hm_iface details) + -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. @@ -864,11 +903,9 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h -> - if notHomeModule (hsc_home_unit h) modl - then return False - else case lookupHpt (hsc_HPT h) (moduleName modl) of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False + liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case + Just hmi -> return (isJust $ homeModInfoByteCode hmi) + _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) -- Filter the instances by the ones whose tycons (or classes resp) @@ -1065,8 +1102,9 @@ (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ty <- hscParseType str - ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty - + ioMsgMaybe $ hoistTcRnMessage $ + tcRnTypeSkolemising hsc_env ty + -- I'm not sure what to do about those zonked skolems return ty -- Get all the constraints required of a dictionary binding @@ -1076,7 +1114,7 @@ let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing - return CtWanted { + return $ CtWanted $ WantedCt { ctev_pred = varType dict_var, ctev_dest = EvVarDest dict_var, ctev_loc = loc, @@ -1225,7 +1263,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 @@ -1233,7 +1271,7 @@ _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env - let eval_opts = initEvalOpts dflags False + let eval_opts = initEvalOpts dflags EvalStepNone status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval @@ -1253,29 +1291,30 @@ parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . mkHsVar . L (l2l loc) $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce hval :: Dynamic) ----------------------------------------------------------------------------- --- show a module and it's source/object filenames +-- show a module and its source/object filenames -showModule :: GhcMonad m => ModSummary -> m String -showModule mod_summary = +showModule :: GhcMonad m => ModuleNodeInfo -> m String +showModule mni = do + let mod = moduleNodeInfoModule mni withSession $ \hsc_env -> do let dflags = hsc_dflags hsc_env - let interpreted = - case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) - return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary)) + interpreted <- liftIO $ + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case + Nothing -> panic "missing linkable" + Just mod_info -> isJust (homeModInfoByteCode mod_info) && isNothing (homeModInfoObject mod_info) + return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mni)) -moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool -moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> - case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of - Nothing -> panic "missing linkable" - Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info +moduleIsBootOrNotObjectLinkable :: GhcMonad m => Module -> m Bool +moduleIsBootOrNotObjectLinkable mod = withSession $ \hsc_env -> liftIO $ + HUG.lookupHug (hsc_HUG hsc_env) (moduleUnitId mod) (moduleName mod) >>= pure . \case + Nothing -> panic "missing linkable" + Just mod_info -> isNothing $ homeModInfoByteCode mod_info ---------------------------------------------------------------------------- -- RTTI primitives diff --git a/GHC/Runtime/Eval/Types.hs b/GHC/Runtime/Eval/Types.hs --- a/GHC/Runtime/Eval/Types.hs +++ b/GHC/Runtime/Eval/Types.hs @@ -9,17 +9,19 @@ module GHC.Runtime.Eval.Types ( Resume(..), ResumeBindings, IcGlobalRdrEnv(..), History(..), ExecResult(..), - SingleStep(..), isStep, ExecOptions(..) + SingleStep(..), enableGhcStepMode, breakHere, + ExecOptions(..) ) where import GHC.Prelude import GHCi.RemoteTypes import GHCi.Message (EvalExpr, ResumeContext) +import GHC.ByteCode.Types (InternalBreakpointId(..)) +import GHC.Driver.Config (EvalStep(..)) import GHC.Types.Id import GHC.Types.Name import GHC.Types.TyThing -import GHC.Types.BreakInfo import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Exception @@ -35,23 +37,123 @@ , execWrap :: ForeignHValue -> EvalExpr ForeignHValue } +-- | What kind of stepping are we doing? data SingleStep = RunToCompletion - | SingleStep + + -- | :trace [expr] | RunAndLogSteps -isStep :: SingleStep -> Bool -isStep RunToCompletion = False -isStep _ = True + -- | :step [expr] + | SingleStep + -- | :stepout + | StepOut + { initiatedFrom :: Maybe SrcSpan + -- ^ Step-out locations are filtered to make sure we don't stop at a + -- continuation that is within the function from which step-out was + -- initiated. See Note [Debugger: Step-out] + } + + -- | :steplocal [expr] + | LocalStep + { breakAt :: SrcSpan } + + -- | :stepmodule [expr] + | ModuleStep + { breakAt :: SrcSpan } + +-- | Whether this 'SingleStep' mode requires instructing the interpreter to +-- step at every breakpoint or after every return (see @'EvalStep'@). +enableGhcStepMode :: SingleStep -> EvalStep +enableGhcStepMode RunToCompletion = EvalStepNone +enableGhcStepMode StepOut{} = EvalStepOut +-- for the remaining step modes we need to stop at every single breakpoint. +enableGhcStepMode _ = EvalStepSingle + +-- | Given a 'SingleStep' mode, whether the breakpoint was explicitly active, +-- and the SrcSpan of a breakpoint we hit, return @True@ if we should stop at +-- this breakpoint. +-- +-- In particular, this will always be @False@ for @'RunToCompletion'@ and +-- @'RunAndLogSteps'@. We'd need further information e.g. about the user +-- breakpoints to determine whether to break in those modes. +breakHere :: Bool -- ^ Was this breakpoint explicitly active (in the @BreakArray@s)? + -> SingleStep -- ^ What kind of stepping were we doing + -> SrcSpan -- ^ The span of the breakpoint we hit + -> Bool -- ^ Should we stop here then? +breakHere b RunToCompletion _ = b +breakHere b RunAndLogSteps _ = b +breakHere _ SingleStep _ = True +breakHere b step break_span = case step of + LocalStep start_span -> b || break_span `isSubspanOf` start_span + ModuleStep start_span -> b || srcSpanFileName_maybe start_span == srcSpanFileName_maybe break_span + StepOut Nothing -> True + StepOut (Just start) -> + -- See Note [Debugger: Filtering step-out stops] + not (break_span `isSubspanOf` start) + +{- +Note [Debugger: Filtering step-out stops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall from Note [Debugger: Step-out] that the RTS explicitly enables the +breakpoint at the start of the first continuation frame on the stack, when +the step-out flag is set. + +Often, the continuation on top of the stack will be part of the same function +from which step-out was initiated. A trivial example is a case expression: + + f x = case g x of ... + +If we're stopped in , the continuation will be in the case alternatives rather +than in the function which called `f`. This is especially relevant for monadic +do-blocks which may end up being compiled to long chains of case expressions, +such as IO, and we don't want to stop at every line in the block while stepping out! + +To make sure we only stop at a continuation outside of the current function, we +compare the continuation breakpoint `SrcSpan` against the current one. If the +continuation breakpoint is within the current function, instead of stopping, we +re-trigger step-out and return to the RTS interpreter right away. + +This behaviour is very similar to `:steplocal`, which is implemented by +yielding from the RTS at every breakpoint (using `:step`) but only really +stopping when the breakpoint's `SrcSpan` is contained in the current function. + +The function which determines if we should stop at the current breakpoint is +`breakHere`. For `StepOut`, `breakHere` will only return `True` if the +breakpoint is not contained in the function from which step-out was initiated. + +Notably, this means we will ignore breakpoints enabled by the user if they are +contained in the function we are stepping out of. + +If we had a way to distinguish whether a breakpoint was explicitly enabled (in +`BreakArrays`) by the user vs by step-out we could additionally break on +user-enabled breakpoints; however, it's not straightforward to determine this +and arguably it may be uncommon for a user to use step-out to run until the +next breakpoint in the same function. Of course, if a breakpoint in any other +function is hit before returning to the continuation, we will still stop there +(`breakHere` will be `True` because the break point is not within the initiator +function). +-} + data ExecResult + + -- | Execution is complete with either an exception or the list of + -- user-visible names that were brought into scope. = ExecComplete { execResult :: Either SomeException [Name] , execAllocation :: Word64 } - | ExecBreak - { breakNames :: [Name] - , breakInfo :: Maybe BreakInfo + + -- | Execution stopped at a breakpoint. + -- + -- Note: `ExecBreak` is only returned by `handleRunStatus` when GHCi should + -- definitely stop at this breakpoint. GHCi is /not/ responsible for + -- subsequently deciding whether to really stop here. + -- `ExecBreak` always means GHCi breaks. + | ExecBreak + { breakNames :: [Name] + , breakPointId :: Maybe InternalBreakpointId } -- | Essentially a GlobalRdrEnv, but with additional cached values to allow @@ -73,11 +175,10 @@ , resumeFinalIds :: [Id] -- [Id] to bind on completion , resumeApStack :: ForeignHValue -- The object from which we can get -- value of the free variables. - , resumeBreakInfo :: Maybe BreakInfo - -- the breakpoint we stopped at - -- (module, index) + , resumeBreakpointId :: Maybe InternalBreakpointId + -- ^ the internal breakpoint we stopped at -- (Nothing <=> exception) - , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan -- from the ModBreaks, -- otherwise it's a pain to -- fetch the ModDetails & @@ -90,9 +191,8 @@ type ResumeBindings = ([TyThing], IcGlobalRdrEnv) -data History - = History { - historyApStack :: ForeignHValue, - historyBreakInfo :: BreakInfo, - historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint - } +data History = History + { historyApStack :: ForeignHValue + , historyBreakpointId :: InternalBreakpointId -- ^ breakpoint identifier + , historyEnclosingDecls :: [String] -- ^ declarations enclosing the breakpoint + } diff --git a/GHC/Runtime/Eval/Utils.hs b/GHC/Runtime/Eval/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Eval/Utils.hs @@ -0,0 +1,48 @@ +module GHC.Runtime.Eval.Utils where + +import GHC.Prelude +import Data.Char +import Data.List (elemIndices) + +-- | Split up a string with an eventually qualified declaration name into 3 components +-- +-- 1. module name +-- 2. top-level decl +-- 3. full-name of the eventually nested decl, but without module qualification +-- +-- === __Example__ +-- +-- @ +-- "foo" = ("", "foo", "foo") +-- "A.B.C.foo" = ("A.B.C", "foo", "foo") +-- "M.N.foo.bar" = ("M.N", "foo", "foo.bar") +-- @ +splitIdent :: String -> (String, String, String) +splitIdent [] = ("", "", "") +splitIdent inp@(a : _) + | (isUpper a) = case fixs of + [] -> (inp, "", "") + (i1 : [] ) -> (upto i1, from i1, from i1) + (i1 : i2 : _) -> (upto i1, take (i2 - i1 - 1) (from i1), from i1) + | otherwise = case ixs of + [] -> ("", inp, inp) + (i1 : _) -> ("", upto i1, inp) + where + ixs = elemIndices '.' inp -- indices of '.' in whole input + fixs = dropWhile isNextUc ixs -- indices of '.' in function names -- + isNextUc ix = isUpper $ safeInp !! (ix+1) + safeInp = inp ++ " " + upto i = take i inp + from i = drop (i + 1) inp + +-- | Qualify an identifier name with a module name +-- +-- @ +-- combineModIdent "A" "foo" = "A.foo" +-- combineModIdent "" "foo" = "foo" +-- @ +combineModIdent :: String -> String -> String +combineModIdent mod ident + | null mod = ident + | null ident = mod + | otherwise = mod ++ "." ++ ident diff --git a/GHC/Runtime/Heap/Inspect.hs b/GHC/Runtime/Heap/Inspect.hs --- a/GHC/Runtime/Heap/Inspect.hs +++ b/GHC/Runtime/Heap/Inspect.hs @@ -1,5 +1,16 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ > 912 +{-# OPTIONS_GHC -Wwarn=incomplete-record-selectors #-} +-- This module has a bunch of uses of incomplete record selectors +-- and it is FAR from obvious that they won't cause crashes. +-- But I don't want them to kill CI, so the above flag turns +-- them into warnings +#endif + + ----------------------------------------------------------------------------- -- -- GHC Interactive support for inspecting arbitrary closures at runtime @@ -33,6 +44,7 @@ import GHC.Core.DataCon import GHC.Core.Type +import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped ) import GHC.Types.RepType import GHC.Core.Multiplicity import qualified GHC.Core.Unify as U @@ -60,7 +72,6 @@ import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo ) @@ -76,6 +87,7 @@ import Data.Sequence (viewl, ViewL(..)) import Foreign hiding (shiftL, shiftR) import System.IO.Unsafe +import GHC.InfoProv --------------------------------------------- -- * A representation of semi evaluated Terms @@ -96,6 +108,7 @@ , ty :: RttiType , val :: ForeignHValue , bound_to :: Maybe Name -- Useful for printing + , infoprov :: Maybe InfoProv -- Provenance is printed when available } | NewtypeWrap{ -- At runtime there are no newtypes, and hence no -- newtype constructors. A NewtypeWrap is just a @@ -118,6 +131,11 @@ isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t isFullyEvaluatedTerm _ = False +-- | Gives an error if the term doesn't have subterms +expectSubTerms :: Term -> [Term] +expectSubTerms (Term { subTerms = subTerms} ) = subTerms +expectSubTerms _ = panic "expectSubTerms" + instance Outputable (Term) where ppr t | Just doc <- cPprTerm cPprTermBase t = doc | otherwise = panic "Outputable Term instance" @@ -149,7 +167,7 @@ data TermFold a = TermFold { fTerm :: TermProcessor a a , fPrim :: RttiType -> [Word] -> a , fSuspension :: ClosureType -> RttiType -> ForeignHValue - -> Maybe Name -> a + -> Maybe Name -> Maybe InfoProv -> a , fNewtypeWrap :: RttiType -> Either String DataCon -> a -> a , fRefWrap :: RttiType -> a -> a @@ -160,7 +178,7 @@ TermFoldM {fTermM :: TermProcessor a (m a) , fPrimM :: RttiType -> [Word] -> m a , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue - -> Maybe Name -> m a + -> Maybe Name -> Maybe InfoProv -> m a , fNewtypeWrapM :: RttiType -> Either String DataCon -> a -> m a , fRefWrapM :: RttiType -> a -> m a @@ -169,7 +187,7 @@ foldTerm :: TermFold a -> Term -> a foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) foldTerm tf (Prim ty v ) = fPrim tf ty v -foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b +foldTerm tf (Suspension ct ty v b i) = fSuspension tf ct ty v b i foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) @@ -177,7 +195,7 @@ foldTermM :: Monad m => TermFoldM m a -> Term -> m a foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v foldTermM tf (Prim ty v ) = fPrimM tf ty v -foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b +foldTermM tf (Suspension ct ty v b i) = fSuspensionM tf ct ty v b i foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty @@ -193,8 +211,8 @@ mapTermType :: (RttiType -> Type) -> Term -> Term mapTermType f = foldTerm idTermFold { fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, - fSuspension = \ct ty hval n -> - Suspension ct (f ty) hval n, + fSuspension = \ct ty hval n i -> + Suspension ct (f ty) hval n i, fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, fRefWrap = \ty t -> RefWrap (f ty) t} @@ -202,8 +220,8 @@ mapTermTypeM f = foldTermM TermFoldM { fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, fPrimM = (return.) . Prim, - fSuspensionM = \ct ty hval n -> - f ty >>= \ty' -> return $ Suspension ct ty' hval n, + fSuspensionM = \ct ty hval n i -> + f ty >>= \ty' -> return $ Suspension ct ty' hval n i, fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} @@ -211,7 +229,7 @@ termTyCoVars = foldTerm TermFold { fTerm = \ty _ _ tt -> tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, - fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, + fSuspension = \_ ty _ _ _ -> tyCoVarsOfType ty, fPrim = \ _ _ -> emptyVarSet, fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} @@ -269,8 +287,24 @@ ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words -ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = - return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty)) +ppr_termM1 Suspension{ty=ty, bound_to=Nothing, infoprov=mipe} = + return $ hcat $ +    [ char '_' +    , whenPprDebug $ + space <> + dcolon <> + pprSigmaType ty +    ] ++ +    [ whenPprDebug $ + space <> + char '<' <> + text (ipSrcFile ipe) <> + char ':' <> + text (ipSrcSpan ipe) <> + char '>' +    | Just ipe <- [mipe] + , not $ null $ ipSrcFile ipe +    ] ppr_termM1 Suspension{ty=ty, bound_to=Just n} | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{} = panic "ppr_termM1 - Term" @@ -322,8 +356,8 @@ cPprTermBase y = [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) . mapM (y (-1)) - . subTerms) - , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) + . expectSubTerms) + , ifTerm (\t -> isTyCon listTyCon (ty t) && expectSubTerms t `lengthIs` 2) ppr_list , ifTerm' (isTyCon intTyCon . ty) ppr_int , ifTerm' (isTyCon charTyCon . ty) ppr_char @@ -758,12 +792,18 @@ traceTR (text "Gave up reconstructing a term after" <> int max_depth <> text " steps") clos <- trIO $ GHCi.getClosure interp a - return (Suspension (tipe (info clos)) my_ty a Nothing) + ipe <- trIO $ GHCi.whereFrom interp a +#if MIN_VERSION_ghc_heap(9,15,0) + return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe) +#else + return (Suspension (tipe (info clos)) my_ty a Nothing ipe) +#endif go !max_depth my_ty old_ty a = do let monomorphic = not(isTyVarTy my_ty) -- This ^^^ is a convention. The ancestor tests for -- monomorphism and passes a type instead of a tv clos <- trIO $ GHCi.getClosure interp a + ipe <- trIO $ GHCi.whereFrom interp a case clos of -- Thunks we may want to force t | isThunk t && force -> do @@ -782,7 +822,8 @@ BlackholeClosure{indirectee=ind} -> do traceTR (text "Following a BLACKHOLE") ind_clos <- trIO (GHCi.getClosure interp ind) - let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing) + ind_ipe <- trIO (GHCi.whereFrom interp ind) + let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing ind_ipe) case ind_clos of -- TSO and BLOCKING_QUEUE cases BlockingQueueClosure{} -> return_bh_value @@ -840,7 +881,7 @@ Just dc -> do traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) subTtypes <- getDataConArgTys dc my_ty - subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes + subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) pArgs dArgs subTtypes return (Term my_ty (Right dc) a subTerms) -- This is to support printing of Integers. It's not a general @@ -854,8 +895,11 @@ _ -> do traceTR (text "Unknown closure:" <+> text (show (fmap (const ()) clos))) - return (Suspension (tipe (info clos)) my_ty a Nothing) - +#if MIN_VERSION_ghc_heap(9,15,0) + return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing ipe) +#else + return (Suspension (tipe (info clos)) my_ty a Nothing ipe) +#endif -- insert NewtypeWraps around newtypes expandNewtypes = foldTerm idTermFold { fTerm = worker } where worker ty dc hval tt @@ -870,15 +914,16 @@ -- Avoid returning types where predicates have been expanded to dictionaries. fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where - worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n - | otherwise = Suspension ct ty hval n + worker ct ty hval n i | isFunTy ty = Suspension ct (dictsView ty) hval n i + | otherwise = Suspension ct ty hval n i extractSubTerms :: (Type -> ForeignHValue -> TcM Term) - -> GenClosure ForeignHValue -> [Type] -> TcM [Term] -extractSubTerms recurse clos = liftM thdOf3 . go 0 0 + -> [ForeignHValue] -- ^ pointer arguments + -> [Word] -- ^ data arguments + -> [Type] + -> TcM [Term] +extractSubTerms recurse ptr_args data_args = liftM thdOf3 . go 0 0 where - array = dataArgs clos - go ptr_i arr_i [] = return (ptr_i, arr_i, []) go ptr_i arr_i (ty:tys) | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty @@ -889,13 +934,13 @@ (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) | otherwise - = case typePrimRepArgs ty of - rep_ty :| [] -> do + = case typePrimRep ty of + [rep_ty] -> do (ptr_i, arr_i, term0) <- go_rep ptr_i arr_i ty rep_ty (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, term0 : terms1) - rep_ty :| rep_tys -> do - (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i (rep_ty:rep_tys) + rep_tys -> do + (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1) @@ -908,7 +953,7 @@ go_rep ptr_i arr_i ty rep | isGcPtrRep rep = do - t <- recurse ty $ (ptrArgs clos)!!ptr_i + t <- recurse ty $ ptr_args !! ptr_i return (ptr_i + 1, arr_i, t) | otherwise = do -- This is a bit involved since we allow packing multiple fields @@ -929,7 +974,7 @@ | otherwise = let (q, r) = size_b `quotRem` word_size in assert (r == 0 ) - [ array!!i + [ data_args !! i | o <- [0.. q - 1] , let i = (aligned_idx `quot` word_size) + o ] @@ -952,7 +997,7 @@ LittleEndian -> (word `shiftR` moveBits) `shiftL` zeroOutBits `shiftR` zeroOutBits where (q, r) = aligned_idx `quotRem` word_size - word = array!!q + word = data_args !! q moveBits = r * 8 zeroOutBits = (word_size - size_b) * 8 @@ -1094,7 +1139,7 @@ -- The types can contain skolem type variables, which need to be treated as normal vars. -- In particular, we want them to unify with things. improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst -improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty +improveRTTIType _ base_ty new_ty = U.tcUnifyDebugger base_ty new_ty getDataConArgTys :: DataCon -> Type -> TR [Type] -- Given the result type ty of a constructor application (D a b c :: ty) @@ -1371,8 +1416,8 @@ zonkTerm = foldTermM (TermFoldM { fTermM = \ty dc v tt -> zonkRttiType ty >>= \ty' -> return (Term ty' dc v tt) - , fSuspensionM = \ct ty v b -> zonkRttiType ty >>= \ty -> - return (Suspension ct ty v b) + , fSuspensionM = \ct ty v b i -> zonkRttiType ty >>= \ty -> + return (Suspension ct ty v b i) , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' -> return$ NewtypeWrap ty' dc t , fRefWrapM = \ty t -> return RefWrap `ap` diff --git a/GHC/Runtime/Interpreter.hs b/GHC/Runtime/Interpreter.hs --- a/GHC/Runtime/Interpreter.hs +++ b/GHC/Runtime/Interpreter.hs @@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} -- | Interacting with the iserv interpreter, whether it is running on an -- external process or in the current process. @@ -25,15 +21,17 @@ , mkCostCentres , costCentreStackInfo , newBreakArray - , newModuleName , storeBreakpoint , breakpointStatus , getBreakpointVar , getClosure + , whereFrom , getModBreaks + , readIModBreaks + , readIModBreaksMaybe + , readIModModBreaks , seqHValue - , interpreterDynamic - , interpreterProfiled + , evalBreakpointToId -- * The object-code linker , initObjLinker @@ -71,38 +69,35 @@ 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 import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) -import GHC.Types.BreakInfo (BreakInfo(..)) -import GHC.ByteCode.Types +import GHC.ByteCode.Breakpoints +import GHC.ByteCode.Types import GHC.Linker.Types import GHC.Data.Maybe import GHC.Data.FastString import GHC.Types.SrcLoc -import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Utils.Panic import GHC.Utils.Exception as Ex import GHC.Utils.Outputable(brackets, ppr, showSDocUnsafe) import GHC.Utils.Fingerprint -import GHC.Utils.Misc import GHC.Unit.Module -import GHC.Unit.Module.ModIface import GHC.Unit.Home.ModInfo import GHC.Unit.Env #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run -import GHC.Platform.Ways #endif import Control.Concurrent @@ -110,18 +105,21 @@ import Control.Monad.IO.Class import Control.Monad.Catch as MC (mask) import Data.Binary -import Data.Binary.Put import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as LB -import Data.Array ((!)) -import Data.IORef import Foreign hiding (void) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Directory import System.Process -import GHC.Conc (pseq, par) +import qualified GHC.InfoProv as InfoProv +import GHC.Builtin.Names +import GHC.Types.Name +import qualified GHC.Unit.Home.Graph as HUG + +-- Standard libraries +import GHC.Exts + {- Note [Remote GHCi] ~~~~~~~~~~~~~~~~~~ When the flag -fexternal-interpreter is given to GHC, interpreted code @@ -204,11 +202,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] @@ -237,6 +237,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. @@ -314,7 +319,7 @@ -> IO (EvalStatus_ [ForeignHValue] [HValueRef]) handleEvalStatus interp status = case status of - EvalBreak a b c d e f -> return (EvalBreak a b c d e f) + EvalBreak a b c d -> return (EvalBreak a b c d) EvalComplete alloc res -> EvalComplete alloc <$> addFinalizer res where @@ -353,19 +358,7 @@ -- | Create a set of BCOs that may be mutually recursive. createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef] createBCOs interp rbcos = do - -- Serializing ResolvedBCO is expensive, so we do it in parallel - interpCmd interp (CreateBCOs puts) - where - puts = parMap doChunk (chunkList 100 rbcos) - - -- make sure we force the whole lazy ByteString - doChunk c = pseq (LB.length bs) bs - where bs = runPut (put c) - - -- We don't have the parallel package, so roll our own simple parMap - parMap _ [] = [] - parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) - where fx = f x; fxs = parMap f xs + interpCmd interp (CreateBCOs rbcos) addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO () addSptEntry interp fpr ref = @@ -381,10 +374,6 @@ breakArray <- interpCmd interp (NewBreakArray size) mkFinalizedHValue interp breakArray -newModuleName :: Interp -> ModuleName -> IO (RemotePtr ModuleName) -newModuleName interp mod_name = - castRemotePtr <$> interpCmd interp (NewBreakModule (moduleNameString mod_name)) - storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO () storeBreakpoint interp ref ix cnt = do -- #19157 withForeignRef ref $ \breakarray -> @@ -407,6 +396,11 @@ mb <- interpCmd interp (GetClosure hval) mapM (mkFinalizedHValue interp) mb +whereFrom :: Interp -> ForeignHValue -> IO (Maybe InfoProv.InfoProv) +whereFrom interp ref = + withForeignRef ref $ \hval -> do + interpCmd interp (WhereFrom hval) + -- | Send a Seq message to the iserv process to force a value #2950 seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ()) seqHValue interp unit_env ref = @@ -414,38 +408,52 @@ status <- interpCmd interp (Seq hval) handleSeqHValueStatus interp unit_env status +evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId +evalBreakpointToId eval_break = + let + mkUnitId u = fsToUnit $ mkFastStringShortByteString u + toModule u n = mkModule (mkUnitId u) (mkModuleName n) + in + InternalBreakpointId + { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) + , ibi_info_index = eb_info_index eval_break + } + -- | Process the result of a Seq or ResumeSeq message. #2950 handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ()) handleSeqHValueStatus interp unit_env eval_status = case eval_status of - (EvalBreak is_exception _ ix mod_name resume_ctxt _) -> do + (EvalBreak _ maybe_break resume_ctxt _) -> do -- A breakpoint was hit; inform the user and tell them -- which breakpoint was hit. resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt - let hmi = expectJust "handleRunStatus" $ - lookupHpt (ue_hpt unit_env) (mkModuleName mod_name) - modl = mi_module (hm_iface hmi) - bp | is_exception = Nothing - | otherwise = Just (BreakInfo modl ix) - sdocBpLoc = brackets . ppr . getSeqBpSpan - putStrLn ("*** Ignoring breakpoint " ++ - (showSDocUnsafe $ sdocBpLoc bp)) + + let put x = putStrLn ("*** Ignoring breakpoint " ++ (showSDocUnsafe x)) + let nothing_case = put $ brackets . ppr $ mkGeneralSrcSpan (fsLit "") + case maybe_break of + Nothing -> nothing_case + -- Nothing case - should not occur! + -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq + + Just break -> do + let ibi = evalBreakpointToId break + hug = ue_home_unit_graph unit_env + + -- Just case: Stopped at a breakpoint, extract SrcSpan information + -- from the breakpoint. + mb_modbreaks <- readIModBreaksMaybe hug (ibi_info_mod ibi) + case mb_modbreaks of + -- Nothing case - should not occur! We should have the appropriate + -- breakpoint information + Nothing -> nothing_case + Just modbreaks -> put . brackets . ppr =<< + getBreakLoc (readIModModBreaks hug) ibi modbreaks + -- resume the seq (:force) processing in the iserv process withForeignRef resume_ctxt_fhv $ \hval -> do status <- interpCmd interp (ResumeSeq hval) handleSeqHValueStatus interp unit_env status (EvalComplete _ r) -> return r - where - getSeqBpSpan :: Maybe BreakInfo -> SrcSpan - -- Just case: Stopped at a breakpoint, extract SrcSpan information - -- from the breakpoint. - getSeqBpSpan (Just BreakInfo{..}) = - (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number - -- Nothing case - should not occur! - -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq - getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "") - breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $ - lookupHpt (ue_hpt unit_env) (moduleName mod) -- ----------------------------------------------------------------------------- @@ -454,49 +462,65 @@ initObjLinker :: Interp -> IO () initObjLinker interp = interpCmd interp InitLinker -lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ())) -lookupSymbol interp str = case interpInstance interp of +lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ())) +lookupSymbol interp str = withSymbolCache interp str $ + case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str))) #endif - - ExternalInterp ext -> case ext of - ExtIServ i -> withIServ i $ \inst -> do - -- Profiling of GHCi showed a lot of time and allocation spent - -- making cross-process LookupSymbol calls, so I added a GHC-side - -- cache which sped things up quite a lot. We have to be careful - -- to purge this cache when unloading code though. - cache <- readMVar (interpLookupSymbolCache interp) - case lookupUFM cache str of - Just p -> return (Just p) - Nothing -> do - m <- uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS str)) - case m of - Nothing -> return Nothing - Just r -> do - let p = fromRemotePtr r - cache' = addToUFM cache str p - modifyMVar_ (interpLookupSymbolCache interp) (const (pure cache')) - return (Just p) - - ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) -lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ())) +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbolInDLL interp dll str = withSymbolCache interp str $ case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str)) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbolInDLL dll (unpackFS str)) + sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) + -- wasm dyld doesn't track which symbol comes from which .so + ExtWasm {} -> lookupSymbol interp str -lookupClosure :: Interp -> String -> IO (Maybe HValueRef) +interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString +interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is -> + let + n = interpSymbolName is + suffix = interpSymbolSuffix is + + encodeZ = fastZStringToByteString . zEncodeFS + (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of + -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers + -- See Note [Primop wrappers] in GHC.Builtin.PrimOps. + mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS + mod -> mod + packagePart = encodeZ (unitFS pkgKey) + modulePart = encodeZ (moduleNameFS modName) + occPart = encodeZ $ occNameMangledFS (nameOccName n) + + label = mconcat $ + [ packagePart `mappend` "_" | pkgKey /= mainUnit ] + ++ + [modulePart + , "_" + , occPart + , "_" + , fromString suffix + ] + in mkFastStringByteString label + +lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef) lookupClosure interp str = - interpCmd interp (LookupClosure str) + interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str))) -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' -- which maps symbols to the address where they are loaded. @@ -504,7 +528,7 @@ -- a miss we run the action which determines the symbol's address and populate -- the cache with the answer. withSymbolCache :: Interp - -> FastString + -> InterpSymbol s -- ^ The symbol we are looking up in the cache -> IO (Maybe (Ptr ())) -- ^ An action which determines the address of the symbol we @@ -521,21 +545,19 @@ -- The analysis in #23415 further showed this cache should also benefit the -- internal interpreter's loading times, and needn't be used by the external -- interpreter only. - cache <- readMVar (interpLookupSymbolCache interp) - case lookupUFM cache str of - Just p -> return (Just p) + cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp) + case cached_val of + Just {} -> return cached_val Nothing -> do - maddr <- determine_addr case maddr of Nothing -> return Nothing Just p -> do - let upd_cache cache' = addToUFM cache' str p - modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache) - return (Just p) + updateInterpSymbolCache str (interpSymbolCache interp) p + return maddr purgeLookupSymbolCache :: Interp -> IO () -purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM)) +purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp) -- | loadDLL loads a dynamic library using the OS's native linker -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either @@ -593,11 +615,12 @@ (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf) [] (iservConfOpts conf) - lo_ref <- newIORef Nothing - let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } + interpPipe <- mkPipeFromHandles rh wh + lock <- newMVar () let process = InterpProcess { interpHandle = ph - , interpPipe = pipe + , interpPipe + , interpLock = lock } pending_frees <- newMVar [] @@ -704,6 +727,34 @@ ExternalInterp {} -> throwIO (InstallationError "this operation requires -fno-external-interpreter") +-------------------------------------------------------------------------------- +-- * Finding breakpoint information +-------------------------------------------------------------------------------- + +-- | Get the breakpoint information from the ByteCode object associated to this +-- 'HomeModInfo'. +getModBreaks :: HomeModInfo -> Maybe InternalModBreaks +getModBreaks hmi + | Just linkable <- homeModInfoByteCode hmi, + -- The linkable may have 'DotO's as well; only consider BCOs. See #20570. + [cbc] <- linkableBCOs linkable + = bc_breaks cbc + | otherwise + = Nothing -- probably object code + +-- | Read the 'InternalModBreaks' of the given home 'Module' (via +-- 'InternalBreakpointId') from the 'HomeUnitGraph'. +readIModBreaks :: HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks +readIModBreaks hug ibi = expectJust <$> readIModBreaksMaybe hug (ibi_info_mod ibi) + +-- | Read the 'InternalModBreaks' of the given home 'Module' from the 'HomeUnitGraph'. +readIModBreaksMaybe :: HomeUnitGraph -> Module -> IO (Maybe InternalModBreaks) +readIModBreaksMaybe hug mod = getModBreaks . expectJust <$> HUG.lookupHugByModule mod hug + +-- | Read the 'ModBreaks' from the given module's 'InternalModBreaks' +readIModModBreaks :: HUG.HomeUnitGraph -> Module -> IO ModBreaks +readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaksMaybe hug mod + -- ----------------------------------------------------------------------------- -- Misc utils @@ -711,35 +762,3 @@ fromEvalResult (EvalException e) = throwIO (fromSerializableException e) fromEvalResult (EvalSuccess a) = return a -getModBreaks :: HomeModInfo -> ModBreaks -getModBreaks hmi - | Just linkable <- homeModInfoByteCode hmi, - [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked 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 -interpreterProfiled interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsProfiled -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfProfiled (interpConfig i) - ExtJS {} -> False -- we don't support profiling yet in the JS backend - --- | Interpreter uses Dynamic way -interpreterDynamic :: Interp -> Bool -interpreterDynamic interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsDynamic -#endif - ExternalInterp ext -> case ext of - ExtIServ i -> iservConfDynamic (interpConfig i) - ExtJS {} -> False -- dynamic doesn't make sense for JS diff --git a/GHC/Runtime/Interpreter/JS.hs b/GHC/Runtime/Interpreter/JS.hs --- a/GHC/Runtime/Interpreter/JS.hs +++ b/GHC/Runtime/Interpreter/JS.hs @@ -129,11 +129,12 @@ (nodeExtraArgs settings) std_in <- readIORef interp_in - lo_ref <- newIORef Nothing - let pipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } + interpPipe <- mkPipeFromHandles rh wh + lock <- newMVar () let proc = InterpProcess { interpHandle = hdl - , interpPipe = pipe + , interpPipe + , interpLock = lock } pure (std_in, proc) @@ -164,7 +165,7 @@ -- get the unit-id of the ghci package. We need this to load the -- interpreter code. - ghci_unit_id <- case lookupPackageName (ue_units unit_env) (PackageName (fsLit "ghci")) of + ghci_unit_id <- case lookupPackageName (ue_homeUnitState unit_env) (PackageName (fsLit "ghci")) of Nothing -> cmdLineErrorIO "JS interpreter: couldn't find \"ghci\" package" Just i -> pure i @@ -183,6 +184,18 @@ , instExtra = extra } + -- TODO: to support incremental linking of wasm modules (e.g. produced from C + -- sources), we should: + -- + -- 1. link the emcc rts without trimming dead code as we don't know what might + -- be needed later by the Wasm modules we will dynamically load (cf + -- -sMAIN_MODULE). + -- 2. make the RUN_SERVER command wait for the emcc rts to be loaded. + -- 3. link wasm modules with -sSIDE_MODULE + -- 4. add a new command to load side modules with Emscripten's dlopen + -- + -- cf https://emscripten.org/docs/compiling/Dynamic-Linking.html + -- link rts and its deps jsLinkRts logger tmpfs tmp_dir codegen_cfg unit_env inst @@ -210,22 +223,26 @@ , lcForeignRefs = False -- we don't need foreign references , lcNoJSExecutables = True -- we don't need executables , lcNoHsMain = True -- nor HsMain + , lcForceEmccRts = False -- nor the emcc rts + , lcLinkCsources = False -- we know that there are no C sources to load for the RTS } - -- link the RTS and its dependencies (things it uses from `base`, etc.) + -- link the RTS and its dependencies (things it uses from `ghc-internal`, etc.) let link_spec = LinkSpec - { lks_unit_ids = [rtsUnitId, baseUnitId, primUnitId] - , lks_obj_files = mempty + { lks_unit_ids = [rtsUnitId, ghcInternalUnitId] , lks_obj_root_filter = const False , lks_extra_roots = mempty - , lks_extra_js = mempty + , lks_objs_hs = mempty + , lks_objs_js = mempty + , lks_objs_cc = mempty } let finder_opts = instFinderOpts (instExtra inst) finder_cache = instFinderCache (instExtra inst) - link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache - jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan + ar_cache <- newArchiveCache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan -- | Link JS interpreter jsLinkInterp :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO () @@ -238,6 +255,8 @@ , lcForeignRefs = False -- we don't need foreign references , lcNoJSExecutables = True -- we don't need executables , lcNoHsMain = True -- nor HsMain + , lcForceEmccRts = False -- nor the emcc rts + , lcLinkCsources = True -- enable C sources, if any } let is_root _ = True -- FIXME: we shouldn't consider every function as a root @@ -245,7 +264,7 @@ let ghci_unit_id = instGhciUnitId (instExtra inst) -- compute unit dependencies of ghc_unit_id - let unit_map = unitInfoMap (ue_units unit_env) + let unit_map = unitInfoMap (ue_homeUnitState unit_env) dep_units <- mayThrowUnitErr $ closeUnitDeps unit_map [(ghci_unit_id,Nothing)] let units = dep_units ++ [ghci_unit_id] @@ -255,18 +274,19 @@ -- link the interpreter and its dependencies let link_spec = LinkSpec { lks_unit_ids = units - , lks_obj_files = mempty , lks_obj_root_filter = is_root , lks_extra_roots = root_deps - , lks_extra_js = mempty + , lks_objs_hs = mempty + , lks_objs_js = mempty + , lks_objs_cc = mempty } let finder_cache = instFinderCache (instExtra inst) finder_opts = instFinderOpts (instExtra inst) - link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache - - jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan + ar_cache <- newArchiveCache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan -- | Link object files @@ -279,27 +299,28 @@ , lcForeignRefs = False -- we don't need foreign references , lcNoJSExecutables = True -- we don't need executables , lcNoHsMain = True -- nor HsMain + , lcForceEmccRts = False -- nor the emcc rts + , lcLinkCsources = True -- enable C sources, if any } - let units = preloadUnits (ue_units unit_env) - ++ [thUnitId] -- don't forget TH which is an implicit dep + let units = preloadUnits (ue_homeUnitState unit_env) -- compute dependencies let link_spec = LinkSpec { lks_unit_ids = units - , lks_obj_files = fmap ObjFile objs , lks_obj_root_filter = is_root , lks_extra_roots = mempty - , lks_extra_js = mempty + , lks_objs_hs = objs + , lks_objs_js = mempty + , lks_objs_cc = mempty } let finder_opts = instFinderOpts (instExtra inst) finder_cache = instFinderCache (instExtra inst) - link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache - - -- link - jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan + ar_cache <- newArchiveCache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache + jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan @@ -314,8 +335,8 @@ -- | Link the given link plan -- -- Perform incremental linking by removing what is already linked from the plan -jsLinkPlan :: Logger -> TmpFs -> TempDir -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO () -jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do +jsLinkPlan :: Logger -> TmpFs -> TempDir -> ArchiveCache -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO () +jsLinkPlan logger tmpfs tmp_dir ar_cache link_cfg cfg inst link_plan = do ---------------------------------------------------------------- -- Get already linked stuff and compute incremental plan ---------------------------------------------------------------- @@ -330,7 +351,7 @@ ---------------------------------------------------------------- tmp_out <- newTempSubDir logger tmpfs tmp_dir - void $ jsLink link_cfg cfg logger tmp_out diff_plan + void $ jsLink link_cfg cfg logger tmpfs ar_cache tmp_out diff_plan -- Code has been linked into the following files: -- - generated rts from tmp_out/rts.js (depends on link options) diff --git a/GHC/Runtime/Interpreter/Process.hs b/GHC/Runtime/Interpreter/Process.hs --- a/GHC/Runtime/Interpreter/Process.hs +++ b/GHC/Runtime/Interpreter/Process.hs @@ -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 diff --git a/GHC/Runtime/Interpreter/Types.hs b/GHC/Runtime/Interpreter/Types.hs --- a/GHC/Runtime/Interpreter/Types.hs +++ b/GHC/Runtime/Interpreter/Types.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} -- | Types used by the runtime interpreter module GHC.Runtime.Interpreter.Types @@ -10,6 +12,21 @@ , ExtInterpInstance (..) , ExtInterpState (..) , InterpStatus(..) + -- * InterpSymbolCache + , InterpSymbolCache(..) + , mkInterpSymbolCache + , lookupInterpSymbolCache + , updateInterpSymbolCache + , purgeInterpSymbolCache + , InterpSymbol(..) + , SuffixOrInterpreted(..) + , interpSymbolName + , interpSymbolSuffix + , eliminateInterpSymbol + , interpretedInterpSymbol + , interpreterProfiled + , interpreterDynamic + -- * IServ , IServ , IServConfig(..) @@ -20,6 +37,8 @@ , JSState (..) , NodeJsSettings (..) , defaultNodeJsSettings + , WasmInterp + , WasmInterpConfig (..) ) where @@ -28,16 +47,19 @@ import GHCi.RemoteTypes import GHCi.Message ( Pipe ) -import GHC.Types.Unique.FM -import GHC.Data.FastString ( FastString ) -import Foreign +import GHC.Platform +#if defined(HAVE_INTERNAL_INTERPRETER) +import GHC.Platform.Ways +#endif import GHC.Utils.TmpFs import GHC.Utils.Logger import GHC.Unit.Env +import GHC.Unit.State import GHC.Unit.Types import GHC.StgToJS.Types import GHC.StgToJS.Linker.Types +import GHC.Runtime.Interpreter.Types.SymbolCache import Control.Concurrent import System.Process ( ProcessHandle, CreateProcess ) @@ -52,7 +74,7 @@ , interpLoader :: !Loader -- ^ Interpreter loader - , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) + , interpSymbolCache :: !InterpSymbolCache -- ^ LookupSymbol cache } @@ -65,6 +87,7 @@ data ExtInterp = ExtIServ !IServ | ExtJS !JSInterp + | ExtWasm !WasmInterp -- | External interpreter -- @@ -80,10 +103,12 @@ type IServ = ExtInterpState IServConfig () type JSInterp = ExtInterpState JSInterpConfig JSInterpExtra +type WasmInterp = ExtInterpState WasmInterpConfig () data InterpProcess = InterpProcess { interpPipe :: !Pipe -- ^ Pipe to communicate with the server , interpHandle :: !ProcessHandle -- ^ Process handle of the server + , interpLock :: !(MVar ()) -- ^ Lock to prevent concurrent access to the stream } -- | Status of an external interpreter @@ -115,6 +140,28 @@ -- ^ Instance specific extra fields } +-- | Interpreter uses Profiling way +interpreterProfiled :: Interp -> Bool +interpreterProfiled interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsProfiled +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfProfiled (interpConfig i) + ExtJS {} -> False -- we don't support profiling yet in the JS backend + ExtWasm i -> wasmInterpProfiled $ interpConfig i + +-- | Interpreter uses Dynamic way +interpreterDynamic :: Interp -> Bool +interpreterDynamic interp = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> hostIsDynamic +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> iservConfDynamic (interpConfig i) + ExtJS {} -> False -- dynamic doesn't make sense for JS + ExtWasm {} -> True -- wasm dyld can only load dynamic code + ------------------------ -- JS Stuff ------------------------ @@ -161,3 +208,26 @@ , jsInterpFinderCache :: !FinderCache } +------------------------ +-- Wasm Stuff +------------------------ + +data WasmInterpConfig = WasmInterpConfig + { wasmInterpDyLD :: !FilePath -- ^ Location of dyld.mjs script + , wasmInterpLibDir :: FilePath -- ^ wasi-sdk sysroot libdir containing libc.so, etc + , wasmInterpOpts :: ![String] -- ^ Additional command line arguments for iserv + + -- wasm ghci browser mode + , wasmInterpBrowser :: !Bool + , wasmInterpBrowserHost :: !String + , wasmInterpBrowserPort :: !Int + , wasmInterpBrowserRedirectWasiConsole :: !Bool + , wasmInterpBrowserPuppeteerLaunchOpts :: !(Maybe String) + , wasmInterpBrowserPlaywrightBrowserType :: !(Maybe String) + , wasmInterpBrowserPlaywrightLaunchOpts :: !(Maybe String) + + , wasmInterpTargetPlatform :: !Platform + , wasmInterpProfiled :: !Bool -- ^ Are we profiling yet? + , wasmInterpHsSoSuffix :: !String -- ^ Shared lib filename common suffix sans .so, e.g. p-ghc9.13.20241001 + , wasmInterpUnitState :: !UnitState + } diff --git a/GHC/Runtime/Interpreter/Types/SymbolCache.hs b/GHC/Runtime/Interpreter/Types/SymbolCache.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Types/SymbolCache.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} + +-- | The SymbolCache is used to cache lookups for specific symbols when using +-- the interpreter. +module GHC.Runtime.Interpreter.Types.SymbolCache ( + InterpSymbolCache(..) + , mkInterpSymbolCache + , lookupInterpSymbolCache + , updateInterpSymbolCache + , purgeInterpSymbolCache + , InterpSymbol(..) + , SuffixOrInterpreted(..) + , interpSymbolName + , interpSymbolSuffix + , eliminateInterpSymbol + , interpretedInterpSymbol + ) where + +import GHC.Prelude + +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Data.FastString +import Foreign + +import Control.Concurrent +import GHC.Utils.Outputable +import GHC.TypeLits + + +-- The symbols records the suffix which each cache deals with. +newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) } + +-- Each cache is keyed by Name, there is one cache for each type of symbol we will +-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult +-- a complicated `FastString` each time. +data InterpSymbolCache = InterpSymbolCache { + interpClosureCache :: MVar (SymbolCache "closure") + , interpConInfoCache :: MVar (SymbolCache "con_info") + , interpStaticInfoCache :: MVar (SymbolCache "static_info") + , interpBytesCache :: MVar (SymbolCache "bytes") + , interpFaststringCache :: MVar (UniqFM FastString (Ptr ())) + } + +data SuffixOrInterpreted = Suffix Symbol | Interpreted + +data InterpSymbol (s :: SuffixOrInterpreted) where + IClosureSymbol :: Name -> InterpSymbol (Suffix "closure") + IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info") + IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info") + IBytesSymbol :: Name -> InterpSymbol (Suffix "bytes") + IFaststringSymbol :: FastString -> InterpSymbol Interpreted + +instance Outputable (InterpSymbol s) where + ppr s = eliminateInterpSymbol s + (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s) + (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s)) + +eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r) + -> (forall x . InterpSymbol (Suffix x) -> r) + -> r +eliminateInterpSymbol s k1 k2 = + case s of + IFaststringSymbol {} -> k1 s + IBytesSymbol {} -> k2 s + IStaticInfoSymbol {} -> k2 s + IConInfoSymbol {} -> k2 s + IClosureSymbol {} -> k2 s + + +interpSymbolName :: InterpSymbol (Suffix s) -> Name +interpSymbolName (IClosureSymbol n) = n +interpSymbolName (IConInfoSymbol n) = n +interpSymbolName (IStaticInfoSymbol n) = n +interpSymbolName (IBytesSymbol n) = n + +interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString +interpretedInterpSymbol (IFaststringSymbol s) = s + +interpSymbolSuffix :: InterpSymbol (Suffix s) -> String +interpSymbolSuffix (IClosureSymbol {}) = "closure" +interpSymbolSuffix (IConInfoSymbol {}) = "con_info" +interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info" +interpSymbolSuffix (IBytesSymbol {}) = "bytes" + +emptySymbolCache :: SymbolCache s +emptySymbolCache = SymbolCache emptyUFM + +lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ()) +lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s) + +insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s +insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v) + +lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ())) +lookupInterpSymbolCache = withInterpSymbolCache + (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var) + (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var) + + +updateInterpSymbolCache :: InterpSymbol s + -> InterpSymbolCache -> Ptr () -> IO () +updateInterpSymbolCache = withInterpSymbolCache + (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v)) + (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache)) + +withInterpSymbolCache :: + (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r) + -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r) + -> InterpSymbol s + -> InterpSymbolCache + -> r +withInterpSymbolCache k1 k2 key InterpSymbolCache{..} = + case key of + IClosureSymbol {} -> k2 key interpClosureCache + IConInfoSymbol {} -> k2 key interpConInfoCache + IStaticInfoSymbol {} -> k2 key interpStaticInfoCache + IBytesSymbol {} -> k2 key interpBytesCache + IFaststringSymbol {} -> k1 key interpFaststringCache + +-- | Clear all symbol caches. +purgeInterpSymbolCache :: InterpSymbolCache -> IO () +purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do + modifyMVar_ a (\_ -> do + modifyMVar_ b (\_ -> do + modifyMVar_ c (\_ -> do + modifyMVar_ d (\_ -> do + modifyMVar_ e (\_ -> pure emptyUFM) + pure emptySymbolCache) + pure emptySymbolCache) + pure emptySymbolCache) + pure emptySymbolCache) + +mkInterpSymbolCache :: IO InterpSymbolCache +mkInterpSymbolCache = do + InterpSymbolCache <$> newMVar emptySymbolCache + <*> newMVar emptySymbolCache + <*> newMVar emptySymbolCache + <*> newMVar emptySymbolCache + <*> newMVar emptyUFM diff --git a/GHC/Runtime/Interpreter/Wasm.hs b/GHC/Runtime/Interpreter/Wasm.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Wasm.hs @@ -0,0 +1,94 @@ +{-# 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.Maybe +import GHC.Data.FastString +import qualified GHC.Data.ShortText as ST +import GHC.Platform +import GHC.Unit +import GHCi.Message +import System.Directory +import System.Environment.Blank +import System.IO +import qualified System.Posix.IO as Posix +import System.Process + +#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 + ghc_env <- getEnvironment + let dyld_env = + [("GHCI_BROWSER", "1") | wasmInterpBrowser] + ++ [("GHCI_BROWSER_HOST", wasmInterpBrowserHost), ("GHCI_BROWSER_PORT", show wasmInterpBrowserPort)] + ++ [("GHCI_BROWSER_REDIRECT_WASI_CONSOLE", "1") | wasmInterpBrowserRedirectWasiConsole] + ++ [("GHCI_BROWSER_PUPPETEER_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPuppeteerLaunchOpts] + ++ [("GHCI_BROWSER_PLAYWRIGHT_BROWSER_TYPE", f) | f <- maybeToList wasmInterpBrowserPlaywrightBrowserType] + ++ [("GHCI_BROWSER_PLAYWRIGHT_LAUNCH_OPTS", f) | f <- maybeToList wasmInterpBrowserPlaywrightLaunchOpts] + ++ ghc_env + (_, _, _, ph) <- + createProcess + ( proc wasmInterpDyLD $ + [wasmInterpLibDir, ghci_so_path, show wfd1, show rfd2] + ++ wasmInterpOpts + ++ ["+RTS", "-H64m", "-RTS"] + ) { env = Just dyld_env } + Posix.closeFd wfd1 + Posix.closeFd rfd2 + rh <- Posix.fdToHandle rfd1 + wh <- Posix.fdToHandle wfd2 + hSetBuffering wh NoBuffering + hSetBuffering rh NoBuffering + interpPipe <- mkPipeFromHandles rh wh + pending_frees <- newMVar [] + lock <- newMVar () + pure + $ ExtInterpInstance + { instProcess = + InterpProcess + { interpHandle = ph, + interpPipe, + 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 diff --git a/GHC/Runtime/Loader.hs b/GHC/Runtime/Loader.hs --- a/GHC/Runtime/Loader.hs +++ b/GHC/Runtime/Loader.hs @@ -49,15 +49,15 @@ 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 import GHC.Types.Unique.DFM import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) -import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) -import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit) ) +import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface import GHC.Unit.Env @@ -120,14 +120,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) @@ -213,7 +214,7 @@ ; case eith_plugin of Left actual_type -> throwGhcExceptionIO (CmdLineError $ - showSDocForUser dflags (ue_units (hsc_unit_env hsc_env)) + showSDocForUser dflags (ue_homeUnitState (hsc_unit_env hsc_env)) alwaysQualify $ hsep [ text "The value", ppr name , text "with type", ppr actual_type @@ -341,13 +342,8 @@ -> IO (Maybe (Name, ModIface)) lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - let fc = hsc_FC hsc_env - let unit_env = hsc_unit_env hsc_env - let unit_state = ue_units unit_env - let mhome_unit = hsc_home_unit_maybe hsc_env -- First find the unit the module resides in by searching exposed units and home modules - found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name + found_module <- findPluginModule hsc_env mod_name case found_module of Found _ mod -> do -- Find the exports of the module @@ -357,8 +353,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, is_level = SpliceLevel } imp_spec = ImpSpec decl_spec ImpAll env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) diff --git a/GHC/Settings.hs b/GHC/Settings.hs --- a/GHC/Settings.hs +++ b/GHC/Settings.hs @@ -5,6 +5,7 @@ ( Settings (..) , ToolSettings (..) , FileSettings (..) + , UnitSettings(..) , GhcNameVersion (..) , Platform (..) , PlatformMisc (..) @@ -19,21 +20,22 @@ , sGlobalPackageDatabasePath , sLdSupportsCompactUnwind , sLdSupportsFilelist - , sLdSupportsResponseFiles + , sMergeObjsSupportsResponseFiles , sLdIsGnuLd , sGccSupportsNoPie , sUseInplaceMinGW , sArSupportsDashL , sPgm_L , sPgm_P + , sPgm_JSP + , sPgm_CmmP , sPgm_F , sPgm_c , sPgm_cxx + , sPgm_cpp , sPgm_a , sPgm_l , sPgm_lm - , sPgm_dll - , sPgm_T , sPgm_windres , sPgm_ar , sPgm_otool @@ -41,11 +43,15 @@ , sPgm_ranlib , sPgm_lo , sPgm_lc - , sPgm_lcc + , sPgm_las , sPgm_i , sOpt_L , sOpt_P , sOpt_P_fingerprint + , sOpt_JSP + , sOpt_JSP_fingerprint + , sOpt_CmmP + , sOpt_CmmP_fingerprint , sOpt_F , sOpt_c , sOpt_cxx @@ -55,12 +61,12 @@ , sOpt_windres , sOpt_lo , sOpt_lc - , sOpt_lcc , sOpt_i , sExtraGccViaCFlags , sTargetPlatformString , sGhcWithInterpreter , sLibFFI + , sTargetRTSLinkerOnlySupportsSharedLibs ) where import GHC.Prelude @@ -68,6 +74,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform +import GHC.Unit.Types data Settings = Settings { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion @@ -75,12 +82,15 @@ , sTargetPlatform :: Platform -- Filled in by SysTools , sToolSettings :: {-# UNPACK #-} !ToolSettings , sPlatformMisc :: {-# UNPACK #-} !PlatformMisc + , sUnitSettings :: !UnitSettings -- You shouldn't need to look things up in rawSettings directly. -- They should have their own fields instead. , sRawSettings :: [(String, String)] } +data UnitSettings = UnitSettings { unitSettings_baseUnitId :: !UnitId } + -- | Settings for other executables GHC calls. -- -- Probably should further split down by phase, or split between @@ -88,27 +98,33 @@ data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool , toolSettings_ldSupportsFilelist :: Bool - , toolSettings_ldSupportsResponseFiles :: Bool , toolSettings_ldSupportsSingleModule :: Bool + , toolSettings_mergeObjsSupportsResponseFiles :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool , toolSettings_useInplaceMinGW :: Bool , toolSettings_arSupportsDashL :: Bool + , toolSettings_cmmCppSupportsG0 :: Bool -- commands for particular phases , toolSettings_pgm_L :: String - , toolSettings_pgm_P :: (String, [Option]) + , -- | The Haskell C preprocessor and default options (not added by -optP) + toolSettings_pgm_P :: (String, [Option]) + , -- | The JavaScript C preprocessor and default options (not added by -optP) + toolSettings_pgm_JSP :: (String, [Option]) + , -- | The C-- C Preprocessor and default options (not added by -optP) + toolSettings_pgm_CmmP :: (String, [Option]) , toolSettings_pgm_F :: String , toolSettings_pgm_c :: String , toolSettings_pgm_cxx :: String + , -- | The C preprocessor (distinct from the Haskell C preprocessor!) + toolSettings_pgm_cpp :: (String, [Option]) , toolSettings_pgm_a :: (String, [Option]) , toolSettings_pgm_l :: (String, [Option]) , toolSettings_pgm_lm :: Maybe (String, [Option]) -- ^ N.B. On Windows we don't have a linker which supports object -- merging, hence the 'Maybe'. See Note [Object merging] in -- "GHC.Driver.Pipeline.Execute" for details. - , toolSettings_pgm_dll :: (String, [Option]) - , toolSettings_pgm_T :: String , toolSettings_pgm_windres :: String , toolSettings_pgm_ar :: String , toolSettings_pgm_otool :: String @@ -118,16 +134,24 @@ toolSettings_pgm_lo :: (String, [Option]) , -- | LLVM: llc static compiler toolSettings_pgm_lc :: (String, [Option]) - , -- | LLVM: c compiler - toolSettings_pgm_lcc :: (String, [Option]) + -- | LLVM: assembler + , toolSettings_pgm_las :: (String, [Option]) , toolSettings_pgm_i :: String -- options for particular phases , toolSettings_opt_L :: [String] , toolSettings_opt_P :: [String] + , toolSettings_opt_JSP :: [String] + , toolSettings_opt_CmmP :: [String] , -- | cached Fingerprint of sOpt_P -- See Note [Repeated -optP hashing] - toolSettings_opt_P_fingerprint :: Fingerprint + toolSettings_opt_P_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_JSP + -- See Note [Repeated -optP hashing] + toolSettings_opt_JSP_fingerprint :: Fingerprint + , -- | cached Fingerprint of sOpt_CmmP + -- See Note [Repeated -optP hashing] + toolSettings_opt_CmmP_fingerprint :: Fingerprint , toolSettings_opt_F :: [String] , toolSettings_opt_c :: [String] , toolSettings_opt_cxx :: [String] @@ -139,8 +163,7 @@ toolSettings_opt_lo :: [String] , -- | LLVM: llc static compiler toolSettings_opt_lc :: [String] - , -- | LLVM: c compiler - toolSettings_opt_lcc :: [String] + , toolSettings_opt_las :: [String] , -- | iserv options toolSettings_opt_i :: [String] @@ -192,8 +215,8 @@ sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings -sLdSupportsResponseFiles :: Settings -> Bool -sLdSupportsResponseFiles = toolSettings_ldSupportsResponseFiles . sToolSettings +sMergeObjsSupportsResponseFiles :: Settings -> Bool +sMergeObjsSupportsResponseFiles = toolSettings_mergeObjsSupportsResponseFiles . sToolSettings sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool @@ -207,22 +230,24 @@ sPgm_L = toolSettings_pgm_L . sToolSettings sPgm_P :: Settings -> (String, [Option]) sPgm_P = toolSettings_pgm_P . sToolSettings +sPgm_JSP :: Settings -> (String, [Option]) +sPgm_JSP = toolSettings_pgm_JSP . sToolSettings +sPgm_CmmP :: Settings -> (String, [Option]) +sPgm_CmmP = toolSettings_pgm_CmmP . sToolSettings sPgm_F :: Settings -> String sPgm_F = toolSettings_pgm_F . sToolSettings sPgm_c :: Settings -> String sPgm_c = toolSettings_pgm_c . sToolSettings sPgm_cxx :: Settings -> String sPgm_cxx = toolSettings_pgm_cxx . sToolSettings +sPgm_cpp :: Settings -> (String, [Option]) +sPgm_cpp = toolSettings_pgm_cpp . sToolSettings sPgm_a :: Settings -> (String, [Option]) sPgm_a = toolSettings_pgm_a . sToolSettings sPgm_l :: Settings -> (String, [Option]) sPgm_l = toolSettings_pgm_l . sToolSettings sPgm_lm :: Settings -> Maybe (String, [Option]) sPgm_lm = toolSettings_pgm_lm . sToolSettings -sPgm_dll :: Settings -> (String, [Option]) -sPgm_dll = toolSettings_pgm_dll . sToolSettings -sPgm_T :: Settings -> String -sPgm_T = toolSettings_pgm_T . sToolSettings sPgm_windres :: Settings -> String sPgm_windres = toolSettings_pgm_windres . sToolSettings sPgm_ar :: Settings -> String @@ -237,8 +262,8 @@ sPgm_lo = toolSettings_pgm_lo . sToolSettings sPgm_lc :: Settings -> (String, [Option]) sPgm_lc = toolSettings_pgm_lc . sToolSettings -sPgm_lcc :: Settings -> (String, [Option]) -sPgm_lcc = toolSettings_pgm_lcc . sToolSettings +sPgm_las :: Settings -> (String, [Option]) +sPgm_las = toolSettings_pgm_las . sToolSettings sPgm_i :: Settings -> String sPgm_i = toolSettings_pgm_i . sToolSettings sOpt_L :: Settings -> [String] @@ -247,6 +272,14 @@ sOpt_P = toolSettings_opt_P . sToolSettings sOpt_P_fingerprint :: Settings -> Fingerprint sOpt_P_fingerprint = toolSettings_opt_P_fingerprint . sToolSettings +sOpt_JSP :: Settings -> [String] +sOpt_JSP = toolSettings_opt_JSP . sToolSettings +sOpt_JSP_fingerprint :: Settings -> Fingerprint +sOpt_JSP_fingerprint = toolSettings_opt_JSP_fingerprint . sToolSettings +sOpt_CmmP :: Settings -> [String] +sOpt_CmmP = toolSettings_opt_CmmP . sToolSettings +sOpt_CmmP_fingerprint :: Settings -> Fingerprint +sOpt_CmmP_fingerprint = toolSettings_opt_CmmP_fingerprint . sToolSettings sOpt_F :: Settings -> [String] sOpt_F = toolSettings_opt_F . sToolSettings sOpt_c :: Settings -> [String] @@ -265,8 +298,6 @@ sOpt_lo = toolSettings_opt_lo . sToolSettings sOpt_lc :: Settings -> [String] sOpt_lc = toolSettings_opt_lc . sToolSettings -sOpt_lcc :: Settings -> [String] -sOpt_lcc = toolSettings_opt_lcc . sToolSettings sOpt_i :: Settings -> [String] sOpt_i = toolSettings_opt_i . sToolSettings @@ -279,3 +310,6 @@ sGhcWithInterpreter = platformMisc_ghcWithInterpreter . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc + +sTargetRTSLinkerOnlySupportsSharedLibs :: Settings -> Bool +sTargetRTSLinkerOnlySupportsSharedLibs = platformMisc_targetRTSLinkerOnlySupportsSharedLibs . sPlatformMisc diff --git a/GHC/Settings/Constants.hs b/GHC/Settings/Constants.hs --- a/GHC/Settings/Constants.hs +++ b/GHC/Settings/Constants.hs @@ -30,7 +30,7 @@ mAX_SOLVER_ITERATIONS :: Int mAX_SOLVER_ITERATIONS = 4 --- | In case of loopy quantified costraints constraints, +-- | In case of loopy quantified constraints constraints, -- how many times should we allow superclass expansions -- Should be less than mAX_SOLVER_ITERATIONS -- See Note [Expanding Recursive Superclasses and ExpansionFuel] diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs --- a/GHC/Settings/IO.hs +++ b/GHC/Settings/IO.hs @@ -19,14 +19,16 @@ import GHC.ResponseFile import GHC.Settings import GHC.SysTools.BaseDir +import GHC.Unit.Types -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 @@ -40,7 +42,7 @@ let installed :: FilePath -> FilePath installed file = top_dir file libexec :: FilePath -> FilePath - libexec file = top_dir "bin" file + libexec file = top_dir ".." "bin" file settingsFile = installed "settings" readFileSafe :: FilePath -> ExceptT SettingsError m String @@ -70,34 +72,51 @@ 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. - 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" + targetPlatformString <- getSetting_raw "target platform string" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command" - cc_args_str <- getToolSetting "C compiler flags" - cxx_args_str <- getToolSetting "C++ compiler flags" + cc_args0 <- getFlagsSetting "C compiler flags" + cxx_args <- getFlagsSetting "C++ compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" - cpp_prog <- getToolSetting "Haskell CPP command" - cpp_args_str <- getToolSetting "Haskell CPP flags" + cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0" + cpp_prog <- getToolSetting "CPP command" + cpp_args <- map Option <$> getFlagsSetting "CPP flags" + hs_cpp_prog <- getToolSetting "Haskell CPP command" + hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags" + js_cpp_prog <- getToolSetting "JavaScript CPP command" + js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags" + cmmCpp_prog <- getToolSetting "C-- CPP command" + cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags" platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"] else [] - cpp_args = map Option (unescapeArgs cpp_args_str) - cc_args = unescapeArgs cc_args_str ++ unreg_cc_args - cxx_args = unescapeArgs cxx_args_str + cc_args = cc_args0 ++ unreg_cc_args -- The extra flags we need to pass gcc when we invoke it to compile .hc code. -- @@ -110,13 +129,19 @@ ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" - ldSupportsResponseFiles <- getBooleanSetting "ld supports response files" ldSupportsSingleModule <- getBooleanSetting "ld supports single module" + mergeObjsSupportsResponseFiles <- getBooleanSetting "Merge objects supports response files" 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 @@ -129,40 +154,38 @@ install_name_tool_path <- getToolSetting "install_name_tool command" ranlib_path <- getToolSetting "ranlib command" - touch_path <- getToolSetting "touch command" - - mkdll_prog <- getToolSetting "dllwrap command" - let mkdll_args = [] - - -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - -- Other things being equal, as and ld are simply gcc - cc_link_args_str <- getToolSetting "C compiler link flags" + -- Other things being equal, 'as' and 'ld' are simply 'gcc' + cc_link_args <- getFlagsSetting "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 ++ unescapeArgs cc_link_args_str) + ld_args = map Option (cc_args ++ cc_link_args) ld_r_prog <- getToolSetting "Merge objects command" - ld_r_args <- getToolSetting "Merge objects flags" + ld_r_args <- getFlagsSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing - | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args) + | otherwise = Just (ld_r_prog, map Option ld_r_args) - llvmTarget <- getSetting "LLVM target" + llvmTarget <- getSetting_raw "LLVM target" -- We just assume on command line - lc_prog <- getSetting "LLVM llc command" - lo_prog <- getSetting "LLVM opt command" - lcc_prog <- getSetting "LLVM clang command" + lc_prog <- getToolSetting "LLVM llc command" + lo_prog <- getToolSetting "LLVM opt command" + las_prog <- getToolSetting "LLVM llvm-as command" + las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags" let iserv_prog = libexec "ghc-iserv" + targetRTSLinkerOnlySupportsSharedLibs <- getBooleanSetting "target RTS linker only supports shared libraries" ghcWithInterpreter <- getBooleanSetting "Use interpreter" useLibFFI <- getBooleanSetting "Use LibFFI" + baseUnitId <- getSetting_raw "base unit-id" + return $ Settings { sGhcNameVersion = GhcNameVersion { ghcNameVersion_programName = "ghc" @@ -177,26 +200,33 @@ , fileSettings_globalPackageDatabase = globalpkgdb_path } + , sUnitSettings = UnitSettings + { + unitSettings_baseUnitId = stringToUnitId baseUnitId + } + , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind , toolSettings_ldSupportsFilelist = ldSupportsFilelist - , toolSettings_ldSupportsResponseFiles = ldSupportsResponseFiles , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule + , toolSettings_mergeObjsSupportsResponseFiles = mergeObjsSupportsResponseFiles , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW , toolSettings_arSupportsDashL = arSupportsDashL + , toolSettings_cmmCppSupportsG0 = cmmCppSupportsG0 , toolSettings_pgm_L = unlit_path - , toolSettings_pgm_P = (cpp_prog, cpp_args) + , toolSettings_pgm_P = (hs_cpp_prog, hs_cpp_args) + , toolSettings_pgm_JSP = (js_cpp_prog, js_cpp_args) + , toolSettings_pgm_CmmP = (cmmCpp_prog, cmmCpp_args) , toolSettings_pgm_F = "" , toolSettings_pgm_c = cc_prog , toolSettings_pgm_cxx = cxx_prog + , toolSettings_pgm_cpp = (cpp_prog, cpp_args) , toolSettings_pgm_a = (as_prog, as_args) , toolSettings_pgm_l = (ld_prog, ld_args) , toolSettings_pgm_lm = ld_r - , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) - , toolSettings_pgm_T = touch_path , toolSettings_pgm_windres = windres_path , toolSettings_pgm_ar = ar_path , toolSettings_pgm_otool = otool_path @@ -204,11 +234,15 @@ , toolSettings_pgm_ranlib = ranlib_path , toolSettings_pgm_lo = (lo_prog,[]) , toolSettings_pgm_lc = (lc_prog,[]) - , toolSettings_pgm_lcc = (lcc_prog,[]) + , toolSettings_pgm_las = (las_prog, las_args) , toolSettings_pgm_i = iserv_prog , toolSettings_opt_L = [] , toolSettings_opt_P = [] - , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_JSP = [] + , toolSettings_opt_CmmP = [] + , toolSettings_opt_P_fingerprint = fingerprint0 + , toolSettings_opt_JSP_fingerprint = fingerprint0 + , toolSettings_opt_CmmP_fingerprint = fingerprint0 , toolSettings_opt_F = [] , toolSettings_opt_c = cc_args , toolSettings_opt_cxx = cxx_args @@ -216,9 +250,9 @@ , toolSettings_opt_l = [] , toolSettings_opt_lm = [] , toolSettings_opt_windres = [] - , toolSettings_opt_lcc = [] , toolSettings_opt_lo = [] , toolSettings_opt_lc = [] + , toolSettings_opt_las = [] , toolSettings_opt_i = [] , toolSettings_extraGccViaCFlags = extraGccViaCFlags @@ -230,6 +264,7 @@ , platformMisc_ghcWithInterpreter = ghcWithInterpreter , platformMisc_libFFI = useLibFFI , platformMisc_llvmTarget = llvmTarget + , platformMisc_targetRTSLinkerOnlySupportsSharedLibs = targetRTSLinkerOnlySupportsSharedLibs } , sRawSettings = settingsList diff --git a/GHC/Stg/BcPrep.hs b/GHC/Stg/BcPrep.hs --- a/GHC/Stg/BcPrep.hs +++ b/GHC/Stg/BcPrep.hs @@ -170,7 +170,7 @@ We thus must have *some* strategy for dealing with representation-polymorphic and unlifted join points. Representation-polymorphic variables are generally -not allowed (though representation -polymorphic join points *are*; see +not allowed (though representation-polymorphic join points *are*; see Note [Invariants on join points] in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly. The questionable join points are *not-necessarily-lifted join points* diff --git a/GHC/Stg/CSE.hs b/GHC/Stg/CSE.hs --- a/GHC/Stg/CSE.hs +++ b/GHC/Stg/CSE.hs @@ -71,6 +71,11 @@ , Right [x] -> b} +Note that this can revive dead case binders (e.g. "b" above), hence we zap +occurrence information on all case binders during STG CSE. +See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr. + + Note [StgCse after unarisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -104,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 -- @@ -117,6 +124,8 @@ , sam_lit :: LiteralMap a } +type LiteralMap a = Map.Map Literal a + -- TODO(22292): derive instance Functor StgArgMap where fmap f SAM { sam_var = varm, sam_lit = litm } = SAM @@ -133,6 +142,8 @@ foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) filterTM f (SAM {sam_var = varm, sam_lit = litm}) = SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm } + mapMaybeTM f (SAM {sam_var = varm, sam_lit = litm}) = + SAM { sam_var = mapMaybeTM f varm, sam_lit = mapMaybeTM f litm } newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } @@ -149,6 +160,7 @@ m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } foldTM k = un_cam >.> foldTM (foldTM k) filterTM f = un_cam >.> fmap (filterTM f) >.> CAM + mapMaybeTM f = un_cam >.> fmap (mapMaybeTM f) >.> CAM ----------------- -- The CSE Env -- @@ -344,16 +356,20 @@ = let body' = stgCseExpr env body in StgTick tick body' stgCseExpr env (StgCase scrut bndr ty alts) - = mkStgCase scrut' bndr' ty alts' + = mkStgCase scrut' bndr'' ty alts' where scrut' = stgCseExpr env scrut (env1, bndr') = substBndr env bndr + -- we must zap occurrence information on the case binder + -- because CSE might revive it. + -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr + bndr'' = zapIdOccInfo bndr' env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 -- See Note [Trivial case scrutinee] | otherwise = env1 - alts' = map (stgCseAlt env2 ty bndr') alts + alts' = map (stgCseAlt env2 ty bndr'') alts -- A constructor application. diff --git a/GHC/Stg/Debug.hs b/GHC/Stg/Debug.hs --- a/GHC/Stg/Debug.hs +++ b/GHC/Stg/Debug.hs @@ -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 @@ -68,21 +68,25 @@ return (StgRec es) collectStgRhs :: Id -> StgRhs -> M StgRhs -collectStgRhs bndr (StgRhsClosure ext cc us bs e t) = do - let - name = idName bndr - -- If the name has a span, use that initially as the source position in-case - -- we don't get anything better. - with_span = case nameSrcSpan name of - RealSrcSpan pos _ -> withSpan (pos, LexicalFastString $ occNameFS (getOccName name)) - _ -> id - e' <- with_span $ collectExpr e - recordInfo bndr e' - return $ StgRhsClosure ext cc us bs e' t -collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args typ) = do - n' <- numberDataCon dc ticks - return (StgRhsCon cc dc n' ticks args typ) - +collectStgRhs bndr rhs = + case rhs of + StgRhsClosure ext cc us bs e t -> do + e' <- with_span $ collectExpr e + recordInfo bndr e' + return $ StgRhsClosure ext cc us bs e' t + StgRhsCon cc dc _mn ticks args typ -> do + n' <- with_span $ numberDataCon dc ticks + return (StgRhsCon cc dc n' ticks args typ) + where + -- If the binder name has a span, use that initially as the source position + -- in case we don't get anything better + with_span :: M a -> M a + with_span = + let name = idName bndr in + case nameSrcSpan name of + RealSrcSpan pos _ -> + withSpan (pos, LexicalFastString $ occNameFS (getOccName name)) + _ -> id recordInfo :: Id -> StgExpr -> M () recordInfo bndr new_rhs = do @@ -149,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 @@ -162,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 diff --git a/GHC/Stg/EnforceEpt.hs b/GHC/Stg/EnforceEpt.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt.hs @@ -0,0 +1,750 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass + +{-# OPTIONS_GHC -Wname-shadowing #-} +module GHC.Stg.EnforceEpt ( enforceEpt ) where + +import GHC.Prelude hiding (id) + +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Types.Id +import GHC.Types.Id.Info (tagSigInfo) +import GHC.Types.Name +import GHC.Stg.Syntax +import GHC.Types.Basic ( CbvMark (..) ) +import GHC.Types.Demand (isDeadEndAppSig) +import GHC.Types.Unique.Supply (mkSplitUniqSupply) +import GHC.Types.RepType (dataConRuntimeRepStrictness) +import GHC.Core (AltCon(..)) +import Data.List (mapAccumL) +import GHC.Utils.Outputable +import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) + +import GHC.Stg.EnforceEpt.Types +import GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds) +import Data.Maybe +import GHC.Types.Name.Env (mkNameEnv, NameEnv) +import GHC.Driver.DynFlags +import GHC.Utils.Logger +import qualified GHC.Unit.Types + +{- Note [Evaluated and Properly Tagged] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A pointer is Evaluated and Properly Tagged (EPT) when the pointer + + (a) points directly to the value (not to an indirection, and not to a thunk) + (b) is tagged with the tag corresponding to said value (e.g. constructor tag + or arity of a function). + +A binder is EPT when all the runtime pointers it binds are EPT. + +Note that a lifted EPT pointer will never point to a thunk, nor will it be +tagged `000` (meaning "might be a thunk"). + +See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/haskell-execution/pointer-tagging +for more information on pointer tagging. + +Examples: +* Case binders are always EPT; hence an eval + case x of x' { __DEFAULT -> ... } + ensures that x' is EPT even if x was not. +* Data constructor bindings + let x = Just y in ... + are EPT: x will point to the heap-allocated constructor closure for (Just y), + and the tag-bits of the pointer will encode the tag for Just (i.e. `010`). +* In practice, GHC also guarantees that strict fields (and others) are EPT; + see Note [EPT enforcement]. + +Caveat: +Currently, the proper tag for builtin *unlifted* data types such as `Array#` is +not `001` but `000`, which is not a proper tag for lifted data. +This means that UnliftedRep is not a proper sub-rep of LiftedRep. +SG thinks it would be good to fix this; see #21792. + +Note [EPT enforcement] +~~~~~~~~~~~~~~~~~~~~~~ +The goal of EnforceEPT pass is to mark as many binders as possible as EPT +(see Note [Evaluated and Properly Tagged]). +To find more EPT binders, it establishes the following + +EPT INVARIANT: +> Any binder of +> * a strict field (see Note [Strict fields in Core]), or +> * a CBV argument (see Note [CBV Function Ids]) +> is EPT. + +(Note that prior to EPT enforcement, this invariant may *not* always be upheld. +An example can be found at the end of this Note.) +This is all to optimise code such as the following: + + data SPair a b = SP !a !b + case p :: SP Bool Bool of + SP x y -> + case x of + True -> ... + False -> ... + +We can infer that the strict field x is EPT and hence may safely +omit the code to enter x and the check for the presence of a tag that goes along +with it. However we still branch on the tag as usual to jump to the True or +False case. + +Note that for every example involving strict fields we could find a similar +example using CBV functions, e.g. + + $wf x[EPT] y = + case x of + True -> ... + False -> ... + +is the above example translated to use a CBV function $wf. +Note that /any/ strict function can in principle be chosen as a CBV function; +however, we presently only promote worker functions such as $wf to CBV because +we see all its call sites and can use the proper by-value calling convention. +More precisely, with -O0, we guarantee that no CBV functions are visible in +the interface file, so that naïve clients do not need to know how to call CBV +functions. See Note [CBV Function Ids] for more details. + +Specification +------------- +EPT enforcement works like implicit type conversions in C, such as from int to +float, only much simpler (no overloaded operations such as +). +For EPT enforcement, the "type system" in question is whether a binder is +statically EPT. We differentiate "EPT binder" from "non-EPT binder", where the +latter means "might be EPT, but we could not prove it so". +In this sense, EPT binders form a subtype of non-EPT binders. +We differentiate two conversion directions: + + * Downcast: EPT binders can be converted into non-EPT binders for free. + * Upcast: non-EPT binders can be converted into EPT binders by inserting an eval. + +The EPT invariant expresses type signatures. In particular, these type +signatures entail two things: + + * A _precondition_: Any binder that is passed as a CBV arg/strict field + must be EPT (i.e. must have type "EPT binder"). + * A _postcondition_: Any binder of a CBV arg/strict field is EPT. + +EPT enforcement is then simply a matter of figuring out where to insert +Upcasts (remember that Downcasts are free). +Since Upcasts (evals!) are not free, it is desirable to insert as few as possible. +To this end, we run a static *EPT analysis*, the purpose of which is to identify +as many EPT binders as possible. +Beyond discovering case binders and value bindings, EPT analysis exploits the +type signatures provided by the EPT invariant, looks inside returned tuples and +does some limited amount of fixpointing. +Afterwards, the *EPT rewriter* inserts the actual evals realising Upcasts. + +Implementation +-------------- + +* EPT analysis is implemented in GHC.Stg.EnforceEpt.inferTags. + It attaches its result to /binders/, not occurrence sites. +* The EPT rewriter establishes the EPT invariant by inserting evals. That is, if + (a) a binder x is used to + * construct a strict field (`SP x y`), or + * passed as a CBV argument (`$wf x`), + and + (b) x was not inferred EPT, + then the EPT rewriter inserts an eval prior to the call, e.g. + case x of x' { __ DEFAULT -> SP x' y }. + case x of x' { __ DEFAULT -> $wf x' }. + (Recall that the case binder x' is always EPT.) + This is implemented in GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds. + This pass also propagates the EPTness from binders to occurrences. + It is sound to insert evals on strict fields (Note [Strict fields in Core]), + and on CBV arguments as well (Note [CBV Function Ids]). +* We also export the EPTness of top level bindings to allow this optimisation + to work across module boundaries. + NB: The EPT Invariant *must* be upheld, regardless of the optimisation level; + hence EPTness is practically part of the internal ABI of a strict data + constructor or CBV function. Note [CBV Function Ids] contains the details. +* Finally, code generation skips the thunk check when branching on binders that + are EPT. This is done by `cgExpr`/`cgCase` in the backend. + +Evaluation +---------- +EPT enforcement can have large impact on spine-strict tree data structure +performance. For containers the reduction in runtimes with this optimization +was as follows: + +intmap-benchmarks: 89.30% +intset-benchmarks: 90.87% +map-benchmarks: 88.00% +sequence-benchmarks: 99.84% +set-benchmarks: 85.00% +set-operations-intmap:88.64% +set-operations-map: 74.23% +set-operations-set: 76.50% +lookupge-intmap: 89.57% +lookupge-map: 70.95% + +With nofib being ~0.3% faster as well. + +Note that EPT enforcement may cause regressions in rare cases. +For example consider this code: + + foo x = ... + let c = StrictJust x + in ... + +When x cannot be inferred EPT, the rewriter transforms to + + foo x = ... + let c = case x of x' -> StrictJust x' + in ... + +which allocates an additional thunk for `c` that returns the constructor. Boo! + +Note [EPT enforcement lowers strict constructor worker semantics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Core, a saturated application of a strict constructor worker evaluates its +strict fields and thus is *not* a value; see Note [Strict fields in Core]. +This is also the semantics of strict constructor workers in STG *before* EPT +enforcement (see Note [EPT enforcement]) + +However, after enforcing the EPT Invariant, all constructor workers can +effectively be lazy. That is, when actually generating code to allocate the +data constructor, the code generator does not need to evaluate the argument; +that has already been done by the EPT pass. + +Thus for code-gen reasons (StgToX), all constructor workers are considered lazy +after EPT enforcement. + +Note [Why isn't the EPT Invariant enforced during Core passes?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall the definition of the EPT Invariant from Note [EPT enforcement]. +Why can't it be established as an invariant right while desugaring to Core? +The reason is that some Core optimisations, such as FloatOut, will drop or delay +evals whenever they think it useful and thus destroy the Invariant. Example: + + data Set a = Tip | Bin !a (Set a) (Set a) + +We start with + + thk = f () + g x = ...(case thk of xv -> Bin xv Tip Tip)... + +So far so good; the argument to Bin (which is strict) is evaluated. +Now we do float-out. And in doing so we do a reverse binder-swap (see +Note [Binder-swap during float-out] in SetLevels) thus + + g x = ...(case thk of xv -> Bin thk Nil Nil)... + +The goal of the reverse binder-swap is to allow more floating -- and +indeed it does! We float the Bin to top level: + + lvl = Bin thk Tip Tip + g x = ...(case thk of xv -> lvl)... + +Now you can see that the argument of Bin, namely thk, points to the +thunk, not to the value as it did before. + +In short, although it may be rare, the output of Core optimisation passes +might destroy the EPT Invariant, hence we need to enforce the EPT invariant +*after* passes such as FloatOut. +-} + +{- Note [TagInfo of functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The purpose of tag inference is really to figure out when we don't have to enter +value closures. There the meaning of the tag is fairly obvious. +For functions we never make use of the tag info so we have two choices: +* Treat them as TagDunno +* Treat them as TagProper (as they *are* tagged with their arity) and be really + careful to make sure we still enter them when needed. +As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where +it made the code simpler. But besides implementation complexity there isn't any reason +why we couldn't be more rigorous in dealing with functions. + +NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions. +So option two isn't really an option without reworking this anyway. + +Note [EPT enforcement debugging] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a flag -dtag-inference-checks which inserts various +compile/runtime checks in order to ensure the EPT Invariant +holds. It should cover all places +where tags matter and disable optimizations which interfere with checking +the invariant like generation of AP-Thunks. + +Note [Polymorphic StgPass for inferTagExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to reach a fixpoint we sometimes have to re-analyse an expression +multiple times. But after the initial run the Ast will be parameterized by +a different StgPass! To handle this a large part of the analysis is polymorphic +over the exact StgPass we are using. Which allows us to run the analysis on +the output of itself. + +Note [EPT enforcement for interpreted code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The bytecode interpreter has a different behaviour when it comes +to the tagging of binders in certain situations than the StgToCmm code generator. + +a) Tags for let-bindings: + + When compiling a binding for a constructor like `let x = Just True` + Whether `x` will be properly tagged depends on the backend. + For the interpreter x points to a BCO which once + evaluated returns a properly tagged pointer to the heap object. + In the Cmm backend for the same binding we would allocate the constructor right + away and x will immediately be represented by a tagged pointer. + This means for interpreted code we can not assume let bound constructors are + properly tagged. Hence we distinguish between targeting bytecode and native in + the analysis. + We make this differentiation in `mkLetSig` where we simply never assume + lets are tagged when targeting bytecode. + +b) When referencing ids from other modules the Cmm backend will try to put a + proper tag on these references through various means. When doing analysis we + usually predict these cases to improve precision of the analysis. + But to my knowledge the bytecode generator makes no such attempts so we must + not infer imported bindings as tagged. + This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo + + +-} + +{- ********************************************************************* +* * + EPT enforcement pass +* * +********************************************************************* -} + +enforceEpt :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) +enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do + -- pprTraceM "enforceEpt for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) + -- Annotate binders with tag information. + let (!stg_binds_w_tags) = {-# SCC "StgEptInfer" #-} + inferTags for_bytecode stg_binds + putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags) + + let export_tag_info = collectExportInfo stg_binds_w_tags + + -- Rewrite STG to uphold the strict field invariant + us_t <- mkSplitUniqSupply 't' + let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] + + return (rewritten_binds,export_tag_info) + +{- ********************************************************************* +* * + Main inference algorithm +* * +********************************************************************* -} + +type OutputableInferPass p = (Outputable (TagEnv p) + , Outputable (GenStgExpr p) + , Outputable (BinderP p) + , Outputable (GenStgRhs p)) + +-- | This constraint encodes the fact that no matter what pass +-- we use the Let/Closure extension points are the same as these for +-- 'InferTaggedBinders. +type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders + , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders + , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders) + +inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] +inferTags for_bytecode binds = + -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ + snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) + +----------------------- +inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen + -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders) +inferTagTopBind env (StgTopStringLit id bs) + = (env, StgTopStringLit id bs) +inferTagTopBind env (StgTopLifted bind) + = (env', StgTopLifted bind') + where + (env', bind') = inferTagBind env bind + + +-- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr] +----------------------- +inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p) + => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders) +inferTagExpr env (StgApp fun args) + = --pprTrace "inferTagExpr1" + -- (ppr fun <+> ppr args $$ ppr info $$ + -- text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args) + -- ) + (info, StgApp fun args) + where + !fun_arity = idArity fun + info + -- It's important that we check for bottoms before all else. + -- See Note [Bottom functions are TagTagged] and #24806 for why. + | isDeadEndAppSig (idDmdSig fun) (length args) + = TagTagged + + | fun_arity == 0 -- Unknown arity => Thunk or unknown call + = TagDunno + + | Just (TagSig res_info) <- tagSigInfo (idInfo fun) + , fun_arity == length args -- Saturated + = res_info + + | Just (TagSig res_info) <- lookupSig env fun + , fun_arity == length args -- Saturated + = res_info + + | otherwise + = --pprTrace "inferAppUnknown" (ppr fun) $ + TagDunno + +inferTagExpr env (StgConApp con cn args tys) + = (inferConTag env con args, StgConApp con cn args tys) + +inferTagExpr _ (StgLit l) + = (TagTagged, StgLit l) + +inferTagExpr env (StgTick tick body) + = (info, StgTick tick body') + where + (info, body') = inferTagExpr env body + +inferTagExpr _ (StgOpApp op args ty) + -- Which primops guarantee to return a properly tagged value? + -- Probably none, and that is the conservative assumption anyway. + -- (And foreign calls definitely need not make promises.) + = (TagDunno, StgOpApp op args ty) + +inferTagExpr env (StgLet ext bind body) + = (info, StgLet ext bind' body') + where + (env', bind') = inferTagBind env bind + (info, body') = inferTagExpr env' body + +inferTagExpr env (StgLetNoEscape ext bind body) + = (info, StgLetNoEscape ext bind' body') + where + (env', bind') = inferTagBind env bind + (info, body') = inferTagExpr env' body + +inferTagExpr in_env (StgCase scrut bndr ty alts) + -- Unboxed tuples get their info from the expression we scrutinise if any + | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts + , isUnboxedTupleDataCon con + , Just infos <- scrut_infos bndrs + , let bndrs' = zipWithEqual mk_bndr bndrs infos + mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig) + mk_bndr tup_bndr tup_info = + -- pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $ + (getBinderId in_env tup_bndr, TagSig tup_info) + -- no case binder in alt_env here, unboxed tuple binders are dead after unarise + alt_env = extendSigEnv in_env bndrs' + (info, rhs') = inferTagExpr alt_env rhs + = + -- pprTrace "inferCase1" ( + -- text "scrut:" <> ppr scrut $$ + -- text "bndr:" <> ppr bndr $$ + -- text "infos" <> ppr infos $$ + -- text "out_bndrs" <> ppr bndrs') $ + (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con + , alt_bndrs=bndrs' + , alt_rhs=rhs'}]) + + | null alts -- Empty case, but I might just be paranoid. + = -- pprTrace "inferCase2" empty $ + (TagDunno, StgCase scrut' bndr' ty []) + -- More than one alternative OR non-TagTuple single alternative. + | otherwise + = + let + case_env = extendSigEnv in_env [bndr'] + + (infos, alts') + = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'}) + | g@GenStgAlt{ alt_con = con + , alt_bndrs = bndrs + , alt_rhs = rhs + } <- alts + , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs + (info, rhs') = inferTagExpr alt_env rhs + ] + alt_info = foldr combineAltInfo TagTagged infos + in ( alt_info, StgCase scrut' bndr' ty alts') + where + -- Single unboxed tuple alternative + scrut_infos bndrs = case scrut_info of + TagTagged -> Just $ replicate (length bndrs) TagProper + TagTuple infos -> Just infos + _ -> Nothing + (scrut_info, scrut') = inferTagExpr in_env scrut + bndr' = (getBinderId in_env bndr, TagSig TagProper) + +-- Compute binder sigs based on the constructors strict fields. +-- NB: Not used if we have tuple info from the scrutinee. +addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders]) +addAltBndrInfo env (DataAlt con) bndrs + | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) + = (out_env, out_bndrs) + where + marks = dataConRuntimeRepStrictness con :: [StrictnessMark] + out_bndrs = zipWith mk_bndr bndrs marks + out_env = extendSigEnv env out_bndrs + + mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig)) + mk_bndr bndr mark + | isUnliftedType (idType id) || isMarkedStrict mark + = (id, TagSig TagProper) + | otherwise + = noSig env bndr + where + id = getBinderId env bndr + +addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs) + +----------------------------- +inferTagBind :: (OutputableInferPass p, InferExtEq p) + => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders) +inferTagBind in_env (StgNonRec bndr rhs) + = + -- pprTrace "inferBindNonRec" ( + -- ppr bndr $$ + -- ppr (isDeadEndId id) $$ + -- ppr sig) + (env', StgNonRec (id, out_sig) rhs') + where + id = getBinderId in_env bndr + (in_sig,rhs') = inferTagRhs id in_env rhs + out_sig = mkLetSig in_env in_sig + env' = extendSigEnv in_env [(id, out_sig)] + +inferTagBind in_env (StgRec pairs) + = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $ + (in_env { te_env = out_env }, StgRec pairs') + where + (bndrs, rhss) = unzip pairs + in_ids = map (getBinderId in_env) bndrs + init_sigs = map (initSig) $ zip in_ids rhss + (out_env, pairs') = go in_env init_sigs rhss + + go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q] + -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)]) + go go_env in_sigs go_rhss + -- | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False + -- = undefined + | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss') + | otherwise = go env' out_sigs rhss' + where + in_bndrs = in_ids `zip` in_sigs + out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive + rhs_env = extendSigEnv go_env in_bndrs + (out_sigs, rhss') = unzip (zipWithEqual anaRhs in_ids go_rhss) + env' = makeTagged go_env + + anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders) + anaRhs bnd rhs = + let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs + in (mkLetSig go_env sig_rhs, rhs') + + + updateBndr :: (Id,TagSig) -> (Id,TagSig) + updateBndr (v,sig) = (setIdTagSig v sig, sig) + +initSig :: forall p. (Id, GenStgRhs p) -> TagSig +-- Initial signature for the fixpoint loop +initSig (_bndr, StgRhsCon {}) = TagSig TagTagged +initSig (bndr, StgRhsClosure _ _ _ _ _ _) = + fromMaybe defaultSig (idTagSig_maybe bndr) + where defaultSig = (TagSig TagTagged) + +{- Note [Bottom functions are TagTagged] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a function with two branches with one +being bottom, and the other returning a tagged +unboxed tuple what is the result? We give it TagTagged! +To answer why consider this function: + +foo :: Bool -> (# Bool, Bool #) +foo x = case x of + True -> (# True,True #) + False -> undefined + +The true branch is obviously tagged. The other branch isn't. +We want to treat the *result* of foo as tagged as well so that +the combination of the branches also is tagged if all non-bottom +branches are tagged. +This is safe because the function is still always called/entered as long +as it's applied to arguments. Since the function will never return we can give +it safely any tag sig we like. +So we give it TagTagged, as it allows the combined tag sig of the case expression +to be the combination of all non-bottoming branches. + +NB: After the analysis is done we go back to treating bottoming functions as +untagged to ensure they are evaluated as expected in code like: + + case bottom_id of { ...} + +-} + +----------------------------- +inferTagRhs :: forall p. + (OutputableInferPass p, InferExtEq p) + => Id -- ^ Id we are binding to. + -> TagEnv p -- ^ + -> GenStgRhs p -- ^ + -> (TagSig, GenStgRhs 'InferTaggedBinders) +inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ) + | isDeadEndId bnd_id && (notNull) bndrs + -- See Note [Bottom functions are TagTagged] + = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ) + | otherwise + = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ + (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ) + where + out_bndrs + | Just marks <- idCbvMarks_maybe bnd_id + -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim + -- the list of marks to the last strict entry. So we can conservatively + -- assume these are not strict + = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv) + | otherwise = map (noSig env') bndrs :: [(Id,TagSig)] + + env' = extendSigEnv in_env out_bndrs + (info, body') = inferTagExpr env' body + info' + -- It's a thunk + | null bndrs + = TagDunno + -- TODO: We could preserve tuple fields for thunks + -- as well. But likely not worth the complexity. + + | otherwise = info + + mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig) + mkArgSig bndp mark = + let id = getBinderId in_env bndp + tag = case mark of + MarkedCbv -> TagProper + _ + | isUnliftedType (idType id) -> TagProper + | otherwise -> TagDunno + in (id, TagSig tag) + +inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ) +-- Constructors, which have untagged arguments to strict fields +-- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno + = --pprTrace "inferTagRhsCon" (ppr grp_ids) $ + (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ) + +-- Adjust let semantics to the targeted backend. +-- See Note [EPT enforcement for interpreted code] +mkLetSig :: TagEnv p -> TagSig -> TagSig +mkLetSig env in_sig + | for_bytecode = TagSig TagDunno + | otherwise = in_sig + where + for_bytecode = te_bytecode env + +{- Note [Constructor TagSigs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor +or a StgConApp expression. +Usually these will simply be TagProper. But there are exceptions. +If any of the fields in the constructor are strict, but any argument to these +fields is not tagged then we will have to case on the argument before storing +in the constructor. Which means for let bindings the RHS turns into a thunk +which obviously is no longer properly tagged. +For example we might start with: + + let x = f ... + let c = StrictPair x True + +But we know during the rewrite stage x will need to be evaluated in the RHS +of `c` so we will infer: + + let x = f ... + let c = StrictPair x True + +Which in the rewrite stage will then be rewritten into: + + let x = f ... + let c = case x of x' -> StrictPair x' True + +The other exception is unboxed tuples. These will get a TagTuple +signature with a list of TagInfo about their individual binders +as argument. As example: + + let c = True + let x = ... + let f z = case z of z' -> (# c, x #) + +Here we will infer for f the Signature . +This information will be used if we scrutinize a saturated application of +`f` in order to determine the taggedness of the result. +That is for `case f x of (# r1,r2 #) -> rhs` we can infer +r1 and r2 which allows us to skip all tag checks on `r1` +in `rhs`. + +Things get a bit more complicated with nesting: + + let closeFd = ... + let f x = ... + case x of + _ -> Solo# closeFd + +The "natural" signature for the Solo# branch in `f` would be . +But we flatten this out to for the time being as it improves compile +time and there doesn't seem to huge benefit to doing differently. + + -} + +-- See Note [Constructor TagSigs] +inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo +inferConTag env con args + | isUnboxedTupleDataCon con + = TagTuple $ map (flatten_arg_tag . lookupInfo env) args + | otherwise = + -- pprTrace "inferConTag" + -- ( text "con:" <> ppr con $$ + -- text "args:" <> ppr args $$ + -- text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$ + -- text "arg_info:" <> ppr (map (lookupInfo env) args) $$ + -- text "info:" <> ppr info) $ + info + where + info = if any arg_needs_eval strictArgs then TagDunno else TagProper + strictArgs = zipEqual args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)]) + arg_needs_eval (arg,strict) + -- lazy args + | not (isMarkedStrict strict) = False + | tag <- (lookupInfo env arg) + -- banged args need to be tagged, or require eval + = not (isTaggedInfo tag) + + flatten_arg_tag (TagTagged) = TagProper + flatten_arg_tag (TagProper ) = TagProper + flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs] + flatten_arg_tag (TagDunno) = TagDunno + + +collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig +collectExportInfo binds = + mkNameEnv bndr_info + where + bndr_info = concatMap collect binds :: [(Name,TagSig)] + + collect (StgTopStringLit {}) = [] + collect (StgTopLifted bnd) = + case bnd of + StgNonRec (id,sig) _rhs + | TagSig TagDunno <- sig -> [] + | otherwise -> [(idName id,sig)] + StgRec bnds -> collectRec bnds + + collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)] + collectRec [] = [] + collectRec (bnd:bnds) + | (p,_rhs) <- bnd + , (id,sig) <- p + , TagSig TagDunno <- sig + = (idName id,sig) : collectRec bnds + | otherwise = collectRec bnds diff --git a/GHC/Stg/EnforceEpt/Rewrite.hs b/GHC/Stg/EnforceEpt/Rewrite.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt/Rewrite.hs @@ -0,0 +1,562 @@ + +-- Copyright (c) 2019 Andreas Klebinger +-- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds, rewriteOpApp) +where + +import GHC.Prelude + +import GHC.Builtin.PrimOps ( PrimOp(..) ) +import GHC.Types.Basic ( CbvMark (..), isMarkedCbv + , TopLevelFlag(..), isTopLevel ) +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Unique.Supply +import GHC.Types.Unique.FM +import GHC.Types.RepType +import GHC.Types.Var.Set +import GHC.Unit.Types + +import GHC.Core.DataCon +import GHC.Core ( AltCon(..) ) +import GHC.Core.Type + +import GHC.StgToCmm.Types +import GHC.StgToCmm.Closure (importedIdLFInfo) + +import GHC.Stg.Utils +import GHC.Stg.Syntax as StgSyn + +import GHC.Data.Maybe +import GHC.Utils.Panic + +import GHC.Utils.Outputable +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Misc + +import GHC.Stg.EnforceEpt.Types + +import Control.Monad + +newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } + deriving (Functor, Monad, Applicative) + +------------------------------------------------------------ +-- Add cases around strict fields where required. +------------------------------------------------------------ +{- +The work of this pass is simple: +* We traverse the STG AST looking for constructor allocations. +* For all allocations we check if there are strict fields in the constructor. +* For any strict field we check if the argument is known to be properly tagged. +* If it's not known to be properly tagged, we wrap the whole thing in a case, + which will force the argument before allocation. +This is described in detail in Note [Evaluated and Properly Tagged]. + +The only slight complication is that we have to make sure not to invalidate free +variable analysis in the process. + +Note [Partially applied workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we will get a function f of the form + -- Arity 1 + f :: Dict a -> a -> b -> (c -> d) + f dict a b = case dict of + C m1 m2 -> m1 a b + +Which will result in a W/W split along the lines of + -- Arity 1 + f :: Dict a -> a -> b -> (c -> d) + f dict a = case dict of + C m1 m2 -> $wf m1 a b + + -- Arity 4 + $wf :: (a -> b -> d -> c) -> a -> b -> c -> d + $wf m1 a b c = m1 a b c + +It's notable that the worker is called *undersaturated* in the wrapper. +At runtime what happens is that the wrapper will allocate a PAP which +once fully applied will call the worker. And all is fine. + +But what about a call by value function! Well the function returned by `f` would +be a unknown call, so we lose the ability to enforce the invariant that +cbv marked arguments from StictWorkerId's are actually properly tagged +as the annotations would be unavailable at the (unknown) call site. + +The fix is easy. We eta-expand all calls to functions taking call-by-value +arguments during CorePrep just like we do with constructor allocations. + +Note [Upholding free variable annotations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The code generator requires us to maintain exact information +about free variables about closures. Since we convert some +RHSs from constructor allocations to closures we have to provide +fvs of these closures. Not all constructor arguments will become +free variables. Only these which are not bound at the top level +have to be captured. +To facilitate this we keep track of a set of locally bound variables in +the current context which we then use to filter constructor arguments +when building the free variable list. +-} + +-------------------------------- +-- Utilities +-------------------------------- + +instance MonadUnique RM where + getUniqueSupplyM = RM $ do + (m, us, mod,lcls) <- get + let (us1, us2) = splitUniqSupply us + (put) (m,us2,mod,lcls) + return us1 + +getMap :: RM (UniqFM Id TagSig) +getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) + +setMap :: (UniqFM Id TagSig) -> RM () +setMap !m = RM $ do + (_,us,mod,lcls) <- get + put (m, us,mod,lcls) + +getMod :: RM Module +getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) + +getFVs :: RM IdSet +getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) + +setFVs :: IdSet -> RM () +setFVs !fvs = RM $ do + (tag_map,us,mod,_lcls) <- get + put (tag_map, us,mod,fvs) + +-- Rewrite the RHS(s) while making the id and it's sig available +-- to determine if things are tagged/need to be captured as FV. +withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a +withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont +withBind top_flag (StgRec binds) cont = do + let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders]) + withBinders top_flag bnds cont + +addTopBind :: GenStgBinding 'InferTaggedBinders -> RM () +addTopBind (StgNonRec (id, tag) _) = do + s <- getMap + -- pprTraceM "AddBind" (ppr id) + setMap $ addToUFM s id tag + return () +addTopBind (StgRec binds) = do + let (bnds,_rhss) = unzip binds + !s <- getMap + -- pprTraceM "AddBinds" (ppr $ map fst bnds) + setMap $! addListToUFM s bnds + +withBinder :: TopLevelFlag -> (Id, TagSig) -> RM a -> RM a +withBinder top_flag (id,sig) cont = do + oldMap <- getMap + setMap $ addToUFM oldMap id sig + a <- if isTopLevel top_flag + then cont + else withLcl id cont + setMap oldMap + return a + +withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a +withBinders TopLevel sigs cont = do + oldMap <- getMap + setMap $ addListToUFM oldMap sigs + a <- cont + setMap oldMap + return a +withBinders NotTopLevel sigs cont = do + oldMap <- getMap + oldFvs <- getFVs + setMap $ addListToUFM oldMap sigs + setFVs $ extendVarSetList oldFvs (map fst sigs) + a <- cont + setMap oldMap + setFVs oldFvs + return a + +-- | Compute the argument with the given set of ids treated as requiring capture +-- as free variables. +withClosureLcls :: DIdSet -> RM a -> RM a +withClosureLcls fvs act = do + old_fvs <- getFVs + let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs + setFVs fvs' + !r <- act + setFVs old_fvs + return r + +-- | Compute the argument with the given id treated as requiring capture +-- as free variables in closures. +withLcl :: Id -> RM a -> RM a +withLcl fv act = do + old_fvs <- getFVs + let !fvs' = extendVarSet old_fvs fv + setFVs fvs' + !r <- act + setFVs old_fvs + return r + +{- Note [Tag inference for interactive contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling bytecode we call myCoreToStg to get STG code first. +myCoreToStg in turn calls out to stg2stg which runs the STG to STG +passes followed by free variables analysis and the tag inference pass including +its rewriting phase at the end. +Running tag inference is important as it upholds Note [Evaluated and Properly Tagged]. +While code executed by GHCi doesn't take advantage of the SFI it can call into +compiled code which does. So it must still make sure that the SFI is upheld. +See also #21083 and #22042. + +However there one important difference in code generation for GHCi and regular +compilation. When compiling an entire module (not a GHCi expression), we call +`stg2stg` on the entire module which allows us to build up a map which is guaranteed +to have an entry for every binder in the current module. +For non-interactive compilation the tag inference rewrite pass takes advantage +of this by building up a map from binders to their tag signatures. + +When compiling a GHCi expression on the other hand we invoke stg2stg separately +for each expression on the prompt. This means in GHCi for a sequence of: + > let x = True + > let y = StrictJust x +We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`. + +While computing the tag signature for `y` during tag inference inferConTag will check +if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping. +However since this mapping isn't persistent between stg2stg +invocations the lookup will fail. This isn't a correctness issue since it's always +safe to assume a binding isn't tagged and that's what we do in such cases. + +However for non-interactive mode we *don't* want to do this. Since in non-interactive mode +we have all binders of the module available for each invocation we can expect the binder->signature +mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup +indicates a bug in the tag inference implementation. +For this reason we assert that we are running in interactive mode if a lookup fails. +-} +isTagged :: Id -> RM Bool +isTagged v + -- See Note [Bottom functions are TagTagged] + | isDeadEndId v = pure False + | otherwise = do + this_mod <- getMod + -- See Note [Tag inference for interactive contexts] + let lookupDefault v = assertPpr (isInteractiveModule this_mod) + (text "unknown Id:" <> ppr this_mod <+> ppr v) + (TagSig TagDunno) + case nameIsLocalOrFrom this_mod (idName v) of + True + | definitelyUnliftedType (idType v) + -- NB: v might be the Id of a representation-polymorphic join point, + -- so we shouldn't use isUnliftedType here. See T22212. + -> return True + | otherwise -> do -- Local binding + !s <- getMap + let !sig = lookupWithDefaultUFM s (lookupDefault v) v + return $ case sig of + TagSig info -> + case info of + TagDunno -> False + TagProper -> True + TagTagged -> True + TagTuple _ -> True -- Consider unboxed tuples tagged. + -- Imported + False -> return $! + -- Determine whether it is tagged from the LFInfo of the imported id. + -- See Note [The LFInfo of Imported Ids] + case importedIdLFInfo v of + -- Function, applied not entered. + LFReEntrant {} + -> True + -- Thunks need to be entered. + LFThunk {} + -> False + -- LFCon means we already know the tag, and it's tagged. + LFCon {} + -> True + LFUnknown {} + -> False + LFUnlifted {} + -> True + LFLetNoEscape {} + -- Shouldn't be possible. I don't think we can export letNoEscapes + -> True + + +isArgTagged :: StgArg -> RM Bool +isArgTagged (StgLitArg _) = return True +isArgTagged (StgVarArg v) = isTagged v + +mkLocalArgId :: Id -> RM Id +mkLocalArgId id = do + !u <- getUniqueM + return $! setIdUnique (localiseId id) u + +--------------------------- +-- Actual rewrite pass +--------------------------- + + +rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] +rewriteTopBinds mod us binds = + let doBinds = mapM rewriteTop binds + + in evalState (unRM doBinds) (mempty, us, mod, mempty) + +rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding +rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s) +rewriteTop (StgTopLifted bind) = do + -- Top level bindings can, and must remain in scope + addTopBind bind + (StgTopLifted) <$!> (rewriteBinds TopLevel bind) + +-- For top level binds, the wrapper is guaranteed to be `id` +rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding) +rewriteBinds _top_flag (StgNonRec v rhs) = do + (!rhs) <- rewriteRhs v rhs + return $! (StgNonRec (fst v) rhs) +rewriteBinds top_flag b@(StgRec binds) = + -- Bring sigs of binds into scope for all rhss + withBind top_flag b $ do + (rhss) <- mapM (uncurry rewriteRhs) binds + return $! (mkRec rhss) + where + mkRec :: [TgStgRhs] -> TgStgBinding + mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss) + +-- Rewrite a RHS +rewriteRhs :: (Id,TagSig) -> InferStgRhs + -> RM (TgStgRhs) +rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewriteRhs_ #-} do + -- pprTraceM "rewriteRhs" (ppr _id) + + -- Look up the nodes representing the constructor arguments. + fieldInfos <- mapM isArgTagged args + + -- Filter out non-strict fields. + let strictFields = + getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo) + -- Filter out already tagged arguments. + let needsEval = map fst . --get the actual argument + filter (not . snd) $ -- Keep untagged (False) elements. + strictFields :: [StgArg] + let evalArgs = [v | StgVarArg v <- needsEval] :: [Id] + + if (null evalArgs) + then return $! (StgRhsCon ccs con cn ticks args typ) + else do + --assert not (isTaggedSig tagSig) + -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id + + -- At this point iff we have possibly untagged arguments to strict fields + -- we convert the RHS into a RhsClosure which will evaluate the arguments + -- before allocating the constructor. + let ty_stub = panic "mkSeqs shouldn't use the type arg" + conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub) + + fvs <- fvArgs args + -- lcls <- getFVs + -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls) + + -- We mark the closure updatable to retain sharing in the case that + -- conExpr is an infinite recursive data type. See #23783. + return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ +rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do + withBinders NotTopLevel args $ + withClosureLcls fvs $ + StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ + -- return (closure) + +fvArgs :: [StgArg] -> RM DVarSet +fvArgs args = do + fv_lcls <- getFVs + -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) ) + return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls] + +rewriteArgs :: [StgArg] -> RM [StgArg] +rewriteArgs = mapM rewriteArg +rewriteArg :: StgArg -> RM StgArg +rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v +rewriteArg (lit@StgLitArg{}) = return lit + +rewriteId :: Id -> RM Id +rewriteId v = do + !is_tagged <- isTagged v + if is_tagged then return $! setIdTagSig v (TagSig TagProper) + else return v + +rewriteExpr :: GenStgExpr 'InferTaggedBinders -> RM (GenStgExpr 'CodeGen) +rewriteExpr (e@StgCase {}) = rewriteCase e +rewriteExpr (e@StgLet {}) = rewriteLet e +rewriteExpr (e@StgLetNoEscape {}) = rewriteLetNoEscape e +rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e +rewriteExpr e@(StgConApp {}) = rewriteConApp e +rewriteExpr e@(StgApp {}) = rewriteApp e +rewriteExpr (StgLit lit) = return $! (StgLit lit) +rewriteExpr (StgOpApp op args res_ty) = (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty + + +rewriteCase :: InferStgExpr -> RM TgStgExpr +rewriteCase (StgCase scrut bndr alt_type alts) = + withBinder NotTopLevel bndr $ + pure StgCase <*> + rewriteExpr scrut <*> + rewriteId (fst bndr) <*> + pure alt_type <*> + mapM rewriteAlt alts + +rewriteCase _ = panic "Impossible: nodeCase" + +rewriteAlt :: InferStgAlt -> RM TgStgAlt +rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} = + withBinders NotTopLevel bndrs $ do + !rhs' <- rewriteExpr rhs + return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'} + +rewriteLet :: InferStgExpr -> RM TgStgExpr +rewriteLet (StgLet xt bind expr) = do + (!bind') <- rewriteBinds NotTopLevel bind + withBind NotTopLevel bind $ do + -- pprTraceM "withBindLet" (ppr $ bindersOfX bind) + !expr' <- rewriteExpr expr + return $! (StgLet xt bind' expr') +rewriteLet _ = panic "Impossible" + +rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr +rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do + (!bind') <- rewriteBinds NotTopLevel bind + withBind NotTopLevel bind $ do + !expr' <- rewriteExpr expr + return $! (StgLetNoEscape xt bind' expr') +rewriteLetNoEscape _ = panic "Impossible" + +rewriteConApp :: InferStgExpr -> RM TgStgExpr +rewriteConApp (StgConApp con cn args tys) = do + -- We check if the strict field arguments are already known to be tagged. + -- If not we evaluate them first. + fieldInfos <- mapM isArgTagged args + let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)] + let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg] + let evalArgs = [v | StgVarArg v <- needsEval] :: [Id] + if (not $ null evalArgs) + then do + -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos ) + mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys) + else return $! (StgConApp con cn args tys) + +rewriteConApp _ = panic "Impossible" + +-- Special case: Atomic binders, usually in a case context like `case f of ...`. +rewriteApp :: InferStgExpr -> RM TgStgExpr +rewriteApp (StgApp f []) = do + f' <- rewriteId f + return $! StgApp f' [] +rewriteApp (StgApp f args) + -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False + -- = undefined + | Just marks <- idCbvMarks_maybe f + , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks + , any isMarkedCbv relevant_marks + = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks) + unliftArg relevant_marks + + where + -- If the function expects any argument to be call-by-value ensure the argument is already + -- evaluated. + unliftArg relevant_marks = do + argTags <- mapM isArgTagged args + let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv) argTags :: [(StgArg, CbvMark, Bool)] + + -- untagged cbv argument positions + cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo + cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id] + mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args) + +rewriteApp (StgApp f args) = return $ StgApp f args +rewriteApp _ = panic "Impossible" + +{- +Note [Rewriting primop arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given an application `op# x y`, is it worth applying `rewriteArg` to +`x` and `y`? All that will do will be to set the `tagSig` for that +occurrence of `x` and `y` to record whether it is evaluated and +properly tagged. For the vast majority of primops that's a waste of +time: the argument is an `Int#` or something. + +But code generation for `seq#` and the `dataToTag#` ops /does/ consult that +tag, to statically avoid generating an eval. All three do so via `cgIdApp`, +which in turn uses `getCallMethod` which looks at the `tagSig`. + +So for these we should call `rewriteArgs`. + +-} + +rewriteOpApp :: InferStgExpr -> RM TgStgExpr +rewriteOpApp (StgOpApp op args res_ty) = case op of + op@(StgPrimOp primOp) + | primOp == DataToTagSmallOp || primOp == DataToTagLargeOp + -- see Note [Rewriting primop arguments] + -> (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty + _ -> pure $! StgOpApp op args res_ty +rewriteOpApp _ = panic "Impossible" + +-- `mkSeq` x x' e generates `case x of x' -> e` +-- We could also substitute x' for x in e but that's so rarely beneficial +-- that we don't bother. +mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr +mkSeq id bndr !expr = + -- pprTrace "mkSeq" (ppr (id,bndr)) $ + let altTy = mkStgAltTypeFromStgAlts bndr alt + alt = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}] + in StgCase (StgApp id []) bndr altTy alt + +-- `mkSeqs args vs mkExpr` will force all vs, and construct +-- an argument list args' where each v is replaced by it's evaluated +-- counterpart v'. +-- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then +-- the result will be (case x of x' { _DEFAULT -> } +{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr +mkSeqs :: [StgArg] -- ^ Original arguments + -> [Id] -- ^ var args to be evaluated ahead of time + -> ([StgArg] -> TgStgExpr) + -- ^ Function that reconstructs the expressions when passed + -- the list of evaluated arguments. + -> RM TgStgExpr +mkSeqs args untaggedIds mkExpr = do + argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)] + -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap + let taggedArgs :: [StgArg] + = map (\v -> case v of + StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap + lit -> lit) + args + + let conBody = mkExpr taggedArgs + let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap + return $! body + +-- Out of all arguments passed at runtime only return these ending up in a +-- strict field +getStrictConArgs :: Outputable a => DataCon -> [a] -> [a] +getStrictConArgs con args + -- These are always lazy in their arguments. + | isUnboxedTupleDataCon con = [] + | isUnboxedSumDataCon con = [] + -- For proper data cons we have to check. + | otherwise = + assertPpr (length args == length (dataConRuntimeRepStrictness con)) + (text "Mismatched con arg and con rep strictness lengths:" $$ + text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$ + text "But seems to have arity" <> ppr (length repStrictness)) $ + [ arg | (arg,MarkedStrict) + <- zipEqual args + repStrictness] + where + repStrictness = (dataConRuntimeRepStrictness con) diff --git a/GHC/Stg/EnforceEpt/TagSig.hs b/GHC/Stg/EnforceEpt/TagSig.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt/TagSig.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- We export this type from this module instead of GHC.Stg.EnforceEpt.Types +-- because it's used by more than the analysis itself. For example in interface +-- files where we record a tag signature for bindings. +-- By putting the sig into its own module we can avoid module loops. +module GHC.Stg.EnforceEpt.TagSig + +where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Name.Env( NameEnv ) +import GHC.Utils.Outputable +import GHC.Utils.Binary +import GHC.Utils.Panic.Plain +import Data.Coerce + +-- | Information to be exposed in interface files which is produced +-- by the stg2stg passes. +type StgCgInfos = NameEnv TagSig + +newtype TagSig -- The signature for each binding, this is a newtype as we might + -- want to track more information in the future. + = TagSig TagInfo + deriving (Eq) + +data TagInfo + = TagDunno -- We don't know anything about the tag. + | TagTuple [TagInfo] -- Represents a function/thunk which when evaluated + -- will return a Unboxed tuple whos components have + -- the given TagInfos. + | TagProper -- Heap pointer to properly-tagged value + | TagTagged -- Bottom of the domain. + deriving (Eq) + +instance Outputable TagInfo where + ppr TagTagged = text "TagTagged" + ppr TagDunno = text "TagDunno" + ppr TagProper = text "TagProper" + ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis) + +instance Binary TagInfo where + put_ bh TagDunno = putByte bh 1 + put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds + put_ bh TagProper = putByte bh 3 + put_ bh TagTagged = putByte bh 4 + + get bh = do tag <- getByte bh + case tag of 1 -> return TagDunno + 2 -> TagTuple <$> get bh + 3 -> return TagProper + 4 -> return TagTagged + _ -> panic ("get TagInfo " ++ show tag) + +instance Outputable TagSig where + ppr (TagSig ti) = char '<' <> ppr ti <> char '>' +instance OutputableBndr (Id,TagSig) where + pprInfixOcc = ppr + pprPrefixOcc = ppr + +instance Binary TagSig where + put_ bh (TagSig sig) = put_ bh sig + get bh = pure TagSig <*> get bh + +isTaggedSig :: TagSig -> Bool +isTaggedSig (TagSig TagProper) = True +isTaggedSig (TagSig TagTagged) = True +isTaggedSig _ = False + +seqTagSig :: TagSig -> () +seqTagSig = coerce seqTagInfo + +seqTagInfo :: TagInfo -> () +seqTagInfo TagTagged = () +seqTagInfo TagDunno = () +seqTagInfo TagProper = () +seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis diff --git a/GHC/Stg/EnforceEpt/Types.hs b/GHC/Stg/EnforceEpt/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/EnforceEpt/Types.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +{-# LANGUAGE UndecidableInstances #-} + -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen + +module GHC.Stg.EnforceEpt.Types + ( module GHC.Stg.EnforceEpt.Types + , module TagSig) +where + +import GHC.Prelude + +import GHC.Core.DataCon +import GHC.Core.Type (isUnliftedType) +import GHC.Types.Id +import GHC.Stg.Syntax +import GHC.Stg.EnforceEpt.TagSig as TagSig +import GHC.Types.Var.Env +import GHC.Utils.Outputable +import GHC.Utils.Misc( zipWithEqual ) +import GHC.Utils.Panic + +import GHC.StgToCmm.Types + +{- ********************************************************************* +* * + Supporting data types +* * +********************************************************************* -} + +type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders +type InferStgBinding = GenStgBinding 'InferTaggedBinders +type InferStgExpr = GenStgExpr 'InferTaggedBinders +type InferStgRhs = GenStgRhs 'InferTaggedBinders +type InferStgAlt = GenStgAlt 'InferTaggedBinders + +combineAltInfo :: TagInfo -> TagInfo -> TagInfo +combineAltInfo TagDunno _ = TagDunno +combineAltInfo _ TagDunno = TagDunno +combineAltInfo (TagTuple {}) TagProper = TagDunno -- This can happen with rep-polymorphic result, see #26107 +combineAltInfo TagProper (TagTuple {}) = TagDunno -- This can happen with rep-polymorphic result, see #26107 +combineAltInfo TagProper TagProper = TagProper +combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual combineAltInfo is1 is2) +combineAltInfo (TagTagged) ti = ti +combineAltInfo ti TagTagged = ti + +type TagSigEnv = IdEnv TagSig +data TagEnv p = TE { te_env :: TagSigEnv + , te_get :: BinderP p -> Id + , te_bytecode :: !Bool + } + +instance Outputable (TagEnv p) where + ppr te = for_txt <+> ppr (te_env te) + where + for_txt = if te_bytecode te + then text "for_bytecode" + else text "for_native" + +getBinderId :: TagEnv p -> BinderP p -> Id +getBinderId = te_get + +initEnv :: Bool -> TagEnv 'CodeGen +initEnv for_bytecode = TE { te_env = emptyVarEnv + , te_get = \x -> x + , te_bytecode = for_bytecode } + +-- | Simple convert env to a env of the 'InferTaggedBinders pass +-- with no other changes. +makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders +makeTagged env = TE { te_env = te_env env + , te_get = fst + , te_bytecode = te_bytecode env } + +noSig :: TagEnv p -> BinderP p -> (Id, TagSig) +noSig env bndr + | isUnliftedType (idType var) = (var, TagSig TagProper) + | otherwise = (var, TagSig TagDunno) + where + var = getBinderId env bndr + +-- | Look up a sig in the given env +lookupSig :: TagEnv p -> Id -> Maybe TagSig +lookupSig env fun = lookupVarEnv (te_env env) fun + +-- | Look up a sig in the env or derive it from information +-- in the arg itself. +lookupInfo :: TagEnv p -> StgArg -> TagInfo +lookupInfo env (StgVarArg var) + -- Nullary data constructors like True, False + | Just dc <- isDataConWorkId_maybe var + , isNullaryRepDataCon dc + , not for_bytecode + = TagProper + + | isUnliftedType (idType var) + = TagProper + + -- Variables in the environment. + | Just (TagSig info) <- lookupVarEnv (te_env env) var + = info + + | Just lf_info <- idLFInfo_maybe var + , not for_bytecode + = case lf_info of + -- Function, tagged (with arity) + LFReEntrant {} + -> TagProper + -- Thunks need to be entered. + LFThunk {} + -> TagDunno + -- Constructors, already tagged. + LFCon {} + -> TagProper + LFUnknown {} + -> TagDunno + LFUnlifted {} + -> TagProper + -- Shouldn't be possible. I don't think we can export letNoEscapes + LFLetNoEscape {} -> panic "LFLetNoEscape exported" + + | otherwise + = TagDunno + where + for_bytecode = te_bytecode env + +lookupInfo _ (StgLitArg {}) + = TagProper + +isDunnoSig :: TagSig -> Bool +isDunnoSig (TagSig TagDunno) = True +isDunnoSig (TagSig TagProper) = False +isDunnoSig (TagSig TagTuple{}) = False +isDunnoSig (TagSig TagTagged{}) = False + +isTaggedInfo :: TagInfo -> Bool +isTaggedInfo TagProper = True +isTaggedInfo TagTagged = True +isTaggedInfo _ = False + +extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p +extendSigEnv env@(TE { te_env = sig_env }) bndrs + = env { te_env = extendVarEnvList sig_env bndrs } diff --git a/GHC/Stg/InferTags.hs b/GHC/Stg/InferTags.hs deleted file mode 100644 --- a/GHC/Stg/InferTags.hs +++ /dev/null @@ -1,674 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass - -{-# OPTIONS_GHC -Wname-shadowing #-} -module GHC.Stg.InferTags ( inferTags ) where - -import GHC.Prelude hiding (id) - -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Types.Id -import GHC.Types.Id.Info (tagSigInfo) -import GHC.Types.Name -import GHC.Stg.Syntax -import GHC.Types.Basic ( CbvMark (..) ) -import GHC.Types.Unique.Supply (mkSplitUniqSupply) -import GHC.Types.RepType (dataConRuntimeRepStrictness) -import GHC.Core (AltCon(..)) -import Data.List (mapAccumL) -import GHC.Utils.Outputable -import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) - -import GHC.Stg.InferTags.Types -import GHC.Stg.InferTags.Rewrite (rewriteTopBinds) -import Data.Maybe -import GHC.Types.Name.Env (mkNameEnv, NameEnv) -import GHC.Driver.DynFlags -import GHC.Utils.Logger -import qualified GHC.Unit.Types - -{- Note [Tag Inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The purpose of this pass is to attach to every binder a flag -to indicate whether or not it is "properly tagged". A binder -is properly tagged if it is guaranteed: - - to point to a heap-allocated *value* - - and to have the tag of the value encoded in the pointer - -For example - let x = Just y in ... - -Here x will be properly tagged: it will point to the heap-allocated -values for (Just y), and the tag-bits of the pointer will encode -the tag for Just so there is no need to re-enter the closure or even -check for the presence of tag bits. The impacts of this can be very large. - -For containers the reduction in runtimes with this optimization was as follows: - -intmap-benchmarks: 89.30% -intset-benchmarks: 90.87% -map-benchmarks: 88.00% -sequence-benchmarks: 99.84% -set-benchmarks: 85.00% -set-operations-intmap:88.64% -set-operations-map: 74.23% -set-operations-set: 76.50% -lookupge-intmap: 89.57% -lookupge-map: 70.95% - -With nofib being ~0.3% faster as well. - -See Note [Tag inference passes] for how we proceed to generate and use this information. - -Note [Strict Field Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As part of tag inference we introduce the Strict Field Invariant. -Which consists of us saying that: - -* Pointers in strict fields must (a) point directly to the value, and - (b) must be properly tagged. - -For example, given - data T = MkT ![Int] - -the Strict Field Invariant guarantees that the first field of any `MkT` constructor -will either point directly to nil, or directly to a cons cell; -and will be tagged with `001` or `010` respectively. -It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). -NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs. - -This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids]. - -Why do we care? Because if we have code like: - -case strictPair of - SP x y -> - case x of ... - -It allows us to safely omit the code to enter x and the check -for the presence of a tag that goes along with it. -However we might still branch on the tag as usual. -See Note [Tag Inference] for how much impact this can have for -some code. - -This is enforced by the code GHC.Stg.InferTags.Rewrite -where we: - -* Look at all constructor allocations. -* Check if arguments to their strict fields are known to be properly tagged -* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'` - -This is usually very beneficial but can cause regressions in rare edge cases where -we fail to proof that x is properly tagged, or where it simply isn't. -See Note [How untagged pointers can end up in strict fields] for how the second case -can arise. - -For a full example of the worst case consider this code: - -foo ... = ... - let c = StrictJust x - in ... - -Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'` -However that is horrible! We end up allocating a thunk for `c` first, which only when -evaluated will allocate the constructor. - -So we do our best to establish that `x` is already tagged (which it almost always is) -to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions. - -Note that there are similar constraints around Note [CBV Function Ids]. - -Note [How untagged pointers can end up in strict fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data Set a = Tip | Bin !a (Set a) (Set a) - -We make a wrapper for Bin that evaluates its arguments - $WBin x a b = case x of xv -> Bin xv a b -Here `xv` will always be evaluated and properly tagged, just as the -Strict Field Invariant requires. - -But alas the Simplifier can destroy the invariant: see #15696. -We start with - thk = f () - g x = ...(case thk of xv -> Bin xv Tip Tip)... - -So far so good; the argument to Bin (which is strict) is evaluated. -Now we do float-out. And in doing so we do a reverse binder-swap (see -Note [Binder-swap during float-out] in SetLevels) thus - - g x = ...(case thk of xv -> Bin thk Nil Nil)... - -The goal of the reverse binder-swap is to allow more floating -- and -indeed it does! We float the Bin to top level: - - lvl = Bin thk Tip Tip - g x = ...(case thk of xv -> lvl)... - -Now you can see that the argument of Bin, namely thk, points to the -thunk, not to the value as it did before. - -In short, although it may be rare, the output of optimisation passes -cannot guarantee to obey the Strict Field Invariant. For this reason -we run tag inference. See Note [Tag inference passes]. - -Note [Tag inference passes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tag inference proceeds in two passes: -* The first pass is an analysis to compute which binders are properly tagged. - The result is then attached to /binders/. - This is implemented by `inferTagsAnal` in GHC.Stg.InferTags -* The second pass walks over the AST checking if the Strict Field Invariant is upheld. - See Note [Strict Field Invariant]. - If required this pass modifies the program to uphold this invariant. - Tag information is also moved from /binders/ to /occurrences/ during this pass. - This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`. -* Finally the code generation uses this information to skip the thunk check when branching on - values. This is done by `cgExpr`/`cgCase` in the backend. - -Last but not least we also export the tag sigs of top level bindings to allow this optimization - to work across module boundaries. - -Note [TagInfo of functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The purpose of tag inference is really to figure out when we don't have to enter -value closures. There the meaning of the tag is fairly obvious. -For functions we never make use of the tag info so we have two choices: -* Treat them as TagDunno -* Treat them as TagProper (as they *are* tagged with their arity) and be really - careful to make sure we still enter them when needed. -As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where -it made the code simpler. But besides implementation complexity there isn't any reason -why we couldn't be more rigorous in dealing with functions. - -NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions. -So option two isn't really an option without reworking this anyway. - -Note [Tag inference debugging] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is a flag -dtag-inference-checks which inserts various -compile/runtime checks in order to ensure the Strict Field Invariant -holds. It should cover all places -where tags matter and disable optimizations which interfere with checking -the invariant like generation of AP-Thunks. - -Note [Polymorphic StgPass for inferTagExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to reach a fixpoint we sometimes have to re-analyse an expression -multiple times. But after the initial run the Ast will be parameterized by -a different StgPass! To handle this a large part of the analysis is polymorphic -over the exact StgPass we are using. Which allows us to run the analysis on -the output of itself. - -Note [Tag inference for interpreted code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The bytecode interpreter has a different behaviour when it comes -to the tagging of binders in certain situations than the StgToCmm code generator. - -a) Tags for let-bindings: - - When compiling a binding for a constructor like `let x = Just True` - Whether `x` will be properly tagged depends on the backend. - For the interpreter x points to a BCO which once - evaluated returns a properly tagged pointer to the heap object. - In the Cmm backend for the same binding we would allocate the constructor right - away and x will immediately be represented by a tagged pointer. - This means for interpreted code we can not assume let bound constructors are - properly tagged. Hence we distinguish between targeting bytecode and native in - the analysis. - We make this differentiation in `mkLetSig` where we simply never assume - lets are tagged when targeting bytecode. - -b) When referencing ids from other modules the Cmm backend will try to put a - proper tag on these references through various means. When doing analysis we - usually predict these cases to improve precision of the analysis. - But to my knowledge the bytecode generator makes no such attempts so we must - not infer imported bindings as tagged. - This is handled in GHC.Stg.InferTags.Types.lookupInfo - - --} - -{- ********************************************************************* -* * - Tag inference pass -* * -********************************************************************* -} - -inferTags :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) -inferTags ppr_opts !for_bytecode logger this_mod stg_binds = do - -- pprTraceM "inferTags for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) - -- Annotate binders with tag information. - let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-} - inferTagsAnal for_bytecode stg_binds - putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags) - - let export_tag_info = collectExportInfo stg_binds_w_tags - - -- Rewrite STG to uphold the strict field invariant - us_t <- mkSplitUniqSupply 't' - let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] - - return (rewritten_binds,export_tag_info) - -{- ********************************************************************* -* * - Main inference algorithm -* * -********************************************************************* -} - -type OutputableInferPass p = (Outputable (TagEnv p) - , Outputable (GenStgExpr p) - , Outputable (BinderP p) - , Outputable (GenStgRhs p)) - --- | This constraint encodes the fact that no matter what pass --- we use the Let/Closure extension points are the same as these for --- 'InferTaggedBinders. -type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders - , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders - , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders) - -inferTagsAnal :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] -inferTagsAnal for_bytecode binds = - -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ - snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) - ------------------------ -inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen - -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders) -inferTagTopBind env (StgTopStringLit id bs) - = (env, StgTopStringLit id bs) -inferTagTopBind env (StgTopLifted bind) - = (env', StgTopLifted bind') - where - (env', bind') = inferTagBind env bind - - --- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr] ------------------------ -inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p) - => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders) -inferTagExpr env (StgApp fun args) - = --pprTrace "inferTagExpr1" - -- (ppr fun <+> ppr args $$ ppr info $$ - -- text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args) - -- ) - (info, StgApp fun args) - where - !fun_arity = idArity fun - info | fun_arity == 0 -- Unknown arity => Thunk or unknown call - = TagDunno - - | isDeadEndId fun - , fun_arity == length args -- Implies we will simply call the function. - = TagTagged -- See Note [Bottom functions are TagTagged] - - | Just (TagSig res_info) <- tagSigInfo (idInfo fun) - , fun_arity == length args -- Saturated - = res_info - - | Just (TagSig res_info) <- lookupSig env fun - , fun_arity == length args -- Saturated - = res_info - - | otherwise - = --pprTrace "inferAppUnknown" (ppr fun) $ - TagDunno --- TODO: --- If we have something like: --- let x = thunk in --- f g = case g of g' -> (# x, g' #) --- then we *do* know that g' will be properly tagged, --- so we should return TagTagged [TagDunno,TagProper] but currently we infer --- TagTagged [TagDunno,TagDunno] because of the unknown arity case in inferTagExpr. --- Seems not to matter much but should be changed eventually. - -inferTagExpr env (StgConApp con cn args tys) - = (inferConTag env con args, StgConApp con cn args tys) - -inferTagExpr _ (StgLit l) - = (TagTagged, StgLit l) - -inferTagExpr env (StgTick tick body) - = (info, StgTick tick body') - where - (info, body') = inferTagExpr env body - -inferTagExpr _ (StgOpApp op args ty) - = -- Do any primops guarantee to return a properly tagged value? - -- I think not. Ditto foreign calls. - (TagDunno, StgOpApp op args ty) - -inferTagExpr env (StgLet ext bind body) - = (info, StgLet ext bind' body') - where - (env', bind') = inferTagBind env bind - (info, body') = inferTagExpr env' body - -inferTagExpr env (StgLetNoEscape ext bind body) - = (info, StgLetNoEscape ext bind' body') - where - (env', bind') = inferTagBind env bind - (info, body') = inferTagExpr env' body - -inferTagExpr in_env (StgCase scrut bndr ty alts) - -- Unboxed tuples get their info from the expression we scrutinise if any - | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts - , isUnboxedTupleDataCon con - , Just infos <- scrut_infos bndrs - , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos - mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig) - mk_bndr tup_bndr tup_info = - -- pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $ - (getBinderId in_env tup_bndr, TagSig tup_info) - -- no case binder in alt_env here, unboxed tuple binders are dead after unarise - alt_env = extendSigEnv in_env bndrs' - (info, rhs') = inferTagExpr alt_env rhs - = - -- pprTrace "inferCase1" ( - -- text "scrut:" <> ppr scrut $$ - -- text "bndr:" <> ppr bndr $$ - -- text "infos" <> ppr infos $$ - -- text "out_bndrs" <> ppr bndrs') $ - (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con - , alt_bndrs=bndrs' - , alt_rhs=rhs'}]) - - | null alts -- Empty case, but I might just be paranoid. - = -- pprTrace "inferCase2" empty $ - (TagDunno, StgCase scrut' bndr' ty []) - -- More than one alternative OR non-TagTuple single alternative. - | otherwise - = - let - case_env = extendSigEnv in_env [bndr'] - - (infos, alts') - = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'}) - | g@GenStgAlt{ alt_con = con - , alt_bndrs = bndrs - , alt_rhs = rhs - } <- alts - , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs - (info, rhs') = inferTagExpr alt_env rhs - ] - alt_info = foldr combineAltInfo TagTagged infos - in ( alt_info, StgCase scrut' bndr' ty alts') - where - -- Single unboxed tuple alternative - scrut_infos bndrs = case scrut_info of - TagTagged -> Just $ replicate (length bndrs) TagProper - TagTuple infos -> Just infos - _ -> Nothing - (scrut_info, scrut') = inferTagExpr in_env scrut - bndr' = (getBinderId in_env bndr, TagSig TagProper) - --- Compute binder sigs based on the constructors strict fields. --- NB: Not used if we have tuple info from the scrutinee. -addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders]) -addAltBndrInfo env (DataAlt con) bndrs - | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) - = (out_env, out_bndrs) - where - marks = dataConRuntimeRepStrictness con :: [StrictnessMark] - out_bndrs = zipWith mk_bndr bndrs marks - out_env = extendSigEnv env out_bndrs - - mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig)) - mk_bndr bndr mark - | isUnliftedType (idType id) || isMarkedStrict mark - = (id, TagSig TagProper) - | otherwise - = noSig env bndr - where - id = getBinderId env bndr - -addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs) - ------------------------------ -inferTagBind :: (OutputableInferPass p, InferExtEq p) - => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders) -inferTagBind in_env (StgNonRec bndr rhs) - = - -- pprTrace "inferBindNonRec" ( - -- ppr bndr $$ - -- ppr (isDeadEndId id) $$ - -- ppr sig) - (env', StgNonRec (id, out_sig) rhs') - where - id = getBinderId in_env bndr - (in_sig,rhs') = inferTagRhs id in_env rhs - out_sig = mkLetSig in_env in_sig - env' = extendSigEnv in_env [(id, out_sig)] - -inferTagBind in_env (StgRec pairs) - = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $ - (in_env { te_env = out_env }, StgRec pairs') - where - (bndrs, rhss) = unzip pairs - in_ids = map (getBinderId in_env) bndrs - init_sigs = map (initSig) $ zip in_ids rhss - (out_env, pairs') = go in_env init_sigs rhss - - go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q] - -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)]) - go go_env in_sigs go_rhss - -- | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False - -- = undefined - | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss') - | otherwise = go env' out_sigs rhss' - where - in_bndrs = in_ids `zip` in_sigs - out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive - rhs_env = extendSigEnv go_env in_bndrs - (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss) - env' = makeTagged go_env - - anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders) - anaRhs bnd rhs = - let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs - in (mkLetSig go_env sig_rhs, rhs') - - - updateBndr :: (Id,TagSig) -> (Id,TagSig) - updateBndr (v,sig) = (setIdTagSig v sig, sig) - -initSig :: forall p. (Id, GenStgRhs p) -> TagSig --- Initial signature for the fixpoint loop -initSig (_bndr, StgRhsCon {}) = TagSig TagTagged -initSig (bndr, StgRhsClosure _ _ _ _ _ _) = - fromMaybe defaultSig (idTagSig_maybe bndr) - where defaultSig = (TagSig TagTagged) - -{- Note [Bottom functions are TagTagged] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a function with two branches with one -being bottom, and the other returning a tagged -unboxed tuple what is the result? We give it TagTagged! -To answer why consider this function: - -foo :: Bool -> (# Bool, Bool #) -foo x = case x of - True -> (# True,True #) - False -> undefined - -The true branch is obviously tagged. The other branch isn't. -We want to treat the *result* of foo as tagged as well so that -the combination of the branches also is tagged if all non-bottom -branches are tagged. -This is safe because the function is still always called/entered as long -as it's applied to arguments. Since the function will never return we can give -it safely any tag sig we like. -So we give it TagTagged, as it allows the combined tag sig of the case expression -to be the combination of all non-bottoming branches. - --} - ------------------------------ -inferTagRhs :: forall p. - (OutputableInferPass p, InferExtEq p) - => Id -- ^ Id we are binding to. - -> TagEnv p -- ^ - -> GenStgRhs p -- ^ - -> (TagSig, GenStgRhs 'InferTaggedBinders) -inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ) - | isDeadEndId bnd_id && (notNull) bndrs - -- See Note [Bottom functions are TagTagged] - = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ) - | otherwise - = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ - (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ) - where - out_bndrs - | Just marks <- idCbvMarks_maybe bnd_id - -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim - -- the list of marks to the last strict entry. So we can conservatively - -- assume these are not strict - = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv) - | otherwise = map (noSig env') bndrs :: [(Id,TagSig)] - - env' = extendSigEnv in_env out_bndrs - (info, body') = inferTagExpr env' body - info' - -- It's a thunk - | null bndrs - = TagDunno - -- TODO: We could preserve tuple fields for thunks - -- as well. But likely not worth the complexity. - - | otherwise = info - - mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig) - mkArgSig bndp mark = - let id = getBinderId in_env bndp - tag = case mark of - MarkedCbv -> TagProper - _ - | isUnliftedType (idType id) -> TagProper - | otherwise -> TagDunno - in (id, TagSig tag) - -inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ) --- Constructors, which have untagged arguments to strict fields --- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno - = --pprTrace "inferTagRhsCon" (ppr grp_ids) $ - (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ) - --- Adjust let semantics to the targeted backend. --- See Note [Tag inference for interpreted code] -mkLetSig :: TagEnv p -> TagSig -> TagSig -mkLetSig env in_sig - | for_bytecode = TagSig TagDunno - | otherwise = in_sig - where - for_bytecode = te_bytecode env - -{- Note [Constructor TagSigs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor -or a StgConApp expression. -Usually these will simply be TagProper. But there are exceptions. -If any of the fields in the constructor are strict, but any argument to these -fields is not tagged then we will have to case on the argument before storing -in the constructor. Which means for let bindings the RHS turns into a thunk -which obviously is no longer properly tagged. -For example we might start with: - - let x = f ... - let c = StrictPair x True - -But we know during the rewrite stage x will need to be evaluated in the RHS -of `c` so we will infer: - - let x = f ... - let c = StrictPair x True - -Which in the rewrite stage will then be rewritten into: - - let x = f ... - let c = case x of x' -> StrictPair x' True - -The other exception is unboxed tuples. These will get a TagTuple -signature with a list of TagInfo about their individual binders -as argument. As example: - - let c = True - let x = ... - let f z = case z of z' -> (# c, x #) - -Here we will infer for f the Signature . -This information will be used if we scrutinize a saturated application of -`f` in order to determine the taggedness of the result. -That is for `case f x of (# r1,r2 #) -> rhs` we can infer -r1 and r2 which allows us to skip all tag checks on `r1` -in `rhs`. - -Things get a bit more complicated with nesting: - - let closeFd = ... - let f x = ... - case x of - _ -> Solo# closeFd - -The "natural" signature for the Solo# branch in `f` would be . -But we flatten this out to for the time being as it improves compile -time and there doesn't seem to huge benefit to doing differently. - - -} - --- See Note [Constructor TagSigs] -inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo -inferConTag env con args - | isUnboxedTupleDataCon con - = TagTuple $ map (flatten_arg_tag . lookupInfo env) args - | otherwise = - -- pprTrace "inferConTag" - -- ( text "con:" <> ppr con $$ - -- text "args:" <> ppr args $$ - -- text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$ - -- text "arg_info:" <> ppr (map (lookupInfo env) args) $$ - -- text "info:" <> ppr info) $ - info - where - info = if any arg_needs_eval strictArgs then TagDunno else TagProper - strictArgs = zipEqual "inferTagRhs" args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)]) - arg_needs_eval (arg,strict) - -- lazy args - | not (isMarkedStrict strict) = False - | tag <- (lookupInfo env arg) - -- banged args need to be tagged, or require eval - = not (isTaggedInfo tag) - - flatten_arg_tag (TagTagged) = TagProper - flatten_arg_tag (TagProper ) = TagProper - flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs] - flatten_arg_tag (TagDunno) = TagDunno - - -collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig -collectExportInfo binds = - mkNameEnv bndr_info - where - bndr_info = concatMap collect binds :: [(Name,TagSig)] - - collect (StgTopStringLit {}) = [] - collect (StgTopLifted bnd) = - case bnd of - StgNonRec (id,sig) _rhs - | TagSig TagDunno <- sig -> [] - | otherwise -> [(idName id,sig)] - StgRec bnds -> collectRec bnds - - collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)] - collectRec [] = [] - collectRec (bnd:bnds) - | (p,_rhs) <- bnd - , (id,sig) <- p - , TagSig TagDunno <- sig - = (idName id,sig) : collectRec bnds - | otherwise = collectRec bnds diff --git a/GHC/Stg/InferTags/Rewrite.hs b/GHC/Stg/InferTags/Rewrite.hs deleted file mode 100644 --- a/GHC/Stg/InferTags/Rewrite.hs +++ /dev/null @@ -1,544 +0,0 @@ - --- Copyright (c) 2019 Andreas Klebinger --- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -module GHC.Stg.InferTags.Rewrite (rewriteTopBinds) -where - -import GHC.Prelude - -import GHC.Builtin.PrimOps ( PrimOp(..) ) -import GHC.Types.Basic ( CbvMark (..), isMarkedCbv - , TopLevelFlag(..), isTopLevel ) -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Unique.Supply -import GHC.Types.Unique.FM -import GHC.Types.RepType -import GHC.Types.Var.Set -import GHC.Unit.Types - -import GHC.Core.DataCon -import GHC.Core ( AltCon(..) ) -import GHC.Core.Type - -import GHC.StgToCmm.Types -import GHC.StgToCmm.Closure (importedIdLFInfo) - -import GHC.Stg.Utils -import GHC.Stg.Syntax as StgSyn - -import GHC.Data.Maybe -import GHC.Utils.Panic - -import GHC.Utils.Outputable -import GHC.Utils.Monad.State.Strict -import GHC.Utils.Misc - -import GHC.Stg.InferTags.Types - -import Control.Monad - -newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } - deriving (Functor, Monad, Applicative) - ------------------------------------------------------------- --- Add cases around strict fields where required. ------------------------------------------------------------- -{- -The work of this pass is simple: -* We traverse the STG AST looking for constructor allocations. -* For all allocations we check if there are strict fields in the constructor. -* For any strict field we check if the argument is known to be properly tagged. -* If it's not known to be properly tagged, we wrap the whole thing in a case, - which will force the argument before allocation. -This is described in detail in Note [Strict Field Invariant]. - -The only slight complication is that we have to make sure not to invalidate free -variable analysis in the process. - -Note [Partially applied workers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes we will get a function f of the form - -- Arity 1 - f :: Dict a -> a -> b -> (c -> d) - f dict a b = case dict of - C m1 m2 -> m1 a b - -Which will result in a W/W split along the lines of - -- Arity 1 - f :: Dict a -> a -> b -> (c -> d) - f dict a = case dict of - C m1 m2 -> $wf m1 a b - - -- Arity 4 - $wf :: (a -> b -> d -> c) -> a -> b -> c -> d - $wf m1 a b c = m1 a b c - -It's notable that the worker is called *undersaturated* in the wrapper. -At runtime what happens is that the wrapper will allocate a PAP which -once fully applied will call the worker. And all is fine. - -But what about a call by value function! Well the function returned by `f` would -be a unknown call, so we lose the ability to enforce the invariant that -cbv marked arguments from StictWorkerId's are actually properly tagged -as the annotations would be unavailable at the (unknown) call site. - -The fix is easy. We eta-expand all calls to functions taking call-by-value -arguments during CorePrep just like we do with constructor allocations. - -Note [Upholding free variable annotations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The code generator requires us to maintain exact information -about free variables about closures. Since we convert some -RHSs from constructor allocations to closures we have to provide -fvs of these closures. Not all constructor arguments will become -free variables. Only these which are not bound at the top level -have to be captured. -To facilitate this we keep track of a set of locally bound variables in -the current context which we then use to filter constructor arguments -when building the free variable list. --} - --------------------------------- --- Utilities --------------------------------- - -instance MonadUnique RM where - getUniqueSupplyM = RM $ do - (m, us, mod,lcls) <- get - let (us1, us2) = splitUniqSupply us - (put) (m,us2,mod,lcls) - return us1 - -getMap :: RM (UniqFM Id TagSig) -getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) - -setMap :: (UniqFM Id TagSig) -> RM () -setMap !m = RM $ do - (_,us,mod,lcls) <- get - put (m, us,mod,lcls) - -getMod :: RM Module -getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get) - -getFVs :: RM IdSet -getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) - -setFVs :: IdSet -> RM () -setFVs !fvs = RM $ do - (tag_map,us,mod,_lcls) <- get - put (tag_map, us,mod,fvs) - --- Rewrite the RHS(s) while making the id and it's sig available --- to determine if things are tagged/need to be captured as FV. -withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a -withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont -withBind top_flag (StgRec binds) cont = do - let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders]) - withBinders top_flag bnds cont - -addTopBind :: GenStgBinding 'InferTaggedBinders -> RM () -addTopBind (StgNonRec (id, tag) _) = do - s <- getMap - -- pprTraceM "AddBind" (ppr id) - setMap $ addToUFM s id tag - return () -addTopBind (StgRec binds) = do - let (bnds,_rhss) = unzip binds - !s <- getMap - -- pprTraceM "AddBinds" (ppr $ map fst bnds) - setMap $! addListToUFM s bnds - -withBinder :: TopLevelFlag -> (Id, TagSig) -> RM a -> RM a -withBinder top_flag (id,sig) cont = do - oldMap <- getMap - setMap $ addToUFM oldMap id sig - a <- if isTopLevel top_flag - then cont - else withLcl id cont - setMap oldMap - return a - -withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a -withBinders TopLevel sigs cont = do - oldMap <- getMap - setMap $ addListToUFM oldMap sigs - a <- cont - setMap oldMap - return a -withBinders NotTopLevel sigs cont = do - oldMap <- getMap - oldFvs <- getFVs - setMap $ addListToUFM oldMap sigs - setFVs $ extendVarSetList oldFvs (map fst sigs) - a <- cont - setMap oldMap - setFVs oldFvs - return a - --- | Compute the argument with the given set of ids treated as requiring capture --- as free variables. -withClosureLcls :: DIdSet -> RM a -> RM a -withClosureLcls fvs act = do - old_fvs <- getFVs - let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs - setFVs fvs' - !r <- act - setFVs old_fvs - return r - --- | Compute the argument with the given id treated as requiring capture --- as free variables in closures. -withLcl :: Id -> RM a -> RM a -withLcl fv act = do - old_fvs <- getFVs - let !fvs' = extendVarSet old_fvs fv - setFVs fvs' - !r <- act - setFVs old_fvs - return r - -{- Note [Tag inference for interactive contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When compiling bytecode we call myCoreToStg to get STG code first. -myCoreToStg in turn calls out to stg2stg which runs the STG to STG -passes followed by free variables analysis and the tag inference pass including -it's rewriting phase at the end. -Running tag inference is important as it upholds Note [Strict Field Invariant]. -While code executed by GHCi doesn't take advantage of the SFI it can call into -compiled code which does. So it must still make sure that the SFI is upheld. -See also #21083 and #22042. - -However there one important difference in code generation for GHCi and regular -compilation. When compiling an entire module (not a GHCi expression), we call -`stg2stg` on the entire module which allows us to build up a map which is guaranteed -to have an entry for every binder in the current module. -For non-interactive compilation the tag inference rewrite pass takes advantage -of this by building up a map from binders to their tag signatures. - -When compiling a GHCi expression on the other hand we invoke stg2stg separately -for each expression on the prompt. This means in GHCi for a sequence of: - > let x = True - > let y = StrictJust x -We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`. - -While computing the tag signature for `y` during tag inference inferConTag will check -if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping. -However since this mapping isn't persistent between stg2stg -invocations the lookup will fail. This isn't a correctness issue since it's always -safe to assume a binding isn't tagged and that's what we do in such cases. - -However for non-interactive mode we *don't* want to do this. Since in non-interactive mode -we have all binders of the module available for each invocation we can expect the binder->signature -mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup -indicates a bug in the tag inference implementation. -For this reason we assert that we are running in interactive mode if a lookup fails. --} -isTagged :: Id -> RM Bool -isTagged v = do - this_mod <- getMod - -- See Note [Tag inference for interactive contexts] - let lookupDefault v = assertPpr (isInteractiveModule this_mod) - (text "unknown Id:" <> ppr this_mod <+> ppr v) - (TagSig TagDunno) - case nameIsLocalOrFrom this_mod (idName v) of - True - | definitelyUnliftedType (idType v) - -- NB: v might be the Id of a representation-polymorphic join point, - -- so we shouldn't use isUnliftedType here. See T22212. - -> return True - | otherwise -> do -- Local binding - !s <- getMap - let !sig = lookupWithDefaultUFM s (lookupDefault v) v - return $ case sig of - TagSig info -> - case info of - TagDunno -> False - TagProper -> True - TagTagged -> True - TagTuple _ -> True -- Consider unboxed tuples tagged. - -- Imported - False -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case importedIdLFInfo v of - -- Function, applied not entered. - LFReEntrant {} - -> True - -- Thunks need to be entered. - LFThunk {} - -> False - -- LFCon means we already know the tag, and it's tagged. - LFCon {} - -> True - LFUnknown {} - -> False - LFUnlifted {} - -> True - LFLetNoEscape {} - -- Shouldn't be possible. I don't think we can export letNoEscapes - -> True - - -isArgTagged :: StgArg -> RM Bool -isArgTagged (StgLitArg _) = return True -isArgTagged (StgVarArg v) = isTagged v - -mkLocalArgId :: Id -> RM Id -mkLocalArgId id = do - !u <- getUniqueM - return $! setIdUnique (localiseId id) u - ---------------------------- --- Actual rewrite pass ---------------------------- - - -rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding] -rewriteTopBinds mod us binds = - let doBinds = mapM rewriteTop binds - - in evalState (unRM doBinds) (mempty, us, mod, mempty) - -rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding -rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s) -rewriteTop (StgTopLifted bind) = do - -- Top level bindings can, and must remain in scope - addTopBind bind - (StgTopLifted) <$!> (rewriteBinds TopLevel bind) - --- For top level binds, the wrapper is guaranteed to be `id` -rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding) -rewriteBinds _top_flag (StgNonRec v rhs) = do - (!rhs) <- rewriteRhs v rhs - return $! (StgNonRec (fst v) rhs) -rewriteBinds top_flag b@(StgRec binds) = - -- Bring sigs of binds into scope for all rhss - withBind top_flag b $ do - (rhss) <- mapM (uncurry rewriteRhs) binds - return $! (mkRec rhss) - where - mkRec :: [TgStgRhs] -> TgStgBinding - mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss) - --- Rewrite a RHS -rewriteRhs :: (Id,TagSig) -> InferStgRhs - -> RM (TgStgRhs) -rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewriteRhs_ #-} do - -- pprTraceM "rewriteRhs" (ppr _id) - - -- Look up the nodes representing the constructor arguments. - fieldInfos <- mapM isArgTagged args - - -- Filter out non-strict fields. - let strictFields = - getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo) - -- Filter out already tagged arguments. - let needsEval = map fst . --get the actual argument - filter (not . snd) $ -- Keep untagged (False) elements. - strictFields :: [StgArg] - let evalArgs = [v | StgVarArg v <- needsEval] :: [Id] - - if (null evalArgs) - then return $! (StgRhsCon ccs con cn ticks args typ) - else do - --assert not (isTaggedSig tagSig) - -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id - - -- At this point iff we have possibly untagged arguments to strict fields - -- we convert the RHS into a RhsClosure which will evaluate the arguments - -- before allocating the constructor. - let ty_stub = panic "mkSeqs shouldn't use the type arg" - conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub) - - fvs <- fvArgs args - -- lcls <- getFVs - -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls) - - -- We mark the closure updatable to retain sharing in the case that - -- conExpr is an infinite recursive data type. See #23783. - return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ -rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do - withBinders NotTopLevel args $ - withClosureLcls fvs $ - StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body <*> pure typ - -- return (closure) - -fvArgs :: [StgArg] -> RM DVarSet -fvArgs args = do - fv_lcls <- getFVs - -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) ) - return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls] - -rewriteArgs :: [StgArg] -> RM [StgArg] -rewriteArgs = mapM rewriteArg -rewriteArg :: StgArg -> RM StgArg -rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v -rewriteArg (lit@StgLitArg{}) = return lit - -rewriteId :: Id -> RM Id -rewriteId v = do - !is_tagged <- isTagged v - if is_tagged then return $! setIdTagSig v (TagSig TagProper) - else return v - -rewriteExpr :: InferStgExpr -> RM TgStgExpr -rewriteExpr (e@StgCase {}) = rewriteCase e -rewriteExpr (e@StgLet {}) = rewriteLet e -rewriteExpr (e@StgLetNoEscape {}) = rewriteLetNoEscape e -rewriteExpr (StgTick t e) = StgTick t <$!> rewriteExpr e -rewriteExpr e@(StgConApp {}) = rewriteConApp e -rewriteExpr e@(StgApp {}) = rewriteApp e -rewriteExpr (StgLit lit) = return $! (StgLit lit) -rewriteExpr (StgOpApp op@(StgPrimOp DataToTagOp) args res_ty) = do - (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty -rewriteExpr (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty) - - -rewriteCase :: InferStgExpr -> RM TgStgExpr -rewriteCase (StgCase scrut bndr alt_type alts) = - withBinder NotTopLevel bndr $ - pure StgCase <*> - rewriteExpr scrut <*> - pure (fst bndr) <*> - pure alt_type <*> - mapM rewriteAlt alts - -rewriteCase _ = panic "Impossible: nodeCase" - -rewriteAlt :: InferStgAlt -> RM TgStgAlt -rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} = - withBinders NotTopLevel bndrs $ do - !rhs' <- rewriteExpr rhs - return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'} - -rewriteLet :: InferStgExpr -> RM TgStgExpr -rewriteLet (StgLet xt bind expr) = do - (!bind') <- rewriteBinds NotTopLevel bind - withBind NotTopLevel bind $ do - -- pprTraceM "withBindLet" (ppr $ bindersOfX bind) - !expr' <- rewriteExpr expr - return $! (StgLet xt bind' expr') -rewriteLet _ = panic "Impossible" - -rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr -rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do - (!bind') <- rewriteBinds NotTopLevel bind - withBind NotTopLevel bind $ do - !expr' <- rewriteExpr expr - return $! (StgLetNoEscape xt bind' expr') -rewriteLetNoEscape _ = panic "Impossible" - -rewriteConApp :: InferStgExpr -> RM TgStgExpr -rewriteConApp (StgConApp con cn args tys) = do - -- We check if the strict field arguments are already known to be tagged. - -- If not we evaluate them first. - fieldInfos <- mapM isArgTagged args - let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)] - let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg] - let evalArgs = [v | StgVarArg v <- needsEval] :: [Id] - if (not $ null evalArgs) - then do - -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos ) - mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys) - else return $! (StgConApp con cn args tys) - -rewriteConApp _ = panic "Impossible" - --- Special case: Atomic binders, usually in a case context like `case f of ...`. -rewriteApp :: InferStgExpr -> RM TgStgExpr -rewriteApp (StgApp f []) = do - f' <- rewriteId f - return $! StgApp f' [] -rewriteApp (StgApp f args) - -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False - -- = undefined - | Just marks <- idCbvMarks_maybe f - , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks - , any isMarkedCbv relevant_marks - = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks) - unliftArg relevant_marks - - where - -- If the function expects any argument to be call-by-value ensure the argument is already - -- evaluated. - unliftArg relevant_marks = do - argTags <- mapM isArgTagged args - let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv) argTags :: [(StgArg, CbvMark, Bool)] - - -- untagged cbv argument positions - cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo - cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id] - mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args) - -rewriteApp (StgApp f args) = return $ StgApp f args -rewriteApp _ = panic "Impossible" - --- `mkSeq` x x' e generates `case x of x' -> e` --- We could also substitute x' for x in e but that's so rarely beneficial --- that we don't bother. -mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr -mkSeq id bndr !expr = - -- pprTrace "mkSeq" (ppr (id,bndr)) $ - let altTy = mkStgAltTypeFromStgAlts bndr alt - alt = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}] - in StgCase (StgApp id []) bndr altTy alt - --- `mkSeqs args vs mkExpr` will force all vs, and construct --- an argument list args' where each v is replaced by it's evaluated --- counterpart v'. --- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then --- the result will be (case x of x' { _DEFAULT -> } -{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr -mkSeqs :: [StgArg] -- ^ Original arguments - -> [Id] -- ^ var args to be evaluated ahead of time - -> ([StgArg] -> TgStgExpr) - -- ^ Function that reconstructs the expressions when passed - -- the list of evaluated arguments. - -> RM TgStgExpr -mkSeqs args untaggedIds mkExpr = do - argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)] - -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap - let taggedArgs :: [StgArg] - = map (\v -> case v of - StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap - lit -> lit) - args - - let conBody = mkExpr taggedArgs - let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap - return $! body - --- Out of all arguments passed at runtime only return these ending up in a --- strict field -getStrictConArgs :: Outputable a => DataCon -> [a] -> [a] -getStrictConArgs con args - -- These are always lazy in their arguments. - | isUnboxedTupleDataCon con = [] - | isUnboxedSumDataCon con = [] - -- For proper data cons we have to check. - | otherwise = - assertPpr (length args == length (dataConRuntimeRepStrictness con)) - (text "Mismatched con arg and con rep strictness lengths:" $$ - text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$ - text "But seems to have arity" <> ppr (length repStrictness)) $ - [ arg | (arg,MarkedStrict) - <- zipEqual "getStrictConArgs" - args - repStrictness] - where - repStrictness = (dataConRuntimeRepStrictness con) diff --git a/GHC/Stg/InferTags/TagSig.hs b/GHC/Stg/InferTags/TagSig.hs deleted file mode 100644 --- a/GHC/Stg/InferTags/TagSig.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} - --- We export this type from this module instead of GHC.Stg.InferTags.Types --- because it's used by more than the analysis itself. For example in interface --- files where we record a tag signature for bindings. --- By putting the sig into it's own module we can avoid module loops. -module GHC.Stg.InferTags.TagSig - -where - -import GHC.Prelude - -import GHC.Types.Var -import GHC.Types.Name.Env( NameEnv ) -import GHC.Utils.Outputable -import GHC.Utils.Binary -import GHC.Utils.Panic.Plain -import Data.Coerce - --- | Information to be exposed in interface files which is produced --- by the stg2stg passes. -type StgCgInfos = NameEnv TagSig - -newtype TagSig -- The signature for each binding, this is a newtype as we might - -- want to track more information in the future. - = TagSig TagInfo - deriving (Eq) - -data TagInfo - = TagDunno -- We don't know anything about the tag. - | TagTuple [TagInfo] -- Represents a function/thunk which when evaluated - -- will return a Unboxed tuple whos components have - -- the given TagInfos. - | TagProper -- Heap pointer to properly-tagged value - | TagTagged -- Bottom of the domain. - deriving (Eq) - -instance Outputable TagInfo where - ppr TagTagged = text "TagTagged" - ppr TagDunno = text "TagDunno" - ppr TagProper = text "TagProper" - ppr (TagTuple tis) = text "TagTuple" <> brackets (pprWithCommas ppr tis) - -instance Binary TagInfo where - put_ bh TagDunno = putByte bh 1 - put_ bh (TagTuple flds) = putByte bh 2 >> put_ bh flds - put_ bh TagProper = putByte bh 3 - put_ bh TagTagged = putByte bh 4 - - get bh = do tag <- getByte bh - case tag of 1 -> return TagDunno - 2 -> TagTuple <$> get bh - 3 -> return TagProper - 4 -> return TagTagged - _ -> panic ("get TagInfo " ++ show tag) - -instance Outputable TagSig where - ppr (TagSig ti) = char '<' <> ppr ti <> char '>' -instance OutputableBndr (Id,TagSig) where - pprInfixOcc = ppr - pprPrefixOcc = ppr - -instance Binary TagSig where - put_ bh (TagSig sig) = put_ bh sig - get bh = pure TagSig <*> get bh - -isTaggedSig :: TagSig -> Bool -isTaggedSig (TagSig TagProper) = True -isTaggedSig (TagSig TagTagged) = True -isTaggedSig _ = False - -seqTagSig :: TagSig -> () -seqTagSig = coerce seqTagInfo - -seqTagInfo :: TagInfo -> () -seqTagInfo TagTagged = () -seqTagInfo TagDunno = () -seqTagInfo TagProper = () -seqTagInfo (TagTuple tis) = foldl' (\_unit sig -> seqTagSig (coerce sig)) () tis diff --git a/GHC/Stg/InferTags/Types.hs b/GHC/Stg/InferTags/Types.hs deleted file mode 100644 --- a/GHC/Stg/InferTags/Types.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} - -{-# LANGUAGE UndecidableInstances #-} - -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen - -module GHC.Stg.InferTags.Types - ( module GHC.Stg.InferTags.Types - , module TagSig) -where - -import GHC.Prelude - -import GHC.Core.DataCon -import GHC.Core.Type (isUnliftedType) -import GHC.Types.Id -import GHC.Stg.Syntax -import GHC.Stg.InferTags.TagSig as TagSig -import GHC.Types.Var.Env -import GHC.Utils.Outputable -import GHC.Utils.Misc( zipWithEqual ) -import GHC.Utils.Panic - -import GHC.StgToCmm.Types - -{- ********************************************************************* -* * - Supporting data types -* * -********************************************************************* -} - -type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders -type InferStgBinding = GenStgBinding 'InferTaggedBinders -type InferStgExpr = GenStgExpr 'InferTaggedBinders -type InferStgRhs = GenStgRhs 'InferTaggedBinders -type InferStgAlt = GenStgAlt 'InferTaggedBinders - -combineAltInfo :: TagInfo -> TagInfo -> TagInfo -combineAltInfo TagDunno _ = TagDunno -combineAltInfo _ TagDunno = TagDunno -combineAltInfo (TagTuple {}) TagProper = panic "Combining unboxed tuple with non-tuple result" -combineAltInfo TagProper (TagTuple {}) = panic "Combining unboxed tuple with non-tuple result" -combineAltInfo TagProper TagProper = TagProper -combineAltInfo (TagTuple is1) (TagTuple is2) = TagTuple (zipWithEqual "combineAltInfo" combineAltInfo is1 is2) -combineAltInfo (TagTagged) ti = ti -combineAltInfo ti TagTagged = ti - -type TagSigEnv = IdEnv TagSig -data TagEnv p = TE { te_env :: TagSigEnv - , te_get :: BinderP p -> Id - , te_bytecode :: !Bool - } - -instance Outputable (TagEnv p) where - ppr te = for_txt <+> ppr (te_env te) - where - for_txt = if te_bytecode te - then text "for_bytecode" - else text "for_native" - -getBinderId :: TagEnv p -> BinderP p -> Id -getBinderId = te_get - -initEnv :: Bool -> TagEnv 'CodeGen -initEnv for_bytecode = TE { te_env = emptyVarEnv - , te_get = \x -> x - , te_bytecode = for_bytecode } - --- | Simple convert env to a env of the 'InferTaggedBinders pass --- with no other changes. -makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders -makeTagged env = TE { te_env = te_env env - , te_get = fst - , te_bytecode = te_bytecode env } - -noSig :: TagEnv p -> BinderP p -> (Id, TagSig) -noSig env bndr - | isUnliftedType (idType var) = (var, TagSig TagProper) - | otherwise = (var, TagSig TagDunno) - where - var = getBinderId env bndr - --- | Look up a sig in the given env -lookupSig :: TagEnv p -> Id -> Maybe TagSig -lookupSig env fun = lookupVarEnv (te_env env) fun - --- | Look up a sig in the env or derive it from information --- in the arg itself. -lookupInfo :: TagEnv p -> StgArg -> TagInfo -lookupInfo env (StgVarArg var) - -- Nullary data constructors like True, False - | Just dc <- isDataConWorkId_maybe var - , isNullaryRepDataCon dc - , not for_bytecode - = TagProper - - | isUnliftedType (idType var) - = TagProper - - -- Variables in the environment. - | Just (TagSig info) <- lookupVarEnv (te_env env) var - = info - - | Just lf_info <- idLFInfo_maybe var - , not for_bytecode - = case lf_info of - -- Function, tagged (with arity) - LFReEntrant {} - -> TagProper - -- Thunks need to be entered. - LFThunk {} - -> TagDunno - -- Constructors, already tagged. - LFCon {} - -> TagProper - LFUnknown {} - -> TagDunno - LFUnlifted {} - -> TagProper - -- Shouldn't be possible. I don't think we can export letNoEscapes - LFLetNoEscape {} -> panic "LFLetNoEscape exported" - - | otherwise - = TagDunno - where - for_bytecode = te_bytecode env - -lookupInfo _ (StgLitArg {}) - = TagProper - -isDunnoSig :: TagSig -> Bool -isDunnoSig (TagSig TagDunno) = True -isDunnoSig (TagSig TagProper) = False -isDunnoSig (TagSig TagTuple{}) = False -isDunnoSig (TagSig TagTagged{}) = False - -isTaggedInfo :: TagInfo -> Bool -isTaggedInfo TagProper = True -isTaggedInfo TagTagged = True -isTaggedInfo _ = False - -extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p -extendSigEnv env@(TE { te_env = sig_env }) bndrs - = env { te_env = extendVarEnvList sig_env bndrs } diff --git a/GHC/Stg/Lift/Analysis.hs b/GHC/Stg/Lift/Analysis.hs --- a/GHC/Stg/Lift/Analysis.hs +++ b/GHC/Stg/Lift/Analysis.hs @@ -376,7 +376,7 @@ -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess -- args are passed on the stack, which means slow memory accesses args_spill_on_stack - | Just n <- max_n_args = maximum (map n_args rhss) > n + | Just n <- max_n_args = any (> n) (map n_args rhss) | otherwise = False -- We only perform the lift if allocations didn't increase. @@ -418,7 +418,7 @@ -- | The number of words a single 'Id' adds to a closure's size. -- Note that this can't handle unboxed tuples (which may still be present in -- let-no-escapes, even after Unarise), in which case --- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash. +-- @'GHC.StgToCmm.ArgRep.idArgRep'@ will crash. idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform = StgToCmm.ArgRep.argRepSizeW platform @@ -478,9 +478,9 @@ -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of -- 'rhsCard' and accurately captures the cardinality of the RHSs body -- relative to its defining context. - | isAbs n = 0 - | cg <= 0 = if isStrict n then cg else 0 - | isUsedOnce n = cg - | otherwise = infinity + | isAbs n = 0 + | cg <= 0 = if isStrict n then cg else 0 + | isAtMostOnce n = cg + | otherwise = infinity where cg = go body diff --git a/GHC/Stg/Lift/Monad.hs b/GHC/Stg/Lift/Monad.hs --- a/GHC/Stg/Lift/Monad.hs +++ b/GHC/Stg/Lift/Monad.hs @@ -39,7 +39,6 @@ import GHC.Core.Utils import GHC.Types.Unique.Supply import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Multiplicity diff --git a/GHC/Stg/Lift/Types.hs b/GHC/Stg/Lift/Types.hs --- a/GHC/Stg/Lift/Types.hs +++ b/GHC/Stg/Lift/Types.hs @@ -4,7 +4,7 @@ -- This module declares some basic types used by GHC.Stg.Lift -- We can import this module into GHC.Stg.Syntax, where the --- type instance declartions for BinderP etc live +-- type instance declarations for BinderP etc live module GHC.Stg.Lift.Types( Skeleton(..), diff --git a/GHC/Stg/Lint.hs b/GHC/Stg/Lint.hs --- a/GHC/Stg/Lint.hs +++ b/GHC/Stg/Lint.hs @@ -178,7 +178,7 @@ lintStgConArg :: StgArg -> LintM () lintStgConArg arg = do unarised <- lf_unarised <$> getLintFlags - when unarised $ case typePrimRep_maybe (stgArgType arg) of + when unarised $ case stgArgRep_maybe arg of -- Note [Post-unarisation invariants], invariant 4 Just [_] -> pure () badRep -> addErrL $ @@ -192,7 +192,7 @@ lintStgFunArg :: StgArg -> LintM () lintStgFunArg arg = do unarised <- lf_unarised <$> getLintFlags - when unarised $ case typePrimRep_maybe (stgArgType arg) of + when unarised $ case stgArgRep_maybe arg of -- Note [Post-unarisation invariants], invariant 3 Just [] -> pure () Just [_] -> pure () @@ -302,13 +302,13 @@ lintStgExpr (StgLet _ binds body) = do binders <- lintStgBinds NotTopLevel binds - addLoc (BodyOfLetRec binders) $ + addLoc (BodyOfLet binders) $ addInScopeVars binders $ lintStgExpr body lintStgExpr (StgLetNoEscape _ binds body) = do binders <- lintStgBinds NotTopLevel binds - addLoc (BodyOfLetRec binders) $ + addLoc (BodyOfLet binders) $ addInScopeVars binders $ lintStgExpr body @@ -371,22 +371,16 @@ -- and we abort kind checking. fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]] fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys' - actual_arg_reps = map (typePrimRep_maybe . stgArgType) args + actual_arg_reps = map stgArgRep_maybe args match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM () match_args (Nothing:_) _ = return () match_args (_) (Nothing:_) = return () match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left) - -- Common case, reps are exactly the same + -- Common case, reps are exactly the same (perhaps void) | actual_rep == expected_rep = match_args actual_reps_left expected_reps_left - -- Check for void rep which can be either an empty list *or* [VoidRep] - -- No, typePrimRep_maybe will never return a result containing VoidRep. - -- We should refactor to make this obvious from the types. - | isVoidRep actual_rep && isVoidRep expected_rep - = match_args actual_reps_left expected_reps_left - -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep. -- We check for that here with primRepCompatible | primRepsCompatible platform actual_rep expected_rep @@ -409,9 +403,6 @@ -- text "expected reps:" <> ppr arg_ty_reps $$ text "unarised?:" <> ppr (lf_unarised lf)) where - isVoidRep [] = True - isVoidRep [VoidRep] = True - isVoidRep _ = False -- Try to strip one non-void arg rep from the current argument type returning -- the remaining list of arguments. We return Nothing for invalid input which -- will result in a lint failure in match_args. @@ -438,7 +429,7 @@ (text "marks" <> ppr marks $$ text "args" <> ppr args $$ text "arity" <> ppr (idArity fun) $$ - text "join_arity" <> ppr (isJoinId_maybe fun)) + text "join_arity" <> ppr (idJoinPointHood fun)) lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks" {- @@ -469,7 +460,7 @@ data LintLocInfo = RhsOf Id -- The variable bound | LambdaBodyOf [Id] -- The lambda-binder - | BodyOfLetRec [Id] -- One of the binders + | BodyOfLet [Id] -- The binders of the let dumpLoc :: LintLocInfo -> (SrcSpan, SDoc) dumpLoc (RhsOf v) = @@ -477,8 +468,8 @@ dumpLoc (LambdaBodyOf bs) = (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' ) -dumpLoc (BodyOfLetRec bs) = - (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' ) +dumpLoc (BodyOfLet bs) = + (srcLocSpan (getSrcLoc (head bs)), text " [in body of let with binders " <> pp_binders bs <> char ']' ) pp_binders :: [Id] -> SDoc diff --git a/GHC/Stg/Make.hs b/GHC/Stg/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Make.hs @@ -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 diff --git a/GHC/Stg/Pipeline.hs b/GHC/Stg/Pipeline.hs --- a/GHC/Stg/Pipeline.hs +++ b/GHC/Stg/Pipeline.hs @@ -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 @@ -41,8 +43,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import GHC.Settings (Platform) -import GHC.Stg.InferTags (inferTags) -import GHC.Stg.InferTags.TagSig ( StgCgInfos ) +import GHC.Stg.EnforceEpt (enforceEpt) +import GHC.Stg.EnforceEpt.TagSig ( StgCgInfos ) data StgPipelineOpts = StgPipelineOpts { stgPipeline_phases :: ![StgToDo] @@ -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 } @@ -74,6 +82,7 @@ -> IO ([(CgStgTopBinding,IdSet)], StgCgInfos) -- output program stg2stg logger extra_vars opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds + ; stg_linter False "StgFromCore" binds ; showPass logger "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $ @@ -91,11 +100,13 @@ -- annotations (which is used by code generator to compute offsets into closures) ; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds') -- See Note [Tag inference for interactive contexts] - ; (cg_binds, cg_infos) <- inferTags (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs + ; (cg_binds, cg_infos) <- enforceEpt (stgPipeline_pprOpts opts) (stgPipeline_forBytecode opts) logger this_mod binds_sorted_with_fvs + ; stg_linter False "StgCodeGen" cg_binds ; pure (zip cg_binds imp_fvs, cg_infos) } where + stg_linter :: (BinderP a ~ Id, OutputablePass a) => Bool -> String -> [GenStgTopBinding a] -> IO () stg_linter unarised | Just diag_opts <- stgPipeline_lint opts = lintStgTopBindings @@ -133,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' diff --git a/GHC/Stg/Stats.hs b/GHC/Stg/Stats.hs --- a/GHC/Stg/Stats.hs +++ b/GHC/Stg/Stats.hs @@ -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 ) {- diff --git a/GHC/Stg/Syntax.hs b/GHC/Stg/Syntax.hs --- a/GHC/Stg/Syntax.hs +++ b/GHC/Stg/Syntax.hs @@ -54,8 +54,12 @@ -- utils stgRhsArity, freeVarsOfRhs, - isDllConApp, stgArgType, + stgArgRep, + stgArgRep1, + stgArgRepU, + stgArgRep_maybe, + stgCaseBndrInScope, -- ppr @@ -68,7 +72,7 @@ import GHC.Prelude -import GHC.Stg.InferTags.TagSig( TagSig ) +import GHC.Stg.EnforceEpt.TagSig( TagSig ) import GHC.Stg.Lift.Types -- To avoid having an orphan instances for BinderP, XLet etc @@ -76,23 +80,20 @@ import GHC.Core ( AltCon ) import GHC.Core.DataCon -import GHC.Core.TyCon ( PrimRep(..), TyCon ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type ( Type ) import GHC.Core.Ppr( {- instances -} ) import GHC.Types.ForeignCall ( ForeignCall ) import GHC.Types.Id -import GHC.Types.Name ( isDynLinkName ) import GHC.Types.Tickish ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal ( Literal, literalType ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) -import GHC.Unit.Module ( Module ) import GHC.Utils.Outputable import GHC.Utils.Panic.Plain -import GHC.Platform import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) import Data.ByteString ( ByteString ) @@ -133,63 +134,39 @@ = StgVarArg Id | StgLitArg Literal --- | Does this constructor application refer to anything in a different --- *Windows* DLL? --- If so, we can't allocate it statically -isDllConApp - :: Platform - -> Bool -- is Opt_ExternalDynamicRefs enabled? - -> Module - -> DataCon - -> [StgArg] - -> Bool -isDllConApp platform ext_dyn_refs this_mod con args - | not ext_dyn_refs = False - | platformOS platform == OSMinGW32 - = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args - | otherwise = False - where - -- 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 False for isDllConApp --- --- 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 :: PrimRep -> Bool -isAddrRep AddrRep = True -isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript -isAddrRep _ = False - -- | Type of an @StgArg@ -- -- Very half baked because we have lost the type arguments. +-- +-- This function should be avoided: in STG we aren't supposed to +-- look at types, but only PrimReps. +-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed. stgArgType :: StgArg -> Type stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit +stgArgRep :: StgArg -> [PrimRep] +stgArgRep ty = typePrimRep (stgArgType ty) + +stgArgRep_maybe :: StgArg -> Maybe [PrimRep] +stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty) + +-- | Assumes that the argument has at most one PrimRep, which holds after unarisation. +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRep1 :: StgArg -> PrimOrVoidRep +stgArgRep1 ty = typePrimRep1 (stgArgType ty) + +-- | Assumes that the argument has exactly one PrimRep. +-- See Note [VoidRep] in GHC.Types.RepType. +stgArgRepU :: StgArg -> PrimRep +stgArgRepU ty = typePrimRepU (stgArgType ty) + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- -- Case binders of unboxed tuple or unboxed sum type always dead after the --- unariser has run. See Note [Post-unarisation invariants]. +-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise. stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool stgCaseBndrInScope alt_ty unarised = case alt_ty of @@ -291,7 +268,7 @@ | StgConApp DataCon ConstructorNumber [StgArg] -- Saturated. See Note [Constructor applications in STG] - [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call [StgArg] -- Saturated. @@ -633,9 +610,9 @@ each binding. See Note [Late lambda lifting in STG]. - 4. Tag inference takes in 'Vanilla and produces 'InferTagged STG, while using + 4. EPT enforcement takes in 'Vanilla and produces 'InferTagged STG, while using the InferTaggedBinders annotated AST internally. - See Note [Tag Inference]. + See Note [EPT enforcement]. 5. Stg.FVs annotates closures with their free variables. To store these annotations we use the 'CodeGen parameterisation. @@ -650,9 +627,9 @@ = Vanilla | LiftLams -- ^ Use internally by the lambda lifting pass | InferTaggedBinders -- ^ Tag inference information on binders. - -- See Note [Tag inference passes] in GHC.Stg.InferTags + -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt | InferTagged -- ^ Tag inference information put on relevant StgApp nodes - -- See Note [Tag inference passes] in GHC.Stg.InferTags + -- See Note [EPT enforcement] in GHC.Stg.EnforceEpt | CodeGen type family BinderP (pass :: StgPass) @@ -695,24 +672,35 @@ This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. -A @ReEntrant@ closure may be entered multiple times, but should not be updated -or blackholed. An @Updatable@ closure should be updated after evaluation (and -may be blackholed during evaluation). A @SingleEntry@ closure will only be -entered once, and so need not be updated but may safely be blackholed. -} -data UpdateFlag = ReEntrant | Updatable | SingleEntry +data UpdateFlag + = ReEntrant + -- ^ A @ReEntrant@ closure may be entered multiple times, but should not + -- be updated or blackholed. + | Updatable + -- ^ An @Updatable@ closure should be updated after evaluation (and may be + -- blackholed during evaluation). + | SingleEntry + -- ^ A @SingleEntry@ closure will only be entered once, and so need not be + -- updated but may safely be blackholed. + | JumpedTo + -- ^ A @JumpedTo@ (join-point) closure is entered once or multiple times + -- but has no heap-allocated associated closure. + deriving (Show,Eq) instance Outputable UpdateFlag where ppr u = char $ case u of ReEntrant -> 'r' Updatable -> 'u' SingleEntry -> 's' + JumpedTo -> 'j' isUpdatable :: UpdateFlag -> Bool isUpdatable ReEntrant = False isUpdatable SingleEntry = False isUpdatable Updatable = True +isUpdatable JumpedTo = False {- ************************************************************************ @@ -880,10 +868,9 @@ , hang (text "} in ") 2 (pprStgExpr opts expr) ] - StgTick _tickish expr -> sdocOption sdocSuppressTicks $ \case + StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case True -> pprStgExpr opts expr - False -> pprStgExpr opts expr - -- XXX sep [ ppr tickish, pprStgExpr opts expr ] + False -> sep [ ppr tickish, pprStgExpr opts expr ] -- Don't indent for a single case alternative. StgCase expr bndr alt_type [alt] diff --git a/GHC/Stg/Unarise.hs b/GHC/Stg/Unarise.hs --- a/GHC/Stg/Unarise.hs +++ b/GHC/Stg/Unarise.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiWayIf #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 @@ -166,8 +167,8 @@ way to fix what is ultimately a corner-case. -Note [Types in StgConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Representations in StgConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term: (# 123 | #) @@ -180,10 +181,22 @@ (# 1#, 123, rubbish, rubbish #) -- when type is (# Int | (# Int, Int, Int #) #) -So we pass type arguments of the DataCon's TyCon in StgConApp to decide what -layout to use. Note that unlifted values can't be let-bound, so we don't need -types in StgRhsCon. +Therefore, in StgConApp we store a list [[PrimRep]] of representations +to decide what layout to use. +Given (# T_1 | ... | T_n #), this list will be +[typePrimRep T_1, ..., typePrimRep T_n]. +For example, given type + (# Int | String #) we will store [[LiftedRep], [LiftedRep]] + (# Int | Float# #) we will store [[LiftedRep], [FloatRep]] + (# Int | (# Int, Int, Int #) #) we will store [[LiftedRep], [LiftedRep, LiftedRep, LiftedRep]]. +This field is used for unboxed sums only and it's an empty list otherwise. +Perhaps it would be more elegant to have a separate StgUnboxedSumCon, +but that would require duplication of code in cases where the logic is shared. + +Note that unlifted values can't be let-bound, so we don't need +representations in StgRhsCon. + Note [Casting slot arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this function which selects between Int32# and Int64# from a unboxed sum. @@ -298,7 +311,7 @@ (x' :: Int32#) -> alt_rhs ) -We then run unarise on alt_rhs within that expression, which will replace the first occurence +We then run unarise on alt_rhs within that expression, which will replace the first occurrence of `x` with sum_slot_arg_1 giving us post-unarise: f sum_tag sum_slot1 = @@ -361,6 +374,7 @@ 2. No unboxed tuple binders. Tuples only appear in return position. 3. Binders and literals always have zero (for void arguments) or one PrimRep. + (i.e. typePrimRep1 won't crash; see Note [VoidRep] in GHC.Types.RepType.) 4. DataCon applications (StgRhsCon and StgConApp) don't have void arguments. This means that it's safe to wrap `StgArg`s of DataCon applications with @@ -385,10 +399,10 @@ import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Stg.Utils +import GHC.Stg.Make import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types @@ -430,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]. @@ -447,10 +465,10 @@ -- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv extendRho env x (MultiVal args) - = assert (all (isNvUnaryType . stgArgType) args) + = assert (all (isNvUnaryRep . stgArgRep) args) env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) } extendRho env x (UnaryVal val) - = assert (isNvUnaryType (stgArgType val)) + = assert (isNvUnaryRep (stgArgRep val)) env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) } -- Properly shadow things from an outer scope. -- See Note [UnariseEnv] @@ -465,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) @@ -528,7 +576,7 @@ -> return $ (mkTuple args') | otherwise = let args' = unariseConArgs rho args in - return $ (StgConApp dc n args' (map stgArgType args')) + return $ (StgConApp dc n args' []) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -564,16 +612,16 @@ -- 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 -- Doesn't return void args. -unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [[PrimRep]] -> ( [OutStgArg] -- Arguments representing the unboxed sum , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them -- into the right Rep @@ -596,13 +644,12 @@ -- See also Note [Rubbish literals] in GHC.Types.Literal. unariseLiteral_maybe :: Literal -> Maybe [OutStgArg] unariseLiteral_maybe (LitRubbish torc rep) - | [prep] <- preps - , assert (not (isVoidRep prep)) True - = Nothing -- Single, non-void PrimRep. Nothing to do! + | [_] <- preps + = Nothing -- Single PrimRep. Nothing to do! - | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase + | otherwise -- Multiple reps, or zero. Eliminate via elimCase = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) - | prep <- preps, assert (not (isVoidRep prep)) True ] + | prep <- preps ] where preps = runtimeRepPrimRep (text "unariseLiteral_maybe") rep @@ -746,15 +793,13 @@ -> UnariseEnv -> UnariseEnv mapTupleIdBinders ids args0 rho0 - = assert (not (any (isZeroBitTy . stgArgType) args0)) $ + = 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) @@ -769,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). @@ -780,13 +825,13 @@ -> UniqSM (UnariseEnv, OutStgExpr) mapSumIdBinders alt_bndr args rhs rho0 - = assert (not (any (isZeroBitTy . stgArgType) args)) $ do + = assert (not (any (null . stgArgRep) args)) $ do uss <- listSplitUniqSupply <$> getUniqueSupplyM let fld_reps = typePrimRep (idType alt_bndr) -- Slots representing the whole sum - arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args + arg_slots = map primRepSlot $ concatMap stgArgRep args -- The slots representing the field of the sum we bind. id_slots = map primRepSlot $ fld_reps layout1 = layoutUbxSum arg_slots id_slots @@ -797,15 +842,13 @@ -- Select only the args which contain parts of the current field. id_arg_exprs = [ args !! i | i <- layout1 ] id_vars = [v | StgVarArg v <- id_arg_exprs] - -- Output types for the field binders based on their rep - id_tys = map primRepToType fld_reps - typed_id_arg_input = assert (equalLength id_vars id_tys) $ - zip3 id_vars id_tys uss + typed_id_arg_input = assert (equalLength id_vars fld_reps) $ + zip3 id_vars fld_reps uss - mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) - mkCastInput (id,tar_type,bndr_us) = - let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + mkCastInput :: (Id,PrimRep,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,rep,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRepU $ idType id) rep cst_opts = zip3 ops types $ uniqsFromSupply bndr_us out_id = case cst_opts of [] -> id @@ -823,7 +866,7 @@ typed_id_args = map StgVarArg typed_ids -- pprTrace "mapSumIdBinders" - -- (text "id_tys" <+> ppr id_tys $$ + -- (text "fld_reps" <+> ppr fld_reps $$ -- text "id_args" <+> ppr id_arg_exprs $$ -- text "rhs" <+> ppr rhs $$ -- text "rhs_with_casts" <+> ppr rhs_with_casts @@ -851,7 +894,7 @@ mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = - let r2 = typePrimRep1 out_ty + let r2 = typePrimRepU out_ty scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} alt_ty = PrimAlt r2 @@ -861,7 +904,7 @@ -- -- Example, for (# x | #) :: (# (# #) | Int #) we call -- --- mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ] +-- mkUbxSum (# _ | #) [ [], [LiftedRep] ] [ voidPrimId ] -- -- which returns -- @@ -870,7 +913,7 @@ mkUbxSum :: HasDebugCallStack => DataCon -- Sum data con - -> [Type] -- Type arguments of the sum data con + -> [[PrimRep]] -- Representations of type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. -> UniqSupply -> ([OutStgArg] -- Final tuple arguments @@ -878,14 +921,14 @@ ) mkUbxSum dc ty_args args0 us = let - _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType ty_args -- drop tag slot - field_slots = (mapMaybe (typeSlotTy . stgArgType) args0) + field_slots = (mapMaybe (repSlotTy . stgArgRep) args0) tag = dataConTag dc layout' = layoutUbxSum sum_slots field_slots tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) - arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) + arg_idxs = IM.fromList (zipEqual layout' args0) ((_idx,_idx_map,_us,wrapper),slot_args) = assert (length arg_idxs <= length sum_slots ) $ @@ -897,7 +940,7 @@ mkTupArg (arg_idx, arg_map, us, wrapper) slot | Just stg_arg <- IM.lookup arg_idx arg_map = case castArg us slot stg_arg of - -- Slot and arg type missmatched, do a cast + -- Slot and arg type mismatched, do a cast Just (casted_arg,us',wrapper') -> ( (arg_idx+1, arg_map, us', wrapper . wrapper') , casted_arg) @@ -913,9 +956,8 @@ castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) castArg us slot_ty arg -- Cast the argument to the type of the slot if required - | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg) - , out_ty <- primRepToType $ slotPrimRep slot_ty - , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty + | slotPrimRep slot_ty /= stgArgRepU arg + , (ops,types) <- unzip $ getCasts (stgArgRepU arg) $ slotPrimRep slot_ty , not . null $ ops = let (us1,us2) = splitUniqSupply us cast_uqs = uniqsFromSupply us1 @@ -964,13 +1006,13 @@ - When unarising function arg binders and arguments, we don't want to remove void binders and arguments. For example, - f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ... + f :: (# (# #), (# #) #) -> Void# -> State# RealWorld -> ... f x y z = Here after unarise we should still get a function with arity 3. Similarly in the call site we shouldn't remove void arguments: - f (# (# #), (# #) #) void# rw + f (# (# #), (# #) #) void# realWorld# When unarising , we extend the environment with these binders: @@ -1086,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] @@ -1102,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 @@ -1122,7 +1164,7 @@ isUnboxedTupleBndr = isUnboxedTupleType . idType mkTuple :: [StgArg] -> StgExpr -mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args) +mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args [] tagAltTy :: AltType tagAltTy = PrimAlt IntRep @@ -1134,7 +1176,7 @@ voidArg = StgVarArg voidPrimId mkDefaultLitAlt :: [StgAlt] -> [StgAlt] --- We have an exhauseive list of literal alternatives +-- We have an exhaustive list of literal alternatives -- 1# -> e1 -- 2# -> e2 -- Since they are exhaustive, we can replace one with DEFAULT, to avoid diff --git a/GHC/Stg/Utils.hs b/GHC/Stg/Utils.hs --- a/GHC/Stg/Utils.hs +++ b/GHC/Stg/Utils.hs @@ -9,9 +9,12 @@ , idArgs , mkUnarisedId, mkUnarisedIds + + , allowTopLevelConApp ) where import GHC.Prelude +import GHC.Platform import GHC.Types.Id import GHC.Core.Type @@ -22,19 +25,20 @@ 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 -import GHC.Utils.Panic.Plain import GHC.Utils.Panic 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. @@ -123,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 + diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -1,2272 +1,2776 @@ - -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} - -{-# OPTIONS_GHC -fprof-auto-top #-} - --- --- (c) The University of Glasgow 2002-2006 --- - --- | GHC.StgToByteCode: Generate bytecode from STG -module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where - -import GHC.Prelude - -import GHC.Driver.DynFlags -import GHC.Driver.Env - -import GHC.ByteCode.Instr -import GHC.ByteCode.Asm -import GHC.ByteCode.Types - -import GHC.Cmm.CallConv -import GHC.Cmm.Expr -import GHC.Cmm.Node -import GHC.Cmm.Utils - -import GHC.Platform -import GHC.Platform.Profile - -import GHC.Runtime.Interpreter -import GHCi.FFI -import GHCi.RemoteTypes -import GHC.Types.Basic -import GHC.Utils.Outputable -import GHC.Types.Name -import GHC.Types.Id -import GHC.Types.ForeignCall -import GHC.Core -import GHC.Types.Literal -import GHC.Builtin.PrimOps -import GHC.Builtin.PrimOps.Ids (primOpId) -import GHC.Core.Type -import GHC.Core.TyCo.Compare (eqType) -import GHC.Types.RepType -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Utils.Misc -import GHC.Utils.Logger -import GHC.Types.Var.Set -import GHC.Builtin.Types.Prim -import GHC.Core.TyCo.Ppr ( pprType ) -import GHC.Utils.Error -import GHC.Builtin.Uniques -import GHC.Data.FastString -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Exception (evaluate) -import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds, argPrimRep ) -import GHC.StgToCmm.Layout -import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) -import GHC.Data.Bitmap -import GHC.Data.OrdList -import GHC.Data.Maybe -import GHC.Types.Name.Env (mkNameEnv) -import GHC.Types.Tickish - -import Data.List ( genericReplicate, genericLength, intersperse - , partition, scanl', sortBy, zip4, zip6 ) -import Foreign hiding (shiftL, shiftR) -import Control.Monad -import Data.Char - -import GHC.Unit.Module - -import Data.Array -import Data.Coerce (coerce) -import Data.ByteString (ByteString) -import Data.Map (Map) -import Data.IntMap (IntMap) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import qualified Data.List.NonEmpty as NE -import qualified GHC.Data.FiniteMap as Map -import Data.Ord -import GHC.Stack.CCS -import Data.Either ( partitionEithers ) - -import GHC.Stg.Syntax -import qualified Data.IntSet as IntSet -import GHC.CoreToIface - --- ----------------------------------------------------------------------------- --- Generating byte code for a complete module - -byteCodeGen :: HscEnv - -> Module - -> [CgStgTopBinding] - -> [TyCon] - -> Maybe ModBreaks - -> IO CompiledByteCode -byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming logger - (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) - (const ()) $ do - -- Split top-level binds into strings and others. - -- See Note [Generating code for top-level string literal bindings]. - let (strings, lifted_binds) = partitionEithers $ do -- list monad - bnd <- binds - case bnd of - StgTopLifted bnd -> [Right bnd] - StgTopStringLit b str -> [Left (b, str)] - flattenBind (StgNonRec b e) = [(b,e)] - flattenBind (StgRec bs) = bs - stringPtrs <- allocateTopStrings interp strings - - (BcM_State{..}, proto_bcos) <- - runBc hsc_env this_mod mb_modBreaks $ do - let flattened_binds = concatMap flattenBind (reverse lifted_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))) - - cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs - (case modBreaks of - Nothing -> Nothing - Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) - - -- Squash space leaks in the CompiledByteCode. This is really - -- important, because when loading a set of modules into GHCi - -- we don't touch the CompiledByteCode until the end when we - -- do linking. Forcing out the thunks here reduces space - -- usage by more than 50% when loading a large number of - -- modules. - evaluate (seqCompiledByteCode cbc) - - return cbc - - where dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - interp = hscInterp hsc_env - profile = targetProfile dflags - --- | see Note [Generating code for top-level string literal bindings] -allocateTopStrings - :: Interp - -> [(Id, ByteString)] - -> IO AddrEnv -allocateTopStrings interp topStrings = do - let !(bndrs, strings) = unzip topStrings - ptrs <- interpCmd interp $ MallocStrings strings - return $ mkNameEnv (zipWith mk_entry bndrs ptrs) - where - mk_entry bndr ptr = let nm = getName bndr - in (nm, (nm, AddrPtr ptr)) - -{- Note [Generating code for top-level string literal bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Compilation plan for top-level string literals] -in GHC.Core, the core-to-core optimizer can introduce top-level Addr# -bindings to represent string literals. The creates two challenges for -the bytecode compiler: (1) compiling the bindings themselves, and -(2) compiling references to such bindings. Here is a summary on how -we deal with them: - - 1. Top-level string literal bindings are separated from the rest of - the module. Memory for them is allocated immediately, via - interpCmd, in allocateTopStrings, and the resulting AddrEnv is - recorded in the bc_strs field of the CompiledByteCode result. - - 2. When we encounter a reference to a top-level string literal, we - generate a PUSH_ADDR pseudo-instruction, which is assembled to - a PUSH_UBX instruction with a BCONPtrAddr argument. - - 3. The loader accumulates string literal bindings from loaded - bytecode in the addr_env field of the LinkerEnv. - - 4. The BCO linker resolves BCONPtrAddr references by searching both - the addr_env (to find literals defined in bytecode) and the native - symbol table (to find literals defined in native code). - -This strategy works alright, but it does have one significant problem: -we never free the memory that we allocate for the top-level strings. -In theory, we could explicitly free it when BCOs are unloaded, but -this comes with its own complications; see #22400 for why. For now, -we just accept the leak, but it would nice to find something better. -} - --- ----------------------------------------------------------------------------- --- Compilation schema for the bytecode generator - -type BCInstrList = OrdList BCInstr - -wordsToBytes :: Platform -> WordOff -> ByteOff -wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral - --- Used when we know we have a whole number of words -bytesToWords :: Platform -> ByteOff -> WordOff -bytesToWords platform (ByteOff bytes) = - let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform) - in if r == 0 - then fromIntegral q - else pprPanic "GHC.StgToByteCode.bytesToWords" - (text "bytes=" <> ppr bytes) - -wordSize :: Platform -> ByteOff -wordSize platform = ByteOff (platformWordSizeInBytes platform) - -type Sequel = ByteOff -- back off to this depth before ENTER - -type StackDepth = ByteOff - --- | Maps Ids to their stack depth. This allows us to avoid having to mess with --- it after each push/pop. -type BCEnv = Map Id StackDepth -- To find vars on the stack - -{- -ppBCEnv :: BCEnv -> SDoc -ppBCEnv p - = text "begin-env" - $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) - $$ text "end-env" - where - pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var) - cmp_snd x y = compare (snd x) (snd y) --} - --- Create a BCO and do a spot of peephole optimisation on the insns --- at the same time. -mkProtoBCO - :: Platform - -> name - -> BCInstrList - -> Either [CgStgAlt] (CgStgRhs) - -- ^ original expression; for debugging only - -> Int -- ^ arity - -> WordOff -- ^ bitmap size - -> [StgWord] -- ^ bitmap - -> Bool -- ^ True <=> is a return point, rather than a function - -> [FFIInfo] - -> ProtoBCO name -mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis - = ProtoBCO { - protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, - protoBCOBitmap = bitmap, - protoBCOBitmapSize = fromIntegral bitmap_size, - protoBCOArity = arity, - protoBCOExpr = origin, - protoBCOFFIs = ffis - } - where - -- Overestimate the stack usage (in words) of this BCO, - -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit - -- stack check. (The interpreter always does a stack check - -- for iNTERP_STACK_CHECK_THRESH words at the start of each - -- BCO anyway, so we only need to add an explicit one in the - -- (hopefully rare) cases when the (overestimated) stack use - -- exceeds iNTERP_STACK_CHECK_THRESH. - maybe_with_stack_check - | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d - -- don't do stack checks at return points, - -- everything is aggregated up to the top BCO - -- (which must be a function). - -- That is, unless the stack usage is >= AP_STACK_SPLIM, - -- see bug #1466. - | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH - = STKCHECK stack_usage : peep_d - | otherwise - = peep_d -- the supposedly common case - - -- We assume that this sum doesn't wrap - stack_usage = sum (map bciStackUse peep_d) - - -- Merge local pushes - peep_d = peep (fromOL instrs_ordlist) - - peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) - = PUSH_LLL off1 (off2-1) (off3-2) : peep rest - peep (PUSH_L off1 : PUSH_L off2 : rest) - = PUSH_LL off1 (off2-1) : peep rest - peep (i:rest) - = i : peep rest - peep [] - = [] - -argBits :: Platform -> [ArgRep] -> [Bool] -argBits _ [] = [] -argBits platform (rep : args) - | isFollowableArg rep = False : argBits platform args - | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args - -non_void :: NonEmpty ArgRep -> [ArgRep] -non_void = NE.filter nv - where nv V = False - nv _ = True - --- ----------------------------------------------------------------------------- --- schemeTopBind - --- Compile code for the right-hand side of a top-level binding - -schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name) -schemeTopBind (id, rhs) - | Just data_con <- isDataConWorkId_maybe id, - isNullaryRepDataCon data_con = do - platform <- profilePlatform <$> getProfile - -- Special case for the worker of a nullary data con. - -- It'll look like this: Nil = /\a -> Nil a - -- If we feed it into schemeR, we'll get - -- Nil = Nil - -- because mkConAppCode treats nullary constructor applications - -- by just re-using the single top-level definition. So - -- for the worker itself, we must allocate it directly. - -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) - - | otherwise - = schemeR [{- No free variables -}] (getName id, rhs) - - --- ----------------------------------------------------------------------------- --- schemeR - --- Compile code for a right-hand side, to give a BCO that, --- when executed with the free variables and arguments on top of the stack, --- will return with a pointer to the result on top of the stack, after --- removing the free variables and arguments. --- --- Park the resulting BCO in the monad. Also requires the --- name of the variable to which this value was bound, --- so as to give the resulting BCO a name. -schemeR :: [Id] -- Free vars of the RHS, ordered as they - -- will appear in the thunk. Empty for - -- top-level things, which have no free vars. - -> (Name, CgStgRhs) - -> BcM (ProtoBCO Name) -schemeR fvs (nm, rhs) - = schemeR_wrk fvs nm rhs (collect rhs) - --- If an expression is a lambda, return the --- list of arguments to the lambda (in R-to-L order) and the --- underlying expression - -collect :: CgStgRhs -> ([Var], CgStgExpr) -collect (StgRhsClosure _ _ _ args body _) = (args, body) -collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args []) - -schemeR_wrk - :: [Id] - -> Name - -> CgStgRhs -- expression e, for debugging only - -> ([Var], CgStgExpr) -- result of collect on e - -> BcM (ProtoBCO Name) -schemeR_wrk fvs nm original_body (args, body) - = do - profile <- getProfile - let - platform = profilePlatform profile - all_args = reverse args ++ fvs - arity = length all_args - -- all_args are the args in reverse order. We're compiling a function - -- \fv1..fvn x1..xn -> e - -- i.e. the fvs come first - - -- Stack arguments always take a whole number of words, we never pack - -- them unlike constructor fields. - szsb_args = map (wordsToBytes platform . idSizeW platform) all_args - sum_szsb_args = sum szsb_args - p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) - - -- make the arg bitmap - bits = argBits platform (reverse (map (bcIdArgRep platform) all_args)) - bitmap_size = genericLength bits - bitmap = mkBitmap platform bits - body_code <- schemeER_wrk sum_szsb_args p_init body - - emitBc (mkProtoBCO platform nm body_code (Right original_body) - arity bitmap_size bitmap False{-not alts-}) - --- introduce break instructions for ticked expressions -schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs) - = do code <- schemeE d 0 p rhs - cc_arr <- getCCArray - platform <- profilePlatform <$> getProfile - let idOffSets = getVarOffSets platform d p fvs - ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) - let toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) - toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) - breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty - newBreakInfo tick_no breakInfo - hsc_env <- getHscEnv - let cc | Just interp <- hsc_interp hsc_env - , interpreterProfiled interp - = cc_arr ! tick_no - | otherwise = toRemotePtr nullPtr - mb_mod_name <- getCurrentModuleName - case mb_mod_name of - Just mod_ptr -> do - let breakInstr = BRK_FUN (fromIntegral tick_no) mod_ptr cc - return $ breakInstr `consOL` code - Nothing -> return code -schemeER_wrk d p rhs = schemeE d 0 p rhs - -getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] -getVarOffSets platform depth env = map getOffSet - where - getOffSet id = case lookupBCEnv_maybe id env of - Nothing -> Nothing - Just offset -> - -- michalt: I'm not entirely sure why we need the stack - -- adjustment by 2 here. I initially thought that there's - -- something off with getIdValFromApStack (the only user of this - -- value), but it looks ok to me. My current hypothesis is that - -- this "adjustment" is needed due to stack manipulation for - -- BRK_FUN in Interpreter.c In any case, this is used only when - -- we trigger a breakpoint. - let !var_depth_ws = bytesToWords platform (depth - offset) + 2 - in Just (id, var_depth_ws) - -fvsToEnv :: BCEnv -> CgStgRhs -> [Id] --- Takes the free variables of a right-hand side, and --- delivers an ordered list of the local variables that will --- be captured in the thunk for the RHS --- The BCEnv argument tells which variables are in the local --- environment: these are the ones that should be captured --- --- The code that constructs the thunk, and the code that executes --- it, have to agree about this layout - -fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs, - v `Map.member` p] - --- ----------------------------------------------------------------------------- --- schemeE - --- Returning an unlifted value. --- Heave it on the stack, SLIDE, and RETURN. -returnUnliftedAtom - :: StackDepth - -> Sequel - -> BCEnv - -> StgArg - -> BcM BCInstrList -returnUnliftedAtom d s p e = do - let reps = case e of - StgLitArg lit -> typePrimRepArgs (literalType lit) - StgVarArg i -> bcIdPrimReps i - (push, szb) <- pushAtom d p e - ret <- returnUnliftedReps d s szb (NE.toList $! reps) - return (push `appOL` ret) - --- return an unlifted value from the top of the stack -returnUnliftedReps - :: StackDepth - -> Sequel - -> ByteOff -- size of the thing we're returning - -> [PrimRep] -- representations - -> BcM BCInstrList -returnUnliftedReps d s szb reps = do - profile <- getProfile - let platform = profilePlatform profile - non_void VoidRep = False - non_void _ = True - ret <- case filter non_void reps of - -- use RETURN for nullary/unary representations - [] -> return (unitOL $ RETURN V) - [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 - 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 - `consOL` ret) -- go - --- construct and return an unboxed tuple -returnUnboxedTuple - :: StackDepth - -> Sequel - -> BCEnv - -> [StgArg] - -> BcM BCInstrList -returnUnboxedTuple d s p es = do - profile <- getProfile - let platform = profilePlatform profile - arg_ty e = primRepCmmType platform (atomPrimRep e) - (call_info, tuple_components) = layoutNativeCall profile - NativeTupleReturn - d - arg_ty - es - go _ pushes [] = return (reverse pushes) - go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a - massert (off == dd + szb) - go (dd + szb) (push:pushes) cs - pushes <- go d [] tuple_components - ret <- returnUnliftedReps d - s - (wordsToBytes platform $ nativeCallSize call_info) - (map atomPrimRep es) - return (mconcat pushes `appOL` ret) - --- Compile code to apply the given expression to the remaining args --- on the stack, returning a HNF. -schemeE - :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList -schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) -schemeE d s p (StgApp x []) - | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) --- Delegate tail-calls to schemeT. -schemeE d s p e@(StgApp {}) = schemeT d s p e -schemeE d s p e@(StgConApp {}) = schemeT d s p e -schemeE d s p e@(StgOpApp {}) = schemeT d s p e -schemeE d s p (StgLetNoEscape xlet bnd body) - = schemeE d s p (StgLet xlet bnd body) -schemeE d s p (StgLet _xlet - (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args _typ)) - body) - = do -- Special case for a non-recursive let whose RHS is a - -- saturated constructor application. - -- Just allocate the constructor and carry on - alloc_code <- mkConAppCode d s p data_con args - platform <- targetPlatform <$> getDynFlags - let !d2 = d + wordSize platform - body_code <- schemeE d2 s (Map.insert x d2 p) body - return (alloc_code `appOL` body_code) --- General case for let. Generates correct, if inefficient, code in --- all situations. -schemeE d s p (StgLet _ext binds body) = do - platform <- targetPlatform <$> getDynFlags - let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs]) - StgRec xs_n_rhss -> unzip xs_n_rhss - n_binds = genericLength xs - - fvss = map (fvsToEnv p') rhss - - -- Sizes of free vars - size_w = idSizeW platform - sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss - - -- the arity of each rhs - 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 - -- after the closures have been allocated in the heap (but not - -- filled in), and pointers to them parked on the stack. - offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform)) - p' = Map.insertList (zipE xs offsets) p - d' = d + wordsToBytes platform n_binds - zipE = zipEqual "schemeE" - - -- ToDo: don't build thunks for things with no free variables - build_thunk - :: StackDepth - -> [Id] - -> WordOff - -> ProtoBCO Name - -> WordOff - -> HalfWord - -> BcM BCInstrList - build_thunk _ [] size bco off arity - = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) (fromIntegral size))) - where - mkap | arity == 0 = MKAP - | otherwise = MKPAP - build_thunk dd (fv:fvs) size bco off arity = do - (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv) - more_push_code <- - build_thunk (dd + pushed_szb) fvs size bco off arity - return (push_code `appOL` more_push_code) - - alloc_code = toOL (zipWith mkAlloc sizes arities) - where mkAlloc sz 0 - | is_tick = ALLOC_AP_NOUPD (fromIntegral sz) - | otherwise = ALLOC_AP (fromIntegral sz) - mkAlloc sz arity = ALLOC_PAP arity (fromIntegral sz) - - is_tick = case binds of - StgNonRec id _ -> occNameFS (getOccName id) == tickFS - _other -> False - - compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do - bco <- schemeR fvs (getName x,rhs) - build_thunk d' fvs size bco off arity - - compile_binds = - [ compile_bind d' fvs x rhs size arity n - | (fvs, x, rhs, size, arity, n) <- - zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] - ] - body_code <- schemeE d' s p' body - thunk_codes <- sequence compile_binds - return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) - -schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) - = panic ("schemeE: Breakpoint without let binding: " ++ - show bp_id ++ - " forgot to run bcPrep?") - --- ignore other kinds of tick -schemeE d s p (StgTick _ rhs) = schemeE d s p rhs - --- no alts: scrut is guaranteed to diverge -schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut - -schemeE d s p (StgCase scrut bndr _ alts) - = doCase d s p scrut bndr alts - - -{- - Ticked Expressions - ------------------ - - The idea is that the "breakpoint E" is really just an annotation on - the code. When we find such a thing, we pull out the useful information, - and then compile the code as if it was just the expression E. --} - --- Compile code to do a tail call. Specifically, push the fn, --- slide the on-stack app back down to the sequel depth, --- and enter. Four cases: --- --- 0. (Nasty hack). --- An application "GHC.Prim.tagToEnum# unboxed-int". --- The int will be on the stack. Generate a code sequence --- to convert it to the relevant constructor, SLIDE and ENTER. --- --- 1. The fn denotes a ccall. Defer to generateCCall. --- --- 2. An unboxed tuple: push the components on the top of --- the stack and return. --- --- 3. Application of a constructor, by defn saturated. --- Split the args into ptrs and non-ptrs, and push the nonptrs, --- then the ptrs, and then do PACK and RETURN. --- --- 4. Otherwise, it must be a function call. Push the args --- right to left, SLIDE and ENTER. - -schemeT :: StackDepth -- Stack depth - -> Sequel -- Sequel depth - -> BCEnv -- stack env - -> CgStgExpr - -> BcM BCInstrList - - -- Case 0 -schemeT d s p app - | Just (arg, constr_names) <- maybe_is_tagToEnum_call app - = implement_tagToId d s p arg constr_names - - -- Case 1 -schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty) - = if isSupportedCConv ccall_spec - then generateCCall d s p ccall_spec result_ty args - else unsupportedCConvException - -schemeT d s p (StgOpApp (StgPrimOp op) args _ty) - = doTailCall d s p (primOpId op) (reverse args) - -schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) - = generatePrimCall d s p label (Just unit) result_ty args - -schemeT d s p (StgConApp con _cn args _tys) - -- Case 2: Unboxed tuple - | isUnboxedTupleDataCon con || isUnboxedSumDataCon con - = returnUnboxedTuple d s p args - - -- Case 3: Ordinary data constructor - | otherwise - = do alloc_con <- mkConAppCode d s p con args - platform <- profilePlatform <$> getProfile - return (alloc_con `appOL` - mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P) - - -- Case 4: Tail call of function -schemeT d s p (StgApp fn args) - = doTailCall d s p fn (reverse args) - -schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT" - (pprStgExpr shortStgPprOpts e) - --- ----------------------------------------------------------------------------- --- Generate code to build a constructor application, --- leaving it on top of the stack - -mkConAppCode - :: StackDepth - -> Sequel - -> BCEnv - -> DataCon -- The data constructor - -> [StgArg] -- Args, in *reverse* order - -> BcM BCInstrList -mkConAppCode orig_d _ p con args = app_code - where - app_code = do - profile <- getProfile - let platform = profilePlatform profile - - non_voids = - [ NonVoid (prim_rep, arg) - | arg <- args - , let prim_rep = atomPrimRep arg - , not (isVoidRep prim_rep) - ] - (_, _, args_offsets) = - mkVirtHeapOffsetsWithPadding profile StdHeader non_voids - - do_pushery !d (arg : args) = do - (push, arg_bytes) <- case arg of - (Padding l _) -> return $! pushPadding (ByteOff l) - (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) - more_push_code <- do_pushery (d + arg_bytes) args - return (push `appOL` more_push_code) - do_pushery !d [] = do - let !n_arg_words = bytesToWords platform (d - orig_d) - return (unitOL (PACK con n_arg_words)) - - -- Push on the stack in the reverse order. - do_pushery orig_d (reverse args_offsets) - --- ----------------------------------------------------------------------------- --- Generate code for a tail-call - -doTailCall - :: StackDepth - -> Sequel - -> BCEnv - -> Id - -> [StgArg] - -> BcM BCInstrList -doTailCall init_d s p fn args = do - platform <- profilePlatform <$> getProfile - do_pushes init_d args (map (atomRep platform) args) - where - do_pushes !d [] reps = do - assert (null reps) return () - (push_fn, sz) <- pushAtom d p (StgVarArg fn) - 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 `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 - (next_d, push_code) <- push_seq d these_args - platform <- profilePlatform <$> getProfile - instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps - -- ^^^ for the PUSH_APPLY_ instruction - return (push_code `appOL` (push_apply `consOL` instrs)) - - push_seq d [] = return (d, nilOL) - push_seq d (arg:args) = do - (push_code, sz) <- pushAtom d p arg - (final_d, more_push_code) <- push_seq (d + sz) args - return (final_d, push_code `appOL` more_push_code) - --- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) -findPushSeq (P: P: P: P: P: P: rest) - = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (P: P: P: P: P: rest) - = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (P: P: P: P: rest) - = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (P: P: P: rest) - = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (P: P: rest) - = (PUSH_APPLY_PP, 2, rest) -findPushSeq (P: rest) - = (PUSH_APPLY_P, 1, rest) -findPushSeq (V: rest) - = (PUSH_APPLY_V, 1, rest) -findPushSeq (N: rest) - = (PUSH_APPLY_N, 1, rest) -findPushSeq (F: rest) - = (PUSH_APPLY_F, 1, rest) -findPushSeq (D: rest) - = (PUSH_APPLY_D, 1, rest) -findPushSeq (L: rest) - = (PUSH_APPLY_L, 1, rest) -findPushSeq argReps - | any (`elem` [V16, V32, V64]) argReps - = sorry "SIMD vector operations are not available in GHCi" -findPushSeq _ - = panic "GHC.StgToByteCode.findPushSeq" - --- ----------------------------------------------------------------------------- --- Case expressions - -doCase - :: StackDepth - -> Sequel - -> BCEnv - -> CgStgExpr - -> Id - -> [CgStgAlt] - -> BcM BCInstrList -doCase d s p scrut bndr alts - = do - profile <- getProfile - hsc_env <- getHscEnv - let - platform = profilePlatform profile - - -- Are we dealing with an unboxed tuple with a tuple return frame? - -- - -- 'Simple' tuples with at most one non-void component, - -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a - -- tuple return frame. This is because (# foo #) and (# foo, Void# #) - -- have the same runtime rep. We have more efficient specialized - -- return frames for the situations with one non-void element. - - non_void_arg_reps = non_void (typeArgReps platform bndr_ty) - ubx_tuple_frame = - (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && - length non_void_arg_reps > 1 - - profiling - | Just interp <- hsc_interp hsc_env - = interpreterProfiled interp - | otherwise = False - - -- Top of stack is the return itbl, as usual. - -- underneath it is the pointer to the alt_code BCO. - -- When an alt is entered, it assumes the returned value is - -- on top of the itbl; see Note [Return convention for non-tuple values] - -- for details. - ret_frame_size_b :: StackDepth - ret_frame_size_b | ubx_tuple_frame = - (if profiling then 5 else 4) * wordSize platform - | otherwise = 2 * wordSize platform - - -- The stack space used to save/restore the CCCS when profiling - save_ccs_size_b | profiling && - not ubx_tuple_frame = 2 * wordSize platform - | otherwise = 0 - - -- The size of the return frame info table pointer if one exists - unlifted_itbl_size_b :: StackDepth - unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform - | otherwise = 0 - - (bndr_size, call_info, args_offsets) - | ubx_tuple_frame = - let bndr_ty = primRepCmmType platform - bndr_reps = NE.filter (not.isVoidRep) (bcIdPrimReps bndr) - (call_info, args_offsets) = - layoutNativeCall profile NativeTupleReturn 0 bndr_ty bndr_reps - in ( wordsToBytes platform (nativeCallSize call_info) - , call_info - , args_offsets - ) - | otherwise = ( wordsToBytes platform (idSizeW platform bndr) - , voidTupleReturnInfo - , [] - ) - - -- depth of stack after the return value has been pushed - d_bndr = - d + ret_frame_size_b + bndr_size - - -- depth of stack after the extra info table for an unlifted return - -- has been pushed, if any. This is the stack depth at the - -- continuation. - d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b - - -- Env in which to compile the alts, not including - -- any vars bound by the alts themselves - p_alts = Map.insert bndr d_bndr p - - bndr_ty = idType bndr - isAlgCase = isAlgType bndr_ty - - -- given an alt, return a discr and code for it. - codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList) - codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs} - = do rhs_code <- schemeE d_alts s p_alts rhs - return (NoDiscr, rhs_code) - - codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} - -- primitive or nullary constructor alt: no need to UNPACK - | null real_bndrs = do - rhs_code <- schemeE d_alts s p_alts rhs - return (my_discr alt, rhs_code) - | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = - let bndr_ty = primRepCmmType platform . bcIdPrimRep - tuple_start = d_bndr - (call_info, args_offsets) = - layoutNativeCall profile - NativeTupleReturn - 0 - bndr_ty - bndrs - - stack_bot = d_alts - - p' = Map.insertList - [ (arg, tuple_start - - wordsToBytes platform (nativeCallSize call_info) + - offset) - | (arg, offset) <- args_offsets - , not (isVoidRep $ bcIdPrimRep arg)] - p_alts - in do - rhs_code <- schemeE stack_bot s p' rhs - return (NoDiscr, rhs_code) - -- algebraic alt with some binders - | otherwise = - let (tot_wds, _ptrs_wds, args_offsets) = - mkVirtHeapOffsets profile NoHeader - [ NonVoid (bcIdPrimRep id, id) - | NonVoid id <- nonVoidIds real_bndrs - ] - size = WordOff tot_wds - - stack_bot = d_alts + wordsToBytes platform size - - -- convert offsets from Sp into offsets into the virtual stack - p' = Map.insertList - [ (arg, stack_bot - ByteOff offset) - | (NonVoid arg, offset) <- args_offsets ] - p_alts - - in do - massert isAlgCase - rhs_code <- schemeE stack_bot s p' rhs - return (my_discr alt, - unitOL (UNPACK size) `appOL` rhs_code) - where - real_bndrs = filterOut isTyVar bndrs - - my_discr alt = case alt_con alt of - DEFAULT -> NoDiscr {-shouldn't really happen-} - DataAlt dc - | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc - -> NoDiscr - | otherwise - -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) - LitAlt l -> case l of - LitNumber LitNumInt i -> DiscrI (fromInteger i) - LitNumber LitNumInt8 i -> DiscrI8 (fromInteger i) - LitNumber LitNumInt16 i -> DiscrI16 (fromInteger i) - LitNumber LitNumInt32 i -> DiscrI32 (fromInteger i) - LitNumber LitNumInt64 i -> DiscrI64 (fromInteger i) - LitNumber LitNumWord w -> DiscrW (fromInteger w) - LitNumber LitNumWord8 w -> DiscrW8 (fromInteger w) - LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w) - LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w) - LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w) - LitNumber LitNumBigNat _ -> unsupported - LitFloat r -> DiscrF (fromRational r) - LitDouble r -> DiscrD (fromRational r) - LitChar i -> DiscrI (ord i) - LitString {} -> unsupported - LitRubbish {} -> unsupported - LitNullAddr {} -> unsupported - LitLabel {} -> unsupported - where - unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l) - - maybe_ncons - | not isAlgCase = Nothing - | otherwise - = case [dc | DataAlt dc <- alt_con <$> alts] of - [] -> Nothing - (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) - - -- the bitmap is relative to stack depth d, i.e. before the - -- BCO, info table and return value are pushed on. - -- This bit of code is v. similar to buildLivenessMask in CgBindery, - -- except that here we build the bitmap from the known bindings of - -- things that are pointers, whereas in CgBindery the code builds the - -- bitmap from the free slots and unboxed bindings. - -- (ToDo: merge?) - -- - -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. - -- The bitmap must cover the portion of the stack up to the sequel only. - -- Previously we were building a bitmap for the whole depth (d), but we - -- really want a bitmap up to depth (d-s). This affects compilation of - -- case-of-case expressions, which is the only time we can be compiling a - -- case expression with s /= 0. - - -- unboxed tuples get two more words, the second is a pointer (tuple_bco) - (extra_pointers, extra_slots) - | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS - | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO - | otherwise = ([], 0) - - bitmap_size :: WordOff - bitmap_size = fromIntegral extra_slots + - bytesToWords platform (d - s) - - bitmap_size' :: Int - bitmap_size' = fromIntegral bitmap_size - - - pointers = - extra_pointers ++ - filter (< bitmap_size') (map (+extra_slots) rel_slots) - where - -- NB: unboxed tuple cases bind the scrut binder to the same offset - -- as one of the alt binders, so we have to remove any duplicates here: - -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'. - rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p - spread id offset | isUnboxedTupleType (idType id) || - isUnboxedSumType (idType id) = Nothing - | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset) - | otherwise = Nothing - where rel_offset = bytesToWords platform (d - offset) - - bitmap = intsToReverseBitmap platform bitmap_size' pointers - - alt_stuff <- mapM codeAlt alts - alt_final0 <- mkMultiBranch maybe_ncons alt_stuff - - let alt_final - | ubx_tuple_frame = SLIDE 0 2 `consOL` alt_final0 - | otherwise = alt_final0 - - let - alt_bco_name = getName bndr - alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts) - 0{-no arity-} bitmap_size bitmap True{-is alts-} - scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b) - (d + ret_frame_size_b + save_ccs_size_b) - p scrut - alt_bco' <- emitBc alt_bco - if ubx_tuple_frame - then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets) - return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco - `consOL` scrut_code) - else let scrut_rep = case non_void_arg_reps of - [] -> V - [rep] -> rep - _ -> panic "schemeE(StgCase).push_alts" - in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code) - - --- ----------------------------------------------------------------------------- --- Deal with tuples - --- The native calling convention uses registers for tuples, but in the --- bytecode interpreter, all values live on the stack. - -layoutNativeCall :: Profile - -> NativeCallType - -> ByteOff - -> (a -> CmmType) - -> [a] - -> ( NativeCallInfo -- See Note [GHCi TupleInfo] - , [(a, ByteOff)] -- argument, offset on stack - ) -layoutNativeCall profile call_type start_off arg_ty reps = - let platform = profilePlatform profile - (orig_stk_bytes, pos) = assignArgumentsPos profile - 0 - NativeReturn - arg_ty - reps - - -- keep the stack parameters in the same place - orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos] - - -- sort the register parameters by register and add them to the stack - regs_order :: Map.Map GlobalReg Int - regs_order = Map.fromList $ zip (allArgRegsCover platform) [0..] - - reg_order :: GlobalReg -> (Int, GlobalReg) - reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg) - -- if we don't have a position for a FloatReg then they must be passed - -- in the equivalent DoubleReg - reg_order (FloatReg n) = reg_order (DoubleReg n) - -- one-tuples can be passed in other registers, but then we don't need - -- to care about the order - reg_order reg = (0, reg) - - (regs, reg_params) - = unzip $ sortBy (comparing fst) - [(reg_order reg, x) | (x, RegisterParam reg) <- pos] - - (new_stk_bytes, new_stk_params) = assignStack platform - orig_stk_bytes - arg_ty - reg_params - - regs_set = mkRegSet (map snd regs) - - get_byte_off (x, StackParam y) = (x, fromIntegral y) - get_byte_off _ = - panic "GHC.StgToByteCode.layoutTuple get_byte_off" - - in ( NativeCallInfo - { nativeCallType = call_type - , nativeCallSize = bytesToWords platform (ByteOff new_stk_bytes) - , nativeCallRegs = regs_set - , nativeCallStackSpillSize = bytesToWords platform - (ByteOff orig_stk_bytes) - } - , sortBy (comparing snd) $ - map (\(x, o) -> (x, o + start_off)) - (orig_stk_params ++ map get_byte_off new_stk_params) - ) - -{- Note [Return convention for non-tuple values] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The RETURN and ENTER instructions are used to return values. RETURN directly -returns the value at the top of the stack while ENTER evaluates it first (so -RETURN is only used when the result is already known to be evaluated), but the -end result is the same: control returns to the enclosing stack frame with the -result at the top of the stack. - -The PUSH_ALTS instruction pushes a two-word stack frame that receives a single -lifted value. Its payload is a BCO that is executed when control returns, with -the stack set up as if a RETURN instruction had just been executed: the returned -value is at the top of the stack, and beneath it is the two-word frame being -returned to. It is the continuation BCO’s job to pop its own frame off the -stack, so the simplest possible continuation consists of two instructions: - - SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value - RETURN P -- return the returned value to our caller - -RETURN and PUSH_ALTS are not really instructions but are in fact representation- -polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a -single real instruction, since it is only used to return lifted values, which -are always pointers. - -The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned -value has nullary or unary representation. Returning/receiving an unboxed -tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to -unboxed tuples by Unarise) containing two or more results uses the special -RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return -convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details. - -Note [unboxed tuple bytecodes and tuple_BCO] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to - return and receive arbitrary unboxed tuples, respectively. These - instructions use the helper data tuple_BCO and call_info. - - The helper data is used to convert tuples between GHCs native calling - convention (object code), which uses stack and registers, and the bytecode - calling convention, which only uses the stack. See Note [GHCi TupleInfo] - for more details. - - - Returning a tuple - ================= - - Bytecode that returns a tuple first pushes all the tuple fields followed - by the appropriate call_info and tuple_BCO onto the stack. It then - executes the RETURN_TUPLE instruction, which causes the interpreter - to push stg_ret_t_info to the top of the stack. The stack (growing down) - then looks as follows: - - ... - next_frame - tuple_field_1 - tuple_field_2 - ... - tuple_field_n - call_info - tuple_BCO - stg_ret_t_info <- Sp - - If next_frame is bytecode, the interpreter will start executing it. If - it's object code, the interpreter jumps back to the scheduler, which in - turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native - calling convention using the description in call_info, and then jumps - to next_frame. - - - Receiving a tuple - ================= - - Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to - push a continuation, followed by jumping to the code that produces the - tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data: - - * cont_BCO: the continuation that receives the tuple - * call_info: see below - * tuple_BCO: see below - - The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE - instruction is executed, followed by stg_ctoi_tN_info, with N depending - on the number of stack words used by the tuple in the GHC native calling - convention. N is derived from call_info. - - For example if we expect a tuple with three words on the stack, the stack - looks as follows after PUSH_ALTS_TUPLE: - - ... - next_frame - cont_free_var_1 - cont_free_var_2 - ... - cont_free_var_n - call_info - tuple_BCO - cont_BCO - stg_ctoi_t3_info <- Sp - - If the tuple is returned by object code, stg_ctoi_t3 will deal with - adjusting the stack pointer and converting the tuple to the bytecode - calling convention. See Note [GHCi unboxed tuples stack spills] for more - details. - - - The tuple_BCO - ============= - - The tuple_BCO is a helper bytecode object. Its main purpose is describing - the contents of the stack frame containing the tuple for the storage - manager. It contains only instructions to immediately return the tuple - that is already on the stack. - - - The call_info word - =================== - - The call_info word describes the stack and STG register (e.g. R1..R6, - D1..D6) usage for the tuple. call_info contains enough information to - convert the tuple between the stack-only bytecode and stack+registers - GHC native calling conventions. - - See Note [GHCi and native call registers] for more details of how the - data is packed in a single word. - - -} - -tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name -tupleBCO platform args_info args = - mkProtoBCO platform invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} - where - {- - The tuple BCO is never referred to by name, so we can get away - with using a fake name here. We will need to change this if we want - to save some memory by sharing the BCO between places that have - the same tuple shape - -} - invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple") - - -- the first word in the frame is the call_info word, - -- which is not a pointer - nptrs_prefix = 1 - (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args - - body_code = mkSlideW 0 1 -- pop frame header - `snocOL` RETURN_TUPLE -- and add it again - -primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name -primCallBCO platform args_info args = - mkProtoBCO platform invented_name body_code (Left []) - 0{-no arity-} bitmap_size bitmap False{-is alts-} - where - {- - The primcall BCO is never referred to by name, so we can get away - with using a fake name here. We will need to change this if we want - to save some memory by sharing the BCO between places that have - the same tuple shape - -} - invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall") - - -- The first two words in the frame (after the BCO) are the call_info word - -- and the pointer to the Cmm function being called. Neither of these is a - -- pointer that should be followed by the garbage collector. - nptrs_prefix = 2 - (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args - - -- if the primcall BCO is ever run it's a bug, since the BCO should only - -- be pushed immediately before running the PRIMCALL bytecode instruction, - -- which immediately leaves the interpreter to jump to the stg_primcall_info - -- Cmm function - body_code = unitOL CASEFAIL - --- | Builds a bitmap for a stack layout with a nonpointer prefix followed by --- some number of arguments. -mkStackBitmap - :: Platform - -> WordOff - -- ^ The number of nonpointer words that prefix the arguments. - -> NativeCallInfo - -> [(PrimRep, ByteOff)] - -- ^ The stack layout of the arguments, where each offset is relative to the - -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned, - -- and the list must be sorted in order of ascending offset (i.e. bottom to top). - -> (WordOff, [StgWord]) -mkStackBitmap platform nptrs_prefix args_info args - = (bitmap_size, bitmap) - where - bitmap_size = nptrs_prefix + arg_bottom - bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets - - arg_bottom = nativeCallSize args_info - ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset) - $ mapMaybe get_ptr_offset args - - get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff - get_ptr_offset (rep, byte_offset) - | isFollowableArg (toArgRep platform rep) = Just byte_offset - | otherwise = Nothing - - convert_arg_offset :: ByteOff -> WordOff - convert_arg_offset arg_offset = - -- The argument offsets are relative to `arg_bottom`, but - -- `intsToReverseBitmap` expects offsets from the top, so we need to flip - -- them around. - nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset) - --- ----------------------------------------------------------------------------- --- Deal with a primitive call to native code. - -generatePrimCall - :: StackDepth - -> Sequel - -> BCEnv - -> CLabelString -- where to call - -> Maybe Unit - -> Type - -> [StgArg] -- args (atoms) - -> BcM BCInstrList -generatePrimCall d s p target _mb_unit _result_ty args - = do - profile <- getProfile - let - platform = profilePlatform profile - - non_void VoidRep = False - non_void _ = True - - nv_args :: [StgArg] - nv_args = filter (non_void . argPrimRep) args - - (args_info, args_offsets) = - layoutNativeCall profile - NativePrimCall - 0 - (primRepCmmType platform . argPrimRep) - nv_args - - prim_args_offsets = mapFst argPrimRep args_offsets - shifted_args_offsets = mapSnd (+ d) args_offsets - - push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 - push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1 - {- - compute size to move payload (without stg_primcall_info header) - - size of arguments plus three words for: - - function pointer to the target - - call_info word - - BCO to describe the stack frame - -} - szb = wordsToBytes platform (nativeCallSize args_info + 3) - 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 - push_args <- go d [] shifted_args_offsets - args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets) - return $ mconcat push_args `appOL` - (push_target `consOL` - push_info `consOL` - PUSH_BCO args_bco `consOL` - (mkSlideB platform szb (d - s) `consOL` unitOL PRIMCALL)) - --- ----------------------------------------------------------------------------- --- Deal with a CCall. - --- Taggedly push the args onto the stack R->L, --- deferencing ForeignObj#s and adjusting addrs to point to --- payloads in Ptr/Byte arrays. Then, generate the marshalling --- (machine) code for the ccall, and create bytecodes to call that and --- then return in the right way. - -generateCCall - :: StackDepth - -> Sequel - -> BCEnv - -> CCallSpec -- where to call - -> Type - -> [StgArg] -- args (atoms) - -> BcM BCInstrList -generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args - | (StaticTarget _ label mb_unit _) <- target - = 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 - = do - profile <- getProfile - - let - args_r_to_l = reverse args - platform = profilePlatform profile - -- useful constants - addr_size_b :: ByteOff - addr_size_b = wordSize platform - - arrayish_rep_hdr_size :: TyCon -> Maybe Int - arrayish_rep_hdr_size t - | t == arrayPrimTyCon || t == mutableArrayPrimTyCon - = Just (arrPtrsHdrSize profile) - | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon - = Just (smallArrPtrsHdrSize profile) - | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon - = Just (arrWordsHdrSize profile) - | otherwise - = Nothing - - -- Get the args on the stack, with tags and suitably - -- dereferenced for the CCall. For each arg, return the - -- depth to the first word of the bits for that arg, and the - -- ArgRep of what was actually pushed. - - pargs - :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)] - pargs _ [] = return [] - pargs d (aa@(StgVarArg a):az) - | Just t <- tyConAppTyCon_maybe (idType a) - , Just hdr_sz <- arrayish_rep_hdr_size t - -- Do magic for Ptr/Byte arrays. Push a ptr to the array on - -- the stack but then advance it over the headers, so as to - -- point to the payload. - = do rest <- pargs (d + addr_size_b) az - (push_fo, _) <- pushAtom d p aa - -- The ptr points at the header. Advance it over the - -- header and then pretend this is an Addr#. - let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) - return ((code, AddrRep) : rest) - pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa - rest <- pargs (d + sz_a) az - return ((code_a, atomPrimRep aa) : rest) - - code_n_reps <- pargs d0 args_r_to_l - let - (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps - a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l) - - push_args = concatOL pushs_arg - !d_after_args = d0 + wordsToBytes platform a_reps_sizeW - a_reps_pushed_RAW - | x:xs <- a_reps_pushed_r_to_l - , isVoidRep x - = reverse xs - | otherwise - = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" - - -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. - -- push_args is the code to do that. - -- d_after_args is the stack depth once the args are on. - - -- Get the result rep. - (returns_void, r_rep) - = case maybe_getCCallReturnRep result_ty of - Nothing -> (True, VoidRep) - Just rr -> (False, rr) - {- - Because the Haskell stack grows down, the a_reps refer to - lowest to highest addresses in that order. The args for the call - are on the stack. Now push an unboxed Addr# indicating - the C function to call. Then push a dummy placeholder for the - result. Finally, emit a CCALL insn with an offset pointing to the - Addr# just pushed, and a literal field holding the mallocville - address of the piece of marshalling code we generate. - So, just prior to the CCALL insn, the stack looks like this - (growing down, as usual): - - - ... - - Addr# address_of_C_fn - (must be an unboxed type) - - The interpreter then calls the marshal code mentioned - in the CCALL insn, passing it (& ), - that is, the addr of the topmost word in the stack. - When this returns, the placeholder will have been - filled in. The placeholder is slid down to the sequel - depth, and we RETURN. - - This arrangement makes it simple to do f-i-dynamic since the Addr# - value is the first arg anyway. - - The marshalling code is generated specifically for this - call site, and so knows exactly the (Haskell) stack - offsets of the args, fn address and placeholder. It - copies the args to the C stack, calls the stacked addr, - and parks the result back in the placeholder. The interpreter - calls it as a normal C call, assuming it has a signature - void marshal_code ( StgWord* ptr_to_top_of_stack ) - -} - -- resolve static address - maybe_static_target :: Maybe Literal - maybe_static_target = - case target of - DynamicTarget -> Nothing - 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 - - let - is_static = isJust maybe_static_target - - -- Get the arg reps, zapping the leading Addr# in the dynamic case - a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" - | is_static = a_reps_pushed_RAW - | _:xs <- a_reps_pushed_RAW = xs - | otherwise = panic "GHC.StgToByteCode.generateCCall: dyn with no args" - - -- push the Addr# - (push_Addr, d_after_Addr) - | Just machlabel <- maybe_static_target - = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b) - | otherwise -- is already on the stack - = (nilOL, d_after_args) - - -- Push the return placeholder. For a call returning nothing, - -- this is a V (tag). - r_sizeW = repSizeWords platform r_rep - d_after_r = d_after_Addr + wordsToBytes platform r_sizeW - push_r = - if returns_void - then nilOL - else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (r_sizeW)) - - -- generate the marshalling code we're going to call - - -- Offset of the next stack frame down the stack. The CCALL - -- instruction needs to describe the chunk of stack containing - -- the ccall args to the GC, so it needs to know how large it - -- 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. - - - let ffires = primRepToFFIType platform r_rep - ffiargs = map (primRepToFFIType platform) a_reps - interp <- hscInterp <$> getHscEnv - token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires) - recordFFIBc token - - let - -- do the call - do_call = unitOL (CCALL stk_offset token flags) - where flags = case safety of - PlaySafe -> 0x0 - PlayInterruptible -> 0x1 - PlayRisky -> 0x2 - - -- slide and return - d_after_r_min_s = bytesToWords platform (d_after_r - s) - wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) - `snocOL` RETURN (toArgRep platform r_rep) - --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ - return ( - push_args `appOL` - push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup - ) - -primRepToFFIType :: Platform -> PrimRep -> FFIType -primRepToFFIType platform r - = case r of - VoidRep -> FFIVoid - IntRep -> signed_word - WordRep -> unsigned_word - Int8Rep -> FFISInt8 - Word8Rep -> FFIUInt8 - Int16Rep -> FFISInt16 - Word16Rep -> FFIUInt16 - Int32Rep -> FFISInt32 - Word32Rep -> FFIUInt32 - Int64Rep -> FFISInt64 - Word64Rep -> FFIUInt64 - AddrRep -> FFIPointer - FloatRep -> FFIFloat - DoubleRep -> FFIDouble - BoxedRep _ -> FFIPointer - _ -> pprPanic "primRepToFFIType" (ppr r) - where - (signed_word, unsigned_word) = case platformWordSize platform of - PW4 -> (FFISInt32, FFIUInt32) - PW8 -> (FFISInt64, FFIUInt64) - --- Make a dummy literal, to be used as a placeholder for FFI return --- values on the stack. -mkDummyLiteral :: Platform -> PrimRep -> Literal -mkDummyLiteral platform pr - = case pr of - IntRep -> mkLitInt platform 0 - WordRep -> mkLitWord platform 0 - Int8Rep -> mkLitInt8 0 - Word8Rep -> mkLitWord8 0 - Int16Rep -> mkLitInt16 0 - Word16Rep -> mkLitWord16 0 - Int32Rep -> mkLitInt32 0 - Word32Rep -> mkLitWord32 0 - Int64Rep -> mkLitInt64 0 - Word64Rep -> mkLitWord64 0 - AddrRep -> LitNullAddr - DoubleRep -> LitDouble 0 - FloatRep -> LitFloat 0 - BoxedRep _ -> LitNullAddr - _ -> pprPanic "mkDummyLiteral" (ppr pr) - - --- Convert (eg) --- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld --- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) --- --- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is V'd. --- --- Alternatively, for call-targets returning nothing, convert --- --- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld --- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) --- --- to Nothing - -maybe_getCCallReturnRep :: Type -> Maybe PrimRep -maybe_getCCallReturnRep fn_ty - = let - (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - r_reps = typePrimRepArgs r_ty - - blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" - (pprType fn_ty) - in - case r_reps of - VoidRep :| [] -> Nothing - rep :| [] -> Just rep - - -- if it was, it would be impossible to create a - -- valid return value placeholder on the stack - _ -> blargh - -maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name]) --- Detect and extract relevant info for the tagToEnum kludge. -maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t) - = Just (v, extract_constr_Names t) - where - extract_constr_Names ty - | rep_ty <- unwrapType ty - , Just tyc <- tyConAppTyCon_maybe rep_ty - , isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See "GHC.Core.DataCon" for details. - | otherwise - = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) -maybe_is_tagToEnum_call _ = Nothing - -{- ----------------------------------------------------------------------------- -Note [Implementing tagToEnum#] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(implement_tagToId arg names) compiles code which takes an argument -'arg', (call it i), and enters the i'th closure in the supplied list -as a consequence. The [Name] is a list of the constructors of this -(enumeration) type. - -The code we generate is this: - push arg - - TESTEQ_I 0 L1 - PUSH_G - JMP L_Exit - - L1: TESTEQ_I 1 L2 - PUSH_G - JMP L_Exit - ...etc... - Ln: TESTEQ_I n L_fail - PUSH_G - JMP L_Exit - - L_fail: CASEFAIL - - L_exit: SLIDE 1 n - ENTER --} - - -implement_tagToId - :: StackDepth - -> Sequel - -> BCEnv - -> 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 (StgVarArg arg) - labels <- getLabelsBc (genericLength names) - label_fail <- getLabelBc - label_exit <- getLabelBc - dflags <- getDynFlags - let infos = zip4 labels (tail labels ++ [label_fail]) - [0 ..] names - platform = targetPlatform dflags - steps = map (mkStep label_exit) infos - slide_ws = bytesToWords platform (d - s + arg_bytes) - - return (push_arg - `appOL` concatOL steps - `appOL` toOL [ LABEL label_fail, CASEFAIL, - LABEL label_exit ] - `appOL` mkSlideW 1 slide_ws - `appOL` unitOL ENTER) - where - mkStep l_exit (my_label, next_label, n, name_for_n) - = toOL [LABEL my_label, - TESTEQ_I n next_label, - PUSH_G name_for_n, - JMP l_exit] - - --- ----------------------------------------------------------------------------- --- pushAtom - --- Push an atom onto the stack, returning suitable code & number of --- stack words used. --- --- The env p must map each variable to the highest- numbered stack --- slot for it. For example, if the stack has depth 4 and we --- tagged-ly push (v :: Int#) on it, the value will be in stack[4], --- the tag in stack[5], the stack will have depth 6, and p must map v --- to 5 and not to 4. Stack locations are numbered from zero, so a --- depth 6 stack has valid words 0 .. 5. - -pushAtom - :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) - --- See Note [Empty case alternatives] in GHC.Core --- and Note [Bottoming expressions] in GHC.Core.Utils: --- The scrutinee of an empty case evaluates to bottom -pushAtom d p (StgVarArg var) - | [] <- typePrimRep (idType var) - = return (nilOL, 0) - - | isFCallId var - = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var) - - | Just primop <- isPrimOpId_maybe var - = do - platform <- targetPlatform <$> getDynFlags - return (unitOL (PUSH_PRIMOP primop), wordSize platform) - - | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable - = do platform <- targetPlatform <$> getDynFlags - - let !szb = idSizeCon platform var - with_instr :: (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff) - with_instr instr = do - let !off_b = d - d_v - return (unitOL (instr off_b), wordSize platform) - - case szb of - 1 -> with_instr PUSH8_W - 2 -> with_instr PUSH16_W - 4 -> with_instr PUSH32_W - _ -> do - let !szw = bytesToWords platform szb - !off_w = bytesToWords platform (d - d_v) + szw - 1 - return (toOL (genericReplicate szw (PUSH_L off_w)), - wordsToBytes platform szw) - -- d - d_v offset from TOS to the first slot of the object - -- - -- d - d_v + sz - 1 offset from the TOS of the last slot of the object - -- - -- Having found the last slot, we proceed to copy the right number of - -- slots on to the top of the stack. - - | otherwise -- var must be a global variable - = do platform <- targetPlatform <$> getDynFlags - let !szb = idSizeCon platform var - massert (szb == wordSize platform) - - -- PUSH_G doesn't tag constructors. So we use PACK here - -- if we are dealing with nullary constructor. - case isDataConWorkId_maybe var of - Just con -> do - massert (isNullaryRepDataCon con) - return (unitOL (PACK con 0), szb) - - Nothing - -- see Note [Generating code for top-level string literal bindings] - | isUnliftedType (idType var) -> do - massert (idType var `eqType` addrPrimTy) - return (unitOL (PUSH_ADDR (getName var)), szb) - - | otherwise -> do - return (unitOL (PUSH_G (getName var)), szb) - - -pushAtom _ _ (StgLitArg lit) = pushLiteral True lit - -pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff) -pushLiteral padded lit = - do - platform <- targetPlatform <$> getDynFlags - let code :: PrimRep -> BcM (BCInstrList, ByteOff) - code rep = - return (padding_instr `snocOL` instr, size_bytes + padding_bytes) - where - size_bytes = ByteOff $ primRepSizeB platform rep - - -- Here we handle the non-word-width cases specifically since we - -- must emit different bytecode for them. - - round_to_words (ByteOff bytes) = - ByteOff (roundUpToWords platform bytes) - - padding_bytes - | padded = round_to_words size_bytes - size_bytes - | otherwise = 0 - - (padding_instr, _) = pushPadding padding_bytes - - instr = - case size_bytes of - 1 -> PUSH_UBX8 lit - 2 -> PUSH_UBX16 lit - 4 -> PUSH_UBX32 lit - _ -> PUSH_UBX lit (bytesToWords platform size_bytes) - - case lit of - LitLabel {} -> code AddrRep - LitFloat {} -> code FloatRep - LitDouble {} -> code DoubleRep - LitChar {} -> code WordRep - LitNullAddr -> code AddrRep - LitString {} -> code AddrRep - LitRubbish _ rep-> case runtimeRepPrimRep (text "pushLiteral") rep of - [pr] -> code pr - _ -> pprPanic "pushLiteral" (ppr lit) - LitNumber nt _ -> case nt of - LitNumInt -> code IntRep - LitNumWord -> code WordRep - LitNumInt8 -> code Int8Rep - LitNumWord8 -> code Word8Rep - LitNumInt16 -> code Int16Rep - LitNumWord16 -> code Word16Rep - LitNumInt32 -> code Int32Rep - LitNumWord32 -> code Word32Rep - LitNumInt64 -> code Int64Rep - LitNumWord64 -> code Word64Rep - -- No LitNumBigNat should be left by the time this is called. CorePrep - -- should have converted them all to a real core representation. - LitNumBigNat -> panic "pushAtom: LitNumBigNat" - --- | Push an atom for constructor (i.e., PACK instruction) onto the stack. --- This is slightly different to @pushAtom@ due to the fact that we allow --- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. -pushConstrAtom - :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) -pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit - -pushConstrAtom d p va@(StgVarArg v) - | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable - platform <- targetPlatform <$> getDynFlags - let !szb = idSizeCon platform v - done instr = do - let !off = d - d_v - return (unitOL (instr off), szb) - case szb of - 1 -> done PUSH8 - 2 -> done PUSH16 - 4 -> done PUSH32 - _ -> pushAtom d p va - -pushConstrAtom d p expr = pushAtom d p expr - -pushPadding :: ByteOff -> (BCInstrList, ByteOff) -pushPadding (ByteOff n) = go n (nilOL, 0) - where - go n acc@(!instrs, !off) = case n of - 0 -> acc - 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1) - 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2) - 3 -> go 1 (go 2 acc) - 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4) - _ -> go (n - 4) (go 4 acc) - --- ----------------------------------------------------------------------------- --- Given a bunch of alts code and their discrs, do the donkey work --- of making a multiway branch using a switch tree. --- What a load of hassle! - -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt - -- a hint; generates better code - -- Nothing is always safe - -> [(Discr, BCInstrList)] - -> BcM BCInstrList -mkMultiBranch maybe_ncons raw_ways = do - lbl_default <- getLabelBc - - let - mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList - mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) - -- shouldn't happen? - - mkTree [val] range_lo range_hi - | range_lo == range_hi - = return (snd val) - | null defaults -- Note [CASEFAIL] - = do lbl <- getLabelBc - return (testEQ (fst val) lbl - `consOL` (snd val - `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) - | otherwise - = return (testEQ (fst val) lbl_default `consOL` snd val) - - -- Note [CASEFAIL] - -- ~~~~~~~~~~~~~~~ - -- It may be that this case has no default - -- branch, but the alternatives are not exhaustive - this - -- happens for GADT cases for example, where the types - -- prove that certain branches are impossible. We could - -- just assume that the other cases won't occur, but if - -- this assumption was wrong (because of a bug in GHC) - -- then the result would be a segfault. So instead we - -- emit an explicit test and a CASEFAIL instruction that - -- causes the interpreter to barf() if it is ever - -- executed. - - mkTree vals range_lo range_hi - = let n = length vals `div` 2 - (vals_lo, vals_hi) = splitAt n vals - v_mid = fst (head vals_hi) - in do - label_geq <- getLabelBc - code_lo <- mkTree vals_lo range_lo (dec v_mid) - code_hi <- mkTree vals_hi v_mid range_hi - return (testLT v_mid label_geq - `consOL` (code_lo - `appOL` unitOL (LABEL label_geq) - `appOL` code_hi)) - - the_default - = case defaults of - [] -> nilOL - [(_, def)] -> LABEL lbl_default `consOL` def - _ -> panic "mkMultiBranch/the_default" - instrs <- mkTree notd_ways init_lo init_hi - return (instrs `appOL` the_default) - where - (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways - notd_ways = sortBy (comparing fst) not_defaults - - testLT (DiscrI i) fail_label = TESTLT_I i fail_label - testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label - testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label - testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label - testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label - testLT (DiscrW i) fail_label = TESTLT_W i fail_label - testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label - testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label - testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label - testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label - testLT (DiscrF i) fail_label = TESTLT_F i fail_label - testLT (DiscrD i) fail_label = TESTLT_D i fail_label - testLT (DiscrP i) fail_label = TESTLT_P i fail_label - testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" - - testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label - testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label - testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label - testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label - testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label - testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label - testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label - testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label - testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label - testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label - testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label - testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label - testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label - testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" - - -- None of these will be needed if there are no non-default alts - (init_lo, init_hi) = case notd_ways of - [] -> panic "mkMultiBranch: awesome foursome" - (discr, _):_ -> case discr of - DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) - DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound ) - DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound ) - DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound ) - DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound ) - DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) - DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound ) - DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound ) - DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound ) - DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound ) - DiscrF _ -> ( DiscrF minF, DiscrF maxF ) - DiscrD _ -> ( DiscrD minD, DiscrD maxD ) - DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) - NoDiscr -> panic "mkMultiBranch NoDiscr" - - (algMinBound, algMaxBound) - = case maybe_ncons of - -- XXX What happens when n == 0? - Just n -> (0, fromIntegral n - 1) - Nothing -> (minBound, maxBound) - - isNoDiscr NoDiscr = True - isNoDiscr _ = False - - dec (DiscrI i) = DiscrI (i-1) - dec (DiscrW w) = DiscrW (w-1) - dec (DiscrP i) = DiscrP (i-1) - dec other = other -- not really right, but if you - -- do cases on floating values, you'll get what you deserve - - -- same snotty comment applies to the following - minF, maxF :: Float - minD, maxD :: Double - minF = -1.0e37 - maxF = 1.0e37 - minD = -1.0e308 - maxD = 1.0e308 - - --- ----------------------------------------------------------------------------- --- Supporting junk for the compilation schemes - --- Describes case alts -data Discr - = DiscrI Int - | DiscrI8 Int8 - | DiscrI16 Int16 - | DiscrI32 Int32 - | DiscrI64 Int64 - | DiscrW Word - | DiscrW8 Word8 - | DiscrW16 Word16 - | DiscrW32 Word32 - | DiscrW64 Word64 - | DiscrF Float - | DiscrD Double - | DiscrP Word16 - | NoDiscr - deriving (Eq, Ord) - -instance Outputable Discr where - ppr (DiscrI i) = int i - ppr (DiscrI8 i) = text (show i) - ppr (DiscrI16 i) = text (show i) - ppr (DiscrI32 i) = text (show i) - ppr (DiscrI64 i) = text (show i) - ppr (DiscrW w) = text (show w) - ppr (DiscrW8 w) = text (show w) - ppr (DiscrW16 w) = text (show w) - ppr (DiscrW32 w) = text (show w) - ppr (DiscrW64 w) = text (show w) - ppr (DiscrF f) = text (show f) - ppr (DiscrD d) = text (show d) - ppr (DiscrP i) = ppr i - ppr NoDiscr = text "DEF" - - -lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff -lookupBCEnv_maybe = Map.lookup - -idSizeW :: Platform -> Id -> WordOff -idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform - -idSizeCon :: Platform -> Id -> ByteOff -idSizeCon platform var - -- unboxed tuple components are padded to word size - | isUnboxedTupleType (idType var) || - isUnboxedSumType (idType var) = - wordsToBytes platform . - WordOff . sum . map (argRepSizeW platform . toArgRep platform) . - NE.toList . bcIdPrimReps $ var - | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var)) - -bcIdArgRep :: Platform -> Id -> ArgRep -bcIdArgRep platform = toArgRep platform . bcIdPrimRep - -bcIdPrimRep :: Id -> PrimRep -bcIdPrimRep id - | rep :| [] <- typePrimRepArgs (idType id) - = rep - | otherwise - = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) - - -bcIdPrimReps :: Id -> NonEmpty PrimRep -bcIdPrimReps id = typePrimRepArgs (idType id) - -repSizeWords :: Platform -> PrimRep -> WordOff -repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep) - -isFollowableArg :: ArgRep -> Bool -isFollowableArg P = True -isFollowableArg _ = False - --- | Indicate if the calling convention is supported -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 - PrimCallConv -> True -- is triggered when a new one is added - JavaScriptCallConv -> False - CApiConv -> True - --- See bug #10462 -unsupportedCConvException :: a -unsupportedCConvException = throwGhcException (ProgramError - ("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 -> BCInstr -mkSlideB platform nb db = SLIDE n d - where - !n = bytesToWords platform nb - !d = bytesToWords platform db - -mkSlideW :: WordOff -> WordOff -> OrdList BCInstr -mkSlideW !n !ws - | ws == 0 - = nilOL - | otherwise - = unitOL (SLIDE n $ fromIntegral ws) - - - -atomPrimRep :: StgArg -> PrimRep -atomPrimRep (StgVarArg v) = bcIdPrimRep v -atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l) - -atomRep :: Platform -> StgArg -> ArgRep -atomRep platform e = toArgRep platform (atomPrimRep e) - --- | Let szsw be the sizes in bytes of some items pushed onto the stack, which --- has initial depth @original_depth@. Return the values which the stack --- environment should map these items to. -mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] -mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) - -typeArgReps :: Platform -> Type -> NonEmpty ArgRep -typeArgReps platform = NE.map (toArgRep platform) . typePrimRepArgs - --- ----------------------------------------------------------------------------- --- The bytecode generator's monad - -data BcM_State - = BcM_State - { bcm_hsc_env :: HscEnv - , thisModule :: Module -- current module (for breakpoints) - , nextlabel :: Word32 -- for generating local labels - , ffis :: [FFIInfo] -- ffi info blocks, to free later - -- Should be free()d when it is GCd - , modBreaks :: Maybe ModBreaks -- info about breakpoints - , breakInfo :: IntMap CgBreakInfo - } - -newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor) - -ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io - return (st, x) - -runBc :: HscEnv -> Module -> Maybe ModBreaks - -> BcM r - -> IO (BcM_State, r) -runBc hsc_env this_mod modBreaks (BcM m) - = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty) - -thenBc :: BcM a -> (a -> BcM b) -> BcM b -thenBc (BcM expr) cont = BcM $ \st0 -> do - (st1, q) <- expr st0 - let BcM k = cont q - (st2, r) <- k st1 - return (st2, r) - -thenBc_ :: BcM a -> BcM b -> BcM b -thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do - (st1, _) <- expr st0 - (st2, r) <- cont st1 - return (st2, r) - -returnBc :: a -> BcM a -returnBc result = BcM $ \st -> (return (st, result)) - -instance Applicative BcM where - pure = returnBc - (<*>) = ap - (*>) = thenBc_ - -instance Monad BcM where - (>>=) = thenBc - (>>) = (*>) - -instance HasDynFlags BcM where - getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st)) - -getHscEnv :: BcM HscEnv -getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) - -getProfile :: BcM Profile -getProfile = targetProfile <$> getDynFlags - -emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) -emitBc bco - = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) - -recordFFIBc :: RemotePtr C_ffi_cif -> BcM () -recordFFIBc a - = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ()) - -getLabelBc :: BcM LocalLabel -getLabelBc - = BcM $ \st -> do let nl = nextlabel st - when (nl == maxBound) $ - panic "getLabelBc: Ran out of labels" - return (st{nextlabel = nl + 1}, LocalLabel nl) - -getLabelsBc :: Word32 -> BcM [LocalLabel] -getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1]) - -getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre)) -getCCArray = BcM $ \st -> - let breaks = expectJust "GHC.StgToByteCode.getCCArray" $ modBreaks st in - return (st, modBreaks_ccs breaks) - - -newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM () -newBreakInfo ix info = BcM $ \st -> - return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ()) - -getCurrentModuleName :: BcM (Maybe (RemotePtr ModuleName)) -getCurrentModuleName = BcM $ \st -> return (st, modBreaks_module <$> modBreaks st) - -tickFS :: FastString -tickFS = fsLit "ticked" +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DerivingVia #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | GHC.StgToByteCode: Generate bytecode from STG +module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Driver.Env + +import GHC.ByteCode.Instr +import GHC.ByteCode.Asm +import GHC.ByteCode.Types + +import GHC.Cmm.CallConv +import GHC.Cmm.Expr +import GHC.Cmm.Reg ( GlobalArgRegs(..) ) +import GHC.Cmm.Node +import GHC.Cmm.Utils + +import GHC.Platform +import GHC.Platform.Profile + +import GHCi.FFI +import GHC.Types.Basic +import GHC.Utils.Outputable +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.ForeignCall +import GHC.Core +import GHC.Types.Literal +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids (primOpId) +import GHC.Core.Type +import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped ) +import GHC.Core.TyCo.Compare (eqType) +import GHC.Types.RepType +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Utils.Misc +import GHC.Utils.Logger +import GHC.Types.Var.Set +import GHC.Builtin.Types.Prim +import GHC.Core.TyCo.Ppr ( pprType ) +import GHC.Utils.Error +import GHC.Builtin.Uniques +import GHC.Data.FastString +import GHC.Utils.Panic +import GHC.Utils.Exception (evaluate) +import GHC.CmmToAsm.Config (platformWordWidth) +import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, + addIdReps, addArgReps, + assertNonVoidIds, assertNonVoidStgArgs ) +import GHC.StgToCmm.Layout +import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes) +import GHC.Runtime.Interpreter ( interpreterProfiled ) +import GHC.Data.Bitmap +import GHC.Data.FlatBag as FlatBag +import GHC.Data.OrdList +import GHC.Data.Maybe +import GHC.Types.Tickish +import GHC.Types.SptEntry +import GHC.ByteCode.Breakpoints + +import Data.List ( genericReplicate, intersperse + , partition, scanl', sortBy, zip4, zip6 ) +import Foreign hiding (shiftL, shiftR) +import Control.Monad +import Data.Char + +import GHC.Unit.Module + +import Data.Coerce (coerce) +#if MIN_VERSION_rts(1,0,3) +import qualified Data.ByteString.Char8 as BS +#endif +import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import qualified GHC.Data.FiniteMap as Map +import Data.Ord +import Data.Either ( partitionEithers ) + +import GHC.Stg.Syntax +import qualified Data.IntSet as IntSet +import GHC.CoreToIface + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT(..)) +import Data.Bifunctor (Bifunctor(..)) + +-- ----------------------------------------------------------------------------- +-- Generating byte code for a complete module + +byteCodeGen :: HscEnv + -> Module + -> [CgStgTopBinding] + -> [TyCon] + -> Maybe ModBreaks + -> [SptEntry] + -> IO CompiledByteCode +byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries + = withTiming logger + (text "GHC.StgToByteCode"<+>brackets (ppr this_mod)) + (const ()) $ do + -- Split top-level binds into strings and others. + -- See Note [Generating code for top-level string literal bindings]. + let (strings, lifted_binds) = partitionEithers $ do -- list monad + bnd <- binds + case bnd of + StgTopLifted bnd -> [Right bnd] + StgTopStringLit b str -> [Left (getName b, str)] + flattenBind (StgNonRec b e) = [(b,e)] + flattenBind (StgRec bs) = bs + + (proto_bcos, BcM_State{..}) <- + runBc hsc_env this_mod mb_modBreaks $ do + let flattened_binds = concatMap flattenBind (reverse lifted_binds) + FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds + + putDumpFileMaybe logger Opt_D_dump_BCOs + "Proto-BCOs" FormatByteCode + (vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos))) + + let mod_breaks = case mb_modBreaks of + Nothing -> Nothing + Just mb -> Just $ mkInternalModBreaks this_mod breakInfo mb + cbc <- assembleBCOs profile proto_bcos tycs strings mod_breaks spt_entries + + -- Squash space leaks in the CompiledByteCode. This is really + -- important, because when loading a set of modules into GHCi + -- we don't touch the CompiledByteCode until the end when we + -- do linking. Forcing out the thunks here reduces space + -- usage by more than 50% when loading a large number of + -- modules. + evaluate (seqCompiledByteCode cbc) + + return cbc + + where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + profile = targetProfile dflags + +{- Note [Generating code for top-level string literal bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Compilation plan for top-level string literals] +in GHC.Core, the core-to-core optimizer can introduce top-level Addr# +bindings to represent string literals. The creates two challenges for +the bytecode compiler: (1) compiling the bindings themselves, and +(2) compiling references to such bindings. Here is a summary on how +we deal with them: + + 1. Top-level string literal bindings are separated from the rest of + the module. Memory is not allocated until bytecode link-time, the + bc_strs field of the CompiledByteCode result records [(Name, ByteString)] + directly. + + 2. When we encounter a reference to a top-level string literal, we + generate a PUSH_ADDR pseudo-instruction, which is assembled to + a PUSH_UBX instruction with a BCONPtrAddr argument. + + 3. The loader accumulates string literal bindings from loaded + bytecode in the addr_env field of the LinkerEnv. + + 4. The BCO linker resolves BCONPtrAddr references by searching both + the addr_env (to find literals defined in bytecode) and the native + symbol table (to find literals defined in native code). + +This strategy works alright, but it does have one significant problem: +we never free the memory that we allocate for the top-level strings. +In theory, we could explicitly free it when BCOs are unloaded, but +this comes with its own complications; see #22400 for why. For now, +we just accept the leak, but it would nice to find something better. -} + +-- ----------------------------------------------------------------------------- +-- Compilation schema for the bytecode generator + +type BCInstrList = OrdList BCInstr + +wordsToBytes :: Platform -> WordOff -> ByteOff +wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral + +-- Used when we know we have a whole number of words +bytesToWords :: Platform -> ByteOff -> WordOff +bytesToWords platform (ByteOff bytes) = + let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform) + in if r == 0 + then fromIntegral q + else pprPanic "GHC.StgToByteCode.bytesToWords" + (text "bytes=" <> ppr bytes) + +wordSize :: Platform -> ByteOff +wordSize platform = ByteOff (platformWordSizeInBytes platform) + +type Sequel = ByteOff -- back off to this depth before ENTER + +type StackDepth = ByteOff + +-- | Maps Ids to their stack depth. This allows us to avoid having to mess with +-- it after each push/pop. +type BCEnv = Map Id StackDepth -- To find vars on the stack + +{- +ppBCEnv :: BCEnv -> SDoc +ppBCEnv p + = text "begin-env" + $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) + $$ text "end-env" + where + pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var) + cmp_snd x y = compare (snd x) (snd y) +-} + +-- Create a BCO and do a spot of peephole optimisation on the insns +-- at the same time. +mkProtoBCO + :: + Platform + -> Maybe Module + -- ^ Just cur_mod <=> label with @BCO_NAME@ instruction + -- see Note [BCO_NAME] + -> Name + -> BCInstrList + -> Either [CgStgAlt] (CgStgRhs) + -- ^ original expression; for debugging only + -> Int -- ^ arity + -> WordOff -- ^ bitmap size + -> [StgWord] -- ^ bitmap + -> Bool -- ^ True <=> it's a case continuation, rather than a function + -- See also Note [Case continuation BCOs]. + -> ProtoBCO Name +mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret + = ProtoBCO { + protoBCOName = nm, + protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = fromIntegral bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin + } + where +#if MIN_VERSION_rts(1,0,3) + maybe_add_bco_name instrs + | Just cur_mod <- _add_bco_name = + let str = BS.pack $ showSDocOneLine defaultSDocContext (pprFullNameWithUnique cur_mod nm) + in BCO_NAME str : instrs +#endif + maybe_add_bco_name instrs = instrs + + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit one in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_add_stack_check instrs + | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = instrs + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). + -- That is, unless the stack usage is >= AP_STACK_SPLIM, + -- see bug #1466. + | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH + = STKCHECK stack_usage : instrs + | otherwise + = instrs -- the supposedly common case + + -- We assume that this sum doesn't wrap + stack_usage = sum (map bciStackUse peep_d) + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) + = PUSH_LLL off1 (off2-1) (off3-2) : peep rest + peep (PUSH_L off1 : PUSH_L off2 : rest) + = PUSH_LL off1 (off2-1) : peep rest + peep (i:rest) + = i : peep rest + peep [] + = [] + +argBits :: Platform -> [ArgRep] -> [Bool] +argBits _ [] = [] +argBits platform (rep : args) + | isFollowableArg rep = False : argBits platform args + | otherwise = replicate (argRepSizeW platform rep) True ++ argBits platform args + +-- ----------------------------------------------------------------------------- +-- schemeTopBind + +-- Compile code for the right-hand side of a top-level binding + +schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name) +schemeTopBind (id, rhs) + | Just data_con <- isDataConWorkId_maybe id, + isNullaryRepDataCon data_con = do + platform <- profilePlatform <$> getProfile + add_bco_name <- shouldAddBcoName + -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. + -- liftIO (putStrLn $ "top level BCO") + pure (mkProtoBCO platform add_bco_name + (getName id) (toOL [PACK data_con 0, RETURN P]) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + + | otherwise + = schemeR [{- No free variables -}] (getName id, rhs) + + +-- ----------------------------------------------------------------------------- +-- schemeR + +-- Compile code for a right-hand side, to give a BCO that, +-- when executed with the free variables and arguments on top of the stack, +-- will return with a pointer to the result on top of the stack, after +-- removing the free variables and arguments. +-- +-- Park the resulting BCO in the monad. Also requires the +-- name of the variable to which this value was bound, +-- so as to give the resulting BCO a name. +-- +-- The resulting ProtoBCO expects the free variables and the function arguments +-- to be in the stack frame directly before it. +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Name, CgStgRhs) + -> BcM (ProtoBCO Name) +schemeR fvs (nm, rhs) + = schemeR_wrk fvs nm rhs (collect rhs) + +-- If an expression is a lambda, return the +-- list of arguments to the lambda (in R-to-L order) and the +-- underlying expression + +collect :: CgStgRhs -> ([Var], CgStgExpr) +collect (StgRhsClosure _ _ _ args body _) = (args, body) +collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args []) + +schemeR_wrk + :: [Id] + -> Name + -> CgStgRhs -- expression e, for debugging only + -> ([Var], CgStgExpr) -- result of collect on e + -> BcM (ProtoBCO Name) +schemeR_wrk fvs nm original_body (args, body) + = do + add_bco_name <- shouldAddBcoName + profile <- getProfile + let + platform = profilePlatform profile + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first + + -- Stack arguments always take a whole number of words, we never pack + -- them unlike constructor fields. + szsb_args = map (wordsToBytes platform . idSizeW platform) all_args + sum_szsb_args = sum szsb_args + -- Make a stack offset for each argument or free var -- they should + -- appear contiguous in the stack, in order. + p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args)) + + -- make the arg bitmap + bits = argBits platform (reverse (map (idArgRep platform) all_args)) + bitmap_size = strictGenericLength bits + bitmap = mkBitmap platform bits + body_code <- schemeER_wrk sum_szsb_args p_init body + + pure (mkProtoBCO platform add_bco_name nm body_code (Right original_body) + arity bitmap_size bitmap False{-not alts-}) + +-- | Introduce break instructions for ticked expressions. +-- If no breakpoint information is available, the instruction is omitted. +schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList +schemeER_wrk d p (StgTick bp@(Breakpoint tick_ty tick_id fvs) rhs) = do + platform <- profilePlatform <$> getProfile + + -- When we find a tick we update the "last breakpoint location". + -- We use it when constructing step-out BRK_FUNs in doCase + -- See Note [Debugger: Stepout internal break locs] + code <- withBreakTick bp $ schemeE d 0 p rhs + + -- As per Note [Stack layout when entering run_BCO], the breakpoint AP_STACK + -- as we yield from the interpreter is headed by a stg_apply_interp + BCO to be a valid stack. + -- Therefore, the var offsets are offset by 2 words + let idOffSets = map (fmap (second (+2))) $ + getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty + (Right tick_id) + + mibi <- newBreakInfo breakInfo + + return $ case mibi of + Nothing -> code + Just ibi -> BRK_FUN ibi `consOL` code + +schemeER_wrk d p rhs = schemeE d 0 p rhs + +-- | Get the offset in words into this breakpoint's AP_STACK which contains the matching Id +getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, WordOff)] +getVarOffSets platform depth env = map getOffSet + where + getOffSet id = case lookupBCEnv_maybe id env of + Nothing -> Nothing + Just offset -> + let !var_depth_ws = bytesToWords platform (depth - offset) + in Just (id, var_depth_ws) + +fvsToEnv :: BCEnv -> CgStgRhs -> [Id] +-- Takes the free variables of a right-hand side, and +-- delivers an ordered list of the local variables that will +-- be captured in the thunk for the RHS +-- The BCEnv argument tells which variables are in the local +-- environment: these are the ones that should be captured +-- +-- The code that constructs the thunk, and the code that executes +-- it, have to agree about this layout + +fvsToEnv p rhs = [v | v <- dVarSetElems $ freeVarsOfRhs rhs, + v `Map.member` p] + +-- ----------------------------------------------------------------------------- +-- schemeE + +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnliftedAtom + :: StackDepth + -> Sequel + -> BCEnv + -> StgArg + -> BcM BCInstrList +returnUnliftedAtom d s p e = do + let reps = stgArgRep e + (push, szb) <- pushAtom d p e + ret <- returnUnliftedReps d s szb reps + return (push `appOL` ret) + +-- return an unlifted value from the top of the stack +returnUnliftedReps + :: StackDepth + -> Sequel + -> ByteOff -- size of the thing we're returning + -> [PrimRep] -- representations + -> BcM BCInstrList +returnUnliftedReps d s szb reps = do + profile <- getProfile + let platform = profilePlatform profile + ret <- case reps of + -- use RETURN for nullary/unary representations + [] -> return (unitOL $ RETURN V) + [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 id nv_reps + tuple_bco = tupleBCO platform call_info args_offsets + return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` + PUSH_BCO tuple_bco `consOL` + unitOL RETURN_TUPLE + return ( mkSlideB platform szb (d - s) -- clear to sequel + `appOL` ret) -- go + +-- construct and return an unboxed tuple +returnUnboxedTuple + :: StackDepth + -> Sequel + -> BCEnv + -> [StgArg] + -> BcM BCInstrList +returnUnboxedTuple d s p es = do + profile <- getProfile + let platform = profilePlatform profile + (call_info, tuple_components) = layoutNativeCall profile + NativeTupleReturn + d + 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 + + ret <- returnUnliftedReps d + s + (wordsToBytes platform $ nativeCallSize call_info) + (map stgArgRepU es) + return (mconcat pushes `appOL` ret) + +-- Compile code to apply the given expression to the remaining args +-- on the stack, returning a HNF. +schemeE :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList +schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) +schemeE d s p (StgApp x []) + | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x) +-- Delegate tail-calls to schemeT. +schemeE d s p e@(StgApp {}) = schemeT d s p e +schemeE d s p e@(StgConApp {}) = schemeT d s p e +schemeE d s p e@(StgOpApp {}) = schemeT d s p e +schemeE d s p (StgLetNoEscape xlet bnd body) + = schemeE d s p (StgLet xlet bnd body) +schemeE d s p (StgLet _xlet + (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args _typ)) + body) + = do -- Special case for a non-recursive let whose RHS is a + -- saturated constructor application. + -- Just allocate the constructor and carry on + alloc_code <- mkConAppCode d s p data_con args + platform <- targetPlatform <$> getDynFlags + let !d2 = d + wordSize platform + body_code <- schemeE d2 s (Map.insert x d2 p) body + return (alloc_code `appOL` body_code) +-- General case for let. Generates correct, if inefficient, code in +-- all situations. +schemeE d s p (StgLet _ext binds body) = do + 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 + + fvss = map (fvsToEnv p') rhss + + -- Sizes of free vars + size_w = idSizeW platform + sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss + + -- the arity of each rhs + arities = map (strictGenericLength . fst . collect) rhss + + -- This p', d' defn is safe because all the items being pushed + -- are ptrs, so all have size 1 word. d' and p' reflect the stack + -- after the closures have been allocated in the heap (but not + -- filled in), and pointers to them parked on the stack. + offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform)) + p' = Map.insertList (zipEqual xs offsets) p + d' = d + wordsToBytes platform n_binds + + -- ToDo: don't build thunks for things with no free variables + build_thunk + :: StackDepth + -> [Id] + -> WordOff + -> ProtoBCO Name + -> WordOff + -> HalfWord + -> BcM BCInstrList + build_thunk _ [] size bco off arity + = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) (fromIntegral size))) + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP + build_thunk dd (fv:fvs) size bco off arity = do + (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv) + more_push_code <- + build_thunk (dd + pushed_szb) fvs size bco off arity + return (push_code `appOL` more_push_code) + + alloc_code = toOL (zipWith mkAlloc sizes arities) + where mkAlloc sz 0 + | is_tick = ALLOC_AP_NOUPD (fromIntegral sz) + | otherwise = ALLOC_AP (fromIntegral sz) + mkAlloc sz arity = ALLOC_PAP arity (fromIntegral sz) + + is_tick = case binds of + StgNonRec id _ -> occNameFS (getOccName id) == tickFS + _other -> False + + compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do + bco <- schemeR fvs (getName x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + ] + body_code <- schemeE d' s p' body + thunk_codes <- sequence compile_binds + return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code) + +schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs) + = pprPanic "schemeE: Breakpoint without let binding:" + (ppr bp_id <+> text "forgot to run bcPrep?") + +-- ignore other kinds of tick +schemeE d s p (StgTick _ rhs) = schemeE d s p rhs + +-- no alts: scrut is guaranteed to diverge +schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut + +schemeE d s p (StgCase scrut bndr _ alts) + = doCase d s p scrut bndr alts + + +{- + Ticked Expressions + ------------------ + + The idea is that the "breakpoint E" is really just an annotation on + the code. When we find such a thing, we pull out the useful information, + and then compile the code as if it was just the expression E. +-} + +-- Compile code to do a tail call. Specifically, push the fn, +-- slide the on-stack app back down to the sequel depth, +-- and enter. Four cases: +-- +-- 0. (Nasty hack). +-- An application "GHC.Prim.tagToEnum# unboxed-int". +-- The int will be on the stack. Generate a code sequence +-- to convert it to the relevant constructor, SLIDE and ENTER. +-- +-- 1. The fn denotes a ccall. Defer to generateCCall. +-- +-- 2. An unboxed tuple: push the components on the top of +-- the stack and return. +-- +-- 3. Application of a constructor, by defn saturated. +-- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- then the ptrs, and then do PACK and RETURN. +-- +-- 4. Otherwise, it must be a function call. Push the args +-- right to left, SLIDE and ENTER. + +schemeT :: StackDepth -- Stack depth + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> CgStgExpr + -> BcM BCInstrList + + -- Case 0 +schemeT d s p app + | Just (arg, constr_names) <- maybe_is_tagToEnum_call app + = implement_tagToId d s p arg constr_names + + -- Case 1 +schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty) + = if isSupportedCConv ccall_spec + then generateCCall d s p ccall_spec result_ty args + else unsupportedCConvException + +schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do + profile <- getProfile + let platform = profilePlatform profile + case doPrimOp platform op d s p args of + -- Can we do this right in the interpreter? + Just prim_code -> prim_code + -- Otherwise we have to do a call to the primop wrapper instead :( + _ -> doTailCall d s p (primOpId op) (reverse args) + +schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty) + = generatePrimCall d s p label (Just unit) result_ty args + +schemeT d s p (StgConApp con _cn args _tys) + -- Case 2: Unboxed tuple + | isUnboxedTupleDataCon con || isUnboxedSumDataCon con + = returnUnboxedTuple d s p args + + -- Case 3: Ordinary data constructor + | otherwise + = do alloc_con <- mkConAppCode d s p con args + platform <- profilePlatform <$> getProfile + return (alloc_con `appOL` + mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN P) + + -- Case 4: Tail call of function +schemeT d s p (StgApp fn args) + = doTailCall d s p fn (reverse args) + +schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT" + (pprStgExpr shortStgPprOpts e) + +-- ----------------------------------------------------------------------------- +-- Generate code to build a constructor application, +-- leaving it on top of the stack + +mkConAppCode + :: StackDepth + -> Sequel + -> BCEnv + -> DataCon -- The data constructor + -> [StgArg] -- Args, in *reverse* order + -> BcM BCInstrList +mkConAppCode orig_d _ p con args = app_code + where + app_code = do + profile <- getProfile + let platform = profilePlatform profile + + non_voids = + addArgReps (assertNonVoidStgArgs args) + (_, _, args_offsets) = + mkVirtHeapOffsetsWithPadding profile StdHeader non_voids + + do_pushery !d (arg : args) = do + (push, arg_bytes) <- case arg of + (Padding l _) -> return $! pushPadding (ByteOff l) + (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !d [] = do + let !n_arg_words = bytesToWords platform (d - orig_d) + return (unitOL (PACK con n_arg_words)) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args_offsets) + +-- ----------------------------------------------------------------------------- +-- Generate code for a tail-call + +doTailCall + :: StackDepth + -> Sequel + -> BCEnv + -> Id + -> [StgArg] + -> BcM BCInstrList +doTailCall init_d s p fn args = do + platform <- profilePlatform <$> getProfile + + -- Do tail call only after + do_pushes init_d args (map (atomRep platform) args) + + where + do_pushes !d [] reps = do + assert (null reps) return () + (push_fn, sz) <- pushAtom d p (StgVarArg fn) + 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)) + do_pushes !d args reps = do + let (push_apply, n, rest_of_reps) = findPushSeq reps + (these_args, rest_of_args) = splitAt n args + (next_d, push_code) <- push_seq d these_args + platform <- profilePlatform <$> getProfile + instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction + return (push_code `appOL` (push_apply `consOL` instrs)) + + push_seq d [] = return (d, nilOL) + push_seq d (arg:args) = do + (push_code, sz) <- pushAtom d p arg + (final_d, more_push_code) <- push_seq (d + sz) args + return (final_d, push_code `appOL` more_push_code) + +doPrimOp :: Platform + -> PrimOp + -> StackDepth + -> Sequel + -> BCEnv + -> [StgArg] + -> Maybe (BcM BCInstrList) +doPrimOp platform op init_d s p args = + case op of + IntAddOp -> sizedPrimOp OP_ADD + Int64AddOp -> only64bit $ sizedPrimOp OP_ADD + Int32AddOp -> sizedPrimOp OP_ADD + Int16AddOp -> sizedPrimOp OP_ADD + Int8AddOp -> sizedPrimOp OP_ADD + WordAddOp -> sizedPrimOp OP_ADD + Word64AddOp -> only64bit $ sizedPrimOp OP_ADD + Word32AddOp -> sizedPrimOp OP_ADD + Word16AddOp -> sizedPrimOp OP_ADD + Word8AddOp -> sizedPrimOp OP_ADD + AddrAddOp -> sizedPrimOp OP_ADD + + IntMulOp -> sizedPrimOp OP_MUL + Int64MulOp -> only64bit $ sizedPrimOp OP_MUL + Int32MulOp -> sizedPrimOp OP_MUL + Int16MulOp -> sizedPrimOp OP_MUL + Int8MulOp -> sizedPrimOp OP_MUL + WordMulOp -> sizedPrimOp OP_MUL + Word64MulOp -> only64bit $ sizedPrimOp OP_MUL + Word32MulOp -> sizedPrimOp OP_MUL + Word16MulOp -> sizedPrimOp OP_MUL + Word8MulOp -> sizedPrimOp OP_MUL + + IntSubOp -> sizedPrimOp OP_SUB + WordSubOp -> sizedPrimOp OP_SUB + Int64SubOp -> only64bit $ sizedPrimOp OP_SUB + Int32SubOp -> sizedPrimOp OP_SUB + Int16SubOp -> sizedPrimOp OP_SUB + Int8SubOp -> sizedPrimOp OP_SUB + Word64SubOp -> only64bit $ sizedPrimOp OP_SUB + Word32SubOp -> sizedPrimOp OP_SUB + Word16SubOp -> sizedPrimOp OP_SUB + Word8SubOp -> sizedPrimOp OP_SUB + AddrSubOp -> sizedPrimOp OP_SUB + + IntAndOp -> sizedPrimOp OP_AND + WordAndOp -> sizedPrimOp OP_AND + Word64AndOp -> only64bit $ sizedPrimOp OP_AND + Word32AndOp -> sizedPrimOp OP_AND + Word16AndOp -> sizedPrimOp OP_AND + Word8AndOp -> sizedPrimOp OP_AND + + IntNotOp -> sizedPrimOp OP_NOT + WordNotOp -> sizedPrimOp OP_NOT + Word64NotOp -> only64bit $ sizedPrimOp OP_NOT + Word32NotOp -> sizedPrimOp OP_NOT + Word16NotOp -> sizedPrimOp OP_NOT + Word8NotOp -> sizedPrimOp OP_NOT + + IntXorOp -> sizedPrimOp OP_XOR + WordXorOp -> sizedPrimOp OP_XOR + Word64XorOp -> only64bit $ sizedPrimOp OP_XOR + Word32XorOp -> sizedPrimOp OP_XOR + Word16XorOp -> sizedPrimOp OP_XOR + Word8XorOp -> sizedPrimOp OP_XOR + + IntOrOp -> sizedPrimOp OP_OR + WordOrOp -> sizedPrimOp OP_OR + Word64OrOp -> only64bit $ sizedPrimOp OP_OR + Word32OrOp -> sizedPrimOp OP_OR + Word16OrOp -> sizedPrimOp OP_OR + Word8OrOp -> sizedPrimOp OP_OR + + WordSllOp -> sizedPrimOp OP_SHL + Word64SllOp -> only64bit $ sizedPrimOp OP_SHL -- check 32bit platform + Word32SllOp -> sizedPrimOp OP_SHL + Word16SllOp -> sizedPrimOp OP_SHL + Word8SllOp -> sizedPrimOp OP_SHL + IntSllOp -> sizedPrimOp OP_SHL + Int64SllOp -> only64bit $ sizedPrimOp OP_SHL + Int32SllOp -> sizedPrimOp OP_SHL + Int16SllOp -> sizedPrimOp OP_SHL + Int8SllOp -> sizedPrimOp OP_SHL + + WordSrlOp -> sizedPrimOp OP_LSR + Word64SrlOp -> only64bit $ sizedPrimOp OP_LSR + Word32SrlOp -> sizedPrimOp OP_LSR + Word16SrlOp -> sizedPrimOp OP_LSR + Word8SrlOp -> sizedPrimOp OP_LSR + IntSrlOp -> sizedPrimOp OP_LSR + Int64SrlOp -> only64bit $ sizedPrimOp OP_LSR -- check 32bit platform + Int32SrlOp -> sizedPrimOp OP_LSR + Int16SrlOp -> sizedPrimOp OP_LSR + Int8SrlOp -> sizedPrimOp OP_LSR + + IntSraOp -> sizedPrimOp OP_ASR + Int64SraOp -> only64bit $ sizedPrimOp OP_ASR -- check 32bit platform + Int32SraOp -> sizedPrimOp OP_ASR + Int16SraOp -> sizedPrimOp OP_ASR + Int8SraOp -> sizedPrimOp OP_ASR + + + IntNeOp -> sizedPrimOp OP_NEQ + Int64NeOp -> only64bit $ sizedPrimOp OP_NEQ + Int32NeOp -> sizedPrimOp OP_NEQ + Int16NeOp -> sizedPrimOp OP_NEQ + Int8NeOp -> sizedPrimOp OP_NEQ + WordNeOp -> sizedPrimOp OP_NEQ + Word64NeOp -> only64bit $ sizedPrimOp OP_NEQ + Word32NeOp -> sizedPrimOp OP_NEQ + Word16NeOp -> sizedPrimOp OP_NEQ + Word8NeOp -> sizedPrimOp OP_NEQ + AddrNeOp -> sizedPrimOp OP_NEQ + + IntEqOp -> sizedPrimOp OP_EQ + Int64EqOp -> only64bit $ sizedPrimOp OP_EQ + Int32EqOp -> sizedPrimOp OP_EQ + Int16EqOp -> sizedPrimOp OP_EQ + Int8EqOp -> sizedPrimOp OP_EQ + WordEqOp -> sizedPrimOp OP_EQ + Word64EqOp -> only64bit $ sizedPrimOp OP_EQ + Word32EqOp -> sizedPrimOp OP_EQ + Word16EqOp -> sizedPrimOp OP_EQ + Word8EqOp -> sizedPrimOp OP_EQ + AddrEqOp -> sizedPrimOp OP_EQ + CharEqOp -> sizedPrimOp OP_EQ + + IntLtOp -> sizedPrimOp OP_S_LT + Int64LtOp -> only64bit $ sizedPrimOp OP_S_LT + Int32LtOp -> sizedPrimOp OP_S_LT + Int16LtOp -> sizedPrimOp OP_S_LT + Int8LtOp -> sizedPrimOp OP_S_LT + WordLtOp -> sizedPrimOp OP_U_LT + Word64LtOp -> only64bit $ sizedPrimOp OP_U_LT + Word32LtOp -> sizedPrimOp OP_U_LT + Word16LtOp -> sizedPrimOp OP_U_LT + Word8LtOp -> sizedPrimOp OP_U_LT + AddrLtOp -> sizedPrimOp OP_U_LT + CharLtOp -> sizedPrimOp OP_U_LT + + IntGeOp -> sizedPrimOp OP_S_GE + Int64GeOp -> only64bit $ sizedPrimOp OP_S_GE + Int32GeOp -> sizedPrimOp OP_S_GE + Int16GeOp -> sizedPrimOp OP_S_GE + Int8GeOp -> sizedPrimOp OP_S_GE + WordGeOp -> sizedPrimOp OP_U_GE + Word64GeOp -> only64bit $ sizedPrimOp OP_U_GE + Word32GeOp -> sizedPrimOp OP_U_GE + Word16GeOp -> sizedPrimOp OP_U_GE + Word8GeOp -> sizedPrimOp OP_U_GE + AddrGeOp -> sizedPrimOp OP_U_GE + CharGeOp -> sizedPrimOp OP_U_GE + + IntGtOp -> sizedPrimOp OP_S_GT + Int64GtOp -> only64bit $ sizedPrimOp OP_S_GT + Int32GtOp -> sizedPrimOp OP_S_GT + Int16GtOp -> sizedPrimOp OP_S_GT + Int8GtOp -> sizedPrimOp OP_S_GT + WordGtOp -> sizedPrimOp OP_U_GT + Word64GtOp -> only64bit $ sizedPrimOp OP_U_GT + Word32GtOp -> sizedPrimOp OP_U_GT + Word16GtOp -> sizedPrimOp OP_U_GT + Word8GtOp -> sizedPrimOp OP_U_GT + AddrGtOp -> sizedPrimOp OP_U_GT + CharGtOp -> sizedPrimOp OP_U_GT + + IntLeOp -> sizedPrimOp OP_S_LE + Int64LeOp -> only64bit $ sizedPrimOp OP_S_LE + Int32LeOp -> sizedPrimOp OP_S_LE + Int16LeOp -> sizedPrimOp OP_S_LE + Int8LeOp -> sizedPrimOp OP_S_LE + WordLeOp -> sizedPrimOp OP_U_LE + Word64LeOp -> only64bit $ sizedPrimOp OP_U_LE + Word32LeOp -> sizedPrimOp OP_U_LE + Word16LeOp -> sizedPrimOp OP_U_LE + Word8LeOp -> sizedPrimOp OP_U_LE + AddrLeOp -> sizedPrimOp OP_U_LE + CharLeOp -> sizedPrimOp OP_U_LE + + IntNegOp -> sizedPrimOp OP_NEG + Int64NegOp -> only64bit $ sizedPrimOp OP_NEG + Int32NegOp -> sizedPrimOp OP_NEG + Int16NegOp -> sizedPrimOp OP_NEG + Int8NegOp -> sizedPrimOp OP_NEG + + IntToWordOp -> mk_conv (platformWordWidth platform) + WordToIntOp -> mk_conv (platformWordWidth platform) + Int8ToWord8Op -> mk_conv W8 + Word8ToInt8Op -> mk_conv W8 + Int16ToWord16Op -> mk_conv W16 + Word16ToInt16Op -> mk_conv W16 + Int32ToWord32Op -> mk_conv W32 + Word32ToInt32Op -> mk_conv W32 + Int64ToWord64Op -> only64bit $ mk_conv W64 + Word64ToInt64Op -> only64bit $ mk_conv W64 + IntToAddrOp -> mk_conv (platformWordWidth platform) + AddrToIntOp -> mk_conv (platformWordWidth platform) + ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same + OrdOp -> mk_conv (platformWordWidth platform) + + -- Memory primops, expand the ghci-mem-primops test if you add more. + IndexOffAddrOp_Word8 -> primOpWithRep (OP_INDEX_ADDR W8) W8 + IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16 + IndexOffAddrOp_Word32 -> primOpWithRep (OP_INDEX_ADDR W32) W32 + IndexOffAddrOp_Word64 -> only64bit $ primOpWithRep (OP_INDEX_ADDR W64) W64 + + _ -> Nothing + where + only64bit = if platformWordWidth platform == W64 then id else const Nothing + primArg1Width :: StgArg -> Width + primArg1Width arg + | rep <- (stgArgRepU arg) + = case rep of + AddrRep -> platformWordWidth platform + IntRep -> platformWordWidth platform + WordRep -> platformWordWidth platform + + Int64Rep -> W64 + Word64Rep -> W64 + + Int32Rep -> W32 + Word32Rep -> W32 + + Int16Rep -> W16 + Word16Rep -> W16 + + Int8Rep -> W8 + Word8Rep -> W8 + + FloatRep -> unexpectedRep + DoubleRep -> unexpectedRep + + BoxedRep{} -> unexpectedRep + VecRep{} -> unexpectedRep + where + unexpectedRep = panic "doPrimOp: Unexpected argument rep" + + + -- TODO: The slides for the result need to be two words on 32bit for 64bit ops. + mkNReturn width + | W64 <- width = RETURN L -- L works for 64 bit on any platform + | otherwise = RETURN N -- <64bit width, fits in word on all platforms + + mkSlideWords width = if platformWordWidth platform < width then 2 else 1 + + -- Push args, execute primop, slide, return_N + -- Decides width of operation based on first argument. + sizedPrimOp op_inst = Just $ do + let width = primArg1Width (head args) + prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width + return $ prim_code `appOL` slide + + -- primOpWithRep op w => operation @op@ resulting in result @w@ wide. + primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr)) + primOpWithRep op_inst result_width = Just $ do + prim_code <- mkPrimOpCode init_d s p op_inst $ args + let slide = mkSlideW (mkSlideWords result_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn result_width + return $ prim_code `appOL` slide + + -- Coerce the argument, requires them to be the same size + mk_conv :: Width -> Maybe (BcM (OrdList BCInstr)) + mk_conv target_width = Just $ do + let width = primArg1Width (head args) + massert (width == target_width) + (push_code, _bytes) <- pushAtom init_d p (head args) + let slide = mkSlideW (mkSlideWords target_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width + return $ push_code `appOL` slide + +-- Push the arguments on the stack and emit the given instruction +-- Pushes at least one word per non void arg. +mkPrimOpCode + :: StackDepth + -> Sequel + -> BCEnv + -> BCInstr -- The operator + -> [StgArg] -- Args, in *reverse* order (must be fully applied) + -> BcM BCInstrList +mkPrimOpCode orig_d _ p op_inst args = app_code + where + app_code = do + profile <- getProfile + let _platform = profilePlatform profile + + do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList + do_pushery !d (arg : args) = do + (push,arg_bytes) <- pushAtom d p arg + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !_d [] = do + return (unitOL op_inst) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args) + +-- v. similar to CgStackery.findMatch, ToDo: merge +findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) +findPushSeq (P: P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPPP, 6, rest) +findPushSeq (P: P: P: P: P: rest) + = (PUSH_APPLY_PPPPP, 5, rest) +findPushSeq (P: P: P: P: rest) + = (PUSH_APPLY_PPPP, 4, rest) +findPushSeq (P: P: P: rest) + = (PUSH_APPLY_PPP, 3, rest) +findPushSeq (P: P: rest) + = (PUSH_APPLY_PP, 2, rest) +findPushSeq (P: rest) + = (PUSH_APPLY_P, 1, rest) +findPushSeq (V: rest) + = (PUSH_APPLY_V, 1, rest) +findPushSeq (N: rest) + = (PUSH_APPLY_N, 1, rest) +findPushSeq (F: rest) + = (PUSH_APPLY_F, 1, rest) +findPushSeq (D: rest) + = (PUSH_APPLY_D, 1, rest) +findPushSeq (L: rest) + = (PUSH_APPLY_L, 1, rest) +findPushSeq argReps + | any (`elem` [V16, V32, V64]) argReps + = sorry "SIMD vector operations are not available in GHCi" +findPushSeq _ + = panic "GHC.StgToByteCode.findPushSeq" + +-- ----------------------------------------------------------------------------- +-- Case expressions + +-- | Generate ByteCode for a case expression. +-- +-- Note that case BCOs may be "nested" within other parent BCOs and refer to +-- its parent's variables (as in the 'BCEnv' contains variables from parent +-- frames). For more details about the interaction between case BCOs and their +-- parent frames see Note [Case continuation BCOs]. +doCase + :: StackDepth + -> Sequel + -> BCEnv + -> CgStgExpr + -> Id + -> [CgStgAlt] + -> BcM BCInstrList +doCase d s p scrut bndr alts + = do + profile <- getProfile + hsc_env <- getHscEnv + let + platform = profilePlatform profile + + -- Are we dealing with an unboxed tuple with a tuple return frame? + -- + -- 'Simple' tuples with at most one non-void component, + -- like (# Word# #) or (# Int#, State# RealWorld #) do not have a + -- tuple return frame. This is because (# foo #) and (# foo, Void# #) + -- have the same runtime rep. We have more efficient specialized + -- return frames for the situations with one non-void element. + + non_void_arg_reps = typeArgReps platform bndr_ty + ubx_tuple_frame = + (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && + length non_void_arg_reps > 1 + + profiling + | Just interp <- hsc_interp hsc_env + = interpreterProfiled interp + | otherwise = False + + -- Top of stack is the return itbl, as usual. + -- underneath it is the pointer to the alt_code BCO. + -- When an alt is entered, it assumes the returned value is + -- on top of the itbl; see Note [Return convention for non-tuple values] + -- for details. + ctoi_frame_header_w :: WordOff + ctoi_frame_header_w + | ubx_tuple_frame = + if profiling then 5 else 4 + | otherwise = 2 + + -- The size of the ret_*_info frame header, whose frame returns the + -- value to the case continuation frame (ctoi_*_info) + ret_info_header_w :: WordOff + | ubx_tuple_frame = 3 + | otherwise = 1 + + -- The stack space used to save/restore the CCCS when profiling + save_ccs_size_b | profiling && + not ubx_tuple_frame = 2 * wordSize platform + | otherwise = 0 + + (bndr_size, call_info, args_offsets) + | ubx_tuple_frame = + let bndr_reps = typePrimRep (idType bndr) + (call_info, args_offsets) = + layoutNativeCall profile NativeTupleReturn 0 id bndr_reps + in ( nativeCallSize call_info + , call_info + , args_offsets + ) + | otherwise = ( idSizeW platform bndr + , voidTupleReturnInfo + , [] + ) + + -- Depth of stack after the return value has been pushed + -- This is the stack depth at the continuation. + d_bndr = + d + wordsToBytes platform bndr_size + + -- Env in which to compile the alts, not including + -- any vars bound by the alts themselves + p_alts = Map.insert bndr d_bndr p + + bndr_ty = idType bndr + isAlgCase = isAlgType bndr_ty + + -- given an alt, return a discr and code for it. + codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList) + codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs} + = do rhs_code <- schemeE d_bndr s p_alts rhs + return (NoDiscr, rhs_code) + + codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_bndr s p_alts rhs + return (my_discr alt, rhs_code) + | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty = + let bndr_ty = idPrimRepU . fromNonVoid + tuple_start = d_bndr + (call_info, args_offsets) = + layoutNativeCall profile + NativeTupleReturn + 0 + bndr_ty + (assertNonVoidIds bndrs) + + stack_bot = d_bndr + + p' = Map.insertList + [ (arg, tuple_start - + wordsToBytes platform (nativeCallSize call_info) + + offset) + | (NonVoid arg, offset) <- args_offsets] + p_alts + in do + rhs_code <- schemeE stack_bot s p' rhs + return (NoDiscr, rhs_code) + -- algebraic alt with some binders + | otherwise = + let (tot_wds, _ptrs_wds, args_offsets) = + mkVirtHeapOffsets profile NoHeader + (addIdReps (assertNonVoidIds real_bndrs)) + size = WordOff tot_wds + + stack_bot = d_bndr + wordsToBytes platform size + + -- convert offsets from Sp into offsets into the virtual stack + p' = Map.insertList + [ (arg, stack_bot - ByteOff offset) + | (NonVoid arg, offset) <- args_offsets ] + p_alts + + in do + massert isAlgCase + rhs_code <- schemeE stack_bot s p' rhs + return (my_discr alt, + unitOL (UNPACK size) `appOL` rhs_code) + where + real_bndrs = filterOut isTyVar bndrs + + my_discr alt = case alt_con alt of + DEFAULT -> NoDiscr {-shouldn't really happen-} + DataAlt dc + | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc + -> NoDiscr + | otherwise + -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG)) + LitAlt l -> case l of + LitNumber LitNumInt i -> DiscrI (fromInteger i) + LitNumber LitNumInt8 i -> DiscrI8 (fromInteger i) + LitNumber LitNumInt16 i -> DiscrI16 (fromInteger i) + LitNumber LitNumInt32 i -> DiscrI32 (fromInteger i) + LitNumber LitNumInt64 i -> DiscrI64 (fromInteger i) + LitNumber LitNumWord w -> DiscrW (fromInteger w) + LitNumber LitNumWord8 w -> DiscrW8 (fromInteger w) + LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w) + LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w) + LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w) + LitNumber LitNumBigNat _ -> unsupported + LitFloat r -> DiscrF (fromRational r) + LitDouble r -> DiscrD (fromRational r) + LitChar i -> DiscrI (ord i) + LitString {} -> unsupported + LitRubbish {} -> unsupported + LitNullAddr {} -> unsupported + LitLabel {} -> unsupported + where + unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l) + + maybe_ncons + | not isAlgCase = Nothing + | otherwise + = case [dc | DataAlt dc <- alt_con <$> alts] of + [] -> Nothing + (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) + + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) + -- + -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. + -- The bitmap must cover the portion of the stack up to the sequel only. + -- Previously we were building a bitmap for the whole depth (d), but we + -- really want a bitmap up to depth (d-s). This affects compilation of + -- case-of-case expressions, which is the only time we can be compiling a + -- case expression with s /= 0. + + -- unboxed tuples get two more words, the second is a pointer (tuple_bco) + (extra_pointers, extra_slots) + | ubx_tuple_frame && profiling = ([1], 3) -- call_info, tuple_BCO, CCCS + | ubx_tuple_frame = ([1], 2) -- call_info, tuple_BCO + | otherwise = ([], 0) + + bitmap_size :: WordOff + bitmap_size = fromIntegral extra_slots + + bytesToWords platform (d - s) + + bitmap_size' :: Int + bitmap_size' = fromIntegral bitmap_size + + + pointers = + extra_pointers ++ + filter (< bitmap_size') (map (+extra_slots) rel_slots) + where + -- NB: unboxed tuple cases bind the scrut binder to the same offset + -- as one of the alt binders, so we have to remove any duplicates here: + -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'. + rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p + spread id offset | isUnboxedTupleType (idType id) || + isUnboxedSumType (idType id) = Nothing + | isFollowableArg (idArgRep platform id) = Just (fromIntegral rel_offset) + | otherwise = Nothing + where rel_offset = bytesToWords platform (d - offset) + + bitmap = intsToReverseBitmap platform bitmap_size' pointers + + alt_stuff <- mapM codeAlt alts + alt_final0 <- mkMultiBranch maybe_ncons alt_stuff + + let + + -- drop the stg_ctoi_*_info header... + alt_final1 = SLIDE bndr_size ctoi_frame_header_w `consOL` alt_final0 + + -- after dropping the stg_ret_*_info header + alt_final2 = SLIDE 0 ret_info_header_w `consOL` alt_final1 + + -- When entering a case continuation BCO, the stack is always headed + -- by the stg_ret frame and the stg_ctoi frame that returned to it. + -- See Note [Stack layout when entering run_BCO] + -- + -- Right after the breakpoint instruction, a case continuation BCO + -- drops the stg_ret and stg_ctoi frame headers (see alt_final1, + -- alt_final2), leaving the stack with the scrutinee followed by the + -- free variables (with depth==d_bndr) + alt_final <- getLastBreakTick >>= \case + Just (Breakpoint tick_ty tick_id fvs) + | gopt Opt_InsertBreakpoints (hsc_dflags hsc_env) + -- Construct an internal breakpoint to put at the start of this case + -- continuation BCO, for step-out. + -- See Note [Debugger: Stepout internal break locs] + -> do + + -- same fvs available in the surrounding tick are available in the case continuation + + -- The variable offsets into the yielded AP_STACK are adjusted + -- differently because a case continuation AP_STACK has the + -- additional stg_ret and stg_ctoi frame headers + -- (as per Note [Stack layout when entering run_BCO]): + let firstVarOff = ret_info_header_w+bndr_size+ctoi_frame_header_w + idOffSets = map (fmap (second (+firstVarOff))) $ + getVarOffSets platform d p fvs + ty_vars = tyCoVarsOfTypesWellScoped (tick_ty:map idType fvs) + toWord :: Maybe (Id, WordOff) -> Maybe (Id, Word) + toWord = fmap (\(i, wo) -> (i, fromIntegral wo)) + breakInfo = dehydrateCgBreakInfo ty_vars (map toWord idOffSets) tick_ty + (Left (InternalBreakLoc tick_id)) + + mibi <- newBreakInfo breakInfo + return $ case mibi of + Nothing -> alt_final2 + Just ibi -> BRK_FUN ibi `consOL` alt_final2 + _ -> pure alt_final2 + + add_bco_name <- shouldAddBcoName + let + alt_bco_name = getName bndr + alt_bco = mkProtoBCO platform add_bco_name alt_bco_name alt_final (Left alts) + 0{-no arity-} bitmap_size bitmap True{-is alts-} + scrut_code <- schemeE (d + wordsToBytes platform ctoi_frame_header_w + save_ccs_size_b) + (d + wordsToBytes platform ctoi_frame_header_w + save_ccs_size_b) + p scrut + if ubx_tuple_frame + then do let tuple_bco = tupleBCO platform call_info args_offsets + return (PUSH_ALTS_TUPLE alt_bco call_info tuple_bco + `consOL` scrut_code) + else let scrut_rep = case non_void_arg_reps of + [] -> V + [rep] -> rep + _ -> panic "schemeE(StgCase).push_alts" + in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code) + +{- +Note [Debugger: Stepout internal break locs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Step-out tells the interpreter to run until the current function +returns to where it was called from, and stop there. + +This is achieved by enabling the BRK_FUN found on the first RET_BCO +frame on the stack (See [Note Debugger: Step-out]). + +Case continuation BCOs (which select an alternative branch) must +therefore be headed by a BRK_FUN. An example: + + f x = case g x of <--- end up here + 1 -> ... + 2 -> ... + + g y = ... <--- step out from here + +- `g` will return a value to the case continuation BCO in `f` +- The case continuation BCO will receive the value returned from g +- Match on it and push the alternative continuation for that branch +- And then enter that alternative. + +If we step-out of `g`, the first RET_BCO on the stack is the case +continuation of `f` -- execution should stop at its start, before +selecting an alternative. (One might ask, "why not enable the breakpoint +in the alternative instead?", because the alternative continuation is +only pushed to the stack *after* it is selected by the case cont. BCO) + +However, the case cont. BCO is not associated with any source-level +tick, it is merely the glue code which selects alternatives which do +have source level ticks. Therefore, we have to come up at code +generation time with a breakpoint location ('InternalBreakLoc') to +display to the user when it is stopped there. + +Our solution is to use the last tick seen just before reaching the case +continuation. This is robust because a case continuation will thus +always have a relevant breakpoint location: + + - The source location will be the last source-relevant expression + executed before the continuation is pushed + + - So the source location will point to the thing you've just stepped + out of + + - The variables available are the same as the ones bound just before entering + + - Doing :step-local from there will put you on the selected + alternative (which at the source level may also be the e.g. next + line in a do-block) + +Examples, using angle brackets (<<...>>) to denote the breakpoint span: + + f x = case <> {- step in here -} of + 1 -> ... + 2 -> ...> + + g y = <<...>> <--- step out from here + + ... + + f x = < ... + 2 -> ...>> + + doing :step-local ... + + f x = case g x of + 1 -> <<...>> <--- stop in the alternative + 2 -> ... + +A second example based on T26042d2, where the source is a do-block IO +action, optimised to a chain of `case expressions`. + + main = do + putStrLn "hello1" + <> <--- step-in here + putStrLn "hello3" + putStrLn "hello4" + + f = do + <> <--- step-out from here + putStrLn "hello2.2" + + ... + + main = do + putStrLn "hello1" + <> <--- end up here again, the previously executed expression + putStrLn "hello3" + putStrLn "hello4" + + doing step/step-local ... + + main = do + putStrLn "hello1" + f + <> <--- straight to the next line + putStrLn "hello4" +-} + +-- ----------------------------------------------------------------------------- +-- Deal with tuples + +-- 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 -> PrimRep) + -> [a] + -> ( NativeCallInfo -- See Note [GHCi TupleInfo] + , [(a, ByteOff)] -- argument, offset on stack + ) +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 + arg_ty + reps + + -- keep the stack parameters in the same place + orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos] + + -- sort the register parameters by register and add them to the stack + regs_order :: Map.Map GlobalReg Int + regs_order = Map.fromList $ zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..] + + reg_order :: GlobalReg -> (Int, GlobalReg) + reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg) + -- if we don't have a position for a FloatReg then they must be passed + -- in the equivalent DoubleReg + reg_order (FloatReg n) = reg_order (DoubleReg n) + -- one-tuples can be passed in other registers, but then we don't need + -- to care about the order + reg_order reg = (0, reg) + + (regs, reg_params) + = unzip $ sortBy (comparing fst) + [(reg_order reg, x) | (x, RegisterParam reg) <- pos] + + (new_stk_bytes, new_stk_params) = assignStack platform + orig_stk_bytes + arg_ty + reg_params + + regs_set = mkRegSet (map snd regs) + + get_byte_off (x, StackParam y) = (x, fromIntegral y) + get_byte_off _ = + panic "GHC.StgToByteCode.layoutTuple get_byte_off" + + in ( NativeCallInfo + { nativeCallType = call_type + , nativeCallSize = bytesToWords platform (ByteOff new_stk_bytes) + , nativeCallRegs = regs_set + , nativeCallStackSpillSize = bytesToWords platform + (ByteOff orig_stk_bytes) + } + , sortBy (comparing snd) $ + map (\(x, o) -> (x, o + start_off)) + (orig_stk_params ++ map get_byte_off new_stk_params) + ) + +{- Note [Return convention for non-tuple values] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RETURN and ENTER instructions are used to return values. RETURN directly +returns the value at the top of the stack while ENTER evaluates it first (so +RETURN is only used when the result is already known to be evaluated), but the +end result is the same: control returns to the enclosing stack frame with the +result at the top of the stack. + +The PUSH_ALTS instruction pushes a two-word stack frame that receives a single +lifted value. Its payload is a BCO that is executed when control returns, with +the stack set up as if a RETURN instruction had just been executed: the returned +value is at the top of the stack, and beneath it is the two-word frame being +returned to. It is the continuation BCO’s job to pop its own frame off the +stack, so the simplest possible continuation consists of two instructions: + + SLIDE 1 2 -- pop the return frame off the stack, keeping the returned value + RETURN P -- return the returned value to our caller + +RETURN and PUSH_ALTS are not really instructions but are in fact representation- +polymorphic *families* of instructions indexed by ArgRep. ENTER, however, is a +single real instruction, since it is only used to return lifted values, which +are always pointers. + +The RETURN, ENTER, and PUSH_ALTS instructions are only used when the returned +value has nullary or unary representation. Returning/receiving an unboxed +tuple (or, indirectly, an unboxed sum, since unboxed sums have been desugared to +unboxed tuples by Unarise) containing two or more results uses the special +RETURN_TUPLE/PUSH_ALTS_TUPLE instructions, which use a different return +convention. See Note [unboxed tuple bytecodes and tuple_BCO] for details. + +Note [unboxed tuple bytecodes and tuple_BCO] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to + return and receive arbitrary unboxed tuples, respectively. These + instructions use the helper data tuple_BCO and call_info. + + The helper data is used to convert tuples between GHCs native calling + convention (object code), which uses stack and registers, and the bytecode + calling convention, which only uses the stack. See Note [GHCi TupleInfo] + for more details. + + + Returning a tuple + ================= + + Bytecode that returns a tuple first pushes all the tuple fields followed + by the appropriate call_info and tuple_BCO onto the stack. It then + executes the RETURN_TUPLE instruction, which causes the interpreter + to push stg_ret_t_info to the top of the stack. The stack (growing down) + then looks as follows: + + ... + next_frame + tuple_field_1 + tuple_field_2 + ... + tuple_field_n + call_info + tuple_BCO + stg_ret_t_info <- Sp + + If next_frame is bytecode, the interpreter will start executing it. If + it's object code, the interpreter jumps back to the scheduler, which in + turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native + calling convention using the description in call_info, and then jumps + to next_frame. + + + Receiving a tuple + ================= + + Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to + push a continuation, followed by jumping to the code that produces the + tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data: + + * cont_BCO: the continuation that receives the tuple + * call_info: see below + * tuple_BCO: see below + + The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE + instruction is executed, followed by stg_ctoi_tN_info, with N depending + on the number of stack words used by the tuple in the GHC native calling + convention. N is derived from call_info. + + For example if we expect a tuple with three words on the stack, the stack + looks as follows after PUSH_ALTS_TUPLE: + + ... + next_frame + cont_free_var_1 + cont_free_var_2 + ... + cont_free_var_n + call_info + tuple_BCO + cont_BCO + stg_ctoi_t3_info <- Sp + + If the tuple is returned by object code, stg_ctoi_t3 will deal with + adjusting the stack pointer and converting the tuple to the bytecode + calling convention. See Note [GHCi unboxed tuples stack spills] for more + details. + + + The tuple_BCO + ============= + + The tuple_BCO is a helper bytecode object. Its main purpose is describing + the contents of the stack frame containing the tuple for the storage + manager. It contains only instructions to immediately return the tuple + that is already on the stack. + + + The call_info word + =================== + + The call_info word describes the stack and STG register (e.g. R1..R6, + D1..D6) usage for the tuple. call_info contains enough information to + convert the tuple between the stack-only bytecode and stack+registers + GHC native calling conventions. + + See Note [GHCi and native call registers] for more details of how the + data is packed in a single word. + + -} + +tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name +tupleBCO platform args_info args = + mkProtoBCO platform Nothing invented_name body_code (Left []) + 0{-no arity-} bitmap_size bitmap False{-not alts-} + where + {- + The tuple BCO is never referred to by name, so we can get away + with using a fake name here. We will need to change this if we want + to save some memory by sharing the BCO between places that have + the same tuple shape + -} + invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple") + + -- the first word in the frame is the call_info word, + -- which is not a pointer + nptrs_prefix = 1 + (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args + + body_code = mkSlideW 0 1 -- pop frame header + `snocOL` RETURN_TUPLE -- and add it again + +primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name +primCallBCO platform args_info args = + mkProtoBCO platform Nothing invented_name body_code (Left []) + 0{-no arity-} bitmap_size bitmap False{-not alts-} + where + {- + The primcall BCO is never referred to by name, so we can get away + with using a fake name here. We will need to change this if we want + to save some memory by sharing the BCO between places that have + the same tuple shape + -} + invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "primcall") + + -- The first two words in the frame (after the BCO) are the call_info word + -- and the pointer to the Cmm function being called. Neither of these is a + -- pointer that should be followed by the garbage collector. + nptrs_prefix = 2 + (bitmap_size, bitmap) = mkStackBitmap platform nptrs_prefix args_info args + + -- if the primcall BCO is ever run it's a bug, since the BCO should only + -- be pushed immediately before running the PRIMCALL bytecode instruction, + -- which immediately leaves the interpreter to jump to the stg_primcall_info + -- Cmm function + body_code = unitOL CASEFAIL + +-- | Builds a bitmap for a stack layout with a nonpointer prefix followed by +-- some number of arguments. +mkStackBitmap + :: Platform + -> WordOff + -- ^ The number of nonpointer words that prefix the arguments. + -> NativeCallInfo + -> [(PrimRep, ByteOff)] + -- ^ The stack layout of the arguments, where each offset is relative to the + -- /bottom/ of the stack space they occupy. Their offsets must be word-aligned, + -- and the list must be sorted in order of ascending offset (i.e. bottom to top). + -> (WordOff, [StgWord]) +mkStackBitmap platform nptrs_prefix args_info args + = (bitmap_size, bitmap) + where + bitmap_size = nptrs_prefix + arg_bottom + bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) ptr_offsets + + arg_bottom = nativeCallSize args_info + ptr_offsets = reverse $ map (fromIntegral . convert_arg_offset) + $ mapMaybe get_ptr_offset args + + get_ptr_offset :: (PrimRep, ByteOff) -> Maybe ByteOff + get_ptr_offset (rep, byte_offset) + | isFollowableArg (toArgRep platform rep) = Just byte_offset + | otherwise = Nothing + + convert_arg_offset :: ByteOff -> WordOff + convert_arg_offset arg_offset = + -- The argument offsets are relative to `arg_bottom`, but + -- `intsToReverseBitmap` expects offsets from the top, so we need to flip + -- them around. + nptrs_prefix + (arg_bottom - bytesToWords platform arg_offset) + +-- ----------------------------------------------------------------------------- +-- Deal with a primitive call to native code. + +generatePrimCall + :: StackDepth + -> Sequel + -> BCEnv + -> CLabelString -- where to call + -> Maybe Unit + -> Type + -> [StgArg] -- args (atoms) + -> BcM BCInstrList +generatePrimCall d s p target _mb_unit _result_ty args + = do + profile <- getProfile + let + platform = profilePlatform profile + + non_void VoidRep = False + non_void _ = True + + nv_args :: [StgArg] + nv_args = filter (non_void . stgArgRep1) args + + (args_info, args_offsets) = + layoutNativeCall profile + NativePrimCall + 0 + stgArgRepU + nv_args + + prim_args_offsets = mapFst stgArgRepU args_offsets + shifted_args_offsets = mapSnd (+ d) args_offsets + + 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) + + size of arguments plus three words for: + - function pointer to the target + - call_info word + - BCO to describe the stack frame + -} + szb = wordsToBytes platform (nativeCallSize args_info + 3) + 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 + push_args <- go d [] shifted_args_offsets + let args_bco = primCallBCO platform args_info prim_args_offsets + return $ mconcat push_args `appOL` + (push_target `consOL` + push_info `consOL` + PUSH_BCO args_bco `consOL` + (mkSlideB platform szb (d - s) `appOL` unitOL PRIMCALL)) + +-- ----------------------------------------------------------------------------- +-- Deal with a CCall. + +-- Taggedly push the args onto the stack R->L, +-- deferencing ForeignObj#s and adjusting addrs to point to +-- payloads in Ptr/Byte arrays. Then, generate the marshalling +-- (machine) code for the ccall, and create bytecodes to call that and +-- then return in the right way. + +generateCCall + :: StackDepth + -> Sequel + -> BCEnv + -> CCallSpec -- where to call + -> Type + -> [StgArg] -- args (atoms) + -> BcM BCInstrList +generateCCall d0 s p (CCallSpec target PrimCallConv _) result_ty args + | (StaticTarget _ label mb_unit _) <- target + = 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 _ safety) result_ty args + = do + profile <- getProfile + + let + args_r_to_l = reverse args + platform = profilePlatform profile + -- useful constants + addr_size_b :: ByteOff + addr_size_b = wordSize platform + + arrayish_rep_hdr_size :: TyCon -> Maybe Int + arrayish_rep_hdr_size t + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + = Just (arrPtrsHdrSize profile) + | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon + = Just (smallArrPtrsHdrSize profile) + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + = Just (arrWordsHdrSize profile) + | otherwise + = Nothing + + -- Get the args on the stack, with tags and suitably + -- dereferenced for the CCall. For each arg, return the + -- depth to the first word of the bits for that arg, and the + -- ArgRep of what was actually pushed. + + pargs + :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimOrVoidRep)] + pargs _ [] = return [] + pargs d (aa@(StgVarArg a):az) + | Just t <- tyConAppTyCon_maybe (idType a) + , Just hdr_sz <- arrayish_rep_hdr_size t + -- Do magic for Ptr/Byte arrays. Push a ptr to the array on + -- the stack but then advance it over the headers, so as to + -- point to the payload. + = do rest <- pargs (d + addr_size_b) az + (push_fo, _) <- pushAtom d p aa + -- The ptr points at the header. Advance it over the + -- header and then pretend this is an Addr#. + let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz) + return ((code, NVRep AddrRep) : rest) + pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa + rest <- pargs (d + sz_a) az + return ((code_a, stgArgRep1 aa) : rest) + + code_n_reps <- pargs d0 args_r_to_l + let + (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps + a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l) + + push_args = concatOL pushs_arg + !d_after_args = d0 + wordsToBytes platform a_reps_sizeW + a_reps_pushed_RAW + | VoidRep:xs <- a_reps_pushed_r_to_l + = reverse xs + | otherwise + = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" + + -- Now: a_reps_pushed_RAW are the reps which are actually on the stack. + -- push_args is the code to do that. + -- d_after_args is the stack depth once the args are on. + + -- Get the result rep. + r_rep = maybe_getCCallReturnRep result_ty + {- + Because the Haskell stack grows down, the a_reps refer to + lowest to highest addresses in that order. The args for the call + are on the stack. Now push an unboxed Addr# indicating + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the + Addr# just pushed, and a literal field holding the mallocville + address of the piece of marshalling code we generate. + So, just prior to the CCALL insn, the stack looks like this + (growing down, as usual): + + + ... + + Addr# address_of_C_fn + (must be an unboxed type) + + The interpreter then calls the marshal code mentioned + in the CCALL insn, passing it (& ), + that is, the addr of the topmost word in the stack. + When this returns, the placeholder will have been + filled in. The placeholder is slid down to the sequel + depth, and we RETURN. + + This arrangement makes it simple to do f-i-dynamic since the Addr# + value is the first arg anyway. + + The marshalling code is generated specifically for this + call site, and so knows exactly the (Haskell) stack + offsets of the args, fn address and placeholder. It + copies the args to the C stack, calls the stacked addr, + and parks the result back in the placeholder. The interpreter + calls it as a normal C call, assuming it has a signature + void marshal_code ( StgWord* ptr_to_top_of_stack ) + -} + -- resolve static address + maybe_static_target :: Maybe Literal + maybe_static_target = + case target of + DynamicTarget -> Nothing + StaticTarget _ _ _ False -> + panic "generateCCall: unexpected FFI value import" + StaticTarget _ target _ True -> + Just (LitLabel target IsFunction) + + let + is_static = isJust maybe_static_target + + -- Get the arg reps, zapping the leading Addr# in the dynamic case + a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" + | is_static = a_reps_pushed_RAW + | _:xs <- a_reps_pushed_RAW = xs + | otherwise = panic "GHC.StgToByteCode.generateCCall: dyn with no args" + + -- push the Addr# + (push_Addr, d_after_Addr) + | Just machlabel <- maybe_static_target + = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b) + | otherwise -- is already on the stack + = (nilOL, d_after_args) + + -- Push the return placeholder. For a call returning nothing, + -- this is a V (tag). + r_sizeW = repSizeWords platform r_rep + d_after_r = d_after_Addr + wordsToBytes platform r_sizeW + push_r = case r_rep of + VoidRep -> nilOL + NVRep r -> unitOL (PUSH_UBX (mkDummyLiteral platform r) r_sizeW) + + -- generate the marshalling code we're going to call + + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = bytesToWords platform (d_after_r - s) + + -- 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. + + + let ffires = primRepToFFIType platform r_rep + ffiargs = map (primRepToFFIType platform) a_reps + + let + -- do the call + do_call = unitOL (CCALL stk_offset (FFIInfo ffiargs ffires) flags) + where flags = case safety of + PlaySafe -> 0x0 + PlayInterruptible -> 0x1 + PlayRisky -> 0x2 + + -- slide and return + d_after_r_min_s = bytesToWords platform (d_after_r - s) + wrapup = mkSlideW r_sizeW (d_after_r_min_s - r_sizeW) + `snocOL` RETURN (toArgRepOrV platform r_rep) + --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ + return ( + push_args `appOL` + push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup + ) + +primRepToFFIType :: Platform -> PrimOrVoidRep -> FFIType +primRepToFFIType _ VoidRep = FFIVoid +primRepToFFIType platform (NVRep r) + = case r of + IntRep -> signed_word + WordRep -> unsigned_word + Int8Rep -> FFISInt8 + Word8Rep -> FFIUInt8 + Int16Rep -> FFISInt16 + Word16Rep -> FFIUInt16 + Int32Rep -> FFISInt32 + Word32Rep -> FFIUInt32 + Int64Rep -> FFISInt64 + Word64Rep -> FFIUInt64 + AddrRep -> FFIPointer + FloatRep -> FFIFloat + DoubleRep -> FFIDouble + BoxedRep _ -> FFIPointer + VecRep{} -> pprPanic "primRepToFFIType" (ppr r) + where + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> (FFISInt32, FFIUInt32) + PW8 -> (FFISInt64, FFIUInt64) + +-- Make a dummy literal, to be used as a placeholder for FFI return +-- values on the stack. +mkDummyLiteral :: Platform -> PrimRep -> Literal +mkDummyLiteral platform pr + = case pr of + IntRep -> mkLitInt platform 0 + WordRep -> mkLitWord platform 0 + Int8Rep -> mkLitInt8 0 + Word8Rep -> mkLitWord8 0 + Int16Rep -> mkLitInt16 0 + Word16Rep -> mkLitWord16 0 + Int32Rep -> mkLitInt32 0 + Word32Rep -> mkLitWord32 0 + Int64Rep -> mkLitInt64 0 + Word64Rep -> mkLitWord64 0 + AddrRep -> LitNullAddr + DoubleRep -> LitDouble 0 + FloatRep -> LitFloat 0 + BoxedRep _ -> LitNullAddr + VecRep{} -> pprPanic "mkDummyLiteral" (ppr pr) + + +-- Convert (eg) +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) +-- +-- to NVRep IntRep +-- and check that an unboxed pair is returned wherein the first arg is V'd. +-- +-- Alternatively, for call-targets returning nothing, convert +-- +-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld +-- -> (# GHC.Prim.State# GHC.Prim.RealWorld #) +-- +-- to VoidRep + +maybe_getCCallReturnRep :: Type -> PrimOrVoidRep +maybe_getCCallReturnRep fn_ty + = let + (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) + in + case typePrimRep r_ty of + [] -> VoidRep + [rep] -> NVRep rep + + -- if it was, it would be impossible to create a + -- valid return value placeholder on the stack + _ -> pprPanic "maybe_getCCallReturn: can't handle:" + (pprType fn_ty) + +maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (StgArg, [Name]) +-- Detect and extract relevant info for the tagToEnum kludge. +maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) args t) + | [v] <- args + = 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 + , Just tyc <- tyConAppTyCon_maybe rep_ty + , isBoxedDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See "GHC.Core.DataCon" for details. + | otherwise + = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) +maybe_is_tagToEnum_call _ = Nothing + +{- ----------------------------------------------------------------------------- +Note [Implementing tagToEnum#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(implement_tagToId arg names) compiles code which takes an argument +'arg', (call it i), and enters the i'th closure in the supplied list +as a consequence. The [Name] is a list of the constructors of this +(enumeration) type. + +The code we generate is this: + push arg + + TESTEQ_I 0 L1 + PUSH_G + JMP L_Exit + + L1: TESTEQ_I 1 L2 + PUSH_G + JMP L_Exit + ...etc... + Ln: TESTEQ_I n L_fail + PUSH_G + JMP L_Exit + + L_fail: CASEFAIL + + L_exit: SLIDE 1 n + ENTER +-} + + +implement_tagToId + :: StackDepth + -> Sequel + -> BCEnv + -> StgArg + -> [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) + label_fail <- getLabelBc + label_exit <- getLabelBc + dflags <- getDynFlags + let infos = zip4 labels (tail labels ++ [label_fail]) + [0 ..] names + platform = targetPlatform dflags + steps = map (mkStep label_exit) infos + slide_ws = bytesToWords platform (d - s + arg_bytes) + + return (push_arg + `appOL` concatOL steps + `appOL` toOL [ LABEL label_fail, CASEFAIL, + LABEL label_exit ] + `appOL` mkSlideW 1 slide_ws + `appOL` unitOL ENTER) + where + mkStep l_exit (my_label, next_label, n, name_for_n) + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G name_for_n, + JMP l_exit] + + +-- ----------------------------------------------------------------------------- +-- pushAtom + +-- Push an atom onto the stack, returning suitable code & number of +-- stack words used. +-- +-- The env p must map each variable to the highest- numbered stack +-- slot for it. For example, if the stack has depth 4 and we +-- tagged-ly push (v :: Int#) on it, the value will be in stack[4], +-- the tag in stack[5], the stack will have depth 6, and p must map v +-- to 5 and not to 4. Stack locations are numbered from zero, so a +-- depth 6 stack has valid words 0 .. 5. + +pushAtom :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) +-- See Note [Empty case alternatives] in GHC.Core +-- and Note [Bottoming expressions] in GHC.Core.Utils: +-- The scrutinee of an empty case evaluates to bottom +pushAtom d p (StgVarArg var) + | [] <- typePrimRep (idType var) + = return (nilOL, 0) + + | isFCallId var + = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var) + + | Just primop <- isPrimOpId_maybe var + = do + platform <- targetPlatform <$> getDynFlags + return (unitOL (PUSH_PRIMOP primop), wordSize platform) + + | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable + = do platform <- targetPlatform <$> getDynFlags + + let !szb = idSizeCon platform var + with_instr :: (ByteOff -> BCInstr) -> BcM (OrdList BCInstr, ByteOff) + with_instr instr = do + let !off_b = d - d_v + return (unitOL (instr off_b), wordSize platform) + + case szb of + 1 -> with_instr PUSH8_W + 2 -> with_instr PUSH16_W + 4 -> with_instr PUSH32_W + _ -> do + let !szw = bytesToWords platform szb + !off_w = bytesToWords platform (d - d_v) + szw - 1 + return (toOL (genericReplicate szw (PUSH_L off_w)), + wordsToBytes platform szw) + -- d - d_v offset from TOS to the first slot of the object + -- + -- d - d_v + sz - 1 offset from the TOS of the last slot of the object + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. + + | otherwise -- var must be a global variable + = do platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform var + massert (szb == wordSize platform) + + -- PUSH_G doesn't tag constructors. So we use PACK here + -- if we are dealing with nullary constructor. + case isDataConWorkId_maybe var of + Just con + -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make. + | isNullaryRepDataCon con -> + return (unitOL (PACK con 0), szb) + + _ + -- see Note [Generating code for top-level string literal bindings] + | idType var `eqType` addrPrimTy -> + return (unitOL (PUSH_ADDR (getName var)), szb) + + | otherwise -> do + let varTy = idType var + massertPpr (definitelyLiftedType varTy) $ + vcat [ text "pushAtom: unhandled unlifted type" + , text "var:" <+> ppr var <+> dcolon <+> ppr varTy <> dcolon <+> ppr (typeKind varTy) + ] + return (unitOL (PUSH_G (getName var)), szb) + +pushAtom _ _ (StgLitArg lit) = pushLiteral True lit + +pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff) +pushLiteral padded lit = + do + platform <- targetPlatform <$> getDynFlags + let code :: PrimRep -> BcM (BCInstrList, ByteOff) + code rep = + -- TODO: It's a bit silly to use up to four instructions to put a single literal on the stack. + -- Lot's of better ways to do this. Add a instruction to push it as full word. + -- Store the literal as full word and push it as full word. + -- Maybe more, but for now this will do. + case platformByteOrder platform of + LittleEndian -> return (padding_instr `snocOL` instr, size_bytes + padding_bytes) + BigEndian -> return (instr `consOL` padding_instr, size_bytes + padding_bytes) + where + size_bytes = ByteOff $ primRepSizeB platform rep + + -- Here we handle the non-word-width cases specifically since we + -- must emit different bytecode for them. + + round_to_words (ByteOff bytes) = + ByteOff (roundUpToWords platform bytes) + + padding_bytes + | padded = round_to_words size_bytes - size_bytes + | otherwise = 0 + + (padding_instr, _) = pushPadding padding_bytes + + instr = + case size_bytes of + 1 -> PUSH_UBX8 lit + 2 -> PUSH_UBX16 lit + 4 -> PUSH_UBX32 lit + _ -> PUSH_UBX lit (bytesToWords platform size_bytes) + + case lit of + LitLabel {} -> code AddrRep + LitFloat {} -> code FloatRep + LitDouble {} -> code DoubleRep + LitChar {} -> code WordRep + LitNullAddr -> code AddrRep + LitString {} -> code AddrRep + LitRubbish _ rep-> case runtimeRepPrimRep (text "pushLiteral") rep of + [pr] -> code pr + _ -> pprPanic "pushLiteral" (ppr lit) + LitNumber nt _ -> case nt of + LitNumInt -> code IntRep + LitNumWord -> code WordRep + LitNumInt8 -> code Int8Rep + LitNumWord8 -> code Word8Rep + LitNumInt16 -> code Int16Rep + LitNumWord16 -> code Word16Rep + LitNumInt32 -> code Int32Rep + LitNumWord32 -> code Word32Rep + LitNumInt64 -> code Int64Rep + LitNumWord64 -> code Word64Rep + -- No LitNumBigNat should be left by the time this is called. CorePrep + -- should have converted them all to a real core representation. + LitNumBigNat -> panic "pushAtom: LitNumBigNat" + +-- | Push an atom for constructor (i.e., PACK instruction) onto the stack. +-- This is slightly different to @pushAtom@ due to the fact that we allow +-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. +pushConstrAtom + :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff) +pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit + +pushConstrAtom d p va@(StgVarArg v) + | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable + platform <- targetPlatform <$> getDynFlags + let !szb = idSizeCon platform v + done instr = do + let !off = d - d_v + return (unitOL (instr off), szb) + case szb of + 1 -> done PUSH8 + 2 -> done PUSH16 + 4 -> done PUSH32 + _ -> pushAtom d p va + +pushConstrAtom d p expr = pushAtom d p expr + +pushPadding :: ByteOff -> (BCInstrList, ByteOff) +pushPadding (ByteOff n) = go n (nilOL, 0) + where + go n acc@(!instrs, !off) = case n of + 0 -> acc + 1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1) + 2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2) + 3 -> go 1 (go 2 acc) + 4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4) + _ -> go (n - 4) (go 4 acc) + +-- ----------------------------------------------------------------------------- +-- Given a bunch of alts code and their discrs, do the donkey work +-- of making a multiway branch using a switch tree. +-- What a load of hassle! + +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] + -> BcM BCInstrList +mkMultiBranch maybe_ncons raw_ways = do + lbl_default <- getLabelBc + + let + mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList + mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default)) + -- shouldn't happen? + + mkTree [val] range_lo range_hi + | range_lo == range_hi + = return (snd val) + | null defaults -- Note [CASEFAIL] + = do lbl <- getLabelBc + return (testEQ (fst val) lbl + `consOL` (snd val + `appOL` (LABEL lbl `consOL` unitOL CASEFAIL))) + | otherwise + = return (testEQ (fst val) lbl_default `consOL` snd val) + + -- Note [CASEFAIL] + -- ~~~~~~~~~~~~~~~ + -- It may be that this case has no default + -- branch, but the alternatives are not exhaustive - this + -- happens for GADT cases for example, where the types + -- prove that certain branches are impossible. We could + -- just assume that the other cases won't occur, but if + -- this assumption was wrong (because of a bug in GHC) + -- then the result would be a segfault. So instead we + -- emit an explicit test and a CASEFAIL instruction that + -- causes the interpreter to barf() if it is ever + -- executed. + + mkTree vals range_lo range_hi + = let n = length vals `div` 2 + (vals_lo, vals_hi) = splitAt n vals + v_mid = fst (head vals_hi) + in do + label_geq <- getLabelBc + code_lo <- mkTree vals_lo range_lo (dec v_mid) + code_hi <- mkTree vals_hi v_mid range_hi + return (testLT v_mid label_geq + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default + = case defaults of + [] -> nilOL + [(_, def)] -> LABEL lbl_default `consOL` def + _ -> panic "mkMultiBranch/the_default" + instrs <- mkTree notd_ways init_lo init_hi + return (instrs `appOL` the_default) + where + (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways + notd_ways = sortBy (comparing fst) not_defaults + + testLT (DiscrI i) fail_label = TESTLT_I i fail_label + testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label + testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label + testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label + testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label + testLT (DiscrW i) fail_label = TESTLT_W i fail_label + testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label + testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label + testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label + testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label + testLT (DiscrF i) fail_label = TESTLT_F i fail_label + testLT (DiscrD i) fail_label = TESTLT_D i fail_label + testLT (DiscrP i) fail_label = TESTLT_P i fail_label + testLT NoDiscr _ = panic "mkMultiBranch NoDiscr" + + testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label + testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label + testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label + testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label + testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label + testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label + testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label + testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label + testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label + testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label + testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label + testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label + testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label + testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" + + -- None of these will be needed if there are no non-default alts + (init_lo, init_hi) = case notd_ways of + [] -> panic "mkMultiBranch: awesome foursome" + (discr, _):_ -> case discr of + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound ) + DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound ) + DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound ) + DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound ) + DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound ) + DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound ) + DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" + + (algMinBound, algMaxBound) + = case maybe_ncons of + -- XXX What happens when n == 0? + Just n -> (0, fromIntegral n - 1) + Nothing -> (minBound, maxBound) + + isNoDiscr NoDiscr = True + isNoDiscr _ = False + + dec (DiscrI i) = DiscrI (i-1) + dec (DiscrW w) = DiscrW (w-1) + dec (DiscrP i) = DiscrP (i-1) + dec other = other -- not really right, but if you + -- do cases on floating values, you'll get what you deserve + + -- same snotty comment applies to the following + minF, maxF :: Float + minD, maxD :: Double + minF = -1.0e37 + maxF = 1.0e37 + minD = -1.0e308 + maxD = 1.0e308 + + +-- ----------------------------------------------------------------------------- +-- Supporting junk for the compilation schemes + +-- Describes case alts +data Discr + = DiscrI Int + | DiscrI8 Int8 + | DiscrI16 Int16 + | DiscrI32 Int32 + | DiscrI64 Int64 + | DiscrW Word + | DiscrW8 Word8 + | DiscrW16 Word16 + | DiscrW32 Word32 + | DiscrW64 Word64 + | DiscrF Float + | DiscrD Double + | DiscrP Word16 + | NoDiscr + deriving (Eq, Ord) + +instance Outputable Discr where + ppr (DiscrI i) = int i + ppr (DiscrI8 i) = text (show i) + ppr (DiscrI16 i) = text (show i) + ppr (DiscrI32 i) = text (show i) + ppr (DiscrI64 i) = text (show i) + ppr (DiscrW w) = text (show w) + ppr (DiscrW8 w) = text (show w) + ppr (DiscrW16 w) = text (show w) + ppr (DiscrW32 w) = text (show w) + ppr (DiscrW64 w) = text (show w) + ppr (DiscrF f) = text (show f) + ppr (DiscrD d) = text (show d) + ppr (DiscrP i) = ppr i + ppr NoDiscr = text "DEF" + + +lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff +lookupBCEnv_maybe = Map.lookup + +idSizeW :: Platform -> Id -> WordOff +idSizeW platform = WordOff . argRepSizeW platform . idArgRep platform + +idSizeCon :: Platform -> Id -> ByteOff +idSizeCon platform var + -- unboxed tuple components are padded to word size + | isUnboxedTupleType (idType var) || + isUnboxedSumType (idType var) = + wordsToBytes platform . + WordOff . sum . map (argRepSizeW platform . toArgRep platform) . + typePrimRep . idType $ var + | otherwise = ByteOff (primRepSizeB platform (idPrimRepU var)) + +repSizeWords :: Platform -> PrimOrVoidRep -> WordOff +repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRepOrV platform rep) + +isFollowableArg :: ArgRep -> Bool +isFollowableArg P = True +isFollowableArg _ = False + +-- | Indicate if the calling convention is supported +isSupportedCConv :: CCallSpec -> Bool +isSupportedCConv (CCallSpec _ cconv _) = case cconv of + CCallConv -> True -- we explicitly pattern match on every + StdCallConv -> False -- convention to ensure that a warning + PrimCallConv -> True -- is triggered when a new one is added + JavaScriptCallConv -> False + CApiConv -> True + +-- See bug #10462 +unsupportedCConvException :: a +unsupportedCConvException = throwGhcException (ProgramError + ("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 + where + !n = bytesToWords platform nb + !d = bytesToWords platform db + +mkSlideW :: WordOff -> WordOff -> OrdList BCInstr +mkSlideW !n !ws + | ws == 0 + = nilOL + | otherwise + = unitOL (SLIDE n $ fromIntegral ws) + + + +atomRep :: Platform -> StgArg -> ArgRep +atomRep platform e = toArgRepOrV platform (stgArgRep1 e) + +-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which +-- has initial depth @original_depth@. Return the values which the stack +-- environment should map these items to. +mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff] +mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb) + +typeArgReps :: Platform -> Type -> [ArgRep] +typeArgReps platform = map (toArgRep platform) . typePrimRep + +-- ----------------------------------------------------------------------------- +-- The bytecode generator's monad + +-- | Read only environment for generating ByteCode +data BcM_Env + = BcM_Env + { bcm_hsc_env :: !HscEnv + , bcm_module :: !Module -- current module (for breakpoints) + , modBreaks :: !(Maybe ModBreaks) + , last_bp_tick :: !(Maybe StgTickish) + } + +data BcM_State + = BcM_State + { nextlabel :: !Word32 -- ^ For generating local labels + , breakInfoIdx :: !Int -- ^ Next index for breakInfo array + , breakInfo :: !(IntMap CgBreakInfo) + -- ^ Info at breakpoints occurrences. Indexed with + -- 'InternalBreakpointId'. See Note [Breakpoint identifiers] in + -- GHC.ByteCode.Breakpoints. + } + +newtype BcM r = BcM (BcM_Env -> BcM_State -> IO (r, BcM_State)) + deriving (Functor, Applicative, Monad, MonadIO) + via (ReaderT BcM_Env (StateT BcM_State IO)) + +runBc :: HscEnv -> Module -> Maybe ModBreaks -> BcM r -> IO (r, BcM_State) +runBc hsc_env this_mod mbs (BcM m) + = m (BcM_Env hsc_env this_mod mbs Nothing) (BcM_State 0 0 IntMap.empty) + +instance HasDynFlags BcM where + getDynFlags = hsc_dflags <$> getHscEnv + +getHscEnv :: BcM HscEnv +getHscEnv = BcM $ \env st -> return (bcm_hsc_env env, st) + +getProfile :: BcM Profile +getProfile = targetProfile <$> getDynFlags + +shouldAddBcoName :: BcM (Maybe Module) +shouldAddBcoName = do + add <- gopt Opt_AddBcoName <$> getDynFlags + if add + then Just <$> getCurrentModule + else return Nothing + +getLabelBc :: BcM LocalLabel +getLabelBc = BcM $ \_ st -> + do let nl = nextlabel st + when (nl == maxBound) $ + panic "getLabelBc: Ran out of labels" + return (LocalLabel nl, st{nextlabel = nl + 1}) + +getLabelsBc :: Word32 -> BcM [LocalLabel] +getLabelsBc n = BcM $ \_ st -> + let ctr = nextlabel st + in return (coerce [ctr .. ctr+n-1], st{nextlabel = ctr+n}) + +newBreakInfo :: CgBreakInfo -> BcM (Maybe InternalBreakpointId) +newBreakInfo info = BcM $ \env st -> do + -- if we're not generating ModBreaks for this module for some reason, we + -- can't store breakpoint occurrence information. + case modBreaks env of + Nothing -> pure (Nothing, st) + Just modBreaks -> do + let ix = breakInfoIdx st + st' = st + { breakInfo = IntMap.insert ix info (breakInfo st) + , breakInfoIdx = ix + 1 + } + return (Just $ InternalBreakpointId (modBreaks_module modBreaks) ix, st') + +getCurrentModule :: BcM Module +getCurrentModule = BcM $ \env st -> return (bcm_module env, st) + +withBreakTick :: StgTickish -> BcM a -> BcM a +withBreakTick bp (BcM act) = BcM $ \env st -> + act env{last_bp_tick=Just bp} st + +getLastBreakTick :: BcM (Maybe StgTickish) +getLastBreakTick = BcM $ \env st -> + pure (last_bp_tick env, st) + +tickFS :: FastString +tickFS = fsLit "ticked" + +-- Dehydrating CgBreakInfo + +dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word)] -> Type -> Either InternalBreakLoc BreakpointId -> CgBreakInfo +dehydrateCgBreakInfo ty_vars idOffSets tick_ty bid = + CgBreakInfo + { cgb_tyvars = map toIfaceTvBndr ty_vars + , cgb_vars = map (fmap (\(i, offset) -> (toIfaceIdBndr i, offset))) idOffSets + , cgb_resty = toIfaceType tick_ty + , cgb_tick_id = bid + } diff --git a/GHC/StgToCmm.hs b/GHC/StgToCmm.hs --- a/GHC/StgToCmm.hs +++ b/GHC/StgToCmm.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- @@ -15,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 @@ -24,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 @@ -37,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 @@ -50,25 +50,22 @@ import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Unit.Module import GHC.Utils.Error import GHC.Utils.Outputable -import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Data.Stream import GHC.Data.OrdList -import GHC.Types.Unique.Map import Control.Monad (when,void, forM_) import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS import Data.IORef -import GHC.Utils.Panic (assertPpr) +import GHC.Utils.Panic codeGen :: Logger -> TmpFs @@ -77,56 +74,59 @@ -> [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 _ _) 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 - -- Note [codegen-split-init] the cmm_init block must come - -- FIRST. This is because when -split-objs is on we need to - -- combine this block with its initialisation routines; see - -- Note [pipeline-split-init]. - ; 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 + -- Put datatype_stuff (cgTyCon) after code_stuff (cgTopBinding), because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in -- code_stuff - ; let do_tycon tycon = do - -- Generate a table of static closures for an - -- enumeration type Note that the closure pointers are - -- tagged. - when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon) - -- Emit normal info_tables, for data constructors defined in this module. - mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon) - ; mapM_ do_tycon data_tycons + ; mapM_ (cg . cgTyCon) tycons -- Emit special info tables for everything used in this module -- This will only do something if `-fdistinct-info-tables` is turned on. - ; 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 @@ -144,9 +144,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 --------------------------------------------------------------- @@ -215,22 +270,39 @@ 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 } --------------------------------------------------------------- --- Generating static stuff for algebraic data types +-- Generating static stuff for algebraic data types, including +-- * entry code for each data con +-- * info table for each data con +-- * for enumerations, a table of all the closures --------------------------------------------------------------- +--------------------------------------------------------------- +-- Data type constructors +--------------------------------------------------------------- +cgTyCon :: TyCon -> FCode () +-- Generate static data for each algebraic data type +cgTyCon tycon + | not (isBoxedDataTyCon tycon) -- Type families, newtypes, and `type data` constructors + = return () + | otherwise -- An honest-to-goodness algebraic data type + = do { -- Emit normal info_tables, for data constructors defined in this module. + mapM_ (cgDataCon DefinitionSite) (tyConDataCons tycon) + + ; when (isEnumerationTyCon tycon) $ + cgEnumerationTyCon tycon } + cgEnumerationTyCon :: TyCon -> FCode () +-- Generate a table of static closures for an enumeration type. +-- Note that the closure pointers in the table are tagged. cgEnumerationTyCon tycon = do platform <- getPlatform emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs) @@ -238,7 +310,6 @@ (tagForCon platform con) | con <- tyConDataCons tycon] - cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. @@ -258,11 +329,11 @@ -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. - arg_reps :: [NonVoid PrimRep] - arg_reps = [ NonVoid rep_ty + arg_reps :: [PrimRep] + arg_reps = [ rep_ty | ty <- dataConRepArgTys data_con , rep_ty <- typePrimRep (scaledThing ty) - , not (isVoidRep rep_ty) ] + ] ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $ -- NB: the closure pointer is assumed *untagged* on diff --git a/GHC/StgToCmm/ArgRep.hs b/GHC/StgToCmm/ArgRep.hs --- a/GHC/StgToCmm/ArgRep.hs +++ b/GHC/StgToCmm/ArgRep.hs @@ -9,7 +9,7 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToCmm.ArgRep ( - ArgRep(..), toArgRep, argRepSizeW, + ArgRep(..), toArgRep, toArgRepOrV, argRepSizeW, argRepString, isNonV, idArgRep, @@ -20,10 +20,10 @@ import GHC.Prelude import GHC.Platform -import GHC.StgToCmm.Closure ( idPrimRep ) +import GHC.StgToCmm.Closure ( idPrimRep1 ) import GHC.Runtime.Heap.Layout ( WordOff ) import GHC.Types.Id ( Id ) -import GHC.Core.TyCon ( PrimRep(..), primElemRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primElemRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Settings.Constants ( wORD64_SIZE, dOUBLE_SIZE ) @@ -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 @@ -68,7 +68,6 @@ toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V BoxedRep _ -> P IntRep -> N WordRep -> N @@ -93,6 +92,10 @@ 64 -> V64 _ -> error "toArgRep: bad vector primrep" +toArgRepOrV :: Platform -> PrimOrVoidRep -> ArgRep +toArgRepOrV _ VoidRep = V +toArgRepOrV platform (NVRep rep) = toArgRep platform rep + isNonV :: ArgRep -> Bool isNonV V = False isNonV _ = True @@ -112,7 +115,7 @@ ws = platformWordSizeInBytes platform idArgRep :: Platform -> Id -> ArgRep -idArgRep platform = toArgRep platform . idPrimRep +idArgRep platform = toArgRepOrV platform . idPrimRep1 -- This list of argument patterns should be kept in sync with at least -- the following: diff --git a/GHC/StgToCmm/Bind.hs b/GHC/StgToCmm/Bind.hs --- a/GHC/StgToCmm/Bind.hs +++ b/GHC/StgToCmm/Bind.hs @@ -123,26 +123,10 @@ -- StgStdThunks.cmm. gen_code _ closure_label | null args - , StgApp f [arg] <- stripStgTicksTopE (not . tickishIsCode) body - , Just unpack <- is_string_unpack_op f - = do arg' <- getArgAmode (NonVoid arg) - case arg' of - CmmLit lit -> do - let info = CmmInfoTable - { cit_lbl = unpack - , cit_rep = HeapRep True 0 1 Thunk - , cit_prof = NoProfilingInfo - , cit_srt = Nothing - , cit_clo = Nothing - } - emitDecl $ CmmData (Section Data closure_label) $ - CmmStatics closure_label info ccs [] [lit] - _ -> panic "cgTopRhsClosure.gen_code" - where - is_string_unpack_op f - | idName f == unpackCStringName = Just mkRtsUnpackCStringLabel - | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label - | otherwise = Nothing + , Just gen <- isUnpackCStringClosure body + = do (info, lit) <- gen + emitDecl $ CmmData (Section Data closure_label) $ + CmmStatics closure_label info ccs [] [lit] gen_code lf_info _closure_label = do { profile <- getProfile @@ -168,6 +152,41 @@ unLit (CmmLit l) = l unLit _ = panic "unLit" +isUnpackCStringClosure :: CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit)) +isUnpackCStringClosure body = case stripStgTicksTopE (not . tickishIsCode) body of + StgApp f [arg] + | Just unpack <- is_string_unpack_op f + -> Just $ do + arg' <- getArgAmode (NonVoid arg) + case arg' of + CmmLit lit -> do + let info = CmmInfoTable + { cit_lbl = unpack + , cit_rep = HeapRep True 0 1 Thunk + , cit_prof = NoProfilingInfo + , cit_srt = Nothing + , cit_clo = Nothing + } + return (info, lit) + _ -> panic "isUnpackCStringClosure: not a lit" + StgCase (StgLit l) b _ [alt] + -- In -O0, we might get strings that haven't been floated to top-level, e.g., + -- case "undefined"# of sat { + -- __DEFAULT -> unpackCString# sat + -- } + -- This case is supposed to catch that. + | Just gen <- isUnpackCStringClosure (alt_rhs alt) + -> Just $ do + e <- cgLit l + addBindC (mkCgIdInfo b mkLFStringLit e) + gen + _ -> Nothing + where + is_string_unpack_op f + | idName f == unpackCStringName = Just mkRtsUnpackCStringLabel + | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label + | otherwise = Nothing + ------------------------------------------------------------------------ -- Non-top-level bindings ------------------------------------------------------------------------ @@ -363,7 +382,7 @@ -- args are all distinct local variables -- The "-1" is for fun_id -- Missed opportunity: (f x x) is not detected - , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs + , all (isGcPtrRep . idPrimRepU . fromNonVoid) fvs , isUpdatable upd_flag , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) , not (profileIsProfiling profile) @@ -372,7 +391,7 @@ -- thunk (e.g. its type) (#949) , idArity fun_id == unknownArity -- don't spoil a known call -- Ha! an Ap thunk - , not check_tags -- See Note [Tag inference debugging] + , not check_tags -- See Note [EPT enforcement debugging] = cgRhsStdThunk bndr lf_info payload where @@ -744,7 +763,8 @@ lbl | bh = mkBHUpdInfoLabel | otherwise = mkUpdInfoLabel - pushUpdateFrame lbl (CmmReg (CmmLocal node)) body + pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -752,7 +772,8 @@ ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf node - ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body } + ; pushOrigThunkInfoFrame closure_info + $ pushUpdateFrame mkBHUpdInfoLabel upd_closure body } else do {tickyUpdateFrameOmitted; body} } @@ -768,8 +789,7 @@ = do updfr <- getUpdFrameOff profile <- getProfile - let - hdr = fixedHdrSize profile + let hdr = fixedHdrSize profile frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- emitUpdateFrame (CmmStackSlot Old frame) lbl updatee @@ -788,6 +808,47 @@ initUpdFrameProf frame ----------------------------------------------------------------------------- +-- Original thunk info table frames +-- +-- Note [Original thunk info table frames] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In some debugging scenarios (e.g. when debugging cyclic thunks) it can be very +-- useful to know which thunks the program is in the process of evaluating. +-- However, in the case of updateable thunks this can be very difficult +-- to determine since the process of blackholing overwrites the thunk's +-- info table pointer. +-- +-- To help in such situations we provide the -forig-thunk-info flag. This enables +-- code generation logic which pushes a stg_orig_thunk_info_frame stack frame to +-- accompany each update frame. As the name suggests, this frame captures the +-- the original info table of the thunk being updated. The entry code for these +-- frames has no operational effects; the frames merely exist as breadcrumbs +-- for debugging. + +pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode () +pushOrigThunkInfoFrame closure_info body = do + cfg <- getStgToCmmConfig + if stgToCmmOrigThunkInfo cfg + then do_it + else body + where + orig_itbl = mkLblExpr (closureInfoLabel closure_info) + do_it = do + updfr <- getUpdFrameOff + profile <- getProfile + let platform = profilePlatform profile + hdr = fixedHdrSize profile + orig_info_frame_sz = + hdr + pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (profileConstants profile) + off_orig_info = hdr + pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (profileConstants profile) + frame_off = updfr + orig_info_frame_sz + frame = CmmStackSlot Old frame_off + -- + emitStore frame (mkLblExpr mkOrigThunkInfoLabel) + emitStore (cmmOffset platform frame off_orig_info) orig_itbl + withUpdFrameOff frame_off body + +----------------------------------------------------------------------------- -- Entering a CAF -- -- See Note [CAF management] in rts/sm/Storage.c @@ -800,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 diff --git a/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs --- a/GHC/StgToCmm/CgUtils.hs +++ b/GHC/StgToCmm/CgUtils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- @@ -15,6 +14,9 @@ get_Regtable_addr_from_offset, regTableOffset, get_GlobalReg_addr, + + -- * Streaming for CG + CgStream ) where import GHC.Prelude @@ -27,8 +29,24 @@ import GHC.Cmm.Utils import GHC.Cmm.CLabel import GHC.Utils.Panic +import GHC.Cmm.Dataflow.Label +import GHC.Data.Stream (Stream) +import GHC.Types.Unique.DSM (UniqDSMT) + -- ----------------------------------------------------------------------------- +-- Streaming + +-- | The Stream instantiation used for code generation. +-- Note the underlying monad is @UniqDSMT IO@, where @UniqDSMT@ is a transformer +-- that propagates a deterministic unique supply (essentially an incrementing +-- counter) from which new uniques are deterministically created during the +-- code generation stages following StgToCmm. +-- See Note [Object determinism]. +type CgStream = Stream (UniqDSMT IO) + + +-- ----------------------------------------------------------------------------- -- Information about global registers baseRegOffset :: Platform -> GlobalReg -> Int @@ -129,11 +147,11 @@ -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target. -fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl +fixStgRegisters :: Platform -> GenCmmDecl d h (GenCmmGraph CmmNode) -> GenCmmDecl d h (GenCmmGraph CmmNode) fixStgRegisters _ top@(CmmData _ _) = top fixStgRegisters platform (CmmProc info lbl live graph) = - let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph + let graph' = modifyGraph (mapGraphBlocks mapMap (fixStgRegBlock platform)) graph in CmmProc info lbl live graph' fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x @@ -153,7 +171,7 @@ in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg_use) src False -> CmmStore baseAddr src NaturallyAligned - where reg = globalRegUseGlobalReg reg_use + where reg = globalRegUse_reg reg_use other_stmt -> other_stmt fixExpr expr = case expr of @@ -166,7 +184,7 @@ -- 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 + let reg = globalRegUse_reg reg_use in case reg `elem` activeStgRegs platform of True -> expr False -> @@ -174,7 +192,7 @@ in case reg of BaseReg -> baseAddr _other -> CmmLoad baseAddr - (globalRegSpillType platform reg) + (globalRegUse_type reg_use) NaturallyAligned CmmRegOff greg@(CmmGlobal reg) offset -> @@ -184,7 +202,7 @@ -- 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 + case globalRegUse_reg reg `elem` activeStgRegs platform of True -> expr False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [ fixExpr (CmmReg greg), diff --git a/GHC/StgToCmm/Closure.hs b/GHC/StgToCmm/Closure.hs --- a/GHC/StgToCmm/Closure.hs +++ b/GHC/StgToCmm/Closure.hs @@ -18,8 +18,7 @@ module GHC.StgToCmm.Closure ( DynTag, tagForCon, isSmallFamily, - idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps, - argPrimRep, + idPrimRep1, idPrimRepU, isGcPtrRep, addIdReps, addArgReps, NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs, assertNonVoidIds, assertNonVoidStgArgs, @@ -94,13 +93,12 @@ import GHC.Types.Basic import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Maybe (isNothing) import Data.Coerce (coerce) import qualified Data.ByteString.Char8 as BS8 import GHC.StgToCmm.Config -import GHC.Stg.InferTags.TagSig (isTaggedSig) +import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) ----------------------------------------------------------------------------- -- Data types and synonyms @@ -161,13 +159,13 @@ coerce ids nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] -nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))] +nonVoidStgArgs args = [NonVoid arg | arg <- args, not (null (stgArgRep arg))] -- | Used in places where some invariant ensures that all these arguments are -- non-void; e.g. constructor arguments. -- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise". assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg] -assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $ +assertNonVoidStgArgs args = assert (not (any (null . stgArgRep) args)) $ coerce args @@ -177,29 +175,27 @@ -- Why are these here? --- | Assumes that there is precisely one 'PrimRep' of the type. This assumption +-- | Assumes that there is at most one 'PrimRep' of the type. This assumption -- holds after unarise. --- See Note [Post-unarisation invariants] -idPrimRep :: Id -> PrimRep -idPrimRep id = typePrimRep1 (idType id) - -- See also Note [VoidRep] in GHC.Types.RepType +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. +-- See Note [VoidRep] in GHC.Types.RepType. +idPrimRep1 :: Id -> PrimOrVoidRep +idPrimRep1 id = typePrimRep1 (idType id) +idPrimRepU :: Id -> PrimRep +idPrimRepU id = typePrimRepU (idType id) + -- | Assumes that Ids have one PrimRep, which holds after unarisation. --- See Note [Post-unarisation invariants] +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)] addIdReps = map (\id -> let id' = fromNonVoid id - in NonVoid (idPrimRep id', id')) + in NonVoid (idPrimRepU id', id')) -- | Assumes that arguments have one PrimRep, which holds after unarisation. --- See Note [Post-unarisation invariants] +-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise. addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)] addArgReps = map (\arg -> let arg' = fromNonVoid arg - in NonVoid (argPrimRep arg', arg')) - --- | Assumes that the argument has one PrimRep, which holds after unarisation. --- See Note [Post-unarisation invariants] -argPrimRep :: StgArg -> PrimRep -argPrimRep arg = typePrimRep1 (stgArgType arg) + in NonVoid (stgArgRepU arg', arg')) ------------------------------------------------------ -- Building LambdaFormInfo @@ -512,8 +508,8 @@ -- or constructor), so just return it. | InferedReturnIt -- A properly tagged value, as determined by tag inference. - -- See Note [Tag Inference] and Note [Tag inference passes] in - -- GHC.Stg.InferTags. + -- See Note [Evaluated and Properly Tagged] + -- and Note [EPT enforcement] in GHC.Stg.EnforceEpt. -- It behaves /precisely/ like `ReturnIt`, except that when debugging is -- enabled we emit an extra assertion to check that the returned value is -- properly tagged. We can use this as a check that tag inference is working @@ -587,8 +583,8 @@ n_args _cg_loc _self_loop_info | Just sig <- idTagSig_maybe id - , isTaggedSig sig -- Infered to be already evaluated by Tag Inference - , n_args == 0 -- See Note [Tag Inference] + , isTaggedSig sig -- Infered to be already evaluated by EPT analysis + , n_args == 0 -- See Note [EPT enforcement] = InferedReturnIt | is_fun -- it *might* be a function, so we must "call" it (which is always safe) @@ -625,12 +621,12 @@ getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info | n_args == 0 , Just sig <- idTagSig_maybe id - , isTaggedSig sig -- Infered to be already evaluated by Tag Inference + , isTaggedSig sig -- Infered to be already evaluated by EPT analysis -- When profiling we must enter all potential functions to make sure we update the SCC -- even if the function itself is already evaluated. -- See Note [Evaluating functions with profiling] in rts/Apply.cmm , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function) - = InferedReturnIt -- See Note [Tag Inference] + = InferedReturnIt -- See Note [EPT enforcement] | might_be_a_function = SlowCall diff --git a/GHC/StgToCmm/Config.hs b/GHC/StgToCmm/Config.hs --- a/GHC/StgToCmm/Config.hs +++ b/GHC/StgToCmm/Config.hs @@ -46,10 +46,10 @@ ---------------------------------- Flags -------------------------------------- , stgToCmmLoopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) , stgToCmmAlignCheck :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@) - , stgToCmmOptHpc :: !Bool -- ^ perform code generation for code coverage , stgToCmmFastPAPCalls :: !Bool -- ^ , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled , stgToCmmEagerBlackHole :: !Bool -- ^ + , stgToCmmOrigThunkInfo :: !Bool -- ^ Push @stg_orig_thunk_info@ frames during thunk update. , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See Note [Mapping Info Tables to Source Positions] , stgToCmmInfoTableMapWithFallback :: !Bool -- ^ Include info tables with fallback source locations in the info table map , stgToCmmInfoTableMapWithStack :: !Bool -- ^ Include info tables for STACK closures in the info table map @@ -62,14 +62,20 @@ , stgToCmmDoBoundsCheck :: !Bool -- ^ decides whether to check array bounds in StgToCmm.Prim -- or not , stgToCmmDoTagCheck :: !Bool -- ^ Verify tag inference predictions. + , stgToCmmObjectDeterminism :: !Bool -- ^ Enable deterministic code generation (more precisely, the deterministic unique-renaming pass in StgToCmm) ------------------------------ Backend Flags ---------------------------------- - , stgToCmmAllowBigArith :: !Bool -- ^ Allowed to emit larger than native size arithmetic (only LLVM and C backends) + , stgToCmmAllowArith64 :: !Bool -- ^ Allowed to emit 64-bit arithmetic operations + , stgToCmmAllowQuot64 :: !Bool -- ^ Allowed to emit 64-bit division operations , stgToCmmAllowQuotRemInstr :: !Bool -- ^ Allowed to generate QuotRem instructions , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction + , stgToCmmAllowWordMul2Instr :: !Bool -- ^ Allowed to generate WordMul2 instruction , stgToCmmAllowFMAInstr :: FMASign -> Bool -- ^ Allowed to generate FMA instruction + , stgToCmmAllowIntWord64X2MinMax :: !Bool -- ^ Allowed to generate min/max instructions for Int64X2/Word64X2 , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. + , stgToCmmSaveFCallTargetToLocal :: !Bool -- ^ Save a foreign call target to a Cmm local, see + -- Note [Saving foreign call target to local] for details ------------------------------ SIMD flags ------------------------------------ -- Each of these flags checks vector compatibility with the backend requested -- during compilation. In essence, this means checking for @-fllvm@ which is diff --git a/GHC/StgToCmm/DataCon.hs b/GHC/StgToCmm/DataCon.hs --- a/GHC/StgToCmm/DataCon.hs +++ b/GHC/StgToCmm/DataCon.hs @@ -19,6 +19,7 @@ import GHC.Platform +import GHC.Stg.Utils (allowTopLevelConApp) import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -45,11 +46,9 @@ import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) -import Control.Monad import Data.Char import GHC.StgToCmm.Config (stgToCmmPlatform) import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn) @@ -91,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 @@ -336,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 @@ -367,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 diff --git a/GHC/StgToCmm/Env.hs b/GHC/StgToCmm/Env.hs --- a/GHC/StgToCmm/Env.hs +++ b/GHC/StgToCmm/Env.hs @@ -10,7 +10,7 @@ module GHC.StgToCmm.Env ( CgIdInfo, - litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, + mkCgIdInfo, litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit, idInfoToAmode, addBindC, addBindsC, @@ -43,7 +43,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Builtin.Names (getUnique) @@ -206,4 +205,4 @@ -- about accidental collision idToReg platform (NonVoid id) = LocalReg (idUnique id) - (primRepCmmType platform (idPrimRep id)) + (primRepCmmType platform (idPrimRepU id)) diff --git a/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs --- a/GHC/StgToCmm/Expr.hs +++ b/GHC/StgToCmm/Expr.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} @@ -37,7 +35,7 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info -import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) +import GHC.Cmm.Utils ( cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -53,12 +51,11 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Control.Monad ( unless, void ) import Control.Arrow ( first ) import Data.List ( partition ) -import GHC.Stg.InferTags.TagSig (isTaggedSig) +import GHC.Stg.EnforceEpt.TagSig (isTaggedSig) import GHC.Platform.Profile (profileIsProfiling) ------------------------------------------------------------------------ @@ -69,60 +66,51 @@ 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 +cgExpr (StgOpApp (StgPrimOp DataToTagSmallOp) [StgVarArg a] _res_ty) = do + platform <- getPlatform + emitComment (mkFastString "dataToTagSmall#") --- dataToTag# :: a -> Int# --- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold --- TODO: There are some more optimization ideas for this code path --- in #21710 -cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + tag1 = cmmConstrTag1 platform a_eval_expr + + -- subtract 1 because we need to return a zero-indexed tag + emitReturn [cmmSubWord platform tag1 (CmmLit $ mkWordCLit platform 1)] + +-- dataToTagLarge# :: a_levpoly -> Int# +-- See Note [DataToTag overview] in GHC.Tc.Instance.Class, +-- particularly wrinkles H3 and DTW4 +cgExpr (StgOpApp (StgPrimOp DataToTagLargeOp) [StgVarArg a] _res_ty) = do platform <- getPlatform - emitComment (mkFastString "dataToTag#") - info <- getCgIdInfo a - let amode = idInfoToAmode info - tag_reg <- assignTemp $ cmmConstrTag1 platform amode + emitComment (mkFastString "dataToTagLarge#") + + a_eval_reg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [a_eval_reg] False) (cgIdApp a []) + let a_eval_expr = CmmReg (CmmLocal a_eval_reg) + + tag1_reg <- assignTemp $ cmmConstrTag1 platform a_eval_expr result_reg <- newTemp (bWord platform) - let tag = CmmReg $ CmmLocal tag_reg - is_tagged = cmmNeWord platform tag (zeroExpr platform) - is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform) - -- Here we will first check the tag bits of the pointer we were given; - -- if this doesn't work then enter the closure and use the info table - -- to determine the constructor. Note that all tag bits set means that - -- the constructor index is too large to fit in the pointer and therefore - -- we must look in the info table. See Note [Tagging big families]. + let tag1_expr = CmmReg $ CmmLocal tag1_reg + is_too_big_tag = cmmEqWord platform tag1_expr (cmmTagMask platform) - (fast_path :: CmmAGraph) <- getCode $ do - -- Return the constructor index from the pointer tag - return_ptr_tag <- getCode $ do - emitAssign (CmmLocal result_reg) - $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1) - -- Return the constructor index recorded in the info table - return_info_tag <- getCode $ do - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform amode) + -- Return the constructor index from the pointer tag + -- (Used if pointer tag is small enough to be unambiguous) + return_ptr_tag <- getCode $ do + emitAssign (CmmLocal result_reg) + $ cmmSubWord platform tag1_expr (CmmLit $ mkWordCLit platform 1) - emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - -- If we know the argument is already tagged there is no need to generate code to evaluate it - -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow - -- path which evaluates the argument before fetching the tag. - case (idTagSig_maybe a) of - Just sig - | isTaggedSig sig - -> emit fast_path - _ -> do - slow_path <- getCode $ do - tmp <- newTemp (bWord platform) - _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) - profile <- getProfile - align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig - emitAssign (CmmLocal result_reg) - $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp))) - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + -- Return the constructor index recorded in the info table + return_info_tag <- getCode $ do + profile <- getProfile + align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig + emitAssign (CmmLocal result_reg) + $ getConstrTag profile align_check (cmmUntag platform a_eval_expr) + + emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) emitReturn [CmmReg $ CmmLocal result_reg] @@ -189,7 +177,7 @@ cgLetNoEscapeRhs join_id local_cc bndr rhs = do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs - ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info + ; let (bid, _) = expectJust $ maybeLetNoEscape info ; let code = do { (_, body) <- getCodeScoped rhs_code ; emitOutOfLine bid (first (<*> mkBranch join_id) body) } ; return (info, code) @@ -240,6 +228,8 @@ the case forces an evaluation, or if there is a primitive op which can trigger GC. +NB: things are not settled here: see #8326. + A more interesting situation is this (a Plan-B situation) !P!; @@ -447,25 +437,53 @@ Note [Dead-binder optimisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A case-binder, or data-constructor argument, may be marked as dead, -because we preserve occurrence-info on binders in GHC.Core.Tidy (see +Consider: + + case x of (y, z) -> rhs + +where `z` is unused in `rhs`. When we return form the eval of `x`, +GHC.StgToCmm.DataCon.bindConArgs will generate some loads, assuming the the +value of `x` is returned in R1: + y := R1[1] + z := R1[2] + +If `z` is never used, the load `z := R1[2]` is a waste of a memory operation. +CmmSink (which sinks loads to their usage sites, if any) will eliminate the dead +load; but + 1. CmmSink only runs with -O + 2. It would save CmmSink work if we simply did not generate the load in the + first place. + +Hence STG uses dead-binder information, in `bindConArgs` to drop dead loads. +That's why we preserve occurrence-info on binders in GHC.Core.Tidy (see GHC.Core.Tidy.tidyIdBndr). -If the binder is dead, we can sometimes eliminate a load. While -CmmSink will eliminate that load, it's very easy to kill it at source -(giving CmmSink less work to do), and in any case CmmSink only runs -with -O. Since the majority of case binders are dead, this -optimisation probably still has a great benefit-cost ratio and we want -to keep it for -O0. See also Phab:D5358. +So it's important that deadness is accurate. But StgCse can invalidate it +(#14895 #24233). Here is an example: -This probably also was the reason for occurrence hack in Phab:D5339 to -exist, perhaps because the occurrence information preserved by -'GHC.Core.Tidy.tidyIdBndr' was insufficient. But now that CmmSink does the -job we deleted the hacks. + map_either :: (a -> b) -> Either String a -> Either String b + map_either = \f e -> case e of b { + Right x -> Right (f x) + Left x -> Left x + } + + The case-binder "b" is dead (not used in the rhss of the alternatives). + StgCse notices that `Left x` doesn't need to be allocated as we can reuse `b`, + and we get: + + map_either :: (a -> b) -> Either String a -> Either String b + map_either = \f e -> case e of b { -- b no longer dead! + Right x -> Right (f x) + Left x -> b + } + +For now StgCse simply zaps occurrence information on case binders. A more +accurate update would complexify the implementation and doesn't seem worth it. + -} cgCase (StgApp v []) _ (PrimAlt _) alts - | isVoidRep (idPrimRep v) -- See Note [Scrutinising VoidRep] + | isZeroBitTy (idType v) -- See Note [Scrutinising VoidRep] , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts = cgExpr rhs @@ -499,9 +517,9 @@ ; _ <- bindArgToReg (NonVoid bndr) ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts } where - reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr) + reps_compatible platform = primRepCompatible platform (idPrimRepU v) (idPrimRepU bndr) - pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id)) + pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRepU id)) {- Note [Dodgy unsafeCoerce 2, #3132] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -526,26 +544,57 @@ ; return AssignedDirectly } -{- Note [Handle seq#] -~~~~~~~~~~~~~~~~~~~~~ -See Note [seq# magic] in GHC.Core.Opt.ConstantFold. -The special case for seq# in cgCase does this: +{- +Note [Eliminate trivial Solo# continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have code like this: - case seq# a s of v - (# s', a' #) -> e -==> - case a of v - (# s', a' #) -> e + case scrut of bndr { + alt -> Solo# bndr + } -(taking advantage of the fact that the return convention for (# State#, a #) -is the same as the return convention for just 'a') +The RHS of the only branch does nothing except wrap the case-binder +returned by 'scrut' in a unary unboxed tuple. But unboxed tuples +don't exist at run-time, i.e. the branch is a no-op! So we can +generate code as if we just had 'scrut' instead of a case-expression. + +This situation can easily arise for IO or ST code, where the last +operation a function performs is commonly 'pure $! someExpr'. +See also #24264 and !11778. More concretely, as of December 2023, +when building a stage2 "perf+no_profiled_libs" ghc: + + * The special case is reached 398 times. + * Of these, 158 have scrutinees that call a function or enter a + potential thunk, and would need to push a useless stack frame if + not for this optimisation. + +We might consider rewriting such case expressions in GHC.Stg.CSE as a +slight extension of Note [All alternatives are the binder]. But the +RuntimeReps of 'bndr' and 'Solo# bndr' are not exactly the same, and +per Note [Typing the STG language] in GHC.Stg.Lint, we do expect Stg +code to remain RuntimeRep-correct. So we just detect the situation in +StgToCmm instead. + +Crucially, the return conventions for 'ty' and '(# ty #)' are compatible: +The returned value is passed in the same register(s) or stack slot in +both conventions, and the set of allowed return values for 'ty' +is a subset of the allowed return values for '(# ty #)': + + * For a lifted type 'ty', the return convention for 'ty' promises to + return an evaluated-properly-tagged heap pointer, while a return + type '(# ty #)' only promises to return a heap pointer to an object + that can be evaluated later if need be. + + * If 'ty' is unlifted, the allowed return + values for 'ty' and '(# ty #)' are identical. -} -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 +cgCase scrut bndr _alt_type [GenStgAlt { alt_rhs = rhs}] + -- see Note [Eliminate trivial Solo# continuations] + | StgConApp dc _ [StgVarArg v] _ <- rhs + , isUnboxedTupleDataCon dc + , v == bndr + = cgExpr scrut cgCase scrut bndr alt_type alts = -- the general case @@ -578,20 +627,10 @@ {- Note [GC for conditionals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For boolean conditionals it seems that we have always done NoGcInAlts. -That is, we have always done the GC check before the conditional. -This is enshrined in the special case for - case tagToEnum# (a>b) of ... -See Note [case on bool] - -It's odd, and it's flagrantly inconsistent with the rules described -Note [Compiling case expressions]. However, after eliminating the -tagToEnum# (#13397) we will have: - case (a>b) of ... -Rather than make it behave quite differently, I am testing for a -comparison operator here in the general case as well. - -ToDo: figure out what the Right Rule should be. +For comparison operators (`is_cmp_op`) it seems that we have always done +NoGcInAlts. It's odd, and it's flagrantly inconsistent with the rules described +Note [Compiling case expressions]. However, that's the way it has been for ages +(there was some long-gone history involving tagToEnum#; see #13397, #8317, #8326). Note [scrut sequel] ~~~~~~~~~~~~~~~~~~~ @@ -639,8 +678,10 @@ isSimpleOp :: StgOp -> [StgArg] -> FCode Bool -- True iff the op cannot block or allocate isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe) --- dataToTag# evaluates its argument, see Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold -isSimpleOp (StgPrimOp DataToTagOp) _ = return False +-- dataToTagSmall#/dataToTagLarge# evaluate an argument; +-- see Note [DataToTag overview] in GHC.Tc.Instance.Class +isSimpleOp (StgPrimOp DataToTagSmallOp) _ = return False +isSimpleOp (StgPrimOp DataToTagLargeOp) _ = return False isSimpleOp (StgPrimOp op) stg_args = do arg_exprs <- getNonVoidArgAmodes stg_args cfg <- getStgToCmmConfig @@ -687,7 +728,9 @@ ; tagged_cmms <- cgAltRhss gc_plan bndr alts ; let bndr_reg = CmmLocal (idToReg platform bndr) - (DEFAULT,deflt) = head tagged_cmms + deflt = case tagged_cmms of + (DEFAULT,deflt):_ -> deflt + _ -> panic "cgAlts PrimAlt" -- PrimAlts always have a DEFAULT case -- and it always comes first @@ -851,6 +894,7 @@ -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like @@ -1027,7 +1071,7 @@ (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) fun - EnterIt -> assert (null args) $ -- Discarding arguments + EnterIt -> assertPpr (null args) (ppr fun_id $$ ppr args) $ -- Discarding arguments emitEnter fun SlowCall -> do -- A slow function call via the RTS apply routines diff --git a/GHC/StgToCmm/ExtCode.hs b/GHC/StgToCmm/ExtCode.hs --- a/GHC/StgToCmm/ExtCode.hs +++ b/GHC/StgToCmm/ExtCode.hs @@ -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) diff --git a/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs --- a/GHC/StgToCmm/Foreign.hs +++ b/GHC/StgToCmm/Foreign.hs @@ -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) @@ -277,23 +264,83 @@ load_target_into_temp other_target@(PrimTarget _) = return other_target +-- Note [Saving foreign call target to local] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- What we want to do here is create a new temporary for the foreign -- call argument if it is not safe to use the expression directly, -- because the expression mentions caller-saves GlobalRegs (see -- Note [Register parameter passing]). -- -- However, we can't pattern-match on the expression here, because --- this is used in a loop by GHC.Cmm.Parser, and testing the expression --- results in a black hole. So we always create a temporary, and rely --- on GHC.Cmm.Sink to clean it up later. (Yuck, ToDo). The generated code --- ends up being the same, at least for the RTS .cmm code. +-- this is used in a loop by GHC.Cmm.Parser, and testing the +-- expression results in a black hole. So when there exist +-- caller-saves GlobalRegs, we create a temporary, and rely on +-- GHC.Cmm.Sink to clean it up later. The generated code ends up being +-- the same if -fcmm-sink is enabled (implied by -O). -- +-- When there doesn't exist caller-save GlobalRegs, keep the original +-- target in place. This matters for the wasm backend, otherwise it +-- cannot infer the target symbol's correct foreign function type in +-- unoptimized Cmm. For instance: +-- +-- foreign import ccall unsafe "foo" c_foo :: IO () +-- +-- Without optimization, previously this would lower to something like: +-- +-- [Test.c_foo_entry() { // [] +-- { [] +-- } +-- {offset +-- cDk: +-- goto cDm; +-- cDm: +-- _cDj::I32 = foo; +-- call "ccall" arg hints: [] result hints: [] (_cDj::I32)(); +-- R1 = GHC.Tuple.()_closure+1; +-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4; +-- } +-- }, +-- +-- The wasm backend only sees "foo" being assigned to a local, but +-- there's no type signature associated with a CLabel! So it has to +-- emit a dummy .functype directive and fingers crossed that wasm-ld +-- tolerates function type mismatch. THis is horrible, not future +-- proof against upstream toolchain upgrades, and already known to +-- break in certain cases (e.g. when LTO objects are involved). +-- +-- Therefore, on wasm as well as other targets that don't risk +-- mentioning caller-saved GlobalRegs in a foreign call target, just +-- keep the original call target in place and don't assign it to a +-- local. So this would now lower to something like: +-- +-- [Test.c_foo_entry() { // [] +-- { [] +-- } +-- {offset +-- cDo: +-- goto cDq; +-- cDq: +-- call "ccall" arg hints: [] result hints: [] foo(); +-- R1 = GHC.Tuple.()_closure+1; +-- call (I32[P32[Sp]])(R1) args: 4, res: 0, upd: 4; +-- } +-- }, +-- +-- Since "foo" appears at call site directly, the wasm backend would +-- now be able to infer its type signature correctly. + maybe_assign_temp :: CmmExpr -> FCode CmmExpr maybe_assign_temp e = do - platform <- getPlatform - reg <- newTemp (cmmExprType platform e) - emitAssign (CmmLocal reg) e - return (CmmReg (CmmLocal reg)) + do_save <- stgToCmmSaveFCallTargetToLocal <$> getStgToCmmConfig + if do_save + then do + platform <- getPlatform + reg <- newTemp (cmmExprType platform e) + emitAssign (CmmLocal reg) e + return (CmmReg (CmmLocal reg)) + else + pure e -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO @@ -308,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) @@ -344,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 @@ -381,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) @@ -399,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 @@ -447,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 @@ -480,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) @@ -545,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 @@ -673,7 +720,7 @@ -- Precondition: args and typs have the same length -- See Note [Unlifted boxed arguments to foreign calls] getFCallArgs args typ - = do { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ)) + = do { mb_cmms <- mapM get (zipEqual args (collectStgFArgTypes typ)) ; return (catMaybes mb_cmms) } where get (arg,typ) diff --git a/GHC/StgToCmm/Hpc.hs b/GHC/StgToCmm/Hpc.hs --- a/GHC/StgToCmm/Hpc.hs +++ b/GHC/StgToCmm/Hpc.hs @@ -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 ..] - ] - diff --git a/GHC/StgToCmm/InfoTableProv.hs b/GHC/StgToCmm/InfoTableProv.hs --- a/GHC/StgToCmm/InfoTableProv.hs +++ b/GHC/StgToCmm/InfoTableProv.hs @@ -6,7 +6,6 @@ #if defined(HAVE_LIBZSTD) import Foreign.C.Types -import Foreign.Marshal.Utils (copyBytes) import qualified Data.ByteString.Internal as BSI import GHC.IO (unsafePerformIO) #endif @@ -14,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(..)) @@ -71,22 +71,34 @@ 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 - (cg_ipes, strtab) = flip runState emptyStringTable $ do - module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod) - mapM (toCgIPE platform ctx module_name) ents + ((cg_ipes, unit_id, module_name), strtab) = flip runState emptyStringTable $ do + unit_id <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleName this_mod) + module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr $ moduleUnit this_mod) + cg_ipes <- mapM (toCgIPE platform ctx) ents + return (cg_ipes, unit_id, module_name) tables :: [CmmStatic] tables = map (CmmStaticLit . CmmLabel . ipeInfoTablePtr) cg_ipes @@ -137,6 +149,12 @@ -- 'string_table_size' field (decompressed size) , int $ BS.length uncompressed_strings + + -- 'module_name' field + , CmmInt (fromIntegral module_name) W32 + + -- 'unit_id' field + , CmmInt (fromIntegral unit_id) W32 ] -- Emit the list of info table pointers @@ -159,6 +177,8 @@ (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 :: ByteOrder -- ^ Byte order to write the data in @@ -171,13 +191,11 @@ to_ipe_buf_ent :: CgInfoProvEnt -> [Word32] to_ipe_buf_ent cg_ipe = [ ipeTableName cg_ipe - , ipeClosureDesc cg_ipe + , fromIntegral $ ipeClosureDesc cg_ipe , ipeTypeDesc cg_ipe , ipeLabel cg_ipe - , ipeModuleName cg_ipe , ipeSrcFile cg_ipe , ipeSrcSpan cg_ipe - , 0 -- padding ] word32Builder :: Word32 -> BSB.Builder @@ -185,10 +203,9 @@ BigEndian -> BSB.word32BE LittleEndian -> BSB.word32LE -toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt -toCgIPE platform ctx module_name ipe = do +toCgIPE :: Platform -> SDocContext -> InfoProvEnt -> State StringTable CgInfoProvEnt +toCgIPE platform ctx ipe = do table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe)) - closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe) type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe) let (src_loc_file, src_loc_span) = @@ -203,10 +220,9 @@ src_span <- lookupStringTable $ ST.pack src_loc_span return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe , ipeTableName = table_name - , ipeClosureDesc = closure_desc + , ipeClosureDesc = fromIntegral (infoProvEntClosureType ipe) , ipeTypeDesc = type_desc , ipeLabel = label - , ipeModuleName = module_name , ipeSrcFile = src_file , ipeSrcSpan = src_span } @@ -214,10 +230,9 @@ data CgInfoProvEnt = CgInfoProvEnt { ipeInfoTablePtr :: !CLabel , ipeTableName :: !StrTabOffset - , ipeClosureDesc :: !StrTabOffset + , ipeClosureDesc :: !Word32 , ipeTypeDesc :: !StrTabOffset , ipeLabel :: !StrTabOffset - , ipeModuleName :: !StrTabOffset , ipeSrcFile :: !StrTabOffset , ipeSrcSpan :: !StrTabOffset } diff --git a/GHC/StgToCmm/Layout.hs b/GHC/StgToCmm/Layout.hs --- a/GHC/StgToCmm/Layout.hs +++ b/GHC/StgToCmm/Layout.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- @@ -26,7 +25,7 @@ mkVirtConstrSizes, getHpRelOffset, - ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep + ArgRep(..), toArgRep, toArgRepOrV, idArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep getArgAmode, getNonVoidArgAmodes ) where @@ -50,7 +49,7 @@ import GHC.Cmm.CLabel import GHC.Stg.Syntax import GHC.Types.Id -import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) +import GHC.Core.TyCon ( PrimRep(..), PrimOrVoidRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Platform import GHC.Platform.Profile @@ -60,12 +59,12 @@ import Data.List (mapAccumL, partition) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Data.FastString import Control.Monad import GHC.StgToCmm.Config (stgToCmmPlatform) import GHC.StgToCmm.Types +import Data.List.NonEmpty (nonEmpty) ------------------------------------------------------------------------ -- Call and return sequences @@ -329,10 +328,10 @@ platform <- profilePlatform <$> getProfile mapM (getArgRepAmode platform) args where getArgRepAmode platform arg - | V <- rep = return (V, Nothing) - | otherwise = do expr <- getArgAmode (NonVoid arg) - return (rep, Just expr) - where rep = toArgRep platform (argPrimRep arg) + = case stgArgRep1 arg of + VoidRep -> return (V, Nothing) + NVRep rep -> do expr <- getArgAmode (NonVoid arg) + return (toArgRep platform rep, Just expr) nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = [] @@ -378,19 +377,28 @@ -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] -slowArgs _ [] _ = mempty slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V), but args does not - | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled - | otherwise = this_pat ++ slowArgs platform rest_args sccProfilingEnabled - where - (arg_pat, n) = slowCallPattern (map fst args) - (call_args, rest_args) = splitAt n args + = case nonEmpty args of + Nothing -> mempty + Just args1 + | sccProfilingEnabled -> save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled + | otherwise -> this_pat ++ slowArgs platform rest_args sccProfilingEnabled + where + (arg_pat, n) = slowCallPattern (fmap fst args) + (call_args, rest_args) = splitAt n args - stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat - this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args - save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)] - save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs") + stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat + this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args + save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)] + save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit $ "stg_restore_cccs_" ++ arg_reps) + arg_reps = case maximum (fmap fst args1) of + V64 -> "v64" + V32 -> "v32" + V16 -> "v16" + _ -> "d" + + ------------------------------------------------------------------------- ---- Laying out objects on the heap and stack ------------------------------------------------------------------------- @@ -439,7 +447,6 @@ -- than the unboxed things mkVirtHeapOffsetsWithPadding profile header things = - assert (not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad @@ -521,13 +528,13 @@ -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes :: Profile -> [PrimRep] -> (WordOff, WordOff) mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = mkVirtConstrOffsets profile - (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) + (map (\nv_rep -> NonVoid (nv_rep, ())) field_reps) ------------------------------------------------------------------------- -- @@ -604,12 +611,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, -- so the result list may be shorter than the argument list -getNonVoidArgAmodes [] = return [] -getNonVoidArgAmodes (arg:args) - | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode (NonVoid arg) - ; amodes <- getNonVoidArgAmodes args - ; return ( amode : amodes ) } +getNonVoidArgAmodes args = mapM getArgAmode (nonVoidStgArgs args) ------------------------------------------------------------------------- -- diff --git a/GHC/StgToCmm/Lit.hs b/GHC/StgToCmm/Lit.hs --- a/GHC/StgToCmm/Lit.hs +++ b/GHC/StgToCmm/Lit.hs @@ -51,8 +51,7 @@ CmmLit <$> newByteStringCLit s -- not unpackFS; we want the UTF-8 byte stream. cgLit (LitRubbish _ rep) = - case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- ditto + case expectOnly prim_reps of -- Note [Post-unarisation invariants] BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do @@ -98,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) - diff --git a/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/GHC/StgToCmm/Monad.hs @@ -73,7 +73,6 @@ import GHC.StgToCmm.Config import GHC.StgToCmm.Closure import GHC.StgToCmm.Sequel -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -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,29 +781,39 @@ 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 + -- we must be careful to: + -- 1. not emit a proc label twice (#22792) + -- 2. emit it at least once! (#25565) + -- + -- (2) happened because the entry label was the label of a basic + -- block that got dropped (empty basic block...), hence we never + -- generated a label for it after we fixed (1) where we were + -- always emitting entry label. + proc_lbl = toProcDelimiterLbl lbl + proc_block = CmmProc tinfo proc_lbl live blks + ; 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 +889,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) } diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/GHC/StgToCmm/Prim.hs @@ -1,2662 +1,2973 @@ {-# 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 GHC.Utils.Panic.Plain -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 --- know 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 - --- 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 - --- 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 allowExtAdd - 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 - DataToTagOp -> 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 :: [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 - - 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. - _ | stgToCmmAllowBigArith 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 - ReturnsPrim VoidRep -> pure [] - ReturnsPrim rep - -> do reg <- newTemp (primRepCmmType platform rep) - pure [reg] - - ReturnsAlg tycon | isUnboxedTupleTyCon tycon - -> do (regs, _hints) <- newUnboxedTupleRegs res_ty - pure regs - - _ -> panic "cgOpApp" - 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 - - 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) - ------------------------------------------------------------------------------- --- Helpers for translating prefetching. - - --- | Translate byte array prefetch operations into proper primcalls. -doPrefetchByteArrayOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchByteArrayOp locality [addr,idx] - = do profile <- getProfile - mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx -doPrefetchByteArrayOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" - --- | Translate mutable byte array prefetch operations into proper primcalls. -doPrefetchMutableByteArrayOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchMutableByteArrayOp locality [addr,idx] - = do profile <- getProfile - mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx -doPrefetchMutableByteArrayOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" - --- | Translate address prefetch operations into proper primcalls. -doPrefetchAddrOp ::Int - -> [CmmExpr] - -> FCode () -doPrefetchAddrOp locality [addr,idx] - = mkBasicPrefetch locality 0 addr idx -doPrefetchAddrOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp" - --- | Translate value prefetch operations into proper primcalls. -doPrefetchValueOp :: Int - -> [CmmExpr] - -> FCode () -doPrefetchValueOp locality [addr] - = do platform <- getPlatform - mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth platform))) -doPrefetchValueOp _ _ - = panic "GHC.StgToCmm.Prim: doPrefetchValueOp" - --- | helper to generate prefetch primcalls -mkBasicPrefetch :: Int -- Locality level 0-3 - -> ByteOff -- Initial offset in bytes - -> CmmExpr -- Base address - -> CmmExpr -- Index - -> FCode () -mkBasicPrefetch locality off base idx - = do platform <- getPlatform - emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx] - return () - --- ---------------------------------------------------------------------------- --- Allocating byte arrays - --- | Takes a register to return the newly allocated array in and the --- size of the new array in bytes. Allocates a new --- 'MutableByteArray#'. -doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () -doNewByteArrayOp res_r n = do - profile <- getProfile - platform <- getPlatform - - let info_ptr = mkLblExpr mkArrWords_infoLabel - rep = arrWordsRep platform n - - tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) - (zeroExpr platform) - - let hdr_size = fixedHdrSize profile - - base <- allocHeapClosure rep info_ptr (cccsExpr platform) - [ (mkIntExpr platform n, - hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) - ] - - emit $ mkAssign (CmmLocal res_r) base - --- ---------------------------------------------------------------------------- --- Comparing byte arrays - -doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do - profile <- getProfile - platform <- getPlatform - - whenCheckBounds $ ifNonZero n $ do - emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1) - emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2) - - ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off - ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off - - -- short-cut in case of equal pointers avoiding a costly - -- subroutine call to the memcmp(3) routine; the Cmm logic below - -- results in assembly code being generated for - -- - -- cmpPrefix10 :: ByteArray# -> ByteArray# -> Int# - -- cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10# - -- - -- that looks like - -- - -- leaq 16(%r14),%rax - -- leaq 16(%rsi),%rbx - -- xorl %ecx,%ecx - -- cmpq %rbx,%rax - -- je l_ptr_eq - -- - -- ; NB: the common case (unequal pointers) falls-through - -- ; the conditional jump, and therefore matches the - -- ; usual static branch prediction convention of modern cpus - -- - -- subq $8,%rsp - -- movq %rbx,%rsi - -- movq %rax,%rdi - -- movl $10,%edx - -- xorl %eax,%eax - -- call memcmp - -- addq $8,%rsp - -- movslq %eax,%rax - -- movq %rax,%rcx - -- l_ptr_eq: - -- movq %rcx,%rbx - -- jmp *(%rbp) - - l_ptr_eq <- newBlockId - l_ptr_ne <- newBlockId - - emit (mkAssign (CmmLocal res) (zeroExpr platform)) - emit (mkCbranch (cmmEqWord platform ba1_p ba2_p) - l_ptr_eq l_ptr_ne (Just False)) - - emitLabel l_ptr_ne - emitMemcmpCall res ba1_p ba2_p n 1 - - emitLabel l_ptr_eq - --- ---------------------------------------------------------------------------- --- Copying byte arrays - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'MutableByteArray#', an offset into the destination --- array, and the number of bytes to copy. Copies the given number of --- bytes from the source array to the destination array. -doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyByteArrayOp = emitCopyByteArray copy - where - -- Copy data (we assume the arrays aren't overlapping since - -- they're of different types) - copy _src _dst dst_p src_p bytes align = - emitCheckedMemcpyCall dst_p src_p bytes align - --- | Takes a source 'MutableByteArray#', an offset in the source --- array, a destination 'MutableByteArray#', an offset into the --- destination array, and the number of bytes to copy. Copies the --- given number of bytes from the source array to the destination --- array. -doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayOp = emitCopyByteArray copy - where - -- The only time the memory might overlap is when the two arrays - -- we were provided are the same array! - -- TODO: Optimize branch for common case of no aliasing. - copy src dst dst_p src_p bytes align = do - platform <- getPlatform - (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p bytes align) - (getCode $ emitMemcpyCall dst_p src_p bytes align) - emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall - --- | Takes a source 'MutableByteArray#', an offset in the source --- array, a destination 'MutableByteArray#', an offset into the --- destination array, and the number of bytes to copy. Copies the --- given number of bytes from the source array to the destination --- array. Assumes the two ranges are disjoint -doCopyMutableByteArrayNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayNonOverlappingOp = emitCopyByteArray copy - where - copy _src _dst dst_p src_p bytes align = do - emitCheckedMemcpyCall dst_p src_p bytes align - - -emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> Alignment -> FCode ()) - -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -emitCopyByteArray copy src src_off dst dst_off n = do - profile <- getProfile - platform <- getPlatform - - whenCheckBounds $ ifNonZero n $ do - emitRangeBoundsCheck src_off n (byteArraySize platform profile src) - emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst) - - let byteArrayAlignment = wordAlignment platform - srcOffAlignment = cmmExprAlignment src_off - dstOffAlignment = cmmExprAlignment dst_off - align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment] +{-# 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.List.NonEmpty (NonEmpty (..)) +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) -> opCallish (MO_VS_Quot n w) + (VecRemOp IntVec n w) -> opCallish (MO_VS_Rem n w) + (VecNegOp IntVec n w) -> opTranslate (MO_VS_Neg n w) + (VecMinOp IntVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_I64X2_Min + (VecMinOp IntVec n w) -> opTranslate (MO_VS_Min n w) + (VecMaxOp IntVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_I64X2_Max + (VecMaxOp IntVec n w) -> opTranslate (MO_VS_Max n w) + + (VecAddOp WordVec n w) -> opTranslate (MO_V_Add n w) + (VecSubOp WordVec n w) -> opTranslate (MO_V_Sub n w) + (VecMulOp WordVec n w) -> opTranslate (MO_V_Mul n w) + (VecDivOp WordVec _ _) -> \_ -> panic "unsupported primop" + (VecQuotOp WordVec n w) -> opCallish (MO_VU_Quot n w) + (VecRemOp WordVec n w) -> opCallish (MO_VU_Rem n w) + (VecNegOp WordVec _ _) -> \_ -> panic "unsupported primop" + (VecMinOp WordVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_W64X2_Min + (VecMinOp WordVec n w) -> opTranslate (MO_VU_Min n w) + (VecMaxOp WordVec 2 W64) + | not allowIntWord64X2MinMax -> opCallish MO_W64X2_Max + (VecMaxOp WordVec n w) -> opTranslate (MO_VU_Max n w) + + -- Vector FMA instructions + 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 -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem (wordWidth platform)) + else Right (genericIntQuotRemOp (wordWidth platform)) + + Int8QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W8) + else Right (genericIntQuotRemOp W8) + + Int16QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W16) + else Right (genericIntQuotRemOp W16) + + Int32QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_S_QuotRem W32) + else Right (genericIntQuotRemOp W32) + + WordQuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + 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 -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W8) + else Right (genericWordQuotRemOp W8) + + Word16QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + then Left (MO_U_QuotRem W16) + else Right (genericWordQuotRemOp W16) + + Word32QuotRemOp -> \args -> flip opCallishHandledLater args $ + if allowQuotRem && not (quotRemCanBeOptimized args) + 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 + 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 + AnnotateStackOp -> alwaysExternal + TraceEventOp -> alwaysExternal + TraceEventBinaryOp -> alwaysExternal + TraceMarkerOp -> alwaysExternal + SetThreadAllocationCounter -> alwaysExternal + SetOtherThreadAllocationCounter -> 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 + -- 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 + allowArith64 = stgToCmmAllowArith64 cfg + allowQuot64 = stgToCmmAllowQuot64 cfg + allowIntWord64X2MinMax = stgToCmmAllowIntWord64X2MinMax cfg + + -- a bit of a hack, for certain code generaters, e.g. PPC, and i386 we + -- continue to use the cmm versions of these functions instead of inline + -- 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< 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 + -- The type checker ensures that the indices have the correct length, + -- so we only need to check whether the indices are constants and within the valid range. + = case mapMaybe idx_maybe idxs of + is + | length is == len + -> emitAssign (CmmLocal res) (CmmMachOp (mo is) [v1,v2]) + | otherwise + -> pgmErrorDoc "Vector shuffle:" $ + vcat [ text "shuffle indices must be literals, 0 <= i <" <+> ppr (2 * len) ] + | otherwise + = pprPanic "doShuffleOp" $ + vcat [ text "non-vector argument type:" <+> ppr ty ] + 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. + + +-- | Translate byte array prefetch operations into proper primcalls. +doPrefetchByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchByteArrayOp locality [addr,idx] + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx +doPrefetchByteArrayOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" + +-- | Translate mutable byte array prefetch operations into proper primcalls. +doPrefetchMutableByteArrayOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchMutableByteArrayOp locality [addr,idx] + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx +doPrefetchMutableByteArrayOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" + +-- | Translate address prefetch operations into proper primcalls. +doPrefetchAddrOp ::Int + -> [CmmExpr] + -> FCode () +doPrefetchAddrOp locality [addr,idx] + = mkBasicPrefetch locality 0 addr idx +doPrefetchAddrOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp" + +-- | Translate value prefetch operations into proper primcalls. +doPrefetchValueOp :: Int + -> [CmmExpr] + -> FCode () +doPrefetchValueOp locality [addr] + = do platform <- getPlatform + mkBasicPrefetch locality 0 addr (CmmLit (CmmInt 0 (wordWidth platform))) +doPrefetchValueOp _ _ + = panic "GHC.StgToCmm.Prim: doPrefetchValueOp" + +-- | helper to generate prefetch primcalls +mkBasicPrefetch :: Int -- Locality level 0-3 + -> ByteOff -- Initial offset in bytes + -> CmmExpr -- Base address + -> CmmExpr -- Index + -> FCode () +mkBasicPrefetch locality off base idx + = do platform <- getPlatform + emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx] + return () + +-- ---------------------------------------------------------------------------- +-- Allocating byte arrays + +-- | Takes a register to return the newly allocated array in and the +-- size of the new array in bytes. Allocates a new +-- 'MutableByteArray#'. +doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () +doNewByteArrayOp res_r n = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr mkArrWords_infoLabel + rep = arrWordsRep platform n + + tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize profile + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) + [ (mkIntExpr platform n, + hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) + ] + + emit $ mkAssign (CmmLocal res_r) base + +-- ---------------------------------------------------------------------------- +-- Comparing byte arrays + +doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do + profile <- getProfile + platform <- getPlatform + + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1) + emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2) + + ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off + ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off + + -- short-cut in case of equal pointers avoiding a costly + -- subroutine call to the memcmp(3) routine; the Cmm logic below + -- results in assembly code being generated for + -- + -- cmpPrefix10 :: ByteArray# -> ByteArray# -> Int# + -- cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10# + -- + -- that looks like + -- + -- leaq 16(%r14),%rax + -- leaq 16(%rsi),%rbx + -- xorl %ecx,%ecx + -- cmpq %rbx,%rax + -- je l_ptr_eq + -- + -- ; NB: the common case (unequal pointers) falls-through + -- ; the conditional jump, and therefore matches the + -- ; usual static branch prediction convention of modern cpus + -- + -- subq $8,%rsp + -- movq %rbx,%rsi + -- movq %rax,%rdi + -- movl $10,%edx + -- xorl %eax,%eax + -- call memcmp + -- addq $8,%rsp + -- movslq %eax,%rax + -- movq %rax,%rcx + -- l_ptr_eq: + -- movq %rcx,%rbx + -- jmp *(%rbp) + + l_ptr_eq <- newBlockId + l_ptr_ne <- newBlockId + + emit (mkAssign (CmmLocal res) (zeroExpr platform)) + emit (mkCbranch (cmmEqWord platform ba1_p ba2_p) + l_ptr_eq l_ptr_ne (Just False)) + + emitLabel l_ptr_ne + emitMemcmpCall res ba1_p ba2_p n 1 + + emitLabel l_ptr_eq + +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes align = + emitCheckedMemcpyCall dst_p src_p bytes align + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes align = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p bytes align) + (getCode $ emitMemcpyCall dst_p src_p bytes align) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. Assumes the two ranges are disjoint +doCopyMutableByteArrayNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayNonOverlappingOp = emitCopyByteArray copy + where + copy _src _dst dst_p src_p bytes align = do + emitCheckedMemcpyCall dst_p src_p bytes align + + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> Alignment -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyByteArray copy src src_off dst dst_off n = do + profile <- getProfile + platform <- getPlatform + + whenCheckBounds $ ifNonZero n $ do + emitRangeBoundsCheck src_off n (byteArraySize platform profile src) + emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst) + + let byteArrayAlignment = wordAlignment platform + srcOffAlignment = cmmExprAlignment src_off + dstOffAlignment = cmmExprAlignment dst_off + align = minimum (byteArrayAlignment :| srcOffAlignment : dstOffAlignment : []) dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off copy src dst dst_p src_p n align diff --git a/GHC/StgToCmm/Prof.hs b/GHC/StgToCmm/Prof.hs --- a/GHC/StgToCmm/Prof.hs +++ b/GHC/StgToCmm/Prof.hs @@ -23,7 +23,7 @@ saveCurrentCostCentre, restoreCurrentCostCentre, -- Lag/drag/void stuff - ldvEnter, ldvEnterClosure, ldvRecordCreate + ldvEnter, ldvEnterClosure, profHeaderCreate ) where import GHC.Prelude @@ -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 @@ -88,14 +89,14 @@ -- | The profiling header words in a static closure staticProfHdr :: Profile -> CostCentreStack -> [CmmLit] staticProfHdr profile ccs - | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform] + | profileIsProfiling profile = [mkCCostCentreStack ccs, staticProfHeaderInit platform] | otherwise = [] where platform = profilePlatform profile -- | Profiling header words in a dynamic closure dynProfHdr :: Profile -> CmmExpr -> [CmmExpr] dynProfHdr profile ccs - | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)] + | profileIsProfiling profile = [ccs, dynProfInit (profilePlatform profile)] | otherwise = [] -- | Initialise the profiling field of an update frame @@ -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 @@ -322,34 +323,63 @@ ----------------------------------------------------------------------------- -- --- Lag/drag/void stuff +-- Profiling header stuff -- ----------------------------------------------------------------------------- --- --- Initial value for the LDV field in a static closure --- -staticLdvInit :: Platform -> CmmLit -staticLdvInit = zeroCLit --- --- Initial value of the LDV field in a dynamic closure --- +-- Header initialisation for static objects happens to coicincide for the +-- three uses of the header +-- * LDV profiling = 0 (era = 0, LDV_STATE_CREATE) +-- * Eras profiling = 0 (user_era = 0, ignored by profiler) +-- * Retainer profiling = 0 + +staticProfHeaderInit :: Platform -> CmmLit +staticProfHeaderInit plat = zeroCLit plat + + +-- Dynamic initialisation + +dynErasInit :: Platform -> CmmExpr +dynErasInit platform = loadUserEra platform + dynLdvInit :: Platform -> CmmExpr -dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit platform = +-- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr platform) [ CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))], CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) ] --- --- Initialise the LDV word of a new closure --- -ldvRecordCreate :: CmmExpr -> FCode () -ldvRecordCreate closure = do + +-- | If LDV profiling the user_era = 0 +-- , if eras profiling then (ldv)era = 0, so we can initialise correctly by OR the two expressions. +dynProfInit :: Platform -> CmmExpr +dynProfInit platform = CmmMachOp (mo_wordOr platform) [(dynLdvInit platform), dynErasInit platform] + + +-- | Initialise the profiling word of a new dynamic closure +-- * When LDV profiling is enabled (era > 0) - Initialise to the LDV word +-- * When eras profiling is enabled (user_era > 0) - Initialise to current user_era +profHeaderCreate :: CmmExpr -> FCode () +profHeaderCreate closure = do platform <- getPlatform - emit $ mkStore (ldvWord platform closure) (dynLdvInit platform) + let prof_header_wd = profHeaderWord platform closure + let check_ldv = mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) + let check_eras = mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadUserEra platform, CmmLit (zeroCLit platform)]) + -- Case 2: user_era > 0, eras profiling is enabled + check_1 <- check_eras (mkStore prof_header_wd (dynErasInit platform)) mkNop + -- Case 1: era > 0, LDV profiling is enabled + check_2 <- check_ldv (mkStore prof_header_wd (dynLdvInit platform)) check_1 + emit check_2 + + + + + + + -- -- | Called when a closure is entered, marks the closure as having -- been "used". The closure is not an "inherently used" one. The @@ -368,27 +398,35 @@ platform <- getPlatform let constants = platformConstants platform -- don't forget to subtract node's tag - ldv_wd = ldvWord platform cl_ptr + ldv_wd = profHeaderWord platform cl_ptr new_ldv_wd = cmmOrWord platform (cmmAndWord platform (cmmLoadBWord platform ldv_wd) (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants)))) (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) - ifProfiling $ - -- if (era > 0) { + ifProfiling $ do + -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) (mkStore ldv_wd new_ldv_wd) mkNop + + loadEra :: Platform -> CmmExpr loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) (cInt platform) NaturallyAligned] +loadUserEra :: Platform -> CmmExpr +loadUserEra platform = CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "user_era"))) + (bWord platform) + NaturallyAligned + -- | Takes the address of a closure, and returns --- the address of the LDV word in the closure -ldvWord :: Platform -> CmmExpr -> CmmExpr -ldvWord platform closure_ptr +-- the address of the prof header word in the closure (this is used to store LDV info, +-- retainer profiling info and eras profiling info). +profHeaderWord :: Platform -> CmmExpr -> CmmExpr +profHeaderWord platform closure_ptr = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform)) diff --git a/GHC/StgToCmm/TagCheck.hs b/GHC/StgToCmm/TagCheck.hs --- a/GHC/StgToCmm/TagCheck.hs +++ b/GHC/StgToCmm/TagCheck.hs @@ -31,8 +31,7 @@ import GHC.Core.DataCon import Control.Monad import GHC.StgToCmm.Types -import GHC.Utils.Panic (pprPanic) -import GHC.Utils.Panic.Plain (panic) +import GHC.Utils.Panic (pprPanic, panic) import GHC.Stg.Syntax import GHC.StgToCmm.Closure import GHC.Cmm.Switch (mkSwitchTargets) @@ -133,10 +132,10 @@ emitArgTagCheck info marks args = whenCheckTags $ do mod <- getModuleName let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args - arg_infos <- mapM getCgIdInfo cbv_args - let arg_cmms = map idInfoToAmode arg_infos - mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg) - zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms) + forM_ cbv_args $ \arg -> do + cginfo <- getCgIdInfo arg + let msg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg) + emitTagAssertion msg (idInfoToAmode cginfo) taggedCgInfo :: CgIdInfo -> Bool taggedCgInfo cg_info @@ -175,5 +174,4 @@ if taggedCgInfo info then return () else pprPanic "Arg not tagged as expected" (ppr msg <+> ppr arg) - diff --git a/GHC/StgToCmm/Ticky.hs b/GHC/StgToCmm/Ticky.hs --- a/GHC/StgToCmm/Ticky.hs +++ b/GHC/StgToCmm/Ticky.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- @@ -118,7 +117,7 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) +import GHC.StgToCmm.ArgRep ( slowCallPattern, toArgRepOrV, argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Config import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) @@ -587,7 +586,7 @@ tickyDirectCall arity args | args `lengthIs` arity = tickyKnownCallExact | otherwise = do tickyKnownCallExtraArgs - tickySlowCallPat (map argPrimRep (drop arity args)) + tickySlowCallPat (drop arity args) tickyKnownCallTooFewArgs :: FCode () tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") @@ -610,12 +609,12 @@ if isKnownFun lf_info then tickyKnownCallTooFewArgs else tickyUnknownCall - tickySlowCallPat (map argPrimRep args) + tickySlowCallPat args -tickySlowCallPat :: [PrimRep] -> FCode () +tickySlowCallPat :: [StgArg] -> FCode () tickySlowCallPat args = ifTicky $ do platform <- profilePlatform <$> getProfile - let argReps = map (toArgRep platform) args + let argReps = map (toArgRepOrV platform . stgArgRep1) args (_, n_matched) = slowCallPattern argReps if n_matched > 0 && args `lengthIs` n_matched then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps @@ -830,25 +829,34 @@ bumpTickyLit lhs = bumpTickyLitBy lhs 1 bumpTickyLitBy :: CmmLit -> Int -> FCode () -bumpTickyLitBy lhs n = do - platform <- getPlatform - emit (addToMem (bWord platform) (CmmLit lhs) n) +bumpTickyLitBy lhs n = emitAddToMem (CmmLit lhs) n bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode () -bumpTickyLitByE lhs e = do - platform <- getPlatform - emit (addToMemE (bWord platform) (CmmLit lhs) e) +bumpTickyLitByE lhs e = emitAddToMemE (CmmLit lhs) e bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do platform <- getPlatform let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1) - emit (addToMem (bWord platform) - (cmmIndexExpr platform + let addr = + cmmIndexExpr platform (wordWidth platform) (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl))) - (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform)))) - 1) + (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))) + emitAddToMem addr 1 + +emitAddToMem :: CmmExpr -> Int -> FCode () +emitAddToMem lhs n = do + platform <- getPlatform + emitAddToMemE lhs (mkIntExpr platform n) + +emitAddToMemE :: CmmExpr -> CmmExpr -> FCode () +emitAddToMemE lhs n = do + platform <- getPlatform + val <- newTemp (bWord platform) + emitAtomicRead MemOrderRelaxed val lhs + let val' = cmmOffsetExpr platform (CmmReg (CmmLocal val)) n + emitAtomicWrite MemOrderRelaxed lhs val' ------------------------------------------------------------------ -- Showing the "type category" for ticky-ticky profiling diff --git a/GHC/StgToCmm/Types.hs b/GHC/StgToCmm/Types.hs --- a/GHC/StgToCmm/Types.hs +++ b/GHC/StgToCmm/Types.hs @@ -22,7 +22,6 @@ import GHC.Utils.Outputable - {- Note [Conveying CAF-info and LFInfo between modules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs --- a/GHC/StgToCmm/Utils.hs +++ b/GHC/StgToCmm/Utils.hs @@ -39,6 +39,7 @@ cmmUntag, cmmIsTagged, addToMem, addToMemE, addToMemLblE, addToMemLbl, + emitAtomicRead, emitAtomicWrite, -- * Update remembered set operations whenUpdRemSetEnabled, @@ -62,6 +63,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.Utils import GHC.Cmm.Switch +import {-# SOURCE #-} GHC.StgToCmm.Foreign (emitPrimCall) import GHC.StgToCmm.CgUtils import GHC.Types.ForeignCall @@ -77,7 +79,6 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Types.CostCentre import GHC.Types.IPE @@ -85,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 @@ -123,7 +123,30 @@ addToMemE rep ptr n = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep NaturallyAligned, n]) +------------------------------------------------------------------------- +-- Atomic loads and stores +------------------------------------------------------------------------- +emitAtomicRead + :: MemoryOrdering + -> LocalReg -- ^ result register + -> CmmExpr -- ^ address + -> FCode () +emitAtomicRead mord res addr + = void $ emitPrimCall [res] (MO_AtomicRead w mord) [addr] + where + w = typeWidth $ localRegType res + +emitAtomicWrite + :: MemoryOrdering + -> CmmExpr -- ^ address + -> CmmExpr -- ^ value + -> FCode () +emitAtomicWrite mord addr val + = do platform <- getPlatform + let w = typeWidth $ cmmExprType platform val + void $ emitPrimCall [] (MO_AtomicWrite w mord) [addr, val] + ------------------------------------------------------------------------- -- -- Loading a field from an object, @@ -237,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) ------------------------------------------------------------------------- -- @@ -649,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]) @@ -662,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 @@ -670,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))) diff --git a/GHC/StgToJS.hs b/GHC/StgToJS.hs --- a/GHC/StgToJS.hs +++ b/GHC/StgToJS.hs @@ -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 diff --git a/GHC/StgToJS/Apply.hs b/GHC/StgToJS/Apply.hs --- a/GHC/StgToJS/Apply.hs +++ b/GHC/StgToJS/Apply.hs @@ -1,1128 +1,1334 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Apply --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Josh Meredith --- Stability : experimental --- --- --- Module that deals with expression application in JavaScript. In some cases we --- rely on pre-generated functions that are bundled with the RTS (see rtsApply). ------------------------------------------------------------------------------ - -module GHC.StgToJS.Apply - ( genApp - , rtsApply - ) -where - -import GHC.Prelude hiding ((.|.)) - -import GHC.JS.Unsat.Syntax -import GHC.JS.Make - -import GHC.StgToJS.Arg -import GHC.StgToJS.Closure -import GHC.StgToJS.DataCon -import GHC.StgToJS.ExprCtx -import GHC.StgToJS.Heap -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.Types.Id -import GHC.Types.Id.Info -import GHC.Types.CostCentre -import GHC.Types.RepType (mightBeFunTy) - -import GHC.Stg.Syntax - -import GHC.Builtin.Names - -import GHC.Core.TyCon -import GHC.Core.DataCon -import GHC.Core.Type hiding (typeSize) - -import GHC.Utils.Misc -import GHC.Utils.Monad -import GHC.Utils.Panic -import GHC.Utils.Outputable (vcat, ppr) -import GHC.Data.FastString - -import qualified Data.Bits as Bits -import Data.Monoid -import Data.Array - --- | Pre-generated functions for fast Apply. --- These are bundled with the RTS. -rtsApply :: StgToJSConfig -> JStat -rtsApply cfg = BlockStat $ - map (specApply cfg) applySpec - ++ map (pap cfg) specPap - ++ [ mkApplyArr - , genericStackApply cfg - , genericFastApply cfg - , zeroApply cfg - , updates cfg - , papGen cfg - , moveRegs2 - , selectors cfg - ] - - --- | Generate an application of some args to an Id. --- --- The case where args is null is common as it's used to generate the evaluation --- code for an Id. -genApp - :: HasDebugCallStack - => ExprCtx - -> Id - -> [StgArg] - -> G (JStat, ExprResult) -genApp ctx i args - - -- let-no-escape - | Just n <- ctxLneBindingStackSize ctx i - = do - as' <- concatMapM genArg args - ei <- varForEntryId i - let ra = mconcat . reverse $ - zipWith (\r a -> toJExpr r |= a) [R1 ..] as' - p <- pushLneFrame n ctx - a <- adjSp 1 -- for the header (which will only be written when the thread is suspended) - return (ra <> p <> a <> returnS ei, ExprCont) - - -- proxy# - | [] <- args - , getUnique i == proxyHashKey - , [top] <- concatMap typex_expr (ctxTarget ctx) - = return (top |= null_, ExprInline Nothing) - - -- unboxed tuple or strict type: return fields individually - | [] <- args - , isUnboxedTupleType (idType i) || isStrictType (idType i) - = do - a <- storeIdFields i (ctxTarget ctx) - return (a, ExprInline Nothing) - - -- Handle alternative heap object representation: in some cases, a heap - -- object is not represented as a JS object but directly as a number or a - -- string. I.e. only the payload is stored because the box isn't useful. - -- It happens for "Int Int#" for example: no need to box the Int# in JS. - -- - -- We must check that: - -- - the object is subject to the optimization (cf isUnboxable predicate) - -- - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we - -- need to evaluate it properly first. - -- - -- In which case we generate a dynamic check (using isObject) that either: - -- - returns the payload of the heap object, if it uses the generic heap - -- object representation - -- - returns the object directly, otherwise - | [] <- args - , [vt] <- idVt i - , isUnboxable vt - , ctxIsEvaluated ctx i - = do - let c = head (concatMap typex_expr $ ctxTarget ctx) - is <- varsForId i - case is of - [i'] -> - return ( c |= if_ (isObject i') (closureField1 i') i' - , ExprInline Nothing - ) - _ -> panic "genApp: invalid size" - - -- case of Id without args and known to be already evaluated: return fields - -- individually - | [] <- args - , ctxIsEvaluated ctx i || isStrictType (idType i) - = do - a <- storeIdFields i (ctxTarget ctx) - -- optional runtime assert for detecting unexpected thunks (unevaluated) - settings <- getSettings - let ww = case concatMap typex_expr (ctxTarget ctx) of - [t] | csAssertRts settings -> - ifS (isObject t .&&. isThunk t) - (appS "throw" [String "unexpected thunk"]) -- yuck - mempty - _ -> mempty - return (a `mappend` ww, ExprInline Nothing) - - - -- Case: "newtype" datacon wrapper - -- - -- If the wrapped argument is known to be already evaluated, then we don't - -- need to enter it. - | DataConWrapId dc <- idDetails i - , isNewTyCon (dataConTyCon dc) - = do - as <- concatMapM genArg args - case as of - [ai] -> do - let t = head (concatMap typex_expr (ctxTarget ctx)) - a' = case args of - [StgVarArg a'] -> a' - _ -> panic "genApp: unexpected arg" - if isStrictId a' || ctxIsEvaluated ctx a' - then return (t |= ai, ExprInline Nothing) - else return (returnS (app "h$e" [ai]), ExprCont) - _ -> panic "genApp: invalid size" - - -- no args and Id can't be a function: just enter it - | [] <- args - , idFunRepArity i == 0 - , not (mightBeFunTy (idType i)) - = do - enter_id <- genIdArg i >>= - \case - [x] -> return x - xs -> pprPanic "genApp: unexpected multi-var argument" - (vcat [ppr (length xs), ppr i]) - return (returnS (app "h$e" [enter_id]), ExprCont) - - -- fully saturated global function: - -- - deals with arguments - -- - jumps into the function - | n <- length args - , n /= 0 - , idFunRepArity i == n - , not (isLocalId i) - , isStrictId i - = do - as' <- concatMapM genArg args - is <- assignAll jsRegsFromR1 <$> varsForId i - jmp <- jumpToII i as' is - return (jmp, ExprCont) - - -- oversaturated function: - -- - push continuation with extra args - -- - deals with arguments - -- - jumps into the function - | idFunRepArity i < length args - , isStrictId i - , idFunRepArity i > 0 - = do - let (reg,over) = splitAt (idFunRepArity i) args - reg' <- concatMapM genArg reg - pc <- pushCont over - is <- assignAll jsRegsFromR1 <$> varsForId i - jmp <- jumpToII i reg' is - return (pc <> jmp, ExprCont) - - -- generic apply: - -- - try to find a pre-generated apply function that matches - -- - use it if any - -- - otherwise use generic apply function h$ap_gen_fast - | otherwise - = do - is <- assignAll jsRegsFromR1 <$> varsForId i - jmp <- jumpToFast args is - return (jmp, ExprCont) - --- avoid one indirection for global ids --- fixme in many cases we can also jump directly to the entry for local? -jumpToII :: Id -> [JExpr] -> JStat -> G JStat -jumpToII i vars load_app_in_r1 - | isLocalId i = do - ii <- varForId i - return $ mconcat - [ assignAllReverseOrder jsRegsFromR2 vars - , load_app_in_r1 - , returnS (closureEntry ii) - ] - | otherwise = do - ei <- varForEntryId i - return $ mconcat - [ assignAllReverseOrder jsRegsFromR2 vars - , load_app_in_r1 - , returnS ei - ] - --- | Try to use a specialized pre-generated application function. --- If there is none, use h$ap_gen_fast instead -jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat -jumpToFast args load_app_in_r1 = do - -- get JS expressions for every argument - -- Arguments may have more than one expression (e.g. Word64#) - vars <- concatMapM genArg args - -- try to find a specialized apply function - let spec = mkApplySpec RegsConv args vars - ap_fun <- selectApply spec - pure $ mconcat - [ assignAllReverseOrder jsRegsFromR2 vars - , load_app_in_r1 - , case ap_fun of - -- specialized apply: no tag - Right fun -> returnS (ApplExpr fun []) - -- generic apply: pass a tag indicating number of args/slots - Left fun -> returnS (ApplExpr fun [specTagExpr spec]) - ] - --- | Calling convention for an apply function -data ApplyConv - = RegsConv -- ^ Fast calling convention: use registers - | StackConv -- ^ Slow calling convention: use the stack - deriving (Show,Eq,Ord) - --- | Name of the generic apply function -genericApplyName :: ApplyConv -> FastString -genericApplyName = \case - RegsConv -> "h$ap_gen_fast" - StackConv -> "h$ap_gen" - --- | Expr of the generic apply function -genericApplyExpr :: ApplyConv -> JExpr -genericApplyExpr conv = var (genericApplyName conv) - - --- | Return the name of the specialized apply function for the given number of --- args, number of arg variables, and calling convention. -specApplyName :: ApplySpec -> FastString -specApplyName = \case - -- specialize a few for compiler performance (avoid building FastStrings over - -- and over for common cases) - ApplySpec RegsConv 0 0 -> "h$ap_0_0_fast" - ApplySpec StackConv 0 0 -> "h$ap_0_0" - ApplySpec RegsConv 1 0 -> "h$ap_1_0_fast" - ApplySpec StackConv 1 0 -> "h$ap_1_0" - ApplySpec RegsConv 1 1 -> "h$ap_1_1_fast" - ApplySpec StackConv 1 1 -> "h$ap_1_1" - ApplySpec RegsConv 1 2 -> "h$ap_1_2_fast" - ApplySpec StackConv 1 2 -> "h$ap_1_2" - ApplySpec RegsConv 2 1 -> "h$ap_2_1_fast" - ApplySpec StackConv 2 1 -> "h$ap_2_1" - ApplySpec RegsConv 2 2 -> "h$ap_2_2_fast" - ApplySpec StackConv 2 2 -> "h$ap_2_2" - ApplySpec RegsConv 2 3 -> "h$ap_2_3_fast" - ApplySpec StackConv 2 3 -> "h$ap_2_3" - ApplySpec conv nargs nvars -> mkFastString $ mconcat - [ "h$ap_", show nargs - , "_" , show nvars - , case conv of - RegsConv -> "_fast" - StackConv -> "" - ] - --- | Return the expression of the specialized apply function for the given --- number of args, number of arg variables, and calling convention. --- --- Warning: the returned function may not be generated! Use specApplyExprMaybe --- if you want to ensure that it exists. -specApplyExpr :: ApplySpec -> JExpr -specApplyExpr spec = var (specApplyName spec) - --- | Return the expression of the specialized apply function for the given --- number of args, number of arg variables, and calling convention. --- Return Nothing if it isn't generated. -specApplyExprMaybe :: ApplySpec -> Maybe JExpr -specApplyExprMaybe spec = - if spec `elem` applySpec - then Just (specApplyExpr spec) - else Nothing - --- | Make an ApplySpec from a calling convention, a list of Haskell args, and a --- list of corresponding JS variables -mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec -mkApplySpec conv args vars = ApplySpec - { specConv = conv - , specArgs = length args - , specVars = length vars - } - --- | Find a specialized application function if there is one -selectApply - :: ApplySpec - -> G (Either JExpr JExpr) -- ^ the function to call (Left for generic, Right for specialized) -selectApply spec = - case specApplyExprMaybe spec of - Just e -> return (Right e) - Nothing -> return (Left (genericApplyExpr (specConv spec))) - - --- | Apply specification -data ApplySpec = ApplySpec - { specConv :: !ApplyConv -- ^ Calling convention - , specArgs :: !Int -- ^ number of Haskell arguments - , specVars :: !Int -- ^ number of JavaScript variables for the arguments - } - deriving (Show,Eq,Ord) - --- | List of specialized apply function templates -applySpec :: [ApplySpec] -applySpec = [ ApplySpec conv nargs nvars - | conv <- [RegsConv, StackConv] - , nargs <- [0..4] - , nvars <- [max 0 (nargs-1)..(nargs*2)] - ] - --- | Generate a tag for the given ApplySpec --- --- Warning: tag doesn't take into account the calling convention -specTag :: ApplySpec -> Int -specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. (specArgs spec) - --- | Generate a tag expression for the given ApplySpec -specTagExpr :: ApplySpec -> JExpr -specTagExpr = toJExpr . specTag - --- | Build arrays to quickly lookup apply functions --- --- h$apply[r << 8 | n] = function application for r regs, n args --- h$paps[r] = partial application for r registers (number of args is in the object) -mkApplyArr :: JStat -mkApplyArr = mconcat - [ TxtI "h$apply" ||= toJExpr (JList []) - , TxtI "h$paps" ||= toJExpr (JList []) - , ApplStat (var "h$initStatic" .^ "push") - [ ValExpr $ JFunc [] $ mconcat - [ jFor (|= zero_) (.<. Int 65536) preIncrS - (\j -> var "h$apply" .! j |= var "h$ap_gen") - , jFor (|= zero_) (.<. Int 128) preIncrS - (\j -> var "h$paps" .! j |= var "h$pap_gen") - , mconcat (map assignSpec applySpec) - , mconcat (map assignPap specPap) - ] - ] - ] - where - assignSpec :: ApplySpec -> JStat - assignSpec spec = case specConv spec of - -- 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 - RegsConv -> mempty - - assignPap :: Int -> JStat - assignPap p = var "h$paps" .! toJExpr p |= - (var (mkFastString $ ("h$pap_" ++ show p))) - --- | Push a continuation on the stack --- --- First push the given args, then push an apply function (specialized if --- possible, otherwise the generic h$ap_gen function). -pushCont :: HasDebugCallStack - => [StgArg] - -> G JStat -pushCont args = do - vars <- concatMapM genArg args - let spec = mkApplySpec StackConv args vars - selectApply spec >>= \case - Right app -> push $ reverse $ app : vars - Left app -> push $ reverse $ app : specTagExpr spec : vars - --- | Generic stack apply function (h$ap_gen) that can do everything, but less --- efficiently than other more specialized functions. --- --- Stack layout: --- -3: ... --- -2: args --- -1: tag (number of arg slots << 8 | number of args) --- --- Regs: --- R1 = applied closure --- -genericStackApply :: StgToJSConfig -> JStat -genericStackApply cfg = closure info body - where - -- h$ap_gen body - body = jVar \cf -> - [ traceRts cfg (jString "h$ap_gen") - , cf |= closureEntry r1 - -- switch on closure type - , SwitchStat (entryClosureType cf) - [ (toJExpr Thunk , thunk_case cfg cf) - , (toJExpr Fun , fun_case cf (funArity' cf)) - , (toJExpr Pap , fun_case cf (papArity r1)) - , (toJExpr Blackhole, blackhole_case cfg) - ] - (default_case cf) - ] - - -- info table for h$ap_gen - info = ClosureInfo - { ciVar = TxtI "h$ap_gen" - , ciRegs = CIRegs 0 [PtrV] -- closure to apply to - , ciName = "h$ap_gen" - , ciLayout = CILayoutVariable - , ciType = CIStackFrame - , ciStatic = mempty - } - - default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type " - + (entryClosureType cf)] - - thunk_case cfg cf = mconcat - [ profStat cfg pushRestoreCCS - , returnS cf - ] - - blackhole_case cfg = mconcat - [ push' cfg [r1, var "h$return"] - , returnS (app "h$blockOnBlackhole" [r1]) - ] - - fun_case c arity = jVar \tag needed_args needed_regs given_args given_regs newTag newAp p dat -> - [ tag |= stack .! (sp - 1) -- tag on the stack - , given_args |= mask8 tag -- indicates the number of passed args - , given_regs |= tag .>>. 8 -- and the number of passed values for registers - , needed_args |= mask8 arity - , needed_regs |= arity .>>. 8 - , traceRts cfg (jString "h$ap_gen: args: " + given_args - + jString " regs: " + given_regs) - , ifBlockS (given_args .===. needed_args) - -------------------------------- - -- exactly saturated application - -------------------------------- - [ traceRts cfg (jString "h$ap_gen: exact") - -- Set registers to register values on the stack - , loop 0 (.<. given_regs) \i -> mconcat - [ appS "h$setReg" [i+2, stack .! (sp-2-i)] - , postIncrS i - ] - -- drop register values from the stack - , sp |= sp - given_regs - 2 - -- enter closure in R1 - , returnS c - ] - [ ifBlockS (given_args .>. needed_args) - ---------------------------- - -- oversaturated application - ---------------------------- - [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args - + jString " regs: " + needed_regs) - -- load needed register values - , loop 0 (.<. needed_regs) \i -> mconcat - [ traceRts cfg (jString "h$ap_gen: loading register: " + i) - , appS "h$setReg" [i+2, stack .! (sp-2-i)] - , postIncrS i - ] - -- 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 - , 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") - ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag)) - (sp |= sp - needed_regs - 1) - - -- Push generic application function as continuation - , stack .! sp |= newAp - - -- Push "current thread CCS restore" function as continuation - , profStat cfg pushRestoreCCS - - -- enter closure in R1 - , returnS c - ] - - ----------------------------- - -- undersaturated application - ----------------------------- - [ traceRts cfg (jString "h$ap_gen: undersat") - -- find PAP entry function corresponding to given_regs count - , p |= var "h$paps" .! given_regs - - -- build PAP payload: R1 + tag + given register values - , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args) - , dat |= toJExpr [r1, newTag] - , loop 0 (.<. given_regs) \i -> mconcat - [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)] - , postIncrS i - ] - - -- remove register values from the stack. - , sp |= sp - given_regs - 2 - - -- alloc PAP closure, store reference to it in R1. - , r1 |= initClosure cfg p dat jCurrentCCS - - -- return to the continuation on the stack - , returnStack - ] - ] - ] - --- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less --- efficiently than other more specialized functions. --- --- Signature tag in argument. Tag: (regs << 8 | arity) --- --- Regs: --- R1 = closure to apply to --- -genericFastApply :: StgToJSConfig -> JStat -genericFastApply s = - jFun (TxtI "h$ap_gen_fast") \tag -> jVar \c -> - [traceRts s (jString "h$ap_gen_fast: " + tag) - , c |= closureEntry r1 - , SwitchStat (entryClosureType c) - [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk") - <> pushStackApply c tag - <> returnS c) - , (toJExpr Fun, jVar \farity -> - [ farity |= funArity' c - , traceRts s (jString "h$ap_gen_fast: fun " + farity) - , funCase c tag farity - ]) - , (toJExpr Pap, jVar \parity -> - [ parity |= papArity r1 - , traceRts s (jString "h$ap_gen_fast: pap " + parity) - , funCase c tag parity - ]) - , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con") - <> jwhenS (tag .!=. 0) - (appS "throw" [jString "h$ap_gen_fast: invalid apply"]) - <> returnS c) - , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole") - <> pushStackApply c tag - <> push' s [r1, var "h$return"] - <> returnS (app "h$blockOnBlackhole" [r1])) - ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c] - ] - - where - -- thunk: push everything to stack frame, enter thunk first - pushStackApply :: JExpr -> JExpr -> JStat - pushStackApply _c tag = - jVar \ap -> - [ pushAllRegs tag - , ap |= var "h$apply" .! tag - , ifS (ap .===. var "h$ap_gen") - ((sp |= sp + 2) <> (stack .! (sp-1) |= tag)) - (sp |= sp + 1) - , stack .! sp |= ap - , profStat s pushRestoreCCS - ] - - funCase :: JExpr -> JExpr -> JExpr -> JStat - funCase c tag arity = - jVar \ar myAr myRegs regsStart newTag newAp dat p -> - [ ar |= mask8 arity - , myAr |= mask8 tag - , myRegs |= tag .>>. 8 - , traceRts s (jString "h$ap_gen_fast: args: " + myAr - + jString " regs: " + myRegs) - , ifS (myAr .===. ar) - -- call the function directly - (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c) - (ifBlockS (myAr .>. ar) - -- push stack frame with remaining args, then call fun - [ traceRts s (jString "h$ap_gen_fast: oversat " + sp) - , regsStart |= (arity .>>. 8) + 1 - , sp |= sp + myRegs - regsStart + 1 - , traceRts s (jString "h$ap_gen_fast: oversat " + sp) - , pushArgs regsStart myRegs - , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar - , newAp |= var "h$apply" .! newTag - , ifS (newAp .===. var "h$ap_gen") - ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag)) - (sp |= sp + 1) - , stack .! sp |= newAp - , profStat s pushRestoreCCS - , returnS c - ] - -- else - [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag) - , jwhenS (tag .!=. 0) $ mconcat - [ p |= var "h$paps" .! myRegs - , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] - , loop 0 (.<. myRegs) - (\i -> (dat .^ "push") - `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i) - , r1 |= initClosure s p dat jCurrentCCS - ] - , returnStack - ]) - ] - - - pushAllRegs :: JExpr -> JStat - pushAllRegs tag = - jVar \regs -> - [ regs |= tag .>>. 8 - , sp |= sp + regs - , SwitchStat regs (map pushReg [65,64..2]) mempty - ] - where - pushReg :: Int -> (JExpr, JStat) - pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r) - - pushArgs :: JExpr -> JExpr -> JStat - pushArgs start end = - loop end (.>=.start) (\i -> traceRts s (jString "pushing register: " + i) - <> (stack .! (sp + start - i) |= app "h$getReg" [i+1]) - <> postDecrS i - ) - --- | Make specialized apply function for the given ApplySpec -specApply :: StgToJSConfig -> ApplySpec -> JStat -specApply cfg spec@(ApplySpec conv nargs nvars) = - let fun_name = specApplyName spec - in case conv of - RegsConv -> fastApply cfg fun_name nargs nvars - StackConv -> stackApply cfg fun_name nargs nvars - --- | Make specialized apply function with Stack calling convention -stackApply - :: StgToJSConfig - -> FastString - -> Int - -> Int - -> JStat -stackApply s fun_name nargs nvars = - -- special case for h$ap_0_0 - if nargs == 0 && nvars == 0 - then closure info0 body0 - else closure info body - where - info = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty - info0 = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 []) CIStackFrame mempty - - body0 = adjSpN' 1 <> enter s r1 - - body = jVar \c -> - [ c |= closureEntry r1 - , traceRts s (toJExpr fun_name - + jString " " - + (c .^ "n") - + jString " sp: " + sp - + jString " a: " + (c .^ "a")) - , SwitchStat (entryClosureType c) - [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c) - , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> funCase c) - , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> papCase c) - , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1])) - ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)]) - ] - - funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c - stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars] - - papCase :: JExpr -> JStat - papCase c = jVar \expr arity0 arity -> - case expr of - ValExpr (JVar pap) -> [ arity0 |= papArity r1 - , arity |= mask8 arity0 - , traceRts s (toJExpr (fun_name <> ": found pap, arity: ") + arity) - , ifS (toJExpr nargs .===. arity) - --then - (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) - -- else - (ifS (toJExpr nargs .>. arity) - (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity0 arity) - (traceRts s (toJExpr (fun_name <> ": undersat")) - <> mkPap s pap r1 (toJExpr nargs) stackArgs - <> (sp |= sp - toJExpr (nvars + 1)) - <> (r1 |= toJExpr pap) - <> returnStack)) - ] - _ -> mempty - - - funCase :: JExpr -> JStat - funCase c = jVar \expr ar0 ar -> - case expr of - ValExpr (JVar pap) -> [ ar0 |= funArity' c - , ar |= mask8 ar0 - , ifS (toJExpr nargs .===. ar) - (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) - (ifS (toJExpr nargs .>. ar) - (traceRts s (toJExpr (fun_name <> ": oversat")) - <> oversatCase c ar0 ar) - (traceRts s (toJExpr (fun_name <> ": undersat")) - <> mkPap s pap (toJExpr R1) (toJExpr nargs) stackArgs - <> (sp |= sp - toJExpr (nvars+1)) - <> (r1 |= toJExpr pap) - <> returnStack)) - ] - _ -> mempty - - - -- oversat: call the function but keep enough on the stack for the next - oversatCase :: JExpr -- function - -> JExpr -- the arity tag - -> JExpr -- real arity (arity & 0xff) - -> JStat - oversatCase c arity arity0 = - jVar \rs newAp -> - [ rs |= (arity .>>. 8) - , loadRegs rs - , sp |= sp - rs - , newAp |= (var "h$apply" .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8))) - , stack .! sp |= newAp - , profStat s pushRestoreCCS - , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n")) - , returnS c - ] - where - loadRegs rs = SwitchStat rs switchAlts mempty - where - switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [nvars,nvars-1..1] - --- | Make specialized apply function with Regs calling convention --- --- h$ap_n_r_fast is entered if a function of unknown arity is called, n --- arguments are already in r registers -fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat -fastApply s fun_name nargs nvars = body0 - where - -- special case for h$ap_0_0_fast - body0 = if nargs == 0 && nvars == 0 - then jFun func (enter s r1) - else FuncStat func myFunArgs body - - func = TxtI fun_name - - myFunArgs = [] - - regArgs = take nvars jsRegsFromR2 - - mkAp :: Int -> Int -> [JExpr] - mkAp n' r' = [ specApplyExpr (ApplySpec StackConv n' r') ] - - body = - jVar \c farity arity -> - [ c |= closureEntry r1 - , traceRts s (toJExpr (fun_name <> ": sp ") + sp) - , SwitchStat (entryClosureType c) - [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ") - + clName c - + jString " (arity: " + (c .^ "a") + jString ")") - <> (farity |= funArity' c) - <> funCase c farity) - ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> funCase c arity) - ,(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]) - ] - - funCase :: JExpr -> JExpr -> JStat - funCase c arity = jVar \arg ar -> case arg of - ValExpr (JVar pap) -> [ ar |= mask8 arity - , ifS (toJExpr nargs .===. ar) - -- then - (traceRts s (toJExpr (fun_name <> ": exact")) <> returnS c) - -- else - (ifS (toJExpr nargs .>. ar) - --then - (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity) - -- else - (traceRts s (toJExpr (fun_name <> ": undersat")) - <> mkPap s pap r1 (toJExpr nargs) regArgs - <> (r1 |= toJExpr pap) - <> returnStack)) - ] - _ -> mempty - - oversatCase :: JExpr -> JExpr -> JStat - oversatCase c arity = - jVar \rs rsRemain -> - [ rs |= arity .>>. 8 - , rsRemain |= toJExpr nvars - rs - , traceRts s (toJExpr - (fun_name <> " regs oversat ") - + rs - + jString " remain: " - + rsRemain) - , saveRegs rs - , sp |= sp + rsRemain + 1 - , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity)) - , profStat s pushRestoreCCS - , returnS c - ] - where - saveRegs n = SwitchStat n switchAlts mempty - where - switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1] - -zeroApply :: StgToJSConfig -> JStat -zeroApply s = mconcat - [ jFun (TxtI "h$e") (\c -> (r1 |= c) <> enter s c) - ] - --- carefully enter a closure that might be a thunk or a function - --- ex may be a local var, but must've been copied to R1 before calling this -enter :: StgToJSConfig -> JExpr -> JStat -enter s ex = jVar \c -> - [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack - , c |= closureEntry ex - , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack) - , SwitchStat (entryClosureType 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])) - ] (returnS c) - ] - -updates :: StgToJSConfig -> JStat -updates s = BlockStat - [ closure - (ClosureInfo (TxtI "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - $ jVar \updatee waiters ss si sir -> - let unbox_closure = Closure - { clEntry = var "h$unbox_e" - , clField1 = sir - , clField2 = null_ - , clMeta = 0 - , clCC = Nothing - } - updateCC updatee = closureCC updatee |= jCurrentCCS - in [ updatee |= stack .! (sp - 1) - , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc") - , -- wake up threads blocked on blackhole - waiters |= closureField2 updatee - , jwhenS (waiters .!==. null_) - (loop 0 (.<. waiters .^ "length") - (\i -> appS "h$wakeupThread" [waiters .! i] <> postIncrS i)) - , -- update selectors - jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel")) - ((ss |= closureMeta updatee .^ "sel") - <> loop 0 (.<. ss .^ "length") \i -> mconcat - [ si |= ss .! i - , sir |= (closureField2 si) `ApplExpr` [r1] - , ifS (app "typeof" [sir] .===. jTyObject) - (copyClosure DontCopyCC si sir) - (assignClosure si unbox_closure) - , postIncrS i - ]) - , -- overwrite the object - ifS (app "typeof" [r1] .===. jTyObject) - (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n")) - , copyClosure DontCopyCC updatee r1 - ]) - -- the heap object is represented by another type of value - -- (e.g. a JS number or string) so the unboxing closure - -- will simply return it. - (assignClosure updatee (unbox_closure { clField1 = r1 })) - , profStat s (updateCC updatee) - , adjSpN' 2 - , traceRts s (jString "h$upd_frame: updating: " - + updatee - + jString " -> " - + r1) - , returnStack - ] - - , closure - (ClosureInfo (TxtI "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - $ jVar \updateePos -> - [ updateePos |= stack .! (sp - 1) - , (stack .! updateePos |= r1) - , adjSpN' 2 - , traceRts s (jString "h$upd_frame_lne: updating: " - + updateePos - + jString " -> " - + r1) - , returnStack - ] - ] - -selectors :: StgToJSConfig -> JStat -selectors s = - mkSel "1" closureField1 - <> mkSel "2a" closureField2 - <> mkSel "2b" (closureField1 . closureField2) - <> mconcat (map mkSelN [3..16]) - where - mkSelN :: Int -> JStat - mkSelN x = mkSel (mkFastString $ show x) - (\e -> SelExpr (closureField2 (toJExpr e)) - (TxtI $ mkFastString ("d" ++ show (x-1)))) - - - mkSel :: FastString -> (JExpr -> JExpr) -> JStat - mkSel name sel = mconcat - [jFun (TxtI createName) \r -> mconcat - [ 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)) - ] - , jFun (TxtI resName) \r -> mconcat - [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc")) - , returnS (sel r) - ] - , closure - (ClosureInfo (TxtI entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty) - (jVar \tgt -> - [ tgt |= closureField1 r1 - , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc")) - , ifS (isThunk tgt .||. isBlackhole tgt) - (preIncrS sp - <> (stack .! sp |= var frameName) - <> returnS (app "h$e" [tgt])) - (returnS (app "h$e" [sel tgt])) - ]) - , closure - (ClosureInfo (TxtI frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty) - $ mconcat [ traceRts s (toJExpr ("selector frame: " <> name)) - , postDecrS sp - , returnS (app "h$e" [sel r1]) - ] - ] - - where - v x = JVar (TxtI x) - n ext = "h$c_sel_" <> name <> ext - createName = n "" - resName = n "_res" - entryName = n "_e" - frameName = n "_frame_e" - - --- arity is the remaining arity after our supplied arguments are applied -mkPap :: StgToJSConfig - -> Ident -- ^ id of the pap object - -> JExpr -- ^ the function that's called (can be a second pap) - -> JExpr -- ^ number of arguments in pap - -> [JExpr] -- ^ values for the supplied arguments - -> JStat -mkPap s tgt fun n values = - traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items") - `mappend` - allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values') - (if csProf s then Just jCurrentCCS else Nothing) - where - papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n - - values' | GHC.Prelude.null values = [null_] - | otherwise = values - entry | length values > numSpecPap = TxtI "h$pap_gen" - | otherwise = specPapIdents ! length values - --- | Number of specialized PAPs (pre-generated for a given number of args) -numSpecPap :: Int -numSpecPap = 6 - --- specialized (faster) pap generated for [0..numSpecPap] --- others use h$pap_gen -specPap :: [Int] -specPap = [0..numSpecPap] - --- | Cache of specialized PAP idents -specPapIdents :: Array Int Ident -specPapIdents = listArray (0,numSpecPap) $ map (TxtI . mkFastString . ("h$pap_"++) . show) specPap - -pap :: StgToJSConfig - -> Int - -> JStat -pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body - where - funcIdent = TxtI funcName - funcName = mkFastString ("h$pap_" ++ show r) - - body = jVar \c d f extra -> - [ c |= closureField1 r1 - , d |= closureField2 r1 - , f |= closureEntry c - , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap") - , profStat s (enterCostCentreFun currentCCS) - , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r - , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra) - , moveBy extra - , loadOwnArgs d - , r1 |= c - , returnS f - ] - moveBy extra = SwitchStat extra - (reverse $ map moveCase [1..maxReg-r-1]) mempty - 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 (TxtI . mkFastString $ ('d':show (n-1))) - --- Construct a generic PAP -papGen :: StgToJSConfig -> JStat -papGen cfg = - closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty) - (jVar \c f d pr or r -> - [ c |= closureField1 r1 - , d |= closureField2 r1 - , f |= closureEntry c - , pr |= funOrPapArity c (Just f) .>>. 8 - , or |= papArity r1 .>>. 8 - , r |= pr - or - , assertRts cfg - (isFun' f .||. isPap' f) - (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] - , loadOwnArgs d r - , r1 |= c - , returnS f - ]) - - - where - funcIdent = TxtI funcName - funcName = "h$pap_gen" - loadOwnArgs d r = - let prop n = d .^ ("d" <> mkFastString (show $ n+1)) - loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n) - in SwitchStat r (map loadOwnArg [127,126..1]) mempty - --- general utilities --- move the first n registers, starting at R2, m places up (do not use with negative m) -moveRegs2 :: JStat -moveRegs2 = jFun (TxtI "h$moveRegs2") moveSwitch - where - moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m) - -- fast cases - switchCases = [switchCase n m | n <- [1..5], m <- [1..4]] - switchCase :: Int -> Int -> (JExpr, JStat) - switchCase n m = (toJExpr $ - (n `Bits.shiftL` 8) Bits..|. m - , mconcat (map (`moveRegFast` m) [n+1,n..2]) - <> BreakStat Nothing {-[j| break; |]-}) - moveRegFast n m = jsReg (n+m) |= jsReg n - -- fallback - defaultCase n m = - loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i) - - --- Initalize a variable sized object from an array of values -initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr -initClosure cfg entry values ccs = app "h$init_closure" - [ newClosure $ Closure - { clEntry = entry - , clField1 = null_ - , clField2 = null_ - , clMeta = 0 - , clCC = if csProf cfg then Just ccs else Nothing - } - , values - ] - --- | Return an expression for every field of the given Id -getIdFields :: Id -> G [TypedExpr] -getIdFields i = assocIdExprs i <$> varsForId i - --- | Store fields of Id into the given target expressions -storeIdFields :: Id -> [TypedExpr] -> G JStat +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Apply +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Josh Meredith +-- Stability : experimental +-- +-- +-- Module that deals with expression application in JavaScript. In some cases we +-- rely on pre-generated functions that are bundled with the RTS (see rtsApply). +----------------------------------------------------------------------------- + +module GHC.StgToJS.Apply + ( genApp + , rtsApply + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Ident +import GHC.JS.Make + +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure +import GHC.StgToJS.DataCon +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Ids +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Rts.Types +import GHC.StgToJS.Stack +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types +import GHC.StgToJS.Utils +import GHC.StgToJS.Linker.Utils (decodeModifiedUTF8) + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.CostCentre +import GHC.Types.RepType (mightBeFunTy) +import GHC.Types.Literal + +import GHC.Stg.Syntax + +import GHC.Builtin.Names + +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Outputable (vcat, ppr) +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import Data.Monoid +import Data.Array + +-- | Pre-generated functions for fast Apply. +-- These are bundled with the RTS. +rtsApply :: StgToJSConfig -> JSM JStgStat +rtsApply cfg = jBlock + [ mconcat <$> mapM (specApply cfg) applySpec + , mconcat <$> mapM (pap cfg) specPap + , mkApplyArr + , genericStackApply cfg + , genericFastApply cfg + , zeroApply cfg + , updates cfg + , papGen cfg + , selectors cfg + , moveRegs2 + ] + +-- | Generate an application of some args to an Id. +-- +-- The case where args is null is common as it's used to generate the evaluation +-- code for an Id. +genApp + :: HasDebugCallStack + => ExprCtx + -> Id + -> [StgArg] + -> G (JStgStat, ExprResult) +genApp ctx i args + -- Test case moved to T24744 + -- See: https://github.com/ghcjs/ghcjs/blob/b7711fbca7c3f43a61f1dba526e6f2a2656ef44c/src/Gen2/Generator.hs#L876 + -- Comment by Luite Stegeman + -- Special cases for JSString literals. + -- We could handle unpackNBytes# here, but that's probably not common + -- enough to warrant a special case. + -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588/#note_503978 + -- Comment by Jeffrey Young + -- We detect if the Id is unsafeUnpackJSStringUtf8## applied to a string literal, + -- if so then we convert the unsafeUnpack to a call to h$decode. + | [StgVarArg v] <- args + , idName i == unsafeUnpackJSStringUtf8ShShName + -- See: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10588 + -- Comment by Josh Meredith + -- `typex_expr` can throw an error for certain bindings so it's important + -- that this condition comes after matching on the function name + , [top] <- concatMap typex_expr (ctxTarget ctx) + = (,ExprInline) . (|=) top . app hdDecodeUtf8Z <$> varsForId v + + -- Test case T23479 + | [StgLitArg (LitString bs)] <- args + , Just d <- decodeModifiedUTF8 bs + , idName i == unsafeUnpackJSStringUtf8ShShName + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return . (,ExprInline) $ top |= toJExpr d + + -- Test case T24495 with single occurrence at -02 and third occurrence at -01 + -- Moved back from removal at https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12308 + -- See commit hash b36ee57bfbecc628b7f0919e1e59b7066495034f + -- + -- Case: unpackCStringAppend# "some string"# str + -- + -- Generates h$appendToHsStringA(str, "some string"), which has a faster + -- decoding loop. + | [StgLitArg (LitString bs), x] <- args + , Just d <- decodeModifiedUTF8 bs + , getUnique i == unpackCStringAppendIdKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) + , ExprInline + ) + | [StgLitArg (LitString bs), x] <- args + , Just d <- decodeModifiedUTF8 bs + , getUnique i == unpackCStringAppendUtf8IdKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg) + , ExprInline + ) + + -- Case: unpackCString# "some string"# + -- + -- Generates h$toHsString("some string"), which has a faster + -- decoding loop. + -- + Utf8 version below + | [StgLitArg (LitString bs)] <- args + , Just d <- decodeModifiedUTF8 bs + , idName i == unpackCStringName + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsStringA" [toJExpr d] + , ExprInline + ) + | [StgLitArg (LitString bs)] <- args + , Just d <- decodeModifiedUTF8 bs + , idName i == unpackCStringUtf8Name + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsString" [toJExpr d] + , ExprInline + ) + + -- let-no-escape + | Just n <- ctxLneBindingStackSize ctx i + = do + as' <- concatMapM genArg args + ei <- varForEntryId i + let ra = mconcat . reverse $ + zipWith (\r a -> toJExpr r |= a) [R1 ..] as' + p <- pushLneFrame n ctx + a <- adjSp 1 -- for the header (which will only be written when the thread is suspended) + return (ra <> p <> a <> returnS ei, ExprCont) + + -- proxy# + | [] <- args + , getUnique i == proxyHashKey + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return (top |= null_, ExprInline) + + -- unboxed tuple or strict type: return fields individually + | [] <- args + , isUnboxedTupleType (idType i) || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + return (a, ExprInline) + + -- Handle alternative heap object representation: in some cases, a heap + -- object is not represented as a JS object but directly as a number or a + -- string. I.e. only the payload is stored because the box isn't useful. + -- It happens for "Int Int#" for example: no need to box the Int# in JS. + -- + -- We must check that: + -- - the object is subject to the optimization (cf isUnboxable predicate) + -- - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we + -- need to evaluate it properly first. + -- + -- In which case we generate a dynamic check (using isObject) that either: + -- - returns the payload of the heap object, if it uses the generic heap + -- object representation + -- - returns the object directly, otherwise + | [] <- args + , [vt] <- idJSRep i + , isUnboxable vt + , ctxIsEvaluated i + = do + let c = head (concatMap typex_expr $ ctxTarget ctx) + is <- varsForId i + case is of + [i'] -> + return ( c |= if_ (isObject i') (closureField1 i') i' + , ExprInline + ) + _ -> panic "genApp: invalid size" + + -- case of Id without args and known to be already evaluated: return fields + -- individually + | [] <- args + , ctxIsEvaluated i || isStrictType (idType i) + = do + a <- storeIdFields i (ctxTarget ctx) + -- optional runtime assert for detecting unexpected thunks (unevaluated) + settings <- getSettings + let ww = case concatMap typex_expr (ctxTarget ctx) of + [t] | csAssertRts settings -> + ifS (isObject t .&&. isThunk t) + (appS throwStr [String "unexpected thunk"]) -- yuck + mempty + _ -> mempty + return (a `mappend` ww, ExprInline) + + + -- Case: "newtype" datacon wrapper + -- + -- If the wrapped argument is known to be already evaluated, then we don't + -- need to enter it. + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + = do + as <- concatMapM genArg args + case as of + [ai] -> do + let t = head (concatMap typex_expr (ctxTarget ctx)) + a' = case args of + [StgVarArg a'] -> a' + _ -> panic "genApp: unexpected arg" + if isStrictId a' || ctxIsEvaluated a' + then return (t |= ai, ExprInline) + else return (returnS (app (identFS hdEntry) [ai]), ExprCont) + _ -> panic "genApp: invalid size" + + -- no args and Id can't be a function: just enter it + | [] <- args + , idFunRepArity i == 0 + , not (mightBeFunTy (idType i)) + = do + enter_id <- genIdArg i >>= + \case + [x] -> return x + xs -> pprPanic "genApp: unexpected multi-var argument" + (vcat [ppr (length xs), ppr i]) + return (returnS (app (identFS hdEntry) [enter_id]), ExprCont) + + -- fully saturated global function: + -- - deals with arguments + -- - jumps into the function + | n <- length args + , n /= 0 + , idFunRepArity i == n + , not (isLocalId i) + , isStrictId i + = do + as' <- concatMapM genArg args + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i as' is + return (jmp, ExprCont) + + -- oversaturated function: + -- - push continuation with extra args + -- - deals with arguments + -- - jumps into the function + | idFunRepArity i < length args + , isStrictId i + , idFunRepArity i > 0 + = do + let (reg,over) = splitAt (idFunRepArity i) args + reg' <- concatMapM genArg reg + pc <- pushCont over + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToII i reg' is + return (pc <> jmp, ExprCont) + + -- generic apply: + -- - try to find a pre-generated apply function that matches + -- - use it if any + -- - otherwise use generic apply function h$ap_gen_fast + | otherwise + = do + is <- assignAll jsRegsFromR1 <$> varsForId i + jmp <- jumpToFast args is + return (jmp, ExprCont) + +-- avoid one indirection for global ids +-- fixme in many cases we can also jump directly to the entry for local? +jumpToII :: Id -> [JStgExpr] -> JStgStat -> G JStgStat +jumpToII i vars load_app_in_r1 + | isLocalId i = do + ii <- varForId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS (closureInfo ii) + ] + | otherwise = do + ei <- varForEntryId i + return $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , returnS ei + ] + +-- | Try to use a specialized pre-generated application function. +-- If there is none, use h$ap_gen_fast instead +jumpToFast :: HasDebugCallStack => [StgArg] -> JStgStat -> G JStgStat +jumpToFast args load_app_in_r1 = do + -- get JS expressions for every argument + -- Arguments may have more than one expression (e.g. Word64#) + vars <- concatMapM genArg args + -- try to find a specialized apply function + let spec = mkApplySpec RegsConv args vars + ap_fun <- selectApply spec + pure $ mconcat + [ assignAllReverseOrder jsRegsFromR2 vars + , load_app_in_r1 + , case ap_fun of + -- specialized apply: no tag + Right fun -> returnS (ApplExpr fun []) + -- generic apply: pass a tag indicating number of args/slots + Left fun -> returnS (ApplExpr fun [specTagExpr spec]) + ] + +-- | Calling convention for an apply function +data ApplyConv + = RegsConv -- ^ Fast calling convention: use registers + | StackConv -- ^ Slow calling convention: use the stack + deriving (Show,Eq,Ord) + +-- | Name of the generic apply function +genericApplyName :: ApplyConv -> FastString +genericApplyName = \case + RegsConv -> identFS hdApGenFastStr + StackConv -> identFS hdApGenStr + +-- | Expr of the generic apply function +genericApplyExpr :: ApplyConv -> JStgExpr +genericApplyExpr conv = global (genericApplyName conv) + + +-- | Return the name of the specialized apply function for the given number of +-- args, number of arg variables, and calling convention. +specApplyName :: ApplySpec -> FastString +specApplyName = \case + -- specialize a few for compiler performance (avoid building FastStrings over + -- and over for common cases) + ApplySpec RegsConv 0 0 -> "h$ap_0_0_fast" + ApplySpec StackConv 0 0 -> "h$ap_0_0" + ApplySpec RegsConv 1 0 -> "h$ap_1_0_fast" + ApplySpec StackConv 1 0 -> "h$ap_1_0" + ApplySpec RegsConv 1 1 -> "h$ap_1_1_fast" + ApplySpec StackConv 1 1 -> "h$ap_1_1" + ApplySpec RegsConv 1 2 -> "h$ap_1_2_fast" + ApplySpec StackConv 1 2 -> "h$ap_1_2" + ApplySpec RegsConv 2 1 -> "h$ap_2_1_fast" + ApplySpec StackConv 2 1 -> "h$ap_2_1" + ApplySpec RegsConv 2 2 -> "h$ap_2_2_fast" + ApplySpec StackConv 2 2 -> "h$ap_2_2" + ApplySpec RegsConv 2 3 -> "h$ap_2_3_fast" + ApplySpec StackConv 2 3 -> "h$ap_2_3" + ApplySpec conv nargs nvars -> mkFastString $ mconcat + [ "h$ap_", show nargs + , "_" , show nvars + , case conv of + RegsConv -> "_fast" + StackConv -> "" + ] + +-- | Return the expression of the specialized apply function for the given +-- number of args, number of arg variables, and calling convention. +-- +-- Warning: the returned function may not be generated! Use specApplyExprMaybe +-- if you want to ensure that it exists. +specApplyExpr :: ApplySpec -> JStgExpr +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. +-- Return Nothing if it isn't generated. +specApplyExprMaybe :: ApplySpec -> Maybe JStgExpr +specApplyExprMaybe spec = + if spec `elem` applySpec + then Just (specApplyExpr spec) + else Nothing + +-- | Make an ApplySpec from a calling convention, a list of Haskell args, and a +-- list of corresponding JS variables +mkApplySpec :: ApplyConv -> [StgArg] -> [JStgExpr] -> ApplySpec +mkApplySpec conv args vars = ApplySpec + { specConv = conv + , specArgs = length args + , specVars = length vars + } + +-- | Find a specialized application function if there is one +selectApply + :: ApplySpec + -> G (Either JStgExpr JStgExpr) -- ^ the function to call (Left for generic, Right for specialized) +selectApply spec = + case specApplyExprMaybe spec of + Just e -> return (Right e) + Nothing -> return (Left (genericApplyExpr (specConv spec))) + + +-- | Apply specification +data ApplySpec = ApplySpec + { specConv :: !ApplyConv -- ^ Calling convention + , specArgs :: !Int -- ^ number of Haskell arguments + , specVars :: !Int -- ^ number of JavaScript variables for the arguments + } + deriving (Show,Eq,Ord) + +-- | List of specialized apply function templates +applySpec :: [ApplySpec] +applySpec = [ ApplySpec conv nargs nvars + | conv <- [RegsConv, StackConv] + , nargs <- [0..4] + , nvars <- [max 0 (nargs-1)..(nargs*2)] + ] + +-- | Generate a tag for the given ApplySpec +-- +-- Warning: tag doesn't take into account the calling convention +specTag :: ApplySpec -> Int +specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. specArgs spec + +-- | Generate a tag expression for the given ApplySpec +specTagExpr :: ApplySpec -> JStgExpr +specTagExpr = toJExpr . specTag + +-- | Build arrays to quickly lookup apply functions +-- +-- h$apply[r << 8 | n] = function application for r regs, n args +-- h$paps[r] = partial application for r registers (number of args is in the object) +mkApplyArr :: JSM JStgStat +mkApplyArr = + do mk_ap_gens <- jFor (|= zero_) (.<. Int 65536) preIncrS + \j -> hdApply .! j |= hdApGen + mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS + \j -> hdPaps .! j |= hdPapGen + return $ mconcat + [ name hdApplyStr ||= toJExpr (JList []) + , name hdPapsStr ||= toJExpr (JList []) + , ApplStat (hdInitStatic .^ "push") + [ jLam' $ + mconcat + [ mk_ap_gens + , mk_pap_gens + , mconcat (map assignSpec applySpec) + , mconcat (map assignPap specPap) + ] + ] + ] + where + assignSpec :: ApplySpec -> JStgStat + assignSpec spec = case specConv spec of + -- 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 -> hdApply .! specTagExpr spec |= specApplyExpr spec + RegsConv -> mempty + + hdPap_ = unpackFS hdPapStr_ + + assignPap :: Int -> JStgStat + assignPap p = hdPaps .! toJExpr p |= global (mkFastString (hdPap_ ++ show p)) + +-- | Push a continuation on the stack +-- +-- First push the given args, then push an apply function (specialized if +-- possible, otherwise the generic h$ap_gen function). +pushCont :: HasDebugCallStack + => [StgArg] + -> G JStgStat +pushCont args = do + vars <- concatMapM genArg args + let spec = mkApplySpec StackConv args vars + selectApply spec >>= \case + Right app -> push $ reverse $ app : vars + Left app -> push $ reverse $ app : specTagExpr spec : vars + +-- | Generic stack apply function (h$ap_gen) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Stack layout: +-- -3: ... +-- -2: args +-- -1: tag (number of arg slots << 8 | number of args) +-- +-- Regs: +-- R1 = applied closure +-- +genericStackApply :: StgToJSConfig -> JSM JStgStat +genericStackApply cfg = closure info body + where + -- h$ap_gen body + body = jVar $ \cf -> + do fun <- fun_case cf (infoFunArity cf) + pap <- fun_case cf (papArity r1) + return $ + mconcat $ + [ traceRts cfg (jString $ identFS hdApGenStr) + , cf |= closureInfo r1 + -- switch on closure type + , SwitchStat (infoClosureType cf) + [ (toJExpr Thunk , thunk_case cfg cf) + , (toJExpr Fun , fun) + , (toJExpr Pap , pap) + , (toJExpr Blackhole, blackhole_case cfg) + ] + (default_case cf) + ] + + -- info table for h$ap_gen + info = ClosureInfo + { ciVar = hdApGenStr + , ciRegs = CIRegs 0 [PtrV] -- closure to apply to + , ciName = identFS hdApGenStr + , ciLayout = CILayoutVariable + , ciType = CIStackFrame + , ciStatic = mempty + } + + default_case cf = appS throwStr [jString "h$ap_gen: unexpected closure type " + + (infoClosureType cf)] + + thunk_case cfg cf = mconcat + [ profStat cfg pushRestoreCCS + , returnS cf + ] + + blackhole_case cfg = mconcat + [ 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) -> + do build_pap_payload <- loop 0 (.<. given_regs) + \i -> return $ mconcat [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)] + , postIncrS i + ] + load_reg_values <- loop 0 (.<. needed_regs) + \i -> return $ + mconcat [ traceRts cfg (jString "h$ap_gen: loading register: " + i) + , appS hdSetRegStr [ i+2 , stack .! (sp-2-i)] + , postIncrS i + ] + set_reg_values <- loop 0 (.<. given_regs) + \i -> return $ + mconcat [ appS hdSetRegStr [ i+2, stack .! (sp-2-i)] + , postIncrS i + ] + return $ + mconcat $ [ tag |= stack .! (sp - 1) -- tag on the stack + , given_args |= mask8 tag -- indicates the number of passed args + , given_regs |= tag .>>. 8 -- and the number of passed values for registers + , needed_args |= mask8 arity + , needed_regs |= arity .>>. 8 + , traceRts cfg (jString "h$ap_gen: args: " + given_args + + jString " regs: " + given_regs) + , ifBlockS (given_args .===. needed_args) + -------------------------------- + -- exactly saturated application + -------------------------------- + [ traceRts cfg (jString "h$ap_gen: exact") + -- Set registers to register values on the stack + , set_reg_values + -- drop register values from the stack + , sp |= sp - given_regs - 2 + -- enter closure in R1 + , returnS c + ] + [ ifBlockS (given_args .>. needed_args) + ---------------------------- + -- oversaturated application + ---------------------------- + [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args + + jString " regs: " + needed_regs) + + -- load needed register values + , load_reg_values + + -- 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 |= 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 .===. hdApGen ) + ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp - needed_regs - 1) + + -- Push generic application function as continuation + , stack .! sp |= newAp + + -- Push "current thread CCS restore" function as continuation + , profStat cfg pushRestoreCCS + + -- enter closure in R1 + , returnS c + ] + + ----------------------------- + -- undersaturated application + ----------------------------- + [ traceRts cfg (jString "h$ap_gen: undersat") + -- find PAP entry function corresponding to given_regs count + , p |= hdPaps .! given_regs + + -- build PAP payload: R1 + tag + given register values + , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args) + , dat |= toJExpr [r1, newTag] + , build_pap_payload + + -- remove register values from the stack. + , sp |= sp - given_regs - 2 + + -- alloc PAP closure, store reference to it in R1. + , r1 |= initClosure cfg p dat jCurrentCCS + + -- return to the continuation on the stack + , returnStack + ] + ] + ] + +-- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less +-- efficiently than other more specialized functions. +-- +-- Signature tag in argument. Tag: (regs << 8 | arity) +-- +-- Regs: +-- R1 = closure to apply to +-- +genericFastApply :: StgToJSConfig -> JSM JStgStat +genericFastApply s = + 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 |= infoFunArity c + , traceRts s (jString "h$ap_gen_fast: fun " + farity) + , fast_fun] + fast_pap <- jVar \parity -> + do fast_pap <- funCase c tag parity + return $ mconcat $ + [ parity |= papArity r1 + , traceRts s (jString "h$ap_gen_fast: pap " + parity) + , fast_pap + ] + return $ mconcat $ + [traceRts s (jString "h$ap_gen_fast: " + tag) + , c |= closureInfo r1 + , SwitchStat (infoClosureType c) + [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk") + <> push_stk_app + <> returnS c) + , (toJExpr Fun, fast_fun) + , (toJExpr Pap, fast_pap) + , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con") + <> jwhenS (tag .!=. 0) + (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, hdReturn] + <> returnS (app hdBlockOnBlackHoleStr [r1])) + ] $ appS throwStr [jString "h$ap_gen_fast: unexpected closure type: " + infoClosureType c] + ] + + where + -- thunk: push everything to stack frame, enter thunk first + pushStackApply :: JStgExpr -> JStgExpr -> JSM JStgStat + pushStackApply _c tag = + jVar \ap -> + do push_all_regs <- pushAllRegs tag + return $ mconcat $ + [ push_all_regs + , ap |= hdApply .! tag + , ifS (ap .===. hdApGen) + ((sp |= sp + 2) <> (stack .! (sp-1) |= tag)) + (sp |= sp + 1) + , stack .! sp |= ap + , profStat s pushRestoreCCS + ] + + funCase :: JStgExpr -> JStgExpr -> JStgExpr -> JSM JStgStat + funCase c tag arity = jVars $ + \(ar, myAr, myRegs, regsStart, newTag, newAp, dat, p) -> + + do get_regs <- loop 0 (.<. myRegs) $ + \i -> return $ + (dat .^ "push") `ApplStat` [app hdGetRegStr [i+2]] <> postIncrS i + push_args <- pushArgs regsStart myRegs + + return $ mconcat $ + [ ar |= mask8 arity + , myAr |= mask8 tag + , myRegs |= tag .>>. 8 + , traceRts s (jString "h$ap_gen_fast: args: " + myAr + + jString " regs: " + myRegs) + , ifS (myAr .===. ar) + -- call the function directly + (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c) + (ifBlockS (myAr .>. ar) + -- push stack frame with remaining args, then call fun + [ traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , regsStart |= (arity .>>. 8) + 1 + , sp |= sp + myRegs - regsStart + 1 + , traceRts s (jString "h$ap_gen_fast: oversat " + sp) + , push_args + , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar + , newAp |= hdApply .! newTag + , ifS (newAp .===. hdApGen) + ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag)) + (sp |= sp + 1) + , stack .! sp |= newAp + , profStat s pushRestoreCCS + , returnS c + ] + -- else + [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag) + , jwhenS (tag .!=. 0) $ mconcat + [ p |= hdPaps .! myRegs + , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr] + , get_regs + , r1 |= initClosure s p dat jCurrentCCS + ] + , returnStack + ]) + ] + + pushAllRegs :: JStgExpr -> JSM JStgStat + pushAllRegs tag = + jVar \regs -> + return $ mconcat $ + [ regs |= tag .>>. 8 + , sp |= sp + regs + , SwitchStat regs (map pushReg [65,64..2]) mempty + ] + where + pushReg :: Int -> (JStgExpr, JStgStat) + pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r) + + pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat + pushArgs start end = + loop end (.>=.start) + \i -> return $ + traceRts s (jString "pushing register: " + i) + <> (stack .! (sp + start - i) |= app hdGetRegStr [i+1]) + <> postDecrS i + +-- | Make specialized apply function for the given ApplySpec +specApply :: StgToJSConfig -> ApplySpec -> JSM JStgStat +specApply cfg spec@(ApplySpec conv nargs nvars) = + let fun_name = specApplyName spec + in case conv of + RegsConv -> fastApply cfg fun_name nargs nvars + StackConv -> stackApply cfg fun_name nargs nvars + +-- | Make specialized apply function with Stack calling convention +stackApply + :: StgToJSConfig + -> FastString + -> Int + -> Int + -> JSM JStgStat +stackApply s fun_name nargs nvars = + -- special case for h$ap_0_0 + if nargs == 0 && nvars == 0 + then closure info0 body0 + else closure info body + where + 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 + + body = jVar $ \c -> + do fun_case <- funCase c + pap_case <- papCase c + return $ mconcat + [ c |= closureInfo r1 + , traceRts s (toJExpr fun_name + + jString " " + + (c .^ "n") + + jString " sp: " + sp + + jString " a: " + (c .^ "a")) + , 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, 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 + stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars] + + papCase :: JStgExpr -> JSM JStgStat + papCase c = jVars \(expr, arity0, arity) -> + do oversat_case <- oversatCase c arity0 arity + return $ mconcat $ + case expr of + ValExpr (JVar pap) -> [ arity0 |= papArity r1 + , arity |= mask8 arity0 + , traceRts s (toJExpr (fun_name <> ": found pap, arity: ") + arity) + , ifS (toJExpr nargs .===. arity) + --then + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + -- else + (ifS (toJExpr nargs .>. arity) + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversat_case) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars + 1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + funCase :: JStgExpr -> JSM JStgStat + funCase c = jVars \(expr, ar0, ar) -> + do oversat_case <- oversatCase c ar0 ar + return $ mconcat $ + case expr of + ValExpr (JVar pap) -> [ ar0 |= infoFunArity c + , ar |= mask8 ar0 + , ifS (toJExpr nargs .===. ar) + (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c) + (ifS (toJExpr nargs .>. ar) + (traceRts s (toJExpr (fun_name <> ": oversat")) + <> oversat_case) + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap (toJExpr R1) (toJExpr nargs) stackArgs + <> (sp |= sp - toJExpr (nvars+1)) + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + + -- oversat: call the function but keep enough on the stack for the next + oversatCase :: JStgExpr -- function + -> JStgExpr -- the arity tag + -> JStgExpr -- real arity (arity & 0xff) + -> JSM JStgStat + oversatCase c arity arity0 = + jVars \(rs, newAp) -> + return $ mconcat $ + [ rs |= (arity .>>. 8) + , loadRegs rs + , sp |= sp - rs + , 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")) + , returnS c + ] + where + loadRegs rs = SwitchStat rs switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [nvars,nvars-1..1] + +-- | Make specialized apply function with Regs calling convention +-- +-- h$ap_n_r_fast is entered if a function of unknown arity is called, n +-- arguments are already in r registers +fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JSM JStgStat +fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0 + -- special case for h$ap_0_0_fast + then jFunction' func ap_fast + -- general case + else jFunction' func body + where + func = name fun_name + ap_fast :: JSM JStgStat + ap_fast = enter s r1 + + regArgs = take nvars jsRegsFromR2 + + mkAp :: Int -> Int -> [JStgExpr] + mkAp n' r' = [ specApplyExpr (ApplySpec StackConv n' r') ] + + body = jVars $ \(c, farity, arity) -> + do fun_case_fun <- funCase c farity + fun_case_pap <- funCase c arity + return $ mconcat $ + [ c |= closureInfo r1 + , traceRts s (toJExpr (fun_name <> ": sp ") + sp) + , SwitchStat (infoClosureType c) + [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ") + + clName c + + jString " (arity: " + (c .^ "a") + jString ")") + <> (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, global "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))] + (appS throwStr [toJExpr (fun_name <> ": unexpected closure type: ") + infoClosureType c]) + ] + + funCase :: JStgExpr -> JStgExpr -> JSM JStgStat + funCase c arity = jVars \(arg, ar) -> + do oversat_case <- oversatCase c arity + return $ mconcat $ + case arg of + ValExpr (JVar pap) -> [ ar |= mask8 arity + , ifS (toJExpr nargs .===. ar) + -- then + (traceRts s (toJExpr (fun_name <> ": exact")) <> returnS c) + -- else + (ifS (toJExpr nargs .>. ar) + --then + (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversat_case) + -- else + (traceRts s (toJExpr (fun_name <> ": undersat")) + <> mkPap s pap r1 (toJExpr nargs) regArgs + <> (r1 |= toJExpr pap) + <> returnStack)) + ] + _ -> mempty + + oversatCase :: JStgExpr -> JStgExpr -> JSM JStgStat + oversatCase c arity = + jVars \(rs, rsRemain) -> + return $ mconcat $ + [ rs |= arity .>>. 8 + , rsRemain |= toJExpr nvars - rs + , traceRts s (toJExpr + (fun_name <> " regs oversat ") + + rs + + jString " remain: " + + rsRemain) + , saveRegs rs + , sp |= sp + rsRemain + 1 + , stack .! sp |= hdApply .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity)) + , profStat s pushRestoreCCS + , returnS c + ] + where + saveRegs n = SwitchStat n switchAlts mempty + where + switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1] + +zeroApply :: StgToJSConfig -> JSM JStgStat +zeroApply s = jFunction hdEntry + $ \(MkSolo c) -> fmap ((r1 |= c) <>) $ enter s c + +-- carefully enter a closure that might be a thunk or a function + +-- ex may be a local var, but must've been copied to R1 before calling this +enter :: StgToJSConfig -> JStgExpr -> JSM JStgStat +enter s ex = jVar \c -> + return $ mconcat $ + [ 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 [hdAp00, ex, hdReturn] + <> returnS (app hdBlockOnBlackHoleStr [ex])) + ] (returnS c) + ] + +updates :: StgToJSConfig -> JSM JStgStat +updates s = do + upd_frm <- update_frame + upd_frm_lne <- update_frame_lne + return $ BlockStat [upd_frm, upd_frm_lne] + where + unbox_closure f1 = Closure { clInfo = hdUnboxEntry -- global "h$unbox_e" + , clField1 = f1 + , clField2 = null_ + , clMeta = 0 + , clCC = Nothing + } + upd_loop' ss' si' sir' = loop zero_ (.<. ss' .^ "length") + $ \i -> return $ mconcat + [ si' |= ss' .! i + , sir' |= (closureField2 si') `ApplExpr` [r1] + , ifS (app "typeof" [sir'] .===. jTyObject) + (copyClosure DontCopyCC si' sir') + (assignClosure si' $ unbox_closure sir') + , postIncrS i + ] + update_frame = closure + (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 hdWakeupThread [waiters .! i] + <> postIncrS i + let updateCC updatee = closureCC updatee |= jCurrentCCS + + return $ mconcat $ + [ updatee |= stack .! (sp - 1) + , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc") + , -- wake up threads blocked on blackhole + waiters |= closureField2 updatee + , jwhenS (waiters .!==. null_) wake_thread_loop + , -- update selectors + 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: " + ((closureInfo r1) .^ "n")) + , copyClosure DontCopyCC updatee r1 + ]) + -- the heap object is represented by another type of value + -- (e.g. a JS number or string) so the unboxing closure + -- will simply return it. + (assignClosure updatee (unbox_closure r1)) + , profStat s (updateCC updatee) + , adjSpN' 2 + , traceRts s (jString "h$upd_frame: updating: " + + updatee + + jString " -> " + + r1) + , returnStack + ] + + update_frame_lne = closure + (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 + , adjSpN' 2 + , traceRts s (jString "h$upd_frame_lne: updating: " + + updateePos + + jString " -> " + + r1) + , returnStack + ] + +selectors :: StgToJSConfig -> JSM JStgStat +selectors s = + do + sel_one <- mkSel "1" closureField1 + sel_twoA <- mkSel "2a" closureField2 + sel_twoB <- mkSel "2b" (closureField1 . closureField2) + 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)) + (name $ mkFastString ("d" ++ show (x-1)))) + + + mkSel :: FastString -> (JStgExpr -> JStgExpr) -> JSM JStgStat + mkSel name_ sel = mconcat <$> sequence + [jFunction (name createName) $ + \(MkSolo r) -> return $ mconcat + [ 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 (name resName) $ + \(MkSolo r) -> return $ mconcat + [ traceRts s (toJExpr ("selector result: " <> name_ <> " for ") + (r .^ "alloc")) + , returnS (sel r) + ] + , closure + (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")) + , ifS (isThunk tgt .||. isBlackhole tgt) + (preIncrS sp + <> (stack .! sp |= global frameName) + <> returnS (app "h$e" [tgt])) + (returnS (app "h$e" [sel tgt])) + ]) + , closure + (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_)) + , postDecrS sp + , returnS (app "h$e" [sel r1]) + ] + ] + + where + v x = JVar (name x) + n ext = "h$c_sel_" <> name_ <> ext + createName = n "" + resName = n "_res" + entryName = n "_e" + frameName = n "_frame_e" + + +-- arity is the remaining arity after our supplied arguments are applied +mkPap :: StgToJSConfig + -> Ident -- ^ id of the pap object + -> JStgExpr -- ^ the function that's called (can be a second pap) + -> JStgExpr -- ^ number of arguments in pap + -> [JStgExpr] -- ^ values for the supplied arguments + -> JStgStat +mkPap s tgt fun n values = + traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items") + `mappend` + allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values') + (if csProf s then Just jCurrentCCS else Nothing) + where + papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n + + values' | GHC.Prelude.null values = [null_] + | otherwise = values + entry | length values > numSpecPap = name "h$pap_gen" + | otherwise = specPapIdents ! length values + +-- | Number of specialized PAPs (pre-generated for a given number of args) +numSpecPap :: Int +numSpecPap = 6 + +-- specialized (faster) pap generated for [0..numSpecPap] +-- others use h$pap_gen +specPap :: [Int] +specPap = [0..numSpecPap] + +-- | Cache of specialized PAP idents +specPapIdents :: Array Int Ident +specPapIdents = listArray (0,numSpecPap) $ map (name . mkFastString . ("h$pap_"++) . show) specPap + +pap :: StgToJSConfig + -> Int + -> JSM JStgStat +pap s r = closure (ClosureInfo + { ciVar = funcIdent + , ciRegs = CIRegsUnknown + , ciName = funcName + , ciLayout = CILayoutUnknown (r+2) + , ciType = CIPap + , ciStatic = mempty + }) body + where + funcIdent = name funcName + funcName = mkFastString ("h$pap_" ++ show r) + + body = jVars $ \(c, d, f, extra) -> + return $ mconcat $ + [ c |= closureField1 r1 + , d |= closureField2 r1 + , 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 + , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra) + , moveBy extra + , loadOwnArgs d + , r1 |= c + , returnS f + ] + moveBy extra = SwitchStat extra + (reverse $ map moveCase [1..maxReg-r-1]) mempty + 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 (name . mkFastString $ ('d':show (n-1))) + +-- Construct a generic PAP +papGen :: StgToJSConfig -> JSM JStgStat +papGen cfg = + 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 |= closureInfo c + , pr |= funOrPapArity c (Just f) .>>. 8 + , or |= papArity r1 .>>. 8 + , r |= pr - or + , assertRts cfg + (isFun' f .||. isPap' f) + (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 hdMoveRegs2 [or, r] + , loadOwnArgs d r + , r1 |= c + , returnS f + ]) + + + where + 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) + in SwitchStat r (map loadOwnArg [127,126..1]) mempty + +-- general utilities +-- move the first n registers, starting at R2, m places up (do not use with negative m) +moveRegs2 :: JSM JStgStat +moveRegs2 = jFunction (name hdMoveRegs2) moveSwitch + where + moveSwitch (n,m) = defaultCase n m >>= return . SwitchStat ((n .<<. 8) .|. m) switchCases + -- fast cases + switchCases = [switchCase n m | n <- [1..5], m <- [1..4]] + switchCase :: Int -> Int -> (JStgExpr, JStgStat) + switchCase n m = (toJExpr $ + (n `Bits.shiftL` 8) Bits..|. m + , mconcat (map (`moveRegFast` m) [n+1,n..2]) + <> BreakStat Nothing {-[j| break; |]-}) + moveRegFast n m = jsReg (n+m) |= jsReg n + -- fallback + defaultCase n m = + loop n (.>.0) (\i -> return $ + 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 info values ccs = app hdInitClosure + [ newClosure $ Closure + { clInfo = info + , clField1 = null_ + , clField2 = null_ + , clMeta = 0 + , clCC = if csProf cfg then Just ccs else Nothing + } + , values + ] + +-- | Return an expression for every field of the given Id +getIdFields :: Id -> G [TypedExpr] +getIdFields i = assocIdExprs i <$> varsForId i + +-- | Store fields of Id into the given target expressions +storeIdFields :: Id -> [TypedExpr] -> G JStgStat storeIdFields i dst = do fields <- getIdFields i pure (assignCoerce1 dst fields) diff --git a/GHC/StgToJS/Arg.hs b/GHC/StgToJS/Arg.hs --- a/GHC/StgToJS/Arg.hs +++ b/GHC/StgToJS/Arg.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -21,16 +22,14 @@ , genIdArgI , genIdStackArgI , allocConStatic - , allocUnboxedConStatic - , allocateStaticList - , jsStaticArg , jsStaticArgs ) where import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import GHC.JS.Make import GHC.StgToJS.DataCon @@ -67,7 +66,7 @@ // a JS object for an Int8 var anInt8 = { d1 = - , f : entry function which would scrutinize the payload + , f : info table / entry function which would scrutinize the payload } we instead generate: @@ -118,7 +117,7 @@ Nothing -> reg Just expr -> unfloated expr where - r = uTypeVt . stgArgType $ a + r = primOrVoidRepToJSRep $ stgArgRep1 a reg | isVoid r = return [] @@ -127,23 +126,23 @@ | i == falseDataConId = return [StaticLitArg (BoolLit False)] | isMultiVar r = - map (\(TxtI t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj? - | otherwise = (\(TxtI it) -> [StaticObjArg it]) <$> identForId i + map (\(identFS -> t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj? + | otherwise = (\(identFS -> it) -> [StaticObjArg it]) <$> identForId i unfloated :: CgStgExpr -> G [StaticArg] unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l unfloated (StgConApp dc _n args _) | isBoolDataCon dc || isUnboxableCon dc = (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon? - | null args = (\(TxtI t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc) + | null args = (\(identFS -> t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc) | otherwise = do as <- concat <$> mapM genStaticArg args - (TxtI e) <- identForDataConWorker dc + e <- identFS <$> identForDataConWorker dc return [StaticConArg e as] unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) -- | Generate JS code for an StgArg -genArg :: HasDebugCallStack => StgArg -> G [JExpr] +genArg :: HasDebugCallStack => StgArg -> G [JStgExpr] genArg a = case a of StgLitArg l -> genLit l StgVarArg i -> do @@ -159,10 +158,10 @@ where -- if our argument is a joinid, it can be an unboxed tuple - r :: HasDebugCallStack => VarType - r = uTypeVt . stgArgType $ a + r :: HasDebugCallStack => JSRep + r = primOrVoidRepToJSRep $ stgArgRep1 a - unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr] + unfloated :: HasDebugCallStack => CgStgExpr -> G [JStgExpr] unfloated = \case StgLit l -> genLit l StgConApp dc _n args _ @@ -176,8 +175,8 @@ return [allocDynamicE inl_alloc e as Nothing] x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x) --- | Generate a Var as JExpr -genIdArg :: HasDebugCallStack => Id -> G [JExpr] +-- | Generate a Var as JStgExpr +genIdArg :: HasDebugCallStack => Id -> G [JStgExpr] genIdArg i = genArg (StgVarArg i) -- | Generate an Id as an Ident @@ -187,7 +186,7 @@ | isMultiVar r = mapM (identForIdN i) [1..varSize r] | otherwise = (:[]) <$> identForId i where - r = uTypeVt . idType $ i + r = unaryTypeJSRep . idType $ i -- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)] @@ -198,7 +197,7 @@ -- | Allocate Static Constructors allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G () -allocConStatic (TxtI to) cc con args = do +allocConStatic (identFS -> to) cc con args = do as <- mapM genStaticArg args cc' <- costCentreStackLbl cc allocConStatic' cc' (concat as) @@ -212,8 +211,8 @@ | isBoolDataCon con && dataConTag con == 2 = emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc' | otherwise = do - (TxtI e) <- identForDataConWorker con - emitStatic to (StaticData e []) cc' + e <- identFS <$> identForDataConWorker con + emitStatic to (StaticApp SAKData e []) cc' allocConStatic' cc' [x] | isUnboxableCon con = case x of @@ -231,8 +230,8 @@ (a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1 _ -> panic "allocConStatic: invalid args for consDataCon" else do - (TxtI e) <- identForDataConWorker con - emitStatic to (StaticData e xs) cc' + e <- identFS <$> identForDataConWorker con + emitStatic to (StaticApp SAKData e xs) cc' -- | Allocate unboxed constructors allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg @@ -272,14 +271,14 @@ allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list" -- | Generate JS code corresponding to a static arg -jsStaticArg :: StaticArg -> JExpr +jsStaticArg :: StaticArg -> JStgExpr jsStaticArg = \case StaticLitArg l -> toJExpr l - StaticObjArg t -> ValExpr (JVar (TxtI t)) + StaticObjArg t -> global t StaticConArg c args -> - allocDynamicE False (ValExpr . JVar . TxtI $ 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] -> JExpr +jsStaticArgs :: [StaticArg] -> JStgExpr jsStaticArgs = ValExpr . JList . map jsStaticArg diff --git a/GHC/StgToJS/Closure.hs b/GHC/StgToJS/Closure.hs --- a/GHC/StgToJS/Closure.hs +++ b/GHC/StgToJS/Closure.hs @@ -28,10 +28,11 @@ 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.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Ident import GHC.Types.Unique.Map @@ -39,18 +40,23 @@ import Data.Monoid import qualified Data.Bits as Bits -closureInfoStat :: Bool -> ClosureInfo -> JStat -closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs) - = setObjInfoL debug obj rs layout ty name tag srefs +-- | 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 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 @@ -67,7 +73,7 @@ -> FastString -- ^ object name, for printing -> Int -- ^ `a' argument, depends on type (arity, conid) -> CIStatic -- ^ static refs - -> JStat + -> JStgStat setObjInfoL debug obj rs layout t n a = setObjInfo debug obj t n field_types a size rs where @@ -77,8 +83,9 @@ CILayoutFixed sz _ -> sz field_types = case layout of CILayoutVariable -> [] - CILayoutUnknown size -> toTypeList (replicate size ObjV) - CILayoutFixed _ fs -> toTypeList fs + CILayoutUnknown size -> to_type_list (replicate size ObjV) + CILayoutFixed _ fs -> to_type_list fs + to_type_list = concatMap (\x -> replicate (varSize x) (fromEnum x)) setObjInfo :: Bool -- ^ debug: output all symbol names -> Ident -- ^ the thing to modify @@ -89,7 +96,7 @@ -> Int -- ^ object size, -1 (number of vars) for unknown -> CIRegs -- ^ things in registers -> CIStatic -- ^ static refs - -> JStat + -> JStgStat setObjInfo debug obj t name fields a size regs static | debug = appS "h$setObjInfo" [ toJExpr obj , toJExpr t @@ -110,31 +117,42 @@ where regTag CIRegsUnknown = -1 regTag (CIRegs skip types) = - let nregs = sum $ map varSize types + let nregs = sum $ fmap varSize types in skip + (nregs `Bits.shiftL` 8) -closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@ - -> JStat -- ^ rhs - -> JStat -closure ci body = (jFun (ciVar ci) body) `mappend` closureInfoStat False ci +-- | 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 +closure ci body = do + f <- jFunction' (ciVar ci) body + return $ f `mappend` closureInfoStat False ci -conClosure :: Ident -> FastString -> CILayout -> Int -> JStat -conClosure symbol name layout constr = - closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty) - (returnS (stack .! sp)) +conClosure :: Ident -> FastString -> CILayout -> Int -> JSM JStgStat +conClosure symbol name layout constr = closure ci body + where + 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 :: JExpr - , clField1 :: JExpr - , clField2 :: JExpr - , clMeta :: JExpr - , clCC :: Maybe JExpr + { clInfo :: JStgExpr -- ^ InfoTable object + , clField1 :: JStgExpr -- ^ Payload field 1 + , clField2 :: JStgExpr -- ^ Payload field 2 + , clMeta :: JStgExpr + , clCC :: Maybe JStgExpr } -newClosure :: Closure -> JExpr +newClosure :: Closure -> JStgExpr newClosure Closure{..} = - let xs = [ (closureEntry_ , clEntry) + let xs = [ (closureInfo_ , clInfo) , (closureField1_, clField1) , (closureField2_, clField2) , (closureMeta_ , clMeta) @@ -145,9 +163,9 @@ Nothing -> ValExpr (jhFromList xs) Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs) -assignClosure :: JExpr -> Closure -> JStat +assignClosure :: JStgExpr -> Closure -> JStgStat assignClosure t Closure{..} = BlockStat - [ closureEntry t |= clEntry + [ closureInfo t |= clInfo , closureField1 t |= clField1 , closureField2 t |= clField2 , closureMeta t |= clMeta @@ -157,9 +175,9 @@ data CopyCC = CopyCC | DontCopyCC -copyClosure :: CopyCC -> JExpr -> JExpr -> JStat +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 @@ -167,9 +185,9 @@ DontCopyCC -> mempty CopyCC -> closureCC t |= closureCC s -mkClosure :: JExpr -> [JExpr] -> JExpr -> Maybe JExpr -> Closure -mkClosure entry fields meta cc = Closure - { clEntry = entry +mkClosure :: JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure +mkClosure info fields meta cc = Closure + { clInfo = info , clField1 = x1 , clField2 = x2 , clMeta = meta @@ -183,7 +201,7 @@ [] -> null_ [_] -> null_ [_,x] -> x - _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (map dataFieldName [1..]) (x:xs) + _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (fmap dataFieldName [1..]) (x:xs) ------------------------------------------------------------------------------- @@ -193,7 +211,7 @@ -- | Cache "dXXX" field names dataFieldCache :: Array Int FastString -dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) +dataFieldCache = listArray (0,nFieldCache) (fmap (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) -- | Data names are used in the AST, and logging has determined that 255 is the maximum number we see. nFieldCache :: Int @@ -211,33 +229,34 @@ -- | Cache "h$dXXX" names dataCache :: Array Int FastString -dataCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount]) +dataCache = listArray (0,jsClosureCount) (fmap (mkFastString . ("h$d"++) . show) [(0::Int)..jsClosureCount]) dataName :: Int -> FastString dataName i | i < 0 || i > nFieldCache = mkFastString ("h$d" ++ show i) | otherwise = dataCache ! i -allocData :: Int -> JExpr -allocData i = toJExpr (TxtI (dataName i)) +allocData :: Int -> JStgExpr +allocData i = toJExpr (global (dataName i)) -- | Cache "h$cXXX" names clsCache :: Array Int FastString -clsCache = listArray (0,jsClosureCount) (map (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount]) +clsCache = listArray (0,jsClosureCount) (fmap (mkFastString . ("h$c"++) . show) [(0::Int)..jsClosureCount]) clsName :: Int -> FastString clsName i | i < 0 || i > jsClosureCount = mkFastString ("h$c" ++ show i) | otherwise = clsCache ! i -allocClsA :: Int -> JExpr -allocClsA i = toJExpr (TxtI (clsName i)) +allocClsA :: Int -> JStgExpr +allocClsA i = toJExpr (global (clsName i)) -- | Cache "xXXX" names varCache :: Array Int Ident -varCache = listArray (0,jsClosureCount) (map (TxtI . 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 = TxtI $ mkFastString ('x' : show i) + | i < 0 || i > jsClosureCount = name $ mkFastString ('x' : show i) | otherwise = varCache ! i + diff --git a/GHC/StgToJS/CodeGen.hs b/GHC/StgToJS/CodeGen.hs --- a/GHC/StgToJS/CodeGen.hs +++ b/GHC/StgToJS/CodeGen.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} -- | JavaScript code generator module GHC.StgToJS.CodeGen @@ -10,16 +11,17 @@ import GHC.Prelude -import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) +import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js, Opt_D_dump_stg_from_js_sinker)) import GHC.JS.Ppr -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import GHC.JS.Make import GHC.JS.Transform import GHC.JS.Optimizer import GHC.StgToJS.Arg -import GHC.StgToJS.Sinker +import GHC.StgToJS.Sinker.Sinker import GHC.StgToJS.Types import qualified GHC.StgToJS.Object as Object import GHC.StgToJS.Utils @@ -46,6 +48,7 @@ import GHC.Types.RepType import GHC.Types.Id import GHC.Types.Unique +import GHC.Types.Unique.FM (nonDetEltsUFM) import GHC.Data.FastString import GHC.Utils.Encoding @@ -58,6 +61,7 @@ import qualified Data.Set as S import Data.Monoid +import Data.List (sortBy) import Control.Monad import System.Directory import System.FilePath @@ -79,7 +83,8 @@ -- TODO: avoid top level lifting in core-2-core when the JS backend is -- enabled instead of undoing it here - -- TODO: add dump pass for optimized STG ast for JS + putDumpFileMaybe logger Opt_D_dump_stg_from_js_sinker "STG Optimized JS Sinker:" FormatSTG + (pprGenStgTopBindings (StgPprOpts False) stg_binds) (deps,lus) <- runG config this_mod unfloated_binds $ do ifProfilingM $ initCostCentres cccs @@ -93,7 +98,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) @@ -133,15 +138,15 @@ glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( jsOptimize . - satJStat (Just $ modulePrefix m 1) + let stat = ( jStgStatToJS $ mconcat (reverse glbl) <> staticInit) + let opt_stat = jsOptimize stat let syms = [moduleGlobalSymbol m] let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = [] - , oiStat = stat + , oiStat = opt_stat , oiRaw = mempty , oiFExports = [] , oiFImports = [] @@ -196,26 +201,21 @@ => CgStgTopBinding -> Int -> G (Maybe LinkableUnit) - generateBlock top_bind n = case top_bind of + generateBlock top_bind _n = case top_bind of StgTopStringLit bnd str -> do bids <- identsForId bnd case bids of - [(TxtI b1t),(TxtI b2t)] -> do - -- [e1,e2] <- genLit (MachStr str) + [(identFS -> b1t),(identFS -> b2t)] -> do emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing - _extraTl <- State.gets (ggsToplevelStats . gsGroup) si <- State.gets (ggsStatic . gsGroup) - let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2 - let stat = jsOptimize - $ satJStat (Just $ modulePrefix m n) body let ids = [bnd] - syms <- (\(TxtI i) -> [i]) <$> identForId bnd + syms <- (\(identFS -> i) -> [i]) <$> identForId bnd let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = si - , oiStat = stat + , oiStat = mempty , oiRaw = "" , oiFExports = [] , oiFImports = [] @@ -245,15 +245,15 @@ let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = jsOptimize - . satJStat (Just $ modulePrefix m n) + stat = jStgStatToJS $ mconcat (reverse extraTl) <> tl - syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps + let opt_stat = jsOptimize stat + syms <- mapM (fmap (\(identFS -> i) -> i) . identForId) topDeps let oi = ObjBlock { oiSymbols = syms , oiClInfo = ci , oiStatic = si - , oiStat = stat + , oiStat = opt_stat , oiRaw = "" , oiFExports = [] , oiFImports = fRefs @@ -271,23 +271,18 @@ pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu -- | variable prefix for the nth block in module -modulePrefix :: Module -> Int -> FastString -modulePrefix m n = - let encMod = zEncodeString . moduleNameString . moduleName $ m - in mkFastString $ "h$" ++ encMod ++ "_id_" ++ show n -genToplevel :: CgStgBinding -> G JStat +genToplevel :: CgStgBinding -> G JStgStat genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs genToplevel (StgRec bs) = mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs -genToplevelDecl :: Id -> CgStgRhs -> G JStat +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 JStat +genToplevelConEntry :: Id -> CgStgRhs -> G () genToplevelConEntry i rhs = case rhs of StgRhsCon _cc con _mu _ts _args _typ | isDataConWorkId i @@ -295,29 +290,28 @@ 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 JStat +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 uTypeVt 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 -> JStat +mkDataEntry :: Ident -> JStgStat mkDataEntry i = FuncStat i [] returnStack -genToplevelRhs :: Id -> CgStgRhs -> G JStat +genToplevelRhs :: Id -> CgStgRhs -> G JStgStat -- general cases: genToplevelRhs i rhs = case rhs of StgRhsCon cc con _mu _tys args _typ -> do @@ -332,37 +326,45 @@ - order by increasing use - prepend loading lives var to body: body can stay the same -} - eid@(TxtI eidt) <- identForEntryId i - (TxtI idt) <- identForId i + eid <- identForEntryId i + idt <- identFS <$> identForId i body <- genBody (initExprCtx i) R2 args body typ - global_occs <- globalOccs (satJStat (Just "ghcjs_tmp_sat_") body) - let lidents = map global_ident global_occs - let lids = map global_id global_occs + occs <- globalOccs body + let lids = global_id <$> (sortBy cmp_cnt $ nonDetEltsUFM occs) + -- Regenerate idents from lids to restore right order of representatives. + -- Representatives have occurrence order which can be mixed. + lidents <- concat <$> traverse identsForId lids + let eidt = identFS eid let lidents' = map identFS lidents CIStaticRefs sr0 <- genStaticRefsRhs rhs let sri = filter (`notElem` lidents') sr0 sr = CIStaticRefs sri et <- genEntryType args ll <- loadLiveFun lids - (static, regs, upd) <- + (appK, regs, upd) <- if et == CIThunk then do r <- updateThunk - pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r) - else return (StaticFun eidt (map StaticObjArg lidents'), - (if null lidents then CIRegs 1 (concatMap idVt args) - else CIRegs 0 (PtrV : concatMap idVt args)) - , mempty) + pure (SAKThunk, CIRegs 0 [PtrV], r) + else + let regs = if null lidents then CIRegs 1 (concatMap idJSRep args) + else CIRegs 0 (PtrV : concatMap idJSRep args) + in pure (SAKFun, regs, mempty) setcc <- ifProfiling $ if et == CIThunk then enterCostCentreThunk else enterCostCentreFun cc - emitClosureInfo (ClosureInfo eid - regs - idt - (fixedLayout $ map (uTypeVt . 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 + emitStatic idt (StaticApp appK eidt $ map StaticObjArg lidents') ccId return $ (FuncStat eid [] (ll <> upd <> setcc <> body)) + where + cmp_cnt :: GlobalOcc -> GlobalOcc -> Ordering + cmp_cnt g1 g2 = compare (global_count g1) (global_count g2) diff --git a/GHC/StgToJS/DataCon.hs b/GHC/StgToJS/DataCon.hs --- a/GHC/StgToJS/DataCon.hs +++ b/GHC/StgToJS/DataCon.hs @@ -27,9 +27,10 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax -import GHC.JS.Transform +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import GHC.JS.Make +import GHC.JS.Transform import GHC.StgToJS.Closure import GHC.StgToJS.ExprCtx @@ -49,26 +50,26 @@ import Data.Maybe -- | Generate a data constructor. Special handling for unboxed tuples -genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat +genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat genCon ctx con args | isUnboxedTupleDataCon con = return $ assignToExprCtx ctx args - | [ValExpr (JVar ctxi)] <- concatMap typex_expr (ctxTarget ctx) + | [Var ctxi] <- concatMap (typex_expr) (ctxTarget ctx) = allocCon ctxi con currentCCS args | xs <- concatMap typex_expr (ctxTarget ctx) = pprPanic "genCon: unhandled DataCon" (ppr (con - , satJExpr Nothing <$> args - , satJExpr Nothing <$> xs + , map jStgExprToJS args + , map jStgExprToJS xs )) -- | Allocate a data constructor. Allocate in this context means bind the data -- constructor to 'to' -allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat +allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat allocCon to con cc xs | isBoolDataCon con || isUnboxableCon con = - return (toJExpr to |= allocUnboxedCon con xs) + return $ AssignStat (Var to) AssignOp (allocUnboxedCon con xs) {- | null xs = do i <- varForId (dataConWorkId con) return (assignj to i) -} @@ -82,32 +83,32 @@ -- | Allocate an unboxed data constructor. If we have a bool we calculate the -- right value. If not then we expect a singleton list and unbox by converting -- ''C x' to 'x'. NB. This function may panic. -allocUnboxedCon :: DataCon -> [JExpr] -> JExpr +allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr allocUnboxedCon con = \case [] | isBoolDataCon con && dataConTag con == 1 -> false_ | isBoolDataCon con && dataConTag con == 2 -> true_ [x] | isUnboxableCon con -> x - xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, satJExpr Nothing <$> xs)) + xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, map jStgExprToJS xs)) -- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig - -> JExpr - -> [JExpr] - -> Maybe JExpr - -> JExpr + -> JStgExpr + -> [JStgExpr] + -> Maybe JStgExpr + -> JStgExpr allocDynamicE inline_alloc entry free cc | inline_alloc || length free > jsClosureCount - = newClosure $ mkClosure entry free (ValExpr (JInt 0)) cc - | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc) + = newClosure $ mkClosure entry free zero_ cc + | otherwise = ApplExpr allocFun (entry : free ++ maybeToList cc) where allocFun = allocClsA (length free) -- | Allocate a dynamic object -allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat +allocDynamic :: StgToJSConfig -> Bool -> Ident -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgStat allocDynamic s need_decl to entry free cc | need_decl = DeclStat to (Just value) - | otherwise = toJExpr to |= value + | otherwise = AssignStat (Var to) AssignOp value where value = allocDynamicE (csInlineAlloc s) entry free cc diff --git a/GHC/StgToJS/Deps.hs b/GHC/StgToJS/Deps.hs --- a/GHC/StgToJS/Deps.hs +++ b/GHC/StgToJS/Deps.hs @@ -26,7 +26,7 @@ import GHC.StgToJS.Types import GHC.StgToJS.Ids -import GHC.JS.Unsat.Syntax +import GHC.JS.Ident import GHC.Types.Id import GHC.Types.Unique @@ -48,7 +48,6 @@ import qualified GHC.Data.Word64Map as WM import GHC.Data.Word64Map (Word64Map) import Data.Array -import Data.Either import Data.Word import Control.Monad @@ -101,9 +100,9 @@ -> Int -> StateT DependencyDataCache G (Int, BlockDeps, Bool, [ExportedFun]) oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do - (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps - (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps - (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps + (edi, bdi) <- partitionWithM (lookupIdFun n) idDeps + (edo, bdo) <- partitionWithM lookupOtherFun otherDeps + (edp, bdp) <- partitionWithM (lookupPseudoIdFun n) pseudoIdDeps expi <- mapM lookupExportedId (filter isExportedId idExports) expo <- mapM lookupExportedOther otherExports -- fixme thin deps, remove all transitive dependencies! @@ -140,7 +139,7 @@ let k = getKey . getUnique $ i addEntry :: StateT DependencyDataCache G ExportedFun addEntry = do - (TxtI idTxt) <- lift (identForId i) + idTxt <- identFS <$> lift (identForId i) lookupExternalFun (Just k) (OtherSymb m idTxt) in if m == mod then pprPanic "local id not found" (ppr m) @@ -160,7 +159,7 @@ lookupExportedId :: Id -> StateT DependencyDataCache G ExportedFun lookupExportedId i = do - (TxtI idTxt) <- lift (identForId i) + idTxt <- identFS <$> lift (identForId i) lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) lookupExportedOther :: FastString -> StateT DependencyDataCache G ExportedFun diff --git a/GHC/StgToJS/Expr.hs b/GHC/StgToJS/Expr.hs --- a/GHC/StgToJS/Expr.hs +++ b/GHC/StgToJS/Expr.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -30,26 +31,30 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad import GHC.JS.Transform import GHC.JS.Make +import GHC.JS.Ident 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.StgToJS.Linker.Utils (decodeModifiedUTF8) import GHC.Types.CostCentre import GHC.Types.Tickish @@ -65,25 +70,26 @@ import GHC.Builtin.PrimOps import GHC.Builtin.Names -import GHC.Core +import GHC.Core hiding (Var) import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Opt.Arity (isOneShotBndr) import GHC.Core.Type hiding (typeSize) import GHC.Utils.Misc -import GHC.Utils.Encoding import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext) import qualified Control.Monad.Trans.State.Strict as State import GHC.Data.FastString +import qualified GHC.Types.Unique.Map as UM + import qualified GHC.Data.List.SetOps as ListSetOps +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Monoid import Data.Maybe import Data.Function -import Data.Either import qualified Data.List as L import qualified Data.Set as S import qualified Data.Map as M @@ -91,17 +97,17 @@ import Control.Arrow ((&&&)) -- | Evaluate an expression in the given expression context (continuation) -genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult) +genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStgStat, ExprResult) genExpr ctx stg = case stg of StgApp f args -> genApp ctx f args StgLit l -> do ls <- genLit l let r = assignToExprCtx ctx ls - pure (r,ExprInline Nothing) + pure (r,ExprInline) StgConApp con _n args _ -> do as <- concatMapM genArg args c <- genCon ctx con as - return (c, ExprInline (Just as)) + return (c, ExprInline) StgOpApp (StgFCallOp f _) args t -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args StgOpApp (StgPrimOp op) args t @@ -131,23 +137,23 @@ genBind :: HasDebugCallStack => ExprCtx -> CgStgBinding - -> G (JStat, ExprCtx) + -> G (JStgStat, ExprCtx) genBind ctx bndr = case bndr of StgNonRec b r -> do j <- assign b r >>= \case Just ja -> return ja Nothing -> allocCls Nothing [(b,r)] - return (j, addEvalRhs ctx [(b,r)]) + return (j, ctx) StgRec bs -> do jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls let m = if null jas then Nothing else Just (mconcat $ catMaybes jas) j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs - return (j, addEvalRhs ctx bs) + return (j, ctx) where ctx' = ctxClearLneFrame ctx - assign :: Id -> CgStgRhs -> G (Maybe JStat) + assign :: Id -> CgStgRhs -> G (Maybe JStgStat) assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr _typ) | let strip = snd . stripStgTicksTop (not . tickishIsCode) , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr @@ -166,10 +172,10 @@ 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) - | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do + | isInlineExpr expr = do d <- declVarsForId b tgt <- varsForId b let ctx' = ctx { ctxTarget = assocIdExprs b tgt } @@ -178,16 +184,10 @@ assign _b StgRhsCon{} = return Nothing assign b r = genEntry ctx' b r >> return Nothing - addEvalRhs c [] = c - addEvalRhs c ((b,r):xs) - | StgRhsCon{} <- r = addEvalRhs (ctxAssertEvaluated b c) xs - | (StgRhsClosure _ _ ReEntrant _ _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs - | otherwise = addEvalRhs c xs - genBindLne :: HasDebugCallStack => ExprCtx -> CgStgBinding - -> G (JStat, ExprCtx) + -> G (JStgStat, ExprCtx) genBindLne ctx bndr = do -- compute live variables and the offsets where they will be stored in the -- stack @@ -231,72 +231,74 @@ maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame") ((payloadSize-) . fst) (L.find ((==i) . fst . snd) (zip [0..] vars)) - bh | isUpdatable update = - jVar (\x -> mconcat - [ x |= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] - , IfStat x (ReturnStat x) mempty - ]) - | otherwise = mempty - lvs <- popLneFrame True payloadSize ctx - body <- genBody ctx R1 args body typ - ei@(TxtI eii) <- identForEntryId i + mk_bh :: G JStgStat + mk_bh | isUpdatable update = + do x <- freshIdent + return $ mconcat + [ x ||= ApplExpr hdBlackHoleLNE [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)] + , IfStat (Var x) (ReturnStat (Var x)) mempty + ] + | otherwise = pure mempty + blk_hl <- mk_bh + locals <- popLneFrame True payloadSize ctx + body <- genBody ctx R1 args body typ + ei@(identFS -> eii) <- identForEntryId i sr <- genStaticRefsRhs rhs - let f = (bh <> lvs <> body) - emitClosureInfo $ - ClosureInfo ei - (CIRegs 0 $ concatMap idVt args) - (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) - (fixedLayout . reverse $ - map (stackSlotType . fst) (ctxLneFrameVars ctx)) - CIStackFrame - sr - emitToplevel (jFunction ei [] f) + 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 - ei@(TxtI _eii) <- identForEntryId i + ei <- identForEntryId i -- di <- varForDataConWorker con ii <- freshIdent p <- popLneFrame True payloadSize ctx args' <- concatMapM genArg args ac <- allocCon ii con cc args' - emitToplevel (jFunction ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) + emitToplevel (FuncStat ei [] (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])) -- | 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@(TxtI 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 idVt args) - (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) - (fixedLayout $ map (uTypeVt . idType) live) - et - sr - emitToplevel (jFunction ei [] (mconcat [ll, llv, upd, setcc, body])) - where - entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + 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])) + -- | Generate the entry function types for identifiers. Note that this only --- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is --- filtered as not a RuntimeRepKinded type. +-- returns either 'CIThunk' or 'CIFun'. genEntryType :: HasDebugCallStack => [Id] -> G CIType genEntryType [] = return CIThunk -genEntryType args0 = do +genEntryType args = do args' <- mapM genIdArg args return $ CIFun (length args) (length $ concat args') - where - args = filter (not . isRuntimeRepKindedTy . idType) args0 -- | Generate the body of an object genBody :: HasDebugCallStack @@ -305,7 +307,7 @@ -> [Id] -> CgStgExpr -> Type - -> G JStat + -> G JStgStat genBody ctx startReg args e typ = do -- load arguments into local variables la <- do @@ -352,7 +354,7 @@ -- -- Se we're left to use the applied arguments to peel the type (unwrapped) one -- arg at a time. But passed args are args after unarisation so we need to --- unarise every argument type that we peel (using typePrimRepArgs) to get the +-- unarise every argument type that we peel (using typePrimRep) to get the -- number of passed args consumed by each type arg. -- -- In case of failure to determine the type, we default to LiftedRep as it's @@ -367,7 +369,7 @@ -- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function -- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False. -verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat +verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStgStat verifyRuntimeReps xs = do runtime_assert <- csRuntimeAssert <$> getSettings if not runtime_assert @@ -376,7 +378,7 @@ where verifyRuntimeRep i = do i' <- varsForId i - pure $ go i' (idVt i) + pure $ go i' (idJSRep i) go js (VoidV:vs) = go js vs go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs @@ -388,13 +390,13 @@ 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 -- registers. For the empty, singleton, and binary case use register 1, for any -- more use as many registers as necessary. -loadLiveFun :: [Id] -> G JStat +loadLiveFun :: [Id] -> G JStgStat loadLiveFun l = do l' <- concat <$> mapM identsForId l case l' of @@ -416,11 +418,11 @@ , l'' ] where - loadLiveVar d n v = let ident = TxtI (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 -popLneFrame :: Bool -> Int -> ExprCtx -> G JStat +popLneFrame :: Bool -> Int -> ExprCtx -> G JStgStat popLneFrame inEntry size ctx = do -- calculate the new stack size let ctx' = ctxLneShrinkStack ctx size @@ -436,7 +438,7 @@ popSkipI skip is -- | Generate an updated given an 'Id' -genUpdFrame :: UpdateFlag -> Id -> G JStat +genUpdFrame :: UpdateFlag -> Id -> G JStgStat genUpdFrame u i | isReEntrant u = pure mempty | isOneShotBndr i = maybeBh @@ -456,11 +458,11 @@ -- Useful for making sure that the object is not accidentally entered multiple -- times -- -bhSingleEntry :: StgToJSConfig -> JStat +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 @@ -480,7 +482,7 @@ sv = liveStatic lv getStaticRef :: Id -> G (Maybe FastString) - getStaticRef = fmap (fmap itxt . listToMaybe) . identsForId + getStaticRef = fmap (fmap identFS . listToMaybe) . identsForId -- | Reorder the things we need to push to reuse existing stack values as much -- as possible True if already on the stack at that location @@ -494,17 +496,18 @@ -- -- Bool: True when the slot already contains a value optimizeFree offset ids = do -- this line goes wrong vvvvvvv - let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids + let -- ids' = concat $ map (\i -> map (i,) [1..varSize . unaryTypeJSRep . idType $ i]) ids idSize :: Id -> Int - idSize i = sum $ map varSize (typeVt . idType $ i) + idSize i = typeSize $ idType i ids' = concatMap (\i -> map (i,) [1..idSize i]) ids - -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids) + -- 1..varSize] . unaryTypeJSRep . idType $ i]) (typeJSRep ids) l = length ids' slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots let slm = M.fromList (zip slots [0..]) - (remaining, fixed) = partitionEithers $ - map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True)) - (M.lookup (SlotId i n) slm)) ids' + (remaining, fixed) = partitionWith (\inp@(i,n) -> maybe (Left inp) + (\j -> Right (i,n,j,True)) + (M.lookup (SlotId i n) slm)) + ids' takenSlots = S.fromList (fmap (\(_,_,x,_) -> x) fixed) freeSlots = filter (`S.notMember` takenSlots) [0..l-1] remaining' = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots @@ -512,15 +515,15 @@ return $ map (\(i,n,_,b) -> (i,n,b)) allSlots -- | Allocate local closures -allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat +allocCls :: Maybe JStgStat -> [(Id, CgStgRhs)] -> G JStgStat allocCls dynMiddle xs = do - (stat, dyn) <- partitionEithers <$> mapM toCl xs - ac <- allocDynAll True dynMiddle dyn + (stat, dyn) <- partitionWithM toCl xs + ac <- allocDynAll False dynMiddle dyn pure (mconcat stat <> ac) where -- left = static, right = dynamic toCl :: (Id, CgStgRhs) - -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack)) + -> G (Either JStgStat (Ident,JStgExpr,[JStgExpr],CostCentreStack)) -- statics {- making zero-arg constructors static is problematic, see #646 proper candidates for this optimization should have been floated @@ -557,7 +560,7 @@ -> AltType -> [CgStgAlt] -> LiveVars - -> G (JStat, ExprResult) + -> G (JStgStat, ExprResult) genCase ctx bnd e at alts l -- For: unpackCStringAppend# "some string"# str -- Generate: h$appendToHsStringA(str, "some string") @@ -579,28 +582,72 @@ , getUnique i == unpackCStringAppendIdKey , [StgVarArg b',x] <- args , bnd == b' - , d <- utf8DecodeByteString bs + , Just d <- decodeModifiedUTF8 bs , [top] <- concatMap typex_expr (ctxTarget ctx) = do prof <- csProf <$> getSettings let profArg = if prof then [jCafCCS] else [] a <- genArg x return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg) - , ExprInline Nothing + , ExprInline ) + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , getUnique i == unpackCStringAppendUtf8IdKey + , [StgVarArg b',x] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg) + , ExprInline + ) - | snd $ isInlineExpr (ctxEvaluatedIds ctx) e = do + -- The latter has a faster decoding loop. + -- + -- case "some string"# of b { + -- DEFAULT -> unpackCString# b + -- } + -- + -- + Utf8 version below + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , idName i == unpackCStringName + , [StgVarArg b'] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsStringA" [toJExpr d] + , ExprInline + ) + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , idName i == unpackCStringUtf8Name + , [StgVarArg b'] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsString" [toJExpr d] + , ExprInline + ) + + | isInlineExpr e = do bndi <- identsForId bnd let ctx' = ctxSetTop bnd $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi)) $ ctx (ej, r) <- genExpr ctx' e - let d = case r of - ExprInline d0 -> d0 - ExprCont -> pprPanic "genCase: expression was not inline" - (pprStgExpr panicStgPprOpts e) + massert (r == ExprInline) - (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts + (aj, ar) <- genAlts ctx bnd at alts (saveCCS,restoreCCS) <- ifProfilingM $ do ccsVar <- freshIdent pure ( ccsVar ||= toJExpr jCurrentCCS @@ -616,7 +663,7 @@ , ar ) | otherwise = do - rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l + rj <- genRet ctx bnd at alts l let ctx' = ctxSetTop bnd $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..])) $ ctx @@ -629,20 +676,20 @@ -> AltType -> [CgStgAlt] -> LiveVars - -> G JStat + -> G JStgStat genRet ctx e at as l = freshIdent >>= f where allRefs :: [Id] allRefs = S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as lneLive :: Int - lneLive = maximum $ 0 : catMaybes (map (ctxLneBindingStackSize ctx) allRefs) + lneLive = maximum $ 0 :| catMaybes (map (ctxLneBindingStackSize ctx) allRefs) ctx' = ctxLneShrinkStack ctx lneLive lneVars = map fst $ ctxLneFrameVars ctx' isLne i = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i nonLne = filter (not . isLne) (dVarSetElems l) - f :: Ident -> G JStat - f r@(TxtI ri) = do + f :: Ident -> G JStgStat + f r@(identFS -> ri) = do pushLne <- pushLneFrame lneLive ctx saveCCS <- ifProfilingM $ push [jCurrentCCS] free <- optimizeFree 0 nonLne @@ -650,27 +697,28 @@ 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 - emitToplevel $ jFunction r [] fun' + ++ if prof then [ObjV] else map stackSlotType lneVars + , ciType = CIStackFrame + , ciStatic = sr + } + emitToplevel $ FuncStat r [] fun' return (pushLne <> saveCCS <> pushRet) fst3 ~(x,_,_) = x - altRegs :: HasDebugCallStack => [VarType] + altRegs :: HasDebugCallStack => [JSRep] altRegs = case at of - PrimAlt ptc -> [primRepVt ptc] - MultiValAlt _n -> idVt e + PrimAlt ptc -> [primRepToJSRep ptc] + MultiValAlt _n -> idJSRep e _ -> [PtrV] -- special case for popping CCS but preserving stack size - pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat + pop_handle_CCS :: [(JStgExpr, StackSlot)] -> G JStgStat pop_handle_CCS [] = return mempty pop_handle_CCS xs = do -- grab the slots from 'xs' and push @@ -689,7 +737,7 @@ restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown) rlne <- popLneFrame False lneLive ctx' rlnev <- verifyRuntimeReps lneVars - (alts, _altr) <- genAlts ctx' e at Nothing as + (alts, _altr) <- genAlts ctx' e at as return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> returnStack @@ -700,10 +748,9 @@ => ExprCtx -- ^ lhs to assign expression result to -> Id -- ^ id being matched -> AltType -- ^ type - -> Maybe [JExpr] -- ^ if known, fields in datacon from earlier expression -> [CgStgAlt] -- ^ the alternatives - -> G (JStat, ExprResult) -genAlts ctx e at me alts = do + -> G (JStgStat, ExprResult) +genAlts ctx e at alts = do (st, er) <- case at of PolyAlt -> case alts of @@ -723,7 +770,7 @@ -> do ie <- varsForId e (r, bss) <- normalizeBranches ctx <$> - mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts + mapM (isolateSlots . mkPrimIfBranch ctx [primRepToJSRep tc]) alts setSlots [] return (mkSw ie bss, r) @@ -741,15 +788,6 @@ -> panic "genAlts: unexpected unboxed tuple" AlgAlt _tc - | Just es <- me - , [GenStgAlt (DataAlt dc) bs expr] <- alts - , not (isUnboxableCon dc) - -> do - bsi <- mapM identsForId bs - (ej, er) <- genExpr ctx expr - return (declAssignAll (concat bsi) es <> ej, er) - - AlgAlt _tc | [alt] <- alts -> do Branch _ s r <- mkAlgBranch ctx e alt @@ -787,7 +825,7 @@ -- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that -- asserts the pattern match is valid, e.g., the match is attempted on a -- Boolean, a Data Constructor, or some number. -verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat +verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStgStat verifyMatchRep x alt = do runtime_assert <- csRuntimeAssert <$> getSettings if not runtime_assert @@ -795,14 +833,14 @@ 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, -- i.e., a possible code path from an 'StgAlt' data Branch a = Branch { branch_expr :: a - , branch_stat :: JStat + , branch_stat :: JStgStat , branch_result :: ExprResult } deriving (Eq,Functor) @@ -818,29 +856,29 @@ | branchResult (fmap branch_result brs) == ExprCont = (ExprCont, map mkCont brs) | otherwise = - (ExprInline Nothing, brs) + (ExprInline, brs) where mkCont b = case branch_result b of - ExprInline{} -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1 - (concatMap typex_expr $ ctxTarget ctx) - , branch_result = ExprCont - } + ExprInline -> b { branch_stat = branch_stat b <> assignAll jsRegsFromR1 + (concatMap typex_expr $ ctxTarget ctx) + , branch_result = ExprCont + } _ -> b -- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input -- ID's, declaring them as variables in JS land and binding them, in order, to -- 'es'. -loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat +loadUbxTup :: [JStgExpr] -> [Id] -> Int -> G JStgStat loadUbxTup es bs _n = do bs' <- concatMapM identsForId bs return $ declAssignAll bs' es -mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkSw :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat mkSw [e] cases = mkSwitch e (fmap (fmap (fmap head)) cases) mkSw es cases = mkIfElse es cases -- | Switch for pattern matching on constructors or prims -mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat +mkSwitch :: JStgExpr -> [Branch (Maybe JStgExpr)] -> JStgStat mkSwitch e cases | [Branch (Just c1) s1 _] <- n , [Branch _ s2 _] <- d @@ -865,7 +903,7 @@ -- | if/else for pattern matching on things that js cannot switch on -- the list of branches is expected to have the default alternative -- first, if it exists -mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +mkIfElse :: [JStgExpr] -> [Branch (Maybe [JStgExpr])] -> JStgStat mkIfElse e s = go (L.reverse s) where go = \case @@ -874,19 +912,19 @@ [] -> panic "mkIfElse: empty expression list" _ -> panic "mkIfElse: multiple DEFAULT cases" --- | Wrapper to contruct sequences of (===), e.g., +-- | Wrapper to construct sequences of (===), e.g., -- -- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2) -- -mkEq :: [JExpr] -> [JExpr] -> JExpr +mkEq :: [JStgExpr] -> [JStgExpr] -> JStgExpr mkEq es1 es2 - | length es1 == length es2 = foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2) + | length es1 == length es2 = L.foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2) | otherwise = panic "mkEq: incompatible expressions" mkAlgBranch :: ExprCtx -- ^ toplevel id for the result -> Id -- ^ datacon to match -> CgStgAlt -- ^ match alternative with binders - -> G (Branch (Maybe JExpr)) + -> G (Branch (Maybe JStgExpr)) mkAlgBranch top d alt | DataAlt dc <- alt_con alt , isUnboxableCon dc @@ -910,52 +948,54 @@ -- | Generate a primitive If-expression mkPrimIfBranch :: ExprCtx - -> [VarType] + -> [JSRep] -> CgStgAlt - -> G (Branch (Maybe [JExpr])) + -> G (Branch (Maybe [JStgExpr])) mkPrimIfBranch top _vt alt = (\ic (ej,er) -> Branch ic ej er) <$> ifCond (alt_con alt) <*> genExpr top (alt_rhs alt) -- fixme are bool things always checked correctly here? -ifCond :: AltCon -> G (Maybe [JExpr]) +ifCond :: AltCon -> G (Maybe [JStgExpr]) ifCond = \case DataAlt da -> return $ Just [toJExpr (dataConTag da)] LitAlt l -> Just <$> genLit l DEFAULT -> return Nothing -caseCond :: AltCon -> G (Maybe JExpr) +caseCond :: AltCon -> G (Maybe JStgExpr) caseCond = \case +-- fixme use single tmp var for all branches DEFAULT -> return Nothing DataAlt da -> return $ Just (toJExpr $ dataConTag da) LitAlt l -> genLit l >>= \case [e] -> pure (Just e) - es -> pprPanic "caseCond: expected single-variable literal" (ppr $ satJExpr Nothing <$> es) + es -> pprPanic "caseCond: expected single-variable literal" (ppr $ jStgExprToJS <$> es) --- fixme use single tmp var for all branches -- | Load parameters from constructor -loadParams :: JExpr -> [Id] -> G JStat +loadParams :: JStgExpr -> [Id] -> G JStgStat loadParams from args = do as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use - return $ case as of - [] -> mempty - [(x,u)] -> loadIfUsed (from .^ closureField1_) x u - [(x1,u1),(x2,u2)] -> mconcat + case as of + [] -> return mempty + [(x,u)] -> return $ loadIfUsed (from .^ closureField1_) x u + [(x1,u1),(x2,u2)] -> return $ mconcat [ loadIfUsed (from .^ closureField1_) x1 u1 , loadIfUsed (from .^ closureField2_) x2 u2 ] - ((x,u):xs) -> mconcat - [ loadIfUsed (from .^ closureField1_) x u - , jVar (\d -> mconcat [ d |= from .^ closureField2_ - , loadConVarsIfUsed d xs - ]) - ] + ((x,u):xs) -> do d <- freshIdent + return $ mconcat + [ loadIfUsed (from .^ closureField1_) x u + , mconcat [ d ||= from .^ closureField2_ + , loadConVarsIfUsed (Var d) xs + ] + ] where use = repeat True -- fixme clean up + loadIfUsed fr tgt True = tgt ||= fr loadIfUsed _ _ _ = mempty loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..] - where f (x,u) n = loadIfUsed (SelExpr fr (TxtI (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' @@ -967,98 +1007,113 @@ (ExprCont:_) -> ExprCont (_:es) | elem ExprCont es -> ExprCont - | otherwise -> ExprInline Nothing + | otherwise -> ExprInline -- | Push return arguments onto the stack. The 'Bool' tracks whether the value -- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'. -pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat +pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JStgExpr -> G JStgStat pushRetArgs free fun = do rs <- mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free pushOptimized (rs++[(fun,False)]) -- | Load the return arguments then pop the stack frame -loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat +loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStgStat loadRetArgs free = do ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free popSkipI 1 ids +-- All identifiers referenced by the expression (does not traverse into nested functions) +allVars :: JStgExpr -> [Ident] +allVars (ValExpr v) = case v of + (JVar i) -> [i] + (JList xs) -> concatMap allVars xs + (JHash xs) -> concatMap (allVars . snd) (UM.nonDetUniqMapToList xs) + (JInt {}) -> [] + (JDouble {}) -> [] + (JStr {}) -> [] + (JRegEx {}) -> [] + (JBool {}) -> [] + (JFunc is _s) -> is +allVars (InfixExpr _op lh rh) = allVars lh ++ allVars rh +allVars (ApplExpr f xs) = allVars f ++ concatMap allVars xs +allVars (IfExpr c t e) = allVars c ++ allVars t ++ allVars e +allVars (UOpExpr _op x) = allVars x +allVars (SelExpr e _) = allVars e +allVars (IdxExpr e i) = allVars e ++ allVars i + -- | allocate multiple, possibly mutually recursive, closures -allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat -{- -XXX remove use of template and enable in-place init again +allocDynAll :: Bool -> Maybe JStgStat -> [(Ident,JStgExpr,[JStgExpr],CostCentreStack)] -> G JStgStat allocDynAll haveDecl middle [(to,entry,free,cc)] - | isNothing middle && to `notElem` (free ^.. template) = do + | isNothing middle && to `notElem` concatMap allVars free = do ccs <- ccsVarJ cc - return $ allocDynamic s haveDecl to entry free ccs -} + s <- getSettings + return $ allocDynamic s (not haveDecl) to entry free ccs allocDynAll haveDecl middle cls = do settings <- getSettings let + middle' :: JStgStat middle' = fromMaybe mempty middle decl_maybe i e | haveDecl = toJExpr i |= e | otherwise = i ||= e - makeObjs :: G JStat + makeObjs :: G JStgStat makeObjs = fmap mconcat $ forM cls $ \(i,f,_,cc) -> do 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 = mconcat $ 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 - ] + fillObjs :: [JStgStat] + fillObjs = map fillObj cls + 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 [] = null_ - fillFun es = ApplExpr (allocData (length es)) es + | otherwise + -> mconcat [ closureField1 i |= ex + , closureField2 i |= ApplExpr (allocData (length es)) es + ] - checkObjs | csAssertRts settings = mconcat $ - map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls + checkObjs :: [JStgStat] + checkObjs | csAssertRts settings = + map (\(i,_,_,_) -> ApplStat hdCheckObj [Var i]) cls | otherwise = mempty objs <- makeObjs - pure $ mconcat [objs, middle', fillObjs, checkObjs] + return $ mconcat [objs, middle', mconcat fillObjs, mconcat checkObjs] -- | Generate a primop. This function wraps around the real generator -- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before -- generating the primop. -genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult) +genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStgStat, ExprResult) genPrimOp ctx op args t = do as <- concatMapM genArg args prof <- csProf <$> getSettings bound <- csBoundsCheck <$> getSettings + let prim_gen = withTag "h$PRM" $ genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as -- fixme: should we preserve/check the primreps? - return $ case genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as of - PrimInline s -> (s, ExprInline Nothing) + jsm <- liftIO initJSM + return $ case runJSM jsm prim_gen of + PrimInline s -> (s, ExprInline) PRPrimCall s -> (s, ExprCont) diff --git a/GHC/StgToJS/ExprCtx.hs b/GHC/StgToJS/ExprCtx.hs --- a/GHC/StgToJS/ExprCtx.hs +++ b/GHC/StgToJS/ExprCtx.hs @@ -18,14 +18,12 @@ module GHC.StgToJS.ExprCtx ( ExprCtx , initExprCtx - , ctxAssertEvaluated , ctxIsEvaluated , ctxSetSrcSpan , ctxSrcSpan , ctxSetTop , ctxTarget , ctxSetTarget - , ctxEvaluatedIds -- * Let-no-escape , ctxClearLneFrame , ctxUpdateLneFrame @@ -43,10 +41,13 @@ import GHC.StgToJS.Types import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Types.Var import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Stg.EnforceEpt.TagSig + import GHC.Utils.Outputable import GHC.Utils.Panic @@ -61,10 +62,6 @@ , ctxTarget :: [TypedExpr] -- ^ Target variables for the evaluated expression - , ctxEvaluatedIds :: UniqSet Id - -- ^ Ids that we know to be evaluated (e.g. case binders when the expression - -- to evaluate is in an alternative) - , ctxSrcSpan :: Maybe RealSrcSpan -- ^ Source location @@ -89,13 +86,22 @@ } +instance Outputable ExprCtx where + ppr g = hang (text "ExprCtx") 2 $ vcat + [ hcat [text "ctxTop: ", ppr (ctxTop g)] + , hcat [text "ctxTarget:", ppr (ctxTarget g)] + , hcat [text "ctxSrcSpan:", ppr (ctxSrcSpan g)] + , hcat [text "ctxLneFrameBs:", ppr (ctxLneFrameBs g)] + , hcat [text "ctxLneFrameVars:", ppr (ctxLneFrameVars g)] + , hcat [text "ctxLneFrameSize:", ppr (ctxLneFrameSize g)] + ] + -- | Initialize an expression context in the context of the given top-level -- binding Id initExprCtx :: Id -> ExprCtx initExprCtx i = ExprCtx { ctxTop = i , ctxTarget = [] - , ctxEvaluatedIds = emptyUniqSet , ctxLneFrameBs = emptyUFM , ctxLneFrameVars = [] , ctxLneFrameSize = 0 @@ -110,10 +116,6 @@ ctxSetTop :: Id -> ExprCtx -> ExprCtx ctxSetTop i ctx = ctx { ctxTop = i } --- | Add an Id to the known-evaluated set -ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx -ctxAssertEvaluated i ctx = ctx { ctxEvaluatedIds = addOneToUniqSet (ctxEvaluatedIds ctx) i } - -- | Set source location ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span } @@ -139,8 +141,39 @@ } -- | Predicate: do we know for sure that the given Id is evaluated? -ctxIsEvaluated :: ExprCtx -> Id -> Bool -ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx +ctxIsEvaluated :: Id -> Bool +ctxIsEvaluated i = + maybe False isTaggedSig (idTagSig_maybe i) + && go (idDetails i) + where + go JoinId{} = False + go _ = True + + + -- DFunId new_type -> not new_type + -- -- DFuns terminate, unless the dict is implemented + -- -- with a newtype in which case they may not + + -- DataConWorkId {} -> True + + -- ClassOpId {} -> False + -- -- suppose an argument, and we don't have one + + -- PrimOpId op _ -> primop_ok op + -- -- probably already handled by StgOpApp + + -- JoinId {} -> False + -- -- Don't speculate join points + + -- TickBoxOpId {} -> False + -- -- Don't speculate box ticking + + -- -- Tagged (evaluated) ids + -- _ | Just sig <- idTagSig_maybe i + -- , isTaggedSig sig + -- -> True + + -- _ -> False -- | Does the given Id correspond to a LNE binding ctxIsLneBinding :: ExprCtx -> Id -> Bool diff --git a/GHC/StgToJS/FFI.hs b/GHC/StgToJS/FFI.hs --- a/GHC/StgToJS/FFI.hs +++ b/GHC/StgToJS/FFI.hs @@ -5,25 +5,23 @@ module GHC.StgToJS.FFI ( genPrimCall , genForeignCall - , saturateFFI ) where import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax import GHC.JS.Make -import GHC.JS.Transform -import qualified GHC.JS.Syntax as Sat 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,10 +42,10 @@ import Data.Monoid import qualified Data.List as L -genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult) +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 - return (j, ExprInline Nothing) + j <- parseFFIPattern False False False (unpackFS hdStr ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args + return (j, ExprInline) -- | generate the actual call {- @@ -69,9 +67,9 @@ -> Bool -- ^ using javascript calling convention -> String -> Type - -> [JExpr] + -> [JStgExpr] -> [StgArg] - -> G JStat + -> G JStgStat parseFFIPattern catchExcep async jscc pat t es as | catchExcep = do c <- parseFFIPatternA async jscc pat t es as @@ -81,17 +79,16 @@ -- } catch(except) { -- return h$throwJSException(except); -- } - let ex = TxtI "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 -> Bool -- ^ using JavaScript calling conv -> String -> Type - -> [JExpr] + -> [JStgExpr] -> [StgArg] - -> G JStat + -> G JStgStat -- async calls get an extra callback argument -- call it with the result parseFFIPatternA True True pat t es as = do @@ -100,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) ]) ] @@ -122,13 +119,13 @@ -- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous" -parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async - -> Bool -- ^ javascript calling convention used - -> String -- ^ pattern called - -> Type -- ^ return type - -> [JExpr] -- ^ expressions to return in (may be more than necessary) - -> [StgArg] -- ^ arguments - -> G JStat +parseFFIPattern' :: Maybe JStgExpr -- ^ Nothing for sync, Just callback for async + -> Bool -- ^ javascript calling convention used + -> String -- ^ pattern called + -> Type -- ^ return type + -> [JStgExpr] -- ^ expressions to return in (may be more than necessary) + -> [StgArg] -- ^ arguments + -> G JStgStat parseFFIPattern' callback javascriptCc pat t ret args | not javascriptCc = mkApply pat | otherwise = mkApply pat @@ -153,16 +150,16 @@ (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args cs <- getSettings return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as) - where f' = toJExpr (TxtI $ mkFastString f) + where f' = toJExpr (global $ mkFastString f) 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 JStat to be run +-- generate arg to be passed to FFI call, with marshalling JStgStat to be run -- before the call -genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr]) +genFFIArg :: Bool -> StgArg -> G (JStgStat, [JStgExpr]) genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l genFFIArg isJavaScriptCc a@(StgVarArg i) | not isJavaScriptCc && @@ -175,18 +172,15 @@ where tycon = tyConAppTyCon (unwrapType arg_ty) arg_ty = stgArgType a - r = uTypeVt arg_ty - -saturateFFI :: Int -> JStat -> Sat.JStat -saturateFFI u = satJStat (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u) + r = unaryTypeJSRep arg_ty genForeignCall :: HasDebugCallStack => ExprCtx -> ForeignCall -> Type - -> [JExpr] + -> [JStgExpr] -> [StgArg] - -> G (JStat, ExprResult) + -> G (JStgStat, ExprResult) genForeignCall _ctx (CCall (CCallSpec (StaticTarget _ tgt Nothing True) JavaScriptCallConv @@ -194,29 +188,30 @@ _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')) - , ExprInline Nothing + , ExprInline ) 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 Nothing + | otherwise = ExprInline catchExcep = (cconv == JavaScriptCallConv) && playSafe safety || playInterruptible safety @@ -227,7 +222,7 @@ tgt' | async = take (length tgt) jsRegsFromR1 | otherwise = tgt - wrapperPrefix = "ghczuwrapperZC" + wrapperPrefix = unpackFS wrapperColonStr getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] getObjectKeyValuePairs [] = Just [] @@ -247,4 +242,4 @@ showType t | Just tc <- tyConAppTyCon_maybe (unwrapType t) = mkFastString (renderWithContext defaultSDocContext (ppr tc)) - | otherwise = "" + | otherwise = unknown diff --git a/GHC/StgToJS/Heap.hs b/GHC/StgToJS/Heap.hs --- a/GHC/StgToJS/Heap.hs +++ b/GHC/StgToJS/Heap.hs @@ -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_ @@ -38,118 +38,127 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax import GHC.JS.Make 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 :: JExpr +jTyObject :: JStgExpr jTyObject = jString "object" -closureType :: JExpr -> JExpr -closureType = entryClosureType . closureEntry +-- | Closure type from infotable +infoClosureType :: JStgExpr -> JStgExpr +infoClosureType f = f .^ infoClosureType_ -entryClosureType :: JExpr -> JExpr -entryClosureType f = f .^ entryClosureType_ +-- | Function arity from infotable +infoFunArity :: JStgExpr -> JStgExpr +infoFunArity f = f .^ infoFunArity_ -isObject :: JExpr -> JExpr -isObject c = typeof c .===. String "object" +closureType :: JStgExpr -> JStgExpr +closureType = infoClosureType . closureInfo -isThunk :: JExpr -> JExpr +isObject :: JStgExpr -> JStgExpr +isObject c = typeOf c .===. String "object" + +isThunk :: JStgExpr -> JStgExpr isThunk c = closureType c .===. toJExpr Thunk -isThunk' :: JExpr -> JExpr -isThunk' f = entryClosureType f .===. toJExpr Thunk +isThunk' :: JStgExpr -> JStgExpr +isThunk' f = infoClosureType f .===. toJExpr Thunk -isBlackhole :: JExpr -> JExpr +isBlackhole :: JStgExpr -> JStgExpr isBlackhole c = closureType c .===. toJExpr Blackhole -isFun :: JExpr -> JExpr +isFun :: JStgExpr -> JStgExpr isFun c = closureType c .===. toJExpr Fun -isFun' :: JExpr -> JExpr -isFun' f = entryClosureType f .===. toJExpr Fun +isFun' :: JStgExpr -> JStgExpr +isFun' f = infoClosureType f .===. toJExpr Fun -isPap :: JExpr -> JExpr +isPap :: JStgExpr -> JStgExpr isPap c = closureType c .===. toJExpr Pap -isPap' :: JExpr -> JExpr -isPap' f = entryClosureType f .===. toJExpr Pap +isPap' :: JStgExpr -> JStgExpr +isPap' f = infoClosureType f .===. toJExpr Pap -isCon :: JExpr -> JExpr +isCon :: JStgExpr -> JStgExpr isCon c = closureType c .===. toJExpr Con -isCon' :: JExpr -> JExpr -isCon' f = entryClosureType f .===. toJExpr Con +isCon' :: JStgExpr -> JStgExpr +isCon' f = infoClosureType f .===. toJExpr Con -conTag :: JExpr -> JExpr -conTag = conTag' . closureEntry +conTag :: JStgExpr -> JStgExpr +conTag = conTag' . closureInfo -conTag' :: JExpr -> JExpr -conTag' f = f .^ entryConTag_ +conTag' :: JStgExpr -> JStgExpr +conTag' f = f .^ infoConTag_ --- | Get closure entry function -closureEntry :: JExpr -> JExpr -closureEntry p = p .^ closureEntry_ +-- | Get closure infotable +closureInfo :: JStgExpr -> JStgExpr +closureInfo p = p .^ closureInfo_ -- | Get closure metadata -closureMeta :: JExpr -> JExpr +closureMeta :: JStgExpr -> JStgExpr closureMeta p = p .^ closureMeta_ -- | Get closure cost-center -closureCC :: JExpr -> JExpr +closureCC :: JStgExpr -> JStgExpr closureCC p = p .^ closureCC_ -- | Get closure extra field 1 -closureField1 :: JExpr -> JExpr +closureField1 :: JStgExpr -> JStgExpr closureField1 p = p .^ closureField1_ -- | Get closure extra field 2 -closureField2 :: JExpr -> JExpr +closureField2 :: JStgExpr -> JStgExpr closureField2 p = p .^ closureField2_ --- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) -funArity :: JExpr -> JExpr -funArity = funArity' . closureEntry - --- function arity with raw reference to the entry -funArity' :: JExpr -> JExpr -funArity' f = f .^ entryFunArity_ +-- | Number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) +funArity :: JStgExpr -> JStgExpr +funArity = infoFunArity . closureInfo -- arity of a partial application -papArity :: JExpr -> JExpr +papArity :: JStgExpr -> JStgExpr papArity cp = closureField1 (closureField2 cp) funOrPapArity - :: JExpr -- ^ heap object - -> Maybe JExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice) - -> JExpr -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments) + :: JStgExpr -- ^ heap object + -> 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)) diff --git a/GHC/StgToJS/Ids.hs b/GHC/StgToJS/Ids.hs --- a/GHC/StgToJS/Ids.hs +++ b/GHC/StgToJS/Ids.hs @@ -43,7 +43,8 @@ import GHC.StgToJS.Utils import GHC.StgToJS.Symbols -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import GHC.JS.Make import GHC.Core.DataCon @@ -72,14 +73,13 @@ writeFastMutInt id_gen (v+1) pure v --- | Get fresh local Ident of the form: h$$unit:module_uniq +-- | Get fresh module-local Ident of the form: h$$unit:module_uniq freshIdent :: G Ident freshIdent = do i <- freshUnique mod <- State.gets gsModule - let !name = mkFreshJsSymbol mod i - return (TxtI name) - + let !sym_name = mkFreshJsSymbol mod i + return (name sym_name) -- | Generate unique Ident for the given ID (uncached!) -- @@ -99,19 +99,19 @@ -- Int64#), Addr#, StablePtr#, unboxed tuples, etc. -- makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident -makeIdentForId i num id_type current_module = TxtI 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 @@ -155,7 +155,7 @@ -- Now update the GlobalId cache, if required - let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain + let update_global_cache = isGlobalId i && id_type == IdPlain -- fixme also allow caching entries for lifting? when (update_global_cache) $ do @@ -197,15 +197,15 @@ -- | Retrieve default variable name for the given Id -varForId :: Id -> G JExpr +varForId :: Id -> G JStgExpr varForId i = toJExpr <$> identForId i -- | Retrieve default variable name for the given Id with sub index -varForIdN :: Id -> Int -> G JExpr +varForIdN :: Id -> Int -> G JStgExpr varForIdN i n = toJExpr <$> identForIdN i n -- | Retrieve all the JS vars for the given Id -varsForId :: Id -> G [JExpr] +varsForId :: Id -> G [JStgExpr] varsForId i = case typeSize (idType i) of 0 -> pure mempty 1 -> (:[]) <$> varForId i @@ -213,11 +213,11 @@ -- | Retrieve entry variable name for the given Id -varForEntryId :: Id -> G JExpr +varForEntryId :: Id -> G JStgExpr varForEntryId i = toJExpr <$> identForEntryId i -- | Retrieve datacon entry variable name for the given Id -varForDataConEntryId :: Id -> G JExpr +varForDataConEntryId :: Id -> G JStgExpr varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i @@ -226,11 +226,11 @@ identForDataConWorker d = identForDataConEntryId (dataConWorkId d) -- | Retrieve datacon worker entry variable name for the given datacon -varForDataConWorker :: DataCon -> G JExpr +varForDataConWorker :: DataCon -> G JStgExpr varForDataConWorker d = varForDataConEntryId (dataConWorkId d) -- | Declare all js vars for the id -declVarsForId :: Id -> G JStat +declVarsForId :: Id -> G JStgStat declVarsForId i = case typeSize (idType i) of 0 -> return mempty 1 -> decl <$> identForId i diff --git a/GHC/StgToJS/Linker/Linker.hs b/GHC/StgToJS/Linker/Linker.hs --- a/GHC/StgToJS/Linker/Linker.hs +++ b/GHC/StgToJS/Linker/Linker.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | @@ -23,8 +25,6 @@ ( jsLinkBinary , jsLink , embedJsFile - , staticInitStat - , staticDeclStat , mkExportedFuns , mkExportedModFuns , computeLinkDependencies @@ -32,17 +32,21 @@ , LinkPlan (..) , emptyLinkPlan , incrementLinkPlan + , ArchiveCache + , newArchiveCache ) where -import Prelude +import GHC.Prelude import GHC.Platform.Host (hostPlatformArchOS) import GHC.JS.Make import GHC.JS.Optimizer -import GHC.JS.Unsat.Syntax -import qualified GHC.JS.Syntax as Sat +import GHC.JS.Ident +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import qualified GHC.JS.Syntax as JS import GHC.JS.Transform import GHC.Driver.DynFlags (DynFlags(..)) @@ -51,7 +55,8 @@ 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 import GHC.StgToJS.Linker.Utils @@ -76,7 +81,6 @@ import GHC.Utils.Logger (Logger, logVerbAtLeast) import GHC.Utils.Binary import qualified GHC.Utils.Ppr as Ppr -import GHC.Utils.Monad import GHC.Utils.TmpFs import GHC.Types.Unique.Set @@ -96,13 +100,14 @@ import Data.Function (on) import qualified Data.IntSet as IS import Data.IORef -import Data.List ( nub, intercalate, groupBy, intersperse, sortBy) +import Data.List ( nub, intercalate, groupBy, intersperse ) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Set (Set) import qualified Data.Set as S import Data.Word +import Data.Monoid import System.IO import System.FilePath ((<.>), (), dropExtension, takeDirectory) @@ -117,16 +122,17 @@ import GHC.Unit.Finder.Types import GHC.Unit.Finder (findObjectLinkableMaybe, findHomeModule) import GHC.Driver.Config.Finder (initFinderOpts) +import qualified GHC.Unit.Home.Graph as HUG data LinkerStats = LinkerStats { bytesPerModule :: !(Map Module Word64) -- ^ number of bytes linked per module , packedMetaDataSize :: !Word64 -- ^ number of bytes for metadata } -newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.Archive) } +newtype ArchiveCache = ArchiveCache { loadedArchives :: IORef (Map FilePath Ar.Archive) } -emptyArchiveState :: IO ArchiveState -emptyArchiveState = ArchiveState <$> newIORef M.empty +newArchiveCache :: IO ArchiveCache +newArchiveCache = ArchiveCache <$> newIORef M.empty defaultJsContext :: SDocContext defaultJsContext = defaultSDocContext{sdocStyle = PprCode} @@ -135,52 +141,70 @@ :: FinderCache -> JSLinkConfig -> StgToJSConfig - -> [FilePath] -> Logger + -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -jsLinkBinary finder_cache lc_cfg cfg js_srcs logger dflags unit_env objs dep_units +jsLinkBinary finder_cache lc_cfg cfg logger tmpfs dflags unit_env hs_objs dep_units | lcNoJSExecutables lc_cfg = return () | otherwise = do + -- additional objects to link are passed as FileOption ldInputs... let cmdline_objs = [ f | FileOption _ f <- ldInputs dflags ] - -- discriminate JavaScript sources from real object files. - (cmdline_js_srcs, cmdline_js_objs) <- partitionM isJsFile cmdline_objs + + -- cmdline objects: discriminate between the 3 kinds of objects we have + let disc hss jss ccs = \case + [] -> pure (hss, jss, ccs) + (o:os) -> getObjectKind o >>= \case + Just ObjHs -> disc (o:hss) jss ccs os + Just ObjJs -> disc hss (o:jss) ccs os + Just ObjCc -> disc hss jss (o:ccs) os + Nothing -> do + logInfo logger (vcat [text "Ignoring unexpected command-line object: ", text o]) + disc hss jss ccs os + (cmdline_hs_objs, cmdline_js_objs, cmdline_cc_objs) <- disc [] [] [] cmdline_objs + let - objs' = map ObjFile (objs ++ cmdline_js_objs) - js_srcs' = js_srcs ++ cmdline_js_srcs - is_root _ = True -- FIXME: we shouldn't consider every function as a root, - -- but only the program entry point (main), either the - -- generated one or coming from an object - exe = jsExeFileName dflags + exe = jsExeFileName dflags + all_hs_objs = hs_objs ++ cmdline_hs_objs + all_js_objs = cmdline_js_objs + all_cc_objs = cmdline_cc_objs + is_root _ = True + -- FIXME: we shouldn't consider every function as a root, + -- but only the program entry point (main), either the + -- generated one or coming from an object -- compute dependencies let link_spec = LinkSpec { lks_unit_ids = dep_units - , lks_obj_files = objs' , lks_obj_root_filter = is_root , lks_extra_roots = mempty - , lks_extra_js = js_srcs' + , lks_objs_hs = all_hs_objs + , lks_objs_js = all_js_objs + , lks_objs_cc = all_cc_objs } let finder_opts = initFinderOpts dflags + ar_cache <- newArchiveCache - link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache + link_plan <- computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache - void $ jsLink lc_cfg cfg logger exe link_plan + void $ jsLink lc_cfg cfg logger tmpfs ar_cache exe link_plan -- | link and write result to disk (jsexe directory) jsLink :: JSLinkConfig -> StgToJSConfig -> Logger + -> TmpFs + -> ArchiveCache -> FilePath -- ^ output file/directory -> LinkPlan -> IO () -jsLink lc_cfg cfg logger out link_plan = do +jsLink lc_cfg cfg logger tmpfs ar_cache out link_plan = do -- create output directory createDirectoryIfMissing False out @@ -192,11 +216,11 @@ -- link all Haskell code (program + dependencies) into out.js -- retrieve code for Haskell dependencies - mods <- collectModuleCodes link_plan + mods <- collectModuleCodes ar_cache link_plan -- LTO + rendering of JS code link_stats <- withBinaryFile (out "out.js") WriteMode $ \h -> - renderLinker h (csPrettyRender cfg) mods (lkp_extra_js link_plan) + renderModules h (csPrettyRender cfg) mods ------------------------------------------------------------- @@ -217,52 +241,156 @@ -- link generated RTS parts into rts.js unless (lcNoRts lc_cfg) $ do + jsm <- initJSM withFile (out "rts.js") WriteMode $ \h -> do - void $ hPutJS (csPrettyRender cfg) h (rts cfg) + let opt = jsOptimize (runJSM jsm $ jStgStatToJS <$> rts cfg) + void $ + hPutJS (csPrettyRender cfg) h opt - -- link dependencies' JS files into lib.js - withBinaryFile (out "lib.js") WriteMode $ \h -> do - forM_ (lkp_archives link_plan) $ \archive_file -> do - Ar.Archive entries <- Ar.loadAr archive_file - forM_ entries $ \entry -> do - case getJsArchiveEntry entry of - Nothing -> return () - Just bs -> do - B.hPut h bs + + -- link user-provided JS files into lib.js + (emcc_opts,lib_cc_objs) <- withBinaryFile (out "lib.js") WriteMode $ \h -> do + + let + tmp_dir = linkerTempDir (csLinkerConfig cfg) + + -- JS objects from dependencies' archives (.a) + go_archives emcc_opts cc_objs = \case + [] -> pure (emcc_opts, cc_objs) + (a:as) -> do + Ar.Archive entries <- loadArchive ar_cache a + (emcc_opts', cc_objs') <- go_entries emcc_opts cc_objs entries + go_archives emcc_opts' cc_objs' as + + -- archive's entries + go_entries emcc_opts cc_objs = \case + [] -> pure (emcc_opts, cc_objs) + (e:es) -> case getObjectKindBS (Ar.filedata e) of + Just ObjHs -> do + -- Nothing to do. HS objects are collected in + -- collectModuleCodes + go_entries emcc_opts cc_objs es + Just ObjCc -> do + -- extract the object file from the archive in a temporary + -- file and return its path + cc_obj_fn <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o" + B.writeFile cc_obj_fn (Ar.filedata e) + let cc_objs' = cc_obj_fn:cc_objs + go_entries emcc_opts cc_objs' es + Just ObjJs -> do + -- extract the JS code and append it to the `lib.js` file + (opts,bs) <- parseJSObjectBS (Ar.filedata e) + B.hPut h bs + hPutChar h '\n' + let emcc_opts' = emcc_opts <> opts + go_entries emcc_opts' cc_objs es + Nothing -> case Ar.filename e of + -- JavaScript code linker does not support symbol table processing. + -- Currently the linker does nothing when the symbol table is met. + -- Ar/Ranlib usually do not create a record for the symbol table + -- in the object archive when the table has no entries. + -- For JavaScript code it should not be created by default. + + "__.SYMDEF" -> + -- GNU Ar added the symbol table. + + -- Emscripten Ar (at least 3.1.24 version) + -- adds it even when the symbol table is empty. + go_entries emcc_opts cc_objs es + "__.SYMDEF SORTED" -> + -- BSD-like Ar added the symbol table. + + -- By default, Clang Ar does not add it when the + -- symbol table is empty (and it should be empty) but we left + -- it here to handle the case with symbol table completely + -- for GNU and BSD tools. + go_entries emcc_opts cc_objs es + unknown_name -> do + logInfo logger (vcat [text "Ignoring unexpected archive entry: ", text unknown_name]) + go_entries emcc_opts cc_objs es + + -- additional JS objects (e.g. from the command-line) + go_extra emcc_opts = \case + [] -> pure emcc_opts + (e:es) -> do + (opts,bs) <- readJSObject e + B.hPut h bs hPutChar h '\n' + let emcc_opts' = emcc_opts <> opts + go_extra emcc_opts' es + -- archives + (emcc_opts0, cc_objs) <- go_archives defaultJSOptions [] (S.toList (lkp_archives link_plan)) + -- extra object files + emcc_opts1 <- go_extra emcc_opts0 (S.toList (lkp_objs_js link_plan)) + pure (emcc_opts1,cc_objs) + + + -- Link Cc objects using emcc's linker + -- + -- Cc objects have been extracted from archives (see above) and are listed + -- in lib_cc_objs. + -- + -- We don't link C sources if there are none (obviously) or if asked + -- explicitly by the user with -ddisable-js-c-sources (mostly used for + -- debugging purpose). + let emcc_objs = lib_cc_objs ++ S.toList (lkp_objs_cc link_plan) + let has_emcc_objs = not (null emcc_objs) + let link_c_sources = lcLinkCsources lc_cfg && has_emcc_objs + + when link_c_sources $ do + + runLink logger tmpfs (csLinkerConfig cfg) $ + [ Option "-o" + , FileOption "" (out "clibs.js") + -- Embed wasm files into a single .js file + , Option "-sSINGLE_FILE=1" + -- Enable support for addFunction (callbacks) + , Option "-sALLOW_TABLE_GROWTH" + -- keep some RTS methods and functions (otherwise removed as dead + -- code) + , Option ("-sEXPORTED_RUNTIME_METHODS=" ++ concat (intersperse "," (emccExportedRuntimeMethods emcc_opts))) + , Option ("-sEXPORTED_FUNCTIONS=" ++ concat (intersperse "," (emccExportedFunctions emcc_opts))) + ] + -- pass extra options from JS files' pragmas + ++ map Option (emccExtraOptions emcc_opts) + -- link objects + ++ map (FileOption "") emcc_objs + + -- Don't enable the Emcc rts when not needed (i.e. no Wasm module to link + -- with) and not forced by the caller (e.g. in the future iserv may require + -- incremental linking of Wasm modules, hence the emcc rts even building + -- iserv itself doesn't require the emcc rts) + let use_emcc_rts = UseEmccRts $ link_c_sources || lcForceEmccRts lc_cfg + + -- link everything together into a runnable all.js -- only if we link a complete application, -- no incremental linking and no skipped parts when (lcCombineAll lc_cfg && not (lcNoRts lc_cfg)) $ do - _ <- combineFiles lc_cfg out + writeRunMain out use_emcc_rts + _ <- combineFiles lc_cfg link_c_sources out writeHtml out - writeRunMain out writeRunner lc_cfg out writeExterns out data LinkSpec = LinkSpec { lks_unit_ids :: [UnitId] - - , lks_obj_files :: [LinkedObj] - - , lks_obj_root_filter :: ExportedFun -> Bool - -- ^ Predicate for exported functions in objects to declare as root - - , lks_extra_roots :: Set ExportedFun - -- ^ Extra root functions from loaded units - - , lks_extra_js :: [FilePath] - -- ^ Extra JS files to link + , lks_obj_root_filter :: ExportedFun -> Bool -- ^ Predicate for exported functions in objects to declare as root + , lks_extra_roots :: Set ExportedFun -- ^ Extra root functions from loaded units + , lks_objs_hs :: [FilePath] -- ^ HS objects to link + , lks_objs_js :: [FilePath] -- ^ JS objects to link + , lks_objs_cc :: [FilePath] -- ^ Cc objects to link } instance Outputable LinkSpec where ppr s = hang (text "LinkSpec") 2 $ vcat [ hcat [text "Unit ids: ", ppr (lks_unit_ids s)] - , hcat [text "Object files:", ppr (lks_obj_files s)] + , hcat [text "HS objects:", vcat (fmap text (lks_objs_hs s))] + , hang (text "JS objects::") 2 (vcat (fmap text (lks_objs_js s))) + , hang (text "Cc objects::") 2 (vcat (fmap text (lks_objs_cc s))) , text "Object root filter: " , hcat [text "Extra roots: ", ppr (lks_extra_roots s)] - , hang (text "Extra JS:") 2 (vcat (fmap text (lks_extra_js s))) ] emptyLinkPlan :: LinkPlan @@ -270,7 +398,8 @@ { lkp_block_info = mempty , lkp_dep_blocks = mempty , lkp_archives = mempty - , lkp_extra_js = mempty + , lkp_objs_js = mempty + , lkp_objs_cc = mempty } -- | Given a `base` link plan (assumed to be already linked) and a `new` link @@ -285,13 +414,15 @@ { lkp_block_info = M.union (lkp_block_info base) (lkp_block_info new) , lkp_dep_blocks = S.union (lkp_dep_blocks base) (lkp_dep_blocks new) , lkp_archives = S.union (lkp_archives base) (lkp_archives new) - , lkp_extra_js = S.union (lkp_extra_js base) (lkp_extra_js new) + , lkp_objs_js = S.union (lkp_objs_js base) (lkp_objs_js new) + , lkp_objs_cc = S.union (lkp_objs_cc base) (lkp_objs_cc new) } diff = LinkPlan { lkp_block_info = lkp_block_info new -- block info from "new" contains all we need to load new blocks , lkp_dep_blocks = S.difference (lkp_dep_blocks new) (lkp_dep_blocks base) , lkp_archives = S.difference (lkp_archives new) (lkp_archives base) - , lkp_extra_js = S.difference (lkp_extra_js new) (lkp_extra_js base) + , lkp_objs_js = S.difference (lkp_objs_js new) (lkp_objs_js base) + , lkp_objs_cc = S.difference (lkp_objs_cc new) (lkp_objs_cc base) } @@ -301,11 +432,14 @@ -> LinkSpec -> FinderOpts -> FinderCache + -> ArchiveCache -> IO LinkPlan -computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache = do +computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache = do let units = lks_unit_ids link_spec - let obj_files = lks_obj_files link_spec + let hs_objs = lks_objs_hs link_spec + let js_objs = lks_objs_js link_spec + let cc_objs = lks_objs_cc link_spec let extra_roots = lks_extra_roots link_spec let obj_is_root = lks_obj_root_filter link_spec @@ -319,15 +453,18 @@ -- find/load linkable on-demand when a module is missing. - (objs_block_info, objs_required_blocks) <- loadObjBlockInfo obj_files + (objs_block_info, objs_required_blocks) <- loadObjBlockInfo hs_objs let obj_roots = S.fromList . filter obj_is_root $ concatMap (M.keys . bi_exports . lbi_info) (M.elems objs_block_info) obj_units = map moduleUnitId $ nub (M.keys objs_block_info) - let (rts_wired_units, rts_wired_functions) = rtsDeps units + let (rts_wired_units, rts_wired_functions) = rtsDeps -- all the units we want to link together, without their dependencies let root_units = filter (/= ue_currentUnit unit_env) + -- fendor: GHCi uses more 'UnidIds' than just 'interactiveUnitId'. + -- If this breaks for some reason, + -- see Note [Multiple Home Units aware GHCi] for GHCi session setup. $ filter (/= interactiveUnitId) $ nub $ rts_wired_units ++ reverse obj_units ++ reverse units @@ -339,7 +476,7 @@ let all_units = fmap unitId all_units_infos dep_archives <- getPackageArchives cfg unit_env all_units - (archives_block_info, archives_required_blocks) <- loadArchiveBlockInfo dep_archives + (archives_block_info, archives_required_blocks) <- loadArchiveBlockInfo ar_cache dep_archives -- compute dependencies let block_info = objs_block_info `M.union` archives_block_info @@ -349,7 +486,7 @@ new_required_blocks_var <- newIORef [] let load_info mod = do -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps. - linkable <- case lookupHugByModule mod (ue_home_unit_graph unit_env) of + linkable <- HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case Nothing -> -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... @@ -372,17 +509,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 [ObjFile 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 @@ -401,7 +534,8 @@ { lkp_block_info = updated_block_info , lkp_dep_blocks = all_deps , lkp_archives = S.fromList dep_archives - , lkp_extra_js = S.fromList (lks_extra_js link_spec) + , lkp_objs_js = S.fromList js_objs + , lkp_objs_cc = S.fromList cc_objs } return plan @@ -410,27 +544,37 @@ -- | Compiled module data ModuleCode = ModuleCode { mc_module :: !Module - , mc_js_code :: !Sat.JStat + , mc_js_code :: !JS.JStat , mc_exports :: !B.ByteString -- ^ rendered exports , mc_closures :: ![ClosureInfo] , mc_statics :: ![StaticInfo] , mc_frefs :: ![ForeignJSRef] } +instance Outputable ModuleCode where + ppr m = hang (text "ModuleCode") 2 $ vcat + [ hcat [text "Module: ", ppr (mc_module m)] + , hcat [text "JS Code:", pretty True (mc_js_code m)] + , hcat [text "JS Exports:", pprHsBytes (mc_exports m)] + , hang (text "JS Closures::") 2 (vcat (fmap (text . show) (mc_closures m))) + , hang (text "JS Statics::") 2 (vcat (fmap (text . show) (mc_statics m))) + , hang (text "JS ForeignRefs::") 2 (vcat (fmap (text . show) (mc_frefs m))) + ] + -- | ModuleCode after link with other modules. -- -- It contains less information than ModuleCode because they have been commoned -- up into global "metadata" for the whole link. data CompactedModuleCode = CompactedModuleCode { cmc_module :: !Module - , cmc_js_code :: !Sat.JStat + , cmc_js_code :: !JS.JStat , cmc_exports :: !B.ByteString -- ^ rendered exports } -- | Output JS statements and return the output size in bytes. -hPutJS :: Bool -> Handle -> Sat.JStat -> IO Integer +hPutJS :: Bool -> Handle -> JS.JStat -> IO Integer hPutJS render_pretty h = \case - Sat.BlockStat [] -> pure 0 + JS.BlockStat [] -> pure 0 x -> do before <- hTell h if render_pretty @@ -446,19 +590,17 @@ pure $! (after - before) -- | Link modules and pretty-print them into the given Handle -renderLinker +renderModules :: Handle -> Bool -- ^ should we render readable JS for debugging? -> [ModuleCode] -- ^ linked code per module - -> Set FilePath -- ^ additional JS files -> IO LinkerStats -renderLinker h render_pretty mods js_files = do +renderModules h render_pretty mods = do -- link modules let (compacted_mods, meta) = linkModules mods let - putBS = B.hPut h putJS = hPutJS render_pretty h --------------------------------------------------------- @@ -470,21 +612,20 @@ -- modules themselves mod_sizes <- forM compacted_mods $ \m -> do - !mod_size <- fromIntegral <$> putJS (cmc_js_code m) + + !mod_size <- fromIntegral <$> (putJS $ cmc_js_code m) let !mod_mod = cmc_module m pure (mod_mod, mod_size) -- commoned up metadata - !meta_length <- fromIntegral <$> putJS (jsOptimize $ satJStat Nothing meta) + let meta_opt = jsOptimize meta + !meta_length <- fromIntegral <$> putJS meta_opt -- module exports - mapM_ (putBS . cmc_exports) compacted_mods - - -- explicit additional JS files - mapM_ (\i -> B.readFile i >>= putBS) (S.toList js_files) + mapM_ (B.hPut h . cmc_exports) compacted_mods -- stats - let link_stats = LinkerStats + let !link_stats = LinkerStats { bytesPerModule = M.fromList mod_sizes , packedMetaDataSize = meta_length } @@ -526,14 +667,21 @@ getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] -getPackageArchives cfg unit_env units = - filterM doesFileExist [ ST.unpack p "lib" ++ ST.unpack l ++ profSuff <.> "a" - | u <- units - , p <- getInstalledPackageLibDirs ue_state u - , l <- getInstalledPackageHsLibs ue_state u - ] +getPackageArchives cfg unit_env units = do + fmap concat $ forM units $ \u -> do + let archives = [ ST.unpack p "lib" ++ ST.unpack l ++ profSuff <.> "a" + | p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + foundArchives <- filterM doesFileExist archives + if | not (null archives) + , null foundArchives + -> do + throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u)) + | otherwise + -> pure foundArchives where - ue_state = ue_units unit_env + ue_state = ue_homeUnitState unit_env -- XXX the profiling library name is probably wrong now profSuff | csProf cfg = "_p" @@ -543,15 +691,20 @@ -- | Combine rts.js, lib.js, out.js to all.js that can be run -- directly with node.js or SpiderMonkey jsshell combineFiles :: JSLinkConfig + -> Bool -- has clibs.js -> FilePath -> IO () -combineFiles cfg fp = do - let files = map (fp ) ["rts.js", "lib.js", "out.js"] - withBinaryFile (fp "all.js") WriteMode $ \h -> do - let cpy i = B.readFile i >>= B.hPut h - mapM_ cpy files - unless (lcNoHsMain cfg) $ do - B.hPut h runMainJS +combineFiles cfg has_clibs fp = do + let files = map (fp ) $ catMaybes + [ Just "rts.js" + , Just "lib.js" + , Just "out.js" + , if has_clibs then Just "clibs.js" else Nothing + , if lcNoHsMain cfg then Nothing else Just "runmain.js" + ] + withBinaryFile (fp "all.js") WriteMode $ \h -> + forM_ files $ \i -> + B.readFile i >>= B.hPut h -- | write the index.html file that loads the program if it does not exit writeHtml @@ -579,16 +732,22 @@ -- index.html is loaded writeRunMain :: FilePath -- ^ output directory + -> UseEmccRts -> IO () -writeRunMain out = do +writeRunMain out use_emcc_rts = do let runMainFile = out "runmain.js" - e <- doesFileExist runMainFile - unless e $ - B.writeFile runMainFile runMainJS + B.writeFile runMainFile (runMainJS use_emcc_rts) -runMainJS :: B.ByteString -runMainJS = "h$main(h$mainZCZCMainzimain);\n" +newtype UseEmccRts = UseEmccRts Bool +runMainJS :: UseEmccRts -> B.ByteString +runMainJS (UseEmccRts use_emcc_rts) = if use_emcc_rts + then "Module['onRuntimeInitialized'] = function() {\n\ + \h$initEmscriptenHeap();\n\ + \h$main(h$mainZCZCMainzimain);\n\ + \}\n" + else "h$main(h$mainZCZCMainzimain);\n" + writeRunner :: JSLinkConfig -- ^ Settings -> FilePath -- ^ Output directory -> IO () @@ -606,17 +765,76 @@ rtsExterns :: FastString rtsExterns = + -- Google Closure Compiler --externs option is deprecated. + -- Need pass them as a js file with @externs module-level jsdoc. + "/** @externs @suppress {duplicate} */\n" <> "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <> - mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") - [(7::Int)..16384]) + mconcat + -- See GHC.StgToJS + -- We connect all payload fields "dXX" on JavaScript Object. + -- That's most simple way to make Google Closure Compiler prevent + -- property names mangling. + (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") + [(1::Int)..16384]) <> + mconcat + (map (\x -> "/** @type {*} */\nObject." <> x <> ";\n") + -- We do same for special STG properties as well. + ["m", "f", "cc", "t", "size", "i", "n", "a", "r", "s"]) <> + mconcat + [ -- Used at h$mkForeignCallback + "/** @type {*} */\nObject.mv;\n" + ] <> + mconcat + (map (\x -> x <> ";\n") + [ -- Externs needed by node environment + "/** @type {string} */ var __dirname" + -- Copied minimally from https://github.com/externs/nodejs/blob/6c6882c73efcdceecf42e7ba11f1e3e5c9c041f0/v8/nodejs.js#L8 + , "/** @const */ var NodeJS = {}" + -- NodeJS Stream interface + , "/** @interface */ NodeJS.Stream = function () {}" + , "/** @template THIS @this {THIS} @return {THIS} */ NodeJS.Stream.prototype.on = function() {}" + , "/** @return {boolean} */ NodeJS.Stream.prototype.write = function() {}" + -- NodeJS versions property contains actual versions of the environment + , "/** @interface */ NodeJS.ProcessVersions = function() {}" + , "/** @type {string} */ NodeJS.ProcessVersions.prototype.node" + -- NodeJS Process interface + , "/** @interface */ NodeJS.Process = function() {}" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stderr" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdin" + , "/** @type {!NodeJS.Stream} */ NodeJS.Process.prototype.stdout" + , "/** @type {!NodeJS.ProcessVersions} */ NodeJS.Process.prototype.versions" + , "/** @return {?} */ NodeJS.Process.prototype.exit = function() {}" + , "/** @type {!Array} */ NodeJS.Process.prototype.argv" + -- NodeJS Process definition + , "/** @type {!NodeJS.Process} */ var process" + -- NodeJS Buffer class + , "/** @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" + ]) writeExterns :: FilePath -> IO () -writeExterns out = writeFile (out "all.js.externs") +writeExterns out = writeFile (out "all.externs.js") $ unpackFS rtsExterns -- | 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 @@ -632,7 +850,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 @@ -707,8 +925,8 @@ in open `S.union` S.fromList (filter (not . alreadyLinked) new_blocks) -- | collect dependencies for a set of roots -collectModuleCodes :: LinkPlan -> IO [ModuleCode] -collectModuleCodes link_plan = do +collectModuleCodes :: ArchiveCache -> LinkPlan -> IO [ModuleCode] +collectModuleCodes ar_cache link_plan = do let block_info = lkp_block_info link_plan let blocks = lkp_dep_blocks link_plan @@ -719,28 +937,13 @@ module_blocks = M.fromListWith IS.union $ map (\ref -> (block_ref_mod ref, IS.singleton (block_ref_idx ref))) (S.toList blocks) - -- GHCJS had this comment: "read ghc-prim first, since we depend on that for - -- static initialization". Not sure if it's still true as we haven't ported - -- the compactor yet. Still we sort to read ghc-prim blocks first just in - -- case. - let pred x = moduleUnitId (fst x) == primUnitId - cmp x y = case (pred x, pred y) of - (True,False) -> LT - (False,True) -> GT - (True,True) -> EQ - (False,False) -> EQ - - sorted_module_blocks :: [(Module,BlockIds)] - sorted_module_blocks = sortBy cmp (M.toList module_blocks) - -- load blocks - ar_state <- emptyArchiveState - forM sorted_module_blocks $ \(mod,bids) -> do + forM (M.toList module_blocks) $ \(mod,bids) -> do case M.lookup mod block_info of Nothing -> pprPanic "collectModuleCodes: couldn't find block info for module" (ppr mod) - Just lbi -> extractBlocks ar_state lbi bids + Just lbi -> extractBlocks ar_cache lbi bids -extractBlocks :: ArchiveState -> LocatedBlockInfo -> BlockIds -> IO ModuleCode +extractBlocks :: ArchiveCache -> LocatedBlockInfo -> BlockIds -> IO ModuleCode extractBlocks ar_state lbi blocks = do case lbi_loc lbi of ObjectFile fp -> do @@ -767,16 +970,22 @@ , mc_frefs = concatMap oiFImports l } -readArObject :: ArchiveState -> Module -> FilePath -> IO Object -readArObject ar_state mod ar_file = do - loaded_ars <- readIORef (loadedArchives ar_state) - (Ar.Archive entries) <- case M.lookup ar_file loaded_ars of +-- | Load an archive in memory and store it in the cache for future loads. +loadArchive :: ArchiveCache -> FilePath -> IO Ar.Archive +loadArchive ar_cache ar_file = do + loaded_ars <- readIORef (loadedArchives ar_cache) + case M.lookup ar_file loaded_ars of Just a -> pure a Nothing -> do a <- Ar.loadAr ar_file - modifyIORef (loadedArchives ar_state) (M.insert ar_file a) + modifyIORef (loadedArchives ar_cache) (M.insert ar_file a) pure a + +readArObject :: ArchiveCache -> Module -> FilePath -> IO Object +readArObject ar_cache mod ar_file = do + Ar.Archive entries <- loadArchive ar_cache ar_file + -- look for the right object in archive let go_entries = \case -- XXX this shouldn't be an exception probably @@ -798,49 +1007,34 @@ go_entries entries - --- | A helper function to read system dependencies that are hardcoded -diffDeps - :: [UnitId] -- ^ Packages that are already Linked - -> ([UnitId], Set ExportedFun) -- ^ New units and functions to link - -> ([UnitId], Set ExportedFun) -- ^ Diff -diffDeps pkgs (deps_pkgs,deps_funs) = - ( filter linked_pkg deps_pkgs - , S.filter linked_fun deps_funs - ) - where - linked_fun f = moduleUnitId (funModule f) `S.member` linked_pkgs - linked_pkg p = S.member p linked_pkgs - linked_pkgs = S.fromList pkgs - -- | dependencies for the RTS, these need to be always linked -rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun) -rtsDeps pkgs = diffDeps pkgs $ - ( [baseUnitId, primUnitId] +rtsDeps :: ([UnitId], Set ExportedFun) +rtsDeps = + ( [ghcInternalUnitId] , S.fromList $ concat - [ mkBaseFuns "GHC.Conc.Sync" + [ mkInternalFuns "GHC.Internal.Conc.Sync" ["reportError"] - , mkBaseFuns "Control.Exception.Base" + , mkInternalFuns "GHC.Internal.Control.Exception.Base" ["nonTermination"] - , mkBaseFuns "GHC.Exception.Type" + , mkInternalFuns "GHC.Internal.Exception.Type" [ "SomeException" , "underflowException" , "overflowException" , "divZeroException" ] - , mkBaseFuns "GHC.TopHandler" + , mkInternalFuns "GHC.Internal.TopHandler" [ "runMainIO" , "topHandler" ] - , mkBaseFuns "GHC.Base" + , mkInternalFuns "GHC.Internal.Base" ["$fMonadIO"] - , mkBaseFuns "GHC.Maybe" + , mkInternalFuns "GHC.Internal.Maybe" [ "Nothing" , "Just" ] - , mkBaseFuns "GHC.Ptr" + , mkInternalFuns "GHC.Internal.Ptr" ["Ptr"] - , mkBaseFuns "GHC.JS.Prim" + , mkInternalFuns "GHC.Internal.JS.Prim" [ "JSVal" , "JSException" , "$fShowJSException" @@ -849,7 +1043,7 @@ , "resolveIO" , "toIO" ] - , mkBaseFuns "GHC.JS.Prim.Internal" + , mkInternalFuns "GHC.Internal.JS.Prim.Internal" [ "wouldBlock" , "blockedIndefinitelyOnMVar" , "blockedIndefinitelyOnSTM" @@ -857,11 +1051,11 @@ , "setCurrentThreadResultException" , "setCurrentThreadResultValue" ] - , mkPrimFuns "GHC.Types" + , mkInternalFuns "GHC.Internal.Types" [ ":" , "[]" ] - , mkPrimFuns "GHC.Tuple.Prim" + , mkInternalFuns "GHC.Internal.Tuple" [ "(,)" , "(,,)" , "(,,,)" @@ -875,13 +1069,9 @@ ] ) --- | Export the functions in base -mkBaseFuns :: FastString -> [FastString] -> [ExportedFun] -mkBaseFuns = mkExportedFuns baseUnitId - --- | Export the Prim functions -mkPrimFuns :: FastString -> [FastString] -> [ExportedFun] -mkPrimFuns = mkExportedFuns primUnitId +-- | Export the functions in @ghc-internal@ +mkInternalFuns :: FastString -> [FastString] -> [ExportedFun] +mkInternalFuns = mkExportedFuns ghcInternalUnitId -- | Given a @UnitId@, a module name, and a set of symbols in the module, -- package these into an @ExportedFun@. @@ -899,15 +1089,16 @@ mk_fun sym = ExportedFun mod (LexicalFastString sym) -- | read all dependency data from the to-be-linked files -loadObjBlockInfo :: [LinkedObj] -- ^ object files to link - -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadObjBlockInfo + :: [FilePath] -- ^ object files to link + -> IO (Map Module LocatedBlockInfo, [BlockRef]) loadObjBlockInfo objs = (prepareLoadedDeps . catMaybes) <$> mapM readBlockInfoFromObj objs -- | Load dependencies for the Linker from Ar -loadArchiveBlockInfo :: [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef]) -loadArchiveBlockInfo archives = do +loadArchiveBlockInfo :: ArchiveCache -> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadArchiveBlockInfo ar_cache archives = do archDeps <- forM archives $ \file -> do - (Ar.Archive entries) <- Ar.loadAr file + (Ar.Archive entries) <- loadArchive ar_cache file catMaybes <$> mapM (readEntry file) entries return (prepareLoadedDeps $ concat archDeps) where @@ -922,34 +1113,6 @@ let !info = objBlockInfo obj pure $ Just (LocatedBlockInfo (ArchiveFile ar_file) info) --- | Predicate to check that an entry in Ar is a JS source --- and to return it without its header -getJsArchiveEntry :: Ar.ArchiveEntry -> Maybe B.ByteString -getJsArchiveEntry entry = getJsBS (Ar.filedata entry) - --- | Predicate to check that a file is a JS source -isJsFile :: FilePath -> IO Bool -isJsFile fp = withBinaryFile fp ReadMode $ \h -> do - bs <- B.hGet h jsHeaderLength - pure (isJsBS bs) - -isJsBS :: B.ByteString -> Bool -isJsBS bs = isJust (getJsBS bs) - --- | Get JS source with its header (if it's one) -getJsBS :: B.ByteString -> Maybe B.ByteString -getJsBS bs = B.stripPrefix jsHeader bs - --- Header added to JS sources to discriminate them from other object files. --- They all have .o extension but JS sources have this header. -jsHeader :: B.ByteString -jsHeader = "//JavaScript" - -jsHeaderLength :: Int -jsHeaderLength = B.length jsHeader - - - prepareLoadedDeps :: [LocatedBlockInfo] -> (Map Module LocatedBlockInfo, [BlockRef]) prepareLoadedDeps lbis = (module_blocks, must_link) @@ -967,25 +1130,21 @@ -- | read block info from an object that might have already been into memory -- pulls in all Deps from an archive -readBlockInfoFromObj :: LinkedObj -> IO (Maybe LocatedBlockInfo) -readBlockInfoFromObj = \case - ObjLoaded name obj -> do - let !info = objBlockInfo obj - pure $ Just (LocatedBlockInfo (InMemory name obj) info) - ObjFile file -> do - readObjectBlockInfo file >>= \case - Nothing -> pure Nothing - Just info -> pure $ Just (LocatedBlockInfo (ObjectFile file) info) +readBlockInfoFromObj :: FilePath -> IO (Maybe LocatedBlockInfo) +readBlockInfoFromObj file = do + readObjectBlockInfo file >>= \case + Nothing -> pure Nothing + Just info -> pure $ Just (LocatedBlockInfo (ObjectFile file) info) --- | Embed a JS file into a .o file --- --- The JS file is merely copied into a .o file with an additional header --- ("//Javascript") in order to be recognized later on. +-- | Embed a JS file into a JS object .o file -- -- JS files may contain option pragmas of the form: //#OPTIONS: --- For now, only the CPP option is supported. If the CPP option is set, we --- append some common CPP definitions to the file and call cpp on it. +-- One of those is //#OPTIONS:CPP. When it is set, we append some common CPP +-- definitions to the file and call cpp on it. +-- +-- Other options (e.g. EMCC additional flags for link time) are stored in the +-- JS object header. See JSOptions. embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO () embedJsFile logger dflags tmpfs unit_env input_fn output_fn = do let profiling = False -- FIXME: add support for profiling way @@ -995,12 +1154,14 @@ -- the header lets the linker recognize processed JavaScript files -- But don't add JavaScript header to object files! - -- header appended to JS files stored as .o to recognize them. - let header = "//JavaScript\n" - jsFileNeedsCpp input_fn >>= \case - False -> copyWithHeader header input_fn output_fn - True -> do + -- read pragmas from JS file + -- we need to store them explicitly as they can be removed by CPP. + opts <- getOptionsFromJsFile input_fn + -- run CPP if needed + cpp_fn <- case enableCPP opts of + False -> pure input_fn + True -> do -- append common CPP definitions to the .js file. -- They define macros that avoid directly wiring zencoded names -- in RTS JS files @@ -1012,8 +1173,9 @@ js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" let cpp_opts = CppOpts - { cppUseCc = True - , cppLinePragmas = False -- LINE pragmas aren't JS compatible + { sourceCodePreprocessor = SCPJsCpp + -- JS code requires keeping JSDoc comments for third party minification tooling + , cppLinePragmas = False -- LINE pragmas aren't JS compatible } doCpp logger tmpfs @@ -1022,19 +1184,17 @@ cpp_opts pp_fn js_fn - -- add header to recognize the object as a JS file - copyWithHeader header js_fn output_fn + pure js_fn -jsFileNeedsCpp :: FilePath -> IO Bool -jsFileNeedsCpp fn = do - opts <- getOptionsFromJsFile fn - pure (CPP `elem` opts) + -- write JS object + cpp_bs <- B.readFile cpp_fn + writeJSObject opts cpp_bs output_fn -- | Link module codes. -- -- Performs link time optimizations and produces one JStat per module plus some -- commoned up initialization code. -linkModules :: [ModuleCode] -> ([CompactedModuleCode], JStat) +linkModules :: [ModuleCode] -> ([CompactedModuleCode], JS.JStat) linkModules mods = (compact_mods, meta) where compact_mods = map compact mods @@ -1061,7 +1221,7 @@ -- render metadata as individual statements [ mconcat (map staticDeclStat statics) , mconcat (map staticInitStat statics) - , mconcat (map (closureInfoStat debug) infos) + , jStgStatToJS $ mconcat (map (closureInfoStat debug) infos) ] -- | Only keep a single StaticInfo with a given name @@ -1081,30 +1241,26 @@ -- | Initialize a global object. -- -- All global objects have to be declared (staticInfoDecl) first. -staticInitStat :: StaticInfo -> JStat +staticInitStat :: StaticInfo -> JS.JStat staticInitStat (StaticInfo i sv mcc) = + jStgStatToJS $ case sv of - StaticData con args -> appS "h$sti" $ add_cc_arg - [ var i - , var con - , jsStaticArgs args - ] - StaticFun f args -> appS "h$sti" $ add_cc_arg - [ var i - , var f - , jsStaticArgs args - ] - StaticList args mt -> appS "h$stl" $ add_cc_arg - [ var i - , jsStaticArgs args - , toJExpr $ maybe null_ (toJExpr . TxtI) mt - ] - StaticThunk (Just (f,args)) -> appS "h$stc" $ add_cc_arg - [ var i - , var f - , jsStaticArgs args - ] - _ -> mempty + (StaticApp k app args) -> appS + (if k == SAKThunk then hdStcStr else hdStiStr) + $ add_cc_arg + [ global i + , global app + , jsStaticArgs args + ] + + StaticList args mt -> appS hdStlStr + $ add_cc_arg + [ global i + , jsStaticArgs args + , toJExpr $ maybe null_ (toJExpr . TxtI) mt + ] + + StaticUnboxed _ -> mempty where -- add optional cost-center argument add_cc_arg as = case mcc of @@ -1112,23 +1268,27 @@ Just cc -> as ++ [toJExpr cc] -- | declare and do first-pass init of a global object (create JS object for heap objects) -staticDeclStat :: StaticInfo -> JStat -staticDeclStat (StaticInfo global_name static_value _) = decl +staticDeclStat :: StaticInfo -> JS.JStat +staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl where - global_ident = TxtI global_name + global_ident = name global_name decl_init v = global_ident ||= v - decl_no_init = appS "h$di" [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)] + 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] diff --git a/GHC/StgToJS/Linker/Opt.hs b/GHC/StgToJS/Linker/Opt.hs --- a/GHC/StgToJS/Linker/Opt.hs +++ b/GHC/StgToJS/Linker/Opt.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | @@ -59,7 +60,7 @@ hdd = SBS.pack (map (fromIntegral . ord) "h$$") ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc -ghcjsRenderJsI _ (TxtI fs) +ghcjsRenderJsI _ (identFS -> fs) -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by -- name in user code, only in compiled code. Hence we can rename them if we do -- it consistently in all the linked code. diff --git a/GHC/StgToJS/Linker/Types.hs b/GHC/StgToJS/Linker/Types.hs --- a/GHC/StgToJS/Linker/Types.hs +++ b/GHC/StgToJS/Linker/Types.hs @@ -18,8 +18,6 @@ module GHC.StgToJS.Linker.Types ( JSLinkConfig (..) - , defaultJSLinkConfig - , LinkedObj (..) , LinkPlan (..) ) where @@ -27,7 +25,7 @@ import GHC.StgToJS.Object import GHC.Unit.Types -import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat)) +import GHC.Utils.Outputable (Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat)) import Data.Map.Strict (Map) import Data.Set (Set) @@ -42,23 +40,18 @@ -------------------------------------------------------------------------------- data JSLinkConfig = JSLinkConfig - { lcNoJSExecutables :: !Bool -- ^ Dont' build JS executables - , lcNoHsMain :: !Bool -- ^ Don't generate Haskell main entry - , lcNoRts :: !Bool -- ^ Don't dump the generated RTS - , lcNoStats :: !Bool -- ^ Disable .stats file generation - , lcForeignRefs :: !Bool -- ^ Dump .frefs (foreign references) files - , lcCombineAll :: !Bool -- ^ Generate all.js (combined js) + wrappers - } - --- | Default linker configuration -defaultJSLinkConfig :: JSLinkConfig -defaultJSLinkConfig = JSLinkConfig - { lcNoJSExecutables = False - , lcNoHsMain = False - , lcNoRts = False - , lcNoStats = False - , lcCombineAll = True - , lcForeignRefs = True + { lcNoJSExecutables :: !Bool -- ^ Dont' build JS executables + , lcNoHsMain :: !Bool -- ^ Don't generate Haskell main entry + , lcNoRts :: !Bool -- ^ Don't dump the generated RTS + , lcNoStats :: !Bool -- ^ Disable .stats file generation + , lcForeignRefs :: !Bool -- ^ Dump .frefs (foreign references) files + , lcCombineAll :: !Bool -- ^ Generate all.js (combined js) + wrappers + , lcForceEmccRts :: !Bool + -- ^ Force the link with the emcc rts. Use this if you plan to dynamically + -- load wasm modules made from C files (e.g. in iserv). + , lcLinkCsources :: !Bool + -- ^ Link C sources (compiled to JS/Wasm) with Haskell code compiled to + -- JS. This implies the use of the Emscripten RTS to load this code. } data LinkPlan = LinkPlan @@ -68,11 +61,15 @@ , lkp_dep_blocks :: Set BlockRef -- ^ Blocks to link - , lkp_archives :: Set FilePath - -- ^ Archives to load JS sources from + , lkp_archives :: !(Set FilePath) + -- ^ Archives to load JS and Cc sources from (JS code corresponding to + -- Haskell code is handled with blocks above) - , lkp_extra_js :: Set FilePath - -- ^ Extra JS files to link + , lkp_objs_js :: !(Set FilePath) + -- ^ JS objects to link + + , lkp_objs_cc :: !(Set FilePath) + -- ^ Cc objects to link } instance Outputable LinkPlan where @@ -81,20 +78,7 @@ -- plan, just meta info used to retrieve actual block contents -- [ hcat [ text "Block info: ", ppr (lkp_block_info s)] [ hcat [ text "Blocks: ", ppr (S.size (lkp_dep_blocks s))] - , hang (text "JS files from archives:") 2 (vcat (fmap text (S.toList (lkp_archives s)))) - , hang (text "Extra JS:") 2 (vcat (fmap text (S.toList (lkp_extra_js s)))) + , hang (text "Archives:") 2 (vcat (fmap text (S.toList (lkp_archives s)))) + , hang (text "Extra JS objects:") 2 (vcat (fmap text (S.toList (lkp_objs_js s)))) + , hang (text "Extra Cc objects:") 2 (vcat (fmap text (S.toList (lkp_objs_cc s)))) ] - --------------------------------------------------------------------------------- --- Linker Environment --------------------------------------------------------------------------------- - --- | An object file that's either already in memory (with name) or on disk -data LinkedObj - = ObjFile FilePath -- ^ load from this file - | ObjLoaded String Object -- ^ already loaded: description and payload - -instance Outputable LinkedObj where - ppr = \case - ObjFile fp -> hsep [text "ObjFile", text fp] - ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)] diff --git a/GHC/StgToJS/Linker/Utils.hs b/GHC/StgToJS/Linker/Utils.hs --- a/GHC/StgToJS/Linker/Utils.hs +++ b/GHC/StgToJS/Linker/Utils.hs @@ -17,12 +17,11 @@ ----------------------------------------------------------------------------- module GHC.StgToJS.Linker.Utils - ( getOptionsFromJsFile - , JSOption(..) - , jsExeFileName + ( jsExeFileName , getInstalledPackageLibDirs , getInstalledPackageHsLibs , commonCppDefs + , decodeModifiedUTF8 ) where @@ -41,18 +40,14 @@ import Prelude import GHC.Platform -import GHC.Utils.Misc import Data.List (isPrefixOf) -import System.IO -import Data.Char (isSpace) -import qualified Control.Exception as Exception import GHC.Builtin.Types import Language.Haskell.Syntax.Basic import GHC.Types.Name import GHC.StgToJS.Ids +import GHC.JS.Ident import GHC.Core.DataCon -import GHC.JS.Unsat.Syntax import GHC.Data.FastString -- | Retrieve library directories provided by the @UnitId@ in @UnitState@ @@ -82,18 +77,20 @@ -- | Generate macros MK_TUP* for tuples sized 2+. genMkTup :: Bool -> Int -> ByteString genMkTup profiling n = mconcat - [ "#define MK_TUP", sn -- #define MK_TUPn - , "(", B.intercalate "," xs, ")" -- (x1,x2,...) - , "(h$c", sn, "(" -- (h$cn( - , bytesFS symbol, "," -- h$ghczmprimZCGHCziTupleziPrimziZnT_con_e, -- , - , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs -- (x1),(x2),(...) - , if profiling then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" else "" -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM - , "))\n" -- ))\n + [ "#define MK_TUP", sn -- #define MK_TUPn + , "(", B.intercalate "," xs, ")" -- (x1,x2,...) + , "(h$c", sn, "(" -- (h$cn( + , bytesFS symbol, "," -- h$ghczminternalZCGHCziInternalziTupleziZnT_con_e, + , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs -- (x1),(x2),(...) + , if profiling -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM + then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" + else "" + , "))\n" -- ))\n ] where xs = take n $ map (("x" <>) . Char8.pack . show) ([1..] :: [Int]) sn = Char8.pack $ show n - TxtI symbol = makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod + symbol = identFS $ makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod name = tupleDataConName Boxed n mod = case nameModule_maybe name of Just m -> m @@ -122,57 +119,57 @@ -- GHCJS.Prim.JSVal , if profiling - then "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n" - else "#define MK_JSVAL(x) (h$c1(h$baseZCGHCziJSziPrimziJSVal_con_e, (x)))\n" + then "#define MK_JSVAL(x) (h$c1(h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM))\n" + else "#define MK_JSVAL(x) (h$c1(h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e, (x)))\n" , "#define JSVAL_VAL(x) ((x).d1)\n" -- GHCJS.Prim.JSException , if profiling - then "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n" - else "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n" + then "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$ghczminternalZCGHCziInternalziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n" + else "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$ghczminternalZCGHCziInternalziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n" -- Exception dictionary for JSException - , "#define HS_JSEXCEPTION_EXCEPTION h$baseZCGHCziJSziPrimzizdfExceptionJSException\n" + , "#define HS_JSEXCEPTION_EXCEPTION h$ghczminternalZCGHCziInternalziJSziPrimzizdfExceptionJSException\n" -- SomeException , if profiling - then "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n" - else "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except)))\n" + then "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$ghczminternalZCGHCziInternalziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n" + else "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$ghczminternalZCGHCziInternalziExceptionziTypeziSomeException_con_e,(dict),(except)))\n" -- GHC.Ptr.Ptr , if profiling - then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" - else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n" + then "#define MK_PTR(val,offset) (h$c2(h$ghczminternalZCGHCziInternalziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n" + else "#define MK_PTR(val,offset) (h$c2(h$ghczminternalZCGHCziInternalziPtrziPtr_con_e, (val), (offset)))\n" -- Put Addr# in ByteArray# or at Addr# (same thing) , "#define PUT_ADDR(a,o,va,vo) if (!(a).arr) (a).arr = []; (a).arr[o] = va; (a).dv.setInt32(o,vo,true);\n" - , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null_); var ro = (a).dv.getInt32(o,true);\n" + , "#define GET_ADDR(a,o,ra,ro) var ra = (((a).arr && (a).arr[o]) ? (a).arr[o] : null); var ro = (a).dv.getInt32(o,true);\n" -- Data.Maybe.Maybe - , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n" - , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n" - , "#define IS_JUST(cl) ((cl).f === h$baseZCGHCziMaybeziJust_con_e)\n" + , "#define HS_NOTHING h$ghczminternalZCGHCziInternalziMaybeziNothing\n" + , "#define IS_NOTHING(cl) ((cl).f === h$ghczminternalZCGHCziInternalziMaybeziNothing_con_e)\n" + , "#define IS_JUST(cl) ((cl).f === h$ghczminternalZCGHCziInternalziMaybeziJust_con_e)\n" , "#define JUST_VAL(jj) ((jj).d1)\n" -- "#define HS_NOTHING h$nothing\n" , if profiling - then "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n" - else "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val)))\n" + then "#define MK_JUST(val) (h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n" + else "#define MK_JUST(val) (h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, (val)))\n" -- Data.List - , "#define HS_NIL h$ghczmprimZCGHCziTypesziZMZN\n" - , "#define HS_NIL_CON h$ghczmprimZCGHCziTypesziZMZN_con_e\n" - , "#define IS_CONS(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZC_con_e)\n" - , "#define IS_NIL(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZMZN_con_e)\n" + , "#define HS_NIL h$ghczminternalZCGHCziInternalziTypesziZMZN\n" + , "#define HS_NIL_CON h$ghczminternalZCGHCziInternalziTypesziZMZN_con_e\n" + , "#define IS_CONS(cl) ((cl).f === h$ghczminternalZCGHCziInternalziTypesziZC_con_e)\n" + , "#define IS_NIL(cl) ((cl).f === h$ghczminternalZCGHCziInternalziTypesziZMZN_con_e)\n" , "#define CONS_HEAD(cl) ((cl).d1)\n" , "#define CONS_TAIL(cl) ((cl).d2)\n" , if profiling then mconcat - [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n" - , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), (cc)))\n" + [ "#define MK_CONS(head,tail) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail), (cc)))\n" ] else mconcat - [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n" - , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n" + [ "#define MK_CONS(head,tail) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail)))\n" + , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczminternalZCGHCziInternalziTypesziZC_con_e, (head), (tail)))\n" ] -- Data.Text @@ -197,6 +194,9 @@ -- resumable thunks , "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n" + -- making a thunk + , "#define MK_UPD_THUNK(closure) h$c1(h$upd_thunk_e,(closure))\n" + -- general deconstruction , "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n" , "#define CONSTR_TAG(x) ((x).f.a)\n" @@ -253,6 +253,10 @@ , "#define RETURN_UBX_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); return (x1); }\n" , "#define RETURN_UBX_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); h$ret9 = (x10); return (x1); }\n" + , "#define RETURN_INT64(h,l) RETURN_UBX_TUP2((h)|0,(l)>>>0)\n" + , "#define RETURN_WORD64(h,l) RETURN_UBX_TUP2((h)>>>0,(l)>>>0)\n" + , "#define RETURN_ADDR(a,o) RETURN_UBX_TUP2(a,o)\n" + , "#define CALL_UBX_TUP2(r1,r2,c) { (r1) = (c); (r2) = h$ret1; }\n" , "#define CALL_UBX_TUP3(r1,r2,r3,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; }\n" , "#define CALL_UBX_TUP4(r1,r2,r3,r4,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; }\n" @@ -283,37 +287,14 @@ | prefix `isPrefixOf` xs = drop (length prefix) xs | otherwise = xs - --- | Parse option pragma in JS file -getOptionsFromJsFile :: FilePath -- ^ Input file - -> IO [JSOption] -- ^ Parsed options, if any. -getOptionsFromJsFile filename - = Exception.bracket - (openBinaryFile filename ReadMode) - hClose - getJsOptions - -data JSOption = CPP deriving (Eq, Ord) - -getJsOptions :: Handle -> IO [JSOption] -getJsOptions handle = do - hSetEncoding handle utf8 - prefix' <- B.hGet handle prefixLen - if prefix == prefix' - then parseJsOptions <$> hGetLine handle - else pure [] - where - prefix :: B.ByteString - prefix = "//#OPTIONS:" - prefixLen = B.length prefix - -parseJsOptions :: String -> [JSOption] -parseJsOptions xs = go xs - where - trim = dropWhileEndLE isSpace . dropWhile isSpace - go [] = [] - go xs = let (tok, rest) = break (== ',') xs - tok' = trim tok - rest' = drop 1 rest - in if | tok' == "CPP" -> CPP : go rest' - | otherwise -> go rest' +-- 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 diff --git a/GHC/StgToJS/Literal.hs b/GHC/StgToJS/Literal.hs --- a/GHC/StgToJS/Literal.hs +++ b/GHC/StgToJS/Literal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module GHC.StgToJS.Literal ( genLit @@ -9,15 +10,16 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax 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.StgToJS.Linker.Utils (decodeModifiedUTF8) -import GHC.Data.FastString import GHC.Types.Literal import GHC.Types.Basic import GHC.Types.RepType @@ -35,15 +37,15 @@ -- * Addr# (Null and Strings): array and offset -- * 64-bit values: high 32-bit, low 32-bit -- * labels: call to h$mkFunctionPtr and 0, or function name and 0 -genLit :: HasDebugCallStack => Literal -> G [JExpr] +genLit :: HasDebugCallStack => Literal -> G [JStgExpr] genLit = \case LitChar c -> return [ toJExpr (ord c) ] LitString str -> - freshIdent >>= \strLit@(TxtI strLitT) -> - freshIdent >>= \strOff@(TxtI strOffT) -> do + freshIdent >>= \strLit@(identFS -> strLitT) -> + freshIdent >>= \strOff@(identFS -> strOffT) -> do emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing - return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ] + return [ Var strLit, Var strOff ] LitNullAddr -> return [ null_, ValExpr (JInt 0) ] LitNumber nt v -> case nt of LitNumInt -> return [ toJExpr v ] @@ -59,12 +61,12 @@ 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 (TxtI (mkRawSymbol True name)) + | otherwise -> return [ toJExpr (global (mkRawSymbol True name)) , ValExpr (JInt 0) ] LitRubbish _ rr_ty -> @@ -86,7 +88,6 @@ Int64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] DoubleRep -> [ ValExpr (JInt 0) ] FloatRep -> [ ValExpr (JInt 0) ] - VoidRep -> panic "GHC.StgToJS.Literal.genLit: LitRubbish(VoidRep)" VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported" in return (concatMap rub reps) @@ -94,9 +95,10 @@ genStaticLit :: Literal -> G [StaticLit] genStaticLit = \case LitChar c -> return [ IntLit (fromIntegral $ ord c) ] - LitString str - | True -> return [ StringLit (mkFastStringByteString str), IntLit 0] - -- \| invalid UTF8 -> return [ BinLit str, IntLit 0] + LitString str -> case decodeModifiedUTF8 str of + Just t -> return [ StringLit t, IntLit 0] + -- invalid UTF8 + Nothing -> return [ BinLit str, IntLit 0] LitNullAddr -> return [ NullLit, IntLit 0 ] LitNumber nt v -> case nt of LitNumInt -> return [ IntLit v ] @@ -112,11 +114,11 @@ 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 - in case expectOnly "GHC.StgToJS.Literal.genStaticLit" prim_reps of -- Note [Post-unarisation invariants] + in case expectOnly prim_reps of -- Note [Post-unarisation invariants] BoxedRep _ -> pure [ NullLit ] AddrRep -> pure [ NullLit, IntLit 0 ] IntRep -> pure [ IntLit 0 ] @@ -131,11 +133,10 @@ Word64Rep -> pure [ IntLit 0, IntLit 0 ] FloatRep -> pure [ DoubleLit (SaneDouble 0) ] DoubleRep -> pure [ DoubleLit (SaneDouble 0) ] - VoidRep -> panic "GHC.StgToJS.Literal.getStaticLit: LitRubbish(VoidRep)" VecRep {} -> pprPanic "GHC.StgToJS.Literal.genStaticLit: LitRubbish(VecRep) isn't supported" (ppr rep) -- make an unsigned 32 bit number from this unsigned one, lower 32 bits -toU32Expr :: Integer -> JExpr +toU32Expr :: Integer -> JStgExpr toU32Expr i = Int (i Bits..&. 0xFFFFFFFF) .>>>. 0 -- make an unsigned 32 bit number from this unsigned one, lower 32 bits diff --git a/GHC/StgToJS/Monad.hs b/GHC/StgToJS/Monad.hs --- a/GHC/StgToJS/Monad.hs +++ b/GHC/StgToJS/Monad.hs @@ -24,13 +24,14 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax -import qualified GHC.JS.Syntax as Sat +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import GHC.JS.Transform import GHC.StgToJS.Types import GHC.Unit.Module +import GHC.Utils.Outputable import GHC.Stg.Syntax import GHC.Types.SrcLoc @@ -44,7 +45,6 @@ import qualified Data.Map as M import qualified Data.Set as S -import qualified Data.List as L runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a runG config m unfloat action = State.evalStateT action =<< initState config m unfloat @@ -69,7 +69,7 @@ mod_state s = s { gsGroup = f (gsGroup s) } -- | emit a global (for the current module) toplevel statement -emitGlobal :: JStat -> G () +emitGlobal :: JStgStat -> G () emitGlobal stat = State.modify (\s -> s { gsGlobal = stat : gsGlobal s }) -- | add a dependency on a particular symbol to the current group @@ -79,7 +79,7 @@ mod_group g = g { ggsExtraDeps = S.insert symbol (ggsExtraDeps g) } -- | emit a top-level statement for the current binding group -emitToplevel :: JStat -> G () +emitToplevel :: JStgStat -> G () emitToplevel s = modifyGroup mod_group where mod_group g = g { ggsToplevelStats = s : ggsToplevelStats g} @@ -138,7 +138,7 @@ -assertRtsStat :: G JStat -> G JStat +assertRtsStat :: G JStgStat -> G JStgStat assertRtsStat stat = do s <- State.gets gsSettings if csAssertRts s then stat else pure mempty @@ -152,25 +152,30 @@ setGlobalIdCache :: GlobalIdCache -> G () setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}}) - data GlobalOcc = GlobalOcc - { global_ident :: !Ident - , global_id :: !Id + { global_id :: !Id , global_count :: !Word } --- | Return number of occurrences of every global id used in the given JStat. +instance Outputable GlobalOcc where + ppr g = hang (text "GlobalOcc") 2 $ vcat + [ hcat [text "Id:", ppr (global_id g)] + , hcat [text "Count:", ppr (global_count g)] + ] + +-- | Return occurrences of every global id used in the given JStgStat. -- Sort by increasing occurrence count. -globalOccs :: Sat.JStat -> G [GlobalOcc] +globalOccs :: JStgStat -> G (UniqFM Id GlobalOcc) globalOccs jst = do GlobalIdCache gidc <- getGlobalIdCache - -- build a map form Ident Unique to (Ident, Id, Count) + -- build a map form Ident Unique to (Id, Count) + -- Note that different Idents can map to the same Id (e.g. string payload and string offset idents) let - cmp_cnt g1 g2 = compare (global_count g1) (global_count g2) inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 } + + go :: UniqFM Id GlobalOcc -> [Ident] -> UniqFM Id GlobalOcc go gids = \case - [] -> -- return global Ids used locally sorted by increased use - L.sortBy cmp_cnt $ nonDetEltsUFM gids + [] -> gids (i:is) -> -- check if the Id is global case lookupUFM gidc i of @@ -178,7 +183,7 @@ Just (_k,gid) -> -- add it to the list of already found global ids. Increasing -- count by 1 - let g = GlobalOcc i gid 1 - in go (addToUFM_C inc gids i g) is + let g = GlobalOcc gid 1 + in go (addToUFM_C inc gids gid g) is - pure $ go emptyUFM (identsS jst) + pure $ go emptyUFM $ identsS jst diff --git a/GHC/StgToJS/Object.hs b/GHC/StgToJS/Object.hs --- a/GHC/StgToJS/Object.hs +++ b/GHC/StgToJS/Object.hs @@ -3,6 +3,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} -- only for DB.Binary instances on Module {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,28 +23,23 @@ -- Stability : experimental -- -- Serialization/deserialization of binary .o files for the JavaScript backend --- The .o files contain dependency information and generated code. --- All strings are mapped to a central string table, which helps reduce --- file size and gives us efficient hash consing on read -- --- Binary intermediate JavaScript object files: --- serialized [Text] -> ([ClosureInfo], JStat) blocks --- --- file layout: --- - magic "GHCJSOBJ" --- - compiler version tag --- - module name --- - offsets of string table --- - dependencies --- - offset of the index --- - unit infos --- - index --- - string table --- ----------------------------------------------------------------------------- module GHC.StgToJS.Object - ( putObject + ( ObjectKind(..) + , getObjectKind + , getObjectKindBS + -- * JS object + , JSOptions(..) + , defaultJSOptions + , getOptionsFromJsFile + , writeJSObject + , readJSObject + , parseJSObject + , parseJSObjectBS + -- * HS object + , putObject , getObjectHeader , getObjectBody , getObject @@ -50,7 +48,6 @@ , readObjectBlocks , readObjectBlockInfo , isGlobalBlock - , isJsObjectFile , Object(..) , IndexEntry(..) , LocatedBlockInfo (..) @@ -69,21 +66,23 @@ import Control.Monad import Data.Array +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Data.Char (isSpace) import Data.Int import Data.IntSet (IntSet) import qualified Data.IntSet as IS import Data.List (sortOn) +import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as M import Data.Word -import Data.Char -import Foreign.Storable -import Foreign.Marshal.Array -import System.IO +import Data.Semigroup +import System.IO import GHC.Settings.Constants (hiVersion) -import GHC.JS.Unsat.Syntax +import GHC.JS.Ident import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Types @@ -96,12 +95,80 @@ import GHC.Utils.Binary hiding (SymbolTable) import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep) import GHC.Utils.Monad (mapMaybeM) +import GHC.Utils.Panic +import GHC.Utils.Misc (dropWhileEndLE) +import System.IO.Unsafe +import qualified Control.Exception as Exception --- | An object file +---------------------------------------------- +-- The JS backend supports 3 kinds of objects: +-- 1. HS objects: produced from Haskell sources +-- 2. JS objects: produced from JS sources +-- 3. Cc objects: produced by emcc (e.g. from C sources) +-- +-- They all have a different header that allows them to be distinguished. +-- See ObjectKind type. +---------------------------------------------- + +-- | Different kinds of object (.o) supported by the JS backend +data ObjectKind + = ObjJs -- ^ JavaScript source embedded in a .o + | ObjHs -- ^ JS backend object for Haskell code + | ObjCc -- ^ Wasm module object as produced by emcc + deriving (Show,Eq,Ord) + +-- | Get the kind of a file object, if any +getObjectKind :: FilePath -> IO (Maybe ObjectKind) +getObjectKind fp = withBinaryFile fp ReadMode $ \h -> do + let !max_header_length = max (B.length jsHeader) + $ max (B.length wasmHeader) + (B.length hsHeader) + + bs <- B.hGet h max_header_length + pure $! getObjectKindBS bs + +-- | Get the kind of an object stored in a bytestring, if any +getObjectKindBS :: B.ByteString -> Maybe ObjectKind +getObjectKindBS bs + | jsHeader `B.isPrefixOf` bs = Just ObjJs + | hsHeader `B.isPrefixOf` bs = Just ObjHs + | wasmHeader `B.isPrefixOf` bs = Just ObjCc + | otherwise = Nothing + +-- Header added to JS sources to discriminate them from other object files. +-- They all have .o extension but JS sources have this header. +jsHeader :: B.ByteString +jsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_JS"# + +hsHeader :: B.ByteString +hsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_HS"# + +wasmHeader :: B.ByteString +wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"# + + + +------------------------------------------------ +-- HS objects +-- +-- file layout: +-- - magic "GHCJS_HS" +-- - compiler version tag +-- - module name +-- - offsets of string table +-- - dependencies +-- - offset of the index +-- - unit infos +-- - index +-- - string table +-- +------------------------------------------------ + +-- | A HS object file data Object = Object { objModuleName :: !ModuleName -- ^ name of the module - , objHandle :: !BinHandle + , objHandle :: !ReadBinHandle -- ^ BinHandle that can be used to read the ObjBlocks , objPayloadOffset :: !(Bin ObjBlock) -- ^ Offset of the payload (units) @@ -186,25 +253,25 @@ -- | Write an ObjBlock, except for the top level symbols which are stored in the -- index -putObjBlock :: BinHandle -> ObjBlock -> IO () +putObjBlock :: WriteBinHandle -> ObjBlock -> IO () putObjBlock bh (ObjBlock _syms b c d e f g) = do - put_ bh b - put_ bh c + lazyPut bh b + lazyPut bh c lazyPut bh d - put_ bh e - put_ bh f - put_ bh g + lazyPut bh e + lazyPut bh f + lazyPut bh g -- | Read an ObjBlock and associate it to the given symbols (that must have been -- read from the index) -getObjBlock :: [FastString] -> BinHandle -> IO ObjBlock +getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock getObjBlock syms bh = do - b <- get bh - c <- get bh + b <- lazyGet bh + c <- lazyGet bh d <- lazyGet bh - e <- get bh - f <- get bh - g <- get bh + e <- lazyGet bh + f <- lazyGet bh + g <- lazyGet bh pure $ ObjBlock { oiSymbols = syms , oiClInfo = b @@ -216,11 +283,6 @@ } --- | A tag that determines the kind of payload in the .o file. See --- @StgToJS.Linker.Arhive.magic@ for another kind of magic -magic :: String -magic = "GHCJSOBJ" - -- | Serialized block indexes and their exported symbols -- (the first block is module-global) type Index = [IndexEntry] @@ -231,19 +293,19 @@ -------------------------------------------------------------------------------- --- Essential oeprations on Objects +-- Essential operations on Objects -------------------------------------------------------------------------------- -- | Given a handle to a Binary payload, add the module, 'mod_name', its -- dependencies, 'deps', and its linkable units to the payload. putObject - :: BinHandle + :: WriteBinHandle -> ModuleName -- ^ module -> BlockInfo -- ^ block infos -> [ObjBlock] -- ^ linkable units and their symbols -> IO () putObject bh mod_name deps os = do - forM_ magic (putByte bh . fromIntegral . ord) + putByteString bh hsHeader put_ bh (show hiVersion) -- we store the module name as a String because we don't want to have to @@ -251,52 +313,28 @@ -- object in an archive. put_ bh (moduleNameString mod_name) - (bh_fs, _bin_dict, put_dict) <- initFSTable bh + (fs_tbl, fs_writer) <- initFastStringWriterTable + let bh_fs = addWriterToUserData fs_writer bh - forwardPut_ bh (const put_dict) $ do + forwardPut_ bh (const (putTable fs_tbl bh_fs)) $ do put_ bh_fs deps -- forward put the index forwardPut_ bh_fs (put_ bh_fs) $ do idx <- forM os $ \o -> do - p <- tellBin bh_fs + p <- tellBinWriter bh_fs -- write units without their symbols putObjBlock bh_fs o -- return symbols and offset to store in the index pure (oiSymbols o,p) pure idx --- | Test if the object file is a JS object -isJsObjectFile :: FilePath -> IO Bool -isJsObjectFile fp = do - let !n = length magic - withBinaryFile fp ReadMode $ \hdl -> do - allocaArray n $ \ptr -> do - n' <- hGetBuf hdl ptr n - if (n' /= n) - then pure False - else checkMagic (peekElemOff ptr) - --- | Check magic -checkMagic :: (Int -> IO Word8) -> IO Bool -checkMagic get_byte = do - let go_magic !i = \case - [] -> pure True - (e:es) -> get_byte i >>= \case - c | fromIntegral (ord e) == c -> go_magic (i+1) es - | otherwise -> pure False - go_magic 0 magic - --- | Parse object magic -getCheckMagic :: BinHandle -> IO Bool -getCheckMagic bh = checkMagic (const (getByte bh)) - -- | Parse object header -getObjectHeader :: BinHandle -> IO (Either String ModuleName) +getObjectHeader :: ReadBinHandle -> IO (Either String ModuleName) getObjectHeader bh = do - is_magic <- getCheckMagic bh - case is_magic of - False -> pure (Left "invalid magic header") + magic <- getByteString bh (B.length hsHeader) + case magic == hsHeader of + False -> pure (Left "invalid magic header for HS object") True -> do is_correct_version <- ((== hiVersion) . read) <$> get bh case is_correct_version of @@ -306,16 +344,16 @@ pure (Right (mkModuleName (mod_name))) --- | Parse object body. Must be called after a sucessful getObjectHeader -getObjectBody :: BinHandle -> ModuleName -> IO Object +-- | Parse object body. Must be called after a successful getObjectHeader +getObjectBody :: ReadBinHandle -> ModuleName -> IO Object getObjectBody bh0 mod_name = do -- Read the string table dict <- forwardGet bh0 (getDictionary bh0) - let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict } + let bh = setReaderUserData bh0 $ newReadState (panic "No name allowed") (getDictFastString dict) block_info <- get bh idx <- forwardGet bh (get bh) - payload_pos <- tellBin bh + payload_pos <- tellBinReader bh pure $ Object { objModuleName = mod_name @@ -326,7 +364,7 @@ } -- | Parse object -getObject :: BinHandle -> IO (Maybe Object) +getObject :: ReadBinHandle -> IO (Maybe Object) getObject bh = do getObjectHeader bh >>= \case Left _err -> pure Nothing @@ -355,7 +393,7 @@ bh = objHandle obj read_entry (IndexEntry syms offset,i) | IS.member i bids = do - seekBin bh offset + seekBinReader bh offset Just <$> getObjBlock syms bh | otherwise = pure Nothing @@ -371,12 +409,12 @@ -- Helper functions -------------------------------------------------------------------------------- -putEnum :: Enum a => BinHandle -> a -> IO () +putEnum :: Enum a => WriteBinHandle -> a -> IO () putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n) | otherwise = put_ bh n where n = fromIntegral $ fromEnum x :: Word16 -getEnum :: Enum a => BinHandle -> IO a +getEnum :: Enum a => ReadBinHandle -> IO a getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16) -- | Helper to convert Int to Int32 @@ -483,8 +521,9 @@ put_ bh (Sat.JInt i) = putByte bh 4 >> put_ bh i put_ bh (Sat.JStr xs) = putByte bh 5 >> put_ bh xs put_ bh (Sat.JRegEx xs) = putByte bh 6 >> put_ bh xs - put_ bh (Sat.JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m) - put_ bh (Sat.JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s + put_ bh (Sat.JBool b) = putByte bh 7 >> put_ bh b + put_ bh (Sat.JHash m) = putByte bh 8 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m) + put_ bh (Sat.JFunc is s) = putByte bh 9 >> put_ bh is >> put_ bh s get bh = getByte bh >>= \case 1 -> Sat.JVar <$> get bh 2 -> Sat.JList <$> get bh @@ -492,13 +531,14 @@ 4 -> Sat.JInt <$> get bh 5 -> Sat.JStr <$> get bh 6 -> Sat.JRegEx <$> get bh - 7 -> Sat.JHash . listToUniqMap <$> get bh - 8 -> Sat.JFunc <$> get bh <*> get bh + 7 -> Sat.JBool <$> get bh + 8 -> Sat.JHash . listToUniqMap <$> get bh + 9 -> Sat.JFunc <$> get bh <*> get bh n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n) instance Binary Ident where - put_ bh (TxtI xs) = put_ bh xs - get bh = TxtI <$> get bh + put_ bh (identFS -> xs) = put_ bh xs + get bh = name <$> get bh instance Binary ClosureInfo where put_ bh (ClosureInfo v regs name layo typ static) = do @@ -509,7 +549,7 @@ put_ bh = putEnum bh get bh = getEnum bh -instance Binary VarType where +instance Binary JSRep where put_ bh = putEnum bh get bh = getEnum bh @@ -575,16 +615,16 @@ get bh = StaticInfo <$> get bh <*> get bh <*> get bh instance Binary StaticVal where - put_ bh (StaticFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args - put_ bh (StaticThunk t) = putByte bh 2 >> put_ bh t - put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u - put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args - put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t + put_ bh (StaticApp SAKFun f args) = putByte bh 1 >> put_ bh f >> put_ bh args + put_ bh (StaticApp SAKThunk f args) = putByte bh 2 >> put_ bh f >> put_ bh args + put_ bh (StaticUnboxed u) = putByte bh 3 >> put_ bh u + put_ bh (StaticApp SAKData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args + put_ bh (StaticList xs t) = putByte bh 5 >> put_ bh xs >> put_ bh t get bh = getByte bh >>= \case - 1 -> StaticFun <$> get bh <*> get bh - 2 -> StaticThunk <$> get bh + 1 -> StaticApp SAKFun <$> get bh <*> get bh + 2 -> StaticApp SAKThunk <$> get bh <*> get bh 3 -> StaticUnboxed <$> get bh - 4 -> StaticData <$> get bh <*> get bh + 4 -> StaticApp SAKData <$> get bh <*> get bh 5 -> StaticList <$> get bh <*> get bh n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) @@ -629,3 +669,134 @@ 6 -> BinLit <$> get bh 7 -> LabelLit <$> get bh <*> get bh n -> error ("Binary get bh StaticLit: invalid tag " ++ show n) + + +------------------------------------------------ +-- JS objects +------------------------------------------------ + +-- | Options obtained from pragmas in JS files +data JSOptions = JSOptions + { enableCPP :: !Bool -- ^ Enable CPP on the JS file + , emccExtraOptions :: ![String] -- ^ Pass additional options to emcc at link time + , emccExportedFunctions :: ![String] -- ^ Arguments for `-sEXPORTED_FUNCTIONS` + , emccExportedRuntimeMethods :: ![String] -- ^ Arguments for `-sEXPORTED_RUNTIME_METHODS` + } + deriving (Eq, Ord) + + +instance Binary JSOptions where + put_ bh (JSOptions a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + get bh = JSOptions <$> get bh <*> get bh <*> get bh <*> get bh + +instance Semigroup JSOptions where + a <> b = JSOptions + { enableCPP = enableCPP a || enableCPP b + , emccExtraOptions = emccExtraOptions a ++ emccExtraOptions b + , emccExportedFunctions = List.nub (List.sort (emccExportedFunctions a ++ emccExportedFunctions b)) + , emccExportedRuntimeMethods = List.nub (List.sort (emccExportedRuntimeMethods a ++ emccExportedRuntimeMethods b)) + } + +defaultJSOptions :: JSOptions +defaultJSOptions = JSOptions + { enableCPP = False + , emccExtraOptions = [] + , emccExportedRuntimeMethods = [] + , emccExportedFunctions = [] + } + +-- mimics `lines` implementation +splitOnComma :: String -> [String] +splitOnComma s = cons $ case break (== ',') s of + (l, s') -> (l, case s' of + [] -> [] + _:s'' -> splitOnComma s'') + where + cons ~(h, t) = h : t + + + +-- | Get the JS option pragmas from .js files +getJsOptions :: Handle -> IO JSOptions +getJsOptions handle = do + hSetEncoding handle utf8 + let trim = dropWhileEndLE isSpace . dropWhile isSpace + let go opts = do + hIsEOF handle >>= \case + True -> pure opts + False -> do + xs <- hGetLine handle + if not ("//#OPTIONS:" `List.isPrefixOf` xs) + then pure opts + else do + -- drop prefix and spaces + let ys = trim (drop 11 xs) + let opts' = if + | ys == "CPP" + -> opts {enableCPP = True} + + | Just s <- List.stripPrefix "EMCC:EXPORTED_FUNCTIONS=" ys + , fns <- fmap trim (splitOnComma s) + -> opts { emccExportedFunctions = emccExportedFunctions opts ++ fns } + + | Just s <- List.stripPrefix "EMCC:EXPORTED_RUNTIME_METHODS=" ys + , fns <- fmap trim (splitOnComma s) + -> opts { emccExportedRuntimeMethods = emccExportedRuntimeMethods opts ++ fns } + + | Just s <- List.stripPrefix "EMCC:EXTRA=" ys + -> opts { emccExtraOptions = emccExtraOptions opts ++ [s] } + + | otherwise + -> panic ("Unrecognized JS pragma: " ++ ys) + + go opts' + go defaultJSOptions + +-- | Parse option pragma in JS file +getOptionsFromJsFile :: FilePath -- ^ Input file + -> IO JSOptions -- ^ Parsed options. +getOptionsFromJsFile filename + = Exception.bracket + (openBinaryFile filename ReadMode) + hClose + getJsOptions + + +-- | Write a JS object (embed some handwritten JS code) +writeJSObject :: JSOptions -> B.ByteString -> FilePath -> IO () +writeJSObject opts contents output_fn = do + bh <- openBinMem (B.length contents + 1000) + + putByteString bh jsHeader + put_ bh opts + put_ bh contents + + writeBinMem bh output_fn + + +-- | Read a JS object from BinHandle +parseJSObject :: ReadBinHandle -> IO (JSOptions, B.ByteString) +parseJSObject bh = do + magic <- getByteString bh (B.length jsHeader) + case magic == jsHeader of + False -> panic "invalid magic header for JS object" + True -> do + opts <- get bh + contents <- get bh + pure (opts,contents) + +-- | Read a JS object from ByteString +parseJSObjectBS :: B.ByteString -> IO (JSOptions, B.ByteString) +parseJSObjectBS bs = do + bh <- unsafeUnpackBinBuffer bs + parseJSObject bh + +-- | Read a JS object from file +readJSObject :: FilePath -> IO (JSOptions, B.ByteString) +readJSObject input_fn = do + bh <- readBinMem input_fn + parseJSObject bh diff --git a/GHC/StgToJS/Prim.hs b/GHC/StgToJS/Prim.hs --- a/GHC/StgToJS/Prim.hs +++ b/GHC/StgToJS/Prim.hs @@ -13,1587 +13,1685 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax hiding (JUOp (..)) -import GHC.JS.Make - -import GHC.StgToJS.Heap -import GHC.StgToJS.Types -import GHC.StgToJS.Profiling -import GHC.StgToJS.Regs - -import GHC.Core.Type - -import GHC.Builtin.PrimOps -import GHC.Tc.Utils.TcType (isBoolTy) -import GHC.Utils.Encoding (zEncodeString) - -import GHC.Data.FastString -import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) - - -genPrim :: Bool -- ^ Profiling (cost-centres) enabled - -> Bool -- ^ Array bounds-checking enabled - -> Type - -> PrimOp -- ^ the primitive operation - -> [JExpr] -- ^ where to store the result - -> [JExpr] -- ^ arguments - -> PrimRes -genPrim prof bound ty op = case op of - CharGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - CharGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - CharEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - CharNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - CharLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - CharLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - OrdOp -> \[r] [x] -> PrimInline $ r |= x - - Int8ToWord8Op -> \[r] [x] -> PrimInline $ r |= mask8 x - Word8ToInt8Op -> \[r] [x] -> PrimInline $ r |= signExtend8 x - Int16ToWord16Op -> \[r] [x] -> PrimInline $ r |= mask16 x - Word16ToInt16Op -> \[r] [x] -> PrimInline $ r |= signExtend16 x - Int32ToWord32Op -> \[r] [x] -> PrimInline $ r |= x .>>>. zero_ - Word32ToInt32Op -> \[r] [x] -> PrimInline $ r |= toI32 x - ------------------------------- Int ---------------------------------------------- - --- N.B. See Note [StgToJS design] in GHC.StgToJS for details on --- number representation. - - IntAddOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Add x y) - IntSubOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Sub x y) - IntMulOp -> \[r] [x,y] -> PrimInline $ r |= app "Math.imul" [x, y] - IntMul2Op -> \[c,hr,lr] [x,y] -> PrimInline $ appT [c,hr,lr] "h$hs_timesInt2" [x, y] - IntMulMayOfloOp -> \[r] [x,y] -> PrimInline $ jVar \tmp -> mconcat - [ tmp |= Mul x y - , r |= if01 (tmp .===. toI32 tmp) - ] - IntQuotOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (Div x y) - IntRemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y - IntQuotRemOp -> \[q,r] [x,y] -> PrimInline $ mconcat - [ q |= toI32 (Div x y) - , r |= x `Sub` (Mul y q) - ] - IntAndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y - IntOrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y - IntXorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y - IntNotOp -> \[r] [x] -> PrimInline $ r |= BNot x - - IntNegOp -> \[r] [x] -> PrimInline $ r |= toI32 (Negate x) --- add with carry: overflow == 0 iff no overflow - IntAddCOp -> \[r,overf] [x,y] -> - PrimInline $ jVar \rt -> mconcat - [ rt |= Add x y - , r |= toI32 rt - , overf |= if10 (r .!=. rt) - ] - IntSubCOp -> \[r,overf] [x,y] -> - PrimInline $ jVar \rt -> mconcat - [ rt |= Sub x y - , r |= toI32 rt - , overf |= if10 (r .!=. rt) - ] - IntGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - IntGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - IntEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - IntNeOp -> \[r] [x,y] -> PrimInline $ r |= if10(x .!==. y) - IntLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - IntLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - ChrOp -> \[r] [x] -> PrimInline $ r |= x - IntToWordOp -> \[r] [x] -> PrimInline $ r |= x .>>>. 0 - IntToFloatOp -> \[r] [x] -> PrimInline $ r |= x - IntToDoubleOp -> \[r] [x] -> PrimInline $ r |= x - IntSllOp -> \[r] [x,y] -> PrimInline $ r |= x .<<. y - IntSraOp -> \[r] [x,y] -> PrimInline $ r |= x .>>. y - IntSrlOp -> \[r] [x,y] -> PrimInline $ r |= toI32 (x .>>>. y) - ------------------------------- Int8 --------------------------------------------- - - Int8ToIntOp -> \[r] [x] -> PrimInline $ r |= x - IntToInt8Op -> \[r] [x] -> PrimInline $ r |= signExtend8 x - Int8NegOp -> \[r] [x] -> PrimInline $ r |= signExtend8 (Negate x) - Int8AddOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Add x y) - Int8SubOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Sub x y) - Int8MulOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (Mul x y) - Int8QuotOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (quotShortInt 8 x y) - Int8RemOp -> \[r] [x,y] -> PrimInline $ r |= signExtend8 (remShortInt 8 x y) - Int8QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat - [ r1 |= signExtend8 (quotShortInt 8 x y) - , r2 |= signExtend8 (remShortInt 8 x y) - ] - Int8EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - Int8GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24))) - Int8GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>. (y .<<. (Int 24))) - Int8LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24))) - Int8LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<. (y .<<. (Int 24))) - Int8NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - - Int8SraOp -> \[r] [x,i] -> PrimInline $ r |= x .>>. i - Int8SrlOp -> \[r] [x,i] -> PrimInline $ r |= signExtend8 (mask8 x .>>>. i) - Int8SllOp -> \[r] [x,i] -> PrimInline $ r |= signExtend8 (mask8 (x .<<. i)) - ------------------------------- Word8 -------------------------------------------- - - Word8ToWordOp -> \[r] [x] -> PrimInline $ r |= mask8 x - WordToWord8Op -> \[r] [x] -> PrimInline $ r |= mask8 x - - Word8AddOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Add x y) - Word8SubOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Sub x y) - Word8MulOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Mul x y) - Word8QuotOp -> \[r] [x,y] -> PrimInline $ r |= mask8 (Div x y) - Word8RemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y - Word8QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat - [ r1 |= toI32 (Div x y) - , r2 |= Mod x y - ] - Word8EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - Word8GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - Word8GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - Word8LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - Word8LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - Word8NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - - Word8AndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y - Word8OrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y - Word8XorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y - Word8NotOp -> \[r] [x] -> PrimInline $ r |= BXor x (Int 0xff) - - Word8SllOp -> \[r] [x,i] -> PrimInline $ r |= mask8 (x .<<. i) - Word8SrlOp -> \[r] [x,i] -> PrimInline $ r |= x .>>>. i - ------------------------------- Int16 ------------------------------------------- - - Int16ToIntOp -> \[r] [x] -> PrimInline $ r |= x - IntToInt16Op -> \[r] [x] -> PrimInline $ r |= signExtend16 x - - Int16NegOp -> \[r] [x] -> PrimInline $ r |= signExtend16 (Negate x) - Int16AddOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Add x y) - Int16SubOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Sub x y) - Int16MulOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (Mul x y) - Int16QuotOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (quotShortInt 16 x y) - Int16RemOp -> \[r] [x,y] -> PrimInline $ r |= signExtend16 (remShortInt 16 x y) - Int16QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat - [ r1 |= signExtend16 (quotShortInt 16 x y) - , r2 |= signExtend16 (remShortInt 16 x y) - ] - Int16EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - Int16GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16))) - Int16GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>. (y .<<. (Int 16))) - Int16LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16))) - Int16LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<. (y .<<. (Int 16))) - Int16NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - - Int16SraOp -> \[r] [x,i] -> PrimInline $ r |= x .>>. i - Int16SrlOp -> \[r] [x,i] -> PrimInline $ r |= signExtend16 (mask16 x .>>>. i) - Int16SllOp -> \[r] [x,i] -> PrimInline $ r |= signExtend16 (x .<<. i) - ------------------------------- Word16 ------------------------------------------ - - Word16ToWordOp -> \[r] [x] -> PrimInline $ r |= x - WordToWord16Op -> \[r] [x] -> PrimInline $ r |= mask16 x - - Word16AddOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Add x y) - Word16SubOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Sub x y) - Word16MulOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Mul x y) - Word16QuotOp -> \[r] [x,y] -> PrimInline $ r |= mask16 (Div x y) - Word16RemOp -> \[r] [x,y] -> PrimInline $ r |= Mod x y - Word16QuotRemOp -> \[r1,r2] [x,y] -> PrimInline $ mconcat - [ r1 |= toI32 (Div x y) - , r2 |= Mod x y - ] - Word16EqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - Word16GeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - Word16GtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - Word16LeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - Word16LtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - Word16NeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - - Word16AndOp -> \[r] [x,y] -> PrimInline $ r |= BAnd x y - Word16OrOp -> \[r] [x,y] -> PrimInline $ r |= BOr x y - Word16XorOp -> \[r] [x,y] -> PrimInline $ r |= BXor x y - Word16NotOp -> \[r] [x] -> PrimInline $ r |= BXor x (Int 0xffff) - - Word16SllOp -> \[r] [x,i] -> PrimInline $ r |= mask16 (x .<<. i) - Word16SrlOp -> \[r] [x,i] -> PrimInline $ r |= x .>>>. i - ------------------------------- Int32 -------------------------------------------- - - Int32ToIntOp -> \[r] [x] -> PrimInline $ r |= x - IntToInt32Op -> \[r] [x] -> PrimInline $ r |= x - - Int32NegOp -> \rs xs -> genPrim prof bound ty IntNegOp rs xs - Int32AddOp -> \rs xs -> genPrim prof bound ty IntAddOp rs xs - Int32SubOp -> \rs xs -> genPrim prof bound ty IntSubOp rs xs - Int32MulOp -> \rs xs -> genPrim prof bound ty IntMulOp rs xs - Int32QuotOp -> \rs xs -> genPrim prof bound ty IntQuotOp rs xs - Int32RemOp -> \rs xs -> genPrim prof bound ty IntRemOp rs xs - Int32QuotRemOp -> \rs xs -> genPrim prof bound ty IntQuotRemOp rs xs - - Int32EqOp -> \rs xs -> genPrim prof bound ty IntEqOp rs xs - Int32GeOp -> \rs xs -> genPrim prof bound ty IntGeOp rs xs - Int32GtOp -> \rs xs -> genPrim prof bound ty IntGtOp rs xs - Int32LeOp -> \rs xs -> genPrim prof bound ty IntLeOp rs xs - Int32LtOp -> \rs xs -> genPrim prof bound ty IntLtOp rs xs - Int32NeOp -> \rs xs -> genPrim prof bound ty IntNeOp rs xs - - Int32SraOp -> \rs xs -> genPrim prof bound ty IntSraOp rs xs - Int32SrlOp -> \rs xs -> genPrim prof bound ty IntSrlOp rs xs - Int32SllOp -> \rs xs -> genPrim prof bound ty IntSllOp rs xs - ------------------------------- Word32 ------------------------------------------- - - Word32ToWordOp -> \[r] [x] -> PrimInline $ r |= x - WordToWord32Op -> \[r] [x] -> PrimInline $ r |= x - - Word32AddOp -> \rs xs -> genPrim prof bound ty WordAddOp rs xs - Word32SubOp -> \rs xs -> genPrim prof bound ty WordSubOp rs xs - Word32MulOp -> \rs xs -> genPrim prof bound ty WordMulOp rs xs - Word32QuotOp -> \rs xs -> genPrim prof bound ty WordQuotOp rs xs - Word32RemOp -> \rs xs -> genPrim prof bound ty WordRemOp rs xs - Word32QuotRemOp -> \rs xs -> genPrim prof bound ty WordQuotRemOp rs xs - - Word32EqOp -> \rs xs -> genPrim prof bound ty WordEqOp rs xs - Word32GeOp -> \rs xs -> genPrim prof bound ty WordGeOp rs xs - Word32GtOp -> \rs xs -> genPrim prof bound ty WordGtOp rs xs - Word32LeOp -> \rs xs -> genPrim prof bound ty WordLeOp rs xs - Word32LtOp -> \rs xs -> genPrim prof bound ty WordLtOp rs xs - Word32NeOp -> \rs xs -> genPrim prof bound ty WordNeOp rs xs - - Word32AndOp -> \rs xs -> genPrim prof bound ty WordAndOp rs xs - Word32OrOp -> \rs xs -> genPrim prof bound ty WordOrOp rs xs - Word32XorOp -> \rs xs -> genPrim prof bound ty WordXorOp rs xs - Word32NotOp -> \rs xs -> genPrim prof bound ty WordNotOp rs xs - - Word32SllOp -> \rs xs -> genPrim prof bound ty WordSllOp rs xs - Word32SrlOp -> \rs xs -> genPrim prof bound ty WordSrlOp rs xs - ------------------------------- Int64 -------------------------------------------- - - Int64ToIntOp -> \[r] [_h,l] -> PrimInline $ r |= toI32 l - - Int64NegOp -> \[r_h,r_l] [h,l] -> - PrimInline $ mconcat - [ r_l |= toU32 (BNot l + 1) - , r_h |= toI32 (BNot h + Not r_l) - ] - - Int64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusInt64" [h0,l0,h1,l1] - Int64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusInt64" [h0,l0,h1,l1] - Int64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesInt64" [h0,l0,h1,l1] - Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotInt64" [h0,l0,h1,l1] - Int64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remInt64" [h0,l0,h1,l1] - - Int64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLLInt64" [h,l,n] - Int64SraOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRAInt64" [h,l,n] - Int64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRLInt64" [h,l,n] - - Int64ToWord64Op -> \[r1,r2] [x1,x2] -> - PrimInline $ mconcat - [ r1 |= toU32 x1 - , r2 |= x2 - ] - IntToInt64Op -> \[r1,r2] [x] -> - PrimInline $ mconcat - [ r1 |= if_ (x .<. 0) (-1) 0 -- sign-extension - , r2 |= toU32 x - ] - - Int64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) - Int64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) - Int64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) - Int64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) - Int64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) - Int64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) - ------------------------------- Word64 ------------------------------------------- - - Word64ToWordOp -> \[r] [_x1,x2] -> PrimInline $ r |= x2 - - WordToWord64Op -> \[rh,rl] [x] -> - PrimInline $ mconcat - [ rh |= 0 - , rl |= x - ] - - Word64ToInt64Op -> \[r1,r2] [x1,x2] -> - PrimInline $ mconcat - [ r1 |= toI32 x1 - , r2 |= x2 - ] - - Word64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) - Word64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) - Word64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) - Word64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) - Word64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) - Word64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) - - Word64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLWord64" [h,l,n] - Word64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRWord64" [h,l,n] - - Word64OrOp -> \[hr,hl] [h0, l0, h1, l1] -> - PrimInline $ mconcat - [ hr |= toU32 (BOr h0 h1) - , hl |= toU32 (BOr l0 l1) - ] - - Word64AndOp -> \[hr,hl] [h0, l0, h1, l1] -> - PrimInline $ mconcat - [ hr |= toU32 (BAnd h0 h1) - , hl |= toU32 (BAnd l0 l1) - ] - - Word64XorOp -> \[hr,hl] [h0, l0, h1, l1] -> - PrimInline $ mconcat - [ hr |= toU32 (BXor h0 h1) - , hl |= toU32 (BXor l0 l1) - ] - - Word64NotOp -> \[hr,hl] [h, l] -> - PrimInline $ mconcat - [ hr |= toU32 (BNot h) - , hl |= toU32 (BNot l) - ] - - Word64AddOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusWord64" [h0,l0,h1,l1] - Word64SubOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusWord64" [h0,l0,h1,l1] - Word64MulOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesWord64" [h0,l0,h1,l1] - Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotWord64" [h0,l0,h1,l1] - Word64RemOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remWord64" [h0,l0,h1,l1] - ------------------------------- Word --------------------------------------------- - - WordAddOp -> \[r] [x,y] -> PrimInline $ r |= (x `Add` y) .>>>. zero_ - WordAddCOp -> \[r,c] [x,y] -> PrimInline $ - jVar \t -> mconcat - [ t |= x `Add` y - , r |= toU32 t - , c |= if10 (t .!==. r) - ] - WordSubCOp -> \[r,c] [x,y] -> - PrimInline $ mconcat - [ r |= toU32 (Sub x y) - , c |= if10 (y .>. x) - ] - WordAdd2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$wordAdd2" [x,y] - WordSubOp -> \ [r] [x,y] -> PrimInline $ r |= toU32 (Sub x y) - WordMulOp -> \ [r] [x,y] -> PrimInline $ r |= toU32 (app "Math.imul" [x, y]) - WordMul2Op -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$mul2Word32" [x,y] - WordQuotOp -> \ [q] [x,y] -> PrimInline $ q |= app "h$quotWord32" [x,y] - WordRemOp -> \ [r] [x,y] -> PrimInline $ r |= app "h$remWord32" [x,y] - WordQuotRemOp -> \[q,r] [x,y] -> PrimInline $ appT [q,r] "h$quotRemWord32" [x,y] - WordQuotRem2Op -> \[q,r] [xh,xl,y] -> PrimInline $ appT [q,r] "h$quotRem2Word32" [xh,xl,y] - WordAndOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BAnd x y) - WordOrOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BOr x y) - WordXorOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (BXor x y) - WordNotOp -> \[r] [x] -> PrimInline $ r |= toU32 (BNot x) - WordSllOp -> \[r] [x,y] -> PrimInline $ r |= toU32 (x .<<. y) - WordSrlOp -> \[r] [x,y] -> PrimInline $ r |= x .>>>. y - WordToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x - WordGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - WordGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - WordEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - WordNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - WordLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - WordLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - WordToDoubleOp -> \[r] [x] -> PrimInline $ r |= x - WordToFloatOp -> \[r] [x] -> PrimInline $ r |= math_fround [x] - PopCnt8Op -> \[r] [x] -> PrimInline $ r |= var "h$popCntTab" .! (mask8 x) - PopCnt16Op -> \[r] [x] -> PrimInline $ r |= Add (var "h$popCntTab" .! (mask8 x)) - (var "h$popCntTab" .! (mask8 (x .>>>. Int 8))) - - PopCnt32Op -> \[r] [x] -> PrimInline $ r |= app "h$popCnt32" [x] - PopCnt64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$popCnt64" [x1,x2] - PopCntOp -> \[r] [x] -> genPrim prof bound ty PopCnt32Op [r] [x] - Pdep8Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep8" [s,m] - Pdep16Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep16" [s,m] - Pdep32Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pdep32" [s,m] - Pdep64Op -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pdep64" [sa,sb,ma,mb] - PdepOp -> \rs xs -> genPrim prof bound ty Pdep32Op rs xs - Pext8Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext8" [s,m] - Pext16Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext16" [s,m] - Pext32Op -> \[r] [s,m] -> PrimInline $ r |= app "h$pext32" [s,m] - Pext64Op -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pext64" [sa,sb,ma,mb] - PextOp -> \rs xs -> genPrim prof bound ty Pext32Op rs xs - - ClzOp -> \[r] [x] -> PrimInline $ r |= app "h$clz32" [x] - Clz8Op -> \[r] [x] -> PrimInline $ r |= app "h$clz8" [x] - Clz16Op -> \[r] [x] -> PrimInline $ r |= app "h$clz16" [x] - Clz32Op -> \[r] [x] -> PrimInline $ r |= app "h$clz32" [x] - Clz64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$clz64" [x1,x2] - CtzOp -> \[r] [x] -> PrimInline $ r |= app "h$ctz32" [x] - Ctz8Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz8" [x] - Ctz16Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz16" [x] - Ctz32Op -> \[r] [x] -> PrimInline $ r |= app "h$ctz32" [x] - Ctz64Op -> \[r] [x1,x2] -> PrimInline $ r |= app "h$ctz64" [x1,x2] - - BSwap16Op -> \[r] [x] -> PrimInline $ - r |= BOr ((mask8 x) .<<. (Int 8)) - (mask8 (x .>>>. (Int 8))) - BSwap32Op -> \[r] [x] -> PrimInline $ - r |= toU32 ((x .<<. (Int 24)) - `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8)) - `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8)) - `BOr` (x .>>>. (Int 24))) - BSwap64Op -> \[r1,r2] [x,y] -> PrimInline $ appT [r1,r2] "h$bswap64" [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] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 24) - BRev16Op -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 16) - BRev32Op -> \[r] [w] -> PrimInline $ r |= app "h$reverseWord" [w] - BRev64Op -> \[rh,rl] [h,l] -> PrimInline $ mconcat [ rl |= app "h$reverseWord" [h] - , rh |= app "h$reverseWord" [l] - ] - ------------------------------- Narrow ------------------------------------------- - - Narrow8IntOp -> \[r] [x] -> PrimInline $ r |= signExtend8 x - Narrow16IntOp -> \[r] [x] -> PrimInline $ r |= signExtend16 x - Narrow32IntOp -> \[r] [x] -> PrimInline $ r |= toI32 x - Narrow8WordOp -> \[r] [x] -> PrimInline $ r |= mask8 x - Narrow16WordOp -> \[r] [x] -> PrimInline $ r |= mask16 x - Narrow32WordOp -> \[r] [x] -> PrimInline $ r |= toU32 x - ------------------------------- Double ------------------------------------------- - - DoubleGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - DoubleGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - DoubleEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - DoubleNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - DoubleLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - DoubleLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - DoubleAddOp -> \[r] [x,y] -> PrimInline $ r |= Add x y - DoubleSubOp -> \[r] [x,y] -> PrimInline $ r |= Sub x y - DoubleMulOp -> \[r] [x,y] -> PrimInline $ r |= Mul x y - DoubleDivOp -> \[r] [x,y] -> PrimInline $ r |= Div x y - DoubleNegOp -> \[r] [x] -> PrimInline $ r |= Negate x - DoubleFabsOp -> \[r] [x] -> PrimInline $ r |= math_abs [x] - DoubleToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x - DoubleToFloatOp -> \[r] [x] -> PrimInline $ r |= math_fround [x] - DoubleExpOp -> \[r] [x] -> PrimInline $ r |= math_exp [x] - DoubleExpM1Op -> \[r] [x] -> PrimInline $ r |= math_expm1 [x] - DoubleLogOp -> \[r] [x] -> PrimInline $ r |= math_log [x] - DoubleLog1POp -> \[r] [x] -> PrimInline $ r |= math_log1p [x] - DoubleSqrtOp -> \[r] [x] -> PrimInline $ r |= math_sqrt [x] - DoubleSinOp -> \[r] [x] -> PrimInline $ r |= math_sin [x] - DoubleCosOp -> \[r] [x] -> PrimInline $ r |= math_cos [x] - DoubleTanOp -> \[r] [x] -> PrimInline $ r |= math_tan [x] - DoubleAsinOp -> \[r] [x] -> PrimInline $ r |= math_asin [x] - DoubleAcosOp -> \[r] [x] -> PrimInline $ r |= math_acos [x] - DoubleAtanOp -> \[r] [x] -> PrimInline $ r |= math_atan [x] - DoubleSinhOp -> \[r] [x] -> PrimInline $ r |= math_sinh [x] - DoubleCoshOp -> \[r] [x] -> PrimInline $ r |= math_cosh [x] - DoubleTanhOp -> \[r] [x] -> PrimInline $ r |= math_tanh [x] - DoubleAsinhOp -> \[r] [x] -> PrimInline $ r |= math_asinh [x] - DoubleAcoshOp -> \[r] [x] -> PrimInline $ r |= math_acosh [x] - DoubleAtanhOp -> \[r] [x] -> PrimInline $ r |= math_atanh [x] - DoublePowerOp -> \[r] [x,y] -> PrimInline $ r |= math_pow [x,y] - DoubleDecode_2IntOp -> \[s,h,l,e] [x] -> PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x] - DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d] - - DoubleFMAdd -> unhandledPrimop op - DoubleFMSub -> unhandledPrimop op - DoubleFNMAdd -> unhandledPrimop op - DoubleFNMSub -> unhandledPrimop op - ------------------------------- Float -------------------------------------------- - - FloatGtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y) - FloatGeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y) - FloatEqOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y) - FloatNeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y) - FloatLtOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y) - FloatLeOp -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y) - FloatAddOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Add x y] - FloatSubOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Sub x y] - FloatMulOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Mul x y] - FloatDivOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [Div x y] - FloatNegOp -> \[r] [x] -> PrimInline $ r |= Negate x - FloatFabsOp -> \[r] [x] -> PrimInline $ r |= math_abs [x] - FloatToIntOp -> \[r] [x] -> PrimInline $ r |= toI32 x - FloatExpOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_exp [x]] - FloatExpM1Op -> \[r] [x] -> PrimInline $ r |= math_fround [math_expm1 [x]] - FloatLogOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_log [x]] - FloatLog1POp -> \[r] [x] -> PrimInline $ r |= math_fround [math_log1p [x]] - FloatSqrtOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sqrt [x]] - FloatSinOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sin [x]] - FloatCosOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_cos [x]] - FloatTanOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_tan [x]] - FloatAsinOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_asin [x]] - FloatAcosOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_acos [x]] - FloatAtanOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_atan [x]] - FloatSinhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_sinh [x]] - FloatCoshOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_cosh [x]] - FloatTanhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_tanh [x]] - FloatAsinhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_asinh [x]] - FloatAcoshOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_acosh [x]] - FloatAtanhOp -> \[r] [x] -> PrimInline $ r |= math_fround [math_atanh [x]] - FloatPowerOp -> \[r] [x,y] -> PrimInline $ r |= math_fround [math_pow [x,y]] - FloatToDoubleOp -> \[r] [x] -> PrimInline $ r |= x - FloatDecode_IntOp -> \[s,e] [x] -> PrimInline $ appT [s,e] "h$decodeFloatInt" [x] - - FloatFMAdd -> unhandledPrimop op - FloatFMSub -> unhandledPrimop op - FloatFNMAdd -> unhandledPrimop op - FloatFNMSub -> unhandledPrimop op - ------------------------------- Arrays ------------------------------------------- - - NewArrayOp -> \[r] [l,e] -> PrimInline $ r |= app "h$newArray" [l,e] - ReadArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) - WriteArrayOp -> \[] [a,i,v] -> PrimInline $ bnd_arr bound a i (a .! i |= v) - SizeofArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - SizeofMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) - UnsafeFreezeArrayOp -> \[r] [a] -> PrimInline $ r |= a - UnsafeThawArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopyArrayOp -> \[] [a,o1,ma,o2,n] -> - PrimInline - $ bnd_arr_range bound a o1 n - $ bnd_arr_range bound ma o2 n - $ loopBlockS (Int 0) (.<. n) \i -> - [ ma .! (Add i o2) |= a .! (Add i o1) - , preIncrS i - ] - CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> - PrimInline - $ bnd_arr_range bound a1 o1 n - $ bnd_arr_range bound a2 o2 n - $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] - - CloneArrayOp -> \[r] [a,start,n] -> - PrimInline - $ bnd_arr_range bound a start n - $ r |= app "h$sliceArray" [a,start,n] - - CloneMutableArrayOp -> \[r] [a,start,n] -> - PrimInline - $ bnd_arr_range bound a start n - $ r |= app "h$sliceArray" [a,start,n] - - FreezeArrayOp -> \[r] [a,start,n] -> - PrimInline - $ bnd_arr_range bound a start n - $ r |= app "h$sliceArray" [a,start,n] - - ThawArrayOp -> \[r] [a,start,n] -> - PrimInline - $ bnd_arr_range bound a start n - $ r |= app "h$sliceArray" [a,start,n] - - CasArrayOp -> \[s,o] [a,i,old,new] -> - PrimInline - $ bnd_arr bound a i - $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] - ------------------------------- Small Arrays ------------------------------------- - - NewSmallArrayOp -> \[a] [n,e] -> PrimInline $ a |= app "h$newArray" [n,e] - ReadSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) - WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ bnd_arr bound a i (a .! i |= e) - SizeofSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - SizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - IndexSmallArrayOp -> \[r] [a,i] -> PrimInline $ bnd_arr bound a i (r |= a .! i) - UnsafeFreezeSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - UnsafeThawSmallArrayOp -> \[r] [a] -> PrimInline $ r |= a - CopySmallArrayOp -> \[] [s,si,d,di,n] -> - PrimInline - $ bnd_arr_range bound s si n - $ bnd_arr_range bound d di n - $ loopBlockS (Sub n one_) (.>=. zero_) \i -> - [ d .! (Add di i) |= s .! (Add si i) - , postDecrS i - ] - CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> - PrimInline - $ bnd_arr_range bound s si n - $ bnd_arr_range bound d di n - $ appS "h$copyMutableArray" [s,si,d,di,n] - - CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n - CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n - FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n - ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray bound r a o n - - CasSmallArrayOp -> \[s,o] [a,i,old,new] -> - PrimInline - $ bnd_arr bound a i - $ jVar \x -> mconcat - [ x |= a .! i - , ifBlockS (x .===. old) - [ o |= new - , a .! i |= new - , s |= zero_ - ] - [ s |= one_ - , o |= x - ] - ] - -------------------------------- Byte Arrays ------------------------------------- - - NewByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewPinnedByteArrayOp_Char -> \[r] [l] -> PrimInline (newByteArray r l) - NewAlignedPinnedByteArrayOp_Char -> \[r] [l,_align] -> PrimInline (newByteArray r l) - MutableByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayIsPinnedOp -> \[r] [_] -> PrimInline $ r |= one_ - ByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - MutableByteArrayContents_Char -> \[a,o] [b] -> PrimInline $ mconcat [a |= b, o |= zero_] - ShrinkMutableByteArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n] - ResizeMutableByteArrayOp_Char -> \[r] [a,n] -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n] - UnsafeFreezeByteArrayOp -> \[a] [b] -> PrimInline $ a |= b - SizeofByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - SizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - GetSizeofMutableByteArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "len" - - IndexByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i - IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i - IndexByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o - IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i - IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i - IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o - IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i - IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i - IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l - IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i - IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i - IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i - IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l - - ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i - ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i - ReadByteArrayOp_Addr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_addr a i r o - ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i - ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i - ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o - ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i - ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i - ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l - ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i - ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i - ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i - ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l - - WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e - WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e - WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e - WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e - WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_addr a i r o - WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_f32 a i e - WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline $ bnd_ix64 bound a i $ write_f64 a i e - WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o - WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_i8 a i e - WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_i16 a i e - WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i e - WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l - WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline $ bnd_ix8 bound a i $ write_u8 a i e - WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline $ bnd_ix16 bound a i $ write_u16 a i e - WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline $ bnd_ix32 bound a i $ write_u32 a i e - WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l - - CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> - PrimInline . bnd_ba_range bound a1 o1 n - . bnd_ba_range bound a2 o2 n - $ r |= app "h$compareByteArrays" [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#) - CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n - CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n - CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n - CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n - CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n - CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray False bound a1 o1 a2 o2 n - - CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n - CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> copyByteArray True bound a1 o1 a2 o2 n - - SetByteArrayOp -> \[] [a,o,n,v] -> - PrimInline . bnd_ba_range bound a o n $ loopBlockS zero_ (.<. n) \i -> - [ write_u8 a (Add o i) v - , postIncrS i - ] - SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs - - AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i - AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ write_i32 a i v - FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v - FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v - FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v - FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v - FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v - FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v - -------------------------------- Addr# ------------------------------------------ - - AddrAddOp -> \[a',o'] [a,o,i] -> PrimInline $ mconcat [a' |= a, o' |= Add o i] - AddrSubOp -> \[i] [_a1,o1,_a2,o2] -> PrimInline $ i |= Sub o1 o2 - AddrRemOp -> \[r] [_a,o,i] -> PrimInline $ r |= Mod o i - AddrToIntOp -> \[i] [_a,o] -> PrimInline $ i |= o -- only usable for comparisons within one range - IntToAddrOp -> \[a,o] [i] -> PrimInline $ mconcat [a |= null_, o |= i] - AddrGtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>. zero_) - AddrGeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>=. zero_) - AddrEqOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .===. zero_) - AddrNeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .!==. zero_) - AddrLtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<. zero_) - AddrLeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<=. zero_) - -------------------------------- Addr Indexing: Unboxed Arrays ------------------- - - IndexOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro - IndexOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) - IndexOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) - IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro - IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) - IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) - IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) - IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l - IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) - IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) - IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) - IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l - - ReadOffAddrOp_Char -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Word -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_addr a (off32 o i) ra ro - ReadOffAddrOp_Float -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f32 a (off32 o i) - ReadOffAddrOp_Double -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_f64 a (off64 o i) - ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> PrimInline $ read_boff_stableptr a (off32 o i) ra ro - ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i8 a (off8 o i) - ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i16 a (off16 o i) - ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_i32 a (off32 o i) - ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_i64 a (off64 o i) h l - ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u8 a (off8 o i) - ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u16 a (off16 o i) - ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> PrimInline $ r |= read_boff_u32 a (off32 o i) - ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> PrimInline $ read_boff_u64 a (off64 o i) h l - - WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_addr a (off32 o i) va vo - WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline $ write_boff_f32 a (off32 o i) v - WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline $ write_boff_f64 a (off64 o i) v - WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> PrimInline $ write_boff_stableptr a (off32 o i) va vo - WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i8 a (off8 o i) v - WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i16 a (off16 o i) v - WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_i32 a (off32 o i) v - WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_i64 a (off64 o i) h l - WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u8 a (off8 o i) v - WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u16 a (off16 o i) v - WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline $ write_boff_u32 a (off32 o i) v - WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> PrimInline $ write_boff_u64 a (off64 o i) h l - -------------------------------- Mutable varialbes -------------------------------------- - NewMutVarOp -> \[r] [x] -> PrimInline $ r |= New (app "h$MutVar" [x]) - ReadMutVarOp -> \[r] [m] -> PrimInline $ r |= m .^ "val" - WriteMutVarOp -> \[] [m,x] -> PrimInline $ m .^ "val" |= x - AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f] - AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f] - - AtomicSwapMutVarOp -> \[r] [mv,v] -> PrimInline $ mconcat - [ r |= mv .^ "val", mv .^ "val" |= v ] - CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o) - (mconcat [status |= zero_, r |= n, mv .^ "val" |= n]) - (mconcat [status |= one_ , r |= mv .^ "val"]) - -------------------------------- Exceptions -------------------------------------- - - CatchOp -> \[_r] [a,handler] -> PRPrimCall $ returnS (app "h$catch" [a, handler]) - - -- fully ignore the result arity as it can use 1 or 2 - -- slots, depending on the return type. - RaiseOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_]) - RaiseIOOp -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_]) - RaiseUnderflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypeziunderflowException", false_]) - RaiseOverflowOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezioverflowException", false_]) - RaiseDivZeroOp -> \_r [] -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezidivZZeroException", false_]) - MaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskAsync" [a]) - MaskUninterruptibleOp -> \_r [a] -> PRPrimCall $ returnS (app "h$maskUnintAsync" [a]) - UnmaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$unmaskAsync" [a]) - - MaskStatus -> \[r] [] -> PrimInline $ r |= app "h$maskStatus" [] - -------------------------------- STM-accessible Mutable Variables -------------- - - AtomicallyOp -> \[_r] [a] -> PRPrimCall $ returnS (app "h$atomically" [a]) - RetryOp -> \_r [] -> PRPrimCall $ returnS (app "h$stmRetry" []) - CatchRetryOp -> \[_r] [a,b] -> PRPrimCall $ returnS (app "h$stmCatchRetry" [a,b]) - CatchSTMOp -> \[_r] [a,h] -> PRPrimCall $ returnS (app "h$catchStm" [a,h]) - NewTVarOp -> \[tv] [v] -> PrimInline $ tv |= app "h$newTVar" [v] - ReadTVarOp -> \[r] [tv] -> PrimInline $ r |= app "h$readTVar" [tv] - ReadTVarIOOp -> \[r] [tv] -> PrimInline $ r |= app "h$readTVarIO" [tv] - WriteTVarOp -> \[] [tv,v] -> PrimInline $ appS "h$writeTVar" [tv,v] - -------------------------------- Synchronized Mutable Variables ------------------ - - NewMVarOp -> \[r] [] -> PrimInline $ r |= New (app "h$MVar" []) - TakeMVarOp -> \[_r] [m] -> PRPrimCall $ returnS (app "h$takeMVar" [m]) - TryTakeMVarOp -> \[r,v] [m] -> PrimInline $ appT [r,v] "h$tryTakeMVar" [m] - PutMVarOp -> \[] [m,v] -> PRPrimCall $ returnS (app "h$putMVar" [m,v]) - TryPutMVarOp -> \[r] [m,v] -> PrimInline $ r |= app "h$tryPutMVar" [m,v] - ReadMVarOp -> \[_r] [m] -> PRPrimCall $ returnS (app "h$readMVar" [m]) - TryReadMVarOp -> \[r,v] [m] -> PrimInline $ mconcat - [ v |= m .^ "val" - , r |= if01 (v .===. null_) - ] - IsEmptyMVarOp -> \[r] [m] -> PrimInline $ r |= if10 (m .^ "val" .===. null_) - -------------------------------- Delay/Wait Ops --------------------------------- - - DelayOp -> \[] [t] -> PRPrimCall $ returnS (app "h$delayThread" [t]) - WaitReadOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waidRead" [fd]) - WaitWriteOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waitWrite" [fd]) - -------------------------------- Concurrency Primitives ------------------------- - - ForkOp -> \[_tid] [x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) - ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument - KillThreadOp -> \[] [tid,ex] -> PRPrimCall $ returnS (app "h$killThread" [tid,ex]) - YieldOp -> \[] [] -> PRPrimCall $ returnS (app "h$yield" []) - MyThreadIdOp -> \[r] [] -> PrimInline $ r |= var "h$currentThread" - IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_ - NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing - ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid] - ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" [] - GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t] - LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l - -------------------------------- Weak Pointers ----------------------------------- - - MkWeakOp -> \[r] [o,b,c] -> PrimInline $ r |= app "h$makeWeak" [o,b,c] - MkWeakNoFinalizerOp -> \[r] [o,b] -> PrimInline $ r |= app "h$makeWeakNoFinalizer" [o,b] - AddCFinalizerToWeakOp -> \[r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] -> PrimInline $ r |= one_ - DeRefWeakOp -> \[f,v] [w] -> PrimInline $ mconcat - [ v |= w .^ "val" - , f |= if01 (v .===. null_) - ] - FinalizeWeakOp -> \[fl,fin] [w] -> PrimInline $ appT [fin, fl] "h$finalizeWeak" [w] - TouchOp -> \[] [_e] -> PrimInline mempty - KeepAliveOp -> \[_r] [x, f] -> PRPrimCall $ ReturnStat (app "h$keepAlive" [x, f]) - - ------------------------------- Stable pointers and names ------------------------ - - MakeStablePtrOp -> \[s1,s2] [a] -> PrimInline $ mconcat - [ s1 |= var "h$stablePtrBuf" - , s2 |= app "h$makeStablePtr" [a] - ] - DeRefStablePtrOp -> \[r] [_s1,s2] -> PrimInline $ r |= app "h$deRefStablePtr" [s2] - EqStablePtrOp -> \[r] [_sa1,sa2,_sb1,sb2] -> PrimInline $ r |= if10 (sa2 .===. sb2) - - MakeStableNameOp -> \[r] [a] -> PrimInline $ r |= app "h$makeStableName" [a] - StableNameToIntOp -> \[r] [s] -> PrimInline $ r |= app "h$stableNameInt" [s] - ------------------------------- Compact normal form ----------------------------- - - CompactNewOp -> \[c] [s] -> PrimInline $ c |= app "h$compactNew" [s] - CompactResizeOp -> \[] [c,s] -> PrimInline $ appS "h$compactResize" [c,s] - CompactContainsOp -> \[r] [c,v] -> PrimInline $ r |= app "h$compactContains" [c,v] - CompactContainsAnyOp -> \[r] [v] -> PrimInline $ r |= app "h$compactContainsAny" [v] - CompactGetFirstBlockOp -> \[ra,ro,s] [c] -> - PrimInline $ appT [ra,ro,s] "h$compactGetFirstBlock" [c] - CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] -> - PrimInline $ appT [ra,ro,s] "h$compactGetNextBlock" [c,a,o] - CompactAllocateBlockOp -> \[ra,ro] [size,sa,so] -> - PrimInline $ appT [ra,ro] "h$compactAllocateBlock" [size,sa,so] - CompactFixupPointersOp -> \[c,newroota, newrooto] [blocka,blocko,roota,rooto] -> - PrimInline $ appT [c,newroota,newrooto] "h$compactFixupPointers" [blocka,blocko,roota,rooto] - CompactAdd -> \[_r] [c,o] -> - PRPrimCall $ returnS (app "h$compactAdd" [c,o]) - CompactAddWithSharing -> \[_r] [c,o] -> - PRPrimCall $ returnS (app "h$compactAddWithSharing" [c,o]) - CompactSize -> \[s] [c] -> - PrimInline $ s |= app "h$compactSize" [c] - ------------------------------- Unsafe pointer equality -------------------------- - - ReallyUnsafePtrEqualityOp -> \[r] [p1,p2] -> PrimInline $ r |= if10 (p1 .===. p2) - ------------------------------- Parallelism -------------------------------------- - - ParOp -> \[r] [_a] -> PrimInline $ r |= zero_ - SparkOp -> \[r] [a] -> PrimInline $ r |= a - SeqOp -> \[_r] [e] -> PRPrimCall $ returnS (app "h$e" [e]) - NumSparks -> \[r] [] -> PrimInline $ r |= zero_ - ------------------------------- Tag to enum stuff -------------------------------- - - DataToTagOp -> \[_r] [d] -> PRPrimCall $ mconcat - [ stack .! PreInc sp |= var "h$dataToTag_e" - , returnS (app "h$e" [d]) - ] - TagToEnumOp -> \[r] [tag] -> if - | isBoolTy ty -> PrimInline $ r |= IfExpr tag true_ false_ - | otherwise -> PrimInline $ r |= app "h$tagToEnum" [tag] - ------------------------------- Bytecode operations ------------------------------ - - AddrToAnyOp -> \[r] [d,_o] -> PrimInline $ r |= d - ------------------------------- Profiling (CCS) ------------------------------ - - GetCCSOfOp -> \[a, o] [obj] -> if - | prof -> PrimInline $ mconcat - [ a |= if_ (isObject obj) - (app "h$buildCCSPtr" [obj .^ "cc"]) - null_ - , o |= zero_ - ] - | otherwise -> PrimInline $ mconcat - [ a |= null_ - , o |= zero_ - ] - - GetCurrentCCSOp -> \[a, o] [_dummy_arg] -> - let ptr = if prof then app "h$buildCCSPtr" [jCurrentCCS] - else null_ - in PrimInline $ mconcat - [ a |= ptr - , o |= zero_ - ] - - ClearCCSOp -> \[_r] [x] -> PRPrimCall $ ReturnStat (app "h$clearCCS" [x]) - ------------------------------- Eventlog ------------------- - - TraceEventOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceEvent" [ed,eo] - TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len] - TraceMarkerOp -> \[] [ed,eo] -> PrimInline $ appS "h$traceMarker" [ed,eo] - ------------------------------- ByteArray ------------------- - - IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i - IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o - IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i - IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i - IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o - IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i - IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l - IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i - IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i - IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i - IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l - IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i - - ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i - ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o - ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i - ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i - ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o - ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i - ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l - ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i - ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i - ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i - ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l - ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i - - WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e - WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o - WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e - WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e - WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o - WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e - WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l - WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e - WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e - WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e - WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l - WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e - - CasByteArrayOp_Int -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n - CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n - CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n - CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n - - CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) - - CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) - CasAddrOp_Word -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word8 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8 write_u8 r a o old new - CasAddrOp_Word16 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new - CasAddrOp_Word32 -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new - CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) - - FetchAddAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v - FetchSubAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub r a o v - FetchAndAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd r a o v - FetchNandAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v - FetchOrAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr r a o v - FetchXorAddrOp_Word -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor r a o v - - InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> PrimInline $ mconcat - [ read_boff_addr a1 o1 ra ro - , write_boff_addr a1 o1 a2 o2 - ] - InterlockedExchange_Word -> \[r] [a,o,w] -> PrimInline $ mconcat - [ r |= read_boff_u32 a o - , write_boff_u32 a o w - ] - - ShrinkSmallMutableArrayOp_Char -> \[] [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n] - GetSizeofSmallMutableArrayOp -> \[r] [a] -> PrimInline $ r |= a .^ "length" - - AtomicReadAddrOp_Word -> \[r] [a,o] -> PrimInline $ r |= read_boff_u32 a o - AtomicWriteAddrOp_Word -> \[] [a,o,w] -> PrimInline $ write_boff_u32 a o w - - ------------------------------- Unhandled primops ------------------- - - NewPromptTagOp -> unhandledPrimop op - PromptOp -> unhandledPrimop op - Control0Op -> unhandledPrimop op - - NewIOPortOp -> unhandledPrimop op - ReadIOPortOp -> unhandledPrimop op - WriteIOPortOp -> unhandledPrimop op - - GetSparkOp -> unhandledPrimop op - AnyToAddrOp -> unhandledPrimop op - MkApUpd0_Op -> unhandledPrimop op - NewBCOOp -> unhandledPrimop op - UnpackClosureOp -> unhandledPrimop op - ClosureSizeOp -> unhandledPrimop op - GetApStackValOp -> unhandledPrimop op - WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n - - SetThreadAllocationCounter -> unhandledPrimop op - -------------------------------- Vector ----------------------------------------- --- For now, vectors are unsupported on the JS backend. Simply put, they do not --- make much sense to support given support for arrays and lack of SIMD support --- in JS. We could try to roll something special but we would not be able to --- give any performance guarentees to the user and so we leave these has --- unhandled for now. - VecBroadcastOp _ _ _ -> unhandledPrimop op - VecPackOp _ _ _ -> unhandledPrimop op - VecUnpackOp _ _ _ -> unhandledPrimop op - VecInsertOp _ _ _ -> unhandledPrimop op - VecAddOp _ _ _ -> unhandledPrimop op - VecSubOp _ _ _ -> unhandledPrimop op - VecMulOp _ _ _ -> unhandledPrimop op - VecDivOp _ _ _ -> unhandledPrimop op - VecQuotOp _ _ _ -> unhandledPrimop op - VecRemOp _ _ _ -> unhandledPrimop op - VecNegOp _ _ _ -> unhandledPrimop op - VecIndexByteArrayOp _ _ _ -> unhandledPrimop op - VecReadByteArrayOp _ _ _ -> unhandledPrimop op - VecWriteByteArrayOp _ _ _ -> unhandledPrimop op - VecIndexOffAddrOp _ _ _ -> unhandledPrimop op - VecReadOffAddrOp _ _ _ -> unhandledPrimop op - VecWriteOffAddrOp _ _ _ -> unhandledPrimop op - - VecIndexScalarByteArrayOp _ _ _ -> unhandledPrimop op - VecReadScalarByteArrayOp _ _ _ -> unhandledPrimop op - VecWriteScalarByteArrayOp _ _ _ -> unhandledPrimop op - VecIndexScalarOffAddrOp _ _ _ -> unhandledPrimop op - VecReadScalarOffAddrOp _ _ _ -> unhandledPrimop op - VecWriteScalarOffAddrOp _ _ _ -> unhandledPrimop op - - PrefetchByteArrayOp3 -> noOp - PrefetchMutableByteArrayOp3 -> noOp - PrefetchAddrOp3 -> noOp - PrefetchValueOp3 -> noOp - PrefetchByteArrayOp2 -> noOp - PrefetchMutableByteArrayOp2 -> noOp - PrefetchAddrOp2 -> noOp - PrefetchValueOp2 -> noOp - PrefetchByteArrayOp1 -> noOp - PrefetchMutableByteArrayOp1 -> noOp - PrefetchAddrOp1 -> noOp - PrefetchValueOp1 -> noOp - PrefetchByteArrayOp0 -> noOp - PrefetchMutableByteArrayOp0 -> noOp - PrefetchAddrOp0 -> noOp - PrefetchValueOp0 -> noOp - -unhandledPrimop :: PrimOp -> [JExpr] -> [JExpr] -> PrimRes -unhandledPrimop op rs as = PrimInline $ mconcat - [ appS "h$log" [toJExpr $ mconcat - [ "warning, unhandled primop: " - , renderWithContext defaultSDocContext (ppr op) - , " " - , show (length rs, length as) - ]] - , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as - -- copyRes - , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1) - ] - --- | A No Op, used for primops the JS platform cannot or do not support. For --- example, the prefetching primops do not make sense on the JS platform because --- we do not have enough control over memory to provide any kind of prefetching --- mechanism. Hence, these are NoOps. -noOp :: Foldable f => f a -> f a -> PrimRes -noOp = const . const $ PrimInline mempty - --- tuple returns -appT :: [JExpr] -> FastString -> [JExpr] -> JStat -appT [] f xs = appS f xs -appT (r:rs) f xs = mconcat - [ r |= app f xs - , mconcat (zipWith (\r ret -> r |= toJExpr ret) rs (enumFrom Ret1)) - ] - --------------------------------------------- --- ByteArray indexing --------------------------------------------- - --- For every ByteArray, the RTS creates the following views: --- i3: Int32 view --- u8: Word8 view --- u1: Word16 view --- f3: Float32 view --- f6: Float64 view --- dv: generic DataView --- It seems a bit weird to mix Int and Word views like this, but perhaps they --- are the more common. --- --- See 'h$newByteArray' in 'ghc/rts/js/mem.js' for details. --- --- Note that *byte* indexing can only be done with the generic DataView. Use --- read_boff_* and write_boff_* for this. --- --- Other read_* and write_* helpers directly use the more specific views. --- Prefer using them over idx_* to make your intent clearer. - -idx_i32, idx_u8, idx_u16, idx_f64, idx_f32 :: JExpr -> JExpr -> JExpr -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 :: JExpr -> JExpr -> JExpr -read_u8 a i = idx_u8 a i - -read_u16 :: JExpr -> JExpr -> JExpr -read_u16 a i = idx_u16 a i - -read_u32 :: JExpr -> JExpr -> JExpr -read_u32 a i = toU32 (idx_i32 a i) - -read_i8 :: JExpr -> JExpr -> JExpr -read_i8 a i = signExtend8 (idx_u8 a i) - -read_i16 :: JExpr -> JExpr -> JExpr -read_i16 a i = signExtend16 (idx_u16 a i) - -read_i32 :: JExpr -> JExpr -> JExpr -read_i32 a i = idx_i32 a i - -read_f32 :: JExpr -> JExpr -> JExpr -read_f32 a i = idx_f32 a i - -read_f64 :: JExpr -> JExpr -> JExpr -read_f64 a i = idx_f64 a i - -read_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_u64 a i rh rl = mconcat - [ rl |= read_u32 a (i .<<. 1) - , rh |= read_u32 a (Add 1 (i .<<. 1)) - ] - -read_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_i64 a i rh rl = mconcat - [ rl |= read_u32 a (i .<<. 1) - , rh |= read_i32 a (Add 1 (i .<<. 1)) - ] - --------------------------------------- --- Addr# --------------------------------------- - -write_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -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 .<<. 2) |= r - ] - -read_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_addr a i r o = mconcat - [ o |= read_i32 a i - , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! (i .<<. 2))) - (a .^ "arr" .! (i .<<. 2)) - null_ - ] - -read_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_boff_addr a i r o = mconcat - [ o |= read_boff_i32 a i - , r |= if_ ((a .^ "arr") .&&. (a .^ "arr" .! i)) - (a .^ "arr" .! i) - null_ - ] - -write_boff_addr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -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 - ] - - --------------------------------------- --- StablePtr --------------------------------------- - -read_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_stableptr a i r o = mconcat - [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array - , o |= read_i32 a i - ] - -read_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_boff_stableptr a i r o = mconcat - [ r |= var "h$stablePtrBuf" -- stable pointers are always in this array - , o |= read_boff_i32 a i - ] - -write_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -write_stableptr a i _r o = write_i32 a i o - -- don't store "r" as it must be h$stablePtrBuf - -write_boff_stableptr :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -write_boff_stableptr a i _r o = write_boff_i32 a i o - -- don't store "r" as it must be h$stablePtrBuf - -write_u8 :: JExpr -> JExpr -> JExpr -> JStat -write_u8 a i v = idx_u8 a i |= v - -write_u16 :: JExpr -> JExpr -> JExpr -> JStat -write_u16 a i v = idx_u16 a i |= v - -write_u32 :: JExpr -> JExpr -> JExpr -> JStat -write_u32 a i v = idx_i32 a i |= v - -write_i8 :: JExpr -> JExpr -> JExpr -> JStat -write_i8 a i v = idx_u8 a i |= v - -write_i16 :: JExpr -> JExpr -> JExpr -> JStat -write_i16 a i v = idx_u16 a i |= v - -write_i32 :: JExpr -> JExpr -> JExpr -> JStat -write_i32 a i v = idx_i32 a i |= v - -write_f32 :: JExpr -> JExpr -> JExpr -> JStat -write_f32 a i v = idx_f32 a i |= v - -write_f64 :: JExpr -> JExpr -> JExpr -> JStat -write_f64 a i v = idx_f64 a i |= v - -write_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -write_u64 a i h l = mconcat - [ write_u32 a (i .<<. 1) l - , write_u32 a (Add 1 (i .<<. 1)) h - ] - -write_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -write_i64 a i h l = mconcat - [ write_u32 a (i .<<. 1) l - , write_i32 a (Add 1 (i .<<. 1)) h - ] - --- Data View helper functions: byte indexed! --- --- The argument list consists of the array @a@, the index @i@, and the new value --- to set (in the case of a setter) @v@. - -write_boff_i8, write_boff_u8, write_boff_i16, write_boff_u16, write_boff_i32, write_boff_u32, write_boff_f32, write_boff_f64 :: JExpr -> JExpr -> JExpr -> JStat -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_i64, write_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -write_boff_i64 a i h l = mconcat - [ write_boff_i32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] -write_boff_u64 a i h l = mconcat - [ write_boff_u32 a (Add i (Int 4)) h - , write_boff_u32 a i l - ] - -read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr -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_i64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_boff_i64 a i rh rl = mconcat - [ rh |= read_boff_i32 a (Add i (Int 4)) - , rl |= read_boff_u32 a i - ] - -read_boff_u64 :: JExpr -> JExpr -> JExpr -> JExpr -> JStat -read_boff_u64 a i rh rl = mconcat - [ rh |= read_boff_u32 a (Add i (Int 4)) - , rl |= read_boff_u32 a i - ] - -fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat -fetchOpByteArray op tgt src i v = mconcat - [ tgt |= read_i32 src i - , write_i32 src i (op tgt v) - ] - -fetchOpAddr :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat -fetchOpAddr op tgt src i v = mconcat - [ tgt |= read_boff_u32 src i - , write_boff_u32 src i (op tgt v) - ] - -casOp - :: (JExpr -> JExpr -> JExpr) -- read - -> (JExpr -> JExpr -> JExpr -> JStat) -- write - -> JExpr -- target register to store result - -> JExpr -- source array - -> JExpr -- index - -> JExpr -- old value to compare - -> JExpr -- new value to write - -> JStat -casOp read write tgt src i old new = mconcat - [ tgt |= read src i - , ifS (tgt .===. old) - (write src i new) - mempty - ] - -casOp2 - :: (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- read - -> (JExpr -> JExpr -> JExpr -> JExpr -> JStat) -- write - -> (JExpr,JExpr) -- target registers to store result - -> JExpr -- source array - -> JExpr -- index - -> (JExpr,JExpr) -- old value to compare - -> (JExpr,JExpr) -- new value to write - -> JStat -casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat - [ read src i tgt1 tgt2 - , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) - (write src i new1 new2) - mempty - ] - --------------------------------------------------------------------------------- --- Lifted Arrays --------------------------------------------------------------------------------- --- | lifted arrays -cloneArray :: Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JStat -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_ - ] - -newByteArray :: JExpr -> JExpr -> JStat -newByteArray tgt len = - tgt |= app "h$newByteArray" [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 -check_bound - :: JExpr -- ^ Max index expression - -> Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -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]) - , r - ] - --- | Bounds checking using ".length" property (Arrays) -bnd_arr - :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -bnd_arr do_check arr = check_bound (arr .^ "length") do_check - --- | Range bounds checking using ".length" property (Arrays) --- --- Empty ranges trivially pass the check -bnd_arr_range - :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JExpr -- ^ Range size - -> JStat -- ^ Result - -> JStat -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]) $ - -- Empty ranges trivially pass the check - ifS (n .===. zero_) - r - (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n 1)) r) - --- | Bounds checking using ".len" property (ByteArrays) -bnd_ba - :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JStat -- ^ Result - -> JStat -bnd_ba do_check arr = check_bound (arr .^ "len") do_check - --- | ByteArray bounds checking (byte offset, 8-bit value) -bnd_ba8 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ba8 = bnd_ba - --- | ByteArray bounds checking (byte offset, 16-bit value) -bnd_ba16 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ba16 do_check arr idx r = - -- check that idx non incremented is in range: - -- (idx + 1) may be in range while idx isn't - bnd_ba do_check arr idx - $ bnd_ba do_check arr (Add idx 1) r - --- | ByteArray bounds checking (byte offset, 32-bit value) -bnd_ba32 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ba32 do_check arr idx r = - -- check that idx non incremented is in range: - -- (idx + 3) may be in range while idx isn't - bnd_ba do_check arr idx - $ bnd_ba do_check arr (Add idx 3) r - --- | ByteArray bounds checking (byte offset, 64-bit value) -bnd_ba64 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ba64 do_check arr idx r = - -- check that idx non incremented is in range: - -- (idx + 7) may be in range while idx isn't - bnd_ba do_check arr idx - $ bnd_ba do_check arr (Add idx 7) r - --- | ByteArray bounds checking (8-bit offset, 8-bit value) -bnd_ix8 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ix8 = bnd_ba8 - --- | ByteArray bounds checking (16-bit offset, 16-bit value) -bnd_ix16 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. 1) r - --- | ByteArray bounds checking (32-bit offset, 32-bit value) -bnd_ix32 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. 2) r - --- | ByteArray bounds checking (64-bit offset, 64-bit value) -bnd_ix64 :: Bool -> JExpr -> JExpr -> JStat -> JStat -bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. 3) r - --- | Bounds checking on a range and using ".len" property (ByteArrays) --- --- Empty ranges trivially pass the check -bnd_ba_range - :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ Array - -> JExpr -- ^ Index - -> JExpr -- ^ Range size - -> JStat -- ^ Result - -> JStat -bnd_ba_range False _ _ _ r = r -bnd_ba_range True xs i n r = - ifS (n .<. zero_) (returnS $ app "h$exitProcess" [Int 134]) $ - -- Empty ranges trivially pass the check - ifS (n .===. zero_) - r - (bnd_ba True xs (Add i (Sub n 1)) (bnd_ba True xs i r)) - -checkOverlapByteArray - :: Bool -- ^ Should we do bounds checking? - -> JExpr -- ^ First array - -> JExpr -- ^ First offset - -> JExpr -- ^ Second array - -> JExpr -- ^ Second offset - -> JExpr -- ^ Range size - -> JStat -- ^ Result - -> JStat -checkOverlapByteArray False _ _ _ _ _ r = r -checkOverlapByteArray True a1 o1 a2 o2 n r = - ifS (app "h$checkOverlapByteArray" [a1, o1, a2, o2, n]) - r - (returnS $ app "h$exitProcess" [Int 134]) - -copyByteArray :: Bool -> Bool -> JExpr -> JExpr -> JExpr -> JExpr -> JExpr -> PrimRes -copyByteArray allow_overlap bound a1 o1 a2 o2 n = PrimInline $ check $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] - where - check = bnd_ba_range bound a1 o1 n - . bnd_ba_range bound a2 o2 n - . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) - --- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 --- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. --- So (x|0) * (y|0) can still return values outside of the Int32 range. You have --- been warned! -toI32 :: JExpr -> JExpr -toI32 e = BOr e zero_ - --- e>>>0 (32 bit unsigned integer truncation) --- required because of JS numbers. e>>>0 converts e to a Word32 --- so (-2147483648) >>> 0 = 2147483648 --- and ((-2147483648) >>>0) | 0 = -2147483648 -toU32 :: JExpr -> JExpr -toU32 e = e .>>>. zero_ - -quotShortInt :: Int -> JExpr -> JExpr -> JExpr -quotShortInt bits x y = BAnd (signed x `Div` signed y) mask - where - signed z = (z .<<. shift) .>>. shift - shift = toJExpr (32 - bits) - mask = toJExpr (((2::Integer) ^ bits) - 1) - -remShortInt :: Int -> JExpr -> JExpr -> JExpr -remShortInt bits x y = BAnd (signed x `Mod` signed y) mask - where - signed z = (z .<<. shift) .>>. shift - shift = toJExpr (32 - bits) - mask = toJExpr (((2::Integer) ^ bits) - 1) +import GHC.JS.JStg.Syntax hiding (YieldOp) +import GHC.JS.JStg.Monad +import GHC.JS.Make +import GHC.JS.Ident + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.Symbols + +import GHC.Core.Type + +import GHC.Builtin.PrimOps +import GHC.Tc.Utils.TcType (isBoolTy) +import GHC.Utils.Encoding (zEncodeString) + +import GHC.Data.FastString +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) + +genPrim :: Bool -- ^ Profiling (cost-centres) enabled + -> Bool -- ^ Array bounds-checking enabled + -> Type + -> PrimOp -- ^ the primitive operation + -> [JStgExpr] -- ^ where to store the result + -> [JStgExpr] -- ^ arguments + -> JSM PrimRes +genPrim prof bound ty op = case op of + CharGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + CharGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + CharEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + CharNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + CharLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + CharLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + OrdOp -> \[r] [x] -> pure $ PrimInline $ r |= x + + Int8ToWord8Op -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + Word8ToInt8Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 x + Int16ToWord16Op -> \[r] [x] -> pure $ PrimInline $ r |= mask16 x + Word16ToInt16Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 x + Int32ToWord32Op -> \[r] [x] -> pure $ PrimInline $ r |= x .>>>. zero_ + Word32ToInt32Op -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + +------------------------------ Int ---------------------------------------------- + + 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 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 -> + pure $ mconcat + [ tmp |= Mul x y + , r |= if01 (tmp .===. toI32 tmp) + ] + IntQuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (Div x y) + IntRemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mod x y + IntQuotRemOp -> \[q,r] [x,y] -> pure $ PrimInline $ mconcat + [ q |= toI32 (Div x y) + , r |= x `Sub` (Mul y q) + ] + IntAndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BAnd x y + IntOrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BOr x y + IntXorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BXor x y + IntNotOp -> \[r] [x] -> pure $ PrimInline $ r |= BNot x + + IntNegOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 (Negate x) +-- add with carry: overflow == 0 iff no overflow + IntAddCOp -> \[r,overf] [x,y] -> + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= Add x y + , r |= toI32 tmp + , overf |= if10 (r .!=. tmp) + ] + IntSubCOp -> \[r,overf] [x,y] -> + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= Sub x y + , r |= toI32 tmp + , overf |= if10 (r .!=. tmp) + ] + 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) + 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 + IntToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= x .>>>. zero_ + IntToFloatOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToDoubleOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntSllOp -> \[r] [x,y] -> pure $ PrimInline $ r |= x .<<. y + IntSraOp -> \[r] [x,y] -> pure $ PrimInline $ r |= x .>>. y + IntSrlOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toI32 (x .>>>. y) + +------------------------------ Int8 --------------------------------------------- + + Int8ToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToInt8Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 x + Int8NegOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 (Negate x) + Int8AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (Add x y) + Int8SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (Sub x y) + Int8MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (Mul x y) + Int8QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (quotShortInt 8 x y) + Int8RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend8 (remShortInt 8 x y) + Int8QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= signExtend8 (quotShortInt 8 x y) + , r2 |= signExtend8 (remShortInt 8 x y) + ] + Int8EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Int8GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24))) + Int8GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .>. (y .<<. (Int 24))) + Int8LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24))) + Int8LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 24)) .<. (y .<<. (Int 24))) + Int8NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Int8SraOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>. i + Int8SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend8 (mask8 x .>>>. i) + Int8SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend8 (mask8 (x .<<. i)) + +------------------------------ Word8 -------------------------------------------- + + Word8ToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + WordToWord8Op -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + + Word8AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Add x y) + Word8SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Sub x y) + Word8MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Mul x y) + Word8QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask8 (Div x y) + Word8RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mod x y + Word8QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word8EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Word8GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + Word8GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + Word8LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + Word8LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + Word8NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Word8AndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BAnd x y + Word8OrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BOr x y + Word8XorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BXor x y + Word8NotOp -> \[r] [x] -> pure $ PrimInline $ r |= BXor x (Int 0xff) + + Word8SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= mask8 (x .<<. i) + Word8SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>>. i + +------------------------------ Int16 ------------------------------------------- + + Int16ToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToInt16Op -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 x + + Int16NegOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 (Negate x) + Int16AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (Add x y) + Int16SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (Sub x y) + Int16MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (Mul x y) + Int16QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (quotShortInt 16 x y) + Int16RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= signExtend16 (remShortInt 16 x y) + Int16QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= signExtend16 (quotShortInt 16 x y) + , r2 |= signExtend16 (remShortInt 16 x y) + ] + Int16EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Int16GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16))) + Int16GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .>. (y .<<. (Int 16))) + Int16LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16))) + Int16LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 ((x .<<. (Int 16)) .<. (y .<<. (Int 16))) + Int16NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Int16SraOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>. i + Int16SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend16 (mask16 x .>>>. i) + Int16SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= signExtend16 (x .<<. i) + +------------------------------ Word16 ------------------------------------------ + + Word16ToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= x + WordToWord16Op -> \[r] [x] -> pure $ PrimInline $ r |= mask16 x + + Word16AddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Add x y) + Word16SubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Sub x y) + Word16MulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Mul x y) + Word16QuotOp -> \[r] [x,y] -> pure $ PrimInline $ r |= mask16 (Div x y) + Word16RemOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mod x y + Word16QuotRemOp -> \[r1,r2] [x,y] -> pure $ PrimInline $ mconcat + [ r1 |= toI32 (Div x y) + , r2 |= Mod x y + ] + Word16EqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + Word16GeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + Word16GtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + Word16LeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + Word16LtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + Word16NeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + + Word16AndOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BAnd x y + Word16OrOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BOr x y + Word16XorOp -> \[r] [x,y] -> pure $ PrimInline $ r |= BXor x y + Word16NotOp -> \[r] [x] -> pure $ PrimInline $ r |= BXor x (Int 0xffff) + + Word16SllOp -> \[r] [x,i] -> pure $ PrimInline $ r |= mask16 (x .<<. i) + Word16SrlOp -> \[r] [x,i] -> pure $ PrimInline $ r |= x .>>>. i + +------------------------------ Int32 -------------------------------------------- + + Int32ToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= x + IntToInt32Op -> \[r] [x] -> pure $ PrimInline $ r |= x + + Int32NegOp -> \rs xs -> genPrim prof bound ty IntNegOp rs xs + Int32AddOp -> \rs xs -> genPrim prof bound ty IntAddOp rs xs + Int32SubOp -> \rs xs -> genPrim prof bound ty IntSubOp rs xs + Int32MulOp -> \rs xs -> genPrim prof bound ty IntMulOp rs xs + Int32QuotOp -> \rs xs -> genPrim prof bound ty IntQuotOp rs xs + Int32RemOp -> \rs xs -> genPrim prof bound ty IntRemOp rs xs + Int32QuotRemOp -> \rs xs -> genPrim prof bound ty IntQuotRemOp rs xs + + Int32EqOp -> \rs xs -> genPrim prof bound ty IntEqOp rs xs + Int32GeOp -> \rs xs -> genPrim prof bound ty IntGeOp rs xs + Int32GtOp -> \rs xs -> genPrim prof bound ty IntGtOp rs xs + Int32LeOp -> \rs xs -> genPrim prof bound ty IntLeOp rs xs + Int32LtOp -> \rs xs -> genPrim prof bound ty IntLtOp rs xs + Int32NeOp -> \rs xs -> genPrim prof bound ty IntNeOp rs xs + + Int32SraOp -> \rs xs -> genPrim prof bound ty IntSraOp rs xs + Int32SrlOp -> \rs xs -> genPrim prof bound ty IntSrlOp rs xs + Int32SllOp -> \rs xs -> genPrim prof bound ty IntSllOp rs xs + +------------------------------ Word32 ------------------------------------------- + + Word32ToWordOp -> \[r] [x] -> pure $ PrimInline $ r |= x + WordToWord32Op -> \[r] [x] -> pure $ PrimInline $ r |= x + + Word32AddOp -> \rs xs -> genPrim prof bound ty WordAddOp rs xs + Word32SubOp -> \rs xs -> genPrim prof bound ty WordSubOp rs xs + Word32MulOp -> \rs xs -> genPrim prof bound ty WordMulOp rs xs + Word32QuotOp -> \rs xs -> genPrim prof bound ty WordQuotOp rs xs + Word32RemOp -> \rs xs -> genPrim prof bound ty WordRemOp rs xs + Word32QuotRemOp -> \rs xs -> genPrim prof bound ty WordQuotRemOp rs xs + + Word32EqOp -> \rs xs -> genPrim prof bound ty WordEqOp rs xs + Word32GeOp -> \rs xs -> genPrim prof bound ty WordGeOp rs xs + Word32GtOp -> \rs xs -> genPrim prof bound ty WordGtOp rs xs + Word32LeOp -> \rs xs -> genPrim prof bound ty WordLeOp rs xs + Word32LtOp -> \rs xs -> genPrim prof bound ty WordLtOp rs xs + Word32NeOp -> \rs xs -> genPrim prof bound ty WordNeOp rs xs + + Word32AndOp -> \rs xs -> genPrim prof bound ty WordAndOp rs xs + Word32OrOp -> \rs xs -> genPrim prof bound ty WordOrOp rs xs + Word32XorOp -> \rs xs -> genPrim prof bound ty WordXorOp rs xs + Word32NotOp -> \rs xs -> genPrim prof bound ty WordNotOp rs xs + + Word32SllOp -> \rs xs -> genPrim prof bound ty WordSllOp rs xs + Word32SrlOp -> \rs xs -> genPrim prof bound ty WordSrlOp rs xs + +------------------------------ Int64 -------------------------------------------- + + Int64ToIntOp -> \[r] [_h,l] -> pure $ PrimInline $ r |= toI32 l + + Int64NegOp -> \[r_h,r_l] [h,l] -> + pure $ PrimInline $ mconcat + [ r_l |= toU32 (Add (BNot l) one_) + , r_h |= toI32 (Add (BNot h) (Not r_l)) + ] + + 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] 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 + [ r1 |= toU32 x1 + , r2 |= x2 + ] + IntToInt64Op -> \[r1,r2] [x] -> + pure $ PrimInline $ mconcat + [ r1 |= if_ (x .<. zero_) (Negate one_) zero_ -- sign-extension + , r2 |= toU32 x + ] + + Int64EqOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Int64NeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Int64GeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Int64GtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + Int64LeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1))) + Int64LtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1))) + +------------------------------ Word64 ------------------------------------------- + + Word64ToWordOp -> \[r] [_x1,x2] -> pure $ PrimInline $ r |= x2 + + WordToWord64Op -> \[rh,rl] [x] -> + pure $ PrimInline $ mconcat + [ rh |= zero_ + , rl |= x + ] + + Word64ToInt64Op -> \[r1,r2] [x1,x2] -> + pure $ PrimInline $ mconcat + [ r1 |= toI32 x1 + , r2 |= x2 + ] + + Word64EqOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1)) + Word64NeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1)) + Word64GeOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1))) + Word64GtOp -> \[r] [h0,l0,h1,l1] -> pure $ PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1))) + 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] 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 + [ hr |= toU32 (BOr h0 h1) + , hl |= toU32 (BOr l0 l1) + ] + + Word64AndOp -> \[hr,hl] [h0, l0, h1, l1] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BAnd h0 h1) + , hl |= toU32 (BAnd l0 l1) + ] + + Word64XorOp -> \[hr,hl] [h0, l0, h1, l1] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BXor h0 h1) + , hl |= toU32 (BXor l0 l1) + ] + + Word64NotOp -> \[hr,hl] [h, l] -> + pure $ PrimInline $ mconcat + [ hr |= toU32 (BNot h) + , hl |= toU32 (BNot l) + ] + + 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 --------------------------------------------- + + WordAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= (x `Add` y) .>>>. zero_ + WordAddCOp -> \[r,c] [x,y] -> + PrimInline <$> + jVar \tmp -> + pure $ mconcat + [ tmp |= x `Add` y + , r |= toU32 tmp + , c |= if10 (tmp .!==. r) + ] + WordSubCOp -> \[r,c] [x,y] -> + pure $ PrimInline $ mconcat + [ r |= toU32 (Sub x y) + , c |= if10 (y .>. x) + ] + 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 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) + WordNotOp -> \[r] [x] -> pure $ PrimInline $ r |= toU32 (BNot x) + WordSllOp -> \[r] [x,y] -> pure $ PrimInline $ r |= toU32 (x .<<. y) + WordSrlOp -> \[r] [x,y] -> pure $ PrimInline $ r |= x .>>>. y + WordToIntOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + WordGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + WordGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + WordEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + WordNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + WordLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + 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 |= 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 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 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 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 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)) + (mask8 (x .>>>. (Int 8))) + BSwap32Op -> \[r] [x] -> pure $ PrimInline $ + r |= toU32 ((x .<<. (Int 24)) + `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] 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 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 hdReverseWordStr [h] + , rh |= app hdReverseWordStr [l] + ] + +------------------------------ Narrow ------------------------------------------- + + Narrow8IntOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend8 x + Narrow16IntOp -> \[r] [x] -> pure $ PrimInline $ r |= signExtend16 x + Narrow32IntOp -> \[r] [x] -> pure $ PrimInline $ r |= toI32 x + Narrow8WordOp -> \[r] [x] -> pure $ PrimInline $ r |= mask8 x + Narrow16WordOp -> \[r] [x] -> pure $ PrimInline $ r |= mask16 x + Narrow32WordOp -> \[r] [x] -> pure $ PrimInline $ r |= toU32 x + +------------------------------ Double ------------------------------------------- + + DoubleGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + DoubleGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + DoubleEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + DoubleNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + DoubleLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + DoubleLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + DoubleAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Add x y + DoubleSubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Sub x y + DoubleMulOp -> \[r] [x,y] -> pure $ PrimInline $ r |= Mul x y + 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] + DoubleExpM1Op -> \[r] [x] -> pure $ PrimInline $ r |= math_expm1 [x] + DoubleLogOp -> \[r] [x] -> pure $ PrimInline $ r |= math_log [x] + DoubleLog1POp -> \[r] [x] -> pure $ PrimInline $ r |= math_log1p [x] + DoubleSqrtOp -> \[r] [x] -> pure $ PrimInline $ r |= math_sqrt [x] + DoubleSinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_sin [x] + DoubleCosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_cos [x] + DoubleTanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_tan [x] + DoubleAsinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_asin [x] + DoubleAcosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_acos [x] + DoubleAtanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_atan [x] + DoubleSinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_sinh [x] + DoubleCoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_cosh [x] + DoubleTanhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_tanh [x] + DoubleAsinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_asinh [x] + 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] 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 + DoubleFNMAdd -> unhandledPrimop op + DoubleFNMSub -> unhandledPrimop op + +------------------------------ Float -------------------------------------------- + + FloatGtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>. y) + FloatGeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .>=. y) + FloatEqOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .===. y) + FloatNeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .!==. y) + FloatLtOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<. y) + FloatLeOp -> \[r] [x,y] -> pure $ PrimInline $ r |= if10 (x .<=. y) + FloatAddOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Add x y] + FloatSubOp -> \[r] [x,y] -> pure $ PrimInline $ r |= math_fround [Sub x y] + 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]] + FloatExpM1Op -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_expm1 [x]] + FloatLogOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_log [x]] + FloatLog1POp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_log1p [x]] + FloatSqrtOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_sqrt [x]] + FloatSinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_sin [x]] + FloatCosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_cos [x]] + FloatTanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_tan [x]] + FloatAsinOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_asin [x]] + FloatAcosOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_acos [x]] + FloatAtanOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_atan [x]] + FloatSinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_sinh [x]] + FloatCoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_cosh [x]] + FloatTanhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_tanh [x]] + FloatAsinhOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_asinh [x]] + FloatAcoshOp -> \[r] [x] -> pure $ PrimInline $ r |= math_fround [math_acosh [x]] + 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] hdDecodeFloatIntStr [x] + CastFloatToWord32Op -> \[r] [x] -> pure $ PrimInline $ appT [r] hdCastFloatToWord32Str [x] + CastWord32ToFloatOp -> \[r] [x] -> pure $ PrimInline $ appT [r] hdCastWord32ToFloatStr [x] + + + FloatFMAdd -> unhandledPrimop op + FloatFMSub -> unhandledPrimop op + FloatFNMAdd -> unhandledPrimop op + FloatFNMSub -> unhandledPrimop op + +------------------------------ Arrays ------------------------------------------- + + 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 .^ 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 + CopyArrayOp -> \[] [a,o1,ma,o2,n] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr_range bound a o1 n + $ bnd_arr_range bound ma o2 n + $ mconcat [ tmp |= Int 0 + , WhileStat False (tmp .<. n) $ + mconcat [ ma .! (Add tmp o2) |= a .! (Add tmp o1) + , preIncrS tmp + ] + + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> + pure $ PrimInline + $ bnd_arr_range bound a1 o1 n + $ bnd_arr_range bound 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 hdSliceArrayStr [a,start,n] + + CloneMutableArrayOp -> \[r] [a,start,n] -> + pure $ PrimInline + $ bnd_arr_range bound 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 hdSliceArrayStr [a,start,n] + + ThawArrayOp -> \[r] [a,start,n] -> + pure $ PrimInline + $ bnd_arr_range bound a start n + $ r |= app hdSliceArrayStr [a,start,n] + + CasArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr bound a i + $ mconcat + [ tmp |= a .! i + , ifBlockS (tmp .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= tmp + ] + ] + +------------------------------ Small Arrays ------------------------------------- + + 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 .^ 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 + CopySmallArrayOp -> \[] [s,si,d,di,n] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr_range bound s si n + $ bnd_arr_range bound d di n + $ mconcat [ tmp |= Sub n one_ + , WhileStat False (tmp .>=. zero_) + $ mconcat [ d .! (Add di tmp) |= s .! (Add si tmp) + , postDecrS tmp + ] + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> + pure $ PrimInline + $ bnd_arr_range bound s si n + $ bnd_arr_range bound 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 + FreezeSmallArrayOp -> \[r] [a,o,n] -> pure $ PrimInline $ cloneArray bound r a o n + ThawSmallArrayOp -> \[r] [a,o,n] -> pure $ PrimInline $ cloneArray bound r a o n + + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> + PrimInline <$> + jVar \tmp -> + pure $ bnd_arr bound a i + $ mconcat + [ tmp |= a .! i + , ifBlockS (tmp .===. old) + [ o |= new + , a .! i |= new + , s |= zero_ + ] + [ s |= one_ + , o |= tmp + ] + ] + +------------------------------- Byte Arrays ------------------------------------- + + NewByteArrayOp_Char -> \[r] [l] -> pure $ PrimInline (newByteArray r l) + NewPinnedByteArrayOp_Char -> \[r] [l] -> pure $ PrimInline (newByteArray r l) + 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 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 + + 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 + IndexByteArrayOp_Int -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + IndexByteArrayOp_Float -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + IndexByteArrayOp_Int8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + IndexByteArrayOp_Word8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + ReadByteArrayOp_Char -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_addr a i r o + ReadByteArrayOp_Float -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ read_stableptr a i r o + ReadByteArrayOp_Int8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_i64 a i h l + ReadByteArrayOp_Word8 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix8 bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix16 bound a i $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ix64 bound a i $ read_u64 a i h l + + WriteByteArrayOp_Char -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,r,o] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_addr a i r o + WriteByteArrayOp_Float -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix64 bound a i $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,r,o] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_stableptr a i r o + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix8 bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix16 bound a i $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ix64 bound a i $ write_i64 a i h l + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix8 bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix16 bound a i $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ix64 bound a i $ write_u64 a i h l + + CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> + pure . PrimInline + . bnd_ba_range bound a1 o1 n + . bnd_ba_range bound 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#) + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToByteArrayOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyMutableByteArrayNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyAddrToAddrNonOverlappingOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + CopyByteArrayToAddrOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray False bound a1 o1 a2 o2 n + + CopyMutableByteArrayOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray True bound a1 o1 a2 o2 n + CopyAddrToAddrOp -> \[] [a1,o1,a2,o2,n] -> pure $ copyByteArray True bound a1 o1 a2 o2 n + + SetByteArrayOp -> \[] [a,o,n,v] -> + PrimInline <$> jVar \tmpIdent -> + do + let tmp = global $ identFS tmpIdent + pure . bnd_ba_range bound a o n $ + mconcat [ tmpIdent ||= zero_ + , WhileStat False (tmp .<. n) $ + mconcat [ write_u8 a (Add o tmp) v + , postIncrS tmp + ] + ] + SetAddrRangeOp -> \[] xs@[_a,_o,_n,_v] -> genPrim prof bound ty SetByteArrayOp [] xs + + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> pure $ PrimInline $ bnd_ix32 bound a i $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> pure $ PrimInline $ bnd_ix32 bound a i $ fetchOpByteArray BXor r a i v + +------------------------------- Addr# ------------------------------------------ + + AddrAddOp -> \[a',o'] [a,o,i] -> pure $ PrimInline $ mconcat [a' |= a, o' |= Add o i] + AddrSubOp -> \[i] [_a1,o1,_a2,o2] -> pure $ PrimInline $ i |= Sub o1 o2 + 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 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 ------------------- + + IndexOffAddrOp_Char -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off32 o i) ra ro + IndexOffAddrOp_Float -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off32 o i) ra ro + IndexOffAddrOp_Int8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off64 o i) h l + IndexOffAddrOp_Word8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off64 o i) h l + + ReadOffAddrOp_Char -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off32 o i) ra ro + ReadOffAddrOp_Float -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off32 o i) ra ro + ReadOffAddrOp_Int8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off64 o i) h l + ReadOffAddrOp_Word8 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off64 o i) h l + + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_addr a (off32 o i) va vo + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_stableptr a (off32 o i) va vo + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_i64 a (off64 o i) h l + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_u64 a (off64 o i) h l + + IndexOffAddrOp_Word8AsChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word8AsWideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsInt -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsWord -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + IndexOffAddrOp_Word8AsAddr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off8 o i) ra ro + IndexOffAddrOp_Word8AsFloat -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off8 o i) + IndexOffAddrOp_Word8AsDouble -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off8 o i) + IndexOffAddrOp_Word8AsStablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off8 o i) ra ro + IndexOffAddrOp_Word8AsInt16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off8 o i) + IndexOffAddrOp_Word8AsInt32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + IndexOffAddrOp_Word8AsInt64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off8 o i) h l + IndexOffAddrOp_Word8AsWord16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off8 o i) + IndexOffAddrOp_Word8AsWord32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + IndexOffAddrOp_Word8AsWord64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off8 o i) h l + + ReadOffAddrOp_Word8AsChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word8AsWideChar -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsInt -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsWord -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + ReadOffAddrOp_Word8AsAddr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_addr a (off8 o i) ra ro + ReadOffAddrOp_Word8AsFloat -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f32 a (off8 o i) + ReadOffAddrOp_Word8AsDouble -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_f64 a (off8 o i) + ReadOffAddrOp_Word8AsStablePtr -> \[ra,ro] [a,o,i] -> pure $ PrimInline $ read_boff_stableptr a (off8 o i) ra ro + ReadOffAddrOp_Word8AsInt16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i16 a (off8 o i) + ReadOffAddrOp_Word8AsInt32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_i32 a (off8 o i) + ReadOffAddrOp_Word8AsInt64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_i64 a (off8 o i) h l + ReadOffAddrOp_Word8AsWord16 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u16 a (off8 o i) + ReadOffAddrOp_Word8AsWord32 -> \[r] [a,o,i] -> pure $ PrimInline $ r |= read_boff_u32 a (off8 o i) + ReadOffAddrOp_Word8AsWord64 -> \[h,l] [a,o,i] -> pure $ PrimInline $ read_boff_u64 a (off8 o i) h l + + WriteOffAddrOp_Word8AsChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word8AsWideChar -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsInt -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsWord -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off8 o i) v + WriteOffAddrOp_Word8AsAddr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_addr a (off8 o i) va vo + WriteOffAddrOp_Word8AsFloat -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f32 a (off8 o i) v + WriteOffAddrOp_Word8AsDouble -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_f64 a (off8 o i) v + WriteOffAddrOp_Word8AsStablePtr -> \[] [a,o,i,va,vo] -> pure $ PrimInline $ write_boff_stableptr a (off8 o i) va vo + WriteOffAddrOp_Word8AsInt16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i16 a (off8 o i) v + WriteOffAddrOp_Word8AsInt32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_i32 a (off8 o i) v + WriteOffAddrOp_Word8AsInt64 -> \[] [a,o,i,h,l] -> pure $ PrimInline $ write_boff_i64 a (off8 o i) h l + WriteOffAddrOp_Word8AsWord16 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u16 a (off8 o i) v + WriteOffAddrOp_Word8AsWord32 -> \[] [a,o,i,v] -> pure $ PrimInline $ write_boff_u32 a (off8 o i) v + 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 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]) + +------------------------------- Exceptions -------------------------------------- + + 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 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 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 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 + , r |= if01 (v .===. null_) + ] + IsEmptyMVarOp -> \[r] [m] -> pure $ PrimInline $ r |= if10 (m .^ val .===. null_) + +------------------------------- Delay/Wait Ops --------------------------------- + + 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 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] 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 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 + , f |= if01 (v .===. null_) + ] + FinalizeWeakOp -> \[fl,fin] [w] -> pure $ PrimInline $ appT [fin, fl] hdFinalizeWeak [w] + TouchOp -> \[] [_e] -> pure $ PrimInline mempty + KeepAliveOp -> \[_r] [x, f] -> pure $ PRPrimCall $ ReturnStat (app hdKeepAlive [x, f]) + + +------------------------------ Stable pointers and names ------------------------ + + MakeStablePtrOp -> \[s1,s2] [a] -> pure $ PrimInline $ mconcat + [ s1 |= hdStablePtrBuf + , s2 |= app hdMakeStablePtrStr [a] + ] + 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 hdMakeStableName [a] + StableNameToIntOp -> \[r] [s] -> pure $ PrimInline $ r |= app hdStableNameInt [s] + +------------------------------ Compact normal form ----------------------------- + + 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] hdCompactGetFirstBlock [c] + CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] -> + pure $ PrimInline $ appT [ra,ro,s] hdCompactGetNextBlock [c,a,o] + CompactAllocateBlockOp -> \[ra,ro] [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] hdCompactFixupPointers [blocka,blocko,roota,rooto] + CompactAdd -> \[_r] [c,o] -> + pure $ PRPrimCall $ returnS (app hdCompactAdd [c,o]) + CompactAddWithSharing -> \[_r] [c,o] -> + pure $ PRPrimCall $ returnS (app hdCompactAddWithSharing [c,o]) + CompactSize -> \[s] [c] -> + pure $ PrimInline $ s |= app hdCompactSize [c] + +------------------------------ Unsafe pointer equality -------------------------- + + ReallyUnsafePtrEqualityOp -> \[r] [p1,p2] -> pure $ PrimInline $ r |= if10 (p1 .===. p2) + +------------------------------ Parallelism -------------------------------------- + + ParOp -> \[r] [_a] -> pure $ PrimInline $ r |= zero_ + SparkOp -> \[r] [a] -> pure $ PrimInline $ r |= a + NumSparks -> \[r] [] -> pure $ PrimInline $ r |= zero_ + +------------------------------ Tag to enum stuff -------------------------------- + + DataToTagSmallOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ stack .! PreInc sp |= global (identFS hdDataToTagEntryStr) + , returnS (app hdEntryStr [d]) + ] + DataToTagLargeOp -> \[_r] [d] -> pure $ PRPrimCall $ mconcat + [ 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 hdTagToEnum [tag] + +------------------------------ Bytecode operations ------------------------------ + + AddrToAnyOp -> \[r] [d,_o] -> pure $ PrimInline $ r |= d + +------------------------------ Profiling (CCS) ------------------------------ + + GetCCSOfOp -> \[a, o] [obj] -> pure $ PrimInline $ mconcat + if prof + then [ a |= if_ (isObject obj) + (app hdBuildCCSPtrStr [obj .^ ccStr]) + null_ + , o |= zero_ + ] + else [ a |= null_ + , o |= zero_ + ] + + GetCurrentCCSOp -> \[a, o] [_dummy_arg] -> + 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 hdClearCCSStr [x]) + +------------------------------ Eventlog ------------------- + + 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 ------------------- + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba8 bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_addr a i r o + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r,o] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ read_boff_stableptr a i r o + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_i64 a i h l + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba16 bound a i $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> pure $ PrimInline $ bnd_ba64 bound a i $ read_boff_u64 a i h l + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> pure $ PrimInline $ bnd_ba32 bound a i $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba8 bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,r,o] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_addr a i r o + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba64 bound a i $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_,o] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i o + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba16 bound a i $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ba64 bound a i $ write_boff_i64 a i h l + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba16 bound a i $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> pure $ PrimInline $ bnd_ba64 bound a i $ write_boff_u64 a i h l + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> pure $ PrimInline $ bnd_ba32 bound a i $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + CasByteArrayOp_Int8 -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix8 bound a i $ casOp read_i8 write_i8 r a i o n + CasByteArrayOp_Int16 -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix16 bound a i $ casOp read_i16 write_i16 r a i o n + CasByteArrayOp_Int32 -> \[r] [a,i,o,n] -> pure $ PrimInline $ bnd_ix32 bound a i $ casOp read_i32 write_i32 r a i o n + + CasByteArrayOp_Int64 -> \[rh,rl] [a,i,oh,ol,nh,nl] -> pure $ PrimInline $ bnd_ix64 bound a i $ casOp2 read_i64 write_i64 (rh,rl) a i (oh,ol) (nh,nl) + + CasAddrOp_Addr -> \[ra,ro] [a,o,oa,oo,na,no] -> pure $ PrimInline $ casOp2 read_boff_addr write_boff_addr (ra,ro) a o (oa,oo) (na,no) + CasAddrOp_Word -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word8 -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u8 write_u8 r a o old new + CasAddrOp_Word16 -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u16 write_u16 r a o old new + CasAddrOp_Word32 -> \[r] [a,o,old,new] -> pure $ PrimInline $ casOp read_u32 write_u32 r a o old new + CasAddrOp_Word64 -> \[rh,rl] [a,o,oh,ol,nh,nl] -> pure $ PrimInline $ casOp2 read_u64 write_u64 (rh,rl) a o (oh,ol) (nh,nl) + + FetchAddAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr Add r a o v + FetchSubAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr Sub r a o v + FetchAndAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr BAnd r a o v + FetchNandAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v + FetchOrAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr BOr r a o v + FetchXorAddrOp_Word -> \[r] [a,o,v] -> pure $ PrimInline $ fetchOpAddr BXor r a o v + + InterlockedExchange_Addr -> \[ra,ro] [a1,o1,a2,o2] -> pure $ PrimInline $ mconcat + [ read_boff_addr a1 o1 ra ro + , write_boff_addr a1 o1 a2 o2 + ] + InterlockedExchange_Word -> \[r] [a,o,w] -> pure $ PrimInline $ mconcat + [ r |= read_boff_u32 a o + , write_boff_u32 a o w + ] + + 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 + + +------------------------------ Unhandled primops ------------------- + + AnnotateStackOp -> unhandledPrimop op + + NewPromptTagOp -> unhandledPrimop op + PromptOp -> unhandledPrimop op + Control0Op -> unhandledPrimop op + + GetSparkOp -> unhandledPrimop op + AnyToAddrOp -> unhandledPrimop op + MkApUpd0_Op -> unhandledPrimop op + NewBCOOp -> unhandledPrimop op + UnpackClosureOp -> unhandledPrimop op + ClosureSizeOp -> unhandledPrimop op + GetApStackValOp -> unhandledPrimop op + WhereFromOp -> unhandledPrimop op -- should be easily implementable with o.f.n + + SetThreadAllocationCounter -> unhandledPrimop op + SetOtherThreadAllocationCounter -> unhandledPrimop op + +------------------------------- Vector ----------------------------------------- +-- For now, vectors are unsupported on the JS backend. Simply put, they do not +-- make much sense to support given support for arrays and lack of SIMD support +-- in JS. We could try to roll something special but we would not be able to +-- give any performance guarentees to the user and so we leave these has +-- unhandled for now. + VecBroadcastOp _ _ _ -> unhandledPrimop op + VecPackOp _ _ _ -> unhandledPrimop op + VecUnpackOp _ _ _ -> unhandledPrimop op + VecInsertOp _ _ _ -> unhandledPrimop op + VecAddOp _ _ _ -> unhandledPrimop op + VecSubOp _ _ _ -> unhandledPrimop op + VecMulOp _ _ _ -> unhandledPrimop op + VecDivOp _ _ _ -> unhandledPrimop op + VecQuotOp _ _ _ -> unhandledPrimop op + VecRemOp _ _ _ -> unhandledPrimop op + VecNegOp _ _ _ -> unhandledPrimop op + VecIndexByteArrayOp _ _ _ -> unhandledPrimop op + VecReadByteArrayOp _ _ _ -> unhandledPrimop op + VecWriteByteArrayOp _ _ _ -> unhandledPrimop op + VecIndexOffAddrOp _ _ _ -> unhandledPrimop op + 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 + PrefetchAddrOp3 -> noOp + PrefetchValueOp3 -> noOp + PrefetchByteArrayOp2 -> noOp + PrefetchMutableByteArrayOp2 -> noOp + PrefetchAddrOp2 -> noOp + PrefetchValueOp2 -> noOp + PrefetchByteArrayOp1 -> noOp + PrefetchMutableByteArrayOp1 -> noOp + PrefetchAddrOp1 -> noOp + PrefetchValueOp1 -> noOp + PrefetchByteArrayOp0 -> noOp + PrefetchMutableByteArrayOp0 -> noOp + PrefetchAddrOp0 -> noOp + PrefetchValueOp0 -> noOp + +unhandledPrimop :: PrimOp -> [JStgExpr] -> [JStgExpr] -> JSM PrimRes +unhandledPrimop op rs as = pure $ PrimInline $ mconcat + [ appS "h$log" $ pure $ String $ + fsLit $ mconcat + [ "warning, unhandled primop: " + , renderWithContext defaultSDocContext (ppr op) + , " " + , show (length rs, length as) + ] + , appS (mkFastString $ unpackFS hdPrimOpStr ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as + -- copyRes + , 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 +-- example, the prefetching primops do not make sense on the JS platform because +-- we do not have enough control over memory to provide any kind of prefetching +-- mechanism. Hence, these are NoOps. +noOp :: Foldable f => f a -> f a -> JSM PrimRes +noOp = const . const . pure $ PrimInline mempty + +-- tuple returns +appT :: [JStgExpr] -> FastString -> [JStgExpr] -> JStgStat +appT [] f xs = appS f xs +appT (r:rs) f xs = mconcat + [ r |= app f xs + , mconcat (zipWith (\r ret -> r |= (foreignRegister ret)) rs (enumFrom Ret1)) + ] + +-------------------------------------------- +-- ByteArray indexing +-------------------------------------------- + +-- For every ByteArray, the RTS creates the following views: +-- i3: Int32 view +-- u8: Word8 view +-- u1: Word16 view +-- f3: Float32 view +-- f6: Float64 view +-- dv: generic DataView +-- It seems a bit weird to mix Int and Word views like this, but perhaps they +-- are the more common. +-- +-- See 'h$newByteArray' in 'ghc/rts/js/mem.js' for details. +-- +-- Note that *byte* indexing can only be done with the generic DataView. Use +-- read_boff_* and write_boff_* for this. +-- +-- Other read_* and write_* helpers directly use the more specific views. +-- 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 + +read_u8 :: JStgExpr -> JStgExpr -> JStgExpr +read_u8 a i = idx_u8 a i + +read_u16 :: JStgExpr -> JStgExpr -> JStgExpr +read_u16 a i = idx_u16 a i + +read_u32 :: JStgExpr -> JStgExpr -> JStgExpr +read_u32 a i = toU32 (idx_i32 a i) + +read_i8 :: JStgExpr -> JStgExpr -> JStgExpr +read_i8 a i = signExtend8 (idx_u8 a i) + +read_i16 :: JStgExpr -> JStgExpr -> JStgExpr +read_i16 a i = signExtend16 (idx_u16 a i) + +read_i32 :: JStgExpr -> JStgExpr -> JStgExpr +read_i32 a i = idx_i32 a i + +read_f32 :: JStgExpr -> JStgExpr -> JStgExpr +read_f32 a i = idx_f32 a i + +read_f64 :: JStgExpr -> JStgExpr -> JStgExpr +read_f64 a i = idx_f64 a i + +read_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_u64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. one_) + , rh |= read_u32 a (Add one_ (i .<<. one_)) + ] + +read_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_i64 a i rh rl = mconcat + [ rl |= read_u32 a (i .<<. one_) + , rh |= read_i32 a (Add one_ (i .<<. one_)) + ] + +-------------------------------------- +-- Addr# +-------------------------------------- + +write_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +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 + ] + +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_)) + 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) + null_ + ] + +write_boff_addr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +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 + ] + + +-------------------------------------- +-- StablePtr +-------------------------------------- + +read_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_stableptr a i r o = mconcat + [ o |= read_i32 a i + , ifS (o .===. zero_) + (r |= null_) + (r |= hdStablePtrBuf) + ] + +read_boff_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_stableptr a i r o = mconcat + [ o |= read_boff_i32 a i + , ifS (o .===. zero_) + (r |= null_) + (r |= hdStablePtrBuf) + ] + +write_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_stableptr a i _r o = write_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf or null + +write_boff_stableptr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_boff_stableptr a i _r o = write_boff_i32 a i o + -- don't store "r" as it must be h$stablePtrBuf or null + +write_u8 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u8 a i v = idx_u8 a i |= v + +write_u16 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u16 a i v = idx_u16 a i |= v + +write_u32 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u32 a i v = idx_i32 a i |= v + +write_i8 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i8 a i v = idx_u8 a i |= v + +write_i16 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i16 a i v = idx_u16 a i |= v + +write_i32 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i32 a i v = idx_i32 a i |= v + +write_f32 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_f32 a i v = idx_f32 a i |= v + +write_f64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_f64 a i v = idx_f64 a i |= v + +write_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_u64 a i h l = mconcat + [ write_u32 a (i .<<. one_) l + , write_u32 a (Add one_ (i .<<. one_)) h + ] + +write_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_i64 a i h l = mconcat + [ write_u32 a (i .<<. one_) l + , write_i32 a (Add one_ (i .<<. one_)) h + ] + +-- Data View helper functions: byte indexed! +-- +-- The argument list consists of the array @a@, the index @i@, and the new value +-- to set (in the case of a setter) @v@. + +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_i64, write_boff_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +write_boff_i64 a i h l = mconcat + [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] +write_boff_u64 a i h l = mconcat + [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + +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_i64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_i64 a i rh rl = mconcat + [ rh |= read_boff_i32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +read_boff_u64 :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +read_boff_u64 a i rh rl = mconcat + [ rh |= read_boff_u32 a (Add i (Int 4)) + , rl |= read_boff_u32 a i + ] + +fetchOpByteArray :: (JStgExpr -> JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +fetchOpByteArray op tgt src i v = mconcat + [ tgt |= read_i32 src i + , write_i32 src i (op tgt v) + ] + +fetchOpAddr :: (JStgExpr -> JStgExpr -> JStgExpr) -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +fetchOpAddr op tgt src i v = mconcat + [ tgt |= read_boff_u32 src i + , write_boff_u32 src i (op tgt v) + ] + +casOp + :: (JStgExpr -> JStgExpr -> JStgExpr) -- read + -> (JStgExpr -> JStgExpr -> JStgExpr -> JStgStat) -- write + -> JStgExpr -- target register to store result + -> JStgExpr -- source array + -> JStgExpr -- index + -> JStgExpr -- old value to compare + -> JStgExpr -- new value to write + -> JStgStat +casOp read write tgt src i old new = mconcat + [ tgt |= read src i + , ifS (tgt .===. old) + (write src i new) + mempty + ] + +casOp2 + :: (JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat) -- read + -> (JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat) -- write + -> (JStgExpr,JStgExpr) -- target registers to store result + -> JStgExpr -- source array + -> JStgExpr -- index + -> (JStgExpr,JStgExpr) -- old value to compare + -> (JStgExpr,JStgExpr) -- new value to write + -> JStgStat +casOp2 read write (tgt1,tgt2) src i (old1,old2) (new1,new2) = mconcat + [ read src i tgt1 tgt2 + , ifS ((tgt2 .===. old2) .&&. (tgt1 .===. old1)) + (write src i new1 new2) + mempty + ] + +-------------------------------------------------------------------------------- +-- Lifted Arrays +-------------------------------------------------------------------------------- +-- | lifted arrays +cloneArray :: Bool -> JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr -> JStgStat +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_ + ] + +newByteArray :: JStgExpr -> JStgExpr -> JStgStat +newByteArray tgt 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 +check_bound + :: JStgExpr -- ^ Max index expression + -> Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Index + -> JStgStat -- ^ Result + -> JStgStat +check_bound _ False _ r = r +check_bound max_index True i r = mconcat + [ jwhenS ((i .<. zero_) .||. (i .>=. max_index)) $ + returnS (app hdExitProcess [Int 134]) + , r + ] + +-- | Bounds checking using ".length" property (Arrays) +bnd_arr + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgStat -- ^ Result + -> JStgStat +bnd_arr do_check arr = check_bound (arr .^ lngth) do_check + +-- | Range bounds checking using ".length" property (Arrays) +-- +-- Empty ranges trivially pass the check +bnd_arr_range + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgExpr -- ^ Range size + -> JStgStat -- ^ Result + -> JStgStat +bnd_arr_range False _arr _i _n r = r +bnd_arr_range True arr i n r = + ifS (n .<. zero_) (returnS $ app hdExitProcess [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_arr True arr i $ bnd_arr True arr (Add i (Sub n one_)) r) + +-- | Bounds checking using ".len" property (ByteArrays) +bnd_ba + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgStat -- ^ Result + -> JStgStat +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 +bnd_ba8 = bnd_ba + +-- | ByteArray bounds checking (byte offset, 16-bit value) +bnd_ba16 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba16 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 1) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx one_) r + +-- | ByteArray bounds checking (byte offset, 32-bit value) +bnd_ba32 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba32 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 3) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx three_) r + +-- | ByteArray bounds checking (byte offset, 64-bit value) +bnd_ba64 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ba64 do_check arr idx r = + -- check that idx non incremented is in range: + -- (idx + 7) may be in range while idx isn't + bnd_ba do_check arr idx + $ bnd_ba do_check arr (Add idx (Int 7)) r + +-- | ByteArray bounds checking (8-bit offset, 8-bit value) +bnd_ix8 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix8 = bnd_ba8 + +-- | ByteArray bounds checking (16-bit offset, 16-bit value) +bnd_ix16 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix16 do_check arr idx r = bnd_ba16 do_check arr (idx .<<. one_) r + +-- | ByteArray bounds checking (32-bit offset, 32-bit value) +bnd_ix32 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix32 do_check arr idx r = bnd_ba32 do_check arr (idx .<<. two_) r + +-- | ByteArray bounds checking (64-bit offset, 64-bit value) +bnd_ix64 :: Bool -> JStgExpr -> JStgExpr -> JStgStat -> JStgStat +bnd_ix64 do_check arr idx r = bnd_ba64 do_check arr (idx .<<. three_) r + +-- | Bounds checking on a range and using ".len" property (ByteArrays) +-- +-- Empty ranges trivially pass the check +bnd_ba_range + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ Array + -> JStgExpr -- ^ Index + -> JStgExpr -- ^ Range size + -> JStgStat -- ^ Result + -> JStgStat +bnd_ba_range False _ _ _ r = r +bnd_ba_range True xs i n r = + ifS (n .<. zero_) (returnS $ app hdExitProcess [Int 134]) $ + -- Empty ranges trivially pass the check + ifS (n .===. zero_) + r + (bnd_ba True xs (Add i (Sub n one_)) (bnd_ba True xs i r)) + +checkOverlapByteArray + :: Bool -- ^ Should we do bounds checking? + -> JStgExpr -- ^ First array + -> JStgExpr -- ^ First offset + -> JStgExpr -- ^ Second array + -> JStgExpr -- ^ Second offset + -> JStgExpr -- ^ Range size + -> JStgStat -- ^ Result + -> JStgStat +checkOverlapByteArray False _ _ _ _ _ r = r +checkOverlapByteArray True a1 o1 a2 o2 n r = + ifS (app hdCheckOverlapByteArrayStr [a1, o1, a2, o2, n]) + r + (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 hdCopyMutableByteArrayStr [a1,o1,a2,o2,n] + where + check = bnd_ba_range bound a1 o1 n + . bnd_ba_range bound a2 o2 n + . (if not allow_overlap then checkOverlapByteArray bound a1 o1 a2 o2 n else id) + +-- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0 +-- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript. +-- So (x|0) * (y|0) can still return values outside of the Int32 range. You have +-- been warned! +toI32 :: JStgExpr -> JStgExpr +toI32 e = BOr e zero_ + +-- e>>>0 (32 bit unsigned integer truncation) +-- required because of JS numbers. e>>>0 converts e to a Word32 +-- so (-2147483648) >>> 0 = 2147483648 +-- and ((-2147483648) >>>0) | 0 = -2147483648 +toU32 :: JStgExpr -> JStgExpr +toU32 e = e .>>>. zero_ + +quotShortInt :: Int -> JStgExpr -> JStgExpr -> JStgExpr +quotShortInt bits x y = BAnd (signed x `Div` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = Int (32 - toInteger bits) + mask = Int (((2::Integer) ^ toInteger bits) - 1) + +remShortInt :: Int -> JStgExpr -> JStgExpr -> JStgExpr +remShortInt bits x y = BAnd (signed x `Mod` signed y) mask + where + signed z = (z .<<. shift) .>>. shift + shift = Int (32 - toInteger bits) + mask = Int (((2::Integer) ^ toInteger bits) - 1) diff --git a/GHC/StgToJS/Profiling.hs b/GHC/StgToJS/Profiling.hs --- a/GHC/StgToJS/Profiling.hs +++ b/GHC/StgToJS/Profiling.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module GHC.StgToJS.Profiling ( initCostCentres @@ -26,13 +27,16 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +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 @@ -44,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 () @@ -58,12 +89,13 @@ label = costCentreUserName cc modl = moduleNameString $ moduleName $ cc_mod cc loc = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc)) - js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CC") - [ toJExpr label - , toJExpr modl - , toJExpr loc - , toJExpr is_caf - ]) + js = JStg.DeclStat ccsLbl + (Just (JStg.UOpExpr JStg.NewOp (JStg.ApplExpr hdCC + [ toJExpr label + , toJExpr modl + , toJExpr loc + , toJExpr is_caf + ]))) emitGlobal js emitCostCentreStackDecl :: CostCentreStack -> G () @@ -72,43 +104,48 @@ Just cc -> do ccsLbl <- singletonCCSLbl cc ccLbl <- costCentreLbl cc - let js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CCS") [null_, toJExpr ccLbl]) + let js = + JStg.DeclStat ccsLbl + (Just (JStg.UOpExpr JStg.NewOp + (JStg.ApplExpr hdCCS [null_, toJExpr ccLbl]))) emitGlobal js Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) -------------------------------------------------------------------------------- -- Entering to cost-centres -enterCostCentreFun :: CostCentreStack -> JStat +enterCostCentreFun :: CostCentreStack -> JStg.JStgStat enterCostCentreFun ccs - | isCurrentCCS ccs = ApplStat (var "h$enterFunCCS") [jCurrentCCS, r1 .^ "cc"] + | isCurrentCCS ccs = JStg.ApplStat hdEnterFunCCS [jCurrentCCS, JStg.SelExpr r1 cc] | otherwise = mempty -- top-level function, nothing to do -enterCostCentreThunk :: JStat -enterCostCentreThunk = ApplStat (var "h$enterThunkCCS") [r1 .^ "cc"] +enterCostCentreThunk :: JStg.JStgStat +enterCostCentreThunk = JStg.ApplStat hdEnterThunkCCS [JStg.SelExpr r1 cc] -setCC :: CostCentre -> Bool -> Bool -> G JStat +setCC :: CostCentre -> Bool -> Bool -> G JStg.JStgStat setCC cc _tick True = do - ccI@(TxtI _ccLbl) <- costCentreLbl cc + ccI@(identFS -> _ccLbl) <- costCentreLbl cc addDependency $ OtherSymb (cc_mod cc) (moduleGlobalSymbol $ cc_mod cc) - return $ jCurrentCCS |= ApplExpr (var "h$pushCostCentre") [jCurrentCCS, toJExpr ccI] + return $ jCurrentCCS |= JStg.ApplExpr hdPushCostCentre [ jCurrentCCS + , JStg.Var ccI + ] setCC _cc _tick _push = return mempty -pushRestoreCCS :: JStat -pushRestoreCCS = ApplStat (var "h$pushRestoreCCS") [] +pushRestoreCCS :: JStg.JStgStat +pushRestoreCCS = JStg.ApplStat hdPushRestoreCCS [] -------------------------------------------------------------------------------- -- Some cost-centre stacks to be used in generator -jCurrentCCS :: JExpr -jCurrentCCS = var "h$currentThread" .^ "ccs" +jCurrentCCS :: JStg.JStgExpr +jCurrentCCS = JStg.SelExpr hdCurrentThread ccs -jCafCCS :: JExpr -jCafCCS = var "h$CAF" +jCafCCS :: JStg.JStgExpr +jCafCCS = JStg.global "h$CAF" -jSystemCCS :: JExpr -jSystemCCS = var "h$CCS_SYSTEM" +jSystemCCS :: JStg.JStgExpr +jSystemCCS = JStg.global "h$CCS_SYSTEM" -------------------------------------------------------------------------------- -- Helpers for generating profiling related things @@ -125,9 +162,10 @@ prof <- profiling if prof then m else return mempty --- | If profiling is enabled, then use input JStat, else ignore -profStat :: StgToJSConfig -> JStat -> JStat +-- | 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 @@ -140,7 +178,7 @@ moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl costCentreLbl :: CostCentre -> G Ident -costCentreLbl cc = TxtI . mkFastString <$> costCentreLbl' cc +costCentreLbl cc = name . mkFastString <$> costCentreLbl' cc costCentreStackLbl' :: CostCentreStack -> G (Maybe String) costCentreStackLbl' ccs = do @@ -154,7 +192,7 @@ Nothing -> pure Nothing costCentreStackLbl :: CostCentreStack -> G (Maybe Ident) -costCentreStackLbl ccs = fmap (TxtI . mkFastString) <$> costCentreStackLbl' ccs +costCentreStackLbl ccs = fmap (name . mkFastString) <$> costCentreStackLbl' ccs singletonCCSLbl' :: CostCentre -> G String singletonCCSLbl' cc = do @@ -168,11 +206,11 @@ ] singletonCCSLbl :: CostCentre -> G Ident -singletonCCSLbl cc = TxtI . mkFastString <$> singletonCCSLbl' cc +singletonCCSLbl cc = name . mkFastString <$> singletonCCSLbl' cc -ccsVarJ :: CostCentreStack -> G (Maybe JExpr) +ccsVarJ :: CostCentreStack -> G (Maybe JStg.JStgExpr) ccsVarJ ccs = do prof <- profiling if prof - then fmap (ValExpr . JVar) <$> costCentreStackLbl ccs + then fmap (JStg.ValExpr . JStg.JVar) <$> costCentreStackLbl ccs else pure Nothing diff --git a/GHC/StgToJS/Regs.hs b/GHC/StgToJS/Regs.hs --- a/GHC/StgToJS/Regs.hs +++ b/GHC/StgToJS/Regs.hs @@ -16,18 +16,27 @@ , jsReg , maxReg , minReg + , lowRegs + , retRegs + , register + , foreignRegister ) where import GHC.Prelude -import GHC.JS.Unsat.Syntax +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" -- @@ -65,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 @@ -78,13 +87,13 @@ -- helpers --------------------------------------------------- -sp :: JExpr +sp :: JStgExpr sp = toJExpr Sp -stack :: JExpr +stack :: JStgExpr stack = toJExpr Stack -r1, r2, r3, r4 :: JExpr +r1, r2, r3, r4 :: JStgExpr r1 = toJExpr R1 r2 = toJExpr R2 r3 = toJExpr R3 @@ -97,7 +106,7 @@ intToJSReg :: Int -> StgReg intToJSReg r = toEnum (r - 1) -jsReg :: Int -> JExpr +jsReg :: Int -> JStgExpr jsReg r = toJExpr (intToJSReg r) maxReg :: Int @@ -114,29 +123,43 @@ regsFromR2 :: [StgReg] regsFromR2 = tail regsFromR1 --- | List of registers, starting from R1 as JExpr -jsRegsFromR1 :: [JExpr] +-- | List of registers, starting from R1 as JStgExpr +jsRegsFromR1 :: [JStgExpr] jsRegsFromR1 = fmap toJExpr regsFromR1 -- | List of registers, starting from R2 as JExpr -jsRegsFromR2 :: [JExpr] +jsRegsFromR2 :: [JStgExpr] jsRegsFromR2 = tail jsRegsFromR1 --------------------------------------------------- -- 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 JExpr -registers = listArray (minBound, maxBound) (map regN regsFromR1) +registers :: Array StgReg JStgExpr +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 JExpr +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 +register i = registers ! i + +-- | Given a register, return the JS syntax object representing that register +foreignRegister :: StgRet -> JStgExpr +foreignRegister i = rets ! i diff --git a/GHC/StgToJS/Rts/Rts.hs b/GHC/StgToJS/Rts/Rts.hs --- a/GHC/StgToJS/Rts/Rts.hs +++ b/GHC/StgToJS/Rts/Rts.hs @@ -31,168 +31,192 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad import GHC.JS.Make -import GHC.JS.Transform -import GHC.JS.Optimizer -import qualified GHC.JS.Syntax as Sat +import GHC.JS.Ident import GHC.StgToJS.Apply import GHC.StgToJS.Closure 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 :: JStat -garbageCollector = - mconcat [ jFun (TxtI "h$resetRegisters") (mconcat $ map resetRegister [minBound..maxBound]) - , jFun (TxtI "h$resetResultVars") (mconcat $ map resetResultVar [minBound..maxBound]) - ] +garbageCollector :: JSM JStgStat +garbageCollector = jBlock + [ 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 -- register to a dummy variable called "null", /not/ by setting to JS's nil -- value. -resetRegister :: StgReg -> JStat +resetRegister :: StgReg -> JStgStat resetRegister r = toJExpr r |= null_ -- | Reset the return variable 'r' in JS Land. Note that this "resets" by -- setting the register to a dummy variable called "null", /not/ by setting to -- JS's nil value. -resetResultVar :: StgRet -> JStat +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. -closureConstructors :: StgToJSConfig -> JStat -closureConstructors s = BlockStat - [ mconcat (map mkClosureCon (Nothing : map Just [0..jsClosureCount])) - , mconcat (map mkDataFill [1..jsClosureCount]) - ] +-- | 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]) + fillers <- mapM mkDataFill [1..jsClosureCount] + return $ BlockStat $ closures ++ fillers + where prof = csProf s (ccArg,ccVal) -- the cc argument happens to be named just like the cc field... - | prof = ([TxtI 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 -- although it's possible (and legal) to make other Haskell types -- to contain JS refs directly -- this can cause false positives here - checkC :: JStat + checkC :: JSM JStgStat checkC | csAssertRts s = jVar $ \msg -> - jwhenS (var "arguments" .! 0 .!==. jString "h$baseZCGHCziJSziPrimziJSVal_con_e") - (loop 1 (.<. var "arguments" .^ "length") - (\i -> - 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]) - , postIncrS i - ]) - - ) - | otherwise = mempty + jwhenS (arguments .! 0 .!==. jString hdGhcInternalJSPrimValConEntryStr) + <$> + (loop 1 (.<. arguments .^ lngth) + (\i -> + return $ + mconcat [msg |= jString "warning: undefined or null in argument: " + + i + + jString " allocating closure: " + (arguments .! 0 .^ n) + , appS hdLogStr [msg] + , jwhenS (console .&&. (console .^ trace)) ((console .^ trace) `ApplStat` [msg]) + , postIncrS i + ])) + | otherwise = pure mempty -- 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_)) - (jVar $ \msg -> + 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 = mempty + | otherwise = pure mempty - mkClosureCon :: Maybe Int -> JStat - mkClosureCon n0 = jFunction funName args funBod + -- special case handler, the key difference is a call to @jFunction@ instead + -- of @jFunctionSized@ + singleton_closure_con nm = jFunction nm $ + \(MkSolo f) -> do + chk_c <- checkC + jVar $ \x -> + return $ mconcat $ + [ chk_c + , x |= newClosure (mkClosure f mempty 0 ccVal) + , notifyAlloc x + , traceAlloc x + , returnS x + ] + + mkClosureCon :: Maybe Int -> JSM JStgStat + -- the h$c special case + mkClosureCon Nothing = singleton_closure_con hdCStr + -- the h$c0 special case + 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 - n | Just n' <- n0 = n' - | Nothing <- n0 = 0 - funName | Just n' <- n0 = TxtI $ clsName n' - | Nothing <- n0 = TxtI $ mkFastString "h$c" - -- args are: f x1 x2 .. xn [cc] - args = TxtI "f" : addCCArg' (map varName [1..n]) - -- x1 goes into closureField1. All the other args are bundled into an - -- object in closureField2: { d1 = x2, d2 = x3, ... } - -- - vars = map (toJExpr . varName) [1..n] + funName = name $ clsName n - funBod = jVar $ \x -> - [ checkC - , x |= newClosure (mkClosure (var "f") vars 0 ccVal) + funBod [] = pure mempty -- impossible + funBod (f:vars') = do + let vars = addCCArg' vars' + chk_c <- checkC + jVar $ \x -> + return $ mconcat $ + [ chk_c + , x |= newClosure (mkClosure f vars 0 ccVal) , notifyAlloc x , traceAlloc x , returnS x ] - mkDataFill :: Int -> JStat - mkDataFill n = jFunction funName (map TxtI ds) body + mkDataFill :: Int -> JSM JStgStat + mkDataFill n = jFunctionSized funName n body where - funName = TxtI $ dataName n + funName = name $ dataName n ds = map dataFieldName [1..n] - extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - body = (checkD <> returnS extra_args) + extra_args as = ValExpr . JHash + . listToUniqMap + $ zip ds as + body :: [JStgExpr] -> JSM JStgStat + body ids = do + c <- checkD + return (c <> returnS (extra_args ids)) -- | JS Payload to perform stack manipulation in the RTS -stackManip :: JStat -stackManip = mconcat (map mkPush [1..32]) <> - mconcat (map mkPpush [1..255]) +stackManip :: JSM JStgStat +stackManip = do + pushes <- mapM mkPush [1..32] + ppushes <- mapM mkPpush [1..255] + return $ mconcat $ pushes ++ ppushes where - mkPush :: Int -> JStat - mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) - as = map varName [1..n] - body = ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) + mkPush :: Int -> JSM JStgStat + mkPush n = let funName = pushN ! n + body as = return $ + ((sp |= sp + toJExpr n) + <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= a) [1..] as)) - in jFunction funName as body + in jFunctionSized funName n body -- partial pushes, based on bitmap, increases Sp by highest bit - mkPpush :: Integer -> JStat - mkPpush sig | sig Bits..&. (sig+1) == 0 = mempty -- already handled by h$p - mkPpush sig = let funName = TxtI $ mkFastString ("h$pp" ++ show sig) + mkPpush :: Integer -> JSM JStgStat + mkPpush sig | sig Bits..&. (sig+1) == 0 = pure mempty -- already handled by h$p + mkPpush sig = let funName = pushNN ! sig bits = bitsIdx sig - n = length bits h = last bits - args = map varName [1..n] - body = mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in jFunction funName args body + body args = return $ + mconcat [ sp |= sp + toJExpr (h+1) + , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= a) bits args) + ] + in jFunctionSized funName (length bits) body bitsIdx :: Integer -> [Int] bitsIdx n | n < 0 = error "bitsIdx: negative" @@ -202,73 +226,66 @@ go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1) | otherwise = go (Bits.clearBit m b) (b+1) -bhLneStats :: StgToJSConfig -> JExpr -> JExpr -> JStat -bhLneStats _s p frameSize = - jVar $ \v -> - mconcat [ v |= stack .! p - , ifS v - ((sp |= sp - frameSize) - <> ifS (v .===. var "h$blackhole") - (returnS $ app "h$throw" [var "h$baseZCControlziExceptionziBasezinonTermination", false_]) - (mconcat [r1 |= v - , sp |= sp - frameSize - , returnStack - ])) - ((stack .! p |= var "h$blackhole") <> returnS null_) - ] +bhLneStats :: StgToJSConfig -> JStgExpr -> JStgExpr -> JSM JStgStat +bhLneStats _s p frameSize = jVar $ \v -> + return $ mconcat + [ v |= stack .! p + , ifS v + ((sp |= sp - frameSize) + <> ifS (v .===. hdBlackHole) + (returnS $ app hdThrowStr [hdInternalExceptionControlExceptionBaseNonTermination, false_]) + (mconcat [r1 |= v + , sp |= sp - frameSize + , returnStack + ])) + ((stack .! p |= hdBlackHole) <> returnS null_) + ] -- | JS payload to declare the registers -declRegs :: JStat -declRegs = - mconcat [ TxtI "h$regs" ||= toJExpr (JList []) - , mconcat (map declReg (enumFromTo R1 R32)) - , regGettersSetters - , loadRegs - ] +declRegs :: JSM JStgStat +declRegs = do + getters_setters <- regGettersSetters + loaders <- loadRegs + return $ + mconcat [ hdRegsStr ||= toJExpr (JList []) + , mconcat (map declReg lowRegs) + , getters_setters + , loaders + ] where - declReg r = (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) r - <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |] + declReg r = decl r <> BlockStat [toJExpr r |= zero_] -- | JS payload to define getters and setters on the registers. -regGettersSetters :: JStat +regGettersSetters :: JSM JStgStat regGettersSetters = - mconcat [ jFun (TxtI "h$getReg") (\n -> SwitchStat n getRegCases mempty) - , jFun (TxtI "h$setReg") (\n v -> 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 = map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1 + setRegCases :: JStgExpr -> [(JStgExpr,JStgStat)] setRegCases v = map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1 -- | JS payload that defines the functions to load each register -loadRegs :: JStat -loadRegs = mconcat $ map mkLoad [1..32] +loadRegs :: JSM JStgStat +loadRegs = mconcat <$> mapM mkLoad [1..32] where - mkLoad :: Int -> JStat - mkLoad n = let args = map varName [1..n] - body = mconcat $ - zipWith (\a r -> toJExpr r |= toJExpr a) + mkLoad :: Int -> JSM JStgStat + mkLoad n = let body = \args -> return $ mconcat $ + zipWith (\a r -> toJExpr r |= a) args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - in jFunction fname args body + 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 -> [JExpr] -> JStat -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; @@ -277,337 +294,387 @@ -- h$r1 = x4; -- }; -- @ -assignRegs' :: Array Int Ident -assignRegs' = listArray (1,32) (map (TxtI . 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 :: JStat -declRets = mconcat $ map (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1) +declRets :: JStgStat +declRets = mconcat $ map decl retRegs -- | JS payload defining the types closures. -closureTypes :: JStat -closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName +closureTypes :: JSM JStgStat +closureTypes = do + cls_typ_nm <- closureTypeName + return $ + mconcat (map mkClosureType (enumFromTo minBound maxBound)) + <> cls_typ_nm where - mkClosureType :: ClosureType -> JStat - mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE" + mkClosureType :: ClosureType -> JStgStat + mkClosureType c = let s = closureNames ! c in s ||= toJExpr c - closureTypeName :: JStat - closureTypeName = jFun (TxtI "h$closureTypeName") \c -> - mconcat (map (ifCT c) [minBound..maxBound]) - <> returnS (jString "InvalidClosureType") + closureTypeName :: JSM JStgStat + closureTypeName = jFunction hdClosureTypeNameStr + \(MkSolo c) -> return $ + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType") - ifCT :: JExpr -> ClosureType -> JStat + ifCT :: JStgExpr -> ClosureType -> JStgStat ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) -- | JS payload declaring the RTS functions. -rtsDecls :: JStat -rtsDecls = - mconcat [ TxtI "h$currentThread" ||= null_ -- thread state object for current thread - , TxtI "h$stack" ||= null_ -- stack for the current thread - , TxtI "h$sp" ||= 0 -- stack pointer for the current thread - , TxtI "h$initStatic" ||= toJExpr (JList []) -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs - , TxtI "h$staticThunks" ||= toJExpr (jhFromList []) -- funcName -> heapidx map for srefs - , TxtI "h$staticThunksArr" ||= toJExpr (JList []) -- indices of updatable thunks in static heap - , TxtI "h$CAFs" ||= toJExpr (JList []) - , TxtI "h$CAFsReset" ||= toJExpr (JList []) - -- stg registers - , declRegs - , declRets] +rtsDecls :: JSM JStgStat +rtsDecls = do + decl_stg_regs <- declRegs + return $ + 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 + ] -- | Generated RTS code -rts :: StgToJSConfig -> Sat.JStat -rts cfg = jsOptimize $ satJStat (Just "h$RTS") $ mconcat - [ rtsDecls - , rts' cfg - ] +rts :: StgToJSConfig -> JSM JStgStat +rts cfg = withTag "h$RTS" $ + do + rts_ <- rts_gen cfg + rts_decls <- rtsDecls + return $ rts_decls <> rts_ -- | JS Payload which defines the embedded RTS. -rts' :: StgToJSConfig -> JStat -rts' s = - mconcat [ closureConstructors s - , garbageCollector - , stackManip - , TxtI "h$rts_traceForeign" ||= toJExpr (csTraceForeign s) - , TxtI "h$rts_profiling" ||= toJExpr (csProf s) - , TxtI "h$ct_fun" ||= toJExpr Fun - , TxtI "h$ct_con" ||= toJExpr Con - , TxtI "h$ct_thunk" ||= toJExpr Thunk - , TxtI "h$ct_pap" ||= toJExpr Pap - , TxtI "h$ct_blackhole" ||= toJExpr Blackhole - , TxtI "h$ct_stackframe" ||= toJExpr StackFrame - , TxtI "h$vt_ptr" ||= toJExpr PtrV - , TxtI "h$vt_void" ||= toJExpr VoidV - , TxtI "h$vt_double" ||= toJExpr IntV - , TxtI "h$vt_long" ||= toJExpr LongV - , TxtI "h$vt_addr" ||= toJExpr AddrV - , TxtI "h$vt_obj" ||= toJExpr ObjV - , TxtI "h$vt_arr" ||= toJExpr ArrV - , jFun (TxtI "h$bh") (bhStats s True) - , jFun (TxtI "h$bh_lne") (\x frameSize -> bhLneStats s x frameSize) - , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty) - (appS "throw" [jString "oops: entered black hole"]) - , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty) - (appS "throw" [jString "oops: entered multiple times"]) - , closure (ClosureInfo (TxtI "h$done") (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty) - (appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule")) - , closure (ClosureInfo (TxtI "h$doneMain_e") (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty) - (returnS (var "h$doneMain")) - , conClosure (TxtI "h$false_e") "GHC.Types.False" (CILayoutFixed 0 []) 1 - , conClosure (TxtI "h$true_e" ) "GHC.Types.True" (CILayoutFixed 0 []) 2 - -- generic data constructor with 1 non-heapobj field - , conClosure (TxtI "h$data1_e") "data1" (CILayoutFixed 1 [ObjV]) 1 - -- generic data constructor with 2 non-heapobj fields - , conClosure (TxtI "h$data2_e") "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1 - , closure (ClosureInfo (TxtI "h$noop_e") (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty) - (returnS (stack .! sp)) - <> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s])) - , closure (ClosureInfo (TxtI "h$catch_e") (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty) - (adjSpN' 3 <> returnS (stack .! sp)) - , closure (ClosureInfo (TxtI "h$dataToTag_e") (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty) - $ 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 (TxtI "h$ap1_e") (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty) - (jVar $ \d1 d2 -> - mconcat [ d1 |= closureField1 r1 - , d2 |= closureField2 r1 - , appS "h$bh" [] - , profStat s enterCostCentreThunk - , r1 |= d1 - , r2 |= d2 - , returnS (app "h$ap_1_1_fast" []) - ]) - -- function application to two arguments - , closure (ClosureInfo (TxtI "h$ap2_e") (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty) - (jVar $ \d1 d2 d3 -> - mconcat [ d1 |= closureField1 r1 - , d2 |= closureField2 r1 .^ "d1" - , d3 |= closureField2 r1 .^ "d2" - , appS "h$bh" [] - , profStat s enterCostCentreThunk - , r1 |= d1 - , r2 |= d2 - , r3 |= d3 - , returnS (app "h$ap_2_2_fast" []) - ]) - -- function application to three arguments - , closure (ClosureInfo (TxtI "h$ap3_e") (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty) - (jVar $ \d1 d2 d3 d4 -> - mconcat [ d1 |= closureField1 r1 - , d2 |= closureField2 r1 .^ "d1" - , d3 |= closureField2 r1 .^ "d2" - , d4 |= closureField2 r1 .^ "d3" - , appS "h$bh" [] - , r1 |= d1 - , r2 |= d2 - , r3 |= d3 - , r4 |= d4 - , returnS (app "h$ap_3_3_fast" []) - ]) - -- select first field - , closure (ClosureInfo (TxtI "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty) - (jVar $ \t -> - 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_ - , r1 |= t - , returnS (app "h$ap_0_0_fast" []) - ]) - , closure (ClosureInfo (TxtI "h$select1_ret") (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty) - ((r1 |= closureField1 r1) - <> adjSpN' 1 - <> returnS (app "h$ap_0_0_fast" []) - ) - -- select second field of a two-field constructor - , closure (ClosureInfo (TxtI "h$select2_e") (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty) - (jVar $ \t -> +rts_gen :: StgToJSConfig -> JSM JStgStat +rts_gen s = do + 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 + stk_manip <- stackManip + rest <- impure + return $ mconcat $ pure gc <> decls <> [closure_cons, stk_manip] <> rest + where + impure = sequence + [ 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 hdData1Entry "data1" (CILayoutFixed 1 [ObjV]) 1 + -- generic data constructor with 2 non-heapobj fields + , 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 (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 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 hdAp1EntryStr (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty) + (jVars \(d1, d2) -> return $ + mconcat [ d1 |= closureField1 r1 + , d2 |= closureField2 r1 + , appS hdBhStr [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , returnS (app hdAp11Fast []) + ]) + -- function application to two arguments + , 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 .^ d1Str + , d3 |= closureField2 r1 .^ d2Str + , appS hdBhStr [] + , profStat s enterCostCentreThunk + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , returnS (app hdAp22FastStr []) + ]) + -- function application to three arguments + , 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 .^ d1Str + , d3 |= closureField2 r1 .^ d2Str + , d4 |= closureField2 r1 .^ d3Str + , appS hdBhStr [] + , r1 |= d1 + , r2 |= d2 + , r3 |= d3 + , r4 |= d4 + , returnS (app hdAp33FastStr []) + ]) + , closure (ClosureInfo hdUpdThunkEntryStr (CIRegs 0 [PtrV]) "updatable thunk" (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_ + , adjSp' 2 + , stack .! (sp - 1) |= r1 + , stack .! sp |= hdUpdFrame + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ , r1 |= t - , returnS (app "h$ap_0_0_fast" []) + , returnS (app hdAp00FastStr []) ] ) - , closure (ClosureInfo (TxtI "h$select2_ret") (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty) - $ mconcat [ r1 |= closureField2 r1 - , adjSpN' 1 - , returnS (app "h$ap_0_0_fast" []) + -- select first field + , 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) |= hdUpdFrame + , stack .! sp |= hdSelect1Ret + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app hdAp00FastStr []) + ]) + , closure (ClosureInfo hdSelect1RetStr (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (r1 |= closureField1 r1) + <> adjSpN' 1 + <> returnS (app hdAp00FastStr []) + ) + -- select second field of a two-field constructor + , 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) |= hdUpdFrame + , stack .! sp |= hdSelect2Return + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app hdAp00FastStr []) + ] + ) + , closure (ClosureInfo hdSelect2ReturnStr (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty) + $ return $ mconcat [ r1 |= closureField2 r1 + , adjSpN' 1 + , returnS (app hdAp00FastStr []) + ] + , 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 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 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 hdReduceStr (CIRegs 0 [PtrV]) (identFS hdReduceStr) (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + ifS (isThunk r1) + (returnS (r1 .^ "f")) + (adjSpN' 1 <> returnS (stack .! sp)) + ) + , rtsApply s + , closureTypes + , closure (ClosureInfo hdRunIOEntryStr (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty) + $ return $ mconcat [ r1 |= closureField1 r1 + , stack .! PreInc sp |= hdAp10 + , returnS hdAp10 + ] + , closure (ClosureInfo hdFlushStdoutEntryStr (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty) + $ return $ mconcat [ r1 |= hdGhcInternalIOHandleFlush + , r2 |= hdGhcInternalIOHandleFDStdout + , returnS (app hdAp11Fast []) ] - , closure (ClosureInfo (TxtI "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - (mconcat [ adjSpN' 2 + , pure $ hdFlushStdoutStr ||= app hdStaticThunkStr [hdFlushStdoutEntry] + -- the scheduler pushes this frame when suspending a thread that + -- has not called h$reschedule explicitly + , closure (ClosureInfo hdRestoreThreadStr (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty) + (jVars \(f,frameSize,nregs) -> + do set_regs <- loop 1 (.<=. nregs) + (\i -> return $ appS hdSetRegStr [i, stack .! (sp - 2 - i)] <> postIncrS i) + return $ mconcat [f |= stack .! (sp - 2) + , frameSize |= stack .! (sp - 1) + , nregs |= frameSize - 3 + , set_regs + , sp |= sp - frameSize + , returnS f + ]) + -- return a closure in the stack frame to the next thing on the stack + , 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 hdReturnFStr (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (jVar \r -> return $ + mconcat [ r |= stack .! (sp - 1) + , adjSpN' 2 + , returnS r + ]) + -- 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 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 hdDumpResStr (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty) + (jVar \re -> return $ + 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 hdLogStr [jString "function" + + ApplExpr (ApplExpr ((jString "" + r1 .^ f) .^ substring) [0, 50] .^ replace) [r1, jString "$1"]] + ] + , adjSpN' 2 + , r1 |= null_ , returnS (stack .! sp) - ] - ) - -- a thunk that just raises a synchronous exception - , closure (ClosureInfo (TxtI "h$raise_e") (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty) - (returnS (app "h$throw" [closureField1 r1, false_])) - , closure (ClosureInfo (TxtI "h$raiseAsync_e") (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty) - (returnS (app "h$throw" [closureField1 r1, true_])) - , closure (ClosureInfo (TxtI "h$raiseAsync_frame") (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty) - (jVar $ \ex -> - mconcat [ ex |= stack .! (sp - 1) - , adjSpN' 2 - , returnS (app "h$throw" [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 (TxtI "h$reduce") (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty) - (ifS (isThunk r1) - (returnS (r1 .^ "f")) - (adjSpN' 1 <> returnS (stack .! sp)) - ) - , rtsApply s - , closureTypes - , closure (ClosureInfo (TxtI "h$runio_e") (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty) - $ mconcat [ r1 |= closureField1 r1 - , stack .! PreInc sp |= var "h$ap_1_0" - , returnS (var "h$ap_1_0") - ] - , closure (ClosureInfo (TxtI "h$flushStdout_e") (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty) - $ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush" - , r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout" - , returnS (app "h$ap_1_1_fast" []) - ] - , TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"] - -- the scheduler pushes this frame when suspending a thread that - -- has not called h$reschedule explicitly - , closure (ClosureInfo (TxtI "h$restoreThread") (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty) - (jVar $ \f frameSize nregs -> - mconcat [f |= stack .! (sp - 2) - , frameSize |= stack .! (sp - 1) - , nregs |= frameSize - 3 - , loop 1 (.<=. nregs) - (\i -> appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i) - , sp |= sp - frameSize - , returnS f - ]) - -- return a closure in the stack frame to the next thing on the stack - , closure (ClosureInfo (TxtI "h$return") (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - ((r1 |= stack .! (sp - 1)) - <> adjSpN' 2 - <> returnS (stack .! sp)) - -- return a function in the stack frame for the next call - , closure (ClosureInfo (TxtI "h$returnf") (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) - (jVar $ \r -> - mconcat [ r |= stack .! (sp - 1) - , adjSpN' 2 - , returnS r - ]) - -- 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 (TxtI "h$reschedule") (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty) - (returnS $ var "h$reschedule") - -- debug thing, insert on stack to dump current result, should be boxed - , closure (ClosureInfo (TxtI "h$dumpRes") (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty) - (jVar $ \re -> - 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 - [ 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"]] - ] - , adjSpN' 2 - , r1 |= null_ - , returnS (stack .! sp) - ]) - , closure (ClosureInfo (TxtI "h$resume_e") (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty) - (jVar $ \ss -> - mconcat [ss |= closureField1 r1 - , updateThunk' s - , loop 0 (.<. ss .^ "length") (\i -> (stack .! (sp+1+i) |= ss .! i) - <> postIncrS i) - , sp |= sp + ss .^ "length" - , r1 |= null_ - , returnS (stack .! sp) - ]) - , closure (ClosureInfo (TxtI "h$unmaskFrame") (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty) - ((var "h$currentThread" .^ "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")) + ]) + , closure (ClosureInfo hdResumeEntryStr (CIRegs 0 [PtrV]) resume (CILayoutFixed 0 []) CIThunk mempty) + (jVar \ss -> + 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 .^ lngth + , r1 |= null_ + , returnS (stack .! sp) + ]) + , closure (ClosureInfo hdUnMaskFrameStr (CIRegs 0 [PtrV]) unMask (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 0) + <> adjSpN' 1 + -- back to scheduler to give us async exception if pending + <> ifS (hdCurrentThread .^ excepStr .^ lngth .>. 0) + (push' s [r1, hdReturn] <> returnS hdReschedule) (returnS (stack .! sp))) - , closure (ClosureInfo (TxtI "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty) - ((var "h$currentThread" .^ "mask" |= 2) + , closure (ClosureInfo hdMaskFrameStr (CIRegs 0 [PtrV]) mask (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 2) <> adjSpN' 1 <> returnS (stack .! sp)) - , closure (ClosureInfo (TxtI "h$maskUnintFrame") (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) - ((var "h$currentThread" .^ "mask" |= 1) + , closure (ClosureInfo hdMaskUnintFrameStr (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 1) <> adjSpN' 1 <> returnS (stack .! sp)) - , closure (ClosureInfo (TxtI "h$unboxFFIResult") (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty) - (jVar $ \d -> - mconcat [d |= closureField1 r1 - , loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i) - , adjSpN' 1 - , returnS (stack .! sp) - ]) - , closure (ClosureInfo (TxtI "h$unbox_e") (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty) - ((r1 |= closureField1 r1) <> returnS (stack .! sp)) - , closure (ClosureInfo (TxtI "h$retryInterrupted") (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) - (jVar $ \a -> - mconcat [ a |= stack .! (sp - 1) - , adjSpN' 2 - , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]]) - ]) - , closure (ClosureInfo (TxtI "h$atomically_e") (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - (ifS (app "h$stmValidateTransaction" []) - (appS "h$stmCommitTransaction" [] - <> adjSpN' 2 - <> returnS (stack .! sp)) - (returnS (app "h$stmStartTransaction" [stack .! (sp - 1)]))) + , 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 hdUnboxEntryStr (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty) + (return $ (r1 |= closureField1 r1) <> returnS (stack .! sp)) + , 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) [this, ApplExpr (a .^ slice) [1]]) + ]) + , 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 hdStmStartTransactionStr [stack .! (sp - 1)]))) - , closure (ClosureInfo (TxtI "h$stmCatchRetry_e") (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - (adjSpN' 2 - <> appS "h$stmCommitTransaction" [] - <> returnS (stack .! sp)) - , closure (ClosureInfo (TxtI "h$catchStm_e") (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty) - (adjSpN' 4 - <> appS "h$stmCommitTransaction" [] - <> returnS (stack .! sp)) - , closure (ClosureInfo (TxtI "h$stmResumeRetry_e") (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty) - (jVar $ \blocked -> - mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e") - (appS "throw" [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)]) - ]) - , closure (ClosureInfo (TxtI "h$lazy_e") (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty) - (jVar $ \x -> - mconcat [x |= ApplExpr (closureField1 r1) [] - , appS "h$bh" [] - , profStat s enterCostCentreThunk - , r1 |= x - , returnS (stack .! sp) - ]) - -- Top-level statements to generate only in profiling mode - , profStat s (closure (ClosureInfo (TxtI "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) - (appS "h$restoreCCS" [ stack .! (sp - 1)] - <> adjSpN' 2 - <> returnS (stack .! sp))) - ] + , closure (ClosureInfo hdStmCatchRetryEntryStr (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) + (return $ + adjSpN' 2 + <> appS hdStmCommitTransactionStr [] + <> returnS (stack .! sp)) + , closure (ClosureInfo hdStmCatchEntryStr (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty) + (return $ + adjSpN' 4 + <> appS hdStmCommitTransactionStr [] + <> returnS (stack .! sp)) + , closure (ClosureInfo hdStgResumeRetryEntryStr (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty) + (jVar \blocked -> + return $ + mconcat [ jwhenS (stack .! (sp - 2) .!==. hdAtomicallyEntry) + (appS throwStr [jString "h$stmResumeRetry_e: unexpected value on stack"]) + , blocked |= stack .! (sp - 1) + , adjSpN' 2 + , appS hdStmRemoveBlockedThreadStr [blocked, hdCurrentThread] + , returnS (app hdStmStartTransactionStr [stack .! (sp - 1)]) + ]) + , closure (ClosureInfo hdLazyEntryStr (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty) + (jVar \x -> + return $ + mconcat [x |= ApplExpr (closureField1 r1) [] + , appS hdBhStr [] + , profStat s enterCostCentreThunk + , r1 |= x + , returnS (stack .! sp) + ]) + , 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 hdSetCcsEntryStr (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty) + (return $ + appS hdRestoreCCSStr [ stack .! (sp - 1)] + <> adjSpN' 2 + <> returnS (stack .! sp))) + ] diff --git a/GHC/StgToJS/Rts/Types.hs b/GHC/StgToJS/Rts/Types.hs --- a/GHC/StgToJS/Rts/Types.hs +++ b/GHC/StgToJS/Rts/Types.hs @@ -22,57 +22,59 @@ import GHC.Prelude import GHC.JS.Make -import GHC.JS.Unsat.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 @JExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS --- program -traceRts :: StgToJSConfig -> JExpr -> JStat +-- | 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 --- | Syntactic sugar. Given a @JExpr@, 'ex' which is assumed to be a predicate, +-- | Syntactic sugar. Given a @JStgExpr@, 'ex' which is assumed to be a predicate, -- and a message 'm', assert that 'not ex' is True, if not throw an exception in -- JS land with message 'm'. -assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat +assertRts :: ToJExpr a => StgToJSConfig -> JStgExpr -> a -> JStgStat assertRts s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]) | otherwise = mempty -- | name of the closure 'c' -clName :: JExpr -> JExpr +clName :: JStgExpr -> JStgExpr clName c = c .^ "n" -- | Type name of the closure 'c' -clTypeName :: JExpr -> JExpr +clTypeName :: JStgExpr -> JStgExpr clTypeName c = app "h$closureTypeName" [c .^ "t"] -- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers) -stackFrameSize :: JExpr -- ^ assign frame size to this - -> JExpr -- ^ stack frame header function - -> JStat -- ^ size of the frame, including header +stackFrameSize :: JStgExpr -- ^ assign frame size to this + -> JStgExpr -- ^ stack frame header function + -> JSM JStgStat -- ^ size of the frame, including header stackFrameSize tgt f = - ifS (f .===. var "h$ap_gen") -- h$ap_gen is special - (tgt |= (stack .! (sp - 1) .>>. 8) + 2) - (jVar (\tag -> - mconcat - [tag |= f .^ "size" - , ifS (tag .<. 0) -- if tag is less than 0 - (tgt |= stack .! (sp - 1)) -- set target to stack pointer - 1 - (tgt |= mask8 tag + 1) -- else set to mask'd tag + 1 - ] - )) + jIf (f .===. hdApGen) -- h$ap_gen is special + (pure $ tgt |= (stack .! (sp - 1) .>>. 8) + 2) + (jVar (\tag -> + return $ mconcat + [tag |= f .^ "size" + , ifS (tag .<. 0) -- if tag is less than 0 + (tgt |= stack .! (sp - 1)) -- set target to stack pointer - 1 + (tgt |= mask8 tag + 1) -- else set to mask'd tag + 1 + ] + )) --------------------------------------------------------------------------------- + -------------------------------------------------------------------------------- -- Register utilities -------------------------------------------------------------------------------- -- | Perform the computation 'f', on the range of registers bounded by 'start' -- and 'end'. -withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat +withRegs :: StgReg -> StgReg -> (StgReg -> JStgStat) -> JStgStat withRegs start end f = mconcat $ fmap f [start..end] diff --git a/GHC/StgToJS/Sinker.hs b/GHC/StgToJS/Sinker.hs deleted file mode 100644 --- a/GHC/StgToJS/Sinker.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} - -module GHC.StgToJS.Sinker (sinkPgm) where - -import GHC.Prelude -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM -import GHC.Types.Var.Set -import GHC.Stg.Syntax -import GHC.Types.Id -import GHC.Types.Name -import GHC.Unit.Module -import GHC.Types.Literal -import GHC.Data.Graph.Directed - -import GHC.StgToJS.Utils - -import Data.Char -import Data.Either -import Data.List (partition) -import Data.Maybe - - --- | Unfloat some top-level unexported things --- --- GHC floats constants to the top level. This is fine in native code, but with JS --- they occupy some global variable name. We can unfloat some unexported things: --- --- - global constructors, as long as they're referenced only once by another global --- constructor and are not in a recursive binding group --- - literals (small literals may also be sunk if they are used more than once) -sinkPgm :: Module - -> [CgStgTopBinding] - -> (UniqFM Id CgStgExpr, [CgStgTopBinding]) -sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits) - where - selectLifted (StgTopLifted b) = Left b - selectLifted x = Right x - (pgm', stringLits) = partitionEithers (map selectLifted pgm) - (sunk, pgm'') = sinkPgm' m pgm' - -sinkPgm' - :: Module - -- ^ the module, since we treat definitions from the current module - -- differently - -> [CgStgBinding] - -- ^ the bindings - -> (UniqFM Id CgStgExpr, [CgStgBinding]) - -- ^ a map with sunken replacements for nodes, for where the replacement - -- does not fit in the 'StgBinding' AST and the new bindings -sinkPgm' m pgm = - let usedOnce = collectUsedOnce pgm - sinkables = listToUFM $ - concatMap alwaysSinkable pgm ++ - filter ((`elementOfUniqSet` usedOnce) . fst) (concatMap (onceSinkable m) pgm) - isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True - isSunkBind _ = False - in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm) - --- | always sinkable, values that may be duplicated in the generated code (e.g. --- small literals) -alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)] -alwaysSinkable (StgRec {}) = [] -alwaysSinkable (StgNonRec b rhs) = case rhs of - StgRhsClosure _ _ _ _ e@(StgLit l) _ - | isSmallSinkableLit l - , isLocal b - -> [(b,e)] - StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ - | isSmallSinkableLit l - , isLocal b - , isUnboxableCon dc - -> [(b,StgConApp dc cnum as [])] - _ -> [] - -isSmallSinkableLit :: Literal -> Bool -isSmallSinkableLit (LitChar c) = ord c < 100000 -isSmallSinkableLit (LitNumber _ i) = abs i < 100000 -isSmallSinkableLit _ = False - - --- | once sinkable: may be sunk, but duplication is not ok -onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)] -onceSinkable _m (StgNonRec b rhs) - | Just e <- getSinkable rhs - , isLocal b = [(b,e)] - where - getSinkable = \case - StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args []) - StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e - _ -> Nothing -onceSinkable _ _ = [] - --- | collect all idents used only once in an argument at the top level --- and never anywhere else -collectUsedOnce :: [CgStgBinding] -> IdSet -collectUsedOnce binds = intersectUniqSets (usedOnce args) (usedOnce top_args) - where - top_args = concatMap collectArgsTop binds - args = concatMap collectArgs binds - usedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet) - g i t@(once, mult) - | i `elementOfUniqSet` mult = t - | i `elementOfUniqSet` once - = (delOneFromUniqSet once i, addOneToUniqSet mult i) - | otherwise = (addOneToUniqSet once i, mult) - --- | fold over all id in StgArg used at the top level in an StgRhsCon -collectArgsTop :: CgStgBinding -> [Id] -collectArgsTop = \case - StgNonRec _b r -> collectArgsTopRhs r - StgRec bs -> concatMap (collectArgsTopRhs . snd) bs - -collectArgsTopRhs :: CgStgRhs -> [Id] -collectArgsTopRhs = \case - StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args - StgRhsClosure {} -> [] - --- | fold over all Id in StgArg in the AST -collectArgs :: CgStgBinding -> [Id] -collectArgs = \case - StgNonRec _b r -> collectArgsR r - StgRec bs -> concatMap (collectArgsR . snd) bs - -collectArgsR :: CgStgRhs -> [Id] -collectArgsR = \case - StgRhsClosure _x0 _x1 _x2 _x3 e _typ -> collectArgsE e - StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args - -collectArgsAlt :: CgStgAlt -> [Id] -collectArgsAlt alt = collectArgsE (alt_rhs alt) - -collectArgsE :: CgStgExpr -> [Id] -collectArgsE = \case - StgApp x args - -> x : concatMap collectArgsA args - StgConApp _con _mn args _ts - -> concatMap collectArgsA args - StgOpApp _x args _t - -> concatMap collectArgsA args - StgCase e _b _a alts - -> collectArgsE e ++ concatMap collectArgsAlt alts - StgLet _x b e - -> collectArgs b ++ collectArgsE e - StgLetNoEscape _x b e - -> collectArgs b ++ collectArgsE e - StgTick _i e - -> collectArgsE e - StgLit _ - -> [] - -collectArgsA :: StgArg -> [Id] -collectArgsA = \case - StgVarArg i -> [i] - StgLitArg _ -> [] - -isLocal :: Id -> Bool -isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i) - --- | since we have sequential initialization, topsort the non-recursive --- constructor bindings -topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding] -topSortDecls _m binds = rest ++ nr' - where - (nr, rest) = partition isNonRec binds - isNonRec StgNonRec{} = True - isNonRec _ = False - vs = map getV nr - keys = mkUniqSet (map node_key vs) - getV e@(StgNonRec b _) = DigraphNode e b [] - getV _ = error "topSortDecls: getV, unexpected binding" - collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) = - [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ] - collectDeps _ = [] - g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr) - nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g] - = error "topSortDecls: unexpected cycle" - | otherwise = map node_payload (topologicalSortG g) diff --git a/GHC/StgToJS/Sinker/Collect.hs b/GHC/StgToJS/Sinker/Collect.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker/Collect.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Sinker.Collect + ( collectArgsTop + , collectArgs + , selectUsedOnce + ) + where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Unique + +-- | fold over all id in StgArg used at the top level in an StgRhsCon +collectArgsTop :: CgStgBinding -> [Id] +collectArgsTop = \case + StgNonRec _b r -> collectArgsTopRhs r + StgRec bs -> concatMap (collectArgsTopRhs . snd) bs + where + collectArgsTopRhs :: CgStgRhs -> [Id] + collectArgsTopRhs = \case + StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args + StgRhsClosure {} -> [] + +-- | fold over all Id in StgArg in the AST +collectArgs :: CgStgBinding -> [Id] +collectArgs = \case + StgNonRec _b r -> collectArgsR r + StgRec bs -> concatMap (collectArgsR . snd) bs + where + collectArgsR :: CgStgRhs -> [Id] + collectArgsR = \case + StgRhsClosure _x0 _x1 _x2 _x3 e _typ -> collectArgsE e + StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args + + collectArgsAlt :: CgStgAlt -> [Id] + collectArgsAlt alt = collectArgsE (alt_rhs alt) + + collectArgsE :: CgStgExpr -> [Id] + collectArgsE = \case + StgApp x args + -> x : concatMap collectArgsA args + StgConApp _con _mn args _ts + -> concatMap collectArgsA args + StgOpApp _x args _t + -> concatMap collectArgsA args + StgCase e _b _a alts + -> collectArgsE e ++ concatMap collectArgsAlt alts + StgLet _x b e + -> collectArgs b ++ collectArgsE e + StgLetNoEscape _x b e + -> collectArgs b ++ collectArgsE e + StgTick _i e + -> collectArgsE e + StgLit _ + -> [] + +collectArgsA :: StgArg -> [Id] +collectArgsA = \case + StgVarArg i -> [i] + StgLitArg _ -> [] + +selectUsedOnce :: (Foldable t, Uniquable a) => t a -> UniqSet a +selectUsedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet) + where + g i t@(once, mult) + | i `elementOfUniqSet` mult = t + | i `elementOfUniqSet` once + = (delOneFromUniqSet once i, addOneToUniqSet mult i) + | otherwise = (addOneToUniqSet once i, mult) diff --git a/GHC/StgToJS/Sinker/Sinker.hs b/GHC/StgToJS/Sinker/Sinker.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker/Sinker.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Sinker.Sinker (sinkPgm) where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Types.Var.Set +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Types.Literal +import GHC.Data.Graph.Directed +import GHC.StgToJS.Sinker.Collect +import GHC.StgToJS.Sinker.StringsUnfloat + +import GHC.Utils.Misc (partitionWith) +import GHC.StgToJS.Utils + +import Data.Char +import Data.List (partition) +import Data.Maybe +import Data.ByteString (ByteString) + +-- | Unfloat some top-level unexported things +-- +-- GHC floats constants to the top level. This is fine in native code, but with JS +-- they occupy some global variable name. We can unfloat some unexported things: +-- +-- - global constructors, as long as they're referenced only once by another global +-- constructor and are not in a recursive binding group +-- - literals (small literals may also be sunk if they are used more than once) +sinkPgm :: Module + -> [CgStgTopBinding] + -> (UniqFM Id CgStgExpr, [CgStgTopBinding]) +sinkPgm m pgm + = (sunk, map StgTopLifted pgm''' ++ stringLits) + where + selectLifted :: CgStgTopBinding -> Either CgStgBinding (Id, ByteString) + selectLifted (StgTopLifted b) = Left b + selectLifted (StgTopStringLit i b) = Right (i, b) + + (pgm', allStringLits) = partitionWith selectLifted pgm + usedOnceIds = selectUsedOnce $ concatMap collectArgs pgm' + + stringLitsUFM = listToUFM $ (\(i, b) -> (idName i, (i, b))) <$> allStringLits + (pgm'', _actuallyUnfloatedStringLitNames) = + unfloatStringLits + (idName `mapUniqSet` usedOnceIds) + (snd `mapUFM` stringLitsUFM) + pgm' + + stringLits = uncurry StgTopStringLit <$> allStringLits + + (sunk, pgm''') = sinkPgm' m usedOnceIds pgm'' + +sinkPgm' + :: Module + -- ^ the module, since we treat definitions from the current module + -- differently + -> IdSet + -- ^ the set of used once ids + -> [CgStgBinding] + -- ^ the bindings + -> (UniqFM Id CgStgExpr, [CgStgBinding]) + -- ^ a map with sunken replacements for nodes, for where the replacement + -- does not fit in the 'StgBinding' AST and the new bindings +sinkPgm' m usedOnceIds pgm = + let usedOnce = collectTopLevelUsedOnce usedOnceIds pgm + sinkables = listToUFM $ + concatMap alwaysSinkable pgm ++ + concatMap (filter ((`elementOfUniqSet` usedOnce) . fst) . onceSinkable m) pgm + isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True + isSunkBind _ = False + in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm) + +-- | always sinkable, values that may be duplicated in the generated code (e.g. +-- small literals) +alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)] +alwaysSinkable (StgRec {}) = [] +alwaysSinkable (StgNonRec b rhs) = case rhs of + StgRhsClosure _ _ _ _ e@(StgLit l) _ + | isSmallSinkableLit l + , isLocal b + -> [(b,e)] + StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ + | isSmallSinkableLit l + , isLocal b + , isUnboxableCon dc + -> [(b,StgConApp dc cnum as [])] + _ -> [] + +isSmallSinkableLit :: Literal -> Bool +isSmallSinkableLit (LitChar c) = ord c < 100000 +isSmallSinkableLit (LitNumber _ i) = abs i < 100000 +isSmallSinkableLit _ = False + + +-- | once sinkable: may be sunk, but duplication is not ok +onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)] +onceSinkable _m (StgNonRec b rhs) + | Just e <- getSinkable rhs + , isLocal b = [(b,e)] + where + getSinkable = \case + StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args []) + StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e + _ -> Nothing +onceSinkable _ _ = [] + +-- | collect all idents used only once in an argument at the top level +-- and never anywhere else +collectTopLevelUsedOnce :: IdSet -> [CgStgBinding] -> IdSet +collectTopLevelUsedOnce usedOnceIds binds = intersectUniqSets usedOnceIds (selectUsedOnce top_args) + where + top_args = concatMap collectArgsTop binds + +isLocal :: Id -> Bool +isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i) + +-- | since we have sequential initialization, topsort the non-recursive +-- constructor bindings +topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding] +topSortDecls _m binds = rest ++ nr' + where + (nr, rest) = partition isNonRec binds + isNonRec StgNonRec{} = True + isNonRec _ = False + vs = map getV nr + keys = mkUniqSet (map node_key vs) + getV e@(StgNonRec b _) = DigraphNode e b [] + getV _ = error "topSortDecls: getV, unexpected binding" + collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) = + [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ] + collectDeps _ = [] + g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr) + nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g] + = error "topSortDecls: unexpected cycle" + | otherwise = map node_payload (topologicalSortG g) diff --git a/GHC/StgToJS/Sinker/StringsUnfloat.hs b/GHC/StgToJS/Sinker/StringsUnfloat.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker/StringsUnfloat.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.StgToJS.Sinker.StringsUnfloat + ( unfloatStringLits + ) + where + +import GHC.Prelude +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM +import GHC.Stg.Syntax +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Utils.Misc (partitionWith) + +import Data.ByteString qualified as BS +import Data.ByteString (ByteString) +import Data.Bifunctor (Bifunctor (..)) + +-- | We suppose that every string shorter than 80 symbols is safe for sink. +-- Sinker is working on per module. It means that ALL locally defined strings +-- in a module shorter 80 symbols will be unfloated back. +pattern STRING_LIT_MAX_LENGTH :: Int +pattern STRING_LIT_MAX_LENGTH = 80 + +unfloatStringLits + :: UniqSet Name + -> UniqFM Name ByteString + -> [CgStgBinding] + -> ([CgStgBinding], UniqSet Name) +unfloatStringLits usedOnceStringLits stringLits = + unfloatStringLits' (selectStringLitsForUnfloat usedOnceStringLits stringLits) + +-- | We are doing attempts to unfloat string literals back to +-- the call site. Further special JS optimizations +-- can generate more performant operations over them. +unfloatStringLits' :: UniqFM Name ByteString -> [CgStgBinding] -> ([CgStgBinding], UniqSet Name) +unfloatStringLits' stringLits allBindings = (binderWithoutChanges ++ binderWithUnfloatedStringLit, actuallyUsedStringLitNames) + where + (binderWithoutChanges, binderWithUnfloatedStringLitPairs) = partitionWith substituteStringLit allBindings + + binderWithUnfloatedStringLit = fst <$> binderWithUnfloatedStringLitPairs + actuallyUsedStringLitNames = unionManyUniqSets (snd <$> binderWithUnfloatedStringLitPairs) + + substituteStringLit :: CgStgBinding -> Either CgStgBinding (CgStgBinding, UniqSet Name) + substituteStringLit x@(StgRec bnds) + | isEmptyUniqSet names = Left x + | otherwise = Right (StgRec bnds', names) + where + (bnds', names) = extractNames id $ do + (i, rhs) <- bnds + pure $ case processStgRhs rhs of + Nothing -> Left (i, rhs) + Just (rhs', names) -> Right ((i, rhs'), names) + substituteStringLit x@(StgNonRec binder rhs) + = maybe (Left x) + (\(body', names) -> Right (StgNonRec binder body', names)) + (processStgRhs rhs) + + processStgRhs :: CgStgRhs -> Maybe (CgStgRhs, UniqSet Name) + processStgRhs (StgRhsCon ccs dataCon mu ticks args typ) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgRhsCon ccs dataCon mu ticks unified typ, names) + where + (unified, names) = substituteArgWithNames args + processStgRhs (StgRhsClosure fvs ccs upd bndrs body typ) + = (\(body', names) -> (StgRhsClosure fvs ccs upd bndrs body' typ, names)) <$> + processStgExpr body + + -- Recursive expressions + processStgExpr :: CgStgExpr -> Maybe (CgStgExpr, UniqSet Name) + processStgExpr (StgLit _) = Nothing + processStgExpr (StgTick _ _) = Nothing + processStgExpr (StgLet n b e) = + case (substituteStringLit b, processStgExpr e) of + (Left _, Nothing) -> Nothing + (Right (b', names), Nothing) -> Just (StgLet n b' e, names) + (Left _, Just (e', names)) -> Just (StgLet n b e', names) + (Right (b', names), Just (e', names')) -> Just (StgLet n b' e', names `unionUniqSets` names') + processStgExpr (StgLetNoEscape n b e) = + case (substituteStringLit b, processStgExpr e) of + (Left _, Nothing) -> Nothing + (Right (b', names), Nothing) -> Just (StgLetNoEscape n b' e, names) + (Left _, Just (e', names)) -> Just (StgLetNoEscape n b e', names) + (Right (b', names), Just (e', names')) -> Just (StgLetNoEscape n b' e', names `unionUniqSets` names') + -- We should keep the order: See Note [Case expression invariants] + processStgExpr (StgCase e bndr alt_type alts) = + case (isEmptyUniqSet names, processStgExpr e) of + (True, Nothing) -> Nothing + (True, Just (e', names')) -> Just (StgCase e' bndr alt_type alts, names') + (False, Nothing) -> Just (StgCase e bndr alt_type unified, names) + (False, Just (e', names')) -> Just (StgCase e' bndr alt_type unified, names `unionUniqSets` names') + where + (unified, names) = extractNames splitAlts alts + + splitAlts :: CgStgAlt -> Either CgStgAlt (CgStgAlt, UniqSet Name) + splitAlts alt@(GenStgAlt con bndrs rhs) = + case processStgExpr rhs of + Nothing -> Left alt + Just (alt', names) -> Right (GenStgAlt con bndrs alt', names) + + -- No args + processStgExpr (StgApp _ []) = Nothing + processStgExpr (StgConApp _ _ [] _) = Nothing + processStgExpr (StgOpApp _ [] _) = Nothing + + -- Main targets. Preserving the order of args is important + processStgExpr (StgApp fn args@(_:_)) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgApp fn unified, names) + where + (unified, names) = substituteArgWithNames args + processStgExpr (StgConApp dc n args@(_:_) tys) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgConApp dc n unified tys, names) + where + (unified, names) = substituteArgWithNames args + processStgExpr (StgOpApp op args@(_:_) tys) + | isEmptyUniqSet names = Nothing + | otherwise = Just (StgOpApp op unified tys, names) + where + (unified, names) = substituteArgWithNames args + + substituteArg :: StgArg -> Either StgArg (StgArg, Name) + substituteArg a@(StgLitArg _) = Left a + substituteArg a@(StgVarArg i) = + let name = idName i + in case lookupUFM stringLits name of + Nothing -> Left a + Just b -> Right (StgLitArg $ LitString b, name) + + substituteArgWithNames = extractNames (second (second unitUniqSet) . substituteArg) + + extractNames :: (a -> Either x (x, UniqSet Name)) -> [a] -> ([x], UniqSet Name) + extractNames splitter target = + let + splitted = splitter <$> target + combined = either (, emptyUniqSet) id <$> splitted + unified = fst <$> combined + names = unionManyUniqSets (snd <$> combined) + in (unified, names) + +selectStringLitsForUnfloat :: UniqSet Name -> UniqFM Name ByteString -> UniqFM Name ByteString +selectStringLitsForUnfloat usedOnceStringLits stringLits = alwaysUnfloat `plusUFM` usedOnceUnfloat + where + alwaysUnfloat = alwaysUnfloatStringLits stringLits + usedOnceUnfloat = selectUsedOnceStringLits usedOnceStringLits stringLits + + alwaysUnfloatStringLits :: UniqFM Name ByteString -> UniqFM Name ByteString + alwaysUnfloatStringLits = filterUFM $ \b -> BS.length b < STRING_LIT_MAX_LENGTH + + selectUsedOnceStringLits :: UniqSet Name -> UniqFM Name ByteString -> UniqFM Name ByteString + selectUsedOnceStringLits usedOnceStringLits stringLits = + stringLits `intersectUFM` getUniqSet usedOnceStringLits diff --git a/GHC/StgToJS/Stack.hs b/GHC/StgToJS/Stack.hs --- a/GHC/StgToJS/Stack.hs +++ b/GHC/StgToJS/Stack.hs @@ -66,15 +66,17 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax 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 @@ -147,13 +149,13 @@ dropSlots :: Int -> G () dropSlots n = modifySlots (drop n) -push :: [JExpr] -> G JStat +push :: [JStgExpr] -> G JStgStat push xs = do dropSlots (length xs) modifyStackDepth (+ (length xs)) flip push' xs <$> getSettings -push' :: StgToJSConfig -> [JExpr] -> JStat +push' :: StgToJSConfig -> [JStgExpr] -> JStgStat push' _ [] = mempty push' cs xs | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items @@ -163,24 +165,24 @@ offset i | i == l = sp | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) l = length xs - f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e) + f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) AssignOp (toJExpr e) -- | Grow the stack pointer by 'n' without modifying the stack depth. The stack -- is just a JS array so we add to grow (instead of the traditional subtract) -adjSp' :: Int -> JStat +adjSp' :: Int -> JStgStat adjSp' 0 = mempty adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n) -- | Shrink the stack pointer by 'n'. The stack grows downward so substract -adjSpN' :: Int -> JStat +adjSpN' :: Int -> JStgStat adjSpN' 0 = mempty adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n) -- | Wrapper which adjusts the stack pointer /and/ modifies the stack depth -- tracked in 'G'. See also 'adjSp'' which actually does the stack pointer -- manipulation. -adjSp :: Int -> G JStat +adjSp :: Int -> G JStgStat adjSp 0 = return mempty adjSp n = do -- grow depth by n @@ -190,7 +192,7 @@ -- | Shrink the stack and stack pointer. NB: This function is unsafe when the -- input 'n', is negative. This function wraps around 'adjSpN' which actually -- performs the work. -adjSpN :: Int -> G JStat +adjSpN :: Int -> G JStgStat adjSpN 0 = return mempty adjSpN n = do modifyStackDepth (\x -> x - n) @@ -212,13 +214,13 @@ -- -- and so on up to 32. pushN :: Array Int Ident -pushN = listArray (1,32) $ map (TxtI . 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 -- caught in 'GHC.StgToJS.Printer.prettyBlock'' to turn these into global -- functions. -pushN' :: Array Int JExpr +pushN' :: Array Int JStgExpr pushN' = fmap (ValExpr . JVar) pushN -- | Partial Push functions. Like 'pushN' except these push functions skip @@ -234,13 +236,13 @@ -- 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 (TxtI . 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 JExpr +pushNN' :: Array Integer JStgExpr pushNN' = fmap (ValExpr . JVar) pushNN -pushOptimized' :: [(Id,Int)] -> G JStat +pushOptimized' :: [(Id,Int)] -> G JStgStat pushOptimized' xs = do slots <- getSlots pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown)) @@ -255,8 +257,8 @@ -- | optimized push that reuses existing values on stack automatically chooses -- an optimized partial push (h$ppN) function when possible. -pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there - -> G JStat +pushOptimized :: [(JStgExpr,Bool)] -- ^ contents of the slots, True if same value is already there + -> G JStgStat pushOptimized [] = return mempty pushOptimized xs = do dropSlots l @@ -281,26 +283,26 @@ | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) -- | push a let-no-escape frame onto the stack -pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat +pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStgStat pushLneFrame size ctx = let ctx' = ctxLneShrinkStack ctx size in pushOptimized' (ctxLneFrameVars ctx') -- | Pop things, don't update the stack knowledge in 'G' popSkip :: Int -- ^ number of slots to skip - -> [JExpr] -- ^ assign stack slot values to these - -> JStat + -> [JStgExpr] -- ^ assign stack slot values to these + -> JStgStat popSkip 0 [] = mempty popSkip n [] = adjSpN' n popSkip n tgt = loadSkip n tgt <> adjSpN' (length tgt + n) --- | Load 'length (xs :: [JExpr])' things from the stack at offset 'n :: Int'. +-- | Load 'length (xs :: [JStgExpr])' things from the stack at offset 'n :: Int'. -- This function does no stack pointer manipulation, it merely indexes into the -- stack and loads payloads into 'xs'. -loadSkip :: Int -> [JExpr] -> JStat +loadSkip :: Int -> [JStgExpr] -> JStgStat loadSkip = loadSkipFrom sp where - loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat + loadSkipFrom :: JStgExpr -> Int -> [JStgExpr] -> JStgStat loadSkipFrom fr n xs = mconcat items where items = reverse $ zipWith f [(0::Int)..] (reverse xs) @@ -312,7 +314,7 @@ -- | Pop but preserve the first N slots -popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat +popSkipI :: Int -> [(Ident,StackSlot)] -> G JStgStat popSkipI 0 [] = pure mempty popSkipI n [] = popN n popSkipI n xs = do @@ -327,10 +329,10 @@ -- now load skipping first N slots return (loadSkipI n (map fst xs) <> a) --- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr' -loadSkipI :: Int -> [Ident] -> JStat +-- | Just like 'loadSkip' but operate on 'Ident's rather than 'JStgExpr' +loadSkipI :: Int -> [Ident] -> JStgStat loadSkipI = loadSkipIFrom sp - where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat + where loadSkipIFrom :: JStgExpr -> Int -> [Ident] -> JStgStat loadSkipIFrom fr n xs = mconcat items where items = reverse $ zipWith f [(0::Int)..] (reverse xs) @@ -339,21 +341,21 @@ f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n))) -- | Blindly pop N slots -popN :: Int -> G JStat +popN :: Int -> G JStgStat popN n = addUnknownSlots n >> adjSpN n -- | Generate statements to update the current node with a blackhole -bhStats :: StgToJSConfig -> Bool -> JStat +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 ] -- | Wrapper around 'updateThunk'', performs the stack manipulation before -- updating the Thunk. -updateThunk :: G JStat +updateThunk :: G JStgStat updateThunk = do settings <- getSettings -- update frame size @@ -361,13 +363,13 @@ 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 -- handler. -updateThunk' :: StgToJSConfig -> JStat +updateThunk' :: StgToJSConfig -> JStgStat updateThunk' settings = if csInlineBlackhole settings then bhStats settings True - else ApplStat (var "h$bh") [] + else ApplStat hdBh [] diff --git a/GHC/StgToJS/StaticPtr.hs b/GHC/StgToJS/StaticPtr.hs --- a/GHC/StgToJS/StaticPtr.hs +++ b/GHC/StgToJS/StaticPtr.hs @@ -10,19 +10,19 @@ import GHC.Fingerprint.Type import GHC.Types.Literal -import GHC.JS.Unsat.Syntax +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 JStat +initStaticPtrs :: [SptEntry] -> G JStgStat initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs where initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do i <- varForId sp_id fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2] - let sptInsert = ApplExpr (var "h$hs_spt_insert") (fpa ++ [i]) - return $ (var "h$initStatic" .^ "push") `ApplStat` [jLam sptInsert] - + let sptInsert = ApplStat hdHsSptInsert (fpa ++ [i]) + return $ (hdInitStatic .^ "push") `ApplStat` [Func [] sptInsert] diff --git a/GHC/StgToJS/Symbols.hs b/GHC/StgToJS/Symbols.hs --- a/GHC/StgToJS/Symbols.hs +++ b/GHC/StgToJS/Symbols.hs @@ -1,98 +1,1216 @@ - --- | 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 "_" - ] - -moduleExportsSymbol :: Module -> FastString -moduleExportsSymbol m = mkFastStringByteString $ mconcat - [ hd - , unitModuleStringZ m - , BSC.pack "_" - ] - --- | 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 +{-# LANGUAGE OverloadedStrings #-} + +-- | JS symbol generation +module GHC.StgToJS.Symbols where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.Ident + +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 + +import Data.Array +import Data.Semigroup ((<>)) + +-- | 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 + [ hdB + , unitModuleStringZ m + , BSC.pack "_" + ] + +moduleExportsSymbol :: Module -> FastString +moduleExportsSymbol m = mkFastStringByteString $ mconcat + [ hdB + , unitModuleStringZ m + , BSC.pack "_" + ] + +-- | 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 hdB else hddB + , 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 + [ hddB + , unitModuleStringZ mod + , BSC.pack "_" + , intBS i + ] + +-- | Make symbol "h$XYZ" or "h$$XYZ" +mkRawSymbol :: Bool -> FastString -> FastString +mkRawSymbol exported fs + | exported = mkFastStringByteString $ mconcat [ hdB, bytesFS fs ] + | otherwise = mkFastStringByteString $ mconcat [ hddB, bytesFS fs ] + +-- | "h$$" constant string +hddB :: ByteString +hddB = BSC.pack "h$$" + +-- | "h$" constant string +hdB :: ByteString +hdB = BSC.take 2 hddB + +hd :: JStgExpr +hd = global hdStr + +hdStr :: FastString +hdStr = mkFastStringByteString hdB + +hdlB :: ByteString +hdlB = BSC.pack "h$l" + +----------------------------------------- Runtime ------------------------------- +hdApply :: JStgExpr +hdApply = global hdApplyStr + +hdApplyStr :: FastString +hdApplyStr = fsLit "h$apply" + +hdMoveRegs2 :: FastString +hdMoveRegs2 = fsLit "h$moveRegs2" + +hdPapGen :: JStgExpr +hdPapGen = global hdPapGenStr + +hdPapGenStr :: FastString +hdPapGenStr = fsLit "h$pap_gen" + +hdSetReg :: JStgExpr +hdSetReg = global hdSetRegStr + +hdSetRegStr :: FastString +hdSetRegStr = fsLit "h$setReg" + +hdGetReg :: JStgExpr +hdGetReg = global hdGetRegStr + +hdGetRegStr :: FastString +hdGetRegStr = fsLit "h$getReg" + +hdResetRegisters :: Ident +hdResetRegisters = name "h$resetRegisters" + +hdResetResultVars :: Ident +hdResetResultVars = name "h$resetResultVars" + +hdInitClosure :: FastString +hdInitClosure = fsLit "h$init_closure" + +hdRegs :: JStgExpr +hdRegs = global (identFS hdRegsStr) + +hdRegsStr :: Ident +hdRegsStr = name "h$regs" + +hdReturn :: JStgExpr +hdReturn = global (identFS hdReturnStr) + +hdReturnStr :: Ident +hdReturnStr = name "h$return" + +hdStack :: JStgExpr +hdStack = global (identFS hdStackStr) + +hdStackStr :: Ident +hdStackStr = name "h$stack" + +hdStackPtr :: JStgExpr +hdStackPtr = global (identFS hdStackPtrStr) + +hdStackPtrStr :: Ident +hdStackPtrStr = name "h$sp" + +hdBlackHoleTrap :: JStgExpr +hdBlackHoleTrap = global (identFS hdBlackHoleTrapStr) + +hdBlackHoleTrapStr :: Ident +hdBlackHoleTrapStr = name "h$blackholeTrap" + +hdBlockOnBlackHoleStr :: FastString +hdBlockOnBlackHoleStr = "h$blockOnBlackhole" + +hdBlackHoleLNE :: JStgExpr +hdBlackHoleLNE = global (identFS hdBlackHoleLNEStr) + +hdBlackHoleLNEStr :: Ident +hdBlackHoleLNEStr = name "h$bh_lne" + +hdClosureTypeName :: JStgExpr +hdClosureTypeName = global (identFS hdClosureTypeNameStr) + +hdClosureTypeNameStr :: Ident +hdClosureTypeNameStr = name "h$closureTypeName" + +hdBh :: JStgExpr +hdBh = global hdBhStr + +hdBhStr :: FastString +hdBhStr = fsLit "h$bh" + +hdBlackHole :: JStgExpr +hdBlackHole = global (identFS hdBlackHoleStr) + +hdBlackHoleStr :: Ident +hdBlackHoleStr = name "h$blackhole" + +hdUpdFrame :: JStgExpr +hdUpdFrame = global (identFS hdUpdFrameStr) + +hdUpdFrameStr :: Ident +hdUpdFrameStr = name $ fsLit "h$upd_frame" + +hdCSel :: JStgExpr +hdCSel = global hdCSelStr + +hdCSelStr :: FastString +hdCSelStr = "h$c_sel_" + +hdEntry :: Ident +hdEntry = name hdEntryStr + +hdEntryStr :: FastString +hdEntryStr = fsLit "h$e" + +hdApGen :: JStgExpr +hdApGen = global (identFS hdApGenStr) + +hdApGenStr :: Ident +hdApGenStr = name "h$ap_gen" + +hdApGenFastStr :: Ident +hdApGenFastStr = name $ fsLit $ unpackFS (identFS hdApGenStr) ++ "_fast" + +hdLog :: JStgExpr +hdLog = global hdLogStr + +hdLogStr :: FastString +hdLogStr = fsLit "h$log" + +hdMkFunctionPtr :: JStgExpr +hdMkFunctionPtr = global "h$mkFunctionPtr" + +hdInitStatic :: JStgExpr +hdInitStatic = global (identFS hdInitStaticStr) + +hdInitStaticStr :: Ident +hdInitStaticStr = name "h$initStatic" + +hdHsSptInsert :: JStgExpr +hdHsSptInsert = global "h$hs_spt_insert" + +hdCurrentThread :: JStgExpr +hdCurrentThread = global (identFS hdCurrentThreadStr) + +hdCurrentThreadStr :: Ident +hdCurrentThreadStr = name "h$currentThread" + +hdWakeupThread :: FastString +hdWakeupThread = fsLit "h$wakeupThread" + +hdPaps :: JStgExpr +hdPaps = global hdPapsStr + +hdPapsStr :: FastString +hdPapsStr = fsLit "h$paps" + +hdPapStr_ :: FastString +hdPapStr_ = fsLit "h$pap_" + +hdLazyEntryStr :: Ident +hdLazyEntryStr = name "h$lazy_e" + +hdUnboxEntry :: JStgExpr +hdUnboxEntry = global (identFS hdUnboxEntryStr) + +hdUnboxEntryStr :: Ident +hdUnboxEntryStr = name "h$unbox_e" + +hdMaskFrame :: JStgExpr +hdMaskFrame = global (identFS hdMaskFrameStr) + +hdMaskFrameStr :: Ident +hdMaskFrameStr = name "h$maskFrame" + +hdUnMaskFrameStr :: Ident +hdUnMaskFrameStr = name "h$unmaskFrame" + +hdReturnF :: JStgExpr +hdReturnF = global (identFS hdReturnFStr) + +hdReturnFStr :: Ident +hdReturnFStr = name "h$returnf" + +hdResumeEntryStr :: Ident +hdResumeEntryStr = name "h$resume_e" + +hdFlushStdout :: JStgExpr +hdFlushStdout = global (identFS hdFlushStdoutStr) + +hdFlushStdoutStr :: Ident +hdFlushStdoutStr = name "h$flushStdout" + +hdFlushStdoutEntry :: JStgExpr +hdFlushStdoutEntry = global (identFS hdFlushStdoutEntryStr) + +hdFlushStdoutEntryStr :: Ident +hdFlushStdoutEntryStr = name "h$flushStdout_e" + +hdRunIOEntry :: JStgExpr +hdRunIOEntry = global (identFS hdRunIOEntryStr) + +hdRunIOEntryStr :: Ident +hdRunIOEntryStr = name "h$runio_e" + +hdReduce :: JStgExpr +hdReduce = global (identFS hdReduceStr) + +hdReduceStr :: Ident +hdReduceStr = name "h$reduce" + +hdThrowStr :: FastString +hdThrowStr = fsLit "h$throw" + +hdRaiseAsyncFrame :: JStgExpr +hdRaiseAsyncFrame = global (identFS hdRaiseAsyncFrameStr) + +hdRaiseAsyncFrameStr :: Ident +hdRaiseAsyncFrameStr = name "h$raiseAsync_frame" + +hdRaiseAsyncEntry :: JStgExpr +hdRaiseAsyncEntry = global (identFS hdRaiseAsyncEntryStr) + +hdRaiseAsyncEntryStr :: Ident +hdRaiseAsyncEntryStr = name "h$raiseAsync_e" + +hdRaiseEntry :: JStgExpr +hdRaiseEntry = global (identFS hdRaiseEntryStr) + +hdRaiseEntryStr :: Ident +hdRaiseEntryStr = name "h$raise_e" + +hdKeepAliveEntry :: JStgExpr +hdKeepAliveEntry = global (identFS hdKeepAliveEntryStr) + +hdKeepAliveEntryStr :: Ident +hdKeepAliveEntryStr = name "h$keepAlive_e" + +hdSelect2Return :: JStgExpr +hdSelect2Return = global (identFS hdSelect2ReturnStr) + +hdSelect2ReturnStr :: Ident +hdSelect2ReturnStr = name "h$select2_ret" + +hdSelect2Entry :: JStgExpr +hdSelect2Entry = global (identFS hdSelect2EntryStr) + +hdSelect2EntryStr :: Ident +hdSelect2EntryStr = name "h$select2_e" + +hdSelect1Ret :: JStgExpr +hdSelect1Ret = global (identFS hdSelect1RetStr) + +hdSelect1RetStr :: Ident +hdSelect1RetStr = name "h$select1_ret" + +hdSelect1EntryStr :: Ident +hdSelect1EntryStr = name "h$select1_e" + +hdStaticThunkStr :: FastString +hdStaticThunkStr = fsLit "h$static_thunk" + +hdStaticThunksStr + , hdStaticThunksArrStr + , hdCAFsStr + , hdCAFsResetStr :: Ident +hdStaticThunksStr = name "h$staticThunks" +hdStaticThunksArrStr = name "h$staticThunksArr" +hdCAFsStr = name "h$CAFs" +hdCAFsResetStr = name "h$CAFsReset" + +hdUpdThunkEntryStr :: Ident +hdUpdThunkEntryStr = name "h$upd_thunk_e" + +hdAp3EntryStr :: Ident +hdAp3EntryStr = name "h$ap3_e" + +hdAp2EntryStr :: Ident +hdAp2EntryStr = name "h$ap2_e" + +hdAp1EntryStr :: Ident +hdAp1EntryStr = name "h$ap1_e" + +hdDataToTagEntryStr :: Ident +hdDataToTagEntryStr = name "h$dataToTag_e" + +hdTagToEnum :: FastString +hdTagToEnum = fsLit "h$tagToEnum" + +hdCatchEntryStr :: Ident +hdCatchEntryStr = name "h$catch_e" + +hdNoopStr :: Ident +hdNoopStr = name "h$noop" + +hdNoopEntry :: JStgExpr +hdNoopEntry = global (identFS hdNoopEntryStr) + +hdNoopEntryStr :: Ident +hdNoopEntryStr = name "h$noop_e" + +hdC0 :: JStgExpr +hdC0 = global (identFS hdC0Str) + +hdC :: JStgExpr +hdC = global (identFS hdCStr) + +hdC0Str :: Ident +hdC0Str = name "h$c0" + +hdCStr :: Ident +hdCStr = name "h$c" + +hdData2Entry :: Ident +hdData2Entry = name "h$data2_e" + +hdData1Entry :: Ident +hdData1Entry = name "h$data1_e" + +hdTrueEntry :: Ident +hdTrueEntry = name "h$true_e" + +hdFalseEntry :: Ident +hdFalseEntry = name "h$false_e" + +hdDoneMainEntry :: JStgExpr +hdDoneMainEntry = global (identFS hdDoneMainEntryStr) + +hdDoneMainEntryStr :: Ident +hdDoneMainEntryStr = name "h$doneMain_e" + +hdDoneMain :: JStgExpr +hdDoneMain = global "h$doneMain" + +hdDone :: Ident +hdDone = name "h$done" + +hdExitProcess :: FastString +hdExitProcess = "h$exitProcess" + +hdTraceAlloc :: FastString +hdTraceAlloc = fsLit "h$traceAlloc" + +hdDebugAllocNotifyAlloc :: FastString +hdDebugAllocNotifyAlloc = fsLit "h$debugAlloc_notifyAlloc" + +hdRtsTraceForeign + , hdRtsProfiling + , hdCtFun + , hdCtCon + , hdCtThunk + , hdCtPap + , hdCtBlackhole + , hdCtStackFrame + , hdCtVtPtr + , hdVtVoid + , hdVtInt + , hdVtDouble + , hdVtLong + , hdVtAddr + , hdVtObj + , hdVtArr :: Ident +hdRtsTraceForeign = name "h$rts_traceForeign" +hdRtsProfiling = name "h$rts_profiling" +hdCtFun = name "h$ct_fun" +hdCtCon = name "h$ct_con" +hdCtThunk = name "h$ct_thunk" +hdCtPap = name "h$ct_pap" +hdCtBlackhole = name "h$ct_blackhole" +hdCtStackFrame = name "h$ct_stackframe" +hdCtVtPtr = name "h$vt_ptr" +hdVtVoid = name "h$vt_void" +hdVtInt = name "h$vt_int" +hdVtDouble = name "h$vt_double" +hdVtLong = name "h$vt_long" +hdVtAddr = name "h$vt_addr" +hdVtObj = name "h$vt_obj" +hdVtArr = name "h$vt_arr" + + +hdLoads :: Array Int Ident +hdLoads = listArray (1,32) [ name . mkFastStringByteString $ hdlB <> BSC.pack (show n) + | n <- [1..32::Int] + ] + +----------------------------------------- Precompiled Aps ---------------------- +hdAp00 :: JStgExpr +hdAp00 = global (identFS hdAp00Str) + +hdAp00Str :: Ident +hdAp00Str = name "h$ap_0_0" + +hdAp00FastStr :: FastString +hdAp00FastStr = fsLit "h$ap_0_0_fast" + +hdAp11Fast :: FastString +hdAp11Fast = fsLit "h$ap_1_1_fast" + +hdAp10 :: JStgExpr +hdAp10 = global "h$ap_1_0" + +hdAp33FastStr :: FastString +hdAp33FastStr = fsLit "h$ap_3_3_fast" + +hdAp22FastStr :: FastString +hdAp22FastStr = fsLit "h$ap_2_2_fast" + +----------------------------------------- ByteArray ----------------------------- +hdNewByteArrayStr :: FastString +hdNewByteArrayStr = "h$newByteArray" + +hdCopyMutableByteArrayStr :: FastString +hdCopyMutableByteArrayStr = "h$copyMutableByteArray" + +hdCheckOverlapByteArrayStr :: FastString +hdCheckOverlapByteArrayStr = "h$checkOverlapByteArray" + +hdShrinkMutableCharArrayStr :: FastString +hdShrinkMutableCharArrayStr = "h$shrinkMutableCharArray" + +----------------------------------------- EventLog ----------------------------- +hdTraceEventStr :: FastString +hdTraceEventStr = "h$traceEvent" + +hdTraceEventBinaryStr :: FastString +hdTraceEventBinaryStr = "h$traceEventBinary" + +hdTraceMarkerStr :: FastString +hdTraceMarkerStr = "h$traceMarker" + +----------------------------------------- FFI ---------------------------------- +hdThrowJSException :: JStgExpr +hdThrowJSException = global $ fsLit "h$throwJSException" + +hdUnboxFFIResult :: JStgExpr +hdUnboxFFIResult = global (identFS hdUnboxFFIResultStr) + +hdUnboxFFIResultStr :: Ident +hdUnboxFFIResultStr = name "h$unboxFFIResult" + +hdMkForeignCallback :: JStgExpr +hdMkForeignCallback = global $ fsLit "h$mkForeignCallback" + +hdTraceForeign :: JStgExpr +hdTraceForeign = global $ fsLit "h$traceForeign" + +hdBuildObject :: JStgExpr +hdBuildObject = global hdBuildObjectStr + +hdBuildObjectStr :: FastString +hdBuildObjectStr = fsLit "h$buildObject" + +hdCallDynamicStr :: FastString +hdCallDynamicStr = fsLit "h$callDynamic" + +except :: JStgExpr +except = global $ identFS exceptStr + +exceptStr :: Ident +exceptStr = name $ fsLit "except" + +excepStr :: FastString +excepStr = fsLit "excep" + +----------------------------------------- Accessors ----------------------------- + +-- for almost all other symbols that are faststrings we turn 'foo' into 'fooStr' +-- because these are overloaded with JStgExpr's. But for accessors we leave +-- these as FastStrings because they will become Idents after the refactor. +mv :: FastString +mv = fsLit "mv" + +lngth :: FastString +lngth = fsLit "length" + +-- | only for byte arrays. This is a JS byte array method +len :: FastString +len = fsLit "len" + +slice :: FastString +slice = fsLit "slice" + +this :: JStgExpr +this = global "this" + +arr :: FastString +arr = fsLit "arr" + +dv :: FastString +dv = fsLit "dv" + +d1, d2, d3 :: JStgExpr +d1 = global d1Str +d2 = global d2Str +d3 = global d3Str + +d1Str, d2Str, d3Str :: FastString +d1Str = fsLit "d1" +d2Str = fsLit "d2" +d3Str = fsLit "d3" + +getInt16 :: FastString +getInt16 = "getInt16" + +getUint16 :: FastString +getUint16 = "getUint16" + +getInt32 :: FastString +getInt32 = "getInt32" + +getUint32 :: FastString +getUint32 = "getUint32" + +getFloat32 :: FastString +getFloat32 = "getFloat32" + +getFloat64 :: FastString +getFloat64 = "getFloat64" + +setInt16 :: FastString +setInt16 = "setInt16" + +setUint16 :: FastString +setUint16 = "setUint16" + +setInt32 :: FastString +setInt32 = "setInt32" + +setUint32 :: FastString +setUint32 = "setUint32" + +setFloat32 :: FastString +setFloat32 = "setFloat32" + +setFloat64 :: FastString +setFloat64 = "setFloat64" + +i3, u8, u1, f6, f3 :: FastString +i3 = "i3" +u8 = "u8" +u1 = "u1" +f6 = "f6" +f3 = "f3" + +val :: FastString +val = fsLit "val" + +label :: FastString +label = fsLit "label" + +mask :: FastString +mask = fsLit "mask" + +unMask :: FastString +unMask = fsLit "unmask" + +resume :: FastString +resume = "resume" + +f :: FastString +f = fsLit "f" + +n :: FastString +n = fsLit "n" + +hasOwnProperty :: FastString +hasOwnProperty = fsLit "hasOwnProperty" + +hdCollectProps :: FastString +hdCollectProps = fsLit "h$collectProps" + +replace :: FastString +replace = fsLit "replace" + +substring :: FastString +substring = fsLit "substring" + +trace :: FastString +trace = fsLit "trace" + +apply :: FastString +apply = fsLit "apply" + +----------------------------------------- STM ---------------------------------- +hdMVar :: JStgExpr +hdMVar = global hdMVarStr + +hdMVarStr :: FastString +hdMVarStr = fsLit "h$MVar" + +hdTakeMVar :: JStgExpr +hdTakeMVar = global hdTakeMVarStr + +hdTakeMVarStr :: FastString +hdTakeMVarStr = fsLit "h$takeMVar" + +hdTryTakeMVarStr :: FastString +hdTryTakeMVarStr = fsLit "h$tryTakeMVar" + +hdPutMVarStr :: FastString +hdPutMVarStr = fsLit "h$putMVar" + +hdTryPutMVarStr :: FastString +hdTryPutMVarStr = fsLit "h$tryPutMVar" + +hdNewTVar :: FastString +hdNewTVar = fsLit "h$newTVar" + +hdReadTVar :: FastString +hdReadTVar = fsLit "h$readTVar" + +hdReadTVarIO :: FastString +hdReadTVarIO = fsLit "h$readTVarIO" + +hdWriteTVar :: FastString +hdWriteTVar = fsLit "h$writeTVar" + +hdReadMVarStr :: FastString +hdReadMVarStr = fsLit "h$readMVar" + +hdStmRemoveBlockedThreadStr :: FastString +hdStmRemoveBlockedThreadStr = fsLit "h$stmRemoveBlockedThread" + +hdStmStartTransactionStr :: FastString +hdStmStartTransactionStr = fsLit "h$stmStartTransaction" + +hdAtomicallyEntry :: JStgExpr +hdAtomicallyEntry = global (identFS hdAtomicallyEntryStr) + +hdAtomicallyEntryStr :: Ident +hdAtomicallyEntryStr = name $ fsLit "h$atomically_e" + +hdAtomicallyStr :: FastString +hdAtomicallyStr = "h$atomically" + +hdStgResumeRetryEntry :: JStgExpr +hdStgResumeRetryEntry = global (identFS hdStgResumeRetryEntryStr) + +hdStgResumeRetryEntryStr :: Ident +hdStgResumeRetryEntryStr = name $ fsLit "h$stmResumeRetry_e" + +hdStmCommitTransactionStr :: FastString +hdStmCommitTransactionStr = fsLit "h$stmCommitTransaction" + +hdStmValidateTransactionStr :: FastString +hdStmValidateTransactionStr = "h$stmValidateTransaction" + +hdStmCatchRetryEntry :: JStgExpr +hdStmCatchRetryEntry = global (identFS hdStmCatchRetryEntryStr) + +hdStmCatchRetryEntryStr :: Ident +hdStmCatchRetryEntryStr = name $ fsLit "h$stmCatchRetry_e" + +hdStmRetryStr :: FastString +hdStmRetryStr = fsLit "h$stmRetry" + +hdStmCatchRetryStr :: FastString +hdStmCatchRetryStr = fsLit "h$stmCatchRetry" + +hdStmCatchEntry :: JStgExpr +hdStmCatchEntry = global (identFS hdStmCatchEntryStr) + +hdCatchStmStr :: FastString +hdCatchStmStr = fsLit "h$catchStm" + +hdStmCatchEntryStr :: Ident +hdStmCatchEntryStr = name $ fsLit "h$catchStm_e" + +hdRetryInterrupted :: JStgExpr +hdRetryInterrupted = global (identFS hdRetryInterruptedStr) + +hdRetryInterruptedStr :: Ident +hdRetryInterruptedStr = name $ fsLit "h$retryInterrupted" + +hdMaskUnintFrame :: JStgExpr +hdMaskUnintFrame = global (identFS hdMaskUnintFrameStr) + +hdMaskUnintFrameStr :: Ident +hdMaskUnintFrameStr = name $ fsLit "h$maskUnintFrame" + +hdReschedule :: JStgExpr +hdReschedule = global (identFS hdRescheduleStr) + +hdRescheduleStr :: Ident +hdRescheduleStr = name $ fsLit "h$reschedule" + +hdRestoreThread :: JStgExpr +hdRestoreThread = global (identFS hdRestoreThreadStr) + +hdRestoreThreadStr :: Ident +hdRestoreThreadStr = name $ fsLit "h$restoreThread" + +hdFinishedThread :: FastString +hdFinishedThread = fsLit "h$finishThread" + +----------------------------------------- Z-Encodings --------------------------- +hdPrimOpStr :: FastString +hdPrimOpStr = fsLit "h$primop_" + +wrapperColonStr :: FastString +wrapperColonStr = fsLit "ghczuwrapperZC" -- equivalent non-z-encoding => ghc_wrapper: + +hdInternalExceptionTypeDivZero :: JStgExpr +hdInternalExceptionTypeDivZero = global "h$ghczminternalZCGHCziInternalziExceptionziTypezidivZZeroException" + +hdInternalExceptionTypeOverflow :: JStgExpr +hdInternalExceptionTypeOverflow = global "h$ghczminternalZCGHCziInternalziExceptionziTypezioverflowException" + +hdInternalExceptionTypeUnderflow :: JStgExpr +hdInternalExceptionTypeUnderflow = global "h$ghczminternalZCGHCziInternalziExceptionziTypeziunderflowException" + +hdInternalExceptionControlExceptionBaseNonTermination :: JStgExpr +hdInternalExceptionControlExceptionBaseNonTermination = global "h$ghczminternalZCGHCziInternalziControlziExceptionziBasezinonTermination" + +hdGhcInternalIOHandleFlush :: JStgExpr +hdGhcInternalIOHandleFlush = global "h$ghczminternalZCGHCziInternalziIOziHandlezihFlush" + +hdGhcInternalIOHandleFDStdout :: JStgExpr +hdGhcInternalIOHandleFDStdout = global "h$ghczminternalZCGHCziInternalziIOziHandleziFDzistdout" + +hdGhcInternalJSPrimValConEntryStr :: FastString +hdGhcInternalJSPrimValConEntryStr = fsLit "h$ghczminternalZCGHCziInternalziJSziPrimziJSVal_con_e" + +----------------------------------------- Profiling ----------------------------- +hdBuildCCSPtrStr :: FastString +hdBuildCCSPtrStr = "h$buildCCSPtr" + +hdClearCCSStr :: FastString +hdClearCCSStr = "h$clearCCS" + +hdRestoreCCSStr :: FastString +hdRestoreCCSStr = fsLit "h$restoreCCS" + +hdSetCcsEntry :: JStgExpr +hdSetCcsEntry = global (identFS hdSetCcsEntryStr) + +hdSetCcsEntryStr :: Ident +hdSetCcsEntryStr = name $ fsLit "h$setCcs_e" + +ccStr :: FastString +ccStr = fsLit "cc" +----------------------------------------- Others ------------------------------- +unknown :: FastString +unknown = fsLit "" + +typeof :: FastString +typeof = fsLit "typeof" + +throwStr :: FastString +throwStr = fsLit "throw" + +hdCheckObj :: JStgExpr +hdCheckObj = global $ fsLit "h$checkObj" + +console :: JStgExpr +console = global consoleStr + +consoleStr :: FastString +consoleStr = fsLit "console" + +arguments :: JStgExpr +arguments = global argumentsStr + +argumentsStr :: FastString +argumentsStr = fsLit "arguments" + +hdReportHeapOverflow :: JStgExpr +hdReportHeapOverflow = global (identFS hdReportHeapOverflowStr) + +hdReportHeapOverflowStr :: Ident +hdReportHeapOverflowStr = name $ fsLit "h$reportHeapOverflow" + +hdReportStackOverflow :: JStgExpr +hdReportStackOverflow = global (identFS hdReportStackOverflowStr) + +hdReportStackOverflowStr :: Ident +hdReportStackOverflowStr = name $ fsLit "h$reportStackOverflow" + +hdDumpRes :: JStgExpr +hdDumpRes = global (identFS hdDumpResStr) + +hdDumpResStr :: Ident +hdDumpResStr = name $ fsLit "h$dumpRes" + +ghcjsArray :: FastString +ghcjsArray = fsLit "__ghcjsArray" + +----------------------------------------- Compact ------------------------------- + +hdCompactSize :: FastString +hdCompactSize = fsLit "h$compactSize" + +hdCompactAddWithSharing :: FastString +hdCompactAddWithSharing = fsLit "h$compactAddWithSharing" + +hdCompactAdd :: FastString +hdCompactAdd = fsLit "h$compactAdd" + +hdCompactFixupPointers :: FastString +hdCompactFixupPointers = fsLit "h$compactFixupPointers" + +hdCompactAllocateBlock :: FastString +hdCompactAllocateBlock = fsLit "h$compactAllocateBlock" + +hdCompactGetNextBlock :: FastString +hdCompactGetNextBlock = fsLit "h$compactGetNextBlock" + +hdCompactGetFirstBlock :: FastString +hdCompactGetFirstBlock = fsLit "h$compactGetFirstBlock" + +hdCompactContainsAny :: FastString +hdCompactContainsAny = fsLit "h$compactContainsAny" + +hdCompactContains :: FastString +hdCompactContains = fsLit "h$compactContains" + +hdCompactResize :: FastString +hdCompactResize = fsLit "h$compactResize" + +hdCompactNew :: FastString +hdCompactNew = fsLit "h$compactNew" + +----------------------------------------- Stable Pointers ----------------------- + +hdStableNameInt :: FastString +hdStableNameInt = fsLit "h$stableNameInt" + +hdMakeStableName :: FastString +hdMakeStableName = fsLit "h$makeStableName" + +hdDeRefStablePtr :: FastString +hdDeRefStablePtr = fsLit "h$deRefStablePtr" + +hdStablePtrBuf :: JStgExpr +hdStablePtrBuf = global "h$stablePtrBuf" + +hdMakeStablePtrStr :: FastString +hdMakeStablePtrStr = fsLit "h$makeStablePtr" + +------------------------------- Weak Pointers ----------------------------------- + +hdKeepAlive :: FastString +hdKeepAlive = fsLit "h$keepAlive" + +hdFinalizeWeak :: FastString +hdFinalizeWeak = fsLit "h$finalizeWeak" + +hdMakeWeakNoFinalizer :: FastString +hdMakeWeakNoFinalizer = fsLit "h$makeWeakNoFinalizer" + +hdMakeWeak :: FastString +hdMakeWeak = fsLit "h$makeWeak" + +------------------------------- Concurrency Primitives ------------------------- + +hdGetThreadLabel :: FastString +hdGetThreadLabel = fsLit "h$getThreadLabel" + +hdListThreads :: FastString +hdListThreads = fsLit "h$listThreads" + +hdThreadStatus :: FastString +hdThreadStatus = fsLit "h$threadStatus" + +hdYield :: FastString +hdYield = fsLit "h$yield" + +hdKillThread :: FastString +hdKillThread = fsLit "h$killThread" + +hdFork :: FastString +hdFork = fsLit "h$fork" + +------------------------------- Delay/Wait Ops --------------------------------- + +hdWaitWrite :: FastString +hdWaitWrite = fsLit "h$waitWrite" + +hdWaitRead :: FastString +hdWaitRead = fsLit "h$waitRead" + +hdDelayThread :: FastString +hdDelayThread = fsLit "h$delayThread" + +------------------------------- Exceptions -------------------------------------- + +hdCatchStr :: FastString +hdCatchStr = fsLit "h$catch" + +hdMaskAsyncStr :: FastString +hdMaskAsyncStr = fsLit "h$maskAsync" + +hdMaskUnintAsyncStr :: FastString +hdMaskUnintAsyncStr = fsLit "h$maskUnintAsync" + +hdUnmaskAsyncStr :: FastString +hdUnmaskAsyncStr = fsLit "h$unmaskAsync" + +------------------------------- Mutable variables -------------------------------------- + +hdMutVarStr :: FastString +hdMutVarStr = fsLit "h$MutVar" + +hdAtomicModifyMutVar2Str :: FastString +hdAtomicModifyMutVar2Str = fsLit "h$atomicModifyMutVar2" + +hdAtomicModifyMutVarStr :: FastString +hdAtomicModifyMutVarStr = fsLit "h$atomicModifyMutVar" + +------------------------------- Addr# ------------------------------------------ + +hdComparePointerStr :: FastString +hdComparePointerStr = fsLit "h$comparePointer" + +------------------------------- Byte Arrays ------------------------------------- + +hdCompareByteArraysStr :: FastString +hdCompareByteArraysStr = fsLit "h$compareByteArrays" + +hdResizeMutableByteArrayStr :: FastString +hdResizeMutableByteArrayStr = fsLit "h$resizeMutableByteArray" + +hdShrinkMutableByteArrayStr :: FastString +hdShrinkMutableByteArrayStr = fsLit "h$shrinkMutableByteArray" + +------------------------------- Arrays ------------------------------------------ + +hdCopyMutableArrayStr :: FastString +hdCopyMutableArrayStr = fsLit "h$copyMutableArray" + +hdNewArrayStr :: FastString +hdNewArrayStr = fsLit "h$newArray" + +hdSliceArrayStr :: FastString +hdSliceArrayStr = fsLit "h$sliceArray" + +------------------------------ Float -------------------------------------------- + +hdDecodeFloatIntStr :: FastString +hdDecodeFloatIntStr = fsLit "h$decodeFloatInt" + +hdCastFloatToWord32Str :: FastString +hdCastFloatToWord32Str = fsLit "h$castFloatToWord32" + +hdCastWord32ToFloatStr :: FastString +hdCastWord32ToFloatStr = fsLit "h$castWord32ToFloat" + +------------------------------ Double ------------------------------------------- + +hdDecodeDouble2IntStr :: FastString +hdDecodeDouble2IntStr = fsLit "h$decodeDouble2Int" + +hdDecodeDoubleInt64Str :: FastString +hdDecodeDoubleInt64Str = fsLit "h$decodeDoubleInt64" + +hdCastDoubleToWord64Str :: FastString +hdCastDoubleToWord64Str = fsLit "h$castDoubleToWord64" + +hdCastWord64ToDoubleStr :: FastString +hdCastWord64ToDoubleStr = fsLit "h$castWord64ToDouble" + +------------------------------ Word ------------------------------------------- + +hdReverseWordStr :: FastString +hdReverseWordStr = fsLit "h$reverseWord" + +hdClz8Str + , hdClz16Str + , hdClz32Str + , hdClz64Str + , hdCtz8Str + , hdCtz16Str + , hdCtz32Str + , hdCtz64Str :: FastString + +hdClz8Str = fsLit "h$clz8" +hdClz16Str = fsLit "h$clz16" +hdClz32Str = fsLit "h$clz32" +hdClz64Str = fsLit "h$clz64" +hdCtz8Str = fsLit "h$ctz8" +hdCtz16Str = fsLit "h$ctz16" +hdCtz32Str = fsLit "h$ctz32" +hdCtz64Str = fsLit "h$ctz64" + +hdBSwap64Str :: FastString +hdBSwap64Str = "h$bswap64" + +hdPExit8Str + , hdPExit16Str + , hdPExit32Str + , hdPExit64Str + , hdPDep8Str + , hdPDep16Str + , hdPDep32Str + , hdPDep64Str :: FastString + +hdPExit8Str = fsLit "h$pext8" +hdPExit16Str = fsLit "h$pext16" +hdPExit32Str = fsLit "h$pext32" +hdPExit64Str = fsLit "h$pext64" +hdPDep8Str = fsLit "h$pdep8" +hdPDep16Str = fsLit "h$pdep16" +hdPDep32Str = fsLit "h$pdep32" +hdPDep64Str = fsLit "h$pdep64" + +hdPopCntTab :: JStgExpr +hdPopCntTab = global "h$popCntTab" + +hdPopCnt32Str :: FastString +hdPopCnt32Str = fsLit "h$popCnt32" + +hdPopCnt64Str :: FastString +hdPopCnt64Str = fsLit "h$popCnt64" + +hdQuotRem2Word32Str :: FastString +hdQuotRem2Word32Str = fsLit "h$quotRem2Word32" + +hdQuotRemWord32Str :: FastString +hdQuotRemWord32Str = fsLit "h$quotRemWord32" + +hdRemWord32Str :: FastString +hdRemWord32Str = fsLit "h$remWord32" + +hdQuotWord32Str :: FastString +hdQuotWord32Str = fsLit "h$quotWord32" + +hdMul2Word32Str :: FastString +hdMul2Word32Str = fsLit "h$mul2Word32" + +hdMulImulStr :: FastString +hdMulImulStr = fsLit "Math.imul" + +hdWordAdd2 :: FastString +hdWordAdd2 = fsLit "h$wordAdd2" + +hdHsPlusWord64Str :: FastString +hdHsPlusWord64Str = fsLit "h$hs_plusWord64" + +hdHsMinusWord64Str :: FastString +hdHsMinusWord64Str = fsLit "h$hs_minusWord64" + +hdHsTimesWord64Str :: FastString +hdHsTimesWord64Str = fsLit "h$hs_timesWord64" + +hdHsQuotWord64Str :: FastString +hdHsQuotWord64Str = fsLit "h$hs_quotWord64" + +hdHsRemWord64Str :: FastString +hdHsRemWord64Str = fsLit "h$hs_remWord64" + +hdHsUncheckedShiftRWord64Str :: FastString +hdHsUncheckedShiftRWord64Str = fsLit "h$hs_uncheckedShiftRWord64" + +hdHsUncheckedShiftLWord64Str :: FastString +hdHsUncheckedShiftLWord64Str = fsLit "h$hs_uncheckedShiftLWord64" + +hdHsPlusInt64Str :: FastString +hdHsPlusInt64Str = fsLit "h$hs_plusInt64" + +hdHsMinusInt64Str :: FastString +hdHsMinusInt64Str = fsLit "h$hs_minusInt64" + +hdHsTimesInt64Str :: FastString +hdHsTimesInt64Str = fsLit "h$hs_timesInt64" + +hdHsQuotInt64Str :: FastString +hdHsQuotInt64Str = fsLit "h$hs_quotInt64" + +hdHsRemInt64Str :: FastString +hdHsRemInt64Str = fsLit "h$hs_remInt64" + +hdHsUncheckedShiftLLInt64Str :: FastString +hdHsUncheckedShiftLLInt64Str = fsLit "h$hs_uncheckedShiftLLInt64" + +hdHsUncheckedShiftRAInt64Str :: FastString +hdHsUncheckedShiftRAInt64Str = fsLit "h$hs_uncheckedShiftRAInt64" + +hdHsUncheckedShiftRLInt64Str :: FastString +hdHsUncheckedShiftRLInt64Str = fsLit "h$hs_uncheckedShiftRLInt64" + +hdHsTimesInt2Str :: FastString +hdHsTimesInt2Str = fsLit "h$hs_timesInt2" + +------------------------------ Linker ------------------------------------------- + +hdEncodeModifiedUtf8Str :: FastString +hdEncodeModifiedUtf8Str = fsLit "h$encodeModifiedUtf8" + +hdRawStringDataStr :: FastString +hdRawStringDataStr = fsLit "h$rawStringData" + +hdPStr :: FastString +hdPStr = fsLit "h$p" + +hdDStr :: FastString +hdDStr = fsLit "h$d" + +hdDiStr :: FastString +hdDiStr = fsLit "h$di" + +hdStcStr :: FastString +hdStcStr = fsLit "h$stc" + +hdStlStr :: FastString +hdStlStr = fsLit "h$stl" + +hdStiStr :: FastString +hdStiStr = fsLit "h$sti" + +------------------------------ Pack/Unpack -------------------------------------------- + +hdDecodeUtf8Z :: FastString +hdDecodeUtf8Z = fsLit "h$decodeUtf8z" diff --git a/GHC/StgToJS/Types.hs b/GHC/StgToJS/Types.hs --- a/GHC/StgToJS/Types.hs +++ b/GHC/StgToJS/Types.hs @@ -22,13 +22,17 @@ import GHC.Prelude -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import qualified GHC.JS.Syntax as Sat import GHC.JS.Make -import GHC.JS.Ppr () +import GHC.JS.Ppr () -- expose Outputable instances to downstream modules +import GHC.StgToJS.Symbols + import GHC.Stg.Syntax import GHC.Core.TyCon +import GHC.Linker.Config import GHC.Types.Unique import GHC.Types.Unique.FM @@ -43,10 +47,14 @@ import GHC.Unit.Module +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Char (toUpper) import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.ByteString as BS import Data.Monoid +import Data.Set (Set) import Data.Word -- | A State monad over IO holding the generator state. @@ -60,12 +68,12 @@ , gsIdents :: !IdCache -- ^ hash consing for identifiers from a Unique , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments , gsGroup :: GenGroupState -- ^ state for the current binding group - , gsGlobal :: [JStat] -- ^ global (per module) statements (gets included when anything else from the module is used) + , gsGlobal :: [JStgStat] -- ^ global (per module) statements (gets included when anything else from the module is used) } -- | The JS code generator state relevant for the current binding group data GenGroupState = GenGroupState - { ggsToplevelStats :: [JStat] -- ^ extra toplevel statements for the binding group + { ggsToplevelStats :: [JStgStat] -- ^ extra toplevel statements for the binding group , ggsClosureInfo :: [ClosureInfo] -- ^ closure metadata (info tables) for the binding group , ggsStatic :: [StaticInfo] -- ^ static (CAF) data in our binding group , ggsStack :: [StackSlot] -- ^ stack info for the current expression @@ -93,11 +101,12 @@ , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions -- settings , csContext :: !SDocContext + , csLinkerConfig :: !LinkerConfig -- ^ Emscripten linker } --- | Information relevenat to code generation for closures. +-- | Closure info table data ClosureInfo = ClosureInfo - { ciVar :: Ident -- ^ object being infod + { ciVar :: Ident -- ^ entry code identifier: infotable fields are stored as properties of this function , ciRegs :: CIRegs -- ^ size of the payload (in number of JS values) , ciName :: FastString -- ^ friendly name for printing , ciLayout :: CILayout -- ^ heap/stack layout of the object @@ -110,7 +119,7 @@ data CIRegs = CIRegsUnknown -- ^ A value witnessing a state of unknown registers | CIRegs { ciRegsSkip :: Int -- ^ unused registers before actual args start - , ciRegsTypes :: [VarType] -- ^ args + , ciRegsTypes :: [JSRep] -- ^ args } deriving stock (Eq, Ord, Show) @@ -122,7 +131,7 @@ } | CILayoutFixed -- ^ whole layout known { layoutSize :: !Int -- ^ closure size in array positions, including entry - , layout :: [VarType] -- ^ The set of sized Types to layout + , layout :: [JSRep] -- ^ The list of JSReps to layout } deriving stock (Eq, Ord, Show) @@ -147,10 +156,10 @@ -- note: only works after all top-level objects have been created instance ToJExpr CIStatic where toJExpr (CIStaticRefs []) = null_ -- [je| null |] - toJExpr (CIStaticRefs rs) = toJExpr (map TxtI rs) + toJExpr (CIStaticRefs rs) = toJExpr (map global rs) --- | Free variable types -data VarType +-- | JS primitive representations +data JSRep = PtrV -- ^ pointer = reference to heap object (closure object), lifted or not. -- Can also be some RTS object (e.g. TVar#, MVar#, MutVar#, Weak#) | VoidV -- ^ no fields @@ -162,21 +171,21 @@ | ArrV -- ^ boxed array deriving stock (Eq, Ord, Enum, Bounded, Show) -instance ToJExpr VarType where +instance ToJExpr JSRep where toJExpr = toJExpr . fromEnum -- | The type of identifiers. These determine the suffix of generated functions -- in JS Land. For example, the entry function for the 'Just' constructor is a -- 'IdConEntry' which compiles to: -- @ --- function h$baseZCGHCziMaybeziJust_con_e() { return h$rs() }; +-- function h$ghczminternalZCGHCziInternalziMaybeziJust_con_e() { return h$rs() }; -- @ -- which just returns whatever the stack point is pointing to. Whereas the entry -- function to 'Just' is an 'IdEntry' and does the work. It compiles to: -- @ --- function h$baseZCGHCziMaybeziJust_e() { +-- function h$ghczminternalZCGHCziInternalziMaybeziJust_e() { -- var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2; --- h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5); +-- h$r1 = h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, h$$ghczminternalZCGHCziInternalziMaybezieta_8KXnScrCjF5); -- return h$rs(); -- }; -- @ @@ -222,18 +231,22 @@ , siCC :: !(Maybe Ident) -- ^ optional CCS name } deriving stock (Eq, Show) +data StaticAppKind + = SAKFun + -- ^ heap object for function + | SAKThunk + -- ^ heap object for CAF + | SAKData + -- ^ regular datacon app + deriving stock (Eq, Show) + data StaticVal - = StaticFun !FastString [StaticArg] - -- ^ heap object for function - | StaticThunk !(Maybe (FastString,[StaticArg])) - -- ^ heap object for CAF (field is Nothing when thunk is initialized in an - -- alternative way, like string thunks through h$str) - | StaticUnboxed !StaticUnboxed + = StaticUnboxed !StaticUnboxed -- ^ unboxed constructor (Bool, Int, Double etc) - | StaticData !FastString [StaticArg] - -- ^ regular datacon app | StaticList [StaticArg] (Maybe FastString) -- ^ list initializer (with optional tail) + | StaticApp StaticAppKind !FastString [StaticArg] + -- ^ static application of static args. Can be a CAF, a FUN, or a CON app. deriving stock (Eq, Show) data StaticUnboxed @@ -275,9 +288,9 @@ toJExpr (IntLit i) = toJExpr i toJExpr NullLit = null_ toJExpr (DoubleLit d) = toJExpr (unSaneDouble d) - toJExpr (StringLit t) = app (mkFastString "h$str") [toJExpr t] - toJExpr (BinLit b) = app (mkFastString "h$rstr") [toJExpr (map toInteger (BS.unpack b))] - toJExpr (LabelLit _isFun lbl) = var lbl + toJExpr (StringLit t) = app hdEncodeModifiedUtf8Str [toJExpr t] + toJExpr (BinLit b) = app hdRawStringDataStr [toJExpr (map toInteger (BS.unpack b))] + toJExpr (LabelLit _isFun lbl) = global lbl -- | A foreign reference to some JS code data ForeignJSRef = ForeignJSRef @@ -288,6 +301,7 @@ , foreignRefArgs :: ![FastString] , foreignRefResult :: !FastString } + deriving (Show) -- | data used to generate one ObjBlock in our object file data LinkableUnit = LinkableUnit @@ -303,13 +317,13 @@ -- | one toplevel block in the object file data ObjBlock = ObjBlock - { oiSymbols :: ![FastString] -- ^ toplevel symbols (stored in index) - , oiClInfo :: ![ClosureInfo] -- ^ closure information of all closures in block - , oiStatic :: ![StaticInfo] -- ^ static closure data + { oiSymbols :: [FastString] -- ^ toplevel symbols (stored in index) + , oiClInfo :: [ClosureInfo] -- ^ closure information of all closures in block + , oiStatic :: [StaticInfo] -- ^ static closure data , oiStat :: Sat.JStat -- ^ the code - , oiRaw :: !BS.ByteString -- ^ raw JS code - , oiFExports :: ![ExpFun] - , oiFImports :: ![ForeignJSRef] + , oiRaw :: BS.ByteString -- ^ raw JS code + , oiFExports :: [ExpFun] + , oiFImports :: [ForeignJSRef] } data ExpFun = ExpFun @@ -338,28 +352,26 @@ -- | Typed expression data TypedExpr = TypedExpr { typex_typ :: !PrimRep - , typex_expr :: [JExpr] + , typex_expr :: [JStgExpr] } --- FIXME: temporarily removed until JStg replaces JStat --- instance Outputable TypedExpr where --- ppr x = text "TypedExpr: " <+> ppr (typex_expr x) --- $$ text "PrimReps: " <+> ppr (typex_typ x) +instance Outputable TypedExpr where + ppr (TypedExpr typ x) = ppr (typ, x) -- | A Primop result is either an inlining of some JS payload, or a primitive -- call to a JS function defined in Shim files in base. data PrimRes - = PrimInline JStat -- ^ primop is inline, result is assigned directly - | PRPrimCall JStat -- ^ primop is async call, primop returns the next - -- function to run. result returned to stack top in - -- registers + = PrimInline JStgStat -- ^ primop is inline, result is assigned directly + | PRPrimCall JStgStat -- ^ primop is async call, primop returns the next + -- function to run. result returned to stack top in + -- registers data ExprResult = ExprCont - | ExprInline (Maybe [JExpr]) + | ExprInline deriving (Eq) -newtype ExprValData = ExprValData [JExpr] +newtype ExprValData = ExprValData [JStgExpr] deriving newtype (Eq) -- | A Closure is one of six types @@ -370,7 +382,7 @@ | Con -- ^ The closure is a Constructor | Blackhole -- ^ The closure is a Blackhole | StackFrame -- ^ The closure is a stack frame - deriving (Show, Eq, Ord, Enum, Bounded) + deriving (Show, Eq, Ord, Enum, Bounded, Ix) -- | Convert 'ClosureType' to an Int ctNum :: ClosureType -> Int @@ -380,6 +392,20 @@ ctNum Pap = 3 ctNum Blackhole = 5 ctNum StackFrame = -1 + +closureB :: ByteString +closureB = BSC.pack "_CLOSURE" + +closureNames :: Array ClosureType Ident +closureNames = listArray (minBound, maxBound) [ name $ mk_names n + | n <- enumFromTo minBound maxBound + ] + where + mk_names :: ClosureType -> FastString + mk_names nm = mkFastStringByteString + $ hdB + <> BSC.pack (map toUpper (show nm)) + <> closureB -- | Convert 'ClosureType' to a String ctJsName :: ClosureType -> String diff --git a/GHC/StgToJS/Utils.hs b/GHC/StgToJS/Utils.hs --- a/GHC/StgToJS/Utils.hs +++ b/GHC/StgToJS/Utils.hs @@ -2,83 +2,53 @@ {-# LANGUAGE LambdaCase #-} module GHC.StgToJS.Utils - ( assignToTypedExprs - , assignCoerce1 + ( assignCoerce1 , assignToExprCtx - -- * Core Utils + , fixedLayout + , assocIdExprs + -- * Unboxable datacon , isUnboxableCon , isUnboxable - , SlotCount(..) + , isBoolDataCon + -- * JSRep , slotCount , varSize - , varSlotCount , typeSize , isVoid - , isPtr - , isSingleVar , isMultiVar - , isMatchable - , tyConVt - , idVt - , typeVt - , uTypeVt - , primRepVt - , typePrimRep' - , tyConPrimRep' - , kindPrimRep' - , primTypeVt - , argVt - , dataConType - , isBoolDataCon - , fixedLayout + , idJSRep + , typeJSRep + , unaryTypeJSRep + , primRepToJSRep + , primOrVoidRepToJSRep , stackSlotType - , idPrimReps - , typePrimReps , primRepSize - , assocPrimReps - , assocIdPrimReps - , assocIdExprs , mkArityTag - , toTypeList - -- * Stg Utils - , bindingRefs - , rhsRefs + -- * References and Ids , exprRefs - , altRefs - , argRefs , hasExport , collectTopIds , collectIds - , removeTick + -- * Live variables , LiveVars , liveStatic , liveVars - , stgTopBindLive - , stgBindLive - , stgBindRhsLive , stgRhsLive - , stgArgLive , stgExprLive - , stgAltLive - , stgLetNoEscapeLive - , bindees , isUpdatableRhs - , stgLneLive , stgLneLive' , stgLneLiveExpr , isInlineExpr - , inspectInlineBinding - , inspectInlineRhs - , isInlineForeignCall - , isInlineApp - ) where + ) +where import GHC.Prelude -import GHC.StgToJS.Types import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types -import GHC.JS.Unsat.Syntax +import GHC.JS.JStg.Syntax import GHC.JS.Make import GHC.JS.Transform @@ -91,10 +61,8 @@ import GHC.Tc.Utils.TcType -import GHC.Builtin.Types -import GHC.Builtin.Types.Prim import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) +import GHC.Builtin.PrimOps (primOpIsReallyInline) import GHC.Types.RepType import GHC.Types.Var @@ -102,7 +70,6 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Unique.FM -import GHC.Types.Unique.Set import GHC.Types.ForeignCall import GHC.Types.TyThing import GHC.Types.Name @@ -119,35 +86,45 @@ import Data.Monoid -assignToTypedExprs :: [TypedExpr] -> [JExpr] -> JStat +assignToTypedExprs :: [TypedExpr] -> [JStgExpr] -> JStgStat assignToTypedExprs tes es = assignAllEqual (concatMap typex_expr tes) es -assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat +assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStgStat assignTypedExprs tes es = - -- TODO: check primRep (typex_typ) here? - assignToTypedExprs tes (concatMap typex_expr es) + let prim_tes = concatMap typex_expr tes + prim_es = concatMap typex_expr es + -- extract the JExprs, effectively unarising a RuntimeRep thing to + -- multiple VarType-repped things (e.g., AddrRep takes two VarType-regs) + in assertPpr (equalLength prim_tes prim_es) + (ppr (map typex_typ tes) $$ ppr (map typex_typ es)) + (assignAllEqual prim_tes prim_es) -assignToExprCtx :: ExprCtx -> [JExpr] -> JStat +assignToExprCtx :: ExprCtx -> [JStgExpr] -> JStgStat assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es -- | Assign first expr only (if it exists), performing coercions between some -- PrimReps (e.g. StablePtr# and Addr#). -assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStat +assignCoerce1 :: [TypedExpr] -> [TypedExpr] -> JStgStat assignCoerce1 [x] [y] = assignCoerce x y assignCoerce1 [] [] = mempty -assignCoerce1 _x _y = pprPanic "assignCoerce1" +-- We silently ignore the case of an empty list on the first argument. It denotes +-- "assign nothing to n empty slots on the right". Usually this case shouldn't come +-- up, but rare cases where the earlier code can't correctly guess the size of type +-- classes causes slots to be allocated when they aren't needed. +assignCoerce1 [] _ = mempty +assignCoerce1 x y = pprPanic "assignCoerce1" (vcat [ text "lengths do not match" -- FIXME: Outputable instance removed until JStg replaces JStat - -- , ppr x - -- , ppr y + , ppr x + , ppr y ]) -- | Assign p2 to p1 with optional coercion -assignCoerce :: TypedExpr -> TypedExpr -> JStat +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]) = @@ -163,7 +140,7 @@ isUnboxableCon :: DataCon -> Bool isUnboxableCon dc | [t] <- dataConRepArgTys dc - , [t1] <- typeVt (scaledThing t) + , [t1] <- typeJSRep (scaledThing t) = isUnboxable t1 && dataConTag dc == 1 && length (tyConDataCons $ dataConTyCon dc) == 1 @@ -171,7 +148,7 @@ -- | one-constructor types with one primitive field represented as a JS Number -- can be unboxed -isUnboxable :: VarType -> Bool +isUnboxable :: JSRep -> Bool isUnboxable DoubleV = True isUnboxable IntV = True -- includes Char# isUnboxable _ = False @@ -194,153 +171,59 @@ TwoSlots -> 2 --- | Number of slots occupied by a value with the given VarType -varSize :: VarType -> Int -varSize = slotCount . varSlotCount +-- | Number of slots occupied by a value with the given JSRep +varSize :: JSRep -> Int +varSize = slotCount . jsRepSlots -varSlotCount :: VarType -> SlotCount -varSlotCount VoidV = NoSlot -varSlotCount LongV = TwoSlots -- hi, low -varSlotCount AddrV = TwoSlots -- obj/array, offset -varSlotCount _ = OneSlot +jsRepSlots :: JSRep -> SlotCount +jsRepSlots VoidV = NoSlot +jsRepSlots LongV = TwoSlots -- hi, low +jsRepSlots AddrV = TwoSlots -- obj/array, offset +jsRepSlots _ = OneSlot typeSize :: Type -> Int -typeSize t = sum . map varSize . typeVt $ t +typeSize t = sum . map varSize . typeJSRep $ t -isVoid :: VarType -> Bool +isVoid :: JSRep -> Bool isVoid VoidV = True isVoid _ = False -isPtr :: VarType -> Bool -isPtr PtrV = True -isPtr _ = False - -isSingleVar :: VarType -> Bool -isSingleVar v = varSlotCount v == OneSlot - -isMultiVar :: VarType -> Bool -isMultiVar v = case varSlotCount v of +isMultiVar :: JSRep -> Bool +isMultiVar v = case jsRepSlots v of NoSlot -> False OneSlot -> False TwoSlots -> True --- | can we pattern match on these values in a case? -isMatchable :: [VarType] -> Bool -isMatchable [DoubleV] = True -isMatchable [IntV] = True -isMatchable _ = False - -tyConVt :: HasDebugCallStack => TyCon -> [VarType] -tyConVt = typeVt . mkTyConTy - -idVt :: HasDebugCallStack => Id -> [VarType] -idVt = typeVt . idType +idJSRep :: HasDebugCallStack => Id -> [JSRep] +idJSRep = typeJSRep . idType -typeVt :: HasDebugCallStack => Type -> [VarType] -typeVt t | isRuntimeRepKindedTy t = [] -typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t) +typeJSRep :: HasDebugCallStack => Type -> [JSRep] +typeJSRep t = map primRepToJSRep (typePrimRep t) -- only use if you know it's not an unboxed tuple -uTypeVt :: HasDebugCallStack => UnaryType -> VarType -uTypeVt ut - | isRuntimeRepKindedTy ut = VoidV --- | isRuntimeRepTy ut = VoidV - -- GHC panics on this otherwise - | Just (tc, ty_args) <- splitTyConApp_maybe ut - , length ty_args /= tyConArity tc = PtrV - | isPrimitiveType ut = (primTypeVt ut) - | otherwise = - case typePrimRep' ut of - [] -> VoidV - [pt] -> primRepVt pt - _ -> pprPanic "uTypeVt: not unary" (ppr ut) - -primRepVt :: HasDebugCallStack => PrimRep -> VarType -primRepVt VoidRep = VoidV -primRepVt (BoxedRep _) = PtrV -- fixme does ByteArray# ever map to this? -primRepVt IntRep = IntV -primRepVt Int8Rep = IntV -primRepVt Int16Rep = IntV -primRepVt Int32Rep = IntV -primRepVt WordRep = IntV -primRepVt Word8Rep = IntV -primRepVt Word16Rep = IntV -primRepVt Word32Rep = IntV -primRepVt Int64Rep = LongV -primRepVt Word64Rep = LongV -primRepVt AddrRep = AddrV -primRepVt FloatRep = DoubleV -primRepVt DoubleRep = DoubleV -primRepVt (VecRep{}) = error "uTypeVt: vector types are unsupported" - -typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep] -typePrimRep' ty = kindPrimRep' empty (typeKind ty) - --- | Find the primitive representation of a 'TyCon'. Defined here to --- avoid module loops. Call this only on unlifted tycons. -tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep] -tyConPrimRep' tc = kindPrimRep' empty res_kind - where - res_kind = tyConResKind tc - --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's --- of values of types of this kind. -kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] -kindPrimRep' doc ki - | Just ki' <- coreView ki - = kindPrimRep' doc ki' -kindPrimRep' doc (TyConApp _typ [runtime_rep]) - = -- ASSERT( typ `hasKey` tYPETyConKey ) - runtimeRepPrimRep doc runtime_rep -kindPrimRep' doc ki - = pprPanic "kindPrimRep'" (ppr ki $$ doc) +unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) -primTypeVt :: HasDebugCallStack => Type -> VarType -primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of - Nothing -> error "primTypeVt: not a TyCon" - Just tc - | tc == charPrimTyCon -> IntV - | tc == intPrimTyCon -> IntV - | tc == wordPrimTyCon -> IntV - | tc == floatPrimTyCon -> DoubleV - | tc == doublePrimTyCon -> DoubleV - | tc == int8PrimTyCon -> IntV - | tc == word8PrimTyCon -> IntV - | tc == int16PrimTyCon -> IntV - | tc == word16PrimTyCon -> IntV - | tc == int32PrimTyCon -> IntV - | tc == word32PrimTyCon -> IntV - | tc == int64PrimTyCon -> LongV - | tc == word64PrimTyCon -> LongV - | tc == addrPrimTyCon -> AddrV - | tc == stablePtrPrimTyCon -> AddrV - | tc == stableNamePrimTyCon -> PtrV - | tc == statePrimTyCon -> VoidV - | tc == proxyPrimTyCon -> VoidV - | tc == realWorldTyCon -> VoidV - | tc == threadIdPrimTyCon -> PtrV - | tc == weakPrimTyCon -> PtrV - | tc == arrayPrimTyCon -> ArrV - | tc == smallArrayPrimTyCon -> ArrV - | tc == byteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal - | tc == mutableArrayPrimTyCon -> ArrV - | tc == smallMutableArrayPrimTyCon -> ArrV - | tc == mutableByteArrayPrimTyCon -> ObjV -- can contain any JS reference, used for JSVal - | tc == mutVarPrimTyCon -> PtrV - | tc == mVarPrimTyCon -> PtrV - | tc == tVarPrimTyCon -> PtrV - | tc == bcoPrimTyCon -> PtrV -- unsupported? - | tc == stackSnapshotPrimTyCon -> PtrV - | tc == ioPortPrimTyCon -> PtrV -- unsupported? - | tc == anyTyCon -> PtrV - | tc == compactPrimTyCon -> PtrV -- unsupported? - | tc == eqPrimTyCon -> VoidV -- coercion token? - | tc == eqReprPrimTyCon -> VoidV -- role - | tc == unboxedUnitTyCon -> VoidV -- Void# - | otherwise -> PtrV -- anything else must be some boxed thing +primRepToJSRep :: HasDebugCallStack => PrimRep -> JSRep +primRepToJSRep (BoxedRep _) = PtrV +primRepToJSRep IntRep = IntV +primRepToJSRep Int8Rep = IntV +primRepToJSRep Int16Rep = IntV +primRepToJSRep Int32Rep = IntV +primRepToJSRep WordRep = IntV +primRepToJSRep Word8Rep = IntV +primRepToJSRep Word16Rep = IntV +primRepToJSRep Word32Rep = IntV +primRepToJSRep Int64Rep = LongV +primRepToJSRep Word64Rep = LongV +primRepToJSRep AddrRep = AddrV +primRepToJSRep FloatRep = DoubleV +primRepToJSRep DoubleRep = DoubleV +primRepToJSRep (VecRep{}) = error "primRepToJSRep: vector types are unsupported" -argVt :: StgArg -> VarType -argVt a = uTypeVt . stgArgType $ a +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep dataConType :: DataCon -> Type dataConType dc = idType (dataConWrapId dc) @@ -350,16 +233,16 @@ -- standard fixed layout: payload types -- payload starts at .d1 for heap objects, entry closest to Sp for stack frames -fixedLayout :: [VarType] -> CILayout +fixedLayout :: [JSRep] -> CILayout fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts -- 2-var values might have been moved around separately, use DoubleV as substitute -- ObjV is 1 var, so this is no problem for implicit metadata -stackSlotType :: Id -> VarType +stackSlotType :: Id -> JSRep stackSlotType i - | OneSlot <- varSlotCount otype = otype - | otherwise = DoubleV - where otype = uTypeVt (idType i) + | OneSlot <- jsRepSlots otype = otype + | otherwise = DoubleV + where otype = unaryTypeJSRep (idType i) idPrimReps :: Id -> [PrimRep] idPrimReps = typePrimReps . idType @@ -368,34 +251,31 @@ typePrimReps = typePrimRep . unwrapType primRepSize :: PrimRep -> SlotCount -primRepSize p = varSlotCount (primRepVt p) +primRepSize p = jsRepSlots (primRepToJSRep p) -- | Associate the given values to each RrimRep in the given order, taking into -- account the number of slots per PrimRep -assocPrimReps :: [PrimRep] -> [JExpr] -> [(PrimRep, [JExpr])] +assocPrimReps :: [PrimRep] -> [JStgExpr] -> [(PrimRep, [JStgExpr])] assocPrimReps [] _ = [] assocPrimReps (r:rs) vs = case (primRepSize r,vs) of (NoSlot, xs) -> (r,[]) : assocPrimReps rs xs (OneSlot, x:xs) -> (r,[x]) : assocPrimReps rs xs (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs - err -> pprPanic "assocPrimReps" (ppr $ map (satJExpr Nothing) <$> err) + err -> pprPanic "assocPrimReps" (ppr $ map jStgExprToJS <$> err) -- | Associate the given values to the Id's PrimReps, taking into account the -- number of slots per PrimRep -assocIdPrimReps :: Id -> [JExpr] -> [(PrimRep, [JExpr])] +assocIdPrimReps :: Id -> [JStgExpr] -> [(PrimRep, [JStgExpr])] assocIdPrimReps i = assocPrimReps (idPrimReps i) -- | Associate the given JExpr to the Id's PrimReps, taking into account the -- number of slots per PrimRep -assocIdExprs :: Id -> [JExpr] -> [TypedExpr] +assocIdExprs :: Id -> [JStgExpr] -> [TypedExpr] assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) mkArityTag :: Int -> Int -> Int mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) -toTypeList :: [VarType] -> [Int] -toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) - -------------------------------------------------------------------------------- -- Stg Utils -------------------------------------------------------------------------------- @@ -462,14 +342,16 @@ in seqList xs `seq` xs where acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] - -- the GHC.Prim module has no js source file isForbidden i - | Just m <- nameModule_maybe (getName i) = m == gHC_PRIM - | otherwise = False - -removeTick :: CgStgExpr -> CgStgExpr -removeTick (StgTick _ e) = e -removeTick e = e + -- the GHC.Prim module has no js source file + | Just m <- nameModule_maybe (getName i) + , m == gHC_PRIM + = True + -- unboxed tuples have no definition + | isUnboxedTupleDataConLikeName (getName i) + = True + | otherwise + = False ----------------------------------------------------- -- Live vars @@ -484,11 +366,6 @@ liveVars :: LiveVars -> LiveVars liveVars = filterDVarSet (not . isGlobalId) -stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)] -stgTopBindLive = \case - StgTopLifted b -> stgBindLive b - StgTopStringLit {} -> [] - stgBindLive :: CgStgBinding -> [(Id, LiveVars)] stgBindLive = \case StgNonRec b rhs -> [(b, stgRhsLive rhs)] @@ -529,9 +406,6 @@ stgAltLive alt = delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) -stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars -stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive" - bindees :: CgStgBinding -> [Id] bindees = \case StgNonRec b _e -> [b] @@ -554,61 +428,46 @@ -- stgLneLiveExpr StgRhsCon {} = [] -- | returns True if the expression is definitely inline -isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool) -isInlineExpr v = \case +isInlineExpr :: CgStgExpr -> Bool +isInlineExpr = \case StgApp i args - -> (emptyUniqSet, isInlineApp v i args) + -> isInlineApp i args StgLit{} - -> (emptyUniqSet, True) + -> True StgConApp{} - -> (emptyUniqSet, True) + -> True StgOpApp (StgFCallOp f _) _ _ - -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) + -> isInlineForeignCall f StgOpApp (StgPrimOp op) _ _ - -> (emptyUniqSet, primOpIsReallyInline op) + -> primOpIsReallyInline op StgOpApp (StgPrimCallOp _c) _ _ - -> (emptyUniqSet, True) - StgCase e b _ alts - ->let (_ve, ie) = isInlineExpr v e - v' = addOneToUniqSet v b - (vas, ias) = unzip $ map (isInlineExpr v') (fmap alt_rhs alts) - vr = L.foldl1' intersectUniqSets vas - in (vr, (ie || b `elementOfUniqSet` v) && and ias) - StgLet _ b e - -> isInlineExpr (inspectInlineBinding v b) e - StgLetNoEscape _ _b e - -> isInlineExpr v e - StgTick _ e - -> isInlineExpr v e - -inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id -inspectInlineBinding v = \case - StgNonRec i r -> inspectInlineRhs v i r - StgRec bs -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs - -inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id -inspectInlineRhs v i = \case - StgRhsCon{} -> addOneToUniqSet v i - StgRhsClosure _ _ ReEntrant _ _ _ -> addOneToUniqSet v i - _ -> v + -> True + StgCase e _ _ alts + ->let ie = isInlineExpr e + ias = map isInlineExpr (fmap alt_rhs alts) + in ie && and ias + StgLet _ _ e + -> isInlineExpr e + StgLetNoEscape _ _ e + -> isInlineExpr e + StgTick _ e + -> isInlineExpr e isInlineForeignCall :: ForeignCall -> Bool isInlineForeignCall (CCall (CCallSpec _ cconv safety)) = not (playInterruptible safety) && not (cconv /= JavaScriptCallConv && playSafe safety) -isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool -isInlineApp v i = \case +isInlineApp :: Id -> [StgArg] -> Bool +isInlineApp i = \case _ | isJoinId i -> False [] -> isUnboxedTupleType (idType i) || isStrictType (idType i) || - i `elementOfUniqSet` v + ctxIsEvaluated i [StgVarArg a] | DataConWrapId dc <- idDetails i , isNewTyCon (dataConTyCon dc) - , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a + , isStrictType (idType a) || ctxIsEvaluated a || isStrictId a -> True _ -> False diff --git a/GHC/SysTools.hs b/GHC/SysTools.hs --- a/GHC/SysTools.hs +++ b/GHC/SysTools.hs @@ -17,7 +17,6 @@ -- * Interface to system tools module GHC.SysTools.Tasks, - module GHC.SysTools.Info, -- * Fast file copy copyFile, @@ -35,8 +34,6 @@ import GHC.Utils.Panic import GHC.Driver.Session -import GHC.Linker.ExtraObj -import GHC.SysTools.Info import GHC.SysTools.Tasks import GHC.SysTools.BaseDir import GHC.Settings.IO diff --git a/GHC/SysTools/Ar.hs b/GHC/SysTools/Ar.hs --- a/GHC/SysTools/Ar.hs +++ b/GHC/SysTools/Ar.hs @@ -168,7 +168,7 @@ putPaddedInt 6 own putPaddedInt 6 grp putPaddedInt 8 mode - putPaddedInt 10 (st_size + pad) + putPaddedInt 10 st_size putByteString "\x60\x0a" putByteString file when (pad == 1) $ diff --git a/GHC/SysTools/Cpp.hs b/GHC/SysTools/Cpp.hs --- a/GHC/SysTools/Cpp.hs +++ b/GHC/SysTools/Cpp.hs @@ -5,8 +5,9 @@ module GHC.SysTools.Cpp ( doCpp - , CppOpts (..) + , CppOpts(..) , getGhcVersionPathName + , getGhcVersionIncludeFlags , applyCDefs , offsetIncludePaths ) @@ -15,13 +16,13 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Backend -import GHC.CmmToLlvm.Config +import GHC.CmmToLlvm.Version import GHC.Platform import GHC.Platform.ArchOS import GHC.SysTools -import GHC.Unit.Env +import GHC.Unit.Env as UnitEnv import GHC.Unit.Info import GHC.Unit.State import GHC.Unit.Types @@ -31,7 +32,6 @@ import GHC.Utils.Panic import Data.Version -import Data.List (intercalate) import Data.Maybe import Control.Monad @@ -40,18 +40,80 @@ import System.FilePath data CppOpts = CppOpts - { cppUseCc :: !Bool -- ^ Use "cc -E" as preprocessor, otherwise use "cpp" - , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas + { sourceCodePreprocessor :: !SourceCodePreprocessor + , cppLinePragmas :: !Bool + -- ^ Enable generation of LINE pragmas } --- | Run CPP +{- +Note [Preprocessing invocations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must consider four distinct preprocessors when preprocessing Haskell. +These are: + +(1) The Haskell C preprocessor (HsCpp), which preprocesses Haskell files that make use + of the CPP language extension + +(2) The C preprocessor (Cpp), which is used to preprocess C files + +(3) The JavaScript preprocessor (JsCpp), which preprocesses JavaScript files + +(4) The C-- preprocessor (CmmCpp), which preprocesses C-- files + +These preprocessors are indeed different. Despite often sharing the same +underlying program (the C compiler), the set of flags passed determines the +behaviour of the preprocessor, and Cpp and HsCpp behave differently. +Specifically, we rely on "traditional" (pre-standard) preprocessing semantics +(which most compilers expose via the `-traditional` flag) when preprocessing +Haskell source. This avoids the following situations: + + * Removal of C-style comments, which are not comments in Haskell but valid + operators; + + * Errors due to an ANSI C preprocessor lexing the source and failing on + names with single quotes (TH quotes, ticked promoted constructors, + names with primes in them). + + Both of those cases may be subtle: gcc and clang permit C++-style // + comments in C code, and Data.Array and Data.Vector both export a // + operator whose type is such that a removed "comment" may leave code that + typechecks but does the wrong thing. Another example is that, since ANSI + C permits long character constants, an expression involving multiple + functions with primes in their names may not expand macros properly when + they occur between the primed functions. + +Third special type of preprocessor for JavaScript was added laterly due to +needing to keep JSDoc comments and multiline comments. Various third party +minifying software (for example, Google Closure Compiler) uses JSDoc +information to apply more strict rules to code reduction which results in +better but more dangerous minification. JSDoc comments are usually used to +instruct minifiers where dangerous optimizations could be applied. + +The fourth, the C-- preprocessor, is needed as modern compilers emit defines +for debug info generation when preprocessing. The C-- preprocessor avoids this +by suppressing debug info generation. The C-- preprocessor also inherits flags +passed to the C compiler. This is done for compatibility. Following those, +the C-- compiler receives -g0, if it was detected as supported, and flags +passed via -optCmmP specifically for the C-- preprocessor. The combined +command line looks like: + + $pgmCmmP $optCs_without_g3s $g0_if_supported $optCmmP + +-} + +-- | Run either the Haskell preprocessor, JavaScript preprocessor +-- or the C preprocessor, as per the 'CppOpts' passed. +-- 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 let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags) - let unit_state = ue_units unit_env + let unit_state = ue_homeUnitState unit_env pkg_include_dirs <- mayThrowUnitErr (collectIncludeDirs <$> preloadUnitsInfo unit_env) -- MP: This is not quite right, the headers which are supposed to be installed in @@ -62,20 +124,17 @@ [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env] dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps] - let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) [] + let include_paths_global = map ("-I" ++) (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs ++ concatMap includePathsGlobal dep_pkg_extra_inputs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + let include_paths_quote = map ("-iquote" ++) (includePathsQuote cmdline_include_paths ++ includePathsQuoteImplicit cmdline_include_paths) let include_paths = include_paths_quote ++ include_paths_global let verbFlags = getVerbFlags dflags - let cpp_prog args - | cppUseCc opts = GHC.SysTools.runCc Nothing logger tmpfs dflags - (GHC.SysTools.Option "-E" : args) - | otherwise = GHC.SysTools.runCpp logger dflags args + let cpp_prog args = runSourceCodePreprocessor logger tmpfs dflags (sourceCodePreprocessor opts) args let platform = targetPlatform dflags targetArch = stringEncodeArch $ platformArch platform @@ -96,6 +155,9 @@ let sse_defs = [ "-D__SSE__" | isSseEnabled platform ] ++ [ "-D__SSE2__" | isSse2Enabled platform ] ++ + [ "-D__SSE3__" | isSse3Enabled dflags ] ++ + [ "-D__SSSE3__" | isSsse3Enabled dflags ] ++ + [ "-D__SSE4_1__" | isSse4_1Enabled dflags ] ++ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] let fma_def = @@ -112,9 +174,11 @@ 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 ] + ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env -- MIN_VERSION macros let uids = explicitUnits unit_state @@ -137,10 +201,11 @@ cpp_prog ( map GHC.SysTools.Option verbFlags ++ map GHC.SysTools.Option include_paths - ++ map GHC.SysTools.Option hsSourceCppOpts + ++ map GHC.SysTools.Option ghcVersionH ++ map GHC.SysTools.Option target_defs ++ map GHC.SysTools.Option backend_defs ++ map GHC.SysTools.Option th_defs + ++ map GHC.SysTools.Option asserts_def ++ map GHC.SysTools.Option hscpp_opts ++ map GHC.SysTools.Option sse_defs ++ map GHC.SysTools.Option fma_def @@ -199,28 +264,32 @@ _ -> error "take3" (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0" +getGhcVersionIncludeFlags :: DynFlags -> UnitEnv -> IO [String] +getGhcVersionIncludeFlags dflags unit_env = + getGhcVersionPathName dflags unit_env >>= \case + Nothing -> pure [] + Just path -> pure [ "-include", path ] -- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath -getGhcVersionPathName dflags unit_env = do - let candidates = case ghcVersionFile dflags of - -- the user has provided an explicit `ghcversion.h` file to use. - Just path -> [path] - -- otherwise, try to find it in the rts' include-dirs. - -- Note: only in the RTS include-dirs! not all preload units less we may - -- use a wrong file. See #25106 where a globally installed - -- /usr/include/ghcversion.h file was used instead of the one provided - -- by the rts. - Nothing -> case lookupUnitId (ue_units unit_env) rtsUnitId of - Nothing -> [] - Just info -> ( "ghcversion.h") <$> collectIncludeDirs [info] - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x +getGhcVersionPathName :: DynFlags -> UnitEnv -> IO (Maybe FilePath) +getGhcVersionPathName dflags unit_env = case ghcVersionFile dflags of + -- the user has provided an explicit `ghcversion.h` file to use. + Just path -> doesFileExist path >>= \case + True -> return (Just path) + False -> throwGhcExceptionIO (InstallationError ("ghcversion.h not found in: " ++ path)) + -- otherwise, try to find it in the rts' include-dirs. + -- Note: only in the RTS include-dirs! not all preload units less we may + -- use a wrong file. See #25106 where a globally installed + -- /usr/include/ghcversion.h file was used instead of the one provided + -- by the rts. + Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of + Nothing -> pure Nothing + Just info -> do + let candidates = ( "ghcversion.h") <$> collectIncludeDirs [info] + found <- filterM doesFileExist candidates + case found of + [] -> pure Nothing + (x:_) -> pure (Just x) applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] applyCDefs NoCDefs _ _ = return [] diff --git a/GHC/SysTools/Info.hs b/GHC/SysTools/Info.hs deleted file mode 100644 --- a/GHC/SysTools/Info.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Compiler information functions --- --- (c) The GHC Team 2017 --- ------------------------------------------------------------------------------ -module GHC.SysTools.Info where - -import GHC.Utils.Exception -import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Logger - -import Data.List ( isInfixOf, isPrefixOf ) -import Data.IORef - -import System.IO - -import GHC.Platform -import GHC.Prelude - -import GHC.SysTools.Process - -{- Note [Run-time linker info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: #5240, #6063, #10110 - -Before 'runLink', we need to be sure to get the relevant information -about the linker we're using at runtime to see if we need any extra -options. - -Generally, the linker changing from what was detected at ./configure -time has always been possible using -pgml, but on Linux it can happen -'transparently' by installing packages like binutils-gold, which -change what /usr/bin/ld actually points to. - -Clang vs GCC notes: - -For gcc, 'gcc -Wl,--version' gives a bunch of output about how to -invoke the linker before the version information string. For 'clang', -the version information for 'ld' is all that's output. For this -reason, we typically need to slurp up all of the standard error output -and look through it. - -Other notes: - -We cache the LinkerInfo inside DynFlags, since clients may link -multiple times. The definition of LinkerInfo is there to avoid a -circular dependency. - --} - -{- Note [ELF needed shared libs] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some distributions change the link editor's default handling of -ELF DT_NEEDED tags to include only those shared objects that are -needed to resolve undefined symbols. For Template Haskell we need -the last temporary shared library also if it is not needed for the -currently linked temporary shared library. We specify --no-as-needed -to override the default. This flag exists in GNU ld and GNU gold. - -The flag is only needed on ELF systems. On Windows (PE) and Mac OS X -(Mach-O) the flag is not needed. - --} - -neededLinkArgs :: LinkerInfo -> [Option] -neededLinkArgs (GnuLD o) = o -neededLinkArgs (Mold o) = o -neededLinkArgs (GnuGold o) = o -neededLinkArgs (LlvmLLD o) = o -neededLinkArgs (DarwinLD o) = o -neededLinkArgs (SolarisLD o) = o -neededLinkArgs (AixLD o) = o -neededLinkArgs UnknownLD = [] - --- Grab linker info and cache it in DynFlags. -getLinkerInfo :: Logger -> DynFlags -> IO LinkerInfo -getLinkerInfo logger dflags = do - info <- readIORef (rtldInfo dflags) - case info of - Just v -> return v - Nothing -> do - v <- getLinkerInfo' logger dflags - writeIORef (rtldInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getLinkerInfo' :: Logger -> DynFlags -> IO LinkerInfo -getLinkerInfo' logger dflags = do - let platform = targetPlatform dflags - os = platformOS platform - (pgm,args0) = pgm_l dflags - args1 = map Option (getOpts dflags opt_l) - args2 = args0 ++ args1 - args3 = filter notNull (map showOpt args2) - - -- Try to grab the info from the process output. - parseLinkerInfo stdo _stde _exitc - | any ("GNU ld" `isPrefixOf`) stdo = - -- Set DT_NEEDED for all shared libraries. #10110. - return (GnuLD $ map Option [-- ELF specific flag - -- see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - | any ("mold" `isPrefixOf`) stdo = - return (Mold $ map Option [ --see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) - - | any ("GNU gold" `isPrefixOf`) stdo = - -- GNU gold only needs --no-as-needed. #10110. - -- ELF specific flag, see Note [ELF needed shared libs] - return (GnuGold [Option "-Wl,--no-as-needed"]) - - | any (\line -> "LLD" `isPrefixOf` line || "LLD" `elem` words line) stdo = - return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs] - "-Wl,--no-as-needed" | osElfTarget os || os == OSMinGW32 ]) - - -- Unknown linker. - | otherwise = fail "invalid --version output, or linker is unsupported" - - -- Process the executable call - catchIO ( - case os of - OSSolaris2 -> - -- Solaris uses its own Solaris linker. Even all - -- GNU C are recommended to configure with Solaris - -- linker instead of using GNU binutils linker. Also - -- all GCC distributed with Solaris follows this rule - -- precisely so we assume here, the Solaris linker is - -- used. - return $ SolarisLD [] - OSAIX -> - -- IBM AIX uses its own non-binutils linker as well - return $ AixLD [] - OSDarwin -> - -- Darwin has neither GNU Gold or GNU LD, but a strange linker - -- that doesn't support --version. We can just assume that's - -- what we're using. - return $ DarwinLD [] - OSMinGW32 -> - -- GHC doesn't support anything but GNU ld on Windows anyway. - -- Process creation is also fairly expensive on win32, so - -- we short-circuit here. - return $ GnuLD $ map Option - [ -- Emit stack checks - -- See Note [Windows stack allocations] - "-fstack-check" - ] - _ -> do - -- In practice, we use the compiler as the linker here. Pass - -- -Wl,--version to get linker version info. - (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm - (["-Wl,--version"] ++ args3) - c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. In particular, 'clang' and 'gcc' - -- have slightly different outputs for '-Wl,--version', but - -- it's still easy to figure out. - parseLinkerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg logger 2 - (text "Error (figuring out linker information):" <+> - text (show err)) - errorMsg logger $ hang (text "Warning:") 9 $ - text "Couldn't figure out linker information!" $$ - text "Make sure you're using GNU ld, GNU gold" <+> - text "or the built in OS X linker, etc." - return UnknownLD - ) - --- | Grab compiler info and cache it in DynFlags. -getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo -getCompilerInfo logger dflags = do - info <- readIORef (rtccInfo dflags) - case info of - Just v -> return v - Nothing -> do - let pgm = pgm_c dflags - v <- getCompilerInfo' logger pgm - writeIORef (rtccInfo dflags) (Just v) - return v - --- | Grab assembler info and cache it in DynFlags. -getAssemblerInfo :: Logger -> DynFlags -> IO CompilerInfo -getAssemblerInfo logger dflags = do - info <- readIORef (rtasmInfo dflags) - case info of - Just v -> return v - Nothing -> do - let (pgm, _) = pgm_a dflags - v <- getCompilerInfo' logger pgm - writeIORef (rtasmInfo dflags) (Just v) - return v - --- See Note [Run-time linker info]. -getCompilerInfo' :: Logger -> String -> IO CompilerInfo -getCompilerInfo' logger pgm = do - let -- Try to grab the info from the process output. - parseCompilerInfo _stdo stde _exitc - -- Regular GCC - | any ("gcc version" `isInfixOf`) stde = - return GCC - -- Regular clang - | any ("clang version" `isInfixOf`) stde = - return Clang - -- FreeBSD clang - | any ("FreeBSD clang version" `isInfixOf`) stde = - return Clang - -- Xcode 5.1 clang - | any ("Apple LLVM version 5.1" `isPrefixOf`) stde = - return AppleClang51 - -- Xcode 5 clang - | any ("Apple LLVM version" `isPrefixOf`) stde = - return AppleClang - -- Xcode 4.1 clang - | any ("Apple clang version" `isPrefixOf`) stde = - return AppleClang - -- Unknown compiler. - | otherwise = fail $ "invalid -v output, or compiler is unsupported (" ++ pgm ++ "): " ++ unlines stde - - -- Process the executable call - catchIO (do - (exitc, stdo, stde) <- - readProcessEnvWithExitCode pgm ["-v"] c_locale_env - -- Split the output by lines to make certain kinds - -- of processing easier. - parseCompilerInfo (lines stdo) (lines stde) exitc - ) - (\err -> do - debugTraceMsg logger 2 - (text "Error (figuring out C compiler information):" <+> - text (show err)) - errorMsg logger $ hang (text "Warning:") 9 $ - text "Couldn't figure out C compiler information!" $$ - text "Make sure you're using GNU gcc, or clang" - return UnknownCC - ) diff --git a/GHC/SysTools/Process.hs b/GHC/SysTools/Process.hs --- a/GHC/SysTools/Process.hs +++ b/GHC/SysTools/Process.hs @@ -6,22 +6,37 @@ -- (c) The GHC Team 2017 -- ----------------------------------------------------------------------------- -module GHC.SysTools.Process where +module GHC.SysTools.Process + ( readCreateProcessWithExitCode' + , getGccEnv + , runSomething + , runSomethingResponseFile + , runSomethingFiltered + , runSomethingWith + ) where import GHC.Prelude -import GHC.Driver.DynFlags - import GHC.Utils.Exception import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.CliOption import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString +import GHC.IO.Encoding + +#if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.Event.Windows (associateHandle') +#endif + import Control.Concurrent import Data.Char @@ -32,25 +47,12 @@ import System.IO.Error as IO import System.Process -import GHC.Utils.TmpFs -- | Enable process jobs support on Windows if it can be expected to work (e.g. -- @process >= 1.6.9.0@). enableProcessJobs :: CreateProcess -> CreateProcess -#if defined(MIN_VERSION_process) enableProcessJobs opts = opts { use_process_jobs = True } -#else -enableProcessJobs opts = opts -#endif -#if !MIN_VERSION_base(4,15,0) --- TODO: This can be dropped with GHC 8.16 -hGetContents' :: Handle -> IO String -hGetContents' hdl = do - output <- hGetContents hdl - _ <- evaluate $ length output - return output -#endif -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is -- inherited from the parent process, and output to stderr is not captured. @@ -81,26 +83,6 @@ return (ex, output) -replaceVar :: (String, String) -> [(String, String)] -> [(String, String)] -replaceVar (var, value) env = - (var, value) : filter (\(var',_) -> var /= var') env - --- | Version of @System.Process.readProcessWithExitCode@ that takes a --- key-value tuple to insert into the environment. -readProcessEnvWithExitCode - :: String -- ^ program path - -> [String] -- ^ program args - -> (String, String) -- ^ addition to the environment - -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr) -readProcessEnvWithExitCode prog args env_update = do - current_env <- getEnvironment - readCreateProcessWithExitCode (proc prog args) { - env = Just (replaceVar env_update current_env) } "" - --- Don't let gcc localize version info string, #8825 -c_locale_env :: (String, String) -c_locale_env = ("LANGUAGE", "C") - -- If the -B option is set, add to PATH. This works around -- a bug in gcc on Windows Vista where it can't find its auxiliary -- binaries (see bug #1110). @@ -153,14 +135,14 @@ runSomethingResponseFile :: Logger -> TmpFs - -> DynFlags - -> (String->String) + -> TempDir + -> ([String] -> [String]) -> String -> String -> [Option] -> Maybe [(String,String)] -> IO () -runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env = +runSomethingResponseFile logger tmpfs tmp_dir filter_fn phase_name pgm args mb_env = runSomethingWith logger phase_name pgm args $ \real_args -> do fp <- getResponseFile real_args let args = ['@':fp] @@ -168,7 +150,7 @@ return (r,()) where getResponseFile args = do - fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp" + fp <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do hSetEncoding h utf8 hPutStr h $ unlines $ map escape args @@ -200,7 +182,7 @@ ] runSomethingFiltered - :: Logger -> (String->String) -> String -> String -> [Option] + :: Logger -> ([String] -> [String]) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env = @@ -233,20 +215,30 @@ then does_not_exist else throwGhcExceptionIO (ProgramError $ show err) - does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) + does_not_exist = + throwGhcExceptionIO $ + InstallationError (phase_name ++ ": could not execute: " ++ pgm) +withPipe :: ((Handle, Handle) -> IO a) -> IO a +withPipe = bracket createPipe $ \ (readEnd, writeEnd) -> do + hClose readEnd + hClose writeEnd -builderMainLoop :: Logger -> (String -> String) -> FilePath +builderMainLoop :: Logger -> ([String] -> [String]) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode -builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do - chan <- newChan +builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (readEnd, writeEnd) -> do +#if defined(__IO_MANAGER_WINIO__) + return () do + associateHandle' =<< handleToHANDLE readEnd +#endif + -- We use a mask here rather than a bracket because we want -- to distinguish between cleaning up with and without an -- exception. This is to avoid calling terminateProcess -- unless an exception was raised. - let safely inner = mask $ \restore -> do + mask $ \restore -> do -- acquire -- On Windows due to how exec is emulated the old process will exit and -- a new process will be created. This means waiting for termination of @@ -256,105 +248,86 @@ -- finish. let procdata = enableProcessJobs - $ (proc pgm real_args) { cwd = mb_cwd - , env = mb_env - , std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - } - (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $ + $ (proc pgm real_args) { + cwd = mb_cwd + , env = mb_env + , std_in = CreatePipe + + -- We used to treat stdout/stderr as separate streams, but this + -- was racy (see #25517). We now treat them as one stream and + -- that is fine for our use-case. We rely on upstream programs + -- to serialize writes to the two streams appropriately (note + -- that they already need to do that to produce deterministic + -- output when used interactively / on the command-line). + , std_out = UseHandle writeEnd + , std_err = UseHandle writeEnd + } + (Just hStdIn, Nothing, Nothing, hProcess) <- restore $ createProcess_ "builderMainLoop" procdata - let cleanup_handles = do - hClose hStdIn - hClose hStdOut - hClose hStdErr + hClose writeEnd r <- try $ restore $ do - hSetBuffering hStdOut LineBuffering - hSetBuffering hStdErr LineBuffering - let make_reader_proc h = forkIO $ readerProc chan h filter_fn - bracketOnError (make_reader_proc hStdOut) killThread $ \_ -> - bracketOnError (make_reader_proc hStdErr) killThread $ \_ -> - inner hProcess + getLocaleEncoding >>= hSetEncoding readEnd + hSetNewlineMode readEnd nativeNewlineMode + hSetBuffering readEnd LineBuffering + messages <- parseBuildMessages . filter_fn . lines <$> hGetContents readEnd + mapM_ processBuildMessage messages + waitForProcess hProcess + hClose hStdIn case r of - -- onException Left (SomeException e) -> do terminateProcess hProcess - cleanup_handles throw e - -- cleanup when there was no exception Right s -> do - cleanup_handles return s - safely $ \h -> do - -- we don't want to finish until 2 streams have been complete - -- (stdout and stderr) - log_loop chan (2 :: Integer) - -- after that, we wait for the process to finish and return the exit code. - waitForProcess h where - -- t starts at the number of streams we're listening to (2) decrements each - -- time a reader process sends EOF. We are safe from looping forever if a - -- reader thread dies, because they send EOF in a finally handler. - log_loop _ 0 = return () - log_loop chan t = do - msg <- readChan chan + processBuildMessage :: BuildMessage -> IO () + processBuildMessage msg = do case msg of BuildMsg msg -> do logInfo logger $ withPprStyle defaultUserStyle msg - log_loop chan t BuildError loc msg -> do logMsg logger errorDiagnostic (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg - log_loop chan t - EOF -> - log_loop chan (t-1) -readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO () -readerProc chan hdl filter_fn = - (do str <- hGetContents hdl - loop (linesPlatform (filter_fn str)) Nothing) - `finally` - writeChan chan EOF - -- ToDo: check errors more carefully - -- ToDo: in the future, the filter should be implemented as - -- a stream transformer. +parseBuildMessages :: [String] -> [BuildMessage] +parseBuildMessages str = loop str Nothing where - loop [] Nothing = return () - loop [] (Just err) = writeChan chan err + loop :: [String] -> Maybe BuildMessage -> [BuildMessage] + loop [] Nothing = [] + loop [] (Just err) = [err] loop (l:ls) in_err = case in_err of Just err@(BuildError srcLoc msg) | leading_whitespace l -> loop ls (Just (BuildError srcLoc (msg $$ text l))) - | otherwise -> do - writeChan chan err - checkError l ls + | otherwise -> + err : checkError l ls Nothing -> checkError l ls - _ -> panic "readerProc/loop" + _ -> panic "parseBuildMessages/loop" + checkError :: String -> [String] -> [BuildMessage] checkError l ls = case parseError l of - Nothing -> do - writeChan chan (BuildMsg (text l)) - loop ls Nothing - Just (file, lineNum, colNum, msg) -> do - let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum + Nothing -> + BuildMsg (text l) : loop ls Nothing + Just (srcLoc, msg) -> do loop ls (Just (BuildError srcLoc (text msg))) + leading_whitespace :: String -> Bool leading_whitespace [] = False leading_whitespace (x:_) = isSpace x -parseError :: String -> Maybe (String, Int, Int, String) +parseError :: String -> Maybe (SrcLoc, String) parseError s0 = case breakColon s0 of Just (filename, s1) -> case breakIntColon s1 of Just (lineNum, s2) -> case breakIntColon s2 of Just (columnNum, s3) -> - Just (filename, lineNum, columnNum, s3) + Just (mkSrcLoc (mkFastString filename) lineNum columnNum, s3) Nothing -> - Just (filename, lineNum, 0, s2) + Just (mkSrcLoc (mkFastString filename) lineNum 0, s2) Nothing -> Nothing Nothing -> Nothing @@ -384,22 +357,3 @@ data BuildMessage = BuildMsg !SDoc | BuildError !SrcLoc !SDoc - | EOF - --- Divvy up text stream into lines, taking platform dependent --- line termination into account. -linesPlatform :: String -> [String] -#if !defined(mingw32_HOST_OS) -linesPlatform ls = lines ls -#else -linesPlatform "" = [] -linesPlatform xs = - case lineBreak xs of - (as,xs1) -> as : linesPlatform xs1 - where - lineBreak "" = ("","") - lineBreak ('\r':'\n':xs) = ([],xs) - lineBreak ('\n':xs) = ([],xs) - lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs) - -#endif diff --git a/GHC/SysTools/Tasks.hs b/GHC/SysTools/Tasks.hs --- a/GHC/SysTools/Tasks.hs +++ b/GHC/SysTools/Tasks.hs @@ -7,22 +7,37 @@ -- (c) The GHC Team 2017 -- ----------------------------------------------------------------------------- -module GHC.SysTools.Tasks where +module GHC.SysTools.Tasks + ( runUnlit + , SourceCodePreprocessor(..) + , runSourceCodePreprocessor + , runPp + , runCc + , askLd + , runAs + , runLlvmOpt + , runLlvmLlc + , runLlvmAs + , runEmscripten + , figureLlvmVersion + , runMergeObjects + , runAr + , askOtool + , runInstallNameTool + , runRanlib + , runWindres + ) where import GHC.Prelude -import GHC.Platform import GHC.ForeignSrcLang -import GHC.IO (catchException) -import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) +import GHC.CmmToLlvm.Version (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) import GHC.Settings import GHC.SysTools.Process -import GHC.SysTools.Info import GHC.Driver.Session - import GHC.Utils.Exception as Exception import GHC.Utils.Error import GHC.Utils.Outputable @@ -31,10 +46,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) {- ************************************************************************ @@ -60,38 +81,9 @@ augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp : augmentImports dflags fps augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps) -runCpp :: Logger -> DynFlags -> [Option] -> IO () -runCpp logger dflags args = traceSystoolCommand logger "cpp" $ do - let opts = getOpts dflags opt_P - modified_imports = augmentImports dflags opts - let (p,args0) = pgm_P dflags - args1 = map Option modified_imports - args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] - ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] - mb_env <- getGccEnv args2 - runSomethingFiltered logger id "C pre-processor" p - (args0 ++ args1 ++ args2 ++ args) Nothing mb_env - -runPp :: Logger -> DynFlags -> [Option] -> IO () -runPp logger dflags args = traceSystoolCommand logger "pp" $ do - let prog = pgm_F dflags - opts = map Option (getOpts dflags opt_F) - runSomething logger "Haskell pre-processor" prog (args ++ opts) - --- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do - let args1 = map Option userOpts - args2 = languageOptions ++ args ++ args1 - -- We take care to pass -optc flags in args1 last to ensure that the - -- user can override flags passed by GHC. See #14452. - mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs dflags cc_filter dbgstring prog args2 - mb_env - where - -- discard some harmless warnings from gcc that we can't turn off - cc_filter = unlines . doFilter . lines - +-- | Discard some harmless warnings from gcc that we can't turn off +cc_filter :: [String] -> [String] +cc_filter = doFilter where {- gcc gives warnings in chunks like so: In file included from /foo/bar/baz.h:11, @@ -139,6 +131,93 @@ | "warning: call-clobbered register used" `isContainedIn` w = False | otherwise = True +-- | See the Note [Preprocessing invocations] +data SourceCodePreprocessor + = SCPCpp + -- ^ Use the ordinary C preprocessor + | SCPHsCpp + -- ^ Use the Haskell C preprocessor (don't remove C comments, don't break on names including single quotes) + | SCPJsCpp + -- ^ Use the JavaScript preprocessor (don't remove jsdoc and multiline comments) + | SCPCmmCpp + -- ^ Use the C-- preprocessor (don't emit debug information) + deriving (Eq) + +-- | Run source code preprocessor. +-- See also Note [Preprocessing invocations] in GHC.SysTools.Cpp +runSourceCodePreprocessor + :: Logger + -> TmpFs + -> DynFlags + -> SourceCodePreprocessor + -> [Option] + -> IO () +runSourceCodePreprocessor logger tmpfs dflags preprocessor args = + traceSystoolCommand logger logger_name $ do + let + (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 (configured_args ++ runtime_args) + + runSomething readable_name program all_args mb_env + + where + toolSettings' = toolSettings dflags + cmmG0 = ["-g0" | toolSettings_cmmCppSupportsG0 toolSettings'] + -- GCC <=10 (pre commit r11-5596-g934a54180541d2) implied -dD for debug + -- flags by the spec snippet %{g3|ggdb3|gstabs3|gxcoff3|gvms3:-dD}. This + -- means that a g0 will not override a previously-specified -g3 causing + -- debug info emission (see https://gcc.gnu.org/PR97989). We're filtering + -- -optc here, rather than the combined command line, in order to avoid an + -- issue where a user has to, for some reason, override our decision. If + -- they see the need to do that, they can pass -optCmmP. + g3Flags = ["-g3", "-ggdb3", "-gstabs3", "-gxcoff3", "-gvms3"] + 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. 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 + SCPCpp -> ("cpp", pgm_cpp, opt_c, "C pre-processor") + SCPHsCpp -> ("hs-cpp", pgm_P, opt_P, "Haskell C pre-processor") + SCPJsCpp -> ("js-cpp", pgm_JSP, opt_JSP, "JavaScript C pre-processor") + SCPCmmCpp -> ("cmm-cpp", pgm_CmmP, cAndCmmOpt, "C-- C pre-processor") + + runSomethingResponseFileCpp + = runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter + runSomethingFilteredOther phase_name pgm args mb_env + = runSomethingFiltered logger id phase_name pgm args Nothing mb_env + + runSomething + = case preprocessor of + SCPCpp -> runSomethingResponseFileCpp + SCPHsCpp -> runSomethingFilteredOther + SCPJsCpp -> runSomethingFilteredOther + SCPCmmCpp -> runSomethingResponseFileCpp + +runPp :: Logger -> DynFlags -> [Option] -> IO () +runPp logger dflags args = traceSystoolCommand logger "pp" $ do + let prog = pgm_F dflags + opts = map Option (getOpts dflags opt_F) + runSomething logger "Haskell pre-processor" prog (args ++ opts) + +-- | Run compiler of C-like languages and raw objects (such as gcc or clang). +runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () +runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do + let args1 = map Option userOpts + args2 = languageOptions ++ args ++ args1 + -- We take care to pass -optc flags in args1 last to ensure that the + -- user can override flags passed by GHC. See #14452. + mb_env <- getGccEnv args2 + runSomethingResponseFile logger tmpfs (tmpDir dflags) cc_filter dbgstring prog args2 + mb_env + where -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a @@ -204,28 +283,14 @@ args1 = map Option (getOpts dflags opt_lc) runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args) --- | Run the clang compiler (used as an assembler for the LLVM --- backend on OS X as LLVM doesn't support the OS X system --- assembler) -runClang :: Logger -> DynFlags -> [Option] -> IO () -runClang logger dflags args = traceSystoolCommand logger "clang" $ do - let (clang,_) = pgm_lcc dflags - -- be careful what options we call clang with - -- see #5903 and #7617 for bugs caused by this. - (_,args0) = pgm_a dflags - args1 = map Option (getOpts dflags opt_a) - args2 = args0 ++ args1 ++ args - mb_env <- getGccEnv args2 - catchException - (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env) - (\(err :: SomeException) -> do - errorMsg logger $ - text ("Error running clang! you need clang installed to use the" ++ - " LLVM backend") $+$ - text "(or GHC tried to execute clang incorrectly)" - throwIO err - ) +-- | Run the LLVM Assembler +runLlvmAs :: Logger -> DynFlags -> [Option] -> IO () +runLlvmAs logger dflags args = traceSystoolCommand logger "llvm-as" $ do + let (p,args0) = pgm_las dflags + args1 = map Option (getOpts dflags opt_las) + runSomething logger "LLVM assembler" p (args0 ++ args1 ++ args) + runEmscripten :: Logger -> DynFlags -> [Option] -> IO () runEmscripten logger dflags args = traceSystoolCommand logger "emcc" $ do let (p,args0) = pgm_a dflags @@ -236,24 +301,41 @@ 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 - LLVM (http://llvm.org/): - LLVM version 3.5.2 + LLVM version 15.0.7 ... + OR + LLVM (http://llvm.org/): + LLVM version 14.0.6 -} hSetBinaryMode pout False - _ <- hGetLine pout - vline <- hGetLine pout - let mb_ver = parseLlvmVersion vline + line1 <- hGetLine pout + mb_ver <- case parseLlvmVersion line1 of + mb_ver@(Just _) -> return mb_ver + Nothing -> parseLlvmVersion <$> hGetLine pout -- Try the second line hClose pin hClose pout hClose perr @@ -274,71 +356,6 @@ ++ ")") ] return Nothing) - - -runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runLink logger tmpfs dflags args = traceSystoolCommand logger "linker" $ do - -- See Note [Run-time linker info] - -- - -- `-optl` args come at the end, so that later `-l` options - -- given there manually can fill in symbols needed by - -- Haskell libraries coming in via `args`. - linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags - let (p,args0) = pgm_l dflags - optl_args = map Option (getOpts dflags opt_l) - args2 = args0 ++ linkargs ++ args ++ optl_args - mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs dflags ld_filter "Linker" p args2 mb_env - where - ld_filter = case (platformOS (targetPlatform dflags)) of - OSSolaris2 -> sunos_ld_filter - _ -> id -{- - SunOS/Solaris ld emits harmless warning messages about unresolved - symbols in case of compiling into shared library when we do not - link against all the required libs. That is the case of GHC which - does not link against RTS library explicitly in order to be able to - choose the library later based on binary application linking - parameters. The warnings look like: - -Undefined first referenced - symbol in file -stg_ap_n_fast ./T2386_Lib.o -stg_upd_frame_info ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o -newCAF ./T2386_Lib.o -stg_bh_upd_frame_info ./T2386_Lib.o -stg_ap_ppp_fast ./T2386_Lib.o -templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o -stg_ap_p_fast ./T2386_Lib.o -stg_ap_pp_fast ./T2386_Lib.o -ld: warning: symbol referencing errors - - this is actually coming from T2386 testcase. The emitting of those - warnings is also a reason why so many TH testcases fail on Solaris. - - Following filter code is SunOS/Solaris linker specific and should - filter out only linker warnings. Please note that the logic is a - little bit more complex due to the simple reason that we need to preserve - any other linker emitted messages. If there are any. Simply speaking - if we see "Undefined" and later "ld: warning:..." then we omit all - text between (including) the marks. Otherwise we copy the whole output. --} - sunos_ld_filter :: String -> String - sunos_ld_filter = unlines . sunos_ld_filter' . lines - sunos_ld_filter' x = if (undefined_found x && ld_warning_found x) - then (ld_prefix x) ++ (ld_postfix x) - else x - breakStartsWith x y = break (isPrefixOf x) y - ld_prefix = fst . breakStartsWith "Undefined" - undefined_found = not . null . snd . breakStartsWith "Undefined" - ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors" - ld_postfix = tail . snd . ld_warn_break - ld_warning_found = not . null . snd . ld_warn_break - -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args = @@ -349,10 +366,10 @@ , "does not support object merging." ] optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args - if toolSettings_ldSupportsResponseFiles (toolSettings dflags) + if toolSettings_mergeObjsSupportsResponseFiles (toolSettings dflags) then do mb_env <- getGccEnv args2 - runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env + runSomethingResponseFile logger tmpfs (tmpDir dflags) id "Merge objects" p args2 mb_env else do runSomething logger "Merge objects" p args2 @@ -384,7 +401,3 @@ opts = map Option (getOpts dflags opt_windres) mb_env <- getGccEnv cc_args runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env - -touch :: Logger -> DynFlags -> String -> String -> IO () -touch logger dflags purpose arg = traceSystoolCommand logger "touch" $ - runSomething logger purpose (pgm_T dflags) [FileOption "" arg] diff --git a/GHC/SysTools/Terminal.hs b/GHC/SysTools/Terminal.hs --- a/GHC/SysTools/Terminal.hs +++ b/GHC/SysTools/Terminal.hs @@ -17,16 +17,6 @@ import System.IO.Unsafe -#if defined(mingw32_HOST_OS) && !defined(WINAPI) -# if defined(i386_HOST_ARCH) -# define WINAPI stdcall -# elif defined(x86_64_HOST_ARCH) -# define WINAPI ccall -# else -# error unknown architecture -# endif -#endif - -- | Does the controlling terminal support ANSI color sequences? -- This memoized to avoid thread-safety issues in ncurses (see #17922). stderrSupportsAnsiColors :: Bool @@ -84,10 +74,10 @@ setConsoleMode h mode = do Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) -foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode +foreign import ccall unsafe "windows.h GetConsoleMode" c_GetConsoleMode :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL -foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode +foreign import ccall unsafe "windows.h SetConsoleMode" c_SetConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL #endif diff --git a/GHC/Tc/Deriv.hs b/GHC/Tc/Deriv.hs --- a/GHC/Tc/Deriv.hs +++ b/GHC/Tc/Deriv.hs @@ -20,57 +20,64 @@ import GHC.Driver.Session import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Monad import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils -import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) -import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate +import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) import GHC.Tc.Validity( checkValidInstHead ) -import GHC.Core.InstEnv -import GHC.Tc.Utils.Instantiate -import GHC.Core.FamInstEnv import GHC.Tc.Gen.HsType -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Env import GHC.Rename.Bind import GHC.Rename.Env import GHC.Rename.Module ( addTcgDUs ) import GHC.Rename.Utils +import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv import GHC.Core.Unify( tcUnifyTy ) import GHC.Core.Class import GHC.Core.Type -import GHC.Utils.Error import GHC.Core.DataCon -import GHC.Data.Maybe +import GHC.Core.TyCon +import GHC.Core.Predicate( tyCoVarsOfTypesWellScoped ) + +import GHC.Types.Hint (AssumedDerivingStrategy(..)) import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Set as NameSet -import GHC.Core.TyCon -import GHC.Tc.Utils.TcType import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Builtin.Names import GHC.Types.SrcLoc + +import GHC.Unit.Module.Warnings +import GHC.Builtin.Names + +import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Logger -import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.Bag +import GHC.Data.Maybe import GHC.Data.BooleanFormula ( isUnsatisfied ) import Control.Monad 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 {- ************************************************************************ @@ -174,7 +181,7 @@ -- See @Note [Scoped tyvars in a TcTyCon]@ in -- "GHC.Core.TyCon". , di_clauses :: [LHsDerivingClause GhcRn] - , di_ctxt :: SDoc -- ^ error context + , di_ctxt :: ErrCtxtMsg -- ^ error context } {- @@ -278,8 +285,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,11 +298,11 @@ -- 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. - ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds + ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyMiniFixityEnv aux_val_binds ; bindLocalNames bndrs $ do { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos @@ -415,6 +423,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 +511,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 +522,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)@. + -> ErrCtxtMsg -> 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 +537,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 @@ -492,21 +579,20 @@ , text "deriv_pred" <+> ppr deriv_pred , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat , text "via_tvs" <+> ppr via_tvs ] - (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred - when (cls_arg_kinds `lengthIsNot` 1) $ - failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred) - let [cls_arg_kind] = cls_arg_kinds - mb_deriv_strat = fmap unLoc mb_lderiv_strat - if (className cls == typeableClassName) - then do warnUselessTypeable - return Nothing - else let deriv_tvs = via_tvs ++ cls_tvs in - Just <$> deriveTyData tc tys mb_deriv_strat - deriv_tvs cls cls_tys cls_arg_kind + mb_cls_minus1 <- tcHsDeriv deriv_pred + case mb_cls_minus1 of + Nothing -> return Nothing + Just (cls, cls_tvs, arg_tys, arg_kind) -> + do let mb_deriv_strat = fmap unLoc mb_lderiv_strat + if className cls == typeableClassName + then do warnUselessTypeable + return Nothing + else let deriv_tvs = via_tvs ++ cls_tvs in + Just <$> deriveTyData tc tys mb_deriv_strat + deriv_tvs cls arg_tys arg_kind -{- -Note [Don't typecheck too much in DerivingVia] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Don't typecheck too much in DerivingVia] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following example: data D = ... @@ -607,9 +693,9 @@ -- -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. -deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode)) +deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mode)) = setSrcSpanA loc $ - addErrCtxt (standaloneCtxt deriv_ty) $ + addErrCtxt (StandaloneDerivCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True ; traceTc "Deriving strategy (standalone deriving)" $ @@ -640,12 +726,12 @@ inst_ty_kind = typeKind inst_ty mb_match = tcUnifyTy inst_ty_kind via_kind - checkTc (isJust mb_match) - (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ - DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) + kind_subst <- checkJustTc + ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind ) + mb_match - let Just kind_subst = mb_match - ki_subst_range = getSubstRangeTyCoFVs kind_subst + let ki_subst_range = getSubstRangeTyCoFVs kind_subst -- See Note [Unification of two kind variables in deriving] unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst && not (v `elemVarSet` ki_subst_range)) @@ -678,9 +764,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' } + 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. -- @@ -763,9 +856,10 @@ , text "tycon:" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) , text "cls_arg:" <+> ppr (mkTyConApp tc tc_args_to_keep) <+> dcolon <+> ppr inst_ty_kind , text "cls_arg_kind:" <+> ppr cls_arg_kind ] - ; checkTc (enough_args && isJust mb_match) - (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $ - DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep) + ; kind_subst <- checkJustTc + ( TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $ + DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep ) + ( guard enough_args *> mb_match ) ; let -- Returns a singleton-element list if using ViaStrategy and an -- empty list otherwise. Useful for free-variable calculations. @@ -793,7 +887,6 @@ ; let tkvs = scopedSort $ fvVarList $ unionFV (tyCoFVsOfTypes tc_args_to_keep) (FV.mkFVs deriv_tvs) - Just kind_subst = mb_match (tkvs', cls_tys', tc_args', mb_deriv_strat') = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep mb_deriv_strat @@ -809,11 +902,11 @@ = typeKind (mkTyConApp tc tc_args') via_match = tcUnifyTy inst_ty_kind via_kind - checkTc (isJust via_match) - (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ - DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) + via_subst <- checkJustTc + ( TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $ + DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind ) + via_match - let Just via_subst = via_match pure $ propagate_subst via_subst tkvs' cls_tys' tc_args' mb_deriv_strat' @@ -855,6 +948,7 @@ ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args (InferContext Nothing) final_mb_deriv_strat + Nothing ; traceTc "deriveTyData 3" (ppr spec) ; return spec } @@ -1134,13 +1228,14 @@ -- InferContext => context inferred (deriving on data decl, or -- standalone deriving decl with a wildcard) -> Maybe (DerivStrategy GhcTc) + -> Maybe (WarningTxt GhcRn) -> TcRn EarlyDerivSpec -- Make the EarlyDerivSpec for an instance -- forall tvs. theta => cls (tys ++ [ty]) -- where the 'theta' is optional (that's the Maybe part) -- Assumes that this declaration is well-kinded -mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do +mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat warn = do is_boot <- tcIsHsBootOrSig when is_boot $ bale_out DerivErrBootFileFound @@ -1155,7 +1250,8 @@ , denv_inst_tys = cls_args' , denv_ctxt = deriv_ctxt , denv_skol_info = skol_info - , denv_strat = deriv_strat' } + , denv_strat = deriv_strat' + , denv_warn = warn } runReaderT mk_eqn deriv_env where skolemise_when_inferring_context :: @@ -1336,12 +1432,13 @@ -- EarlyDerivSpec from it. mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt - , denv_skol_info = skol_info } <- ask + = do env@(DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt + , denv_skol_info = skol_info + , denv_warn = warn }) <- ask user_ctxt <- askDerivUserTypeCtxt doDerivInstErrorChecks1 mechanism loc <- lift getSrcSpanM @@ -1349,7 +1446,7 @@ case deriv_ctxt of InferContext wildcard -> do { (inferred_constraints, tvs', inst_tys', mechanism') - <- inferConstraints mechanism + <- inferConstraints mechanism env ; return $ InferTheta $ DS { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs' @@ -1359,7 +1456,8 @@ , ds_user_ctxt = user_ctxt , ds_overlap = overlap_mode , ds_standalone_wildcard = wildcard - , ds_mechanism = mechanism' } } + , ds_mechanism = mechanism' + , ds_warn = warn } } SupplyContext theta -> return $ GivenTheta $ DS @@ -1371,7 +1469,8 @@ , ds_user_ctxt = user_ctxt , ds_overlap = overlap_mode , ds_standalone_wildcard = Nothing - , ds_mechanism = mechanism } + , ds_mechanism = mechanism + , ds_warn = warn } mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class -> DerivM EarlyDerivSpec @@ -1876,12 +1975,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 @@ -1904,7 +2000,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 @@ -1915,8 +2011,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] @@ -1973,7 +2069,7 @@ DerivSpecStock{dsm_stock_dit = dit} -> data_cons_in_scope_check dit -- No need to 'data_cons_in_scope_check' for newtype deriving. - -- Additionally, we also don't need to mark the constructos as + -- Additionally, we also don't need to mark the constructors as -- used because newtypes are handled separately elsewhere. -- See Note [Tracking unused binding and imports] in GHC.Tc.Types -- or #17328 for more. @@ -2257,6 +2353,3 @@ = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving else NoGeneralizedNewtypeDeriving -standaloneCtxt :: LHsSigWcType GhcRn -> SDoc -standaloneCtxt ty = hang (text "In the stand-alone deriving instance for") - 2 (quotes (ppr ty)) diff --git a/GHC/Tc/Deriv/Functor.hs b/GHC/Tc/Deriv/Functor.hs --- a/GHC/Tc/Deriv/Functor.hs +++ b/GHC/Tc/Deriv/Functor.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonadComprehensions #-} -- | The deriving code for the Functor, Foldable, and Traversable classes module GHC.Tc.Deriv.Functor @@ -43,7 +44,10 @@ import GHC.Types.Var.Set import GHC.Types.Id.Make (coerceId) import GHC.Builtin.Types (true_RDR, false_RDR) +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf +import Data.Foldable import Data.Maybe (catMaybes, isJust) {- @@ -154,25 +158,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 @@ -181,7 +185,7 @@ fmap_eqns = map fmap_eqn data_cons - ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_fmap :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) ft_fmap = FT { ft_triv = \x -> pure x -- fmap f x = x , ft_var = \x -> pure $ nlHsApp f_Expr x @@ -211,7 +215,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 @@ -220,7 +224,7 @@ replace_eqns = map replace_eqn data_cons - ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) + ft_replace :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) ft_replace = FT { ft_triv = \x -> pure x -- p <$ x = x , ft_var = \_ -> pure z_Expr @@ -247,7 +251,7 @@ -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... match_for_con :: Monad m - => HsMatchContext GhcPs + => HsMatchContextPs -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) @@ -600,27 +604,23 @@ -- The kind checks have ensured the last type parameter is of kind *. -- Make a HsLam using a fresh variable from a State monad -mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) +mkSimpleLam :: (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs)) + -> State (Infinite RdrName) (LHsExpr GhcPs) -- (mkSimpleLam fn) returns (\x. fn(x)) mkSimpleLam lam = - get >>= \case - n:names -> do + get >>= \ (Inf n names) -> do put names body <- lam (nlHsVar n) - return (mkHsLam [nlVarPat n] body) - _ -> panic "mkSimpleLam" + return (mkHsLam (noLocA [nlVarPat n]) body) mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs - -> State [RdrName] (LHsExpr GhcPs)) - -> State [RdrName] (LHsExpr GhcPs) + -> State (Infinite RdrName) (LHsExpr GhcPs)) + -> State (Infinite RdrName) (LHsExpr GhcPs) mkSimpleLam2 lam = - get >>= \case - n1:n2:names -> do + get >>= \ (n1 `Inf` n2 `Inf` names) -> do put names body <- lam (nlHsVar n1) (nlHsVar n2) - return (mkHsLam [nlVarPat n1,nlVarPat n2] body) - _ -> panic "mkSimpleLam2" + return (mkHsLam (noLocA [nlVarPat n1,nlVarPat n2]) body) -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -- @@ -629,7 +629,7 @@ -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ -- and its arguments, applying an expression (from @insides@) to each of the -- respective arguments of @con@. -mkSimpleConMatch :: Monad m => HsMatchContext GhcPs +mkSimpleConMatch :: Monad m => HsMatchContextPs -> (RdrName -> [a] -> m (LHsExpr GhcPs)) -> [LPat GhcPs] -> DataCon @@ -637,14 +637,14 @@ -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch ctxt fold extra_pats con insides = do let con_name = getRdrName con - let vars_needed = takeList insides as_RDRs + let vars_needed = takeList insides as_RDRList let bare_pat = nlConVarPat con_name vars_needed let pat = if null vars_needed then bare_pat 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)" -- @@ -664,7 +664,7 @@ -- -- See Note [Generated code for DeriveFoldable and DeriveTraversable] mkSimpleConMatch2 :: Monad m - => HsMatchContext GhcPs + => HsMatchContextPs -> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)) -> [LPat GhcPs] @@ -673,7 +673,7 @@ -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch2 ctxt fold extra_pats con insides = do let con_name = getRdrName con - vars_needed = takeList insides as_RDRs + vars_needed = takeList insides (toList as_RDRs) pat = nlConVarPat con_name vars_needed -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indices in each expression to match up with the argument indices @@ -684,17 +684,17 @@ -- with the same index has a type which mentions the last type -- variable. argTysTyVarInfo = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo (toList as_Vars) con_expr | null asWithTyVar = nlHsApps con_name asWithoutTyVar | otherwise = - let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo bs_Vars as_Vars - in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) + let bs = filterByList argTysTyVarInfo bs_RDRList + vars = filterByLists argTysTyVarInfo bs_VarList as_VarList + in mkHsLam (noLocA (map nlVarPat bs)) (nlHsApps con_name vars) rhs <- fold con_expr exps - 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,14 +880,14 @@ 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 -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] - ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldr :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) ft_foldr = FT { ft_triv = return Nothing -- foldr f = \x z -> z @@ -922,7 +922,7 @@ mkFoldr = foldr nlHsApp z -- See Note [FFoldType and functorLikeTraverse] - ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_foldMap :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) ft_foldMap = FT { ft_triv = return Nothing -- foldMap f = \x -> mempty @@ -949,15 +949,14 @@ where -- mappend v1 (mappend v2 ..) mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkFoldMap [] = mempty_Expr - mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs + mkFoldMap = foldr1WithDefault mempty_Expr (\x y -> nlHsApps mappend_RDR [x,y]) -- See Note [FFoldType and functorLikeTraverse] -- Yields NullM an expression if we're folding over an expression -- that may or may not be null. Yields IsNull if it's certainly -- null, and yields NotNull if it's certainly not null. -- See Note [Deriving null] - ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) + ft_null :: FFoldType (State (Infinite RdrName) (NullM (LHsExpr GhcPs))) ft_null = FT { ft_triv = return IsNull -- null = \_ -> True @@ -998,8 +997,7 @@ where -- v1 && v2 && .. mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs - mkNull [] = true_Expr - mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs + mkNull = foldr1WithDefault true_Expr (\x y -> nlHsApps and_RDR [x,y]) data NullM a = IsNull -- Definitely null @@ -1051,19 +1049,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,12 +1075,12 @@ = 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'. -- See Note [FFoldType and functorLikeTraverse] - ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) + ft_trav :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs))) ft_trav = FT { ft_triv = return Nothing -- traverse f = pure x @@ -1140,13 +1138,21 @@ f_RDR = mkVarUnqual (fsLit "f") z_RDR = mkVarUnqual (fsLit "z") -as_RDRs, bs_RDRs :: [RdrName] -as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +as_RDRs, bs_RDRs :: Infinite RdrName +as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- Inf.enumFrom (1::Int) ] +bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- Inf.enumFrom (1::Int) ] -as_Vars, bs_Vars :: [LHsExpr GhcPs] -as_Vars = map nlHsVar as_RDRs -bs_Vars = map nlHsVar bs_RDRs +as_Vars, bs_Vars :: Infinite (LHsExpr GhcPs) +as_Vars = fmap nlHsVar as_RDRs +bs_Vars = fmap nlHsVar bs_RDRs + +as_RDRList, bs_RDRList :: [RdrName] +as_RDRList = Inf.toList as_RDRs +bs_RDRList = Inf.toList bs_RDRs + +as_VarList, bs_VarList :: [LHsExpr GhcPs] +as_VarList = Inf.toList as_Vars +bs_VarList = Inf.toList bs_Vars f_Pat, z_Pat :: LPat GhcPs f_Pat = nlVarPat f_RDR diff --git a/GHC/Tc/Deriv/Generate.hs b/GHC/Tc/Deriv/Generate.hs --- a/GHC/Tc/Deriv/Generate.hs +++ b/GHC/Tc/Deriv/Generate.hs @@ -34,7 +34,7 @@ gen_Newtype_fam_insts, mkCoerceClassMethEqn, genAuxBinds, - ordOpTbl, boxConTbl, litConTbl, + ordOpTbl, boxConTbl, mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr, getPossibleDataCons, @@ -83,7 +83,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Data.FastString @@ -241,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 @@ -264,7 +263,7 @@ ------------------------------------------------------------------ nested_eq_expr [] [] [] = true_Expr nested_eq_expr tys as bs - = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + = foldr1 and_Expr $ expectNonEmpty $ zipWith3Equal nested_eq tys as bs -- Using 'foldr1' here ensures that the derived code is correctly -- associated. See #10859. where @@ -407,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 @@ -419,16 +417,17 @@ 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) - lE = mkSimpleGeneratedFunBind loc le_RDR [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 [a_Pat, b_Pat] $ + gT = mkSimpleGeneratedFunBind loc gt_RDR pats $ nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr - gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $ + gE = mkSimpleGeneratedFunBind loc ge_RDR pats $ negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr) get_tag con = dataConTag con - fIRST_TAG @@ -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 @@ -516,7 +515,7 @@ where tag = get_tag data_con tag_lit - = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag))) + = noLocA (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs) -- First argument 'a' known to be built with K @@ -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) noHsTok - (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,10 +911,10 @@ -------------------------------------------------------------- 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 + stmts = zipWith3Equal mk_qual as_needed bs_needed cs_needed mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c) (nlHsApp (nlHsVar range_RDR) @@ -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,14 +949,14 @@ ------------------ 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). then true_Expr - else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range - as_needed bs_needed cs_needed) + else foldl1 and_Expr $ expectNonEmpty $ + zipWith3Equal in_range as_needed bs_needed cs_needed where in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c] @@ -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 @@ -1053,9 +1055,9 @@ rhs | null data_cons -- See Note [Read for empty data types] = nlHsVar pfail_RDR | otherwise - = nlHsApp (nlHsVar parens_RDR) - (foldr1 mk_alt (read_nullary_cons ++ - read_non_nullary_cons)) + = nlHsApp (nlHsVar parens_RDR) $ + foldr1 mk_alt $ expectNonEmpty $ + read_nullary_cons ++ read_non_nullary_cons read_non_nullary_cons = map read_non_nullary_con non_nullary_cons @@ -1115,7 +1117,7 @@ ++ concat (intersperse [read_punc ","] field_stmts) ++ [read_punc "}"] - field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed + field_stmts = zipWithEqual read_field labels as_needed con_arity = dataConSourceArity data_con labels = map (field_label . flLabel) $ dataConFieldLabels data_con @@ -1123,7 +1125,7 @@ is_infix = dataConIsInfix data_con is_record = labels `lengthExceeds` 0 as_needed = take con_arity as_RDRs - read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (derivDataConInstArgTys data_con dit) + read_args = zipWithEqual read_arg as_needed (derivDataConInstArgTys data_con dit) (read_a1:read_a2:_) = read_args prefix_prec = appPrecedence @@ -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) @@ -1267,7 +1269,7 @@ where nm = wrapOpParens (unpackFS l) - show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys + show_args = zipWithEqual show_arg bs_needed arg_tys (show_arg1:show_arg2:_) = show_args show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args @@ -1276,8 +1278,7 @@ show_record_args = concat $ intersperse [comma_space] $ [ [show_label lbl, arg] - | (lbl,arg) <- zipEqual "gen_Show_binds" - labels show_args ] + | (lbl,arg) <- zipEqual labels show_args ] show_arg :: RdrName -> Type -> LHsExpr GhcPs show_arg b arg_ty @@ -1336,7 +1337,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 +1387,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 @@ -1405,7 +1406,7 @@ gfoldl_eqn con = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], - foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed) + foldl' mk_k_app (z_Expr `nlHsApp` (nlHsVar (getRdrName con))) as_needed) where con_name :: RdrName con_name = getRdrName con @@ -1415,7 +1416,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 @@ -1425,18 +1426,9 @@ gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) mk_unfold_rhs dc = foldr nlHsApp - (z_Expr `nlHsApp` (eta_expand_data_con dc)) + (z_Expr `nlHsApp` (nlHsVar (getRdrName dc))) (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) - eta_expand_data_con dc = - mkHsLam eta_expand_pats - (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars) - where - eta_expand_pats = map nlVarPat eta_expand_vars - eta_expand_hsvars = map nlHsVar eta_expand_vars - eta_expand_vars = take (dataConSourceArity dc) as_RDRs - - mk_unfold_pat dc -- Last one is a wild-pat, to avoid -- redundant test, and annoying warning | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor @@ -1456,7 +1448,7 @@ = mkSimpleGeneratedFunBind loc dataTypeOf_RDR - [nlWildPat] + (noLocA [nlWildPat]) (nlHsVar dataT_RDR) ------------ gcast1/2 @@ -1478,10 +1470,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 @@ -1509,21 +1501,21 @@ int8DataCon_RDR, int16DataCon_RDR, int32DataCon_RDR, int64DataCon_RDR, word8DataCon_RDR, word16DataCon_RDR, word32DataCon_RDR, word64DataCon_RDR :: RdrName -gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") -gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") -toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") -dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1") -dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2") -gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1") -gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2") -mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag") -constr_RDR = tcQual_RDR gENERICS (fsLit "Constr") -mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") -dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType") -conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") -prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") -infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") +gfoldl_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "gunfold") +toConstr_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "dataTypeOf") +dataCast1_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "dataCast1") +dataCast2_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "dataCast2") +gcast1_RDR = varQual_RDR gHC_INTERNAL_TYPEABLE (fsLit "gcast1") +gcast2_RDR = varQual_RDR gHC_INTERNAL_TYPEABLE (fsLit "gcast2") +mkConstrTag_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "mkConstrTag") +constr_RDR = tcQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "Constr") +mkDataType_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "mkDataType") +dataType_RDR = tcQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "DataType") +conIndex_RDR = varQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "Prefix") +infix_RDR = dataQual_RDR gHC_INTERNAL_DATA_DATA (fsLit "Infix") eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#") ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#") @@ -1610,14 +1602,14 @@ gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") -int8DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I8#") -int16DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I16#") -int32DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I32#") -int64DataCon_RDR = dataQual_RDR gHC_INT (fsLit "I64#") -word8DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W8#") -word16DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W16#") -word32DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W32#") -word64DataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W64#") +int8DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I8#") +int16DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I16#") +int32DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I32#") +int64DataCon_RDR = dataQual_RDR gHC_INTERNAL_INT (fsLit "I64#") +word8DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W8#") +word16DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W16#") +word32DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W32#") +word64DataCon_RDR = dataQual_RDR gHC_INTERNAL_WORD (fsLit "W64#") {- ************************************************************************ * * @@ -1632,50 +1624,54 @@ ==> instance (Lift a) => Lift (Foo a) where - lift (Foo a) = [| Foo $(lift a) |] - lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |] + lift (Foo a) = ConE 'Foo `appE` (lift a) + lift ((:^:) u v) = ConE '(:^:) `appE` (lift u) `appE` (lift v) - liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||] - liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||] + liftTyped (Foo a) = unsafeCodeCoerce (ConE 'Foo `appE` (lift a)) + liftTyped ((:^:) u v) = unsafeCodeCoerce (ConE '(:^:) `appE` (lift u) `appE` (lift v)) -Note that we use explicit splices here in order to not trigger the implicit -lifting warning in derived code. (See #20688) +Note that we use variable quotes, in order to avoid the constructor being +lifted by implicit cross-stage lifting when `-XNoImplicitStagePersistence` is enabled. -} 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) + (map (pats_etc mk_untyped_bracket ) data_cons) liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr) - (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons) + (map (pats_etc mk_typed_bracket ) data_cons) - mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField - mk_typed_bracket = HsTypedBracket noAnn + mk_untyped_bracket = id + mk_typed_bracket = nlHsApp unsafeCodeCoerce_Expr - mk_tsplice = HsTypedSplice (EpAnnNotUsed, noAnn) - mk_usplice = HsUntypedSplice EpAnnNotUsed . HsUntypedSpliceExpr noAnn data_cons = getPossibleDataCons tycon tycon_args - pats_etc mk_bracket mk_splice lift_name data_con + + pats_etc :: (LHsExpr GhcPs -> LHsExpr GhcPs) -> DataCon -> ([LPat GhcPs], LHsExpr GhcPs) + pats_etc mk_bracket data_con = ([con_pat], lift_Expr) where con_pat = nlConVarPat data_con_RDR as_needed data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con as_needed = take con_arity as_RDRs - lift_Expr = noLocA (mk_bracket br_body) - br_body = nlHsApps (Exact (dataConName data_con)) - (map lift_var as_needed) + lift_Expr = mk_bracket finish + con_brack :: LHsExpr GhcPs + con_brack = nlHsApps (Exact conEName) + [noLocA $ HsUntypedBracket noExtField + $ VarBr noSrcSpanA True (noLocA (Exact (dataConName data_con)))] + finish = foldl' (\b1 b2 -> nlHsApps (Exact appEName) [b1, b2]) con_brack (map lift_var as_needed) + lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed) - lift_var x = noLocA (mk_splice (nlHsPar (mk_lift_expr x))) + lift_var x = nlHsPar (mk_lift_expr x) mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed) - mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x] + mk_lift_expr x = nlHsApps (Exact liftName) [nlHsVar x] {- ************************************************************************ @@ -1697,17 +1693,25 @@ newtype T x = MkT instance C a => C a (T x) where - op :: forall c. a -> [T x] -> c -> Int - op = coerce @(a -> [] -> c -> Int) - @(a -> [T x] -> c -> Int) - op + op @c = coerce @(a -> [] -> 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 +1724,6 @@ class C a where op :: a -> forall b. b -> b newtype T x = MkT instance C => C (T x) where - op :: T x -> forall b. b -> b op = coerce @( -> forall b. b -> b) @(T x -> forall b. b -> b) op @@ -1734,6 +1737,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 => R where + r = \ @b -> coerce @(Proxy b -> ) + @(Proxy b -> ) + 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 => R where + r = \ @b -> coerce @(Proxy @{k} b -> ) + @(Proxy @{k} b -> ) + 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 => R where + r = \ @{k :: Type} -> \ @(b :: k) -> + coerce @(Proxy @{k} b -> ) + @(Proxy @{k} b -> ) + 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 +1897,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 +1914,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 +2007,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 +2031,30 @@ -- -- instance C a => C a (T x) where -- - mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs) - mk_bind_and_sig meth_id - = ( -- The derived binding, e.g., - -- - -- op = coerce @(a -> [] -> 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 -> [] -> 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 +2064,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. @@ -2101,12 +2125,12 @@ rep_cvs' = scopedSort rep_cvs nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLocA (HsAppType noExtField e noHsTok hs_ty) +nlHsAppType e s = noLocA (HsAppType noAnn e hs_ty) where hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s nlHsCoreTy :: HsCoreTy -> LHsType GhcPs -nlHsCoreTy = noLocA . XHsType +nlHsCoreTy = noLocA . XHsType . HsCoreTy mkCoerceClassMethEqn :: Class -- the class being derived -> [TyVar] -- the tvs in the instance head (this includes @@ -2179,7 +2203,7 @@ where tc_name = tyConName tycon tc_name_string = occNameFS (getOccName tc_name) - definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name)) + definition_mod_name = moduleNameFS (moduleName (expectJust $ nameModule_maybe tc_name)) rhs = nlHsVar mkDataType_RDR `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string])) `nlHsApp` nlList (map nlHsVar dataC_RDRs) @@ -2223,10 +2247,10 @@ genAuxBindSpecSig loc spec = case spec of DerivTag2Con tycon _ -> mk_sig $ L (noAnnSrcSpan loc) $ - XHsType $ mkSpecForAllTys (tyConTyVars tycon) $ + XHsType $ HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ intTy `mkVisFunTyMany` mkParentType tycon DerivMaxTag _ _ - -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy)) + -> mk_sig (L (noAnnSrcSpan loc) (XHsType (HsCoreTy intTy))) DerivDataDataType _ _ _ -> mk_sig (nlHsTyVar NotPromoted dataType_RDR) DerivDataConstr _ _ _ @@ -2285,15 +2309,15 @@ 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] mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches) + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches) -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last @@ -2306,8 +2330,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 ] @@ -2321,7 +2345,7 @@ -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches') + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2333,8 +2357,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 @@ -2345,7 +2369,7 @@ mkRdrFunBindSE :: Arity -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindSE arity fun@(L loc fun_rdr) matches - = L (na2la loc) (mkFunBind (Generated SkipPmc) fun matches') + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2353,8 +2377,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) @@ -2365,7 +2389,7 @@ -> Type -- The argument type -> LHsExpr GhcPs -- Boxed version of the arg -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer -box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg +box cls_str arg arg_ty = nlHsApp (assoc_ty_id cls_str boxConTbl arg_ty) arg --------------------- primOrdOps :: String -- The class involved @@ -2405,23 +2429,22 @@ ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ] --- A mapping from a primitive type to a function that constructs its boxed --- version. -boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] +-- A mapping from a primitive type to a DataCon of its boxed version. +boxConTbl :: [(Type, LHsExpr GhcPs)] boxConTbl = - [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon)) - , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon)) - , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon )) - , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon )) - , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon)) - , (int8PrimTy, nlHsApp (nlHsVar int8DataCon_RDR)) - , (word8PrimTy, nlHsApp (nlHsVar word8DataCon_RDR)) - , (int16PrimTy, nlHsApp (nlHsVar int16DataCon_RDR)) - , (word16PrimTy, nlHsApp (nlHsVar word16DataCon_RDR)) - , (int32PrimTy, nlHsApp (nlHsVar int32DataCon_RDR)) - , (word32PrimTy, nlHsApp (nlHsVar word32DataCon_RDR)) - , (int64PrimTy, nlHsApp (nlHsVar int64DataCon_RDR)) - , (word64PrimTy, nlHsApp (nlHsVar word64DataCon_RDR)) + [ (charPrimTy , nlHsVar $ getRdrName charDataCon) + , (intPrimTy , nlHsVar $ getRdrName intDataCon) + , (wordPrimTy , nlHsVar $ getRdrName wordDataCon) + , (floatPrimTy , nlHsVar $ getRdrName floatDataCon) + , (doublePrimTy, nlHsVar $ getRdrName doubleDataCon) + , (int8PrimTy, nlHsVar int8DataCon_RDR) + , (word8PrimTy, nlHsVar word8DataCon_RDR) + , (int16PrimTy, nlHsVar int16DataCon_RDR) + , (word16PrimTy, nlHsVar word16DataCon_RDR) + , (int32PrimTy, nlHsVar int32DataCon_RDR) + , (word32PrimTy, nlHsVar word32DataCon_RDR) + , (int64PrimTy, nlHsVar int64DataCon_RDR) + , (word64PrimTy, nlHsVar word64DataCon_RDR) ] @@ -2445,26 +2468,6 @@ ,(word64PrimTy, "#Word64") ] -litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)] -litConTbl - = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR)) - ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR) - . nlHsApp (nlHsVar toInteger_RDR)) - ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR) - . nlHsApp (nlHsApp - (nlHsVar map_RDR) - (compose_RDR `nlHsApps` - [ nlHsVar fromIntegral_RDR - , nlHsVar fromEnum_RDR - ]))) - ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR) - . nlHsApp (nlHsVar toRational_RDR)) - ] - -- | Lookup `Type` in an association list. assoc_ty_id :: HasDebugCallStack => String -- The class involved -> [(Type,a)] -- The table @@ -2519,46 +2522,21 @@ showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs - -nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty -nested_compose_Expr [e] = parenify e -nested_compose_Expr (e:es) - = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) +nested_compose_Expr = + nlHsLam . mkSimpleMatch (LamAlt LamSingle) (noLocA [z_Pat]) . go + where + -- Previously we used (`.`), but inlining its definition improves compiler + -- performance significantly since we no longer need to typecheck lots of + -- (.) applications (each which needed three type applications, all @String) + -- (See #25453 for why this is especially slow currently) + go [] = panic "nested_compose_expr" -- Arg is always non-empty + go [e] = nlHsApp e z_Expr + go (e:es) = nlHsApp e (go es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! error_Expr :: FastString -> LHsExpr GhcPs error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string)) - --- 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 -parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. diff --git a/GHC/Tc/Deriv/Generics.hs b/GHC/Tc/Deriv/Generics.hs --- a/GHC/Tc/Deriv/Generics.hs +++ b/GHC/Tc/Deriv/Generics.hs @@ -58,19 +58,16 @@ import GHC.Utils.Error( Validity'(..), andValid ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Driver.DynFlags -import GHC.Data.Bag import GHC.Data.FastString import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad (mplus) import Data.List (zip4, partition) -import qualified Data.List as Partial (last) -import Data.List.NonEmpty (nonEmpty) +import Data.List.NonEmpty (NonEmpty (..), last, nonEmpty) import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) @@ -353,17 +350,16 @@ $ getTyVar last_dc_inst_univ where dc_inst_univs = dataConInstUnivs dc tc_args - last_dc_inst_univ = assert (not (null dc_inst_univs)) $ - Partial.last dc_inst_univs + last_dc_inst_univ = last $ expectNonEmpty dc_inst_univs -- Bindings for the Generic instance 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 @@ -380,7 +376,7 @@ | otherwise = False where cons = length datacons - max_fields = maximum $ map dataConSourceArity datacons + max_fields = maximum $ 0 :| map dataConSourceArity datacons inline1 f = L loc'' . InlineSig noAnn (L loc' f) $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 } @@ -655,9 +651,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)] diff --git a/GHC/Tc/Deriv/Infer.hs b/GHC/Tc/Deriv/Infer.hs --- a/GHC/Tc/Deriv/Infer.hs +++ b/GHC/Tc/Deriv/Infer.hs @@ -17,6 +17,7 @@ import GHC.Prelude import GHC.Tc.Deriv.Utils +import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor @@ -26,7 +27,8 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcType -import GHC.Tc.Solver +import GHC.Tc.Solver( simplifyTopImplic ) +import GHC.Tc.Solver.Solve( solveWanteds ) import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor) @@ -43,12 +45,10 @@ import GHC.Data.Pair import GHC.Builtin.Names -import GHC.Builtin.Types (typeToTypeKind) +import GHC.Builtin.Types (mkConstraintTupleTy, typeToTypeKind) -import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Types.Basic @@ -66,7 +66,7 @@ ---------------------- -inferConstraints :: DerivSpecMechanism +inferConstraints :: DerivSpecMechanism -> DerivEnv -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a @@ -83,12 +83,12 @@ -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) +inferConstraints mechanism (DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys }) + = do { let wildcard = isStandaloneWildcardDeriv ctxt + infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) infer_constraints = case mechanism of DerivSpecStock{dsm_stock_dit = dit} @@ -169,12 +169,12 @@ , dit_tc_args = tc_args , dit_rep_tc = rep_tc , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs + = do DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = main_cls , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args + let wildcard = isStandaloneWildcardDeriv ctxt + inst_ty = mkTyConApp tc tc_args tc_binders = tyConBinders rep_tc choose_level bndr | isNamedTyConBinder bndr = KindLevel @@ -297,7 +297,7 @@ = map $ \ty -> let ki = typeKind ty in ( [ mk_cls_pred orig t_or_k cls ty , SimplePredSpec - { sps_pred = mkPrimEqPred ki typeToTypeKind + { sps_pred = mkNomEqPred ki typeToTypeKind , sps_origin = orig , sps_type_or_kind = KindLevel } @@ -370,13 +370,14 @@ -- derived instance context. inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls + = do { DerivEnv { denv_ctxt = ctxt + , denv_cls = cls , denv_inst_tys = inst_tys } <- ask ; let gen_dms = [ (sel_id, dm_ty) | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - ; wildcard <- isStandaloneWildcardDeriv - ; let meth_pred :: (Id, Type) -> PredSpec + ; let wildcard = isStandaloneWildcardDeriv ctxt + meth_pred :: (Id, Type) -> PredSpec -- (Id,Type) are the selector Id and the generic default method type -- NB: the latter is /not/ quantified over the class variables -- See Note [Gathering and simplifying constraints for DeriveAnyClass] @@ -408,46 +409,64 @@ inferConstraintsCoerceBased :: [Type] -> Type -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs + DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = cls , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv - let -- The following functions are polymorphic over the representation - -- type, since we might either give it the underlying type of a - -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type - -- (for DerivingVia). - rep_tys ty = cls_tys ++ [ty] - rep_pred ty = mkClassPred cls (rep_tys ty) - rep_pred_o ty = SimplePredSpec { sps_pred = rep_pred ty - , sps_origin = deriv_origin - , sps_type_or_kind = TypeLevel - } + let -- rep_ty might come from: + -- GeneralizedNewtypeDeriving / DerivSpecNewtype: + -- the underlying type of the newtype () + -- DerivingVia / DerivSpecVia + -- the `via` type + + rep_pred_o = SimplePredSpec { sps_pred = mkClassPred cls (cls_tys ++ [rep_ty]) + , sps_origin = deriv_origin + , sps_type_or_kind = TypeLevel + } -- rep_pred is the representation dictionary, from where -- we are going to get all the methods for the final -- dictionary deriv_origin = mkDerivOrigin sa_wildcard + sa_wildcard = isStandaloneWildcardDeriv ctxt -- Next we collect constraints for the class methods -- If there are no methods, we don't need any constraints -- Otherwise we need (C rep_ty), for the representation methods, -- and constraints to coerce each individual method - meth_preds :: Type -> ThetaSpec - meth_preds ty - | null meths = [] -- No methods => no constraints - -- (#12814) - | otherwise = rep_pred_o ty : coercible_constraints ty + meth_preds :: ThetaSpec + meth_preds | null meths = [] -- No methods => no constraints (#12814) + | otherwise = rep_pred_o : coercible_constraints meths = classMethods cls - coercible_constraints ty + + coercible_constraints = [ SimplePredSpec - { sps_pred = mkReprPrimEqPred t1 t2 + { sps_pred = + assertPpr (tvs1 == tvs2) (ppr t1 $$ ppr t2) $ + -- assert: mkCoerceClassMethEqn returns two + -- foralls with the very same forall-binders + tcMkDFunSigmaTy tvs2 theta2 $ + mkConstraintTupleTy $ mkReprEqPred tau1 tau2 : theta1 + -- The two method types (tau1, tau2) must be coercible. + -- Also, if there are constraints, the constraints + -- provided to the derived method (theta2) must be + -- sufficient to solve the constraints required by the + -- method being coerced (theta1). + -- See Note [Inferred contexts from method constraints] , sps_origin = DerivOriginCoerce meth t1 t2 sa_wildcard , sps_type_or_kind = TypeLevel } | meth <- meths , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs - inst_tys ty meth ] + inst_tys rep_ty meth + -- If we have class C a b c where { op :: op_ty } + -- and inst_tys = [t1, t2, t3] + -- then t1 = op_ty{t1,t2,rep_ty/a,b,c] + -- t2 = op_ty{t1,t2,t3/a,b,c] + , let (tvs1, theta1, tau1) = tcSplitSigmaTy t1 + , let (tvs2, theta2, tau2) = tcSplitSigmaTy t2 + ] - pure (meth_preds rep_ty) + pure meth_preds {- Note [Inferring the instance context] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -551,7 +570,72 @@ a context for the Data instances: instance Typeable a => Data (T a) where ... +Note [Inferred contexts from method constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the `deriving Alt` part of this example (from the passing part of +T20815a): + class Alt f where + some :: forall a. Applicative f => f a -> f [a] + + newtype T f a = T (f a) deriving Alt + +We will produce this derived instance declaration: + + instance (Alt f, ???) => Alt (T f) where + some :: forall a. Applicative (T f) => T f a -> T f [a] + some @a (d1 :: Applicative (T f)) + = coerce @(f a -> f [a]) + @(T f a -> T f [a]) + (d2 :: Coercible (f a -> f [a]) (T f a -> T f [a])) + (some @f (d3 :: Alt f) @a (d4 :: Applicative f)) + +(Dictionary abstractions and applications are added here even though they are +not usually visible, or even emitted in the code generated by `deriving`.) + +The task of `inferConstraints` is to determine the `???` such that it will be +sufficient to solve the constraints arising from that definition of `some`. We +can write out what the type checker sees as follows: + + forall f + [G] Alt f -- Given + [G] ??? -- Given + => + forall a. + [G] Applicative (T f) -- Also given (as d1) + => + [W] Coercible (f a -> f [a]) (T f a -> T f [a]) -- Wanted (as d2) + [W] Alt f -- Wanted (as d3) + [W] Applicative f -- Wanted (as d4) + +`d3` is trivially provided by the given `Alt f`. The simplest way to ensure that +`d4` and `d2` can be solved is to: + +* Generate this "target constraint" (in `inferConstraintsCoerceBased`): + + forall a. Applicative (T f) + => ( Coercible (f a -> f [a]) (T f a -> T f [a]) + , Applicative f + ) + +* Simplify the target constraint (in `simplifyInstanceContexts`, which in turn + calls `simplifyDeriv`). This solves the `Coercible` constraint outright, but + cannot solve the `Applicative f` constraint. + See Note [Simplifying the instance context] + +* The leftover, unsolved constraint (here `Applicative f`) becomes the `???` in + the derived instance decl. + +The target constraint for GND is created in `inferConstraintsCoerceBased`. + +In general, the point here is that the inferred context for a derived instance +must include, for each class method with constraints, a quantified constraint +mapping the provided context for the derived method to both: + - the `Coercible` corresponding to the monotypes of the base and derived + methods, and + - the needed context for the base method. + + ************************************************************************ * * Finding the fixed point of deriving equations @@ -715,10 +799,6 @@ -- See Note [Deterministic simplifyInstanceContexts] canSolution = map (sortBy nonDetCmpType) -derivInstCtxt :: PredType -> SDoc -derivInstCtxt pred - = text "When deriving the instance for" <+> parens (ppr pred) - {- *********************************************************************************** * * @@ -737,7 +817,7 @@ , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs , ds_skol_info = skol_info, ds_user_ctxt = user_ctxt }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt (mkClassPred clas inst_tys)) $ + addErrCtxt (DerivInstCtxt (mkClassPred clas inst_tys)) $ do { -- See [STEP DAC BUILD] -- Generate the implication constraints, one for each method, to solve @@ -763,9 +843,11 @@ -- See [STEP DAC HOIST] -- From the simplified constraints extract a subset 'good' that will -- become the context 'min_theta' for the derived instance. - ; let residual_simple = approximateWC True solved_wanteds - head_size = pSizeClassPred clas inst_tys - good = mapMaybeBag get_good residual_simple + ; let residual_simple = approximateWC False solved_wanteds + -- False: ignore any non-quantifiable constraints, + -- including equalities hidden under Given equalities + head_size = pSizeClassPred clas inst_tys + good = mapMaybeBag get_good residual_simple -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is -- suitable to be inferred in the context of a derived instance. diff --git a/GHC/Tc/Deriv/Utils.hs b/GHC/Tc/Deriv/Utils.hs --- a/GHC/Tc/Deriv/Utils.hs +++ b/GHC/Tc/Deriv/Utils.hs @@ -26,6 +26,7 @@ import GHC.Prelude +import GHC.Hs.Extension import GHC.Data.Bag import GHC.Types.Basic @@ -51,25 +52,26 @@ import GHC.Hs import GHC.Driver.Session import GHC.Unit.Module (getModule) +import GHC.Unit.Module.Warnings import GHC.Unit.Module.ModIface (mi_fix) -import GHC.Types.Fixity.Env (lookupFixity) import GHC.Iface.Load (loadInterfaceForName) + +import GHC.Types.Fixity.Env (lookupFixity) import GHC.Types.Name import GHC.Types.SrcLoc -import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Builtin.Names import GHC.Builtin.Names.TH (liftClassKey) +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Unique (sameUnique) import Control.Monad.Trans.Reader -import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe) @@ -90,12 +92,9 @@ -- | Is GHC processing a standalone deriving declaration with an -- extra-constraints wildcard as the context? -- (e.g., @deriving instance _ => Eq (Foo a)@) -isStandaloneWildcardDeriv :: DerivM Bool -isStandaloneWildcardDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = False +isStandaloneWildcardDeriv :: DerivContext -> Bool +isStandaloneWildcardDeriv (InferContext wildcard) = isJust wildcard +isStandaloneWildcardDeriv (SupplyContext {}) = False -- | Return 'InstDeclCtxt' if processing with a standalone @deriving@ -- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause. @@ -107,12 +106,8 @@ go (InferContext Just{}) = InstDeclCtxt True go (InferContext Nothing) = DerivClauseCtxt --- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True', --- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting. mkDerivOrigin :: Bool -> CtOrigin -mkDerivOrigin standalone_wildcard - | standalone_wildcard = StandAloneDerivOrigin - | otherwise = DerivClauseOrigin +mkDerivOrigin standalone = DerivOrigin standalone -- | Contains all of the information known about a derived instance when -- determining what its @EarlyDerivSpec@ should be. @@ -144,6 +139,8 @@ , denv_strat :: Maybe (DerivStrategy GhcTc) -- ^ 'Just' if user requests a particular deriving strategy. -- Otherwise, 'Nothing'. + , denv_warn :: Maybe (WarningTxt GhcRn) + -- ^ A warning to emit whenever the derived instance is used } instance Outputable DerivEnv where @@ -175,7 +172,8 @@ , ds_standalone_wildcard :: Maybe SrcSpan -- See Note [Inferring the instance context] -- in GHC.Tc.Deriv.Infer - , ds_mechanism :: DerivSpecMechanism } + , ds_mechanism :: DerivSpecMechanism + , ds_warn :: Maybe (WarningTxt GhcRn)} -- This spec implies a dfun declaration of the form -- df :: forall tvs. theta => C tys -- The Name is the name for the DFun we'll build @@ -558,11 +556,19 @@ SimplePredSpec { sps_pred :: TcPredType -- ^ The constraint to emit as a wanted + -- Usually just a simple predicate like (Eq a) or (ki ~# Type), + -- but can be a forall-constraint: + -- * in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased + -- * if a class has quantified-constraint superclasses, + -- via `mkDirectThetaSpec` in `inferConstraints` + , sps_origin :: CtOrigin -- ^ The origin of the constraint + , sps_type_or_kind :: TypeOrKind -- ^ Whether the constraint is a type or kind } + | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an @@ -672,8 +678,8 @@ -- @deriving@ declaration -> ThetaSpec -- ^ The specs from which constraints will be created -> TcM (TcLevel, WantedConstraints) -captureThetaSpecConstraints user_ctxt theta = - pushTcLevelM $ mk_wanteds theta +captureThetaSpecConstraints user_ctxt theta + = pushTcLevelM $ mk_wanteds theta where -- Create the constraints we need to solve. For stock and newtype -- deriving, these constraints will be simple wanted constraints @@ -684,34 +690,28 @@ mk_wanteds :: ThetaSpec -> TcM WantedConstraints mk_wanteds preds = do { (_, wanteds) <- captureConstraints $ - traverse_ emit_constraints preds + mapM_ (emitPredSpecConstraints user_ctxt) preds ; pure wanteds } - -- Emit the appropriate constraints depending on what sort of - -- PredSpec we are dealing with. - emit_constraints :: PredSpec -> TcM () - emit_constraints ps = - case ps of - -- For constraints like (C a, Ord b), emit the - -- constraints directly as simple wanted constraints. - SimplePredSpec { sps_pred = wanted - , sps_origin = orig - , sps_type_or_kind = t_or_k - } -> do - ev <- newWanted orig (Just t_or_k) wanted - emitSimple (mkNonCanonical ev) +emitPredSpecConstraints :: UserTypeCtxt -> PredSpec -> TcM () +--- Emit the appropriate constraints depending on what sort of +-- PredSpec we are dealing with. +emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred + , sps_origin = orig + , sps_type_or_kind = t_or_k }) + = do { ev <- newWanted orig (Just t_or_k) wanted_pred + ; emitSimple (mkNonCanonical ev) } - -- For DeriveAnyClass, check if ty_actual is a subtype of - -- ty_expected, which emits an implication constraint as a - -- side effect. See - -- Note [Gathering and simplifying constraints for DeriveAnyClass]. - -- in GHC.Tc.Deriv.Infer. - SubTypePredSpec { stps_ty_actual = ty_actual - , stps_ty_expected = ty_expected - , stps_origin = orig - } -> do - _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected - return () +emitPredSpecConstraints user_ctxt + (SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected + , stps_origin = orig }) +-- For DeriveAnyClass, check if ty_actual is a subtype of ty_expected, +-- which emits an implication constraint as a side effect. See +-- Note [Gathering and simplifying constraints for DeriveAnyClass] +-- in GHC.Tc.Deriv.Infer. + = do { _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected + ; return () } {- ************************************************************************ @@ -922,6 +922,7 @@ cond_vanilla `andCond` cond_Representable1Ok) | sameUnique cls_key liftClassKey = Just (checkFlag LangExt.DeriveLift `andCond` + checkFlag LangExt.ImplicitStagePersistence `andCond` cond_vanilla `andCond` cond_args cls) | otherwise = Nothing @@ -1182,8 +1183,9 @@ newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode , ds_tvs = tvs, ds_theta = theta - , ds_cls = clas, ds_tys = tys }) - = newClsInst overlap_mode dfun_name tvs theta clas tys + , ds_cls = clas, ds_tys = tys + , ds_warn = warn }) + = newClsInst overlap_mode dfun_name tvs theta clas tys warn extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances; don't bother to check diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs --- a/GHC/Tc/Errors.hs +++ b/GHC/Tc/Errors.hs @@ -1,18 +1,18 @@ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, warnDefaulting, -- * GHC API helper functions - solverReportMsg_ExpectedActuals, + solverReportMsg_ExpectedActuals, mismatchMsg_ExpectedActuals ) where import GHC.Prelude @@ -29,16 +29,16 @@ 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 import GHC.Tc.Zonk.TcType import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence -import GHC.Tc.Types.EvTerm import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate -import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit ) +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig ) import GHC.Types.Name import GHC.Types.Name.Reader @@ -52,7 +52,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 @@ -60,6 +59,7 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Ppr ( pprTyVars ) +import GHC.Core.TyCo.Tidy import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.DataCon @@ -78,11 +78,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 {- ************************************************************************ @@ -217,7 +216,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 @@ -226,8 +226,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 ] @@ -262,16 +266,13 @@ important ctxt doc = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc , sr_supplementary = [] - , sr_hints = [] } + , sr_hints = noHints + } add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp }) = report { sr_supplementary = SupplementaryBindings binds : supp } -add_report_hints :: [GhcHint] -> SolverReport -> SolverReport -add_report_hints hints report@(SolverReport { sr_hints = prev_hints }) - = report { sr_hints = prev_hints ++ hints } - -- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred deferringAnyBindings :: SolverReportErrCtxt -> Bool -- Don't check cec_type_holes, as these don't cause bindings to be deferred @@ -397,13 +398,6 @@ | null redundant_evs = return () - -- Do not report redundant constraints for quantified constraints - -- See (RC4) in Note [Tracking redundant constraints] - -- Fortunately it is easy to spot implications constraints that arise - -- from quantified constraints, from their SkolInfo - | InstSkol (IsQC {}) _ <- info - = return () - | SigSkol user_ctxt _ _ <- info -- When dealing with a user-written type signature, -- we want to add "In the type signature for f". @@ -422,20 +416,16 @@ -> TcRn () report_redundant_msg show_info lcl_env = do { msg <- - mkErrorReport - lcl_env + mkErrorReport lcl_env (TcRnRedundantConstraints redundant_evs (info, show_info)) - (Just ctxt) - [] + (Just ctxt) [] [] ; reportDiagnostic msg } reportBadTelescope :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols - = do { msg <- mkErrorReport - env - (TcRnSolverReport report ErrorWithoutFlag noHints) - (Just ctxt) - [] + = do { msg <- mkErrorReport env + (TcRnSolverReport report ErrorWithoutFlag) + (Just ctxt) [] [] ; reportDiagnostic msg } where report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols @@ -449,10 +439,9 @@ -- See Note [Constraints to ignore]. ignoreConstraint :: Ct -> Bool ignoreConstraint ct - | AssocFamPatOrigin <- ctOrigin ct - = True - | otherwise - = False + = case ctOrigin ct of + AssocFamPatOrigin -> True -- See (CIG1) + _ -> False -- | Makes an error item from a constraint, calculating whether or not -- the item should be suppressed. See Note [Wanteds rewrite Wanteds] @@ -468,13 +457,12 @@ = do { let loc = ctLoc ct flav = ctFlavour ct - ; (suppress, m_evdest) <- case ctEvidence ct of - -- For this `suppress` stuff - -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint - CtGiven {} -> return (False, Nothing) - CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } - -> do { rewriters' <- zonkRewriterSet rewriters - ; return (not (isEmptyRewriterSet rewriters'), Just dest) } + (suppress, m_evdest) = case ctEvidence ct of + -- For this `suppress` stuff + -- see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint + CtGiven {} -> (False, Nothing) + CtWanted (WantedCt { ctev_rewriters = rws, ctev_dest = dest }) + -> (not (isEmptyRewriterSet rws), Just dest) ; let m_reason = case ct of CIrredCan (IrredCt { ir_reason = reason }) -> Just reason @@ -505,7 +493,7 @@ , text "tidy_errs =" <+> ppr tidy_errs ]) -- Catch an awkward (and probably rare) case in which /all/ errors are - -- suppressed: see Wrinkle (WRW2) in Note [Prioritise Wanteds with empty + -- suppressed: see Wrinkle (PER2) in Note [Prioritise Wanteds with empty -- RewriterSet] in GHC.Tc.Types.Constraint. -- -- Unless we are sure that an error will be reported some other way @@ -524,7 +512,7 @@ = tidy_items1 -- First, deal with any out-of-scope errors: - ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs + ; let (out_of_scope, other_holes, not_conc_errs, mult_co_errs) = partition_errors tidy_errs -- don't suppress out-of-scope errors ctxt_for_scope_errs = ctxt { cec_suppress = False } ; (_, no_out_of_scope) <- askNoErrs $ @@ -541,16 +529,23 @@ ; reportNotConcreteErrs ctxt_for_insols not_conc_errs + -- We only want to report multiplicity coercion errors for multiplicity + -- constraints which are /solved/ with a non-reflexivity coercion. We + -- over approximate here: we only report multiplicity coercion errors + -- when /all/ constraints are solved. + -- See wrinkle (DME1) in Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. + ; when (null simples) $ reportMultiplicityCoercionErrs ctxt_for_insols mult_co_errs + -- See Note [Suppressing confusing errors] - ; let (suppressed_items, items0) = partition suppress tidy_items + ; let (suppressed_items, reportable_items) = partition suppressItem tidy_items ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) - ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 + ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 reportable_items -- Now all the other constraints. We suppress errors here if -- any of the first batch failed, or if the enclosing context -- says to suppress ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 } - ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1 + ; (_, leftovers) <- tryReporters ctxt2 report2 items1 ; massertPpr (null leftovers) (text "The following unsolved Wanted constraints \ \have not been reported to the user:" @@ -561,41 +556,37 @@ -- wanted insoluble here; but do suppress inner insolubles -- if there's a *given* insoluble here (= inaccessible code) - -- Only now, if there are no errors, do we report suppressed ones - -- See Note [Suppressing confusing errors] - -- We don't need to update the context further because of the - -- whenNoErrs guard - ; whenNoErrs $ - do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items + -- If there are no other errors to report, report suppressed errors. + -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors + -- we might have reported warnings only from `reportable_items`, but we + -- still want to suppress the `suppressed_items`. + ; when (null reportable_items) $ + do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) + suppressed_items + -- ctxt_for_insols: the suppressed errors can be Int~Bool, which + -- will have made the incoming `ctxt` be True; don't make that + -- suppress the Int~Bool error! ; massertPpr (null more_leftovers) (ppr more_leftovers) } } where env = cec_tidy ctxt tidy_cts = bagToList (mapBag (tidyCt env) simples) tidy_errs = bagToList (mapBag (tidyDelayedError env) errs) - partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError]) - partition_errors = go [] [] [] - where - go out_of_scope other_holes syn_eqs [] - = (out_of_scope, other_holes, syn_eqs) - go es1 es2 es3 (err:errs) - | (es1, es2, es3) <- go es1 es2 es3 errs - = case err of - DE_Hole hole - | isOutOfScopeHole hole - -> (hole : es1, es2, es3) - | otherwise - -> (es1, hole : es2, es3) - DE_NotConcrete err - -> (es1, es2, err : es3) - - -- See Note [Suppressing confusing errors] - suppress :: ErrorItem -> Bool - suppress item - | Wanted <- ei_flavour item - = is_ww_fundep_item item - | otherwise - = False + partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError], [(TcCoercion, CtLoc)]) + partition_errors [] + = ([], [], [], []) + partition_errors (err:errs) + | (es1, es2, es3, es4) <- partition_errors errs + = case err of + DE_Hole hole + | isOutOfScopeHole hole + -> (hole : es1, es2, es3, es4) + | otherwise + -> (es1, hole : es2, es3, es4) + DE_NotConcrete err + -> (es1, es2, err : es3, es4) + DE_Multiplicity mult_co loc + -> (es1, es2, es3, (mult_co, loc):es4) -- report1: ones that should *not* be suppressed by -- an insoluble somewhere else in the tree @@ -603,34 +594,53 @@ -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise -- we might suppress its error message, and proceed on past -- type checking to get a Lint error later - report1 = [ ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) - -- (Handles TypeError and Unsatisfiable) + report1 = [ -- We put implicit lifting errors first, because are solid errors + -- See "Implicit lifting" in GHC.Tc.Gen.Splice + -- Note [Lifecycle of an untyped splice, and PendingRnSplice] + ("implicit lifting", is_implicit_lifting, True, mkImplicitLiftingReporter) + -- Next, solid equality errors , given_eq_spec , ("insoluble2", utterly_wrong, True, mkGroupReporter mkEqErr) , ("skolem eq1", very_wrong, True, mkSkolReporter) , ("FixedRuntimeRep", is_FRR, True, mkGroupReporter mkFRRErr) , ("skolem eq2", skolem_eq, True, mkSkolReporter) + + -- Next, custom type errors + -- See Note [Custom type errors in constraints] in GHC.Tc.Types.Constraint + -- + -- Put custom type errors /after/ solid equality errors. In #26255 we + -- had a custom error (T <= F alpha) which was suppressing a far more + -- informative (K Int ~ [K alpha]). That mismatch between K and [] is + -- definitely wrong; and if it was fixed we'd know alpha:=Int, and hence + -- perhaps be able to solve T <= F alpha, by reducing F Int. + -- + -- But put custom type errors /before/ "non-tv eq", because if we have + -- () ~ TypeError blah + -- we want to report it as a custom error, /not/ as a mis-match + -- between TypeError and ()! Also see the Assert example + -- in Note [Custom type errors in constraints] + , ("custom_error", is_user_type_error, True, mkUserTypeErrorReporter) + -- (Handles TypeError and Unsatisfiable) + + -- "non-tv-eq": equalities (ty1 ~ ty2) where ty1 is not a tyvar , ("non-tv eq", non_tv_eq, True, mkSkolReporter) -- The only remaining equalities are alpha ~ ty, -- where alpha is untouchable; and representational equalities -- Prefer homogeneous equalities over hetero, because the -- former might be holding up the latter. - -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality + -- See Note [Equalities with heterogeneous kinds] in GHC.Tc.Solver.Equality , ("Homo eqs", is_homo_equality, True, mkGroupReporter mkEqErr) , ("Other eqs", is_equality, True, mkGroupReporter mkEqErr) + ] -- report2: we suppress these if there are insolubles elsewhere in the tree report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] - - -- report3: suppressed errors should be reported as categorized by either report1 - -- or report2. Keep this in sync with the suppress function above - report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr) - ] + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) + , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] -- rigid_nom_eq, rigid_nom_tv_eq, is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool @@ -667,6 +677,11 @@ -- See also Note [Implementation of Unsatisfiable constraints], point (F). is_user_type_error item _ = containsUserTypeError (errorItemPred item) + is_implicit_lifting item _ = + case (errorItemOrigin item) of + ImplicitLiftOrigin {} -> True + _ -> False + is_homo_equality _ (EqPred _ ty1 ty2) = typeKind ty1 `tcEqType` typeKind ty2 is_homo_equality _ _ @@ -684,9 +699,8 @@ is_irred _ (IrredPred {}) = True is_irred _ _ = False - -- See situation (1) of Note [Suppressing confusing errors] - is_ww_fundep item _ = is_ww_fundep_item item - is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin + is_qc _ (ForAllPred {}) = True + is_qc _ _ = False given_eq_spec -- See Note [Given errors] | has_gadt_match_here @@ -713,6 +727,16 @@ = has_gadt_match implics --------------- +suppressItem :: ErrorItem -> Bool + -- See Note [Suppressing confusing errors] +suppressItem item + | Wanted <- ei_flavour item + , let orig = errorItemOrigin item + = isWantedSuperclassOrigin orig -- See (SCE1) + || isWantedWantedFunDepOrigin orig -- See (SCE2) + | otherwise + = False + isSkolemTy :: TcLevel -> Type -> Bool -- The type is a skolem tyvar isSkolemTy tc_lvl ty @@ -735,9 +759,25 @@ Certain errors we might encounter are potentially confusing to users. If there are any other errors to report, at all, we want to suppress these. -Which errors (only 1 case right now): +Which errors are suppressed? -1) Errors which arise from the interaction of two Wanted fun-dep constraints. +(SCE1) Superclasses of Wanteds. These are generated only in case they trigger functional + dependencies. If such a constraint is unsolved, then its "parent" constraint must + also be unsolved, and is much more informative to the user. Example (#26255): + class (MinVersion <= F era) => Era era where { ... } + f :: forall era. EraFamily era -> IO () + f = ..blah... -- [W] Era era + Here we have simply omitted "Era era =>" from f's type. But we'll end up with + /two/ Wanted constraints: + [W] d1 : Era era + [W] d2 : MinVersion <= F era -- Superclass of d1 + We definitely want to report d1 and not d2! Happily it's easy to filter out those + superclass-Wanteds, becuase their Origin betrays them. + + See test T18851 for an example of how it is (just, barely) possible for the /only/ + errors to be superclass-of-Wanted constraints. + +(SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints. Example: class C a b | a -> b where @@ -780,7 +820,7 @@ Currently, the constraints to ignore are: -1) Constraints generated in order to unify associated type instance parameters +(CIG1) Constraints generated in order to unify associated type instance parameters with class parameters. Here are two illustrative examples: class C (a :: k) where @@ -808,6 +848,9 @@ If there is any trouble, checkValidFamInst bleats, aborting compilation. +(Note: Aug 25: this seems a rather tricky corner; + c.f. Note [Suppressing confusing errors]) + Note [Implementation of Unsatisfiable constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Unsatisfiable constraint was introduced in GHC proposal #433 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst). @@ -953,7 +996,7 @@ -- Suppress duplicates with either the same LHS, or same location -- Pre-condition: all items are equalities mkSkolReporter ctxt items - = mapM_ (reportGroup mkEqErr ctxt) (group (toList items)) + = mapM_ (reportGroup (mkEqErr ctxt) ctxt) (group (toList items)) where group [] = [] group (item:items) = (item :| yeses) : group noes @@ -1024,7 +1067,7 @@ reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM () reportNotConcreteErrs _ [] = return () reportNotConcreteErrs ctxt errs@(err0:_) - = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) [] + = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) [] [] ; reportDiagnostic msg } where @@ -1032,7 +1075,7 @@ frr_origins = acc_errors errs diag = TcRnSolverReport (SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)) - ErrorWithoutFlag noHints + ErrorWithoutFlag -- Accumulate the different kind of errors arising from syntactic equality. -- (Only SynEq_FRR origin for the moment.) @@ -1043,13 +1086,25 @@ | frr_errs <- go frr_errs errs = case err of NCE_FRR - { nce_frr_origin = frr_orig - , nce_reasons = _not_conc } -> + { nce_frr_origin = frr_orig } -> FRR_Info { frr_info_origin = frr_orig - , frr_info_not_concrete = Nothing } + , frr_info_not_concrete = Nothing + , frr_info_other_origin = Nothing } : frr_errs +reportMultiplicityCoercionErrs :: SolverReportErrCtxt -> [(TcCoercion, CtLoc)] -> TcM () +reportMultiplicityCoercionErrs ctxt errs = mapM_ reportOne errs + where + reportOne :: (TcCoercion, CtLoc) -> TcM () + reportOne (_co, loc) + = do { msg <- mkErrorReport (ctLocEnv loc) diag (Just ctxt) [] [] + ; reportDiagnostic msg } + + diag = TcRnSolverReport + (SolverReportWithCtxt ctxt MultiplicityCoercionsNotSupported) + ErrorWithoutFlag + {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have module with a /lot/ of partial type signatures, and we @@ -1067,7 +1122,7 @@ mkUserTypeErrorReporter ctxt = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item ; maybeReportError ctxt (item :| []) err - ; addDeferredBinding ctxt err item } + ; addSolverDeferredBinding err item } mkUserTypeError :: ErrorItem -> TcSolverReportMsg mkUserTypeError item @@ -1080,23 +1135,41 @@ where pty = errorItemPred item +mkImplicitLiftingReporter :: Reporter +mkImplicitLiftingReporter ctxt + = mapM_ $ \item -> do { let err = mkImplicitLiftingError item + ; msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item)) err (Just ctxt) [] [] + ; reportDiagnostic msg + ; addDeferredBinding ctxt [] [] err item + } + + where + mkImplicitLiftingError :: ErrorItem -> TcRnMessage + mkImplicitLiftingError item = + case errorItemOrigin item of + ImplicitLiftOrigin (HsImplicitLiftSplice bound used gre name) -> + TcRnBadlyLevelled (LevelCheckSplice (getName name) gre) bound used (Just item) (cec_defer_type_errors ctxt) + _ -> pprPanic "mkImplicitLiftingError" (ppr item) + mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt (item:|_) = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item - ; let (implic:_) = cec_encl ctxt - -- Always non-empty when mkGivenErrorReporter is called + ; let implic = + case cec_encl ctxt of + -- cec_encl is always non-empty when mkGivenErrorReporter is called + outer_implic:_ -> outer_implic + _ -> pprPanic "mkGivenErrorReporter" (ppr item) + loc' = setCtLocEnv (ei_loc item) (ic_env implic) item' = item { ei_loc = loc' } -- For given constraints we overwrite the env (and hence src-loc) -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - ; (eq_err_msg, _hints) <- mkEqErr_help ctxt item' ty1 ty2 - -- The hints wouldn't help in this situation, so we discard them. - ; let supplementary = [ SupplementaryBindings relevant_binds ] - msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg) - ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary + ; eq_err_msg <- mkEqErr_help ctxt item' ty1 ty2 + ; let msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg) + ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) [SupplementaryBindings relevant_binds] [] ; reportDiagnostic msg } where (ty1, ty2) = getEqPredTys (errorItemPred item) @@ -1149,7 +1222,7 @@ -- Group together errors from same location, -- and report only the first (to avoid a cascade) mkGroupReporter mk_err ctxt items - = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc (toList items)) + = mapM_ (reportGroup (mk_err ctxt) ctxt) (equivClasses cmp_loc (toList items)) eq_lhs_type :: ErrorItem -> ErrorItem -> Bool eq_lhs_type item1 item2 @@ -1165,9 +1238,9 @@ -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport) -> Reporter +reportGroup :: (NonEmpty ErrorItem -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt items - = do { err <- mk_err ctxt items + = do { err <- mk_err items ; traceTc "About to maybeReportErr" $ vcat [ text "Constraint:" <+> ppr items , text "cec_suppress =" <+> ppr (cec_suppress ctxt) @@ -1175,7 +1248,7 @@ ; maybeReportError ctxt items err -- But see Note [Always warn with -fdefer-type-errors] ; traceTc "reportGroup" (ppr items) - ; mapM_ (addDeferredBinding ctxt err) items } + ; mapM_ (addSolverDeferredBinding err) items } -- Add deferred bindings for all -- Redundant if we are going to abort compilation, -- but that's hard to know for sure, and if we don't @@ -1183,7 +1256,8 @@ -- See Note [No deferring for multiplicity errors] nonDeferrableOrigin :: CtOrigin -> Bool -nonDeferrableOrigin NonLinearPatternOrigin = True +nonDeferrableOrigin (NonLinearPatternOrigin {}) = True +nonDeferrableOrigin (OmittedFieldOrigin {}) = True nonDeferrableOrigin (UsageEnvironmentOf {}) = True nonDeferrableOrigin (FRROrigin {}) = True nonDeferrableOrigin _ = False @@ -1193,7 +1267,7 @@ -> SolverReport -> TcM () maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important , sr_supplementary = supp - , sr_hints = hints }) + , sr_hints = hints }) = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic || all ei_suppress items) $ -- if they're all to be suppressed, report nothing @@ -1203,35 +1277,57 @@ do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag | otherwise = cec_defer_type_errors ctxt -- See Note [No deferring for multiplicity errors] - diag = TcRnSolverReport important reason hints - msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp + diag = TcRnSolverReport important reason + msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints reportDiagnostic msg -addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding :: SolverReport -> ErrorItem -> TcM () +addSolverDeferredBinding err item = + let ctxt = reportContext . sr_important_msg $ err + supp = sr_supplementary err + hints = sr_hints err + important = sr_important_msg err + in addDeferredBinding ctxt supp hints (TcRnSolverReport important ErrorWithoutFlag) item + + +addDeferredBinding :: SolverReportErrCtxt -> [SupplementaryInfo] -> [GhcHint] -> TcRnMessage -> ErrorItem -> TcM () -- See Note [Deferring coercion errors to runtime] -addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty - , ei_loc = loc }) - -- if evdest is Just, then the constraint was from a wanted +addDeferredBinding ctxt supp hints msg (EI { ei_evdest = Just dest + , ei_pred = item_ty + , ei_loc = loc }) + -- if evdest is Just, then the constraint was from a wanted | deferringAnyBindings ctxt - = do { err_tm <- mkErrorTerm ctxt loc item_ty err + = do { err_tm <- mkErrorTerm loc item_ty ctxt msg supp hints ; let ev_binds_var = cec_binds ctxt ; case dest of 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 +addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given -mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type -- of the error term - -> SolverReport -> TcM EvTerm -mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp }) +mkSolverErrorTerm :: CtLoc -> Type -- of the error term + -> SolverReport -> TcM EvTerm +mkSolverErrorTerm ct_loc ty err + = mkErrorTerm ct_loc ty (reportContext . sr_important_msg $ err) + (TcRnSolverReport (sr_important_msg err) ErrorWithoutFlag) + (sr_supplementary err) + (sr_hints err) + +mkErrorTerm :: CtLoc -> Type -- of the error term + -> SolverReportErrCtxt -> TcRnMessage + -> [SupplementaryInfo] -> [GhcHint] -> TcM EvTerm +mkErrorTerm ct_loc ty ctxt msg supp hints = do { msg <- mkErrorReport (ctLocEnv ct_loc) - (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp + msg + (Just $ ctxt) + supp + hints -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" ; dflags <- getDynFlags ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg @@ -1287,74 +1383,22 @@ -- ^ The context to add, after the main diagnostic -- but before the supplementary information. -- Nothing <=> don't add any context. - -> [SolverReportSupplementary] + -> [SupplementaryInfo] -- ^ Supplementary information, to be added at the end of the message. + -> [GhcHint] + -- ^ Suggested fixes -> TcM (MsgEnvelope TcRnMessage) -mkErrorReport tcl_env msg mb_ctxt supplementary - = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt +mkErrorReport tcl_env msg mb_ctxt supp hints + = do { mb_context <- traverse (\ ctxt -> mkErrCtxt (cec_tidy ctxt) (ctl_ctxt tcl_env)) mb_ctxt ; unit_state <- hsc_units <$> getTopEnv ; hfdc <- getHoleFitDispConfig ; let - err_info = - ErrInfo - (fromMaybe empty mb_context) - (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) - ; let detailed_msg = mkDetailedMessage err_info msg + err_info = ErrInfo (fromMaybe [] mb_context) (Just (hfdc, supp)) hints + detailed_msg = mkDetailedMessage err_info msg ; mkTcRnMessage (RealSrcSpan (ctl_loc tcl_env) Strict.Nothing) (TcRnMessageWithInfo unit_state $ detailed_msg) } - - --- | Pretty-print supplementary information, to add to an error report. -pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc --- This function should be in "GHC.Tc.Errors.Ppr", --- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. -pprSolverReportSupplementary hfdc = \case - SupplementaryBindings binds -> pprRelevantBindings binds - SupplementaryHoleFits fits -> pprValidHoleFits hfdc fits - SupplementaryCts cts -> pprConstraintsInclude cts - --- | Display a collection of valid hole fits. -pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc --- This function should be in "GHC.Tc.Errors.Ppr", --- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. -pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs)) - = fits_msg $$ refs_msg - - where - fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc - fits_msg = ppUnless (null fits) $ - hang (text "Valid hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) fits) - $$ ppWhen discarded_fits fits_discard_msg - refs_msg = ppUnless (null refs) $ - hang (text "Valid refinement hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) refs) - $$ ppWhen discarded_refs refs_discard_msg - fits_discard_msg = - text "(Some hole fits suppressed;" <+> - text "use -fmax-valid-hole-fits=N" <+> - text "or -fno-max-valid-hole-fits)" - refs_discard_msg = - text "(Some refinement hole fits suppressed;" <+> - text "use -fmax-refinement-hole-fits=N" <+> - text "or -fno-max-refinement-hole-fits)" - --- | Add a "Constraints include..." message. --- --- See Note [Constraints include ...] -pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc --- This function should be in "GHC.Tc.Errors.Ppr", --- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. -pprConstraintsInclude cts - = ppUnless (null cts) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint cts) - where - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - {- Note [Always warn with -fdefer-type-errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When -fdefer-type-errors is on we warn about *all* type errors, even @@ -1371,23 +1415,22 @@ Note [No deferring for multiplicity errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify, +As explained in Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify, linear types do not support casts and any nontrivial coercion will raise -an error during desugaring. +an error at the end of typechecking (a delayed error). This means that even if we defer a multiplicity mismatch during typechecking, -the desugarer will refuse to compile anyway. Worse: the error raised -by the desugarer would shadow the type mismatch warnings (#20083). -As a solution, we refuse to defer submultiplicity constraints. Test: T20083. +the desugarer will refuse to compile anyway. Worse: the delayed error would +shadow the type mismatch warnings (#20083). As a solution, we refuse to defer +submultiplicity constraints. Test: T20083. To determine whether a constraint arose from a submultiplicity check, we -look at the CtOrigin. All calls to tcSubMult use 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 --fdefer-type-errors, but the current implementation does not always -place the wrapper in the right place and the resulting program can fail Lint. +In the future, we should compile unsolved multiplicity constraints to a runtime error with +-fdefer-type-errors, but there's currently no good way to insert this type error +in the desugared program. Especially in a way that would pass the linter. This plan is tracked in #20083. Note [Deferred errors for coercion holes] @@ -1418,7 +1461,6 @@ {- Note [Constructing Hole Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms, these "hole" errors are /not/ suppressed by cec_suppress. We want to see them! @@ -1453,20 +1495,28 @@ ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) -mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) +mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_sort = sort, hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole = do { (imp_errs, hints) - <- unknownNameSuggestions (ctl_rdr lcl_env) WL_Anything occ + <- unknownNameSuggestions (ctl_rdr lcl_env) what_look occ ; let - err = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs) - report = SolverReport err [] hints + err = SolverReportWithCtxt ctxt + $ ReportHoleError hole OutOfScopeHole + supp = [ SupplementaryImportErrors imps | imps <- maybeToList (NE.nonEmpty imp_errs) ] - ; maybeAddDeferredBindings ctxt hole report - ; mkErrorReport lcl_env (TcRnSolverReport err (cec_out_of_scope_holes ctxt) hints) Nothing [] - -- Pass the value 'Nothing' for the context, as it's generally not helpful - -- to include the context here. + ; maybeAddDeferredBindings hole $ SolverReport err supp hints + ; mkErrorReport lcl_env + ( TcRnSolverReport err (cec_out_of_scope_holes ctxt) + ) + Nothing supp hints + -- Pass the value 'Nothing' for the context, as it's generally not helpful + -- to include the context here. } where + what_look = case sort of + ExprHole {} -> WL_Term + TypeHole {} -> WL_Type + ConstraintHole {} -> WL_Type lcl_env = ctLocEnv ct_loc -- general case: not an out-of-scope error @@ -1492,14 +1542,16 @@ ; (grouped_skvs, other_tvs) <- liftZonkM $ zonkAndGroupSkolTvs hole_ty ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - err = SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs - supp = [ SupplementaryBindings rel_binds - , SupplementaryCts relevant_cts - , SupplementaryHoleFits hole_fits ] - - ; maybeAddDeferredBindings ctxt hole (SolverReport err supp []) + err = SolverReportWithCtxt ctxt + $ ReportHoleError hole + $ HoleError sort other_tvs grouped_skvs + supp = [ SupplementaryBindings rel_binds ] + ++ [ SupplementaryCts cts | cts <- maybeToList (NE.nonEmpty relevant_cts) ] + ++ [ SupplementaryHoleFits hole_fits ] - ; mkErrorReport lcl_env (TcRnSolverReport err reason noHints) (Just ctxt) supp + ; maybeAddDeferredBindings hole (SolverReport err supp noHints) + ; let msg = TcRnSolverReport err reason + ; mkErrorReport lcl_env msg (Just ctxt) supp noHints } where @@ -1528,33 +1580,32 @@ {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - When working with typed holes we have to deal with the case where we want holes to be reported as warnings to users during compile time but as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings' so that the correct 'Severity' can be computed out of that later on. - -} -- | Adds deferred bindings (as errors). -- See Note [Adding deferred bindings]. -maybeAddDeferredBindings :: SolverReportErrCtxt - -> Hole +maybeAddDeferredBindings :: Hole -> SolverReport -> TcM () -maybeAddDeferredBindings ctxt hole report = do +maybeAddDeferredBindings hole report = do case hole_sort hole of ExprHole (HER ref ref_ty _) -> do -- Only add bindings for holes in expressions -- not for holes in partial type signatures -- cf. addDeferredBinding when (deferringAnyBindings ctxt) $ do - err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report + err_tm <- mkSolverErrorTerm (hole_loc hole) ref_ty report -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. - -- See Note [Holes] in GHC.Tc.Types.Constraint + -- See Note [Holes in expressions] in GHC.Hs.Expr writeMutVar ref err_tm _ -> pure () + where + ctxt = reportContext $ sr_important_msg $ report -- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module -- imports @@ -1575,10 +1626,11 @@ mk_wanted :: ErrorItem -> Maybe CtEvidence mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc }) | Just dest <- m_dest - = Just (CtWanted { ctev_pred = pred - , ctev_dest = dest - , ctev_loc = loc - , ctev_rewriters = emptyRewriterSet }) + = Just $ CtWanted $ + WantedCt { ctev_pred = pred + , ctev_dest = dest + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } | otherwise = Nothing -- The ErrorItem was a Given @@ -1616,7 +1668,7 @@ -- Zonk/tidy to show useful variable names. nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $ -- Remove duplicates: only one representation-polymorphism error per type. - map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe) $ + map (expectJust . fixedRuntimeRepOrigin_maybe) $ toList items ; return $ important ctxt $ FixedRuntimeRepError frr_infos } @@ -1624,14 +1676,25 @@ fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo fixedRuntimeRepOrigin_maybe item -- An error that arose directly from a representation-polymorphism check. - | FRROrigin frr_orig <- errorItemOrigin item + | FRROrigin frr_orig <- orig = Just $ FRR_Info { frr_info_origin = frr_orig - , frr_info_not_concrete = Nothing } - -- Unsolved nominal equalities involving a concrete type variable, + , frr_info_not_concrete = Nothing + , frr_info_other_origin = Nothing + } + -- A nominal equality involving a concrete type variable, -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a - -- type family application @RR@, are handled by 'mkTyVarEqErr''. + -- type family application @RR@. + | EqPred NomEq ty1 ty2 <- classifyPredType (errorItemPred item) + = if | Just (tv1, ConcreteFRR frr1) <- isConcreteTyVarTy_maybe ty1 + -> Just $ FRR_Info frr1 (Just (tv1, ty2)) (Just orig) + | Just (tv2, ConcreteFRR frr2) <- isConcreteTyVarTy_maybe ty2 + -> Just $ FRR_Info frr2 (Just (tv2, ty1)) (Just orig) + | otherwise + -> Nothing | otherwise = Nothing + where + orig = errorItemOrigin item {- Note [Constraints include ...] @@ -1702,10 +1765,9 @@ -- givens handled in mkGivenErrorReporter = do { (ctxt, binds, item) <- relevantBindings True ctxt item ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item)) - ; (err_msg, hints) <- mkEqErr_help ctxt item ty1 ty2 + ; err_msg <- mkEqErr_help ctxt item ty1 ty2 ; let report = add_relevant_bindings binds - $ add_report_hints hints $ important ctxt err_msg ; return report } where @@ -1754,18 +1816,17 @@ mkEqErr_help :: SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) + -> TcType -> TcType -> TcM TcSolverReportMsg mkEqErr_help ctxt item ty1 ty2 - | Just casted_tv1 <- getCastedTyVar_maybe ty1 - = mkTyVarEqErr ctxt item casted_tv1 ty2 + | Just (tv1, _co) <- getCastedTyVar_maybe ty1 + = mkTyVarEqErr ctxt item tv1 ty2 -- ToDo: explain.. Cf T2627b Dual (Dual a) ~ a - | Just casted_tv2 <- getCastedTyVar_maybe ty2 - = mkTyVarEqErr ctxt item casted_tv2 ty1 + | Just (tv2, _co) <- getCastedTyVar_maybe ty2 + = mkTyVarEqErr ctxt item tv2 ty1 | otherwise - = do { err <- reportEqErr ctxt item ty1 ty2 - ; return (err, noHints) } + = reportEqErr ctxt item ty1 ty2 reportEqErr :: SolverReportErrCtxt -> ErrorItem @@ -1795,22 +1856,22 @@ return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem - -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) + -> TcTyVar -> TcType -> TcM TcSolverReportMsg -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt item casted_tv1 ty2 - = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2) - ; mkTyVarEqErr' ctxt item casted_tv1 ty2 } +mkTyVarEqErr ctxt item tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2) + ; mkTyVarEqErr' ctxt item tv1 ty2 } mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem - -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) -mkTyVarEqErr' ctxt item (tv1, co1) ty2 + -> TcTyVar -> TcType -> TcM TcSolverReportMsg +mkTyVarEqErr' ctxt item tv1 ty2 -- Is this a representation-polymorphism error, e.g. -- alpha[conc] ~# rr[sk] ? If so, handle that first. | Just frr_info <- mb_concrete_reason = do (_, infos) <- liftZonkM $ zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] - return (FixedRuntimeRepError infos, []) + return $ FixedRuntimeRepError infos -- Impredicativity is a simple error to understand; -- try it before anything more complicated. @@ -1831,13 +1892,7 @@ -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. - return (main_msg, []) - - -- Incompatible kinds - -- This is wrinkle (EIK2) in Note [Equalities with incompatible kinds] - -- in GHC.Tc.Solver.Equality - | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2 - = return (mkBlockedEqErr item, []) + return main_msg | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Equality.canEqTyVarHomo @@ -1852,7 +1907,7 @@ let main_msg = CannotUnifyVariable { mismatchMsg = headline_msg , cannotUnifyReason = reason } - return (main_msg, add_sig) + return main_msg | tv1 `elemVarSet` tyCoVarsOfType ty2 -- We report an "occurs check" even for a ~ F t a, where F is a type @@ -1877,7 +1932,7 @@ { mismatchMsg = headline_msg , cannotUnifyReason = occurs_err } - in return (main_msg, []) + in return main_msg -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1893,7 +1948,7 @@ , mismatchTyVarInfo = Just tv_extra , mismatchAmbiguityInfo = [] , mismatchCoercibleInfo = Nothing } - return (msg, []) + return msg -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context @@ -1905,7 +1960,7 @@ { mismatchMsg = mismatch_msg , cannotUnifyReason = SkolemEscape item implic esc_skols } - in return (main_msg, []) + in return main_msg -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1914,8 +1969,10 @@ -- See Note [Error messages for untouchables] | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_tclvl = lvl } <- implic - = assertPpr (not (isTouchableMetaTyVar lvl tv1)) + = assertPpr (not (isTouchableMetaTyVar lvl tv1) || hasCoercionHole ty2) (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] + -- We can still get touchable meta-tyvars on the LHS if there is an + -- unsolved coercion hole, e.g. (alpha::Type) ~ Int# |> co_hole tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2 let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic } msg = Mismatch @@ -1923,18 +1980,16 @@ , mismatchTyVarInfo = Just tv_extra' , mismatchAmbiguityInfo = [] , mismatchCoercibleInfo = Nothing } - return (msg, add_sig) + return msg | otherwise - = do { err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2 - ; return (err, []) } + = reportEqErr ctxt item (mkTyVarTy tv1) ty2 -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where headline_msg = misMatchOrCND ctxt item ty1 ty2 mismatch_msg = mkMismatchMsg item ty1 ty2 - add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 -- The following doesn't use the cterHasProblem mechanism because -- we need to retrieve the ConcreteTvOrigin. Just knowing whether @@ -1953,7 +2008,8 @@ = Nothing frr_reason (ConcreteFRR frr_orig) conc_tv not_conc = FRR_Info { frr_info_origin = frr_orig - , frr_info_not_concrete = Just (conc_tv, not_conc) } + , frr_info_not_concrete = Just (conc_tv, not_conc) + , frr_info_other_origin = Just (errorItemOrigin item) } ty1 = mkTyVarTy tv1 @@ -1973,12 +2029,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) @@ -2019,14 +2080,6 @@ -- Keep only UserGivens that have some equalities. -- See Note [Suppress redundant givens during error reporting] --- These are for the "blocked" equalities, as described in GHC.Tc.Solver.Equality --- Note [Equalities with incompatible kinds], wrinkle (EIK2). There should --- always be another unsolved wanted around, which will ordinarily suppress --- this message. But this can still be printed out with -fdefer-type-errors --- (sigh), so we must produce a message. -mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg -mkBlockedEqErr item = BlockedEquality item - {- Note [Suppress redundant givens during error reporting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2092,42 +2145,15 @@ return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps) _ -> return tv - -suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint --- See Note [Suggest adding a type signature] -suggestAddSig ctxt ty1 _ty2 - | bndr : bndrs <- inferred_bndrs - = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs) - | otherwise - = Nothing - where - inferred_bndrs = - case getTyVar_maybe ty1 of - Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv - _ -> [] - - -- 'find' returns the binders of an InferSkol for 'tv', - -- provided there is an intervening implication with - -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match) - find [] _ _ = [] - find (implic:implics) seen_eqs tv - | tv `elem` ic_skols implic - , InferSkol prs <- ic_info implic - , seen_eqs - = map fst prs - | otherwise - = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv - -------------------- mkMismatchMsg :: ErrorItem -> Type -> Type -> MismatchMsg mkMismatchMsg item ty1 ty2 = case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> (TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 + { teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 , teq_mismatch_actual = uo_actual , teq_mismatch_expected = uo_expected , teq_mismatch_what = mb_thing @@ -2151,26 +2177,7 @@ where orig = errorItemOrigin item mb_same_occ = sameOccExtras ty2 ty1 - ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) --- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. --- --- This function first checks to see if the 'CtOrigin' argument is a --- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible --- equality; if it's not, definitely print the kinds. Even if the equality is --- a visible equality, check the expected/actual types to see if the types --- have equal visible components. If the 'CtOrigin' is --- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves. -shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool -shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_visible = vis }) - | not vis = True -- See tests T15870, T16204c - | otherwise = tcEqTypeVis act exp -- See tests T9171, T9144. -shouldPprWithExplicitKinds ty1 ty2 _ct - = tcEqTypeVis ty1 ty2 - {- Note [Insoluble mis-match] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble @@ -2206,33 +2213,7 @@ | otherwise = Nothing -{- Note [Suggest adding a type signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The OutsideIn algorithm rejects GADT programs that don't have a principal -type, and indeed some that do. Example: - data T a where - MkT :: Int -> T Int - - f (MkT n) = n - -Does this have type f :: T a -> a, or f :: T a -> Int? -The error that shows up tends to be an attempt to unify an -untouchable type variable. So suggestAddSig sees if the offending -type variable is bound by an *inferred* signature, and suggests -adding a declared signature instead. - -More specifically, we suggest adding a type sig if we have p ~ ty, and -p is a skolem bound by an InferSkol. Those skolems were created from -unification variables in simplifyInfer. Why didn't we unify? It must -have been because of an intervening GADT or existential, making it -untouchable. Either way, a type signature would help. For GADTs, it -might make it typeable; for existentials the attempt to write a -signature will fail -- or at least will produce a better error message -next time - -This initially came up in #8968, concerning pattern synonyms. - -Note [Disambiguating (X ~ X) errors] +{- Note [Disambiguating (X ~ X) errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #8278 @@ -2273,6 +2254,15 @@ ************************************************************************ -} +mkQCErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkQCErr ctxt items + | item1 :| _ <- tryFilter (not . ei_suppress) items + -- Ignore multiple qc-errors on the same line + = do { let msg = mkPlainMismatchMsg $ + CouldNotDeduce (getUserGivens ctxt) (item1 :| []) Nothing + ; return $ important ctxt msg } + + mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkDictErr ctxt orig_items = do { inst_envs <- tcGetInstEnvs @@ -2285,8 +2275,16 @@ -- But we report only one of them (hence 'head') because they all -- have the same source-location origin, to try avoid a cascade -- of error from one location - ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items)) - ; return $ important ctxt err } + ; ( err, (imp_errs, hints) ) <- + mk_dict_err ctxt (head (no_inst_items ++ overlap_items)) + ; return $ + SolverReport + { sr_important_msg = SolverReportWithCtxt ctxt err + , sr_supplementary = [ SupplementaryImportErrors imps + | imps <- maybeToList (NE.nonEmpty imp_errs) ] + , sr_hints = hints + } + } where items = tryFilter (not . ei_suppress) orig_items @@ -2320,25 +2318,31 @@ -- matching and unifying instances, and say "The choice depends on the instantion of ..., -- and the result of evaluating ...". mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult) - -> TcM TcSolverReportMsg -mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of + -> TcM ( TcSolverReportMsg, ([ImportError], [GhcHint]) ) +mk_dict_err ctxt (item, (matches, pot_unifiers, unsafe_overlapped)) + = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of (Nothing, _) -> do -- No matches but perhaps several unifiers { (_, rel_binds, item) <- relevantBindings True ctxt item ; candidate_insts <- get_candidate_instances ; (imp_errs, field_suggestions) <- record_field_suggestions item - ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } + ; return (CannotResolveInstance item unifiers candidate_insts rel_binds, (imp_errs, field_suggestions)) } -- Some matches => overlap errors (Just matchesNE, Nothing) -> return $ - OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers unifiers) + ( OverlappingInstances item (NE.map fst matchesNE) unifiers, ([], [])) (Just (match :| []), Just unsafe_overlappedNE) -> return $ - UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE) - (Just matches@(_ :| _), Just overlaps) -> pprPanic "mk_dict_err: multiple matches with overlap" $ vcat [ text "matches:" <+> ppr matches, text "overlaps:" <+> ppr overlaps ] + ( UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE), ([], [])) + (Just matches@(_ :| _), Just overlaps) -> + pprPanic "mk_dict_err: multiple matches with overlap" $ + vcat [ text "matches:" <+> ppr matches + , text "overlaps:" <+> ppr overlaps + ] where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred + orig = errorItemOrigin item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + unifiers = getCoherentUnifiers pot_unifiers get_candidate_instances :: TcM [ClsInst] -- See Note [Report candidate instances] @@ -2379,7 +2383,7 @@ report_no_fieldnames item | Just (EvVarDest evvar) <- ei_evdest item -- we can assume that here we have a `HasField @Symbol x r a` instance - -- because of HasFieldOrigin in record_field + -- because of GetFieldOrigin in record_field , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar) , Just (r_tycon, _) <- tcSplitTyConApp_maybe r , Just x_name <- isStrLitTy x @@ -2394,14 +2398,9 @@ isNothing (lookupLocalRdrOcc lcl_env occ_name) record_field = case orig of - HasFieldOrigin name -> Just (mkVarOccFS name) + GetFieldOrigin name -> Just (mkVarOccFS name) _ -> Nothing - cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings - -> [ImportError] -> [GhcHint] -> TcSolverReportMsg - cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions - = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds - {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have an unsolved (Num Int), where `Int` is not the Prelude Int, @@ -2459,29 +2458,6 @@ in the import of ‘Data.Monoid’ -} -{- -Note [Kind arguments in error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It can be terribly confusing to get an error message like (#9171) - - Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ - with actual type ‘GetParam Base (GetParam Base Int)’ - -The reason may be that the kinds don't match up. Typically you'll get -more useful information, but not when it's as a result of ambiguity. - -To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag -whenever any error message arises due to a kind mismatch. This means that -the above error message would instead be displayed as: - - Couldn't match expected type - ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ - with actual type - ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ - -Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. --} - ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be @@ -2604,10 +2580,10 @@ (RelevantBindings (bd:bds) discards) tc_bndrs } ----------------------- -warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () -warnDefaulting _ [] _ +warnDefaulting :: [Ct] -> TcTyVar -> Type -> TcM () +warnDefaulting [] _ _ = panic "warnDefaulting: empty Wanteds" -warnDefaulting the_tv wanteds@(ct:_) default_ty +warnDefaulting wanteds@(ct:_) the_tv default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- liftZonkM $ tcInitTidyEnv -- don't want to report all the superclass constraints, which @@ -2642,20 +2618,12 @@ -- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype -- if you just want this information, as the datatype itself is subject to change -- across GHC versions. -solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)] +solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> Maybe (Type, Type) solverReportMsg_ExpectedActuals = \case Mismatch { mismatchMsg = mismatch_msg } -> - case mismatch_msg of - BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } -> - [(exp, act)] - KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } -> - [(exp, act)] - TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } -> - [(exp,act)] - CouldNotDeduce {} -> - [] - _ -> [] + mismatchMsg_ExpectedActuals mismatch_msg + _ -> Nothing -- | Filter the list by the given predicate, but if that would be empty, -- just give back the original list. diff --git a/GHC/Tc/Errors/Hole.hs b/GHC/Tc/Errors/Hole.hs --- a/GHC/Tc/Errors/Hole.hs +++ b/GHC/Tc/Errors/Hole.hs @@ -11,7 +11,6 @@ , isFlexiTyVar , tcFilterHoleFits , getLocalBindings - , pprHoleFit , addHoleFitDocs , getHoleFitSortingAlg , getHoleFitDispConfig @@ -39,16 +38,18 @@ 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 import GHC.Core.TyCon( TyCon, isGenerativeTyCon ) import GHC.Core.TyCo.Rep( Type(..) ) import GHC.Core.DataCon import GHC.Core.Predicate( Pred(..), classifyPredType, eqRelRole ) +import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Builtin.Names ( gHC_ERR, uNSAFE_COERCE ) +import GHC.Builtin.Names ( gHC_INTERNAL_ERR, gHC_INTERNAL_UNSAFE_COERCE ) +import GHC.Builtin.Types ( tupleDataConName, unboxedSumDataConName ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -56,7 +57,6 @@ import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) import GHC.Utils.Misc -import GHC.Utils.Panic import GHC.Tc.Utils.Env (tcLookup) import GHC.Utils.Outputable import GHC.Driver.DynFlags @@ -76,7 +76,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) @@ -88,7 +88,11 @@ import GHC.Data.FastString (NonDetFastString(..)) import GHC.Types.Unique.Map +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions as LangExt + {- Note [Valid hole fits include ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -402,7 +406,7 @@ Note [Speeding up valid hole-fits] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To fix #16875 we noted that a lot of time was being spent on unecessary work. +To fix #16875 we noted that a lot of time was being spent on unnecessary work. When we'd call `tcCheckHoleFit hole hole_ty ty`, we would end up by generating a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For @@ -470,17 +474,17 @@ else return fits } where msg = text "GHC.Tc.Errors.Hole addHoleFitDocs" - upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) = + upd mb_local_docs mods_without_docs (TcHoleFit fit@(HoleFit {hfCand = cand})) = let name = getName cand in do { mb_docs <- if hfIsLcl fit then pure mb_local_docs else mi_docs <$> loadInterfaceForName msg name ; case mb_docs of - { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit) + { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, TcHoleFit fit) ; Just docs -> do { let doc = lookupUniqMap (docs_decls docs) name - ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}} - upd _ mods_without_docs fit = pure (mods_without_docs, fit) + ; return $ (mods_without_docs, TcHoleFit (fit {hfDoc = map hsDocString <$> doc})) }}} + upd _ mods_without_docs fit@(RawHoleFit {}) = pure (mods_without_docs, fit) nameOrigin name = case nameModule_maybe name of Just m -> Right m Nothing -> @@ -497,63 +501,6 @@ ; warnPprTrace (not $ Set.null mods) "addHoleFitDocs" warning (pure ()) } --- For pretty printing hole fits, we display the name and type of the fit, --- with added '_' to represent any extra arguments in case of a non-zero --- refinement level. -pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc -pprHoleFit _ (RawHoleFit sd) = sd -pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = - hang display 2 provenance - where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap - where pprArg b arg = case binderFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty - Required -> pprPanic "pprHoleFit: bad Required" - (ppr b <+> ppr arg) - tyAppVars = sep $ punctuate comma $ - zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+> - text "~" <+> pprParendType t) - vars hfWrap - - vars = unwrapTypeVars hfType - where - -- Attempts to get all the quantified type variables in a type, - -- e.g. - -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) - -- into [m, a] - unwrapTypeVars :: Type -> [ForAllTyBinder] - unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, _, _, unfunned) -> unwrapTypeVars unfunned - _ -> [] - where (vars, unforalled) = splitForAllForAllTyBinders t - holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches - holeDisp = if sMs then holeVs - else sep $ replicate (length hfMatches) $ text "_" - occDisp = case hfCand of - GreHFCand gre -> pprPrefixOcc (greName gre) - NameHFCand name -> pprPrefixOcc name - IdHFCand id_ -> pprPrefixOcc id_ - tyDisp = ppWhen sTy $ dcolon <+> ppr hfType - has = not . null - wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) - $ text "with" <+> if sWrp || not sTy - then occDisp <+> tyApp - else tyAppVars - docs = case hfDoc of - Just d -> pprHsDocStrings d - _ -> empty - funcInfo = ppWhen (has hfMatches && sTy) $ - text "where" <+> occDisp <+> tyDisp - subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp - display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) - provenance = ppWhen sProv $ parens $ - case hfCand of - GreHFCand gre -> pprNameProvenance gre - NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name) - IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_) - getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] getLocalBindings tidy_orig ct_loc = do { (env1, _) <- liftZonkM $ zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) @@ -589,6 +536,7 @@ ; maxVSubs <- maxValidHoleFits <$> getDynFlags ; sortingAlg <- getHoleFitSortingAlg ; dflags <- getDynFlags + ; let exts = extensionFlags dflags ; hfPlugs <- tcg_hf_plugins <$> getGblEnv ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs refLevel = refLevelHoleFits dflags @@ -610,7 +558,7 @@ locals = removeBindingShadowing $ map IdHFCand lclBinds ++ map GreHFCand lcl globals = map GreHFCand gbl - syntax = map NameHFCand builtIns + syntax = map NameHFCand (builtIns exts) -- If the hole is a rigid type-variable, then we only check the -- locals, since only they can match the type (in a meaningful way). only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty @@ -622,7 +570,9 @@ tcFilterHoleFits findVLimit hole (hole_ty, []) cands ; (tidy_env, tidy_subs) <- liftZonkM $ zonkSubs tidy_env subs ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs - ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins + ; let apply_plugin :: [HoleFit] -> ([HoleFit] -> TcM [HoleFit]) -> TcM [HoleFit] + apply_plugin fits plug = plug fits + ; plugin_handled_subs <- foldM apply_plugin (map TcHoleFit tidy_sorted_subs) fitPlugins ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs vDiscards = pVDisc || searchDiscards ; subs_with_docs <- addHoleFitDocs limited_subs @@ -641,19 +591,21 @@ ; traceTc "ref_tys are" $ ppr ref_tys ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing else maxRSubs - ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole) - cands) ref_tys - ; (tidy_env, tidy_rsubs) <- liftZonkM $ zonkSubs tidy_env $ concatMap snd refDs - ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs + ; refDs :: [(Bool, [TcHoleFit])] + <- mapM (flip (tcFilterHoleFits findRLimit hole) cands) ref_tys + ; (tidy_env, tidy_rsubs :: [TcHoleFit]) + <- liftZonkM $ zonkSubs tidy_env $ concatMap snd refDs + ; tidy_sorted_rsubs :: [TcHoleFit] <- sortFits sortingAlg tidy_rsubs -- For refinement substitutions we want matches -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t), -- and others in that vein to appear last, since these are -- unlikely to be the most relevant fits. ; (tidy_env, tidy_hole_ty) <- liftZonkM $ zonkTidyTcType tidy_env hole_ty ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap + exact, not_exact :: [TcHoleFit] (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs - ; plugin_handled_rsubs <- foldM (flip ($)) - (not_exact ++ exact) fitPlugins + fits :: [HoleFit] = map TcHoleFit (not_exact ++ exact) + ; plugin_handled_rsubs <- foldM apply_plugin fits fitPlugins ; let (pRDisc, exact_last_rfits) = possiblyDiscard maxRSubs $ plugin_handled_rsubs rDiscards = pRDisc || any fst refDs @@ -668,9 +620,29 @@ hole_lvl = ctLocLevel ct_loc -- BuiltInSyntax names like (:) and [] - builtIns :: [Name] - builtIns = filter isBuiltInSyntax knownKeyNames + builtIns :: EnumSet LangExt.Extension -> [Name] + builtIns exts = filter isBuiltInSyntax (knownKeyNames ++ infFamNames) + where + -- Tuples and sums of are not included in knownKeyName as there are infinitely many of them. + -- See Note [Infinite families of known-key names] in GHC.Builtin.Names. + infFamNames = + [tupleDataConName Boxed n | n <- [0..max_tup]] + ++ [tupleDataConName Unboxed n | unboxedTuples, n <- [0..max_tup]] + ++ [unboxedSumDataConName k n | unboxedSums, n <- [2..max_sum], k <- [1..n]] + -- The upper limits on arity are small to avoid bloating the list with + -- too many names, which would incur a performance cost. + -- Users are unlikely to care about larger tuples/sums anyway. + max_tup = 7 + -- Tuples up to (,,,,,,). Common limit, e.g. this is the highest tuple + -- arity that has a Functor instance. + max_sum = 7 + -- Sums up to (#||||||#). Results in 27 sum constructors because there + -- are [1..n] data constructors at each arity. + + unboxedTuples = EnumSet.member LangExt.UnboxedTuples exts + unboxedSums = EnumSet.member LangExt.UnboxedSums exts + -- We make a refinement type by adding a new type variable in front -- of the type of t h hole, going from e.g. [Integer] -> Integer -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier @@ -684,8 +656,8 @@ wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty sortFits :: HoleFitSortingAlg -- How we should sort the hole fits - -> [HoleFit] -- The subs to sort - -> TcM [HoleFit] + -> [TcHoleFit] -- The subs to sort + -> TcM [TcHoleFit] sortFits HFSNoSorting subs = return subs sortFits HFSBySize subs = (++) <$> sortHoleFitsBySize (sort lclFits) @@ -730,14 +702,13 @@ -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output. -zonkSubs :: TidyEnv -> [HoleFit] -> ZonkM (TidyEnv, [HoleFit]) +zonkSubs :: TidyEnv -> [TcHoleFit] -> ZonkM (TidyEnv, [TcHoleFit]) zonkSubs = zonkSubs' [] where zonkSubs' zs env [] = return (env, reverse zs) zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf ; zonkSubs' (z:zs) env' hfs } - zonkSub :: TidyEnv -> HoleFit -> ZonkM (TidyEnv, HoleFit) - zonkSub env hf@RawHoleFit{} = return (env, hf) + zonkSub :: TidyEnv -> TcHoleFit -> ZonkM (TidyEnv, TcHoleFit) zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp} = do { (env, ty') <- zonkTidyTcType env ty ; (env, m') <- zonkTidyTcTypes env m @@ -749,9 +720,9 @@ -- types needed to instantiate the fit to the type of the hole. -- This is much quicker than sorting by subsumption, and gives reasonable -- results in most cases. -sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] +sortHoleFitsBySize :: [TcHoleFit] -> TcM [TcHoleFit] sortHoleFitsBySize = return . sortOn sizeOfFit - where sizeOfFit :: HoleFit -> TypeSize + where sizeOfFit :: TcHoleFit -> TypeSize sizeOfFit = sizeTypes . nubBy tcEqType . hfWrap -- Based on a suggestion by phadej on #ghc, we can sort the found fits @@ -760,12 +731,12 @@ -- probably those most relevant. This takes a lot of work (but results in -- much more useful output), and can be disabled by -- '-fno-sort-valid-hole-fits'. -sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit] +sortHoleFitsByGraph :: [TcHoleFit] -> TcM [TcHoleFit] sortHoleFitsByGraph fits = go [] fits where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty) where fvs = tyCoFVsOfTypes [ht,ty] - go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit] + go :: [(TcHoleFit, [TcHoleFit])] -> [TcHoleFit] -> TcM [TcHoleFit] go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar ; return $ uncurry (++) $ partition hfIsLcl topSorted } where toV (hf, adjs) = (hf, hfId hf, map hfId adjs) @@ -787,7 +758,7 @@ -- additional holes. -> [HoleFitCandidate] -- ^ The candidates to check whether fit. - -> TcM (Bool, [HoleFit]) + -> TcM (Bool, [TcHoleFit]) -- ^ We return whether or not we stopped due to hitting the limit -- and the fits we found. tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0 @@ -802,12 +773,12 @@ -- Kickoff the checking of the elements. -- We iterate over the elements, checking each one in turn for whether -- it fits, and adding it to the results if it does. - go :: [HoleFit] -- What we've found so far. + go :: [TcHoleFit] -- What we've found so far. -> VarSet -- Ids we've already checked -> Maybe Int -- How many we're allowed to find, if limited -> (TcType, [TcTyVar]) -- The type, and its refinement variables. -> [HoleFitCandidate] -- The elements we've yet to check. - -> TcM (Bool, [HoleFit]) + -> TcM (Bool, [TcHoleFit]) go subs _ _ _ [] = return (False, reverse subs) go subs _ (Just 0) _ _ = return (True, reverse subs) go subs seen maxleft ty (el:elts) = @@ -824,7 +795,7 @@ _ -> discard_it } where -- We want to filter out undefined and the likes from GHC.Err (#17940) - not_trivial id = nameModule_maybe (idName id) `notElem` [Just gHC_ERR, Just uNSAFE_COERCE] + not_trivial id = nameModule_maybe (idName id) `notElem` [Just gHC_INTERNAL_ERR, Just gHC_INTERNAL_UNSAFE_COERCE] lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type)) lookup (IdHFCand id) = return (Just (id, idType id)) @@ -836,9 +807,6 @@ Just (dataConWrapId con, dataConNonlinearType con) _ -> Nothing } where name = case hfc of -#if __GLASGOW_HASKELL__ < 901 - IdHFCand id -> idName id -#endif GreHFCand gre -> greName gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts @@ -959,7 +927,7 @@ , th_implics = [] , th_hole = Nothing } --- | A tcSubsumes which takes into account relevant constraints, to fix trac +-- | A tcSubsumes which takes into account relevant constraints, to fix -- #14273. This makes sure that when checking whether a type fits the hole, -- the type has to be subsumed by type of the hole as well as fulfill all -- constraints on the type of the hole. diff --git a/GHC/Tc/Errors/Hole.hs-boot b/GHC/Tc/Errors/Hole.hs-boot --- a/GHC/Tc/Errors/Hole.hs-boot +++ b/GHC/Tc/Errors/Hole.hs-boot @@ -4,40 +4,13 @@ -- + which calls 'GHC.Tc.Solver.simpl_top' module GHC.Tc.Errors.Hole where -import GHC.Types.Var ( Id ) import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication ) -import GHC.Utils.Outputable ( SDoc ) +import GHC.Tc.Types.Constraint ( CtEvidence, Hole, Implication ) import GHC.Types.Var.Env ( TidyEnv ) -import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate ) -import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar ) -import GHC.Tc.Zonk.Monad ( ZonkM ) -import GHC.Tc.Types.Evidence ( HsWrapper ) -import GHC.Utils.FV ( FV ) -import Data.Bool ( Bool ) -import Data.Maybe ( Maybe ) -import Data.Int ( Int ) findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole -> TcM (TidyEnv, ValidHoleFits) -tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType - -> TcM (Bool, HsWrapper) - -withoutUnification :: FV -> TcM a -> TcM a -tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool -tcFilterHoleFits :: Maybe Int -> TypedHole -> (TcType, [TcTyVar]) - -> [HoleFitCandidate] -> TcM (Bool, [HoleFit]) -getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] -addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] - -data HoleFitSortingAlg - -pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc -getHoleFitSortingAlg :: TcM HoleFitSortingAlg getHoleFitDispConfig :: TcM HoleFitDispConfig -zonkSubs :: TidyEnv -> [HoleFit] -> ZonkM (TidyEnv, [HoleFit]) -sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit] -sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit] diff --git a/GHC/Tc/Errors/Hole/FitTypes.hs b/GHC/Tc/Errors/Hole/FitTypes.hs --- a/GHC/Tc/Errors/Hole/FitTypes.hs +++ b/GHC/Tc/Errors/Hole/FitTypes.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} module GHC.Tc.Errors.Hole.FitTypes ( - TypedHole (..), HoleFit (..), HoleFitCandidate (..), + TypedHole (..), HoleFit (..), TcHoleFit(..), HoleFitCandidate (..), hfIsLcl, pprHoleFitCand ) where @@ -77,7 +77,7 @@ -- element that was checked, the Id of that element as found by `tcLookup`, -- and the refinement level of the fit, which is the number of extra argument -- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`). -data HoleFit = +data TcHoleFit = HoleFit { hfId :: Id -- ^ The elements id in the TcM , hfCand :: HoleFitCandidate -- ^ The candidate that was checked. , hfType :: TcType -- ^ The type of the id, possibly zonked. @@ -88,16 +88,22 @@ , hfDoc :: Maybe [HsDocString] -- ^ Documentation of this HoleFit, if available. } - | RawHoleFit SDoc - -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins + +data HoleFit + = TcHoleFit TcHoleFit + | RawHoleFit SDoc + -- ^ A fit that is just displayed as is. Here so that HoleFitPlugins -- can inject any fit they want. -- We define an Eq and Ord instance to be able to build a graph. -instance Eq HoleFit where +instance Eq TcHoleFit where (==) = (==) `on` hfId instance Outputable HoleFit where + ppr (TcHoleFit hf) = ppr hf ppr (RawHoleFit sd) = sd + +instance Outputable TcHoleFit where ppr (HoleFit _ cand ty _ _ mtchs _) = hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty)) where name = ppr $ getName cand @@ -107,20 +113,18 @@ -- want our tests to be affected by the non-determinism of `nonDetCmpVar`, -- which is used to compare Ids. When comparing, we want HoleFits with a lower -- refinement level to come first. -instance Ord HoleFit where - compare (RawHoleFit _) (RawHoleFit _) = EQ - compare (RawHoleFit _) _ = LT - compare _ (RawHoleFit _) = GT +instance Ord TcHoleFit where +-- compare (RawHoleFit _) (RawHoleFit _) = EQ +-- compare (RawHoleFit _) _ = LT +-- compare _ (RawHoleFit _) = GT compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b where cmp = if hfRefLvl a == hfRefLvl b then compare `on` (getName . hfCand) else compare `on` hfRefLvl -hfIsLcl :: HoleFit -> Bool +hfIsLcl :: TcHoleFit -> Bool hfIsLcl hf@(HoleFit {}) = case hfCand hf of IdHFCand _ -> True NameHFCand _ -> False GreHFCand gre -> gre_lcl gre -hfIsLcl _ = False - diff --git a/GHC/Tc/Errors/Hole/Plugin.hs b/GHC/Tc/Errors/Hole/Plugin.hs --- a/GHC/Tc/Errors/Hole/Plugin.hs +++ b/GHC/Tc/Errors/Hole/Plugin.hs diff --git a/GHC/Tc/Errors/Hole/Plugin.hs-boot b/GHC/Tc/Errors/Hole/Plugin.hs-boot --- a/GHC/Tc/Errors/Hole/Plugin.hs-boot +++ b/GHC/Tc/Errors/Hole/Plugin.hs-boot @@ -1,3 +1,6 @@ module GHC.Tc.Errors.Hole.Plugin where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + data HoleFitPlugin diff --git a/GHC/Tc/Errors/Ppr.hs b/GHC/Tc/Errors/Ppr.hs --- a/GHC/Tc/Errors/Ppr.hs +++ b/GHC/Tc/Errors/Ppr.hs @@ -1,6568 +1,7551 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage -{-# LANGUAGE InstanceSigs #-} - -module GHC.Tc.Errors.Ppr - ( pprTypeDoesNotHaveFixedRuntimeRep - , pprScopeError - -- - , tidySkolemInfo - , tidySkolemInfoAnon - -- - , pprHsDocContext - , inHsDocContext - , TcRnMessageOpts(..) - , pprTyThingUsedWrong - , pprUntouchableVariable - - -- | Useful when overriding message printing. - , messageWithInfoDiagnosticMessage - , messageWithHsDocContext - ) - where - -import GHC.Prelude - -import qualified Language.Haskell.TH as TH - -import GHC.Builtin.Names -import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple ) - -import GHC.Types.Name.Reader -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Warnings - -import GHC.Core.Coercion -import GHC.Core.Unify ( tcMatchTys ) -import GHC.Core.TyCon -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Core.Coercion.Axiom (CoAxBranch, coAxiomTyCon, coAxiomSingleBranch) -import GHC.Core.ConLike -import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst ) -import GHC.Core.InstEnv -import GHC.Core.TyCo.Rep (Type(..)) -import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, - pprSourceTyCon, pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType) -import GHC.Core.PatSyn ( patSynName, pprPatSynType ) -import GHC.Core.Predicate -import GHC.Core.Type -import GHC.Core.FVs( orphNamesOfTypes ) -import GHC.CoreToIface - -import GHC.Driver.Flags -import GHC.Driver.Backend -import GHC.Hs - -import GHC.Tc.Errors.Types -import GHC.Tc.Types.BasicTypes -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Rank (Rank(..)) -import GHC.Tc.Types.TH -import GHC.Tc.Utils.TcType - -import GHC.Types.Error -import GHC.Types.Hint -import GHC.Types.Hint.Ppr () -- Outputable GhcHint -import GHC.Types.Basic -import GHC.Types.Error.Codes ( constructorCode ) -import GHC.Types.Id -import GHC.Types.Id.Info ( RecSelParent(..) ) -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.SourceFile -import GHC.Types.SrcLoc -import GHC.Types.TyThing -import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Fixity (defaultFixity) - -import GHC.Iface.Errors.Types -import GHC.Iface.Errors.Ppr -import GHC.Iface.Syntax - -import GHC.Unit.State -import GHC.Unit.Module - -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Data.List.SetOps ( nubOrdBy ) -import GHC.Data.Maybe -import GHC.Data.Pair -import GHC.Settings.Constants (mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE) -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.BooleanFormula (pprBooleanFormulaNice) - -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Foldable ( fold ) -import Data.Function (on) -import Data.List ( groupBy, sortBy, tails - , partition, unfoldr ) -import Data.Ord ( comparing ) -import Data.Bifunctor - - -defaultTcRnMessageOpts :: TcRnMessageOpts -defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True - , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage } - -instance HasDefaultDiagnosticOpts TcRnMessageOpts where - defaultOpts = defaultTcRnMessageOpts - -instance Diagnostic TcRnMessage where - type DiagnosticOpts TcRnMessage = TcRnMessageOpts - diagnosticMessage opts = \case - TcRnUnknownMessage (UnknownDiagnostic f m) - -> diagnosticMessage (f opts) m - TcRnMessageWithInfo unit_state msg_with_info - -> case msg_with_info of - TcRnMessageDetailed err_info msg - -> messageWithInfoDiagnosticMessage unit_state err_info - (tcOptsShowContext opts) - (diagnosticMessage opts msg) - TcRnWithHsDocContext ctxt msg - -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg) - TcRnSolverReport msg _ _ - -> mkSimpleDecorated $ pprSolverReportWithCtxt msg - TcRnSolverDepthError ty depth -> mkSimpleDecorated msg - where - msg = - vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr ty) ] - TcRnRedundantConstraints redundants (info, show_info) - -> mkSimpleDecorated $ - text "Redundant constraint" <> plural redundants <> colon - <+> pprEvVarTheta redundants - $$ if show_info then text "In" <+> ppr info else empty - TcRnInaccessibleCode implic contra - -> mkSimpleDecorated $ - hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - $$ pprSolverReportWithCtxt contra - TcRnInaccessibleCoAxBranch fam_tc cur_branch - -> mkSimpleDecorated $ - text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranchUser fam_tc cur_branch) - TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) - -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] - TcRnImplicitLift id_or_name ErrInfo{..} - -> mkDecorated $ - ( text "The variable" <+> quotes (ppr id_or_name) <+> - text "is implicitly lifted in the TH quotation" - ) : [errInfoContext, errInfoSupplementary] - TcRnUnusedPatternBinds bind - -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] - TcRnDodgyImports (DodgyImportsEmptyParent gre) - -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)] - TcRnDodgyImports (DodgyImportsHiding reason) - -> mkSimpleDecorated $ - pprImportLookup reason - TcRnDodgyExports gre - -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)] - TcRnMissingImportList ie - -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> - text "does not have an explicit import list" - ] - TcRnUnsafeDueToPlugin - -> mkDecorated [text "Use of plugins makes the module unsafe"] - TcRnModMissingRealSrcSpan mod - -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod] - TcRnIdNotExportedFromModuleSig name mod - -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> - text "does not exist in the signature for" <+> ppr mod - ] - TcRnIdNotExportedFromLocalSig name - -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> - text "does not exist in the local signature." - ] - TcRnShadowedName occ provenance - -> let shadowed_locs = case provenance of - ShadowedNameProvenanceLocal n -> [text "bound at" <+> ppr n] - ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres - in mkSimpleDecorated $ - sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, - nest 2 (vcat shadowed_locs)] - TcRnInvalidWarningCategory cat - -> mkSimpleDecorated $ - vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid", - text "(user-defined category names must begin with" <+> quotes (text "x-"), - text "and contain only letters, numbers, apostrophes and dashes)" ] - TcRnDuplicateWarningDecls d rdr_name - -> mkSimpleDecorated $ - vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr (getLocA d)] - TcRnSimplifierTooManyIterations simples limit wc - -> mkSimpleDecorated $ - hang (text "solveWanteds: too many iterations" - <+> parens (text "limit =" <+> ppr limit)) - 2 (vcat [ text "Unsolved:" <+> ppr wc - , text "Simples:" <+> ppr simples - ]) - TcRnIllegalPatSynDecl rdrname - -> mkSimpleDecorated $ - hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) - 2 (text "Pattern synonym declarations are only valid at top level") - TcRnLinearPatSyn ty - -> mkSimpleDecorated $ - hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty) - TcRnEmptyRecordUpdate - -> mkSimpleDecorated $ text "Empty record update" - TcRnIllegalFieldPunning fld - -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld) - TcRnIllegalWildcardsInRecord fld_part - -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part - TcRnIllegalWildcardInType mb_name bad - -> mkSimpleDecorated $ case bad of - WildcardNotLastInConstraint -> - hang notAllowed 2 constraint_hint_msg - ExtraConstraintWildcardNotAllowed allow_sole -> - case allow_sole of - SoleExtraConstraintWildcardNotAllowed -> - notAllowed - SoleExtraConstraintWildcardAllowed -> - hang notAllowed 2 sole_msg - WildcardsNotAllowedAtAll -> - notAllowed - where - notAllowed, what, wildcard, how :: SDoc - notAllowed = what <+> quotes wildcard <+> how - wildcard = case mb_name of - Nothing -> pprAnonWildCard - Just name -> ppr name - what - | Just _ <- mb_name - = text "Named wildcard" - | ExtraConstraintWildcardNotAllowed {} <- bad - = text "Extra-constraint wildcard" - | otherwise - = text "Wildcard" - how = case bad of - WildcardNotLastInConstraint - -> text "not allowed in a constraint" - _ -> text "not allowed" - constraint_hint_msg :: SDoc - constraint_hint_msg - | Just _ <- mb_name - = vcat [ text "Extra-constraint wildcards must be anonymous" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - | otherwise - = vcat [ text "except as the last top-level constraint of a type signature" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] - sole_msg :: SDoc - sole_msg = - vcat [ text "except as the sole constraint" - , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] - TcRnDuplicateFieldName fld_part dups - -> mkSimpleDecorated $ - hsep [ text "Duplicate field name" - , quotes (ppr (rdrNameOcc $ NE.head dups)) - , text "in record", pprRecordFieldPart fld_part ] - TcRnIllegalViewPattern pat - -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] - TcRnCharLiteralOutOfRange c - -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' - TcRnIllegalWildcardsInConstructor con - -> mkSimpleDecorated $ - vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.") - , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.") - ] - TcRnIgnoringAnnotations anns - -> mkSimpleDecorated $ - text "Ignoring ANN annotation" <> plural anns <> comma - <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi" - TcRnAnnotationInSafeHaskell - -> mkSimpleDecorated $ - vcat [ text "Annotations are not compatible with Safe Haskell." - , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] - TcRnInvalidTypeApplication fun_ty hs_ty - -> mkSimpleDecorated $ - text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ - text "to a visible type argument" <+> quotes (ppr hs_ty) - TcRnTagToEnumMissingValArg - -> mkSimpleDecorated $ - text "tagToEnum# must appear applied to one value argument" - TcRnTagToEnumUnspecifiedResTy ty - -> mkSimpleDecorated $ - hang (text "Bad call to tagToEnum# at type" <+> ppr ty) - 2 (vcat [ text "Specify the type by giving a type signature" - , text "e.g. (tagToEnum# x) :: Bool" ]) - TcRnTagToEnumResTyNotAnEnum ty - -> mkSimpleDecorated $ - hang (text "Bad call to tagToEnum# at type" <+> ppr ty) - 2 (text "Result type must be an enumeration type") - TcRnTagToEnumResTyTypeData ty - -> mkSimpleDecorated $ - hang (text "Bad call to tagToEnum# at type" <+> ppr ty) - 2 (text "Result type cannot be headed by a `type data` type") - TcRnArrowIfThenElsePredDependsOnResultTy - -> mkSimpleDecorated $ - text "Predicate type of `ifThenElse' depends on result type" - TcRnIllegalHsBootOrSigDecl boot_or_sig decls - -> mkSimpleDecorated $ - text "Illegal" <+> what <+> text "in" <+> whr <> dot - where - what = case decls of - BootBindsPs {} -> text "binding" - BootBindsRn {} -> text "binding" - BootInstanceSigs {} -> text "instance body" - BootFamInst {} -> text "family instance" - BootSpliceDecls {} -> text "splice" - BootForeignDecls {} -> text "foreign declaration" - BootDefaultDecls {} -> text "default declaration" - BootRuleDecls {} -> text "RULE pragma" - whr = case boot_or_sig of - HsBoot -> text "an hs-boot file" - Hsig -> text "a backpack signature file" - TcRnBootMismatch boot_or_sig err -> - mkSimpleDecorated $ pprBootMismatch boot_or_sig err - TcRnRecursivePatternSynonym binds - -> mkSimpleDecorated $ - hang (text "Recursive pattern synonym definition with following bindings:") - 2 (vcat $ map pprLBind . bagToList $ binds) - where - pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc - pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) - <+> pprLoc (locA loc) - TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty - -> mkSimpleDecorated $ - hang (text "Couldn't match" <+> quotes (ppr n1) - <+> text "with" <+> quotes (ppr n2)) - 2 (hang (text "both bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) - TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty - -> mkSimpleDecorated $ - hang (text "Can't quantify over" <+> quotes (ppr n)) - 2 (vcat [ hang (text "bound by the partial type signature:") - 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) - , extra ]) - where - extra | Just rhs_ty <- m_unif_ty - = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] - | otherwise - = empty - TcRnMissingSignature what _ -> - mkSimpleDecorated $ - case what of - MissingPatSynSig p -> - hang (text "Pattern synonym with no type signature:") - 2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p) - MissingTopLevelBindingSig name ty -> - hang (text "Top-level binding with no type signature:") - 2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty) - MissingTyConKindSig tc cusks_enabled -> - hang msg - 2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc)) - where - msg | cusks_enabled - = text "Top-level type constructor with no standalone kind signature or CUSK:" - | otherwise - = text "Top-level type constructor with no standalone kind signature:" - - TcRnPolymorphicBinderMissingSig n ty - -> mkSimpleDecorated $ - sep [ text "Polymorphic local binding with no type signature:" - , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ] - TcRnOverloadedSig sig - -> mkSimpleDecorated $ - hang (text "Overloaded signature conflicts with monomorphism restriction") - 2 (ppr sig) - TcRnTupleConstraintInst _ - -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint" - TcRnUserTypeError ty - -> mkSimpleDecorated (pprUserTypeErrorTy ty) - TcRnConstraintInKind ty - -> mkSimpleDecorated $ - text "Illegal constraint in a kind:" <+> pprType ty - TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty - -> mkSimpleDecorated $ - sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:" - , pprType ty ] - where - what = case tuple_or_sum of - UnboxedTupleType -> text "tuple" - UnboxedSumType -> text "sum" - TcRnLinearFuncInKind ty - -> mkSimpleDecorated $ - text "Illegal linear function in a kind:" <+> pprType ty - TcRnForAllEscapeError ty kind - -> mkSimpleDecorated $ vcat - [ hang (text "Quantified type's kind mentions quantified type variable") - 2 (text "type:" <+> quotes (ppr ty)) - , hang (text "where the body of the forall has this kind:") - 2 (quotes (pprKind kind)) ] - TcRnSimplifiableConstraint pred what - -> mkSimpleDecorated $ vcat - [ hang (text "The constraint" <+> quotes (pprType pred) <+> text "matches") - 2 (ppr what) - , hang (text "This makes type inference for inner bindings fragile;") - 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] - TcRnArityMismatch thing thing_arity nb_args - -> mkSimpleDecorated $ - hsep [ text "The" <+> what, quotes (ppr $ getName thing), text "should have" - , n_arguments <> comma, text "but has been given" - , if nb_args == 0 then text "none" else int nb_args - ] - where - what = case thing of - ATyCon tc -> ppr (tyConFlavour tc) - _ -> text (tyThingCategory thing) - n_arguments | thing_arity == 0 = text "no arguments" - | thing_arity == 1 = text "1 argument" - | True = hsep [int thing_arity, text "arguments"] - TcRnIllegalInstance reason -> - mkSimpleDecorated $ pprIllegalInstance reason - TcRnVDQInTermType mb_ty - -> mkSimpleDecorated $ vcat - [ case mb_ty of - Nothing -> main_msg - Just ty -> hang (main_msg <> char ':') 2 (pprType ty) - , text "(GHC does not yet support this)" ] - where - main_msg = - text "Illegal visible, dependent quantification" <+> - text "in the type of a term" - TcRnBadQuantPredHead ty - -> mkSimpleDecorated $ - hang (text "Quantified predicate must have a class or type variable head:") - 2 (pprType ty) - TcRnIllegalTupleConstraint ty - -> mkSimpleDecorated $ - text "Illegal tuple constraint:" <+> pprType ty - TcRnNonTypeVarArgInConstraint ty - -> mkSimpleDecorated $ - hang (text "Non type-variable argument") - 2 (text "in the constraint:" <+> pprType ty) - TcRnIllegalImplicitParam ty - -> mkSimpleDecorated $ - text "Illegal implicit parameter" <+> quotes (pprType ty) - TcRnIllegalConstraintSynonymOfKind kind - -> mkSimpleDecorated $ - text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind) - TcRnOversaturatedVisibleKindArg ty - -> mkSimpleDecorated $ - text "Illegal oversaturated visible kind argument:" <+> - quotes (char '@' <> pprParendType ty) - TcRnForAllRankErr rank ty - -> let herald = case tcSplitForAllTyVars ty of - ([], _) -> text "Illegal qualified type:" - _ -> text "Illegal polymorphic type:" - extra = case rank of - MonoTypeConstraint -> text "A constraint must be a monotype" - _ -> empty - in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra] - TcRnMonomorphicBindings bindings - -> let pp_bndrs = pprBindings bindings - in mkSimpleDecorated $ - sep [ text "The Monomorphism Restriction applies to the binding" - <> plural bindings - , text "for" <+> pp_bndrs ] - TcRnOrphanInstance (Left cls_inst) - -> mkSimpleDecorated $ - hang (text "Orphan class instance:") - 2 (pprInstanceHdr cls_inst) - TcRnOrphanInstance (Right fam_inst) - -> mkSimpleDecorated $ - hang (text "Orphan family instance:") - 2 (pprFamInst fam_inst) - TcRnFunDepConflict unit_state sorted - -> let herald = text "Functional dependencies conflict between instance declarations:" - in mkSimpleDecorated $ - pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) - TcRnDupInstanceDecls unit_state sorted - -> let herald = text "Duplicate instance declarations:" - in mkSimpleDecorated $ - pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) - TcRnConflictingFamInstDecls sortedNE - -> let sorted = NE.toList sortedNE - in mkSimpleDecorated $ - hang (text "Conflicting family instance declarations:") - 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) - | fi <- sorted - , let ax = famInstAxiom fi ]) - TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns) - -> let (herald, show_kinds) = case rea of - InjErrRhsBareTyVar tys -> - (injectivityErrorHerald $$ - text "RHS of injective type family equation is a bare" <+> - text "type variable" $$ - text "but these LHS type and kind patterns are not bare" <+> - text "variables:" <+> pprQuotedList tys, False) - InjErrRhsCannotBeATypeFam -> - (injectivityErrorHerald $$ - text "RHS of injective type family equation cannot" <+> - text "be a type family:", False) - InjErrRhsOverlap -> - (text "Type family equation right-hand sides overlap; this violates" $$ - text "the family's injectivity annotation:", False) - InjErrCannotInferFromRhs tvs has_kinds _ -> - let show_kinds = has_kinds == YesHasKinds - what = if show_kinds then text "Type/kind" else text "Type" - body = sep [ what <+> text "variable" <> - pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) - , text "cannot be inferred from the right-hand side." ] - in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) - - in mkSimpleDecorated $ pprWithExplicitKindsWhen show_kinds $ - hang herald - 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) - TcRnBangOnUnliftedType ty - -> mkSimpleDecorated $ - text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty) - TcRnLazyBangOnUnliftedType ty - -> mkSimpleDecorated $ - text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty) - TcRnMultipleDefaultDeclarations dup_things - -> mkSimpleDecorated $ - hang (text "Multiple default declarations") - 2 (vcat (map pp dup_things)) - where - pp :: LDefaultDecl GhcRn -> SDoc - pp (L locn (DefaultDecl _ _)) - = text "here was another default declaration" <+> ppr (locA locn) - TcRnBadDefaultType ty deflt_clss - -> mkSimpleDecorated $ - hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") - 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss)) - TcRnPatSynBundledWithNonDataCon - -> mkSimpleDecorated $ - text "Pattern synonyms can be bundled only with datatypes." - TcRnPatSynBundledWithWrongType expected_res_ty res_ty - -> mkSimpleDecorated $ - text "Pattern synonyms can only be bundled with matching type constructors" - $$ text "Couldn't match expected type of" - <+> quotes (ppr expected_res_ty) - <+> text "with actual type of" - <+> quotes (ppr res_ty) - TcRnDupeModuleExport mod - -> mkSimpleDecorated $ - hsep [ text "Duplicate" - , quotes (text "Module" <+> ppr mod) - , text "in export list" ] - TcRnExportedModNotImported mod - -> mkSimpleDecorated - $ formatExportItemError - (text "module" <+> ppr mod) - "is not imported" - TcRnNullExportedModule mod - -> mkSimpleDecorated - $ formatExportItemError - (text "module" <+> ppr mod) - "exports nothing" - TcRnMissingExportList mod - -> mkSimpleDecorated - $ formatExportItemError - (text "module" <+> ppr mod) - "is missing an export list" - TcRnExportHiddenComponents export_item - -> mkSimpleDecorated - $ formatExportItemError - (ppr export_item) - "attempts to export constructors or class methods that are not visible here" - TcRnDuplicateExport gre ie1 ie2 - -> mkSimpleDecorated $ - hsep [ quotes (ppr $ greName gre) - , text "is exported by", quotes (ppr ie1) - , text "and", quotes (ppr ie2) ] - TcRnExportedParentChildMismatch parent_name ty_thing child parent_names - -> mkSimpleDecorated $ - text "The type constructor" <+> quotes (ppr parent_name) - <+> text "is not the parent of the" <+> text what_is - <+> quotes thing <> char '.' - $$ text (capitalise what_is) - <> text "s can only be exported with their parent type constructor." - $$ (case parents of - [] -> empty - [_] -> text "Parent:" - _ -> text "Parents:") <+> fsep (punctuate comma parents) - where - pp_category :: TyThing -> String - pp_category (AnId i) - | isRecordSelector i = "record selector" - pp_category i = tyThingCategory i - what_is = pp_category ty_thing - thing = ppr $ nameOccName child - parents = map ppr parent_names - TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2 - -> mkSimpleDecorated $ - vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export child_gre1 ie1 - , ppr_export child_gre2 ie2 - ] - where - ppr_export gre ie = - nest 3 $ - hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre)) - 2 (pprNameProvenance gre) - TcRnDuplicateFieldExport (gre, ie1) gres_ies -> - mkSimpleDecorated $ - vcat ( hsep [ text "Duplicate record field" - , quotes (ppr $ greOccName gre) - , text "in export list" <> colon ] - : map ppr_export ((gre,ie1) : NE.toList gres_ies) - ) - where - ppr_export (gre,ie) = - nest 3 $ - hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre) - , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ]) - 2 (pprNameProvenance gre) - where - fld_cons :: [ConLikeName] - fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre - TcRnAmbiguousFieldInUpdate (gre1, gre2, gres) - -> mkSimpleDecorated $ - vcat [ text "Ambiguous record field" <+> fld <> dot - , hang (text "It could refer to any of the following:") - 2 $ vcat (map pprSugg (gre1 : gre2 : gres)) - ] - where - fld = quotes $ ppr (occNameFS $ greOccName gre1) - pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma - , nest 2 (pprNameProvenance gre) ] - pprGRE gre = case greInfo gre of - IAmRecField {} - -> let parent = par_is $ greParent gre - in text "record field" <+> fld <+> text "of" <+> quotes (ppr parent) - _ -> text "variable" <+> fld - TcRnAmbiguousRecordUpdate _rupd tc - -> mkSimpleDecorated $ - vcat [ text "Ambiguous record update with parent" <+> what <> dot - , hsep [ text "This type-directed disambiguation mechanism" - , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ] - , text "Consider disambiguating using module qualification instead." - ] - where - what :: SDoc - what = text "type constructor" <+> quotes (ppr $ RecSelData tc) - TcRnMissingFields con fields - -> mkSimpleDecorated $ vcat [header, nest 2 rest] - where - rest | null fields = empty - | otherwise = vcat (fmap pprField fields) - header = text "Fields of" <+> quotes (ppr con) <+> - text "not initialised" <> - if null fields then empty else colon - TcRnFieldUpdateInvalidType prs - -> mkSimpleDecorated $ - hang (text "Record update for insufficiently polymorphic field" - <> plural prs <> colon) - 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) - TcRnMissingStrictFields con fields - -> mkSimpleDecorated $ vcat [header, nest 2 rest] - where - rest | null fields = empty -- Happens for non-record constructors - -- with strict fields - | otherwise = vcat (fmap pprField fields) - - header = text "Constructor" <+> quotes (ppr con) <+> - text "does not have the required strict field(s)" <> - if null fields then empty else colon - TcRnBadRecordUpdate upd_flds reason - -> case reason of - NoConstructorHasAllFields { conflictingFields = conflicts } - | [fld] <- conflicts - -> mkSimpleDecorated $ - vcat [ header - , text "No constructor in scope has the field" <+> quotes (ppr fld) ] - | otherwise - -> - mkSimpleDecorated $ - vcat [ header - , hang (text "No constructor in scope has all of the following fields:") - 2 (pprQuotedList conflicts) ] - where - header :: SDoc - header = text "Invalid record update." - MultiplePossibleParents (par1, par2, pars) -> - mkSimpleDecorated $ - vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds) - 2 ppr_flds - , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent) - 2 (quotedListWithAnd (map ppr (par1:par2:pars))) ] - where - ppr_flds, what_parent, which :: SDoc - ppr_flds = quotedListWithAnd $ map ppr upd_flds - what_parent = case par1 of - RecSelData {} -> text "appear" <> singular upd_flds - <+> text "in" <+> which <+> text "datatypes" - RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with" - <+> which <+> text "pattern synonyms" - which = case pars of - [] -> text "both" - _ -> text "all of the" - InvalidTyConParent tc pars -> - mkSimpleDecorated $ - vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:") - 2 (pprQuotedList upd_flds) - , pat_syn_msg ] - where - what = text "type constructor" <+> quotes (ppr (RecSelData tc)) - pat_syn_msg - | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars - = text "NB: type-directed disambiguation is not supported for pattern synonym record fields." - | otherwise - = empty - TcRnStaticFormNotClosed name reason - -> mkSimpleDecorated $ - quotes (ppr name) - <+> text "is used in a static form but it is not closed" - <+> text "because it" - $$ sep (causes reason) - where - causes :: NotClosedReason -> [SDoc] - causes NotLetBoundReason = [text "is not let-bound."] - causes (NotTypeClosed vs) = - [ text "has a non-closed type because it contains the" - , text "type variables:" <+> - pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) - ] - causes (NotClosed n reason) = - let msg = text "uses" <+> quotes (ppr n) <+> text "which" - in case reason of - NotClosed _ _ -> msg : causes reason - _ -> let (xs0, xs1) = splitAt 1 $ causes reason - in fmap (msg <+>) xs0 ++ xs1 - TcRnUselessTypeable - -> mkSimpleDecorated $ - text "Deriving" <+> quotes (ppr typeableClassName) <+> - text "has no effect: all types now auto-derive Typeable" - TcRnDerivingDefaults cls - -> mkSimpleDecorated $ sep - [ text "Both DeriveAnyClass and" - <+> text "GeneralizedNewtypeDeriving are enabled" - , text "Defaulting to the DeriveAnyClass strategy" - <+> text "for instantiating" <+> ppr cls - ] - TcRnNonUnaryTypeclassConstraint ct - -> mkSimpleDecorated $ - quotes (ppr ct) - <+> text "is not a unary constraint, as expected by a deriving clause" - TcRnPartialTypeSignatures _ theta - -> mkSimpleDecorated $ - text "Found type wildcard" <+> quotes (char '_') - <+> text "standing for" <+> quotes (pprTheta theta) - TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason - -> mkSimpleDecorated $ - derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason - TcRnLookupInstance cls tys reason - -> mkSimpleDecorated $ - text "Couldn't match instance:" <+> - lookupInstanceErrDiagnosticMessage cls tys reason - TcRnLazyGADTPattern - -> mkSimpleDecorated $ - hang (text "An existential or GADT data constructor cannot be used") - 2 (text "inside a lazy (~) pattern") - TcRnArrowProcGADTPattern - -> mkSimpleDecorated $ - text "Proc patterns cannot use existential or GADT data constructors" - TcRnForallIdentifier rdr_name - -> mkSimpleDecorated $ - fsep [ text "The use of" <+> quotes (ppr rdr_name) - <+> text "as an identifier", - text "will become an error in a future GHC release." ] - TcRnTypeEqualityOutOfScope - -> mkDecorated - [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$ - text "Assuming it to stand for an equality constraint." - , text "NB:" <+> (quotes (text "~") <+> text "used to be built-in syntax but now is a regular type operator" $$ - text "exported from Data.Type.Equality and Prelude.") $$ - text "If you are using a custom Prelude, consider re-exporting it." - , text "This will become an error in a future GHC release." ] - TcRnTypeEqualityRequiresOperators - -> mkSimpleDecorated $ - fsep [ text "The use of" <+> quotes (text "~") - <+> text "without TypeOperators", - text "will become an error in a future GHC release." ] - TcRnIllegalTypeOperator overall_ty op - -> mkSimpleDecorated $ - text "Illegal operator" <+> quotes (ppr op) <+> - text "in type" <+> quotes (ppr overall_ty) - TcRnIllegalTypeOperatorDecl name - -> mkSimpleDecorated $ - text "Illegal declaration of a type or class operator" <+> quotes (ppr name) - TcRnGADTMonoLocalBinds - -> mkSimpleDecorated $ - fsep [ text "Pattern matching on GADTs without MonoLocalBinds" - , text "is fragile." ] - TcRnIncorrectNameSpace name _ - -> mkSimpleDecorated $ msg - where - msg - -- We are in a type-level namespace, - -- and the name is incorrectly at the term-level. - | isValNameSpace ns - = text "The" <+> what <+> text "does not live in the type-level namespace" - - -- We are in a term-level namespace, - -- and the name is incorrectly at the type-level. - | otherwise - = text "Illegal term-level use of the" <+> what - ns = nameNameSpace name - what = pprNameSpace ns <+> quotes (ppr name) - TcRnNotInScope err name imp_errs _ - -> mkSimpleDecorated $ - pprScopeError name err $$ vcat (map ppr imp_errs) - TcRnTermNameInType name _ - -> mkSimpleDecorated $ - quotes (ppr name) <+> - (text "is a term-level binding") $+$ - (text " and can not be used at the type level.") - TcRnUntickedPromotedThing thing - -> mkSimpleDecorated $ - text "Unticked promoted" <+> what - where - what :: SDoc - what = case thing of - UntickedExplicitList -> text "list" <> dot - UntickedConstructor fixity nm -> - let con = pprUntickedConstructor fixity nm - bare_sym = isBareSymbol fixity nm - in text "constructor:" <+> con <> if bare_sym then empty else dot - TcRnIllegalBuiltinSyntax what rdr_name - -> mkSimpleDecorated $ - hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name] - TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty - -> mkSimpleDecorated $ - hang (hsep $ [ text "Defaulting" ] - ++ - (case tidy_tv of - Nothing -> [] - Just tv -> [text "the type variable" - , quotes (ppr tv)]) - ++ - [ text "to type" - , quotes (ppr default_ty) - , text "in the following constraint" <> plural tidy_wanteds ]) - 2 - (pprWithArising tidy_wanteds) - - - TcRnForeignImportPrimExtNotSet _decl - -> mkSimpleDecorated $ - text "`foreign import prim' requires GHCForeignImportPrim." - - TcRnForeignImportPrimSafeAnn _decl - -> mkSimpleDecorated $ - text "The safe/unsafe annotation should not be used with `foreign import prim'." - - TcRnForeignFunctionImportAsValue _decl - -> mkSimpleDecorated $ - text "`value' imports cannot have function types" - - TcRnFunPtrImportWithoutAmpersand _decl - -> mkSimpleDecorated $ - text "possible missing & in foreign import of FunPtr" - - TcRnIllegalForeignDeclBackend _decl _backend expectedBknds - -> mkSimpleDecorated $ - fsep (text "Illegal foreign declaration: requires one of these back ends:" : - commafyWith (text "or") (map (text . backendDescription) expectedBknds)) - - TcRnUnsupportedCallConv _decl unsupportedCC - -> mkSimpleDecorated $ - case unsupportedCC of - StdCallConvUnsupported -> - text "the 'stdcall' calling convention is unsupported on this platform," - $$ text "treating as ccall" - PrimCallConvUnsupported -> - text "The `prim' calling convention can only be used with `foreign import'" - JavaScriptCallConvUnsupported -> - text "The `javascript' calling convention is unsupported on this platform" - - TcRnIllegalForeignType mArgOrResult reason - -> mkSimpleDecorated $ hang msg 2 extra - where - arg_or_res = case mArgOrResult of - Nothing -> empty - Just Arg -> text "argument" - Just Result -> text "result" - msg = hsep [ text "Unacceptable", arg_or_res - , text "type in foreign declaration:"] - extra = - case reason of - TypeCannotBeMarshaled ty why -> - let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" - in case why of - NotADataType -> - quotes (ppr ty) <+> text "is not a data type" - NewtypeDataConNotInScope _ [] -> - hang innerMsg 2 $ text "because its data constructor is not in scope" - NewtypeDataConNotInScope tc _ -> - hang innerMsg 2 $ - text "because the data constructor for" - <+> quotes (ppr tc) <+> text "is not in scope" - UnliftedFFITypesNeeded -> - innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types" - NotABoxedMarshalableTyCon -> innerMsg - ForeignLabelNotAPtr -> - innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)" - NotSimpleUnliftedType -> - innerMsg $$ text "foreign import prim only accepts simple unlifted types" - NotBoxedKindAny -> - text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$ - text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty)) - ForeignDynNotPtr expected ty -> - vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text " Actual:" <+> ppr ty ] - SafeHaskellMustBeInIO -> - text "Safe Haskell is on, all FFI imports must be in the IO monad" - IOResultExpected -> - text "IO result type expected" - UnexpectedNestedForall -> - text "Unexpected nested forall" - LinearTypesNotAllowed -> - text "Linear types are not supported in FFI declarations, see #18472" - OneArgExpected -> - text "One argument expected" - AtLeastOneArgExpected -> - text "At least one argument expected" - TcRnInvalidCIdentifier target - -> mkSimpleDecorated $ - sep [quotes (ppr target) <+> text "is not a valid C identifier"] - TcRnExpectedValueId thing - -> mkSimpleDecorated $ - ppr thing <+> text "used where a value identifier was expected" - TcRnRecSelectorEscapedTyVar lbl - -> mkSimpleDecorated $ - text "Cannot use record selector" <+> quotes (ppr lbl) <+> - text "as a function due to escaped type variables" - TcRnPatSynNotBidirectional name - -> mkSimpleDecorated $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" - TcRnIllegalDerivingItem hs_ty - -> mkSimpleDecorated $ - text "Illegal deriving item" <+> quotes (ppr hs_ty) - TcRnUnexpectedAnnotation ty bang - -> mkSimpleDecorated $ - let err = case bang of - HsSrcBang _ SrcUnpack _ -> "UNPACK" - HsSrcBang _ SrcNoUnpack _ -> "NOUNPACK" - HsSrcBang _ NoSrcUnpack SrcLazy -> "laziness" - HsSrcBang _ _ _ -> "strictness" - in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ - text err <+> text "annotation cannot appear nested inside a type" - TcRnIllegalRecordSyntax either_ty_ty - -> mkSimpleDecorated $ - text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty - TcRnInvalidVisibleKindArgument arg ty - -> mkSimpleDecorated $ - text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) - TcRnTooManyBinders ki bndrs - -> mkSimpleDecorated $ - hang (text "Not a function kind:") - 4 (ppr ki) $$ - hang (text "but extra binders found:") - 4 (fsep (map ppr bndrs)) - TcRnDifferentNamesForTyVar n1 n2 - -> mkSimpleDecorated $ - hang (text "Different names for the same type variable:") 2 info - where - info | nameOccName n1 /= nameOccName n2 - = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) - | otherwise -- Same OccNames! See C2 in - -- Note [Swizzling the tyvars before generaliseTcTyCon] - = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) - , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] - - TcRnDisconnectedTyVar n - -> mkSimpleDecorated $ - hang (text "Scoped type variable only appears non-injectively in declaration header:") - 2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n)) - - TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext - -> mkSimpleDecorated $ - sep [ ppDataSort data_sort <+> - text "has non-" <> - allowed_kind_tycon - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr kind) - ] - where - is_data_family = - case data_sort of - DataDeclSort{} -> False - DataInstanceSort{} -> False - DataFamilySort -> True - allowed_kind_tycon = - case allowed_kind of - AnyTYPEKind -> ppr tYPETyCon - AnyBoxedKind -> ppr boxedRepDataConTyCon - LiftedKind -> ppr liftedTypeKind - TcRnClassKindNotConstraint _kind - -> mkSimpleDecorated $ - text "Kind signature on a class must end with" <+> ppr constraintKind $$ - text "unobscured by type families" - TcRnUnpromotableThing name err - -> mkSimpleDecorated $ - (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") - 2 (parens reason)) - where - reason = case err of - ConstrainedDataConPE theta - -> text "it has an unpromotable context" - <+> quotes (pprTheta theta) - - FamDataConPE -> text "it comes from a data family instance" - NoDataKindsDC -> text "perhaps you intended to use DataKinds" - PatSynPE -> text "pattern synonyms cannot be promoted" - RecDataConPE -> same_rec_group_msg - ClassPE -> same_rec_group_msg - TyConPE -> same_rec_group_msg - TermVariablePE -> text "term variables cannot be promoted" - TypeVariablePE -> text "type variables bound in a kind signature cannot be used in the type" - same_rec_group_msg = text "it is defined and used in the same recursive group" - TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches) - -> mkSimpleDecorated $ - (vcat [ pprMatchContextNouns argsContext <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLocA match1)) - , nest 2 (ppr (getLocA (NE.head bad_matches)))]) - TcRnCannotBindScopedTyVarInPatSig sig_tvs - -> mkSimpleDecorated $ - hang (text "You cannot bind scoped type variable" - <> plural (NE.toList sig_tvs) - <+> pprQuotedList (map fst $ NE.toList sig_tvs)) - 2 (text "in a pattern binding signature") - TcRnCannotBindTyVarsInPatBind _offenders - -> mkSimpleDecorated $ - text "Binding type variables is not allowed in pattern bindings" - TcRnTooManyTyArgsInConPattern con_like expected_number actual_number - -> mkSimpleDecorated $ - text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ - text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number - TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags - -> mkSimpleDecorated $ - hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (fst_inl_prag : NE.toList inl_prags))) - where - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - TcRnUnexpectedPragmas poly_id bad_sigs - -> mkSimpleDecorated $ - hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs)) - TcRnNonOverloadedSpecialisePragma fun_name - -> mkSimpleDecorated $ - text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name) - TcRnSpecialiseNotVisible name - -> mkSimpleDecorated $ - text "You cannot SPECIALISE" <+> quotes (ppr name) - <+> text "because its definition is not visible in this module" - TcRnPragmaWarning {pragma_warning_occ, pragma_warning_msg, pragma_warning_import_mod, pragma_warning_defined_mod} - -> mkSimpleDecorated $ - sep [ sep [ text "In the use of" - <+> pprNonVarNameSpace (occNameSpace pragma_warning_occ) - <+> quotes (ppr pragma_warning_occ) - , parens impMsg <> colon ] - , pprWarningTxtForMsg pragma_warning_msg ] - where - impMsg = text "imported from" <+> ppr pragma_warning_import_mod <> extra - extra = case pragma_warning_defined_mod of - Just def_mod - | def_mod /= pragma_warning_import_mod - -> text ", but defined in" <+> ppr def_mod - _ -> empty - TcRnDifferentExportWarnings name locs - -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages", - text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)] - TcRnIncompleteExportWarnings name locs - -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "will not have its export warned about", - text "missing export warning at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)] - TcRnIllegalHsigDefaultMethods name meths - -> mkSimpleDecorated $ - text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file" - TcRnHsigFixityMismatch real_thing real_fixity sig_fixity - -> - let ppr_fix f = ppr f <+> if f == defaultFixity then parens (text "default") else empty - in mkSimpleDecorated $ - vcat [ppr real_thing <+> text "has conflicting fixities in the module", - text "and its hsig file", - text "Main module:" <+> ppr_fix real_fixity, - text "Hsig file:" <+> ppr_fix sig_fixity] - TcRnHsigShapeMismatch (HsigShapeSortMismatch info1 info2) - -> mkSimpleDecorated $ - text "While merging export lists, could not combine" - <+> ppr info1 <+> text "with" <+> ppr info2 - <+> parens (text "one is a type, the other is a plain identifier") - TcRnHsigShapeMismatch (HsigShapeNotUnifiable name1 name2 notHere) - -> - let extra = if notHere - then text "Neither name variable originates from the current signature." - else empty - in mkSimpleDecorated $ - text "While merging export lists, could not unify" - <+> ppr name1 <+> text "with" <+> ppr name2 $$ extra - TcRnHsigMissingModuleExport occ unit_state impl_mod - -> mkSimpleDecorated $ - quotes (ppr occ) - <+> text "is exported by the hsig file, but not exported by the implementing module" - <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) - TcRnBadGenericMethod clas op - -> mkSimpleDecorated $ - hsep [text "Class", quotes (ppr clas), - text "has a generic-default signature without a binding", quotes (ppr op)] - TcRnWarningMinimalDefIncomplete mindef - -> mkSimpleDecorated $ - vcat [ text "The MINIMAL pragma does not require:" - , nest 2 (pprBooleanFormulaNice mindef) - , text "but there is no default implementation." ] - TcRnDefaultMethodForPragmaLacksBinding sel_id prag - -> mkSimpleDecorated $ - text "The" <+> hsSigDoc prag <+> text "for default method" - <+> quotes (ppr sel_id) - <+> text "lacks an accompanying binding" - TcRnIgnoreSpecialisePragmaOnDefMethod sel_name - -> mkSimpleDecorated $ - text "Ignoring SPECIALISE pragmas on default method" - <+> quotes (ppr sel_name) - TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName} - -> mkSimpleDecorated $ - hsep [text "Class", quotes (ppr badMethodErrClassName), - text "does not have a method", quotes (ppr badMethodErrMethodName)] - TcRnIllegalTypeData - -> mkSimpleDecorated $ - text "Illegal type-level data declaration" - TcRnTypeDataForbids feature - -> mkSimpleDecorated $ - ppr feature <+> text "are not allowed in type data declarations." - - TcRnIllegalNewtype con show_linear_types reason - -> mkSimpleDecorated $ - vcat [msg, additional] - where - (msg,additional) = - case reason of - DoesNotHaveSingleField n_flds -> - (sep [ - text "A newtype constructor must have exactly one field", - nest 2 $ - text "but" <+> quotes (ppr con) <+> text "has" <+> speakN n_flds - ], - ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) - IsNonLinear -> - (text "A newtype constructor must be linear", - ppr con <+> dcolon <+> ppr (dataConDisplayType True con)) - IsGADT -> - (text "A newtype must not be a GADT", - ppr con <+> dcolon <+> pprWithExplicitKindsWhen sneaky_eq_spec - (ppr $ dataConDisplayType show_linear_types con)) - HasConstructorContext -> - (text "A newtype constructor must not have a context in its type", - ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) - HasExistentialTyVar -> - (text "A newtype constructor must not have existential type variables", - ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) - HasStrictnessAnnotation -> - (text "A newtype constructor must not have a strictness annotation", empty) - - -- Is the data con a "covert" GADT? See Note [isCovertGadtDataCon] - -- in GHC.Core.DataCon - sneaky_eq_spec = isCovertGadtDataCon con - TcRnUnsatisfiedMinimalDef mindef - -> mkSimpleDecorated $ - vcat [text "No explicit implementation for" - ,nest 2 $ pprBooleanFormulaNice mindef - ] - TcRnMisplacedInstSig name hs_ty - -> mkSimpleDecorated $ - vcat [ hang (text "Illegal type signature in instance declaration:") - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - ] - TcRnNoRebindableSyntaxRecordDot -> mkSimpleDecorated $ - text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." - TcRnNoFieldPunsRecordDot -> mkSimpleDecorated $ - text "For this to work enable NamedFieldPuns" - TcRnIllegalStaticExpression e -> mkSimpleDecorated $ - text "Illegal static expression:" <+> ppr e - TcRnListComprehensionDuplicateBinding n -> mkSimpleDecorated $ - (text "Duplicate binding in parallel list comprehension for:" - <+> quotes (ppr n)) - TcRnEmptyStmtsGroup cause -> mkSimpleDecorated $ case cause of - EmptyStmtsGroupInParallelComp -> - text "Empty statement group in parallel comprehension" - EmptyStmtsGroupInTransformListComp -> - text "Empty statement group preceding 'group' or 'then'" - EmptyStmtsGroupInDoNotation ctxt -> - text "Empty" <+> pprHsDoFlavour ctxt - EmptyStmtsGroupInArrowNotation -> - text "Empty 'do' block in an arrow command" - TcRnLastStmtNotExpr ctxt (UnexpectedStatement stmt) -> - mkSimpleDecorated $ hang last_error 2 (ppr stmt) - where - last_error = - text "The last statement in" <+> pprAStmtContext ctxt - <+> text "must be an expression" - TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $ - sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" - , text "in" <+> pprAStmtContext ctxt ] - TcRnIllegalTupleSection -> mkSimpleDecorated $ - text "Illegal tuple section" - TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $ - either msg msg eBinds - where - msg binds = hang - (text "Implicit-parameter bindings illegal in an mdo expression") - 2 (ppr binds) - TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $ - hang (text "A section must be enclosed in parentheses") - 2 (text "thus:" <+> (parens (ppr expr))) - TcRnMissingRoleAnnotation name roles -> mkSimpleDecorated $ - hang (text "Missing role annotation" <> colon) - 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) - - TcRnCapturedTermName tv_name shadowed_term_names - -> mkSimpleDecorated $ - text "The type variable" <+> quotes (ppr tv_name) <+> - text "is implicitly quantified," $+$ - text "even though another variable of the same name is in scope:" $+$ - nest 2 var_names $+$ - text "This is not forward-compatible with a planned GHC extension, RequiredTypeArguments." - where - var_names = case shadowed_term_names of - Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names) - Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at" - <+> ppr (nameSrcLoc lcl_name) - TcRnBindingOfExistingName name -> mkSimpleDecorated $ - text "Illegal binding of an existing name:" <+> ppr (filterCTuple name) - TcRnMultipleFixityDecls loc rdr_name -> mkSimpleDecorated $ - vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] - TcRnIllegalPatternSynonymDecl -> mkSimpleDecorated $ - text "Illegal pattern synonym declaration" - TcRnIllegalClassBinding dsort bind -> mkSimpleDecorated $ - vcat [ what <+> text "not allowed in" <+> decl_sort - , nest 2 (ppr bind) ] - where - decl_sort = case dsort of - ClassDeclSort -> text "class declaration:" - InstanceDeclSort -> text "instance declaration:" - what = case bind of - PatBind {} -> text "Pattern bindings (except simple variables)" - PatSynBind {} -> text "Pattern synonyms" - -- Associated pattern synonyms are not implemented yet - _ -> pprPanic "rnMethodBind" (ppr bind) - TcRnOrphanCompletePragma -> mkSimpleDecorated $ - text "Orphan COMPLETE pragmas not supported" $$ - text "A COMPLETE pragma must mention at least one data constructor" $$ - text "or pattern synonym defined in the same module." - TcRnEmptyCase ctxt -> mkSimpleDecorated message - where - pp_ctxt = case ctxt of - CaseAlt -> text "case expression" - LamCaseAlt LamCase -> text "\\case expression" - ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command" - ArrowMatchCtxt ArrowCaseAlt -> text "case command" - ArrowMatchCtxt KappaExpr -> text "kappa abstraction" - _ -> text "(unexpected)" - <+> pprMatchContextNoun ctxt - - message = case ctxt of - LamCaseAlt LamCases -> lcases_msg <+> text "expression" - ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> lcases_msg <+> text "command" - _ -> text "Empty list of alternatives in" <+> pp_ctxt - - lcases_msg = - text "Empty list of alternatives is not allowed in \\cases" - TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $ - text "accepting non-standard pattern guards" $$ - nest 4 (interpp'SP guards) - TcRnDuplicateSigDecl pairs@((L _ name, sig) :| _) -> mkSimpleDecorated $ - vcat [ text "Duplicate" <+> what_it_is - <> text "s for" <+> quotes (ppr name) - , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest - $ map (getLocA . fst) - $ NE.toList pairs) - ] - where - what_it_is = hsSigDoc sig - TcRnMisplacedSigDecl sig -> mkSimpleDecorated $ - sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] - TcRnUnexpectedDefaultSig sig -> mkSimpleDecorated $ - hang (text "Unexpected default signature:") - 2 (ppr sig) - TcRnDuplicateMinimalSig sig1 sig2 otherSigs -> mkSimpleDecorated $ - vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ map getLocA sigs) - , text "Combine alternative minimal complete definitions with `|'" ] - where - sigs = sig1 : sig2 : otherSigs - TcRnLoopySuperclassSolve wtd_loc wtd_pty -> - mkSimpleDecorated $ vcat [ header, warning, user_manual ] - where - header, warning, user_manual :: SDoc - header - = vcat [ text "I am solving the constraint" <+> quotes (ppr wtd_pty) <> comma - , nest 2 $ pprCtOrigin (ctLocOrigin wtd_loc) <> comma - , text "in a way that might turn out to loop at runtime." ] - warning - = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ] - user_manual = - vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ] - TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $ - text "Illegal standalone deriving declaration" - TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $ - sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, - text "Forall'd variable" <+> quotes (ppr var) <+> - text "does not appear on left hand side"] - TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $ - text "Illegal standalone kind signature" - TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $ - sep [text "Rule" <+> pprRuleName name <> colon, - nest 2 (vcat [err, - text "in left-hand side:" <+> ppr lhs])] - $$ - text "LHS must be of form (f e1 .. en) where f is not forall'd" - where - err = case errReason of - UnboundVariable uv nis -> pprScopeError uv nis - IllegalExpression -> text "Illegal expression:" <+> ppr bad_e - TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $ - hang (text "Duplicate role annotations for" <+> - quotes (ppr $ roleAnnotDeclName first_decl) <> colon) - 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((L _ first_decl) :| _) = sorted_list - - pp_role_annot (L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = leftmost_smallest `on` getLocA - TcRnDuplicateKindSig list -> mkSimpleDecorated $ - hang (text "Duplicate standalone kind signatures for" <+> - quotes (ppr $ standaloneKindSigName first_decl) <> colon) - 2 (vcat $ map pp_kisig $ NE.toList sorted_list) - where - sorted_list = NE.sortBy cmp_loc list - ((L _ first_decl) :| _) = sorted_list - - pp_kisig (L loc decl) = - hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = leftmost_smallest `on` getLocA - TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $ - text "Illegal deriving strategy" <> colon <+> derivStrategyName ds - TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $ - text "Illegal use of multiple, consecutive deriving clauses" - TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text - "No deriving strategy specified. Did you want stock, newtype, or anyclass?" - TcRnStupidThetaInGadt{} -> mkSimpleDecorated $ - vcat [text "No context is allowed on a GADT-style data declaration", - text "(You can put a context on each constructor, though.)"] - TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $ - hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable" - TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $ - vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])] - TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $ - hsep [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] - TcRnBadlyStaged reason bind_lvl use_lvl - -> mkSimpleDecorated $ - text "Stage error:" <+> pprStageCheckReason reason <+> - hsep [text "is bound at stage" <+> ppr bind_lvl, - text "but used at stage" <+> ppr use_lvl] - TcRnStageRestriction reason - -> mkSimpleDecorated $ - sep [ text "GHC stage restriction:" - , nest 2 (vcat [ pprStageCheckReason reason <+> - text "is used in a top-level splice, quasi-quote, or annotation," - , text "and must be imported, not defined locally"])] - TcRnTyThingUsedWrong sort thing name - -> mkSimpleDecorated $ - pprTyThingUsedWrong sort thing name - TcRnCannotDefaultKindVar var knd -> - mkSimpleDecorated $ - (vcat [ text "Cannot default kind variable" <+> quotes (ppr var) - , text "of kind:" <+> ppr knd - , text "Perhaps enable PolyKinds or add a kind signature" ]) - TcRnUninferrableTyVar tidied_tvs context -> - mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ - vcat [ text "Uninferrable type variable" - <> plural tidied_tvs - <+> pprWithCommas pprTyVar tidied_tvs - <+> text "in" - , pprUninferrableTyVarCtx context ] - TcRnSkolemEscape escapees tv orig_ty -> - mkSimpleDecorated $ - pprWithExplicitKindsWhen True $ - vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees - , quotes $ pprTyVars escapees - , text "would escape" <+> itsOrTheir escapees <+> text "scope" - ] - , sep [ text "if I tried to quantify" - , pprTyVar tv - , text "in this type:" - ] - , nest 2 (pprTidiedType orig_ty) - , text "(Indeed, I sometimes struggle even printing this correctly," - , text " due to its ill-scoped nature.)" - ] - TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $ - vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" - , hang (text "Pattern-bound variable") - 2 (ppr arg <+> dcolon <+> ppr (idType arg)) - , nest 2 $ - hang (text "has a type that mentions pattern-bound coercion" - <> plural bad_co_list <> colon) - 2 (pprWithCommas ppr bad_co_list) - , text "Hint: use -fprint-explicit-coercions to see the coercions" - , text "Probable fix: add a pattern signature" ] - where - bad_co_list = NE.toList bad_co_ne - TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $ - hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma - , text "namely" <+> quotes (ppr pat_ty) ]) - 2 (text "mentions existential type variable" <> plural bad_tvs - <+> pprQuotedList bad_tvs) - TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $ - hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" - <+> speakNOf decl_arity (text "argument")) - 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") - TcRnPatSynInvalidRhs ps_name lpat _ reason -> mkSimpleDecorated $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr ps_name) <> colon) - 2 (pprPatSynInvalidRhsReason reason) - , text "RHS pattern:" <+> ppr lpat ] - TcRnTyFamDepsDisabled -> mkSimpleDecorated $ - text "Illegal injectivity annotation" - TcRnAbstractClosedTyFamDecl -> mkSimpleDecorated $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" - TcRnPartialFieldSelector fld -> mkSimpleDecorated $ - sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr (occName fld))] - TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $ - hang (pprBadFieldAnnotationReason reason) - 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) - TcRnSuperclassCycle (MkSuperclassCycle cls definite details) -> - let herald | definite = text "Superclass cycle for" - | otherwise = text "Potential superclass cycle for" - in mkSimpleDecorated $ - vcat [ herald <+> quotes (ppr cls), nest 2 (vcat (pprSuperclassCycleDetail <$> details))] - TcRnDefaultSigMismatch sel_id dm_ty -> mkSimpleDecorated $ - hang (text "The default type signature for" - <+> ppr sel_id <> colon) - 2 (ppr dm_ty) - $$ (text "does not match its corresponding" - <+> text "non-default type signature") - TcRnTyFamsDisabled reason -> mkSimpleDecorated $ - text "Illegal family" <+> text sort <+> text "for" <+> quotes name - where - (sort, name) = case reason of - TyFamsDisabledFamily n -> ("declaration", ppr n) - TyFamsDisabledInstance n -> ("instance", ppr n) - TcRnBadTyConTelescope tc -> mkSimpleDecorated $ - vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") - 2 pp_tc_kind - , extra - , hang (text "Perhaps try this order instead:") - 2 (pprTyVars sorted_tvs) ] - where - pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) - ppr_untidy ty = pprIfaceType (toIfaceType ty) - -- We need ppr_untidy here because pprType will tidy the type, which - -- will turn the bogus kind we are trying to report - -- T :: forall (a::k) k (b::k) -> blah - -- into a misleadingly sanitised version - -- T :: forall (a::k) k1 (b::k1) -> blah - - tcbs = tyConBinders tc - tvs = binderVars tcbs - sorted_tvs = scopedSort tvs - - inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] - specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] - - extra - | null inferred_tvs && null specified_tvs - = empty - | null inferred_tvs - = hang (text "NB: Specified variables") - 2 (sep [pp_spec, text "always come first"]) - | null specified_tvs - = hang (text "NB: Inferred variables") - 2 (sep [pp_inf, text "always come first"]) - | otherwise - = hang (text "NB: Inferred variables") - 2 (vcat [ sep [ pp_inf, text "always come first"] - , sep [text "then Specified variables", pp_spec]]) - - pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) - pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) - TcRnTyFamResultDisabled tc_name tvb -> mkSimpleDecorated $ - text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name) - TcRnRoleValidationFailed role reason -> mkSimpleDecorated $ - vcat [text "Internal error in role inference:", - pprRoleValidationFailedReason role reason, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] - TcRnCommonFieldResultTypeMismatch con1 con2 field_name -> mkSimpleDecorated $ - vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "have a common field" <+> quotes (ppr field_name) <> comma], - nest 2 $ text "but have different result types"] - TcRnCommonFieldTypeMismatch con1 con2 field_name -> mkSimpleDecorated $ - sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - TcRnClassExtensionDisabled cls reason -> mkSimpleDecorated $ - pprDisabledClassExtension cls reason - TcRnDataConParentTypeMismatch data_con res_ty_tmpl -> mkSimpleDecorated $ - hang (text "Data constructor" <+> quotes (ppr data_con) <+> - text "returns type" <+> quotes (ppr actual_res_ty)) - 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) - where - actual_res_ty = dataConOrigResTy data_con - TcRnGADTsDisabled tc_name -> mkSimpleDecorated $ - text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) - TcRnExistentialQuantificationDisabled con -> mkSimpleDecorated $ - sdocOption sdocLinearTypes (\show_linear_types -> - hang (text "Data constructor" <+> quotes (ppr con) <+> - text "has existential type variables, a context, or a specialised result type") - 2 (ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))) - TcRnGADTDataContext tc_name -> mkSimpleDecorated $ - text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - TcRnMultipleConForNewtype tycon n -> mkSimpleDecorated $ - sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n] - TcRnKindSignaturesDisabled thing -> mkSimpleDecorated $ - text "Illegal kind signature" <+> quotes (either ppr with_sig thing) - where - with_sig (tc_name, ksig) = ppr tc_name <+> dcolon <+> ppr ksig - TcRnEmptyDataDeclsDisabled tycon -> mkSimpleDecorated $ - quotes (ppr tycon) <+> text "has no constructors" - TcRnRoleMismatch var annot inferred -> mkSimpleDecorated $ - hang (text "Role mismatch on variable" <+> ppr var <> colon) - 2 (sep [ text "Annotation says", ppr annot - , text "but role", ppr inferred - , text "is required" ]) - TcRnRoleCountMismatch tyvars d@(L _ (RoleAnnotDecl _ _ annots)) -> mkSimpleDecorated $ - hang (text "Wrong number of roles listed in role annotation;" $$ - text "Expected" <+> (ppr tyvars) <> comma <+> - text "got" <+> (ppr $ length annots) <> colon) - 2 (ppr d) - TcRnIllegalRoleAnnotation (RoleAnnotDecl _ tycon _) -> mkSimpleDecorated $ - (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") - TcRnRoleAnnotationsDisabled tc -> mkSimpleDecorated $ - text "Illegal role annotation for" <+> ppr tc - TcRnIncoherentRoles _ -> mkSimpleDecorated $ - (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") - TcRnBindVarAlreadyInScope tv_names_in_scope - -> mkSimpleDecorated $ - vcat - [ text "Type variable" <> plural tv_names_in_scope - <+> hcat (punctuate (text ",") (map (quotes . ppr) tv_names_in_scope)) - <+> isOrAre tv_names_in_scope - <+> text "already in scope." - , text "Type applications in patterns must bind fresh variables, without shadowing." - ] - - TcRnBindMultipleVariables ctx tv_name_w_loc - -> mkSimpleDecorated $ - text "Variable" <+> text "`" <> ppr tv_name_w_loc <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "." - - TcRnUnexpectedKindVar tv_name - -> mkSimpleDecorated $ text "Unexpected kind variable" <+> quotes (ppr tv_name) - - TcRnNegativeNumTypeLiteral tyLit - -> mkSimpleDecorated $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit - - TcRnIllegalKind ty_thing _ - -> mkSimpleDecorated $ text "Illegal kind:" <+> (ppr ty_thing) - - TcRnPrecedenceParsingError op1 op2 - -> mkSimpleDecorated $ - hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", - ppr_opfix op2, - text "in the same infix expression"]) - - TcRnSectionPrecedenceError op arg_op section - -> mkSimpleDecorated $ - vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", - nest 4 (sep [text "must have lower precedence than that of the operand,", - nest 2 (text "namely" <+> ppr_opfix arg_op)]), - nest 4 (text "in the section:" <+> quotes (ppr section))] - - TcRnUnexpectedPatSigType ty - -> mkSimpleDecorated $ - hang (text "Illegal type signature:" <+> quotes (ppr ty)) - 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") - - TcRnIllegalKindSignature ty - -> mkSimpleDecorated $ text "Illegal kind signature:" <+> quotes (ppr ty) - - TcRnUnusedQuantifiedTypeVar doc tyVar - -> mkSimpleDecorated $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tyVar) - , inHsDocContext doc ] - - TcRnDataKindsError typeOrKind thing - -> mkSimpleDecorated $ - text "Illegal" <+> (text $ levelString typeOrKind) <> colon <+> quotes (ppr thing) - - TcRnTypeSynonymCycle decl_or_tcs - -> mkSimpleDecorated $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_decl decl_or_tcs)) ] - where - ppr_decl = \case - Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl - Left tc -> - let n = tyConName tc - in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc) - <+> text "from external module" - TcRnZonkerMessage err - -> mkSimpleDecorated $ pprZonkerMessage err - TcRnInterfaceError reason - -> diagnosticMessage (tcOptsIfaceOpts opts) reason - TcRnSelfImport imp_mod_name - -> mkSimpleDecorated $ - text "A module cannot import itself:" <+> ppr imp_mod_name - TcRnNoExplicitImportList mod - -> mkSimpleDecorated $ - text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" - TcRnSafeImportsDisabled _ - -> mkSimpleDecorated $ - text "safe import can't be used as Safe Haskell isn't on!" - TcRnDeprecatedModule mod txt - -> mkSimpleDecorated $ - sep [ text "Module" <+> quotes (ppr mod) <> text extra <> colon, - nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ] - where - (extra, msg) = case txt of - WarningTxt _ _ msg -> ("", msg) - DeprecatedTxt _ msg -> (" is deprecated", msg) - TcRnCompatUnqualifiedImport decl - -> mkSimpleDecorated $ - vcat - [ text "To ensure compatibility with future core libraries changes" - , text "imports to" <+> ppr (ideclName decl) <+> text "should be" - , text "either qualified or have an explicit import list." - ] - TcRnRedundantSourceImport mod_name - -> mkSimpleDecorated $ - text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) - TcRnImportLookup reason - -> mkSimpleDecorated $ - pprImportLookup reason - TcRnUnusedImport decl reason - -> mkSimpleDecorated $ - pprUnusedImport decl reason - TcRnDuplicateDecls name sorted_names - -> mkSimpleDecorated $ - vcat [text "Multiple declarations of" <+> - quotes (ppr name), - -- NB. print the OccName, not the Name, because the - -- latter might not be in scope in the RdrEnv and so will - -- be printed qualified. - text "Declared at:" <+> - vcat (NE.toList $ ppr . nameSrcLoc <$> sorted_names)] - TcRnPackageImportsDisabled - -> mkSimpleDecorated $ - text "Package-qualified imports are not enabled" - TcRnIllegalDataCon name - -> mkSimpleDecorated $ - hsep [text "Illegal data constructor name", quotes (ppr name)] - TcRnNestedForallsContexts entity - -> mkSimpleDecorated $ - what <+> text "cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" - where - what = case entity of - NFC_Specialize -> text "SPECIALISE instance type" - NFC_ViaType -> quotes (text "via") <+> text "type" - NFC_GadtConSig -> text "GADT constructor type signature" - NFC_InstanceHead -> text "Instance head" - NFC_StandaloneDerivedInstanceHead -> text "Standalone-derived instance head" - NFC_DerivedClassType -> text "Derived class type" - TcRnRedundantRecordWildcard - -> mkSimpleDecorated $ - text "Record wildcard does not bind any new variables" - TcRnUnusedRecordWildcard _ - -> mkSimpleDecorated $ - text "No variables bound in the record wildcard match are used" - TcRnUnusedName name reason - -> mkSimpleDecorated $ - pprUnusedName name reason - TcRnQualifiedBinder rdr_name - -> mkSimpleDecorated $ - text "Qualified name in binding position:" <+> ppr rdr_name - TcRnTypeApplicationsDisabled ty_app - -> mkSimpleDecorated $ - text "Illegal visible" <+> what <+> text "application" <+> ctx <> colon - <+> ppr arg - where - arg = case ty_app of - TypeApplication ty _ -> char '@' <> ppr ty - TypeApplicationInPattern ty_app -> ppr ty_app - what = case ty_app of - TypeApplication _ ty_or_ki -> - case ty_or_ki of - TypeLevel -> text "type" - KindLevel -> text "kind" - TypeApplicationInPattern _ -> text "type" - ctx = case ty_app of - TypeApplicationInPattern _ -> text "in a pattern" - _ -> empty - TcRnInvalidRecordField con field - -> mkSimpleDecorated $ - hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] - TcRnTupleTooLarge tup_size - -> mkSimpleDecorated $ - sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", - nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")] - TcRnCTupleTooLarge tup_size - -> mkSimpleDecorated $ - hang (text "Constraint tuple arity too large:" <+> int tup_size - <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) - 2 (text "Instead, use a nested tuple") - TcRnIllegalInferredTyVars _ - -> mkSimpleDecorated $ - text "Inferred type variables are not allowed" - TcRnAmbiguousName gre_env name gres - -> mkSimpleDecorated $ - vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot - , text "It could refer to" - , nest 3 (vcat msgs) ] - where - np1 NE.:| nps = gres - msgs = punctuateFinal comma dot $ - text "either" <+> ppr_gre np1 - : [text " or" <+> ppr_gre np | np <- nps] - - ppr_gre gre = pprAmbiguousGreName gre_env gre - - TcRnBindingNameConflict name locs - -> mkSimpleDecorated $ - vcat [text "Conflicting definitions for" <+> quotes (ppr name), - locations] - where - locations = - text "Bound at:" - <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs))) - TcRnNonCanonicalDefinition reason inst_ty - -> mkSimpleDecorated $ - pprNonCanonicalDefinition inst_ty reason - TcRnImplicitImportOfPrelude - -> mkSimpleDecorated $ - text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported." - TcRnMissingMain explicit_export_list main_mod main_occ - -> mkSimpleDecorated $ - text "The" <+> ppMainFn main_occ - <+> text "is not" <+> defOrExp <+> text "module" - <+> quotes (ppr main_mod) - where - defOrExp :: SDoc - defOrExp | explicit_export_list = text "exported by" - | otherwise = text "defined in" - TcRnGhciUnliftedBind id - -> mkSimpleDecorated $ - sep [ text "GHCi can't bind a variable of unlifted type:" - , nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id)) ] - TcRnGhciMonadLookupFail ty lookups - -> mkSimpleDecorated $ - hang (text "Can't find type" <+> pp_ty <> dot $$ ambig_msg) - 2 (text "When checking that" <+> pp_ty <> - text "is a monad that can execute GHCi statements.") - where - pp_ty = quotes (text ty) - ambig_msg = case lookups of - Just (_:_:_) -> text "The type is ambiguous." - _ -> empty - TcRnIllegalQuasiQuotes -> mkSimpleDecorated $ - text "Quasi-quotes are not permitted without QuasiQuotes" - TcRnTHError err -> pprTHError err - TcRnPatersonCondFailure reason ctxt lhs rhs -> - mkSimpleDecorated $ pprPatersonCondFailure reason ctxt lhs rhs - TcRnIllegalInvisTyVarBndr bndr -> - mkSimpleDecorated $ - hang (text "Illegal invisible type variable binder:") - 2 (ppr bndr) - - TcRnInvalidInvisTyVarBndr name hs_bndr -> - mkSimpleDecorated $ - vcat [ hang (text "Invalid invisible type variable binder:") - 2 (ppr hs_bndr) - , text "There is no matching forall-bound variable" - , text "in the standalone kind signature for" <+> quotes (ppr name) <> dot - , text "NB." <+> vcat [ - text "Only" <+> quotes (text "forall a.") <+> text "-quantification matches invisible binders,", - text "whereas" <+> quotes (text "forall {a}.") <+> text "and" <+> quotes (text "forall a ->") <+> text "do not." - ]] - - TcRnDeprecatedInvisTyArgInConPat -> - mkSimpleDecorated $ - cat [ text "Type applications in constructor patterns will require" - , text "the TypeAbstractions extension starting from GHC 9.12." ] - - TcRnInvisBndrWithoutSig _ hs_bndr -> - mkSimpleDecorated $ - vcat [ hang (text "Invalid invisible type variable binder:") - 2 (ppr hs_bndr) - , text "Either a standalone kind signature (SAKS)" - , text "or a complete user-supplied kind (CUSK, legacy feature)" - , text "is required to use invisible binders." ] - - TcRnImplicitRhsQuantification kv -> mkSimpleDecorated $ - vcat [ text "The variable" <+> quotes (ppr kv) <+> text "occurs free on the RHS of the type declaration" - , text "In the future GHC will no longer implicitly quantify over such variables" - ] - - diagnosticReason = \case - TcRnUnknownMessage m - -> diagnosticReason m - TcRnMessageWithInfo _ msg_with_info - -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticReason m - TcRnWithHsDocContext _ msg - -> diagnosticReason msg - TcRnSolverReport _ reason _ - -> reason -- Error, or a Warning if we are deferring type errors - TcRnSolverDepthError {} - -> ErrorWithoutFlag - TcRnRedundantConstraints {} - -> WarningWithFlag Opt_WarnRedundantConstraints - TcRnInaccessibleCode {} - -> WarningWithFlag Opt_WarnInaccessibleCode - TcRnInaccessibleCoAxBranch {} - -> WarningWithFlag Opt_WarnInaccessibleCode - TcRnTypeDoesNotHaveFixedRuntimeRep{} - -> ErrorWithoutFlag - TcRnImplicitLift{} - -> WarningWithFlag Opt_WarnImplicitLift - TcRnUnusedPatternBinds{} - -> WarningWithFlag Opt_WarnUnusedPatternBinds - TcRnDodgyImports{} - -> WarningWithFlag Opt_WarnDodgyImports - TcRnDodgyExports{} - -> WarningWithFlag Opt_WarnDodgyExports - TcRnMissingImportList{} - -> WarningWithFlag Opt_WarnMissingImportList - TcRnUnsafeDueToPlugin{} - -> WarningWithoutFlag - TcRnModMissingRealSrcSpan{} - -> ErrorWithoutFlag - TcRnIdNotExportedFromModuleSig{} - -> ErrorWithoutFlag - TcRnIdNotExportedFromLocalSig{} - -> ErrorWithoutFlag - TcRnShadowedName{} - -> WarningWithFlag Opt_WarnNameShadowing - TcRnInvalidWarningCategory{} - -> ErrorWithoutFlag - TcRnDuplicateWarningDecls{} - -> ErrorWithoutFlag - TcRnSimplifierTooManyIterations{} - -> ErrorWithoutFlag - TcRnIllegalPatSynDecl{} - -> ErrorWithoutFlag - TcRnLinearPatSyn{} - -> ErrorWithoutFlag - TcRnEmptyRecordUpdate - -> ErrorWithoutFlag - TcRnIllegalFieldPunning{} - -> ErrorWithoutFlag - TcRnIllegalWildcardsInRecord{} - -> ErrorWithoutFlag - TcRnIllegalWildcardInType{} - -> ErrorWithoutFlag - TcRnDuplicateFieldName{} - -> ErrorWithoutFlag - TcRnIllegalViewPattern{} - -> ErrorWithoutFlag - TcRnCharLiteralOutOfRange{} - -> ErrorWithoutFlag - TcRnIllegalWildcardsInConstructor{} - -> ErrorWithoutFlag - TcRnIgnoringAnnotations{} - -> WarningWithoutFlag - TcRnAnnotationInSafeHaskell - -> ErrorWithoutFlag - TcRnInvalidTypeApplication{} - -> ErrorWithoutFlag - TcRnTagToEnumMissingValArg - -> ErrorWithoutFlag - TcRnTagToEnumUnspecifiedResTy{} - -> ErrorWithoutFlag - TcRnTagToEnumResTyNotAnEnum{} - -> ErrorWithoutFlag - TcRnTagToEnumResTyTypeData{} - -> ErrorWithoutFlag - TcRnArrowIfThenElsePredDependsOnResultTy - -> ErrorWithoutFlag - TcRnIllegalHsBootOrSigDecl {} - -> ErrorWithoutFlag - TcRnBootMismatch {} - -> ErrorWithoutFlag - TcRnRecursivePatternSynonym{} - -> ErrorWithoutFlag - TcRnPartialTypeSigTyVarMismatch{} - -> ErrorWithoutFlag - TcRnPartialTypeSigBadQuantifier{} - -> ErrorWithoutFlag - TcRnMissingSignature what exported - -> WarningWithFlags $ missingSignatureWarningFlags what exported - TcRnPolymorphicBinderMissingSig{} - -> WarningWithFlag Opt_WarnMissingLocalSignatures - TcRnOverloadedSig{} - -> ErrorWithoutFlag - TcRnTupleConstraintInst{} - -> ErrorWithoutFlag - TcRnUserTypeError{} - -> ErrorWithoutFlag - TcRnConstraintInKind{} - -> ErrorWithoutFlag - TcRnUnboxedTupleOrSumTypeFuncArg{} - -> ErrorWithoutFlag - TcRnLinearFuncInKind{} - -> ErrorWithoutFlag - TcRnForAllEscapeError{} - -> ErrorWithoutFlag - TcRnSimplifiableConstraint{} - -> WarningWithFlag Opt_WarnSimplifiableClassConstraints - TcRnArityMismatch{} - -> ErrorWithoutFlag - TcRnIllegalInstance rea - -> illegalInstanceReason rea - TcRnVDQInTermType{} - -> ErrorWithoutFlag - TcRnBadQuantPredHead{} - -> ErrorWithoutFlag - TcRnIllegalTupleConstraint{} - -> ErrorWithoutFlag - TcRnNonTypeVarArgInConstraint{} - -> ErrorWithoutFlag - TcRnIllegalImplicitParam{} - -> ErrorWithoutFlag - TcRnIllegalConstraintSynonymOfKind{} - -> ErrorWithoutFlag - TcRnOversaturatedVisibleKindArg{} - -> ErrorWithoutFlag - TcRnForAllRankErr{} - -> ErrorWithoutFlag - TcRnMonomorphicBindings{} - -> WarningWithFlag Opt_WarnMonomorphism - TcRnOrphanInstance{} - -> WarningWithFlag Opt_WarnOrphans - TcRnFunDepConflict{} - -> ErrorWithoutFlag - TcRnDupInstanceDecls{} - -> ErrorWithoutFlag - TcRnConflictingFamInstDecls{} - -> ErrorWithoutFlag - TcRnFamInstNotInjective{} - -> ErrorWithoutFlag - TcRnBangOnUnliftedType{} - -> WarningWithFlag Opt_WarnRedundantStrictnessFlags - TcRnLazyBangOnUnliftedType{} - -> WarningWithFlag Opt_WarnRedundantStrictnessFlags - TcRnMultipleDefaultDeclarations{} - -> ErrorWithoutFlag - TcRnBadDefaultType{} - -> ErrorWithoutFlag - TcRnPatSynBundledWithNonDataCon{} - -> ErrorWithoutFlag - TcRnPatSynBundledWithWrongType{} - -> ErrorWithoutFlag - TcRnDupeModuleExport{} - -> WarningWithFlag Opt_WarnDuplicateExports - TcRnExportedModNotImported{} - -> ErrorWithoutFlag - TcRnNullExportedModule{} - -> WarningWithFlag Opt_WarnDodgyExports - TcRnMissingExportList{} - -> WarningWithFlag Opt_WarnMissingExportList - TcRnExportHiddenComponents{} - -> ErrorWithoutFlag - TcRnDuplicateExport{} - -> WarningWithFlag Opt_WarnDuplicateExports - TcRnExportedParentChildMismatch{} - -> ErrorWithoutFlag - TcRnConflictingExports{} - -> ErrorWithoutFlag - TcRnDuplicateFieldExport {} - -> ErrorWithoutFlag - TcRnAmbiguousFieldInUpdate {} - -> ErrorWithoutFlag - TcRnAmbiguousRecordUpdate{} - -> WarningWithFlag Opt_WarnAmbiguousFields - TcRnMissingFields{} - -> WarningWithFlag Opt_WarnMissingFields - TcRnFieldUpdateInvalidType{} - -> ErrorWithoutFlag - TcRnMissingStrictFields{} - -> ErrorWithoutFlag - TcRnBadRecordUpdate{} - -> ErrorWithoutFlag - TcRnIllegalStaticExpression {} - -> ErrorWithoutFlag - TcRnStaticFormNotClosed{} - -> ErrorWithoutFlag - TcRnUselessTypeable - -> WarningWithFlag Opt_WarnDerivingTypeable - TcRnDerivingDefaults{} - -> WarningWithFlag Opt_WarnDerivingDefaults - TcRnNonUnaryTypeclassConstraint{} - -> ErrorWithoutFlag - TcRnPartialTypeSignatures{} - -> WarningWithFlag Opt_WarnPartialTypeSignatures - TcRnCannotDeriveInstance _ _ _ _ rea - -> case rea of - DerivErrNotWellKinded{} -> ErrorWithoutFlag - DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag - DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag - DerivErrNoEtaReduce{} -> ErrorWithoutFlag - DerivErrBootFileFound -> ErrorWithoutFlag - DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag - DerivErrGNDUsedOnData -> ErrorWithoutFlag - DerivErrNullaryClasses -> ErrorWithoutFlag - DerivErrLastArgMustBeApp -> ErrorWithoutFlag - DerivErrNoFamilyInstance{} -> ErrorWithoutFlag - DerivErrNotStockDeriveable{} -> ErrorWithoutFlag - DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag - DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag - DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag - DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag - DerivErrNotDeriveable{} -> ErrorWithoutFlag - DerivErrNotAClass{} -> ErrorWithoutFlag - DerivErrNoConstructors{} -> ErrorWithoutFlag - DerivErrLangExtRequired{} -> ErrorWithoutFlag - DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag - DerivErrMustBeEnumType{} -> ErrorWithoutFlag - DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag - DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag - DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag - DerivErrBadConstructor{} -> ErrorWithoutFlag - DerivErrGenerics{} -> ErrorWithoutFlag - DerivErrEnumOrProduct{} -> ErrorWithoutFlag - TcRnLookupInstance _ _ _ - -> ErrorWithoutFlag - TcRnLazyGADTPattern - -> ErrorWithoutFlag - TcRnArrowProcGADTPattern - -> ErrorWithoutFlag - TcRnForallIdentifier {} - -> WarningWithFlag Opt_WarnForallIdentifier - TcRnTypeEqualityOutOfScope - -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope - TcRnTypeEqualityRequiresOperators - -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators - TcRnIllegalTypeOperator {} - -> ErrorWithoutFlag - TcRnIllegalTypeOperatorDecl {} - -> ErrorWithoutFlag - TcRnGADTMonoLocalBinds {} - -> WarningWithFlag Opt_WarnGADTMonoLocalBinds - TcRnIncorrectNameSpace {} - -> ErrorWithoutFlag - TcRnNotInScope {} - -> ErrorWithoutFlag - TcRnTermNameInType {} - -> ErrorWithoutFlag - TcRnUntickedPromotedThing {} - -> WarningWithFlag Opt_WarnUntickedPromotedConstructors - TcRnIllegalBuiltinSyntax {} - -> ErrorWithoutFlag - TcRnWarnDefaulting {} - -> WarningWithFlag Opt_WarnTypeDefaults - TcRnForeignImportPrimExtNotSet{} - -> ErrorWithoutFlag - TcRnForeignImportPrimSafeAnn{} - -> ErrorWithoutFlag - TcRnForeignFunctionImportAsValue{} - -> ErrorWithoutFlag - TcRnFunPtrImportWithoutAmpersand{} - -> WarningWithFlag Opt_WarnDodgyForeignImports - TcRnIllegalForeignDeclBackend{} - -> ErrorWithoutFlag - TcRnUnsupportedCallConv _ unsupportedCC - -> case unsupportedCC of - StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions - _ -> ErrorWithoutFlag - TcRnIllegalForeignType{} - -> ErrorWithoutFlag - TcRnInvalidCIdentifier{} - -> ErrorWithoutFlag - TcRnExpectedValueId{} - -> ErrorWithoutFlag - TcRnRecSelectorEscapedTyVar{} - -> ErrorWithoutFlag - TcRnPatSynNotBidirectional{} - -> ErrorWithoutFlag - TcRnIllegalDerivingItem{} - -> ErrorWithoutFlag - TcRnUnexpectedAnnotation{} - -> ErrorWithoutFlag - TcRnIllegalRecordSyntax{} - -> ErrorWithoutFlag - TcRnInvalidVisibleKindArgument{} - -> ErrorWithoutFlag - TcRnTooManyBinders{} - -> ErrorWithoutFlag - TcRnDifferentNamesForTyVar{} - -> ErrorWithoutFlag - TcRnDisconnectedTyVar{} - -> ErrorWithoutFlag - TcRnInvalidReturnKind{} - -> ErrorWithoutFlag - TcRnClassKindNotConstraint{} - -> ErrorWithoutFlag - TcRnUnpromotableThing{} - -> ErrorWithoutFlag - TcRnMatchesHaveDiffNumArgs{} - -> ErrorWithoutFlag - TcRnCannotBindScopedTyVarInPatSig{} - -> ErrorWithoutFlag - TcRnCannotBindTyVarsInPatBind{} - -> ErrorWithoutFlag - TcRnTooManyTyArgsInConPattern{} - -> ErrorWithoutFlag - TcRnMultipleInlinePragmas{} - -> WarningWithoutFlag - TcRnUnexpectedPragmas{} - -> WarningWithoutFlag - TcRnNonOverloadedSpecialisePragma{} - -> WarningWithoutFlag - TcRnSpecialiseNotVisible{} - -> WarningWithoutFlag - TcRnPragmaWarning{pragma_warning_msg} - -> WarningWithCategory (warningTxtCategory pragma_warning_msg) - TcRnDifferentExportWarnings _ _ - -> ErrorWithoutFlag - TcRnIncompleteExportWarnings _ _ - -> WarningWithFlag Opt_WarnIncompleteExportWarnings - TcRnIllegalHsigDefaultMethods{} - -> ErrorWithoutFlag - TcRnHsigFixityMismatch{} - -> ErrorWithoutFlag - TcRnHsigShapeMismatch{} - -> ErrorWithoutFlag - TcRnHsigMissingModuleExport{} - -> ErrorWithoutFlag - TcRnBadGenericMethod{} - -> ErrorWithoutFlag - TcRnWarningMinimalDefIncomplete{} - -> WarningWithoutFlag - TcRnDefaultMethodForPragmaLacksBinding{} - -> ErrorWithoutFlag - TcRnIgnoreSpecialisePragmaOnDefMethod{} - -> WarningWithoutFlag - TcRnBadMethodErr{} - -> ErrorWithoutFlag - TcRnIllegalTypeData - -> ErrorWithoutFlag - TcRnIllegalQuasiQuotes{} - -> ErrorWithoutFlag - TcRnTHError err - -> thErrorReason err - TcRnTypeDataForbids{} - -> ErrorWithoutFlag - TcRnIllegalNewtype{} - -> ErrorWithoutFlag - TcRnUnsatisfiedMinimalDef{} - -> WarningWithFlag (Opt_WarnMissingMethods) - TcRnMisplacedInstSig{} - -> ErrorWithoutFlag - TcRnNoRebindableSyntaxRecordDot{} - -> ErrorWithoutFlag - TcRnNoFieldPunsRecordDot{} - -> ErrorWithoutFlag - TcRnListComprehensionDuplicateBinding{} - -> ErrorWithoutFlag - TcRnEmptyStmtsGroup{} - -> ErrorWithoutFlag - TcRnLastStmtNotExpr{} - -> ErrorWithoutFlag - TcRnUnexpectedStatementInContext{} - -> ErrorWithoutFlag - TcRnSectionWithoutParentheses{} - -> ErrorWithoutFlag - TcRnIllegalImplicitParameterBindings{} - -> ErrorWithoutFlag - TcRnIllegalTupleSection{} - -> ErrorWithoutFlag - TcRnCapturedTermName{} - -> WarningWithFlag Opt_WarnTermVariableCapture - TcRnBindingOfExistingName{} - -> ErrorWithoutFlag - TcRnMultipleFixityDecls{} - -> ErrorWithoutFlag - TcRnIllegalPatternSynonymDecl{} - -> ErrorWithoutFlag - TcRnIllegalClassBinding{} - -> ErrorWithoutFlag - TcRnOrphanCompletePragma{} - -> ErrorWithoutFlag - TcRnEmptyCase{} - -> ErrorWithoutFlag - TcRnNonStdGuards{} - -> WarningWithoutFlag - TcRnDuplicateSigDecl{} - -> ErrorWithoutFlag - TcRnMisplacedSigDecl{} - -> ErrorWithoutFlag - TcRnUnexpectedDefaultSig{} - -> ErrorWithoutFlag - TcRnDuplicateMinimalSig{} - -> ErrorWithoutFlag - TcRnLoopySuperclassSolve{} - -> WarningWithFlag Opt_WarnLoopySuperclassSolve - TcRnUnexpectedStandaloneDerivingDecl{} - -> ErrorWithoutFlag - TcRnUnusedVariableInRuleDecl{} - -> ErrorWithoutFlag - TcRnUnexpectedStandaloneKindSig{} - -> ErrorWithoutFlag - TcRnIllegalRuleLhs{} - -> ErrorWithoutFlag - TcRnDuplicateRoleAnnot{} - -> ErrorWithoutFlag - TcRnDuplicateKindSig{} - -> ErrorWithoutFlag - TcRnIllegalDerivStrategy{} - -> ErrorWithoutFlag - TcRnIllegalMultipleDerivClauses{} - -> ErrorWithoutFlag - TcRnNoDerivStratSpecified{} - -> WarningWithFlag Opt_WarnMissingDerivingStrategies - TcRnStupidThetaInGadt{} - -> ErrorWithoutFlag - TcRnShadowedTyVarNameInFamResult{} - -> ErrorWithoutFlag - TcRnIncorrectTyVarOnLhsOfInjCond{} - -> ErrorWithoutFlag - TcRnUnknownTyVarsOnRhsOfInjCond{} - -> ErrorWithoutFlag - TcRnBadlyStaged{} - -> ErrorWithoutFlag - TcRnStageRestriction{} - -> ErrorWithoutFlag - TcRnTyThingUsedWrong{} - -> ErrorWithoutFlag - TcRnCannotDefaultKindVar{} - -> ErrorWithoutFlag - TcRnUninferrableTyVar{} - -> ErrorWithoutFlag - TcRnSkolemEscape{} - -> ErrorWithoutFlag - TcRnPatSynEscapedCoercion{} - -> ErrorWithoutFlag - TcRnPatSynExistentialInResult{} - -> ErrorWithoutFlag - TcRnPatSynArityMismatch{} - -> ErrorWithoutFlag - TcRnPatSynInvalidRhs{} - -> ErrorWithoutFlag - TcRnTyFamDepsDisabled{} - -> ErrorWithoutFlag - TcRnAbstractClosedTyFamDecl{} - -> ErrorWithoutFlag - TcRnPartialFieldSelector{} - -> WarningWithFlag Opt_WarnPartialFields - TcRnBadFieldAnnotation _ _ LazyFieldsDisabled - -> ErrorWithoutFlag - TcRnBadFieldAnnotation{} - -> WarningWithoutFlag - TcRnSuperclassCycle{} - -> ErrorWithoutFlag - TcRnDefaultSigMismatch{} - -> ErrorWithoutFlag - TcRnTyFamsDisabled{} - -> ErrorWithoutFlag - TcRnBadTyConTelescope {} - -> ErrorWithoutFlag - TcRnTyFamResultDisabled{} - -> ErrorWithoutFlag - TcRnRoleValidationFailed{} - -> ErrorWithoutFlag - TcRnCommonFieldResultTypeMismatch{} - -> ErrorWithoutFlag - TcRnCommonFieldTypeMismatch{} - -> ErrorWithoutFlag - TcRnClassExtensionDisabled{} - -> ErrorWithoutFlag - TcRnDataConParentTypeMismatch{} - -> ErrorWithoutFlag - TcRnGADTsDisabled{} - -> ErrorWithoutFlag - TcRnExistentialQuantificationDisabled{} - -> ErrorWithoutFlag - TcRnGADTDataContext{} - -> ErrorWithoutFlag - TcRnMultipleConForNewtype{} - -> ErrorWithoutFlag - TcRnKindSignaturesDisabled{} - -> ErrorWithoutFlag - TcRnEmptyDataDeclsDisabled{} - -> ErrorWithoutFlag - TcRnRoleMismatch{} - -> ErrorWithoutFlag - TcRnRoleCountMismatch{} - -> ErrorWithoutFlag - TcRnIllegalRoleAnnotation{} - -> ErrorWithoutFlag - TcRnRoleAnnotationsDisabled{} - -> ErrorWithoutFlag - TcRnIncoherentRoles{} - -> ErrorWithoutFlag - TcRnBindVarAlreadyInScope{} - -> ErrorWithoutFlag - TcRnBindMultipleVariables{} - -> ErrorWithoutFlag - TcRnUnexpectedKindVar{} - -> ErrorWithoutFlag - TcRnNegativeNumTypeLiteral{} - -> ErrorWithoutFlag - TcRnIllegalKind{} - -> ErrorWithoutFlag - TcRnPrecedenceParsingError{} - -> ErrorWithoutFlag - TcRnSectionPrecedenceError{} - -> ErrorWithoutFlag - TcRnUnexpectedPatSigType{} - -> ErrorWithoutFlag - TcRnIllegalKindSignature{} - -> ErrorWithoutFlag - TcRnUnusedQuantifiedTypeVar{} - -> WarningWithFlag Opt_WarnUnusedForalls - TcRnDataKindsError{} - -> ErrorWithoutFlag - TcRnTypeSynonymCycle{} - -> ErrorWithoutFlag - TcRnZonkerMessage msg - -> zonkerMessageReason msg - TcRnInterfaceError err - -> interfaceErrorReason err - TcRnSelfImport{} - -> ErrorWithoutFlag - TcRnNoExplicitImportList{} - -> WarningWithFlag Opt_WarnMissingImportList - TcRnSafeImportsDisabled{} - -> ErrorWithoutFlag - TcRnDeprecatedModule _ txt - -> WarningWithCategory (warningTxtCategory txt) - TcRnCompatUnqualifiedImport{} - -> WarningWithFlag Opt_WarnCompatUnqualifiedImports - TcRnRedundantSourceImport{} - -> WarningWithoutFlag - TcRnImportLookup{} - -> ErrorWithoutFlag - TcRnUnusedImport{} - -> WarningWithFlag Opt_WarnUnusedImports - TcRnDuplicateDecls{} - -> ErrorWithoutFlag - TcRnPackageImportsDisabled - -> ErrorWithoutFlag - TcRnIllegalDataCon{} - -> ErrorWithoutFlag - TcRnNestedForallsContexts{} - -> ErrorWithoutFlag - TcRnRedundantRecordWildcard - -> WarningWithFlag Opt_WarnRedundantRecordWildcards - TcRnUnusedRecordWildcard{} - -> WarningWithFlag Opt_WarnUnusedRecordWildcards - TcRnUnusedName _ prov - -> WarningWithFlag $ case prov of - UnusedNameTopDecl -> Opt_WarnUnusedTopBinds - UnusedNameImported _ -> Opt_WarnUnusedTopBinds - UnusedNameTypePattern -> Opt_WarnUnusedTypePatterns - UnusedNameMatch -> Opt_WarnUnusedMatches - UnusedNameLocalBind -> Opt_WarnUnusedLocalBinds - TcRnQualifiedBinder{} - -> ErrorWithoutFlag - TcRnTypeApplicationsDisabled{} - -> ErrorWithoutFlag - TcRnInvalidRecordField{} - -> ErrorWithoutFlag - TcRnTupleTooLarge{} - -> ErrorWithoutFlag - TcRnCTupleTooLarge{} - -> ErrorWithoutFlag - TcRnIllegalInferredTyVars{} - -> ErrorWithoutFlag - TcRnAmbiguousName{} - -> ErrorWithoutFlag - TcRnBindingNameConflict{} - -> ErrorWithoutFlag - TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _ - -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances - TcRnNonCanonicalDefinition (NonCanonicalMonad _) _ - -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances - TcRnImplicitImportOfPrelude {} - -> WarningWithFlag Opt_WarnImplicitPrelude - TcRnMissingMain {} - -> ErrorWithoutFlag - TcRnGhciUnliftedBind {} - -> ErrorWithoutFlag - TcRnGhciMonadLookupFail {} - -> ErrorWithoutFlag - TcRnMissingRoleAnnotation{} - -> WarningWithFlag Opt_WarnMissingRoleAnnotations - TcRnIllegalInvisTyVarBndr{} - -> ErrorWithoutFlag - TcRnDeprecatedInvisTyArgInConPat {} - -> WarningWithoutFlag - TcRnInvalidInvisTyVarBndr{} - -> ErrorWithoutFlag - TcRnInvisBndrWithoutSig{} - -> ErrorWithoutFlag - TcRnImplicitRhsQuantification{} - -> WarningWithFlag Opt_WarnImplicitRhsQuantification - TcRnPatersonCondFailure{} - -> ErrorWithoutFlag - - diagnosticHints = \case - TcRnUnknownMessage m - -> diagnosticHints m - TcRnMessageWithInfo _ msg_with_info - -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticHints m - TcRnWithHsDocContext _ msg - -> diagnosticHints msg - TcRnSolverReport _ _ hints - -> hints - TcRnSolverDepthError {} - -> [SuggestIncreaseReductionDepth] - TcRnRedundantConstraints{} - -> noHints - TcRnInaccessibleCode{} - -> noHints - TcRnInaccessibleCoAxBranch{} - -> noHints - TcRnTypeDoesNotHaveFixedRuntimeRep{} - -> noHints - TcRnImplicitLift{} - -> noHints - TcRnUnusedPatternBinds{} - -> noHints - TcRnDodgyImports{} - -> noHints - TcRnDodgyExports{} - -> noHints - TcRnMissingImportList{} - -> noHints - TcRnUnsafeDueToPlugin{} - -> noHints - TcRnModMissingRealSrcSpan{} - -> noHints - TcRnIdNotExportedFromModuleSig name mod - -> [SuggestAddToHSigExportList name $ Just mod] - TcRnIdNotExportedFromLocalSig name - -> [SuggestAddToHSigExportList name Nothing] - TcRnShadowedName{} - -> noHints - TcRnInvalidWarningCategory{} - -> noHints - TcRnDuplicateWarningDecls{} - -> noHints - TcRnSimplifierTooManyIterations{} - -> [SuggestIncreaseSimplifierIterations] - TcRnIllegalPatSynDecl{} - -> noHints - TcRnLinearPatSyn{} - -> noHints - TcRnEmptyRecordUpdate{} - -> noHints - TcRnIllegalFieldPunning{} - -> [suggestExtension LangExt.NamedFieldPuns] - TcRnIllegalWildcardsInRecord{} - -> [suggestExtension LangExt.RecordWildCards] - TcRnIllegalWildcardInType{} - -> noHints - TcRnDuplicateFieldName{} - -> noHints - TcRnIllegalViewPattern{} - -> [suggestExtension LangExt.ViewPatterns] - TcRnCharLiteralOutOfRange{} - -> noHints - TcRnIllegalWildcardsInConstructor{} - -> noHints - TcRnIgnoringAnnotations{} - -> noHints - TcRnAnnotationInSafeHaskell - -> noHints - TcRnInvalidTypeApplication{} - -> noHints - TcRnTagToEnumMissingValArg - -> noHints - TcRnTagToEnumUnspecifiedResTy{} - -> noHints - TcRnTagToEnumResTyNotAnEnum{} - -> noHints - TcRnTagToEnumResTyTypeData{} - -> noHints - TcRnArrowIfThenElsePredDependsOnResultTy - -> noHints - TcRnIllegalHsBootOrSigDecl {} - -> noHints - TcRnBootMismatch boot_or_sig err - | Hsig <- boot_or_sig - , BootMismatch _ _ (BootMismatchedTyCons _boot_tc real_tc tc_errs) <- err - , any is_synAbsData_etaReduce (NE.toList tc_errs) - -> [SuggestEtaReduceAbsDataTySyn real_tc] - | otherwise - -> noHints - where - is_synAbsData_etaReduce (SynAbstractData SynAbsDataTySynNotNullary) = True - is_synAbsData_etaReduce _ = False - TcRnRecursivePatternSynonym{} - -> noHints - TcRnPartialTypeSigTyVarMismatch{} - -> noHints - TcRnPartialTypeSigBadQuantifier{} - -> noHints - TcRnMissingSignature {} - -> noHints - TcRnPolymorphicBinderMissingSig{} - -> noHints - TcRnOverloadedSig{} - -> noHints - TcRnTupleConstraintInst{} - -> noHints - TcRnUserTypeError{} - -> noHints - TcRnConstraintInKind{} - -> noHints - TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _ - -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum] - TcRnLinearFuncInKind{} - -> noHints - TcRnForAllEscapeError{} - -> noHints - TcRnVDQInTermType{} - -> noHints - TcRnBadQuantPredHead{} - -> noHints - TcRnIllegalTupleConstraint{} - -> [suggestExtension LangExt.ConstraintKinds] - TcRnNonTypeVarArgInConstraint{} - -> [suggestExtension LangExt.FlexibleContexts] - TcRnIllegalImplicitParam{} - -> noHints - TcRnIllegalConstraintSynonymOfKind{} - -> [suggestExtension LangExt.ConstraintKinds] - TcRnOversaturatedVisibleKindArg{} - -> noHints - TcRnForAllRankErr rank _ - -> case rank of - LimitedRank{} -> [suggestExtension LangExt.RankNTypes] - MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes] - MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes] - MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms] - MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints] - _ -> noHints - TcRnSimplifiableConstraint{} - -> noHints - TcRnArityMismatch{} - -> noHints - TcRnIllegalInstance rea - -> illegalInstanceHints rea - TcRnMonomorphicBindings bindings - -> case bindings of - [] -> noHints - (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)] - TcRnOrphanInstance clsOrFamInst - -> [SuggestFixOrphanInst { isFamilyInstance = isFam }] - where - isFam = case clsOrFamInst :: Either ClsInst FamInst of - Left _clsInst -> Nothing - Right famInst -> Just $ fi_flavor famInst - TcRnFunDepConflict{} - -> noHints - TcRnDupInstanceDecls{} - -> noHints - TcRnConflictingFamInstDecls{} - -> noHints - TcRnFamInstNotInjective rea _ _ - -> case rea of - InjErrRhsBareTyVar{} -> noHints - InjErrRhsCannotBeATypeFam -> noHints - InjErrRhsOverlap -> noHints - InjErrCannotInferFromRhs _ _ suggestUndInst - | YesSuggestUndecidableInstaces <- suggestUndInst - -> [suggestExtension LangExt.UndecidableInstances] - | otherwise - -> noHints - TcRnBangOnUnliftedType{} - -> noHints - TcRnLazyBangOnUnliftedType{} - -> noHints - TcRnMultipleDefaultDeclarations{} - -> noHints - TcRnBadDefaultType{} - -> noHints - TcRnPatSynBundledWithNonDataCon{} - -> noHints - TcRnPatSynBundledWithWrongType{} - -> noHints - TcRnDupeModuleExport{} - -> noHints - TcRnExportedModNotImported{} - -> noHints - TcRnNullExportedModule{} - -> noHints - TcRnMissingExportList{} - -> noHints - TcRnExportHiddenComponents{} - -> noHints - TcRnDuplicateExport{} - -> noHints - TcRnExportedParentChildMismatch{} - -> noHints - TcRnConflictingExports{} - -> noHints - TcRnDuplicateFieldExport {} - -> [suggestExtension LangExt.DuplicateRecordFields] - TcRnAmbiguousFieldInUpdate {} - -> [suggestExtension LangExt.DisambiguateRecordFields] - TcRnAmbiguousRecordUpdate{} - -> noHints - TcRnMissingFields{} - -> noHints - TcRnFieldUpdateInvalidType{} - -> noHints - TcRnMissingStrictFields{} - -> noHints - TcRnBadRecordUpdate{} - -> noHints - TcRnIllegalStaticExpression {} - -> [suggestExtension LangExt.StaticPointers] - TcRnStaticFormNotClosed{} - -> noHints - TcRnUselessTypeable - -> noHints - TcRnDerivingDefaults{} - -> [useDerivingStrategies] - TcRnNonUnaryTypeclassConstraint{} - -> noHints - TcRnPartialTypeSignatures suggestParSig _ - -> case suggestParSig of - YesSuggestPartialTypeSignatures - -> let info = text "to use the inferred type" - in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures] - NoSuggestPartialTypeSignatures - -> noHints - TcRnCannotDeriveInstance cls _ _ newtype_deriving rea - -> deriveInstanceErrReasonHints cls newtype_deriving rea - TcRnLookupInstance _ _ _ - -> noHints - TcRnLazyGADTPattern - -> noHints - TcRnArrowProcGADTPattern - -> noHints - TcRnForallIdentifier {} - -> [SuggestRenameForall] - TcRnTypeEqualityOutOfScope - -> noHints - TcRnTypeEqualityRequiresOperators - -> [suggestExtension LangExt.TypeOperators] - TcRnIllegalTypeOperator {} - -> [suggestExtension LangExt.TypeOperators] - TcRnIllegalTypeOperatorDecl {} - -> [suggestExtension LangExt.TypeOperators] - TcRnGADTMonoLocalBinds {} - -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] - TcRnIncorrectNameSpace nm is_th_use - | is_th_use - -> [SuggestAppropriateTHTick $ nameNameSpace nm] - | otherwise - -> noHints - TcRnNotInScope err _ _ hints - -> scopeErrorHints err ++ hints - TcRnTermNameInType _ hints - -> hints - TcRnUntickedPromotedThing thing - -> [SuggestAddTick thing] - TcRnIllegalBuiltinSyntax {} - -> noHints - TcRnWarnDefaulting {} - -> noHints - TcRnForeignImportPrimExtNotSet{} - -> [suggestExtension LangExt.GHCForeignImportPrim] - TcRnForeignImportPrimSafeAnn{} - -> noHints - TcRnForeignFunctionImportAsValue{} - -> noHints - TcRnFunPtrImportWithoutAmpersand{} - -> noHints - TcRnIllegalForeignDeclBackend{} - -> noHints - TcRnUnsupportedCallConv{} - -> noHints - TcRnIllegalForeignType _ reason - -> case reason of - TypeCannotBeMarshaled _ why - | NewtypeDataConNotInScope tc _ <- why - -> let tc_nm = tyConName tc - dc = dataConName $ head $ tyConDataCons tc - in [ ImportSuggestion (occName dc) - $ ImportDataCon Nothing (nameOccName tc_nm) ] - | UnliftedFFITypesNeeded <- why - -> [suggestExtension LangExt.UnliftedFFITypes] - _ -> noHints - TcRnInvalidCIdentifier{} - -> noHints - TcRnExpectedValueId{} - -> noHints - TcRnRecSelectorEscapedTyVar{} - -> [SuggestPatternMatchingSyntax] - TcRnPatSynNotBidirectional{} - -> noHints - TcRnIllegalDerivingItem{} - -> noHints - TcRnUnexpectedAnnotation{} - -> noHints - TcRnIllegalRecordSyntax{} - -> noHints - TcRnInvalidVisibleKindArgument{} - -> noHints - TcRnTooManyBinders{} - -> noHints - TcRnDifferentNamesForTyVar{} - -> noHints - TcRnDisconnectedTyVar n - -> [SuggestBindTyVarExplicitly n] - TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext - -> case mb_suggest_unlifted_ext of - Nothing -> noHints - Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes] - Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes] - TcRnClassKindNotConstraint{} - -> noHints - TcRnUnpromotableThing{} - -> noHints - TcRnMatchesHaveDiffNumArgs{} - -> noHints - TcRnCannotBindScopedTyVarInPatSig{} - -> noHints - TcRnCannotBindTyVarsInPatBind{} - -> noHints - TcRnTooManyTyArgsInConPattern{} - -> noHints - TcRnMultipleInlinePragmas{} - -> noHints - TcRnUnexpectedPragmas{} - -> noHints - TcRnNonOverloadedSpecialisePragma{} - -> noHints - TcRnSpecialiseNotVisible name - -> [SuggestSpecialiseVisibilityHints name] - TcRnPragmaWarning{} - -> noHints - TcRnDifferentExportWarnings _ _ - -> noHints - TcRnIncompleteExportWarnings _ _ - -> noHints - TcRnIllegalHsigDefaultMethods{} - -> noHints - TcRnIllegalQuasiQuotes{} - -> [suggestExtension LangExt.QuasiQuotes] - TcRnTHError err - -> thErrorHints err - TcRnHsigFixityMismatch{} - -> noHints - TcRnHsigShapeMismatch{} - -> noHints - TcRnHsigMissingModuleExport{} - -> noHints - TcRnBadGenericMethod{} - -> noHints - TcRnWarningMinimalDefIncomplete{} - -> noHints - TcRnDefaultMethodForPragmaLacksBinding{} - -> noHints - TcRnIgnoreSpecialisePragmaOnDefMethod{} - -> noHints - TcRnBadMethodErr{} - -> noHints - TcRnIllegalTypeData - -> [suggestExtension LangExt.TypeData] - TcRnTypeDataForbids{} - -> noHints - TcRnIllegalNewtype{} - -> noHints - TcRnUnsatisfiedMinimalDef{} - -> noHints - TcRnMisplacedInstSig{} - -> [suggestExtension LangExt.InstanceSigs] - TcRnNoRebindableSyntaxRecordDot{} - -> noHints - TcRnNoFieldPunsRecordDot{} - -> noHints - TcRnListComprehensionDuplicateBinding{} - -> noHints - TcRnEmptyStmtsGroup EmptyStmtsGroupInDoNotation{} - -> [suggestExtension LangExt.NondecreasingIndentation] - TcRnEmptyStmtsGroup{} - -> noHints - TcRnLastStmtNotExpr{} - -> noHints - TcRnUnexpectedStatementInContext _ _ mExt - | Nothing <- mExt -> noHints - | Just ext <- mExt -> [suggestExtension ext] - TcRnSectionWithoutParentheses{} - -> noHints - TcRnIllegalImplicitParameterBindings{} - -> noHints - TcRnIllegalTupleSection{} - -> [suggestExtension LangExt.TupleSections] - TcRnCapturedTermName{} - -> [SuggestRenameTypeVariable] - TcRnBindingOfExistingName{} - -> noHints - TcRnMultipleFixityDecls{} - -> noHints - TcRnIllegalPatternSynonymDecl{} - -> [suggestExtension LangExt.PatternSynonyms] - TcRnIllegalClassBinding{} - -> noHints - TcRnOrphanCompletePragma{} - -> noHints - TcRnEmptyCase ctxt -> case ctxt of - LamCaseAlt LamCases -> noHints -- cases syntax doesn't support empty case. - ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> noHints - _ -> [suggestExtension LangExt.EmptyCase] - TcRnNonStdGuards{} - -> [suggestExtension LangExt.PatternGuards] - TcRnDuplicateSigDecl{} - -> noHints - TcRnMisplacedSigDecl{} - -> noHints - TcRnUnexpectedDefaultSig{} - -> [suggestExtension LangExt.DefaultSignatures] - TcRnDuplicateMinimalSig{} - -> noHints - TcRnLoopySuperclassSolve wtd_loc wtd_pty - -> [LoopySuperclassSolveHint wtd_pty cls_or_qc] - where - cls_or_qc :: ClsInstOrQC - cls_or_qc = case ctLocOrigin wtd_loc of - ScOrigin c_or_q _ -> c_or_q - _ -> IsClsInst -- shouldn't happen - TcRnUnexpectedStandaloneDerivingDecl{} - -> [suggestExtension LangExt.StandaloneDeriving] - TcRnUnusedVariableInRuleDecl{} - -> noHints - TcRnUnexpectedStandaloneKindSig{} - -> [suggestExtension LangExt.StandaloneKindSignatures] - TcRnIllegalRuleLhs{} - -> noHints - TcRnDuplicateRoleAnnot{} - -> noHints - TcRnDuplicateKindSig{} - -> noHints - TcRnIllegalDerivStrategy ds -> case ds of - ViaStrategy{} -> [suggestExtension LangExt.DerivingVia] - _ -> [suggestExtension LangExt.DerivingStrategies] - TcRnIllegalMultipleDerivClauses{} - -> [suggestExtension LangExt.DerivingStrategies] - TcRnNoDerivStratSpecified isDSEnabled -> if isDSEnabled - then noHints - else [suggestExtension LangExt.DerivingStrategies] - TcRnStupidThetaInGadt{} - -> noHints - TcRnShadowedTyVarNameInFamResult{} - -> noHints - TcRnIncorrectTyVarOnLhsOfInjCond{} - -> noHints - TcRnUnknownTyVarsOnRhsOfInjCond{} - -> noHints - TcRnBadlyStaged{} - -> noHints - TcRnStageRestriction{} - -> noHints - TcRnTyThingUsedWrong{} - -> noHints - TcRnCannotDefaultKindVar{} - -> noHints - TcRnUninferrableTyVar{} - -> noHints - TcRnSkolemEscape{} - -> noHints - TcRnPatSynEscapedCoercion{} - -> noHints - TcRnPatSynExistentialInResult{} - -> noHints - TcRnPatSynArityMismatch{} - -> noHints - TcRnPatSynInvalidRhs name pat args (PatSynNotInvertible _) - -> [SuggestExplicitBidiPatSyn name pat args] - TcRnPatSynInvalidRhs{} - -> noHints - TcRnTyFamDepsDisabled{} - -> [suggestExtension LangExt.TypeFamilyDependencies] - TcRnAbstractClosedTyFamDecl{} - -> noHints - TcRnPartialFieldSelector{} - -> noHints - TcRnBadFieldAnnotation _ _ LazyFieldsDisabled - -> [suggestExtension LangExt.StrictData] - TcRnBadFieldAnnotation{} - -> noHints - TcRnSuperclassCycle{} - -> [suggestExtension LangExt.UndecidableSuperClasses] - TcRnDefaultSigMismatch{} - -> noHints - TcRnTyFamsDisabled{} - -> [suggestExtension LangExt.TypeFamilies] - TcRnBadTyConTelescope{} - -> noHints - TcRnTyFamResultDisabled{} - -> [suggestExtension LangExt.TypeFamilyDependencies] - TcRnRoleValidationFailed{} - -> noHints - TcRnCommonFieldResultTypeMismatch{} - -> noHints - TcRnCommonFieldTypeMismatch{} - -> noHints - TcRnClassExtensionDisabled _ MultiParamDisabled{} - -> [suggestExtension LangExt.MultiParamTypeClasses] - TcRnClassExtensionDisabled _ FunDepsDisabled{} - -> [suggestExtension LangExt.FunctionalDependencies] - TcRnClassExtensionDisabled _ ConstrainedClassMethodsDisabled{} - -> [suggestExtension LangExt.ConstrainedClassMethods] - TcRnDataConParentTypeMismatch{} - -> noHints - TcRnGADTsDisabled{} - -> [suggestExtension LangExt.GADTs] - TcRnExistentialQuantificationDisabled{} - -> [suggestExtension LangExt.ExistentialQuantification, - suggestExtension LangExt.GADTs] - TcRnGADTDataContext{} - -> noHints - TcRnMultipleConForNewtype{} - -> noHints - TcRnKindSignaturesDisabled{} - -> [suggestExtension LangExt.KindSignatures] - TcRnEmptyDataDeclsDisabled{} - -> [suggestExtension LangExt.EmptyDataDecls] - TcRnRoleMismatch{} - -> noHints - TcRnRoleCountMismatch{} - -> noHints - TcRnIllegalRoleAnnotation{} - -> noHints - TcRnRoleAnnotationsDisabled{} - -> [suggestExtension LangExt.RoleAnnotations] - TcRnIncoherentRoles{} - -> [suggestExtension LangExt.IncoherentInstances] - TcRnBindVarAlreadyInScope{} - -> noHints - TcRnBindMultipleVariables{} - -> noHints - TcRnUnexpectedKindVar{} - -> [suggestExtension LangExt.PolyKinds] - TcRnNegativeNumTypeLiteral{} - -> noHints - TcRnIllegalKind _ suggest_polyKinds - -> if suggest_polyKinds - then [suggestExtension LangExt.PolyKinds] - else noHints - TcRnPrecedenceParsingError{} - -> noHints - TcRnSectionPrecedenceError{} - -> noHints - TcRnUnexpectedPatSigType{} - -> [suggestExtension LangExt.ScopedTypeVariables] - TcRnIllegalKindSignature{} - -> [suggestExtension LangExt.KindSignatures] - TcRnUnusedQuantifiedTypeVar{} - -> noHints - TcRnDataKindsError{} - -> [suggestExtension LangExt.DataKinds] - TcRnTypeSynonymCycle{} - -> noHints - TcRnZonkerMessage msg - -> zonkerMessageHints msg - TcRnInterfaceError reason - -> interfaceErrorHints reason - TcRnSelfImport{} - -> noHints - TcRnNoExplicitImportList{} - -> noHints - TcRnSafeImportsDisabled{} - -> [SuggestSafeHaskell] - TcRnDeprecatedModule{} - -> noHints - TcRnCompatUnqualifiedImport{} - -> noHints - TcRnRedundantSourceImport{} - -> noHints - TcRnImportLookup (ImportLookupBad k _ is ie patsyns_enabled) -> - let mod_name = moduleName $ is_mod is - occ = rdrNameOcc $ ieName ie - in case k of - BadImportAvailVar -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name] - BadImportNotExported suggs -> suggs - BadImportAvailTyCon -> [ImportSuggestion occ $ CouldAddTypeKeyword mod_name] - BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par] - BadImportNotExportedSubordinates{} -> noHints - TcRnImportLookup{} - -> noHints - TcRnUnusedImport{} - -> noHints - TcRnDuplicateDecls{} - -> noHints - TcRnPackageImportsDisabled - -> [suggestExtension LangExt.PackageImports] - TcRnIllegalDataCon{} - -> noHints - TcRnNestedForallsContexts{} - -> noHints - TcRnRedundantRecordWildcard - -> [SuggestRemoveRecordWildcard] - TcRnUnusedRecordWildcard{} - -> [SuggestRemoveRecordWildcard] - TcRnUnusedName{} - -> noHints - TcRnQualifiedBinder{} - -> noHints - TcRnTypeApplicationsDisabled ty_app - -> case ty_app of - TypeApplication {} - -> [suggestExtension LangExt.TypeApplications] - TypeApplicationInPattern {} - -> [suggestExtension LangExt.TypeAbstractions] - TcRnInvalidRecordField{} - -> noHints - TcRnTupleTooLarge{} - -> noHints - TcRnCTupleTooLarge{} - -> noHints - TcRnIllegalInferredTyVars{} - -> noHints - TcRnAmbiguousName{} - -> noHints - TcRnBindingNameConflict{} - -> noHints - TcRnNonCanonicalDefinition reason _ - -> suggestNonCanonicalDefinition reason - TcRnImplicitImportOfPrelude {} - -> noHints - TcRnMissingMain {} - -> noHints - TcRnGhciUnliftedBind {} - -> noHints - TcRnGhciMonadLookupFail {} - -> noHints - TcRnMissingRoleAnnotation{} - -> noHints - TcRnIllegalInvisTyVarBndr{} - -> [suggestExtension LangExt.TypeAbstractions] - TcRnDeprecatedInvisTyArgInConPat{} - -> [suggestExtension LangExt.TypeAbstractions] - TcRnInvalidInvisTyVarBndr{} - -> noHints - TcRnInvisBndrWithoutSig name _ - -> [SuggestAddStandaloneKindSignature name] - TcRnImplicitRhsQuantification kv - -> [SuggestBindTyVarOnLhs (unLoc kv)] - TcRnPatersonCondFailure{} - -> [suggestExtension LangExt.UndecidableInstances] - - diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode - diagnosticCode = constructorCode - --- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", --- and so on. The `and` stands for any `conjunction`, which is passed in. -commafyWith :: SDoc -> [SDoc] -> [SDoc] -commafyWith _ [] = [] -commafyWith _ [x] = [x] -commafyWith conjunction [x, y] = [x <+> conjunction <+> y] -commafyWith conjunction xs = addConjunction $ punctuate comma xs - where addConjunction [x, y] = [x, conjunction, y] - addConjunction (x : xs) = x : addConjunction xs - addConjunction _ = panic "commafyWith expected 2 or more elements" - -deriveInstanceErrReasonHints :: Class - -> UsingGeneralizedNewtypeDeriving - -> DeriveInstanceErrReason - -> [GhcHint] -deriveInstanceErrReasonHints cls newtype_deriving = \case - DerivErrNotWellKinded _ _ n_args_to_keep - | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0 - -> [suggestExtension LangExt.PolyKinds] - | otherwise - -> noHints - DerivErrSafeHaskellGenericInst -> noHints - DerivErrDerivingViaWrongKind{} -> noHints - DerivErrNoEtaReduce{} -> noHints - DerivErrBootFileFound -> noHints - DerivErrDataConsNotAllInScope{} -> noHints - DerivErrGNDUsedOnData -> noHints - DerivErrNullaryClasses -> noHints - DerivErrLastArgMustBeApp -> noHints - DerivErrNoFamilyInstance{} -> noHints - DerivErrNotStockDeriveable deriveAnyClassEnabled - | deriveAnyClassEnabled == NoDeriveAnyClassEnabled - -> [suggestExtension LangExt.DeriveAnyClass] - | otherwise - -> noHints - DerivErrHasAssociatedDatatypes{} - -> noHints - DerivErrNewtypeNonDeriveableClass - | newtype_deriving == NoGeneralizedNewtypeDeriving - -> [useGND] - | otherwise - -> noHints - DerivErrCannotEtaReduceEnough{} - | newtype_deriving == NoGeneralizedNewtypeDeriving - -> [useGND] - | otherwise - -> noHints - DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled - | deriveAnyClassEnabled == NoDeriveAnyClassEnabled - -> [suggestExtension LangExt.DeriveAnyClass] - | otherwise - -> noHints - DerivErrNotDeriveable deriveAnyClassEnabled - | deriveAnyClassEnabled == NoDeriveAnyClassEnabled - -> [suggestExtension LangExt.DeriveAnyClass] - | otherwise - -> noHints - DerivErrNotAClass{} - -> noHints - DerivErrNoConstructors{} - -> let info = text "to enable deriving for empty data types" - in [useExtensionInOrderTo info LangExt.EmptyDataDeriving] - DerivErrLangExtRequired{} - -- This is a slightly weird corner case of GHC: we are failing - -- to derive a typeclass instance because a particular 'Extension' - -- is not enabled (and so we report in the main error), but here - -- we don't want to /repeat/ to enable the extension in the hint. - -> noHints - DerivErrDunnoHowToDeriveForType{} - -> noHints - DerivErrMustBeEnumType rep_tc - -- We want to suggest GND only if this /is/ a newtype. - | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc - -> [useGND] - | otherwise - -> noHints - DerivErrMustHaveExactlyOneConstructor{} - -> noHints - DerivErrMustHaveSomeParameters{} - -> noHints - DerivErrMustNotHaveClassContext{} - -> noHints - DerivErrBadConstructor wcard _ - -> case wcard of - Nothing -> noHints - Just YesHasWildcard -> [SuggestFillInWildcardConstraint] - Just NoHasWildcard -> [SuggestAddStandaloneDerivation] - DerivErrGenerics{} - -> noHints - DerivErrEnumOrProduct{} - -> noHints - -messageWithInfoDiagnosticMessage :: UnitState - -> ErrInfo - -> Bool - -> DecoratedSDoc - -> DecoratedSDoc -messageWithInfoDiagnosticMessage unit_state ErrInfo{..} show_ctxt important = - let err_info' = map (pprWithUnitState unit_state) ([errInfoContext | show_ctxt] ++ [errInfoSupplementary]) - in (mapDecoratedSDoc (pprWithUnitState unit_state) important) `unionDecoratedSDoc` - mkDecorated err_info' - -messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc -messageWithHsDocContext opts ctxt main_msg = do - if tcOptsShowContext opts - then main_msg `unionDecoratedSDoc` ctxt_msg - else main_msg - where - ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) - -dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc -dodgy_msg kind tc ie - = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that" - , quotes (ppr $ greName tc) <+> text "has" <+> sep rest ] - where - rest :: [SDoc] - rest = - case greInfo tc of - IAmTyCon ClassFlavour - -> [ text "(in-scope) class methods or associated types" <> comma - , text "but it has none" ] - IAmTyCon _ - -> [ text "(in-scope) constructors or record fields" <> comma - , text "but it has none" ] - _ -> [ text "children" <> comma - , text "but it is not a type constructor or a class" ] - -dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn -dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii - where - ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre) - -pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc -pprTypeDoesNotHaveFixedRuntimeRep ty prov = - let what = pprFixedRuntimeRepProvenance prov - in text "The" <+> what <+> text "does not have a fixed runtime representation:" - $$ format_frr_err ty - -format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation - -> SDoc -format_frr_err ty - = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki) - where - (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty - tidy_ki = tidyType tidy_env (typeKind ty) - -pprField :: (FieldLabelString, TcType) -> SDoc -pprField (f,ty) = ppr f <+> dcolon <+> ppr ty - -pprRecordFieldPart :: RecordFieldPart -> SDoc -pprRecordFieldPart = \case - RecordFieldDecl {} -> text "declaration" - RecordFieldConstructor{} -> text "construction" - RecordFieldPattern{} -> text "pattern" - RecordFieldUpdate -> text "update" - -ppr_opfix :: (OpName, Fixity) -> SDoc -ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) - where - pp_op | NegateOp <- op = text "prefix `-'" - | otherwise = quotes (ppr op) - -pprBindings :: [Name] -> SDoc -pprBindings = pprWithCommas (quotes . ppr) - - -injectivityErrorHerald :: SDoc -injectivityErrorHerald = - text "Type family equation violates the family's injectivity annotation." - -formatExportItemError :: SDoc -> String -> SDoc -formatExportItemError exportedThing reason = - hsep [ text "The export item" - , quotes exportedThing - , text reason ] - --- | What warning flags are associated with the given missing signature? -missingSignatureWarningFlags :: MissingSignature -> Exported -> NonEmpty WarningFlag -missingSignatureWarningFlags (MissingTopLevelBindingSig {}) exported - -- We prefer "bigger" warnings first: #14794 - -- - -- See Note [Warnings controlled by multiple flags] - = Opt_WarnMissingSignatures :| - [ Opt_WarnMissingExportedSignatures | IsExported == exported ] -missingSignatureWarningFlags (MissingPatSynSig {}) exported - = Opt_WarnMissingPatternSynonymSignatures :| - [ Opt_WarnMissingExportedPatternSynonymSignatures | IsExported == exported ] -missingSignatureWarningFlags (MissingTyConKindSig ty_con _) _ - = Opt_WarnMissingKindSignatures :| [Opt_WarnMissingPolyKindSignatures | isForAllTy_invis_ty (tyConKind ty_con) ] - -useDerivingStrategies :: GhcHint -useDerivingStrategies = - useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies - -useGND :: GhcHint -useGND = let info = text "for GHC's" <+> text "newtype-deriving extension" - in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving - -cannotMakeDerivedInstanceHerald :: Class - -> [Type] - -> Maybe (DerivStrategy GhcTc) - -> UsingGeneralizedNewtypeDeriving - -> Bool -- ^ If False, only prints the why. - -> SDoc - -> SDoc -cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why = - if pprHerald - then sep [(hang (text "Can't make a derived instance of") - 2 (quotes (ppr pred) <+> via_mechanism) - $$ nest 2 extra) <> colon, - nest 2 why] - else why - where - strat_used = isJust mb_strat - extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving) - = text "(even with cunning GeneralizedNewtypeDeriving)" - | otherwise = empty - pred = mkClassPred cls cls_args - via_mechanism | strat_used - , Just strat <- mb_strat - = text "with the" <+> (derivStrategyName strat) <+> text "strategy" - | otherwise - = empty - -badCon :: DataCon -> SDoc -> SDoc -badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg - -derivErrDiagnosticMessage :: Class - -> [Type] - -> Maybe (DerivStrategy GhcTc) - -> UsingGeneralizedNewtypeDeriving - -> Bool -- If True, includes the herald \"can't make a derived..\" - -> DeriveInstanceErrReason - -> SDoc -derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case - DerivErrNotWellKinded tc cls_kind _ - -> sep [ hang (text "Cannot derive well-kinded instance of form" - <+> quotes (pprClassPred cls cls_tys - <+> parens (ppr tc <+> text "..."))) - 2 empty - , nest 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind)) - ] - DerivErrSafeHaskellGenericInst - -> text "Generic instances can only be derived in" - <+> text "Safe Haskell using the stock strategy." - DerivErrDerivingViaWrongKind cls_kind via_ty via_kind - -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) - 2 (text "Class" <+> quotes (ppr cls) - <+> text "expects an argument of kind" - <+> quotes (pprKind cls_kind) <> char ',' - $+$ text "but" <+> quotes (pprType via_ty) - <+> text "has kind" <+> quotes (pprKind via_kind)) - DerivErrNoEtaReduce inst_ty - -> sep [text "Cannot eta-reduce to an instance of form", - nest 2 (text "instance (...) =>" - <+> pprClassPred cls (cls_tys ++ [inst_ty]))] - DerivErrBootFileFound - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Cannot derive instances in hs-boot files" - $+$ text "Write an instance declaration instead") - DerivErrDataConsNotAllInScope tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") - 2 (text "so you cannot derive an instance for it")) - DerivErrGNDUsedOnData - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes") - DerivErrNullaryClasses - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Cannot derive instances for nullary classes") - DerivErrLastArgMustBeApp - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - ( text "The last argument of the instance must be a" - <+> text "data or newtype application") - DerivErrNoFamilyInstance tc tc_args - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "No family instance for" <+> quotes (pprTypeApp tc tc_args)) - DerivErrNotStockDeriveable _ - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)") - DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg - , case at_without_last_cls_tv of - YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc - NoAssociatedTyNotParamOverLastTyVar -> empty - , case at_last_cls_tv_in_kinds of - YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc - NoAssocTyLastVarInKind -> empty - ] - where - - adfs_msg = text "the class has associated data types" - - at_without_last_cls_tv_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "is not parameterized over the last type variable") - 2 (text "of the class" <+> quotes (ppr cls)) - - at_last_cls_tv_in_kinds_msg at_tc = hang - (text "the associated type" <+> quotes (ppr at_tc) - <+> text "contains the last type variable") - 2 (text "of the class" <+> quotes (ppr cls) - <+> text "in a kind, which is not (yet) allowed") - DerivErrNewtypeNonDeriveableClass - -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled) - DerivErrCannotEtaReduceEnough eta_ok - -> let cant_derive_err = ppUnless eta_ok eta_msg - eta_msg = text "cannot eta-reduce the representation type enough" - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - cant_derive_err - DerivErrOnlyAnyClassDeriveable tc _ - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (ppr tc) <+> text "is a type class," - <+> text "and can only have a derived instance" - $+$ text "if DeriveAnyClass is enabled") - DerivErrNotDeriveable _ - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty - DerivErrNotAClass predType - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (ppr predType) <+> text "is not a class") - DerivErrNoConstructors rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor") - DerivErrLangExtRequired ext - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "You need " <> ppr ext - <+> text "to derive an instance for this class") - DerivErrDunnoHowToDeriveForType ty - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (hang (text "Don't know how to derive" <+> quotes (ppr cls)) - 2 (text "for type" <+> quotes (ppr ty))) - DerivErrMustBeEnumType rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (sep [ quotes (pprSourceTyCon rep_tc) <+> - text "must be an enumeration type" - , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]) - - DerivErrMustHaveExactlyOneConstructor rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor") - DerivErrMustHaveSomeParameters rep_tc - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters") - DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta - -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (text "Data type" <+> quotes (ppr rep_tc) - <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) - DerivErrBadConstructor _ reasons - -> let why = vcat $ map renderReason reasons - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why - where - renderReason = \case - DerivErrBadConExistential con - -> badCon con $ text "must be truly polymorphic in the last argument of the data type" - DerivErrBadConCovariant con - -> badCon con $ text "must not use the type variable in a function argument" - DerivErrBadConFunTypes con - -> badCon con $ text "must not contain function types" - DerivErrBadConWrongArg con - -> badCon con $ text "must use the type variable only as the last argument of a data type" - DerivErrBadConIsGADT con - -> badCon con $ text "is a GADT" - DerivErrBadConHasExistentials con - -> badCon con $ text "has existential type variables in its type" - DerivErrBadConHasConstraints con - -> badCon con $ text "has constraints in its type" - DerivErrBadConHasHigherRankType con - -> badCon con $ text "has a higher-rank type" - DerivErrGenerics reasons - -> let why = vcat $ map renderReason reasons - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why - where - renderReason = \case - DerivErrGenericsMustNotHaveDatatypeContext tc_name - -> ppr tc_name <+> text "must not have a datatype context" - DerivErrGenericsMustNotHaveExoticArgs dc - -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments" - DerivErrGenericsMustBeVanillaDataCon dc - -> ppr dc <+> text "must be a vanilla data constructor" - DerivErrGenericsMustHaveSomeTypeParams rep_tc - -> text "Data type" <+> quotes (ppr rep_tc) - <+> text "must have some type parameters" - DerivErrGenericsMustNotHaveExistentials con - -> badCon con $ text "must not have existential arguments" - DerivErrGenericsWrongArgKind con - -> badCon con $ - text "applies a type to an argument involving the last parameter" - $$ text "but the applied type is not of kind * -> *" - DerivErrEnumOrProduct this that - -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this - ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that - in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald - (ppr1 $$ text " or" $$ ppr2) - -lookupInstanceErrDiagnosticMessage :: Class - -> [Type] - -> LookupInstanceErrReason - -> SDoc -lookupInstanceErrDiagnosticMessage cls tys = \case - LookupInstErrNotExact - -> text "Not an exact match (i.e., some variables get instantiated)" - LookupInstErrFlexiVar - -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys) - LookupInstErrNotFound - -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys) - -{- ********************************************************************* -* * - Outputable SolverReportErrCtxt (for debugging) -* * -**********************************************************************-} - -instance Outputable SolverReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_expand_syns = es - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_expand_syns" <+> equals <+> ppr es - , text "cec_suppress" <+> equals <+> ppr sup ]) - -{- ********************************************************************* -* * - Outputting TcSolverReportMsg errors -* * -**********************************************************************-} - --- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg' --- with its enclosing 'SolverReportErrCtxt'. -pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc -pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg }) - = pprTcSolverReportMsg ctxt msg - --- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. -pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc -pprTcSolverReportMsg _ (BadTelescope telescope skols) = - hang (text "These kind and type variables:" <+> ppr telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - where - sorted_tvs = scopedSort skols -pprTcSolverReportMsg _ (UserTypeError ty) = - pprUserTypeErrorTy ty -pprTcSolverReportMsg _ (UnsatisfiableError ty) = - pprUserTypeErrorTy ty -pprTcSolverReportMsg ctxt (ReportHoleError hole err) = - pprHoleError ctxt hole err -pprTcSolverReportMsg ctxt - (CannotUnifyVariable - { mismatchMsg = msg - , cannotUnifyReason = reason }) - = pprMismatchMsg ctxt msg - $$ pprCannotUnifyVariableReason ctxt reason -pprTcSolverReportMsg ctxt - (Mismatch - { mismatchMsg = mismatch_msg - , mismatchTyVarInfo = tv_info - , mismatchAmbiguityInfo = ambig_infos - , mismatchCoercibleInfo = coercible_info }) - = vcat ([ pprMismatchMsg ctxt mismatch_msg - , maybe empty (pprTyVarInfo ctxt) tv_info - , maybe empty pprCoercibleMsg coercible_info ] - ++ (map pprAmbiguityInfo ambig_infos)) -pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = - vcat (map make_msg frr_origs) - where - -- Assemble the error message: pair up each origin with the corresponding type, e.g. - -- • FixedRuntimeRep origin msg 1 ... - -- a :: TYPE r1 - -- • FixedRuntimeRep origin msg 2 ... - -- b :: TYPE r2 - make_msg :: FixedRuntimeRepErrorInfo -> SDoc - make_msg (FRR_Info { frr_info_origin = - FixedRuntimeRepOrigin - { frr_type = ty - , frr_context = frr_ctxt } - , frr_info_not_concrete = - mb_not_conc }) = - -- Add bullet points if there is more than one error. - (if length frr_origs > 1 then (bullet <+>) else id) $ - vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt - , text "does not have a fixed runtime representation." ] - , type_printout ty - , case mb_not_conc of - Nothing -> empty - Just (conc_tv, not_conc) -> - unsolved_concrete_eq_explanation conc_tv not_conc ] - - -- Don't print out the type (only the kind), if the type includes - -- a confusing cast, unless the user passed -fprint-explicit-coercions. - -- - -- Example: - -- - -- In T20363, we have a representation-polymorphism error with a type - -- of the form - -- - -- ( (# #) |> co ) :: TYPE NilRep - -- - -- where NilRep is a nullary type family application which reduces to TupleRep '[]. - -- We prefer avoiding showing the cast to the user, but we also don't want to - -- print the confusing: - -- - -- (# #) :: TYPE NilRep - -- - -- So in this case we simply don't print the type, only the kind. - confusing_cast :: Type -> Bool - confusing_cast ty = - case ty of - CastTy inner_ty _ - -- A confusing cast is one that is responsible - -- for a representation-polymorphism error. - -> isConcreteType (typeKind inner_ty) - _ -> False - - type_printout :: Type -> SDoc - type_printout ty = - sdocOption sdocPrintExplicitCoercions $ \ show_coercions -> - if confusing_cast ty && not show_coercions - then vcat [ text "Its kind is:" - , nest 2 $ pprWithTYPE (typeKind ty) - , text "(Use -fprint-explicit-coercions to see the full type.)" ] - else vcat [ text "Its type is:" - , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] - - unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc - unsolved_concrete_eq_explanation tv not_conc = - text "Cannot unify" <+> quotes (ppr not_conc) - <+> text "with the type variable" <+> quotes (ppr tv) - $$ text "because it is not a concrete" <+> what <> dot - where - ki = tyVarKind tv - what :: SDoc - what - | isRuntimeRepTy ki - = quotes (text "RuntimeRep") - | isLevityTy ki - = quotes (text "Levity") - | otherwise - = text "type" -pprTcSolverReportMsg _ (BlockedEquality item) = - vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (errorItemPred item)) - , text "Doing so would be ill-kinded." ] -pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = - text "Expecting" <+> speakN (abs n) <+> - more <+> quotes (ppr thing) - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 -pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = - let givens = getUserGivens ctxt - in if null givens - then addArising (errorItemCtLoc item) $ - sep [ text "Unbound implicit parameter" <> plural preds - , nest 2 (pprParendTheta preds) ] - else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) - where - preds = map errorItemPred (item : items) -pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) = - pprAmbiguityInfo (Ambiguity True ambigs) <+> - pprArising (errorItemCtLoc item) $$ - text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) - <+> text "from being solved." -pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) - (CannotResolveInstance item unifiers candidates imp_errs suggs binds) - = - vcat - [ no_inst_msg - , nest 2 extra_note - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig $ - pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs)) - , pprRelevantBindings binds - , potential_msg ]) - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambigs pred implics - ++ drv_fixes ++ naked_sc_fixes) - , ppWhen (not (null candidates)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidates))) - -- See Note [Report candidate instances] - , vcat $ map ppr imp_errs - , vcat $ map ppr suggs ] - where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors - (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred - ambigs = ambig_kvs ++ ambig_tvs - has_ambigs = not (null ambigs) - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens - lead_with_ambig = not (null ambigs) - && not (any isRuntimeUnkSkol ambigs) - && not (null unifiers) - && null useful_givens - - no_inst_msg :: SDoc - no_inst_msg - | lead_with_ambig - = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) - | otherwise - = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - potential_hdr $$ - potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) - - potential_hdr - = ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") - - -- naked_sc_fix: try to produce a helpful error message for - -- superclass constraints caught by the subtleties described by - -- Note [Recursive superclasses] in GHC.TyCl.Instance - naked_sc_fixes - | ScOrigin _ NakedSc <- orig -- A superclass wanted with no instance decls used yet - , any non_tyvar_preds useful_givens -- Some non-tyvar givens - = [vcat [ text "If the constraint looks soluble from a superclass of the instance context," - , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]] - | otherwise = [] - - non_tyvar_preds :: UserGiven -> Bool - non_tyvar_preds = any non_tyvar_pred . ic_given - - non_tyvar_pred :: EvVar -> Bool - -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars - non_tyvar_pred given = case getClassPredTys_maybe (idType given) of - Just (_, tys) -> not (all isTyVarTy tys) - Nothing -> False - -pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = - vcat - [ addArising ct_loc $ - (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - , potentialInstancesErrMsg - (PotentialInstances { matches = NE.toList matches, unifiers }) - , ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (null $ NE.tail matches) $ - parens (vcat [ ppUnless (null tyCoVars) $ - text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr tyCoVars) - , ppUnless (null famTyCons) $ - if (null tyCoVars) - then - text "The choice depends on the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - else - text "and the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - where - ct_loc = errorItemCtLoc item - orig = ctLocOrigin ct_loc - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - tyCoVars = tyCoVarsOfTypesList tys - famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - matching_givens = mapMaybe matchable useful_givens - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (getCtLocEnvLoc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False -pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) = - vcat [ addArising ct_loc (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance match)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped]) - ] - ] - where - ct_loc = errorItemCtLoc item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - -pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc -pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) = - vcat [ (if isSkolemTyVar tv1 - then text "Cannot equate type variable" - else text "Cannot instantiate unification variable") - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) - , maybe empty (pprTyVarInfo ctxt) mb_tv_info ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel - -pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) = - let - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - in - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr (ic_info implic) - , nest 2 $ text "at" <+> - ppr (getCtLocEnvLoc (ic_env implic)) ] ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel - -pprCannotUnifyVariableReason ctxt - (OccursCheck - { occursCheckInterestingTyVars = interesting_tvs - , occursCheckAmbiguityInfos = ambig_infos }) - = ppr_interesting_tyVars interesting_tvs - $$ vcat (map pprAmbiguityInfo ambig_infos) - where - ppr_interesting_tyVars [] = empty - ppr_interesting_tyVars (tv:tvs) = - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - (tv:tvs)) - tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) -pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info) - = pprTyVarInfo ctxt tv_info -pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg) - = pprTyVarInfo ctxt tv_info - $$ maybe empty pprCoercibleMsg mb_coercible_msg - -pprUntouchableVariable :: TcTyVar -> Implication -> SDoc -pprUntouchableVariable tv (Implic { ic_given = given, ic_info = skol_info, ic_env = env }) - = sep [ quotes (ppr tv) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> ppr (getCtLocEnvLoc env) ] - -pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc -pprMismatchMsg ctxt - (BasicMismatch { mismatch_ea = ea - , mismatch_item = item - , mismatch_ty1 = ty1 -- Expected - , mismatch_ty2 = ty2 -- Actual - , mismatch_whenMatching = mb_match_txt - , mismatch_mb_same_occ = same_occ_info }) - = vcat [ addArising (errorItemCtLoc item) msg - , ea_extra - , maybe empty (pprWhenMatching ctxt) mb_match_txt - , maybe empty pprSameOccInfo same_occ_info ] - where - msg - | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || - (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || - (isLiftedLevity ty1 && isUnliftedLevity ty2) || - (isLiftedLevity ty2 && isUnliftedLevity ty1) - = text "Couldn't match a lifted type with an unlifted type" - - | isAtomicTy ty1 || isAtomicTy ty2 - = -- Print with quotes - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) ] - - | otherwise - = -- Print with vertical layout - vcat [ text herald1 <> colon <+> ppr ty1 - , nest padding $ - text herald2 <> colon <+> ppr ty2 ] - - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if want_ea then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if want_ea then ("actual " ++ what) else "" ] - - padding = length herald1 - length herald2 - - (want_ea, ea_extra) - = case ea of - NoEA -> (False, empty) - EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra) - is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } - - what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) -pprMismatchMsg _ - (KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act }) - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> - quotes (ppr act)) - where - kind_desc | isConstraintLikeKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - -pprMismatchMsg ctxt - (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 -- These types are the actual types - , teq_mismatch_ty2 = ty2 -- that don't match; may be swapped - , teq_mismatch_expected = exp -- These are the context of - , teq_mismatch_actual = act -- the mis-match - , teq_mismatch_what = mb_thing - , teq_mb_same_occ = mb_same_occ }) - = addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg - $$ maybe empty pprSameOccInfo mb_same_occ - where - msg | Just (torc, rep) <- sORTKind_maybe exp - = msg_for_exp_sort torc rep - - | Just nargs_msg <- num_args_msg - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = nargs_msg $$ pprMismatchMsg ctxt ea_msg - - | ea_looks_same ty1 ty2 exp act - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = pprMismatchMsg ctxt ea_msg - - | otherwise - = bale_out_msg - - -- bale_out_msg: the mismatched types are /inside/ exp and act - bale_out_msg = vcat errs - where - errs = case mk_ea_msg ctxt Nothing level orig of - Left ea_info -> pprMismatchMsg ctxt mismatch_err - : map (pprExpectedActualInfo ctxt) ea_info - Right ea_err -> [ pprMismatchMsg ctxt mismatch_err - , pprMismatchMsg ctxt ea_err ] - mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 - - -- 'expected' is (TYPE rep) or (CONSTRAINT rep) - msg_for_exp_sort exp_torc exp_rep - | Just (act_torc, act_rep) <- sORTKind_maybe act - = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc - msg_torc_torc act_torc act_rep - | otherwise - = -- (TYPE _) ~ Bool, etc - maybe_num_args_msg $$ - sep [ text "Expected a" <+> ppr_torc exp_torc <> comma - , text "but" <+> case mb_thing of - Nothing -> text "found something with kind" - Just thing -> quotes (ppr thing) <+> text "has kind" - , quotes (pprWithTYPE act) ] - - where - msg_torc_torc act_torc act_rep - | exp_torc == act_torc - = msg_same_torc act_torc act_rep - | otherwise - = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma - , text "but" <+> case mb_thing of - Nothing -> text "found a" - Just thing -> quotes (ppr thing) <+> text "is a" - <+> ppr_torc act_torc ] - - msg_same_torc act_torc act_rep - | Just exp_doc <- describe_rep exp_rep - , Just act_doc <- describe_rep act_rep - = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma - , text "but" <+> case mb_thing of - Just thing -> quotes (ppr thing) <+> text "is" - Nothing -> text "got" - <+> act_doc <+> ppr_torc act_torc ] - msg_same_torc _ _ = bale_out_msg - - ct_loc = errorItemCtLoc item - orig = errorItemOrigin item - level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- mb_thing - -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = num_args_msg `orElse` empty - - count_args ty = count isVisiblePiTyBinder $ fst $ splitPiTys ty - - ppr_torc TypeLike = text "type"; - ppr_torc ConstraintLike = text "constraint" - - describe_rep :: RuntimeRepType -> Maybe SDoc - -- describe_rep IntRep = Just "an IntRep" - -- describe_rep (BoxedRep Lifted) = Just "a lifted" - -- etc - describe_rep rep - | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep - = case rr_args of - [lev_ty] | rr_tc `hasKey` boxedRepDataConKey - , Just lev <- levityType_maybe lev_ty - -> case lev of - Lifted -> Just (text "a lifted") - Unlifted -> Just (text "a boxed unlifted") - [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit") - | starts_with_vowel rr_occ -> Just (text "an" <+> text rr_occ) - | otherwise -> Just (text "a" <+> text rr_occ) - where - rr_occ = occNameString (getOccName rr_tc) - - _ -> Nothing -- Must be TupleRep [r1..rn] - | otherwise = Nothing - - starts_with_vowel (c:_) = c `elem` "AEIOU" - starts_with_vowel [] = False - -pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) - = main_msg $$ - case supplementary of - Left infos - -> vcat (map (pprExpectedActualInfo ctxt) infos) - Right other_msg - -> pprMismatchMsg ctxt other_msg - where - main_msg - | null useful_givens - = addArising ct_loc (no_instance_msg <+> missing) - | otherwise - = vcat (addArising ct_loc (no_deduce_msg <+> missing) - : pp_givens useful_givens) - - supplementary = case mb_extra of - Nothing - -> Left [] - Just (CND_Extra level ty1 ty2) - -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig - ct_loc = errorItemCtLoc item - orig = ctLocOrigin ct_loc - wanteds = map errorItemPred (item:others) - - no_instance_msg = - case wanteds of - [wanted] | Just (tc, _) <- splitTyConApp_maybe wanted - -- Don't say "no instance" for a constraint such as "c" for a type variable c. - , isClassTyCon tc -> text "No instance for" - _ -> text "Could not solve:" - - no_deduce_msg = - case wanteds of - [_wanted] -> text "Could not deduce" - _ -> text "Could not deduce:" - - missing = - case wanteds of - [wanted] -> quotes (ppr wanted) - _ -> pprTheta wanteds - - - -{- ********************************************************************* -* * - Displaying potential instances -* * -**********************************************************************-} - --- | Directly display the given matching and unifying instances, --- with a header for each: `Matching instances`/`Potentially matching instances`. -pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc -pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = - vcat - [ ppWhen (not $ null matches) $ - text "Matching instance" <> plural matches <> colon $$ - nest 2 (vcat (map ppr_inst matches)) - , ppWhen (not $ null unifiers) $ - (text "Potentially matching instance" <> plural unifiers <> colon) $$ - nest 2 (vcat (map ppr_inst unifiers)) - ] - --- | Display a summary of available instances, omitting those involving --- out-of-scope types, in order to explain why we couldn't solve a particular --- constraint, e.g. due to instance overlap or out-of-scope types. --- --- To directly display a collection of matching/unifying instances, --- use 'pprPotentialInstances'. -potentialInstancesErrMsg :: PotentialInstances -> SDoc --- See Note [Displaying potential instances] -potentialInstancesErrMsg potentials = - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - potentials_msg_with_options potentials print_insts sty - --- | Display a summary of available instances, omitting out-of-scope ones. --- --- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing --- options. -potentials_msg_with_options :: PotentialInstances - -> Bool -- ^ Whether to print /all/ potential instances - -> PprStyle - -> SDoc -potentials_msg_with_options - (PotentialInstances { matches, unifiers }) - show_all_potentials sty - | null matches && null unifiers - = empty - - | null show_these_matches && null show_these_unifiers - = vcat [ not_in_scope_msg empty - , flag_hint ] - - | otherwise - = vcat [ pprPotentialInstances - pprInstance -- print instance + location info - (PotentialInstances - { matches = show_these_matches - , unifiers = show_these_unifiers }) - , overlapping_but_not_more_specific_msg sorted_matches - , nest 2 $ vcat - [ ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , ppWhen (not_in_scopes > 0) $ - not_in_scope_msg (text "...plus") - , flag_hint ] ] - where - n_show_matches, n_show_unifiers :: Int - n_show_matches = 3 - n_show_unifiers = 2 - - (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches - (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers - sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches - sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers - (show_these_matches, show_these_unifiers) - | show_all_potentials = (sorted_matches, sorted_unifiers) - | otherwise = (take n_show_matches sorted_matches - ,take n_show_unifiers sorted_unifiers) - n_in_scope_hidden - = length sorted_matches + length sorted_unifiers - - length show_these_matches - length show_these_unifiers - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | pretendNameIsInScope name - = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scopes :: Int - not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers - - not_in_scope_msg herald = - hang (herald <+> speakNOf not_in_scopes (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_all_potentials $ - pprPotentialInstances - pprInstanceHdr -- only print the header, not the instance location info - (PotentialInstances - { matches = not_in_scope_matches - , unifiers = not_in_scope_unifiers - })) - - flag_hint = ppUnless (show_all_potentials - || (equalLength show_these_matches matches - && equalLength show_these_unifiers unifiers)) $ - text "(use -fprint-potential-instances to see them all)" - --- | Compute a message informing the user of any instances that are overlapped --- but were not discarded because the instance overlapping them wasn't --- strictly more specific. -overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc -overlapping_but_not_more_specific_msg insts - -- Only print one example of "overlapping but not strictly more specific", - -- to avoid information overload. - | overlap : _ <- overlapping_but_not_more_specific - = overlap_header $$ ppr_overlapping overlap - | otherwise - = empty - where - overlap_header :: SDoc - overlap_header - | [_] <- overlapping_but_not_more_specific - = text "An overlapping instance can only be chosen when it is strictly more specific." - | otherwise - = text "Overlapping instances can only be chosen when they are strictly more specific." - overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] - overlapping_but_not_more_specific - = nubOrdBy (comparing (is_dfun . fst)) - [ (overlapper, overlappee) - | these <- groupBy ((==) `on` is_cls_nm) insts - -- Take all pairs of distinct instances... - , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` - , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` - -- ... such that one instance in the pair overlaps the other... - , let mb_overlapping - | hasOverlappingFlag (overlapMode $ is_flag one) - || hasOverlappableFlag (overlapMode $ is_flag other) - = [(one, other)] - | hasOverlappingFlag (overlapMode $ is_flag other) - || hasOverlappableFlag (overlapMode $ is_flag one) - = [(other, one)] - | otherwise - = [] - , (overlapper, overlappee) <- mb_overlapping - -- ... but the overlapper is not more specific than the overlappee. - , not (overlapper `more_specific_than` overlappee) - ] - more_specific_than :: ClsInst -> ClsInst -> Bool - is1 `more_specific_than` is2 - = isJust (tcMatchTys (is_tys is1) (is_tys is2)) - ppr_overlapping :: (ClsInst, ClsInst) -> SDoc - ppr_overlapping (overlapper, overlappee) - = text "The first instance that follows overlaps the second, but is not more specific than it:" - $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus N others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - -{- ********************************************************************* -* * - Outputting additional solver report information -* * -**********************************************************************-} - --- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. -pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc -pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = - vcat - [ text "Expected:" <+> ppr exp - , text " Actual:" <+> ppr act ] -pprExpectedActualInfo _ - (ExpectedActualAfterTySynExpansion - { ea_expanded_expected = exp - , ea_expanded_actual = act } ) - = vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr exp - , text " Actual type:" <+> ppr act ] - -pprCoercibleMsg :: CoercibleMsg -> SDoc -pprCoercibleMsg (UnknownRoles ty) = - hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr ty) <+> text "have;") - 2 (text "we must assume that the role is nominal") -pprCoercibleMsg (TyConIsAbstract tc) = - hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] -pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = - hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) - -pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc -pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = - sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - if printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - then vcat [ hang (text "When matching" <+> sub_whats) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (typeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (typeKind cty2) ]) - , supplementary ] - else text "When matching the kind of" <+> quotes (ppr cty1) - where - sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel - sub_whats = text (levelString sub_t_or_k) <> char 's' - supplementary = - case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of - Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos - Right msg -> pprMismatchMsg ctxt msg - -pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc -pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic }) - = vcat [ mk_msg tv1 - , maybe empty (pprUntouchableVariable tv1) mb_implic - , case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 } ] - where - mk_msg tv = case tcTyVarDetails tv of - SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -pprAmbiguityInfo :: AmbiguityInfo -> SDoc -pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg - where - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" -pprAmbiguityInfo (NonInjectiveTyFam tc) = - text "NB:" <+> quotes (ppr tc) - <+> text "is a non-injective type family" - -pprSameOccInfo :: SameOccInfo -> SDoc -pprSameOccInfo (SameOcc same_pkg n1 n2) = - text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnit) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnit mod - mod = nameModule nm - loc = nameSrcSpan nm - -{- ********************************************************************* -* * - Outputting HoleError messages -* * -**********************************************************************-} - -pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc -pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs) - = out_of_scope_msg $$ vcat (map ppr imp_errs) - where - herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr rdr) - | otherwise = hang herald 2 (pp_rdr_with_type rdr hole_ty) - boring_type = isTyVarTy hole_ty -pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) = - vcat [ hole_msg - , tyvars_msg - , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] - - where - - hole_msg = case sort of - ExprHole {} -> - hang (text "Found hole:") - 2 (pp_rdr_with_type hole_occ hole_ty) - TypeHole -> - hang (text "Found type wildcard" <+> quotes (ppr hole_occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - ConstraintHole -> - hang (text "Found extra-constraints wildcard standing for") - 2 (quotes $ pprType hole_ty) -- always kind Constraint - - hole_kind = typeKind hole_ty - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars = tyCoVarsOfTypeList hole_ty - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt hole_skol_info) - -- Coercion variables can be free in the - -- hole, via kind casts - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS (rdrNameOcc hole_occ)) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr hole_occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - type_hole_hint - | ErrorWithoutFlag <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - -pp_rdr_with_type :: RdrName -> Type -> SDoc -pp_rdr_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - -{- ********************************************************************* -* * - Outputting ScopeError messages -* * -**********************************************************************-} - -pprScopeError :: RdrName -> NotInScopeError -> SDoc -pprScopeError rdr_name scope_err = - case scope_err of - NotInScope -> - hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - NotARecordField -> - hang (text "Not in scope:") - 2 (text "record field" <+> quotes (ppr rdr_name)) - NoExactName name -> - text "The Name" <+> quotes (ppr name) <+> text "is not in scope." - SameName gres -> - assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres)) - $ hang (text "Same Name in multiple name-spaces:") - 2 (vcat (map pp_one sorted_names)) - where - sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) - $ map greName gres - pp_one name - = hang (pprNameSpace (occNameSpace (getOccName name)) - <+> quotes (ppr name) <> comma) - 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - MissingBinding thing _ -> - sep [ text "The" <+> thing - <+> text "for" <+> quotes (ppr rdr_name) - , nest 2 $ text "lacks an accompanying binding" ] - NoTopLevelBinding -> - hang (text "No top-level binding for") - 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") - UnknownSubordinate doc -> - quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc - NotInScopeTc env -> - vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+> - text "is not in scope during type checking, but it passed the renamer", - text "tcl_env of environment:" <+> ppr env] - where - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - -scopeErrorHints :: NotInScopeError -> [GhcHint] -scopeErrorHints scope_err = - case scope_err of - NotInScope -> noHints - NotARecordField -> noHints - NoExactName {} -> [SuggestDumpSlices] - SameName {} -> [SuggestDumpSlices] - MissingBinding _ hints -> hints - NoTopLevelBinding -> noHints - UnknownSubordinate {} -> noHints - NotInScopeTc _ -> noHints - -{- ********************************************************************* -* * - Outputting ImportError messages -* * -**********************************************************************-} - -instance Outputable ImportError where - ppr (MissingModule mod_name) = - hsep - [ text "NB: no module named" - , quotes (ppr mod_name) - , text "is imported." - ] - ppr (ModulesDoNotExport mods occ_name) - | mod NE.:| [] <- mods - = hsep - [ text "NB: the module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot ] - | otherwise - = hsep - [ text "NB: neither" - , quotedListWithNor (map ppr $ NE.toList mods) - , text "export" - , quotes (ppr occ_name) <> dot ] - -{- ********************************************************************* -* * - Suggested fixes for implication constraints -* * -**********************************************************************-} - --- TODO: these functions should use GhcHint instead. - -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature - -pp_givens :: [Implication] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (getCtLocEnvLoc (ic_env implic)) ]) - -{- ********************************************************************* -* * - CtOrigin information -* * -**********************************************************************-} - -levelString :: TypeOrKind -> String -levelString TypeLevel = "type" -levelString KindLevel = "kind" - -pprArising :: CtLoc -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, givens -pprArising ct_loc - | in_generated_code = empty -- See Note ["Arising from" messages in generated code] - | suppress_origin = empty - | otherwise = pprCtOrigin orig - where - orig = ctLocOrigin ct_loc - in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc) - suppress_origin - | isGivenOrigin orig = True - | otherwise = case orig of - TypeEqOrigin {} -> True -- We've done special processing - KindEqOrigin {} -> True -- for TypeEq, KindEq, givens - AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context - -- is sufficient; more would be repetitive - _ -> False - --- Add the "arising from..." part to a message -addArising :: CtLoc -> SDoc -> SDoc -addArising ct_loc msg = hang msg 2 (pprArising ct_loc) - -pprWithArising :: [Ct] -> SDoc --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = addArising loc (pprTheta [ctPred ct]) - | otherwise - = vcat (map ppr_one (ct:cts)) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -{- Note ["Arising from" messages in generated code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider code generated when we desugar code before typechecking; -see Note [Rebindable syntax and HsExpansion]. - -In this code, constraints may be generated, but we don't want to -say "arising from a call of foo" if 'foo' doesn't appear in the -users code. We leave the actual CtOrigin untouched (partly because -it is generated in many, many places), but suppress the "Arising from" -message for constraints that originate in generated code. --} - - -{- ********************************************************************* -* * - SkolemInfo -* * -**********************************************************************-} - - -tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo -tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon) - ----------------- -tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon -tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) -tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs -tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) -tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) -tidySkolemInfoAnon _ info = info - -tidySigSkol :: TidyEnv -> UserTypeCtxt - -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon --- We need to take special care when tidying SigSkol --- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" -tidySigSkol env cx ty tv_prs - = SigSkol cx (tidy_ty env ty) tv_prs' - where - tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs - inst_env = mkNameEnv tv_prs' - - tidy_ty env (ForAllTy (Bndr tv vis) ty) - = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) - where - (env', tv') = tidy_tv_bndr env tv - - tidy_ty env ty@(FunTy af w arg res) -- Look under c => t - | isInvisibleFunArg af - = ty { ft_mult = tidy_ty env w - , ft_arg = tidyType env arg - , ft_res = tidy_ty env res } - - tidy_ty env ty = tidyType env ty - - tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) - tidy_tv_bndr env@(occ_env, subst) tv - | Just tv' <- lookupNameEnv inst_env (tyVarName tv) - = ((occ_env, extendVarEnv subst tv tv'), tv') - - | otherwise - = tidyVarBndr env tv - -pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc -pprSkols ctxt zonked_ty_vars - = - let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars - in vcat (map pp_one tidy_ty_vars) - where - - no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars - $$ text "This should not happen, please report it as a bug following the instructions at:" - $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" - - - pp_one (UnkSkol cs, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "(rigid, skolem)") - , nest 2 (text "of unknown origin") - , nest 2 (text "bound at" <+> ppr (skolsSpan tvs)) - , no_msg - , prettyCallStackDoc cs - ] - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - -skolsSpan :: [TcTyVar] -> SrcSpan -skolsSpan skol_tvs = foldr1 combineSrcSpans (map getSrcSpan skol_tvs) - -{- ********************************************************************* -* * - Utilities for expected/actual messages -* * -**********************************************************************-} - -mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg -mk_supplementary_ea_msg ctxt level ty1 ty2 orig - | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig - , not (ea_looks_same ty1 ty2 exp act) - = mk_ea_msg ctxt Nothing level orig - | otherwise - = Left [] - -ea_looks_same :: Type -> Type -> Type -> Type -> Bool --- True if the faulting types (ty1, ty2) look the same as --- the expected/actual types (exp, act). --- If so, we don't want to redundantly report the latter -ea_looks_same ty1 ty2 exp act - = (act `looks_same` ty1 && exp `looks_same` ty2) || - (exp `looks_same` ty1 && act `looks_same` ty2) - where - looks_same t1 t2 = t1 `pickyEqType` t2 - || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind - -- pickyEqType is sensitive to synonyms, so only replies True - -- when the types really look the same. However, - -- (TYPE 'LiftedRep) and Type both print the same way. - -mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind - -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg --- Constructs a "Couldn't match" message --- The (Maybe ErrorItem) says whether this is the main top-level message (Just) --- or a supplementary message (Nothing) -mk_ea_msg ctxt at_top level - (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) - | Just thing <- mb_thing - , KindLevel <- level - = Right $ KindMismatch { kmismatch_what = thing - , kmismatch_expected = exp - , kmismatch_actual = act } - | Just item <- at_top - , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing - mismatch = mkBasicMismatchMsg ea item exp act - = Right mismatch - | otherwise - = Left $ - if expanded_syns - then [ea,ea_expanded] - else [ea] - - where - ea = ExpectedActual { ea_expected = exp, ea_actual = act } - ea_expanded = - ExpectedActualAfterTySynExpansion - { ea_expanded_expected = expTy1 - , ea_expanded_actual = expTy2 } - - expanded_syns = cec_expand_syns ctxt - && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) - (expTy1, expTy2) = expandSynonymsToMatch exp act -mk_ea_msg _ _ _ _ = Left [] - -{- Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) --} - --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 - , tys1 `equalLength` tys2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. The lengths of tys1 and tys2 must be equal; - -- for example, with type S a = a, we don't want - -- to zip (S Monad Int) and (S Bool). - let (tys1', tys2') = - unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ..., Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t) - - -- Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext HsTypePatCtx = text "a type argument in a pattern" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names - -pprConversionFailReason :: ConversionFailReason -> SDoc -pprConversionFailReason = \case - IllegalOccName ctxt_ns occ -> - text "Illegal" <+> pprNameSpace ctxt_ns - <+> text "name:" <+> quotes (text occ) - SumAltArityExceeded alt arity -> - text "Sum alternative" <+> int alt - <+> text "exceeds its arity," <+> int arity - IllegalSumAlt alt -> - vcat [ text "Illegal sum alternative:" <+> int alt - , nest 2 $ text "Sum alternatives must start from 1" ] - IllegalSumArity arity -> - vcat [ text "Illegal sum arity:" <+> int arity - , nest 2 $ text "Sums must have an arity of at least 2" ] - MalformedType typeOrKind ty -> - text "Malformed " <> text ty_str <+> text (show ty) - where ty_str = case typeOrKind of - TypeLevel -> "type" - KindLevel -> "kind" - IllegalLastStatement do_or_lc stmt -> - vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon - , nest 2 $ ppr stmt - , text "(It should be an expression.)" ] - KindSigsOnlyAllowedOnGADTs -> - text "Kind signatures are only allowed on GADTs" - IllegalDeclaration declDescr bad_decls -> - sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon - , nest 2 bads ] - where - (what, bads) = case bad_decls of - IllegalDecls (NE.toList -> decls) -> - (text "declaration" <> plural decls, vcat $ map ppr decls) - IllegalFamDecls (NE.toList -> decls) -> - ( text "family declaration" <> plural decls, vcat $ map ppr decls) - descrDoc = text $ case declDescr of - InstanceDecl -> "an instance declaration" - WhereClause -> "a where clause" - LetBinding -> "a let expression" - LetExpression -> "a let expression" - ClssDecl -> "a class declaration" - CannotMixGADTConsWith98Cons -> - text "Cannot mix GADT constructors with Haskell 98" - <+> text "constructors" - EmptyStmtListInDoBlock -> - text "Empty stmt list in do-block" - NonVarInInfixExpr -> - text "Non-variable expression is not allowed in an infix expression" - MultiWayIfWithoutAlts -> - text "Multi-way if-expression with no alternatives" - CasesExprWithoutAlts -> - text "\\cases expression with no alternatives" - ImplicitParamsWithOtherBinds -> - text "Implicit parameters mixed with other bindings" - InvalidCCallImpent from -> - text (show from) <+> text "is not a valid ccall impent" - RecGadtNoCons -> - quotes (text "RecGadtC") <+> text "must have at least one constructor name" - GadtNoCons -> - quotes (text "GadtC") <+> text "must have at least one constructor name" - InvalidTypeInstanceHeader tys -> - text "Invalid type instance header:" - <+> text (show tys) - InvalidTyFamInstLHS lhs -> - text "Invalid type family instance LHS:" - <+> text (show lhs) - InvalidImplicitParamBinding -> - text "Implicit parameter binding only allowed in let or where" - DefaultDataInstDecl adts -> - (text "Default data instance declarations" - <+> text "are not allowed:") - $$ ppr adts - FunBindLacksEquations nm -> - text "Function binding for" - <+> quotes (text (TH.pprint nm)) - <+> text "has no equations" - -pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc -pprTyThingUsedWrong sort thing name = - pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> pprWrongThingSort sort - -pprWrongThingSort :: WrongThingSort -> SDoc -pprWrongThingSort = - text . \case - WrongThingType -> "type" - WrongThingDataCon -> "data constructor" - WrongThingPatSyn -> "pattern synonym" - WrongThingConLike -> "constructor-like thing" - WrongThingClass -> "class" - WrongThingTyCon -> "type constructor" - WrongThingAxiom -> "axiom" - -pprStageCheckReason :: StageCheckReason -> SDoc -pprStageCheckReason = \case - StageCheckInstance _ t -> - text "instance for" <+> quotes (ppr t) - StageCheckSplice t -> - quotes (ppr t) - -pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc -pprUninferrableTyVarCtx = \case - UninfTyCtx_ClassContext theta -> - sep [ text "the class context:", pprTheta theta ] - UninfTyCtx_DataContext theta -> - sep [ text "the datatype context:", pprTheta theta ] - UninfTyCtx_ProvidedContext theta -> - sep [ text "the provided context:" , pprTheta theta ] - UninfTyCtx_TyFamRhs rhs_ty -> - sep [ text "the type family equation right-hand side:" , ppr rhs_ty ] - UninfTyCtx_TySynRhs rhs_ty -> - sep [ text "the type synonym right-hand side:" , ppr rhs_ty ] - UninfTyCtx_Sig exp_kind full_hs_ty -> - hang (text "the kind" <+> ppr exp_kind) 2 - (text "of the type signature:" <+> ppr full_hs_ty) - -pprPatSynInvalidRhsReason :: PatSynInvalidRhsReason -> SDoc -pprPatSynInvalidRhsReason = \case - PatSynNotInvertible p -> - text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" - PatSynUnboundVar var -> - quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym" - -pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc -pprBadFieldAnnotationReason = \case - LazyFieldsDisabled -> - text "Lazy field annotations (~) are disabled" - UnpackWithoutStrictness -> - text "UNPACK pragma lacks '!'" - BackpackUnpackAbstractType -> - text "Ignoring unusable UNPACK pragma" - -pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc -pprSuperclassCycleDetail = \case - SCD_HeadTyVar pred -> - hang (text "one of whose superclass constraints is headed by a type variable:") - 2 (quotes (ppr pred)) - SCD_HeadTyFam pred -> - hang (text "one of whose superclass constraints is headed by a type family:") - 2 (quotes (ppr pred)) - SCD_Superclass cls -> - text "one of whose superclasses is" <+> quotes (ppr cls) - -pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc -pprRoleValidationFailedReason role = \case - TyVarRoleMismatch tv role' -> - text "type variable" <+> quotes (ppr tv) <+> - text "cannot have role" <+> ppr role <+> - text "because it was assigned role" <+> ppr role' - TyVarMissingInEnv tv -> - text "type variable" <+> quotes (ppr tv) <+> text "missing in environment" - BadCoercionRole co -> - text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role - -pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc -pprDisabledClassExtension cls = \case - MultiParamDisabled n -> - text howMany <+> text "parameters for class" <+> quotes (ppr cls) - where - howMany | n == 0 = "No" - | otherwise = "Too many" - FunDepsDisabled -> - text "Fundeps in class" <+> quotes (ppr cls) - ConstrainedClassMethodsDisabled sel_id pred -> - vcat [ hang (text "Constraint" <+> quotes (ppr pred) - <+> text "in the type of" <+> quotes (ppr sel_id)) - 2 (text "constrains only the class type variables")] - -pprImportLookup :: ImportLookupReason -> SDoc -pprImportLookup = \case - ImportLookupBad k iface decl_spec ie _ps -> - let - pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc - pprImpDeclSpec iface decl_spec = - quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of - IsBoot -> text "(hi-boot interface)" - NotBoot -> empty - withContext msgs = - hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon) - 2 (vcat msgs) - in case k of - BadImportNotExported _ -> - vcat - [ text "Module" <+> pprImpDeclSpec iface decl_spec <+> - text "does not export" <+> quotes (ppr ie) <> dot - ] - BadImportAvailVar -> - withContext - [ text "an item called" - <+> quotes val <+> text "is exported, but it is not a type." - ] - where - val_occ = rdrNameOcc $ ieName ie - val = parenSymOcc val_occ (ppr val_occ) - BadImportAvailTyCon {} -> - withContext - [ text "an item called" - <+> quotes tycon <+> text "is exported, but it is a type." - ] - where - tycon_occ = rdrNameOcc $ ieName ie - tycon = parenSymOcc tycon_occ (ppr tycon_occ) - BadImportNotExportedSubordinates ns -> - withContext - [ text "an item called" <+> quotes sub <+> text "is exported, but it does not export any children" - , text "(constructors, class methods or field names) called" - <+> pprWithCommas (quotes . ppr) ns <> dot - ] - where - sub_occ = rdrNameOcc $ ieName ie - sub = parenSymOcc sub_occ (ppr sub_occ) - BadImportAvailDataCon dataType_occ -> - withContext - [ text "an item called" <+> quotes datacon - , text "is exported, but it is a data constructor of" - , quotes dataType <> dot - ] - where - datacon_occ = rdrNameOcc $ ieName ie - datacon = parenSymOcc datacon_occ (ppr datacon_occ) - dataType = parenSymOcc dataType_occ (ppr dataType_occ) - ImportLookupQualified rdr -> - hang (text "Illegal qualified name in import item:") - 2 (ppr rdr) - ImportLookupIllegal -> - text "Illegal import item" - ImportLookupAmbiguous rdr gres -> - hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") - 2 (vcat (map (ppr . greOccName) gres)) - -pprUnusedImport :: ImportDecl GhcRn -> UnusedImportReason -> SDoc -pprUnusedImport decl = \case - UnusedImportNone -> - vcat [ pp_herald <+> quotes pp_mod <+> text "is redundant" - , nest 2 (text "except perhaps to import instances from" - <+> quotes pp_mod) - , text "To import instances alone, use:" - <+> text "import" <+> pp_mod <> parens empty ] - UnusedImportSome sort_unused -> - sep [ pp_herald <+> quotes (pprWithCommas pp_unused sort_unused) - , text "from module" <+> quotes pp_mod <+> text "is redundant"] - where - pp_mod = ppr (unLoc (ideclName decl)) - pp_herald = text "The" <+> pp_qual <+> text "import of" - pp_qual - | isImportDeclQualified (ideclQualified decl) = text "qualified" - | otherwise = empty - pp_unused = \case - UnusedImportNameRegular n -> - pprNameUnqualified n - UnusedImportNameRecField par fld_occ -> - case par of - ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ) - NoParent -> ppr fld_occ - -pprUnusedName :: OccName -> UnusedNameProv -> SDoc -pprUnusedName name reason = - sep [ msg <> colon - , nest 2 $ pprNonVarNameSpace (occNameSpace name) - <+> quotes (ppr name)] - where - msg = case reason of - UnusedNameTopDecl -> - defined - UnusedNameImported mod -> - text "Imported from" <+> quotes (ppr mod) <+> text "but not used" - UnusedNameTypePattern -> - defined <+> text "on the right hand side" - UnusedNameMatch -> - defined - UnusedNameLocalBind -> - defined - defined = text "Defined but not used" - --- When printing the name, take care to qualify it in the same --- way as the provenance reported by pprNameProvenance, namely --- the head of 'gre_imp'. Otherwise we get confusing reports like --- Ambiguous occurrence ‘null’ --- It could refer to either ‘T15487a.null’, --- imported from ‘Prelude’ at T15487.hs:1:8-13 --- or ... --- See #15487 -pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc -pprAmbiguousGreName gre_env gre - | IAmRecField fld_info <- greInfo gre - = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma - , pprNameProvenance gre ] - | otherwise - = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma - , pprNameProvenance gre ] - - where - occ = greOccName gre - parent_info fld_info = - case first_con of - PatSynName ps -> text "of pattern synonym" <+> quotes (ppr ps) - DataConName {} -> - case greParent gre of - ParentIs par - -- For a data family, only reporting the family TyCon can be - -- unhelpful (see T23301). So we give a bit of additional - -- info in that case. - | Just par_gre <- lookupGRE_Name gre_env par - , IAmTyCon tc_flav <- greInfo par_gre - , OpenFamilyFlavour IAmData _ <- tc_flav - -> vcat [ ppr_cons - , text "in a data family instance of" <+> quotes (ppr par) ] - | otherwise - -> text "of record" <+> quotes (ppr par) - NoParent -> ppr_cons - where - cons :: [ConLikeName] - cons = nonDetEltsUniqSet $ recFieldCons fld_info - first_con :: ConLikeName - first_con = head cons - ppr_cons :: SDoc - ppr_cons = hsep [ text "belonging to data constructor" - , quotes (ppr $ nameOccName $ conLikeName_Name first_con) - , if length cons > 1 then parens (text "among others") else empty - ] - pp_qual - | gre_lcl gre - = ppr (nameModule $ greName gre) - | Just imp <- headMaybe $ gre_imp gre - -- This 'imp' is the one that - -- pprNameProvenance chooses - , ImpDeclSpec { is_as = mod } <- is_decl imp - = ppr mod - | otherwise - = pprPanic "addNameClassErrRn" (ppr gre) - -- Invariant: either 'lcl' is True or 'iss' is non-empty - -pprNonCanonicalDefinition :: LHsSigType GhcRn - -> NonCanonicalDefinition - -> SDoc -pprNonCanonicalDefinition inst_ty = \case - NonCanonicalMonoid sub -> case sub of - NonCanonical_Sappend -> - msg1 "(<>)" "mappend" - NonCanonical_Mappend -> - msg2 "mappend" "(<>)" - NonCanonicalMonad sub -> case sub of - NonCanonical_Pure -> - msg1 "pure" "return" - NonCanonical_ThenA -> - msg1 "(*>)" "(>>)" - NonCanonical_Return -> - msg2 "return" "pure" - NonCanonical_ThenM -> - msg2 "(>>)" "(*>)" - where - msg1 :: String -> String -> SDoc - msg1 lhs rhs = - vcat [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , inst - ] - - msg2 :: String -> String -> SDoc - msg2 lhs rhs = - vcat [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , inst - , quotes (text lhs) <+> - text "will eventually be removed in favour of" <+> - quotes (text rhs) - ] - - inst = instDeclCtxt1 inst_ty - - -- stolen from GHC.Tc.TyCl.Instance - instDeclCtxt1 :: LHsSigType GhcRn -> SDoc - instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) - - inst_decl_ctxt :: SDoc -> SDoc - inst_decl_ctxt doc = hang (text "in the instance declaration for") - 2 (quotes doc <> text ".") - -suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint] -suggestNonCanonicalDefinition reason = - [action doc] - where - action = case reason of - NonCanonicalMonoid sub -> case sub of - NonCanonical_Sappend -> move sappendName mappendName - NonCanonical_Mappend -> remove mappendName sappendName - NonCanonicalMonad sub -> case sub of - NonCanonical_Pure -> move pureAName returnMName - NonCanonical_ThenA -> move thenAName thenMName - NonCanonical_Return -> remove returnMName pureAName - NonCanonical_ThenM -> remove thenMName thenAName - - move = SuggestMoveNonCanonicalDefinition - remove = SuggestRemoveNonCanonicalDefinition - - doc = case reason of - NonCanonicalMonoid _ -> doc_monoid - NonCanonicalMonad _ -> doc_monad - - doc_monoid = - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" - doc_monad = - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" - --------------------------------------------------------------------------------- --- hs-boot mismatch errors - -pprBootMismatch :: HsBootOrSig -> BootMismatch -> SDoc -pprBootMismatch boot_or_sig = \case - MissingBootThing nm err -> - let def_or_exp = case err of - MissingBootDefinition -> text "defined in" - MissingBootExport -> text "exported by" - in quotes (ppr nm) <+> text "is exported by the" - <+> ppr_boot_or_sig <> comma - <+> text "but not" - <+> def_or_exp <+> text "the implementing module." - MissingBootInstance boot_dfun -> - hang (text "instance" <+> ppr (idType boot_dfun)) - 2 (text "is defined in the" <+> ppr ppr_boot_or_sig <> comma <+> - text "but not in the implementing module.") - BadReexportedBootThing name name' -> - withUserStyle alwaysQualify AllTheWay $ vcat - [ text "The" <+> ppr_boot_or_sig - <+> text "(re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - BootMismatch boot_thing real_thing err -> - vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module" - , text "and its" <+> ppr_boot_or_sig <> dot, - text "Main module:" <+> real_doc - , (case boot_or_sig of - HsBoot -> text " Boot file:" - Hsig -> text " Hsig file:") <+> boot_doc - , pprBootMismatchWhat boot_or_sig err - ] - where - to_doc - = pprTyThingInContext $ - showToHeader - { ss_forall = - case boot_or_sig of - HsBoot -> ShowForAllMust - Hsig -> ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - where - ppr_boot_or_sig = case boot_or_sig of - HsBoot -> text "hs-boot file" - Hsig -> text "hsig file" - - -pprBootMismatchWhat :: HsBootOrSig -> BootMismatchWhat -> SDoc -pprBootMismatchWhat boot_or_sig = \case - BootMismatchedIdTypes {} -> - text "The two types are different." - BootMismatchedTyCons tc1 tc2 errs -> - vcat $ map (pprBootTyConMismatch boot_or_sig tc1 tc2) (NE.toList errs) - -pprBootTyConMismatch :: HsBootOrSig -> TyCon -> TyCon - -> BootTyConMismatch -> SDoc -pprBootTyConMismatch boot_or_sig tc1 tc2 = \case - TyConKindMismatch -> - text "The types have different kinds." - TyConRoleMismatch sub_type -> - if sub_type - then - text "The roles are not compatible:" $$ - text "Main module:" <+> ppr (tyConRoles tc1) $$ - text " Hsig file:" <+> ppr (tyConRoles tc2) - else - text "The roles do not match." $$ - if boot_or_sig == HsBoot - then text "NB: roles on abstract types default to" <+> - quotes (text "representational") <+> text "in hs-boot files." - else empty - TyConSynonymMismatch {} -> empty -- nothing interesting to say - TyConFlavourMismatch fam_flav1 fam_flav2 -> - whenPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match" - TyConAxiomMismatch ax_errs -> - pprBootListMismatches (text "Type family equations do not match:") - pprTyConAxiomMismatch ax_errs - TyConInjectivityMismatch {} -> - text "Injectivity annotations do not match" - TyConMismatchedClasses _ _ err -> - pprBootClassMismatch boot_or_sig err - TyConMismatchedData _rhs1 _rhs2 err -> - pprBootDataMismatch err - SynAbstractData err -> - pprSynAbstractDataError err - TyConsVeryDifferent -> - empty -- should be obvious to the user what the problem is - -pprSynAbstractDataError :: SynAbstractDataError -> SDoc -pprSynAbstractDataError = \case - SynAbsDataTySynNotNullary -> - text "Illegal parameterized type synonym in implementation of abstract data." - SynAbstractDataInvalidRHS bad_sub_tys -> - let msgs = mapMaybe pprInvalidAbstractSubTy (NE.toList bad_sub_tys) - in case msgs of - [] -> herald <> dot - msg:[] -> hang (herald <> colon) - 2 msg - _ -> hang (herald <> colon) - 2 (vcat $ map (<+> bullet) msgs) - - where - herald = text "Illegal implementation of abstract data" - pprInvalidAbstractSubTy = \case - TyConApp tc _ - -> assertPpr (isTypeFamilyTyCon tc) (ppr tc) $ - Just $ text "Invalid type family" <+> quotes (ppr tc) <> dot - ty@(ForAllTy {}) - -> Just $ text "Invalid polymorphic type" <> colon <+> ppr ty <> dot - ty@(FunTy af _ _ _) - | not (af == FTF_T_T) - -> Just $ text "Invalid qualified type" <> colon <+> ppr ty <> dot - _ -> Nothing - -pprTyConAxiomMismatch :: BootListMismatch CoAxBranch BootAxiomBranchMismatch -> SDoc -pprTyConAxiomMismatch = \case - MismatchedLength -> - text "The number of equations differs." - MismatchedThing i br1 br2 err -> - hang (text "The" <+> speakNth (i+1) <+> text "equations do not match.") - 2 (pprCoAxBranchMismatch br1 br2 err) - -pprCoAxBranchMismatch :: CoAxBranch -> CoAxBranch -> BootAxiomBranchMismatch -> SDoc -pprCoAxBranchMismatch _br1 _br2 err = - text "The" <+> what <+> text "don't match." - where - what = case err of - MismatchedAxiomBinders -> text "variables bound in the equation" - MismatchedAxiomLHS -> text "equation left-hand sides" - MismatchedAxiomRHS -> text "equation right-hand sides" - -pprBootListMismatches :: SDoc -- ^ herald - -> (BootListMismatch item err -> SDoc) - -> BootListMismatches item err -> SDoc -pprBootListMismatches herald ppr_one errs = - hang herald 2 msgs - where - msgs = case errs of - err :| [] -> ppr_one err - _ -> vcat $ map ((bullet <+>) . ppr_one) $ NE.toList errs - -pprBootClassMismatch :: HsBootOrSig -> BootClassMismatch -> SDoc -pprBootClassMismatch boot_or_sig = \case - MismatchedMethods errs -> - pprBootListMismatches (text "The class methods do not match:") - pprBootClassMethodListMismatch errs - MismatchedATs at_errs -> - pprBootListMismatches (text "The associated types do not match:") - (pprATMismatch boot_or_sig) at_errs - MismatchedFunDeps -> - text "The functional dependencies do not match." - MismatchedSuperclasses -> - text "The superclass constraints do not match." - MismatchedMinimalPragmas -> - text "The MINIMAL pragmas are not compatible." - -pprATMismatch :: HsBootOrSig -> BootListMismatch ClassATItem BootATMismatch -> SDoc -pprATMismatch boot_or_sig = \case - MismatchedLength -> - text "The number of associated type defaults differs." - MismatchedThing i at1 at2 err -> - pprATMismatchErr boot_or_sig i at1 at2 err - -pprATMismatchErr :: HsBootOrSig -> Int -> ClassATItem -> ClassATItem -> BootATMismatch -> SDoc -pprATMismatchErr boot_or_sig i (ATI tc1 _) (ATI tc2 _) = \case - MismatchedTyConAT err -> - hang (text "The associated types differ:") - 2 $ pprBootTyConMismatch boot_or_sig tc1 tc2 err - MismatchedATDefaultType -> - text "The types of the" <+> speakNth (i+1) <+> - text "associated type default differ." - -pprBootClassMethodListMismatch :: BootListMismatch ClassOpItem BootMethodMismatch -> SDoc -pprBootClassMethodListMismatch = \case - MismatchedLength -> - text "The number of class methods differs." - MismatchedThing _ op1 op2 err -> - pprBootClassMethodMismatch op1 op2 err - -pprBootClassMethodMismatch :: ClassOpItem -> ClassOpItem -> BootMethodMismatch -> SDoc -pprBootClassMethodMismatch (op1, _) (op2, _) = \case - MismatchedMethodNames -> - text "The method names" <+> quotes pname1 <+> text "and" - <+> quotes pname2 <+> text "differ." - MismatchedMethodTypes {} -> - text "The types of" <+> pname1 <+> text "are different." - MismatchedDefaultMethods subtype_check -> - if subtype_check - then - text "The default methods associated with" <+> pname1 <+> - text "are not compatible." - else - text "The default methods associated with" <+> pname1 <+> - text "are different." - where - nm1 = idName op1 - nm2 = idName op2 - pname1 = quotes (ppr nm1) - pname2 = quotes (ppr nm2) - -pprBootDataMismatch :: BootDataMismatch -> SDoc -pprBootDataMismatch = \case - MismatchedNewtypeVsData -> - text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition." - MismatchedConstructors dc_errs -> - pprBootListMismatches (text "The constructors do not match:") - pprBootDataConMismatch dc_errs - MismatchedDatatypeContexts {} -> - text "The datatype contexts do not match." - -pprBootDataConMismatch :: BootListMismatch DataCon BootDataConMismatch - -> SDoc -pprBootDataConMismatch = \case - MismatchedLength -> - text "The number of constructors differs." - MismatchedThing _ dc1 dc2 err -> - pprBootDataConMismatchErr dc1 dc2 err - -pprBootDataConMismatchErr :: DataCon -> DataCon -> BootDataConMismatch -> SDoc -pprBootDataConMismatchErr dc1 dc2 = \case - MismatchedDataConNames -> - text "The names" <+> pname1 <+> text "and" <+> pname2 <+> text "differ." - MismatchedDataConFixities -> - text "The fixities of" <+> pname1 <+> text "differ." - MismatchedDataConBangs -> - text "The strictness annotations for" <+> pname1 <+> text "differ." - MismatchedDataConFieldLabels -> - text "The record label lists for" <+> pname1 <+> text "differ." - MismatchedDataConTypes -> - text "The types for" <+> pname1 <+> text "differ." - where - name1 = dataConName dc1 - name2 = dataConName dc2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - --------------------------------------------------------------------------------- --- Illegal instance errors - -pprIllegalInstance :: IllegalInstanceReason -> SDoc -pprIllegalInstance = \case - IllegalClassInstance head_ty reason -> - pprIllegalClassInstanceReason head_ty reason - IllegalFamilyInstance reason -> - pprIllegalFamilyInstance reason - IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args -> - pprWithExplicitKindsWhen invis_arg $ - hang (text "Illegal type synonym family application" - <+> quotes (ppr tf_ty) <+> text "in instance" <> colon) - 2 (ppr inst_ty) - where - tf_ty = mkTyConApp tf_tc tf_args - -pprIllegalClassInstanceReason :: TypedThing -> IllegalClassInstanceReason -> SDoc -pprIllegalClassInstanceReason head_ty = \case - IllegalInstanceHead reason -> - pprIllegalInstanceHeadReason head_ty reason - IllegalHasFieldInstance has_field_err -> - with_illegal_instance_header head_ty $ - pprIllegalHasFieldInstance has_field_err - IllegalSpecialClassInstance cls because_safeHaskell -> - text "Class" <+> quotes (ppr $ className cls) - <+> text "does not support user-specified instances" - <> safeHaskell_msg - where - safeHaskell_msg - | because_safeHaskell - = text " when Safe Haskell is enabled." - | otherwise - = dot - IllegalInstanceFailsCoverageCondition cls coverage_failure -> - with_illegal_instance_header head_ty $ - pprNotCovered cls coverage_failure - -pprIllegalInstanceHeadReason :: TypedThing - -> IllegalInstanceHeadReason -> SDoc -pprIllegalInstanceHeadReason head_ty = \case - InstHeadTySynArgs -> with_illegal_instance_header head_ty $ - text "All instance types must be of the form (T t1 ... tn)" $$ - text "where T is not a synonym." - InstHeadNonTyVarArgs -> with_illegal_instance_header head_ty $ vcat [ - text "All instance types must be of the form (T a1 ... an)", - text "where a1 ... an are *distinct type variables*,", - text "and each type variable appears at most once in the instance head."] - InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $ - text "Only one type can be given in an instance head." - InstHeadAbstractClass clas -> - text "Cannot define instance for abstract class" <+> - quotes (ppr (className clas)) - InstHeadNonClass bad_head -> - vcat [ text "Illegal" <+> what_illegal <> dot - , text "Instance heads must be of the form" - , nest 2 $ text "C ty_1 ... ty_n" - , text "where" <+> quotes (char 'C') <+> text "is a class." - ] - where - what_illegal = case bad_head of - Just tc -> - text "instance for" <+> ppr (tyConFlavour tc) <+> quotes (ppr $ tyConName tc) - Nothing -> - text "head of an instance declaration:" <+> quotes (ppr head_ty) - -with_illegal_instance_header :: TypedThing -> SDoc -> SDoc -with_illegal_instance_header head_ty msg = - hang (hang (text "Illegal instance declaration for") - 2 (quotes (ppr head_ty)) <> colon) - 2 msg - -pprIllegalHasFieldInstance :: IllegalHasFieldInstance -> SDoc -pprIllegalHasFieldInstance = \case - IllegalHasFieldInstanceNotATyCon - -> text "Record data type must be specified." - IllegalHasFieldInstanceFamilyTyCon - -> text "Record data type may not be a data family." - IllegalHasFieldInstanceTyConHasField tc lbl - -> quotes (ppr tc) <+> text "already has a field" <+> quotes (ppr lbl) <> dot - IllegalHasFieldInstanceTyConHasFields tc lbl - -> sep [ ppr_tc <+> text "has fields, and the type" <+> quotes (ppr lbl) - , text "could unify with one of the field labels of" <+> ppr_tc <> dot ] - where ppr_tc = quotes (ppr tc) - -pprNotCovered :: Class -> CoverageProblem -> SDoc -pprNotCovered clas - CoverageProblem - { not_covered_fundep = fd - , not_covered_fundep_inst = (ls, rs) - , not_covered_invis_vis_tvs = undetermined_tvs - , not_covered_liberal = which_cc_failed - } = - pprWithExplicitKindsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ - vcat [ sep [ text "The" - <+> ppWhen liberal (text "liberal") - <+> text "coverage condition fails in class" - <+> quotes (ppr clas) - , nest 2 $ text "for functional dependency:" - <+> quotes (pprFunDep fd) ] - , sep [ text "Reason: lhs type" <> plural ls <+> pprQuotedList ls - , nest 2 $ - (if isSingleton ls - then text "does not" - else text "do not jointly") - <+> text "determine rhs type" <> plural rs - <+> pprQuotedList rs ] - , text "Un-determined variable" <> pluralVarSet undet_set <> colon - <+> pprVarSet undet_set (pprWithCommas ppr) - ] - where - liberal = case which_cc_failed of - FailedLICC -> True - FailedICC {} -> False - undet_set = fold undetermined_tvs - -illegalInstanceHints :: IllegalInstanceReason -> [GhcHint] -illegalInstanceHints = \case - IllegalClassInstance _ reason -> - illegalClassInstanceHints reason - IllegalFamilyInstance reason -> - illegalFamilyInstanceHints reason - IllegalFamilyApplicationInInstance {} -> - noHints - -illegalInstanceReason :: IllegalInstanceReason -> DiagnosticReason -illegalInstanceReason = \case - IllegalClassInstance _ reason -> - illegalClassInstanceReason reason - IllegalFamilyInstance reason -> - illegalFamilyInstanceReason reason - IllegalFamilyApplicationInInstance {} -> - ErrorWithoutFlag - -illegalClassInstanceHints :: IllegalClassInstanceReason -> [GhcHint] -illegalClassInstanceHints = \case - IllegalInstanceHead reason -> - illegalInstanceHeadHints reason - IllegalHasFieldInstance has_field_err -> - illegalHasFieldInstanceHints has_field_err - IllegalSpecialClassInstance {} -> noHints - IllegalInstanceFailsCoverageCondition _ coverage_failure -> - failedCoverageConditionHints coverage_failure - - -illegalClassInstanceReason :: IllegalClassInstanceReason -> DiagnosticReason -illegalClassInstanceReason = \case - IllegalInstanceHead reason -> - illegalInstanceHeadReason reason - IllegalHasFieldInstance has_field_err -> - illegalHasFieldInstanceReason has_field_err - IllegalSpecialClassInstance {} -> ErrorWithoutFlag - IllegalInstanceFailsCoverageCondition _ coverage_failure -> - failedCoverageConditionReason coverage_failure - -illegalInstanceHeadHints :: IllegalInstanceHeadReason -> [GhcHint] -illegalInstanceHeadHints = \case - InstHeadTySynArgs -> - [suggestExtension LangExt.TypeSynonymInstances] - InstHeadNonTyVarArgs -> - [suggestExtension LangExt.FlexibleInstances] - InstHeadMultiParam -> - [suggestExtension LangExt.MultiParamTypeClasses] - InstHeadAbstractClass {} -> - noHints - InstHeadNonClass {} -> - noHints - -illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason -illegalInstanceHeadReason = \case - -- These are serious - InstHeadAbstractClass {} -> - ErrorWithoutFlag - InstHeadNonClass {} -> - ErrorWithoutFlag - - -- These are less serious (enable an extension) - InstHeadTySynArgs -> - ErrorWithoutFlag - InstHeadNonTyVarArgs -> - ErrorWithoutFlag - InstHeadMultiParam -> - ErrorWithoutFlag - -illegalHasFieldInstanceHints :: IllegalHasFieldInstance -> [GhcHint] -illegalHasFieldInstanceHints = \case - IllegalHasFieldInstanceNotATyCon - -> noHints - IllegalHasFieldInstanceFamilyTyCon - -> noHints - IllegalHasFieldInstanceTyConHasField {} - -> noHints - IllegalHasFieldInstanceTyConHasFields {} - -> noHints - -illegalHasFieldInstanceReason :: IllegalHasFieldInstance -> DiagnosticReason -illegalHasFieldInstanceReason = \case - IllegalHasFieldInstanceNotATyCon - -> ErrorWithoutFlag - IllegalHasFieldInstanceFamilyTyCon - -> ErrorWithoutFlag - IllegalHasFieldInstanceTyConHasField {} - -> ErrorWithoutFlag - IllegalHasFieldInstanceTyConHasFields {} - -> ErrorWithoutFlag - -failedCoverageConditionHints :: CoverageProblem -> [GhcHint] -failedCoverageConditionHints (CoverageProblem { not_covered_liberal = failed_cc }) - = case failed_cc of - FailedLICC -> noHints - FailedICC { alsoFailedLICC = failed_licc } -> - -- Turning on UndecidableInstances makes the check liberal, - -- so if the liberal check passes, suggest enabling UndecidableInstances. - if failed_licc - then noHints - else [suggestExtension LangExt.UndecidableInstances] - -failedCoverageConditionReason :: CoverageProblem -> DiagnosticReason -failedCoverageConditionReason _ = ErrorWithoutFlag - -pprIllegalFamilyInstance :: IllegalFamilyInstanceReason -> SDoc -pprIllegalFamilyInstance = \case - InvalidAssoc reason -> pprInvalidAssoc reason - NotAFamilyTyCon ty_or_data tc -> - vcat [ text "Illegal family instance for" <+> quotes (ppr tc) - , nest 2 $ parens (quotes (ppr tc) <+> text "is not a" <+> what) ] - where - what = ppr ty_or_data <+> text "family" - NotAnOpenFamilyTyCon tc -> - text "Illegal instance for closed family" <+> quotes (ppr tc) - FamilyCategoryMismatch tc -> - text "Wrong category of family instance; declaration was for a" <+> what <> dot - where - what = case tyConFlavour tc of - OpenFamilyFlavour IAmData _ -> text "data family" - _ -> text "type family" - FamilyArityMismatch _ max_args -> - text "Number of parameters must match family declaration; expected" - <+> ppr max_args <> dot - TyFamNameMismatch fam_tc_name eqn_tc_name -> - hang (text "Mismatched type name in type family instance.") - 2 (vcat [ text "Expected:" <+> ppr fam_tc_name - , text " Actual:" <+> ppr eqn_tc_name ]) - FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) -> - hang (text "Out of scope type variable" <> plural tvs - <+> pprWithCommas (quotes . ppr) tvs - <+> text "in the RHS of a family instance.") - 2 (text "All such variables must be bound on the LHS.") - $$ mk_extra - where - -- mk_extra: #7536: give a decent error message for - -- type T a = Int - -- type instance F (T a) = a - mk_extra = case mb_dodgy of - Nothing -> empty - Just (fam_tc, pats, dodgy_tvs) -> - ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $ - hang (text "The real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) - FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) -> - vcat [ not_bound_msg, not_used_msg, dodgy_msg ] - where - - -- Filter to only keep user-written variables, - -- unless none were user-written in which case we report all of them - -- (as we need to report an error). - filter_user tvs - = map ifiqtv - $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs } - - (not_bound, not_used, dodgy) - = case foldr acc_tv ([], [], []) bad_qtvs of - (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d) - - acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of - InvalidFamInstQTvNotUsedInRHS -> (nb, tv : nu, d) - InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d) - InvalidFamInstQTvDodgy -> (nb, nu, tv : d) - - -- Error message for type variables not bound in LHS patterns. - not_bound_msg - | null not_bound - = empty - | otherwise - = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound - <+> isOrAre not_bound <+> text "bound by a forall," - , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ] - - -- Error message for type variables bound by a forall but not used - -- in the RHS. - not_used_msg = - if null not_used - then empty - else text "The type variable" <> plural not_used <+> pprQuotedList not_used - <+> isOrAre not_used <+> text "bound by a forall," $$ - text "but" <+> itOrThey not_used <+> - isOrAre not_used <> text "n't used in the family instance." - - -- Error message for dodgy type variables. - -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity. - dodgy_msg - | null dodgy - = empty - | otherwise - = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy - <+> text "in the LHS of a family instance:") - 2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy - <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns," - $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.") - - -illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint] -illegalFamilyInstanceHints = \case - InvalidAssoc rea -> invalidAssocHints rea - NotAFamilyTyCon {} -> noHints - NotAnOpenFamilyTyCon {} -> noHints - FamilyCategoryMismatch {} -> noHints - FamilyArityMismatch {} -> noHints - TyFamNameMismatch {} -> noHints - FamInstRHSOutOfScopeTyVars {} -> noHints - FamInstLHSUnusedBoundTyVars {} -> noHints - -illegalFamilyInstanceReason :: IllegalFamilyInstanceReason -> DiagnosticReason -illegalFamilyInstanceReason = \case - InvalidAssoc rea -> invalidAssocReason rea - NotAFamilyTyCon {} -> ErrorWithoutFlag - NotAnOpenFamilyTyCon {} -> ErrorWithoutFlag - FamilyCategoryMismatch {} -> ErrorWithoutFlag - FamilyArityMismatch {} -> ErrorWithoutFlag - TyFamNameMismatch {} -> ErrorWithoutFlag - FamInstRHSOutOfScopeTyVars {} -> ErrorWithoutFlag - FamInstLHSUnusedBoundTyVars {} -> ErrorWithoutFlag - -pprInvalidAssoc :: InvalidAssoc -> SDoc -pprInvalidAssoc = \case - InvalidAssocInstance rea -> pprInvalidAssocInstance rea - InvalidAssocDefault rea -> pprInvalidAssocDefault rea - -pprInvalidAssocInstance :: InvalidAssocInstance -> SDoc -pprInvalidAssocInstance = \case - AssocInstanceMissing name -> - text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name) - AssocInstanceNotInAClass fam_tc -> - text "Associated type" <+> quotes (ppr fam_tc) <+> - text "must be inside a class instance" - AssocNotInThisClass cls fam_tc -> - hsep [ text "Class", quotes (ppr cls) - , text "does not have an associated type", quotes (ppr fam_tc) ] - AssocNoClassTyVar cls fam_tc -> - sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) - , text "mentions none of the type or kind variables of the class" <+> - quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))] - AssocTyVarsDontMatch vis fam_tc exp_tys act_tys -> - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ - vcat [ text "Type indexes must match class instance head" - , text "Expected:" <+> pp exp_tys - , text " Actual:" <+> pp act_tys ] - where - pp tys = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc tys - -pprInvalidAssocDefault :: InvalidAssocDefault -> SDoc -pprInvalidAssocDefault = \case - AssocDefaultNotAssoc cls tc -> - hsep [ text "Class", quotes (ppr cls) - , text "does not have an associated type", quotes (ppr tc) ] - AssocMultipleDefaults name -> - text "More than one default declaration for" <+> quotes (ppr name) - AssocDefaultBadArgs fam_tc pat_tys bad_arg -> - let (pat_vis, main_msg) = case bad_arg of - AssocDefaultNonTyVarArg (pat_ty, pat_vis) -> - (pat_vis, - text "Illegal argument" <+> quotes (ppr pat_ty) <+> text "in:") - AssocDefaultDuplicateTyVars dups -> - let (pat_tv, pat_vis) = NE.head dups - in (pat_vis, - text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") - in pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ - hang main_msg - 2 (vcat [ppr_eqn, suggestion]) - where - ppr_eqn :: SDoc - ppr_eqn = - quotes (text "type" <+> ppr (mkTyConApp fam_tc pat_tys) - <+> equals <+> text "...") - - suggestion :: SDoc - suggestion = text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be distinct type variables." - -invalidAssocHints :: InvalidAssoc -> [GhcHint] -invalidAssocHints = \case - InvalidAssocInstance rea -> invalidAssocInstanceHints rea - InvalidAssocDefault rea -> invalidAssocDefaultHints rea - -invalidAssocInstanceHints :: InvalidAssocInstance -> [GhcHint] -invalidAssocInstanceHints = \case - AssocInstanceMissing {} -> noHints - AssocInstanceNotInAClass {} -> noHints - AssocNotInThisClass {} -> noHints - AssocNoClassTyVar {} -> noHints - AssocTyVarsDontMatch {} -> noHints - -invalidAssocDefaultHints :: InvalidAssocDefault -> [GhcHint] -invalidAssocDefaultHints = \case - AssocDefaultNotAssoc {} -> noHints - AssocMultipleDefaults {} -> noHints - AssocDefaultBadArgs _ _ bad -> - assocDefaultBadArgHints bad - -assocDefaultBadArgHints :: AssocDefaultBadArgs -> [GhcHint] -assocDefaultBadArgHints = \case - AssocDefaultNonTyVarArg {} -> noHints - AssocDefaultDuplicateTyVars {} -> noHints - -invalidAssocReason :: InvalidAssoc -> DiagnosticReason -invalidAssocReason = \case - InvalidAssocInstance rea -> invalidAssocInstanceReason rea - InvalidAssocDefault rea -> invalidAssocDefaultReason rea - -invalidAssocInstanceReason :: InvalidAssocInstance -> DiagnosticReason -invalidAssocInstanceReason = \case - AssocInstanceMissing {} -> WarningWithFlag (Opt_WarnMissingMethods) - AssocInstanceNotInAClass {} -> ErrorWithoutFlag - AssocNotInThisClass {} -> ErrorWithoutFlag - AssocNoClassTyVar {} -> ErrorWithoutFlag - AssocTyVarsDontMatch {} -> ErrorWithoutFlag - -invalidAssocDefaultReason :: InvalidAssocDefault -> DiagnosticReason -invalidAssocDefaultReason = \case - AssocDefaultNotAssoc {} -> ErrorWithoutFlag - AssocMultipleDefaults {} -> ErrorWithoutFlag - AssocDefaultBadArgs _ _ rea -> - assocDefaultBadArgReason rea - -assocDefaultBadArgReason :: AssocDefaultBadArgs -> DiagnosticReason -assocDefaultBadArgReason = \case - AssocDefaultNonTyVarArg {} -> ErrorWithoutFlag - AssocDefaultDuplicateTyVars {} -> ErrorWithoutFlag - --------------------------------------------------------------------------------- --- Template Haskell quotes and splices - -pprTHError :: THError -> DecoratedSDoc -pprTHError = \case - THSyntaxError err -> pprTHSyntaxError err - THNameError err -> pprTHNameError err - THReifyError err -> pprTHReifyError err - TypedTHError err -> pprTypedTHError err - THSpliceFailed rea -> pprSpliceFailReason rea - AddTopDeclsError err -> pprAddTopDeclsError err - - IllegalStaticFormInSplice e -> - mkSimpleDecorated $ - sep [ text "static forms cannot be used in splices:" - , nest 2 $ ppr e - ] - - FailedToLookupThInstName th_type reason -> - mkSimpleDecorated $ - case reason of - NoMatchesFound -> - text "Couldn't find any instances of" - <+> text (TH.pprint th_type) - <+> text "to add documentation to" - CouldNotDetermineInstance -> - text "Couldn't work out what instance" - <+> text (TH.pprint th_type) - <+> text "is supposed to be" - - AddInvalidCorePlugin plugin -> - mkSimpleDecorated $ - hang (text "addCorePlugin: invalid plugin module" <+> quotes (text plugin) ) - 2 (text "Plugins in the current package can't be specified.") - - AddDocToNonLocalDefn doc_loc -> - mkSimpleDecorated $ - text "Can't add documentation to" <+> ppr_loc doc_loc <> comma <+> - text "as it isn't inside the current module." - where - ppr_loc (TH.DeclDoc n) = text $ TH.pprint n - ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n - ppr_loc (TH.InstDoc t) = text $ TH.pprint t - ppr_loc TH.ModuleDoc = text "the module header" - - ReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg - -pprTHSyntaxError :: THSyntaxError -> DecoratedSDoc -pprTHSyntaxError = mkSimpleDecorated . \case - IllegalTHQuotes expr -> - text "Syntax error on" <+> ppr expr - -- The error message context will say - -- "In the Template Haskell quotation", so no need to repeat that here. - BadImplicitSplice -> - sep [ text "Parse error: module header, import declaration" - , text "or top-level declaration expected." ] - -- The compiler should not mention TemplateHaskell, as the common case - -- is that this is a simple beginner error, for example: - -- - -- module M where - -- f :: Int -> Int; f x = x - -- xyzzy - -- g y = f y + 1 - -- - -- It's unlikely that 'xyzzy' above was intended to be a Template Haskell - -- splice; instead it's probably something mistakenly left in the code. - -- See #12146 for discussion. - - IllegalTHSplice -> - text "Unexpected top-level splice." - MismatchedSpliceType splice_type inner_splice_or_bracket -> - inner <+> text "may not appear in" <+> outer <> dot - where - (inner, outer) = case inner_splice_or_bracket of - IsSplice -> case splice_type of - Typed -> (text "Typed splices" , text "untyped brackets") - Untyped -> (text "Untyped splices", text "typed brackets") - IsBracket -> - case splice_type of - Typed -> (text "Untyped brackets", text "typed splices") - Untyped -> (text "Typed brackets" , text "untyped splices") - NestedTHBrackets -> - text "Template Haskell brackets cannot be nested" <+> - text "(without intervening splices)" - -pprTHNameError :: THNameError -> DecoratedSDoc -pprTHNameError = \case - NonExactName name -> - mkSimpleDecorated $ - hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") - 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") - QuotedNameWrongStage quote -> - mkSimpleDecorated $ - sep [ text "Stage error: the non-top-level quoted name" <+> ppr quote - , text "must be used at the same stage at which it is bound." ] - -pprTHReifyError :: THReifyError -> DecoratedSDoc -pprTHReifyError = \case - CannotReifyInstance ty - -> mkSimpleDecorated $ - hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application") - CannotReifyOutOfScopeThing th_name - -> mkSimpleDecorated $ - quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name - CannotReifyThingNotInTypeEnv name - -> mkSimpleDecorated $ - quotes (ppr name) <+> text "is not in the type environment at a reify" - NoRolesAssociatedWithThing thing - -> mkSimpleDecorated $ - text "No roles associated with" <+> (ppr thing) - CannotRepresentType sort ty - -> mkSimpleDecorated $ - hsep [text "Can't represent" <+> sort_doc <+> - text "in Template Haskell:", - nest 2 (ppr ty)] - where - sort_doc = text $ - case sort of - LinearInvisibleArgument -> "linear invisible argument" - CoercionsInTypes -> "coercions in types" - -pprTypedTHError :: TypedTHError -> DecoratedSDoc -pprTypedTHError = \case - SplicePolymorphicLocalVar ident - -> mkSimpleDecorated $ - text "Can't splice the polymorphic local variable" <+> quotes (ppr ident) - TypedTHWithPolyType ty - -> mkSimpleDecorated $ - vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - -pprSpliceFailReason :: SpliceFailReason -> DecoratedSDoc -pprSpliceFailReason = \case - SpliceThrewException phase _exn exn_msg expr show_code -> - mkSimpleDecorated $ - vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:" - , nest 2 (text exn_msg) - , if show_code then text "Code:" <+> ppr expr else empty] - where phaseStr = - case phase of - SplicePhase_Run -> "run" - SplicePhase_CompileAndLink -> "compile and link" - RunSpliceFailure err -> pprRunSpliceFailure Nothing err - -pprAddTopDeclsError :: AddTopDeclsError -> DecoratedSDoc -pprAddTopDeclsError = \case - InvalidTopDecl _decl -> - mkSimpleDecorated $ - sep [ text "Only function, value, annotation, and foreign import declarations" - , text "may be added with" <+> quotes (text "addTopDecls") <> dot ] - AddTopDeclsUnexpectedDeclarationSplice {} -> - mkSimpleDecorated $ - text "Declaration splices are not permitted" <+> - text "inside top-level declarations added with" <+> - quotes (text "addTopDecls") <> dot - AddTopDeclsRunSpliceFailure err -> - pprRunSpliceFailure (Just "addTopDecls") err - -pprRunSpliceFailure :: Maybe String -> RunSpliceFailReason -> DecoratedSDoc -pprRunSpliceFailure mb_calling_fn (ConversionFail what reason) = - mkSimpleDecorated . add_calling_fn . addSpliceInfo $ - pprConversionFailReason reason - where - add_calling_fn rest = - case mb_calling_fn of - Just calling_fn -> - hang (text "Error in a declaration passed to" <+> quotes (text calling_fn) <> colon) - 2 rest - Nothing -> rest - addSpliceInfo = case what of - ConvDec d -> addSliceInfo' "declaration" d - ConvExp e -> addSliceInfo' "expression" e - ConvPat p -> addSliceInfo' "pattern" p - ConvType t -> addSliceInfo' "type" t - addSliceInfo' what item reasonErr = reasonErr $$ descr - where - -- Show the item in pretty syntax normally, - -- but with all its constructors if you say -dppr-debug - descr = hang (text "When splicing a TH" <+> text what <> colon) - 2 (getPprDebug $ \case - True -> text (show item) - False -> text (TH.pprint item)) - -thErrorReason :: THError -> DiagnosticReason -thErrorReason = \case - THSyntaxError err -> thSyntaxErrorReason err - THNameError err -> thNameErrorReason err - THReifyError err -> thReifyErrorReason err - TypedTHError err -> typedTHErrorReason err - THSpliceFailed rea -> spliceFailedReason rea - AddTopDeclsError err -> addTopDeclsErrorReason err - - IllegalStaticFormInSplice {} -> ErrorWithoutFlag - FailedToLookupThInstName {} -> ErrorWithoutFlag - AddInvalidCorePlugin {} -> ErrorWithoutFlag - AddDocToNonLocalDefn {} -> ErrorWithoutFlag - ReportCustomQuasiError is_error _ -> - if is_error - then ErrorWithoutFlag - else WarningWithoutFlag - -thSyntaxErrorReason :: THSyntaxError -> DiagnosticReason -thSyntaxErrorReason = \case - IllegalTHQuotes{} -> ErrorWithoutFlag - BadImplicitSplice -> ErrorWithoutFlag - IllegalTHSplice{} -> ErrorWithoutFlag - NestedTHBrackets{} -> ErrorWithoutFlag - MismatchedSpliceType{} -> ErrorWithoutFlag - -thNameErrorReason :: THNameError -> DiagnosticReason -thNameErrorReason = \case - NonExactName {} -> ErrorWithoutFlag - QuotedNameWrongStage {} -> ErrorWithoutFlag - -thReifyErrorReason :: THReifyError -> DiagnosticReason -thReifyErrorReason = \case - CannotReifyInstance {} -> ErrorWithoutFlag - CannotReifyOutOfScopeThing {} -> ErrorWithoutFlag - CannotReifyThingNotInTypeEnv {} -> ErrorWithoutFlag - NoRolesAssociatedWithThing {} -> ErrorWithoutFlag - CannotRepresentType {} -> ErrorWithoutFlag - -typedTHErrorReason :: TypedTHError -> DiagnosticReason -typedTHErrorReason = \case - SplicePolymorphicLocalVar {} -> ErrorWithoutFlag - TypedTHWithPolyType {} -> ErrorWithoutFlag - -spliceFailedReason :: SpliceFailReason -> DiagnosticReason -spliceFailedReason = \case - SpliceThrewException {} -> ErrorWithoutFlag - RunSpliceFailure {} -> ErrorWithoutFlag - -addTopDeclsErrorReason :: AddTopDeclsError -> DiagnosticReason -addTopDeclsErrorReason = \case - InvalidTopDecl {} - -> ErrorWithoutFlag - AddTopDeclsUnexpectedDeclarationSplice {} - -> ErrorWithoutFlag - AddTopDeclsRunSpliceFailure {} - -> ErrorWithoutFlag - -thErrorHints :: THError -> [GhcHint] -thErrorHints = \case - THSyntaxError err -> thSyntaxErrorHints err - THNameError err -> thNameErrorHints err - THReifyError err -> thReifyErrorHints err - TypedTHError err -> typedTHErrorHints err - THSpliceFailed rea -> spliceFailedHints rea - AddTopDeclsError err -> addTopDeclsErrorHints err - - IllegalStaticFormInSplice {} -> noHints - FailedToLookupThInstName {} -> noHints - AddInvalidCorePlugin {} -> noHints - AddDocToNonLocalDefn {} -> noHints - ReportCustomQuasiError {} -> noHints - -thSyntaxErrorHints :: THSyntaxError -> [GhcHint] -thSyntaxErrorHints = \case - IllegalTHQuotes{} - -> [suggestAnyExtension [LangExt.TemplateHaskell, LangExt.TemplateHaskellQuotes]] - BadImplicitSplice {} - -> noHints -- NB: don't suggest TemplateHaskell - -- see comments on BadImplicitSplice in pprTHSyntaxError - IllegalTHSplice{} - -> [suggestExtension LangExt.TemplateHaskell] - NestedTHBrackets{} - -> noHints - MismatchedSpliceType{} - -> noHints - -thNameErrorHints :: THNameError -> [GhcHint] -thNameErrorHints = \case - NonExactName {} -> noHints - QuotedNameWrongStage {} -> noHints - -thReifyErrorHints :: THReifyError -> [GhcHint] -thReifyErrorHints = \case - CannotReifyInstance {} -> noHints - CannotReifyOutOfScopeThing {} -> noHints - CannotReifyThingNotInTypeEnv {} -> noHints - NoRolesAssociatedWithThing {} -> noHints - CannotRepresentType {} -> noHints - -typedTHErrorHints :: TypedTHError -> [GhcHint] -typedTHErrorHints = \case - SplicePolymorphicLocalVar {} -> noHints - TypedTHWithPolyType {} -> noHints - -spliceFailedHints :: SpliceFailReason -> [GhcHint] -spliceFailedHints = \case - SpliceThrewException {} -> noHints - RunSpliceFailure {} -> noHints - -addTopDeclsErrorHints :: AddTopDeclsError -> [GhcHint] -addTopDeclsErrorHints = \case - InvalidTopDecl {} - -> noHints - AddTopDeclsUnexpectedDeclarationSplice {} - -> noHints - AddTopDeclsRunSpliceFailure {} - -> noHints - --------------------------------------------------------------------------------- - -pprPatersonCondFailure :: - PatersonCondFailure -> PatersonCondFailureContext -> Type -> Type -> SDoc -pprPatersonCondFailure (PCF_TyVar tvs) InInstanceDecl lhs rhs = - hang (occMsg tvs) - 2 (sep [ text "in the constraint" <+> quotes (ppr lhs) - , text "than in the instance head" <+> quotes (ppr rhs) ]) - where - occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> pp_occurs <+> text "more often" - pp_occurs | isSingleton tvs = text "occurs" - | otherwise = text "occur" -pprPatersonCondFailure (PCF_TyVar tvs) InTyFamEquation lhs rhs = - hang (occMsg tvs) - 2 (sep [ text "in the type-family application" <+> quotes (ppr rhs) - , text "than in the LHS of the family instance" <+> quotes (ppr lhs) ]) - where - occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> pp_occurs <+> text "more often" - pp_occurs | isSingleton tvs = text "occurs" - | otherwise = text "occur" -pprPatersonCondFailure PCF_Size InInstanceDecl lhs rhs = - hang (text "The constraint" <+> quotes (ppr lhs)) - 2 (sep [ text "is no smaller than", pp_rhs ]) - where pp_rhs = text "the instance head" <+> quotes (ppr rhs) -pprPatersonCondFailure PCF_Size InTyFamEquation lhs rhs = - hang (text "The type-family application" <+> quotes (ppr rhs)) - 2 (sep [ text "is no smaller than", pp_lhs ]) - where pp_lhs = text "the LHS of the family instance" <+> quotes (ppr lhs) -pprPatersonCondFailure (PCF_TyFam tc) InInstanceDecl lhs _rhs = - hang (text "Illegal use of type family" <+> quotes (ppr tc)) - 2 (text "in the constraint" <+> quotes (ppr lhs)) -pprPatersonCondFailure (PCF_TyFam tc) InTyFamEquation _lhs rhs = - hang (text "Illegal nested use of type family" <+> quotes (ppr tc)) - 2 (text "in the arguments of the type-family application" <+> quotes (ppr rhs)) - - - --------------------------------------------------------------------------------- - -pprZonkerMessage :: ZonkerMessage -> SDoc -pprZonkerMessage = \case - ZonkerCannotDefaultConcrete frr -> - ppr (frr_context frr) $$ - text "cannot be assigned a fixed runtime representation," <+> - text "not even by defaulting." - -zonkerMessageHints :: ZonkerMessage -> [GhcHint] -zonkerMessageHints = \case - ZonkerCannotDefaultConcrete {} -> [SuggestAddTypeSignatures UnnamedBinding] - -zonkerMessageReason :: ZonkerMessage -> DiagnosticReason -zonkerMessageReason = \case - ZonkerCannotDefaultConcrete {} -> ErrorWithoutFlag - --------------------------------------------------------------------------------- +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE InstanceSigs #-} + +module GHC.Tc.Errors.Ppr + ( pprTypeDoesNotHaveFixedRuntimeRep + , pprScopeError + , pprErrCtxtMsg + -- + , tidySkolemInfo + , tidySkolemInfoAnon + -- + , pprHsDocContext + , inHsDocContext + , TcRnMessageOpts(..) + , pprTyThingUsedWrong + , pprUntouchableVariable + + -- + , mismatchMsg_ExpectedActuals + + -- | Useful when overriding message printing. + , messageWithInfoDiagnosticMessage + , messageWithHsDocContext + ) + where + +import GHC.Prelude + +import qualified GHC.Boot.TH.Syntax as TH +-- In stage1: import "ghc-boot-th-next" qualified GHC.Boot.TH.Syntax as TH +-- In stage2: import "ghc-boot-th" qualified GHC.Boot.TH.Syntax as TH +-- which is a rexport of +-- import "ghc-internal" qualified GHC.Internal.TH.Syntax as TH +import qualified GHC.Boot.TH.Ppr as TH + +import GHC.Builtin.Names +import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, pretendNameIsInScope ) + +import GHC.Types.Name.Reader +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Warnings + +import GHC.Core.Coercion +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.Coercion.Axiom (CoAxBranch, coAxiomTyCon, coAxiomSingleBranch) +import GHC.Core.ConLike +import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst ) +import GHC.Core.InstEnv +import GHC.Core.TyCo.Rep (Type(..)) +import GHC.Core.TyCo.Ppr (pprWithInvisibleBitsWhen, pprSourceTyCon, + pprTyVars, pprWithTYPE, pprTyVar, pprTidiedType, pprForAll) +import GHC.Core.PatSyn ( patSynName, pprPatSynType ) +import GHC.Core.TyCo.Tidy +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.FVs( orphNamesOfTypes ) +import GHC.CoreToIface + +import GHC.Driver.Flags +import GHC.Driver.Backend +import GHC.Hs hiding (HoleError) + +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Origin hiding ( Position(..) ) +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Rank (Rank(..)) +import GHC.Tc.Types.TH +import GHC.Tc.Utils.TcType + +import GHC.Types.DefaultEnv (ClassDefaults(ClassDefaults, cd_types, cd_provenance), DefaultProvenance (..)) +import GHC.Types.Error +import GHC.Types.Error.Codes +import GHC.Types.Hint +import GHC.Types.Hint.Ppr ( pprSigLike ) -- & Outputable GhcHint +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Id.Info ( RecSelParent(..) ) +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Fixity (defaultFixity) + +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr +import GHC.Iface.Syntax + +import GHC.Unit.State +import GHC.Unit.Module + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.List.SetOps ( nubOrdBy ) +import GHC.Data.Maybe +import GHC.Data.Pair +import GHC.Settings.Constants (mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE) +import GHC.Utils.Lexeme +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.BooleanFormula (pprBooleanFormulaNice) + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import Data.Foldable ( fold ) +import Data.Function (on) +import Data.List ( groupBy, sortBy, tails + , partition, unfoldr ) +import Data.Ord ( comparing ) +import Data.Bifunctor +import GHC.Tc.Errors.Types.PromotionErr (pprTermLevelUseCtxt) + + +defaultTcRnMessageOpts :: TcRnMessageOpts +defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True + , tcOptsIfaceOpts = defaultDiagnosticOpts @IfaceMessage } + +instance HasDefaultDiagnosticOpts TcRnMessageOpts where + defaultOpts = defaultTcRnMessageOpts + +instance Diagnostic TcRnMessage where + type DiagnosticOpts TcRnMessage = TcRnMessageOpts + diagnosticMessage opts = \case + TcRnUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m + TcRnMessageWithInfo unit_state msg_with_info + -> case msg_with_info of + TcRnMessageDetailed err_info msg + -> messageWithInfoDiagnosticMessage unit_state err_info + (tcOptsShowContext opts) + (diagnosticMessage opts msg) + TcRnWithHsDocContext ctxt msg + -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg) + TcRnSolverReport msg _reason + -> mkSimpleDecorated $ pprSolverReportWithCtxt msg + TcRnSolverDepthError ty depth -> mkSimpleDecorated msg + where + msg = + vcat [ text "Reduction stack overflow; size =" <+> ppr depth + , hang (text "When simplifying the following type:") + 2 (ppr ty) ] + TcRnRedundantConstraints redundants (info, show_info) + -> mkSimpleDecorated $ + text "Redundant constraint" <> plural redundants <> colon + <+> pprEvVarTheta redundants + $$ if show_info then text "In" <+> ppr info else empty + TcRnInaccessibleCode implic contra + -> mkSimpleDecorated $ + hang (text "Inaccessible code in") + 2 (ppr (ic_info implic)) + $$ pprSolverReportWithCtxt contra + TcRnInaccessibleCoAxBranch fam_tc cur_branch + -> mkSimpleDecorated $ + text "Type family instance equation is overlapped:" $$ + nest 2 (pprCoAxBranchUser fam_tc cur_branch) + TcRnTypeDoesNotHaveFixedRuntimeRep ty prov err_ctxt + -> mkDecorated $ + (pprTypeDoesNotHaveFixedRuntimeRep ty prov) + : map pprErrCtxtMsg err_ctxt + TcRnImplicitLift id_or_name err_ctxt + -> mkDecorated $ + ( text "The variable" <+> quotes (ppr id_or_name) <+> + text "is implicitly lifted in the TH quotation" + ) : map pprErrCtxtMsg err_ctxt + TcRnUnusedPatternBinds bind + -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)] + TcRnDodgyImports (DodgyImportsEmptyParent gre) + -> mkDecorated [dodgy_msg (text "import") gre (dodgy_msg_insert gre)] + TcRnDodgyImports (DodgyImportsHiding reason) + -> mkSimpleDecorated $ + pprImportLookup reason + TcRnDodgyExports gre + -> mkDecorated [dodgy_msg (text "export") gre (dodgy_msg_insert gre)] + TcRnMissingImportList ie + -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> + text "does not have an explicit import list" + ] + TcRnUnsafeDueToPlugin + -> mkDecorated [text "Use of plugins makes the module unsafe"] + TcRnModMissingRealSrcSpan mod + -> mkDecorated [text "Module does not have a RealSrcSpan:" <+> ppr mod] + TcRnIdNotExportedFromModuleSig name mod + -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> + text "does not exist in the signature for" <+> ppr mod + ] + TcRnIdNotExportedFromLocalSig name + -> mkDecorated [ text "The identifier" <+> ppr (occName name) <+> + text "does not exist in the local signature." + ] + TcRnShadowedName occ provenance + -> let shadowed_locs = case provenance of + ShadowedNameProvenanceLocal n -> [text "bound at" <+> ppr n] + ShadowedNameProvenanceGlobal gres -> map pprNameProvenance gres + in mkSimpleDecorated $ + sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + TcRnInvalidWarningCategory cat + -> mkSimpleDecorated $ + vcat [text "Warning category" <+> quotes (ppr cat) <+> text "is not valid", + text "(user-defined category names must begin with" <+> quotes (text "x-"), + text "and contain only letters, numbers, apostrophes and dashes)" ] + TcRnDuplicateWarningDecls d rdr_name + -> mkSimpleDecorated $ + vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr (getLocA d)] + TcRnSimplifierTooManyIterations simples limit wc + -> mkSimpleDecorated $ + hang (text "solveWanteds: too many iterations" + <+> parens (text "limit =" <+> ppr limit)) + 2 (vcat [ text "Unsolved:" <+> ppr wc + , text "Simples:" <+> ppr simples + ]) + TcRnIllegalPatSynDecl rdrname + -> mkSimpleDecorated $ + hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") + TcRnLinearPatSyn ty + -> mkSimpleDecorated $ + hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty) + TcRnEmptyRecordUpdate + -> mkSimpleDecorated $ text "Empty record update" + TcRnIllegalFieldPunning fld + -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld) + TcRnIllegalWildcardsInRecord fld_part + -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part + TcRnIllegalWildcardInType mb_name bad + -> mkSimpleDecorated $ case bad of + WildcardNotLastInConstraint -> + hang notAllowed 2 constraint_hint_msg + ExtraConstraintWildcardNotAllowed allow_sole -> + case allow_sole of + SoleExtraConstraintWildcardNotAllowed -> + notAllowed + SoleExtraConstraintWildcardAllowed -> + hang notAllowed 2 sole_msg + WildcardsNotAllowedAtAll -> + notAllowed + WildcardBndrInForallTelescope -> + notAllowed + WildcardBndrInTyFamResultVar -> + notAllowed + where + notAllowed, what, wildcard, how :: SDoc + notAllowed = what <+> quotes wildcard <+> how + wildcard = case mb_name of + Nothing -> pprAnonWildCard + Just name -> ppr name + what + | Just _ <- mb_name + = text "Named wildcard" + | ExtraConstraintWildcardNotAllowed {} <- bad + = text "Extra-constraint wildcard" + | WildcardBndrInForallTelescope {} <- bad + = text "Wildcard binder" + | WildcardBndrInTyFamResultVar {} <- bad + = text "Wildcard binder" + | otherwise + = text "Wildcard" + how = case bad of + WildcardNotLastInConstraint + -> text "not allowed in a constraint" + WildcardBndrInForallTelescope + -> text "not allowed in a forall telescope" + WildcardBndrInTyFamResultVar + -> text "not allowed in a type family result" + _ -> text "not allowed" + constraint_hint_msg :: SDoc + constraint_hint_msg + | Just _ <- mb_name + = vcat [ text "Extra-constraint wildcards must be anonymous" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + | otherwise + = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + sole_msg :: SDoc + sole_msg = + vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] + TcRnIllegalNamedWildcardInTypeArgument rdr + -> mkSimpleDecorated $ + hang (text "Illegal named wildcard in a required type argument:") + 2 (quotes (ppr rdr)) + TcRnIllegalImplicitTyVarInTypeArgument rdr + -> mkSimpleDecorated $ + hang (text "Illegal implicitly quantified type variable in a required type argument:") + 2 (quotes (ppr rdr)) + TcRnIllegalPunnedVarOccInTypeArgument n1 n2 + -> mkSimpleDecorated $ hang msg 2 info + where + msg = vcat [ text "Illegal punned variable occurrence in a required type argument." + , text "The name" <+> quotes (ppr n1) <+> text "could refer to:" ] + info = vcat [ quotes (ppr n1) <+> pprResolvedNameProvenance n1 + , quotes (ppr n2) <+> pprResolvedNameProvenance n2 ] + TcRnDuplicateFieldName fld_part dups + -> mkSimpleDecorated $ + hsep [ text "Duplicate field name" + , quotes (ppr (rdrNameOcc $ NE.head dups)) + , text "in record", pprRecordFieldPart fld_part ] + TcRnIllegalViewPattern pat + -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat] + TcRnCharLiteralOutOfRange c + -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' + TcRnIllegalWildcardsInConstructor con + -> mkSimpleDecorated $ + vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.") + , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.") + ] + TcRnIgnoringAnnotations anns + -> mkSimpleDecorated $ + text "Ignoring ANN annotation" <> plural anns <> comma + <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi" + TcRnAnnotationInSafeHaskell + -> mkSimpleDecorated $ + vcat [ text "Annotations are not compatible with Safe Haskell." + , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] + TcRnInvalidTypeApplication fun_ty hs_ty + -> mkSimpleDecorated $ + text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$ + text "to a visible type argument" <+> quotes (ppr hs_ty) + TcRnTagToEnumMissingValArg + -> mkSimpleDecorated $ + text "tagToEnum# must appear applied to one value argument" + TcRnTagToEnumUnspecifiedResTy ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (vcat [ text "Specify the type by giving a type signature" + , text "e.g. (tagToEnum# x) :: Bool" ]) + TcRnTagToEnumResTyNotAnEnum ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type must be an enumeration type") + TcRnTagToEnumResTyTypeData ty + -> mkSimpleDecorated $ + hang (text "Bad call to tagToEnum# at type" <+> ppr ty) + 2 (text "Result type cannot be headed by a `type data` type") + TcRnArrowIfThenElsePredDependsOnResultTy + -> mkSimpleDecorated $ + text "Predicate type of `ifThenElse' depends on result type" + TcRnIllegalHsBootOrSigDecl boot_or_sig decls + -> mkSimpleDecorated $ + text "Illegal" <+> what <+> text "in" <+> whr <> dot + where + what = case decls of + BootBindsPs {} -> text "binding" + BootBindsRn {} -> text "binding" + BootInstanceSigs {} -> text "instance body" + BootFamInst {} -> text "family instance" + BootSpliceDecls {} -> text "splice" + BootForeignDecls {} -> text "foreign declaration" + BootDefaultDecls {} -> text "default declaration" + BootRuleDecls {} -> text "RULE pragma" + whr = case boot_or_sig of + HsBoot -> text "an hs-boot file" + Hsig -> text "a backpack signature file" + TcRnBootMismatch boot_or_sig err -> + mkSimpleDecorated $ pprBootMismatch boot_or_sig err + TcRnRecursivePatternSynonym binds + -> mkSimpleDecorated $ + hang (text "Recursive pattern synonym definition with following bindings:") + 2 (vcat $ map pprLBind binds) + where + pprLoc loc = parens (text "defined at" <+> ppr loc) + pprLBind :: CollectPass GhcRn => GenLocated (EpAnn a) (HsBindLR GhcRn idR) -> SDoc + pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) + <+> pprLoc (locA loc) + TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty + -> mkSimpleDecorated $ + hang (text "Couldn't match" <+> quotes (ppr n1) + <+> text "with" <+> quotes (ppr n2)) + 2 (hang (text "both bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty)) + TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty + -> mkSimpleDecorated $ + hang (text "Can't quantify over" <+> quotes (ppr n)) + 2 (vcat [ hang (text "bound by the partial type signature:") + 2 (ppr fn_name <+> dcolon <+> ppr hs_ty) + , extra ]) + where + extra | Just rhs_ty <- m_unif_ty + = sep [ quotes (ppr n), text "should really be", quotes (ppr rhs_ty) ] + | otherwise + = empty + TcRnMissingSignature what _ -> + mkSimpleDecorated $ + case what of + MissingPatSynSig p -> + hang (text "Pattern synonym with no type signature:") + 2 (text "pattern" <+> pprPrefixName (patSynName p) <+> dcolon <+> pprPatSynType p) + MissingTopLevelBindingSig name ty -> + hang (text "Top-level binding with no type signature:") + 2 (pprPrefixName name <+> dcolon <+> pprSigmaType ty) + MissingTyConKindSig tc cusks_enabled -> + hang msg + 2 (text "type" <+> pprPrefixName (tyConName tc) <+> dcolon <+> pprKind (tyConKind tc)) + where + msg | cusks_enabled + = text "Top-level type constructor with no standalone kind signature or CUSK:" + | otherwise + = text "Top-level type constructor with no standalone kind signature:" + + TcRnPolymorphicBinderMissingSig n ty + -> mkSimpleDecorated $ + sep [ text "Polymorphic local binding with no type signature:" + , nest 2 $ pprPrefixName n <+> dcolon <+> ppr ty ] + TcRnOverloadedSig sig + -> mkSimpleDecorated $ + hang (text "Overloaded signature conflicts with monomorphism restriction") + 2 (ppr sig) + TcRnTupleConstraintInst _ + -> mkSimpleDecorated $ text "You can't specify an instance for a tuple constraint" + TcRnUserTypeError ty + -> mkSimpleDecorated (pprUserTypeErrorTy ty) + TcRnConstraintInKind ty + -> mkSimpleDecorated $ + text "Illegal constraint in a kind:" <+> pprType ty + TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum ty + -> mkSimpleDecorated $ + sep [ text "Illegal unboxed" <+> what <+> text "type as function argument:" + , pprType ty ] + where + what = case tuple_or_sum of + UnboxedTupleType -> text "tuple" + UnboxedSumType -> text "sum" + TcRnLinearFuncInKind ty + -> mkSimpleDecorated $ + text "Illegal linear function in a kind:" <+> pprType ty + TcRnForAllEscapeError ty kind + -> mkSimpleDecorated $ vcat + [ hang (text "Quantified type's kind mentions quantified type variable") + 2 (text "type:" <+> quotes (ppr ty)) + , hang (text "where the body of the forall has this kind:") + 2 (quotes (pprKind kind)) ] + TcRnSimplifiableConstraint pred what + -> mkSimpleDecorated $ vcat + [ hang (text "The constraint" <+> quotes (pprType pred) <+> text "matches") + 2 (ppr what) + , hang (text "This makes type inference for inner bindings fragile;") + 2 (text "either use MonoLocalBinds, or simplify it using the instance") ] + TcRnArityMismatch thing thing_arity nb_args + -> mkSimpleDecorated $ + hsep [ text "The" <+> what, quotes (ppr $ getName thing), text "should have" + , n_arguments <> comma, text "but has been given" + , if nb_args == 0 then text "none" else int nb_args + ] + where + what = case thing of + ATyCon tc -> ppr (tyConFlavour tc) + _ -> text (tyThingCategory thing) + n_arguments | thing_arity == 0 = text "no arguments" + | thing_arity == 1 = text "1 argument" + | True = hsep [int thing_arity, text "arguments"] + TcRnIllegalInstance reason -> + mkSimpleDecorated $ pprIllegalInstance reason + TcRnVDQInTermType mb_ty + -> mkSimpleDecorated $ + case mb_ty of + Nothing -> main_msg + Just ty -> hang (main_msg <> char ':') 2 (pprType ty) + where + main_msg = + text "Illegal visible, dependent quantification" <+> + text "in the type of a term" + TcRnBadQuantPredHead ty + -> mkSimpleDecorated $ + hang (text "Quantified predicate must have a class or type variable head:") + 2 (pprType ty) + TcRnIllegalTupleConstraint ty + -> mkSimpleDecorated $ + text "Illegal tuple constraint:" <+> pprType ty + TcRnNonTypeVarArgInConstraint ty + -> mkSimpleDecorated $ + hang (text "Non type-variable argument") + 2 (text "in the constraint:" <+> pprType ty) + TcRnIllegalImplicitParam ty + -> mkSimpleDecorated $ + text "Illegal implicit parameter" <+> quotes (pprType ty) + TcRnIllegalConstraintSynonymOfKind kind + -> mkSimpleDecorated $ + text "Illegal constraint synonym of kind:" <+> quotes (pprKind kind) + TcRnOversaturatedVisibleKindArg ty + -> mkSimpleDecorated $ + text "Illegal oversaturated visible kind argument:" <+> + quotes (char '@' <> pprParendType ty) + TcRnForAllRankErr rank ty + -> let herald = case tcSplitForAllTyVars ty of + ([], _) -> text "Illegal qualified type:" + _ -> text "Illegal polymorphic type:" + extra = case rank of + MonoTypeConstraint -> text "A constraint must be a monotype" + _ -> empty + in mkSimpleDecorated $ vcat [hang herald 2 (pprType ty), extra] + TcRnMonomorphicBindings bindings + -> let pp_bndrs = pprBindings bindings + in mkSimpleDecorated $ + sep [ text "The Monomorphism Restriction applies to the binding" + <> plural bindings + , text "for" <+> pp_bndrs ] + TcRnOrphanInstance (Left cls_inst) + -> mkSimpleDecorated $ + hang (text "Orphan class instance:") + 2 (pprInstanceHdr cls_inst) + TcRnOrphanInstance (Right fam_inst) + -> mkSimpleDecorated $ + hang (text "Orphan family instance:") + 2 (pprFamInst fam_inst) + TcRnFunDepConflict unit_state sorted + -> let herald = text "Functional dependencies conflict between instance declarations:" + in mkSimpleDecorated $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) + TcRnDupInstanceDecls unit_state sorted + -> let herald = text "Duplicate instance declarations:" + in mkSimpleDecorated $ + pprWithUnitState unit_state $ (hang herald 2 (pprInstances $ NE.toList sorted)) + TcRnConflictingFamInstDecls sortedNE + -> let sorted = NE.toList sortedNE + in mkSimpleDecorated $ + hang (text "Conflicting family instance declarations:") + 2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax) + | fi <- sorted + , let ax = famInstAxiom fi ]) + TcRnFamInstNotInjective rea fam_tc (eqn1 NE.:| rest_eqns) + -> let (herald, show_kinds) = case rea of + InjErrRhsBareTyVar tys -> + (injectivityErrorHerald $$ + text "RHS of injective type family equation is a bare" <+> + text "type variable" $$ + text "but these LHS type and kind patterns are not bare" <+> + text "variables:" <+> pprQuotedList tys, False) + InjErrRhsCannotBeATypeFam -> + (injectivityErrorHerald $$ + text "RHS of injective type family equation cannot" <+> + text "be a type family:", False) + InjErrRhsOverlap -> + (text "Type family equation right-hand sides overlap; this violates" $$ + text "the family's injectivity annotation:", False) + InjErrCannotInferFromRhs tvs has_kinds _ -> + let show_kinds = has_kinds == YesHasKinds + what = if show_kinds then text "Type/kind" else text "Type" + body = sep [ what <+> text "variable" <> + pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort) + , text "cannot be inferred from the right-hand side." ] + in (injectivityErrorHerald $$ body $$ text "In the type family equation:", show_kinds) + + in mkSimpleDecorated $ pprWithInvisibleBitsWhen show_kinds $ + hang herald + 2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) + TcRnBangOnUnliftedType ty + -> mkSimpleDecorated $ + text "Strictness flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnLazyBangOnUnliftedType ty + -> mkSimpleDecorated $ + text "Lazy flag has no effect on unlifted type" <+> quotes (ppr ty) + TcRnMultipleDefaultDeclarations cls dup_things + -> mkSimpleDecorated $ + hang (text "Multiple default declarations for class" <+> quotes (ppr cls)) + 2 (pp dup_things) + where + pp :: ClassDefaults -> SDoc + pp (ClassDefaults { cd_provenance = prov }) + = case prov of + DP_Local { defaultDeclLoc = loc, defaultDeclH98 = isH98 } + -> let + what = + if isH98 + then text "default declaration" + else text "named default declaration" + in text "conflicting" <+> what <+> text "at:" <+> ppr loc + _ -> empty -- doesn't happen, as local defaults override imported and built-in defaults + TcRnBadDefaultType ty deflt_clss + -> mkSimpleDecorated $ + hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") + 2 (foldr1 (\a b -> a <+> text "or" <+> b) (NE.map (quotes. ppr) deflt_clss)) + TcRnPatSynBundledWithNonDataCon + -> mkSimpleDecorated $ + text "Pattern synonyms can be bundled only with datatypes." + TcRnPatSynBundledWithWrongType expected_res_ty res_ty + -> mkSimpleDecorated $ + text "Pattern synonyms can only be bundled with matching type constructors" + $$ text "Couldn't match expected type of" + <+> quotes (ppr expected_res_ty) + <+> text "with actual type of" + <+> quotes (ppr res_ty) + TcRnDupeModuleExport mod + -> mkSimpleDecorated $ + hsep [ text "Duplicate" + , quotes (text "Module" <+> ppr mod) + , text "in export list" ] + TcRnExportedModNotImported mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is not imported" + TcRnNullExportedModule mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "exports nothing" + TcRnMissingExportList mod + -> mkSimpleDecorated + $ formatExportItemError + (text "module" <+> ppr mod) + "is missing an export list" + TcRnExportHiddenComponents export_item + -> mkSimpleDecorated + $ formatExportItemError + (ppr export_item) + "attempts to export constructors or class methods that are not visible here" + TcRnExportHiddenDefault export_item + -> mkSimpleDecorated + $ formatExportItemError + (ppr export_item) + "attempts to export a default class declaration that is not visible here" + TcRnDuplicateExport gre ie1 ie2 + -> mkSimpleDecorated $ + hsep [ quotes (ppr $ greName gre) + , text "is exported by", quotes (ppr ie1) + , text "and", quotes (ppr ie2) ] + TcRnDuplicateNamedDefaultExport nm ie1 ie2 + -> mkSimpleDecorated $ + hsep [ text "The named default declaration for" <+> quotes (ppr nm) + , text "is exported by", quotes (ppr ie1) + , text "and", quotes (ppr ie2) ] + TcRnExportedParentChildMismatch parent_name ty_thing child parent_names + -> mkSimpleDecorated $ + text "The type constructor" <+> quotes (ppr parent_name) + <+> text "is not the parent of the" <+> text what_is + <+> quotes thing <> char '.' + $$ text (capitalise what_is) + <> text "s can only be exported with their parent type constructor." + $$ (case parents of + [] -> empty + [_] -> text "Parent:" + _ -> text "Parents:") <+> fsep (punctuate comma parents) + where + pp_category :: TyThing -> String + pp_category (AnId i) + | isRecordSelector i = "record selector" + pp_category i = tyThingCategory i + what_is = pp_category ty_thing + thing = ppr $ nameOccName child + parents = map ppr parent_names + TcRnConflictingExports occ child_gre1 ie1 child_gre2 ie2 + -> mkSimpleDecorated $ + vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon + , ppr_export child_gre1 ie1 + , ppr_export child_gre2 ie2 + ] + where + ppr_export gre ie = + nest 3 $ + hang (quotes (ppr ie) <+> text "exports" <+> quotes (ppr $ greName gre)) + 2 (pprNameProvenance gre) + TcRnDuplicateFieldExport (gre, ie1) gres_ies -> + mkSimpleDecorated $ + vcat ( hsep [ text "Duplicate record field" + , quotes (ppr $ greOccName gre) + , text "in export list" <> colon ] + : map ppr_export ((gre,ie1) : NE.toList gres_ies) + ) + where + ppr_export (gre,ie) = + nest 3 $ + hang (sep [ quotes (ppr ie) <+> text "exports the field" <+> quotes (ppr $ greName gre) + , text "belonging to the constructor" <> plural fld_cons <+> pprQuotedList fld_cons ]) + 2 (pprNameProvenance gre) + where + fld_cons :: [ConLikeName] + fld_cons = nonDetEltsUniqSet $ recFieldCons $ fieldGREInfo gre + TcRnAmbiguousFieldInUpdate (gre1, gre2, gres) + -> mkSimpleDecorated $ + vcat [ text "Ambiguous record field" <+> fld <> dot + , hang (text "It could refer to any of the following:") + 2 $ vcat (map pprSugg (gre1 : gre2 : gres)) + ] + where + fld = quotes $ ppr (occNameFS $ greOccName gre1) + pprSugg gre = vcat [ bullet <+> pprGRE gre <> comma + , nest 2 (pprNameProvenance gre) ] + pprGRE gre = case greInfo gre of + IAmRecField {} + | ParentIs { par_is = parent } <- greParent gre + -> text "record field" <+> fld <+> text "of" <+> quotes (ppr parent) + _ -> text "variable" <+> fld + TcRnAmbiguousRecordUpdate _rupd tc + -> mkSimpleDecorated $ + vcat [ text "Ambiguous record update with parent" <+> what <> dot + , hsep [ text "This type-directed disambiguation mechanism" + , text "will not be supported by -XDuplicateRecordFields in future releases of GHC." ] + , text "Consider disambiguating using module qualification instead." + ] + where + what :: SDoc + what = text "type constructor" <+> quotes (ppr $ RecSelData tc) + TcRnMissingFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty + | otherwise = vcat (fmap pprField fields) + header = text "Fields of" <+> quotes (ppr con) <+> + text "not initialised" <> + if null fields then empty else colon + TcRnFieldUpdateInvalidType prs + -> mkSimpleDecorated $ + hang (text "Record update for insufficiently polymorphic field" + <> plural prs <> colon) + 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ]) + TcRnMissingStrictFields con fields + -> mkSimpleDecorated $ vcat [header, nest 2 rest] + where + rest | null fields = empty -- Happens for non-record constructors + -- with strict fields + | otherwise = vcat (fmap pprField fields) + + header = text "Constructor" <+> quotes (ppr con) <+> + text "does not have the required strict field(s)" <> + if null fields then empty else colon + TcRnBadRecordUpdate upd_flds reason + -> case reason of + NoConstructorHasAllFields { conflictingFields = conflicts } + | [fld] <- conflicts + -> mkSimpleDecorated $ + vcat [ header + , text "No constructor in scope has the field" <+> quotes (ppr fld) ] + | otherwise + -> + mkSimpleDecorated $ + vcat [ header + , hang (text "No constructor in scope has all of the following fields:") + 2 (pprQuotedList conflicts) ] + where + header :: SDoc + header = text "Invalid record update." + MultiplePossibleParents (par1, par2, pars) -> + mkSimpleDecorated $ + vcat [ hang (text "Ambiguous record update with field" <> plural upd_flds) + 2 ppr_flds + , hang (thisOrThese upd_flds <+> text "field" <> plural upd_flds <+> what_parent) + 2 (quotedListWithAnd (map ppr (par1:par2:pars))) ] + where + ppr_flds, what_parent, which :: SDoc + ppr_flds = quotedListWithAnd $ map ppr upd_flds + what_parent = case par1 of + RecSelData {} -> text "appear" <> singular upd_flds + <+> text "in" <+> which <+> text "datatypes" + RecSelPatSyn {} -> isOrAre upd_flds <+> text "associated with" + <+> which <+> text "pattern synonyms" + which = case pars of + [] -> text "both" + _ -> text "all of the" + InvalidTyConParent tc pars -> + mkSimpleDecorated $ + vcat [ hang (text "No data constructor of" <+> what $$ text "has all of the fields:") + 2 (pprQuotedList upd_flds) + , pat_syn_msg ] + where + what = text "type constructor" <+> quotes (ppr (RecSelData tc)) + pat_syn_msg + | any (\case { RecSelPatSyn {} -> True; _ -> False}) pars + = note "Type-directed disambiguation is not supported for pattern synonym record fields" + | otherwise + = empty + TcRnStaticFormNotClosed name reason + -> mkSimpleDecorated $ + quotes (ppr name) + <+> text "is used in a static form but it is not closed" + <+> text "because it" + $$ sep (causes reason) + where + causes :: NotClosedReason -> [SDoc] + causes NotLetBoundReason = [text "is not let-bound."] + causes (NotTypeClosed vs) = + [ text "has a non-closed type because it contains the" + , text "type variables:" <+> + pprVarSet vs (hsep . punctuate comma . map (quotes . ppr)) + ] + causes (NotClosed n reason) = + let msg = text "uses" <+> quotes (ppr n) <+> text "which" + in case reason of + NotClosed _ _ -> msg : causes reason + _ -> let (xs0, xs1) = splitAt 1 $ causes reason + in fmap (msg <+>) xs0 ++ xs1 + TcRnUselessTypeable + -> mkSimpleDecorated $ + text "Deriving" <+> quotes (ppr typeableClassName) <+> + text "has no effect: all types now auto-derive Typeable" + TcRnDerivingDefaults cls + -> mkSimpleDecorated $ sep + [ text "Both DeriveAnyClass and" + <+> text "GeneralizedNewtypeDeriving are enabled" + , text "Defaulting to the DeriveAnyClass strategy" + <+> text "for instantiating" <+> ppr cls + ] + TcRnNonUnaryTypeclassConstraint ctxt ct + -> mkSimpleDecorated $ + quotes (ppr ct) + <+> text "is not a unary constraint, as expected by" + <+> pprUserTypeCtxt ctxt + TcRnPartialTypeSignatures _ theta + -> mkSimpleDecorated $ + text "Found type wildcard" <+> quotes (char '_') + <+> text "standing for" <+> quotes (pprTheta theta) + TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason + -> mkSimpleDecorated $ + derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason + TcRnLookupInstance cls tys reason + -> mkSimpleDecorated $ + text "Couldn't match instance:" <+> + lookupInstanceErrDiagnosticMessage cls tys reason + TcRnLazyGADTPattern + -> mkSimpleDecorated $ + hang (text "An existential or GADT data constructor cannot be used") + 2 (text "inside a lazy (~) pattern") + TcRnArrowProcGADTPattern + -> mkSimpleDecorated $ + text "Proc patterns cannot use existential or GADT data constructors" + TcRnTypeEqualityOutOfScope + -> mkDecorated + [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$ + text "Assuming it to stand for an equality constraint." + , note $ quotes "~" <+> "used to be built-in syntax but now is a regular type operator" $$ + "exported from Data.Type.Equality and Prelude." $$ + "If you are using a custom Prelude, consider re-exporting it" + , text "This will become an error in a future GHC release." ] + TcRnTypeEqualityRequiresOperators + -> mkSimpleDecorated $ + fsep [ text "The use of" <+> quotes (text "~") + <+> text "without TypeOperators", + text "will become an error in a future GHC release." ] + TcRnIllegalTypeOperator overall_ty op + -> mkSimpleDecorated $ + text "Illegal operator" <+> quotes (ppr op) <+> + text "in type" <+> quotes (ppr overall_ty) + TcRnIllegalTypeOperatorDecl name + -> mkSimpleDecorated $ + text "Illegal declaration of a type or class operator" <+> quotes (ppr name) + TcRnGADTMonoLocalBinds + -> mkSimpleDecorated $ + fsep [ text "Pattern matching on GADTs without MonoLocalBinds" + , text "is fragile." ] + TcRnIncorrectNameSpace name _in_th_tick + -> mkSimpleDecorated $ + text "The" <+> what <+> text "does not live in" <+> other_ns + where + -- the other (opposite) namespace + other_ns | isValNameSpace ns = text "the type-level namespace" + | otherwise = text "the term-level namespace" + ns = nameNameSpace name + what = pprNameSpace ns <+> quotes (ppr name) + TcRnNotInScope err name + -> mkSimpleDecorated $ pprScopeError name err + TcRnTermNameInType name + -> mkSimpleDecorated $ + quotes (ppr name) <+> + (text "is a term-level binding") $+$ + (text " and can not be used at the type level.") + TcRnUntickedPromotedThing thing + -> mkSimpleDecorated $ + text "Unticked promoted" <+> what + where + what :: SDoc + what = case thing of + UntickedExplicitList -> text "list" <> dot + UntickedConstructor fixity nm -> + let con = pprUntickedConstructor fixity nm + bare_sym = isBareSymbol fixity nm + in text "constructor:" <+> con <> if bare_sym then empty else dot + TcRnIllegalBuiltinSyntax sig rdr_name + -> mkSimpleDecorated $ + hsep [text "Illegal", pprSigLike sig, text "of built-in syntax:", ppr rdr_name] + TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + -> mkSimpleDecorated $ + hang (hsep $ [ text "Defaulting" ] + ++ + (case tidy_tv of + Nothing -> [] + Just tv -> [text "the type variable" + , quotes (ppr tv)]) + ++ + [ text "to type" + , quotes (ppr default_ty) + , text "in the following constraint" <> plural tidy_wanteds ]) + 2 + (pprWithArising tidy_wanteds) + TcRnWarnClashingDefaultImports cls Nothing imports + -> mkSimpleDecorated $ + hang (text "Clashing imported defaults for class" <+> quotes (ppr cls) <> colon) + 2 (vcat $ defaultTypesAndImport <$> NE.toList imports) + TcRnWarnClashingDefaultImports cls (Just local) imports + -> mkSimpleDecorated $ + sep [ hang (text "Imported defaults for class" <+> quotes (ppr cls) <> colon) + 2 (vcat $ defaultTypesAndImport <$> NE.toList imports) + , hang (text "are not subsumed by the local `default` declaration") + 2 (parens $ pprWithCommas ppr local) + ] + + TcRnForeignImportPrimExtNotSet _decl + -> mkSimpleDecorated $ + text "`foreign import prim' requires GHCForeignImportPrim." + + TcRnForeignImportPrimSafeAnn _decl + -> mkSimpleDecorated $ + text "The safe/unsafe annotation should not be used with `foreign import prim'." + + TcRnForeignFunctionImportAsValue _decl + -> mkSimpleDecorated $ + text "`value' imports cannot have function types" + + TcRnFunPtrImportWithoutAmpersand _decl + -> mkSimpleDecorated $ + text "possible missing & in foreign import of FunPtr" + + TcRnIllegalForeignDeclBackend _decl _backend expectedBknds + -> mkSimpleDecorated $ + fsep (text "Illegal foreign declaration: requires one of these back ends:" : + commafyWith (text "or") (map (text . backendDescription) expectedBknds)) + + TcRnUnsupportedCallConv _decl unsupportedCC + -> mkSimpleDecorated $ + case unsupportedCC of + StdCallConvUnsupported -> + text "the 'stdcall' calling convention is unsupported on this platform," + $$ text "treating as ccall" + PrimCallConvUnsupported -> + text "The `prim' calling convention can only be used with `foreign import'" + JavaScriptCallConvUnsupported -> + text "The `javascript' calling convention is unsupported on this platform" + + TcRnIllegalForeignType mArgOrResult reason + -> mkSimpleDecorated $ hang msg 2 extra + where + arg_or_res = case mArgOrResult of + Nothing -> empty + Just Arg -> text "argument" + Just Result -> text "result" + msg = hsep [ text "Unacceptable", arg_or_res + , text "type in foreign declaration:"] + extra = + case reason of + TypeCannotBeMarshaled ty why -> + let innerMsg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" + in case why of + NotADataType -> + quotes (ppr ty) <+> text "is not a data type" + NewtypeDataConNotInScope _ [] -> + hang innerMsg 2 $ text "because its data constructor is not in scope" + NewtypeDataConNotInScope tc _ -> + hang innerMsg 2 $ + text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + UnliftedFFITypesNeeded -> + innerMsg $$ text "UnliftedFFITypes is required to marshal unlifted types" + NotABoxedMarshalableTyCon -> innerMsg + ForeignLabelNotAPtr -> + innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)" + NotSimpleUnliftedType -> + innerMsg $$ text "foreign import prim only accepts simple unlifted types" + NotBoxedKindAny -> + text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$ + text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty)) + ForeignDynNotPtr expected ty -> + vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text " Actual:" <+> ppr ty ] + SafeHaskellMustBeInIO -> + text "Safe Haskell is on, all FFI imports must be in the IO monad" + IOResultExpected -> + text "IO result type expected" + UnexpectedNestedForall -> + text "Unexpected nested forall" + LinearTypesNotAllowed -> + text "Linear types are not supported in FFI declarations, see #18472" + OneArgExpected -> + text "One argument expected" + AtLeastOneArgExpected -> + text "At least one argument expected" + TcRnInvalidCIdentifier target + -> mkSimpleDecorated $ + sep [quotes (ppr target) <+> text "is not a valid C identifier"] + TcRnExpectedValueId thing + -> mkSimpleDecorated $ + ppr thing <+> text "used where a value identifier was expected" + TcRnRecSelectorEscapedTyVar lbl + -> mkSimpleDecorated $ + text "Cannot use record selector" <+> quotes (ppr lbl) <+> + text "as a function due to escaped type variables" + TcRnPatSynNotBidirectional name + -> mkSimpleDecorated $ + text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" + TcRnIllegalDerivingItem hs_ty + -> mkSimpleDecorated $ + text "Illegal deriving item" <+> quotes (ppr hs_ty) + TcRnIllegalDefaultClass nm + -> mkSimpleDecorated $ + text "Illegal named default declaration for non-class" <+> quotes (ppr nm) + TcRnIllegalNamedDefault hs_decl + -> mkSimpleDecorated $ text "Illegal named default declaration" <+> quotes (ppr hs_decl) + TcRnUnexpectedAnnotation ty bang + -> mkSimpleDecorated $ + let err = case bang of + HsSrcBang _ SrcUnpack _ -> "UNPACK" + HsSrcBang _ SrcNoUnpack _ -> "NOUNPACK" + HsSrcBang _ NoSrcUnpack SrcLazy -> "laziness (~)" + HsSrcBang _ _ _ -> "strictness (!)" + in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ + text err <+> text "annotation can only appear on the arguments of a data constructor type" + TcRnIllegalRecordSyntax ty + -> mkSimpleDecorated $ + text "Record syntax is illegal here:" <+> ppr ty + + TcRnInvalidVisibleKindArgument arg ty + -> mkSimpleDecorated $ + text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + TcRnTooManyBinders ki bndrs + -> mkSimpleDecorated $ + hang (text "Not a function kind:") + 4 (ppr ki) $$ + hang (text "but extra binders found:") + 4 (fsep (map ppr bndrs)) + TcRnDifferentNamesForTyVar n1 n2 + -> mkSimpleDecorated $ + hang (text "Different names for the same type variable:") 2 info + where + info | nameOccName n1 /= nameOccName n2 + = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2) + | otherwise -- Same OccNames! See C2 in + -- Note [Swizzling the tyvars before generaliseTcTyCon] + = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) + , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + + TcRnDisconnectedTyVar n + -> mkSimpleDecorated $ + hang (text "Scoped type variable only appears non-injectively in declaration header:") + 2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n)) + + TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext + -> mkSimpleDecorated $ + sep [ ppDataSort data_sort <+> + text "has non-" <> + allowed_kind_tycon + , (if is_data_family then text "and non-variable" else empty) <+> + text "return kind" <+> quotes (ppr kind) + ] + where + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + allowed_kind_tycon = + case allowed_kind of + AnyTYPEKind -> ppr tYPETyCon + AnyBoxedKind -> ppr boxedRepDataConTyCon + LiftedKind -> ppr liftedTypeKind + TcRnClassKindNotConstraint _kind + -> mkSimpleDecorated $ + text "Kind signature on a class must end with" <+> ppr constraintKind $$ + text "unobscured by type families" + TcRnUnpromotableThing name err + -> mkSimpleDecorated $ + (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here") + 2 (parens reason)) + where + reason = case err of + ConstrainedDataConPE theta + -> text "it has an unpromotable context" + <+> quotes (pprTheta theta) + + FamDataConPE -> text "it comes from a data family instance" + PatSynPE -> text "pattern synonyms cannot be promoted" + RecDataConPE -> same_rec_group_msg + ClassPE -> same_rec_group_msg + TyConPE -> same_rec_group_msg + TermVariablePE -> text "term variables cannot be promoted" + TypeVariablePE -> text "type variables bound in a kind signature cannot be used in the type" + same_rec_group_msg = text "it is defined and used in the same recursive group" + TcRnIllegalTermLevelUse simple_msg rdr name err + -> mkSimpleDecorated $ + if simple_msg + then + vcat [ expecting_what <+> text "out of scope:" <+> quotes (ppr rdr) <> dot + , "NB: the" <+> text (teCategory err) <+> quotes (ppr qnm) <+> "cannot appear in this position." + ] + else + text "Illegal term-level use of the" <+> + text (teCategory err) <+> quotes (ppr qnm) + where + expecting_what = case err of + TyVarTE -> "Term variable" + ClassTE -> "Data constructor" + TyConTE -> "Data constructor" + qnm = WithUserRdr rdr name + TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches) + -> mkSimpleDecorated $ + (vcat [ pprMatchContextNouns argsContext <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLocA match1)) + , nest 2 (ppr (getLocA (NE.head bad_matches)))]) + TcRnCannotBindScopedTyVarInPatSig sig_tvs + -> mkSimpleDecorated $ + hang (text "You cannot bind scoped type variable" + <> plural (NE.toList sig_tvs) + <+> pprQuotedList (map fst $ NE.toList sig_tvs)) + 2 (text "in a pattern binding signature") + TcRnCannotBindTyVarsInPatBind _offenders + -> mkSimpleDecorated $ + text "Binding type variables is not allowed in pattern bindings" + TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags + -> mkSimpleDecorated $ + hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (fst_inl_prag : NE.toList inl_prags))) + where + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) + TcRnUnexpectedPragmas poly_id bad_sigs + -> mkSimpleDecorated $ + hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs)) + TcRnNonOverloadedSpecialisePragma fun_name + -> mkSimpleDecorated $ + text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name) + TcRnSpecialiseNotVisible name + -> mkSimpleDecorated $ + text "You cannot SPECIALISE" <+> quotes (ppr name) + <+> text "because its definition is not visible in this module" + TcRnPragmaWarning + { pragma_warning_info = PragmaWarningInstance{pwarn_dfunid, pwarn_ctorig} + , pragma_warning_msg } + -> mkSimpleDecorated $ + sep [ hang (text "In the use of") + 2 (pprDFunId pwarn_dfunid) + , ppr pwarn_ctorig + , pprWarningTxtForMsg pragma_warning_msg + ] + TcRnPragmaWarning + { pragma_warning_info = PragmaWarningDefault{pwarn_class, pwarn_impmod} + , pragma_warning_msg } + -> mkSimpleDecorated $ + sep [ sep [ text "In the use of class" + <+> ppr pwarn_class + <+> text "defaults imported from" + <+> ppr pwarn_impmod <> colon ] + , pprWarningTxtForMsg pragma_warning_msg + ] + TcRnPragmaWarning {pragma_warning_info, pragma_warning_msg} + -> mkSimpleDecorated $ + sep [ sep [ text "In the use of" + <+> pprNonVarNameSpace (occNameSpace occ_name) + <+> quotes (ppr occ_name) + , parens imp_msg <> colon ] + , pprWarningTxtForMsg pragma_warning_msg ] + where + occ_name = pwarn_occname pragma_warning_info + imp_mod = pwarn_impmod pragma_warning_info + imp_msg = text "imported from" <+> ppr imp_mod <> extra + extra | PragmaWarningName {pwarn_declmod = decl_mod} <- pragma_warning_info + , imp_mod /= decl_mod = text ", but defined in" <+> ppr decl_mod + | otherwise = empty + TcRnDifferentExportWarnings name locs + -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages", + text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)] + TcRnIncompleteExportWarnings name locs + -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "will not have its export warned about", + text "missing export warning at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)] + TcRnIllegalHsigDefaultMethods name meths + -> mkSimpleDecorated $ + text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file" + TcRnHsigFixityMismatch real_thing real_fixity sig_fixity + -> + let ppr_fix f = ppr f <+> if f == defaultFixity then parens (text "default") else empty + in mkSimpleDecorated $ + vcat [ppr real_thing <+> text "has conflicting fixities in the module", + text "and its hsig file", + text "Main module:" <+> ppr_fix real_fixity, + text "Hsig file:" <+> ppr_fix sig_fixity] + TcRnHsigShapeMismatch (HsigShapeSortMismatch info1 info2) + -> mkSimpleDecorated $ + text "While merging export lists, could not combine" + <+> ppr info1 <+> text "with" <+> ppr info2 + <+> parens (text "one is a type, the other is a plain identifier") + TcRnHsigShapeMismatch (HsigShapeNotUnifiable name1 name2 notHere) + -> + let extra = if notHere + then text "Neither name variable originates from the current signature." + else empty + in mkSimpleDecorated $ + text "While merging export lists, could not unify" + <+> ppr name1 <+> text "with" <+> ppr name2 $$ extra + TcRnHsigMissingModuleExport occ unit_state impl_mod + -> mkSimpleDecorated $ + quotes (ppr occ) + <+> text "is exported by the hsig file, but not exported by the implementing module" + <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) + TcRnBadGenericMethod clas op + -> mkSimpleDecorated $ + hsep [text "Class", quotes (ppr clas), + text "has a generic-default signature without a binding", quotes (ppr op)] + TcRnWarningMinimalDefIncomplete mindef + -> mkSimpleDecorated $ + vcat [ text "The MINIMAL pragma does not require:" + , nest 2 (pprBooleanFormulaNice mindef) + , text "but there is no default implementation." ] + TcRnDefaultMethodForPragmaLacksBinding sel_id prag + -> mkSimpleDecorated $ + text "The" <+> hsSigDoc prag <+> text "for default method" + <+> quotes (ppr sel_id) + <+> text "lacks an accompanying binding" + TcRnIgnoreSpecialisePragmaOnDefMethod sel_name + -> mkSimpleDecorated $ + text "Ignoring SPECIALISE pragmas on default method" + <+> quotes (ppr sel_name) + TcRnBadMethodErr{badMethodErrClassName, badMethodErrMethodName} + -> mkSimpleDecorated $ + hsep [text "Class", quotes (ppr badMethodErrClassName), + text "does not have a method", quotes (ppr badMethodErrMethodName)] + TcRnIllegalTypeData + -> mkSimpleDecorated $ + text "Illegal type-level data declaration" + TcRnTypeDataForbids feature + -> mkSimpleDecorated $ + ppr feature <+> text "are not allowed in type data declarations." + + TcRnIllegalNewtype con show_linear_types reason + -> mkSimpleDecorated $ + vcat [msg, additional] + where + (msg,additional) = + case reason of + DoesNotHaveSingleField n_flds -> + (sep [ + text "A newtype constructor must have exactly one field", + nest 2 $ + text "but" <+> quotes (ppr con) <+> text "has" <+> speakN n_flds + ], + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + IsNonLinear -> + (text "A newtype constructor must be linear", + ppr con <+> dcolon <+> ppr (dataConDisplayType True con)) + IsGADT -> + (text "A newtype must not be a GADT", + ppr con <+> dcolon <+> pprWithInvisibleBitsWhen sneaky_eq_spec + (ppr $ dataConDisplayType show_linear_types con)) + HasConstructorContext -> + (text "A newtype constructor must not have a context in its type", + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + HasExistentialTyVar -> + (text "A newtype constructor must not have existential type variables", + ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + HasStrictnessAnnotation -> + (text "A newtype constructor must not have a strictness annotation", empty) + + -- Is the data con a "covert" GADT? See Note [isCovertGadtDataCon] + -- in GHC.Core.DataCon + sneaky_eq_spec = isCovertGadtDataCon con + TcRnOrPatBindsVariables bndrs -> mkSimpleDecorated $ + text "An or-pattern may not bind term or type variables such as" + <+> quotedListWithOr (map ppr (NE.toList bndrs)) + TcRnUnsatisfiedMinimalDef mindef + -> mkSimpleDecorated $ + vcat [text "No explicit implementation for" + ,nest 2 $ pprBooleanFormulaNice mindef + ] + TcRnMisplacedInstSig name hs_ty + -> mkSimpleDecorated $ + vcat [ hang (text "Illegal type signature in instance declaration:") + 2 (hang (pprPrefixName name) + 2 (dcolon <+> ppr hs_ty)) + ] + TcRnNoRebindableSyntaxRecordDot -> mkSimpleDecorated $ + text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + TcRnNoFieldPunsRecordDot -> mkSimpleDecorated $ + text "For this to work enable NamedFieldPuns" + TcRnIllegalStaticExpression e -> mkSimpleDecorated $ + text "Illegal static expression:" <+> ppr e + TcRnListComprehensionDuplicateBinding n -> mkSimpleDecorated $ + (text "Duplicate binding in parallel list comprehension for:" + <+> quotes (ppr n)) + TcRnEmptyStmtsGroup cause -> mkSimpleDecorated $ case cause of + EmptyStmtsGroupInParallelComp -> + text "Empty statement group in parallel comprehension" + EmptyStmtsGroupInTransformListComp -> + text "Empty statement group preceding 'group' or 'then'" + EmptyStmtsGroupInDoNotation ctxt -> + text "Empty" <+> pprHsDoFlavour ctxt + EmptyStmtsGroupInArrowNotation -> + text "Empty 'do' block in an arrow command" + TcRnLastStmtNotExpr ctxt (UnexpectedStatement stmt) -> + mkSimpleDecorated $ hang last_error 2 (ppr stmt) + where + last_error = + text "The last statement in" <+> pprAStmtContext ctxt + <+> text "must be an expression" + TcRnUnexpectedStatementInContext ctxt (UnexpectedStatement stmt) _ -> mkSimpleDecorated $ + sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" + , text "in" <+> pprAStmtContext ctxt ] + TcRnIllegalTupleSection -> mkSimpleDecorated $ + text "Illegal tuple section" + TcRnIllegalImplicitParameterBindings eBinds -> mkSimpleDecorated $ + either msg msg eBinds + where + msg binds = hang + (text "Implicit-parameter bindings illegal in an mdo expression") + 2 (ppr binds) + TcRnSectionWithoutParentheses expr -> mkSimpleDecorated $ + hang (text "A section must be enclosed in parentheses") + 2 (text "thus:" <+> (parens (ppr expr))) + TcRnMissingRoleAnnotation name roles -> mkSimpleDecorated $ + hang (text "Missing role annotation" <> colon) + 2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) + + TcRnIllformedTypePattern p + -> mkSimpleDecorated $ + hang (text "Ill-formed type pattern:") 2 (ppr p) + TcRnIllegalTypePattern + -> mkSimpleDecorated $ + text "Illegal type pattern." $$ + text "A type pattern must be checked against a visible forall." + TcRnIllformedTypeArgument e + -> mkSimpleDecorated $ + hang (text "Ill-formed type argument:") 2 (ppr e) + TcRnIllegalTypeExpr syntax -> mkSimpleDecorated $ + vcat [ text "Illegal" <+> pprTypeSyntaxName syntax + , text "Type syntax may only be used in a required type argument," + , text "i.e. to instantiate a visible forall." ] + + TcRnCapturedTermName tv_name shadowed_term_names + -> mkSimpleDecorated $ + text "The type variable" <+> quotes (ppr tv_name) <+> + text "is implicitly quantified," $+$ + text "even though another variable of the same name is in scope:" $+$ + nest 2 var_names $+$ + text "This is not compatible with the RequiredTypeArguments extension." + where + var_names = case shadowed_term_names of + Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names) + Right lcl_name -> quotes (ppr lcl_name) <+> text "defined at" + <+> ppr (nameSrcLoc lcl_name) + TcRnBindingOfExistingName name -> mkSimpleDecorated $ + text "Illegal binding of an existing name:" <+> ppr name + TcRnMultipleFixityDecls loc rdr_name -> mkSimpleDecorated $ + vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] + TcRnIllegalPatternSynonymDecl -> mkSimpleDecorated $ + text "Illegal pattern synonym declaration" + TcRnIllegalClassBinding dsort bind -> mkSimpleDecorated $ + vcat [ what <+> text "not allowed in" <+> decl_sort + , nest 2 (ppr bind) ] + where + decl_sort = case dsort of + ClassDeclSort -> text "class declaration:" + InstanceDeclSort -> text "instance declaration:" + what = case bind of + PatBind {} -> text "Pattern bindings (except simple variables)" + PatSynBind {} -> text "Pattern synonyms" + -- Associated pattern synonyms are not implemented yet + _ -> pprPanic "rnMethodBind" (ppr bind) + + TcRnOrphanCompletePragma -> mkSimpleDecorated $ + text "Orphan COMPLETE pragmas not supported" $$ + text "A COMPLETE pragma must mention at least one data constructor" $$ + text "or pattern synonym defined in the same module." + TcRnEmptyCase ctxt reason -> mkSimpleDecorated $ + case reason of + EmptyCaseWithoutFlag -> + text "Empty list of alternatives in" <+> pp_ctxt + EmptyCaseDisallowedCtxt -> + text "Empty list of alternatives is not allowed in" <+> pp_ctxt + EmptyCaseForall tvb -> + vcat [ text "Empty list of alternatives in" <+> pp_ctxt + , hang (text "checked against a forall-type:") + 2 (pprForAll [tvb] <+> text "...") + ] + where + pp_ctxt = case ctxt of + CaseAlt -> text "case expression" + LamAlt LamCase -> text "\\case expression" + LamAlt LamCases -> text "\\cases expression" + ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction" + ArrowMatchCtxt (ArrowLamAlt LamCase) -> text "\\case command" + ArrowMatchCtxt (ArrowLamAlt LamCases) -> text "\\cases command" + ArrowMatchCtxt ArrowCaseAlt -> text "case command" + ctxt -> text "(unexpected)" <+> pprMatchContextNoun ctxt + TcRnNonStdGuards (NonStandardGuards guards) -> mkSimpleDecorated $ + text "accepting non-standard pattern guards" $$ + nest 4 (interpp'SP guards) + TcRnDuplicateSigDecl pairs@((L _ name, sig) :| _) -> mkSimpleDecorated $ + vcat [ text "Duplicate" <+> what_it_is + <> text "s for" <+> quotes (ppr name) + , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest + $ map (getLocA . fst) + $ NE.toList pairs) + ] + where + what_it_is = hsSigDoc sig + TcRnMisplacedSigDecl sig -> mkSimpleDecorated $ + sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] + TcRnUnexpectedDefaultSig sig -> mkSimpleDecorated $ + hang (text "Unexpected default signature:") + 2 (ppr sig) + TcRnDuplicateMinimalSig sig1 sig2 otherSigs -> mkSimpleDecorated $ + vcat [ text "Multiple minimal complete definitions" + , text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ map getLocA sigs) + , text "Combine alternative minimal complete definitions with `|'" ] + where + sigs = sig1 : sig2 : otherSigs + TcRnSpecSigShape spec_e -> mkSimpleDecorated $ + hang (text "Illegal form of SPECIALISE pragma:") + 2 (ppr spec_e) + TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $ + text "Illegal standalone deriving declaration" + TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $ + sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + text "Forall'd variable" <+> quotes (ppr var) <+> + text "does not appear on left hand side"] + TcRnUnexpectedStandaloneKindSig -> mkSimpleDecorated $ + text "Illegal standalone kind signature" + TcRnIllegalRuleLhs errReason name lhs bad_e -> mkSimpleDecorated $ + sep [text "Rule" <+> pprRuleName name <> colon, + nest 2 (vcat [err, + text "in left-hand side:" <+> ppr lhs])] + $$ + text "LHS must be of form (f e1 .. en) where f is not forall'd" + where + err = case errReason of + UnboundVariable uv nis -> pprScopeError uv nis + IllegalExpression -> text "Illegal expression:" <+> ppr bad_e + TcRnRuleLhsEqualities ruleName _lhs cts -> mkSimpleDecorated $ + text "Discarding RULE" <+> doubleQuotes (ftext ruleName) <> dot + $$ + hang + (sep [ text "The LHS of this rule gave rise to equality constraints" + , text "that GHC was unable to quantify over:" ] + ) + 4 (pprWithArising $ NE.toList cts) + $$ + text "NB: this warning will become an error starting from GHC 9.18" + TcRnDuplicateRoleAnnot list -> mkSimpleDecorated $ + hang (text "Duplicate role annotations for" <+> + quotes (ppr $ roleAnnotDeclName first_decl) <> colon) + 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L _ first_decl) :| _) = sorted_list + + pp_role_annot (L loc decl) = hang (ppr decl) + 4 (text "-- written at" <+> ppr (locA loc)) + + cmp_loc = leftmost_smallest `on` getLocA + TcRnDuplicateKindSig list -> mkSimpleDecorated $ + hang (text "Duplicate standalone kind signatures for" <+> + quotes (ppr $ standaloneKindSigName first_decl) <> colon) + 2 (vcat $ map pp_kisig $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L _ first_decl) :| _) = sorted_list + + pp_kisig (L loc decl) = + hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) + + cmp_loc = leftmost_smallest `on` getLocA + TcRnIllegalDerivStrategy ds -> mkSimpleDecorated $ + text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + TcRnIllegalMultipleDerivClauses -> mkSimpleDecorated $ + text "Illegal use of multiple, consecutive deriving clauses" + TcRnNoDerivStratSpecified{} -> mkSimpleDecorated $ text + "No deriving strategy specified. Did you want stock, newtype, or anyclass?" + TcRnStupidThetaInGadt{} -> mkSimpleDecorated $ + vcat [text "No context is allowed on a GADT-style data declaration", + text "(You can put a context on each constructor, though.)"] + TcRnShadowedTyVarNameInFamResult resName -> mkSimpleDecorated $ + hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable" + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom -> mkSimpleDecorated $ + vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])] + TcRnUnknownTyVarsOnRhsOfInjCond errorVars -> mkSimpleDecorated $ + hsep [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] + TcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt _reason + -> pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt + TcRnBadlyLevelledType name bind_lvls use_lvl + -> mkSimpleDecorated $ + text "Badly levelled type:" <+> ppr name <+> + fsep [text "is bound at" <+> pprThBindLevel bind_lvls, + text "but used at level" <+> ppr use_lvl] + TcRnTyThingUsedWrong sort thing name + -> mkSimpleDecorated $ + pprTyThingUsedWrong sort thing name + TcRnCannotDefaultKindVar var knd -> + mkSimpleDecorated $ + (vcat [ text "Cannot default kind variable" <+> quotes (ppr var) + , text "of kind:" <+> ppr knd + , text "Perhaps enable PolyKinds or add a kind signature" ]) + TcRnUninferrableTyVar tidied_tvs context -> + mkSimpleDecorated $ + pprWithInvisibleBitsWhen True $ + vcat [ text "Uninferrable type variable" + <> plural tidied_tvs + <+> pprWithCommas pprTyVar tidied_tvs + <+> text "in" + , pprUninferrableTyVarCtx context ] + TcRnSkolemEscape escapees tv orig_ty -> + mkSimpleDecorated $ + pprWithInvisibleBitsWhen True $ + vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees + , quotes $ pprTyVars escapees + , text "would escape" <+> itsOrTheir escapees <+> text "scope" + ] + , sep [ text "if I tried to quantify" + , pprTyVar tv + , text "in this type:" + ] + , nest 2 (pprTidiedType orig_ty) + , text "(Indeed, I sometimes struggle even printing this correctly," + , text " due to its ill-scoped nature.)" + ] + TcRnPatSynEscapedCoercion arg bad_co_ne -> mkSimpleDecorated $ + vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" + , hang (text "Pattern-bound variable") + 2 (ppr arg <+> dcolon <+> ppr (idType arg)) + , nest 2 $ + hang (text "has a type that mentions pattern-bound coercion" + <> plural bad_co_list <> colon) + 2 (pprWithCommas ppr bad_co_list) + , text "Hint: use -fprint-explicit-coercions to see the coercions" + , text "Probable fix: add a pattern signature" ] + where + bad_co_list = NE.toList bad_co_ne + TcRnPatSynExistentialInResult name pat_ty bad_tvs -> mkSimpleDecorated $ + hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma + , text "namely" <+> quotes (ppr pat_ty) ]) + 2 (text "mentions existential type variable" <> plural bad_tvs + <+> pprQuotedList bad_tvs) + TcRnPatSynArityMismatch name decl_arity missing -> mkSimpleDecorated $ + hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" + <+> speakNOf decl_arity (text "argument")) + 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows") + TcRnPatSynInvalidRhs ps_name lpat _ reason -> mkSimpleDecorated $ + vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" + <+> quotes (ppr ps_name) <> colon) + 2 (pprPatSynInvalidRhsReason reason) + , text "RHS pattern:" <+> ppr lpat ] + TcRnTyFamDepsDisabled -> mkSimpleDecorated $ + text "Illegal injectivity annotation" + TcRnAbstractClosedTyFamDecl -> mkSimpleDecorated $ + text "You may define an abstract closed type family" $$ + text "only in a .hs-boot file" + TcRnPartialFieldSelector fld -> mkSimpleDecorated $ + vcat [ sep [ text "Definition of partial record field" <> colon + , nest 2 $ quotes (ppr (occName fld)) ] + , text "Record selection and update using this field will be partial." ] + TcRnHasFieldResolvedIncomplete name cons maxCons -> mkSimpleDecorated $ + hang (text "Selecting the record field" <+> quotes (ppr name) + <+> text "may fail for the following constructors:") + 2 + (hsep $ punctuate comma $ + map ppr (take maxCons cons) ++ [ text "..." | lengthExceeds cons maxCons ]) + TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $ + hang (pprBadFieldAnnotationReason reason) + 2 (text "on the" <+> speakNth n + <+> text "argument of" <+> quotes (ppr con)) + TcRnSuperclassCycle (MkSuperclassCycle cls definite details) -> + let herald | definite = text "Superclass cycle for" + | otherwise = text "Potential superclass cycle for" + in mkSimpleDecorated $ + vcat [ herald <+> quotes (ppr cls), nest 2 (vcat (pprSuperclassCycleDetail <$> details))] + TcRnDefaultSigMismatch sel_id dm_ty -> mkSimpleDecorated $ + hang (text "The default type signature for" + <+> ppr sel_id <> colon) + 2 (ppr dm_ty) + $$ (text "does not match its corresponding" + <+> text "non-default type signature") + TcRnTyFamsDisabled reason -> mkSimpleDecorated $ + text "Illegal family" <+> text sort <+> text "for" <+> quotes name + where + (sort, name) = case reason of + TyFamsDisabledFamily n -> ("declaration", ppr n) + TyFamsDisabledInstance n -> ("instance", ppr n) + TcRnBadTyConTelescope tc -> mkSimpleDecorated $ + vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") + 2 pp_tc_kind + , extra + , hang (text "Perhaps try this order instead:") + 2 (pprTyVars sorted_tvs) ] + where + pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc) + ppr_untidy ty = pprIfaceType (toIfaceType ty) + -- We need ppr_untidy here because pprType will tidy the type, which + -- will turn the bogus kind we are trying to report + -- T :: forall (a::k) k (b::k) -> blah + -- into a misleadingly sanitised version + -- T :: forall (a::k) k1 (b::k1) -> blah + + tcbs = tyConBinders tc + tvs = binderVars tcbs + sorted_tvs = scopedSort tvs + + inferred_tvs = [ binderVar tcb + | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] + specified_tvs = [ binderVar tcb + | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] + + extra + | null inferred_tvs && null specified_tvs + = empty + | null inferred_tvs + = note $ "Specified variables" <+> pp_spec <+> "always come first" + | null specified_tvs + = note inf_always_first + | otherwise + = note $ inf_always_first $$ + "then specified variables" <+> pp_spec + + inf_always_first = "Inferred variables" <+> pp_inf $$ "always come first" + + pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) + pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) + TcRnTyFamResultDisabled tc_name tvb -> mkSimpleDecorated $ + text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name) + TcRnRoleValidationFailed role reason -> mkSimpleDecorated $ + vcat [text "Internal error in role inference:", + pprRoleValidationFailedReason role reason, + text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] + TcRnCommonFieldResultTypeMismatch con1 con2 field_name -> mkSimpleDecorated $ + vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "have a common field" <+> quotes (ppr field_name) <> comma], + nest 2 $ text "but have different result types"] + TcRnCommonFieldTypeMismatch con1 con2 field_name -> mkSimpleDecorated $ + sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, + text "give different types for field", quotes (ppr field_name)] + TcRnClassExtensionDisabled cls reason -> mkSimpleDecorated $ + pprDisabledClassExtension cls reason + TcRnDataConParentTypeMismatch data_con res_ty_tmpl -> mkSimpleDecorated $ + hang (text "Data constructor" <+> quotes (ppr data_con) <+> + text "returns type" <+> quotes (ppr actual_res_ty)) + 2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl)) + where + actual_res_ty = dataConOrigResTy data_con + TcRnGADTsDisabled tc_name -> mkSimpleDecorated $ + text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) + TcRnExistentialQuantificationDisabled con -> mkSimpleDecorated $ + sdocOption sdocLinearTypes (\show_linear_types -> + hang (text "Data constructor" <+> quotes (ppr con) <+> + text "has existential type variables, a context, or a specialised result type") + 2 (ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))) + TcRnGADTDataContext tc_name -> mkSimpleDecorated $ + text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) + TcRnMultipleConForNewtype tycon n -> mkSimpleDecorated $ + sep [text "A newtype must have exactly one constructor,", + nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n] + TcRnKindSignaturesDisabled thing -> mkSimpleDecorated $ + text "Illegal kind signature" <+> quotes (either ppr with_sig thing) + where + with_sig (tc_name, ksig) = ppr tc_name <+> dcolon <+> ppr ksig + TcRnEmptyDataDeclsDisabled tycon -> mkSimpleDecorated $ + quotes (ppr tycon) <+> text "has no constructors" + TcRnRoleMismatch var annot inferred -> mkSimpleDecorated $ + hang (text "Role mismatch on variable" <+> ppr var <> colon) + 2 (sep [ text "Annotation says", ppr annot + , text "but role", ppr inferred + , text "is required" ]) + TcRnRoleCountMismatch tyvars d@(L _ (RoleAnnotDecl _ _ annots)) -> mkSimpleDecorated $ + hang (text "Wrong number of roles listed in role annotation;" $$ + text "Expected" <+> (ppr tyvars) <> comma <+> + text "got" <+> (ppr $ length annots) <> colon) + 2 (ppr d) + TcRnIllegalRoleAnnotation (RoleAnnotDecl _ tycon _) -> mkSimpleDecorated $ + (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ + text "they are allowed only for datatypes and classes.") + TcRnRoleAnnotationsDisabled tc -> mkSimpleDecorated $ + text "Illegal role annotation for" <+> ppr tc + TcRnIncoherentRoles _ -> mkSimpleDecorated $ + (text "Roles other than" <+> quotes (text "nominal") <+> + text "for class parameters can lead to incoherence.") + TcRnUnexpectedKindVar tv_name + -> mkSimpleDecorated $ text "Unexpected kind variable" <+> quotes (ppr tv_name) + + TcRnNegativeNumTypeLiteral tyLit + -> mkSimpleDecorated $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit + + TcRnIllegalKind ty_thing _ + -> mkSimpleDecorated $ text "Illegal kind:" <+> (ppr ty_thing) + + TcRnPrecedenceParsingError op1 op2 + -> mkSimpleDecorated $ + hang (text "Precedence parsing error") + 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", + ppr_opfix op2, + text "in the same infix expression"]) + + TcRnSectionPrecedenceError op arg_op section + -> mkSimpleDecorated $ + vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", + nest 4 (sep [text "must have lower precedence than that of the operand,", + nest 2 (text "namely" <+> ppr_opfix arg_op)]), + nest 4 (text "in the section:" <+> quotes (ppr section))] + + TcRnUnexpectedPatSigType ty + -> mkSimpleDecorated $ + hang (text "Illegal type signature:" <+> quotes (ppr ty)) + 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + + TcRnIllegalKindSignature ty + -> mkSimpleDecorated $ text "Illegal kind signature:" <+> quotes (ppr ty) + + TcRnUnusedQuantifiedTypeVar doc tyVar + -> mkSimpleDecorated $ + vcat [ text "Unused quantified type variable" <+> quotes (ppr tyVar) + , inHsDocContext doc ] + + TcRnDataKindsError typeOrKind thing + -> case thing of + Left renamer_thing -> + mkSimpleDecorated $ msg renamer_thing + Right typechecker_thing -> + mkSimpleDecorated $ msg typechecker_thing + where + msg :: Outputable a => a -> SDoc + msg thing = text "Illegal" <+> text (levelString typeOrKind) <> + colon <+> quotes (ppr thing) + + TcRnTypeSynonymCycle decl_or_tcs + -> mkSimpleDecorated $ + sep [ text "Cycle in type synonym declarations:" + , nest 2 (vcat (map ppr_decl decl_or_tcs)) ] + where + ppr_decl = \case + Right (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl + Left tc -> + let n = tyConName tc + in ppr (getSrcSpan n) <> colon <+> ppr (tyConName tc) + <+> text "from external module" + TcRnZonkerMessage err + -> mkSimpleDecorated $ pprZonkerMessage err + TcRnInterfaceError reason + -> diagnosticMessage (tcOptsIfaceOpts opts) reason + TcRnSelfImport imp_mod_name + -> mkSimpleDecorated $ + text "A module cannot import itself:" <+> ppr imp_mod_name + TcRnNoExplicitImportList mod + -> mkSimpleDecorated $ + text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" + TcRnSafeImportsDisabled _ + -> mkSimpleDecorated $ + text "safe import can't be used as Safe Haskell isn't on!" + TcRnDeprecatedModule mod txt + -> mkSimpleDecorated $ + sep [ text "Module" <+> quotes (ppr mod) <> text extra <> colon, + nest 2 (vcat (map (ppr . hsDocString . unLoc) msg)) ] + where + (extra, msg) = case txt of + WarningTxt _ _ msg -> ("", msg) + DeprecatedTxt _ msg -> (" is deprecated", msg) + TcRnRedundantSourceImport mod_name + -> mkSimpleDecorated $ + text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) + TcRnImportLookup reason + -> mkSimpleDecorated $ + pprImportLookup reason + TcRnUnusedImport decl reason + -> mkSimpleDecorated $ + pprUnusedImport decl reason + TcRnDuplicateDecls name sorted_names + -> mkSimpleDecorated $ + vcat [text "Multiple declarations of" <+> + quotes (ppr name), + -- NB. print the OccName, not the Name, because the + -- latter might not be in scope in the RdrEnv and so will + -- be printed qualified. + text "Declared at:" <+> + vcat (NE.toList $ ppr . nameSrcLoc <$> sorted_names)] + TcRnPackageImportsDisabled + -> mkSimpleDecorated $ + text "Package-qualified imports are not enabled" + TcRnIllegalDataCon name + -> mkSimpleDecorated $ + hsep [text "Illegal data constructor name", quotes (ppr name)] + TcRnNestedForallsContexts entity + -> mkSimpleDecorated $ + what <+> text "cannot contain nested" + <+> quotes forAllLit <> text "s or contexts" + where + what = case entity of + NFC_Specialize -> text "SPECIALISE instance type" + NFC_ViaType -> quotes (text "via") <+> text "type" + NFC_GadtConSig -> text "GADT constructor type signature" + NFC_InstanceHead -> text "Instance head" + NFC_StandaloneDerivedInstanceHead -> text "Standalone-derived instance head" + NFC_DerivedClassType -> text "Derived class type" + TcRnRedundantRecordWildcard + -> mkSimpleDecorated $ + text "Record wildcard does not bind any new variables" + TcRnUnusedRecordWildcard _ + -> mkSimpleDecorated $ + text "No variables bound in the record wildcard match are used" + TcRnUnusedName name reason + -> mkSimpleDecorated $ + pprUnusedName name reason + TcRnQualifiedBinder rdr_name + -> mkSimpleDecorated $ + text "Qualified name in binding position:" <+> ppr rdr_name + TcRnTypeApplicationsDisabled ty ty_or_ki + -> mkSimpleDecorated $ + text "Illegal visible" <+> what <+> text "application" <> colon + <+> ppr arg + where + arg = char '@' <> ppr ty + what = case ty_or_ki of + TypeLevel -> text "type" + KindLevel -> text "kind" + TcRnInvalidRecordField con field + -> mkSimpleDecorated $ + hsep [text "Constructor" <+> quotes (ppr con), + text "does not have field", quotes (ppr field)] + TcRnTupleTooLarge tup_size + -> mkSimpleDecorated $ + sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", + nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), + nest 2 (text "Workaround: use nested tuples or define a data type")] + TcRnCTupleTooLarge tup_size + -> mkSimpleDecorated $ + hang (text "Constraint tuple arity too large:" <+> int tup_size + <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE)) + 2 (text "Instead, use a nested tuple") + TcRnIllegalInferredTyVars _ + -> mkSimpleDecorated $ + text "Inferred type variables are not allowed" + TcRnAmbiguousName gre_env name gres + -> mkSimpleDecorated $ + vcat [ text "Ambiguous occurrence" <+> quotes (ppr name) <> dot + , text "It could refer to" + , nest 3 (vcat msgs) ] + where + np1 NE.:| nps = gres + msgs = punctuateFinal comma dot $ + text "either" <+> ppr_gre np1 + : [text " or" <+> ppr_gre np | np <- nps] + + ppr_gre gre = pprAmbiguousGreName gre_env gre + + TcRnBindingNameConflict name locs + -> mkSimpleDecorated $ + vcat [text "Conflicting definitions for" <+> quotes (ppr name), + locations] + where + locations = + text "Bound at:" + <+> vcat (map ppr (sortBy leftmost_smallest (NE.toList locs))) + TcRnNonCanonicalDefinition reason inst_ty + -> mkSimpleDecorated $ + pprNonCanonicalDefinition inst_ty reason + TcRnDefaultedExceptionContext ct_loc -> + mkSimpleDecorated $ vcat [ header, warning, proposal ] + where + header, warning, proposal :: SDoc + header + = vcat [ text "Solving for an implicit ExceptionContext constraint" + , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ] + warning + = vcat [ text "Future versions of GHC will turn this warning into an error." ] + proposal + = vcat [ text "See GHC Proposal #330." ] + TcRnImplicitImportOfPrelude + -> mkSimpleDecorated $ + text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported." + TcRnMissingMain explicit_export_list main_mod main_occ + -> mkSimpleDecorated $ + text "The" <+> ppMainFn main_occ + <+> text "is not" <+> defOrExp <+> text "module" + <+> quotes (ppr main_mod) + where + defOrExp :: SDoc + defOrExp | explicit_export_list = text "exported by" + | otherwise = text "defined in" + TcRnGhciUnliftedBind id + -> mkSimpleDecorated $ + sep [ text "GHCi can't bind a variable of unlifted type:" + , nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id)) ] + TcRnGhciMonadLookupFail ty lookups + -> mkSimpleDecorated $ + hang (text "Can't find type" <+> pp_ty <> dot $$ ambig_msg) + 2 (text "When checking that" <+> pp_ty <> + text "is a monad that can execute GHCi statements.") + where + pp_ty = quotes (text ty) + ambig_msg = case lookups of + Just (_:_:_) -> text "The type is ambiguous." + _ -> empty + TcRnIllegalQuasiQuotes -> mkSimpleDecorated $ + text "Quasi-quotes are not permitted without QuasiQuotes" + TcRnTHError err -> pprTHError err + TcRnPatersonCondFailure reason ctxt lhs rhs -> + mkSimpleDecorated $ pprPatersonCondFailure reason ctxt lhs rhs + TcRnIllegalInvisTyVarBndr bndr -> + mkSimpleDecorated $ + hang (text "Illegal invisible type variable binder:") + 2 (ppr bndr) + TcRnIllegalWildcardTyVarBndr bndr -> + mkSimpleDecorated $ + hang (text "Illegal wildcard binder:") + 2 (ppr bndr) + + TcRnInvalidInvisTyVarBndr name hs_bndr -> + mkSimpleDecorated $ + vcat [ hang (text "Invalid invisible type variable binder:") + 2 (ppr hs_bndr) + , text "There is no matching forall-bound variable" + , text "in the standalone kind signature for" <+> quotes (ppr name) <> dot + , note $ vcat [ + "Only" <+> quotes "forall a." <+> "-quantification matches invisible binders,", + "whereas" <+> quotes "forall {a}." <+> "and" <+> quotes "forall a ->" <+> "do not" + ]] + + TcRnInvisBndrWithoutSig _ hs_bndr -> + mkSimpleDecorated $ + vcat [ hang (text "Invalid invisible type variable binder:") + 2 (ppr hs_bndr) + , text "Either a standalone kind signature (SAKS)" + , text "or a complete user-supplied kind (CUSK, legacy feature)" + , text "is required to use invisible binders." ] + + TcRnImplicitRhsQuantification kv -> mkSimpleDecorated $ + vcat [ text "The variable" <+> quotes (ppr kv) <+> text "occurs free on the RHS of the type declaration" + , text "The next version of GHC will reject this program, no longer implicitly quantify over" <+> quotes (ppr kv) + ] + + TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs -> + mkSimpleDecorated $ + pprWithInvisibleBitsWhen True $ + vcat [ text "Invalid defaulting proposal." + , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon) + 2 (pprQuotedList (NE.toList bad_tvs)) + , hang (text "Defaulting proposal:") + 2 (ppr proposal) + , hang (text "Wanted constraints:") + 2 (pprQuotedList (map ctPred wanteds)) + ] + where + why + | _ :| [] <- bad_tvs + = text "it is not an unfilled metavariable" + | otherwise + = text "they are not unfilled metavariables" + + TcRnNamespacedWarningPragmaWithoutFlag warning@(Warning (kw, _) _ txt) -> mkSimpleDecorated $ + vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:" + , nest 2 (ppr warning) + , text "in a" <+> pragma_type <+> text "pragma" + ] + where + pragma_type = case txt of + WarningTxt{} -> text "WARNING" + DeprecatedTxt{} -> text "DEPRECATED" + + TcRnIllegalInvisibleTypePattern tp reason -> mkSimpleDecorated $ + vcat [ hang (text "Illegal invisible type pattern:") + 2 (char '@' <> ppr tp) + , case reason of + InvisPatWithoutFlag -> empty + InvisPatNoForall -> text "An invisible type pattern must be checked against a forall." + InvisPatMisplaced -> text "An invisible type pattern must occur in an argument position." + ] + + TcRnNamespacedFixitySigWithoutFlag sig@(FixitySig kw _ _) -> mkSimpleDecorated $ + vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:" + , nest 2 (ppr sig) + , text "in a fixity signature" + ] + + TcRnOutOfArityTyVar ts_name tv_name -> mkDecorated + [ vcat [ text "The arity of" <+> quotes (ppr ts_name) <+> text "is insufficiently high to accommodate" + , text "an implicit binding for the" <+> quotes (ppr tv_name) <+> text "type variable." ] + , suggestion ] + where + suggestion = + text "Use" <+> quotes at_bndr <+> text "on the LHS" <+> + text "or" <+> quotes forall_bndr <+> text "on the RHS" <+> + text "to bring it into scope." + at_bndr = char '@' <> ppr tv_name + forall_bndr = text "forall" <+> ppr tv_name <> text "." + + TcRnUnexpectedTypeSyntaxInTerms syntax -> mkSimpleDecorated $ + text "Unexpected" <+> pprTypeSyntaxName syntax + + diagnosticReason :: TcRnMessage -> DiagnosticReason + diagnosticReason = \case + TcRnUnknownMessage m + -> diagnosticReason m + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed _ m -> diagnosticReason m + TcRnWithHsDocContext _ msg + -> diagnosticReason msg + TcRnSolverReport _report reason + -> reason -- Error, or a Warning if we are deferring type errors + TcRnSolverDepthError {} + -> ErrorWithoutFlag + TcRnRedundantConstraints {} + -> WarningWithFlag Opt_WarnRedundantConstraints + TcRnInaccessibleCode {} + -> WarningWithFlag Opt_WarnInaccessibleCode + TcRnInaccessibleCoAxBranch {} + -> WarningWithFlag Opt_WarnInaccessibleCode + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> ErrorWithoutFlag + TcRnImplicitLift{} + -> WarningWithFlag Opt_WarnImplicitLift + TcRnUnusedPatternBinds{} + -> WarningWithFlag Opt_WarnUnusedPatternBinds + TcRnDodgyImports{} + -> WarningWithFlag Opt_WarnDodgyImports + TcRnDodgyExports{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingImportList{} + -> WarningWithFlag Opt_WarnMissingImportList + TcRnUnsafeDueToPlugin{} + -> WarningWithoutFlag + TcRnModMissingRealSrcSpan{} + -> ErrorWithoutFlag + TcRnIdNotExportedFromModuleSig{} + -> ErrorWithoutFlag + TcRnIdNotExportedFromLocalSig{} + -> ErrorWithoutFlag + TcRnShadowedName{} + -> WarningWithFlag Opt_WarnNameShadowing + TcRnInvalidWarningCategory{} + -> ErrorWithoutFlag + TcRnDuplicateWarningDecls{} + -> ErrorWithoutFlag + TcRnSimplifierTooManyIterations{} + -> ErrorWithoutFlag + TcRnIllegalPatSynDecl{} + -> ErrorWithoutFlag + TcRnLinearPatSyn{} + -> ErrorWithoutFlag + TcRnEmptyRecordUpdate + -> ErrorWithoutFlag + TcRnIllegalFieldPunning{} + -> ErrorWithoutFlag + TcRnIllegalWildcardsInRecord{} + -> ErrorWithoutFlag + TcRnIllegalWildcardInType{} + -> ErrorWithoutFlag + TcRnIllegalNamedWildcardInTypeArgument{} + -> ErrorWithoutFlag + TcRnIllegalImplicitTyVarInTypeArgument{} + -> ErrorWithoutFlag + TcRnIllegalPunnedVarOccInTypeArgument{} + -> ErrorWithoutFlag + TcRnDuplicateFieldName{} + -> ErrorWithoutFlag + TcRnIllegalViewPattern{} + -> ErrorWithoutFlag + TcRnCharLiteralOutOfRange{} + -> ErrorWithoutFlag + TcRnIllegalWildcardsInConstructor{} + -> ErrorWithoutFlag + TcRnIgnoringAnnotations{} + -> WarningWithoutFlag + TcRnAnnotationInSafeHaskell + -> ErrorWithoutFlag + TcRnInvalidTypeApplication{} + -> ErrorWithoutFlag + TcRnTagToEnumMissingValArg + -> ErrorWithoutFlag + TcRnTagToEnumUnspecifiedResTy{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyNotAnEnum{} + -> ErrorWithoutFlag + TcRnTagToEnumResTyTypeData{} + -> ErrorWithoutFlag + TcRnArrowIfThenElsePredDependsOnResultTy + -> ErrorWithoutFlag + TcRnIllegalHsBootOrSigDecl {} + -> ErrorWithoutFlag + TcRnBootMismatch {} + -> ErrorWithoutFlag + TcRnRecursivePatternSynonym{} + -> ErrorWithoutFlag + TcRnPartialTypeSigTyVarMismatch{} + -> ErrorWithoutFlag + TcRnPartialTypeSigBadQuantifier{} + -> ErrorWithoutFlag + TcRnMissingSignature what exported + -> WarningWithFlags $ missingSignatureWarningFlags what exported + TcRnPolymorphicBinderMissingSig{} + -> WarningWithFlag Opt_WarnMissingLocalSignatures + TcRnOverloadedSig{} + -> ErrorWithoutFlag + TcRnTupleConstraintInst{} + -> ErrorWithoutFlag + TcRnUserTypeError{} + -> ErrorWithoutFlag + TcRnConstraintInKind{} + -> ErrorWithoutFlag + TcRnUnboxedTupleOrSumTypeFuncArg{} + -> ErrorWithoutFlag + TcRnLinearFuncInKind{} + -> ErrorWithoutFlag + TcRnForAllEscapeError{} + -> ErrorWithoutFlag + TcRnSimplifiableConstraint{} + -> WarningWithFlag Opt_WarnSimplifiableClassConstraints + TcRnArityMismatch{} + -> ErrorWithoutFlag + TcRnIllegalInstance rea + -> illegalInstanceReason rea + TcRnVDQInTermType{} + -> ErrorWithoutFlag + TcRnBadQuantPredHead{} + -> ErrorWithoutFlag + TcRnIllegalTupleConstraint{} + -> ErrorWithoutFlag + TcRnNonTypeVarArgInConstraint{} + -> ErrorWithoutFlag + TcRnIllegalImplicitParam{} + -> ErrorWithoutFlag + TcRnIllegalConstraintSynonymOfKind{} + -> ErrorWithoutFlag + TcRnOversaturatedVisibleKindArg{} + -> ErrorWithoutFlag + TcRnForAllRankErr{} + -> ErrorWithoutFlag + TcRnMonomorphicBindings{} + -> WarningWithFlag Opt_WarnMonomorphism + TcRnOrphanInstance{} + -> WarningWithFlag Opt_WarnOrphans + TcRnFunDepConflict{} + -> ErrorWithoutFlag + TcRnDupInstanceDecls{} + -> ErrorWithoutFlag + TcRnConflictingFamInstDecls{} + -> ErrorWithoutFlag + TcRnFamInstNotInjective{} + -> ErrorWithoutFlag + TcRnBangOnUnliftedType{} + -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnLazyBangOnUnliftedType{} + -> WarningWithFlag Opt_WarnRedundantStrictnessFlags + TcRnMultipleDefaultDeclarations{} + -> ErrorWithoutFlag + TcRnBadDefaultType{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithNonDataCon{} + -> ErrorWithoutFlag + TcRnPatSynBundledWithWrongType{} + -> ErrorWithoutFlag + TcRnDupeModuleExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedModNotImported{} + -> ErrorWithoutFlag + TcRnNullExportedModule{} + -> WarningWithFlag Opt_WarnDodgyExports + TcRnMissingExportList{} + -> WarningWithFlag Opt_WarnMissingExportList + TcRnExportHiddenComponents{} + -> ErrorWithoutFlag + TcRnExportHiddenDefault{} + -> ErrorWithoutFlag + TcRnDuplicateExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnDuplicateNamedDefaultExport{} + -> WarningWithFlag Opt_WarnDuplicateExports + TcRnExportedParentChildMismatch{} + -> ErrorWithoutFlag + TcRnConflictingExports{} + -> ErrorWithoutFlag + TcRnDuplicateFieldExport {} + -> ErrorWithoutFlag + TcRnAmbiguousFieldInUpdate {} + -> ErrorWithoutFlag + TcRnAmbiguousRecordUpdate{} + -> WarningWithFlag Opt_WarnAmbiguousFields + TcRnMissingFields{} + -> WarningWithFlag Opt_WarnMissingFields + TcRnFieldUpdateInvalidType{} + -> ErrorWithoutFlag + TcRnMissingStrictFields{} + -> ErrorWithoutFlag + TcRnBadRecordUpdate{} + -> ErrorWithoutFlag + TcRnIllegalStaticExpression {} + -> ErrorWithoutFlag + TcRnStaticFormNotClosed{} + -> ErrorWithoutFlag + TcRnUselessTypeable + -> WarningWithFlag Opt_WarnDerivingTypeable + TcRnDerivingDefaults{} + -> WarningWithFlag Opt_WarnDerivingDefaults + TcRnNonUnaryTypeclassConstraint{} + -> ErrorWithoutFlag + TcRnPartialTypeSignatures{} + -> WarningWithFlag Opt_WarnPartialTypeSignatures + TcRnCannotDeriveInstance _ _ _ _ rea + -> case rea of + DerivErrNotWellKinded{} -> ErrorWithoutFlag + DerivErrSafeHaskellGenericInst -> ErrorWithoutFlag + DerivErrDerivingViaWrongKind{} -> ErrorWithoutFlag + DerivErrNoEtaReduce{} -> ErrorWithoutFlag + DerivErrBootFileFound -> ErrorWithoutFlag + DerivErrDataConsNotAllInScope{} -> ErrorWithoutFlag + DerivErrGNDUsedOnData -> ErrorWithoutFlag + DerivErrNullaryClasses -> ErrorWithoutFlag + DerivErrLastArgMustBeApp -> ErrorWithoutFlag + DerivErrNoFamilyInstance{} -> ErrorWithoutFlag + DerivErrNotStockDeriveable{} -> ErrorWithoutFlag + DerivErrHasAssociatedDatatypes{} -> ErrorWithoutFlag + DerivErrNewtypeNonDeriveableClass -> ErrorWithoutFlag + DerivErrCannotEtaReduceEnough{} -> ErrorWithoutFlag + DerivErrOnlyAnyClassDeriveable{} -> ErrorWithoutFlag + DerivErrNotDeriveable{} -> ErrorWithoutFlag + DerivErrNotAClass{} -> ErrorWithoutFlag + DerivErrNoConstructors{} -> ErrorWithoutFlag + DerivErrLangExtRequired{} -> ErrorWithoutFlag + DerivErrDunnoHowToDeriveForType{} -> ErrorWithoutFlag + DerivErrMustBeEnumType{} -> ErrorWithoutFlag + DerivErrMustHaveExactlyOneConstructor{} -> ErrorWithoutFlag + DerivErrMustHaveSomeParameters{} -> ErrorWithoutFlag + DerivErrMustNotHaveClassContext{} -> ErrorWithoutFlag + DerivErrBadConstructor{} -> ErrorWithoutFlag + DerivErrGenerics{} -> ErrorWithoutFlag + DerivErrEnumOrProduct{} -> ErrorWithoutFlag + TcRnLookupInstance _ _ _ + -> ErrorWithoutFlag + TcRnLazyGADTPattern + -> ErrorWithoutFlag + TcRnArrowProcGADTPattern + -> ErrorWithoutFlag + TcRnTypeEqualityOutOfScope + -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope + TcRnTypeEqualityRequiresOperators + -> WarningWithFlag Opt_WarnTypeEqualityRequiresOperators + TcRnIllegalTypeOperator {} + -> ErrorWithoutFlag + TcRnIllegalTypeOperatorDecl {} + -> ErrorWithoutFlag + TcRnGADTMonoLocalBinds {} + -> WarningWithFlag Opt_WarnGADTMonoLocalBinds + TcRnIncorrectNameSpace {} + -> ErrorWithoutFlag + TcRnNotInScope {} + -> ErrorWithoutFlag + TcRnTermNameInType {} + -> ErrorWithoutFlag + TcRnUntickedPromotedThing {} + -> WarningWithFlag Opt_WarnUntickedPromotedConstructors + TcRnIllegalBuiltinSyntax {} + -> ErrorWithoutFlag + TcRnWarnDefaulting {} + -> WarningWithFlag Opt_WarnTypeDefaults + TcRnWarnClashingDefaultImports {} + -> WarningWithFlag Opt_WarnTypeDefaults + TcRnForeignImportPrimExtNotSet{} + -> ErrorWithoutFlag + TcRnForeignImportPrimSafeAnn{} + -> ErrorWithoutFlag + TcRnForeignFunctionImportAsValue{} + -> ErrorWithoutFlag + TcRnFunPtrImportWithoutAmpersand{} + -> WarningWithFlag Opt_WarnDodgyForeignImports + TcRnIllegalForeignDeclBackend{} + -> ErrorWithoutFlag + TcRnUnsupportedCallConv _ unsupportedCC + -> case unsupportedCC of + StdCallConvUnsupported -> WarningWithFlag Opt_WarnUnsupportedCallingConventions + _ -> ErrorWithoutFlag + TcRnIllegalForeignType{} + -> ErrorWithoutFlag + TcRnInvalidCIdentifier{} + -> ErrorWithoutFlag + TcRnExpectedValueId{} + -> ErrorWithoutFlag + TcRnRecSelectorEscapedTyVar{} + -> ErrorWithoutFlag + TcRnPatSynNotBidirectional{} + -> ErrorWithoutFlag + TcRnIllegalDerivingItem{} + -> ErrorWithoutFlag + TcRnIllegalDefaultClass{} + -> ErrorWithoutFlag + TcRnIllegalNamedDefault{} + -> ErrorWithoutFlag + TcRnUnexpectedAnnotation{} + -> ErrorWithoutFlag + TcRnIllegalRecordSyntax{} + -> ErrorWithoutFlag + TcRnInvalidVisibleKindArgument{} + -> ErrorWithoutFlag + TcRnTooManyBinders{} + -> ErrorWithoutFlag + TcRnDifferentNamesForTyVar{} + -> ErrorWithoutFlag + TcRnDisconnectedTyVar{} + -> ErrorWithoutFlag + TcRnInvalidReturnKind{} + -> ErrorWithoutFlag + TcRnClassKindNotConstraint{} + -> ErrorWithoutFlag + TcRnUnpromotableThing{} + -> ErrorWithoutFlag + TcRnIllegalTermLevelUse{} + -> ErrorWithoutFlag + TcRnMatchesHaveDiffNumArgs{} + -> ErrorWithoutFlag + TcRnCannotBindScopedTyVarInPatSig{} + -> ErrorWithoutFlag + TcRnCannotBindTyVarsInPatBind{} + -> ErrorWithoutFlag + TcRnMultipleInlinePragmas{} + -> WarningWithoutFlag + TcRnUnexpectedPragmas{} + -> WarningWithoutFlag + TcRnNonOverloadedSpecialisePragma{} + -> WarningWithoutFlag + TcRnSpecialiseNotVisible{} + -> WarningWithoutFlag + TcRnPragmaWarning{pragma_warning_msg} + -> WarningWithCategory (warningTxtCategory pragma_warning_msg) + TcRnDifferentExportWarnings _ _ + -> ErrorWithoutFlag + TcRnIncompleteExportWarnings _ _ + -> WarningWithFlag Opt_WarnIncompleteExportWarnings + TcRnIllegalHsigDefaultMethods{} + -> ErrorWithoutFlag + TcRnHsigFixityMismatch{} + -> ErrorWithoutFlag + TcRnHsigShapeMismatch{} + -> ErrorWithoutFlag + TcRnHsigMissingModuleExport{} + -> ErrorWithoutFlag + TcRnBadGenericMethod{} + -> ErrorWithoutFlag + TcRnWarningMinimalDefIncomplete{} + -> WarningWithoutFlag + TcRnDefaultMethodForPragmaLacksBinding{} + -> ErrorWithoutFlag + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> WarningWithoutFlag + TcRnBadMethodErr{} + -> ErrorWithoutFlag + TcRnIllegalTypeData + -> ErrorWithoutFlag + TcRnIllegalQuasiQuotes{} + -> ErrorWithoutFlag + TcRnTHError err + -> thErrorReason err + TcRnTypeDataForbids{} + -> ErrorWithoutFlag + TcRnIllegalNewtype{} + -> ErrorWithoutFlag + TcRnOrPatBindsVariables{} + -> ErrorWithoutFlag + TcRnUnsatisfiedMinimalDef{} + -> WarningWithFlag (Opt_WarnMissingMethods) + TcRnMisplacedInstSig{} + -> ErrorWithoutFlag + TcRnNoRebindableSyntaxRecordDot{} + -> ErrorWithoutFlag + TcRnNoFieldPunsRecordDot{} + -> ErrorWithoutFlag + TcRnListComprehensionDuplicateBinding{} + -> ErrorWithoutFlag + TcRnEmptyStmtsGroup{} + -> ErrorWithoutFlag + TcRnLastStmtNotExpr{} + -> ErrorWithoutFlag + TcRnUnexpectedStatementInContext{} + -> ErrorWithoutFlag + TcRnSectionWithoutParentheses{} + -> ErrorWithoutFlag + TcRnIllegalImplicitParameterBindings{} + -> ErrorWithoutFlag + TcRnIllegalTupleSection{} + -> ErrorWithoutFlag + TcRnCapturedTermName{} + -> WarningWithFlag Opt_WarnTermVariableCapture + TcRnBindingOfExistingName{} + -> ErrorWithoutFlag + TcRnMultipleFixityDecls{} + -> ErrorWithoutFlag + TcRnIllegalPatternSynonymDecl{} + -> ErrorWithoutFlag + TcRnIllegalClassBinding{} + -> ErrorWithoutFlag + TcRnOrphanCompletePragma{} + -> ErrorWithoutFlag + TcRnSpecSigShape{} + -> ErrorWithoutFlag + TcRnEmptyCase{} + -> ErrorWithoutFlag + TcRnNonStdGuards{} + -> WarningWithoutFlag + TcRnDuplicateSigDecl{} + -> ErrorWithoutFlag + TcRnMisplacedSigDecl{} + -> ErrorWithoutFlag + TcRnUnexpectedDefaultSig{} + -> ErrorWithoutFlag + TcRnDuplicateMinimalSig{} + -> ErrorWithoutFlag + TcRnUnexpectedStandaloneDerivingDecl{} + -> ErrorWithoutFlag + TcRnUnusedVariableInRuleDecl{} + -> ErrorWithoutFlag + TcRnUnexpectedStandaloneKindSig{} + -> ErrorWithoutFlag + TcRnIllegalRuleLhs{} + -> ErrorWithoutFlag + TcRnRuleLhsEqualities{} + -> WarningWithFlag Opt_WarnRuleLhsEqualities + TcRnDuplicateRoleAnnot{} + -> ErrorWithoutFlag + TcRnDuplicateKindSig{} + -> ErrorWithoutFlag + TcRnIllegalDerivStrategy{} + -> ErrorWithoutFlag + TcRnIllegalMultipleDerivClauses{} + -> ErrorWithoutFlag + TcRnNoDerivStratSpecified{} + -> WarningWithFlag Opt_WarnMissingDerivingStrategies + TcRnStupidThetaInGadt{} + -> ErrorWithoutFlag + TcRnShadowedTyVarNameInFamResult{} + -> ErrorWithoutFlag + TcRnIncorrectTyVarOnLhsOfInjCond{} + -> ErrorWithoutFlag + TcRnUnknownTyVarsOnRhsOfInjCond{} + -> ErrorWithoutFlag + TcRnBadlyLevelled _ _ _ _ reason + -> reason + TcRnBadlyLevelledType{} + -> WarningWithFlag Opt_WarnBadlyLevelledTypes + TcRnTyThingUsedWrong{} + -> ErrorWithoutFlag + TcRnCannotDefaultKindVar{} + -> ErrorWithoutFlag + TcRnUninferrableTyVar{} + -> ErrorWithoutFlag + TcRnSkolemEscape{} + -> ErrorWithoutFlag + TcRnPatSynEscapedCoercion{} + -> ErrorWithoutFlag + TcRnPatSynExistentialInResult{} + -> ErrorWithoutFlag + TcRnPatSynArityMismatch{} + -> ErrorWithoutFlag + TcRnPatSynInvalidRhs{} + -> ErrorWithoutFlag + TcRnTyFamDepsDisabled{} + -> ErrorWithoutFlag + TcRnAbstractClosedTyFamDecl{} + -> ErrorWithoutFlag + TcRnPartialFieldSelector{} + -> WarningWithFlag Opt_WarnPartialFields + TcRnHasFieldResolvedIncomplete{} + -> WarningWithFlag Opt_WarnIncompleteRecordSelectors + TcRnBadFieldAnnotation _ _ LazyFieldsDisabled + -> ErrorWithoutFlag + TcRnBadFieldAnnotation _ _ UnusableUnpackPragma + -> WarningWithFlag Opt_WarnUnusableUnpackPragmas + TcRnBadFieldAnnotation{} + -> WarningWithoutFlag + TcRnSuperclassCycle{} + -> ErrorWithoutFlag + TcRnDefaultSigMismatch{} + -> ErrorWithoutFlag + TcRnTyFamsDisabled{} + -> ErrorWithoutFlag + TcRnBadTyConTelescope {} + -> ErrorWithoutFlag + TcRnTyFamResultDisabled{} + -> ErrorWithoutFlag + TcRnRoleValidationFailed{} + -> ErrorWithoutFlag + TcRnCommonFieldResultTypeMismatch{} + -> ErrorWithoutFlag + TcRnCommonFieldTypeMismatch{} + -> ErrorWithoutFlag + TcRnClassExtensionDisabled{} + -> ErrorWithoutFlag + TcRnDataConParentTypeMismatch{} + -> ErrorWithoutFlag + TcRnGADTsDisabled{} + -> ErrorWithoutFlag + TcRnExistentialQuantificationDisabled{} + -> ErrorWithoutFlag + TcRnGADTDataContext{} + -> ErrorWithoutFlag + TcRnMultipleConForNewtype{} + -> ErrorWithoutFlag + TcRnKindSignaturesDisabled{} + -> ErrorWithoutFlag + TcRnEmptyDataDeclsDisabled{} + -> ErrorWithoutFlag + TcRnRoleMismatch{} + -> ErrorWithoutFlag + TcRnRoleCountMismatch{} + -> ErrorWithoutFlag + TcRnIllegalRoleAnnotation{} + -> ErrorWithoutFlag + TcRnRoleAnnotationsDisabled{} + -> ErrorWithoutFlag + TcRnIncoherentRoles{} + -> ErrorWithoutFlag + TcRnUnexpectedKindVar{} + -> ErrorWithoutFlag + TcRnNegativeNumTypeLiteral{} + -> ErrorWithoutFlag + TcRnIllegalKind{} + -> ErrorWithoutFlag + TcRnPrecedenceParsingError{} + -> ErrorWithoutFlag + TcRnSectionPrecedenceError{} + -> ErrorWithoutFlag + TcRnUnexpectedPatSigType{} + -> ErrorWithoutFlag + TcRnIllegalKindSignature{} + -> ErrorWithoutFlag + TcRnUnusedQuantifiedTypeVar{} + -> WarningWithFlag Opt_WarnUnusedForalls + TcRnDataKindsError{} + -> ErrorWithoutFlag + TcRnTypeSynonymCycle{} + -> ErrorWithoutFlag + TcRnZonkerMessage msg + -> zonkerMessageReason msg + TcRnInterfaceError err + -> interfaceErrorReason err + TcRnSelfImport{} + -> ErrorWithoutFlag + TcRnNoExplicitImportList{} + -> WarningWithFlag Opt_WarnMissingImportList + TcRnSafeImportsDisabled{} + -> ErrorWithoutFlag + TcRnDeprecatedModule _ txt + -> WarningWithCategory (warningTxtCategory txt) + TcRnRedundantSourceImport{} + -> WarningWithoutFlag + TcRnImportLookup{} + -> ErrorWithoutFlag + TcRnUnusedImport{} + -> WarningWithFlag Opt_WarnUnusedImports + TcRnDuplicateDecls{} + -> ErrorWithoutFlag + TcRnPackageImportsDisabled + -> ErrorWithoutFlag + TcRnIllegalDataCon{} + -> ErrorWithoutFlag + TcRnNestedForallsContexts{} + -> ErrorWithoutFlag + TcRnRedundantRecordWildcard + -> WarningWithFlag Opt_WarnRedundantRecordWildcards + TcRnUnusedRecordWildcard{} + -> WarningWithFlag Opt_WarnUnusedRecordWildcards + TcRnUnusedName _ prov + -> WarningWithFlag $ case prov of + UnusedNameTopDecl -> Opt_WarnUnusedTopBinds + UnusedNameImported _ -> Opt_WarnUnusedTopBinds + UnusedNameTypePattern -> Opt_WarnUnusedTypePatterns + UnusedNameMatch -> Opt_WarnUnusedMatches + UnusedNameLocalBind -> Opt_WarnUnusedLocalBinds + TcRnQualifiedBinder{} + -> ErrorWithoutFlag + TcRnTypeApplicationsDisabled{} + -> ErrorWithoutFlag + TcRnInvalidRecordField{} + -> ErrorWithoutFlag + TcRnTupleTooLarge{} + -> ErrorWithoutFlag + TcRnCTupleTooLarge{} + -> ErrorWithoutFlag + TcRnIllegalInferredTyVars{} + -> ErrorWithoutFlag + TcRnAmbiguousName{} + -> ErrorWithoutFlag + TcRnBindingNameConflict{} + -> ErrorWithoutFlag + TcRnNonCanonicalDefinition (NonCanonicalMonoid _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances + TcRnNonCanonicalDefinition (NonCanonicalMonad _) _ + -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances + TcRnDefaultedExceptionContext{} + -> WarningWithFlag Opt_WarnDefaultedExceptionContext + TcRnImplicitImportOfPrelude {} + -> WarningWithFlag Opt_WarnImplicitPrelude + TcRnMissingMain {} + -> ErrorWithoutFlag + TcRnGhciUnliftedBind {} + -> ErrorWithoutFlag + TcRnGhciMonadLookupFail {} + -> ErrorWithoutFlag + TcRnMissingRoleAnnotation{} + -> WarningWithFlag Opt_WarnMissingRoleAnnotations + TcRnIllegalInvisTyVarBndr{} + -> ErrorWithoutFlag + TcRnIllegalWildcardTyVarBndr{} + -> ErrorWithoutFlag + TcRnInvalidInvisTyVarBndr{} + -> ErrorWithoutFlag + TcRnInvisBndrWithoutSig{} + -> ErrorWithoutFlag + TcRnImplicitRhsQuantification{} + -> WarningWithFlag Opt_WarnImplicitRhsQuantification + TcRnPatersonCondFailure{} + -> ErrorWithoutFlag + TcRnIllformedTypePattern{} + -> ErrorWithoutFlag + TcRnIllegalTypePattern{} + -> ErrorWithoutFlag + TcRnIllformedTypeArgument{} + -> ErrorWithoutFlag + TcRnIllegalTypeExpr{} + -> ErrorWithoutFlag + TcRnInvalidDefaultedTyVar{} + -> ErrorWithoutFlag + TcRnNamespacedWarningPragmaWithoutFlag{} + -> ErrorWithoutFlag + TcRnIllegalInvisibleTypePattern{} + -> ErrorWithoutFlag + TcRnNamespacedFixitySigWithoutFlag{} + -> ErrorWithoutFlag + TcRnOutOfArityTyVar{} + -> ErrorWithoutFlag + TcRnUnexpectedTypeSyntaxInTerms{} + -> ErrorWithoutFlag + + diagnosticHints = \case + TcRnUnknownMessage m + -> diagnosticHints m + TcRnMessageWithInfo _ msg_with_info + -> case msg_with_info of + TcRnMessageDetailed info m -> + errInfoHints info ++ diagnosticHints m + TcRnWithHsDocContext _ msg + -> diagnosticHints msg + TcRnSolverReport (SolverReportWithCtxt ctxt msg) _ + -> tcSolverReportMsgHints ctxt msg + TcRnSolverDepthError {} + -> [SuggestIncreaseReductionDepth] + TcRnRedundantConstraints{} + -> noHints + TcRnInaccessibleCode{} + -> noHints + TcRnInaccessibleCoAxBranch{} + -> noHints + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> noHints + TcRnImplicitLift{} + -> noHints + TcRnUnusedPatternBinds{} + -> noHints + TcRnDodgyImports{} + -> noHints + TcRnDodgyExports{} + -> noHints + TcRnMissingImportList{} + -> noHints + TcRnUnsafeDueToPlugin{} + -> noHints + TcRnModMissingRealSrcSpan{} + -> noHints + TcRnIdNotExportedFromModuleSig name mod + -> [SuggestAddToHSigExportList name $ Just mod] + TcRnIdNotExportedFromLocalSig name + -> [SuggestAddToHSigExportList name Nothing] + TcRnShadowedName{} + -> noHints + TcRnInvalidWarningCategory{} + -> noHints + TcRnDuplicateWarningDecls{} + -> noHints + TcRnSimplifierTooManyIterations{} + -> [SuggestIncreaseSimplifierIterations] + TcRnIllegalPatSynDecl{} + -> noHints + TcRnLinearPatSyn{} + -> noHints + TcRnEmptyRecordUpdate{} + -> noHints + TcRnIllegalFieldPunning{} + -> [suggestExtension LangExt.NamedFieldPuns] + TcRnIllegalWildcardsInRecord{} + -> [suggestExtension LangExt.RecordWildCards] + TcRnIllegalWildcardInType{} + -> noHints + TcRnIllegalNamedWildcardInTypeArgument{} + -> [SuggestAnonymousWildcard] + TcRnIllegalImplicitTyVarInTypeArgument tv + -> [SuggestExplicitQuantification tv] + TcRnIllegalPunnedVarOccInTypeArgument{} + -> [] + TcRnDuplicateFieldName{} + -> noHints + TcRnIllegalViewPattern{} + -> [suggestExtension LangExt.ViewPatterns] + TcRnCharLiteralOutOfRange{} + -> noHints + TcRnIllegalWildcardsInConstructor{} + -> noHints + TcRnIgnoringAnnotations{} + -> noHints + TcRnAnnotationInSafeHaskell + -> noHints + TcRnInvalidTypeApplication{} + -> noHints + TcRnTagToEnumMissingValArg + -> noHints + TcRnTagToEnumUnspecifiedResTy{} + -> noHints + TcRnTagToEnumResTyNotAnEnum{} + -> noHints + TcRnTagToEnumResTyTypeData{} + -> noHints + TcRnArrowIfThenElsePredDependsOnResultTy + -> noHints + TcRnIllegalHsBootOrSigDecl {} + -> noHints + TcRnBootMismatch boot_or_sig err + | Hsig <- boot_or_sig + , BootMismatch _ _ (BootMismatchedTyCons _boot_tc real_tc tc_errs) <- err + , any is_synAbsData_etaReduce (NE.toList tc_errs) + -> [SuggestEtaReduceAbsDataTySyn real_tc] + | otherwise + -> noHints + where + is_synAbsData_etaReduce (SynAbstractData SynAbsDataTySynNotNullary) = True + is_synAbsData_etaReduce _ = False + TcRnRecursivePatternSynonym{} + -> noHints + TcRnPartialTypeSigTyVarMismatch{} + -> noHints + TcRnPartialTypeSigBadQuantifier{} + -> noHints + TcRnMissingSignature {} + -> noHints + TcRnPolymorphicBinderMissingSig{} + -> noHints + TcRnOverloadedSig{} + -> noHints + TcRnTupleConstraintInst{} + -> noHints + TcRnUserTypeError{} + -> noHints + TcRnConstraintInKind{} + -> noHints + TcRnUnboxedTupleOrSumTypeFuncArg tuple_or_sum _ + -> [suggestExtension $ unboxedTupleOrSumExtension tuple_or_sum] + TcRnLinearFuncInKind{} + -> noHints + TcRnForAllEscapeError{} + -> noHints + TcRnVDQInTermType mb_ty + | isJust mb_ty -> [suggestExtension LangExt.RequiredTypeArguments] + | otherwise -> [] + TcRnBadQuantPredHead{} + -> noHints + TcRnIllegalTupleConstraint{} + -> [suggestExtension LangExt.ConstraintKinds] + TcRnNonTypeVarArgInConstraint{} + -> [suggestExtension LangExt.FlexibleContexts] + TcRnIllegalImplicitParam{} + -> noHints + TcRnIllegalConstraintSynonymOfKind{} + -> [suggestExtension LangExt.ConstraintKinds] + TcRnOversaturatedVisibleKindArg{} + -> noHints + TcRnForAllRankErr rank _ + -> case rank of + LimitedRank{} -> [suggestExtension LangExt.RankNTypes] + MonoTypeRankZero -> [suggestExtension LangExt.RankNTypes] + MonoTypeTyConArg -> [suggestExtension LangExt.ImpredicativeTypes] + MonoTypeSynArg -> [suggestExtension LangExt.LiberalTypeSynonyms] + MonoTypeConstraint -> [suggestExtension LangExt.QuantifiedConstraints] + _ -> noHints + TcRnSimplifiableConstraint{} + -> noHints + TcRnArityMismatch{} + -> noHints + TcRnIllegalInstance rea + -> illegalInstanceHints rea + TcRnMonomorphicBindings bindings + -> case bindings of + [] -> noHints + (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)] + TcRnOrphanInstance clsOrFamInst + -> [SuggestFixOrphanInst { isFamilyInstance = isFam }] + where + isFam = case clsOrFamInst :: Either ClsInst FamInst of + Left _clsInst -> Nothing + Right famInst -> Just $ fi_flavor famInst + TcRnFunDepConflict{} + -> noHints + TcRnDupInstanceDecls{} + -> noHints + TcRnConflictingFamInstDecls{} + -> noHints + TcRnFamInstNotInjective rea _ _ + -> case rea of + InjErrRhsBareTyVar{} -> noHints + InjErrRhsCannotBeATypeFam -> noHints + InjErrRhsOverlap -> noHints + InjErrCannotInferFromRhs _ _ suggestUndInst + | YesSuggestUndecidableInstaces <- suggestUndInst + -> [suggestExtension LangExt.UndecidableInstances] + | otherwise + -> noHints + TcRnBangOnUnliftedType{} + -> noHints + TcRnLazyBangOnUnliftedType{} + -> noHints + TcRnMultipleDefaultDeclarations{} + -> noHints + TcRnBadDefaultType{} + -> noHints + TcRnPatSynBundledWithNonDataCon{} + -> noHints + TcRnPatSynBundledWithWrongType{} + -> noHints + TcRnDupeModuleExport{} + -> noHints + TcRnExportedModNotImported{} + -> noHints + TcRnNullExportedModule{} + -> noHints + TcRnMissingExportList{} + -> noHints + TcRnExportHiddenComponents{} + -> noHints + TcRnExportHiddenDefault{} + -> noHints + TcRnDuplicateExport{} + -> noHints + TcRnDuplicateNamedDefaultExport{} + -> noHints + TcRnExportedParentChildMismatch{} + -> noHints + TcRnConflictingExports{} + -> noHints + TcRnDuplicateFieldExport {} + -> [suggestExtension LangExt.DuplicateRecordFields] + TcRnAmbiguousFieldInUpdate {} + -> [suggestExtension LangExt.DisambiguateRecordFields] + TcRnAmbiguousRecordUpdate{} + -> noHints + TcRnMissingFields{} + -> noHints + TcRnFieldUpdateInvalidType{} + -> noHints + TcRnMissingStrictFields{} + -> noHints + TcRnBadRecordUpdate{} + -> noHints + TcRnIllegalStaticExpression {} + -> [suggestExtension LangExt.StaticPointers] + TcRnStaticFormNotClosed{} + -> noHints + TcRnUselessTypeable + -> noHints + TcRnDerivingDefaults{} + -> [useDerivingStrategies] + TcRnNonUnaryTypeclassConstraint{} + -> noHints + TcRnPartialTypeSignatures suggestParSig _ + -> case suggestParSig of + YesSuggestPartialTypeSignatures + -> let info = text "to use the inferred type" + in [suggestExtensionWithInfo info LangExt.PartialTypeSignatures] + NoSuggestPartialTypeSignatures + -> noHints + TcRnCannotDeriveInstance cls _ _ newtype_deriving rea + -> deriveInstanceErrReasonHints cls newtype_deriving rea + TcRnLookupInstance _ _ _ + -> noHints + TcRnLazyGADTPattern + -> noHints + TcRnArrowProcGADTPattern + -> noHints + TcRnTypeEqualityOutOfScope + -> noHints + TcRnTypeEqualityRequiresOperators + -> [suggestExtension LangExt.TypeOperators] + TcRnIllegalTypeOperator {} + -> [suggestExtension LangExt.TypeOperators] + TcRnIllegalTypeOperatorDecl {} + -> [suggestExtension LangExt.TypeOperators] + TcRnGADTMonoLocalBinds {} + -> [suggestAnyExtension [LangExt.GADTs, LangExt.TypeFamilies]] + TcRnIncorrectNameSpace nm is_th_use + | is_th_use + -> [SuggestAppropriateTHTick (nameNameSpace nm)] + | otherwise + -> noHints + TcRnNotInScope err _nm + -> scopeErrorHints err + TcRnTermNameInType {} + -> noHints + TcRnUntickedPromotedThing thing + -> [SuggestAddTick thing] + TcRnIllegalBuiltinSyntax {} + -> noHints + TcRnWarnDefaulting {} + -> noHints + TcRnWarnClashingDefaultImports cls local imports + -> suggestDefaultDeclaration cls (fold local) (cd_types <$> NE.toList imports) + TcRnForeignImportPrimExtNotSet{} + -> [suggestExtension LangExt.GHCForeignImportPrim] + TcRnForeignImportPrimSafeAnn{} + -> noHints + TcRnForeignFunctionImportAsValue{} + -> noHints + TcRnFunPtrImportWithoutAmpersand{} + -> noHints + TcRnIllegalForeignDeclBackend{} + -> noHints + TcRnUnsupportedCallConv{} + -> noHints + TcRnIllegalForeignType _ reason + -> case reason of + TypeCannotBeMarshaled _ why + | NewtypeDataConNotInScope tc _ <- why + -> let tc_nm = tyConName tc + dc = dataConName $ head $ tyConDataCons tc + in [ ImportSuggestion (occName dc) + $ ImportDataCon Nothing False False (nameOccName tc_nm) ] + | UnliftedFFITypesNeeded <- why + -> [suggestExtension LangExt.UnliftedFFITypes] + _ -> noHints + TcRnInvalidCIdentifier{} + -> noHints + TcRnExpectedValueId{} + -> noHints + TcRnRecSelectorEscapedTyVar{} + -> [SuggestPatternMatchingSyntax] + TcRnPatSynNotBidirectional{} + -> noHints + TcRnIllegalDerivingItem{} + -> noHints + TcRnIllegalDefaultClass{} + -> noHints + TcRnIllegalNamedDefault{} + -> [suggestExtension LangExt.NamedDefaults] + TcRnUnexpectedAnnotation{} + -> noHints + TcRnIllegalRecordSyntax{} + -> noHints + TcRnInvalidVisibleKindArgument{} + -> noHints + TcRnTooManyBinders{} + -> noHints + TcRnDifferentNamesForTyVar{} + -> noHints + TcRnDisconnectedTyVar n + -> [SuggestBindTyVarExplicitly n] + TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext + -> case mb_suggest_unlifted_ext of + Nothing -> noHints + Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes] + Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes] + TcRnClassKindNotConstraint{} + -> noHints + TcRnUnpromotableThing{} + -> noHints + TcRnIllegalTermLevelUse {} + -> noHints + TcRnMatchesHaveDiffNumArgs{} + -> noHints + TcRnCannotBindScopedTyVarInPatSig{} + -> noHints + TcRnCannotBindTyVarsInPatBind{} + -> noHints + TcRnMultipleInlinePragmas{} + -> noHints + TcRnUnexpectedPragmas{} + -> noHints + TcRnNonOverloadedSpecialisePragma{} + -> noHints + TcRnSpecialiseNotVisible name + -> [SuggestSpecialiseVisibilityHints name] + TcRnPragmaWarning{} + -> noHints + TcRnDifferentExportWarnings _ _ + -> noHints + TcRnIncompleteExportWarnings _ _ + -> noHints + TcRnIllegalHsigDefaultMethods{} + -> noHints + TcRnIllegalQuasiQuotes{} + -> [suggestExtension LangExt.QuasiQuotes] + TcRnTHError err + -> thErrorHints err + TcRnHsigFixityMismatch{} + -> noHints + TcRnHsigShapeMismatch{} + -> noHints + TcRnHsigMissingModuleExport{} + -> noHints + TcRnBadGenericMethod{} + -> noHints + TcRnWarningMinimalDefIncomplete{} + -> noHints + TcRnDefaultMethodForPragmaLacksBinding{} + -> noHints + TcRnIgnoreSpecialisePragmaOnDefMethod{} + -> noHints + TcRnBadMethodErr{} + -> noHints + TcRnIllegalTypeData + -> [suggestExtension LangExt.TypeData] + TcRnTypeDataForbids{} + -> noHints + TcRnIllegalNewtype{} + -> noHints + TcRnOrPatBindsVariables{} + -> noHints + TcRnUnsatisfiedMinimalDef{} + -> noHints + TcRnMisplacedInstSig{} + -> [suggestExtension LangExt.InstanceSigs] + TcRnNoRebindableSyntaxRecordDot{} + -> noHints + TcRnNoFieldPunsRecordDot{} + -> noHints + TcRnListComprehensionDuplicateBinding{} + -> noHints + TcRnEmptyStmtsGroup EmptyStmtsGroupInDoNotation{} + -> [suggestExtension LangExt.NondecreasingIndentation] + TcRnEmptyStmtsGroup{} + -> noHints + TcRnLastStmtNotExpr{} + -> noHints + TcRnUnexpectedStatementInContext _ _ mExt + | Nothing <- mExt -> noHints + | Just ext <- mExt -> [suggestExtension ext] + TcRnSectionWithoutParentheses{} + -> noHints + TcRnIllegalImplicitParameterBindings{} + -> noHints + TcRnIllegalTupleSection{} + -> [suggestExtension LangExt.TupleSections] + TcRnCapturedTermName{} + -> [SuggestRenameTypeVariable] + TcRnBindingOfExistingName{} + -> noHints + TcRnMultipleFixityDecls{} + -> noHints + TcRnIllegalPatternSynonymDecl{} + -> [suggestExtension LangExt.PatternSynonyms] + TcRnIllegalClassBinding{} + -> noHints + TcRnOrphanCompletePragma{} + -> noHints + TcRnEmptyCase _ reason -> + case reason of + EmptyCaseWithoutFlag{} -> [suggestExtension LangExt.EmptyCase] + EmptyCaseDisallowedCtxt{} -> noHints + EmptyCaseForall{} -> noHints + TcRnSpecSigShape{} + -> noHints + TcRnNonStdGuards{} + -> [suggestExtension LangExt.PatternGuards] + TcRnDuplicateSigDecl{} + -> noHints + TcRnMisplacedSigDecl{} + -> noHints + TcRnUnexpectedDefaultSig{} + -> [suggestExtension LangExt.DefaultSignatures] + TcRnDuplicateMinimalSig{} + -> noHints + TcRnUnexpectedStandaloneDerivingDecl{} + -> [suggestExtension LangExt.StandaloneDeriving] + TcRnUnusedVariableInRuleDecl{} + -> noHints + TcRnUnexpectedStandaloneKindSig{} + -> [suggestExtension LangExt.StandaloneKindSignatures] + TcRnIllegalRuleLhs{} + -> noHints + TcRnRuleLhsEqualities{} + -> noHints + TcRnDuplicateRoleAnnot{} + -> noHints + TcRnDuplicateKindSig{} + -> noHints + TcRnIllegalDerivStrategy ds -> case ds of + ViaStrategy{} -> [suggestExtension LangExt.DerivingVia] + _ -> [suggestExtension LangExt.DerivingStrategies] + TcRnIllegalMultipleDerivClauses{} + -> [suggestExtension LangExt.DerivingStrategies] + TcRnNoDerivStratSpecified is_ds_enabled info -> do + let explicit_strategy_hint = case info of + TcRnNoDerivingClauseStrategySpecified assumed_derivings -> + SuggestExplicitDerivingClauseStrategies assumed_derivings + TcRnNoStandaloneDerivingStrategySpecified assumed_strategy deriv_sig -> + SuggestExplicitStandaloneDerivingStrategy assumed_strategy deriv_sig + explicit_strategy_hint : [suggestExtension LangExt.DerivingStrategies | not is_ds_enabled] + TcRnStupidThetaInGadt{} + -> noHints + TcRnShadowedTyVarNameInFamResult{} + -> noHints + TcRnIncorrectTyVarOnLhsOfInjCond{} + -> noHints + TcRnUnknownTyVarsOnRhsOfInjCond{} + -> noHints + TcRnBadlyLevelled{} + -> noHints + TcRnBadlyLevelledType{} + -> noHints + TcRnTyThingUsedWrong{} + -> noHints + TcRnCannotDefaultKindVar{} + -> noHints + TcRnUninferrableTyVar{} + -> noHints + TcRnSkolemEscape{} + -> noHints + TcRnPatSynEscapedCoercion{} + -> noHints + TcRnPatSynExistentialInResult{} + -> noHints + TcRnPatSynArityMismatch{} + -> noHints + TcRnPatSynInvalidRhs name pat args (PatSynNotInvertible _) + -> [SuggestExplicitBidiPatSyn name pat args] + TcRnPatSynInvalidRhs{} + -> noHints + TcRnTyFamDepsDisabled{} + -> [suggestExtension LangExt.TypeFamilyDependencies] + TcRnAbstractClosedTyFamDecl{} + -> noHints + TcRnPartialFieldSelector{} + -> noHints + TcRnHasFieldResolvedIncomplete{} + -> noHints + TcRnBadFieldAnnotation _ _ LazyFieldsDisabled + -> [suggestExtension LangExt.StrictData] + TcRnBadFieldAnnotation{} + -> noHints + TcRnSuperclassCycle{} + -> [suggestExtension LangExt.UndecidableSuperClasses] + TcRnDefaultSigMismatch{} + -> noHints + TcRnTyFamsDisabled{} + -> [suggestExtension LangExt.TypeFamilies] + TcRnBadTyConTelescope{} + -> noHints + TcRnTyFamResultDisabled{} + -> [suggestExtension LangExt.TypeFamilyDependencies] + TcRnRoleValidationFailed{} + -> noHints + TcRnCommonFieldResultTypeMismatch{} + -> noHints + TcRnCommonFieldTypeMismatch{} + -> noHints + TcRnClassExtensionDisabled _ MultiParamDisabled{} + -> [suggestExtension LangExt.MultiParamTypeClasses] + TcRnClassExtensionDisabled _ FunDepsDisabled{} + -> [suggestExtension LangExt.FunctionalDependencies] + TcRnClassExtensionDisabled _ ConstrainedClassMethodsDisabled{} + -> [suggestExtension LangExt.ConstrainedClassMethods] + TcRnDataConParentTypeMismatch{} + -> noHints + TcRnGADTsDisabled{} + -> [suggestExtension LangExt.GADTs] + TcRnExistentialQuantificationDisabled{} + -> [suggestAnyExtension [LangExt.ExistentialQuantification, LangExt.GADTs]] + TcRnGADTDataContext{} + -> noHints + TcRnMultipleConForNewtype{} + -> noHints + TcRnKindSignaturesDisabled{} + -> [suggestExtension LangExt.KindSignatures] + TcRnEmptyDataDeclsDisabled{} + -> [suggestExtension LangExt.EmptyDataDecls] + TcRnRoleMismatch{} + -> noHints + TcRnRoleCountMismatch{} + -> noHints + TcRnIllegalRoleAnnotation{} + -> noHints + TcRnRoleAnnotationsDisabled{} + -> [suggestExtension LangExt.RoleAnnotations] + TcRnIncoherentRoles{} + -> [suggestExtension LangExt.IncoherentInstances] + TcRnUnexpectedKindVar{} + -> [suggestExtension LangExt.PolyKinds] + TcRnNegativeNumTypeLiteral{} + -> noHints + TcRnIllegalKind _ suggest_polyKinds + -> if suggest_polyKinds + then [suggestExtension LangExt.PolyKinds] + else noHints + TcRnPrecedenceParsingError{} + -> noHints + TcRnSectionPrecedenceError{} + -> noHints + TcRnUnexpectedPatSigType{} + -> [suggestExtension LangExt.ScopedTypeVariables] + TcRnIllegalKindSignature{} + -> [suggestExtension LangExt.KindSignatures] + TcRnUnusedQuantifiedTypeVar{} + -> noHints + TcRnDataKindsError{} + -> [suggestExtension LangExt.DataKinds] + TcRnTypeSynonymCycle{} + -> noHints + TcRnZonkerMessage msg + -> zonkerMessageHints msg + TcRnInterfaceError reason + -> interfaceErrorHints reason + TcRnSelfImport{} + -> noHints + TcRnNoExplicitImportList{} + -> noHints + TcRnSafeImportsDisabled{} + -> [SuggestSafeHaskell] + TcRnDeprecatedModule{} + -> noHints + TcRnRedundantSourceImport{} + -> noHints + TcRnImportLookup (ImportLookupBad k _ is ie exts) -> + let mod_name = moduleName $ is_mod is + occ = rdrNameOcc $ ieName ie + could_change_item item_suggestion = + [useExtensionInOrderTo empty LangExt.ExplicitNamespaces | suggest_ext] ++ + [ ImportSuggestion occ $ + CouldChangeImportItem mod_name item_suggestion ] + where + suggest_ext + | ile_explicit_namespaces exts = False -- extension already on + | otherwise = + case item_suggestion of + -- ImportItemRemove* -> False + ImportItemRemoveType{} -> False + ImportItemRemoveData{} -> False + ImportItemRemovePattern{} -> False + ImportItemRemoveSubordinateType{} -> False + ImportItemRemoveSubordinateData{} -> False + -- ImportItemAdd* -> True + ImportItemAddType{} -> True + in case k of + BadImportAvailVar -> could_change_item ImportItemRemoveType + BadImportNotExported suggs -> suggs + BadImportAvailTyCon + -- The three cases (TyOp, DataKw, PatternKw) are laid out + -- in Note [Reasons for BadImportAvailTyCon] in GHC.Tc.Errors.Types + | isSymOcc occ -> could_change_item ImportItemAddType -- Case (TyOp) + | otherwise -> -- Non-operator cases + case unLoc (ieLIEWrappedName ie) of + IEData{} -> could_change_item ImportItemRemoveData -- Case (DataKw) + IEPattern{} -> could_change_item ImportItemRemovePattern -- Case (PatternKw) + _ -> panic "diagnosticHints: unexpected BadImportAvailTyCon" + + BadImportAvailDataCon par -> + [ ImportSuggestion occ $ + ImportDataCon { ies_suggest_import_from = Just mod_name + , ies_suggest_pattern_keyword = ile_pattern_synonyms exts + && not (ile_explicit_namespaces exts) -- do not suggest 'pattern' when we can suggest 'data' + , ies_suggest_data_keyword = ile_explicit_namespaces exts + , ies_parent = par } ] + BadImportNotExportedSubordinates{} -> noHints + BadImportNonTypeSubordinates _ nontype1 -> + could_change_item (ImportItemRemoveSubordinateType (nameOccName . greName <$> nontype1)) + BadImportNonDataSubordinates _ nondata1 -> + could_change_item (ImportItemRemoveSubordinateData (nameOccName . greName <$> nondata1)) + TcRnImportLookup{} + -> noHints + TcRnUnusedImport{} + -> noHints + TcRnDuplicateDecls _ fs + -> [suggestExtension LangExt.DuplicateRecordFields | all isFieldName fs] + TcRnPackageImportsDisabled + -> [suggestExtension LangExt.PackageImports] + TcRnIllegalDataCon{} + -> noHints + TcRnNestedForallsContexts{} + -> noHints + TcRnRedundantRecordWildcard + -> [SuggestRemoveRecordWildcard] + TcRnUnusedRecordWildcard{} + -> [SuggestRemoveRecordWildcard] + TcRnUnusedName{} + -> noHints + TcRnQualifiedBinder{} + -> noHints + TcRnTypeApplicationsDisabled{} + -> [suggestExtension LangExt.TypeApplications] + TcRnInvalidRecordField{} + -> noHints + TcRnTupleTooLarge{} + -> noHints + TcRnCTupleTooLarge{} + -> noHints + TcRnIllegalInferredTyVars{} + -> noHints + TcRnAmbiguousName{} + -> noHints + TcRnBindingNameConflict{} + -> noHints + TcRnNonCanonicalDefinition reason _ + -> suggestNonCanonicalDefinition reason + TcRnDefaultedExceptionContext _ + -> noHints + TcRnImplicitImportOfPrelude {} + -> noHints + TcRnMissingMain {} + -> noHints + TcRnGhciUnliftedBind {} + -> noHints + TcRnGhciMonadLookupFail {} + -> noHints + TcRnMissingRoleAnnotation{} + -> noHints + TcRnIllegalInvisTyVarBndr{} + -> [suggestExtension LangExt.TypeAbstractions] + TcRnIllegalWildcardTyVarBndr{} + -> [suggestExtension LangExt.TypeAbstractions] + TcRnInvalidInvisTyVarBndr{} + -> noHints + TcRnInvisBndrWithoutSig name _ + -> [SuggestAddStandaloneKindSignature name] + TcRnImplicitRhsQuantification kv + -> [SuggestBindTyVarOnLhs (unLoc kv)] + TcRnPatersonCondFailure{} + -> [suggestExtension LangExt.UndecidableInstances] + TcRnIllformedTypePattern{} + -> noHints + TcRnIllegalTypePattern{} + -> noHints + TcRnIllformedTypeArgument{} + -> noHints + TcRnIllegalTypeExpr{} + -> noHints + TcRnInvalidDefaultedTyVar{} + -> noHints + TcRnNamespacedWarningPragmaWithoutFlag{} + -> [suggestExtension LangExt.ExplicitNamespaces] + TcRnIllegalInvisibleTypePattern _ reason + -> case reason of + InvisPatWithoutFlag -> [suggestExtension LangExt.TypeAbstractions] + InvisPatNoForall -> noHints + InvisPatMisplaced -> noHints + TcRnNamespacedFixitySigWithoutFlag{} + -> [suggestExtension LangExt.ExplicitNamespaces] + TcRnOutOfArityTyVar{} + -> noHints + TcRnUnexpectedTypeSyntaxInTerms syntax + -> [suggestExtension (typeSyntaxExtension syntax)] + + diagnosticCode = constructorCode @GHC + +pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc +pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ + [ fsep [ text "Level error:", pprLevelCheckReason reason + , text "is bound at" <+> pprThBindLevel bind_lvls + , text "but used at level" <+> ppr use_lvl] + ] ++ + [hang (text "Could not be resolved by implicit lifting due to the following error:") 2 + (text "No instance for:" <+> quotes (ppr (errorItemPred item))) + | Just item <- [lift_attempt] + ] ++ + [ vcat (text "Available from the imports:" : ppr_imports (gre_imp gre)) + | LevelCheckSplice _ (Just gre) <- [reason] + , not (isEmptyBag (gre_imp gre)) ] + where + ppr_imports :: Bag ImportSpec -> [SDoc] + ppr_imports = map ((bullet <+>) . ppr ) . bagToList + +note :: SDoc -> SDoc +note note = "Note" <> colon <+> note <> dot + +-- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", +-- and so on. The `and` stands for any `conjunction`, which is passed in. +commafyWith :: SDoc -> [SDoc] -> [SDoc] +commafyWith _ [] = [] +commafyWith _ [x] = [x] +commafyWith conjunction [x, y] = [x <+> conjunction <+> y] +commafyWith conjunction xs = addConjunction $ punctuate comma xs + where addConjunction [x, y] = [x, conjunction, y] + addConjunction (x : xs) = x : addConjunction xs + addConjunction _ = panic "commafyWith expected 2 or more elements" + +deriveInstanceErrReasonHints :: Class + -> UsingGeneralizedNewtypeDeriving + -> DeriveInstanceErrReason + -> [GhcHint] +deriveInstanceErrReasonHints cls newtype_deriving = \case + DerivErrNotWellKinded _ _ n_args_to_keep + | cls `hasKey` gen1ClassKey && n_args_to_keep >= 0 + -> [suggestExtension LangExt.PolyKinds] + | otherwise + -> noHints + DerivErrSafeHaskellGenericInst -> noHints + DerivErrDerivingViaWrongKind{} -> noHints + DerivErrNoEtaReduce{} -> noHints + DerivErrBootFileFound -> noHints + DerivErrDataConsNotAllInScope{} -> noHints + DerivErrGNDUsedOnData -> noHints + DerivErrNullaryClasses -> noHints + DerivErrLastArgMustBeApp -> noHints + DerivErrNoFamilyInstance{} -> noHints + DerivErrNotStockDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrHasAssociatedDatatypes{} + -> noHints + DerivErrNewtypeNonDeriveableClass + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrCannotEtaReduceEnough{} + | newtype_deriving == NoGeneralizedNewtypeDeriving + -> [useGND] + | otherwise + -> noHints + DerivErrOnlyAnyClassDeriveable _ deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotDeriveable deriveAnyClassEnabled + | deriveAnyClassEnabled == NoDeriveAnyClassEnabled + -> [suggestExtension LangExt.DeriveAnyClass] + | otherwise + -> noHints + DerivErrNotAClass{} + -> noHints + DerivErrNoConstructors{} + -> let info = text "to enable deriving for empty data types" + in [useExtensionInOrderTo info LangExt.EmptyDataDeriving] + DerivErrLangExtRequired{} + -- This is a slightly weird corner case of GHC: we are failing + -- to derive a typeclass instance because a particular 'Extension' + -- is not enabled (and so we report in the main error), but here + -- we don't want to /repeat/ to enable the extension in the hint. + -> noHints + DerivErrDunnoHowToDeriveForType{} + -> noHints + DerivErrMustBeEnumType rep_tc + -- We want to suggest GND only if this /is/ a newtype. + | newtype_deriving == NoGeneralizedNewtypeDeriving && isNewTyCon rep_tc + -> [useGND] + | otherwise + -> noHints + DerivErrMustHaveExactlyOneConstructor{} + -> noHints + DerivErrMustHaveSomeParameters{} + -> noHints + DerivErrMustNotHaveClassContext{} + -> noHints + DerivErrBadConstructor wcard _ + -> case wcard of + Nothing -> noHints + Just YesHasWildcard -> [SuggestFillInWildcardConstraint] + Just NoHasWildcard -> [SuggestAddStandaloneDerivation] + DerivErrGenerics{} + -> noHints + DerivErrEnumOrProduct{} + -> noHints + +-------------------------------------------------------------------------------- + +-- | Pretty-print supplementary information, to add to an error report. +pprSolverReportSupplementary :: HoleFitDispConfig -> SupplementaryInfo -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprSolverReportSupplementary hfdc = \case + SupplementaryBindings binds -> pprRelevantBindings binds + SupplementaryHoleFits fits -> pprValidHoleFits hfdc fits + SupplementaryCts cts -> pprConstraintsInclude cts + SupplementaryImportErrors errs -> vcat (map ppr $ NE.toList errs) + +-- | Display a collection of valid hole fits. +pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs)) + = fits_msg $$ refs_msg + + where + fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc + fits_msg = ppUnless (null fits) $ + hang (text "Valid hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) fits) + $$ ppWhen discarded_fits fits_discard_msg + refs_msg = ppUnless (null refs) $ + hang (text "Valid refinement hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) refs) + $$ ppWhen discarded_refs refs_discard_msg + fits_discard_msg = + text "(Some hole fits suppressed;" <+> + text "use -fmax-valid-hole-fits=N" <+> + text "or -fno-max-valid-hole-fits)" + refs_discard_msg = + text "(Some refinement hole fits suppressed;" <+> + text "use -fmax-refinement-hole-fits=N" <+> + text "or -fno-max-refinement-hole-fits)" + +-- For pretty printing hole fits, we display the name and type of the fit, +-- with added '_' to represent any extra arguments in case of a non-zero +-- refinement level. +pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc +pprHoleFit _ (RawHoleFit sd) = sd +pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (TcHoleFit (HoleFit {..})) = + hang display 2 provenance + where tyApp = sep $ zipWithEqual pprArg vars hfWrap + where pprArg b arg = case binderFlag b of + Specified -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + Inferred -> empty + Required -> pprPanic "pprHoleFit: bad Required" + (ppr b <+> ppr arg) + tyAppVars = sep $ punctuate comma $ + zipWithEqual (\v t -> ppr (binderVar v) <+> text "~" <+> pprParendType t) + vars hfWrap + + vars = unwrapTypeVars hfType + where + -- Attempts to get all the quantified type variables in a type, + -- e.g. + -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) + -- into [m, a] + unwrapTypeVars :: Type -> [ForAllTyBinder] + unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of + Just (_, _, _, unfunned) -> unwrapTypeVars unfunned + _ -> [] + where (vars, unforalled) = splitForAllForAllTyBinders t + holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches + holeDisp = if sMs then holeVs + else sep $ replicate (length hfMatches) $ text "_" + occDisp = case hfCand of + GreHFCand gre -> pprPrefixOcc (greName gre) + NameHFCand name -> pprPrefixOcc name + IdHFCand id_ -> pprPrefixOcc id_ + tyDisp = ppWhen sTy $ dcolon <+> ppr hfType + has = not . null + wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars)) + $ text "with" <+> if sWrp || not sTy + then occDisp <+> tyApp + else tyAppVars + docs = case hfDoc of + Just d -> pprHsDocStrings d + _ -> empty + funcInfo = ppWhen (has hfMatches && sTy) $ + text "where" <+> occDisp <+> tyDisp + subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp + display = subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp) + provenance = ppWhen sProv $ parens $ + case hfCand of + GreHFCand gre -> pprNameProvenance gre + NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name) + IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_) + +-- | Add a "Constraints include..." message. +-- +-- See Note [Constraints include ...] +pprConstraintsInclude :: NE.NonEmpty (PredType, RealSrcSpan) -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprConstraintsInclude cts + = hang (text "Constraints include") + 2 (vcat $ map pprConstraint $ NE.toList cts) + where + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) + +messageWithInfoDiagnosticMessage :: UnitState + -> ErrInfo + -> Bool + -> DecoratedSDoc + -> DecoratedSDoc +messageWithInfoDiagnosticMessage unit_state (ErrInfo {..}) show_ctxt important = + let ctxt = pprWithUnitState unit_state + $ vcat $ map pprErrCtxtMsg [ ctx | ctx <- errInfoContext, show_ctxt ] + + supp = case errInfoSupplementary of + Nothing -> empty + Just (hfdc, supp_msgs) -> + pprWithUnitState unit_state $ + vcat $ map (pprSolverReportSupplementary hfdc) supp_msgs + in mapDecoratedSDoc (pprWithUnitState unit_state) important + `unionDecoratedSDoc` + mkDecorated [ctxt, supp] + +messageWithHsDocContext :: TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc +messageWithHsDocContext opts ctxt main_msg = do + if tcOptsShowContext opts + then main_msg `unionDecoratedSDoc` ctxt_msg + else main_msg + where + ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) + +-------------------------------------------------------------------------------- + +dodgy_msg :: Outputable ie => SDoc -> GlobalRdrElt -> ie -> SDoc +dodgy_msg kind tc ie + = vcat [ text "The" <+> kind <+> text "item" <+> quotes (ppr ie) <+> text "suggests that" + , quotes (ppr $ greName tc) <+> text "has" <+> sep rest ] + where + rest :: [SDoc] + rest = + case greInfo tc of + IAmTyCon ClassFlavour + -> [ text "(in-scope) class methods or associated types" <> comma + , text "but it has none" ] + IAmTyCon _ + -> [ text "(in-scope) constructors or record fields" <> comma + , text "but it has none" ] + _ -> [ text "children" <> comma + , text "but it is not a type constructor or a class" ] + +dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn +dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii Nothing + where + ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre) + +pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc +pprTypeDoesNotHaveFixedRuntimeRep ty prov = + let what = pprFixedRuntimeRepProvenance prov + in text "The" <+> what <+> text "does not have a fixed runtime representation:" + $$ format_frr_err ty + +format_frr_err :: Type -- ^ the type which doesn't have a fixed runtime representation + -> SDoc +format_frr_err ty + = (bullet <+> ppr tidy_ty <+> dcolon <+> ppr tidy_ki) + where + (tidy_env, tidy_ty) = tidyOpenTypeX emptyTidyEnv ty + tidy_ki = tidyType tidy_env (typeKind ty) + +pprField :: (FieldLabelString, TcType) -> SDoc +pprField (f,ty) = ppr f <+> dcolon <+> ppr ty + +pprRecordFieldPart :: RecordFieldPart -> SDoc +pprRecordFieldPart = \case + RecordFieldDecl {} -> text "declaration" + RecordFieldConstructor{} -> text "construction" + RecordFieldPattern{} -> text "pattern" + RecordFieldUpdate -> text "update" + +ppr_opfix :: (OpName, Fixity) -> SDoc +ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) + where + pp_op | NegateOp <- op = text "prefix `-'" + | otherwise = quotes (ppr op) + +pprBindings :: [Name] -> SDoc +pprBindings = pprWithCommas (quotes . ppr) + + +injectivityErrorHerald :: SDoc +injectivityErrorHerald = + text "Type family equation violates the family's injectivity annotation." + +formatExportItemError :: SDoc -> String -> SDoc +formatExportItemError exportedThing reason = + hsep [ text "The export item" + , quotes exportedThing + , text reason ] + +-- | What warning flags are associated with the given missing signature? +missingSignatureWarningFlags :: MissingSignature -> Exported -> NonEmpty WarningFlag +missingSignatureWarningFlags (MissingTopLevelBindingSig {}) exported + -- We prefer "bigger" warnings first: #14794 + -- + -- See Note [Warnings controlled by multiple flags] + = Opt_WarnMissingSignatures :| + [ Opt_WarnMissingExportedSignatures | IsExported == exported ] +missingSignatureWarningFlags (MissingPatSynSig {}) exported + = Opt_WarnMissingPatternSynonymSignatures :| + [ Opt_WarnMissingExportedPatternSynonymSignatures | IsExported == exported ] +missingSignatureWarningFlags (MissingTyConKindSig ty_con _) _ + = Opt_WarnMissingKindSignatures :| [Opt_WarnMissingPolyKindSignatures | isForAllTy_invis_ty (tyConKind ty_con) ] + +useDerivingStrategies :: GhcHint +useDerivingStrategies = + useExtensionInOrderTo (text "to pick a different strategy") LangExt.DerivingStrategies + +useGND :: GhcHint +useGND = let info = text "for GHC's" <+> text "newtype-deriving extension" + in suggestExtensionWithInfo info LangExt.GeneralizedNewtypeDeriving + +cannotMakeDerivedInstanceHerald :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- ^ If False, only prints the why. + -> SDoc + -> SDoc +cannotMakeDerivedInstanceHerald cls cls_args mb_strat newtype_deriving pprHerald why = + if pprHerald + then sep [(hang (text "Can't make a derived instance of") + 2 (quotes (ppr pred) <+> via_mechanism) + $$ nest 2 extra) <> colon, + nest 2 why] + else why + where + strat_used = isJust mb_strat + extra | not strat_used, (newtype_deriving == YesGeneralizedNewtypeDeriving) + = text "(even with cunning GeneralizedNewtypeDeriving)" + | otherwise = empty + pred = mkClassPred cls cls_args + via_mechanism | strat_used + , Just strat <- mb_strat + = text "with the" <+> (derivStrategyName strat) <+> text "strategy" + | otherwise + = empty + +badCon :: DataCon -> SDoc -> SDoc +badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg + +derivErrDiagnosticMessage :: Class + -> [Type] + -> Maybe (DerivStrategy GhcTc) + -> UsingGeneralizedNewtypeDeriving + -> Bool -- If True, includes the herald \"can't make a derived..\" + -> DeriveInstanceErrReason + -> SDoc +derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \case + DerivErrNotWellKinded tc cls_kind _ + -> sep [ hang (text "Cannot derive well-kinded instance of form" + <+> quotes (pprClassPred cls cls_tys + <+> parens (ppr tc <+> text "..."))) + 2 empty + , nest 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind)) + ] + DerivErrSafeHaskellGenericInst + -> text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." + DerivErrDerivingViaWrongKind cls_kind via_ty via_kind + -> hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) + 2 (text "Class" <+> quotes (ppr cls) + <+> text "expects an argument of kind" + <+> quotes (pprKind cls_kind) <> char ',' + $+$ text "but" <+> quotes (pprType via_ty) + <+> text "has kind" <+> quotes (pprKind via_kind)) + DerivErrNoEtaReduce inst_ty + -> sep [text "Cannot eta-reduce to an instance of form", + nest 2 (text "instance (...) =>" + <+> pprClassPred cls (cls_tys ++ [inst_ty]))] + DerivErrBootFileFound + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances in hs-boot files" + $+$ text "Write an instance declaration instead") + DerivErrDataConsNotAllInScope tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") + 2 (text "so you cannot derive an instance for it")) + DerivErrGNDUsedOnData + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "GeneralizedNewtypeDeriving cannot be used on non-newtypes") + DerivErrNullaryClasses + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Cannot derive instances for nullary classes") + DerivErrLastArgMustBeApp + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + ( text "The last argument of the instance must be a" + <+> text "data or newtype application") + DerivErrNoFamilyInstance tc tc_args + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "No family instance for" <+> quotes (pprTypeApp tc tc_args)) + DerivErrNotStockDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr cls) <+> text "is not a stock derivable class (Eq, Show, etc.)") + DerivErrHasAssociatedDatatypes hasAdfs at_last_cls_tv_in_kinds at_without_last_cls_tv + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + $ vcat [ ppWhen (hasAdfs == YesHasAdfs) adfs_msg + , case at_without_last_cls_tv of + YesAssociatedTyNotParamOverLastTyVar tc -> at_without_last_cls_tv_msg tc + NoAssociatedTyNotParamOverLastTyVar -> empty + , case at_last_cls_tv_in_kinds of + YesAssocTyLastVarInKind tc -> at_last_cls_tv_in_kinds_msg tc + NoAssocTyLastVarInKind -> empty + ] + where + + adfs_msg = text "the class has associated data types" + + at_without_last_cls_tv_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "is not parameterized over the last type variable") + 2 (text "of the class" <+> quotes (ppr cls)) + + at_last_cls_tv_in_kinds_msg at_tc = hang + (text "the associated type" <+> quotes (ppr at_tc) + <+> text "contains the last type variable") + 2 (text "of the class" <+> quotes (ppr cls) + <+> text "in a kind, which is not (yet) allowed") + DerivErrNewtypeNonDeriveableClass + -> derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald (DerivErrNotStockDeriveable NoDeriveAnyClassEnabled) + DerivErrCannotEtaReduceEnough eta_ok + -> let cant_derive_err = ppUnless eta_ok eta_msg + eta_msg = text "cannot eta-reduce the representation type enough" + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + cant_derive_err + DerivErrOnlyAnyClassDeriveable tc _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr tc) <+> text "is a type class," + <+> text "and can only have a derived instance" + $+$ text "if DeriveAnyClass is enabled") + DerivErrNotDeriveable _ + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald empty + DerivErrNotAClass predType + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (ppr predType) <+> text "is not a class") + DerivErrNoConstructors rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have at least one data constructor") + DerivErrLangExtRequired ext + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "You need " <> ppr ext + <+> text "to derive an instance for this class") + DerivErrDunnoHowToDeriveForType ty + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (hang (text "Don't know how to derive" <+> quotes (ppr cls)) + 2 (text "for type" <+> quotes (ppr ty))) + DerivErrMustBeEnumType rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (sep [ quotes (pprSourceTyCon rep_tc) <+> + text "must be an enumeration type" + , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]) + + DerivErrMustHaveExactlyOneConstructor rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (quotes (pprSourceTyCon rep_tc) <+> text "must have precisely one constructor") + DerivErrMustHaveSomeParameters rep_tc + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) <+> text "must have some type parameters") + DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta + -> cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (text "Data type" <+> quotes (ppr rep_tc) + <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta) + DerivErrBadConstructor _ reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrBadConExistential con + -> badCon con $ text "must be truly polymorphic in the last argument of the data type" + DerivErrBadConCovariant con + -> badCon con $ text "must not use the type variable in a function argument" + DerivErrBadConFunTypes con + -> badCon con $ text "must not contain function types" + DerivErrBadConWrongArg con + -> badCon con $ text "must use the type variable only as the last argument of a data type" + DerivErrBadConIsGADT con + -> badCon con $ text "is a GADT" + DerivErrBadConHasExistentials con + -> badCon con $ text "has existential type variables in its type" + DerivErrBadConHasConstraints con + -> badCon con $ text "has constraints in its type" + DerivErrBadConHasHigherRankType con + -> badCon con $ text "has a higher-rank type" + DerivErrGenerics reasons + -> let why = vcat $ map renderReason reasons + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald why + where + renderReason = \case + DerivErrGenericsMustNotHaveDatatypeContext tc_name + -> ppr tc_name <+> text "must not have a datatype context" + DerivErrGenericsMustNotHaveExoticArgs dc + -> ppr dc <+> text "must not have exotic unlifted or polymorphic arguments" + DerivErrGenericsMustBeVanillaDataCon dc + -> ppr dc <+> text "must be a vanilla data constructor" + DerivErrGenericsMustHaveSomeTypeParams rep_tc + -> text "Data type" <+> quotes (ppr rep_tc) + <+> text "must have some type parameters" + DerivErrGenericsMustNotHaveExistentials con + -> badCon con $ text "must not have existential arguments" + DerivErrGenericsWrongArgKind con + -> badCon con $ + text "applies a type to an argument involving the last parameter" + $$ text "but the applied type is not of kind * -> *" + DerivErrEnumOrProduct this that + -> let ppr1 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False this + ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that + in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald + (ppr1 $$ text " or" $$ ppr2) + +lookupInstanceErrDiagnosticMessage :: Class + -> [Type] + -> LookupInstanceErrReason + -> SDoc +lookupInstanceErrDiagnosticMessage cls tys = \case + LookupInstErrNotExact + -> text "Not an exact match (i.e., some variables get instantiated)" + LookupInstErrFlexiVar + -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys) + LookupInstErrNotFound + -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys) + +{- ********************************************************************* +* * + Outputable SolverReportErrCtxt (for debugging) +* * +**********************************************************************-} + +instance Outputable SolverReportErrCtxt where + ppr (CEC { cec_binds = bvar + , cec_defer_type_errors = dte + , cec_expr_holes = eh + , cec_type_holes = th + , cec_out_of_scope_holes = osh + , cec_warn_redundant = wr + , cec_expand_syns = es + , cec_suppress = sup }) + = text "CEC" <+> braces (vcat + [ text "cec_binds" <+> equals <+> ppr bvar + , text "cec_defer_type_errors" <+> equals <+> ppr dte + , text "cec_expr_holes" <+> equals <+> ppr eh + , text "cec_type_holes" <+> equals <+> ppr th + , text "cec_out_of_scope_holes" <+> equals <+> ppr osh + , text "cec_warn_redundant" <+> equals <+> ppr wr + , text "cec_expand_syns" <+> equals <+> ppr es + , text "cec_suppress" <+> equals <+> ppr sup ]) + +{- ********************************************************************* +* * + Outputting TcSolverReportMsg errors +* * +**********************************************************************-} + +-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg' +-- with its enclosing 'SolverReportErrCtxt'. +pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc +pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext = ctxt, reportContent = msg }) + = pprTcSolverReportMsg ctxt msg + +-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'. +pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc +pprTcSolverReportMsg _ (BadTelescope telescope skols) = + hang (text "These kind and type variables:" <+> ppr telescope $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (pprTyVars sorted_tvs) + where + sorted_tvs = scopedSort skols +pprTcSolverReportMsg _ (UserTypeError ty) = + pprUserTypeErrorTy ty +pprTcSolverReportMsg _ (UnsatisfiableError ty) = + pprUserTypeErrorTy ty +pprTcSolverReportMsg ctxt (ReportHoleError hole err) = + pprHoleError ctxt hole err +pprTcSolverReportMsg ctxt + (CannotUnifyVariable + { mismatchMsg = msg + , cannotUnifyReason = reason }) + = pprMismatchMsg ctxt msg + $$ pprCannotUnifyVariableReason ctxt reason +pprTcSolverReportMsg ctxt + (Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = ambig_infos + , mismatchCoercibleInfo = coercible_info }) + = vcat ([ pprMismatchMsg ctxt mismatch_msg + , maybe empty (pprTyVarInfo ctxt) tv_info + , maybe empty pprCoercibleMsg coercible_info ] + ++ (map pprAmbiguityInfo ambig_infos)) +pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) = + vcat (map make_msg frr_origs) + where + -- Assemble the error message: pair up each origin with the corresponding type, e.g. + -- • FixedRuntimeRep origin msg 1 ... + -- a :: TYPE r1 + -- • FixedRuntimeRep origin msg 2 ... + -- b :: TYPE r2 + make_msg :: FixedRuntimeRepErrorInfo -> SDoc + make_msg (FRR_Info { frr_info_origin = + FixedRuntimeRepOrigin + { frr_type = ty + , frr_context = frr_ctxt } + , frr_info_not_concrete = mb_not_conc + , frr_info_other_origin = mb_other_orig }) = + -- Add bullet points if there is more than one error. + (if length frr_origs > 1 then (bullet <+>) else id) $ + vcat [ sep [ pprFixedRuntimeRepContext frr_ctxt + , text "does not have a fixed runtime representation." ] + , type_printout ty + , case mb_other_orig of + Nothing -> empty + Just o -> other_context o + , case mb_not_conc of + Just (conc_tv, not_conc) + | conc_tv `elemVarSet` tyCoVarsOfType ty + -- Only show this message if 'conc_tv' appears somewhere + -- in the type, otherwise it's not helpful. + -> unsolved_concrete_eq_explanation conc_tv not_conc + _ -> empty + ] + + -- Don't print out the type (only the kind), if the type includes + -- a confusing cast, unless the user passed -fprint-explicit-coercions. + -- + -- Example: + -- + -- In T20363, we have a representation-polymorphism error with a type + -- of the form + -- + -- ( (# #) |> co ) :: TYPE NilRep + -- + -- where NilRep is a nullary type family application which reduces to TupleRep '[]. + -- We prefer avoiding showing the cast to the user, but we also don't want to + -- print the confusing: + -- + -- (# #) :: TYPE NilRep + -- + -- So in this case we simply don't print the type, only the kind. + confusing_cast :: Type -> Bool + confusing_cast ty = + case ty of + CastTy inner_ty _ + -- A confusing cast is one that is responsible + -- for a representation-polymorphism error. + -> isConcreteType (typeKind inner_ty) + _ -> False + + type_printout :: Type -> SDoc + type_printout ty = + sdocOption sdocPrintExplicitCoercions $ \ show_coercions -> + if confusing_cast ty && not show_coercions + then vcat [ text "Its kind is:" + , nest 2 $ pprWithTYPE (typeKind ty) + , text "(Use -fprint-explicit-coercions to see the full type.)" ] + else vcat [ text "Its type is:" + , nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty) ] + + other_context :: CtOrigin -> SDoc + other_context = \case + TypeEqOrigin { uo_actual = actual_ty, uo_expected = exp_ty } -> + -- TODO: use uo_thing in the error message as well? + hang (text "When unifying:") 2 $ + vcat [ bullet <+> ppr actual_ty + , bullet <+> ppr exp_ty + ] + KindEqOrigin _ _ orig' _ + -> other_context orig' + _ -> empty -- Don't think this ever happens + + unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc + unsolved_concrete_eq_explanation tv not_conc = + text "Cannot unify" <+> quotes (ppr not_conc) + <+> text "with the type variable" <+> quotes (ppr tv) + $$ text "because the former is not a concrete" <+> what <> dot + where + ki = tyVarKind tv + what :: SDoc + what + | isRuntimeRepTy ki + = quotes (text "RuntimeRep") + | isLevityTy ki + = quotes (text "Levity") + | otherwise + = text "type" +pprTcSolverReportMsg _ (ExpectingMoreArguments n thing) = + text "Expecting" <+> speakN (abs n) <+> + more <+> quotes (ppr thing) + where + more + | n == 1 = text "more argument to" + | otherwise = text "more arguments to" -- n > 1 +pprTcSolverReportMsg ctxt (UnboundImplicitParams (item :| items)) = + let givens = getUserGivens ctxt + in if null givens + then addArising (errorItemCtLoc item) $ + sep [ text "Unbound implicit parameter" <> plural preds + , nest 2 (pprParendTheta preds) ] + else pprMismatchMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) + where + preds = map errorItemPred (item : items) +pprTcSolverReportMsg _ (AmbiguityPreventsSolvingCt item ambigs) = + pprAmbiguityInfo (Ambiguity True ambigs) <+> + pprArising (errorItemCtLoc item) $$ + text "prevents the constraint" <+> quotes (pprParendType $ errorItemPred item) + <+> text "from being solved." +pprTcSolverReportMsg ctxt@(CEC {cec_encl = implics}) + (CannotResolveInstance item unifiers candidates rel_binds) + = + vcat + [ no_inst_msg + , extra_note + , mb_patsyn_prov `orElse` empty + , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) + (vcat [ ppUnless lead_with_ambig $ + pprAmbiguityInfo (Ambiguity False (ambig_kvs, ambig_tvs)) + , pprRelevantBindings rel_binds + -- "Relevant bindings" can help explain to the user where an + -- ambiguous type variable comes from. + , potential_msg ]) + , ppWhen (isNothing mb_patsyn_prov) $ + -- Don't suggest fixes for the provided context of a pattern + -- synonym; the right fix is to bind more in the pattern + show_fixes (ctxt_fixes ++ drv_fixes ++ naked_sc_fixes) + , ppWhen (not (null candidates)) + (hang (text "There are instances for similar types:") + 2 (vcat (map ppr candidates))) + -- See Note [Report candidate instances] + ] + where + orig = errorItemOrigin item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + -- See Note [Highlighting ambiguous type variables] in GHC.Tc.Errors + (ambig_kvs, ambig_tvs) = ambigTkvsOfTy pred + ambigs = ambig_kvs ++ ambig_tvs + has_ambigs = not (null ambigs) + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + -- useful_givens are the enclosing implications with non-empty givens, + -- modulo the horrid discardProvCtxtGivens + lead_with_ambig = not (null ambigs) + && not (any isRuntimeUnkSkol ambigs) + && not (null unifiers) + && null useful_givens + + no_inst_msg :: SDoc + no_inst_msg + | lead_with_ambig + = pprTcSolverReportMsg ctxt $ AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) + | otherwise + = pprMismatchMsg ctxt $ CouldNotDeduce useful_givens (item :| []) Nothing + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + potential_hdr $$ + potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) + + potential_hdr + = ppWhen lead_with_ambig $ + text "Probable fix: use a type annotation to specify what" + <+> pprQuotedList ambig_tvs <+> text "should be." + + mb_patsyn_prov :: Maybe SDoc + mb_patsyn_prov + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + = Just (vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ]) + | otherwise = Nothing + + extra_note + -- Flag up partially applied uses of (->) + | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) + = text "(maybe you haven't applied a function to enough arguments?)" + + -- Clarify the mysterious "No instance for (Typeable T) + | className clas == typeableClassName + , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) + , Just (tc,_) <- tcSplitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) + + | otherwise + = empty + + ----------- Possible fixes ---------------- + ctxt_fixes = ctxtFixes has_ambigs pred implics + + drv_fixes = case orig of + DerivOrigin standalone -> [drv_fix standalone] + DerivOriginDC _ _ standalone -> [drv_fix standalone] + DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] + _ -> [] + + drv_fix standalone_wildcard + | standalone_wildcard + = text "fill in the wildcard constraint yourself" + | otherwise + = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") + + -- naked_sc_fix: try to produce a helpful error message for + -- superclass constraints caught by the subtleties described by + -- Note [Recursive superclasses] in GHC.TyCl.Instance + naked_sc_fixes + | ScOrigin IsClsInst NakedSc <- orig -- A superclass wanted with no instance decls used yet + , any non_tyvar_preds useful_givens -- Some non-tyvar givens + = [vcat [ text "if the constraint looks soluble from a superclass of the instance context," + , text "read 'Undecidable instances and loopy superclasses' in the user manual" ]] + | otherwise = [] + + non_tyvar_preds :: UserGiven -> Bool + non_tyvar_preds = any non_tyvar_pred . ic_given + + non_tyvar_pred :: EvVar -> Bool + -- Tells if the Given is of form (C ty1 .. tyn), where the tys are not all tyvars + non_tyvar_pred given = case getClassPredTys_maybe (idType given) of + Just (_, tys) -> not (all isTyVarTy tys) + Nothing -> False + +pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = + vcat + [ addArising ct_loc $ + (text "Overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , ppUnless (null matching_givens) $ + sep [text "Matching givens (or their superclasses):" + , nest 2 (vcat matching_givens)] + , potentialInstancesErrMsg + (PotentialInstances { matches = NE.toList matches, unifiers }) + , ppWhen (null matching_givens && null (NE.tail matches) && null unifiers) $ + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ text "There exists a (perhaps superclass) match:" + , nest 2 (vcat (pp_from_givens useful_givens))] + + , ppWhen (null $ NE.tail matches) $ + parens (vcat [ ppUnless (null tyCoVars) $ + text "The choice depends on the instantiation of" <+> + quotes (pprWithCommas ppr tyCoVars) + , ppUnless (null famTyCons) $ + if (null tyCoVars) + then + text "The choice depends on the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + else + text "and the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + , ppWhen (null (matching_givens)) $ + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] + ])] + where + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + tyCoVars = tyCoVarsOfTypesList tys + famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + matching_givens = mapMaybe matchable useful_givens + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> + ppr (getCtLocEnvLoc (ic_env implic)) ]) + where ev_vars_matching = [ pred + | ev_var <- evvars + , let pred = evVarPred ev_var + , any can_match (pred : transSuperClasses pred) ] + can_match pred + = case getClassPredTys_maybe pred of + Just (clas', tys') -> clas' == clas + && isJust (tcMatchTys tys tys') + Nothing -> False +pprTcSolverReportMsg _ (UnsafeOverlap item match unsafe_overlapped) = + vcat [ addArising ct_loc (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance match)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ NE.toList unsafe_overlapped]) + ] + ] + where + ct_loc = errorItemCtLoc item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + +pprTcSolverReportMsg _ MultiplicityCoercionsNotSupported = text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities" + +pprCannotUnifyVariableReason :: SolverReportErrCtxt -> CannotUnifyVariableReason -> SDoc +pprCannotUnifyVariableReason ctxt (CannotUnifyWithPolytype item tv1 ty2 mb_tv_info) = + vcat [ (if isSkolemTyVar tv1 + then text "Cannot equate type variable" + else text "Cannot instantiate unification variable") + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) + , maybe empty (pprTyVarInfo ctxt) mb_tv_info ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason _ (SkolemEscape item implic esc_skols) = + let + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + in + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr (ic_info implic) + , nest 2 $ text "at" <+> + ppr (getCtLocEnvLoc (ic_env implic)) ] ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + +pprCannotUnifyVariableReason ctxt + (OccursCheck + { occursCheckInterestingTyVars = interesting_tvs + , occursCheckAmbiguityInfos = ambig_infos }) + = ppr_interesting_tyVars interesting_tvs + $$ vcat (map pprAmbiguityInfo ambig_infos) + where + ppr_interesting_tyVars [] = empty + ppr_interesting_tyVars (tv:tvs) = + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + (tv:tvs)) + tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) +pprCannotUnifyVariableReason ctxt (DifferentTyVars tv_info) + = pprTyVarInfo ctxt tv_info +pprCannotUnifyVariableReason ctxt (RepresentationalEq tv_info mb_coercible_msg) + = pprTyVarInfo ctxt tv_info + $$ maybe empty pprCoercibleMsg mb_coercible_msg + +pprUntouchableVariable :: TcTyVar -> Implication -> SDoc +pprUntouchableVariable tv (Implic { ic_given = given, ic_info = skol_info, ic_env = env }) + = sep [ quotes (ppr tv) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> ppr (getCtLocEnvLoc env) ] + +pprMismatchMsg :: SolverReportErrCtxt -> MismatchMsg -> SDoc +pprMismatchMsg ctxt + (BasicMismatch { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 -- Expected + , mismatch_ty2 = ty2 -- Actual + , mismatch_whenMatching = mb_match_txt + , mismatch_mb_same_occ = same_occ_info }) + = vcat [ addArising (errorItemCtLoc item) msg + , pprQCOriginExtra item + , ea_extra + , maybe empty (pprWhenMatching ctxt) mb_match_txt + , maybe empty pprSameOccInfo same_occ_info ] + where + msg + | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || + (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || + (isLiftedLevity ty1 && isUnliftedLevity ty2) || + (isLiftedLevity ty2 && isUnliftedLevity ty1) + = text "Couldn't match a lifted type with an unlifted type" + + | isAtomicTy ty1 || isAtomicTy ty2 + = -- Print with quotes + sep [ text herald1 <+> quotes (ppr ty1) + , nest padding $ + text herald2 <+> quotes (ppr ty2) ] + + | otherwise + = -- Print with vertical layout + vcat [ text herald1 <> colon <+> ppr ty1 + , nest padding $ + text herald2 <> colon <+> ppr ty2 ] + + herald1 = conc [ "Couldn't match" + , if is_repr then "representation of" else "" + , if want_ea then "expected" else "" + , what ] + herald2 = conc [ "with" + , if is_repr then "that of" else "" + , if want_ea then ("actual " ++ what) else "" ] + + padding = length herald1 - length herald2 + + (want_ea, ea_extra) + = case ea of + NoEA -> (False, empty) + EA mb_extra -> (True , maybe empty (pprExpectedActualInfo ctxt) mb_extra) + is_repr = case errorItemEqRel item of { ReprEq -> True; NomEq -> False } + + what = levelString (ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel) + + conc :: [String] -> String + conc = unwords . filter (not . null) + +pprMismatchMsg ctxt + (TypeEqMismatch { teq_mismatch_item = item + , teq_mismatch_ty1 = ty1 -- These types are the actual types + , teq_mismatch_ty2 = ty2 -- that don't match; may be swapped + , teq_mismatch_expected = exp -- These are the context of + , teq_mismatch_actual = act -- the mis-match + , teq_mismatch_what = mb_thing + , teq_mb_same_occ = mb_same_occ }) + = vcat [ addArising ct_loc $ + pprWithInvisibleBitsWhen ppr_invis_bits msg + $$ maybe empty pprSameOccInfo mb_same_occ + , pprQCOriginExtra item ] + where + + msg | Just (torc, rep) <- sORTKind_maybe exp + = msg_for_exp_sort torc rep + + | Just nargs_msg <- num_args_msg + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = nargs_msg $$ ea_msg + + | ea_looks_same ty1 ty2 exp act + , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig + = ea_msg + + | otherwise + = bale_out_msg + + -- bale_out_msg: the mismatched types are /inside/ exp and act + bale_out_msg = vcat errs + where + errs = case mk_ea_msg ctxt Nothing level orig of + Left ea_info -> pprMismatchMsg ctxt mismatch_err + : map (pprExpectedActualInfo ctxt) ea_info + Right ea_err -> [ pprMismatchMsg ctxt mismatch_err + , ea_err ] + mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2 + + -- 'expected' is (TYPE rep) or (CONSTRAINT rep) + msg_for_exp_sort exp_torc exp_rep + | Just (act_torc, act_rep) <- sORTKind_maybe act + = -- (TYPE exp_rep) ~ (CONSTRAINT act_rep) etc + msg_torc_torc act_torc act_rep + | otherwise + = -- (TYPE _) ~ Bool, etc + maybe_num_args_msg $$ + sep [ text "Expected a" <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Nothing -> text "found something with kind" + Just thing -> quotes (ppr thing) <+> text "has kind" + , quotes (pprWithTYPE act) ] + + where + msg_torc_torc act_torc act_rep + | exp_torc == act_torc + = msg_same_torc act_torc act_rep + | otherwise + = sep [ text "Expected a" <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Nothing -> text "found a" + Just thing -> quotes (ppr thing) <+> text "is a" + <+> ppr_torc act_torc ] + + msg_same_torc act_torc act_rep + | Just exp_doc <- describe_rep exp_rep + , Just act_doc <- describe_rep act_rep + = sep [ text "Expected" <+> exp_doc <+> ppr_torc exp_torc <> comma + , text "but" <+> case mb_thing of + Just thing -> quotes (ppr thing) <+> text "is" + Nothing -> text "got" + <+> act_doc <+> ppr_torc act_torc ] + msg_same_torc _ _ = bale_out_msg + + ct_loc = errorItemCtLoc item + orig = errorItemOrigin item + level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + ppr_invis_bits = shouldPprWithInvisibleBits ty1 ty2 orig + + num_args_msg = case level of + KindLevel + | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) + -- if one is a meta-tyvar, then it's possible that the user + -- has asked for something impredicative, and we couldn't unify. + -- Don't bother with counting arguments. + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n > 0 -- we don't know how many args there are, so don't + -- recommend removing args that aren't + , Just thing <- mb_thing + -> Just $ pprTcSolverReportMsg ctxt (ExpectingMoreArguments n thing) + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = num_args_msg `orElse` empty + + count_args ty = count isVisiblePiTyBinder $ fst $ splitPiTys ty + + ppr_torc TypeLike = text "type"; + ppr_torc ConstraintLike = text "constraint" + + describe_rep :: RuntimeRepType -> Maybe SDoc + -- describe_rep IntRep = Just "an IntRep" + -- describe_rep (BoxedRep Lifted) = Just "a lifted" + -- etc + describe_rep rep + | Just (rr_tc, rr_args) <- splitRuntimeRep_maybe rep + = case rr_args of + [lev_ty] | rr_tc `hasKey` boxedRepDataConKey + , Just lev <- levityType_maybe lev_ty + -> case lev of + Lifted -> Just (text "a lifted") + Unlifted -> Just (text "a boxed unlifted") + [] | rr_tc `hasKey` tupleRepDataConTyConKey -> Just (text "a zero-bit") + | starts_with_vowel rr_occ -> Just (text "an" <+> text rr_occ) + | otherwise -> Just (text "a" <+> text rr_occ) + where + rr_occ = occNameString (getOccName rr_tc) + + _ -> Nothing -- Must be TupleRep [r1..rn] + | otherwise = Nothing + + starts_with_vowel (c:_) = c `elem` ("AEIOU" :: String) + starts_with_vowel [] = False + +pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) + = vcat [ main_msg + , pprQCOriginExtra item + , ea_supplementary ] + where + main_msg + | null useful_givens = addArising ct_loc no_instance_msg + | otherwise = vcat ( addArising ct_loc no_deduce_msg + : pp_from_givens useful_givens) + + ea_supplementary = case mb_extra of + Nothing -> empty + Just (CND_Extra level ty1 ty2) -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig + + ct_loc = errorItemCtLoc item + orig = ctLocOrigin ct_loc + wanteds = map errorItemPred (item:others) + + no_instance_msg = + case wanteds of + [wanted] | -- Guard: don't say "no instance" for a constraint + -- such as "c" for a type variable c. + Just (tc, _) <- splitTyConApp_maybe wanted + , isClassTyCon tc + -> text "No instance for" <+> quotes (ppr wanted) + _ -> text "Could not solve:" <+> pprTheta wanteds + + no_deduce_msg = + case wanteds of + [wanted] -> text "Could not deduce" <+> quotes (ppr wanted) + _ -> text "Could not deduce:" <+> pprTheta wanteds + +pprQCOriginExtra :: ErrorItem -> SDoc +-- When we were originally trying to solve a quantified constraint like +-- (forall a. Eq a => Eq (c a)) +-- add a note to say so, so the overall error looks like +-- Cannot deduce Eq (c a) +-- from (Eq a) +-- when trying to solve (forall a. Eq a => Eq (c a)) +-- Without this, the error is very inscrutable +-- See (WFA3) in Note [Solving a Wanted forall-constraint], +-- in GHC.Tc.Solver.Solve +pprQCOriginExtra item + | ScOrigin (IsQC pred orig) _ <- orig + = hang (text "When trying to solve the quantified constraint") + 2 (vcat [ ppr pred + , text "arising from" <+> pprCtOriginBriefly orig ]) + | otherwise + = empty + where + orig = ctLocOrigin (errorItemCtLoc item) + +pprKindMismatchMsg :: TypedThing -> Type -> Type -> SDoc +pprKindMismatchMsg thing exp act + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | isConstraintLikeKind exp = text "a constraint" + | Just arg <- kindRep_maybe exp -- TYPE t0 + , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case + True -> text "kind" <+> quotes (ppr exp) + False -> text "a type" + | otherwise = text "kind" <+> quotes (ppr exp) + +-- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types. +-- See Note [Showing invisible bits of types in error messages] +-- +-- This function first checks to see if the 'CtOrigin' argument is a +-- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible +-- equality; if it's not, definitely print the kinds. Even if the equality is +-- a visible equality, check the expected/actual types to see if the types +-- have equal visible components. If the 'CtOrigin' is +-- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves. +shouldPprWithInvisibleBits :: Type -> Type -> CtOrigin -> Bool +shouldPprWithInvisibleBits _ty1 _ty2 (TypeEqOrigin { uo_actual = act + , uo_expected = exp + , uo_visible = vis }) + | not vis = True -- See tests T15870, T16204c + | otherwise = mayLookIdentical act exp -- See tests T9171, T9144. +shouldPprWithInvisibleBits ty1 ty2 _ct + = mayLookIdentical ty1 ty2 + +{- Note [Showing invisible bits of types in error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be terribly confusing to get an error message like (#9171) + + Couldn't match expected type ‘GetParam Base (GetParam Base Int)’ + with actual type ‘GetParam Base (GetParam Base Int)’ + +The reason may be that the kinds don't match up. Typically you'll get +more useful information, but not when it's as a result of ambiguity. + +To mitigate this, when we find a type or kind mis-match: + +* See if normally-visible parts of the type would make the two types + look different. This check is made by + `GHC.Core.TyCo.Compare.mayLookIdentical` + +* If not, display the types with their normally-visible parts made visible, + by setting flags in the `SDocContext": + Specifically: + - Display kind arguments: sdocPrintExplicitKinds + - Don't default away runtime-reps: sdocPrintExplicitRuntimeReps, + which controls `GHC.Iface.Type.hideNonStandardTypes` + (NB: foralls are always printed by pprType, it turns out.) + +As a result the above error message would instead be displayed as: + + Couldn't match expected type + ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’ + with actual type + ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’ + +Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. + +Another example of what goes wrong without this: #24553. +-} + +{- ********************************************************************* +* * + Displaying potential instances +* * +**********************************************************************-} + +-- | Directly display the given matching and unifying instances, +-- with a header for each: `Matching instances`/`Potentially matching instances`. +pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc +pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = + vcat + [ ppWhen (not $ null matches) $ + text "Matching instance" <> plural matches <> colon $$ + nest 2 (vcat (map ppr_inst matches)) + , ppWhen (not $ null unifiers) $ + (text "Potentially matching instance" <> plural unifiers <> colon) $$ + nest 2 (vcat (map ppr_inst unifiers)) + ] + +-- | Display a summary of available instances, omitting those involving +-- out-of-scope types, in order to explain why we couldn't solve a particular +-- constraint, e.g. due to instance overlap or out-of-scope types. +-- +-- To directly display a collection of matching/unifying instances, +-- use 'pprPotentialInstances'. +potentialInstancesErrMsg :: PotentialInstances -> SDoc +-- See Note [Displaying potential instances] +potentialInstancesErrMsg potentials = + sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + potentials_msg_with_options potentials print_insts sty + +-- | Display a summary of available instances, omitting out-of-scope ones. +-- +-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing +-- options. +potentials_msg_with_options :: PotentialInstances + -> Bool -- ^ Whether to print /all/ potential instances + -> PprStyle + -> SDoc +potentials_msg_with_options + (PotentialInstances { matches, unifiers }) + show_all_potentials sty + | null matches && null unifiers + = empty + + | null show_these_matches && null show_these_unifiers + = vcat [ not_in_scope_msg empty + , flag_hint ] + + | otherwise + = vcat [ pprPotentialInstances + pprInstance -- print instance + location info + (PotentialInstances + { matches = show_these_matches + , unifiers = show_these_unifiers }) + , overlapping_but_not_more_specific_msg sorted_matches + , nest 2 $ vcat + [ ppWhen (n_in_scope_hidden > 0) $ + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , ppWhen (not_in_scopes > 0) $ + not_in_scope_msg (text "...plus") + , flag_hint ] ] + where + n_show_matches, n_show_unifiers :: Int + n_show_matches = 3 + n_show_unifiers = 2 + + (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches + (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers + sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches + sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers + (show_these_matches, show_these_unifiers) + | show_all_potentials = (sorted_matches, sorted_unifiers) + | otherwise = (take n_show_matches sorted_matches + ,take n_show_unifiers sorted_unifiers) + n_in_scope_hidden + = length sorted_matches + length sorted_unifiers + - length show_these_matches - length show_these_unifiers + + -- "in scope" means that all the type constructors + -- are lexically in scope; these instances are likely + -- to be more useful + inst_in_scope :: ClsInst -> Bool + inst_in_scope cls_inst = nameSetAll name_in_scope $ + orphNamesOfTypes (is_tys cls_inst) + + name_in_scope name + | pretendNameIsInScope name + = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names + | Just mod <- nameModule_maybe name + = qual_in_scope (qualName sty mod Nothing (nameOccName name)) + | otherwise + = True + + qual_in_scope :: QualifyName -> Bool + qual_in_scope NameUnqual = True + qual_in_scope (NameQual {}) = True + qual_in_scope _ = False + + not_in_scopes :: Int + not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers + + not_in_scope_msg herald = + hang (herald <+> speakNOf not_in_scopes (text "instance") + <+> text "involving out-of-scope types") + 2 (ppWhen show_all_potentials $ + pprPotentialInstances + pprInstanceHdr -- only print the header, not the instance location info + (PotentialInstances + { matches = not_in_scope_matches + , unifiers = not_in_scope_unifiers + })) + + flag_hint = ppUnless (show_all_potentials + || (equalLength show_these_matches matches + && equalLength show_these_unifiers unifiers)) $ + text "(use -fprint-potential-instances to see them all)" + +-- | Compute a message informing the user of any instances that are overlapped +-- but were not discarded because the instance overlapping them wasn't +-- strictly more specific. +overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc +overlapping_but_not_more_specific_msg insts + -- Only print one example of "overlapping but not strictly more specific", + -- to avoid information overload. + | overlap : _ <- overlapping_but_not_more_specific + = overlap_header $$ ppr_overlapping overlap + | otherwise + = empty + where + overlap_header :: SDoc + overlap_header + | [_] <- overlapping_but_not_more_specific + = text "An overlapping instance can only be chosen when it is strictly more specific." + | otherwise + = text "Overlapping instances can only be chosen when they are strictly more specific." + overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] + overlapping_but_not_more_specific + = nubOrdBy (comparing (is_dfun . fst)) + [ (overlapper, overlappee) + | these <- groupBy ((==) `on` is_cls_nm) insts + -- Take all pairs of distinct instances... + , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` + , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` + -- ... such that one instance in the pair overlaps the other... + , let mb_overlapping + | hasOverlappingFlag (overlapMode $ is_flag one) + || hasOverlappableFlag (overlapMode $ is_flag other) + = [(one, other)] + | hasOverlappingFlag (overlapMode $ is_flag other) + || hasOverlappableFlag (overlapMode $ is_flag one) + = [(other, one)] + | otherwise + = [] + , (overlapper, overlappee) <- mb_overlapping + -- ... but the overlapper is not more specific than the overlappee. + , not (overlapper `more_specific_than` overlappee) + ] + more_specific_than :: ClsInst -> ClsInst -> Bool + is1 `more_specific_than` is2 + = isJust (tcMatchTys (is_tys is1) (is_tys is2)) + ppr_overlapping :: (ClsInst, ClsInst) -> SDoc + ppr_overlapping (overlapper, overlappee) + = text "The first instance that follows overlaps the second, but is not more specific than it:" + $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) + +{- Note [Displaying potential instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When showing a list of instances for + - overlapping instances (show ones that match) + - no such instance (show ones that could match) +we want to give it a bit of structure. Here's the plan + +* Say that an instance is "in scope" if all of the + type constructors it mentions are lexically in scope. + These are the ones most likely to be useful to the programmer. + +* Show at most n_show in-scope instances, + and summarise the rest ("plus N others") + +* Summarise the not-in-scope instances ("plus 4 not in scope") + +* Add the flag -fshow-potential-instances which replaces the + summary with the full list +-} + +{- ********************************************************************* +* * + Outputting additional solver report information +* * +**********************************************************************-} + +-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. +pprExpectedActualInfo :: SolverReportErrCtxt -> ExpectedActualInfo -> SDoc +pprExpectedActualInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = + vcat + [ text "Expected:" <+> ppr exp + , text " Actual:" <+> ppr act ] +pprExpectedActualInfo _ + (ExpectedActualAfterTySynExpansion + { ea_expanded_expected = exp + , ea_expanded_actual = act } ) + = vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] + +pprCoercibleMsg :: CoercibleMsg -> SDoc +pprCoercibleMsg (UnknownRoles ty) = + note $ "We cannot know what roles the parameters to" <+> quotes (ppr ty) <+> "have;" $$ + "we must assume that the role is nominal" +pprCoercibleMsg (TyConIsAbstract tc) = + note $ "The type constructor" <+> quotes (pprSourceTyCon tc) <+> "is abstract" +pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = + hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + +pprWhenMatching :: SolverReportErrCtxt -> WhenMatching -> SDoc +pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = + sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> + if printExplicitCoercions + || not (cty1 `pickyEqType` cty2) + then vcat [ hang (text "When matching" <+> sub_whats) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (typeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (typeKind cty2) ]) + , supplementary ] + else text "When matching the kind of" <+> quotes (ppr cty1) + where + sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel + sub_whats = text (levelString sub_t_or_k) <> char 's' + supplementary = mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o + +pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc +pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic }) + = vcat [ mk_msg tv1 + , maybe empty (pprUntouchableVariable tv1) mb_implic + , case mb_tv2 of { Nothing -> empty; Just tv2 -> mk_msg tv2 } ] + where + mk_msg tv = case tcTyVarDetails tv of + SkolemTv sk_info _ _ -> pprSkols ctxt [(getSkolemInfo sk_info, [tv])] + RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" + MetaTv {} -> empty + +pprAmbiguityInfo :: AmbiguityInfo -> SDoc +pprAmbiguityInfo (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg + where + + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs + = vcat [ text "Cannot resolve unknown runtime type" + <> plural ambig_tvs <+> pprQuotedList ambig_tvs + , text "Use :print or :force to determine these types"] + + | not (null ambig_tvs) + = pp_ambig (text "type") ambig_tvs + + | otherwise + = pp_ambig (text "kind") ambig_kvs + + pp_ambig what tkvs + | prepend_msg -- "Ambiguous type variable 't0'" + = text "Ambiguous" <+> what <+> text "variable" + <> plural tkvs <+> pprQuotedList tkvs + + | otherwise -- "The type variable 't0' is ambiguous" + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" +pprAmbiguityInfo (NonInjectiveTyFam tc) = + note $ quotes (ppr tc) <+> text "is a non-injective type family" + +pprSameOccInfo :: SameOccInfo -> SDoc +pprSameOccInfo (SameOcc same_pkg n1 n2) = + note (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> text "is defined at") + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainUnit) $ + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) + where + pkg = moduleUnit mod + mod = nameModule nm + loc = nameSrcSpan nm + +{- ********************************************************************* +* * + Outputting HoleError messages +* * +**********************************************************************-} + +pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc +pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) OutOfScopeHole + = out_of_scope_msg + where + herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" + out_of_scope_msg -- Print v :: ty only if the type has structure + | boring_type = hang herald 2 (ppr rdr) + | otherwise = hang herald 2 (pp_rdr_with_type rdr hole_ty) + boring_type = isTyVarTy hole_ty +pprHoleError ctxt (Hole { hole_ty, hole_occ}) (HoleError sort other_tvs hole_skol_info) = + vcat [ hole_msg + , tyvars_msg + , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] + + where + + hole_msg = case sort of + ExprHole {} -> + hang (text "Found hole:") + 2 (pp_rdr_with_type hole_occ hole_ty) + TypeHole -> + hang (text "Found type wildcard" <+> quotes (ppr hole_occ)) + 2 (text "standing for" <+> quotes pp_hole_type_with_kind) + ConstraintHole -> + hang (text "Found extra-constraints wildcard standing for") + 2 (quotes $ pprType hole_ty) -- always kind Constraint + + hole_kind = typeKind hole_ty + + pp_hole_type_with_kind + | isLiftedTypeKind hole_kind + || isEqPred hole_ty -- Don't print the kind of unlifted + -- equalities (#15039) + = pprType hole_ty + | otherwise + = pprType hole_ty <+> dcolon <+> pprKind hole_kind + + tyvars = tyCoVarsOfTypeList hole_ty + tyvars_msg = ppUnless (null tyvars) $ + text "Where:" <+> (vcat (map loc_msg other_tvs) + $$ pprSkols ctxt hole_skol_info) + -- Coercion variables can be free in the + -- hole, via kind casts + expr_hole_hint -- Give hint for, say, f x = _x + | lengthFS (occNameFS (rdrNameOcc hole_occ)) > 1 -- Don't give this hint for plain "_" + = text "Or perhaps" <+> quotes (ppr hole_occ) + <+> text "is mis-spelled, or not in scope" + | otherwise + = empty + + type_hole_hint + | ErrorWithoutFlag <- cec_type_holes ctxt + = text "To use the inferred type, enable PartialTypeSignatures" + | otherwise + = empty + + loc_msg tv + | isTyVar tv + = case tcTyVarDetails tv of + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" + _ -> empty -- Skolems dealt with already + | otherwise -- A coercion variable can be free in the hole type + = ppWhenOption sdocPrintExplicitCoercions $ + quotes (ppr tv) <+> text "is a coercion variable" + +pp_rdr_with_type :: RdrName -> Type -> SDoc +pp_rdr_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) + +{- ********************************************************************* +* * + Outputting ScopeError messages +* * +**********************************************************************-} + +pprScopeError :: RdrName -> NotInScopeError -> SDoc +pprScopeError rdr_name scope_err = + case scope_err of + NotInScope -> + hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + NotARecordField -> + hang (text "Not in scope:") + 2 (text "record field" <+> quotes (ppr rdr_name)) + NoExactName name -> + text "The Name" <+> quotes (ppr name) <+> text "is not in scope." + SameName gres -> + assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres)) + $ hang (text "Same Name in multiple name-spaces:") + 2 (vcat (map pp_one sorted_names)) + where + sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) + $ map greName gres + pp_one name + = hang (pprNameSpace (occNameSpace (getOccName name)) + <+> quotes (ppr name) <> comma) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) + MissingBinding sig _ -> + sep [ text "The" <+> pprSigLike sig + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding" ] + NoTopLevelBinding -> + hang (text "No top-level binding for") + 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") + UnknownSubordinate parent_nm sub -> + quotes (ppr rdr_name) <+> text "is not a (visible)" <+> pprSubordinate parent_nm sub + NotInScopeTc env -> + vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+> + text "is not in scope during type checking, but it passed the renamer", + text "tcl_env of environment:" <+> ppr env] + where + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + +scopeErrorHints :: NotInScopeError -> [GhcHint] +scopeErrorHints scope_err = + case scope_err of + NotInScope -> noHints + NotARecordField -> noHints + NoExactName {} -> [SuggestDumpSlices] + SameName {} -> [SuggestDumpSlices] + MissingBinding _ hints -> hints + NoTopLevelBinding -> noHints + UnknownSubordinate {} -> noHints + NotInScopeTc _ -> noHints + +tcSolverReportMsgHints :: SolverReportErrCtxt -> TcSolverReportMsg -> [GhcHint] +tcSolverReportMsgHints ctxt = \case + BadTelescope {} + -> noHints + UserTypeError {} + -> noHints + UnsatisfiableError {} + -> noHints + ReportHoleError {} + -> noHints + CannotUnifyVariable mismatch_msg rea + -> mismatchMsgHints ctxt mismatch_msg ++ cannotUnifyVariableHints rea + Mismatch { mismatchMsg = mismatch_msg } + -> mismatchMsgHints ctxt mismatch_msg + FixedRuntimeRepError {} + -> noHints + ExpectingMoreArguments {} + -> noHints + UnboundImplicitParams {} + -> noHints + AmbiguityPreventsSolvingCt {} + -> noHints + CannotResolveInstance {} + -> noHints + OverlappingInstances {} + -> noHints + UnsafeOverlap {} + -> noHints + MultiplicityCoercionsNotSupported {} + -> noHints + +mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint] +mismatchMsgHints ctxt msg = + maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg + , hint <- suggestAddSig ctxt exp act ] + +mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type) +mismatchMsg_ExpectedActuals = \case + BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } -> + Just (exp, act) + TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } -> + Just (exp,act) + CouldNotDeduce { cnd_extra = cnd_extra } + | Just (CND_Extra _ exp act) <- cnd_extra + -> Just (exp, act) + | otherwise + -> Nothing + +cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint] +cannotUnifyVariableHints = \case + CannotUnifyWithPolytype {} + -> noHints + OccursCheck {} + -> noHints + SkolemEscape {} + -> noHints + DifferentTyVars {} + -> noHints + RepresentationalEq {} + -> noHints + +suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint +-- See Note [Suggest adding a type signature] +suggestAddSig ctxt ty1 _ty2 + | bndr : bndrs <- inferred_bndrs + = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs) + | otherwise + = Nothing + where + inferred_bndrs = + case getTyVar_maybe ty1 of + Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv + _ -> [] + + -- 'find' returns the binders of an InferSkol for 'tv', + -- provided there is an intervening implication with + -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match) + find [] _ _ = [] + find (implic:implics) seen_eqs tv + | tv `elem` ic_skols implic + , InferSkol prs <- ic_info implic + , seen_eqs + = map fst prs + | otherwise + = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv + +{- Note [Suggest adding a type signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The OutsideIn algorithm rejects GADT programs that don't have a principal +type, and indeed some that do. Example: + data T a where + MkT :: Int -> T Int + + f (MkT n) = n + +Does this have type f :: T a -> a, or f :: T a -> Int? +The error that shows up tends to be an attempt to unify an +untouchable type variable. So suggestAddSig sees if the offending +type variable is bound by an *inferred* signature, and suggests +adding a declared signature instead. + +More specifically, we suggest adding a type sig if we have p ~ ty, and +p is a skolem bound by an InferSkol. Those skolems were created from +unification variables in simplifyInfer. Why didn't we unify? It must +have been because of an intervening GADT or existential, making it +untouchable. Either way, a type signature would help. For GADTs, it +might make it typeable; for existentials the attempt to write a +signature will fail -- or at least will produce a better error message +next time + +This initially came up in #8968, concerning pattern synonyms. +-} + +{- ********************************************************************* +* * + Outputting ImportError messages +* * +**********************************************************************-} + +instance Outputable ImportError where + ppr err = note $ case err of + MissingModule mod_name -> "No module named" <+> quoted mod_name <+> "is imported" + ModulesDoNotExport mods what_look occ_name + | mod NE.:| [] <- mods -> "The module" <+> quoted mod <+> "does not export" <+> what <+> quoted occ_name + | otherwise -> "Neither" <+> quotedListWithNor (map ppr $ NE.toList mods) <+> "export" <+> what <+> quoted occ_name + where + what :: SDoc + what = case what_look of + WL_ConLike -> text "data constructor" + WL_RecField -> text "record field" + _ -> empty + where + quoted :: Outputable a => a -> SDoc + quoted = quotes . ppr + +{- ********************************************************************* +* * + Suggested fixes for implication constraints +* * +**********************************************************************-} + +-- TODO: these functions should use GhcHint instead. + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] + +ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] +ctxtFixes has_ambig_tvs pred implics + | not has_ambig_tvs + , isTyVarClassPred pred -- Don't suggest adding (Eq T) to the context, say + , (skol:skols) <- usefulContext implics pred + , let what | null skols + , SigSkol (PatSynCtxt {}) _ _ <- skol + = text "\"required\"" + | otherwise + = empty + = [sep [ text "add" <+> pprParendType pred + <+> text "to the" <+> what <+> text "context of" + , nest 2 $ ppr_skol skol $$ + vcat [ text "or" <+> ppr_skol skol + | skol <- skols ] ] ] + | otherwise = [] + where + ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) + ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) + ppr_skol skol_info = ppr skol_info + +usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon] +-- usefulContext picks out the implications whose context +-- the programmer might plausibly augment to solve 'pred' +usefulContext implics pred + = go implics + where + pred_tvs = tyCoVarsOfType pred + go [] = [] + go (ic : ics) + | implausible ic = rest + | otherwise = ic_info ic : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature + +pp_from_givens :: [Implication] -> [SDoc] +pp_from_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs + where + ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) + = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) + -- See Note [Suppress redundant givens during error reporting] + -- for why we use mkMinimalBySCs above. + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr (getCtLocEnvLoc (ic_env implic)) ]) + +{- ********************************************************************* +* * + CtOrigin information +* * +**********************************************************************-} + +levelString :: TypeOrKind -> String +levelString TypeLevel = "type" +levelString KindLevel = "kind" + +pprArising :: CtLoc -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq, KindEq, givens +pprArising ct_loc + | in_generated_code = empty -- See Note ["Arising from" messages in generated code] + | suppress_origin = empty + | otherwise = pprCtOrigin orig + where + orig = ctLocOrigin ct_loc + in_generated_code = ctLocEnvInGeneratedCode (ctLocEnv ct_loc) + suppress_origin + | isGivenOrigin orig = True + | otherwise = case orig of + TypeEqOrigin {} -> True -- We've done special processing + KindEqOrigin {} -> True -- for TypeEq, KindEq, givens + AmbiguityCheckOrigin {} -> True -- The "In the ambiguity check" context + -- is sufficient; more would be repetitive + _ -> False + +-- Add the "arising from..." part to a message +addArising :: CtLoc -> SDoc -> SDoc +addArising ct_loc msg = hang msg 2 (pprArising ct_loc) + +pprWithArising :: [Ct] -> SDoc +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = addArising loc (pprTheta [ctPred ct]) + | otherwise + = vcat (map ppr_one (ct:cts)) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprCtLoc (ctLoc ct')) + +{- Note ["Arising from" messages in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider code generated when we desugar code before typechecking; +see Note [Rebindable syntax and XXExprGhcRn]. + +In this code, constraints may be generated, but we don't want to +say "arising from a call of foo" if 'foo' doesn't appear in the +users code. We leave the actual CtOrigin untouched (partly because +it is generated in many, many places), but suppress the "Arising from" +message for constraints that originate in generated code. +-} + + +{- ********************************************************************* +* * + SkolemInfo +* * +**********************************************************************-} + + +tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo +tidySkolemInfo env (SkolemInfo u sk_anon) = SkolemInfo u (tidySkolemInfoAnon env sk_anon) + +---------------- +tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon +tidySkolemInfoAnon env (DerivSkol ty) = DerivSkol (tidyType env ty) +tidySkolemInfoAnon env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs +tidySkolemInfoAnon env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfoAnon env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) +tidySkolemInfoAnon _ info = info + +tidySigSkol :: TidyEnv -> UserTypeCtxt + -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon +-- We need to take special care when tidying SigSkol +-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin" +tidySigSkol env cx ty tv_prs + = SigSkol cx (tidy_ty env ty) tv_prs' + where + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs + inst_env = mkNameEnv tv_prs' + + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) + where + (env', tv') = tidy_tv_bndr env tv + + tidy_ty env ty@(FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) + = -- Look under c => t and t1 -> t2 + ty { ft_mult = tidy_ty env w + , ft_arg = tidyType env arg + , ft_res = tidy_ty env res } + + tidy_ty env ty = tidyType env ty + + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) + tidy_tv_bndr env@(occ_env, subst) tv + | Just tv' <- lookupNameEnv inst_env (tyVarName tv) + = ((occ_env, extendVarEnv subst tv tv'), tv') + + | otherwise + = tidyVarBndr env tv + +pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc +pprSkols ctxt zonked_ty_vars + = + let tidy_ty_vars = map (bimap (tidySkolemInfoAnon (cec_tidy ctxt)) id) zonked_ty_vars + in vcat (map pp_one tidy_ty_vars) + where + + no_msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr zonked_ty_vars + $$ text "This should not happen, please report it as a bug following the instructions at:" + $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" + + + pp_one (UnkSkol cs, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "(rigid, skolem)") + , nest 2 (text "of unknown origin") + , nest 2 (text "bound at" <+> ppr (skolsSpan tvs)) + , no_msg + , prettyCallStackDoc cs + ] + pp_one (RuntimeUnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown runtime") + pp_one (skol_info, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "rigid" <+> text "bound by") + , nest 2 (pprSkolInfo skol_info) + , nest 2 (text "at" <+> ppr (skolsSpan tvs)) ] + + is_or_are [_] article adjective = text "is" <+> text article <+> text adjective + <+> text "type variable" + is_or_are _ _ adjective = text "are" <+> text adjective + <+> text "type variables" + +skolsSpan :: [TcTyVar] -> SrcSpan +skolsSpan skol_tvs = foldr1WithDefault noSrcSpan combineSrcSpans (map getSrcSpan skol_tvs) + +{- ********************************************************************* +* * + Utilities for expected/actual messages +* * +**********************************************************************-} + +mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind + -> Type -> Type -> CtOrigin -> SDoc +mk_supplementary_ea_msg ctxt level ty1 ty2 orig + | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig + , not (ea_looks_same ty1 ty2 exp act) + = case mk_ea_msg ctxt Nothing level orig of + Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos + Right msg -> msg + | otherwise + = empty + +ea_looks_same :: Type -> Type -> Type -> Type -> Bool +-- True if the faulting types (ty1, ty2) look the same as +-- the expected/actual types (exp, act). +-- If so, we don't want to redundantly report the latter +ea_looks_same ty1 ty2 exp act + = (act `looks_same` ty1 && exp `looks_same` ty2) || + (exp `looks_same` ty1 && act `looks_same` ty2) + where + looks_same t1 t2 = t1 `pickyEqType` t2 + || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind + -- pickyEqType is sensitive to synonyms, so only replies True + -- when the types really look the same. However, + -- (TYPE 'LiftedRep) and Type both print the same way. + +mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind + -> CtOrigin -> Either [ExpectedActualInfo] SDoc +-- Constructs a "Couldn't match" message +-- The (Maybe ErrorItem) says whether this is the main top-level message (Just) +-- or a supplementary message (Nothing) +mk_ea_msg ctxt at_top level + (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) + | Just thing <- mb_thing + , KindLevel <- level + = Right $ pprKindMismatchMsg thing exp act + | Just item <- at_top + , let ea = EA $ if expanded_syns then Just ea_expanded else Nothing + mismatch = mkBasicMismatchMsg ea item exp act + = Right (pprMismatchMsg ctxt mismatch) + | otherwise + = Left $ + if expanded_syns + then [ea,ea_expanded] + else [ea] + + where + ea = ExpectedActual { ea_expected = exp, ea_actual = act } + ea_expanded = + ExpectedActualAfterTySynExpansion + { ea_expanded_expected = expTy1 + , ea_expanded_actual = expTy2 } + + expanded_syns = cec_expand_syns ctxt + && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) + (expTy1, expTy2) = expandSynonymsToMatch exp act +mk_ea_msg _ _ _ _ = Left [] + +{- Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. Given two types t1 and t2: + + * If they're already same, it just returns the types. + + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it expands C1 and C2 if they're different type synonyms. + Then it recursively does the same thing on expanded types. If C1 and C2 are + same, then it applies the same procedure to arguments of C1 and arguments of + C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, + Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and + `T (T3, T3, Bool)`. + + * Otherwise types don't have same shapes and so the difference is clearly + visible. It doesn't do any expansions and show these types. + +Note that we only expand top-layer type synonyms. Only when top-layer +constructors are the same we start expanding inner type synonyms. + +Suppose top-layer type synonyms of t1 and t2 can expand N and M times, +respectively. If their type-synonym-expanded forms will meet at some point (i.e. +will have same shapes according to `sameShapes` function), it's possible to find +where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) +comparisons. We first collect all the top-layer expansions of t1 and t2 in two +lists, then drop the prefix of the longer list so that they have same lengths. +Then we search through both lists in parallel, and return the first pair of +types that have same shapes. Inner types of these two types with same shapes +are then expanded using the same algorithm. + +In case they don't meet, we return the last pair of types in the lists, which +has top-layer type synonyms completely expanded. (in this case the inner types +are not expanded at all, as the current form already shows the type error) +-} + +-- | Expand type synonyms in given types only enough to make them as similar as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +-- +-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for +-- some examples of how this should work. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (ty1_ret, ty2_ret) = go ty1 ty2 + + -- Returns (type synonym expanded version of first type, + -- type synonym expanded version of second type) + go :: Type -> Type -> (Type, Type) + go t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (t1, t2) + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. The lengths of tys1 and tys2 must be equal; + -- for example, with type S a = a, we don't want + -- to zip (S Monad Int) and (S Bool). + let (tys1', tys2') = unzip (zipWithEqual go tys1 tys2) + in (TyConApp tc1 tys1', TyConApp tc2 tys2') + + go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') + + go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } + , ty2 { ft_arg = t2_1', ft_res = t2_2' }) + + go (ForAllTy b1 t1) (ForAllTy b2 t2) = + -- NOTE: We may have a bug here, but we just can't reproduce it easily. + -- See D1016 comments for details and our attempts at producing a test + -- case. Short version: We probably need RnEnv2 to really get this right. + let (t1', t2') = go t1 t2 + in (ForAllTy b1 t1', ForAllTy b2 t2') + + go (CastTy ty1 _) ty2 = go ty1 ty2 + go ty1 (CastTy ty2 _) = go ty1 ty2 + + go t1 t2 = + -- See Note [Expanding type synonyms to make types similar] for how this + -- works + let + t1_exp_tys = t1 : tyExpansions t1 + t2_exp_tys = t2 : tyExpansions t2 + t1_exps = length t1_exp_tys + t2_exps = length t2_exp_tys + dif = abs (t1_exps - t2_exps) + in + followExpansions $ + zipEqual + (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) + (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) + + -- Expand the top layer type synonyms repeatedly, collect expansions in a + -- list. The list does not include the original type. + -- + -- Example, if you have: + -- + -- type T10 = T9 + -- type T9 = T8 + -- ... + -- type T0 = Int + -- + -- `tyExpansions T10` returns [T9, T8, T7, ..., Int] + -- + -- This only expands the top layer, so if you have: + -- + -- type M a = Maybe a + -- + -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) + tyExpansions :: Type -> [Type] + tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` coreView t) + + -- Drop the type pairs until types in a pair look alike (i.e. the outer + -- constructors are the same). + followExpansions :: [(Type, Type)] -> (Type, Type) + followExpansions [] = pprPanic "followExpansions" empty + followExpansions [(t1, t2)] + | sameShapes t1 t2 = go t1 t2 -- expand subtrees + | otherwise = (t1, t2) -- the difference is already visible + followExpansions ((t1, t2) : tss) + -- Traverse subtrees when the outer shapes are the same + | sameShapes t1 t2 = go t1 t2 + -- Otherwise follow the expansions until they look alike + | otherwise = followExpansions tss + + sameShapes :: Type -> Type -> Bool + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx vs) = text "the type signature for" <+> ppr_sig_bndrs vs +pprHsDocContext (StandaloneKindSigCtx v)= text "the standalone kind signature for" <+> quotes (ppr v) +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) +pprHsDocContext (SpecECtx name) = text "the SPECIALISE pragma for" <+> quotes (ppr name) +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext HsTypePatCtx = text "a type argument in a pattern" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ReifyInstancesCtx = text "GHC.Tc.Gen.Splice.reifyInstances" +pprHsDocContext (ClassInstanceCtx inst_ty) = + text "the instance declaration for" <+> quotes (ppr inst_ty) +pprHsDocContext (ClassMethodSigCtx name) = text "a class method signature for" <+> quotes (ppr name) +pprHsDocContext (SpecialiseSigCtx name) = text "a SPECIALISE signature for" <+> quotes (ppr name) +pprHsDocContext (PatSynSigCtx vs) = + text "a pattern synonym signature for" <+> ppr_sig_bndrs vs + +pprHsDocContext (ForeignDeclCtx name) + = text "the foreign declaration for" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names + +ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) + +pprConversionFailReason :: ConversionFailReason -> SDoc +pprConversionFailReason = \case + IllegalOccName ctxt_ns occ -> + text "Illegal" <+> pprNameSpace ctxt_ns + <+> text "name:" <+> quotes (text occ) + SumAltArityExceeded alt arity -> + text "Sum alternative" <+> int alt + <+> text "exceeds its arity," <+> int arity + IllegalSumAlt alt -> + vcat [ text "Illegal sum alternative:" <+> int alt + , nest 2 $ text "Sum alternatives must start from 1" ] + IllegalSumArity arity -> + vcat [ text "Illegal sum arity:" <+> int arity + , nest 2 $ text "Sums must have an arity of at least 2" ] + MalformedType typeOrKind ty -> + text "Malformed " <> text ty_str <+> text (show ty) + where ty_str = case typeOrKind of + TypeLevel -> "type" + KindLevel -> "kind" + IllegalLastStatement do_or_lc stmt -> + vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon + , nest 2 $ ppr stmt + , text "(It should be an expression.)" ] + KindSigsOnlyAllowedOnGADTs -> + text "Kind signatures are only allowed on GADTs" + IllegalDeclaration declDescr bad_decls -> + sep [ text "Illegal" <+> what <+> text "in" <+> descrDoc <> colon + , nest 2 bads ] + where + (what, bads) = case bad_decls of + IllegalDecls (NE.toList -> decls) -> + (text "declaration" <> plural decls, vcat $ map ppr decls) + IllegalFamDecls (NE.toList -> decls) -> + ( text "family declaration" <> plural decls, vcat $ map ppr decls) + descrDoc = text $ case declDescr of + InstanceDecl -> "an instance declaration" + WhereClause -> "a where clause" + LetBinding -> "a let expression" + LetExpression -> "a let expression" + ClssDecl -> "a class declaration" + CannotMixGADTConsWith98Cons -> + text "Cannot mix GADT constructors with Haskell 98" + <+> text "constructors" + EmptyStmtListInDoBlock -> + text "Empty stmt list in do-block" + NonVarInInfixExpr -> + text "Non-variable expression is not allowed in an infix expression" + MultiWayIfWithoutAlts -> + text "Multi-way if-expression with no alternatives" + CasesExprWithoutAlts -> + text "\\cases expression with no alternatives" + ImplicitParamsWithOtherBinds -> + text "Implicit parameters mixed with other bindings" + InvalidCCallImpent from -> + text (show from) <+> text "is not a valid ccall impent" + RecGadtNoCons -> + quotes (text "RecGadtC") <+> text "must have at least one constructor name" + GadtNoCons -> + quotes (text "GadtC") <+> text "must have at least one constructor name" + InvalidTypeInstanceHeader tys -> + text "Invalid type instance header:" + <+> text (show tys) + InvalidTyFamInstLHS lhs -> + text "Invalid type family instance LHS:" + <+> text (show lhs) + InvalidImplicitParamBinding -> + text "Implicit parameter binding only allowed in let or where" + DefaultDataInstDecl adts -> + (text "Default data instance declarations" + <+> text "are not allowed:") + $$ ppr adts + FunBindLacksEquations nm -> + text "Function binding for" + <+> quotes (text (TH.pprint nm)) + <+> text "has no equations" + EmptyGuard -> + text "Empty guard" + EmptyParStmt -> + text "Empty par stmt" + +pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc +pprTyThingUsedWrong sort thing name = + pprTcTyThingCategory thing <+> quotes (ppr name) <+> + text "used as a" <+> pprWrongThingSort sort + +pprWrongThingSort :: WrongThingSort -> SDoc +pprWrongThingSort = + text . \case + WrongThingType -> "type" + WrongThingDataCon -> "data constructor" + WrongThingPatSyn -> "pattern synonym" + WrongThingConLike -> "constructor-like thing" + WrongThingClass -> "class" + WrongThingTyCon -> "type constructor" + WrongThingAxiom -> "axiom" + +pprLevelCheckReason :: LevelCheckReason -> SDoc +pprLevelCheckReason = \case + LevelCheckInstance _ t -> + text "instance for" <+> quotes (ppr t) + LevelCheckSplice t _ -> + quotes (ppr t) + +pprUninferrableTyVarCtx :: UninferrableTyVarCtx -> SDoc +pprUninferrableTyVarCtx = \case + UninfTyCtx_ClassContext theta -> + sep [ text "the class context:", pprTheta theta ] + UninfTyCtx_DataContext theta -> + sep [ text "the datatype context:", pprTheta theta ] + UninfTyCtx_ProvidedContext theta -> + sep [ text "the provided context:" , pprTheta theta ] + UninfTyCtx_TyFamRhs rhs_ty -> + sep [ text "the type family equation right-hand side:" , ppr rhs_ty ] + UninfTyCtx_TySynRhs rhs_ty -> + sep [ text "the type synonym right-hand side:" , ppr rhs_ty ] + UninfTyCtx_Sig exp_kind full_hs_ty -> + hang (text "the kind" <+> ppr exp_kind) 2 + (text "of the type signature:" <+> ppr full_hs_ty) + +pprPatSynInvalidRhsReason :: PatSynInvalidRhsReason -> SDoc +pprPatSynInvalidRhsReason = \case + PatSynNotInvertible p -> + text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" + PatSynUnboundVar var -> + quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym" + +pprBadFieldAnnotationReason :: BadFieldAnnotationReason -> SDoc +pprBadFieldAnnotationReason = \case + LazyFieldsDisabled -> + text "Lazy field annotations (~) are disabled" + UnpackWithoutStrictness -> + text "UNPACK pragma lacks '!'" + UnusableUnpackPragma -> + text "Ignoring unusable UNPACK pragma" + +pprSuperclassCycleDetail :: SuperclassCycleDetail -> SDoc +pprSuperclassCycleDetail = \case + SCD_HeadTyVar pred -> + hang (text "one of whose superclass constraints is headed by a type variable:") + 2 (quotes (ppr pred)) + SCD_HeadTyFam pred -> + hang (text "one of whose superclass constraints is headed by a type family:") + 2 (quotes (ppr pred)) + SCD_Superclass cls -> + text "one of whose superclasses is" <+> quotes (ppr cls) + +pprRoleValidationFailedReason :: Role -> RoleValidationFailedReason -> SDoc +pprRoleValidationFailedReason role = \case + TyVarRoleMismatch tv role' -> + text "type variable" <+> quotes (ppr tv) <+> + text "cannot have role" <+> ppr role <+> + text "because it was assigned role" <+> ppr role' + TyVarMissingInEnv tv -> + text "type variable" <+> quotes (ppr tv) <+> text "missing in environment" + BadCoercionRole co -> + text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role + +pprDisabledClassExtension :: Class -> DisabledClassExtension -> SDoc +pprDisabledClassExtension cls = \case + MultiParamDisabled n -> + text howMany <+> text "parameters for class" <+> quotes (ppr cls) + where + howMany | n == 0 = "No" + | otherwise = "Too many" + FunDepsDisabled -> + text "Fundeps in class" <+> quotes (ppr cls) + ConstrainedClassMethodsDisabled sel_id pred -> + vcat [ hang (text "Constraint" <+> quotes (ppr pred) + <+> text "in the type of" <+> quotes (ppr sel_id)) + 2 (text "constrains only the class type variables")] + +pprImportLookup :: ImportLookupReason -> SDoc +pprImportLookup = \case + ImportLookupBad k iface decl_spec ie _exts -> + let + pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc + pprImpDeclSpec iface decl_spec = + quotes (ppr (moduleName $ is_mod decl_spec)) <+> case mi_boot iface of + IsBoot -> text "(hi-boot interface)" + NotBoot -> empty + withContext msgs = + hang (text "In the import of" <+> pprImpDeclSpec iface decl_spec <> colon) + 2 (vcat msgs) + in case k of + BadImportNotExported _ -> + vcat + [ text "Module" <+> pprImpDeclSpec iface decl_spec <+> + text "does not export" <+> quotes (ppr ie) <> dot + ] + BadImportAvailVar -> + withContext + [ text "an item called" + <+> quotes val <+> text "is exported, but it is not a type." + ] + where + val_occ = rdrNameOcc $ ieName ie + val = parenSymOcc val_occ (ppr val_occ) + BadImportAvailTyCon {} -> + withContext + [ text "an item called" + <+> quotes tycon <+> text "is exported, but it is a type." + ] + where + tycon_occ = rdrNameOcc $ ieName ie + tycon = parenSymOcc tycon_occ (ppr tycon_occ) + BadImportNotExportedSubordinates gre unavailable1 -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported, but it does not export" + , text "any" <+> what_children <+> text "called" <+> unavailable_names <> dot + ] + where + unavailable = NE.toList unavailable1 + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + unavailable_names = pprWithCommas (quotes . ppr) unavailable + any_names p = any (p . unpackFS) unavailable + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" + what_children = unquotedListWith "or" $ case greInfo gre of + IAmTyCon ClassFlavour -> + [text "class methods" | any_names okVarOcc ] ++ + [text "associated types" | any_names okTcOcc ] + IAmTyCon _ -> + [text "constructors" | any_names okConOcc ] ++ + [text "record fields" | any_names okVarOcc ] + _ -> [text "children"] + BadImportNonTypeSubordinates gre nontype1 -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported," + , sep [ text "but its subordinate item" <> plural nontype <+> nontype_names + , isOrAre nontype <+> "not in the type namespace." ] ] + where + nontype = NE.toList nontype1 + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + nontype_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nontype + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" + BadImportNonDataSubordinates gre nondata1 -> + withContext + [ what <+> text "called" <+> parent_name <+> text "is exported," + , sep [ text "but its subordinate item" <> plural nondata <+> nondata_names + , isOrAre nondata <+> "not in the data namespace." ] ] + where + nondata = NE.toList nondata1 + parent_name = (quotes . pprPrefixOcc . nameOccName . gre_name) gre + nondata_names = pprWithCommas (quotes . pprPrefixOcc . nameOccName . gre_name) nondata + what = case greInfo gre of + IAmTyCon ClassFlavour -> text "a class" + IAmTyCon _ -> text "a data type" + _ -> text "an item" + BadImportAvailDataCon dataType_occ -> + withContext + [ text "an item called" <+> quotes datacon + , text "is exported, but it is a data constructor of" + , quotes dataType <> dot + ] + where + datacon_occ = rdrNameOcc $ ieName ie + datacon = parenSymOcc datacon_occ (ppr datacon_occ) + dataType = parenSymOcc dataType_occ (ppr dataType_occ) + ImportLookupQualified rdr -> + hang (text "Illegal qualified name in import item:") + 2 (ppr rdr) + ImportLookupIllegal -> + text "Illegal import item" + ImportLookupAmbiguous rdr gres -> + hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") + 2 (vcat (map (ppr . greOccName) gres)) + +pprUnusedImport :: ImportDecl GhcRn -> UnusedImportReason -> SDoc +pprUnusedImport decl = \case + UnusedImportNone -> + vcat [ pp_herald <+> quotes pp_mod <+> text "is redundant" + , nest 2 (text "except perhaps to import instances from" + <+> quotes pp_mod) + , text "To import instances alone, use:" + <+> text "import" <+> pp_mod <> parens empty ] + UnusedImportSome sort_unused -> + sep [ pp_herald <+> quotes (pprWithCommas pp_unused sort_unused) + , text "from module" <+> quotes pp_mod <+> text "is redundant"] + where + pp_mod = ppr (unLoc (ideclName decl)) + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | isImportDeclQualified (ideclQualified decl) = text "qualified" + | otherwise = empty + pp_unused = \case + UnusedImportNameRegular n -> + pprNameUnqualified n + UnusedImportNameRecField par fld_occ -> + case par of + ParentIs p -> pprNameUnqualified p <> parens (ppr fld_occ) + NoParent -> ppr fld_occ + +pprUnusedName :: OccName -> UnusedNameProv -> SDoc +pprUnusedName name reason = + sep [ msg <> colon + , nest 2 $ pprNonVarNameSpace (occNameSpace name) + <+> quotes (ppr name)] + where + msg = case reason of + UnusedNameTopDecl -> + defined + UnusedNameImported mod -> + text "Imported from" <+> quotes (ppr mod) <+> text "but not used" + UnusedNameTypePattern -> + defined <+> text "on the right hand side" + UnusedNameMatch -> + defined + UnusedNameLocalBind -> + defined + defined = text "Defined but not used" + +-- When printing the name, take care to qualify it in the same +-- way as the provenance reported by pprNameProvenance, namely +-- the head of 'gre_imp'. Otherwise we get confusing reports like +-- Ambiguous occurrence ‘null’ +-- It could refer to either ‘T15487a.null’, +-- imported from ‘Prelude’ at T15487.hs:1:8-13 +-- or ... +-- See #15487 +pprAmbiguousGreName :: GlobalRdrEnv -> GlobalRdrElt -> SDoc +pprAmbiguousGreName gre_env gre + | IAmRecField fld_info <- greInfo gre + = sep [ text "the field" <+> quotes (ppr occ) <+> parent_info fld_info <> comma + , pprNameProvenance gre ] + | otherwise + = sep [ quotes (pp_qual <> dot <> ppr occ) <> comma + , pprNameProvenance gre ] + + where + occ = greOccName gre + parent_info fld_info = + case first_con of + PatSynName ps -> text "of pattern synonym" <+> quotes (ppr ps) + DataConName {} -> + case greParent gre of + ParentIs par + -- For a data family, only reporting the family TyCon can be + -- unhelpful (see T23301). So we give a bit of additional + -- info in that case. + | Just par_gre <- lookupGRE_Name gre_env par + , IAmTyCon tc_flav <- greInfo par_gre + , OpenFamilyFlavour (IAmData {}) _ <- tc_flav + -> vcat [ ppr_cons + , text "in a data family instance of" <+> quotes (ppr par) ] + | otherwise + -> text "of record" <+> quotes (ppr par) + NoParent -> ppr_cons + where + cons :: [ConLikeName] + cons = nonDetEltsUniqSet $ recFieldCons fld_info + first_con :: ConLikeName + first_con = head cons + ppr_cons :: SDoc + ppr_cons = hsep [ text "belonging to data constructor" + , quotes (ppr $ nameOccName $ conLikeName_Name first_con) + , if length cons > 1 then parens (text "among others") else empty + ] + pp_qual + | gre_lcl gre + = ppr (nameModule $ greName gre) + | Just imp <- headMaybe $ gre_imp gre + -- This 'imp' is the one that + -- pprNameProvenance chooses + , ImpDeclSpec { is_as = mod } <- is_decl imp + = ppr mod + | otherwise + = pprPanic "addNameClassErrRn" (ppr gre) + -- Invariant: either 'lcl' is True or 'iss' is non-empty + +pprNonCanonicalDefinition :: LHsSigType GhcRn + -> NonCanonicalDefinition + -> SDoc +pprNonCanonicalDefinition inst_ty = \case + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> + msg1 "(<>)" "mappend" + NonCanonical_Mappend -> + msg2 "mappend" "(<>)" + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> + msg1 "pure" "return" + NonCanonical_ThenA -> + msg1 "(*>)" "(>>)" + NonCanonical_Return -> + msg2 "return" "pure" + NonCanonical_ThenM -> + msg2 "(>>)" "(*>)" + where + msg1 :: String -> String -> SDoc + msg1 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , inst + ] + + msg2 :: String -> String -> SDoc + msg2 lhs rhs = + vcat [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , inst + , quotes (text lhs) <+> + text "will eventually be removed in favour of" <+> + quotes (text rhs) + ] + + inst = instDeclCtxt1 inst_ty + + -- stolen from GHC.Tc.TyCl.Instance + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + +suggestNonCanonicalDefinition :: NonCanonicalDefinition -> [GhcHint] +suggestNonCanonicalDefinition reason = + [action doc] + where + action = case reason of + NonCanonicalMonoid sub -> case sub of + NonCanonical_Sappend -> move sappendName mappendName + NonCanonical_Mappend -> remove mappendName sappendName + NonCanonicalMonad sub -> case sub of + NonCanonical_Pure -> move pureAName returnMName + NonCanonical_ThenA -> move thenAName thenMName + NonCanonical_Return -> remove returnMName pureAName + NonCanonical_ThenM -> remove thenMName thenAName + + move = SuggestMoveNonCanonicalDefinition + remove = SuggestRemoveNonCanonicalDefinition + + doc = case reason of + NonCanonicalMonoid _ -> doc_monoid + NonCanonicalMonad _ -> doc_monad + + doc_monoid = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" + doc_monad = + "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" + +suggestDefaultDeclaration :: Class-> [Type] -> [[Type]] -> [GhcHint] +suggestDefaultDeclaration cls prefix seqs = + [SuggestDefaultDeclaration cls $ supersequence (prefix : seqs)] + where + -- Not exactly the shortest possible supersequence, but it preserves + -- the head sequence as the prefix of the result which is a requirement. + supersequence :: [[Type]] -> [Type] + supersequence [] = [] + supersequence ([] : seqs) = supersequence seqs + supersequence ((x : xs) : seqs) = + x : supersequence (xs : (dropHead x <$> seqs)) + dropHead x ys@(y : ys') + | tcEqType x y = ys' + | otherwise = ys + dropHead _ [] = [] + +-------------------------------------------------------------------------------- +-- hs-boot mismatch errors + +pprBootMismatch :: HsBootOrSig -> BootMismatch -> SDoc +pprBootMismatch boot_or_sig = \case + MissingBootThing nm err -> + let def_or_exp = case err of + MissingBootDefinition -> text "defined in" + MissingBootExport -> text "exported by" + in quotes (ppr nm) <+> text "is exported by the" + <+> ppr_boot_or_sig <> comma + <+> text "but not" + <+> def_or_exp <+> text "the implementing module." + MissingBootInstance boot_dfun -> + hang (text "instance" <+> ppr (idType boot_dfun)) + 2 (text "is defined in the" <+> ppr ppr_boot_or_sig <> comma <+> + text "but not in the implementing module.") + BadReexportedBootThing name name' -> + withUserStyle alwaysQualify AllTheWay $ vcat + [ text "The" <+> ppr_boot_or_sig + <+> text "(re)exports" <+> quotes (ppr name) + , text "but the implementing module exports a different identifier" <+> quotes (ppr name') + ] + BootMismatch boot_thing real_thing err -> + vcat + [ ppr real_thing <+> + text "has conflicting definitions in the module" + , text "and its" <+> ppr_boot_or_sig <> dot, + text "Main module:" <+> real_doc + , (case boot_or_sig of + HsBoot -> text " Boot file:" + Hsig -> text " Hsig file:") <+> boot_doc + , pprBootMismatchWhat boot_or_sig err + ] + where + to_doc + = pprTyThingInContext $ + showToHeader + { ss_forall = + case boot_or_sig of + HsBoot -> ShowForAllMust + Hsig -> ShowForAllWhen } + + real_doc = to_doc real_thing + boot_doc = to_doc boot_thing + + where + ppr_boot_or_sig = case boot_or_sig of + HsBoot -> text "hs-boot file" + Hsig -> text "hsig file" + + +pprBootMismatchWhat :: HsBootOrSig -> BootMismatchWhat -> SDoc +pprBootMismatchWhat boot_or_sig = \case + BootMismatchedIdTypes {} -> + text "The two types are different." + BootMismatchedTyCons tc1 tc2 errs -> + vcat $ map (pprBootTyConMismatch boot_or_sig tc1 tc2) (NE.toList errs) + +pprBootTyConMismatch :: HsBootOrSig -> TyCon -> TyCon + -> BootTyConMismatch -> SDoc +pprBootTyConMismatch boot_or_sig tc1 tc2 = \case + TyConKindMismatch -> + text "The types have different kinds." + TyConRoleMismatch sub_type -> + if sub_type + then + text "The roles are not compatible:" $$ + text "Main module:" <+> ppr (tyConRoles tc1) $$ + text " Hsig file:" <+> ppr (tyConRoles tc2) + else + text "The roles do not match." $$ + if boot_or_sig == HsBoot + then note $ "Roles on abstract types default to" <+> quotes "representational" <+> "in hs-boot files" + else empty + TyConSynonymMismatch {} -> empty -- nothing interesting to say + TyConFlavourMismatch fam_flav1 fam_flav2 -> + whenPprDebug $ + text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> + text "do not match" + TyConAxiomMismatch ax_errs -> + pprBootListMismatches (text "Type family equations do not match:") + pprTyConAxiomMismatch ax_errs + TyConInjectivityMismatch {} -> + text "Injectivity annotations do not match" + TyConMismatchedClasses _ _ err -> + pprBootClassMismatch boot_or_sig err + TyConMismatchedData _rhs1 _rhs2 err -> + pprBootDataMismatch err + SynAbstractData err -> + pprSynAbstractDataError err + TyConsVeryDifferent -> + empty -- should be obvious to the user what the problem is + +pprSynAbstractDataError :: SynAbstractDataError -> SDoc +pprSynAbstractDataError = \case + SynAbsDataTySynNotNullary -> + text "Illegal parameterized type synonym in implementation of abstract data." + SynAbstractDataInvalidRHS bad_sub_tys -> + let msgs = mapMaybe pprInvalidAbstractSubTy (NE.toList bad_sub_tys) + in case msgs of + [] -> herald <> dot + msg:[] -> hang (herald <> colon) + 2 msg + _ -> hang (herald <> colon) + 2 (vcat $ map (<+> bullet) msgs) + + where + herald = text "Illegal implementation of abstract data" + pprInvalidAbstractSubTy = \case + TyConApp tc _ + -> assertPpr (isTypeFamilyTyCon tc) (ppr tc) $ + Just $ text "Invalid type family" <+> quotes (ppr tc) <> dot + ty@(ForAllTy {}) + -> Just $ text "Invalid polymorphic type" <> colon <+> ppr ty <> dot + ty@(FunTy af _ _ _) + | not (af == FTF_T_T) + -> Just $ text "Invalid qualified type" <> colon <+> ppr ty <> dot + _ -> Nothing + +pprTyConAxiomMismatch :: BootListMismatch CoAxBranch BootAxiomBranchMismatch -> SDoc +pprTyConAxiomMismatch = \case + MismatchedLength -> + text "The number of equations differs." + MismatchedThing i br1 br2 err -> + hang (text "The" <+> speakNth (i+1) <+> text "equations do not match.") + 2 (pprCoAxBranchMismatch br1 br2 err) + +pprCoAxBranchMismatch :: CoAxBranch -> CoAxBranch -> BootAxiomBranchMismatch -> SDoc +pprCoAxBranchMismatch _br1 _br2 err = + text "The" <+> what <+> text "don't match." + where + what = case err of + MismatchedAxiomBinders -> text "variables bound in the equation" + MismatchedAxiomLHS -> text "equation left-hand sides" + MismatchedAxiomRHS -> text "equation right-hand sides" + +pprBootListMismatches :: SDoc -- ^ herald + -> (BootListMismatch item err -> SDoc) + -> BootListMismatches item err -> SDoc +pprBootListMismatches herald ppr_one errs = + hang herald 2 msgs + where + msgs = case errs of + err :| [] -> ppr_one err + _ -> vcat $ map ((bullet <+>) . ppr_one) $ NE.toList errs + +pprBootClassMismatch :: HsBootOrSig -> BootClassMismatch -> SDoc +pprBootClassMismatch boot_or_sig = \case + MismatchedMethods errs -> + pprBootListMismatches (text "The class methods do not match:") + pprBootClassMethodListMismatch errs + MismatchedATs at_errs -> + pprBootListMismatches (text "The associated types do not match:") + (pprATMismatch boot_or_sig) at_errs + MismatchedFunDeps -> + text "The functional dependencies do not match." + MismatchedSuperclasses -> + text "The superclass constraints do not match." + MismatchedMinimalPragmas -> + text "The MINIMAL pragmas are not compatible." + +pprATMismatch :: HsBootOrSig -> BootListMismatch ClassATItem BootATMismatch -> SDoc +pprATMismatch boot_or_sig = \case + MismatchedLength -> + text "The number of associated type defaults differs." + MismatchedThing i at1 at2 err -> + pprATMismatchErr boot_or_sig i at1 at2 err + +pprATMismatchErr :: HsBootOrSig -> Int -> ClassATItem -> ClassATItem -> BootATMismatch -> SDoc +pprATMismatchErr boot_or_sig i (ATI tc1 _) (ATI tc2 _) = \case + MismatchedTyConAT err -> + hang (text "The associated types differ:") + 2 $ pprBootTyConMismatch boot_or_sig tc1 tc2 err + MismatchedATDefaultType -> + text "The types of the" <+> speakNth (i+1) <+> + text "associated type default differ." + +pprBootClassMethodListMismatch :: BootListMismatch ClassOpItem BootMethodMismatch -> SDoc +pprBootClassMethodListMismatch = \case + MismatchedLength -> + text "The number of class methods differs." + MismatchedThing _ op1 op2 err -> + pprBootClassMethodMismatch op1 op2 err + +pprBootClassMethodMismatch :: ClassOpItem -> ClassOpItem -> BootMethodMismatch -> SDoc +pprBootClassMethodMismatch (op1, _) (op2, _) = \case + MismatchedMethodNames -> + text "The method names" <+> quotes pname1 <+> text "and" + <+> quotes pname2 <+> text "differ." + MismatchedMethodTypes {} -> + text "The types of" <+> pname1 <+> text "are different." + MismatchedDefaultMethods subtype_check -> + if subtype_check + then + text "The default methods associated with" <+> pname1 <+> + text "are not compatible." + else + text "The default methods associated with" <+> pname1 <+> + text "are different." + where + nm1 = idName op1 + nm2 = idName op2 + pname1 = quotes (ppr nm1) + pname2 = quotes (ppr nm2) + +pprBootDataMismatch :: BootDataMismatch -> SDoc +pprBootDataMismatch = \case + MismatchedNewtypeVsData -> + text "Cannot match a" <+> quotes (text "data") <+> + text "definition with a" <+> quotes (text "newtype") <+> + text "definition." + MismatchedConstructors dc_errs -> + pprBootListMismatches (text "The constructors do not match:") + pprBootDataConMismatch dc_errs + MismatchedDatatypeContexts {} -> + text "The datatype contexts do not match." + +pprBootDataConMismatch :: BootListMismatch DataCon BootDataConMismatch + -> SDoc +pprBootDataConMismatch = \case + MismatchedLength -> + text "The number of constructors differs." + MismatchedThing _ dc1 dc2 err -> + pprBootDataConMismatchErr dc1 dc2 err + +pprBootDataConMismatchErr :: DataCon -> DataCon -> BootDataConMismatch -> SDoc +pprBootDataConMismatchErr dc1 dc2 = \case + MismatchedDataConNames -> + text "The names" <+> pname1 <+> text "and" <+> pname2 <+> text "differ." + MismatchedDataConFixities -> + text "The fixities of" <+> pname1 <+> text "differ." + MismatchedDataConBangs -> + text "The strictness annotations for" <+> pname1 <+> text "differ." + MismatchedDataConFieldLabels -> + text "The record label lists for" <+> pname1 <+> text "differ." + MismatchedDataConTypes -> + text "The types for" <+> pname1 <+> text "differ." + where + name1 = dataConName dc1 + name2 = dataConName dc2 + pname1 = quotes (ppr name1) + pname2 = quotes (ppr name2) + +-------------------------------------------------------------------------------- +-- Illegal instance errors + +pprIllegalInstance :: IllegalInstanceReason -> SDoc +pprIllegalInstance = \case + IllegalClassInstance head_ty reason -> + pprIllegalClassInstanceReason head_ty reason + IllegalFamilyInstance reason -> + pprIllegalFamilyInstance reason + IllegalFamilyApplicationInInstance inst_ty invis_arg tf_tc tf_args -> + pprWithInvisibleBitsWhen invis_arg $ + hang (text "Illegal type synonym family application" + <+> quotes (ppr tf_ty) <+> text "in instance" <> colon) + 2 (ppr inst_ty) + where + tf_ty = mkTyConApp tf_tc tf_args + +pprIllegalClassInstanceReason :: TypedThing -> IllegalClassInstanceReason -> SDoc +pprIllegalClassInstanceReason head_ty = \case + IllegalInstanceHead reason -> + pprIllegalInstanceHeadReason head_ty reason + IllegalHasFieldInstance has_field_err -> + with_illegal_instance_header head_ty $ + pprIllegalHasFieldInstance has_field_err + IllegalSpecialClassInstance cls because_safeHaskell -> + text "Class" <+> quotes (ppr $ className cls) + <+> text "does not support user-specified instances" + <> safeHaskell_msg + where + safeHaskell_msg + | because_safeHaskell + = text " when Safe Haskell is enabled." + | otherwise + = dot + IllegalInstanceFailsCoverageCondition cls coverage_failure -> + with_illegal_instance_header head_ty $ + pprNotCovered cls coverage_failure + +pprIllegalInstanceHeadReason :: TypedThing + -> IllegalInstanceHeadReason -> SDoc +pprIllegalInstanceHeadReason head_ty = \case + InstHeadTySynArgs -> with_illegal_instance_header head_ty $ + text "All instance types must be of the form (T t1 ... tn)" $$ + text "where T is not a synonym." + InstHeadNonTyVarArgs -> with_illegal_instance_header head_ty $ vcat [ + text "All instance types must be of the form (T a1 ... an)", + text "where a1 ... an are *distinct type variables*,", + text "and each type variable appears at most once in the instance head."] + InstHeadMultiParam -> with_illegal_instance_header head_ty $ parens $ + text "Only one type can be given in an instance head." + InstHeadAbstractClass cls -> + text "Cannot define instance for abstract class" <+> + quotes (ppr cls) + InstHeadNonClassHead bad_head -> + vcat [ text "Illegal" <+> what_illegal <> dot + , text "Instance heads must be of the form" + , nest 2 $ text "C ty_1 ... ty_n" + , text "where" <+> quotes (char 'C') <+> text "is a class." + ] + where + what_illegal = case bad_head of + InstNonClassTyCon tc_nm flav -> + text "instance for" <+> ppr flav <+> quotes (ppr tc_nm) + InstNonTyCon -> + text "head of an instance declaration:" <+> quotes (ppr head_ty) + +with_illegal_instance_header :: TypedThing -> SDoc -> SDoc +with_illegal_instance_header head_ty msg = + hang (hang (text "Illegal instance declaration for") + 2 (quotes (ppr head_ty)) <> colon) + 2 msg + +pprIllegalHasFieldInstance :: IllegalHasFieldInstance -> SDoc +pprIllegalHasFieldInstance = \case + IllegalHasFieldInstanceNotATyCon + -> text "Record data type must be specified." + IllegalHasFieldInstanceFamilyTyCon + -> text "Record data type may not be a data family." + IllegalHasFieldInstanceTyConHasField tc lbl + -> quotes (ppr tc) <+> text "already has a field" <+> quotes (ppr lbl) <> dot + IllegalHasFieldInstanceTyConHasFields tc lbl + -> sep [ ppr_tc <+> text "has fields, and the type" <+> quotes (ppr lbl) + , text "could unify with one of the field labels of" <+> ppr_tc <> dot ] + where ppr_tc = quotes (ppr tc) + +pprNotCovered :: Class -> CoverageProblem -> SDoc +pprNotCovered clas + CoverageProblem + { not_covered_fundep = fd + , not_covered_fundep_inst = (ls, rs) + , not_covered_invis_vis_tvs = undetermined_tvs + , not_covered_liberal = which_cc_failed + } = + pprWithInvisibleBitsWhen (isEmptyVarSet $ pSnd undetermined_tvs) $ + vcat [ sep [ text "The" + <+> ppWhen liberal (text "liberal") + <+> text "coverage condition fails in class" + <+> quotes (ppr clas) + , nest 2 $ text "for functional dependency:" + <+> quotes (pprFunDep fd) ] + , sep [ text "Reason: lhs type" <> plural ls <+> pprQuotedList ls + , nest 2 $ + (if isSingleton ls + then text "does not" + else text "do not jointly") + <+> text "determine rhs type" <> plural rs + <+> pprQuotedList rs ] + , text "Un-determined variable" <> pluralVarSet undet_set <> colon + <+> pprVarSet undet_set (pprWithCommas ppr) + ] + where + liberal = case which_cc_failed of + FailedLICC -> True + FailedICC {} -> False + undet_set = fold undetermined_tvs + +illegalInstanceHints :: IllegalInstanceReason -> [GhcHint] +illegalInstanceHints = \case + IllegalClassInstance _ reason -> + illegalClassInstanceHints reason + IllegalFamilyInstance reason -> + illegalFamilyInstanceHints reason + IllegalFamilyApplicationInInstance {} -> + noHints + +illegalInstanceReason :: IllegalInstanceReason -> DiagnosticReason +illegalInstanceReason = \case + IllegalClassInstance _ reason -> + illegalClassInstanceReason reason + IllegalFamilyInstance reason -> + illegalFamilyInstanceReason reason + IllegalFamilyApplicationInInstance {} -> + ErrorWithoutFlag + +illegalClassInstanceHints :: IllegalClassInstanceReason -> [GhcHint] +illegalClassInstanceHints = \case + IllegalInstanceHead reason -> + illegalInstanceHeadHints reason + IllegalHasFieldInstance has_field_err -> + illegalHasFieldInstanceHints has_field_err + IllegalSpecialClassInstance {} -> noHints + IllegalInstanceFailsCoverageCondition _ coverage_failure -> + failedCoverageConditionHints coverage_failure + + +illegalClassInstanceReason :: IllegalClassInstanceReason -> DiagnosticReason +illegalClassInstanceReason = \case + IllegalInstanceHead reason -> + illegalInstanceHeadReason reason + IllegalHasFieldInstance has_field_err -> + illegalHasFieldInstanceReason has_field_err + IllegalSpecialClassInstance {} -> ErrorWithoutFlag + IllegalInstanceFailsCoverageCondition _ coverage_failure -> + failedCoverageConditionReason coverage_failure + +illegalInstanceHeadHints :: IllegalInstanceHeadReason -> [GhcHint] +illegalInstanceHeadHints = \case + InstHeadTySynArgs -> + [suggestExtension LangExt.TypeSynonymInstances] + InstHeadNonTyVarArgs -> + [suggestExtension LangExt.FlexibleInstances] + InstHeadMultiParam -> + [suggestExtension LangExt.MultiParamTypeClasses] + InstHeadAbstractClass {} -> + noHints + InstHeadNonClassHead {} -> + noHints + +illegalInstanceHeadReason :: IllegalInstanceHeadReason -> DiagnosticReason +illegalInstanceHeadReason = \case + -- These are serious + InstHeadAbstractClass {} -> + ErrorWithoutFlag + InstHeadNonClassHead {} -> + ErrorWithoutFlag + + -- These are less serious (enable an extension) + InstHeadTySynArgs -> + ErrorWithoutFlag + InstHeadNonTyVarArgs -> + ErrorWithoutFlag + InstHeadMultiParam -> + ErrorWithoutFlag + +illegalHasFieldInstanceHints :: IllegalHasFieldInstance -> [GhcHint] +illegalHasFieldInstanceHints = \case + IllegalHasFieldInstanceNotATyCon + -> noHints + IllegalHasFieldInstanceFamilyTyCon + -> noHints + IllegalHasFieldInstanceTyConHasField {} + -> noHints + IllegalHasFieldInstanceTyConHasFields {} + -> noHints + +illegalHasFieldInstanceReason :: IllegalHasFieldInstance -> DiagnosticReason +illegalHasFieldInstanceReason = \case + IllegalHasFieldInstanceNotATyCon + -> ErrorWithoutFlag + IllegalHasFieldInstanceFamilyTyCon + -> ErrorWithoutFlag + IllegalHasFieldInstanceTyConHasField {} + -> ErrorWithoutFlag + IllegalHasFieldInstanceTyConHasFields {} + -> ErrorWithoutFlag + +failedCoverageConditionHints :: CoverageProblem -> [GhcHint] +failedCoverageConditionHints (CoverageProblem { not_covered_liberal = failed_cc }) + = case failed_cc of + FailedLICC -> noHints + FailedICC { alsoFailedLICC = failed_licc } -> + -- Turning on UndecidableInstances makes the check liberal, + -- so if the liberal check passes, suggest enabling UndecidableInstances. + if failed_licc + then noHints + else [suggestExtension LangExt.UndecidableInstances] + +failedCoverageConditionReason :: CoverageProblem -> DiagnosticReason +failedCoverageConditionReason _ = ErrorWithoutFlag + +pprIllegalFamilyInstance :: IllegalFamilyInstanceReason -> SDoc +pprIllegalFamilyInstance = \case + InvalidAssoc reason -> pprInvalidAssoc reason + NotAFamilyTyCon ty_or_data tc -> + vcat [ text "Illegal family instance for" <+> quotes (ppr tc) + , nest 2 $ parens (quotes (ppr tc) <+> text "is not a" <+> what) ] + where + what = ppr ty_or_data <+> text "family" + NotAnOpenFamilyTyCon tc -> + text "Illegal instance for closed family" <+> quotes (ppr tc) + FamilyCategoryMismatch tc -> + text "Wrong category of family instance; declaration was for a" <+> what <> dot + where + what = case tyConFlavour tc of + OpenFamilyFlavour (IAmData {}) _ -> text "data family" + _ -> text "type family" + FamilyArityMismatch _ max_args -> + text "Number of parameters must match family declaration; expected" + <+> ppr max_args <> dot + TyFamNameMismatch fam_tc_name eqn_tc_name -> + hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) + FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) -> + hang (text "Out of scope type variable" <> plural tvs + <+> pprWithCommas (quotes . ppr) tvs + <+> text "in the RHS of a family instance.") + 2 (text "All such variables must be bound on the LHS.") + $$ mk_extra + where + -- mk_extra: #7536: give a decent error message for + -- type T a = Int + -- type instance F (T a) = a + mk_extra = case mb_dodgy of + Nothing -> empty + Just (fam_tc, pats, dodgy_tvs) -> + ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $ + hang (text "The real LHS (expanding synonyms) is:") + 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) + FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) -> + vcat [ not_bound_msg, not_used_msg, dodgy_msg ] + where + + -- Filter to only keep user-written variables, + -- unless none were user-written in which case we report all of them + -- (as we need to report an error). + filter_user tvs + = map ifiqtv + $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs } + + (not_bound, not_used, dodgy) + = case foldr acc_tv ([], [], []) bad_qtvs of + (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d) + + acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of + InvalidFamInstQTvNotUsedInRHS -> (nb, tv : nu, d) + InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d) + InvalidFamInstQTvDodgy -> (nb, nu, tv : d) + + -- Error message for type variables not bound in LHS patterns. + not_bound_msg + | null not_bound + = empty + | otherwise + = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound + <+> isOrAre not_bound <+> text "bound by a forall," + , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ] + + -- Error message for type variables bound by a forall but not used + -- in the RHS. + not_used_msg = + if null not_used + then empty + else text "The type variable" <> plural not_used <+> pprQuotedList not_used + <+> isOrAre not_used <+> text "bound by a forall," $$ + text "but" <+> itOrThey not_used <+> + isOrAre not_used <> text "n't used in the family instance." + + -- Error message for dodgy type variables. + -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity. + dodgy_msg + | null dodgy + = empty + | otherwise + = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy + <+> text "in the LHS of a family instance:") + 2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy + <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns," + $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.") + + +illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint] +illegalFamilyInstanceHints = \case + InvalidAssoc rea -> invalidAssocHints rea + NotAFamilyTyCon {} -> noHints + NotAnOpenFamilyTyCon {} -> noHints + FamilyCategoryMismatch {} -> noHints + FamilyArityMismatch {} -> noHints + TyFamNameMismatch {} -> noHints + FamInstRHSOutOfScopeTyVars {} -> noHints + FamInstLHSUnusedBoundTyVars {} -> noHints + +illegalFamilyInstanceReason :: IllegalFamilyInstanceReason -> DiagnosticReason +illegalFamilyInstanceReason = \case + InvalidAssoc rea -> invalidAssocReason rea + NotAFamilyTyCon {} -> ErrorWithoutFlag + NotAnOpenFamilyTyCon {} -> ErrorWithoutFlag + FamilyCategoryMismatch {} -> ErrorWithoutFlag + FamilyArityMismatch {} -> ErrorWithoutFlag + TyFamNameMismatch {} -> ErrorWithoutFlag + FamInstRHSOutOfScopeTyVars {} -> ErrorWithoutFlag + FamInstLHSUnusedBoundTyVars {} -> ErrorWithoutFlag + +pprInvalidAssoc :: InvalidAssoc -> SDoc +pprInvalidAssoc = \case + InvalidAssocInstance rea -> pprInvalidAssocInstance rea + InvalidAssocDefault rea -> pprInvalidAssocDefault rea + +pprInvalidAssocInstance :: InvalidAssocInstance -> SDoc +pprInvalidAssocInstance = \case + AssocInstanceMissing name -> + text "No explicit" <+> text "associated type" + <+> text "or default declaration for" + <+> quotes (ppr name) + AssocInstanceNotInAClass fam_tc -> + text "Associated type" <+> quotes (ppr fam_tc) <+> + text "must be inside a class instance" + AssocNotInThisClass cls fam_tc -> + hsep [ text "Class", quotes (ppr cls) + , text "does not have an associated type", quotes (ppr fam_tc) ] + AssocNoClassTyVar cls fam_tc -> + sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc))) + , text "mentions none of the type or kind variables of the class" <+> + quotes (ppr cls <+> hsep (map ppr (classTyVars cls)))] + AssocTyVarsDontMatch vis fam_tc exp_tys act_tys -> + pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag vis) $ + vcat [ text "Type indexes must match class instance head" + , text "Expected:" <+> pp exp_tys + , text " Actual:" <+> pp act_tys ] + where + pp tys = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ + toIfaceTcArgs fam_tc tys + +pprInvalidAssocDefault :: InvalidAssocDefault -> SDoc +pprInvalidAssocDefault = \case + AssocDefaultNotAssoc cls tc -> + hsep [ text "Class", quotes (ppr cls) + , text "does not have an associated type", quotes (ppr tc) ] + AssocMultipleDefaults name -> + text "More than one default declaration for" <+> quotes (ppr name) + AssocDefaultBadArgs fam_tc pat_tys bad_arg -> + let (pat_vis, main_msg) = case bad_arg of + AssocDefaultNonTyVarArg (pat_ty, pat_vis) -> + (pat_vis, + text "Illegal argument" <+> quotes (ppr pat_ty) <+> text "in:") + AssocDefaultDuplicateTyVars dups -> + let (pat_tv, pat_vis) = NE.head dups + in (pat_vis, + text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") + in pprWithInvisibleBitsWhen (isInvisibleForAllTyFlag pat_vis) $ + hang main_msg + 2 (vcat [ppr_eqn, suggestion]) + where + ppr_eqn :: SDoc + ppr_eqn = + quotes (text "type" <+> ppr (mkTyConApp fam_tc pat_tys) + <+> equals <+> text "...") + + suggestion :: SDoc + suggestion = text "The arguments to" <+> quotes (ppr fam_tc) + <+> text "must all be distinct type variables." + +invalidAssocHints :: InvalidAssoc -> [GhcHint] +invalidAssocHints = \case + InvalidAssocInstance rea -> invalidAssocInstanceHints rea + InvalidAssocDefault rea -> invalidAssocDefaultHints rea + +invalidAssocInstanceHints :: InvalidAssocInstance -> [GhcHint] +invalidAssocInstanceHints = \case + AssocInstanceMissing {} -> noHints + AssocInstanceNotInAClass {} -> noHints + AssocNotInThisClass {} -> noHints + AssocNoClassTyVar {} -> noHints + AssocTyVarsDontMatch {} -> noHints + +invalidAssocDefaultHints :: InvalidAssocDefault -> [GhcHint] +invalidAssocDefaultHints = \case + AssocDefaultNotAssoc {} -> noHints + AssocMultipleDefaults {} -> noHints + AssocDefaultBadArgs _ _ bad -> + assocDefaultBadArgHints bad + +assocDefaultBadArgHints :: AssocDefaultBadArgs -> [GhcHint] +assocDefaultBadArgHints = \case + AssocDefaultNonTyVarArg {} -> noHints + AssocDefaultDuplicateTyVars {} -> noHints + +invalidAssocReason :: InvalidAssoc -> DiagnosticReason +invalidAssocReason = \case + InvalidAssocInstance rea -> invalidAssocInstanceReason rea + InvalidAssocDefault rea -> invalidAssocDefaultReason rea + +invalidAssocInstanceReason :: InvalidAssocInstance -> DiagnosticReason +invalidAssocInstanceReason = \case + AssocInstanceMissing {} -> WarningWithFlag (Opt_WarnMissingMethods) + AssocInstanceNotInAClass {} -> ErrorWithoutFlag + AssocNotInThisClass {} -> ErrorWithoutFlag + AssocNoClassTyVar {} -> ErrorWithoutFlag + AssocTyVarsDontMatch {} -> ErrorWithoutFlag + +invalidAssocDefaultReason :: InvalidAssocDefault -> DiagnosticReason +invalidAssocDefaultReason = \case + AssocDefaultNotAssoc {} -> ErrorWithoutFlag + AssocMultipleDefaults {} -> ErrorWithoutFlag + AssocDefaultBadArgs _ _ rea -> + assocDefaultBadArgReason rea + +assocDefaultBadArgReason :: AssocDefaultBadArgs -> DiagnosticReason +assocDefaultBadArgReason = \case + AssocDefaultNonTyVarArg {} -> ErrorWithoutFlag + AssocDefaultDuplicateTyVars {} -> ErrorWithoutFlag + +-------------------------------------------------------------------------------- +-- Template Haskell quotes and splices + +pprTHError :: THError -> DecoratedSDoc +pprTHError = \case + THSyntaxError err -> pprTHSyntaxError err + THNameError err -> pprTHNameError err + THReifyError err -> pprTHReifyError err + TypedTHError err -> pprTypedTHError err + THSpliceFailed rea -> pprSpliceFailReason rea + AddTopDeclsError err -> pprAddTopDeclsError err + + IllegalStaticFormInSplice e -> + mkSimpleDecorated $ + sep [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] + + FailedToLookupThInstName th_type reason -> + mkSimpleDecorated $ + case reason of + NoMatchesFound -> + text "Couldn't find any instances of" + <+> text (TH.pprint th_type) + <+> text "to add documentation to" + CouldNotDetermineInstance -> + text "Couldn't work out what instance" + <+> text (TH.pprint th_type) + <+> text "is supposed to be" + + AddInvalidCorePlugin plugin -> + mkSimpleDecorated $ + hang (text "addCorePlugin: invalid plugin module" <+> quotes (text plugin) ) + 2 (text "Plugins in the current package can't be specified.") + + AddDocToNonLocalDefn doc_loc -> + mkSimpleDecorated $ + text "Can't add documentation to" <+> ppr_loc doc_loc <> comma <+> + text "as it isn't inside the current module." + where + ppr_loc (TH.DeclDoc n) = text $ TH.pprint n + ppr_loc (TH.ArgDoc n _) = text $ TH.pprint n + ppr_loc (TH.InstDoc t) = text $ TH.pprint t + ppr_loc TH.ModuleDoc = text "the module header" + + ReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg + +pprTHSyntaxError :: THSyntaxError -> DecoratedSDoc +pprTHSyntaxError = mkSimpleDecorated . \case + IllegalTHQuotes expr -> + text "Syntax error on" <+> ppr expr + -- The error message context will say + -- "In the Template Haskell quotation", so no need to repeat that here. + BadImplicitSplice -> + sep [ text "Parse error: module header, import declaration" + , text "or top-level declaration expected." ] + -- The compiler should not mention TemplateHaskell, as the common case + -- is that this is a simple beginner error, for example: + -- + -- module M where + -- f :: Int -> Int; f x = x + -- xyzzy + -- g y = f y + 1 + -- + -- It's unlikely that 'xyzzy' above was intended to be a Template Haskell + -- splice; instead it's probably something mistakenly left in the code. + -- See #12146 for discussion. + + IllegalTHSplice -> + text "Unexpected top-level splice." + MismatchedSpliceType splice_type inner_splice_or_bracket -> + inner <+> text "may not appear in" <+> outer <> dot + where + (inner, outer) = case inner_splice_or_bracket of + IsSplice -> case splice_type of + Typed -> (text "Typed splices" , text "untyped brackets") + Untyped -> (text "Untyped splices", text "typed brackets") + IsBracket -> + case splice_type of + Typed -> (text "Untyped brackets", text "typed splices") + Untyped -> (text "Typed brackets" , text "untyped splices") + NestedTHBrackets -> + text "Template Haskell brackets cannot be nested" <+> + text "(without intervening splices)" + +pprTHNameError :: THNameError -> DecoratedSDoc +pprTHNameError = \case + NonExactName name -> + mkSimpleDecorated $ + hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") + 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") + +pprTHReifyError :: THReifyError -> DecoratedSDoc +pprTHReifyError = \case + CannotReifyInstance ty + -> mkSimpleDecorated $ + hang (text "reifyInstances:" <+> quotes (ppr ty)) + 2 (text "is not a class constraint or type family application") + CannotReifyOutOfScopeThing th_name + -> mkSimpleDecorated $ + quotes (text (TH.pprint th_name)) <+> + text "is not in scope at a reify" + -- Ugh! Rather an indirect way to display the name + CannotReifyThingNotInTypeEnv name + -> mkSimpleDecorated $ + quotes (ppr name) <+> text "is not in the type environment at a reify" + NoRolesAssociatedWithThing thing + -> mkSimpleDecorated $ + text "No roles associated with" <+> (ppr thing) + CannotRepresentType sort ty + -> mkSimpleDecorated $ + hang (text "Can't represent" <+> sort_doc <+> text "in Template Haskell:") + 2 (ppr ty) + where + sort_doc = text $ + case sort of + LinearInvisibleArgument -> "linear invisible argument" + CoercionsInTypes -> "coercions in types" + DataConVisibleForall -> "visible forall in the type of a data constructor" + +pprTypedTHError :: TypedTHError -> DecoratedSDoc +pprTypedTHError = \case + SplicePolymorphicLocalVar ident + -> mkSimpleDecorated $ + text "Can't splice the polymorphic local variable" <+> quotes (ppr ident) + TypedTHWithPolyType ty + -> mkSimpleDecorated $ + vcat [ text "Illegal polytype:" <+> ppr ty + , text "The type of a Typed Template Haskell expression must" <+> + text "not have any quantification." ] + +pprSpliceFailReason :: SpliceFailReason -> DecoratedSDoc +pprSpliceFailReason = \case + SpliceThrewException phase _exn exn_msg expr show_code -> + mkSimpleDecorated $ + vcat [ text "Exception when trying to" <+> text phaseStr <+> text "compile-time code:" + , nest 2 (text exn_msg) + , if show_code then text "Code:" <+> ppr expr else empty] + where phaseStr = + case phase of + SplicePhase_Run -> "run" + SplicePhase_CompileAndLink -> "compile and link" + RunSpliceFailure err -> pprRunSpliceFailure Nothing err + +pprAddTopDeclsError :: AddTopDeclsError -> DecoratedSDoc +pprAddTopDeclsError = \case + InvalidTopDecl _decl -> + mkSimpleDecorated $ + sep [ text "Only function, value, annotation, and foreign import declarations" + , text "may be added with" <+> quotes (text "addTopDecls") <> dot ] + AddTopDeclsUnexpectedDeclarationSplice {} -> + mkSimpleDecorated $ + text "Declaration splices are not permitted" <+> + text "inside top-level declarations added with" <+> + quotes (text "addTopDecls") <> dot + AddTopDeclsRunSpliceFailure err -> + pprRunSpliceFailure (Just "addTopDecls") err + +pprRunSpliceFailure :: Maybe String -> RunSpliceFailReason -> DecoratedSDoc +pprRunSpliceFailure mb_calling_fn (ConversionFail what reason) = + mkSimpleDecorated . add_calling_fn . addSpliceInfo $ + pprConversionFailReason reason + where + add_calling_fn rest = + case mb_calling_fn of + Just calling_fn -> + hang (text "Error in a declaration passed to" <+> quotes (text calling_fn) <> colon) + 2 rest + Nothing -> rest + addSpliceInfo = case what of + ConvDec d -> addSliceInfo' "declaration" d + ConvExp e -> addSliceInfo' "expression" e + ConvPat p -> addSliceInfo' "pattern" p + ConvType t -> addSliceInfo' "type" t + addSliceInfo' what item reasonErr = reasonErr $$ descr + where + -- Show the item in pretty syntax normally, + -- but with all its constructors if you say -dppr-debug + descr = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (TH.pprint item)) + +thErrorReason :: THError -> DiagnosticReason +thErrorReason = \case + THSyntaxError err -> thSyntaxErrorReason err + THNameError err -> thNameErrorReason err + THReifyError err -> thReifyErrorReason err + TypedTHError err -> typedTHErrorReason err + THSpliceFailed rea -> spliceFailedReason rea + AddTopDeclsError err -> addTopDeclsErrorReason err + + IllegalStaticFormInSplice {} -> ErrorWithoutFlag + FailedToLookupThInstName {} -> ErrorWithoutFlag + AddInvalidCorePlugin {} -> ErrorWithoutFlag + AddDocToNonLocalDefn {} -> ErrorWithoutFlag + ReportCustomQuasiError is_error _ -> + if is_error + then ErrorWithoutFlag + else WarningWithoutFlag + +thSyntaxErrorReason :: THSyntaxError -> DiagnosticReason +thSyntaxErrorReason = \case + IllegalTHQuotes{} -> ErrorWithoutFlag + BadImplicitSplice -> ErrorWithoutFlag + IllegalTHSplice{} -> ErrorWithoutFlag + NestedTHBrackets{} -> ErrorWithoutFlag + MismatchedSpliceType{} -> ErrorWithoutFlag + +thNameErrorReason :: THNameError -> DiagnosticReason +thNameErrorReason = \case + NonExactName {} -> ErrorWithoutFlag + +thReifyErrorReason :: THReifyError -> DiagnosticReason +thReifyErrorReason = \case + CannotReifyInstance {} -> ErrorWithoutFlag + CannotReifyOutOfScopeThing {} -> ErrorWithoutFlag + CannotReifyThingNotInTypeEnv {} -> ErrorWithoutFlag + NoRolesAssociatedWithThing {} -> ErrorWithoutFlag + CannotRepresentType {} -> ErrorWithoutFlag + +typedTHErrorReason :: TypedTHError -> DiagnosticReason +typedTHErrorReason = \case + SplicePolymorphicLocalVar {} -> ErrorWithoutFlag + TypedTHWithPolyType {} -> ErrorWithoutFlag + +spliceFailedReason :: SpliceFailReason -> DiagnosticReason +spliceFailedReason = \case + SpliceThrewException {} -> ErrorWithoutFlag + RunSpliceFailure {} -> ErrorWithoutFlag + +addTopDeclsErrorReason :: AddTopDeclsError -> DiagnosticReason +addTopDeclsErrorReason = \case + InvalidTopDecl {} + -> ErrorWithoutFlag + AddTopDeclsUnexpectedDeclarationSplice {} + -> ErrorWithoutFlag + AddTopDeclsRunSpliceFailure {} + -> ErrorWithoutFlag + +thErrorHints :: THError -> [GhcHint] +thErrorHints = \case + THSyntaxError err -> thSyntaxErrorHints err + THNameError err -> thNameErrorHints err + THReifyError err -> thReifyErrorHints err + TypedTHError err -> typedTHErrorHints err + THSpliceFailed rea -> spliceFailedHints rea + AddTopDeclsError err -> addTopDeclsErrorHints err + + IllegalStaticFormInSplice {} -> noHints + FailedToLookupThInstName {} -> noHints + AddInvalidCorePlugin {} -> noHints + AddDocToNonLocalDefn {} -> noHints + ReportCustomQuasiError {} -> noHints + +thSyntaxErrorHints :: THSyntaxError -> [GhcHint] +thSyntaxErrorHints = \case + IllegalTHQuotes{} + -> [suggestExtension LangExt.TemplateHaskellQuotes] + BadImplicitSplice {} + -> noHints -- NB: don't suggest TemplateHaskell + -- see comments on BadImplicitSplice in pprTHSyntaxError + IllegalTHSplice{} + -> [suggestExtension LangExt.TemplateHaskell] + NestedTHBrackets{} + -> noHints + MismatchedSpliceType{} + -> noHints + +thNameErrorHints :: THNameError -> [GhcHint] +thNameErrorHints = \case + NonExactName {} -> noHints + +thReifyErrorHints :: THReifyError -> [GhcHint] +thReifyErrorHints = \case + CannotReifyInstance {} -> noHints + CannotReifyOutOfScopeThing {} -> noHints + CannotReifyThingNotInTypeEnv {} -> noHints + NoRolesAssociatedWithThing {} -> noHints + CannotRepresentType {} -> noHints + +typedTHErrorHints :: TypedTHError -> [GhcHint] +typedTHErrorHints = \case + SplicePolymorphicLocalVar {} -> noHints + TypedTHWithPolyType {} -> noHints + +spliceFailedHints :: SpliceFailReason -> [GhcHint] +spliceFailedHints = \case + SpliceThrewException {} -> noHints + RunSpliceFailure {} -> noHints + +addTopDeclsErrorHints :: AddTopDeclsError -> [GhcHint] +addTopDeclsErrorHints = \case + InvalidTopDecl {} + -> noHints + AddTopDeclsUnexpectedDeclarationSplice {} + -> noHints + AddTopDeclsRunSpliceFailure {} + -> noHints + +-------------------------------------------------------------------------------- + +pprPatersonCondFailure :: + PatersonCondFailure -> PatersonCondFailureContext -> Type -> Type -> SDoc +pprPatersonCondFailure (PCF_TyVar tvs) InInstanceDecl lhs rhs = + hang (occMsg tvs) + 2 (sep [ text "in the constraint" <+> quotes (ppr lhs) + , text "than in the instance head" <+> quotes (ppr rhs) ]) + where + occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> pp_occurs <+> text "more often" + pp_occurs | isSingleton tvs = text "occurs" + | otherwise = text "occur" +pprPatersonCondFailure (PCF_TyVar tvs) InTyFamEquation lhs rhs = + hang (occMsg tvs) + 2 (sep [ text "in the type-family application" <+> quotes (ppr rhs) + , text "than in the LHS of the family instance" <+> quotes (ppr lhs) ]) + where + occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) + <+> pp_occurs <+> text "more often" + pp_occurs | isSingleton tvs = text "occurs" + | otherwise = text "occur" +pprPatersonCondFailure PCF_Size InInstanceDecl lhs rhs = + hang (text "The constraint" <+> quotes (ppr lhs)) + 2 (sep [ text "is no smaller than", pp_rhs ]) + where pp_rhs = text "the instance head" <+> quotes (ppr rhs) +pprPatersonCondFailure PCF_Size InTyFamEquation lhs rhs = + hang (text "The type-family application" <+> quotes (ppr rhs)) + 2 (sep [ text "is no smaller than", pp_lhs ]) + where pp_lhs = text "the LHS of the family instance" <+> quotes (ppr lhs) +pprPatersonCondFailure (PCF_TyFam tc) InInstanceDecl lhs _rhs = + hang (text "Illegal use of type family" <+> quotes (ppr tc)) + 2 (text "in the constraint" <+> quotes (ppr lhs)) +pprPatersonCondFailure (PCF_TyFam tc) InTyFamEquation _lhs rhs = + hang (text "Illegal nested use of type family" <+> quotes (ppr tc)) + 2 (text "in the arguments of the type-family application" <+> quotes (ppr rhs)) + +-------------------------------------------------------------------------------- + +defaultTypesAndImport :: ClassDefaults -> SDoc +defaultTypesAndImport ClassDefaults{cd_types, cd_provenance = DP_Imported cdm} = + hang (parens $ pprWithCommas ppr cd_types) + 2 (text "imported from" <+> ppr cdm) +defaultTypesAndImport ClassDefaults{cd_types} = parens (pprWithCommas ppr cd_types) + +-------------------------------------------------------------------------------- + +pprZonkerMessage :: ZonkerMessage -> SDoc +pprZonkerMessage = \case + ZonkerCannotDefaultConcrete frr -> + ppr (frr_context frr) $$ + text "cannot be assigned a fixed runtime representation," <+> + text "not even by defaulting." + +zonkerMessageHints :: ZonkerMessage -> [GhcHint] +zonkerMessageHints = \case + ZonkerCannotDefaultConcrete {} -> [SuggestAddTypeSignatures UnnamedBinding] + +zonkerMessageReason :: ZonkerMessage -> DiagnosticReason +zonkerMessageReason = \case + ZonkerCannotDefaultConcrete {} -> ErrorWithoutFlag + +-------------------------------------------------------------------------------- + +pprTypeSyntaxName :: TypeSyntax -> SDoc +pprTypeSyntaxName TypeKeywordSyntax = "keyword" <+> quotes "type" +pprTypeSyntaxName ForallTelescopeSyntax = "forall telescope" +pprTypeSyntaxName ContextArrowSyntax = "context arrow (=>)" +pprTypeSyntaxName FunctionArrowSyntax = "function type arrow (->)" + +-------------------------------------------------------------------------------- +-- ErrCtxt + +pprTyConInstFlavour :: TyConInstFlavour -> SDoc +pprTyConInstFlavour + ( TyConInstFlavour + { tyConInstFlavour = flav + , tyConInstIsDefault = is_dflt + } + ) = (if is_dflt then text "default" else empty) <+> ppr flav <+> text "instance" + +pprErrCtxtMsg :: ErrCtxtMsg -> SDoc +pprErrCtxtMsg = \case + ExprCtxt expr -> + hang (text "In the expression:") + 2 (ppr (stripParensHsExpr expr)) + ThetaCtxt ctxt theta -> + vcat [ text "In the context:" <+> pprTheta theta + , text "While checking" <+> pprUserTypeCtxt ctxt ] + QuantifiedCtCtxt pty -> + text "In the quantified constraint" <+> quotes (ppr pty) + InferredTypeCtxt poly_name poly_ty -> + vcat [ text "When checking the inferred type" + , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] + SigCtxt sig -> + text "In" <+> ppr sig + UserSigCtxt ctxt hs_ty + | Just n <- isSigMaybe ctxt + -> hang (text "In the type signature:") + 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) + | otherwise + -> hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) + 2 (ppr hs_ty) + RecordUpdCtxt ne_relevant_cons@(relevant_con :| _) upd_fld_names ex_tvs -> + make_lines_msg $ + (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :) + $ case relevant_con of + RealDataCon con -> + [ text "with type constructor" <+> quotes (ppr (dataConTyCon con)) + , text "data constructor" <+> plural relevant_cons <+> cons ] + PatSynCon {} -> + [ text "with pattern synonym" <+> plural relevant_cons <+> cons ] + ++ if null ex_tvs + then [] + else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ] + + where + cons = pprQuotedList relevant_cons + relevant_cons = NE.toList ne_relevant_cons + -- Pretty-print a collection of lines, adding commas at the end of each line, + -- and adding "and" to the start of the last line. + make_lines_msg :: [SDoc] -> SDoc + make_lines_msg [] = empty + make_lines_msg [last] = ppr last <> dot + make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot + make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls + PatSigErrCtxt sig_ty res_ty -> + vcat [ hang (text "When checking that the pattern signature:") + 4 (ppr sig_ty) + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr res_ty)) ] + PatCtxt pat -> + hang (text "In the pattern:") 2 (ppr pat) + PatSynDeclCtxt name -> + text "In the declaration for pattern synonym" <+> quotes (ppr name) + ClassOpCtxt meth meth_ty -> + sep [ text "When checking the class method:" + , nest 2 (pprPrefixOcc meth <+> dcolon <+> ppr meth_ty)] + MethSigCtxt sel_name sig_ty meth_ty -> + hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) + 2 (vcat [ text "is more general than its signature in the class" + , text "Instance sig:" <+> ppr sig_ty + , text " Class sig:" <+> ppr meth_ty ]) + PatMonoBindsCtxt pat grhss -> + hang (text "In a pattern binding:") + 2 (pprPatBind pat grhss) + ForeignDeclCtxt fo -> + hang (text "When checking declaration:") + 2 (ppr fo) + RuleCtxt rule_name -> + text "When checking the rewrite rule" <+> doubleQuotes (ftext rule_name) + FieldCtxt field_name -> + text "In the" <+> quotes (ppr field_name) <+> text "field of a record" + TypeCtxt ty -> + text "In the type" <+> quotes (ppr ty) + KindCtxt ki -> + text "In the kind" <+> quotes (ppr ki) + SubTypeCtxt ty_expected ty_actual -> + vcat [ hang (text "When checking that:") + 4 (ppr ty_actual) + , nest 2 (hang (text "is more polymorphic than:") + 2 (ppr ty_expected)) ] + AmbiguityCheckCtxt ctxt allow_ambiguous -> + vcat [ text "In the ambiguity check for" <+> what + , ppUnless allow_ambiguous ambig_msg ] + where + ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" + what | Just n <- isSigMaybe ctxt = quotes (ppr n) + | otherwise = pprUserTypeCtxt ctxt + + FunAppCtxt fun_arg arg_no -> + hang (hsep [ text "In the", speakNth arg_no, text "argument of" + , quotes fun <> text ", namely"]) + 2 (quotes arg) + where + fun, arg :: SDoc + (fun, arg) = case fun_arg of + FunAppCtxtExpr fn a -> (ppr fn, ppr a) + FunAppCtxtTy fn a -> (ppr fn, ppr a) + FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args + | n_vis_args_in_call <= n_fun_args -- Enough args, in the end + -> text "In the result of a function call" + | otherwise + -> hang (full_herald <> comma) + 2 (sep [ text "but its type" <+> quotes (pprSigmaType fun_ty) + , if n_fun_args == 0 then text "has none" + else text "has only" <+> speakN n_fun_args]) + where + full_herald = pprExpectedFunTyHerald herald + <+> speakNOf n_vis_args_in_call (text "visible argument") + -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic + FunResCtxt fun n_val_args res_fun res_env n_fun n_env + | -- Check for too few args + -- fun_tau = a -> b, res_tau = Int + n_fun > n_env + , not_fun res_env + -> text "Probable cause:" <+> quotes (ppr fun) + <+> text "is applied to too few arguments" + + | -- Check for too many args + -- fun_tau = a -> Int, res_tau = a -> b -> c -> d + -- The final guard suppresses the message when there + -- aren't enough args to drop; eg. the call is (f e1) + n_fun < n_env + , not_fun res_fun + , n_fun + n_val_args >= n_env + -- Never suggest that a naked variable is + -- applied to too many args! + -> text "Possible cause:" <+> quotes (ppr fun) + <+> text "is applied to too many arguments" + + | otherwise + -> empty + where + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False + + TyConDeclCtxt name flav -> + hsep [ text "In the", ppr flav + , text "declaration for", quotes (ppr name) ] + TyConInstCtxt name flav -> + hsep [ text "In the" <+> pprTyConInstFlavour flav <+> text "declaration for" + , quotes (ppr name) ] + DataConDefCtxt cons -> + text "In the definition of data constructor" <> plural (NE.toList cons) + <+> ppr_cons (NE.toList cons) + where + ppr_cons :: [LocatedN Name] -> SDoc + ppr_cons [con] = quotes (ppr con) + ppr_cons cons = interpp'SP cons + DataConResTyCtxt cons -> + text "In the result type of data constructor" <> plural (NE.toList cons) + <+> ppr_cons (NE.toList cons) + where + ppr_cons :: [LocatedN Name] -> SDoc + ppr_cons [con] = quotes (ppr con) + ppr_cons cons = interpp'SP cons + ClosedFamEqnCtxt tc -> + text "In the equations for closed type family" <+> + quotes (ppr tc) + TySynErrCtxt tc -> + text "In the expansion of type synonym" <+> quotes (ppr tc) + RoleAnnotErrCtxt name -> + nest 2 $ text "while checking a role annotation for" <+> quotes (ppr name) + CmdCtxt cmd -> + text "In the command:" <+> ppr cmd + InstDeclErrCtxt either_ty_ty -> + hang (text "In the instance declaration for") + 2 (quotes $ ppr_ty) + where + ppr_ty = case either_ty_ty of + Left ty -> ppr ty + Right ty -> ppr ty + StaticFormCtxt expr -> + hang (text "In the body of a static form:") + 2 (ppr expr) + DefaultDeclErrCtxt { ddec_in_type_list = in_type_list } -> + if in_type_list + then + text "When checking the types in a default declaration" + else + text "When checking the class at the head of a named default declaration" + MainCtxt main_name -> + text "When checking the type of the" + <+> ppMainFn (nameOccName main_name) + + VDQWarningCtxt tycon -> + vcat + [ text "NB: Type" <+> quotes (ppr tycon) <+> + text "was inferred to use visible dependent quantification." + , text "Most types with visible dependent quantification are" + , text "polymorphically recursive and need a standalone kind" + , text "signature. Perhaps supply one, with StandaloneKindSignatures." + ] + TermLevelUseCtxt name ctxt -> + pprTermLevelUseCtxt name ctxt + + StmtErrCtxt ctxt stmt + -- For [ e | .. ], do not mutter about "stmts" + | LastStmt _ e _ _ <- stmt + , isComprehensionContext ctxt + -> hang (text "In the expression:") 2 (ppr e) + | otherwise + -> hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt + + DerivInstCtxt pred -> + text "When deriving the instance for" <+> parens (ppr pred) + StandaloneDerivCtxt ty -> + hang (text "In the stand-alone deriving instance for") + 2 (quotes (ppr ty)) + DerivBindCtxt sel_id clas tys -> + vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) + , nest 2 (text "in a derived instance for" + <+> quotes (pprClassPred clas tys) <> colon) + , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] + + + ExportCtxt ie -> + text "In the export:" <+> ppr ie + PatSynExportCtxt ps -> + text "In the pattern synonym:" <+> ppr ps + PatSynRecSelExportCtxt _ps sel -> + text "In the pattern synonym record selector:" <+> ppr sel + + SyntaxNameCtxt name orig ty loc -> + vcat [ text "when checking that" <+> quotes (ppr name) + <+> text "(needed by a syntactic construct)" + , nest 2 (text "has the required type:" + <+> ppr ty) + , nest 2 (sep [ppr orig, text "at" <+> ppr loc])] + + AnnCtxt ann -> + hang (text "In the annotation:") 2 (ppr ann) + SpecPragmaCtxt prag -> + hang (text "In the pragma:") 2 (ppr prag) + MatchCtxt ctxt -> + text "In" <+> pprMatchContext ctxt + MatchInCtxt match -> + hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) + 4 (pprMatch match) + UntypedTHBracketCtxt br -> + hang (text "In the Template Haskell quotation" <> colon) + 2 (ppr br) + TypedTHBracketCtxt br_body -> + hang (text "In the Template Haskell typed quotation" <> colon) + 2 (thTyBrackets . ppr $ br_body) + UntypedSpliceCtxt splice -> + hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice) + where + what = case splice of + HsUntypedSpliceExpr {} -> text "untyped splice:" + HsQuasiQuote {} -> text "quasi-quotation:" + TypedSpliceCtxt mb_nm expr -> + hang (text "In the typed Template Haskell splice:") + 2 (pprTypedSplice mb_nm expr) + TypedSpliceResultCtxt expr -> + sep [ text "In the result of the splice:" + , nest 2 (pprTypedSplice Nothing (HsTypedSpliceExpr noExtField expr)) + , text "To see what the splice expanded to, use -ddump-splices"] + + ReifyInstancesCtxt th_nm th_tys -> + text "In the argument of" <+> quotes (text "reifyInstances") <> colon + <+> ppr_th th_nm <+> sep (map ppr_th th_tys) + where + ppr_th :: TH.Ppr a => a -> SDoc + ppr_th x = text (TH.pprint x) + + MergeSignaturesCtxt unit_state mod_name reqs -> + pprWithUnitState unit_state $ + if null reqs + then text "While checking the local signature" <+> ppr mod_name <+> + text "for consistency" + else hang (text "While merging the signatures from" <> colon) + 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ + bullet <+> text "...and the local signature for" <+> ppr mod_name) + CheckImplementsCtxt unit_state impl_mod (Module req_uid req_mod_name) -> + pprWithUnitState unit_state $ + text "While checking that" <+> quotes (ppr impl_mod) <+> + text "implements signature" <+> quotes (ppr req_mod_name) <+> + text "in" <+> quotes (ppr req_uid) <> dot + +-------------------------------------------------------------------------------- + +pprThBindLevel :: Set.Set ThLevelIndex -> SDoc +pprThBindLevel levels_set = text "level" <> pluralSet levels_set <+> pprUnquotedSet levels_set diff --git a/GHC/Tc/Errors/Types.hs b/GHC/Tc/Errors/Types.hs --- a/GHC/Tc/Errors/Types.hs +++ b/GHC/Tc/Errors/Types.hs @@ -6,6471 +6,7059 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-} - -module GHC.Tc.Errors.Types ( - -- * Main types - TcRnMessage(..) - , TcRnMessageOpts(..) - , mkTcRnUnknownMessage - , TcRnMessageDetailed(..) - , TypeDataForbids(..) - , ErrInfo(..) - , FixedRuntimeRepProvenance(..) - , pprFixedRuntimeRepProvenance - , ShadowedNameProvenance(..) - , RecordFieldPart(..) - , IllegalNewtypeReason(..) - , BadRecordUpdateReason(..) - , InjectivityErrReason(..) - , HasKinds(..) - , hasKinds - , SuggestUndecidableInstances(..) - , suggestUndecidableInstances - , SuggestUnliftedTypes(..) - , DataSort(..), ppDataSort - , AllowedDataResKind(..) - , NotClosedReason(..) - , SuggestPartialTypeSignatures(..) - , suggestPartialTypeSignatures - , DeriveInstanceErrReason(..) - , UsingGeneralizedNewtypeDeriving(..) - , usingGeneralizedNewtypeDeriving - , DeriveAnyClassEnabled(..) - , deriveAnyClassEnabled - , DeriveInstanceBadConstructor(..) - , HasWildcard(..) - , hasWildcard - , BadAnonWildcardContext(..) - , SoleExtraConstraintWildcardAllowed(..) - , DeriveGenericsErrReason(..) - , HasAssociatedDataFamInsts(..) - , hasAssociatedDataFamInsts - , AssociatedTyLastVarInKind(..) - , associatedTyLastVarInKind - , AssociatedTyNotParamOverLastTyVar(..) - , associatedTyNotParamOverLastTyVar - , MissingSignature(..) - , Exported(..) - , HsDocContext(..) - , FixedRuntimeRepErrorInfo(..) - - , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc - - , SolverReport(..), SolverReportSupplementary(..) - , SolverReportWithCtxt(..) - , SolverReportErrCtxt(..) - , getUserGivens, discardProvCtxtGivens - , TcSolverReportMsg(..) - , CannotUnifyVariableReason(..) - , MismatchMsg(..) - , MismatchEA(..) - , mkPlainMismatchMsg, mkBasicMismatchMsg - , WhenMatching(..) - , ExpectedActualInfo(..) - , TyVarInfo(..), SameOccInfo(..) - , AmbiguityInfo(..) - , CND_Extra(..) - , FitsMbSuppressed(..) - , ValidHoleFits(..), noValidHoleFits - , HoleFitDispConfig(..) - , RelevantBindings(..), pprRelevantBindings - , PromotionErr(..), pprPECategory, peCategory - , NotInScopeError(..), mkTcRnNotInScope - , ImportError(..) - , HoleError(..) - , CoercibleMsg(..) - , PotentialInstances(..) - , UnsupportedCallConvention(..) - , ExpectedBackends - , ArgOrResult(..) - , MatchArgsContext(..), MatchArgBadMatches(..) - , EmptyStatementGroupErrReason(..) - , UnexpectedStatement(..) - , DeclSort(..) - , NonStandardGuards(..) - , RuleLhsErrReason(..) - , HsigShapeMismatchReason(..) - , WrongThingSort(..) - , StageCheckReason(..) - , UninferrableTyVarCtx(..) - , PatSynInvalidRhsReason(..) - , BadFieldAnnotationReason(..) - , SuperclassCycle(..) - , SuperclassCycleDetail(..) - , RoleValidationFailedReason(..) - , DisabledClassExtension(..) - , TyFamsDisabledReason(..) - , TypeApplication(..) - , HsTypeOrSigType(..) - , HsTyVarBndrExistentialFlag(..) - , TySynCycleTyCons - , BadImportKind(..) - , DodgyImportsReason (..) - , ImportLookupReason (..) - , UnusedImportReason (..) - , UnusedImportName (..) - , NestedForallsContextsIn(..) - , UnusedNameProv(..) - , NonCanonicalDefinition(..) - , NonCanonical_Monoid(..) - , NonCanonical_Monad(..) - - -- * Errors for hs-boot and signature files - , BadBootDecls(..) - , MissingBootThing(..), missingBootThing - , BootMismatch(..) - , BootMismatchWhat(..) - , BootTyConMismatch(..) - , BootAxiomBranchMismatch(..) - , BootClassMismatch(..) - , BootMethodMismatch(..) - , BootATMismatch(..) - , BootDataMismatch(..) - , BootDataConMismatch(..) - , SynAbstractDataError(..) - , BootListMismatch(..), BootListMismatches - - -- * Class and family instance errors - , IllegalInstanceReason(..) - , IllegalClassInstanceReason(..) - , IllegalInstanceHeadReason(..) - , IllegalHasFieldInstance(..) - , CoverageProblem(..), FailedCoverageCondition(..) - , IllegalFamilyInstanceReason(..) - , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..) - , InvalidAssoc(..), InvalidAssocInstance(..) - , InvalidAssocDefault(..), AssocDefaultBadArgs(..) - - -- * Template Haskell errors - , THError(..), THSyntaxError(..), THNameError(..) - , THReifyError(..), TypedTHError(..) - , SpliceFailReason(..), RunSpliceFailReason(..) - , AddTopDeclsError(..) - , ConversionFailReason(..) - , UnrepresentableTypeDescr(..) - , LookupTHInstNameErrReason(..) - , SplicePhase(..) - , THDeclDescriptor(..) - , ThingBeingConverted(..) - , IllegalDecls(..) - - -- * Zonker errors - , ZonkerMessage(..) - - -- FFI Errors - , IllegalForeignTypeReason(..) - , TypeCannotBeMarshaledReason(..) - ) where - -import GHC.Prelude - -import GHC.Hs -import GHC.Tc.Errors.Types.PromotionErr -import GHC.Tc.Errors.Hole.FitTypes (HoleFit) -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence (EvBindsVar) -import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) - , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing - , FixedRuntimeRepOrigin(..), InstanceWhat ) -import GHC.Tc.Types.Rank (Rank) -import GHC.Tc.Utils.TcType (TcType, TcSigmaType, TcPredType, - PatersonCondFailure, PatersonCondFailureContext) -import GHC.Types.Basic -import GHC.Types.Error -import GHC.Types.Avail -import GHC.Types.Hint (UntickedPromotedThing(..)) -import GHC.Types.ForeignCall (CLabelString) -import GHC.Types.Id.Info ( RecSelParent(..) ) -import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan) -import qualified GHC.Types.Name.Occurrence as OccName -import GHC.Types.Name.Reader -import GHC.Types.SourceFile (HsBootOrSig(..)) -import GHC.Types.SrcLoc -import GHC.Types.TyThing (TyThing) -import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar, Specificity) -import GHC.Types.Var.Env (TidyEnv) -import GHC.Types.Var.Set (TyVarSet, VarSet) -import GHC.Unit.Types (Module) -import GHC.Utils.Outputable -import GHC.Core.Class (Class, ClassMinimalDef, ClassOpItem, ClassATItem) -import GHC.Core.Coercion (Coercion) -import GHC.Core.Coercion.Axiom (CoAxBranch) -import GHC.Core.ConLike (ConLike) -import GHC.Core.DataCon (DataCon, FieldLabel) -import GHC.Core.FamInstEnv (FamInst) -import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst, DFunId) -import GHC.Core.PatSyn (PatSyn) -import GHC.Core.Predicate (EqRel, predTypeEqRel) -import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs) -import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag) -import GHC.Driver.Backend (Backend) -import GHC.Unit.State (UnitState) -import GHC.Utils.Misc (filterOut) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Data.FastString (FastString) -import GHC.Data.Pair -import GHC.Exception.Type (SomeException) - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import qualified Data.List.NonEmpty as NE -import Data.Typeable (Typeable) -import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt) -import qualified Language.Haskell.TH.Syntax as TH - -import GHC.Generics ( Generic ) -import GHC.Types.Name.Env (NameEnv) -import GHC.Iface.Errors.Types -import GHC.Unit.Module.ModIface (ModIface) -import GHC.Tc.Types.TH -import GHC.Tc.Types.BasicTypes - - - -data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not - , tcOptsIfaceOpts :: !IfaceMessageOpts - } - -{- Note [Migrating TcM Messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As part of #18516, we are slowly migrating the diagnostic messages emitted -and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted -some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions -that accepted 3 SDocs an input: one for the important part of the message, -one for the context and one for any supplementary information. Consider the following: - - • Couldn't match expected type ‘Int’ with actual type ‘Char’ - • In the expression: x4 - In a stmt of a 'do' block: return (x2, x4) - In the expression: - -Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" -as the important part, "In the expression" as the context and "In a stmt..In the expression" -as the supplementary, with the context and supplementary usually smashed together so that -the final message would be composed only by two SDoc (which would then be bulleted like in -the example). - -In order for us to smooth out the migration to the new diagnostic infrastructure, we -introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose -of bridging the two worlds together without breaking the external API or the existing -format of messages reported by GHC. - -Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden -diagnostic API inside Tc.Utils.Monad, enabling further refactorings. - -In the future, once the conversion will be complete and we will successfully eradicate -any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and -existence of these two types, which for now remain a "necessary evil". --} - --- The majority of TcRn messages come with extra context about the error, --- and this newtype captures it. See Note [Migrating TcM Messages]. -data ErrInfo = ErrInfo { - errInfoContext :: !SDoc - -- ^ Extra context associated to the error. - , errInfoSupplementary :: !SDoc - -- ^ Extra supplementary info associated to the error. - } - --- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside --- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing --- any extra info needed to correctly pretty-print this diagnostic later on. -data TcRnMessageDetailed - = TcRnMessageDetailed !ErrInfo - -- ^ Extra info associated with the message - !TcRnMessage - deriving Generic - -mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) - => a -> TcRnMessage -mkTcRnUnknownMessage diag = TcRnUnknownMessage (mkSimpleUnknownDiagnostic diag) - -- Please don't use this function inside the GHC codebase; - -- it mainly exists for users of the GHC API, such as plugins. - -- - -- If you need to emit a new error message in the typechecker, - -- you should add a new constructor to 'TcRnMessage' instead. - --- | An error which might arise during typechecking/renaming. -data TcRnMessage where - {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins - to provide custom diagnostic messages originated during typechecking/renaming. - -} - TcRnUnknownMessage :: (UnknownDiagnostic (DiagnosticOpts TcRnMessage)) -> TcRnMessage - - {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface - files during typechecking but encounter an error. -} - - TcRnInterfaceError :: !IfaceMessage -> TcRnMessage - - {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed - to be provided in order to qualify a diagnostic and where it was originated (and why). - It carries an extra 'UnitState' which can be used to pretty-print some names - and it wraps a 'TcRnMessageDetailed', which includes any extra context associated - with this diagnostic. - -} - TcRnMessageWithInfo :: !UnitState - -- ^ The 'UnitState' will allow us to pretty-print - -- some diagnostics with more detail. - -> !TcRnMessageDetailed - -> TcRnMessage - - {-| TcRnWithHsDocContext annotates an error message with the context in which - it originated. - -} - TcRnWithHsDocContext :: !HsDocContext - -> !TcRnMessage - -> TcRnMessage - - {-| TcRnSolverReport is the constructor used to report unsolved constraints - after constraint solving, as well as other errors such as hole fit errors. - - See the documentation of t'TcSolverReportMsg' datatype for an overview - of the different errors. - -} - TcRnSolverReport :: SolverReportWithCtxt - -> DiagnosticReason - -> [GhcHint] - -> TcRnMessage - -- TODO: split up TcRnSolverReport into several components, - -- so that we can compute the reason and hints, as opposed - -- to having to pass them here. - - {-| TcRnSolverDepthError is an error that occurs when the constraint solver - exceeds the maximum recursion depth. - - Example: - - class C a where { meth :: a } - instance Cls [a] => Cls a where { meth = head . meth } - - t :: () - t = meth - - Test cases: - T7788 - T8550 - T9554 - T15316A - T17267{∅,a,b,c,e} - T17458 - ContextStack1 - T22924b - TcCoercibleFail - -} - TcRnSolverDepthError :: !Type -> !SubGoalDepth -> TcRnMessage - - {-| TcRnRedundantConstraints is a warning that is emitted when a binding - has a user-written type signature which contains superfluous constraints. - - Example: - - f :: (Eq a, Ord a) => a -> a -> a - f x y = (x < y) || x == y - -- `Eq a` is superfluous: the `Ord a` constraint suffices. - - Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. - -} - TcRnRedundantConstraints :: [Id] - -> (SkolemInfoAnon, Bool) - -- ^ The contextual skolem info. - -- The boolean controls whether we - -- want to show it in the user message. - -- (Nice to keep track of the info in either case, - -- for other users of the GHC API.) - -> TcRnMessage - - {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern - match is inaccessible, because the constraint solver has detected a contradiction. - - Example: - - data B a where { MkTrue :: B True; MkFalse :: B False } - - foo :: B False -> Bool - foo MkFalse = False - foo MkTrue = True -- Inaccessible: requires True ~ False - - Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. - -} - TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. - -> SolverReportWithCtxt -- ^ The contradiction. - -> TcRnMessage - {-| TcRnInaccessibleCoAxBranch is a warning that is emitted when a closed type family has a - branch which is inaccessible due to a more general, prior branch. - - Example: - type family F a where - F a = Int - F Bool = Bool - Test cases: T9085, T14066a, T9085, T6018, tc265, - - -} - TcRnInaccessibleCoAxBranch :: TyCon -- ^ The type family's constructor - -> CoAxBranch -- ^ The inaccessible branch - -> TcRnMessage - {-| A type which was expected to have a fixed runtime representation - does not have a fixed runtime representation. - - Example: - - data D (a :: TYPE r) = MkD a - - Test cases: T11724, T18534, - RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype, - RepPolyPatSynRes, T20423 - -} - TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type - -> !FixedRuntimeRepProvenance - -> !ErrInfo -- Extra info accumulated in the TcM monad - -> TcRnMessage - - {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when - a Template Haskell quote implicitly uses 'lift'. - - Example: - warning1 :: Lift t => t -> Q Exp - warning1 x = [| x |] - - Test cases: th/T17804 - -} - TcRnImplicitLift :: Name -> !ErrInfo -> TcRnMessage - - {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) - that occurs if a pattern binding binds no variables at all, unless it is a - lone wild-card pattern, or a banged pattern. - - Example: - Just _ = rhs3 -- Warning: unused pattern binding - (_, _) = rhs4 -- Warning: unused pattern binding - _ = rhs3 -- No warning: lone wild-card pattern - !() = rhs4 -- No warning: banged pattern; behaves like seq - - Test cases: rename/{T13646,T17c,T17e,T7085} - -} - TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage - - {-| TcRnUnusedQuantifiedTypeVar is a warning that occurs if there are unused - quantified type variables. - - Examples: - f :: forall a. Int -> Char - - Test cases: rename/should_compile/ExplicitForAllRules1 - rename/should_compile/T5331 - -} - TcRnUnusedQuantifiedTypeVar - :: HsDocContext - -> HsTyVarBndrExistentialFlag -- ^ tyVar binder. - -> TcRnMessage - - {-| TcRnDodgyImports is a group of warnings (controlled with -Wdodgy-imports). - - See 'DodgyImportsReason' for the different warnings. - -} - TcRnDodgyImports :: !DodgyImportsReason -> TcRnMessage - {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when - an export of the form 'T(..)' for a type constructor 'T' does not actually export anything - beside 'T' itself. - - Example: - module Foo ( - T(..) -- Warning: T is a type synonym - , A(..) -- Warning: A is a type family - , C(..) -- Warning: C is a data family - ) where - - type T = Int - type family A :: * -> * - data family C :: * -> * - - Test cases: warnings/should_compile/DodgyExports01 - -} - TcRnDodgyExports :: GlobalRdrElt -> TcRnMessage - {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when - an import declaration does not explicitly list all the names brought into scope. - - Test cases: rename/should_compile/T4489 - -} - TcRnMissingImportList :: IE GhcPs -> TcRnMessage - {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled - with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the - reason the module was inferred to be unsafe. This warning is not raised if the - -fplugin-trustworthy flag is passed. - - Test cases: plugins/T19926 - -} - TcRnUnsafeDueToPlugin :: TcRnMessage - {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks - an associated 'RealSrcSpan'. - - Test cases: None - -} - TcRnModMissingRealSrcSpan :: Module -> TcRnMessage - {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs - when an identifier required by a signature is not exported by the module - or signature that is being used as a substitution for that signature. - - Example(s): None - - Test cases: backpack/should_fail/bkpfail36 - -} - TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage - {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that - occurs when an identifier which is necessary for implementing a module - signature is not exported from that signature. - - Example(s): None - - Test cases: backpack/should_fail/bkpfail30 - backpack/should_fail/bkpfail31 - backpack/should_fail/bkpfail34 - -} - TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage - - {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever - an inner-scope value has the same name as an outer-scope value, i.e. the inner - value shadows the outer one. This can catch typographical errors that turn into - hard-to-find bugs. The warning is suppressed for names beginning with an underscore. - - Examples(s): - f = ... let f = id in ... f ... -- NOT OK, 'f' is shadowed - f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore - - Test cases: typecheck/should_compile/T10971a - rename/should_compile/rn039 - rename/should_compile/rn064 - rename/should_compile/T1972 - rename/should_fail/T2723 - rename/should_compile/T3262 - driver/werror - -} - TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage - - {-| TcRnInvalidWarningCategory is an error that occurs when a warning is declared - with a category name that is not the special category "deprecations", and - either does not begin with the prefix "x-" indicating a user-defined - category, or contains characters not valid in category names. See Note - [Warning categories] in GHC.Unit.Module.Warnings - - Examples(s): - module M {-# WARNING in "invalid" "Oops" #-} where - - {-# WARNING in "x- spaces not allowed" foo "Oops" #-} - - Test cases: warnings/should_fail/WarningCategoryInvalid - -} - TcRnInvalidWarningCategory :: !WarningCategory -> TcRnMessage - - {-| TcRnDuplicateWarningDecls is an error that occurs whenever - a warning is declared twice. - - Examples(s): - {-# DEPRECATED foo "Don't use me" #-} - {-# DEPRECATED foo "Don't use me" #-} - foo :: Int - foo = 2 - - Test cases: - rename/should_fail/rnfail058 - -} - TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage - - {-| TcRnSimplifierTooManyIterations is an error that occurs whenever - the constraint solver in the simplifier hits the iterations' limit. - - Examples(s): - None. - - Test cases: - None. - -} - TcRnSimplifierTooManyIterations :: Cts - -> !IntWithInf - -- ^ The limit. - -> WantedConstraints - -> TcRnMessage - - {-| TcRnIllegalPatSynDecl is an error that occurs whenever - there is an illegal pattern synonym declaration. - - Examples(s): - - varWithLocalPatSyn x = case x of - P -> () - where - pattern P = () -- not valid, it can't be local, it must be defined at top-level. - - Test cases: patsyn/should_fail/local - -} - TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage - - {-| TcRnLinearPatSyn is an error that occurs whenever a pattern - synonym signature uses a field that is not unrestricted. - - Example(s): None - - Test cases: linear/should_fail/LinearPatSyn2 - -} - TcRnLinearPatSyn :: !Type -> TcRnMessage - - {-| TcRnEmptyRecordUpdate is an error that occurs whenever - a record is updated without specifying any field. - - Examples(s): - - $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions - - Test cases: th/T12788 - -} - TcRnEmptyRecordUpdate :: TcRnMessage - - {-| TcRnIllegalFieldPunning is an error that occurs whenever - field punning is used without the 'NamedFieldPuns' extension enabled. - - Examples(s): - - data Foo = Foo { a :: Int } - - foo :: Foo -> Int - foo Foo{a} = a -- Not ok, punning used without extension. - - Test cases: parser/should_fail/RecordDotSyntaxFail12 - -} - TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage - - {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever - wildcards (..) are used in a record without the relevant - extension being enabled. - - Examples(s): - - data Foo = Foo { a :: Int } - - foo :: Foo -> Int - foo Foo{..} = a -- Not ok, wildcards used without extension. - - Test cases: parser/should_fail/RecordWildCardsFail - -} - TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage - - {-| TcRnIllegalWildcardInType is an error that occurs - when a wildcard appears in a type in a location in which - wildcards aren't allowed. - - Examples: - - Type synonyms: - - type T = _ - - Class declarations and instances: - - class C _ - instance C _ - - Standalone kind signatures: - - type D :: _ - data D - - Test cases: - ExtraConstraintsWildcardInTypeSplice2 - ExtraConstraintsWildcardInTypeSpliceUsed - ExtraConstraintsWildcardNotLast - ExtraConstraintsWildcardTwice - NestedExtraConstraintsWildcard - NestedNamedExtraConstraintsWildcard - PartialClassMethodSignature - PartialClassMethodSignature2 - T12039 - T13324_fail1 - UnnamedConstraintWildcard1 - UnnamedConstraintWildcard2 - WildcardInADT1 - WildcardInADT2 - WildcardInADT3 - WildcardInADTContext1 - WildcardInDefault - WildcardInDefaultSignature - WildcardInDeriving - WildcardInForeignExport - WildcardInForeignImport - WildcardInGADT1 - WildcardInGADT2 - WildcardInInstanceHead - WildcardInInstanceSig - WildcardInNewtype - WildcardInPatSynSig - WildcardInStandaloneDeriving - WildcardInTypeFamilyInstanceRHS - WildcardInTypeSynonymRHS - saks_fail003 - T15433a - -} - TcRnIllegalWildcardInType - :: Maybe Name - -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard - -> !BadAnonWildcardContext - -> TcRnMessage - - {-| TcRnDuplicateFieldName is an error that occurs whenever - there are duplicate field names in a single record. - - Examples(s): - - data R = MkR { x :: Int, x :: Bool } - f r = r { x = 3, x = 4 } - - Test cases: T21959. - -} - TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage - - {-| TcRnIllegalViewPattern is an error that occurs whenever - the ViewPatterns syntax is used but the ViewPatterns language extension - is not enabled. - - Examples(s): - data Foo = Foo { a :: Int } - - foo :: Foo -> Int - foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled. - - Test cases: parser/should_fail/ViewPatternsFail - -} - TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage - - {-| TcRnCharLiteralOutOfRange is an error that occurs whenever - a character is out of range. - - Examples(s): None - - Test cases: None - -} - TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage - - {-| TcRnNegativeNumTypeLiteral is an error that occurs whenever - a type-level number literal is negative. - - type Neg = -1 - - Test cases: th/T8412 - typecheck/should_fail/T8306 - -} - TcRnNegativeNumTypeLiteral :: HsType GhcPs -> TcRnMessage - - {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever - the record wildcards '..' are used inside a constructor without labeled fields. - - Examples(s): None - - Test cases: - rename/should_fail/T9815.hs - rename/should_fail/T9815b.hs - rename/should_fail/T9815ghci.hs - rename/should_fail/T9815bghci.hs - -} - TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage - - {-| TcRnIgnoringAnnotations is a warning that occurs when the source code - contains annotation pragmas but the platform in use does not support an - external interpreter such as GHCi and therefore the annotations are ignored. - - Example(s): None - - Test cases: None - -} - TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage - - {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas - are used in conjunction with Safe Haskell. - - Example(s): None - - Test cases: annotations/should_fail/T10826 - -} - TcRnAnnotationInSafeHaskell :: TcRnMessage - - {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application - is used with an expression that does not accept "specified" type arguments. - - Example(s): - foo :: forall {a}. a -> a - foo x = x - bar :: () - bar = let x = foo @Int 42 - in () - - Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03 - typecheck/should_fail/ExplicitSpecificity1 - typecheck/should_fail/ExplicitSpecificity10 - typecheck/should_fail/ExplicitSpecificity2 - typecheck/should_fail/T17173 - typecheck/should_fail/VtaFail - -} - TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage - - {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#' - function is not applied to a single value argument. - - Example(s): - tagToEnum# 1 2 - - Test cases: None - -} - TcRnTagToEnumMissingValArg :: TcRnMessage - - {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#' - function is not given a concrete result type. - - Example(s): - foo :: forall a. a - foo = tagToEnum# 0# - - Test cases: typecheck/should_fail/tcfail164 - -} - TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage - - {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#' - function is given a result type that is not an enumeration type. - - Example(s): - foo :: Int -- not an enumeration TyCon - foo = tagToEnum# 0# - - Test cases: typecheck/should_fail/tcfail164 - -} - TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage - - {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#' - function is given a result type that is headed by a @type data@ type, as - the data constructors of a @type data@ do not exist at the term level. - - Example(s): - type data Letter = A | B | C - - foo :: Letter - foo = tagToEnum# 0# - - Test cases: type-data/should_fail/TDTagToEnum.hs - -} - TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage - - {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the - predicate type of an ifThenElse expression in arrow notation depends on - the type of the result. - - Example(s): None - - Test cases: None - -} - TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage - - {-| TcRnIllegalHsBootOrSigDecl is an error that occurs when an hs-boot file - contains declarations that are not allowed, such as bindings. - - Examples: - - -- A.hs-boot - f :: Int -> Int - f x = 2 * x -- binding not allowed - - -- B.hs-boot - type family F a where { F Int = Bool } - -- type family equations not allowed - - -- C.hsig - bar :: Int -> Int - {-# RULES forall x. bar x = x #-} -- RULES not allowed - - - Test cases: - - - bindings: T19781 - - class instance body: none - - type family instance: HsBootFam - - splice: none - - foreign declaration: none - - default declaration: none - - RULEs: none - -} - TcRnIllegalHsBootOrSigDecl :: !HsBootOrSig -> !BadBootDecls -> TcRnMessage - - {-| TcRnBootMismatch is a family of errors that occur when there is a - mismatch between the hs-boot and hs files. - - Examples: - - -- A.hs-boot - foo :: Int -> Bool - data D = MkD - - -- A.hs - foo :: Int -> Char - foo = chr - - data D = MkD Int - - Test cases: - - - missing export: bkpcabal06, bkpfail{01,05,09,16,35}, rnfail{047,055} - - missing definition: none - - missing instance: T14075 - - mismatch in exports: bkpfail{03,19} - - conflicting definitions: bkpcabal02, - bkpfail{04,06,07,10,12,133,14,15,17,22,23,25,26,27,41,42,45,47,50,52,53,54}, - T19244{a,b}, T23344, ClosedFam3, rnfail055 - -} - TcRnBootMismatch :: !HsBootOrSig -> !BootMismatch -> TcRnMessage - - {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym - is defined in terms of itself, either directly or indirectly. - - Example(s): - pattern A = B - pattern B = A - - Test cases: patsyn/should_fail/T16900 - -} - TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage - - {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature - attempts to unify two different types. - - Example(s): - f :: a -> b -> _ - f x y = [x, y] - - Test cases: partial-sigs/should_fail/T14449 - -} - TcRnPartialTypeSigTyVarMismatch - :: Name -- ^ first type variable - -> Name -- ^ second type variable - -> Name -- ^ function name - -> LHsSigWcType GhcRn -> TcRnMessage - - {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable - being quantified over in the partial type signature of a function gets unified - with a type that is free in that function's context. - - Example(s): - foo :: Num a => a -> a - foo xxx = g xxx - where - g :: forall b. Num b => _ -> b - g y = xxx + y - - Test cases: partial-sig/should_fail/T14479 - -} - TcRnPartialTypeSigBadQuantifier - :: Name -- ^ user-written name of type variable being quantified - -> Name -- ^ function name - -> Maybe Type -- ^ type the variable unified with, if known - -> LHsSigWcType GhcRn -- ^ partial type signature - -> TcRnMessage - - {-| TcRnMissingSignature is a warning that occurs when a top-level binding - or a pattern synonym does not have a type signature. - - Controlled by the flags: - -Wmissing-signatures - -Wmissing-exported-signatures - -Wmissing-pattern-synonym-signatures - -Wmissing-exported-pattern-synonym-signatures - -Wmissing-kind-signatures - -Wmissing-poly-kind-signatures - - Test cases: - T11077 (top-level bindings) - T12484 (pattern synonyms) - T19564 (kind signatures) - -} - TcRnMissingSignature :: MissingSignature - -> Exported - -> TcRnMessage - - {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures - that occurs when a local polymorphic binding lacks a type signature. - - Example(s): - id a = a - - Test cases: warnings/should_compile/T12574 - -} - TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage - - {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts - with the monomorphism restriction. - - Example(s): - data T a = T a - mono = ... where - x :: Applicative f => f a - T x = ... - - Test cases: typecheck/should_compile/T11339 - -} - TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage - - {-| TcRnTupleConstraintInst is an error that occurs whenever an instance - for a tuple constraint is specified. - - Examples(s): - class C m a - class D m a - f :: (forall a. Eq a => (C m a, D m a)) => m a - f = undefined - - Test cases: quantified-constraints/T15334 - -} - TcRnTupleConstraintInst :: !Class -> TcRnMessage - - {-| TcRnUserTypeError is an error that occurs due to a user's custom type error, - which can be triggered by adding a `TypeError` constraint in a type signature - or typeclass instance. - - Examples(s): - f :: TypeError (Text "This is a type error") - f = undefined - - Test cases: typecheck/should_fail/CustomTypeErrors02 - typecheck/should_fail/CustomTypeErrors03 - -} - TcRnUserTypeError :: !Type -> TcRnMessage - - {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified - in a kind. - - Examples(s): - data Q :: Eq a => Type where {} - - Test cases: dependent/should_fail/T13895 - polykinds/T16263 - saks/should_fail/saks_fail004 - typecheck/should_fail/T16059a - typecheck/should_fail/T18714 - -} - TcRnConstraintInKind :: !Type -> TcRnMessage - - {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple - or unboxed sum type is specified as a function argument, when the appropriate - extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled. - - Examples(s): - -- T15073.hs - import T15073a - newtype Foo a = MkFoo a - deriving P - - -- T15073a.hs - class P a where - p :: a -> (# a #) - - Test cases: deriving/should_fail/T15073.hs - deriving/should_fail/T15073a.hs - typecheck/should_fail/T16059d - -} - TcRnUnboxedTupleOrSumTypeFuncArg - :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum - -> !Type - -> TcRnMessage - - {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is - specified in a kind. - - Examples(s): - data A :: * %1 -> * - - Test cases: linear/should_fail/LinearKind - linear/should_fail/LinearKind2 - linear/should_fail/LinearKind3 - -} - TcRnLinearFuncInKind :: !Type -> TcRnMessage - - {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind - mentions quantified type variable. - - Examples(s): - type T :: TYPE (BoxedRep l) - data T = MkT - - Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly - -} - TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage - - {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification - is specified in the type of a term. - - Examples(s): - a = (undefined :: forall k -> k -> Type) @Int - - Test cases: dependent/should_fail/T15859 - dependent/should_fail/T16326_Fail1 - dependent/should_fail/T16326_Fail2 - dependent/should_fail/T16326_Fail3 - dependent/should_fail/T16326_Fail4 - dependent/should_fail/T16326_Fail5 - dependent/should_fail/T16326_Fail6 - dependent/should_fail/T16326_Fail7 - dependent/should_fail/T16326_Fail8 - dependent/should_fail/T16326_Fail9 - dependent/should_fail/T16326_Fail10 - dependent/should_fail/T16326_Fail11 - dependent/should_fail/T16326_Fail12 - dependent/should_fail/T17687 - dependent/should_fail/T18271 - -} - TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage - - {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate - lacks a class or type variable head. - - Examples(s): - class (forall a. A t a => A t [a]) => B t where - type A t a :: Constraint - - Test cases: quantified-constraints/T16474 - -} - TcRnBadQuantPredHead :: !Type -> TcRnMessage - - {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple - constraint is specified. - - Examples(s): - g :: ((Show a, Num a), Eq a) => a -> a - g = undefined - - Test cases: typecheck/should_fail/tcfail209a - -} - TcRnIllegalTupleConstraint :: !Type -> TcRnMessage - - {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable - argument is specified in a constraint. - - Examples(s): - data T - instance Eq Int => Eq T - - Test cases: ghci/scripts/T13202 - ghci/scripts/T13202a - polykinds/T12055a - typecheck/should_fail/T10351 - typecheck/should_fail/T19187 - typecheck/should_fail/T6022 - typecheck/should_fail/T8883 - -} - TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage - - {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit - parameter is specified. - - Examples(s): - type Bla = ?x::Int - data T = T - instance Bla => Eq T - - Test cases: polykinds/T11466 - typecheck/should_fail/T8912 - typecheck/should_fail/tcfail041 - typecheck/should_fail/tcfail211 - typecheck/should_fail/tcrun045 - -} - TcRnIllegalImplicitParam :: !Type -> TcRnMessage - - {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint - synonym of kind is specified. - - Examples(s): - type Showish = Show - f :: (Showish a) => a -> a - f = undefined - - Test cases: typecheck/should_fail/tcfail209 - -} - TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage - - {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated - visible kind argument is specified. - - Examples(s): - type family - F2 :: forall (a :: Type). Type where - F2 @a = Maybe a - - Test cases: typecheck/should_fail/T15793 - typecheck/should_fail/T16255 - -} - TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage - - {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type - is specified. - - Examples(s): - foo :: (a,b) -> (a~b => t) -> (a,b) - foo p x = p - - Test cases: - - ghci/should_run/T15806 - - indexed-types/should_fail/SimpleFail15 - - typecheck/should_fail/T11355 - - typecheck/should_fail/T12083a - - typecheck/should_fail/T12083b - - typecheck/should_fail/T16059c - - typecheck/should_fail/T16059e - - typecheck/should_fail/T17213 - - typecheck/should_fail/T18939_Fail - - typecheck/should_fail/T2538 - - typecheck/should_fail/T5957 - - typecheck/should_fail/T7019 - - typecheck/should_fail/T7019a - - typecheck/should_fail/T7809 - - typecheck/should_fail/T9196 - - typecheck/should_fail/tcfail127 - - typecheck/should_fail/tcfail184 - - typecheck/should_fail/tcfail196 - - typecheck/should_fail/tcfail197 - -} - TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage - - {-| TcRnSimplifiableConstraint is a warning triggered by the occurrence of - a simplifiable constraint in a context, when MonoLocalBinds is not enabled. - - Examples(s): - simplifiableEq :: Eq (a, a) => a -> a -> Bool - simplifiableEq = undefined - - Test cases: - - indexed-types/should_compile/T15322 - - partial-sigs/should_compile/SomethingShowable - - typecheck/should_compile/T13526 - -} - TcRnSimplifiableConstraint :: !PredType -> !InstanceWhat -> TcRnMessage - - {-| TcRnArityMismatch is an error that occurs when a type constructor is supplied with - fewer arguments than required. - - Examples(s): - f Left = undefined - - Test cases: - - backpack/should_fail/bkpfail25.bkp - - ghci/should_fail/T16013 - - ghci/should_fail/T16287 - - indexed-types/should_fail/BadSock - - indexed-types/should_fail/T9433 - - module/mod60 - - ndexed-types/should_fail/T2157 - - parser/should_fail/ParserNoBinaryLiterals2 - - parser/should_fail/ParserNoBinaryLiterals3 - - patsyn/should_fail/T12819 - - polykinds/T10516 - - typecheck/should_fail/T12124 - - typecheck/should_fail/T15954 - - typecheck/should_fail/T16874 - - typecheck/should_fail/tcfail100 - - typecheck/should_fail/tcfail101 - - typecheck/should_fail/tcfail107 - - typecheck/should_fail/tcfail129 - - typecheck/should_fail/tcfail187 - -} - TcRnArityMismatch :: !TyThing - -> !Arity -- ^ expected arity - -> !Arity -- ^ actual arity - -> TcRnMessage - - {-| TcRnIllegalClassInstance is a collection of diagnostics that arise - from an invalid class or family instance declaration. - - See t'IllegalInstanceReason'. - -} - TcRnIllegalInstance :: IllegalInstanceReason -> TcRnMessage - - {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction) - that arises when the monomorphism restriction applies to the given bindings. - - Examples(s): - {-# OPTIONS_GHC -Wmonomorphism-restriction #-} - - bar = 10 - - foo :: Int - foo = bar - - main :: IO () - main = print foo - - The example above emits the warning (for 'bar'), because without monomorphism - restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us - that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar' - less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that. - - Test cases: typecheck/should_compile/T13785 - -} - TcRnMonomorphicBindings :: [Name] -> TcRnMessage - - {-| TcRnOrphanInstance is a warning (controlled by -Worphans) that arises when - a typeclass instance or family instance is an \"orphan\", i.e. if it - appears in a module in which neither the class/family nor the type being - instanced are declared in the same module. - - Examples(s): None - - Test cases: warnings/should_compile/T9178 - typecheck/should_compile/T4912 - -} - TcRnOrphanInstance :: Either ClsInst FamInst -> TcRnMessage - - {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies - conflicts between instance declarations. - - Examples(s): None - - Test cases: typecheck/should_fail/T2307 - typecheck/should_fail/tcfail096 - typecheck/should_fail/tcfail202 - -} - TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage - - {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance - declarations. - - Examples(s): - class Foo a where - foo :: a -> Int - - instance Foo Int where - foo = id - - instance Foo Int where - foo = const 42 - - Test cases: cabal/T12733/T12733 - typecheck/should_fail/tcfail035 - typecheck/should_fail/tcfail023 - backpack/should_fail/bkpfail18 - typecheck/should_fail/TcNullaryTCFail - typecheck/should_fail/tcfail036 - typecheck/should_fail/tcfail073 - module/mod51 - module/mod52 - module/mod44 - -} - TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage - - {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting - family instance declarations. - - Examples(s): None. - - Test cases: indexed-types/should_fail/ExplicitForAllFams4b - indexed-types/should_fail/NoGood - indexed-types/should_fail/Over - indexed-types/should_fail/OverDirectThisMod - indexed-types/should_fail/OverIndirectThisMod - indexed-types/should_fail/SimpleFail11a - indexed-types/should_fail/SimpleFail11b - indexed-types/should_fail/SimpleFail11c - indexed-types/should_fail/SimpleFail11d - indexed-types/should_fail/SimpleFail2a - indexed-types/should_fail/SimpleFail2b - indexed-types/should_fail/T13092/T13092 - indexed-types/should_fail/T13092c/T13092c - indexed-types/should_fail/T14179 - indexed-types/should_fail/T2334A - indexed-types/should_fail/T2677 - indexed-types/should_fail/T3330b - indexed-types/should_fail/T4246 - indexed-types/should_fail/T7102a - indexed-types/should_fail/T9371 - polykinds/T7524 - typecheck/should_fail/UnliftedNewtypesOverlap - -} - TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage - - {-| TcRnFamInstNotInjective is a collection of errors that arise from - a type family equation violating the injectivity annotation. - - See 'InjectivityErrReason'. - -} - TcRnFamInstNotInjective :: InjectivityErrReason -- ^ the violation - -> TyCon -- ^ the family 'TyCon' - -> NE.NonEmpty CoAxBranch -- ^ the family equations - -> TcRnMessage - - {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that - occurs when a strictness annotation is applied to an unlifted type. - - Example(s): - data T = MkT !Int# -- Strictness flag has no effect on unlifted types - - Test cases: typecheck/should_compile/T20187a - typecheck/should_compile/T20187b - -} - TcRnBangOnUnliftedType :: !Type -> TcRnMessage - - {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that - occurs when a lazy annotation is applied to an unlifted type. - - Example(s): - data T = MkT ~Int# -- Lazy flag has no effect on unlifted types - - Test cases: typecheck/should_compile/T21951a - typecheck/should_compile/T21951b - -} - TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage - - {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has - more than one default declaration. - - Example: - default (Integer, Int) - default (Double, Float) -- 2nd default declaration not allowed - - Text cases: module/mod58 - -} - TcRnMultipleDefaultDeclarations :: [LDefaultDecl GhcRn] -> TcRnMessage - - {-| TcRnBadDefaultType is an error that occurs when a type used in a default - declaration does not have an instance for any of the applicable classes. - - Example(s): - data Foo - default (Foo) - - Test cases: typecheck/should_fail/T11974b - -} - TcRnBadDefaultType :: Type -> [Class] -> TcRnMessage - - {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's - export list bundles a pattern synonym with a type that is not a proper - `data` or `newtype` construction. - - Example(s): - module Foo (MyClass(.., P)) where - pattern P = Nothing - class MyClass a where - foo :: a -> Int - - Test cases: patsyn/should_fail/export-class - -} - TcRnPatSynBundledWithNonDataCon :: TcRnMessage - - {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list - of a module has a pattern synonym bundled with a type that does not match - the type of the pattern synonym. - - Example(s): - module Foo (R(P,x)) where - data Q = Q Int - data R = R - pattern P{x} = Q x - - Text cases: patsyn/should_fail/export-ps-rec-sel - patsyn/should_fail/export-type-synonym - patsyn/should_fail/export-type - -} - TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage - - {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that - occurs when a module appears more than once in an export list. - - Example(s): - module Foo (module Bar, module Bar) - import Bar - - Text cases: None - -} - TcRnDupeModuleExport :: ModuleName -> TcRnMessage - - {-| TcRnExportedModNotImported is an error that occurs when an export list - contains a module that is not imported. - - Example(s): None - - Text cases: module/mod135 - module/mod8 - rename/should_fail/rnfail028 - backpack/should_fail/bkpfail48 - -} - TcRnExportedModNotImported :: ModuleName -> TcRnMessage - - {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs - when an export list contains a module that has no exports. - - Example(s): - module Foo (module Bar) where - import Bar () - - Test cases: None - -} - TcRnNullExportedModule :: ModuleName -> TcRnMessage - - {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that - occurs when a module does not have an explicit export list. - - Example(s): None - - Test cases: typecheck/should_fail/MissingExportList03 - -} - TcRnMissingExportList :: ModuleName -> TcRnMessage - - {-| TcRnExportHiddenComponents is an error that occurs when an export contains - constructor or class methods that are not visible. - - Example(s): None - - Test cases: None - -} - TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage - - {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs - when an identifier appears in an export list more than once. - - Example(s): None - - Test cases: module/MultiExport - module/mod128 - module/mod14 - module/mod5 - overloadedrecflds/should_fail/DuplicateExports - patsyn/should_compile/T11959 - -} - TcRnDuplicateExport :: GlobalRdrElt -> IE GhcPs -> IE GhcPs -> TcRnMessage - - {-| TcRnExportedParentChildMismatch is an error that occurs when an export is - bundled with a parent that it does not belong to - - Example(s): - module Foo (T(a)) where - data T - a = True - - Test cases: module/T11970 - module/T11970B - module/mod17 - module/mod3 - overloadedrecflds/should_fail/NoParent - -} - TcRnExportedParentChildMismatch :: Name -- ^ parent - -> TyThing - -> Name -- ^ child - -> [Name] -> TcRnMessage - - {-| TcRnConflictingExports is an error that occurs when different identifiers that - have the same name are being exported by a module. - - Example(s): - module Foo (Bar.f, module Baz) where - import qualified Bar (f) - import Baz (f) - - Test cases: module/mod131 - module/mod142 - module/mod143 - module/mod144 - module/mod145 - module/mod146 - module/mod150 - module/mod155 - overloadedrecflds/should_fail/T14953 - overloadedrecflds/should_fail/overloadedrecfldsfail10 - rename/should_fail/rnfail029 - rename/should_fail/rnfail040 - typecheck/should_fail/T16453E2 - typecheck/should_fail/tcfail025 - typecheck/should_fail/tcfail026 - -} - TcRnConflictingExports - :: OccName -- ^ Occurrence name shared by both exports - -> GlobalRdrElt -- ^ First export - -> IE GhcPs -- ^ Export decl of first export - -> GlobalRdrElt -- ^ Second export - -> IE GhcPs -- ^ Export decl of second export - -> TcRnMessage - - {-| TcRnDuplicateFieldExport is an error that occurs when a module exports - multiple record fields with the same name, without enabling - DuplicateRecordFields. - - Example: - - module M1 where - data D1 = MkD1 { foo :: Int } - module M2 where - data D2 = MkD2 { foo :: Int } - module M ( D1(..), D2(..) ) where - import module M1 - import module M2 - - Test case: overloadedrecflds/should_fail/overloadedrecfldsfail10 - -} - TcRnDuplicateFieldExport - :: (GlobalRdrElt, IE GhcPs) - -> NE.NonEmpty (GlobalRdrElt, IE GhcPs) - -> TcRnMessage - - {-| TcRnAmbiguousRecordUpdate is a warning, controlled by -Wambiguous-fields, - which occurs when a user relies on the type-directed disambiguation - mechanism to disambiguate a record update. This will not be supported by - -XDuplicateRecordFields in future releases. - - Example(s): - - data Person = MkPerson { personId :: Int, name :: String } - data Address = MkAddress { personId :: Int, address :: String } - bad1 x = x { personId = 4 } :: Person -- ambiguous - bad2 (x :: Person) = x { personId = 4 } -- ambiguous - good x = (x :: Person) { personId = 4 } -- not ambiguous - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 - -} - TcRnAmbiguousRecordUpdate - :: HsExpr GhcRn -- ^ Field update - -> TyCon -- ^ Record type - -> TcRnMessage - - {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring - when the intialisation of a record is missing one or more (lazy) fields. - - Example(s): - data Rec = Rec { a :: Int, b :: String, c :: Bool } - x = Rec { a = 1, b = "two" } -- missing field 'c' - - Test cases: deSugar/should_compile/T13870 - deSugar/should_compile/ds041 - patsyn/should_compile/T11283 - rename/should_compile/T5334 - rename/should_compile/T12229 - rename/should_compile/T5892a - warnings/should_fail/WerrorFail2 - -} - TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage - - {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's - type mentions something that is outside the universally quantified variables - of the data constructor, such as an existentially quantified type. - - Example(s): - data X = forall a. MkX { f :: a } - x = (MkX ()) { f = False } - - Test cases: patsyn/should_fail/records-exquant - typecheck/should_fail/T3323 - -} - TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage - - {-| TcRnMissingStrictFields is an error occurring when a record field marked - as strict is omitted when constructing said record. - - Example(s): - data R = R { strictField :: !Bool, nonStrict :: Int } - x = R { nonStrict = 1 } - - Test cases: typecheck/should_fail/T18869 - typecheck/should_fail/tcfail085 - typecheck/should_fail/tcfail112 - -} - TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage - - {-| TcRnAmbiguousFieldInUpdate is an error that occurs when a field in a - record update clashes with another field or top-level function of the - same name, and the user hasn't enabled -XDisambiguateRecordFields. - - Example: - - {-# LANGUAGE NoFieldSelectors #-} - {-# LANGUAGE NoDisambiguateRecordFields #-} - module M where - - data A = MkA { fld :: Int } - - fld :: Bool - fld = False - - f r = r { fld = 3 } - - -} - TcRnAmbiguousFieldInUpdate :: (GlobalRdrElt, GlobalRdrElt, [GlobalRdrElt]) - -> TcRnMessage - - {-| TcRnBadRecordUpdate is an error when a regular (non-overloaded) - record update cannot be pinned down to any one parent. - - The problem with the record update is stored in the 'BadRecordUpdateReason' - field. - - Example(s): - - data R1 = R1 { x :: Int } - data R2 = R2 { x :: Int } - update r = r { x = 1 } - -- ambiguous - - data R1 = R1 { x :: Int, y :: Int } - data R2 = R2 { y :: Int, z :: Int } - update r = r { x = 1, y = 2, z = 3 } - -- no parent has all the fields - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 - overloadedrecflds/should_fail/overloadedrecfldsfail01 - overloadedrecflds/should_fail/overloadedrecfldsfail14 - -} - TcRnBadRecordUpdate :: [RdrName] - -- ^ the fields of the record update - -> BadRecordUpdateReason - -- ^ the reason this record update was rejected - -> TcRnMessage - - {-| TcRnStaticFormNotClosed is an error pertaining to terms that are marked static - using the -XStaticPointers extension but which are not closed terms. - - Example(s): - f x = static x - - Test cases: rename/should_fail/RnStaticPointersFail01 - rename/should_fail/RnStaticPointersFail03 - -} - TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage - - {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that - occurs when trying to derive an instance of the 'Typeable' class. Deriving - 'Typeable' is no longer necessary (hence the \"useless\") as all types - automatically derive 'Typeable' in modern GHC versions. - - Example(s): None. - - Test cases: warnings/should_compile/DerivingTypeable - -} - TcRnUselessTypeable :: TcRnMessage - - {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that - occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are - enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not - be what the user wants. - - Example(s): None. - - Test cases: typecheck/should_compile/T15839a - deriving/should_compile/T16179 - -} - TcRnDerivingDefaults :: !Class -> TcRnMessage - - {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC - encounters a non-unary constraint when trying to derive a typeclass. - - Example(s): - class A - deriving instance A - data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a'). - - Test cases: deriving/should_fail/T7959 - deriving/should_fail/drvfail005 - deriving/should_fail/drvfail009 - deriving/should_fail/drvfail006 - -} - TcRnNonUnaryTypeclassConstraint :: !(LHsSigType GhcRn) -> TcRnMessage - - {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) - that occurs when a wildcard '_' is found in place of a type in a signature or a - type class derivation - - Example(s): - foo :: _ -> Int - foo = ... - - deriving instance _ => Eq (Foo a) - - Test cases: dependent/should_compile/T11241 - dependent/should_compile/T15076 - dependent/should_compile/T14880-2 - typecheck/should_compile/T17024 - typecheck/should_compile/T10072 - partial-sigs/should_fail/TidyClash2 - partial-sigs/should_fail/Defaulting1MROff - partial-sigs/should_fail/WildcardsInPatternAndExprSig - partial-sigs/should_fail/T10615 - partial-sigs/should_fail/T14584a - partial-sigs/should_fail/TidyClash - partial-sigs/should_fail/T11122 - partial-sigs/should_fail/T14584 - partial-sigs/should_fail/T10045 - partial-sigs/should_fail/PartialTypeSignaturesDisabled - partial-sigs/should_fail/T10999 - partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature - partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice - partial-sigs/should_fail/WildcardInstantiations - partial-sigs/should_run/T15415 - partial-sigs/should_compile/T10463 - partial-sigs/should_compile/T15039a - partial-sigs/should_compile/T16728b - partial-sigs/should_compile/T15039c - partial-sigs/should_compile/T10438 - partial-sigs/should_compile/SplicesUsed - partial-sigs/should_compile/T18008 - partial-sigs/should_compile/ExprSigLocal - partial-sigs/should_compile/T11339a - partial-sigs/should_compile/T11670 - partial-sigs/should_compile/WarningWildcardInstantiations - partial-sigs/should_compile/T16728 - partial-sigs/should_compile/T12033 - partial-sigs/should_compile/T15039b - partial-sigs/should_compile/T10403 - partial-sigs/should_compile/T11192 - partial-sigs/should_compile/T16728a - partial-sigs/should_compile/TypedSplice - partial-sigs/should_compile/T15039d - partial-sigs/should_compile/T11016 - partial-sigs/should_compile/T13324_compile2 - linear/should_fail/LinearPartialSig - polykinds/T14265 - polykinds/T14172 - -} - TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage - - {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance - can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason - this error arose. - - Example(s): None. - - Test cases: generics/T10604/T10604_no_PolyKinds - deriving/should_fail/drvfail009 - deriving/should_fail/drvfail-functor2 - deriving/should_fail/T10598_fail3 - deriving/should_fail/deriving-via-fail2 - deriving/should_fail/deriving-via-fail - deriving/should_fail/T16181 - -} - TcRnCannotDeriveInstance :: !Class - -- ^ The typeclass we are trying to derive - -- an instance for - -> [Type] - -- ^ The typeclass arguments, if any. - -> !(Maybe (DerivStrategy GhcTc)) - -- ^ The derivation strategy, if any. - -> !UsingGeneralizedNewtypeDeriving - -- ^ Is '-XGeneralizedNewtypeDeriving' enabled? - -> !DeriveInstanceErrReason - -- ^ The specific reason why we couldn't derive - -- an instance for the class. - -> TcRnMessage - - {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested - GADT pattern match inside a lazy (~) pattern. - - Test case: gadt/lazypat - -} - TcRnLazyGADTPattern :: TcRnMessage - - {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a - GADT pattern inside arrow proc notation. - - Test case: arrows/should_fail/arrowfail004. - -} - TcRnArrowProcGADTPattern :: TcRnMessage - - {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs - when a definition uses 'forall' as an identifier. - - Example: - forall x = () - g forall = () - - Test cases: T20609 T20609a T20609b T20609c T20609d - -} - TcRnForallIdentifier :: RdrName -> TcRnMessage - - {-| TcRnCapturedTermName is a warning (controlled by -Wterm-variable-capture) that occurs - when an implicitly quantified type variable's name is already used for a term. - Example: - a = 10 - f :: a -> a - - Test cases: T22513a T22513b T22513c T22513d T22513e T22513f T22513g T22513h T22513i - -} - TcRnCapturedTermName :: RdrName -> Either [GlobalRdrElt] Name -> TcRnMessage - - {-| TcRnTypeMultipleOccurenceOfBindVar is an error that occurs if a bound - type variable's name is already in use. - Example: - f :: forall a. ... - f (MkT @a ...) = ... - - Test cases: TyAppPat_ScopedTyVarConflict TyAppPat_NonlinearMultiPat TyAppPat_NonlinearMultiAppPat - -} - TcRnBindVarAlreadyInScope :: [LocatedN RdrName] -> TcRnMessage - - {-| TcRnBindMultipleVariables is an error that occurs in the case of - multiple occurrences of a bound variable. - Example: - foo (MkFoo @(a,a) ...) = ... - - Test case: typecheck/should_fail/TyAppPat_NonlinearSinglePat - -} - TcRnBindMultipleVariables :: HsDocContext -> LocatedN RdrName -> TcRnMessage - - {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope) - that occurs when the type equality (a ~ b) is not in scope. - - Test case: warnings/should_compile/T18862b - -} - TcRnTypeEqualityOutOfScope :: TcRnMessage - - {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators) - that occurs when the type equality (a ~ b) is used without the TypeOperators extension. - - Example: - {-# LANGUAGE NoTypeOperators #-} - f :: (a ~ b) => a -> b - - Test case: T18862a - -} - TcRnTypeEqualityRequiresOperators :: TcRnMessage - - {-| TcRnIllegalTypeOperator is an error that occurs when a type operator - is used without the TypeOperators extension. - - Example: - {-# LANGUAGE NoTypeOperators #-} - f :: Vec a n -> Vec a m -> Vec a (n + m) - - Test case: T12811 - -} - TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage - - {-| TcRnIllegalTypeOperatorDecl is an error that occurs when a type or class - operator is declared without the TypeOperators extension. - - See Note [Type and class operator definitions] - - Example: - {-# LANGUAGE Haskell2010 #-} - {-# LANGUAGE MultiParamTypeClasses #-} - - module T3265 where - - data a :+: b = Left a | Right b - - class a :*: b where {} - - - Test cases: T3265, tcfail173 - -} - TcRnIllegalTypeOperatorDecl :: !RdrName -> TcRnMessage - - {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds - that occurs when pattern matching on a GADT when -XMonoLocalBinds is off. - - Example(s): None - - Test cases: T20485, T20485a - -} - TcRnGADTMonoLocalBinds :: TcRnMessage - - {-| The TcRnNotInScope constructor is used for various not-in-scope errors. - See 'NotInScopeError' for more details. -} - TcRnNotInScope :: NotInScopeError -- ^ what the problem is - -> RdrName -- ^ the name that is not in scope - -> [ImportError] -- ^ import errors that are relevant - -> [GhcHint] -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor - -> TcRnMessage - - {-| TcRnTermNameInType is an error that occurs when a term-level identifier - is used in a type. - - Example: - - import qualified Prelude - - bad :: Prelude.fst (Bool, Float) - bad = False - - Test cases: T21605{c,d} - -} - TcRnTermNameInType :: RdrName -> [GhcHint] -> TcRnMessage - - {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors) - that is triggered by an unticked occurrence of a promoted data constructor. - - Examples: - - data A = MkA - type family F (a :: A) where { F MkA = Bool } - - type B = [ Int, Bool ] - - Test cases: T9778, T19984. - -} - TcRnUntickedPromotedThing :: UntickedPromotedThing - -> TcRnMessage - - {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears - in an unexpected location, e.g. as a data constructor or in a fixity declaration. - - Examples: - - infixl 5 : - - data P = (,) - - Test cases: rnfail042, T14907b, T15124, T15233. - -} - TcRnIllegalBuiltinSyntax :: SDoc -- ^ what kind of thing this is (a binding, fixity declaration, ...) - -> RdrName - -> TcRnMessage - -- TODO: remove the SDoc argument. - - {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults) - that is triggered whenever a Wanted typeclass constraint - is solving through the defaulting of a type variable. - - Example: - - one = show 1 - -- We get Wanteds Show a0, Num a0, and default a0 to Integer. - - Test cases: - none (which are really specific to defaulting), - but see e.g. tcfail204. - -} - TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred - -> Maybe TyVar -- ^ The type variable being defaulted - -> Type -- ^ The default type - -> TcRnMessage - - {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name' - is used in the incorrect 'NameSpace', e.g. a type constructor - or class used in a term, or a term variable used in a type. - - Example: - - f x = Int - - Test cases: T18740a, T20884. - -} - TcRnIncorrectNameSpace :: Name - -> Bool -- ^ whether the error is happening - -- in a Template Haskell tick - -- (so we should give a Template Haskell hint) - -> TcRnMessage - - {-| TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import - is declared using the @prim@ calling convention without having turned on - the -XGHCForeignImportPrim extension. - - Example(s): - foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) - - Test cases: ffi/should_fail/T20116 - -} - TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage - - {-| TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe - annotation should not be used with @prim@ foreign imports. - - Example(s): - foreign import prim unsafe "my_primop_cmm" :: ... - - Test cases: None - -} - TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage - - {-| TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ - imports cannot have function types. - - Example(s): - foreign import capi "math.h value sqrt" f :: CInt -> CInt - - Test cases: ffi/should_fail/capi_value_function - -} - TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage - - {-| TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ - that informs the user of a possible missing @&@ in the declaration of a - foreign import with a 'FunPtr' return type. - - Example(s): - foreign import ccall "f" f :: FunPtr (Int -> IO ()) - - Test cases: ffi/should_compile/T1357 - -} - TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage - - {-| TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration - is not compatible with the code generation backend being used. - - Example(s): None - - Test cases: None - -} - TcRnIllegalForeignDeclBackend - :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) - -> Backend - -> ExpectedBackends - -> TcRnMessage - - {-| TcRnUnsupportedCallConv informs the user that the calling convention specified - for a foreign export declaration is not compatible with the target platform. - It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of - @stdcall@ but is otherwise considered an error. - - Example(s): None - - Test cases: None - -} - TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) - -> UnsupportedCallConvention - -> TcRnMessage - - {-| TcRnIllegalForeignType is an error for when a type appears in a foreign - function signature that is not compatible with the FFI. - - Example(s): None - - Test cases: ffi/should_fail/T3066 - ffi/should_fail/ccfail004 - ffi/should_fail/T10461 - ffi/should_fail/T7506 - ffi/should_fail/T5664 - safeHaskell/ghci/p6 - safeHaskell/safeLanguage/SafeLang08 - ffi/should_fail/T16702 - linear/should_fail/LinearFFI - ffi/should_fail/T7243 - -} - TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage - - {-| TcRnInvalidCIdentifier indicates a C identifier that is not valid. - - Example(s): - foreign import prim safe "not valid" cmm_test2 :: Int# -> Int# - - Test cases: th/T10638 - -} - TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage - - {-| TcRnExpectedValueId is an error occurring when something that is not a - value identifier is used where one is expected. - - Example(s): none - - Test cases: none - -} - TcRnExpectedValueId :: !TcTyThing -> TcRnMessage - - {-| TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector - containing an existential type variable is used as a function rather than in - a pattern match. - - Example(s): - data Rec = forall a. Rec { field :: a } - field (Rec True) - - Test cases: patsyn/should_fail/records-exquant - typecheck/should_fail/T3176 - -} - TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage - - {-| TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern - synonym is used as a constructor. - - Example(s): - pattern Five :: Int - pattern Five <- 5 - five = Five - - Test cases: patsyn/should_fail/records-no-uni-update - patsyn/should_fail/records-no-uni-update2 - -} - TcRnPatSynNotBidirectional :: !Name -> TcRnMessage - - {-| TcRnIllegalDerivingItem is an error for when something other than a type class - appears in a deriving statement. - - Example(s): - data X = X deriving Int - - Test cases: deriving/should_fail/T5922 - -} - TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage - - {-| TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such - as strictness, laziness, or unpacking. - - Example(s): - data T = T { t :: Maybe {-# UNPACK #-} Int } - data C = C { f :: !IntMap Int } - - Test cases: parser/should_fail/unpack_inside_type - typecheck/should_fail/T7210 - -} - TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsSrcBang -> TcRnMessage - - {-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax. - - Example(s): - data T = T Int { field :: Int } - - Test cases: rename/should_fail/T7943 - rename/should_fail/T9077 - -} - TcRnIllegalRecordSyntax :: Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage - - {-| TcRnInvalidVisibleKindArgument is an error for a kind application on a - target type that cannot accept it. - - Example(s): - bad :: Int @Type - bad = 1 - type Foo :: forall a {b}. a -> b -> b - type Foo x y = y - type Bar = Foo @Bool @Int True 42 - - Test cases: indexed-types/should_fail/T16356_Fail3 - typecheck/should_fail/ExplicitSpecificity7 - typecheck/should_fail/T12045b - typecheck/should_fail/T12045c - typecheck/should_fail/T15592a - typecheck/should_fail/T15816 - -} - TcRnInvalidVisibleKindArgument - :: !(LHsType GhcRn) -- ^ The visible kind argument - -> !Type -- ^ Target of the kind application - -> TcRnMessage - - {-| TcRnTooManyBinders is an error for a type constructor that is declared with - more arguments then its kind specifies. - - Example(s): - type T :: Type -> (Type -> Type) -> Type - data T a (b :: Type -> Type) x1 (x2 :: Type -> Type) - - Test cases: saks/should_fail/saks_fail008 - -} - TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcRnMessage - - {-| TcRnDifferentNamesForTyVar is an error that indicates different names being - used for the same type variable. - - Example(s): - data SameKind :: k -> k -> * - data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) - - Test cases: polykinds/T11203 - polykinds/T11821a - saks/should_fail/T20916 - typecheck/should_fail/T17566b - typecheck/should_fail/T17566c - -} - TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage - - {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature, - where the implicitly-bound type type variables can't be matched up unambiguously - with the ones from the signature. See Note [Disconnected type variables] in - GHC.Tc.Gen.HsType. - -} - TcRnDisconnectedTyVar :: !Name -> TcRnMessage - - {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature - with an invalid result kind. - - Example(s): - data family Foo :: Constraint - - Test cases: typecheck/should_fail/T14048b - typecheck/should_fail/UnliftedNewtypesConstraintFamily - typecheck/should_fail/T12729 - typecheck/should_fail/T15883 - typecheck/should_fail/T16829a - typecheck/should_fail/T16829b - typecheck/should_fail/UnliftedNewtypesNotEnabled - typecheck/should_fail/tcfail079 - -} - TcRnInvalidReturnKind - :: !DataSort -- ^ classification of thing being returned - -> !AllowedDataResKind -- ^ allowed kind - -> !Kind -- ^ the return kind - -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension - -> TcRnMessage - - {-| TcRnUnexpectedKindVar is an error that occurs when the user - tries to use kind variables without -XPolyKinds. - - Example: - f :: forall k a. Proxy (a :: k) - - Test cases: polykinds/BadKindVar - polykinds/T14710 - saks/should_fail/T16722 - -} - TcRnUnexpectedKindVar :: RdrName -> TcRnMessage - - {-| TcRnIllegalKind is used for a various illegal kinds errors including - - Example: - type T :: forall k. Type -- without emabled -XPolyKinds - - Test cases: polykinds/T16762b - -} - TcRnIllegalKind - :: HsTypeOrSigType GhcPs - -- ^ The illegal kind - -> Bool -- ^ Whether enabling -XPolyKinds should be suggested - -> TcRnMessage - - {-| TcRnClassKindNotConstraint is an error for a type class that has a kind that - is not equivalent to Constraint. - - Example(s): - type C :: Type -> Type - class C a - - Test cases: saks/should_fail/T16826 - -} - TcRnClassKindNotConstraint :: !Kind -> TcRnMessage - - {-| TcRnUnpromotableThing is an error that occurs when the user attempts to - use the promoted version of something which is not promotable. - - Example(s): - data T :: T -> * - data X a where - MkX :: Show a => a -> X a - foo :: Proxy ('MkX 'True) - foo = Proxy - - Test cases: dependent/should_fail/PromotedClass - dependent/should_fail/T14845_fail1 - dependent/should_fail/T14845_fail2 - dependent/should_fail/T15215 - dependent/should_fail/T13780c - dependent/should_fail/T15245 - polykinds/T5716 - polykinds/T5716a - polykinds/T6129 - polykinds/T7433 - patsyn/should_fail/T11265 - patsyn/should_fail/T9161-1 - patsyn/should_fail/T9161-2 - dependent/should_fail/SelfDep - polykinds/PolyKinds06 - polykinds/PolyKinds07 - polykinds/T13625 - polykinds/T15116 - polykinds/T15116a - saks/should_fail/T16727a - saks/should_fail/T16727b - rename/should_fail/T12686 - rename/should_fail/T16635a - rename/should_fail/T16635b - rename/should_fail/T16635c - -} - TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage - - {-| TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches - that have different numbers of arguments - - Example(s): - foo x = True - foo x y = False - - Test cases: rename/should_fail/rnfail045 - typecheck/should_fail/T20768_fail - -} - TcRnMatchesHaveDiffNumArgs - :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics - -> !MatchArgBadMatches - -> TcRnMessage - - {-| TcRnUnexpectedPatSigType is an error occurring when there is - a type signature in a pattern without -XScopedTypeVariables extension - - Examples: - f (a :: Bool) = ... - - Test case: rename/should_fail/T11663 - -} - TcRnUnexpectedPatSigType :: HsPatSigType GhcPs -> TcRnMessage - - {-| TcRnIllegalKindSignature is an error occuring when there is - a kind signature without -XKindSignatures extension - - Examples: - data Foo (a :: Nat) = .... - - Test case: parser/should_fail/readFail036 - -} - TcRnIllegalKindSignature :: HsType GhcPs -> TcRnMessage - - {-| TcRnDataKindsError is an error occurring when there is - an illegal type or kind, probably required -XDataKinds - and is used without the enabled extension. - - Examples: - - type Foo = [Nat, Char] - - type Bar = [Int, String] - - Test cases: linear/should_fail/T18888 - polykinds/T7151 - th/TH_Promoted1Tuple - typecheck/should_fail/tcfail094 - -} - TcRnDataKindsError :: TypeOrKind -> HsType GhcPs -> TcRnMessage - - {-| TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type - variables cannot be used in pattern bindings. - - Example(s): - let (x :: a) = 5 - - Test cases: typecheck/should_compile/tc141 - -} - TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage - - {-| TcRnCannotBindTyVarsInPatBind is an error for when type - variables are introduced in a pattern binding - - Example(s): - Just @a x = Just True - - Test cases: typecheck/should_fail/TyAppPat_PatternBinding - typecheck/should_fail/TyAppPat_PatternBindingExistential - -} - TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage - - {-| TcRnTooManyTyArgsInConPattern is an error occurring when a constructor pattern - has more than the expected number of type arguments - - Example(s): - f (Just @Int @Bool x) = x - - Test cases: typecheck/should_fail/TyAppPat_TooMany - typecheck/should_fail/T20443b - -} - TcRnTooManyTyArgsInConPattern - :: !ConLike - -> !Int -- ^ Expected number of args - -> !Int -- ^ Actual number of args - -> TcRnMessage - - {-| TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas - reference the same definition. - - Example(s): - {-# INLINE foo #-} - {-# INLINE foo #-} - foo :: Bool -> Bool - foo = id - - Test cases: none - -} - TcRnMultipleInlinePragmas - :: !Id -- ^ Target of the pragmas - -> !(LocatedA InlinePragma) -- ^ The first pragma - -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas - -> TcRnMessage - - {-| TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear - in the source. - - Example(s): - - Test cases: none - -} - TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage - - {-| TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being - placed on a definition that is not overloaded. - - Example(s): - {-# SPECIALISE foo :: Bool -> Bool #-} - foo :: Bool -> Bool - foo = id - - Test cases: simplCore/should_compile/T8537 - typecheck/should_compile/T10504 - -} - TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage - - {-| TcRnSpecialiseNotVisible is a warning that occurs when the subject of a - SPECIALISE pragma has a definition that is not visible from the current module. - - Example(s): none - - Test cases: none - -} - TcRnSpecialiseNotVisible :: !Name -> TcRnMessage - - {-| TcRnPragmaWarning is a warning that can happen when usage of something - is warned or deprecated by pragma. - - Test cases: - DeprU - T5281 - T5867 - rn050 - rn066 (here is a warning, not deprecation) - T3303 - -} - TcRnPragmaWarning :: { - pragma_warning_occ :: OccName, - pragma_warning_msg :: WarningTxt GhcRn, - pragma_warning_import_mod :: ModuleName, - pragma_warning_defined_mod :: Maybe ModuleName - } -> TcRnMessage - - {-| TcRnDifferentExportWarnings is an error that occurs when the - warning messages for exports of a name differ between several export items. - - Test case: - DifferentExportWarnings - -} - TcRnDifferentExportWarnings :: !Name -- ^ The name with different export warnings - -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that differ - -- from the one at which the error is reported - -> TcRnMessage - - {-| TcRnIncompleteExportWarnings is a warning (controlled by -Wincomplete-export-warnings) that - occurs when some of the exports of a name do not have an export warning and some do - - Test case: - ExportWarnings6 - -} - TcRnIncompleteExportWarnings :: !Name -- ^ The name that is exported - -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that are - -- missing the export warning - -> TcRnMessage - - {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for - a class default method is provided in a Backpack signature file. - - Test case: - bkpfail40 - -} - TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class - -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods - -> TcRnMessage - - {-| TcRnHsigFixityMismatch is an error indicating that the fixity decl in a - Backpack signature file differs from the one in the source file for the same - operator. - - Test cases: - bkpfail37, bkpfail38 - -} - TcRnHsigFixityMismatch :: !TyThing -- ^ The operator whose fixity is defined - -> !Fixity -- ^ the fixity used in the source file - -> !Fixity -- ^ the fixity used in the signature - -> TcRnMessage - - {-| TcRnHsigShapeMismatch is a group of errors related to mismatches between - backpack signatures. - -} - TcRnHsigShapeMismatch :: !HsigShapeMismatchReason - -> TcRnMessage - - {-| TcRnHsigMissingModuleExport is an error indicating that a module doesn't - export a name exported by its signature. - - Test cases: - bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06 - -} - TcRnHsigMissingModuleExport :: !OccName -- ^ The missing name - -> !UnitState -- ^ The module's unit state - -> !Module -- ^ The implementation module - -> TcRnMessage - - {-| TcRnBadGenericMethod - This test ensures that if you provide a "more specific" type signatures - for the default method, you must also provide a binding. - - Example: - {-# LANGUAGE DefaultSignatures #-} - - class C a where - meth :: a - default meth :: Num a => a - meth = 0 - - Test case: - typecheck/should_fail/MissingDefaultMethodBinding.hs - -} - TcRnBadGenericMethod :: !Name -- ^ 'Name' of the class - -> !Name -- ^ Problematic method - -> TcRnMessage - - {-| TcRnWarningMinimalDefIncomplete is a warning that one must - specify which methods must be implemented by all instances. - - Example: - class Cheater a where -- WARNING LINE - cheater :: a - {-# MINIMAL #-} -- warning! - - Test case: - warnings/minimal/WarnMinimal.hs: - -} - TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage - - {-| TcRnIllegalQuasiQuotes is an error that occurs when a quasi-quote - is used without the QuasiQuotes extension. - - Example: - - foo = [myQuoter|x y z|] - - Test cases: none; the parser fails to parse this if QuasiQuotes is off. - -} - TcRnIllegalQuasiQuotes :: TcRnMessage - - {-| TcRnTHError is a family of errors involving Template Haskell. - See 'THError'. - -} - TcRnTHError :: THError -> TcRnMessage - - {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when - a default method pragma is missing an accompanying binding. - - Test cases: - typecheck/should_fail/T5084.hs - typecheck/should_fail/T2354.hs - -} - TcRnDefaultMethodForPragmaLacksBinding - :: Id -- ^ method - -> Sig GhcRn -- ^ the pragma - -> TcRnMessage - {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when - a specialise pragma is put on a default method. - - Test cases: none - -} - TcRnIgnoreSpecialisePragmaOnDefMethod - :: !Name - -> TcRnMessage - {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method - in a class instance, when the class doesn't have a method by that name. - - Test case: - th/T12387 - -} - TcRnBadMethodErr - :: { badMethodErrClassName :: !Name - , badMethodErrMethodName :: !Name - } -> TcRnMessage - - {-| TcRnIllegalNewtype is an error that occurs when a newtype: - - * Does not have exactly one field, or - * is non-linear, or - * is a GADT, or - * has a context in its constructor's type, or - * has existential type variables in its constructor's type, or - * has strictness annotations. - - Test cases: - gadt/T14719 - indexed-types/should_fail/T14033 - indexed-types/should_fail/T2334A - linear/should_fail/LinearGADTNewtype - parser/should_fail/readFail008 - polykinds/T11459 - typecheck/should_fail/T15523 - typecheck/should_fail/T15796 - typecheck/should_fail/T17955 - typecheck/should_fail/T18891a - typecheck/should_fail/T21447 - typecheck/should_fail/tcfail156 - -} - TcRnIllegalNewtype - :: DataCon - -> Bool -- ^ True if linear types enabled - -> IllegalNewtypeReason - -> TcRnMessage - - {-| TcRnIllegalTypeData is an error that occurs when a @type data@ - declaration occurs without the TypeOperators extension. - - See Note [Type data declarations] - - Test case: - type-data/should_fail/TDNoPragma - -} - TcRnIllegalTypeData :: TcRnMessage - - {-| TcRnTypeDataForbids is an error that occurs when a @type data@ - declaration contains @data@ declaration features that are - forbidden in a @type data@ declaration. - - See Note [Type data declarations] - - Test cases: - type-data/should_fail/TDDeriving - type-data/should_fail/TDRecordsGADT - type-data/should_fail/TDRecordsH98 - type-data/should_fail/TDStrictnessGADT - type-data/should_fail/TDStrictnessH98 - -} - TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage - - {-| TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance - is missing methods that are required by the minimal definition. - - Example: - class C a where - foo :: a -> a - instance C () -- | foo needs to be defined here - - Test cases: - typecheck/prog001/typecheck.prog001 - typecheck/should_compile/tc126 - typecheck/should_compile/T7903 - typecheck/should_compile/tc116 - typecheck/should_compile/tc175 - typecheck/should_compile/HasKey - typecheck/should_compile/tc125 - typecheck/should_compile/tc078 - typecheck/should_compile/tc161 - typecheck/should_fail/T5051 - typecheck/should_compile/T21583 - backpack/should_compile/bkp47 - backpack/should_fail/bkpfail25 - parser/should_compile/T2245 - parser/should_compile/read014 - indexed-types/should_compile/Class3 - indexed-types/should_compile/Simple2 - indexed-types/should_fail/T7862 - deriving/should_compile/deriving-1935 - deriving/should_compile/T9968a - deriving/should_compile/drv003 - deriving/should_compile/T4966 - deriving/should_compile/T14094 - perf/compiler/T15304 - warnings/minimal/WarnMinimal - simplCore/should_compile/simpl020 - deSugar/should_compile/T14546d - ghci/scripts/T5820 - ghci/scripts/ghci019 - -} - TcRnUnsatisfiedMinimalDef :: ClassMinimalDef -> TcRnMessage - - {-| 'TcRnMisplacedInstSig' is an error that happens when a method in - a class instance is given a type signature, but the user has not - enabled the @InstanceSigs@ extension. - - Test case: module/mod45 - -} - TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage - {-| TcRnNoRebindableSyntaxRecordDot is an error triggered by an overloaded record update - without RebindableSyntax enabled. - - Example(s): - - Test cases: parser/should_fail/RecordDotSyntaxFail5 - -} - TcRnNoRebindableSyntaxRecordDot :: TcRnMessage - - {-| TcRnNoFieldPunsRecordDot is an error triggered by the use of record field puns - in an overloaded record update without enabling NamedFieldPuns. - - Example(s): - print $ a{ foo.bar.baz.quux } - - Test cases: parser/should_fail/RecordDotSyntaxFail12 - -} - TcRnNoFieldPunsRecordDot :: TcRnMessage - - {-| TcRnIllegalStaticExpression is an error thrown when user creates a static - pointer via TemplateHaskell without enabling the StaticPointers extension. - - Example(s): - - Test cases: th/T14204 - -} - TcRnIllegalStaticExpression :: HsExpr GhcPs -> TcRnMessage - - {-| TcRnListComprehensionDuplicateBinding is an error triggered by duplicate - let-bindings in a list comprehension. - - Example(s): - [ () | let a = 13 | let a = 17 ] - - Test cases: typecheck/should_fail/tcfail092 - -} - TcRnListComprehensionDuplicateBinding :: Name -> TcRnMessage - - {-| TcRnEmptyStmtsGroup is an error triggered by an empty list of statements - in a statement block. For more information, see 'EmptyStatementGroupErrReason' - - Example(s): - - [() | then ()] - - do - - proc () -> do - - Test cases: rename/should_fail/RnEmptyStatementGroup1 - -} - TcRnEmptyStmtsGroup:: EmptyStatementGroupErrReason -> TcRnMessage - - {-| TcRnLastStmtNotExpr is an error caused by the last statement - in a statement block not being an expression. - - Example(s): - - do x <- pure () - - do let x = 5 - - Test cases: rename/should_fail/T6060 - parser/should_fail/T3811g - parser/should_fail/readFail028 - -} - TcRnLastStmtNotExpr - :: HsStmtContext GhcRn - -> UnexpectedStatement - -> TcRnMessage - - {-| TcRnUnexpectedStatementInContext is an error when a statement appears - in an unexpected context (e.g. an arrow statement appears in a list comprehension). - - Example(s): - - Test cases: parser/should_fail/readFail042 - parser/should_fail/readFail038 - parser/should_fail/readFail043 - -} - TcRnUnexpectedStatementInContext - :: HsStmtContext GhcRn - -> UnexpectedStatement - -> Maybe LangExt.Extension - -> TcRnMessage - - {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section - without enabling the TupleSections extension. - - Example(s): - (5,) - - Test cases: rename/should_fail/rnfail056 - -} - TcRnIllegalTupleSection :: TcRnMessage - - {-| TcRnIllegalImplicitParameterBindings is an error triggered by binding - an implicit parameter in an mdo block. - - Example(s): - mdo { let { ?x = 5 }; () } - - Test cases: rename/should_fail/RnImplicitBindInMdoNotation - -} - TcRnIllegalImplicitParameterBindings - :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) - -> TcRnMessage - - {-| TcRnSectionWithoutParentheses is an error triggered by attempting to - use an operator section without parentheses. - - Example(s): - (`head` x, ()) - - Test cases: rename/should_fail/T2490 - rename/should_fail/T5657 - -} - TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage - - {-| TcRnBindingOfExistingName is an error triggered by an attempt to rebind - built-in syntax, punned list or tuple syntax, or a name quoted via Template Haskell. - - Examples: - - data [] - data (->) - $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) - - Test cases: rename/should_fail/T14907b - rename/should_fail/T22839 - rename/should_fail/rnfail042 - th/T13968 - -} - TcRnBindingOfExistingName :: RdrName -> TcRnMessage - {-| TcRnMultipleFixityDecls is an error triggered by multiple - fixity declarations for the same operator. - - Example(s): - - infixr 6 $$ - infixl 4 $$ - - Test cases: rename/should_fail/RnMultipleFixityFail - -} - TcRnMultipleFixityDecls :: SrcSpan -> RdrName -> TcRnMessage - - {-| TcRnIllegalPatternSynonymDecl is an error thrown when a user - defines a pattern synonyms without enabling the PatternSynonyms extension. - - Example: - - pattern O :: Int - pattern O = 0 - - Test cases: rename/should_fail/RnPatternSynonymFail - -} - TcRnIllegalPatternSynonymDecl :: TcRnMessage - - {-| TcRnIllegalClassBinding is an error triggered by a binding - in a class or instance declaration of an illegal form. - - Examples: - - class ZeroOne a where - zero :: a - one :: a - instance ZeroOne Int where - (zero,one) = (0,1) - - class C a where - pattern P = () - - Test cases: module/mod48 - patsyn/should_fail/T9705-1 - patsyn/should_fail/T9705-2 - typecheck/should_fail/tcfail021 - - -} - TcRnIllegalClassBinding :: DeclSort -> HsBindLR GhcPs GhcPs -> TcRnMessage - - {-| TcRnOrphanCompletePragma is an error triggered by a {-# COMPLETE #-} - pragma which does not mention any data constructors or pattern synonyms - defined in the current module. - - Test cases: patsyn/should_fail/T13349 - -} - TcRnOrphanCompletePragma :: TcRnMessage - - {-| TcRnEmptyCase is an error thrown when a user uses - a case expression with an empty list of alternatives without - enabling the EmptyCase extension. - - Example(s): - - case () of - - Test cases: rename/should_fail/RnEmptyCaseFail - -} - TcRnEmptyCase :: HsMatchContext GhcRn -> TcRnMessage - - {-| TcRnNonStdGuards is a warning thrown when a user uses - non-standard guards (e.g. patterns in guards) without - enabling the PatternGuards extension. - More realistically: the user has explicitly disabled PatternGuards, - as it is enabled by default with `-XHaskell2010`. - - Example(s): - - f | 5 <- 2 + 3 = ... - - Test cases: rename/should_compile/rn049 - -} - TcRnNonStdGuards :: NonStandardGuards -> TcRnMessage - - {-| TcRnDuplicateSigDecl is an error triggered by two or more - signatures for one entity. - - Examples: - - f :: Int -> Bool - f :: Int -> Bool - f _ = True - - g x = x - {-# INLINE g #-} - {-# NOINLINE g #-} - - pattern P = () - {-# COMPLETE P #-} - {-# COMPLETE P #-} - - Test cases: module/mod68 - parser/should_fail/OpaqueParseFail4 - patsyn/should_fail/T12165 - rename/should_fail/rnfail048 - rename/should_fail/T5589 - rename/should_fail/T7338 - rename/should_fail/T7338a - -} - TcRnDuplicateSigDecl :: NE.NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRnMessage - - {-| TcRnMisplacedSigDecl is an error triggered by the pragma application - in the wrong context, like `MINIMAL` applied to a function or - `SPECIALIZE` to an instance. - - Example: - - f x = x - {-# MINIMAL f #-} - - Test cases: rename/should_fail/T18138 - warnings/minimal/WarnMinimalFail1 - -} - TcRnMisplacedSigDecl :: Sig GhcRn -> TcRnMessage - - {-| TcRnUnexpectedDefaultSig is an error thrown when a user uses - default signatures without enabling the DefaultSignatures extension. - - Example: - - class C a where - m :: a - default m :: Num a => a - m = 0 - - Test cases: rename/should_fail/RnDefaultSigFail - -} - TcRnUnexpectedDefaultSig :: Sig GhcPs -> TcRnMessage - - {-| TcRnDuplicateMinimalSig is an error triggered by two or more minimal - signatures for one type class. - - Example: - - class C where - f :: () - {-# MINIMAL f #-} - {-# MINIMAL f #-} - - Test cases: rename/should_fail/RnMultipleMinimalPragmaFail - -} - TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage - - {-| 'TcRnIllegalInvisTyVarBndr' is an error that occurs - when invisible type variable binders in type declarations - are used without enabling the @TypeAbstractions@ extension. - - Example: - {-# LANGUAGE NoTypeAbstractions #-} -- extension disabled - data T @k (a :: k) @(j :: Type) (b :: j) - ^^ ^^^^^^^^^^^^ - - Test case: T22560_fail_ext - -} - TcRnIllegalInvisTyVarBndr - :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) - -> TcRnMessage - - {-| 'TcRnInvalidInvisTyVarBndr' is an error that occurs - when an invisible type variable binder has no corresponding - @forall k.@ quantifier in the standalone kind signature. - - Example: - type P :: forall a -> Type - data P @a = MkP - - Test cases: T22560_fail_a T22560_fail_b - -} - TcRnInvalidInvisTyVarBndr - :: !Name - -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) - -> TcRnMessage - - {-| 'TcRnInvisBndrWithoutSig' is an error triggered by attempting to use - an invisible type variable binder in a type declaration without a - standalone kind signature or a complete user-supplied kind. - - Example: - data T @k (a :: k) -- No CUSK, no SAKS - - Test case: T22560_fail_d - -} - TcRnInvisBndrWithoutSig - :: !Name - -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) - -> TcRnMessage - - {-| TcRnDeprecatedInvisTyArgInConPat is a warning that triggers on type applications - in constructor patterns when the user has not enabled '-XTypeAbstractions' - but instead has enabled both '-XScopedTypeVariables' and '-XTypeApplications'. - - This warning is a deprecation mechanism that is scheduled until GHC 9.12. - -} - TcRnDeprecatedInvisTyArgInConPat - :: TcRnMessage - - {-| TcRnLoopySuperclassSolve is a warning, controlled by @-Wloopy-superclass-solve@, - that is triggered when GHC solves a constraint in a possibly-loopy way, - violating the class instance termination rules described in the section - "Undecidable instances and loopy superclasses" of the user's guide. - - Example: - - class Foo f - class Foo f => Bar f g - instance Bar f f => Bar f (h k) - - Test cases: T20666, T20666{a,b}, T22891, T22912. - -} - TcRnLoopySuperclassSolve :: CtLoc -- ^ Wanted 'CtLoc' - -> PredType -- ^ Wanted 'PredType' - -> TcRnMessage - - {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses - standalone deriving without enabling the StandaloneDeriving extension. - - Example: - - deriving instance Eq Foo - - Test cases: rename/should_fail/RnUnexpectedStandaloneDeriving - -} - TcRnUnexpectedStandaloneDerivingDecl :: TcRnMessage - - {-| TcRnUnusedVariableInRuleDecl is an error triggered by forall'd variable in - rewrite rule that does not appear on left-hand side - - Example: - - {-# RULES "rule" forall a. id = id #-} - - Test cases: rename/should_fail/ExplicitForAllRules2 - -} - TcRnUnusedVariableInRuleDecl :: FastString -> Name -> TcRnMessage - - {-| TcRnUnexpectedStandaloneKindSig is an error thrown when a user uses standalone - kind signature without enabling the StandaloneKindSignatures extension. - - Example: - - type D :: Type - data D = D - - Test cases: saks/should_fail/saks_fail001 - -} - TcRnUnexpectedStandaloneKindSig :: TcRnMessage - - {-| TcRnIllegalRuleLhs is an error triggered by malformed left-hand side - of rewrite rule - - Examples: - - {-# RULES "test" forall x. f x = x #-} - - {-# RULES "test" forall x. case x of = x #-} - - Test cases: rename/should_fail/T15659 - -} - TcRnIllegalRuleLhs - :: RuleLhsErrReason - -> FastString -- Rule name - -> LHsExpr GhcRn -- Full expression - -> HsExpr GhcRn -- Bad expression - -> TcRnMessage - - {-| TcRnDuplicateRoleAnnot is an error triggered by two or more role - annotations for one type - - Example: - - data D a - type role D phantom - type role D phantom - - Test cases: roles/should_fail/Roles8 - -} - TcRnDuplicateRoleAnnot :: NE.NonEmpty (LRoleAnnotDecl GhcPs) -> TcRnMessage - - {-| TcRnDuplicateKindSig is an error triggered by two or more standalone - kind signatures for one type - - Example: - - type D :: Type - type D :: Type - data D - - Test cases: saks/should_fail/saks_fail002 - -} - TcRnDuplicateKindSig :: NE.NonEmpty (LStandaloneKindSig GhcPs) -> TcRnMessage - - {-| TcRnIllegalDerivStrategy is an error thrown when a user uses deriving - strategy without enabling the DerivingStrategies extension or uses deriving - via without enabling the DerivingVia extension. - - Examples: - - data T = T deriving stock Eq - - data T = T deriving via Eq T - - Test cases: deriving/should_fail/deriving-via-fail3 - deriving/should_fail/T10598_fail4 - -} - TcRnIllegalDerivStrategy :: DerivStrategy GhcPs -> TcRnMessage - - {-| TcRnIllegalMultipleDerivClauses is an error thrown when a user uses two or more - deriving clauses without enabling the DerivingStrategies extension. - - Example: - - data T = T - deriving Eq - deriving Ord - - Test cases: deriving/should_fail/T10598_fail5 - -} - TcRnIllegalMultipleDerivClauses :: TcRnMessage - - {-| TcRnNoDerivStratSpecified is a warning implied by -Wmissing-deriving-strategies - and triggered by deriving clause without specified deriving strategy. - - Example: - - data T = T - deriving Eq - - Test cases: rename/should_compile/T15798a - rename/should_compile/T15798b - rename/should_compile/T15798c - -} - TcRnNoDerivStratSpecified - :: Bool -- True if DerivingStrategies is enabled - -> TcRnMessage - - {-| TcRnStupidThetaInGadt is an error triggered by data contexts in GADT-style - data declaration - - Example: - - data (Eq a) => D a where - MkD :: D Int - - Test cases: rename/should_fail/RnStupidThetaInGadt - -} - TcRnStupidThetaInGadt :: HsDocContext -> TcRnMessage - - {-| TcRnShadowedTyVarNameInFamResult is an error triggered by type variable in - type family result that shadows type variable from left hand side - - Example: - - type family F a b c = b - - Test cases: ghci/scripts/T6018ghcirnfail - rename/should_fail/T6018rnfail - -} - TcRnShadowedTyVarNameInFamResult :: IdP GhcPs -> TcRnMessage - - {-| TcRnIncorrectTyVarOnRhsOfInjCond is an error caused by a situation where the - left-hand side of an injectivity condition of a type family is not a variable - referring to the type family result. - See Note [Renaming injectivity annotation] for more details. - - Example: - - type family F a = r | a -> a - - Test cases: ghci/scripts/T6018ghcirnfail - rename/should_fail/T6018rnfail - -} - TcRnIncorrectTyVarOnLhsOfInjCond - :: IdP GhcRn -- Expected - -> LIdP GhcPs -- Actual - -> TcRnMessage - - {-| TcRnUnknownTyVarsOnRhsOfInjCond is an error triggered by out-of-scope type - variables on the right-hand side of a of an injectivity condition of a type family - - Example: - - type family F a = res | res -> b - - Test cases: ghci/scripts/T6018ghcirnfail - rename/should_fail/T6018rnfail - -} - TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage - - {-| TcRnLookupInstance groups several errors emitted when looking up class instances. - - Test cases: - none - -} - TcRnLookupInstance - :: !Class - -> ![Type] - -> !LookupInstanceErrReason - -> TcRnMessage - - {-| TcRnBadlyStaged is an error that occurs when a TH binding is used in an - invalid stage. - - Test cases: - T17820d - -} - TcRnBadlyStaged - :: !StageCheckReason -- ^ The binding being spliced. - -> !Int -- ^ The binding stage. - -> !Int -- ^ The stage at which the binding is used. - -> TcRnMessage - - {-| TcRnStageRestriction is an error that occurs when a top level splice refers to - a local name. - - Test cases: - T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9} - -} - TcRnStageRestriction - :: !StageCheckReason -- ^ The binding being spliced. - -> TcRnMessage - - {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another - thing was expected. - - Test cases: - none - -} - TcRnTyThingUsedWrong - :: !WrongThingSort -- ^ Expected thing. - -> !TcTyThing -- ^ Thing used wrongly. - -> !Name -- ^ Name of the thing used wrongly. - -> TcRnMessage - - {-| TcRnCannotDefaultKindVar is an error that occurs when attempting to use - unconstrained kind variables whose type isn't @Type@, without -XPolyKinds. - - Test cases: - T11334b - -} - TcRnCannotDefaultKindVar - :: !TyVar -- ^ The unconstrained variable. - -> !Kind -- ^ Kind of the variable. - -> TcRnMessage - - {-| TcRnUninferrableTyVar is an error that occurs when metavariables - in a type could not be defaulted. - - Test cases: - T17301, T17562, T17567, T17567StupidTheta, T15474, T21479 - -} - TcRnUninferrableTyVar - :: ![TyCoVar] -- ^ The variables that could not be defaulted. - -> !UninferrableTyVarCtx -- ^ Description of the surrounding context. - -> TcRnMessage - - {-| TcRnSkolemEscape is an error that occurs when type variables from an - outer scope is used in a context where they should be locally scoped. - - Test cases: - T15076, T15076b, T14880-2, T15825, T14880, T15807, T16946, T14350, - T14040A, T15795, T15795a, T14552 - -} - TcRnSkolemEscape - :: ![TcTyVar] -- ^ The variables that would escape. - -> !TcTyVar -- ^ The variable that is being quantified. - -> !Type -- ^ The type in which they occur. - -> TcRnMessage - - {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from - a pattern synonym into a type. - See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn - - Test cases: - T14507 - -} - TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable - -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions - -> TcRnMessage - - {-| TcRnPatSynExistentialInResult is an error indicating that the result type - of a pattern synonym mentions an existential type variable. - - Test cases: - PatSynExistential - -} - TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym - -> !TcSigmaType -- ^ The result type - -> ![TyVar] -- ^ The escaped existential variables - -> TcRnMessage - - {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a - pattern synonym's equation differs from the number of parameters in its - signature. - - Test cases: - PatSynArity - -} - TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym - -> !Arity -- ^ The number of equation arguments - -> !Arity -- ^ The difference - -> TcRnMessage - - {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the - right hand side of a pattern synonym is invalid. - - Test cases: - unidir, T14112 - -} - TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym - -> !(LPat GhcRn) -- ^ The pattern - -> ![LIdP GhcRn] -- ^ The LHS args - -> !PatSynInvalidRhsReason -- ^ The number of equation arguments - -> TcRnMessage - - {-| TcRnZonkerMessage is collection of errors that occur when zonking, - i.e. filling in metavariables with their final values. - - See 'ZonkerMessage' - -} - TcRnZonkerMessage :: ZonkerMessage -> TcRnMessage - - {-| TcRnTyFamDepsDisabled is an error indicating that a type family injectivity - annotation was used without enabling the extension TypeFamilyDependencies. - - Test cases: - T11381 - -} - TcRnTyFamDepsDisabled :: TcRnMessage - - {-| TcRnAbstractClosedTyFamDecl is an error indicating that an abstract closed - type family was declared in a regular source file, while it is only allowed - in hs-boot files. - - Test cases: - ClosedFam4 - -} - TcRnAbstractClosedTyFamDecl :: TcRnMessage - - {-| TcRnPartialFieldSelector is a warning indicating that a record selector - was not defined for all constructors of a data type. - - Test cases: - DRFPartialFields, T7169 - -} - TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector - -> TcRnMessage - - {-| TcRnBadFieldAnnotation is an error/warning group indicating that a - strictness/unpack related data type field annotation is invalid. - -} - TcRnBadFieldAnnotation :: !Int -- ^ The index of the field - -> !DataCon -- ^ The constructor in which the field is defined - -> !BadFieldAnnotationReason -- ^ The error specifics - -> TcRnMessage - - {-| TcRnSuperclassCycle is an error indicating that a class has a superclass - cycle. - - Test cases: - mod40, tcfail027, tcfail213, tcfail216, tcfail217, T9415, T9739 - -} - TcRnSuperclassCycle :: !SuperclassCycle -- ^ The details of the cycle - -> TcRnMessage - - {-| TcRnDefaultSigMismatch is an error indicating that a default method - signature doesn't match the regular method signature. - - Test cases: - T7437, T12918a, T12918b, T12151 - -} - TcRnDefaultSigMismatch :: !Id -- ^ The name of the method - -> !Type -- ^ The type of the default signature - -> TcRnMessage - - {-| TcRnTyFamsDisabled is an error indicating that a type family or instance - was declared while the extension TypeFamilies was disabled. - - Test cases: - TyFamsDisabled - -} - TcRnTyFamsDisabled :: !TyFamsDisabledReason -- ^ The name of the family or instance - -> TcRnMessage - - {-| TcRnBadTyConTelescope is an error caused by an ill-scoped 'TyCon' kind, - due to type variables being out of dependency order. - - Example: - - class C a (b :: Proxy a) (c :: Proxy b) where - type T c a - - Test cases: - BadTelescope{∅,3,4} - T14066{f,g} - T14887 - T15591{b,c} - T15743{c,d} - T15764 - T23252 - - -} - TcRnBadTyConTelescope :: !TyCon -> TcRnMessage - - {-| TcRnTyFamResultDisabled is an error indicating that a result variable - was used on a type family while the extension TypeFamilyDependencies was - disabled. - - Test cases: - T13571, T13571a - -} - TcRnTyFamResultDisabled :: !Name -- ^ The name of the type family - -> !(LHsTyVarBndr () GhcRn) -- ^ Name of the result variable - -> TcRnMessage - - {-| TcRnRoleValidationFailed is an error indicating that a variable was - assigned an invalid role by the inference algorithm. - This is only performed with -dcore-lint. - -} - TcRnRoleValidationFailed :: !Role -- ^ The validated role - -> !RoleValidationFailedReason -- ^ The failure reason - -> TcRnMessage - - {-| TcRnCommonFieldResultTypeMismatch is an error indicating that a sum type - declares the same field name in multiple constructors, but the constructors' - result types differ. - - Test cases: - CommonFieldResultTypeMismatch - -} - TcRnCommonFieldResultTypeMismatch :: !DataCon -- ^ First constructor - -> !DataCon -- ^ Second constructor - -> !FieldLabelString -- ^ Field name - -> TcRnMessage - - {-| TcRnCommonFieldTypeMismatch is an error indicating that a sum type - declares the same field name in multiple constructors, but their types - differ. - - Test cases: - CommonFieldTypeMismatch - -} - TcRnCommonFieldTypeMismatch :: !DataCon -- ^ First constructor - -> !DataCon -- ^ Second constructor - -> !FieldLabelString -- ^ Field name - -> TcRnMessage - - {-| TcRnClassExtensionDisabled is an error indicating that a class - was declared with an extension feature while the extension was disabled. - -} - TcRnClassExtensionDisabled :: !Class -- ^ The class - -> !DisabledClassExtension -- ^ The extension - -> TcRnMessage - - {-| TcRnDataConParentTypeMismatch is an error indicating that a data - constructor was declared with a type that doesn't match its type - constructor (i.e. a GADT result type and its data name). - - Test cases: - T7175, T13300, T14719, T18357, T18357b, gadt11, tcfail155, tcfail176 - -} - TcRnDataConParentTypeMismatch :: !DataCon -- ^ The data constructor - -> !Type -- ^ The parent type - -> TcRnMessage - - {-| TcRnGADTsDisabled is an error indicating that a GADT was declared - while the extension GADTs was disabled. - - Test cases: - ghci057, T9293 - -} - TcRnGADTsDisabled :: !Name -- ^ The name of the GADT - -> TcRnMessage - - {-| TcRnExistentialQuantificationDisabled is an error indicating that - a data constructor was declared with existential features while the - extension ExistentialQuantification was disabled. - - Test cases: - ghci057, T9293, gadtSyntaxFail001, gadtSyntaxFail002, gadtSyntaxFail003, - prog006, rnfail053, T12083a - -} - TcRnExistentialQuantificationDisabled :: !DataCon -- ^ The constructor - -> TcRnMessage - - {-| TcRnGADTDataContext is an error indicating that a GADT was declared with a - data type context. - This error is emitted in the tc, but it is also caught in the renamer. - -} - TcRnGADTDataContext :: !Name -- ^ The data type name - -> TcRnMessage - - {-| TcRnMultipleConForNewtype is an error indicating that a newtype was - declared with multiple constructors. - This error is caught by the parser. - -} - TcRnMultipleConForNewtype :: !Name -- ^ The newtype name - -> !Int -- ^ The number of constructors - -> TcRnMessage - - {-| TcRnKindSignaturesDisabled is an error indicating that a kind signature - was used in a data type declaration while the extension KindSignatures was - disabled. - - Test cases: - T20873c, readFail036 - -} - TcRnKindSignaturesDisabled :: !(Either (HsType GhcPs) (Name, HsType GhcRn)) - -- ^ The data type name - -> TcRnMessage - - {-| TcRnEmptyDataDeclsDisabled is an error indicating that a data type - was declared with no constructors while the extension EmptyDataDecls was - disabled. - - Test cases: - readFail035 - -} - TcRnEmptyDataDeclsDisabled :: !Name -- ^ The data type name - -> TcRnMessage - - {-| TcRnRoleMismatch is an error indicating that the role specified - in an annotation differs from its inferred role. - - Test cases: - T7253, Roles11 - -} - TcRnRoleMismatch :: !Name -- ^ The type variable - -> !Role -- ^ The annotated role - -> !Role -- ^ The inferred role - -> TcRnMessage - - {-| TcRnRoleCountMismatch is an error indicating that the number of - roles in an annotation doesn't match the number of type parameters. - - Test cases: - Roles6 - -} - TcRnRoleCountMismatch :: !Int -- ^ The number of type variables - -> !(LRoleAnnotDecl GhcRn) -- ^ The role annotation - -> TcRnMessage - - {-| TcRnIllegalRoleAnnotation is an error indicating that a role - annotation was attached to a decl that doesn't allow it. - - Test cases: - Roles5 - -} - TcRnIllegalRoleAnnotation :: !(RoleAnnotDecl GhcRn) -- ^ The role annotation - -> TcRnMessage - - {-| TcRnRoleAnnotationsDisabled is an error indicating that a role - annotation was declared while the extension RoleAnnotations was disabled. - - Test cases: - Roles5, TH_Roles1 - -} - TcRnRoleAnnotationsDisabled :: !TyCon -- ^ The annotated type - -> TcRnMessage - - {-| TcRnIncoherentRoles is an error indicating that a role - annotation for a class parameter was declared as not nominal. - - Test cases: - T8773 - -} - TcRnIncoherentRoles :: !TyCon -- ^ The class tycon - -> TcRnMessage - {-| TcRnPrecedenceParsingError is an error caused by attempting to - use operators with the same precedence in one infix expression. - - Example: - eq :: (a ~ b ~ c) :~: () - - Test cases: module/mod61 - parser/should_fail/readFail016 - rename/should_fail/rnfail017 - rename/should_fail/T9077 - typecheck/should_fail/T18252a - -} - TcRnPrecedenceParsingError - :: (OpName, Fixity) -- ^ first operator's name and fixity - -> (OpName, Fixity) -- ^ second operator's name and fixity - -> TcRnMessage - - {-| TcRnPrecedenceParsingError is an error caused by attempting to - use an operator with higher precedence than the operand. - - Example: - k = (-3 **) - where - (**) = const - infixl 7 ** - - Test cases: overloadedrecflds/should_fail/T13132_duplicaterecflds - parser/should_fail/readFail023 - rename/should_fail/rnfail019 - th/TH_unresolvedInfix2 - -} - TcRnSectionPrecedenceError - :: (OpName, Fixity) -- ^ first operator's name and fixity - -> (OpName, Fixity) -- ^ argument operator - -> HsExpr GhcPs -- ^ Section - -> TcRnMessage - - {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type - synonyms has occurred. - - Test cases: - mod27, ghc-e-fail2, bkpfail29 - -} - TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle - -> TcRnMessage - - {-| TcRnSelfImport is an error indicating that a module contains an - import of itself. - - Test cases: - T9032 - -} - TcRnSelfImport :: !ModuleName -- ^ The module - -> TcRnMessage - - {-| TcRnNoExplicitImportList is a warning indicating that an import - statement did not include an explicit import list. - - Test cases: - T1789, T4489 - -} - TcRnNoExplicitImportList :: !ModuleName -- ^ The imported module - -> TcRnMessage - - {-| TcRnSafeImportsDisabled is an error indicating that an import was - declared using the @safe@ keyword while SafeHaskell wasn't active. - - Test cases: - Mixed01 - -} - TcRnSafeImportsDisabled :: !ModuleName -- ^ The imported module - -> TcRnMessage - - {-| TcRnDeprecatedModule is a warning indicating that an imported module - is annotated with a warning or deprecation pragma. - - Test cases: - DeprU - -} - TcRnDeprecatedModule :: !ModuleName -- ^ The imported module - -> !(WarningTxt GhcRn) -- ^ The pragma data - -> TcRnMessage - - {-| TcRnCompatUnqualifiedImport is a warning indicating that a special - module (right now only Data.List) was imported unqualified without - import list, for compatibility reasons. - - Test cases: - T17244A - -} - TcRnCompatUnqualifiedImport :: !(ImportDecl GhcPs) -- ^ The import - -> TcRnMessage - - {-| TcRnRedundantSourceImport is a warning indicating that a {-# SOURCE #-} - import was used when there is no import cycle. - - Test cases: - none - -} - TcRnRedundantSourceImport :: !ModuleName -- ^ The imported module - -> TcRnMessage - - {-| TcRnImportLookup is a group of errors about bad imported names. - -} - TcRnImportLookup :: !ImportLookupReason -- ^ Details about the error - -> TcRnMessage - - {-| TcRnUnusedImport is a group of errors about unused imports. - -} - TcRnUnusedImport :: !(ImportDecl GhcRn) -- ^ The import - -> !UnusedImportReason -- ^ Details about the error - -> TcRnMessage - - {-| TcRnDuplicateDecls is an error indicating that the same name was used for - multiple declarations. - - Test cases: - FieldSelectors, overloadedrecfldsfail03, T17965, NFSDuplicate, T9975a, - TDMultiple01, mod19, mod38, mod21, mod66, mod20, TDPunning, mod18, mod22, - TDMultiple02, T4127a, ghci048, T8932, rnfail015, rnfail010, rnfail011, - rnfail013, rnfail002, rnfail003, rn_dup, rnfail009, T7164, rnfail043, - TH_dupdecl, rnfail012 - -} - TcRnDuplicateDecls :: !OccName -- ^ The name of the declarations - -> !(NE.NonEmpty Name) -- ^ The individual declarations - -> TcRnMessage - - {-| TcRnPackageImportsDisabled is an error indicating that an import uses - a package qualifier while the extension PackageImports was disabled. - - Test cases: - PackageImportsDisabled - -} - TcRnPackageImportsDisabled :: TcRnMessage - - {-| TcRnIllegalDataCon is an error indicating that a data constructor was - defined using a lowercase name, or a symbolic name in prefix position. - Mostly caught by PsErrNotADataCon. - - Test cases: - None - -} - TcRnIllegalDataCon :: !RdrName -- ^ The constructor name - -> TcRnMessage - - {-| TcRnNestedForallsContexts is an error indicating that multiple foralls or - contexts are nested/curried where this is not supported, - like @∀ x. ∀ y.@ instead of @∀ x y.@. - - Test cases: - T12087, T14320, T16114, T16394, T16427, T18191, T18240a, T18240b, T18455, T5951 - -} - TcRnNestedForallsContexts :: !NestedForallsContextsIn -> TcRnMessage - - {-| TcRnRedundantRecordWildcard is a warning indicating that a pattern uses - a record wildcard even though all of the record's fields are bound explicitly. - - Test cases: - T15957_Fail - -} - TcRnRedundantRecordWildcard :: TcRnMessage - - {-| TcRnUnusedRecordWildcard is a warning indicating that a pattern uses - a record wildcard while none of the fields bound by it are used. - - Test cases: - T15957_Fail - -} - TcRnUnusedRecordWildcard :: ![Name] -- ^ The names bound by the wildcard - -> TcRnMessage - - {-| TcRnUnusedName is a warning indicating that a defined or imported name - is not used in the module. - - Test cases: - ds053, mc10, overloadedrecfldsfail05, overloadedrecfldsfail06, prog018, - read014, rn040, rn041, rn047, rn063, T13839, T13839a, T13919, T17171b, - T17a, T17b, T17d, T17e, T18470, T1972, t22391, t22391j, T2497, T3371, - T3449, T7145b, T7336, TH_recover_warns, unused_haddock, WarningGroups, - werror - -} - TcRnUnusedName :: !OccName -- ^ The unused name - -> !UnusedNameProv -- ^ The provenance of the name - -> TcRnMessage - - {-| TcRnQualifiedBinder is an error indicating that a qualified name - was used in binding position. - - Test cases: - mod62, rnfail021, rnfail034, rnfail039, rnfail046 - -} - TcRnQualifiedBinder :: !RdrName -- ^ The name used as a binder - -> TcRnMessage - - {-| TcRnTypeApplicationsDisabled is an error indicating that a type - application was used while the extension TypeApplications was disabled. - - Test cases: - T12411, T12446, T15527, T16133, T18251c - -} - TcRnTypeApplicationsDisabled :: !TypeApplication -- ^ what kind of type application is it? - -> TcRnMessage - - {-| TcRnInvalidRecordField is an error indicating that a record field was - used that doesn't exist in a constructor. - - Test cases: - T13644, T13847, T17469, T8448, T8570, tcfail083, tcfail084 - -} - TcRnInvalidRecordField :: !Name -- ^ The constructor name - -> !FieldLabelString -- ^ The name of the field - -> TcRnMessage - - {-| TcRnTupleTooLarge is an error indicating that the arity of a tuple - exceeds mAX_TUPLE_SIZE. - - Test cases: - T18723a, T18723b, T18723c, T6148a, T6148b, T6148c, T6148d - -} - TcRnTupleTooLarge :: !Int -- ^ The arity of the tuple - -> TcRnMessage - - {-| TcRnCTupleTooLarge is an error indicating that the arity of a constraint - tuple exceeds mAX_CTUPLE_SIZE. - - Test cases: - T10451 - -} - TcRnCTupleTooLarge :: !Int -- ^ The arity of the constraint tuple - -> TcRnMessage - - {-| TcRnIllegalInferredTyVars is an error indicating that some type variables - were quantified as inferred (like @∀ {a}.@) in a place where this is not - allowed, like in an instance declaration. - - Test cases: - ExplicitSpecificity5, ExplicitSpecificity6, ExplicitSpecificity8, - ExplicitSpecificity9 - -} - TcRnIllegalInferredTyVars :: !(NE.NonEmpty (HsTyVarBndr Specificity GhcPs)) - -- ^ The offending type variables - -> TcRnMessage - - {-| TcRnAmbiguousName is an error indicating that an unbound name - might refer to multiple names in scope. - - Test cases: - BootFldReexport, DRFUnused, duplicaterecfldsghci01, GHCiDRF, mod110, - mod151, mod152, mod153, mod164, mod165, NoFieldSelectorsFail, - overloadedrecfldsfail02, overloadedrecfldsfail04, overloadedrecfldsfail11, - overloadedrecfldsfail12, overloadedrecfldsfail13, - overloadedrecfldswasrunnowfail06, rnfail044, T11167_ambig, - T11167_ambiguous_fixity, T13132_duplicaterecflds, T15487, T16745, T17420, - T18999_NoDisambiguateRecordFields, T19397E1, T19397E2, T23010_fail, - tcfail037 - -} - TcRnAmbiguousName :: !GlobalRdrEnv - -> !RdrName -- ^ The name - -> !(NE.NonEmpty GlobalRdrElt) -- ^ The possible matches - -> TcRnMessage - - {-| TcRnBindingNameConflict is an error indicating that multiple local or - top-level bindings have the same name. - - Test cases: - dsrun006, mdofail002, mdofail003, mod23, mod24, qq006, rnfail001, - rnfail004, SimpleFail6, T14114, T16110_Fail1, tcfail038, TH_spliceD1 - -} - TcRnBindingNameConflict :: !RdrName -- ^ The conflicting name - -> !(NE.NonEmpty SrcSpan) - -- ^ The locations of the duplicates - -> TcRnMessage - - {-| TcRnNonCanonicalDefinition is a warning indicating that an instance - defines an implementation for a method that should not be defined in a way - that deviates from its default implementation, for example because it has - been scheduled to be absorbed into another method, like @pure@ making - @return@ obsolete. - - Test cases: - WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff - -} - TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics - -> !(LHsSigType GhcRn) -- ^ The instance type - -> TcRnMessage - {-| TcRnImplicitImportOfPrelude is a warning, controlled by @Wimplicit-prelude@, - that is triggered upon an implicit import of the @Prelude@ module. - - Example: - - {-# OPTIONS_GHC -fwarn-implicit-prelude #-} - module M where {} - - Test case: rn055 - - -} - TcRnImplicitImportOfPrelude :: TcRnMessage - - {-| TcRnMissingMain is an error that occurs when a Main module does - not define a main function (named @main@ by default, but overridable - with the @main-is@ command line flag). - - Example: - - module Main where {} - - Test cases: - T414, T7765, readFail021, rnfail007, T13839b, T17171a, T16453E1, tcfail030, - T19397E3, T19397E4 - - -} - TcRnMissingMain - :: !Bool -- ^ whether the module has an explicit export list - -> !Module - -> !OccName -- ^ the expected name of the main function - -> TcRnMessage - - {-| TcRnGhciUnliftedBind is an error that occurs when a user attempts to - bind an unlifted value in GHCi. - - Example (in GHCi): - - let a = (# 1#, 3# #) - - Test cases: T9140, T19035b - -} - TcRnGhciUnliftedBind :: !Id -> TcRnMessage - - {-| TcRnGhciMonadLookupFail is an error that occurs when the user sets - the GHCi monad, using the GHC API 'setGHCiMonad' function, but GHC - can't find which monad the user is referring to. - - Example: - - import GHC ( setGHCiMonad ) - - ... setGHCiMonad "NoSuchThing" - - Test cases: none - -} - TcRnGhciMonadLookupFail - :: String -- ^ the textual name of the monad requested by the user - -> Maybe [GlobalRdrElt] -- ^ lookup result - -> TcRnMessage - - {-| TcRnMissingRoleAnnotation is a warning that occurs when type declaration - doesn't have a role annotatiosn - - Controlled by flags: - - Wmissing-role-annotations - - Test cases: - T22702 - - -} - TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage - {-| TcRnPatersonCondFailure is an error that occurs when an instance - declaration fails to conform to the Paterson conditions. Which particular condition - fails depends on the constructor of PatersonCondFailure - See Note [Paterson conditions]. - - Test cases: - T15231, tcfail157, T15316, T19187a, fd-loop, tcfail108, tcfail154, - T15172, tcfail214 - -} - TcRnPatersonCondFailure - :: PatersonCondFailure -- ^ the failed Paterson Condition - -> PatersonCondFailureContext - -> Type -- ^ the LHS - -> Type -- ^ the RHS - -> TcRnMessage - - {-| TcRnImplicitRhsQuantification is a warning that occurs when GHC implicitly - quantifies over a type variable that occurs free on the RHS of the type declaration - that is not mentioned on the LHS - - Example: - - type T = 'Nothing :: Maybe a - - Controlled by flags: - - Wimplicit-rhs-quantification - - Test cases: - T23510a - T23510b - -} - TcRnImplicitRhsQuantification :: LocatedN RdrName -> TcRnMessage - - deriving Generic - - ----- - -data ZonkerMessage where - {-| ZonkerCannotDefaultConcrete is an error occurring when a concrete - type variable cannot be defaulted. - - Test cases: - T23153 - -} - ZonkerCannotDefaultConcrete - :: !FixedRuntimeRepOrigin - -> ZonkerMessage - - deriving Generic - ----- - --- | Things forbidden in @type data@ declarations. --- See Note [Type data declarations] -data TypeDataForbids - = TypeDataForbidsDatatypeContexts - | TypeDataForbidsLabelledFields - | TypeDataForbidsStrictnessAnnotations - | TypeDataForbidsDerivingClauses - deriving Generic - -instance Outputable TypeDataForbids where - ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" - ppr TypeDataForbidsLabelledFields = text "Labelled fields" - ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" - ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" - --- | Specifies which back ends can handle a requested foreign import or export -type ExpectedBackends = [Backend] - --- | Specifies which calling convention is unsupported on the current platform -data UnsupportedCallConvention - = StdCallConvUnsupported - | PrimCallConvUnsupported - | JavaScriptCallConvUnsupported - deriving Eq - --- | Whether the error pertains to a function argument or a result. -data ArgOrResult - = Arg | Result - --- | Which parts of a record field are affected by a particular error or warning. -data RecordFieldPart - = RecordFieldDecl !Name - | RecordFieldConstructor !Name - | RecordFieldPattern !Name - | RecordFieldUpdate - --- | Why did we reject a record update? -data BadRecordUpdateReason - -- | No constructor has all of the required fields. - = NoConstructorHasAllFields - { conflictingFields :: [FieldLabelString] } - - -- | There are several possible parents which have all of the required fields, - -- and we weren't able to disambiguate in any way. - | MultiplePossibleParents - (RecSelParent, RecSelParent, [RecSelParent]) - -- ^ The possible parents (at least 2) - - -- | We used type-directed disambiguation, but this resulted in - -- an invalid parent (the type-directed parent is not among the - -- parents we computed from the field labels alone). - | InvalidTyConParent TyCon (NE.NonEmpty RecSelParent) - - deriving Generic - --- | Where a shadowed name comes from -data ShadowedNameProvenance - = ShadowedNameProvenanceLocal !SrcLoc - -- ^ The shadowed name is local to the module - | ShadowedNameProvenanceGlobal [GlobalRdrElt] - -- ^ The shadowed name is global, typically imported from elsewhere. - --- | In what context did we require a type to have a fixed runtime representation? --- --- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing --- representation polymorphism errors when validity checking. --- --- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete -data FixedRuntimeRepProvenance - -- | Data constructor fields must have a fixed runtime representation. - -- - -- Tests: T11734, T18534. - = FixedRuntimeRepDataConField - - -- | Pattern synonym signature arguments must have a fixed runtime representation. - -- - -- Test: RepPolyPatSynArg. - | FixedRuntimeRepPatSynSigArg - - -- | Pattern synonym signature scrutinee must have a fixed runtime representation. - -- - -- Test: RepPolyPatSynRes. - | FixedRuntimeRepPatSynSigRes - -pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc -pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field" -pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument" -pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee" - --- | Why the particular illegal newtype error arose together with more --- information, if any. -data IllegalNewtypeReason - = DoesNotHaveSingleField !Int - | IsNonLinear - | IsGADT - | HasConstructorContext - | HasExistentialTyVar - | HasStrictnessAnnotation - deriving Generic - --- | Why the particular injectivity error arose together with more information, --- if any. -data InjectivityErrReason - = InjErrRhsBareTyVar [Type] - | InjErrRhsCannotBeATypeFam - | InjErrRhsOverlap - | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances - -data HasKinds - = YesHasKinds - | NoHasKinds - deriving (Show, Eq) - -hasKinds :: Bool -> HasKinds -hasKinds True = YesHasKinds -hasKinds False = NoHasKinds - -data SuggestUndecidableInstances - = YesSuggestUndecidableInstaces - | NoSuggestUndecidableInstaces - deriving (Show, Eq) - -suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances -suggestUndecidableInstances True = YesSuggestUndecidableInstaces -suggestUndecidableInstances False = NoSuggestUndecidableInstaces - -data SuggestUnliftedTypes - = SuggestUnliftedNewtypes - | SuggestUnliftedDatatypes - --- | A description of whether something is a --- --- * @data@ or @newtype@ ('DataDeclSort') --- --- * @data instance@ or @newtype instance@ ('DataInstanceSort') --- --- * @data family@ ('DataFamilySort') --- --- At present, this data type is only consumed by 'checkDataKindSig'. -data DataSort - = DataDeclSort NewOrData - | DataInstanceSort NewOrData - | DataFamilySort - -ppDataSort :: DataSort -> SDoc -ppDataSort data_sort = text $ - case data_sort of - DataDeclSort DataType -> "Data type" - DataDeclSort NewType -> "Newtype" - DataInstanceSort DataType -> "Data instance" - DataInstanceSort NewType -> "Newtype instance" - DataFamilySort -> "Data family" - --- | Helper type used in 'checkDataKindSig'. --- --- Superficially similar to 'ContextKind', but it lacks 'AnyKind' --- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@ --- provides 'LiftedKind', which is much simpler to match on and --- handle in 'isAllowedDataResKind'. -data AllowedDataResKind - = AnyTYPEKind - | AnyBoxedKind - | LiftedKind - --- | A data type to describe why a variable is not closed. --- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr -data NotClosedReason = NotLetBoundReason - | NotTypeClosed VarSet - | NotClosed Name NotClosedReason - -data SuggestPartialTypeSignatures - = YesSuggestPartialTypeSignatures - | NoSuggestPartialTypeSignatures - deriving (Show, Eq) - -suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures -suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures -suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures - -data UsingGeneralizedNewtypeDeriving - = YesGeneralizedNewtypeDeriving - | NoGeneralizedNewtypeDeriving - deriving Eq - -usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving -usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving -usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving - -data DeriveAnyClassEnabled - = YesDeriveAnyClassEnabled - | NoDeriveAnyClassEnabled - deriving Eq - -deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled -deriveAnyClassEnabled True = YesDeriveAnyClassEnabled -deriveAnyClassEnabled False = NoDeriveAnyClassEnabled - --- | Why a particular typeclass instance couldn't be derived. -data DeriveInstanceErrReason - = - -- | The typeclass instance is not well-kinded. - DerivErrNotWellKinded !TyCon - -- ^ The type constructor that occurs in - -- the typeclass instance declaration. - !Kind - -- ^ The typeclass kind. - !Int - -- ^ The number of typeclass arguments that GHC - -- kept. See Note [tc_args and tycon arity] in - -- GHC.Tc.Deriv. - -- | Generic instances can only be derived using the stock strategy - -- in Safe Haskell. - | DerivErrSafeHaskellGenericInst - | DerivErrDerivingViaWrongKind !Kind !Type !Kind - | DerivErrNoEtaReduce !Type - -- ^ The instance type - -- | We cannot derive instances in boot files - | DerivErrBootFileFound - | DerivErrDataConsNotAllInScope !TyCon - -- | We cannot use GND on non-newtype types - | DerivErrGNDUsedOnData - -- | We cannot derive instances of nullary classes - | DerivErrNullaryClasses - -- | Last arg must be newtype or data application - | DerivErrLastArgMustBeApp - | DerivErrNoFamilyInstance !TyCon [Type] - | DerivErrNotStockDeriveable !DeriveAnyClassEnabled - | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts - !AssociatedTyLastVarInKind - !AssociatedTyNotParamOverLastTyVar - | DerivErrNewtypeNonDeriveableClass - | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK? - | DerivErrOnlyAnyClassDeriveable !TyCon - -- ^ Type constructor for which the instance - -- is requested - !DeriveAnyClassEnabled - -- ^ Whether or not -XDeriveAnyClass is enabled - -- already. - -- | Stock deriving won't work, but perhaps DeriveAnyClass will. - | DerivErrNotDeriveable !DeriveAnyClassEnabled - -- | The given 'PredType' is not a class. - | DerivErrNotAClass !PredType - -- | The given (representation of the) 'TyCon' has no - -- data constructors. - | DerivErrNoConstructors !TyCon - | DerivErrLangExtRequired !LangExt.Extension - -- | GHC simply doesn't how to how derive the input 'Class' for the given - -- 'Type'. - | DerivErrDunnoHowToDeriveForType !Type - -- | The given 'TyCon' must be an enumeration. - -- See Note [Enumeration types] in GHC.Core.TyCon - | DerivErrMustBeEnumType !TyCon - -- | The given 'TyCon' must have /precisely/ one constructor. - | DerivErrMustHaveExactlyOneConstructor !TyCon - -- | The given data type must have some parameters. - | DerivErrMustHaveSomeParameters !TyCon - -- | The given data type must not have a class context. - | DerivErrMustNotHaveClassContext !TyCon !ThetaType - -- | We couldn't derive an instance for a particular data constructor - -- for a variety of reasons. - | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor] - -- | We couldn't derive a 'Generic' instance for the given type for a - -- variety of reasons - | DerivErrGenerics [DeriveGenericsErrReason] - -- | We couldn't derive an instance either because the type was not an - -- enum type or because it did have more than one constructor. - | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason - deriving Generic - -data DeriveInstanceBadConstructor - = - -- | The given 'DataCon' must be truly polymorphic in the - -- last argument of the data type. - DerivErrBadConExistential !DataCon - -- | The given 'DataCon' must not use the type variable in a function argument" - | DerivErrBadConCovariant !DataCon - -- | The given 'DataCon' must not contain function types - | DerivErrBadConFunTypes !DataCon - -- | The given 'DataCon' must use the type variable only - -- as the last argument of a data type - | DerivErrBadConWrongArg !DataCon - -- | The given 'DataCon' is a GADT so we cannot directly - -- derive an istance for it. - | DerivErrBadConIsGADT !DataCon - -- | The given 'DataCon' has existentials type vars in its type. - | DerivErrBadConHasExistentials !DataCon - -- | The given 'DataCon' has constraints in its type. - | DerivErrBadConHasConstraints !DataCon - -- | The given 'DataCon' has a higher-rank type. - | DerivErrBadConHasHigherRankType !DataCon - -data DeriveGenericsErrReason - = -- | The type must not have some datatype context. - DerivErrGenericsMustNotHaveDatatypeContext !TyCon - -- | The data constructor must not have exotic unlifted - -- or polymorphic arguments. - | DerivErrGenericsMustNotHaveExoticArgs !DataCon - -- | The data constructor must be a vanilla constructor. - | DerivErrGenericsMustBeVanillaDataCon !DataCon - -- | The type must have some type parameters. - -- check (d) from Note [Requirements for deriving Generic and Rep] - -- in GHC.Tc.Deriv.Generics. - | DerivErrGenericsMustHaveSomeTypeParams !TyCon - -- | The data constructor must not have existential arguments. - | DerivErrGenericsMustNotHaveExistentials !DataCon - -- | The derivation applies a type to an argument involving - -- the last parameter but the applied type is not of kind * -> *. - | DerivErrGenericsWrongArgKind !DataCon - -data HasWildcard - = YesHasWildcard - | NoHasWildcard - deriving Eq - -hasWildcard :: Bool -> HasWildcard -hasWildcard True = YesHasWildcard -hasWildcard False = NoHasWildcard - --- | A context in which we don't allow anonymous wildcards. -data BadAnonWildcardContext - = WildcardNotLastInConstraint - | ExtraConstraintWildcardNotAllowed - SoleExtraConstraintWildcardAllowed - | WildcardsNotAllowedAtAll - --- | Whether a sole extra-constraint wildcard is allowed, --- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@. -data SoleExtraConstraintWildcardAllowed - = SoleExtraConstraintWildcardNotAllowed - | SoleExtraConstraintWildcardAllowed - --- | Why is a class instance head invalid? -data IllegalInstanceHeadReason - -- | An instance for an abstract class from an hs-boot or Backpack - -- hsig file. - -- - -- Example: - -- - -- -- A.hs-boot - -- module A where - -- class C a - -- - -- -- B.hs - -- module B where - -- import {-# SOURCE #-} A - -- instance C Int where - -- - -- -- A.hs - -- module A where - -- import B - -- class C a where - -- f :: a - -- - -- Test cases: typecheck/should_fail/T13068 - = InstHeadAbstractClass !Class - -- | An instance whose head is not a class. - -- - -- Examples(s): - -- - -- instance c - -- - -- instance 42 - -- - -- instance !Show D - -- - -- type C1 a = (Show (a -> Bool)) - -- instance C1 Int where - -- - -- Test cases: typecheck/rename/T5513 - -- typecheck/rename/T16385 - -- parser/should_fail/T3811c - -- rename/should_fail/T18240a - -- polykinds/T13267 - -- deriving/should_fail/T23522 - | InstHeadNonClass - !(Maybe TyCon) -- ^ the 'TyCon' at the head of the instance head, - -- or 'Nothing' if the instance head is not even headed - -- by a 'TyCon' - - -- | Instance head was headed by a type synonym. - -- - -- Example: - -- type MyInt = Int - -- class C a where {..} - -- instance C MyInt where {..} - -- - -- Test cases: drvfail015, mod42, TidyClassKinds, tcfail139 - | InstHeadTySynArgs - -- | Instance head was not of the form @T a1 ... an@, - -- where @a1, ..., an@ are all type variables or literals. - -- - -- Example: - -- - -- instance Num [Int] where {..} - -- - -- Test cases: mod41, mod42, tcfail044, tcfail047. - | InstHeadNonTyVarArgs - -- | Multi-param instance without -XMultiParamTypeClasses. - -- - -- Example: - -- - -- instance C a b where {..} - -- - -- Test case: IllegalMultiParamInstance - | InstHeadMultiParam - deriving Generic - - --- | Why is a (type or data) family instance invalid? -data IllegalFamilyInstanceReason - {-| A top-level family instance for a 'TyCon' that isn't a family 'TyCon'. - - Example: - - data D a = MkD - type instance D Int = Bool - - Test case: indexed-types/should_fail/T3092 - -} - = NotAFamilyTyCon - !TypeOrData -- ^ was this a 'type' or a 'data' instance? - !TyCon - {-| A top-level (open) type family instance for a closed type family. - - Test cases: - indexed-types/should_fail/Overlap7 - indexed-types/should_fail/Overlap3 - -} - | NotAnOpenFamilyTyCon !TyCon - - {-| A family instance was declared for a family of a different kind, - e.g. a data instance for a type family 'TyCon'. - - Test cases: - T9896, SimpleFail3a - -} - | FamilyCategoryMismatch !TyCon -- ^ The family tycon - - - {-| A family instance was declared with a different number of arguments - than expected. - See Note [Oversaturated type family equations] in "GHC.Tc.Validity". - - Test cases: - TyFamArity1, TyFamArity2, T11136, Overlap4, AssocTyDef05, AssocTyDef06, - T14110 - -} - | FamilyArityMismatch !TyCon -- ^ The family tycon - !Arity -- ^ The right number of parameters - - {-| A closed type family equation used a different name than the parent family. - - Example: - - type family F a where - G Int = Bool - - Test cases: - Overlap5, T15362, T16002, T20260, T11623 - -} - | TyFamNameMismatch !Name -- ^ The family name - !Name -- ^ The name used in the equation - - - -- | There are out-of-scope type variables in the right-hand side - -- of an associated type or data family instance. - -- - -- Example: - -- - -- instance forall a. C Int where - -- data instance D Int = MkD1 a - -- - -- Test cases: indexed-types/should_fail/T5515, polykinds/T9574, rename/should_fail/T18021 - | FamInstRHSOutOfScopeTyVars - !(Maybe (TyCon, [Type], TyVarSet)) - -- ^ family 'TyCon', arguments, and set of "dodgy" type variables - -- See Note [Dodgy binding sites in type family instances] - -- in GHC.Tc.Validity - !(NE.NonEmpty Name) -- ^ the out-of-scope type variables - - | FamInstLHSUnusedBoundTyVars - !(NE.NonEmpty InvalidFamInstQTv) -- ^ the unused bound type variables - - | InvalidAssoc !InvalidAssoc - deriving Generic - --- | A quantified type variable in a type or data family equation that --- is either not bound in any LHS patterns or not used in the RHS (or both). -data InvalidFamInstQTv - = InvalidFamInstQTv - { ifiqtv :: TcTyVar - , ifiqtv_user_written :: Bool - -- ^ Did the user write this type variable, or was introduced by GHC? - -- For example: with @-XPolyKinds@, in @type instance forall a. F = ()@, - -- we have a user-written @a@ but GHC introduces a kind variable @k@ - -- as well. See #23734. - , ifiqtv_reason :: InvalidFamInstQTvReason - -- ^ For what reason was the quantified type variable invalid? - } - -data InvalidFamInstQTvReason - -- | A dodgy binder, i.e. a variable that syntactically appears in - -- LHS patterns but only in non-injective positions. - -- - -- See Note [Dodgy binding sites in type family instances] - -- in GHC.Tc.Validity. - = InvalidFamInstQTvDodgy - -- | A quantified type variable in a type or data family equation - -- that is not bound in any LHS patterns. - | InvalidFamInstQTvNotBoundInPats - -- | A quantified type variable in a type or data family equation - -- that is not used on the RHS. - | InvalidFamInstQTvNotUsedInRHS - --- The 'check_tvs' function in 'GHC.Tc.Validity.checkFamPatBinders' --- uses 'getSrcSpan', so this 'NamedThing' instance is convenient. -instance NamedThing InvalidFamInstQTv where - getName = getName . ifiqtv - -data InvalidAssoc - -- | An invalid associated family instance. - -- - -- See t'InvalidAssocInstance'.Builder - = InvalidAssocInstance !InvalidAssocInstance - -- | An invalid associated family default declaration. - -- - -- See t'InvalidAssocDefault'. - | InvalidAssocDefault !InvalidAssocDefault - deriving Generic - --- | The reason that an associated family instance was invalid. -data InvalidAssocInstance - -- | A class instance is missing its expected associated type/data instance. - -- - -- Test cases: deriving/should_compile/T14094 - -- indexed-types/should_compile/Simple2 - -- typecheck/should_compile/tc254 - = AssocInstanceMissing !Name - - -- | A top-level instance for an associated family 'TyCon'. - -- - -- Example: - -- - -- class C a where { type T a } - -- instance T Int = Bool - -- - -- Test case: indexed-types/should_fail/SimpleFail7 - | AssocInstanceNotInAClass !TyCon - - -- | An associated type instance is provided for a class that doesn't have - -- that associated type. - -- - -- Examples(s): - -- $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo) - -- [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)] - -- return [d]) - -- ======> - -- instance Eq Foo where - -- type Rep Foo = Maybe - -- - -- Test cases: th/T12387a - | AssocNotInThisClass !Class !TyCon - -- | An associated family instance does not mention any of the parent 'Class' - -- 'TyVar's. - -- - -- Test cases: T2888, T9167, T12867 - | AssocNoClassTyVar !Class !TyCon - - | AssocTyVarsDontMatch - !ForAllTyFlag - !TyCon -- ^ family 'TyCon' - ![Type] -- ^ expected type arguments - ![Type] -- ^ actual type arguments - deriving Generic - - --- | The reason that an associated family default declaration was invalid. -data InvalidAssocDefault - -- | An associated family default declaration for something that isn't - -- an associated family. - = AssocDefaultNotAssoc !Name -- ^ 'Class' 'Name' - !Name -- ^ 'TyCon' 'Name' - -- | Multiple default declarations were given for an associated - -- family instance. - -- - -- Test cases: none. - | AssocMultipleDefaults !Name - -- | Invalid arguments in an associated family instance. - -- - -- See t'AssocDefaultBadArgs'. - | AssocDefaultBadArgs !TyCon ![Type] AssocDefaultBadArgs - deriving Generic - --- | Invalid arguments in an associated family instance declaration. -data AssocDefaultBadArgs - -- | An argument which isn't a type variable in an associated - -- family instance default declaration. - = AssocDefaultNonTyVarArg !(Type, ForAllTyFlag) - -- | Duplicate occurrence of a type variable in an associated - -- family instance default declaration. - | AssocDefaultDuplicateTyVars !(NE.NonEmpty (TyCoVar, ForAllTyFlag)) - deriving Generic - --- | A type representing whether or not the input type has associated data family instances. -data HasAssociatedDataFamInsts - = YesHasAdfs - | NoHasAdfs - deriving Eq - -hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts -hasAssociatedDataFamInsts True = YesHasAdfs -hasAssociatedDataFamInsts False = NoHasAdfs - --- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass --- contains the last type variable of the class in a kind, which is not (yet) allowed --- by GHC. -data AssociatedTyLastVarInKind - = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class - | NoAssocTyLastVarInKind - deriving Eq - -associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind -associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc -associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind - --- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a --- typeclass is not parameterized over the last type variable of the class -data AssociatedTyNotParamOverLastTyVar - = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class - | NoAssociatedTyNotParamOverLastTyVar - deriving Eq - -associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar -associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc -associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar - --- | What kind of thing is missing a type signature? --- --- Used for reporting @"missing signature"@ warnings, see --- 'tcRnMissingSignature'. -data MissingSignature - = MissingTopLevelBindingSig Name Type - | MissingPatSynSig PatSyn - | MissingTyConKindSig - TyCon - Bool -- ^ whether -XCUSKs is enabled - --- | Is the object we are dealing with exported or not? --- --- Used for reporting @"missing signature"@ warnings, see --- 'TcRnMissingSignature'. -data Exported - = IsNotExported - | IsExported - deriving Eq - -instance Outputable Exported where - ppr IsNotExported = text "IsNotExported" - ppr IsExported = text "IsExported" - --- | What declarations were not allowed in an hs-boot or hsig file? -data BadBootDecls - = BootBindsPs !(NE.NonEmpty (LHsBindLR GhcRn GhcPs)) - | BootBindsRn !(NE.NonEmpty (LHsBindLR GhcRn GhcRn)) - | BootInstanceSigs !(NE.NonEmpty (LSig GhcRn)) - | BootFamInst !TyCon - | BootSpliceDecls !(NE.NonEmpty (LocatedA (HsUntypedSplice GhcPs))) - | BootForeignDecls !(NE.NonEmpty (LForeignDecl GhcRn)) - | BootDefaultDecls !(NE.NonEmpty (LDefaultDecl GhcRn)) - | BootRuleDecls !(NE.NonEmpty (LRuleDecls GhcRn)) - --- | A mismatch between an hs-boot or signature file and its implementing module. -data BootMismatch - -- | Something defined or exported by an hs-boot or signature file - -- is missing from the implementing module. - = MissingBootThing !Name !MissingBootThing - - -- | A typeclass instance is declared in the hs-boot file but - -- it is not present in the implementing module. - | MissingBootInstance !DFunId -- ^ the boot instance 'DFunId' - -- NB: we never trigger this for hsig files, as in that case we do - -- a full round of constraint solving, and a missing instance gets reported - -- as an unsolved Wanted constraint with a 'InstProvidedOrigin' 'CtOrigin'. - -- See GHC.Tc.Utils.Backpack.check_inst. - - -- | A mismatch between an hsig file and its implementing module - -- in the 'Name' that a particular re-export refers to. - | BadReexportedBootThing !Name !Name - - -- | A mismatch between the declaration of something in the hs-boot or - -- signature file and its implementation, e.g. a type mismatch or - -- a type family implemented as a class. - | BootMismatch - !TyThing -- ^ boot thing - !TyThing -- ^ real thing - !BootMismatchWhat - deriving Generic - --- | Something from the hs-boot or signature file is missing from the --- implementing module. -data MissingBootThing - -- | Something defined in the hs-boot or signature file is not defined in the - -- implementing module. - = MissingBootDefinition - -- | Something exported by the hs-boot or signature file is not exported by the - -- implementing module. - | MissingBootExport - deriving Generic - -missingBootThing :: HsBootOrSig -> Name -> MissingBootThing -> TcRnMessage -missingBootThing src nm thing = - TcRnBootMismatch src (MissingBootThing nm thing) - --- | A mismatch of two 'TyThing's between an hs-boot or signature file --- and its implementing module. -data BootMismatchWhat - -- | The 'Id's have different types. - = BootMismatchedIdTypes !Id -- ^ boot 'Id' - !Id -- ^ real 'Id' - -- | Two 'TyCon's aren't compatible. - | BootMismatchedTyCons !TyCon -- ^ boot 'TyCon' - !TyCon -- ^ real 'TyCon' - !(NE.NonEmpty BootTyConMismatch) - deriving Generic - --- | An error in the implementation of an abstract datatype using --- a type synonym. -data SynAbstractDataError - -- | The type synony was not nullary. - = SynAbsDataTySynNotNullary - -- | The type synonym RHS contained invalid types, e.g. - -- a type family or a forall. - | SynAbstractDataInvalidRHS !(NE.NonEmpty Type) - --- | Mismatched implementation of a 'TyCon' in an hs-boot or signature file. -data BootTyConMismatch - -- | The 'TyCon' kinds differ. - = TyConKindMismatch - -- | The 'TyCon' 'Role's aren't compatible. - | TyConRoleMismatch !Bool -- ^ True <=> role subtype check - -- | Two type synonyms have different RHSs. - | TyConSynonymMismatch !Kind !Kind - -- | The two 'TyCon's are of a different flavour, e.g. one is - -- a data family and the other is a type family. - | TyConFlavourMismatch !FamTyConFlav !FamTyConFlav - -- | The equations of a type family don't match. - | TyConAxiomMismatch !(BootListMismatches CoAxBranch BootAxiomBranchMismatch) - -- | The type family injectivity annotations don't match. - | TyConInjectivityMismatch - -- | The 'TyCon's are both datatype 'TyCon's, but they have diferent 'DataCon's. - | TyConMismatchedData !AlgTyConRhs !AlgTyConRhs !BootDataMismatch - -- | The 'TyCon's are both 'Class' 'TyCon's, but the classes don't match. - | TyConMismatchedClasses !Class !Class !BootClassMismatch - -- | The 'TyCon's are something completely different. - | TyConsVeryDifferent - -- | An abstract 'TyCon' is implemented using a type synonym in an invalid - -- manner. See 'SynAbstractDataError'. - | SynAbstractData !SynAbstractDataError - - --- | Utility datatype to record errors when checking compatibity --- between two lists of things, e.g. class methods, associated types, --- type family equations, etc. -data BootListMismatch item err - -- | Different number of items. - = MismatchedLength - -- | The item at the given position in the list differs. - | MismatchedThing !Int !item !item !err - -type BootListMismatches item err = - NE.NonEmpty (BootListMismatch item err) - -data BootAxiomBranchMismatch - -- | The quantified variables in an equation don't match. - -- - -- Example: the quantification of @a@ in - -- - -- @type family F a where { forall a. F a = Maybe a }@ - = MismatchedAxiomBinders - -- | The LHSs of an equation don't match. - | MismatchedAxiomLHS - -- | The RHSs of an equation don't match. - | MismatchedAxiomRHS - --- | A mismatch in a class, between its declaration in an hs-boot or signature --- file, and its implementation in a source Haskell file. -data BootClassMismatch - -- | The class methods don't match. - = MismatchedMethods !(BootListMismatches ClassOpItem BootMethodMismatch) - -- | The associated types don't match. - | MismatchedATs !(BootListMismatches ClassATItem BootATMismatch) - -- | The functional dependencies don't match. - | MismatchedFunDeps - -- | The superclasses don't match. - | MismatchedSuperclasses - -- | The @MINIMAL@ pragmas are not compatible. - | MismatchedMinimalPragmas - --- | A mismatch in a class method, between its declaration in an hs-boot or signature --- file, and its implementation in a source Haskell file. -data BootMethodMismatch - -- | The class method names are different. - = MismatchedMethodNames - -- | The types of a class method are different. - | MismatchedMethodTypes !Type !Type - -- | The default method types are not compatible. - | MismatchedDefaultMethods !Bool -- ^ True <=> subtype check - --- | A mismatch in an associated type of a class, between its declaration --- in an hs-boot or signature file, and its implementation in a source Haskell file. -data BootATMismatch - -- | Two associated types don't match. - = MismatchedTyConAT !BootTyConMismatch - -- | Two associated type defaults don't match. - | MismatchedATDefaultType - --- | A mismatch in a datatype declaration, between an hs-boot file or signature --- file and its implementing module. -data BootDataMismatch - -- | A datatype is implemented as a newtype or vice-versa. - = MismatchedNewtypeVsData - -- | The constructors don't match. - | MismatchedConstructors !(BootListMismatches DataCon BootDataConMismatch) - -- | The datatype contexts differ. - | MismatchedDatatypeContexts - --- | A mismatch in a data constrcutor, between its declaration in an hs-boot --- file or signature file, and its implementation in a source Haskell module. -data BootDataConMismatch - -- | The 'Name's of the 'DataCon's differ. - = MismatchedDataConNames - -- | The fixities of the 'DataCon's differ. - | MismatchedDataConFixities - -- | The strictness annotations of the 'DataCon's differ. - | MismatchedDataConBangs - -- | The 'DataCon's have different field labels. - | MismatchedDataConFieldLabels - -- | The 'DataCon's have incompatible types. - | MismatchedDataConTypes - --------------------------------------------------------------------------------- --- --- Errors used in GHC.Tc.Errors --- --------------------------------------------------------------------------------- - -{- Note [Error report] -~~~~~~~~~~~~~~~~~~~~~~ -The idea is that error msgs are divided into three parts: the main msg, the -context block ("In the second argument of ..."), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. --} - --- | A collection of main error messages and supplementary information. --- --- In practice, we will: --- - display the important messages first, --- - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'), --- - then the supplementary information (e.g. relevant bindings, valid hole fits), --- - then the hints ("Possible fix: ..."). --- --- So this is mostly just a way of making sure that the error context appears --- early on rather than at the end of the message. --- --- See Note [Error report] for details. -data SolverReport - = SolverReport - { sr_important_msg :: SolverReportWithCtxt - , sr_supplementary :: [SolverReportSupplementary] - , sr_hints :: [GhcHint] - } - --- | Additional information to print in a 'SolverReport', after the --- important messages and after the error context. --- --- See Note [Error report]. -data SolverReportSupplementary - = SupplementaryBindings RelevantBindings - | SupplementaryHoleFits ValidHoleFits - | SupplementaryCts [(PredType, RealSrcSpan)] - --- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) --- that are needed in order to report it. -data SolverReportWithCtxt = - SolverReportWithCtxt - { reportContext :: SolverReportErrCtxt - -- ^ Context for what we wish to report. - -- This can change as we enter implications, so is - -- stored alongside the content. - , reportContent :: TcSolverReportMsg - -- ^ The content of the message to report. - } - deriving Generic - --- | Context needed when reporting a 'TcSolverReportMsg', such as --- the enclosing implication constraints or whether we are deferring type errors. -data SolverReportErrCtxt - = CEC { cec_encl :: [Implication] -- ^ Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- ^ We make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime - - -- We might throw a warning on an error when encountering a hole, - -- depending on the type of hole (expression hole, type hole, out of scope hole). - -- We store the reasons for reporting a diagnostic for each type of hole. - , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions. - , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types. - , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes. - - , cec_warn_redundant :: Bool -- ^ True <=> -Wredundant-constraints - , cec_expand_syns :: Bool -- ^ True <=> -fprint-expanded-synonyms - - , cec_suppress :: Bool -- ^ True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -getUserGivens :: SolverReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - ----------------------------------------------------------------------------- --- --- ErrorItem --- ----------------------------------------------------------------------------- - --- | A predicate with its arising location; used to encapsulate a constraint --- that will give rise to a diagnostic. -data ErrorItem --- We could perhaps use Ct here (and indeed used to do exactly that), but --- having a separate type gives to denote errors-in-formation gives us --- a nice place to do pre-processing, such as calculating ei_suppress. --- Perhaps some day, an ErrorItem could eventually evolve to contain --- the error text (or some representation of it), so we can then have all --- the errors together when deciding which to report. - = EI { ei_pred :: PredType -- report about this - -- The ei_pred field will never be an unboxed equality with - -- a (casted) tyvar on the right; this is guaranteed by the solver - , ei_evdest :: Maybe TcEvDest - -- ^ for Wanteds, where to put the evidence - -- for Givens, Nothing - , ei_flavour :: CtFlavour - , ei_loc :: CtLoc - , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a - -- CtIrred, this stores the reason - , ei_suppress :: Bool -- Suppress because of Note [Wanteds rewrite Wanteds] - -- in GHC.Tc.Constraint - } - -instance Outputable ErrorItem where - ppr (EI { ei_pred = pred - , ei_evdest = m_evdest - , ei_flavour = flav - , ei_suppress = supp }) - = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred - where - pp_dest Nothing = empty - pp_dest (Just ev) = ppr ev <+> dcolon - - pp_supp = if supp then text "suppress:" else empty - -errorItemOrigin :: ErrorItem -> CtOrigin -errorItemOrigin = ctLocOrigin . ei_loc - -errorItemEqRel :: ErrorItem -> EqRel -errorItemEqRel = predTypeEqRel . ei_pred - -errorItemCtLoc :: ErrorItem -> CtLoc -errorItemCtLoc = ei_loc - -errorItemPred :: ErrorItem -> PredType -errorItemPred = ei_pred - -{- Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... --} - - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - - --- | An error reported after constraint solving. --- This is usually, some sort of unsolved constraint error, --- but we try to be specific about the precise problem we encountered. -data TcSolverReportMsg - -- | Quantified variables appear out of dependency order. - -- - -- Example: - -- - -- forall (a :: k) k. ... - -- - -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. - = BadTelescope TyVarBndrs [TyCoVar] - - -- | We came across a custom type error and we have decided to report it. - -- - -- Example: - -- - -- type family F a where - -- F a = TypeError (Text "error") - -- - -- err :: F () - -- err = () - -- - -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104. - | UserTypeError ErrorMsgType -- ^ the message to report - - -- | Report a Wanted constraint of the form "Unsatisfiable msg". - | UnsatisfiableError ErrorMsgType -- ^ the message to report - - -- | We want to report an out of scope variable or a typed hole. - -- See 'HoleError'. - | ReportHoleError Hole HoleError - - -- | Cannot unify a variable, because of a type mismatch. - | CannotUnifyVariable - { mismatchMsg :: MismatchMsg - , cannotUnifyReason :: CannotUnifyVariableReason } - - -- | A mismatch between two types. - | Mismatch - { mismatchMsg :: MismatchMsg - , mismatchTyVarInfo :: Maybe TyVarInfo - , mismatchAmbiguityInfo :: [AmbiguityInfo] - , mismatchCoercibleInfo :: Maybe CoercibleMsg } - - -- | A violation of the representation-polymorphism invariants. - -- - -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. - | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] - - -- | An equality between two types is blocked on a kind equality - -- between their kinds. - -- - -- Test cases: none. - | BlockedEquality ErrorItem - -- These are for the "blocked" equalities, as described in - -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality, - -- wrinkle (EIK2). There should always be another unsolved wanted around, - -- which will ordinarily suppress this message. But this can still be printed out - -- with -fdefer-type-errors (sigh), so we must produce a message. - - -- | Something was not applied to sufficiently many arguments. - -- - -- Example: - -- - -- instance Eq Maybe where {..} - -- - -- Test case: T11563. - | ExpectingMoreArguments Int TypedThing - - -- | Trying to use an unbound implicit parameter. - -- - -- Example: - -- - -- foo :: Int - -- foo = ?param - -- - -- Test case: tcfail130. - | UnboundImplicitParams - (NE.NonEmpty ErrorItem) - - -- | A constraint couldn't be solved because it contains - -- ambiguous type variables. - -- - -- Example: - -- - -- class C a b where - -- f :: (a,b) - -- - -- x = fst f - -- - -- - -- Test case: T4921. - | AmbiguityPreventsSolvingCt - ErrorItem -- ^ always a class constraint - ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively - - -- | Could not solve a constraint; there were several unifying candidate instances - -- but no matching instances. This is used to report as much useful information - -- as possible about why we couldn't choose any instance, e.g. because of - -- ambiguous type variables. - | CannotResolveInstance - { cannotResolve_item :: ErrorItem - , cannotResolve_unifiers :: [ClsInst] - , cannotResolve_candidates :: [ClsInst] - , cannotResolve_importErrors :: [ImportError] - , cannotResolve_suggestions :: [GhcHint] - , cannotResolve_relevant_bindings :: RelevantBindings } - -- TODO: remove the fields of type [GhcHint] and RelevantBindings, - -- in order to handle them uniformly with other diagnostic messages. - - -- | Could not solve a constraint using available instances - -- because the instances overlap. - -- - -- Test cases: tcfail118, tcfail121, tcfail218. - | OverlappingInstances - { overlappingInstances_item :: ErrorItem - , overlappingInstances_matches :: NE.NonEmpty ClsInst - , overlappingInstances_unifiers :: [ClsInst] } - - -- | Could not solve a constraint from instances because - -- instances declared in a Safe module cannot overlap instances - -- from other modules (with -XSafeHaskell). - -- - -- Test cases: SH_Overlap{1,2,5,6,7,11}. - | UnsafeOverlap - { unsafeOverlap_item :: ErrorItem - , unsafeOverlap_match :: ClsInst - , unsafeOverlapped :: NE.NonEmpty ClsInst } - - deriving Generic - -data MismatchMsg - = -- | Couldn't unify two types or kinds. - -- - -- Example: - -- - -- 3 + 3# -- can't match a lifted type with an unlifted type - -- - -- Test cases: T1396, T8263, ... - BasicMismatch - { mismatch_ea :: MismatchEA -- ^ Should this be phrased in terms of expected vs actual? - , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. - , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) - , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) - , mismatch_whenMatching :: Maybe WhenMatching - , mismatch_mb_same_occ :: Maybe SameOccInfo - } - - -- | A type has an unexpected kind. - -- - -- Test cases: T2994, T7609, ... - | KindMismatch - { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? - , kmismatch_expected :: Type - , kmismatch_actual :: Type - } - -- TODO: combine with 'BasicMismatch'. - - -- | A mismatch between two types, which arose from a type equality. - -- - -- Test cases: T1470, tcfail212. - | TypeEqMismatch - { teq_mismatch_ppr_explicit_kinds :: Bool - , teq_mismatch_item :: ErrorItem - , teq_mismatch_ty1 :: Type - , teq_mismatch_ty2 :: Type - , teq_mismatch_expected :: Type -- ^ The overall expected type - , teq_mismatch_actual :: Type -- ^ The overall actual type - , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? - , teq_mb_same_occ :: Maybe SameOccInfo - } - -- TODO: combine with 'BasicMismatch'. - - -- | Couldn't solve some Wanted constraints using the Givens. - -- Used for messages such as @"No instance for ..."@ and - -- @"Could not deduce ... from"@. - | CouldNotDeduce - { cnd_user_givens :: [Implication] - -- | The Wanted constraints we couldn't solve. - -- - -- N.B.: the 'ErrorItem' at the head of the list has been tidied, - -- perhaps not the others. - , cnd_wanted :: NE.NonEmpty ErrorItem - - -- | Some additional info consumed by 'mk_supplementary_ea_msg'. - , cnd_extra :: Maybe CND_Extra - } - deriving Generic - --- | Construct a basic mismatch message between two types. --- --- See 'pprMismatchMsg' for how such a message is displayed to users. -mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg -mkBasicMismatchMsg ea item ty1 ty2 - = BasicMismatch - { mismatch_ea = ea - , mismatch_item = item - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 - , mismatch_whenMatching = Nothing - , mismatch_mb_same_occ = Nothing - } - --- | Whether to use expected/actual in a type mismatch message. -data MismatchEA - -- | Don't use expected/actual. - = NoEA - -- | Use expected/actual. - | EA - { mismatch_mbEA :: Maybe ExpectedActualInfo - -- ^ Whether to also mention type synonym expansion. - } - -data CannotUnifyVariableReason - = -- | A type equality between a type variable and a polytype. - -- - -- Test cases: T12427a, T2846b, T10194, ... - CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo) - - -- | An occurs check. - | OccursCheck - { occursCheckInterestingTyVars :: [TyVar] - , occursCheckAmbiguityInfos :: [AmbiguityInfo] } - - -- | A skolem type variable escapes its scope. - -- - -- Example: - -- - -- data Ex where { MkEx :: a -> MkEx } - -- foo (MkEx x) = x - -- - -- Test cases: TypeSkolEscape, T11142. - | SkolemEscape ErrorItem Implication [TyVar] - - -- | Can't unify the type variable with the other type - -- due to the kind of type variable it is. - -- - -- For example, trying to unify a 'SkolemTv' with the - -- type Int, or with a 'TyVarTv'. - | DifferentTyVars TyVarInfo - | RepresentationalEq TyVarInfo (Maybe CoercibleMsg) - deriving Generic - --- | Report a mismatch error without any extra --- information. -mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg -mkPlainMismatchMsg msg - = Mismatch - { mismatchMsg = msg - , mismatchTyVarInfo = Nothing - , mismatchAmbiguityInfo = [] - , mismatchCoercibleInfo = Nothing } - --- | Additional information to be given in a 'CouldNotDeduce' message, --- which is then passed on to 'mk_supplementary_ea_msg'. -data CND_Extra = CND_Extra TypeOrKind Type Type - --- | A cue to print out information about type variables, --- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@. -data TyVarInfo = - TyVarInfo { thisTyVar :: TyVar - , thisTyVarIsUntouchable :: Maybe Implication - , otherTy :: Maybe TyVar } - --- | Add some information to disambiguate errors in which --- two 'Names' would otherwise appear to be identical. --- --- See Note [Disambiguating (X ~ X) errors]. -data SameOccInfo - = SameOcc - { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. - , sameOcc_lhs :: Name - , sameOcc_rhs :: Name } - --- | Add some information about ambiguity -data AmbiguityInfo - - -- | Some type variables remained ambiguous: print them to the user. - = Ambiguity - { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..." - -- False <=> create a message of the form "The type variable is ambiguous." - , ambig_tyvars :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively. - -- Guaranteed to not both be empty. - } - - -- | Remind the user that a particular type family is not injective. - | NonInjectiveTyFam TyCon - --- | Expected/actual information. -data ExpectedActualInfo - -- | Display the expected and actual types. - = ExpectedActual - { ea_expected, ea_actual :: Type } - - -- | Display the expected and actual types, after expanding type synonyms. - | ExpectedActualAfterTySynExpansion - { ea_expanded_expected, ea_expanded_actual :: Type } - --- | Explain how a kind equality originated. -data WhenMatching - - = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) - deriving Generic - -data BadImportKind - -- | Module does not export... - = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant - -- | Missing @type@ keyword when importing a type. - | BadImportAvailTyCon - -- | Trying to import a data constructor directly, e.g. - -- @import Data.Maybe (Just)@ instead of @import Data.Maybe (Maybe(Just))@ - | BadImportAvailDataCon OccName - -- | The parent does not export the given children. - | BadImportNotExportedSubordinates [OccName] - -- | Incorrect @type@ keyword when importing something which isn't a type. - | BadImportAvailVar - deriving Generic - --- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' --- constructor of 'HoleError'. -data NotInScopeError - - -- | A run-of-the-mill @"not in scope"@ error. - = NotInScope - - -- | Like 'NotInScope', but when we know we are looking for a - -- record field. - | NotARecordField - - -- | An exact 'Name' was not in scope. - -- - -- This usually indicates a problem with a Template Haskell splice. - -- - -- Test cases: T5971, T18263. - | NoExactName Name - - -- The same exact 'Name' occurs in multiple name-spaces. - -- - -- This usually indicates a problem with a Template Haskell splice. - -- - -- Test case: T7241. - | SameName [GlobalRdrElt] -- ^ always at least 2 elements - - -- A type signature, fixity declaration, pragma, standalone kind signature... - -- is missing an associated binding. - | MissingBinding SDoc [GhcHint] - -- TODO: remove the SDoc argument. - - -- | Couldn't find a top-level binding. - -- - -- Happens when specifying an annotation for something that - -- is not in scope. - -- - -- Test cases: annfail01, annfail02, annfail11. - | NoTopLevelBinding - - -- | A class doesn't have a method with this name, - -- or, a class doesn't have an associated type with this name, - -- or, a record doesn't have a record field with this name. - | UnknownSubordinate SDoc - - -- | A name is not in scope during type checking but passed the renamer. - -- - -- Test cases: - -- none - | NotInScopeTc (NameEnv TcTyThing) - deriving Generic - --- | Create a @"not in scope"@ error message for the given 'RdrName'. -mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage -mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints - --- | Configuration for pretty-printing valid hole fits. -data HoleFitDispConfig = - HFDC { showWrap, showWrapVars, showType, showProv, showMatches - :: Bool } - --- | Report an error involving a 'Hole'. --- --- This could be an out of scope data constructor or variable, --- a typed hole, or a wildcard in a type. -data HoleError - -- | Report an out-of-scope data constructor or variable - -- masquerading as an expression hole. - -- - -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint. - -- See 'NotInScopeError' for other not-in-scope errors. - -- - -- Test cases: T9177a. - = OutOfScopeHole [ImportError] - -- | Report a typed hole, or wildcard, with additional information. - | HoleError HoleSort - [TcTyVar] -- Other type variables which get computed on the way. - [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole. - --- | A message that aims to explain why two types couldn't be seen --- to be representationally equal. -data CoercibleMsg - -- | Not knowing the role of a type constructor prevents us from - -- concluding that two types are representationally equal. - -- - -- Example: - -- - -- foo :: Applicative m => m (Sum Int) - -- foo = coerce (pure $ 1 :: Int) - -- - -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`. - -- - -- Test cases: T8984, TcCoercibleFail. - = UnknownRoles Type - - -- | The fact that a 'TyCon' is abstract prevents us from decomposing - -- a 'TyConApp' and deducing that two types are representationally equal. - -- - -- Test cases: none. - | TyConIsAbstract TyCon - - -- | We can't unwrap a newtype whose constructor is not in scope. - -- - -- Example: - -- - -- import Data.Ord (Down) -- NB: not importing the constructor - -- foo :: Int -> Down Int - -- foo = coerce - -- - -- Test cases: TcCoercibleFail. - | OutOfScopeNewtypeConstructor TyCon DataCon - --- | Explain a problem with an import. -data ImportError - -- | Couldn't find a module with the requested name. - = MissingModule ModuleName - -- | The imported modules don't export what we're looking for. - | ModulesDoNotExport (NE.NonEmpty Module) OccName - --- | This datatype collates instances that match or unifier, --- in order to report an error message for an unsolved typeclass constraint. -data PotentialInstances - = PotentialInstances - { matches :: [ClsInst] - , unifiers :: [ClsInst] - } - --- | A collection of valid hole fits or refinement fits, --- in which some fits might have been suppressed. -data FitsMbSuppressed - = Fits - { fits :: [HoleFit] - , fitsSuppressed :: Bool -- ^ Whether we have suppressed any fits because there were too many. - } - --- | A collection of hole fits and refinement fits. -data ValidHoleFits - = ValidHoleFits - { holeFits :: FitsMbSuppressed - , refinementFits :: FitsMbSuppressed - } - -noValidHoleFits :: ValidHoleFits -noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False) - -data RelevantBindings - = RelevantBindings - { relevantBindingNamesAndTys :: [(Name, Type)] - , ranOutOfFuel :: Bool -- ^ Whether we ran out of fuel generating the bindings. - } - --- | Display some relevant bindings. -pprRelevantBindings :: RelevantBindings -> SDoc --- This function should be in "GHC.Tc.Errors.Ppr", --- but it's here for the moment as it's needed in "GHC.Tc.Errors". -pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = - ppUnless (null rel_bds) $ - hang (text "Relevant bindings include") - 2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg) - where - ppr_binding (nm, tidy_ty) = - sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc nm)))] - rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - - --- | Stores the information to be reported in a representation-polymorphism --- error message. -data FixedRuntimeRepErrorInfo - = FRR_Info - { frr_info_origin :: FixedRuntimeRepOrigin - -- ^ What is the original type we checked for - -- representation-polymorphism, and what specific - -- check did we perform? - , frr_info_not_concrete :: Maybe (TcTyVar, TcType) - -- ^ Which non-concrete type did we try to - -- unify this concrete type variable with? - } - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | StandaloneKindSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (LocatedN RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (LocatedN RdrName) - | TySynCtx (LocatedN RdrName) - | TyFamilyCtx (LocatedN RdrName) - | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [LocatedN Name] - | ClassDeclCtx (LocatedN RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | HsTypePatCtx - | GHCiCtx - | SpliceTypeCtx (LHsType GhcPs) - | ClassInstanceCtx - | GenericCtx SDoc - --- | Context for a mismatch in the number of arguments -data MatchArgsContext - = EquationArgs - !Name -- ^ Name of the function - | PatternArgs - !(HsMatchContext GhcTc) -- ^ Pattern match specifics - --- | The information necessary to report mismatched --- numbers of arguments in a match group. -data MatchArgBadMatches where - MatchArgMatches - :: { matchArgFirstMatch :: LocatedA (Match GhcRn body) - , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) } - -> MatchArgBadMatches - --- | The context for an "empty statement group" error. -data EmptyStatementGroupErrReason - = EmptyStmtsGroupInParallelComp - -- ^ Empty statement group in a parallel list comprehension - | EmptyStmtsGroupInTransformListComp - -- ^ Empty statement group in a transform list comprehension - -- - -- Example: - -- [() | then ()] - | EmptyStmtsGroupInDoNotation HsDoFlavour - -- ^ Empty statement group in do notation - -- - -- Example: - -- do - | EmptyStmtsGroupInArrowNotation - -- ^ Empty statement group in arrow notation - -- - -- Example: - -- proc () -> do - - deriving (Generic) - --- | An existential wrapper around @'StmtLR' GhcPs GhcPs body@. -data UnexpectedStatement where - UnexpectedStatement - :: Outputable (StmtLR GhcPs GhcPs body) - => StmtLR GhcPs GhcPs body - -> UnexpectedStatement - -data DeclSort = ClassDeclSort | InstanceDeclSort - -data NonStandardGuards where - NonStandardGuards - :: (Outputable body, - Anno (Stmt GhcRn body) ~ SrcSpanAnnA) - => [LStmtLR GhcRn GhcRn body] - -> NonStandardGuards - -data RuleLhsErrReason - = UnboundVariable RdrName NotInScopeError - | IllegalExpression - -data HsigShapeMismatchReason = - {-| HsigShapeSortMismatch is an error indicating that an item in the - export list of a signature doesn't match the item of the same name in - another signature when merging the two – one is a type while the other is a - plain identifier. - - Test cases: - none - -} - HsigShapeSortMismatch !AvailInfo !AvailInfo - | - {-| HsigShapeNotUnifiable is an error indicating that a name in the - export list of a signature cannot be unified with a name of the same name in - another signature when merging the two. - - Test cases: - bkpfail20, bkpfail21 - -} - HsigShapeNotUnifiable !Name !Name !Bool - deriving (Generic) - -data WrongThingSort - = WrongThingType - | WrongThingDataCon - | WrongThingPatSyn - | WrongThingConLike - | WrongThingClass - | WrongThingTyCon - | WrongThingAxiom - -data StageCheckReason - = StageCheckInstance !InstanceWhat !PredType - | StageCheckSplice !Name - -data UninferrableTyVarCtx - = UninfTyCtx_ClassContext [TcType] - | UninfTyCtx_DataContext [TcType] - | UninfTyCtx_ProvidedContext [TcType] - | UninfTyCtx_TyFamRhs TcType - | UninfTyCtx_TySynRhs TcType - | UninfTyCtx_Sig TcType (LHsSigType GhcRn) - -data PatSynInvalidRhsReason - = PatSynNotInvertible !(Pat GhcRn) - | PatSynUnboundVar !Name - deriving (Generic) - -data BadFieldAnnotationReason where - {-| A lazy data type field annotation (~) was used without enabling the - extension StrictData. - - Test cases: - LazyFieldsDisabled - -} - LazyFieldsDisabled :: BadFieldAnnotationReason - {-| An UNPACK pragma was applied to a field without strictness annotation (!). - - Test cases: - T14761a, T7562 - -} - UnpackWithoutStrictness :: BadFieldAnnotationReason - {-| An UNPACK pragma was applied to an abstract type in an indefinite package - in Backpack. - - Test cases: - unpack_sums_5, T3966, T7050 - -} - BackpackUnpackAbstractType :: BadFieldAnnotationReason - deriving (Generic) - -data SuperclassCycle = - MkSuperclassCycle { cls :: Class, definite :: Bool, reasons :: [SuperclassCycleDetail] } - -data SuperclassCycleDetail - = SCD_HeadTyVar !PredType - | SCD_HeadTyFam !PredType - | SCD_Superclass !Class - -data RoleValidationFailedReason - = TyVarRoleMismatch !TyVar !Role - | TyVarMissingInEnv !TyVar - | BadCoercionRole !Coercion - deriving (Generic) - -data DisabledClassExtension where - {-| MultiParamTypeClasses is required. - - Test cases: - readFail037, TcNoNullaryTC - -} - MultiParamDisabled :: !Int -- ^ The arity - -> DisabledClassExtension - {-| FunctionalDependencies is required. - - Test cases: - readFail041 - -} - FunDepsDisabled :: DisabledClassExtension - {-| ConstrainedClassMethods is required. - - Test cases: - mod39, tcfail150 - -} - ConstrainedClassMethodsDisabled :: !Id - -> !TcPredType - -> DisabledClassExtension - deriving (Generic) - -data TyFamsDisabledReason - = TyFamsDisabledFamily !Name - | TyFamsDisabledInstance !TyCon - deriving (Generic) - -data TypeApplication - = TypeApplication !(HsType GhcPs) !TypeOrKind - | TypeApplicationInPattern !(HsConPatTyArg GhcPs) - deriving Generic - --- | Either `HsType p` or `HsSigType p`. --- --- Used for reporting errors in `TcRnIllegalKind`. -data HsTypeOrSigType p - = HsType (HsType p) - | HsSigType (HsSigType p) - -instance OutputableBndrId p => Outputable (HsTypeOrSigType (GhcPass p)) where - ppr (HsType ty) = ppr ty - ppr (HsSigType sig_ty) = ppr sig_ty - --- | A wrapper around HsTyVarBndr. --- Used for reporting errors in `TcRnUnusedQuantifiedTypeVar`. -data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed => - HsTyVarBndrExistentialFlag (HsTyVarBndr flag GhcRn) - -instance Outputable HsTyVarBndrExistentialFlag where - ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr - -type TySynCycleTyCons = - [Either TyCon (LTyClDecl GhcRn)] - --- | Different types of warnings for dodgy imports. -data DodgyImportsReason = - {-| An import of the form 'T(..)' or 'f(..)' does not actually import anything beside - 'T'/'f' itself. - - Test cases: - DodgyImports - -} - DodgyImportsEmptyParent !GlobalRdrElt - | - {-| A 'hiding' clause contains something that would be reported as an error in a - regular import, but is relaxed to a warning. - - Test cases: - DodgyImports_hiding - -} - DodgyImportsHiding !ImportLookupReason - deriving (Generic) - --- | Different types of errors for import lookup. -data ImportLookupReason where - {-| An item in an import statement is not exported by the corresponding - module. - - Test cases: - T21826, recomp001, retc001, mod79, mod80, mod81, mod91, T6007, T7167, - T9006, T11071, T9905fail2, T5385, T10668 - -} - ImportLookupBad :: BadImportKind - -> ModIface - -> ImpDeclSpec - -> IE GhcPs - -> Bool -- ^ whether @-XPatternSynonyms@ was enabled - -> ImportLookupReason - {-| A name is specified with a qualifying module. - - Test cases: - T3792 - -} - ImportLookupQualified :: !RdrName -- ^ The name extracted from the import item - -> ImportLookupReason - - {-| Something completely unexpected is in an import list, like @module Foo@. - - Test cases: - ImportLookupIllegal - -} - ImportLookupIllegal :: ImportLookupReason - {-| An item in an import list matches multiple names exported from that module. - - Test cases: - None - -} - ImportLookupAmbiguous :: !RdrName -- ^ The name extracted from the import item - -> ![GlobalRdrElt] -- ^ The potential matches - -> ImportLookupReason - deriving (Generic) - --- | Distinguish record fields from other names for pretty-printing. -data UnusedImportName where - UnusedImportNameRecField :: !Parent -> !OccName -> UnusedImportName - UnusedImportNameRegular :: !Name -> UnusedImportName - --- | Different types of errors for unused imports. -data UnusedImportReason where - {-| No names in the import list are used in the module. - - Test cases: - overloadedrecfldsfail06, T10890_2, t22391, t22391j, T1074, prog018, - mod177, rn046, rn037, T5211 - -} - UnusedImportNone :: UnusedImportReason - {-| A set of names in the import list are not used in the module. - - Test cases: - overloadedrecfldsfail06, T17324, mod176, T11970A, rn046, T14881, - T7454, T8149, T13064 - -} - UnusedImportSome :: ![UnusedImportName] -- ^ The unsed names - -> UnusedImportReason - deriving (Generic) - --- | Different places in which a nested foralls/contexts error might occur. -data NestedForallsContextsIn - -- | Nested forall in @SPECIALISE instance@ - = NFC_Specialize - -- | Nested forall in @deriving via@ (via-type) - | NFC_ViaType - -- | Nested forall in the type of a GADT constructor - | NFC_GadtConSig - -- | Nested forall in an instance head - | NFC_InstanceHead - -- | Nested forall in a standalone deriving instance head - | NFC_StandaloneDerivedInstanceHead - -- | Nested forall in deriving class type - | NFC_DerivedClassType - --- | Provenance of an unused name. -data UnusedNameProv - = UnusedNameTopDecl - | UnusedNameImported !ModuleName - | UnusedNameTypePattern - | UnusedNameMatch - | UnusedNameLocalBind - --- | Different reasons for TcRnNonCanonicalDefinition. -data NonCanonicalDefinition = - -- | Related to @(<>)@ and @mappend@. - NonCanonicalMonoid NonCanonical_Monoid - | - -- | Related to @(*>)@/@(>>)@ and @pure@/@return@. - NonCanonicalMonad NonCanonical_Monad - deriving (Generic) - --- | Possible cases for the -Wnoncanonical-monoid-instances. -data NonCanonical_Monoid = - -- | @(<>) = mappend@ was defined. - NonCanonical_Sappend - | - -- | @mappend@ was defined as something other than @(<>)@. - NonCanonical_Mappend - --- | Possible cases for the -Wnoncanonical-monad-instances. -data NonCanonical_Monad = - -- | @pure = return@ was defined. - NonCanonical_Pure - | - -- | @(*>) = (>>)@ was defined. - NonCanonical_ThenA - | - -- | @return@ was defined as something other than @pure@. - NonCanonical_Return - | - -- | @(>>)@ was defined as something other than @(*>)@. - NonCanonical_ThenM - --- | Why was an instance declaration rejected? -data IllegalInstanceReason - = IllegalClassInstance - !TypedThing -- ^ the instance head type - !IllegalClassInstanceReason -- ^ the problem with the instance head - | IllegalFamilyInstance !IllegalFamilyInstanceReason - | IllegalFamilyApplicationInInstance - !Type -- ^ the instance head type - !Bool -- ^ is this an invisible argument? - !TyCon -- ^ type family - ![Type] -- ^ type family argument - deriving Generic - --- | Why was a class instance declaration rejected? -data IllegalClassInstanceReason - -- | An illegal type at the head of the instance. - -- - -- See t'IllegalInstanceHeadReason'. - = IllegalInstanceHead !IllegalInstanceHeadReason - -- | An illegal HasField instance. See t'IllegalHasFieldInstance'. - | IllegalHasFieldInstance !IllegalHasFieldInstance - -- | An illegal instance for a built-in typeclass such as - -- 'Coercible', 'Typeable', or 'KnownNat', outside of a signature file. - -- - -- Test cases: deriving/should_fail/T9687 - -- deriving/should_fail/T14916 - -- polykinds/T8132 - -- typecheck/should_fail/TcCoercibleFail2 - -- typecheck/should_fail/T12837 - -- typecheck/should_fail/T14390 - | IllegalSpecialClassInstance !Class !Bool -- ^ Whether the error is due to Safe Haskell being enabled - -- | The instance failed the coverage condition, i.e. the functional - -- dependencies were not respected. - -- - -- Example: - -- - -- class C a b | a -> b where {..} - -- instance C a b where {..} - -- - -- Test cases: T9106, T10570, T2247, T12803, tcfail170. - | IllegalInstanceFailsCoverageCondition - !Class !CoverageProblem - deriving Generic - --- | Why was a HasField instance declaration rejected? -data IllegalHasFieldInstance - -- | HasField instance for a type not headed by a TyCon. - -- - -- Example: - -- - -- instance HasField a where {..} - -- - -- Test case: hasfieldfail03 - = IllegalHasFieldInstanceNotATyCon - -- | HasField instance for a data family. - -- - -- Example: - -- - -- data family D a - -- data instance D Int = MkDInt Char - -- - -- instance HasField "fld" (D Int) where {..} - -- - -- Test case: hasfieldfail03 - | IllegalHasFieldInstanceFamilyTyCon - -- | HasField instance for a type that already has that field. - -- - -- Example - -- - -- data T = MkT { quux :: Int } - -- instance HasField "quux" T Int where {..} - -- - -- Test case: hasfieldfail03 - | IllegalHasFieldInstanceTyConHasField !TyCon !FieldLabelString - -- | HasField instance for a type that already has fields, when the - -- field label could potentially unify with those fields. - -- - -- Example: - -- - -- data T = MkInt { quux :: Int } - -- instance forall (fld :: Symbol). HasField fld T Int where {..} - -- - -- Test case: hasfieldfail03 - | IllegalHasFieldInstanceTyConHasFields !TyCon !Type -- ^ the label type in the instance head - deriving Generic - --- | Description of an instance coverage condition failure. -data CoverageProblem = - CoverageProblem - { not_covered_fundep :: ([TyVar], [TyVar]) - , not_covered_fundep_inst :: ([Type], [Type]) - , not_covered_invis_vis_tvs :: Pair VarSet - , not_covered_liberal :: FailedCoverageCondition - } - --- | Which instance coverage condition failed? Was it the liberal --- coverage condition? -data FailedCoverageCondition - -- | Failed the instance coverage condition (ICC) - = FailedICC - { alsoFailedLICC :: !Bool - -- ^ Whether the instance also failed the LICC - } - -- | Failed the liberal instance coverage condition (LICC) - | FailedLICC - --------------------------------------------------------------------------------- --- Template Haskell errors - -data THError - -- | A syntax error with Template Haskel quotes & splices. - -- See t'THSyntaxError'. - = THSyntaxError !THSyntaxError - -- | An error in Template Haskell involving 'Name's. - -- See t'THNameError'. - | THNameError !THNameError - -- | An error in Template Haskell reification. See t'THReifyError'. - | THReifyError !THReifyError - -- | An error due to typing restrictions in Typed Template Haskell. - -- See t'TypedTHError'. - | TypedTHError !TypedTHError - -- | An error occurred when trying to run a splice in Template Haskell. - -- See 'SpliceFailReason'. - | THSpliceFailed !SpliceFailReason - -- | An error involving the 'addTopDecls' functionality. See t'AddTopDeclsError'. - | AddTopDeclsError !AddTopDeclsError - - {-| IllegalStaticFormInSplice is an error when a user attempts to define - a static pointer in a Template Haskell splice. - - Example(s): - - Test cases: th/TH_StaticPointers02 - -} - | IllegalStaticFormInSplice !(HsExpr GhcPs) - - {-| FailedToLookupThInstName is a Template Haskell error that occurrs when looking up an - instance fails. - - Example(s): - - Test cases: showIface/should_fail/THPutDocNonExistent - -} - | FailedToLookupThInstName !TH.Type !LookupTHInstNameErrReason - - {-| AddInvalidCorePlugin is a Template Haskell error indicating that a - Core plugin being added has an invalid module due to being - in the current package. - - Example(s): - - Test cases: - -} - | AddInvalidCorePlugin !String -- ^ Module name - - {-| AddDocToNonLocalDefn is a Template Haskell error for documentation being added to a - definition which is not in the current module. - - Example(s): - - Test cases: showIface/should_fail/THPutDocExternal - -} - | AddDocToNonLocalDefn !TH.DocLoc - - {-| ReportCustomQuasiError is an error or warning thrown using 'qReport' from - the 'Quasi' instance of 'TcM'. - - Example(s): - - Test cases: - -} - | ReportCustomQuasiError - !Bool -- ^ True => Error, False => Warning - !String -- ^ Error body - deriving Generic - --- | An error involving Template Haskell quotes or splices, e.g. nested --- quotation brackets or the use of an untyped bracket inside a typed splice. -data THSyntaxError - = {-| IllegalTHQuotes is an error that occurs when a Template Haskell - quote is used without the TemplateHaskell extension enabled. - - Test case: T18251e - -} - IllegalTHQuotes !(HsExpr GhcPs) - - {-| IllegalTHSplice is an error that occurs when a Template Haskell - splice occurs without having enabled the TemplateHaskell extension. - - Test cases: - bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06 - -} - | IllegalTHSplice - - {-| NestedTHBrackets is an error that occurs when Template Haskell - brackets are nested without any intervening splices. - - Example: - - foo = [| [| 'x' |] |] - - Test cases: TH_NestedSplicesFail{5,6,7,8} - -} - | NestedTHBrackets - - {-| MismatchedSpliceType is an error that happens when a typed bracket - or splice is used inside a typed splice/bracket, or the other way around. - - Examples: - - f1 = [| $$x |] - f2 = [|| $y ||] - f3 = $$( [| 'x' |] ) - f4 = $( [|| 'y' ||] ) - - Test cases: TH_NestedSplicesFail{1,2,3,4} - -} - | MismatchedSpliceType - SpliceType -- ^ type of the splice - SpliceOrBracket -- ^ what's nested inside - {-| BadImplicitSplice is an error thrown when a user uses top-level implicit - TH-splice without enabling the TemplateHaskell extension. - - Example: - - pure [] -- on top-level - - Test cases: ghci/prog019/prog019 - ghci/scripts/T1914 - ghci/scripts/T6106 - rename/should_fail/T4042 - rename/should_fail/T12146 - -} - | BadImplicitSplice - deriving Generic - -data THNameError - {-| NonExactName is a Template Haskell error that occurs when the user - attempts to define a binder with a 'RdrName' that is not an exact 'Name'. - - Example(s): - - Test cases: - -} - = NonExactName !RdrName - - {-| QuotedNameWrongStage is an error that can happen when a - (non-top-level) Name is used at a different Template Haskell stage - than the stage at which it is bound. - - Test cases: T16976z - -} - | QuotedNameWrongStage !(HsQuote GhcPs) - deriving Generic - -data THReifyError - = {-| CannotReifyInstance is a Template Haskell error for when an instance being reified - via `reifyInstances` is not a class constraint or type family application. - - Example(s): - - Test cases: - -} - CannotReifyInstance !Type - - {-| CannotReifyOutOfScopeThing is a Template Haskell error indicating - that the given name is not in scope and therefore cannot be reified. - - Example(s): - - Test cases: th/T16976f - -} - | CannotReifyOutOfScopeThing !TH.Name - - {-| CannotReifyThingNotInTypeEnv is a Template Haskell error occurring - when the given name is not in the type environment and therefore cannot be reified. - - Example(s): - - Test cases: - -} - | CannotReifyThingNotInTypeEnv !Name - - {-| NoRolesAssociatedWithName is a Template Haskell error for when the user - tries to reify the roles of a given name but it is not something that has - roles associated with it. - - Example(s): - - Test cases: - -} - | NoRolesAssociatedWithThing !TcTyThing - - {-| CannotRepresentThing is a Template Haskell error indicating that a - type cannot be reified because it does not have a representation in Template Haskell. - - Example(s): - - Test cases: - -} - | CannotRepresentType !UnrepresentableTypeDescr !Type - deriving Generic - -data AddTopDeclsError - = {-| InvalidTopDecl is a Template Haskell error occurring when one of the 'Dec's passed to - 'addTopDecls' is not a function, value, annotation, or foreign import declaration. - - Example(s): - - Test cases: - -} - InvalidTopDecl !(HsDecl GhcPs) - {-| UnexpectedDeclarationSplice is an error that occurs when a Template Haskell - splice appears inside top-level declarations added with 'addTopDecls'. - - Example(s): none - - Test cases: none - -} - | AddTopDeclsUnexpectedDeclarationSplice - - | AddTopDeclsRunSpliceFailure !RunSpliceFailReason - deriving Generic - -data TypedTHError - = {-| SplicePolymorphicLocalVar is the error that occurs when the expression - inside typed Template Haskell brackets is a polymorphic local variable. - - Example(s): - x = \(y :: forall a. a -> a) -> [|| y ||] - - Test cases: quotes/T10384 - -} - SplicePolymorphicLocalVar !Id - - {-| TypedTHWithPolyType is an error that signifies the illegal use - of a polytype in a typed Template Haskell expression. - - Example(s): - bad :: (forall a. a -> a) -> () - bad = $$( [|| \_ -> () ||] ) - - Test cases: th/T11452 - -} - | TypedTHWithPolyType !TcType - deriving Generic - -data SpliceFailReason - = {-| SpliceThrewException is an error that occurs when running a Template - Haskell splice throws an exception. - - Example(s): - - Test cases: annotations/should_fail/annfail12 - perf/compiler/MultiLayerModulesTH_Make - perf/compiler/MultiLayerModulesTH_OneShot - th/T10796b - th/T19470 - th/T19709d - th/T5358 - th/T5976 - th/T7276a - th/T8987 - th/TH_exn1 - th/TH_exn2 - th/TH_runIO - -} - SpliceThrewException - !SplicePhase - !SomeException - !String -- ^ Result of showing the exception (cannot be done safely outside IO) - !(LHsExpr GhcTc) - !Bool -- True <=> Print the expression - - {-| RunSpliceFailure is an error indicating that a Template Haskell splice - failed to be converted into a valid expression. - - Example(s): - - Test cases: th/T10828a - th/T10828b - th/T12478_4 - th/T15270A - th/T15270B - th/T16895a - th/T16895b - th/T16895c - th/T16895d - th/T16895e - th/T18740d - th/T2597b - th/T2674 - th/T3395 - th/T7484 - th/T7667a - th/TH_implicitParamsErr1 - th/TH_implicitParamsErr2 - th/TH_implicitParamsErr3 - th/TH_invalid_add_top_decl - -} - | RunSpliceFailure !RunSpliceFailReason - deriving Generic - -data RunSpliceFailReason - = ConversionFail !ThingBeingConverted !ConversionFailReason - deriving Generic - --- | Identifies the TH splice attempting to be converted -data ThingBeingConverted - = ConvDec !TH.Dec - | ConvExp !TH.Exp - | ConvPat !TH.Pat - | ConvType !TH.Type - --- | The reason a TH splice could not be converted to a Haskell expression -data ConversionFailReason - = IllegalOccName !OccName.NameSpace !String - | SumAltArityExceeded !TH.SumAlt !TH.SumArity - | IllegalSumAlt !TH.SumAlt - | IllegalSumArity !TH.SumArity - | MalformedType !TypeOrKind !TH.Type - | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs)) - | KindSigsOnlyAllowedOnGADTs - | IllegalDeclaration !THDeclDescriptor !IllegalDecls - | CannotMixGADTConsWith98Cons - | EmptyStmtListInDoBlock - | NonVarInInfixExpr - | MultiWayIfWithoutAlts - | CasesExprWithoutAlts - | ImplicitParamsWithOtherBinds - | InvalidCCallImpent !String -- ^ Source - | RecGadtNoCons - | GadtNoCons - | InvalidTypeInstanceHeader !TH.Type - | InvalidTyFamInstLHS !TH.Type - | InvalidImplicitParamBinding - | DefaultDataInstDecl ![LDataFamInstDecl GhcPs] - | FunBindLacksEquations !TH.Name - deriving Generic - -data IllegalDecls - = IllegalDecls !(NE.NonEmpty (LHsDecl GhcPs)) - | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs)) - --- | Label for a TH declaration -data THDeclDescriptor - = InstanceDecl - | WhereClause - | LetBinding - | LetExpression - | ClssDecl - --- | The phase in which an exception was encountered when dealing with a TH splice -data SplicePhase - = SplicePhase_Run - | SplicePhase_CompileAndLink - -data LookupTHInstNameErrReason - = NoMatchesFound - | CouldNotDetermineInstance - -data UnrepresentableTypeDescr - = LinearInvisibleArgument - | CoercionsInTypes - --- FFI error types -data IllegalForeignTypeReason - = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason - | ForeignDynNotPtr - !Type -- ^ Expected type - !Type -- ^ Actual type - | SafeHaskellMustBeInIO - | IOResultExpected - | UnexpectedNestedForall - | LinearTypesNotAllowed - | OneArgExpected - | AtLeastOneArgExpected - deriving Generic - --- | Reason why a type cannot be marshalled through the FFI. -data TypeCannotBeMarshaledReason - = NotADataType - | NewtypeDataConNotInScope !TyCon ![Type] - | UnliftedFFITypesNeeded - | NotABoxedMarshalableTyCon - | ForeignLabelNotAPtr - | NotSimpleUnliftedType - | NotBoxedKindAny - deriving Generic +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Errors.Types ( + -- * Main types + TcRnMessage(..) + , TcRnMessageOpts(..) + , mkTcRnUnknownMessage + , TcRnMessageDetailed(..), ErrInfo(..) + , TypeDataForbids(..) + , FixedRuntimeRepProvenance(..) + , pprFixedRuntimeRepProvenance + , ShadowedNameProvenance(..) + , ResolvedNameInfo(..) + , pprResolvedNameProvenance + , RecordFieldPart(..) + , IllegalNewtypeReason(..) + , BadRecordUpdateReason(..) + , InjectivityErrReason(..) + , HasKinds(..) + , hasKinds + , SuggestUndecidableInstances(..) + , suggestUndecidableInstances + , SuggestUnliftedTypes(..) + , DataSort(..), ppDataSort + , AllowedDataResKind(..) + , NotClosedReason(..) + , SuggestPartialTypeSignatures(..) + , suggestPartialTypeSignatures + , DeriveInstanceErrReason(..) + , UsingGeneralizedNewtypeDeriving(..) + , usingGeneralizedNewtypeDeriving + , DeriveAnyClassEnabled(..) + , deriveAnyClassEnabled + , DeriveInstanceBadConstructor(..) + , HasWildcard(..) + , hasWildcard + , BadAnonWildcardContext(..) + , SoleExtraConstraintWildcardAllowed(..) + , DeriveGenericsErrReason(..) + , HasAssociatedDataFamInsts(..) + , hasAssociatedDataFamInsts + , AssociatedTyLastVarInKind(..) + , associatedTyLastVarInKind + , AssociatedTyNotParamOverLastTyVar(..) + , associatedTyNotParamOverLastTyVar + , MissingSignature(..) + , Exported(..) + , HsDocContext(..) + , FixedRuntimeRepErrorInfo(..) + , TcRnNoDerivStratSpecifiedInfo(..) + + , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc + + , SolverReport(..), SupplementaryInfo(..) + , SolverReportWithCtxt(..) + , SolverReportErrCtxt(..) + , getUserGivens, discardProvCtxtGivens + , TcSolverReportMsg(..) + , CannotUnifyVariableReason(..) + , MismatchMsg(..) + , MismatchEA(..) + , mkPlainMismatchMsg, mkBasicMismatchMsg + , WhenMatching(..) + , ExpectedActualInfo(..) + , TyVarInfo(..), SameOccInfo(..) + , AmbiguityInfo(..) + , CND_Extra(..) + , FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits + , HoleFitDispConfig(..) + , RelevantBindings(..), pprRelevantBindings + , PromotionErr(..), pprPECategory, peCategory + , TermLevelUseErr(..), teCategory + , NotInScopeError(..) + , Subordinate(..), pprSubordinate + , ImportError(..) + , WhatLooking(..) + , lookingForSubordinate + , HoleError(..) + , CoercibleMsg(..) + , PotentialInstances(..) + , UnsupportedCallConvention(..) + , ExpectedBackends + , ArgOrResult(..) + , MatchArgsContext(..), MatchArgBadMatches(..) + , PragmaWarningInfo(..) + , EmptyStatementGroupErrReason(..) + , UnexpectedStatement(..) + , DeclSort(..) + , NonStandardGuards(..) + , RuleLhsErrReason(..) + , HsigShapeMismatchReason(..) + , WrongThingSort(..) + , LevelCheckReason(..) + , UninferrableTyVarCtx(..) + , PatSynInvalidRhsReason(..) + , BadFieldAnnotationReason(..) + , SuperclassCycle(..) + , SuperclassCycleDetail(..) + , RoleValidationFailedReason(..) + , DisabledClassExtension(..) + , TyFamsDisabledReason(..) + , BadInvisPatReason(..) + , BadEmptyCaseReason(..) + , HsTypeOrSigType(..) + , HsTyVarBndrExistentialFlag(..) + , TySynCycleTyCons + , BadImportKind(..) + , DodgyImportsReason (..) + , ImportLookupExtensions (..) + , ImportLookupReason (..) + , UnusedImportReason (..) + , UnusedImportName (..) + , NestedForallsContextsIn(..) + , UnusedNameProv(..) + , NonCanonicalDefinition(..) + , NonCanonical_Monoid(..) + , NonCanonical_Monad(..) + , TypeSyntax(..) + , typeSyntaxExtension + + -- * Errors for hs-boot and signature files + , BadBootDecls(..) + , MissingBootThing(..), missingBootThing + , BootMismatch(..) + , BootMismatchWhat(..) + , BootTyConMismatch(..) + , BootAxiomBranchMismatch(..) + , BootClassMismatch(..) + , BootMethodMismatch(..) + , BootATMismatch(..) + , BootDataMismatch(..) + , BootDataConMismatch(..) + , SynAbstractDataError(..) + , BootListMismatch(..), BootListMismatches + + -- * Class and family instance errors + , IllegalInstanceReason(..) + , IllegalClassInstanceReason(..) + , IllegalInstanceHeadReason(..) + , IllegalHasFieldInstance(..) + , CoverageProblem(..), FailedCoverageCondition(..) + , IllegalFamilyInstanceReason(..) + , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..) + , InvalidAssoc(..), InvalidAssocInstance(..) + , InvalidAssocDefault(..), AssocDefaultBadArgs(..) + , InstHeadNonClassHead(..) + + -- * Template Haskell errors + , THError(..), THSyntaxError(..), THNameError(..) + , THReifyError(..), TypedTHError(..) + , SpliceFailReason(..), RunSpliceFailReason(..) + , AddTopDeclsError(..) + , ConversionFailReason(..) + , UnrepresentableTypeDescr(..) + , LookupTHInstNameErrReason(..) + , SplicePhase(..) + , THDeclDescriptor(..) + , ThingBeingConverted(..) + , IllegalDecls(..) + + -- * Zonker errors + , ZonkerMessage(..) + + -- * FFI Errors + , IllegalForeignTypeReason(..) + , TypeCannotBeMarshaledReason(..) + + -- * Error contexts + , ErrCtxtMsg(..) + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Errors.Types.PromotionErr +import GHC.Tc.Errors.Hole.FitTypes (HoleFit) +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence (EvBindsVar) +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) + , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing + , FixedRuntimeRepOrigin(..), InstanceWhat ) +import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, SubGoalDepth ) +import GHC.Tc.Types.Rank (Rank) +import GHC.Tc.Types.TH +import GHC.Tc.Utils.TcType (TcType, TcSigmaType, TcPredType, + PatersonCondFailure, PatersonCondFailureContext) + +import GHC.Types.Basic +import GHC.Types.Error +import GHC.Types.Avail +import GHC.Types.Hint (UntickedPromotedThing(..), AssumedDerivingStrategy(..), SigLike) +import GHC.Types.ForeignCall (CLabelString) +import GHC.Types.Id.Info ( RecSelParent(..) ) +import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan) +import GHC.Types.Name.Env (NameEnv) +import qualified GHC.Types.Name.Occurrence as OccName +import GHC.Types.Name.Reader +import GHC.Types.SourceFile (HsBootOrSig(..)) +import GHC.Types.SrcLoc +import GHC.Types.TyThing (TyThing) +import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar, CoVar, Specificity) +import GHC.Types.Var.Env (TidyEnv) +import GHC.Types.Var.Set (TyVarSet, VarSet) +import GHC.Types.DefaultEnv (ClassDefaults) + +import GHC.Unit.Types (Module) +import GHC.Unit.State (UnitState) +import GHC.Unit.Module.Warnings (WarningCategory, WarningTxt) +import GHC.Unit.Module.ModIface (ModIface) + +import GHC.Utils.Outputable + +import GHC.Core.Class (Class, ClassMinimalDef, ClassOpItem, ClassATItem) +import GHC.Core.Coercion (Coercion) +import GHC.Core.Coercion.Axiom (CoAxBranch) +import GHC.Core.ConLike (ConLike) +import GHC.Core.DataCon (DataCon, FieldLabel) +import GHC.Core.FamInstEnv (FamInst) +import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst, DFunId) +import GHC.Core.PatSyn (PatSyn) +import GHC.Core.Predicate (EqRel, predTypeEqRel) +import GHC.Core.TyCon (TyCon, Role, FamTyConFlav, AlgTyConRhs) +import GHC.Core.Type (Kind, Type, ThetaType, PredType, ErrorMsgType, ForAllTyFlag, ForAllTyBinder) + +import GHC.Driver.Backend (Backend) + +import GHC.Iface.Errors.Types + +import GHC.Utils.Misc (filterOut) + +import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString (FastString) +import GHC.Data.Pair +import GHC.Exception.Type (SomeException) + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Typeable (Typeable) +import qualified GHC.Boot.TH.Syntax as TH +import Data.Map.Strict (Map) + +import GHC.Generics ( Generic ) + +import qualified Data.Set as Set + +data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not + , tcOptsIfaceOpts :: !IfaceMessageOpts + } + +{- Note [Migrating TcM Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As part of #18516, we are slowly migrating the diagnostic messages emitted +and reported in the TcM from SDoc to TcRnMessage. Historically, GHC emitted +some diagnostics in 3 pieces, i.e. there were lots of error-reporting functions +that accepted 3 SDocs an input: one for the important part of the message, +one for the context and one for any supplementary information. Consider the following: + + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the expression: x4 + In a stmt of a 'do' block: return (x2, x4) + In the expression: + +Under the hood, the reporting functions in Tc.Utils.Monad were emitting "Couldn't match" +as the important part, "In the expression" as the context and "In a stmt..In the expression" +as the supplementary, with the context and supplementary usually smashed together so that +the final message would be composed only by two SDoc (which would then be bulleted like in +the example). + +In order for us to smooth out the migration to the new diagnostic infrastructure, we +introduce the 'ErrInfo' and 'TcRnMessageDetailed' types, which serve exactly the purpose +of bridging the two worlds together without breaking the external API or the existing +format of messages reported by GHC. + +Using 'ErrInfo' and 'TcRnMessageDetailed' also allows us to move away from the SDoc-ridden +diagnostic API inside Tc.Utils.Monad, enabling further refactorings. + +In the future, once the conversion will be complete and we will successfully eradicate +any use of SDoc in the diagnostic reporting of GHC, we can surely revisit the usage and +existence of these two types, which for now remain a "necessary evil". +-} + + +-- | The majority of TcRn messages come with extra context about the error, +-- and this newtype captures it. See Note [Migrating TcM Messages]. +data ErrInfo = ErrInfo { + errInfoContext :: ![ErrCtxtMsg] + -- ^ Extra context associated to the error. + , errInfoSupplementary :: !(Maybe (HoleFitDispConfig, [SupplementaryInfo])) + -- ^ Extra supplementary info associated to the error. + , errInfoHints :: ![GhcHint] + -- ^ Extra hints associated to the error. + } + + +-- | 'TcRnMessageDetailed' is an \"internal\" type (used only inside +-- 'GHC.Tc.Utils.Monad' that wraps a 'TcRnMessage' while also providing +-- any extra info needed to correctly pretty-print this diagnostic later on. +data TcRnMessageDetailed + = TcRnMessageDetailed + !ErrInfo + -- ^ extra info associated with the message + !TcRnMessage + -- ^ main error payload + deriving Generic + +mkTcRnUnknownMessage :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint TcRnMessage) + => a -> TcRnMessage +mkTcRnUnknownMessage diag = TcRnUnknownMessage (mkSimpleUnknownDiagnostic diag) + -- Please don't use this function inside the GHC codebase; + -- it mainly exists for users of the GHC API, such as plugins. + -- + -- If you need to emit a new error message in the typechecker, + -- you should add a new constructor to 'TcRnMessage' instead. + +-- | An error which might arise during typechecking/renaming. +data TcRnMessage where + {-| Simply wraps an unknown 'Diagnostic' message @a@. It can be used by plugins + to provide custom diagnostic messages originated during typechecking/renaming. + -} + TcRnUnknownMessage :: UnknownDiagnosticFor TcRnMessage -> TcRnMessage + + {-| Wrap an 'IfaceMessage' to a 'TcRnMessage' for when we attempt to load interface + files during typechecking but encounter an error. -} + + TcRnInterfaceError :: !IfaceMessage -> TcRnMessage + + {-| TcRnMessageWithInfo is a constructor which is used when extra information is needed + to be provided in order to qualify a diagnostic and where it was originated (and why). + It carries an extra 'UnitState' which can be used to pretty-print some names + and it wraps a 'TcRnMessageDetailed', which includes any extra context associated + with this diagnostic. + -} + TcRnMessageWithInfo :: !UnitState + -- ^ The 'UnitState' will allow us to pretty-print + -- some diagnostics with more detail. + -> !TcRnMessageDetailed + -> TcRnMessage + + {-| TcRnWithHsDocContext annotates an error message with the context in which + it originated. + -} + TcRnWithHsDocContext :: !HsDocContext + -> !TcRnMessage + -> TcRnMessage + + {-| TcRnSolverReport is the constructor used to report unsolved constraints + after constraint solving, as well as other errors such as hole fit errors. + + See the documentation of t'TcSolverReportMsg' datatype for an overview + of the different errors. + -} + TcRnSolverReport :: SolverReportWithCtxt + -> DiagnosticReason + -> TcRnMessage + + {-| TcRnSolverDepthError is an error that occurs when the constraint solver + exceeds the maximum recursion depth. + + Example: + + class C a where { meth :: a } + instance Cls [a] => Cls a where { meth = head . meth } + + t :: () + t = meth + + Test cases: + T7788 + T8550 + T9554 + T15316A + T17267{∅,a,b,c,e} + T17458 + ContextStack1 + T22924b + TcCoercibleFail + -} + TcRnSolverDepthError :: !Type -> !SubGoalDepth -> TcRnMessage + + {-| TcRnRedundantConstraints is a warning that is emitted when a binding + has a user-written type signature which contains superfluous constraints. + + Example: + + f :: (Eq a, Ord a) => a -> a -> a + f x y = (x < y) || x == y + -- `Eq a` is superfluous: the `Ord a` constraint suffices. + + Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. + -} + TcRnRedundantConstraints :: [Id] + -> (SkolemInfoAnon, Bool) + -- ^ The contextual skolem info. + -- The boolean controls whether we + -- want to show it in the user message. + -- (Nice to keep track of the info in either case, + -- for other users of the GHC API.) + -> TcRnMessage + + {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern + match is inaccessible, because the constraint solver has detected a contradiction. + + Example: + + data B a where { MkTrue :: B True; MkFalse :: B False } + + foo :: B False -> Bool + foo MkFalse = False + foo MkTrue = True -- Inaccessible: requires True ~ False + + Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. + -} + TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. + -> SolverReportWithCtxt -- ^ The contradiction. + -> TcRnMessage + {-| TcRnInaccessibleCoAxBranch is a warning that is emitted when a closed type family has a + branch which is inaccessible due to a more general, prior branch. + + Example: + type family F a where + F a = Int + F Bool = Bool + Test cases: T9085, T14066a, T9085, T6018, tc265, + + -} + TcRnInaccessibleCoAxBranch :: TyCon -- ^ The type family's constructor + -> CoAxBranch -- ^ The inaccessible branch + -> TcRnMessage + {-| A type which was expected to have a fixed runtime representation + does not have a fixed runtime representation. + + Example: + + data D (a :: TYPE r) = MkD a + + Test cases: T11724, T18534, + RepPolyPatSynArg, RepPolyPatSynUnliftedNewtype, + RepPolyPatSynRes, T20423 + -} + TcRnTypeDoesNotHaveFixedRuntimeRep :: !Type + -> !FixedRuntimeRepProvenance + -> ![ErrCtxtMsg] -- Extra info accumulated in the TcM monad + -> TcRnMessage + + {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when + a Template Haskell quote implicitly uses 'lift'. + + Example: + warning1 :: Lift t => t -> Q Exp + warning1 x = [| x |] + + Test cases: th/T17804 + -} + TcRnImplicitLift :: Name -> ![ErrCtxtMsg] -> TcRnMessage + + {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds) + that occurs if a pattern binding binds no variables at all, unless it is a + lone wild-card pattern, or a banged pattern. + + Example: + Just _ = rhs3 -- Warning: unused pattern binding + (_, _) = rhs4 -- Warning: unused pattern binding + _ = rhs3 -- No warning: lone wild-card pattern + !() = rhs4 -- No warning: banged pattern; behaves like seq + + Test cases: rename/{T13646,T17c,T17e,T7085} + -} + TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage + + {-| TcRnUnusedQuantifiedTypeVar is a warning that occurs if there are unused + quantified type variables. + + Examples: + f :: forall a. Int -> Char + + Test cases: rename/should_compile/ExplicitForAllRules1 + rename/should_compile/T5331 + -} + TcRnUnusedQuantifiedTypeVar + :: HsDocContext + -> HsTyVarBndrExistentialFlag -- ^ tyVar binder. + -> TcRnMessage + + {-| TcRnDodgyImports is a group of warnings (controlled with -Wdodgy-imports). + + See 'DodgyImportsReason' for the different warnings. + -} + TcRnDodgyImports :: !DodgyImportsReason -> TcRnMessage + {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when + an export of the form 'T(..)' for a type constructor 'T' does not actually export anything + beside 'T' itself. + + Example: + module Foo ( + T(..) -- Warning: T is a type synonym + , A(..) -- Warning: A is a type family + , C(..) -- Warning: C is a data family + ) where + + type T = Int + type family A :: * -> * + data family C :: * -> * + + Test cases: warnings/should_compile/DodgyExports01 + -} + TcRnDodgyExports :: GlobalRdrElt -> TcRnMessage + {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when + an import declaration does not explicitly list all the names brought into scope. + + Test cases: rename/should_compile/T4489 + -} + TcRnMissingImportList :: IE GhcPs -> TcRnMessage + {-| When a module marked trustworthy or unsafe (using -XTrustworthy or -XUnsafe) is compiled + with a plugin, the TcRnUnsafeDueToPlugin warning (controlled by -Wunsafe) is used as the + reason the module was inferred to be unsafe. This warning is not raised if the + -fplugin-trustworthy flag is passed. + + Test cases: plugins/T19926 + -} + TcRnUnsafeDueToPlugin :: TcRnMessage + {-| TcRnModMissingRealSrcSpan is an error that occurs when compiling a module that lacks + an associated 'RealSrcSpan'. + + Test cases: None + -} + TcRnModMissingRealSrcSpan :: Module -> TcRnMessage + {-| TcRnIdNotExportedFromModuleSig is an error pertaining to backpack that occurs + when an identifier required by a signature is not exported by the module + or signature that is being used as a substitution for that signature. + + Example(s): None + + Test cases: backpack/should_fail/bkpfail36 + -} + TcRnIdNotExportedFromModuleSig :: Name -> Module -> TcRnMessage + {-| TcRnIdNotExportedFromLocalSig is an error pertaining to backpack that + occurs when an identifier which is necessary for implementing a module + signature is not exported from that signature. + + Example(s): None + + Test cases: backpack/should_fail/bkpfail30 + backpack/should_fail/bkpfail31 + backpack/should_fail/bkpfail34 + -} + TcRnIdNotExportedFromLocalSig :: Name -> TcRnMessage + + {-| TcRnShadowedName is a warning (controlled by -Wname-shadowing) that occurs whenever + an inner-scope value has the same name as an outer-scope value, i.e. the inner + value shadows the outer one. This can catch typographical errors that turn into + hard-to-find bugs. The warning is suppressed for names beginning with an underscore. + + Examples(s): + f = ... let f = id in ... f ... -- NOT OK, 'f' is shadowed + f x = do { _ignore <- this; _ignore <- that; return (the other) } -- suppressed via underscore + + Test cases: typecheck/should_compile/T10971a + rename/should_compile/rn039 + rename/should_compile/rn064 + rename/should_compile/T1972 + rename/should_fail/T2723 + rename/should_compile/T3262 + driver/werror + rename/should_fail/T22478d + typecheck/should_fail/TyAppPat_ScopedTyVarConflict + -} + TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage + + {-| TcRnInvalidWarningCategory is an error that occurs when a warning is declared + with a category name that is not the special category "deprecations", and + either does not begin with the prefix "x-" indicating a user-defined + category, or contains characters not valid in category names. See Note + [Warning categories] in GHC.Unit.Module.Warnings + + Examples(s): + module M {-# WARNING in "invalid" "Oops" #-} where + + {-# WARNING in "x- spaces not allowed" foo "Oops" #-} + + Test cases: warnings/should_fail/WarningCategoryInvalid + -} + TcRnInvalidWarningCategory :: !WarningCategory -> TcRnMessage + + {-| TcRnDuplicateWarningDecls is an error that occurs whenever + a warning is declared twice. + + Examples(s): + {-# DEPRECATED foo "Don't use me" #-} + {-# DEPRECATED foo "Don't use me" #-} + foo :: Int + foo = 2 + + Test cases: + rename/should_fail/rnfail058 + -} + TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage + + {-| TcRnSimplifierTooManyIterations is an error that occurs whenever + the constraint solver in the simplifier hits the iterations' limit. + + Examples(s): + None. + + Test cases: + None. + -} + TcRnSimplifierTooManyIterations :: Cts + -> !IntWithInf + -- ^ The limit. + -> WantedConstraints + -> TcRnMessage + + {-| TcRnIllegalPatSynDecl is an error that occurs whenever + there is an illegal pattern synonym declaration. + + Examples(s): + + varWithLocalPatSyn x = case x of + P -> () + where + pattern P = () -- not valid, it can't be local, it must be defined at top-level. + + Test cases: patsyn/should_fail/local + -} + TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage + + {-| TcRnLinearPatSyn is an error that occurs whenever a pattern + synonym signature uses a field that is not unrestricted. + + Example(s): None + + Test cases: linear/should_fail/LinearPatSyn2 + -} + TcRnLinearPatSyn :: !Type -> TcRnMessage + + {-| TcRnEmptyRecordUpdate is an error that occurs whenever + a record is updated without specifying any field. + + Examples(s): + + $(deriveJSON defaultOptions{} ''Bad) -- not ok, no fields selected for update of defaultOptions + + Test cases: th/T12788 + -} + TcRnEmptyRecordUpdate :: TcRnMessage + + {-| TcRnIllegalFieldPunning is an error that occurs whenever + field punning is used without the 'NamedFieldPuns' extension enabled. + + Examples(s): + + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo Foo{a} = a -- Not ok, punning used without extension. + + Test cases: parser/should_fail/RecordDotSyntaxFail12 + -} + TcRnIllegalFieldPunning :: !(Located RdrName) -> TcRnMessage + + {-| TcRnIllegalWildcardsInRecord is an error that occurs whenever + wildcards (..) are used in a record without the relevant + extension being enabled. + + Examples(s): + + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo Foo{..} = a -- Not ok, wildcards used without extension. + + Test cases: parser/should_fail/RecordWildCardsFail + -} + TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage + + {-| TcRnIllegalWildcardInType is an error that occurs + when a wildcard appears in a type in a location in which + wildcards aren't allowed. + + Examples: + + Type synonyms: + + type T = _ + + Class declarations and instances: + + class C _ + instance C _ + + Standalone kind signatures: + + type D :: _ + data D + + Test cases: + ExtraConstraintsWildcardInTypeSplice2 + ExtraConstraintsWildcardInTypeSpliceUsed + ExtraConstraintsWildcardNotLast + ExtraConstraintsWildcardTwice + NestedExtraConstraintsWildcard + NestedNamedExtraConstraintsWildcard + PartialClassMethodSignature + PartialClassMethodSignature2 + T12039 + T13324_fail1 + UnnamedConstraintWildcard1 + UnnamedConstraintWildcard2 + WildcardInADT1 + WildcardInADT2 + WildcardInADT3 + WildcardInADTContext1 + WildcardInDefault + WildcardInDefaultSignature + WildcardInDeriving + WildcardInForeignExport + WildcardInForeignImport + WildcardInGADT1 + WildcardInGADT2 + WildcardInInstanceHead + WildcardInInstanceSig + WildcardInNewtype + WildcardInPatSynSig + WildcardInStandaloneDeriving + WildcardInTypeFamilyInstanceRHS + WildcardInTypeSynonymRHS + saks_fail003 + T15433a + -} + TcRnIllegalWildcardInType + :: Maybe Name + -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard + -> !BadAnonWildcardContext + -> TcRnMessage + + {-| TcRnIllegalNamedWildcardInTypeArgument is an error that occurs + when a named wildcard is used in a required type argument. + + Example: + + vfun :: forall (a :: k) -> () + x = vfun _nwc + -- ^^^^ + -- named wildcards not allowed in type arguments + + Test cases: + T23738_fail_wild + -} + TcRnIllegalNamedWildcardInTypeArgument + :: RdrName + -> TcRnMessage + + {- TcRnIllegalImplicitTyVarInTypeArgument is an error raised + when a type variable is implicitly quantified in a required type argument. + + Example: + vfun :: forall (a :: k) -> () + x = vfun (Nothing :: Maybe a) + -- ^^^ + -- implicit quantification not allowed in type arguments + + -} + TcRnIllegalImplicitTyVarInTypeArgument + :: RdrName + -> TcRnMessage + + {- TcRnIllegalPunnedVarOccInTypeArgument is an error raised + when a punned variable occurs in a required type argument. + + Example: + vfun :: forall (a :: k) -> () + f (Just @a a) = vfun a + -- ^^^ + -- which `a` is referenced? + -} + TcRnIllegalPunnedVarOccInTypeArgument + :: { illegalPunTermName :: !ResolvedNameInfo -- ^ How the variable was actually resolved (term namespace) + , illegalPunTypeName :: !ResolvedNameInfo -- ^ How the variable could have been resolved (type namespace) + } -> TcRnMessage + + {-| TcRnDuplicateFieldName is an error that occurs whenever + there are duplicate field names in a single record. + + Examples(s): + + data R = MkR { x :: Int, x :: Bool } + f r = r { x = 3, x = 4 } + + Test cases: T21959. + -} + TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage + + {-| TcRnIllegalViewPattern is an error that occurs whenever + the ViewPatterns syntax is used but the ViewPatterns language extension + is not enabled. + + Examples(s): + data Foo = Foo { a :: Int } + + foo :: Foo -> Int + foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled. + + Test cases: parser/should_fail/ViewPatternsFail + -} + TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage + + {-| TcRnCharLiteralOutOfRange is an error that occurs whenever + a character is out of range. + + Examples(s): None + + Test cases: None + -} + TcRnCharLiteralOutOfRange :: !Char -> TcRnMessage + + {-| TcRnNegativeNumTypeLiteral is an error that occurs whenever + a type-level number literal is negative. + + type Neg = -1 + + Test cases: th/T8412 + typecheck/should_fail/T8306 + -} + TcRnNegativeNumTypeLiteral :: HsTyLit GhcPs -> TcRnMessage + + {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever + the record wildcards '..' are used inside a constructor without labeled fields. + + Examples(s): None + + Test cases: + rename/should_fail/T9815.hs + rename/should_fail/T9815b.hs + rename/should_fail/T9815ghci.hs + rename/should_fail/T9815bghci.hs + -} + TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage + + {-| TcRnIgnoringAnnotations is a warning that occurs when the source code + contains annotation pragmas but the platform in use does not support an + external interpreter such as GHCi and therefore the annotations are ignored. + + Example(s): None + + Test cases: None + -} + TcRnIgnoringAnnotations :: [LAnnDecl GhcRn] -> TcRnMessage + + {-| TcRnAnnotationInSafeHaskell is an error that occurs if annotation pragmas + are used in conjunction with Safe Haskell. + + Example(s): None + + Test cases: annotations/should_fail/T10826 + -} + TcRnAnnotationInSafeHaskell :: TcRnMessage + + {-| TcRnInvalidTypeApplication is an error that occurs when a visible type application + is used with an expression that does not accept "specified" type arguments. + + Example(s): + foo :: forall {a}. a -> a + foo x = x + bar :: () + bar = let x = foo @Int 42 + in () + + Test cases: overloadedrecflds/should_fail/overloadedlabelsfail03 + typecheck/should_fail/ExplicitSpecificity1 + typecheck/should_fail/ExplicitSpecificity10 + typecheck/should_fail/ExplicitSpecificity2 + typecheck/should_fail/T17173 + typecheck/should_fail/VtaFail + -} + TcRnInvalidTypeApplication :: Type -> LHsWcType GhcRn -> TcRnMessage + + {-| TcRnTagToEnumMissingValArg is an error that occurs when the 'tagToEnum#' + function is not applied to a single value argument. + + Example(s): + tagToEnum# 1 2 + + Test cases: None + -} + TcRnTagToEnumMissingValArg :: TcRnMessage + + {-| TcRnTagToEnumUnspecifiedResTy is an error that occurs when the 'tagToEnum#' + function is not given a concrete result type. + + Example(s): + foo :: forall a. a + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumUnspecifiedResTy :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyNotAnEnum is an error that occurs when the 'tagToEnum#' + function is given a result type that is not an enumeration type. + + Example(s): + foo :: Int -- not an enumeration TyCon + foo = tagToEnum# 0# + + Test cases: typecheck/should_fail/tcfail164 + -} + TcRnTagToEnumResTyNotAnEnum :: Type -> TcRnMessage + + {-| TcRnTagToEnumResTyTypeData is an error that occurs when the 'tagToEnum#' + function is given a result type that is headed by a @type data@ type, as + the data constructors of a @type data@ do not exist at the term level. + + Example(s): + type data Letter = A | B | C + + foo :: Letter + foo = tagToEnum# 0# + + Test cases: type-data/should_fail/TDTagToEnum.hs + -} + TcRnTagToEnumResTyTypeData :: Type -> TcRnMessage + + {-| TcRnArrowIfThenElsePredDependsOnResultTy is an error that occurs when the + predicate type of an ifThenElse expression in arrow notation depends on + the type of the result. + + Example(s): None + + Test cases: None + -} + TcRnArrowIfThenElsePredDependsOnResultTy :: TcRnMessage + + {-| TcRnIllegalHsBootOrSigDecl is an error that occurs when an hs-boot file + contains declarations that are not allowed, such as bindings. + + Examples: + + -- A.hs-boot + f :: Int -> Int + f x = 2 * x -- binding not allowed + + -- B.hs-boot + type family F a where { F Int = Bool } + -- type family equations not allowed + + -- C.hsig + bar :: Int -> Int + {-# RULES forall x. bar x = x #-} -- RULES not allowed + + + Test cases: + + - bindings: T19781 + - class instance body: none + - type family instance: HsBootFam + - splice: none + - foreign declaration: none + - default declaration: none + - RULEs: none + -} + TcRnIllegalHsBootOrSigDecl :: !HsBootOrSig -> !BadBootDecls -> TcRnMessage + + {-| TcRnBootMismatch is a family of errors that occur when there is a + mismatch between the hs-boot and hs files. + + Examples: + + -- A.hs-boot + foo :: Int -> Bool + data D = MkD + + -- A.hs + foo :: Int -> Char + foo = chr + + data D = MkD Int + + Test cases: + + - missing export: bkpcabal06, bkpfail{01,05,09,16,35}, rnfail{047,055} + - missing definition: none + - missing instance: T14075 + - mismatch in exports: bkpfail{03,19} + - conflicting definitions: bkpcabal02, + bkpfail{04,06,07,10,12,133,14,15,17,22,23,25,26,27,41,42,45,47,50,52,53,54}, + T19244{a,b}, T23344, ClosedFam3, rnfail055 + -} + TcRnBootMismatch :: !HsBootOrSig -> !BootMismatch -> TcRnMessage + + {-| TcRnRecursivePatternSynonym is an error that occurs when a pattern synonym + is defined in terms of itself, either directly or indirectly. + + Example(s): + pattern A = B + pattern B = A + + Test cases: patsyn/should_fail/T16900 + -} + TcRnRecursivePatternSynonym :: LHsBinds GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigTyVarMismatch is an error that occurs when a partial type signature + attempts to unify two different types. + + Example(s): + f :: a -> b -> _ + f x y = [x, y] + + Test cases: partial-sigs/should_fail/T14449 + -} + TcRnPartialTypeSigTyVarMismatch + :: Name -- ^ first type variable + -> Name -- ^ second type variable + -> Name -- ^ function name + -> LHsSigWcType GhcRn -> TcRnMessage + + {-| TcRnPartialTypeSigBadQuantifier is an error that occurs when a type variable + being quantified over in the partial type signature of a function gets unified + with a type that is free in that function's context. + + Example(s): + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + Test cases: partial-sig/should_fail/T14479 + -} + TcRnPartialTypeSigBadQuantifier + :: Name -- ^ user-written name of type variable being quantified + -> Name -- ^ function name + -> Maybe Type -- ^ type the variable unified with, if known + -> LHsSigWcType GhcRn -- ^ partial type signature + -> TcRnMessage + + {-| TcRnMissingSignature is a warning that occurs when a top-level binding + or a pattern synonym does not have a type signature. + + Controlled by the flags: + -Wmissing-signatures + -Wmissing-exported-signatures + -Wmissing-pattern-synonym-signatures + -Wmissing-exported-pattern-synonym-signatures + -Wmissing-kind-signatures + -Wmissing-poly-kind-signatures + + Test cases: + T11077 (top-level bindings) + T12484 (pattern synonyms) + T19564 (kind signatures) + -} + TcRnMissingSignature :: MissingSignature + -> Exported + -> TcRnMessage + + {-| TcRnPolymorphicBinderMissingSig is a warning controlled by -Wmissing-local-signatures + that occurs when a local polymorphic binding lacks a type signature. + + Example(s): + id a = a + + Test cases: warnings/should_compile/T12574 + -} + TcRnPolymorphicBinderMissingSig :: Name -> Type -> TcRnMessage + + {-| TcRnOverloadedSig is an error that occurs when a binding group conflicts + with the monomorphism restriction. + + Example(s): + data T a = T a + mono = ... where + x :: Applicative f => f a + T x = ... + + Test cases: typecheck/should_compile/T11339 + -} + TcRnOverloadedSig :: TcIdSig -> TcRnMessage + + {-| TcRnTupleConstraintInst is an error that occurs whenever an instance + for a tuple constraint is specified. + + Examples(s): + class C m a + class D m a + f :: (forall a. Eq a => (C m a, D m a)) => m a + f = undefined + + Test cases: quantified-constraints/T15334 + -} + TcRnTupleConstraintInst :: !Class -> TcRnMessage + + {-| TcRnUserTypeError is an error that occurs due to a user's custom type error, + which can be triggered by adding a `TypeError` constraint in a type signature + or typeclass instance. + + Examples(s): + f :: TypeError (Text "This is a type error") + f = undefined + + Test cases: typecheck/should_fail/CustomTypeErrors02 + typecheck/should_fail/CustomTypeErrors03 + -} + TcRnUserTypeError :: !Type -> TcRnMessage + + {-| TcRnConstraintInKind is an error that occurs whenever a constraint is specified + in a kind. + + Examples(s): + data Q :: Eq a => Type where {} + + Test cases: dependent/should_fail/T13895 + polykinds/T16263 + saks/should_fail/saks_fail004 + typecheck/should_fail/T16059a + typecheck/should_fail/T18714 + -} + TcRnConstraintInKind :: !Type -> TcRnMessage + + {-| TcRnUnboxedTupleTypeFuncArg is an error that occurs whenever an unboxed tuple + or unboxed sum type is specified as a function argument, when the appropriate + extension (`-XUnboxedTuples` or `-XUnboxedSums`) isn't enabled. + + Examples(s): + -- T15073.hs + import T15073a + newtype Foo a = MkFoo a + deriving P + + -- T15073a.hs + class P a where + p :: a -> (# a #) + + Test cases: deriving/should_fail/T15073.hs + deriving/should_fail/T15073a.hs + typecheck/should_fail/T16059d + -} + TcRnUnboxedTupleOrSumTypeFuncArg + :: UnboxedTupleOrSum -- ^ whether this is an unboxed tuple or an unboxed sum + -> !Type + -> TcRnMessage + + {-| TcRnLinearFuncInKind is an error that occurs whenever a linear function is + specified in a kind. + + Examples(s): + data A :: * %1 -> * + + Test cases: linear/should_fail/LinearKind + linear/should_fail/LinearKind2 + linear/should_fail/LinearKind3 + -} + TcRnLinearFuncInKind :: !Type -> TcRnMessage + + {-| TcRnForAllEscapeError is an error that occurs whenever a quantified type's kind + mentions quantified type variable. + + Examples(s): + type T :: TYPE (BoxedRep l) + data T = MkT + + Test cases: unlifted-datatypes/should_fail/UnlDataNullaryPoly + -} + TcRnForAllEscapeError :: !Type -> !Kind -> TcRnMessage + + {-| TcRnVDQInTermType is an error that occurs whenever a visible dependent quantification + is specified in the type of a term. + + Examples(s): + a = (undefined :: forall k -> k -> Type) @Int + + Test cases: dependent/should_fail/T15859 + dependent/should_fail/T16326_Fail1 + dependent/should_fail/T16326_Fail2 + dependent/should_fail/T16326_Fail3 + dependent/should_fail/T16326_Fail4 + dependent/should_fail/T16326_Fail5 + dependent/should_fail/T16326_Fail6 + dependent/should_fail/T16326_Fail7 + dependent/should_fail/T16326_Fail8 + dependent/should_fail/T16326_Fail9 + dependent/should_fail/T16326_Fail10 + dependent/should_fail/T16326_Fail11 + dependent/should_fail/T16326_Fail12 + dependent/should_fail/T17687 + dependent/should_fail/T18271 + -} + TcRnVDQInTermType :: !(Maybe Type) -> TcRnMessage + + {-| TcRnBadQuantPredHead is an error that occurs whenever a quantified predicate + lacks a class or type variable head. + + Examples(s): + class (forall a. A t a => A t [a]) => B t where + type A t a :: Constraint + + Test cases: quantified-constraints/T16474 + -} + TcRnBadQuantPredHead :: !Type -> TcRnMessage + + {-| TcRnIllegalTupleConstraint is an error that occurs whenever an illegal tuple + constraint is specified. + + Examples(s): + g :: ((Show a, Num a), Eq a) => a -> a + g = undefined + + Test cases: typecheck/should_fail/tcfail209a + -} + TcRnIllegalTupleConstraint :: !Type -> TcRnMessage + + {-| TcRnNonTypeVarArgInConstraint is an error that occurs whenever a non type-variable + argument is specified in a constraint. + + Examples(s): + data T + instance Eq Int => Eq T + + Test cases: ghci/scripts/T13202 + ghci/scripts/T13202a + polykinds/T12055a + typecheck/should_fail/T10351 + typecheck/should_fail/T19187 + typecheck/should_fail/T6022 + typecheck/should_fail/T8883 + -} + TcRnNonTypeVarArgInConstraint :: !Type -> TcRnMessage + + {-| TcRnIllegalImplicitParam is an error that occurs whenever an illegal implicit + parameter is specified. + + Examples(s): + type Bla = ?x::Int + data T = T + instance Bla => Eq T + + Test cases: polykinds/T11466 + typecheck/should_fail/T8912 + typecheck/should_fail/tcfail041 + typecheck/should_fail/tcfail211 + typecheck/should_fail/tcrun045 + -} + TcRnIllegalImplicitParam :: !Type -> TcRnMessage + + {-| TcRnIllegalConstraintSynonymOfKind is an error that occurs whenever an illegal constraint + synonym of kind is specified. + + Examples(s): + type Showish = Show + f :: (Showish a) => a -> a + f = undefined + + Test cases: typecheck/should_fail/tcfail209 + -} + TcRnIllegalConstraintSynonymOfKind :: !Type -> TcRnMessage + + {-| TcRnOversaturatedVisibleKindArg is an error that occurs whenever an illegal oversaturated + visible kind argument is specified. + + Examples(s): + type family + F2 :: forall (a :: Type). Type where + F2 @a = Maybe a + + Test cases: typecheck/should_fail/T15793 + typecheck/should_fail/T16255 + -} + TcRnOversaturatedVisibleKindArg :: !Type -> TcRnMessage + + {-| TcRnForAllRankErr is an error that occurs whenever an illegal ranked type + is specified. + + Examples(s): + foo :: (a,b) -> (a~b => t) -> (a,b) + foo p x = p + + Test cases: + - ghci/should_run/T15806 + - indexed-types/should_fail/SimpleFail15 + - typecheck/should_fail/T11355 + - typecheck/should_fail/T12083a + - typecheck/should_fail/T12083b + - typecheck/should_fail/T16059c + - typecheck/should_fail/T16059e + - typecheck/should_fail/T17213 + - typecheck/should_fail/T18939_Fail + - typecheck/should_fail/T2538 + - typecheck/should_fail/T5957 + - typecheck/should_fail/T7019 + - typecheck/should_fail/T7019a + - typecheck/should_fail/T7809 + - typecheck/should_fail/T9196 + - typecheck/should_fail/tcfail127 + - typecheck/should_fail/tcfail184 + - typecheck/should_fail/tcfail196 + - typecheck/should_fail/tcfail197 + -} + TcRnForAllRankErr :: !Rank -> !Type -> TcRnMessage + + {-| TcRnSimplifiableConstraint is a warning triggered by the occurrence of + a simplifiable constraint in a context, when MonoLocalBinds is not enabled. + + Examples(s): + simplifiableEq :: Eq (a, a) => a -> a -> Bool + simplifiableEq = undefined + + Test cases: + - indexed-types/should_compile/T15322 + - partial-sigs/should_compile/SomethingShowable + - typecheck/should_compile/T13526 + -} + TcRnSimplifiableConstraint :: !PredType -> !InstanceWhat -> TcRnMessage + + {-| TcRnArityMismatch is an error that occurs when a type constructor is supplied with + fewer arguments than required. + + Examples(s): + f Left = undefined + + Test cases: + - backpack/should_fail/bkpfail25.bkp + - ghci/should_fail/T16013 + - ghci/should_fail/T16287 + - indexed-types/should_fail/BadSock + - indexed-types/should_fail/T9433 + - module/mod60 + - ndexed-types/should_fail/T2157 + - parser/should_fail/ParserNoBinaryLiterals2 + - parser/should_fail/ParserNoBinaryLiterals3 + - patsyn/should_fail/T12819 + - polykinds/T10516 + - typecheck/should_fail/T12124 + - typecheck/should_fail/T15954 + - typecheck/should_fail/T16874 + - typecheck/should_fail/tcfail100 + - typecheck/should_fail/tcfail101 + - typecheck/should_fail/tcfail107 + - typecheck/should_fail/tcfail129 + - typecheck/should_fail/tcfail187 + -} + TcRnArityMismatch :: !TyThing + -> !Arity -- ^ expected arity + -> !Arity -- ^ actual arity + -> TcRnMessage + + {-| TcRnIllegalClassInstance is a collection of diagnostics that arise + from an invalid class or family instance declaration. + + See t'IllegalInstanceReason'. + -} + TcRnIllegalInstance :: IllegalInstanceReason -> TcRnMessage + + {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction) + that arises when the monomorphism restriction applies to the given bindings. + + Examples(s): + {-# OPTIONS_GHC -Wmonomorphism-restriction #-} + + bar = 10 + + foo :: Int + foo = bar + + main :: IO () + main = print foo + + The example above emits the warning (for 'bar'), because without monomorphism + restriction the inferred type for 'bar' is 'bar :: Num p => p'. This warning tells us + that /if/ we were to enable '-XMonomorphismRestriction' we would make 'bar' + less polymorphic, as its type would become 'bar :: Int', so GHC warns us about that. + + Test cases: typecheck/should_compile/T13785 + -} + TcRnMonomorphicBindings :: [Name] -> TcRnMessage + + {-| TcRnOrphanInstance is a warning (controlled by -Worphans) that arises when + a typeclass instance or family instance is an \"orphan\", i.e. if it + appears in a module in which neither the class/family nor the type being + instanced are declared in the same module. + + Examples(s): None + + Test cases: warnings/should_compile/T9178 + typecheck/should_compile/T4912 + -} + TcRnOrphanInstance :: Either ClsInst FamInst -> TcRnMessage + + {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies + conflicts between instance declarations. + + Examples(s): None + + Test cases: typecheck/should_fail/T2307 + typecheck/should_fail/tcfail096 + typecheck/should_fail/tcfail202 + -} + TcRnFunDepConflict :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage + + {-| TcRnDupInstanceDecls is an error that occurs when there are duplicate instance + declarations. + + Examples(s): + class Foo a where + foo :: a -> Int + + instance Foo Int where + foo = id + + instance Foo Int where + foo = const 42 + + Test cases: cabal/T12733/T12733 + typecheck/should_fail/tcfail035 + typecheck/should_fail/tcfail023 + backpack/should_fail/bkpfail18 + typecheck/should_fail/TcNullaryTCFail + typecheck/should_fail/tcfail036 + typecheck/should_fail/tcfail073 + module/mod51 + module/mod52 + module/mod44 + -} + TcRnDupInstanceDecls :: !UnitState -> NE.NonEmpty ClsInst -> TcRnMessage + + {-| TcRnConflictingFamInstDecls is an error that occurs when there are conflicting + family instance declarations. + + Examples(s): None. + + Test cases: indexed-types/should_fail/ExplicitForAllFams4b + indexed-types/should_fail/NoGood + indexed-types/should_fail/Over + indexed-types/should_fail/OverDirectThisMod + indexed-types/should_fail/OverIndirectThisMod + indexed-types/should_fail/SimpleFail11a + indexed-types/should_fail/SimpleFail11b + indexed-types/should_fail/SimpleFail11c + indexed-types/should_fail/SimpleFail11d + indexed-types/should_fail/SimpleFail2a + indexed-types/should_fail/SimpleFail2b + indexed-types/should_fail/T13092/T13092 + indexed-types/should_fail/T13092c/T13092c + indexed-types/should_fail/T14179 + indexed-types/should_fail/T2334A + indexed-types/should_fail/T2677 + indexed-types/should_fail/T3330b + indexed-types/should_fail/T4246 + indexed-types/should_fail/T7102a + indexed-types/should_fail/T9371 + polykinds/T7524 + typecheck/should_fail/UnliftedNewtypesOverlap + -} + TcRnConflictingFamInstDecls :: NE.NonEmpty FamInst -> TcRnMessage + + {-| TcRnFamInstNotInjective is a collection of errors that arise from + a type family equation violating the injectivity annotation. + + See 'InjectivityErrReason'. + -} + TcRnFamInstNotInjective :: InjectivityErrReason -- ^ the violation + -> TyCon -- ^ the family 'TyCon' + -> NE.NonEmpty CoAxBranch -- ^ the family equations + -> TcRnMessage + + {-| TcRnBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that + occurs when a strictness annotation is applied to an unlifted type. + + Example(s): + data T = MkT !Int# -- Strictness flag has no effect on unlifted types + + Test cases: typecheck/should_compile/T20187a + typecheck/should_compile/T20187b + -} + TcRnBangOnUnliftedType :: !Type -> TcRnMessage + + {-| TcRnLazyBangOnUnliftedType is a warning (controlled by -Wredundant-strictness-flags) that + occurs when a lazy annotation is applied to an unlifted type. + + Example(s): + data T = MkT ~Int# -- Lazy flag has no effect on unlifted types + + Test cases: typecheck/should_compile/T21951a + typecheck/should_compile/T21951b + -} + TcRnLazyBangOnUnliftedType :: !Type -> TcRnMessage + + {-| TcRnMultipleDefaultDeclarations is an error that occurs when a module has + more than one default declaration for the same class. + + Example: + default (Integer, Int) -- implicitly applies to Num + default (Double, Float) -- 2nd default declaration not allowed + + Text cases: module/mod58 + -} + TcRnMultipleDefaultDeclarations :: Class -> ClassDefaults -> TcRnMessage + + {-| TcRnWarnClashingDefaultImports is a warning that occurs when a module imports + more than one default declaration for the same class, and they are not all + subsumed by one of them nor by a local `default` declaration. + + See Note [Named default declarations] in GHC.Tc.Gen.Default + + Test cases: default/Import07.hs + -} + TcRnWarnClashingDefaultImports :: Class + -> Maybe [Type] -- ^ locally declared defaults + -> NE.NonEmpty ClassDefaults -- ^ imported defaults + -> TcRnMessage + + {-| TcRnBadDefaultType is an error that occurs when a type used in a default + declaration does not have an instance for any of the applicable classes. + + Example(s): + data Foo + default (Foo) + + Test cases: typecheck/should_fail/T11974b + -} + TcRnBadDefaultType :: LHsType GhcRn -> NonEmpty Class -> TcRnMessage + + {-| TcRnPatSynBundledWithNonDataCon is an error that occurs when a module's + export list bundles a pattern synonym with a type that is not a proper + `data` or `newtype` construction. + + Example(s): + module Foo (MyClass(.., P)) where + pattern P = Nothing + class MyClass a where + foo :: a -> Int + + Test cases: patsyn/should_fail/export-class + -} + TcRnPatSynBundledWithNonDataCon :: TcRnMessage + + {-| TcRnPatSynBundledWithWrongType is an error that occurs when the export list + of a module has a pattern synonym bundled with a type that does not match + the type of the pattern synonym. + + Example(s): + module Foo (R(P,x)) where + data Q = Q Int + data R = R + pattern P{x} = Q x + + Text cases: patsyn/should_fail/export-ps-rec-sel + patsyn/should_fail/export-type-synonym + patsyn/should_fail/export-type + -} + TcRnPatSynBundledWithWrongType :: Type -> Type -> TcRnMessage + + {-| TcRnDupeModuleExport is a warning controlled by @-Wduplicate-exports@ that + occurs when a module appears more than once in an export list. + + Example(s): + module Foo (module Bar, module Bar) + import Bar + + Text cases: None + -} + TcRnDupeModuleExport :: ModuleName -> TcRnMessage + + {-| TcRnExportedModNotImported is an error that occurs when an export list + contains a module that is not imported. + + Example(s): None + + Text cases: module/mod135 + module/mod8 + rename/should_fail/rnfail028 + backpack/should_fail/bkpfail48 + -} + TcRnExportedModNotImported :: ModuleName -> TcRnMessage + + {-| TcRnNullExportedModule is a warning controlled by -Wdodgy-exports that occurs + when an export list contains a module that has no exports. + + Example(s): + module Foo (module Bar) where + import Bar () + + Test cases: None + -} + TcRnNullExportedModule :: ModuleName -> TcRnMessage + + {-| TcRnMissingExportList is a warning controlled by -Wmissing-export-lists that + occurs when a module does not have an explicit export list. + + Example(s): None + + Test cases: typecheck/should_fail/MissingExportList03 + -} + TcRnMissingExportList :: ModuleName -> TcRnMessage + + {-| TcRnExportHiddenComponents is an error that occurs when an export contains + constructor or class methods that are not visible. + + Example(s): None + + Test cases: None + -} + TcRnExportHiddenComponents :: IE GhcPs -> TcRnMessage + + {-| TcRnExportHiddenDefault is an error that occurs when an export contains + a class default (with language extension NamedDefaults) that is not visible. + + Example(s): None + + Test cases: default/fail06.hs + -} + TcRnExportHiddenDefault :: IE GhcPs -> TcRnMessage + + {-| TcRnDuplicateExport is a warning (controlled by -Wduplicate-exports) that occurs + when an identifier appears in an export list more than once. + + Example(s): None + + Test cases: module/MultiExport + module/mod128 + module/mod14 + module/mod5 + overloadedrecflds/should_fail/DuplicateExports + patsyn/should_compile/T11959 + -} + TcRnDuplicateExport :: GlobalRdrElt -> IE GhcPs -> IE GhcPs -> TcRnMessage + + {-| TcRnDuplicateNamedDefaultExport is a warning (controlled by -Wduplicate-exports) + that occurs when a named default declaration appears in an export list + more than once. + + -} + TcRnDuplicateNamedDefaultExport :: TyCon -> IE GhcPs -> IE GhcPs -> TcRnMessage + + {-| TcRnExportedParentChildMismatch is an error that occurs when an export is + bundled with a parent that it does not belong to + + Example(s): + module Foo (T(a)) where + data T + a = True + + Test cases: module/T11970 + module/T11970B + module/mod17 + module/mod3 + overloadedrecflds/should_fail/NoParent + -} + TcRnExportedParentChildMismatch :: Name -- ^ parent + -> TyThing + -> Name -- ^ child + -> [Name] -> TcRnMessage + + {-| TcRnConflictingExports is an error that occurs when different identifiers that + have the same name are being exported by a module. + + Example(s): + module Foo (Bar.f, module Baz) where + import qualified Bar (f) + import Baz (f) + + Test cases: module/mod131 + module/mod142 + module/mod143 + module/mod144 + module/mod145 + module/mod146 + module/mod150 + module/mod155 + overloadedrecflds/should_fail/T14953 + overloadedrecflds/should_fail/overloadedrecfldsfail10 + rename/should_fail/rnfail029 + rename/should_fail/rnfail040 + typecheck/should_fail/T16453E2 + typecheck/should_fail/tcfail025 + typecheck/should_fail/tcfail026 + -} + TcRnConflictingExports + :: OccName -- ^ Occurrence name shared by both exports + -> GlobalRdrElt -- ^ First export + -> IE GhcPs -- ^ Export decl of first export + -> GlobalRdrElt -- ^ Second export + -> IE GhcPs -- ^ Export decl of second export + -> TcRnMessage + + {-| TcRnDuplicateFieldExport is an error that occurs when a module exports + multiple record fields with the same name, without enabling + DuplicateRecordFields. + + Example: + + module M1 where + data D1 = MkD1 { foo :: Int } + module M2 where + data D2 = MkD2 { foo :: Int } + module M ( D1(..), D2(..) ) where + import module M1 + import module M2 + + Test case: overloadedrecflds/should_fail/overloadedrecfldsfail10 + -} + TcRnDuplicateFieldExport + :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (GlobalRdrElt, IE GhcPs) + -> TcRnMessage + + {-| TcRnAmbiguousRecordUpdate is a warning, controlled by -Wambiguous-fields, + which occurs when a user relies on the type-directed disambiguation + mechanism to disambiguate a record update. This will not be supported by + -XDuplicateRecordFields in future releases. + + Example(s): + + data Person = MkPerson { personId :: Int, name :: String } + data Address = MkAddress { personId :: Int, address :: String } + bad1 x = x { personId = 4 } :: Person -- ambiguous + bad2 (x :: Person) = x { personId = 4 } -- ambiguous + good x = (x :: Person) { personId = 4 } -- not ambiguous + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail06 + -} + TcRnAmbiguousRecordUpdate + :: HsExpr GhcRn -- ^ Field update + -> TyCon -- ^ Record type + -> TcRnMessage + + {-| TcRnMissingFields is a warning controlled by -Wmissing-fields occurring + when the intialisation of a record is missing one or more (lazy) fields. + + Example(s): + data Rec = Rec { a :: Int, b :: String, c :: Bool } + x = Rec { a = 1, b = "two" } -- missing field 'c' + + Test cases: deSugar/should_compile/T13870 + deSugar/should_compile/ds041 + patsyn/should_compile/T11283 + rename/should_compile/T5334 + rename/should_compile/T12229 + rename/should_compile/T5892a + warnings/should_fail/WerrorFail2 + -} + TcRnMissingFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {-| TcRnFieldUpdateInvalidType is an error occurring when an updated field's + type mentions something that is outside the universally quantified variables + of the data constructor, such as an existentially quantified type. + + Example(s): + data X = forall a. MkX { f :: a } + x = (MkX ()) { f = False } + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3323 + -} + TcRnFieldUpdateInvalidType :: [(FieldLabelString,TcType)] -> TcRnMessage + + {-| TcRnMissingStrictFields is an error occurring when a record field marked + as strict is omitted when constructing said record. + + Example(s): + data R = R { strictField :: !Bool, nonStrict :: Int } + x = R { nonStrict = 1 } + + Test cases: typecheck/should_fail/T18869 + typecheck/should_fail/tcfail085 + typecheck/should_fail/tcfail112 + -} + TcRnMissingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> TcRnMessage + + {-| TcRnAmbiguousFieldInUpdate is an error that occurs when a field in a + record update clashes with another field or top-level function of the + same name, and the user hasn't enabled -XDisambiguateRecordFields. + + Example: + + {-# LANGUAGE NoFieldSelectors #-} + {-# LANGUAGE NoDisambiguateRecordFields #-} + module M where + + data A = MkA { fld :: Int } + + fld :: Bool + fld = False + + f r = r { fld = 3 } + + -} + TcRnAmbiguousFieldInUpdate :: (GlobalRdrElt, GlobalRdrElt, [GlobalRdrElt]) + -> TcRnMessage + + {-| TcRnBadRecordUpdate is an error when a regular (non-overloaded) + record update cannot be pinned down to any one parent. + + The problem with the record update is stored in the 'BadRecordUpdateReason' + field. + + Example(s): + + data R1 = R1 { x :: Int } + data R2 = R2 { x :: Int } + update r = r { x = 1 } + -- ambiguous + + data R1 = R1 { x :: Int, y :: Int } + data R2 = R2 { y :: Int, z :: Int } + update r = r { x = 1, y = 2, z = 3 } + -- no parent has all the fields + + Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail01 + overloadedrecflds/should_fail/overloadedrecfldsfail14 + -} + TcRnBadRecordUpdate :: [RdrName] + -- ^ the fields of the record update + -> BadRecordUpdateReason + -- ^ the reason this record update was rejected + -> TcRnMessage + + {-| TcRnStaticFormNotClosed is an error pertaining to terms that are marked static + using the -XStaticPointers extension but which are not closed terms. + + Example(s): + f x = static x + + Test cases: rename/should_fail/RnStaticPointersFail01 + rename/should_fail/RnStaticPointersFail03 + -} + TcRnStaticFormNotClosed :: Name -> NotClosedReason -> TcRnMessage + + {-| TcRnUselessTypeable is a warning (controlled by -Wderiving-typeable) that + occurs when trying to derive an instance of the 'Typeable' class. Deriving + 'Typeable' is no longer necessary (hence the \"useless\") as all types + automatically derive 'Typeable' in modern GHC versions. + + Example(s): None. + + Test cases: warnings/should_compile/DerivingTypeable + -} + TcRnUselessTypeable :: TcRnMessage + + {-| TcRnDerivingDefaults is a warning (controlled by -Wderiving-defaults) that + occurs when both 'DeriveAnyClass' and 'GeneralizedNewtypeDeriving' are + enabled, and therefore GHC defaults to 'DeriveAnyClass', which might not + be what the user wants. + + Example(s): None. + + Test cases: typecheck/should_compile/T15839a + deriving/should_compile/T16179 + -} + TcRnDerivingDefaults :: !Class -> TcRnMessage + + {-| TcRnNonUnaryTypeclassConstraint is an error that occurs when GHC + encounters a non-unary constraint when trying to derive a typeclass. + + Example(s): + class A + deriving instance A + data B deriving A -- We cannot derive A, is not unary (i.e. 'class A a'). + + Test cases: deriving/should_fail/T7959 + deriving/should_fail/drvfail005 + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail006 + -} + TcRnNonUnaryTypeclassConstraint :: !UserTypeCtxt -> !TypedThing -> TcRnMessage + + {-| TcRnPartialTypeSignatures is a warning (controlled by -Wpartial-type-signatures) + that occurs when a wildcard '_' is found in place of a type in a signature or a + type class derivation + + Example(s): + foo :: _ -> Int + foo = ... + + deriving instance _ => Eq (Foo a) + + Test cases: dependent/should_compile/T11241 + dependent/should_compile/T15076 + dependent/should_compile/T14880-2 + typecheck/should_compile/T17024 + typecheck/should_compile/T10072 + partial-sigs/should_fail/TidyClash2 + partial-sigs/should_fail/Defaulting1MROff + partial-sigs/should_fail/WildcardsInPatternAndExprSig + partial-sigs/should_fail/T10615 + partial-sigs/should_fail/T14584a + partial-sigs/should_fail/TidyClash + partial-sigs/should_fail/T11122 + partial-sigs/should_fail/T14584 + partial-sigs/should_fail/T10045 + partial-sigs/should_fail/PartialTypeSignaturesDisabled + partial-sigs/should_fail/T10999 + partial-sigs/should_fail/ExtraConstraintsWildcardInExpressionSignature + partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice + partial-sigs/should_fail/WildcardInstantiations + partial-sigs/should_run/T15415 + partial-sigs/should_compile/T10463 + partial-sigs/should_compile/T15039a + partial-sigs/should_compile/T16728b + partial-sigs/should_compile/T15039c + partial-sigs/should_compile/T10438 + partial-sigs/should_compile/SplicesUsed + partial-sigs/should_compile/T18008 + partial-sigs/should_compile/ExprSigLocal + partial-sigs/should_compile/T11339a + partial-sigs/should_compile/T11670 + partial-sigs/should_compile/WarningWildcardInstantiations + partial-sigs/should_compile/T16728 + partial-sigs/should_compile/T12033 + partial-sigs/should_compile/T15039b + partial-sigs/should_compile/T10403 + partial-sigs/should_compile/T11192 + partial-sigs/should_compile/T16728a + partial-sigs/should_compile/TypedSplice + partial-sigs/should_compile/T15039d + partial-sigs/should_compile/T11016 + partial-sigs/should_compile/T13324_compile2 + linear/should_fail/LinearPartialSig + polykinds/T14265 + polykinds/T14172 + -} + TcRnPartialTypeSignatures :: !SuggestPartialTypeSignatures -> !ThetaType -> TcRnMessage + + {-| TcRnCannotDeriveInstance is an error that occurs every time a typeclass instance + can't be derived. The 'DeriveInstanceErrReason' will contain the specific reason + this error arose. + + Example(s): None. + + Test cases: generics/T10604/T10604_no_PolyKinds + deriving/should_fail/drvfail009 + deriving/should_fail/drvfail-functor2 + deriving/should_fail/T10598_fail3 + deriving/should_fail/deriving-via-fail2 + deriving/should_fail/deriving-via-fail + deriving/should_fail/T16181 + -} + TcRnCannotDeriveInstance :: !Class + -- ^ The typeclass we are trying to derive + -- an instance for + -> [Type] + -- ^ The typeclass arguments, if any. + -> !(Maybe (DerivStrategy GhcTc)) + -- ^ The derivation strategy, if any. + -> !UsingGeneralizedNewtypeDeriving + -- ^ Is '-XGeneralizedNewtypeDeriving' enabled? + -> !DeriveInstanceErrReason + -- ^ The specific reason why we couldn't derive + -- an instance for the class. + -> TcRnMessage + + {-| TcRnLazyGADTPattern is an error that occurs when a user writes a nested + GADT pattern match inside a lazy (~) pattern. + + Test case: gadt/lazypat + -} + TcRnLazyGADTPattern :: TcRnMessage + + {-| TcRnArrowProcGADTPattern is an error that occurs when a user writes a + GADT pattern inside arrow proc notation. + + Test case: arrows/should_fail/arrowfail004. + -} + TcRnArrowProcGADTPattern :: TcRnMessage + + {-| TcRnCapturedTermName is a warning (controlled by -Wterm-variable-capture) that occurs + when an implicitly quantified type variable's name is already used for a term. + Example: + a = 10 + f :: a -> a + + Test cases: T22513a T22513b T22513c T22513d T22513e T22513f T22513g T22513h T22513i + -} + TcRnCapturedTermName :: RdrName -> Either [GlobalRdrElt] Name -> TcRnMessage + + {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope) + that occurs when the type equality (a ~ b) is not in scope. + + Test case: warnings/should_compile/T18862b + -} + TcRnTypeEqualityOutOfScope :: TcRnMessage + + {-| TcRnTypeEqualityRequiresOperators is a warning (controlled by -Wtype-equality-requires-operators) + that occurs when the type equality (a ~ b) is used without the TypeOperators extension. + + Example: + {-# LANGUAGE NoTypeOperators #-} + f :: (a ~ b) => a -> b + + Test case: T18862a + -} + TcRnTypeEqualityRequiresOperators :: TcRnMessage + + {-| TcRnIllegalTypeOperator is an error that occurs when a type operator + is used without the TypeOperators extension. + + Example: + {-# LANGUAGE NoTypeOperators #-} + f :: Vec a n -> Vec a m -> Vec a (n + m) + + Test case: T12811 + -} + TcRnIllegalTypeOperator :: !SDoc -> !RdrName -> TcRnMessage + + {-| TcRnIllegalTypeOperatorDecl is an error that occurs when a type or class + operator is declared without the TypeOperators extension. + + See Note [Type and class operator definitions] + + Example: + {-# LANGUAGE Haskell2010 #-} + {-# LANGUAGE MultiParamTypeClasses #-} + + module T3265 where + + data a :+: b = Left a | Right b + + class a :*: b where {} + + + Test cases: T3265, tcfail173 + -} + TcRnIllegalTypeOperatorDecl :: !RdrName -> TcRnMessage + + {-| TcRnGADTMonoLocalBinds is a warning controlled by -Wgadt-mono-local-binds + that occurs when pattern matching on a GADT when -XMonoLocalBinds is off. + + Example(s): None + + Test cases: T20485, T20485a + -} + TcRnGADTMonoLocalBinds :: TcRnMessage + + {-| The TcRnNotInScope constructor is used for various not-in-scope errors. + See 'NotInScopeError' for more details. -} + TcRnNotInScope :: NotInScopeError -- ^ what the problem is + -> RdrName -- ^ the name that is not in scope + -> TcRnMessage + + {-| TcRnTermNameInType is an error that occurs when a term-level identifier + is used in a type. + + Example: + + import qualified Prelude + + bad :: Prelude.fst (Bool, Float) + bad = False + + Test cases: T21605{c,d} + -} + TcRnTermNameInType :: !RdrName -> TcRnMessage + + {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors) + that is triggered by an unticked occurrence of a promoted data constructor. + + Examples: + + data A = MkA + type family F (a :: A) where { F MkA = Bool } + + type B = [ Int, Bool ] + + Test cases: T9778, T19984. + -} + TcRnUntickedPromotedThing :: UntickedPromotedThing + -> TcRnMessage + + {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears + in an unexpected location, e.g. as a data constructor or in a fixity declaration. + + Examples: + + infixl 5 : + + data P = (,) + + Test cases: rnfail042, T14907b, T15124, T15233. + -} + TcRnIllegalBuiltinSyntax :: SigLike -- ^ what kind of thing this is (a binding, fixity declaration, ...) + -> RdrName + -> TcRnMessage + + {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults) + that is triggered whenever a Wanted typeclass constraint + is solving through the defaulting of a type variable. + + Example: + + one = show 1 + -- We get Wanteds Show a0, Num a0, and default a0 to Integer. + + Test cases: + none (which are really specific to defaulting), + but see e.g. tcfail204. + -} + TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred + -> Maybe TyVar -- ^ The type variable being defaulted + -> Type -- ^ The default type + -> TcRnMessage + + {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name' + is used in the incorrect 'NameSpace', e.g. a type constructor + or class used in a term, or a term variable used in a type. + + Example: + + list2 = $( conE ''(:) `appE` litE (IntegerL 5) `appE` conE '[] ) + -- ^^^^^ + -- should use a single quotation tick, i.e. '(:) + + Test cases: T20884. + -} + TcRnIncorrectNameSpace :: Name + -> Bool -- ^ whether the error is happening + -- in a Template Haskell tick + -- (so we should give a Template Haskell hint) + -> TcRnMessage + + {-| TcRnForeignImportPrimExtNotSet is an error occurring when a foreign import + is declared using the @prim@ calling convention without having turned on + the -XGHCForeignImportPrim extension. + + Example(s): + foreign import prim "foo" foo :: ByteArray# -> (# Int#, Int# #) + + Test cases: ffi/should_fail/T20116 + -} + TcRnForeignImportPrimExtNotSet :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe + annotation should not be used with @prim@ foreign imports. + + Example(s): + foreign import prim unsafe "my_primop_cmm" :: ... + + Test cases: None + -} + TcRnForeignImportPrimSafeAnn :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ + imports cannot have function types. + + Example(s): + foreign import capi "math.h value sqrt" f :: CInt -> CInt + + Test cases: ffi/should_fail/capi_value_function + -} + TcRnForeignFunctionImportAsValue :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ + that informs the user of a possible missing @&@ in the declaration of a + foreign import with a 'FunPtr' return type. + + Example(s): + foreign import ccall "f" f :: FunPtr (Int -> IO ()) + + Test cases: ffi/should_compile/T1357 + -} + TcRnFunPtrImportWithoutAmpersand :: ForeignImport GhcRn -> TcRnMessage + + {-| TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration + is not compatible with the code generation backend being used. + + Example(s): None + + Test cases: None + -} + TcRnIllegalForeignDeclBackend + :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> Backend + -> ExpectedBackends + -> TcRnMessage + + {-| TcRnUnsupportedCallConv informs the user that the calling convention specified + for a foreign export declaration is not compatible with the target platform. + It is a warning controlled by @-Wunsupported-calling-conventions@ in the case of + @stdcall@ but is otherwise considered an error. + + Example(s): None + + Test cases: None + -} + TcRnUnsupportedCallConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> UnsupportedCallConvention + -> TcRnMessage + + {-| TcRnIllegalForeignType is an error for when a type appears in a foreign + function signature that is not compatible with the FFI. + + Example(s): None + + Test cases: ffi/should_fail/T3066 + ffi/should_fail/ccfail004 + ffi/should_fail/T10461 + ffi/should_fail/T7506 + ffi/should_fail/T5664 + safeHaskell/ghci/p6 + safeHaskell/safeLanguage/SafeLang08 + ffi/should_fail/T16702 + linear/should_fail/LinearFFI + ffi/should_fail/T7243 + -} + TcRnIllegalForeignType :: !(Maybe ArgOrResult) -> !IllegalForeignTypeReason -> TcRnMessage + + {-| TcRnInvalidCIdentifier indicates a C identifier that is not valid. + + Example(s): + foreign import prim safe "not valid" cmm_test2 :: Int# -> Int# + + Test cases: th/T10638 + -} + TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage + + {-| TcRnExpectedValueId is an error occurring when something that is not a + value identifier is used where one is expected. + + Example(s): none + + Test cases: none + -} + TcRnExpectedValueId :: !TcTyThing -> TcRnMessage + + {-| TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector + containing an existential type variable is used as a function rather than in + a pattern match. + + Example(s): + data Rec = forall a. Rec { field :: a } + field (Rec True) + + Test cases: patsyn/should_fail/records-exquant + typecheck/should_fail/T3176 + -} + TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage + + {-| TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern + synonym is used as a constructor. + + Example(s): + pattern Five :: Int + pattern Five <- 5 + five = Five + + Test cases: patsyn/should_fail/records-no-uni-update + patsyn/should_fail/records-no-uni-update2 + -} + TcRnPatSynNotBidirectional :: !Name -> TcRnMessage + + {-| TcRnIllegalDerivingItem is an error for when something other than a type class + appears in a deriving statement. + + Example(s): + data X = X deriving Int + + Test cases: deriving/should_fail/T5922 + -} + TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage + + {-| TcRnIllegalDefaultClass is an error for when something other than a type class + appears in a default declaration after the keyword. + + Example(s): + default Integer (Int) + + Test cases: default/fail01 + -} + TcRnIllegalDefaultClass :: !Name -> TcRnMessage + + {-| TcRnIllegalNamedDefault is an error for specifying an explicit default class name + without @-XNamedDefaults@. + + Example(s): + default Num (Integer) + + Test cases: default/fail02 + -} + TcRnIllegalNamedDefault :: !(LDefaultDecl GhcRn) -> TcRnMessage + + {-| TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such + as strictness, laziness, or unpacking. + + Example(s): + data T = T { t :: Maybe {-# UNPACK #-} Int } + data C = C { f :: !IntMap Int } + + Test cases: parser/should_fail/unpack_inside_type + typecheck/should_fail/T7210 + rename/should_fail/T22478b + -} + TcRnUnexpectedAnnotation :: !(HsType GhcPs) -> !HsSrcBang -> TcRnMessage + + {-| TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax. + + Example(s): + data T = T Int { field :: Int } + + Test cases: rename/should_fail/T7943 + rename/should_fail/T9077 + rename/should_fail/T22478b + -} + TcRnIllegalRecordSyntax :: HsType GhcPs -> TcRnMessage + + {-| TcRnInvalidVisibleKindArgument is an error for a kind application on a + target type that cannot accept it. + + Example(s): + bad :: Int @Type + bad = 1 + type Foo :: forall a {b}. a -> b -> b + type Foo x y = y + type Bar = Foo @Bool @Int True 42 + + Test cases: indexed-types/should_fail/T16356_Fail3 + typecheck/should_fail/ExplicitSpecificity7 + typecheck/should_fail/T12045b + typecheck/should_fail/T12045c + typecheck/should_fail/T15592a + typecheck/should_fail/T15816 + -} + TcRnInvalidVisibleKindArgument + :: !(LHsType GhcRn) -- ^ The visible kind argument + -> !Type -- ^ Target of the kind application + -> TcRnMessage + + {-| TcRnTooManyBinders is an error for a type constructor that is declared with + more arguments then its kind specifies. + + Example(s): + type T :: Type -> (Type -> Type) -> Type + data T a (b :: Type -> Type) x1 (x2 :: Type -> Type) + + Test cases: saks/should_fail/saks_fail008 + -} + TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcRnMessage + + {-| TcRnDifferentNamesForTyVar is an error that indicates different names being + used for the same type variable. + + Example(s): + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + + Test cases: polykinds/T11203 + polykinds/T11821a + saks/should_fail/T20916 + typecheck/should_fail/T17566b + typecheck/should_fail/T17566c + -} + TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage + + {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature, + where the implicitly-bound type type variables can't be matched up unambiguously + with the ones from the signature. See Note [Disconnected type variables] in + GHC.Tc.Gen.HsType. + + Test cases: T24083 + -} + TcRnDisconnectedTyVar :: !Name -> TcRnMessage + + {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature + with an invalid result kind. + + Example(s): + data family Foo :: Constraint + + Test cases: typecheck/should_fail/T14048b + typecheck/should_fail/UnliftedNewtypesConstraintFamily + typecheck/should_fail/T12729 + typecheck/should_fail/T15883 + typecheck/should_fail/T16829a + typecheck/should_fail/T16829b + typecheck/should_fail/UnliftedNewtypesNotEnabled + typecheck/should_fail/tcfail079 + -} + TcRnInvalidReturnKind + :: !DataSort -- ^ classification of thing being returned + -> !AllowedDataResKind -- ^ allowed kind + -> !Kind -- ^ the return kind + -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension + -> TcRnMessage + + {-| TcRnUnexpectedKindVar is an error that occurs when the user + tries to use kind variables without -XPolyKinds. + + Example: + f :: forall k a. Proxy (a :: k) + + Test cases: polykinds/BadKindVar + polykinds/T14710 + saks/should_fail/T16722 + -} + TcRnUnexpectedKindVar :: RdrName -> TcRnMessage + + {-| TcRnIllegalKind is used for a various illegal kinds errors including + + Example: + type T :: forall k. Type -- without emabled -XPolyKinds + + Test cases: polykinds/T16762b + -} + TcRnIllegalKind + :: HsTypeOrSigType GhcPs + -- ^ The illegal kind + -> Bool -- ^ Whether enabling -XPolyKinds should be suggested + -> TcRnMessage + + {-| TcRnClassKindNotConstraint is an error for a type class that has a kind that + is not equivalent to Constraint. + + Example(s): + type C :: Type -> Type + class C a + + Test cases: saks/should_fail/T16826 + -} + TcRnClassKindNotConstraint :: !Kind -> TcRnMessage + + {-| TcRnUnpromotableThing is an error that occurs when the user attempts to + use the promoted version of something which is not promotable. + + Example(s): + data T :: T -> * + data X a where + MkX :: Show a => a -> X a + foo :: Proxy ('MkX 'True) + foo = Proxy + + Test cases: dependent/should_fail/PromotedClass + dependent/should_fail/T14845_fail1 + dependent/should_fail/T14845_fail2 + dependent/should_fail/T15215 + dependent/should_fail/T13780c + dependent/should_fail/T15245 + polykinds/T5716 + polykinds/T5716a + polykinds/T6129 + polykinds/T7433 + patsyn/should_fail/T11265 + patsyn/should_fail/T9161-1 + patsyn/should_fail/T9161-2 + dependent/should_fail/SelfDep + polykinds/PolyKinds06 + polykinds/PolyKinds07 + polykinds/T13625 + polykinds/T15116 + polykinds/T15116a + saks/should_fail/T16727a + saks/should_fail/T16727b + rename/should_fail/T12686 + rename/should_fail/T16635a + rename/should_fail/T16635b + rename/should_fail/T16635c + -} + TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage + + {- | TcRnIllegalTermLevelUse is an error that occurs when the user attempts to + use a type-level entity at the term-level. + + Examples: + f x = Int -- illegal use of a type constructor + g (Proxy :: Proxy a) = a -- illegal use of a type variable + + Note that the namespace cannot be used to determine if a name refers to a + type-level entity: + + {-# LANGUAGE RequiredTypeArguments #-} + bad :: forall (a :: k) -> k + bad t = t + + The name `t` is assigned the `varName` namespace but stands for a type + variable that cannot be used at the term level. + + Test cases: T18740a, T18740b, T23739_fail_ret, T23739_fail_case + -} + TcRnIllegalTermLevelUse + :: !Bool -- ^ should we give a simple "out of scope" message, + -- instead of a full-blown "Illegal term level use" message? + -> !RdrName -- ^ the user-written identifier + -> !Name -- ^ the type-level 'Name' we resolved it to + -> !TermLevelUseErr + -> TcRnMessage + + {-| TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches + that have different numbers of arguments + + Example(s): + foo x = True + foo x y = False + + Test cases: rename/should_fail/rnfail045 + typecheck/should_fail/T20768_fail + -} + TcRnMatchesHaveDiffNumArgs + :: !HsMatchContextRn -- ^ Pattern match specifics + -> !MatchArgBadMatches + -> TcRnMessage + + {-| TcRnUnexpectedPatSigType is an error occurring when there is + a type signature in a pattern without -XScopedTypeVariables extension + + Examples: + f (a :: Bool) = ... + + Test case: rename/should_fail/T11663 + -} + TcRnUnexpectedPatSigType :: HsPatSigType GhcPs -> TcRnMessage + + {-| TcRnIllegalKindSignature is an error occurring when there is + a kind signature without -XKindSignatures extension + + Examples: + data Foo (a :: Nat) = .... + + Test case: parser/should_fail/readFail036 + -} + TcRnIllegalKindSignature :: HsType GhcPs -> TcRnMessage + + {-| TcRnDataKindsError is an error occurring when there is + an illegal type or kind, probably required -XDataKinds + and is used without the enabled extension. + + This error can occur in both the renamer and the typechecker. The field + of type @'Either' ('HsType' 'GhcPs') 'Type'@ reflects this: this field + will contain a 'Left' value if the error occurred in the renamer, and this + field will contain a 'Right' value if the error occurred in the + typechecker. + + Examples: + + type Foo = [Nat, Char] + + type Bar = [Int, String] + + Test cases: linear/should_fail/T18888 + parser/should_fail/readFail001 + polykinds/T7151 + polykinds/T7433 + rename/should_fail/T13568 + rename/should_fail/T22478e + th/TH_Promoted1Tuple + typecheck/should_compile/tcfail094 + typecheck/should_fail/T22141a + typecheck/should_fail/T22141b + typecheck/should_fail/T22141c + typecheck/should_fail/T22141d + typecheck/should_fail/T22141e + typecheck/should_compile/T22141f + typecheck/should_compile/T22141g + typecheck/should_fail/T20873c + typecheck/should_fail/T20873d + -} + TcRnDataKindsError :: TypeOrKind -> Either (HsType GhcPs) Type -> TcRnMessage + + {-| TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type + variables cannot be used in pattern bindings. + + Example(s): + let (x :: a) = 5 + + Test cases: typecheck/should_compile/tc141 + -} + TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {-| TcRnCannotBindTyVarsInPatBind is an error for when type + variables are introduced in a pattern binding + + Example(s): + Just @a x = Just True + + Test cases: typecheck/should_fail/TyAppPat_PatternBinding + typecheck/should_fail/TyAppPat_PatternBindingExistential + -} + TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {-| TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas + reference the same definition. + + Example(s): + {-# INLINE foo #-} + {-# INLINE foo #-} + foo :: Bool -> Bool + foo = id + + Test cases: none + -} + TcRnMultipleInlinePragmas + :: !Id -- ^ Target of the pragmas + -> !(LocatedA InlinePragma) -- ^ The first pragma + -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas + -> TcRnMessage + + {-| TcRnUnexpectedPragmas is a warning that occurs when unexpected pragmas appear + in the source. + + Example(s): + + Test cases: none + -} + TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage + + {-| TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being + placed on a definition that is not overloaded. + + Example(s): + {-# SPECIALISE foo :: Bool -> Bool #-} + foo :: Bool -> Bool + foo = id + + Test cases: simplCore/should_compile/T8537 + typecheck/should_compile/T10504 + -} + TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage + -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540) + + {-| TcRnSpecialiseNotVisible is a warning that occurs when the subject of a + SPECIALISE pragma has a definition that is not visible from the current module. + + Example(s): none + + Test cases: none + -} + TcRnSpecialiseNotVisible :: !Name -> TcRnMessage + + {-| TcRnPragmaWarning is a warning that can happen when usage of something + is warned or deprecated by pragma. + + Test cases: + DeprU + T5281 + T5867 + rn050 + rn066 (here is a warning, not deprecation) + T3303 + ExportWarnings1 + ExportWarnings2 + ExportWarnings3 + ExportWarnings4 + ExportWarnings5 + ExportWarnings6 + InstanceWarnings + -} + TcRnPragmaWarning :: { + pragma_warning_info :: PragmaWarningInfo, + pragma_warning_msg :: WarningTxt GhcRn + } -> TcRnMessage + + {-| TcRnDifferentExportWarnings is an error that occurs when the + warning messages for exports of a name differ between several export items. + + Test case: + DifferentExportWarnings + -} + TcRnDifferentExportWarnings :: !Name -- ^ The name with different export warnings + -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that differ + -- from the one at which the error is reported + -> TcRnMessage + + {-| TcRnIncompleteExportWarnings is a warning (controlled by -Wincomplete-export-warnings) that + occurs when some of the exports of a name do not have an export warning and some do + + Test case: + ExportWarnings6 + -} + TcRnIncompleteExportWarnings :: !Name -- ^ The name that is exported + -> NE.NonEmpty SrcSpan -- ^ The locations of export list items that are + -- missing the export warning + -> TcRnMessage + + {-| TcRnIllegalHsigDefaultMethods is an error that occurs when a binding for + a class default method is provided in a Backpack signature file. + + Test case: + bkpfail40 + -} + TcRnIllegalHsigDefaultMethods :: !Name -- ^ 'Name' of the class + -> NE.NonEmpty (LHsBind GhcRn) -- ^ default methods + -> TcRnMessage + + {-| TcRnHsigFixityMismatch is an error indicating that the fixity decl in a + Backpack signature file differs from the one in the source file for the same + operator. + + Test cases: + bkpfail37, bkpfail38 + -} + TcRnHsigFixityMismatch :: !TyThing -- ^ The operator whose fixity is defined + -> !Fixity -- ^ the fixity used in the source file + -> !Fixity -- ^ the fixity used in the signature + -> TcRnMessage + + {-| TcRnHsigShapeMismatch is a group of errors related to mismatches between + backpack signatures. + -} + TcRnHsigShapeMismatch :: !HsigShapeMismatchReason + -> TcRnMessage + + {-| TcRnHsigMissingModuleExport is an error indicating that a module doesn't + export a name exported by its signature. + + Test cases: + bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06 + -} + TcRnHsigMissingModuleExport :: !OccName -- ^ The missing name + -> !UnitState -- ^ The module's unit state + -> !Module -- ^ The implementation module + -> TcRnMessage + + {-| TcRnBadGenericMethod + This test ensures that if you provide a "more specific" type signatures + for the default method, you must also provide a binding. + + Example: + {-# LANGUAGE DefaultSignatures #-} + + class C a where + meth :: a + default meth :: Num a => a + meth = 0 + + Test case: + typecheck/should_fail/MissingDefaultMethodBinding.hs + -} + TcRnBadGenericMethod :: !Name -- ^ 'Name' of the class + -> !Name -- ^ Problematic method + -> TcRnMessage + + {-| TcRnWarningMinimalDefIncomplete is a warning that one must + specify which methods must be implemented by all instances. + + Example: + class Cheater a where -- WARNING LINE + cheater :: a + {-# MINIMAL #-} -- warning! + + Test case: + warnings/minimal/WarnMinimal.hs: + -} + TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage + + {-| TcRnIllegalQuasiQuotes is an error that occurs when a quasi-quote + is used without the QuasiQuotes extension. + + Example: + + foo = [myQuoter|x y z|] + + Test cases: none; the parser fails to parse this if QuasiQuotes is off. + -} + TcRnIllegalQuasiQuotes :: TcRnMessage + + {-| TcRnTHError is a family of errors involving Template Haskell. + See 'THError'. + -} + TcRnTHError :: THError -> TcRnMessage + + {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when + a default method pragma is missing an accompanying binding. + + Test cases: + typecheck/should_fail/T5084.hs + typecheck/should_fail/T2354.hs + -} + TcRnDefaultMethodForPragmaLacksBinding + :: Id -- ^ method + -> Sig GhcRn -- ^ the pragma + -> TcRnMessage + {-| TcRnIgnoreSpecialisePragmaOnDefMethod is a warning that occurs when + a specialise pragma is put on a default method. + + Test cases: none + -} + TcRnIgnoreSpecialisePragmaOnDefMethod + :: !Name + -> TcRnMessage + {-| TcRnBadMethodErr is an error that happens when one attempts to provide a method + in a class instance, when the class doesn't have a method by that name. + + Test case: + th/T12387 + -} + TcRnBadMethodErr + :: { badMethodErrClassName :: !Name + , badMethodErrMethodName :: !Name + } -> TcRnMessage + + {-| TcRnIllegalNewtype is an error that occurs when a newtype: + + * Does not have exactly one field, or + * is non-linear, or + * is a GADT, or + * has a context in its constructor's type, or + * has existential type variables in its constructor's type, or + * has strictness annotations. + + Test cases: + gadt/T14719 + indexed-types/should_fail/T14033 + indexed-types/should_fail/T2334A + linear/should_fail/LinearGADTNewtype + parser/should_fail/readFail008 + polykinds/T11459 + typecheck/should_fail/T15523 + typecheck/should_fail/T15796 + typecheck/should_fail/T17955 + typecheck/should_fail/T18891a + typecheck/should_fail/T21447 + typecheck/should_fail/tcfail156 + -} + TcRnIllegalNewtype + :: DataCon + -> Bool -- ^ True if linear types enabled + -> IllegalNewtypeReason + -> TcRnMessage + + {-| TcRnIllegalTypeData is an error that occurs when a @type data@ + declaration occurs without the TypeOperators extension. + + See Note [Type data declarations] + + Test case: + type-data/should_fail/TDNoPragma + -} + TcRnIllegalTypeData :: TcRnMessage + + {-| TcRnTypeDataForbids is an error that occurs when a @type data@ + declaration contains @data@ declaration features that are + forbidden in a @type data@ declaration. + + See Note [Type data declarations] + + Test cases: + type-data/should_fail/TDDeriving + type-data/should_fail/TDRecordsGADT + type-data/should_fail/TDRecordsH98 + type-data/should_fail/TDStrictnessGADT + type-data/should_fail/TDStrictnessH98 + -} + TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage + + {-| TcRnOrPatBindsVariables is an error that happens when an + or-pattern binds term or type variables, e.g. (A @x; B y). + + Test case: + testsuite/tests/typecheck/should_fail/Or3 + -} + TcRnOrPatBindsVariables + :: NE.NonEmpty (IdP GhcRn) -- ^ List of binders + -> TcRnMessage + + {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance + is missing methods that are required by the minimal definition. + + Example: + class C a where + foo :: a -> a + instance C () -- | foo needs to be defined here + + Test cases: + typecheck/prog001/typecheck.prog001 + typecheck/should_compile/tc126 + typecheck/should_compile/T7903 + typecheck/should_compile/tc116 + typecheck/should_compile/tc175 + typecheck/should_compile/HasKey + typecheck/should_compile/tc125 + typecheck/should_compile/tc078 + typecheck/should_compile/tc161 + typecheck/should_fail/T5051 + typecheck/should_compile/T21583 + backpack/should_compile/bkp47 + backpack/should_fail/bkpfail25 + parser/should_compile/T2245 + parser/should_compile/read014 + indexed-types/should_compile/Class3 + indexed-types/should_compile/Simple2 + indexed-types/should_fail/T7862 + deriving/should_compile/deriving-1935 + deriving/should_compile/T9968a + deriving/should_compile/drv003 + deriving/should_compile/T4966 + deriving/should_compile/T14094 + perf/compiler/T15304 + warnings/minimal/WarnMinimal + simplCore/should_compile/simpl020 + deSugar/should_compile/T14546d + ghci/scripts/T5820 + ghci/scripts/ghci019 + -} + TcRnUnsatisfiedMinimalDef :: ClassMinimalDef -> TcRnMessage + + {-| 'TcRnMisplacedInstSig' is an error that happens when a method in + a class instance is given a type signature, but the user has not + enabled the @InstanceSigs@ extension. + + Test case: module/mod45 + -} + TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage + {-| TcRnNoRebindableSyntaxRecordDot is an error triggered by an overloaded record update + without RebindableSyntax enabled. + + Example(s): + + Test cases: parser/should_fail/RecordDotSyntaxFail5 + -} + TcRnNoRebindableSyntaxRecordDot :: TcRnMessage + + {-| TcRnNoFieldPunsRecordDot is an error triggered by the use of record field puns + in an overloaded record update without enabling NamedFieldPuns. + + Example(s): + print $ a{ foo.bar.baz.quux } + + Test cases: parser/should_fail/RecordDotSyntaxFail12 + -} + TcRnNoFieldPunsRecordDot :: TcRnMessage + + {-| TcRnIllegalStaticExpression is an error thrown when user creates a static + pointer via TemplateHaskell without enabling the StaticPointers extension. + + Example(s): + + Test cases: th/T14204 + -} + TcRnIllegalStaticExpression :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnListComprehensionDuplicateBinding is an error triggered by duplicate + let-bindings in a list comprehension. + + Example(s): + [ () | let a = 13 | let a = 17 ] + + Test cases: typecheck/should_fail/tcfail092 + -} + TcRnListComprehensionDuplicateBinding :: Name -> TcRnMessage + + {-| TcRnEmptyStmtsGroup is an error triggered by an empty list of statements + in a statement block. For more information, see 'EmptyStatementGroupErrReason' + + Example(s): + + [() | then ()] + + do + + proc () -> do + + Test cases: rename/should_fail/RnEmptyStatementGroup1 + -} + TcRnEmptyStmtsGroup:: EmptyStatementGroupErrReason -> TcRnMessage + + {-| TcRnLastStmtNotExpr is an error caused by the last statement + in a statement block not being an expression. + + Example(s): + + do x <- pure () + + do let x = 5 + + Test cases: rename/should_fail/T6060 + parser/should_fail/T3811g + parser/should_fail/readFail028 + -} + TcRnLastStmtNotExpr + :: HsStmtContextRn + -> UnexpectedStatement + -> TcRnMessage + + {-| TcRnUnexpectedStatementInContext is an error when a statement appears + in an unexpected context (e.g. an arrow statement appears in a list comprehension). + + Example(s): + + Test cases: parser/should_fail/readFail042 + parser/should_fail/readFail038 + parser/should_fail/readFail043 + -} + TcRnUnexpectedStatementInContext + :: HsStmtContextRn + -> UnexpectedStatement + -> Maybe LangExt.Extension + -> TcRnMessage + + {-| TcRnIllegalTupleSection is an error triggered by usage of a tuple section + without enabling the TupleSections extension. + + Example(s): + (5,) + + Test cases: rename/should_fail/rnfail056 + -} + TcRnIllegalTupleSection :: TcRnMessage + + {-| TcRnIllegalImplicitParameterBindings is an error triggered by binding + an implicit parameter in an mdo block. + + Example(s): + mdo { let { ?x = 5 }; () } + + Test cases: rename/should_fail/RnImplicitBindInMdoNotation + -} + TcRnIllegalImplicitParameterBindings + :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) + -> TcRnMessage + + {-| TcRnSectionWithoutParentheses is an error triggered by attempting to + use an operator section without parentheses. + + Example(s): + (`head` x, ()) + + Test cases: rename/should_fail/T2490 + rename/should_fail/T5657 + -} + TcRnSectionWithoutParentheses :: HsExpr GhcPs -> TcRnMessage + + {-| TcRnBindingOfExistingName is an error triggered by an attempt to rebind + built-in syntax, punned list or tuple syntax, or a name quoted via Template Haskell. + + Examples: + + data [] + data (->) + $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) + + Test cases: rename/should_fail/T14907b + rename/should_fail/T22839 + rename/should_fail/rnfail042 + th/T13968 + -} + TcRnBindingOfExistingName :: RdrName -> TcRnMessage + {-| TcRnMultipleFixityDecls is an error triggered by multiple + fixity declarations for the same operator. + + Example(s): + + infixr 6 $$ + infixl 4 $$ + + Test cases: rename/should_fail/RnMultipleFixityFail + -} + TcRnMultipleFixityDecls :: SrcSpan -> RdrName -> TcRnMessage + + {-| TcRnIllegalPatternSynonymDecl is an error thrown when a user + defines a pattern synonyms without enabling the PatternSynonyms extension. + + Example: + + pattern O :: Int + pattern O = 0 + + Test cases: rename/should_fail/RnPatternSynonymFail + -} + TcRnIllegalPatternSynonymDecl :: TcRnMessage + + {-| TcRnIllegalClassBinding is an error triggered by a binding + in a class or instance declaration of an illegal form. + + Examples: + + class ZeroOne a where + zero :: a + one :: a + instance ZeroOne Int where + (zero,one) = (0,1) + + class C a where + pattern P = () + + Test cases: module/mod48 + patsyn/should_fail/T9705-1 + patsyn/should_fail/T9705-2 + typecheck/should_fail/tcfail021 + + -} + TcRnIllegalClassBinding :: DeclSort -> HsBindLR GhcPs GhcPs -> TcRnMessage + + {-| TcRnOrphanCompletePragma is an error triggered by a {-# COMPLETE #-} + pragma which does not mention any data constructors or pattern synonyms + defined in the current module. + + Test cases: patsyn/should_fail/T13349 + -} + TcRnOrphanCompletePragma :: TcRnMessage + + {-| TcRnEmptyCase is an error thrown when a user uses + a case expression with an empty list of alternatives without + enabling the EmptyCase extension. + + Example for EmptyCaseWithoutFlag: + + {-# LANGUAGE NoEmptyCase #-} + f :: Void -> a + f = \case {} -- extension not enabled + + Example for EmptyCaseDisallowedCtxt: + + f = \cases {} -- multi-case requires n>0 alternatives + + Example for EmptyCaseForall: + + f :: forall (xs :: Type) -> () + f = \case {} -- can't match on a type argument + + Test cases: rename/should_fail/RnEmptyCaseFail + typecheck/should_fail/T25004 + -} + TcRnEmptyCase :: !HsMatchContextRn + -> !BadEmptyCaseReason + -> TcRnMessage + + {-| TcRnNonStdGuards is a warning thrown when a user uses + non-standard guards (e.g. patterns in guards) without + enabling the PatternGuards extension. + More realistically: the user has explicitly disabled PatternGuards, + as it is enabled by default with `-XHaskell2010`. + + Example(s): + + f | 5 <- 2 + 3 = ... + + Test cases: rename/should_compile/rn049 + -} + TcRnNonStdGuards :: NonStandardGuards -> TcRnMessage + + {-| TcRnDuplicateSigDecl is an error triggered by two or more + signatures for one entity. + + Examples: + + f :: Int -> Bool + f :: Int -> Bool + f _ = True + + g x = x + {-# INLINE g #-} + {-# NOINLINE g #-} + + pattern P = () + {-# COMPLETE P #-} + {-# COMPLETE P #-} + + Test cases: module/mod68 + parser/should_fail/OpaqueParseFail4 + patsyn/should_fail/T12165 + rename/should_fail/rnfail048 + rename/should_fail/T5589 + rename/should_fail/T7338 + rename/should_fail/T7338a + -} + TcRnDuplicateSigDecl :: NE.NonEmpty (LocatedN RdrName, Sig GhcPs) -> TcRnMessage + + {-| TcRnMisplacedSigDecl is an error triggered by the pragma application + in the wrong context, like `MINIMAL` applied to a function or + `SPECIALIZE` to an instance. + + Example: + + f x = x + {-# MINIMAL f #-} + + Test cases: rename/should_fail/T18138 + warnings/minimal/WarnMinimalFail1 + -} + TcRnMisplacedSigDecl :: Sig GhcRn -> TcRnMessage + + {-| TcRnUnexpectedDefaultSig is an error thrown when a user uses + default signatures without enabling the DefaultSignatures extension. + + Example: + + class C a where + m :: a + default m :: Num a => a + m = 0 + + Test cases: rename/should_fail/RnDefaultSigFail + -} + TcRnUnexpectedDefaultSig :: Sig GhcPs -> TcRnMessage + + {-| TcRnDuplicateMinimalSig is an error triggered by two or more minimal + signatures for one type class. + + Example: + + class C where + f :: () + {-# MINIMAL f #-} + {-# MINIMAL f #-} + + Test cases: rename/should_fail/RnMultipleMinimalPragmaFail + -} + TcRnDuplicateMinimalSig :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> TcRnMessage + + {-| TcRnSpecSigShape is an error that occurs when the user writes a SPECIALISE + pragma that isn't just a function application. + + Example: + {-# SPECIALISE let x=True in x #-} + -} + TcRnSpecSigShape :: LHsExpr GhcPs -> TcRnMessage + + {-| 'TcRnIllegalInvisTyVarBndr' is an error that occurs + when invisible type variable binders in type declarations + are used without enabling the @TypeAbstractions@ extension. + + Example: + {-# LANGUAGE NoTypeAbstractions #-} -- extension disabled + data T @k (a :: k) @(j :: Type) (b :: j) + ^^ ^^^^^^^^^^^^ + + Test case: T22560_fail_ext + -} + TcRnIllegalInvisTyVarBndr + :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| 'TcRnIllegalWildcardTyVarBndr' is an error that occurs + when a wildcard binder is used in a type declaration + without enabling the @TypeAbstractions@ extension. + + Example: + {-# LANGUAGE NoTypeAbstractions #-} -- extension disabled + type Const a _ = a + ^ + + Test case: T23501_fail_ext + -} + TcRnIllegalWildcardTyVarBndr + :: !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| 'TcRnInvalidInvisTyVarBndr' is an error that occurs + when an invisible type variable binder has no corresponding + @forall k.@ quantifier in the standalone kind signature. + + Example: + type P :: forall a -> Type + data P @a = MkP + + Test cases: T22560_fail_a T22560_fail_b + -} + TcRnInvalidInvisTyVarBndr + :: !Name + -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| 'TcRnInvisBndrWithoutSig' is an error triggered by attempting to use + an invisible type variable binder in a type declaration without a + standalone kind signature or a complete user-supplied kind. + + Example: + data T @k (a :: k) -- No CUSK, no SAKS + + Test case: T22560_fail_d + -} + TcRnInvisBndrWithoutSig + :: !Name + -> !(LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) + -> TcRnMessage + + {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses + standalone deriving without enabling the StandaloneDeriving extension. + + Example: + + deriving instance Eq Foo + + Test cases: rename/should_fail/RnUnexpectedStandaloneDeriving + -} + TcRnUnexpectedStandaloneDerivingDecl :: TcRnMessage + + {-| TcRnUnusedVariableInRuleDecl is an error triggered by forall'd variable in + rewrite rule that does not appear on left-hand side + + Example: + + {-# RULES "rule" forall a. id = id #-} + + Test cases: rename/should_fail/ExplicitForAllRules2 + -} + TcRnUnusedVariableInRuleDecl :: FastString -> Name -> TcRnMessage + + {-| TcRnUnexpectedStandaloneKindSig is an error thrown when a user uses standalone + kind signature without enabling the StandaloneKindSignatures extension. + + Example: + + type D :: Type + data D = D + + Test cases: saks/should_fail/saks_fail001 + -} + TcRnUnexpectedStandaloneKindSig :: TcRnMessage + + {-| TcRnIllegalRuleLhs is an error triggered by malformed left-hand side + of rewrite rule + + Examples: + + {-# RULES "test" forall x. f x = x #-} + + {-# RULES "test" forall x. case x of = x #-} + + Test cases: rename/should_fail/T15659 + -} + TcRnIllegalRuleLhs + :: RuleLhsErrReason + -> FastString -- ^ Rule name + -> LHsExpr GhcRn -- ^ Full expression + -> HsExpr GhcRn -- ^ Bad expression + -> TcRnMessage + + {-| TcRnRuleLhsEqualities is a warning, controlled by '-Wrule-lhs-equalities', + that is triggered by a RULE whose LHS contains equality constraints + (of a certain form, such as @F a ~ b@ for a type family @F@). + + Test case: typecheck/should_compile/RuleEqs + -} + TcRnRuleLhsEqualities + :: FastString -- ^ rule name + -> LHsExpr GhcRn -- ^ LHS expression + -> NE.NonEmpty Ct -- ^ LHS equality constraints + -> TcRnMessage + + {-| TcRnDuplicateRoleAnnot is an error triggered by two or more role + annotations for one type + + Example: + + data D a + type role D phantom + type role D phantom + + Test cases: roles/should_fail/Roles8 + -} + TcRnDuplicateRoleAnnot :: NE.NonEmpty (LRoleAnnotDecl GhcPs) -> TcRnMessage + + {-| TcRnDuplicateKindSig is an error triggered by two or more standalone + kind signatures for one type + + Example: + + type D :: Type + type D :: Type + data D + + Test cases: saks/should_fail/saks_fail002 + -} + TcRnDuplicateKindSig :: NE.NonEmpty (LStandaloneKindSig GhcPs) -> TcRnMessage + + {-| TcRnIllegalDerivStrategy is an error thrown when a user uses deriving + strategy without enabling the DerivingStrategies extension or uses deriving + via without enabling the DerivingVia extension. + + Examples: + + data T = T deriving stock Eq + + data T = T deriving via Eq T + + Test cases: deriving/should_fail/deriving-via-fail3 + deriving/should_fail/T10598_fail4 + -} + TcRnIllegalDerivStrategy :: DerivStrategy GhcPs -> TcRnMessage + + {-| TcRnIllegalMultipleDerivClauses is an error thrown when a user uses two or more + deriving clauses without enabling the DerivingStrategies extension. + + Example: + + data T = T + deriving Eq + deriving Ord + + Test cases: deriving/should_fail/T10598_fail5 + -} + TcRnIllegalMultipleDerivClauses :: TcRnMessage + + {-| TcRnNoDerivStratSpecified is a warning implied by + -Wmissing-deriving-strategies and triggered by deriving without + mentioning a strategy. + + See 'TcRnNoDerivStratSpecifiedInfo' cases for examples. + + Test cases: deriving/should_compile/T15798a + deriving/should_compile/T15798b + deriving/should_compile/T15798c + deriving/should_compile/T24955a + deriving/should_compile/T24955b + deriving/should_compile/T24955c + -} + TcRnNoDerivStratSpecified + :: Bool -- ^ True if DerivingStrategies is enabled + -> TcRnNoDerivStratSpecifiedInfo + -> TcRnMessage + + {-| TcRnStupidThetaInGadt is an error triggered by data contexts in GADT-style + data declaration + + Example: + + data (Eq a) => D a where + MkD :: D Int + + Test cases: rename/should_fail/RnStupidThetaInGadt + -} + TcRnStupidThetaInGadt :: HsDocContext -> TcRnMessage + + {-| TcRnShadowedTyVarNameInFamResult is an error triggered by type variable in + type family result that shadows type variable from left hand side + + Example: + + type family F a b c = b + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnShadowedTyVarNameInFamResult :: IdP GhcPs -> TcRnMessage + + {-| TcRnIncorrectTyVarOnRhsOfInjCond is an error caused by a situation where the + left-hand side of an injectivity condition of a type family is not a variable + referring to the type family result. + See Note [Renaming injectivity annotation] for more details. + + Example: + + type family F a = r | a -> a + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnIncorrectTyVarOnLhsOfInjCond + :: IdP GhcRn -- Expected + -> LIdP GhcPs -- Actual + -> TcRnMessage + + {-| TcRnUnknownTyVarsOnRhsOfInjCond is an error triggered by out-of-scope type + variables on the right-hand side of a of an injectivity condition of a type family + + Example: + + type family F a = res | res -> b + + Test cases: ghci/scripts/T6018ghcirnfail + rename/should_fail/T6018rnfail + -} + TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage + + {-| TcRnLookupInstance groups several errors emitted when looking up class instances. + + Test cases: + none + -} + TcRnLookupInstance + :: !Class + -> ![Type] + -> !LookupInstanceErrReason + -> TcRnMessage + + {-| TcRnBadlyLevelled is an error that occurs when a TH binding is used at an + invalid level. + + Test cases: + T17820d, T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9} + -} + TcRnBadlyLevelled + :: !LevelCheckReason -- ^ The binding + -> !(Set.Set ThLevelIndex) -- ^ The binding levels + -> !ThLevelIndex -- ^ The level at which the binding is used. + -> !(Maybe ErrorItem) -- ^ The attempt we made to implicitly lift the binding. + -> DiagnosticReason -- ^ Whether to defer this error or fail + -> TcRnMessage + + {-| TcRnBadlyLevelledWarn is a warning that occurs when a TH type binding is + used in an invalid stage. + + Controlled by flags: + - Wbadly-levelled-type + + Test cases: + T23829_timely T23829_tardy T23829_hasty + -} + TcRnBadlyLevelledType + :: !Name -- ^ The type binding being spliced. + -> !(Set.Set ThLevelIndex) -- ^ The binding stage. + -> !ThLevelIndex -- ^ The stage at which the binding is used. + -> TcRnMessage + + {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another + thing was expected. + + Test cases: + none + -} + TcRnTyThingUsedWrong + :: !WrongThingSort -- ^ Expected thing. + -> !TcTyThing -- ^ Thing used wrongly. + -> !Name -- ^ Name of the thing used wrongly. + -> TcRnMessage + + {-| TcRnCannotDefaultKindVar is an error that occurs when attempting to use + unconstrained kind variables whose type isn't @Type@, without -XPolyKinds. + + Test cases: + T11334b + -} + TcRnCannotDefaultKindVar + :: !TyVar -- ^ The unconstrained variable. + -> !Kind -- ^ Kind of the variable. + -> TcRnMessage + + {-| TcRnUninferrableTyVar is an error that occurs when metavariables + in a type could not be defaulted. + + Test cases: + T17301, T17562, T17567, T17567StupidTheta, T15474, T21479 + -} + TcRnUninferrableTyVar + :: ![TyCoVar] -- ^ The variables that could not be defaulted. + -> !UninferrableTyVarCtx -- ^ Description of the surrounding context. + -> TcRnMessage + + {-| TcRnSkolemEscape is an error that occurs when type variables from an + outer scope is used in a context where they should be locally scoped. + + Test cases: + T15076, T15076b, T14880-2, T15825, T14880, T15807, T16946, T14350, + T14040A, T15795, T15795a, T14552 + -} + TcRnSkolemEscape + :: ![TcTyVar] -- ^ The variables that would escape. + -> !TcTyVar -- ^ The variable that is being quantified. + -> !Type -- ^ The type in which they occur. + -> TcRnMessage + + {-| TcRnPatSynEscapedCoercion is an error indicating that a coercion escaped from + a pattern synonym into a type. + See Note [Coercions that escape] in GHC.Tc.TyCl.PatSyn + + Test cases: + T14507 + -} + TcRnPatSynEscapedCoercion :: !Id -- ^ The pattern-bound variable + -> !(NE.NonEmpty CoVar) -- ^ The escaped coercions + -> TcRnMessage + + {-| TcRnPatSynExistentialInResult is an error indicating that the result type + of a pattern synonym mentions an existential type variable. + + Test cases: + PatSynExistential + -} + TcRnPatSynExistentialInResult :: !Name -- ^ The name of the pattern synonym + -> !TcSigmaType -- ^ The result type + -> ![TyVar] -- ^ The escaped existential variables + -> TcRnMessage + + {-| TcRnPatSynArityMismatch is an error indicating that the number of arguments in a + pattern synonym's equation differs from the number of parameters in its + signature. + + Test cases: + PatSynArity + -} + TcRnPatSynArityMismatch :: !Name -- ^ The name of the pattern synonym + -> !Arity -- ^ The number of equation arguments + -> !Arity -- ^ The difference + -> TcRnMessage + + {-| TcRnPatSynInvalidRhs is an error group indicating that the pattern on the + right hand side of a pattern synonym is invalid. + + Test cases: + unidir, T14112 + -} + TcRnPatSynInvalidRhs :: !Name -- ^ The name of the pattern synonym + -> !(LPat GhcRn) -- ^ The pattern + -> ![LIdP GhcRn] -- ^ The LHS args + -> !PatSynInvalidRhsReason -- ^ The number of equation arguments + -> TcRnMessage + + {-| TcRnZonkerMessage is collection of errors that occur when zonking, + i.e. filling in metavariables with their final values. + + See 'ZonkerMessage' + -} + TcRnZonkerMessage :: ZonkerMessage -> TcRnMessage + + {-| TcRnTyFamDepsDisabled is an error indicating that a type family injectivity + annotation was used without enabling the extension TypeFamilyDependencies. + + Test cases: + T11381 + -} + TcRnTyFamDepsDisabled :: TcRnMessage + + {-| TcRnAbstractClosedTyFamDecl is an error indicating that an abstract closed + type family was declared in a regular source file, while it is only allowed + in hs-boot files. + + Test cases: + ClosedFam4 + -} + TcRnAbstractClosedTyFamDecl :: TcRnMessage + + {-| TcRnPartialFieldSelector is a warning indicating that a record field + was not defined for all constructors of a data type. + + Test cases: + DRFPartialFields, T7169 + -} + TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector + -> TcRnMessage + + {-| TcRnHasFieldResolvedIncomplete is a warning triggered when a HasField constraint + is resolved for a record field for which a `getField @"field"` application + might not be successful. Currently, this means that the warning is triggered when + the parent data type of that record field does not have that field in all + its constructors. + + Example(s): + data T = T1 | T2 {x :: Bool} + f :: HasField t "x" Bool => t -> Bool + f = getField @"x" + g :: T -> Bool + g = f + + Test cases: + TcIncompleteRecSel + -} + TcRnHasFieldResolvedIncomplete :: !Name -- ^ The selector + -> ![ConLike] -- ^ The partial constructors + -> !Int -- ^ The max number of constructors reported + -> TcRnMessage + + {-| TcRnBadFieldAnnotation is an error/warning group indicating that a + strictness/unpack related data type field annotation is invalid. + -} + TcRnBadFieldAnnotation :: !Int -- ^ The index of the field + -> !DataCon -- ^ The constructor in which the field is defined + -> !BadFieldAnnotationReason -- ^ The error specifics + -> TcRnMessage + + {-| TcRnSuperclassCycle is an error indicating that a class has a superclass + cycle. + + Test cases: + mod40, tcfail027, tcfail213, tcfail216, tcfail217, T9415, T9739 + -} + TcRnSuperclassCycle :: !SuperclassCycle -- ^ The details of the cycle + -> TcRnMessage + + {-| TcRnDefaultSigMismatch is an error indicating that a default method + signature doesn't match the regular method signature. + + Test cases: + T7437, T12918a, T12918b, T12151 + -} + TcRnDefaultSigMismatch :: !Id -- ^ The name of the method + -> !Type -- ^ The type of the default signature + -> TcRnMessage + + {-| TcRnTyFamsDisabled is an error indicating that a type family or instance + was declared while the extension TypeFamilies was disabled. + + Test cases: + TyFamsDisabled + -} + TcRnTyFamsDisabled :: !TyFamsDisabledReason -- ^ The name of the family or instance + -> TcRnMessage + + {-| TcRnBadTyConTelescope is an error caused by an ill-scoped 'TyCon' kind, + due to type variables being out of dependency order. + + Example: + + class C a (b :: Proxy a) (c :: Proxy b) where + type T c a + + Test cases: + BadTelescope{∅,3,4} + T14066{f,g} + T14887 + T15591{b,c} + T15743{c,d} + T15764 + T23252 + + -} + TcRnBadTyConTelescope :: !TyCon -> TcRnMessage + + {-| TcRnTyFamResultDisabled is an error indicating that a result variable + was used on a type family while the extension TypeFamilyDependencies was + disabled. + + Test cases: + T13571, T13571a + -} + TcRnTyFamResultDisabled :: !Name -- ^ The name of the type family + -> !(LHsTyVarBndr () GhcRn) -- ^ Name of the result variable + -> TcRnMessage + + {-| TcRnRoleValidationFailed is an error indicating that a variable was + assigned an invalid role by the inference algorithm. + This is only performed with -dcore-lint. + -} + TcRnRoleValidationFailed :: !Role -- ^ The validated role + -> !RoleValidationFailedReason -- ^ The failure reason + -> TcRnMessage + + {-| TcRnCommonFieldResultTypeMismatch is an error indicating that a sum type + declares the same field name in multiple constructors, but the constructors' + result types differ. + + Test cases: + CommonFieldResultTypeMismatch + -} + TcRnCommonFieldResultTypeMismatch :: !DataCon -- ^ First constructor + -> !DataCon -- ^ Second constructor + -> !FieldLabelString -- ^ Field name + -> TcRnMessage + + {-| TcRnCommonFieldTypeMismatch is an error indicating that a sum type + declares the same field name in multiple constructors, but their types + differ. + + Test cases: + CommonFieldTypeMismatch + -} + TcRnCommonFieldTypeMismatch :: !DataCon -- ^ First constructor + -> !DataCon -- ^ Second constructor + -> !FieldLabelString -- ^ Field name + -> TcRnMessage + + {-| TcRnClassExtensionDisabled is an error indicating that a class + was declared with an extension feature while the extension was disabled. + -} + TcRnClassExtensionDisabled :: !Class -- ^ The class + -> !DisabledClassExtension -- ^ The extension + -> TcRnMessage + + {-| TcRnDataConParentTypeMismatch is an error indicating that a data + constructor was declared with a type that doesn't match its type + constructor (i.e. a GADT result type and its data name). + + Test cases: + T7175, T13300, T14719, T18357, T18357b, gadt11, tcfail155, tcfail176 + -} + TcRnDataConParentTypeMismatch :: !DataCon -- ^ The data constructor + -> !Type -- ^ The parent type + -> TcRnMessage + + {-| TcRnGADTsDisabled is an error indicating that a GADT was declared + while the extension GADTs was disabled. + + Test cases: + ghci057, T9293 + -} + TcRnGADTsDisabled :: !Name -- ^ The name of the GADT + -> TcRnMessage + + {-| TcRnExistentialQuantificationDisabled is an error indicating that + a data constructor was declared with existential features while the + extension ExistentialQuantification was disabled. + + Test cases: + ghci057, T9293, gadtSyntaxFail001, gadtSyntaxFail002, gadtSyntaxFail003, + prog006, rnfail053, T12083a + -} + TcRnExistentialQuantificationDisabled :: !DataCon -- ^ The constructor + -> TcRnMessage + + {-| TcRnGADTDataContext is an error indicating that a GADT was declared with a + data type context. + This error is emitted in the tc, but it is also caught in the renamer. + -} + TcRnGADTDataContext :: !Name -- ^ The data type name + -> TcRnMessage + + {-| TcRnMultipleConForNewtype is an error indicating that a newtype was + declared with multiple constructors. + This error is caught by the parser. + -} + TcRnMultipleConForNewtype :: !Name -- ^ The newtype name + -> !Int -- ^ The number of constructors + -> TcRnMessage + + {-| TcRnKindSignaturesDisabled is an error indicating that a kind signature + was used in a data type declaration while the extension KindSignatures was + disabled. + + Test cases: + T20873c, readFail036 + -} + TcRnKindSignaturesDisabled :: !(Either (HsType GhcPs) (Name, HsType GhcRn)) + -- ^ The data type name + -> TcRnMessage + + {-| TcRnEmptyDataDeclsDisabled is an error indicating that a data type + was declared with no constructors while the extension EmptyDataDecls was + disabled. + + Test cases: + readFail035 + -} + TcRnEmptyDataDeclsDisabled :: !Name -- ^ The data type name + -> TcRnMessage + + {-| TcRnRoleMismatch is an error indicating that the role specified + in an annotation differs from its inferred role. + + Test cases: + T7253, Roles11 + -} + TcRnRoleMismatch :: !Name -- ^ The type variable + -> !Role -- ^ The annotated role + -> !Role -- ^ The inferred role + -> TcRnMessage + + {-| TcRnRoleCountMismatch is an error indicating that the number of + roles in an annotation doesn't match the number of type parameters. + + Test cases: + Roles6 + -} + TcRnRoleCountMismatch :: !Int -- ^ The number of type variables + -> !(LRoleAnnotDecl GhcRn) -- ^ The role annotation + -> TcRnMessage + + {-| TcRnIllegalRoleAnnotation is an error indicating that a role + annotation was attached to a decl that doesn't allow it. + + Test cases: + Roles5 + -} + TcRnIllegalRoleAnnotation :: !(RoleAnnotDecl GhcRn) -- ^ The role annotation + -> TcRnMessage + + {-| TcRnRoleAnnotationsDisabled is an error indicating that a role + annotation was declared while the extension RoleAnnotations was disabled. + + Test cases: + Roles5, TH_Roles1 + -} + TcRnRoleAnnotationsDisabled :: !TyCon -- ^ The annotated type + -> TcRnMessage + + {-| TcRnIncoherentRoles is an error indicating that a role + annotation for a class parameter was declared as not nominal. + + Test cases: + T8773 + -} + TcRnIncoherentRoles :: !TyCon -- ^ The class tycon + -> TcRnMessage + {-| TcRnPrecedenceParsingError is an error caused by attempting to + use operators with the same precedence in one infix expression. + + Example: + eq :: (a ~ b ~ c) :~: () + + Test cases: module/mod61 + parser/should_fail/readFail016 + rename/should_fail/rnfail017 + rename/should_fail/T9077 + typecheck/should_fail/T18252a + -} + TcRnPrecedenceParsingError + :: (OpName, Fixity) -- ^ first operator's name and fixity + -> (OpName, Fixity) -- ^ second operator's name and fixity + -> TcRnMessage + + {-| TcRnPrecedenceParsingError is an error caused by attempting to + use an operator with higher precedence than the operand. + + Example: + k = (-3 **) + where + (**) = const + infixl 7 ** + + Test cases: overloadedrecflds/should_fail/T13132_duplicaterecflds + parser/should_fail/readFail023 + rename/should_fail/rnfail019 + th/TH_unresolvedInfix2 + -} + TcRnSectionPrecedenceError + :: (OpName, Fixity) -- ^ first operator's name and fixity + -> (OpName, Fixity) -- ^ argument operator + -> HsExpr GhcPs -- ^ Section + -> TcRnMessage + + {-| TcRnTypeSynonymCycle is an error indicating that a cycle between type + synonyms has occurred. + + Test cases: + mod27, ghc-e-fail2, bkpfail29 + -} + TcRnTypeSynonymCycle :: !TySynCycleTyCons -- ^ The tycons involved in the cycle + -> TcRnMessage + + {-| TcRnSelfImport is an error indicating that a module contains an + import of itself. + + Test cases: + T9032 + -} + TcRnSelfImport :: !ModuleName -- ^ The module + -> TcRnMessage + + {-| TcRnNoExplicitImportList is a warning indicating that an import + statement did not include an explicit import list. + + Test cases: + T1789, T4489 + -} + TcRnNoExplicitImportList :: !ModuleName -- ^ The imported module + -> TcRnMessage + + {-| TcRnSafeImportsDisabled is an error indicating that an import was + declared using the @safe@ keyword while SafeHaskell wasn't active. + + Test cases: + Mixed01 + -} + TcRnSafeImportsDisabled :: !ModuleName -- ^ The imported module + -> TcRnMessage + + {-| TcRnDeprecatedModule is a warning indicating that an imported module + is annotated with a warning or deprecation pragma. + + Test cases: + DeprU + -} + TcRnDeprecatedModule :: !ModuleName -- ^ The imported module + -> !(WarningTxt GhcRn) -- ^ The pragma data + -> TcRnMessage + + {-| TcRnRedundantSourceImport is a warning indicating that a {-# SOURCE #-} + import was used when there is no import cycle. + + Test cases: + none + -} + TcRnRedundantSourceImport :: !ModuleName -- ^ The imported module + -> TcRnMessage + + {-| TcRnImportLookup is a group of errors about bad imported names. + -} + TcRnImportLookup :: !ImportLookupReason -- ^ Details about the error + -> TcRnMessage + + {-| TcRnUnusedImport is a group of errors about unused imports. + -} + TcRnUnusedImport :: !(ImportDecl GhcRn) -- ^ The import + -> !UnusedImportReason -- ^ Details about the error + -> TcRnMessage + + {-| TcRnDuplicateDecls is an error indicating that the same name was used for + multiple declarations. + + Test cases: + FieldSelectors, overloadedrecfldsfail03, T17965, NFSDuplicate, T9975a, + TDMultiple01, mod19, mod38, mod21, mod66, mod20, TDPunning, mod18, mod22, + TDMultiple02, T4127a, ghci048, T8932, rnfail015, rnfail010, rnfail011, + rnfail013, rnfail002, rnfail003, rn_dup, rnfail009, T7164, rnfail043, + TH_dupdecl, rnfail012 + -} + TcRnDuplicateDecls :: !OccName -- ^ The name of the declarations + -> !(NE.NonEmpty Name) -- ^ The individual declarations + -> TcRnMessage + + {-| TcRnPackageImportsDisabled is an error indicating that an import uses + a package qualifier while the extension PackageImports was disabled. + + Test cases: + PackageImportsDisabled + -} + TcRnPackageImportsDisabled :: TcRnMessage + + {-| TcRnIllegalDataCon is an error indicating that a data constructor was + defined using a lowercase name, or a symbolic name in prefix position. + Mostly caught by PsErrNotADataCon. + + Test cases: + None + -} + TcRnIllegalDataCon :: !RdrName -- ^ The constructor name + -> TcRnMessage + + {-| TcRnNestedForallsContexts is an error indicating that multiple foralls or + contexts are nested/curried where this is not supported, + like @∀ x. ∀ y.@ instead of @∀ x y.@. + + Test cases: + T12087, T14320, T16114, T16394, T16427, T18191, T18240a, T18240b, T18455, T5951 + -} + TcRnNestedForallsContexts :: !NestedForallsContextsIn -> TcRnMessage + + {-| TcRnRedundantRecordWildcard is a warning indicating that a pattern uses + a record wildcard even though all of the record's fields are bound explicitly. + + Test cases: + T15957_Fail + -} + TcRnRedundantRecordWildcard :: TcRnMessage + + {-| TcRnUnusedRecordWildcard is a warning indicating that a pattern uses + a record wildcard while none of the fields bound by it are used. + + Test cases: + T15957_Fail + -} + TcRnUnusedRecordWildcard :: ![Name] -- ^ The names bound by the wildcard + -> TcRnMessage + + {-| TcRnUnusedName is a warning indicating that a defined or imported name + is not used in the module. + + Test cases: + ds053, mc10, overloadedrecfldsfail05, overloadedrecfldsfail06, prog018, + read014, rn040, rn041, rn047, rn063, T13839, T13839a, T13919, T17171b, + T17a, T17b, T17d, T17e, T18470, T1972, t22391, t22391j, T2497, T3371, + T3449, T7145b, T7336, TH_recover_warns, unused_haddock, WarningGroups, + werror + -} + TcRnUnusedName :: !OccName -- ^ The unused name + -> !UnusedNameProv -- ^ The provenance of the name + -> TcRnMessage + + {-| TcRnQualifiedBinder is an error indicating that a qualified name + was used in binding position. + + Test cases: + mod62, rnfail021, rnfail034, rnfail039, rnfail046 + -} + TcRnQualifiedBinder :: !RdrName -- ^ The name used as a binder + -> TcRnMessage + + {-| TcRnTypeApplicationsDisabled is an error indicating that a type + application was used while the extension TypeApplications was disabled. + + Test cases: + T12411, T12446, T15527, T16133, T18251c + -} + TcRnTypeApplicationsDisabled :: !(HsType GhcPs) + -> !TypeOrKind + -> TcRnMessage + + {-| TcRnInvalidRecordField is an error indicating that a record field was + used that doesn't exist in a constructor. + + Test cases: + T13644, T13847, T17469, T8448, T8570, tcfail083, tcfail084 + -} + TcRnInvalidRecordField :: !Name -- ^ The constructor name + -> !FieldLabelString -- ^ The name of the field + -> TcRnMessage + + {-| TcRnTupleTooLarge is an error indicating that the arity of a tuple + exceeds mAX_TUPLE_SIZE. + + Test cases: + T18723a, T18723b, T18723c, T6148a, T6148b, T6148c, T6148d + -} + TcRnTupleTooLarge :: !Int -- ^ The arity of the tuple + -> TcRnMessage + + {-| TcRnCTupleTooLarge is an error indicating that the arity of a constraint + tuple exceeds mAX_CTUPLE_SIZE. + + Test cases: + T10451 + -} + TcRnCTupleTooLarge :: !Int -- ^ The arity of the constraint tuple + -> TcRnMessage + + {-| TcRnIllegalInferredTyVars is an error indicating that some type variables + were quantified as inferred (like @∀ {a}.@) in a place where this is not + allowed, like in an instance declaration. + + Test cases: + ExplicitSpecificity5, ExplicitSpecificity6, ExplicitSpecificity8, + ExplicitSpecificity9 + -} + TcRnIllegalInferredTyVars :: !(NE.NonEmpty (HsTyVarBndr Specificity GhcPs)) + -- ^ The offending type variables + -> TcRnMessage + + {-| TcRnAmbiguousName is an error indicating that an unbound name + might refer to multiple names in scope. + + Test cases: + BootFldReexport, DRFUnused, duplicaterecfldsghci01, GHCiDRF, mod110, + mod151, mod152, mod153, mod164, mod165, NoFieldSelectorsFail, + overloadedrecfldsfail02, overloadedrecfldsfail04, overloadedrecfldsfail11, + overloadedrecfldsfail12, overloadedrecfldsfail13, + overloadedrecfldswasrunnowfail06, rnfail044, T11167_ambig, + T11167_ambiguous_fixity, T13132_duplicaterecflds, T15487, T16745, T17420, + T18999_NoDisambiguateRecordFields, T19397E1, T19397E2, T23010_fail, + tcfail037 + -} + TcRnAmbiguousName :: !GlobalRdrEnv + -> !RdrName -- ^ The name + -> !(NE.NonEmpty GlobalRdrElt) -- ^ The possible matches + -> TcRnMessage + + {-| TcRnBindingNameConflict is an error indicating that multiple local or + top-level bindings have the same name. + + Test cases: + dsrun006, mdofail002, mdofail003, mod23, mod24, qq006, rnfail001, + rnfail004, SimpleFail6, T14114, T16110_Fail1, tcfail038, TH_spliceD1, + T22478b, TyAppPat_NonlinearMultiAppPat, TyAppPat_NonlinearMultiPat, + TyAppPat_NonlinearSinglePat, + -} + TcRnBindingNameConflict :: !RdrName -- ^ The conflicting name + -> !(NE.NonEmpty SrcSpan) + -- ^ The locations of the duplicates + -> TcRnMessage + + {-| TcRnNonCanonicalDefinition is a warning indicating that an instance + defines an implementation for a method that should not be defined in a way + that deviates from its default implementation, for example because it has + been scheduled to be absorbed into another method, like @pure@ making + @return@ obsolete. + + Test cases: + WCompatWarningsOn, WCompatWarningsOff, WCompatWarningsOnOff + -} + TcRnNonCanonicalDefinition :: !NonCanonicalDefinition -- ^ Specifics + -> !(LHsSigType GhcRn) -- ^ The instance type + -> TcRnMessage + {-| TcRnImplicitImportOfPrelude is a warning, controlled by @Wimplicit-prelude@, + that is triggered upon an implicit import of the @Prelude@ module. + + Example: + + {-# OPTIONS_GHC -fwarn-implicit-prelude #-} + module M where {} + + Test case: rn055 + + -} + TcRnImplicitImportOfPrelude :: TcRnMessage + + {-| TcRnMissingMain is an error that occurs when a Main module does + not define a main function (named @main@ by default, but overridable + with the @main-is@ command line flag). + + Example: + + module Main where {} + + Test cases: + T414, T7765, readFail021, rnfail007, T13839b, T17171a, T16453E1, tcfail030, + T19397E3, T19397E4 + + -} + TcRnMissingMain + :: !Bool -- ^ whether the module has an explicit export list + -> !Module + -> !OccName -- ^ the expected name of the main function + -> TcRnMessage + + {-| TcRnGhciUnliftedBind is an error that occurs when a user attempts to + bind an unlifted value in GHCi. + + Example (in GHCi): + + let a = (# 1#, 3# #) + + Test cases: T9140, T19035b + -} + TcRnGhciUnliftedBind :: !Id -> TcRnMessage + + {-| TcRnGhciMonadLookupFail is an error that occurs when the user sets + the GHCi monad, using the GHC API 'setGHCiMonad' function, but GHC + can't find which monad the user is referring to. + + Example: + + import GHC ( setGHCiMonad ) + + ... setGHCiMonad "NoSuchThing" + + Test cases: none + -} + TcRnGhciMonadLookupFail + :: String -- ^ the textual name of the monad requested by the user + -> Maybe [GlobalRdrElt] -- ^ lookup result + -> TcRnMessage + + {-| TcRnMissingRoleAnnotation is a warning that occurs when type declaration + doesn't have a role annotatiosn + + Controlled by flags: + - Wmissing-role-annotations + + Test cases: + T22702 + + -} + TcRnMissingRoleAnnotation :: Name -> [Role] -> TcRnMessage + {-| TcRnPatersonCondFailure is an error that occurs when an instance + declaration fails to conform to the Paterson conditions. Which particular condition + fails depends on the constructor of PatersonCondFailure + See Note [Paterson conditions]. + + Test cases: + T15231, tcfail157, T15316, T19187a, fd-loop, tcfail108, tcfail154, + T15172, tcfail214 + -} + TcRnPatersonCondFailure + :: PatersonCondFailure -- ^ the failed Paterson Condition + -> PatersonCondFailureContext + -> Type -- ^ the LHS + -> Type -- ^ the RHS + -> TcRnMessage + + {-| TcRnImplicitRhsQuantification is a warning that occurs when GHC implicitly + quantifies over a type variable that occurs free on the RHS of the type declaration + that is not mentioned on the LHS + + Example: + + type T = 'Nothing :: Maybe a + + Controlled by flags: + - Wimplicit-rhs-quantification + + Test cases: + T23510a + T23510b + -} + TcRnImplicitRhsQuantification :: LocatedN RdrName -> TcRnMessage + + {-| TcRnIllformedTypePattern is an error raised when the pattern + corresponding to a required type argument (visible forall) + does not have a form that can be interpreted as a type pattern. + + Example: + + vfun :: forall (a :: k) -> () + vfun !x = () + -- ^^ + -- bang-patterns not allowed as type patterns + + Test cases: + T22326_fail_bang_pat + -} + TcRnIllformedTypePattern :: !(Pat GhcRn) -> TcRnMessage + + {-| TcRnIllegalTypePattern is an error raised when a pattern constructed + with the @type@ keyword occurs in a position that does not correspond + to a required type argument (visible forall). + + Example: + + case x of + (type _) -> True -- the (type _) pattern is illegal here + _ -> False + + Test cases: + T22326_fail_ado + T22326_fail_caseof + -} + TcRnIllegalTypePattern :: TcRnMessage + + {-| TcRnIllformedTypeArgument is an error raised when an argument + that specifies a required type argument (instantiates a visible forall) + does not have a form that can be interpreted as a type argument. + + Example: + + vfun :: forall (a :: k) -> () + x = vfun (\_ -> _) + -- ^^^^^^^^^ + -- lambdas not allowed in type arguments + + Test cases: + T22326_fail_lam_arg + -} + TcRnIllformedTypeArgument :: !(LHsExpr GhcRn) -> TcRnMessage + + {- TcRnIllegalTypeExpr is an error raised when an expression constructed with + type syntax (@type@, @->@, @=>@, @forall@) occurs in a position that + doesn't correspond to required type argument (visible forall). + + Examples: + + -- Not a function argument: + xtop1 = type Int + xtop2 = (Int -> Int) + xtop3 = (forall a. a) + xtop4 = ((Show Int, Eq Bool) => Unit) + + -- The function does not expect a type argument: + xarg1 = length (type Int) + xarg2 = show (Int -> Int) + + Test cases: + T22326_fail_app + T22326_fail_top + T24159_type_syntax_tc_fail + -} + TcRnIllegalTypeExpr :: TypeSyntax -> TcRnMessage + + {-| TcRnInvalidDefaultedTyVar is an error raised when a + defaulting plugin proposes to default a type variable that is + not an unfilled metavariable + + Test cases: + T23832_invalid + -} + TcRnInvalidDefaultedTyVar + :: ![Ct] -- ^ The constraints passed to the plugin + -> [(TcTyVar, Type)] -- ^ The plugin-proposed type variable defaults + -> NE.NonEmpty TcTyVar -- ^ The invalid type variables of the proposal + -> TcRnMessage + + {-| TcRnNamespacedWarningPragmaWithoutFlag is an error that occurs when + a namespace specifier is used in {-# WARNING ... #-} or {-# DEPRECATED ... #-} + pragmas without the -XExplicitNamespaces extension enabled + + Example: + + {-# LANGUAGE NoExplicitNamespaces #-} + f = id + {-# WARNING data f "some warning message" #-} + + Test cases: + T24396c + -} + TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage + + {-| TcRnIllegalInvisibleTypePattern is an error raised when an invisible + type pattern, i.e. a pattern of the form `@p`, is rejected. + + Example for InvisPatWithoutFlag: + + {-# LANGUAGE NoTypeAbstractions #-} + id :: a -> a + id @t x = x + + Examples for InvisPatNoForall: + + f :: Int + f @t = 5 + + g :: [a -> a] + g = [\ @t x -> x :: t] + + Examples for InvisPatMisplaced: + + f (smth, $(invisP (varT (newName "blah")))) = ... + + g = do + $(invisP (varT (newName "blah"))) <- aciton1 + ... + + Test cases: + T17694b -- InvisPatWithoutFlag + T17694c -- InvisPatNoForall + T17594d -- InvisPatNoForall + T24557a -- InvisPatMisplaced + T24557b -- InvisPatMisplaced + T24557c -- InvisPatMisplaced + T24557d -- InvisPatMisplaced + -} + TcRnIllegalInvisibleTypePattern + :: !(HsTyPat GhcRn) -- the rejected type pattern + -> !BadInvisPatReason -- the reason for rejection + -> TcRnMessage + + {-| TcRnNamespacedFixitySigWithoutFlag is an error that occurs when + a namespace specifier is used in fixity signatures + without the -XExplicitNamespaces extension enabled + + Example: + + {-# LANGUAGE NoExplicitNamespaces #-} + f = const + infixl 7 data `f` + + Test cases: + T14032c + -} + TcRnNamespacedFixitySigWithoutFlag :: FixitySig GhcPs -> TcRnMessage + + {-| TcRnDefaultedExceptionContext is a warning that is triggered when the + backward-compatibility logic solving for implicit ExceptionContext + constraints fires. + + Test cases: DefaultExceptionContext + -} + TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage + + {-| TcRnOutOfArityTyVar is an error raised when the arity of a type synonym + (as determined by the SAKS and the LHS) is insufficiently high to + accommodate an implicit binding for a free variable that occurs in the + outermost kind signature on the RHS of the said type synonym. + + Example: + + type SynBad :: forall k. k -> Type + type SynBad = Proxy :: j -> Type + + Test cases: + T24770a + -} + TcRnOutOfArityTyVar + :: Name -- ^ Type synonym's name + -> Name -- ^ Type variable's name + -> TcRnMessage + + {- TcRnUnexpectedTypeSyntaxInTerms is an error that occurs + when type syntax is used in terms without -XRequiredTypeArguments + extension enabled + + Examples: + + idVis (forall a. forall b -> (a ~ Int, b ~ Bool) => a -> b) + + Test cases: T24159_type_syntax_rn_fail + -} + TcRnUnexpectedTypeSyntaxInTerms :: TypeSyntax -> TcRnMessage + deriving Generic + +---- + +data ZonkerMessage where + {-| ZonkerCannotDefaultConcrete is an error occurring when a concrete + type variable cannot be defaulted. + + Test cases: + T23153 + -} + ZonkerCannotDefaultConcrete + :: !FixedRuntimeRepOrigin + -> ZonkerMessage + + deriving Generic + +---- + +-- | Things forbidden in @type data@ declarations. +-- See Note [Type data declarations] +data TypeDataForbids + = TypeDataForbidsDatatypeContexts + | TypeDataForbidsLabelledFields + | TypeDataForbidsStrictnessAnnotations + | TypeDataForbidsDerivingClauses + deriving Generic + +instance Outputable TypeDataForbids where + ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" + ppr TypeDataForbidsLabelledFields = text "Labelled fields" + ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" + ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" + +-- | Specifies which back ends can handle a requested foreign import or export +type ExpectedBackends = [Backend] + +-- | Specifies which calling convention is unsupported on the current platform +data UnsupportedCallConvention + = StdCallConvUnsupported + | PrimCallConvUnsupported + | JavaScriptCallConvUnsupported + deriving Eq + +-- | Whether the error pertains to a function argument or a result. +data ArgOrResult + = Arg | Result + +-- | Which parts of a record field are affected by a particular error or warning. +data RecordFieldPart + = RecordFieldDecl !Name + | RecordFieldConstructor !Name + | RecordFieldPattern !Name + | RecordFieldUpdate + +-- | Why did we reject a record update? +data BadRecordUpdateReason + -- | No constructor has all of the required fields. + = NoConstructorHasAllFields + { conflictingFields :: [FieldLabelString] } + + -- | There are several possible parents which have all of the required fields, + -- and we weren't able to disambiguate in any way. + | MultiplePossibleParents + (RecSelParent, RecSelParent, [RecSelParent]) + -- ^ The possible parents (at least 2) + + -- | We used type-directed disambiguation, but this resulted in + -- an invalid parent (the type-directed parent is not among the + -- parents we computed from the field labels alone). + | InvalidTyConParent TyCon (NE.NonEmpty RecSelParent) + + deriving Generic + +-- | Where a shadowed name comes from +data ShadowedNameProvenance + = ShadowedNameProvenanceLocal !SrcLoc + -- ^ The shadowed name is local to the module + | ShadowedNameProvenanceGlobal [GlobalRdrElt] + -- ^ The shadowed name is global, typically imported from elsewhere. + +-- | Information about a resolved name +data ResolvedNameInfo + = ResolvedNameInfo ![GlobalRdrElt] !RdrName !Name + +instance Outputable ResolvedNameInfo where + ppr (ResolvedNameInfo _ rdr name) = ppr (WithUserRdr rdr name) + +pprResolvedNameProvenance :: ResolvedNameInfo -> SDoc +pprResolvedNameProvenance (ResolvedNameInfo gres _ name) + | gre:_ <- gres = pprNameProvenance gre + | otherwise = text "bound at" <+> ppr (getSrcLoc name) + +-- | In what context did we require a type to have a fixed runtime representation? +-- +-- Used by 'GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep' for throwing +-- representation polymorphism errors when validity checking. +-- +-- See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +data FixedRuntimeRepProvenance + -- | Data constructor fields must have a fixed runtime representation. + -- + -- Tests: T11734, T18534. + = FixedRuntimeRepDataConField + + -- | Pattern synonym signature arguments must have a fixed runtime representation. + -- + -- Test: RepPolyPatSynArg. + | FixedRuntimeRepPatSynSigArg + + -- | Pattern synonym signature scrutinee must have a fixed runtime representation. + -- + -- Test: RepPolyPatSynRes. + | FixedRuntimeRepPatSynSigRes + +pprFixedRuntimeRepProvenance :: FixedRuntimeRepProvenance -> SDoc +pprFixedRuntimeRepProvenance FixedRuntimeRepDataConField = text "data constructor field" +pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigArg = text "pattern synonym argument" +pprFixedRuntimeRepProvenance FixedRuntimeRepPatSynSigRes = text "pattern synonym scrutinee" + +-- | Why the particular illegal newtype error arose together with more +-- information, if any. +data IllegalNewtypeReason + = DoesNotHaveSingleField !Int + | IsNonLinear + | IsGADT + | HasConstructorContext + | HasExistentialTyVar + | HasStrictnessAnnotation + deriving Generic + +-- | Why the particular injectivity error arose together with more information, +-- if any. +data InjectivityErrReason + = InjErrRhsBareTyVar [Type] + | InjErrRhsCannotBeATypeFam + | InjErrRhsOverlap + | InjErrCannotInferFromRhs !TyVarSet !HasKinds !SuggestUndecidableInstances + +data HasKinds + = YesHasKinds + | NoHasKinds + deriving (Show, Eq) + +hasKinds :: Bool -> HasKinds +hasKinds True = YesHasKinds +hasKinds False = NoHasKinds + +data SuggestUndecidableInstances + = YesSuggestUndecidableInstaces + | NoSuggestUndecidableInstaces + deriving (Show, Eq) + +suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances +suggestUndecidableInstances True = YesSuggestUndecidableInstaces +suggestUndecidableInstances False = NoSuggestUndecidableInstaces + +data SuggestUnliftedTypes + = SuggestUnliftedNewtypes + | SuggestUnliftedDatatypes + +-- | A description of whether something is a +-- +-- * @data@ or @newtype@ ('DataDeclSort') +-- +-- * @data instance@ or @newtype instance@ ('DataInstanceSort') +-- +-- * @data family@ ('DataFamilySort') +-- +-- At present, this data type is only consumed by 'checkDataKindSig'. +data DataSort + = DataDeclSort NewOrData + | DataInstanceSort NewOrData + | DataFamilySort + +ppDataSort :: DataSort -> SDoc +ppDataSort data_sort = text $ + case data_sort of + DataDeclSort DataType -> "Data type" + DataDeclSort NewType -> "Newtype" + DataInstanceSort DataType -> "Data instance" + DataInstanceSort NewType -> "Newtype instance" + DataFamilySort -> "Data family" + +-- | Helper type used in 'checkDataKindSig'. +-- +-- Superficially similar to 'ContextKind', but it lacks 'AnyKind' +-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@ +-- provides 'LiftedKind', which is much simpler to match on and +-- handle in 'isAllowedDataResKind'. +data AllowedDataResKind + = AnyTYPEKind + | AnyBoxedKind + | LiftedKind + +-- | A data type to describe why a variable is not closed. +-- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr +data NotClosedReason = NotLetBoundReason + | NotTypeClosed VarSet + | NotClosed Name NotClosedReason + +data SuggestPartialTypeSignatures + = YesSuggestPartialTypeSignatures + | NoSuggestPartialTypeSignatures + deriving (Show, Eq) + +suggestPartialTypeSignatures :: Bool -> SuggestPartialTypeSignatures +suggestPartialTypeSignatures True = YesSuggestPartialTypeSignatures +suggestPartialTypeSignatures False = NoSuggestPartialTypeSignatures + +data UsingGeneralizedNewtypeDeriving + = YesGeneralizedNewtypeDeriving + | NoGeneralizedNewtypeDeriving + deriving Eq + +usingGeneralizedNewtypeDeriving :: Bool -> UsingGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving True = YesGeneralizedNewtypeDeriving +usingGeneralizedNewtypeDeriving False = NoGeneralizedNewtypeDeriving + +data DeriveAnyClassEnabled + = YesDeriveAnyClassEnabled + | NoDeriveAnyClassEnabled + deriving Eq + +deriveAnyClassEnabled :: Bool -> DeriveAnyClassEnabled +deriveAnyClassEnabled True = YesDeriveAnyClassEnabled +deriveAnyClassEnabled False = NoDeriveAnyClassEnabled + +-- | Why a particular typeclass instance couldn't be derived. +data DeriveInstanceErrReason + = + -- | The typeclass instance is not well-kinded. + DerivErrNotWellKinded !TyCon + -- ^ The type constructor that occurs in + -- the typeclass instance declaration. + !Kind + -- ^ The typeclass kind. + !Int + -- ^ The number of typeclass arguments that GHC + -- kept. See Note [tc_args and tycon arity] in + -- GHC.Tc.Deriv. + -- | Generic instances can only be derived using the stock strategy + -- in Safe Haskell. + | DerivErrSafeHaskellGenericInst + | DerivErrDerivingViaWrongKind !Kind !Type !Kind + | DerivErrNoEtaReduce !Type + -- ^ The instance type + -- | We cannot derive instances in boot files + | DerivErrBootFileFound + | DerivErrDataConsNotAllInScope !TyCon + -- | We cannot use GND on non-newtype types + | DerivErrGNDUsedOnData + -- | We cannot derive instances of nullary classes + | DerivErrNullaryClasses + -- | Last arg must be newtype or data application + | DerivErrLastArgMustBeApp + | DerivErrNoFamilyInstance !TyCon [Type] + | DerivErrNotStockDeriveable !DeriveAnyClassEnabled + | DerivErrHasAssociatedDatatypes !HasAssociatedDataFamInsts + !AssociatedTyLastVarInKind + !AssociatedTyNotParamOverLastTyVar + | DerivErrNewtypeNonDeriveableClass + | DerivErrCannotEtaReduceEnough !Bool -- Is eta-reduction OK? + | DerivErrOnlyAnyClassDeriveable !TyCon + -- ^ Type constructor for which the instance + -- is requested + !DeriveAnyClassEnabled + -- ^ Whether or not -XDeriveAnyClass is enabled + -- already. + -- | Stock deriving won't work, but perhaps DeriveAnyClass will. + | DerivErrNotDeriveable !DeriveAnyClassEnabled + -- | The given 'PredType' is not a class. + | DerivErrNotAClass !PredType + -- | The given (representation of the) 'TyCon' has no + -- data constructors. + | DerivErrNoConstructors !TyCon + | DerivErrLangExtRequired !LangExt.Extension + -- | GHC simply doesn't how to how derive the input 'Class' for the given + -- 'Type'. + | DerivErrDunnoHowToDeriveForType !Type + -- | The given 'TyCon' must be an enumeration. + -- See Note [Enumeration types] in GHC.Core.TyCon + | DerivErrMustBeEnumType !TyCon + -- | The given 'TyCon' must have /precisely/ one constructor. + | DerivErrMustHaveExactlyOneConstructor !TyCon + -- | The given data type must have some parameters. + | DerivErrMustHaveSomeParameters !TyCon + -- | The given data type must not have a class context. + | DerivErrMustNotHaveClassContext !TyCon !ThetaType + -- | We couldn't derive an instance for a particular data constructor + -- for a variety of reasons. + | DerivErrBadConstructor !(Maybe HasWildcard) [DeriveInstanceBadConstructor] + -- | We couldn't derive a 'Generic' instance for the given type for a + -- variety of reasons + | DerivErrGenerics [DeriveGenericsErrReason] + -- | We couldn't derive an instance either because the type was not an + -- enum type or because it did have more than one constructor. + | DerivErrEnumOrProduct !DeriveInstanceErrReason !DeriveInstanceErrReason + deriving Generic + +data DeriveInstanceBadConstructor + = + -- | The given 'DataCon' must be truly polymorphic in the + -- last argument of the data type. + DerivErrBadConExistential !DataCon + -- | The given 'DataCon' must not use the type variable in a function argument" + | DerivErrBadConCovariant !DataCon + -- | The given 'DataCon' must not contain function types + | DerivErrBadConFunTypes !DataCon + -- | The given 'DataCon' must use the type variable only + -- as the last argument of a data type + | DerivErrBadConWrongArg !DataCon + -- | The given 'DataCon' is a GADT so we cannot directly + -- derive an istance for it. + | DerivErrBadConIsGADT !DataCon + -- | The given 'DataCon' has existentials type vars in its type. + | DerivErrBadConHasExistentials !DataCon + -- | The given 'DataCon' has constraints in its type. + | DerivErrBadConHasConstraints !DataCon + -- | The given 'DataCon' has a higher-rank type. + | DerivErrBadConHasHigherRankType !DataCon + +data DeriveGenericsErrReason + = -- | The type must not have some datatype context. + DerivErrGenericsMustNotHaveDatatypeContext !TyCon + -- | The data constructor must not have exotic unlifted + -- or polymorphic arguments. + | DerivErrGenericsMustNotHaveExoticArgs !DataCon + -- | The data constructor must be a vanilla constructor. + | DerivErrGenericsMustBeVanillaDataCon !DataCon + -- | The type must have some type parameters. + -- check (d) from Note [Requirements for deriving Generic and Rep] + -- in GHC.Tc.Deriv.Generics. + | DerivErrGenericsMustHaveSomeTypeParams !TyCon + -- | The data constructor must not have existential arguments. + | DerivErrGenericsMustNotHaveExistentials !DataCon + -- | The derivation applies a type to an argument involving + -- the last parameter but the applied type is not of kind * -> *. + | DerivErrGenericsWrongArgKind !DataCon + +data HasWildcard + = YesHasWildcard + | NoHasWildcard + deriving Eq + +hasWildcard :: Bool -> HasWildcard +hasWildcard True = YesHasWildcard +hasWildcard False = NoHasWildcard + +-- | A context in which we don't allow anonymous wildcards. +data BadAnonWildcardContext + = WildcardNotLastInConstraint + | ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardAllowed + | WildcardsNotAllowedAtAll + + -- See Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type + | WildcardBndrInForallTelescope + | WildcardBndrInTyFamResultVar + +-- | Whether a sole extra-constraint wildcard is allowed, +-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@. +data SoleExtraConstraintWildcardAllowed + = SoleExtraConstraintWildcardNotAllowed + | SoleExtraConstraintWildcardAllowed + +-- | Why is a class instance head invalid? +data IllegalInstanceHeadReason + -- | An instance for an abstract class from an hs-boot or Backpack + -- hsig file. + -- + -- Example: + -- + -- -- A.hs-boot + -- module A where + -- class C a + -- + -- -- B.hs + -- module B where + -- import {-# SOURCE #-} A + -- instance C Int where + -- + -- -- A.hs + -- module A where + -- import B + -- class C a where + -- f :: a + -- + -- Test cases: typecheck/should_fail/T13068 + = InstHeadAbstractClass !(WithUserRdr Name) -- ^ name of the abstract 'Class' + -- | An instance whose head is not a class. + -- + -- Examples(s): + -- + -- instance c + -- + -- instance 42 + -- + -- instance !Show D + -- + -- type C1 a = (Show (a -> Bool)) + -- instance C1 Int where + -- + -- Test cases: typecheck/rename/T5513 + -- typecheck/rename/T16385 + -- parser/should_fail/T3811c + -- rename/should_fail/T18240a + -- polykinds/T13267 + -- deriving/should_fail/T23522 + | InstHeadNonClassHead InstHeadNonClassHead + + -- | Instance head was headed by a type synonym. + -- + -- Example: + -- type MyInt = Int + -- class C a where {..} + -- instance C MyInt where {..} + -- + -- Test cases: drvfail015, mod42, TidyClassKinds, tcfail139 + | InstHeadTySynArgs + -- | Instance head was not of the form @T a1 ... an@, + -- where @a1, ..., an@ are all type variables or literals. + -- + -- Example: + -- + -- instance Num [Int] where {..} + -- + -- Test cases: mod41, mod42, tcfail044, tcfail047. + | InstHeadNonTyVarArgs + -- | Multi-param instance without -XMultiParamTypeClasses. + -- + -- Example: + -- + -- instance C a b where {..} + -- + -- Test case: IllegalMultiParamInstance + | InstHeadMultiParam + deriving Generic + + +-- | What was at the head of an instance head, when we expected a class? +data InstHeadNonClassHead + -- | A 'TyCon' that isn't a class was at the head + = InstNonClassTyCon (WithUserRdr Name) (TyConFlavour Name) + -- | Something else than a 'TyCon' was at the head + | InstNonTyCon + +-- | Why is a (type or data) family instance invalid? +data IllegalFamilyInstanceReason + {-| A top-level family instance for a 'TyCon' that isn't a family 'TyCon'. + + Example: + + data D a = MkD + type instance D Int = Bool + + Test case: indexed-types/should_fail/T3092 + -} + = NotAFamilyTyCon + !TypeOrData -- ^ was this a 'type' or a 'data' instance? + !TyCon + {-| A top-level (open) type family instance for a closed type family. + + Test cases: + indexed-types/should_fail/Overlap7 + indexed-types/should_fail/Overlap3 + -} + | NotAnOpenFamilyTyCon !TyCon + + {-| A family instance was declared for a family of a different kind, + e.g. a data instance for a type family 'TyCon'. + + Test cases: + T9896, SimpleFail3a + -} + | FamilyCategoryMismatch !TyCon -- ^ The family tycon + + + {-| A family instance was declared with a different number of arguments + than expected. + See Note [Oversaturated type family equations] in "GHC.Tc.Validity". + + Test cases: + TyFamArity1, TyFamArity2, T11136, Overlap4, AssocTyDef05, AssocTyDef06, + T14110 + -} + | FamilyArityMismatch !TyCon -- ^ The family tycon + !Arity -- ^ The right number of parameters + + {-| A closed type family equation used a different name than the parent family. + + Example: + + type family F a where + G Int = Bool + + Test cases: + Overlap5, T15362, T16002, T20260, T11623 + -} + | TyFamNameMismatch !Name -- ^ The family name + !Name -- ^ The name used in the equation + + + -- | There are out-of-scope type variables in the right-hand side + -- of an associated type or data family instance. + -- + -- Example: + -- + -- instance forall a. C Int where + -- data instance D Int = MkD1 a + -- + -- Test cases: indexed-types/should_fail/T5515, polykinds/T9574, rename/should_fail/T18021 + | FamInstRHSOutOfScopeTyVars + !(Maybe (TyCon, [Type], TyVarSet)) + -- ^ family 'TyCon', arguments, and set of "dodgy" type variables + -- See Note [Dodgy binding sites in type family instances] + -- in GHC.Tc.Validity + !(NE.NonEmpty Name) -- ^ the out-of-scope type variables + + | FamInstLHSUnusedBoundTyVars + !(NE.NonEmpty InvalidFamInstQTv) -- ^ the unused bound type variables + + | InvalidAssoc !InvalidAssoc + deriving Generic + +-- | A quantified type variable in a type or data family equation that +-- is either not bound in any LHS patterns or not used in the RHS (or both). +data InvalidFamInstQTv + = InvalidFamInstQTv + { ifiqtv :: TcTyVar + , ifiqtv_user_written :: Bool + -- ^ Did the user write this type variable, or was introduced by GHC? + -- For example: with @-XPolyKinds@, in @type instance forall a. F = ()@, + -- we have a user-written @a@ but GHC introduces a kind variable @k@ + -- as well. See #23734. + , ifiqtv_reason :: InvalidFamInstQTvReason + -- ^ For what reason was the quantified type variable invalid? + } + +data InvalidFamInstQTvReason + -- | A dodgy binder, i.e. a variable that syntactically appears in + -- LHS patterns but only in non-injective positions. + -- + -- See Note [Dodgy binding sites in type family instances] + -- in GHC.Tc.Validity. + = InvalidFamInstQTvDodgy + -- | A quantified type variable in a type or data family equation + -- that is not bound in any LHS patterns. + | InvalidFamInstQTvNotBoundInPats + -- | A quantified type variable in a type or data family equation + -- that is not used on the RHS. + | InvalidFamInstQTvNotUsedInRHS + +-- The 'check_tvs' function in 'GHC.Tc.Validity.checkFamPatBinders' +-- uses 'getSrcSpan', so this 'NamedThing' instance is convenient. +instance NamedThing InvalidFamInstQTv where + getName = getName . ifiqtv + +data InvalidAssoc + -- | An invalid associated family instance. + -- + -- See t'InvalidAssocInstance'.Builder + = InvalidAssocInstance !InvalidAssocInstance + -- | An invalid associated family default declaration. + -- + -- See t'InvalidAssocDefault'. + | InvalidAssocDefault !InvalidAssocDefault + deriving Generic + +-- | The reason that an associated family instance was invalid. +data InvalidAssocInstance + -- | A class instance is missing its expected associated type/data instance. + -- + -- Test cases: deriving/should_compile/T14094 + -- indexed-types/should_compile/Simple2 + -- typecheck/should_compile/tc254 + = AssocInstanceMissing !Name + + -- | A top-level instance for an associated family 'TyCon'. + -- + -- Example: + -- + -- class C a where { type T a } + -- instance T Int = Bool + -- + -- Test case: indexed-types/should_fail/SimpleFail7 + | AssocInstanceNotInAClass !TyCon + + -- | An associated type instance is provided for a class that doesn't have + -- that associated type. + -- + -- Examples(s): + -- $(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo) + -- [tySynInstD $ tySynEqn Nothing (conT ''Rep `appT` conT ''Foo) (conT ''Maybe)] + -- return [d]) + -- ======> + -- instance Eq Foo where + -- type Rep Foo = Maybe + -- + -- Test cases: th/T12387a + | AssocNotInThisClass !Class !TyCon + -- | An associated family instance does not mention any of the parent 'Class' + -- 'TyVar's. + -- + -- Test cases: T2888, T9167, T12867 + | AssocNoClassTyVar !Class !TyCon + + | AssocTyVarsDontMatch + !ForAllTyFlag + !TyCon -- ^ family 'TyCon' + ![Type] -- ^ expected type arguments + ![Type] -- ^ actual type arguments + deriving Generic + + +-- | The reason that an associated family default declaration was invalid. +data InvalidAssocDefault + -- | An associated family default declaration for something that isn't + -- an associated family. + = AssocDefaultNotAssoc !Name -- ^ 'Class' 'Name' + !Name -- ^ 'TyCon' 'Name' + -- | Multiple default declarations were given for an associated + -- family instance. + -- + -- Test cases: none. + | AssocMultipleDefaults !Name + -- | Invalid arguments in an associated family instance default declaration. + -- + -- See t'AssocDefaultBadArgs'. + | AssocDefaultBadArgs !TyCon ![Type] AssocDefaultBadArgs + deriving Generic + +-- | Invalid arguments in an associated family instance declaration. +data AssocDefaultBadArgs + -- | An argument which isn't a type variable in an associated + -- family instance default declaration. + = AssocDefaultNonTyVarArg !(Type, ForAllTyFlag) + -- | Duplicate occurrence of a type variable in an associated + -- family instance default declaration. + | AssocDefaultDuplicateTyVars !(NE.NonEmpty (TyCoVar, ForAllTyFlag)) + deriving Generic + +-- | A type representing whether or not the input type has associated data family instances. +data HasAssociatedDataFamInsts + = YesHasAdfs + | NoHasAdfs + deriving Eq + +hasAssociatedDataFamInsts :: Bool -> HasAssociatedDataFamInsts +hasAssociatedDataFamInsts True = YesHasAdfs +hasAssociatedDataFamInsts False = NoHasAdfs + +-- | If 'YesAssocTyLastVarInKind', the associated type of a typeclass +-- contains the last type variable of the class in a kind, which is not (yet) allowed +-- by GHC. +data AssociatedTyLastVarInKind + = YesAssocTyLastVarInKind !TyCon -- ^ The associated type family of the class + | NoAssocTyLastVarInKind + deriving Eq + +associatedTyLastVarInKind :: Maybe TyCon -> AssociatedTyLastVarInKind +associatedTyLastVarInKind (Just tc) = YesAssocTyLastVarInKind tc +associatedTyLastVarInKind Nothing = NoAssocTyLastVarInKind + +-- | If 'NoAssociatedTyNotParamOverLastTyVar', the associated type of a +-- typeclass is not parameterized over the last type variable of the class +data AssociatedTyNotParamOverLastTyVar + = YesAssociatedTyNotParamOverLastTyVar !TyCon -- ^ The associated type family of the class + | NoAssociatedTyNotParamOverLastTyVar + deriving Eq + +associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar +associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc +associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar + +-- | What kind of thing is missing a type signature? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'tcRnMissingSignature'. +data MissingSignature + = MissingTopLevelBindingSig Name Type + | MissingPatSynSig PatSyn + | MissingTyConKindSig + TyCon + Bool -- ^ whether -XCUSKs is enabled + +-- | Is the object we are dealing with exported or not? +-- +-- Used for reporting @"missing signature"@ warnings, see +-- 'TcRnMissingSignature'. +data Exported + = IsNotExported + | IsExported + deriving Eq + +instance Outputable Exported where + ppr IsNotExported = text "IsNotExported" + ppr IsExported = text "IsExported" + +-- | What declarations were not allowed in an hs-boot or hsig file? +data BadBootDecls + = BootBindsPs !(NE.NonEmpty (LHsBindLR GhcRn GhcPs)) + | BootBindsRn !(NE.NonEmpty (LHsBindLR GhcRn GhcRn)) + | BootInstanceSigs !(NE.NonEmpty (LSig GhcRn)) + | BootFamInst !TyCon + | BootSpliceDecls !(NE.NonEmpty (LocatedA (HsUntypedSplice GhcPs))) + | BootForeignDecls !(NE.NonEmpty (LForeignDecl GhcRn)) + | BootDefaultDecls !(NE.NonEmpty (LDefaultDecl GhcRn)) + | BootRuleDecls !(NE.NonEmpty (LRuleDecls GhcRn)) + +-- | A mismatch between an hs-boot or signature file and its implementing module. +data BootMismatch + -- | Something defined or exported by an hs-boot or signature file + -- is missing from the implementing module. + = MissingBootThing !Name !MissingBootThing + + -- | A typeclass instance is declared in the hs-boot file but + -- it is not present in the implementing module. + | MissingBootInstance !DFunId -- ^ the boot instance 'DFunId' + -- NB: we never trigger this for hsig files, as in that case we do + -- a full round of constraint solving, and a missing instance gets reported + -- as an unsolved Wanted constraint with a 'InstProvidedOrigin' 'CtOrigin'. + -- See GHC.Tc.Utils.Backpack.check_inst. + + -- | A mismatch between an hsig file and its implementing module + -- in the 'Name' that a particular re-export refers to. + | BadReexportedBootThing !Name !Name + + -- | A mismatch between the declaration of something in the hs-boot or + -- signature file and its implementation, e.g. a type mismatch or + -- a type family implemented as a class. + | BootMismatch + !TyThing -- ^ boot thing + !TyThing -- ^ real thing + !BootMismatchWhat + deriving Generic + +-- | Something from the hs-boot or signature file is missing from the +-- implementing module. +data MissingBootThing + -- | Something defined in the hs-boot or signature file is not defined in the + -- implementing module. + = MissingBootDefinition + -- | Something exported by the hs-boot or signature file is not exported by the + -- implementing module. + | MissingBootExport + deriving Generic + +missingBootThing :: HsBootOrSig -> Name -> MissingBootThing -> TcRnMessage +missingBootThing src nm thing = + TcRnBootMismatch src (MissingBootThing nm thing) + +-- | A mismatch of two 'TyThing's between an hs-boot or signature file +-- and its implementing module. +data BootMismatchWhat + -- | The 'Id's have different types. + = BootMismatchedIdTypes !Id -- ^ boot 'Id' + !Id -- ^ real 'Id' + -- | Two 'TyCon's aren't compatible. + | BootMismatchedTyCons !TyCon -- ^ boot 'TyCon' + !TyCon -- ^ real 'TyCon' + !(NE.NonEmpty BootTyConMismatch) + deriving Generic + +-- | An error in the implementation of an abstract datatype using +-- a type synonym. +data SynAbstractDataError + -- | The type synony was not nullary. + = SynAbsDataTySynNotNullary + -- | The type synonym RHS contained invalid types, e.g. + -- a type family or a forall. + | SynAbstractDataInvalidRHS !(NE.NonEmpty Type) + +-- | Mismatched implementation of a 'TyCon' in an hs-boot or signature file. +data BootTyConMismatch + -- | The 'TyCon' kinds differ. + = TyConKindMismatch + -- | The 'TyCon' 'Role's aren't compatible. + | TyConRoleMismatch !Bool -- ^ True <=> role subtype check + -- | Two type synonyms have different RHSs. + | TyConSynonymMismatch !Kind !Kind + -- | The two 'TyCon's are of a different flavour, e.g. one is + -- a data family and the other is a type family. + | TyConFlavourMismatch !FamTyConFlav !FamTyConFlav + -- | The equations of a type family don't match. + | TyConAxiomMismatch !(BootListMismatches CoAxBranch BootAxiomBranchMismatch) + -- | The type family injectivity annotations don't match. + | TyConInjectivityMismatch + -- | The 'TyCon's are both datatype 'TyCon's, but they have diferent 'DataCon's. + | TyConMismatchedData !AlgTyConRhs !AlgTyConRhs !BootDataMismatch + -- | The 'TyCon's are both 'Class' 'TyCon's, but the classes don't match. + | TyConMismatchedClasses !Class !Class !BootClassMismatch + -- | The 'TyCon's are something completely different. + | TyConsVeryDifferent + -- | An abstract 'TyCon' is implemented using a type synonym in an invalid + -- manner. See 'SynAbstractDataError'. + | SynAbstractData !SynAbstractDataError + + +-- | Utility datatype to record errors when checking compatibity +-- between two lists of things, e.g. class methods, associated types, +-- type family equations, etc. +data BootListMismatch item err + -- | Different number of items. + = MismatchedLength + -- | The item at the given position in the list differs. + | MismatchedThing !Int !item !item !err + +type BootListMismatches item err = + NE.NonEmpty (BootListMismatch item err) + +data BootAxiomBranchMismatch + -- | The quantified variables in an equation don't match. + -- + -- Example: the quantification of @a@ in + -- + -- @type family F a where { forall a. F a = Maybe a }@ + = MismatchedAxiomBinders + -- | The LHSs of an equation don't match. + | MismatchedAxiomLHS + -- | The RHSs of an equation don't match. + | MismatchedAxiomRHS + +-- | A mismatch in a class, between its declaration in an hs-boot or signature +-- file, and its implementation in a source Haskell file. +data BootClassMismatch + -- | The class methods don't match. + = MismatchedMethods !(BootListMismatches ClassOpItem BootMethodMismatch) + -- | The associated types don't match. + | MismatchedATs !(BootListMismatches ClassATItem BootATMismatch) + -- | The functional dependencies don't match. + | MismatchedFunDeps + -- | The superclasses don't match. + | MismatchedSuperclasses + -- | The @MINIMAL@ pragmas are not compatible. + | MismatchedMinimalPragmas + +-- | A mismatch in a class method, between its declaration in an hs-boot or signature +-- file, and its implementation in a source Haskell file. +data BootMethodMismatch + -- | The class method names are different. + = MismatchedMethodNames + -- | The types of a class method are different. + | MismatchedMethodTypes !Type !Type + -- | The default method types are not compatible. + | MismatchedDefaultMethods !Bool -- ^ True <=> subtype check + +-- | A mismatch in an associated type of a class, between its declaration +-- in an hs-boot or signature file, and its implementation in a source Haskell file. +data BootATMismatch + -- | Two associated types don't match. + = MismatchedTyConAT !BootTyConMismatch + -- | Two associated type defaults don't match. + | MismatchedATDefaultType + +-- | A mismatch in a datatype declaration, between an hs-boot file or signature +-- file and its implementing module. +data BootDataMismatch + -- | A datatype is implemented as a newtype or vice-versa. + = MismatchedNewtypeVsData + -- | The constructors don't match. + | MismatchedConstructors !(BootListMismatches DataCon BootDataConMismatch) + -- | The datatype contexts differ. + | MismatchedDatatypeContexts + +-- | A mismatch in a data constrcutor, between its declaration in an hs-boot +-- file or signature file, and its implementation in a source Haskell module. +data BootDataConMismatch + -- | The 'Name's of the 'DataCon's differ. + = MismatchedDataConNames + -- | The fixities of the 'DataCon's differ. + | MismatchedDataConFixities + -- | The strictness annotations of the 'DataCon's differ. + | MismatchedDataConBangs + -- | The 'DataCon's have different field labels. + | MismatchedDataConFieldLabels + -- | The 'DataCon's have incompatible types. + | MismatchedDataConTypes + +-------------------------------------------------------------------------------- +-- +-- Errors used in GHC.Tc.Errors +-- +-------------------------------------------------------------------------------- + +{- Note [Error report] +~~~~~~~~~~~~~~~~~~~~~~ +The idea is that error msgs are divided into three parts: the main msg, the +context block ("In the second argument of ..."), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +the main msg ('report_important') varies depending on the error +in question, but context and relevant bindings are always the same, which +should simplify visual parsing. + +See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. +-} + +-- | A collection of main error messages and supplementary information. +-- +-- In practice, we will: +-- - display the important messages first, +-- - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'), +-- - then the supplementary information (e.g. relevant bindings, valid hole fits), +-- - then the hints ("Possible fix: ..."). +-- +-- So this is mostly just a way of making sure that the error context appears +-- early on rather than at the end of the message. +-- +-- See Note [Error report] for details. +data SolverReport + = SolverReport + { sr_important_msg :: SolverReportWithCtxt + , sr_supplementary :: [SupplementaryInfo] + , sr_hints :: [GhcHint] + } + +-- | Additional information to print in an error message, after the +-- important messages and after the error context. +-- +-- See Note [Error report]. +data SupplementaryInfo + = SupplementaryBindings RelevantBindings + | SupplementaryHoleFits ValidHoleFits + | SupplementaryCts (NE.NonEmpty (PredType, RealSrcSpan)) + | SupplementaryImportErrors (NE.NonEmpty ImportError) + +-- | A 'TcSolverReportMsg', together with context (e.g. enclosing implication constraints) +-- that are needed in order to report it. +data SolverReportWithCtxt = + SolverReportWithCtxt + { reportContext :: SolverReportErrCtxt + -- ^ Context for what we wish to report. + -- This can change as we enter implications, so is + -- stored alongside the content. + , reportContent :: TcSolverReportMsg + -- ^ The content of the message to report. + } + deriving Generic + +-- | Context needed when reporting a 'TcSolverReportMsg', such as +-- the enclosing implication constraints or whether we are deferring type errors. +data SolverReportErrCtxt + = CEC { cec_encl :: [Implication] -- ^ Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + + , cec_binds :: EvBindsVar -- ^ We make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'cec_binds' for unsolved constraints + + , cec_defer_type_errors :: DiagnosticReason -- ^ Whether to defer type errors until runtime + + -- We might throw a warning on an error when encountering a hole, + -- depending on the type of hole (expression hole, type hole, out of scope hole). + -- We store the reasons for reporting a diagnostic for each type of hole. + , cec_expr_holes :: DiagnosticReason -- ^ Reason for reporting holes in expressions. + , cec_type_holes :: DiagnosticReason -- ^ Reason for reporting holes in types. + , cec_out_of_scope_holes :: DiagnosticReason -- ^ Reason for reporting out of scope holes. + + , cec_warn_redundant :: Bool -- ^ True <=> -Wredundant-constraints + , cec_expand_syns :: Bool -- ^ True <=> -fprint-expanded-synonyms + + , cec_suppress :: Bool -- ^ True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +getUserGivens :: SolverReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics + +---------------------------------------------------------------------------- +-- +-- ErrorItem +-- +---------------------------------------------------------------------------- + +-- | A predicate with its arising location; used to encapsulate a constraint +-- that will give rise to a diagnostic. +data ErrorItem +-- We could perhaps use Ct here (and indeed used to do exactly that), but +-- having a separate type gives to denote errors-in-formation gives us +-- a nice place to do pre-processing, such as calculating ei_suppress. +-- Perhaps some day, an ErrorItem could eventually evolve to contain +-- the error text (or some representation of it), so we can then have all +-- the errors together when deciding which to report. + = EI { ei_pred :: PredType -- report about this + -- The ei_pred field will never be an unboxed equality with + -- a (casted) tyvar on the right; this is guaranteed by the solver + , ei_evdest :: Maybe TcEvDest + -- ^ for Wanteds, where to put the evidence + -- for Givens, Nothing + , ei_flavour :: CtFlavour + , ei_loc :: CtLoc + , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a + -- CtIrred, this stores the reason + , ei_suppress :: Bool -- Suppress because of Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Constraint + } + +instance Outputable ErrorItem where + ppr (EI { ei_pred = pred + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_suppress = supp }) + = pp_supp <+> ppr flav <+> pp_dest m_evdest <+> ppr pred + where + pp_dest Nothing = empty + pp_dest (Just ev) = ppr ev <+> dcolon + + pp_supp = if supp then text "suppress:" else empty + +errorItemOrigin :: ErrorItem -> CtOrigin +errorItemOrigin = ctLocOrigin . ei_loc + +errorItemEqRel :: ErrorItem -> EqRel +errorItemEqRel = predTypeEqRel . ei_pred + +errorItemCtLoc :: ErrorItem -> CtLoc +errorItemCtLoc = ei_loc + +errorItemPred :: ErrorItem -> PredType +errorItemPred = ei_pred + +{- Note [discardProvCtxtGivens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most situations we call all enclosing implications "useful". There is one +exception, and that is when the constraint that causes the error is from the +"provided" context of a pattern synonym declaration: + + pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a + -- required => provided => type + pattern Pat x <- (Just x, 4) + +When checking the pattern RHS we must check that it does actually bind all +the claimed "provided" constraints; in this case, does the pattern (Just x, 4) +bind the (Show a) constraint. Answer: no! + +But the implication we generate for this will look like + forall a. (Num a, Eq a) => [W] Show a +because when checking the pattern we must make the required +constraints available, since they are needed to match the pattern (in +this case the literal '4' needs (Num a, Eq a)). + +BUT we don't want to suggest adding (Show a) to the "required" constraints +of the pattern synonym, thus: + pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a +It would then typecheck but it's silly. We want the /pattern/ to bind +the alleged "provided" constraints, Show a. + +So we suppress that Implication in discardProvCtxtGivens. It's +painfully ad-hoc but the truth is that adding it to the "required" +constraints would work. Suppressing it solves two problems. First, +we never tell the user that we could not deduce a "provided" +constraint from the "required" context. Second, we never give a +possible fix that suggests to add a "provided" constraint to the +"required" context. + +For example, without this distinction the above code gives a bad error +message (showing both problems): + + error: Could not deduce (Show a) ... from the context: (Eq a) + ... Possible fix: add (Show a) to the context of + the signature for pattern synonym `Pat' ... +-} + + +discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] +discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + = filterOut (discard name) givens + | otherwise + = givens + where + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False + + +-- | An error reported after constraint solving. +-- This is usually, some sort of unsolved constraint error, +-- but we try to be specific about the precise problem we encountered. +data TcSolverReportMsg + -- | Quantified variables appear out of dependency order. + -- + -- Example: + -- + -- forall (a :: k) k. ... + -- + -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. + = BadTelescope TyVarBndrs [TyCoVar] + + -- | We came across a custom type error and we have decided to report it. + -- + -- Example: + -- + -- type family F a where + -- F a = TypeError (Text "error") + -- + -- err :: F () + -- err = () + -- + -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104. + | UserTypeError ErrorMsgType -- ^ the message to report + + -- | Report a Wanted constraint of the form "Unsatisfiable msg". + | UnsatisfiableError ErrorMsgType -- ^ the message to report + + -- | We want to report an out of scope variable or a typed hole. + -- See 'HoleError'. + | ReportHoleError Hole HoleError + + -- | Cannot unify a variable, because of a type mismatch. + | CannotUnifyVariable + { mismatchMsg :: MismatchMsg + , cannotUnifyReason :: CannotUnifyVariableReason } + + -- | A mismatch between two types. + | Mismatch + { mismatchMsg :: MismatchMsg + , mismatchTyVarInfo :: Maybe TyVarInfo + , mismatchAmbiguityInfo :: [AmbiguityInfo] + , mismatchCoercibleInfo :: Maybe CoercibleMsg } + + -- | A violation of the representation-polymorphism invariants. + -- + -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. + | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] + + -- | Something was not applied to sufficiently many arguments. + -- + -- Example: + -- + -- instance Eq Maybe where {..} + -- + -- Test case: T11563. + | ExpectingMoreArguments Int TypedThing + + -- | Trying to use an unbound implicit parameter. + -- + -- Example: + -- + -- foo :: Int + -- foo = ?param + -- + -- Test case: tcfail130. + | UnboundImplicitParams + (NE.NonEmpty ErrorItem) + + -- | A constraint couldn't be solved because it contains + -- ambiguous type variables. + -- + -- Example: + -- + -- class C a b where + -- f :: (a,b) + -- + -- x = fst f + -- + -- + -- Test case: T4921. + | AmbiguityPreventsSolvingCt + ErrorItem -- ^ always a class constraint + ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively + + -- | Could not solve a constraint; there were several unifying candidate instances + -- but no matching instances. This is used to report as much useful information + -- as possible about why we couldn't choose any instance, e.g. because of + -- ambiguous type variables. + | CannotResolveInstance + { cannotResolve_item :: ErrorItem + , cannotResolve_unifiers :: [ClsInst] + , cannotResolve_candidates :: [ClsInst] + , cannotResolve_relBinds :: RelevantBindings + } + + -- | Could not solve a constraint using available instances + -- because the instances overlap. + -- + -- Test cases: tcfail118, tcfail121, tcfail218. + | OverlappingInstances + { overlappingInstances_item :: ErrorItem + , overlappingInstances_matches :: NE.NonEmpty ClsInst + , overlappingInstances_unifiers :: [ClsInst] } + + -- | Could not solve a constraint from instances because + -- instances declared in a Safe module cannot overlap instances + -- from other modules (with -XSafeHaskell). + -- + -- Test cases: SH_Overlap{1,2,5,6,7,11}. + | UnsafeOverlap + { unsafeOverlap_item :: ErrorItem + , unsafeOverlap_match :: ClsInst + , unsafeOverlapped :: NE.NonEmpty ClsInst } + + | MultiplicityCoercionsNotSupported + + deriving Generic + +data MismatchMsg + = -- | Couldn't unify two types or kinds. + -- + -- Example: + -- + -- 3 + 3# -- can't match a lifted type with an unlifted type + -- + -- Test cases: T1396, T8263, ... + BasicMismatch + { mismatch_ea :: MismatchEA -- ^ Should this be phrased in terms of expected vs actual? + , mismatch_item :: ErrorItem -- ^ The constraint in which the mismatch originated. + , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) + , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) + , mismatch_whenMatching :: Maybe WhenMatching + , mismatch_mb_same_occ :: Maybe SameOccInfo + } + + -- | A mismatch between two types, which arose from a type equality. + -- + -- Test cases: T1470, tcfail212, T2994, T7609. + | TypeEqMismatch + { teq_mismatch_item :: ErrorItem + , teq_mismatch_ty1 :: Type + , teq_mismatch_ty2 :: Type + , teq_mismatch_expected :: Type -- ^ The overall expected type + , teq_mismatch_actual :: Type -- ^ The overall actual type + , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? + , teq_mb_same_occ :: Maybe SameOccInfo + } + -- TODO: combine with 'BasicMismatch'. + + -- | Couldn't solve some Wanted constraints using the Givens. + -- Used for messages such as @"No instance for ..."@ and + -- @"Could not deduce ... from"@. + | CouldNotDeduce + { cnd_user_givens :: [Implication] + -- | The Wanted constraints we couldn't solve. + -- + -- N.B.: the 'ErrorItem' at the head of the list has been tidied, + -- perhaps not the others. + , cnd_wanted :: NE.NonEmpty ErrorItem + + -- | Some additional info consumed by 'mk_supplementary_ea_msg'. + , cnd_extra :: Maybe CND_Extra + } + deriving Generic + +-- | Construct a basic mismatch message between two types. +-- +-- See 'pprMismatchMsg' for how such a message is displayed to users. +mkBasicMismatchMsg :: MismatchEA -> ErrorItem -> Type -> Type -> MismatchMsg +mkBasicMismatchMsg ea item ty1 ty2 + = BasicMismatch + { mismatch_ea = ea + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = Nothing + } + +-- | Whether to use expected/actual in a type mismatch message. +data MismatchEA + -- | Don't use expected/actual. + = NoEA + -- | Use expected/actual. + | EA + { mismatch_mbEA :: Maybe ExpectedActualInfo + -- ^ Whether to also mention type synonym expansion. + } + +data CannotUnifyVariableReason + = -- | A type equality between a type variable and a polytype. + -- + -- Test cases: T12427a, T2846b, T10194, ... + CannotUnifyWithPolytype ErrorItem TyVar Type (Maybe TyVarInfo) + + -- | An occurs check. + | OccursCheck + { occursCheckInterestingTyVars :: [TyVar] + , occursCheckAmbiguityInfos :: [AmbiguityInfo] } + + -- | A skolem type variable escapes its scope. + -- + -- Example: + -- + -- data Ex where { MkEx :: a -> MkEx } + -- foo (MkEx x) = x + -- + -- Test cases: TypeSkolEscape, T11142. + | SkolemEscape ErrorItem Implication [TyVar] + + -- | Can't unify the type variable with the other type + -- due to the kind of type variable it is. + -- + -- For example, trying to unify a 'SkolemTv' with the + -- type Int, or with a 'TyVarTv'. + | DifferentTyVars TyVarInfo + | RepresentationalEq TyVarInfo (Maybe CoercibleMsg) + deriving Generic + +-- | Report a mismatch error without any extra +-- information. +mkPlainMismatchMsg :: MismatchMsg -> TcSolverReportMsg +mkPlainMismatchMsg msg + = Mismatch + { mismatchMsg = msg + , mismatchTyVarInfo = Nothing + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + +-- | Additional information to be given in a 'CouldNotDeduce' message, +-- which is then passed on to 'mk_supplementary_ea_msg'. +data CND_Extra = CND_Extra TypeOrKind Type Type + +-- | A cue to print out information about type variables, +-- e.g. where they were bound, when there is a mismatch @tv1 ~ ty2@. +data TyVarInfo = + TyVarInfo { thisTyVar :: TyVar + , thisTyVarIsUntouchable :: Maybe Implication + , otherTy :: Maybe TyVar } + +-- | Add some information to disambiguate errors in which +-- two 'Names' would otherwise appear to be identical. +-- +-- See Note [Disambiguating (X ~ X) errors]. +data SameOccInfo + = SameOcc + { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. + , sameOcc_lhs :: Name + , sameOcc_rhs :: Name } + +-- | Add some information about ambiguity +data AmbiguityInfo + + -- | Some type variables remained ambiguous: print them to the user. + = Ambiguity + { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..." + -- False <=> create a message of the form "The type variable is ambiguous." + , ambig_tyvars :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively. + -- Guaranteed to not both be empty. + } + + -- | Remind the user that a particular type family is not injective. + | NonInjectiveTyFam TyCon + +-- | Expected/actual information. +data ExpectedActualInfo + -- | Display the expected and actual types. + = ExpectedActual + { ea_expected, ea_actual :: Type } + + -- | Display the expected and actual types, after expanding type synonyms. + | ExpectedActualAfterTySynExpansion + { ea_expanded_expected, ea_expanded_actual :: Type } + +-- | Explain how a kind equality originated. +data WhenMatching + + = WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) + deriving Generic + +data BadImportKind + -- | Module does not export... + = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant + -- | Missing @type@ keyword when importing a type. + -- e.g. `import TypeLits( (+) )`, where TypeLits exports a /type/ (+), not a /term/ (+) + -- Then we want to suggest using `import TypeLits( type (+) )` + | BadImportAvailTyCon + -- | Trying to import a data constructor directly, e.g. + -- @import Data.Maybe (Just)@ instead of @import Data.Maybe (Maybe(Just))@ + | BadImportAvailDataCon OccName + -- | The parent does not export the given children. + | BadImportNotExportedSubordinates !GlobalRdrElt (NonEmpty FastString) + -- | Incorrect @type@ keyword when importing subordinates that aren't types. + | BadImportNonTypeSubordinates !GlobalRdrElt (NonEmpty GlobalRdrElt) + -- | Incorrect @data@ keyword when importing something which isn't a term. + | BadImportNonDataSubordinates !GlobalRdrElt (NonEmpty GlobalRdrElt) + -- | Incorrect @type@ keyword when importing something which isn't a type. + | BadImportAvailVar + deriving Generic + +{- Note [Reasons for BadImportAvailTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BadImportAvailTyCon means a name is available in the TcCls namespace +but name resolution could not use it. Possible reasons for that: + +- Case (TyOp) `import M ((#))` or `import M (data (#))` + The user tried to import a type operator without using the `type` keyword, + or using a different keyword. Suggested fix: add 'type'. + +- Case (DataKw) `import M (data T)` + The user tried to import a non-operator type constructor, but mistakenly + used the `data` keyword, which restricted the lookup to the value namespace. + Suggested fix: remove 'data'; no need to add 'type' for non-operators. + +- Case (PatternKw) `import M (pattern T)` + Same as the (DataKw) case, mutatis mutandis. + +Any other case would not have resulted in BadImportAvailTyCon. +-} + +-- | Describes what category of subordinate we are dealing with, e.g. +-- a method of a class, a field of a record, etc. +data Subordinate + = MethodOfClass -- ^ A method of a class + | AssociatedTypeOfClass -- ^ An associated type of a class + | FieldOfConstructor -- ^ A field of a constructor + + deriving Generic + +pprSubordinate :: Name -> Subordinate -> SDoc +pprSubordinate parent_nm = \case + MethodOfClass -> + text "method of class" <+> quotes (ppr parent_nm) + AssociatedTypeOfClass -> + text "associated type of class" <+> quotes (ppr parent_nm) + FieldOfConstructor -> + text "field of constructor" <+> quotes (ppr parent_nm) + +-- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' +-- constructor of 'HoleError'. +data NotInScopeError + + -- | A run-of-the-mill @"not in scope"@ error. + = NotInScope + + -- | Like 'NotInScope', but when we know we are looking for a + -- record field. + | NotARecordField + + -- | An exact 'Name' was not in scope. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test cases: T5971, T18263. + | NoExactName Name + + -- The same exact 'Name' occurs in multiple name-spaces. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test case: T7241. + | SameName [GlobalRdrElt] -- ^ always at least 2 elements + + -- A type signature, fixity declaration, pragma, standalone kind signature... + -- is missing an associated binding. + | MissingBinding SigLike [GhcHint] + + -- | Couldn't find a top-level binding. + -- + -- Happens when specifying an annotation for something that + -- is not in scope. + -- + -- Test cases: annfail01, annfail02, annfail11. + | NoTopLevelBinding + + -- | A class doesn't have a method with this name, + -- or, a class doesn't have an associated type with this name, + -- or, a record doesn't have a record field with this name. + | UnknownSubordinate + Name -- ^ name of the parent + Subordinate -- ^ the kind of subordinate + + -- | A name is not in scope during type checking but passed the renamer. + -- + -- Test cases: + -- none + | NotInScopeTc (NameEnv TcTyThing) + deriving Generic + +-- | Configuration for pretty-printing valid hole fits. +data HoleFitDispConfig = + HFDC { showWrap, showWrapVars, showType, showProv, showMatches + :: Bool } + +-- | Report an error involving a 'Hole'. +-- +-- This could be an out of scope data constructor or variable, +-- a typed hole, or a wildcard in a type. +data HoleError + -- | Report an out-of-scope data constructor or variable + -- masquerading as an expression hole. + -- + -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint. + -- See 'NotInScopeError' for other not-in-scope errors. + -- + -- Test cases: T9177a. + = OutOfScopeHole + -- | Report a typed hole, or wildcard, with additional information. + | HoleError HoleSort + [TcTyVar] -- Other type variables which get computed on the way. + [(SkolemInfoAnon, [TcTyVar])] -- Zonked and grouped skolems for the type of the hole. + +-- | A message that aims to explain why two types couldn't be seen +-- to be representationally equal. +data CoercibleMsg + -- | Not knowing the role of a type constructor prevents us from + -- concluding that two types are representationally equal. + -- + -- Example: + -- + -- foo :: Applicative m => m (Sum Int) + -- foo = coerce (pure $ 1 :: Int) + -- + -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`. + -- + -- Test cases: T8984, TcCoercibleFail. + = UnknownRoles Type + + -- | The fact that a 'TyCon' is abstract prevents us from decomposing + -- a 'TyConApp' and deducing that two types are representationally equal. + -- + -- Test cases: none. + | TyConIsAbstract TyCon + + -- | We can't unwrap a newtype whose constructor is not in scope. + -- + -- Example: + -- + -- import Data.Ord (Down) -- NB: not importing the constructor + -- foo :: Int -> Down Int + -- foo = coerce + -- + -- Test cases: TcCoercibleFail. + | OutOfScopeNewtypeConstructor TyCon DataCon + +-- | Explain a problem with an import. +data ImportError + -- | Couldn't find a module with the requested name. + = MissingModule ModuleName + -- | The imported modules don't export what we're looking for. + | ModulesDoNotExport (NE.NonEmpty Module) WhatLooking OccName + +-- What kind of suggestion are we looking for? #19843 +data WhatLooking = WL_Anything + -- ^ Any sugestion + | WL_Constructor + -- ^ Suggest type constructors, data constructors + -- (including promoted data constructors), and pattern + -- synonyms. + | WL_TyCon + -- ^ Suggest type constructors/classes only; do not + -- include promoted data constructors. + | WL_TyCon_or_TermVar + -- ^ Suggest type constructors and term variables, + -- but not data constructors nor type variables + | WL_TyVar + -- ^ Suggest type variables only. + | WL_ConLike + -- ^ Suggest term-level data constructors and pattern + -- synonyms; no type constructors or promoted data + -- constructors + | WL_RecField + -- ^ Suggest record fields + -- + -- E.g. in @K { f1 = True, f2 = False }@, if @f2@ is not in + -- scope, suggest only constructor fields + | WL_Term + -- ^ Suggest terms + -- + -- If we are expecting a term value, then only suggest + -- terms (e.g. term variables, data constructors) and + -- not type constructors or type variables + | WL_TermVariable + -- ^ Suggest term variables (and record fields) + | WL_Type + -- ^ Suggest types: type constructors, type variables, + -- promoted data constructors. + | WL_None + -- ^ No suggestions + -- + -- This is is used for rebindable syntax, where there + -- is no point in suggesting alternative spellings + deriving (Eq, Show) + +-- | In what namespaces should we look for a subordinate +-- of the given 'GlobalRdrElt'. +lookingForSubordinate :: GlobalRdrElt -> WhatLooking +lookingForSubordinate parent_gre = + case greInfo parent_gre of + IAmTyCon ClassFlavour + -> WL_TyCon_or_TermVar + _ -> WL_Term + +-- | This datatype collates instances that match or unifier, +-- in order to report an error message for an unsolved typeclass constraint. +data PotentialInstances + = PotentialInstances + { matches :: [ClsInst] + , unifiers :: [ClsInst] + } + +-- | A collection of valid hole fits or refinement fits, +-- in which some fits might have been suppressed. +data FitsMbSuppressed + = Fits + { fits :: [HoleFit] + , fitsSuppressed :: Bool -- ^ Whether we have suppressed any fits because there were too many. + } + +-- | A collection of hole fits and refinement fits. +data ValidHoleFits + = ValidHoleFits + { holeFits :: FitsMbSuppressed + , refinementFits :: FitsMbSuppressed + } + +noValidHoleFits :: ValidHoleFits +noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False) + +data RelevantBindings + = RelevantBindings + { relevantBindingNamesAndTys :: [(Name, Type)] + , ranOutOfFuel :: Bool -- ^ Whether we ran out of fuel generating the bindings. + } + +-- | Display some relevant bindings. +pprRelevantBindings :: RelevantBindings -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but it's here for the moment as it's needed in "GHC.Tc.Errors". +pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = + ppUnless (null rel_bds) $ + hang (text "Relevant bindings include") + 2 (vcat (map ppr_binding rel_bds) $$ ppWhen ran_out_of_fuel discardMsg) + where + ppr_binding (nm, tidy_ty) = + sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc nm)))] + rel_bds = filter (not . isGeneratedSrcSpan . getSrcSpan . fst) bds + +discardMsg :: SDoc +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + + +-- | Stores the information to be reported in a representation-polymorphism +-- error message. +data FixedRuntimeRepErrorInfo + = FRR_Info + { frr_info_origin :: FixedRuntimeRepOrigin + -- ^ What is the original type we checked for + -- representation-polymorphism, and what specific + -- check did we perform? + , frr_info_not_concrete :: Maybe (TcTyVar, TcType) + -- ^ Which non-concrete type did we try to + -- unify this concrete type variable with? + , frr_info_other_origin :: Maybe CtOrigin + -- ^ Did the representation polymorphism check arise + -- from another constraint? If so, record that 'CtOrigin' here + -- (it will never be a 'FRROrigin'). + } + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- | An error message context, for errors in the renamer. +-- +-- TODO: this should probably get merged in some way with 'ErrCtxtMsg', +-- but that's a battle for another day. +data HsDocContext + = TypeSigCtx [LocatedN RdrName] + | StandaloneKindSigCtx (LocatedN RdrName) + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (LocatedN RdrName) + | DerivDeclCtx + | RuleCtx FastString + | SpecECtx RdrName + | TyDataCtx (LocatedN RdrName) + | TySynCtx (LocatedN RdrName) + | TyFamilyCtx (LocatedN RdrName) + | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [LocatedN Name] + | ClassDeclCtx (LocatedN RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | HsTypePatCtx + | GHCiCtx + | SpliceTypeCtx (LHsType GhcPs) + | ReifyInstancesCtx + | ClassInstanceCtx (LHsType GhcRn) + | ClassMethodSigCtx (LocatedN RdrName) -- ^ Class method signature + | SpecialiseSigCtx (LocatedN RdrName) -- ^ SPECIALISE signature + | PatSynSigCtx [LocatedN RdrName] -- ^ Pattern synonym signature + + -- | Escape hatch, for GHC plugins and other GHC API users. + -- + -- Not for use within GHC; add a new constructor to 'HsDocContext' + -- if you need to add a new renamer error context. + | GenericCtx SDoc + +-- | Context for a mismatch in the number of arguments +data MatchArgsContext + = EquationArgs + !Name -- ^ Name of the function + | PatternArgs + !HsMatchContextRn -- ^ Pattern match specifics + +-- | The information necessary to report mismatched +-- numbers of arguments in a match group. +data MatchArgBadMatches where + MatchArgMatches + :: { matchArgFirstMatch :: LocatedA (Match GhcRn body) + , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) } + -> MatchArgBadMatches + +data PragmaWarningInfo + = PragmaWarningName { pwarn_occname :: OccName + , pwarn_impmod :: ModuleName + , pwarn_declmod :: ModuleName } + | PragmaWarningExport { pwarn_occname :: OccName + , pwarn_impmod :: ModuleName } + | PragmaWarningInstance { pwarn_dfunid :: DFunId + , pwarn_ctorig :: CtOrigin } + | PragmaWarningDefault { pwarn_class :: TyCon + , pwarn_impmod :: ModuleName } + + +-- | The context for an "empty statement group" error. +data EmptyStatementGroupErrReason + = EmptyStmtsGroupInParallelComp + -- ^ Empty statement group in a parallel list comprehension + | EmptyStmtsGroupInTransformListComp + -- ^ Empty statement group in a transform list comprehension + -- + -- Example: + -- [() | then ()] + | EmptyStmtsGroupInDoNotation HsDoFlavour + -- ^ Empty statement group in do notation + -- + -- Example: + -- do + | EmptyStmtsGroupInArrowNotation + -- ^ Empty statement group in arrow notation + -- + -- Example: + -- proc () -> do + + deriving (Generic) + +-- | An existential wrapper around @'StmtLR' GhcPs GhcPs body@. +data UnexpectedStatement where + UnexpectedStatement + :: Outputable (StmtLR GhcPs GhcPs body) + => StmtLR GhcPs GhcPs body + -> UnexpectedStatement + +data DeclSort = ClassDeclSort | InstanceDeclSort + +data NonStandardGuards where + NonStandardGuards + :: (Outputable body, + Anno (Stmt GhcRn body) ~ SrcSpanAnnA) + => [LStmtLR GhcRn GhcRn body] + -> NonStandardGuards + +data RuleLhsErrReason + = UnboundVariable RdrName NotInScopeError + | IllegalExpression + +data HsigShapeMismatchReason = + {-| HsigShapeSortMismatch is an error indicating that an item in the + export list of a signature doesn't match the item of the same name in + another signature when merging the two – one is a type while the other is a + plain identifier. + + Test cases: + none + -} + HsigShapeSortMismatch !AvailInfo !AvailInfo + | + {-| HsigShapeNotUnifiable is an error indicating that a name in the + export list of a signature cannot be unified with a name of the same name in + another signature when merging the two. + + Test cases: + bkpfail20, bkpfail21 + -} + HsigShapeNotUnifiable !Name !Name !Bool + deriving (Generic) + +data WrongThingSort + = WrongThingType + | WrongThingDataCon + | WrongThingPatSyn + | WrongThingConLike + | WrongThingClass + | WrongThingTyCon + | WrongThingAxiom + +data LevelCheckReason + = LevelCheckInstance !InstanceWhat !PredType + | LevelCheckSplice !Name !(Maybe GlobalRdrElt) + +data UninferrableTyVarCtx + = UninfTyCtx_ClassContext [TcType] + | UninfTyCtx_DataContext [TcType] + | UninfTyCtx_ProvidedContext [TcType] + | UninfTyCtx_TyFamRhs TcType + | UninfTyCtx_TySynRhs TcType + | UninfTyCtx_Sig TcType (LHsSigType GhcRn) + +data PatSynInvalidRhsReason + = PatSynNotInvertible !(Pat GhcRn) + | PatSynUnboundVar !Name + deriving (Generic) + +data BadFieldAnnotationReason where + {-| A lazy data type field annotation (~) was used without enabling the + extension StrictData. + + Test cases: + LazyFieldsDisabled + -} + LazyFieldsDisabled :: BadFieldAnnotationReason + {-| An UNPACK pragma was applied to a field without strictness annotation (!). + + Test cases: + T14761a, T7562 + -} + UnpackWithoutStrictness :: BadFieldAnnotationReason + {-| An UNPACK pragma is unusable. + + A possible reason for this warning is that the UNPACK pragma was applied to + one of the following: + + * a function type @a -> b@ + * a recursive use of the data type being defined + * a sum type that cannot be unpacked, see @Note [UNPACK for sum types]@ + * a type/data family application with no matching instance in the environment + + However, it is deliberately /not/ emitted if: + + * the failure occurs in an indefinite package in Backpack + * the pragma is usable, but unpacking is disabled by @-O0@ + + Test cases: + unpack_sums_5, T3966, T7050, T25672, T23307c + + Negative test cases (must not trigger this warning): + T3990 + -} + UnusableUnpackPragma :: BadFieldAnnotationReason + deriving (Generic) + +data SuperclassCycle = + MkSuperclassCycle { cls :: Class, definite :: Bool, reasons :: [SuperclassCycleDetail] } + +data SuperclassCycleDetail + = SCD_HeadTyVar !PredType + | SCD_HeadTyFam !PredType + | SCD_Superclass !Class + +data RoleValidationFailedReason + = TyVarRoleMismatch !TyVar !Role + | TyVarMissingInEnv !TyVar + | BadCoercionRole !Coercion + deriving (Generic) + +data DisabledClassExtension where + {-| MultiParamTypeClasses is required. + + Test cases: + readFail037, TcNoNullaryTC + -} + MultiParamDisabled :: !Int -- ^ The arity + -> DisabledClassExtension + {-| FunctionalDependencies is required. + + Test cases: + readFail041 + -} + FunDepsDisabled :: DisabledClassExtension + {-| ConstrainedClassMethods is required. + + Test cases: + mod39, tcfail150 + -} + ConstrainedClassMethodsDisabled :: !Id + -> !TcPredType + -> DisabledClassExtension + deriving (Generic) + +data TyFamsDisabledReason + = TyFamsDisabledFamily !Name + | TyFamsDisabledInstance !TyCon + deriving (Generic) + +-- | Why was an invisible pattern `@p` rejected? +data BadInvisPatReason + = InvisPatWithoutFlag + | InvisPatNoForall + | InvisPatMisplaced + deriving (Generic) + +-- | Why was the empty case rejected? +data BadEmptyCaseReason + = EmptyCaseWithoutFlag + | EmptyCaseDisallowedCtxt + | EmptyCaseForall ForAllTyBinder + +-- | Either `HsType p` or `HsSigType p`. +-- +-- Used for reporting errors in `TcRnIllegalKind`. +data HsTypeOrSigType p + = HsType (HsType p) + | HsSigType (HsSigType p) + +instance OutputableBndrId p => Outputable (HsTypeOrSigType (GhcPass p)) where + ppr (HsType ty) = ppr ty + ppr (HsSigType sig_ty) = ppr sig_ty + +-- | A wrapper around HsTyVarBndr. +-- Used for reporting errors in `TcRnUnusedQuantifiedTypeVar`. +data HsTyVarBndrExistentialFlag = forall flag. OutputableBndrFlag flag 'Renamed => + HsTyVarBndrExistentialFlag (HsTyVarBndr flag GhcRn) + +instance Outputable HsTyVarBndrExistentialFlag where + ppr (HsTyVarBndrExistentialFlag hsTyVarBndr) = ppr hsTyVarBndr + +type TySynCycleTyCons = + [Either TyCon (LTyClDecl GhcRn)] + +-- | Different types of warnings for dodgy imports. +data DodgyImportsReason = + {-| An import of the form 'T(..)' or 'f(..)' does not actually import anything beside + 'T'/'f' itself. + + Test cases: + DodgyImports + -} + DodgyImportsEmptyParent !GlobalRdrElt + | + {-| A 'hiding' clause contains something that would be reported as an error in a + regular import, but is relaxed to a warning. + + Test cases: + DodgyImports_hiding + -} + DodgyImportsHiding !ImportLookupReason + deriving (Generic) + +-- | What extensions were enabled at import site. +data ImportLookupExtensions = + ImportLookupExtensions + { ile_pattern_synonyms :: !Bool + , ile_explicit_namespaces :: !Bool + } + deriving (Generic) + +-- | Different types of errors for import lookup. +data ImportLookupReason where + {-| An item in an import statement is not exported by the corresponding + module. + + Test cases: + T21826, recomp001, retc001, mod79, mod80, mod81, mod91, T6007, T7167, + T9006, T11071, T9905fail2, T5385, T10668 + -} + ImportLookupBad :: BadImportKind + -> ModIface + -> ImpDeclSpec + -> IE GhcPs + -> ImportLookupExtensions + -> ImportLookupReason + {-| A name is specified with a qualifying module. + + Test cases: + T3792 + -} + ImportLookupQualified :: !RdrName -- ^ The name extracted from the import item + -> ImportLookupReason + + {-| Something completely unexpected is in an import list, like @module Foo@. + + Test cases: + ImportLookupIllegal + -} + ImportLookupIllegal :: ImportLookupReason + {-| An item in an import list matches multiple names exported from that module. + + Test cases: + None + -} + ImportLookupAmbiguous :: !RdrName -- ^ The name extracted from the import item + -> ![GlobalRdrElt] -- ^ The potential matches + -> ImportLookupReason + deriving (Generic) + +-- | Distinguish record fields from other names for pretty-printing. +data UnusedImportName where + UnusedImportNameRecField :: !Parent -> !OccName -> UnusedImportName + UnusedImportNameRegular :: !Name -> UnusedImportName + +-- | Different types of errors for unused imports. +data UnusedImportReason where + {-| No names in the import list are used in the module. + + Test cases: + overloadedrecfldsfail06, T10890_2, t22391, t22391j, T1074, prog018, + mod177, rn046, rn037, T5211 + -} + UnusedImportNone :: UnusedImportReason + {-| A set of names in the import list are not used in the module. + + Test cases: + overloadedrecfldsfail06, T17324, mod176, T11970A, rn046, T14881, + T7454, T8149, T13064 + -} + UnusedImportSome :: ![UnusedImportName] -- ^ The unsed names + -> UnusedImportReason + deriving (Generic) + +-- | Different places in which a nested foralls/contexts error might occur. +data NestedForallsContextsIn + -- | Nested forall in @SPECIALISE instance@ + = NFC_Specialize + -- | Nested forall in @deriving via@ (via-type) + | NFC_ViaType + -- | Nested forall in the type of a GADT constructor + | NFC_GadtConSig + -- | Nested forall in an instance head + | NFC_InstanceHead + -- | Nested forall in a standalone deriving instance head + | NFC_StandaloneDerivedInstanceHead + -- | Nested forall in deriving class type + | NFC_DerivedClassType + +-- | Provenance of an unused name. +data UnusedNameProv + = UnusedNameTopDecl + | UnusedNameImported !ModuleName + | UnusedNameTypePattern + | UnusedNameMatch + | UnusedNameLocalBind + +-- | Different reasons for TcRnNonCanonicalDefinition. +data NonCanonicalDefinition = + -- | Related to @(<>)@ and @mappend@. + NonCanonicalMonoid NonCanonical_Monoid + | + -- | Related to @(*>)@/@(>>)@ and @pure@/@return@. + NonCanonicalMonad NonCanonical_Monad + deriving (Generic) + +-- | Possible cases for the -Wnoncanonical-monoid-instances. +data NonCanonical_Monoid = + -- | @(<>) = mappend@ was defined. + NonCanonical_Sappend + | + -- | @mappend@ was defined as something other than @(<>)@. + NonCanonical_Mappend + +-- | Possible cases for the -Wnoncanonical-monad-instances. +data NonCanonical_Monad = + -- | @pure = return@ was defined. + NonCanonical_Pure + | + -- | @(*>) = (>>)@ was defined. + NonCanonical_ThenA + | + -- | @return@ was defined as something other than @pure@. + NonCanonical_Return + | + -- | @(>>)@ was defined as something other than @(*>)@. + NonCanonical_ThenM + +-- | Why was an instance declaration rejected? +data IllegalInstanceReason + = IllegalClassInstance + !TypedThing -- ^ the instance head type + !IllegalClassInstanceReason -- ^ the problem with the instance head + | IllegalFamilyInstance !IllegalFamilyInstanceReason + | IllegalFamilyApplicationInInstance + !Type -- ^ the instance head type + !Bool -- ^ is this an invisible argument? + !TyCon -- ^ type family + ![Type] -- ^ type family argument + deriving Generic + +-- | Why was a class instance declaration rejected? +data IllegalClassInstanceReason + -- | An illegal type at the head of the instance. + -- + -- See t'IllegalInstanceHeadReason'. + = IllegalInstanceHead !IllegalInstanceHeadReason + -- | An illegal HasField instance. See t'IllegalHasFieldInstance'. + | IllegalHasFieldInstance !IllegalHasFieldInstance + -- | An illegal instance for a built-in typeclass such as + -- 'Coercible', 'Typeable', or 'KnownNat', outside of a signature file. + -- + -- Test cases: deriving/should_fail/T9687 + -- deriving/should_fail/T14916 + -- polykinds/T8132 + -- typecheck/should_fail/TcCoercibleFail2 + -- typecheck/should_fail/T12837 + -- typecheck/should_fail/T14390 + | IllegalSpecialClassInstance !Class !Bool -- ^ Whether the error is due to Safe Haskell being enabled + -- | The instance failed the coverage condition, i.e. the functional + -- dependencies were not respected. + -- + -- Example: + -- + -- class C a b | a -> b where {..} + -- instance C a b where {..} + -- + -- Test cases: T9106, T10570, T2247, T12803, tcfail170. + | IllegalInstanceFailsCoverageCondition + !Class !CoverageProblem + deriving Generic + +-- | Why was a HasField instance declaration rejected? +data IllegalHasFieldInstance + -- | HasField instance for a type not headed by a TyCon. + -- + -- Example: + -- + -- instance HasField a where {..} + -- + -- Test case: hasfieldfail03 + = IllegalHasFieldInstanceNotATyCon + -- | HasField instance for a data family. + -- + -- Example: + -- + -- data family D a + -- data instance D Int = MkDInt Char + -- + -- instance HasField "fld" (D Int) where {..} + -- + -- Test case: hasfieldfail03 + | IllegalHasFieldInstanceFamilyTyCon + -- | HasField instance for a type that already has that field. + -- + -- Example + -- + -- data T = MkT { quux :: Int } + -- instance HasField "quux" T Int where {..} + -- + -- Test case: hasfieldfail03 + | IllegalHasFieldInstanceTyConHasField !TyCon !FieldLabelString + -- | HasField instance for a type that already has fields, when the + -- field label could potentially unify with those fields. + -- + -- Example: + -- + -- data T = MkInt { quux :: Int } + -- instance forall (fld :: Symbol). HasField fld T Int where {..} + -- + -- Test case: hasfieldfail03 + | IllegalHasFieldInstanceTyConHasFields !TyCon !Type -- ^ the label type in the instance head + deriving Generic + +-- | Description of an instance coverage condition failure. +data CoverageProblem = + CoverageProblem + { not_covered_fundep :: ([TyVar], [TyVar]) + , not_covered_fundep_inst :: ([Type], [Type]) + , not_covered_invis_vis_tvs :: Pair VarSet + , not_covered_liberal :: FailedCoverageCondition + } + +-- | Which instance coverage condition failed? Was it the liberal +-- coverage condition? +data FailedCoverageCondition + -- | Failed the instance coverage condition (ICC) + = FailedICC + { alsoFailedLICC :: !Bool + -- ^ Whether the instance also failed the LICC + } + -- | Failed the liberal instance coverage condition (LICC) + | FailedLICC + +-------------------------------------------------------------------------------- +-- Template Haskell errors + +data THError + -- | A syntax error with Template Haskel quotes & splices. + -- See t'THSyntaxError'. + = THSyntaxError !THSyntaxError + -- | An error in Template Haskell involving 'Name's. + -- See t'THNameError'. + | THNameError !THNameError + -- | An error in Template Haskell reification. See t'THReifyError'. + | THReifyError !THReifyError + -- | An error due to typing restrictions in Typed Template Haskell. + -- See t'TypedTHError'. + | TypedTHError !TypedTHError + -- | An error occurred when trying to run a splice in Template Haskell. + -- See 'SpliceFailReason'. + | THSpliceFailed !SpliceFailReason + -- | An error involving the 'addTopDecls' functionality. See t'AddTopDeclsError'. + | AddTopDeclsError !AddTopDeclsError + + {-| IllegalStaticFormInSplice is an error when a user attempts to define + a static pointer in a Template Haskell splice. + + Example(s): + + Test cases: th/TH_StaticPointers02 + -} + | IllegalStaticFormInSplice !(HsExpr GhcPs) + + {-| FailedToLookupThInstName is a Template Haskell error that occurrs when looking up an + instance fails. + + Example(s): + + Test cases: showIface/should_fail/THPutDocNonExistent + -} + | FailedToLookupThInstName !TH.Type !LookupTHInstNameErrReason + + {-| AddInvalidCorePlugin is a Template Haskell error indicating that a + Core plugin being added has an invalid module due to being + in the current package. + + Example(s): + + Test cases: + -} + | AddInvalidCorePlugin !String -- ^ Module name + + {-| AddDocToNonLocalDefn is a Template Haskell error for documentation being added to a + definition which is not in the current module. + + Example(s): + + Test cases: showIface/should_fail/THPutDocExternal + -} + | AddDocToNonLocalDefn !TH.DocLoc + + {-| ReportCustomQuasiError is an error or warning thrown using 'qReport' from + the 'Quasi' instance of 'TcM'. + + Example(s): + + Test cases: + -} + | ReportCustomQuasiError + !Bool -- ^ True => Error, False => Warning + !String -- ^ Error body + deriving Generic + +-- | An error involving Template Haskell quotes or splices, e.g. nested +-- quotation brackets or the use of an untyped bracket inside a typed splice. +data THSyntaxError + = {-| IllegalTHQuotes is an error that occurs when a Template Haskell + quote is used without the TemplateHaskell extension enabled. + + Test case: T18251e + -} + IllegalTHQuotes !(HsExpr GhcPs) + + {-| IllegalTHSplice is an error that occurs when a Template Haskell + splice occurs without having enabled the TemplateHaskell extension. + + Test cases: + bkpfail01, bkpfail05, bkpfail09, bkpfail16, bkpfail35, bkpcabal06 + -} + | IllegalTHSplice + + {-| NestedTHBrackets is an error that occurs when Template Haskell + brackets are nested without any intervening splices. + + Example: + + foo = [| [| 'x' |] |] + + Test cases: TH_NestedSplicesFail{5,6,7,8} + -} + | NestedTHBrackets + + {-| MismatchedSpliceType is an error that happens when a typed bracket + or splice is used inside a typed splice/bracket, or the other way around. + + Examples: + + f1 = [| $$x |] + f2 = [|| $y ||] + f3 = $$( [| 'x' |] ) + f4 = $( [|| 'y' ||] ) + + Test cases: TH_NestedSplicesFail{1,2,3,4} + -} + | MismatchedSpliceType + SpliceType -- ^ type of the splice + SpliceOrBracket -- ^ what's nested inside + {-| BadImplicitSplice is an error thrown when a user uses top-level implicit + TH-splice without enabling the TemplateHaskell extension. + + Example: + + pure [] -- on top-level + + Test cases: ghci/prog019/prog019 + ghci/scripts/T1914 + ghci/scripts/T6106 + rename/should_fail/T4042 + rename/should_fail/T12146 + -} + | BadImplicitSplice + deriving Generic + +data THNameError + {-| NonExactName is a Template Haskell error that occurs when the user + attempts to define a binder with a 'RdrName' that is not an exact 'Name'. + + Example(s): + + Test cases: + -} + = NonExactName !RdrName + + deriving Generic + +data THReifyError + = {-| CannotReifyInstance is a Template Haskell error for when an instance being reified + via `reifyInstances` is not a class constraint or type family application. + + Example(s): + + Test cases: + -} + CannotReifyInstance !Type + + {-| CannotReifyOutOfScopeThing is a Template Haskell error indicating + that the given name is not in scope and therefore cannot be reified. + + Example(s): + + Test cases: th/T16976f + -} + | CannotReifyOutOfScopeThing !TH.Name + + {-| CannotReifyThingNotInTypeEnv is a Template Haskell error occurring + when the given name is not in the type environment and therefore cannot be reified. + + Example(s): + + Test cases: + -} + | CannotReifyThingNotInTypeEnv !Name + + {-| NoRolesAssociatedWithName is a Template Haskell error for when the user + tries to reify the roles of a given name but it is not something that has + roles associated with it. + + Example(s): + + Test cases: + -} + | NoRolesAssociatedWithThing !TcTyThing + + {-| CannotRepresentThing is a Template Haskell error indicating that a + type cannot be reified because it does not have a representation in Template Haskell. + + Example(s): + + Test cases: + -} + | CannotRepresentType !UnrepresentableTypeDescr !Type + deriving Generic + +data AddTopDeclsError + = {-| InvalidTopDecl is a Template Haskell error occurring when one of the 'Dec's passed to + 'addTopDecls' is not a function, value, annotation, or foreign import declaration. + + Example(s): + + Test cases: + -} + InvalidTopDecl !(HsDecl GhcPs) + {-| UnexpectedDeclarationSplice is an error that occurs when a Template Haskell + splice appears inside top-level declarations added with 'addTopDecls'. + + Example(s): none + + Test cases: none + -} + | AddTopDeclsUnexpectedDeclarationSplice + + | AddTopDeclsRunSpliceFailure !RunSpliceFailReason + deriving Generic + +data TypedTHError + = {-| SplicePolymorphicLocalVar is the error that occurs when the expression + inside typed Template Haskell brackets is a polymorphic local variable. + + Example(s): + x = \(y :: forall a. a -> a) -> [|| y ||] + + Test cases: quotes/T10384 + -} + SplicePolymorphicLocalVar !Id + + {-| TypedTHWithPolyType is an error that signifies the illegal use + of a polytype in a typed Template Haskell expression. + + Example(s): + bad :: (forall a. a -> a) -> () + bad = $$( [|| \_ -> () ||] ) + + Test cases: th/T11452 + -} + | TypedTHWithPolyType !TcType + deriving Generic + +data SpliceFailReason + = {-| SpliceThrewException is an error that occurs when running a Template + Haskell splice throws an exception. + + Example(s): + + Test cases: annotations/should_fail/annfail12 + perf/compiler/MultiLayerModulesTH_Make + perf/compiler/MultiLayerModulesTH_OneShot + th/T10796b + th/T19470 + th/T19709d + th/T5358 + th/T5976 + th/T7276a + th/T8987 + th/TH_exn1 + th/TH_exn2 + th/TH_runIO + -} + SpliceThrewException + !SplicePhase + !SomeException + !String -- ^ Result of showing the exception (cannot be done safely outside IO) + !(LHsExpr GhcTc) + !Bool -- True <=> Print the expression + + {-| RunSpliceFailure is an error indicating that a Template Haskell splice + failed to be converted into a valid expression. + + Example(s): + + Test cases: th/T10828a + th/T10828b + th/T12478_4 + th/T15270A + th/T15270B + th/T16895a + th/T16895b + th/T16895c + th/T16895d + th/T16895e + th/T18740d + th/T2597b + th/T2674 + th/T3395 + th/T7484 + th/T7667a + th/TH_implicitParamsErr1 + th/TH_implicitParamsErr2 + th/TH_implicitParamsErr3 + th/TH_invalid_add_top_decl + -} + | RunSpliceFailure !RunSpliceFailReason + deriving Generic + +data RunSpliceFailReason + = ConversionFail !ThingBeingConverted !ConversionFailReason + deriving Generic + +-- | Identifies the TH splice attempting to be converted +data ThingBeingConverted + = ConvDec !TH.Dec + | ConvExp !TH.Exp + | ConvPat !TH.Pat + | ConvType !TH.Type + +-- | The reason a TH splice could not be converted to a Haskell expression +data ConversionFailReason + = IllegalOccName !OccName.NameSpace !String + | SumAltArityExceeded !TH.SumAlt !TH.SumArity + | IllegalSumAlt !TH.SumAlt + | IllegalSumArity !TH.SumArity + | MalformedType !TypeOrKind !TH.Type + | IllegalLastStatement !HsDoFlavour !(LStmt GhcPs (LHsExpr GhcPs)) + | KindSigsOnlyAllowedOnGADTs + | IllegalDeclaration !THDeclDescriptor !IllegalDecls + | CannotMixGADTConsWith98Cons + | EmptyStmtListInDoBlock + | NonVarInInfixExpr + | MultiWayIfWithoutAlts + | CasesExprWithoutAlts + | ImplicitParamsWithOtherBinds + | InvalidCCallImpent !String -- ^ Source + | RecGadtNoCons + | GadtNoCons + | InvalidTypeInstanceHeader !TH.Type + | InvalidTyFamInstLHS !TH.Type + | InvalidImplicitParamBinding + | DefaultDataInstDecl ![LDataFamInstDecl GhcPs] + | FunBindLacksEquations !TH.Name + | EmptyGuard + | EmptyParStmt + deriving Generic + +data IllegalDecls + = IllegalDecls !(NE.NonEmpty (LHsDecl GhcPs)) + | IllegalFamDecls !(NE.NonEmpty (LFamilyDecl GhcPs)) + +-- | Label for a TH declaration +data THDeclDescriptor + = InstanceDecl + | WhereClause + | LetBinding + | LetExpression + | ClssDecl + +-- | The phase in which an exception was encountered when dealing with a TH splice +data SplicePhase + = SplicePhase_Run + | SplicePhase_CompileAndLink + +data LookupTHInstNameErrReason + = NoMatchesFound + | CouldNotDetermineInstance + +data UnrepresentableTypeDescr + = LinearInvisibleArgument + | CoercionsInTypes + | DataConVisibleForall + +-- FFI error types +data IllegalForeignTypeReason + = TypeCannotBeMarshaled !Type TypeCannotBeMarshaledReason + | ForeignDynNotPtr + !Type -- ^ Expected type + !Type -- ^ Actual type + | SafeHaskellMustBeInIO + | IOResultExpected + | UnexpectedNestedForall + | LinearTypesNotAllowed + | OneArgExpected + | AtLeastOneArgExpected + deriving Generic + +-- | Reason why a type cannot be marshalled through the FFI. +data TypeCannotBeMarshaledReason + = NotADataType + | NewtypeDataConNotInScope !TyCon ![Type] + | UnliftedFFITypesNeeded + | NotABoxedMarshalableTyCon + | ForeignLabelNotAPtr + | NotSimpleUnliftedType + | NotBoxedKindAny + deriving Generic + +data TcRnNoDerivStratSpecifiedInfo where + {-| 'TcRnNoDerivStratSpecified TcRnNoDerivingClauseStrategySpecified' is + a warning implied by -Wmissing-deriving-strategies and triggered by a + deriving clause without a specified deriving strategy. + + Example: + + newtype T = T Int + deriving (Eq, Ord, Show) + + Here we would suggest fixing the deriving clause to: + + deriving stock (Show) + deriving newtype (Eq, Ord) + + Test cases: deriving/should_compile/T15798a + deriving/should_compile/T15798c + deriving/should_compile/T24955a + deriving/should_compile/T24955b + -} + TcRnNoDerivingClauseStrategySpecified + :: Map AssumedDerivingStrategy [LHsSigType GhcRn] + -> TcRnNoDerivStratSpecifiedInfo + + {-| 'TcRnNoDerivStratSpecified TcRnNoStandaloneDerivingStrategySpecified' is + a warning implied by -Wmissing-deriving-strategies and triggered by a + standalone deriving declaration without a specified deriving strategy. + + Example: + + data T a = T a + deriving instance Show a => Show (T a) + + Here we would suggest fixing the instance to: + + deriving stock instance Show a => Show (T a) + + Test cases: deriving/should_compile/T15798b + deriving/should_compile/T24955c + -} + TcRnNoStandaloneDerivingStrategySpecified + :: AssumedDerivingStrategy + -> LHsSigWcType GhcRn -- ^ The instance signature (e.g @Show a => Show (T a)@) + -> TcRnNoDerivStratSpecifiedInfo + +-- | Label for syntax that may occur in terms (expressions) only as part of a +-- required type argument. +data TypeSyntax + = TypeKeywordSyntax -- ^ @type t@ + | ContextArrowSyntax -- ^ @ctx => t@ + | FunctionArrowSyntax -- ^ @t1 -> t2@ + | ForallTelescopeSyntax -- ^ @forall tvs. t@ + deriving Generic + +typeSyntaxExtension :: TypeSyntax -> LangExt.Extension +typeSyntaxExtension TypeKeywordSyntax = LangExt.ExplicitNamespaces +typeSyntaxExtension ContextArrowSyntax = LangExt.RequiredTypeArguments +typeSyntaxExtension FunctionArrowSyntax = LangExt.RequiredTypeArguments +typeSyntaxExtension ForallTelescopeSyntax = LangExt.RequiredTypeArguments diff --git a/GHC/Tc/Errors/Types/PromotionErr.hs b/GHC/Tc/Errors/Types/PromotionErr.hs --- a/GHC/Tc/Errors/Types/PromotionErr.hs +++ b/GHC/Tc/Errors/Types/PromotionErr.hs @@ -1,7 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..) , pprPECategory , peCategory + , TermLevelUseErr(..) + , TermLevelUseCtxt(..) + , pprTermLevelUseCtxt + , teCategory ) where import GHC.Prelude @@ -9,6 +15,8 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Generics (Generic) +import GHC.Types.Name.Reader (GlobalRdrElt, pprNameProvenance) +import GHC.Types.Name (Name, nameSrcLoc) data PromotionErr = TyConPE -- TyCon used in a kind before we are ready @@ -25,8 +33,7 @@ | RecDataConPE -- Data constructor in a recursive loop -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl - | TermVariablePE -- See Note [Promoted variables in types] - | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) + | TermVariablePE -- See Note [Demotion of unqualified variables] in GHC.Rename.Env | TypeVariablePE -- See Note [Type variable scoping errors during typechecking] deriving (Generic) @@ -37,7 +44,6 @@ ppr FamDataConPE = text "FamDataConPE" ppr (ConstrainedDataConPE theta) = text "ConstrainedDataConPE" <+> parens (ppr theta) ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKindsDC = text "NoDataKindsDC" ppr TermVariablePE = text "TermVariablePE" ppr TypeVariablePE = text "TypeVariablePE" @@ -51,9 +57,30 @@ peCategory FamDataConPE = "data constructor" peCategory ConstrainedDataConPE{} = "data constructor" peCategory RecDataConPE = "data constructor" -peCategory NoDataKindsDC = "data constructor" peCategory TermVariablePE = "term variable" peCategory TypeVariablePE = "type variable" + +-- The opposite of a promotion error (a demotion error, in a sense). +data TermLevelUseErr + = TyConTE -- Type constructor used at the term level, e.g. x = Int + | ClassTE -- Class used at the term level, e.g. x = Functor + | TyVarTE -- Type variable used at the term level, e.g. f (Proxy :: Proxy a) = a + deriving (Generic) + +teCategory :: TermLevelUseErr -> String +teCategory ClassTE = "class" +teCategory TyConTE = "type constructor" +teCategory TyVarTE = "type variable" + +data TermLevelUseCtxt + = TermLevelUseGRE !GlobalRdrElt + | TermLevelUseTyVar + deriving (Generic) + +pprTermLevelUseCtxt :: Name -> TermLevelUseCtxt -> SDoc +pprTermLevelUseCtxt nm = \case + TermLevelUseGRE gre -> pprNameProvenance gre + TermLevelUseTyVar -> text "bound at" <+> ppr (nameSrcLoc nm) {- Note [Type variable scoping errors during typechecking] diff --git a/GHC/Tc/Gen/Annotation.hs b/GHC/Tc/Gen/Annotation.hs --- a/GHC/Tc/Gen/Annotation.hs +++ b/GHC/Tc/Gen/Annotation.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} -- | Typechecking annotations -module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where +module GHC.Tc.Gen.Annotation ( tcAnnotations ) where import GHC.Prelude @@ -23,8 +23,6 @@ import GHC.Hs -import GHC.Utils.Outputable - import GHC.Types.Name import GHC.Types.Annotations import GHC.Types.SrcLoc @@ -54,7 +52,7 @@ let target = annProvenanceToTarget mod provenance -- Run that annotation and construct the full Annotation data structure - setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do + setSrcSpanA loc $ addErrCtxt (AnnCtxt ann) $ do -- See #10826 -- Annotations allow one to bypass Safe Haskell. dflags <- getDynFlags when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell @@ -66,6 +64,3 @@ annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod -annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc -annCtxt ann - = hang (text "In the annotation:") 2 (ppr ann) diff --git a/GHC/Tc/Gen/App.hs b/GHC/Tc/Gen/App.hs --- a/GHC/Tc/Gen/App.hs +++ b/GHC/Tc/Gen/App.hs @@ -2,1232 +2,2329 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] - -{- -% -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - -module GHC.Tc.Gen.App - ( tcApp - , tcInferSigma - , tcExprPrag ) where - -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) - -import GHC.Types.Var -import GHC.Builtin.Types ( multiplicityTy ) -import GHC.Tc.Gen.Head -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.TcMType -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType as TcType -import GHC.Tc.Zonk.TcType -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( shallowTyCoVarsOfType ) -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Tc.Types.Evidence -import GHC.Types.Var.Set -import GHC.Builtin.PrimOps( tagToEnumKey ) -import GHC.Builtin.Names -import GHC.Driver.DynFlags -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) - | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr - = addExprCtxt rn_expr $ - setSrcSpanA loc $ - do { do_ql <- wantQuickLook rn_fun - ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args - ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args - ; _tc_args <- tcValArgs do_ql inst_args - ; return app_res_sigma } - -{- ********************************************************************* -* * - 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 - | $([| head |]) -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices - | 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. - -We also wish to typecheck application chains with untyped Template Haskell -splices in the head, such as this example from #21038: - data Foo = MkFoo (forall a. a -> a) - f = $([| MkFoo |]) $ \x -> x -This should typecheck just as if the TH splice was never in the way—that is, -just as if the user had written `MkFoo $ \x -> x`. We could conceivably have -a case for typed TH expression splices too, but it wouldn't be useful in -practice, since the types of typed TH expressions aren't allowed to have -polymorphic types, such as the type of MkFoo. - -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 - | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr - = do { traceTc "tcApp {" $ - vcat [ text "rn_fun:" <+> ppr rn_fun - , text "rn_args:" <+> ppr rn_args ] - - ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args - - -- Instantiate - ; do_ql <- wantQuickLook rn_fun - ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun 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 - = 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 at hs_ty ty) = return (ETypeArg l at 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 GhcRn, AppCtxt) -- Error messages only - -> 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 (rn_fun, fun_ctxt) fun_sigma rn_args - = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma - , text "args:" <+> ppr rn_args - , text "do_ql" <+> ppr do_ql ]) - ; go emptyVarSet [] [] fun_sigma rn_args } - where - fun_orig = exprCtOrigin (case fun_ctxt of - VAExpansion e _ -> e - VACall e _ _ -> e) - - -- 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 rn_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) - - -- Rule IALL from Fig 4 of the QL paper - -- 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 fun_ctxt $ - instantiateSigma fun_orig tvs theta body2 - -- addHeadCtxt: important for the class constraints - -- that may be emitted from instantiating fun_sigma - ; 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 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_at = at, eva_hs_ty = hs_ty } - : rest_args ) - | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] - = go delta acc so_far fun_ty rest_args - - | otherwise - = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty - ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_at = at, 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 matchActualFunTysRho - -- but there are many small differences: - -- - We know that the function type in unfilled meta-tyvar - -- matchActualFunTysRho 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 valArgsCount = countLeadingValArgs args - ; arg_nus <- replicateM valArgsCount newOpenFlexiTyVar - -- We need variables for multiplicity (#18731) - -- Otherwise, 'undefined x' wouldn't be linear in x - ; mults <- replicateM valArgsCount (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 { (wrap, arg_ty, res_ty) <- - matchActualFunTySigma - (ExpectedFunTyArg (HsExprRnThing rn_fun) (unLoc arg)) - (Just $ HsExprRnThing rn_fun) - (n_val_args, so_far) 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 } - - -addArgCtxt :: AppCtxt -> LHsExpr GhcRn - -> TcM a -> TcM a --- There are two cases: --- * In the normal case, we add an informative context --- "In the third argument of f, namely blah" --- * If we are deep inside generated code (isGeneratedCode) --- 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 HsExpansion] in GHC.Hs.Expr -addArgCtxt ctxt (L arg_loc arg) thing_inside - = do { in_generated_code <- inGeneratedCode - ; case ctxt of - VACall fun arg_no _ | not in_generated_code - -> setSrcSpanA arg_loc $ - addErrCtxt (funAppCtxt fun arg arg_no) $ - thing_inside - - _ -> setSrcSpanA arg_loc $ - addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated - thing_inside } - -{- ********************************************************************* -* * - Visible type application -* * -********************************************************************* -} - -tcVTA :: 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 fun_ty hs_ty - | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty - , binderFlag tvb == Specified - -- It really can't be Inferred, because we've just - -- instantiated those. But, oddly, it might just be Required. - -- See Note [Required quantifiers in the type of a term] - = do { let tv = binderVar tvb - kind = tyVarKind tv - ; ty_arg <- tcHsTypeApp hs_ty kind - - ; inner_ty <- liftZonkM $ zonkTcType inner_ty - -- See Note [Visible type application zonk] - - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg]) - insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty - -- NB: tv and ty_arg have the same kind, so this - -- substitution is kind-respecting - ; traceTc "VTA" (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) } - - | otherwise - = do { (_, fun_ty) <- liftZonkM $ zonkTidyTcType emptyTidyEnv fun_ty - ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty } - -{- Note [Required quantifiers in the type of a term] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15859) - - data A k :: k -> Type -- A :: forall k -> k -> Type - type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type - a = (undefined :: KindOf A) @Int - -With ImpredicativeTypes (thin ice, I know), we instantiate -KindOf at type (forall k -> k -> Type), so - KindOf A = forall k -> k -> Type -whose first argument is Required - -We want to reject this type application to Int, but in earlier -GHCs we had an ASSERT that Required could not occur here. - -The ice is thin; c.f. Note [No Required PiTyBinder in terms] -in GHC.Core.TyCo.Rep. - -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've already inferred the type of -the function (in tcInferAppHead), so 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. - -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 [Visible type application zonk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg). - -* tcHsTypeApp only guarantees that - - ty_arg is zonked - - kind(zonk(tv)) = kind(ty_arg) - (checkExpectedKind zonks as it goes). - -So we must zonk inner_ty as well, to guarantee consistency between zonk(tv) -and inner_ty. Otherwise we can build an ill-kinded type. An example was #14158, -where we had: - id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a -and we had the visible type application - id @(->) - -* We instantiated k := kappa, yielding - forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a -* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *). -* That instantiated (->) as ((->) q1 q1), and unified kappa := q1, - Here q1 :: RuntimeRep -* Now we substitute - cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> * - but we must first zonk the inner_ty to get - forall (a :: TYPE q1). cat a a - so that the result of substitution is well-kinded - Failing to do so led to #14158. - --} - -{- ********************************************************************* -* * - 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 { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg - ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args - ; traceTc "quickLookArg 1" $ - vcat [ text "arg:" <+> ppr arg - , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty - , 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 fun 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') +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE TypeApplications #-} -- Wrinkle in Note [Trees That Grow] + +{- +% +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module GHC.Tc.Gen.App + ( tcApp + , tcExprPrag ) where + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) + +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.ErrCtxt ( FunAppCtxtFunArg(..) ) +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. +-} + + +{- ********************************************************************* +* * + 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 runInferExpr). + +There is no special treatment for HsHole (HsVar ...), HsOverLit, etc, because +we can't get a polytype from them. + +Left and right sections (e.g. (x +) and (+ x)) are not yet supported. +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) + -- inst_final: top-instantiate the result type of the application, + -- EXCEPT if we are trying to infer a sigma-type + inst_final = case exp_res_ty of + Check {} -> True + Infer (IR {ir_inst=iif}) -> + case iif of + IIF_ShallowRho -> True + IIF_DeepRho -> True + IIF_Sigma -> False + + -- Step 3: Instantiate the function type (taking a quick look at args) + ; do_ql <- wantQuickLook rn_fun + ; (inst_args, app_res_rho) + <- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in + -- Note [tcApp: typechecking applications] + tcInstFun do_ql inst_final 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: zonk to expose the polymophism hidden under + -- QuickLook instantiation variables in `app_res_rho` + ; app_res_rho <- liftZonkM $ zonkTcType app_res_rho + + -- Step 5.4: subsumption check against the expected type + ; res_wrap <- checkResultTy rn_expr tc_head inst_args + app_res_rho exp_res_ty + -- 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) + ; traceTc "End tcApp }" (ppr tc_fun) + ; return (mkHsWrap res_wrap res_expr) } + +-- | Connect up the inferred type of an application with the expected type. +-- This is usually just a unification, but with deep subsumption there is more to do. +checkResultTy :: HsExpr GhcRn + -> (HsExpr GhcTc, AppCtxt) -- Head + -> [HsExprArg p] -- Arguments, just error messages + -> TcRhoType -- Inferred type of the application; zonked to + -- expose foralls, but maybe not /deeply/ instantiated + -> ExpRhoType -- Expected type; this is deeply skolemised + -> TcM HsWrapper +checkResultTy rn_expr _fun _inst_args app_res_rho (Infer inf_res) + = fillInferResult (exprCtOrigin rn_expr) app_res_rho inf_res + -- fillInferResult does deep instantiation if DeepSubsumption is on + +checkResultTy rn_expr (tc_fun, fun_ctxt) inst_args app_res_rho (Check res_ty) +-- Unify with expected type from the context +-- 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. + 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 _ (WithUserRdr _ 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 /top-level, inferred/ variables; + -- so may return a sigma-type + -- True <=> Instantiate /top-level, invisible/ type variables; + -- always return a rho-type (but not a deep-rho type) + -- Generally speaking we pass in True; in Fig 5 of the paper + -- |-inst returns a rho-type + -> (HsExpr GhcTc, AppCtxt) + -> TcSigmaType -> [HsExprArg 'TcpRn] + -> TcM ( [HsExprArg 'TcpInst] + , TcSigmaType ) -- Does not instantiate trailing invisible foralls +-- This crucial function implements the |-inst judgement in Fig 4, plus the +-- modification in Fig 5, of the QL paper: +-- "A quick look at impredicativity" (ICFP'20). +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 + HsHole _ -> True + _ -> False + + inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool + -- True <=> instantiate a tyvar that has this ForAllTyFlag + inst_fun [] | inst_final = isInvisibleForAllTyFlag + | otherwise = const False + 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 (FunAppCtxtExpr 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 + <* failIfErrsM -- Suppress unhelpful errors that arise after a failed T2T + 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 :: HsMultAnnOf (LHsExpr GhcRn) GhcRn -> TcM (HsMultAnn GhcRn) + go_arrow (HsUnannotated _) = pure (HsUnannotated noExtField) + go_arrow (HsLinearAnn{}) = pure (HsLinearAnn noExtField) + go_arrow (HsExplicitMult _ exp) = HsExplicitMult noExtField <$> go exp + go (L l (HsForAll _ tele expr)) = + do { ty <- go expr + ; 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)) = + -- GHC Proposal #281, section 7.5 "T2T-Mapping": + -- variables and constructors (regardless of their namespace) + -- are mapped directly, without modification. + do { detect_puns lname + ; return (L l (HsTyVar noAnn NotPromoted lname)) } + go (L l (HsApp _ lhs rhs)) = + do { lhs' <- go lhs + ; rhs' <- go rhs + ; 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 (HsHole (HoleVar (L _ 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 $ TcRnNotInScope NotInScope rdr + go (L l (XExpr (ExpandedThingRn (OrigExpr orig) _))) = + -- Use the original, user-written expression (before expansion). + -- Example. Say we have vfun :: forall a -> blah + -- 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 + + detect_puns :: LocatedN (WithUserRdr Name) -> TcM () + -- GHC Proposal #281, section 7.5 "T2T-Mapping": + -- there should be no variable of the same name but from + -- a different namespace, or else raise an ambiguity error + -- (does not apply to constructors) + detect_puns (L l (WithUserRdr rdr _)) + | isTermVarOrFieldNameSpace (rdrNameSpace rdr) + , Just promoted_rdr <- promoteRdrName rdr + = do { envs <- getRdrEnvs + ; whenIsJust (lookup_rdr envs rdr) $ \unpromoted -> + whenIsJust (lookup_rdr envs promoted_rdr) $ \promoted -> + addErrAt (locA l) $ + TcRnIllegalPunnedVarOccInTypeArgument { illegalPunTermName = unpromoted + , illegalPunTypeName = promoted } } + | otherwise = return () + + lookup_rdr :: (GlobalRdrEnv, LocalRdrEnv) -> RdrName -> Maybe ResolvedNameInfo + lookup_rdr (gbl_env, lcl_env) rdr + | Just name <- lookupLocalRdrEnv lcl_env rdr + = Just (ResolvedNameInfo [] rdr name) + | gres@(gre:_) <- lookupGRE gbl_env (LookupRdrName rdr (RelevantGREsFOS WantNormal)) + = Just (ResolvedNameInfo gres rdr (gre_name gre)) + | otherwise = Nothing + + unwrap_wc :: HsWildCardBndrs GhcRn t -> TcM t + unwrap_wc (HsWC wcs t) + = do { mapM_ (illegal_wc . nameRdrName) wcs + ; 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 HsHole (HsVar ...). + 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_lvl <- getThLevel + ; ty_arg <- case mb_conc of + Nothing -> return ty_arg0 + Just conc + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | TypedBrack {} <- th_lvl + -> return ty_arg0 + | otherwise + -> + -- Example: user wrote e.g. (#,#) @(F Bool) for a type family F. + -- Emit [W] F Bool ~ kappa[conc] and pretend the user wrote (#,#) @kappa. + coercionRKind <$> unifyConcrete (occNameFS $ getOccName $ tv_nm) conc ty_arg0 + + ; 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 [Pat] -- (Con @tp1 @tp2 p1 p2) (constructor pattern) + | EmbTyPat HsTyPat -- (type tp) (embed a type into a pattern with `type`) + | InvisPat HsTyPat -- (@tp) (invisible type pattern) + | ... + data HsTyPat = HsTP LHsType + (In ConPat, the type and term arguments are actually inside HsConPatDetails.) + + * Similar to HsAppType in HsExpr, InvisPat in ConPat is used for @ty arguments + * Similar to HsEmbTy in HsExpr, EmbTyPat lets you embed a type in a pattern + +* Examples: + \ (MkT @a (x :: a)) -> rhs -- ConPat (c.o. Pat) and InvisPat (c.o. Pat) + \ (type a) (x :: a) -> rhs -- EmbTyPat (c.o. Pat) + \ a (x :: a) -> rhs -- VarPat (c.o. Pat) + \ @a (x :: a) -> rhs -- InvisPat (c.o. Pat) + +* 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 (HsHole (HsVar "wurble")) for 'wurble', +and the typechecker will typecheck it with tcUnboundId, giving it +a type 'alpha', and emitting a deferred Hole constraint, to +be reported later. + +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 HsHole. We use this info to simply skip +over any visible type arguments. We'll /already/ have emitted a +Hole constraint; failing preserves that constraint. + +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 + = do { cur_lvl <- getTcLevel + -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles + -- Here we are in the TcM monad, which does not track enclosing + -- Given equalities; so for quick-look unification we conservatively + -- treat /any/ level outside this one as untouchable. Hence cur_lvl. + ; case simpleUnifyCheck UC_QuickLook cur_lvl kappa ty2 of + SUC_CanUnify -> + do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind + -- unifyKind: see (UQL2) in Note [QuickLook unification] + -- and (MIV2) in Note [Monomorphise instantiation variables] + ; let ty2' = mkCastTy ty2 co + ; traceTc "qlUnify:update" $ + ppr kappa <+> text ":=" <+> ppr ty2 + ; liftZonkM $ writeMetaTyVar kappa ty2' } + _ -> return () -- e.g. occurs-check or forall-bound variable + } + where + kappa_kind = tyVarKind kappa + ty2_kind = typeKind ty2 + +{- 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 () {- ********************************************************************* diff --git a/GHC/Tc/Gen/Arrow.hs b/GHC/Tc/Gen/Arrow.hs --- a/GHC/Tc/Gen/Arrow.hs +++ b/GHC/Tc/Gen/Arrow.hs @@ -40,7 +40,6 @@ import GHC.Types.Var.Set import GHC.Builtin.Types.Prim import GHC.Types.Basic( Arity ) -import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -150,32 +149,22 @@ ; return (L loc cmd') } tc_cmd :: CmdEnv -> HsCmd GhcRn -> CmdType -> TcM (HsCmd GhcTc) -tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty +tc_cmd env (HsCmdPar x cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty - ; return (HsCmdPar x lpar cmd' rpar) } + ; return (HsCmdPar x cmd') } -tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty +tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty = do { (binds', body') <- tcLocalBinds binds $ setSrcSpan (locA body_loc) $ tc_cmd env body res_ty - ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) } + ; return (HsCmdLet x binds' (L body_loc body')) } tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty) - = addErrCtxt (cmdCtxt in_cmd) $ do - (scrut', scrut_ty) <- tcInferRho scrut - hasFixedRuntimeRep_syntactic - (FRRArrow $ ArrowCmdCase) - scrut_ty - matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty) - return (HsCmdCase x scrut' matches') - -tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty - = addErrCtxt (cmdCtxt cmd) - do { let match_ctxt = ArrowLamCaseAlt lc_variant - ; checkArgCounts (ArrowMatchCtxt match_ctxt) match - ; (wrap, match') <- - tcCmdMatchLambda env match_ctxt match cmd_ty - ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) } + = addErrCtxt (CmdCtxt in_cmd) $ do + do { (scrut', scrut_ty) <- tcInferRho scrut + ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdCase) scrut_ty + ; matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty) + ; return (HsCmdCase x scrut' matches') } tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcCheckMonoExpr pred boolTy @@ -221,7 +210,7 @@ -- (plus -<< requires ArrowApply) tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (CmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; let fun_ty = mkCmdArrTy env arg_ty res_ty ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty) @@ -252,7 +241,7 @@ -- D;G |-a cmd exp : stk --> res tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) $ + = addErrCtxt (CmdCtxt cmd) $ do { arg_ty <- newOpenFlexiTyVarTy ; fun' <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty) ; arg' <- tcCheckMonoExpr arg arg_ty @@ -268,9 +257,14 @@ -- ------------------------------ -- D;G |-a (\x.cmd) : (t,stk) --> res -tc_cmd env (HsCmdLam x match) cmd_ty - = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr match cmd_ty - ; return (mkHsCmdWrap wrap (HsCmdLam x match')) } +tc_cmd env cmd@(HsCmdLam x lam_variant match) cmd_ty + = (case lam_variant of -- Add context only for \case and \cases + LamSingle -> id -- Avoids clutter in the vanilla-lambda form + _ -> addErrCtxt (CmdCtxt cmd)) $ + do { let match_ctxt = ArrowLamAlt lam_variant + ; arity <- checkArgCounts match + ; (wrap, match') <- tcCmdMatchLambda env match_ctxt arity match cmd_ty + ; return (mkHsCmdWrap wrap (HsCmdLam x lam_variant match')) } ------------------------------------------- -- Do notation @@ -295,15 +289,15 @@ -- ---------------------------------------------- -- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) - = addErrCtxt (cmdCtxt cmd) +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' ; let e_ty = mkInfForAllTy alphaTyVar $ 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) @@ -324,28 +318,27 @@ -> CmdType -> TcM (MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatches env scrut_ty matches (stk, res_ty) - = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty) + = tcCaseMatches ctxt tc_body (unrestricted scrut_ty) matches (mkCheckExpType res_ty) where - match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt, - mc_body = mc_body } - mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' + ctxt = ArrowMatchCtxt ArrowCaseAlt + tc_body body res_ty' = do { res_ty' <- expTypeToType res_ty' ; tcCmd env body (stk, res_ty') } -- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'. tcCmdMatchLambda :: CmdEnv -> HsArrowMatchContext + -> Arity -> MatchGroup GhcRn (LHsCmd GhcRn) -> CmdType -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) -tcCmdMatchLambda env - ctxt +tcCmdMatchLambda env ctxt arity mg@MG { mg_alts = L l matches, mg_ext = origin } (cmd_stk, res_ty) - = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk + = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs arity cmd_stk ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys ; matches' <- forM matches $ - addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk' + addErrCtxt . MatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk' ; let arg_tys' = map unrestricted arg_tys mg' = mg { mg_alts = L l matches' @@ -353,32 +346,29 @@ ; return (mkWpCastN co, mg') } where - n_pats | isEmptyMatchGroup mg = 1 -- must be lambda-case - | otherwise = matchGroupArity mg - -- 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 $ - tcPats match_ctxt pats arg_tys $ + 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 pg_ctxt = PatGuard match_ctxt tc_grhss (GRHSs x grhss binds) stk_ty res_ty - = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss + = do { (binds',grhss') <- tcLocalBinds binds $ + mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss ; return (GRHSs x grhss' binds') } tc_grhs stk_ty res_ty (GRHS x guards body) = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ \ res_ty -> tcCmd env body - (stk_ty, checkingExpType "tc_grhs" res_ty) + (stk_ty, checkingExpType res_ty) ; return (GRHS x guards' rhs') } matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) @@ -480,14 +470,3 @@ arrowTyConKind :: Kind -- *->*->* arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind - -{- -************************************************************************ -* * - Errors -* * -************************************************************************ --} - -cmdCtxt :: HsCmd GhcRn -> SDoc -cmdCtxt cmd = text "In the command:" <+> ppr cmd diff --git a/GHC/Tc/Gen/Bind.hs b/GHC/Tc/Gen/Bind.hs --- a/GHC/Tc/Gen/Bind.hs +++ b/GHC/Tc/Gen/Bind.hs @@ -23,7 +23,7 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) +import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcFunBindMatches ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) @@ -45,7 +45,8 @@ import GHC.Tc.Solver import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint - +import GHC.Core.Predicate +import GHC.Core.UsageEnv ( bottomUE ) import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Utils.TcMType @@ -53,17 +54,16 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Validity (checkValidType, checkEscapingKind) import GHC.Tc.Zonk.TcType - -import GHC.Core.Predicate ( getEqPredTys_maybe ) import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity 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, mkCastTy) import GHC.Core.TyCo.Ppr( pprTyVars ) +import GHC.Core.TyCo.Tidy( tidyOpenTypeX ) -import GHC.Builtin.Types ( mkConstraintTupleTy ) +import GHC.Builtin.Types ( mkConstraintTupleTy, multiplicityTy, oneDataConTy ) import GHC.Builtin.Types.Prim import GHC.Unit.Module @@ -78,15 +78,12 @@ import GHC.Types.SourceFile import GHC.Types.SrcLoc -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 @@ -95,7 +92,7 @@ import GHC.Data.Maybe import Control.Monad -import Data.Foldable (find) +import Data.Foldable (find, traverse_) {- ************************************************************************ @@ -198,48 +195,22 @@ (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs ; 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) (L _ ns) mb_tc_nm)) - = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do - cls <- mkUniqDSet <$> mapM (addLocMA 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) - ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } + 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 where @@ -250,6 +221,7 @@ tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) ------------------------ + tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing) @@ -280,22 +252,11 @@ -- ?y = ?x + 1 tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc) tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr) - = do { ty <- newOpenFlexiTyVarTy + = do { ty <- newFlexiTyVarTy liftedTypeKind -- see #24298 ; let p = mkStrLitTy $ hsIPNameFS ip - ; ip_id <- newDict ipClass [ p, ty ] + ; ip_id <- newDict ipClass [p, ty] ; expr' <- tcCheckMonoExpr expr ty - ; let d = fmap (toDict ipClass p ty) expr' - ; return (ip_id, (IPBind ip_id l_name d)) } - - -- Coerces a `t` into a dictionary for `IP "x" t`. - -- co : t -> IP "x" t - toDict :: Class -- IP class - -> Type -- type-level string for name of IP - -> Type -- type of IP - -> HsExpr GhcTc -- def'n of IP variable - -> HsExpr GhcTc -- dictionary for IP - toDict ipClass x ty = mkHsWrap $ mkWpCastR $ - wrapIP $ mkClassPred ipClass [x,ty] + ; return (ip_id, IPBind ip_id l_name expr') } tcValBinds :: TopLevelFlag -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] @@ -331,9 +292,10 @@ ; return (binds' ++ extra_binds', thing) }} where patsyns = getPatSynBinds binds - prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds) + prag_fn = mkPragEnv sigs (concatMap snd binds) ------------------------ + tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing -> TcM ([(RecFlag, LHsBinds GhcTc)], thing) @@ -387,12 +349,12 @@ -- 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" ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed - thing_inside + thing_inside ; return ( [(NonRecursive, bind')], thing) } tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside @@ -419,10 +381,11 @@ go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc -- recursive bindings must be unrestricted -- (the ids added to the environment here are the name of the recursive definitions). - ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn closed ids1 - (go sccs) - ; return (binds1 `unionBags` binds2, thing) } - go [] = do { thing <- thing_inside; return (emptyBag, thing) } + ; (binds2, thing) <- + tcExtendLetEnv top_lvl sig_fn closed ids1 + (go sccs) + ; return (binds1 ++ binds2, thing) } + go [] = do { thing <- thing_inside; return ([], thing) } tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind] tc_scc (CyclicSCC binds) = tc_sub_group Recursive binds @@ -455,8 +418,6 @@ NonRecursive NonRecursive closed [lbind] - -- since we are defining a non-recursive binding, it is not necessary here - -- to define an unrestricted binding. But we do so until toplevel linear bindings are supported. ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside ; return (binds1, thing) } @@ -481,7 +442,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 @@ -494,7 +455,7 @@ -- dependencies based on type signatures -> IsGroupClosed -- Whether the group is closed -> [LHsBind GhcRn] -- None are PatSynBind - -> TcM (LHsBinds GhcTc, [TcId]) + -> TcM (LHsBinds GhcTc, [Scaled TcId]) -- Typechecks a single bunch of values bindings all together, -- and generalises them. The bunch may be only part of a recursive @@ -517,11 +478,13 @@ ; dflags <- getDynFlags ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list ; traceTc "Generalisation plan" (ppr plan) - ; result@(_, poly_ids) <- case plan of - NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen -> tcPolyInfer rec_tc prag_fn sig_fn bind_list + ; result@(_, scaled_poly_ids) <- case plan of + NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list + InferGen -> tcPolyInfer top_lvl rec_tc prag_fn sig_fn bind_list CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind + ; let poly_ids = map scaledThing scaled_poly_ids + ; mapM_ (\ poly_id -> hasFixedRuntimeRep_syntactic (FRRBinder $ idName poly_id) (idType poly_id)) poly_ids @@ -533,7 +496,7 @@ ; return result } where binder_names = collectHsBindListBinders CollNoDictBinders bind_list - loc = foldr1 combineSrcSpans (map (locA . getLoc) bind_list) + loc = foldr1WithDefault noSrcSpan combineSrcSpans (map (locA . getLoc) bind_list) -- The mbinds have been dependency analysed and -- may no longer be adjacent; so find the narrowest -- span that includes them all @@ -542,11 +505,11 @@ -- If typechecking the binds fails, then return with each -- signature-less binder given type (forall a.a), to minimise -- subsequent error messages -recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id]) +recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Scaled Id]) recoveryCode binder_names sig_fn = do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names) - ; let poly_ids = map mk_dummy binder_names - ; return (emptyBag, poly_ids) } + ; let poly_ids = map (Scaled ManyTy) $ map mk_dummy binder_names + ; return ([], poly_ids) } where mk_dummy name | Just sig <- sig_fn name @@ -575,7 +538,7 @@ -- dependencies based on type signatures -> TcPragEnv -> TcSigFun -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTc, [TcId]) + -> TcM (LHsBinds GhcTc, [Scaled TcId]) tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn @@ -584,9 +547,9 @@ ; mono_ids' <- mapM tc_mono_info mono_infos ; return (binds', mono_ids') } where - tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id }) + tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id, mbi_mono_mult = mult }) = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name) - ; return mono_id } + ; return $ Scaled mult mono_id } -- NB: tcPrags generates error messages for -- specialisation pragmas for non-overloaded sigs -- Indeed that is why we call it here! @@ -600,37 +563,36 @@ ********************************************************************* -} tcPolyCheck :: TcPragEnv - -> TcIdSigInfo -- Must be a complete signature + -> TcCompleteSig -> LHsBind GhcRn -- Must be a FunBind - -> TcM (LHsBinds GhcTc, [TcId]) + -> TcM (LHsBinds GhcTc, [Scaled TcId]) -- There is just one binding, -- it is a FunBind -- it has a complete type signature, tcPolyCheck prag_fn - (CompleteSig { sig_bndr = poly_id - , sig_ctxt = ctxt - , sig_loc = sig_loc }) + sig@(CSig { sig_bndr = poly_id, sig_ctxt = ctxt }) (L bind_loc (FunBind { fun_id = L nm_loc name , fun_matches = matches })) - = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) + = do { traceTc "tcPolyCheck" (ppr sig) + -- Make a new Name, whose SrcSpan is nm_loc. For a ClassOp + -- The original Name, in the FunBind{fun_id}, is bound in the + -- class declaration, whereas we want a Name bound right here. + -- We pass mono_name to tcFunBindMatches which in turn puts it in + -- the BinderStack, whence it shows up in "Relevant bindings.." ; mono_name <- newNameAt (nameOccName name) (locA nm_loc) + + ; mult <- newMultiplicityVar ; (wrap_gen, (wrap_res, matches')) - <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems - tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> - -- Unwraps multiple layers; e.g - -- f :: forall a. Eq a => forall b. Ord b => blah - -- NB: tcSkolemiseScoped makes fresh type variables - -- See Note [Instantiate sig with fresh variables] + <- tcSkolemiseCompleteSig sig $ \invis_pat_tys rho_ty -> - let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in + let mono_id = mkLocalId mono_name (idMult poly_id) rho_ty in tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $ -- Why mono_id in the BinderStack? - -- See Note [Relevant bindings and the binder stack] + -- See Note [Relevant bindings and the binder stack] - setSrcSpanA bind_loc $ - tcMatchesFun (L nm_loc (idName mono_id)) matches - (mkCheckExpType rho_ty) + setSrcSpanA bind_loc $ + tcFunBindMatches ctxt mono_name mult matches invis_pat_tys (mkCheckExpType rho_ty) -- We make a funny AbsBinds, abstracting over nothing, -- just so we have somewhere to put the SpecPrags. @@ -648,8 +610,7 @@ ; let bind' = FunBind { fun_id = L nm_loc poly_id2 , fun_matches = matches' - , fun_ext = (wrap_gen <.> wrap_res, tick) - } + , fun_ext = (wrap_gen <.> wrap_res, tick) } export = ABE { abe_wrap = idHsWrapper , abe_poly = poly_id @@ -661,10 +622,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, [poly_id]) } + ; return ([abs_bind], [Scaled mult poly_id]) } tcPolyCheck _prag_fn sig bind = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) @@ -708,18 +669,68 @@ * * ********************************************************************* -} +{- 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 +- is a non-variable pattern +- binds variables to polymorphic or qualified types + +A detailed explanation can be found at: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst#let-bindings-and-polymorphism + +To address this we to do a few things + +- (NVP1) 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 + 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 + + 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 - :: RecFlag -- Whether it's recursive after breaking + :: TopLevelFlag + -> RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> TcPragEnv -> TcSigFun -> [LHsBind GhcRn] - -> TcM (LHsBinds GhcTc, [TcId]) -tcPolyInfer rec_tc prag_fn tc_sig_fn bind_list + -> TcM (LHsBinds GhcTc, [Scaled TcId]) +tcPolyInfer top_lvl rec_tc prag_fn tc_sig_fn bind_list = do { (tclvl, wanted, (binds', mono_infos)) <- pushLevelAndCaptureConstraints $ tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list ; 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] + ; manyIfPats binds' + ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos)) ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) @@ -729,11 +740,12 @@ ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) ; ((qtvs, givens, ev_binds, insoluble), residual) - <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted + <- captureConstraints $ simplifyInfer top_lvl tclvl infer_mode sigs name_taus wanted ; let inferred_theta = map evVarPred givens - ; exports <- checkNoErrs $ + ; scaled_exports <- checkNoErrs $ mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos + ; let exports = map scaledThing scaled_exports -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate @@ -743,7 +755,8 @@ ; emitConstraints residual ; loc <- getSrcSpanM - ; let poly_ids = map abe_poly exports + ; let scaled_poly_ids = [ Scaled p (abe_poly export) | Scaled p export <- scaled_exports] + poly_ids = map scaledThing scaled_poly_ids abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $ AbsBinds { abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] @@ -751,8 +764,15 @@ , abs_sig = False } ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids)) - ; return (unitBag abs_bind, poly_ids) } + ; return ([abs_bind], scaled_poly_ids) } -- poly_ids are guaranteed zonked by mkExport + where + manyIfPat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) + = return () + manyIfPat (L _ (PatBind {pat_mult=mult_ann})) + = tcSubMult (NonLinearPatternOrigin GeneralisedPatternReason nlWildPatName) ManyTy (getTcMultAnn mult_ann) + manyIfPat _ = return () + manyIfPats binds' = traverse_ manyIfPat binds' checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool -- True <=> apply the MR @@ -771,8 +791,8 @@ no_mr_name (MBI { mbi_sig = Just sig }) | TISI { sig_inst_sig = info, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig = case info of - CompleteSig { sig_bndr = bndr } -> Just (idName bndr) - PartialSig { psig_name = nm } + TcCompleteSig (CSig { sig_bndr = bndr }) -> Just (idName bndr) + TcPartialSig (PSig { psig_name = nm }) | null theta, isNothing wcx -> Nothing -- f :: _ -> _ | otherwise -> Just nm -- f :: Num a => a -> _ -- For the latter case, we don't want the MR: @@ -800,13 +820,12 @@ -- The MR applies, but the signature is overloaded, and it's -- best to complain about this directly -- c.f #11339 -checkOverloadedSig (MBI { mbi_sig = mb_sig }) - | Just (TISI { sig_inst_sig = orig_sig, sig_inst_theta = theta, sig_inst_wcx = wcx }) <- mb_sig +checkOverloadedSig (MBI { mbi_sig = Just sig }) + | TISI { sig_inst_sig = orig_sig, sig_inst_theta = theta, sig_inst_wcx = wcx } <- sig , not (null theta && isNothing wcx) - = setSrcSpan (sig_loc orig_sig) $ + = setSrcSpan (tcIdSigLoc orig_sig) $ failWith $ TcRnOverloadedSig orig_sig - | otherwise - = return () +checkOverloadedSig _ = return () {- Note [When the MR applies] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -860,7 +879,7 @@ -- when typechecking the bindings -> [TyVar] -> TcThetaType -- Both already zonked -> MonoBindInfo - -> TcM ABExport + -> TcM (Scaled ABExport) -- Only called for generalisation plan InferGen, not by CheckGen or NoGen -- -- mkExport generates exports with @@ -877,14 +896,17 @@ mkExport prag_fn residual insoluble qtvs theta (MBI { mbi_poly_name = poly_name , mbi_sig = mb_sig - , mbi_mono_id = mono_id }) + , mbi_mono_id = mono_id + , mbi_mono_mult = mono_mult }) = do { mono_ty <- liftZonkM $ zonkTcType (idType mono_id) ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty -- NB: poly_id has a zonked type - ; poly_id <- addInlinePrags poly_id prag_sigs - ; spec_prags <- tcSpecPrags poly_id prag_sigs - -- tcPrags requires a zonked poly_id + ; poly_id <- addInlinePrags poly_id prag_sigs + ; spec_prags <- tcExtendIdEnv1 poly_name poly_id $ + tcSpecPrags poly_id prag_sigs + -- tcSpecPrags requires a zonked poly_id. It also needs poly_id to + -- be in the type env (so we can typecheck the SPECIALISE expression) -- See Note [Impedance matching] -- NB: we have already done checkValidType, including an ambiguity check, @@ -907,7 +929,8 @@ ; localSigWarn poly_id mb_sig - ; return (ABE { abe_wrap = wrap + ; return (Scaled mono_mult $ + ABE { abe_wrap = wrap -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id , abe_poly = poly_id , abe_mono = mono_id @@ -924,7 +947,7 @@ -> TcM TcId mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty | Just (TISI { sig_inst_sig = sig }) <- mb_sig_inst - , CompleteSig { sig_bndr = poly_id } <- sig + , TcCompleteSig (CSig { sig_bndr = poly_id }) <- sig = return poly_id | otherwise -- Either no type sig or partial type sig @@ -983,10 +1006,9 @@ ; return (binders, my_theta) } chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs - (Just (TISI { sig_inst_sig = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty }) - , sig_inst_wcx = wcx - , sig_inst_theta = annotated_theta - , sig_inst_skols = annotated_tvs })) + (Just (TISI { sig_inst_sig = sig, sig_inst_wcx = wcx + , sig_inst_theta = annotated_theta, sig_inst_skols = annotated_tvs })) + | TcPartialSig (PSig { psig_name = fn_name, psig_hs_ty = hs_ty }) <- sig = -- Choose quantifiers for a partial type signature do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs ; psig_qtv_bndrs <- liftZonkM $ mapM zonkInvisTVBinder psig_qtv_bndrs @@ -999,14 +1021,15 @@ -- Check whether the quantified variables of the -- partial signature have been unified together -- See Note [Quantified variables in partial type signatures] - ; mapM_ report_dup_tyvar_tv_err (findDupTyVarTvs psig_qtv_prs) + ; mapM_ (report_dup_tyvar_tv_err fn_name hs_ty) $ + findDupTyVarTvs psig_qtv_prs -- Check whether a quantified variable of the partial type -- signature is not actually quantified. How can that happen? -- See Note [Quantification and partial signatures] Wrinkle 4 -- in GHC.Tc.Solver - ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs - , not (tv `elem` qtvs) ] + ; mapM_ (report_mono_sig_tv_err fn_name hs_ty) + [ pr | pr@(_,tv) <- psig_qtv_prs, not (tv `elem` qtvs) ] ; annotated_theta <- liftZonkM $ zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx @@ -1083,10 +1106,10 @@ -- Return (annotated_theta ++ diff_theta) -- See Note [Extra-constraints wildcards] - report_dup_tyvar_tv_err (n1,n2) + report_dup_tyvar_tv_err fn_name hs_ty (n1,n2) = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) - report_mono_sig_tv_err (n,tv) + report_mono_sig_tv_err fn_name hs_ty (n,tv) = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty) where m_unif_ty = listToMaybe @@ -1099,15 +1122,13 @@ , Just lhs_tv <- [ getTyVar_maybe lhs ] , lhs_tv == tv ] -chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) })) +chooseInferredQuantifiers _ _ _ _ (Just sig) = pprPanic "chooseInferredQuantifiers" (ppr sig) -mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) +mk_inf_msg :: Name -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) mk_inf_msg poly_name poly_ty tidy_env = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty - ; let msg = vcat [ text "When checking the inferred type" - , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ] - ; return (tidy_env1, msg) } + ; return (tidy_env1, InferredTypeCtxt poly_name poly_ty) } -- | Warn the user about polymorphic local binders that lack type signatures. localSigWarn :: Id -> Maybe TcIdSigInst -> TcM () @@ -1119,7 +1140,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) } @@ -1251,27 +1272,6 @@ to Integer because of Num. See #7173. If we're dealing with a nondefaultable class, impedance matching can fail. See #23427. -Note [SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no point in a SPECIALISE pragma for a non-overloaded function: - reverse :: [a] -> [a] - {-# SPECIALISE reverse :: [Int] -> [Int] #-} - -But SPECIALISE INLINE *can* make sense for GADTS: - data Arr e where - ArrInt :: !Int -> ByteArray# -> Arr Int - ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) - - (!:) :: Arr e -> Int -> e - {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} - {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} - (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) - (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) - -When (!:) is specialised it becomes non-recursive, and can usefully -be inlined. Scary! So we only warn for SPECIALISE *without* INLINE -for a non-overloaded function. - ************************************************************************ * * tcMonoBinds @@ -1284,7 +1284,8 @@ data MonoBindInfo = MBI { mbi_poly_name :: Name , mbi_sig :: Maybe TcIdSigInst - , mbi_mono_id :: TcId } + , mbi_mono_id :: TcId + , mbi_mono_mult :: Mult } tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking purposes -- i.e. the binders are mentioned in their RHSs, and @@ -1301,44 +1302,75 @@ | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , Nothing <- sig_fn name -- ...with no type signature = setSrcSpanA b_loc $ - do { ((co_fn, matches'), rhs_ty') - <- tcInferFRR (FRRBinder name) $ \ exp_ty -> - -- tcInferFRR: the type of a let-binder must have - -- a fixed runtime rep. See #23176 - tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ - -- We extend the error context even for a non-recursive - -- function so that in type error messages we show the - -- type of the thing whose rhs we are type checking - tcMatchesFun (L nm_loc name) matches exp_ty - ; mono_id <- newLetBndr no_gen name ManyTy rhs_ty' + do { mult <- newMultiplicityVar - ; return (unitBag $ L b_loc $ - FunBind { fun_id = L nm_loc mono_id, + ; ((co_fn, matches'), rhs_ty') + <- runInferRhoFRR (FRRBinder name) $ \ exp_ty -> + -- runInferRhoFRR: the type of a let-binder must have + -- a fixed runtime rep. See #23176 + tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $ + -- We extend the error context even for a non-recursive + -- function so that in type error messages we show the + -- type of the thing whose rhs we are type checking. + -- See Note [Relevant bindings and the binder stack] + tcFunBindMatches (InfSigCtxt name) name mult matches [] exp_ty + ; mono_id <- newLetBndr no_gen name mult rhs_ty' + + ; return (singleton $ L b_loc $ + FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', - fun_ext = (co_fn, []) }, + fun_ext = (co_fn, []) }, [MBI { mbi_poly_name = name , mbi_sig = Nothing - , mbi_mono_id = mono_id }]) } + , mbi_mono_id = mono_id + , mbi_mono_mult = mult }]) } -- SPECIAL CASE 2: see Note [Special case for non-recursive pattern bindings] tcMonoBinds is_rec sig_fn no_gen - [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })] + [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann })] | NonRecursive <- is_rec -- ...binder isn't mentioned in RHS , all (isNothing . sig_fn) bndrs - = addErrCtxt (patMonoBindsCtxt pat grhss) $ - do { (grhss', pat_ty) <- tcInferFRR FRRPatBind $ \ exp_ty -> - -- tcInferFRR: the type of each let-binder must have + = addErrCtxt (PatMonoBindsCtxt pat grhss) $ + do { mult <- tcMultAnnOnPatBind mult_ann + + ; (grhss', pat_ty) <- runInferRhoFRR FRRPatBind $ \ exp_ty -> + -- runInferRhoFRR: the type of each let-binder must have -- a fixed runtime rep. See #23176 - tcGRHSsPat grhss exp_ty + tcGRHSsPat mult grhss exp_ty ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR - exp_pat_ty = unrestricted (mkCheckExpType pat_ty) - ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $ - mapM lookupMBI bndrs + exp_pat_ty = Scaled mult (mkCheckExpType pat_ty) + ; (_, (pat', mbis)) <- tcCollectingUsage $ + tcLetPat (const Nothing) no_gen pat exp_pat_ty $ do + tcEmitBindingUsage bottomUE + mapM lookupMBI bndrs + -- What's happening here? Typing pattern-matching (either from case + -- expression or equation) and typing bindings (let or where) have a + -- different control flow: for pattern-matching, the rhs is typed + -- within the `thing_inside` argument. The type-checker walks down + -- the pattern, and when finally it is done, all variables have been + -- added to the environment, thing_inside is called. So, when + -- type-checking patterns, the check for the correctness of + -- multiplicity is generated in the VarPat case. This is quite + -- natural. + -- + -- Bindings, however, have a more complex control flow for our + -- purpose: we collect all the variables as we go down, then return + -- them (here as `mapM lookupMBI bndrs`), and in a subsequent + -- computation (rather than an inner computation), the rhs is + -- type-checked. This poses a problem here: we're calling + -- `tcLetPat`, which will verify the proper usage of the introduced + -- variable when reaching the `VarPat` case. But there is no actual + -- usage of variable in the `thing_inside`. This would always + -- fail. So we emit a `bottomUE`, which is compatible with every + -- usage. So that we can bypass the check in VarPat. Then we use + -- `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_ext = (pat_ty, ([],[])) + , pat_mult = setTcMultAnn mult mult_ann } , mbis ) } where @@ -1365,7 +1397,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1446,8 +1478,8 @@ -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't data TcMonoBind -- Half completed; LHS done, RHS not done - = TcFunBind MonoBindInfo SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn)) - | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn)) + = TcFunBind MonoBindInfo SrcSpan Mult (MatchGroup GhcRn (LHsExpr GhcRn)) + | TcPatBind [MonoBindInfo] (LPat GhcTc) Mult (HsMultAnn GhcRn) (GRHSs GhcRn (LHsExpr GhcRn)) TcSigmaTypeFRR tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind @@ -1466,32 +1498,32 @@ -- Just g = ...f... -- Hence always typechecked with InferGen do { mono_info <- tcLhsSigId no_gen (name, sig) - ; return (TcFunBind mono_info (locA nm_loc) matches) } + ; mult <- newMultiplicityVar + ; return (TcFunBind mono_info (locA nm_loc) mult matches) } | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name ManyTy mono_ty - -- This ^ generates a binder with Many multiplicity because all - -- let/where-binders are unrestricted. When we introduce linear let - -- binders, we will need to retrieve the multiplicity information. + ; mult <- newMultiplicityVar + ; mono_id <- newLetBndr no_gen name mult mono_ty ; let mono_info = MBI { mbi_poly_name = name , mbi_sig = Nothing - , mbi_mono_id = mono_id } - ; return (TcFunBind mono_info (locA nm_loc) matches) } + , mbi_mono_id = mono_id + , mbi_mono_mult = mult} + ; return (TcFunBind mono_info (locA nm_loc) mult matches) } -tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss }) +tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann }) = -- See Note [Typechecking pattern bindings] do { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $ [ (mbi_poly_name mbi, mbi_mono_id mbi) | mbi <- sig_mbis ] - + ; mult <- tcMultAnnOnPatBind mult_ann -- See Note [Typechecking pattern bindings] ; ((pat', nosig_mbis), pat_ty) - <- addErrCtxt (patMonoBindsCtxt pat grhss) $ - tcInferFRR FRRPatBind $ \ exp_ty -> - tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $ + <- addErrCtxt (PatMonoBindsCtxt pat grhss) $ + runInferSigmaFRR FRRPatBind $ \ exp_ty -> + tcLetPat inst_sig_fun no_gen pat (Scaled mult exp_ty) $ -- The above inferred type get an unrestricted multiplicity. It may be -- worth it to try and find a finer-grained multiplicity here -- if examples warrant it. @@ -1503,12 +1535,12 @@ | mbi <- mbis, let id = mbi_mono_id mbi ] $$ ppr no_gen) - ; return (TcPatBind mbis pat' grhss pat_ty) } + ; return (TcPatBind mbis pat' mult mult_ann grhss pat_ty) } where bndr_names = collectPatBinders CollNoDictBinders pat (nosig_names, sig_names) = partitionWith find_sig bndr_names - find_sig :: Name -> Either Name (Name, TcIdSigInfo) + find_sig :: Name -> Either Name (Name, TcIdSig) find_sig name = case sig_fn name of Just (TcIdSig sig) -> Right (name, sig) _ -> Left name @@ -1526,21 +1558,23 @@ = do { mono_id <- tcLookupId name ; return (MBI { mbi_poly_name = name , mbi_sig = Nothing - , mbi_mono_id = mono_id }) } + , mbi_mono_id = mono_id + , mbi_mono_mult = idMult mono_id }) } ------------------- -tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo +tcLhsSigId :: LetBndrSpec -> (Name, TcIdSig) -> TcM MonoBindInfo tcLhsSigId no_gen (name, sig) = do { inst_sig <- tcInstSig sig ; mono_id <- newSigLetBndr no_gen name inst_sig ; return (MBI { mbi_poly_name = name , mbi_sig = Just inst_sig - , mbi_mono_id = mono_id }) } + , mbi_mono_id = mono_id + , mbi_mono_mult = idMult mono_id }) } ------------ newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig }) - | CompleteSig { sig_bndr = poly_id } <- id_sig + | TcCompleteSig (CSig { sig_bndr = poly_id }) <- id_sig = addInlinePrags poly_id (lookupPragEnv prags name) newSigLetBndr no_gen name (TISI { sig_inst_tau = tau }) = newLetBndr no_gen name ManyTy tau @@ -1551,30 +1585,42 @@ ------------------- tcRhs :: TcMonoBind -> TcM (HsBind GhcTc) tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id }) - loc matches) + loc mult matches) = tcExtendIdBinderStackForRhs [info] $ tcExtendTyVarEnvForRhs mb_sig $ - do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id)) - ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id)) - matches (mkCheckExpType $ idType mono_id) - ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id + do { let mono_ty = idType mono_id + mono_name = idName mono_id + ; traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr mono_ty) + ; (co_fn, matches') <- tcFunBindMatches (InfSigCtxt mono_name) mono_name mult + matches [] (mkCheckExpType mono_ty) + ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches' - , fun_ext = (co_fn, []) + , fun_ext = (co_fn, []) } ) } -tcRhs (TcPatBind infos pat' grhss pat_ty) +tcRhs (TcPatBind infos pat' mult mult_ann grhss pat_ty) = -- When we are doing pattern bindings we *don't* bring any scoped -- type variables into scope unlike function bindings -- Wny not? They are not completely rigid. -- That's why we have the special case for a single FunBind in tcMonoBinds tcExtendIdBinderStackForRhs infos $ do { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty) - ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $ - tcGRHSsPat grhss (mkCheckExpType pat_ty) + ; grhss' <- addErrCtxt (PatMonoBindsCtxt pat' grhss) $ + tcGRHSsPat mult grhss (mkCheckExpType pat_ty) ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = (pat_ty, ([],[])) } )} + , pat_ext = (pat_ty, ([],[])) + , pat_mult = setTcMultAnn mult mult_ann } )} + +-- | @'tcMultAnnOnPatBind' ann@ takes an optional multiplicity annotation. If +-- present the multiplicity is returned, otherwise a fresh unification variable +-- is generated so that multiplicity can be inferred. +tcMultAnnOnPatBind :: HsMultAnn GhcRn -> TcM Mult +tcMultAnnOnPatBind (HsLinearAnn _) = return oneDataConTy +tcMultAnnOnPatBind (HsExplicitMult _ p) = tcCheckLHsTypeInContext p (TheKind multiplicityTy) +tcMultAnnOnPatBind (HsUnannotated _) = newMultiplicityVar + tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvForRhs Nothing thing_inside = thing_inside @@ -1601,8 +1647,8 @@ getMonoBindInfo tc_binds = foldr (get_info . unLoc) [] tc_binds where - get_info (TcFunBind info _ _) rest = info : rest - get_info (TcPatBind infos _ _ _) rest = infos ++ rest + get_info (TcFunBind info _ _ _) rest = info : rest + get_info (TcPatBind infos _ _ _ _ _) rest = infos ++ rest {- Note [Relevant bindings and the binder stack] @@ -1643,7 +1689,7 @@ * (E2) is fine, despite the existential pattern, because q::Int, and nothing escapes. -* Even (E3) is fine. The existential pattern binds a dictionary +* Even (E3) is fine. The existential pattern bindings a dictionary for (Integral a) which the view pattern can use to convert the a-valued field to an Integer, so r :: Integer. @@ -1742,7 +1788,7 @@ | CheckGen -- One FunBind with a complete signature: (LHsBind GhcRn) -- do explicit generalisation - TcIdSigInfo -- Always CompleteSig + TcCompleteSig -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one @@ -1764,10 +1810,18 @@ | isTopLevel top_lvl = True -- See Note [Always generalise top-level bindings] - | IsGroupClosed _ True <- closed = True + | has_mult_anns_and_pats = False + -- See (NVP1) and (NVP4) in Note [Non-variable pattern bindings aren't linear] + + | IsGroupClosed _ True <- closed + , not (null binders) = True -- The 'True' means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore - -- -XMonoLocalBinds, and generalise anyway + -- -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. | has_partial_sigs = True -- See Note [Partial type signatures and generalisation] @@ -1778,7 +1832,7 @@ -- except a single function binding with a complete signature one_funbind_with_sig | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcIdSig sig@(CompleteSig {})) <- sig_fn (unLoc v) + , Just (TcIdSig (TcCompleteSig sig)) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise = Nothing @@ -1786,10 +1840,15 @@ binders = collectHsBindListBinders CollNoDictBinders lbinds has_partial_sigs = any has_partial_sig binders has_partial_sig nm = case sig_fn nm of - Just (TcIdSig (PartialSig {})) -> True - _ -> False + Just (TcIdSig (TcPartialSig {})) -> True + _ -> False + has_mult_anns_and_pats = any has_mult_ann_and_pat lbinds + has_mult_ann_and_pat (L _ (PatBind{pat_mult=HsUnannotated{}})) = False + has_mult_ann_and_pat (L _ (PatBind{pat_lhs=(L _ (VarPat{}))})) = False + has_mult_ann_and_pat (L _ (PatBind{})) = True + has_mult_ann_and_pat _ = False -isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed +isClosedBndrGroup :: TcTypeEnv -> [(LHsBind GhcRn)] -> IsGroupClosed isClosedBndrGroup type_env binds = IsGroupClosed fv_env type_closed where @@ -1856,15 +1915,3 @@ applying to, well, local bindings. -} -{- ********************************************************************* -* * - Error contexts and messages -* * -********************************************************************* -} - --- This one is called on LHS, when pat and grhss are both Name --- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId p) - => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc -patMonoBindsCtxt pat grhss - = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/GHC/Tc/Gen/Default.hs b/GHC/Tc/Gen/Default.hs --- a/GHC/Tc/Gen/Default.hs +++ b/GHC/Tc/Gen/Default.hs @@ -3,108 +3,344 @@ (c) The AQUA Project, Glasgow University, 1993-1998 -} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} -- | Typechecking @default@ declarations -module GHC.Tc.Gen.Default ( tcDefaults ) where +module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) where import GHC.Prelude - import GHC.Hs + +import GHC.Builtin.Names import GHC.Core.Class -import GHC.Core.Type( typeKind ) +import GHC.Core.Predicate ( Pred (..), classifyPredType ) -import GHC.Types.Var( tyVarKind ) +import GHC.Data.Maybe ( firstJusts, maybeToList ) + import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType -import GHC.Tc.Zonk.Type -import GHC.Tc.Solver -import GHC.Tc.Validity +import GHC.Tc.Solver.Monad ( runTcS ) +import GHC.Tc.Solver.Solve ( solveWanteds ) +import GHC.Tc.Types.Constraint ( isEmptyWC, andWC, mkSimpleWC ) +import GHC.Tc.Types.Origin ( CtOrigin(DefaultOrigin) ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType ( newWanted ) import GHC.Tc.Utils.TcType -import GHC.Builtin.Names -import GHC.Types.Error + +import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults (..), lookupDefaultEnv, insertDefaultEnv, DefaultProvenance (..) ) import GHC.Types.SrcLoc + +import GHC.Unit.Types (ghcInternalUnit, moduleUnit) + import GHC.Utils.Outputable + import qualified GHC.LanguageExtensions as LangExt import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) -tcDefaults :: [LDefaultDecl GhcRn] - -> TcM (Maybe [Type]) -- Defaulting types to heave - -- into Tc monad for later use - -- in Disambig. +{- Note [Named default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With the `NamedDefaults` language extension, a `default` declaration can specify type-class +defaulting behaviour for specific classes. For example -tcDefaults [] - = getDeclaredDefaultTys -- No default declaration, so get the - -- default types from the envt; - -- i.e. use the current ones - -- (the caller will put them back there) - -- It's important not to return defaultDefaultTys here (which - -- we used to do) because in a TH program, tcDefaults [] is called - -- repeatedly, once for each group of declarations between top-level - -- splices. We don't want to carefully set the default types in - -- one group, only for the next group to ignore them and install - -- defaultDefaultTys + class C a where + ... + default C( Int, Bool ) -- The default types for class C -tcDefaults [L _ (DefaultDecl _ [])] - = return (Just []) -- Default declaration specifying no types +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 -tcDefaults [L locn (DefaultDecl _ mono_tys)] - = setSrcSpan (locA locn) $ - addErrCtxt defaultDeclCtxt $ - 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 + default (Int, Bool) - ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys +the default declaration behaves as before, affecting primarily the `Num` class. - ; return (Just tau_tys) } +Moreover, a module export list can specify a list of classes whose defaults should be +exported. For example -tcDefaults (decl@(L locn (DefaultDecl _ _)) : decls) - = setSrcSpan (locA locn) $ - failWithTc (dupDefaultDeclErr (decl:|decls)) + module M( C, default C ) +would export the above `default` declaration for `C`. -tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type -tc_default_ty deflt_clss hs_ty - = do { ty <- solveEqualities "tc_default_ty" $ - tcInferLHsType hs_ty - ; ty <- zonkTcTypeToType ty -- establish Type invariants - ; checkValidType DefaultDeclCtxt ty +See details at +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0409-exportable-named-default.rst - -- 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 } +The moving parts are as follows: -check_instance :: Type -> Class -> TcM Bool --- Check that ty is an instance of cls --- We only care about whether it worked or not; return a boolean --- This checks that cls :: k -> Constraint --- with just one argument and no polymorphism; if we need to add --- polymorphism we can make it more complicated. For now we are --- concerned with classes like --- Num :: Type -> Constraint --- Foldable :: (Type->Type) -> Constraint -check_instance ty cls - | [cls_tv] <- classTyVars cls - , tyVarKind cls_tv `tcEqType` typeKind ty - = simplifyDefault [mkClassPred cls [ty]] - | otherwise - = return False +* Language.Haskell.Syntax.Decls.DefaultDecl: A `DefaultDecl` optionally carries + the specified class. -defaultDeclCtxt :: SDoc -defaultDeclCtxt = text "When checking the types in a default declaration" +* Parsing and renaming are entirely straightforward. -dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage -dupDefaultDeclErr (L _ (DefaultDecl _ _) :| dup_things) - = TcRnMultipleDefaultDeclarations dup_things +* 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.tcDefaultDecls` 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 [Builtin class defaults] in GHC.Tc.Utils.Env + +* Beside the defaults, the `ExtendedDefaultRules` and `OverloadedStrings` + extensions also affect the traditional `default` declarations that don't name + 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. + For example, + module M( ..., default C, ... ) + exports the defaults for class C. + + A module's exported defaults are computed by exports_from_avail, + tracked in tcg_default_exports, which are then transferred to mg_defaults, + md_defaults, and mi_defaults_. + + Only defaults explicitly exported are actually exported. + (i.e. No defaults are exported in a module header like: + module M where ...) + + See Note [Default exports] in GHC.Tc.Gen.Export + +* Since the class defaults merely help the solver infer the correct types, they + leave no trace in Haskell Core. +-} + +-- | Typecheck a collection of default declarations. These can be either: +-- +-- - Haskell 98 default declarations, of the form @default (Float, Double)@ +-- - Named default declarations, of the form @default Cls(Int, Char)@. +-- See Note [Named default declarations] +tcDefaultDecls :: [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] +tcDefaultDecls decls = + do + tcg_env <- getGblEnv + let here = tcg_mod tcg_env + is_internal_unit = moduleUnit here == ghcInternalUnit + case (is_internal_unit, decls) of + -- No default declarations + (_, []) -> return [] + -- As per Remark [default () in ghc-internal] in Note [Builtin class defaults], + -- some modules in ghc-internal include an empty `default ()` declaration, in order + -- to disable built-in defaults. This is no longer necessary (see `GHC.Tc.Utils.Env.tcGetDefaultTys`), + -- but we must still make sure not to error if we fail to look up e.g. the 'Num' + -- typeclass when typechecking such a default declaration. To do this, we wrap + -- calls of 'tcLookupClass' in 'tryTc'. + (True, [L _ (DefaultDecl _ Nothing [])]) -> do + h2010_dflt_clss <- foldMapM (fmap maybeToList . fmap fst . tryTc . tcLookupClass) =<< getH2010DefaultNames + case NE.nonEmpty h2010_dflt_clss of + Nothing -> return [] + Just h2010_dflt_clss' -> toClassDefaults h2010_dflt_clss' decls + -- Otherwise we take apart the declaration into the class constructor and its default types. + _ -> do + h2010_dflt_clss <- getH2010DefaultClasses + toClassDefaults h2010_dflt_clss decls + where + getH2010DefaultClasses :: TcM (NonEmpty Class) + -- All the classes subject to defaulting with a Haskell 2010 default + -- declaration, of the form: + -- + -- default (Int, Bool, Float) + -- + -- Specifically: + -- No extensions: Num + -- OverloadedStrings: add IsString + -- ExtendedDefaults: add Show, Eq, Ord, Foldable, Traversable + getH2010DefaultClasses = mapM tcLookupClass =<< getH2010DefaultNames + getH2010DefaultNames + = do { ovl_str <- xoptM LangExt.OverloadedStrings + ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules + ; let deflt_str = if ovl_str + then [isStringClassName] + else [] + ; let deflt_interactive = if ext_deflt + then interactiveClassNames + else [] + ; let extra_clss_names = deflt_str ++ deflt_interactive + ; return $ numClassName :| extra_clss_names + } + declarationParts :: NonEmpty Class -> LDefaultDecl GhcRn -> TcM (Maybe (Maybe Class, LDefaultDecl GhcRn, [Type])) + declarationParts h2010_dflt_clss decl@(L locn (DefaultDecl _ mb_cls_name dflt_hs_tys)) + = setSrcSpan (locA locn) $ + case mb_cls_name of + -- Haskell 98 default declaration + Nothing -> + do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True }) + $ mapMaybeM (check_instance_any h2010_dflt_clss) dflt_hs_tys + ; return $ Just (Nothing, decl, tau_tys) } + -- Named default declaration + Just cls_name -> + do { named_deflt <- xoptM LangExt.NamedDefaults + ; checkErr named_deflt (TcRnIllegalNamedDefault decl) + ; mb_cls <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = False }) + $ tcDefaultDeclClass cls_name + ; for mb_cls $ \ cls -> + do { tau_tys <- addErrCtxt (DefaultDeclErrCtxt { ddec_in_type_list = True }) + $ mapMaybeM (check_instance_any (NE.singleton cls)) dflt_hs_tys + ; return (Just cls, decl, tau_tys) + } } + + toClassDefaults :: NonEmpty Class -> [LDefaultDecl GhcRn] -> TcM [LocatedA ClassDefaults] + toClassDefaults h2010_dflt_clss dfs = do + dfs <- mapMaybeM (declarationParts h2010_dflt_clss) dfs + return $ concatMap (go False) dfs + where + go h98 = \case + (Nothing, rn_decl, tys) -> concatMap (go True) [(Just cls, rn_decl, tys) | cls <- NE.toList h2010_dflt_clss] + (Just cls, (L locn _), tys) -> [(L locn $ ClassDefaults cls tys (DP_Local (locA locn) h98) Nothing)] + +-- | Extend the default environment with the local default declarations +-- and do the action in the extended environment. +extendDefaultEnvWithLocalDefaults :: [LocatedA ClassDefaults] -> TcM a -> TcM a +extendDefaultEnvWithLocalDefaults decls action = do + tcg_env <- getGblEnv + let default_env = tcg_default tcg_env + new_default_env <- insertDefaultDecls default_env decls + updGblEnv (\gbl -> gbl { tcg_default = new_default_env } ) $ action + +-- | Insert local default declarations into the default environment. +-- +-- See 'insertDefaultDecl'. +insertDefaultDecls :: DefaultEnv -> [LocatedA ClassDefaults] -> TcM DefaultEnv +insertDefaultDecls = foldrM insertDefaultDecl +-- | Insert a local default declaration into the default environment. +-- +-- If the class already has a local default declaration in the DefaultEnv, +-- report an error and return the original DefaultEnv. Otherwise, override +-- any existing default declarations (e.g. imported default declarations). +-- +-- See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module +insertDefaultDecl :: LocatedA ClassDefaults -> DefaultEnv -> TcM DefaultEnv +insertDefaultDecl (L decl_loc new_cls_defaults ) default_env = + case lookupDefaultEnv default_env (className cls) of + Just cls_defaults + | DP_Local {} <- cd_provenance cls_defaults + -> do { setSrcSpan (locA decl_loc) (addErrTc $ TcRnMultipleDefaultDeclarations cls cls_defaults) + ; return default_env } + _ -> return $ insertDefaultEnv new_cls_defaults default_env + -- NB: this overrides imported and built-in default declarations + -- for this class, if there were any. + where + cls = cd_class new_cls_defaults + + +-- | Check that the type is an instance of at least one of the default classes. +-- +-- See Note [Instance check for default declarations] +check_instance_any :: NonEmpty Class + -- ^ classes, all assumed to be unary + -> LHsType GhcRn + -- ^ default type + -> TcM (Maybe Type) +check_instance_any deflt_clss ty + = do { oks <- mapM (\ cls -> simplifyDefault cls ty) deflt_clss + ; case firstJusts oks of + Nothing -> + do { addErrTc $ TcRnBadDefaultType ty deflt_clss + ; return Nothing } + Just ty -> + return $ Just ty + } + +-- | Given a class @C@ and a type @ty@, is @C ty@ soluble? +-- +-- Used to check that a type is an instance of a class in a default +-- declaration. +-- +-- See Note [Instance check for default declarations] in GHC.Tc.Solver.Default. +simplifyDefault + :: Class -- ^ class, assumed to be unary,i.e. it takes some invisible arguments + -- and then a single (final) visible argument + -> LHsType GhcRn -- ^ default type + -> TcM (Maybe Type) +simplifyDefault cls dflt_ty@(L l _) + = do { let app_ty :: LHsType GhcRn + app_ty = L l $ HsAppTy noExtField (nlHsTyVar NotPromoted (className cls)) dflt_ty + ; (inst_pred, wtds) <- captureConstraints $ tcCheckLHsType app_ty constraintKind + ; wtd_inst <- newWanted DefaultOrigin (Just TypeLevel) inst_pred + ; let all_wanteds = wtds `andWC` mkSimpleWC [wtd_inst] + ; (unsolved, _) <- runTcS $ solveWanteds all_wanteds + ; traceTc "simplifyDefault" $ + vcat [ text "cls:" <+> ppr cls + , text "dflt_ty:" <+> ppr dflt_ty + , text "inst_pred:" <+> ppr inst_pred + , text "all_wanteds " <+> ppr all_wanteds + , text "unsolved:" <+> ppr unsolved ] + ; let is_instance = isEmptyWC unsolved + ; return $ + if | is_instance + , ClassPred _ tys <- classifyPredType inst_pred + -- inst_pred looks like (C @k1 .. @kn t); + -- we want the final (visible) argument `t` + , Just tys_ne <- NE.nonEmpty tys + -> Just $ NE.last tys_ne + | otherwise + -> Nothing + } + +{- Note [Instance check for default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see a named default declaration, such as: + + default C(ty_1, ..., ty_n) + +we must check that each of the types 'ty1', ..., 'ty_n' is an instance of +the class 'C'. For each individual type 'ty', the strategy is thus: + + - Create a new Wanted constraint 'C ty', and run the solver on it. + The default declaration 'default C(ty)' is valid iff the solver succeeds + in solving this constraint (with no residual unsolved Wanteds). + +This is implemented in GHC.Tc.Gen.Default.check_instance, and tested in T25882. + +The only slightly subtle point is that we want to allow classes such as + + Typeable :: forall k. k -> Constraint + +which take invisible arguments and a (single) visible argument. The function +GHC.Tc.Gen.HsType.tcDefaultDeclClass checks that the class 'C' takes a single +visible parameter. + +Note that Haskell98 default declarations, of the form + + default (ty_1, ..., ty_n) + +work similarly, except that instead of checking for a single class, we check +whether each type is an instance of: + + - only the Num class, by default + - ... or the IsString class, with -XOverloadedStrings + - ... or any of the Show, Eq, Ord, Foldable, and Traversable classes, + with -XExtendedDefaultRules +-} diff --git a/GHC/Tc/Gen/Do.hs b/GHC/Tc/Gen/Do.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Gen/Do.hs @@ -0,0 +1,494 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +(c) The University of Iowa 2023 + +-} + +-- | Expand @Do@ block statements into @(>>=)@, @(>>)@ and @let@s +-- After renaming but right ebefore type checking +module GHC.Tc.Gen.Do (expandDoStmts) where + +import GHC.Prelude + +import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, + genHsLamDoExp, genHsCaseAltDoExp, genWildPat ) +import GHC.Rename.Env ( irrefutableConLikeRn ) + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType + +import GHC.Hs + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Driver.DynFlags ( DynFlags, getDynFlags ) +import GHC.Driver.Ppr (showPpr) + +import GHC.Types.SrcLoc +import GHC.Types.Basic +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ((\\)) + + +{- +************************************************************************ +* * +\subsection{XXExprGhcRn for Do Statements} +* * +************************************************************************ +-} + +-- | Expand the `do`-statments into expressions right after renaming +-- so that they can be typechecked. +-- See Note [Expanding HsDo with XXExprGhcRn] below for `HsDo` specific commentary +-- and Note [Handling overloaded and rebindable constructs] for high level commentary +expandDoStmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn) +expandDoStmts doFlav stmts = do expanded_expr <- expand_do_stmts doFlav stmts + case expanded_expr of + L _ (XExpr (PopErrCtxt e)) -> return e + -- The first expanded stmt doesn't need a pop as + -- it would otherwise pop the "In the expression do ... " from + -- the error context + _ -> return expanded_expr + +-- | The main work horse for expanding do block statements into applications of binds and thens +-- See Note [Expanding HsDo with XXExprGhcRn] +expand_do_stmts :: HsDoFlavour -> [ExprLStmt GhcRn] -> TcM (LHsExpr GhcRn) + +expand_do_stmts ListComp _ = + pprPanic "expand_do_stmts: impossible happened. ListComp" empty + -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` + +expand_do_stmts _ [] = pprPanic "expand_do_stmts: impossible happened. Empty stmts" empty + +expand_do_stmts _ (stmt@(L _ (TransStmt {})):_) = + pprPanic "expand_do_stmts: TransStmt" $ ppr stmt + -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` + +expand_do_stmts _ (stmt@(L _ (ParStmt {})):_) = + pprPanic "expand_do_stmts: ParStmt" $ ppr stmt + -- handeled by `GHC.Tc.Gen.Match.tcLcStmt` + +expand_do_stmts _ (stmt@(L _ (XStmtLR ApplicativeStmt{})): _) = + pprPanic "expand_do_stmts: Applicative Stmt" $ ppr stmt + -- Handeled by tcSyntaxOp see `GHC.Tc.Gen.Match.tcStmtsAndThen` + + +expand_do_stmts _ [stmt@(L loc (LastStmt _ (L body_loc body) _ ret_expr))] +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (5) below +-- last statement of a list comprehension, needs to explicitly return it +-- See `checkLastStmt` and `Syntax.Expr.StmtLR.LastStmt` + | NoSyntaxExprRn <- ret_expr + -- Last statement is just body if we are not in ListComp context. See Syntax.Expr.LastStmt + = do traceTc "expand_do_stmts last" (ppr ret_expr) + return $ mkExpandedStmtPopAt loc stmt body + + | SyntaxExprRn ret <- ret_expr + -- + -- ------------------------------------------------ + -- return e ~~> return e + -- to make T18324 work + = do traceTc "expand_do_stmts last" (ppr ret_expr) + let expansion = genHsApp ret (L body_loc body) + return $ mkExpandedStmtPopAt loc stmt expansion + +expand_do_stmts do_or_lc (stmt@(L loc (LetStmt _ bs)) : lstmts) = +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (3) below +-- stmts ~~> stmts' +-- ------------------------------------------------ +-- let x = e ; stmts ~~> let x = e in stmts' + do expand_stmts <- expand_do_stmts do_or_lc lstmts + let expansion = genHsLet bs expand_stmts + return $ mkExpandedStmtPopAt loc stmt expansion + +expand_do_stmts do_or_lc (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) + | SyntaxExprRn bind_op <- xbsrn_bindOp xbsrn + , fail_op <- xbsrn_failOp xbsrn +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (2) below +-- the pattern binding pat can fail +-- stmts ~~> stmt' f = \case pat -> stmts'; +-- _ -> fail "Pattern match failure .." +-- ------------------------------------------------------- +-- pat <- e ; stmts ~~> (>>=) e f + = do expand_stmts <- expand_do_stmts do_or_lc lstmts + failable_expr <- mk_failable_expr do_or_lc pat expand_stmts fail_op + let expansion = genHsExpApps bind_op -- (>>=) + [ e + , failable_expr ] + return $ mkExpandedStmtPopAt loc stmt expansion + + | otherwise + = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) + +expand_do_stmts do_or_lc (stmt@(L loc (BodyStmt _ e (SyntaxExprRn then_op) _)) : lstmts) = +-- See Note [BodyStmt] in Language.Haskell.Syntax.Expr +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below +-- stmts ~~> stmts' +-- ---------------------------------------------- +-- e ; stmts ~~> (>>) e stmts' + do expand_stmts_expr <- expand_do_stmts do_or_lc lstmts + let expansion = genHsExpApps then_op -- (>>) + [ e + , expand_stmts_expr ] + return $ mkExpandedStmtPopAt loc stmt expansion + +expand_do_stmts do_or_lc + ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts + , recS_later_ids = later_ids -- forward referenced local ids + , recS_rec_ids = local_ids -- ids referenced outside of the rec block + , recS_bind_fn = SyntaxExprRn bind_fun -- the (>>=) expr + , recS_mfix_fn = SyntaxExprRn mfix_fun -- the `mfix` expr + , recS_ret_fn = SyntaxExprRn return_fun -- the `return` expr + -- use it explicitly + -- at the end of expanded rec block + })) + : lstmts) = +-- See Note [Typing a RecStmt] in Language.Haskell.Syntax.Expr +-- See Note [Expanding HsDo with XXExprGhcRn] Equation (4) and (6) below +-- stmts ~~> stmts' +-- ------------------------------------------------------------------------------------------- +-- rec { later_ids, local_ids, rec_block } ; stmts +-- ~~> (>>=) (mfix (\[ local_only_ids ++ later_ids ] +-- -> do { rec_stmts +-- ; return (local_only_ids ++ later_ids) } )) +-- (\ [ local_only_ids ++ later_ids ] -> stmts') + do expand_stmts <- expand_do_stmts do_or_lc lstmts + -- NB: No need to wrap the expansion with an ExpandedStmt + -- as we want to flatten the rec block statements into its parent do block anyway + return $ mkHsApps (wrapGenSpan bind_fun) -- (>>=) + [ (wrapGenSpan mfix_fun) `mkHsApp` mfix_expr -- (mfix (do block)) + , genHsLamDoExp do_or_lc [ mkBigLHsVarPatTup all_ids ] -- (\ x -> + expand_stmts -- stmts') + ] + where + local_only_ids = local_ids \\ later_ids -- get unique local rec ids; + -- local rec ids and later ids can overlap + all_ids = local_only_ids ++ later_ids -- put local ids before return ids + + return_stmt :: ExprLStmt GhcRn + return_stmt = wrapGenSpan $ LastStmt noExtField + (mkBigLHsTup (map nlHsVar all_ids) noExtField) + Nothing + (SyntaxExprRn return_fun) + do_stmts :: XRec GhcRn [ExprLStmt GhcRn] + do_stmts = L stmts_loc $ rec_stmts ++ [return_stmt] + do_block :: LHsExpr GhcRn + do_block = L loc $ HsDo noExtField do_or_lc do_stmts + mfix_expr :: LHsExpr GhcRn + mfix_expr = genHsLamDoExp do_or_lc [ wrapGenSpan (LazyPat noExtField $ mkBigLHsVarPatTup all_ids) ] + $ do_block + -- NB: LazyPat because we do not want to eagerly evaluate the pattern + -- and potentially loop forever + +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 +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 + ; 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 + then return $ genHsLamDoExp doFlav [pat] expr + else L loc <$> mk_fail_block doFlav pat expr fail_op + } + +-- makes the fail block with a given fail_op +mk_fail_block :: HsDoFlavour -> LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (HsExpr GhcRn) +mk_fail_block doFlav pat@(L ploc _) e (Just (SyntaxExprRn fail_op)) = + do dflags <- getDynFlags + return $ HsLam noAnn LamCases $ mkMatchGroup (doExpansionOrigin doFlav) -- \ + (wrapGenSpan [ genHsCaseAltDoExp doFlav pat e -- pat -> expr + , fail_alt_case dflags pat fail_op -- _ -> fail "fail pattern" + ]) + where + fail_alt_case :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn) + fail_alt_case dflags pat fail_op = genHsCaseAltDoExp doFlav genWildPat $ + L ploc (fail_op_expr dflags pat fail_op) + + fail_op_expr :: DynFlags -> LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn + fail_op_expr dflags pat fail_op + = mkExpandedPatRn pat $ + genHsApp fail_op (mk_fail_msg_expr dflags pat) + + mk_fail_msg_expr :: DynFlags -> LPat GhcRn -> LHsExpr GhcRn + mk_fail_msg_expr dflags pat + = nlHsLit $ mkHsString $ showPpr dflags $ + text "Pattern match failure in" <+> pprHsDoFlavour (DoExpr Nothing) + <+> text "at" <+> ppr (getLocA pat) + + +mk_fail_block _ _ _ _ = pprPanic "mk_fail_block: impossible happened" empty + + +{- Note [Expanding HsDo with XXExprGhcRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand `do`-blocks before typechecking it, by re-using the existing `XXExprGhcRns` and `RebindableSyntax` machinery. +This is very similar to: + 1. Expansions done in `GHC.Rename.Expr.rnHsIf` for expanding `HsIf`; and + 2. `desugarRecordUpd` in `GHC.Tc.Gen.Expr.tcExpr` for expanding `RecordUpd` +See Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr + +To disabmiguate desugaring (`HsExpr GhcTc -> Core.Expr`) we use the phrase expansion +(`HsExpr GhcRn -> HsExpr GhcRn`) + +This expansion is done right before typechecking and after renaming +See Part 2. of Note [Doing XXExprGhcRn in the Renamer vs Typechecker] in `GHC.Rename.Expr` + +Historical note START +--------------------- +In previous versions of GHC, the `do`-notation wasn't expanded before typechecking, +instead the typechecker would operate directly on the original. +Why? because it ensured that type error messages were explained in terms of +what the programmer has written. In practice, however, this didn't work very well: + +* Attempts to typecheck the original source code turned out to be buggy, and virtually impossible + to fix (#14963, #15598, #21206 and others) + +* The typechecker expected the `>>=` operator to have a type that matches + `m _ -> (_ -> m _) -> m _` for some `m`. With `RebindableSyntax` or + `QualifiedDo` the `>>=` operator might not have the + standard type. It might have a type like + + (>>=) :: Wombat m => m a1 a2 b -> (b -> m a2 a3 c) -> m a1 a3 c + + Typechecking the term `(>>=) e1 (\x -> e2)` deals with all of this automatically. + +* With `ImpredicativeTypes` the programmer will expect Quick Look to instantiate + the quantifiers impredicatively (#18324). Again, that happens automatically if + you typecheck the expanded expression. + +Historical note END +------------------- + +Do Expansions Equationally +-------------------------- +We have the following schema for expanding `do`-statements. +They capture the essence of statement expansions as implemented in `expand_do_stmts` + + DO【 _ 】 maps a sequence of do statements and recursively converts them into expressions + + (1) DO【 s; ss 】 = ‹ExpansionStmt s›((>>) s (‹PopErrCtxt›DO【 ss 】)) + + (2) DO【 p <- e; ss 】 = if p is irrefutable + then ‹ExpansionStmt (p <- e)› + (>>=) s (‹PopExprCtxt›(\ p -> DO【 ss 】)) + else ‹ExpansionStmt (p <- e)› + (>>=) s (‹PopExprCtxt›(\case p -> DO【 ss 】 + _ -> fail "pattern p failure")) + + (3) DO【 let x = e; ss 】 + = ‹ExpansionStmt (let x = e)› (let x = e in (‹PopErrCtxt›DO【 ss 】)) + + + (4) DO【 rec ss; sss 】 + = (>>=) e (\vars -> ‹PopErrCtxt›DO【 sss 】)) + where (vars, e) = RECDO【 ss 】 + + (5) DO【 s 】 = s + + RECDO【 _ 】 maps a sequence of recursively dependent monadic statements and converts it into an expression paired + with the variables that the rec finds a fix point of. + + (6) RECDO【 ss 】 = (vars, mfix (\~vars -> (>>=) (DO【 ss 】) (return vars))) + where vars are all the variables free in ss + + +For a concrete example, consider a `do`-block written by the user + + f = {l0} do {l1} {pl}p <- {l1'} e1 + {l2} g p + {l3} return {l3'} p + +The expanded version (performed by `expand_do_stmts`) looks like: + + f = {g1} (>>=) ({l1'} e1) (\ {pl}p -> + {g2} (>>) ({l2} g p) + ({l3} return p)) + +The {l1} etc are location/source span information stored in the AST by the parser, +{g1} are compiler generated source spans. + + +The 3 non-obvious points to consider are: + 1. Wrap the expression with a `fail` block if the pattern match is not irrefutable. + See Part 1. below + 2. Generate appropriate warnings for discarded results in a body statement + eg. say `do { .. ; (g p :: m Int) ; ... }` + See Part 2. below + 3. Generating appropriate type error messages which blame the correct source spans + See Part 3. below + +Part 1. Expanding Patterns Bindings +----------------------------------- +If `p` is a failable pattern---checked by `GHC.Tc.Gen.Pat.isIrrefutableHsPatRnTcM`--- +we need to wrap it with a `fail`-block. See Equation (2) above. + +The expansion of the `do`-block + + do { Just p <- e1; e2 } + +(ignoring the location information) will be + + (>>=) (e1) + (\case -- anonymous continuation lambda + Just p -> e2 + _ -> fail "failable pattern p at location") + +The `fail`-block wrapping is done by `GHC.Tc.Gen.Do.mk_failable_expr`. + +* Note the explicit call to `fail`, in the monad of the `do`-block. Part of the specification + of do-notation is that if the pattern match fails, we fail in the monad, *not* just crash + at runtime. + +* According to the language specification, when the pattern is irrefutable, + we should not add the `fail` alternative. This is important because + the occurrence of `fail` means that the typechecker will generate a `MonadFail` constraint, + and irrefutable patterns shouldn't need a fail alternative. + +* _Wrinkel 1_: Note that pattern synonyms count as refutable during type checking, + (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): + + pattern MyJust :: a -> Maybe a + pattern MyJust x <- Just x where MyJust = Just + + and a `do`-block with the following bind and return statement + + do { MyJust x <- [MyNothing, MyJust ()] + ; return x } + + The `do`-expansion will generate the expansion + + (>>=) ([MyNothing, MyJust ()]) + (\case MyJust x -> return x -- (1) + _ -> fail "failable pattern .. " -- (2) + ) + + This code (specifically the `match` spanning lines (1) and (2)) is a compiler generated code; + the associated `Origin` in tagged `Generated` + The alternative statements will thus be ignored by the pattern match check (c.f. `isMatchContextPmChecked`). + This ensures we do not generate spurious redundant-pattern-match warnings due to the line (2) above. + See Note [Generated code and pattern-match checking] + See Note [Long-distance information in matchWrapper] + +* _Wrinkle 2_: The call to `fail` will give rise to a `MonadFail` constraint. What `CtOrigin` do we + attach to that constraint? When the `MonadFail` constraint can't be solved, it'll show up in error + messages and it needs to be a good location. Ideally, it should identify the + pattern `p`. Hence, we wrap the `fail` alternative expression with a `ExpandedPat` + that tags the fail expression with the failable pattern. (See testcase MonadFailErrors.hs) + +Part 2. Generate warnings for discarded body statement results +-------------------------------------------------------------- +If the `do`-blocks' body statement is an expression that returns a +value that is not of type `()`, we need to warn the user about discarded +the value when `-Wunused-binds` flag is turned on. (See testcase T3263-2.hs) + +For example the `do`-block + + do { e1; e2 } -- where, e1 :: m Int + +expands to + + (>>) e1 e2 + +* If `e1` returns a non-() value we want to emit a warning, telling the user that they + are discarding the value returned by e1. This is done by `HsToCore.dsExpr` in the `HsApp` + with a call to `HsToCore.warnUnusedBindValue`. + +* The decision to trigger the warning is: if the function is a compiler generated `(>>)`, + and its first argument `e1` has a non-() type + +Part 3. Blaming Offending Source Code and Generating Appropriate Error Messages +------------------------------------------------------------------------------- +To ensure we correctly track source of the offending user written source code, +in this case the `do`-statement, we need to keep track of +which source statement's expansion the typechecker is currently typechecking. +For this purpose we use the `XXExprGhcRn.ExpansionRn`. +It stores the original statement (with location) and the expanded expression + + A. Expanding Body Statements + ----------------------------- + For example, the `do`-block + + do { e1; e2; e3 } + + expands (ignoring the location info) to + + ‹ExpandedThingRn do { e1; e2; e3 }› -- Original Do Expression + -- Expanded Do Expression + (‹ExpandedThingRn e1› -- Original Statement + ({(>>) e1} -- Expanded Expression + ‹PopErrCtxt› (‹ExpandedThingRn e2› + ({(>>) e2} + ‹PopErrCtxt› (‹ExpandedThingRn e3› {e3}))))) + + * Whenever the typechecker steps through an `ExpandedThingRn`, + we push the original statement in the error context, set the error location to the + location of the statement, and then typecheck the expanded expression. + This is similar to vanilla `XXExprGhcRn` and rebindable syntax + See Note [Rebindable syntax and XXExprGhcRn] in `GHC.Hs.Expr`. + + * Recall, that when a source function argument fails to typecheck, + we print an error message like "In the second argument of the function f..". + However, `(>>)` is generated thus, we don't want to display that to the user; it would be confusing. + But also, we do not want to completely ignore it as we do want to keep the error blame carets + as precise as possible, and not just blame the complete `do`-block. + Thus, when we typecheck the application `(>>) e1`, we push the "In the stmt of do block e1" with + the source location of `e1` in the error context stack as we walk inside an `ExpandedThingRn`. + See also Note [splitHsApps]. + + * After the expanded expression of a `do`-statement is typechecked + and before moving to the next statement of the `do`-block, we need to first pop the top + of the error context stack which contains the error message for + the previous statement: eg. "In the stmt of a do block: e1". + This is explicitly encoded in the expansion expression using + the `XXExprGhcRn.PopErrCtxt`. Whenever `GHC.Tc.Gen.Expr.tcExpr` (via `GHC.Tc.Gen.tcXExpr`) + sees a `PopErrCtxt` it calls `GHC.Tc.Utils.Monad.popErrCtxt` to pop of the top of error context stack. + See ‹PopErrCtxt› in the example above. + Without this popping business for error context stack, + if there is a type error in `e2`, we would get a spurious and confusing error message + which mentions "In the stmt of a do block e1" along with the message + "In the stmt of a do block e2". + + B. Expanding Bind Statements + ----------------------------- + A `do`-block with a bind statement: + + do { p <- e1; e2 } + + expands (ignoring the location information) to + + ‹ExpandedThingRn do{ p <- e1; e2 }› -- Original Do Expression + -- + (‹ExpandedThingRn (p <- e1)› -- Original Statement + (((>>=) e1) -- Expanded Expression + ‹PopErrCtxt› ((\ p -> ‹ExpandedThingRn (e2)› e2))) + ) + + + However, the expansion lambda `(\p -> e2)` is special as it is generated from a `do`-stmt expansion + and if a type checker error occurs in the pattern `p` (which is source generated), we need to say + "in a pattern binding in a do block" and not "in the pattern of a lambda" (cf. Typeable1.hs). + We hence use a tag `GenReason` in `Ghc.Tc.Origin`. When typechecking a `HsLam` in `Tc.Gen.Expr.tcExpr` + the `match_ctxt` is set to a `StmtCtxt` if `GenOrigin` is a `DoExpansionOrigin`. +-} diff --git a/GHC/Tc/Gen/Export.hs b/GHC/Tc/Gen/Export.hs --- a/GHC/Tc/Gen/Export.hs +++ b/GHC/Tc/Gen/Export.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where @@ -10,6 +12,7 @@ import GHC.Hs import GHC.Builtin.Names +import GHC.Core.Class import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env @@ -20,7 +23,7 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) -import GHC.Utils.Error +import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported import GHC.Unit.Module.Warnings @@ -41,6 +44,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set +import GHC.Types.DefaultEnv import GHC.Types.Avail import GHC.Types.SourceFile import GHC.Types.Id @@ -52,6 +56,8 @@ import qualified Data.List.NonEmpty as NE import Data.Traversable ( for ) import Data.List ( sortBy ) +import qualified Data.Map as Map +import GHC.Types.Unique.FM {- ************************************************************************ @@ -140,6 +146,8 @@ = ExportAccum { expacc_exp_occs :: ExportOccMap, -- ^ Tracks exported occurrence names + expacc_exp_dflts :: NameEnv (ClassDefaults, IE GhcPs), + -- ^ Tracks exported named default declarations expacc_mods :: UniqMap ModuleName [Name], -- ^ Tracks (re-)exported module names -- and the names they re-export @@ -152,15 +160,16 @@ emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum emptyOccEnv emptyUniqMap [] emptyNameEnv +emptyExportAccum = ExportAccum emptyOccEnv emptyNameEnv emptyUniqMap [] emptyNameEnv accumExports :: (ExportAccum -> x -> TcRn (ExportAccum, Maybe y)) -> [x] - -> TcRn ([y], ExportWarnSpanNames, DontWarnExportNames) + -> TcRn ([y], DefaultEnv, ExportWarnSpanNames, DontWarnExportNames) accumExports f xs = do - (ExportAccum _ _ export_warn_spans dont_warn_export, ys) + (ExportAccum _ dflts _ export_warn_spans dont_warn_export, ys) <- mapAccumLM f' emptyExportAccum xs return ( catMaybes ys + , fmap fst dflts , export_warn_spans , dont_warn_export ) where f' acc x @@ -173,7 +182,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 @@ -206,14 +215,14 @@ | explicit_mod = exports | has_main = Just (noLocA [noLocA (IEVar Nothing - (noLocA (IEName noExtField $ noLocA default_main)))]) + (noLocA (IEName noExtField $ noLocA default_main)) Nothing)]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope | otherwise = Nothing -- Rename the export list ; let do_it = exports_from_avail real_exports rdr_env imports this_mod - ; (rn_exports, final_avails, new_export_warns) + ; (rn_exports, default_env, final_avails, new_export_warns) <- if hsc_src == HsigFile then do (mb_r, msgs) <- tryTc do_it case mb_r of @@ -230,6 +239,9 @@ , tcg_rn_exports = case tcg_rn_exports tcg_env of Nothing -> Nothing Just _ -> rn_exports + , tcg_default_exports = case exports of + Nothing -> emptyDefaultEnv + _ -> default_env , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly final_ns , tcg_warns = insertWarnExports @@ -243,7 +255,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_provenance` field of `ClassDefaults` tracks the module whence the default was +imported from, for the purpose of warning reports. The said warning report may be +triggered by `-Wtype-defaults` or by a user-defined `WARNING` pragma attached to +the default export. In the latter case the warning text is stored in the +`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 +299,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, Avails)], DefaultEnv, Avails, ExportWarnNames GhcRn) -- (Nothing, _, _) <=> no explicit export list -- if explicit export list is present it contains -- each renamed export item together with its exported @@ -265,9 +313,9 @@ ; addDiagnostic (TcRnMissingExportList $ moduleName _this_mod) ; let avails = - map fix_faminst . gresToAvailInfo + map fix_faminst . gresToAvailInfo . mapMaybe pickLevelZeroGRE . filter isLocalGRE . globalRdrEnvElts $ rdr_env - ; return (Nothing, avails, []) } + ; return (Nothing, emptyDefaultEnv, avails, []) } where -- #11164: when we define a data instance -- but not data family, re-export the family @@ -283,11 +331,11 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do (ie_avails, export_warn_spans, dont_warn_export) + = do (ie_avails, ie_dflts, export_warn_spans, dont_warn_export) <- accumExports do_litem rdr_items let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export - return (Just ie_avails, final_exports, export_warn_names) + return (Just ie_avails, ie_dflts, final_exports, export_warn_names) where do_litem :: ExportAccum -> LIE GhcPs -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails)) @@ -307,13 +355,14 @@ = [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)) exports_from_item expacc@ExportAccum{ expacc_exp_occs = occs, + expacc_exp_dflts = exp_dflts, expacc_mods = earlier_mods, expacc_warn_spans = export_warn_spans, expacc_dont_warn = dont_warn_export @@ -336,6 +385,7 @@ = do { let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) + -- NB: this filters out non level 0 exports ; new_gres = [ gre' | (gre, _) <- gre_prs , gre' <- expand_tyty_gre gre ] @@ -369,6 +419,7 @@ (vcat [ ppr mod , ppr new_exports ]) ; return ( ExportAccum { expacc_exp_occs = occs' + , expacc_exp_dflts = exp_dflts -- IEModuleContents does not re-export defaults , expacc_mods = mods , expacc_warn_spans = export_warn_spans' , expacc_dont_warn = dont_warn_export' } @@ -377,26 +428,32 @@ 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, [])) 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, mb_item) -> + case mb_item of + Nothing -> + return (acc', Nothing) + Just avail -> + return (acc', Just (new_ie, [avail])) ------------- - lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, AvailInfo)) + lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, Maybe AvailInfo)) lookup_ie expacc@ExportAccum{ expacc_exp_occs = occs, expacc_warn_spans = export_warn_spans, expacc_dont_warn = dont_warn_export - } (L loc ie@(IEVar warn_txt_ps l)) - = do mb_gre <- lookupGreAvailRn $ lieWrappedName l + } (L loc ie@(IEVar warn_txt_ps l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l for mb_gre $ \ gre -> do let avail = availFromGRE gre name = greName gre + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie [gre] (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -405,23 +462,47 @@ warn_txt_ps (locA loc) + doc' <- traverse rnLHsDoc doc return ( expacc{ expacc_exp_occs = occs' , expacc_warn_spans = export_warn_spans' , expacc_dont_warn = dont_warn_export' } - , L loc (IEVar warn_txt_rn (replaceLWrappedName l name)) - , avail ) + , L loc (IEVar warn_txt_rn (replaceLWrappedName l name) doc') + , Just avail ) lookup_ie expacc@ExportAccum{ expacc_exp_occs = occs, + expacc_exp_dflts = exp_dflts, expacc_warn_spans = export_warn_spans, expacc_dont_warn = dont_warn_export - } (L loc ie@(IEThingAbs (warn_txt_ps, ann) l)) - = do mb_gre <- lookupGreAvailRn $ lieWrappedName l + } (L loc ie@(IEThingAbs warn_txt_ps l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l for mb_gre $ \ gre -> do let avail = availFromGRE gre name = greName gre - occs' <- check_occs occs ie [gre] + (mb_avail, occs', exp_dflts') <- + case unLoc l of + -- see Note [Default exports] + IEDefault {} -> do + defaults <- tcg_default <$> getGblEnv + case lookupUFM_Directly defaults (nameUnique name) of + Nothing -> + do addErr $ TcRnExportHiddenDefault ie + return (Nothing, occs, exp_dflts) + Just cls_dflts -> do + let cls = cd_class cls_dflts + case lookupNameEnv exp_dflts (className cls) of + Just (_, ie') -> do + addDiagnostic $ + TcRnDuplicateNamedDefaultExport (classTyCon cls) ie ie' + return (Nothing, occs, exp_dflts) + Nothing -> + return $ (Nothing, occs, extendNameEnv exp_dflts (className cls) (cls_dflts, ie)) + _ -> do + occs' <- check_occs occs ie [gre] + return (Just avail, occs', exp_dflts) + + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans dont_warn_export @@ -429,24 +510,27 @@ warn_txt_ps (locA loc) + doc' <- traverse rnLHsDoc doc return ( expacc{ expacc_exp_occs = occs' + , expacc_exp_dflts = exp_dflts' , expacc_warn_spans = export_warn_spans' , expacc_dont_warn = dont_warn_export' } - , L loc (IEThingAbs (warn_txt_rn, ann) (replaceLWrappedName l name)) - , avail ) + , L loc (IEThingAbs warn_txt_rn (replaceLWrappedName l name) doc') + , mb_avail ) lookup_ie expacc@ExportAccum{ expacc_exp_occs = occs, expacc_warn_spans = export_warn_spans, expacc_dont_warn = dont_warn_export - } (L loc ie@(IEThingAll (warn_txt_ps, ann) l)) - = do mb_gre <- lookupGreAvailRn $ lieWrappedName l + } (L loc ie@(IEThingAll (warn_txt_ps, ann) l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l for mb_gre $ \ par -> do all_kids <- lookup_ie_kids_all ie l par let name = greName par all_gres = par : all_kids all_names = map greName all_gres + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -455,22 +539,23 @@ warn_txt_ps (locA loc) + doc' <- traverse rnLHsDoc doc return ( expacc{ expacc_exp_occs = occs' , expacc_warn_spans = export_warn_spans' , expacc_dont_warn = dont_warn_export' } - , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name)) - , AvailTC name all_names ) + , L loc (IEThingAll (warn_txt_rn, ann) (replaceLWrappedName l name) doc') + , Just $ AvailTC name all_names ) lookup_ie expacc@ExportAccum{ expacc_exp_occs = occs, expacc_warn_spans = export_warn_spans, expacc_dont_warn = dont_warn_export - } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs)) - = do mb_gre <- addExportErrCtxt ie - $ lookupGreAvailRn $ lieWrappedName l + } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs doc)) + = do mb_gre <- addErrCtxt (ExportCtxt ie) + $ lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l for mb_gre $ \ par -> do (subs, with_kids) - <- addExportErrCtxt ie + <- addErrCtxt (ExportCtxt ie) $ lookup_ie_kids_with par sub_rdrs wc_kids <- @@ -483,6 +568,7 @@ all_gres = par : all_kids all_names = map greName all_gres + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) occs' <- check_occs occs ie all_gres (export_warn_spans', dont_warn_export', warn_txt_rn) <- process_warning export_warn_spans @@ -491,11 +577,12 @@ warn_txt_ps (locA loc) + doc' <- traverse rnLHsDoc doc return ( expacc{ expacc_exp_occs = occs' , expacc_warn_spans = export_warn_spans' , expacc_dont_warn = dont_warn_export' } - , L loc (IEThingWith (warn_txt_rn, ann) (replaceLWrappedName l name) wc subs) - , AvailTC name all_names ) + , L loc (IEThingWith (warn_txt_rn, ann) (replaceLWrappedName l name) wc subs doc') + , Just $ AvailTC name all_names ) lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier @@ -503,29 +590,27 @@ lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs] -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt]) lookup_ie_kids_with gre sub_rdrs = - do { let name = greName gre - ; kids <- lookupChildrenExport name sub_rdrs + do { kids <- lookupChildrenExport gre sub_rdrs ; return (map fst kids, map snd kids) } lookup_ie_kids_all :: IE GhcPs -> LIEWrappedName GhcPs -> GlobalRdrElt -> RnM [GlobalRdrElt] - lookup_ie_kids_all ie (L _ rdr) gre = + lookup_ie_kids_all ie (L _loc rdr) gre = do { let name = greName gre gres = findChildren kids_env name - ; addUsedKids (ieWrappedName rdr) gres - ; when (null gres) $ + -- We only choose level 0 exports when filling in part of an export list implicitly. + ; let kids_0 = mapMaybe pickLevelZeroGRE gres + ; addUsedKids (ieWrappedName rdr) kids_0 + ; when (null kids_0) $ if isTyConName name then addTcRnDiagnostic (TcRnDodgyExports gre) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (TcRnExportHiddenComponents ie) - ; return gres } + ; return kids_0 } ------------- - rn_warning_txt_loc :: LocatedP (WarningTxt GhcPs) -> RnM (LocatedP (WarningTxt GhcRn)) - rn_warning_txt_loc (L loc warn_txt) = L loc <$> rnWarningTxt warn_txt - -- Runs for every Name -- - If there is no new warning, flags that the old warning should not be -- included (since a warning should only be emitted if all @@ -534,12 +619,12 @@ process_warning :: ExportWarnSpanNames -- Old aggregate data about warnins -> DontWarnExportNames -- Old names not to warn about -> [Name] -- Names to warn about - -> Maybe (LocatedP (WarningTxt GhcPs)) -- Warning + -> Maybe (LWarningTxt GhcPs) -- Warning -> SrcSpan -- Span of the export list item -> RnM (ExportWarnSpanNames, -- Aggregate data about the warnings DontWarnExportNames, -- Names not to warn about in the end -- (when there was a non-warned export) - Maybe (LocatedP (WarningTxt GhcRn))) -- Renamed warning + Maybe (LWarningTxt GhcRn)) -- Renamed warning process_warning export_warn_spans dont_warn_export names Nothing loc @@ -560,7 +645,7 @@ dont_warn_export names (Just warn_txt_ps) loc = do - warn_txt_rn <- rn_warning_txt_loc warn_txt_ps + warn_txt_rn <- rnLWarningTxt warn_txt_ps let new_export_warn_spans = map (, unLoc warn_txt_rn, loc) names return ( new_export_warn_spans ++ export_warn_spans , dont_warn_export @@ -619,6 +704,23 @@ addUsedKids parent_rdr kid_gres = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) + +ieLWrappedUserRdrName :: LIEWrappedName GhcPs -> Name -> LIdOccP GhcRn +ieLWrappedUserRdrName l n = fmap (\rdr -> WithUserRdr rdr n) $ ieLWrappedName l + +-- | In what namespaces should we go looking for an import/export item +-- that is out of scope, for suggestions in error messages? +ieWrappedNameWhatLooking :: IEWrappedName GhcPs -> WhatLooking +ieWrappedNameWhatLooking = \case + IEName {} -> WL_TyCon_or_TermVar + IEDefault {} -> WL_TyCon + IEType {} -> WL_Type + IEData {} -> WL_Term + IEPattern {} -> WL_ConLike + +ieLWrappedNameWhatLooking :: LIEWrappedName GhcPs -> WhatLooking +ieLWrappedNameWhatLooking = ieWrappedNameWhatLooking . unLoc + -- Renaming and typechecking of exports happens after everything else has -- been typechecked. @@ -629,14 +731,14 @@ >> An abbreviated form of module, consisting only of the module body, is >> permitted. If this is used, the header is assumed to be ->> ‘module Main(main) where’. +>> 'module Main(main) where'. For modules without a module header, this is implemented the following way: If the module has a main function in scope: Then create a module header and export the main function, - as if a module header like ‘module Main(main) where...’ would exist. + as if a module header like 'module Main(main) where...' would exist. This has the effect to mark the main function and all top level functions called directly or indirectly via main as 'used', and later on, unused top-level functions can be reported correctly. @@ -650,7 +752,7 @@ In GHCi this has the effect, that we don't get any 'non-used' warnings. In GHC, however, the 'has-main-module' check in GHC.Tc.Module.checkMain fires, and we get the error: - The IO action ‘main’ is not defined in module ‘Main’ + The IO action 'main' is not defined in module 'Main' -} @@ -679,27 +781,21 @@ -lookupChildrenExport :: Name -> [LIEWrappedName GhcPs] +lookupChildrenExport :: GlobalRdrElt + -> [LIEWrappedName GhcPs] -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) -lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items +lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items where + spec_parent = greName parent_gre -- Process an individual child doOne :: LIEWrappedName GhcPs -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) doOne n = do let bareName = (ieWrappedName . unLoc) n - what_lkup :: LookupChild - what_lkup = - LookupChild - { wantedParent = spec_parent - , lookupDataConFirst = True - , prioritiseParent = False -- See T11970. - } - -- Do not report export list declaration deprecations name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings - spec_parent bareName what_lkup + (ParentGRE spec_parent (greInfo parent_gre)) bareName traceRn "lookupChildrenExport" (ppr name) -- Default to data constructors for slightly better error -- messages @@ -710,15 +806,16 @@ case name of NameNotFound -> - do { ub <- reportUnboundName unboundName + do { ub <- reportUnboundName (lookingForSubordinate parent_gre) unboundName ; let l = getLoc n gre = mkLocalGRE UnboundGRE NoParent ub - ; return (L l (IEName noExtField (L (la2na l) ub)), gre)} + ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> do { checkPatSynParent spec_parent par child_nm + ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) ; return (replaceLWrappedName n child_nm, child) } - IncorrectParent p c gs -> failWithDcErr p (greName c) gs + IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs -- Note [Typing Pattern Synonym Exports] @@ -801,16 +898,13 @@ ; case mpat_syn_thing of AnId i | isId i , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr nm) parent_ty_con p + -> handle_pat_syn (PatSynRecSelExportCtxt p nm) parent_ty_con p - AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p + AConLike (PatSynCon p) -> handle_pat_syn (PatSynExportCtxt p) parent_ty_con p _ -> failWithDcErr parent nm [] } where - psErr = exportErrCtxt "pattern synonym" - selErr = exportErrCtxt "pattern synonym record selector" - - handle_pat_syn :: SDoc + handle_pat_syn :: ErrCtxtMsg -> TyCon -- Parent TyCon -> PatSyn -- Corresponding bundled PatSyn -- and pretty printed origin @@ -906,7 +1000,7 @@ || (explicit_in ie1 && explicit_in ie2) ) where explicit_in (IEModuleContents {}) = False -- module M - explicit_in (IEThingAll _ r) + explicit_in (IEThingAll _ r _) = occName child == rdrNameOcc (ieWrappedName $ unLoc r) -- T(..) explicit_in _ = True @@ -914,18 +1008,6 @@ single IEThingAbs {} = True single _ = False -exportErrCtxt :: Outputable o => String -> o -> SDoc -exportErrCtxt herald exp = - text "In the" <+> text (herald ++ ":") <+> ppr exp - - -addExportErrCtxt :: (OutputableBndrId p) - => IE (GhcPass p) -> TcM a -> TcM a -addExportErrCtxt ie = addErrCtxt exportCtxt - where - exportCtxt = text "In the export:" <+> ppr ie - - failWithDcErr :: Name -> Name -> [Name] -> TcM a failWithDcErr parent child parents = do ty_thing <- tcLookupGlobal child @@ -957,7 +1039,7 @@ -> RnM () addDuplicateFieldExportErr gre others = do { rdr_env <- getGlobalRdrEnv - ; let lkup = expectJust "addDuplicateFieldExportErr" . lookupGRE_Name rdr_env + ; let lkup = expectJust . lookupGRE_Name rdr_env other_gres = fmap (first lkup) others ; addErr (TcRnDuplicateFieldExport gre other_gres) } diff --git a/GHC/Tc/Gen/Expr.hs b/GHC/Tc/Gen/Expr.hs --- a/GHC/Tc/Gen/Expr.hs +++ b/GHC/Tc/Gen/Expr.hs @@ -19,8 +19,8 @@ ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, - tcInferRho, tcInferRhoNC, - tcPolyExpr, tcExpr, + tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC, + tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, ) where @@ -30,65 +30,70 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import {-# SOURCE #-} GHC.Tc.Gen.Splice - ( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) + ( tcTypedSplice, tcTypedBracket, tcUntypedBracket, getUntypedSpliceBody ) import GHC.Hs import GHC.Hs.Syn.Type + import GHC.Rename.Utils -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Unify -import GHC.Types.Basic -import GHC.Types.Error -import GHC.Types.FieldLabel -import GHC.Types.Unique.FM -import GHC.Types.Unique.Map -import GHC.Types.Unique.Set -import GHC.Core.Multiplicity -import GHC.Core.UsageEnv -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep ) -import GHC.Tc.Utils.Instantiate +import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls ) + import GHC.Tc.Gen.App import GHC.Tc.Gen.Head import GHC.Tc.Gen.Bind ( tcLocalBinds ) -import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Rename.Expr ( mkExpandedExpr ) -import GHC.Rename.Env ( addUsedGRE, getUpdFieldLbls, DeprecationWarnings(..) ) -import GHC.Tc.Utils.Env -import GHC.Tc.Gen.Arrow -import GHC.Tc.Gen.Match import GHC.Tc.Gen.HsType -import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.Arrow +import GHC.Tc.Gen.Match( tcBody, tcLambdaMatches, tcCaseMatches + , tcGRHSNE, tcDoStmts ) +import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) import GHC.Tc.Zonk.TcType -import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType as TcType -import GHC.Types.Id -import GHC.Types.Id.Info +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep ) +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types hiding (HoleError) + +import GHC.Core.Multiplicity +import GHC.Core.UsageEnv +import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core.ConLike import GHC.Core.DataCon +import GHC.Core.Class(classTyCon) +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Predicate( decomposeIPPred ) + +import GHC.Types.Basic +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Set +import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Reader -import GHC.Core.Class(classTyCon) -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion( mkSymCo ) -import GHC.Tc.Types.Evidence +import GHC.Types.SrcLoc + import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkBuiltinUnique ) + import GHC.Driver.DynFlags -import GHC.Types.SrcLoc + import GHC.Utils.Misc -import GHC.Data.Bag ( unitBag ) -import GHC.Data.List.SetOps -import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain +import GHC.Data.List.SetOps +import GHC.Data.Maybe + import Control.Monad import qualified Data.List.NonEmpty as NE @@ -100,7 +105,6 @@ ************************************************************************ -} - tcCheckPolyExpr, tcCheckPolyExprNC :: LHsExpr GhcRn -- Expression to type check -> TcSigmaType -- Expected type (could be a polytype) @@ -114,12 +118,13 @@ tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty) tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) +----------------- -- These versions take an ExpType tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) tcPolyLExpr (L loc expr) res_ty - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad addExprCtxt expr $ -- Note [Error contexts in generated code] do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } @@ -129,6 +134,125 @@ do { expr' <- tcPolyExpr expr res_ty ; return (L loc expr') } +----------------- +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr e (Infer inf) = tcExpr e (Infer inf) +tcPolyExpr e (Check ty) = tcPolyExprCheck e (Left ty) + +----------------- +tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) +tcPolyLExprSig (L loc expr) sig + = setSrcSpanA loc $ + -- No addExprCtxt. For (e :: ty) we don't want generate + -- In the expression e + -- In the expression e :: ty + -- We have already got an error-context for (e::ty), so when we + -- get to `e`, just add the location + do { traceTc "tcPolyLExprSig" (ppr loc $$ ppr expr) + ; expr' <- tcPolyExprCheck expr (Right sig) + ; return (L loc expr') } + +----------------- +tcPolyExprCheck :: HsExpr GhcRn + -> Either TcSigmaType TcCompleteSig + -> TcM (HsExpr GhcTc) +-- tcPolyExpCheck deals with the special case for HsLam, in case the pushed-down +-- type is a forall-type. E.g. (\@a -> blah) :: forall b. b -> Int +-- +-- The (Either TcSigmaType TcCompleteSig) deals with: +-- Left ty: (f e) pushes f's argument type `ty` into `e` +-- Right sig: (e :: sig) pushes `sig` into `e` +-- The Either stuff is entirely local to this function and its immediate callers. +-- +-- See Note [Skolemisation overview] in GHC.Tc.Utils.Unify + +tcPolyExprCheck expr res_ty + = outer_skolemise res_ty $ \pat_tys rho_ty -> + let + -- tc_body is a little loop that looks past parentheses + tc_body (HsPar x (L loc e)) + = setSrcSpanA loc $ + do { e' <- tc_body e + ; return (HsPar x (L loc e')) } + + -- Look through any untyped splices (#24559) + -- c.f. Note [Looking through Template Haskell splices in splitHsApps] + tc_body (HsUntypedSplice splice_res _) + = do { body <- getUntypedSpliceBody splice_res + ; tc_body body } + + -- The special case for lambda: go to tcLambdaMatches, passing pat_tys + tc_body e@(HsLam x lam_variant matches) + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches pat_tys + (mkCheckExpType rho_ty) + -- NB: tcLambdaMatches concludes with deep skolemisation, + -- if DeepSubsumption is on; hence no need to do that here + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + + -- The general case: just do deep skolemisation if necessary, + -- before handing off to tcExpr + tc_body e = do { ds_flag <- getDeepSubsumptionFlag + ; inner_skolemise ds_flag rho_ty $ \rho_ty' -> + tcExpr e (mkCheckExpType rho_ty') } + in tc_body expr + where + -- `outer_skolemise` is used always + -- It only does shallow skolemisation + -- It always makes an implication constraint if deferred-errors is on + outer_skolemise :: Either TcSigmaType TcCompleteSig + -> ([ExpPatType] -> TcRhoType -> TcM (HsExpr GhcTc)) + -> TcM (HsExpr GhcTc) + outer_skolemise (Left ty) thing_inside + = do { (wrap, expr') <- tcSkolemiseExpectedType ty thing_inside + ; return (mkHsWrap wrap expr') } + outer_skolemise (Right sig) thing_inside + = do { (wrap, expr') <- tcSkolemiseCompleteSig sig thing_inside + ; return (mkHsWrap wrap expr') } + + -- inner_skolemise is used when we do not have a lambda + -- With deep skolemisation we must remember to deeply skolemise + -- after the (always-shallow) tcSkolemiseCompleteSig + inner_skolemise :: DeepSubsumptionFlag -> TcRhoType + -> (TcRhoType -> TcM (HsExpr GhcTc)) -> TcM (HsExpr GhcTc) + inner_skolemise Shallow rho_ty thing_inside + = -- We have already done shallow skolemisation, so nothing further to do + thing_inside rho_ty + inner_skolemise Deep rho_ty thing_inside + = -- Try deep skolemisation + do { (wrap, expr') <- tcSkolemise Deep ctxt rho_ty thing_inside + ; return (mkHsWrap wrap expr') } + + ctxt = case res_ty of + Left {} -> GenSigCtxt + Right sig -> sig_ctxt sig + + +{- ********************************************************************* +* * + tcExpr: the main expression typechecker +* * +********************************************************************* -} + +tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType) +tcInferSigma = tcInferExpr IIF_Sigma + +tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +-- Infer a *rho*-type. The return type is always instantiated. +tcInferRho = tcInferExpr IIF_DeepRho +tcInferRhoNC = tcInferExprNC IIF_DeepRho + +tcInferExpr, tcInferExprNC :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) +tcInferExpr iif (L loc expr) + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) + ; return (L loc expr', rho) } + +tcInferExprNC iif (L loc expr) + = setSrcSpanA loc $ + do { (expr', rho) <- runInfer iif IFRR_Any (tcExpr expr) + ; return (L loc expr', rho) } + --------------- tcCheckMonoExpr, tcCheckMonoExprNC :: LHsExpr GhcRn -- Expression to type check @@ -138,6 +262,7 @@ tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty) tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty) +--------------- tcMonoExpr, tcMonoExprNC :: LHsExpr GhcRn -- Expression to type check -> ExpRhoType -- Expected type @@ -156,47 +281,23 @@ ; return (L loc expr') } --------------- -tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) --- Infer a *rho*-type. The return type is always instantiated. -tcInferRho (L loc expr) - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] - do { (expr', rho) <- tcInfer (tcExpr expr) - ; return (L loc expr', rho) } - -tcInferRhoNC (L loc expr) - = setSrcSpanA loc $ - do { (expr', rho) <- tcInfer (tcExpr expr) - ; return (L loc expr', rho) } - - -{- ********************************************************************* -* * - tcExpr: the main expression typechecker -* * -********************************************************************* -} - -tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) -tcPolyExpr expr res_ty - = do { traceTc "tcPolyExpr" (ppr res_ty) - ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ mkHsWrap wrap 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: --- - HsVar lone variables, to ensure that they can get an +-- - HsVar lone variables, to ensure that they can get an -- impredicative instantiation (via Quick Look -- driven by res_ty (in checking mode)). --- - HsApp value applications --- - HsAppType type applications --- - ExprWithTySig (e :: type) --- - HsRecSel overloaded record fields --- - HsExpanded renamer expansions --- - HsOpApp operator applications --- - HsOverLit overloaded literals +-- - HsApp value applications +-- - HsAppType type applications +-- - ExprWithTySig (e :: type) +-- - HsRecSel overloaded record fields +-- - ExpandedThingRn renamer/pre-typechecker expansions +-- - HsOpApp operator applications +-- - HsOverLit overloaded literals -- These constructors are the union of -- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps -- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe @@ -206,34 +307,30 @@ 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 e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty -tcExpr e@(HsOverLit _ lit) res_ty - = do { mb_res <- tcShortCutLit lit res_ty - -- See Note [Short cut for overloaded literals] in GHC.Tc.Zonk.Type - ; case mb_res of - Just lit' -> return (HsOverLit noAnn lit') - Nothing -> tcApp e res_ty } +tcExpr (XExpr e) res_ty = tcXExpr e res_ty -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site -tcExpr (HsUnboundVar _ occ) res_ty +-- Others might simply be variables that accidentally have no binding site. +tcExpr (HsHole (HoleVar locc@(L _ occ))) res_ty = do { ty <- expTypeToType res_ty -- Allow Int# etc (#12531) ; her <- emitNewExprHole occ ty ; tcEmitBindingUsage bottomUE -- Holes fit any usage environment -- (#18491) - ; return (HsUnboundVar her occ) } + ; return (HsHole (HoleVar locc, her)) + } +tcExpr (HsHole HoleError) _ = + panic "GHC.Tc.Gen.Expr: tcExpr: HoleError: Not implemented" tcExpr e@(HsLit x lit) res_ty = do { let lit_ty = hsLitType lit ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty } -tcExpr (HsPar x lpar expr rpar) res_ty +tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x lpar expr' rpar) } + ; return (HsPar x expr') } tcExpr (HsPragE x prag expr) res_ty = do { expr' <- tcMonoExpr expr res_ty @@ -251,34 +348,65 @@ -- Create a unification type variable of kind 'Type'. -- (The type of an implicit parameter must have kind 'Type'.) ; let ip_name = mkStrLitTy (hsIPNameFS x) - ; ipClass <- tcLookupClass ipClassName - ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) + origin = IPOccOrigin x + ; ip_class <- tcLookupClass ipClassName + ; let ip_pred = mkClassPred ip_class [ip_name, ip_ty] + ; ip_dict <- emitWantedEvVar origin ip_pred + ; let (ip_op, _) = decomposeIPPred ip_pred + wrap = mkWpEvVarApps [ip_dict] <.> mkWpTyApps [ip_name, ip_ty] ; tcWrapResult e - (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var))) - ip_ty res_ty } - where - -- Coerces a dictionary for `IP "x" t` into `t`. - fromDict ipClass x ty = mkHsWrap $ mkWpCastR $ - unwrapIP $ mkClassPred ipClass [x,ty] - origin = IPOccOrigin x + (mkHsWrap wrap (mkHsVar (noLocA ip_op))) + ip_ty res_ty } -tcExpr (HsLam _ match) res_ty - = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty - ; return (mkHsWrap wrap (HsLam noExtField match')) } - where - match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody } - herald = ExpectedFunTyLam match +tcExpr e@(HsLam x lam_variant matches) res_ty + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } -tcExpr e@(HsLamCase x lc_variant matches) res_ty - = do { (wrap, matches') - <- tcMatchLambda herald match_ctxt matches res_ty - ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') } - where - match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody } - herald = ExpectedFunTyLamCase lc_variant e +{- +************************************************************************ +* * + Overloaded literals +* * +************************************************************************ +-} +tcExpr e@(HsOverLit _ lit) res_ty + = -- See Note [Typechecking overloaded literals] + do { mb_res <- tcShortCutLit lit res_ty + -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType + ; case mb_res of + Just lit' -> return (HsOverLit noExtField lit') + Nothing -> tcApp e res_ty } + -- Why go via tcApp? See Note [Typechecking overloaded literals] +{- Note [Typechecking overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, an overloaded literal like "3" typechecks as if you +had written (fromInteger (3 :: Integer)). But in practice it's a little +tricky: +* Rebindable syntax (see #19154 and !4981). With rebindable syntax we might have + fromInteger :: Integer -> forall a. Num a => a + and then we might hope to use a Visible Type Application (VTA) to write + 3 @Int + expecting it to expand to + fromInteger (3::Integer) @Int dNumInt + To achieve that, we need to + * treat the application using `tcApp` to deal with the VTA + * treat the overloaded literal as the "head" of an application; + see `GHC.Tc.Gen.Head.tcInferAppHead`. + +* Short-cutting. If we have + xs :: [Int] + xs = [3,4,5,6... ] + then it's a huge short-cut (in compile time) to just cough up the `Int` literal + for `3`, rather than (fromInteger @Int d), with a wanted constraint `[W] Num Int`. + See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType. + + We can only take this short-cut if rebindable syntax is off; see `tcShortCutLit`. +-} + + {- ************************************************************************ * * @@ -311,19 +439,12 @@ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys Boxed -> arg_tys - ; tup_args1 <- tcTupArgs tup_args arg_tys' + ; tup_args1 <- tcCheckExplicitTuple tup_args arg_tys' ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) } | otherwise - = -- The tup_args are a mixture of Present and Missing (for tuple sections) - do { let arity = length tup_args - - ; arg_tys <- case boxity of - { Boxed -> newFlexiTyVarTys arity liftedTypeKind - ; Unboxed -> replicateM arity newOpenFlexiTyVarTy } - - -- Handle tuple sections where - ; tup_args1 <- tcTupArgs tup_args arg_tys + = -- The tup_args are a mixture of Present and Missing (for tuple sections). + do { (tup_args1, arg_tys) <- tcInferTupArgs boxity tup_args ; let expr' = ExplicitTuple x tup_args1 boxity missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] @@ -351,7 +472,7 @@ -- This should cause an error, even though (17# :: Int#) -- is not representation-polymorphic: we don't know how -- wide the concrete representation of the sum type will be. - ; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty + ; hasFixedRuntimeRep_syntactic (FRRUnboxedSum Nothing) res_ty ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } @@ -363,12 +484,12 @@ ************************************************************************ -} -tcExpr (HsLet x tkLet binds tkIn expr) res_ty +tcExpr (HsLet x binds expr) res_ty = do { (binds', expr') <- tcLocalBinds binds $ tcMonoExpr expr res_ty - ; return (HsLet x tkLet binds' tkIn expr') } + ; return (HsLet x binds' expr') } -tcExpr (HsCase x scrut matches) res_ty +tcExpr (HsCase ctxt scrut matches) res_ty = do { -- We used to typecheck the case alternatives first. -- The case patterns tend to give good type info to use -- when typechecking the scrutinee. For example @@ -381,20 +502,16 @@ mult <- newFlexiTyVarTy multiplicityTy -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma - -- would also be possible (tcMatchesCase accepts sigma-types) + -- would also be possible (tcCaseMatches accepts sigma-types) -- Interesting litmus test: do these two behave the same? -- case id of {..} -- case (\v -> v) of {..} -- This design choice is discussed in #17790 ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut - ; traceTc "HsCase" (ppr scrut_ty) ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty - ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty - ; return (HsCase x scrut' matches') } - where - match_ctxt = MC { mc_what = x, - mc_body = tcBody } + ; matches' <- tcCaseMatches ctxt tcBody (Scaled mult scrut_ty) matches res_ty + ; return (HsCase ctxt scrut' matches') } tcExpr (HsIf x pred b1 b2) res_ty = do { pred' <- tcCheckMonoExpr pred boolTy @@ -428,11 +545,10 @@ -} tcExpr (HsMultiIf _ alts) res_ty - = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $ wrapLocMA (tcGRHS match_ctxt res_ty) alt) alts + = do { alts' <- tcGRHSNE IfAlt tcBody alts res_ty + -- See Note [MultiWayIf linearity checking] ; res_ty <- readExpType res_ty - ; tcEmitBindingUsage (supUEs ues) -- See Note [MultiWayIf linearity checking] ; return (HsMultiIf res_ty alts') } - where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } tcExpr (HsDo _ do_or_lc stmts) res_ty = tcDoStmts do_or_lc stmts res_ty @@ -453,10 +569,8 @@ = do { res_ty <- expTypeToType res_ty ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty ; (expr', lie) <- captureConstraints $ - addErrCtxt (hang (text "In the body of a static form:") - 2 (ppr expr) - ) $ - tcCheckPolyExprNC expr expr_ty + addErrCtxt (StaticFormCtxt expr) $ + tcCheckPolyExprNC expr expr_ty -- Check that the free variables of the static form are closed. -- It's OK to use nonDetEltsUniqSet here as the only side effects of @@ -470,7 +584,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. @@ -479,11 +595,16 @@ ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] ; loc <- getSrcSpanM ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName - ; return $ mkHsWrapCo co $ HsApp noComments + ; return $ mkHsWrapCo co $ HsApp noExtField (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) } +tcExpr (HsEmbTy _ _) _ = failWith (TcRnIllegalTypeExpr TypeKeywordSyntax) +tcExpr (HsQual _ _ _) _ = failWith (TcRnIllegalTypeExpr ContextArrowSyntax) +tcExpr (HsForAll _ _ _) _ = failWith (TcRnIllegalTypeExpr ForallTelescopeSyntax) +tcExpr (HsFunArr _ _ _ _) _ = failWith (TcRnIllegalTypeExpr FunctionArrowSyntax) + {- ************************************************************************ * * @@ -492,11 +613,11 @@ ************************************************************************ -} -tcExpr expr@(RecordCon { rcon_con = L loc con_name +tcExpr expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name) , rcon_flds = rbinds }) res_ty - = do { con_like <- tcLookupConLike con_name + = do { con_like <- tcLookupConLike qcon - ; (con_expr, con_sigma) <- tcInferId con_name + ; (con_expr, con_sigma) <- tcInferConLike con_like ; (con_wrap, con_tau) <- topInstantiate orig con_sigma -- a shallow instantiation should really be enough for -- a data constructor. @@ -506,12 +627,7 @@ ; checkTc (conLikeHasBuilder con_like) $ nonBidirectionalErr (conLikeName con_like) - ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds - -- It is currently not possible for a record to have - -- multiplicities. When they do, `tcRecordBinds` will take - -- scaled types instead. Meanwhile, it's safe to take - -- `scaledThing` above, as we know all the multiplicities are - -- Many. + ; rbinds' <- tcRecordBinds con_like arg_tys rbinds ; let rcon_tc = mkHsWrap con_wrap con_expr expr' = RecordCon { rcon_ext = rcon_tc @@ -534,7 +650,7 @@ where orig = OccurrenceOf con_name --- Record updates via dot syntax are replaced by desugared expressions +-- Record updates via dot syntax are replaced by expanded expressions -- in the renamer. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. @@ -546,18 +662,18 @@ }) res_ty = assert (notNull rbnds) $ - do { -- Desugar the record update. See Note [Record Updates]. + do { -- Expand the record update. See Note [Record Updates]. ; (ds_expr, ds_res_ty, err_ctxt) - <- desugarRecordUpd record_expr possible_parents rbnds res_ty + <- expandRecordUpd record_expr possible_parents rbnds res_ty - -- Typecheck the desugared expression. + -- Typecheck the expanded expression. ; expr' <- addErrCtxt err_ctxt $ tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty) -- NB: it's important to use ds_res_ty and not res_ty here. -- Test case: T18802b. ; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty - -- We need to unify the result type of the desugared + -- We need to unify the result type of the expanded -- expression with the expected result type. -- -- See Note [Unifying result types in tcRecordUpd]. @@ -588,7 +704,7 @@ ************************************************************************ -} --- These terms have been replaced by desugaring in the renamer. See +-- These terms have been replaced by their expanded expressions in the renamer. See -- Note [Overview of record dot syntax]. tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented" tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented" @@ -604,15 +720,18 @@ -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty -tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty +tcExpr e@(HsTypedBracket _ext body) res_ty = tcTypedBracket e body res_ty tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty tcExpr (HsUntypedSplice splice _) res_ty - = case splice of - HsUntypedSpliceTop mod_finalizers expr - -> do { addModFinalizersWithLclEnv mod_finalizers - ; tcExpr expr res_ty } - HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice" + -- Since `tcApp` deals with `HsUntypedSplice` (in `splitHsApps`), you might + -- wonder why we don't delegate to `tcApp` as we do for `HsVar`, etc. + -- (See the initial block of equations for `tcExpr`.) But we can't do this + -- for `HsUntypedSplice`; to see why, read Wrinkle (UTS1) in + -- Note [Looking through Template Haskell splices in splitHsApps] in + -- GHC.Tc.Gen.Head. + = do { expr <- getUntypedSpliceBody splice + ; tcExpr expr res_ty } {- ************************************************************************ @@ -630,6 +749,45 @@ {- ************************************************************************ * * + Expansion Expressions (XXExprGhcRn) +* * +************************************************************************ +-} + +tcXExpr :: XXExprGhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) + +tcXExpr (PopErrCtxt (L loc e)) res_ty + = popErrCtxt $ -- See Part 3 of Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` + setSrcSpanA loc $ + tcExpr e res_ty + +tcXExpr xe@(ExpandedThingRn o e') res_ty + | OrigStmt ls@(L loc s@LetStmt{}) <- o + , HsLet x binds e <- e' + = do { (binds', e') <- setSrcSpanA loc $ + addStmtCtxt s $ + tcLocalBinds binds $ + tcMonoExprNC e res_ty -- NB: Do not call tcMonoExpr here as it adds + -- a duplicate error context + ; return $ mkExpandedStmtTc ls (HsLet x binds' e') + } + | OrigStmt ls@(L loc s@LastStmt{}) <- o + = setSrcSpanA loc $ + addStmtCtxt s $ + mkExpandedStmtTc ls <$> tcExpr e' res_ty + -- It is important that we call tcExpr (and not tcApp) here as + -- `e` is the last statement's body expression + -- and not a HsApp of a generated (>>) or (>>=) + -- This improves error messages e.g. tests: DoExpansion1, DoExpansion2, DoExpansion3 + | OrigStmt ls@(L loc _) <- o + = setSrcSpanA loc $ + mkExpandedStmtTc ls <$> tcApp (XExpr xe) res_ty + +tcXExpr xe res_ty = tcApp (XExpr xe) res_ty + +{- +************************************************************************ +* * Arithmetic sequences [a..b] etc * * ************************************************************************ @@ -688,27 +846,57 @@ ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } ---------------- -tcTupArgs :: [HsTupArg GhcRn] - -> [TcSigmaType] - -- ^ Argument types. - -- This function ensures they all have - -- a fixed runtime representation. - -> TcM [HsTupArg GhcTc] -tcTupArgs args tys + +-- | Typecheck an explicit tuple @(a,b,c)@ or @(\#a,b,c\#)@. +-- +-- Does not handle tuple sections. +tcCheckExplicitTuple :: [HsTupArg GhcRn] + -> [TcSigmaType] + -- ^ Argument types. + -- This function ensures they all have + -- a fixed runtime representation. + -> TcM [HsTupArg GhcTc] +tcCheckExplicitTuple args tys = do massert (equalLength args tys) checkTupSize (length args) zipWith3M go [1,2..] args tys where go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc) go i (Missing {}) arg_ty - = do { mult <- newFlexiTyVarTy multiplicityTy - ; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty - ; return (Missing (Scaled mult arg_ty)) } + = pprPanic "tcCheckExplicitTuple: tuple sections not handled here" + (ppr i $$ ppr arg_ty) go i (Present x expr) arg_ty = do { expr' <- tcCheckPolyExpr expr arg_ty - ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty - ; return (Present x expr') } + ; (co, _) <- hasFixedRuntimeRep (FRRUnboxedTuple i) arg_ty + ; return (Present x (mkLHsWrap (mkWpCastN co) expr')) } +-- | Typecheck an explicit tuple or tuple section by performing type inference. +tcInferTupArgs :: Boxity + -> [HsTupArg GhcRn] -- ^ argument types + -> TcM ([HsTupArg GhcTc], [TcSigmaTypeFRR]) +tcInferTupArgs boxity args + = do { checkTupSize (length args) + ; zipWithAndUnzipM tc_infer_tup_arg [1,2..] args } + where + tc_infer_tup_arg :: Int -> HsTupArg GhcRn -> TcM (HsTupArg GhcTc, TcSigmaTypeFRR) + tc_infer_tup_arg i (Missing {}) + = do { mult <- newFlexiTyVarTy multiplicityTy + ; arg_ty <- new_arg_ty i + ; return (Missing (Scaled mult arg_ty), arg_ty) } + tc_infer_tup_arg i (Present x lexpr@(L l expr)) + = do { (expr', arg_ty) <- case boxity of + Unboxed -> runInferRhoFRR (FRRUnboxedTuple i) (tcPolyExpr expr) + Boxed -> do { arg_ty <- newFlexiTyVarTy liftedTypeKind + ; L _ expr' <- tcCheckPolyExpr lexpr arg_ty + ; return (expr', arg_ty) } + ; return (Present x (L l expr'), arg_ty) } + + new_arg_ty :: Int -> TcM TcTypeFRR + new_arg_ty i = + case boxity of + Unboxed -> newOpenFlexiFRRTyVarTy (FRRUnboxedTupleSection i) + Boxed -> newFlexiTyVarTy liftedTypeKind + --------------------------- -- See TcType.SyntaxOpType also for commentary tcSyntaxOp :: CtOrigin @@ -735,7 +923,7 @@ -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] + = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) -- Ugh!! But all this code is scheduled for demolition anyway ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) @@ -768,8 +956,8 @@ -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper)) - <- tcTopSkolemise GenSigCtxt sigma_ty - (\ rho_ty -> go rho_ty syn_ty) + <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty -> + go rho_ty syn_ty ; return (result, skol_wrap <.> ty_wrapper) } where go rho_ty SynAny @@ -791,7 +979,7 @@ , res_wrapper ) -- :: res_ty_out "->" res_ty , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ - \ [arg_ty] res_ty -> + \ [ExpFunPatTy arg_ty] res_ty -> do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) ; res_tc_ty <- expTypeToType res_ty @@ -838,8 +1026,7 @@ -- and a wrapper to be applied to the overall expression tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside = do { (match_wrapper, arg_tys, res_ty) - <- matchActualFunTysRho herald orig Nothing - (length arg_shapes) sigma_ty + <- matchActualFunTys herald orig (length arg_shapes) sigma_ty -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty) ; ((result, res_wrapper), arg_wrappers) <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults -> @@ -883,7 +1070,8 @@ tc_syn_arg _ (SynFun {}) _ = pprPanic "tcSynArgA hits a SynFun" (ppr orig) tc_syn_arg res_ty (SynType the_ty) thing_inside - = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty + = do { wrap <- addSubTypeCtxt res_ty the_ty $ + tcSubType orig GenSigCtxt Nothing res_ty the_ty ; result <- thing_inside [] ; return (result, wrap) } @@ -915,19 +1103,19 @@ {- ********************************************************************* * * - Desugaring record update + Expanding record update * * ********************************************************************* -} {- Note [Record Updates] ~~~~~~~~~~~~~~~~~~~~~~~~ -To typecheck a record update, we desugar it first. Suppose we have +To typecheck a record update, we expand it first. Suppose we have data T p q = T1 { x :: Int, y :: Bool, z :: Char } | T2 { v :: Char } | T3 { x :: Int } | T4 { p :: Float, y :: Bool, x :: Int } | T5 -Then the record update `e { x=e1, y=e2 }` desugars as follows +Then the record update `e { x=e1, y=e2 }` expands as follows e { x=e1, y=e2 } ===> @@ -936,7 +1124,7 @@ T1 _ _ z -> T1 x' y' z T4 p _ _ -> T4 p y' x' T2, T3 and T5 should not occur, so we omit them from the match. -The critical part of desugaring is to identify T and then T1/T4. +The critical part of expansion is to identify T and then T1/T4. Wrinkle [Disambiguating fields] @@ -951,17 +1139,17 @@ https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. -All in all, this means that when typechecking a record update via desugaring, +All in all, this means that when typechecking a record update via expansion, we take the following steps: (0) Perform a first typechecking pass on the record expression (`e` in the example above), to infer the type of the record being updated. (1) Disambiguate the record fields (potentially using the type obtained in (0)). - (2) Desugar the record update as described above, using an HsExpansion. + (2) Expand the record update as described above, using an XXExprGhcRn. (a) Create a let-binding to share the record update right-hand sides. - (b) Desugar the record update to a case expression updating all the + (b) Expand the record update to a case expression updating all the relevant constructors (those that have all of the fields being updated). - (3) Typecheck the desugared code. + (3) Typecheck the expanded code. In (0), we call inferRho to infer the type of the record being updated. This returns the inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc) @@ -984,7 +1172,7 @@ data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } foo r = r { f = \ k -> (k 3, k 'x') } - If we desugar to: + If we expand to: ds_foo r = let f' = \ k -> (k 3, k 'x') @@ -1012,13 +1200,34 @@ Note [Type-directed record disambiguation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC currently supports an additional type-directed disambiguation -mechanism, which is deprecated and scheduled for removal as part of -GHC proposal #366 https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst. +Deprecation notice: + The type-directed disambiguation mechanism for record updates described in + this Note is deprecated, as per GHC proposal #366 (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst). + The removal of type-directed disambiguation for record updates is tracked + in GHC ticket #19461, but progress towards this goal has stalled. -To perform this disambiguation, when there are multiple possible parents for -a record update, the renamer defers to the typechecker. -See GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary + Why? There are several suggested replacement mechanisms, such as: + 1. using module qualification to disambiguate, + 2. using OverloadedRecordUpdate for type-directed disambiguation + (as described in Note [Overview of record dot syntax] in GHC.Hs.Expr). + However, these solutions do not work in all situations: + 1. Module qualification doesn't work for fields defined in the current module, + nor to disambiguate between constructors of different data family instances + of a given parent data family TyCon. + 2. OverloadedRecordUpdate does not allow for type-changing record update, + nor can it deal with fields with existentials or polytypes. + There are also some avenues to improve the renamer's ability to disambiguate: + - GHC ticket #23032 suggests using as-patterns to disambiguate in the renamer. + - GHC proposal https://github.com/ghc-proposals/ghc-proposals/pull/537 + suggests a syntactic form of type-directed disambiguation that could be + carried out in the renamer. + Neither of these have been accepted/implemented at the time of writing (Sept 2025). + This means that removal of type-directed disambiguation is currently stalled. + +GHC tries to disambiguate record updates in the renamer, as described in +Note [Disambiguating record updates] in GHC.Rename.Pat. However, if the renamer +is unable to disambiguate, the renamer will defer to the typechecker: see +GHC.Tc.Gen.Expr.disambiguateRecordBinds, and in particular the auxiliary function identifyParentLabels, which picks a parent for the record update using the following additional mechanisms: @@ -1050,7 +1259,7 @@ Note [Unifying result types in tcRecordUpd] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After desugaring and typechecking a record update in the way described in +After expanding and typechecking a record update in the way described in Note [Record Updates], we must take care to unify the result types. Example: @@ -1061,7 +1270,7 @@ f :: F Int -> D Bool -> D Int f i r = r { fld = i } -This record update desugars to: +This record update expands to: let x :: F alpha -- metavariable x = i @@ -1095,13 +1304,13 @@ -} --- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression +-- | Expands a record update @record_expr { fld1 = e1, fld2 = e2 }@ into a case expression -- that matches on the constructors of the record @r@, as described in -- Note [Record Updates]. -- -- Returns a renamed but not-yet-typechecked expression, together with the --- result type of this desugared record update. -desugarRecordUpd :: LHsExpr GhcRn +-- result type of this expanded record update. +expandRecordUpd :: LHsExpr GhcRn -- ^ @record_expr@: expression to which the record update is applied -> NE.NonEmpty (HsRecUpdParent GhcRn) -- ^ Possible parent 'TyCon'/'PatSyn's for the record update, @@ -1111,19 +1320,19 @@ -> ExpRhoType -- ^ the expected result type of the record update -> TcM ( HsExpr GhcRn - -- desugared record update expression + -- Expanded record update expression , TcType - -- result type of desugared record update - , SDoc + -- result type of expanded record update + , ErrCtxtMsg -- error context to push when typechecking - -- the desugared code + -- the expanded code ) -desugarRecordUpd record_expr possible_parents rbnds res_ty +expandRecordUpd record_expr possible_parents rbnds res_ty = do { -- STEP 0: typecheck the record_expr, the record to be updated. -- -- Until GHC proposal #366 is implemented, we still use the type of -- the record to disambiguate its fields, so we must infer the record - -- type here before we can desugar. See Wrinkle [Disambiguating fields] + -- type here before we can expand. See Wrinkle [Disambiguating fields] -- in Note [Record Updates]. ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below tcScalingUsage ManyTy $ -- see (2) below @@ -1133,7 +1342,7 @@ -- Note that we capture, and then discard, the constraints. -- This `tcInferRho` is used *only* to identify the data type, -- so we can deal with field disambiguation. - -- Then we are going to generate a desugared record update, including `record_expr`, + -- Then we are going to generate a expanded record update, including `record_expr`, -- and typecheck it from scratch. We don't want to generate the constraints twice! -- (2) @@ -1157,13 +1366,15 @@ -- 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_cons@(relevant_con NE.:| _) = + case NE.nonEmpty $ nonDetEltsUniqSet cons of + Just rel_cons -> rel_cons + Nothing -> pprPanic "desugarRecordUpd: no relevant constructors" $ + vcat [ text "record_expr:" <+> ppr record_expr ] - -- STEP 2: desugar the record update. + -- STEP 2: expand the record update. -- -- (a) Create new variables for the fields we are updating, -- so that we can share them across constructors. @@ -1238,7 +1449,7 @@ updEnv = listToUniqMap $ upd_ids make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn) - -- As explained in Note [Record Updates], to desugar + -- As explained in Note [Record Updates], to expand -- -- e { x=e1, y=e2 } -- @@ -1251,7 +1462,7 @@ -- we let-bind x' = e1, y' = e2 and generate the equation: -- -- T1 _ _ z -> T1 x' y' z - make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs + make_pat conLike = mkSimpleMatch RecUpd (noLocA [pat]) rhs where (lhs_con_pats, rhs_con_args) = zipWithAndUnzip mk_con_arg [1..] con_fields @@ -1267,7 +1478,7 @@ , LHsExpr GhcRn ) -- RHS constructor argument mk_con_arg i fld_lbl = - -- The following generates the pattern matches of the desugared `case` expression. + -- The following generates the pattern matches of the expanded `case` expression. -- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]), -- wildcards are used to avoid creating unused variables. case lookupUniqMap updEnv $ flSelector fld_lbl of @@ -1279,21 +1490,21 @@ generatedSrcSpan in (genVarPat fld_nm, genLHsVar fld_nm) - -- STEP 2 (b): desugar to HsCase, as per note [Record Updates] + -- STEP 2 (b): expand to HsCase, as per note [Record Updates] ; let ds_expr :: HsExpr GhcRn - ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) + ds_expr = HsLet noExtField let_binds (L gen case_expr) case_expr :: HsExpr GhcRn case_expr = HsCase RecUpd record_expr - $ mkMatchGroup (Generated DoPmc) (wrapGenSpan matches) + $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches) matches :: [LMatch GhcRn (LHsExpr GhcRn)] - matches = map make_pat relevant_cons + matches = map make_pat (NE.toList relevant_cons) let_binds :: HsLocalBindsLR GhcRn GhcRn let_binds = HsValBinds noAnn $ XValBindsLR $ 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 @@ -1302,35 +1513,16 @@ -- See Wrinkle [Using IdSig] in Note [Record Updates]. gen = noAnnSrcSpan generatedSrcSpan - ; traceTc "desugarRecordUpd" $ + ; traceTc "expandRecordUpd" $ vcat [ text "relevant_con:" <+> ppr relevant_con , text "res_ty:" <+> ppr res_ty , text "ds_res_ty:" <+> ppr ds_res_ty + , text "ds_expr:" <+> ppr ds_expr ] - ; let cons = pprQuotedList relevant_cons - err_lines = - (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :) - $ case relevant_con of - RealDataCon con -> - [ text "with type constructor" <+> quotes (ppr (dataConTyCon con)) - , text "data constructor" <+> plural relevant_cons <+> cons ] - PatSynCon {} -> - [ text "with pattern synonym" <+> plural relevant_cons <+> cons ] - ++ if null ex_tvs - then [] - else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ] - err_ctxt = make_lines_msg err_lines + ; return (ds_expr, ds_res_ty, RecordUpdCtxt relevant_cons upd_fld_names ex_tvs) } - ; return (ds_expr, ds_res_ty, err_ctxt) } --- | Pretty-print a collection of lines, adding commas at the end of each line, --- and adding "and" to the start of the last line. -make_lines_msg :: [SDoc] -> SDoc -make_lines_msg [] = empty -make_lines_msg [last] = ppr last <> dot -make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot -make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls {- ********************************************************************* * * @@ -1428,7 +1620,8 @@ lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons }) = do { let cons' :: NonDetUniqFM ConLike ConLikeName cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons - ; cons <- traverse (tcLookupConLike . conLikeName_Name) cons' + lookup_one con = tcLookupConLike (noUserRdr $ getName con) + ; cons <- traverse lookup_one cons' ; tc <- tcLookupRecSelParent par ; return $ TcRecUpdParent @@ -1441,7 +1634,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. @@ -1453,7 +1646,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 } } @@ -1494,16 +1687,16 @@ tcRecordBinds :: ConLike - -> [TcType] -- Expected type for each field + -> [Scaled TcType] -- Expected type for each field -> HsRecordBinds GhcRn -> TcM (HsRecordBinds GhcTc) -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) +tcRecordBinds con_like arg_tys (HsRecFields x rbinds dd) = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } + ; return (HsRecFields x (catMaybes mb_binds) dd) } where fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys + flds_w_tys = zipEqual fields arg_tys do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) @@ -1519,32 +1712,28 @@ , hfbRHS = rhs' , hfbPun = hfbPun fld}))) } -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" - -tcRecordField :: ConLike -> Assoc Name Type +tcRecordField :: ConLike -> Assoc Name (Scaled Type) -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) 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')) +tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs + | Just (Scaled field_mult field_ty) <- assocMaybe flds_w_tys sel_name + = addErrCtxt (FieldCtxt field_lbl)$ + do { rhs' <- tcScalingUsage field_mult $ tcCheckPolyExprNC rhs field_ty + ; hasFixedRuntimeRep_syntactic (FRRRecordCon rdr (unLoc rhs')) field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) - ManyTy field_ty (locA loc) + field_mult field_ty (locA loc) -- Yuk: the field_id has the *unique* of the selector Id -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS - -- (so the desugarer knows the type of local binder to make) - ; return (Just (L loc (FieldOcc field_id lbl), rhs')) } + -- (so the expansion knows the type of local binder to make) + ; 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 () diff --git a/GHC/Tc/Gen/Expr.hs-boot b/GHC/Tc/Gen/Expr.hs-boot --- a/GHC/Tc/Gen/Expr.hs-boot +++ b/GHC/Tc/Gen/Expr.hs-boot @@ -1,10 +1,11 @@ module GHC.Tc.Gen.Expr where import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) -import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR - , SyntaxOpType +import GHC.Tc.Utils.TcType ( TcType, TcRhoType, TcSigmaType, TcSigmaTypeFRR + , SyntaxOpType, InferInstFlag , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.BasicTypes( TcCompleteSig ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) import GHC.Hs.Extension ( GhcRn, GhcTc ) @@ -23,12 +24,17 @@ -> TcRhoType -> TcM (LHsExpr GhcTc) +tcPolyLExpr :: LHsExpr GhcRn -> ExpSigmaType -> TcM (LHsExpr GhcTc) +tcPolyLExprSig :: LHsExpr GhcRn -> TcCompleteSig -> TcM (LHsExpr GhcTc) + tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) +tcInferExpr :: InferInstFlag -> LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcType) + tcSyntaxOp :: CtOrigin -> SyntaxExprRn -> [SyntaxOpType] -- ^ shape of syntax operator arguments @@ -42,4 +48,3 @@ -> SyntaxOpType -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) - diff --git a/GHC/Tc/Gen/Foreign.hs b/GHC/Tc/Gen/Foreign.hs --- a/GHC/Tc/Gen/Foreign.hs +++ b/GHC/Tc/Gen/Foreign.hs @@ -78,14 +78,14 @@ import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( zipWithM ) +import Control.Monad ( when, zipWithM ) import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell ) import Control.Monad.Trans.Class ( lift ) import Data.Maybe (isJust) -import GHC.Types.RepType (tyConPrimRep) import GHC.Builtin.Types (unitTyCon) +import GHC.Types.RepType (typePrimRep1) -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool @@ -254,7 +254,7 @@ -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty , fd_fi = imp_decl })) - = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo) $ + = setSrcSpanA dloc $ addErrCtxt (ForeignDeclCtxt fo) $ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let @@ -298,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. @@ -356,7 +356,7 @@ dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - checkMissingAmpersand idecl (map scaledThing arg_tys) res_ty + checkMissingAmpersand idecl target (map scaledThing arg_tys) res_ty case target of StaticTarget _ _ _ False | not (null arg_tys) -> @@ -373,8 +373,10 @@ checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM () -checkMissingAmpersand idecl arg_tys res_ty +checkMissingAmpersand :: ForeignImport GhcRn -> CCallTarget -> [Type] -> Type -> TcM () +checkMissingAmpersand _ (StaticTarget _ _ _ False) _ _ = return () + +checkMissingAmpersand idecl _ arg_tys res_ty | null arg_tys && isFunPtrTy res_ty = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl | otherwise @@ -405,12 +407,12 @@ 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) tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec }) - = addErrCtxt (foreignDeclCtxt fo) $ do + = addErrCtxt (ForeignDeclCtxt fo) $ do sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty @@ -442,7 +444,7 @@ tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc) tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do checkCg (Left edecl) backendValidityOfCExport - checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) + when (cconv /= JavaScriptCallConv) $ checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty @@ -462,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 >> @@ -540,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 @@ -553,7 +566,7 @@ return PrimCallConv checkCConv decl JavaScriptCallConv = do dflags <- getDynFlags - if platformArch (targetPlatform dflags) == ArchJavaScript + if platformArch (targetPlatform dflags) `elem` [ ArchJavaScript, ArchWasm32 ] then return JavaScriptCallConv else do addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported @@ -567,12 +580,6 @@ check IsValid _ = return () check (NotValid reason) mkMessage = addErrTc (mkMessage reason) -foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc -foreignDeclCtxt fo - = hang (text "When checking declaration:") - 2 (ppr fo) - - {- Predicates on Types used in this module -} -- | Reason why a type in an FFI signature is invalid @@ -735,7 +742,6 @@ marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason marshalableTyCon dflags tc | marshalablePrimTyCon tc - , not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | otherwise = boxedMarshalableTyCon tc @@ -751,6 +757,7 @@ , charTyConKey , stablePtrTyConKey , boolTyConKey + , jsvalTyConKey ] = IsValid @@ -769,7 +776,6 @@ -- types and also unboxed tuple and sum result types. legalFIPrimResultTyCon dflags tc | marshalablePrimTyCon tc - , not (null (tyConPrimRep tc)) -- Note [Marshalling void] = validIfUnliftedFFITypes dflags | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc @@ -782,14 +788,3 @@ validIfUnliftedFFITypes dflags | xopt LangExt.UnliftedFFITypes dflags = IsValid | otherwise = NotValid UnliftedFFITypesNeeded - -{- -Note [Marshalling void] -~~~~~~~~~~~~~~~~~~~~~~~ -We don't treat State# (whose PrimRep is VoidRep) as marshalable. -In turn that means you can't write - foreign import foo :: Int -> State# RealWorld - -Reason: the back end falls over with panic "primRepHint:VoidRep"; - and there is no compelling reason to permit it --} diff --git a/GHC/Tc/Gen/Head.hs b/GHC/Tc/Gen/Head.hs --- a/GHC/Tc/Gen/Head.hs +++ b/GHC/Tc/Gen/Head.hs @@ -16,1461 +16,1209 @@ -} module GHC.Tc.Gen.Head - ( HsExprArg(..), EValArg(..), TcPass(..) - , AppCtxt(..), appCtxtLoc, insideExpansion - , splitHsApps, rebuildHsApps - , addArgWrap, isHsValArg - , countLeadingValArgs, isVisibleArg, pprHsExprArgTc - , countVisAndInvisValArgs, countHsWrapperInvisArgs - - , tcInferAppHead, tcInferAppHead_maybe - , tcInferId, tcCheckId - , obviousSig - , tyConOf, tyConOfET, fieldNotInType - , nonBidirectionalErr - - , addHeadCtxt, addExprCtxt, addFunResCtxt ) where - -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC ) - -import GHC.Prelude -import GHC.Hs -import GHC.Hs.Syn.Type - -import GHC.Tc.Gen.HsType -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) - -import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) -import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan ) -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.Utils.TcType as TcType -import GHC.Tc.Types.Evidence -import GHC.Tc.Zonk.TcType - - -import GHC.Core.PatSyn( PatSyn ) -import GHC.Core.ConLike( ConLike(..) ) -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -import GHC.Core.Type - -import GHC.Types.Var( isInvisibleFunArg ) -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Name -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import GHC.Types.Basic -import GHC.Types.Error - -import GHC.Builtin.Types( multiplicityTy ) -import GHC.Builtin.Names -import GHC.Builtin.Names.TH( liftStringName, liftName ) - -import GHC.Driver.Env -import GHC.Driver.DynFlags -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import GHC.Data.Maybe -import Control.Monad - - - -{- ********************************************************************* -* * - HsExprArg: auxiliary data type -* * -********************************************************************* -} - -{- Note [HsExprArg] -~~~~~~~~~~~~~~~~~~~ -The data type HsExprArg :: TcPass -> Type -is a very local type, used only within this module and GHC.Tc.Gen.App - -* It's really a zipper for an application chain - See Note [Application chains and heads] in GHC.Tc.Gen.App for - what an "application chain" is. - -* It's a GHC-specific type, so using TTG only where necessary - -* It is indexed by TcPass, meaning - - HsExprArg TcpRn: - 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 - - - HsExprArg TcpTc: - The result of tcArg, which typechecks the value args - In EValArg we now have a (LHsExpr GhcTc) - -* 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 - -2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL, - under the conditions when quick-look should happen (eg the argument - type is guarded) -- see quickLookArg - -Note [splitHsApps] -~~~~~~~~~~~~~~~~~~ -The key function - splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn]) -takes apart either an HsApp, or an infix OpApp, returning - -* The "head" of the application, an expression that is often a variable; - this is used for typechecking - -* The "user head" or "error head" of the application, to be reported to the - user in case of an error. Example: - (`op` e) - expands (via HsExpanded) to - (rightSection op e) - but we don't want to see 'rightSection' in error messages. So we keep the - innermost un-expanded head as the "error head". - -* A list of HsExprArg, the arguments --} - -data TcPass = TcpRn -- Arguments decomposed - | 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) } - - | ETypeArg { eva_ctxt :: AppCtxt - , eva_at :: !(LHsToken "@" GhcRn) - , eva_hs_ty :: LHsWcType GhcRn -- The type arg - , eva_ty :: !(XETAType p) } -- Kind-checked type arg - - | EPrag AppCtxt - (HsPragE (GhcPass (XPass p))) - - | EWrap EWrap - -data EWrap = EPar AppCtxt - | EExpand (HsExpr GhcRn) - | 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 - (HsExpr GhcRn) -- Inside an expansion of this expression - SrcSpan -- The SrcSpan of the expression - -- noSrcSpan if outermost; see Note [AppCtxt] - - | VACall - (HsExpr GhcRn) Int -- In the third argument of function f - 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 -example, the AppCtxt for e3 allows us to say - "In the third argument of `f`" -See splitHsApps. - -To do this we must take a quick look into the expression to find the -function at the head (`f` in this case) and how many arguments it -has. That is what the funcion top_ctxt does. - -If the function part is an expansion, we don't want to look further. -For example, with rebindable syntax the expression - (if e1 then e2 else e3) e4 e5 -might expand to - (ifThenElse e1 e2 e3) e4 e5 -For e4 we an AppCtxt that says "In the first argument of (if ...)", -not "In the fourth argument of ifThenElse". So top_ctxt stops -at expansions. - -The SrcSpan in an AppCtxt describes the whole call. We initialise -it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so -we don't have a span for the whole call; and we use that noSrcSpan in -GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`" -a second time. --} - -appCtxtLoc :: AppCtxt -> SrcSpan -appCtxtLoc (VAExpansion _ l) = l -appCtxtLoc (VACall _ _ l) = l - -insideExpansion :: AppCtxt -> Bool -insideExpansion (VAExpansion {}) = True -insideExpansion (VACall {}) = False - -instance Outputable AppCtxt where - ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e - ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f - -type family XPass p 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 } - -mkETypeArg :: AppCtxt -> LHsToken "@" GhcRn -> LHsWcType GhcRn -> HsExprArg 'TcpRn -mkETypeArg ctxt at hs_ty = - ETypeArg { eva_ctxt = ctxt - , eva_at = at, eva_hs_ty = hs_ty - , eva_ty = noExtField } - -addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst] -addArgWrap wrap args - | isIdHsWrapper wrap = args - | otherwise = EWrap (EHsWrap wrap) : args - -splitHsApps :: HsExpr GhcRn - -> ( (HsExpr GhcRn, AppCtxt) -- Head - , [HsExprArg 'TcpRn]) -- Args --- See Note [splitHsApps] -splitHsApps e = go e (top_ctxt 0 e) [] - where - top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt - -- Always returns VACall fun n_val_args noSrcSpan - -- to initialise the argument splitting in 'go' - -- See Note [AppCtxt] - top_ctxt n (HsPar _ _ fun _) = top_lctxt n fun - top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun - top_ctxt n (HsAppType _ fun _ _) = top_lctxt (n+1) fun - top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun - top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan - top_ctxt n other_fun = VACall other_fun n noSrcSpan - - top_lctxt n (L _ fun) = top_ctxt n fun - - go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] - -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) - -- Modify the AppCtxt as we walk inwards, so it describes the next argument - go (HsPar _ _ (L l fun) _) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) - go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) - go (HsAppType _ (L l fun) at ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt at ty : args) - go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args) - - -- See Note [Looking through HsExpanded] - go (XExpr (HsExpanded orig fun)) ctxt args - = go fun (VAExpansion orig (appCtxtLoc ctxt)) - (EWrap (EExpand orig) : args) - - -- See Note [Desugar OpApp in the typechecker] - go e@(OpApp _ arg1 (L l op) arg2) _ args - = ( (op, VACall op 0 (locA l)) - , mkEValArg (VACall op 1 generatedSrcSpan) arg1 - : mkEValArg (VACall op 2 generatedSrcSpan) arg2 - : EWrap (EExpand e) - : args ) - - go e ctxt args = ((e,ctxt), args) - - set :: SrcSpanAnnA -> AppCtxt -> AppCtxt - set l (VACall f n _) = VACall f n (locA l) - set _ ctxt@(VAExpansion {}) = ctxt - - dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt - dec l (VACall f n _) = VACall f (n-1) (locA l) - dec _ ctxt@(VAExpansion {}) = ctxt - --- | Rebuild an application: takes a type-checked application head --- expression together with arguments in the form of typechecked 'HsExprArg's --- and returns a typechecked application of the head to the arguments. --- --- This performs a representation-polymorphism check to ensure that the --- remaining value arguments in an application have a fixed RuntimeRep. --- --- See Note [Checking for representation-polymorphic built-ins]. -rebuildHsApps :: HsExpr GhcTc - -- ^ 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 { tcRemainingValArgs 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) - = case arg of - EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } - -> rebuild_hs_apps (HsApp noAnn lfun arg) ctxt' args - ETypeArg { eva_hs_ty = hs_ty, eva_at = at, eva_ty = ty, eva_ctxt = ctxt' } - -> rebuild_hs_apps (HsAppType ty lfun at hs_ty) ctxt' args - EPrag ctxt' p - -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args - EWrap (EPar ctxt') - -> rebuild_hs_apps (gHsPar lfun) ctxt' args - EWrap (EExpand orig) - -> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args - EWrap (EHsWrap wrap) - -> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args - where - lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun - -{- Note [Checking for representation-polymorphic built-ins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We cannot have representation-polymorphic or levity-polymorphic -function arguments. See Note [Representation polymorphism invariants] -in GHC.Core. That is checked by the calls to `hasFixedRuntimeRep` in -`tcEValArg`. - -But some /built-in/ functions have representation-polymorphic argument -types. Users can't define such Ids; they are all GHC built-ins or data -constructors. Specifically they are: - -1. A few wired-in Ids such as coerce and unsafeCoerce#, -2. Primops, such as raise#. -3. Newtype constructors with `UnliftedNewtypes` which have - a representation-polymorphic argument. -4. Representation-polymorphic data constructors: unboxed tuples - and unboxed sums. - -For (1) consider - badId :: forall r (a :: TYPE r). a -> a - badId = unsafeCoerce# @r @r @a @a - -The 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) 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. - -For (3), 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 - -So these cases need special treatment. We add a special case -in tcApp to check whether an application of an Id has any remaining -representation-polymorphic arguments, after instantiation and application -of previous arguments. This is achieved by the tcRemainingValArgs -function, which computes the types of the remaining value arguments, and checks -that each of these have a fixed runtime representation. - -Note that this function also ensures that data constructors always -appear saturated, by performing eta-expansion if necessary. -See Note [Typechecking data constructors]. - -Wrinkle [Arity] - - We don't want to check for arguments past the arity of the function. - - For example - - raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b - - has arity 1, so an instantiation such as: - - foo :: forall w r (z :: TYPE r). w -> z -> z - foo = raise# @w @(z -> z) - - is unproblematic. This means we must take care not to perform a - representation-polymorphism check on `z`. - - To achieve this, we consult the arity of the 'Id' which is the head - of the application (or just use 1 for a newtype constructor), - and keep track of how many value-level arguments we have seen, - to ensure we stop checking once we reach the arity. - This is slightly complicated by the need to include both visible - and invisible arguments, as the arity counts both: - see GHC.Tc.Gen.Head.countVisAndInvisValArgs. - - Test cases: T20330{a,b} - -Wrinkle [Syntactic check] - - We only perform a syntactic check in tcRemainingValArgs. That is, - we will reject partial applications such as: - - type RR :: RuntimeREp - type family RR where { RR = IntRep } - type T :: TYPE RR - type family T where { T = Int# } - - (# , #) @LiftedRep @RR e1 - - Why do we reject? Wee would need to elaborate this partial application - of (# , #) as follows: - - let x1 = e1 - in - ( \ @(ty2 :: TYPE RR) (x2 :: ty2 |> TYPE RR[0]) - -> ( ( (# , #) @LiftedRep @RR @Char @ty2 x1 ) |> co1 ) - x2 - ) |> co2 - - That is, we need to cast the partial application - - (# , #) @LiftedRep @RR @Char @ty2 x1 - - so that the next argument we provide to it has a fixed RuntimeRep, - and then eta-expand it. This is quite tricky, and other parts - of the compiler aren't set up to handle this mix of applications - and casts (e.g. checkCanEtaExpand in GHC.Core.Lint). - - So we refrain from doing so, and instead limit ourselves to a simple syntactic - check. See the wiki page https://gitlab.haskell.org/ghc/ghc/-/wikis/Remaining-ValArgs - for a more in-depth discussion. --} - --- | Typecheck the remaining value arguments in a partial application, --- ensuring they have a fixed RuntimeRep in the sense of Note [Fixed RuntimeRep] --- in GHC.Tc.Utils.Concrete. --- --- Example: --- --- > repPolyId :: forall r (a :: TYPE r). a -> a --- > repPolyId = coerce --- --- This is an invalid instantiation of 'coerce', as we can't eta expand it --- to --- --- > \@r \@(a :: TYPE r) (x :: a) -> coerce @r @a @a x --- --- because the binder `x` does not have a fixed runtime representation. -tcRemainingValArgs :: HasDebugCallStack - => [HsExprArg 'TcpTc] - -> TcRhoType - -> HsExpr GhcTc - -> TcM () -tcRemainingValArgs applied_args app_res_rho fun = case fun of - - HsVar _ (L _ fun_id) - - -- (1): unsafeCoerce# - -- 'unsafeCoerce#' is peculiar: it is patched in manually as per - -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore. - -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair, - -- at this stage, if we query idArity, we get 0. This is because - -- we end up looking at the non-patched version of unsafeCoerce# - -- defined in Unsafe.Coerce, and that one indeed has arity 0. - -- - -- We thus manually specify the correct arity of 1 here. - | idName fun_id == unsafeCoercePrimName - -> tc_remaining_args 1 (RepPolyWiredIn fun_id) - - -- (2): primops and other wired-in representation-polymorphic functions, - -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings - -- in GHC.Types.Id.Make - | isWiredInName (idName fun_id) && hasNoBinding fun_id - -> tc_remaining_args (idArity fun_id) (RepPolyWiredIn fun_id) - -- NB: idArity consults the IdInfo of the Id. This can be a problem - -- in the presence of hs-boot files, as we might not have finished - -- typechecking; inspecting the IdInfo at this point can cause - -- strange Core Lint errors (see #20447). - -- We avoid this entirely by only checking wired-in names, - -- as those are the only ones this check is applicable to anyway. - - XExpr (ConLikeTc (RealDataCon con) _ _) - -- (3): Representation-polymorphic newtype constructors. - | isNewDataCon con - -- (4): Unboxed tuples and unboxed sums - || isUnboxedTupleDataCon con - || isUnboxedSumDataCon con - -> tc_remaining_args (dc_val_arity con) (RepPolyDataCon con) - - _ -> return () - - where - - dc_val_arity :: DataCon -> Arity - dc_val_arity con = count (not . isEqPrimPred) (dataConTheta con) - + length (dataConStupidTheta con) - + dataConSourceArity con - -- Count how many value-level arguments this data constructor expects: - -- - dictionary arguments from the context (including the stupid context), - -- - source value arguments. - -- Tests: EtaExpandDataCon, EtaExpandStupid{1,2}. - - nb_applied_vis_val_args :: Int - nb_applied_vis_val_args = count isHsValArg applied_args - - nb_applied_val_args :: Int - nb_applied_val_args = countVisAndInvisValArgs applied_args - - tc_remaining_args :: Arity -> RepPolyFun -> TcM () - tc_remaining_args arity rep_poly_fun = - tc_rem_args - (nb_applied_vis_val_args + 1) - (nb_applied_val_args + 1) - rem_arg_tys - - where - - rem_arg_tys :: [(Scaled Type, FunTyFlag)] - rem_arg_tys = getRuntimeArgTys app_res_rho - -- We do not need to zonk app_res_rho first, because the number of arrows - -- in the (possibly instantiated) inferred type of the function will - -- be at least the arity of the function. - - -- The following function is essentially "mapM hasFixedRuntimeRep rem_arg_tys", - -- but we need to keep track of indices for error messages, hence the manual recursion. - tc_rem_args :: Int - -- visible value argument index, starting from 1 - -- (only used to report the argument position in error messages) - -> Int - -- value argument index, starting from 1 - -- used to count up to the arity to ensure that - -- we don't check too many argument types - -> [(Scaled Type, FunTyFlag)] - -- run-time argument types - -> TcM () - tc_rem_args _ i_val _ - | i_val > arity - = return () - tc_rem_args _ _ [] - -- Should never happen: it would mean that the arity is higher - -- than the number of arguments apparent from the type. - = pprPanic "tcRemainingValArgs" debug_msg - tc_rem_args i_visval !i_val ((Scaled _ arg_ty, af) : tys) - = do { let (i_visval', arg_pos) - | isInvisibleFunArg af = ( i_visval , ArgPosInvis ) - | otherwise = ( i_visval + 1, ArgPosVis i_visval ) - frr_ctxt = FRRNoBindingResArg rep_poly_fun arg_pos - ; hasFixedRuntimeRep_syntactic frr_ctxt arg_ty - -- Why is this a syntactic check? See Wrinkle [Syntactic check] in - -- Note [Checking for representation-polymorphic built-ins]. - ; tc_rem_args i_visval' (i_val + 1) tys } - - debug_msg :: SDoc - debug_msg = - vcat - [ text "app_head =" <+> ppr fun - , text "arity =" <+> ppr arity - , text "applied_args =" <+> ppr applied_args - , text "nb_applied_val_args =" <+> ppr nb_applied_val_args ] - - -isHsValArg :: HsExprArg id -> Bool -isHsValArg (EValArg {}) = True -isHsValArg _ = False - -countLeadingValArgs :: [HsExprArg id] -> Int -countLeadingValArgs [] = 0 -countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args -countLeadingValArgs (EWrap {} : args) = countLeadingValArgs args -countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args -countLeadingValArgs (ETypeArg {} : _) = 0 - -isValArg :: HsExprArg id -> Bool -isValArg (EValArg {}) = True -isValArg _ = False - -isVisibleArg :: HsExprArg id -> Bool -isVisibleArg (EValArg {}) = True -isVisibleArg (ETypeArg {}) = True -isVisibleArg _ = False - --- | Count visible and invisible value arguments in a list --- of 'HsExprArg' arguments. -countVisAndInvisValArgs :: [HsExprArg id] -> Arity -countVisAndInvisValArgs [] = 0 -countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args -countVisAndInvisValArgs (EWrap wrap : args) = - case wrap of { EHsWrap hsWrap -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args - ; EPar {} -> countVisAndInvisValArgs args - ; EExpand {} -> countVisAndInvisValArgs args } -countVisAndInvisValArgs (EPrag {} : args) = countVisAndInvisValArgs args -countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args - --- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'. --- Precondition: this wrapper contains no abstractions. -countHsWrapperInvisArgs :: HsWrapper -> Arity -countHsWrapperInvisArgs = go - where - go WpHole = 0 - go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2 - go fun@(WpFun {}) = nope fun - go (WpCast {}) = 0 - go evLam@(WpEvLam {}) = nope evLam - go (WpEvApp _) = 1 - go tyLam@(WpTyLam {}) = nope tyLam - go (WpTyApp _) = 0 - go (WpLet _) = 0 - go (WpMultCoercion {}) = 0 - - nope x = pprPanic "countHsWrapperInvisApps" (ppr x) - -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 - -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 -Note [Handling overloaded and rebindable constructs]. -But for reasons explained there, we rename OpApp to OpApp. Then, -here in the typechecker, we desugar it to a use of HsExpanded. -That makes it possible to typecheck something like - e1 `f` e2 -where - f :: forall a. t1 -> forall b. t2 -> t3 - -Note [Looking through HsExpanded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When creating an application chain in splitHsApps, we must deal with - HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3 - -as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded -labels (#19154) won't work. - -It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`. --} - -{- ********************************************************************* -* * - tcInferAppHead -* * -********************************************************************* -} - -tcInferAppHead :: (HsExpr GhcRn, AppCtxt) - -> [HsExprArg 'TcpRn] - -> TcM (HsExpr GhcTc, TcSigmaType) --- Infer type of the head of an application --- i.e. the 'f' in (f e1 ... en) --- See Note [Application chains and heads] in GHC.Tc.Gen.App --- We get back a /SigmaType/ because we have special cases for --- * A bare identifier (just look it up) --- This case also covers a record selector HsRecSel --- * An expression with a type signature (e :: ty) --- See Note [Application chains and heads] in GHC.Tc.Gen.App --- --- Why do we need the arguments to infer the type of the head of the --- application? Simply to inform add_head_ctxt about whether or not --- to put push a new "In the expression..." context. (We don't push a --- new one if there are no arguments, because we already have.) --- --- Note that [] and (,,) are both HsVar: --- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr --- --- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those --- cases are dealt with by splitHsApps. --- --- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App -tcInferAppHead (fun,ctxt) args - = addHeadCtxt ctxt $ - do { mb_tc_fun <- tcInferAppHead_maybe fun args - ; case mb_tc_fun of - Just (fun', fun_sigma) -> return (fun', fun_sigma) - Nothing -> tcInfer (tcExpr fun) } - -tcInferAppHead_maybe :: HsExpr GhcRn - -> [HsExprArg 'TcpRn] - -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) --- See Note [Application chains and heads] in GHC.Tc.Gen.App --- Returns Nothing for a complicated head -tcInferAppHead_maybe fun args - = case fun of - HsVar _ (L _ nm) -> Just <$> tcInferId nm - HsRecSel _ f -> Just <$> tcInferRecSelId f - ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty - HsOverLit _ lit -> Just <$> tcInferOverLit lit - HsUntypedSplice (HsUntypedSpliceTop _ e) _ - -> tcInferAppHead_maybe e args - _ -> return Nothing - -addHeadCtxt :: AppCtxt -> TcM a -> TcM a -addHeadCtxt fun_ctxt thing_inside - | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments - = thing_inside -- => context is already set - | otherwise - = setSrcSpan fun_loc $ - case fun_ctxt of - VAExpansion orig _ -> addExprCtxt orig thing_inside - VACall {} -> thing_inside - where - fun_loc = appCtxtLoc fun_ctxt - -{- ********************************************************************* -* * - Record selectors -* * -********************************************************************* -} - -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) - } - where - occ :: OccName - occ = rdrNameOcc (unLoc lbl) - - tc_rec_sel_id :: TcM TcId - -- Like tc_infer_id, but returns an Id not a HsExpr, - -- so we can wrap it back up into a HsRecSel - tc_rec_sel_id - = do { thing <- tcLookup sel_name - ; case thing of - ATcId { tct_id = id } - -> do { check_naughty occ id -- See Note [Local record selectors] - ; check_local_id id - ; return id } - - AGlobal (AnId id) - -> do { check_naughty occ id - ; return id } - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- hence no checkTh stuff here - - _ -> failWithTc $ TcRnExpectedValueId thing } - ------------------------- - --- A type signature on the argument of an ambiguous record selector or --- the record expression in an update must be "obvious", i.e. the --- outermost constructor ignoring parentheses. -obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) -obviousSig (ExprWithTySig _ _ ty) = Just ty -obviousSig (HsPar _ _ p _) = obviousSig (unLoc p) -obviousSig (HsPragE _ _ p) = obviousSig (unLoc p) -obviousSig _ = Nothing - --- Extract the outermost TyCon of a type, if there is one; for --- data families this is the representation tycon (because that's --- where the fields live). -tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon -tyConOf fam_inst_envs ty0 - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) - Nothing -> Nothing - where - (_, _, ty) = tcSplitSigmaTy ty0 - --- Variant of tyConOf that works for ExpTypes -tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon -tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 - -fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage -fieldNotInType p rdr - = mkTcRnNotInScope rdr $ - UnknownSubordinate (text "field of type" <+> quotes (ppr p)) - - -{- ********************************************************************* -* * - Expressions with a type signature - expr :: type -* * -********************************************************************* -} - -tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) - -> TcM (HsExpr GhcTc, TcSigmaType) -tcExprWithSig expr hs_ty - = do { sig_info <- checkNoErrs $ -- Avoid error cascade - tcUserTypeSig loc hs_ty Nothing - ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info - ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } - where - loc = getLocA (dropWildCards hs_ty) - ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) - -tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) -tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { let poly_ty = idType poly_id - ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty -> - tcCheckMonoExprNC expr rho_ty - ; return (mkLHsWrap wrap expr', poly_ty) } - -tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) - = setSrcSpan loc $ -- Sets the location for the implication constraint - do { (tclvl, wanted, (expr', sig_inst)) - <- pushLevelAndCaptureConstraints $ - do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ - tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ - tcCheckPolyExprNC expr (sig_inst_tau sig_inst) - ; return (expr', sig_inst) } - -- See Note [Partial expression signatures] - ; let tau = sig_inst_tau sig_inst - infer_mode | null (sig_inst_theta sig_inst) - , isNothing (sig_inst_wcx sig_inst) - = ApplyMR - | otherwise - = NoRestrictions - ; ((qtvs, givens, ev_binds, _), residual) - <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted - ; emitConstraints residual - - ; tau <- liftZonkM $ zonkTcType tau - ; let inferred_theta = map evVarPred givens - tau_tvs = tyCoVarsOfType tau - ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta - tau_tvs qtvs (Just sig_inst) - ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) - ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. - then return idHsWrapper -- Fast path; also avoids complaint when we infer - -- an ambiguous type and have AllowAmbiguousType - -- e..g infer x :: forall a. F a -> Int - else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma - - ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) - ; let poly_wrap = wrap - <.> mkWpTyLams qtvs - <.> mkWpEvLams givens - <.> mkWpLet ev_binds - ; return (mkLHsWrap poly_wrap expr', my_sigma) } - - -{- Note [Partial expression signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Partial type signatures on expressions are easy to get wrong. But -here is a guiding principle - e :: ty -should behave like - let x :: ty - x = e - in x - -So for partial signatures we apply the MR if no context is given. So - e :: IO _ apply the MR - e :: _ => IO _ do not apply the MR -just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan - -This makes a difference (#11670): - peek :: Ptr a -> IO CLong - peek ptr = peekElemOff undefined 0 :: _ -from (peekElemOff undefined 0) we get - type: IO w - constraints: Storable w - -We must NOT try to generalise over 'w' because the signature specifies -no constraints so we'll complain about not being able to solve -Storable w. Instead, don't generalise; then _ gets instantiated to -CLong, as it should. --} - - -{- ********************************************************************* -* * - Overloaded literals -* * -********************************************************************* -} - -tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) -tcInferOverLit lit@(OverLit { ol_val = val - , ol_ext = OverLitRn { ol_rebindable = rebindable - , ol_from_fun = L loc from_name } }) - = -- Desugar "3" to (fromInteger (3 :: Integer)) - -- where fromInteger is gotten by looking up from_name, and - -- the (3 :: Integer) is returned by mkOverLit - -- Ditto the string literal "foo" to (fromString ("foo" :: String)) - do { hs_lit <- mkOverLit val - ; from_id <- tcLookupId from_name - ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id) - ; let - thing = NameThing from_name - mb_thing = Just thing - herald = ExpectedFunTyArg thing (HsLit noAnn hs_lit) - ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing - (1, []) from_ty - - ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) - ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ - HsLit noAnn hs_lit - from_expr = mkHsWrap (wrap2 <.> wrap1) $ - HsVar noExtField (L loc from_id) - witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr - lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable - , ol_witness = witness - , ol_type = res_ty } } - ; return (HsOverLit noAnn lit', res_ty) } - -{- ********************************************************************* -* * - tcInferId, tcCheckId -* * -********************************************************************* -} - -tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) -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 $ - tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty } - where - rn_fun = HsVar noExtField (noLocA name) - ------------------------- -tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType) --- Look up an occurrence of an Id --- Do not instantiate its type -tcInferId id_name - | id_name `hasKey` assertIdKey - = do { dflags <- getDynFlags - ; if gopt Opt_IgnoreAsserts dflags - then tc_infer_id id_name - else tc_infer_assert id_name } - - | otherwise - = do { (expr, ty) <- tc_infer_id id_name - ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) - ; return (expr, ty) } - -tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType) --- Deal with an occurrence of 'assert' --- See Note [Adding the implicit parameter to 'assert'] -tc_infer_assert assert_name - = do { assert_error_id <- tcLookupId assertErrorName - ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) - (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho) - } - -tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType) -tc_infer_id id_name - = do { thing <- tcLookup id_name - ; case thing of - ATcId { tct_id = id } - -> do { check_local_id id - ; return_id id } - - AGlobal (AnId id) -> return_id id - -- A global cannot possibly be ill-staged - -- nor does it need the 'lifting' treatment - -- Hence no checkTh stuff here - - AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con - AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps - (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon - ATyVar name _ -> fail_tyvar name - - _ -> failWithTc $ TcRnExpectedValueId thing } - where - fail_tycon tc = do - gre <- getGlobalRdrEnv - let nm = tyConName tc - pprov = case lookupGRE_Name gre nm of - Just gre -> nest 2 (pprNameProvenance gre) - Nothing -> empty - fail_with_msg dataName nm pprov - - fail_tyvar nm = - let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm)) - in fail_with_msg varName nm pprov - - fail_with_msg whatName nm pprov = do - (import_errs, hints) <- get_suggestions whatName - unit_state <- hsc_units <$> getTopEnv - let - -- TODO: unfortunate to have to convert to SDoc here. - -- This should go away once we refactor ErrInfo. - hint_msg = vcat $ map ppr hints - import_err_msg = vcat $ map ppr import_errs - info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } - failWithTc $ TcRnMessageWithInfo unit_state ( - mkDetailedMessage info (TcRnIncorrectNameSpace nm False)) - - get_suggestions ns = do - let occ = mkOccNameFS ns (occNameFS (occName id_name)) - lcl_env <- getLocalRdrEnv - unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ) - - return_id id = return (HsVar noExtField (noLocA id), idType id) - -check_local_id :: Id -> TcM () -check_local_id id - = do { checkThLocalId id - ; tcEmitBindingUsage $ singleUsageUE id } - -check_naughty :: OccName -> TcId -> TcM () -check_naughty lbl id - | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl) - | otherwise = return () - -tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) --- See Note [Typechecking data constructors] -tcInferDataCon con - = do { let tvbs = dataConUserTyVarBinders con - tvs = binderVars tvbs - theta = dataConOtherTheta con - args = dataConOrigArgTys con - res = dataConOrigResTy con - stupid_theta = dataConStupidTheta con - - ; scaled_arg_tys <- mapM linear_to_poly args - - ; let full_theta = stupid_theta ++ theta - all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys - -- We are building the type of the data con wrapper, so the - -- type must precisely match the construction in - -- GHC.Core.DataCon.dataConWrapperType. - -- See Note [Instantiating stupid theta] - -- in GHC.Core.DataCon. - - ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys) - , mkInvisForAllTys tvbs $ mkPhiTy full_theta $ - mkScaledFunTys scaled_arg_tys res ) } - where - linear_to_poly :: Scaled Type -> TcM (Scaled Type) - -- linear_to_poly implements point (3,4) - -- of Note [Typechecking data constructors] - linear_to_poly (Scaled OneTy ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy - ; return (Scaled mul_var ty) } - linear_to_poly scaled_ty = return scaled_ty - -tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType) -tcInferPatSyn id_name ps - = case patSynBuilderOcc ps of - Just (expr,ty) -> return (expr,ty) - Nothing -> failWithTc (nonBidirectionalErr id_name) - -nonBidirectionalErr :: Name -> TcRnMessage -nonBidirectionalErr = TcRnPatSynNotBidirectional - -{- Note [Adding the implicit parameter to 'assert'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker transforms (assert e1 e2) to (assertError e1 e2). -This isn't really the Right Thing because there's no way to "undo" -if you want to see the original source code in the typechecker -output. We'll have fix this in due course, when we care more about -being able to reconstruct the exact original program. - -Note [Typechecking data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As per Note [Polymorphisation of linear fields] in -GHC.Core.Multiplicity, linear fields of data constructors get a -polymorphic multiplicity when the data constructor is used as a term: - - Just :: forall {p} a. a %p -> Maybe a - -So at an occurrence of a data constructor we do the following: - -1. Typechecking, in tcInferDataCon. - - a. Get the original type of the constructor, say - K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a - Note the %1: it is linear - - b. We are going to return a ConLikeTc, thus: - XExpr (ConLikeTc K [r,a] [Scaled p a]) - :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a - where 'p' is a fresh multiplicity unification variable. - - To get the returned ConLikeTc, we allocate a fresh multiplicity - variable for each linear argument, and store the type, scaled by - the fresh multiplicity variable in the ConLikeTc; along with - the type of the ConLikeTc. This is done by linear_to_poly. - - If the argument is not linear (perhaps explicitly declared as - non-linear by the user), don't bother with this. - -2. Desugaring, in dsConLike. - - a. The (ConLikeTc K [r,a] [Scaled p a]) is desugared to - (/\r (a :: TYPE r). \(x %p :: a). K @r @a x) - which has the desired type given in the previous bullet. - - The 'p' is the multiplicity unification variable, which - will by now have been unified to something, or defaulted in - `GHC.Tc.Zonk.Type.commitFlexi`. So it won't just be an - (unbound) variable. - - So a saturated application (K e), where e::Int will desugar to - (/\r (a :: TYPE r). ..etc..) - @LiftedRep @Int e - and all those lambdas will beta-reduce away in the simple optimiser - (see Wrinkle [Representation-polymorphic lambdas] below). - - But for an /unsaturated/ application, such as `map (K @LiftedRep @Int) xs`, - beta reduction will leave (\x %Many :: Int. K x), which is the type `map` - expects whereas if we had just plain K, with its linear type, we'd - get a type mismatch. That's why we do this funky desugaring. - -Wrinkles - - [ConLikeTc arguments] - - Note that the [TcType] argument to ConLikeTc is strictly redundant; those are - the type variables from the dataConUserTyVarBinders of the data constructor. - Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly - from the data constructor. The only bit that /isn't/ redundant is the - fresh multiplicity variables! - - So an alternative would be to define ConLikeTc like this: - | ConLikeTc [TcType] -- Just the multiplicity variables - But then the desugarer would need to repeat some of the work done here. - So for now at least ConLikeTc records this strictly-redundant info. - - [Representation-polymorphic lambdas] - - The lambda expression we produce in (4) can have representation-polymorphic - arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x), - we have a lambda-bound variable x :: (a :: TYPE r). - This goes against the representation polymorphism invariants given in - Note [Representation polymorphism invariants] in GHC.Core. The trick is that - this this lambda will always be instantiated in a way that upholds the invariants. - This is achieved as follows: - - A. Any arguments to such lambda abstractions are guaranteed to have - a fixed runtime representation. This is enforced in 'tcApp' by - 'matchActualFunTySigma'. - - B. If there are fewer arguments than there are bound term variables, - hasFixedRuntimeRep_remainingValArgs will ensure that we are still - instantiating at a representation-monomorphic type, e.g. - - ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int# - :: Int# -> T IntRep Int# - - 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 - pass, we switch off Lint's representation-polymorphism checks; see - the `lf_check_fixed_rep` flag in `LintFlags`. --} - -{- -************************************************************************ -* * - Template Haskell checks -* * -************************************************************************ --} - -checkThLocalId :: Id -> TcM () --- The renamer has already done checkWellStaged, --- in RnSplice.checkThLocalName, so don't repeat that here. --- Here we just add constraints for cross-stage lifting -checkThLocalId id - = do { mb_local_use <- getStageAndBindLevel (idName id) - ; case mb_local_use of - Just (top_lvl, bind_lvl, use_stage) - | thLevel use_stage > bind_lvl - -> checkCrossStageLifting top_lvl id use_stage - _ -> return () -- Not a locally-bound thing, or - -- no cross-stage link - } - --------------------------------------- -checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM () --- If we are inside typed brackets, and (use_lvl > bind_lvl) --- we must check whether there's a cross-stage lift to do --- Examples \x -> [|| x ||] --- [|| map ||] --- --- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but --- this code is applied to *typed* brackets. - -checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q)) - | isTopLevel top_lvl - = when (isExternalName id_name) (keepAlive id_name) - -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice - - | otherwise - = -- Nested identifiers, such as 'x' in - -- E.g. \x -> [|| h x ||] - -- We must behave as if the reference to x was - -- h $(lift x) - -- We use 'x' itself as the splice proxy, used by - -- the desugarer to stitch it all back together. - -- If 'x' occurs many times we may get many identical - -- bindings of the same splice proxy, but that doesn't - -- matter, although it's a mite untidy. - do { let id_ty = idType id - ; checkTc (isTauTy id_ty) $ - TcRnTHError $ TypedTHError $ SplicePolymorphicLocalVar id - -- If x is polymorphic, its occurrence sites might - -- have different instantiations, so we can't use plain - -- 'x' as the splice proxy name. I don't know how to - -- solve this, and it's probably unimportant, so I'm - -- just going to flag an error for now - - ; lift <- if isStringTy id_ty then - do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName - -- See Note [Lifting strings] - ; return (HsVar noExtField (noLocA sid)) } - else - setConstraintVar lie_var $ - -- Put the 'lift' constraint into the right LIE - newMethodFromName (OccurrenceOf id_name) - GHC.Builtin.Names.TH.liftName - [getRuntimeRep id_ty, id_ty] - - -- Warning for implicit lift (#17804) - ; addDetailedDiagnostic (TcRnImplicitLift $ idName id) - - -- Update the pending splices - ; ps <- readMutVar ps_var - ; let pending_splice = PendingTcSplice id_name - (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) - (nlHsVar id)) - ; writeMutVar ps_var (pending_splice : ps) - - ; return () } - where - id_name = idName id - -checkCrossStageLifting _ _ _ = return () - -{- -Note [Lifting strings] -~~~~~~~~~~~~~~~~~~~~~~ -If we see $(... [| s |] ...) where s::String, we don't want to -generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. -So this conditional short-circuits the lifting mechanism to generate -(liftString "xy") in that case. I didn't want to use overlapping instances -for the Lift class in TH.Syntax, because that can lead to overlapping-instance -errors in a polymorphic situation. - -If this check fails (which isn't impossible) we get another chance; see -Note [Converting strings] in Convert.hs - -Note [Local record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Record selectors for TyCons in this module are ordinary local bindings, -which show up as ATcIds rather than AGlobals. So we need to check for -naughtiness in both branches. c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds. --} - - -{- ********************************************************************* -* * - Error reporting for function result mis-matches -* * -********************************************************************* -} - -addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] - -> TcType -> ExpRhoType - -> TcM a -> TcM a --- When we have a mis-match in the return type of a function --- try to give a helpful message about too many/few arguments --- But not in generated code, where we don't want --- to mention internal (rebindable syntax) function names -addFunResCtxt fun args fun_res_ty env_ty thing_inside - = do { env_tv <- newFlexiTyVarTy liftedTypeKind - ; dumping <- doptM Opt_D_dump_tc_trace - ; addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg dumping env_tv) thing_inside } - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg dumping env_tv - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; fun_res' <- zonkTcType fun_res_ty - ; env' <- case mb_env_ty of - Just env_ty -> zonkTcType env_ty - Nothing -> do { massert dumping; return env_tv } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' - (_, _, env_tau) = tcSplitNestedSigmaTys env' - -- env_ty is an ExpRhoTy, but with simple subsumption it - -- is not deeply skolemised, so still use tcSplitNestedSigmaTys - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - n_fun = length args_fun - n_env = length args_env - info | -- Check for too few args - -- fun_tau = a -> b, res_tau = Int - n_fun > n_env - , not_fun res_env - = text "Probable cause:" <+> quotes (ppr fun) - <+> text "is applied to too few arguments" - - | -- Check for too many args - -- fun_tau = a -> Int, res_tau = a -> b -> c -> d - -- The final guard suppresses the message when there - -- aren't enough args to drop; eg. the call is (f e1) - n_fun < n_env - , not_fun res_fun - , (n_fun + count isValArg args) >= n_env - -- Never suggest that a naked variable is - -- applied to too many args! - = text "Possible cause:" <+> quotes (ppr fun) - <+> text "is applied to too many arguments" - - | otherwise - = Outputable.empty - - ; return info } - - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False - -{- -Note [Splitting nested sigma types in mismatched function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When one applies a function to too few arguments, GHC tries to determine this -fact if possible so that it may give a helpful error message. It accomplishes -this by checking if the type of the applied function has more argument types -than supplied arguments. - -Previously, GHC computed the number of argument types through tcSplitSigmaTy. -This is incorrect in the face of nested foralls, however! -This caused Ticket #13311, for instance: - - f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b - -If one uses `f` like so: - - do { f; putChar 'a' } - -Then tcSplitSigmaTy will decompose the type of `f` into: - - Tyvars: [a] - Context: (Monoid a) - Argument types: [] - Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b - -That is, it will conclude that there are *no* argument types, and since `f` -was given no arguments, it won't print a helpful error message. On the other -hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: - - Tyvars: [a, b] - Context: (Monoid a, Monoid b) - Argument types: [Int, Maybe a] - Return type: Maybe b - -So now GHC recognizes that `f` has one more argument type than it was actually -provided. - -Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless -of simple/deep subsumption. Here we are concerned only whether there is a -mis-match in the number of value arguments. --} - - -{- ********************************************************************* -* * - Misc utility functions -* * -********************************************************************* -} - -addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a -addExprCtxt e thing_inside - = case e of - HsUnboundVar {} -> thing_inside - _ -> addErrCtxt (exprCtxt e) thing_inside - -- The HsUnboundVar special case addresses situations like - -- f x = _ - -- when we don't want to say "In the expression: _", - -- because it is mentioned in the error message itself - -exprCtxt :: HsExpr GhcRn -> SDoc -exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr)) + ( HsExprArg(..), TcPass(..), QLFlag(..), EWrap(..) + , AppCtxt(..), appCtxtLoc, insideExpansion + , splitHsApps, rebuildHsApps + , addArgWrap, isHsValArg + , leadingValArgs, isVisibleArg + + , tcInferAppHead, tcInferAppHead_maybe + , tcInferId, tcCheckId, tcInferConLike, obviousSig + , tyConOf, tyConOfET + , nonBidirectionalErr + + , pprArgInst + , addHeadCtxt, addExprCtxt, addStmtCtxt, addFunResCtxt ) where + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckPolyExprNC, tcPolyLExprSig ) +import {-# SOURCE #-} GHC.Tc.Gen.Splice( getUntypedSpliceBody ) + +import GHC.Prelude +import GHC.Hs +import GHC.Hs.Syn.Type + +import GHC.Tc.Gen.HsType +import GHC.Tc.Gen.Bind( chooseInferredQuantifiers ) +import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig ) +import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) +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, patSynName ) +import GHC.Core.ConLike( ConLike(..) ) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type + +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error + +import GHC.Builtin.Types( multiplicityTy ) +import GHC.Builtin.Names + +import GHC.Driver.DynFlags +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Data.Maybe + + + +{- ********************************************************************* +* * + HsExprArg: auxiliary data type +* * +********************************************************************* -} + +{- Note [HsExprArg] +~~~~~~~~~~~~~~~~~~~ +The data type HsExprArg :: TcPass -> Type +is a very local type, used only within this module and GHC.Tc.Gen.App + +* It's really a zipper for an application chain + See Note [Application chains and heads] in GHC.Tc.Gen.App for + what an "application chain" is. + +* It's a GHC-specific type, so using TTG only where necessary + +* It is indexed by TcPass, meaning + - HsExprArg TcpRn: + The result of splitHsApps, which decomposes a HsExpr GhcRn + + - HsExprArg TcpInst: + 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 + In EValArg we now have a (LHsExpr GhcTc) + +* rebuildPrefixApps is dual to splitHsApps, and zips an application + back into a HsExpr + +Invariants: + +1. With QL switched off, all arguments are ValArg; no ValArgQL + +2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL, + 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 + splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn]) +takes apart either an HsApp, or an infix OpApp, returning + +* The "head" of the application, an expression that is often a variable; + this is used for typechecking + +* The "user head" or "error head" of the application, to be reported to the + user in case of an error. Example: + (`op` e) + expands (via ExpandedThingRn) to + (rightSection op e) + but we don't want to see 'rightSection' in error messages. So we keep the + innermost un-expanded head as the "error head". + +* A list of HsExprArg, the arguments +-} + +data TcPass = TcpRn -- Arguments decomposed + | TcpInst -- Function instantiated + | TcpTc -- Typechecked + +data HsExprArg (p :: TcPass) where -- See Note [HsExprArg] + + -- Data constructor EValArg represents a value argument + EValArg :: { ea_ctxt :: AppCtxt + , ea_arg_ty :: !(XEVAType p) + , ea_arg :: LHsExpr (GhcPass (XPass p)) } + -> HsExprArg 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 + + 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 AppCtxt + = VAExpansion + HsThingRn + SrcSpan + SrcSpan + + | VACall + (HsExpr GhcRn) Int -- In the third argument of function f + 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 +example, the AppCtxt for e3 allows us to say + "In the third argument of `f`" +See splitHsApps. + +To do this we must take a quick look into the expression to find the +function at the head (`f` in this case) and how many arguments it +has. That is what the funcion top_ctxt does. + +If the function part is an expansion, we don't want to look further. +For example, with rebindable syntax the expression + (if e1 then e2 else e3) e4 e5 +might expand to + (ifThenElse e1 e2 e3) e4 e5 +For e4 we an AppCtxt that says "In the first argument of (if ...)", +not "In the fourth argument of ifThenElse". So top_ctxt stops +at expansions. + +The SrcSpan in an AppCtxt describes the whole call. We initialise +it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so +we don't have a span for the whole call; and we use that noSrcSpan in +GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`" +a second time. +-} + +appCtxtLoc :: AppCtxt -> SrcSpan +appCtxtLoc (VAExpansion _ l _) = l +appCtxtLoc (VACall _ _ l) = l + +insideExpansion :: AppCtxt -> Bool +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 :: TcPass) where + XPass 'TcpRn = 'Renamed + XPass 'TcpInst = 'Renamed + XPass 'TcpTc = 'Typechecked + +mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn +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 { ea_ctxt = ctxt + , ea_hs_ty = hs_ty + , ea_ty_arg = noExtField } + +addArgWrap :: HsWrapper -> [HsExprArg p] -> [HsExprArg p] +addArgWrap wrap args + | isIdHsWrapper wrap = args + | otherwise = EWrap (EHsWrap wrap) : args + +splitHsApps :: HsExpr GhcRn + -> TcM ( (HsExpr GhcRn, AppCtxt) -- Head + , [HsExprArg 'TcpRn]) -- Args +-- See Note [splitHsApps]. +-- +-- This uses the TcM monad solely because we must run modFinalizers when looking +-- through HsUntypedSplices +-- (see Note [Looking through Template Haskell splices in splitHsApps]). +splitHsApps e = go e (top_ctxt 0 e) [] + where + top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt + -- Always returns VACall fun n_val_args noSrcSpan + -- to initialise the argument splitting in 'go' + -- See Note [AppCtxt] + top_ctxt n (HsPar _ fun) = top_lctxt n fun + top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun + top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun + top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun + top_ctxt n (XExpr (ExpandedThingRn o _)) + | OrigExpr fun <- o = VACall fun n noSrcSpan + top_ctxt n other_fun = VACall other_fun n noSrcSpan + + top_lctxt n (L _ fun) = top_ctxt n fun + + go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] + -> TcM ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) + -- Modify the AppCtxt as we walk inwards, so it describes the next argument + go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) + go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) + go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args) + go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args) + + -- See Note [Looking through Template Haskell splices in splitHsApps] + go e@(HsUntypedSplice splice_res splice) ctxt args + = do { fun <- getUntypedSpliceBody splice_res + ; go fun ctxt' (EWrap (EExpand (OrigExpr e)) : args) } + where + ctxt' :: AppCtxt + ctxt' = case splice of + HsUntypedSpliceExpr _ (L l _) -> set l ctxt -- l :: SrcAnn AnnListItem + HsQuasiQuote _ _ (L l _) -> set l ctxt -- l :: SrcAnn NoEpAnns + (XUntypedSplice (HsImplicitLiftSplice _ _ _ (L l _))) -> set l ctxt + + -- See Note [Looking through ExpandedThingRn] + go (XExpr (ExpandedThingRn o e)) ctxt args + | isHsThingRnExpr o + = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt)) + (EWrap (EExpand o) : args) + + | OrigStmt (L _ stmt) <- o -- so that we set `(>>)` as generated + , BodyStmt{} <- stmt -- and get the right unused bind warnings + = go e (VAExpansion o generatedSrcSpan generatedSrcSpan) + -- See Part 3. in Note [Expanding HsDo with XXExprGhcRn] + (EWrap (EExpand o) : args) -- in `GHC.Tc.Gen.Do` + + + | OrigPat (L loc _) <- o -- so that we set the compiler generated fail context + = go e (VAExpansion o (locA loc) (locA loc)) -- to be originating from a failable pattern + -- See Part 1. Wrinkle 2. of + (EWrap (EExpand o) : args) -- Note [Expanding HsDo with XXExprGhcRn] + -- in `GHC.Tc.Gen.Do` + + | otherwise + = go e (VAExpansion o (appCtxtLoc ctxt) (appCtxtLoc ctxt)) + (EWrap (EExpand o) : args) + + -- See Note [Desugar OpApp in the typechecker] + go e@(OpApp _ arg1 (L l op) arg2) _ args + = 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 ) + + go e ctxt args = pure ((e,ctxt), args) + + set :: EpAnn ann -> AppCtxt -> AppCtxt + set l (VACall f n _) = VACall f n (locA l) + set l (VAExpansion orig ol _) = VAExpansion orig ol (locA l) + + dec :: EpAnn ann -> AppCtxt -> AppCtxt + dec l (VACall f n _) = VACall f (n-1) (locA l) + dec l (VAExpansion orig ol _) = VAExpansion orig ol (locA l) + +-- | Rebuild an application: takes a type-checked application head +-- expression together with arguments in the form of typechecked 'HsExprArg's +-- and returns a typechecked application of the head to the arguments. +-- +-- This performs a representation-polymorphism check to ensure that +-- representation-polymorphic unlifted newtypes have been eta-expanded. +-- +-- See Note [Eta-expanding rep-poly unlifted newtypes]. +rebuildHsApps :: (HsExpr GhcTc, AppCtxt) + -- ^ the function being applied + -> [HsExprArg 'TcpTc] + -- ^ the arguments to the function + -> HsExpr GhcTc +rebuildHsApps (fun, _) [] = fun +rebuildHsApps (fun, ctxt) (arg : args) + = case arg of + 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 + -> rebuildHsApps (HsPragE noExtField p lfun, ctxt') args + EWrap (EPar ctxt') + -> rebuildHsApps (gHsPar lfun, ctxt') args + EWrap (EExpand orig) + | OrigExpr oe <- orig + -> rebuildHsApps (mkExpandedExprTc oe fun, ctxt) args + | otherwise + -> rebuildHsApps (fun, ctxt) args + EWrap (EHsWrap wrap) + -> rebuildHsApps (mkHsWrap wrap fun, ctxt) args + where + lfun = L (noAnnSrcSpan $ appCtxtLoc' ctxt) fun + appCtxtLoc' (VAExpansion _ _ l) = l + appCtxtLoc' v = appCtxtLoc v + + +isHsValArg :: HsExprArg id -> Bool +isHsValArg (EValArg {}) = True +isHsValArg _ = False + +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 +isValArg _ = False + +isVisibleArg :: HsExprArg id -> Bool +isVisibleArg (EValArg {}) = True +isVisibleArg (ETypeArg {}) = True +isVisibleArg _ = False + +instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where + 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 + +{- Note [Desugar OpApp in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Operator sections are desugared in the renamer; see GHC.Rename.Expr +Note [Handling overloaded and rebindable constructs]. +But for reasons explained there, we rename OpApp to OpApp. Then, +here in the typechecker, we desugar it to a use of ExpandedThingRn. +That makes it possible to typecheck something like + e1 `f` e2 +where + f :: forall a. t1 -> forall b. t2 -> t3 + +Note [Looking through ExpandedThingRn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When creating an application chain in splitHsApps, we must deal with + ExpandedThingRn f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3 + +as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded +labels (#19154) won't work. + +It's easy to achieve this: `splitHsApps` unwraps `ExpandedThingRn`. + +In order to be able to more accurately reconstruct the original `SrcSpan`s +from the renamer in `rebuildHsApps`, we also have to track the `SrcSpan` +of the current application in `VAExpansion` when unwrapping `ExpandedThingRn` +in `splitHsApps`, just as we track it in a non-expanded expression. + +Previously, `rebuildHsApps` substituted the location of the original +expression as given by `splitHsApps` for this. As a result, the application +head in expanded expressions, e.g. the call to `fromListN`, would either +have `noSrcSpan` set as its location post-typecheck, or get the location +of the original expression, depending on whether the `XExpr` given to +`splitHsApps` is in the outermost layer. The span it got in the renamer +would always be discarded, causing #23120. + +Note [Looking through Template Haskell splices in splitHsApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking an application, we must look through untyped TH splices in +order to typecheck examples like the one in #21077: + + data Foo = MkFoo () (forall a. a -> a) + + foo :: Foo + foo = $([| MkFoo () |]) $ \x -> x + +In principle, this is straightforward to accomplish. By the time we typecheck +`foo`, the renamer will have already run the splice, so all we have to do is +look at the expanded version of the splice in `splitHsApps`. See the +`HsUntypedSplice` case in `splitHsApps` for how this is accomplished. + +There is one slight complication in that untyped TH splices also include +modFinalizers (see Note [Delaying modFinalizers in untyped splices] in +GHC.Rename.Splice), which must be run during typechecking. splitHsApps is a +convenient place to run the modFinalizers, so we do so there. This is the only +reason that `splitHsApps` uses the TcM monad. + +`HsUntypedSplice` covers both ordinary TH splices, such as the example above, +as well as quasiquotes (see Note [Quasi-quote overview] in +Language.Haskell.Syntax.Expr). The `splitHsApps` case for `HsUntypedSplice` +handles both of these. This is easy to accomplish, since all the real work in +handling splices and quasiquotes has already been performed by the renamer by +the time we get to `splitHsApps`. + +Wrinkle (UTS1): + `tcExpr` has a separate case for `HsUntypedSplice`s that do /not/ occur at the + head of an application. This is important to handle programs like this one: + + foo :: (forall a. a -> a) -> b -> b + foo = $([| \g x -> g x |]) + + Here, it is vital that we push the expected type inwards so that `g` gets the + type `forall a. a -> a`, and the `tcExpr` case for `HsUntypedSplice` performs + this pushing. Without it, we would instead infer `g` to have type `b -> b`, + which isn't sufficiently general. Unfortunately, this does mean that there are + two different places in the code where an `HsUntypedSplice`'s modFinalizers can + be ran, depending on whether the splice appears at the head of an application + or not. +-} + +{- ********************************************************************* +* * + tcInferAppHead +* * +********************************************************************* -} + +tcInferAppHead :: (HsExpr GhcRn, AppCtxt) + -> TcM (HsExpr GhcTc, TcSigmaType) +-- Infer type of the head of an application +-- i.e. the 'f' in (f e1 ... en) +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +-- We get back a /SigmaType/ because we have special cases for +-- * A bare identifier (just look it up) +-- This case also covers a record selector HsRecSel +-- * An expression with a type signature (e :: ty) +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +-- +-- Note that [] and (,,) are both HsVar: +-- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr +-- +-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those +-- cases are dealt with by splitHsApps. +-- +-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App +tcInferAppHead (fun,ctxt) + = addHeadCtxt ctxt $ + do { mb_tc_fun <- tcInferAppHead_maybe fun + ; case mb_tc_fun of + Just (fun', fun_sigma) -> return (fun', fun_sigma) + Nothing -> runInferRho (tcExpr fun) } + +tcInferAppHead_maybe :: HsExpr GhcRn + -> TcM (Maybe (HsExpr GhcTc, TcSigmaType)) +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +-- Returns Nothing for a complicated head +tcInferAppHead_maybe fun + = case fun of + HsVar _ nm -> Just <$> tcInferId nm + XExpr (HsRecSelRn f) -> Just <$> tcInferRecSelId f + ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty + HsOverLit _ lit -> Just <$> tcInferOverLit lit + _ -> return Nothing + +addHeadCtxt :: AppCtxt -> TcM a -> TcM a +addHeadCtxt (VAExpansion (OrigStmt (L loc stmt)) _ _) thing_inside = + do setSrcSpanA loc $ + addStmtCtxt stmt + thing_inside +addHeadCtxt fun_ctxt thing_inside + | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments + = thing_inside -- => context is already set + | otherwise + = setSrcSpan fun_loc $ + do case fun_ctxt of + VAExpansion (OrigExpr orig) _ _ -> addExprCtxt orig thing_inside + _ -> thing_inside + where + fun_loc = appCtxtLoc fun_ctxt + + +{- ********************************************************************* +* * + Record selectors +* * +********************************************************************* -} + +tcInferRecSelId :: FieldOcc GhcRn + -> 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 = 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 + tc_rec_sel_id + = do { thing <- tcLookup sel_name + ; case thing of + ATcId { tct_id = id } + -> do { check_naughty occ id -- See Note [Local record selectors] + ; check_local_id id + ; return id } + + AGlobal (AnId id) + -> do { check_naughty occ id + ; return id } + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- hence no checkTh stuff here + + _ -> failWithTc $ TcRnExpectedValueId thing } + +------------------------ + +-- A type signature on the argument of an ambiguous record selector or +-- the record expression in an update must be "obvious", i.e. the +-- outermost constructor ignoring parentheses. +obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn) +obviousSig (ExprWithTySig _ _ ty) = Just ty +obviousSig (HsPar _ p) = obviousSig (unLoc p) +obviousSig (HsPragE _ _ p) = obviousSig (unLoc p) +obviousSig _ = Nothing + +-- Extract the outermost TyCon of a type, if there is one; for +-- data families this is the representation tycon (because that's +-- where the fields live). +tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon +tyConOf fam_inst_envs ty0 + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys)) + Nothing -> Nothing + where + (_, _, ty) = tcSplitSigmaTy ty0 + +-- Variant of tyConOf that works for ExpTypes +tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon +tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0 + +{- ********************************************************************* +* * + Expressions with a type signature + expr :: type +* * +********************************************************************* -} + +tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn) + -> TcM (HsExpr GhcTc, TcSigmaType) +tcExprWithSig expr hs_ty + = do { sig_info <- checkNoErrs $ -- Avoid error cascade + tcUserTypeSig loc hs_ty Nothing + ; (expr', poly_ty) <- tcExprSig expr sig_info + ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } + where + loc = getLocA (dropWildCards hs_ty) + +tcExprSig :: LHsExpr GhcRn -> TcIdSig -> TcM (LHsExpr GhcTc, TcSigmaType) +tcExprSig expr (TcCompleteSig sig) + = do { expr' <- tcPolyLExprSig expr sig + ; return (expr', idType (sig_bndr sig)) } + +tcExprSig expr sig@(TcPartialSig (PSig { psig_name = name, psig_loc = loc })) + = setSrcSpan loc $ -- Sets the location for the implication constraint + do { (tclvl, wanted, (expr', sig_inst)) + <- pushLevelAndCaptureConstraints $ + do { sig_inst <- tcInstSig sig + ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ + tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ + tcCheckPolyExprNC expr (sig_inst_tau sig_inst) + ; return (expr', sig_inst) } + -- See Note [Partial expression signatures] + ; let tau = sig_inst_tau sig_inst + infer_mode | null (sig_inst_theta sig_inst) + , isNothing (sig_inst_wcx sig_inst) + = ApplyMR + | otherwise + = NoRestrictions + ; ((qtvs, givens, ev_binds, _), residual) + <- captureConstraints $ + simplifyInfer NotTopLevel tclvl infer_mode [sig_inst] [(name, tau)] wanted + ; emitConstraints residual + + ; tau <- liftZonkM $ zonkTcType tau + ; let inferred_theta = map evVarPred givens + tau_tvs = tyCoVarsOfType tau + ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta + tau_tvs qtvs (Just sig_inst) + ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau + my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) + ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. + then return idHsWrapper -- Fast path; also avoids complaint when we infer + -- an ambiguous type and have AllowAmbiguousType + -- e..g infer x :: forall a. F a -> Int + else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma + + ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) + ; let poly_wrap = wrap + <.> mkWpTyLams qtvs + <.> mkWpEvLams givens + <.> mkWpLet ev_binds + ; return (mkLHsWrap poly_wrap expr', my_sigma) } + + +{- Note [Partial expression signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial type signatures on expressions are easy to get wrong. But +here is a guiding principle + e :: ty +should behave like + let x :: ty + x = e + in x + +So for partial signatures we apply the MR if no context is given. So + e :: IO _ apply the MR + e :: _ => IO _ do not apply the MR +just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan + +This makes a difference (#11670): + peek :: Ptr a -> IO CLong + peek ptr = peekElemOff undefined 0 :: _ +from (peekElemOff undefined 0) we get + type: IO w + constraints: Storable w + +We must NOT try to generalise over 'w' because the signature specifies +no constraints so we'll complain about not being able to solve +Storable w. Instead, don't generalise; then _ gets instantiated to +CLong, as it should. +-} + + +{- ********************************************************************* +* * + Overloaded literals +* * +********************************************************************* -} + +tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferOverLit lit@(OverLit { ol_val = val + , ol_ext = OverLitRn { ol_rebindable = rebindable + , ol_from_fun = L loc from_name } }) + = -- Desugar "3" to (fromInteger (3 :: Integer)) + -- where fromInteger is gotten by looking up from_name, and + -- the (3 :: Integer) is returned by mkOverLit + -- Ditto the string literal "foo" to (fromString ("foo" :: String)) + -- + -- See Note [Typechecking overloaded literals] in GHC.Tc.Gen.Expr + do { hs_lit <- mkOverLit val + ; from_id <- tcLookupId from_name + ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id) + ; let + thing = NameThing from_name + mb_thing = Just thing + herald = ExpectedFunTyArg thing (HsLit noExtField hs_lit) + ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty + + ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) + -- See Note [Source locations for implicit function calls] in GHC.Iface.Ext.Ast + ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ + HsLit noExtField hs_lit + from_expr = mkHsWrap (wrap2 <.> wrap1) $ + mkHsVar (L loc from_id) + witness = HsApp noExtField (L (l2l loc) from_expr) lit_expr + lit' = OverLit { ol_val = val + , ol_ext = OverLitTc { ol_rebindable = rebindable + , ol_witness = witness + , ol_type = res_ty } } + ; return (HsOverLit noExtField lit', res_ty) } + +{- ********************************************************************* +* * + tcInferId, tcCheckId +* * +********************************************************************* -} + +tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc) +tcCheckId name res_ty + = do { (expr, actual_res_ty) <- tcInferId (noLocA $ noUserRdr name) + ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) + ; addFunResCtxt expr [] actual_res_ty res_ty $ + tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty } + where + rn_fun = mkHsVar (noLocA name) + +------------------------ +tcInferId :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType) +-- Look up an occurrence of an Id +-- Do not instantiate its type +tcInferId lname@(L loc (WithUserRdr rdr id_name)) + + | id_name `hasKey` assertIdKey + = -- See Note [Overview of assertions] + do { dflags <- getDynFlags + ; if gopt Opt_IgnoreAsserts dflags + then tc_infer_id lname + else tc_infer_id (L loc $ WithUserRdr rdr assertErrorName) } + + | otherwise + = tc_infer_id lname + +tc_infer_id :: LocatedN (WithUserRdr Name) -> TcM (HsExpr GhcTc, TcSigmaType) +tc_infer_id (L loc (WithUserRdr rdr id_name)) + = do { thing <- tcLookup id_name + ; (expr,ty) <- case thing of + ATcId { tct_id = id } + -> do { check_local_id id + ; return_id id } + + AGlobal (AnId id) -> return_id id + -- A global cannot possibly be ill-staged + -- nor does it need the 'lifting' treatment + -- Hence no checkTh stuff here + + AGlobal (AConLike cl) -> tcInferConLike cl + + (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Term (WithUserRdr rdr (tyConName tc)) + ATyVar name _ -> failIllegalTyVar (WithUserRdr rdr name) + + _ -> failWithTc $ TcRnExpectedValueId thing + + ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty) + ; return (expr, ty) } + where + return_id id = return (mkHsVar (L loc id), idType id) + +{- Note [Overview of assertions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you write (assert pred x) then + + * If `-fignore-asserts` (which sets Opt_IgnoreAsserts) is on, the code is + typechecked as written, but `assert`, defined in GHC.Internal.Base + assert _pred r = r + simply ignores `pred` + + * But without `-fignore-asserts`, GHC rewrites it to (assertError pred e) + and that is defined in GHC.Internal.IO.Exception as + assertError :: (?callStack :: CallStack) => Bool -> a -> a + which does test the predicate and, if it is not True, throws an exception, + capturing the CallStack. + + This rewrite is done in `tcInferId`. + +So `-fignore-asserts` makes the assertion go away altogether, which may be good for +production code. + +The reason that `assert` and `assertError` are defined in very different modules +is a historical accident. + +Note: the Haddock for `assert` is on `GHC.Internal.Base.assert`, since that is +what appears in the user's source proram. + +It's not entirely kosher to rewrite `assert` to `assertError`, because there's no +way to "undo" if you want to see the original source code in the typechecker +output. We can fix this if it becomes a problem. + +Note [Suppress hints with RequiredTypeArguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a type variable is used at the term level, GHC assumes the user might +have made a typo and suggests a term variable with a similar name. + +For example, if the user writes + f (Proxy :: Proxy nap) (Proxy :: Proxy gap) = nap (+1) [1,2,3] +then GHC will helpfully suggest `map` instead of `nap` + • Illegal term-level use of the type variable ‘nap’ + • Perhaps use ‘map’ (imported from Prelude) + +Importantly, GHC does /not/ suggest `gap`, which is in scope. +Question: How does GHC know not to suggest `gap`? After all, the edit distance + between `map`, `nap`, and `gap` is equally short. +Answer: GHC takes the namespace into consideration. `gap` is a `tvName`, and GHC + would only suggest a `varName` at the term level. + +In other words, the current hint infrastructure assumes that the namespace of an +entity is a reliable indicator of its level + term-level name <=> term-level entity + type-level name <=> type-level entity + +With RequiredTypeArguments, this assumption does not hold. Consider + bad :: forall a b -> ... + bad nap gap = nap + +This use of `nap` on the RHS is illegal because `nap` stands for a type +variable. It cannot be returned as the result of a function. At the same time, +it is bound as a `varName`, i.e. in the term-level namespace. + +Unless we suppress hints, GHC gets awfully confused + • Illegal term-level use of the variable ‘nap’ + • Perhaps use one of these: + ‘nap’ (line 2), ‘gap’ (line 2), ‘map’ (imported from Prelude) + +GHC shouldn't suggest `gap`, which is also a type variable; using it would +result in the same error. And it especially shouldn't suggest using `nap` +instead of `nap`, which is absurd. + +The proper solution is to overhaul the hint system to consider what a name +stands for instead of looking at its namespace alone. This is tracked in #24231. +As a temporary measure, we avoid those potentially misleading hints by +suppressing them entirely if RequiredTypeArguments is in effect. +-} + +check_local_id :: Id -> TcM () +check_local_id id + = do { tcEmitBindingUsage $ singleUsageUE id } + +check_naughty :: OccName -> TcId -> TcM () +check_naughty lbl id + | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl) + | otherwise = return () + +tcInferConLike :: ConLike -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferConLike (RealDataCon con) = tcInferDataCon con +tcInferConLike (PatSynCon ps) = tcInferPatSyn ps + +tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) +-- See Note [Typechecking data constructors] +tcInferDataCon con + = do { let tvbs = dataConUserTyVarBinders con + tvs = binderVars tvbs + theta = dataConOtherTheta con + args = dataConOrigArgTys con + res = dataConOrigResTy con + stupid_theta = dataConStupidTheta con + + ; scaled_arg_tys <- mapM linear_to_poly args + + ; let full_theta = stupid_theta ++ theta + all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys + -- We are building the type of the data con wrapper, so the + -- type must precisely match the construction in + -- GHC.Core.DataCon.dataConWrapperType. + -- See Note [Instantiating stupid theta] + -- in GHC.Core.DataCon. + + ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys) + , mkForAllTys tvbs $ mkPhiTy full_theta $ + mkScaledFunTys scaled_arg_tys res ) } + where + linear_to_poly :: Scaled Type -> TcM (Scaled Type) + -- linear_to_poly implements point (3,4) + -- of Note [Typechecking data constructors] + linear_to_poly (Scaled OneTy ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy + ; return (Scaled mul_var ty) } + linear_to_poly scaled_ty = return scaled_ty + +tcInferPatSyn :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferPatSyn ps + = case patSynBuilderOcc ps of + Just (expr,ty) -> return (expr,ty) + Nothing -> failWithTc (nonBidirectionalErr (patSynName ps)) + +nonBidirectionalErr :: Name -> TcRnMessage +nonBidirectionalErr = TcRnPatSynNotBidirectional + +{- Note [Typechecking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As per Note [Polymorphisation of linear fields] in +GHC.Core.Multiplicity, linear fields of data constructors get a +polymorphic multiplicity when the data constructor is used as a term: + + Just :: forall {p} a. a %p -> Maybe a + +So at an occurrence of a data constructor we do the following: + +1. Typechecking, in tcInferDataCon. + + a. Get the original type of the constructor, say + K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a + Note the %1: it is linear + + b. We are going to return a ConLikeTc, thus: + XExpr (ConLikeTc K [r,a] [Scaled p a]) + :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a + where 'p' is a fresh multiplicity unification variable. + + To get the returned ConLikeTc, we allocate a fresh multiplicity + variable for each linear argument, and store the type, scaled by + the fresh multiplicity variable in the ConLikeTc; along with + the type of the ConLikeTc. This is done by linear_to_poly. + + If the argument is not linear (perhaps explicitly declared as + non-linear by the user), don't bother with this. + +2. Desugaring, in dsConLike. + + a. The (ConLikeTc K [r,a] [Scaled p a]) is desugared to + (/\r (a :: TYPE r). \(x %p :: a). K @r @a x) + which has the desired type given in the previous bullet. + + The 'p' is the multiplicity unification variable, which + will by now have been unified to something, or defaulted in + `GHC.Tc.Zonk.Type.commitFlexi`. So it won't just be an + (unbound) variable. + + So a saturated application (K e), where e::Int will desugar to + (/\r (a :: TYPE r). ..etc..) + @LiftedRep @Int e + and all those lambdas will beta-reduce away in the simple optimiser + (see Wrinkle [Representation-polymorphic lambdas] below). + + But for an /unsaturated/ application, such as `map (K @LiftedRep @Int) xs`, + beta reduction will leave (\x %Many :: Int. K x), which is the type `map` + expects whereas if we had just plain K, with its linear type, we'd + get a type mismatch. That's why we do this funky desugaring. + +Wrinkles + + [ConLikeTc arguments] + + Note that the [TcType] argument to ConLikeTc is strictly redundant; those are + the type variables from the dataConUserTyVarBinders of the data constructor. + Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly + from the data constructor. The only bit that /isn't/ redundant is the + fresh multiplicity variables! + + So an alternative would be to define ConLikeTc like this: + | ConLikeTc [TcType] -- Just the multiplicity variables + But then the desugarer would need to repeat some of the work done here. + So for now at least ConLikeTc records this strictly-redundant info. + + [Representation-polymorphic lambdas] + + The lambda expression we produce in (4) can have representation-polymorphic + arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x), + we have a lambda-bound variable x :: (a :: TYPE r). + This goes against the representation polymorphism invariants given in + Note [Representation polymorphism invariants] in GHC.Core. The trick is that + this this lambda will always be instantiated in a way that upholds the invariants. + This is achieved as follows: + + A. Any arguments to such lambda abstractions are guaranteed to have + a fixed runtime representation. This is enforced in 'tcApp' by + 'matchActualFunTy'. + + B. If there are fewer arguments than there are bound term variables, + we will ensure that the appropriate type arguments are instantiated + concretely, such as 'r' in + + ( /\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.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 + pass, we switch off Lint's representation-polymorphism checks; see + the `lf_check_fixed_rep` flag in `LintFlags`. +-} + +{- +************************************************************************ +* * + Template Haskell checks +* * +************************************************************************ +-} + + +{- +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.hs + +Note [Local record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record selectors for TyCons in this module are ordinary local bindings, +which show up as ATcIds rather than AGlobals. So we need to check for +naughtiness in both branches. c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds. + +Note [Explicit Level Imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the overview note which explains the whole implementation of ExplicitLevelImports + +GHC Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0682-explicit-level-imports.rst +Paper: https://mpickering.github.io/papers/explicit-level-imports.pdf + +The feature is turned on by the `ExplicitLevelImports` extension. +At the source level, the user marks imports with `quote` or `splice` to introduce +them at level 1 or -1. + +The function GHC.Tc.Utils.Monad.getCurrentAndBindLevel. computes the levels +at which a Name is available: + - for top-level Names, this information is stored in its GRE; it is either local + (level 0) or imported, in which case the levels it is imported at are stored in the + 'ImpDeclSpec's for the GRE. The function 'greLevels' retrieves this information. + - for locally-bound Names, this information is stored in the ThBindEnv. +GHC.Rename.Splice.checkCrossLevelLifting checks that levels in user-written programs +are correct. + +Instances are checked by `checkWellLevelledDFun`, which computes the level of an +instance by calling `checkWellLevelledInstanceWhat`, which sees what is available at by looking at the module graph. + +That's it for the main implementation of the feature; the rest is modifications +to the driver parts of the code to use this information. For example, in downsweep, +we only enable code generation for modules needed at the runtime stage. +See Note [-fno-code mode]. + +-} + + +{- ********************************************************************* +* * + Error reporting for function result mis-matches +* * +********************************************************************* -} + +addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] + -> TcType -> ExpRhoType + -> TcM a -> TcM a +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +-- But not in generated code, where we don't want +-- to mention internal (rebindable syntax) function names +addFunResCtxt fun args fun_res_ty env_ty thing_inside + = do { env_tv <- newFlexiTyVarTy liftedTypeKind + ; dumping <- doptM Opt_D_dump_tc_trace + ; addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg dumping env_tv) thing_inside } + -- NB: use a landmark error context, so that an empty context + -- doesn't suppress some more useful context + where + mk_msg dumping env_tv + = do { mb_env_ty <- readExpType_maybe env_ty + -- by the time the message is rendered, the ExpType + -- will be filled in (except if we're debugging) + ; fun_res' <- zonkTcType fun_res_ty + ; env' <- case mb_env_ty of + Just env_ty -> zonkTcType env_ty + Nothing -> do { massert dumping; return env_tv } + ; let -- See Note [Splitting nested sigma types in mismatched + -- function types] + (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res' + (_, _, env_tau) = tcSplitNestedSigmaTys env' + -- env_ty is an ExpRhoTy, but with simple subsumption it + -- is not deeply skolemised, so still use tcSplitNestedSigmaTys + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + info = + FunResCtxt fun (count isValArg args) res_fun res_env + (length args_fun) (length args_env) + ; return info } + + +{- +Note [Splitting nested sigma types in mismatched function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When one applies a function to too few arguments, GHC tries to determine this +fact if possible so that it may give a helpful error message. It accomplishes +this by checking if the type of the applied function has more argument types +than supplied arguments. + +Previously, GHC computed the number of argument types through tcSplitSigmaTy. +This is incorrect in the face of nested foralls, however! +This caused Ticket #13311, for instance: + + f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b + +If one uses `f` like so: + + do { f; putChar 'a' } + +Then tcSplitSigmaTy will decompose the type of `f` into: + + Tyvars: [a] + Context: (Monoid a) + Argument types: [] + Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b + +That is, it will conclude that there are *no* argument types, and since `f` +was given no arguments, it won't print a helpful error message. On the other +hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to: + + Tyvars: [a, b] + Context: (Monoid a, Monoid b) + Argument types: [Int, Maybe a] + Return type: Maybe b + +So now GHC recognizes that `f` has one more argument type than it was actually +provided. + +Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless +of simple/deep subsumption. Here we are concerned only whether there is a +mis-match in the number of value arguments. +-} + + +{- ********************************************************************* +* * + Misc utility functions +* * +********************************************************************* -} + +addStmtCtxt :: ExprStmt GhcRn -> TcRn a -> TcRn a +addStmtCtxt stmt = + addErrCtxt (StmtErrCtxt (HsDoStmt (DoExpr Nothing)) stmt) + +addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a +addExprCtxt e thing_inside + = case e of + HsHole _ -> thing_inside + _ -> addErrCtxt (ExprCtxt e) thing_inside + -- The HsHole special case addresses situations like + -- f x = _ + -- when we don't want to say "In the expression: _", + -- because it is mentioned in the error message itself diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs --- a/GHC/Tc/Gen/HsType.hs +++ b/GHC/Tc/Gen/HsType.hs @@ -7,4495 +7,4777 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecursiveDo #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - --- | Typechecking user-specified @MonoTypes@ -module GHC.Tc.Gen.HsType ( - -- Type signatures - kcClassSigType, tcClassSigType, - tcHsSigType, tcHsSigWcType, - tcHsPartialSigType, - tcStandaloneKindSig, - funsSigCtxt, addSigCtxt, pprSigCtxt, - - tcHsClsInstType, - tcHsDeriv, tcDerivStrategy, - tcHsTypeApp, - UserTypeCtxt(..), - bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, - bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, - bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, - bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, - - bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs, - tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs, - bindOuterSigTKBndrs_Tv, - tcExplicitTKBndrs, - bindNamedWildCardBinders, - - -- Type checking type and class decls, and instances thereof - bindTyClTyVars, bindTyClTyVarsAndZonk, - tcFamTyPats, - etaExpandAlgTyCon, tcbVisibilities, - - -- tyvars - zonkAndScopedSort, - - -- Kind-checking types - -- No kind generalisation, no checkValidType - InitialKindStrategy(..), - SAKS_or_CUSK(..), - ContextKind(..), - kcDeclHeader, checkForDuplicateScopedTyVars, - tcHsLiftedType, tcHsOpenType, - tcHsLiftedTypeNC, tcHsOpenTypeNC, - tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, - tcCheckLHsType, - tcHsContext, tcLHsPredType, - - kindGeneralizeAll, - - -- Sort-checking kinds - tcLHsKindSig, checkDataKindSig, DataSort(..), - checkClassKindSig, - - -- Multiplicity - tcMult, - - -- Pattern type signatures - tcHsPatSigType, - HoleMode(..), - - -- Error messages - funAppCtxt, addTyConFlavCtxt - ) where - -import GHC.Prelude hiding ( head, init, last, tail ) - -import GHC.Hs -import GHC.Rename.Utils -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Types.Origin -import GHC.Tc.Types.LclEnv -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcMType -import GHC.Tc.Validity -import GHC.Tc.Utils.Unify -import GHC.IfaceToCore -import GHC.Tc.Solver -import GHC.Tc.Zonk.Type -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, - tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs, - tcInstTypeBndrs ) -import GHC.Tc.Zonk.TcType - -import GHC.Core.Type -import GHC.Core.Predicate -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr - -import GHC.Builtin.Types.Prim -import GHC.Types.Error -import GHC.Types.Name.Env -import GHC.Types.Name.Reader( lookupLocalRdrOcc ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Class -import GHC.Types.Name -import GHC.Types.Var.Env -import GHC.Builtin.Types -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Utils.Misc -import GHC.Types.Unique.Supply -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Builtin.Names hiding ( wildCardName ) -import GHC.Driver.DynFlags -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.FastString -import GHC.Data.List.Infinite ( Infinite (..) ) -import qualified GHC.Data.List.Infinite as Inf -import GHC.Data.List.SetOps -import GHC.Data.Maybe -import GHC.Data.Bag( unitBag ) - -import Data.Function ( on ) -import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) -import qualified Data.List.NonEmpty as NE -import Data.List ( mapAccumL ) -import Control.Monad -import Data.Tuple( swap ) - -{- - ---------------------------- - General notes - ---------------------------- - -Unlike with expressions, type-checking types both does some checking and -desugars at the same time. This is necessary because we often want to perform -equality checks on the types right away, and it would be incredibly painful -to do this on un-desugared types. Luckily, desugared types are close enough -to HsTypes to make the error messages sane. - -During type-checking, we perform as little validity checking as possible. -Generally, after type-checking, you will want to do validity checking, say -with GHC.Tc.Validity.checkValidType. - -Validity checking -~~~~~~~~~~~~~~~~~ -Some of the validity check could in principle be done by the kind checker, -but not all: - -- During desugaring, we normalise by expanding type synonyms. Only - after this step can we check things like type-synonym saturation - e.g. type T k = k Int - type S a = a - Then (T S) is ok, because T is saturated; (T S) expands to (S Int); - and then S is saturated. This is a GHC extension. - -- Similarly, also a GHC extension, we look through synonyms before complaining - about the form of a class or instance declaration - -- Ambiguity checks involve functional dependencies - -Also, in a mutually recursive group of types, we can't look at the TyCon until we've -finished building the loop. So to keep things simple, we postpone most validity -checking until step (3). - -%************************************************************************ -%* * - Check types AND do validity checking -* * -************************************************************************ - -Note [Keeping implicitly quantified variables in order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user implicitly quantifies over variables (say, in a type -signature), we need to come up with some ordering on these variables. -This is done by bumping the TcLevel, bringing the tyvars into scope, -and then type-checking the thing_inside. The constraints are all -wrapped in an implication, which is then solved. Finally, we can -zonk all the binders and then order them with scopedSort. - -It's critical to solve before zonking and ordering in order to uncover -any unifications. You might worry that this eager solving could cause -trouble elsewhere. I don't think it will. Because it will solve only -in an increased TcLevel, it can't unify anything that was mentioned -elsewhere. Additionally, we require that the order of implicitly -quantified variables is manifest by the scope of these variables, so -we're not going to learn more information later that will help order -these variables. - -Note [Recipe for checking a signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind-checking a user-written signature requires several steps: - - 0. Bump the TcLevel - 1. Bind any lexically-scoped type variables. - 2. Generate constraints. - 3. Solve constraints. - 4. Sort any implicitly-bound variables into dependency order - 5. Promote tyvars and/or kind-generalize. - 6. Zonk. - 7. Check validity. - -Very similar steps also apply when kind-checking a type or class -declaration. - -The general pattern looks something like this. (But NB every -specific instance varies in one way or another!) - - do { (tclvl, wanted, (spec_tkvs, ty)) - <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ - bindImplicitTKBndrs_Skol sig_vars $ - - - ; spec_tkvs <- zonkAndScopedSort spec_tkvs - - ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted - - ; let ty1 = mkSpecForAllTys spec_tkvs ty - ; kvs <- kindGeneralizeAll ty1 - - ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) - - ; checkValidType final_ty - -This pattern is repeated many times in GHC.Tc.Gen.HsType, -GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations. In more detail: - -* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel, - calls the thing inside to generate constraints, solves those - constraints as much as possible, returning the residual unsolved - constraints in 'wanted'. - -* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type - variables E.g. when kind-checking f :: forall a. F a -> a we must - bring 'a' into scope before kind-checking (F a -> a) - -* zonkAndScopedSort (Step 4) puts those user-specified variables in - the dependency order. (For "implicit" variables the order is no - user-specified. E.g. forall (a::k1) (b::k2). blah k1 and k2 are - implicitly brought into scope. - -* reportUnsolvedEqualities (Step 3 continued) reports any unsolved - equalities, carefully wrapping them in an implication that binds the - skolems. We can't do that in pushLevelAndSolveEqualitiesX because - that function doesn't have access to the skolems. - -* kindGeneralize (Step 5). See Note [Kind generalisation] - -* The final zonkTcTypeToType must happen after promoting/generalizing, - because promoting and generalizing fill in metavariables. - - -Doing Step 3 (constraint solving) eagerly (rather than building an -implication constraint and solving later) is necessary for several -reasons: - -* Exactly as for Solver.simplifyInfer: when generalising, we solve all - the constraints we can so that we don't have to quantify over them - or, since we don't quantify over constraints in kinds, float them - and inhibit generalisation. - -* Most signatures also bring implicitly quantified variables into - scope, and solving is necessary to get these in the right order - (Step 4) see Note [Keeping implicitly quantified variables in - order]). - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Step 5 of Note [Recipe for checking a signature], namely -kind-generalisation, is done by - kindGeneraliseAll - kindGeneraliseSome - kindGeneraliseNone - -Here, we have to deal with the fact that metatyvars generated in the -type will have a bumped TcLevel, because explicit foralls raise the -TcLevel. To avoid these variables from ever being visible in the -surrounding context, we must obey the following dictum: - - Every metavariable in a type must either be - (A) generalized, or - (B) promoted, or See Note [Promotion in signatures] - (C) a cause to error See Note [Naughty quantification candidates] - in GHC.Tc.Utils.TcMType - -There are three steps (look at kindGeneraliseSome): - -1. candidateQTyVarsOfType finds the free variables of the type or kind, - to generalise - -2. filterConstrainedCandidates filters out candidates that appear - in the unsolved 'wanteds', and promotes the ones that get filtered out - thereby. - -3. quantifyTyVars quantifies the remaining type variables - -The kindGeneralize functions do not require pre-zonking; they zonk as they -go. - -kindGeneraliseAll specialises for the case where step (2) is vacuous. -kindGeneraliseNone specialises for the case where we do no quantification, -but we must still promote. - -If you are actually doing kind-generalization, you need to bump the -level before generating constraints, as we will only generalize -variables with a TcLevel higher than the ambient one. -Hence the "pushLevel" in pushLevelAndSolveEqualities. - -Note [Promotion in signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If an unsolved metavariable in a signature is not generalized -(because we're not generalizing the construct -- e.g., pattern -sig -- or because the metavars are constrained -- see kindGeneralizeSome) -we need to promote to maintain (WantedInv) of Note [TcLevel invariants] -in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing -and the reinstantiating with a fresh metavariable at the current level. -So in some sense, we generalize *all* variables, but then re-instantiate -some of them. - -Here is an example of why we must promote: - foo (x :: forall a. a -> Proxy b) = ... - -In the pattern signature, `b` is unbound, and will thus be brought into -scope. We do not know its kind: it will be assigned kappa[2]. Note that -kappa is at TcLevel 2, because it is invented under a forall. (A priori, -the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel -than the surrounding context.) This kappa cannot be solved for while checking -the pattern signature (which is not kind-generalized). When we are checking -the *body* of foo, though, we need to unify the type of x with the argument -type of bar. At this point, the ambient TcLevel is 1, and spotting a -metavariable with level 2 would violate the (WantedInv) invariant of -Note [TcLevel invariants]. So, instead of kind-generalizing, -we promote the metavariable to level 1. This is all done in kindGeneralizeNone. - --} - -funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt --- Returns FunSigCtxt, with no redundant-context-reporting, --- form a list of located names -funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC -funsSigCtxt [] = panic "funSigCtxt" - -addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a -addSigCtxt ctxt hs_ty thing_inside - = setSrcSpan (getLocA hs_ty) $ - addErrCtxt (pprSigCtxt ctxt hs_ty) $ - thing_inside - -pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc --- (pprSigCtxt ctxt ) --- prints In the type signature for 'f': --- f :: --- The is either empty or "the ambiguity check for" -pprSigCtxt ctxt hs_ty - | Just n <- isSigMaybe ctxt - = hang (text "In the type signature:") - 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) - - | otherwise - = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) - 2 (ppr hs_ty) - -tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type --- This one is used when we have a LHsSigWcType, but in --- a place where wildcards aren't allowed. The renamer has --- already checked this, so we can simply ignore it. -tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) - -kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () --- This is a special form of tcClassSigType that is used during the --- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type. --- Importantly, this does *not* kind-generalize. Consider --- class SC f where --- meth :: forall a (x :: f a). Proxy x -> () --- When instantiating Proxy with kappa, we must unify kappa := f a. But we're --- still working out the kind of f, and thus f a will have a coercion in it. --- Coercions may block unification (Note [Equalities with incompatible kinds] in --- GHC.Tc.Solver.Equality, wrinkle (EIK2)) and so we fail to unify. If we try to --- kind-generalize, we'll end up promoting kappa to the top level (because --- kind-generalization is normally done right before adding a binding to the context), --- and then we can't set kappa := f a, because a is local. -kcClassSigType names - sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty })) - = addSigCtxt (funsSigCtxt names) sig_ty $ - do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs $ - tcLHsType hs_ty liftedTypeKind - ; return () } - -tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type --- Does not do validity checking -tcClassSigType names sig_ty - = addSigCtxt sig_ctxt sig_ty $ - do { skol_info <- mkSkolemInfo skol_info_anon - ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind) - ; emitImplication implic - ; return ty } - -- Do not zonk-to-Type, nor perform a validity check - -- We are in a knot with the class and associated types - -- Zonking and validity checking is done by tcClassDecl - -- - -- No need to fail here if the type has an error: - -- If we're in the kind-checking phase, the solveEqualities - -- in kcTyClGroup catches the error - -- If we're in the type-checking phase, the solveEqualities - -- in tcClassDecl1 gets it - -- Failing fast here degrades the error message in, e.g., tcfail135: - -- class Foo f where - -- baa :: f a -> f - -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. - -- It should be that f has kind `k2 -> *`, but we never get a chance - -- to run the solver where the kind of f is touchable. This is - -- painfully delicate. - where - sig_ctxt = funsSigCtxt names - skol_info_anon = SigTypeSkol sig_ctxt - -tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- Does validity checking --- See Note [Recipe for checking a signature] -tcHsSigType ctxt sig_ty - = addSigCtxt ctxt sig_ty $ - do { traceTc "tcHsSigType {" (ppr sig_ty) - ; skol_info <- mkSkolemInfo skol_info - -- Generalise here: see Note [Kind generalisation] - ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) - - -- Float out constraints, failing fast if not possible - -- See Note [Failure in local type signatures] in GHC.Tc.Solver - ; traceTc "tcHsSigType 2" (ppr implic) - ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic)) - - ; ty <- liftZonkM $ zonkTcType ty - ; checkValidType ctxt ty - ; traceTc "end tcHsSigType }" (ppr ty) - ; return ty } - where - skol_info = SigTypeSkol ctxt - -tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn - -> ContextKind -> TcM (Implication, TcType) --- Kind-checks/desugars an 'LHsSigType', --- solve equalities, --- and then kind-generalizes. --- This will never emit constraints, as it uses solveEqualities internally. --- No validity checking or zonking --- Returns also an implication for the unsolved constraints -tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs - , sig_body = hs_ty })) ctxt_kind - = setSrcSpanA loc $ - do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty))) - <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $ - -- See Note [Failure in local type signatures] - 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 - ; return (exp_kind, stuff) } - - -- Default any unconstrained variables free in the kind - -- See Note [Escaping kind in type signatures] - ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind - ; doNotQuantifyTyVars exp_kind_dvs (err_ctx exp_kind) - - ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) - ; outer_bndrs <- scopedSortOuter outer_bndrs - - ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs - ty1 = mkInvisForAllTys outer_tv_bndrs ty - ; kvs <- kindGeneralizeSome skol_info wanted ty1 - - -- Build an implication for any as-yet-unsolved kind equalities - -- See Note [Skolem escape in type signatures] - ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted - - ; return (implic, mkInfForAllTys kvs ty1) } - where - err_ctx exp_kind tidy_env - = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind - ; return (tidy_env2, UninfTyCtx_Sig exp_kind full_hs_ty) } - - - -{- Note [Escaping kind in type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider kind-checking the signature for `foo` (#19495): - type family T (r :: RuntimeRep) :: TYPE r - - foo :: forall (r :: RuntimeRep). T r - foo = ... - -We kind-check the type with expected kind `TYPE delta` (see newExpectedKind), -where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep` -because we allow signatures like `foo :: Int#`.) - -Suppose we are at level L currently. We do this - * pushLevelAndSolveEqualitiesX: moves to level L+1 - * newExpectedKind: allocates delta{L+1} - * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2} - * kind-check the body (T r) :: TYPE delta{L+1} - -Then -* We can't unify delta{L+1} with r{L+2}. - And rightly so: skolem would escape. - -* If delta{L+1} is unified with some-kind{L}, that is fine. - This can happen - \(x::a) -> let y :: a; y = x in ...(x :: Int#)... - Here (x :: a :: TYPE gamma) is in the environment when we check - the signature y::a. We unify delta := gamma, and all is well. - -* If delta{L+1} is unconstrained, we /must not/ quantify over it! - E.g. Consider f :: Any where Any :: forall k. k - We kind-check this with expected kind TYPE kappa. We get - Any @(TYPE kappa) :: TYPE kappa - We don't want to generalise to forall k. Any @k - because that is ill-kinded: the kind of the body of the forall, - (Any @k :: k) mentions the bound variable k. - - Instead we want to default it to LiftedRep. - - An alternative would be to promote it, similar to the monomorphism - restriction, but the MR is pretty confusing. Defaulting seems better - -How does that defaulting happen? Well, since we /currently/ default -RuntimeRep variables during generalisation, it'll happen in -kindGeneralize. But in principle we might allow generalisation over -RuntimeRep variables in future. Moreover, what if we had - kappa{L+1} := F alpha{L+1} -where F :: Type -> RuntimeRep. Now it's alpha that is free in the kind -and it /won't/ be defaulted. - -So we use doNotQuantifyTyVars to either default the free vars of -exp_kind (if possible), or error (if not). - -Note [Skolem escape in type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcHsSigType is tricky. Consider (T11142) - foo :: forall b. (forall k (a :: k). SameKind a b) -> () -This is ill-kinded because of a nested skolem-escape. - -That will show up as an un-solvable constraint in the implication -returned by buildTvImplication in tc_lhs_sig_type. See Note [Skolem -escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable -(the unification variable for b's kind is untouchable). - -Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType) -we'll try to float out the constraint, be unable to do so, and fail. -See GHC.Tc.Solver Note [Failure in local type signatures] for more -detail on this. - -The separation between tcHsSigType and tc_lhs_sig_type is because -tcClassSigType wants to use the latter, but *not* fail fast, because -there are skolems from the class decl which are in scope; but it's fine -not to because tcClassDecl1 has a solveEqualities wrapped around all -the tcClassSigType calls. - -That's why tcHsSigType does simplifyAndEmitFlatConstraints (which -fails fast) but tcClassSigType just does emitImplication (which does -not). Ugh. - -c.f. see also Note [Skolem escape and forall-types]. The difference -is that we don't need to simplify at a forall type, only at the -top level of a signature. --} - --- Does validity checking and zonking. -tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) -tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig)) - = addSigCtxt ctxt ksig $ - do { kind <- tc_top_lhs_type KindLevel ctxt ksig - ; checkValidType ctxt kind - ; return (name, kind) } - where - ctxt = StandaloneKindSigCtxt name - -tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -tcTopLHsType ctxt lsig_ty - = checkNoErrs $ -- Fail eagerly to avoid follow-on errors. We are at - -- top level so these constraints will never be solved later. - tc_top_lhs_type TypeLevel ctxt lsig_ty - -tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type --- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where --- we want to fully solve /all/ equalities, and report errors --- Does zonking, but not validity checking because it's used --- for things (like deriving and instances) that aren't --- ordinary types --- Used for both types and kinds -tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs - , sig_body = body })) - = setSrcSpanA loc $ - do { traceTc "tc_top_lhs_type {" (ppr sig_ty) - ; 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 } - - ; outer_bndrs <- scopedSortOuter outer_bndrs - ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs - ty1 = mkInvisForAllTys outer_tv_bndrs ty - - ; kvs <- kindGeneralizeAll skol_info ty1 -- "All" because it's a top-level type - ; reportUnsolvedEqualities skol_info kvs tclvl wanted - - ; final_ty <- initZonkEnv DefaultFlexi - $ zonkTcTypeToTypeX (mkInfForAllTys kvs ty1) - ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) - ; return final_ty } - 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 --- 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 - ; let (tvs, pred) = splitForAllTyCoVars ty - (kind_args, _) = splitFunTys (typeKind pred) - ; case getClassPredTys_maybe pred of - Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) - Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty } - --- | 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) - -- ^ The deriving strategy - -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar]) - -- ^ The typechecked deriving strategy and the tyvars that it binds - -- (if using 'ViaStrategy'). -tcDerivStrategy mb_lds - = case mb_lds of - Nothing -> boring_case Nothing - Just (L loc ds) -> - setSrcSpanA loc $ do - (ds', tvs) <- tc_deriv_strategy ds - pure (Just (L loc ds'), tvs) - where - tc_deriv_strategy :: DerivStrategy GhcRn - -> TcM (DerivStrategy GhcTc, [TyVar]) - tc_deriv_strategy (StockStrategy _) = boring_case (StockStrategy noExtField) - tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField) - tc_deriv_strategy (NewtypeStrategy _) = boring_case (NewtypeStrategy noExtField) - tc_deriv_strategy (ViaStrategy hs_sig) - = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty } - ; pure (ViaStrategy via_pred, via_tvs) } - - boring_case :: ds -> TcM (ds, [a]) - boring_case ds = pure (ds, []) - -tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt - -> LHsSigType GhcRn - -> TcM Type --- Like tcHsSigType, but for a class instance declaration -tcHsClsInstType user_ctxt hs_inst_ty - = setSrcSpan (getLocA hs_inst_ty) $ - do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty - ; checkValidInstance user_ctxt hs_inst_ty inst_ty - ; return inst_ty } - ----------------------------------------------- --- | Type-check a visible type application -tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type --- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType -tcHsTypeApp wc_ty kind - | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty - = do { mode <- mkHoleMode TypeLevel HM_VTA - -- HM_VTA: See Note [Wildcards in visible type application] - ; ty <- addTypeCtxt hs_ty $ - solveEqualities "tcHsTypeApp" $ - -- 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 - - -- We do not kind-generalize type applications: we just - -- instantiate with exactly what the user says. - -- See Note [No generalization in type application] - -- We still must call kindGeneralizeNone, though, according - -- to Note [Recipe for checking a signature] - ; kindGeneralizeNone ty - ; ty <- liftZonkM $ zonkTcType ty - ; checkValidType TypeAppCtxt ty - ; return ty } - -{- Note [Wildcards in visible type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 -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 -@_ to skip a instantiating a type variable variable without fuss. The -solution is to switch the PartialTypeSignatures flags here to let the -typechecker know that it's checking a '@_' and do not emit hole -constraints on it. See related Note [Wildcards in visible kind -application] and Note [The wildcard story for types] in GHC.Hs.Type - -Ugh! - -Note [No generalization in type application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not kind-generalize type applications. Imagine - - id @(Proxy Nothing) - -If we kind-generalized, we would get - - id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) - -which is very sneakily impredicative instantiation. - -There is also the possibility of mentioning a wildcard -(`id @(Proxy _)`), which definitely should not be kind-generalized. - --} - -tcFamTyPats :: TyCon - -> HsTyPats GhcRn -- Patterns - -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) --- Check the LHS of a type/data family instance --- e.g. type instance F ty1 .. tyn = ... --- Used for both type and data families -tcFamTyPats fam_tc hs_pats - = do { traceTc "tcFamTyPats {" $ - vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] - - ; mode <- mkHoleMode TypeLevel HM_FamPat - -- HM_FamPat: See Note [Wildcards in family instances] in - -- GHC.Rename.Module - ; let fun_ty = mkTyConApp fam_tc [] - ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats - - -- Hack alert: see Note [tcFamTyPats: zonking the result kind] - ; res_kind <- liftZonkM $ zonkTcType res_kind - - ; traceTc "End tcFamTyPats }" $ - vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] - - ; return (fam_app, res_kind) } - where - fam_name = tyConName fam_tc - fam_arity = tyConArity fam_tc - lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name)) - -{- Note [tcFamTyPats: zonking the result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#19250) - F :: forall k. k -> k - type instance F (x :: Constraint) = () - -The tricky point is this: - is that () an empty type tuple (() :: Type), or - an empty constraint tuple (() :: Constraint)? -We work this out in a hacky way, by looking at the expected kind: -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. - -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 -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 -that info when kind-checking the RHS. - -Easy solution: just zonk that return kind. Of course this won't help -if there is lots of type-family reduction to do, but it works fine in -common cases. --} - - -{- -************************************************************************ -* * - The main kind checker: no validity checks here -* * -************************************************************************ --} - ---------------------------- -tcHsOpenType, tcHsLiftedType, - tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType --- Used for type signatures --- Do not do validity checking -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 - --- Like tcHsType, but takes an expected kind -tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType -tcCheckLHsType hs_ty exp_kind - = addTypeCtxt hs_ty $ - do { ek <- newExpectedKind exp_kind - ; tcLHsType hs_ty ek } - -tcInferLHsType :: LHsType GhcRn -> TcM TcType -tcInferLHsType hs_ty - = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty - ; return ty } - -tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) --- Called from outside: set the context --- Eagerly instantiate any trailing invisible binders -tcInferLHsTypeKind lhs_ty@(L loc hs_ty) - = addTypeCtxt lhs_ty $ - setSrcSpanA loc $ -- Cover the tcInstInvisibleTyBinders - do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty - ; tcInstInvisibleTyBinders res_ty res_kind } - -- See Note [Do not always instantiate eagerly in types] - --- Used to check the argument of GHCi :kind --- Allow and report wildcards, e.g. :kind T _ --- Do not saturate family applications: see Note [Dealing with :kind] --- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types] -tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) -tcInferLHsTypeUnsaturated hs_ty - = addTypeCtxt hs_ty $ - do { mode <- mkHoleMode TypeLevel HM_Sig -- Allow and report holes - ; case splitHsAppTys (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 } - -- Notice the 'nosat'; do not instantiate trailing - -- invisible arguments of a type family. - -- See Note [Dealing with :kind] - Nothing -> tc_infer_lhs_type mode hs_ty } - -{- Note [Dealing with :kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GHCi command - ghci> type family F :: Either j k - ghci> :kind F - F :: forall {j,k}. Either j k - -We will only get the 'forall' if we /refrain/ from saturating those -invisible binders. But generally we /do/ saturate those invisible -binders (see tcInferTyApps), and we want to do so for nested application -even in GHCi. Consider for example (#16287) - ghci> type family F :: k - ghci> data T :: (forall k. k) -> Type - ghci> :kind T F -We want to reject this. It's just at the very top level that we want -to switch off saturation. - -So tcInferLHsTypeUnsaturated does a little special case for top level -applications. Actually the common case is a bare variable, as above. - -Note [Do not always instantiate eagerly in types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Terms are eagerly instantiated. This means that if you say - - 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. - -************************************************************************ -* * - Type-checking modes -* * -************************************************************************ - -The kind-checker is parameterised by a TcTyMode, which contains some -information about where we're checking a type. - -The renamer issues errors about what it can. All errors issued here must -concern things that the renamer can't handle. - --} - -tcMult :: HsArrow GhcRn -> TcM Mult -tcMult hc = tc_mult typeLevelMode hc - --- | Info about the context in which we're checking a type. Currently, --- differentiates only between types and kinds, but this will likely --- grow, at least to include the distinction between patterns and --- not-patterns. --- --- To find out where the mode is used, search for 'mode_tyki' --- --- This data type is purely local, not exported from this module -data TcTyMode - = TcTyMode { mode_tyki :: TypeOrKind - , mode_holes :: HoleInfo } - --- See Note [Levels for wildcards] --- Nothing <=> no wildcards expected -type HoleInfo = Maybe (TcLevel, HoleMode) - --- HoleMode says how to treat the occurrences --- of anonymous wildcards; see tcAnonWildCardOcc -data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int - | HM_FamPat -- Family instances: F _ Int = Bool - | HM_VTA -- Visible type and kind application: - -- f @(Maybe _) - -- Maybe @(_ -> _) - | HM_TyAppPat -- Visible type applications in patterns: - -- foo (Con @_ @t x) = ... - -- case x of Con @_ @t v -> ... - -mkMode :: TypeOrKind -> TcTyMode -mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing } - -typeLevelMode, kindLevelMode :: TcTyMode --- These modes expect no wildcards (holes) in the type -kindLevelMode = mkMode KindLevel -typeLevelMode = mkMode TypeLevel - -mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode -mkHoleMode tyki hm - = do { lvl <- getTcLevel - ; return (TcTyMode { mode_tyki = tyki - , mode_holes = Just (lvl,hm) }) } - -instance Outputable HoleMode where - ppr HM_Sig = text "HM_Sig" - ppr HM_FamPat = text "HM_FamPat" - ppr HM_VTA = text "HM_VTA" - ppr HM_TyAppPat = text "HM_TyAppPat" - -instance Outputable TcTyMode where - ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm }) - = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma - , ppr hm ]) - -{- -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. - -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. - -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. - --} - ------------------------------------------- --- | Check and desugar a type, returning the core type and its --- possibly-polymorphic kind. Much like 'tcInferRho' at the expression --- level. -tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) -tc_infer_lhs_type mode (L span ty) - = setSrcSpanA span $ - 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) } - -{- -Note [Typechecking HsCoreTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. -As such, there's not much to be done in order to typecheck an HsCoreTy, -since it's already been typechecked to some extent. There is one thing that -we must do, however: we must substitute the type variables from the tcl_env. -To see why, consider GeneralizedNewtypeDeriving, which is one of the main -clients of HsCoreTy (example adapted from #14579): - - newtype T a = MkT a deriving newtype Eq - -This will produce an InstInfo GhcPs that looks roughly like this: - - instance forall a_1. Eq a_1 => Eq (T a_1) where - (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an HsCoreTy - @(T a_1 -> T a_1 -> Bool) -- So is this - (==) - -This is then fed into the renamer. Since all of the type variables in this -InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically -identical. Things get more interesting when the InstInfo is fed into the -typechecker, however. GHC will first generate fresh skolems to instantiate -the instance-bound type variables with. In the example above, we might generate -the skolem a_2 and use that to instantiate a_1, which extends the local type -environment (tcl_env) with [a_1 :-> a_2]. This gives us: - - instance forall a_2. Eq a_2 => Eq (T a_2) where ... - -To ensure that the body of this instance is well scoped, every occurrence of -the `a` type variable should refer to a_2, the new skolem. However, the -HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the -substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this -substitution to each HsCoreTy and all is well: - - instance forall a_2. Eq a_2 => Eq (T a_2) where - (==) = coerce @( a_2 -> a_2 -> Bool) - @(T a_2 -> T a_2 -> Bool) - (==) --} - ------------------------------------------- -tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType -tcLHsType hs_ty exp_kind - = tc_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 - = setSrcSpanA span $ - tc_hs_type mode ty exp_kind - -tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType --- See Note [Bidirectional type checking] - -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 _) _ - -- 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 {}) _ - -- Record types (which only show up temporarily in constructor - -- signatures) should have been removed by now - = failWithTc $ TcRnIllegalRecordSyntax (Right ty) - --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. --- Here we get rid of it and add the finalizers to the global environment --- while capturing the local environment. --- --- See Note [Delaying modFinalizers in untyped splices]. -tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _) - exp_kind - = do addModFinalizersWithLclEnv mod_finalizers - tc_lhs_type mode ty exp_kind - -tc_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tc_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s) - ----------- Functions and applications -tc_hs_type 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 - | op `hasKey` unrestrictedFunTyConKey - = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind - ---------- Foralls -tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind - = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $ - tc_lhs_type mode ty exp_kind - -- 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 - -- Why exp_kind? See Note [Body kind of a HsForAllTy] - - -- 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 - | null (unLoc ctxt) - = tc_lhs_type mode rn_ty exp_kind - - -- See Note [Body kind of a HsQualTy] - | isConstraintLikeKind exp_kind - = do { ctxt' <- tc_hs_context mode ctxt - ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (tcMkDFunPhiTy ctxt' ty') } - - | otherwise - = do { ctxt' <- tc_hs_context mode ctxt - - ; 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 } - ---------- 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 - ; checkWiredInTyCon listTyCon - ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } - --- See Note [Distinguishing tuple kinds] in GHC.Hs.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 } - - -tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind - = tc_tuple rn_ty mode UnboxedTuple tys exp_kind - -tc_hs_type 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 - ; 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 - } - ---------- 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]. - | null tys - = tc_infer_hs_type_ek mode rn_ty 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 } - 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 - -- 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 - ; 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 } - where - arity = length tys - ---------- Constraint types -tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind - = do { massert (isTypeLevel (mode_tyki mode)) - ; ty' <- tc_lhs_type mode ty liftedTypeKind - ; let n' = mkStrLitTy $ hsIPNameFS n - ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) - constraintKind exp_kind } - -tc_hs_type _ 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 - ---------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind - = do { checkWiredInTyCon naturalTyCon - ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind } - -tc_hs_type _ 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 - = do { checkWiredInTyCon charTyCon - ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind } - ---------- Wildcards - -tc_hs_type mode ty@(HsWildCardTy _) ek - = tcAnonWildCardOcc NoExtraConstraint mode ty ek - ---------- 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 - -{- -Note [Variable Specificity and Forall Visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall -binder. Furthermore, each invisible type variable binder also has a -Specificity. Together, these determine the variable binders (ForAllTyFlag) for each -variable in the generated ForAllTy type. - -This table summarises this relation: ----------------------------------------------------------------------------- -| User-written type HsForAllTelescope Specificity ForAllTyFlag -|--------------------------------------------------------------------------- -| f :: forall a. type HsForAllInvis SpecifiedSpec Specified -| f :: forall {a}. type HsForAllInvis InferredSpec Inferred -| f :: forall a -> type HsForAllVis SpecifiedSpec Required -| f :: forall {a} -> type HsForAllVis InferredSpec / -| This last form is nonsensical and is thus rejected. ----------------------------------------------------------------------------- - -For more information regarding the interpretation of the resulting ForAllTyFlag, see -Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". --} - ------------------------------------------- -tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult -tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy ------------------------------------------- -tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind - -> 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 - ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn 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 - ; mult' <- tc_mult mode mult - ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) - (tcMkVisFunTy mult' ty1' ty2') - liftedTypeKind exp_kind } - -{- Note [Skolem escape and forall-types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Checking telescopes]. - -Consider - f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () - -The Proxy '[a,b] forces a and b to have the same kind. But a's -kind must be bound outside the 'forall a', and hence escapes. -We discover this by building an implication constraint for -each forall. So the inner implication constraint will look like - forall kb (b::kb). kb ~ ka -where ka is a's kind. We can't unify these two, /even/ if ka is -unification variable, because it would be untouchable inside -this inner implication. - -That's what the pushLevelAndCaptureConstraints, plus subsequent -buildTvImplication/emitImplication is all about, when kind-checking -HsForAllTy. - -Note that - -* We don't need to /simplify/ the constraints here - because we aren't generalising. We just capture them. - -* We can't use emitResidualTvConstraint, because that has a fast-path - for empty constraints. We can't take that fast path here, because - we must do the bad-telescope check even if there are no inner wanted - constraints. See Note [Checking telescopes] in - GHC.Tc.Types.Constraint. Lacking this check led to #16247. --} - -{- ********************************************************************* -* * - Tuples -* * -********************************************************************* -} - ---------------------------- -tupKindSort_maybe :: TcKind -> Maybe TupleSort -tupKindSort_maybe k - | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- coreView k = tupKindSort_maybe k' - | isConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing - -tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType -tc_tuple rn_ty mode tup_sort tys exp_kind - = do { arg_kinds <- case tup_sort of - BoxedTuple -> return (replicate arity liftedTypeKind) - UnboxedTuple -> replicateM arity newOpenTypeKind - ConstraintTuple -> return (replicate arity constraintKind) - ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } - where - arity = length tys - -finish_tuple :: HsType GhcRn - -> TupleSort - -> [TcType] -- ^ argument types - -> [TcKind] -- ^ of these kinds - -> TcKind -- ^ expected kind of the whole tuple - -> TcM TcType -finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do - traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) - case tup_sort of - ConstraintTuple - | [tau_ty] <- tau_tys - -- Drop any uses of 1-tuple constraints here. - -- See Note [Ignore unary constraint tuples] - -> check_expected_kind tau_ty constraintKind - | otherwise - -> do let tycon = cTupleTyCon arity - checkCTupSize arity - check_expected_kind (mkTyConApp tycon tau_tys) constraintKind - BoxedTuple -> do - let tycon = tupleTyCon Boxed arity - checkTupSize arity - checkWiredInTyCon tycon - check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind - UnboxedTuple -> do - let tycon = tupleTyCon Unboxed arity - tau_reps = map kindRep tau_kinds - -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - arg_tys = tau_reps ++ tau_tys - res_kind = unboxedTupleKind tau_reps - checkTupSize arity - check_expected_kind (mkTyConApp tycon arg_tys) res_kind - where - arity = length tau_tys - check_expected_kind ty act_kind = - checkExpectedKind rn_ty ty act_kind exp_kind - -{- -Note [Ignore unary constraint tuples] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in -GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First, -recall the definition of a unary tuple data type: - - data Solo a = Solo a - -Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and -lazy. Therefore, the presence of `Solo` matters semantically. On the other -hand, suppose we had a unary constraint tuple: - - class a => Solo% a - -This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is -semantically equivalent to `a`. Therefore, a 1-tuple constraint would have -no user-visible impact, nor would it allow you to express anything that -you couldn't otherwise. - -We could simply add Solo% for consistency with tuples (Solo) and unboxed -tuples (Solo#), but that would require even more magic to wire in another -magical class, so we opt not to do so. We must be careful, however, since -one can try to sneak in uses of unary constraint tuples through Template -Haskell, such as in this program (from #17511): - - f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)] - (ConT ''String))) - -- f :: Solo% (Show Int) => String - f = "abc" - -This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1, -and since it is used in a Constraint position, GHC will attempt to treat -it as thought it were a constraint tuple, which can potentially lead to -trouble if one attempts to look up the name of a constraint tuple of arity -1 (as it won't exist). To avoid this trouble, we simply take any unary -constraint tuples discovered when typechecking and drop them—i.e., treat -"Solo% a" as though the user had written "a". This is always safe to do -since the two constraints should be semantically equivalent. --} - -{- ********************************************************************* -* * - Type applications -* * -********************************************************************* -} - -splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn]) -splitHsAppTys hs_ty - | is_app hs_ty = Just (go (noLocA hs_ty) []) - | otherwise = Nothing - where - is_app :: HsType GhcRn -> Bool - is_app (HsAppKindTy {}) = True - is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` unrestrictedFunTyConKey) - -- I'm not sure why this funTyConKey test is necessary - -- Can it even happen? Perhaps for t1 `(->)` t2 - -- but then maybe it's ok to treat that like a normal - -- application rather than using the special rule for HsFunTy - is_app (HsTyVar {}) = True - is_app (HsParTy _ (L _ ty)) = is_app ty - is_app _ = False - - go :: LHsType GhcRn - -> [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)] - -> (LHsType GhcRn, - [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp - go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as) - go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) - go (L _ (HsOpTy _ prom l op@(L sp _) r)) as - = ( L (na2la sp) (HsTyVar noAnn prom op) - , HsValArg l : HsValArg r : as ) - go f as = (f, as) - ---------------------------- -tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) --- Version of tc_infer_lhs_type specialised for the head of an --- application. In particular, for a HsTyVar (which includes type --- constructors, it does not zoom off into tcInferTyApps and family --- saturation -tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ tv))) - = tcTyVar tv -tcInferTyAppHead mode ty - = tc_infer_lhs_type mode ty - ---------------------------- --- | Apply a type of a given kind to a list of arguments. This instantiates --- invisible parameters as necessary. Always consumes all the arguments, --- using matchExpectedFunKind as necessary. --- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- --- These kinds should be used to instantiate invisible kind variables; --- they come from an enclosing class for an associated type/data family. --- --- tcInferTyApps also arranges to saturate any trailing invisible arguments --- of a type-family application, which is usually the right thing to do --- tcInferTyApps_nosat does not do this saturation; it is used only --- by ":kind" in GHCi -tcInferTyApps, tcInferTyApps_nosat - :: TcTyMode - -> LHsType GhcRn -- ^ Function (for printing only) - -> TcType -- ^ Function - -> [LHsTypeArg GhcRn] -- ^ Args - -> TcM (TcType, TcKind) -- ^ (f args, result kind) -tcInferTyApps mode hs_ty fun hs_args - = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args - ; saturateFamApp f_args res_k } - -tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args - = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) - ; (f_args, res_k) <- go_init 1 fun orig_hs_args - ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k) - ; return (f_args, res_k) } - where - - -- go_init just initialises the auxiliary - -- arguments of the 'go' loop - go_init n fun all_args - = go n fun empty_subst fun_ki all_args - where - fun_ki = typeKind fun - -- We do (typeKind fun) here, even though the caller - -- knows the function kind, to absolutely guarantee - -- INVARIANT for 'go' - -- Note that in a typical application (F t1 t2 t3), - -- the 'fun' is just a TyCon, so typeKind is fast - - empty_subst = mkEmptySubst $ mkInScopeSet $ - tyCoVarsOfType fun_ki - - go :: Int -- The # of the next argument - -> TcType -- Function applied to some args - -> Subst -- Applies to function kind - -> TcKind -- Function kind - -> [LHsTypeArg GhcRn] -- Un-type-checked args - -> TcM (TcType, TcKind) -- Result type and its kind - -- INVARIANT: in any call (go n fun subst fun_ki args) - -- typeKind fun = subst(fun_ki) - -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling typeKind. - -- - -- Reason for INVARIANT: to support the Purely Kinded Type Invariant - -- it's important that if fun_ki has a forall, then so does - -- (typeKind fun), because the next thing we are going to do - -- is apply 'fun' to an argument type. - - -- Dispatch on all_args first, for performance reasons - go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of - - ---------------- No user-written args left. We're done! - ([], _) -> return (fun, substTy subst fun_ki) - - ---------------- HsArgPar: We don't care about parens here - (HsArgPar _ : args, _) -> go n fun subst fun_ki args - - ---------------- HsTypeArg: a kind application (fun @ki) - (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> - case ki_binder of - - -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr kv Inferred) -> instantiate kv inner_ki - - Named (Bndr _ Specified) -> -- Visible kind application - do { traceTc "tcInferTyApps (vis kind app)" - (vcat [ ppr ki_binder, ppr hs_ki_arg - , ppr (piTyBinderType ki_binder) - , ppr subst ]) - - ; let exp_kind = substTy subst $ piTyBinderType ki_binder - ; arg_mode <- mkHoleMode KindLevel HM_VTA - -- HM_VKA: see Note [Wildcards in visible kind application] - ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $ - tc_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 - ; go (n+1) fun' subst' inner_ki hs_args } - - -- Attempted visible kind application (fun @ki), but fun_ki is - -- forall k -> blah or k1 -> k2 - -- So we need a normal application. Error. - _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki - - -- No binder; try applying the substitution, or fail if that's not possible - (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ - ty_app_err ki_arg substed_fun_ki - - ---------------- HsValArg: a normal argument (fun ty) - (HsValArg arg : args, Just (ki_binder, inner_ki)) - -- next binder is invisible; need to instantiate it - | Named (Bndr kv flag) <- ki_binder - , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified - -> instantiate kv inner_ki - - -- "normal" case - | otherwise - -> do { traceTc "tcInferTyApps (vis normal app)" - (vcat [ ppr ki_binder - , ppr arg - , ppr (piTyBinderType ki_binder) - , 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 - ; 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 } - - -- no binder; try applying the substitution, or infer another arrow in fun kind - (HsValArg _ : _, Nothing) - -> try_again_after_substing_or $ - do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki - - ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTy` co) - -- This zonk is essential, to expose the fruits - -- of matchExpectedFunKind to the 'go' loop - - ; traceTc "tcInferTyApps (no binder)" $ - vcat [ ppr fun <+> dcolon <+> ppr fun_ki - , ppr arrows_needed - , ppr co - , ppr fun' <+> dcolon <+> ppr (typeKind fun')] - ; go_init n fun' all_args } - -- Use go_init to establish go's INVARIANT - where - instantiate ki_binder inner_ki - = do { traceTc "tcInferTyApps (need to instantiate)" - (vcat [ ppr ki_binder, ppr subst]) - ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder - ; go n (mkAppTy fun arg') subst' inner_ki all_args } - -- Because tcInvisibleTyBinder instantiate ki_binder, - -- the kind of arg' will have the same shape as the kind - -- of ki_binder. So we don't need mkAppTyM here. - - try_again_after_substing_or fallthrough - | not (isEmptyTCvSubst subst) - = go n fun zapped_subst substed_fun_ki all_args - | otherwise - = fallthrough - - zapped_subst = zapSubst subst - substed_fun_ki = substTy subst fun_ki - hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) - - n_initial_val_args :: [HsArg p tm ty] -> Arity - -- Count how many leading HsValArgs we have - n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args - n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args - n_initial_val_args _ = 0 - - ty_app_err arg ty - = failWith $ TcRnInvalidVisibleKindArgument arg ty - -mkAppTyM :: Subst - -> TcType -> PiTyBinder -- fun, plus its top-level binder - -> TcType -- arg - -> TcM (Subst, TcType) -- Extended subst, plus (fun arg) --- Precondition: the application (fun arg) is well-kinded after zonking --- That is, the application makes sense --- --- Precondition: for (mkAppTyM subst fun bndr arg) --- typeKind fun = Pi bndr. body --- That is, fun always has a ForAllTy or FunTy at the top --- and 'bndr' is fun's pi-binder --- --- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type --- invariant, then so does the result type (fun arg) --- --- We do not require that --- typeKind arg = tyVarKind (binderVar bndr) --- This must be true after zonking (precondition 1), but it's not --- required for the (PKTI). -mkAppTyM subst fun ki_binder arg - | -- See Note [mkAppTyM]: Nasty case 2 - TyConApp tc args <- fun - , isTypeSynonymTyCon tc - , args `lengthIs` (tyConArity tc - 1) - , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym - = do { (arg':args') <- liftZonkM $ zonkTcTypes (arg:args) - ; let subst' = case ki_binder of - Anon {} -> subst - Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' - ; return (subst', mkTyConApp tc (args' ++ [arg'])) } - - -mkAppTyM subst fun (Anon {}) arg - = return (subst, mk_app_ty fun arg) - -mkAppTyM subst fun (Named (Bndr tv _)) arg - = do { arg' <- if isTrickyTvBinder tv - then -- See Note [mkAppTyM]: Nasty case 1 - liftZonkM $ zonkTcType arg - else return arg - ; return ( extendTvSubstAndInScope subst tv arg' - , mk_app_ty fun arg' ) } - -mk_app_ty :: TcType -> TcType -> TcType --- This function just adds an ASSERT for mkAppTyM's precondition -mk_app_ty fun arg - = assertPpr (isPiTy fun_kind) - (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ - mkAppTy fun arg - where - fun_kind = typeKind fun - -isTrickyTvBinder :: TcTyVar -> Bool --- NB: isTrickyTvBinder is just an optimisation --- It would be absolutely sound to return True always -isTrickyTvBinder tv = isPiTy (tyVarKind tv) - -{- Note [The Purely Kinded Type Invariant (PKTI)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type inference, we maintain this invariant - - (PKTI) It is legal to call 'typeKind' on any Type ty, - on any sub-term of ty, /without/ zonking ty - - Moreover, any such returned kind - will itself satisfy (PKTI) - -By "legal to call typeKind" we mean "typeKind will not crash". -The way in which typeKind can crash is in applications - (a t1 t2 .. tn) -if 'a' is a type variable whose kind doesn't have enough arrows -or foralls. (The crash is in piResultTys.) - -The loop in tcInferTyApps has to be very careful to maintain the (PKTI). -For example, suppose - kappa is a unification variable - We have already unified kappa := Type - yielding co :: Refl (Type -> Type) - a :: kappa -then consider the type - (a Int) -If we call typeKind on that, we'll crash, because the (un-zonked) -kind of 'a' is just kappa, not an arrow kind. So we must zonk first. - -So the type inference engine is very careful when building applications. -This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int), -where (a :: kappa). Then in tcInferApps we'll run out of binders on -a's kind, so we'll call matchExpectedFunKind, and unify - kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) -At this point we must zonk the function type to expose the arrrow, so -that (a Int) will satisfy (PKTI). - -The absence of this caused #14174 and #14520. - -The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM]. - -Wrinkle around FunTy: -Note that the PKTI does *not* guarantee anything about the shape of FunTys. -Specifically, when we have (FunTy vis mult arg res), it should be the case -that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we -might not have this. Example: if the user writes (a -> b), then we might -invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1 -(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2). -However, when we build the FunTy, we might not have zonked `a`, and so the -FunTy will be built without being able to purely extract the RuntimeReps. - -Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy, -we must be aware of this when splitting: splitTyConApp and splitAppTy will *not* -split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy] -in GHC.Tc.Solver.Equality. - -Note [mkAppTyM] -~~~~~~~~~~~~~~~ -mkAppTyM is trying to guarantee the Purely Kinded Type Invariant -(PKTI) for its result type (fun arg). There are two ways it can go wrong: - -* Nasty case 1: forall types (polykinds/T14174a) - T :: forall (p :: *->*). p Int -> p Bool - Now kind-check (T x), where x::kappa. - Well, T and x both satisfy the PKTI, but - T x :: x Int -> x Bool - and (x Int) does /not/ satisfy the PKTI. - -* Nasty case 2: type synonyms - type S f a = f a - Even though (S ff aa) would satisfy the (PKTI) if S was a data type - (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) - if S is a type synonym, because the /expansion/ of (S ff aa) is - (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps - (ff :: kappa), where 'kappa' has already been unified with (*->*). - - We check for nasty case 2 on the final argument of a type synonym. - -Notice that in both cases the trickiness only happens if the -bound variable has a pi-type. Hence isTrickyTvBinder. --} - - -saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) --- Precondition for (saturateFamApp ty kind): --- typeKind ty = kind --- --- If 'ty' is an unsaturated family application with trailing --- invisible arguments, instantiate them. --- See Note [saturateFamApp] - -saturateFamApp ty kind - | Just (tc, args) <- tcSplitTyConApp_maybe ty - , tyConMustBeSaturated tc - , let n_to_inst = tyConArity tc - length args - = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind - ; return (ty `mkAppTys` extra_args, ki') } - | otherwise - = return (ty, kind) - -{- Note [saturateFamApp] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type family F :: Either j k - type instance F @Type = Right Maybe - type instance F @Type = Right Either``` - -Then F :: forall {j,k}. Either j k - -The two type instances do a visible kind application that instantiates -'j' but not 'k'. But we want to end up with instances that look like - type instance F @Type @(*->*) = Right @Type @(*->*) Maybe - -so that F has arity 2. We must instantiate that trailing invisible -binder. In general, Invisible binders precede Specified and Required, -so this is only going to bite for apparently-nullary families. - -Note that - type family F2 :: forall k. k -> * -is quite different and really does have arity 0. - -It's not just type instances where we need to saturate those -unsaturated arguments: see #11246. Hence doing this in tcInferApps. --} - -appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn -appTypeToArg f [] = f -appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args -appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args -appTypeToArg f (HsTypeArg at arg : args) - = appTypeToArg (mkHsAppKindTy f at arg) args - - -{- ********************************************************************* -* * - checkExpectedKind -* * -********************************************************************* -} - --- | This instantiates invisible arguments for the type being checked if it must --- be saturated and is not yet saturated. It then calls and uses the result --- from checkExpectedKindX to build the final type -checkExpectedKind :: HasDebugCallStack - => HsType GhcRn -- ^ type we're checking (for printing) - -> TcType -- ^ type we're checking - -> TcKind -- ^ the known kind of that type - -> TcKind -- ^ the expected kind - -> TcM TcType --- Just a convenience wrapper to save calls to 'ppr' -checkExpectedKind hs_ty ty act_kind exp_kind - = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) - - ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind - - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just (HsTypeRnThing hs_ty) - , uo_visible = True } -- the hs_ty is visible - - ; traceTc "checkExpectedKindX" $ - vcat [ ppr hs_ty - , text "act_kind':" <+> ppr act_kind' - , text "exp_kind:" <+> ppr exp_kind ] - - ; let res_ty = ty `mkAppTys` new_args - - ; if act_kind' `tcEqType` exp_kind - then return res_ty -- This is very common - else do { co_k <- unifyTypeAndEmit KindLevel origin act_kind' exp_kind - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; return (res_ty `mkCastTy` co_k) } } - where - -- We need to make sure that both kinds have the same number of implicit - -- foralls out front. If the actual kind has more, instantiate accordingly. - -- Otherwise, just pass the type & kind through: the errors are caught - -- in unifyType. - n_exp_invis_bndrs = invisibleTyBndrCount exp_kind - n_act_invis_bndrs = invisibleTyBndrCount act_kind - n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs - ---------------------------- - -tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] -tcHsContext Nothing = return [] -tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt - -tcLHsPredType :: LHsType GhcRn -> TcM PredType -tcLHsPredType pred = tc_lhs_pred typeLevelMode pred - -tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] -tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) - -tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType -tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind - ---------------------------- -tcTyVar :: Name -> TcM (TcType, TcKind) --- See Note [Type checking recursive type and class declarations] --- in GHC.Tc.TyCl --- This does not instantiate. See Note [Do not always instantiate eagerly in types] -tcTyVar name -- Could be a tyvar, a tycon, or a datacon - = do { traceTc "lk1" (ppr name) - ; thing <- tcLookup name - ; case thing of - ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) - - -- See Note [Recursion through the kinds] - (tcTyThingTyCon_maybe -> Just tc) -- TyCon or TcTyCon - -> return (mkTyConTy tc, tyConKind tc) - - AGlobal (AConLike (RealDataCon dc)) - -> do { data_kinds <- xoptM LangExt.DataKinds - ; unless (data_kinds || specialPromotedDc dc) $ - promotionErr name NoDataKindsDC - ; when (isFamInstTyCon (dataConTyCon dc)) $ - -- see #15245 - promotionErr name FamDataConPE - ; let (_, _, _, theta, _, _) = dataConFullSig dc - ; traceTc "tcTyVar" (ppr dc <+> ppr theta) - -- promotionErr: Note [No constraints in kinds] in GHC.Tc.Validity - ; unless (null theta) $ - promotionErr name (ConstrainedDataConPE theta) - ; let tc = promoteDataCon dc - ; return (mkTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr WrongThingType thing name } - -{- -Note [Recursion through the kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these examples - -Ticket #11554: - data P (x :: k) = Q - data A :: Type where - MkA :: forall (a :: A). P a -> A - -Ticket #12174 - data V a - data T = forall (a :: T). MkT (V a) - -The type is recursive (which is fine) but it is recursive /through the -kinds/. In earlier versions of GHC this caused a loop in the compiler -(to do with knot-tying) but there is nothing fundamentally wrong with -the code (kinds are types, and the recursive declarations are OK). But -it's hard to distinguish "recursion through the kinds" from "recursion -through the types". Consider this (also #11554): - - data PB k (x :: k) = Q - data B :: Type where - MkB :: P B a -> B - -Here the occurrence of B is not obviously in a kind position. - -So now GHC allows all these programs. #12081 and #15942 are other -examples. - -Note [Body kind of a HsForAllTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The body of a forall is usually a type, but in principle -there's no reason to prohibit *unlifted* types. -In fact, GHC can itself construct a function with an -unboxed tuple inside a for-all (via CPR analysis; see -typecheck/should_compile/tc170). - -Moreover in instance heads we get forall-types with -kind Constraint. - -It's tempting to check that the body kind is (TYPE _). But this is -wrong. For example: - - class C a b - newtype N = Mk Foo deriving (C a) - -We're doing newtype-deriving for C. But notice how `a` isn't in scope in -the predicate `C a`. So we quantify, yielding `forall a. C a` even though -`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but -convenient. Bottom line: don't check for (TYPE _) here. - -Note [Body kind of a HsQualTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ctxt is non-empty, the HsQualTy really is a /function/, so the -kind of the result really is '*', and in that case the kind of the -body-type can be lifted or unlifted. - -However, consider - instance Eq a => Eq [a] where ... -or - f :: (Eq a => Eq [a]) => blah -Here both body-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 (=>). - -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.) - -Note [Inferring tuple kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple, -we try to figure out whether it's a tuple of kind * or Constraint. - Step 1: look at the expected kind - Step 2: infer argument kinds - -If after Step 2 it's not clear from the arguments that it's -Constraint, then it must be *. Once having decided that we re-check -the arguments to give good error messages in - e.g. (Maybe, Maybe) - -Note that we will still fail to infer the correct kind in this case: - - type T a = ((a,a), D a) - type family D :: Constraint -> Constraint - -While kind checking T, we do not yet know the kind of D, so we will default the -kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. - -Note [Desugaring types] -~~~~~~~~~~~~~~~~~~~~~~~ -The type desugarer is phase 2 of dealing with HsTypes. Specifically: - - * It transforms from HsType to Type - - * It zonks any kinds. The returned type should have no mutable kind - or type variables (hence returning Type not TcType): - - any unconstrained kind variables are defaulted to (Any *) just - as in GHC.Tc.Zonk.Type. - - there are no mutable type variables because we are - kind-checking a type - Reason: the returned type may be put in a TyCon or DataCon where - it will never subsequently be zonked. - -You might worry about nested scopes: - ..a:kappa in scope.. - let f :: forall b. T '[a,b] -> Int -In this case, f's type could have a mutable kind variable kappa in it; -and we might then default it to (Any *) when dealing with f's type -signature. But we don't expect this to happen because we can't get a -lexically scoped type variable with a mutable kind variable in it. A -delicate point, this. If it becomes an issue we might need to -distinguish top-level from nested uses. - -Moreover - * it cannot fail, - * it does no unifications - * it does no validity checking, except for structural matters, such as - (a) spurious ! annotations. - (b) a class used as a type - -Note [Kind of a type splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these terms, each with TH type splice inside: - [| e1 :: Maybe $(..blah..) |] - [| e2 :: $(..blah..) |] -When kind-checking the type signature, we'll kind-check the splice -$(..blah..); we want to give it a kind that can fit in any context, -as if $(..blah..) :: forall k. k. - -In the e1 example, the context of the splice fixes kappa to *. But -in the e2 example, we'll desugar the type, zonking the kind unification -variables as we go. When we encounter the unconstrained kappa, we -want to default it to '*', not to (Any *). - --} - -addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a - -- Wrap a context around only if we want to show that contexts. - -- Omit invisible ones and ones user's won't grok -addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. -addTypeCtxt (L _ ty) thing - = addErrCtxt doc thing - where - doc = text "In the type" <+> quotes (ppr ty) - - -{- ********************************************************************* -* * - Type-variable binders -* * -********************************************************************* -} - -bindNamedWildCardBinders :: [Name] - -> ([(Name, TcTyVar)] -> TcM a) - -> TcM a --- Bring into scope the /named/ wildcard binders. Remember that --- plain wildcards _ are anonymous and dealt with by HsWildCardTy --- Soe Note [The wildcard story for types] in GHC.Hs.Type -bindNamedWildCardBinders wc_names thing_inside - = do { wcs <- mapM newNamedWildTyVar wc_names - ; let wc_prs = wc_names `zip` wcs - ; tcExtendNameTyVarEnv wc_prs $ - thing_inside wc_prs } - -newNamedWildTyVar :: Name -> TcM TcTyVar --- ^ New unification variable '_' for a wildcard -newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in the type - = do { kind <- newMetaKindVar - ; details <- newMetaDetails TauTv - ; wc_name <- newMetaTyVarName (fsLit "w") -- See Note [Wildcard names] - ; let tyvar = mkTcTyVar wc_name kind details - ; traceTc "newWildTyVar" (ppr tyvar) - ; return tyvar } - ---------------------------- -tcAnonWildCardOcc :: IsExtraConstraint - -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType -tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) - ty exp_kind - -- hole_lvl: see Note [Checking partial type signatures] - -- esp the bullet on nested forall types - = do { kv_details <- newTauTvDetailsAtLevel hole_lvl - ; kv_name <- newMetaTyVarName (fsLit "k") - ; wc_details <- newTauTvDetailsAtLevel hole_lvl - ; wc_name <- newMetaTyVarName (fsLit wc_nm) - ; let kv = mkTcTyVar kv_name liftedTypeKind kv_details - wc_kind = mkTyVarTy kv - wc_tv = mkTcTyVar wc_name wc_kind wc_details - - ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes) - ; when emit_holes $ - emitAnonTypeHole is_extra wc_tv - -- Why the 'when' guard? - -- See Note [Wildcards in visible kind application] - - -- You might think that this would always just unify - -- wc_kind with exp_kind, so we could avoid even creating kv - -- But the level numbers might not allow that unification, - -- so we have to do it properly (T14140a) - ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind } - where - -- See Note [Wildcard names] - wc_nm = case hole_mode of - HM_Sig -> "w" - HM_FamPat -> "_" - HM_VTA -> "w" - HM_TyAppPat -> "_" - - emit_holes = case hole_mode of - HM_Sig -> True - HM_FamPat -> False - HM_VTA -> False - HM_TyAppPat -> False - -tcAnonWildCardOcc is_extra _ _ _ --- mode_holes is Nothing. This means we have an anonymous wildcard --- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard', --- but it is possible for a wildcard to be introduced by a Template Haskell splice, --- as per #15433. To account for this, we throw a generic catch-all error message. - = failWith $ TcRnIllegalWildcardInType Nothing reason - where - reason = - case is_extra of - YesExtraConstraint -> - ExtraConstraintWildcardNotAllowed - SoleExtraConstraintWildcardNotAllowed - NoExtraConstraint -> - WildcardsNotAllowedAtAll - -{- Note [Wildcard names] -~~~~~~~~~~~~~~~~~~~~~~~~ -So we hackily use the mode_holes flag to control the name used -for wildcards: - -* For proper holes (whether in a visible type application (VTA) or no), - we rename the '_' to 'w'. This is so that we see variables like 'w0' - or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For - example, we prefer - Found type wildcard ‘_’ standing for ‘w0’ - over - Found type wildcard ‘_’ standing for ‘_1’ - - Even in the VTA case, where we do not emit an error to be printed, we - want to do the renaming, as the variables may appear in other, - non-wildcard error messages. - -* However, holes in the left-hand sides of type families ("type - patterns") stand for type variables which we do not care to name -- - much like the use of an underscore in an ordinary term-level - pattern. When we spot these, we neither wish to generate an error - message nor to rename the variable. We don't rename the variable so - that we can pretty-print a type family LHS as, e.g., - F _ Int _ = ... - and not - F w1 Int w2 = ... - - See also Note [Wildcards in family instances] in - GHC.Rename.Module. The choice of HM_FamPat is made in - tcFamTyPats. There is also some unsavory magic, relying on that - underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser. - -Note [Wildcards in visible kind application] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are cases where users might want to pass in a wildcard as a visible kind -argument, for instance: - -data T :: forall k1 k2. k1 → k2 → Type where - MkT :: T a b -x :: T @_ @Nat False n -x = MkT - -So we should allow '@_' without emitting any hole constraints, and -regardless of whether PartialTypeSignatures is enabled or not. But how -would the typechecker know which '_' is being used in VKA and which is -not when it calls emitNamedTypeHole in -tcHsPartialSigType on all HsWildCardBndrs? The solution is to neither -rename nor include unnamed wildcards in HsWildCardBndrs, but instead -give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. - -And whenever we see a '@', we set mode_holes to HM_VKA, so that -we do not call emitAnonTypeHole in tcAnonWildCardOcc. -See related Note [Wildcards in visible type application] here and -Note [The wildcard story for types] in GHC.Hs.Type --} - -{- ********************************************************************* -* * - Kind inference for type declarations -* * -********************************************************************* -} - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -data InitialKindStrategy - = InitialKindCheck SAKS_or_CUSK - | InitialKindInfer - --- Does the declaration have a standalone kind signature (SAKS) or a complete --- user-supplied kind (CUSK)? -data SAKS_or_CUSK - = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-supplied kind (CUSK) - -instance Outputable SAKS_or_CUSK where - ppr (SAKS k) = text "SAKS" <+> ppr k - ppr CUSK = text "CUSK" - --- See Note [kcCheckDeclHeader vs kcInferDeclHeader] -kcDeclHeader - :: InitialKindStrategy - -> Name -- ^ of the thing being checked - -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon -kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig -kcDeclHeader InitialKindInfer = kcInferDeclHeader - -{- Note [kcCheckDeclHeader vs kcInferDeclHeader] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind -of a type constructor. - -* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that - case, find the full, final, poly-kinded kind of the TyCon. It's very like a - term-level binding where we have a complete type signature for the function. - -* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a - CUSK. Find a monomorphic kind, with unification variables in it; they will be - generalised later. It's very like a term-level binding where we do not have a - type signature (or, more accurately, where we have a partial type signature), - so we infer the type and generalise. --} - ------------------------------- -kcCheckDeclHeader - :: SAKS_or_CUSK - -> Name -- ^ of the thing being checked - -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig -kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk - -kcCheckDeclHeader_cusk - :: Name -- ^ of the thing being checked - -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind - -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon -kcCheckDeclHeader_cusk name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_tvs }) kc_res_ki - -- CUSK case - -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - = addTyConFlavCtxt name flav $ - do { skol_info <- mkSkolemInfo skol_info_anon - ; (tclvl, wanted, (scoped_kvs, (tc_bndrs, res_kind))) - <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $ - bindImplicitTKBndrs_Q_Skol skol_info kv_ns $ - bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs $ - newExpectedKind =<< kc_res_ki - - -- Now, because we're in a CUSK, - -- we quantify over the mentioned kind vars - ; let spec_req_tkvs = scoped_kvs ++ binderVars tc_bndrs - all_kinds = res_kind : map tyVarKind spec_req_tkvs - - ; candidates <- candidateQTyVarsOfKinds all_kinds - -- 'candidates' are all the variables that we are going to - -- skolemise and then quantify over. We do not include spec_req_tvs - -- because they are /already/ skolems - - ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $ - candidates `delCandidates` spec_req_tkvs - -- NB: 'inferred' comes back sorted in dependency order - - ; (scoped_kvs, tc_bndrs, res_kind) <- liftZonkM $ - do { scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_bndrs are skolems, - ; tc_bndrs <- mapM zonkTyCoVarBndrKind tc_bndrs -- so zonkTyCoVarBndrKind suffices - ; res_kind <- zonkTcType res_kind - ; return (scoped_kvs, tc_bndrs, res_kind) } - - ; let mentioned_kv_set = candidateKindVars candidates - specified = scopedSort scoped_kvs - -- NB: maintain the L-R order of scoped_kvs - - all_tcbs = mkNamedTyConBinders Inferred inferred - ++ mkNamedTyConBinders Specified specified - ++ map (mkExplicitTyConBinder mentioned_kv_set) tc_bndrs - - -- Eta expand if necessary; we are building a PolyTyCon - ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind - - ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ binderVars tc_bndrs) - final_tcbs = all_tcbs `chkAppend` eta_tcbs - tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs - True -- Make a PolyTcTyCon, fully generalised - flav - - ; reportUnsolvedEqualities skol_info (binderVars final_tcbs) - tclvl wanted - - -- If the ordering from - -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - -- doesn't work, we catch it here, before an error cascade - ; checkTyConTelescope tycon - - ; traceTc "kcCheckDeclHeader_cusk " $ - vcat [ text "name" <+> ppr name - , text "candidates" <+> ppr candidates - , text "mentioned_kv_set" <+> ppr mentioned_kv_set - , text "kv_ns" <+> ppr kv_ns - , text "hs_tvs" <+> ppr hs_tvs - , text "scoped_kvs" <+> ppr scoped_kvs - , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs - , text "all_kinds" <+> ppr all_kinds - , text "tc_tvs" <+> pprTyVars (binderVars tc_bndrs) - , text "res_kind" <+> ppr res_kind - , text "inferred" <+> ppr inferred - , text "specified" <+> ppr specified - , text "final_tcbs" <+> ppr final_tcbs - , text "mkTyConKind final_tc_bndrs res_kind" - <+> ppr (mkTyConKind final_tcbs res_kind) - , text "all_tv_prs" <+> ppr all_tv_prs ] - - ; return tycon } - where - skol_info_anon = TyConSkol flav name - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - --- | Create a TyConBinder for a user-written type variable binder. -mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently - -> VarBndr TyVar (HsBndrVis GhcRn) - -> TyConBinder -mkExplicitTyConBinder dep_set (Bndr tv flag) = - case flag of - HsBndrRequired -> mkRequiredTyConBinder dep_set tv - HsBndrInvisible{} -> mkNamedTyConBinder Specified tv - --- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and --- other kinds). --- --- This function does not do telescope checking. -kcInferDeclHeader - :: Name -- ^ of the thing being checked - -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn - -> TcM ContextKind -- ^ The result kind - -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon -kcInferDeclHeader name flav - (HsQTvs { hsq_ext = kv_ns - , hsq_explicit = hs_bndrs }) kc_res_ki - -- No standalone kind signature and no CUSK. - -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - = addTyConFlavCtxt name flav $ - do { rejectInvisibleBinders name hs_bndrs - ; (scoped_kvs, (tc_bndrs, res_kind)) - -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? - -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - <- bindImplicitTKBndrs_Q_Tv kv_ns $ - bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs $ - newExpectedKind =<< kc_res_ki - -- Why "_Tv" not "_Skol"? See third wrinkle in - -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, - - ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they - -- might unify with kind vars in other types in a mutually - -- recursive group. - -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - - tc_tvs = binderVars tc_bndrs - -- Discard visibility flags. We made sure all of them are HsBndrRequired - -- by the call to rejectInvisibleBinders above. - - tc_binders = mkAnonTyConBinders tc_tvs - -- This has to be mkAnonTyConBinder! - -- See Note [No polymorphic recursion in type decls] in GHC.Tc.TyCl - -- - -- Also, note that tc_binders has the tyvars from only the - -- user-written type variable binders. - -- See S1 Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl - - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - -- NB: bindExplicitTKBndrs_Q_Tv does not clone; - -- ditto Implicit - -- See Note [Cloning for type variable binders] - - tycon = mkTcTyCon name tc_binders res_kind all_tv_prs - False -- Make a MonoTcTyCon - flav - - ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_bndrs - , ppr scoped_kvs - , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - --- rejectInvisibleBinders is called on on the inference code path; there is --- no standalone kind signature, nor CUSK. --- See Note [No inference for invisible binders in type decls] in GHC.Tc.TyCl -rejectInvisibleBinders :: Name -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcM () -rejectInvisibleBinders name = mapM_ check_bndr_vis - where - check_bndr_vis :: LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcM () - check_bndr_vis bndr = - when (isHsBndrInvisible (hsTyVarBndrFlag (unLoc bndr))) $ - addErr (TcRnInvisBndrWithoutSig name bndr) - --- | Kind-check a declaration header against a standalone kind signature. --- See Note [kcCheckDeclHeader_sig] -kcCheckDeclHeader_sig - :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) - -> Name -- ^ of the thing being checked - -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked - -> LHsQTyVars GhcRn -- ^ Binders in the header - -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature - -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon --- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki): --- kind(returned PolyTcTyCon) = sig_kind --- -kcCheckDeclHeader_sig sig_kind name flav - (HsQTvs { hsq_ext = implicit_nms - , hsq_explicit = hs_tv_bndrs }) kc_res_ki - = addTyConFlavCtxt name flav $ - do { skol_info <- mkSkolemInfo (TyConSkol flav name) - ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind) - <- splitTyConKind skol_info emptyInScopeSet - (map getOccName hs_tv_bndrs) sig_kind - - ; traceTc "kcCheckDeclHeader_sig {" $ - vcat [ text "sig_kind:" <+> ppr sig_kind - , text "sig_tcbs:" <+> ppr sig_tcbs - , text "sig_res_kind:" <+> ppr sig_res_kind - , text "implict_nms:" <+> ppr implicit_nms - , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ] - - ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind)))) - <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 - bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone - matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> - do { -- Kind-check the result kind annotation, if present: - -- data T a b :: res_ki where ... - -- ^^^^^^^^^ - -- We do it here because at this point the environment has been - -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. - ; res_kind :: ContextKind <- kc_res_ki - - - -- Work out extra_arity, the number of extra invisible binders from - -- the kind signature that should be part of the TyCon's arity. - -- See Note [Arity inference in kcCheckDeclHeader_sig] - ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs - invis_arity = case res_kind of - AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders - -- the signature into part of the arity of the TyCon - OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the - -- invisible binders part of the arity of the TyCon - TheKind ki -> 0 `max` (n_invis_tcbs - invisibleTyBndrCount ki) - - ; let (invis_tcbs, resid_tcbs) = splitAt invis_arity excess_sig_tcbs - ; let sig_res_kind' = mkTyConKind resid_tcbs sig_res_kind - - ; traceTc "kcCheckDeclHeader_sig 2" $ vcat [ ppr excess_sig_tcbs - , ppr invis_arity, ppr invis_tcbs - , ppr n_invis_tcbs ] - - -- Unify res_ki (from the type declaration) with - -- sig_res_kind', the residual kind from the kind signature. - ; checkExpectedResKind sig_res_kind' res_kind - - -- Add more binders for data/newtype, so the result kind has no arrows - -- See Note [Datatype return kinds] - ; if null resid_tcbs || not (needsEtaExpansion flav) - then return (invis_tcbs, sig_res_kind') - else return (excess_sig_tcbs, sig_res_kind) - } - - - -- Check that there are no unsolved equalities - ; let all_tcbs = skol_tcbs ++ extra_tcbs - ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted - - -- Check that distinct binders map to distinct tyvars (see #20916). For example - -- type T :: k -> k -> Type - -- data T (a::p) (b::q) = ... - -- Here p and q both map to the same kind variable k. We don't allow this - -- so we must check that they are distinct. A similar thing happens - -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference. - -- - -- With visible dependent quantification, one of the binders involved - -- may be explicit. Consider #24604 - -- type UF :: forall zk -> zk -> Constraint - -- class UF kk (xb :: k) - -- Here `k` and `kk` both denote the same variable; but only `k` is implicit - -- Hence we need to add skol_scoped_tvs - ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs - ; let implicit_prs = implicit_nms `zip` implicit_tvs - dup_chk_prs = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs - ; unless (null implicit_nms) $ -- No need if no implicit tyvars - checkForDuplicateScopedTyVars dup_chk_prs - ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs - - -- Swizzle the Names so that the TyCon uses the user-declared implicit names - -- E.g type T :: k -> Type - -- data T (a :: j) = .... - -- We want the TyConBinders of T to be [j, a::j], not [k, a::k] - -- Why? So that the TyConBinders of the TyCon will lexically scope over the - -- associated types and methods of a class. - ; let swizzle_env = mkVarEnv (map swap implicit_prs) - (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptySubst all_tcbs - swizzled_kind = substTy subst tycon_res_kind - all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) - - ; traceTc "kcCheckDeclHeader swizzle" $ vcat - [ text "sig_tcbs =" <+> ppr sig_tcbs - , text "implicit_prs =" <+> ppr implicit_prs - , text "hs_tv_bndrs =" <+> ppr hs_tv_bndrs - , text "all_tcbs =" <+> pprTyVars (binderVars all_tcbs) - , text "swizzled_tcbs =" <+> pprTyVars (binderVars swizzled_tcbs) - , text "tycon_res_kind =" <+> ppr tycon_res_kind - , text "swizzled_kind =" <+> ppr swizzled_kind ] - - -- Build the final, generalized PolyTcTyCon - -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs - -- because the tv_prs is used when (say) typechecking the RHS of - -- a type synonym. - ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs - True -- Make a PolyTcTyCon, fully generalised - flav - - ; traceTc "kcCheckDeclHeader_sig }" $ vcat - [ text "tyConName = " <+> ppr (tyConName tc) - , text "sig_kind =" <+> debugPprType sig_kind - , text "tyConKind =" <+> debugPprType (tyConKind tc) - , text "tyConBinders = " <+> ppr (tyConBinders tc) - , text "tyConResKind" <+> debugPprType (tyConResKind tc) - ] - ; return tc } - --- | Check the result kind annotation on a type constructor against --- the corresponding section of the standalone kind signature. --- Drops invisible binders that interfere with unification. -checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature - -> ContextKind -- ^ the result kind from the declaration header - -> TcM () -checkExpectedResKind _ AnyKind - = return () -- No signature in the declaration header -checkExpectedResKind sig_kind res_ki - = do { actual_res_ki <- newExpectedKind res_ki - - ; let -- Drop invisible binders from sig_kind until they match up - -- with res_ki. By analogy with checkExpectedKind. - n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki - n_sig_invis_bndrs = invisibleTyBndrCount sig_kind - n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs - - (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind - - ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki } - -matchUpSigWithDecl - :: Name -- Name of the type constructor for error messages - -> [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature - -> TcKind -- The tail end of the kind signature - -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -- User-written binders in decl - -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope - -- Argument is excess TyConBinders and tail kind - -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars - , [TcTyVar] -- Skolem tyvars brought into lexical scope by this matching-up - , a ) --- See Note [Matching a kind signature with a declaration] --- Invariant: Length of returned TyConBinders + length of excess TyConBinders --- = length of incoming TyConBinders -matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside - = go emptySubst sig_tcbs hs_bndrs - where - go subst tcbs [] - = do { let (subst', tcbs') = substTyConBindersX subst tcbs - ; res <- thing_inside tcbs' (substTy subst' sig_res_kind) - ; return ([], [], res) } - - go _ [] hs_bndrs - = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs) - - go subst (tcb : tcbs') hs_bndrs@(hs_bndr : hs_bndrs') - | zippable (binderFlag tcb) (hsTyVarBndrFlag (unLoc hs_bndr)) - = -- Visible TyConBinder, so match up with the hs_bndrs - do { let Bndr tv vis = tcb - tv' = updateTyVarKind (substTy subst) $ - setTyVarName tv (getName 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 - subst' = extendTCvSubstWithClone subst tv tv' - ; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv') - ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv') - ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $ - go subst' tcbs' hs_bndrs' - ; return (Bndr tv' vis : tcbs', tv':tvs, res) } - -- We do a tcExtendTyVarEnv [tv'], so we return tv' in - -- the list of lexically-scoped skolem type variables - - | skippable (binderFlag tcb) - = -- Invisible TyConBinder, so do not consume one of the hs_bndrs - do { let (subst', tcb') = substTyConBinderX subst tcb - ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb') - ; (tcbs', tvs, res) <- go subst' tcbs' hs_bndrs - -- NB: pass on hs_bndrs unchanged; we do not consume a - -- HsTyVarBndr for an invisible TyConBinder - ; return (tcb' : tcbs', tvs, res) } - -- Return `tvs`; no new lexically-scoped TyVars brought into scope - - | otherwise = - -- At this point we conclude that: - -- * the quantifier (tcb) is visible: (ty -> ...), (forall a -> ...) - -- * the binder (hs_bndr) is invisible: @t, @(t :: k) - -- Any other combination should have been handled by the zippable/skippable clauses. - 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 } - - -- See GHC Proposal #425, section "Kind checking", - -- where zippable and skippable are defined. - -- In particular: we match up if - -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified) - -- (b) HsBndr looks like a, and TyCon binder is forall k -> (NamedTCB Required) - -- or k -> (AnonTCB) - zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool - zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- (a) - zippable vis HsBndrRequired = isVisibleTcbVis vis -- (b) - - -- See GHC Proposal #425, section "Kind checking", - -- where zippable and skippable are defined. - skippable :: TyConBndrVis -> Bool - skippable vis = not (isVisibleTcbVis vis) - -substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder) -substTyConBinderX subst (Bndr tv vis) - = (subst', Bndr tv' vis) - where - (subst', tv') = substTyVarBndr subst tv - -substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder]) -substTyConBindersX = mapAccumL substTyConBinderX - -swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder) -swizzleTcb swizzle_env subst (Bndr tv vis) - = (subst', Bndr tv2 vis) - where - subst' = extendTCvSubstWithClone subst tv tv2 - tv1 = updateTyVarKind (substTy subst) tv - tv2 = case lookupVarEnv swizzle_env tv of - Just user_name -> setTyVarName tv1 user_name - Nothing -> tv1 - -- NB: the SrcSpan on an implicitly-bound name deliberately spans - -- the whole declaration. e.g. - -- data T (a :: k) (b :: Type -> k) = .... - -- There is no single binding site for 'k'. - -- See Note [Source locations for implicitly bound type variables] - -- in GHC.Tc.Rename.HsType - -{- See Note [kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a kind signature 'sig_kind' and a declaration header, -kcCheckDeclHeader_sig verifies that the declaration conforms to the -signature. The end result is a PolyTcTyCon 'tc' such that: - tyConKind tc == sig_kind - -Basic plan is this: - * splitTyConKind: Take the Kind from the separate kind signature, and - decompose it all the way to a [TyConBinder] and a Kind in the corner. - - NB: these TyConBinders contain TyVars, not TcTyVars. - - * matchUpSigWithDecl: match the [TyConBinder] from the signature with - the [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] from the declaration. The latter are the - explicit, user-written binders. e.g. - data T (a :: k) b = .... - There may be more of the former than the latter, because the former - include invisible binders. matchUpSigWithDecl uses isVisibleTcbVis - to decide which TyConBinders are visible. - - * matchUpSigWithDecl also skolemises the [TyConBinder] to produce - a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder]. - Each new TyConBinder - - Uses the Name from the LHsTyVarBndr, if available, both because that's - what the user expects, and because the binding site accurately comes - from the data/type declaration. - - Uses a skolem TcTyVar. We need these to allow unification. - - * machUpSigWithDecl also unifies the user-supplied kind signature for each - LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming - from the separate kind signature). - - * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate - signature with the kind signature (if any) in the data/type declaration. - E.g. - type S :: forall k. k -> k -> Type - type family S (a :: j) :: j -> Type - Here we match up the 'k ->' with (a :: j); and then must unify the leftover - part of the signature (k -> Type) with the kind signature of the decl, - (j -> Type). This unification, done in kcCheckDeclHeader, needs TcTyVars. - - * The tricky extra_arity part is described in - Note [Arity inference in kcCheckDeclHeader_sig] - -Note [Arity inference in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider these declarations: - type family S1 :: forall k2. k1 -> k2 -> Type - type family S2 (a :: k1) (b :: k2) :: Type - -Both S1 and S2 can be given the same standalone kind signature: - type S1 :: forall k1 k2. k1 -> k2 -> Type - type S2 :: forall k1 k2. k1 -> k2 -> Type - -And, indeed, tyConKind S1 == tyConKind S2. However, -tyConBinders and tyConResKind for S1 and S2 are different: - - tyConBinders S1 == [spec k1] - tyConResKind S1 == forall k2. k1 -> k2 -> Type - tyConKind S1 == forall k1 k2. k1 -> k2 -> Type - - tyConBinders S2 == [spec k1, spec k2, anon-vis (a :: k1), anon-vis (b :: k2)] - tyConResKind S2 == Type - tyConKind S1 == forall k1 k2. k1 -> k2 -> Type - -This difference determines the /arity/: - tyConArity tc == length (tyConBinders tc) -That is, the arity of S1 is 1, while the arity of S2 is 4. - -'kcCheckDeclHeader_sig' needs to infer the desired arity, to split the -standalone kind signature into binders and the result kind. It does so -in two rounds: - -1. matchUpSigWithDecl matches up - - the [TyConBinder] from (applying splitTyConKind to) the kind signature - - with the [LHsTyVarBndr] from the type declaration. - That may leave some excess TyConBinder: in the case of S2 there are - no excess TyConBinders, but in the case of S1 there are two (since - there are no LHsTYVarBndrs. - -2. Split off further TyConBinders (in the case of S1, one more) to - make it possible to unify the residual return kind with the - signature in the type declaration. More precisely, split off such - enough invisible that the remainder of the standalone kind - signature and the user-written result kind signature have the same - number of invisible quantifiers. - -As another example consider the following declarations: - - type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family F a b - - type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type - type family G a b :: forall r2. (r1, r2) -> Type - -For both F and G, the signature (after splitTyConKind) has - sig_tcbs :: [TyConBinder] - = [ anon-vis (@a_aBq), spec (@j_auA), anon-vis (@(b_aBr :: j_auA)) - , spec (@k1_auB), spec (@k2_auC) - , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))] - -matchUpSigWithDecl will consume the first three of these, passing on - excess_sig_tcbs - = [ spec (@k1_auB), spec (@k2_auC) - , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))] - -For F, there is no result kind signature in the declaration for F, so -we absorb all invisible binders into F's arity. The resulting arity of -F is 3+2=5. - -Now, in the case of G, we have a result kind sig 'forall r2. (r2,r2)->Type'. -This has one invisible binder, so we split of enough extra binders from -our excess_sig_tcbs to leave just one to match 'r2'. - - res_ki = forall r2. (r1, r2) -> Type - kisig = forall k1 k2. (k1, k2) -> Type - ^^^ - split off this one. - -The resulting arity of G is 3+1=4. - -Note [discardResult in kcCheckDeclHeader_sig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use 'unifyKind' to check inline kind annotations in declaration headers -against the signature. - - type T :: [i] -> Maybe j -> Type - data T (a :: [k1]) (b :: Maybe k2) :: Type where ... - -Here, we will unify: - - [k1] ~ [i] - Maybe k2 ~ Maybe j - Type ~ Type - -The end result is that we fill in unification variables k1, k2: - - k1 := i - k2 := j - -We also validate that the user isn't confused: - - type T :: Type -> Type - data T (a :: Bool) = ... - -This will report that (Type ~ Bool) failed to unify. - -Now, consider the following example: - - type family Id a where Id x = x - type T :: Bool -> Type - type T (a :: Id Bool) = ... - -We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. -However, we are free to discard it, as the kind of 'T' is determined by the -signature, not by the inline kind annotation: - - we have T :: Bool -> Type - rather than T :: Id Bool -> Type - -This (Id Bool) will not show up anywhere after we're done validating it, so we -have no use for the produced coercion. - -Note [Kind variable ordering for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should be the kind of `T` in the following example? (#15591) - - class C (a :: Type) where - type T (x :: f a) - -As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify -the kind variables in left-to-right order of first occurrence in order to -support visible kind application. But we cannot perform this analysis on just -T alone, since its variable `a` actually occurs /before/ `f` if you consider -the fact that `a` was previously bound by the parent class `C`. That is to say, -the kind of `T` should end up being: - - T :: forall a f. f a -> Type - -(It wouldn't necessarily be /wrong/ if the kind ended up being, say, -forall f a. f a -> Type, but that would not be as predictable for users of -visible kind application.) - -In contrast, if `T` were redefined to be a top-level type family, like `T2` -below: - - type family T2 (x :: f (a :: Type)) - -Then `a` first appears /after/ `f`, so the kind of `T2` should be: - - T2 :: forall f a. f a -> Type - -In order to make this distinction, we need to know (in kcCheckDeclHeader) which -type variables have been bound by the parent class (if there is one). With -the class-bound variables in hand, we can ensure that we always quantify -these first. --} - - -{- ********************************************************************* -* * - Expected kinds -* * -********************************************************************* -} - --- | Describes the kind expected in a certain context. -data ContextKind = TheKind TcKind -- ^ a specific kind - | AnyKind -- ^ any kind will do - | OpenKind -- ^ something of the form @TYPE _@ - ------------------------ -newExpectedKind :: ContextKind -> TcM TcKind -newExpectedKind (TheKind k) = return k -newExpectedKind AnyKind = newMetaKindVar -newExpectedKind OpenKind = newOpenTypeKind - ------------------------ -expectedKindInCtxt :: UserTypeCtxt -> ContextKind --- Depending on the context, we might accept any kind (for instance, in a TH --- splice), or only certain kinds (like in type signatures). -expectedKindInCtxt (TySynCtxt _) = AnyKind -expectedKindInCtxt (GhciCtxt {}) = AnyKind --- The types in a 'default' decl can have varying kinds --- See Note [Extended defaults]" in GHC.Tc.Utils.Env -expectedKindInCtxt DefaultDeclCtxt = AnyKind -expectedKindInCtxt DerivClauseCtxt = AnyKind -expectedKindInCtxt TypeAppCtxt = AnyKind -expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind -expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind -expectedKindInCtxt SpecInstCtxt = TheKind constraintKind -expectedKindInCtxt _ = OpenKind - - -{- ********************************************************************* -* * - Scoped tyvars that map to the same thing -* * -********************************************************************* -} - -checkForDisconnectedScopedTyVars :: TyConFlavour TyCon -> [TcTyConBinder] - -> [(Name,TcTyVar)] -> TcM () --- See Note [Disconnected type variables] --- `scoped_prs` is the mapping gotten by unifying --- - the standalone kind signature for T, with --- - the header of the type/class declaration for T -checkForDisconnectedScopedTyVars flav sig_tcbs scoped_prs - = when (needsEtaExpansion flav) $ - -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables] - mapM_ report_disconnected (filterOut ok scoped_prs) - where - sig_tvs = mkVarSet (binderVars sig_tcbs) - ok (_, tc_tv) = tc_tv `elemVarSet` sig_tvs - - report_disconnected :: (Name,TcTyVar) -> TcM () - report_disconnected (nm, _) - = setSrcSpan (getSrcSpan nm) $ - addErrTc $ TcRnDisconnectedTyVar nm - -checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () --- Check for duplicates --- See Note [Aliasing in type and class declarations] -checkForDuplicateScopedTyVars scoped_prs - = unless (null err_prs) $ - do { mapM_ report_dup err_prs; failM } - where - -------------- Error reporting ------------ - err_prs :: [(Name,Name)] - err_prs = [ (n1,n2) - | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs - , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ] - -- This nubBy avoids bogus error reports when we have - -- [("f", f), ..., ("f",f)....] in swizzle_prs - -- which happens with class C f where { type T f } - - report_dup :: (Name,Name) -> TcM () - report_dup (n1,n2) - = setSrcSpan (getSrcSpan n2) $ - addErrTc $ TcRnDifferentNamesForTyVar n1 n2 - - -{- Note [Aliasing in type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data SameKind (a::k) (b::k) - data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c -We do not allow this, because `k1` and `k2` would both stand for the same type -variable -- they are both aliases for `k`. - -Other examples - data T2 (a::k1) = MkT2 (SameKind a Int) -- k1 stands for Type - data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b) -- k1 and k2 are aliases - - type UF :: forall zk. zk -> Constraint - class UF @kk (xb :: k) where -- kk and k are aliases - op :: (xs::kk) -> Bool - -See #24604 for an example that crashed GHC. - -There is a design choice here. It would be possible to allow implicit type variables -like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/. This is in fact -the rule we use in /terms/ pattern signatures: - f :: [Int] -> Int - f ((x::a) : xs) = ... -Here `a` stands for `Int`. But in type /signatures/ we make a different choice: - f1 :: forall (a::k1) (b::k2). SameKind a b -> blah - f2 :: forall (a::k). SameKind a Int -> blah - -Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is -rejected because `k` stands for `Int`. - -Our current choice is that type and class declarations behave more like signatures; -we do not allow aliasing. That is what `checkForDuplicateScopedTyVars` checks. -See !12328 for some design discussion. - - -Note [Disconnected type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note applies when kind-checking the header of a type/class decl that has -a separate, standalone kind signature. See #24083. - -Consider: - type S a = Type - - type C :: forall k. S k -> Constraint - class C (a :: S kk) where - op :: ...kk... - -Note that the class has a separate kind signature, so the elaborated decl should -look like - class C @kk (a :: S kk) where ... - -But how can we "connect up" the scoped variable `kk` with the skolem kind from the -standalone kind signature for `C`? In general we do this by unifying the two. -For example - type T k = (k,Type) - type W :: forall k. T k -> Type - data W (a :: (x,Type)) = ..blah blah.. - -When we encounter (a :: (x,Type)) we unify the kind (x,Type) with the kind (T k) -from the standalone kind signature. Of course, unification looks through synonyms -so we end up with the mapping [x :-> k] that connects the scoped type variable `x` -with the kind from the signature. - -But in our earlier example this unification is ineffective -- because `S` is a -phantom synonym that just discards its argument. So our plan is this: - - if matchUpSigWithDecl fails to connect `kk with `k`, by unification, - we give up and complain about a "disconnected" type variable. - -See #24083 for dicussion of alternatives, none satisfactory. Also the fix is -easy: just add an explicit `@kk` parameter to the declaration, to bind `kk` -explicitly, rather than binding it implicitly via unification. - -(DTV1) We only want to make this check when there /are/ scoped type variables; and - that is determined by needsEtaExpansion. Examples: - - type C :: x -> y -> Constraint - class C a :: b -> Constraint where { ... } - -- The a,b scope over the "..." - - type D :: forall k. k -> Type - data family D :: kk -> Type - -- Nothing for `kk` to scope over! - - In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will - return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do - the check-for-disconnected-tyvars check we'll complain that `kk` is not bound - to one of `all_tcbs` (see #24083, comments about the `singletons` package). - - The scoped-tyvar stuff is needed precisely for data/class/newtype declarations, - where needsEtaExpansion is True. --} - -{- ********************************************************************* -* * - Bringing type variables into scope -* * -********************************************************************* -} - --------------------------------------- --- HsForAllTelescope --------------------------------------- - -tcTKTelescope :: TcTyMode - -> HsForAllTelescope GhcRn - -> TcM a - -> TcM ([TcTyVarBinder], a) --- A HsForAllTelescope comes only from a HsForAllTy, --- an explicit, user-written forall type -tcTKTelescope mode tele thing_inside = case tele of - HsForAllVis { hsf_vis_bndrs = bndrs } - -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) - ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode - , sm_tvtv = SMDSkolemTv skol_info } - ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside - -- req_tv_bndrs :: [VarBndr TyVar ()], - -- but we want [VarBndr TyVar ForAllTyFlag] - ; return (tyVarReqToBinders req_tv_bndrs, thing) } - - HsForAllInvis { hsf_invis_bndrs = bndrs } - -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) - ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode - , sm_tvtv = SMDSkolemTv skol_info } - ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside - -- inv_tv_bndrs :: [VarBndr TyVar Specificity], - -- but we want [VarBndr TyVar ForAllTyFlag] - ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } - --------------------------------------- --- HsOuterTyVarBndrs --------------------------------------- - -bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc - => SkolemMode - -> HsOuterTyVarBndrs flag GhcRn - -> TcM a - -> TcM (HsOuterTyVarBndrs flag GhcTc, a) -bindOuterTKBndrsX skol_mode outer_bndrs thing_inside - = case outer_bndrs of - HsOuterImplicit{hso_ximplicit = imp_tvs} -> - do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside - ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} - , thing) } - HsOuterExplicit{hso_bndrs = exp_bndrs} -> - do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside - ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' - , hso_bndrs = exp_bndrs } - , thing) } - ---------------- -outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] --- The returned [TcTyVar] is not necessarily in dependency order --- at least for the HsOuterImplicit case -outerTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs -outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs - ---------------- -outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder] -outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs] -outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs - ---------------- -scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc) --- Sort any /implicit/ binders into dependency order --- (zonking first so we can see the dependencies) --- /Explicit/ ones are already in the right order -scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs}) - = do { imp_tvs <- zonkAndScopedSort imp_tvs - ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) } -scopedSortOuter bndrs@(HsOuterExplicit{}) - = -- No need to dependency-sort (or zonk) explicit quantifiers - return bndrs - ---------------- -bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn - -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) -bindOuterSigTKBndrs_Tv - = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) - -bindOuterSigTKBndrs_Tv_M :: TcTyMode - -> HsOuterSigTyVarBndrs GhcRn - -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) --- Do not push level; do not make implication constraint; use Tvs --- Two major clients of this "bind-only" path are: --- Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl --- Note [Checking partial type signatures] -bindOuterSigTKBndrs_Tv_M mode - = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv - , sm_holes = mode_holes mode }) - -bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn - -> TcM a - -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) -bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside - = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = SMDTyVarTv }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - -bindOuterFamEqnTKBndrs :: SkolemInfo - -> HsOuterFamEqnTyVarBndrs GhcRn - -> TcM a - -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) -bindOuterFamEqnTKBndrs skol_info - = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = SMDSkolemTv skol_info }) - -- sm_clone=False: see Note [Cloning for type variable binders] - ---------------- -tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc - => SkolemInfo - -> HsOuterTyVarBndrs flag GhcRn - -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) -tcOuterTKBndrs skol_info - = tcOuterTKBndrsX (smVanilla { sm_clone = False - , sm_tvtv = SMDSkolemTv skol_info }) - skol_info - -- Do not clone the outer binders - -- See Note [Cloning for type variable binders] under "must not" - -tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc - => SkolemMode -> SkolemInfo - -> HsOuterTyVarBndrs flag GhcRn - -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) --- Push level, capture constraints, make implication -tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside - = case outer_bndrs of - HsOuterImplicit{hso_ximplicit = imp_tvs} -> - do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside - ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} - , thing) } - HsOuterExplicit{hso_bndrs = exp_bndrs} -> - do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside - ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' - , hso_bndrs = exp_bndrs } - , thing) } - --------------------------------------- --- Explicit tyvar binders --------------------------------------- - -tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc - => SkolemInfo - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) -tcExplicitTKBndrs skol_info - = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) - -tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc - => SkolemMode - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) --- Push level, capture constraints, and emit an implication constraint. --- The implication constraint has a ForAllSkol ic_info, --- so that it is subject to a telescope test. -tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of - Nothing -> do - { res <- thing_inside - ; return ([], res) } - - Just bndrs1 -> do - { (tclvl, wanted, (skol_tvs, res)) - <- pushLevelAndCaptureConstraints $ - bindExplicitTKBndrsX skol_mode bndrs $ - thing_inside - - -- Set up SkolemInfo for telescope test - ; let bndr_1 = NE.head bndrs1; bndr_n = NE.last bndrs1 - ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) - -- Notice that we use ForAllSkol here, ignoring the enclosing - -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope - -- test applies only to ForAllSkol - - ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n)) - $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted - - ; return (skol_tvs, res) } - ----------------- --- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied --- 'TcTyMode'. -bindExplicitTKBndrs_Skol - :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc - => SkolemInfo - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) - -bindExplicitTKBndrs_Tv - :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc - => [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) - -bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info }) -bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) - -- sm_clone: see Note [Cloning for type variable binders] - -bindExplicitTKBndrs_Q_Skol - :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc - => SkolemInfo - -> ContextKind - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) - -bindExplicitTKBndrs_Q_Tv - :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc - => ContextKind - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) --- These do not clone: see Note [Cloning for type variable binders] -bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside - = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - -bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside - = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True - , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) - hs_bndrs thing_inside - -- sm_clone=False: see Note [Cloning for type variable binders] - -bindExplicitTKBndrsX - :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc - => SkolemMode - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed-in [LHsTyVarBndr] -bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind - , sm_holes = hole_info }) - hs_tvs thing_inside - = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs) - ; go hs_tvs } - where - tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info } - -- Inherit the HoleInfo from the context - - go [] = do { res <- thing_inside - ; return ([], res) } - go (L _ hs_tv : hs_tvs) - = do { lcl_env <- getLclTypeEnv - ; tv <- tc_hs_bndr lcl_env hs_tv - -- Extend the environment as we go, in case a binder - -- is mentioned in the kind of a later binder - -- 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)] $ - go hs_tvs - ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } - - - tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name)) - | check_parent - , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name - = return tv - | otherwise - = do { kind <- newExpectedKind ctxt_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 } - - | otherwise - = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind - ; newTyVarBndr skol_mode name kind } - -newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar -newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind - = do { name <- case clone of - True -> do { uniq <- newUnique - ; return (setNameUnique name uniq) } - False -> return name - ; details <- case tvtv of - SMDTyVarTv -> newMetaDetails TyVarTv - SMDSkolemTv skol_info -> - do { lvl <- getTcLevel - ; return (SkolemTv skol_info lvl False) } - ; return (mkTcTyVar name kind details) } - --------------------------------------- --- Implicit tyvar binders --------------------------------------- - -tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo - -> [Name] - -> TcM a - -> TcM ([TcTyVar], a) --- The workhorse: --- push level, capture constraints, and emit an implication constraint -tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside - | null bndrs -- Short-cut the common case with no quantifiers - -- E.g. f :: Int -> Int - -- makes a HsOuterImplicit with empty bndrs, - -- and tcOuterTKBndrsX goes via here - = do { res <- thing_inside; return ([], res) } - | otherwise - = do { (tclvl, wanted, (skol_tvs, res)) - <- pushLevelAndCaptureConstraints $ - bindImplicitTKBndrsX skol_mode bndrs $ - thing_inside - - ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted - - ; return (skol_tvs, res) } - ------------------- -bindImplicitTKBndrs_Skol, - bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a) - -bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a) -bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) -bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) -bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info }) -bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv }) - -bindImplicitTKBndrsX - :: SkolemMode - -> [Name] -- Generated by renamer; not in dependency order - -> TcM a - -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence - -- with the passed in [Name] -bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind }) - tv_names thing_inside - = do { lcl_env <- getLclTypeEnv - ; tkvs <- mapM (new_tv lcl_env) tv_names - ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs) - ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) - thing_inside - ; return (tkvs, res) } - where - new_tv lcl_env name - | check_parent - , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name - = return tv - | otherwise - = do { kind <- newExpectedKind ctxt_kind - ; newTyVarBndr skol_mode name kind } - --------------------------------------- --- SkolemMode --------------------------------------- - --- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or --- implicit ('Name') binder in a type. It is just a record of flags --- that describe what sort of 'TcTyVar' to create. -data SkolemMode - = SM { sm_parent :: Bool -- True <=> check the in-scope parent type variable - -- Used only for asssociated types - - , sm_clone :: Bool -- True <=> fresh unique - -- See Note [Cloning for type variable binders] - - , sm_tvtv :: SkolemModeDetails -- True <=> use a TyVarTv, rather than SkolemTv - -- Why? See Note [Inferring kinds for type declarations] - -- in GHC.Tc.TyCl, and (in this module) - -- Note [Checking partial type signatures] - - , sm_kind :: ContextKind -- Use this for the kind of any new binders - - , sm_holes :: HoleInfo -- What to do for wildcards in the kind - } - -data SkolemModeDetails - = SMDTyVarTv - | SMDSkolemTv SkolemInfo - - -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 - , sm_kind = AnyKind - , sm_holes = Nothing } - -{- Note [Cloning for type variable binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes we must clone the Name of a type variable binder (written in -the source program); and sometimes we must not. This is controlled by -the sm_clone field of SkolemMode. - -In some cases it doesn't matter whether or not we clone. Perhaps -it'd be better to use MustClone/MayClone/MustNotClone. - -When we /must not/ clone -* In the binders of a type signature (tcOuterTKBndrs) - f :: forall a{27}. blah - f = rhs - Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType), - we must get the type (forall a{27}. blah) for the Id f, because - we bring that type variable into scope when we typecheck 'rhs'. - -* In the binders of a data family instance (bindOuterFamEqnTKBndrs) - data instance - forall p q. D (p,q) = D1 p | D2 q - We kind-check the LHS in tcDataFamInstHeader, and then separately - (in tcDataFamInstDecl) bring p,q into scope before looking at the - the constructor decls. - -* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone - We take advantage of this in kcInferDeclHeader: - all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) - If we cloned, we'd need to take a bit more care here; not hard. - -* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone. - There is no need, I think. - - The payoff here is that avoiding gratuitous cloning means that we can - almost always take the fast path in swizzleTcTyConBndrs. - -When we /must/ clone. -* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning - - This for a narrow and tricky reason which, alas, I couldn't find a - simpler way round. #16221 is the poster child: - - data SameKind :: k -> k -> * - data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int - - When kind-checking T, we give (a :: kappa1). Then: - - - In kcConDecl we make a TyVarTv unification variable kappa2 for k2 - (as described in Note [Using TyVarTvs for kind-checking GADTs], - even though this example is an existential) - - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv - - We end up unifying kappa1 := kappa2, because of the (SameKind a b) - - Now we generalise over kappa2. But if kappa2's Name is precisely k2 - (i.e. we did not clone) we'll end up giving T the utterly final kind - T :: forall k2. k2 -> * - Nothing directly wrong with that but when we typecheck the data constructor - we have k2 in scope; but then it's brought into scope /again/ when we find - the forall k2. This is chaotic, and we end up giving it the type - MkT :: forall k2 (a :: k2) k2 (b :: k2). - SameKind @k2 a b -> Int -> T @{k2} a - which is bogus -- because of the shadowing of k2, we can't - apply T to the kind or a! - - And there no reason /not/ to clone the Name when making a unification - variable. So that's what we do. --} - --------------------------------------- --- Binding type/class variables in the --- kind-checking and typechecking phases --------------------------------------- - -bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a --- ^ Bring into scope the binders of a PolyTcTyCon --- Used for the type variables of a type or class decl --- in the "kind checking" and "type checking" pass, --- but not in the initial-kind run. -bindTyClTyVars tycon_name thing_inside - = do { tycon <- tcLookupTcTyCon tycon_name -- The tycon is a PolyTcTyCon - ; let res_kind = tyConResKind tycon - binders = tyConBinders tycon - ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders) - ; tcExtendTyVarEnv (binderVars binders) $ - thing_inside binders res_kind } - -bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a --- Like bindTyClTyVars, but in addition --- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars --- We always do this same zonking after a call to bindTyClTyVars, but --- here we do it right away because there are no more unifications to come -bindTyClTyVarsAndZonk tycon_name thing_inside - = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind -> - do { (bndrs, kind) <- initZonkEnv NoFlexi $ - runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> - do { kind <- zonkTcTypeToTypeX tc_kind - ; return (bndrs, kind) } - ; thing_inside bndrs kind } - - -{- ********************************************************************* -* * - Kind generalisation -* * -********************************************************************* -} - -zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] -zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- liftZonkM $ zonkTcTyVarsToTcTyVars spec_tkvs - -- Zonk the kinds, to we can do the dependency analysis - - -- Do a stable topological sort, following - -- Note [Ordering of implicit variables] in GHC.Rename.HsType - ; return (scopedSort spec_tkvs) } - --- | Generalize some of the free variables in the given type. --- All such variables should be *kind* variables; any type variables --- should be explicitly quantified (with a `forall`) before now. --- --- The WantedConstraints are un-solved kind constraints. Generally --- they'll be reported as errors later, but meanwhile we refrain --- from quantifying over any variable free in these unsolved --- constraints. See Note [Failure in local type signatures]. --- --- But in all cases, generalize only those variables whose TcLevel is --- strictly greater than the ambient level. This "strictly greater --- than" means that you likely need to push the level before creating --- whatever type gets passed here. --- --- Any variable whose level is greater than the ambient level but is --- not selected to be generalized will be promoted. (See [Promoting --- unification variables] in "GHC.Tc.Solver" and Note [Recipe for --- checking a signature].) --- --- The resulting KindVar are the variables to quantify over, in the --- correct, well-scoped order. They should generally be Inferred, not --- Specified, but that's really up to the caller of this function. -kindGeneralizeSome :: SkolemInfo - -> WantedConstraints - -> TcType -- ^ needn't be zonked - -> TcM [KindVar] -kindGeneralizeSome skol_info wanted kind_or_type - = do { -- Use the "Kind" variant here, as any types we see - -- here will already have all type variables quantified; - -- thus, every free variable is really a kv, never a tv. - ; dvs <- candidateQTyVarsOfKind kind_or_type - ; filtered_dvs <- filterConstrainedCandidates wanted dvs - ; traceTc "kindGeneralizeSome" $ - vcat [ text "type:" <+> ppr kind_or_type - , text "dvs:" <+> ppr dvs - , text "filtered_dvs:" <+> ppr filtered_dvs ] - ; quantifyTyVars skol_info DefaultNonStandardTyVars filtered_dvs } - -filterConstrainedCandidates - :: WantedConstraints -- Don't quantify over variables free in these - -- Not necessarily fully zonked - -> CandidatesQTvs -- Candidates for quantification - -> TcM CandidatesQTvs --- filterConstrainedCandidates removes any candidates that are free in --- 'wanted'; instead, it promotes them. This bit is very much like --- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much --- simpler in kinds, it is much easier here. (In particular, we never --- quantify over a constraint in a type.) -filterConstrainedCandidates wanted dvs - | isEmptyWC wanted -- Fast path for a common case - = return dvs - | otherwise - = do { wc_tvs <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) - ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) - ; _ <- promoteTyVarSet to_promote - ; return dvs' } - --- |- Specialised version of 'kindGeneralizeSome', but with empty --- WantedConstraints, so no filtering is needed --- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC -kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar] -kindGeneralizeAll skol_info kind_or_type - = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) - ; dvs <- candidateQTyVarsOfKind kind_or_type - ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } - --- | Specialized version of 'kindGeneralizeSome', but where no variables --- can be generalized, but perhaps some may need to be promoted. --- Use this variant when it is unknowable whether metavariables might --- later be constrained. --- --- To see why this promotion is needed, see --- Note [Recipe for checking a signature], and especially --- Note [Promotion in signatures]. -kindGeneralizeNone :: TcType -- needn't be zonked - -> TcM () -kindGeneralizeNone kind_or_type - = do { traceTc "kindGeneralizeNone" (ppr kind_or_type) - ; dvs <- candidateQTyVarsOfKind kind_or_type - ; _ <- promoteTyVarSet (candidateKindVars dvs) - ; return () } - -{- Note [Levels and generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = e -with no type signature. We are currently at level i. -We must - * Push the level to level (i+1) - * Allocate a fresh alpha[i+1] for the result type - * Check that e :: alpha[i+1], gathering constraint WC - * Solve WC as far as possible - * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] - * Find the free variables with level > i, in this case gamma[i] - * Skolemise those free variables and quantify over them, giving - f :: forall g. beta[i-1] -> g - * Emit the residual constraint wrapped in an implication for g, - thus forall g. WC - -All of this happens for types too. Consider - f :: Int -> (forall a. Proxy a -> Int) - -Note [Kind generalisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do kind generalisation only at the outer level of a type signature. -For example, consider - T :: forall k. k -> * - f :: (forall a. T a -> Int) -> Int -When kind-checking f's type signature we generalise the kind at -the outermost level, thus: - f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! -and *not* at the inner forall: - f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! -Reason: same as for HM inference on value level declarations, -we want to infer the most general type. The f2 type signature -would be *less applicable* than f1, because it requires a more -polymorphic argument. - -NB: There are no explicit kind variables written in f's signature. -When there are, the renamer adds these kind variables to the list of -variables bound by the forall, so you can indeed have a type that's -higher-rank in its kind. But only by explicit request. - -Note [Kinds of quantified type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyVarBndrsGen quantifies over a specified list of type variables, -*and* over the kind variables mentioned in the kinds of those tyvars. - -Note that we must zonk those kinds (obviously) but less obviously, we -must return type variables whose kinds are zonked too. Example - (a :: k7) where k7 := k9 -> k9 -We must return - [k9, a:k9->k9] -and NOT - [k9, a:k7] -Reason: we're going to turn this into a for-all type, - forall k9. forall (a:k7). blah -which the type checker will then instantiate, and instantiate does not -look through unification variables! - -Hence using zonked_kinds when forming tvs'. - --} - ------------------------------------ -etaExpandAlgTyCon :: TyConFlavour tc -> SkolemInfo - -> [TcTyConBinder] -> Kind - -> TcM ([TcTyConBinder], Kind) -etaExpandAlgTyCon flav skol_info tcbs res_kind - | needsEtaExpansion flav - = splitTyConKind skol_info in_scope avoid_occs res_kind - | otherwise - = return ([], res_kind) - where - tyvars = binderVars tcbs - in_scope = mkInScopeSetList tyvars - avoid_occs = map getOccName tyvars - -needsEtaExpansion :: TyConFlavour tc -> Bool -needsEtaExpansion NewtypeFlavour = True -needsEtaExpansion DataTypeFlavour = True -needsEtaExpansion ClassFlavour = True -needsEtaExpansion _ = False - -splitTyConKind :: SkolemInfo - -> InScopeSet - -> [OccName] -- Avoid these OccNames - -> Kind -- Must be zonked - -> TcM ([TcTyConBinder], TcKind) --- GADT decls can have a (perhaps partial) kind signature --- e.g. data T a :: * -> * -> * where ... --- This function makes up suitable (kinded) TyConBinders for the --- argument kinds. E.g. in this case it might return --- ([b::*, c::*], *) --- Skolemises the type as it goes, returning skolem TcTyVars --- Never emits constraints. --- It's a little trickier than you might think: see Note [splitTyConKind] --- See also Note [Datatype return kinds] in GHC.Tc.TyCl -splitTyConKind skol_info in_scope avoid_occs kind - = do { loc <- getSrcSpanM - ; new_uniqs <- getUniquesM - ; rdr_env <- getLocalRdrEnv - ; lvl <- getTcLevel - ; let new_occs = Inf.filter (\ occ -> - isNothing (lookupLocalRdrOcc rdr_env occ) && - -- Note [Avoid name clashes for associated data types] - not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings - subst = mkEmptySubst in_scope - details = SkolemTv skol_info (pushTcLevel lvl) False - -- As always, allocate skolems one level in - - go occs uniqs subst acc kind - = case splitPiTy_maybe kind of - Nothing -> (reverse acc, substTy subst kind) - - Just (Anon arg af, kind') - -> assert (af == FTF_T_T) $ - go occs' uniqs' subst' (tcb : acc) kind' - where - tcb = Bndr tv AnonTCB - arg' = substTy subst (scaledThing arg) - name = mkInternalName uniq occ loc - tv = mkTcTyVar name arg' details - subst' = extendSubstInScope subst tv - uniq:uniqs' = uniqs - Inf occ occs' = occs - - Just (Named (Bndr tv vis), kind') - -> go occs uniqs subst' (tcb : acc) kind' - where - tcb = Bndr tv' (NamedTCB vis) - tc_tyvar = mkTcTyVar (tyVarName tv) (tyVarKind tv) details - (subst', tv') = substTyVarBndr subst tc_tyvar - - ; return (go new_occs new_uniqs subst [] kind) } - -isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool -isAllowedDataResKind AnyTYPEKind kind = isTypeLikeKind kind -isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind -isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind - --- | Checks that the return kind in a data declaration's kind signature is --- permissible. There are three cases: --- --- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ --- declaration, check that the return kind is @Type@. --- --- If the declaration is a @newtype@ or @newtype instance@ and the --- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so --- that a return kind of the form @TYPE r@ (for some @r@) is permitted. --- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". --- --- If dealing with a @data family@ declaration, check that the return kind is --- either of the form: --- --- 1. @TYPE r@ (for some @r@), or --- --- 2. @k@ (where @k@ is a bare kind variable; see #12369) --- --- See also Note [Datatype return kinds] in "GHC.Tc.TyCl" -checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped off - -> TcM () -checkDataKindSig data_sort kind - = do { dflags <- getDynFlags - ; traceTc "checkDataKindSig" (ppr kind) - ; checkTc (tYPE_ok dflags || is_kind_var) - (err_msg dflags) } - where - res_kind = snd (tcSplitPiTys kind) - -- Look for the result kind after - -- peeling off any foralls and arrows - - is_newtype :: Bool - is_newtype = - case data_sort of - DataDeclSort new_or_data -> new_or_data == NewType - DataInstanceSort new_or_data -> new_or_data == NewType - DataFamilySort -> False - - is_datatype :: Bool - is_datatype = - case data_sort of - DataDeclSort DataType -> True - DataInstanceSort DataType -> True - _ -> False - - is_data_family :: Bool - is_data_family = - case data_sort of - DataDeclSort{} -> False - DataInstanceSort{} -> False - DataFamilySort -> True - - allowed_kind :: DynFlags -> AllowedDataResKind - allowed_kind dflags - | is_newtype && xopt LangExt.UnliftedNewtypes dflags - -- With UnliftedNewtypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE r` since we don't want to accept - -- Constraint or Nat. - -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. - = AnyTYPEKind - | is_data_family - -- If this is a `data family` declaration, we don't need to check if - -- UnliftedNewtypes is enabled, since data family declarations can - -- have return kind `TYPE r` unconditionally (#16827). - = AnyTYPEKind - | is_datatype && xopt LangExt.UnliftedDatatypes dflags - -- With UnliftedDatatypes, we allow kinds other than Type, but they - -- must still be of the form `TYPE (BoxedRep l)`, so that we don't - -- accept result kinds like `TYPE IntRep`. - -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl. - = AnyBoxedKind - | otherwise - = LiftedKind - - tYPE_ok :: DynFlags -> Bool - tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind - - -- In the particular case of a data family, permit a return kind of the - -- form `:: k` (where `k` is a bare kind variable). - is_kind_var :: Bool - is_kind_var | is_data_family = isJust (getCastedTyVar_maybe res_kind) - | otherwise = False - - err_msg :: DynFlags -> TcRnMessage - err_msg dflags = - TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags) - - ext_hint dflags - | isTypeLikeKind kind - , is_newtype - , not (xopt LangExt.UnliftedNewtypes dflags) - = Just SuggestUnliftedNewtypes - | tcIsBoxedTypeKind kind - , is_datatype - , not (xopt LangExt.UnliftedDatatypes dflags) - = Just SuggestUnliftedDatatypes - | otherwise - = Nothing - --- | Checks that the result kind of a class is exactly `Constraint`, rejecting --- type synonyms and type families that reduce to `Constraint`. See #16826. -checkClassKindSig :: Kind -> TcM () -checkClassKindSig kind = checkTc (isConstraintKind kind) err_msg - where - err_msg :: TcRnMessage - err_msg = TcRnClassKindNotConstraint kind - -tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] --- Result is in 1-1 correspondence with orig_args -tcbVisibilities tc orig_args - = go (tyConKind tc) init_subst orig_args - where - init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) - go _ _ [] - = [] - - go fun_kind subst all_args@(arg : args) - | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind - = case tcb of - Anon _ af -> assert (af == FTF_T_T) $ - AnonTCB : go inner_kind subst args - Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args - where - subst' = extendTCvSubst subst tv arg - - | not (isEmptyTCvSubst subst) - = go (substTy subst fun_kind) init_subst all_args - - | otherwise - = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) - - -{- Note [splitTyConKind] -~~~~~~~~~~~~~~~~~~~~~~~~ -Given - data T (a::*) :: * -> forall k. k -> * -we want to generate the extra TyConBinders for T, so we finally get - (a::*) (b::*) (k::*) (c::k) -The function splitTyConKind generates these extra TyConBinders from -the result kind signature. The same function is also used by -kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of -the TyCon given in a standalone kind signature. E.g. - type T :: forall (a::*). * -> forall k. k -> * - -We need to take care to give the TyConBinders - (a) Uniques that are fresh: the TyConBinders of a TyCon - must have distinct uniques. - - (b) Preferably, OccNames that are fresh. If we happen to re-use - OccNames that are other TyConBinders, we'll get a TyCon with - TyConBinders like [a_72, a_53]; same OccName, different Uniques. - Then when pretty-printing (e.g. in GHCi :info) we'll see - data T a a0 - whereas we'd prefer - data T a b - (NB: the tidying happens in the conversion to Iface syntax, - which happens as part of pretty-printing a TyThing.) - - Using fresh OccNames is not essential; it's cosmetic. - And also see Note [Avoid name clashes for associated data types]. - -For (a) perhaps surprisingly, duplicated uniques can happen, even if -we use fresh uniques for Anon arrows. Consider - data T :: forall k. k -> forall k. k -> * -where the two k's are identical even up to their uniques. Surprisingly, -this can happen: see #14515, #19092,3,4. Then if we use those k's in -as TyConBinders we'll get duplicated uniques. - -For (b) we'd like to avoid OccName clashes with the tyvars declared by -the user before the "::"; in the above example that is 'a'. - -It's reasonably easy to solve all this; just run down the list with a -substitution; hence the recursive 'go' function. But for the Uniques -it has to be done. - -Note [Avoid name clashes for associated data types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider class C a b where - data D b :: * -> * -When typechecking the decl for D, we'll invent an extra type variable -for D, to fill out its kind. Ideally we don't want this type variable -to be 'a', because when pretty printing we'll get - class C a b where - data D b a0 -(NB: the tidying happens in the conversion to Iface syntax, which happens -as part of pretty-printing a TyThing.) - -That's why we look in the LocalRdrEnv to see what's in scope. This is -important only to get nice-looking output when doing ":info C" in GHCi. -It isn't essential for correctness. - - -************************************************************************ -* * - Partial signatures -* * -************************************************************************ - --} - -tcHsPartialSigType - :: UserTypeCtxt - -> LHsSigWcType GhcRn -- The type signature - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , Maybe TcType -- Extra-constraints wildcard - , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with - -- the implicitly and explicitly bound type variables - , TcThetaType -- Theta part - , TcType ) -- Tau part --- See Note [Checking partial type signatures] -tcHsPartialSigType ctxt sig_ty - | HsWC { hswc_ext = sig_wcs, hswc_body = sig_ty } <- sig_ty - , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty - , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty - = addSigCtxt ctxt sig_ty $ - do { mode <- mkHoleMode TypeLevel HM_Sig - ; (outer_bndrs, (wcs, wcx, theta, tau)) - <- solveEqualities "tcHsPartialSigType" $ - -- See Note [Failure in local type signatures] - bindNamedWildCardBinders sig_wcs $ \ wcs -> - bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $ - do { -- Instantiate the type-class context; but if there - -- is an extra-constraints wildcard, just discard it here - (theta, wcx) <- tcPartialContext mode hs_ctxt - - ; ek <- newOpenTypeKind - ; tau <- -- Don't do (addTypeCtxt hs_tau) here else we get - -- In the type - -- In the type signature: foo :: - tc_lhs_type mode hs_tau ek - - ; return (wcs, wcx, theta, tau) } - - ; traceTc "tcHsPartialSigType 2" empty - ; outer_bndrs <- scopedSortOuter outer_bndrs - ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs - ; traceTc "tcHsPartialSigType 3" empty - - -- No kind-generalization here: - ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ - tcMkPhiTy theta $ - tau) - - -- Spit out the wildcards (including the extra-constraints one) - -- as "hole" constraints, so that they'll be reported if necessary - -- See Note [Extra-constraint holes in partial type signatures] - ; mapM_ emitNamedTypeHole wcs - - -- The "tau" from tcHsPartialSigType might very well have some foralls - -- at the top, hidden behind a type synonym. Instantiate them! E.g. - -- type T x = forall b. x -> b -> b - -- f :: forall a. T (a,_) - -- We must instantiate the `forall b` just as we do the `forall a`! - -- Missing this led to #21667. - ; (tv_prs', theta', tau) <- tcInstTypeBndrs tau - - -- We return a proper (Name,InvisTVBinder) environment, to be sure that - -- we bring the right name into scope in the function body. - -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let outer_bndr_names :: [Name] - outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs - tv_prs :: [(Name,InvisTVBinder)] - tv_prs = outer_bndr_names `zip` outer_tv_bndrs - - -- Zonk, so that any nested foralls can "see" their occurrences - -- See Note [Checking partial type signatures], and in particular - -- Note [Levels for wildcards] - ; (tv_prs, theta, tau) <- liftZonkM $ - do { tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs') - ; theta <- mapM zonkTcType (theta ++ theta') - ; tau <- zonkTcType tau - ; return (tv_prs, theta, tau) } - - -- NB: checkValidType on the final inferred type will be - -- done later by checkInferredPolyId. We can't do it - -- here because we don't have a complete type to check - - ; traceTc "tcHsPartialSigType" (ppr tv_prs) - ; return (wcs, wcx, tv_prs, theta, tau) } - -tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType) -tcPartialContext _ Nothing = return ([], Nothing) -tcPartialContext mode (Just (L _ hs_theta)) - | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- setSrcSpanA wc_loc $ - tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind - ; theta <- mapM (tc_lhs_pred mode) hs_theta1 - ; return (theta, Just wc_tv_ty) } - | otherwise - = do { theta <- mapM (tc_lhs_pred mode) hs_theta - ; return (theta, Nothing) } - -{- Note [Checking partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note is about tcHsPartialSigType. See also -Note [Recipe for checking a signature] - -When we have a partial signature like - f :: forall a. a -> _ -we do the following - -* tcHsPartialSigType does not make quantified type (forall a. blah) - and then instantiate it -- it makes no sense to instantiate a type - with wildcards in it. Rather, tcHsPartialSigType just returns the - 'a' and the 'blah' separately. - - Nor, for the same reason, do we push a level in tcHsPartialSigType. - -* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ - a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider - f :: forall a. a -> _ - g :: forall b. _ -> b - f = g - g = f - They are typechecked as a recursive group, with monomorphic types, - so 'a' and 'b' will get unified together. Very like kind inference - for mutually recursive data types (sans CUSKs or SAKS); see - Note [Cloning for type variable binders] - -* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike - the companion CompleteSig) contains the original, as-yet-unchecked - source-code LHsSigWcType - -* Then, for f and g /separately/, we call tcInstSig, which in turn - call tcHsPartialSig (defined near this Note). It kind-checks the - LHsSigWcType, creating fresh unification variables for each "_" - wildcard. It's important that the wildcards for f and g are distinct - because they might get instantiated completely differently. E.g. - f,g :: forall a. a -> _ - f x = a - g x = True - It's really as if we'd written two distinct signatures. - -* Nested foralls. See Note [Levels for wildcards] - -* Just as for ordinary signatures, we must solve local equalities and - zonk the type after kind-checking it, to ensure that all the nested - forall binders can "see" their occurrences - - Just as for ordinary signatures, this zonk also gets any Refl casts - out of the way of instantiation. Example: #18008 had - foo :: (forall a. (Show a => blah) |> Refl) -> _ - and that Refl cast messed things up. See #18062. - -Note [Levels for wildcards] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall b. (forall a. a -> _) -> b -We do /not/ allow the "_" to be instantiated to 'a'; although we do -(as before) allow it to be instantiated to the (top level) 'b'. -Why not? Suppose - f x = (x True, x 'c') - -During typecking the RHS we must instantiate that (forall a. a -> _), -so we must know /precisely/ where all the a's are; they must not be -hidden under (possibly-not-yet-filled-in) unification variables! - -We achieve this as follows: - -- For /named/ wildcards such sas - g :: forall b. (forall la. a -> _x) -> b - there is no problem: we create them at the outer level (ie the - ambient level of the signature itself), and push the level when we - go inside a forall. So now the unification variable for the "_x" - can't unify with skolem 'a'. - -- For /anonymous/ wildcards, such as 'f' above, we carry the ambient - level of the signature to the hole in the TcLevel part of the - mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that - level (and /not/ the level ambient at the occurrence of "_") to - create the unification variable for the wildcard. That is the sole - purpose of the TcLevel in the mode_holes field: to transport the - ambient level of the signature down to the anonymous wildcard - occurrences. - -Note [Extra-constraint holes in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (_) => a -> a - f x = ... - -* The renamer leaves '_' untouched. - -* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in - tcWildCardBinders. - -* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar - with the inferred constraints, e.g. (Eq a, Show a) - -* GHC.Tc.Errors.mkHoleError finally reports the error. - -An annoying difficulty happens if there are more than 64 inferred -constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. -Where do we find the TyCon? For good reasons we only have constraint -tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how -can we make a 70-tuple? This was the root cause of #14217. - -It's incredibly tiresome, because we only need this type to fill -in the hole, to communicate to the error reporting machinery. Nothing -more. So I use a HACK: - -* I make an /ordinary/ tuple of the constraints, in - GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because - ordinary tuples can't contain constraints, but it works fine. And for - ordinary tuples we don't have the same limit as for constraint - tuples (which need selectors and an associated class). - -* Because it is ill-kinded (unifying something of kind Constraint with - something of kind Type), it should trip an assert in writeMetaTyVarRef. - -Result works fine, but it may eventually bite us. - -See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for -information about how these are printed. - -************************************************************************ -* * - Pattern signatures (i.e signatures that occur in patterns) -* * -********************************************************************* -} - -tcHsPatSigType :: UserTypeCtxt - -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. - -> HsPatSigType GhcRn -- The type signature - -> ContextKind -- What kind is expected - -> TcM ( [(Name, TcTyVar)] -- Wildcards - , [(Name, TcTyVar)] -- The new bit of type environment, binding - -- the scoped type variables - , TcType) -- The type --- Used for type-checking type signatures in --- (a) patterns e.g f (x::Int) = e --- (b) RULE forall bndrs e.g. forall (x::Int). f x = x --- See Note [Pattern signature binders and scoping] in GHC.Hs.Type --- --- This may emit constraints --- See Note [Recipe for checking a signature] -tcHsPatSigType ctxt hole_mode - (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } - , hsps_body = hs_ty }) - ctxt_kind - = addSigCtxt ctxt hs_ty $ - do { sig_tkv_prs <- mapM new_implicit_tv sig_ns - ; mode <- mkHoleMode TypeLevel hole_mode - ; (wcs, sig_ty) - <- addTypeCtxt hs_ty $ - solveEqualities "tcHsPatSigType" $ - -- See Note [Failure in local type signatures] - -- and c.f #16033 - bindNamedWildCardBinders sig_wcs $ \ wcs -> - tcExtendNameTyVarEnv sig_tkv_prs $ - do { ek <- newExpectedKind ctxt_kind - ; sig_ty <- tc_lhs_type mode hs_ty ek - ; return (wcs, sig_ty) } - - ; mapM_ emitNamedTypeHole wcs - - -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty - -- contains a forall). Promote these. - -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... - -- When we instantiate x, we have to compare the kind of the argument - -- to a's kind, which will be a metavariable. - -- kindGeneralizeNone does this: - ; kindGeneralizeNone sig_ty - ; sig_ty <- liftZonkM $ zonkTcType sig_ty - ; checkValidType ctxt sig_ty - - ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs) - ; return (wcs, sig_tkv_prs, sig_ty) } - where - new_implicit_tv name - = do { kind <- newMetaKindVar - ; tv <- case ctxt of - RuleSigCtxt rname _ -> do - skol_info <- mkSkolemInfo (RuleSkol rname) - newSkolemTyVar skol_info name kind - _ -> newPatSigTyVar name kind - -- See Note [Typechecking pattern signature binders] - -- NB: tv's Name may be fresh (in the case of newPatSigTyVar) - ; return (name, tv) } - -{- Note [Typechecking pattern signature binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Type variables in the type environment] in GHC.Tc.Utils. -Consider - - data T where - MkT :: forall a. a -> (a -> Int) -> T - - f :: T -> ... - f (MkT x (f :: b -> c)) = - -Here - * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', - It must be a skolem so that it retains its identity, and - GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. - - * The type signature pattern (f :: b -> c) makes fresh meta-tyvars - beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the - environment - - * Then unification makes beta := a_sk, gamma := Int - That's why we must make beta and gamma a MetaTv, - not a SkolemTv, so that it can unify to a_sk (or Int, respectively). - - * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, - so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, - -Another example (#13881): - fl :: forall (l :: [a]). Sing l -> Sing l - fl (SNil :: Sing (l :: [y])) = SNil -When we reach the pattern signature, 'l' is in scope from the -outer 'forall': - "a" :-> a_sk :: * - "l" :-> l_sk :: [a_sk] -We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check -the pattern signature - Sing (l :: [y]) -That unifies y_sig := a_sk. We return from tcHsPatSigType with -the pair ("y" :-> y_sig). - -For RULE binders, though, things are a bit different (yuk). - RULE "foo" forall (x::a) (y::[a]). f x y = ... -Here this really is the binding site of the type variable so we'd like -to use a skolem, so that we get a complaint if we unify two of them -together. Hence the new_implicit_tv function in tcHsPatSigType. - - -************************************************************************ -* * - Checking kinds -* * -************************************************************************ - --} - -unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) -unifyKinds rn_tys act_kinds - = do { kind <- newMetaKindVar - ; let check rn_ty (ty, act_kind) - = checkExpectedKind (unLoc rn_ty) ty act_kind kind - ; tys' <- zipWithM check rn_tys act_kinds - ; return (tys', kind) } - -{- -************************************************************************ -* * - Sort checking kinds -* * -************************************************************************ - -tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. -It does sort checking and desugaring at the same time, in one single pass. --} - -tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tcLHsKindSig ctxt hs_kind - = tc_lhs_kind_sig kindLevelMode ctxt hs_kind - -tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind -tc_lhs_kind_sig mode ctxt hs_kind --- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType --- Result is zonked - = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $ - solveEqualities "tcLHsKindSig" $ - tc_lhs_type mode hs_kind liftedTypeKind - ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) - -- No generalization: - ; kindGeneralizeNone kind - ; kind <- liftZonkM $ zonkTcType kind - -- This zonk is very important in the case of higher rank kinds - -- E.g. #13879 f :: forall (p :: forall z (y::z). ). - -- - -- When instantiating p's kind at occurrences of p in - -- it's crucial that the kind we instantiate is fully zonked, - -- else we may fail to substitute properly - - ; checkValidType ctxt kind - ; traceTc "tcLHsKindSig2" (ppr kind) - ; return kind } - -promotionErr :: Name -> PromotionErr -> TcM a -promotionErr name err - = failWithTc $ TcRnUnpromotableThing name err - -{- -************************************************************************ -* * - Error messages and such -* * -************************************************************************ --} - - --- | Make an appropriate message for an error in a function argument. --- Used for both expressions and types. -funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc -funAppCtxt fun arg arg_no - = hang (hsep [ text "In the", speakNth arg_no, text "argument of", - quotes (ppr fun) <> text ", namely"]) - 2 (quotes (ppr arg)) - --- | Add a "In the data declaration for T" or some such. -addTyConFlavCtxt :: Name -> TyConFlavour tc -> TcM a -> TcM a -addTyConFlavCtxt name flav - = addErrCtxt $ hsep [ text "In the", ppr flav - , text "declaration for", quotes (ppr name) ] +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typechecking user-specified @MonoTypes@ +module GHC.Tc.Gen.HsType ( + -- Type signatures + kcClassSigType, tcClassSigType, + tcHsSigType, tcHsSigWcType, + tcHsPartialSigType, + tcStandaloneKindSig, + funsSigCtxt, addSigCtxt, pprSigCtxt, + + tcHsClsInstType, + tcDefaultDeclClass, tcHsDeriv, tcDerivStrategy, + tcHsTypeApp, + UserTypeCtxt(..), + bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol, + bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol, + bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol, + + bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs, + tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs, + tcGadtConTyVarBndrs, + bindOuterSigTKBndrs_Tv, + tcExplicitTKBndrs, + bindNamedWildCardBinders, + + -- Type checking type and class decls, and instances thereof + bindTyClTyVars, bindTyClTyVarsAndZonk, + tcFamTyPats, + maybeEtaExpandAlgTyCon, tcbVisibilities, + etaExpandAlgTyCon, + + -- tyvars + zonkAndScopedSort, + + -- Kind-checking types + -- No kind generalisation, no checkValidType + InitialKindStrategy(..), + SAKS_or_CUSK(..), + ContextKind(..), + kcDeclHeader, checkForDuplicateScopedTyVars, + tcHsLiftedType, tcHsOpenType, + tcHsLiftedTypeNC, tcHsOpenTypeNC, + tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated, + tcCheckLHsTypeInContext, tcCheckLHsType, + tcHsContext, tcLHsPredType, + + kindGeneralizeAll, + + -- Sort-checking kinds + tcLHsKindSig, checkDataKindSig, DataSort(..), + checkClassKindSig, + + -- Multiplicity + tcMult, + + -- Pattern type signatures + tcHsPatSigType, tcHsTyPat, tcRuleBndrSig, + HoleMode(..), + + -- Utils + tyLitFromLit, tyLitFromOverloadedLit, + + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Hs +import GHC.Rename.Utils +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Validity +import GHC.Tc.Utils.Unify +import GHC.IfaceToCore +import GHC.Tc.Solver +import GHC.Tc.Zonk.Type +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, + tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs, + tcInstTypeBndrs ) +import GHC.Tc.Zonk.TcType + +import GHC.Core.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr + +import GHC.Builtin.Types.Prim +import GHC.Types.Error +import GHC.Types.Name.Env +import GHC.Types.Name.Reader( WithUserRdr(..), lookupLocalRdrOcc ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Types.Name +import GHC.Types.Var.Env +import GHC.Builtin.Types +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Utils.Misc +import GHC.Types.Unique.Supply +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Builtin.Names hiding ( wildCardName ) +import GHC.Driver.DynFlags +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Data.FastString +import GHC.Data.List.Infinite ( Infinite (..) ) +import qualified GHC.Data.List.Infinite as Inf +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Data.Bag( unitBag ) + +import Data.Function ( on ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.List ( mapAccumL ) +import Control.Monad +import Data.Tuple( swap ) +import GHC.Types.SourceText + +{- + ---------------------------- + General notes + ---------------------------- + +Unlike with expressions, type-checking types both does some checking and +desugars at the same time. This is necessary because we often want to perform +equality checks on the types right away, and it would be incredibly painful +to do this on un-desugared types. Luckily, desugared types are close enough +to HsTypes to make the error messages sane. + +During type-checking, we perform as little validity checking as possible. +Generally, after type-checking, you will want to do validity checking, say +with GHC.Tc.Validity.checkValidType. + +Validity checking +~~~~~~~~~~~~~~~~~ +Some of the validity check could in principle be done by the kind checker, +but not all: + +- During desugaring, we normalise by expanding type synonyms. Only + after this step can we check things like type-synonym saturation + e.g. type T k = k Int + type S a = a + Then (T S) is ok, because T is saturated; (T S) expands to (S Int); + and then S is saturated. This is a GHC extension. + +- Similarly, also a GHC extension, we look through synonyms before complaining + about the form of a class or instance declaration + +- Ambiguity checks involve functional dependencies + +Also, in a mutually recursive group of types, we can't look at the TyCon until we've +finished building the loop. So to keep things simple, we postpone most validity +checking until step (3). + +%************************************************************************ +%* * + Check types AND do validity checking +* * +************************************************************************ + +Note [Keeping implicitly quantified variables in order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user implicitly quantifies over variables (say, in a type +signature), we need to come up with some ordering on these variables. +This is done by bumping the TcLevel, bringing the tyvars into scope, +and then type-checking the thing_inside. The constraints are all +wrapped in an implication, which is then solved. Finally, we can +zonk all the binders and then order them with scopedSort. + +It's critical to solve before zonking and ordering in order to uncover +any unifications. You might worry that this eager solving could cause +trouble elsewhere. I don't think it will. Because it will solve only +in an increased TcLevel, it can't unify anything that was mentioned +elsewhere. Additionally, we require that the order of implicitly +quantified variables is manifest by the scope of these variables, so +we're not going to learn more information later that will help order +these variables. + +Note [Recipe for checking a signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind-checking a user-written signature requires several steps: + + 0. Bump the TcLevel + 1. Bind any lexically-scoped type variables. + 2. Generate constraints. + 3. Solve constraints. + 4. Sort any implicitly-bound variables into dependency order + 5. Promote tyvars and/or kind-generalize. + 6. Zonk. + 7. Check validity. + +Very similar steps also apply when kind-checking a type or class +declaration. + +The general pattern looks something like this. (But NB every +specific instance varies in one way or another!) + + do { (tclvl, wanted, (spec_tkvs, ty)) + <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ + bindImplicitTKBndrs_Skol sig_vars $ + + + ; spec_tkvs <- zonkAndScopedSort spec_tkvs + + ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted + + ; let ty1 = mkSpecForAllTys spec_tkvs ty + ; kvs <- kindGeneralizeAll ty1 + + ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) + + ; checkValidType final_ty + +This pattern is repeated many times in GHC.Tc.Gen.HsType, +GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations. In more detail: + +* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel, + calls the thing inside to generate constraints, solves those + constraints as much as possible, returning the residual unsolved + constraints in 'wanted'. + +* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type + variables E.g. when kind-checking f :: forall a. F a -> a we must + bring 'a' into scope before kind-checking (F a -> a) + +* zonkAndScopedSort (Step 4) puts those user-specified variables in + the dependency order. (For "implicit" variables the order is no + user-specified. E.g. forall (a::k1) (b::k2). blah k1 and k2 are + implicitly brought into scope. + +* reportUnsolvedEqualities (Step 3 continued) reports any unsolved + equalities, carefully wrapping them in an implication that binds the + skolems. We can't do that in pushLevelAndSolveEqualitiesX because + that function doesn't have access to the skolems. + +* kindGeneralize (Step 5). See Note [Kind generalisation] + +* The final zonkTcTypeToType must happen after promoting/generalizing, + because promoting and generalizing fill in metavariables. + + +Doing Step 3 (constraint solving) eagerly (rather than building an +implication constraint and solving later) is necessary for several +reasons: + +* Exactly as for Solver.simplifyInfer: when generalising, we solve all + the constraints we can so that we don't have to quantify over them + or, since we don't quantify over constraints in kinds, float them + and inhibit generalisation. + +* Most signatures also bring implicitly quantified variables into + scope, and solving is necessary to get these in the right order + (Step 4) see Note [Keeping implicitly quantified variables in + order]). + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Step 5 of Note [Recipe for checking a signature], namely +kind-generalisation, is done by + kindGeneraliseAll + kindGeneraliseSome + kindGeneraliseNone + +Here, we have to deal with the fact that metatyvars generated in the +type will have a bumped TcLevel, because explicit foralls raise the +TcLevel. To avoid these variables from ever being visible in the +surrounding context, we must obey the following dictum: + + Every metavariable in a type must either be + (A) generalized, or + (B) promoted, or See Note [Promotion in signatures] + (C) a cause to error See Note [Naughty quantification candidates] + in GHC.Tc.Utils.TcMType + +There are three steps (look at kindGeneraliseSome): + +1. candidateQTyVarsOfType finds the free variables of the type or kind, + to generalise + +2. filterConstrainedCandidates filters out candidates that appear + in the unsolved 'wanteds', and promotes the ones that get filtered out + thereby. + +3. quantifyTyVars quantifies the remaining type variables + +The kindGeneralize functions do not require pre-zonking; they zonk as they +go. + +kindGeneraliseAll specialises for the case where step (2) is vacuous. +kindGeneraliseNone specialises for the case where we do no quantification, +but we must still promote. + +If you are actually doing kind-generalization, you need to bump the +level before generating constraints, as we will only generalize +variables with a TcLevel higher than the ambient one. +Hence the "pushLevel" in pushLevelAndSolveEqualities. + +Note [Promotion in signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If an unsolved metavariable in a signature is not generalized +(because we're not generalizing the construct -- e.g., pattern +sig -- or because the metavars are constrained -- see kindGeneralizeSome) +we need to promote to maintain (WantedInv) of Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing +and the reinstantiating with a fresh metavariable at the current level. +So in some sense, we generalize *all* variables, but then re-instantiate +some of them. + +Here is an example of why we must promote: + foo (x :: forall a. a -> Proxy b) = ... + +In the pattern signature, `b` is unbound, and will thus be brought into +scope. We do not know its kind: it will be assigned kappa[2]. Note that +kappa is at TcLevel 2, because it is invented under a forall. (A priori, +the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel +than the surrounding context.) This kappa cannot be solved for while checking +the pattern signature (which is not kind-generalized). When we are checking +the *body* of foo, though, we need to unify the type of x with the argument +type of bar. At this point, the ambient TcLevel is 1, and spotting a +metavariable with level 2 would violate the (WantedInv) invariant of +Note [TcLevel invariants]. So, instead of kind-generalizing, +we promote the metavariable to level 1. This is all done in kindGeneralizeNone. + +-} + +funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt +-- Returns FunSigCtxt, with no redundant-context-reporting, +-- form a list of located names +funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC +funsSigCtxt [] = panic "funSigCtxt" + +addSigCtxt :: UserTypeCtxt -> UserSigType GhcRn -> TcM a -> TcM a +addSigCtxt ctxt hs_ty thing_inside + = setSrcSpan l $ + addErrCtxt (UserSigCtxt ctxt hs_ty) $ + thing_inside + where + l = case hs_ty of + UserLHsSigType ty -> getLocA ty + UserLHsType ty -> getLocA ty + +pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc +-- (pprSigCtxt ctxt ) +-- prints In the type signature for 'f': +-- f :: +-- The is either empty or "the ambiguity check for" +pprSigCtxt ctxt hs_ty + | Just n <- isSigMaybe ctxt + = hang (text "In the type signature:") + 2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty) + + | otherwise + = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon) + 2 (ppr hs_ty) + +tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type +-- This one is used when we have a LHsSigWcType, but in +-- a place where wildcards aren't allowed. The renamer has +-- already checked this, so we can simply ignore it. +tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) + +kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM () +-- This is a special form of tcClassSigType that is used during the +-- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type. +-- Importantly, this does *not* kind-generalize. Consider +-- class SC f where +-- meth :: forall a (x :: f a). Proxy x -> () +-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're +-- still working out the kind of f, and thus f a will have a coercion in it. +-- Coercions may block unification (Note [Equalities with heterogeneous kinds] in +-- GHC.Tc.Solver.Equality, wrinkle (EIK2)) and so we fail to unify. If we try to +-- kind-generalize, we'll end up promoting kappa to the top level (because +-- kind-generalization is normally done right before adding a binding to the context), +-- and then we can't set kappa := f a, because a is local. +kcClassSigType names + sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty })) + = addSigCtxt (funsSigCtxt names) (UserLHsSigType sig_ty) $ + do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs $ + tcCheckLHsType hs_ty liftedTypeKind + ; return () } + +tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type +-- Does not do validity checking +tcClassSigType names sig_ty + = addSigCtxt sig_ctxt (UserLHsSigType sig_ty) $ + do { skol_info <- mkSkolemInfo skol_info_anon + ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind) + ; emitImplication implic + ; return ty } + -- Do not zonk-to-Type, nor perform a validity check + -- We are in a knot with the class and associated types + -- Zonking and validity checking is done by tcClassDecl + -- + -- No need to fail here if the type has an error: + -- If we're in the kind-checking phase, the solveEqualities + -- in kcTyClGroup catches the error + -- If we're in the type-checking phase, the solveEqualities + -- in tcClassDecl1 gets it + -- Failing fast here degrades the error message in, e.g., tcfail135: + -- class Foo f where + -- baa :: f a -> f + -- If we fail fast, we're told that f has kind `k1` when we wanted `*`. + -- It should be that f has kind `k2 -> *`, but we never get a chance + -- to run the solver where the kind of f is touchable. This is + -- painfully delicate. + where + sig_ctxt = funsSigCtxt names + skol_info_anon = SigTypeSkol sig_ctxt + +tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +-- Does validity checking +-- See Note [Recipe for checking a signature] +tcHsSigType ctxt sig_ty + = addSigCtxt ctxt (UserLHsSigType sig_ty) $ + do { traceTc "tcHsSigType {" (ppr sig_ty) + ; skol_info <- mkSkolemInfo skol_info + -- Generalise here: see Note [Kind generalisation] + ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (expectedKindInCtxt ctxt) + + -- Float out constraints, failing fast if not possible + -- See Note [Failure in local type signatures] in GHC.Tc.Solver + ; traceTc "tcHsSigType 2" (ppr implic) + ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic)) + + ; ty <- liftZonkM $ zonkTcType ty + ; checkValidType ctxt ty + ; traceTc "end tcHsSigType }" (ppr ty) + ; return ty } + where + skol_info = SigTypeSkol ctxt + +tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn + -> ContextKind -> TcM (Implication, TcType) +-- Kind-checks/desugars an 'LHsSigType', +-- solve equalities, +-- and then kind-generalizes. +-- This will never emit constraints, as it uses solveEqualities internally. +-- No validity checking or zonking +-- Returns also an implication for the unsolved constraints +tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs + , sig_body = hs_ty })) ctxt_kind + = setSrcSpanA loc $ + do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty))) + <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $ + -- See Note [Failure in local type signatures] + do { exp_kind <- newExpectedKind ctxt_kind + -- See Note [Escaping kind in type signatures] + ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $ + tcCheckLHsType hs_ty exp_kind + ; return (exp_kind, stuff) } + + -- Default any unconstrained variables free in the kind + -- See Note [Escaping kind in type signatures] + ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind + ; doNotQuantifyTyVars exp_kind_dvs (err_ctx exp_kind) + + ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs) + ; outer_bndrs <- scopedSortOuter outer_bndrs + + ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs + ty1 = mkInvisForAllTys outer_tv_bndrs ty + ; kvs <- kindGeneralizeSome skol_info wanted ty1 + + -- Build an implication for any as-yet-unsolved kind equalities + -- See Note [Skolem escape in type signatures] + ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted + + ; return (implic, mkInfForAllTys kvs ty1) } + where + err_ctx exp_kind tidy_env + = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind + ; return (tidy_env2, UninfTyCtx_Sig exp_kind full_hs_ty) } + + + +{- Note [Escaping kind in type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider kind-checking the signature for `foo` (#19495, #24686): + type family T (r :: RuntimeRep) :: TYPE r + + foo :: forall (r :: RuntimeRep). T r + foo = ... + +We kind-check the type with expected kind `TYPE delta` (see newExpectedKind), +where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep` +because we allow signatures like `foo :: Int#`.) + +Suppose we are at level L currently. We do this + * pushLevelAndSolveEqualitiesX: moves to level 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} + +Then +* We can't unify delta{L+1} with r{L+2}. + And rightly so: skolem would escape. + +* If delta{L+1} is unified with some-kind{L}, that is fine. + This can happen + \(x::a) -> let y :: a; y = x in ...(x :: Int#)... + Here (x :: a :: TYPE gamma) is in the environment when we check + the signature y::a. We unify delta := gamma, and all is well. + +* If delta{L+1} is unconstrained, we /must not/ quantify over it! + E.g. Consider f :: Any where Any :: forall k. k + We kind-check this with expected kind TYPE kappa. We get + Any @(TYPE kappa) :: TYPE kappa + We don't want to generalise to forall k. Any @k + because that is ill-kinded: the kind of the body of the forall, + (Any @k :: k) mentions the bound variable k. + + Instead we want to default it to LiftedRep. + + An alternative would be to promote it, similar to the monomorphism + restriction, but the MR is pretty confusing. Defaulting seems better + +How does that defaulting happen? Well, since we /currently/ default +RuntimeRep variables during generalisation, it'll happen in +kindGeneralize. But in principle we might allow generalisation over +RuntimeRep variables in future. Moreover, what if we had + kappa{L+1} := F alpha{L+1} +where F :: Type -> RuntimeRep. Now it's alpha that is free in the kind +and it /won't/ be defaulted. + +So we use doNotQuantifyTyVars to either default the free vars of +exp_kind (if possible), or error (if not). + +Note [Skolem escape in type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcHsSigType is tricky. Consider (T11142) + foo :: forall b. (forall k (a :: k). SameKind a b) -> () +This is ill-kinded because of a nested skolem-escape. + +That will show up as an un-solvable constraint in the implication +returned by buildTvImplication in tc_lhs_sig_type. See Note [Skolem +escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable +(the unification variable for b's kind is untouchable). + +Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType) +we'll try to float out the constraint, be unable to do so, and fail. +See GHC.Tc.Solver Note [Failure in local type signatures] for more +detail on this. + +The separation between tcHsSigType and tc_lhs_sig_type is because +tcClassSigType wants to use the latter, but *not* fail fast, because +there are skolems from the class decl which are in scope; but it's fine +not to because tcClassDecl1 has a solveEqualities wrapped around all +the tcClassSigType calls. + +That's why tcHsSigType does simplifyAndEmitFlatConstraints (which +fails fast) but tcClassSigType just does emitImplication (which does +not). Ugh. + +c.f. see also Note [Skolem escape and forall-types]. The difference +is that we don't need to simplify at a forall type, only at the +top level of a signature. +-} + +-- Does validity checking and zonking. +tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind) +tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig)) + = addSigCtxt ctxt (UserLHsSigType ksig) $ + do { kind <- tc_top_lhs_type KindLevel ctxt ksig + ; checkValidType ctxt kind + ; return (name, kind) } + where + ctxt = StandaloneKindSigCtxt name + +tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +tcTopLHsType ctxt lsig_ty + = checkNoErrs $ -- Fail eagerly to avoid follow-on errors. We are at + -- top level so these constraints will never be solved later. + tc_top_lhs_type TypeLevel ctxt lsig_ty + +tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type +-- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where +-- we want to fully solve /all/ equalities, and report errors +-- Does zonking, but not validity checking because it's used +-- for things (like deriving and instances) that aren't +-- ordinary types +-- Used for both types and kinds +tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs + , sig_body = body })) + = setSrcSpanA loc $ + do { traceTc "tc_top_lhs_type {" (ppr sig_ty) + ; skol_info <- mkSkolemInfo skol_info_anon + ; (tclvl, wanted, (outer_bndrs, ty)) + <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $ + do { kind <- newExpectedKind (expectedKindInCtxt ctxt) + ; 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 + ty1 = mkInvisForAllTys outer_tv_bndrs ty + + ; kvs <- kindGeneralizeAll skol_info ty1 -- "All" because it's a top-level type + ; reportUnsolvedEqualities skol_info kvs tclvl wanted + + ; final_ty <- initZonkEnv DefaultFlexi + $ zonkTcTypeToTypeX (mkInfForAllTys kvs ty1) + ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty]) + ; return final_ty } + where + skol_info_anon = SigTypeSkol ctxt + +-- | Typecheck the class in a default declaration, checking that: +-- +-- - it is indeed a class (not e.g. a type family), +-- - that the class expects some invisible arguments followed +-- by a single visible argument. +tcDefaultDeclClass :: LIdP GhcRn -> TcM (Maybe Class) +tcDefaultDeclClass l_nm + = setSrcSpan (locA l_nm) $ + do { let nm = unLoc l_nm + ; thing <- tcLookupGlobal nm + ; case thing of + ATyCon tc + | Just cls <- tyConClass_maybe tc + -> if is_unary (tyConBinders tc) + then return $ Just cls + else + do { addErrTc $ TcRnNonUnaryTypeclassConstraint DefaultDeclCtxt (NameThing nm) + ; return Nothing } + + _ -> do { addErrTc $ TcRnIllegalDefaultClass nm + ; return Nothing } + } + where + is_unary :: [TyConBinder] -> Bool + is_unary = ( `lengthIs` 1 ) . dropWhile isInvisibleTyConBinder + +----------------- +tcHsDeriv :: LHsSigType GhcRn -> TcM (Maybe (Class, [TyCoVar], [Type], Kind)) +-- ^ Like tcHsSigType, but for the @...deriving( C ty1 ty2 )@ clause +-- +-- Returns a class constraint with the last argument missing, and the +-- expected kind of the remaining argument. +-- +-- E.g.: +-- +-- @class C (a::*) (b::k->k)@ +-- @data T a b = ... deriving( C Int )@ +-- +-- This function returns @(C, [k], [k, Int], k->k)@. +-- +-- Return values are fully zonked +tcHsDeriv hs_ty + = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty + + ; let (tvs, pred) = splitForAllTyCoVars ty + (kind_args, _) = splitFunTys (typeKind pred) + -- Checking that `pred` a is type class application + + ; case splitTyConApp_maybe pred of + Just (tc, tc_args) -> + case tyConClass_maybe tc of + Just cls -> + case kind_args of + [Scaled _ last_kind] -> + return $ Just $ + (cls, tvs, tc_args, last_kind) + _ -> + do { addErrTc $ TcRnNonUnaryTypeclassConstraint DerivClauseCtxt (TypeThing pred) + ; return Nothing + } + Nothing -> + do { addErrTc $ TcRnIllegalInstance + $ IllegalClassInstance (TypeThing ty) + $ IllegalInstanceHead + $ InstHeadNonClassHead + $ InstNonClassTyCon + (noUserRdr $ tyConName tc) + (fmap tyConName $ tyConFlavour tc) + ; return Nothing } + Nothing -> + do { addErrTc $ TcRnIllegalDerivingItem hs_ty; return Nothing } + } + +-- | Typecheck a deriving strategy. For most deriving strategies, this is a +-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type. +tcDerivStrategy :: Maybe (LDerivStrategy GhcRn) + -- ^ The deriving strategy + -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar]) + -- ^ The typechecked deriving strategy and the tyvars that it binds + -- (if using 'ViaStrategy'). +tcDerivStrategy mb_lds + = case mb_lds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpanA loc $ do + (ds', tvs) <- tc_deriv_strategy ds + pure (Just (L loc ds'), tvs) + where + tc_deriv_strategy :: DerivStrategy GhcRn + -> TcM (DerivStrategy GhcTc, [TyVar]) + tc_deriv_strategy (StockStrategy _) = boring_case (StockStrategy noExtField) + tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField) + tc_deriv_strategy (NewtypeStrategy _) = boring_case (NewtypeStrategy noExtField) + tc_deriv_strategy (ViaStrategy hs_sig) + = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty } + ; pure (ViaStrategy via_pred, via_tvs) } + + boring_case :: ds -> TcM (ds, [a]) + boring_case ds = pure (ds, []) + +tcHsClsInstType :: UserTypeCtxt -- InstDeclCtxt or SpecInstCtxt + -> LHsSigType GhcRn + -> TcM Type +-- Like tcHsSigType, but for a class instance declaration +tcHsClsInstType user_ctxt hs_inst_ty + = setSrcSpan (getLocA hs_inst_ty) $ + do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty + ; checkValidInstance user_ctxt hs_inst_ty inst_ty + ; return inst_ty } + +---------------------------------------------- +-- | Type-check a visible type application +tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcHsTypeApp wc_ty kind + | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty + = do { mode <- mkHoleMode TypeLevel HM_VTA + -- HM_VTA: See Note [Wildcards in visible type application] + ; ty <- addTypeCtxt hs_ty $ + solveEqualities "tcHsTypeApp" $ + -- 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_check_lhs_type mode hs_ty kind + + -- We do not kind-generalize type applications: we just + -- instantiate with exactly what the user says. + -- See Note [No generalization in type application] + -- We still must call kindGeneralizeNone, though, according + -- to Note [Recipe for checking a signature] + ; kindGeneralizeNone ty + ; ty <- liftZonkM $ zonkTcType ty + ; checkValidType TypeAppCtxt ty + ; return ty } + +{- Note [Wildcards in visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so +any unnamed wildcards stay unchanged in hswc_body. When called in +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 +@_ to skip a instantiating a type variable variable without fuss. The +solution is to switch the PartialTypeSignatures flags here to let the +typechecker know that it's checking a '@_' and do not emit hole +constraints on it. See related Note [Wildcards in visible kind +application] and Note [The wildcard story for types] in GHC.Hs.Type + +Ugh! + +Note [No generalization in type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not kind-generalize type applications. Imagine + + id @(Proxy Nothing) + +If we kind-generalized, we would get + + id @(forall {k}. Proxy @(Maybe k) (Nothing @k)) + +which is very sneakily impredicative instantiation. + +There is also the possibility of mentioning a wildcard +(`id @(Proxy _)`), which definitely should not be kind-generalized. + +-} + +tcFamTyPats :: TyCon + -> HsFamEqnPats GhcRn -- Patterns + -> TcM (TcType, TcKind) -- (lhs_type, lhs_kind) +-- Check the LHS of a type/data family instance +-- e.g. type instance F ty1 .. tyn = ... +-- Used for both type and data families +tcFamTyPats fam_tc hs_pats + = do { traceTc "tcFamTyPats {" $ + vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ] + + ; mode <- mkHoleMode TypeLevel HM_FamPat + -- HM_FamPat: See Note [Wildcards in family instances] in + -- GHC.Rename.Module + ; let fun_ty = mkTyConApp fam_tc [] + ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats + + -- Hack alert: see Note [tcFamTyPats: zonking the result kind] + ; res_kind <- liftZonkM $ zonkTcType res_kind + + ; traceTc "End tcFamTyPats }" $ + vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] + + ; return (fam_app, res_kind) } + where + fam_name = tyConName fam_tc + fam_arity = tyConArity fam_tc + lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA $ noUserRdr fam_name)) + +{- Note [tcFamTyPats: zonking the result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19250) + F :: forall k. k -> k + type instance F (x :: Constraint) = () + +The tricky point is this: + is that () an empty type tuple (() :: Type), or + an empty constraint tuple (() :: Constraint)? +We work this out in a hacky way, by looking at the expected kind: +see Note [Inferring tuple kinds]. + +In this case, we kind-check the RHS using the kind gotten from the LHS: +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 (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 +that info when kind-checking the RHS. + +Easy solution: just zonk that return kind. Of course this won't help +if there is lots of type-family reduction to do, but it works fine in +common cases. +-} + + +{- +************************************************************************ +* * + The main kind checker: no validity checks here +* * +************************************************************************ +-} + +--------------------------- +tcHsOpenType, tcHsLiftedType, + tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType +-- Used for type signatures +-- Do not do validity checking +tcHsOpenType hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty +tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty + +tcHsOpenTypeNC hs_ty = do { ek <- newOpenTypeKind; tcCheckLHsType hs_ty ek } +tcHsLiftedTypeNC hs_ty = tcCheckLHsType hs_ty liftedTypeKind + +-- 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 + ; tcCheckLHsType hs_ty ek } + +tcInferLHsType :: LHsType GhcRn -> TcM TcType +tcInferLHsType hs_ty + = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty + ; return ty } + +tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind) +-- Called from outside: set the context +-- Eagerly instantiate any trailing invisible binders +tcInferLHsTypeKind lhs_ty@(L loc hs_ty) + = addTypeCtxt lhs_ty $ + setSrcSpanA loc $ -- Cover the tcInstInvisibleTyBinders + do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty + ; tcInstInvisibleTyBinders res_ty res_kind } + -- See Note [Do not always instantiate eagerly in types] + +-- Used to check the argument of GHCi :kind +-- Allow and report wildcards, e.g. :kind T _ +-- Do not saturate family applications: see Note [Dealing with :kind] +-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types] +tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind) +tcInferLHsTypeUnsaturated hs_ty + = addTypeCtxt hs_ty $ + do { mode <- mkHoleMode TypeLevel HM_Sig -- Allow and report holes + ; 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 } + -- Notice the 'nosat'; do not instantiate trailing + -- invisible arguments of a type family. + -- See Note [Dealing with :kind] + Nothing -> tc_infer_lhs_type mode hs_ty } + +{- Note [Dealing with :kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi command + ghci> type family F :: Either j k + ghci> :kind F + F :: forall {j,k}. Either j k + +We will only get the 'forall' if we /refrain/ from saturating those +invisible binders. But generally we /do/ saturate those invisible +binders (see tcInferTyApps), and we want to do so for nested application +even in GHCi. Consider for example (#16287) + ghci> type family F :: k + ghci> data T :: (forall k. k) -> Type + ghci> :kind T F +We want to reject this. It's just at the very top level that we want +to switch off saturation. + +So tcInferLHsTypeUnsaturated does a little special case for top level +applications. Actually the common case is a bare variable, as above. + +Note [Do not always instantiate eagerly in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Terms are eagerly instantiated. This means that if you say + + x = id + +then `id` gets instantiated to have type alpha -> alpha. The variable +alpha is then unconstrained and regeneralized. So we may well end up with + x = /\a. id @a +But we cannot do this in types, as we have no type-level lambda. + +So, we must be careful only to instantiate at the last possible moment, when +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`. + +For example, suppose we have: + Actual: ∀ k2 k. k -> k2 -> k + Expected: ∀ k. k -> Type -> k +We must very delicately instantiate just k2 to kappa, and then unify + (∀ k. k -> Type -> k) ~ (∀ k. k -> kappa -> k) + +Otherwise, we are careful /not/ to instantiate. For example: + * at a variable in `tcTyVar` + * in `tcInferLHsTypeUnsaturated`, which is used by :kind in GHCi. + +************************************************************************ +* * + Type-checking modes +* * +************************************************************************ + +The kind-checker is parameterised by a TcTyMode, which contains some +information about where we're checking a type. + +The renamer issues errors about what it can. All errors issued here must +concern things that the renamer can't handle. + +-} + +tcMult :: LHsType GhcRn -> TcM Mult +tcMult ty = tc_check_lhs_type typeLevelMode ty multiplicityTy + +-- | Info about the context in which we're checking a type. Currently, +-- differentiates only between types and kinds, but this will likely +-- grow, at least to include the distinction between patterns and +-- not-patterns. +-- +-- To find out where the mode is used, search for 'mode_tyki' +-- +-- This data type is purely local, not exported from this module +data TcTyMode + = TcTyMode { mode_tyki :: TypeOrKind + , mode_holes :: HoleInfo } + +-- See Note [Levels for wildcards] +-- Nothing <=> no wildcards expected +type HoleInfo = Maybe (TcLevel, HoleMode) + +-- HoleMode says how to treat the occurrences +-- of anonymous wildcards; see tcAnonWildCardOcc +data HoleMode = HM_Sig -- Partial type signatures: f :: _ -> Int + | HM_FamPat -- Family instances: F _ Int = Bool + | HM_VTA -- Visible type and kind application: + -- f @(Maybe _) + -- Maybe @(_ -> _) + | HM_TyAppPat -- Visible type applications in patterns: + -- foo (Con @_ @t x) = ... + -- case x of Con @_ @t v -> ... + +mkMode :: TypeOrKind -> TcTyMode +mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing } + +typeLevelMode, kindLevelMode :: TcTyMode +-- These modes expect no wildcards (holes) in the type +kindLevelMode = mkMode KindLevel +typeLevelMode = mkMode TypeLevel + +mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode +mkHoleMode tyki hm + = do { lvl <- getTcLevel + ; return (TcTyMode { mode_tyki = tyki + , mode_holes = Just (lvl,hm) }) } + +instance Outputable HoleMode where + ppr HM_Sig = text "HM_Sig" + ppr HM_FamPat = text "HM_FamPat" + ppr HM_VTA = text "HM_VTA" + ppr HM_TyAppPat = text "HM_TyAppPat" + +instance Outputable TcTyMode where + ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm }) + = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma + , ppr hm ]) + +{- +Note [Bidirectional type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In types, as in terms, we use bidirectional type infefence. The main workhorse +function looks like this: + + type ExpKind = ExpType + data ExpType = Check TcSigmaKind | Infer ...(hole TcRhoType)... + + 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 +-} + +------------------------------------------ +-- | Check and desugar a type, returning the core type and its +-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression +-- level. +tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +tc_infer_lhs_type mode (L span ty) + = setSrcSpanA span $ + tc_infer_hs_type mode ty + +--------------------------- +-- | Infer the kind of a type and desugar. This is the "up" type-checker, +-- as described in Note [Bidirectional type checking] +tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) +tc_infer_hs_type mode rn_ty + = runInferKind $ \exp_kind -> + tcHsType mode rn_ty exp_kind + +{- +Note [Typechecking HsCoreTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes. +As such, there's not much to be done in order to typecheck an HsCoreTy, +since it's already been typechecked to some extent. There is one thing that +we must do, however: we must substitute the type variables from the tcl_env. +To see why, consider GeneralizedNewtypeDeriving, which is one of the main +clients of HsCoreTy (example adapted from #14579): + + newtype T a = MkT a deriving newtype Eq + +This will produce an InstInfo GhcPs that looks roughly like this: + + instance forall a_1. Eq a_1 => Eq (T a_1) where + (==) = coerce @( a_1 -> a_1 -> Bool) -- The type within @(...) is an HsCoreTy + @(T a_1 -> T a_1 -> Bool) -- So is this + (==) + +This is then fed into the renamer. Since all of the type variables in this +InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically +identical. Things get more interesting when the InstInfo is fed into the +typechecker, however. GHC will first generate fresh skolems to instantiate +the instance-bound type variables with. In the example above, we might generate +the skolem a_2 and use that to instantiate a_1, which extends the local type +environment (tcl_env) with [a_1 :-> a_2]. This gives us: + + instance forall a_2. Eq a_2 => Eq (T a_2) where ... + +To ensure that the body of this instance is well scoped, every occurrence of +the `a` type variable should refer to a_2, the new skolem. However, the +HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the +substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this +substitution to each HsCoreTy and all is well: + + instance forall a_2. Eq a_2 => Eq (T a_2) where + (==) = coerce @( a_2 -> a_2 -> Bool) + @(T a_2 -> T a_2 -> Bool) + (==) +-} + +------------------------------------------ +tcCheckLHsType :: LHsType GhcRn -> TcKind -> TcM TcType +tcCheckLHsType hs_ty exp_kind + = tc_check_lhs_type typeLevelMode hs_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_check_hs_type mode ty exp_kind + +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) + +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 + +-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. +-- Here we get rid of it and add the finalizers to the global environment +-- while capturing the local environment. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tcHsType mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _) + exp_kind + = do addModFinalizersWithLclEnv mod_finalizers + tcLHsType mode ty exp_kind + +tcHsType _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tcHsType: invalid nested splice" (pprUntypedSplice True (Just n) s) + +---------- Functions and applications +tcHsType mode (HsFunTy _ mult ty1 ty2) exp_kind + = tc_fun_type mode mult ty1 ty2 exp_kind + +tcHsType mode (HsOpTy _ _ ty1 (L _ (WithUserRdr _ op)) ty2) exp_kind + | op `hasKey` unrestrictedFunTyConKey + = tc_fun_type mode (HsUnannotated noExtField) ty1 ty2 exp_kind + +--------- Foralls +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 + -- an arbitrary kind (hence exp_kind above). + -- See Note [Body kind of a HsForAllTy] + + | HsForAllVis{} <- tele + = do { ek <- newOpenTypeKind + ; 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 $ + 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 + + -- Do not kind-generalise here! See Note [Kind generalisation] + ; return (mkForAllTys tv_bndrs ty') } + +tcHsType mode t@(HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind + | null (unLoc ctxt) + = 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 + -- 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 + -- be TYPE r, for any r, hence newOpenTypeKind + ; 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 +tcHsType mode rn_ty@(HsListTy _ elt_ty) exp_kind + = do { tau_ty <- tc_check_lhs_type mode elt_ty liftedTypeKind + ; checkWiredInTyCon listTyCon + ; checkExpKind rn_ty (mkListTy tau_ty) liftedTypeKind 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 + +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_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 + ; checkExpKind rn_ty sum_ty sum_kind exp_kind + } + +--------- Promoted lists and tuples +tcHsType mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind + -- See Note [Kind-checking explicit lists] + + | null tys + = 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') + ; 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] + +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_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 + ; checkExpKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } + where + arity = length tys + +--------- Constraint types +tcHsType mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind + = do { massert (isTypeLevel (mode_tyki mode)) + ; ty' <- tc_check_lhs_type mode ty liftedTypeKind + ; let n' = mkStrLitTy $ hsIPNameFS n + ; ipClass <- tcLookupClass ipClassName + ; checkExpKind rn_ty (mkClassPred ipClass [n',ty']) + constraintKind 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' + = checkExpKind rn_ty liftedTypeKind liftedTypeKind exp_kind + +--------- Literals +tcHsType _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind + = do { checkWiredInTyCon naturalTyCon + ; checkExpKind rn_ty (mkNumLitTy n) naturalTy exp_kind } + +tcHsType _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind + = do { checkWiredInTyCon typeSymbolKindCon + ; checkExpKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } +tcHsType _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind + = do { checkWiredInTyCon charTyCon + ; checkExpKind rn_ty (mkCharLitTy c) charTy exp_kind } + +--------- Wildcards + +tcHsType mode ty@(HsWildCardTy _) ek + = do k <- expTypeToType ek + tcAnonWildCardOcc NoExtraConstraint mode ty k + +--------- 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 +binder. Furthermore, each invisible type variable binder also has a +Specificity. Together, these determine the variable binders (ForAllTyFlag) for each +variable in the generated ForAllTy type. + +This table summarises this relation: +---------------------------------------------------------------------------- +| User-written type HsForAllTelescope Specificity ForAllTyFlag +|--------------------------------------------------------------------------- +| f :: forall a. type HsForAllInvis SpecifiedSpec Specified +| f :: forall {a}. type HsForAllInvis InferredSpec Inferred +| f :: forall a -> type HsForAllVis SpecifiedSpec Required +| f :: forall {a} -> type HsForAllVis InferredSpec / +| This last form is nonsensical and is thus rejected. +---------------------------------------------------------------------------- + +For more information regarding the interpretation of the resulting ForAllTyFlag, see +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". +-} + +------------------------------------------ +tc_fun_type :: TcTyMode -> HsMultAnn GhcRn -> LHsType GhcRn -> LHsType GhcRn -> ExpKind + -> TcM TcType +tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of + TypeLevel -> + do { traceTc "tc_fun_type" (ppr ty1 $$ ppr ty2) + ; arg_k <- newOpenTypeKind + ; res_k <- newOpenTypeKind + ; ty1' <- tc_check_lhs_type mode ty1 arg_k + ; ty2' <- tc_check_lhs_type mode ty2 res_k + ; mult' <- tc_mult mode mult + ; checkExpKind (HsFunTy noExtField mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + KindLevel -> -- no representation polymorphism in kinds. yet. + do { ty1' <- tc_check_lhs_type mode ty1 liftedTypeKind + ; ty2' <- tc_check_lhs_type mode ty2 liftedTypeKind + ; mult' <- tc_mult mode mult + ; checkExpKind (HsFunTy noExtField mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') + liftedTypeKind exp_kind } + where + tc_mult mode mult = case multAnnToHsType mult of + Just mult' -> tc_check_lhs_type mode mult' multiplicityTy + Nothing -> return manyDataConTy + +{- Note [Skolem escape and forall-types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Checking telescopes]. + +Consider + f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> () + +The Proxy '[a,b] forces a and b to have the same kind. But a's +kind must be bound outside the 'forall a', and hence escapes. +We discover this by building an implication constraint for +each forall. So the inner implication constraint will look like + forall kb (b::kb). kb ~ ka +where ka is a's kind. We can't unify these two, /even/ if ka is +unification variable, because it would be untouchable inside +this inner implication. + +That's what the pushLevelAndCaptureConstraints, plus subsequent +buildTvImplication/emitImplication is all about, when kind-checking +HsForAllTy. + +Note that + +* We don't need to /simplify/ the constraints here + because we aren't generalising. We just capture them. + +* We can't use emitResidualTvConstraint, because that has a fast-path + for empty constraints. We can't take that fast path here, because + we must do the bad-telescope check even if there are no inner wanted + constraints. See Note [Checking telescopes] in + GHC.Tc.Types.Constraint. Lacking this check led to #16247. +-} + +{- ********************************************************************* +* * + Tuples +* * +********************************************************************* -} + +--------------------------- +tupKindSort_maybe :: TcKind -> Maybe TupleSort +tupKindSort_maybe k + | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' + | Just k' <- coreView k = tupKindSort_maybe k' + | isConstraintKind k = Just ConstraintTuple + | tcIsLiftedTypeKind k = Just BoxedTuple + | otherwise = Nothing + +tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType +tc_tuple rn_ty mode tup_sort tys exp_kind + = do { arg_kinds <- case tup_sort of + BoxedTuple -> return (replicate arity liftedTypeKind) + UnboxedTuple -> replicateM arity newOpenTypeKind + ConstraintTuple -> return (replicate arity constraintKind) + ; 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 + +finish_tuple :: HsType GhcRn + -> TupleSort + -> [TcType] -- ^ argument types + -> [TcKind] -- ^ of these kinds + -> TcKind -- ^ expected kind of the whole tuple + -> TcM TcType +finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do + traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind) + case tup_sort of + ConstraintTuple -> do + let tycon = cTupleTyCon arity + checkCTupSize arity + check_expected_kind (mkTyConApp tycon tau_tys) constraintKind + BoxedTuple -> do + let tycon = tupleTyCon Boxed arity + checkTupSize arity + checkWiredInTyCon tycon + check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind + UnboxedTuple -> do + let tycon = tupleTyCon Unboxed arity + tau_reps = map kindRep tau_kinds + -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + arg_tys = tau_reps ++ tau_tys + res_kind = unboxedTupleKind tau_reps + checkTupSize arity + check_expected_kind (mkTyConApp tycon arg_tys) res_kind + where + arity = length tau_tys + check_expected_kind ty act_kind = + checkExpectedKind rn_ty ty act_kind exp_kind + +{- ********************************************************************* +* * + Type applications +* * +********************************************************************* -} + +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 + is_app (HsAppKindTy {}) = True + is_app (HsAppTy {}) = True + is_app (HsOpTy _ _ _ (L _ (WithUserRdr _ op)) _) + = not (op `hasKey` unrestrictedFunTyConKey) + -- I'm not sure why this funTyConKey test is necessary + -- Can it even happen? Perhaps for t1 `(->)` t2 + -- but then maybe it's ok to treat that like a normal + -- application rather than using the special rule for HsFunTy + is_app (HsTyVar {}) = True + 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, + [HsArg GhcRn (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp + go (L _ (HsAppTy _ f a)) as = go f (HsValArg noExtField a : as) + go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg noExtField k : as) + go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as) + go (L _ (HsOpTy _ prom l op@(L sp _) r)) as + = ( L (l2l sp) (HsTyVar noAnn prom op) + , HsValArg noExtField l : HsValArg noExtField r : as ) + go f as = (f, as) + +--------------------------- +tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind) +-- Version of tc_infer_lhs_type specialised for the head of an +-- application. In particular, for a HsTyVar (which includes type +-- constructors, it does not zoom off into tcInferTyApps and family +-- saturation +tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ (WithUserRdr _ tv)))) + = tcTyVar tv +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, +-- using matchExpectedFunKind as necessary. +-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.- +-- These kinds should be used to instantiate invisible kind variables; +-- they come from an enclosing class for an associated type/data family. +-- +-- tcInferTyApps also arranges to saturate any trailing invisible arguments +-- of a type-family application, which is usually the right thing to do +-- tcInferTyApps_nosat does not do this saturation; it is used only +-- by ":kind" in GHCi +tcInferTyApps, tcInferTyApps_nosat + :: TcTyMode + -> LHsType GhcRn -- ^ Function (for printing only) + -> TcType -- ^ Function + -> [LHsTypeArg GhcRn] -- ^ Args + -> TcM (TcType, TcKind) -- ^ (f args, result kind) +tcInferTyApps mode hs_ty fun hs_args + = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args + ; saturateFamApp f_args res_k } + +tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args + = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args) + ; (f_args, res_k) <- go_init 1 fun orig_hs_args + ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k) + ; return (f_args, res_k) } + where + + -- go_init just initialises the auxiliary + -- arguments of the 'go' loop + go_init n fun all_args + = go n fun empty_subst fun_ki all_args + where + fun_ki = typeKind fun + -- We do (typeKind fun) here, even though the caller + -- knows the function kind, to absolutely guarantee + -- INVARIANT for 'go' + -- Note that in a typical application (F t1 t2 t3), + -- the 'fun' is just a TyCon, so typeKind is fast + + empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfType fun_ki + + go :: Int -- The # of the next argument + -> TcType -- Function applied to some args + -> Subst -- Applies to function kind + -> TcKind -- Function kind + -> [LHsTypeArg GhcRn] -- Un-type-checked args + -> TcM (TcType, TcKind) -- Result type and its kind + -- INVARIANT: in any call (go n fun subst fun_ki args) + -- typeKind fun = subst(fun_ki) + -- So the 'subst' and 'fun_ki' arguments are simply + -- there to avoid repeatedly calling typeKind. + -- + -- Reason for INVARIANT: to support the Purely Kinded Type Invariant + -- it's important that if fun_ki has a forall, then so does + -- (typeKind fun), because the next thing we are going to do + -- is apply 'fun' to an argument type. + + -- Dispatch on all_args first, for performance reasons + go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of + + ---------------- No user-written args left. We're done! + ([], _) -> return (fun, substTy subst fun_ki) + + ---------------- HsArgPar: We don't care about parens here + (HsArgPar _ : args, _) -> go n fun subst fun_ki args + + ---------------- HsTypeArg: a kind application (fun @ki) + (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) -> + case ki_binder of + + -- FunTy with PredTy on LHS, or ForAllTy with Inferred + Named (Bndr kv Inferred) -> instantiate kv inner_ki + + Named (Bndr _ Specified) -> -- Visible kind application + do { traceTc "tcInferTyApps (vis kind app)" + (vcat [ ppr ki_binder, ppr hs_ki_arg + , ppr (piTyBinderType ki_binder) + , ppr subst ]) + + ; let exp_kind = substTy subst $ piTyBinderType ki_binder + ; arg_mode <- mkHoleMode KindLevel HM_VTA + -- HM_VKA: see Note [Wildcards in visible kind application] + ; ki_arg <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty hs_ki_arg) n) $ + tc_check_lhs_type arg_mode hs_ki_arg exp_kind + + ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg + ; go (n+1) fun' subst' inner_ki hs_args } + + -- Attempted visible kind application (fun @ki), but fun_ki is + -- forall k -> blah or k1 -> k2 + -- So we need a normal application. Error. + _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki + + -- No binder; try applying the substitution, or fail if that's not possible + (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $ + ty_app_err ki_arg substed_fun_ki + + ---------------- HsValArg: a normal argument (fun ty) + (HsValArg _ arg : args, Just (ki_binder, inner_ki)) + -- next binder is invisible; need to instantiate it + | Named (Bndr kv flag) <- ki_binder + , isInvisibleForAllTyFlag flag -- ForAllTy with Inferred or Specified + -> instantiate kv inner_ki + + -- "normal" case + | otherwise + -> do { traceTc "tcInferTyApps (vis normal app)" + (vcat [ ppr ki_binder + , ppr arg + , ppr (piTyBinderType ki_binder) + , ppr subst ]) + ; let exp_kind = substTy subst $ piTyBinderType ki_binder + ; arg' <- addErrCtxt (FunAppCtxt (FunAppCtxtTy orig_hs_ty arg) n) $ + tc_check_lhs_type mode arg exp_kind + ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind) + ; (subst', fun') <- mkAppTyM subst fun ki_binder arg' + ; go (n+1) fun' subst' inner_ki args } + + -- no binder; try applying the substitution, or infer another arrow in fun kind + (HsValArg _ _ : _, Nothing) + -> try_again_after_substing_or $ + do { let arrows_needed = n_initial_val_args all_args + ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki + + ; fun' <- liftZonkM $ zonkTcType (fun `mkCastTy` co) + -- This zonk is essential, to expose the fruits + -- of matchExpectedFunKind to the 'go' loop + + ; traceTc "tcInferTyApps (no binder)" $ + vcat [ ppr fun <+> dcolon <+> ppr fun_ki + , ppr arrows_needed + , ppr co + , ppr fun' <+> dcolon <+> ppr (typeKind fun')] + ; go_init n fun' all_args } + -- Use go_init to establish go's INVARIANT + where + instantiate ki_binder inner_ki + = do { traceTc "tcInferTyApps (need to instantiate)" + (vcat [ ppr ki_binder, ppr subst]) + ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder + ; go n (mkAppTy fun arg') subst' inner_ki all_args } + -- Because tcInvisibleTyBinder instantiate ki_binder, + -- the kind of arg' will have the same shape as the kind + -- of ki_binder. So we don't need mkAppTyM here. + + try_again_after_substing_or fallthrough + | not (isEmptyTCvSubst subst) + = go n fun zapped_subst substed_fun_ki all_args + | otherwise + = fallthrough + + zapped_subst = zapSubst subst + substed_fun_ki = substTy subst fun_ki + hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) + + n_initial_val_args :: [HsArg p tm ty] -> Arity + -- Count how many leading HsValArgs we have + n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args + n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args + n_initial_val_args _ = 0 + + ty_app_err arg ty + = failWith $ TcRnInvalidVisibleKindArgument arg ty + +mkAppTyM :: Subst + -> TcType -> PiTyBinder -- fun, plus its top-level binder + -> TcType -- arg + -> TcM (Subst, TcType) -- Extended subst, plus (fun arg) +-- Precondition: the application (fun arg) is well-kinded after zonking +-- That is, the application makes sense +-- +-- Precondition: for (mkAppTyM subst fun bndr arg) +-- typeKind fun = Pi bndr. body +-- That is, fun always has a ForAllTy or FunTy at the top +-- and 'bndr' is fun's pi-binder +-- +-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type +-- invariant, then so does the result type (fun arg) +-- +-- We do not require that +-- typeKind arg = tyVarKind (binderVar bndr) +-- This must be true after zonking (precondition 1), but it's not +-- required for the (PKTI). +mkAppTyM subst fun ki_binder arg + | -- See Note [mkAppTyM]: Nasty case 2 + TyConApp tc args <- fun + , isTypeSynonymTyCon tc + , args `lengthIs` (tyConArity tc - 1) + , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym + = do { (arg':args') <- liftZonkM $ zonkTcTypes (arg:args) + ; let subst' = case ki_binder of + Anon {} -> subst + Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg' + ; return (subst', mkTyConApp tc (args' ++ [arg'])) } + + +mkAppTyM subst fun (Anon {}) arg + = return (subst, mk_app_ty fun arg) + +mkAppTyM subst fun (Named (Bndr tv _)) arg + = do { arg' <- if isTrickyTvBinder tv + then -- See Note [mkAppTyM]: Nasty case 1 + liftZonkM $ zonkTcType arg + else return arg + ; return ( extendTvSubstAndInScope subst tv arg' + , mk_app_ty fun arg' ) } + +mk_app_ty :: TcType -> TcType -> TcType +-- This function just adds an ASSERT for mkAppTyM's precondition +mk_app_ty fun arg + = assertPpr (isPiTy fun_kind) + (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ + mkAppTy fun arg + where + fun_kind = typeKind fun + +isTrickyTvBinder :: TcTyVar -> Bool +-- NB: isTrickyTvBinder is just an optimisation +-- It would be absolutely sound to return True always +isTrickyTvBinder tv = isPiTy (tyVarKind tv) + +{- Note [The Purely Kinded Type Invariant (PKTI)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type inference, we maintain this invariant + + (PKTI) It is legal to call 'typeKind' on any Type ty, + on any sub-term of ty, /without/ zonking ty + + Moreover, any such returned kind + will itself satisfy (PKTI) + +By "legal to call typeKind" we mean "typeKind will not crash". +The way in which typeKind can crash is in applications + (a t1 t2 .. tn) +if 'a' is a type variable whose kind doesn't have enough arrows +or foralls. (The crash is in piResultTys.) + +The loop in tcInferTyApps has to be very careful to maintain the (PKTI). +For example, suppose + kappa is a unification variable + We have already unified kappa := Type + yielding co :: Refl (Type -> Type) + a :: kappa +then consider the type + (a Int) +If we call typeKind on that, we'll crash, because the (un-zonked) +kind of 'a' is just kappa, not an arrow kind. So we must zonk first. + +So the type inference engine is very careful when building applications. +This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int), +where (a :: kappa). Then in tcInferApps we'll run out of binders on +a's kind, so we'll call matchExpectedFunKind, and unify + kappa := kappa1 -> kappa2, with evidence co :: kappa ~ (kappa1 ~ kappa2) +At this point we must zonk the function type to expose the arrrow, so +that (a Int) will satisfy (PKTI). + +The absence of this caused #14174 and #14520. + +The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM]. + +Wrinkle around FunTy: +Note that the PKTI does *not* guarantee anything about the shape of FunTys. +Specifically, when we have (FunTy vis mult arg res), it should be the case +that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we +might not have this. Example: if the user writes (a -> b), then we might +invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1 +(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2). +However, when we build the FunTy, we might not have zonked `a`, and so the +FunTy will be built without being able to purely extract the RuntimeReps. + +Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy, +we must be aware of this when splitting: splitTyConApp and splitAppTy will *not* +split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy] +in GHC.Tc.Solver.Equality. + +Note [mkAppTyM] +~~~~~~~~~~~~~~~ +mkAppTyM is trying to guarantee the Purely Kinded Type Invariant +(PKTI) for its result type (fun arg). There are two ways it can go wrong: + +* Nasty case 1: forall types (polykinds/T14174a) + T :: forall (p :: *->*). p Int -> p Bool + Now kind-check (T x), where x::kappa. + Well, T and x both satisfy the PKTI, but + T x :: x Int -> x Bool + and (x Int) does /not/ satisfy the PKTI. + +* Nasty case 2: type synonyms + type S f a = f a + Even though (S ff aa) would satisfy the (PKTI) if S was a data type + (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI) + if S is a type synonym, because the /expansion/ of (S ff aa) is + (ff aa), and /that/ does not satisfy (PKTI). E.g. perhaps + (ff :: kappa), where 'kappa' has already been unified with (*->*). + + We check for nasty case 2 on the final argument of a type synonym. + +Notice that in both cases the trickiness only happens if the +bound variable has a pi-type. Hence isTrickyTvBinder. +-} + + +saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) +-- Precondition for (saturateFamApp ty kind): +-- typeKind ty = kind +-- +-- If 'ty' is an unsaturated family application with trailing +-- invisible arguments, instantiate them. +-- See Note [saturateFamApp] + +saturateFamApp ty kind + | Just (tc, args) <- tcSplitTyConApp_maybe ty + , tyConMustBeSaturated tc + , let n_to_inst = tyConArity tc - length args + = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind + ; return (ty `mkAppTys` extra_args, ki') } + | otherwise + = return (ty, kind) + +{- Note [saturateFamApp] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family F :: Either j k + type instance F @Type = Right Maybe + type instance F @Type = Right Either``` + +Then F :: forall {j,k}. Either j k + +The two type instances do a visible kind application that instantiates +'j' but not 'k'. But we want to end up with instances that look like + type instance F @Type @(*->*) = Right @Type @(*->*) Maybe + +so that F has arity 2. We must instantiate that trailing invisible +binder. In general, Invisible binders precede Specified and Required, +so this is only going to bite for apparently-nullary families. + +Note that + type family F2 :: forall k. k -> * +is quite different and really does have arity 0. + +It's not just type instances where we need to saturate those +unsaturated arguments: see #11246. Hence doing this in tcInferApps. +-} + +appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn +appTypeToArg f [] = f +appTypeToArg f (HsValArg _ arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsArgPar _ : args) = appTypeToArg f args +appTypeToArg f (HsTypeArg _ arg : args) + = appTypeToArg (mkHsAppKindTy noExtField f arg) args + + +{- ********************************************************************* +* * + checkExpectedKind +* * +********************************************************************* -} + +-- | This instantiates invisible arguments for the type being checked if it must +-- be saturated and is not yet saturated. It then calls and uses the result +-- from checkExpectedKindX to build the final type +checkExpectedKind :: HasDebugCallStack + => HsType GhcRn -- ^ type we're checking (for printing) + -> TcType -- ^ type we're checking + -> TcKind -- ^ the known kind of that type + -> TcKind -- ^ the expected kind + -> TcM TcType +-- Just a convenience wrapper to save calls to 'ppr' +checkExpectedKind hs_ty ty act_kind exp_kind + = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind) + + ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind + + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just (HsTypeRnThing hs_ty) + , uo_visible = True } -- the hs_ty is visible + + ; traceTc "checkExpectedKindX" $ + vcat [ ppr hs_ty + , text "act_kind':" <+> ppr act_kind' + , text "exp_kind:" <+> ppr exp_kind ] + + ; let res_ty = ty `mkAppTys` new_args + + ; if act_kind' `tcEqType` exp_kind + then return res_ty -- This is very common + else do { co_k <- unifyTypeAndEmit KindLevel origin act_kind' exp_kind + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) + ; return (res_ty `mkCastTy` co_k) } } + where + -- We need to make sure that both kinds have the same number of implicit + -- foralls and constraints out front. If the actual kind has more, instantiate + -- accordingly. Otherwise, just pass the type & kind through: the errors + -- are caught in unifyType. + n_exp_invis_bndrs = invisibleBndrCount exp_kind + n_act_invis_bndrs = invisibleBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + + +-- 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 + -- NB: do not instantiate. + -- See Note [Do not always instantiate eagerly in types] + co <- fillInferResultNoInst ki cell + pure (ty `mkCastTy` co) + +--------------------------- + +tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] +tcHsContext Nothing = return [] +tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt + +tcLHsPredType :: LHsType GhcRn -> TcM PredType +tcLHsPredType pred = tc_lhs_pred typeLevelMode pred + +tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType] +tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt) + +tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType +tc_lhs_pred mode pred = tc_check_lhs_type mode pred constraintKind + +--------------------------- +tcTyVar :: Name -> TcM (TcType, TcKind) +-- See Note [Type checking recursive type and class declarations] +-- in GHC.Tc.TyCl +-- This does not instantiate. See Note [Do not always instantiate eagerly in types] +tcTyVar name -- Could be a tyvar, a tycon, or a datacon + = do { traceTc "lk1" (ppr name) + ; thing <- tcLookup name + ; case thing of + ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + + -- See Note [Recursion through the kinds] + (tcTyThingTyCon_maybe -> Just tc) -- TyCon or TcTyCon + -> return (mkTyConTy tc, tyConKind tc) + + AGlobal (AConLike (RealDataCon dc)) + -> do { when (isFamInstTyCon (dataConTyCon dc)) $ + -- see #15245 + promotionErr name FamDataConPE + ; let (_, _, _, theta, _, _) = dataConFullSig dc + ; traceTc "tcTyVar" (ppr dc <+> ppr theta) + -- promotionErr: Note [No constraints in kinds] in GHC.Tc.Validity + ; unless (null theta) $ + promotionErr name (ConstrainedDataConPE theta) + ; let tc = promoteDataCon dc + ; return (mkTyConApp tc [], tyConKind tc) } + + AGlobal AnId{} -> promotionErr name TermVariablePE + ATcId{} -> promotionErr name TermVariablePE + APromotionErr err -> promotionErr name err + + _ -> wrongThingErr WrongThingType thing name } + +{- +Note [Recursion through the kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these examples + +Ticket #11554: + data P (x :: k) = Q + data A :: Type where + MkA :: forall (a :: A). P a -> A + +Ticket #12174 + data V a + data T = forall (a :: T). MkT (V a) + +The type is recursive (which is fine) but it is recursive /through the +kinds/. In earlier versions of GHC this caused a loop in the compiler +(to do with knot-tying) but there is nothing fundamentally wrong with +the code (kinds are types, and the recursive declarations are OK). But +it's hard to distinguish "recursion through the kinds" from "recursion +through the types". Consider this (also #11554): + + data PB k (x :: k) = Q + data B :: Type where + MkB :: P B a -> B + +Here the occurrence of B is not obviously in a kind position. + +So now GHC allows all these programs. #12081 and #15942 are other +examples. + +Note [Body kind of a HsForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The body of a forall is usually a type. +Because of representation polymorphism, it can be a TYPE r, for any r. +(In fact, GHC can itself construct a function with an +unboxed tuple inside a for-all via CPR analysis; see +typecheck/should_compile/tc170). + +A forall can also be used in an instance head, then the body should +be a constraint. + +Right now, we do not have any easy way to enforce that a type is +either a TYPE something or CONSTRAINT something, so we accept any kind. +This is unsound (#22063). We could fix this by implementing a TypeLike +predicate, see #20000. + +For a forall with a required argument, we do not allow constraints; +e.g. forall a -> Eq a is invalid. Therefore, we can enforce that the body +is a TYPE something in this case (#24176). + +Note [Body kind of a HsQualTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ctxt is non-empty, the HsQualTy really is a /function/, so the +kind of the result really is '*', and in that case the kind of the +body-type can be lifted or unlifted. + +However, consider + instance Eq a => Eq [a] where ... +or + f :: (Eq a => Eq [a]) => blah +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. + +(BK1) How do we figure out the right body kind? + +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, +we try to figure out whether it's a tuple of kind * or Constraint. + Step 1: look at the expected kind + Step 2: infer argument kinds + +If after Step 2 it's not clear from the arguments that it's +Constraint, then it must be *. Once having decided that we re-check +the arguments to give good error messages in + e.g. (Maybe, Maybe) + +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. + +Note [Desugaring types] +~~~~~~~~~~~~~~~~~~~~~~~ +The type desugarer is phase 2 of dealing with HsTypes. Specifically: + + * It transforms from HsType to Type + + * It zonks any kinds. The returned type should have no mutable kind + or type variables (hence returning Type not TcType): + - any unconstrained kind variables are defaulted to (Any @Type) just + as in GHC.Tc.Zonk.Type. + - there are no mutable type variables because we are + kind-checking a type + Reason: the returned type may be put in a TyCon or DataCon where + it will never subsequently be zonked. + +You might worry about nested scopes: + ..a:kappa in scope.. + let f :: forall b. T '[a,b] -> Int +In this case, f's type could have a mutable kind variable kappa in it; +and we might then default it to (Any @Type) when dealing with f's type +signature. But we don't expect this to happen because we can't get a +lexically scoped type variable with a mutable kind variable in it. A +delicate point, this. If it becomes an issue we might need to +distinguish top-level from nested uses. + +Moreover + * it cannot fail, + * it does no unifications + * it does no validity checking, except for structural matters, such as + (a) spurious ! annotations. + (b) a class used as a type + +Note [Kind of a type splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these terms, each with TH type splice inside: + [| e1 :: Maybe $(..blah..) |] + [| e2 :: $(..blah..) |] +When kind-checking the type signature, we'll kind-check the splice +$(..blah..); we want to give it a kind that can fit in any context, +as if $(..blah..) :: forall k. k. + +In the e1 example, the context of the splice fixes kappa to *. But +in the e2 example, we'll desugar the type, zonking the kind unification +variables as we go. When we encounter the unconstrained kappa, we +want to default it to 'Type', not to (Any @Type). + +-} + +addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a + -- Wrap a context around only if we want to show that contexts. + -- Omit invisible ones and ones user's won't grok +addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. +addTypeCtxt ty thing = addErrCtxt (TypeCtxt ty) thing + + + +{- ********************************************************************* +* * + Type-variable binders +* * +********************************************************************* -} + +bindNamedWildCardBinders :: [Name] + -> ([(Name, TcTyVar)] -> TcM a) + -> TcM a +-- Bring into scope the /named/ wildcard binders. Remember that +-- plain wildcards _ are anonymous and dealt with by HsWildCardTy +-- Soe Note [The wildcard story for types] in GHC.Hs.Type +bindNamedWildCardBinders wc_names thing_inside + = do { wcs <- mapM newNamedWildTyVar wc_names + ; let wc_prs = wc_names `zip` wcs + ; tcExtendNameTyVarEnv wc_prs $ + thing_inside wc_prs } + +newNamedWildTyVar :: Name -> TcM TcTyVar +-- ^ New unification variable '_' for a wildcard +newNamedWildTyVar _name -- Currently ignoring the "_x" wildcard name used in the type + = do { kind <- newMetaKindVar + ; details <- newMetaDetails TauTv + ; wc_name <- newMetaTyVarName (fsLit "w") -- See Note [Wildcard names] + ; let tyvar = mkTcTyVar wc_name kind details + ; traceTc "newWildTyVar" (ppr tyvar) + ; return tyvar } + +--------------------------- +tcAnonWildCardOcc :: IsExtraConstraint + -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType +tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) }) + ty exp_kind + -- hole_lvl: see Note [Checking partial type signatures] + -- esp the bullet on nested forall types + = do { kv_details <- newTauTvDetailsAtLevel hole_lvl + ; kv_name <- newMetaTyVarName (fsLit "k") + ; wc_details <- newTauTvDetailsAtLevel hole_lvl + ; 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 + + ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes) + ; when emit_holes $ + emitAnonTypeHole is_extra wc_tv + -- Why the 'when' guard? + -- See Note [Wildcards in visible kind application] + + -- You might think that this would always just unify + -- wc_kind with exp_kind, so we could avoid even creating kv + -- But the level numbers might not allow that unification, + -- so we have to do it properly (T14140a) + ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind } + where + -- See Note [Wildcard names] + wc_nm = case hole_mode of + HM_Sig -> fsLit "w" + HM_FamPat -> fsLit "_" + HM_VTA -> fsLit "w" + HM_TyAppPat -> fsLit "_" + + emit_holes = case hole_mode of + HM_Sig -> True + HM_FamPat -> False + HM_VTA -> False + HM_TyAppPat -> False + +tcAnonWildCardOcc is_extra _ _ _ +-- mode_holes is Nothing. This means we have an anonymous wildcard +-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard', +-- but it is possible for a wildcard to be introduced by a Template Haskell splice, +-- as per #15433. To account for this, we throw a generic catch-all error message. + = failWith $ TcRnIllegalWildcardInType Nothing reason + where + reason = + case is_extra of + YesExtraConstraint -> + ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardNotAllowed + NoExtraConstraint -> + WildcardsNotAllowedAtAll + +{- Note [Wildcard names] +~~~~~~~~~~~~~~~~~~~~~~~~ +So we hackily use the mode_holes flag to control the name used +for wildcards: + +* For proper holes (whether in a visible type application (VTA) or no), + we rename the '_' to 'w'. This is so that we see variables like 'w0' + or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For + example, we prefer + Found type wildcard ‘_’ standing for ‘w0’ + over + Found type wildcard ‘_’ standing for ‘_1’ + + Even in the VTA case, where we do not emit an error to be printed, we + want to do the renaming, as the variables may appear in other, + non-wildcard error messages. + +* However, holes in the left-hand sides of type families ("type + patterns") stand for type variables which we do not care to name -- + much like the use of an underscore in an ordinary term-level + pattern. When we spot these, we neither wish to generate an error + message nor to rename the variable. We don't rename the variable so + that we can pretty-print a type family LHS as, e.g., + F _ Int _ = ... + and not + F w1 Int w2 = ... + + See also Note [Wildcards in family instances] in + GHC.Rename.Module. The choice of HM_FamPat is made in + tcFamTyPats. There is also some unsavory magic, relying on that + underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser. + +Note [Wildcards in visible kind application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are cases where users might want to pass in a wildcard as a visible kind +argument, for instance: + +data T :: forall k1 k2. k1 → k2 → Type where + MkT :: T a b +x :: T @_ @Nat False n +x = MkT + +So we should allow '@_' without emitting any hole constraints, and +regardless of whether PartialTypeSignatures is enabled or not. But how +would the typechecker know which '_' is being used in VKA and which is +not when it calls emitNamedTypeHole in +tcHsPartialSigType on all HsWildCardBndrs? The solution is to neither +rename nor include unnamed wildcards in HsWildCardBndrs, but instead +give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc. + +And whenever we see a '@', we set mode_holes to HM_VKA, so that +we do not call emitAnonTypeHole in tcAnonWildCardOcc. +See related Note [Wildcards in visible type application] here and +Note [The wildcard story for types] in GHC.Hs.Type +-} + +{- ********************************************************************* +* * + Kind inference for type declarations +* * +********************************************************************* -} + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +data InitialKindStrategy + = InitialKindCheck SAKS_or_CUSK + | InitialKindInfer + +-- Does the declaration have a standalone kind signature (SAKS) or a complete +-- user-supplied kind (CUSK)? +data SAKS_or_CUSK + = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) + | CUSK -- Complete user-supplied kind (CUSK) + +instance Outputable SAKS_or_CUSK where + ppr (SAKS k) = text "SAKS" <+> ppr k + ppr CUSK = text "CUSK" + +-- See Note [kcCheckDeclHeader vs kcInferDeclHeader] +kcDeclHeader + :: InitialKindStrategy + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM TcTyCon -- ^ A suitably-kinded TcTyCon +kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig +kcDeclHeader InitialKindInfer = kcInferDeclHeader + +{- Note [kcCheckDeclHeader vs kcInferDeclHeader] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind +of a type constructor. + +* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that + case, find the full, final, poly-kinded kind of the TyCon. It's very like a + term-level binding where we have a complete type signature for the function. + +* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a + CUSK. Find a monomorphic kind, with unification variables in it; they will be + generalised later. It's very like a term-level binding where we do not have a + type signature (or, more accurately, where we have a partial type signature), + so we infer the type and generalise. +-} + +------------------------------ +kcCheckDeclHeader + :: SAKS_or_CUSK + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig +kcCheckDeclHeader CUSK = kcCheckDeclHeader_cusk + +kcCheckDeclHeader_cusk + :: Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind + -> TcM PolyTcTyCon -- ^ A suitably-kinded generalized TcTyCon +kcCheckDeclHeader_cusk name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_tvs }) kc_res_ki + -- CUSK case + -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addErrCtxt (TyConDeclCtxt name flav) $ + do { skol_info <- mkSkolemInfo skol_info_anon + ; (tclvl, wanted, (scoped_kvs, (tc_bndrs, res_kind))) + <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $ + bindImplicitTKBndrs_Q_Skol skol_info kv_ns $ + bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs $ + newExpectedKind =<< kc_res_ki + + -- Now, because we're in a CUSK, + -- we quantify over the mentioned kind vars + ; let spec_req_tkvs = scoped_kvs ++ binderVars tc_bndrs + all_kinds = res_kind : map tyVarKind spec_req_tkvs + + ; candidates <- candidateQTyVarsOfKinds all_kinds + -- 'candidates' are all the variables that we are going to + -- skolemise and then quantify over. We do not include spec_req_tvs + -- because they are /already/ skolems + + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $ + candidates `delCandidates` spec_req_tkvs + -- NB: 'inferred' comes back sorted in dependency order + + ; (scoped_kvs, tc_bndrs, res_kind) <- liftZonkM $ + do { scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_bndrs are skolems, + ; tc_bndrs <- mapM zonkTyCoVarBndrKind tc_bndrs -- so zonkTyCoVarBndrKind suffices + ; res_kind <- zonkTcType res_kind + ; return (scoped_kvs, tc_bndrs, res_kind) } + + ; let mentioned_kv_set = candidateKindVars candidates + specified = scopedSort scoped_kvs + -- NB: maintain the L-R order of scoped_kvs + + all_tcbs = mkNamedTyConBinders Inferred inferred + ++ mkNamedTyConBinders Specified specified + ++ map (mkExplicitTyConBinder mentioned_kv_set) tc_bndrs + + -- Eta expand if necessary; we are building a PolyTyCon + ; (eta_tcbs, res_kind) <- maybeEtaExpandAlgTyCon flav skol_info all_tcbs res_kind + + ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ binderVars tc_bndrs) + final_tcbs = all_tcbs `chkAppend` eta_tcbs + tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs + True -- Make a PolyTcTyCon, fully generalised + flav + + ; reportUnsolvedEqualities skol_info (binderVars final_tcbs) + tclvl wanted + + -- If the ordering from + -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + -- doesn't work, we catch it here, before an error cascade + ; checkTyConTelescope tycon + + ; traceTc "kcCheckDeclHeader_cusk " $ + vcat [ text "name" <+> ppr name + , text "candidates" <+> ppr candidates + , text "mentioned_kv_set" <+> ppr mentioned_kv_set + , text "kv_ns" <+> ppr kv_ns + , text "hs_tvs" <+> ppr hs_tvs + , text "scoped_kvs" <+> ppr scoped_kvs + , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs + , text "all_kinds" <+> ppr all_kinds + , text "tc_tvs" <+> pprTyVars (binderVars tc_bndrs) + , text "res_kind" <+> ppr res_kind + , text "inferred" <+> ppr inferred + , text "specified" <+> ppr specified + , text "final_tcbs" <+> ppr final_tcbs + , text "mkTyConKind final_tc_bndrs res_kind" + <+> ppr (mkTyConKind final_tcbs res_kind) + , text "all_tv_prs" <+> ppr all_tv_prs ] + + ; return tycon } + where + skol_info_anon = TyConSkol flav name + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- | Create a TyConBinder for a user-written type variable binder. +mkExplicitTyConBinder :: TyCoVarSet -- variables that are used dependently + -> VarBndr TyVar (HsBndrVis GhcRn) + -> TyConBinder +mkExplicitTyConBinder dep_set (Bndr tv flag) = + case flag of + HsBndrRequired{} -> mkRequiredTyConBinder dep_set tv + HsBndrInvisible{} -> mkNamedTyConBinder Specified tv + +-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and +-- other kinds). +-- +-- This function does not do telescope checking. +kcInferDeclHeader + :: Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn + -> TcM ContextKind -- ^ The result kind + -> TcM MonoTcTyCon -- ^ A suitably-kinded non-generalized TcTyCon +kcInferDeclHeader name flav + (HsQTvs { hsq_ext = kv_ns + , hsq_explicit = hs_bndrs }) kc_res_ki + -- No standalone kind signature and no CUSK. + -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + = addErrCtxt (TyConDeclCtxt name flav) $ + do { rejectInvisibleBinders name hs_bndrs + ; (scoped_kvs, (tc_bndrs, res_kind)) + -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar? + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + <- bindImplicitTKBndrs_Q_Tv kv_ns $ + bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs $ + newExpectedKind =<< kc_res_ki + -- Why "_Tv" not "_Skol"? See third wrinkle in + -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl, + + ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they + -- might unify with kind vars in other types in a mutually + -- recursive group. + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + + tc_tvs = binderVars tc_bndrs + -- Discard visibility flags. We made sure all of them are HsBndrRequired + -- by the call to rejectInvisibleBinders above. + + tc_binders = mkAnonTyConBinders tc_tvs + -- This has to be mkAnonTyConBinder! + -- See Note [No polymorphic recursion in type decls] in GHC.Tc.TyCl + -- + -- Also, note that tc_binders has the tyvars from only the + -- user-written type variable binders. + -- See S1 Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl + + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + -- NB: bindExplicitTKBndrs_Q_Tv does not clone; + -- ditto Implicit + -- See Note [Cloning for type variable binders] + + tycon = mkTcTyCon name tc_binders res_kind all_tv_prs + False -- Make a MonoTcTyCon + flav + + ; traceTc "kcInferDeclHeader: not-cusk" $ + vcat [ ppr name, ppr kv_ns, ppr hs_bndrs + , ppr scoped_kvs + , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] + ; return tycon } + where + ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind + | otherwise = AnyKind + +-- rejectInvisibleBinders is called on on the inference code path; there is +-- no standalone kind signature, nor CUSK. +-- See Note [No inference for invisible binders in type decls] in GHC.Tc.TyCl +rejectInvisibleBinders :: Name -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -> TcM () +rejectInvisibleBinders name = mapM_ check_bndr_vis + where + check_bndr_vis :: LHsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcM () + check_bndr_vis bndr = + when (isHsBndrInvisible (hsTyVarBndrFlag (unLoc bndr))) $ + addErr (TcRnInvisBndrWithoutSig name bndr) + +-- | Kind-check a declaration header against a standalone kind signature. +-- See Note [kcCheckDeclHeader_sig] +kcCheckDeclHeader_sig + :: Kind -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType) + -> Name -- ^ of the thing being checked + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' is being checked + -> LHsQTyVars GhcRn -- ^ Binders in the header + -> TcM ContextKind -- ^ The result kind. AnyKind == no result signature + -> TcM PolyTcTyCon -- ^ A suitably-kinded, fully generalised TcTyCon +-- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki): +-- kind(returned PolyTcTyCon) = sig_kind +-- +kcCheckDeclHeader_sig sig_kind name flav + (HsQTvs { hsq_ext = implicit_nms + , hsq_explicit = hs_tv_bndrs }) kc_res_ki + = addErrCtxt (TyConDeclCtxt name flav) $ + do { skol_info <- mkSkolemInfo (TyConSkol flav name) + ; let avoid_occs = map nameOccName (hsLTyVarNames hs_tv_bndrs) + ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind) + <- splitTyConKind skol_info emptyInScopeSet + avoid_occs sig_kind + + ; traceTc "kcCheckDeclHeader_sig {" $ + vcat [ text "sig_kind:" <+> ppr sig_kind + , text "sig_tcbs:" <+> ppr sig_tcbs + , text "sig_res_kind:" <+> ppr sig_res_kind + , text "implict_nms:" <+> ppr implicit_nms + , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ] + + ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind)))) + <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 + bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone + matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind -> + do { -- Kind-check the result kind annotation, if present: + -- data T a b :: res_ki where ... + -- ^^^^^^^^^ + -- We do it here because at this point the environment has been + -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'. + -- + -- Also see Note [Arity of type families and type synonyms] + ; res_kind :: ContextKind <- kc_res_ki + + ; let sig_res_kind' = mkTyConKind excess_sig_tcbs sig_res_kind + + ; traceTc "kcCheckDeclHeader_sig 2" $ + vcat [ text "excess_sig_tcbs" <+> ppr excess_sig_tcbs + , text "res_kind" <+> ppr res_kind + , text "sig_res_kind'" <+> ppr sig_res_kind' + ] + + -- Unify res_ki (from the type declaration) with + -- sig_res_kind', the residual kind from the kind signature. + ; checkExpectedResKind sig_res_kind' res_kind + + -- Add more binders for data/newtype, so the result kind has no arrows + -- See Note [Datatype return kinds] + ; if null excess_sig_tcbs || not (needsEtaExpansion flav) + then return ([], sig_res_kind') + else return (excess_sig_tcbs, sig_res_kind) + } + + + -- Check that there are no unsolved equalities + ; let all_tcbs = skol_tcbs ++ extra_tcbs + ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted + + -- Check that distinct binders map to distinct tyvars (see #20916). For example + -- type T :: k -> k -> Type + -- data T (a::p) (b::q) = ... + -- Here p and q both map to the same kind variable k. We don't allow this + -- so we must check that they are distinct. A similar thing happens + -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference. + -- + -- With visible dependent quantification, one of the binders involved + -- may be explicit. Consider #24604 + -- type UF :: forall zk -> zk -> Constraint + -- class UF kk (xb :: k) + -- Here `k` and `kk` both denote the same variable; but only `k` is implicit + -- Hence we need to add skol_scoped_tvs + ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs + ; let implicit_prs = implicit_nms `zip` implicit_tvs + dup_chk_prs = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs + ; unless (null implicit_nms) $ -- No need if no implicit tyvars + checkForDuplicateScopedTyVars dup_chk_prs + ; checkForDisconnectedScopedTyVars name flav all_tcbs implicit_prs + + -- Swizzle the Names so that the TyCon uses the user-declared implicit names + -- E.g type T :: k -> Type + -- data T (a :: j) = .... + -- We want the TyConBinders of T to be [j, a::j], not [k, a::k] + -- Why? So that the TyConBinders of the TyCon will lexically scope over the + -- associated types and methods of a class. + ; let swizzle_env = mkVarEnv (map swap implicit_prs) + (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptySubst all_tcbs + swizzled_kind = substTy subst tycon_res_kind + all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) + + ; traceTc "kcCheckDeclHeader swizzle" $ vcat + [ text "sig_tcbs =" <+> ppr sig_tcbs + , text "implicit_prs =" <+> ppr implicit_prs + , text "hs_tv_bndrs =" <+> ppr hs_tv_bndrs + , text "all_tcbs =" <+> pprTyVars (binderVars all_tcbs) + , text "swizzled_tcbs =" <+> pprTyVars (binderVars swizzled_tcbs) + , text "tycon_res_kind =" <+> ppr tycon_res_kind + , text "swizzled_kind =" <+> ppr swizzled_kind ] + + -- Build the final, generalized PolyTcTyCon + -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs + -- because the tv_prs is used when (say) typechecking the RHS of + -- a type synonym. + ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs + True -- Make a PolyTcTyCon, fully generalised + flav + + ; traceTc "kcCheckDeclHeader_sig }" $ vcat + [ text "tyConName = " <+> ppr (tyConName tc) + , text "sig_kind =" <+> debugPprType sig_kind + , text "tyConKind =" <+> debugPprType (tyConKind tc) + , text "tyConBinders = " <+> ppr (tyConBinders tc) + , text "tyConResKind" <+> debugPprType (tyConResKind tc) + ] + ; return tc } + +-- | Check the result kind annotation on a type constructor against +-- the corresponding section of the standalone kind signature. +-- Drops invisible binders that interfere with unification. +checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature + -> ContextKind -- ^ the result kind from the declaration header + -> TcM () +checkExpectedResKind _ AnyKind + = return () -- No signature in the declaration header +checkExpectedResKind sig_kind res_ki + = do { actual_res_ki <- newExpectedKind res_ki + + ; let -- Drop invisible binders from sig_kind until they match up + -- with res_ki. By analogy with checkExpectedKind. + n_res_invis_bndrs = invisibleBndrCount actual_res_ki + n_sig_invis_bndrs = invisibleBndrCount sig_kind + n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs + + (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind + + ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki } + +matchUpSigWithDecl + :: Name -- Name of the type constructor for error messages + -> [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature + -> TcKind -- The tail end of the kind signature + -> [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] -- User-written binders in decl + -> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope + -- Argument is excess TyConBinders and tail kind + -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars + , [TcTyVar] -- Skolem tyvars brought into lexical scope by this matching-up + , a ) +-- See Note [Matching a kind signature with a declaration] +-- Invariant: Length of returned TyConBinders + length of excess TyConBinders +-- = length of incoming TyConBinders +matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside + = go emptySubst sig_tcbs hs_bndrs + where + go subst tcbs [] + = do { let (subst', tcbs') = substTyConBindersX subst tcbs + ; res <- thing_inside tcbs' (substTy subst' sig_res_kind) + ; return ([], [], res) } + + go _ [] hs_bndrs + = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs) + + go subst (tcb : tcbs') hs_bndrs@(hs_bndr : hs_bndrs') + | zippable (binderFlag tcb) (hsTyVarBndrFlag (unLoc hs_bndr)) + = -- Visible TyConBinder, so match up with the hs_bndrs + do { let Bndr tv vis = tcb + tv' = updateTyVarKind (substTy subst) $ + 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 + subst' = extendTCvSubstWithClone subst tv tv' + ; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv') + ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv') + ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $ + go subst' tcbs' hs_bndrs' + ; return (Bndr tv' vis : tcbs', tv':tvs, res) } + -- We do a tcExtendTyVarEnv [tv'], so we return tv' in + -- the list of lexically-scoped skolem type variables + + | skippable (binderFlag tcb) + = -- Invisible TyConBinder, so do not consume one of the hs_bndrs + do { let (subst', tcb') = substTyConBinderX subst tcb + ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb') + ; (tcbs', tvs, res) <- go subst' tcbs' hs_bndrs + -- NB: pass on hs_bndrs unchanged; we do not consume a + -- HsTyVarBndr for an invisible TyConBinder + ; return (tcb' : tcbs', tvs, res) } + -- Return `tvs`; no new lexically-scoped TyVars brought into scope + + | otherwise = + -- At this point we conclude that: + -- * the quantifier (tcb) is visible: (ty -> ...), (forall a -> ...) + -- * the binder (hs_bndr) is invisible: @t, @(t :: k) + -- Any other combination should have been handled by the zippable/skippable clauses. + failWithTc (TcRnInvalidInvisTyVarBndr name hs_bndr) + + tc_hs_bndr :: HsTyVarBndr (HsBndrVis GhcRn) GhcRn -> TcKind -> TcM () + 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. + -- In particular: we match up if + -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified) + -- (b) HsBndr looks like a, and TyCon binder is forall k -> (NamedTCB Required) + -- or k -> (AnonTCB) + zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool + zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- (a) + zippable vis (HsBndrRequired _) = isVisibleTcbVis vis -- (b) + + -- See GHC Proposal #425, section "Kind checking", + -- where zippable and skippable are defined. + 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) + where + (subst', tv') = substTyVarBndr subst tv + +substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder]) +substTyConBindersX = mapAccumL substTyConBinderX + +swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder) +swizzleTcb swizzle_env subst (Bndr tv vis) + = (subst', Bndr tv2 vis) + where + subst' = extendTCvSubstWithClone subst tv tv2 + tv1 = updateTyVarKind (substTy subst) tv + tv2 = case lookupVarEnv swizzle_env tv of + Just user_name -> setTyVarName tv1 user_name + Nothing -> tv1 + -- NB: the SrcSpan on an implicitly-bound name deliberately spans + -- the whole declaration. e.g. + -- data T (a :: k) (b :: Type -> k) = .... + -- There is no single binding site for 'k'. + -- See Note [Source locations for implicitly bound type variables] + -- in GHC.Tc.Rename.HsType + +{- Note [kcCheckDeclHeader_sig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a kind signature 'sig_kind' and a declaration header, +kcCheckDeclHeader_sig verifies that the declaration conforms to the +signature. The end result is a PolyTcTyCon 'tc' such that: + tyConKind tc == sig_kind + +Basic plan is this: + * splitTyConKind: Take the Kind from the separate kind signature, and + decompose it all the way to a [TyConBinder] and a Kind in the corner. + + NB: these TyConBinders contain TyVars, not TcTyVars. + + * matchUpSigWithDecl: match the [TyConBinder] from the signature with + the [LHsTyVarBndr (HsBndrVis GhcRn) GhcRn] from the declaration. The latter are the + explicit, user-written binders. e.g. + data T (a :: k) b = .... + There may be more of the former than the latter, because the former + include invisible binders. matchUpSigWithDecl uses isVisibleTcbVis + to decide which TyConBinders are visible. + + * matchUpSigWithDecl also skolemises the [TyConBinder] to produce + a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder]. + Each new TyConBinder + - Uses the Name from the LHsTyVarBndr, if available, both because that's + what the user expects, and because the binding site accurately comes + from the data/type declaration. + - Uses a skolem TcTyVar. We need these to allow unification. + + * machUpSigWithDecl also unifies the user-supplied kind signature for each + LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming + from the separate kind signature). + + * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate + signature with the kind signature (if any) in the data/type declaration. + E.g. + type S :: forall k. k -> k -> Type + type family S (a :: j) :: j -> Type + Here we match up the 'k ->' with (a :: j); and then must unify the leftover + part of the signature (k -> Type) with the kind signature of the decl, + (j -> Type). This unification, done in kcCheckDeclHeader, needs TcTyVars. + +Note [Arity of type families and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type F0 :: forall k. k -> k -> Type + type family F0 + + type F1 :: forall k. k -> k -> Type + type family F1 @k + + type F2a :: forall k. k -> k -> Type + type family F2a @k a + + type F2b :: forall k. k -> k -> Type + type family F2b a + + type F3 :: forall k. k -> k -> Type + type family F3 a b + +All five have the same /kind/, but what /arity/ do they have? +For a type family, the arity is critical: +* A type family must always appear saturated (up to its arity) +* A type family can match only on `arity` arguments, not further ones +* The arity is recorded by `tyConArity`, and is equal to the number of + `TyConBinders` in the `TyCon`. +* In this context "arity" includes both kind and type arguments. + +The arity is not determined by the kind signature (all five have the same signature). +Rather, it is determined by the declaration of the family: +* `F0` has arity 0. +* `F1` has arity 1. +* `F2a` has arity 2. +* `F2b` also has arity 2: the kind argument is invisible. +* `F3` has arity 3; again the kind argument is invisible. + +The matching-up of kind signature with the declaration itself is done by +`matchUpWithSigDecl`. + +Note [discardResult in tcHsTvbKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use 'unifyKind' to check inline kind annotations in declaration headers +against the signature. + + type T :: [i] -> Maybe j -> Type + data T (a :: [k1]) (b :: Maybe k2) :: Type where ... + +Here, we will unify: + + [k1] ~ [i] + Maybe k2 ~ Maybe j + Type ~ Type + +The end result is that we fill in unification variables k1, k2: + + k1 := i + k2 := j + +We also validate that the user isn't confused: + + type T :: Type -> Type + data T (a :: Bool) = ... + +This will report that (Type ~ Bool) failed to unify. + +Now, consider the following example: + + type family Id a where Id x = x + type T :: Bool -> Type + type T (a :: Id Bool) = ... + +We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion. +However, we are free to discard it, as the kind of 'T' is determined by the +signature, not by the inline kind annotation: + + we have T :: Bool -> Type + rather than T :: Id Bool -> Type + +This (Id Bool) will not show up anywhere after we're done validating it, so we +have no use for the produced coercion. + +Note [Kind variable ordering for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should be the kind of `T` in the following example? (#15591) + + class C (a :: Type) where + type T (x :: f a) + +As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify +the kind variables in left-to-right order of first occurrence in order to +support visible kind application. But we cannot perform this analysis on just +T alone, since its variable `a` actually occurs /before/ `f` if you consider +the fact that `a` was previously bound by the parent class `C`. That is to say, +the kind of `T` should end up being: + + T :: forall a f. f a -> Type + +(It wouldn't necessarily be /wrong/ if the kind ended up being, say, +forall f a. f a -> Type, but that would not be as predictable for users of +visible kind application.) + +In contrast, if `T` were redefined to be a top-level type family, like `T2` +below: + + type family T2 (x :: f (a :: Type)) + +Then `a` first appears /after/ `f`, so the kind of `T2` should be: + + T2 :: forall f a. f a -> Type + +In order to make this distinction, we need to know (in kcCheckDeclHeader) which +type variables have been bound by the parent class (if there is one). With +the class-bound variables in hand, we can ensure that we always quantify +these first. +-} + + +{- ********************************************************************* +* * + Expected kinds +* * +********************************************************************* -} + +-- | Describes the kind expected in a certain context. +data ContextKind = TheKind TcKind -- ^ a specific kind + | AnyKind -- ^ any kind will do + | OpenKind -- ^ something of the form @TYPE _@ + +-- debug only +instance Outputable ContextKind where + ppr AnyKind = text "AnyKind" + ppr OpenKind = text "OpenKind" + ppr (TheKind k) = text "TheKind" <+> ppr k + +----------------------- +newExpectedKind :: ContextKind -> TcM TcKind +newExpectedKind (TheKind k) = return k +newExpectedKind AnyKind = newMetaKindVar +newExpectedKind OpenKind = newOpenTypeKind + +----------------------- +expectedKindInCtxt :: UserTypeCtxt -> ContextKind +-- Depending on the context, we might accept any kind (for instance, in a TH +-- splice), or only certain kinds (like in type signatures). +expectedKindInCtxt (TySynCtxt _) = AnyKind +expectedKindInCtxt (GhciCtxt {}) = AnyKind +-- The types in a 'default' decl can have varying kinds +-- See Note [Extended defaults]" in GHC.Tc.Utils.Env +expectedKindInCtxt DefaultDeclCtxt = AnyKind +expectedKindInCtxt DerivClauseCtxt = AnyKind +expectedKindInCtxt TypeAppCtxt = AnyKind +expectedKindInCtxt (ForSigCtxt _) = TheKind liftedTypeKind +expectedKindInCtxt (InstDeclCtxt {}) = TheKind constraintKind +expectedKindInCtxt SpecInstCtxt = TheKind constraintKind +expectedKindInCtxt _ = OpenKind + + +{- ********************************************************************* +* * + Scoped tyvars that map to the same thing +* * +********************************************************************* -} + +checkForDisconnectedScopedTyVars :: Name -> TyConFlavour TyCon -> [TcTyConBinder] + -> [(Name,TcTyVar)] -> TcM () +-- See Note [Disconnected type variables] +-- For the type synonym case see Note [Out of arity type variables] +-- `scoped_prs` is the mapping gotten by unifying +-- - the standalone kind signature for T, with +-- - the header of the type/class declaration for T +checkForDisconnectedScopedTyVars name flav all_tcbs scoped_prs + -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables] + | needsEtaExpansion flav = mapM_ report_disconnected (filterOut ok scoped_prs) + | flav == TypeSynonymFlavour = mapM_ report_out_of_arity (filterOut ok scoped_prs) + | otherwise = pure () + where + all_tvs = mkVarSet (binderVars all_tcbs) + ok (_, tc_tv) = tc_tv `elemVarSet` all_tvs + + report_disconnected :: (Name,TcTyVar) -> TcM () + report_disconnected (nm, _) + = setSrcSpan (getSrcSpan nm) $ + addErrTc $ TcRnDisconnectedTyVar nm + + report_out_of_arity :: (Name,TcTyVar) -> TcM () + report_out_of_arity (tv_nm, _) + = setSrcSpan (getSrcSpan tv_nm) $ + addErrTc $ TcRnOutOfArityTyVar name tv_nm + +checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () +-- Check for duplicates +-- See Note [Aliasing in type and class declarations] +checkForDuplicateScopedTyVars scoped_prs + = unless (null err_prs) $ + do { mapM_ report_dup err_prs; failM } + where + -------------- Error reporting ------------ + err_prs :: [(Name,Name)] + err_prs = [ (n1,n2) + | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs + , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ] + -- This nubBy avoids bogus error reports when we have + -- [("f", f), ..., ("f",f)....] in swizzle_prs + -- which happens with class C f where { type T f } + + report_dup :: (Name,Name) -> TcM () + report_dup (n1,n2) + = setSrcSpan (getSrcSpan n2) $ + addErrTc $ TcRnDifferentNamesForTyVar n1 n2 + + +{- Note [Aliasing in type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data SameKind (a::k) (b::k) + data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c +We do not allow this, because `k1` and `k2` would both stand for the same type +variable -- they are both aliases for `k`. + +Other examples + data T2 (a::k1) = MkT2 (SameKind a Int) -- k1 stands for Type + data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b) -- k1 and k2 are aliases + + type UF :: forall zk. zk -> Constraint + class UF @kk (xb :: k) where -- kk and k are aliases + op :: (xs::kk) -> Bool + +See #24604 for an example that crashed GHC. + +There is a design choice here. It would be possible to allow implicit type variables +like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/. This is in fact +the rule we use in /terms/ pattern signatures: + f :: [Int] -> Int + f ((x::a) : xs) = ... +Here `a` stands for `Int`. But in type /signatures/ we make a different choice: + f1 :: forall (a::k1) (b::k2). SameKind a b -> blah + f2 :: forall (a::k). SameKind a Int -> blah + +Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is +rejected because `k` stands for `Int`. + +Our current choice is that type and class declarations behave more like signatures; +we do not allow aliasing. That is what `checkForDuplicateScopedTyVars` checks. +See !12328 for some design discussion. + + +Note [Disconnected type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note applies when kind-checking the header of a type/class decl that has +a separate, standalone kind signature. See #24083. + +Consider: + type S a = Type + + type C :: forall k. S k -> Constraint + class C (a :: S kk) where + op :: ...kk... + +Note that the class has a separate kind signature, so the elaborated decl should +look like + class C @kk (a :: S kk) where ... + +But how can we "connect up" the scoped variable `kk` with the skolem kind from the +standalone kind signature for `C`? In general we do this by unifying the two. +For example + type T k = (k,Type) + type W :: forall k. T k -> Type + data W (a :: (x,Type)) = ..blah blah.. + +When we encounter (a :: (x,Type)) we unify the kind (x,Type) with the kind (T k) +from the standalone kind signature. Of course, unification looks through synonyms +so we end up with the mapping [x :-> k] that connects the scoped type variable `x` +with the kind from the signature. + +But in our earlier example this unification is ineffective -- because `S` is a +phantom synonym that just discards its argument. So our plan is this: + + if matchUpSigWithDecl fails to connect `kk with `k`, by unification, + we give up and complain about a "disconnected" type variable. + +See #24083 for dicussion of alternatives, none satisfactory. Also the fix is +easy: just add an explicit `@kk` parameter to the declaration, to bind `kk` +explicitly, rather than binding it implicitly via unification. + +(DTV1) We only want to make this check when there /are/ scoped type variables; and + that is determined by needsEtaExpansion. Examples: + + type C :: x -> y -> Constraint + class C a :: b -> Constraint where { ... } + -- The a,b scope over the "..." + + type D :: forall k. k -> Type + data family D :: kk -> Type + -- Nothing for `kk` to scope over! + + In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will + return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do + the check-for-disconnected-tyvars check we'll complain that `kk` is not bound + to one of `all_tcbs` (see #24083, comments about the `singletons` package). + + The scoped-tyvar stuff is needed precisely for data/class/newtype declarations, + where needsEtaExpansion is True. + +Note [Out of arity type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(Relevant ticket: #24470) +Type synonyms have a special scoping rule that allows implicit quantification in +the outermost kind signature: + + type P_e :: k -> Type + type P_e @k = Proxy :: k -> Type -- explicit binding + + type P_i = Proxy :: k -> Type -- implicit binding (relies on the special rule) + +This is a deprecated feature (warning flag: -Wimplicit-rhs-quantification) but +we have to support it for a couple more releases. It is explained in more detail +in Note [Implicit quantification in type synonyms] in GHC.Rename.HsType. + +Type synonyms `P_e` and `P_i` are equivalent. Both of them have kind +`forall k. k -> Type` and arity 1. (Recall that the arity of a type synonym is +the number of arguments it requires at use sites; the arity matter because +unsaturated application of type families and type synonyms is not allowed). + +We start to see problems when implicit RHS quantification (as in `P_i`) is +combined with a standalone king signature (like the one that `P_e` has). +That is: + + type P_i_sig :: k -> Type + type P_i_sig = Proxy :: k -> Type + +Per GHC Proposal #425, the arity of `P_i_sig` is determined /by the LHS only/, +which has no binders. So the arity of `P_i_sig` is 0. +At the same time, the legacy implicit quantification rule dictates that `k` is +brought into scope, as if there was a binder `@k` on the LHS. + +We end up with a `k` that is in scope on the RHS but cannot be bound implicitly +on the LHS without affecting the arity. This led to #24470 (a compiler crash) + + GHC internal error: ‘k’ is not in scope during type checking, + but it passed the renamer + +This problem occurs only if the arity of the type synonym is insufficiently +high to accommodate an implicit binding. It can be worked around by adding an +unused binder on the LHS: + + type P_w :: k -> Type + type P_w @_w = Proxy :: k -> Type + +The variable `_w` is unused. The only effect of the `@_w` binder is that the +arity of `P_w` is changed from 0 to 1. However, bumping the arity is exactly +what's needed to make the implicit binding of `k` possible. + +All this is a rather unfortunate bit of accidental complexity that will go away +when GHC drops support for implicit RHS quantification. In the meantime, we +ought to produce a proper error message instead of a compiler panic, and we do +that with a check in checkForDisconnectedScopedTyVars: + + | flav == TypeSynonymFlavour = mapM_ report_out_of_arity (filterOut ok scoped_prs) + +-} + +{- ********************************************************************* +* * + Bringing type variables into scope +* * +********************************************************************* -} + +-------------------------------------- +-- HsForAllTelescope +-------------------------------------- + +tcTKTelescope :: TcTyMode + -> HsForAllTelescope GhcRn + -> TcM a + -> TcM ([TcTyVarBinder], a) +-- A HsForAllTelescope comes only from a HsForAllTy, +-- an explicit, user-written forall type +tcTKTelescope mode tele thing_inside = case tele of + HsForAllVis { hsf_vis_bndrs = bndrs } + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -- req_tv_bndrs :: [VarBndr TyVar ()], + -- but we want [VarBndr TyVar ForAllTyFlag] + ; return (tyVarReqToBinders req_tv_bndrs, thing) } + + HsForAllInvis { hsf_invis_bndrs = bndrs } + -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode + , sm_tvtv = SMDSkolemTv skol_info } + ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside + -- inv_tv_bndrs :: [VarBndr TyVar Specificity], + -- but we want [VarBndr TyVar ForAllTyFlag] + ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } + +-------------------------------------- +-- HsOuterTyVarBndrs +-------------------------------------- + +bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc + => SkolemMode + -> HsOuterTyVarBndrs flag GhcRn + -> TcM a + -> TcM (HsOuterTyVarBndrs flag GhcTc, a) +bindOuterTKBndrsX skol_mode outer_bndrs thing_inside + = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_tvs} -> + do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside + ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} + , thing) } + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside + ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' + , hso_bndrs = exp_bndrs } + , thing) } + +--------------- +outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar] +-- The returned [TcTyVar] is not necessarily in dependency order +-- at least for the HsOuterImplicit case +outerTyVars (HsOuterImplicit { hso_ximplicit = tvs }) = tvs +outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs + +--------------- +outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder] +outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs] +outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs + +--------------- +scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc) +-- Sort any /implicit/ binders into dependency order +-- (zonking first so we can see the dependencies) +-- /Explicit/ ones are already in the right order +scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs}) + = do { imp_tvs <- zonkAndScopedSort imp_tvs + ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) } +scopedSortOuter bndrs@(HsOuterExplicit{}) + = -- No need to dependency-sort (or zonk) explicit quantifiers + return bndrs + +--------------- +bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn + -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) +bindOuterSigTKBndrs_Tv + = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) + +bindOuterSigTKBndrs_Tv_M :: TcTyMode + -> HsOuterSigTyVarBndrs GhcRn + -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a) +-- Do not push level; do not make implication constraint; use Tvs +-- Two major clients of this "bind-only" path are: +-- Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl +-- Note [Checking partial type signatures] +bindOuterSigTKBndrs_Tv_M mode + = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv + , sm_holes = mode_holes mode }) + +bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn + -> TcM a + -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) +bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside + = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDTyVarTv }) + hs_bndrs thing_inside + -- sm_clone=False: see Note [Cloning for type variable binders] + +bindOuterFamEqnTKBndrs :: SkolemInfo + -> HsOuterFamEqnTyVarBndrs GhcRn + -> TcM a + -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a) +bindOuterFamEqnTKBndrs skol_info + = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDSkolemTv skol_info }) + -- sm_clone=False: see Note [Cloning for type variable binders] + +--------------- +tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc + => SkolemInfo + -> HsOuterTyVarBndrs flag GhcRn + -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) +tcOuterTKBndrs skol_info + = tcOuterTKBndrsX (smVanilla { sm_clone = False + , sm_tvtv = SMDSkolemTv skol_info }) + skol_info + -- Do not clone the outer binders + -- See Note [Cloning for type variable binders] under "must not" + +tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to support traceTc + => SkolemMode -> SkolemInfo + -> HsOuterTyVarBndrs flag GhcRn + -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a) +-- Push level, capture constraints, make implication +tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside + = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = imp_tvs} -> + do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside + ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'} + , thing) } + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside + ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs' + , hso_bndrs = exp_bndrs } + , thing) } + +--------------- +tcGadtConTyVarBndrs :: SkolemInfo + -> HsOuterSigTyVarBndrs GhcRn + -> [HsForAllTelescope GhcRn] + -> TcM a -> TcM ([TcTyVarBinder], a) +tcGadtConTyVarBndrs skol_info outer inner thing_inside + = do { (outer_bndrs, (inner_tvbs, a)) <- + tcOuterTKBndrs skol_info outer $ + tcExplicitTKBndrs skol_info (concatMap hsForAllTelescopeBndrs inner) $ + thing_inside + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvbs = tyVarSpecToBinders (outerTyVarBndrs outer_bndrs) + ; return (outer_tvbs ++ inner_tvbs, a) } + +-------------------------------------- +-- Explicit tyvar binders +-------------------------------------- + +tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +tcExplicitTKBndrs skol_info + = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) + +tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed -- Only to suppor traceTc + => SkolemMode + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +-- Push level, capture constraints, and emit an implication constraint. +-- The implication constraint has a ForAllSkol ic_info, +-- so that it is subject to a telescope test. +tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of + Nothing -> do + { res <- thing_inside + ; return ([], res) } + + Just bndrs1 -> do + { (tclvl, wanted, (skol_tvs, res)) + <- pushLevelAndCaptureConstraints $ + bindExplicitTKBndrsX skol_mode bndrs $ + thing_inside + + -- Set up SkolemInfo for telescope test + ; let bndr_1 = NE.head bndrs1; bndr_n = NE.last bndrs1 + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs))) + -- Notice that we use ForAllSkol here, ignoring the enclosing + -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope + -- test applies only to ForAllSkol + + ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n)) + $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted + + ; return (skol_tvs, res) } + +---------------- +-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied +-- 'TcTyMode'. +bindExplicitTKBndrs_Skol + :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc + => SkolemInfo + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Tv + :: (OutputableBndrFlag flag 'Renamed) -- Only to suppor traceTc + => [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info }) +bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) + -- sm_clone: see Note [Cloning for type variable binders] + +bindExplicitTKBndrs_Q_Skol + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => SkolemInfo + -> ContextKind + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) + +bindExplicitTKBndrs_Q_Tv + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => ContextKind + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) +-- These do not clone: see Note [Cloning for type variable binders] +bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside + = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info }) + hs_bndrs thing_inside + -- sm_clone=False: see Note [Cloning for type variable binders] + +bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside + = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True + , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) + hs_bndrs thing_inside + -- sm_clone=False: see Note [Cloning for type variable binders] + +bindExplicitTKBndrsX + :: (OutputableBndrFlag flag 'Renamed) -- Only to support traceTc + => SkolemMode + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind + , sm_holes = hole_info }) + hs_tvs thing_inside + = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs) + ; go hs_tvs } + where + tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info } + -- Inherit the HoleInfo from the context + + go [] = do { res <- thing_inside + ; return ([], res) } + go (L _ hs_tv : hs_tvs) + = do { lcl_env <- getLclTypeEnv + ; tv <- tc_hs_bndr lcl_env hs_tv + -- Extend the environment as we go, in case a binder + -- is mentioned in the kind of a later binder + -- 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 (mk_tvb_pairs hs_tv tv) $ + go hs_tvs + ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } + + 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 + = do { check_hs_bndr_kind name (tyVarKind tv) kind + ; return tv } + | otherwise + = do { name <- tcHsBndrVarName bvar + ; kind' <- tc_hs_bndr_kind name kind + ; newTyVarBndr skol_mode name kind' } + + 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 + + -- 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 + True -> do { uniq <- newUnique + ; return (setNameUnique name uniq) } + False -> return name + ; details <- case tvtv of + SMDTyVarTv -> newMetaDetails TyVarTv + SMDSkolemTv skol_info -> + do { lvl <- getTcLevel + ; return (SkolemTv skol_info lvl False) } + ; return (mkTcTyVar name kind details) } + +-------------------------------------- +-- Implicit tyvar binders +-------------------------------------- + +tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo + -> [Name] + -> TcM a + -> TcM ([TcTyVar], a) +-- The workhorse: +-- push level, capture constraints, and emit an implication constraint +tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside + | null bndrs -- Short-cut the common case with no quantifiers + -- E.g. f :: Int -> Int + -- makes a HsOuterImplicit with empty bndrs, + -- and tcOuterTKBndrsX goes via here + = do { res <- thing_inside; return ([], res) } + | otherwise + = do { (tclvl, wanted, (skol_tvs, res)) + <- pushLevelAndCaptureConstraints $ + bindImplicitTKBndrsX skol_mode bndrs $ + thing_inside + + ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted + + ; return (skol_tvs, res) } + +------------------ +bindImplicitTKBndrs_Skol, + bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a) + +bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a) +bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info }) +bindImplicitTKBndrs_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv }) +bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info }) +bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv }) + +bindImplicitTKBndrsX + :: SkolemMode + -> [Name] -- Generated by renamer; not in dependency order + -> TcM a + -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed in [Name] +bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind }) + tv_names thing_inside + = do { lcl_env <- getLclTypeEnv + ; tkvs <- mapM (new_tv lcl_env) tv_names + ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs) + ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs) + thing_inside + ; return (tkvs, res) } + where + new_tv lcl_env name + | check_parent + , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name + = return tv + | otherwise + = do { kind <- newExpectedKind ctxt_kind + ; newTyVarBndr skol_mode name kind } + +-------------------------------------- +-- SkolemMode +-------------------------------------- + +-- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or +-- implicit ('Name') binder in a type. It is just a record of flags +-- that describe what sort of 'TcTyVar' to create. +data SkolemMode + = SM { sm_parent :: Bool -- True <=> check the in-scope parent type variable + -- Used only for asssociated types + + , sm_clone :: Bool -- True <=> fresh unique + -- See Note [Cloning for type variable binders] + + , sm_tvtv :: SkolemModeDetails -- True <=> use a TyVarTv, rather than SkolemTv + -- Why? See Note [Inferring kinds for type declarations] + -- in GHC.Tc.TyCl, and (in this module) + -- Note [Checking partial type signatures] + + , sm_kind :: ContextKind -- Use this for the kind of any new binders + + , sm_holes :: HoleInfo -- What to do for wildcards in the kind + } + +data SkolemModeDetails + = SMDTyVarTv + | SMDSkolemTv SkolemInfo + + +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 + , sm_kind = AnyKind + , sm_holes = Nothing } + +{- Note [Cloning for type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes we must clone the Name of a type variable binder (written in +the source program); and sometimes we must not. This is controlled by +the sm_clone field of SkolemMode. + +In some cases it doesn't matter whether or not we clone. Perhaps +it'd be better to use MustClone/MayClone/MustNotClone. + +When we /must not/ clone +* In the binders of a type signature (tcOuterTKBndrs) + f :: forall a{27}. blah + f = rhs + Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType), + we must get the type (forall a{27}. blah) for the Id f, because + we bring that type variable into scope when we typecheck 'rhs'. + +* In the binders of a data family instance (bindOuterFamEqnTKBndrs) + data instance + forall p q. D (p,q) = D1 p | D2 q + We kind-check the LHS in tcDataFamInstHeader, and then separately + (in tcDataFamInstDecl) bring p,q into scope before looking at the + the constructor decls. + +* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone + We take advantage of this in kcInferDeclHeader: + all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs) + If we cloned, we'd need to take a bit more care here; not hard. + +* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone. + There is no need, I think. + + The payoff here is that avoiding gratuitous cloning means that we can + almost always take the fast path in swizzleTcTyConBndrs. + +When we /must/ clone. +* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning + + This for a narrow and tricky reason which, alas, I couldn't find a + simpler way round. #16221 is the poster child: + + data SameKind :: k -> k -> * + data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int + + When kind-checking T, we give (a :: kappa1). Then: + + - In kcConDecl we make a TyVarTv unification variable kappa2 for k2 + (as described in Note [Using TyVarTvs for kind-checking GADTs], + even though this example is an existential) + - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv + - We end up unifying kappa1 := kappa2, because of the (SameKind a b) + + Now we generalise over kappa2. But if kappa2's Name is precisely k2 + (i.e. we did not clone) we'll end up giving T the utterly final kind + T :: forall k2. k2 -> * + Nothing directly wrong with that but when we typecheck the data constructor + we have k2 in scope; but then it's brought into scope /again/ when we find + the forall k2. This is chaotic, and we end up giving it the type + MkT :: forall k2 (a :: k2) k2 (b :: k2). + SameKind @k2 a b -> Int -> T @{k2} a + which is bogus -- because of the shadowing of k2, we can't + apply T to the kind or a! + + And there no reason /not/ to clone the Name when making a unification + variable. So that's what we do. +-} + +-------------------------------------- +-- Binding type/class variables in the +-- kind-checking and typechecking phases +-------------------------------------- + +bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a +-- ^ Bring into scope the binders of a PolyTcTyCon +-- Used for the type variables of a type or class decl +-- in the "kind checking" and "type checking" pass, +-- but not in the initial-kind run. +bindTyClTyVars tycon_name thing_inside + = do { tycon <- tcLookupTcTyCon tycon_name -- The tycon is a PolyTcTyCon + ; let res_kind = tyConResKind tycon + binders = tyConBinders tycon + ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders) + ; tcExtendTyVarEnv (binderVars binders) $ + thing_inside binders res_kind } + +bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a +-- Like bindTyClTyVars, but in addition +-- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars +-- We always do this same zonking after a call to bindTyClTyVars, but +-- here we do it right away because there are no more unifications to come +bindTyClTyVarsAndZonk tycon_name thing_inside + = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind -> + do { (bndrs, kind) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { kind <- zonkTcTypeToTypeX tc_kind + ; return (bndrs, kind) } + ; thing_inside bndrs kind } + + +{- ********************************************************************* +* * + Kind generalisation +* * +********************************************************************* -} + +zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] +zonkAndScopedSort spec_tkvs + = do { spec_tkvs <- liftZonkM $ zonkTcTyVarsToTcTyVars spec_tkvs + -- Zonk the kinds, to we can do the dependency analysis + + -- Do a stable topological sort, following + -- Note [Ordering of implicit variables] in GHC.Rename.HsType + ; return (scopedSort spec_tkvs) } + +-- | Generalize some of the free variables in the given type. +-- All such variables should be *kind* variables; any type variables +-- should be explicitly quantified (with a `forall`) before now. +-- +-- The WantedConstraints are un-solved kind constraints. Generally +-- they'll be reported as errors later, but meanwhile we refrain +-- from quantifying over any variable free in these unsolved +-- constraints. See Note [Failure in local type signatures]. +-- +-- But in all cases, generalize only those variables whose TcLevel is +-- strictly greater than the ambient level. This "strictly greater +-- than" means that you likely need to push the level before creating +-- whatever type gets passed here. +-- +-- Any variable whose level is greater than the ambient level but is +-- not selected to be generalized will be promoted. (See [Promoting +-- unification variables] in "GHC.Tc.Solver" and Note [Recipe for +-- checking a signature].) +-- +-- The resulting KindVar are the variables to quantify over, in the +-- correct, well-scoped order. They should generally be Inferred, not +-- Specified, but that's really up to the caller of this function. +kindGeneralizeSome :: SkolemInfo + -> WantedConstraints + -> TcType -- ^ needn't be zonked + -> TcM [KindVar] +kindGeneralizeSome skol_info wanted kind_or_type + = do { -- Use the "Kind" variant here, as any types we see + -- here will already have all type variables quantified; + -- thus, every free variable is really a kv, never a tv. + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; filtered_dvs <- filterConstrainedCandidates wanted dvs + ; traceTc "kindGeneralizeSome" $ + vcat [ text "type:" <+> ppr kind_or_type + , text "dvs:" <+> ppr dvs + , text "filtered_dvs:" <+> ppr filtered_dvs ] + ; quantifyTyVars skol_info DefaultNonStandardTyVars filtered_dvs } + +filterConstrainedCandidates + :: WantedConstraints -- Don't quantify over variables free in these + -- Not necessarily fully zonked + -> CandidatesQTvs -- Candidates for quantification + -> TcM CandidatesQTvs +-- filterConstrainedCandidates removes any candidates that are free in +-- 'wanted'; instead, it promotes them. This bit is very much like +-- decidePromotedTyVars in GHC.Tc.Solver, but constraints are so much +-- simpler in kinds, it is much easier here. (In particular, we never +-- quantify over a constraint in a type.) +filterConstrainedCandidates wanted dvs + | isEmptyWC wanted -- Fast path for a common case + = return dvs + | otherwise + = do { wc_tvs <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfWC wanted) + ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) + ; _ <- promoteTyVarSet to_promote + ; return dvs' } + +-- |- Specialised version of 'kindGeneralizeSome', but with empty +-- WantedConstraints, so no filtering is needed +-- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC +kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar] +kindGeneralizeAll skol_info kind_or_type + = do { traceTc "kindGeneralizeAll" (ppr kind_or_type) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs } + +-- | Specialized version of 'kindGeneralizeSome', but where no variables +-- can be generalized, but perhaps some may need to be promoted. +-- Use this variant when it is unknowable whether metavariables might +-- later be constrained. +-- +-- To see why this promotion is needed, see +-- Note [Recipe for checking a signature], and especially +-- Note [Promotion in signatures]. +kindGeneralizeNone :: TcType -- needn't be zonked + -> TcM () +kindGeneralizeNone kind_or_type + = do { traceTc "kindGeneralizeNone" (ppr kind_or_type) + ; dvs <- candidateQTyVarsOfKind kind_or_type + ; _ <- promoteTyVarSet (candidateKindVars dvs) + ; return () } + +{- Note [Levels and generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = e +with no type signature. We are currently at level i. +We must + * Push the level to level (i+1) + * Allocate a fresh alpha[i+1] for the result type + * Check that e :: alpha[i+1], gathering constraint WC + * Solve WC as far as possible + * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i] + * Find the free variables with level > i, in this case gamma[i] + * Skolemise those free variables and quantify over them, giving + f :: forall g. beta[i-1] -> g + * Emit the residual constraint wrapped in an implication for g, + thus forall g. WC + +All of this happens for types too. Consider + f :: Int -> (forall a. Proxy a -> Int) + +Note [Kind generalisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do kind generalisation only at the outer level of a type signature. +For example, consider + T :: forall k. k -> * + f :: (forall a. T a -> Int) -> Int +When kind-checking f's type signature we generalise the kind at +the outermost level, thus: + f1 :: forall k. (forall (a:k). T k a -> Int) -> Int -- YES! +and *not* at the inner forall: + f2 :: (forall k. forall (a:k). T k a -> Int) -> Int -- NO! +Reason: same as for HM inference on value level declarations, +we want to infer the most general type. The f2 type signature +would be *less applicable* than f1, because it requires a more +polymorphic argument. + +NB: There are no explicit kind variables written in f's signature. +When there are, the renamer adds these kind variables to the list of +variables bound by the forall, so you can indeed have a type that's +higher-rank in its kind. But only by explicit request. + +Note [Kinds of quantified type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyVarBndrsGen quantifies over a specified list of type variables, +*and* over the kind variables mentioned in the kinds of those tyvars. + +Note that we must zonk those kinds (obviously) but less obviously, we +must return type variables whose kinds are zonked too. Example + (a :: k7) where k7 := k9 -> k9 +We must return + [k9, a:k9->k9] +and NOT + [k9, a:k7] +Reason: we're going to turn this into a for-all type, + forall k9. forall (a:k7). blah +which the type checker will then instantiate, and instantiate does not +look through unification variables! + +Hence using zonked_kinds when forming tvs'. + +-} + +----------------------------------- +maybeEtaExpandAlgTyCon :: TyConFlavour tc -> SkolemInfo + -> [TcTyConBinder] -> Kind + -> TcM ([TcTyConBinder], Kind) +maybeEtaExpandAlgTyCon flav skol_info tcbs res_kind + | needsEtaExpansion flav + = etaExpandAlgTyCon skol_info tcbs res_kind + | otherwise + = return ([], res_kind) + +etaExpandAlgTyCon :: SkolemInfo + -> [TcTyConBinder] -> Kind + -> TcM ([TcTyConBinder], Kind) +etaExpandAlgTyCon skol_info tcbs res_kind + = splitTyConKind skol_info in_scope avoid_occs res_kind + where + tyvars = binderVars tcbs + in_scope = mkInScopeSetList tyvars + avoid_occs = map getOccName tyvars + +needsEtaExpansion :: TyConFlavour tc -> Bool +needsEtaExpansion NewtypeFlavour = True +needsEtaExpansion DataTypeFlavour = True +needsEtaExpansion ClassFlavour = True +needsEtaExpansion _ = False + +splitTyConKind :: SkolemInfo + -> InScopeSet + -> [OccName] -- Avoid these OccNames + -> Kind -- Must be zonked + -> TcM ([TcTyConBinder], TcKind) +-- GADT decls can have a (perhaps partial) kind signature +-- e.g. data T a :: * -> * -> * where ... +-- This function makes up suitable (kinded) TyConBinders for the +-- argument kinds. E.g. in this case it might return +-- ([b::*, c::*], *) +-- Skolemises the type as it goes, returning skolem TcTyVars +-- Never emits constraints. +-- It's a little trickier than you might think: see Note [splitTyConKind] +-- See also Note [Datatype return kinds] in GHC.Tc.TyCl +splitTyConKind skol_info in_scope avoid_occs kind + = do { loc <- getSrcSpanM + ; new_uniqs <- getUniquesM + ; rdr_env <- getLocalRdrEnv + ; lvl <- getTcLevel + ; let new_occs = Inf.filter (\ occ -> + isNothing (lookupLocalRdrOcc rdr_env occ) && + -- Note [Avoid name clashes for associated data types] + not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings + subst = mkEmptySubst in_scope + details = SkolemTv skol_info (pushTcLevel lvl) False + -- As always, allocate skolems one level in + + go occs uniqs subst acc kind + = case splitPiTy_maybe kind of + Nothing -> (reverse acc, substTy subst kind) + + Just (Anon arg af, kind') + -> assert (af == FTF_T_T) $ + go occs' uniqs' subst' (tcb : acc) kind' + where + tcb = Bndr tv AnonTCB + arg' = substTy subst (scaledThing arg) + name = mkInternalName uniq occ loc + tv = mkTcTyVar name arg' details + subst' = extendSubstInScope subst tv + (uniq,uniqs') = case uniqs of + uniq:uniqs' -> (uniq,uniqs') + _ -> panic "impossible" + Inf occ occs' = occs + + Just (Named (Bndr tv vis), kind') + -> go occs uniqs subst' (tcb : acc) kind' + where + tcb = Bndr tv' (NamedTCB vis) + tc_tyvar = mkTcTyVar (tyVarName tv) (tyVarKind tv) details + (subst', tv') = substTyVarBndr subst tc_tyvar + + ; return (go new_occs new_uniqs subst [] kind) } + +isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool +isAllowedDataResKind AnyTYPEKind kind = isTypeLikeKind kind +isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind +isAllowedDataResKind LiftedKind kind = tcIsLiftedTypeKind kind + +-- | Checks that the return kind in a data declaration's kind signature is +-- permissible. There are three cases: +-- +-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@ +-- declaration, check that the return kind is @Type@. +-- +-- If the declaration is a @newtype@ or @newtype instance@ and the +-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so +-- that a return kind of the form @TYPE r@ (for some @r@) is permitted. +-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl". +-- +-- If dealing with a @data family@ declaration, check that the return kind is +-- either of the form: +-- +-- 1. @TYPE r@ (for some @r@), or +-- +-- 2. @k@ (where @k@ is a bare kind variable; see #12369) +-- +-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl" +checkDataKindSig :: DataSort -> Kind -- any arguments in the kind are stripped off + -> TcM () +checkDataKindSig data_sort kind + = do { dflags <- getDynFlags + ; traceTc "checkDataKindSig" (ppr kind) + ; checkTc (tYPE_ok dflags || is_kind_var) + (err_msg dflags) } + where + res_kind = snd (tcSplitPiTys kind) + -- Look for the result kind after + -- peeling off any foralls and arrows + + is_newtype :: Bool + is_newtype = + case data_sort of + DataDeclSort new_or_data -> new_or_data == NewType + DataInstanceSort new_or_data -> new_or_data == NewType + DataFamilySort -> False + + is_datatype :: Bool + is_datatype = + case data_sort of + DataDeclSort DataType -> True + DataInstanceSort DataType -> True + _ -> False + + is_data_family :: Bool + is_data_family = + case data_sort of + DataDeclSort{} -> False + DataInstanceSort{} -> False + DataFamilySort -> True + + allowed_kind :: DynFlags -> AllowedDataResKind + allowed_kind dflags + | is_newtype && xopt LangExt.UnliftedNewtypes dflags + -- With UnliftedNewtypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE r` since we don't want to accept + -- Constraint or Nat. + -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl. + = AnyTYPEKind + | is_data_family + -- If this is a `data family` declaration, we don't need to check if + -- UnliftedNewtypes is enabled, since data family declarations can + -- have return kind `TYPE r` unconditionally (#16827). + = AnyTYPEKind + | is_datatype && xopt LangExt.UnliftedDatatypes dflags + -- With UnliftedDatatypes, we allow kinds other than Type, but they + -- must still be of the form `TYPE (BoxedRep l)`, so that we don't + -- accept result kinds like `TYPE IntRep`. + -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl. + = AnyBoxedKind + | otherwise + = LiftedKind + + tYPE_ok :: DynFlags -> Bool + tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind + + -- In the particular case of a data family, permit a return kind of the + -- form `:: k` (where `k` is a bare kind variable). + is_kind_var :: Bool + is_kind_var | is_data_family = isJust (getCastedTyVar_maybe res_kind) + | otherwise = False + + err_msg :: DynFlags -> TcRnMessage + err_msg dflags = + TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags) + + ext_hint dflags + | isTypeLikeKind kind + , is_newtype + , not (xopt LangExt.UnliftedNewtypes dflags) + = Just SuggestUnliftedNewtypes + | tcIsBoxedTypeKind kind + , is_datatype + , not (xopt LangExt.UnliftedDatatypes dflags) + = Just SuggestUnliftedDatatypes + | otherwise + = Nothing + +-- | Checks that the result kind of a class is exactly `Constraint`, rejecting +-- type synonyms and type families that reduce to `Constraint`. See #16826. +checkClassKindSig :: Kind -> TcM () +checkClassKindSig kind = checkTc (isConstraintKind kind) err_msg + where + err_msg :: TcRnMessage + err_msg = TcRnClassKindNotConstraint kind + +tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] +-- Result is in 1-1 correspondence with orig_args +tcbVisibilities tc orig_args + = go (tyConKind tc) init_subst orig_args + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + go _ _ [] + = [] + + go fun_kind subst all_args@(arg : args) + | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind + = case tcb of + Anon _ af -> assert (af == FTF_T_T) $ + AnonTCB : go inner_kind subst args + Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args + where + subst' = extendTCvSubst subst tv arg + + | not (isEmptyTCvSubst subst) + = go (substTy subst fun_kind) init_subst all_args + + | otherwise + = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args) + + +{- Note [splitTyConKind] +~~~~~~~~~~~~~~~~~~~~~~~~ +Given + data T (a::*) :: * -> forall k. k -> * +we want to generate the extra TyConBinders for T, so we finally get + (a::*) (b::*) (k::*) (c::k) +The function splitTyConKind generates these extra TyConBinders from +the result kind signature. The same function is also used by +kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of +the TyCon given in a standalone kind signature. E.g. + type T :: forall (a::*). * -> forall k. k -> * + +We need to take care to give the TyConBinders + (a) Uniques that are fresh: the TyConBinders of a TyCon + must have distinct uniques. + + (b) Preferably, OccNames that are fresh. If we happen to re-use + OccNames that are other TyConBinders, we'll get a TyCon with + TyConBinders like [a_72, a_53]; same OccName, different Uniques. + Then when pretty-printing (e.g. in GHCi :info) we'll see + data T a a0 + whereas we'd prefer + data T a b + (NB: the tidying happens in the conversion to Iface syntax, + which happens as part of pretty-printing a TyThing.) + + Using fresh OccNames is not essential; it's cosmetic. + And also see Note [Avoid name clashes for associated data types]. + +For (a) perhaps surprisingly, duplicated uniques can happen, even if +we use fresh uniques for Anon arrows. Consider + data T :: forall k. k -> forall k. k -> * +where the two k's are identical even up to their uniques. Surprisingly, +this can happen: see #14515, #19092,3,4. Then if we use those k's in +as TyConBinders we'll get duplicated uniques. + +For (b) we'd like to avoid OccName clashes with the tyvars declared by +the user before the "::"; in the above example that is 'a'. + +It's reasonably easy to solve all this; just run down the list with a +substitution; hence the recursive 'go' function. But for the Uniques +it has to be done. + +Note [Avoid name clashes for associated data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider class C a b where + data D b :: * -> * +When typechecking the decl for D, we'll invent an extra type variable +for D, to fill out its kind. Ideally we don't want this type variable +to be 'a', because when pretty printing we'll get + class C a b where + data D b a0 +(NB: the tidying happens in the conversion to Iface syntax, which happens +as part of pretty-printing a TyThing.) + +That's why we look in the LocalRdrEnv to see what's in scope. This is +important only to get nice-looking output when doing ":info C" in GHCi. +It isn't essential for correctness. + + +************************************************************************ +* * + Partial signatures +* * +************************************************************************ + +-} + +tcHsPartialSigType + :: UserTypeCtxt + -> LHsSigWcType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , Maybe TcType -- Extra-constraints wildcard + , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with + -- the implicitly and explicitly bound type variables + , TcThetaType -- Theta part + , TcType ) -- Tau part +-- See Note [Checking partial type signatures] +tcHsPartialSigType ctxt sig_ty + | HsWC { hswc_ext = sig_wcs, hswc_body = sig_ty } <- sig_ty + , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty + , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty + = addSigCtxt ctxt (UserLHsSigType sig_ty) $ + do { mode <- mkHoleMode TypeLevel HM_Sig + ; (outer_bndrs, (wcs, wcx, theta, tau)) + <- solveEqualities "tcHsPartialSigType" $ + -- See Note [Failure in local type signatures] + bindNamedWildCardBinders sig_wcs $ \ wcs -> + bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $ + do { -- Instantiate the type-class context; but if there + -- is an extra-constraints wildcard, just discard it here + (theta, wcx) <- tcPartialContext mode hs_ctxt + + ; ek <- newOpenTypeKind + ; tau <- -- Don't do (addTypeCtxt hs_tau) here else we get + -- In the type + -- In the type signature: foo :: + tc_check_lhs_type mode hs_tau ek + + ; return (wcs, wcx, theta, tau) } + + ; traceTc "tcHsPartialSigType 2" empty + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs + ; traceTc "tcHsPartialSigType 3" empty + + -- No kind-generalization here: + ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ + tcMkPhiTy theta $ + tau) + + -- Spit out the wildcards (including the extra-constraints one) + -- as "hole" constraints, so that they'll be reported if necessary + -- See Note [Extra-constraint holes in partial type signatures] + ; mapM_ emitNamedTypeHole wcs + + -- The "tau" from tcHsPartialSigType might very well have some foralls + -- at the top, hidden behind a type synonym. Instantiate them! E.g. + -- type T x = forall b. x -> b -> b + -- f :: forall a. T (a,_) + -- We must instantiate the `forall b` just as we do the `forall a`! + -- Missing this led to #21667. + ; (tv_prs', theta', tau) <- tcInstTypeBndrs tau + + -- We return a proper (Name,InvisTVBinder) environment, to be sure that + -- we bring the right name into scope in the function body. + -- Test case: partial-sigs/should_compile/LocalDefinitionBug + ; let outer_bndr_names :: [Name] + outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs + tv_prs :: [(Name,InvisTVBinder)] + tv_prs = outer_bndr_names `zip` outer_tv_bndrs + + -- Zonk, so that any nested foralls can "see" their occurrences + -- See Note [Checking partial type signatures], and in particular + -- Note [Levels for wildcards] + ; (tv_prs, theta, tau) <- liftZonkM $ + do { tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs') + ; theta <- mapM zonkTcType (theta ++ theta') + ; tau <- zonkTcType tau + ; return (tv_prs, theta, tau) } + + -- NB: checkValidType on the final inferred type will be + -- done later by checkInferredPolyId. We can't do it + -- here because we don't have a complete type to check + + ; traceTc "tcHsPartialSigType" (ppr tv_prs) + ; return (wcs, wcx, tv_prs, theta, tau) } + +tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType) +tcPartialContext _ Nothing = return ([], Nothing) +tcPartialContext mode (Just (L _ hs_theta)) + | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta + , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { wc_tv_ty <- setSrcSpanA wc_loc $ + tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind + ; theta <- mapM (tc_lhs_pred mode) hs_theta1 + ; return (theta, Just wc_tv_ty) } + | otherwise + = do { theta <- mapM (tc_lhs_pred mode) hs_theta + ; return (theta, Nothing) } + +{- Note [Checking partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note is about tcHsPartialSigType. See also +Note [Recipe for checking a signature] + +When we have a partial signature like + f :: forall a. a -> _ +we do the following + +* tcHsPartialSigType does not make quantified type (forall a. blah) + and then instantiate it -- it makes no sense to instantiate a type + with wildcards in it. Rather, tcHsPartialSigType just returns the + 'a' and the 'blah' separately. + + Nor, for the same reason, do we push a level in tcHsPartialSigType. + +* We instantiate 'a' to a unification variable, a TyVarTv, and /not/ + a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv. Consider + f :: forall a. a -> _ + g :: forall b. _ -> b + f = g + g = f + They are typechecked as a recursive group, with monomorphic types, + so 'a' and 'b' will get unified together. Very like kind inference + for mutually recursive data types (sans CUSKs or SAKS); see + Note [Cloning for type variable binders] + +* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike + the companion CompleteSig) contains the original, as-yet-unchecked + source-code LHsSigWcType + +* Then, for f and g /separately/, we call tcInstSig, which in turn + call tcHsPartialSig (defined near this Note). It kind-checks the + LHsSigWcType, creating fresh unification variables for each "_" + wildcard. It's important that the wildcards for f and g are distinct + because they might get instantiated completely differently. E.g. + f,g :: forall a. a -> _ + f x = a + g x = True + It's really as if we'd written two distinct signatures. + +* Nested foralls. See Note [Levels for wildcards] + +* Just as for ordinary signatures, we must solve local equalities and + zonk the type after kind-checking it, to ensure that all the nested + forall binders can "see" their occurrences + + Just as for ordinary signatures, this zonk also gets any Refl casts + out of the way of instantiation. Example: #18008 had + foo :: (forall a. (Show a => blah) |> Refl) -> _ + and that Refl cast messed things up. See #18062. + +Note [Levels for wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b. (forall a. a -> _) -> b +We do /not/ allow the "_" to be instantiated to 'a'; although we do +(as before) allow it to be instantiated to the (top level) 'b'. +Why not? Suppose + f x = (x True, x 'c') + +During typecking the RHS we must instantiate that (forall a. a -> _), +so we must know /precisely/ where all the a's are; they must not be +hidden under (possibly-not-yet-filled-in) unification variables! + +We achieve this as follows: + +- For /named/ wildcards such sas + g :: forall b. (forall la. a -> _x) -> b + there is no problem: we create them at the outer level (ie the + ambient level of the signature itself), and push the level when we + go inside a forall. So now the unification variable for the "_x" + can't unify with skolem 'a'. + +- For /anonymous/ wildcards, such as 'f' above, we carry the ambient + level of the signature to the hole in the TcLevel part of the + mode_holes field of TcTyMode. Then, in tcAnonWildCardOcc we us that + level (and /not/ the level ambient at the occurrence of "_") to + create the unification variable for the wildcard. That is the sole + purpose of the TcLevel in the mode_holes field: to transport the + ambient level of the signature down to the anonymous wildcard + occurrences. + +Note [Extra-constraint holes in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (_) => a -> a + f x = ... + +* The renamer leaves '_' untouched. + +* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in + tcWildCardBinders. + +* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar + with the inferred constraints, e.g. (Eq a, Show a) + +* GHC.Tc.Errors.mkHoleError finally reports the error. + +An annoying difficulty happens if there are more than 64 inferred +constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple. +Where do we find the TyCon? For good reasons we only have constraint +tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types). So how +can we make a 70-tuple? This was the root cause of #14217. + +It's incredibly tiresome, because we only need this type to fill +in the hole, to communicate to the error reporting machinery. Nothing +more. So I use a HACK: + +* I make an /ordinary/ tuple of the constraints, in + GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because + ordinary tuples can't contain constraints, but it works fine. And for + ordinary tuples we don't have the same limit as for constraint + tuples (which need selectors and an associated class). + +* Because it is ill-kinded (unifying something of kind Constraint with + something of kind Type), it should trip an assert in writeMetaTyVarRef. + +Result works fine, but it may eventually bite us. + +See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for +information about how these are printed. + +************************************************************************ +* * + Pattern signatures (i.e signatures that occur in patterns) +* * +********************************************************************* -} + +tcHsPatSigType :: UserTypeCtxt + -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. + -> HsPatSigType GhcRn -- The type signature + -> ContextKind -- What kind is expected + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- (a) patterns e.g f (x::Int) = e +-- (b) RULE forall bndrs e.g. forall (x::Int). f x = x +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +-- +-- This may emit constraints +-- See Note [Recipe for checking a signature] +tcHsPatSigType ctxt hole_mode + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) + ctxt_kind + = tc_type_in_pat ctxt Nothing hole_mode hs_ty sig_wcs sig_ns ctxt_kind + +tcRuleBndrSig :: Name + -> SkolemInfo + -> HsPatSigType GhcRn -- The type signature + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +-- Used for type-checking type signatures in +-- RULE forall bndrs e.g. forall (x::Int). f x = x +-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type +-- +-- This may emit constraints +-- See Note [Recipe for checking a signature] +tcRuleBndrSig name skol_info + (HsPS { hsps_ext = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns } + , hsps_body = hs_ty }) + = tc_type_in_pat (RuleBndrTypeCtxt name) (Just skol_info) + HM_Sig hs_ty sig_wcs sig_ns OpenKind + +-- Typecheck type patterns, in data constructor patterns, e.g +-- f (MkT @a @(Maybe b) ...) = ... +-- +-- We have two completely separate typing rules, +-- one for binder type patterns (handled by `tc_bndr_in_pat`) +-- one for unifier type patterns (handled by `tc_type_in_pat`) +-- The two cases are distinguished by `tyPatToBndr`. +-- See Note [Type patterns: binders and unifiers] +tcHsTyPat :: HsTyPat GhcRn -- The type pattern + -> Kind -- What kind is expected + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +tcHsTyPat hs_pat@(HsTP{hstp_ext = hstp_rn, hstp_body = hs_ty}) expected_kind + = case tyPatToBndr hs_pat of + Nothing -> tc_unif_in_pat hs_ty wcs all_ns (TheKind expected_kind) + Just bndr -> tc_bndr_in_pat bndr wcs imp_ns expected_kind + where + all_ns = imp_ns ++ exp_ns + HsTPRn{hstp_nwcs = wcs, hstp_imp_tvs = imp_ns, hstp_exp_tvs = exp_ns} = hstp_rn + tc_unif_in_pat = tc_type_in_pat TypeAppCtxt Nothing HM_TyAppPat + +-- `tc_bndr_in_pat` is used in type patterns to handle the binders case. +-- See Note [Type patterns: binders and unifiers] +tc_bndr_in_pat :: HsTyVarBndr flag GhcRn + -> [Name] -- All named wildcards in type + -> [Name] -- Implicit (but not explicit) binders in type + -> Kind -- Expected kind + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- 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) + 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" $ + -- See Note [Failure in local type signatures] + -- and c.f #16033 + bindNamedWildCardBinders wcs $ \ wcs -> + tcExtendNameTyVarEnv tkv_prs $ + do { tcHsTvbKind bvar ki expected_kind + ; pure wcs } + + mapM_ emitNamedTypeHole wcs + + 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] + + let tvb_prs = mk_tvb_pairs bndr tv + pure (wcs, tvb_prs ++ tkv_prs, mkTyVarTy tv) + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; tv <- newPatTyVar name kind + -- NB: tv's Name is fresh + ; return (name, tv) } + +-- * In type patterns `tc_type_in_pat` is used to handle the unifiers case. +-- See Note [Type patterns: binders and unifiers] +-- +-- * In patterns `tc_type_in_pat` is used to check pattern signatures. +tc_type_in_pat :: UserTypeCtxt + -> Maybe SkolemInfo -- Just sk for RULE and SPECIALISE pragmas only + -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications. + -> LHsType GhcRn -- The type in pattern + -> [Name] -- All named wildcards in type + -> [Name] -- All binders in type + -> ContextKind -- What kind is expected + -> TcM ( [(Name, TcTyVar)] -- Wildcards + , [(Name, TcTyVar)] -- The new bit of type environment, binding + -- the scoped type variables + , TcType) -- The type +tc_type_in_pat ctxt mb_skol hole_mode hs_ty wcs ns ctxt_kind + = addSigCtxt ctxt (UserLHsType hs_ty) $ + do { tkvs <- mapM new_implicit_tv ns + ; let tkv_prs = ns `zip` tkvs + ; mode <- mkHoleMode TypeLevel hole_mode + ; (wcs, ty) + <- addTypeCtxt hs_ty $ + solveEqualities "tc_type_in_pat" $ + -- See Note [Failure in local type signatures] + -- and c.f #16033 + bindNamedWildCardBinders wcs $ \ wcs -> + tcExtendNameTyVarEnv tkv_prs $ + do { ek <- newExpectedKind ctxt_kind + ; ty <- tc_check_lhs_type mode hs_ty ek + ; return (wcs, ty) } + + ; mapM_ emitNamedTypeHole wcs + + -- ty might have tyvars that are at a higher TcLevel (if hs_ty + -- contains a forall). Promote these. + -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ... + -- When we instantiate x, we have to compare the kind of the argument + -- to a's kind, which will be a metavariable. + -- kindGeneralizeNone does this: + ; kindGeneralizeNone ty + ; ty <- liftZonkM $ zonkTcType ty + ; checkValidType ctxt ty + + ; traceTc "tc_type_in_pat" (ppr tkv_prs) + ; return (wcs, tkv_prs, ty) } + where + new_implicit_tv name + = do { kind <- newMetaKindVar + ; case mb_skol of + Just skol_info -> newSkolemTyVar skol_info name kind + Nothing -> newPatTyVar name kind } + -- See Note [Typechecking pattern signature binders] + -- NB: tv's Name may be fresh (in the case of newPatTyVar) + +-- See Note [Type patterns: binders and unifiers] +tyPatToBndr :: HsTyPat GhcRn -> Maybe (HsTyVarBndr () GhcRn) +tyPatToBndr HsTP{hstp_body = (L _ hs_ty)} = go hs_ty where + go :: HsType GhcRn -> Maybe (HsTyVarBndr () GhcRn) + go (HsParTy _ (L _ ty)) = go ty + 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 _ _ tv) + | isTyVarName (getName tv) + = Just (HsBndrVar noExtField (fmap getName tv)) + go_bvar (HsWildCardTy _) + = Just (HsBndrWildCard noExtField) + go_bvar _ = Nothing + +{- Note [Type patterns: binders and unifiers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type pattern, of type `HsTyPat`, represents a type argument in a data +constructor pattern. For example + f (MkT @a @(Maybe b) p q) = ... +Here the `@a` and `@(Maybe b)` are type patterns. In general, then a +`HsTyPat` is represented by a `HsType`. + +However, for /typechecking/ purposes (only) we distinguish two categories of +type pattern: +* Binder type patterns +* Unifier type patterns + +Binder type patterns are a subset of type patterns described by the following grammar: + + bvar ::= tv | '_' -- type variable or wildcard + tp_bndr ::= + 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. + +Unifier type patterns include all other forms of type patterns, such as `Maybe x`. +This distinction allows the typechecker to accept more programs. +Consider this example from #18986: + + data T where + MkT :: forall (f :: forall k. k -> Type). + f Int -> f Maybe -> T + + k :: T -> () + k (MkT @f (x :: f Int) (y :: f Maybe)) = () + +In general case (if we treat `f` as a unifier) we would create a metavariable for its kind: + f :: kappa +Checking `x :: f Int` would unify + kappa := Type -> Type +and then checking `y :: f Maybe` would unify + kappa := (Type -> Type) -> Type +leading to a type error: + • Expecting one more argument to ‘Maybe’ + Expected a type, but ‘Maybe’ has kind ‘* -> *’ + +However, `@f` is a simple type variable binder, we don't need a metavariable for its kind, we +can add it directly to the context with its polymorphic kind: + f :: forall k . k -> Type +This way both `f Int` and `f Maybe` can be accepted because `k` can be instantiated differently at +each call site. + +Note [Typechecking pattern signature binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Type variables in the type environment] in GHC.Tc.Utils. +Consider + + data T where + MkT :: forall a. a -> (a -> Int) -> T + + f :: T -> ... + f (MkT x (f :: b -> c)) = + +Here + * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk', + It must be a skolem so that it retains its identity, and + GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. + + * The type signature pattern (f :: b -> c) makes fresh meta-tyvars + beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the + environment + + * Then unification makes beta := a_sk, gamma := Int + That's why we must make beta and gamma a MetaTv, + not a SkolemTv, so that it can unify to a_sk (or Int, respectively). + + * Finally, in '' we have the envt "b" :-> beta, "c" :-> gamma, + so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType, + +Another example (#13881): + fl :: forall (l :: [a]). Sing l -> Sing l + fl (SNil :: Sing (l :: [y])) = SNil +When we reach the pattern signature, 'l' is in scope from the +outer 'forall': + "a" :-> a_sk :: * + "l" :-> l_sk :: [a_sk] +We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check +the pattern signature + Sing (l :: [y]) +That unifies y_sig := a_sk. We return from tcHsPatSigType with +the pair ("y" :-> y_sig). + +For RULE binders, though, things are a bit different (yuk). + RULE "foo" forall (x::a) (y::[a]). f x y = ... +Here this really is the binding site of the type variable so we'd like +to use a skolem, so that we get a complaint if we unify two of them +together. Hence the new_implicit_tv function in tcHsPatSigType. + + +************************************************************************ +* * + Checking kinds +* * +************************************************************************ + +-} + +unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) +unifyKinds rn_tys act_kinds + = do { kind <- newMetaKindVar + ; let check rn_ty (ty, act_kind) + = checkExpectedKind (unLoc rn_ty) ty act_kind kind + ; tys' <- zipWithM check rn_tys act_kinds + ; return (tys', kind) } + +{- +************************************************************************ +* * + Sort checking kinds +* * +************************************************************************ + +tcLHsKindSig converts a user-written kind to an internal, sort-checked kind. +It does sort checking and desugaring at the same time, in one single pass. +-} + +tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tcLHsKindSig ctxt hs_kind + = tc_lhs_kind_sig kindLevelMode ctxt hs_kind + +tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind +tc_lhs_kind_sig mode ctxt hs_kind +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +-- Result is zonked + = do { kind <- addErrCtxt (KindCtxt hs_kind) $ + solveEqualities "tcLHsKindSig" $ + tc_check_lhs_type mode hs_kind liftedTypeKind + ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) + -- No generalization: + ; kindGeneralizeNone kind + ; kind <- liftZonkM $ zonkTcType kind + -- This zonk is very important in the case of higher rank kinds + -- E.g. #13879 f :: forall (p :: forall z (y::z). ). + -- + -- When instantiating p's kind at occurrences of p in + -- it's crucial that the kind we instantiate is fully zonked, + -- else we may fail to substitute properly + + ; checkValidType ctxt kind + ; traceTc "tcLHsKindSig2" (ppr kind) + ; return kind } + +promotionErr :: Name -> PromotionErr -> TcM a +promotionErr name err + = failWithTc $ TcRnUnpromotableThing name err + +{- +************************************************************************ +* * + Utils for constructing TyLit +* * +************************************************************************ +-} + + +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 + +tyLitFromOverloadedLit :: OverLitVal -> Maybe (HsTyLit GhcRn) +tyLitFromOverloadedLit (HsIntegral n) = Just $ HsNumTy NoSourceText (il_value n) +tyLitFromOverloadedLit (HsIsString _ s) = Just $ HsStrTy NoSourceText s +tyLitFromOverloadedLit HsFractional{} = Nothing diff --git a/GHC/Tc/Gen/Match.hs b/GHC/Tc/Gen/Match.hs --- a/GHC/Tc/Gen/Match.hs +++ b/GHC/Tc/Gen/Match.hs @@ -1,11 +1,14 @@ - {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- @@ -16,12 +19,11 @@ -- | Typecheck some @Matches@ module GHC.Tc.Gen.Match - ( tcMatchesFun - , tcGRHS + ( tcFunBindMatches + , tcCaseMatches + , tcLambdaMatches + , tcGRHSNE , tcGRHSsPat - , tcMatchesCase - , tcMatchLambda - , TcMatchCtxt(..) , TcStmtChecker , TcExprStmtChecker , TcCmdStmtChecker @@ -38,15 +40,16 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC - , tcMonoExpr, tcMonoExprNC, tcExpr + , tcMonoExprNC, tcExpr , tcCheckMonoExpr, tcCheckMonoExprNC - , tcCheckPolyExpr ) + , tcCheckPolyExpr, tcPolyLExpr ) -import GHC.Rename.Utils ( bindLocalNames, isIrrefutableHsPatRn ) +import GHC.Rename.Utils ( bindLocalNames ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat +import GHC.Tc.Gen.Do import GHC.Tc.Gen.Head( tcCheckId ) import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -55,11 +58,12 @@ 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 import GHC.Core.TyCon --- Create chunkified tuple tybes for monad comprehensions +-- Create chunkified tuple types for monad comprehensions import GHC.Core.Make import GHC.Hs @@ -70,118 +74,130 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Driver.DynFlags ( getDynFlags ) -import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Id import GHC.Types.SrcLoc +import GHC.Types.Basic( VisArity, isDoExpansionGenerated ) +import qualified GHC.Data.List.NonEmpty as NE + import Control.Monad import Control.Arrow ( second ) -import qualified Data.List.NonEmpty as NE +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (mapMaybe) +import qualified GHC.LanguageExtensions as LangExt + + {- ************************************************************************ * * -\subsection{tcMatchesFun, tcMatchesCase} +\subsection{tcFunBindMatches, tcCaseMatches} * * ************************************************************************ -@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a -@FunMonoBind@. The second argument is the name of the function, which +`tcFunBindMatches` typechecks a `[Match]` list which occurs in a +`FunBind`. The second argument is the name of the function, which is used in error messages. It checks that all the equations have the -same number of arguments before using @tcMatches@ to do the work. +same number of arguments before using `tcMatches` to do the work. -} -tcMatchesFun :: LocatedN Name -- MatchContext Id - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType -- Expected type of function - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) - -- Returns type of body -tcMatchesFun fun_name matches exp_ty - = do { -- Check that they all have the same no of arguments - -- Location is in the monad, set the caller so that - -- any inter-equation error messages get some vaguely - -- sensible location. Note: we have to do this odd - -- ann-grabbing, because we don't always have annotations in - -- hand when we call tcMatchesFun... - traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty) - ; checkArgCounts what matches +tcFunBindMatches :: UserTypeCtxt + -> Name -- Function name + -> Mult -- The multiplicity of the binder + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] -- Scoped skolemised binders + -> ExpRhoType -- Expected type of function; caller + -- has skolemised any outer forall's + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +-- See Note [Skolemisation overview] in GHC.Tc.Utils.Unify +tcFunBindMatches ctxt fun_name mult matches invis_pat_tys exp_ty + = assertPpr (funBindPrecondition matches) (pprMatches matches) $ + do { -- Check that they all have the same no of arguments + arity <- checkArgCounts matches - ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> - -- NB: exp_type may be polymorphic, but - -- matchExpectedFunTys can cope with that - tcScalingUsage ManyTy $ - -- toplevel bindings and let bindings are, at the - -- moment, always unrestricted. The value being bound - -- must, accordingly, be unrestricted. Hence them - -- being scaled by Many. When let binders come with a - -- multiplicity, then @tcMatchesFun@ will have to take - -- a multiplicity argument, and scale accordingly. - tcMatches match_ctxt pat_tys rhs_ty matches } + ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity) + + ; (wrap_fun, r) + <- matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> + tcScalingUsage mult $ + -- Makes sure that if the binding is unrestricted, it counts as + -- consuming its rhs Many times. + + do { traceTc "tcFunBindMatches 2" $ + vcat [ text "ctxt:" <+> pprUserTypeCtxt ctxt + , text "arity:" <+> ppr arity + , text "invis_pat_tys:" <+> ppr invis_pat_tys + , text "pat_tys:" <+> ppr pat_tys + , text "rhs_ty:" <+> ppr rhs_ty ] + ; tcMatches mctxt tcBody (invis_pat_tys ++ pat_tys) rhs_ty matches } + + ; return (wrap_fun, r) } where - arity = matchGroupArity matches - herald = ExpectedFunTyMatches (NameThing (unLoc fun_name)) matches - ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True - -- But that's wrong for f :: Int -> forall a. blah - what = FunRhs { mc_fun = fun_name, mc_fixity = Prefix, mc_strictness = strictness } - match_ctxt = MC { mc_what = what, mc_body = tcBody } - strictness - | [L _ match] <- unLoc $ mg_alts matches - , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match - = SrcStrict - | otherwise - = NoSrcStrict + mctxt = mkPrefixFunRhs (noLocA fun_name) noAnn + herald = ExpectedFunTyMatches (NameThing fun_name) matches +funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool +funBindPrecondition (MG { mg_alts = L _ alts }) + = not (null alts) && all is_fun_rhs alts + where + is_fun_rhs (L _ (Match { m_ctxt = FunRhs {} })) = True + is_fun_rhs _ = False + +tcLambdaMatches :: HsExpr GhcRn -> HsLamVariant + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] -- Already skolemised + -> ExpSigmaType -- NB can be a sigma-type + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcLambdaMatches e lam_variant matches invis_pat_tys res_ty + = do { arity <- checkArgCounts matches + -- Check argument counts since this is also used for \cases + + ; (wrapper, r) + <- matchExpectedFunTys herald GenSigCtxt arity res_ty $ \ pat_tys rhs_ty -> + tcMatches ctxt tc_body (invis_pat_tys ++ pat_tys) rhs_ty matches + + ; return (wrapper, r) } + where + ctxt = LamAlt lam_variant + herald = ExpectedFunTyLam lam_variant e + -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify + + tc_body | isDoExpansionGenerated (mg_ext matches) + -- See Part 3. B. of Note [Expanding HsDo with XXExprGhcRn] in + -- `GHC.Tc.Gen.Do`. Testcase: Typeable1 + = tcBodyNC -- NB: Do not add any error contexts + -- It has already been done + | otherwise + = tcBody + {- -@tcMatchesCase@ doesn't do the argument-count check because the +@tcCaseMatches@ doesn't do the argument-count check because the parser guarantees that each equation has exactly one argument. -} -tcMatchesCase :: (AnnoBody body) => - TcMatchCtxt body -- ^ Case context - -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee - -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives - -> ExpRhoType -- ^ Type of the whole case expression - -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) +tcCaseMatches :: (AnnoBody body, Outputable (body GhcTc)) + => HsMatchContextRn + -> 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 + -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -- Translated alternatives -- wrapper goes from MatchGroup's ty to expected ty -tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty - = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches - -tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify - -> TcMatchCtxt HsExpr - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpRhoType - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) -tcMatchLambda herald match_ctxt match res_ty - = do { checkArgCounts (mc_what match_ctxt) match - ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do - -- checking argument counts since this is also used for \cases - tcMatches match_ctxt pat_tys rhs_ty match } - where - n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case - | otherwise = matchGroupArity match +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 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. - -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType +tcGRHSsPat :: Mult -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings -tcGRHSsPat grhss res_ty - = tcScalingUsage ManyTy $ - -- Like in tcMatchesFun, this scaling happens because all - -- let bindings are unrestricted. A difference, here, is - -- that when this is not the case, any more, we will have to - -- make sure that the pattern is strict, otherwise this will - -- desugar to incorrect code. - tcGRHSs match_ctxt grhss res_ty - where - match_ctxt :: TcMatchCtxt HsExpr -- AZ - match_ctxt = MC { mc_what = PatBindRhs, - mc_body = tcBody } +tcGRHSsPat mult grhss res_ty + = tcScalingUsage mult $ tcGRHSs PatBindRhs tcBody grhss res_ty {- ********************************************************************* * * @@ -189,111 +205,177 @@ * * ********************************************************************* -} -data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: HsMatchContext GhcTc, -- What kind of thing this is - mc_body :: LocatedA (body GhcRn) -- Type checker for a body of - -- an alternative - -> ExpRhoType - -> TcM (LocatedA (body GhcTc)) } +-- | Type checker for a body of a match alternative +type TcMatchAltChecker body -- c.f. TcStmtChecker, also in this module + = LocatedA (body GhcRn) + -> ExpRhoType + -> TcM (LocatedA (body GhcTc)) type AnnoBody body = ( 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 (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns - , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns + , 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 , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA ) -- | Type-check a MatchGroup. -tcMatches :: (AnnoBody body ) => TcMatchCtxt body - -> [Scaled ExpSigmaTypeFRR] -- ^ Expected pattern types. +tcMatches :: (AnnoBody body, Outputable (body GhcTc)) + => HsMatchContextRn + -> TcMatchAltChecker body + -> [ExpPatType] -- ^ Expected pattern types. -> ExpRhoType -- ^ Expected result-type of the Match. -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_ext = origin }) +tcMatches ctxt 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 - ; pat_tys <- mapM scaledExpTypeToType pat_tys - ; rhs_ty <- expTypeToType rhs_ty + -- 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" + ; rhs_ty <- expTypeToType rhs_ty ; return (MG { mg_alts = L l [] - , mg_ext = MatchGroupTc pat_tys rhs_ty origin + , mg_ext = MatchGroupTc [pat_ty] rhs_ty origin }) } | otherwise - = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches - ; let (usages,matches') = unzip umatches + = do { umatches <- mapM (tcCollectingUsage . tcMatch tc_body pat_tys rhs_ty) matches + ; let (usages, matches') = unzip umatches ; tcEmitBindingUsage $ supUEs usages - ; pat_tys <- mapM readScaledExpType pat_tys + ; pat_tys <- mapM readScaledExpType (filter_out_forall_pat_tys pat_tys) ; rhs_ty <- readExpType rhs_ty + ; traceTc "tcMatches" (ppr matches' $$ ppr pat_tys $$ ppr rhs_ty) ; return (MG { mg_alts = L l matches' , mg_ext = MatchGroupTc pat_tys rhs_ty origin }) } + where + -- We filter out foralls because we have no use for them in HsToCore. + filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpSigmaTypeFRR] + filter_out_forall_pat_tys = mapMaybe match_fun_pat_ty + where + 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) => TcMatchCtxt body - -> [Scaled ExpSigmaType] -- Expected pattern types +tcMatch :: (AnnoBody body) + => TcMatchAltChecker body + -> [ExpPatType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. -> LMatch GhcRn (LocatedA (body GhcRn)) -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) -tcMatch ctxt pat_tys rhs_ty match - = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match +tcMatch tc_body pat_tys rhs_ty match + = do { (L loc r) <- wrapLocMA (tc_match pat_tys rhs_ty) match + ; return (L loc r) } where - tc_match ctxt pat_tys rhs_ty - match@(Match { m_pats = pats, m_grhss = grhss }) - = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ - tcGRHSs ctxt grhss rhs_ty - ; return (Match { m_ext = noAnn - , m_ctxt = mc_what ctxt, m_pats = pats' - , m_grhss = grhss' }) } + tc_match pat_tys rhs_ty + match@(Match { m_ctxt = ctxt, m_pats = L l pats, m_grhss = grhss }) + = add_match_ctxt $ + do { (pats', (grhss')) <- tcMatchPats ctxt pats pat_tys $ + tcGRHSs ctxt tc_body grhss rhs_ty + -- NB: pats' are just the /value/ patterns + -- See Note [tcMatchPats] in GHC.Tc.Gen.Pat + ; return (Match { m_ext = noExtField + , m_ctxt = ctxt + , m_pats = L l pats' + , m_grhss = grhss' }) } + where -- For (\x -> e), tcExpr has already said "In the expression \x->e" - -- so we don't want to add "In the lambda abstraction \x->e" - add_match_ctxt match thing_inside - = case mc_what ctxt of - LambdaExpr -> thing_inside - _ -> addErrCtxt (pprMatchInCtxt match) thing_inside + -- so we don't want to add "In the lambda abstraction \x->e" + -- But for \cases with many alternatives, it is helpful to say + -- which particular alternative we are looking at + add_match_ctxt thing_inside = case ctxt of + LamAlt LamSingle -> thing_inside + StmtCtxt (HsDoStmt{}) -> thing_inside -- this is an expanded do stmt + _ -> addErrCtxt (MatchInCtxt match) thing_inside ------------- tcGRHSs :: AnnoBody body - => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType + => HsMatchContextRn + -> TcMatchAltChecker body + -> GRHSs GhcRn (LocatedA (body GhcRn)) + -> ExpRhoType -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) - -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like -- f = \(x::forall a.a->a) -> -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more - -tcGRHSs ctxt (GRHSs _ grhss binds) res_ty - = do { (binds', ugrhss) - <- tcLocalBinds binds $ - mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss - ; let (usages, grhss') = unzip ugrhss - ; tcEmitBindingUsage $ supUEs usages +tcGRHSs ctxt tc_body (GRHSs _ grhss binds) res_ty + = do { (binds', grhss') <- tcLocalBinds binds $ do + tcGRHSNE ctxt tc_body grhss res_ty ; return (GRHSs emptyComments grhss' binds') } -------------- -tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn)) - -> TcM (GRHS GhcTc (LocatedA (body GhcTc))) +tcGRHSNE :: forall body. AnnoBody body + => HsMatchContextRn -> TcMatchAltChecker body + -> NonEmpty (LGRHS GhcRn (LocatedA (body GhcRn))) -> ExpRhoType + -> TcM (NonEmpty (LGRHS GhcTc (LocatedA (body GhcTc)))) +tcGRHSNE ctxt tc_body grhss res_ty + = do { (usages, grhss') <- unzip <$> traverse (wrapLocSndMA tc_alt) grhss + ; tcEmitBindingUsage $ supUEs usages + ; return grhss' } + where + stmt_ctxt = PatGuard ctxt -tcGRHS ctxt res_ty (GRHS _ guards rhs) - = do { (guards', rhs') - <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ - mc_body ctxt rhs - ; return (GRHS noAnn guards' rhs') } - where - stmt_ctxt = PatGuard (mc_what ctxt) + tc_alt :: GRHS GhcRn (LocatedA (body GhcRn)) + -> TcM (UsageEnv, GRHS GhcTc (LocatedA (body GhcTc))) + tc_alt (GRHS _ guards rhs) + = tcCollectingUsage $ + do { (guards', rhs') + <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ + tc_body rhs + ; return (GRHS noAnn guards' rhs') } {- ************************************************************************ @@ -304,7 +386,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 @@ -315,15 +397,22 @@ (mkCheckExpType elt_ty) ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) } -tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty - = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty doExpr (L l stmts')) } +tcDoStmts doExpr@(DoExpr _) ss@(L l stmts) res_ty + = do { isApplicativeDo <- xoptM LangExt.ApplicativeDo + ; if isApplicativeDo + then do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty + ; res_ty <- readExpType res_ty + ; 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 } + } -tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty - = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty - ; res_ty <- readExpType res_ty - ; return (HsDo res_ty mDoExpr (L l stmts')) } +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 } tcDoStmts MonadComp (L l stmts) res_ty = do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty @@ -334,9 +423,15 @@ tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) tcBody body res_ty = do { traceTc "tcBody" (ppr res_ty) - ; tcMonoExpr body res_ty + ; tcPolyLExpr body res_ty } +tcBodyNC :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc) +tcBodyNC body res_ty + = do { traceTc "tcBodyNC" (ppr res_ty) + ; tcMonoExprNC body res_ty + } + {- ************************************************************************ * * @@ -349,13 +444,13 @@ type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType type TcStmtChecker body rho_type - = forall thing. HsStmtContext GhcTc + = forall thing. HsStmtContextRn -> Stmt GhcRn (LocatedA (body GhcRn)) -> rho_type -- Result type for comprehension -> (rho_type -> TcM thing) -- Checker for what follows the stmt -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (AnnoBody body) => HsStmtContext GhcTc +tcStmts :: (AnnoBody body) => HsStmtContextRn -> TcStmtChecker body rho_type -- NB: higher-rank type -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type @@ -365,7 +460,7 @@ const (return ()) ; return stmts' } -tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc +tcStmtsAndThen :: (AnnoBody body) => HsStmtContextRn -> TcStmtChecker body rho_type -- NB: higher-rank type -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type @@ -390,7 +485,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' $ @@ -401,7 +496,7 @@ | otherwise = do { (stmt', (stmts', thing)) <- setSrcSpanA loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ + addErrCtxt (StmtErrCtxt ctxt stmt) $ stmt_chk ctxt stmt res_ty $ \ res_ty' -> popErrCtxt $ tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ @@ -452,6 +547,32 @@ -- coercion matching stuff in them. It's hard to avoid the -- potential for non-trivial coercions in tcMcStmt +{- +Note [Binding in list comprehension isn't linear] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, [ y | () <- xs, y <- [0,1]] could be linear in `xs`. +But, the way the desugaring works, we get something like + +case xs of + () : xs ' -> letrec next_stmt = … xs' … + +In the current typing rules for letrec in Core, next_stmt is necessarily of +multiplicity Many and so is every free variable, including xs'. Which, in turns, +requires xs to be of multiplicity Many. + +Rodrigo Mesquita worked out, in his master thesis, how to make letrecs having +non-Many multiplicities. But it's a fair bit of work to implement. + +Since nobody actually cares about [ y | () <- xs, y <- [0,1]] being linear, then +we just conservatively make it unrestricted instead. + +If we're to change that, we have to be careful that [ y | _ <- xs, y <- [0,1]] +isn't linear in `xs` since the elements of `xs` are ignored. So we'd still have +to call `tcScalingUsage` on `xs` in `tcLcStmt`, we'd just have to create a fresh +multiplicity variable. We'd also use the same multiplicity variable in the call +to `tcCheckPat` instead of `unrestricted`. +-} + tcLcStmt :: TyCon -- The list type constructor ([]) -> TcExprStmtChecker @@ -463,46 +584,53 @@ -- A generator, pat <- rhs tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) + -- About the next `tcScalingUsage ManyTy` and unrestricted + -- see Note [Binding in list comprehension isn't linear] + ; rhs' <- tcScalingUsage ManyTy $ tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty]) ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ + tcScalingUsage ManyTy $ thing_inside elt_ty ; return (mkTcBindStmt pat' rhs', thing) } -- A boolean guard tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside = do { rhs' <- tcCheckMonoExpr rhs boolTy - ; thing <- thing_inside elt_ty + ; thing <- tcScalingUsage ManyTy $ thing_inside elt_ty ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) } -- ParStmt: See notes with tcMcStmt and Note [Scoping in parallel list comprehensions] tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside - = do { env <- getLocalRdrEnv + = tcScalingUsage ManyTy $ -- parallel list comprehension never desugars to something linear. + do { env <- getLocalRdrEnv ; (pairs', thing) <- loop env [] bndr_stmts_s ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) } where - -- loop :: LocalRdrEnv -- The original LocalRdrEnv - -- -> [Name] -- Variables bound by earlier branches - -- -> [([LStmt GhcRn], [GhcRn])] - -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing) - -- + loop + :: LocalRdrEnv -> [Name] -> NonEmpty (ParStmtBlock GhcRn GhcRn) + -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _) -- Invariant: on entry to `loop`, the LocalRdrEnv is set to -- origEnv, the LocalRdrEnv for the entire comprehension - loop _ allBinds [] = do { thing <- bindLocalNames allBinds $ thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop origEnv priorBinds (ParStmtBlock x stmts names _ : pairs) + loop origEnv priorBinds (ParStmtBlock x stmts names _ :| pairs) = do { (stmts', (ids, pairs', thing)) <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> do { ids <- tcLookupLocalIds names ; (pairs', thing) <- setLocalRdrEnv origEnv $ - loop origEnv (names ++ priorBinds) pairs + loop1 origEnv (names ++ priorBinds) pairs ; return (ids, pairs', thing) } - ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) } + ; return ( ParStmtBlock x stmts' ids noSyntaxExpr :| pairs', thing ) } + loop1 + :: LocalRdrEnv -> [Name] -> [ParStmtBlock GhcRn GhcRn] + -> TcM ([ParStmtBlock GhcTc GhcTc], _) + -- matching in the branches + loop1 _ binds [] = [ ([], a) | a <- bindLocalNames binds (thing_inside elt_ty) ] + loop1 env binds (x:xs) = [ (toList ys, a) | (ys, a) <- loop env binds (x:|xs) ] + tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts , trS_bndrs = bindersMap , trS_by = by, trS_using = using }) elt_ty thing_inside - = do { let (bndr_names, n_bndr_names) = unzip bindersMap + = tcScalingUsage ManyTy $ -- Transform statements are too complex: just make everything multiplicity Many + do { let (bndr_names, n_bndr_names) = unzip bindersMap unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) -- The inner 'stmts' lack a LastStmt, so the element type -- passed in to tcStmtsAndThen is never looked at @@ -740,7 +868,7 @@ -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` -- See Note [TransStmt binder map] in GHC.Hs.Expr - n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids + n_bndr_ids = zipWithEqual mk_n_bndr n_bndr_names bndr_ids bindersMap' = bndr_ids `zip` n_bndr_ids -- Type check the thing in the environment with @@ -795,20 +923,19 @@ ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty -- type dummies since we don't know all binder types yet - ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind)) - [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ] + ; tup_tys_and_bndr_stmts_s <- traverse (\ bndr_stmts@(ParStmtBlock _ _ names _) -> + [ (tup_tys, bndr_stmts) + | tup_tys <- mkBigCoreTupTy <$> traverse (const (newFlexiTyVarTy liftedTypeKind)) names ]) bndr_stmts_s -- Typecheck bind: - ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ] - tuple_ty = mk_tuple_ty tup_tys + ; let tuple_ty = mk_tuple_ty (NE.map fst tup_tys_and_bndr_stmts_s) ; (((blocks', thing), inner_res_ty), bind_op') <- tcSyntaxOp MCompOrigin bind_op [ synKnownType (m_ty `mkAppTy` tuple_ty) , SynFun (synKnownType tuple_ty) SynRho ] res_ty $ \ [inner_res_ty] _ -> - do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) - tup_tys bndr_stmts_s + do { stuff <- loop m_ty (mkCheckExpType inner_res_ty) tup_tys_and_bndr_stmts_s ; return (stuff, inner_res_ty) } ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) } @@ -816,17 +943,10 @@ where mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys - -- loop :: Type -- m_ty - -- -> ExpRhoType -- inner_res_ty - -- -> [TcType] -- tup_tys - -- -> [ParStmtBlock Name] - -- -> TcM ([([LStmt GhcTc], [TcId])], thing) - loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty - ; return ([], thing) } - -- matching in the branches - - loop m_ty inner_res_ty (tup_ty_in : tup_tys_in) - (ParStmtBlock x stmts names return_op : pairs) + loop + :: Type -> ExpRhoType -> NonEmpty (Type, ParStmtBlock GhcRn GhcRn) + -> TcM (NonEmpty (ParStmtBlock GhcTc GhcTc), _) + loop m_ty inner_res_ty ((tup_ty_in, ParStmtBlock x stmts names return_op) :| xs) = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in ; (stmts', (ids, return_op', pairs', thing)) <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $ @@ -837,11 +957,17 @@ tcSyntaxOp MCompOrigin return_op [synKnownType tup_ty] m_tup_ty' $ \ _ _ -> return () - ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs + ; (pairs', thing) <- loop1 m_ty inner_res_ty xs ; return (ids, return_op', pairs', thing) } - ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) } - loop _ _ _ _ = panic "tcMcStmt.loop" + ; return (ParStmtBlock x stmts' ids return_op' :| pairs', thing) } + loop1 + :: Type -> ExpRhoType -> [(Type, ParStmtBlock GhcRn GhcRn)] + -> TcM ([ParStmtBlock GhcTc GhcTc], _) + -- matching in the branches + loop1 _ r [] = [ ([], a) | a <- thing_inside r ] + loop1 m r (x:xs) = [ (toList ys, a) | (ys, a) <- loop m r (x:|xs) ] + tcMcStmt _ stmt _ _ = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) @@ -857,7 +983,6 @@ = do { body' <- tcMonoExprNC body res_ty ; thing <- thing_inside (panic "tcDoStmt: thing_inside") ; return (LastStmt x body' noret noSyntaxExpr, thing) } - tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside = do { -- Deal with rebindable syntax: -- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty @@ -885,18 +1010,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 @@ -909,7 +1022,6 @@ ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } - tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) @@ -922,7 +1034,7 @@ ; tcExtendIdEnv tup_ids $ do { ((stmts', (ret_op', tup_rets)), stmts_ty) - <- tcInfer $ \ exp_ty -> + <- runInferRho $ \ exp_ty -> tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty -> do { tup_rets <- zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys) @@ -934,7 +1046,7 @@ ; return (ret_op', tup_rets) } ; ((_, mfix_op'), mfix_res_ty) - <- tcInfer $ \ exp_ty -> + <- runInferRho $ \ exp_ty -> tcSyntaxOp DoOrigin mfix_op [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $ \ _ _ -> return () @@ -962,6 +1074,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) @@ -987,8 +1111,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 isIrrefutableHsPatRn 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 ()) @@ -1038,7 +1163,7 @@ -} tcApplicativeStmts - :: HsStmtContext GhcTc + :: HsStmtContextRn -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside @@ -1047,7 +1172,7 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside = do { body_ty <- newFlexiTyVarTy liftedTypeKind ; let arity = length pairs - ; ts <- replicateM (arity-1) $ newInferExpType + ; ts <- replicateM (arity-1) $ newInferExpType IIF_DeepRho ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind ; let fun_ty = mkVisFunTysMany pat_tys body_ty @@ -1090,7 +1215,7 @@ , .. }, pat_ty, exp_ty) = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $ - addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $ + addErrCtxt (StmtErrCtxt ctxt (mkRnBindStmt pat rhs)) $ do { rhs' <- tcCheckMonoExprNC rhs exp_ty ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $ return () @@ -1154,21 +1279,33 @@ -} -- | @checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same --- number of 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 = ... +-- The MatchGroup for `f` has arity 2, not 3 checkArgCounts :: AnnoBody body - => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) - -> TcM () -checkArgCounts _ (MG { mg_alts = L _ [] }) - = return () -checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) }) + => MatchGroup GhcRn (LocatedA (body GhcRn)) + -> TcM VisArity +checkArgCounts (MG { mg_alts = L _ [] }) + = return 1 -- See Note [Empty MatchGroups] in GHC.Rename.Bind + -- case e of {} or \case {} + -- Both have arity 1 + +checkArgCounts (MG { mg_alts = L _ (match1:matches) }) + | null matches -- There was only one match; nothing to check + = return n_args1 + + -- Two or more matches: check that they agree on arity | Just bad_matches <- mb_bad_matches - = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext + = failWithTc $ TcRnMatchesHaveDiffNumArgs (m_ctxt (unLoc match1)) $ MatchArgMatches match1 bad_matches | otherwise - = return () + = return n_args1 where - n_args1 = args_in_match match1 - mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1] + n_args1 = reqd_args_in_match match1 + mb_bad_matches = NE.nonEmpty [m | m <- matches, reqd_args_in_match m /= n_args1] - args_in_match :: (LocatedA (Match GhcRn body1) -> Int) - args_in_match (L _ (Match { m_pats = pats })) = length pats + reqd_args_in_match :: LocatedA (Match GhcRn body1) -> VisArity + -- Counts the number of /required/ (aka visible) args in the match + reqd_args_in_match (L _ (Match { m_pats = L _ pats })) = count isVisArgLPat pats diff --git a/GHC/Tc/Gen/Match.hs-boot b/GHC/Tc/Gen/Match.hs-boot --- a/GHC/Tc/Gen/Match.hs-boot +++ b/GHC/Tc/Gen/Match.hs-boot @@ -1,17 +1,21 @@ module GHC.Tc.Gen.Match where -import GHC.Hs ( GRHSs, MatchGroup, LHsExpr ) -import GHC.Tc.Types.Evidence ( HsWrapper ) -import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) +import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) +import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Origin ( UserTypeCtxt ) +import GHC.Tc.Types.Evidence ( HsWrapper ) +import GHC.Types.Name ( Name ) import GHC.Hs.Extension ( GhcRn, GhcTc ) -import GHC.Parser.Annotation ( LocatedN ) -import GHC.Types.Name (Name) -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) +tcGRHSsPat :: Mult + -> GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Name - -> MatchGroup GhcRn (LHsExpr GhcRn) - -> ExpSigmaType - -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) +tcFunBindMatches :: UserTypeCtxt + -> Name + -> Mult + -> MatchGroup GhcRn (LHsExpr GhcRn) + -> [ExpPatType] + -> ExpSigmaType + -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) diff --git a/GHC/Tc/Gen/Pat.hs b/GHC/Tc/Gen/Pat.hs --- a/GHC/Tc/Gen/Pat.hs +++ b/GHC/Tc/Gen/Pat.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -18,14 +19,14 @@ , newLetBndr , LetBndrSpec(..) , tcCheckPat, tcCheckPat_O, tcInferPat - , tcPats + , tcMatchPats , addDataConStupidTheta ) where import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferExpr ) import GHC.Hs import GHC.Hs.Syn.Type @@ -65,7 +66,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import qualified GHC.LanguageExtensions as LangExt import Control.Arrow ( second ) import Control.Monad @@ -73,9 +73,11 @@ import qualified Data.List.NonEmpty as NE import GHC.Data.List.SetOps ( getNth ) -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Language.Haskell.Syntax.Basic (FieldLabelString(..), LexicalFixity(..)) import Data.List( partition ) +import Control.Monad.Trans.Writer.CPS +import Control.Monad.Trans.Class {- ************************************************************************ @@ -98,51 +100,139 @@ penv = PE { pe_lazy = True , pe_ctxt = ctxt , pe_orig = PatOrigin } - + ; dflags <- getDynFlags + ; manyIfLazy dflags pat ; tc_lpat pat_ty penv pat thing_inside } + where + -- The logic is partly duplicated from decideBangHood in + -- GHC.HsToCore.Utils. Ugh… + manyIfLazy dflags lpat + | xopt LangExt.Strict dflags = xstrict lpat + | otherwise = not_xstrict lpat + where + xstrict p@(L _ (LazyPat _ _)) = checkManyPattern LazyPatternReason p pat_ty + xstrict (L _ (ParPat _ p)) = xstrict p + xstrict _ = return () + not_xstrict (L _ (BangPat _ _)) = return () + not_xstrict (L _ (VarPat _ _)) = return () + not_xstrict (L _ (ParPat _ p)) = not_xstrict p + not_xstrict p = checkManyPattern LazyPatternReason p pat_ty + ----------------- -tcPats :: HsMatchContext GhcTc - -> [LPat GhcRn] -- ^ atterns - -> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns - -> TcM a -- ^ checker for the body - -> TcM ([LPat GhcTc], a) +tcMatchPats :: forall a. + HsMatchContextRn + -> [LPat GhcRn] -- ^ patterns + -> [ExpPatType] -- ^ types of the patterns + -> TcM a -- ^ checker for the body + -> TcM ([LPat GhcTc], a) +-- See Note [tcMatchPats] +-- +-- PRECONDITION: +-- number of visible pats::[LPat GhcRn] (p is visible, @p is invisible) +-- == +-- number of visible pat_tys::[ExpPatType] (ExpFunPatTy is visible, +-- ExpForAllPatTy b is visible iff b is Required) +-- +-- POSTCONDITION: +-- Returns only the /value/ patterns; see Note [tcMatchPats] --- This is the externally-callable wrapper function --- Typecheck the patterns, extend the environment to bind the variables, --- do the thing inside, use any existentially-bound dictionaries to --- discharge parts of the returning LIE, and deal with pattern type --- signatures +tcMatchPats match_ctxt pats pat_tys thing_inside + = assertPpr (count isVisibleExpPatType pat_tys == count isVisArgLPat pats) + (ppr pats $$ ppr pat_tys) $ + -- Check PRECONDITION + -- When we get @patterns the (length pats) will change + do { err_ctxt <- getErrCtxt + ; let loop :: [LPat GhcRn] -> [ExpPatType] -> TcM ([LPat GhcTc], a) --- 1. Initialise the PatState --- 2. Check the patterns --- 3. Check the body --- 4. Check that no existentials escape + -- No more patterns. Discard excess pat_tys; + -- they should all be invisible. Example: + -- f :: Int -> forall a b. blah + -- f x @p = rhs + -- We will call tcMatchPats with + -- pats = [x, @p] + -- pat_tys = [Int, @a, @b] + loop [] pat_tys + = assertPpr (not (any isVisibleExpPatType pat_tys)) (ppr pats $$ ppr pat_tys) $ + do { res <- setErrCtxt err_ctxt thing_inside + ; return ([], res) } -tcPats ctxt pats pat_tys thing_inside - = tc_lpats pat_tys penv pats thing_inside + -- ExpForAllPat: expecting a type pattern + loop all_pats@(pat : pats) (ExpForAllPatTy (Bndr tv vis) : pat_tys) + | isVisibleForAllTyFlag vis + = do { (_p, (ps, res)) <- tc_forall_lpat tv penv pat $ + loop pats pat_tys + + ; return (ps, res) } + -- This VisPat is Erased. + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + + -- Invisible (Specified) forall in type, and an @a type pattern + -- 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 + -- 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) } + + | otherwise -- Discard invisible pat_ty + = loop all_pats pat_tys + + -- This case handles the user error when an InvisPat is used + -- without a corresponding invisible (Specified) forall in the type + -- E.g. 1. f :: Int + -- f @a = ... -- loop (InvisPat{} : _) [] + -- 2. f :: Int -> Int + -- f @a x = ... -- loop (InvisPat{} : _) (ExpFunPatTy{} : _) + -- 3. f :: forall a -> Int + -- f @a t = ... -- loop (InvisPat{} : _) (ExpForAllPatTy (Bndr _ Required) : _) + -- 4. f :: forall {a}. Int + -- f @a t = ... -- loop (InvisPat{} : _) (ExpForAllPatTy (Bndr _ Inferred) : _) + loop (L loc (InvisPat _ tp) : _) _ + = setSrcSpanA loc $ + failWithTc (TcRnIllegalInvisibleTypePattern tp InvisPatNoForall) + + -- ExpFunPatTy: expecting a value pattern + -- tc_lpat will error if it sees a @t type pattern + loop (pat : pats) (ExpFunPatTy pat_ty : pat_tys) + = do { (p, (ps, res)) <- tc_lpat pat_ty penv pat $ + loop pats pat_tys + ; return (p : ps, res) } + -- This VisPat is Retained. + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + + loop pats@(_:_) [] = pprPanic "tcMatchPats" (ppr pats) + -- Failure of PRECONDITION + + ; loop pats pat_tys } where - penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } + penv = PE { pe_lazy = False, pe_ctxt = LamPat match_ctxt, pe_orig = PatOrigin } + tcInferPat :: FixedRuntimeRepContext - -> HsMatchContext GhcTc + -> HsMatchContextRn -> LPat GhcRn -> TcM a -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR) tcInferPat frr_orig ctxt pat thing_inside - = tcInferFRR frr_orig $ \ exp_ty -> + = runInferSigmaFRR frr_orig $ \ exp_ty -> tc_lpat (unrestricted exp_ty) penv pat thing_inside where penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcCheckPat :: HsMatchContext GhcTc +tcCheckPat :: HsMatchContextRn -> LPat GhcRn -> Scaled TcSigmaTypeFRR -> TcM a -- Checker for body -> TcM (LPat GhcTc, a) tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin -- | A variant of 'tcPat' that takes a custom origin -tcCheckPat_O :: HsMatchContext GhcTc +tcCheckPat_O :: HsMatchContextRn -> CtOrigin -- ^ origin to use if the type needs inst'ing -> LPat GhcRn -> Scaled TcSigmaTypeFRR -> TcM a -- Checker for body @@ -153,7 +243,26 @@ penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig } -{- +{- Note [tcMatchPats] +~~~~~~~~~~~~~~~~~~~~~ +tcMatchPats is the externally-callable wrapper function for + function definitions f p1 .. pn = rhs + lambdas \p1 .. pn -> body +Typecheck the patterns, extend the environment to bind the variables, do the +thing inside, use any existentially-bound dictionaries to discharge parts of +the returning LIE, and deal with pattern type signatures + +It takes the list of patterns writen by the user, but it returns only the +/value/ patterns. For example: + f :: forall a. forall b -> a -> Mabye b -> blah + f @a w x (Just y) = .... +tcMatchPats returns only the /value/ patterns [x, Just y]. Why? The +desugarer expects only value patterns. (We could change that, but we would +have to do so carefullly.) However, distinguishing value patterns from type +patterns is a bit tricky; e.g. the `w` in this example. So it's very +convenient to filter them out right here. + + ************************************************************************ * * PatEnv, PatCtxt, LetBndrSpec @@ -169,7 +278,7 @@ data PatCtxt = LamPat -- Used for lambdas, case etc - (HsMatchContext GhcTc) + HsMatchContextRn | LetPat -- Used only for let(rec) pattern bindings -- See Note [Typing patterns in pattern bindings] @@ -230,7 +339,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 @@ -325,21 +434,21 @@ tcMultiple :: Checker inp out -> Checker [inp] [out] tcMultiple tc_pat penv args thing_inside = do { err_ctxt <- getErrCtxt - ; let loop _ [] + ; let loop [] = do { res <- thing_inside ; return ([], res) } - loop penv (arg:args) + loop (arg:args) = do { (p', (ps', res)) <- tc_pat penv arg $ setErrCtxt err_ctxt $ - loop penv args + loop args -- setErrCtxt: restore context before doing the next pattern -- See Note [Nesting] above ; return (p':ps', res) } - ; loop penv args } + ; loop args } -------------------- tc_lpat :: Scaled ExpSigmaTypeFRR @@ -356,13 +465,156 @@ = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $ tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p) penv - (zipEqual "tc_lpats" pats tys) + (zipEqual pats tys) -------------------- --- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. -checkManyPattern :: Scaled a -> TcM HsWrapper -checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin ManyTy (scaledMult pat_ty) +checkManyPattern :: NonLinearPatternReason -> LPat GhcRn -> Scaled a -> TcM () +checkManyPattern reason pat pat_ty = tcSubMult (NonLinearPatternOrigin reason pat) ManyTy (scaledMult pat_ty) + +tc_forall_lpat :: TcTyVar -> Checker (LPat GhcRn) (LPat GhcTc) +tc_forall_lpat tv penv (L span pat) thing_inside + = setSrcSpanA span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_forall_pat tv penv pat) + thing_inside + ; return (L span pat', res) } + +tc_forall_pat :: TcTyVar -> Checker (Pat GhcRn) (Pat GhcTc) +tc_forall_pat tv penv (ParPat x lpat) thing_inside + = do { (lpat', res) <- tc_forall_lpat tv penv lpat thing_inside + ; return (ParPat x lpat', res) } + +tc_forall_pat tv _ (EmbTyPat _ tp) thing_inside + -- The entire type pattern is guarded with the `type` herald: + -- f (type t) (x :: t) = ... + -- This special case is not necessary for correctness but avoids + -- a redundant `ExpansionPat` node. + = do { (arg_ty, result) <- tc_ty_pat tp tv thing_inside + ; return (EmbTyPat arg_ty tp, result) } + +tc_forall_pat tv _ pat thing_inside + -- The type pattern is not guarded with the `type` herald, or perhaps + -- only parts of it are, e.g. + -- f (t :: Type) (x :: t) = ... -- no `type` herald + -- f ((type t) :: Type) (x :: t) = ... -- nested `type` herald + -- Apply a recursive T2T transformation. + = do { tp <- pat_to_type_pat pat + ; (arg_ty, result) <- tc_ty_pat tp tv thing_inside + ; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty tp) + ; return (pat', result) } + + +-- Convert a Pat into the equivalent HsTyPat. +-- See `expr_to_type` (GHC.Tc.Gen.App) for the HsExpr counterpart. +-- The `TcM` monad is only used to fail on ill-formed type patterns. +pat_to_type_pat :: Pat GhcRn -> TcM (HsTyPat GhcRn) +pat_to_type_pat pat = do + (ty, x) <- runWriterT (pat_to_type pat) + pure (HsTP (buildHsTyPatRn x) ty) + +pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) +pat_to_type (EmbTyPat _ (HsTP x t)) = + do { tell (builderFromHsTyPatRn x) + ; return t } +pat_to_type (VarPat _ lname) = + do { tell (tpBuilderExplicitTV (unLoc lname)) + ; return b } + where b = noLocA (HsTyVar noAnn NotPromoted $ fmap noUserRdr lname) +pat_to_type (WildPat _) = return b + where b = noLocA (HsWildCardTy noExtField) +pat_to_type (SigPat _ pat sig_ty) + = do { t <- pat_to_type (unLoc pat) + ; let { !(HsPS x_hsps k) = sig_ty + ; b = noLocA (HsKindSig noAnn t k) } + ; tell (tpBuilderPatSig x_hsps) + ; return b } +pat_to_type (ParPat _ pat) + = do { t <- pat_to_type (unLoc pat) + ; return (noLocA (HsParTy noAnn t)) } +pat_to_type (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do + { t <- pat_to_type pat + ; return (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice)) } + +pat_to_type (TuplePat _ pats Boxed) + = do { tys <- traverse (pat_to_type . unLoc) pats + ; let t = noLocA (HsExplicitTupleTy noExtField NotPromoted tys) + ; pure t } +pat_to_type (ListPat _ pats) + = do { tys <- traverse (pat_to_type . unLoc) pats + ; let t = noLocA (HsExplicitListTy NoExtField NotPromoted tys) + ; pure t } + +pat_to_type (LitPat _ lit) + | Just ty_lit <- tyLitFromLit lit + = do { let t = noLocA (HsTyLit noExtField ty_lit) + ; pure t } +pat_to_type (NPat _ (L _ lit) _ _) + | Just ty_lit <- tyLitFromOverloadedLit (ol_val lit) + = do { let t = noLocA (HsTyLit noExtField ty_lit) + ; pure t} + +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 noExtField NotPromoted lty lname rty)} + ; pure t } +pat_to_type (ConPat _ lname (PrefixCon args)) + = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname) } + ; foldM apply_arg appHead args } + where + apply_arg :: LHsType GhcRn -> LPat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) + apply_arg !t (L _ (InvisPat _ (HsTP argx arg))) + = do { tell (builderFromHsTyPatRn argx) + ; pure (mkHsAppKindTy noExtField t arg)} + apply_arg !t (L _ p) + = do { ty_p <- pat_to_type p + ; pure (mkHsAppTy t ty_p)} + +pat_to_type pat = lift $ + failWith $ TcRnIllformedTypePattern pat + -- This failure is the only use of the TcM monad in `pat_to_type_pat` + +{- +Note [Pattern to type (P2T) conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + data T a b where + MkT :: forall a. forall b -> a -> b -> T a b + -- NB: `a` is invisible, but `b` is required + + f (MkT @[Int] (Maybe Bool) x y) = ... + +The second type argument of `MkT` is Required, so we write it without +an `@` sign in the pattern match. So the (Maybe Bool) will be + * parsed and renamed as a term pattern + * converted to a type when typechecking the pattern-match: the P2T conversion + +This is the only place we have P2T. In type-lambdas, the "pattern" is always a +type variable: + + f :: forall a -> a -> blah + f b (x::b) = ... + +The `b` argument must be a simple variable; we can't pattern-match on types. + +The function `pat_to_type` does the P2T conversion: + pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn) + +It is arranged as a writer monad, where the `HsTyPatRnBuilder` accumulates the +binders bound by the type. (We could discover these binders by a subsequent +traversal, that would mean writing another traversal.) +-} + +tc_ty_pat :: HsTyPat GhcRn -> TcTyVar -> TcM r -> TcM (TcType, r) +tc_ty_pat tp tv thing_inside + = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat tp (varType tv) + ; _ <- unifyType Nothing arg_ty (mkTyVarTy tv) + ; result <- tcExtendNameTyVarEnv sig_wcs $ + tcExtendNameTyVarEnv sig_ibs $ + thing_inside + ; return (arg_ty, result) } + tc_pat :: Scaled ExpSigmaTypeFRR -- ^ Fully refined result type -> Checker (Pat GhcRn) (Pat GhcTc) @@ -372,23 +624,31 @@ VarPat x (L l name) -> do { (wrap, id) <- tcPatBndr penv name pat_ty - ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $ + ; res <- tcCheckUsage name (scaledMult pat_ty) $ tcExtendIdEnv1 name id thing_inside - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) } + ; return (mkHsWrapPat wrap (VarPat x (L l id)) pat_ty, res) } - ParPat x lpar pat rpar -> do + ParPat x pat -> do { (pat', res) <- tc_lpat pat_ty penv pat thing_inside - ; return (ParPat x lpar pat' rpar, res) } + ; return (ParPat x pat', res) } BangPat x pat -> do { (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 pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + { checkManyPattern LazyPatternReason (noLocA ps_pat) pat_ty ; (pat', (res, pat_ct)) <- tc_lpat pat_ty (makeLazy penv) pat $ captureConstraints thing_inside @@ -402,18 +662,16 @@ ; pat_ty <- readExpType (scaledThing pat_ty) ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind - ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) } + ; return ((LazyPat x pat'), res) } WildPat _ -> do - { mult_wrap <- checkManyPattern pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty ; res <- thing_inside ; pat_ty <- expTypeToType (scaledThing pat_ty) - ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } + ; return (WildPat pat_ty, res) } - AsPat x (L nm_loc name) at pat -> do - { mult_wrap <- checkManyPattern pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + AsPat x (L nm_loc name) pat -> do + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id)) @@ -426,26 +684,27 @@ -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) at pat') pat_ty, res) } + ; return (mkHsWrapPat wrap (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } ViewPat _ expr pat -> do - { mult_wrap <- checkManyPattern pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + { checkManyPattern ViewPatternReason (noLocA ps_pat) pat_ty -- -- It should be possible to have view patterns at linear (or otherwise -- non-Many) multiplicity. But it is not clear at the moment what -- restriction need to be put in place, if any, for linear view -- patterns to desugar to type-correct Core. - ; (expr',expr_ty) <- tcInferRho expr - -- Note [View patterns and polymorphism] + ; (expr', expr_rho) <- tcInferExpr IIF_ShallowRho expr + -- IIF_ShallowRho: do not perform deep instantiation, regardless of + -- DeepSubsumption (Note [View patterns and polymorphism]) + -- But we must do top-instantiation to expose the arrow to matchActualFunTy -- Expression must be a function ; let herald = ExpectedFunTyViewPat $ unLoc expr ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) - <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty + <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_rho) expr_rho -- See Note [View patterns and polymorphism] - -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) + -- expr_wrap1 :: expr_rho "->" (inf_arg_ty -> inf_res_sigma) -- Check that overall pattern is more polymorphic than arg type ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty @@ -458,18 +717,18 @@ ; pat_ty <- readExpType h_pat_ty ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper (Scaled w pat_ty) inf_res_sigma - -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" - -- (pat_ty -> inf_res_sigma) - -- NB: pat_ty comes from matchActualFunTySigma, so it has a - -- fixed RuntimeRep, as needed to call mkWpFun. - ; let - expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap + -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->" + -- (pat_ty -> inf_res_sigma) + -- NB: pat_ty comes from matchActualFunTy, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. + expr_wrap = expr_wrap2' <.> expr_wrap1 + ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) } {- Note [View patterns and polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this exotic example: +Consider this exotic example (test T26331a): pair :: forall a. Bool -> a -> forall b. b -> (a,b) f :: Int -> blah @@ -478,11 +737,15 @@ The expression (pair True) should have type pair True :: Int -> forall b. b -> (Int,b) so that it is ready to consume the incoming Int. It should be an -arrow type (t1 -> t2); hence using (tcInferRho expr). +arrow type (t1 -> t2); and we must not instantiate that `forall b`, +/even with DeepSubsumption/. Hence using `IIF_ShallowRho`; this is the only +place where `IIF_ShallowRho` is used. Then, when taking that arrow apart we want to get a *sigma* type (forall b. b->(Int,b)), because that's what we want to bind 'x' to. -Fortunately that's what matchActualFunTySigma returns anyway. +Fortunately that's what matchActualFunTy returns anyway. + +Another example is #26331. -} -- Type signatures in patterns @@ -511,8 +774,7 @@ penv pats thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat coi - (ListPat elt_ty pats') pat_ty, res) -} + (ListPat elt_ty pats') pat_ty, res) } TuplePat _ pats boxity -> do { let arity = length pats @@ -595,9 +857,7 @@ -- -- When there is no negation, neg_lit_ty and lit_ty are the same NPat _ (L l over_lit) mb_neg eq -> do - { mult_wrap <- checkManyPattern pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. - -- + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty -- It may be possible to refine linear pattern so that they work in -- linear environments. But it is not clear how useful this is. ; let orig = LiteralOrigin over_lit @@ -620,7 +880,7 @@ ; res <- thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat mult_wrap (NPat pat_ty (L l lit') mb_neg' eq') pat_ty, res) } + ; return (NPat pat_ty (L l lit') mb_neg' eq', res) } {- Note [NPlusK patterns] @@ -648,8 +908,7 @@ -- See Note [NPlusK patterns] NPlusKPat _ (L nm_loc name) (L loc lit) _ ge minus -> do - { mult_wrap <- checkManyPattern pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + { checkManyPattern OtherPatternReason (noLocA ps_pat) pat_ty ; let pat_exp_ty = scaledThing pat_ty orig = LiteralOrigin lit ; (lit1', ge') @@ -692,7 +951,7 @@ -- we get warnings if we try. #17783 pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2' ge' minus'' - ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) } + ; return (pat', res) } -- Here we get rid of it and add the finalizers to the global environment. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. @@ -702,6 +961,10 @@ SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat" + EmbTyPat _ _ -> failWith TcRnIllegalTypePattern + + InvisPat _ _ -> panic "tc_pat: invisible pattern appears recursively in the pattern" + XPat (HsPatExpanded lpat rpat) -> do { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside ; return (XPat $ ExpansionPat lpat rpat', res) } @@ -780,12 +1043,7 @@ = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty ; res_ty <- readExpType res_ty -- should be filled in by now ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty - ; let msg = vcat [ hang (text "When checking that the pattern signature:") - 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] - ; return (tidy_env, msg) } - + ; return (tidy_env, PatSigErrCtxt sig_ty res_ty) } {- ********************************************************************* * * @@ -861,12 +1119,13 @@ -- MkT :: forall a b c. (a~[b]) => b -> c -> T a -- with scrutinee of type (T ty) -tcConPat :: PatEnv -> LocatedN Name +tcConPat :: PatEnv -> LocatedN (WithUserRdr Name) -> Scaled ExpSigmaTypeFRR -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) -tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside - = do { con_like <- tcLookupConLike con_name +tcConPat penv (L loc qcon) pat_ty arg_pats thing_inside + = do { let con_lname = L loc (getName qcon) + ; con_like <- tcLookupConLike qcon ; case con_like of RealDataCon data_con -> tcDataConPat con_lname data_con pat_ty penv arg_pats thing_inside @@ -924,7 +1183,7 @@ ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs -- Get location from monad, not from ex_tvs -- This freshens: See Note [Freshen existentials] - -- Why "super"? See Note [Binding when looking up instances] + -- Why "super"? See Note [Super skolems: binding when looking up instances] -- in GHC.Core.InstEnv. ; let arg_tys' = substScaledTys tenv arg_tys @@ -948,16 +1207,21 @@ , text "arg_tys':" <+> ppr arg_tys' , text "arg_pats" <+> ppr arg_pats ]) - ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats + ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats + ; traceTc "tcConPat" (vcat [ text "univ_ty_args:" <+> ppr univ_ty_args + , text "ex_ty_args:" <+> ppr ex_ty_args + , text "val_arg_pats:" <+> ppr val_arg_pats ]) + ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) - (arg_pats', res) <- tcConTyArgs tenv penv univ_ty_args $ + (val_arg_pats', res) <- + tcConTyArgs tenv penv univ_ty_args $ tcConValArgs con_like arg_tys_scaled - penv arg_pats thing_inside + penv val_arg_pats thing_inside ; let res_pat = ConPat { pat_con = header - , pat_args = arg_pats' + , pat_args = val_arg_pats' , pat_con_ext = ConPatTc { cpt_tvs = [], cpt_dicts = [] , cpt_binds = emptyTcEvBinds @@ -974,7 +1238,7 @@ -- order is *important* as we generate the list of -- dictionary binders from theta' - ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds + ; when (not (null eq_spec) || any isEqClassPred theta) warnMonoLocalBinds ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) @@ -982,7 +1246,7 @@ tcConTyArgs tenv penv univ_ty_args $ checkConstraints (getSkolemInfo skol_info) ex_tvs' given $ tcConTyArgs tenv penv ex_ty_args $ - tcConValArgs con_like arg_tys_scaled penv arg_pats thing_inside + tcConValArgs con_like arg_tys_scaled penv val_arg_pats thing_inside ; let res_pat = ConPat { pat_con = header @@ -1011,9 +1275,10 @@ ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys) ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv - ; skol_info <- case pe_ctxt penv of - LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc) - LetPat {} -> return unkSkol -- Doesn't matter + ; let match_ctxt = case pe_ctxt penv of + LamPat mc -> mc + LetPat {} -> PatBindRhs + ; skol_info <- mkSkolemInfo (PatSkol (PatSynCon pat_syn) match_ctxt) ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs -- This freshens: Note [Freshen existentials] @@ -1026,12 +1291,11 @@ req_theta' = substTheta tenv req_theta con_like = PatSynCon pat_syn - ; when (any isEqPred prov_theta) warnMonoLocalBinds + ; when (any isEqClassPred prov_theta) warnMonoLocalBinds - ; mult_wrap <- checkManyPattern pat_ty - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. + ; checkManyPattern PatternSynonymReason nlWildPatName pat_ty - ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats + ; (univ_ty_args, ex_ty_args, val_arg_pats) <- splitConTyArgs con_like arg_pats ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' @@ -1058,7 +1322,7 @@ -- 'tcDataConPat'.) ; let bad_arg_tys :: [(Int, Scaled Type)] - bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> typeLevity_maybe arg_ty == Nothing) + bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> not (typeHasFixedRuntimeRep arg_ty)) $ zip [0..] arg_tys' ; massertPpr (null bad_arg_tys) $ vcat [ text "tcPatSynPat: pattern arguments do not have a fixed RuntimeRep" @@ -1066,17 +1330,17 @@ ; traceTc "checkConstraints {" Outputable.empty ; prov_dicts' <- newEvVars prov_theta' - ; (ev_binds, (arg_pats', res)) + ; (ev_binds, (val_arg_pats', res)) <- -- See Note [Type applications in patterns] (W4) tcConTyArgs tenv penv univ_ty_args $ checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $ tcConTyArgs tenv penv ex_ty_args $ - tcConValArgs con_like arg_tys_scaled penv arg_pats $ + tcConValArgs con_like arg_tys_scaled penv val_arg_pats $ thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn - , pat_args = arg_pats' + , pat_args = val_arg_pats' , pat_con_ext = ConPatTc { cpt_tvs = ex_tvs' , cpt_dicts = prov_dicts' @@ -1086,7 +1350,7 @@ } } ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } + ; return (mkHsWrapPat wrap res_pat pat_ty, res) } checkFixedRuntimeRep :: DataCon -> [Scaled TcSigmaTypeFRR] -> TcM () checkFixedRuntimeRep data_con arg_tys @@ -1112,12 +1376,12 @@ This is achieve easily, but a bit trickily. When we instantiate Annotated's "required" constraints, in tcPatSynPat, give them a CtOrigin of (OccurrenceOf "Annotated"). That way the special magic -in GHC.Tc.Solver.Dict.solveCallStack which deals with CallStack +in GHC.Tc.Solver.Dict.canDictCt which deals with CallStack constraints will kick in: that logic only fires on constraints whose Origin is (OccurrenceOf f). See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence -and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types +and Note [Solving CallStack constraints] in GHC.Tc.Solver.Dict -} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function @@ -1320,54 +1584,82 @@ 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. +-} + tcConValArgs :: ConLike -> [Scaled TcSigmaTypeFRR] -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) tcConValArgs con_like arg_tys penv con_args thing_inside = case con_args of - PrefixCon type_args arg_pats -> do - -- NB: type_args already dealt with + PrefixCon arg_pats -> do + -- NB: Type arguments already dealt with by splitConTyArgs, tcConTyArgs. -- See Note [Type applications in patterns] - { checkTc (con_arity == no_of_args) -- Check correct arity - (TcRnArityMismatch (AConLike con_like) con_arity no_of_args) - - ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys + { report_invis_arg_pats arg_pats + ; let pats_w_tys = zipEqual arg_pats arg_tys ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys thing_inside - ; return (PrefixCon type_args arg_pats', res) } - where - con_arity = conLikeArity con_like - no_of_args = length arg_pats + -- Return only /value/ patterns, all /type/ patterns are discarded. + -- This is also what tcMatchPats does, and Note [tcMatchPats] explains why. + ; return (PrefixCon arg_pats', res) } + where + -- Report @-patterns as errors. The valid ones have been dealt with + -- outside tcConValArgs. At this point we are expecting patterns for + -- value arguments only. + report_invis_arg_pats :: [LPat GhcRn] -> TcM () + report_invis_arg_pats ps = do + let bad_ps = [L loc tp | L loc (InvisPat _ tp) <- ps] + forM_ bad_ps $ \(L loc tp) -> + setSrcSpanA loc $ + addErrTc (TcRnIllegalInvisibleTypePattern tp InvisPatNoForall) + unless (null bad_ps) failM InfixCon p1 p2 -> do - { checkTc (con_arity == 2) -- Check correct arity - (TcRnArityMismatch (AConLike con_like) con_arity 2) - ; let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after the arity check + { let [arg_ty1,arg_ty2] = arg_tys -- This can't fail after splitConTyArgs ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)] thing_inside ; return (InfixCon p1' p2', res) } - where - con_arity = conLikeArity con_like - RecCon (HsRecFields rpats dd) -> do - { (rpats', res) <- tcMultiple tc_field penv rpats thing_inside - ; return (RecCon (HsRecFields rpats' dd), res) } + RecCon (HsRecFields x rpats dd) -> do + { check_omitted_fields_multiplicity + ; (rpats', res) <- tcMultiple tc_field penv rpats thing_inside + ; return ((RecCon (HsRecFields x 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 () + check_omitted_fields_multiplicity = do + forM_ omitted_field_tys $ \(fl, pat_ty) -> + tcSubMult (OmittedFieldOrigin fl) ManyTy (scaledMult pat_ty) find_field_ty :: Name -> FastString -> TcM (Scaled TcType) find_field_ty sel lbl - = 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, @@ -1382,56 +1674,96 @@ 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 + +check_con_pat_arity :: ConLike -> Int -> TcM () +check_con_pat_arity con_like no_of_vis_args = + checkTc (con_vis_arity == no_of_vis_args) + (TcRnArityMismatch (AConLike con_like) con_vis_arity no_of_vis_args) + where + con_vis_arity = conLikeVisArity con_like + splitConTyArgs :: ConLike -> HsConPatDetails GhcRn - -> TcM ( [(HsConPatTyArg GhcRn, TyVar)] -- Universals - , [(HsConPatTyArg GhcRn, TyVar)] ) -- Existentials + -> TcM ( [(HsTyPat GhcRn, TyVar)] -- Universals + , [(HsTyPat GhcRn, TyVar)] -- Existentials + , HsConPatDetails GhcRn ) -- Value arguments -- See Note [Type applications in patterns] (W4) --- This function is monadic only because of the error check --- for too many type arguments -splitConTyArgs con_like (PrefixCon type_args _) - = do { checkTc (type_args `leLength` con_spec_bndrs) - (TcRnTooManyTyArgsInConPattern con_like - (length con_spec_bndrs) (length type_args)) - ; if null ex_tvs -- Short cut common case - then return (bndr_ty_arg_prs, []) - else return (partition is_universal bndr_ty_arg_prs) } +-- This function is monadic only to emit error messages +splitConTyArgs con_like (PrefixCon arg_pats) = do + check_con_pat_arity con_like (count isVisArgLPat arg_pats) + split_con_ty_args Prefix con_like arg_pats +splitConTyArgs con_like (InfixCon arg1 arg2) = do + -- should not occur: (@a :+ b), (a :+ @b), or (@a :+ @b) + massert (isVisArgLPat arg1 && isVisArgLPat arg2) + check_con_pat_arity con_like 2 + split_con_ty_args Infix con_like [arg1, arg2] +splitConTyArgs _ p@(RecCon {}) = return ([], [], p) -- No type args in RecCon + +split_con_ty_args :: LexicalFixity -- How to wrap value arguments + -> ConLike -- Data constructor or pattern synonym + -> [LPat GhcRn] -- Argument patterns + -> TcM ( [(HsTyPat GhcRn, TyVar)] -- Universals + , [(HsTyPat GhcRn, TyVar)] -- Existentials + , HsConPatDetails GhcRn ) -- Value arguments +split_con_ty_args fixity con_like arg_pats = do + (bndr_ty_arg_prs, value_args) <- zip_pats_bndrs arg_pats (conLikeUserTyVarBinders con_like) + return $ if null ex_tvs -- Short cut common case + then (bndr_ty_arg_prs, [], mk_details fixity value_args) + else let (ex_prs, univ_prs) = partition is_existential bndr_ty_arg_prs + in (univ_prs, ex_prs, mk_details fixity value_args) where ex_tvs = conLikeExTyCoVars con_like - con_spec_bndrs = [ tv | Bndr tv SpecifiedSpec <- conLikeUserTyVarBinders con_like ] - -- conLikeUserTyVarBinders: see (W3) in - -- Note [Type applications in patterns] - -- SpecifiedSpec: forgetting to filter out inferred binders led to #20443 - - bndr_ty_arg_prs = type_args `zip` con_spec_bndrs - -- The zip truncates to length(type_args) + is_existential (_, tv) = tv `elem` ex_tvs + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- especially INVARIANT(dataConTyVars). - is_universal (_, tv) = not (tv `elem` ex_tvs) - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon - -- especially INVARIANT(dataConTyVars). + mk_details Infix [a,b] = InfixCon a b + mk_details _ ps = PrefixCon ps + -- InfixCon becomes PrefixCon if there are fewer than 2 value arguments. + -- Test case: T25127_infix -splitConTyArgs _ (RecCon {}) = return ([], []) -- No type args in RecCon -splitConTyArgs _ (InfixCon {}) = return ([], []) -- No type args in InfixCon +zip_pats_bndrs :: [LPat GhcRn] -> [TyVarBinder] -> TcM ([(HsTyPat GhcRn, TyVar)], [LPat GhcRn]) +zip_pats_bndrs (L loc pat : pats) (Bndr tv vis : tvbs) + | isVisibleForAllTyFlag vis + = do { tp <- setSrcSpanA loc $ pat_to_type_pat pat + ; (prs, pats') <- zip_pats_bndrs pats tvbs + ; return ((tp, tv) : prs, pats') } + | InvisPat pat_spec tp <- pat + , Invisible spec <- vis + , pat_spec == spec + = do { (prs, pats') <- zip_pats_bndrs pats tvbs + ; return ((tp, tv):prs, pats') } +zip_pats_bndrs pats (Bndr _ vis : tvbs) + -- zip_pats_bndrs [] (Bndr _ Required : tvbs) + -- is ruled out by the arity check in splitConTyArgs, + -- so we can assume (isInvisibleForAllTyFlag vis) + = do { massert (isInvisibleForAllTyFlag vis) + ; zip_pats_bndrs pats tvbs } +zip_pats_bndrs pats [] = return ([], pats) -tcConTyArgs :: Subst -> PatEnv -> [(HsConPatTyArg GhcRn, TyVar)] +tcConTyArgs :: Subst -> PatEnv -> [(HsTyPat GhcRn, TyVar)] -> TcM a -> TcM a tcConTyArgs tenv penv prs thing_inside = tcMultiple_ (tcConTyArg tenv) penv prs thing_inside -tcConTyArg :: Subst -> Checker (HsConPatTyArg GhcRn, TyVar) () -tcConTyArg tenv penv (HsConPatTyArg _ rn_ty, con_tv) thing_inside - = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsPatSigType TypeAppCtxt HM_TyAppPat rn_ty AnyKind - -- AnyKind is a bit suspect: it really should be the kind gotten - -- from instantiating the constructor type. But this would be - -- hard to get right, because earlier type patterns might influence - -- the kinds of later patterns. In any case, it all gets checked - -- by the calls to unifyType below which unifies kinds +tcConTyArg :: Subst -> Checker (HsTyPat GhcRn, TyVar) () +tcConTyArg tenv penv (rn_ty, con_tv) thing_inside + = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat rn_ty (substTy tenv (varType con_tv)) ; case NE.nonEmpty sig_ibs of Just sig_ibs_ne | inPatBind penv -> @@ -1584,14 +1916,13 @@ -- Not all patterns are worth pushing a context maybeWrapPatCtxt pat tcm thing_inside | not (worth_wrapping pat) = tcm thing_inside - | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + | otherwise = addErrCtxt (PatCtxt pat) $ tcm $ popErrCtxt thing_inside -- Remember to pop before doing thing_inside where worth_wrapping (VarPat {}) = False worth_wrapping (ParPat {}) = False worth_wrapping (AsPat {}) = False worth_wrapping _ = True - msg = hang (text "In the pattern:") 2 (ppr pat) ----------------------------------------------- diff --git a/GHC/Tc/Gen/Rule.hs b/GHC/Tc/Gen/Rule.hs deleted file mode 100644 --- a/GHC/Tc/Gen/Rule.hs +++ /dev/null @@ -1,517 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1993-1998 - --} - --- | Typechecking rewrite rules -module GHC.Tc.Gen.Rule ( tcRules ) where - -import GHC.Prelude - -import GHC.Hs -import GHC.Tc.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Solver -import GHC.Tc.Solver.Monad ( runTcS ) -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.TcType -import GHC.Tc.Gen.HsType -import GHC.Tc.Gen.Expr -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Unify( buildImplicationFor ) -import GHC.Tc.Zonk.TcType - -import GHC.Core.Type -import GHC.Core.Coercion( mkCoVarCo ) -import GHC.Core.TyCon( isTypeFamilyTyCon ) -import GHC.Core.Predicate - -import GHC.Types.Id -import GHC.Types.Var( EvVar, tyVarName ) -import GHC.Types.Var.Set -import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) ) -import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString -import GHC.Data.Bag - -{- -Note [Typechecking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We *infer* the typ of the LHS, and use that type to *check* the type of -the RHS. That means that higher-rank rules work reasonably well. Here's -an example (test simplCore/should_compile/rule2.hs) produced by Roman: - - foo :: (forall m. m a -> m b) -> m a -> m b - foo f = ... - - bar :: (forall m. m a -> m a) -> m a -> m a - bar f = ... - - {-# RULES "foo/bar" foo = bar #-} - -He wanted the rule to typecheck. - -Note [TcLevel in type checking rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Bringing type variables into scope naturally bumps the TcLevel. Thus, we type -check the term-level binders in a bumped level, and we must accordingly bump -the level whenever these binders are in scope. - -Note [Re-quantify type variables in rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this example from #17710: - - foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b - foo x = Proxy - {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} - -Written out in more detail, the "foo" rewrite rule looks like this: - - forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 - -Where b0 is a unification variable. Where should b0 be quantified? We have to -quantify it after k, since (b0 :: k). But generalization usually puts inferred -type variables (such as b0) at the /front/ of the telescope! This creates a -conflict. - -One option is to simply throw an error, per the principles of -Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen -if we were generalising over a normal type signature. On the other hand, the -types in a rewrite rule aren't quite "normal", since the notions of specified -and inferred type variables aren't applicable. - -A more permissive design (and the design that GHC uses) is to simply requantify -all of the type variables. That is, we would end up with this: - - forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b - -It's a bit strange putting the generalized variable `b` after the user-written -variables `k` and `a`. But again, the notion of specificity is not relevant to -rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not -only makes "foo" typecheck, but it also makes the implementation simpler. - -See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which -explains a very similar design when generalising over a type family instance -equation. --} - -tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] -tcRules decls = mapM (wrapLocMA tcRuleDecls) decls - -tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) -tcRuleDecls (HsRules { rds_ext = src - , rds_rules = decls }) - = do { tc_decls <- mapM (wrapLocMA tcRule) decls - ; return $ HsRules { rds_ext = src - , rds_rules = tc_decls } } - -tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc) -tcRule (HsRule { rd_ext = ext - , rd_name = rname@(L _ name) - , rd_act = act - , rd_tyvs = ty_bndrs - , rd_tmvs = tm_bndrs - , rd_lhs = lhs - , rd_rhs = rhs }) - = addErrCtxt (ruleCtxt name) $ - do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname) - ; skol_info <- mkSkolemInfo (RuleSkol name) - -- Note [Typechecking rules] - ; (tc_lvl, stuff) <- pushTcLevelM $ - generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs - - ; let (id_bndrs, lhs', lhs_wanted - , rhs', rhs_wanted, rule_ty) = stuff - - ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname - , ppr lhs_wanted - , ppr rhs_wanted ]) - - ; (lhs_evs, residual_lhs_wanted, dont_default) - <- simplifyRule name tc_lvl lhs_wanted rhs_wanted - - -- SimplifyRule Plan, step 4 - -- Now figure out what to quantify over - -- c.f. GHC.Tc.Solver.simplifyInfer - -- We quantify over any tyvars free in *either* the rule - -- *or* the bound variables. The latter is important. Consider - -- ss (x,(y,z)) = (x,z) - -- RULE: forall v. fst (ss v) = fst v - -- The type of the rhs of the rule is just a, but v::(a,(b,c)) - -- - -- We also need to get the completely-unconstrained tyvars of - -- the LHS, lest they otherwise get defaulted to Any; but we do that - -- during zonking (see GHC.Tc.Zonk.Type.zonkRule) - - ; let tpl_ids = lhs_evs ++ id_bndrs - - -- See Note [Re-quantify type variables in rules] - ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) - ; let weed_out = (`dVarSetMinusVarSet` dont_default) - quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs) - , dv_tvs = weed_out (dv_tvs forall_tkvs) } - ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands - ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname - , text "forall_tkvs:" <+> ppr forall_tkvs - , text "quant_cands:" <+> ppr quant_cands - , text "dont_default:" <+> ppr dont_default - , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted - , text "qtkvs:" <+> ppr qtkvs - , text "rule_ty:" <+> ppr rule_ty - , text "ty_bndrs:" <+> ppr ty_bndrs - , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids) - , text "tpl_id info:" <+> - vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] - ]) - - -- SimplfyRule Plan, step 5 - -- Simplify the LHS and RHS constraints: - -- For the LHS constraints we must solve the remaining constraints - -- (a) so that we report insoluble ones - -- (b) so that we bind any soluble ones - ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs - lhs_evs residual_lhs_wanted - ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs - lhs_evs rhs_wanted - ; emitImplications (lhs_implic `unionBags` rhs_implic) - ; return $ HsRule { rd_ext = ext - , rd_name = rname - , rd_act = act - , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA) - (qtkvs ++ tpl_ids) - , rd_lhs = mkHsDictLet lhs_binds lhs' - , rd_rhs = mkHsDictLet rhs_binds rhs' } } - -generateRuleConstraints :: FastString - -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] - -> LHsExpr GhcRn -> LHsExpr GhcRn - -> TcM ( [TcId] - , LHsExpr GhcTc, WantedConstraints - , LHsExpr GhcTc, WantedConstraints - , TcType ) -generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs - = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $ - tcRuleBndrs rule_name ty_bndrs tm_bndrs - -- bndr_wanted constraints can include wildcard hole - -- constraints, which we should not forget about. - -- It may mention the skolem type variables bound by - -- the RULE. c.f. #10072 - ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $ - tcExtendIdEnv id_bndrs $ - do { -- See Note [Solve order for RULES] - ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs) - ; (rhs', rhs_wanted) <- captureConstraints $ - tcCheckMonoExpr rhs rule_ty - ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted - ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } - --- See Note [TcLevel in type checking rules] -tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] - -> TcM ([TcTyVar], [Id]) -tcRuleBndrs rule_name (Just bndrs) xs - = do { skol_info <- mkSkolemInfo (RuleSkol rule_name) - ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $ - tcRuleTmBndrs rule_name xs - ; let tys1 = binderVars tybndrs1 - ; return (tys1 ++ tys2, tms) } - -tcRuleBndrs rule_name Nothing xs - = tcRuleTmBndrs rule_name xs - --- See Note [TcLevel in type checking rules] -tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id]) -tcRuleTmBndrs _ [] = return ([],[]) -tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs) - = do { ty <- newOpenFlexiTyVarTy - ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs - ; return (tyvars, mkLocalId name ManyTy ty : tmvars) } -tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) --- e.g x :: a->a --- The tyvar 'a' is brought into scope first, just as if you'd written --- a::*, x :: a->a --- If there's an explicit forall, the renamer would have already reported an --- error for each out-of-scope type variable used - = do { let ctxt = RuleSigCtxt rule_name name - ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind - ; let id = mkLocalId name ManyTy id_ty - -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType - - -- The type variables scope over subsequent bindings; yuk - ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $ - tcRuleTmBndrs rule_name rule_bndrs - ; return (map snd tvs ++ tyvars, id : tmvars) } - -ruleCtxt :: FastString -> SDoc -ruleCtxt name = text "When checking the rewrite rule" <+> - doubleQuotes (ftext name) - - -{- -********************************************************************************* -* * - Constraint simplification for rules -* * -*********************************************************************************** - -Note [The SimplifyRule Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example. Consider the following left-hand side of a rule - f (x == y) (y > z) = ... -If we typecheck this expression we get constraints - d1 :: Ord a, d2 :: Eq a -We do NOT want to "simplify" to the LHS - forall x::a, y::a, z::a, d1::Ord a. - f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... -Instead we want - forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. - f ((==) d2 x y) ((>) d1 y z) = ... - -Here is another example: - fromIntegral :: (Integral a, Num b) => a -> b - {-# RULES "foo" fromIntegral = id :: Int -> Int #-} -In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But -we *dont* want to get - forall dIntegralInt. - fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int -because the scsel will mess up RULE matching. Instead we want - forall dIntegralInt, dNumInt. - fromIntegral Int Int dIntegralInt dNumInt = id Int - -Even if we have - g (x == y) (y == z) = .. -where the two dictionaries are *identical*, we do NOT WANT - forall x::a, y::a, z::a, d1::Eq a - f ((==) d1 x y) ((>) d1 y z) = ... -because that will only match if the dict args are (visibly) equal. -Instead we want to quantify over the dictionaries separately. - -In short, simplifyRuleLhs must *only* squash equalities, leaving -all dicts unchanged, with absolutely no sharing. - -Also note that we can't solve the LHS constraints in isolation: -Example foo :: Ord a => a -> a - foo_spec :: Int -> Int - {-# RULE "foo" foo = foo_spec #-} -Here, it's the RHS that fixes the type variable - -HOWEVER, under a nested implication things are different -Consider - f :: (forall a. Eq a => a->a) -> Bool -> ... - {-# RULES "foo" forall (v::forall b. Eq b => b->b). - f b True = ... - #-} -Here we *must* solve the wanted (Eq a) from the given (Eq a) -resulting from skolemising the argument type of g. So we -revert to SimplCheck when going under an implication. - - ---------- So the SimplifyRule Plan is this ----------------------- - -* Step 0: typecheck the LHS and RHS to get constraints from each - -* Step 1: Simplify the LHS and RHS constraints all together in one bag, - but /discarding/ the simplified constraints. We do this only - to discover all unification equalities. - -* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take - advantage of those unifications - -* Setp 3: Partition the LHS constraints into the ones we will - quantify over, and the others. - See Note [RULE quantification over equalities] - -* Step 4: Decide on the type variables to quantify over - -* Step 5: Simplify the LHS and RHS constraints separately, using the - quantified constraints as givens - -Note [Solve order for RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step 1 above, we need to be a bit careful about solve order. -Consider - f :: Int -> T Int - type instance T Int = Bool - - RULE f 3 = True - -From the RULE we get - lhs-constraints: T Int ~ alpha - rhs-constraints: Bool ~ alpha -where 'alpha' is the type that connects the two. If we glom them -all together, and solve the RHS constraint first, we might solve -with alpha := Bool. But then we'd end up with a RULE like - - RULE: f 3 |> (co :: T Int ~ Bool) = True - -which is terrible. We want - - RULE: f 3 = True |> (sym co :: Bool ~ T Int) - -So we are careful to solve the LHS constraints first, and *then* the -RHS constraints. Actually much of this is done by the on-the-fly -constraint solving, so the same order must be observed in -tcRule. - - -Note [RULE quantification over equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Deciding which equalities to quantify over is tricky: - * We do not want to quantify over insoluble equalities (Int ~ Bool) - (a) because we prefer to report a LHS type error - (b) because if such things end up in 'givens' we get a bogus - "inaccessible code" error - - * But we do want to quantify over things like (a ~ F b), where - F is a type function. - -The difficulty is that it's hard to tell what is insoluble! -So we see whether the simplification step yielded any type errors, -and if so refrain from quantifying over *any* equalities. - -Note [Quantifying over coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Equality constraints from the LHS will emit coercion hole Wanteds. -These don't have a name, so we can't quantify over them directly. -Instead, because we really do want to quantify here, invent a new -EvVar for the coercion, fill the hole with the invented EvVar, and -then quantify over the EvVar. Not too tricky -- just some -impedance matching, really. - -Note [Simplify cloned constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this stage, we're simplifying constraints only for insolubility -and for unification. Note that all the evidence is quickly discarded. -We use a clone of the real constraint. If we don't do this, -then RHS coercion-hole constraints get filled in, only to get filled -in *again* when solving the implications emitted from tcRule. That's -terrible, so we avoid the problem by cloning the constraints. - --} - -simplifyRule :: RuleName - -> TcLevel -- Level at which to solve the constraints - -> WantedConstraints -- Constraints from LHS - -> WantedConstraints -- Constraints from RHS - -> TcM ( [EvVar] -- Quantify over these LHS vars - , WantedConstraints -- Residual un-quantified LHS constraints - , TcTyVarSet ) -- Don't default these --- See Note [The SimplifyRule Plan] --- NB: This consumes all simple constraints on the LHS, but not --- any LHS implication constraints. -simplifyRule name tc_lvl lhs_wanted rhs_wanted - = do { - -- Note [The SimplifyRule Plan] step 1 - -- First solve the LHS and *then* solve the RHS - -- Crucially, this performs unifications - -- Why clone? See Note [Simplify cloned constraints] - ; lhs_clone <- cloneWC lhs_wanted - ; rhs_clone <- cloneWC rhs_wanted - ; (dont_default, _) - <- setTcLevel tc_lvl $ - runTcS $ - do { lhs_wc <- solveWanteds lhs_clone - ; _rhs_wc <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - - ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc - -- If lhs_wanteds has - -- (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc]) - -- we want r0 to be non-defaultable; - -- see nonDefaultableTyVarsOfWC. Simplest way to get - -- this is to look at the post-simplified lhs_wc, which - -- will contain (rr[sk] ~ r0[conc)]. An example is in - -- test rep-poly/RepPolyRule1 - ; return dont_default } - - -- Note [The SimplifyRule Plan] step 2 - ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted - ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted - - -- Note [The SimplifyRule Plan] step 3 - ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts) - - ; traceTc "simplifyRule" $ - vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) - , text "lhs_wanted" <+> ppr lhs_wanted - , text "rhs_wanted" <+> ppr rhs_wanted - , text "quant_cts" <+> ppr quant_cts - , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted - , text "dont_default" <+> ppr dont_default - ] - - ; return (quant_evs, residual_lhs_wanted, dont_default) } - - where - mk_quant_ev :: Ct -> TcM EvVar - mk_quant_ev ct - | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct - = case dest of - EvVarDest ev_id -> return ev_id - HoleDest hole -> -- See Note [Quantifying over coercion holes] - do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkCoVarCo ev_id) - ; return ev_id } - mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) - - -getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints) --- Extract all the constraints we can quantify over, --- also returning the depleted WantedConstraints --- --- NB: we must look inside implications, because with --- -fdefer-type-errors we generate implications rather eagerly; --- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732. --- --- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, --- and attempt to solve them from the quantified constraints. That --- nearly works, but fails for a constraint like (d :: Eq Int). --- We /do/ want to quantify over it, but the short-cut solver --- (see GHC.Tc.Solver.Dict Note [Shortcut solving]) ignores the quantified --- and instead solves from the top level. --- --- So we must partition the WantedConstraints ourselves --- Not hard, but tiresome. - -getRuleQuantCts wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) - float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs }) - = ( simple_yes `andCts` implic_yes - , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs }) - where - (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples - (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) - emptyBag implics - - float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) - float_implic skol_tvs yes1 imp - = (yes1 `andCts` yes2, imp { ic_wanted = no }) - where - (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) - new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp - - rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool - rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of - EqPred _ t1 t2 - | not (ok_eq t1 t2) - -> False -- Note [RULE quantification over equalities] - _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs - - ok_eq t1 t2 - | t1 `tcEqType` t2 = False - | otherwise = is_fun_app t1 || is_fun_app t2 - - is_fun_app ty -- ty is of form (F tys) where F is a type function - = case tyConAppTyCon_maybe ty of - Just tc -> isTypeFamilyTyCon tc - Nothing -> False diff --git a/GHC/Tc/Gen/Sig.hs b/GHC/Tc/Gen/Sig.hs --- a/GHC/Tc/Gen/Sig.hs +++ b/GHC/Tc/Gen/Sig.hs @@ -8,887 +8,1685 @@ {-# LANGUAGE TypeFamilies #-} module GHC.Tc.Gen.Sig( - TcSigInfo(..), - TcIdSigInfo(..), TcIdSigInst, - TcPatSynInfo(..), - TcSigFun, - - isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, - completeSigPolyId_maybe, isCompleteHsSig, - lhsSigWcTypeContextSpan, lhsSigTypeContextSpan, - - tcTySigs, tcUserTypeSig, completeSigFromId, - tcInstSig, - - TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, - mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, - addInlinePrags, addInlinePragArity - ) where - -import GHC.Prelude -import GHC.Data.FastString - -import GHC.Driver.DynFlags -import GHC.Driver.Backend - -import GHC.Hs - - -import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) ) -import GHC.Tc.Gen.HsType -import GHC.Tc.Types -import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep ) -import GHC.Tc.Zonk.Type -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType -import GHC.Tc.Validity ( checkValidType ) -import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType ) -import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) -import GHC.Tc.Utils.Env( tcLookupId ) -import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) - -import GHC.Core( hasSomeUnfolding ) -import GHC.Core.Type ( mkTyVarBinders ) -import GHC.Core.Multiplicity -import GHC.Core.TyCo.Rep( mkNakedFunTy ) - -import GHC.Types.Error -import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike ) -import GHC.Types.Id ( Id, idName, idType, setInlinePragma - , mkLocalId, realIdUnfolding ) -import GHC.Types.Basic -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.SrcLoc - -import GHC.Builtin.Names( mkUnboundName ) -import GHC.Unit.Module( getModule ) - -import GHC.Utils.Misc as Utils ( singleton ) -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import GHC.Data.Maybe( orElse, whenIsJust ) - -import Data.Maybe( mapMaybe ) -import qualified Data.List.NonEmpty as NE -import Control.Monad( unless ) - - -{- ------------------------------------------------------------- - Note [Overview of type signatures] ----------------------------------------------------------------- -Type signatures, including partial signatures, are jolly tricky, -especially on value bindings. Here's an overview. - - f :: forall a. [a] -> [a] - g :: forall b. _ -> b - - f = ...g... - g = ...f... - -* HsSyn: a signature in a binding starts off as a TypeSig, in - type HsBinds.Sig - -* When starting a mutually recursive group, like f/g above, we - call tcTySig on each signature in the group. - -* tcTySig: Sig -> TcIdSigInfo - - For a /complete/ signature, like 'f' above, tcTySig kind-checks - the HsType, producing a Type, and wraps it in a CompleteSig, and - extend the type environment with this polymorphic 'f'. - - - For a /partial/signature, like 'g' above, tcTySig does nothing - Instead it just wraps the pieces in a PartialSig, to be handled - later. - -* tcInstSig: TcIdSigInfo -> TcIdSigInst - In tcMonoBinds, when looking at an individual binding, we use - tcInstSig to instantiate the signature forall's in the signature, - and attribute that instantiated (monomorphic) type to the - binder. You can see this in GHC.Tc.Gen.Bind.tcLhsId. - - The instantiation does the obvious thing for complete signatures, - but for /partial/ signatures it starts from the HsSyn, so it - has to kind-check it etc: tcHsPartialSigType. It's convenient - to do this at the same time as instantiation, because we can - make the wildcards into unification variables right away, rather - than somehow quantifying over them. And the "TcLevel" of those - unification variables is correct because we are in tcMonoBinds. - - -Note [Binding scoped type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type variables *brought into lexical scope* by a type signature -may be a subset of the *quantified type variables* of the signatures, -for two reasons: - -* With kind polymorphism a signature like - f :: forall f a. f a -> f a - may actually give rise to - f :: forall k. forall (f::k -> *) (a:k). f a -> f a - So the sig_tvs will be [k,f,a], but only f,a are scoped. - NB: the scoped ones are not necessarily the *initial* ones! - -* Even aside from kind polymorphism, there may be more instantiated - type variables than lexically-scoped ones. For example: - type T a = forall b. b -> (a,b) - f :: forall c. T c - Here, the signature for f will have one scoped type variable, c, - but two instantiated type variables, c' and b'. - -However, all of this only applies to the renamer. The typechecker -just puts all of them into the type environment; any lexical-scope -errors were dealt with by the renamer. - --} - - -{- ********************************************************************* -* * - Utility functions for TcSigInfo -* * -********************************************************************* -} - -tcIdSigName :: TcIdSigInfo -> Name -tcIdSigName (CompleteSig { sig_bndr = id }) = idName id -tcIdSigName (PartialSig { psig_name = n }) = n - -tcSigInfoName :: TcSigInfo -> Name -tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi -tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi - -completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId -completeSigPolyId_maybe sig - | TcIdSig sig_info <- sig - , CompleteSig { sig_bndr = id } <- sig_info = Just id - | otherwise = Nothing - - -{- ********************************************************************* -* * - Typechecking user signatures -* * -********************************************************************* -} - -tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) -tcTySigs hs_sigs - = checkNoErrs $ - do { -- Fail if any of the signatures is duff - -- Hence mapAndReportM - -- See Note [Fail eagerly on bad signatures] - ty_sigs_s <- mapAndReportM tcTySig hs_sigs - - ; let ty_sigs = concat ty_sigs_s - poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs - -- The returned [TcId] are the ones for which we have - -- a complete type signature. - -- See Note [Complete and partial type signatures] - env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] - - ; return (poly_ids, lookupNameEnv env) } - -tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (XSig (IdSig id))) - = do { let ctxt = FunSigCtxt (idName id) NoRRC - -- NoRRC: do not report redundant constraints - -- The user has no control over the signature! - sig = completeSigFromId ctxt id - ; return [TcIdSig sig] } - -tcTySig (L loc (TypeSig _ names sig_ty)) - = setSrcSpanA loc $ - do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) - | L _ name <- names ] - ; return (map TcIdSig sigs) } - -tcTySig (L loc (PatSynSig _ names sig_ty)) - = setSrcSpanA loc $ - do { tpsigs <- sequence [ tcPatSynSig name sig_ty - | L _ name <- names ] - ; return (map TcPatSynSig tpsigs) } - -tcTySig _ = return [] - - -tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name - -> TcM TcIdSigInfo --- A function or expression type signature --- Returns a fully quantified type signature; even the wildcards --- are quantified with ordinary skolems that should be instantiated --- --- The SrcSpan is what to declare as the binding site of the --- any skolems in the signature. For function signatures we --- use the whole `f :: ty' signature; for expression signatures --- just the type part. --- --- Just n => Function type signature name :: type --- Nothing => Expression type signature :: type -tcUserTypeSig loc hs_sig_ty mb_name - | isCompleteHsSig hs_sig_ty - = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty - ; traceTc "tcuser" (ppr sigma_ty) - ; return $ - CompleteSig { sig_bndr = mkLocalId name ManyTy sigma_ty - -- We use `Many' as the multiplicity here, - -- as if this identifier corresponds to - -- anything, it is a top-level - -- definition. Which are all unrestricted in - -- the current implementation. - , sig_ctxt = ctxt_rrc -- Report redundant constraints - , sig_loc = loc } } - -- Location of the in f :: - - -- Partial sig with wildcards - | otherwise - = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty - , sig_ctxt = ctxt_no_rrc, sig_loc = loc }) - where - name = case mb_name of - Just n -> n - Nothing -> mkUnboundName (mkVarOccFS (fsLit "")) - - ctxt_rrc = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty) - ctxt_no_rrc = ctxt_fn NoRRC - - ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt - ctxt_fn rcc = case mb_name of - Just n -> FunSigCtxt n rcc - Nothing -> ExprSigCtxt rcc - -lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints --- | Find the location of the top-level context of a HsType. For example: --- --- @ --- forall a b. (Eq a, Ord b) => blah --- ^^^^^^^^^^^^^ --- @ --- If there is none, return Nothing -lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType - -lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints -lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty - where - go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it! - go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty -- Look under foralls - go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens - go _ = NoRRC -- Did not find it - -completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo --- Used for instance methods and record selectors -completeSigFromId ctxt id - = CompleteSig { sig_bndr = id - , sig_ctxt = ctxt - , sig_loc = getSrcSpan id } - -isCompleteHsSig :: LHsSigWcType GhcRn -> Bool --- ^ If there are no wildcards, return a LHsSigWcType -isCompleteHsSig (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty }) - = null wcs && no_anon_wc_sig_ty hs_sig_ty - -no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool -no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) - = all no_anon_wc_tvb (hsOuterExplicitBndrs outer_bndrs) - && no_anon_wc_ty body - -no_anon_wc_ty :: LHsType GhcRn -> Bool -no_anon_wc_ty lty = go lty - where - go (L _ ty) = case ty of - HsWildCardTy _ -> False - HsAppTy _ ty1 ty2 -> go ty1 && go ty2 - HsAppKindTy _ ty _ ki -> go ty && go ki - HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && go (arrowToHsType w) - HsListTy _ ty -> go ty - HsTupleTy _ _ tys -> gos tys - HsSumTy _ tys -> gos tys - HsOpTy _ _ ty1 _ ty2 -> go ty1 && go ty2 - HsParTy _ ty -> go ty - HsIParamTy _ _ ty -> go ty - HsKindSig _ ty kind -> go ty && go kind - HsDocTy _ ty _ -> go ty - HsBangTy _ _ ty -> go ty - HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_tele = tele - , hst_body = ty } -> no_anon_wc_tele tele - && go ty - HsQualTy { hst_ctxt = ctxt - , hst_body = ty } -> gos (unLoc ctxt) && go ty - HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty - HsSpliceTy (HsUntypedSpliceNested _) _ -> True - HsTyLit{} -> True - HsTyVar{} -> True - HsStarTy{} -> True - XHsType{} -> True -- HsCoreTy, which does not have any wildcard - - gos = all go - -no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool -no_anon_wc_tele tele = case tele of - HsForAllVis { hsf_vis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs - 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 - -{- Note [Fail eagerly on bad signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a type signature is wrong, fail immediately: - - * the type sigs may bind type variables, so proceeding without them - can lead to a cascade of errors - - * the type signature might be ambiguous, in which case checking - the code against the signature will give a very similar error - to the ambiguity error. - -ToDo: this means we fall over if any top-level type signature in the -module is wrong, because we typecheck all the signatures together -(see GHC.Tc.Gen.Bind.tcValBinds). Moreover, because of top-level -captureTopConstraints, only insoluble constraints will be reported. -We typecheck all signatures at the same time because a signature -like f,g :: blah might have f and g from different SCCs. - -So it's a bit awkward to get better error recovery, and no one -has complained! --} - -{- ********************************************************************* -* * - Type checking a pattern synonym signature -* * -************************************************************************ - -Note [Pattern synonym signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Pattern synonym signatures are surprisingly tricky (see #11224 for example). -In general they look like this: - - pattern P :: forall univ_tvs. req_theta - => forall ex_tvs. prov_theta - => arg1 -> .. -> argn -> res_ty - -For parsing and renaming we treat the signature as an ordinary LHsSigType. - -Once we get to type checking, we decompose it into its parts, in tcPatSynSig. - -* Note that 'forall univ_tvs' and 'req_theta =>' - and 'forall ex_tvs' and 'prov_theta =>' - are all optional. We gather the pieces at the top of tcPatSynSig - -* Initially the implicitly-bound tyvars (added by the renamer) include both - universal and existential vars. - -* After we kind-check the pieces and convert to Types, we do kind generalisation. - -Note [Report unsolved equalities in tcPatSynSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important that we solve /all/ the equalities in a pattern -synonym signature, because we are going to zonk the signature to -a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that -fails if there are un-filled-in coercion variables mentioned -in the type (#15694). - -So we solve all the equalities we can, and report any unsolved ones, -rather than leaving them in the ambient constraints to be solved -later. Pattern synonyms are top-level, so there's no problem with -completely solving them. --} - -tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo --- See Note [Pattern synonym signatures] --- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType -tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty})) - | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty - , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 - = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - - ; skol_info <- mkSkolemInfo (DataConSkol name) - ; (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) } - - ; let implicit_tvs :: [TcTyVar] - univ_bndrs :: [TcInvisTVBinder] - (implicit_tvs, univ_bndrs) = case outer_bndrs of - HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, []) - HsOuterExplicit{hso_xexplicit = univ_bndrs} -> ([], univ_bndrs) - - ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs - - -- Kind generalisation - ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs - req ex_bndrs prov body_ty - ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) - ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty - ; reportUnsolvedEqualities skol_info kvs tclvl wanted - -- See Note [Report unsolved equalities in tcPatSynSig] - - -- These are /signatures/ so we zonk to squeeze out any kind - -- unification variables. Do this after kindGeneralizeAll which may - -- default kind variables to *. - ; (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, req, prov, body_ty) <- - initZonkEnv NoFlexi $ - runZonkBndrT (zonkTyVarBindersX (mkTyVarBinders InferredSpec kvs)) $ \ kv_bndrs -> - runZonkBndrT (zonkTyVarBindersX implicit_bndrs) $ \ implicit_bndrs -> - runZonkBndrT (zonkTyVarBindersX univ_bndrs) $ \ univ_bndrs -> - do { req <- zonkTcTypesToTypesX req - ; runZonkBndrT (zonkTyVarBindersX ex_bndrs) $ \ ex_bndrs -> - do { prov <- zonkTcTypesToTypesX prov - ; body_ty <- zonkTcTypeToTypeX body_ty - ; return (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, - req, prov, body_ty) } } - - -- Now do validity checking - ; checkValidType ctxt $ - build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty - - -- Neither argument types nor the return type may be representation polymorphic. - -- This is because, when creating a matcher: - -- - the argument types become the binder types (see test RepPolyPatySynArg), - -- - the return type becomes the scrutinee type (see test RepPolyPatSynRes). - ; let (arg_tys, res_ty) = tcSplitFunTys body_ty - ; mapM_ - (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty) - arg_tys - ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty - - ; traceTc "tcTySig }" $ - vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs) - , text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs) - , text "univ_tvs" <+> ppr_tvs (binderVars univ_bndrs) - , text "req" <+> ppr req - , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs) - , text "prov" <+> ppr prov - , text "body_ty" <+> ppr body_ty ] - ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs - , patsig_univ_bndrs = univ_bndrs - , patsig_req = req - , patsig_ex_bndrs = ex_bndrs - , patsig_prov = prov - , patsig_body_ty = body_ty }) } - where - ctxt = PatSynCtxt name - - build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body - = mkInvisForAllTys implicit_bndrs $ - mkInvisForAllTys univ_bndrs $ - mk_naked_phi_ty req $ - mkInvisForAllTys ex_bndrs $ - mk_naked_phi_ty prov $ - body - - -- Use mk_naked_phi_ty because we call build_patsyn_type /before zonking/ - -- just before kindGeneraliseAll, and the invariants that mkPhiTy checks - -- don't hold of the un-zonked types. #22521 was a case in point. - -- (We also called build_patsyn_type on the fully zonked type, so mkPhiTy - -- would work; but it doesn't seem worth duplicating the code.) - mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType - mk_naked_phi_ty theta body = foldr (mkNakedFunTy invisArgTypeLike) body theta - -ppr_tvs :: [TyVar] -> SDoc -ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) - | tv <- tvs]) - - -{- ********************************************************************* -* * - Instantiating user signatures -* * -********************************************************************* -} - - -tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst --- Instantiate a type signature; only used with plan InferGen -tcInstSig hs_sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id) - -- See Note [Pattern bindings and complete signatures] - - ; return (TISI { sig_inst_sig = hs_sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = [] - , sig_inst_wcx = Nothing - , sig_inst_theta = theta - , sig_inst_tau = tau }) } - -tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty - , sig_ctxt = ctxt - , sig_loc = loc }) - = setSrcSpan loc $ -- Set the binding site of the tyvars - do { traceTc "Staring partial sig {" (ppr hs_sig) - ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty - -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType - - ; let inst_sig = TISI { sig_inst_sig = hs_sig - , sig_inst_skols = tv_prs - , sig_inst_wcs = wcs - , sig_inst_wcx = wcx - , sig_inst_theta = theta - , sig_inst_tau = tau } - ; traceTc "End partial sig }" (ppr inst_sig) - ; return inst_sig } - - -{- Note [Pattern bindings and complete signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a = MkT a a - f :: forall a. a->a - g :: forall b. b->b - MkT f g = MkT (\x->x) (\y->y) -Here we'll infer a type from the pattern of 'T a', but if we feed in -the signature types for f and g, we'll end up unifying 'a' and 'b' - -So we instantiate f and g's signature with TyVarTv skolems -(newMetaTyVarTyVars) that can unify with each other. If too much -unification takes place, we'll find out when we do the final -impedance-matching check in GHC.Tc.Gen.Bind.mkExport - -See Note [TyVarTv] in GHC.Tc.Utils.TcMType - -None of this applies to a function binding with a complete -signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.tcPolyCheck. --} - -{- ********************************************************************* -* * - Pragmas and PragEnv -* * -********************************************************************* -} - -type TcPragEnv = NameEnv [LSig GhcRn] - -emptyPragEnv :: TcPragEnv -emptyPragEnv = emptyNameEnv - -lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] -lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] - -extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv -extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) Utils.singleton prag_fn n sig - ---------------- -mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv -mkPragEnv sigs binds - = foldl' extendPragEnv emptyNameEnv prs - where - prs = mapMaybe get_sig sigs - - get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) - get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig) - get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig) - get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig) - get_sig _ = Nothing - - add_arity n sig -- Adjust inl_sat field to match visible arity of function - = case lookupNameEnv ar_env n of - Just ar -> addInlinePragArity ar sig - Nothing -> sig -- See Note [Pattern synonym inline arity] - - -- ar_env maps a local to the arity of its definition - ar_env :: NameEnv Arity - ar_env = foldr lhsBindArity emptyNameEnv binds - -addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn -addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl)) -addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl)) -addInlinePragArity _ sig = sig - -add_inl_arity :: Arity -> InlinePragma -> InlinePragma -add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec }) - | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE - = prag { inl_sat = Just ar } - | otherwise - = prag - -lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity -lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env - = extendNameEnv env (unLoc id) (matchGroupArity ms) -lhsBindArity _ env = env -- PatBind/VarBind - - ------------------ -addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId -addInlinePrags poly_id prags_for_me - | inl@(L _ prag) : inls <- inl_prags - = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) - ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` prag) } - | otherwise - = return poly_id - where - inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] - - warn_multiple_inlines _ [] = return () - - warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) - | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 - , noUserInlineSpec (inlinePragmaSpec prag1) - = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop - -- and inl2 is a user NOINLINE pragma; we don't want to complain - warn_multiple_inlines inl2 inls - | otherwise - = setSrcSpanA loc $ - let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls) - in addDiagnosticTc dia - - -{- Note [Pattern synonym inline arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - {-# INLINE P #-} - pattern P x = (x, True) - -The INLINE pragma attaches to both the /matcher/ and the /builder/ for -the pattern synonym; see Note [Pragmas for pattern synonyms] in -GHC.Tc.TyCl.PatSyn. But they have different inline arities (i.e. number -of binders to which we apply the function before inlining), and we don't -know what those arities are yet. So for pattern synonyms we don't set -the inl_sat field yet; instead we do so (via addInlinePragArity) in -GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind. - -It's a bit messy that we set the arities in different ways. Perhaps we -should add the arity later for all binders. But it works fine like this. --} - - -{- ********************************************************************* -* * - SPECIALISE pragmas -* * -************************************************************************ - -Note [Handling SPECIALISE pragmas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The basic idea is this: - - foo :: Num a => a -> b -> a - {-# SPECIALISE foo :: Int -> b -> Int #-} - -We check that - (forall a b. Num a => a -> b -> a) - is more polymorphic than - forall b. Int -> b -> Int -(for which we could use tcSubType, but see below), generating a HsWrapper -to connect the two, something like - wrap = /\b. Int b dNumInt -This wrapper is put in the TcSpecPrag, in the ABExport record of -the AbsBinds. - - - f :: (Eq a, Ix b) => a -> b -> Bool - {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} - f = - -From this the typechecker generates - - AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds - - SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX - -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) - -From these we generate: - - Rule: forall p, q, (dp:Ix p), (dq:Ix q). - f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq - - Spec bind: f_spec = wrap_fn - -Note that - - * The LHS of the rule may mention dictionary *expressions* (eg - $dfIxPair dp dq), and that is essential because the dp, dq are - needed on the RHS. - - * The RHS of f_spec, has a *copy* of 'binds', so that it - can fully specialise it. - -From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: - - f_spec :: Int -> b -> Int - f_spec = wrap - - RULE: forall b (d:Num b). f b d = f_spec b - -The RULE is generated by taking apart the HsWrapper, which is a little -delicate, but works. - -Some wrinkles - -1. In tcSpecWrapper, rather than calling tcSubType, we directly call - skolemise/instantiate. That is mainly because of wrinkle (2). - - Historical note: in the past, tcSubType did co/contra stuff, which - could generate too complex a LHS for the RULE, which was another - reason for not using tcSubType. But that reason has gone away - with simple subsumption (#17775). - -2. We need to take care with type families (#5821). Consider - type instance F Int = Bool - f :: Num a => a -> F a - {-# SPECIALISE foo :: Int -> Bool #-} - - We *could* try to generate an f_spec with precisely the declared type: - f_spec :: Int -> Bool - f_spec = Int dNumInt |> co - - RULE: forall d. f Int d = f_spec |> sym co - - but the 'co' and 'sym co' are (a) playing no useful role, and (b) are - hard to generate. At all costs we must avoid this: - RULE: forall d. f Int d |> co = f_spec - because the LHS will never match (indeed it's rejected in - decomposeRuleLhs). - - So we simply do this: - - Generate a constraint to check that the specialised type (after - skolemisation) is equal to the instantiated function type. - - But *discard* the evidence (coercion) for that constraint, - so that we ultimately generate the simpler code - f_spec :: Int -> F Int - f_spec = Int dNumInt - - RULE: forall d. f Int d = f_spec - You can see this discarding happening in tcSpecPrag - -3. Note that the HsWrapper can transform *any* function with the right - type prefix - forall ab. (Eq a, Ix b) => XXX - regardless of XXX. It's sort of polymorphic in XXX. This is - useful: we use the same wrapper to transform each of the class ops, as - well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags --} - -tcSpecPrags :: Id -> [LSig GhcRn] - -> TcM [LTcSpecPrag] --- Add INLINE and SPECIALSE pragmas --- INLINE prags are added to the (polymorphic) Id directly --- SPECIALISE prags are passed to the desugarer via TcSpecPrags --- Pre-condition: the poly_id is zonked --- Reason: required by tcSubExp -tcSpecPrags poly_id prag_sigs - = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; whenIsJust (NE.nonEmpty bad_sigs) warn_discarded_sigs - ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs - ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } - where - spec_sigs = filter isSpecLSig prag_sigs - bad_sigs = filter is_bad_sig prag_sigs - is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - - warn_discarded_sigs bad_sigs_ne - = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne - in addDiagnosticTc dia - --------------- -tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] -tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) --- See Note [Handling SPECIALISE pragmas] --- --- The Name fun_name in the SpecSig may not be the same as that of the poly_id --- Example: SPECIALISE for a class method: the Name in the SpecSig is --- for the selector Id, but the poly_id is something like $cop --- However we want to use fun_name in the error message, since that is --- what the user wrote (#8537) - = addErrCtxt (spec_ctxt prag) $ - do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ - TcRnNonOverloadedSpecialisePragma fun_name - -- Note [SPECIALISE pragmas] - ; spec_prags <- mapM tc_one hs_tys - ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) - ; return spec_prags } - where - name = idName poly_id - poly_ty = idType poly_id - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) - - tc_one hs_ty - = do { spec_ty <- tcHsSigType (FunSigCtxt name NoRRC) hs_ty - ; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty - ; return (SpecPrag poly_id wrap inl) } - -tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) - --------------- -tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper --- A simpler variant of tcSubType, used for SPECIALISE pragmas --- See Note [Handling SPECIALISE pragmas], wrinkle 1 -tcSpecWrapper ctxt poly_ty spec_ty - = do { (sk_wrap, inst_wrap) - <- tcTopSkolemise ctxt spec_ty $ \ spec_tau -> - do { (inst_wrap, tau) <- topInstantiate orig poly_ty - ; _ <- unifyType Nothing spec_tau tau - -- Deliberately ignore the evidence - -- See Note [Handling SPECIALISE pragmas], - -- wrinkle (2) - ; return inst_wrap } - ; return (sk_wrap <.> inst_wrap) } - where - orig = SpecPragOrigin ctxt - --------------- -tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] --- SPECIALISE pragmas for imported things -tcImpPrags prags - = do { this_mod <- getModule - ; dflags <- getDynFlags - ; if (not_specialising dflags) then - return [] - else do - { pss <- mapAndRecoverM (wrapLocMA tcImpSpec) - [L loc (name,prag) - | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] - ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } } - where - -- Ignore SPECIALISE pragmas for imported things - -- when we aren't specialising, or when we aren't generating - -- code. The latter happens when Haddocking the base library; - -- we don't want complaints about lack of INLINABLE pragmas - not_specialising dflags = - not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags)) - -tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] -tcImpSpec (name, prag) - = do { id <- tcLookupId name - ; if hasSomeUnfolding (realIdUnfolding id) - -- See Note [SPECIALISE pragmas for imported Ids] - then tcSpecPrag id prag - else do { let dia = TcRnSpecialiseNotVisible name - ; addDiagnosticTc dia - ; return [] } } - -{- Note [SPECIALISE pragmas for imported Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An imported Id may or may not have an unfolding. If not, we obviously -can't specialise it here; indeed the desugar falls over (#18118). - -We used to test whether it had a user-specified INLINABLE pragma but, -because of Note [Worker/wrapper for INLINABLE functions] in -GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with -a wrapper that has no pragma, just an unfolding (#19246). So now -we just test whether the function has an unfolding. - -There's a risk that a pragma-free function may have an unfolding now -(because it is fairly small), and then gets a bit bigger, and no -longer has an unfolding in the future. But then you'll get a helpful -error message suggesting an INLINABLE pragma, which you can follow. -That seems enough for now. --} + TcSigInfo(..), TcIdSig(..), TcSigFun, + + isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc, + completeSigPolyId_maybe, isCompleteHsSig, + lhsSigWcTypeContextSpan, lhsSigTypeContextSpan, + + tcTySigs, tcUserTypeSig, completeSigFromId, + tcInstSig, + + TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv, + mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, + addInlinePrags, addInlinePragArity, + + tcRules + ) where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.Driver.DynFlags +import GHC.Driver.Backend + +import GHC.Hs + +import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcInferRho, tcCheckMonoExpr ) + +import GHC.Tc.Errors.Types +import GHC.Tc.Gen.HsType +import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX + , emitResidualConstraints ) +import GHC.Tc.Solver.Solve( solveWanteds ) +import GHC.Tc.Solver.Monad( runTcS, setTcSMode, TcSMode(..), vanillaTcSMode, runTcSWithEvBinds ) +import GHC.Tc.Validity ( checkValidType ) + +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Unify( DeepSubsumptionFlag(..), tcSkolemise, unifyType, buildImplicationFor ) +import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) +import GHC.Tc.Utils.Env + +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint + +import GHC.Tc.Zonk.TcType +import GHC.Tc.Zonk.Type + +import GHC.Core( hasSomeUnfolding ) +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.Predicate +import GHC.Core.TyCo.Rep( mkNakedFunTy ) +import GHC.Core.TyCon( isTypeFamilyTyCon ) + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id ( idName, idType, setInlinePragma + , mkLocalId, realIdUnfolding ) +import GHC.Types.Basic +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.SrcLoc + +import GHC.Builtin.Names( mkUnboundName ) +import GHC.Unit.Module( Module, getModule ) + +import GHC.Utils.Misc as Utils ( singleton ) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.Bag +import GHC.Data.Maybe( orElse, whenIsJust ) + +import Control.Monad( unless ) +import Data.Foldable ( toList ) +import qualified Data.List.NonEmpty as NE +import Data.Maybe( mapMaybe ) + +{- ------------------------------------------------------------- + Note [Overview of type signatures] +---------------------------------------------------------------- +Type signatures, including partial signatures, are jolly tricky, +especially on value bindings. Here's an overview. + + f :: forall a. [a] -> [a] + g :: forall b. _ -> b + + f = ...g... + g = ...f... + +* HsSyn: a signature in a binding starts off as a TypeSig, in + type HsBinds.Sig + +* When starting a mutually recursive group, like f/g above, we + call tcTySig on each signature in the group. + +* tcTySig: Sig -> TcIdSig + - For a /complete/ signature, like 'f' above, tcTySig kind-checks + the HsType, producing a Type, and wraps it in a TcCompleteSig, and + extend the type environment with this polymorphic 'f'. + + - For a /partial/signature, like 'g' above, tcTySig does nothing + Instead it just wraps the pieces in a PartialSig, to be handled + later. + +* tcInstSig: TcIdSig -> TcIdSigInst + In tcMonoBinds, when looking at an individual binding, we use + tcInstSig to instantiate the signature forall's in the signature, + and attribute that instantiated (monomorphic) type to the + binder. You can see this in GHC.Tc.Gen.Bind.tcLhsId. + + The instantiation does the obvious thing for complete signatures, + but for /partial/ signatures it starts from the HsSyn, so it + has to kind-check it etc: tcHsPartialSigType. It's convenient + to do this at the same time as instantiation, because we can + make the wildcards into unification variables right away, rather + than somehow quantifying over them. And the "TcLevel" of those + unification variables is correct because we are in tcMonoBinds. + + +Note [Binding scoped type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type variables *brought into lexical scope* by a type signature +may be a subset of the *quantified type variables* of the signatures, +for two reasons: + +* With kind polymorphism a signature like + f :: forall f a. f a -> f a + may actually give rise to + f :: forall k. forall (f::k -> *) (a:k). f a -> f a + So the sig_tvs will be [k,f,a], but only f,a are scoped. + NB: the scoped ones are not necessarily the *initial* ones! + +* Even aside from kind polymorphism, there may be more instantiated + type variables than lexically-scoped ones. For example: + type T a = forall b. b -> (a,b) + f :: forall c. T c + Here, the signature for f will have one scoped type variable, c, + but two instantiated type variables, c' and b'. + +However, all of this only applies to the renamer. The typechecker +just puts all of them into the type environment; any lexical-scope +errors were dealt with by the renamer. + +-} + +{- ********************************************************************* +* * + Typechecking user signatures +* * +********************************************************************* -} + +tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun) +tcTySigs hs_sigs + = checkNoErrs $ + do { -- Fail if any of the signatures is duff + -- Hence mapAndReportM + -- See Note [Fail eagerly on bad signatures] + ty_sigs_s <- mapAndReportM tcTySig hs_sigs + + ; let ty_sigs = concat ty_sigs_s + poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs + -- The returned [TcId] are the ones for which we have + -- a complete type signature. + -- See Note [Complete and partial type signatures] + env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs] + + ; return (poly_ids, lookupNameEnv env) } + +tcTySig :: LSig GhcRn -> TcM [TcSigInfo] +tcTySig (L _ (XSig (IdSig id))) + = do { let ctxt = FunSigCtxt (idName id) NoRRC + -- NoRRC: do not report redundant constraints + -- The user has no control over the signature! + sig = completeSigFromId ctxt id + ; return [TcIdSig (TcCompleteSig sig)] } + +tcTySig (L loc (TypeSig _ names sig_ty)) + = setSrcSpanA loc $ + do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name) + | L _ name <- names ] + ; return (map TcIdSig sigs) } + +tcTySig (L loc (PatSynSig _ names sig_ty)) + = setSrcSpanA loc $ + do { tpsigs <- sequence [ tcPatSynSig name sig_ty + | L _ name <- names ] + ; return (map TcPatSynSig tpsigs) } + +tcTySig _ = return [] + + +tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name -> TcM TcIdSig +-- A function or expression type signature +-- Returns a fully quantified type signature; even the wildcards +-- are quantified with ordinary skolems that should be instantiated +-- +-- The SrcSpan is what to declare as the binding site of the +-- any skolems in the signature. For function signatures we +-- use the whole `f :: ty' signature; for expression signatures +-- just the type part. +-- +-- Just n => Function type signature name :: type +-- Nothing => Expression type signature :: type +tcUserTypeSig loc hs_sig_ty mb_name + | isCompleteHsSig hs_sig_ty + = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty + ; traceTc "tcuser" (ppr sigma_ty) + ; return $ TcCompleteSig $ + CSig { sig_bndr = mkLocalId name ManyTy sigma_ty + -- We use `Many' as the multiplicity here, + -- as if this identifier corresponds to + -- anything, it is a top-level + -- definition. Which are all unrestricted in + -- the current implementation. + , sig_ctxt = ctxt_rrc -- Report redundant constraints + , sig_loc = loc } } -- Location of the in f :: + + -- Partial sig with wildcards + | otherwise + = return $ TcPartialSig $ + PSig { psig_name = name, psig_hs_ty = hs_sig_ty + , psig_ctxt = ctxt_no_rrc, psig_loc = loc } + where + name = case mb_name of + Just n -> n + Nothing -> mkUnboundName (mkVarOccFS (fsLit "")) + + ctxt_rrc = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty) + ctxt_no_rrc = ctxt_fn NoRRC + + ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt + ctxt_fn rcc = case mb_name of + Just n -> FunSigCtxt n rcc + Nothing -> ExprSigCtxt rcc + +lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints +-- | Find the location of the top-level context of a HsType. For example: +-- +-- @ +-- forall a b. (Eq a, Ord b) => blah +-- ^^^^^^^^^^^^^ +-- @ +-- If there is none, return Nothing +lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType + +lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints +lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty + where + go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it! + go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty -- Look under foralls + go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens + go _ = NoRRC -- Did not find it + +completeSigFromId :: UserTypeCtxt -> Id -> TcCompleteSig +-- Used for instance methods and record selectors +completeSigFromId ctxt id + = CSig { sig_bndr = id + , sig_ctxt = ctxt + , sig_loc = getSrcSpan id } + +isCompleteHsSig :: LHsSigWcType GhcRn -> Bool +-- ^ If there are no wildcards, return a LHsSigWcType +isCompleteHsSig (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty }) + = null wcs && no_anon_wc_sig_ty hs_sig_ty + +no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool +no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) + = all no_anon_wc_tvb (hsOuterExplicitBndrs outer_bndrs) + && no_anon_wc_ty body + +no_anon_wc_ty :: LHsType GhcRn -> Bool +no_anon_wc_ty lty = go lty + where + go (L _ ty) = case ty of + HsWildCardTy _ -> False + HsAppTy _ ty1 ty2 -> go ty1 && go ty2 + HsAppKindTy _ ty ki -> go ty && go ki + HsFunTy _ w ty1 ty2 -> go ty1 && go ty2 && all go (multAnnToHsType w) + HsListTy _ ty -> go ty + HsTupleTy _ _ tys -> gos tys + HsSumTy _ tys -> gos tys + HsOpTy _ _ ty1 _ ty2 -> go ty1 && go ty2 + HsParTy _ ty -> go ty + HsIParamTy _ _ ty -> go ty + HsKindSig _ ty kind -> go ty && go kind + HsDocTy _ ty _ -> go ty + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ _ tys -> gos tys + HsForAllTy { hst_tele = tele + , hst_body = ty } -> no_anon_wc_tele tele + && go ty + HsQualTy { hst_ctxt = ctxt + , hst_body = ty } -> gos (unLoc ctxt) && go ty + HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty + HsSpliceTy (HsUntypedSpliceNested _) _ -> True + HsTyLit{} -> True + HsTyVar{} -> True + HsStarTy{} -> True + XHsType{} -> True -- HsCoreTy, which does not have any wildcard + + gos = all go + +no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool +no_anon_wc_tele tele = case tele of + HsForAllVis { hsf_vis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs + 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 hsBndrKind tvb of + HsBndrNoKind _ -> True + HsBndrKind _ ki -> no_anon_wc_ty ki + +{- Note [Fail eagerly on bad signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a type signature is wrong, fail immediately: + + * the type sigs may bind type variables, so proceeding without them + can lead to a cascade of errors + + * the type signature might be ambiguous, in which case checking + the code against the signature will give a very similar error + to the ambiguity error. + +ToDo: this means we fall over if any top-level type signature in the +module is wrong, because we typecheck all the signatures together +(see GHC.Tc.Gen.Bind.tcValBinds). Moreover, because of top-level +captureTopConstraints, only insoluble constraints will be reported. +We typecheck all signatures at the same time because a signature +like f,g :: blah might have f and g from different SCCs. + +So it's a bit awkward to get better error recovery, and no one +has complained! +-} + +{- ********************************************************************* +* * + Type checking a pattern synonym signature +* * +************************************************************************ + +Note [Pattern synonym signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Pattern synonym signatures are surprisingly tricky (see #11224 for example). +In general they look like this: + + pattern P :: forall univ_tvs. req_theta + => forall ex_tvs. prov_theta + => arg1 -> .. -> argn -> res_ty + +For parsing and renaming we treat the signature as an ordinary LHsSigType. + +Once we get to type checking, we decompose it into its parts, in tcPatSynSig. + +* Note that 'forall univ_tvs' and 'req_theta =>' + and 'forall ex_tvs' and 'prov_theta =>' + are all optional. We gather the pieces at the top of tcPatSynSig + +* Initially the implicitly-bound tyvars (added by the renamer) include both + universal and existential vars. + +* After we kind-check the pieces and convert to Types, we do kind generalisation. + +Note [Report unsolved equalities in tcPatSynSig] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that we solve /all/ the equalities in a pattern +synonym signature, because we are going to zonk the signature to +a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that +fails if there are un-filled-in coercion variables mentioned +in the type (#15694). + +So we solve all the equalities we can, and report any unsolved ones, +rather than leaving them in the ambient constraints to be solved +later. Pattern synonyms are top-level, so there's no problem with +completely solving them. +-} + +tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynSig +-- See Note [Pattern synonym signatures] +-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType +tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty})) + | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty + , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 + = do { traceTc "tcPatSynSig 1" (ppr sig_ty) + + ; skol_info <- mkSkolemInfo (DataConSkol name) + ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty)))) + <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $ + -- See Note [Report unsolved equalities in tcPatSynSig] + 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] + (implicit_tvs, univ_bndrs) = case outer_bndrs of + HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, []) + HsOuterExplicit{hso_xexplicit = univ_bndrs} -> ([], univ_bndrs) + + ; implicit_tvs <- zonkAndScopedSort implicit_tvs + ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs + + -- Kind generalisation + ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs + req ex_bndrs prov body_ty + ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) + ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty + ; reportUnsolvedEqualities skol_info kvs tclvl wanted + -- See Note [Report unsolved equalities in tcPatSynSig] + + -- These are /signatures/ so we zonk to squeeze out any kind + -- unification variables. Do this after kindGeneralizeAll which may + -- default kind variables to *. + ; (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, req, prov, body_ty) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX (mkTyVarBinders InferredSpec kvs)) $ \ kv_bndrs -> + runZonkBndrT (zonkTyVarBindersX implicit_bndrs) $ \ implicit_bndrs -> + runZonkBndrT (zonkTyVarBindersX univ_bndrs) $ \ univ_bndrs -> + do { req <- zonkTcTypesToTypesX req + ; runZonkBndrT (zonkTyVarBindersX ex_bndrs) $ \ ex_bndrs -> + do { prov <- zonkTcTypesToTypesX prov + ; body_ty <- zonkTcTypeToTypeX body_ty + ; return (kv_bndrs, implicit_bndrs, univ_bndrs, ex_bndrs, + req, prov, body_ty) } } + + -- Now do validity checking + ; checkValidType ctxt $ + build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty + + -- Neither argument types nor the return type may be representation polymorphic. + -- This is because, when creating a matcher: + -- - the argument types become the binder types (see test RepPolyPatySynArg), + -- - the return type becomes the scrutinee type (see test RepPolyPatSynRes). + ; let (arg_tys, res_ty) = tcSplitFunTys body_ty + ; mapM_ + (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty) + arg_tys + ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty + + ; traceTc "tcTySig }" $ + vcat [ text "kvs" <+> ppr_tvs (binderVars kv_bndrs) + , text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs) + , text "univ_tvs" <+> ppr_tvs (binderVars univ_bndrs) + , text "req" <+> ppr req + , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs) + , text "prov" <+> ppr prov + , text "body_ty" <+> ppr body_ty ] + ; return $ + PatSig { patsig_name = name + , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs + , patsig_univ_bndrs = univ_bndrs + , patsig_req = req + , patsig_ex_bndrs = ex_bndrs + , patsig_prov = prov + , patsig_body_ty = body_ty } } + where + ctxt = PatSynCtxt name + + build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body + = mkInvisForAllTys implicit_bndrs $ + mkInvisForAllTys univ_bndrs $ + mk_naked_phi_ty req $ + mkInvisForAllTys ex_bndrs $ + mk_naked_phi_ty prov $ + body + + -- Use mk_naked_phi_ty because we call build_patsyn_type /before zonking/ + -- just before kindGeneraliseAll, and the invariants that mkPhiTy checks + -- don't hold of the un-zonked types. #22521 was a case in point. + -- (We also called build_patsyn_type on the fully zonked type, so mkPhiTy + -- would work; but it doesn't seem worth duplicating the code.) + mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType + mk_naked_phi_ty theta body = foldr (mkNakedFunTy invisArgTypeLike) body theta + +ppr_tvs :: [TyVar] -> SDoc +ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv) + | tv <- tvs]) + + +{- ********************************************************************* +* * + Instantiating user signatures +* * +********************************************************************* -} + + +tcInstSig :: TcIdSig -> TcM TcIdSigInst +-- Instantiate a type signature; only used with plan InferGen +tcInstSig hs_sig@(TcCompleteSig (CSig { sig_bndr = poly_id, sig_loc = loc })) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id) + -- See Note [Pattern bindings and complete signatures] + + ; return (TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = [] + , sig_inst_wcx = Nothing + , sig_inst_theta = theta + , sig_inst_tau = tau }) } + +tcInstSig hs_sig@(TcPartialSig (PSig { psig_hs_ty = hs_ty + , psig_ctxt = ctxt + , psig_loc = loc })) + = setSrcSpan loc $ -- Set the binding site of the tyvars + do { traceTc "Staring partial sig {" (ppr hs_sig) + ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty + -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType + + ; let inst_sig = TISI { sig_inst_sig = hs_sig + , sig_inst_skols = tv_prs + , sig_inst_wcs = wcs + , sig_inst_wcx = wcx + , sig_inst_theta = theta + , sig_inst_tau = tau } + ; traceTc "End partial sig }" (ppr inst_sig) + ; return inst_sig } + +{- Note [Pattern bindings and complete signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = MkT a a + f :: forall a. a->a + g :: forall b. b->b + MkT f g = MkT (\x->x) (\y->y) +Here we'll infer a type from the pattern of 'T a', but if we feed in +the signature types for f and g, we'll end up unifying 'a' and 'b' + +So we instantiate f and g's signature with TyVarTv skolems +(newMetaTyVarTyVars) that can unify with each other. If too much +unification takes place, we'll find out when we do the final +impedance-matching check in GHC.Tc.Gen.Bind.mkExport + +See Note [TyVarTv] in GHC.Tc.Utils.TcMType + +None of this applies to a function binding with a complete +signature, which doesn't use tcInstSig. See GHC.Tc.Gen.Bind.tcPolyCheck. +-} + +{- ********************************************************************* +* * + Pragmas and PragEnv +* * +********************************************************************* -} + +type TcPragEnv = NameEnv [LSig GhcRn] + +emptyPragEnv :: TcPragEnv +emptyPragEnv = emptyNameEnv + +lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn] +lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] + +extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv +extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) Utils.singleton prag_fn n sig + +--------------- +mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv +mkPragEnv sigs binds + = foldl' extendPragEnv emptyNameEnv prs + where + prs = mapMaybe get_sig sigs + + get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) + get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig) + get_sig sig@(L _ (SpecSigE nm _ _ _)) = Just (nm, add_arity nm sig) + get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig) + get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig) + get_sig _ = Nothing + + add_arity n sig -- Adjust inl_sat field to match visible arity of function + = case lookupNameEnv ar_env n of + Just ar -> addInlinePragArity ar sig + Nothing -> sig -- See Note [Pattern synonym inline arity] + + -- ar_env maps a local to the arity of its definition + ar_env :: NameEnv Arity + ar_env = foldr lhsBindArity emptyNameEnv binds + +addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn +addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl)) +addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl)) +addInlinePragArity ar (L l (SpecSigE n x e inl)) = L l (SpecSigE n x e (add_inl_arity ar inl)) +addInlinePragArity _ sig = sig + +add_inl_arity :: Arity -> InlinePragma -> InlinePragma +add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec }) + | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE + = prag { inl_sat = Just ar } + | otherwise + = prag + +lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env + = extendNameEnv env (unLoc id) (matchGroupArity ms) +lhsBindArity _ env = env -- PatBind/VarBind + + +----------------- +addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId +addInlinePrags poly_id prags_for_me + | inl@(L _ prag) : inls <- inl_prags + = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) + ; unless (null inls) (warn_multiple_inlines inl inls) + ; return (poly_id `setInlinePragma` prag) } + | otherwise + = return poly_id + where + inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me] + + warn_multiple_inlines _ [] = return () + + warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls) + | inlinePragmaActivation prag1 == inlinePragmaActivation prag2 + , noUserInlineSpec (inlinePragmaSpec prag1) + = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop + -- and inl2 is a user NOINLINE pragma; we don't want to complain + warn_multiple_inlines inl2 inls + | otherwise + = setSrcSpanA loc $ + let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls) + in addDiagnosticTc dia + + +{- Note [Pattern synonym inline arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + {-# INLINE P #-} + pattern P x = (x, True) + +The INLINE pragma attaches to both the /matcher/ and the /builder/ for +the pattern synonym; see Note [Pragmas for pattern synonyms] in +GHC.Tc.TyCl.PatSyn. But they have different inline arities (i.e. number +of binders to which we apply the function before inlining), and we don't +know what those arities are yet. So for pattern synonyms we don't set +the inl_sat field yet; instead we do so (via addInlinePragArity) in +GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind. + +It's a bit messy that we set the arities in different ways. Perhaps we +should add the arity later for all binders. But it works fine like this. +-} + + +{- ********************************************************************* +* * + SPECIALISE pragmas +* * +************************************************************************ + +Note [Overview of SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea is this: + + foo :: Num a => a -> b -> a + foo = rhs + {-# SPECIALISE foo :: Int -> b -> Int #-} -- Old form + {-# SPECIALISE foo @Float #-} -- New form + +Generally: +* Rename as usual +* Typecheck, attaching info to the ABExport record of the AbsBinds for foo +* Desugar by generating + - a specialised binding $sfoo = rhs @Float + - a rewrite rule like RULE "USPEC foo" foo @Float = $sfoo + +There are two major routes: + +* Old form + - Handled by `SpecSig` and `SpecPrag` + - Deals with SPECIALISE pragmas have multiple signatures + {-# SPECIALISE f :: Int -> Int, Float -> Float #-} + - See Note [Handling old-form SPECIALISE pragmas] + - Deprecated, to be removed in GHC 9.18 as per #25540. + +* New form, described in GHC Proposal #493 + - Handled by `SpecSigE` and `SpecPragE` + - Deals with SPECIALISE pragmas which may have value arguments + {-# SPECIALISE f @Int 3 #-} + - See Note [Handling new-form SPECIALISE pragmas] + +Note [Handling new-form SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +New-form SPECIALISE pragmas are described by GHC Proposal #493. + +The pragma takes the form of a function application, possibly with intervening +parens and type signatures, with a variable at the head: + + {-# SPECIALISE f1 @Int 3 #-} + {-# SPECIALISE f2 :: Int -> Int #-} + {-# SPECIALISE (f3 :: Int -> Int) 5 #-} + +It may also have rule for-alls at the top, e.g. + + {-# SPECIALISE forall x xs. f4 (x:xs) #-} + {-# SPECIALISE forall a. forall x xs. f5 @a @a (x:xs) #-} + +See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check. + +Example: + f :: forall a b. (Eq a, Eq b, Eq c) => a -> b -> c -> Bool -> blah + {-# SPECIALISE forall x y. f (x::Int) y y True #-} + -- y::p + +We want to generate: + + RULE forall @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p). + f @Int @p @p d1 d2 d3 x y y True + = $sf @p d2 x y + $sf @p (d2::Eq p) (x::Int) (y::p) + = let d1 = $fEqInt + d3 = d2 + in @p @p @Int (d1::Eq p) (d2::Eq p) (d3::Eq p) x y y True + +Note that + +* The `rule_bndrs`, over which the RULE is quantified, are all the variables + free in the call to `f`, /ignoring/ all dictionary simplification. Why? + Because we want to make the rule maximally applicable; provided the types + match, the dictionaries should match. + + rule_bndrs = @p (d1::Eq Int) (d2::Eq p) (d3::Eq p) (x::Int) (y::p). + + Note that we have separate binders for `d1` and `d2` even though they are + the same (Eq p) dictionary. Reason: we don't want to force them to be visibly + equal at the call site. + +* The `spec_bndrs`, which are lambda-bound in the specialised function `$sf`, + are a subset of `rule_bndrs`. + + spec_bndrs = @p (d2::Eq p) (x::Int) (y::p) + +* The `spec_const_binds` make up the difference between `rule_bndrs` and + `spec_bndrs`. They communicate the specialisation! + If `spec_bndrs` = `rule_bndrs`, no specialisation has happened. + + spec_const_binds = let d1 = $fEqInt + d3 = d2 + +This is done in three parts. + + A. Typechecker: `GHC.Tc.Gen.Sig.tcSpecPrag` + + (1) Typecheck the expression, capturing its constraints + + (2) Solve these constraints. When doing so, switch on `tcsmFullySolveQCIs`; + see wrinkle (NFS1) below. + + (3) Compute the constraints to quantify over, using `getRuleQuantCts` on + the unsolved constraints returned by (2). + + (4) Emit the residual (non-solved, non-quantified) constraints, and wrap the + expression in a let binding for those constraints. + + (5) Wrap the call in the combined evidence bindings from steps (2) and (4) + + (6) Store all the information in a 'SpecPragE' record, to be consumed + by the desugarer. + + B. Zonker: `GHC.Tc.Zonk.Type.zonkLTcSpecPrags` + + The zonker does a little extra work to collect any free type variables + of the LHS. See Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type. + These weren't conveniently available earlier. + + C. Desugarer: `GHC.HsToCore.Binds.dsSpec`. + + See Note [Desugaring new-form SPECIALISE pragmas] in GHC.HsToCore.Binds for details, + but in brief: + + (1) Simplify the expression. This is important because a type signature in + the expression will have led to type/dictionary abstractions/applications. + After simplification it should look like + let in f d1 d2 d3 + + (2) `prepareSpecLHS` identifies the `spec_const_binds`, discards the other + dictionary bindings, and decomposes the call. + + (3) Then we build the specialised function $sf, and concoct a RULE + of the form: + forall @a @b d1 d2 d3. f d1 d2 d3 = $sf d1 d2 d3 + +(NFS1) Consider + f :: forall f a. (Ix a, forall x. Eq x => Eq (f x)) => a -> f a + {-# SPECIALISE f :: forall f. (forall x. Eq x => Eq (f x)) => Int -> f Int #-} + This SPECIALISE is treated like an expression with a type signature, so + we instantiate the constraints, simplify them and re-generalise. From the + instantiation we get [W] d :: (forall x. Eq a => Eq (f x)) + and we want to generalise over that. We do not want to attempt to solve it + and then get stuck, and emit an error message. If we can't solve it, it is + much, much better to leave it alone. + + We still need to simplify quantified constraints that can be /fully solved/ + from instances, otherwise we would never be able to specialise them + away. Example: {-# SPECIALISE f @[] @a #-}. So: + + * The constraint solver has a mode flag `tcsmFullySolveQCIs` that says + "fully solve quantified constraint, or leave them alone + * When simplifying constraints in a SPECIALISE pragma, we switch on this + flag the `SpecPragE` case of `tcSpecPrag`. + + You might worry about the wasted work from failed attempts to fully-solve, but + it is seldom repeated (because the constraint solver seldom iterates much). + +Note [Handling old-form SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: this code path is deprecated, and is scheduled to be removed in GHC 9.18, as per #25440. +We check that + (forall a b. Num a => a -> b -> a) + is more polymorphic than + forall b. Int -> b -> Int +(for which we could use tcSubType, but see below), generating a HsWrapper +to connect the two, something like + wrap = /\b. Int b dNumInt +This wrapper is put in the TcSpecPrag, in the ABExport record of +the AbsBinds. + + + f :: (Eq a, Ix b) => a -> b -> Bool + {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-} + f = + +From this the typechecker generates + + AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds + + SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX + -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ]) + + wrap_fn = /\ p q \(d1::Ix p)(d2:Ix q). + let w1 = $fEqInt + w2 = $fIxPair d1 d2 + HOLE @Int @(p,q) (w1:Eq Int) (w2:Ix (p,q)) + +From these we generate: + + Rule: forall p, q, (dInt::Eq Int), (dp:Ix p), (dq:Ix q). + f Int (p,q) dInt ($fIxPair dp dq) = f_spec p q dp dq + + Spec bind: f_spec = wrap_fn[ ] + +Note that + + * The LHS of the rule may mention dictionary *expressions* (eg + $fIxPair dp dq), and that is essential because the dp, dq are + needed on the RHS. + + * The RHS of f_spec, has a *copy* of 'binds', so that it + can fully specialise it. + +From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE: + + f_spec :: Int -> b -> Int + f_spec = wrap + + RULE: forall b (d:Num b). f b d = f_spec b + +The RULE is generated by taking apart the HsWrapper, which is a little +delicate, but works. + +Some wrinkles + +1. In tcSpecWrapper, rather than calling tcSubType, we directly call + skolemise/instantiate. That is mainly because of wrinkle (2). + + Historical note: in the past, tcSubType did co/contra stuff, which + could generate too complex a LHS for the RULE, which was another + reason for not using tcSubType. But that reason has gone away + with simple subsumption (#17775). + +2. We need to take care with type families (#5821). Consider + type instance F Int = Bool + f :: Num a => a -> F a + {-# SPECIALISE foo :: Int -> Bool #-} + + We *could* try to generate an f_spec with precisely the declared type: + f_spec :: Int -> Bool + f_spec = Int dNumInt |> co + + RULE: forall d. f Int d = f_spec |> sym co + + but the 'co' and 'sym co' are (a) playing no useful role, and (b) are + hard to generate. At all costs we must avoid this: + RULE: forall d. f Int d |> co = f_spec + because the LHS will never match (indeed it's rejected in + decomposeRuleLhs). + + So we simply do this: + - Generate a constraint to check that the specialised type (after + skolemisation) is equal to the instantiated function type. + - But *discard* the evidence (coercion) for that constraint, + so that we ultimately generate the simpler code + f_spec :: Int -> F Int + f_spec = Int dNumInt + + RULE: forall d. f Int d = f_spec + You can see this discarding happening in tcSpecPrag + +3. Note that the HsWrapper can transform *any* function with the right + type prefix + forall ab. (Eq a, Ix b) => XXX + regardless of XXX. It's sort of polymorphic in XXX. This is + useful: we use the same wrapper to transform each of the class ops, as + well as the dict. That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags + +Note [SPECIALISE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no point in a SPECIALISE pragma for a non-overloaded function: + reverse :: [a] -> [a] + {-# SPECIALISE reverse :: [Int] -> [Int] #-} + +But SPECIALISE INLINE *can* make sense for GADTS: + data Arr e where + ArrInt :: !Int -> ByteArray# -> Arr Int + ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2) + + (!:) :: Arr e -> Int -> e + {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-} + {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-} + (ArrInt _ ba) !: (I# i) = I# (indexIntArray# ba i) + (ArrPair _ a1 a2) !: i = (a1 !: i, a2 !: i) + +When (!:) is specialised it becomes non-recursive, and can usefully +be inlined. Scary! So we only warn for SPECIALISE *without* INLINE +for a non-overloaded function. +-} + +tcSpecPrags :: Id -> [LSig GhcRn] + -> TcM [LTcSpecPrag] +-- Add INLINE and SPECIALISE pragmas +-- INLINE prags are added to the (polymorphic) Id directly +-- SPECIALISE prags are passed to the desugarer via TcSpecPrags +-- Pre-condition: the poly_id is zonked +-- Reason: required by tcSubExp +tcSpecPrags poly_id prag_sigs + = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) + ; whenIsJust (NE.nonEmpty bad_sigs) warn_discarded_sigs + ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } + where + spec_sigs = filter isSpecLSig prag_sigs + bad_sigs = filter is_bad_sig prag_sigs + is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) + + warn_discarded_sigs bad_sigs_ne + = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne + in addDiagnosticTc dia + +-------------- +tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag] +tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) +-- See Note [Handling old-form SPECIALISE pragmas] +-- +-- The Name fun_name in the SpecSig may not be the same as that of the poly_id +-- Example: SPECIALISE for a class method: the Name in the SpecSig is +-- for the selector Id, but the poly_id is something like $cop +-- However we want to use fun_name in the error message, since that is +-- what the user wrote (#8537) + = addErrCtxt (SpecPragmaCtxt prag) $ + do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ + TcRnNonOverloadedSpecialisePragma fun_name + -- Note [SPECIALISE pragmas] + ; spec_prags <- mapM tc_one hs_tys + ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) + ; return spec_prags } + where + name = idName poly_id + poly_ty = idType poly_id + + tc_one hs_ty + = do { spec_ty <- tcHsSigType (FunSigCtxt name NoRRC) hs_ty + ; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty + ; return (SpecPrag poly_id wrap inl) } + +tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl) + -- For running commentary, see Note [Handling new-form SPECIALISE pragmas] + = do { -- (1) Typecheck the expression, spec_e, capturing its constraints + let skol_info_anon = SpecESkol nm + ; traceTc "tcSpecPrag SpecSigE {" (ppr nm $$ ppr spec_e) + ; skol_info <- mkSkolemInfo skol_info_anon + ; (rhs_tclvl, spec_e_wanted, (rule_bndrs', (tc_spec_e, _rho))) + <- tcRuleBndrs skol_info rule_bndrs $ + tcInferRho spec_e + + -- (2) Solve the resulting wanteds + ; ev_binds_var <- newTcEvBinds + ; spec_e_wanted <- setTcLevel rhs_tclvl $ + runTcSWithEvBinds ev_binds_var $ + setTcSMode (vanillaTcSMode { tcsmFullySolveQCIs = True }) $ + -- tcsmFullySolveQCIs: see (NFS1) + solveWanteds spec_e_wanted + ; spec_e_wanted <- liftZonkM $ zonkWC spec_e_wanted + + -- (3) Compute which constraints to quantify over, by looking + -- at the unsolved constraints from (2) + ; (quant_cands, residual_wc) <- getRuleQuantCts spec_e_wanted + + -- (4) Emit the residual constraints (i.e. ones that we have + -- not solved in (2) nor quantified in (3) + -- NB: use the same `ev_binds_var` as (2), so the bindings + -- for (2) and (4) are combined + ; let tv_bndrs = filter isTyVar rule_bndrs' + qevs = map ctEvId (bagToList quant_cands) + ; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var + emptyVarSet tv_bndrs qevs + residual_wc + + -- (5) Wrap the call in the combined evidence bindings + -- from steps (2) and (4) + ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) tc_spec_e + + ; ev_binds <- getTcEvBindsMap ev_binds_var + + ; traceTc "tcSpecPrag SpecSigE }" $ + vcat [ text "nm:" <+> ppr nm + , text "rule_bndrs':" <+> ppr rule_bndrs' + , text "qevs:" <+> ppr qevs + , text "spec_e:" <+> ppr tc_spec_e + , text "inl:" <+> ppr inl + , text "spec_e_wanted:" <+> ppr spec_e_wanted + , text "quant_cands:" <+> ppr quant_cands + , text "residual_wc:" <+> ppr residual_wc + , text (replicate 80 '-') + , text "ev_binds_var:" <+> ppr ev_binds_var + , text "ev_binds:" <+> ppr ev_binds + ] + + -- (6) Store the results in a SpecPragE record, which will be + -- zonked and then consumed by the desugarer. + + ; return [SpecPragE { spe_fn_nm = nm + , spe_fn_id = poly_id + , spe_bndrs = qevs ++ rule_bndrs' -- Dependency order + -- does not matter + , spe_call = lhs_call + , spe_inl = inl }] } + +tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) + +-------------- +tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper +-- A simpler variant of tcSubType, used for SPECIALISE pragmas +-- See Note [Handling old-form SPECIALISE pragmas], wrinkle 1 +tcSpecWrapper ctxt poly_ty spec_ty + = do { (sk_wrap, inst_wrap) + <- tcSkolemise Shallow ctxt spec_ty $ \spec_tau -> + do { (inst_wrap, tau) <- topInstantiate orig poly_ty + ; _ <- unifyType Nothing spec_tau tau + -- Deliberately ignore the evidence + -- See Note [Handling old-form SPECIALISE pragmas], + -- wrinkle (2) + ; return inst_wrap } + ; return (sk_wrap <.> inst_wrap) } + where + orig = SpecPragOrigin ctxt + +-------------- +tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag] +-- SPECIALISE pragmas for imported things +tcImpPrags prags + = do { dflags <- getDynFlags + ; traceTc "tcImpPrags1" (ppr prags) + ; if (not_specialising dflags) then + return [] + else do + { this_mod <- getModule + ; pss <- mapAndRecoverM (wrapLocMA (tcImpSpec this_mod)) prags + ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't want complaints about lack of INLINABLE pragmas + not_specialising dflags = + not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags)) + +tcImpSpec :: Module -> Sig GhcRn -> TcM [TcSpecPrag] +tcImpSpec this_mod prag + | Just name <- is_spec_prag prag -- It's a specialisation pragma + , not (nameIsLocalOrFrom this_mod name) -- The Id is imported + = do { id <- tcLookupId name + ; if hasSomeUnfolding (realIdUnfolding id) + -- See Note [SPECIALISE pragmas for imported Ids] + then tcSpecPrag id prag + else do { let dia = TcRnSpecialiseNotVisible name + ; addDiagnosticTc dia + ; return [] } } + | otherwise + = return [] + where + is_spec_prag (SpecSig _ (L _ nm) _ _) = Just nm + is_spec_prag (SpecSigE nm _ _ _) = Just nm + is_spec_prag _ = Nothing + +{- Note [SPECIALISE pragmas for imported Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An imported Id may or may not have an unfolding. If not, we obviously +can't specialise it here; indeed the desugar falls over (#18118). + +We used to test whether it had a user-specified INLINABLE pragma but, +because of Note [Worker/wrapper for INLINABLE functions] in +GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with +a wrapper that has no pragma, just an unfolding (#19246). So now +we just test whether the function has an unfolding. + +There's a risk that a pragma-free function may have an unfolding now +(because it is fairly small), and then gets a bit bigger, and no +longer has an unfolding in the future. But then you'll get a helpful +error message suggesting an INLINABLE pragma, which you can follow. +That seems enough for now. +-} + + +{- ********************************************************************* +* * + Rules +* * +************************************************************************ + +Note [Typechecking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We *infer* the type of the LHS, and use that type to *check* the type of +the RHS. That means that higher-rank rules work reasonably well. Here's +an example (test simplCore/should_compile/rule2.hs) produced by Roman: + + foo :: (forall m. m a -> m b) -> m a -> m b + foo f = ... + + bar :: (forall m. m a -> m a) -> m a -> m a + bar f = ... + + {-# RULES "foo/bar" foo = bar #-} + +He wanted the rule to typecheck. + +Note [TcLevel in type checking rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Bringing type variables into scope naturally bumps the TcLevel. Thus, we type +check the term-level binders in a bumped level, and we must accordingly bump +the level whenever these binders are in scope. + +Note [Re-quantify type variables in rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example from #17710: + + foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b + foo x = Proxy + {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-} + +Written out in more detail, the "foo" rewrite rule looks like this: + + forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0 + +Where b0 is a unification variable. Where should b0 be quantified? We have to +quantify it after k, since (b0 :: k). But generalization usually puts inferred +type variables (such as b0) at the /front/ of the telescope! This creates a +conflict. + +One option is to simply throw an error, per the principles of +Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen +if we were generalising over a normal type signature. On the other hand, the +types in a rewrite rule aren't quite "normal", since the notions of specified +and inferred type variables aren't applicable. + +A more permissive design (and the design that GHC uses) is to simply requantify +all of the type variables. That is, we would end up with this: + + forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b + +It's a bit strange putting the generalized variable `b` after the user-written +variables `k` and `a`. But again, the notion of specificity is not relevant to +rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not +only makes "foo" typecheck, but it also makes the implementation simpler. + +See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which +explains a very similar design when generalising over a type family instance +equation. +-} + +tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc] +tcRules decls = mapM (wrapLocMA tcRuleDecls) decls + +tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) +tcRuleDecls (HsRules { rds_ext = src + , rds_rules = decls }) + = do { maybe_tc_decls <- mapM (wrapLocMA tcRule) decls + ; let tc_decls = [L loc rule | (L loc (Just rule)) <- maybe_tc_decls] + ; return $ HsRules { rds_ext = src + , rds_rules = tc_decls } } + +tcRule :: RuleDecl GhcRn -> TcM (Maybe (RuleDecl GhcTc)) +tcRule (HsRule { rd_ext = ext + , rd_name = rname@(L _ name) + , rd_act = act + , rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = rhs }) + = addErrCtxt (RuleCtxt name) $ + do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname) + ; skol_info <- mkSkolemInfo (RuleSkol name) + -- Note [Typechecking rules] + ; (tc_lvl, lhs_wanted, stuff) + <- tcRuleBndrs skol_info bndrs $ + do { (lhs', rule_ty) <- tcInferRho lhs + ; (rhs', rhs_wanted) <- captureConstraints $ + tcCheckMonoExpr rhs rule_ty + ; return (lhs', rule_ty, rhs', rhs_wanted) } + + ; let (bndrs', (lhs', rule_ty, rhs', rhs_wanted)) = stuff + + ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname + , ppr lhs_wanted + , ppr rhs_wanted ]) + + ; (lhs_evs, residual_lhs_wanted, dont_default) + <- simplifyRule name tc_lvl lhs_wanted rhs_wanted + + -- SimplifyRule Plan, step 4 + -- Now figure out what to quantify over + -- c.f. GHC.Tc.Solver.simplifyInfer + -- We quantify over any tyvars free in *either* the rule + -- *or* the bound variables. The latter is important. Consider + -- ss (x,(y,z)) = (x,z) + -- RULE: forall v. fst (ss v) = fst v + -- The type of the rhs of the rule is just a, but v::(a,(b,c)) + -- + -- We also need to get the completely-unconstrained tyvars of + -- the LHS, lest they otherwise get defaulted to Any; but we do that + -- during zonking (see GHC.Tc.Zonk.Type.zonkRule) + + ; let tpl_ids = lhs_evs ++ filter isId bndrs' + + -- See Note [Re-quantify type variables in rules] + ; dvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids) + ; let weed_out = (`dVarSetMinusVarSet` dont_default) + weeded_dvs = weedOutCandidates weed_out dvs + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars weeded_dvs + ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname + , text "dvs:" <+> ppr dvs + , text "weeded_dvs:" <+> ppr weeded_dvs + , text "dont_default:" <+> ppr dont_default + , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted + , text "qtkvs:" <+> ppr qtkvs + , text "rule_ty:" <+> ppr rule_ty + , text "bndrs:" <+> ppr bndrs + , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids) + , text "tpl_id info:" <+> + vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + ]) + + -- /Temporarily/ deal with the fact that we previously accepted + -- rules that quantify over certain equality constraints. + -- + -- See Note [Quantifying over equalities in RULES]. + ; case allPreviouslyQuantifiableEqualities residual_lhs_wanted of { + Just cts | not (insolubleWC rhs_wanted) + -> do { addDiagnostic $ TcRnRuleLhsEqualities name lhs cts + ; return Nothing } ; + _ -> + + do { -- SimplifyRule Plan, step 5 + -- Simplify the LHS and RHS constraints: + -- For the LHS constraints we must solve the remaining constraints + -- (a) so that we report insoluble ones + -- (b) so that we bind any soluble ones + (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs + lhs_evs residual_lhs_wanted + ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs + lhs_evs rhs_wanted + + ; emitImplications (lhs_implic `unionBags` rhs_implic) + + ; return $ Just $ + HsRule { rd_ext = ext + , rd_name = rname + , rd_act = act + , rd_bndrs = bndrs { rb_ext = qtkvs ++ tpl_ids } + , rd_lhs = mkHsDictLet lhs_binds lhs' + , rd_rhs = mkHsDictLet rhs_binds rhs' } } } } + +{- ******************************************************************************** +* * + tcRuleBndrs +* * +******************************************************************************** -} + +tcRuleBndrs :: SkolemInfo -> RuleBndrs GhcRn + -> TcM a -- Typecheck this with the rule binders in scope + -> TcM (TcLevel, WantedConstraints, ([Var], a)) + -- The [Var] are the explicitly-quantified variables, + -- both type variables and term variables +tcRuleBndrs skol_info (RuleBndrs { rb_tyvs = mb_tv_bndrs, rb_tmvs = tm_bndrs }) + thing_inside + = pushLevelAndCaptureConstraints $ + case mb_tv_bndrs of + Nothing -> go_tms tm_bndrs thing_inside + Just tv_bndrs -> do { (bndrs1, (bndrs2, res)) <- go_tvs tv_bndrs $ + go_tms tm_bndrs $ + thing_inside + ; return (binderVars bndrs1 ++ bndrs2, res) } + where + -------------- + go_tvs tvs thing_inside = bindExplicitTKBndrs_Skol skol_info tvs thing_inside + + -------------- + go_tms [] thing_inside + = do { res <- thing_inside; return ([], res) } + go_tms (L _ (RuleBndr _ (L _ name)) : rule_bndrs) thing_inside + = do { ty <- newOpenFlexiTyVarTy + ; let bndr_id = mkLocalId name ManyTy ty + ; (bndrs, res) <- tcExtendIdEnv [bndr_id] $ + go_tms rule_bndrs thing_inside + ; return (bndr_id : bndrs, res) } + + go_tms (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs) thing_inside + -- e.g x :: a->a + -- The tyvar 'a' is brought into scope first, just as if you'd written + -- a::*, x :: a->a + -- If there's an explicit forall, the renamer would have already reported an + -- error for each out-of-scope type variable used + = do { (_ , tv_prs, id_ty) <- tcRuleBndrSig name skol_info rn_ty + ; let bndr_id = mkLocalId name ManyTy id_ty + -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType + + -- The type variables scope over subsequent bindings; yuk + ; (bndrs, res) <- tcExtendNameTyVarEnv tv_prs $ + tcExtendIdEnv [bndr_id] $ + go_tms rule_bndrs thing_inside + ; return (map snd tv_prs ++ bndr_id : bndrs, res) } + + +{- +********************************************************************************* +* * + Constraint simplification for rules +* * +*********************************************************************************** + +Note [The SimplifyRule Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Example. Consider the following left-hand side of a rule + f (x == y) (y > z) = ... +If we typecheck this expression we get constraints + d1 :: Ord a, d2 :: Eq a +We do NOT want to "simplify" to the LHS + forall x::a, y::a, z::a, d1::Ord a. + f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ... +Instead we want + forall x::a, y::a, z::a, d1::Ord a, d2::Eq a. + f ((==) d2 x y) ((>) d1 y z) = ... + +Here is another example: + fromIntegral :: (Integral a, Num b) => a -> b + {-# RULES "foo" fromIntegral = id :: Int -> Int #-} +In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But +we *dont* want to get + forall dIntegralInt. + fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int +because the scsel will mess up RULE matching. Instead we want + forall dIntegralInt, dNumInt. + fromIntegral Int Int dIntegralInt dNumInt = id Int + +Even if we have + g (x == y) (y == z) = .. +where the two dictionaries are *identical*, we do NOT WANT + forall x::a, y::a, z::a, d1::Eq a + f ((==) d1 x y) ((>) d1 y z) = ... +because that will only match if the dict args are (visibly) equal. +Instead we want to quantify over the dictionaries separately. + +In short, simplifyRuleLhs must *only* squash equalities, leaving +all dicts unchanged, with absolutely no sharing. + +Also note that we can't solve the LHS constraints in isolation: +Example foo :: Ord a => a -> a + foo_spec :: Int -> Int + {-# RULE "foo" foo = foo_spec #-} +Here, it's the RHS that fixes the type variable + +HOWEVER, under a nested implication things are different +Consider + f :: (forall a. Eq a => a->a) -> Bool -> ... + {-# RULES "foo" forall (v::forall b. Eq b => b->b). + f b True = ... + #-} +Here we *must* solve the wanted (Eq a) from the given (Eq a) +resulting from skolemising the argument type of g. So we +revert to SimplCheck when going under an implication. + + +--------- So the SimplifyRule Plan is this ----------------------- + +* Step 0: typecheck the LHS and RHS to get constraints from each + +* Step 1: Simplify the LHS and RHS constraints all together in one bag, + but /discarding/ the simplified constraints. We do this only + to discover all unification equalities. + +* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take + advantage of those unifications + +* Step 3: Partition the LHS constraints into the ones we will + quantify over, and the others. + See Note [RULE quantification over equalities] + +* Step 4: Decide on the type variables to quantify over + +* Step 5: Simplify the LHS and RHS constraints separately, using the + quantified constraints as givens + +Note [Solve order for RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step 1 above, we need to be a bit careful about solve order. +Consider + f :: Int -> T Int + type instance T Int = Bool + + RULE f 3 = True + +From the RULE we get + lhs-constraints: T Int ~ alpha + rhs-constraints: Bool ~ alpha +where 'alpha' is the type that connects the two. If we glom them +all together, and solve the RHS constraint first, we might solve +with alpha := Bool. But then we'd end up with a RULE like + + RULE: f 3 |> (co :: T Int ~ Bool) = True + +which is terrible. We want + + RULE: f 3 = True |> (sym co :: Bool ~ T Int) + +So we are careful to solve the LHS constraints first, and *then* the +RHS constraints. Actually much of this is done by the on-the-fly +constraint solving, so the same order must be observed in +tcRule. + +Note [RULE quantification over equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment a RULE never quantifies over an equality; see `rule_quant_ct` +in `getRuleQuantCts`. Why not? + + * It's not clear why we would want to do so (see Historical Note + below) + + * We do not want to quantify over insoluble equalities (Int ~ Bool) + (a) because we prefer to report a LHS type error + (b) because if such things end up in 'givens' we get a bogus + "inaccessible code" error + + * Matching on coercions is Deeply Suspicious. We don't want to generate a + RULE like + forall a (co :: F a ~ Int). + foo (x |> Sym co) = ...co... + because matching on that template, to bind `co`, would require us to + match on the /structure/ of a coercion, which we must never do. + See GHC.Core.Rules Note [Casts in the template] + + * Equality constraints are unboxed, and that leads to complications + For example equality constraints from the LHS will emit coercion hole + Wanteds. These don't have a name, so we can't quantify over them directly. + Instead, in `getRuleQuantCts`, we'd have to invent a new EvVar for the + coercion, fill the hole with the invented EvVar, and then quantify over the + EvVar. Here is old code from `mk_one` + do { ev_id <- newEvVar pred + ; fillCoercionHole hole (mkCoVarCo ev_id) + ; return ev_id } + But that led to new complications becuase of the side effect on the coercion + hole. Much easier just to side-step the issue entirely by not quantifying over + equalities. + +Historical Note: + Back in 2012 (5aa1ae24567) we started quantifying over some equality + constraints, saying + * But we do want to quantify over things like (a ~ F b), + where F is a type function. + It is not clear /why/ we did so, and we don't do so any longer. +End of historical note. + +Note [Simplify cloned constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this stage, we're simplifying constraints only for insolubility +and for unification. Note that all the evidence is quickly discarded. +We use a clone of the real constraint. If we don't do this, +then RHS coercion-hole constraints get filled in, only to get filled +in *again* when solving the implications emitted from tcRule. That's +terrible, so we avoid the problem by cloning the constraints. + +-} + +simplifyRule :: RuleName + -> TcLevel -- Level at which to solve the constraints + -> WantedConstraints -- Constraints from LHS + -> WantedConstraints -- Constraints from RHS + -> TcM ( [EvVar] -- Quantify over these LHS vars + , WantedConstraints -- Residual un-quantified LHS constraints + , TcTyVarSet ) -- Don't default these +-- See Note [The SimplifyRule Plan] +-- NB: This consumes all simple constraints on the LHS, but not +-- any LHS implication constraints. +simplifyRule name tc_lvl lhs_wanted rhs_wanted + = do { + -- Note [The SimplifyRule Plan] step 1 + -- First solve the LHS and *then* solve the RHS + -- Crucially, this performs unifications + -- Why clone? See Note [Simplify cloned constraints] + ; lhs_clone <- cloneWC lhs_wanted + ; rhs_clone <- cloneWC rhs_wanted + ; (dont_default, _) + <- setTcLevel tc_lvl $ + runTcS $ + do { lhs_wc <- solveWanteds lhs_clone + ; _rhs_wc <- solveWanteds rhs_clone + -- Why do them separately? + -- See Note [Solve order for RULES] + + ; let dont_default = nonDefaultableTyVarsOfWC lhs_wc + -- If lhs_wanteds has + -- (a[sk] :: TYPE rr[sk]) ~ (b0[tau] :: TYPE r0[conc]) + -- we want r0 to be non-defaultable; + -- see nonDefaultableTyVarsOfWC. Simplest way to get + -- this is to look at the post-simplified lhs_wc, which + -- will contain (rr[sk] ~ r0[conc)]. An example is in + -- test rep-poly/RepPolyRule1 + ; return dont_default } + + -- Note [The SimplifyRule Plan] step 2 + ; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted + + -- Note [The SimplifyRule Plan] step 3 + ; (quant_cts, residual_lhs_wanted) <- getRuleQuantCts lhs_wanted + ; let quant_evs = map ctEvId (bagToList quant_cts) + + ; traceTc "simplifyRule" $ + vcat [ text "LHS of rule" <+> doubleQuotes (ftext name) + , text "lhs_wanted" <+> ppr lhs_wanted + , text "rhs_wanted" <+> ppr rhs_wanted + , text "quant_cts" <+> ppr quant_evs + , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted + , text "dont_default" <+> ppr dont_default + ] + + ; return (quant_evs, residual_lhs_wanted, dont_default) } + +getRuleQuantCts :: WantedConstraints -> TcM (Cts, WantedConstraints) +-- Extract all the constraints that we can quantify over, +-- also returning the depleted WantedConstraints +-- +-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged, +-- and attempt to solve them from the quantified constraints. Instead +-- we /partition/ the WantedConstraints into ones to quantify and ones +-- we can't quantify. We could use approximateWC instead, and leave +-- `wanted` unchanged; but then we'd have to clone fresh binders and +-- generate silly identity bindings. Seems more direct to do this. +-- Probably not a big deal wither way. +-- +-- NB: we must look inside implications, because with +-- -fdefer-type-errors we generate implications rather eagerly; +-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732. + +getRuleQuantCts wc + = return $ float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints) + float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs }) + = ( simple_yes `andCts` implic_yes + , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs }) + where + (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples + (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs) emptyBag implics + + float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication) + float_implic skol_tvs yes1 imp + = (yes1 `andCts` yes2, imp { ic_wanted = no }) + where + (yes2, no) = float_wc new_skol_tvs (ic_wanted imp) + new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp + + rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool + rule_quant_ct skol_tvs ct + | insolubleWantedCt ct + = False + | otherwise + = case classifyPredType (ctPred ct) of + EqPred {} -> False -- Note [RULE quantification over equalities] + _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs + +{- Note [Quantifying over equalities in RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Up until version 9.12 (inclusive), GHC would happily quantify over certain Wanted +equalities in the LHS of a RULE. This was incorrect behaviour that led to a RULE +that would never fire, so GHC 9.14 and above no longer allow such RULES. +However, instead of throwing an error, GHC will /temporarily/ emit a warning +and drop the rule instead, in order to ease migration for library maintainers +(NB: this warning is not emitted when the RHS constraints are insoluble; in that +case we simply report those constraints as errors instead). +This warning is scheduled to be turned into an error, and the warning flag +removed (becoming a normal typechecker error), starting from version 9.18. + +The function 'allPreviouslyQuantifiableEqualities' computes the equality +constraints that previous (<= 9.12) versions of GHC accepted quantifying over. + + + Example (test case 'RuleEqs', extracted from the 'mono-traversable' library): + + type family Element mono + type instance Element [a] = a + + class MonoFoldable mono where + otoList :: mono -> [Element mono] + instance MonoFoldable [a] where + otoList = id + + ointercalate :: (MonoFoldable mono, Monoid (Element mono)) + => Element mono -> mono -> Element mono + {-# RULES "ointercalate list" forall x. ointercalate x = Data.List.intercalate x . otoList #-} + + Now, because Data.List.intercalate has the type signature + + forall a. [a] -> [[a]] -> [a] + + typechecking the LHS of this rule would give rise to the Wanted equality + + [W] Element mono ~ [a] + + Due to the type family, GHC 9.12 and below accepted to quantify over this + equality, which would lead to a rule LHS template of the form: + + forall (@mono) (@a) + ($dMonoFoldable :: MonoFoldable mono) + ($dMonoid :: Monoid (Element mono)) + (co :: [a] ~ Element mono) + (x :: [a]). + ointercalate @mono $dMonoFoldable $dMonoid + (x `cast` (Sub co)) + + Matching against this template would match on the structure of a coercion, + which goes against Note [Casts in the template] in GHC.Core.Rules. + In practice, this meant that this RULE would never fire. +-} + +-- | Computes all equality constraints that GHC doesn't accept, but previously +-- did accept (until GHC 9.12 (included)), when deciding what to quantify over +-- in the LHS of a RULE. +-- +-- See Note [Quantifying over equalities in RULES]. +allPreviouslyQuantifiableEqualities :: WantedConstraints -> Maybe (NE.NonEmpty Ct) +allPreviouslyQuantifiableEqualities wc = go emptyVarSet wc + where + go :: TyVarSet -> WantedConstraints -> Maybe (NE.NonEmpty Ct) + go skol_tvs (WC { wc_simple = simples, wc_impl = implics }) + = do { cts1 <- mapM (go_simple skol_tvs) simples + ; cts2 <- concatMapM (go_implic skol_tvs) implics + ; NE.nonEmpty $ toList cts1 ++ toList cts2 } + + go_simple :: TyVarSet -> Ct -> Maybe Ct + go_simple skol_tvs ct + | not (tyCoVarsOfCt ct `disjointVarSet` skol_tvs) + = Nothing + | EqPred _ t1 t2 <- classifyPredType (ctPred ct), ok_eq t1 t2 + = Just ct + | otherwise + = Nothing + + go_implic :: TyVarSet -> Implication -> Maybe [Ct] + go_implic skol_tvs (Implic { ic_skols = skols, ic_wanted = wc }) + = fmap toList $ go (skol_tvs `extendVarSetList` skols) wc + + ok_eq t1 t2 + | t1 `tcEqType` t2 = False + | otherwise = is_fun_app t1 || is_fun_app t2 + + is_fun_app ty -- ty is of form (F tys) where F is a type function + = case tyConAppTyCon_maybe ty of + Just tc -> isTypeFamilyTyCon tc + Nothing -> False diff --git a/GHC/Tc/Gen/Splice.hs b/GHC/Tc/Gen/Splice.hs --- a/GHC/Tc/Gen/Splice.hs +++ b/GHC/Tc/Gen/Splice.hs @@ -7,11 +7,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# 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 @@ -21,7 +30,7 @@ -- | Template Haskell splices module GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket, - runAnnotation, + runAnnotation, getUntypedSpliceBody, runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, tcTopSpliceExpr, lookupThName_maybe, @@ -81,7 +90,7 @@ import GHCi.RemoteTypes import GHC.Runtime.Interpreter -import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) +import GHC.Rename.Splice( traceSplice, SpliceInfo(..) ) import GHC.Rename.Expr import GHC.Rename.Env import GHC.Rename.Fixity ( lookupFixityRn_help ) @@ -116,31 +125,36 @@ import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Deps +import GHC.Iface.Syntax import GHC.Utils.Misc import GHC.Utils.Panic as Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger -import GHC.Utils.Exception (throwIO, ErrorCall(..), SomeException(..)) +import GHC.Utils.Exception (throwIO, ErrorCall(..)) import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) import GHC.Data.FastString import GHC.Data.Maybe( MaybeErr(..) ) +import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions as LangExt -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.Boot.TH.Syntax as TH +import qualified GHC.Boot.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 ) +#if !MIN_VERSION_base(4,22,0) +import GHC.Desugar ( AnnotationWrapper(..) ) +#else +import GHC.Internal.Desugar ( AnnotationWrapper(..) ) #endif +import Control.DeepSeq +#endif import Control.Monad import Data.Binary @@ -164,27 +178,27 @@ {- Note [Template Haskell state diagram] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here are the ThStages, s, their corresponding level numbers -(the result of (thLevel s)), and their state transitions. +Here are the ThLevels, their corresponding level numbers +(the result of (thLevelIndex s)), and their state transitions. The top level of the program is stage Comp: Start here | V - ----------- $ ------------ $ - | Comp | ---------> | Splice | -----| - | 1 | | 0 | <----| - ----------- ------------ + ----------- $ ------------ $ ----------------- + | Comp | ---------> | Splice | -----> | Splice Splice | + | 0 | | -1 | <---- | -2 | + ----------- ------------ [||] ----------------- ^ | ^ | $ | | [||] $ | | [||] | v | v -------------- ---------------- | Brack Comp | | Brack Splice | - | 2 | | 1 | + | 1 | | 0 | -------------- ---------------- * Normal top-level declarations start in state Comp - (which has level 1). + (which has level 0). Annotations start in state Splice, since they are treated very like a splice (only without a '$') @@ -192,31 +206,30 @@ will be *run at compile time*, with the result replacing the splice -* The original paper used level -1 instead of 0, etc. - * The original paper did not allow a splice within a splice, but there is no reason not to. This is the $ transition in the top right. Note [Template Haskell levels] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Imported things are impLevel (= 0) +* The level checks are implemented for terms in `checkThLocalName` -* However things at level 0 are not *necessarily* imported. - eg $( \b -> ... ) here b is bound at level 0 +* Imported things are level 0 +* Top-level things are level 0 + * In GHCi, variables bound by a previous command are treated - as impLevel, because we have bytecode for them. + as imported, because we have bytecode for them. * Variables are bound at the "current level" -* The current level starts off at outerLevel (= 1) +* The current level starts off at 0 * The level is decremented by splicing $(..) incremented by brackets [| |] incremented by name-quoting 'f -* When a variable is used, checkWellStaged compares +* When a variable is used, checkThLocalName compares bind: binding level, and use: current level at usage site @@ -227,16 +240,18 @@ bind = use Always OK (bound same stage as used) [| \x -> $(f [| x |]) |] - bind < use Inside brackets, it depends - Inside splice, OK - Inside neither, OK + bind < use Inside brackets, it depends on what cross stage + persistence rules are used. For (bind < use) inside brackets, there are three cases: - - Imported things OK f = [| map |] - - Top-level things OK g = [| f |] + - Imported things (if ImplicitStagePersistence is enabled) OK f = [| map |] + - Top-level things (if ImplicitStagePersistence is enabled) OK g = [| f |] - Non-top-level Only if there is a liftable instance h = \(x:Int) -> [| x |] + If ExplicitLevelImports is used, then imports can bring identifiers into scope + at non-zero levels. + To track top-level-ness we use the ThBindEnv in TcLclEnv For example: @@ -374,7 +389,7 @@ returned together in a `QuoteWrapper` and then passed along to two further places during compilation: -1. Typechecking nested splices (immediately in tcPendingSplice) +1. Typechecking nested splices (immediately in tcUntypedSplice) 2. Desugaring quotations (see GHC.HsToCore.Quote) `tcPendingSplice` takes the `m` type variable as an argument and @@ -401,7 +416,7 @@ Note [Lifecycle of an untyped splice, and PendingRnSplice] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Untyped splices $(f x) and quasiquotes [p| stuff |] have the following -life cycle. Remember, quasi-quotes are very like splices; see Note [Quasi-quote overview]). +life cycle. Quasi-quotes are very like splices; see Note [Quasi-quote overview]). The type structure is @@ -411,13 +426,14 @@ data HsUntypedSplice p = HsUntypedSpliceExpr (XUntypedSpliceExpr p) (LHsExpr p) | HsQuasiQuote (XQuasiQuote p) (IdP id) (XRec p FastString) + | XXUntypedSplice (XUntypedSplice p) -Remember that untyped splices can occur in expressions, patterns, +Untyped splices can occur in expressions, patterns, types, and declarations. So we have a HsUntypedSplice data constructor in all four of these types. Untyped splices never occur in (HsExpr GhcTc), and similarly -patterns etc. So we have +patterns etc, because the body of a untyped quotation is not typechecked. So we have type instance XUntypedSplice GhcTc = DataConCantHappen @@ -439,7 +455,7 @@ RENAMER (rnUntypedBracket): -* Set the ThStage to (Brack s (RnPendingUntyped ps_var)) +* Set the ThLevel to (Brack s (RnPendingUntyped ps_var)) * Rename the body @@ -456,9 +472,9 @@ The result is HsUntypedBracket - [PendingRnSplice UntypedExpSplice spn (g x :: LHsExpr GHcRn)] + [PendingRnSplice spn (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GHcRn))] (HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn) - (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn)))) + (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GhcRn)))) Note that a nested splice, such as the `$(g x)` now appears twice: - In the PendingRnSplice: this is the version that will later be typechecked @@ -471,14 +487,13 @@ [| let $e0 in (f :: $e1) $e2 (\ $e -> body ) |] + 1 Here $e0 is a declaration splice, $e1 is a type splice, $e2 is an -expression splice, and $e3 is a pattern splice. The `PendingRnSplice` -keeps track of which is which through its `UntypedSpliceFlavour` -field. +expression splice, and $e3 is a pattern splice. The `SpliceFlavour` is stored +in the extension field of HsUntypedSpliceExpr. TYPECHECKER (tcUntypedBracket): see also Note [Typechecking Overloaded Quotes] -* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice] - So PendingTcSplice is used for both typed and untyped splices. +* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice]. + PendingTcSplice is used for both typed and untyped splices. * Ignore the body of the bracket; just check that the context expects a bracket of that type (e.g. a [p| pat |] bracket should @@ -491,7 +506,7 @@ (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x :: LHsExpr GHcTc)] , hsb_quote = HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn) - (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))) + (HsUntypedSpliceExpr UntypedExpSplice (g x :: LHsExpr GhcRn))) }) (XQuote noExtField) @@ -499,7 +514,20 @@ have type (HsQuote GhcTc) is stubbed off with (XQuote noExtField). The payload is now in the hsb_quote field of the HsBracketTc. +------------------------------------- +Implicit lifting +------------------------------------- +When a variable is bound at level n and used at level n+1, the renamer will decide, +in `checkThLocalNameWithLift`, to implicitly lift this variable to level n+1. +This is done by replacing the occurrence of `x` with `$(lift x)`. +This decision is then stored in the extension points 'XXUntypedSplice'/'XXTypedSplice'. +When we come to typechecking these splices, the typechecker will emit the appropriate +'Lift' constraint, with a `ImplicitLiftOrigin` `CtOrigin`. If we fail to solve this constraint, +a level error is reported to the user. + + + ------------------------------------- Top-level untyped splices/quasiquotes ------------------------------------- @@ -531,8 +559,8 @@ Nested, typed splices ---------------------- When we typecheck a /typed/ bracket, we lift nested splices out as -`PendingTcSplice`, very similar to Note [PendingRnSplice]. Again, the -splice needs a SplicePointName, for the desguarer to use to connect +`PendingTcSplice`, very similar to Note [Pending Splices]. Again, the +splice needs a SplicePointName, for the desugarer to use to connect the splice expression with the point in the syntax tree where it is used. Example: [|| f $$(g 2)||] @@ -540,20 +568,20 @@ Parser: this is parsed as HsTypedBracket _ (HsApp (HsVar "f") - (HsTypedSplice _ (g 2 :: LHsExpr GhcPs))) + (HsTypedSplice _ (HsTypedSpliceExpr _ (g 2 :: LHsExpr GhcPs)))) RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn: HsTypedBracket _ (HsApp (HsVar "f") - (HsTypedSplice spn (g x :: LHsExpr GhcRn))) + (HsTypedSplice (HsTypedSpliceNested spn) (HsTypedSpliceExpr _ (g x :: LHsExpr GhcRn)))) TYPECHECKER (tcTypedBracket): -* Set the ThStage to (Brack s (TcPending ps_var lie_var)) +* Set the ThLevel to (Brack s (TcPending ps_var lie_var quote_wrapper)) -* Typecheck the body, and keep the elaborated result (despite never using it!) +* Typecheck the body, and keep the elaborated result (despite never using it!, todo: it should be stored in the AST) -* Nested splices (which must be typed) are typechecked by tcNestedSplice, and +* Nested splices (which must be typed) are typechecked by tcTypedSplice, and the results accumulated in ps_var; their constraints accumulate in lie_var * Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack @@ -640,13 +668,16 @@ ************************************************************************ -} +-- None of these functions add constraints to the LIE + tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr GhcTc) -tcTypedSplice :: Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -- None of these functions add constraints to the LIE +tcTypedSplice :: HsTypedSpliceResult -> HsTypedSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation + {- ************************************************************************ * * @@ -657,9 +688,9 @@ -- See Note [How brackets and nested splices are handled] tcTypedBracket rn_expr expr res_ty - = addErrCtxt (quotationCtxtDoc expr) $ - do { cur_stage <- getStage - ; ps_ref <- newMutVar [] + = addErrCtxt (TypedTHBracketCtxt expr) $ + do { cur_lvl <- getThLevel + ; ps_var <- newMutVar [] ; lie_var <- getConstraintVar -- Any constraints arising from nested splices -- should get thrown into the constraint set -- from outside the bracket @@ -671,18 +702,19 @@ -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring -- brackets. ; let wrapper = QuoteWrapper ev_var m_var + -- Typecheck expr to make sure it is valid. -- The typechecked expression won't be used, so we just discard it -- (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr) -- We'll typecheck it again when we splice it in somewhere - ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $ + ; (tc_expr, expr_ty) <- setThLevel (Brack cur_lvl (TcPending ps_var lie_var wrapper)) $ tcScalingUsage ManyTy $ -- Scale by Many, TH lifting is currently nonlinear (#18465) tcInferRhoNC expr -- NC for no context; tcBracket does that ; let rep = getRuntimeRep expr_ty - ; meta_ty <- tcTExpTy m_var expr_ty - ; ps' <- readMutVar ps_ref + ; meta_ty <- tcCodeTy m_var expr_ty + ; ps' <- readMutVar ps_var ; codeco <- tcLookupId unsafeCodeCoerceName ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty @@ -709,8 +741,8 @@ -- Match the expected type with the type of all the internal -- splices. They might have further constrained types and if they do -- we want to reflect that in the overall type of the bracket. - ; ps' <- case quoteWrapperTyVarTy <$> brack_info of - Just m_var -> mapM (tcPendingSplice m_var) ps + ; ps' <- case brack_info of + Just q -> mapM (tc_nested_splice q) ps Nothing -> assert (null ps) $ return [] -- Notice that we don't attempt to typecheck the body @@ -726,6 +758,9 @@ expected_type res_ty } + where + tc_nested_splice :: QuoteWrapper -> PendingRnSplice -> TcM PendingTcSplice + tc_nested_splice q (PendingRnSplice splice_name expr) = tcUntypedSplice q splice_name expr -- | A type variable with kind * -> * named "m" mkMetaTyVar :: TcM TyVar @@ -768,41 +803,117 @@ (PatBr {}) -> mkTy patTyConName -- Result type is m Pat (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" + +untypedSpliceResultType :: UntypedSpliceFlavour -> TcType -> TcM TcType +untypedSpliceResultType flavour meta_ty = do + sp_ty <- tcMetaTy sp_ty_name + return $ mkAppTy meta_ty sp_ty + where + sp_ty_name = case flavour of + UntypedExpSplice -> expTyConName + UntypedPatSplice -> patTyConName + UntypedTypeSplice -> typeTyConName + UntypedDeclSplice -> decsTyConName + --------------- -- | Typechecking a pending splice from a untyped bracket -tcPendingSplice :: TcType -- Metavariable for the expected overall type of the +-- TODO: Should return HsUntypedSplice GhcTc, and the desugarer should +-- construct the relevant CoreExpr rather than performing desugaring here. +tcUntypedSplice :: QuoteWrapper -- Metavariable for the expected overall type of the -- quotation. - -> PendingRnSplice + -> SplicePointName + -> HsUntypedSplice GhcRn -> TcM PendingTcSplice -tcPendingSplice m_var (PendingRnSplice flavour splice_name expr) +tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsUntypedSpliceExpr (HsUserSpliceExt flavour) expr) -- See Note [Typechecking Overloaded Quotes] - = do { meta_ty <- tcMetaTy meta_ty_name - -- Expected type of splice, e.g. m Exp - ; let expected_type = mkAppTy m_var meta_ty + = do { expected_type <- untypedSpliceResultType flavour m_var ; expr' <- tcScalingUsage ManyTy $ tcCheckPolyExpr expr expected_type -- Scale by Many, TH lifting is currently nonlinear (#18465) ; return (PendingTcSplice splice_name expr') } - where - meta_ty_name = case flavour of - UntypedExpSplice -> expTyConName - UntypedPatSplice -> patTyConName - UntypedTypeSplice -> typeTyConName - UntypedDeclSplice -> decsTyConName +tcUntypedSplice (QuoteWrapper _ m_var) splice_name (HsQuasiQuote (HsQuasiQuoteExt flavour) quoter s) = do + -- 1. Check that the quoter is of type 'QuasiQuoter' + qq_type <- mkTyConTy <$> tcLookupTyCon quasiQuoterTyConName + quoter' <- setSrcSpan (getLocA quoter) $ tcCheckId (unLoc quoter) (Check qq_type) + -- 2. Check that the quasi-quote has type Q Exp/Q Pat/Q Dec/Q Decs (as appropriate) + qTy <- mkTyConTy <$> tcLookupTyCon qTyConName + quote_ty <- untypedSpliceResultType flavour m_var + splice_ty <- untypedSpliceResultType flavour qTy + res_co <- unifyInvisibleType splice_ty quote_ty + + -- 3. Lookup the relevant field selector from QuasiQuoter + sel <- tcLookupId qq_sel_name + + -- 4. Apply the selector to the quasi-quoter + let expr' = mkLHsWrapCo res_co $ + nlHsApp (nlHsApp (nlHsVar sel) (noLocA quoter')) (nlHsLit (mkHsStringFS (unLoc s))) + + return (PendingTcSplice splice_name expr') + where + qq_sel_name = case flavour of + UntypedExpSplice -> quoteExpName + UntypedPatSplice -> quotePatName + UntypedTypeSplice -> quoteTypeName + UntypedDeclSplice -> quoteDecName + + -- Identifiers that are lifted implicitly, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the SplicePointName, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same SplicePointName, but that doesn't + -- matter, although it's a mite untidy. +tcUntypedSplice q splice_name (XUntypedSplice ils) + = do { let id_name = implicit_lift_lid ils + ; id_ty <- newOpenFlexiTyVarTy + ; let v_expr = noLocA (HsVar noExtField id_name) + ; v_expr' <- tcCheckMonoExpr v_expr id_ty + -- lift :: Quote m' => a -> m' Exp + ; lift <- setSrcSpan (getLocA id_name) $ + newMethodFromName (ImplicitLiftOrigin ils) + GHC.Builtin.Names.TH.liftName + [getRuntimeRep id_ty, id_ty] + ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr' + + ; return (PendingTcSplice splice_name res) } + +tcPendingSpliceTyped :: QuoteWrapper -> SplicePointName -> HsTypedSplice GhcRn -> ExpRhoType -> TcM PendingTcSplice +tcPendingSpliceTyped q@(QuoteWrapper _ m_var) splice_name (HsTypedSpliceExpr _ expr) res_ty + = do { res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty + ; meta_exp_ty <- tcCodeTy m_var res_ty + ; expr' <- tcCheckMonoExpr expr meta_exp_ty + ; untype_code <- tcLookupId unTypeCodeName + ; let expr'' = mkHsApp + (mkLHsWrap (applyQuoteWrapper q) + (nlHsTyApp untype_code [rep, res_ty])) expr' + ; return (PendingTcSplice splice_name expr'') } +tcPendingSpliceTyped q splice_name (XTypedSplice ils) res_ty + = do { let id_name = implicit_lift_lid ils + ; res_ty <- expTypeToType res_ty + ; let rep = getRuntimeRep res_ty + ; let v_expr = noLocA (HsVar noExtField id_name) + ; v_expr' <- tcCheckMonoExpr v_expr res_ty + -- lift :: Quote m' => a -> m' Exp + ; lift <- setSrcSpan (getLocA id_name) $ + newMethodFromName (ImplicitLiftOrigin ils) + GHC.Builtin.Names.TH.liftName + [rep, res_ty] + ; let res = nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift)) v_expr' + ; return (PendingTcSplice splice_name res) } + + --------------- -- Takes a m and tau and returns the type m (TExp tau) -tcTExpTy :: TcType -> TcType -> TcM TcType -tcTExpTy m_ty exp_ty +tcCodeTy :: TcType -> TcType -> TcM TcType +tcCodeTy m_ty exp_ty = do { unless (isTauTy exp_ty) $ addErr $ TcRnTHError $ TypedTHError $ TypedTHWithPolyType exp_ty ; codeCon <- tcLookupTyCon codeTyConName ; let rep = getRuntimeRep exp_ty - ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } - -quotationCtxtDoc :: LHsExpr GhcRn -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (thTyBrackets . ppr $ br_body) + ; return (mkTyConApp codeCon [m_ty, rep, exp_ty]) } -- The whole of the rest of the file is the else-branch (ie stage2 only) @@ -816,20 +927,45 @@ ************************************************************************ -} -tcTypedSplice splice_name expr res_ty - = addErrCtxt (typedSpliceCtxtDoc splice_name expr) $ - setSrcSpan (getLocA expr) $ do - { stage <- getStage - ; case stage of - Splice {} -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend splice_name expr res_ty - RunSplice _ -> - -- See Note [RunSplice ThLevel] in "GHC.Tc.Types". - pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ - "running another splice") (pprTypedSplice (Just splice_name) expr) - Comp -> tcTopSplice expr res_ty - } +-- getUntypedSpliceBody: the renamer has expanded the splice. +-- Just run the finalizers that it produced, and return +-- the renamed expression +getUntypedSpliceBody (HsUntypedSpliceTop { utsplice_result_finalizers = mod_finalizers + , utsplice_result = rn_expr }) + = do { addModFinalizersWithLclEnv mod_finalizers + ; return rn_expr } +getUntypedSpliceBody (HsUntypedSpliceNested {}) + = panic "tcTopUntypedSplice: invalid nested splice" +tcTypedSplice HsTypedSpliceTop ctxt@(HsTypedSpliceExpr _ expr) res_ty + = addErrCtxt (TypedSpliceCtxt Nothing ctxt) $ + setSrcSpan (getLocA expr) $ + tcTopSplice expr res_ty +tcTypedSplice (HsTypedSpliceNested sp) expr res_ty + -- The expr is checked in tcPendingSpliceTyped + = addErrCtxt (TypedSpliceCtxt (Just sp) expr) $ + setSrcSpan loc $ do + lvl <- getThLevel + case lvl of + Brack _ (TcPending ps_var lie_var q) -> do + tc_splice <- setConstraintVar lie_var $ tcPendingSpliceTyped q sp expr res_ty + updTcRef ps_var (tc_splice : ) + -- stubNestedSplice: the returned expression is ignored; it's in the pending splices. + -- + -- Unfortunately, this means that tooling that works with typechecked + -- expressions will not be able to identify where the nested splices are. + -- Instead, we should modify the extension point of HsTypedSplice, in + -- order to propagate the result of typechecking. + + return stubNestedSplice + _ -> panic "tcTypedSplice: invalid level" + where + loc = case expr of + HsTypedSpliceExpr _ expr -> getLocA expr + XTypedSplice (HsImplicitLiftSplice _ _ _ expr) -> getLocA expr +tcTypedSplice _ _ _ = panic "tcTypedSplice: invalid splice" + + {- Note [Collecting modFinalizers in typed splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local @@ -848,13 +984,13 @@ res_ty <- expTypeToType res_ty ; q_type <- tcMetaTy qTyConName -- Top level splices must still be of type Q (TExp a) - ; meta_exp_ty <- tcTExpTy q_type res_ty + ; meta_exp_ty <- tcCodeTy q_type res_ty ; q_expr <- tcTopSpliceExpr Typed $ tcCheckMonoExpr expr meta_exp_ty ; lcl_env <- getLclEnv ; let delayed_splice = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsTypedSplice delayed_splice q_expr) + ; return (HsTypedSplice delayed_splice (HsTypedSpliceExpr noExtField q_expr)) } @@ -872,7 +1008,8 @@ tcTopSpliceExpr isTypedSplice tc_action = checkNoErrs $ -- checkNoErrs: must not try to run the thing -- if the type checker fails! - setStage (Splice isTypedSplice) $ + + setThLevel (Splice isTypedSplice Comp) $ do { -- Typecheck the expression (mb_expr', wanted) <- tryCaptureConstraints tc_action -- If tc_action fails (perhaps because of insoluble constraints) @@ -887,32 +1024,6 @@ Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' } ------------------ -tcNestedSplice :: ThStage -> PendingStuff -> Name - -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -- See Note [How brackets and nested splices are handled] - -- A splice inside brackets -tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty - = do { res_ty <- expTypeToType res_ty - ; let rep = getRuntimeRep res_ty - ; meta_exp_ty <- tcTExpTy m_var res_ty - ; expr' <- setStage pop_stage $ - setConstraintVar lie_var $ - tcCheckMonoExpr expr meta_exp_ty - ; untype_code <- tcLookupId unTypeCodeName - ; let expr'' = mkHsApp - (mkLHsWrap (applyQuoteWrapper q) - (nlHsTyApp untype_code [rep, res_ty])) expr' - ; ps <- readMutVar ps_var - ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps) - - -- The returned expression is ignored; it's in the pending splices - ; return stubNestedSplice } - -tcNestedSplice _ _ splice_name _ _ - = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) - - ------------------- -- This is called in the zonker -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) @@ -923,7 +1034,7 @@ -- See Note [Collecting modFinalizers in typed splices]. ; modfinalizers_ref <- newTcRef [] -- Run the expression - ; expr2 <- setStage (RunSplice modfinalizers_ref) $ + ; expr2 <- setThLevel (RunSplice modfinalizers_ref) $ runMetaE zonked_q_expr ; mod_finalizers <- readTcRef modfinalizers_ref ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers @@ -939,7 +1050,7 @@ -- These steps should never fail; this is a *typed* splice ; (res, wcs) <- captureConstraints $ - addErrCtxt (spliceResultDoc zonked_q_expr) $ do + addErrCtxt (TypedSpliceResultCtxt zonked_q_expr) $ do { (exp3, _fvs) <- rnLExpr expr2 ; tcCheckMonoExpr exp3 zonked_ty } ; ev <- simplifyTop wcs @@ -955,24 +1066,13 @@ ************************************************************************ -} -typedSpliceCtxtDoc :: SplicePointName -> LHsExpr GhcRn -> SDoc -typedSpliceCtxtDoc n splice - = hang (text "In the Template Haskell splice") - 2 (pprTypedSplice (Just n) splice) - -spliceResultDoc :: LHsExpr GhcTc -> SDoc -spliceResultDoc expr - = sep [ text "In the result of the splice:" - , nest 2 (text "$$" <> ppr expr) - , text "To see what the splice expanded to, use -ddump-splices"] - stubNestedSplice :: HsExpr GhcTc -- Used when we need a (LHsExpr GhcTc) that we are never going -- to look at. We could use "panic" but that's confusing if we ever -- do a debug-print. The warning is because this should never happen -- /except/ when doing debug prints. stubNestedSplice = warnPprTrace True "stubNestedSplice" empty $ - HsLit noComments (mkHsString "stubNestedSplice") + HsLit noExtField (mkHsString "stubNestedSplice") {- @@ -1002,8 +1102,8 @@ ; let loc' = noAnnSrcSpan loc ; let specialised_to_annotation_wrapper_expr = L loc' (mkHsWrap wrapper - (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id))) - ; return (L loc' (HsApp noComments + (mkHsVar (L (noAnnSrcSpan loc) to_annotation_wrapper_id))) + ; return (L loc' (HsApp noExtField specialised_to_annotation_wrapper_expr expr')) }) @@ -1034,11 +1134,7 @@ -- annotation are exposed at this point. This is also why we are -- doing all this stuff inside the context of runMeta: it has the -- facilities to deal with user error in a meta-level expression - seqSerialized serialized `seq` serialized - --- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms -seqSerialized :: Serialized -> () -seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () + rnf serialized `seq` serialized #endif @@ -1082,16 +1178,17 @@ runQResult :: (a -> String) - -> (Origin -> SrcSpan -> a -> b) + -> (EnumSet LangExt.Extension -> Origin -> SrcSpan -> a -> b) -> (ForeignHValue -> TcM a) -> SrcSpan -> ForeignHValue {- TH.Q a -} -> TcM b runQResult show_th f runQ expr_span hval - = do { th_result <- runQ hval + = do { exts <- fmap extensionFlags getDynFlags + ; th_result <- runQ hval ; th_origin <- getThSpliceOrigin ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f th_origin expr_span th_result) } + ; return (f exts th_origin expr_span th_result) } ----------------- @@ -1190,8 +1287,6 @@ -> TcM hs_syn -- Of type t runMeta' show_code ppr_hs run_and_convert expr = do { traceTc "About to run" (ppr expr) - ; recordThSpliceUse -- seems to be the best place to do this, - -- we catch all kinds of splices and annotations. -- Check that we've had no errors of any sort so far. -- For example, if we found an error in an earlier defn f, but @@ -1270,7 +1365,7 @@ fail_with_exn phase exn = do exn_msg <- liftIO $ Panic.safeShowException exn failWithTc $ TcRnTHError $ THSpliceFailed $ - SpliceThrewException phase (SomeException exn) exn_msg expr show_code + SpliceThrewException phase (toException exn) exn_msg expr show_code {- Note [Running typed splices in the zonker] @@ -1436,9 +1531,10 @@ liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix qAddTopDecls thds = do + exts <- fmap extensionFlags getDynFlags l <- getSrcSpanM th_origin <- getThSpliceOrigin - let either_hval = convertToHsDecls th_origin l thds + let either_hval = convertToHsDecls exts th_origin l thds ds <- case either_hval of Left exn -> failWithTc $ TcRnTHError $ AddTopDeclsError $ AddTopDeclsRunSpliceFailure exn @@ -1550,7 +1646,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 @@ -1566,7 +1663,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 @@ -1647,15 +1745,15 @@ -- | Adds a mod finalizer reference to the local environment. addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () addModFinalizerRef finRef = do - th_stage <- getStage - case th_stage of + th_lvl <- getThLevel + case th_lvl of RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) -- This case happens only if a splice is executed and the caller does - -- not set the 'ThStage' to 'RunSplice' to collect finalizers. + -- not set the 'ThLevel' to 'RunSplice' to collect finalizers. -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. _ -> pprPanic "addModFinalizer was called when no finalizers were collected" - (ppr th_stage) + (ppr th_lvl) -- | Releases the external interpreter state. finishTH :: TcM () @@ -1877,14 +1975,14 @@ -- ^ Returns 'Left' in the case that the instances were found to -- be class instances, or 'Right' if they are family instances. reifyInstances' th_nm th_tys - = addErrCtxt (text "In the argument of reifyInstances:" - <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $ - do { loc <- getSrcSpanM + = addErrCtxt (ReifyInstancesCtxt th_nm th_tys) $ + do { exts <- fmap extensionFlags getDynFlags + ; loc <- getSrcSpanM ; th_origin <- getThSpliceOrigin - ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) + ; rdr_ty <- cvt exts th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys) -- #9262 says to bring vars into scope, like in HsForAllTy case -- of rnHsTyKi - ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty + ; tv_rdrs <- filterInScopeM $ extractHsTyRdrTyVars rdr_ty -- Rename to HsType Name ; ((tv_names, rn_ty), _fvs) <- checkNoErrs $ -- If there are out-of-scope Names here, then we @@ -1917,7 +2015,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 @@ -1925,11 +2023,11 @@ ; return $ Right (tc, map fim_instance matches) } _ -> bale_out $ TcRnTHError $ THReifyError $ CannotReifyInstance ty } where - doc = ClassInstanceCtx + doc = ReifyInstancesCtx bale_out msg = failWithTc msg - cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) - cvt origin loc th_ty = case convertToHsType origin loc th_ty of + cvt :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs) + cvt exts origin loc th_ty = case convertToHsType exts origin loc th_ty of Left msg -> failWithTc (TcRnTHError $ THSpliceFailed $ RunSpliceFailure msg) Right ty -> return ty @@ -1977,8 +2075,7 @@ getThSpliceOrigin :: TcM Origin getThSpliceOrigin = do warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return (Generated SkipPmc) - + if warn then return FromSource else return (Generated OtherExpansion SkipPmc) getThing :: TH.Name -> TcM TcTyThing getThing th_name @@ -2010,7 +2107,8 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name - = do { let guesses = thRdrNameGuesses th_name + = do { listTuplePuns <- xoptM LangExt.ListTuplePuns + ; let guesses = thRdrNameGuesses listTuplePuns th_name ; case guesses of { [for_sure] -> lookupSameOccRn_maybe for_sure ; _ -> @@ -2273,13 +2371,21 @@ ret_con | null ex_tvs' && null theta' = return main_con | otherwise = do { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVarBndrs ex_tvs' + ; ex_tvs'' <- case to_invis_bndrs ex_tvs' of + Nothing -> noTH DataConVisibleForall (dataConDisplayType False dc) + Just tvs -> reifyTyVarBndrs tvs ; return (TH.ForallC ex_tvs'' cxt main_con) } ; assert (r_arg_tys `equalLength` dcdBangs) ret_con } where - mk_specified tv = Bndr tv SpecifiedSpec + mk_specified tv = Bndr tv Specified + to_invis_bndrs :: [TyVarBinder] -> Maybe [InvisTVBinder] + to_invis_bndrs = traverse $ \(Bndr tv vis) -> + case vis of + Invisible spec -> Just (Bndr tv spec) + Required -> Nothing + subst_tv_binders subst tv_bndrs = let tvs = binderVars tv_bndrs flags = binderFlags tv_bndrs @@ -2803,7 +2909,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 @@ -2873,22 +2979,18 @@ 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 iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod - let usages = [modToTHMod m | usage <- mi_usages iface, - Just m <- [usageToModule (moduleUnit reifMod) usage] ] + let IfaceTopEnv _ imports = mi_top_env iface + -- Convert IfaceImport to module names + usages = [modToTHMod (ifImpModule imp) | imp <- imports] return $ TH.ModuleInfo usages - usageToModule :: Unit -> Usage -> Maybe Module - usageToModule _ (UsageFile {}) = Nothing - usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn - usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m - usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m - usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn + ------------------------------ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys @@ -2896,12 +2998,126 @@ noTH :: UnrepresentableTypeDescr -> Type -> TcM a noTH s d = failWithTc $ TcRnTHError $ THReifyError $ CannotRepresentType s d -ppr_th :: TH.Ppr a => a -> SDoc -ppr_th x = text (TH.pprint x) - tcGetInterp :: TcM Interp tcGetInterp = do hsc_env <- getTopEnv 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. diff --git a/GHC/Tc/Gen/Splice.hs-boot b/GHC/Tc/Gen/Splice.hs-boot --- a/GHC/Tc/Gen/Splice.hs-boot +++ b/GHC/Tc/Gen/Splice.hs-boot @@ -10,11 +10,11 @@ import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) -import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers ) -import qualified Language.Haskell.TH as TH +import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers, HsUntypedSpliceResult, HsTypedSpliceResult, HsTypedSplice ) +import qualified GHC.Boot.TH.Syntax as TH -tcTypedSplice :: Name - -> LHsExpr GhcRn +tcTypedSplice :: HsTypedSpliceResult + -> HsTypedSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) @@ -30,7 +30,8 @@ runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +getUntypedSpliceBody :: HsUntypedSpliceResult (HsExpr GhcRn) -> TcM (HsExpr GhcRn) tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) diff --git a/GHC/Tc/Instance/Class.hs b/GHC/Tc/Instance/Class.hs --- a/GHC/Tc/Instance/Class.hs +++ b/GHC/Tc/Instance/Class.hs @@ -1,19 +1,17 @@ - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Instance.Class ( matchGlobalInst, matchEqualityInst, ClsInstResult(..), InstanceWhat(..), safeOverlap, instanceReturnsDictCon, - AssocInstInfo(..), isNotAssociated + AssocInstInfo(..), isNotAssociated, + lookupHasFieldLabel ) where import GHC.Prelude import GHC.Driver.DynFlags -import GHC.Core.TyCo.Rep - import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType @@ -21,22 +19,28 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping) -import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) -import GHC.Rename.Env( addUsedGRE, DeprecationWarnings (..) ) +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcLookupDataFamInst, FamInstEnvs ) +import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) + import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Builtin.Names +import GHC.Builtin.PrimOps ( PrimOp(..) ) +import GHC.Builtin.PrimOps.Ids ( primOpId ) import GHC.Types.FieldLabel -import GHC.Types.Name.Reader import GHC.Types.SafeHaskell import GHC.Types.Name ( Name ) +import GHC.Types.Name.Reader import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id +import GHC.Types.Id.Info import GHC.Types.Var +import GHC.Core.TyCo.Rep import GHC.Core.Predicate import GHC.Core.Coercion import GHC.Core.InstEnv @@ -45,16 +49,24 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core ( Expr(..), mkConApp ) -import GHC.Core ( Expr(Var, App, Cast) ) +import GHC.StgToCmm.Closure ( isSmallFamily ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) import GHC.Data.FastString +import GHC.Unit.Module.Warnings + +import GHC.Hs.Extension + import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Tc.Errors.Types +import Data.Maybe + {- ******************************************************************* * * A helper for associated types within @@ -92,10 +104,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 @@ -122,23 +135,29 @@ matchGlobalInst :: DynFlags -> Bool -- True <=> caller is the short-cut solver -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult + -> Class -> [Type] -> Maybe CtLoc + -> TcM ClsInstResult -- Precondition: Class does not satisfy GHC.Core.Predicate.isEqualityClass -- (That is handled by a separate code path: see GHC.Tc.Solver.Dict.solveDict, -- which calls solveEqualityDict for equality classes.) -matchGlobalInst dflags short_cut clas tys +matchGlobalInst dflags short_cut clas tys mb_loc | cls_name == knownNatClassName = matchKnownNat dflags short_cut clas tys | cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys | cls_name == knownCharClassName = matchKnownChar dflags short_cut clas tys | isCTupleClass clas = matchCTuple clas tys | cls_name == typeableClassName = matchTypeable clas tys | cls_name == withDictClassName = matchWithDict tys - | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys - | cls_name == unsatisfiableClassName = return NoInstance -- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors + | cls_name == dataToTagClassName = matchDataToTag clas tys + | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys mb_loc + | cls_name == unsatisfiableClassName = matchUnsatisfiable | otherwise = matchInstEnv dflags short_cut clas tys where cls_name = className clas +matchUnsatisfiable :: TcM ClsInstResult +-- See (B) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors +matchUnsatisfiable + = return NoInstance {- ******************************************************************** * * @@ -177,12 +196,13 @@ | otherwise -> 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 - ; match_one (null unsafeOverlaps) canonical dfun_id inst_tys } + ; match_one (null unsafeOverlaps) canonical dfun_id inst_tys warn } -- More than one matches (or Safe Haskell fail!). Defer any -- reactions of a multitude until we learn more about the reagent @@ -193,9 +213,9 @@ where pred = mkClassPred clas tys -match_one :: SafeOverlapping -> Canonical -> DFunId -> [DFunInstType] - -> TcM ClsInstResult -match_one so canonical dfun_id mb_inst_tys +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) ; (tys, theta) <- instDFunType dfun_id mb_inst_tys ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta) @@ -203,8 +223,8 @@ , cir_mk_ev = evDFunApp dfun_id tys , cir_canonical = canonical , cir_what = TopLevInstance { iw_dfun_id = dfun_id - , iw_safe_over = so } } } - + , iw_safe_over = so + , iw_warn = warn } } } {- Note [Shortcut solving: overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -236,13 +256,10 @@ matchCTuple :: Class -> [Type] -> TcM ClsInstResult matchCTuple clas tys -- (isCTupleClass clas) holds = return (OneInst { cir_new_theta = tys - , cir_mk_ev = tuple_ev - , cir_canonical = True + , cir_mk_ev = evDictApp clas tys + , cir_canonical = EvCanonical , cir_what = BuiltinInstance }) -- The dfun *is* the data constructor! - where - data_con = tyConSingleDataCon (classTyCon clas) - tuple_ev = evDFunApp (dataConWrapId data_con) tys {- ******************************************************************** * * @@ -380,8 +397,8 @@ makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult -- makeLitDict adds a coercion that will convert the literal into a dictionary --- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] --- in GHC.Tc.Types.Evidence. The coercion happens in 2 steps: +-- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit]. +-- The coercion happens in 2 steps: -- -- Integer -> SNat n -- representation of literal to singleton -- SNat n -> KnownNat n -- singleton to dictionary @@ -389,26 +406,26 @@ -- The process is mirrored for Symbols: -- String -> SSymbol n -- SSymbol n -> KnownSymbol n -makeLitDict clas ty et - | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] - -- co_dict :: KnownNat n ~ SNat n - , [ meth ] <- classMethods clas - , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth) - -- If the method type is forall n. KnownNat n => SNat n - -- then tcRep is SNat - , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - -- SNat n ~ Integer - , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep)) - = return $ OneInst { cir_new_theta = [] - , cir_mk_ev = \_ -> ev_tm - , cir_canonical = True - , cir_what = BuiltinInstance } +makeLitDict clas lit_ty lit_expr + | [meth] <- classMethods clas + , Just rep_tc <- tyConAppTyCon_maybe (classMethodTy meth) + -- If the method type is forall n. KnownNat n => SNat n + -- then rep_tc :: TyCon is SNat + , [rep_con] <- tyConDataCons rep_tc + = do { let mk_ev _ = evDictApp clas [lit_ty] $ + [mkConApp rep_con [Type lit_ty, lit_expr]] + ; return $ OneInst { cir_new_theta = [] + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } } - | otherwise - = pprPanic "makeLitDict" $ - text "Unexpected evidence for" <+> ppr (className clas) - $$ vcat (map (ppr . idType) (classMethods clas)) + | otherwise + = pprPanic "makeLitDict" $ + text "Unexpected evidence for" <+> ppr (className clas) + $$ vcat (map (ppr . idType) (classMethods clas)) + + {- ******************************************************************** * * Class lookup for WithDict @@ -417,40 +434,35 @@ -- See Note [withDict] matchWithDict :: [Type] -> TcM ClsInstResult -matchWithDict [cls, mty] - -- Check that cls is a class constraint `C t_1 ... t_n`, where +matchWithDict [cls_ty, mty] + -- Check that cls_ty is a class constraint `C t_1 ... t_n`, where -- `dict_tc = C` and `dict_args = t_1 ... t_n`. - | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls + | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls_ty -- Check that C is a class of the form -- `class C a_1 ... a_n where op :: meth_ty` - -- and in that case let - -- co :: C t1 ..tn ~R# inst_meth_ty - , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args + , Just (cls, dict_dc) <- isUnaryClassTyCon_maybe dict_tc + , [inst_meth_ty] <- dataConInstArgTys dict_dc dict_args = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty - ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy) + ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls_ty openAlphaTy) + ; wd_cls <- tcLookupClass withDictClassName - -- Given co2 : mty ~N# inst_meth_ty, construct the method of + -- Given ev_expr : mty ~N# inst_meth_ty, construct the method of -- the WithDict dictionary: -- -- \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> - -- k (sv |> (sub co ; sym co2)) - ; let evWithDict co2 = - mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ - Var k - `App` - (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co)) + -- k (MkC tys (sv |> sub co2)) + ; let evWithDict ev_expr + = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ + Var k `App` (evUnaryDictAppE cls dict_args meth_arg) + where + meth_arg = Var sv `Cast` mkSubCo (evExprCoercion ev_expr) - ; tc <- tcLookupTyCon withDictClassName - ; let Just withdict_data_con - = tyConSingleDataCon_maybe tc -- "Data constructor" - -- for WithDict - mk_ev [c] = evDataConApp withdict_data_con - [cls, mty] [evWithDict (evTermCoercion (EvExpr c))] + ; let mk_ev [c] = evDictApp wd_cls [cls_ty, mty] [evWithDict c] mk_ev e = pprPanic "matchWithDict" (ppr e) - ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty] + ; return $ OneInst { cir_new_theta = [mkNomEqPred mty (scaledThing inst_meth_ty)] , cir_mk_ev = mk_ev - , cir_canonical = False -- See (WD6) in Note [withDict] + , cir_canonical = EvNonCanonical -- See (WD6) in Note [withDict] , cir_what = BuiltinInstance } } @@ -501,11 +513,11 @@ instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) -> - k (sv |> (sub co2 ; sym co)) + k (MkC (sv |> sub co))) That is, it matches on the first (constraint) argument of C; if C is a single-method class, the instance "fires" and emits an equality -constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`. +constraint `mty ~# inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`. The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`. The coercion `co` is a newtype coercion that coerces from `C t1 ... tn` @@ -598,7 +610,332 @@ overloaded function `f` (e.g. with a type such as `f :: Eq a => ...`). See test-case T21575b. +-} + +{- ******************************************************************** +* * + Class lookup for DataToTag +* * +***********************************************************************-} + +matchDataToTag :: Class -> [Type] -> TcM ClsInstResult +-- See Note [DataToTag overview] +matchDataToTag dataToTagClass [levity, dty] = do + famEnvs <- tcGetFamInstEnvs + (gbl_env, _lcl_env) <- getEnvs + platform <- getPlatform + if | isConcreteType levity -- condition C3 + , Just (rawTyCon, rawTyConArgs) <- tcSplitTyConApp_maybe dty + , let (repTyCon, repArgs, repCo) + = tcLookupDataFamInst famEnvs rawTyCon rawTyConArgs + + -- Condition C1 + , Just constrs <- tyConDataCons_maybe repTyCon + , not (isTypeDataTyCon repTyCon || isNewTyCon repTyCon) + + -- Condition C2 + , let rdr_env = tcg_rdr_env gbl_env + inScope con = isJust $ lookupGRE_Name rdr_env $ dataConName con + , all inScope constrs + + , let repTy = mkTyConApp repTyCon repArgs + numConstrs = tyConFamilySize repTyCon + !whichOp -- see wrinkle DTW4 + | isSmallFamily platform numConstrs + = primOpId DataToTagSmallOp + | otherwise + = primOpId DataToTagLargeOp + + -- See wrinkle DTW1; we must apply the underlying + -- operation at the representation type and cast it + methodRep = Var whichOp `App` Type levity `App` Type repTy + methodCo = mkFunCo Representational + FTF_T_T + (mkNomReflCo ManyTy) + (mkSymCo repCo) + (mkReflCo Representational intPrimTy) + -> do { addUsedDataCons rdr_env repTyCon -- See wrinkles DTW2 and DTW3 + ; let mk_ev _ = evDictApp dataToTagClass [levity, dty] $ + [methodRep `Cast` methodCo] + ; pure (OneInst { cir_new_theta = [] -- (Ignore stupid theta.) + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance })} + | otherwise -> pure NoInstance + +matchDataToTag _ _ = pure NoInstance + + +{- Note [DataToTag overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class `DataToTag` is defined like this, in GHC.Magic: + + type DataToTag :: forall {lev :: Levity}. + TYPE (BoxedRep lev) -> Constraint + class DataToTag a where + dataToTag# :: a -> Int# + +`dataToTag#`, evaluates its argument and returns the index of the data +constructor used to build that argument. Clearly, `dataToTag#` cannot +work on /any/ type, only on data types, hence the type-class constraint. + +Users cannot define instances of `DataToTag` +(see `GHC.Tc.Validity.check_special_inst_head`). +Instead, GHC's constraint solver has built-in solving behaviour, + implemented in `GHC.Tc.Instance.Class.matchGlobalInst`. + +(#20441: This common handling of special typeclasses is a bit of a +mess and could use some love, and a dedicated Note.) + +GHC solves a wanted constraint `DataToTag @{lev} dty` +when all of the following conditions are met: + +C1: `dty` is an algebraic data type, i.e. `dty` matches any of: + * a "data" declaration, + * a "data instance" declaration, + * a boxed tuple type + But NOT + * A "type data" declaration; see also wrinkle W2c + of Note [Type data declarations] in GHC.Rename.Module. + * A newtype; in principle we could accept newtypes that wrap + an algebraic data type, but we do not do so. + +C2: All of the constructors of that "data" or "data instance" + declaration are in scope. Otherwise, `dataToTag#` could be + used to peek behind the curtain when used with an abstract + data type whose constructors are intentionally hidden. + +C3: `lev` is statically known, either Lifted or Unlifted: + Otherwise the argument to `dataToTag#` would be + representation-polymorphic and we couldn't do anything + with it without Core Lint rightfully complaining. + This guarantees invariant (DTT1) below. + +It would be possible for GHC to generate custom code for each type, like +this: + + instance DataToTag [a] where + dataToTag# [] = 0# + dataToTag# (_:_) = 1# + +But, to avoid all this boilerplate code, and improve optimisation opportunities, +GHC generates instances like this: + + instance DataToTag [a] where + dataToTag# = dataToTagSmall# + +using one of two dedicated primops: `dataToTagSmall#` and `dataToTagLarge#`. +(Why two primops? What's the difference? See wrinkles DTW4 and DTW5.) +Both primops have the following over-polymorphic type: + + dataToTagLarge# :: forall {l::levity} (a::TYPE (BoxedRep l)). a -> Int# + +Every call to either primop that we generate should look like +(dataToTagSmall# @{lev} @ty) with two type arguments that satisfy +these conditions: + +(DTT1) `lev` is concrete (either lifted or unlifted), not polymorphic. + This is an invariant--we must satisfy this or Core Lint will complain. + (This falls under situation 1 in GHC.Core.Lint's + Note [Linting representation-polymorphic builtins].) + +(DTT2) `ty` is always headed by a TyCon corresponding to one of the following: + * A boxed tuple + * A "data" declaration (but NOT a "type data" declaration) + * The /representation type/ for a "data instance" declaration + (but NOT the data family TyCon itself) + + This ensures that the DataCons associated with `ty` are easily + accessible and safe to use in Core without running afoul of + invariant I1 from Note [Type data declarations] in + GHC.Rename.Module. See Note [caseRules for dataToTag] in + GHC.Core.Opt.ConstantFold for why this matters. + + While wrinkle DTW7 is unresolved, this cannot be a true invariant. + But with a little effort we can ensure that every primop + call we generate in a DataToTag instance satisfies this condition. + +(DTT3) If the TyCon in wrinkle DTT2 is a "large data type" with more + constructors than fit in pointer tags on the target, then the + primop must be dataToTagLarge# and not dataToTagSmall#. + Otherwise, the primop must be dataToTagSmall# and not dataToTagLarge#. + (See wrinkles DTW4 and DTW5.) + +These two primops have special handling in several parts of +the compiler: + +H1. They have a couple of built-in rewrite rules, implemented in + GHC.Core.Opt.ConstantFold.dataToTagRule + +H2. The simplifier rewrites most case expressions scrutinizing their results. + See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold. + +H3. Each evaluates its argument. But we want to omit this eval when the + actual argument is already evaluated and properly tagged. To do this, + + * We have a special case in GHC.Stg.EnforceEpt.Rewrite.rewriteOpApp + ensuring that any inferred tag information on the argument is + retained until code generation. + + * We generate code via special cases in GHC.StgToCmm.Expr.cgExpr + instead of with the other primops in GHC.StgToCmm.Prim.emitPrimOp; + tag info is not readily available in the latter function. + (Wrinkle DTW4 describes what we generate after the eval.) + +Wrinkles: + +(DTW1) To guarantee (DTT2) we need to take care with data families. + Consider data family D a + data instance D (Either p q) = D1 | D2 p q + To solve the constraint + [W] DataToTag (D (Either t1 t2)) + GHC uses the built-in instance + instance DataToTag (D (Either p q)) where + dataToTag# x = dataToTagSmall# @Lifted @(R:DEither p q) + (x |> sym (ax:DEither p q)) + where `ax:DEither` is the axiom arising from the `data instance`: + ax:DEither p q :: D (Either p q) ~ R:DEither p q + + Notice that we cast `x` before giving it to `dataToTagSmall#`, so + that (DTT2) is satisfied. + +(DTW2) Suppose we have module A (T(..)) where { data T = TCon } + and in module B, the constraint `DataToTag T` is needed. Per + condition C2, we only solve this constraint if `TCon` is in + scope. So we had better not later report a warning about the + import of `TCon` being unused in module B! + + To avoid this simply call `addUsedDataCons` when creating a built-in + DataToTag instance. + +(DTW3) Similar to DTW2, consider this example: + + {-# LANGUAGE MagicHash #-} + module A (X(X2, X3), g) where + -- see also testsuite/tests/warnings/should_compile/DataToTagWarnings.hs + import GHC.Exts (dataToTag#, Int#) + data X = X1 | X2 | X3 | X4 + g :: X -> Int# + g X2 = 12# + g v = dataToTag# v + + QUESTION: What warnings should be emitted with -Wunused-top-binds? + + The X1 and X4 constructors are used only in the solving of a + `DataToTag X` constraint in the second equation for `g`. But if + these constructors were just removed, they would not be needed for + the solving of that `DataToTag X` constraint! So for now we take + the stance that both X1 and X4 should be reported as unused. + + It's not entirely clear if this is the right behavior: + Notice that removing X1 changes the value of `g X3` from 2# to 1#. + (Removing X4 causes no observable change in behavior.) + But this is a very obscure program! The current "warn about both" + approach is not obviously wrong, either, and is consistent with the + behavior of derived Ix instances. + + To get these warnings, we do nothing; in particular we do not call + keepAlive on the constructor names. + (Contrast with Note [Unused name reporting and HasField].) + +(DTW4) Why have two primops, `dataToTagSmall#` and `dataToTagLarge#`? + The way tag information is stored at runtime is described in + Note [Tagging big families] in GHC.StgToCmm.Expr. In particular, + for "big data types" we must consult the heap object's info table at + least in the mAX_PTR_TAG case, while for "small data types" we can + always just examine the tag bits on the pointer itself. So: + + * dataToTagSmall# consults the tag bits in the pointer, ignoring the + info table. It should, therefore, be used only for data type with + few enough constructors that the tag always fits in the pointer. + + * dataToTagLarge# also consults the tag bits in the pointer, but + must fall back to examining the info table whenever those tag + bits are equal to mAX_PTR_TAG. + + One could imagine having one primop with a small/large tag, or just + the data type width, but the PrimOp data type is not currently set + up for that. Looking at the type information on the argument during + code generation is also possible, but would be less reliable. + Remember: type information is not always preserved in STG. + +(DTW5) How do the two primops differ in their semantics? We consider + a call `dataToTagSmall# x` to result in undefined behavior whenever + the target supports pointer tagging but the actual constructor index + for `x` is too large to fit in the pointer's tag bits. Otherwise, + `dataToTagSmall#` behaves identically to `dataToTagLarge#`. + + This allows the rewrites performed in GHC.Core.Opt.ConstantFold to + safely treat `dataToTagSmall#` identically to `dataToTagLarge#`: + the allowed program behaviors for the former is always a superset of + the allowed program behaviors for the latter. + + This undefined behavior is only observable if a user writes a + wrongly-sized primop call. The calls we generate are properly-sized + (condition DTT3 above) so that the type system protects us. + +(DTW6) We make no promises about the primops used to implement + DataToTag instances. Changes to GHC's representation of algebraic + data types at runtime may force us to redesign these primops. + Indeed, accommodating such changes without breaking users of the + original (no longer existing) "dataToTag#" primop is one of the + main reasons the DataToTag class exists! + + In particular, our current two primop implementations (as described + in wrinkle DTW4) are adequate for every DataToTag instance only + because every Haskell-land data constructor use gets translated to + its own "real" heap or static data object at runtime and the index + of that constructor is always exposed via pointer tagging and via + the object's info table. + +(DTW7) Currently, the generated module GHC.PrimopWrappers in ghc-prim + contains the following non-sense definitions: + + {-# NOINLINE dataToTagSmall# #-} + dataToTagSmall# :: a_levpoly -> Int# + dataToTagSmall# a1 = GHC.Prim.dataToTagSmall# a1 + {-# NOINLINE dataToTagLarge# #-} + dataToTagLarge# :: a_levpoly -> Int# + dataToTagLarge# a1 = GHC.Prim.dataToTagLarge# a1 + + Why do these exist? GHCi uses these symbols for... something. There + is on-going work to get rid of them. See also #24169, #20155, and !6245. + Their continued existence makes it difficult to do several nice things: + + * As explained in DTW6, the dataToTag# primops are very internal. + We would like to hide them from GHC.Prim entirely to prevent + their mis-use, but doing so would cause GHC.PrimopWrappers to + fail to compile. + + * The primops are applied at the (confusingly monomorphic) type + variable `a_levpoly` in the above definitions. In particular, + they do not satisfy conditions DTT2 and DTT3 above. We would + very much like these conditions to be invariants, but while + GHC.PrimopWrappers breaks them we cannot do so. (The code that + would check these invariants in Core Lint exists but remains + commented out for now.) + + * This in turn means that `GHC.Core.Opt.ConstantFold.caseRules` + must check for condition DTT2 before doing the work described in + Note [caseRules for dataToTag]. + + * Likewise, wrinkle DTW5 is only necessary because condition DTT3 + is not an invariant. Otherwise, invoking the currently-specified + undefined behavior of `dataToTagSmall# @ty` would require passing it + an argument which will not really have type `ty` at runtime. And + evaluating such an expression is always undefined behavior anyway! + + + +Historical note: +During its time as a primop, `dataToTag#` underwent several changes, +mostly relating to under what circumstances it evaluates its argument. +Today, that story is simple: A dataToTag primop always evaluates its +argument, unless tag inference determines the argument was already +evaluated and correctly tagged. Getting here was a long journey, with +many similarities to the story behind Note [Evaluated and Properly Tagged] in +GHC.Stg.EnforceEpt. See also #15696. -} {- ******************************************************************** @@ -643,12 +980,12 @@ 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] - mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $ - EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) + mk_ev [mult_ev, arg_ev, ret_ev] + = evTypeable ty $ EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev) mk_ev _ = panic "GHC.Tc.Instance.Class.doFunTy" @@ -660,7 +997,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 @@ -692,7 +1029,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) @@ -713,7 +1050,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)] @@ -800,21 +1137,21 @@ ***********************************************************************-} -- See also Note [The equality types story] in GHC.Builtin.Types.Prim -matchEqualityInst :: Class -> [Type] -> (DataCon, Role, Type, Type) +matchEqualityInst :: Class -> [Type] -> (Role, Type, Type) -- Precondition: `cls` satisfies GHC.Core.Predicate.isEqualityClass -- See Note [Solving equality classes] in GHC.Tc.Solver.Dict matchEqualityInst cls args | cls `hasKey` eqTyConKey -- Solves (t1 ~ t2) , [_,t1,t2] <- args - = (eqDataCon, Nominal, t1, t2) + = (Nominal, t1, t2) | cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2) , [_,_,t1,t2] <- args - = (heqDataCon, Nominal, t1, t2) + = (Nominal, t1, t2) | cls `hasKey` coercibleTyConKey -- Solves (Coercible t1 t2) , [_, t1, t2] <- args - = (coercibleDataCon, Representational, t1, t2) + = (Representational, t1, t2) | otherwise -- Does not satisfy the precondition = pprPanic "matchEqualityInst" (ppr (mkClassPred cls args)) @@ -826,60 +1163,42 @@ * * ***********************************************************************-} -{- -Note [HasField instances] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - data T y = MkT { foo :: [y] } - -and `foo` is in scope. Then GHC will automatically solve a constraint like - - HasField "foo" (T Int) b - -by emitting a new wanted - - T alpha -> [alpha] ~# T Int -> b - -and building a HasField dictionary out of the selector function `foo`, -appropriately cast. - -The HasField class is defined (in GHC.Records) thus: +{- Note [HasField instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that the HasField class is defined (in GHC.Records) thus: - 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. -Hence we can solve `HasField "foo" (T Int) b` by taking an expression -of type `T Int -> b` and casting it using the newtype coercion. -Note that - - foo :: forall y . T y -> [y] - -so the expression we construct is - - foo @alpha |> co - -where +Suppose we have + data T y = MkT { foo :: [y] } +and `foo` is in scope, with type + foo :: forall y. T y -> [y] - co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b +Then `matchHasField` implements the followind built-in magic to solve + [W] d : HasField "foo" (T rty) fty -is built from + * Check that `T` has a field `foo`, and get the selector Id, sel_id + This is done by `lookupHasFieldLabel` - co1 :: (T alpha -> [alpha]) ~# (T Int -> b) + * Instantiate sel_id's type, giving: T alpha -> [alpha] -which is the new wanted, and + * Generating a new Wanted + [W] co : (T alpha -> [alpha]) ~# (T rty -> fty) - co2 :: (T Int -> b) ~# HasField "foo" (T Int) b + * Solve the original Wanted via + d = MkHasField (sel_id @alpha |> co) -which can be derived from the newtype coercion. +Wrinkles: -If `foo` is not in scope, or has a higher-rank or existentially -quantified type, then the constraint is not solved automatically, but -may be solved by a user-supplied HasField instance. Similarly, if we -encounter a HasField constraint where the field is not a literal -string, or does not belong to the type, then we fall back on the -normal constraint solver behaviour. +(HF1) If `foo` is not in scope, or is "naughty" (has a higher-rank or + existentially quantified type), then the constraint is not solved + automatically, but may be solved by a user-supplied HasField instance. + Similarly, if we encounter a HasField constraint where the field is not a + literal string, or does not belong to the type, then we fall back on the + normal constraint solver behaviour. Note [Unused name reporting and HasField] @@ -897,25 +1216,15 @@ -} -- See Note [HasField instances] -matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult -matchHasField dflags short_cut clas tys +matchHasField :: DynFlags -> Bool -> Class -> [Type] + -> Maybe CtLoc -- Nothing used only during type validity checking + -> TcM ClsInstResult +matchHasField dflags short_cut clas tys mb_ct_loc = do { fam_inst_envs <- tcGetFamInstEnvs ; rdr_env <- getGlobalRdrEnv - ; case tys of - -- We are matching HasField {k} x r a... - [_k_ty, x_ty, r_ty, a_ty] - -- x should be a literal string - | Just x <- isStrLitTy x_ty - -- r should be an applied type constructor - , Just (tc, args) <- tcSplitTyConApp_maybe r_ty - -- use representation tycon (if data family); it has the fields - , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) - -- x should be a field of r - , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc - -- the field selector should be in scope - , Just gre <- lookupGRE_FieldLabel rdr_env fl - - -> do { sel_id <- tcLookupId (flSelector fl) + ; case lookupHasFieldLabel fam_inst_envs rdr_env tys of + Just (sel_name, gre, r_ty, a_ty) -> + do { sel_id <- tcLookupId sel_name ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id -- The first new wanted constraint equates the actual @@ -923,33 +1232,93 @@ -- the HasField x r a dictionary. The preds will -- typically be empty, but if the datatype has a -- "stupid theta" then we have to include it here. - ; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds + ; let tvs = mkTyVarTys (map snd tv_prs) + theta = mkNomEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds -- Use the equality proof to cast the selector Id to - -- type (r -> a), then use the newtype coercion to cast - -- it to a HasField dictionary. - mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co - where - co = mkSubCo (evTermCoercion (EvExpr ev1)) - `mkTransCo` mkSymCo co2 + -- type (r -> a), then use evUnaryDictAppE to turn it + -- into a HasField dictionary. + mk_ev (ev1:evs) = EvExpr $ + evUnaryDictAppE clas tys $ + evCastE (evSelector sel_id tvs evs) + (mkSubCo (evExprCoercion ev1)) mk_ev [] = panic "matchHasField.mk_ev" - Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) - tys + -- The selector must not be "naughty" (i.e. the field + -- cannot have an existentially quantified type), + -- and it must not be higher-rank. + ; if (isNaughtyRecordSelector sel_id) || not (isTauTy sel_ty) + then try_user_instances + else + do { case mb_ct_loc of + Nothing -> return () -- Nothing: happens when type-validity checking + Just loc -> setCtLocM loc $ -- Set location for warnings + do { -- See Note [Unused name reporting and HasField] + addUsedGRE AllDeprecationWarnings gre + ; keepAlive sel_name - tvs = mkTyVarTys (map snd tv_prs) + -- Warn about incomplete record selection + ; warnIncompleteRecSel dflags sel_id loc } - -- The selector must not be "naughty" (i.e. the field - -- cannot have an existentially quantified type), and - -- it must not be higher-rank. - ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty - then do { -- See Note [Unused name reporting and HasField] - addUsedGRE AllDeprecationWarnings gre - ; keepAlive (greName gre) - ; return OneInst { cir_new_theta = theta - , cir_mk_ev = mk_ev - , cir_canonical = True - , cir_what = BuiltinInstance } } - else matchInstEnv dflags short_cut clas tys } + ; return OneInst { cir_new_theta = theta + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } } } - _ -> matchInstEnv dflags short_cut clas tys } + Nothing -> try_user_instances } + where + -- See (HF1) in Note [HasField instances] + try_user_instances = matchInstEnv dflags short_cut clas tys + +warnIncompleteRecSel :: DynFlags -> Id -> CtLoc -> TcM () +-- Warn about incomplete record selectors +-- See (IRS6) in Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc +warnIncompleteRecSel dflags sel_id ct_loc + | not (isGetFieldOrigin (ctLocOrigin ct_loc)) + -- isGetFieldOrigin: see (IRS7) in + -- Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc + , RecSelId { sel_cons = RSI { rsi_undef = fallible_cons } } <- idDetails sel_id + , not (null fallible_cons) + = addDiagnostic $ + TcRnHasFieldResolvedIncomplete (idName sel_id) fallible_cons maxCons + + | otherwise + = return () + where + maxCons = maxUncoveredPatterns dflags + + -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, + -- despite the expansion to (getField @"x" r) + isGetFieldOrigin (GetFieldOrigin {}) = True + isGetFieldOrigin _ = False + +lookupHasFieldLabel + :: FamInstEnvs -> GlobalRdrEnv -> [Type] + -> Maybe ( Name -- Name of the record selector + , GlobalRdrElt -- GRE for the selector + , Type -- Type of the record value + , Type ) -- Type of the field of the record +-- If possible, decompose application +-- (HasField @k @rrep @arep @"fld" @(T t1..tn) @fld-ty), +-- or (getField @k @rrep @arep @"fld" @(T t1..tn) @fld-ty) +-- and return the pieces, if the record selector is in scope +-- +-- A complication is that `T` might be a data family, so we need to +-- look it up in the `fam_envs` to find its representation tycon. +lookupHasFieldLabel fam_inst_envs rdr_env arg_tys + | -- We are matching HasField {k} {r_rep} {a_rep} x r a... + (_k : _rec_rep : _fld_rep : x_ty : rec_ty : fld_ty : _) <- arg_tys + -- x should be a literal string + , Just x <- isStrLitTy x_ty + -- r should be an applied type constructor + , Just (tc, args) <- tcSplitTyConApp_maybe rec_ty + -- Use the representation tycon (if data family); it has the fields + , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args) + -- x should be a field of r + , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc + -- Ensure the field selector is in scope + , Just gre <- lookupGRE_FieldLabel rdr_env fl + = Just (flSelector fl, gre, rec_ty, fld_ty) + + | otherwise + = Nothing diff --git a/GHC/Tc/Instance/Family.hs b/GHC/Tc/Instance/Family.hs --- a/GHC/Tc/Instance/Family.hs +++ b/GHC/Tc/Instance/Family.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE GADTs, ViewPatterns #-} +{-# LANGUAGE GADTs, ViewPatterns, LambdaCase #-} -- | The @FamInst@ type: family instance heads module GHC.Tc.Instance.Family ( FamInstEnvs, tcGetFamInstEnvs, checkFamInstConsistency, tcExtendLocalFamInstEnv, tcLookupDataFamInst, tcLookupDataFamInst_maybe, - tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe, + tcTopNormaliseNewTypeTF_maybe, -- * Injectivity reportInjectivityErrors, reportConflictingInjectivityErrs @@ -34,9 +34,7 @@ import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps -import GHC.Unit.Home.ModInfo import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name.Reader @@ -46,7 +44,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.FV import GHC.Data.Bag( Bag, unionBags, unitBag ) @@ -58,7 +55,8 @@ import Data.Function ( on ) import qualified GHC.LanguageExtensions as LangExt -import GHC.Unit.Env (unitEnv_hpts) +import Data.List (sortOn) +import qualified GHC.Unit.Home.Graph as HUG {- Note [The type family instance consistency story] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -240,6 +238,49 @@ a set of utility modules that every module imports directly or indirectly. This is basically the idea from #13092, comment:14. + +Note [Order of type family consistency checks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a module M which imports modules A, B and C, all defining (open) type +family instances. + +We can waste a lot of work in type family consistency checking depending on the +order in which the modules are processed. + +Suppose for example that C imports A and B. When we compiled C, we will have +checked A and B for consistency against eachother. This means that, when +processing the imports of M to check type family instance consistency: + +* if C is processed first, then A and B will not need to be checked for + consistency against eachother again, +* if we process A and B before C,then the + consistency checks between A and B will be performed again. This is wasted + work, as we already performed them for C. + +This can make a significant difference. Keeping the nomenclature of the above +example for illustration, we have observed situations in practice in which the +compilation time of M goes from 1 second (the "processing A and B first" case) +down to 80 milliseconds (the "processing C first" case). + +Clearly we should engineer that C is checked before B and A, but by what scheme? + +A simple one is to observe that if a module M is in the transitive closure of X +then the size of the consistent family set of M is less than or equal to size +of the consistent family set of X. + +Therefore, by sorting the imports by the size of the consistent family set and +processing the largest first, we make sure to process modules in topological +order. + +For a particular project, without this change we did 40 million checks and with +this change we did 22.9 million checks. This is significant as before this change +type family consistency checks accounted for 26% of total type checker allocations which +was reduced to 15%. + +See tickets #25554 for discussion about this exact issue and #25555 for +why we still do redundant checks. + -} -- We don't need to check the current module, this is done in @@ -251,40 +292,44 @@ ; traceTc "checkFamInstConsistency" (ppr directlyImpMods) ; let { -- Fetch the iface of a given module. Must succeed as -- all directly imported modules must already have been loaded. - modIface mod = - case lookupIfaceByModule hug (eps_PIT eps) mod of + modIface mod = liftIO $ + lookupIfaceByModule hug (eps_PIT eps) mod >>= \case Nothing -> panicDoc "FamInst.checkFamInstConsistency" - (ppr mod $$ ppr hug) - Just iface -> iface + (ppr mod $$ ppr (HUG.allUnits hug)) + Just iface -> pure iface -- Which family instance modules were checked for consistency -- when we compiled `mod`? -- Itself (if a family instance module) and its dep_finsts. -- This is df(D_i) from -- Note [Checking family instance optimization] - ; modConsistent :: Module -> [Module] - ; modConsistent mod = - if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps - where - deps = dep_finsts . mi_deps . modIface $ mod + ; modConsistent :: Module -> TcM [Module] + ; modConsistent mod = do + ifc <- modIface mod + deps <- dep_finsts . mi_deps <$> modIface mod + pure $ + if mi_finsts ifc + then mod:deps + else deps - ; hmiModule = mi_module . hm_iface - ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv - . md_fam_insts . hm_details - ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) - | hpt <- unitEnv_hpts hug - , hmi <- eltsHpt hpt ] + -- Sorting the list by size has the effect of performing a topological sort. + -- See Note [Order of type family consistency checks] } - ; checkMany hpt_fam_insts modConsistent directlyImpMods + ; hpt_fam_insts <- liftIO $ HUG.allFamInstances hug + ; debug_consistent_set <- mapM (\x -> (\y -> (x, length y)) <$> modConsistent x) directlyImpMods + ; traceTc "init_consistent_set" (ppr debug_consistent_set) + ; let init_consistent_set = map fst (reverse (sortOn snd debug_consistent_set)) + ; checkMany hpt_fam_insts modConsistent init_consistent_set + } where -- See Note [Checking family instance optimization] checkMany - :: ModuleEnv FamInstEnv -- home package family instances - -> (Module -> [Module]) -- given A, modules checked when A was checked - -> [Module] -- modules to process + :: ModuleEnv FamInstEnv -- home package family instances + -> (Module -> TcM [Module]) -- given A, modules checked when A was checked + -> [Module] -- modules to process -> TcM () checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods where @@ -295,6 +340,41 @@ -> TcM () go _ _ [] = return () go consistent consistent_set (mod:mods) = do + mod_deps_consistent <- modConsistent mod + let + mod_deps_consistent_set = mkModuleSet mod_deps_consistent + consistent' = to_check_from_mod ++ consistent + consistent_set' = + extendModuleSetList consistent_set to_check_from_mod + to_check_from_consistent = + filterOut (`elemModuleSet` mod_deps_consistent_set) consistent + to_check_from_mod = + filterOut (`elemModuleSet` consistent_set) mod_deps_consistent + -- Why don't we just minusModuleSet here (above)? + -- We could, but doing so means one of two things: + -- + -- 1. When looping over the cartesian product we convert + -- a set into a non-deterministically ordered list. Which + -- happens to be fine for interface file determinism + -- in this case, today, because the order only + -- determines the order of deferred checks. But such + -- invariants are hard to keep. + -- + -- 2. When looping over the cartesian product we convert + -- a set into a deterministically ordered list - this + -- adds some additional cost of sorting for every + -- direct import. + -- + -- That also explains why we need to keep both 'consistent' + -- and 'consistentSet'. + -- + -- See also Note [ModuleEnv performance and determinism]. + + traceTc "checkManySize" (vcat [text "mod:" <+> ppr mod + , text "m1:" <+> ppr (length to_check_from_mod) + , text "m2:" <+> ppr (length (to_check_from_consistent)) + , text "product:" <+> ppr (length to_check_from_mod * length to_check_from_consistent) + ]) sequence_ [ check hpt_fam_insts m1 m2 | m1 <- to_check_from_mod @@ -303,35 +383,6 @@ , m2 <- to_check_from_consistent ] go consistent' consistent_set' mods - where - mod_deps_consistent = modConsistent mod - mod_deps_consistent_set = mkModuleSet mod_deps_consistent - consistent' = to_check_from_mod ++ consistent - consistent_set' = - extendModuleSetList consistent_set to_check_from_mod - to_check_from_consistent = - filterOut (`elemModuleSet` mod_deps_consistent_set) consistent - to_check_from_mod = - filterOut (`elemModuleSet` consistent_set) mod_deps_consistent - -- Why don't we just minusModuleSet here? - -- We could, but doing so means one of two things: - -- - -- 1. When looping over the cartesian product we convert - -- a set into a non-deterministically ordered list. Which - -- happens to be fine for interface file determinism - -- in this case, today, because the order only - -- determines the order of deferred checks. But such - -- invariants are hard to keep. - -- - -- 2. When looping over the cartesian product we convert - -- a set into a deterministically ordered list - this - -- adds some additional cost of sorting for every - -- direct import. - -- - -- That also explains why we need to keep both 'consistent' - -- and 'consistentSet'. - -- - -- See also Note [ModuleEnv performance and determinism]. check hpt_fam_insts m1 m2 = do { env1' <- getFamInsts hpt_fam_insts m1 ; env2' <- getFamInsts hpt_fam_insts m2 @@ -355,7 +406,7 @@ | Just env <- lookupModuleEnv hpt_fam_insts mod = return env | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) ; eps <- getEps - ; return (expectJust "checkFamInstConsistency" $ + ; return (expectJust $ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } where doc = ppr mod <+> text "is a family-instance module" @@ -369,15 +420,6 @@ -} --- | If @co :: T ts ~ rep_ty@ then: --- --- > instNewTyCon_maybe T ts = Just (rep_ty, co) --- --- Checks for a newtype, and for being saturated --- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion -tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion) -tcInstNewTyCon_maybe = instNewTyCon_maybe - -- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if -- there is no data family to unwrap. -- Returns a Representational coercion @@ -404,7 +446,7 @@ , let rep_tc = dataFamInstRepTyCon rep_fam co = mkUnbranchedAxInstCo Representational ax rep_args (mkCoVarCos cvs) - = assert (null rep_cos) $ -- See Note [Constrained family instances] in GHC.Core.FamInstEnv + = assert (null rep_cos) $ -- See Note [Constrained family instances] in ??? (renamed?) Just (rep_tc, rep_args, co) | otherwise diff --git a/GHC/Tc/Instance/FunDeps.hs b/GHC/Tc/Instance/FunDeps.hs --- a/GHC/Tc/Instance/FunDeps.hs +++ b/GHC/Tc/Instance/FunDeps.hs @@ -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 @@ -96,7 +90,7 @@ Then `improveFromInstEnv` should return a FDEqn with FDEqn { fd_qtvs = [], fd_eqs = [Pair Bool ty] } -describing an equality (Int ~ ty). To do this we /match/ the instance head +describing an equality (Bool ~ ty). To do this we /match/ the instance head against the [W], using just the LHS of the fundep; if we match, we return an equality for the RHS. @@ -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 @@ -527,7 +514,7 @@ closeWrtFunDeps is used - when checking the coverage condition for an instance declaration - when determining which tyvars are unquantifiable during generalization, in - GHC.Tc.Solver.decideMonoTyVars. + GHC.Tc.Solver.decidePromotedTyVars. Note [Equality superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -591,11 +578,22 @@ = case classifyPredType pred of EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])] -- See Note [Equality superclasses] - ClassPred cls tys -> [ instFD fd cls_tvs tys - | let (cls_tvs, cls_fds) = classTvsFds cls - , fd <- cls_fds ] + + ClassPred cls tys | not (isIPClass cls) + -- isIPClass: see Note [closeWrtFunDeps ignores implicit parameters] + -> [ instFD fd cls_tvs tys + | let (cls_tvs, cls_fds) = classTvsFds cls + , fd <- cls_fds ] _ -> [] +{- Note [closeWrtFunDeps ignores implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Implicit params don't really determine a type variable (that is, we might have +IP "c" Bool and IP "c" Int in different places within the same program), and +skipping this causes implicit params to monomorphise too many variables; see +Note [Inheriting implicit parameters] in GHC.Tc.Solver. Skipping causes +typecheck/should_compile/tc219 to fail. +-} {- ********************************************************************* * * @@ -665,19 +663,19 @@ | instanceCantMatch trimmed_tcs rough_tcs2 = False | otherwise - = case tcUnifyTyKis bind_fn ltys1 ltys2 of + = case tcUnifyFunDeps qtvs ltys1 ltys2 of Nothing -> False Just subst -> isNothing $ -- Bogus legacy test (#10675) -- See Note [Bogus consistency check] - tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) + tcUnifyFunDeps qtvs (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2) where trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs1 (ltys1, rtys1) = instFD fd cls_tvs tys1 (ltys2, rtys2) = instFD fd cls_tvs tys2 qtv_set2 = mkVarSet qtvs2 - bind_fn = matchBindFun (qtv_set1 `unionVarSet` qtv_set2) + qtvs = qtv_set1 `unionVarSet` qtv_set2 eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2 -- A single instance may appear twice in the un-nubbed conflict list diff --git a/GHC/Tc/Instance/Typeable.hs b/GHC/Tc/Instance/Typeable.hs --- a/GHC/Tc/Instance/Typeable.hs +++ b/GHC/Tc/Instance/Typeable.hs @@ -13,7 +13,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( Boxity(..), TypeOrConstraint(..), neverInlinePragma ) +import GHC.Types.Basic ( TypeOrConstraint(..), neverInlinePragma ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) @@ -25,7 +25,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types - ( tupleTyCon, sumTyCon, runtimeRepTyCon + ( runtimeRepTyCon , levityTyCon, vecCountTyCon, vecElemTyCon , nilDataCon, consDataCon ) import GHC.Types.Name @@ -36,10 +36,8 @@ 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.Settings.Constants import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -105,7 +103,7 @@ * GHC.Prim doesn't have any associated object code, so we need to put the representations for types defined in this module elsewhere. We chose this - place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableBinds is responsible for + place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableTodos is responsible for injecting the bindings for the GHC.Prim representations when compiling GHC.Types. @@ -197,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 @@ -223,18 +221,21 @@ , tycon_rep_id :: !Id } --- | A group of 'TyCon's in need of type-rep bindings. data TypeRepTodo - = TypeRepTodo - { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding - , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint - , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint - , todo_tycons :: [TypeableTyCon] - -- ^ The 'TyCon's in need of bindings kinds - } - | ExportedKindRepsTodo [(Kind, Id)] + = TyConTodo TyConTodo + | ExportedKindRepsTodo [(Kind, Id)] -- ^ Build exported 'KindRep' bindings for the given set of kinds. + +-- | A group of 'TyCon's in need of type-rep bindings. +data TyConTodo + = TCTD { mod_rep_expr :: LHsExpr GhcTc -- ^ Module's typerep binding + , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint + , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint + , todo_tycons :: [TypeableTyCon] + -- ^ The 'TyCon's in need of bindings kinds + } + todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo todoForTyCons mod mod_id tycons = do trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName @@ -257,11 +258,11 @@ , Just rep_name <- pure $ tyConRepName_maybe tc'' , tyConIsTypeable tc'' ] - return TypeRepTodo { mod_rep_expr = nlHsVar mod_id - , pkg_fingerprint = pkg_fpr - , mod_fingerprint = mod_fpr - , todo_tycons = typeable_tycons - } + return $ TyConTodo $ + TCTD { mod_rep_expr = nlHsVar mod_id + , pkg_fingerprint = pkg_fpr + , mod_fingerprint = mod_fpr + , todo_tycons = typeable_tycons } where mod_fpr = fingerprintString $ moduleNameString $ moduleName mod pkg_fpr = fingerprintString $ unitString $ moduleUnit mod @@ -285,8 +286,8 @@ -- TyCon associated with the applied type constructor). ; let produced_bndrs :: [Id] produced_bndrs = [ tycon_rep_id - | todo@(TypeRepTodo{}) <- todos - , TypeableTyCon {..} <- todo_tycons todo + | TyConTodo (TCTD { todo_tycons = tcs }) <- todos + , TypeableTyCon {..} <- tcs ] ++ [ rep_id | ExportedKindRepsTodo kinds <- todos @@ -295,8 +296,8 @@ ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc] - mk_binds todo@(TypeRepTodo {}) = - mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) + mk_binds (TyConTodo (todo@(TCTD { todo_tycons = tcs }))) = + mapM (mkTyConRepBinds stuff todo) tcs mk_binds (ExportedKindRepsTodo kinds) = mkExportedKindReps stuff kinds >> return [] @@ -326,7 +327,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 @@ -354,12 +355,10 @@ -- The majority of the types we need here are contained in 'primTyCons'. -- However, not all of them: in particular unboxed tuples are absent since we -- don't want to include them in the original name cache. See --- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. +-- Note [Built-in syntax and the OrigNameCache] in "GHC.Types.Name.Cache" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat - [ map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] - , map sumTyCon [2..mAX_SUM_SIZE] - , primTyCons + [ primTyCons ] -- | These are types which are defined in GHC.Types but are needed in order to @@ -417,7 +416,7 @@ return trNameLit -- | Make Typeable bindings for the given 'TyCon'. -mkTyConRepBinds :: TypeableStuff -> TypeRepTodo +mkTyConRepBinds :: TypeableStuff -> TyConTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff todo (TypeableTyCon {..}) = do -- Make a KindRep @@ -430,7 +429,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. @@ -532,7 +531,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. @@ -653,7 +652,7 @@ = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) -- | Produce the right-hand-side of a @TyCon@ representation. -mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo +mkTyConRepTyConRHS :: TypeableStuff -> TyConTodo -> TyCon -- ^ the 'TyCon' we are producing a binding for -> LHsExpr GhcTc -- ^ its 'KindRep' -> LHsExpr GhcTc diff --git a/GHC/Tc/Module.hs b/GHC/Tc/Module.hs --- a/GHC/Tc/Module.hs +++ b/GHC/Tc/Module.hs @@ -1,12 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -20,7 +16,8 @@ -- -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker module GHC.Tc.Module ( - tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, + tcRnStmt, tcRnExpr, TcRnExprMode(..), + tcRnType, tcRnTypeSkolemising, tcRnImportDecls, tcRnLookupRdrName, getModuleInterface, @@ -54,6 +51,7 @@ import GHC.Driver.Plugins import GHC.Driver.DynFlags import GHC.Driver.Config.Diagnostic +import GHC.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR (..) ) import GHC.Tc.Errors.Types @@ -64,7 +62,6 @@ import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) import GHC.Tc.Zonk.Type import GHC.Tc.Gen.Expr -import GHC.Tc.Gen.App( tcInferSigma ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence @@ -75,7 +72,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env -import GHC.Tc.Gen.Rule +import GHC.Tc.Gen.Sig( tcRules ) import GHC.Tc.Gen.Foreign import GHC.Tc.TyCl.Instance import GHC.Tc.Utils.TcMType @@ -95,7 +92,7 @@ import GHC.Rename.Env import GHC.Rename.Module import GHC.Rename.Doc -import GHC.Rename.Utils ( mkNameClashErr ) +import GHC.Rename.Utils ( mkNameClashErr, mkRnSyntaxExpr ) import GHC.Iface.Decl ( coAxiomToIfaceDecl ) import GHC.Iface.Env ( externaliseName ) @@ -119,6 +116,7 @@ import GHC.Core.Coercion.Axiom import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.TyCo.Ppr( debugPprType ) +import GHC.Core.TyCo.Tidy( tidyTopType ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst , famInstEnvElts, extendFamInstEnvList, normaliseType ) @@ -132,12 +130,12 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.Name.Reader +import GHC.Types.DefaultEnv import GHC.Types.Fixity.Env import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) @@ -152,9 +150,9 @@ import GHC.Types.Annotations import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.Env as UnitEnv import GHC.Unit.External import GHC.Unit.Types import GHC.Unit.State @@ -165,6 +163,7 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Deps +import GHC.Driver.Downsweep import GHC.Data.FastString import GHC.Data.Maybe @@ -177,14 +176,17 @@ import Control.Monad import Control.Monad.Trans.Writer.CPS import Data.Data ( Data ) +import Data.Function (on) 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 ) +import Data.IORef( newIORef ) @@ -292,8 +294,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 @@ -302,8 +304,8 @@ -- We will rename it properly after renaming everything else so that -- haddock can link the identifiers ; tcg_env <- return (tcg_env - { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) - <$> maybe_doc_hdr }) + { tcg_hdr_info = (fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str []) + <$> maybe_doc_hdr , maybe_mod ) }) ; -- If the whole module is warned about or deprecated -- (via mod_deprec) record that in tcg_warns. If we do thereby add -- a WarnAll, it will override any subsequent deprecations added to tcg_warns @@ -317,6 +319,9 @@ traceRn "rn1a" empty ; tcg_env <- case hsc_src of + -- See Note [Don't typecheck GHC.Internal.Prim] + _ | tcg_mod tcg_env1 == gHC_PRIM -> pure tcg_env1 + HsBootOrSig boot_or_sig -> do { tcg_env <- tcRnHsBootDecls boot_or_sig local_decls ; traceRn "rn4a: before exports" empty @@ -348,11 +353,12 @@ -- 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; ; tcg_env <- return (tcg_env - { tcg_doc_hdr = maybe_doc_hdr }) + { tcg_hdr_info = (maybe_doc_hdr, maybe_mod) }) ; -- add extra source files to tcg_dependent_files addDependentFiles src_files @@ -368,6 +374,85 @@ } } +{- Note [Don't typecheck GHC.Internal.Prim] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC (currently) can't type-check GHC.Internal.Prim, as that module +contains primitive functions that can't be defined in source Haskell. +The GHC.Internal.Prim source file is only used to generate Haddock documentation; +the actual contents of the module are wired in to GHC. +-} + +{- Note [Disambiguation of multiple default declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +See Note [Named default declarations] in GHC.Tc.Gen.Default + +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 (className 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 + {- ************************************************************************ * * @@ -376,24 +461,32 @@ ************************************************************************ -} -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) <- rnImports import_decls + -- Get the default declarations for the classes imported by this module + -- and group them by class. + ; tc_defaults <-(NE.groupBy ((==) `on` cd_class) . (concatMap defaultList)) + <$> tcGetClsDefaults (M.keys $ imp_mods imports) ; this_mod <- getModule ; gbl_env <- getGblEnv - ; let { -- We want instance declarations from all home-package + ; let unitId = homeUnitId $ hsc_home_unit hsc_env + mnwib = GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)) + ; -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't -- get the instances from this module's hs-boot file. This -- filtering also ensures that we don't see instances from -- modules batch (@--make@) compiled before this one, but -- which are not below this one. - ; (home_insts, home_fam_insts) = - - hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env))) + ; (home_insts, home_fam_insts) <- liftIO $ + hugInstancesBelow hsc_env unitId mnwib - } ; + -- We use 'unsafeInterleaveIO' to avoid redundant memory allocations + -- See Note [Lazily loading COMPLETE pragmas] from GHC.HsToCore.Monad + -- and see https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14274#note_620545 + ; completeSigsBelow <- liftIO $ unsafeInterleaveIO $ + hugCompleteSigsBelow hsc_env unitId mnwib -- Record boot-file info in the EPS, so that it's -- visible to loadHiBootInterface in tcRnSrcDecls, @@ -407,11 +500,14 @@ gbl { tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_complete_match_env = tcg_complete_match_env gbl ++ + completeSigsBelow, + tcg_import_decls = imp_user_spec, tcg_rn_imports = rn_imports, + tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) - home_fam_insts, - tcg_hpc = hpc_info + home_fam_insts }) $ do { ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) @@ -436,13 +532,16 @@ -- 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 } - ; checkFamInstConsistency dir_imp_mods + ; logger <- getLogger + ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) + $ checkFamInstConsistency dir_imp_mods ; traceRn "rn1: } checking family instance consistency" empty - ; getGblEnv } } + ; gbl_env <- getGblEnv + ; return (tc_defaults, gbl_env) } } {- ************************************************************************ @@ -453,7 +552,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 @@ -500,7 +599,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 = [] @@ -546,7 +645,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 @@ -714,7 +813,7 @@ -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds + <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds ; setGblEnv tcg_env $ do { -- Emit Typeable bindings @@ -778,10 +877,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 @@ -792,10 +891,6 @@ -- TODO: Maybe setGlobalTypeEnv should be strict. setGlobalTypeEnv tcg_env_w_binds type_env' } -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "checkHiBootIface: unreachable code" -#endif - {- Note [DFun impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We return a list of "impedance-matching" bindings for the dfuns @@ -903,6 +998,11 @@ = do { traceTc "checkHiBootIface" $ vcat [ ppr boot_type_env, ppr boot_exports ] + ; mod <- tcg_mod <$> getGblEnv + + -- See Note [Don't typecheck GHC.Internal.Prim] + ; if mod == gHC_PRIM then pure [] else do { + ; gre_env <- getGlobalRdrEnv -- Check the exports of the boot module, one by one @@ -922,7 +1022,7 @@ ; failIfErrsM - ; return (fld_prs ++ dfun_prs) } + ; return (fld_prs ++ dfun_prs) }} where boot_dfun_names = map idName boot_dfuns @@ -1621,7 +1721,7 @@ traceTc "Tc3" empty ; (tcg_env, inst_infos, th_bndrs, XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; + <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ; updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ setGblEnv tcg_env $ do { @@ -1631,11 +1731,6 @@ (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ do { - -- Default declarations - traceTc "Tc4a" empty ; - default_tys <- tcDefaults default_decls ; - updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { - -- Value declarations next. -- It is important that we check the top-level value bindings -- before the GHC-generated derived bindings, since the latter @@ -1669,8 +1764,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)) @@ -1681,7 +1775,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 @@ -1695,13 +1789,14 @@ addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; return (tcg_env', tcl_env) - }}}}}} + }}}}} tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" --------------------------- tcTyClsInstDecls :: [TyClGroup GhcRn] -> [LDerivDecl GhcRn] + -> [LDefaultDecl GhcRn] -> [(RecFlag, LHsBinds GhcRn)] -> TcM (TcGblEnv, -- The full inst env [InstInfo GhcRn], -- Source-code instance decls to @@ -1711,16 +1806,23 @@ HsValBinds GhcRn) -- Supporting bindings for derived -- instances -tcTyClsInstDecls tycl_decls deriv_decls binds +tcTyClsInstDecls tycl_decls deriv_decls default_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $ do { (tcg_env, inst_info, deriv_info, th_bndrs) <- tcTyAndClassDecls tycl_decls ; + ; setGblEnv tcg_env $ do { + -- With the @TyClDecl@s and @InstDecl@s checked we're ready to -- process the deriving clauses, including data family deriving -- clauses discovered in @tcTyAndClassDecls@. -- + -- But only after we've typechecked 'default' declarations. + -- See Note [Typechecking default declarations] + defaults <- tcDefaultDecls default_decls + ; extendDefaultEnvWithLocalDefaults defaults $ do { + -- Careful to quit now in case there were instance errors, so that -- the deriving errors don't pile up as well. ; failIfErrsM @@ -1729,7 +1831,7 @@ ; setGblEnv tcg_env' $ do { failIfErrsM ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) - }}} + }}}} {- ********************************************************************* * * @@ -1772,7 +1874,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 @@ -1838,7 +1940,7 @@ { traceTc "checkMain found" (ppr main_name) ; (io_ty, res_ty) <- getIOType ; let loc = getSrcSpan main_name - main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name)) + main_expr_rn = L (noAnnSrcSpan loc) (mkHsVar (L (noAnnSrcSpan loc) main_name)) ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ tcCheckMonoExpr main_expr_rn io_ty @@ -1861,7 +1963,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 @@ -1877,13 +1979,11 @@ setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) setMainCtxt main_name io_ty thing_inside = setSrcSpan (getSrcSpan main_name) $ - addErrCtxt main_ctxt $ + addErrCtxt (MainCtxt main_name) $ checkConstraints skol_info [] [] $ -- Builds an implication if necessary thing_inside -- e.g. with -fdefer-type-errors where skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty [] - main_ctxt = text "When checking the type of the" - <+> ppMainFn (nameOccName main_name) {- Note [Dealing with main] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1977,7 +2077,26 @@ There is also some similar (probably dead) logic in GHC.Rename.Env which says it was added for External Core which faced a similar issue. +Note [runTcInteractive module graph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `withInteractiveModuleNode` function sets up the module graph which contains +the interactive module used by `runTcInteractive`. + +The module graph is essentially the ambient module graph which is set up when +ghci loads a module using `load`, with the addition of the interactive module (Ghci), +which imports the parts specified by the `InteractiveImports`. + +Therefore `downsweepInteractiveImports` presumes that any import which is +determined to be from the home module is already present in the module graph. +This saves resummarising and performing the whole downsweep again if it's already been +done. + +On the other hand, when GHCi starts up, and no modules have been loaded yet, the +module graph will be empty. Therefore `downsweepInteractiveImports` will perform +for the unit portion of the graph, if it's not already been performed. + + ********************************************************* * * GHCi stuff @@ -1985,12 +2104,20 @@ ********************************************************* -} +-- See Note [runTcInteractive module graph] +withInteractiveModuleNode :: HscEnv -> TcM a -> TcM a +withInteractiveModuleNode hsc_env thing_inside = do + mg <- liftIO $ downsweepInteractiveImports hsc_env (hsc_IC hsc_env) + updTopEnv (setModuleGraph mg) thing_inside + + runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside = initTcInteractive hsc_env $ withTcPlugins hsc_env $ withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $ + withInteractiveModuleNode hsc_env $ do { traceTc "setInteractiveContext" $ vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) @@ -1999,17 +2126,23 @@ , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - NotBoot mb_pkg) + ; let getOrphansForModuleName m mb_pkg = do + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg + pure $ mi_module iface : dep_orphs (mi_deps iface) + getOrphansForModule m = do + iface <- loadModuleInterface (text "runTcInteractive") m + pure $ mi_module iface : dep_orphs (mi_deps iface) + ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 - IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) + IIModule n -> getOrphansForModule n + IIDecl i -> getOrphansForModuleName (unLoc (ideclName i)) (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) + + ; (home_insts, home_fam_insts) <- liftIO $ UnitEnv.hugAllInstances (hsc_unit_env hsc_env) + ; let imports = emptyImportAvails { imp_orphs = orphs } upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') @@ -2033,8 +2166,6 @@ ; updEnvs upd_envs thing_inside } where - (home_insts, home_fam_insts) = hptAllInstances hsc_env - icxt = hsc_IC hsc_env (ic_insts, ic_finsts) = ic_instances icxt (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) @@ -2176,7 +2307,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 @@ -2189,7 +2320,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 @@ -2497,17 +2628,18 @@ failIfErrsM ; -- Typecheck the expression - ((tclvl, res_ty), lie) + ((tclvl, (_tc_expr, res_ty)), lie) <- captureTopConstraints $ pushTcLevelM $ - tcInferSigma inst rn_expr ; + (if inst then tcInferRho rn_expr + else tcInferSigma rn_expr); -- Generalise uniq <- newUnique ; let { fresh_it = itName uniq (getLocA rdr_expr) } ; ((qtvs, dicts, _, _), residual) <- captureConstraints $ - simplifyInfer tclvl infer_mode + simplifyInfer TopLevel tclvl infer_mode [] {- No sig vars -} [(fresh_it, res_ty)] lie ; @@ -2585,12 +2717,22 @@ -- 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 } + +tcRnTypeSkolemising :: HscEnv + -> LHsType GhcPs + -> IO (Messages TcRnMessage, Maybe (Type, Kind)) +-- tcRnTypeSkolemising skolemisese any free unification variables, +-- and normalises the type +tcRnTypeSkolemising env ty + = do { skol_tv_ref <- liftIO (newIORef []) + ; tcRnType env (SkolemiseFlexi skol_tv_ref) True ty } + -- tcRnType just finds the kind of a type tcRnType :: HscEnv -> ZonkFlexi @@ -2779,7 +2921,7 @@ let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc $ mkTcRnNotInScope rdr_name NotInScope) + ; when (null names) (addErrTc $ TcRnNotInScope NotInScope rdr_name) ; return names } tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) @@ -3124,14 +3266,15 @@ -- exception/signal an error. type RenamedStuff = (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe (LHsDoc GhcRn))) + Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName))) -- | Extract the renamed information from TcGblEnv. getRenamedStuff :: TcGblEnv -> RenamedStuff getRenamedStuff tc_result = fmap (\decls -> ( decls, tcg_rn_imports tc_result - , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) ) + , tcg_rn_exports tc_result, doc_hdr, name_hdr )) (tcg_rn_decls tc_result) + where (doc_hdr, name_hdr) = tcg_hdr_info tc_result runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv runTypecheckerPlugin sum gbl_env = do @@ -3149,3 +3292,43 @@ pluginUnsafe = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin + + +-- Note [Typechecking default declarations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Typechecking default declarations requires careful placement: +-- +-- 1. We must check them after types (tcTyAndClassDecls) because they can refer +-- to them. E.g. +-- +-- data T = MkT ... +-- default(Int, T, Integer) +-- +-- -- or even (tested by T11974b and T2245) +-- default(Int, T, Integer) +-- data T = MkT ... +-- +-- 2. We must check them before typechecking deriving clauses (tcInstDeclsDeriv) +-- otherwise we may lookup default default types (Integer, Double) while checking +-- deriving clauses, ignoring the default declaration. +-- +-- Before this careful placement (#24566), compiling the following example +-- (T24566) with "-ddump-if-trace -ddump-tc-trace" showed a call to +-- `applyDefaultingRules` with default types set to "(Integer,Double)": +-- +-- module M where +-- +-- import GHC.Classes +-- default () +-- +-- data Foo a = Nothing | Just a +-- deriving (Eq, Ord) +-- +-- This was an issue while building modules like M in the ghc-internal package +-- because they would spuriously fail to build if the module defining Integer +-- (ghc-bignum:GHC.Num.Integer) wasn't compiled yet and its interface not to be +-- found. The implicit dependency between M and GHC.Num.Integer isn't known to +-- the build system. +-- In addition, trying to explicitly avoid the implicit dependency with `default +-- ()` didn't work, except if *standalone* deriving was used, which was an +-- inconsistent behavior. diff --git a/GHC/Tc/Plugin.hs b/GHC/Tc/Plugin.hs --- a/GHC/Tc/Plugin.hs +++ b/GHC/Tc/Plugin.hs @@ -1,4 +1,3 @@ - -- | This module provides an interface for typechecker plugins to -- access select functions of the 'TcM', principally those to do with -- reading parts of the state. @@ -15,6 +14,7 @@ lookupOrig, -- * Looking up Names in the typechecking environment + lookupTHName, tcLookupGlobal, tcLookupTyCon, tcLookupDataCon, @@ -66,12 +66,15 @@ import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM , unsafeTcPluginTcM , liftIO, traceTc ) -import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) ) +import GHC.Tc.Types.Constraint ( Ct, CtEvidence(..), GivenCtEvidence(..) ) +import GHC.Tc.Types.CtLoc ( CtLoc ) + 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.Plugins ( thNameToGhcNameIO ) import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name ( OccName, Name ) @@ -88,6 +91,7 @@ import GHC.Types.Unique ( Unique ) import GHC.Types.PkgQual ( PkgQual ) +import qualified GHC.Boot.TH.Syntax as TH -- | Perform some IO, typically to interact with an external tool. tcPluginIO :: IO a -> TcPluginM a @@ -97,7 +101,6 @@ tcPluginTrace :: String -> SDoc -> TcPluginM () tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) - findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv @@ -106,6 +109,13 @@ lookupOrig :: Module -> OccName -> TcPluginM Name lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod +-- | Resolve a @template-haskell@ 'TH.Name' to a GHC 'Name'. +-- +-- @since 9.14.1 +lookupTHName :: TH.Name -> TcPluginM (Maybe Name) +lookupTHName th = do + nc <- hsc_NC <$> getTopEnv + tcPluginIO $ thNameToGhcNameIO nc th tcLookupGlobal :: Name -> TcPluginM TyThing tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal @@ -174,7 +184,8 @@ newGiven tc_evbinds loc pty evtm = do new_ev <- newEvVar pty setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm) - return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } + return $ CtGiven $ + GivenCt { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc } -- | Create a fresh evidence variable. -- @@ -185,7 +196,7 @@ -- | Create a fresh coercion hole. -- This should only be invoked within 'tcPluginSolve'. newCoercionHole :: PredType -> TcPluginM CoercionHole -newCoercionHole = unsafeTcPluginTcM . TcM.newVanillaCoercionHole +newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole -- | Bind an evidence variable. -- diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs --- a/GHC/Tc/Solver.hs +++ b/GHC/Tc/Solver.hs @@ -4,3835 +4,2244 @@ InferMode(..), simplifyInfer, findInferredDiff, growThetaTyVars, simplifyAmbiguityCheck, - simplifyDefault, - simplifyTop, simplifyTopImplic, - simplifyInteractive, - solveEqualities, - pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX, - reportUnsolvedEqualities, - simplifyWantedsTcM, - tcCheckGivens, - tcCheckWanteds, - tcNormalise, - - captureTopConstraints, - - simplifyTopWanteds, - - promoteTyVarSet, simplifyAndEmitFlatConstraints, - - -- For Rules we need these - solveWanteds, - approximateWC - - ) where - -import GHC.Prelude - -import GHC.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.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.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.Instance.FunDeps -import GHC.Core.Predicate -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType -import GHC.Core.Type -import GHC.Core.Ppr -import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) -import GHC.Builtin.Types -import GHC.Core.Unify ( tcMatchTyKi ) -import GHC.Unit.Module ( getModule ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Basic -import GHC.Types.Id.Make ( unboxedUnitExpr ) -import GHC.Types.Error -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 ) -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import GHC.Data.Maybe ( mapMaybe ) - -{- -********************************************************************************* -* * -* External interface * -* * -********************************************************************************* --} - -captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) --- (captureTopConstraints m) runs m, and returns the type constraints it --- generates plus the constraints produced by static forms inside. --- If it fails with an exception, it reports any insolubles --- (out of scope variables) before doing so --- --- captureTopConstraints is used exclusively by GHC.Tc.Module at the top --- level of a module. --- --- Importantly, if captureTopConstraints propagates an exception, it --- reports any insoluble constraints first, lest they be lost --- altogether. This is important, because solveEqualities (maybe --- other things too) throws an exception without adding any error --- messages; it just puts the unsolved constraints back into the --- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors] --- #16376 is an example of what goes wrong if you don't do this. --- --- NB: the caller should bring any environments into scope before --- calling this, so that the reportUnsolved has access to the most --- complete GlobalRdrEnv -captureTopConstraints thing_inside - = do { static_wc_var <- TcM.newTcRef emptyWC ; - ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ - TcM.tryCaptureConstraints thing_inside - ; stWC <- TcM.readTcRef static_wc_var - - -- See GHC.Tc.Utils.Monad Note [Constraints and errors] - -- If the thing_inside threw an exception, but generated some insoluble - -- constraints, report the latter before propagating the exception - -- Otherwise they will be lost altogether - ; case mb_res of - Just res -> return (res, lie `andWC` stWC) - Nothing -> do { _ <- simplifyTop lie; failM } } - -- This call to simplifyTop is the reason - -- this function is here instead of GHC.Tc.Utils.Monad - -- We call simplifyTop so that it does defaulting - -- (esp of runtime-reps) before reporting errors - -simplifyTopImplic :: Bag Implication -> TcM () -simplifyTopImplic implics - = do { empty_binds <- simplifyTop (mkImplicWC implics) - - -- Since all the inputs are implications the returned bindings will be empty - ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) - - ; return () } - -simplifyTop :: WantedConstraints -> TcM (Bag EvBind) --- Simplify top-level constraints --- Usually these will be implications, --- but when there is nothing to quantify we don't wrap --- in a degenerate implication, so we do that here instead -simplifyTop wanteds - = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds - ; ((final_wc, unsafe_ol), binds1) <- runTcS $ - do { final_wc <- simplifyTopWanteds wanteds - ; unsafe_ol <- getSafeOverlapFailures - ; return (final_wc, unsafe_ol) } - ; traceTc "End simplifyTop }" empty - - ; binds2 <- reportUnsolved final_wc - - ; traceTc "reportUnsolved (unsafe overlapping) {" empty - ; unless (isEmptyBag unsafe_ol) $ do { - -- grab current error messages and clear, warnAllUnsolved will - -- update error messages which we'll grab and then restore saved - -- messages. - ; errs_var <- getErrsVar - ; saved_msg <- TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var emptyMessages - - ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol } - - ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var - ; TcM.writeTcRef errs_var saved_msg - ; recordUnsafeInfer (mkMessages whyUnsafe) - } - ; traceTc "reportUnsolved (unsafe overlapping) }" empty - - ; return (evBindMapBinds binds1 `unionBags` binds2) } - -pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a --- Push level, and solve all resulting equalities --- If there are any unsolved equalities, report them --- and fail (in the monad) --- --- Panics if we solve any non-equality constraints. (In runTCSEqualities --- we use an error thunk for the evidence bindings.) -pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside - = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX - "pushLevelAndSolveEqualities" thing_inside - ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted - ; return res } - -pushLevelAndSolveEqualitiesX :: String -> TcM a - -> TcM (TcLevel, WantedConstraints, a) --- Push the level, gather equality constraints, and then solve them. --- Returns any remaining unsolved equalities. --- Does not report errors. --- --- Panics if we solve any non-equality constraints. (In runTCSEqualities --- we use an error thunk for the evidence bindings.) -pushLevelAndSolveEqualitiesX callsite thing_inside - = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite) - ; (tclvl, (wanted, res)) - <- pushTcLevelM $ - do { (res, wanted) <- captureConstraints thing_inside - ; wanted <- runTcSEqualities (simplifyTopWanteds wanted) - ; return (wanted,res) } - ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted - , text "Level:" <+> ppr tclvl ]) - ; return (tclvl, wanted, res) } - --- | Type-check a thing that emits only equality constraints, solving any --- constraints we can and re-emitting constraints that we can't. --- Use this variant only when we'll get another crack at it later --- See Note [Failure in local type signatures] --- --- Panics if we solve any non-equality constraints. (In runTCSEqualities --- we use an error thunk for the evidence bindings.) -solveEqualities :: String -> TcM a -> TcM a -solveEqualities callsite thing_inside - = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite) - ; (res, wanted) <- captureConstraints thing_inside - ; simplifyAndEmitFlatConstraints wanted - -- simplifyAndEmitFlatConstraints fails outright unless - -- the only unsolved constraints are soluble-looking - -- equalities that can float out - ; traceTc "solveEqualities }" empty - ; return res } - -simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () --- See Note [Failure in local type signatures] -simplifyAndEmitFlatConstraints wanted - = do { -- Solve and zonk to establish the - -- preconditions for floatKindEqualities - wanted <- runTcSEqualities (solveWanteds wanted) - ; wanted <- TcM.liftZonkM $ TcM.zonkWC wanted - - ; traceTc "emitFlatConstraints {" (ppr wanted) - ; case floatKindEqualities wanted of - Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted) - -- Emit the bad constraints, wrapped in an implication - -- See Note [Wrapping failing kind equalities] - ; tclvl <- TcM.getTcLevel - ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted - -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ - -- it's OK to use unkSkol | we must increase the TcLevel, - -- because we don't bind | as explained in - -- any skolem variables here | Note [Wrapping failing kind equalities] - ; emitImplication implic - ; failM } - Just (simples, errs) - -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) - ; traceTc "emitFlatConstraints }" $ - vcat [ text "simples:" <+> ppr simples - , text "errs: " <+> ppr errs ] - -- Holes and other delayed errors don't need promotion - ; emitDelayedErrors errs - ; emitSimples simples } } - -floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) --- Float out all the constraints from the WantedConstraints, --- Return Nothing if any constraints can't be floated (captured --- by skolems), or if there is an insoluble constraint, or --- IC_Telescope telescope error --- Precondition 1: we have tried to solve the 'wanteds', both so that --- the ic_status field is set, and because solving can make constraints --- more floatable. --- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities --- is not monadic --- See Note [floatKindEqualities vs approximateWC] -floatKindEqualities wc = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) - float_wc trapping_tvs (WC { wc_simple = simples - , wc_impl = implics - , wc_errors = errs }) - | all is_floatable simples - = do { (inner_simples, inner_errs) - <- flatMapBagPairM (float_implic trapping_tvs) implics - ; return ( simples `unionBags` inner_simples - , errs `unionBags` inner_errs) } - | otherwise - = Nothing - where - is_floatable ct - | insolubleCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs - - float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError) - float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs - , ic_skols = skols, ic_status = status }) - | isInsolubleStatus status - = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope - | otherwise - = do { (simples, holes) <- float_wc new_trapping_tvs wanted - ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $ - Nothing - -- If there are some constraints to float out, but we can't - -- because we don't float out past local equalities - -- (c.f GHC.Tc.Solver.approximateWC), then fail - ; return (simples, holes) } - where - new_trapping_tvs = trapping_tvs `extendVarSetList` skols - - -{- Note [Failure in local type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind checking a type signature, we like to fail fast if we can't -solve all the kind equality constraints, for two reasons: - - * A kind-bogus type signature may cause a cascade of knock-on - errors if we let it pass - - * More seriously, we don't have a convenient term-level place to add - deferred bindings for unsolved kind-equality constraints. In - earlier GHCs this led to un-filled-in coercion holes, which caused - GHC to crash with "fvProv falls into a hole" See #11563, #11520, - #11516, #11399 - -But what about /local/ type signatures, mentioning in-scope type -variables for which there might be 'given' equalities? For these we -might not be able to solve all the equalities locally. Here's an -example (T15076b): - - class (a ~ b) => C a b - data SameKind :: k -> k -> Type where { SK :: SameKind a b } - - bar :: forall (a :: Type) (b :: Type). - C a b => Proxy a -> Proxy b -> () - bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) - -Consider the type signature on 'undefined'. It's ill-kinded unless -a~b. But the superclass of (C a b) means that indeed (a~b). So all -should be well. BUT it's hard to see that when kind-checking the signature -for undefined. We want to emit a residual (a~b) constraint, to solve -later. - -Another possibility is that we might have something like - F alpha ~ [Int] -where alpha is bound further out, which might become soluble -"later" when we learn more about alpha. So we want to emit -those residual constraints. - -BUT it's no good simply wrapping all unsolved constraints from -a type signature in an implication constraint to solve later. The -problem is that we are going to /use/ that signature, including -instantiate it. Say we have - f :: forall a. (forall b. blah) -> blah2 - f x = -To typecheck the definition of f, we have to instantiate those -foralls. Moreover, any unsolved kind equalities will be coercion -holes in the type. If we naively wrap them in an implication like - forall a. (co1:k1~k2, forall b. co2:k3~k4) -hoping to solve it later, we might end up filling in the holes -co1 and co2 with coercions involving 'a' and 'b' -- but by now -we've instantiated the type. Chaos! - -Moreover, the unsolved constraints might be skolem-escape things, and -if we proceed with f bound to a nonsensical type, we get a cascade of -follow-up errors. For example polykinds/T12593, T15577, and many others. - -So here's the plan (see tcHsSigType): - -* pushLevelAndSolveEqualitiesX: try to solve the constraints - -* kindGeneraliseSome: do kind generalisation - -* buildTvImplication: build an implication for the residual, unsolved - constraint - -* simplifyAndEmitFlatConstraints: try to float out every unsolved equality - inside that implication, in the hope that it constrains only global - type variables, not the locally-quantified ones. - - * If we fail, or find an insoluble constraint, emit the implication, - so that the errors will be reported, and fail. - - * If we succeed in floating all the equalities, promote them and - re-emit them as flat constraint, not wrapped at all (since they - don't mention any of the quantified variables. - -* Note that this float-and-promote step means that anonymous - wildcards get floated to top level, as we want; see - Note [Checking partial type signatures] in GHC.Tc.Gen.HsType. - -All this is done: - -* In GHC.Tc.Gen.HsType.tcHsSigType, as above - -* solveEqualities. Use this when there no kind-generalisation - step to complicate matters; then we don't need to push levels, - and can solve the equalities immediately without needing to - wrap it in an implication constraint. (You'll generally see - a kindGeneraliseNone nearby.) - -* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to - pushLevelAndSolveEqualitiesX, followed by quantification, and - then reportUnsolvedEqualities. - - NB: we call reportUnsolvedEqualities before zonkTcTypeToType - because the latter does not expect to see any un-filled-in - coercions, which will happen if we have unsolved equalities. - By calling reportUnsolvedEqualities first, which fails after - reporting errors, we avoid that happening. - -See also #18062, #11506 - -Note [Wrapping failing kind equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In simplifyAndEmitFlatConstraints, if we fail to get down to simple -flat constraints we will -* re-emit the constraints so that they are reported -* fail in the monad -But there is a Terrible Danger that, if -fdefer-type-errors is on, and -we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll -report only a warning and proceed with compilation. But if we ever fail -in the monad it should be fatal; we should report an error and stop after -the type checker. If not, chaos results: #19142. - -Our solution is this: -* Even with -fdefer-type-errors, inside an implication with no place for - value bindings (ic_binds = CoEvBindsVar), report failing equalities as - errors. We have to do this anyway; see GHC.Tc.Errors - Note [Failing equalities with no evidence bindings]. - -* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication - to wrap the failing constraint in a degenerate implication (no - skolems, no theta), with ic_binds = CoEvBindsVar. This setting of - `ic_binds` means that any failing equalities will lead to an - error not a warning, irrespective of -fdefer-type-errors: see - Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors, - and `maybeSwitchOffDefer` in that module. - - We still take care to bump the TcLevel of the implication. Partly, - that ensures that nested implications have increasing level numbers - which seems nice. But more specifically, suppose the outer level - has a Given `(C ty)`, which has pending (not-yet-expanded) - superclasses. Consider what happens when we process this implication - constraint (which we have re-emitted) in that context: - - in the inner implication we'll call `getPendingGivenScs`, - - we /do not/ want to get the `(C ty)` from the outer level, - lest we try to add an evidence term for the superclass, - which we can't do because we have specifically set - `ic_binds` = `CoEvBindsVar`. - - as `getPendingGivenSCcs is careful to only get Givens from - the /current/ level, and we bumped the `TcLevel` of the implication, - we're OK. - - TL;DR: bump the `TcLevel` when creating the nested implication. - If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043). - - -We re-emit the implication rather than reporting the errors right now, -so that the error messages are improved by other solving and defaulting. -e.g. we prefer - Cannot match 'Type->Type' with 'Type' -to Cannot match 'Type->Type' with 'TYPE r0' - - -Note [floatKindEqualities vs approximateWC] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -floatKindEqualities and approximateWC are strikingly similar to each -other, but - -* floatKindEqualites tries to float /all/ equalities, and fails if - it can't, or if any implication is insoluble. -* approximateWC just floats out any constraints - (not just equalities) that can float; it never fails. --} - - -reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel - -> WantedConstraints -> TcM () --- Reports all unsolved wanteds provided; fails in the monad if there are any. --- --- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to --- provide skolem info for any errors. -reportUnsolvedEqualities skol_info skol_tvs tclvl wanted - = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted - -report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel - -> WantedConstraints -> TcM () -report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted - | isEmptyWC wanted - = return () - - | otherwise -- NB: we build an implication /even if skol_tvs is empty/, - -- just to ensure that our level invariants hold, specifically - -- (WantedInv). See Note [TcLevel invariants]. - = checkNoErrs $ -- Fail - do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted - ; reportAllUnsolved (mkImplicWC (unitBag implic)) } - - --- | Simplify top-level constraints, but without reporting any unsolved --- constraints nor unsafe overlapping. -simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints - -- 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 - - -- 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. - - && isMetaTyVar tv - -- Weed out runtime-skolems in GHCi, which we definitely - -- shouldn't try to default. - - && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc) - -- Weed out variables for which defaulting would be unhelpful, - -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk]. - - ; 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 - - 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 } - - try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints - try_callstack_defaulting wc - | isEmptyWC wc - = return wc - | otherwise - = defaultCallStacks wc - --- | If an implication contains a Given of the form @Unsatisfiable msg@, use --- it to solve all Wanteds within the implication. --- --- 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 = - do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc - ; if did_work - then nestTcS (solveWanteds final_wc) - else return final_wc } - where - go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs }) - = do impls' <- mapMaybeBagM go_impl impls - return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs } - go_impl impl - | isSolvedStatus (ic_status impl) - = return $ Just impl - -- Is there a Given with type "Unsatisfiable msg"? - -- If so, use it to solve all other Wanteds. - | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl) - = do { put True - ; lift $ solveImplicationUsingUnsatGiven unsat_given impl } - -- Otherwise, recurse. - | otherwise - = do { wcs' <- go_wc (ic_wanted impl) - ; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } } - --- | Is this evidence variable the evidence for an 'Unsatisfiable' constraint? --- --- If so, return the variable itself together with the error message type. -unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type) -unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v) - --- | We have an implication with an 'Unsatisfiable' Given; use that Given to --- solve all the other Wanted constraints, including those nested within --- deeper implications. -solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS (Maybe Implication) -solveImplicationUsingUnsatGiven - unsat_given@(given_ev,_) - impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var, ic_need_inner = inner }) - | isCoEvBindsVar ev_binds_var - -- We can't use Unsatisfiable evidence in kinds. - -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence. - = return $ Just impl - | otherwise - = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd - ; setImplicationStatus $ - impl { ic_wanted = wcs - , ic_need_inner = inner `extendVarSet` given_ev } } - where - go_wc :: WantedConstraints -> TcS WantedConstraints - go_wc wc@(WC { wc_simple = wtds, wc_impl = impls }) - = do { mapBagM_ go_simple wtds - ; impls <- mapMaybeBagM (solveImplicationUsingUnsatGiven unsat_given) impls - ; return $ wc { wc_simple = emptyBag, wc_impl = impls } } - go_simple :: Ct -> TcS () - go_simple ct = case ctEvidence ct of - CtWanted { ctev_pred = pty, ctev_dest = dst } - -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty - ; setWantedEvTerm dst True $ EvExpr ev_expr } - _ -> return () - --- | Create an evidence expression for an arbitrary constraint using --- evidence for an "Unsatisfiable" Given. --- --- See Note [Evidence terms from Unsatisfiable Givens] -unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr -unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty - = do { mod <- getModule - -- If we're typechecking GHC.TypeError, return a bogus expression; - -- it's only used for the ambiguity check, which throws the evidence away anyway. - -- This avoids problems with circularity; where we are trying to look - -- up the "unsatisfiable" Id while we are in the middle of typechecking it. - ; if mod == gHC_TYPEERROR then return (Var unsat_ev) else - do { unsatisfiable_id <- tcLookupId unsatisfiableIdName - - -- See Note [Evidence terms from Unsatisfiable Givens] - -- for a description of what evidence term we are constructing here. - - ; let -- (##) -=> wtd_ty - fun_ty = mkFunTy visArgConstraintLike ManyTy unboxedUnitTy wtd_ty - mkDictBox = case boxingDataCon fun_ty of - BI_Box { bi_data_con = mkDictBox } -> mkDictBox - _ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty) - dictBox = dataConTyCon mkDictBox - ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty - -- Dict ((##) -=> wtd_ty) - ; let scrut_ty = mkTyConApp dictBox [fun_ty] - -- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev - scrut = - mkCoreApps (Var unsatisfiable_id) - [ Type liftedRepTy - , Type given_msg - , Type scrut_ty - , Var unsat_ev ] - -- case scrut of { MkDictBox @((##) -=> wtd_ty)) ct -> ct (# #) } - ev_expr = - mkWildCase scrut (unrestricted $ scrut_ty) wtd_ty - [ Alt (DataAlt mkDictBox) [ev_bndr] $ - mkCoreApps (Var ev_bndr) [unboxedUnitExpr] - ] - ; return ev_expr } } - -{- Note [Evidence terms from Unsatisfiable Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An Unsatisfiable Given constraint, of the form [G] Unsatisfiable msg, should be -able to solve ANY Wanted constraint whatsoever. - -Recall that we have - - unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep) - . Unsatisfiable msg => a - -We want to use this function, together with the evidence -[G] unsat_ev :: Unsatisfiable msg, to solve any other constraint [W] wtd_ty. - -We could naively think that a valid evidence term for the Wanted might be: - - wanted_ev = unsatisfiable @{rep} @msg @wtd_ty unsat_ev - -Unfortunately, this is a kind error: "wtd_ty :: CONSTRAINT rep", but -"unsatisfiable" expects the third type argument to be of kind "TYPE rep". - -Instead, we use a boxing data constructor to box the constraint into a type. -In the end, we construct the following evidence for the implication: - - [G] unsat_ev :: Unsatisfiable msg - ==> - [W] wtd_ev :: wtd_ty - - wtd_ev = - case unsatisfiable @{LiftedRep} @msg @(Dict ((##) -=> wtd_ty)) unsat_ev of - MkDictBox ct -> ct (# #) - -Note that we play the same trick with the function arrow -=> that we did -in order to define "unsatisfiable" in terms of "unsatisfiableLifted", as described -in Note [The Unsatisfiable representation-polymorphism trick] in base:GHC.TypeError. -This allows us to indirectly box constraints with different representations -(such as primitive equality constraints). --} - --- | Default any remaining @CallStack@ constraints to empty @CallStack@s. -defaultCallStacks :: WantedConstraints -> TcS WantedConstraints --- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence -defaultCallStacks wanteds - = 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 }) - - where - - handle_simples simples - = catBagMaybes <$> mapBagM defaultCallStack simples - - 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 - defaultCallStacks (ic_wanted implic) - ; setImplicationStatus (implic { ic_wanted = wanteds }) } - - defaultCallStack ct - | ClassPred cls tys <- classifyPredType (ctPred ct) - , Just {} <- isCallStackPred cls tys - = do { solveCallStack (ctEvidence ct) EvCsEmpty - ; return Nothing } - - defaultCallStack ct - = return (Just ct) - - -{- Note [When to do type-class defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC -was false, on the grounds that defaulting can't help solve insoluble -constraints. But if we *don't* do defaulting we may report a whole -lot of errors that would be solved by defaulting; these errors are -quite spurious because fixing the single insoluble error means that -defaulting happens again, which makes all the other errors go away. -This is jolly confusing: #9033. - -So it seems better to always do type-class defaulting. - -However, always doing defaulting does mean that we'll do it in -situations like this (#5934): - run :: (forall s. GenST s) -> Int - run = fromInteger 0 -We don't unify the return type of fromInteger with the given function -type, because the latter involves foralls. So we're left with - (Num alpha, alpha ~ (forall s. GenST s) -> Int) -Now we do defaulting, get alpha := Integer, and report that we can't -match Integer with (forall s. GenST s) -> Int. That's not totally -stupid, but perhaps a little strange. - -Another potential alternative would be to suppress *all* non-insoluble -errors if there are *any* insoluble errors, anywhere, but that seems -too drastic. - -Note [Don't default in syntactic equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When there are unsolved syntactic equalities such as - - rr[sk] ~S# alpha[conc] - -we should not default alpha, lest we obtain a poor error message such as - - Couldn't match kind `rr' with `LiftedRep' - -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. - -Note [Must simplify after defaulting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may have a deeply buried constraint - (t:*) ~ (a:Open) -which we couldn't solve because of the kind incompatibility, and 'a' is free. -Then when we default 'a' we can solve the constraint. And we want to do -that before starting in on type classes. We MUST do it before reporting -errors, because it isn't an error! #7967 was due to this. - -Note [Top-level Defaulting Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have considered two design choices for where/when to apply defaulting. - (i) Do it in SimplCheck mode only /whenever/ you try to solve some - simple constraints, maybe deep inside the context of implications. - This used to be the case in GHC 7.4.1. - (ii) Do it in a tight loop at simplifyTop, once all other constraints have - finished. This is the current story. - -Option (i) had many disadvantages: - a) Firstly, it was deep inside the actual solver. - b) Secondly, it was dependent on the context (Infer a type signature, - or Check a type signature, or Interactive) since we did not want - to always start defaulting when inferring (though there is an exception to - this, see Note [Default while Inferring]). - c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: - f :: Int -> Bool - f x = const True (\y -> let w :: a -> a - w a = const a (y+1) - in w y) - We will get an implication constraint (for beta the type of y): - [untch=beta] forall a. 0 => Num beta - which we really cannot default /while solving/ the implication, since beta is - untouchable. - -Instead our new defaulting story is to pull defaulting out of the solver loop and -go with option (ii), implemented at SimplifyTop. Namely: - - First, have a go at solving the residual constraint of the whole - program - - Try to approximate it with a simple constraint - - Figure out derived defaulting equations for that simple constraint - - Go round the loop again if you did manage to get some equations - -Now, that has to do with class defaulting. However there exists type variable /kind/ -defaulting. Again this is done at the top-level and the plan is: - - At the top-level, once you had a go at solving the constraint, do - figure out /all/ the touchable unification variables of the wanted constraints. - - Apply defaulting to their kinds - -More details in Note [DefaultTyVar]. - -Note [Safe Haskell Overlapping Instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Safe Haskell, we apply an extra restriction to overlapping instances. The -motive is to prevent untrusted code provided by a third-party, changing the -behavior of trusted code through type-classes. This is due to the global and -implicit nature of type-classes that can hide the source of the dictionary. - -Another way to state this is: if a module M compiles without importing another -module N, changing M to import N shouldn't change the behavior of M. - -Overlapping instances with type-classes can violate this principle. However, -overlapping instances aren't always unsafe. They are just unsafe when the most -selected dictionary comes from untrusted code (code compiled with -XSafe) and -overlaps instances provided by other modules. - -In particular, in Safe Haskell at a call site with overlapping instances, we -apply the following rule to determine if it is a 'unsafe' overlap: - - 1) Most specific instance, I1, defined in an `-XSafe` compiled module. - 2) I1 is an orphan instance or a MPTC. - 3) At least one overlapped instance, Ix, is both: - A) from a different module than I1 - B) Ix is not marked `OVERLAPPABLE` - -This is a slightly involved heuristic, but captures the situation of an -imported module N changing the behavior of existing code. For example, if -condition (2) isn't violated, then the module author M must depend either on a -type-class or type defined in N. - -Secondly, when should these heuristics be enforced? We enforced them when the -type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. -This allows `-XUnsafe` modules to operate without restriction, and for Safe -Haskell inference to infer modules with unsafe overlaps as unsafe. - -One alternative design would be to also consider if an instance was imported as -a `safe` import or not and only apply the restriction to instances imported -safely. However, since instances are global and can be imported through more -than one path, this alternative doesn't work. - -Note [Safe Haskell Overlapping Instances Implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How is this implemented? It's complicated! So we'll step through it all: - - 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where - we check if a particular type-class method call is safe or unsafe. We do this - through the return type, `ClsInstLookupResult`, where the last parameter is a - list of instances that are unsafe to overlap. When the method call is safe, - the list is null. - - 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution - / dictionary generation. The return type is `ClsInstResult`, which either - says no instance matched, or one found, and if it was a safe or unsafe - overlap. - - 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and - tries to resolve it by calling (in part) `matchClassInst`. The resolving - mechanism has a work list (of constraints) that it process one at a time. If - the constraint can't be resolved, it's added to an inert set. When compiling - an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know - compilation should fail. These are handled as normal constraint resolution - failures from here-on (see step 6). - - Otherwise, we may be inferring safety (or using `-Wunsafe`), and - compilation should succeed, but print warnings and/or mark the compiled module - as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds - the unsafe (but resolved!) constraint to the `inert_safehask` field of - `InertCans`. - - 4) `GHC.Tc.Solver.simplifyTop`: - * Call simplifyTopWanteds, the top-level function for driving the simplifier for - constraint resolution. - - * Once finished, call `getSafeOverlapFailures` to retrieve the - list of overlapping instances that were successfully resolved, - but unsafe. Remember, this is only applicable for generating warnings - (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` - cause compilation failure by not resolving the unsafe constraint at all. - - * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`, - while for resolved but unsafe overlapping dictionary constraints, call - `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a - warning message for the user. - - * In the case of `warnAllUnsolved` for resolved, but unsafe - dictionary constraints, we collect the generated warning - message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to - mark the module we are compiling as unsafe, passing the - warning message along as the reason. - - 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by - actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we - know is the constraint that is unresolved or unsafe. For dictionary, all we - know is that we need a dictionary of type C, but not what instances are - available and how they overlap. So we once again call `lookupInstEnv` to - figure that out so we can generate a helpful error message. - - 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in - IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. - - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling - `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference - failed. - -Note [No defaulting in the ambiguity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying constraints for the ambiguity check, we use -solveWanteds, not simplifyTopWanteds, so that we do no defaulting. -#11947 was an example: - f :: Num a => Int -> Int -This is ambiguous of course, but we don't want to default the -(Num alpha) constraint to (Num Int)! Doing so gives a defaulting -warning, but no error. - -Note [Defaulting insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a set of wanteds is insoluble, we have no hope of accepting the -program. Yet we do not stop constraint solving, etc., because we may -simplify the wanteds to produce better error messages. So, once -we have an insoluble constraint, everything we do is just about producing -helpful error messages. - -Should we default in this case or not? Let's look at an example (tcfail004): - - (f,g) = (1,2,3) - -With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). -Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) -find the latter more helpful. Several other test cases (e.g. tcfail005) suggest -similarly. So: we should not do class defaulting with insolubles. - -On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: - - f :: Integer i => i - f = 0 - -Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind -TYPE r0 -> Constraint and then complains that r0 is actually untouchable -(presumably, because it can't be sure if `Integer i` entails an equality). -If we default, we are told of a clash between (* -> Constraint) and Constraint. -The latter seems far better, suggesting we *should* do RuntimeRep-defaulting -even on insolubles. - -But, evidently, not always. Witness UnliftedNewtypesInfinite: - - newtype Foo = FooC (# Int#, Foo #) - -This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). -If we default RuntimeRep-vars, we get - - Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted - -which is just plain wrong. - -Another situation in which we don't want to default involves concrete metavariables. - -In equalities such as alpha[conc] ~# rr[sk] , alpha[conc] ~# RR beta[tau] -for a type family RR (all at kind RuntimeRep), we would prefer to report a -representation-polymorphism error rather than default alpha and get error: - - Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted` - -which is very confusing. For this reason, we weed out the concrete -metavariables participating in such equalities in nonDefaultableTyVarsOfWC. -Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could -become soluble after defaulting beta (see also #21430). - -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the -user does not want to hear about RuntimeRep stuff -- that is, when --fprint-explicit-runtime-reps is not set. -However, we must still take care not to default concrete type variables -participating in an equality with a non-concrete type, as seen in the -last example above. --} - ------------------- -simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () -simplifyAmbiguityCheck ty wanteds - = do { traceTc "simplifyAmbiguityCheck {" $ - text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds - - ; (final_wc, _) <- runTcS $ useUnsatisfiableGivens =<< solveWanteds wanteds - -- NB: no defaulting! See Note [No defaulting in the ambiguity check] - -- Note: we do still use Unsatisfiable Givens to solve Wanteds, - -- see Wrinkle [Ambiguity] under point (C) of - -- Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. - - ; discardResult (reportUnsolved final_wc) - - ; traceTc "End simplifyAmbiguityCheck }" empty } - ------------------- -simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) -simplifyInteractive wanteds - = traceTc "simplifyInteractive" empty >> - simplifyTop wanteds - ------------------- -simplifyDefault :: ThetaType -- Wanted; has no type variables in it - -> TcM Bool -- Return if the constraint is soluble -simplifyDefault theta - = do { traceTc "simplifyDefault" empty - ; wanteds <- newWanteds DefaultOrigin theta - ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds)) - ; return (isEmptyWC unsolved) } - ------------------- -{- Note [Pattern match warnings with insoluble Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A pattern match on a GADT can introduce new type-level information, which needs -to be analysed in order to get the expected pattern match warnings. - -For example: - -> type IsBool :: Type -> Constraint -> type family IsBool a where -> IsBool Bool = () -> IsBool b = b ~ Bool -> -> data T a where -> MkTInt :: Int -> T Int -> MkTBool :: IsBool b => b -> T b -> -> f :: T Int -> Int -> f (MkTInt i) = i - -The pattern matching performed by `f` is complete: we can't ever call -`f (MkTBool b)`, as type-checking that application would require producing -evidence for `Int ~ Bool`, which can't be done. - -The pattern match checker uses `tcCheckGivens` to accumulate all the Given -constraints, and relies on `tcCheckGivens` to return Nothing if the -Givens become insoluble. `tcCheckGivens` in turn relies on `insolubleCt` -to identify these insoluble constraints. So the precise definition of -`insolubleCt` has a big effect on pattern match overlap warnings. - -To detect this situation, we check whether there are any insoluble Given -constraints. In the example above, the insoluble constraint was an -equality constraint, but it is also important to detect custom type errors: - -> type NotInt :: Type -> Constraint -> type family NotInt a where -> NotInt Int = TypeError (Text "That's Int, silly.") -> NotInt _ = () -> -> data R a where -> MkT1 :: a -> R a -> MkT2 :: NotInt a => R a -> -> foo :: R Int -> Int -> foo (MkT1 x) = x - -To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble -because it is a custom type error. -Failing to do so proved quite inconvenient for users, as evidence by the -tickets #11503 #14141 #16377 #20180. -Test cases: T11503, T14141. - -Examples of constraints that tcCheckGivens considers insoluble: - - Int ~ Bool, - - Coercible Float Word, - - TypeError msg. - -Non-examples: - - constraints which we know aren't satisfied, - e.g. Show (Int -> Int) when no such instance is in scope, - - Eq (TypeError msg), - - C (Int ~ Bool), with @class C (c :: Constraint)@. --} - -tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) --- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely --- contradictory. --- --- See Note [Pattern match warnings with insoluble Givens] above. -tcCheckGivens inerts given_ids = do - (sat, new_inerts) <- runTcSInerts inerts $ do - traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) - lcl_env <- TcS.getLclEnv - let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) - let given_cts = mkGivens given_loc (bagToList given_ids) - -- See Note [Superclasses and satisfiability] - solveSimpleGivens given_cts - insols <- getInertInsols - insols <- try_harder insols - traceTcS "checkGivens }" (ppr insols) - return (isEmptyBag insols) - return $ if sat then Just new_inerts else Nothing - where - try_harder :: Cts -> TcS Cts - -- Maybe we have to search up the superclass chain to find - -- an unsatisfiable constraint. Example: pmcheck/T3927b. - -- At the moment we try just once - try_harder insols - | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable - = return insols -- Hurrah -- stop now. - | otherwise - = do { pending_given <- getPendingGivenScs - ; new_given <- makeSuperClasses pending_given - ; solveSimpleGivens new_given - ; getInertInsols } - -tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool --- ^ Return True if the Wanteds are soluble, False if not -tcCheckWanteds inerts wanteds = do - cts <- newWanteds PatCheckOrigin wanteds - (sat, _new_inerts) <- runTcSInerts inerts $ do - traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) - -- See Note [Superclasses and satisfiability] - wcs <- solveWanteds (mkSimpleWC cts) - traceTcS "checkWanteds }" (ppr wcs) - return (isSolvedWC wcs) - return sat - --- | Normalise a type as much as possible using the given constraints. --- See @Note [tcNormalise]@. -tcNormalise :: InertSet -> Type -> TcM Type -tcNormalise inerts ty - = do { norm_loc <- getCtLocM PatCheckOrigin Nothing - ; (res, _new_inerts) <- runTcSInerts inerts $ - do { traceTcS "tcNormalise {" (ppr inerts) - ; ty' <- rewriteType norm_loc ty - ; traceTcS "tcNormalise }" (ppr ty') - ; pure ty' } - ; return res } - -{- Note [Superclasses and satisfiability] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expand superclasses before starting, because (Int ~ Bool), has -(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) -as a superclass, and it's the latter that is insoluble. See -Note [The equality types story] in GHC.Builtin.Types.Prim. - -If we fail to prove unsatisfiability we (arbitrarily) try just once to -find superclasses, using try_harder. Reason: we might have a type -signature - f :: F op (Implements push) => .. -where F is a type function. This happened in #3972. - -We could do more than once but we'd have to have /some/ limit: in the -the recursive case, we would go on forever in the common case where -the constraints /are/ satisfiable (#10592 comment:12!). - -For straightforward situations without type functions the try_harder -step does nothing. - -Note [tcNormalise] -~~~~~~~~~~~~~~~~~~ -tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas -most invocations of the constraint solver are intended to simplify a set of -constraints or to decide if a particular set of constraints is satisfiable, -the purpose of tcNormalise is to take a type, plus some locally solved -constraints in the form of an InertSet, and normalise the type as much as -possible with respect to those constraints. - -It does *not* reduce type or data family applications or look through newtypes. - -Why is this useful? As one example, when coverage-checking an EmptyCase -expression, it's possible that the type of the scrutinee will only reduce -if some local equalities are solved for. See "Wrinkle: Local equalities" -in Note [Type normalisation] in "GHC.HsToCore.Pmc". - -To accomplish its stated goal, tcNormalise first initialises the solver monad -with the given InertCans, then uses rewriteType to simplify the desired type -with respect to the Givens in the InertCans. - -*********************************************************************************** -* * -* Inference -* * -*********************************************************************************** - -Note [Inferring the type of a let-bound variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = rhs - -To infer f's type we do the following: - * Gather the constraints for the RHS with ambient level *one more than* - the current one. This is done by the call - pushLevelAndCaptureConstraints (tcMonoBinds...) - in GHC.Tc.Gen.Bind.tcPolyInfer - - * Call simplifyInfer to simplify the constraints and decide what to - quantify over. We pass in the level used for the RHS constraints, - here called rhs_tclvl. - -This ensures that the implication constraint we generate, if any, -has a strictly-increased level compared to the ambient level outside -the let binding. - -Note [Inferring principal types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't always infer principal types. For instance, the inferred type for - -> f x = show [x] - -is - -> f :: Show a => a -> String - -This is not the most general type if we allow flexible contexts. -Indeed, if we try to write the following - -> g :: Show [a] => a -> String -> g x = f x - -we get the error: - - * Could not deduce (Show a) arising from a use of `f' - from the context: Show [a] - -Though replacing f x in the right-hand side of g with the definition -of f x works, the call to f x does not. This is the hallmark of -unprincip{led,al} types. - -Another example: - -> class C a -> class D a where -> d :: a -> instance C a => D a where -> d = undefined -> h _ = d -- argument is to avoid the monomorphism restriction - -The inferred type for h is - -> h :: C a => t -> a - -even though - -> h :: D a => t -> a - -is more general. - -The fix is easy: don't simplify constraints before inferring a type. -That is, have the inferred type quantify over all constraints that arise -in a definition's right-hand side, even if they are simplifiable. -Unfortunately, this would yield all manner of unwieldy types, -and so we won't do so. --} - --- | How should we choose which constraints to quantify over? -data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, - -- never quantifying over any constraints - | EagerDefaulting -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module", - -- the :type +d case; this mode refuses - -- to quantify over any defaultable constraint - | NoRestrictions -- ^ Quantify over any constraint that - -- satisfies pickQuantifiablePreds - -instance Outputable InferMode where - ppr ApplyMR = text "ApplyMR" - ppr EagerDefaulting = text "EagerDefaulting" - ppr NoRestrictions = text "NoRestrictions" - -simplifyInfer :: TcLevel -- Used when generating the constraints - -> InferMode - -> [TcIdSigInst] -- Any signatures (possibly partial) - -> [(Name, TcTauType)] -- Variables to be generalised, - -- and their tau-types - -> WantedConstraints - -> TcM ([TcTyVar], -- Quantify over these type variables - [EvVar], -- ... and these constraints (fully zonked) - TcEvBinds, -- ... binding these evidence variables - Bool) -- True <=> the residual constraints are insoluble - -simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds - | isEmptyWC wanteds - = do { -- When quantifying, we want to preserve any order of variables as they - -- appear in partial signatures. cf. decideQuantifiedTyVars - let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs - , (_,Bndr tv _) <- sig_inst_skols sig ] - psig_theta = [ pred | sig <- partial_sigs - , pred <- sig_inst_theta sig ] - - ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) - - ; skol_info <- mkSkolemInfo (InferSkol name_taus) - ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars - ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) - ; return (qtkvs, [], emptyTcEvBinds, False) } - - | otherwise - = do { traceTc "simplifyInfer {" $ vcat - [ text "sigs =" <+> ppr sigs - , text "binds =" <+> ppr name_taus - , text "rhs_tclvl =" <+> ppr rhs_tclvl - , text "infer_mode =" <+> ppr infer_mode - , text "(unzonked) wanted =" <+> ppr wanteds - ] - - ; let psig_theta = concatMap sig_inst_theta partial_sigs - - -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - - ; ev_binds_var <- TcM.newTcEvBinds - ; psig_evs <- newWanteds AnnOrigin psig_theta - ; wanted_transformed - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ - solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) - -- psig_evs : see Note [Add signature contexts as wanteds] - -- See Note [Inferring principal types] - - -- Find quant_pred_candidates, the predicates that - -- we'll consider quantifying over - -- NB1: wanted_transformed does not include anything provable from - -- the psig_theta; it's just the extra bit - -- NB2: We do not do any defaulting when inferring a type, this can lead - -- to less polymorphic types, see Note [Default while Inferring] - ; wanted_transformed <- TcM.liftZonkM $ TcM.zonkWC wanted_transformed - ; let definite_error = insolubleWC wanted_transformed - -- See Note [Quantification with errors] - quant_pred_candidates - | definite_error = [] - | otherwise = ctsPreds (approximateWC False wanted_transformed) - - -- Decide what type variables and constraints to quantify - -- NB: quant_pred_candidates is already fully zonked - -- NB: bound_theta are constraints we want to quantify over, - -- including the psig_theta, which we always quantify over - -- NB: bound_theta are fully zonked - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl - name_taus partial_sigs - quant_pred_candidates - ; bound_theta_vars <- mapM TcM.newEvVar bound_theta - - ; let full_theta = map idType bound_theta_vars - ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ]) - } - - - -- Now emit the residual constraint - ; emitResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs bound_theta_vars - wanted_transformed - - -- All done! - ; traceTc "} simplifyInfer/produced residual implication for quantification" $ - vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates - , text "psig_theta =" <+> ppr psig_theta - , text "bound_theta =" <+> pprCoreBinders bound_theta_vars - , text "qtvs =" <+> ppr qtvs - , text "definite_error =" <+> ppr definite_error ] - - ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } - -- NB: bound_theta_vars must be fully zonked - where - partial_sigs = filter isPartialSig sigs - --------------------- -emitResidualConstraints :: TcLevel -> EvBindsVar - -> [(Name, TcTauType)] - -> CoVarSet -> [TcTyVar] -> [EvVar] - -> WantedConstraints -> TcM () --- Emit the remaining constraints from the RHS. -emitResidualConstraints rhs_tclvl ev_binds_var - name_taus co_vars qtvs full_theta_vars wanteds - | isEmptyWC wanteds - = return () - - | otherwise - = do { wanted_simple <- TcM.liftZonkM $ TcM.zonkSimples (wc_simple wanteds) - ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple - is_mono ct - | Just ct_ev_id <- wantedEvId_maybe ct - = ct_ev_id `elemVarSet` co_vars - | otherwise - = False - -- Reason for the partition: - -- see Note [Emitting the residual implication in simplifyInfer] - --- Already done by defaultTyVarsAndSimplify --- ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) - - ; let inner_wanted = wanteds { wc_simple = inner_simple } - ; implics <- if isEmptyWC inner_wanted - then return emptyBag - else do implic1 <- newImplication - return $ unitBag $ - implic1 { ic_tclvl = rhs_tclvl - , ic_skols = qtvs - , ic_given = full_theta_vars - , ic_wanted = inner_wanted - , ic_binds = ev_binds_var - , ic_given_eqs = MaybeGivenEqs - , ic_info = skol_info } - - ; emitConstraints (emptyWC { wc_simple = outer_simple - , wc_impl = implics }) } - where - full_theta = map idType full_theta_vars - skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty) - | (name, ty) <- name_taus ] - -- We don't add the quantified variables here, because they are - -- also bound in ic_skols and we want them to be tidied - -- uniformly. - --------------------- -findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType --- Given a partial type signature f :: (C a, D a, _) => blah --- and the inferred constraints (X a, D a, Y a, C a) --- compute the difference, which is what will fill in the "_" underscore, --- In this case the diff is (X a, Y a). -findInferredDiff annotated_theta inferred_theta - | null annotated_theta -- Short cut the common case when the user didn't - = return inferred_theta -- write any constraints in the partial signature - | otherwise - = pushTcLevelM_ $ - do { lcl_env <- TcM.getLclEnv - ; given_ids <- mapM TcM.newEvVar annotated_theta - ; wanteds <- newWanteds AnnOrigin inferred_theta - ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) - given_cts = mkGivens given_loc given_ids - - ; (residual, _) <- runTcS $ - do { _ <- solveSimpleGivens given_cts - ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } - -- NB: There are no meta tyvars fromn this level annotated_theta - -- because we have either promoted them or unified them - -- See `Note [Quantification and partial signatures]` Wrinkle 2 - - ; return (map (box_pred . ctPred) $ - bagToList $ - wc_simple residual) } - where - box_pred :: PredType -> PredType - box_pred pred = case classifyPredType pred of - EqPred rel ty1 ty2 - | Just (cls,tys) <- boxEqPred rel ty1 ty2 - -> mkClassPred cls tys - | otherwise - -> pprPanic "findInferredDiff" (ppr pred) - _other -> pred - -{- Note [Emitting the residual implication in simplifyInfer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f = e -where f's type is inferred to be something like (a, Proxy k (Int |> co)) -and we have an as-yet-unsolved, or perhaps insoluble, constraint - [W] co :: Type ~ k -We can't form types like (forall co. blah), so we can't generalise over -the coercion variable, and hence we can't generalise over things free in -its kind, in the case 'k'. But we can still generalise over 'a'. So -we'll generalise to - f :: forall a. (a, Proxy k (Int |> co)) -Now we do NOT want to form the residual implication constraint - forall a. [W] co :: Type ~ k -because then co's eventual binding (which will be a value binding if we -use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose -type mentions 'co'). Instead, just as we don't generalise over 'co', we -should not bury its constraint inside the implication. Instead, we must -put it outside. - -That is the reason for the partitionBag in emitResidualConstraints, -which takes the CoVars free in the inferred type, and pulls their -constraints out. (NB: this set of CoVars should be closed-over-kinds.) - -All rather subtle; see #14584. - -Note [Add signature contexts as wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#11016): - f2 :: (?x :: Int) => _ - f2 = ?x - -or this - class C a b | a -> b - g :: C p q => p -> q - f3 :: C Int b => _ - f3 = g (3::Int) - -We'll use plan InferGen because there are holes in the type. But: - * For f2 we want to have the (?x :: Int) constraint floating around - so that the functional dependencies kick in. Otherwise the - occurrence of ?x on the RHS produces constraint (?x :: alpha), and - we won't unify alpha:=Int. - - * For f3 want the (C Int b) constraint from the partial signature - to meet the (C Int beta) constraint we get from the call to g; again, - fundeps - -Solution: in simplifyInfer, we add the constraints from the signature -as extra Wanteds. - -Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas -that would mess up (GivenInv) in Note [TcLevel invariants]. Consider - f :: (Eq a, _) => blah1 - f = ....g... - g :: (Eq b, _) => blah2 - g = ...f... - -Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with -TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved -all those constraints. And both have level 1, so we can't put them as -Givens when solving at level 1. - -Best to treat them as Wanteds. - -But see also #20076, which would be solved if they were Givens. - - -************************************************************************ -* * - Quantification -* * -************************************************************************ - -Note [Deciding quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the monomorphism restriction does not apply, then we quantify as follows: - -* Step 1: decidePromotedTyVars. - Take the global tyvars, and "grow" them using functional dependencies - E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can - happen because alpha is untouchable here) then do not quantify over - beta, because alpha fixes beta, and beta is effectively free in - the environment too; this logic extends to general fundeps, not - just equalities - - We also account for the monomorphism restriction; if it applies, - add the free vars of all the constraints. - - Result is mono_tvs; we will promote all of these to the outer levek, - and certainly not quantify over them. - -* Step 2: defaultTyVarsAndSimplify. - Default any non-promoted tyvars (i.e ones that are definitely - not going to become further constrained), and re-simplify the - candidate constraints. - - Motivation for re-simplification (#7857): imagine we have a - constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are - not free in the envt, and instance forall (a::*) (b::*). (C a) => C - (a -> b) The instance doesn't match while l1,l2 are polymorphic, but - it will match when we default them to LiftedRep. - - This is all very tiresome. - - This step also promotes the mono_tvs from Step 1. See - Note [Promote monomorphic tyvars]. In fact, the *only* - use of the mono_tvs from Step 1 is to promote them here. - This promotion effectively stops us from quantifying over them - later, in Step 3. Because the actual variables to quantify - over are determined in Step 3 (not in Step 1), it is OK for - the mono_tvs to be missing some variables free in the - environment. This is why removing the psig_qtvs is OK in - decidePromotedTyVars. Test case for this scenario: T14479. - -* Step 3: decideQuantifiedTyVars. - Decide which variables to quantify over, as follows: - - - Take the free vars of the partial-type-signature types and constraints, - and the tau-type (zonked_tau_tvs), and then "grow" - them using all the constraints. These are grown_tcvs. - See Note [growThetaTyVars vs closeWrtFunDeps]. - - - Use quantifyTyVars to quantify over the free variables of all the types - involved, but only those in the grown_tcvs. - - Result is qtvs. - -* Step 4: Filter the constraints using pickQuantifiablePreds and the - qtvs. We have to zonk the constraints first, so they "see" the - freshly created skolems. - -Note [Unconditionally resimplify constraints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke -the solver to simplify the constraints before quantifying them. We do this for -two reasons, enumerated below. We could, in theory, detect when either of these -cases apply and simplify only then, but collecting this information is bothersome, -and simplifying redundantly causes no real harm. Note that this code path -happens only for definitions - * without a type signature - * when -XMonoLocalBinds does not apply - * with unsolved constraints -and so the performance cost will be small. - -1. Defaulting - -Defaulting the variables handled by defaultTyVar may unlock instance simplifications. -Example (typecheck/should_compile/T20584b): - - with (t :: Double) (u :: String) = printf "..." t u - -We know the types of t and u, but we do not know the return type of `with`. So, we -assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is - printf :: PrintfType r => String -> r -The occurrence of printf is instantiated with a fresh var beta. We then get - beta := Double -> String -> alpha -and - [W] PrintfType (Double -> String -> alpha) - -Module Text.Printf exports - instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) -and it looks like that instance should apply. - -But I have elided some key details: (->) is polymorphic over multiplicity and -runtime representation. Here it is in full glory: - [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho)) - instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type)) - -Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance -would have an explicit equality constraint to the left of =>, but that's not what we have.) -Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep. -Yet it's too late to simplify the quantified constraint, and thus GHC infers - wait :: PrintfType (Double -> String -> t) => Double -> String -> t -which is silly. Simplifying again after defaulting solves this problem. - -2. Interacting functional dependencies - -Suppose we have - - class C a b | a -> b - -and we are running simplifyInfer over - - forall[2] x. () => [W] C a beta1[1] - forall[2] y. () => [W] C a beta2[1] - -These are two implication constraints, both of which contain a -wanted for the class C. Neither constraint mentions the bound -skolem. We might imagine that these constraints could thus float -out of their implications and then interact, causing beta1 to unify -with beta2, but constraints do not currently float out of implications. - -Unifying the beta1 and beta2 is important. Without doing so, then we might -infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the -ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as -required by the fundep interactions. This happens in the parsec library, and -in test case typecheck/should_compile/FloatFDs. - -If we re-simplify, however, the two fundep constraints will interact, causing -a unification between beta1 and beta2, and all will be well. The key step -is that this simplification happens *after* the call to approximateWC in -simplifyInfer. - --} - -decideQuantification - :: SkolemInfo - -> InferMode - -> TcLevel - -> [(Name, TcTauType)] -- Variables to be generalised - -> [TcIdSigInst] -- Partial type signatures (if any) - -> [PredType] -- Candidate theta; already zonked - -> TcM ( [TcTyVar] -- Quantify over these (skolems) - , [PredType] -- and this context (fully zonked) - , CoVarSet) --- See Note [Deciding quantification] -decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates - = do { -- Step 1: find the mono_tvs - ; (candidates, co_vars, mono_tvs0) - <- decidePromotedTyVars infer_mode name_taus psigs candidates - - -- Step 2: default any non-mono tyvars, and re-simplify - -- This step may do some unification, but result candidates is zonked - ; candidates <- defaultTyVarsAndSimplify rhs_tclvl candidates - - -- Step 3: decide which kind/type variables to quantify over - ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates - - -- Step 4: choose which of the remaining candidate - -- predicates to actually quantify over - -- NB: decideQuantifiedTyVars turned some meta tyvars - -- into quantified skolems, so we have to zonk again - ; (candidates, psig_theta) <- TcM.liftZonkM $ - do { candidates <- TcM.zonkTcTypes candidates - ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) - ; return (candidates, psig_theta) } - ; min_theta <- pickQuantifiablePreds (mkVarSet qtvs) mono_tvs0 candidates - - -- Take account of partial type signatures - -- See Note [Constraints in partial type signatures] - ; let min_psig_theta = mkMinimalBySCs id psig_theta - ; theta <- if - | null psigs -> return min_theta -- Case (P3) - | not (all has_extra_constraints_wildcard psigs) -- Case (P2) - -> return min_psig_theta - | otherwise -- Case (P1) - -> do { diff <- findInferredDiff min_psig_theta min_theta - ; return (min_psig_theta ++ diff) } - - ; traceTc "decideQuantification" - (vcat [ text "infer_mode:" <+> ppr infer_mode - , text "candidates:" <+> ppr candidates - , text "psig_theta:" <+> ppr psig_theta - , text "co_vars:" <+> ppr co_vars - , text "qtvs:" <+> ppr qtvs - , text "theta:" <+> ppr theta ]) - ; return (qtvs, theta, co_vars) } - - where - has_extra_constraints_wildcard (TISI { sig_inst_wcx = Just {} }) = True - has_extra_constraints_wildcard _ = False - -{- Note [Constraints in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have decided to quantify over min_theta, say (Eq a, C a, Ix a). -Then we distinguish three cases: - -(P1) No partial type signatures: just quantify over min_theta - -(P2) Partial type signatures with no extra_constraints wildcard: - e.g. f :: (Eq a, C a) => a -> _ - Quantify over psig_theta: the user has explicitly specified the - entire context. - - That may mean we have an unsolved residual constraint (Ix a) arising - from the RHS of the function. But so be it: the user said (Eq a, C a). - -(P3) Partial type signature with an extra_constraints wildcard. - e.g. f :: (Eq a, C a, _) => a -> a - Quantify over (psig_theta ++ diff) - where diff = min_theta - psig_theta, using findInferredDiff. - In our example, diff = Ix a - -Some rationale and observations - -* See Note [When the MR applies] in GHC.Tc.Gen.Bind. - -* We always want to quantify over psig_theta (if present). The user specified - it! And pickQuantifiableCandidates might have dropped some - e.g. CallStack constraints. c.f #14658 - equalities (a ~ Bool) - -* In case (P3) we ask that /all/ the signatures have an extra-constraints - wildcard. It's a bit arbitrary; not clear what the "right" thing is. - -* In (P2) we encounter #20076: - f :: Eq [a] => a -> _ - f x = [x] == [x] - From the RHS we get [W] Eq [a]. We simplify those Wanteds in simplifyInfer, - to get (Eq a). But then we quantify over the user-specified (Eq [a]), leaving - a residual implication constraint (forall a. Eq [a] => [W] Eq a), which is - insoluble. Idea: in simplifyInfer we could put the /un-simplified/ constraints - in the residual -- at least in the case like #20076 where the partial signature - fully specifies the final constraint. Maybe: a battle for another day. - -* It's helpful to use the same "find difference" algorithm, `findInferredDiff`, - here as we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) - - At least for single functions we would like to quantify f over precisely the - same theta as , so that we get to take the short-cut path in - `GHC.Tc.Gen.Bind.mkExport`, and avoid calling `tcSubTypeSigma` for impedance - matching. Why avoid? Because it falls over for ambiguous types (#20921). - - We can get precisely the same theta by using the same algorithm, - `findInferredDiff`. - -* All of this goes wrong if we have (a) mutual recursion, (b) multiple - partial type signatures, (c) with different constraints, and (d) - ambiguous types. Something like - f :: forall a. Eq a => F a -> _ - f x = (undefined :: a) == g x undefined - g :: forall b. Show b => F b -> _ -> b - g x y = let _ = (f y, show x) in x - But that's a battle for another day. --} - -decidePromotedTyVars :: InferMode - -> [(Name,TcType)] - -> [TcIdSigInst] - -> [PredType] - -> TcM ([PredType], CoVarSet, TcTyVarSet) --- We are about to generalise over type variables at level N --- Each must be either --- (P) promoted --- (D) defaulted --- (Q) quantified --- This function finds (P), the type variables that we are going to promote: --- (a) Mentioned in a constraint we can't generalise (the MR) --- (b) Mentioned in the kind of a CoVar; we can't quantify over a CoVar, --- so we must not quantify over a type variable free in its kind --- (c) Connected by an equality or fundep to --- * a type variable at level < N, or --- * A tyvar subject to (a), (b) or (c) --- Having found all such level-N tyvars that we can't generalise, --- promote them, to eliminate them from further consideration. --- --- Also return CoVars that appear free in the final quantified types --- we can't quantify over these, and we must make sure they are in scope -decidePromotedTyVars infer_mode name_taus psigs candidates - = do { tc_lvl <- TcM.getTcLevel - ; (no_quant, maybe_quant) <- pick infer_mode candidates - - -- If possible, we quantify over partial-sig qtvs, so they are - -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; (psig_qtvs, psig_theta, taus) <- TcM.liftZonkM $ - do { psig_qtvs <- zonkTcTyVarsToTcTyVars $ binderVars $ - concatMap (map snd . sig_inst_skols) psigs - ; psig_theta <- mapM TcM.zonkTcType $ - concatMap sig_inst_theta psigs - ; taus <- mapM (TcM.zonkTcType . snd) name_taus - ; return (psig_qtvs, psig_theta, taus) } - - ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta - - -- (b) The co_var_tvs are tvs mentioned in the types of covars or - -- coercion holes. We can't quantify over these covars, so we - -- must include the variable in their types in the mono_tvs. - -- E.g. If we can't quantify over co :: k~Type, then we can't - -- quantify over k either! Hence closeOverKinds - -- Recall that coVarsOfTypes also returns coercion holes - co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates) - co_var_tvs = closeOverKinds co_vars - - mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $ - tyCoVarsOfTypes candidates - -- We need to grab all the non-quantifiable tyvars in the - -- types so that we can grow this set to find other - -- non-quantifiable tyvars. This can happen with something like - -- f x y = ... - -- where z = x 3 - -- The body of z tries to unify the type of x (call it alpha[1]) - -- with (beta[2] -> gamma[2]). This unification fails because - -- alpha is untouchable, leaving [W] alpha[1] ~ (beta[2] -> gamma[2]). - -- We need to know not to quantify over beta or gamma, because they - -- are in the equality constraint with alpha. Actual test case: - -- typecheck/should_compile/tc213 - - mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs - - -- mono_tvs1 is now the set of variables from an outer scope - -- (that's mono_tvs0) and the set of covars, closed over kinds. - -- Given this set of variables we know we will not quantify, - -- we want to find any other variables that are determined by this - -- set, by functional dependencies or equalities. We thus use - -- closeWrtFunDeps to find all further variables determined by this root - -- set. See Note [growThetaTyVars vs closeWrtFunDeps] - - non_ip_candidates = filterOut isIPLikePred candidates - -- implicit params don't really determine a type variable - -- (that is, we might have IP "c" Bool and IP "c" Int in different - -- places within the same program), and - -- skipping this causes implicit params to monomorphise too many - -- variables; see Note [Inheriting implicit parameters] in GHC.Tc.Solver. - -- Skipping causes typecheck/should_compile/tc219 to fail. - - mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1 - -- mono_tvs2 now contains any variable determined by the "root - -- set" of monomorphic tyvars in mono_tvs1. - - constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $ - closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant) - `minusVarSet` mono_tvs2 - -- constrained_tvs: the tyvars that we are not going to - -- quantify /solely/ because of the monomorphism restriction - -- - -- (`minusVarSet` mono_tvs2): a type variable is only - -- "constrained" (so that the MR bites) if it is not - -- free in the environment (#13785) or is determined - -- by some variable that is free in the env't - - mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs) - `delVarSetList` psig_qtvs - -- (`delVarSetList` psig_qtvs): if the user has explicitly - -- asked for quantification, then that request "wins" - -- over the MR. - -- - -- What if a psig variable is also free in the environment - -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation - -- in Step 2 of Note [Deciding quantification]. - - -- Warn about the monomorphism restriction - ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do - let dia = TcRnMonomorphicBindings (map fst name_taus) - diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia - - -- Promote the mono_tvs: see Note [Promote monomorphic tyvars] - ; _ <- promoteTyVarSet mono_tvs - - ; traceTc "decidePromotedTyVars" $ vcat - [ text "infer_mode =" <+> ppr infer_mode - , text "psigs =" <+> ppr psigs - , text "psig_qtvs =" <+> ppr psig_qtvs - , text "mono_tvs0 =" <+> ppr mono_tvs0 - , text "no_quant =" <+> ppr no_quant - , text "maybe_quant =" <+> ppr maybe_quant - , text "mono_tvs =" <+> ppr mono_tvs - , text "co_vars =" <+> ppr co_vars ] - - ; return (maybe_quant, co_vars, mono_tvs0) } - where - pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) - -- Split the candidates into ones we definitely - -- won't quantify, and ones that we might - pick ApplyMR cand = return (cand, []) - pick NoRestrictions cand = return ([], cand) - pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } - - -- is_int_ct returns True for a constraint we should /not/ quantify - -- For EagerDefaulting, do not quantify over - -- over any interactive class constraint - is_int_ct ovl_strings pred - = case classifyPredType pred of - ClassPred cls _ -> isInteractiveClass ovl_strings cls - _ -> False - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> [PredType] -- Assumed zonked - -> TcM [PredType] -- Guaranteed zonked --- Default any tyvar free in the constraints; --- and re-simplify in case the defaulting allows further simplification -defaultTyVarsAndSimplify rhs_tclvl candidates - = do { -- Default any kind/levity vars - ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - <- candidateQTyVarsOfTypes candidates - -- NB1: decidePromotedTyVars has promoted any type variable fixed by the - -- type envt, so they won't be chosen by candidateQTyVarsOfTypes - -- NB2: Defaulting for variables free in tau_tys is done later, by quantifyTyVars - -- Hence looking only at 'candidates' - -- NB3: Any covars should already be handled by - -- the logic in decidePromotedTyVars, which looks at - -- the constraints generated - - ; poly_kinds <- xoptM LangExt.PolyKinds - ; let default_kv | poly_kinds = default_tv - | otherwise = defaultTyVar DefaultKindVars - default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars) - ; mapM_ default_kv (dVarSetElems cand_kvs) - ; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - - ; simplify_cand candidates - } - where - -- See Note [Unconditionally resimplify constraints when quantifying] - simplify_cand [] = return [] -- Fast path - simplify_cand candidates - = do { clone_wanteds <- newWanteds DefaultOrigin candidates - ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ - simplifyWantedsTcM clone_wanteds - -- Discard evidence; simples is fully zonked - - ; let new_candidates = ctsPreds simples - ; traceTc "Simplified after defaulting" $ - vcat [ text "Before:" <+> ppr candidates - , text "After:" <+> ppr new_candidates ] - ; return new_candidates } - ------------------- -decideQuantifiedTyVars - :: SkolemInfo - -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs - -> [TcIdSigInst] -- Partial signatures - -> [PredType] -- Candidates, zonked - -> TcM [TyVar] --- Fix what tyvars we are going to quantify over, and quantify them -decideQuantifiedTyVars skol_info name_taus psigs candidates - = do { -- Why psig_tys? We try to quantify over everything free in here - -- See Note [Quantification and partial signatures] - -- Wrinkles 2 and 3 - ; (psig_tv_tys, psig_theta, tau_tys) <- TcM.liftZonkM $ - do { psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,Bndr tv _) <- sig_inst_skols sig ] - ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs - , pred <- sig_inst_theta sig ] - ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus - ; return (psig_tv_tys, psig_theta, tau_tys) } - - ; let -- Try to quantify over variables free in these types - psig_tys = psig_tv_tys ++ psig_theta - seed_tys = psig_tys ++ tau_tys - - -- Now "grow" those seeds to find ones reachable via 'candidates' - -- See Note [growThetaTyVars vs closeWrtFunDeps] - grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys) - - -- Now we have to classify them into kind variables and type variables - -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars - -- - -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces - -- them in that order, so that the final qtvs quantifies in the same - -- order as the partial signatures do (#13524) - ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $ - psig_tys ++ candidates ++ tau_tys - ; let pick = (`dVarSetIntersectVarSet` grown_tcvs) - dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs } - - ; traceTc "decideQuantifiedTyVars" (vcat - [ text "tau_tys =" <+> ppr tau_tys - , text "candidates =" <+> ppr candidates - , text "cand_kvs =" <+> ppr cand_kvs - , text "cand_tvs =" <+> ppr cand_tvs - , text "tau_tys =" <+> ppr tau_tys - , text "seed_tys =" <+> ppr seed_tys - , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys) - , text "grown_tcvs =" <+> ppr grown_tcvs - , text "dvs =" <+> ppr dvs_plus]) - - ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } - ------------------- --- | When inferring types, should we quantify over a given predicate? --- See Note [pickQuantifiablePreds] -pickQuantifiablePreds - :: TyVarSet -- Quantifying over these - -> TcTyVarSet -- mono_tvs0: variables mentioned a candidate - -- constraint that come from some outer level - -> TcThetaType -- Proposed constraints to quantify - -> TcM TcThetaType -- A subset that we can actually quantify --- This function decides whether a particular constraint should be --- quantified over, given the type variables that are being quantified -pickQuantifiablePreds qtvs mono_tvs0 theta - = do { tc_lvl <- TcM.getTcLevel - ; let is_nested = not (isTopTcLevel tc_lvl) - ; return (mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - mapMaybe (pick_me is_nested) theta) } - where - pick_me is_nested pred - = let pred_tvs = tyCoVarsOfType pred - mentions_qtvs = pred_tvs `intersectsVarSet` qtvs - in case classifyPredType pred of - - ClassPred cls tys - | Just {} <- isCallStackPred cls tys - -- NEVER infer a CallStack constraint. Otherwise we let - -- the constraints bubble up to be solved from the outer - -- context, or be defaulted when we reach the top-level. - -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -> Nothing - - | isIPClass cls - -> Just pred -- See Note [Inheriting implicit parameters] - - | not mentions_qtvs - -> Nothing -- Don't quantify over predicates that don't - -- mention any of the quantified type variables - - | is_nested - -> Just pred - - -- From here on, we are thinking about top-level defns only - - | pred_tvs `subVarSet` (qtvs `unionVarSet` mono_tvs0) - -- See Note [Do not quantify over constraints that determine a variable] - -> Just pred - - | otherwise - -> Nothing - - EqPred eq_rel ty1 ty2 - | mentions_qtvs - , quantify_equality eq_rel ty1 ty2 - , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constraints when quantifying] - -> Just (mkClassPred cls tys) - | otherwise - -> Nothing - - IrredPred {} | mentions_qtvs -> Just pred - | otherwise -> Nothing - - ForAllPred {} -> Nothing - - -- See Note [Quantifying over equality constraints] - quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 - quantify_equality ReprEq _ _ = True - - quant_fun ty - = case tcSplitTyConApp_maybe ty of - Just (tc, tys) | isTypeFamilyTyCon tc - -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs - _ -> False - ------------------- -growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet --- See Note [growThetaTyVars vs closeWrtFunDeps] -growThetaTyVars theta tcvs - | null theta = tcvs - | otherwise = transCloVarSet mk_next seed_tcvs - where - seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips - (ips, non_ips) = partition isIPLikePred theta - -- See Note [Inheriting implicit parameters] - - mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones - mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips - grow_one so_far pred tcvs - | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs - | otherwise = tcvs - where - pred_tcvs = tyCoVarsOfType pred - - -{- Note [Promote monomorphic tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Promote any type variables that are free in the environment. Eg - f :: forall qtvs. bound_theta => zonked_tau -The free vars of f's type become free in the envt, and hence will show -up whenever 'f' is called. They may currently at rhs_tclvl, but they -had better be unifiable at the outer_tclvl! Example: envt mentions -alpha[1] - tau_ty = beta[2] -> beta[2] - constraints = alpha ~ [beta] -we don't quantify over beta (since it is fixed by envt) -so we must promote it! The inferred type is just - f :: beta -> beta - -NB: promoteTyVarSet ignores coercion variables - -Note [pickQuantifiablePreds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When pickQuantifiablePreds is called we have decided what type -variables to quantify over, `qtvs`. The only quesion is: which of the -unsolved candidate predicates should we quantify over? Call them -`picked_theta`. - -Note that will leave behind a residual implication - forall qtvs. picked_theta => unsolved_constraints -For the members of unsolved_constraints that we select for picked_theta -it is easy to solve, by identity. For the others we just hope that -we can solve them. - -So which of the candidates should we pick to quantify over? In some -situations we distinguish top-level from nested bindings. The point -about nested binding is that - (a) the types may mention type variables free in the environment - (b) all of the call sites are statically visible, reducing the - worries about "spooky action at a distance". - -First, never pick a constraint that doesn't mention any of the quantified -variables `qtvs`. Picking such a constraint essentially moves the solving of -the constraint from this function definition to call sites. But because the -constraint mentions no quantified variables, call sites have no advantage -over the definition site. Well, not quite: there could be new constraints -brought into scope by a pattern-match against a constrained (e.g. GADT) -constructor. Example - - data T a where { T1 :: T1 Bool; ... } - - f :: forall a. a -> T a -> blah - f x t = let g y = x&&y -- This needs a~Bool - in case t of - T1 -> g True - .... - -At g's call site we have `a~Bool`, so we /could/ infer - g :: forall . (a~Bool) => Bool -> Bool -- qtvs = {} - -This is all very contrived, and probably just postponse type errors to -the call site. If that's what you want, write a type signature. - -Actually, implicit parameters is an exception to the "no quantified vars" -rule (see Note [Inheriting implicit parameters]) so we can't actually -simply test this case first. - -Now we consider the different sorts of constraints: - -* For ClassPred constraints: - - * Never pick a CallStack constraint. - See Note [Overview of implicit CallStacks] - - * Always pick an implicit-parameter constraint. - Note [Inheriting implicit parameters] - - * For /top-level/ class constraints see - Note [Do not quantify over constraints that determine a variable] - -* For EqPred constraints see Note [Quantifying over equality constraints] - -* For IrredPred constraints, we allow anything that mentions the quantified - type variables. - -* A ForAllPred should not appear: the candidates come from approximateWC. - -Notice that we do /not/ consult -XFlexibleContexts here. For example, -we allow `pickQuantifiablePreds` to quantify over a constraint like -`Num [a]`; then if we don't have `-XFlexibleContexts` we'll get an -error from `checkValidType` but (critically) it includes the helpful -suggestion of adding `-XFlexibleContexts`. See #10608, #10351. - -Note [Lift equality constraints when quantifying] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can't quantify over a constraint (t1 ~# t2) because that isn't a -predicate type; see Note [Types for coercions, predicates, and evidence] -in GHC.Core.TyCo.Rep. - -So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted -to Coercible. - -This tiresome lifting is the reason that pick_me (in -pickQuantifiablePreds) returns a Maybe rather than a Bool. - -Note [Inheriting implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - - f x = (x::Int) + ?y - -where f is *not* a top-level binding. -From the RHS of f we'll get the constraint (?y::Int). -There are two types we might infer for f: - - f :: Int -> Int - -(so we get ?y from the context of f's definition), or - - f :: (?y::Int) => Int -> Int - -At first you might think the first was better, because then -?y behaves like a free variable of the definition, rather than -having to be passed at each call site. But of course, the WHOLE -IDEA is that ?y should be passed at each call site (that's what -dynamic binding means) so we'd better infer the second. - -BOTTOM LINE: when *inferring types* you must quantify over implicit -parameters, *even if* they don't mention the bound type variables. -Reason: because implicit parameters, uniquely, have local instance -declarations. See pickQuantifiablePreds. - -Note [Quantifying over equality constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should we quantify over an equality constraint (s ~ t) -in pickQuantifiablePreds? - -* It is always /sound/ to quantify over a constraint -- those - quantified constraints will need to be proved at each call site. - -* We definitely don't want to quantify over (Maybe a ~ Bool), to get - f :: forall a. (Maybe a ~ Bool) => blah - That simply postpones a type error from the function definition site to - its call site. Fortunately we have already filtered out insoluble - constraints: see `definite_error` in `simplifyInfer`. - -* What about (a ~ T alpha b), where we are about to quantify alpha, `a` and - `b` are in-scope skolems, and `T` is a data type. It's pretty unlikely - that this will be soluble at a call site, so we don't quantify over it. - -* What about `(F beta ~ Int)` where we are going to quantify `beta`? - Should we quantify over the (F beta ~ Int), to get - f :: forall b. (F b ~ Int) => blah - Aha! Perhaps yes, because at the call site we will instantiate `b`, and - perhaps we have `instance F Bool = Int`. So we *do* quantify over a - type-family equality where the arguments mention the quantified variables. - -This is all a bit ad-hoc. - -Note [Do not quantify over constraints that determine a variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (typecheck/should_compile/tc231), where we're trying to infer -the type of a top-level declaration. We have - class Zork s a b | a -> b -and the candidate constraint at the end of simplifyInfer is - [W] Zork alpha[1] (Z [Char]) beta[1] -We definitely want to quantify over `alpha` (which is mentioned in the -tau-type). - -But we do *not* want to quantify over `beta`: it is determined by the -functional dependency on Zork: note that the second argument to Zork -in the Wanted is a variable-free `Z [Char]`. Quantifying over it -would be "Henry Ford polymorphism". (Presumably we don't have an -instance in scope that tells us what `beta` actually is.) Instead -we promote `beta[1]` to `beta[0]`, in `decidePromotedTyVars`. - -The question here: do we want to quantify over the constraint, to -give the type - forall a. Zork a (Z [Char]) beta[0] => blah -Definitely not. Since we're not quantifying over beta, it has been -promoted; and then will be zapped to Any in the final zonk. So we end -up with a (perhaps exported) type involving - forall a. Zork a (Z [Char]) Any => blah -No no no: - - Key principle: we never want to show the programmer - a type with `Any` in it. - -What we really want (to catch the Zork example) is this: - - Quantify over the constraint only if all its free variables are - (a) quantified, or - (b) appears in the type of something in the environment (mono_tvs0). - -To understand (b) consider - - class C a b where { op :: a -> b -> () } - - mr = 3 -- mr :: alpha - f1 x = op x mr -- f1 :: forall b. b -> (), plus [W] C b alpha - intify = mr + (4 :: Int) - -In `f1` should we quantify over that `(C b alpha)`? Answer: since `alpha` -is free in the type envt, yes we should. After all, if we'd typechecked -`intify` first, we'd have set `alpha := Int`, and /then/ we'd certainly -quantify. The delicate Zork situation applies when beta is completely -unconstrained (not free in the environment) -- except by the fundep. - -Another way to put it: let's say `alpha` is in `mono_tvs0`. It must be that -some variable `x` has `alpha` free in its type. If we are at top-level (and we -are, because nested decls don't go through this path all), then `x` must also -be at top-level. And, by induction, `x` will not have Any in its type when all -is said and done. The induction is well-founded because, if `x` is mutually -recursive with the definition at hand, then their constraints get processed -together (or `x` has a type signature, in which case the type doesn't have -`Any`). So the key thing is that we must not introduce a new top-level -unconstrained variable here. - -However this regrettably-subtle reasoning is needed only for /top-level/ -declarations. For /nested/ decls we can see all the calls, so we'll -instantiate that quantifed `Zork a (Z [Char]) beta` constraint at call sites, -and either solve it or not (probably not). We won't be left with a -still-callable function with Any in its type. So for nested definitions we -don't make this tricky test. - -Historical note: we had a different, and more complicated test -before, but it was utterly wrong: #23199. - -Note [Quantification and partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When choosing type variables to quantify, the basic plan is to -quantify over all type variables that are - * free in the tau_tvs, and - * not forced to be monomorphic (mono_tvs), - for example by being free in the environment. - -However, in the case of a partial type signature, we are doing inference -*in the presence of a type signature*. For example: - f :: _ -> a - f x = ... -or - g :: (Eq _a) => _b -> _b -In both cases we use plan InferGen, and hence call simplifyInfer. But -those 'a' variables are skolems (actually TyVarTvs), and we should be -sure to quantify over them. This leads to several wrinkles: - -* Wrinkle 1. In the case of a type error - f :: _ -> Maybe a - f x = True && x - The inferred type of 'f' is f :: Bool -> Bool, but there's a - left-over error of form (Maybe a ~ Bool). The error-reporting - machine expects to find a binding site for the skolem 'a', so we - add it to the quantified tyvars. - -* Wrinkle 2. Consider the partial type signature - f :: (Eq _) => Int -> Int - f x = x - In normal cases that makes sense; e.g. - g :: Eq _a => _a -> _a - g x = x - where the signature makes the type less general than it could - be. But for 'f' we must therefore quantify over the user-annotated - constraints, to get - f :: forall a. Eq a => Int -> Int - (thereby correctly triggering an ambiguity error later). If we don't - we'll end up with a strange open type - f :: Eq alpha => Int -> Int - which isn't ambiguous but is still very wrong. - - Bottom line: Try to quantify over any variable free in psig_theta, - just like the tau-part of the type. - -* Wrinkle 3 (#13482). Also consider - f :: forall a. _ => Int -> Int - f x = if (undefined :: a) == undefined then x else 0 - Here we get an (Eq a) constraint, but it's not mentioned in the - psig_theta nor the type of 'f'. But we still want to quantify - over 'a' even if the monomorphism restriction is on. - -* Wrinkle 4 (#14479) - foo :: Num a => a -> a - foo xxx = g xxx - where - g :: forall b. Num b => _ -> b - g y = xxx + y - - In the signature for 'g', we cannot quantify over 'b' because it turns out to - get unified with 'a', which is free in g's environment. So we carefully - refrain from bogusly quantifying, in GHC.Tc.Solver.decidePromotedTyVars. We - report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. - -Note [growThetaTyVars vs closeWrtFunDeps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with -the same type and similar behavior. This Note outlines the differences -and why we use one or the other. - -Both functions take a list of constraints. We will call these the -*candidates*. - -closeWrtFunDeps takes a set of "determined" type variables and finds the -closure of that set with respect to the functional dependencies -within the class constraints in the set of candidates. So, if we -have - - class C a b | a -> b - class D a b -- no fundep - candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)} - -then closeWrtFunDeps {a} will return the set {a,b,c}. -This is because, if `a` is determined, then `b` and `c` are, too, -by functional dependency. closeWrtFunDeps called with any seed set not including -`a` will just return its argument, as only `a` determines any other -type variable (in this example). - -growThetaTyVars operates similarly, but it behaves as if every -constraint has a functional dependency among all its arguments. -So, continuing our example, growThetaTyVars {a} will return -{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of -variables to include all variables that are mentioned in the same -constraint (transitively). - -We use closeWrtFunDeps in places where we need to know which variables are -*always* determined by some seed set. This includes - * when determining the mono-tyvars in decidePromotedTyVars. If `a` - is going to be monomorphic, we need b and c to be also: they - are determined by the choice for `a`. - * when checking instance coverage, in - GHC.Tc.Instance.FunDeps.checkInstCoverage - -On the other hand, we use growThetaTyVars where we need to know -which variables *might* be determined by some seed set. This includes - * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers - and decideQuantifiedTyVars -How can `a` determine (say) `d` in the example above without a fundep? -Suppose we have - instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c) -Now, if `a` turns out to be a list, it really does determine b and c. -The danger in overdoing quantification is the creation of an ambiguous -type signature, but this is conveniently caught in the validity checker. - -Note [Quantification with errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we find that the RHS of the definition has some absolutely-insoluble -constraints (including especially "variable not in scope"), we - -* Abandon all attempts to find a context to quantify over, - and instead make the function fully-polymorphic in whatever - type we have found - -* Return a flag from simplifyInfer, indicating that we found an - insoluble constraint. This flag is used to suppress the ambiguity - check for the inferred type, which may well be bogus, and which - tends to obscure the real error. This fix feels a bit clunky, - but I failed to come up with anything better. - -Reasons: - - Avoid downstream errors - - Do not perform an ambiguity test on a bogus type, which might well - fail spuriously, thereby obfuscating the original insoluble error. - #14000 is an example - -I tried an alternative approach: simply failM, after emitting the -residual implication constraint; the exception will be caught in -GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type -(forall a. a). But that didn't work with -fdefer-type-errors, because -the recovery from failM emits no code at all, so there is no function -to run! But -fdefer-type-errors aspires to produce a runnable program. - -Note [Default while Inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Our current plan is that defaulting only happens at simplifyTop and -not simplifyInfer. This may lead to some insoluble deferred constraints. -Example: - -instance D g => C g Int b - -constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha -type inferred = gamma -> gamma - -Now, if we try to default (alpha := Int) we will be able to refine the implication to - (forall b. 0 => C gamma Int b) -which can then be simplified further to - (forall b. 0 => D gamma) -Finally, we /can/ approximate this implication with (D gamma) and infer the quantified -type: forall g. D g => g -> g - -Instead what will currently happen is that we will get a quantified type -(forall g. g -> g) and an implication: - forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha - -Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an -unsolvable implication: - forall g. 0 => (forall b. 0 => D g) - -The concrete example would be: - h :: C g a s => g -> a -> ST s a - f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) - -But it is quite tedious to do defaulting and resolve the implication constraints, and -we have not observed code breaking because of the lack of defaulting in inference, so -we don't do it for now. - - - -Note [Minimize by Superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we quantify over a constraint, in simplifyInfer we need to -quantify over a constraint that is minimal in some sense: For -instance, if the final wanted constraint is (Eq alpha, Ord alpha), -we'd like to quantify over Ord alpha, because we can just get Eq alpha -from superclass selection from Ord alpha. This minimization is what -mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint -to check the original wanted. - - -Note [Avoid unnecessary constraint simplification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -------- NB NB NB (Jun 12) ------------- - This note not longer applies; see the notes with #4361. - But I'm leaving it in here so we remember the issue.) - ---------------------------------------- -When inferring the type of a let-binding, with simplifyInfer, -try to avoid unnecessarily simplifying class constraints. -Doing so aids sharing, but it also helps with delicate -situations like - - instance C t => C [t] where .. - - f :: C [t] => .... - f x = let g y = ...(constraint C [t])... - in ... -When inferring a type for 'g', we don't want to apply the -instance decl, because then we can't satisfy (C t). So we -just notice that g isn't quantified over 't' and partition -the constraints before simplifying. - -This only half-works, but then let-generalisation only half-works. - -********************************************************************************* -* * -* Main Simplifier * -* * -*********************************************************************************** - --} - -simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints --- Solve the specified Wanted constraints --- Discard the evidence binds --- Postcondition: fully zonked -simplifyWantedsTcM wanted - = do { traceTc "simplifyWantedsTcM {" (ppr wanted) - ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) - ; result <- TcM.liftZonkM $ TcM.zonkWC result - ; traceTc "simplifyWantedsTcM }" (ppr result) - ; return result } - -solveWanteds :: WantedConstraints -> TcS WantedConstraints -solveWanteds wc@(WC { wc_errors = errs }) - | isEmptyWC wc -- Fast path - = return wc - | otherwise - = do { cur_lvl <- TcS.getTcLevel - ; traceTcS "solveWanteds {" $ - vcat [ text "Level =" <+> ppr cur_lvl - , ppr wc ] - - ; dflags <- getDynFlags - ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc - - ; errs' <- simplifyDelayedErrors errs - ; let final_wc = solved_wc { wc_errors = errs' } - - ; ev_binds_var <- getTcEvBindsVar - ; bb <- TcS.getTcEvBindsMap ev_binds_var - ; traceTcS "solveWanteds }" $ - vcat [ text "final wc =" <+> ppr final_wc - , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] - - ; return final_wc } - -simplify_loop :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints --- Do a round of solving, and call maybe_simplify_again to iterate --- The 'definitely_redo_implications' flags is False if the only reason we --- are iterating is that we have added some new Wanted superclasses --- hoping for fundeps to help us; see Note [Superclass iteration] --- --- Does not affect wc_holes at all; reason: wc_holes never affects anything --- else, so we do them once, at the end in solveWanteds -simplify_loop n limit definitely_redo_implications - wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { csTraceTcS $ - text "simplify_loop iteration=" <> int n - <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma - , int (lengthBag simples) <+> text "simples to solve" ]) - ; traceTcS "simplify_loop: wc =" (ppr wc) - - ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration] - solveSimpleWanteds simples - -- Any insoluble constraints are in 'simples' and so get rewritten - -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet - - ; wc2 <- if not definitely_redo_implications -- See Note [Superclass iteration] - && unifs1 == 0 -- for this conditional - && isEmptyBag (wc_impl wc1) - then return (wc { wc_simple = wc_simple wc1 }) -- Short cut - else do { implics2 <- solveNestedImplications $ - implics `unionBags` (wc_impl wc1) - ; return (wc { wc_simple = wc_simple wc1 - , wc_impl = implics2 }) } - - ; unif_happened <- resetUnificationFlag - ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened - -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad - ; maybe_simplify_again (n+1) limit unif_happened wc2 } - -maybe_simplify_again :: Int -> IntWithInf -> Bool - -> WantedConstraints -> TcS WantedConstraints -maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) - | n `intGtLimit` limit - = do { -- Add an error (not a warning) if we blow the limit, - -- Typically if we blow the limit we are going to report some other error - -- (an unsolved constraint), and we don't want that error to suppress - -- the iteration limit warning! - addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc - ; return wc } - - | unif_happened - = simplify_loop n limit True wc - - | superClassesMightHelp wc - = -- We still have unsolved goals, and apparently no way to solve them, - -- so try expanding superclasses at this level, both Given and Wanted - do { pending_given <- getPendingGivenScs - ; let (pending_wanted, simples1) = getPendingWantedScs simples - ; if null pending_given && null pending_wanted - then return wc -- After all, superclasses did not help - else - do { new_given <- makeSuperClasses pending_given - ; new_wanted <- makeSuperClasses pending_wanted - ; solveSimpleGivens new_given -- Add the new Givens to the inert set - ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given - , text "new_given" <+> ppr new_given - , text "pending_wanted" <+> ppr pending_wanted - , text "new_wanted" <+> ppr new_wanted ]) - ; simplify_loop n limit (not (null pending_given)) $ - wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } - -- (not (null pending_given)): see Note [Superclass iteration] - - | otherwise - = return wc - -{- Note [Superclass iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this implication constraint - forall a. - [W] d: C Int beta - forall b. blah -where - class D a b | a -> b - class D a b => C a b -We will expand d's superclasses, giving [W] D Int beta, in the hope of geting -fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), -and if so it seems a pity to waste time iterating the implications (forall b. blah) -(If we add new Given superclasses it's a different matter: it's really worth looking -at the implications.) - -Hence the definitely_redo_implications flag to simplify_loop. It's usually -True, but False in the case where the only reason to iterate is new Wanted -superclasses. In that case we check whether the new Wanteds actually led to -any new unifications, and iterate the implications only if so. --} - -{- Note [Expanding Recursive Superclasses and ExpansionFuel] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the class declaration (T21909) - - class C [a] => C a where - foo :: a -> Int - -and suppose during type inference we obtain an implication constraint: - - forall a. C a => C [[a]] - -To solve this implication constraint, we first expand one layer of the superclass -of Given constraints, but not for Wanted constraints. -(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help] -in GHC.Tc.Solver.Dict.) We thus get: - - [G] g1 :: C a - [G] g2 :: C [a] -- new superclass layer from g1 - [W] w1 :: C [[a]] - -Now, we cannot solve `w1` directly from `g1` or `g2` as we may not have -any instances for C. So we expand a layer of superclasses of each Wanteds and Givens -that we haven't expanded yet. -This is done in `maybe_simplify_again`. And we get: - - [G] g1 :: C a - [G] g2 :: C [a] - [G] g3 :: C [[a]] -- new superclass layer from g2, can solve w1 - [W] w1 :: C [[a]] - [W] w2 :: C [[[a]]] -- new superclass layer from w1, not solvable - -Now, although we can solve `w1` using `g3` (obtained from expanding `g2`), -we have a new wanted constraint `w2` (obtained from expanding `w1`) that cannot be solved. -We thus make another go at solving in `maybe_simplify_again` by expanding more -layers of superclasses. This looping is futile as Givens will never be able to catch up with Wanteds. - -Side Note: In principle we don't actually need to /solve/ `w2`, as it is a superclass of `w1` -but we only expand it to expose any functional dependencies (see Note [The superclass story]) -But `w2` is a wanted constraint, so we will try to solve it like any other, -even though ultimately we will discard its evidence. - -Solution: Simply bound the maximum number of layers of expansion for -Givens and Wanteds, with ExpansionFuel. Give the Givens more fuel -(say 3 layers) than the Wanteds (say 1 layer). Now the Givens will -win. The Wanteds don't need much fuel: we are only expanding at all -to expose functional dependencies, and wantedFuel=1 means we will -expand a full recursive layer. If the superclass hierarchy is -non-recursive (the normal case) one layer is therefore full expansion. - -The default value for wantedFuel = Constants.max_WANTEDS_FUEL = 1. -The default value for givenFuel = Constants.max_GIVENS_FUEL = 3. -Both are configurable via the `-fgivens-fuel` and `-fwanteds-fuel` -compiler flags. - -There are two preconditions for the default fuel values: - (1) default givenFuel >= default wantedsFuel - (2) default givenFuel < solverIterations - -Precondition (1) ensures that we expand givens at least as many times as we expand wanted constraints -preferably givenFuel > wantedsFuel to avoid issues like T21909 while -the precondition (2) ensures that we do not reach the solver iteration limit and fail with a -more meaningful error message (see T19627) - -This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field. --} - - -solveNestedImplications :: Bag Implication - -> TcS (Bag Implication) --- Precondition: the TcS inerts may contain unsolved simples which have --- to be converted to givens before we go inside a nested implication. -solveNestedImplications implics - | isEmptyBag implics - = return (emptyBag) - | otherwise - = do { traceTcS "solveNestedImplications starting {" empty - ; unsolved_implics <- mapBagM solveImplication implics - - -- ... and we are back in the original TcS inerts - -- Notice that the original includes the _insoluble_simples so it was safe to ignore - -- them in the beginning of this function. - ; traceTcS "solveNestedImplications end }" $ - vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ] - - ; return (catBagMaybes unsolved_implics) } - -solveImplication :: Implication -- Wanted - -> TcS (Maybe Implication) -- Simplified implication (empty or singleton) --- Precondition: The TcS monad contains an empty worklist and given-only inerts --- which after trying to solve this implication we must restore to their original value -solveImplication imp@(Implic { ic_tclvl = tclvl - , ic_binds = ev_binds_var - , ic_given = given_ids - , ic_wanted = wanteds - , ic_info = info - , ic_status = status }) - | isSolvedStatus status - = return (Just imp) -- Do nothing - - | otherwise -- Even for IC_Insoluble it is worth doing more work - -- The insoluble stuff might be in one sub-implication - -- and other unsolved goals in another; and we want to - -- solve the latter as much as possible - = do { inerts <- getInertSet - ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) - - -- commented out; see `where` clause below - -- ; when debugIsOn check_tc_level - - -- Solve the nested constraints - ; (has_given_eqs, given_insols, residual_wanted) - <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info (ic_env imp) - givens = mkGivens loc given_ids - ; solveSimpleGivens givens - - ; residual_wanted <- solveWanteds wanteds - - ; (has_eqs, given_insols) <- getHasGivenEqs tclvl - -- Call getHasGivenEqs /after/ solveWanteds, because - -- solveWanteds can augment the givens, via expandSuperClasses, - -- to reveal given superclass equalities - - ; return (has_eqs, given_insols, residual_wanted) } - - ; traceTcS "solveImplication 2" - (ppr given_insols $$ ppr residual_wanted) - ; let final_wanted = residual_wanted `addInsols` given_insols - -- Don't lose track of the insoluble givens, - -- which signal unreachable code; put them in ic_wanted - - ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs - , ic_wanted = final_wanted }) - - ; evbinds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - ; traceTcS "solveImplication end }" $ vcat - [ text "has_given_eqs =" <+> ppr has_given_eqs - , text "res_implic =" <+> ppr res_implic - , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) - , text "implication tvcs =" <+> ppr tcvs ] - - ; return res_implic } - - -- TcLevels must be strictly increasing (see (ImplicInv) in - -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType), - -- and in fact I think they should always increase one level at a time. - - -- Though sensible, this check causes lots of testsuite failures. It is - -- remaining commented out for now. - {- - check_tc_level = do { cur_lvl <- TcS.getTcLevel - ; massertPpr (tclvl == pushTcLevel cur_lvl) - (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) } - -} - ----------------------- -setImplicationStatus :: Implication -> TcS (Maybe Implication) --- Finalise the implication returned from solveImplication, --- setting the ic_status field --- Precondition: the ic_status field is not already IC_Solved --- Return Nothing if we can discard the implication altogether -setImplicationStatus implic@(Implic { ic_status = status - , ic_info = info - , ic_wanted = wc - , ic_given = givens }) - | assertPpr (not (isSolvedStatus status)) (ppr info) $ - -- Precondition: we only set the status if it is not already solved - not (isSolvedWC pruned_wc) - = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic) - - ; implic <- neededEvVars implic - - ; let new_status | insolubleWC pruned_wc = IC_Insoluble - | otherwise = IC_Unsolved - new_implic = implic { ic_status = new_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic) - - ; return $ Just new_implic } - - | otherwise -- Everything is solved - -- Set status to IC_Solved, - -- and compute the dead givens and outer needs - -- See Note [Tracking redundant constraints] - = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic) - - ; implic@(Implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) <- neededEvVars implic - - ; bad_telescope <- checkBadTelescope implic - - ; let warn_givens = findUnnecessaryGivens info need_inner givens - - discard_entire_implication -- Can we discard the entire implication? - = null warn_givens -- No warning from this implication - && not bad_telescope - && isEmptyWC pruned_wc -- No live children - && isEmptyVarSet need_outer -- No needed vars to pass up to parent - - final_status - | bad_telescope = IC_BadTelescope - | otherwise = IC_Solved { ics_dead = warn_givens } - final_implic = implic { ic_status = final_status - , ic_wanted = pruned_wc } - - ; traceTcS "setImplicationStatus(all-solved) }" $ - vcat [ text "discard:" <+> ppr discard_entire_implication - , text "new_implic:" <+> ppr final_implic ] - - ; return $ if discard_entire_implication - then Nothing - else Just final_implic } - where - WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc - - pruned_implics = filterBag keep_me implics - pruned_wc = WC { wc_simple = simples - , wc_impl = pruned_implics - , wc_errors = errs } -- do not prune holes; these should be reported - - keep_me :: Implication -> Bool - keep_me ic - | IC_Solved { ics_dead = dead_givens } <- ic_status ic - -- Fully solved - , null dead_givens -- No redundant givens to report - , isEmptyBag (wc_impl (ic_wanted ic)) - -- And no children that might have things to report - = False -- Tnen we don't need to keep it - | otherwise - = True -- Otherwise, keep it - -findUnnecessaryGivens :: SkolemInfoAnon -> VarSet -> [EvVar] -> [EvVar] -findUnnecessaryGivens info need_inner givens - | not (warnRedundantGivens info) -- Don't report redundant constraints at all - = [] - - | not (null unused_givens) -- Some givens are literally unused - = unused_givens - - | otherwise -- All givens are used, but some might - = redundant_givens -- still be redundant e.g. (Eq a, Ord a) - - where - in_instance_decl = case info of { InstSkol {} -> True; _ -> False } - -- See Note [Redundant constraints in instance decls] - - unused_givens = filterOut is_used givens - - is_used given = is_type_error given - || given `elemVarSet` need_inner - || (in_instance_decl && is_improving (idType given)) - - minimal_givens = mkMinimalBySCs evVarPred givens - is_minimal = (`elemVarSet` mkVarSet minimal_givens) - redundant_givens - | in_instance_decl = [] - | otherwise = filterOut is_minimal givens - - -- See #15232 - is_type_error id = isTopLevelUserTypeError (idType id) - - is_improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Instance declarations are special in two ways: - -* We don't report unused givens if they can give rise to improvement. - Example (#10100): - class Add a b ab | a b -> ab, a ab -> b - instance Add Zero b b - instance Add a b ab => Add (Succ a) b (Succ ab) - The context (Add a b ab) for the instance is clearly unused in terms - of evidence, since the dictionary has no fields. But it is still - needed! With the context, a wanted constraint - Add (Succ Zero) beta (Succ Zero) - we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. - But without the context we won't find beta := Zero. - - This only matters in instance declarations. - -* We don't report givens that are a superclass of another given. E.g. - class Ord r => UserOfRegs r a where ... - instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where - The (Ord r) is not redundant, even though it is a superclass of - (UserOfRegs r CmmReg). See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. - - Again this is specific to instance declarations. --} - - -checkBadTelescope :: Implication -> TcS Bool --- True <=> the skolems form a bad telescope --- See Note [Checking telescopes] in GHC.Tc.Types.Constraint -checkBadTelescope (Implic { ic_info = info - , ic_skols = skols }) - | checkTelescopeSkol info - = do{ skols <- mapM TcS.zonkTyCoVarKind skols - ; return (go emptyVarSet (reverse skols))} - - | otherwise - = return False - - where - go :: TyVarSet -- skolems that appear *later* than the current ones - -> [TcTyVar] -- ordered skolems, in reverse order - -> Bool -- True <=> there is an out-of-order skolem - go _ [] = False - go later_skols (one_skol : earlier_skols) - | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols - = True - | otherwise - = go (later_skols `extendVarSet` one_skol) earlier_skols - -warnRedundantGivens :: SkolemInfoAnon -> Bool -warnRedundantGivens (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt _ rrc -> reportRedundantConstraints rrc - ExprSigCtxt rrc -> reportRedundantConstraints rrc - _ -> False - - -- To think about: do we want to report redundant givens for - -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. -warnRedundantGivens (InstSkol {}) = True -warnRedundantGivens _ = False - -neededEvVars :: Implication -> TcS Implication --- Find all the evidence variables that are "needed", --- and delete dead evidence bindings --- See Note [Tracking redundant constraints] --- See Note [Delete dead Given evidence bindings] --- --- - Start from initial_seeds (from nested implications) --- --- - Add free vars of RHS of all Wanted evidence bindings --- and coercion variables accumulated in tcvs (all Wanted) --- --- - Generate 'needed', the needed set of EvVars, by doing transitive --- closure through Given bindings --- e.g. Needed {a,b} --- Given a = sc_sel a2 --- Then a2 is needed too --- --- - Prune out all Given bindings that are not needed --- --- - From the 'needed' set, delete ev_bndrs, the binders of the --- evidence bindings, to give the final needed variables --- -neededEvVars implic@(Implic { ic_given = givens - , ic_binds = ev_binds_var - , ic_wanted = WC { wc_impl = implics } - , ic_need_inner = old_needs }) - = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var - - ; let seeds1 = foldr add_implic_seeds old_needs implics - seeds2 = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds - -- It's OK to use a non-deterministic fold here - -- because add_wanted is commutative - seeds3 = seeds2 `unionVarSet` tcvs - need_inner = findNeededEvVars ev_binds seeds3 - live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds - need_outer = varSetMinusEvBindMap need_inner live_ev_binds - `delVarSetList` givens - - ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds - -- See Note [Delete dead Given evidence bindings] - - ; traceTcS "neededEvVars" $ - vcat [ text "old_needs:" <+> ppr old_needs - , text "seeds3:" <+> ppr seeds3 - , text "tcvs:" <+> ppr tcvs - , text "ev_binds:" <+> ppr ev_binds - , text "live_ev_binds:" <+> ppr live_ev_binds ] - - ; return (implic { ic_need_inner = need_inner - , ic_need_outer = need_outer }) } - where - add_implic_seeds (Implic { ic_need_outer = needs }) acc - = needs `unionVarSet` acc - - needed_ev_bind needed (EvBind { eb_lhs = ev_var - , eb_info = info }) - | EvBindGiven{} <- info = ev_var `elemVarSet` needed - | otherwise = True -- Keep all wanted bindings - - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs - | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs - -------------------------------------------------- -simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError) --- Simplify any delayed errors: e.g. type and term holes --- NB: At this point we have finished with all the simple --- constraints; they are in wc_simple, not in the inert set. --- So those Wanteds will not rewrite these delayed errors. --- That's probably no bad thing. --- --- However if we have [W] alpha ~ Maybe a, [W] alpha ~ Int --- and _ : alpha, then we'll /unify/ alpha with the first of --- the Wanteds we get, and thereby report (_ : Maybe a) or --- (_ : Int) unpredictably, depending on which we happen to see --- first. Doesn't matter much; there is a type error anyhow. --- T17139 is a case in point. -simplifyDelayedErrors = mapBagM simpl_err - where - simpl_err :: DelayedError -> TcS DelayedError - simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole - simpl_err err@(DE_NotConcrete {}) = return err - - simpl_hole :: Hole -> TcS Hole - - -- See Note [Do not simplify ConstraintHoles] - simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h - - -- other wildcards should be simplified for printing - -- we must do so here, and not in the error-message generation - -- code, because we have all the givens already set up - simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) - = do { ty' <- rewriteType loc ty - ; traceTcS "simpl_hole" (ppr ty $$ ppr ty') - ; return (h { hole_ty = ty' }) } - -{- Note [Delete dead Given evidence bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As a result of superclass expansion, we speculatively -generate evidence bindings for Givens. E.g. - f :: (a ~ b) => a -> b -> Bool - f x y = ... -We'll have - [G] d1 :: (a~b) -and we'll speculatively generate the evidence binding - [G] d2 :: (a ~# b) = sc_sel d - -Now d2 is available for solving. But it may not be needed! Usually -such dead superclass selections will eventually be dropped as dead -code, but: - - * It won't always be dropped (#13032). In the case of an - unlifted-equality superclass like d2 above, we generate - case heq_sc d1 of d2 -> ... - and we can't (in general) drop that case expression in case - d1 is bottom. So it's technically unsound to have added it - in the first place. - - * Simply generating all those extra superclasses can generate lots of - code that has to be zonked, only to be discarded later. Better not - to generate it in the first place. - - Moreover, if we simplify this implication more than once - (e.g. because we can't solve it completely on the first iteration - of simpl_loop), we'll generate all the same bindings AGAIN! - -Easy solution: take advantage of the work we are doing to track dead -(unused) Givens, and use it to prune the Given bindings too. This is -all done by neededEvVars. - -This led to a remarkable 25% overall compiler allocation decrease in -test T12227. - -But we don't get to discard all redundant equality superclasses, alas; -see #15205. - -Note [Do not simplify ConstraintHoles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before printing the inferred value for a type hole (a _ wildcard in -a partial type signature), we simplify it w.r.t. any Givens. This -makes for an easier-to-understand diagnostic for the user. - -However, we do not wish to do this for extra-constraint holes. Here is -the example for why (partial-sigs/should_compile/T12844): - - bar :: _ => FooData rngs - bar = foo - - data FooData rngs - - class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs - - type family Head (xs :: [k]) where Head (x ': xs) = x - -GHC correctly infers that the extra-constraints wildcard on `bar` -should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this -constraint as a Given on the implication constraint for `bar`. (This -implication is emitted by emitResidualConstraints.) The Hole for the _ -is stored within the implication's WantedConstraints. When -simplifyHoles is called, that constraint is already assumed as a -Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r, -r'), Foo rngs), which is disastrous. - -Furthermore, there is no need to simplify here: extra-constraints wildcards -are filled in with the output of the solver, in chooseInferredQuantifiers -(choose_psig_context), so they are already simplified. (Contrast to normal -type holes, which are just bound to a meta-variable.) Avoiding the poor output -is simple: just don't simplify extra-constraints wildcards. - -This is the only reason we need to track ConstraintHole separately -from TypeHole in HoleSort. - -See also Note [Extra-constraint holes in partial type signatures] -in GHC.Tc.Gen.HsType. - -Note [Tracking redundant constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Opt_WarnRedundantConstraints, GHC can report which -constraints of a type signature (or instance declaration) are -redundant, and can be omitted. Here is an overview of how it -works. - -This is all tested in typecheck/should_compile/T20602 (among -others). - ------ What is a redundant constraint? - -* The things that can be redundant are precisely the Given - constraints of an implication. - -* A constraint can be redundant in two different ways: - a) It is not needed by the Wanted constraints covered by the - implication E.g. - f :: Eq a => a -> Bool - f x = True -- Equality not used - b) It is implied by other givens. E.g. - f :: (Eq a, Ord a) => blah -- Eq a unnecessary - g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary - -* To find (a) we need to know which evidence bindings are 'wanted'; - hence the eb_is_given field on an EvBind. - -* To find (b), we use mkMinimalBySCs on the Givens to see if any - are unnecessary. - ------ How tracking works - -(RC1) When two Givens are the same, we drop the evidence for the one - that requires more superclass selectors. This is done - according to 2(c) of Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. - -(RC2) The ic_need fields of an Implic records in-scope (given) evidence - variables bound by the context, that were needed to solve this - implication (so far). See the declaration of Implication. - -(RC3) setImplicationStatus: - When the constraint solver finishes solving all the wanteds in - an implication, it sets its status to IC_Solved - - - The ics_dead field, of IC_Solved, records the subset of this - implication's ic_given that are redundant (not needed). - - - We compute which evidence variables are needed by an implication - in setImplicationStatus. A variable is needed if - a) it is free in the RHS of a Wanted EvBind, - b) it is free in the RHS of an EvBind whose LHS is needed, or - c) it is in the ics_need of a nested implication. - - - After computing which variables are needed, we then look at the - remaining variables for internal redundancies. This is case (b) - from above. This is also done in setImplicationStatus. - Note that we only look for case (b) if case (a) shows up empty, - as exemplified below. - - - We need to be careful not to discard an implication - prematurely, even one that is fully solved, because we might - thereby forget which variables it needs, and hence wrongly - report a constraint as redundant. But we can discard it once - its free vars have been incorporated into its parent; or if it - simply has no free vars. This careful discarding is also - handled in setImplicationStatus. - -(RC4) We do not want to report redundant constraints for implications - that come from quantified constraints. Example #23323: - data T a - instance Show (T a) where ... -- No context! - foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int - bar = foo @T @Eq - - The call to `foo` gives us - [W] d : (forall a. Eq a => Show (T a)) - To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: - forall a. Eq a => [W] ds : Show (T a) - and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` - constraint. But we don't want to report it as redundant! - -* Examples: - - f, g, h :: (Eq a, Ord a) => a -> Bool - f x = x == x - g x = x > x - h x = x == x && x > x - - All three will discover that they have two [G] Eq a constraints: - one as given and one extracted from the Ord a constraint. They will - both discard the latter, as noted above and in - Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. - - The body of f uses the [G] Eq a, but not the [G] Ord a. It will - report a redundant Ord a using the logic for case (a). - - The body of g uses the [G] Ord a, but not the [G] Eq a. It will - report a redundant Eq a using the logic for case (a). - - The body of h uses both [G] Ord a and [G] Eq a. Case (a) will - thus come up with nothing redundant. But then, the case (b) - check will discover that Eq a is redundant and report this. - - If we did case (b) even when case (a) reports something, then - we would report both constraints as redundant for f, which is - terrible. - ------ Reporting redundant constraints - -* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints. - -* We don't report redundant givens for *every* implication; only - for those which reply True to GHC.Tc.Solver.warnRedundantGivens: - - - For example, in a class declaration, the default method *can* - use the class constraint, but it certainly doesn't *have* to, - and we don't want to report an error there. Ditto instance decls. - - - More subtly, in a function definition - f :: (Ord a, Ord a, Ix a) => a -> a - f x = rhs - we do an ambiguity check on the type (which would find that one - of the Ord a constraints was redundant), and then we check that - the definition has that type (which might find that both are - redundant). We don't want to report the same error twice, so we - disable it for the ambiguity check. Hence using two different - FunSigCtxts, one with the warn-redundant field set True, and the - other set False in - - GHC.Tc.Gen.Bind.tcSpecPrag - - GHC.Tc.Gen.Bind.tcTySig - - This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors - so that we can discard implication constraints that we don't need. - So ics_dead consists only of the *reportable* redundant givens. - ------ Shortcomings - -Shortcoming 1. Consider - - j :: (Eq a, a ~ b) => a -> Bool - j x = x == x - - k :: (Eq a, b ~ a) => a -> Bool - k x = x == x - -Currently (Nov 2021), j issues no warning, while k says that b ~ a -is redundant. This is because j uses the a ~ b constraint to rewrite -everything to be in terms of b, while k does none of that. This is -ridiculous, but I (Richard E) don't see a good fix. - -Shortcoming 2. Removing a redundant constraint can cause clients to fail to -compile, by making the function more polymoprhic. Consider (#16154) - - f :: (a ~ Bool) => a -> Int - f x = 3 - - g :: String -> Int - g s = f (read s) - -The constraint in f's signature is redundant; not used to typecheck -`f`. And yet if you remove it, `g` won't compile, because there'll -be an ambiguous variable in `g`. --} - --- | Like 'defaultTyVar', but in the TcS monad. -defaultTyVarTcS :: TcTyVar -> TcS Bool -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 - | isRuntimeRepVar the_tv - = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) - ; unifyTyVar the_tv liftedRepTy - ; return True } - | isLevityVar the_tv - = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv) - ; unifyTyVar the_tv liftedDataConTy - ; return True } - | isMultiplicityVar the_tv - = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) - ; unifyTyVar the_tv ManyTy - ; return True } - | otherwise - = return False -- the common case - -approximateWC :: Bool -- See Wrinkle (W3) in Note [ApproximateWC] - -> WantedConstraints - -> Cts --- Second return value is the depleted wc --- Postcondition: Wanted Cts --- See Note [ApproximateWC] --- See Note [floatKindEqualities vs approximateWC] -approximateWC float_past_equalities wc - = float_wc False emptyVarSet wc - where - float_wc :: Bool -- True <=> there are enclosing equalities - -> TcTyCoVarSet -- Enclosing skolem binders - -> WantedConstraints -> Cts - float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) - = filterBag (is_floatable encl_eqs trapping_tvs) simples `unionBags` - concatMapBag (float_implic encl_eqs trapping_tvs) implics - - float_implic :: Bool -> TcTyCoVarSet -> Implication -> Cts - float_implic encl_eqs trapping_tvs imp - = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp) - where - new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs - - is_floatable encl_eqs skol_tvs ct - | isGivenCt ct = False - | insolubleCt ct = False - | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = False - | otherwise - = case classifyPredType (ctPred ct) of - EqPred {} -> float_past_equalities || not encl_eqs - -- See Wrinkle (W1) - ClassPred {} -> True -- See Wrinkle (W2) - IrredPred {} -> True -- ..both in Note [ApproximateWC] - ForAllPred {} -> False - -{- Note [ApproximateWC] -~~~~~~~~~~~~~~~~~~~~~~~ -approximateWC takes a constraint, typically arising from the RHS of a -let-binding whose type we are *inferring*, and extracts from it some -*simple* constraints that we might plausibly abstract over. Of course -the top-level simple constraints are plausible, but we also float constraints -out from inside, if they are not captured by skolems. - -The same function is used when doing type-class defaulting (see the call -to applyDefaultingRules) to extract constraints that might be defaulted. - -Wrinkle (W1) - When inferring most-general types (in simplifyInfer), we - do *not* float an equality constraint if the implication binds - equality constraints, because that defeats the OutsideIn story. - Consider data T a where TInt :: T Int MkT :: T a - - f TInt = 3::Int - - We get the implication (a ~ Int => res ~ Int), where so far we've decided - f :: T a -> res - We don't want to float (res~Int) out because then we'll infer - f :: T a -> Int - which is only on of the possible types. (GHC 7.6 accidentally *did* - float out of such implications, which meant it would happily infer - non-principal types.) - -Wrinkle (W2) - We do allow /class/ constraints to float, even if - the implication binds equalities. This is a subtle point: see #23224. - In principle, a class constraint might ultimately be satisfiable from - a constraint bound by an implication (see #19106 for an example of this - kind), but it's extremely obscure and I was unable to construct a - concrete example. In any case, in super-subtle cases where this might - make a difference, you would be much better advised to simply write a - type signature. - - I included IrredPred here too, for good measure. In general, - abstracting over more constraints does no harm. - -Wrinkle (W3) - In findDefaultableGroups we are not worried about the - most-general type; and we /do/ want to float out of equalities - (#12797). Hence the boolean flag to approximateWC. - ------- Historical note ----------- -There used to be a second caveat, driven by #8155 - - 2. We do not float out an inner constraint that shares a type variable - (transitively) with one that is trapped by a skolem. Eg - forall a. F a ~ beta, Integral beta - We don't want to float out (Integral beta). Doing so would be bad - when defaulting, because then we'll default beta:=Integer, and that - makes the error message much worse; we'd get - Can't solve F a ~ Integer - rather than - Can't solve Integral (F a) - - Moreover, floating out these "contaminated" constraints doesn't help - when generalising either. If we generalise over (Integral b), we still - can't solve the retained implication (forall a. F a ~ b). Indeed, - arguably that too would be a harder error to understand. - -But this transitive closure stuff gives rise to a complex rule for -when defaulting actually happens, and one that was never documented. -Moreover (#12923), the more complex rule is sometimes NOT what -you want. So I simply removed the extra code to implement the -contamination stuff. There was zero effect on the testsuite (not even #8155). ------- End of historical note ----------- - -Note [DefaultTyVar] -~~~~~~~~~~~~~~~~~~~ -defaultTyVar is used on any un-instantiated meta type variables to -default any RuntimeRep variables to LiftedRep. This is important -to ensure that instance declarations match. For example consider - - instance Show (a->b) - foo x = show (\_ -> True) - -Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), -and that won't match the typeKind (*) in the instance decl. See tests -tc217 and tc175. - -We look only at touchable type variables. No further constraints -are going to affect these type variables, so it's time to do it by -hand. However we aren't ready to default them fully to () or -whatever, because the type-class defaulting rules have yet to run. - -An alternate implementation would be to emit a Wanted constraint setting -the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. - -Note [Promote _and_ default when inferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are inferring a type, we simplify the constraint, and then use -approximateWC to produce a list of candidate constraints. Then we MUST - - a) Promote any meta-tyvars that have been floated out by - approximateWC, to restore invariant (WantedInv) described in - Note [TcLevel invariants] in GHC.Tc.Utils.TcType. - - b) Default the kind of any meta-tyvars that are not mentioned in - in the environment. - -To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we -have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it -should! If we don't solve the constraint, we'll stupidly quantify over -(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over -(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. -#7641 is a simpler example. - -Note [Promoting unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we float an equality out of an implication we must "promote" free -unification variables of the equality, in order to maintain Invariant -(WantedInv) from Note [TcLevel invariants] in GHC.Tc.Types.TcType. - -This is absolutely necessary. Consider the following example. We start -with two implications and a class with a functional dependency. - - class C x y | x -> y - instance C [a] [a] - - (I1) [untch=beta]forall b. 0 => F Int ~ [beta] - (I2) [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c] - -We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2. -They may react to yield that (beta := [alpha]) which can then be pushed inwards -the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that -(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable -beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs: - - class C x y | x -> y where - op :: x -> y -> () - - instance C [a] [a] - - type family F a :: * - - h :: F Int -> () - h = undefined - - data TEx where - TEx :: a -> TEx - - f (x::beta) = - let g1 :: forall b. b -> () - g1 _ = h [x] - g2 z = case z of TEx y -> (h [[undefined]], op x [y]) - in (g1 '3', g2 undefined) - - -********************************************************************************* -* * -* Defaulting and disambiguation * -* * -********************************************************************************* - -Note [Defaulting plugins] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Defaulting plugins enable extending or overriding the defaulting -behaviour. In `applyDefaulting`, before the built-in defaulting -mechanism runs, the loaded defaulting plugins are passed the -`WantedConstraints` and get a chance to propose defaulting assignments -based on them. - -Proposals are represented as `[DefaultingProposal]` with each proposal -consisting of a type variable to fill-in, the list of defaulting types to -try in order, and a set of constraints to check at each try. This is -the same representation (albeit in a nicely packaged-up data type) as -the candidates generated by the built-in defaulting mechanism, so the -actual trying of proposals is done by the same `disambigGroup` function. - -Wrinkle (DP1): The role of `WantedConstraints` - - Plugins are passed `WantedConstraints` that can perhaps be - progressed on by defaulting. But a defaulting plugin is not a solver - plugin, its job is to provide defaulting proposals, i.e. mappings of - type variable to types. How do plugins know which type variables - they are supposed to default? - - The `WantedConstraints` passed to the defaulting plugin are zonked - beforehand to ensure all remaining metavariables are unfilled. Thus, - the `WantedConstraints` serve a dual purpose: they are both the - constraints of the given context that can act as hints to the - defaulting, as well as the containers of the type variables under - consideration for defaulting. - -Wrinkle (DP2): Interactions between defaulting mechanisms - - In the general case, we have multiple defaulting plugins loaded and - there is also the built-in defaulting mechanism. In this case, we - have to be careful to keep the `WantedConstraints` passed to the - plugins up-to-date by zonking between successful defaulting - rounds. Otherwise, two plugins might come up with a defaulting - proposal for the same metavariable; if the first one is accepted by - `disambigGroup` (thus the meta gets filled), the second proposal - becomes invalid (see #23821 for an example). - --} - -applyDefaultingRules :: WantedConstraints -> TcS Bool --- True <=> I did some defaulting, by unifying a meta-tyvar --- Input WantedConstraints are not necessarily zonked - -applyDefaultingRules wanteds - | isEmptyWC wanteds - = return False - | otherwise - = do { info@(default_tys, _) <- getDefaultInfo - ; wanteds <- TcS.zonkWC wanteds - - ; tcg_env <- TcS.getGblEnv - ; let plugins = tcg_defaulting_plugins tcg_env - - -- Run any defaulting plugins - -- See Note [Defaulting plugins] for an overview - ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else - do { - ; traceTcS "defaultingPlugins {" (ppr wanteds) - ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins - ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) - ; return (wanteds, defaultedGroups) - } - - ; let groups = findDefaultableGroups info wanteds - - ; traceTcS "applyDefaultingRules {" $ - vcat [ text "wanteds =" <+> ppr wanteds - , text "groups =" <+> ppr groups - , text "info =" <+> ppr info ] - - ; something_happeneds <- mapM (disambigGroup default_tys) groups - - ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) - - ; return $ or something_happeneds || or plugin_defaulted } - where run_defaulting_plugin wanteds p = - do { groups <- runTcPluginTcS (p wanteds) - ; defaultedGroups <- - filterM (\g -> disambigGroup - (deProposalCandidates g) - (deProposalTyVar g, deProposalCts g)) - groups - ; traceTcS "defaultingPlugin " $ ppr defaultedGroups - ; case defaultedGroups of - [] -> return (wanteds, False) - _ -> do - -- If a defaulting plugin solves any tyvars, some of the wanteds - -- will have filled-in metavars by now (see wrinkle DP2 of - -- Note [Defaulting plugins]). So we re-zonk to make sure later - -- defaulting doesn't try to solve the same metavars. - wanteds' <- TcS.zonkWC wanteds - return (wanteds', True) - } - - -findDefaultableGroups - :: ( [Type] - , (Bool,Bool) ) -- (Overloaded strings, extended default rules) - -> WantedConstraints -- Unsolved - -> [(TyVar, [Ct])] -findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds - | null default_tys - = [] - | otherwise - = [ (tv, map fstOf3 group) - | group'@((_,_,tv) :| _) <- unary_groups - , let group = toList group' - , defaultable_tyvar tv - , defaultable_classes (map sndOf3 group) ] - where - simples = approximateWC True wanteds - (unaries, non_unaries) = partitionWith find_unary (bagToList simples) - unary_groups = equivClasses cmp_tv unaries - - unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints - unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints - non_unaries :: [Ct] -- and *other* constraints - - -- Finds unary type-class constraints - -- But take account of polykinded classes like Typeable, - -- which may look like (Typeable * (a:*)) (#8931) - find_unary :: Ct -> Either (Ct, Class, TyVar) Ct - find_unary cc - | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) - , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys - -- Ignore invisible arguments for this purpose - , Just tv <- getTyVar_maybe ty - , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and - -- we definitely don't want to try to assign to those! - = Left (cc, cls, tv) - find_unary cc = Right cc -- Non unary or non dictionary - - bad_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries - bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries - - cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 - - defaultable_tyvar :: TcTyVar -> Bool - defaultable_tyvar tv - = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] - b2 = not (tv `elemVarSet` bad_tvs) - in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] - - 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)) - ------------------------------- -disambigGroup :: [Type] -- The default types - -> (TcTyVar, [Ct]) -- All constraints sharing same type variable - -> TcS Bool -- True <=> something happened, reflected in ty_binds - -disambigGroup [] _ - = return False -disambigGroup (default_ty:default_tys) group@(the_tv, wanteds) - = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ]) - ; fake_ev_binds_var <- TcS.newTcEvBinds - ; tclvl <- TcS.getTcLevel - ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group - - ; if success then - -- Success: record the type variable binding, and return - do { unifyTyVar the_tv default_ty - ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty - ; traceTcS "disambigGroup succeeded }" (ppr default_ty) - ; return True } - else - -- Failure: try with the next type - do { traceTcS "disambigGroup failed, will try other default types }" - (ppr default_ty) - ; disambigGroup default_tys group } } - where - try_group - | Just subst <- mb_subst - = do { lcl_env <- TcS.getLclEnv - ; tc_lvl <- TcS.getTcLevel - ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) - -- Equality constraints are possible due to type defaulting plugins - ; wanted_evs <- sequence [ newWantedNC loc rewriters pred' - | wanted <- wanteds - , CtWanted { ctev_pred = pred - , ctev_rewriters = rewriters } - <- return (ctEvidence wanted) - , let pred' = substTy subst pred ] - ; fmap isEmptyWC $ - solveSimpleWanteds $ listToBag $ - map mkNonCanonical wanted_evs } - - | otherwise - = return False - - the_ty = mkTyVarTy the_tv - mb_subst = tcMatchTyKi the_ty default_ty - -- 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. - --- In interactive mode, or with -XExtendedDefaultRules, --- we default Show a to Show () to avoid gratuitous errors on "show []" -isInteractiveClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isInteractiveClass ovl_strings cls - = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) - - -- isNumClass adds IsString to the standard numeric classes, - -- when -XOverloadedStrings is enabled -isNumClass :: Bool -- -XOverloadedStrings? - -> Class -> Bool -isNumClass ovl_strings cls - = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) - - -{- -Note [Avoiding spurious errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When doing the unification for defaulting, we check for skolem -type variables, and simply don't default them. For example: - f = (*) -- Monomorphic - g :: Num a => a -> a - g x = f x x -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num a) context arising from f's definition; -we try to unify a with Int (to default it), but find that it's -already been unified with the rigid variable from g's type sig. - -Note [Multi-parameter defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XExtendedDefaultRules, we default only based on single-variable -constraints, but do not exclude from defaulting any type variables which also -appear in multi-variable constraints. This means that the following will -default properly: - - default (Integer, Double) - - class A b (c :: Symbol) where - a :: b -> Proxy c - - instance A Integer c where a _ = Proxy - - main = print (a 5 :: Proxy "5") - -Note that if we change the above instance ("instance A Integer") to -"instance A Double", we get an error: - - No instance for (A Integer "5") - -This is because the first defaulted type (Integer) has successfully satisfied -its single-parameter constraints (in this case Num). + simplifyTop, simplifyTopImplic, + simplifyInteractive, + solveEqualities, + pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX, + reportUnsolvedEqualities, + simplifyWantedsTcM, + tcCheckGivens, + tcCheckWanteds, + tcNormalise, + approximateWC, -- Exported for plugins to use + + captureTopConstraints, emitResidualConstraints, + + simplifyTopWanteds, + + promoteTyVarSet, simplifyAndEmitFlatConstraints + + ) where + +import GHC.Prelude + +import GHC.Tc.Errors +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Solve ( solveSimpleGivens, solveSimpleWanteds + , solveWanteds, simplifyWantedsTcM ) +import GHC.Tc.Solver.Default ( tryDefaulting, tryDefaultingForAmbiguityCheck + , isInteractiveClass ) +import GHC.Tc.Solver.Dict ( makeSuperClasses ) +import GHC.Tc.Solver.Rewrite ( rewriteType ) +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Zonk.TcType as TcM +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType + +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Ppr +import GHC.Core.TyCon ( TyConBinder ) + +import GHC.Types.Name +import GHC.Types.Id + +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Error + +import GHC.Driver.DynFlags( DynFlags, xopt ) +import GHC.Driver.Flags( WarningFlag(..) ) +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) + +import GHC.Data.Bag + +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.List ( partition ) +import GHC.Data.Maybe ( mapMaybe ) + +{- +********************************************************************************* +* * +* External interface * +* * +********************************************************************************* +-} + +captureTopConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureTopConstraints m) runs m, and returns the type constraints it +-- generates plus the constraints produced by static forms inside. +-- If it fails with an exception, it reports any insolubles +-- (out of scope variables) before doing so +-- +-- captureTopConstraints is used exclusively by GHC.Tc.Module at the top +-- level of a module. +-- +-- Importantly, if captureTopConstraints propagates an exception, it +-- reports any insoluble constraints first, lest they be lost +-- altogether. This is important, because solveEqualities (maybe +-- other things too) throws an exception without adding any error +-- messages; it just puts the unsolved constraints back into the +-- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors] +-- #16376 is an example of what goes wrong if you don't do this. +-- +-- NB: the caller should bring any environments into scope before +-- calling this, so that the reportUnsolved has access to the most +-- complete GlobalRdrEnv +captureTopConstraints thing_inside + = do { static_wc_var <- TcM.newTcRef emptyWC ; + ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $ + TcM.tryCaptureConstraints thing_inside + ; stWC <- TcM.readTcRef static_wc_var + + -- See GHC.Tc.Utils.Monad Note [Constraints and errors] + -- If the thing_inside threw an exception, but generated some insoluble + -- constraints, report the latter before propagating the exception + -- Otherwise they will be lost altogether + ; case mb_res of + Just res -> return (res, lie `andWC` stWC) + Nothing -> do { _ <- simplifyTop lie; failM } } + -- This call to simplifyTop is the reason + -- this function is here instead of GHC.Tc.Utils.Monad + -- We call simplifyTop so that it does defaulting + -- (esp of runtime-reps) before reporting errors + +simplifyTopImplic :: Bag Implication -> TcM () +simplifyTopImplic implics + = do { empty_binds <- simplifyTop (mkImplicWC implics) + + -- Since all the inputs are implications the returned bindings will be empty + ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) + + ; return () } + +simplifyTop :: WantedConstraints -> TcM (Bag EvBind) +-- Simplify top-level constraints +-- Usually these will be implications, +-- but when there is nothing to quantify we don't wrap +-- in a degenerate implication, so we do that here instead +simplifyTop wanteds + = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds + ; ((final_wc, unsafe_ol), binds1) <- runTcS $ + do { final_wc <- simplifyTopWanteds wanteds + ; unsafe_ol <- getSafeOverlapFailures + ; return (final_wc, unsafe_ol) } + ; traceTc "End simplifyTop }" empty + + ; binds2 <- reportUnsolved final_wc + + ; traceTc "reportUnsolved (unsafe overlapping) {" empty + ; unless (isEmptyBag unsafe_ol) $ do { + -- grab current error messages and clear, warnAllUnsolved will + -- update error messages which we'll grab and then restore saved + -- messages. + ; errs_var <- getErrsVar + ; saved_msg <- TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var emptyMessages + + ; warnAllUnsolved $ emptyWC { wc_simple = fmap CDictCan unsafe_ol } + + ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var + ; TcM.writeTcRef errs_var saved_msg + ; recordUnsafeInfer (mkMessages whyUnsafe) + } + ; traceTc "reportUnsolved (unsafe overlapping) }" empty + + ; return (evBindMapBinds binds1 `unionBags` binds2) } + +pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a +-- Push level, and solve all resulting equalities +-- If there are any unsolved equalities, report them +-- and fail (in the monad) +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside + = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX + "pushLevelAndSolveEqualities" thing_inside + ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted + ; return res } + +pushLevelAndSolveEqualitiesX :: String -> TcM a + -> TcM (TcLevel, WantedConstraints, a) +-- Push the level, gather equality constraints, and then solve them. +-- Returns any remaining unsolved equalities. +-- Does not report errors. +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +pushLevelAndSolveEqualitiesX callsite thing_inside + = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite) + ; (tclvl, (wanted, res)) + <- pushTcLevelM $ + do { (res, wanted) <- captureConstraints thing_inside + ; wanted <- runTcSEqualities (simplifyTopWanteds wanted) + ; return (wanted,res) } + ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted + , text "Level:" <+> ppr tclvl ]) + ; return (tclvl, wanted, res) } + +-- | Type-check a thing that emits only equality constraints, solving any +-- constraints we can and re-emitting constraints that we can't. +-- Use this variant only when we'll get another crack at it later +-- See Note [Failure in local type signatures] +-- +-- Panics if we solve any non-equality constraints. (In runTCSEqualities +-- we use an error thunk for the evidence bindings.) +solveEqualities :: String -> TcM a -> TcM a +solveEqualities callsite thing_inside + = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite) + ; (res, wanted) <- captureConstraints thing_inside + ; simplifyAndEmitFlatConstraints wanted + -- simplifyAndEmitFlatConstraints fails outright unless + -- the only unsolved constraints are soluble-looking + -- equalities that can float out + ; traceTc "solveEqualities }" empty + ; return res } + +simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM () +-- See Note [Failure in local type signatures] +simplifyAndEmitFlatConstraints wanted + = do { -- Solve and zonk to establish the + -- preconditions for floatKindEqualities + wanted <- runTcSEqualities (solveWanteds wanted) + ; wanted <- TcM.liftZonkM $ TcM.zonkWC wanted + + ; traceTc "emitFlatConstraints {" (ppr wanted) + ; case floatKindEqualities wanted of + Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted) + -- Emit the bad constraints, wrapped in an implication + -- See Note [Wrapping failing kind equalities] + ; tclvl <- TcM.getTcLevel + ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted + -- ^^^^^^ | ^^^^^^^^^^^^^^^^^ + -- it's OK to use unkSkol | we must increase the TcLevel, + -- because we don't bind | as explained in + -- any skolem variables here | Note [Wrapping failing kind equalities] + ; TcM.emitImplication implic + ; failM } + Just (simples, errs) + -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples) + ; traceTc "emitFlatConstraints }" $ + vcat [ text "simples:" <+> ppr simples + , text "errs: " <+> ppr errs ] + -- Holes and other delayed errors don't need promotion + ; emitDelayedErrors errs + ; emitSimples simples } } + +floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) +-- Float out all the constraints from the WantedConstraints, +-- Return Nothing if any constraints can't be floated (captured +-- by skolems), or if there is an insoluble constraint, or +-- IC_Telescope telescope error +-- Precondition 1: we have tried to solve the 'wanteds', both so that +-- the ic_status field is set, and because solving can make constraints +-- more floatable. +-- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities +-- is not monadic +-- See Note [floatKindEqualities vs approximateWC] +floatKindEqualities wc = float_wc emptyVarSet wc + where + float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) + float_wc trapping_tvs (WC { wc_simple = simples + , wc_impl = implics + , wc_errors = errs }) + | all is_floatable simples + = do { (inner_simples, inner_errs) + <- flatMapBagPairM (float_implic trapping_tvs) implics + ; return ( simples `unionBags` inner_simples + , errs `unionBags` inner_errs) } + | otherwise + = Nothing + where + is_floatable ct + | insolubleCt ct = False + | otherwise = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs + + float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError) + float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs + , ic_skols = skols, ic_status = status }) + | isInsolubleStatus status + = Nothing -- A short cut /plus/ we must keep track of IC_BadTelescope + | otherwise + = do { (simples, holes) <- float_wc new_trapping_tvs wanted + ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $ + Nothing + -- If there are some constraints to float out, but we can't + -- because we don't float out past local equalities + -- (c.f GHC.Tc.Solver.approximateWC), then fail + ; return (simples, holes) } + where + new_trapping_tvs = trapping_tvs `extendVarSetList` skols + + +{- Note [Failure in local type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind checking a type signature, we like to fail fast if we can't +solve all the kind equality constraints, for two reasons: + + * A kind-bogus type signature may cause a cascade of knock-on + errors if we let it pass + + * More seriously, we don't have a convenient term-level place to add + deferred bindings for unsolved kind-equality constraints. In + earlier GHCs this led to un-filled-in coercion holes, which caused + GHC to crash with "fvProv falls into a hole" See #11563, #11520, + #11516, #11399 + +But what about /local/ type signatures, mentioning in-scope type +variables for which there might be 'given' equalities? For these we +might not be able to solve all the equalities locally. Here's an +example (T15076b): + + class (a ~ b) => C a b + data SameKind :: k -> k -> Type where { SK :: SameKind a b } + + bar :: forall (a :: Type) (b :: Type). + C a b => Proxy a -> Proxy b -> () + bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) + +Consider the type signature on 'undefined'. It's ill-kinded unless +a~b. But the superclass of (C a b) means that indeed (a~b). So all +should be well. BUT it's hard to see that when kind-checking the signature +for undefined. We want to emit a residual (a~b) constraint, to solve +later. + +Another possibility is that we might have something like + F alpha ~ [Int] +where alpha is bound further out, which might become soluble +"later" when we learn more about alpha. So we want to emit +those residual constraints. + +BUT it's no good simply wrapping all unsolved constraints from +a type signature in an implication constraint to solve later. The +problem is that we are going to /use/ that signature, including +instantiate it. Say we have + f :: forall a. (forall b. blah) -> blah2 + f x = +To typecheck the definition of f, we have to instantiate those +foralls. Moreover, any unsolved kind equalities will be coercion +holes in the type. If we naively wrap them in an implication like + forall a. (co1:k1~k2, forall b. co2:k3~k4) +hoping to solve it later, we might end up filling in the holes +co1 and co2 with coercions involving 'a' and 'b' -- but by now +we've instantiated the type. Chaos! + +Moreover, the unsolved constraints might be skolem-escape things, and +if we proceed with f bound to a nonsensical type, we get a cascade of +follow-up errors. For example polykinds/T12593, T15577, and many others. + +So here's the plan (see tcHsSigType): + +* pushLevelAndSolveEqualitiesX: try to solve the constraints + +* kindGeneraliseSome: do kind generalisation + +* buildTvImplication: build an implication for the residual, unsolved + constraint + +* simplifyAndEmitFlatConstraints: try to float out every unsolved equality + inside that implication, in the hope that it constrains only global + type variables, not the locally-quantified ones. + + * If we fail, or find an insoluble constraint, emit the implication, + so that the errors will be reported, and fail. + + * If we succeed in floating all the equalities, promote them and + re-emit them as flat constraint, not wrapped at all (since they + don't mention any of the quantified variables. + +* Note that this float-and-promote step means that anonymous + wildcards get floated to top level, as we want; see + Note [Checking partial type signatures] in GHC.Tc.Gen.HsType. + +All this is done: + +* In GHC.Tc.Gen.HsType.tcHsSigType, as above + +* solveEqualities. Use this when there no kind-generalisation + step to complicate matters; then we don't need to push levels, + and can solve the equalities immediately without needing to + wrap it in an implication constraint. (You'll generally see + a kindGeneraliseNone nearby.) + +* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to + pushLevelAndSolveEqualitiesX, followed by quantification, and + then reportUnsolvedEqualities. + + NB: we call reportUnsolvedEqualities before zonkTcTypeToType + because the latter does not expect to see any un-filled-in + coercions, which will happen if we have unsolved equalities. + By calling reportUnsolvedEqualities first, which fails after + reporting errors, we avoid that happening. + +See also #18062, #11506 + +Note [Wrapping failing kind equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In simplifyAndEmitFlatConstraints, if we fail to get down to simple +flat constraints we will +* re-emit the constraints so that they are reported +* fail in the monad +But there is a Terrible Danger that, if -fdefer-type-errors is on, and +we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll +report only a warning and proceed with compilation. But if we ever fail +in the monad it should be fatal; we should report an error and stop after +the type checker. If not, chaos results: #19142. + +Our solution is this: +* Even with -fdefer-type-errors, inside an implication with no place for + value bindings (ic_binds = CoEvBindsVar), report failing equalities as + errors. We have to do this anyway; see GHC.Tc.Errors + Note [Failing equalities with no evidence bindings]. + +* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication + to wrap the failing constraint in a degenerate implication (no + skolems, no theta), with ic_binds = CoEvBindsVar. This setting of + `ic_binds` means that any failing equalities will lead to an + error not a warning, irrespective of -fdefer-type-errors: see + Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors, + and `maybeSwitchOffDefer` in that module. + + We still take care to bump the TcLevel of the implication. Partly, + that ensures that nested implications have increasing level numbers + which seems nice. But more specifically, suppose the outer level + has a Given `(C ty)`, which has pending (not-yet-expanded) + superclasses. Consider what happens when we process this implication + constraint (which we have re-emitted) in that context: + - in the inner implication we'll call `getPendingGivenScs`, + - we /do not/ want to get the `(C ty)` from the outer level, + lest we try to add an evidence term for the superclass, + which we can't do because we have specifically set + `ic_binds` = `CoEvBindsVar`. + - as `getPendingGivenSCcs is careful to only get Givens from + the /current/ level, and we bumped the `TcLevel` of the implication, + we're OK. + + TL;DR: bump the `TcLevel` when creating the nested implication. + If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043). + + +We re-emit the implication rather than reporting the errors right now, +so that the error messages are improved by other solving and defaulting. +e.g. we prefer + Cannot match 'Type->Type' with 'Type' +to Cannot match 'Type->Type' with 'TYPE r0' + + +Note [floatKindEqualities vs approximateWC] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +floatKindEqualities and approximateWC are strikingly similar to each +other, but + +* floatKindEqualites tries to float /all/ equalities, and fails if + it can't, or if any implication is insoluble. +* approximateWC just floats out any constraints + (not just equalities) that can float; it never fails. +-} + + +reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +-- Reports all unsolved wanteds provided; fails in the monad if there are any. +-- +-- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to +-- provide skolem info for any errors. +reportUnsolvedEqualities skol_info skol_tvs tclvl wanted + = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted + +report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel + -> WantedConstraints -> TcM () +report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted + | isEmptyWC wanted + = return () + + | otherwise -- NB: we build an implication /even if skol_tvs is empty/, + -- just to ensure that our level invariants hold, specifically + -- (WantedInv). See Note [TcLevel invariants]. + = checkNoErrs $ -- Fail + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted + ; reportAllUnsolved (mkImplicWC (unitBag implic)) } + + +-- | Simplify top-level constraints, but without reporting any unsolved +-- constraints nor unsafe overlapping. +simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints +simplifyTopWanteds wanteds + = do { -- Solve the constraints + wc_first_go <- nestTcS (solveWanteds wanteds) + + -- Now try defaulting: + -- see Note [Top-level Defaulting Plan] + ; tryDefaulting wc_first_go } + +{- Note [Safe Haskell Overlapping Instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Safe Haskell, we apply an extra restriction to overlapping instances. The +motive is to prevent untrusted code provided by a third-party, changing the +behavior of trusted code through type-classes. This is due to the global and +implicit nature of type-classes that can hide the source of the dictionary. + +Another way to state this is: if a module M compiles without importing another +module N, changing M to import N shouldn't change the behavior of M. + +Overlapping instances with type-classes can violate this principle. However, +overlapping instances aren't always unsafe. They are just unsafe when the most +selected dictionary comes from untrusted code (code compiled with -XSafe) and +overlaps instances provided by other modules. + +In particular, in Safe Haskell at a call site with overlapping instances, we +apply the following rule to determine if it is a 'unsafe' overlap: + + 1) Most specific instance, I1, defined in an `-XSafe` compiled module. + 2) I1 is an orphan instance or a MPTC. + 3) At least one overlapped instance, Ix, is both: + A) from a different module than I1 + B) Ix is not marked `OVERLAPPABLE` + +This is a slightly involved heuristic, but captures the situation of an +imported module N changing the behavior of existing code. For example, if +condition (2) isn't violated, then the module author M must depend either on a +type-class or type defined in N. + +Secondly, when should these heuristics be enforced? We enforced them when the +type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`. +This allows `-XUnsafe` modules to operate without restriction, and for Safe +Haskell inference to infer modules with unsafe overlaps as unsafe. + +One alternative design would be to also consider if an instance was imported as +a `safe` import or not and only apply the restriction to instances imported +safely. However, since instances are global and can be imported through more +than one path, this alternative doesn't work. + +Note [Safe Haskell Overlapping Instances Implementation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How is this implemented? It's complicated! So we'll step through it all: + + 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where + we check if a particular type-class method call is safe or unsafe. We do this + through the return type, `ClsInstLookupResult`, where the last parameter is a + list of instances that are unsafe to overlap. When the method call is safe, + the list is null. + + 2) `GHC.Tc.Solver.Dict.matchClassInst` -- This module drives the instance resolution + / dictionary generation. The return type is `ClsInstResult`, which either + says no instance matched, or one found, and if it was a safe or unsafe + overlap. + + 3) `GHC.Tc.Solver.Dict.tryInstances` -- Takes a dictionary / class constraint and + tries to resolve it by calling (in part) `matchClassInst`. The resolving + mechanism has a work list (of constraints) that it process one at a time. If + the constraint can't be resolved, it's added to an inert set. When compiling + an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know + compilation should fail. These are handled as normal constraint resolution + failures from here-on (see step 6). + + Otherwise, we may be inferring safety (or using `-Wunsafe`), and + compilation should succeed, but print warnings and/or mark the compiled module + as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds + the unsafe (but resolved!) constraint to the `inert_safehask` field of + `InertCans`. + + 4) `GHC.Tc.Solver.simplifyTop`: + * Call simplifyTopWanteds, the top-level function for driving the simplifier for + constraint resolution. + + * Once finished, call `getSafeOverlapFailures` to retrieve the + list of overlapping instances that were successfully resolved, + but unsafe. Remember, this is only applicable for generating warnings + (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy` + cause compilation failure by not resolving the unsafe constraint at all. + + * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`, + while for resolved but unsafe overlapping dictionary constraints, call + `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a + warning message for the user. + + * In the case of `warnAllUnsolved` for resolved, but unsafe + dictionary constraints, we collect the generated warning + message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to + mark the module we are compiling as unsafe, passing the + warning message along as the reason. + + 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by + actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we + know is the constraint that is unresolved or unsafe. For dictionary, all we + know is that we need a dictionary of type C, but not what instances are + available and how they overlap. So we once again call `lookupInstEnv` to + figure that out so we can generate a helpful error message. + + 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in + IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. + + 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling + `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference + failed. +-} + +------------------ +simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM () +simplifyAmbiguityCheck ty wc + = do { traceTc "simplifyAmbiguityCheck {" $ + text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wc + + ; (final_wc, _) <- runTcS $ do { wc1 <- solveWanteds wc + ; tryDefaultingForAmbiguityCheck wc1 } + + ; discardResult (reportUnsolved final_wc) + + ; traceTc "End simplifyAmbiguityCheck }" empty } + +------------------ +simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) +simplifyInteractive wanteds + = traceTc "simplifyInteractive" empty >> + simplifyTop wanteds + +------------------ +{- Note [Pattern match warnings with insoluble Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A pattern match on a GADT can introduce new type-level information, which needs +to be analysed in order to get the expected pattern match warnings. + +For example: + +> type IsBool :: Type -> Constraint +> type family IsBool a where +> IsBool Bool = () +> IsBool b = b ~ Bool +> +> data T a where +> MkTInt :: Int -> T Int +> MkTBool :: IsBool b => b -> T b +> +> f :: T Int -> Int +> f (MkTInt i) = i + +The pattern matching performed by `f` is complete: we can't ever call +`f (MkTBool b)`, as type-checking that application would require producing +evidence for `Int ~ Bool`, which can't be done. + +The pattern match checker uses `tcCheckGivens` to accumulate all the Given +constraints, and relies on `tcCheckGivens` to return Nothing if the +Givens become insoluble. `tcCheckGivens` in turn relies on `insolubleCt` +to identify these insoluble constraints. So the precise definition of +`insolubleCt` has a big effect on pattern match overlap warnings. + +To detect this situation, we check whether there are any insoluble Given +constraints. In the example above, the insoluble constraint was an +equality constraint, but it is also important to detect custom type errors: + +> type NotInt :: Type -> Constraint +> type family NotInt a where +> NotInt Int = TypeError (Text "That's Int, silly.") +> NotInt _ = () +> +> data R a where +> MkT1 :: a -> R a +> MkT2 :: NotInt a => R a +> +> foo :: R Int -> Int +> foo (MkT1 x) = x + +To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble +because it is a custom type error. +Failing to do so proved quite inconvenient for users, as evidence by the +tickets #11503 #14141 #16377 #20180. +Test cases: T11503, T14141. + +Examples of constraints that tcCheckGivens considers insoluble: + - Int ~ Bool, + - Coercible Float Word, + - TypeError msg. + +Non-examples: + - constraints which we know aren't satisfied, + e.g. Show (Int -> Int) when no such instance is in scope, + - Eq (TypeError msg), + - C (Int ~ Bool), with @class C (c :: Constraint)@. +-} + +tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet) +-- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely +-- contradictory. +-- +-- See Note [Pattern match warnings with insoluble Givens] above. +tcCheckGivens inerts given_ids = do + (sat, new_inerts) <- runTcSInerts inerts $ do + traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids) + lcl_env <- TcS.getLclEnv + let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + let given_cts = mkGivens given_loc (bagToList given_ids) + -- See Note [Superclasses and satisfiability] + solveSimpleGivens given_cts + insols <- getInertInsols + insols <- try_harder insols + traceTcS "checkGivens }" (ppr insols) + return (isEmptyBag insols) + return $ if sat then Just new_inerts else Nothing + where + try_harder :: Cts -> TcS Cts + -- Maybe we have to search up the superclass chain to find + -- an unsatisfiable constraint. Example: pmcheck/T3927b. + -- At the moment we try just once + try_harder insols + | not (isEmptyBag insols) -- We've found that it's definitely unsatisfiable + = return insols -- Hurrah -- stop now. + | otherwise + = do { pending_given <- getPendingGivenScs + ; new_given <- makeSuperClasses pending_given + ; solveSimpleGivens new_given + ; getInertInsols } + +tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool +-- ^ Return True if the Wanteds are soluble, False if not +tcCheckWanteds inerts wanteds = do + cts <- newWanteds PatCheckOrigin wanteds + (sat, _new_inerts) <- runTcSInerts inerts $ do + traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds) + -- See Note [Superclasses and satisfiability] + wcs <- solveWanteds (mkSimpleWC cts) + traceTcS "checkWanteds }" (ppr wcs) + return (isSolvedWC wcs) + return sat + +-- | Normalise a type as much as possible using the given constraints. +-- See @Note [tcNormalise]@. +tcNormalise :: InertSet -> Type -> TcM Type +tcNormalise inerts ty + = do { norm_loc <- getCtLocM PatCheckOrigin Nothing + ; (res, _new_inerts) <- runTcSInerts inerts $ + do { traceTcS "tcNormalise {" (ppr inerts) + ; ty' <- rewriteType norm_loc ty + ; traceTcS "tcNormalise }" (ppr ty') + ; pure ty' } + ; return res } + +{- Note [Superclasses and satisfiability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expand superclasses before starting, because (Int ~ Bool), has +(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool) +as a superclass, and it's the latter that is insoluble. See +Note [The equality types story] in GHC.Builtin.Types.Prim. + +If we fail to prove unsatisfiability we (arbitrarily) try just once to +find superclasses, using try_harder. Reason: we might have a type +signature + f :: F op (Implements push) => .. +where F is a type function. This happened in #3972. + +We could do more than once but we'd have to have /some/ limit: in the +the recursive case, we would go on forever in the common case where +the constraints /are/ satisfiable (#10592 comment:12!). + +For straightforward situations without type functions the try_harder +step does nothing. + +Note [tcNormalise] +~~~~~~~~~~~~~~~~~~ +tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas +most invocations of the constraint solver are intended to simplify a set of +constraints or to decide if a particular set of constraints is satisfiable, +the purpose of tcNormalise is to take a type, plus some locally solved +constraints in the form of an InertSet, and normalise the type as much as +possible with respect to those constraints. + +It does *not* reduce type or data family applications or look through newtypes. + +Why is this useful? As one example, when coverage-checking an EmptyCase +expression, it's possible that the type of the scrutinee will only reduce +if some local equalities are solved for. See "Wrinkle: Local equalities" +in Note [Type normalisation] in "GHC.HsToCore.Pmc". + +To accomplish its stated goal, tcNormalise first initialises the solver monad +with the given InertCans, then uses rewriteType to simplify the desired type +with respect to the Givens in the InertCans. + +*********************************************************************************** +* * +* Inference +* * +*********************************************************************************** + +Note [Inferring the type of a let-bound variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = rhs + +To infer f's type we do the following: + * Gather the constraints for the RHS with ambient level *one more than* + the current one. This is done by the call + pushLevelAndCaptureConstraints (tcMonoBinds...) + in GHC.Tc.Gen.Bind.tcPolyInfer + + * Call simplifyInfer to simplify the constraints and decide what to + quantify over. We pass in the level used for the RHS constraints, + here called rhs_tclvl. + +This ensures that the implication constraint we generate, if any, +has a strictly-increased level compared to the ambient level outside +the let binding. + +Note [Inferring principal types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't always infer principal types. For instance, the inferred type for + +> f x = show [x] + +is + +> f :: Show a => a -> String + +This is not the most general type if we allow flexible contexts. +Indeed, if we try to write the following + +> g :: Show [a] => a -> String +> g x = f x + +we get the error: + + * Could not deduce (Show a) arising from a use of `f' + from the context: Show [a] + +Though replacing f x in the right-hand side of g with the definition +of f x works, the call to f x does not. This is the hallmark of +unprincip{led,al} types. + +Another example: + +> class C a +> class D a where +> d :: a +> instance C a => D a where +> d = undefined +> h _ = d -- argument is to avoid the monomorphism restriction + +The inferred type for h is + +> h :: C a => t -> a + +even though + +> h :: D a => t -> a + +is more general. + +The fix is easy: don't simplify constraints before inferring a type. +That is, have the inferred type quantify over all constraints that arise +in a definition's right-hand side, even if they are simplifiable. +Unfortunately, this would yield all manner of unwieldy types, +and so we won't do so. +-} + +-- | How should we choose which constraints to quantify over? +data InferMode = ApplyMR -- ^ Apply the monomorphism restriction, + -- never quantifying over any constraints + | EagerDefaulting -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module", + -- the :type +d case; this mode refuses + -- to quantify over any defaultable constraint + | NoRestrictions -- ^ Quantify over any constraint that + -- satisfies pickQuantifiablePreds + +instance Outputable InferMode where + ppr ApplyMR = text "ApplyMR" + ppr EagerDefaulting = text "EagerDefaulting" + ppr NoRestrictions = text "NoRestrictions" + +simplifyInfer :: TopLevelFlag + -> TcLevel -- Used when generating the constraints + -> InferMode + -> [TcIdSigInst] -- Any signatures (possibly partial) + -> [(Name, TcTauType)] -- Variables to be generalised, + -- and their tau-types + -> WantedConstraints + -> TcM ([TcTyVar], -- Quantify over these type variables + [EvVar], -- ... and these constraints (fully zonked) + TcEvBinds, -- ... binding these evidence variables + Bool) -- True <=> the residual constraints are insoluble + +simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds + | isEmptyWC wanteds + = do { -- When quantifying, we want to preserve any order of variables as they + -- appear in partial signatures. cf. decideQuantifiedTyVars + let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs + , (_,Bndr tv _) <- sig_inst_skols sig ] + psig_theta = [ pred | sig <- partial_sigs + , pred <- sig_inst_theta sig ] + + ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) + + ; skol_info <- mkSkolemInfo (InferSkol name_taus) + ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars + ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) + ; return (qtkvs, [], emptyTcEvBinds, False) } + + | otherwise + = do { traceTc "simplifyInfer {" $ vcat + [ text "sigs =" <+> ppr sigs + , text "binds =" <+> ppr name_taus + , text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "infer_mode =" <+> ppr infer_mode + , text "(unzonked) wanted =" <+> ppr wanteds + ] + + ; let psig_theta = concatMap sig_inst_theta partial_sigs + + -- First do full-blown solving + -- NB: we must gather up all the bindings from doing this solving; hence + -- (runTcSWithEvBinds ev_binds_var). And note that since there are + -- nested implications, calling solveWanteds will side-effect their + -- evidence bindings, so we can't just revert to the input constraint. + -- + -- See also Note [Inferring principal types] + ; ev_binds_var <- TcM.newTcEvBinds + ; psig_evs <- newWanteds AnnOrigin psig_theta + ; wanted_transformed + <- runTcSWithEvBinds ev_binds_var $ + setTcLevelTcS rhs_tclvl $ + solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) + -- setLevelTcS: we do setLevel /inside/ the runTcS, so that + -- we initialise the InertSet inert_given_eq_lvl as far + -- out as possible, maximising oppportunities to unify + -- psig_evs : see Note [Add signature contexts as wanteds] + + -- Find quant_pred_candidates, the predicates that + -- we'll consider quantifying over + -- NB1: wanted_transformed does not include anything provable from + -- the psig_theta; it's just the extra bit + -- NB2: We do not do any defaulting when inferring a type, this can lead + -- to less polymorphic types, see Note [Default while Inferring] + ; wanted_transformed <- TcM.liftZonkM $ TcM.zonkWC wanted_transformed + ; let definite_error = insolubleWC wanted_transformed + -- See Note [Quantification with errors] + wanted_dq | definite_error = emptyWC + | otherwise = wanted_transformed + + -- Decide what type variables and constraints to quantify + -- NB: quant_pred_candidates is already fully zonked + -- NB: bound_theta are constraints we want to quantify over, + -- including the psig_theta, which we always quantify over + -- NB: bound_theta are fully zonked + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification + top_lvl rhs_tclvl infer_mode + skol_info name_taus partial_sigs + wanted_dq + + ; bound_theta_vars <- mapM TcM.newEvVar bound_theta + + ; let full_theta = map idType bound_theta_vars + skol_info = InferSkol [ (name, mkPhiTy full_theta ty) + | (name, ty) <- name_taus ] + -- mkPhiTy: we don't add the quantified variables here, because + -- they are also bound in ic_skols and we want them to be tidied + -- uniformly. + } + + + -- Now emit the residual constraint + ; emitResidualConstraints rhs_tclvl skol_info ev_binds_var + co_vars qtvs bound_theta_vars + wanted_transformed + + -- All done! + ; traceTc "} simplifyInfer/produced residual implication for quantification" $ + vcat [ text "wanted_dq =" <+> ppr wanted_dq + , text "psig_theta =" <+> ppr psig_theta + , text "bound_theta =" <+> pprCoreBinders bound_theta_vars + , text "qtvs =" <+> ppr qtvs + , text "definite_error =" <+> ppr definite_error ] + + ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) } + -- NB: bound_theta_vars must be fully zonked + where + partial_sigs = filter isPartialSig sigs + +-------------------- +emitResidualConstraints :: TcLevel -> SkolemInfoAnon -> EvBindsVar + -> CoVarSet -> [TcTyVar] -> [EvVar] + -> WantedConstraints -> TcM () +-- Emit the remaining constraints from the RHS. +emitResidualConstraints rhs_tclvl skol_info ev_binds_var + co_vars qtvs full_theta_vars wanteds + | isEmptyWC wanteds + = return () + + | otherwise + = do { wanted_simple <- TcM.liftZonkM $ TcM.zonkSimples (wc_simple wanteds) + ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple + is_mono ct + | Just ct_ev_id <- wantedEvId_maybe ct + = ct_ev_id `elemVarSet` co_vars + | otherwise + = False + -- Reason for the partition: + -- see Note [Emitting the residual implication in simplifyInfer] + +-- Already done by defaultTyVarsAndSimplify +-- ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) + + ; let inner_wanted = wanteds { wc_simple = inner_simple } + ; implics <- if isEmptyWC inner_wanted + then return emptyBag + else do implic1 <- newImplication + return $ unitBag $ + implic1 { ic_tclvl = rhs_tclvl + , ic_skols = qtvs + , ic_given = full_theta_vars + , ic_wanted = inner_wanted + , ic_binds = ev_binds_var + , ic_given_eqs = MaybeGivenEqs + , ic_info = skol_info } + + ; emitConstraints (emptyWC { wc_simple = outer_simple + , wc_impl = implics }) } + +-------------------- +findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType +-- Given a partial type signature f :: (C a, D a, _) => blah +-- and the inferred constraints (X a, D a, Y a, C a) +-- compute the difference, which is what will fill in the "_" underscore, +-- In this case the diff is (X a, Y a). +findInferredDiff annotated_theta inferred_theta + | null annotated_theta -- Short cut the common case when the user didn't + = return inferred_theta -- write any constraints in the partial signature + | otherwise + = pushTcLevelM_ $ + do { lcl_env <- TcM.getLclEnv + ; given_ids <- mapM TcM.newEvVar annotated_theta + ; wanteds <- newWanteds AnnOrigin inferred_theta + ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + given_cts = mkGivens given_loc given_ids + + ; (residual_wc, _) <- runTcS $ + do { _ <- solveSimpleGivens given_cts + ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) } + -- NB: There are no meta tyvars fromn this level annotated_theta + -- because we have either promoted them or unified them + -- See `Note [Quantification and partial signatures]` Wrinkle 2 + + ; return (map (box_pred . ctPred) $ + bagToList (wc_simple residual_wc)) } + where + box_pred :: PredType -> PredType + box_pred pred = case classifyPredType pred of + EqPred rel ty1 ty2 + | Just (cls,tys) <- boxEqPred rel ty1 ty2 + -> mkClassPred cls tys + | otherwise + -> pprPanic "findInferredDiff" (ppr pred) + _other -> pred + +{- Note [Emitting the residual implication in simplifyInfer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = e +where f's type is inferred to be something like (a, Proxy k (Int |> co)) +and we have an as-yet-unsolved, or perhaps insoluble, constraint + [W] co :: Type ~ k +We can't form types like (forall co. blah), so we can't generalise over +the coercion variable, and hence we can't generalise over things free in +its kind, in the case 'k'. But we can still generalise over 'a'. So +we'll generalise to + f :: forall a. (a, Proxy k (Int |> co)) +Now we do NOT want to form the residual implication constraint + forall a. [W] co :: Type ~ k +because then co's eventual binding (which will be a value binding if we +use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose +type mentions 'co'). Instead, just as we don't generalise over 'co', we +should not bury its constraint inside the implication. Instead, we must +put it outside. + +That is the reason for the partitionBag in emitResidualConstraints, +which takes the CoVars free in the inferred type, and pulls their +constraints out. (NB: this set of CoVars should be closed-over-kinds.) + +All rather subtle; see #14584. + +Note [Add signature contexts as wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#11016): + f2 :: (?x :: Int) => _ + f2 = ?x + +or this + class C a b | a -> b + g :: C p q => p -> q + f3 :: C Int b => _ + f3 = g (3::Int) + +We'll use plan InferGen because there are holes in the type. But: + * For f2 we want to have the (?x :: Int) constraint floating around + so that the functional dependencies kick in. Otherwise the + occurrence of ?x on the RHS produces constraint (?x :: alpha), and + we won't unify alpha:=Int. + + * For f3 want the (C Int b) constraint from the partial signature + to meet the (C Int beta) constraint we get from the call to g; again, + fundeps + +Solution: in simplifyInfer, we add the constraints from the signature +as extra Wanteds. + +Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas +that would mess up (GivenInv) in Note [TcLevel invariants]. Consider + f :: (Eq a, _) => blah1 + f = ....g... + g :: (Eq b, _) => blah2 + g = ...f... + +Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with +TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved +all those constraints. And both have level 1, so we can't put them as +Givens when solving at level 1. + +Best to treat them as Wanteds. + +But see also #20076, which would be solved if they were Givens. + + +************************************************************************ +* * + Quantification +* * +************************************************************************ + +Note [Deciding quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the monomorphism restriction does not apply, then we quantify as follows: + +* Step 1: decidePromotedTyVars. + Take the global tyvars, and "grow" them using functional dependencies + E.g. if x:alpha is in the environment, and alpha ~ [beta] (which can + happen because alpha is untouchable here) then do not quantify over + beta, because alpha fixes beta, and beta is effectively free in + the environment too; this logic extends to general fundeps, not + just equalities + + We also account for the monomorphism restriction; if it applies, + add the free vars of all the constraints. + + Result is mono_tvs; we will promote all of these to the outer levek, + and certainly not quantify over them. + +* Step 2: defaultTyVarsAndSimplify. + Default any non-promoted tyvars (i.e ones that are definitely + not going to become further constrained), and re-simplify the + candidate constraints. + + Motivation for re-simplification (#7857): imagine we have a + constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are + not free in the envt, and instance forall (a::*) (b::*). (C a) => C + (a -> b) The instance doesn't match while l1,l2 are polymorphic, but + it will match when we default them to LiftedRep. + + This is all very tiresome. + + This step also promotes the mono_tvs from Step 1. See + Note [Promote monomorphic tyvars]. In fact, the *only* + use of the mono_tvs from Step 1 is to promote them here. + This promotion effectively stops us from quantifying over them + later, in Step 3. Because the actual variables to quantify + over are determined in Step 3 (not in Step 1), it is OK for + the mono_tvs to be missing some variables free in the + environment. This is why removing the psig_qtvs is OK in + decidePromotedTyVars. Test case for this scenario: T14479. + +* Step 3: decideQuantifiedTyVars. + Decide which variables to quantify over, as follows: + + - Take the free vars of the partial-type-signature types and constraints, + and the tau-type (zonked_tau_tvs), and then "grow" + them using all the constraints. These are grown_tcvs. + See Note [growThetaTyVars vs closeWrtFunDeps]. + + - Use quantifyTyVars to quantify over the free variables of all the types + involved, but only those in the grown_tcvs. + + Result is qtvs. + +* Step 4: Filter the constraints using pickQuantifiablePreds and the + qtvs. We have to zonk the constraints first, so they "see" the + freshly created skolems. + +Note [Unconditionally resimplify constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke +the solver to simplify the constraints before quantifying them. We do this for +two reasons, enumerated below. We could, in theory, detect when either of these +cases apply and simplify only then, but collecting this information is bothersome, +and simplifying redundantly causes no real harm. Note that this code path +happens only for definitions + * without a type signature + * when -XMonoLocalBinds does not apply + * with unsolved constraints +and so the performance cost will be small. + +1. Defaulting + +Defaulting the variables handled by defaultTyVar may unlock instance simplifications. +Example (typecheck/should_compile/T20584b): + + with (t :: Double) (u :: String) = printf "..." t u + +We know the types of t and u, but we do not know the return type of `with`. So, we +assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is + printf :: PrintfType r => String -> r +The occurrence of printf is instantiated with a fresh var beta. We then get + beta := Double -> String -> alpha +and + [W] PrintfType (Double -> String -> alpha) + +Module Text.Printf exports + instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) +and it looks like that instance should apply. + +But I have elided some key details: (->) is polymorphic over multiplicity and +runtime representation. Here it is in full glory: + [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho)) + instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type)) + +Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance +would have an explicit equality constraint to the left of =>, but that's not what we have.) +Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep. +Yet it's too late to simplify the quantified constraint, and thus GHC infers + wait :: PrintfType (Double -> String -> t) => Double -> String -> t +which is silly. Simplifying again after defaulting solves this problem. + +2. Interacting functional dependencies + +Suppose we have + + class C a b | a -> b + +and we are running simplifyInfer over + + forall[2] x. () => [W] C a beta1[1] + forall[2] y. () => [W] C a beta2[1] + +These are two implication constraints, both of which contain a +wanted for the class C. Neither constraint mentions the bound +skolem. We might imagine that these constraints could thus float +out of their implications and then interact, causing beta1 to unify +with beta2, but constraints do not currently float out of implications. + +Unifying the beta1 and beta2 is important. Without doing so, then we might +infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the +ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as +required by the fundep interactions. This happens in the parsec library, and +in test case typecheck/should_compile/FloatFDs. + +If we re-simplify, however, the two fundep constraints will interact, causing +a unification between beta1 and beta2, and all will be well. The key step +is that this simplification happens *after* the call to approximateWC in +simplifyInfer. + +-} + +decideQuantification + :: TopLevelFlag + -> TcLevel + -> InferMode + -> SkolemInfoAnon + -> [(Name, TcTauType)] -- Variables to be generalised + -> [TcIdSigInst] -- Partial type signatures (if any) + -> WantedConstraints -- Candidate theta; already zonked + -> TcM ( [TcTyVar] -- Quantify over these (skolems) + , [PredType] -- and this context (fully zonked) + , CoVarSet) +-- See Note [Deciding quantification] +decideQuantification top_lvl rhs_tclvl infer_mode skol_info name_taus psigs wanted + = do { -- Step 1: find the mono_tvs + ; (candidates, co_vars) + <- decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted + + -- Step 2: default any non-mono tyvars, and re-simplify + -- This step may do some unification, but result candidates is zonked + ; candidates <- defaultTyVarsAndSimplify rhs_tclvl candidates + + -- Step 3: decide which kind/type variables to quantify over + ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates + + -- Step 4: choose which of the remaining candidate + -- predicates to actually quantify over + -- NB: decideQuantifiedTyVars turned some meta tyvars + -- into quantified skolems, so we have to zonk again + ; (candidates, psig_theta) <- TcM.liftZonkM $ + do { candidates <- TcM.zonkTcTypes candidates + ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) + ; return (candidates, psig_theta) } + + -- Take account of partial type signatures + -- See Note [Constraints in partial type signatures] + ; let min_psig_theta = mkMinimalBySCs id psig_theta + min_theta = pickQuantifiablePreds (mkVarSet qtvs) candidates + ; theta <- if + | null psigs -> return min_theta -- Case (P3) + | not (all has_extra_constraints_wildcard psigs) -- Case (P2) + -> return min_psig_theta + | otherwise -- Case (P1) + -> do { diff <- findInferredDiff min_psig_theta min_theta + ; return (min_psig_theta ++ diff) } + + ; traceTc "decideQuantification" + (vcat [ text "infer_mode:" <+> ppr infer_mode + , text "candidates:" <+> ppr candidates + , text "psig_theta:" <+> ppr psig_theta + , text "co_vars:" <+> ppr co_vars + , text "qtvs:" <+> ppr qtvs + , text "theta:" <+> ppr theta ]) + ; return (qtvs, theta, co_vars) } + + where + has_extra_constraints_wildcard (TISI { sig_inst_wcx = Just {} }) = True + has_extra_constraints_wildcard _ = False + +{- Note [Constraints in partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have decided to quantify over min_theta, say (Eq a, C a, Ix a). +Then we distinguish three cases: + +(P1) No partial type signatures: just quantify over min_theta + +(P2) Partial type signatures with no extra_constraints wildcard: + e.g. f :: (Eq a, C a) => a -> _ + Quantify over psig_theta: the user has explicitly specified the + entire context. + + That may mean we have an unsolved residual constraint (Ix a) arising + from the RHS of the function. But so be it: the user said (Eq a, C a). + +(P3) Partial type signature with an extra_constraints wildcard. + e.g. f :: (Eq a, C a, _) => a -> a + Quantify over (psig_theta ++ diff) + where diff = min_theta - psig_theta, using findInferredDiff. + In our example, diff = Ix a + +Some rationale and observations + +* See Note [When the MR applies] in GHC.Tc.Gen.Bind. + +* We always want to quantify over psig_theta (if present). The user specified + it! And pickQuantifiableCandidates might have dropped some + e.g. CallStack constraints. c.f #14658 + equalities (a ~ Bool) + +* In case (P3) we ask that /all/ the signatures have an extra-constraints + wildcard. It's a bit arbitrary; not clear what the "right" thing is. + +* In (P2) we encounter #20076: + f :: Eq [a] => a -> _ + f x = [x] == [x] + From the RHS we get [W] Eq [a]. We simplify those Wanteds in simplifyInfer, + to get (Eq a). But then we quantify over the user-specified (Eq [a]), leaving + a residual implication constraint (forall a. Eq [a] => [W] Eq a), which is + insoluble. Idea: in simplifyInfer we could put the /un-simplified/ constraints + in the residual -- at least in the case like #20076 where the partial signature + fully specifies the final constraint. Maybe: a battle for another day. + +* It's helpful to use the same "find difference" algorithm, `findInferredDiff`, + here as we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) + + At least for single functions we would like to quantify f over precisely the + same theta as , so that we get to take the short-cut path in + `GHC.Tc.Gen.Bind.mkExport`, and avoid calling `tcSubTypeSigma` for impedance + matching. Why avoid? Because it falls over for ambiguous types (#20921). + + We can get precisely the same theta by using the same algorithm, + `findInferredDiff`. + +* All of this goes wrong if we have (a) mutual recursion, (b) multiple + partial type signatures, (c) with different constraints, and (d) + ambiguous types. Something like + f :: forall a. Eq a => F a -> _ + f x = (undefined :: a) == g x undefined + g :: forall b. Show b => F b -> _ -> b + g x y = let _ = (f y, show x) in x + But that's a battle for another day. + +Note [Generalising top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class C a b | a -> b where .. + f x = ...[W] C Int beta[1]... + +When generalising `f`, closeWrtFunDeps will promote beta[1] to beta[0]. +But we do NOT want to make a top level type + f :: C Int beta[0] => blah +The danger is that beta[0] is defaulted to Any, and that then appears +in a user error message. Even if the type `blah` mentions beta[0], /and/ +there is a call that fixes beta[0] to (say) Bool, we'll end up with +[W] C Int Bool, which is insoluble. Why insoluble? If there was an + instance C Int Bool +then fundeps would have fixed beta:=Bool in the first place. + +If the binding of `f` is nested, things are different: we can +definitely see all the calls. + +For nested bindings, I think it just doesn't matter. No one cares what this +variable ends up being; it seems silly to halt compilation around it. (Like in +the length [] case.) +-} + +decideAndPromoteTyVars :: TopLevelFlag -> TcLevel + -> InferMode + -> [(Name,TcType)] + -> [TcIdSigInst] + -> WantedConstraints + -> TcM ([PredType], CoVarSet) +-- See Note [decideAndPromoteTyVars] +decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted + = do { dflags <- getDynFlags + + -- If possible, we quantify over partial-sig qtvs, so they are + -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs + ; (psig_qtvs, psig_theta, tau_tys) <- getSeedTys name_taus psigs + + ; let is_top_level = isTopLevel top_lvl -- A syntactically top-level binding + + -- Step 1 of Note [decideAndPromoteTyVars] + -- Get candidate constraints, decide which we can potentially quantify + -- The `no_quant_tvs` are free in constraints we can't quantify. + (can_quant_cts, no_quant_tvs) = approximateWCX False wanted + can_quant = ctsPreds can_quant_cts + can_quant_tvs = tyCoVarsOfTypes can_quant + + -- Step 2 of Note [decideAndPromoteTyVars] + -- Apply the monomorphism restriction + (post_mr_quant, mr_no_quant) = applyMR dflags infer_mode can_quant + mr_no_quant_tvs = tyCoVarsOfTypes mr_no_quant + + -- The co_var_tvs are tvs mentioned in the types of covars or + -- coercion holes. We can't quantify over these covars, so we + -- must include the variable in their types in the mono_tvs. + -- E.g. If we can't quantify over co :: k~Type, then we can't + -- quantify over k either! Hence closeOverKinds + -- Recall that coVarsOfTypes also returns coercion holes + co_vars = coVarsOfTypes (mkTyVarTys psig_qtvs ++ psig_theta + ++ tau_tys ++ post_mr_quant) + co_var_tvs = closeOverKinds co_vars + + -- outer_tvs are mentioned in `wanted`, and belong to some outer level. + -- We definitely can't quantify over them + outer_tvs = outerLevelTyVars rhs_tclvl $ + can_quant_tvs `unionVarSet` no_quant_tvs + + -- Step 3 of Note [decideAndPromoteTyVars], (a-c) + -- Identify mono_tvs: the type variables that we must not quantify over + -- At top level we are much less keen to create mono tyvars, to avoid + -- spooky action at a distance. + mono_tvs_without_mr + | is_top_level = outer_tvs -- See (DP2) + | otherwise = outer_tvs -- (a) + `unionVarSet` no_quant_tvs -- (b) + `unionVarSet` co_var_tvs -- (c) + + -- Step 3 of Note [decideAndPromoteTyVars], (d) + mono_tvs_with_mr + = -- Even at top level, we don't quantify over type variables + -- mentioned in constraints that the MR tells us not to quantify + -- See Note [decideAndPromoteTyVars] (DP2) + mono_tvs_without_mr `unionVarSet` mr_no_quant_tvs + + -------------------------------------------------------------------- + -- Step 4 of Note [decideAndPromoteTyVars] + -- Use closeWrtFunDeps to find any other variables that are determined by mono_tvs + add_determined tvs preds = closeWrtFunDeps preds tvs + `delVarSetList` psig_qtvs + -- Why delVarSetList psig_qtvs? + -- If the user has explicitly asked for quantification, then that + -- request "wins" over the MR. + -- + -- What if a psig variable is also free in the environment + -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation + -- in Step 2 of Note [Deciding quantification]. + + mono_tvs_with_mr_det = add_determined mono_tvs_with_mr post_mr_quant + mono_tvs_without_mr_det = add_determined mono_tvs_without_mr can_quant + + -------------------------------------------------------------------- + -- Step 5 of Note [decideAndPromoteTyVars] + -- Do not quantify over any constraint mentioning a "newly-mono" tyvar. + newly_mono_tvs = mono_tvs_with_mr_det `minusVarSet` mono_tvs_with_mr + final_quant + | is_top_level = filterOut (predMentions newly_mono_tvs) post_mr_quant + | otherwise = post_mr_quant + + -------------------------------------------------------------------- + -- Check if the Monomorphism Restriction has bitten + ; warn_mr <- woptM Opt_WarnMonomorphism + ; when (warn_mr && case infer_mode of { ApplyMR -> True; _ -> False}) $ + diagnosticTc (not (mono_tvs_with_mr_det `subVarSet` mono_tvs_without_mr_det)) $ + TcRnMonomorphicBindings (map fst name_taus) + -- If there is a variable in mono_tvs, but not in mono_tvs_wo_mr + -- then the MR has "bitten" and reduced polymorphism. + + -------------------------------------------------------------------- + -- Step 6: Promote the mono_tvs: see Note [Promote monomorphic tyvars] + ; _ <- promoteTyVarSet mono_tvs_with_mr_det + + ; traceTc "decideAndPromoteTyVars" $ vcat + [ text "rhs_tclvl =" <+> ppr rhs_tclvl + , text "top =" <+> ppr is_top_level + , text "infer_mode =" <+> ppr infer_mode + , text "psigs =" <+> ppr psigs + , text "psig_qtvs =" <+> ppr psig_qtvs + , text "outer_tvs =" <+> ppr outer_tvs + , text "mono_tvs_with_mr =" <+> ppr mono_tvs_with_mr + , text "mono_tvs_without_mr =" <+> ppr mono_tvs_without_mr + , text "mono_tvs_with_mr_det =" <+> ppr mono_tvs_with_mr_det + , text "mono_tvs_without_mr_det =" <+> ppr mono_tvs_without_mr_det + , text "newly_mono_tvs =" <+> ppr newly_mono_tvs + , text "can_quant =" <+> ppr can_quant + , text "post_mr_quant =" <+> ppr post_mr_quant + , text "no_quant_tvs =" <+> ppr no_quant_tvs + , text "mr_no_quant =" <+> ppr mr_no_quant + , text "final_quant =" <+> ppr final_quant + , text "co_vars =" <+> ppr co_vars ] + + ; return (final_quant, co_vars) } + -- We return `co_vars` that appear free in the final quantified types + -- we can't quantify over these, and we must make sure they are in scope + +------------------- +applyMR :: DynFlags -> InferMode -> [PredType] + -> ( [PredType] -- Quantify over these + , [PredType] ) -- But not over these +-- Split the candidates into ones we definitely +-- won't quantify, and ones that we might +applyMR _ NoRestrictions cand = (cand, []) +applyMR _ ApplyMR cand = ([], cand) +applyMR dflags EagerDefaulting cand = partition not_int_ct cand + where + ovl_strings = xopt LangExt.OverloadedStrings dflags + + -- not_int_ct returns True for a constraint we /can/ quantify + -- For EagerDefaulting, do not quantify over + -- over any interactive class constraint + not_int_ct pred + = case classifyPredType pred of + ClassPred cls _ -> not (isInteractiveClass ovl_strings cls) + _ -> True + +------------------- +outerLevelTyVars :: TcLevel -> TcTyVarSet -> TcTyVarSet +-- Find just the tyvars that are bound outside rhs_tc_lvl +outerLevelTyVars rhs_tclvl tvs + = filterVarSet is_outer_tv tvs + where + is_outer_tv tcv + | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately + = rhs_tclvl `strictlyDeeperThan` tcTyVarLevel tcv + | otherwise + = False + +{- Note [decideAndPromoteTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are about to generalise a let-binding at "outer level" N, where we have +typechecked its RHS at "rhs level" N+1. Each tyvar must be either + (P) promoted + (D) defaulted + (Q) quantified +The function `decideAndPromoteTyVars` figures out (P), the type variables +mentioned in constraints should definitely not be quantified, and promotes them +to the outer level, namely N. + +The plan + +* Step 1. Use `approximateWCX` to extract, from the RHS `WantedConstraints`, + the PredTypes that we might quantify over; and also those that we can't. + Example: suppose the `wanted` is this: + (d1:Eq alpha, forall b. (F b ~ a) => (co:t1 ~ t2), (d:Show alpha)) + Then + can_quant = [Eq alpha, Show alpha] + no_quant = (t1 ~ t2) + We can't quantify over that (t1~t2) because of the enclosing equality (F b ~ a). + + We also choose never to quantify over some forms of equality constraints. + Both this and the "given-equality" thing are described in + Note [Quantifying over equality constraints] in GHC.Tc.Types.Constraint. + +* Step 2. Further trim can_quant using the Monomorphism Restriction, yielding the + further `mr_no_quant` predicates that we won't quantify over; plus `post_mr_quant`, + which we can in principle quantify. + +* Step 3. Identify the type variables we definitely won't quantify, because they are: + a) From an outer level <=N anyway + b) Mentioned in a constraint we /can't/ quantify. See Wrinkle (DP1). + c) Mentioned in the kind of a CoVar; we can't quantify over a CoVar, + so we must not quantify over a type variable free in its kind + d) Mentioned in a constraint that the MR says we should not quantify. + + There is a special case for top-level bindings: see Wrinkle (DP2). + +* Step 4. Close wrt functional dependencies and equalities.Example + Example + f x y = ... + where z = x 3 + The body of z tries to unify the type of x (call it alpha[1]) with + (beta[2] -> gamma[2]). This unification fails because alpha is untouchable, leaving + [W] alpha[1] ~ (beta[2] -> gamma[2]) + We don't want to quantify over beta or gamma because they are fixed by alpha, + which is monomorphic. Actual test case: typecheck/should_compile/tc213 + + Another example. Suppose we have + class C a b | a -> b + and a constraint ([W] C alpha beta), if we promote alpha we should promote beta. + + See also Note [growThetaTyVars vs closeWrtFunDeps] + +* Step 5. Further restrict the quantifiable constraints `post_mr_quant` to ones + that do not mention a "newly mono" tyvar. The "newly-mono" tyvars are the ones + not free in the envt, nor forced to be promoted by the MR; but are determined + (via fundeps) by them. Example: + class C a b | a -> b + [W] C Int beta[1], tau = beta[1]->Int + We promote beta[1] to beta[0] since it is determined by fundep, but we do not + want to generate f :: (C Int beta[0]) => beta[0] -> Int Rather, we generate + f :: beta[0] -> Int, but leave [W] C Int beta[0] in the residual constraints, + which will probably cause a type error + + See Note [Do not quantify over constraints that determine a variable] + +* Step 6: actually promote the type variables we don't want to quantify. + We must do this: see Note [Promote monomorphic tyvars]. + +We also add a warning that signals when the MR "bites". + +Wrinkles + +(DP1) In step 3, why (b)? Consider the example given in Step 1. we can't + quantify over the constraint (t1~t2). But if we quantify over the /tyvars/ in + t1 or t2, we may simply make that constraint insoluble (#25266 was an example). + +(DP2) In Step 3, for top-level bindings, we do (a,d), but /not/ (b,c). Reason: + see Note [The top-level Any principle]. At top level we are very reluctant to + promote type variables. But for bindings affected by the MR we have no choice + but to promote. + + An example is in #26004. + f w e = case e of + T1 -> let y = not w in False + T2 -> True + When generalising `f` we have a constraint + forall. (a ~ Bool) => alpha ~ Bool + where our provisional type for `f` is `f :: T alpha -> blah`. + In a /nested/ setting, we might simply not-generalise `f`, hoping to learn + about `alpha` from f's call sites (test T5266b is an example). But at top + level, to avoid spooky action at a distance. + +Note [The top-level Any principle] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Key principles: + * we never want to show the programmer a type with `Any` in it. + * avoid "spooky action at a distance" and silent defaulting + +Most /top level/ bindings have a type signature, so none of this arises. But +where a top-level binding lacks a signature, we don't want to infer a type like + f :: alpha[0] -> Int +and then subsequently default alpha[0]:=Any. Exposing `Any` to the user is bad +bad bad. Better to report an error, which is what may well happen if we +quantify over alpha instead. + +Moreover, + * If (elsewhere in this module) we add a call to `f`, say (f True), then + `f` will get the type `Bool -> Int` + * If we add /another/ call, say (f 'x'), we will then get a type error. + * If we have no calls, the final exported type of `f` may get set by + defaulting, and might not be principal (#26004). + +For /nested/ bindings, a monomorphic type like `f :: alpha[0] -> Int` is fine, +because we can see all the call sites of `f`, and they will probably fix +`alpha`. In contrast, we can't see all of (or perhaps any of) the calls of +top-level (exported) functions, reducing the worries about "spooky action at a +distance". This also moves in the direction of `MonoLocalBinds`, which we like. + +Note [Do not quantify over constraints that determine a variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/tc231), where we're trying to infer +the type of a top-level declaration. We have + class Zork s a b | a -> b +and the candidate constraint at the end of simplifyInfer is + [W] Zork alpha[1] (Z [Char]) beta[1] +We definitely want to quantify over `alpha` (which is mentioned in the +tau-type). + +But we do *not* want to quantify over `beta`: it is determined by the +functional dependency on Zork: note that the second argument to Zork +in the Wanted is a variable-free `Z [Char]`. Quantifying over it +would be "Henry Ford polymorphism". (Presumably we don't have an +instance in scope that tells us what `beta` actually is.) Instead +we promote `beta[1]` to `beta[0]`, in `decidePromotedTyVars`. + +The question here: do we want to quantify over the constraint, to +give the type + forall a. Zork a (Z [Char]) beta[0] => blah +Definitely not: see Note [The top-level Any principle] + +What we really want (to catch the Zork example) is this: + + Quantify over the constraint only if all its free variables are + (a) quantified, or + (b) appears in the type of something in the environment (mono_tvs0). + +To understand (b) consider + + class C a b where { op :: a -> b -> () } + + mr = 3 -- mr :: alpha + f1 x = op x mr -- f1 :: forall b. b -> (), plus [W] C b alpha + intify = mr + (4 :: Int) + +In `f1` should we quantify over that `(C b alpha)`? Answer: since `alpha` is +free in the type envt, yes we should. After all, if we'd typechecked `intify` +first, we'd have set `alpha := Int`, and /then/ we'd certainly quantify. The +delicate Zork situation applies when beta is completely unconstrained (not free +in the environment) -- except by the fundep. Hence `newly_mono`. + +Another way to put it: let's say `alpha` is in `outer_tvs`. It must be that +some variable `x` has `alpha` free in its type. If we are at top-level (and we +are, because nested decls don't go through this path all), then `x` must also +be at top-level. And, by induction, `x` will not have Any in its type when all +is said and done. The induction is well-founded because, if `x` is mutually +recursive with the definition at hand, then their constraints get processed +together (or `x` has a type signature, in which case the type doesn't have +`Any`). So the key thing is that we must not introduce a new top-level +unconstrained variable here. + +However this regrettably-subtle reasoning is needed only for /top-level/ +declarations. For /nested/ decls we can see all the calls, so we'll instantiate +that quantifed `Zork a (Z [Char]) beta` constraint at call sites, and either +solve it or not (probably not). We won't be left with a still-callable function +with Any in its type. So for nested definitions we don't make this tricky test. + +Historical note: we had a different, and more complicated test before, but it +was utterly wrong: #23199. + +Note [Promote monomorphic tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Promote any type variables that are free in the environment. Eg + f :: forall qtvs. bound_theta => zonked_tau +The free vars of f's type become free in the envt, and hence will show +up whenever 'f' is called. They may currently at rhs_tclvl, but they +had better be unifiable at the outer_tclvl! Example: envt mentions +alpha[1] + tau_ty = beta[2] -> beta[2] + constraints = alpha ~ [beta] +we don't quantify over beta (since it is fixed by envt) +so we must promote it! The inferred type is just + f :: beta -> beta + +NB: promoteTyVarSet ignores coercion variables + +Note [Defaulting during simplifyInfer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are inferring a type, we simplify the constraint, and then use +approximateWC to produce a list of candidate constraints. Then we MUST + + a) Promote any meta-tyvars that have been floated out by + approximateWC, to restore invariant (WantedInv) described in + Note [TcLevel invariants] in GHC.Tc.Utils.TcType. + + b) Default the kind of any meta-tyvars that are not mentioned in + in the environment. + +To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we +have an instance (C ((x:*) -> Int)). The instance doesn't match -- but it +should! If we don't solve the constraint, we'll stupidly quantify over +(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over +(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332. +#7641 is a simpler example. + +-} + +------------------- +defaultTyVarsAndSimplify :: TcLevel + -> [PredType] -- Assumed zonked + -> TcM [PredType] -- Guaranteed zonked +-- Default any tyvar free in the constraints; +-- and re-simplify in case the defaulting allows further simplification +-- See Note [Defaulting during simplifyInfer] +defaultTyVarsAndSimplify rhs_tclvl candidates + = do { -- Default any kind/levity vars + ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} + <- candidateQTyVarsOfTypes candidates + -- NB1: decidePromotedTyVars has promoted any type variable fixed by the + -- type envt, so they won't be chosen by candidateQTyVarsOfTypes + -- NB2: Defaulting for variables free in tau_tys is done later, by quantifyTyVars + -- Hence looking only at 'candidates' + -- NB3: Any covars should already be handled by + -- the logic in decidePromotedTyVars, which looks at + -- the constraints generated + + ; poly_kinds <- xoptM LangExt.PolyKinds + ; let default_kv | poly_kinds = default_tv + | otherwise = defaultTyVar DefaultKindVars + default_tv = defaultTyVar (NonStandardDefaulting DefaultNonStandardTyVars) + ; mapM_ default_kv (dVarSetElems cand_kvs) + ; mapM_ default_tv (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) + + ; simplify_cand candidates + } + where + -- See Note [Unconditionally resimplify constraints when quantifying] + simplify_cand [] = return [] -- Fast path + simplify_cand candidates + = do { clone_wanteds <- newWanteds DefaultOrigin candidates + ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $ + simplifyWantedsTcM clone_wanteds + -- Discard evidence; simples is fully zonked + + ; let new_candidates = ctsPreds simples + ; traceTc "Simplified after defaulting" $ + vcat [ text "Before:" <+> ppr candidates + , text "After:" <+> ppr new_candidates ] + ; return new_candidates } + +------------------ +decideQuantifiedTyVars + :: SkolemInfoAnon + -> [(Name,TcType)] -- Annotated theta and (name,tau) pairs + -> [TcIdSigInst] -- Partial signatures + -> [PredType] -- Candidates, zonked + -> TcM [TyVar] +-- Fix what tyvars we are going to quantify over, and quantify them +decideQuantifiedTyVars skol_info_anon name_taus psigs candidates + = do { -- Why psig_tys? We try to quantify over everything free in here + -- See Note [Quantification and partial signatures] + -- Wrinkles 2 and 3 + (psig_qtvs, psig_theta, tau_tys) <- getSeedTys name_taus psigs + + ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta + seed_tvs = tyCoVarsOfTypes (psig_tys ++ tau_tys) + + -- "Grow" those seeds to find ones reachable via 'candidates' + -- See Note [growThetaTyVars vs closeWrtFunDeps] + grown_tcvs = growThetaTyVars candidates seed_tvs + + -- Now we have to classify them into kind variables and type variables + -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars + -- + -- The psig_tys are first in seed_tys, then candidates, then tau_tvs. + -- This makes candidateQTyVarsOfTypes produces them in that order, so that the + -- final qtvs quantifies in the same- order as the partial signatures do (#13524) + ; dvs <- candidateQTyVarsOfTypes (psig_tys ++ candidates ++ tau_tys) + ; let dvs_plus = weedOutCandidates (`dVarSetIntersectVarSet` grown_tcvs) dvs + + ; traceTc "decideQuantifiedTyVars" (vcat + [ text "tau_tys =" <+> ppr tau_tys + , text "candidates =" <+> ppr candidates + , text "dvs =" <+> ppr dvs + , text "tau_tys =" <+> ppr tau_tys + , text "seed_tvs =" <+> ppr seed_tvs + , text "grown_tcvs =" <+> ppr grown_tcvs + , text "dvs =" <+> ppr dvs_plus]) + + ; skol_info <- mkSkolemInfo skol_info_anon + ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus } + +------------------ +getSeedTys :: [(Name,TcType)] -- The type of each RHS in the group + -> [TcIdSigInst] -- Any partial type signatures + -> TcM ( [TcTyVar] -- Zonked partial-sig quantified tyvars + , ThetaType -- Zonked partial signature thetas + , [TcType] ) -- Zonked tau-tys from the bindings +getSeedTys name_taus psigs + = TcM.liftZonkM $ + do { psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | TISI{ sig_inst_skols = skols } <- psigs + , (_, Bndr tv _) <- skols ] + ; psig_theta <- mapM TcM.zonkTcType [ pred | TISI{ sig_inst_theta = theta } <- psigs + , pred <- theta ] + ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus + ; return ( map getTyVar psig_tv_tys + , psig_theta + , tau_tys ) } + +------------------ +predMentions :: TcTyVarSet -> TcPredType -> Bool +predMentions qtvs pred = tyCoVarsOfType pred `intersectsVarSet` qtvs + +-- | When inferring types, should we quantify over a given predicate? +-- See Note [pickQuantifiablePreds] +pickQuantifiablePreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- This function decides whether a particular constraint should be +-- quantified over, given the type variables that are being quantified +pickQuantifiablePreds qtvs theta + = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] + mapMaybe pick_me theta + where + pick_me pred + = case classifyPredType pred of + ClassPred cls _ + | isIPClass cls + -> Just pred -- Pick, say, (?x::Int) whether or not it mentions qtvs + -- See Note [Inheriting implicit parameters] + + EqPred eq_rel ty1 ty2 + | predMentions qtvs pred + , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 + -- boxEqPred: See Note [Lift equality constraints when quantifying] + -> Just (mkClassPred cls tys) + | otherwise + -> Nothing + + _ | predMentions qtvs pred -> Just pred + | otherwise -> Nothing + +------------------ +growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet +-- See Note [growThetaTyVars vs closeWrtFunDeps] +growThetaTyVars theta tcvs + | null theta = tcvs + | otherwise = transCloVarSet mk_next seed_tcvs + where + seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips + (ips, non_ips) = partition couldBeIPLike theta + -- See Note [Inheriting implicit parameters] + + mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones + mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips + grow_one so_far pred tcvs + | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs + | otherwise = tcvs + where + pred_tcvs = tyCoVarsOfType pred + + +{- Note [pickQuantifiablePreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pickQuantifiablePreds is called we have decided what type +variables to quantify over, `qtvs`. The only quesion is: which of the +unsolved candidate predicates should we quantify over? Call them +`picked_theta`. + +Note that will leave behind a residual implication + forall qtvs. picked_theta => unsolved_constraints +For the members of unsolved_constraints that we select for picked_theta +it is easy to solve, by identity. For the others we just hope that +we can solve them. + +So which of the candidates should we pick to quantify over? It's pretty easy: + +* Never pick a constraint that doesn't mention any of the quantified + variables `qtvs`. Picking such a constraint essentially moves the solving of + the constraint from this function definition to call sites. But because the + constraint mentions no quantified variables, call sites have no advantage + over the definition site. Well, not quite: there could be new constraints + brought into scope by a pattern-match against a constrained (e.g. GADT) + constructor. Example + + data T a where { T1 :: T1 Bool; ... } + + f :: forall a. a -> T a -> blah + f x t = let g y = x&&y -- This needs a~Bool + in case t of + T1 -> g True + .... + + At g's call site we have `a~Bool`, so we /could/ infer + g :: forall . (a~Bool) => Bool -> Bool -- qtvs = {} + + This is all very contrived, and probably just postponse type errors to + the call site. If that's what you want, write a type signature. + +* Implicit parameters is an exception to the "no quantified vars" + rule (see Note [Inheriting implicit parameters]) so we can't actually + simply test this case first. + +* Finally, we may need to "box" equality predicates: if we want to quantify + over `a ~# b`, we actually quantify over the boxed version, `a ~ b`. + See Note [Lift equality constraints when quantifying]. + +Notice that we do /not/ consult -XFlexibleContexts here. For example, +we allow `pickQuantifiablePreds` to quantify over a constraint like +`Num [a]`; then if we don't have `-XFlexibleContexts` we'll get an +error from `checkValidType` but (critically) it includes the helpful +suggestion of adding `-XFlexibleContexts`. See #10608, #10351. + +Note [Lift equality constraints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't quantify over a constraint (t1 ~# t2) because that isn't a +predicate type; see Note [Types for coercions, predicates, and evidence] +in GHC.Core.Predicate + +So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted +to Coercible. + +This tiresome lifting is the reason that pick_me (in +pickQuantifiablePreds) returns a Maybe rather than a Bool. + +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See pickQuantifiablePreds. + +Note [Quantification and partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When choosing type variables to quantify, the basic plan is to +quantify over all type variables that are + * free in the tau_tvs, and + * not forced to be monomorphic (mono_tvs), + for example by being free in the environment. + +However, in the case of a partial type signature, we are doing inference +*in the presence of a type signature*. For example: + f :: _ -> a + f x = ... +or + g :: (Eq _a) => _b -> _b +In both cases we use plan InferGen, and hence call simplifyInfer. But +those 'a' variables are skolems (actually TyVarTvs), and we should be +sure to quantify over them. This leads to several wrinkles: + +* Wrinkle 1. In the case of a type error + f :: _ -> Maybe a + f x = True && x + The inferred type of 'f' is f :: Bool -> Bool, but there's a + left-over error of form (Maybe a ~ Bool). The error-reporting + machine expects to find a binding site for the skolem 'a', so we + add it to the quantified tyvars. + +* Wrinkle 2. Consider the partial type signature + f :: (Eq _) => Int -> Int + f x = x + In normal cases that makes sense; e.g. + g :: Eq _a => _a -> _a + g x = x + where the signature makes the type less general than it could + be. But for 'f' we must therefore quantify over the user-annotated + constraints, to get + f :: forall a. Eq a => Int -> Int + (thereby correctly triggering an ambiguity error later). If we don't + we'll end up with a strange open type + f :: Eq alpha => Int -> Int + which isn't ambiguous but is still very wrong. + + Bottom line: Try to quantify over any variable free in psig_theta, + just like the tau-part of the type. + +* Wrinkle 3 (#13482). Also consider + f :: forall a. _ => Int -> Int + f x = if (undefined :: a) == undefined then x else 0 + Here we get an (Eq a) constraint, but it's not mentioned in the + psig_theta nor the type of 'f'. But we still want to quantify + over 'a' even if the monomorphism restriction is on. + +* Wrinkle 4 (#14479) + foo :: Num a => a -> a + foo xxx = g xxx + where + g :: forall b. Num b => _ -> b + g y = xxx + y + + In the signature for 'g', we cannot quantify over 'b' because it turns out to + get unified with 'a', which is free in g's environment. So we carefully + refrain from bogusly quantifying, in GHC.Tc.Solver.decidePromotedTyVars. We + report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Note [growThetaTyVars vs closeWrtFunDeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with +the same type and similar behavior. This Note outlines the differences +and why we use one or the other. + +Both functions take a list of constraints. We will call these the +*candidates*. + +closeWrtFunDeps takes a set of "determined" type variables and finds the +closure of that set with respect to the functional dependencies +within the class constraints in the set of candidates. So, if we +have + + class C a b | a -> b + class D a b -- no fundep + candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)} + +then closeWrtFunDeps {a} will return the set {a,b,c}. +This is because, if `a` is determined, then `b` and `c` are, too, +by functional dependency. closeWrtFunDeps called with any seed set not including +`a` will just return its argument, as only `a` determines any other +type variable (in this example). + +growThetaTyVars operates similarly, but it behaves as if every +constraint has a functional dependency among all its arguments. +So, continuing our example, growThetaTyVars {a} will return +{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of +variables to include all variables that are mentioned in the same +constraint (transitively). + +We use closeWrtFunDeps in places where we need to know which variables are +*always* determined by some seed set. This includes + * when determining the mono-tyvars in decidePromotedTyVars. If `a` + is going to be monomorphic, we need b and c to be also: they + are determined by the choice for `a`. + * when checking instance coverage, in + GHC.Tc.Instance.FunDeps.checkInstCoverage + +On the other hand, we use growThetaTyVars where we need to know +which variables *might* be determined by some seed set. This includes + * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers + and decideQuantifiedTyVars +How can `a` determine (say) `d` in the example above without a fundep? +Suppose we have + instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c) +Now, if `a` turns out to be a list, it really does determine b and c. +The danger in overdoing quantification is the creation of an ambiguous +type signature, but this is conveniently caught in the validity checker. + +Note [Quantification with errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find that the RHS of the definition has some absolutely-insoluble +constraints (including especially "variable not in scope"), we + +* Abandon all attempts to find a context to quantify over, + and instead make the function fully-polymorphic in whatever + type we have found + +* Return a flag from simplifyInfer, indicating that we found an + insoluble constraint. This flag is used to suppress the ambiguity + check for the inferred type, which may well be bogus, and which + tends to obscure the real error. This fix feels a bit clunky, + but I failed to come up with anything better. + +Reasons: + - Avoid downstream errors + - Do not perform an ambiguity test on a bogus type, which might well + fail spuriously, thereby obfuscating the original insoluble error. + #14000 is an example + +I tried an alternative approach: simply failM, after emitting the +residual implication constraint; the exception will be caught in +GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type +(forall a. a). But that didn't work with -fdefer-type-errors, because +the recovery from failM emits no code at all, so there is no function +to run! But -fdefer-type-errors aspires to produce a runnable program. + +Note [Default while Inferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our current plan is that defaulting only happens at simplifyTop and +not simplifyInfer. This may lead to some insoluble deferred constraints. +Example: + +instance D g => C g Int b + +constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha +type inferred = gamma -> gamma + +Now, if we try to default (alpha := Int) we will be able to refine the implication to + (forall b. 0 => C gamma Int b) +which can then be simplified further to + (forall b. 0 => D gamma) +Finally, we /can/ approximate this implication with (D gamma) and infer the quantified +type: forall g. D g => g -> g + +Instead what will currently happen is that we will get a quantified type +(forall g. g -> g) and an implication: + forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha + +Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an +unsolvable implication: + forall g. 0 => (forall b. 0 => D g) + +The concrete example would be: + h :: C g a s => g -> a -> ST s a + f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1) + +But it is quite tedious to do defaulting and resolve the implication constraints, and +we have not observed code breaking because of the lack of defaulting in inference, so +we don't do it for now. + +Note [Minimize by Superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we quantify over a constraint, in simplifyInfer we need to +quantify over a constraint that is minimal in some sense: For +instance, if the final wanted constraint is (Eq alpha, Ord alpha), +we'd like to quantify over Ord alpha, because we can just get Eq alpha +from superclass selection from Ord alpha. This minimization is what +mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint +to check the original wanted. + + +Note [Avoid unnecessary constraint simplification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -------- NB NB NB (Jun 12) ------------- + This note not longer applies; see the notes with #4361. + But I'm leaving it in here so we remember the issue.) + ---------------------------------------- +When inferring the type of a let-binding, with simplifyInfer, +try to avoid unnecessarily simplifying class constraints. +Doing so aids sharing, but it also helps with delicate +situations like + + instance C t => C [t] where .. + + f :: C [t] => .... + f x = let g y = ...(constraint C [t])... + in ... +When inferring a type for 'g', we don't want to apply the +instance decl, because then we can't satisfy (C t). So we +just notice that g isn't quantified over 't' and partition +the constraints before simplifying. + +This only half-works, but then let-generalisation only half-works. + +Note [DefaultTyVar] +~~~~~~~~~~~~~~~~~~~ +defaultTyVar is used on any un-instantiated meta type variables to +default any RuntimeRep variables to LiftedRep. This is important +to ensure that instance declarations match. For example consider + + instance Show (a->b) + foo x = show (\_ -> True) + +Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r), +and that won't match the typeKind (*) in the instance decl. See tests +tc217 and tc175. + +We look only at touchable type variables. No further constraints +are going to affect these type variables, so it's time to do it by +hand. However we aren't ready to default them fully to () or +whatever, because the type-class defaulting rules have yet to run. + +An alternate implementation would be to emit a Wanted constraint setting +the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect. -} diff --git a/GHC/Tc/Solver/Default.hs b/GHC/Tc/Solver/Default.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Default.hs @@ -0,0 +1,1263 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Solver.Default( + tryDefaulting, tryDefaultingForAmbiguityCheck, + isInteractiveClass, isNumClass + ) where + +import GHC.Prelude + +import GHC.Tc.Errors +import GHC.Tc.Errors.Types +import GHC.Tc.Types.Evidence +import GHC.Tc.Solver.Solve ( solveSimpleWanteds, setImplicationStatus ) +import GHC.Tc.Solver.Dict ( solveCallStack ) +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcMType as TcM +import GHC.Tc.Utils.Monad as TcM +import GHC.Tc.Zonk.TcType as TcM +import GHC.Tc.Solver.Solve( solveWanteds ) +import GHC.Tc.Solver.Monad as TcS +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType + +import GHC.Core.Class +import GHC.Core.Reduction( Reduction, reductionCoercion ) +import GHC.Core +import GHC.Core.DataCon +import GHC.Core.Make +import GHC.Core.Coercion( isReflCo, mkReflCo, mkSubCo, hasCoercionHole ) +import GHC.Core.Unify ( tcMatchTyKis ) +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.TyCo.Tidy + +import GHC.Types.DefaultEnv ( ClassDefaults (..), defaultList ) +import GHC.Types.Unique.Set +import GHC.Types.Id + +import GHC.Builtin.Utils +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.Types.TyThing ( MonadThings(lookupId) ) +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Id.Make ( unboxedUnitExpr ) + +import GHC.Driver.DynFlags +import GHC.Unit.Module ( getModule ) + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Data.Bag + +import Control.Monad +import Control.Monad.Trans.Class ( lift ) +import Control.Monad.Trans.State.Strict ( StateT(runStateT), put ) +import Data.Foldable ( toList, traverse_ ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import GHC.Data.Maybe ( isJust, mapMaybe, catMaybes ) +import Data.Monoid ( First(..) ) + + +{- Note [Top-level Defaulting Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have considered two design choices for where/when to apply defaulting. + (i) Do it in SimplCheck mode only /whenever/ you try to solve some + simple constraints, maybe deep inside the context of implications. + This used to be the case in GHC 7.4.1. + (ii) Do it in a tight loop at simplifyTop, once all other constraints have + finished. This is the current story. + +Option (i) had many disadvantages: + a) Firstly, it was deep inside the actual solver. + b) Secondly, it was dependent on the context (Infer a type signature, + or Check a type signature, or Interactive) since we did not want + to always start defaulting when inferring (though there is an exception to + this, see Note [Default while Inferring]). + c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs: + f :: Int -> Bool + f x = const True (\y -> let w :: a -> a + w a = const a (y+1) + in w y) + We will get an implication constraint (for beta the type of y): + [untch=beta] forall a. 0 => Num beta + which we really cannot default /while solving/ the implication, since beta is + untouchable. + +Instead our new defaulting story is to pull defaulting out of the solver loop and +go with option (ii), implemented at SimplifyTop. Namely: + - First, have a go at solving the residual constraint of the whole + program + - Try to approximate it with a simple constraint + - Figure out derived defaulting equations for that simple constraint + - Go round the loop again if you did manage to get some equations + +Now, that has to do with class defaulting. However there exists type variable /kind/ +defaulting. Again this is done at the top-level and the plan is: + - At the top-level, once you had a go at solving the constraint, do + figure out /all/ the touchable unification variables of the wanted constraints. + - Apply defaulting to their kinds + +More details in Note [DefaultTyVar]. + +Note [Limited defaulting in the ambiguity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying constraints for the ambiguity check, we don't want full +defaulting. E.g. #11947 was an example: + f :: Num a => Int -> Int +This is ambiguous of course, but we don't want to default the (Num +alpha) constraint to (Num Int)! Doing so gives a defaulting warning, +but no error. + +But we still do + +* tryConstraintDefaulting. Example in T10009 where we have this type signature + f :: (UnF (F b) ~ b) => F b -> () + We finish up with an equality that is a member of it's + [W] hole{co_aF0} {rewriters: {co_aF0}}:: b_aES[tau:1] ~# b_aEP[sk:1] + It is not unified because of (REWRITERS) in Note [Unification preconditions] + in GHC.Tc.Utils.Unify + + (`tryConstraintDefaulting` defaults call-stack and exception constraint + as well as equalities; but in the case of the ambiguity check we will + only see equality constraints. Does not seem worth making a version + of `tryConstraintDefaulting` that looks only for equalities.) + +* tryUnsatisfiableGivens: see Wrinkle [Ambiguity] under point (C) of + Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. +-} + + +tryDefaulting :: WantedConstraints -> TcS WantedConstraints +-- This is the function that pulls all the defaulting strategies together +tryDefaulting wc + = do { dflags <- getDynFlags + ; traceTcS "tryDefaulting {" (ppr wc) + ; wc1 <- tryTyVarDefaulting dflags wc + ; wc2 <- tryConstraintDefaulting wc1 + ; wc3 <- tryTypeClassDefaulting wc2 + ; wc4 <- tryUnsatisfiableGivens wc3 + ; traceTcS "tryDefaulting }" (ppr wc4) + ; return wc4 } + +tryDefaultingForAmbiguityCheck :: WantedConstraints -> TcS WantedConstraints +-- See Note [Limited defaulting in the ambiguity check] +tryDefaultingForAmbiguityCheck wc + = do { traceTcS "tryDefaulting for ambiguity {" (ppr wc) + ; wc1 <- tryConstraintDefaulting wc + ; wc2 <- tryUnsatisfiableGivens wc1 + ; traceTcS "tryDefaulting }" (ppr wc2) + ; return wc2 } + +solveAgainIf :: Bool -> WantedConstraints -> TcS WantedConstraints +-- If the Bool is true, solve the wanted constraints again +-- See Note [Must simplify after defaulting] +solveAgainIf False wc = return wc +solveAgainIf True wc = nestTcS (solveWanteds wc) + + +{- ****************************************************************************** +* * + tryTyVarDefaulting +* * +****************************************************************************** -} + +tryTyVarDefaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints +tryTyVarDefaulting dflags wc + | isEmptyWC wc + = return wc + | insolubleWC wc + , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles] + = return wc + | otherwise + = do { -- Need to zonk first, as the WantedConstraints are not yet zonked. + ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc) + ; let defaultable_tvs = filter can_default free_tvs + can_default tv + = isTyVar tv + -- Weed out coercion variables. + + && isMetaTyVar tv + -- Weed out runtime-skolems in GHCi, which we definitely + -- shouldn't try to default. + + && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc) + -- Weed out variables for which defaulting would be unhelpful, + -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk]. + + ; unification_s <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects + ; solveAgainIf (or unification_s) wc } + -- solveAgainIf: see Note [Must simplify after defaulting] + +type UnificationDone = Bool + +noUnification, didUnification :: UnificationDone +noUnification = False +didUnification = True + +-- | Like 'defaultTyVar', but in the TcS monad. +defaultTyVarTcS :: TcTyVar -> TcS UnificationDone +defaultTyVarTcS the_tv + | isTyVarTyVar the_tv + -- TyVarTvs should only be unified with a tyvar + -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar + -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return noUnification + | isRuntimeRepVar the_tv + = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv) + ; unifyTyVar the_tv liftedRepTy + ; return didUnification } + | isLevityVar the_tv + = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv) + ; unifyTyVar the_tv liftedDataConTy + ; return didUnification } + | isMultiplicityVar the_tv + = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) + ; unifyTyVar the_tv ManyTy + ; return didUnification } + | otherwise + = return noUnification -- the common case + + +{- ****************************************************************************** +* * + tryUnsatisfiableGivens +* * +****************************************************************************** -} + +-- | If an implication contains a Given of the form @Unsatisfiable msg@, +-- use it to solve all Wanteds within the implication. +-- See point (C) in Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors. +-- +-- This does a complete walk over the implication tree. +tryUnsatisfiableGivens :: WantedConstraints -> TcS WantedConstraints +tryUnsatisfiableGivens wc = + do { (final_wc, did_work) <- (`runStateT` False) $ go_wc wc + ; solveAgainIf did_work final_wc } + where + go_wc (WC { wc_simple = wtds, wc_impl = impls, wc_errors = errs }) + = do impls' <- mapBagM go_impl impls + return $ WC { wc_simple = wtds, wc_impl = impls', wc_errors = errs } + go_impl impl + | isSolvedStatus (ic_status impl) + = return impl + -- Is there a Given with type "Unsatisfiable msg"? + -- If so, use it to solve all other Wanteds. + | unsat_given:_ <- mapMaybe unsatisfiableEv_maybe (ic_given impl) + = do { put True + ; lift $ solveImplicationUsingUnsatGiven unsat_given impl } + -- Otherwise, recurse. + | otherwise + = do { wcs' <- go_wc (ic_wanted impl) + ; lift $ setImplicationStatus $ impl { ic_wanted = wcs' } } + +-- | Is this evidence variable the evidence for an 'Unsatisfiable' constraint? +-- +-- If so, return the variable itself together with the error message type. +unsatisfiableEv_maybe :: EvVar -> Maybe (EvVar, Type) +unsatisfiableEv_maybe v = (v,) <$> isUnsatisfiableCt_maybe (idType v) + +-- | We have an implication with an 'Unsatisfiable' Given; use that Given to +-- solve all the other Wanted constraints, including those nested within +-- deeper implications. +solveImplicationUsingUnsatGiven :: (EvVar, Type) -> Implication -> TcS Implication +solveImplicationUsingUnsatGiven + unsat_given@(given_ev,_) + impl@(Implic { ic_wanted = wtd, ic_tclvl = tclvl, ic_binds = ev_binds_var + , ic_need_implic = inner }) + | isCoEvBindsVar ev_binds_var + -- We can't use Unsatisfiable evidence in kinds. + -- See Note [Coercion evidence only] in GHC.Tc.Types.Evidence. + = return impl + | otherwise + = do { wcs <- nestImplicTcS ev_binds_var tclvl $ go_wc wtd + ; setImplicationStatus $ + impl { ic_wanted = wcs + , ic_need_implic = inner `extendEvNeedSet` given_ev } } + -- Record that the Given is needed; I'm not certain why + where + go_wc :: WantedConstraints -> TcS WantedConstraints + go_wc wc@(WC { wc_simple = wtds, wc_impl = impls }) + = do { mapBagM_ go_simple wtds + ; impls <- mapBagM (solveImplicationUsingUnsatGiven unsat_given) impls + ; return $ wc { wc_simple = emptyBag, wc_impl = impls } } + go_simple :: Ct -> TcS () + go_simple ct = case ctEvidence ct of + CtWanted (WantedCt { ctev_pred = pty, ctev_dest = dest }) + -> do { ev_expr <- unsatisfiableEvExpr unsat_given pty + ; setWantedEvTerm dest EvNonCanonical $ EvExpr ev_expr } + _ -> return () + +-- | Create an evidence expression for an arbitrary constraint using +-- evidence for an "Unsatisfiable" Given. +-- +-- See Note [Evidence terms from Unsatisfiable Givens] +unsatisfiableEvExpr :: (EvVar, ErrorMsgType) -> PredType -> TcS EvExpr +unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty + = do { mod <- getModule + -- If we're typechecking GHC.TypeError, return a bogus expression; + -- it's only used for the ambiguity check, which throws the evidence away anyway. + -- This avoids problems with circularity; where we are trying to look + -- up the "unsatisfiable" Id while we are in the middle of typechecking it. + ; if mod == gHC_INTERNAL_TYPEERROR then return (Var unsat_ev) else + do { unsatisfiable_id <- tcLookupId unsatisfiableIdName + + -- See Note [Evidence terms from Unsatisfiable Givens] + -- for a description of what evidence term we are constructing here. + + ; let -- (##) -=> wtd_ty + fun_ty = mkFunTy visArgConstraintLike ManyTy unboxedUnitTy wtd_ty + mkDictBox = case boxingDataCon fun_ty of + BI_Box { bi_data_con = mkDictBox } -> mkDictBox + _ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty) + dictBox = dataConTyCon mkDictBox + ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty + -- Dict ((##) -=> wtd_ty) + ; let scrut_ty = mkTyConApp dictBox [fun_ty] + -- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev + scrut = + mkCoreApps (Var unsatisfiable_id) + [ Type liftedRepTy + , Type given_msg + , Type scrut_ty + , Var unsat_ev ] + -- case scrut of { MkDictBox @((##) -=> wtd_ty)) ct -> ct (# #) } + ev_expr = + mkWildCase scrut (unrestricted $ scrut_ty) wtd_ty + [ Alt (DataAlt mkDictBox) [ev_bndr] $ + mkCoreApps (Var ev_bndr) [unboxedUnitExpr] + ] + ; return ev_expr } } + +{- Note [Evidence terms from Unsatisfiable Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An Unsatisfiable Given constraint, of the form [G] Unsatisfiable msg, should be +able to solve ANY Wanted constraint whatsoever. + +Recall that we have + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep) + . Unsatisfiable msg => a + +We want to use this function, together with the evidence +[G] unsat_ev :: Unsatisfiable msg, to solve any other constraint [W] wtd_ty. + +We could naively think that a valid evidence term for the Wanted might be: + + wanted_ev = unsatisfiable @{rep} @msg @wtd_ty unsat_ev + +Unfortunately, this is a kind error: "wtd_ty :: CONSTRAINT rep", but +"unsatisfiable" expects the third type argument to be of kind "TYPE rep". + +Instead, we use a boxing data constructor to box the constraint into a type. +In the end, we construct the following evidence for the implication: + + [G] unsat_ev :: Unsatisfiable msg + ==> + [W] wtd_ev :: wtd_ty + + wtd_ev = + case unsatisfiable @{LiftedRep} @msg @(Dict ((##) -=> wtd_ty)) unsat_ev of + MkDictBox ct -> ct (# #) + +Note that we play the same trick with the function arrow -=> that we did +in order to define "unsatisfiable" in terms of "unsatisfiableLifted", as described +in Note [The Unsatisfiable representation-polymorphism trick] in base:GHC.TypeError. +This allows us to indirectly box constraints with different representations +(such as primitive equality constraints). +-} + + +{- ****************************************************************************** +* * + tryConstraintDefaulting +* * +****************************************************************************** -} + +-- | A 'TcS' action which can may solve a `Ct` +type CtDefaultingStrategy = Ct -> TcS Bool + -- True <=> I solved the constraint + +tryConstraintDefaulting :: WantedConstraints -> TcS WantedConstraints +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +tryConstraintDefaulting wc + | isEmptyWC wc + = return wc + | otherwise + = do { (n_unifs, better_wc) <- reportUnifications (go_wc wc) + -- We may have done unifications; so solve again + ; solveAgainIf (n_unifs > 0) better_wc } + where + go_wc :: WantedConstraints -> TcS WantedConstraints + go_wc wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapMaybeBagM go_simple simples + ; implics' <- mapBagM go_implic implics + ; return (wc { wc_simple = simples', wc_impl = implics' }) } + + go_simple :: Ct -> TcS (Maybe Ct) + go_simple ct = do { solved <- tryCtDefaultingStrategy ct + ; if solved then return Nothing + else return (Just ct) } + + go_implic :: Implication -> TcS Implication + -- The Maybe is because solving the CallStack constraint + -- may well allow us to discard the implication entirely + go_implic implic + | isSolvedStatus (ic_status implic) + = return implic -- Nothing to solve inside here + | otherwise + = do { wanteds <- setEvBindsTcS (ic_binds implic) $ + -- defaultCallStack sets a binding, so + -- we must set the correct binding group + go_wc (ic_wanted implic) + ; setImplicationStatus (implic { ic_wanted = wanteds }) } + +tryCtDefaultingStrategy :: CtDefaultingStrategy +-- The composition of all the CtDefaultingStrategies we want +tryCtDefaultingStrategy + = foldr1 combineStrategies + ( defaultCallStack :| + defaultExceptionContext : + defaultEquality : + [] ) + +-- | Default @ExceptionContext@ constraints to @emptyExceptionContext@. +defaultExceptionContext :: CtDefaultingStrategy +defaultExceptionContext ct + | ClassPred cls tys <- classifyPredType (ctPred ct) + , isJust (isExceptionContextPred cls tys) + = do { warnTcS $ TcRnDefaultedExceptionContext (ctLoc ct) + ; empty_ec_id <- lookupId emptyExceptionContextName + ; let ev = ctEvidence ct + ev_tm = EvExpr (evWrapIPE (ctEvPred ev) (Var empty_ec_id)) + ; setEvBindIfWanted ev EvCanonical ev_tm + -- EvCanonical: see Note [CallStack and ExceptionContext hack] + -- in GHC.Tc.Solver.Dict + ; return True } + | otherwise + = return False + +-- | Default any remaining @CallStack@ constraints to empty @CallStack@s. +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +defaultCallStack :: CtDefaultingStrategy +defaultCallStack ct + | ClassPred cls tys <- classifyPredType (ctPred ct) + , isJust (isCallStackPred cls tys) + = do { solveCallStack (ctEvidence ct) EvCsEmpty + ; return True } + | otherwise + = return False + +defaultEquality :: CtDefaultingStrategy +-- See Note [Defaulting equalities] +defaultEquality ct + | EqPred eq_rel ty1 ty2 <- classifyPredType (ctPred ct) + = do { -- Remember: `ct` may not be zonked; + -- see (DE3) in Note [Defaulting equalities] + z_ty1 <- TcS.zonkTcType ty1 + ; z_ty2 <- TcS.zonkTcType ty2 + ; case eq_rel of + { NomEq -> + -- Now see if either LHS or RHS is a bare type variable + -- You might think the type variable will only be on the LHS + -- but with a type function we might get F t1 ~ alpha + case (getTyVar_maybe z_ty1, getTyVar_maybe z_ty2) of + (Just z_tv1, _) -> try_default_tv z_tv1 z_ty2 + (_, Just z_tv2) -> try_default_tv z_tv2 z_ty1 + _ -> return False ; + + ; ReprEq + -- See Note [Defaulting representational equalities] + | CIrredCan (IrredCt { ir_reason }) <- ct + , isInsolubleReason ir_reason + -- Don't do this for definitely insoluble representational + -- equalities such as Int ~R# Bool. + -> return False + | otherwise + -> + do { traceTcS "defaultEquality ReprEq {" $ vcat + [ text "ct:" <+> ppr ct + , text "z_ty1:" <+> ppr z_ty1 + , text "z_ty2:" <+> ppr z_ty2 + ] + -- Promote this representational equality to a nominal equality. + -- + -- This handles cases such as @IO alpha[tau] ~R# IO Int@ + -- by defaulting @alpha := Int@, which is useful in practice + -- (see Note [Defaulting representational equalities]). + ; (co, new_eqs, _unifs) <- + wrapUnifierX (ctEvidence ct) Nominal $ + -- NB: nominal equality! + \ uenv -> uType uenv z_ty1 z_ty2 + -- Only accept this solution if no new equalities are produced + -- by the unifier. + -- + -- See Note [Defaulting representational equalities]. + ; if null new_eqs + then do { setEvBindIfWanted (ctEvidence ct) EvCanonical $ + (evCoercion $ mkSubCo co) + ; return True } + else return False + } } } + | otherwise + = return False + + where + try_default_tv lhs_tv rhs_ty + | MetaTv { mtv_info = info } <- tcTyVarDetails lhs_tv + , tyVarKind lhs_tv `tcEqType` typeKind rhs_ty + , checkTopShape info rhs_ty + , not (hasCoercionHole rhs_ty) -- See (DE6) in Note [Defaulting equalities] + -- Do not test for touchability of lhs_tv; that is the whole point! + -- See (DE2) in Note [Defaulting equalities] + = do { traceTcS "defaultEquality 1" (ppr lhs_tv $$ ppr rhs_ty) + + -- checkTyEqRhs: check that we can in fact unify lhs_tv := rhs_ty + -- See Note [Defaulting equalities] + ; let flags :: TyEqFlags TcM () + flags = defaulting_TEFTask lhs_tv + + ; res :: PuResult () Reduction <- wrapTcS (checkTyEqRhs flags rhs_ty) + + ; case res of + PuFail {} -> cant_default_tv "checkTyEqRhs" + PuOK _ redn -> assertPpr (isReflCo (reductionCoercion redn)) (ppr redn) $ + -- With TEFA_Recurse we never get any reductions + default_tv } + | otherwise + = cant_default_tv "fall through" + + where + cant_default_tv msg + = do { traceTcS ("defaultEquality fails: " ++ msg) $ + vcat [ ppr lhs_tv <+> char '~' <+> ppr rhs_ty + , ppr (tyVarKind lhs_tv) + , ppr (typeKind rhs_ty) ] + ; return False } + + -- All tests passed: do the unification + default_tv + = do { traceTcS "defaultEquality success:" (ppr rhs_ty) + ; unifyTyVar lhs_tv rhs_ty -- NB: unifyTyVar adds to the + -- TcS unification counter + ; setEvBindIfWanted (ctEvidence ct) EvCanonical $ + evCoercion (mkReflCo Nominal rhs_ty) + ; return True + } + + +combineStrategies :: CtDefaultingStrategy -> CtDefaultingStrategy -> CtDefaultingStrategy +combineStrategies default1 default2 ct + = do { solved <- default1 ct + ; case solved of + True -> return True -- default1 solved it! + False -> default2 ct -- default1 failed, try default2 + } + + +{- Note [When to do type-class defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC +was false, on the grounds that defaulting can't help solve insoluble +constraints. But if we *don't* do defaulting we may report a whole +lot of errors that would be solved by defaulting; these errors are +quite spurious because fixing the single insoluble error means that +defaulting happens again, which makes all the other errors go away. +This is jolly confusing: #9033. + +So it seems better to always do type-class defaulting. + +However, always doing defaulting does mean that we'll do it in +situations like this (#5934): + run :: (forall s. GenST s) -> Int + run = fromInteger 0 +We don't unify the return type of fromInteger with the given function +type, because the latter involves foralls. So we're left with + (Num alpha, alpha ~ (forall s. GenST s) -> Int) +Now we do defaulting, get alpha := Integer, and report that we can't +match Integer with (forall s. GenST s) -> Int. That's not totally +stupid, but perhaps a little strange. + +Another potential alternative would be to suppress *all* non-insoluble +errors if there are *any* insoluble errors, anywhere, but that seems +too drastic. + +Note [Defaulting equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In top-level defaulting (as per Note [Top-level Defaulting Plan]), it makes +sense to try to default equality constraints, in addition to e.g. typeclass +defaulting: this doesn't threaten principal types (see DE1 below), but +allows GHC to accept strictly more programs. + +This Note explains defaulting nominal equalities; see also +Note [Defaulting representational equalities] which describes +the defaulting of representational equalities. + +Consider + + f :: forall a. (forall t. (F t ~ Int) => a -> Int) -> Int + + g :: Int + g = f id + +We'll typecheck + + id :: forall t. (F t ~ Int) => alpha[1] -> Int + +where the `alpha[1]` comes from instantiating `f`. So we'll end up +with the implication constraint + + forall[2] t. (F t ~ Int) => alpha[1] ~ Int + +and that can't be solved because `alpha` is untouchable under the +equality (F t ~ Int). + +This is tiresome, and gave rise to user complaints: #25125 and #25029. +Moreover, in this case there is no good reason not to unify alpha:=Int. +Doing so solves the constraint, and since `alpha` is not otherwise +constrained, it does no harm. + +In conclusion, for a Wanted equality constraint [W] lhs ~ rhs, if the only +reason for not unifying is that either lhs or rhs is an untouchable metavariable +then, in top-level defaulting, go ahead and unify. + +In top-level defaulting, we already do several other somewhat-ad-hoc, +but terribly convenient, unifications. This is just one more. + +Wrinkles: + +(DE1) Note carefully that this does not threaten principal types. + The original worry about unifying untouchable type variables was this: + + data T a where + T1 :: T Bool + f x = case x of T1 -> True + + Should we infer f :: T a -> Bool, or f :: T a -> a. Both are valid, but + neither is more general than the other. + +(DE2) We still can't unify if there is a skolem-escape check, or an occurs check, + or it it'd mean unifying a TyVarTv with a non-tyvar. It's only the + "untouchability test" that we lift. + +(DE3) The contraint we are looking at may not be fully zonked; for example, + an earlier defaulting might have affected it. So we zonk-on-the fly in + `defaultEquality`. + +(DE4) Promotion. Suppose we see alpha[2] := Maybe beta[4]. We want to promote + beta[4] to level 2 and unify alpha[2] := Maybe beta'[2]. This is done by + checkTyEqRhs called in defaultEquality. + +(DE5) Promotion. Suppose we see alpha[2] := F beta[4], where F is a type + family. Then we still want to promote beta to beta'[2], and unify. This is + unusual: more commonly, we don't promote unification variables under a + type family. But here we want to. (This mattered in #25251.) + + Hence the Bool flag on LC_Promote, and its use in `tef_unifying` in + `defaultEquality`. + +(DE6) /Don't/ unify if the RHS has a free coercion hole in it. That means + that there is an as-yet-unsolved equality constraint (whose evidence + will fill that hole); unifying can lead to very confusing type errors. + e.g. [W] co1 :: IntRep ~ LiftedRep + [W] co2 {rewritten by co1} :: alpha ~ t2 |> (TYPE co1) + Unifying alpha := (t1 |> TYPE co1) is a Bad Idea. + + Note that we /do/ unify even if the constraint has a non-empty rewriter + set, which has prevented unification up to now; see + Note [Unify only if the rewriter set is empty] in GHC.Tc.Solver.Equality. + In obscure situations a constraint can end up in its own rewriter set, but + without a coercion hole being in the RHS. + + See #10009, and Note [Limited defaulting in the ambiguity check]. + + +Note [Must simplify after defaulting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a deeply buried constraint + (t:*) ~ (a:Open) +which we couldn't solve because of the kind incompatibility, and 'a' is free. +Then when we default 'a' we can solve the constraint. And we want to do +that before starting in on type classes. We MUST do it before reporting +errors, because it isn't an error! #7967 was due to this. + +Note [Defaulting representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we end up with [W] alpha ~#R Int, with no other constraints on alpha. +Then it makes sense to simply unify alpha := Int -- the alternative is to +reject the program due to an ambiguous metavariable alpha, so it makes sense +to unify and accept instead. + +This is particularly convenient for users of `coerce`, as it lessens the +amount of type annotations required (see #21003). Consider for example: + + -- 'foldMap' defined using 'traverse' + foldMapUsingTraverse :: forall t m a. (Traversable t, Monoid m) => (a -> m) -> t a -> m + foldMapUsingTraverse = coerce $ traverse @t @(Const m) + + -- 'traverse_' defined using 'foldMap' + traverse_UsingFoldMap :: forall f t a. (Foldable t, Applicative f) => (a -> f ()) -> t a -> f () + traverse_UsingFoldMap = coerce $ foldMap @t @(Ap f ()) + +Typechecking these functions results in unsolved Wanted constraints of the form +[W] alpha[tau] ~R# some_ty; accepting such programs by unifying +alpha := some_ty avoids the need for users to specify tiresome additional +type annotations, such as: + + foldMapUsingTraverse = coerce $ traverse @t @(Const m) @a + traverse_UsingFoldMap = coerce $ foldMap @t @(Ap f ()) @a + +Consider also the following example: + + -- 'sequence_', but for two nested 'Foldable' structures + sequenceNested_ :: forall f1 f2. (Foldable f1, Foldable f2) => f1 (f2 (IO ())) -> IO () + sequenceNested_ = coerce $ sequence_ @( Compose f1 f2 ) + +Here, we end up with [W] mu[tau] beta[tau] ~#R IO (), and it similarly makes +sense to default mu := IO, beta := (). This avoids requiring the +user to provide additional type applications: + + sequenceNested_ = coerce $ sequence_ @( Compose f1 f2 ) @IO @() + +The plan for defaulting a representational equality, say [W] ty1 ~R# ty2, +is thus as follows: + + 1. attempt to unify ty1 ~# ty2 (at nominal role) + 2. a. if this succeeds without deferring any constraints, accept this solution + b. otherwise, keep the original constraint. + +(2b) ensures that we don't degrade all error messages by always turning unsolved +representational equalities into nominal ones; we only want to default a +representational equality when we can fully solve it. + +Note that this does not threaten principle types. Recall that the original worry +(as per Note [Do not unify representational equalities]) was that we might have + + [W] alpha ~R# Int + [W] alpha ~ Age + +in which case unifying alpha := Int would be wrong, as the correct solution is +alpha := Age. This worry doesn't concern us in top-level defaulting, because +defaulting takes place after generalisation; it is fully monomorphic. + +********************************************************************************* +* * +* Type-class defaulting +* * +********************************************************************************* + +Note [How type-class constraints are defaulted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type-class defaulting deals with the situation where we have unsolved +constraints like (Num alpha), where `alpha` is a unification variable. We want +to pick a default for `alpha`, such as `alpha := Int` to resolve the ambiguity. + +The function 'tryTypeClassDefaulting' implements type-class defaulting. The +algorithm for defaulting depends on whether certain extensions are enabled, +such as -XOverloadedStrings or -XExtendedDefaultRules. To explain this, let us +define the following: + + Unary typeclass: + a typeclass with a single visible type argument. + + Examples: + + Num :: Type -> Constraint + Eq :: Type -> Constraint + Foldable :: (Type -> Type) -> Constraint + Typeable :: forall k. k -> Constraint -- NB: also has an /invisible/ argument + + Non-examples: + + Nullary :: Constraint + Binary :: Type -> Type -> Constraint + Binary2 :: forall k -> k -> Constraint -- Two visible arguments + + Defaultable class + a typeclass which has at least one in-scope default declaration + + This includes the two different categories of default declarations: + + - Haskell 98 default declarations such as 'default (Integer, Float)'. + + - `Num` is always defaultable; either the user says 'default( Integer, Float )' + or (absent such a declaration) the system fills in a fallback default declaration. + See Section 4.3.4 in https://www.haskell.org/onlinereport/haskell2010/haskellch4.html + + - With `OverloadedStrings`, the class `IsString` is defaultable + - With `ExtendedDefaultRules`, the classes `Show`, `Eq`, `Ord`, `Foldable` and `Traversable` + are defaultable + + - Named default declarations, which apply to the named class, e.g. + 'default Cls(X, Y)' applies precisely to 'Cls'. + Note that these may be locally defined, or they may be imported. + + Standard class: + a class defined in the Prelude or the standard library, as defined + by the Haskell 98 report (section 4.3.4) + + These are defined in GHC.Builtin.Names.standardClassKeys. + +The rules for defaulting a collection 'S' of unsolved constraints are as follows: + + 1. For each metavariable 'v' appearing in 'S', define + + U_v = { C v | C v ∈ U, C is a unary typeclass } + + We then process each 'U_v' in turn, in order to find a defaulting + assignment 'v := ty' that solves all of 'U_v'. + + 2. Unless -XExtendedDefaultRules is in effect, give up if 'v' appears: + + - in any constraint that isn't a unary class constraint + - in a class constraint which is non-standard and does not have + a default declaration in scope. + + 3. Compute candidate assignments: for each unary typeclass 'C' in 'U_v' which + has a default declaration in scope, find the first type 'ty' in the list + of in-scope default types for 'C' for which all of 'U_v' is soluble. + + 4. If there is precisely one type candidate type assignment 'ty' that allows + all of 'U_v' to be solved, we default 'v := ty'. Otherwise, do nothing + ('v' remains ambiguous). + +Note [Defaulting plugins] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Defaulting plugins enable extending or overriding the defaulting +behaviour. In `applyDefaultingRules`, before the built-in defaulting +mechanism runs, the loaded defaulting plugins are passed the +`WantedConstraints` and get a chance to propose defaulting assignments +based on them. + +Proposals are represented as `[DefaultingProposal]` with each proposal +consisting of a type variable to fill-in, the list of defaulting types to +try in order, and a set of constraints to check at each try. This is +the same representation (albeit in a nicely packaged-up data type) as +the candidates generated by the built-in defaulting mechanism, so the +actual trying of proposals is done by the same `disambigGroup` function. + +Wrinkle (DP1): The role of `WantedConstraints` + + Plugins are passed `WantedConstraints` that can perhaps be + progressed on by defaulting. But a defaulting plugin is not a solver + plugin, its job is to provide defaulting proposals, i.e. mappings of + type variable to types. How do plugins know which type variables + they are supposed to default? + + The `WantedConstraints` passed to the defaulting plugin are zonked + beforehand to ensure all remaining metavariables are unfilled. Thus, + the `WantedConstraints` serve a dual purpose: they are both the + constraints of the given context that can act as hints to the + defaulting, as well as the containers of the type variables under + consideration for defaulting. + +Wrinkle (DP2): Interactions between defaulting mechanisms + + In the general case, we have multiple defaulting plugins loaded and + there is also the built-in defaulting mechanism. In this case, we + have to be careful to keep the `WantedConstraints` passed to the + plugins up-to-date by zonking between successful defaulting + rounds. Otherwise, two plugins might come up with a defaulting + proposal for the same metavariable; if the first one is accepted by + `disambigGroup` (thus the meta gets filled), the second proposal + becomes invalid (see #23821 for an example). + +Note [Defaulting insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a set of wanteds is insoluble, we have no hope of accepting the +program. Yet we do not stop constraint solving, etc., because we may +simplify the wanteds to produce better error messages. So, once +we have an insoluble constraint, everything we do is just about producing +helpful error messages. + +Should we default in this case or not? Let's look at an example (tcfail004): + + (f,g) = (1,2,3) + +With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer). +Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard) +find the latter more helpful. Several other test cases (e.g. tcfail005) suggest +similarly. So: we should not do class defaulting with insolubles. + +On the other hand, RuntimeRep-defaulting is different. Witness tcfail078: + + f :: Integer i => i + f = 0 + +Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind +TYPE r0 -> Constraint and then complains that r0 is actually untouchable +(presumably, because it can't be sure if `Integer i` entails an equality). +If we default, we are told of a clash between (* -> Constraint) and Constraint. +The latter seems far better, suggesting we *should* do RuntimeRep-defaulting +even on insolubles. + +But, evidently, not always. Witness UnliftedNewtypesInfinite: + + newtype Foo = FooC (# Int#, Foo #) + +This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes). +If we default RuntimeRep-vars, we get + + Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted + +which is just plain wrong. + +Another situation in which we don't want to default involves concrete metavariables. + +In equalities such as alpha[conc] ~# rr[sk] , alpha[conc] ~# RR beta[tau] +for a type family RR (all at kind RuntimeRep), we would prefer to report a +representation-polymorphism error rather than default alpha and get error: + + Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted` + +which is very confusing. For this reason, we weed out the concrete +metavariables participating in such equalities in nonDefaultableTyVarsOfWC. +Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could +become soluble after defaulting beta (see also #21430). + +Conclusion: we should do RuntimeRep-defaulting on insolubles only when the +user does not want to hear about RuntimeRep stuff -- that is, when +-fprint-explicit-runtime-reps is not set. +However, we must still take care not to default concrete type variables +participating in an equality with a non-concrete type, as seen in the +last example above. + +-} + +tryTypeClassDefaulting :: WantedConstraints -> TcS WantedConstraints +tryTypeClassDefaulting wc + | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles] + = return wc + | otherwise -- See Note [When to do type-class defaulting] + = do { something_happened <- applyDefaultingRules wc + -- See Note [Top-level Defaulting Plan] + ; solveAgainIf something_happened wc } + +applyDefaultingRules :: WantedConstraints -> TcS Bool +-- True <=> I did some defaulting, by unifying a meta-tyvar +-- Input WantedConstraints are not necessarily zonked +-- See Note [How type-class constraints are defaulted] + +applyDefaultingRules wanteds + | isEmptyWC wanteds + = return False + | otherwise + = do { (default_env, extended_rules) <- getDefaultInfo + ; wanteds <- TcS.zonkWC wanteds + + ; tcg_env <- TcS.getGblEnv + ; let plugins = tcg_defaulting_plugins tcg_env + default_tys = defaultList default_env + -- see Note [Named default declarations] in GHC.Tc.Gen.Default + + -- Run any defaulting plugins + -- See Note [Defaulting plugins] for an overview + ; (wanteds, plugin_defaulted) <- if null plugins then return (wanteds, []) else + do { + ; traceTcS "defaultingPlugins {" (ppr wanteds) + ; (wanteds, defaultedGroups) <- mapAccumLM run_defaulting_plugin wanteds plugins + ; traceTcS "defaultingPlugins }" (ppr defaultedGroups) + ; return (wanteds, defaultedGroups) + } + + ; let groups = findDefaultableGroups (default_tys, extended_rules) wanteds + + ; traceTcS "applyDefaultingRules {" $ + vcat [ text "wanteds =" <+> ppr wanteds + , text "groups =" <+> ppr groups + , text "info =" <+> ppr (default_tys, extended_rules) ] + + ; something_happeneds <- mapM (disambigGroup wanteds default_tys) groups + + ; traceTcS "applyDefaultingRules }" (ppr something_happeneds) + + ; return $ or something_happeneds || or plugin_defaulted } + + where + run_defaulting_plugin wanteds p + = do { groups <- runTcPluginTcS (p wanteds) + ; defaultedGroups <- + filterM (\g -> disambigMultiGroup + wanteds + (deProposalCts g) + (ProposalSequence (Proposal <$> deProposals g))) + groups + ; traceTcS "defaultingPlugin " $ ppr defaultedGroups + ; case defaultedGroups of + [] -> return (wanteds, False) + _ -> do + -- If a defaulting plugin solves any tyvars, some of the wanteds + -- will have filled-in metavars by now (see wrinkle DP2 of + -- Note [Defaulting plugins]). So we re-zonk to make sure later + -- defaulting doesn't try to solve the same metavars. + wanteds' <- TcS.zonkWC wanteds + return (wanteds', True) } + +findDefaultableGroups + :: ( [ClassDefaults] + , Bool ) -- extended default rules + -> WantedConstraints -- Unsolved + -> [(TyVar, [Ct])] +findDefaultableGroups (default_tys, extended_defaults) wanteds + | null default_tys + = [] + | otherwise + = [ (tv, map fstOf3 group) + | group'@((_,_,tv) :| _) <- unary_groups + , let group = toList group' + , defaultable_tyvar tv + , defaultable_classes (map sndOf3 group) ] + where + simples = approximateWC True wanteds + -- True: for the purpose of defaulting we don't care + -- about shape or enclosing equalities + -- See (W3) in Note [ApproximateWC] in GHC.Tc.Types.Constraint + + (unaries, non_unaries) = partitionWith find_unary (bagToList simples) + unary_groups = equivClasses cmp_tv unaries + + unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints + unaries :: [(Ct, Class, TcTyVar)] -- (C tv) constraints + non_unaries :: [Ct] -- and *other* constraints + + -- Finds unary type-class constraints + -- But take account of polykinded classes like Typeable, + -- which may look like (Typeable Type (a:Type)) (#8931) + -- See step (1) in Note [How type-class constraints are defaulted] + find_unary :: Ct -> Either (Ct, Class, TyVar) Ct + find_unary cc + | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) + , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys + -- Ignore invisible arguments for this purpose + , Just tv <- getTyVar_maybe ty + , isMetaTyVar tv -- We might have runtime-skolems in GHCi, and + -- we definitely don't want to try to assign to those! + = Left (cc, cls, tv) + find_unary cc = Right cc -- Non unary or non dictionary + + nonunary_tvs :: TcTyCoVarSet -- TyVars mentioned by non-unaries + nonunary_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries + + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 + + defaultable_tyvar :: TcTyVar -> Bool + defaultable_tyvar tv + = let b1 = isTyConableTyVar tv -- Note [Avoiding spurious errors] + b2 = not (tv `elemVarSet` nonunary_tvs) + in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults] + + -- Determines whether the collection of class constraints permits defaulting. + -- See step (2) in Note [How type-class constraints are defaulted] + defaultable_classes :: [Class] -> Bool + defaultable_classes clss = + -- One of the classes has a default declaration in scope + -- (this includes 'Num', and e.g. 'IsString' with -XOverloadedStrings) + any (`elementOfUniqSet` classes_with_defaults) clss + && + -- AND, either: + -- - ExtendedDefaultRules is in effect, or + -- - all the classes are standard or have a default declaration in scope + (extended_defaults || all is_std_or_has_default clss) + is_std_or_has_default :: Class -> Bool + is_std_or_has_default cls = + (getUnique cls `elem` standardClassKeys) + || + (cls `elementOfUniqSet` classes_with_defaults) + + -- All classes with a default declaration in scope; either: + -- + -- - a named default declaration such as 'default C(Double, Bool)', or + -- - a Haskell 98 default declaration such as 'default(Int, Float)', + -- which adds defaults for Num, for IsString with OverloadedStrings, + -- and for Foldable/Traversable/... with ExtendedDefaultRules + classes_with_defaults = mkUniqSet $ map cd_class default_tys + +------------------------------ + +-- | 'Proposal's to be tried in sequence until the first one that succeeds +newtype ProposalSequence = ProposalSequence{getProposalSequence :: [Proposal]} + +-- | An atomic set of proposed type assignments to try applying all at once +newtype Proposal = Proposal [(TcTyVar, Type)] + +instance Outputable ProposalSequence where + ppr (ProposalSequence proposals) = ppr proposals +instance Outputable Proposal where + ppr (Proposal assignments) = ppr assignments + +disambigGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes + -> [ClassDefaults] -- ^ The default classes and types + -> (TcTyVar, [Ct]) -- ^ All constraints sharing same type variable + -> TcS Bool -- True <=> something happened, reflected in ty_binds +disambigGroup orig_wanteds default_ctys (tv, wanteds) + = disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent + where + proposalSequences = [ ProposalSequence [Proposal [(tv, ty)] | ty <- tys] + | ClassDefaults{cd_types = tys} <- defaultses ] + allConsistent ((_, sub) :| subs) = all (eqSubAt tv sub . snd) subs + defaultses = + [ defaults | defaults@ClassDefaults{cd_class = cls} <- default_ctys + , any (isDictForClass (className cls)) wanteds ] + isDictForClass clcon ct = any ((clcon ==) . className . fst) (getClassPredTys_maybe $ ctPred ct) + eqSubAt :: TcTyVar -> Subst -> Subst -> Bool + eqSubAt tvar s1 s2 = or $ liftA2 tcEqType (lookupTyVar s1 tvar) (lookupTyVar s2 tvar) + +-- See Note [How type-class constraints are defaulted] +disambigMultiGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes + -> [Ct] -- ^ check these are solved by defaulting + -> ProposalSequence -- ^ defaulting type assignments to try + -> TcS Bool -- True <=> something happened, reflected in ty_binds +disambigMultiGroup orig_wanteds wanteds proposalSequence + = disambigProposalSequences orig_wanteds wanteds [proposalSequence] (const True) + +disambigProposalSequences :: WantedConstraints -- ^ Original constraints, for diagnostic purposes + -> [Ct] -- ^ Check these are solved by defaulting + -> [ProposalSequence] -- ^ The sequences of assignment proposals + -> (NonEmpty ([TcTyVar], Subst) -> Bool) + -- ^ Predicate for successful assignments + -> TcS Bool -- True <=> something happened, reflected in ty_binds +disambigProposalSequences orig_wanteds wanteds proposalSequences allConsistent + = do { traverse_ (traverse_ reportInvalidDefaultedTyVars . getProposalSequence) proposalSequences + ; fake_ev_binds_var <- TcS.newTcEvBinds + ; tclvl <- TcS.getTcLevel + -- Step (3) in Note [How type-class constraints are defaulted] + ; successes <- fmap catMaybes $ + nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) $ + mapM firstSuccess proposalSequences + ; traceTcS "disambigProposalSequences {" (vcat [ ppr wanteds + , ppr proposalSequences + , ppr successes ]) + -- Step (4) in Note [How type-class constraints are defaulted] + ; case successes of + success@(tvs, subst) : rest + | allConsistent (success :| rest) + -> do { applyDefaultSubst tvs subst + ; let warn tv = mapM_ (warnDefaulting wanteds tv) (lookupTyVar subst tv) + ; wrapWarnTcS $ mapM_ warn tvs + ; traceTcS "disambigProposalSequences succeeded }" (ppr proposalSequences) + ; return True } + _ -> + do { traceTcS "disambigProposalSequences failed }" (ppr proposalSequences) + ; return False } } + where + reportInvalidDefaultedTyVars :: Proposal -> TcS () + firstSuccess :: ProposalSequence -> TcS (Maybe ([TcTyVar], Subst)) + firstSuccess (ProposalSequence proposals) + = getFirst <$> foldMapM (fmap First . tryDefaultGroup wanteds) proposals + reportInvalidDefaultedTyVars proposal@(Proposal assignments) + = do { let tvs = fst <$> assignments + ; invalid_tvs <- filterOutM TcS.isUnfilledMetaTyVar tvs + ; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty invalid_tvs) } + +applyDefaultSubst :: [TcTyVar] -> Subst -> TcS () +applyDefaultSubst tvs subst = + do { deep_tvs <- filterM TcS.isUnfilledMetaTyVar $ nonDetEltsUniqSet $ closeOverKinds (mkVarSet tvs) + ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv) + } + +tryDefaultGroup :: [Ct] -- ^ check these are solved by defaulting + -> Proposal -- ^ defaulting type assignments to try + -> TcS (Maybe ([TcTyVar], Subst)) -- ^ successful substitutions, *not* reflected in ty_binds +tryDefaultGroup wanteds (Proposal assignments) + | let (tvs, default_tys) = unzip assignments + , Just subst <- tcMatchTyKis (mkTyVarTys tvs) default_tys + -- Make sure the kinds match too; hence this call to tcMatchTyKi + -- E.g. suppose the only constraint was (Typeable k (a::k)) + -- With the addition of polykinded defaulting we also want to reject + -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here. + = do { lcl_env <- TcS.getLclEnv + ; tc_lvl <- TcS.getTcLevel + ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env) + new_wtd_ct :: WantedCtEvidence -> TcS Ct + new_wtd_ct (WantedCt { ctev_pred = wtd_pred, ctev_rewriters = rws }) = + mkNonCanonical . CtWanted <$> + -- NB: equality constraints are possible, + -- due to type defaulting plugins + newWantedNC loc rws (substTy subst wtd_pred) + ; new_wanteds <- sequence [ new_wtd_ct wtd + | CtWanted wtd <- map ctEvidence wanteds + ] + ; residual <- solveSimpleWanteds (listToBag new_wanteds) + ; return $ if isEmptyWC residual then Just (tvs, subst) else Nothing } + + | otherwise + = return Nothing + +errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS () +errInvalidDefaultedTyVar wanteds (Proposal assignments) problematic_tvs + = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems + where + proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) assignments + tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs + tidy_wanteds = map (tidyCt tidy_env) $ flattenWC wanteds + tidy_assignments = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- assignments] + tidy_problems = fmap (tidyTyCoVarOcc tidy_env) problematic_tvs + + flattenWC :: WantedConstraints -> [Ct] + flattenWC (WC { wc_simple = cts, wc_impl = impls }) + = ctsElts cts ++ concatMap (flattenWC . ic_wanted) impls + +-- In interactive mode, or with -XExtendedDefaultRules, +-- we default Show a to Show () to avoid gratuitous errors on "show []" +isInteractiveClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isInteractiveClass ovl_strings cls + = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys) + + -- isNumClass adds IsString to the standard numeric classes, + -- when -XOverloadedStrings is enabled +isNumClass :: Bool -- -XOverloadedStrings? + -> Class -> Bool +isNumClass ovl_strings cls + = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + + +{- +Note [Avoiding spurious errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing the unification for defaulting, we check for skolem +type variables, and simply don't default them. For example: + f = (*) -- Monomorphic + g :: Num a => a -> a + g x = f x x +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num a) context arising from f's definition; +we try to unify a with Int (to default it), but find that it's +already been unified with the rigid variable from g's type sig. + +Note [Multi-parameter defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XExtendedDefaultRules, we default only based on single-variable +constraints, but do not exclude from defaulting any type variables which also +appear in multi-variable constraints. This means that the following will +default properly: + + default (Integer, Double) + + class A b (c :: Symbol) where + a :: b -> Proxy c + + instance A Integer c where a _ = Proxy + + main = print (a 5 :: Proxy "5") + +Note that if we change the above instance ("instance A Integer") to +"instance A Double", we get an error: + + No instance for (A Integer "5") + +This is because the first defaulted type (Integer) has successfully satisfied +its single-parameter constraints (in this case Num). +-} diff --git a/GHC/Tc/Solver/Dict.hs b/GHC/Tc/Solver/Dict.hs --- a/GHC/Tc/Solver/Dict.hs +++ b/GHC/Tc/Solver/Dict.hs @@ -1,51 +1,60 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} -- | Solving Class constraints CDictCan module GHC.Tc.Solver.Dict ( - solveDict, solveDictNC, + solveDict, solveDictNC, solveCallStack, checkInstanceOK, matchLocalInst, chooseInstance, makeSuperClasses, mkStrictSuperClasses, - solveCallStack -- For GHC.Tc.Solver ) where import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Solver.Solve( solveSimpleWanteds ) + import GHC.Tc.Errors.Types import GHC.Tc.Instance.FunDeps -import GHC.Tc.Instance.Class( safeOverlap, matchEqualityInst ) +import GHC.Tc.Instance.Class( matchEqualityInst ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Origin -import GHC.Tc.Types.EvTerm( evCallStack ) import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad import GHC.Tc.Solver.Types import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify( uType ) +import GHC.Tc.Utils.Unify( uType, mightEqualLater ) import GHC.Hs.Type( HsIPName(..) ) import GHC.Core +import GHC.Core.Make import GHC.Core.Type -import GHC.Core.InstEnv ( DFunInstType ) +import GHC.Core.InstEnv ( DFunInstType, ClsInst(..) ) import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Multiplicity ( scaledThing ) import GHC.Core.Unify ( ruleMatchTyKiX ) +import GHC.Types.TyThing( lookupDataCon, lookupId ) +import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Id( mkTemplateLocals ) import GHC.Types.Var.Set -import GHC.Types.SrcLoc import GHC.Types.Var.Env +import GHC.Types.SrcLoc +import GHC.Builtin.Names( srcLocDataConName, pushCallStackName, emptyCallStackName ) + import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Unit.Module + import GHC.Data.Bag import GHC.Driver.DynFlags @@ -55,10 +64,7 @@ import Data.Maybe ( listToMaybe, mapMaybe, isJust ) import Data.Void( Void ) -import Control.Monad.Trans.Maybe( MaybeT, runMaybeT ) -import Control.Monad.Trans.Class( lift ) -import Control.Monad( mzero ) - +import Control.Monad {- ********************************************************************* * * @@ -81,7 +87,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 @@ -95,30 +101,9 @@ ; doTopFunDepImprovement dict_ct - ; tryLastResortProhibitedSuperClass dict_ct ; simpleStage (updInertDicts dict_ct) ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } -updInertDicts :: DictCt -> TcS () -updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) - = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) - - ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys - -> -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] - -- Update /both/ inert_cans /and/ inert_solved_dicts. - updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> - inerts { inert_cans = updDicts (filterDicts (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 - 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: -- * expand superclasses @@ -136,29 +121,29 @@ -- doNotExpand: We have already expanded superclasses for /this/ dict -- so set the fuel to doNotExpand to avoid repeating expansion - | CtWanted { ctev_rewriters = rewriters } <- ev + | CtWanted (WantedCt { ctev_rewriters = rws }) <- ev , Just ip_name <- isCallStackPred cls tys - , isPushCallStackOrigin orig + , Just fun_fs <- isPushCallStackOrigin_maybe orig -- If we're given a CallStack constraint that arose from a function -- call, we need to push the current call-site onto the stack instead -- of solving it directly from a given. -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types + -- and Note [Solving CallStack constraints] = Stage $ do { -- First we emit a new constraint that will capture the -- given CallStack. + let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name)) -- We change the origin to IPOccOrigin so -- this rule does not fire again. -- See Note [Overview of implicit CallStacks] -- in GHC.Tc.Types.Evidence - ; new_ev <- newWantedEvVarNC new_loc rewriters pred + ; new_ev <- CtWanted <$> newWantedEvVarNC new_loc rws pred -- Then we solve the wanted by pushing the call-site -- onto the newly emitted CallStack - ; let ev_cs = EvCsPushCall (callStackOriginFS orig) - (ctLocSpan loc) (ctEvExpr new_ev) + ; let ev_cs = EvCsPushCall fun_fs (ctLocSpan loc) (ctEvExpr new_ev) ; solveCallStack ev ev_cs ; continueWith (DictCt { di_ev = new_ev, di_cls = cls @@ -174,24 +159,101 @@ -- See Invariants in `CCDictCan.cc_pend_sc` ; continueWith (DictCt { di_ev = ev, di_cls = cls , di_tys = tys, di_pend_sc = fuel }) } + where loc = ctEvLoc ev orig = ctLocOrigin loc pred = ctEvPred ev +{- ********************************************************************* +* * +* Implicit parameters and call stacks +* * +********************************************************************* -} + solveCallStack :: CtEvidence -> EvCallStack -> TcS () -- Also called from GHC.Tc.Solver when defaulting call stacks solveCallStack ev ev_cs -- We're given ev_cs :: CallStack, but the evidence term should be a -- dictionary, so we have to coerce ev_cs to a dictionary for -- `IP ip CallStack`. See Note [Overview of implicit CallStacks] - = do { cs_tm <- evCallStack ev_cs - ; let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) - ; setEvBindIfWanted ev True ev_tm } + = do { inner_stk <- evCallStack pred ev_cs + ; let ev_tm = EvExpr (evWrapIPE pred inner_stk) + ; setEvBindIfWanted ev EvCanonical ev_tm } + -- EvCanonical: see Note [CallStack and ExceptionContext hack] + where + pred = ctEvPred ev +-- Dictionary for CallStack implicit parameters +evCallStack :: TcPredType -> EvCallStack -> TcS EvExpr +-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +evCallStack _ EvCsEmpty + = Var <$> lookupId emptyCallStackName +evCallStack pred (EvCsPushCall fs loc tm) + = do { df <- getDynFlags + ; m <- getModule + ; srcLocDataCon <- lookupDataCon srcLocDataConName + ; let platform = targetPlatform df + mkSrcLoc l = mkCoreConWrapApps srcLocDataCon <$> + sequence [ mkStringExprFS (unitFS $ moduleUnit m) + , mkStringExprFS (moduleNameFS $ moduleName m) + , mkStringExprFS (srcSpanFile l) + , return $ mkIntExprInt platform (srcSpanStartLine l) + , return $ mkIntExprInt platform (srcSpanStartCol l) + , return $ mkIntExprInt platform (srcSpanEndLine l) + , return $ mkIntExprInt platform (srcSpanEndCol l) + ] -{- Note [Shadowing of implicit parameters] + ; push_cs_id <- lookupId pushCallStackName + ; name_expr <- mkStringExprFS fs + ; loc_expr <- mkSrcLoc loc + -- At this point tm :: IP sym CallStack + -- but we need the actual CallStack to pass to pushCS, + -- so we use evUwrapIP to strip the dictionary wrapper + -- See Note [Overview of implicit CallStacks] + ; let outer_stk = evUnwrapIPE pred tm + ; return (mkCoreApps (Var push_cs_id) + [mkCoreTup [name_expr, loc_expr], outer_stk]) } + +{- Note [Solving CallStack constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence. + +Suppose f :: HasCallStack => blah. Then + +* Each call to 'f' gives rise to + [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f + with a CtOrigin that says "OccurrenceOf f". + Remember that HasCallStack is just shorthand for + IP "callStack" CallStack + See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + +* We canonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by + pushing the call-site info on the stack, and changing the CtOrigin + to record that has been done. + Bind: s1 = pushCallStack s2 + [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin + +* Then, and only then, we can solve the constraint from an enclosing + Given. + +So we must be careful /not/ to solve 's1' from the Givens. We guarantee +this by canonicalising before looking up in the inert set. + +Note [CallStack and ExceptionContext hack] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It isn't really right that we treat CallStack and ExceptionContext dictionaries +as canonical, in the sense of Note [Coherence and specialisation: overview]. +They definitely are not! + +But if we use EvNonCanonical here we get lots of + nospec (error @Int) dict string +(since `error` takes a HasCallStack dict), and that isn't bottoming (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: @@ -199,7 +261,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 @@ -219,7 +281,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 explorered. + implicit parameter constraints) is not well explored. Example in #14218, and #23761 @@ -350,6 +412,11 @@ pattern matching. Its compile-time allocation decreased by 40% when I added the "replace" rather than "add" semantics.) + We achieve this by + (a) not expanding superclasses for equality classes at all; + see the `isEqualityClass` test in `mk_strict_superclasses` + (b) special logic to solve (t1 ~ t2) in `solveEqualityDict`. + (EQC2) Faced with [W] t1 ~ t2, it's always OK to reduce it to [W] t1 ~# t2, without worrying about Note [Instance and Given overlap]. Why? Because if we had [G] s1 ~ s2, then we'd get the superclass [G] s1 ~# s2, and @@ -399,27 +466,29 @@ -} solveEqualityDict :: CtEvidence -> Class -> [Type] -> SolverStage Void +-- See Note [Solving equality classes] -- Precondition: (isEqualityClass cls) True, so cls is (~), (~~), or Coercible solveEqualityDict ev cls tys - | CtWanted { ctev_dest = dest } <- ev + | CtWanted (WantedCt { ctev_dest = dest }) <- ev = Stage $ - do { let (data_con, role, t1, t2) = matchEqualityInst cls tys + do { let (role, t1, t2) = matchEqualityInst cls tys -- Unify t1~t2, putting anything that can't be solved -- immediately into the work list ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> uType uenv t1 t2 -- Set d :: (t1~t2) = Eq# co - ; setWantedEvTerm dest True $ - evDataConApp data_con tys [Coercion co] + ; setWantedEvTerm dest EvCanonical $ + evDictApp cls tys [Coercion co] ; stopWith ev "Solved wanted lifted equality" } - | CtGiven { ctev_evar = ev_id, ctev_loc = loc } <- ev + | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass = Stage $ - do { let sc_pred = classMethodInstTy sel_id tys + do { let loc = ctEvLoc ev + sc_pred = classMethodInstTy sel_id tys ev_expr = EvExpr $ Var sel_id `mkTyApps` tys `App` evId ev_id ; given_ev <- newGivenEvVar loc (sc_pred, ev_expr) - ; startAgainWith (mkNonCanonical given_ev) } + ; startAgainWith (mkNonCanonical $ CtGiven given_ev) } | otherwise = pprPanic "solveEqualityDict" (ppr cls) @@ -462,30 +531,24 @@ case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) } ** NB: It is important to emphasize that all this is purely an optimization: -** exactly the same programs should typecheck with or without this -** procedure. - -Solving fully -~~~~~~~~~~~~~ -There is a reason why the solver does not simply try to solve such -constraints with top-level instances. If the solver finds a relevant -instance declaration in scope, that instance may require a context -that can't be solved for. A good example of this is: - - f :: Ord [a] => ... - f x = ..Need Eq [a]... +** exactly the same programs should typecheck with or without this procedure. -If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would -be left with the obligation to solve the constraint Eq a, which we cannot. So we -must be conservative in our attempt to use an instance declaration to solve the -[W] constraint we're interested in. +Consider + f :: Ord [a] => ... + f x = ..Need Eq [a]... +We could use the Eq [a] superclass of the Ord [a], or we could use the top-level +instance `Eq a => Eq [a]`. But if we did the latter we'd be stuck with an +insoluble constraint (Eq a). -Our rule is that we try to solve all of the instance's subgoals -recursively all at once. Precisely: We only attempt to solve -constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci -are themselves class constraints of the form `C1', ... Cm' => C' t1' -... tn'` and we only succeed if the entire tree of constraints is -solvable from instances. +----------------------------------- +So the ShortCutSolving plan is this: + If we could solve a constraint from a local Given, + try first to /completely/ solve the constraint + using only top-level instances, + /without/ using any local Givens. + - If that succeeds, use it + - If not, use the local Given +----------------------------------- An example that succeeds: @@ -511,7 +574,8 @@ f :: C [a] b => b -> Bool f x = m x == [] -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: +Which, because solving `Eq [a]` demands `Eq a` which we cannot solve. so short-cut +solving fails and we use the superclass of C: f :: forall a b. C [a] b => b -> Bool f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> @@ -521,24 +585,57 @@ (m @ [a] @ b $dC eta) (GHC.Types.[] @ a) -Note [Shortcut solving: type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (#13943) - class Take (n :: Nat) where ... - instance {-# OVERLAPPING #-} Take 0 where .. - instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. +The moving parts are relatively simple: -And we have [W] Take 3. That only matches one instance so we get -[W] Take (3-1). Really we should now rewrite to reduce the (3-1) to 2, and -so on -- but that is reproducing yet more of the solver. Sigh. For now, -we just give up (remember all this is just an optimisation). +* To attempt to solve the constraint completely, we just recursively + call the constraint solver. See the use of `tryShortCutTcS` in + `tcShortCutSolver`. -But we must not just naively try to lookup (Take (3-1)) in the -InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a -unique match on the (Take n) instance. That leads immediately to an -infinite loop. Hence the check that 'preds' have no type families -(isTyFamFree). +* When this attempted recursive solving, in `tryShortCutTcS`, we + - start with an empty inert set: no Givens and no Wanteds + - set a special mode `TcSShortCut`, which signals that we are trying to solve + using only top-level instances. +* When in TcSShortCut mode, since there are no Givens we can short-circuit; + these are all just optimisations: + - `tryInertDicts` + - `GHC.Tc.Solver.Monad.lookupInertDict` + - `noMatchableGivenDicts` + - `matchLocalInst` + - `GHC.Tc.Solver.Solve.runTcPluginsWanted` + +* In `GHC.Tc.Solver.Instance.Class.matchInstEnv`: when short-cut solving, + don't pick overlappable top-level instances + +Some wrinkles: + +(SCS1) Note [Shortcut solving: incoherence] + +(SCS2) The short-cut solver just uses the solver recursively, so we get its + full power: + + * We need to be able to handle recursive super classes. The + solved_dicts state ensures that we remember what we have already + tried to solve to avoid looping. + + * As #15164 showed, it can be important to exploit sharing between + goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; + and to solve G2 we may need H. If we don't spot this sharing we may + solve H twice; and if this pattern repeats we may get exponentially bad + behaviour. + + * Suppose we have (#13943) + class Take (n :: Nat) where ... + instance {-# OVERLAPPING #-} Take 0 where .. + instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where .. + + And we have [W] Take 3. That only matches one instance so we get + [W] Take (3-1). Then we should reduce the (3-1) to 2, and continue. + +(SCS3) When doing short-cut solving we can (and should) inherit the `solved_dicts` + of the caller (#15164). You might worry about having a solved-dict that uses + a Given -- but that too will have been subject to short-cut solving so it's fine. + Note [Shortcut solving: incoherence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This optimization relies on coherence of dictionaries to be correct. When we @@ -603,38 +700,7 @@ IncoherentInstances is `1`. If we were to do the optimization, the output of `main` would be `2`. -Note [Shortcut try_solve_from_instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The workhorse of the short-cut solver is - try_solve_from_instance :: (EvBindMap, DictMap CtEvidence) - -> CtEvidence -- Solve this - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) -Note that: -* The CtEvidence is the goal to be solved - -* The MaybeT manages early failure if we find a subgoal that - cannot be solved from instances. - -* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional - state that allows try_solve_from_instance to augment the evidence - bindings and inert_solved_dicts as it goes. - - If it succeeds, we commit all these bindings and solved dicts to the - main TcS InertSet. If not, we abandon it all entirely. - -Passing along the solved_dicts important for two reasons: - -* We need to be able to handle recursive super classes. The - solved_dicts state ensures that we remember what we have already - tried to solve to avoid looping. - -* As #15164 showed, it can be important to exploit sharing between - goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H; - and to solve G2 we may need H. If we don't spot this sharing we may - solve H twice; and if this pattern repeats we may get exponentially bad - behaviour. - Note [No Given/Given fundeps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not create constraints from: @@ -705,145 +771,75 @@ try_inert_dicts :: InertCans -> DictCt -> TcS (StopOrContinue ()) try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys }) - | Just dict_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + | Just dict_i <- lookupInertDict inerts cls tys , let ev_i = dictCtEvidence dict_i loc_i = ctEvLoc ev_i loc_w = ctEvLoc ev_w = -- There is a matching dictionary in the inert set - do { -- First to try to solve it /completely/ from top level instances + do { -- For a Wanted, first to try to solve it /completely/ from top level instances -- See Note [Shortcut solving] - dflags <- getDynFlags - ; short_cut_worked <- shortCutSolver dflags ev_w ev_i - ; if short_cut_worked - then stopWith ev_w "interactDict/solved from instance" + ; short_cut_worked <- tryShortCutSolver (isGiven ev_i) dict_w - -- Next see if we are in "loopy-superclass" land. If so, - -- we don't want to replace the (Given) inert with the - -- (Wanted) work-item, or vice versa; we want to hang on - -- to both, and try to solve the work-item via an instance. - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - else if prohibitedSuperClassSolve loc_i loc_w - then continueWith () - else - do { -- The short-cut solver didn't fire, and loopy superclasses - -- are dealt with, so we can either solve - -- the inert from the work-item or vice-versa. - ; case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of - KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w) - ; setEvBindIfWanted ev_w True (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) - ; updInertCans (updDicts $ delDict dict_w) - ; continueWith () } } } + ; if | short_cut_worked + -> stopWith ev_w "shortCutSolver worked(1)" + -- Next see if we are in "loopy-superclass" land. If so, + -- we don't want to replace the (Given) inert with the + -- (Wanted) work-item, or vice versa; we want to hang on + -- to both, and try to solve the work-item via an instance. + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + | prohibitedSuperClassSolve loc_i loc_w + -> continueWith () + + | otherwise -- We can either solve the inert from the work-item or vice-versa. + -> case solveOneFromTheOther (CDictCan dict_i) (CDictCan dict_w) of + KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr dict_w) + ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i) + ; return $ Stop ev_w (text "Dict equal" <+> ppr dict_w) } + KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr dict_w) + ; setEvBindIfWanted ev_i EvCanonical (ctEvTerm ev_w) + ; updInertCans (updDicts $ delDict dict_w) + ; continueWith () } } + | otherwise = do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys) ; continueWith () } -- See Note [Shortcut solving] -shortCutSolver :: DynFlags - -> CtEvidence -- Work item - -> CtEvidence -- Inert we want to try to replace - -> TcS Bool -- True <=> success -shortCutSolver dflags ev_w ev_i - | isWanted ev_w - , isGiven ev_i - -- We are about to solve a [W] constraint from a [G] constraint. We take - -- a moment to see if we can get a better solution using an instance. - -- Note that we only do this for the sake of performance. Exactly the same - -- programs should typecheck regardless of whether we take this step or - -- not. See Note [Shortcut solving] - - , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627) - - , not (xopt LangExt.IncoherentInstances dflags) - -- If IncoherentInstances is on then we cannot rely on coherence of proofs - -- in order to justify this optimization: The proof provided by the - -- [G] constraint's superclass may be different from the top-level proof. - -- See Note [Shortcut solving: incoherence] - - , gopt Opt_SolveConstantDicts dflags - -- Enabled by the -fsolve-constant-dicts flag - - = do { ev_binds_var <- getTcEvBindsVar - ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $ - getTcEvBindsMap ev_binds_var - ; solved_dicts <- getSolvedDicts - - ; mb_stuff <- runMaybeT $ - try_solve_from_instance (ev_binds, solved_dicts) ev_w - - ; case mb_stuff of - Nothing -> return False - Just (ev_binds', solved_dicts') - -> do { setTcEvBindsMap ev_binds_var ev_binds' - ; setSolvedDicts solved_dicts' - ; return True } } - - | otherwise +tryShortCutSolver :: Bool -- True <=> try the short-cut solver; False <=> don't + -> DictCt -- Work item + -> TcS Bool -- True <=> success +-- We are about to solve a [W] constraint from a [G] constraint. We take +-- a moment to see if we can get a better solution using an instance. +-- Note that we only do this for the sake of performance. Exactly the same +-- programs should typecheck regardless of whether we take this step or +-- not. See Note [Shortcut solving] +tryShortCutSolver try_short_cut dict_w@(DictCt { di_ev = ev_w }) + | not try_short_cut = return False - where - -- This `CtLoc` is used only to check the well-staged condition of any - -- candidate DFun. Our subgoals all have the same stage as our root - -- [W] constraint so it is safe to use this while solving them. - loc_w = ctEvLoc ev_w - - try_solve_from_instance -- See Note [Shortcut try_solve_from_instance] - :: (EvBindMap, DictMap DictCt) -> CtEvidence - -> MaybeT TcS (EvBindMap, DictMap DictCt) - try_solve_from_instance (ev_binds, solved_dicts) ev - | let pred = ctEvPred ev - , ClassPred cls tys <- classifyPredType pred - = do { inst_res <- lift $ matchGlobalInst dflags True cls tys - ; case inst_res of - OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_canonical = canonical - , cir_what = what } - | safeOverlap what - , all isTyFamFree preds -- Note [Shortcut solving: type families] - -> do { let dict_ct = DictCt { di_ev = ev, di_cls = cls - , di_tys = tys, di_pend_sc = doNotExpand } - solved_dicts' = addSolvedDict dict_ct solved_dicts - -- solved_dicts': it is important that we add our goal - -- to the cache before we solve! Otherwise we may end - -- up in a loop while solving recursive dictionaries. - - ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds) - ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred - ; lift $ checkReductionDepth loc' pred - + | otherwise + = do { dflags <- getDynFlags + ; if | CtWanted (WantedCt { ctev_pred = pred_w }) <- ev_w - ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds - -- Emit work for subgoals but use our local cache - -- so we can solve recursive dictionaries. + , not (couldBeIPLike pred_w) -- Not for implicit parameters (#18627) - ; let ev_tm = mk_ev (map getEvExpr evc_vs) - ev_binds' = extendEvBinds ev_binds $ - mkWantedEvBind (ctEvEvId ev) canonical ev_tm + , not (xopt LangExt.IncoherentInstances dflags) + -- If IncoherentInstances is on then we cannot rely on coherence of proofs + -- in order to justify this optimization: The proof provided by the + -- [G] constraint's superclass may be different from the top-level proof. + -- See Note [Shortcut solving: incoherence] - ; foldlM try_solve_from_instance (ev_binds', solved_dicts') $ - freshGoals evc_vs } + , gopt Opt_SolveConstantDicts dflags + -- Enabled by the -fsolve-constant-dicts flag - _ -> mzero } + -> tryShortCutTcS $ -- tryTcS tries to completely solve some contraints + do { residual <- solveSimpleWanteds (unitBag (CDictCan dict_w)) + ; return (isEmptyWC residual) } - | otherwise - = mzero + | otherwise + -> return False } - -- Use a local cache of solved dicts while emitting EvVars for new work - -- We bail out of the entire computation if we need to emit an EvVar for - -- a subgoal that isn't a ClassPred. - new_wanted_cached :: CtEvidence -> CtLoc - -> DictMap DictCt -> TcPredType -> MaybeT TcS MaybeNew - new_wanted_cached ev_w loc cache pty - | ClassPred cls tys <- classifyPredType pty - = lift $ case findDict cache loc_w cls tys of - Just dict_ct -> return $ Cached (ctEvExpr (dictCtEvidence dict_ct)) - Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty - | otherwise = mzero - {- ******************************************************************* * * Top-level reaction for class constraints (CDictCan) @@ -863,8 +859,8 @@ = continueWith () -- See Note [No Given/Given fundeps] - | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached - = do { setEvBindIfWanted ev True (ctEvTerm solved_ev) + | Just solved_ev <- lookupSolvedDict inerts cls xis -- Cached + = do { setEvBindIfWanted ev EvCanonical (ctEvTerm solved_ev) ; stopWith ev "Dict/Top (cached)" } | otherwise -- Wanted, but not cached @@ -872,11 +868,14 @@ ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc ; case lkup_res of OneInst { cir_what = what } - -> do { insertSafeOverlapFailureTcS what work_item - ; updSolvedDicts what work_item - ; chooseInstance ev lkup_res } - _ -> -- NoInstance or NotSure - -- We didn't solve it; so try functional dependencies + -> do { let is_local_given = case what of { LocalInstance -> True; _ -> False } + ; take_shortcut <- tryShortCutSolver is_local_given work_item + ; if take_shortcut + then stopWith ev "shortCutSolver worked(2)" + else do { insertSafeOverlapFailureTcS what work_item + ; updSolvedDicts what work_item + ; chooseInstance ev lkup_res } } + _ -> -- NoInstance or NotSure: we didn't solve it continueWith () } where dict_loc = ctEvLoc ev @@ -894,7 +893,7 @@ (ppr work_item) ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta ; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) + ; emitWorkNC (map CtWanted $ freshGoals evc_vars) ; stopWith work_item "Dict/Top (solved wanted)" } where pred = ctEvPred work_item @@ -909,7 +908,7 @@ -- Returns the CtLoc to used for sub-goals -- Probably also want to call checkReductionDepth checkInstanceOK loc what pred - = do { checkWellStagedDFun loc what pred + = do { checkWellLevelledDFun loc what pred ; return deeper_loc } where deeper_loc = zap_origin (bumpCtLocDepth loc) @@ -931,7 +930,8 @@ -- First check whether there is an in-scope Given that could -- match this constraint. In that case, do not use any instance -- whether top level, or local quantified constraints. --- See Note [Instance and Given overlap] +-- See Note [Instance and Given overlap] and see +-- (IL0) in Note [Rules for instance lookup] in GHC.Core.InstEnv | not (xopt LangExt.IncoherentInstances dflags) , not (isCTupleClass clas) -- It is always safe to unpack constraint tuples @@ -956,12 +956,83 @@ ; return local_res } NoInstance -- No local instances, so try global ones - -> do { global_res <- matchGlobalInst dflags False clas tys + -> do { global_res <- matchGlobalInst dflags clas tys loc + ; warn_custom_warn_instance global_res loc + -- See Note [Implementation of deprecated instances] ; traceTcS "} matchClassInst global result" $ ppr global_res ; return global_res } } where pred = mkClassPred clas tys +-- | Returns True iff there are no Given constraints that might, +-- potentially, match the given class constraint. This is used when checking to see if a +-- Given might overlap with an instance. See Note [Instance and Given overlap] +-- in GHC.Tc.Solver.Dict +noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool +noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys + = not $ anyBag matchable_given $ + findDictsByClass (inert_dicts inert_cans) clas + where + pred_w = mkClassPred clas tys + + matchable_given :: DictCt -> Bool + matchable_given (DictCt { di_ev = ev }) + | CtGiven (GivenCt { ctev_loc = loc_g, ctev_pred = pred_g }) <- ev + = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w + + | otherwise + = False + +{- Note [Implementation of deprecated instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note describes the implementation of the deprecated instances GHC proposal + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0575-deprecated-instances.rst + +In the parser, we parse deprecations/warnings attached to instances: + + instance {-# DEPRECATED "msg" #-} Show X + deriving instance {-# WARNING "msg2" #-} Eq Y + +(Note that non-standalone deriving instance declarations do not support this mechanism.) +(Note that the DEPRECATED and WARNING pragmas can be used here interchangeably.) + +We store the resulting warning message in the extension field of `ClsInstDecl` +(respectively, `DerivDecl`; See Note [Trees That Grow]). + +In `GHC.Tc.TyCl.Instance.tcClsInstDecl` (respectively, `GHC.Tc.Deriv.Utils.newDerivClsInst`), +we pass on that information to `ClsInst` (and eventually store it in `IfaceClsInst` too). + +Next, if we solve a constraint using such an instance, in +`GHC.Tc.Instance.Class.matchInstEnv`, we pass it further into the +`Ghc.Tc.Types.Origin.InstanceWhat`. + +Finally, if the instance solving function `GHC.Tc.Solver.Monad.matchGlobalInst` returns +a `Ghc.Tc.Instance.Class.ClsInstResult` with `Ghc.Tc.Types.Origin.InstanceWhat` containing +a warning, when called from either `matchClassInst` or `shortCutSolver`, we call +`warn_custom_warn_instance` that ultimately emits the warning if needed. + +Note that we only emit a warning when the instance is used in a different module +than it is defined, which keeps the behaviour in line with the deprecation of +top-level identifiers. +-} + +-- | Emits the custom warning for a deprecated instance +-- +-- See Note [Implementation of deprecated instances] +warn_custom_warn_instance :: ClsInstResult -> CtLoc -> TcS () +warn_custom_warn_instance (OneInst{ cir_what = what }) ct_loc + | TopLevInstance{ iw_dfun_id = dfun, iw_warn = Just warn } <- what = do + let mod = nameModule $ getName dfun + this_mod <- getModule + when (this_mod /= mod) + -- We don't emit warnings for usages inside of the same module + -- to prevent it being triggered for instance child declarations + $ ctLocWarnTcS ct_loc + $ TcRnPragmaWarning + { pragma_warning_info = PragmaWarningInstance dfun (ctl_origin ct_loc) + , pragma_warning_msg = warn } +warn_custom_warn_instance _ _ = return () + {- Note [Instance and Given overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Example, from the OutsideIn(X) paper: @@ -1003,7 +1074,7 @@ - natural numbers - Typeable -* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet. +* See also Note [What might equal later?] in GHC.Tc.Utils.Unify * The given-overlap problem is arguably not easy to appear in practice due to our aggressive prioritization of equality solving over other @@ -1072,25 +1143,28 @@ matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult -- Look up the predicate in Given quantified constraints, -- which are effectively just local instance declarations. -matchLocalInst pred loc - = do { inerts@(IS { inert_cans = ics }) <- getInertSet - ; case match_local_inst inerts (inert_insts ics) of - { ([], []) -> do { traceTcS "No local instance for" (ppr pred) - ; return NoInstance } - ; (matches, unifs) -> - do { matches <- mapM mk_instDFun matches - ; unifs <- mapM mk_instDFun unifs +matchLocalInst body_pred loc + = do { -- Look in the inert set for a matching Given quantified constraint + inerts@(IS { inert_cans = ics }) <- getInertSet + ; case match_local_inst inerts (inert_qcis ics) of + { ([], []) -> do { traceTcS "No local instance for" (ppr body_pred) + ; return NoInstance } + ; (matches, unifs) -> + + do { -- Find the best match -- See Note [Use only the best matching quantified constraint] + matches <- mapM mk_instDFun matches + ; unifs <- mapM mk_instDFun unifs ; case dominatingMatch matches of { Just (dfun_id, tys, theta) | all ((theta `impliedBySCs`) . thdOf3) unifs -> 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 + vcat [ text "body_pred:" <+> ppr body_pred , text "result:" <+> ppr result , text "matches:" <+> ppr matches , text "unifs:" <+> ppr unifs ] @@ -1098,13 +1172,13 @@ ; mb_best -> do { traceTcS "Multiple local instances; not committing to any" - $ vcat [ text "pred:" <+> ppr pred + $ vcat [ text "body_pred:" <+> ppr body_pred , text "matches:" <+> ppr matches , text "unifs:" <+> ppr unifs , text "best_match:" <+> ppr mb_best ] ; return NotSure }}}}} where - pred_tv_set = tyCoVarsOfType pred + body_pred_tv_set = tyCoVarsOfType body_pred mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun mk_instDFun (ev, tys) = @@ -1120,18 +1194,21 @@ match_local_inst _inerts [] = ([], []) match_local_inst inerts (qci@(QCI { qci_tvs = qtvs - , qci_pred = qpred + , qci_body = qbody , qci_ev = qev }) - :qcis) - | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) + : qcis) + | isWanted qev -- Skip Wanteds + = match_local_inst inerts qcis + + | let in_scope = mkInScopeSet (qtv_set `unionVarSet` body_pred_tv_set) , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) - emptyTvSubstEnv qpred pred + emptyTvSubstEnv qbody body_pred , let match = (qev, map (lookupVarEnv tv_subst) qtvs) = (match:matches, unifs) | otherwise - = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred)) - (ppr qci $$ ppr pred) + = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType body_pred)) + (ppr qci $$ ppr body_pred) -- ASSERT: unification relies on the -- quantified variables being fresh (matches, this_unif `combine` unifs) @@ -1140,7 +1217,7 @@ qtv_set = mkVarSet qtvs (matches, unifs) = match_local_inst inerts qcis this_unif - | Just subst <- mightEqualLater inerts qpred qloc pred loc + | Just subst <- mightEqualLater inerts qbody qloc body_pred loc = Just (qev, map (lookupTyVar subst) qtvs) | otherwise = Nothing @@ -1310,38 +1387,6 @@ but that doesn't work for the example from #22216. -} -{- ******************************************************************* -* * - Last resort prohibited superclass -* * -**********************************************************************-} - -tryLastResortProhibitedSuperClass :: DictCt -> SolverStage () --- ^ As a last resort, we TEMPORARILY allow a prohibited superclass solve, --- emitting a loud warning when doing so: we might be creating non-terminating --- evidence (as we are in T22912 for example). --- --- See Note [Migrating away from loopy superclass solving] in GHC.Tc.TyCl.Instance. -tryLastResortProhibitedSuperClass dict_ct - = Stage $ do { inerts <- getInertCans - ; last_resort inerts dict_ct } - -last_resort :: InertCans -> DictCt -> TcS (StopOrContinue ()) -last_resort inerts (DictCt { di_ev = ev_w, di_cls = cls, di_tys = xis }) - | let loc_w = ctEvLoc ev_w - orig_w = ctLocOrigin loc_w - , ScOrigin _ NakedSc <- orig_w -- work_item is definitely Wanted - , Just ct_i <- lookupInertDict inerts loc_w cls xis - , let ev_i = dictCtEvidence ct_i - , isGiven ev_i - = do { setEvBindIfWanted ev_w True (ctEvTerm ev_i) - ; ctLocWarnTcS loc_w $ - TcRnLoopySuperclassSolve loc_w (ctEvPred ev_w) - ; return $ Stop ev_w (text "Loopy superclass") } - | otherwise - = continueWith () - - {- ********************************************************************* * * * Functional dependencies, instantiation of equations @@ -1372,16 +1417,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 @@ -1391,20 +1436,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 @@ -1480,7 +1525,7 @@ Decompose to [W] kfresh0 ~ kb0 [W] (yfresh0::kfresh0) ~ (b0::kb0) - Preserve orientiation when decomposing!! + Preserve orientation when decomposing!! (W2) Suppose we happen to tackle the second Wanted from (W1) first. Then in canEqCanLHSHetero we emit a /kind/ equality, as @@ -1657,13 +1702,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) {- ********************************************************************* @@ -1715,7 +1762,7 @@ 1. Eagerly generate superclasses for given (but not wanted) constraints; see Note [Eagerly expand given superclasses]. - This is done using mkStrictSuperClasses in canClassNC, when + This is done using mkStrictSuperClasses in canDictCt, when we take a non-canonical Given constraint and cannonicalise it. However stop if you encounter the same class twice. That is, @@ -1727,7 +1774,7 @@ solveSimpleWanteds; Note [Danger of adding superclasses during solving] However, /do/ continue to eagerly expand superclasses for new /given/ - /non-canonical/ constraints (canClassNC does this). As #12175 + /non-canonical/ constraints (canDictCt does this). As #12175 showed, a type-family application can expand to a class constraint, and we want to see its superclasses for just the same reason as Note [Eagerly expand given superclasses]. @@ -1783,7 +1830,7 @@ our strategy. Consider f :: C a => a -> Bool f x = x==x -Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses +Then canDictCt gets the [G] d1: C a constraint, and eager emits superclasses G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its cc_pend_sc has pending expansion fuel.) When processing d3 we find a match with d1 in the inert set, and we always @@ -1820,11 +1867,11 @@ So we may need to do a little work on the givens to expose the class that has the superclasses. That's why the superclass -expansion for Givens happens in canClassNC. +expansion for Givens happens in canDictCt. This same scenario happens with quantified constraints, whose superclasses are also eagerly expanded. Test case: typecheck/should_compile/T16502b -These are handled in canForAllNC, analogously to canClassNC. +These are handled in canForAllNC, analogously to canDictCt. Note [Why adding superclasses can help] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1912,10 +1959,10 @@ More generally, if we are expanding the superclasses of g0 :: forall tvs. theta => cls tys -and find a superclass constraint +and find a superclass constraint (itself perhaps a quantified constraint) forall sc_tvs. sc_theta => sc_inner_pred we must have a selector - sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred + sel_id :: forall cls_tvs. cls cls_tvs => forall sc_tvs. sc_theta => sc_inner_pred and thus build g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids. @@ -1928,7 +1975,13 @@ g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. sel_id tys (g0 tvs theta_ids) sc_tvs - -} +(NQCS1) Common case. If theta_ids[] we get just + g_sc = /\ tvs. /\sc_tvs. sel_id tys (g0 tvs) sc_tvs + and can eta-reduce even more to + g_sc = /\ tvs. sel_id tys (g0 tvs) + and if tvs=[] we get the straight superclass selection + g_sc = sel_id tys g0 +-} makeSuperClasses :: [Ct] -> TcS [Ct] -- Returns strict superclasses, transitively, see Note [The superclass story] @@ -1948,10 +2001,9 @@ go (CDictCan (DictCt { di_ev = ev, di_cls = cls, di_tys = tys, di_pend_sc = fuel })) = assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always mkStrictSuperClasses fuel ev [] [] cls tys - go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel })) - = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have - -- class pred heads - assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0 always + go (CQuantCan (QCI { qci_body = body_pred, qci_ev = ev, qci_pend_sc = fuel })) + = assertPpr (isClassPred body_pred) (ppr body_pred) $ -- The cts should all have class pred heads + assertFuelPreconditionStrict fuel $ -- fuel needs to be more than 0, always mkStrictSuperClasses fuel ev tvs theta cls tys where (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) @@ -1979,16 +2031,15 @@ -- The caller of this function is supposed to perform fuel book keeping -- Precondition: fuel >= 0 mk_strict_superclasses _ _ _ _ _ cls _ - | isEqualityClass cls + | isEqualityClass cls -- See (EQC1) in Note [Solving equality classes] = return [] -mk_strict_superclasses fuel rec_clss - ev@(CtGiven { ctev_evar = evar, ctev_loc = loc }) - tvs theta cls tys +mk_strict_superclasses fuel rec_clss ev@(CtGiven (GivenCt { ctev_evar = evar })) tvs theta cls tys = -- Given case do { traceTcS "mk_strict" (ppr ev $$ ppr (ctLocOrigin loc)) ; concatMapM do_one_given (classSCSelIds cls) } where + loc = ctEvLoc ev dict_ids = mkTemplateLocals theta this_size = pSizeClassPred cls tys @@ -2003,14 +2054,14 @@ = do { given_ev <- newGivenEvVar sc_loc $ mk_given_desc sel_id sc_pred ; assertFuelPrecondition fuel $ - mk_superclasses fuel rec_clss given_ev tvs theta sc_pred } + mk_superclasses fuel rec_clss (CtGiven given_ev) tvs theta sc_pred } where sc_pred = classMethodInstTy sel_id tys -- See Note [Nested quantified constraint superclasses] mk_given_desc :: Id -> PredType -> (PredType, EvTerm) mk_given_desc sel_id sc_pred - = (swizzled_pred, swizzled_evterm) + = (swizzled_pred, EvExpr swizzled_evterm) where (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred (sc_theta, sc_inner_pred) = splitFunTys sc_rho @@ -2019,17 +2070,18 @@ all_theta = theta `chkAppend` (map scaledThing sc_theta) swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred - -- evar :: forall tvs. theta => cls tys + -- evar :: forall tvs. theta => cls tys -- sel_id :: forall cls_tvs. cls cls_tvs - -- -> forall sc_tvs. sc_theta => sc_inner_pred + -- => forall sc_tvs. sc_theta => sc_inner_pred -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred - swizzled_evterm = EvExpr $ - mkLams all_tvs $ - mkLams dict_ids $ - Var sel_id - `mkTyApps` tys - `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) - `mkVarApps` sc_tvs + swizzled_evterm + | null tvs, null theta -- See wrinkle (NQCS1) + = Var sel_id `mkTyApps` tys `App` evId evar + | otherwise + = mkLams all_tvs $ mkLams dict_ids $ + Var sel_id `mkTyApps` tys + `App` (evId evar `mkVarApps` (tvs ++ dict_ids)) + `mkVarApps` sc_tvs sc_loc | isCTupleClass cls = loc | otherwise = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) } @@ -2059,7 +2111,9 @@ newly_blocked _ = False -- Wanted case -mk_strict_superclasses fuel rec_clss ev tvs theta cls tys +mk_strict_superclasses fuel rec_clss + (CtWanted (WantedCt { ctev_pred = pty, ctev_loc = loc0, ctev_rewriters = rws })) + tvs theta cls tys | all noFreeVarsOfType tys = return [] -- Wanteds with no variables yield no superclass constraints. -- See Note [Improvement from Ground Wanteds] @@ -2069,12 +2123,12 @@ = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ concatMapM do_one (immSuperClasses cls tys) where - loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) + loc = loc0 `updateCtLocOrigin` WantedSuperclassOrigin pty do_one sc_pred = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred) - ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred - ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred } + ; sc_ev <- newWantedNC loc rws sc_pred + ; mk_superclasses fuel rec_clss (CtWanted sc_ev) [] [] sc_pred } {- Note [Improvement from Ground Wanteds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2135,7 +2189,8 @@ -- NB: If there is a loop, we cut off, so we have not -- added the superclasses, hence cc_pend_sc = fuel | otherwise - = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys + = CQuantCan (QCI { qci_tvs = tvs, qci_theta = theta + , qci_body = mkClassPred cls tys , qci_ev = ev, qci_pend_sc = fuel }) @@ -2165,8 +2220,7 @@ dictionary "functions" that are unboxed. Actually it does just about work, but the simplifier ends up with stuff like case (/\a. eq_sel d) of df -> ...(df @Int)... -and fails to simplify that any further. And it doesn't satisfy -isPredTy any more. +and fails to simplify that any further. So for now we simply decline to take superclasses in the quantified case. Instead we have a special case in GHC.Tc.Solver.Equality.tryQCsEqCt diff --git a/GHC/Tc/Solver/Equality.hs b/GHC/Tc/Solver/Equality.hs --- a/GHC/Tc/Solver/Equality.hs +++ b/GHC/Tc/Solver/Equality.hs @@ -1,3112 +1,3383 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE MultiWayIf #-} - -module GHC.Tc.Solver.Equality( - solveEquality - ) where - - -import GHC.Prelude - -import GHC.Tc.Solver.Irred( solveIrred ) -import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) -import GHC.Tc.Solver.Rewrite -import GHC.Tc.Solver.Monad -import GHC.Tc.Solver.InertSet -import GHC.Tc.Solver.Types( findFunEqsByTyCon ) -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Unify -import GHC.Tc.Utils.TcType -import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) -import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) - -import GHC.Core.Type -import GHC.Core.Predicate -import GHC.Core.Class -import GHC.Core.DataCon ( dataConName ) -import GHC.Core.TyCon -import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking -import GHC.Core.Coercion -import GHC.Core.Coercion.Axiom -import GHC.Core.Reduction -import GHC.Core.Unify( tcUnifyTyWithTFs ) -import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck - , lookupFamInstEnvByTyCon ) -import GHC.Core - -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set( anyVarSet ) -import GHC.Types.Name.Reader -import GHC.Types.Basic - -import GHC.Builtin.Types ( anyTypeOfKind ) - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc -import GHC.Utils.Monad -import GHC.Utils.Constants( debugIsOn ) - -import GHC.Data.Pair -import GHC.Data.Bag -import Control.Monad -import Data.Maybe ( isJust, isNothing ) -import Data.List ( zip4 ) - -import qualified Data.Semigroup as S -import Data.Bifunctor ( bimap ) -import Data.Void( Void ) - -{- ********************************************************************* -* * -* Equalities -* * -************************************************************************ - -Note [Canonicalising equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to canonicalise an equality, we look at the structure of the -two types at hand, looking for similarities. A difficulty is that the -types may look dissimilar before rewriting but similar after rewriting. -However, we don't just want to jump in and rewrite right away, because -this might be wasted effort. So, after looking for similarities and failing, -we rewrite and then try again. Of course, we don't want to loop, so we -track whether or not we've already rewritten. - -It is conceivable to do a better job at tracking whether or not a type -is rewritten, but this is left as future work. (Mar '15) - -Note [Decomposing FunTy] -~~~~~~~~~~~~~~~~~~~~~~~~ -can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This -means that we may very well have a FunTy containing a type of some -unknown kind. For instance, we may have, - - FunTy (a :: k) Int - -Where k is a unification variable. So the calls to splitRuntimeRep_maybe may -fail (returning Nothing). In that case we'll fall through, zonk, and try again. -Zonking should fill the variable k, meaning that decomposition will succeed the -second time around. - -Also note that we require the FunTyFlag to match. This will stop -us decomposing - (Int -> Bool) ~ (Show a => blah) -It's as if we treat (->) and (=>) as different type constructors, which -indeed they are! --} - -solveEquality :: CtEvidence -> EqRel -> Type -> Type - -> 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' - - ; case mb_canon of { - - -- An IrredCt equality may be insoluble; but maybe not! - -- E.g. m a ~R# m b is not canonical, but may be - -- solved by a quantified constraint (T15290) - -- See Note [Looking up primitive equalities in quantified constraints] - Left irred_ct -> do { tryQCsIrredEqCt irred_ct - ; solveIrred irred_ct } ; - - Right eq_ct -> do { tryInertEqs eq_ct - ; tryFunDeps eq_ct - ; tryQCsEqCt eq_ct - ; simpleStage (updInertEqs eq_ct) - ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } } - -updInertEqs :: EqCt -> TcS () -updInertEqs eq_ct - = do { kickOutRewritable (KOAfterAdding (eqCtLHS eq_ct)) (eqCtFlavourRole eq_ct) - ; tc_lvl <- getTcLevel - ; updInertCans (addEqToCans tc_lvl eq_ct) } - - -{- ********************************************************************* -* * -* zonkEqTypes -* * -********************************************************************* -} - ---------------------------------- --- | Compare types for equality, while zonking as necessary. Gives up --- as soon as it finds that two types are not equal. --- This is quite handy when some unification has made two --- types in an inert Wanted to be equal. We can discover the equality without --- rewriting, which is sometimes very expensive (in the case of type functions). --- In particular, this function makes a ~20% improvement in test case --- perf/compiler/T5030. --- --- Returns either the (partially zonked) types in the case of --- inequality, or the one type in the case of equality. canEqReflexive is --- a good next step in the 'Right' case. Returning 'Left' is always safe. --- --- NB: This does *not* look through type synonyms. In fact, it treats type --- synonyms as rigid constructors. In the future, it might be convenient --- to look at only those arguments of type synonyms that actually appear --- in the synonym RHS. But we're not there yet. -zonkEqTypes :: CtEvidence -> EqRel -> TcType -> TcType -> SolverStage (Pair TcType) -zonkEqTypes ev eq_rel ty1 ty2 - = Stage $ do { res <- go ty1 ty2 - ; case res of - Left pair -> continueWith pair - Right ty -> canEqReflexive ev eq_rel ty } - where - go :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) - go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 - go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 - go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 - - -- We handle FunTys explicitly here despite the fact that they could also be - -- treated as an application. Why? Well, for one it's cheaper to just look - -- at two types (the argument and result types) than four (the argument, - -- result, and their RuntimeReps). Also, we haven't completely zonked yet, - -- so we may run into an unzonked type variable while trying to compute the - -- RuntimeReps of the argument and result types. This can be observed in - -- testcase tc269. - go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2) - | af1 == af2 - , eqType w1 w2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev (FunTy af1 w1) res_b res_a } - - go ty1@(FunTy {}) ty2 = bale_out ty1 ty2 - go ty1 ty2@(FunTy {}) = bale_out ty1 ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1 - , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2 - = if tc1 == tc2 && tys1 `equalLength` tys2 - -- Crucial to check for equal-length args, because - -- we cannot assume that the two args to 'go' have - -- the same kind. E.g go (Proxy * (Maybe Int)) - -- (Proxy (*->*) Maybe) - -- We'll call (go (Maybe Int) Maybe) - -- See #13083 - then tycon tc1 tys1 tys2 - else bale_out ty1 ty2 - - go ty1 ty2 - | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 - , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2 - = do { res_a <- go ty1a ty2a - ; res_b <- go ty1b ty2b - ; return $ combine_rev mkAppTy res_b res_a } - - go ty1@(LitTy lit1) (LitTy lit2) - | lit1 == lit2 - = return (Right ty1) - - go ty1 ty2 = bale_out ty1 ty2 - -- We don't handle more complex forms here - - bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) - - tyvar :: SwapFlag -> TcTyVar -> TcType - -> TcS (Either (Pair TcType) TcType) - -- Try to do as little as possible, as anything we do here is redundant - -- with rewriting. In particular, no need to zonk kinds. That's why - -- we don't use the already-defined zonking functions - tyvar swapped tv ty - = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> give_up - Indirect ty' -> do { trace_indirect tv ty' - ; unSwap swapped go ty' ty } } - _ -> give_up - where - give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty - - tyvar_tyvar tv1 tv2 - | tv1 == tv2 = return (Right (mkTyVarTy tv1)) - | otherwise = do { (ty1', progress1) <- quick_zonk tv1 - ; (ty2', progress2) <- quick_zonk tv2 - ; if progress1 || progress2 - then go ty1' ty2' - else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } - - trace_indirect tv ty - = traceTcS "Following filled tyvar (zonk_eq_types)" - (ppr tv <+> equals <+> ppr ty) - - quick_zonk tv = case tcTyVarDetails tv of - MetaTv { mtv_ref = ref } - -> do { cts <- readTcRef ref - ; case cts of - Flexi -> return (TyVarTy tv, False) - Indirect ty' -> do { trace_indirect tv ty' - ; return (ty', True) } } - _ -> return (TyVarTy tv, False) - - -- This happens for type families, too. But recall that failure - -- here just means to try harder, so it's OK if the type function - -- isn't injective. - tycon :: TyCon -> [TcType] -> [TcType] - -> TcS (Either (Pair TcType) TcType) - tycon tc tys1 tys2 - = do { results <- zipWithM go tys1 tys2 - ; return $ case combine_results results of - Left tys -> Left (mkTyConApp tc <$> tys) - Right tys -> Right (mkTyConApp tc tys) } - - combine_results :: [Either (Pair TcType) TcType] - -> Either (Pair [TcType]) [TcType] - combine_results = bimap (fmap reverse) reverse . - foldl' (combine_rev (:)) (Right []) - - -- combine (in reverse) a new result onto an already-combined result - combine_rev :: (a -> b -> c) - -> Either (Pair b) b - -> Either (Pair a) a - -> Either (Pair c) c - combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) - combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) - combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) - combine_rev f (Right tys) (Right ty) = Right (f ty tys) - - -{- ********************************************************************* -* * -* canonicaliseEquality -* * -********************************************************************* -} - -canonicaliseEquality - :: 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 - -canonicaliseEquality ev eq_rel ty1 ty2 - = Stage $ do { traceTcS "canonicaliseEquality" $ - vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc False rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 } - -can_eq_nc - :: Bool -- True => both input types are rewritten - -> GlobalRdrEnv -- needed to see which newtypes are in scope - -> FamInstEnvs -- needed to unwrap data instances - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue (Either IrredCt EqCt)) - --- See Note [Comparing nullary type synonyms] in GHC.Core.Type. -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 - --- Expand synonyms first; see Note [Type synonyms and canonicalization] -can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 - --- need to check for reflexivity in the ReprEq case. --- See Note [Eager reflexivity check] --- Check only when rewritten because the zonk_eq_types check in canEqNC takes --- care of the non-rewritten case. -can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _ - | ty1 `tcEqType` ty2 - = canEqReflexive ev ReprEq ty1 - --- When working with ReprEq, unwrap newtypes. --- See Note [Unwrap newtypes first] --- This must be above the TyVarTy case, in order to guarantee (TyEq:N) -can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | ReprEq <- eq_rel - , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 - = can_eq_newtype_nc rdr_env envs ev NotSwapped ty1 stuff1 ty2 ps_ty2 - - | ReprEq <- eq_rel - , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 - = can_eq_newtype_nc rdr_env envs ev IsSwapped ty2 stuff2 ty1 ps_ty1 - --- Then, get rid of casts -can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 - | isNothing (canEqLHS_maybe ty2) -- See (EIK3) in Note [Equalities with incompatible kinds] - = canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 -can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ - | isNothing (canEqLHS_maybe ty1) -- See (EIK3) in Note [Equalities with incompatible kinds] - = canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 - ----------------------- --- Otherwise try to decompose ----------------------- - --- 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) - ; 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 - | af1 == af2 -- See Note [Decomposing FunTy] - = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b) - --- Decompose type constructor applications --- NB: we have expanded type synonyms already -can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ - | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 - -- tcSplitTyConApp_maybe: we want to catch e.g. Maybe Int ~ (Int -> Int) - -- here for better error messages rather than decomposing into AppTys; - -- hence not using a direct match on TyConApp - - , not (isTypeFamilyTyCon tc1 || isTypeFamilyTyCon tc2) - -- A type family at the top of LHS or RHS: we want to fall through - -- to the canonical-LHS cases (look for canEqLHS_maybe) - - -- See (TC1) in Note [Canonicalising TyCon/TyCon equalities] - , 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 - -can_eq_nc _rewritten _rdr_env _envs ev eq_rel - s1@ForAllTy{} _ - s2@ForAllTy{} _ - = can_eq_nc_forall ev eq_rel s1 s2 - --- See Note [Canonicalising type applications] about why we require rewritten types --- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families --- NB: Only decompose AppTy for nominal equality. --- See Note [Decomposing AppTy equalities] -can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _ - | Just (t1, s1) <- tcSplitAppTy_maybe ty1 - , Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev t1 s1 t2 s2 - -------------------- --- Can't decompose. -------------------- - --- No similarity in type structure detected. Rewrite and try again. -can_eq_nc False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 - = -- Rewrite the two types and try again - do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1 - ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2) - ; can_eq_nc True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - ----------------------------- --- Look for a canonical LHS. --- Only rewritten types end up below here. ----------------------------- - --- NB: pattern match on rewritten=True: we want only rewritten types sent to canEqLHS --- This means we've rewritten any variables and reduced any type family redexes --- See also Note [No top-level newtypes on RHS of representational equalities] - -can_eq_nc True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - | Just can_eq_lhs1 <- canEqLHS_maybe ty1 - = do { traceTcS "can_eq1" (ppr ty1 $$ ppr ty2) - ; canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 } - - | Just can_eq_lhs2 <- canEqLHS_maybe ty2 - = do { traceTcS "can_eq2" (ppr ty1 $$ ppr ty2) - ; canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1 } - - -- If the type is TyConApp tc1 args1, then args1 really can't be less - -- than tyConArity tc1. It could be *more* than tyConArity, but then we - -- should have handled the case as an AppTy. That case only fires if - -- _both_ sides of the equality are AppTy-like... but if one side is - -- AppTy-like and the other isn't (and it also isn't a variable or - -- saturated type family application, both of which are handled by - -- can_eq_nc), we're in a failure mode and can just fall through. - ----------------------------- --- Fall-through. Give up. ----------------------------- - --- We've rewritten and the types don't match. Give up. -can_eq_nc True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 - = do { traceTcS "can_eq_nc catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) - ; case eq_rel of -- See Note [Unsolved equalities] - ReprEq -> finishCanWithIrred ReprEqReason ev - NomEq -> finishCanWithIrred ShapeMismatchReason ev } - -- No need to call canEqSoftFailure/canEqHardFailure because they - -- rewrite, and the types involved here are already rewritten - - -{- Note [Unsolved equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have an unsolved equality like - (a b ~R# Int) -that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. -So we want to make it a potentially-soluble Irred not an insoluble one. -Missing this point is what caused #15431 --} - ---------------------------------- -can_eq_nc_forall :: CtEvidence -> EqRel - -> Type -> Type -- LHS and RHS - -> TcS (StopOrContinue (Either IrredCt EqCt)) --- (forall as. phi1) ~ (forall bs. phi2) --- Check for length match of as, bs --- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs] --- But remember also to unify the kinds of as and bs --- (this is the 'go' loop), and actually substitute phi2[as |> cos / bs] --- Remember also that we might have forall z (a:z). blah --- so we must proceed one binder at a time (#13879) - -can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev - = do { let free_tvs = tyCoVarsOfTypes [s1,s2] - (bndrs1, phi1) = tcSplitForAllTyVarBinders s1 - (bndrs2, phi2) = tcSplitForAllTyVarBinders s2 - flags1 = binderFlags bndrs1 - flags2 = binderFlags bndrs2 - ; if not (all2 eqForAllVis flags1 flags2) -- Note [ForAllTy and type equality] - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr flags1, ppr flags2 ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs - ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) - ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ - binderVars bndrs1 - - ; let phi1' = substTy subst1 phi1 - - -- Unify the kinds, extend the substitution - go :: [TcTyVar] -> Subst -> [TyVarBinder] - -> TcS (TcCoercion, Cts) - go (skol_tv:skol_tvs) subst (bndr2:bndrs2) - = do { let tv2 = binderVar bndr2 - ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv) - (substTy subst (tyVarKind tv2)) - ; let subst' = extendTvSubstAndInScope subst tv2 - (mkCastTy (mkTyVarTy skol_tv) kind_co) - -- skol_tv is already in the in-scope set, but the - -- free vars of kind_co are not; hence "...AndInScope" - ; (co, wanteds2) <- go skol_tvs subst' bndrs2 - ; return ( mkForAllCo skol_tv kind_co co - , wanteds1 `unionBags` wanteds2 ) } - - -- Done: unify phi1 ~ phi2 - go [] subst bndrs2 - = assert (null bndrs2) $ - unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2) - - go _ _ _ = panic "cna_eq_nc_forall" -- case (s:ss) [] - - empty_subst2 = mkEmptySubst (getSubstInScope subst1) - - ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ - go skol_tvs empty_subst2 bndrs2 - ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds - - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } - - | otherwise - = do { traceTcS "Omitting decomposition of given polytype equality" $ - pprEq s1 s2 -- See Note [Do not decompose Given polytype equalities] - ; stopWith ev "Discard given polytype equality" } - - where - unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts) - -- This version returns the wanted constraint rather - -- than putting it in the work list - unify loc rewriters role ty1 ty2 - | ty1 `tcEqType` ty2 - = return (mkReflCo role ty1, emptyBag) - | otherwise - = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2 - ; return (co, unitBag (mkNonCanonical wanted)) } - - -{- Note [Unwrap newtypes first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Decomposing newtype equalities] - -Consider - newtype N m a = MkN (m a) -N will get a conservative, Nominal role for its second parameter 'a', -because it appears as an argument to the unknown 'm'. Now consider - [W] N Maybe a ~R# N Maybe b - -If we /decompose/, we'll get - [W] a ~N# b - -But if instead we /unwrap/ we'll get - [W] Maybe a ~R# Maybe b -which in turn gives us - [W] a ~R# b -which is easier to satisfy. - -Conclusion: we must unwrap newtypes before decomposing them. This happens -in `can_eq_newtype_nc` - -We did flirt with making the /rewriter/ expand newtypes, rather than -doing it in `can_eq_newtype_nc`. But with recursive newtypes we want -to be super-careful about expanding! - - newtype A = MkA [A] -- Recursive! - - f :: A -> [A] - f = coerce - -We have [W] A ~R# [A]. If we rewrite [A], it'll expand to - [[[[[...]]]]] -and blow the reduction stack. See Note [Newtypes can blow the stack] -in GHC.Tc.Solver.Rewrite. But if we expand only the /top level/ of -both sides, we get - [W] [A] ~R# [A] -which we can, just, solve by reflexivity. - -So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`. - -This is all very delicate. There is a real risk of a loop in the type checker -with recursive newtypes -- but I think we're doomed to do *something* -delicate, as we're really trying to solve for equirecursive type -equality. Bottom line for users: recursive newtypes do not play well with type -inference for representational equality. See also Section 5.3.1 and 5.3.4 of -"Safe Zero-cost Coercions for Haskell" (JFP 2016). - -See also Note [Decomposing newtype equalities]. - ---- Historical side note --- - -We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply; -see #22519. But that didn't work: see discussion in #22924. Specifically -we got a loop with a minor variation: - f2 :: a -> [A] - f2 = coerce - -Note [Eager reflexivity check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - -and - - [W] X ~R X - -Naively, we would start unwrapping X and end up in a loop. Instead, -we do this eager reflexivity check. This is necessary only for representational -equality because the rewriter technology deals with the similar case -(recursive type families) for nominal equality. - -Note that this check does not catch all cases, but it will catch the cases -we're most worried about, types like X above that are actually inhabited. - -Here's another place where this reflexivity check is key: -Consider trying to prove (f a) ~R (f a). The AppTys in there can't -be decomposed, because representational equality isn't congruent with respect -to AppTy. So, when canonicalising the equality above, we get stuck and -would normally produce a CIrredCan. However, we really do want to -be able to solve (f a) ~R (f a). So, in the representational case only, -we do a reflexivity check. - -(This would be sound in the nominal case, but unnecessary, and I [Richard -E.] am worried that it would slow down the common case.) - - Note [Newtypes can blow the stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - newtype X = MkX (Int -> X) - newtype Y = MkY (Int -> Y) - -and now wish to prove - - [W] X ~R Y - -This Wanted will loop, expanding out the newtypes ever deeper looking -for a solid match or a solid discrepancy. Indeed, there is something -appropriate to this looping, because X and Y *do* have the same representation, -in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized -coercion will ever witness it. This loop won't actually cause GHC to hang, -though, because we check our depth in `can_eq_newtype_nc`. --} - ------------------------- --- | We're able to unwrap a newtype. Update the bits accordingly. -can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs - -> CtEvidence -- ^ :: ty1 ~ ty2 - -> SwapFlag - -> TcType -- ^ ty1 - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' - -> TcType -- ^ ty2 - -> TcType -- ^ ty2, with type synonyms - -> TcS (StopOrContinue (Either IrredCt EqCt)) -can_eq_newtype_nc rdr_env envs ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 - = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ] - - -- Check for blowing our stack, and increase the depth - -- See Note [Newtypes can blow the stack] - ; let loc = ctEvLoc ev - ev' = ev `setCtEvLoc` bumpCtLocDepth loc - ; checkReductionDepth loc ty1 - - -- Next, we record uses of newtype constructors, since coercing - -- through newtypes is tantamount to using their constructors. - ; recordUsedGREs gres - - ; let redn1 = mkReduction co1 ty1' - - ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped - redn1 (mkReflRedn Representational ps_ty2) - - ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 } - ---------- --- ^ Decompose a type application. --- All input types must be rewritten. See Note [Canonicalising type applications] --- Nominal equality only! -can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 - -> Xi -> Xi -- s1 t1 - -> Xi -> Xi -- s2 t2 - -> TcS (StopOrContinue (Either IrredCt EqCt)) - --- AppTys only decompose for nominal equality, so this case just leads --- to an irreducible constraint; see typecheck/should_compile/T10494 --- See Note [Decomposing AppTy equalities] -can_eq_app ev s1 t1 s2 t2 - | CtWanted { ctev_dest = dest } <- ev - = do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1 - , text "s2:" <+> ppr s2, text "t2:" <+> ppr t2 - , text "vis:" <+> ppr (isNextArgVisible s1) ]) - ; (co,_,_) <- wrapUnifierTcS ev Nominal $ \uenv -> - -- Unify arguments t1/t2 before function s1/s2, because - -- the former have smaller kinds, and hence simpler error messages - -- c.f. GHC.Tc.Utils.Unify.uType (go_app) - do { let arg_env = updUEnvLoc uenv (adjustCtLoc (isNextArgVisible s1) False) - ; co_t <- uType arg_env t1 t2 - ; co_s <- uType uenv s1 s2 - ; return (mkAppCo co_s co_t) } - ; setWantedEq dest co - ; stopWith ev "Decomposed [W] AppTy" } - - -- If there is a ForAll/(->) mismatch, the use of the Left coercion - -- below is ill-typed, potentially leading to a panic in splitTyConApp - -- Test case: typecheck/should_run/Typeable1 - -- We could also include this mismatch check above (for W and D), but it's slow - -- and we'll get a better error message not doing it - | s1k `mismatches` s2k - = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) - - | CtGiven { ctev_evar = evar } <- ev - = do { let co = mkCoVarCo evar - co_s = mkLRCo CLeft co - co_t = mkLRCo CRight co - ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 - , evCoercion co_s ) - ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 - , evCoercion co_t ) - ; emitWorkNC [evar_t] - ; startAgainWith (mkNonCanonical evar_s) } - - where - loc = ctEvLoc ev - - s1k = typeKind s1 - s2k = typeKind s2 - - k1 `mismatches` k2 - = isForAllTy k1 && not (isForAllTy k2) - || not (isForAllTy k1) && isForAllTy k2 - ------------------------ --- | Break apart an equality over a casted type --- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) -canEqCast :: Bool -- are both types rewritten? - -> GlobalRdrEnv -> FamInstEnvs - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue (Either IrredCt EqCt)) -canEqCast rewritten rdr_env envs ev eq_rel swapped ty1 co1 ty2 ps_ty2 - = do { traceTcS "Decomposing cast" (vcat [ ppr ev - , ppr ty1 <+> text "|>" <+> ppr co1 - , ppr ps_ty2 ]) - ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkGReflLeftRedn role ty1 co1) - (mkReflRedn role ps_ty2) - ; can_eq_nc rewritten rdr_env envs new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel - ------------------------- -canTyConApp :: CtEvidence -> EqRel - -> Bool -- Both TyCons are generative - -> TyCon -> [TcType] - -> 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 - | tc1 == tc2 - , tys1 `equalLength` tys2 - = do { inerts <- getInertSet - ; if can_decompose inerts - then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - else canEqSoftFailure ev eq_rel ty1 ty2 } - - -- See Note [Skolem abstract data] in GHC.Core.Tycon - | tyConSkolem tc1 || tyConSkolem tc2 - = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) - ; finishCanWithIrred AbstractTyConReason ev } - - | otherwise -- Different TyCons - = if both_generative -- See (TC2) and (TC3) in - -- Note [Canonicalising TyCon/TyCon equalities] - then canEqHardFailure ev ty1 ty2 - else canEqSoftFailure ev eq_rel ty1 ty2 - 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 - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (assert (eq_rel == ReprEq) $ - -- assert: isInjectiveTyCon is always True for Nominal except - -- for type synonyms/families, neither of which happen here - -- Moreover isInjectiveTyCon is True for Representational - -- for algebraic data types. So we are down to newtypes - -- and data families. - ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts) - -- See Note [Decomposing newtype equalities] (EX2) - -{- Note [Canonicalising TyCon/TyCon equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - type family TF a where TF Char = Bool - data family DF a - newtype instance DF Bool = MkDF Int - -Suppose we are canonicalising [W] Int ~R# DF (TF a). Then - -(TC1) We might have an inert Given (a ~# Char), so if we rewrote the wanted - (i.e. went around again in `can_eq_nc` with `rewritten`=True, we'd get - [W] Int ~R# DF Bool - and then the `tcTopNormaliseNewTypeTF_maybe` call would fire and - we'd unwrap the newtype. So we must do that "go round again" bit. - Hence the complicated guard (rewritten || both_generative) in `can_eq_nc`. - -(TC2) If we can't rewrite `a` yet, we'll finish with an unsolved - [W] Int ~R# DF (TF a) - in the inert set. But we must use canEqSoftFailure, not canEqHardFailure, - because it might be solved "later" when we learn more about `a`. - Hence the use of `both_generative` in `canTyConApp`. - -(TC3) Here's another example: - [G] Age ~R# Int - where Age's constructor is not in scope. We don't want to report - an "inaccessible code" error in the context of this Given! So again - we want `canEqSoftFailure`. - - For example, see typecheck/should_compile/T10493, repeated here: - import Data.Ord (Down) -- no constructor - foo :: Coercible (Down Int) Int => Down Int -> Int - foo = coerce - - That should compile, but only because we use canEqSoftFailure and - not canEqHardFailure. - -Note [Fast path when decomposing TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see (T s1 t1 ~ T s2 t2), then we can just decompose to - (s1 ~ s2, t1 ~ t2) -and push those back into the work list. But if - s1 = K k1 s2 = K k2 -then we will just decompose s1~s2, and it might be better to -do so on the spot. An important special case is where s1=s2, -and we get just Refl. - -So canDecomposableTyConAppOK uses wrapUnifierTcS etc to short-cut -that work. See also Note [Work-list ordering]. - -Note [Decomposing TyConApp equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - [G/W] T ty1 ~r T ty2 -Can we decompose it, and replace it by - [G/W] ty1 ~r' ty2 -and if so what role is r'? (In this Note, all the "~" are primitive -equalities "~#", but I have dropped the noisy "#" symbols.) Lots of -background in the paper "Safe zero-cost coercions for Haskell". - -This Note covers the topic for - * Datatypes - * Newtypes - * Data families -For the rest: - * Type synonyms: are always expanded - * Type families: see Note [Decomposing type family applications] - * AppTy: see Note [Decomposing AppTy equalities]. - ----- Roles of the decomposed constraints ---- -For a start, the role r' will always be defined like this: - * If r=N then r' = N - * If r=R then r' = role of T's first argument - -For example: - data TR a = MkTR a -- Role of T's first arg is Representational - data TN a = MkTN (F a) -- Role of T's first arg is Nominal - -The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument -role r' for a TyCon T at role r. E.g. - tyConRolesX Nominal TR = [Nominal] - tyConRolesX Representational TR = [Representational] - ----- Soundness and completeness ---- -For Givens, for /soundness/ of decomposition we need, forall ty1,ty2: - T ty1 ~r T ty2 ===> ty1 ~r' ty2 -Here "===>" means "implies". That is, given evidence for (co1 : T ty1 ~r T co2) -we can produce evidence for (co2 : ty1 ~r' ty2). But in the solver we -/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs -thereby. So for /completeness/ of decomposition we also need the reverse: - ty1 ~r' ty2 ===> T ty1 ~r T ty2 - -For Wanteds, for /soundness/ of decomposition we need: - ty1 ~r' ty2 ===> T ty1 ~r T ty2 -because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and -from that we want to derive evidence (T co2 : T ty1 ~r T ty2). -For /completeness/ of decomposition we need the reverse implication too, -else we may decompose to a new proof obligation that is stronger than -the one we started with. See Note [Decomposing newtype equalities]. - ----- Injectivity ---- -When do these bi-implications hold? In one direction it is easy. -We /always/ have - ty1 ~r' ty2 ===> T ty1 ~r T ty2 -This is the CO_TYCONAPP rule of the paper (Fig 5); see also the -TyConAppCo case of GHC.Core.Lint.lintCoercion. - -In the other direction, we have - T ty1 ~r T ty2 ==> ty1 ~r' ty2 if T is /injective at role r/ -This is the very /definition/ of injectivity: injectivity means result -is the same => arguments are the same, modulo the role shift. -See comments on GHC.Core.TyCon.isInjectiveTyCon. This is also -the CO_NTH rule in Fig 5 of the paper, except in the paper only -newtypes are non-injective at representation role, so the rule says "H -is not a newtype". - -Injectivity is a bit subtle: - Nominal Representational - Datatype YES YES - Newtype YES NO{1} - Data family YES NO{2} - -{1} Consider newtype N a = MkN (F a) -- Arg has Nominal role - Is it true that (N t1) ~R (N t2) ==> t1 ~N t2 ? - No, absolutely not. E.g. - type instance F Int = Int; type instance F Bool = Char - Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char! - - See Note [Decomposing newtype equalities] - -{2} We must treat data families precisely like newtypes, because of the - possibility of newtype instances. See also - Note [Decomposing newtype equalities]. See #10534 and - test case typecheck/should_fail/T10534. - ----- Takeaway summary ----- -For sound and complete decomposition, we simply need injectivity; -that is for isInjectiveTyCon to be true: - -* At Nominal role, isInjectiveTyCon is True for all the TyCons we are - considering in this Note: datatypes, newtypes, and data families. - -* For Givens, injectivity is necessary for soundness; completeness has no - side conditions. - -* For Wanteds, soundness has no side conditions; but injectivity is needed - for completeness. See Note [Decomposing newtype equalities] - -This is implemented in `can_decompose` in `canTyConApp`; it looks at -injectivity, just as specified above. - -Note [Work-list ordering] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider decomposing a TyCon equality - - (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k1) - -This gives rise to 2 equalities in the solver worklist - - (1) [W] k_fresh ~ k1 - (2) [W] t1::k_fresh ~ t2::k1 - -We would like to solve (1) before looking at (2), so that we don't end -up in the complexities of canEqLHSHetero. To do this: - -* `canDecomposableTyConAppOK` calls `uType` on the arguments - /left-to-right/. See the call to zipWith4M in that function. - -* `uType` keeps the bag of emitted constraints in the same - left-to-right order. See the use of `snocBag` in `uType_defer`. - -* `wrapUnifierTcS` adds the bag of deferred constraints from - `do_unifications` to the work-list using `extendWorkListEqs`. - -* `extendWorkListEqs` and `selectWorkItem` together arrange that the - list of constraints given to `extendWorkListEqs` is processed in - left-to-right order. - -This is not a very big deal. It reduces the number of solver steps -in the test RaeJobTalk from 1830 to 1815, a 1% reduction. But still, -it doesn't cost anything either. - -Note [Decomposing type family applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose we have - [G/W] (F ty1) ~r (F ty2) -This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2. - -We never decompose to - [G/W] ty1 ~r' ty2 - -Instead - -* For Givens we do nothing. Injective type families have no corresponding - evidence of their injectivity, so we cannot decompose an - injective-type-family Given. - -* For Wanteds, for the Nominal role only, we emit new Wanteds rather like - functional dependencies, for each injective argument position. - - E.g type family F a b -- injective in first arg, but not second - [W] (F s1 t1) ~N (F s2 t2) - Emit new Wanteds - [W] s1 ~N s2 - But retain the existing, unsolved constraint. - -Note [Decomposing newtype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note also applies to data families, which we treat like -newtype in case of 'newtype instance'. - -As Note [Decomposing TyConApp equalities] describes, if N is injective -at role r, we can do this decomposition? - [G/W] (N ty1) ~r (N ty2) to [G/W] ty1 ~r' ty2 - -For a Given with r=R, the answer is a solid NO: newtypes are not injective at -representational role, and we must not decompose, or we lose soundness. -Example is wrinkle {1} in Note [Decomposing TyConApp equalities]. - -For a Wanted with r=R, since newtypes are not injective at representational -role, decomposition is sound, but we may lose completeness. Nevertheless, -if the newtype is abstract (so can't be unwrapped) we can only solve -the equality by (a) using a Given or (b) decomposition. If (a) is impossible -(e.g. no Givens) then (b) is safe albeit potentially incomplete. - -There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete: - -* Incompleteness example (EX1): unwrap first - newtype Nt a = MkNt (Id a) - type family Id a where Id a = a - - [W] Nt Int ~R Nt Age - - Because of its use of a type family, Nt's parameter will get inferred to - 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 - 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 - 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 - - [G] Nt t1 ~R Nt t2 - [W] Nt alpha ~R Nt beta - - We *don't* want to decompose to [W] alpha ~R beta, because it's possible - that alpha and beta aren't representationally equal. And if we figure - out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted - from the Given. This is somewhat similar to the question of overlapping - 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 - equalities that could later solve it. - - But what precisely does it mean to say "any Given equalities that could - later solve it"? - - In #22924 we had - [G] f a ~R# a [W] Const (f a) a ~R# Const a a - where Const is an abstract newtype. If we decomposed the newtype, we - could solve. Not-decomposing on the grounds that (f a ~R# a) might turn - into (Const (f a) a ~R# Const a a) seems a bit silly. - - In #22331 we had - [G] N a ~R# N b [W] N b ~R# N a - (where N is abstract so we can't unwrap). Here we really /don't/ want to - decompose, because the /only/ way to solve the Wanted is from that Given - (with a Sym). - - In #22519 we had - [G] a <= b [W] IO Age ~R# IO Int - - (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=) - is a type-level comparison on Nats). Here we /must/ decompose, despite the - existence of an Irred Given, or we will simply be stuck. (Side note: We - flirted with deep-rewriting of newtypes (see discussion on #22519 and - !9623) but that turned out not to solve #22924, and also makes type - inference loop more often on recursive newtypes.) - - The currently-implemented compromise is this: - - we decompose [W] N s ~R# N t unless there is a [G] N s' ~ N t' - - that is, a Given Irred equality with both sides headed with N. - See the call to noGivenNewtypeReprEqs in canTyConApp. - - This is not perfect. In principle a Given like [G] (a b) ~ (c d), or - even just [G] c, could later turn into N s ~ N t. But since the free - vars of a Given are skolems, or at least untouchable unification - variables, this is extremely unlikely to happen. - - Another worry: there could, just, be a CDictCan with some - un-expanded equality superclasses; but only in some very obscure - recursive-superclass situations. - - Yet another approach (!) is desribed in - Note [Decomposing newtypes a bit more aggressively]. - -Remember: decomposing Wanteds is always /sound/. This Note is -only about /completeness/. - -Note [Decomposing newtypes a bit more aggressively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -IMPORTANT: the ideas in this Note are *not* implemented. Instead, the -current approach is detailed in Note [Decomposing newtype equalities] -and Note [Unwrap newtypes first]. -For more details about the ideas in this Note see - * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549 - * issue #22441 - * discussion on !9282. - -Consider [G] c, [W] (IO Int) ~R (IO Age) -where IO is abstract, and - newtype Age = MkAge Int -- Not abstract -With the above rules, if there any Given Irreds, -the Wanted is insoluble because we can't decompose it. But in fact, -if we look at the defn of IO, roughly, - newtype IO a = State# -> (State#, a) -we can see that decomposing [W] (IO Int) ~R (IO Age) to - [W] Int ~R Age -definitely does not lose completeness. Why not? Because the role of -IO's argment is representational. Hence: - - DecomposeNewtypeIdea: - decompose [W] (N s1 .. sn) ~R (N t1 .. tn) - if the roles of all N's arguments are representational - -If N's arguments really /are/ representational this will not lose -completeness. Here "really are representational" means "if you expand -all newtypes in N's RHS, we'd infer a representational role for each -of N's type variables in that expansion". See Note [Role inference] -in GHC.Tc.TyCl.Utils. - -But the user might /override/ a phantom role with an explicit role -annotation, and then we could (obscurely) get incompleteness. -Consider - - module A( silly, T ) where - newtype T a = MkT Int - type role T representational -- Override phantom role - - silly :: Coercion (T Int) (T Bool) - silly = Coercion -- Typechecks by unwrapping the newtype - - data Coercion a b where -- Actually defined in Data.Type.Coercion - Coercion :: Coercible a b => Coercion a b - - module B where - import A - f :: T Int -> T Bool - f = case silly of Coercion -> coerce - -Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose, -we'll get stuck with (Int ~R Bool). Instead we want to use the -[G] (T Int) ~R (T Bool), which will be in the Irreds. - -Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very -obscure incompleteness (above). But no one is reporting a problem from -the lack of decompostion, so we'll just leave it for now. This long -Note is just to record the thinking for our future selves. - -Note [Decomposing AppTy equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For AppTy all the same questions arise as in -Note [Decomposing TyConApp equalities]. We have - - s1 ~r s2, t1 ~N t2 ==> s1 t1 ~r s2 t2 (rule CO_APP) - s1 t1 ~N s2 t2 ==> s1 ~N s2, t1 ~N t2 (CO_LEFT, CO_RIGHT) - -In the first of these, why do we need Nominal equality in (t1 ~N t2)? -See {2} below. - -For sound and complete solving, we need both directions to decompose. So: -* At nominal role, all is well: we have both directions. -* At representational role, decomposition of Givens is unsound (see {1} below), - and decomposition of Wanteds is incomplete. - -Here is an example of the incompleteness for Wanteds: - - [G] g1 :: a ~R b - [W] w1 :: Maybe b ~R alpha a - [W] w2 :: alpha ~N Maybe - -Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get - - w1 := AppCo w3 w4 - [W] w3 :: Maybe ~R alpha - [W] w4 :: b ~N a - -Note that w4 is *nominal*. A nominal role here is necessary because AppCo -requires a nominal role on its second argument. (See {2} for an example of -why.) Now we are stuck, because w4 is insoluble. On the other hand, if we -see w2 first, setting alpha := Maybe, all is well, as we can decompose -Maybe b ~R Maybe a into b ~R a. - -Another example: - newtype Phant x = MkPhant Int - [W] w1 :: Phant Int ~R alpha Bool - [W] w2 :: alpha ~ Phant - -If we see w1 first, decomposing would be disastrous, as we would then try -to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become - [W] w1' :: Phant Int ~R Phant Bool - -which can then (assuming MkPhant is in scope) be simplified to Int ~R Int, -and all will be well. See also Note [Unwrap newtypes first]. - -Bottom line: -* Always decompose AppTy at nominal role: can_eq_app -* Never decompose AppTy at representational role (neither Given nor Wanted): - the lack of an equation in can_eq_nc - -Extra points -{1} Decomposing a Given AppTy over a representational role is simply - unsound. For example, if we have co1 :: Phant Int ~R a Bool (for - the newtype Phant, above), then we surely don't want any relationship - between Int and Bool, lest we also have co2 :: Phant ~ a around. - -{2} The role on the AppCo coercion is a conservative choice, because we don't - know the role signature of the function. For example, let's assume we could - have a representational role on the second argument of AppCo. Then, consider - - data G a where -- G will have a nominal role, as G is a GADT - MkG :: G Int - newtype Age = MkAge Int - - co1 :: G ~R a -- by assumption - co2 :: Age ~R Int -- by newtype axiom - co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo - - and now co3 can be used to cast MkG to have type G Age, in violation of - the way GADTs are supposed to work (which is to use nominal equality). --} - -canDecomposableTyConAppOK :: CtEvidence -> EqRel - -> TyCon -> [TcType] -> [TcType] - -> TcS (StopOrContinue a) --- Precondition: tys1 and tys2 are the same finite length, hence "OK" -canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 - = assert (tys1 `equalLength` tys2) $ - do { traceTcS "canDecomposableTyConAppOK" - (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2) - ; case ev of - CtWanted { ctev_dest = dest } - -- new_locs and tc_roles are both infinite, so we are - -- guaranteed that cos has the same length as tys1 and tys2 - -- See Note [Fast path when decomposing TyConApps] - -> do { (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> - do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2 - -- zipWith4M: see Note [Work-list ordering] - -- in GHC.Tc.Solved.Equality - ; return (mkTyConAppCo role tc cos) } - ; setWantedEq dest co } - - CtGiven { ctev_evar = evar } - | let ev_co = mkCoVarCo evar - -> emitNewGivens loc - [ (r, ty1, ty2, mkSelCo (SelTyCon i r) ev_co) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - - ; stopWith ev "Decomposed TyConApp" } - - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - - u_arg uenv arg_loc arg_role = uType arg_env - where - arg_env = uenv `setUEnvRole` arg_role - `updUEnvLoc` const arg_loc - - -- Infinite, to allow for over-saturated TyConApps - tc_roles = tyConRoleListX role tc - - -- Add nuances to the location during decomposition: - -- * if the argument is a kind argument, remember this, so that error - -- messages say "kind", not "type". This is determined based on whether - -- the corresponding tyConBinder is named (that is, dependent) - -- * if the argument is invisible, note this as well, again by - -- looking at the corresponding binder - -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't - -- do either of these changes. (Forgetting to do so led to #16188) - -- - -- NB: infinite in length - new_locs = [ adjustCtLocTyConBinder bndr loc - | bndr <- tyConBinders tc ] - ++ repeat loc - -canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag - -> (Type,Type,Type) -- (multiplicity,arg,res) - -> (Type,Type,Type) -- (multiplicity,arg,res) - -> TcS (StopOrContinue a) -canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2) - = do { traceTcS "canDecomposableFunTy" - (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) - ; case ev of - CtWanted { ctev_dest = dest } - -> do { (co, _, _) <- wrapUnifierTcS ev Nominal $ \ uenv -> - do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc - `setUEnvRole` funRole role SelMult - ; mult <- uType mult_env m1 m2 - ; arg <- uType (uenv `setUEnvRole` funRole role SelArg) a1 a2 - ; res <- uType (uenv `setUEnvRole` funRole role SelRes) r1 r2 - ; return (mkNakedFunCo role af mult arg res) } - ; setWantedEq dest co } - - CtGiven { ctev_evar = evar } - | let ev_co = mkCoVarCo evar - -> emitNewGivens loc - [ (funRole role fs, ty1, ty2, mkSelCo (SelFun fs) ev_co) - | (fs, ty1, ty2) <- [ (SelMult, m1, m2) - , (SelArg, a1, a2) - , (SelRes, r1, r2)] ] - - ; stopWith ev "Decomposed TyConApp" } - - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - --- | Call canEqSoftFailure when canonicalizing an equality fails, but if the --- equality is representational, there is some hope for the future. -canEqSoftFailure :: CtEvidence -> EqRel -> TcType -> TcType - -> TcS (StopOrContinue (Either IrredCt a)) -canEqSoftFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqSoftFailure ev ReprEq ty1 ty2 - = do { (redn1, rewriters1) <- rewrite ev ty1 - ; (redn2, rewriters2) <- rewrite ev ty2 - -- We must rewrite the types before putting them in the - -- inert set, so that we are sure to kick them out when - -- new equalities become available - ; traceTcS "canEqSoftFailure with ReprEq" $ - vcat [ ppr ev, ppr redn1, ppr redn2 ] - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; finishCanWithIrred ReprEqReason new_ev } - --- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence -> TcType -> TcType - -> TcS (StopOrContinue (Either IrredCt a)) --- See Note [Make sure that insolubles are fully rewritten] -canEqHardFailure ev ty1 ty2 - = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) - ; (redn1, rewriters1) <- rewriteForErrors ev ty1 - ; (redn2, rewriters2) <- rewriteForErrors ev ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; finishCanWithIrred ShapeMismatchReason new_ev } - -{- -Note [Canonicalising type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (s1 t1) ~ ty2, how should we proceed? -The simple thing is to see if ty2 is of form (s2 t2), and -decompose. - -However, over-eager decomposition gives bad error messages -for things like - a b ~ Maybe c - e f ~ p -> q -Suppose (in the first example) we already know a~Array. Then if we -decompose the application eagerly, yielding - a ~ Maybe - b ~ c -we get an error "Can't match Array ~ Maybe", -but we'd prefer to get "Can't match Array b ~ Maybe c". - -So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of -replacing (a b) by (Array b), before using try_decompose_app to -decompose it. - -Note [Make sure that insolubles are fully rewritten] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When an equality fails, we still want to rewrite the equality -all the way down, so that it accurately reflects - (a) the mutable reference substitution in force at start of solving - (b) any ty-binds in force at this point in solving -See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. -And if we don't do this there is a bad danger that -GHC.Tc.Solver.applyTyVarDefaulting will find a variable -that has in fact been substituted. - -Note [Do not decompose Given polytype equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? -No -- what would the evidence look like? So instead we simply discard -this given evidence. - -Note [No top-level newtypes on RHS of representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we're in this situation: - - work item: [W] c1 : a ~R b - inert: [G] c2 : b ~R Id a - -where - newtype Id a = Id a - -We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten -and the Id newtype is unwrapped. This is assured by requiring only rewritten -types in canEqCanLHS *and* having the newtype-unwrapping check above -the tyvar check in can_eq_nc. - -Note that this only applies to saturated applications of newtype TyCons, as -we can't rewrite an unsaturated application. See for example T22310, where -we ended up with: - - newtype Compose f g a = ... - - [W] t[tau] ~# Compose Foo Bar - -Note [Put touchable variables on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticket #10009, a very nasty example: - - f :: (UnF (F b) ~ b) => F b -> () - - g :: forall a. (UnF (F a) ~ a) => a -> () - g _ = f (undefined :: F a) - -For g we get [G] g1 : UnF (F a) ~ a - [W] w1 : UnF (F beta) ~ beta - [W] w2 : F a ~ F beta - -g1 is canonical (CEqCan). It is oriented as above because a is not touchable. -See canEqTyVarFunEq. - -w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key -here. - -w2 is canonical. But which way should it be oriented? As written, we'll be -stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is -a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS -of w2. We'll thus lose. - -But if w2 is swapped around, to - - [W] w3 : F beta ~ F a - -then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then -rewrite w1 to - - [W] w4 : UnF (F a) ~ beta - -and then, using g1, to - - [W] w5 : a ~ beta - -at which point we can unify and go on to glory. (This rewriting actually -happens all at once, in the call to rewrite during canonicalisation.) - -But what about the new LHS makes it better? It mentions a variable (beta) -that can appear in a Wanted -- a touchable metavariable never appears -in a Given. On the other hand, the original LHS mentioned only variables -that appear in Givens. We thus choose to put variables that can appear -in Wanteds on the left. - -Ticket #12526 is another good example of this in action. - --} - ---------------------- -canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- lhs: pretty lhs, already rewritten - -> TcType -> TcType -- rhs: already rewritten - -> TcS (StopOrContinue (Either IrredCt EqCt)) -canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 - | k1 `tcEqType` k2 - = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 - - | otherwise - = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2 - - where - k1 = canEqLHSKind lhs1 - k2 = typeKind xi2 - - -{- -Note [Kind Equality Orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in -practice it does not. See Note [Fundeps with instances, and equality -orientation] where this is discussed at length. As a rule of thumb: we keep -the newest unification variables on the left of the equality. See also -Note [Improvement orientation]. - -In particular, `canEqCanLHSHetero` produces the following constraint equalities - -[X] (xi1 :: ki1) ~ (xi2 :: ki2) - --> [X] kco :: ki1 ~ ki2 - [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1 - -Note that the types in the LHS of the new constraints are the ones that were on the LHS of -the original constraint. - ---- Historical note --- -We prevously used to flip the kco to avoid using a sym in the cast - -[X] (xi1 :: ki1) ~ (xi2 :: ki2) - --> [X] kco :: ki2 ~ ki1 - [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1 - -But this sent solver in an infinite loop (see #19415). --- End of historical note -- --} - -canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) - -- (or reversed if SwapFlag=IsSwapped) - -> EqRel -> SwapFlag - -> CanEqLHS -> TcType -- xi1 - -> TcKind -- ki1 - -> TcType -> TcType -- xi2 - -> TcKind -- ki2 - -> TcS (StopOrContinue (Either IrredCt EqCt)) -canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 --- See Note [Equalities with incompatible kinds] --- See Note [Kind Equality Orientation] - --- NB: preserve left-to-right orientation!! See wrinkle (W2) in --- Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict --- NotSwapped: --- ev :: (lhs1:ki1) ~r# (xi2:ki2) --- kind_co :: k11 ~# ki2 -- Same orientiation as ev --- type_ev :: lhs1 ~r# (xi2 |> sym kind_co) --- Swapped --- ev :: (xi2:ki2) ~r# (lhs1:ki1) --- kind_co :: ki2 ~# ki1 -- Same orientiation as ev --- type_ev :: (xi2 |> kind_co) ~r# lhs1 - - = do { (kind_co, rewriters, unifs_happened) <- mk_kind_eq -- :: ki1 ~N ki2 - ; if unifs_happened - -- Unifications happened, so start again to do the zonking - -- Otherwise we might put something in the inert set that isn't inert - then startAgainWith (mkNonCanonical ev) - else - do { let lhs_redn = mkReflRedn role ps_xi1 - rhs_redn = mkGReflRightRedn role xi2 mb_sym_kind_co - mb_sym_kind_co = case swapped of - NotSwapped -> mkSymCo kind_co - IsSwapped -> kind_co - - ; traceTcS "Hetero equality gives rise to kind equality" - (ppr swapped $$ - ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) - ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - - ; let new_xi2 = mkCastTy ps_xi2 mb_sym_kind_co - ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 }} - - where - mk_kind_eq :: TcS (CoercionN, RewriterSet, Bool) - -- Returned kind_co has kind (k1 ~ k2) if NotSwapped, (k2 ~ k1) if Swapped - -- Returned Bool = True if unifications happened, so we should retry - mk_kind_eq = case ev of - CtGiven { ctev_evar = evar } - -> do { let kind_co = mkKindCo (mkCoVarCo evar) - pred_ty = unSwap swapped (mkNomPrimEqPred liftedTypeKind) ki1 ki2 - kind_loc = mkKindEqLoc xi1 xi2 (ctev_loc ev) - ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co) - ; emitWorkNC [kind_ev] - ; return (ctEvCoercion kind_ev, emptyRewriterSet, False) } - - CtWanted {} - -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv -> - let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2) - in unSwap swapped (uType uenv') ki1 ki2 - ; return (kind_co, rewriterSetFromCts cts, not (null unifs)) } - - xi1 = canEqLHSType lhs1 - role = eqRelRole eq_rel - -canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs - -- or, if swapped: rhs ~ lhs - -> EqRel -> SwapFlag - -> CanEqLHS -> TcType -- lhs, pretty lhs - -> TcType -> TcType -- rhs, pretty rhs - -> TcS (StopOrContinue (Either IrredCt EqCt)) --- Guaranteed that typeKind lhs == typeKind rhs -canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 - | (xi2', mco) <- split_cast_ty xi2 - , Just lhs2 <- canEqLHS_maybe xi2' - = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco - - | otherwise - = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 - - where - split_cast_ty (CastTy ty co) = (ty, MCo co) - split_cast_ty other = (other, MRefl) - --- This function deals with the case that both LHS and RHS are potential --- CanEqLHSs. -canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco) - -- or, if swapped: (rhs |> mco) ~ lhs - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- pretty lhs - -> CanEqLHS -- rhs - -> TcType -- pretty rhs - -> MCoercion -- :: kind(rhs) ~N kind(lhs) - -> TcS (StopOrContinue (Either IrredCt EqCt)) -canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco - | lhs1 `eqCanEqLHS` lhs2 - -- It must be the case that mco is reflexive - = canEqReflexive ev eq_rel lhs1_ty - - | TyVarLHS tv1 <- lhs1 - , TyVarLHS tv2 <- lhs2 - = -- See Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify - do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - ; if swapOverTyVars (isGiven ev) tv1 tv2 - then finish_with_swapping - else finish_without_swapping } - - | TyVarLHS {} <- lhs1 - , TyFamLHS {} <- lhs2 - = if put_tyvar_on_lhs - then finish_without_swapping - else finish_with_swapping - - | TyFamLHS {} <- lhs1 - , TyVarLHS {} <- lhs2 - = if put_tyvar_on_lhs - then finish_with_swapping - else finish_without_swapping - - | 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 - ; let tvs1 = tyCoVarsOfTypes fun_args1 - tvs2 = tyCoVarsOfTypes fun_args2 - - -- See Note [Orienting TyFamLHS/TyFamLHS] - swap_for_size = typesSize fun_args2 > typesSize fun_args1 - - -- See Note [Orienting TyFamLHS/TyFamLHS] - meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1 - meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 - swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs - -- See Note [Put touchable variables on the left] - -- This second check is just to avoid unfruitful swapping - - -- It's important that we don't flip-flop (#T24134) - -- So swap_for_rewriting "wins", and we only try swap_for_size - -- 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 } } - where - sym_mco = mkSymMCo mco - role = eqRelRole eq_rel - lhs1_ty = canEqLHSType lhs1 - lhs2_ty = canEqLHSType lhs2 - - finish_without_swapping - = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) - - -- Swapping. We have ev : lhs1 ~ lhs2 |> co - -- We swap to new_ev : lhs2 ~ lhs1 |> sym co - -- ev = grefl1 ; sym new_ev ; grefl2 - -- where grefl1 : lhs1 ~ lhs1 |> sym co - -- grefl2 : lhs2 ~ lhs2 |> co - finish_with_swapping - = do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco - lhs2_redn = mkGReflLeftMRedn role lhs2_ty mco - ; new_ev <-rewriteEqEvidence emptyRewriterSet ev swapped lhs1_redn lhs2_redn - ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } - - put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq - -- See Note [Orienting TyVarLHS/TyFamLHS] - -- Same conditions as for canEqCanLHSFinish_try_unification - -- which we are setting ourselves up for here - -{- Note [Orienting TyVarLHS/TyFamLHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What if one side is a TyVarLHS and the other is a TyFamLHS, (a ~ F tys)? -Which to put on the left? Answer: - -* If there is no chance of unifying, put the type family on the left, - (F tys ~ a), because it's generally better to rewrite away function - calls. See `put_tyvar_on_lhs` in canEqCanLHS2; and - Note [Orienting TyVarLHS/TyFamLHS] - -* But if there /is/ a chance of unifying, put the tyvar on the left, - (a ~ F tys), as this may be our only shot to unify. Again see - `put_tyvar_on_lhs`. - -* But if we /fail/ to unify then flip back to (F tys ~ a) because it's - generally better to rewrite away function calls. See the call to - `swapAndFinish` in `canEqCanLHSFinish_try_unification` - - It's important to flip back. Consider - [W] F alpha ~ alpha - [W] F alpha ~ beta - [W] G alpha beta ~ Int ( where we have type instance G a a = a ) - If we end up with a stuck alpha ~ F alpha, we won't be able to solve this. - Test case: indexed-types/should_compile/CEqCanOccursCheck - -Note [Orienting TyFamLHS/TyFamLHS] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a TyFamLHS on both sides, we choose how to orient it. - -* swap_for_size. If we have - S a ~ F (G (H (Maybe a))) - then we swap so that we tend to rewrite the bigger type (F (G (H (Maybe a)))) - into the smaller one (S a). This same test tends to avoid occurs-check - errors. E.g. - S g ~ F (G (S g)) - Here (S g) occurs on the RHS, so this is not canonical. But if we swap it - around, it /is/ canonical - F (G (S g)) ~ S g - -* swap_for_rewriting: put touchable meta-tyvars on the left: - see Note [Put touchable variables on the left] --} - --- The RHS here is either not CanEqLHS, or it's one that we --- want to rewrite the LHS to (as per e.g. swapOverTyVars) -canEqCanLHSFinish, canEqCanLHSFinish_try_unification, - canEqCanLHSFinish_no_unification - :: CtEvidence -- (lhs ~ rhs) or if swapped (rhs ~ lhs) - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs - -> TcType -- rhs - -> TcS (StopOrContinue (Either IrredCt EqCt)) - -- RHS is fully rewritten, but with type synonyms - -- preserved as much as possible - -- Guaranteed preconditions that - -- (TyEq:K) handled in canEqCanLHSHomo - -- (TyEq:N) checked in can_eq_nc - -- (TyEq:TV) handled in canEqCanLHS2 - ---------------------------- -canEqCanLHSFinish ev eq_rel swapped lhs rhs - = do { traceTcS "canEqCanLHSFinish" $ - vcat [ text "ev:" <+> ppr ev - , text "swapped:" <+> ppr swapped - , text "lhs:" <+> ppr lhs - , text "rhs:" <+> ppr rhs ] - - -- Assertion: (TyEq:K) is already satisfied - ; massert (canEqLHSKind lhs `eqType` typeKind rhs) - - -- Assertion: (TyEq:N) is already satisfied (if applicable) - ; assertPprM ty_eq_N_OK $ - vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied" - , text "rhs:" <+> ppr rhs ] - - ; canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs } - - where - -- This is about (TyEq:N): check that we don't have a saturated application - -- of a newtype TyCon at the top level of the RHS, if the constructor - -- of the newtype is in scope. - ty_eq_N_OK :: TcS Bool - ty_eq_N_OK - | ReprEq <- eq_rel - , Just (tc, tc_args) <- splitTyConApp_maybe rhs - , Just con <- newTyConDataCon_maybe tc - -- #22310: only a problem if the newtype TyCon is saturated. - , tc_args `lengthAtLeast` tyConArity tc - -- #21010: only a problem if the newtype constructor is in scope. - = do { rdr_env <- getGlobalRdrEnvTcS - ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con) - ; return $ not con_in_scope } - | otherwise - = return True - ------------------------ -canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs - -- Try unification; for Wanted, Nominal equalities with a meta-tyvar on the LHS - | isWanted ev -- See Note [Do not unify Givens] - , NomEq <- eq_rel -- See Note [Do not unify representational equalities] - , TyVarLHS tv <- lhs - = do { given_eq_lvl <- getInnermostGivenEqLevel - ; if not (touchabilityAndShapeTest given_eq_lvl tv rhs) - then if | Just can_rhs <- canTyFamEqLHS_maybe rhs - -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs - -- See Note [Orienting TyVarLHS/TyFamLHS] - - | otherwise - -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs - else - - -- We have a touchable unification variable on the left - do { check_result <- checkTouchableTyVarEq ev tv rhs - ; case check_result of { - PuFail reason - | Just can_rhs <- canTyFamEqLHS_maybe rhs - -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs - -- Swap back: see Note [Orienting TyVarLHS/TyFamLHS] - - | reason `cterHasOnlyProblems` do_not_prevent_rewriting - -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs - - | otherwise - -> tryIrredInstead reason ev eq_rel swapped lhs rhs ; - - PuOK _ rhs_redn -> - - -- Success: we can solve by unification - do { -- In the common case where rhs_redn is Refl, we don't need to rewrite - -- the evidence, even if swapped=IsSwapped. Suppose the original was - -- [W] co : Int ~ alpha - -- We unify alpha := Int, and set co := . No need to - -- swap to co = sym co' - -- co' = - new_ev <- if isReflCo (reductionCoercion rhs_redn) - then return ev - else rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn - - ; let tv_ty = mkTyVarTy tv - final_rhs = reductionReducedType rhs_redn - - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs, - text "Coercion:" <+> pprEq tv_ty final_rhs, - text "Left Kind is:" <+> ppr (typeKind tv_ty), - text "Right Kind is:" <+> ppr (typeKind final_rhs) ] - - -- Update the unification variable itself - ; unifyTyVar tv final_rhs - - -- Provide Refl evidence for the constraint - -- Ignore 'swapped' because it's Refl! - ; setEvBindIfWanted new_ev True $ - evCoercion (mkNomReflCo final_rhs) - - -- Kick out any constraints that can now be rewritten - ; kickOutAfterUnification [tv] - - ; return (Stop new_ev (text "Solved by unification")) }}}} - - -- Otherwise unification is off the table - | otherwise - = canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs - - where - -- Some problems prevent /unification/ but not /rewriting/ - -- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3] - -- we can't unify (skolem-escape); but it /is/ canonical, - -- and hence we /can/ use it for rewriting - -- Concrete-ness: alpha[conc] ~ b[sk] - -- We can use it to rewrite; we still have to solve the original - do_not_prevent_rewriting :: CheckTyEqResult - do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<> - cteProblem cteConcrete - ---------------------------- --- Unification is off the table -canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs - = do { -- Do checkTypeEq to guarantee (TyEq:OC), (TyEq:F) - -- Must do the occurs check even on tyvar/tyvar equalities, - -- in case have x ~ (y :: ..x...); this is #12593. - ; check_result <- checkTypeEq ev eq_rel lhs rhs - - ; let lhs_ty = canEqLHSType lhs - ; case check_result of - PuFail reason - - -- If we had F a ~ G (F a), which gives an occurs check, - -- then swap it to G (F a) ~ F a, which does not - -- However `swap_for_size` above will orient it with (G (F a)) on - -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't - -- matter: in the occurs check case swap_for_rewriting will be moot. - -- TL;DR: the next four lines of code are redundant - -- I'm leaving them here in case they become relevant again --- | TyFamLHS {} <- lhs --- , Just can_rhs <- canTyFamEqLHS_maybe rhs --- , reason `cterHasOnlyProblem` cteSolubleOccurs --- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs --- | otherwise - - -> tryIrredInstead reason ev eq_rel swapped lhs rhs - - PuOK _ rhs_redn - -> do { new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn (eqRelRole eq_rel) lhs_ty) - rhs_redn - - -- Important: even if the coercion is Refl, - -- * new_ev has reductionReducedType on the RHS - -- * eq_rhs is set to reductionReducedType - -- See Note [Forgetful synonyms in checkTyConApp] in GHC.Tc.Utils.Unify - ; continueWith $ Right $ - EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel - , eq_lhs = lhs - , eq_rhs = reductionReducedType rhs_redn } } } - ----------------------- -swapAndFinish :: CtEvidence -> EqRel -> SwapFlag - -> TcType -> CanEqLHS -- ty ~ F tys - -> TcS (StopOrContinue (Either unused EqCt)) --- We have an equality alpha ~ F tys, that we can't unify e.g because 'tys' --- mentions alpha, it would not be a canonical constraint as-is. --- We want to flip it to (F tys ~ a), whereupon it is canonical -swapAndFinish ev eq_rel swapped lhs_ty can_rhs - = do { let role = eqRelRole eq_rel - ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped) - (mkReflRedn role (canEqLHSType can_rhs)) - (mkReflRedn role lhs_ty) - ; continueWith $ Right $ - EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel - , eq_lhs = can_rhs, eq_rhs = lhs_ty } } - ----------------------- -tryIrredInstead :: CheckTyEqResult -> CtEvidence - -> EqRel -> SwapFlag -> CanEqLHS -> TcType - -> TcS (StopOrContinue (Either IrredCt unused)) --- We have a non-canonical equality --- We still swap it if 'swapped' says so, so that it is oriented --- in the direction that the error-reporting machinery --- expects it; e.g. (m ~ t m) rather than (t m ~ m) --- This is not very important, and only affects error reporting. -tryIrredInstead reason ev eq_rel swapped lhs rhs - = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs) - ; let role = eqRelRole eq_rel - ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn role (canEqLHSType lhs)) - (mkReflRedn role rhs) - ; finishCanWithIrred (NonCanonicalReason reason) new_ev } - -finishCanWithIrred :: CtIrredReason -> CtEvidence - -> TcS (StopOrContinue (Either IrredCt a)) -finishCanWithIrred reason ev - = do { -- Abort fast if we have any insoluble Wanted constraints, - -- and the TcS abort-if-insoluble flag is on. - when (isInsolubleReason reason) tryEarlyAbortTcS - - ; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } } - ------------------------ --- | Solve a reflexive equality constraint -canEqReflexive :: CtEvidence -- ty ~ ty - -> EqRel - -> TcType -- ty - -> TcS (StopOrContinue a) -- always Stop -canEqReflexive ev eq_rel ty - = do { setEvBindIfWanted ev True $ - evCoercion (mkReflCo (eqRelRole eq_rel) ty) - ; stopWith ev "Solved by reflexivity" } - -{- Note [Equalities with incompatible kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What do we do when we have an equality - - (tv :: k1) ~ (rhs :: k2) - -where k1 and k2 differ? Easy: we create a coercion that relates k1 and -k2 and use this to cast. To wit, from - - [X] (tv :: k1) ~ (rhs :: k2) - -(where [X] is [G] or [W]), we go to - - [X] co :: k1 ~ k2 - [X] (tv :: k1) ~ ((rhs |> sym co) :: k1) - -Wrinkles: - -(EIK1) When X is W, the new type-level wanted is effectively rewritten by the - kind-level one. We thus include the kind-level wanted in the RewriterSet - for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. - This is done in canEqCanLHSHetero. - -(EIK2) Suppose we have [W] (a::Type) ~ (b::Type->Type). The above rewrite will produce - [W] w : a ~ (b |> kw) - [W] kw : Type ~ (Type->Type) - - But we do /not/ want to regard `w` as canonical, and use it for rewriting - other constraints: `kw` is insoluble, and replacing something of kind - `Type` with something of kind `Type->Type` (even wrapped in an insouluble - cast) does not help, and doing so turns out to lead to much worse error - messages. (In particular, if 'a' is a unification variable, we might - unify, losing the tracking info that it depends on solving `kw`.) - - Conclusion: if a RHS contains a corecion hole arising from fixing a hetero-kinded - equality, treat the equality (`w` in this case) as non-canonical, so that - * It will not be used for unification - * It will not be used for rewriting - Instead, it lands in the inert_irreds in the inert set, awaiting solution of - that `kw`. - - (EIK2a) We must later indeed unify if/when the kind-level wanted, `kw` gets - solved. This is done in kickOutAfterFillingCoercionHole, which kicks out - all equalities whose RHS mentions the filled-in coercion hole. Note that - it looks for type family equalities, too, because of the use of unifyTest - in canEqTyVarFunEq. - - (EIK2b) What if the RHS mentions /other/ coercion holes? How can that happen? The - main way is like this. Assume F :: forall k. k -> Type - [W] kw : k ~ Type - [W] w : a ~ F k t - We can rewrite `w` with `kw` like this: - [W] w' : a ~ F Type (t |> kw) - The cast on the second argument of `F` is necessary to keep the appliation well-kinded. - There is nothing special here; no reason not treat w' as canonical, and use it for - rewriting. Indeed tests JuanLopez only typechecks if we do. So we'd like to treat - this kind of equality as canonical. - - Hence the ch_hetero_kind field in CoercionHole: it is True of constraints - created by `canEqCanLHSHetero` to fix up hetero-kinded equalities; and False otherwise: - - * An equality constraint is non-canonical if it mentions a hetero-kind - CoercionHole on the RHS. See the `hasCoercionHoleCo` test in GHC.Tc.Utils.checkCo. - - * Hetero-kind CoercionHoles are created when the parent's CtOrigin is - KindEqOrigin: see GHC.Tc.Utils.TcMType.newCoercionHole and friends. We - set this origin, via `mkKindLoc`, in `mk_kind_eq` in `canEqCanLHSHetero`. - -(EIK3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the - algorithm detailed here, producing [W] co :: k1 ~ k2, and adding - [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time - later, we solve co, and fill in co's coercion hole. This kicks out - the irreducible as described in (2). - - But now, during canonicalization, we see the cast and remove it, in - canEqCast. By the time we get into canEqCanLHS, the equality is - heterogeneous again, and the process repeats. - - To avoid this, we don't strip casts off a type if the other type in the - equality is a CanEqLHS (the scenario above can happen with a type - family, too. testcase: typecheck/should_compile/T13822). - - And this is an improvement regardless: because tyvars can, generally, - unify with casted types, there's no reason to go through the work of - stripping off the cast when the cast appears opposite a tyvar. This is - implemented in the cast case of can_eq_nc. - -Historical note: - -We used to do this via emitting a Derived kind equality and then parking -the heterogeneous equality as irreducible. But this new approach is much -more direct. And it doesn't produce duplicate Deriveds (as the old one did). - -Note [Type synonyms and canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We treat type synonym applications as xi types, that is, they do not -count as type function applications. However, we do need to be a bit -careful with type synonyms: like type functions they may not be -generative or injective. However, unlike type functions, they are -parametric, so there is no problem in expanding them whenever we see -them, since we do not need to know anything about their arguments in -order to expand them; this is what justifies not having to treat them -as specially as type function applications. The thing that causes -some subtleties is that we prefer to leave type synonym applications -*unexpanded* whenever possible, in order to generate better error -messages. - -If we encounter an equality constraint with type synonym applications -on both sides, or a type synonym application on one side and some sort -of type application on the other, we simply must expand out the type -synonyms in order to continue decomposing the equality constraint into -primitive equality constraints. For example, suppose we have - - type F a = [Int] - -and we encounter the equality - - F a ~ [b] - -In order to continue we must expand F a into [Int], giving us the -equality - - [Int] ~ [b] - -which we can then decompose into the more primitive equality -constraint - - Int ~ b. - -However, if we encounter an equality constraint with a type synonym -application on one side and a variable on the other side, we should -NOT (necessarily) expand the type synonym, since for the purpose of -good error messages we want to leave type synonyms unexpanded as much -as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. - -Note [Type equality cycles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this situation (from indexed-types/should_compile/GivenLoop): - - instance C (Maybe b) - *[G] a ~ Maybe (F a) - [W] C a - -or (typecheck/should_compile/T19682b): - - instance C (a -> b) - *[W] alpha ~ (Arg alpha -> Res alpha) - [W] C alpha - -or (typecheck/should_compile/T21515): - - type family Code a - *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ] - [W] Code a ~ '[ '[ alpha ] ] - -In order to solve the final Wanted, we must use the starred constraint -for rewriting. But note that all starred constraints have occurs-check failures, -and so we can't straightforwardly add these to the inert set and -use them for rewriting. (NB: A rigid type constructor is at the -top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar -cases.) - -The key idea is to replace the outermost type family applications in the RHS of -the starred constraints with a fresh variable, which we'll call a cycle-breaker -variable, or cbv. Then, relate the cbv back with the original type family -application via new equality constraints. Our situations thus become: - - instance C (Maybe b) - [G] a ~ Maybe cbv - [G] F a ~ cbv - [W] C a - -or - - instance C (a -> b) - [W] alpha ~ (cbv1 -> cbv2) - [W] Arg alpha ~ cbv1 - [W] Res alpha ~ cbv2 - [W] C alpha - -or - - [G] Code a ~ '[ '[ cbv ] ] - [G] Head (Head (Code a)) ~ cbv - [W] Code a ~ '[ '[ alpha ] ] - -This transformation (creating the new types and emitting new equality -constraints) is done by the `FamAppBreaker` field of `TEFA_Break`, which -in turn lives in the `tef_fam_app` field of `TyEqFlags`. And that in -turn controls the behaviour of the workhorse: GHC.Tc.Utils.Unify.checkTyEqRhs. - -The details depend on whether we're working with a Given or a Wanted. - -Given ------ -We emit a new Given, [G] F a ~ cbv, equating the type family application -to our new cbv. This is actually done by `break_given` in -`GHC.Tc.Solver.Monad.checkTypeEq`. - -Note its orientation: The type family ends up on the left; see -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. - -(The first Given actually also rewrites the second one, giving -[G] F (Maybe cbv) ~ cbv, but this causes no trouble.) - -Of course, we don't want our fresh variables leaking into e.g. error -messages. So we fill in the metavariables with their original type family -applications after we're done running the solver (in nestImplicTcS and -runTcSWithEvBinds). This is done by `restoreTyVarCycles`, which uses the -`inert_cycle_breakers` field in InertSet, which contains the pairings -invented in `break_given`. - -That is, we transform - [G] g : lhs ~ ...(F lhs)... -to - [G] (Refl lhs) : F lhs ~ cbv -- CEqCan - [G] g : lhs ~ ...cbv... -- CEqCan - -Note that -* `cbv` is a fresh cycle breaker variable. -* `cbv` is a is a meta-tyvar, but it is completely untouchable. -* We track the cycle-breaker variables in inert_cycle_breakers in InertSet -* We eventually fill in the cycle-breakers, with `cbv := F lhs`. - No one else fills in CycleBreakerTvs! -* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know - this fill-in is ultimately going to happen. -* In `inert_cycle_breakers`, we remember the (cbv, F lhs) pair; that is, we - remember the /original/ type. The [G] F lhs ~ cbv constraint may be rewritten - by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we - still fill in with cbv := F lhs -* This fill-in is done when solving is complete, by restoreTyVarCycles - in nestImplicTcS and runTcSWithEvBinds. - -Wanted ------- -First, we do not cycle-break unless the LHS is a unifiable type variable -See Note [Don't cycle-break Wanteds when not unifying] in GHC.Tc.Solver.Monad. - -OK, so suppose the LHS is a unifiable type variable. The fresh cycle-breaker -variables here must actually be normal, touchable metavariables. That is, they -are TauTvs. Nothing at all unusual. Repeating the example from above, we have - - *[W] alpha ~ (Arg alpha -> Res alpha) - -and we turn this into - - *[W] alpha ~ (cbv1 -> cbv2) - [W] Arg alpha ~ cbv1 - [W] Res alpha ~ cbv2 - -where cbv1 and cbv2 are fresh TauTvs. This is actually done by `break_wanted` -in `GHC.Tc.Solver.Monad.checkTouchableTyVarEq`. - -Why TauTvs? See [Why TauTvs] below. - -Critically, we emit the two new constraints (the last two above) -directly instead of calling wrapUnifierTcS. (Otherwise, we'd end up -unifying cbv1 and cbv2 immediately, achieving nothing.) Next, we -unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This -unification happens immediately following a successful call to -checkTouchableTyVarEq, in canEqCanLHSFinish_try_unification. - -Now, we're here (including further context from our original example, -from the top of the Note): - - instance C (a -> b) - [W] Arg (cbv1 -> cbv2) ~ cbv1 - [W] Res (cbv1 -> cbv2) ~ cbv2 - [W] C (cbv1 -> cbv2) - -The first two W constraints reduce to reflexivity and are discarded, -and the last is easily soluble. - -[Why TauTvs]: -Let's look at another example (typecheck/should_compile/T19682) where we need -to unify the cbvs: - - class (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys - instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys - - type family SameShapeAs xs ys :: Constraint where - SameShapeAs '[] ys = (ys ~ '[]) - SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys)) - - type family AllEqF xs ys :: Constraint where - AllEqF '[] '[] = () - AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) - - [W] alpha ~ (Head alpha : Tail alpha) - [W] AllEqF '[Bool] alpha - -Without the logic detailed in this Note, we're stuck here, as AllEqF cannot -reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, -just as described above. We thus invent cbv1 and cbv2 and unify -alpha := cbv1 -> cbv2, yielding (after zonking) - - [W] Head (cbv1 : cbv2) ~ cbv1 - [W] Tail (cbv1 : cbv2) ~ cbv2 - [W] AllEqF '[Bool] (cbv1 : cbv2) - -The first two W constraints simplify to reflexivity and are discarded. -But the last reduces: - - [W] Bool ~ cbv1 - [W] AllEq '[] cbv2 - -The first of these is solved by unification: cbv1 := Bool. The second -is solved by the instance for AllEq to become - - [W] AllEqF '[] cbv2 - [W] SameShapeAs '[] cbv2 - -While the first of these is stuck, the second makes progress, to lead to - - [W] AllEqF '[] cbv2 - [W] cbv2 ~ '[] - -This second constraint is solved by unification: cbv2 := '[]. We now -have - - [W] AllEqF '[] '[] - -which reduces to - - [W] () - -which is trivially satisfiable. Hooray! - -Note that we need to unify the cbvs here; if we did not, there would be -no way to solve those constraints. That's why the cycle-breakers are -ordinary TauTvs. - -How all this is implemented ---------------------------- -We implement all this via the `TEFA_Break` constructor of `TyEqFamApp`, -itself stored in the `tef_fam_app` field of `TyEqFlags`, which controls -the behaviour of `GHC.Tc.Utils.Unify.checkTyEqRhs`. The `TEFA_Break` -stuff happens when `checkTyEqRhs` encounters a family application. - -We try the cycle-breaking trick: -* For Wanteds, when there is a touchable unification variable on the left -* For Givens, regardless of the LHS - -EXCEPT that, in both cases, as `GHC.Tc.Solver.Monad.mkTEFA_Break` shows, we -don't use this trick: - -* When the constraint we are looking at was itself created by cycle-breaking; - see Detail (7) below. - -* For representational equalities, as there is no concrete use case where it is - helpful (unlike for nominal equalities). - - Furthermore, because function applications can be CanEqLHSs, but newtype - applications cannot, the disparities between the cases are enough that it - would be effortful to expand the idea to representational equalities. A quick - attempt, with - data family N a b - f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b - f = coerce - failed with "Could not match 'b' with 'b'." Further work is held off - until when we have a concrete incentive to explore this dark corner. - -More details: - - (1) We don't look under foralls, at all, in `checkTyEqRhs`. There might be - a cyclic occurrence underneath, in a case like - [G] lhs ~ forall b. ... lhs .... - but it doesn't matter because we will classify the constraint as Irred, - so it will not be used for rewriting. - - Earlier versions required an extra, post-breaking, check. Skipping this - check causes typecheck/should_fail/GivenForallLoop and polykinds/T18451 to - loop. But now it is all simpler, with no need for a second check. - - (2) Historical Note: our goal here is to avoid loops in rewriting. We can thus - skip looking in coercions, as we don't rewrite in coercions in the - algorithm in GHC.Solver.Rewrite. This doesn't seem relevant any more. - We cycle break to make the constraint canonical. - - (3) As we cycle-break as described in this Note, we can build ill-kinded - types. For example, if we have Proxy (F a) b, where (b :: F a), then - replacing this with Proxy cbv b is ill-kinded. However, we will later - set cbv := F a, and so the zonked type will be well-kinded again. - The temporary ill-kinded type hurts no one, and avoiding this would - be quite painfully difficult. - - Specifically, this detail does not contravene the Purely Kinded Type Invariant - (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType). - The PKTI says that we can call typeKind on any type, without failure. - It would be violated if we, say, replaced a kind (a -> b) with a kind c, - because an arrow kind might be consulted in piResultTys. Here, we are - replacing one opaque type like (F a b c) with another, cbv (opaque in - that we never assume anything about its structure, like that it has a - result type or a RuntimeRep argument). - - (4) The evidence for the produced Givens is all just reflexive, because we - will eventually set the cycle-breaker variable to be the type family, and - then, after the zonk, all will be well. See also the notes at the end of - the Given section of this Note. - - (5) The implementation in `checkTyEqRhs` is efficient because it only replaces - a type family application with a type variable, if that particular - appplication is implicated in the occurs check. For example: - [W] alpha ~ Maybe (F alpha, G beta) - We'll end up calling GHC.Tc.Utils.Unify.checkFamApp - * On `F alpha`, which fail and calls the cycle-breaker in TEFA_Break - * On `G beta`, which succeeds no problem. - - However, we make no attempt to detect cases like a ~ (F a, F a) and use the - same tyvar to replace F a. The constraint solver will common them up later! - (Cf. Note [Flattening type-family applications when matching instances] in - GHC.Core.Unify, which goes to this extra effort.) However, this is really - a very small corner case. The investment to craft a clever, performant - solution seems unworthwhile. - - (6) We often get the predicate associated with a constraint from its evidence - with ctPred. We thus must not only make sure the generated CEqCan's fields - have the updated RHS type (that is, the one produced by replacing type - family applications with fresh variables), but we must also update the - evidence itself. This is done by the call to rewriteEqEvidence in - canEqCanLHSFinish. - - (7) We don't wish to apply this magic on the equalities created - by this very same process. Consider this, from - typecheck/should_compile/ContextStack2: - - type instance TF (a, b) = (TF a, TF b) - t :: (a ~ TF (a, Int)) => ... - - [G] a ~ TF (a, Int) - - The RHS reduces, so we get - - [G] a ~ (TF a, TF Int) - - We then break cycles, to get - - [G] g1 :: a ~ (cbv1, cbv2) - [G] g2 :: TF a ~ cbv1 - [G] g3 :: TF Int ~ cbv2 - - g1 gets added to the inert set, as written. But then g2 becomes - the work item. g1 rewrites g2 to become - - [G] TF (cbv1, cbv2) ~ cbv1 - - which then uses the type instance to become - - [G] (TF cbv1, TF cbv2) ~ cbv1 - - which looks remarkably like the Given we started with. If left unchecked, - this will end up breaking cycles again, looping ad infinitum (and - resulting in a context-stack reduction error, not an outright loop). The - solution is easy: don't break cycles on an equality generated by breaking - cycles. Instead, we mark this final Given as a CIrredCan with a - NonCanonicalReason with the soluble occurs-check bit set (only). - - We track these equalities by giving them a special CtOrigin, - CycleBreakerOrigin. This works for both Givens and Wanteds, as we need the - logic in the W case for e.g. typecheck/should_fail/T17139. Because this - logic needs to work for Wanteds, too, we cannot simply look for a - CycleBreakerTv on the left: Wanteds don't use them. - - -********************************************************************** -* * - Rewriting evidence -* * -********************************************************************** --} - -rewriteEqEvidence :: RewriterSet -- New rewriters - -- See GHC.Tc.Types.Constraint - -- Note [Wanteds rewrite Wanteds] - -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) - -- or orhs ~ olhs (swapped) - -> SwapFlag - -> Reduction -- lhs_co :: olhs ~ nlhs - -> Reduction -- rhs_co :: orhs ~ nrhs - -> TcS CtEvidence -- Of type nlhs ~ nrhs --- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs), --- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): --- If not swapped --- g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co --- If swapped --- g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co --- --- For a wanted equality (Wanted w), we do the dual thing: --- New w1 : nlhs ~ nrhs --- If not swapped --- w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co --- If swapped --- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co --- --- It's all a form of rewriteEvidence, specialised for equalities -rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) - | NotSwapped <- swapped - , isReflCo lhs_co -- See Note [Rewriting with Refl] - , isReflCo rhs_co - = return (setCtEvPredType old_ev new_pred) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion ( mkSymCo lhs_co - `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar) - `mkTransCo` rhs_co) - ; newGivenEvVar loc (new_pred, new_tm) } - - | 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 - ; let co = maybeSymCo swapped $ - lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co - ; setWantedEq dest co - ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev - , ppr nlhs - , ppr nrhs - , ppr co - , ppr new_rewriters ]) - ; return new_ev } - -#if __GLASGOW_HASKELL__ <= 810 - | otherwise - = panic "rewriteEvidence" -#endif - where - new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs - loc = ctEvLoc old_ev - -{- -********************************************************************** -* * - tryInertEqs -* * -********************************************************************** - -Note [Combining equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - Inert: g1 :: a ~ t - Work item: g2 :: a ~ t - -Then we can simply solve g2 from g1, thus g2 := g1. Easy! -But it's not so simple: - -* If t is a type variable, the equalties might be oriented differently: - e.g. (g1 :: a~b) and (g2 :: b~a) - So we look both ways round. Hence the SwapFlag result to - inertsCanDischarge. - -* We can only do g2 := g1 if g1 can discharge g2; that depends on - (a) the role and (b) the flavour. E.g. a representational equality - cannot discharge a nominal one; a Wanted cannot discharge a Given. - The predicate is eqCanRewriteFR. - -* Visibility. Suppose S :: forall k. k -> Type, and consider unifying - S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type) - From the first argument we get (Type ~ Type->Type); from the second - argument we get (a ~ b) which in turn gives (Type ~ Type->Type). - See typecheck/should_fail/T16204c. - - That first argument is invisible in the source program (aside from - visible type application), so we'd much prefer to get the error from - the second. We track visibility in the uo_visible field of a TypeEqOrigin. - We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters, - the partition on isVisibleOrigin). - - So when combining two otherwise-identical equalites, we want to - keep the visible one, and discharge the invisible one. Hence the - call to strictly_more_visible. --} - -tryInertEqs :: EqCt -> SolverStage () -tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) - = Stage $ - do { inerts <- getInertCans - ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item - -> do { setEvBindIfWanted ev True $ - evCoercion (maybeSymCo swapped $ - downgradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - ; stopWith ev "Solved from inert" } - - | otherwise - -> continueWith () } - -inertsCanDischarge :: InertCans -> EqCt - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag ) -- Whether we need mkSymCo -inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w - , eq_ev = ev_w, eq_eq_rel = eq_rel }) - | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i - , eq_eq_rel = eq_rel } - <- findEq inerts lhs_w - , rhs_i `tcEqType` rhs_w - , inert_beats_wanted ev_i eq_rel ] - = -- Inert: a ~ ty - -- Work item: a ~ ty - Just (ev_i, NotSwapped) - - | Just rhs_lhs <- canEqLHS_maybe rhs_w - , (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i - , eq_eq_rel = eq_rel } - <- findEq inerts rhs_lhs - , rhs_i `tcEqType` canEqLHSType lhs_w - , inert_beats_wanted ev_i eq_rel ] - = -- Inert: a ~ b - -- Work item: b ~ a - Just (ev_i, IsSwapped) - - where - loc_w = ctEvLoc ev_w - flav_w = ctEvFlavour ev_w - fr_w = (flav_w, eq_rel) - - inert_beats_wanted ev_i eq_rel - = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] - -- strictly_more_visible: see last bullet of Note [Combining equalities] - fr_i `eqCanRewriteFR` fr_w - && not ((loc_w `strictly_more_visible` ctEvLoc ev_i) - && (fr_w `eqCanRewriteFR` fr_i)) - where - fr_i = (ctEvFlavour ev_i, eq_rel) - - -- See Note [Combining equalities], final bullet - strictly_more_visible loc1 loc2 - = not (isVisibleOrigin (ctLocOrigin loc2)) && - isVisibleOrigin (ctLocOrigin loc1) - -inertsCanDischarge _ _ = Nothing - - - -{- Note [Do not unify Givens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this GADT match - data T a where - T1 :: T Int - ... - - f x = case x of - T1 -> True - ... - -So we get f :: T alpha[1] -> beta[1] - x :: T alpha[1] -and from the T1 branch we get the implication - forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool - -Now, clearly we don't want to unify alpha:=Int! Yet at the moment we -process [G] alpha[1] ~ Int, we don't have any given-equalities in the -inert set, and hence there are no given equalities to make alpha untouchable. - -NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that -never happens: invariant (GivenInv) in Note [TcLevel invariants] -in GHC.Tc.Utils.TcType. - -Simple solution: never unify in Givens! - -Note [Do not unify representational equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [W] alpha ~R# b -where alpha is touchable. Should we unify alpha := b? - -Certainly not! Unifying forces alpha and be to be the same; but they -only need to be representationally equal types. - -For example, we might have another constraint [W] alpha ~# N b -where - newtype N b = MkN b -and we want to get alpha := N b. - -See also #15144, which was caused by unifying a representational -equality. - -Note [Solve by unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we solve - alpha[n] ~ ty -by unification, there are two cases to consider - -* TouchableSameLevel: if the ambient level is 'n', then - we can simply update alpha := ty, and do nothing else - -* TouchableOuterLevel free_metas n: if the ambient level is greater than - 'n' (the level of alpha), in addition to setting alpha := ty we must - do two other things: - - 1. Promote all the free meta-vars of 'ty' to level n. After all, - alpha[n] is at level n, and so if we set, say, - alpha[n] := Maybe beta[m], - we must ensure that when unifying beta we do skolem-escape checks - etc relevant to level n. Simple way to do that: promote beta to - level n. - - 2. Set the Unification Level Flag to record that a level-n unification has - taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad - -NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion -would be a no-op, and setting the unification flag unnecessarily would just -make the solver iterate more often. (We don't need to iterate when unifying -at the ambient level because of the kick-out mechanism.) --} - - -{-******************************************************************** -* * - Final wrap-up for equalities -* * -********************************************************************-} - -{- Note [Looking up primitive equalities in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For equalities (a ~# b) look up (a ~ b), and then do a superclass -selection. This avoids having to support quantified constraints whose -kind is not Constraint, such as (forall a. F a ~# b) - -See - * Note [Evidence for quantified constraints] in GHC.Core.Predicate - * Note [Equality superclasses in quantified constraints] - in GHC.Tc.Solver.Dict --} - --------------------- -tryQCsIrredEqCt :: IrredCt -> SolverStage () -tryQCsIrredEqCt irred@(IrredCt { ir_ev = ev }) - | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev) - = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2 - - | otherwise -- All the calls come from in this module, where we deal only with - -- equalities, so ctEvPred ev) must be an equality. Indeed, we could - -- pass eq_rel, t1, t2 as arguments, to avoid this can't-happen case, - -- but it's not a hot path, and this is simple and robust - = pprPanic "solveIrredEquality" (ppr ev) - --------------------- -tryQCsEqCt :: EqCt -> SolverStage () -tryQCsEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel }) - = lookup_eq_in_qcis (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs - --------------------- -lookup_eq_in_qcis :: Ct -> EqRel -> TcType -> TcType -> SolverStage () --- The "final QCI check" checks to see if we have --- [W] t1 ~# t2 --- and a Given quantified contraint like (forall a b. blah => a ~ b) --- Why? See Note [Looking up primitive equalities in quantified constraints] --- See also GHC.Tc.Solver.Dict --- Note [Equality superclasses in quantified constraints] -lookup_eq_in_qcis work_ct eq_rel lhs rhs - = Stage $ - do { ev_binds_var <- getTcEvBindsVar - ; ics <- getInertCans - ; if isWanted ev -- Never look up Givens in quantified constraints - && not (null (inert_insts ics)) -- Shortcut common case - && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications] - then try_for_qci - else continueWith () } - where - ev = ctEvidence work_ct - loc = ctEvLoc ev - role = eqRelRole eq_rel - - try_for_qci -- First try looking for (lhs ~ rhs) - | Just (cls, tys) <- boxEqPred eq_rel lhs rhs - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; traceTcS "lookup_irred_in_qcis:1" (ppr (mkClassPred cls tys)) - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) - _ -> try_swapping } - | otherwise - = continueWith () - - try_swapping -- Now try looking for (rhs ~ lhs) (see #23333) - | Just (cls, tys) <- boxEqPred eq_rel rhs lhs - = do { res <- matchLocalInst (mkClassPred cls tys) loc - ; traceTcS "lookup_irred_in_qcis:2" (ppr (mkClassPred cls tys)) - ; case res of - OneInst { cir_mk_ev = mk_ev } - -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped - (mkReflRedn role rhs) (mkReflRedn role lhs) - ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } - _ -> do { traceTcS "lookup_irred_in_qcis:3" (ppr work_ct) - ; continueWith () }} - | otherwise - = continueWith () - - mk_eq_ev cls tys mk_ev evs - | sc_id : rest <- classSCSelIds cls -- Just one superclass for this - = assert (null rest) $ case (mk_ev evs) of - EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) - ev -> pprPanic "mk_eq_ev" (ppr ev) - | otherwise = pprPanic "finishEqCt" (ppr work_ct) - -{- Note [Instances in no-evidence implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #15290 we had - [G] forall p q. Coercible p q => Coercible (m p) (m q)) -- Quantified - [W] forall a. m (Int, IntStateT m a) - ~R# - m (Int, StateT Int m a) - -The Given is an ordinary quantified constraint; the Wanted is an implication -equality that arises from - [W] (forall a. t1) ~R# (forall a. t2) - -But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) -we can't generate any term evidence. So we can't actually use that -lovely quantified constraint. Alas! - -This test arranges to ignore the instance-based solution under these -(rare) circumstances. It's sad, but I really don't see what else we can do. --} - - -{- -********************************************************************** -* * - Functional dependencies for type families -* * -********************************************************************** - -Note [Reverse order of fundep equations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this scenario (from dependent/should_fail/T13135_simple): - - type Sig :: Type -> Type - data Sig a = SigFun a (Sig a) - - type SmartFun :: forall (t :: Type). Sig t -> Type - type family SmartFun sig = r | r -> sig where - SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig - - [W] SmartFun @kappa sigma ~ (Int -> Bool) - -The injectivity of SmartFun allows us to produce two new equalities: - - [W] w1 :: Type ~ kappa - [W] w2 :: SigFun @Type Int beta ~ sigma - -for some fresh (beta :: SigType). The second Wanted here is actually -heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. -Of course, if we solve the first wanted first, the second becomes homogeneous. - -When looking for injectivity-inspired equalities, we work left-to-right, -producing the two equalities in the order written above. However, these -equalities are then passed into wrapUnifierTcS, which will fail, adding these -to the work list. However, crucially, the work list operates like a *stack*. -So, because we add w1 and then w2, we process w2 first. This is silly: solving -w1 would unlock w2. So we make sure to add equalities to the work -list in left-to-right order, which requires a few key calls to 'reverse'. - -This treatment is also used for class-based functional dependencies, although -we do not have a program yet known to exhibit a loop there. It just seems -like the right thing to do. - -When this was originally conceived, it was necessary to avoid a loop in T13135. -That loop is now avoided by continuing with the kind equality (not the type -equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]). -However, the idea of working left-to-right still seems worthwhile, and so the calls -to 'reverse' remain. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Fundeps with instances, and equality orientation], which describes -the Exact Same Problem, with the same solution, but for functional dependencies. - -A very delicate point is the orientation of equalities -arising from injectivity improvement (#12522). Suppose we have - type family F x = t | t -> x - type instance F (a, Int) = (Int, G a) -where G is injective; and wanted constraints - - [W] TF (alpha, beta) ~ fuv - [W] fuv ~ (Int, ) - -The injectivity will give rise to constraints - - [W] gamma1 ~ alpha - [W] Int ~ beta - -The fresh unification variable gamma1 comes from the fact that we -can only do "partial improvement" here; see Section 5.2 of -"Injective type families for Haskell" (HS'15). - -Now, it's very important to orient the equations this way round, -so that the fresh unification variable will be eliminated in -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 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 -introducing gamma1 in the first place, in the case where the -actual argument (alpha, beta) partly matches the improvement -template. But that's a bit tricky, esp when we remember that the -kinds much match too; so it's easier to let the normal machinery -handle it. Instead we are careful to orient the new -equality with the template on the left. Delicate, but it works. - --} - -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 }) - = 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 () - --------------------- -improveTopFunEqs :: TyCon -> [TcType] -> EqCt -> TcS Bool --- 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] - - | otherwise - = do { fam_envs <- getFamInstEnvs - ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs - ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs - , ppr eqns ]) - ; unifyFunDeps ev Nominal $ \uenv -> - uPairsTcM (bump_depth uenv) (reverse eqns) } - -- Missing that `reverse` causes T13135 and T13135_simple to loop. - -- See Note [Reverse order of fundep equations] - - where - bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) } - -- 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 - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = return (sfInteractTop ops args 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) - - ; traceTcS "improve_top_fun_eqs2" (ppr improvs) - ; concatMapM (injImproveEqns injective_args) $ - take 1 improvs } - - | 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 - - | otherwise - = return [] - - where - in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) - - 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 { 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. - - ; return [ Pair (substTy subst ax_arg) arg - -- NB: the ax_arg part is on the left - -- see Note [Improvement orientation] - | case cabr of - Just cabr' -> apartnessCheck (substTys subst ax_args) cabr' - _ -> True - , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } - - -improveLocalFunEqs :: InertCans -> TyCon -> [TcType] -> EqCt -> TcS Bool --- Generate improvement equalities, by comparing --- the current work item with inert CFunEqs --- 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 }) - | 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) ] - ; 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 - - -------------------- - improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] - improvement_eqns - | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc - = -- Try built-in families, notably for arithmethic - concatMap (do_one_built_in ops rhs) funeqs_for_tc - - | Injective injective_args <- fam_inj_info - = -- Try improvement from type families with injectivity annotations - concatMap (do_one_injective injective_args rhs) funeqs_for_tc - - | otherwise - = [] - - -------------------- - 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) - - | 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 ] - | otherwise - = [] - - do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS - - -------------------- - mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] - 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) +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + +module GHC.Tc.Solver.Equality( + solveEquality + ) where + + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Tc.Solver.Solve( trySolveImplication ) + +import GHC.Tc.Solver.Irred( solveIrred ) +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Rewrite +import GHC.Tc.Solver.Monad +import GHC.Tc.Solver.InertSet +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 +import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) +import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) +import qualified GHC.Tc.Utils.Monad as TcM + +import GHC.Core.Type +import GHC.Core.Predicate +import GHC.Core.Class +import GHC.Core.DataCon ( dataConName ) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom +import GHC.Core.Reduction +import GHC.Core.Unify( tcUnifyTyForInjectivity ) +import GHC.Core.FamInstEnv ( FamInstEnvs, FamInst(..), apartnessCheck + , lookupFamInstEnvByTyCon ) +import GHC.Core + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set( anyVarSet ) +import GHC.Types.Name.Reader +import GHC.Types.Basic + +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.Data.Pair +import GHC.Data.Bag +import Control.Monad +import Data.Maybe ( isJust, isNothing ) +import Data.List ( zip4 ) + +import qualified Data.Semigroup as S +import Data.Bifunctor ( bimap ) +import Data.Void( Void ) + +{- ********************************************************************* +* * +* Equalities +* * +************************************************************************ + +Note [Canonicalising equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to canonicalise an equality, we look at the structure of the +two types at hand, looking for similarities. A difficulty is that the +types may look dissimilar before rewriting but similar after rewriting. +However, we don't just want to jump in and rewrite right away, because +this might be wasted effort. So, after looking for similarities and failing, +we rewrite and then try again. Of course, we don't want to loop, so we +track whether or not we've already rewritten. + +It is conceivable to do a better job at tracking whether or not a type +is rewritten, but this is left as future work. (Mar '15) + +Note [Decomposing FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~ +can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This +means that we may very well have a FunTy containing a type of some +unknown kind. For instance, we may have, + + FunTy (a :: k) Int + +Where k is a unification variable. So the calls to splitRuntimeRep_maybe may +fail (returning Nothing). In that case we'll fall through, zonk, and try again. +Zonking should fill the variable k, meaning that decomposition will succeed the +second time around. + +Also note that we require the FunTyFlag to match. This will stop +us decomposing + (Int -> Bool) ~ (Show a => blah) +It's as if we treat (->) and (=>) as different type constructors, which +indeed they are! +-} + +solveEquality :: CtEvidence -> EqRel -> Type -> Type + -> SolverStage Void +solveEquality ev eq_rel ty1 ty2 + = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 + ; mb_canon <- canonicaliseEquality ev eq_rel ty1' ty2' + + ; case mb_canon of { + + -- An IrredCt equality may be insoluble; but maybe not! + -- E.g. m a ~R# m b is not canonical, but may be + -- solved by a quantified constraint (T15290) + -- See Note [Looking up primitive equalities in quantified constraints] + Left irred_ct -> do { tryQCsIrredEqCt irred_ct + ; solveIrred irred_ct } ; + + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_rel eq_ct + ; tryQCsEqCt eq_ct + ; simpleStage (updInertEqs eq_ct) + ; stopWithStage (eqCtEvidence eq_ct) "Kept inert EqCt" } } } + +updInertEqs :: EqCt -> TcS () +updInertEqs eq_ct + = do { kickOutRewritable (KOAfterAdding (eqCtLHS eq_ct)) (eqCtFlavourRole eq_ct) + ; tc_lvl <- getTcLevel + ; updInertCans (addEqToCans tc_lvl eq_ct) } + + +{- ********************************************************************* +* * +* zonkEqTypes +* * +********************************************************************* -} + +--------------------------------- +-- | Compare types for equality, while zonking as necessary. Gives up +-- as soon as it finds that two types are not equal. +-- This is quite handy when some unification has made two +-- types in an inert Wanted to be equal. We can discover the equality without +-- rewriting, which is sometimes very expensive (in the case of type functions). +-- In particular, this function makes a ~20% improvement in test case +-- perf/compiler/T5030. +-- +-- Returns either the (partially zonked) types in the case of +-- inequality, or the one type in the case of equality. canEqReflexive is +-- a good next step in the 'Right' case. Returning 'Left' is always safe. +-- +-- NB: This does *not* look through type synonyms. In fact, it treats type +-- synonyms as rigid constructors. In the future, it might be convenient +-- to look at only those arguments of type synonyms that actually appear +-- in the synonym RHS. But we're not there yet. +zonkEqTypes :: CtEvidence -> EqRel -> TcType -> TcType -> SolverStage (Pair TcType) +zonkEqTypes ev eq_rel ty1 ty2 + = Stage $ do { res <- go ty1 ty2 + ; case res of + Left pair -> continueWith pair + Right ty -> canEqReflexive ev eq_rel ty } + where + go :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) + go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2 + go (TyVarTy tv1) ty2 = tyvar NotSwapped tv1 ty2 + go ty1 (TyVarTy tv2) = tyvar IsSwapped tv2 ty1 + + -- We handle FunTys explicitly here despite the fact that they could also be + -- treated as an application. Why? Well, for one it's cheaper to just look + -- at two types (the argument and result types) than four (the argument, + -- result, and their RuntimeReps). Also, we haven't completely zonked yet, + -- so we may run into an unzonked type variable while trying to compute the + -- RuntimeReps of the argument and result types. This can be observed in + -- testcase tc269. + go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2) + | af1 == af2 + , eqType w1 w2 + = do { res_a <- go arg1 arg2 + ; res_b <- go res1 res2 + ; return $ combine_rev (FunTy af1 w1) res_b res_a } + + go ty1@(FunTy {}) ty2 = bale_out ty1 ty2 + go ty1 ty2@(FunTy {}) = bale_out ty1 ty2 + + go ty1 ty2 + | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1 + , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2 + = if tc1 == tc2 && tys1 `equalLength` tys2 + -- Crucial to check for equal-length args, because + -- we cannot assume that the two args to 'go' have + -- the same kind. E.g go (Proxy * (Maybe Int)) + -- (Proxy (*->*) Maybe) + -- We'll call (go (Maybe Int) Maybe) + -- See #13083 + then tycon tc1 tys1 tys2 + else bale_out ty1 ty2 + + -- If you are temppted to add a case for AppTy/AppTy, be careful + -- See Note [zonkEqTypes and the PKTI] + + go ty1@(LitTy lit1) (LitTy lit2) + | lit1 == lit2 + = return (Right ty1) + + go ty1 ty2 = bale_out ty1 ty2 + -- We don't handle more complex forms here + + bale_out ty1 ty2 = return $ Left (Pair ty1 ty2) + + tyvar :: SwapFlag -> TcTyVar -> TcType + -> TcS (Either (Pair TcType) TcType) + -- Try to do as little as possible, as anything we do here is redundant + -- with rewriting. In particular, no need to zonk kinds. That's why + -- we don't use the already-defined zonking functions + tyvar swapped tv ty + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> give_up + Indirect ty' -> do { trace_indirect tv ty' + ; unSwap swapped go ty' ty } } + _ -> give_up + where + give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty + + tyvar_tyvar tv1 tv2 + | tv1 == tv2 = return (Right (mkTyVarTy tv1)) + | otherwise = do { (ty1', progress1) <- quick_zonk tv1 + ; (ty2', progress2) <- quick_zonk tv2 + ; if progress1 || progress2 + then go ty1' ty2' + else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) } + + trace_indirect tv ty + = traceTcS "Following filled tyvar (zonk_eq_types)" + (ppr tv <+> equals <+> ppr ty) + + quick_zonk tv = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> return (TyVarTy tv, False) + Indirect ty' -> do { trace_indirect tv ty' + ; return (ty', True) } } + _ -> return (TyVarTy tv, False) + + -- This happens for type families, too. But recall that failure + -- here just means to try harder, so it's OK if the type function + -- isn't injective. + tycon :: TyCon -> [TcType] -> [TcType] + -> TcS (Either (Pair TcType) TcType) + tycon tc tys1 tys2 + = do { results <- zipWithM go tys1 tys2 + ; return $ case combine_results results of + Left tys -> Left (mkTyConApp tc <$> tys) + Right tys -> Right (mkTyConApp tc tys) } + + combine_results :: [Either (Pair TcType) TcType] + -> Either (Pair [TcType]) [TcType] + combine_results = bimap (fmap reverse) reverse . + foldl' (combine_rev (:)) (Right []) + + -- combine (in reverse) a new result onto an already-combined result + combine_rev :: (a -> b -> c) + -> Either (Pair b) b + -> Either (Pair a) a + -> Either (Pair c) c + combine_rev f (Left list) (Left elt) = Left (f <$> elt <*> list) + combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list) + combine_rev f (Right tys) (Left elt) = Left (f <$> elt <*> pure tys) + combine_rev f (Right tys) (Right ty) = Right (f ty tys) + + +{- Note [zonkEqTypes and the PKTI] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because `zonkEqTypes` does /partial/ zonking, we need to be very careful +to maintain the Purely Kinded Type Invariant: see GHC.Tc.Gen/HsType +HsNote [The Purely Kinded Type Invariant (PKTI)]. + +In #26256 we try to solve this equality constraint: + Int :-> Maybe Char ~# k0 Int (m0 Char) +where m0 and k0 are unification variables, and + m0 :: Type -> Type +It happens that m0 was already unified + m0 := (w0 :: kappa) +where kappa is another unification variable that is also already unified: + kappa := Type->Type. +So the original type satisifed the PKTI, but a partially-zonked form + k0 Int (w0 Char) +does not!! (This a bit reminiscent of Note [mkAppTyM].) + +The solution I have adopted is simply to make `zonkEqTypes` bale out on `AppTy`. +After all, it's only supposed to be a quick hack to see if two types are already +equal; if we bale out we'll just get into the "proper" canonicaliser. + +The only tricky thing about this approach is that it relies on /omitting/ +code -- for the AppTy/AppTy case! Hence this Note +-} + +{- ********************************************************************* +* * +* canonicaliseEquality +* * +********************************************************************* -} + +canonicaliseEquality + :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> SolverStage (Either IrredCt EqCt) +-- 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" $ + vcat [ ppr ev, ppr eq_rel, ppr ty1, ppr ty2 ] + ; rdr_env <- getGlobalRdrEnvTcS + ; fam_insts <- getFamInstEnvs + ; can_eq_nc False rdr_env fam_insts ev eq_rel ty1 ty1 ty2 ty2 } + +can_eq_nc + :: Bool -- True => both input types are rewritten + -> GlobalRdrEnv -- needed to see which newtypes are in scope + -> FamInstEnvs -- needed to unwrap data instances + -> CtEvidence + -> EqRel + -> Type -> Type -- LHS, after and before type-synonym expansion, resp + -> Type -> Type -- RHS, after and before type-synonym expansion, resp + -> TcS (StopOrContinue (Either IrredCt EqCt)) + +-- 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 + +-- Expand synonyms first; see Note [Type synonyms and canonicalization] +can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 + | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 + +-- need to check for reflexivity in the ReprEq case. +-- See Note [Eager reflexivity check] +-- Check only when rewritten because the zonk_eq_types check in canEqNC takes +-- care of the non-rewritten case. +can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _ + | ty1 `tcEqType` ty2 + = canEqReflexive ev ReprEq ty1 + +-- When working with ReprEq, unwrap newtypes. +-- See Note [Unwrap newtypes first] +-- This must be above the TyVarTy case, in order to guarantee (TyEq:N) +can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | ReprEq <- eq_rel + , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 + = can_eq_newtype_nc rdr_env envs ev NotSwapped ty1 stuff1 ty2 ps_ty2 + + | ReprEq <- eq_rel + , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 + = can_eq_newtype_nc rdr_env envs ev IsSwapped ty2 stuff2 ty1 ps_ty1 + +-- Then, get rid of casts +can_eq_nc rewritten rdr_env envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2 + | isNothing (canEqLHS_maybe ty2) + = -- See (EIK3) in Note [Equalities with heterogeneous kinds] + canEqCast rewritten rdr_env envs ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2 +can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _ + | isNothing (canEqLHS_maybe ty1) + = -- See (EIK3) in Note [Equalities with heterogeneous kinds] + canEqCast rewritten rdr_env envs ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1 + +---------------------- +-- Otherwise try to decompose +---------------------- + +-- Literals +can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ + | l1 == l2 + = 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 + 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 (ty1,am1,ty1a,ty1b) (ty2,am2,ty2a,ty2b) + +-- Decompose type constructor applications +-- NB: we have expanded type synonyms already +can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ + | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2 + -- tcSplitTyConApp_maybe: we want to catch e.g. Maybe Int ~ (Int -> Int) + -- here for better error messages rather than decomposing into AppTys; + -- hence not using a direct match on TyConApp + + , not (isTypeFamilyTyCon tc1 || isTypeFamilyTyCon tc2) + -- A type family at the top of LHS or RHS: we want to fall through + -- to the canonical-LHS cases (look for canEqLHS_maybe) + + -- See (TC1) in Note [Canonicalising TyCon/TyCon equalities] + , let role = eqRelRole eq_rel + both_generative = isGenerativeTyCon tc1 role && isGenerativeTyCon tc2 role + , rewritten || both_generative + = canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) + +can_eq_nc _rewritten _rdr_env _envs ev eq_rel + s1@ForAllTy{} _ + s2@ForAllTy{} _ + = can_eq_nc_forall ev eq_rel s1 s2 + +-- See Note [Canonicalising type applications] about why we require rewritten types +-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families +-- NB: Only decompose AppTy for nominal equality. +-- See Note [Decomposing AppTy equalities] +can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _ + | Just (t1, s1) <- tcSplitAppTy_maybe ty1 + , Just (t2, s2) <- tcSplitAppTy_maybe ty2 + = can_eq_app ev t1 s1 t2 s2 + +------------------- +-- Can't decompose. +------------------- + +-- No similarity in type structure detected. Rewrite and try again. +can_eq_nc False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2 + = -- Rewrite the two types and try again + do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1 + ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; traceTcS "can_eq_nc: go round again" (ppr new_ev $$ ppr xi1 $$ ppr xi2) + ; can_eq_nc True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } + +---------------------------- +-- Look for a canonical LHS. +-- Only rewritten types end up below here. +---------------------------- + +-- NB: pattern match on rewritten=True: we want only rewritten types sent to canEqLHS +-- This means we've rewritten any variables and reduced any type family redexes +-- See also Note [No top-level newtypes on RHS of representational equalities] + +can_eq_nc True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 + | Just can_eq_lhs1 <- canEqLHS_maybe ty1 + = do { traceTcS "can_eq1" (ppr ty1 $$ ppr ty2) + ; canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 } + + | Just can_eq_lhs2 <- canEqLHS_maybe ty2 + = do { traceTcS "can_eq2" (ppr ty1 $$ ppr ty2) + ; canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1 } + + -- If the type is TyConApp tc1 args1, then args1 really can't be less + -- than tyConArity tc1. It could be *more* than tyConArity, but then we + -- should have handled the case as an AppTy. That case only fires if + -- _both_ sides of the equality are AppTy-like... but if one side is + -- AppTy-like and the other isn't (and it also isn't a variable or + -- saturated type family application, both of which are handled by + -- can_eq_nc), we're in a failure mode and can just fall through. + +---------------------------- +-- Fall-through. Give up. +---------------------------- + +-- We've rewritten and the types don't match. Give up. +can_eq_nc True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2 + = do { traceTcS "can_eq_nc catch-all case" (ppr ps_ty1 $$ ppr ps_ty2) + ; case eq_rel of -- See Note [Unsolved equalities] + ReprEq -> finishCanWithIrred ReprEqReason ev + NomEq -> finishCanWithIrred ShapeMismatchReason ev } + -- No need to call canEqSoftFailure/canEqHardFailure because they + -- rewrite, and the types involved here are already rewritten + + +{- Note [Unsolved equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved equality like + (a b ~R# Int) +that is not necessarily insoluble! Maybe 'a' will turn out to be a newtype. +So we want to make it a potentially-soluble Irred not an insoluble one. +Missing this point is what caused #15431 +-} + +--------------------------------- +can_eq_nc_forall :: CtEvidence -> EqRel + -> Type -> Type -- LHS and RHS + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- See Note [Solving forall equalities] + +can_eq_nc_forall ev eq_rel s1 s2 + | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_loc = loc }) <- ev + = do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2 + flags1 = binderFlags bndrs1 + flags2 = binderFlags bndrs2 + + ; if eq_rel == NomEq && not (all2 eqForAllVis flags1 flags2) -- Note [ForAllTy and type equality] + then do { traceTcS "Forall failure: visibility-mismatch" $ + vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 + , ppr flags1, ppr flags2 ] + ; canEqHardFailure ev s1 s2 } + + else + do { let free_tvs = tyCoVarsOfTypes [s1,s2] + empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs + skol_info_anon = UnifyForAllSkol phi1 + ; skol_info <- mkSkolemInfo skol_info_anon + ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ + binderVars bndrs1 + + ; let phi1' = substTy subst1 phi1 + + -- Unify the kinds, extend the substitution + go :: UnifyEnv -> [TcTyVar] -> Subst + -> [TyVarBinder] -> [TyVarBinder] -> TcM.TcM TcCoercion + go uenv (skol_tv:skol_tvs) subst2 (bndr1:bndrs1) (bndr2:bndrs2) + = do { let tv2 = binderVar bndr2 + vis1 = binderFlag bndr1 + vis2 = binderFlag bndr2 + + -- Unify the kinds, at Nominal role + -- See (SF1) in Note [Solving forall equalities] + ; kind_co <- uType (uenv `setUEnvRole` Nominal) + (tyVarKind skol_tv) + (substTy subst2 (tyVarKind tv2)) + + ; let subst2' = extendTvSubstAndInScope subst2 tv2 + (mkCastTy (mkTyVarTy skol_tv) kind_co) + -- skol_tv is already in the in-scope set, but the + -- free vars of kind_co are not; hence "...AndInScope" + ; co <- go uenv skol_tvs subst2' bndrs1 bndrs2 + + ; return (mkNakedForAllCo skol_tv vis1 vis2 kind_co co)} + -- mkNaked.. because these types are not zonked, and the + -- assertions in mkForAllCo may fail without that zonking + + -- Done: unify phi1 ~ phi2 + go uenv [] subst2 bndrs1 bndrs2 + = assert (null bndrs1 && null bndrs2) $ + uType uenv phi1' (substTyUnchecked subst2 phi2) + + go _ _ _ _ _ = panic "can_eq_nc_forall" -- case (s:ss) [] + + init_subst2 = mkEmptySubst (substInScopeSet subst1) + + ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2) + + -- Generate the constraints that live in the body of the implication + -- See (SF5) in Note [Solving forall equalities] + ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ + unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> + go uenv skol_tvs init_subst2 bndrs1 bndrs2 + + -- Solve the implication right away, using `trySolveImplication` + -- See (SF6) in Note [Solving forall equalities] + ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds) + ; ev_binds_var <- newNoTcEvBinds + ; solved <- trySolveImplication $ + (implicationPrototype (ctLocEnv loc)) + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inaccessible = False + , ic_skols = skol_tvs + , ic_given = [] + , ic_wanted = emptyWC { wc_simple = wanteds } } + + ; if solved + then do { zonked_all_co <- zonkCo all_co + -- ToDo: explain this zonk + ; setWantedEq orig_dest zonked_all_co + ; stopWith ev "Polytype equality: solved" } + else canEqSoftFailure IrredShapeReason ev s1 s2 } } + + | otherwise + = do { traceTcS "Omitting decomposition of given polytype equality" $ + pprEq s1 s2 -- See Note [Do not decompose Given polytype equalities] + ; stopWith ev "Discard given polytype equality" } + + where + split_foralls :: TcType -> TcType + -> ( [ForAllTyBinder], TcType + , [ForAllTyBinder], TcType) + -- Split matching foralls; stop when the foralls don't match + -- See #22537. See (SF3) in Note [Solving forall equalities] + -- Postcondition: the two lists of binders returned have the same length + split_foralls s1 s2 + | Just (bndr1, s1') <- splitForAllForAllTyBinder_maybe s1 + , Just (bndr2, s2') <- splitForAllForAllTyBinder_maybe s2 + = let !(bndrs1, phi1, bndrs2, phi2) = split_foralls s1' s2' + in (bndr1:bndrs1, phi1, bndr2:bndrs2, phi2) + split_foralls s1 s2 = ([], s1, [], s2) + +{- Note [Solving forall equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To solve an equality between foralls + [W] (forall a. t1) ~ (forall b. t2) +the basic plan is simple: use `trySolveImplication` to solve the +implication constraint + [W] forall a. { t1 ~ (t2[a/b]) } + +The evidence we produce is a ForAllCo; see the typing rule for +ForAllCo in Note [ForAllCo] in GHC.Tc.TyCo.Rep. + +There are lots of wrinkles of course: + +(SF1) We must check the kinds match (at Nominal role). So from + [W] (forall (a:ka). t1) ~ (forall (b:kb). t2) + we actually generate the implication + [W] forall (a:ka). { ka ~N kb, t1 ~ t2[a/b] } + These kind equalities are generated by the `go` loop in `can_eq_nc_forall`. + Why Nominal role? See the typing rule for ForAllCo. + +(SF2) At Nominal role we must check that the visiblities match. + For example + [W] (forall a. a -> a) ~N (forall b -> b -> b) + should fail. At /Representational/ role we allow this; see the + typing rule for ForAllCo, mentioned above. + +(SF3) Consider this (#22537) + newtype P a = MkP (forall c. (a,c)) + [W] (forall a. P a) ~R (forall a b. (a,b)) + The number of foralls does not line up. But if we just unwrap the outer + forall a, we'll get + [W] P a ~R forall b. (a,b) + Now unwrap the newtype + [W] (forall c. (a,c)) ~R (forall b. (a,b)) + and all is good. + + Conclusion: Don't fail if the number of foralls does not line up. Instead, + handle as many binders as are visibly apparent on both sides, and then keep + going with unification. See `split_foralls` in `can_eq_nc_forall`. In the + above example, at Representational role, the unifier will proceed to unwrap + the newtype on the RHS and we'll end up back in can_eq_nc_forall. + +(SF4) Remember also that we might have forall z (a:z). blah + so in that `go` loop, we must proceed one binder at a time (#13879) + +(SF5) Rather than manually gather the constraints needed in the body of the + implication, we use `uType`. That way we can solve some of them on the fly, + especially Refl ones. We use the `unifyForAllBody` wrapper for `uType`, + because we want to /gather/ the equality constraint (to put in the implication) + rather than /emit/ them into the monad, as `wrapUnifierTcS` does. + +(SF6) We solve the implication on the spot, using `trySolveImplication`. In + the past we instead generated an `Implication` to be solved later. Nice in + some ways but it added complexity: + - We needed a `wl_implics` field of `WorkList` to collect + these emitted implications + - The types of `solveSimpleWanteds` and friends were more complicated + - Trickily, an `EvFun` had to contain an `EvBindsVar` ref-cell, which made + `evVarsOfTerm` harder. Now an `EvFun` just contains the bindings. + The disadvantage of solve-on-the-spot is that if we fail we are simply + left with an unsolved (forall a. blah) ~ (forall b. blah), and it may + not be clear /why/ we couldn't solve it. But on balance the error messages + improve: it is easier to undertand that + (forall a. a->a) ~ (forall b. b->Int) + is insoluble than it is to understand a message about matching `a` with `Int`. +-} + +{- Note [Unwrap newtypes first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Decomposing newtype equalities] + +Consider + newtype N m a = MkN (m a) +N will get a conservative, Nominal role for its second parameter 'a', +because it appears as an argument to the unknown 'm'. Now consider + [W] N Maybe a ~R# N Maybe b + +If we /decompose/, we'll get + [W] a ~N# b + +But if instead we /unwrap/ we'll get + [W] Maybe a ~R# Maybe b +which in turn gives us + [W] a ~R# b +which is easier to satisfy. + +Conclusion: we must unwrap newtypes before decomposing them. This happens +in `can_eq_newtype_nc` + +We did flirt with making the /rewriter/ expand newtypes, rather than +doing it in `can_eq_newtype_nc`. But with recursive newtypes we want +to be super-careful about expanding! + + newtype A = MkA [A] -- Recursive! + + f :: A -> [A] + f = coerce + +We have [W] A ~R# [A]. If we rewrite [A], it'll expand to + [[[[[...]]]]] +and blow the reduction stack. See Note [Newtypes can blow the stack] +in GHC.Tc.Solver.Rewrite. But if we expand only the /top level/ of +both sides, we get + [W] [A] ~R# [A] +which we can, just, solve by reflexivity. + +So we simply unwrap, on-demand, at top level, in `can_eq_newtype_nc`. + +This is all very delicate. There is a real risk of a loop in the type checker +with recursive newtypes -- but I think we're doomed to do *something* +delicate, as we're really trying to solve for equirecursive type +equality. Bottom line for users: recursive newtypes do not play well with type +inference for representational equality. See also Section 5.3.1 and 5.3.4 of +"Safe Zero-cost Coercions for Haskell" (JFP 2016). + +See also Note [Decomposing newtype equalities]. + +--- Historical side note --- + +We flirted with doing /both/ unwrap-at-top-level /and/ rewrite-deeply; +see #22519. But that didn't work: see discussion in #22924. Specifically +we got a loop with a minor variation: + f2 :: a -> [A] + f2 = coerce + +Note [Eager reflexivity check] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + +and + + [W] X ~R X + +Naively, we would start unwrapping X and end up in a loop. Instead, +we do this eager reflexivity check. This is necessary only for representational +equality because the rewriter technology deals with the similar case +(recursive type families) for nominal equality. + +Note that this check does not catch all cases, but it will catch the cases +we're most worried about, types like X above that are actually inhabited. + +Here's another place where this reflexivity check is key: +Consider trying to prove (f a) ~R (f a). The AppTys in there can't +be decomposed, because representational equality isn't congruent with respect +to AppTy. So, when canonicalising the equality above, we get stuck and +would normally produce a CIrredCan. However, we really do want to +be able to solve (f a) ~R (f a). So, in the representational case only, +we do a reflexivity check. + +(This would be sound in the nominal case, but unnecessary, and I [Richard +E.] am worried that it would slow down the common case.) + + Note [Newtypes can blow the stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype X = MkX (Int -> X) + newtype Y = MkY (Int -> Y) + +and now wish to prove + + [W] X ~R Y + +This Wanted will loop, expanding out the newtypes ever deeper looking +for a solid match or a solid discrepancy. Indeed, there is something +appropriate to this looping, because X and Y *do* have the same representation, +in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized +coercion will ever witness it. This loop won't actually cause GHC to hang, +though, because we check our depth in `can_eq_newtype_nc`. +-} + +------------------------ +-- | We're able to unwrap a newtype. Update the bits accordingly. +can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs + -> CtEvidence -- ^ :: ty1 ~ ty2 + -> SwapFlag + -> TcType -- ^ ty1 + -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' + -> TcType -- ^ ty2 + -> TcType -- ^ ty2, with type synonyms + -> TcS (StopOrContinue (Either IrredCt EqCt)) +can_eq_newtype_nc rdr_env envs ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2 + = do { traceTcS "can_eq_newtype_nc" $ + vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ] + + -- Check for blowing our stack, and increase the depth + -- See Note [Newtypes can blow the stack] + ; let loc = ctEvLoc ev + ev' = ev `setCtEvLoc` bumpCtLocDepth loc + ; checkReductionDepth loc ty1 + + -- Next, we record uses of newtype constructors, since coercing + -- through newtypes is tantamount to using their constructors. + ; recordUsedGREs gres + + ; let redn1 = mkReduction co1 ty1' + + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev' swapped + redn1 (mkReflRedn Representational ps_ty2) + + ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 } + +--------- +-- ^ Decompose a type application. +-- All input types must be rewritten. See Note [Canonicalising type applications] +-- Nominal equality only! +can_eq_app :: CtEvidence -- :: s1 t1 ~N s2 t2 + -> Xi -> Xi -- s1 t1 + -> Xi -> Xi -- s2 t2 + -> TcS (StopOrContinue (Either IrredCt EqCt)) + +-- AppTys only decompose for nominal equality, so this case just leads +-- to an irreducible constraint; see typecheck/should_compile/T10494 +-- See Note [Decomposing AppTy equalities] +can_eq_app ev s1 t1 s2 t2 + | CtWanted (WantedCt { ctev_dest = dest }) <- ev + = do { traceTcS "can_eq_app" (vcat [ text "s1:" <+> ppr s1, text "t1:" <+> ppr t1 + , text "s2:" <+> ppr s2, text "t2:" <+> ppr t2 + , text "vis:" <+> ppr (isNextArgVisible s1) ]) + ; (co,_,_) <- wrapUnifierTcS ev Nominal $ \uenv -> + -- Unify arguments t1/t2 before function s1/s2, because + -- the former have smaller kinds, and hence simpler error messages + -- c.f. GHC.Tc.Utils.Unify.uType (go_app) + do { let arg_env = updUEnvLoc uenv (adjustCtLoc (isNextArgVisible s1) False) + ; co_t <- uType arg_env t1 t2 + ; co_s <- uType uenv s1 s2 + ; return (mkAppCo co_s co_t) } + ; setWantedEq dest co + ; stopWith ev "Decomposed [W] AppTy" } + + -- If there is a ForAll/(->) mismatch, the use of the Left coercion + -- below is ill-typed, potentially leading to a panic in splitTyConApp + -- Test case: typecheck/should_run/Typeable1 + -- We could also include this mismatch check above (for W and D), but it's slow + -- and we'll get a better error message not doing it + | s1k `mismatches` s2k + = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2) + + | CtGiven (GivenCt { ctev_evar = evar }) <- ev + = do { let co = mkCoVarCo evar + co_s = mkLRCo CLeft co + co_t = mkLRCo CRight co + ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2 + , evCoercion co_s ) + ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2 + , evCoercion co_t ) + ; emitWorkNC [CtGiven evar_t] + ; startAgainWith (mkNonCanonical $ CtGiven evar_s) } + + where + loc = ctEvLoc ev + + s1k = typeKind s1 + s2k = typeKind s2 + + k1 `mismatches` k2 + = isForAllTy k1 && not (isForAllTy k2) + || not (isForAllTy k1) && isForAllTy k2 + +----------------------- +-- | Break apart an equality over a casted type +-- looking like (ty1 |> co1) ~ ty2 (modulo a swap-flag) +canEqCast :: Bool -- are both types rewritten? + -> GlobalRdrEnv -> FamInstEnvs + -> CtEvidence + -> EqRel + -> SwapFlag + -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 + -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCast rewritten rdr_env envs ev eq_rel swapped ty1 co1 ty2 ps_ty2 + = do { traceTcS "Decomposing cast" (vcat [ ppr ev + , ppr ty1 <+> text "|>" <+> ppr co1 + , ppr ps_ty2 ]) + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkGReflLeftRedn role ty1 co1) + (mkReflRedn role ps_ty2) + ; can_eq_nc rewritten rdr_env envs new_ev eq_rel ty1 ty1 ty2 ps_ty2 } + where + role = eqRelRole eq_rel + +------------------------ +canTyConApp :: CtEvidence -> EqRel + -> 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 (ty1,tc1,tys1) (ty2,tc2,tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 + = do { inerts <- getInertSet + ; if can_decompose inerts + then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2) + else assert (eq_rel == ReprEq) $ + canEqSoftFailure ReprEqReason ev ty1 ty2 } + + -- See Note [Skolem abstract data] in GHC.Core.Tycon + | tyConSkolem tc1 || tyConSkolem tc2 + = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) + ; finishCanWithIrred AbstractTyConReason ev } + + -- Different TyCons + | NomEq <- eq_rel + = canEqHardFailure ev ty1 ty2 + + -- Different TyCons, eq_rel = ReprEq + -- See (TC2) and (TC3) in + -- Note [Canonicalising TyCon/TyCon equalities] + | both_generative + = canEqHardFailure ev ty1 ty2 + + | otherwise + = canEqSoftFailure ReprEqReason ev ty1 ty2 + where + -- See Note [Decomposing TyConApp equalities] + -- and Note [Decomposing newtype equalities] + can_decompose inerts + = isInjectiveTyCon tc1 (eqRelRole eq_rel) + || (assert (eq_rel == ReprEq) $ + -- assert: isInjectiveTyCon is always True for Nominal except + -- for type synonyms/families, neither of which happen here + -- Moreover isInjectiveTyCon is True for Representational + -- for algebraic data types. So we are down to newtypes + -- and data families. + ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts) + -- See Note [Decomposing newtype equalities] (EX2) + +{- Note [Canonicalising TyCon/TyCon equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type family TF a where TF Char = Bool + data family DF a + newtype instance DF Bool = MkDF Int + +Suppose we are canonicalising [W] Int ~R# DF (TF a). Then + +(TC1) We might have an inert Given (a ~# Char), so if we rewrote the wanted + (i.e. went around again in `can_eq_nc` with `rewritten`=True, we'd get + [W] Int ~R# DF Bool + and then the `tcTopNormaliseNewTypeTF_maybe` call would fire and + we'd unwrap the newtype. So we must do that "go round again" bit. + Hence the complicated guard (rewritten || both_generative) in `can_eq_nc`. + +(TC2) If we can't rewrite `a` yet, we'll finish with an unsolved + [W] Int ~R# DF (TF a) + in the inert set. But we must use canEqSoftFailure, not canEqHardFailure, + because it might be solved "later" when we learn more about `a`. + Hence the use of `both_generative` in `canTyConApp`. + +(TC3) Here's another example: + [G] Age ~R# Int + where Age's constructor is not in scope. We don't want to report + an "inaccessible code" error in the context of this Given! So again + we want `canEqSoftFailure`. + + For example, see typecheck/should_compile/T10493, repeated here: + import Data.Ord (Down) -- no constructor + foo :: Coercible (Down Int) Int => Down Int -> Int + foo = coerce + + That should compile, but only because we use canEqSoftFailure and + not canEqHardFailure. + +Note [Fast path when decomposing TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see (T s1 t1 ~ T s2 t2), then we can just decompose to + (s1 ~ s2, t1 ~ t2) +and push those back into the work list. But if + s1 = K k1 s2 = K k2 +then we will just decompose s1~s2, and it might be better to +do so on the spot. An important special case is where s1=s2, +and we get just Refl. + +So canDecomposableTyConAppOK uses wrapUnifierTcS etc to short-cut +that work. See also Note [Work-list ordering]. + +Note [Decomposing TyConApp equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + [G/W] T ty1 ~r T ty2 +Can we decompose it, and replace it by + [G/W] ty1 ~r' ty2 +and if so what role is r'? (In this Note, all the "~" are primitive +equalities "~#", but I have dropped the noisy "#" symbols.) Lots of +background in the paper "Safe zero-cost coercions for Haskell". + +This Note covers the topic for + * Datatypes + * Newtypes + * Data families +For the rest: + * Type synonyms: are always expanded + * Type families: see Note [Decomposing type family applications] + * AppTy: see Note [Decomposing AppTy equalities]. + +---- Roles of the decomposed constraints ---- +For a start, the role r' will always be defined like this: + * If r=N then r' = N + * If r=R then r' = role of T's first argument + +For example: + data TR a = MkTR a -- Role of T's first arg is Representational + data TN a = MkTN (F a) -- Role of T's first arg is Nominal + +The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument +role r' for a TyCon T at role r. E.g. + tyConRolesX Nominal TR = [Nominal] + tyConRolesX Representational TR = [Representational] + +---- Soundness and completeness ---- +For Givens, for /soundness/ of decomposition we need, forall ty1,ty2: + T ty1 ~r T ty2 ===> ty1 ~r' ty2 +Here "===>" means "implies". That is, given evidence for (co1 : T ty1 ~r T co2) +we can produce evidence for (co2 : ty1 ~r' ty2). But in the solver we +/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs +thereby. So for /completeness/ of decomposition we also need the reverse: + ty1 ~r' ty2 ===> T ty1 ~r T ty2 + +For Wanteds, for /soundness/ of decomposition we need: + ty1 ~r' ty2 ===> T ty1 ~r T ty2 +because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and +from that we want to derive evidence (T co2 : T ty1 ~r T ty2). +For /completeness/ of decomposition we need the reverse implication too, +else we may decompose to a new proof obligation that is stronger than +the one we started with. See Note [Decomposing newtype equalities]. + +---- Injectivity ---- +When do these bi-implications hold? In one direction it is easy. +We /always/ have + ty1 ~r' ty2 ===> T ty1 ~r T ty2 +This is the CO_TYCONAPP rule of the paper (Fig 5); see also the +TyConAppCo case of GHC.Core.Lint.lintCoercion. + +In the other direction, we have + T ty1 ~r T ty2 ==> ty1 ~r' ty2 if T is /injective at role r/ +This is the very /definition/ of injectivity: injectivity means result +is the same => arguments are the same, modulo the role shift. +See comments on GHC.Core.TyCon.isInjectiveTyCon. This is also +the CO_NTH rule in Fig 5 of the paper, except in the paper only +newtypes are non-injective at representation role, so the rule says +"H is not a newtype". + +Injectivity is a bit subtle: + Nominal Representational + Datatype YES YES + Newtype YES NO{1} + Data family YES NO{2} + +{1} Consider newtype N a = MkN (F a) -- Arg has Nominal role + Is it true that (N t1) ~R (N t2) ==> t1 ~N t2 ? + No, absolutely not. E.g. + type instance F Int = Int; type instance F Bool = Char + Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char! + + See Note [Decomposing newtype equalities] + +{2} We must treat data families precisely like newtypes, because of the + possibility of newtype instances. See also + Note [Decomposing newtype equalities]. See #10534 and + test case typecheck/should_fail/T10534. + +---- Takeaway summary ----- +For sound and complete decomposition, we simply need injectivity; +that is for isInjectiveTyCon to be true: + +* At Nominal role, isInjectiveTyCon is True for all the TyCons we are + considering in this Note: datatypes, newtypes, and data families. + +* For Givens, injectivity is necessary for soundness; completeness has no + side conditions. + +* For Wanteds, soundness has no side conditions; but injectivity is needed + for completeness. See Note [Decomposing newtype equalities] + +This is implemented in `can_decompose` in `canTyConApp`; it looks at +injectivity, just as specified above. + +Note [Work-list ordering] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider decomposing a TyCon equality + + (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k1) + +This gives rise to 2 equalities in the solver worklist + + (1) [W] k_fresh ~ k1 + (2) [W] t1::k_fresh ~ t2::k1 + +We would like to solve (1) before looking at (2), so that we don't end +up in the complexities of canEqLHSHetero. To do this: + +* `canDecomposableTyConAppOK` calls `uType` on the arguments + /left-to-right/. See the call to zipWith4M in that function. + +* `uType` keeps the bag of emitted constraints in the same + left-to-right order. See the use of `snocBag` in `uType_defer`. + +* `wrapUnifierTcS` adds the bag of deferred constraints from + `do_unifications` to the work-list using `extendWorkListChildEqs`. + +* `extendWorkListChildEqs` and `selectWorkItem` together arrange that the + list of constraints given to `extendWorkListChildEqs` is processed in + left-to-right order. + +This is not a very big deal. It reduces the number of solver steps +in the test RaeJobTalk from 1830 to 1815, a 1% reduction. But still, +it doesn't cost anything either. + +Note [Decomposing type family applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose we have + [G/W] (F ty1) ~r (F ty2) +This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2. + +We never decompose to + [G/W] ty1 ~r' ty2 + +Instead + +* For Givens we do nothing. Injective type families have no corresponding + evidence of their injectivity, so we cannot decompose an + injective-type-family Given. + +* For Wanteds, for the Nominal role only, we emit new Wanteds rather like + functional dependencies, for each injective argument position. + + E.g type family F a b -- injective in first arg, but not second + [W] (F s1 t1) ~N (F s2 t2) + Emit new Wanteds + [W] s1 ~N s2 + But retain the existing, unsolved constraint. + +Note [Decomposing newtype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note also applies to data families, which we treat like +newtype in case of 'newtype instance'. + +As Note [Decomposing TyConApp equalities] describes, if N is injective +at role r, we can do this decomposition? + [G/W] (N ty1) ~r (N ty2) to [G/W] ty1 ~r' ty2 + +For a Given with r=R, the answer is a solid NO: newtypes are not injective at +representational role, and we must not decompose, or we lose soundness. +Example is wrinkle {1} in Note [Decomposing TyConApp equalities]. + +For a Wanted with r=R, since newtypes are not injective at representational +role, decomposition is sound, but we may lose completeness. Nevertheless, +if the newtype is abstract (so can't be unwrapped) we can only solve +the equality by (a) using a Given or (b) decomposition. If (a) is impossible +(e.g. no Givens) then (b) is safe albeit potentially incomplete. + +There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete: + +* Incompleteness example (EX1): unwrap first + newtype Nt a = MkNt (Id a) + type family Id a where Id a = a + + [W] Nt Int ~R Nt Age + + Because of its use of a type family, Nt's parameter will get inferred to + 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 + 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): prioritise Nominal equalities. 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): check available Givens + newtype Nt a = Mk Bool -- NB: a is not used in the RHS, + type role Nt representational -- but the user gives it an R role anyway + + [G] Nt t1 ~R Nt t2 + [W] Nt alpha ~R Nt beta + + We *don't* want to decompose to [W] alpha ~R beta, because it's possible + that alpha and beta aren't representationally equal. And if we figure + out (elsewhere) that alpha:=t1 and beta:=t2, we can solve the Wanted + from the Given. This is somewhat similar to the question of overlapping + 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 + equalities that could later solve it. + + But what precisely does it mean to say "any Given equalities that could + later solve it"? It's tricky! + + * In #22924 we had + [G] f a ~R# a [W] Const (f a) a ~R# Const a a + where Const is an abstract newtype. If we decomposed the newtype, we + could solve. Not-decomposing on the grounds that (f a ~R# a) might turn + into (Const (f a) a ~R# Const a a) seems a bit silly. + + * In #22331 we had + [G] N a ~R# N b [W] N b ~R# N a + (where N is abstract so we can't unwrap). Here we really /don't/ want to + decompose, because the /only/ way to solve the Wanted is from that Given + (with a Sym). + + * In #22519 we had + [G] a <= b [W] IO Age ~R# IO Int + + (where IO is abstract so we can't unwrap, and newtype Age = Int; and (<=) + is a type-level comparison on Nats). Here we /must/ decompose, despite the + existence of an Irred Given, or we will simply be stuck. (Side note: We + flirted with deep-rewriting of newtypes (see discussion on #22519 and + !9623) but that turned out not to solve #22924, and also makes type + inference loop more often on recursive newtypes.) + + * In #26020 we had a /quantified/ constraint + forall x. Coercible (N t1) (N t2) + and (roughly) [W] N t1 ~R# N t2 + That quantified constraint can solve the Wanted, so don't decompose! + + The currently-implemented compromise is this: + We decompose [W] N s ~R# N t unless there is + - an Irred [G] N s' ~ N t' + - a quantified [G] forall ... => N s' ~ N t' + that is, a Given equality with both sides headed with N. + See the call to `noGivenNewtypeReprEqs` in `canTyConApp`. + + This is not perfect. In principle a Given like [G] (a b) ~ (c d), or + even just [G] c, could later turn into N s ~ N t. But since the free + vars of a Given are skolems, or at least untouchable unification + variables, this is extremely unlikely to happen. + + Another worry: there could, just, be a CDictCan with some + un-expanded equality superclasses; but only in some very obscure + recursive-superclass situations. + + Yet another approach (!) is described in + Note [Decomposing newtypes a bit more aggressively]. + +Remember: decomposing Wanteds is always /sound/. This Note is +only about /completeness/. + +Note [Decomposing newtypes a bit more aggressively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +IMPORTANT: the ideas in this Note are *not* implemented. Instead, the +current approach is detailed in Note [Decomposing newtype equalities] +and Note [Unwrap newtypes first]. +For more details about the ideas in this Note see + * GHC propoosal: https://github.com/ghc-proposals/ghc-proposals/pull/549 + * issue #22441 + * discussion on !9282. + +Consider [G] c, [W] (IO Int) ~R (IO Age) +where IO is abstract, and + newtype Age = MkAge Int -- Not abstract +With the above rules, if there any Given Irreds, +the Wanted is insoluble because we can't decompose it. But in fact, +if we look at the defn of IO, roughly, + newtype IO a = State# -> (State#, a) +we can see that decomposing [W] (IO Int) ~R (IO Age) to + [W] Int ~R Age +definitely does not lose completeness. Why not? Because the role of +IO's argment is representational. Hence: + + DecomposeNewtypeIdea: + decompose [W] (N s1 .. sn) ~R (N t1 .. tn) + if the roles of all N's arguments are representational + +If N's arguments really /are/ representational this will not lose +completeness. Here "really are representational" means "if you expand +all newtypes in N's RHS, we'd infer a representational role for each +of N's type variables in that expansion". See Note [Role inference] +in GHC.Tc.TyCl.Utils. + +But the user might /override/ a phantom role with an explicit role +annotation, and then we could (obscurely) get incompleteness. +Consider + + module A( silly, T ) where + newtype T a = MkT Int + type role T representational -- Override phantom role + + silly :: Coercion (T Int) (T Bool) + silly = Coercion -- Typechecks by unwrapping the newtype + + data Coercion a b where -- Actually defined in Data.Type.Coercion + Coercion :: Coercible a b => Coercion a b + + module B where + import A + f :: T Int -> T Bool + f = case silly of Coercion -> coerce + +Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose, +we'll get stuck with (Int ~R Bool). Instead we want to use the +[G] (T Int) ~R (T Bool), which will be in the Irreds. + +Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very +obscure incompleteness (above). But no one is reporting a problem from +the lack of decompostion, so we'll just leave it for now. This long +Note is just to record the thinking for our future selves. + +Note [Decomposing AppTy equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For AppTy all the same questions arise as in +Note [Decomposing TyConApp equalities]. We have + + s1 ~r s2, t1 ~N t2 ==> s1 t1 ~r s2 t2 (rule CO_APP) + s1 t1 ~N s2 t2 ==> s1 ~N s2, t1 ~N t2 (CO_LEFT, CO_RIGHT) + +In the first of these, why do we need Nominal equality in (t1 ~N t2)? +See {2} below. + +For sound and complete solving, we need both directions to decompose. So: +* At nominal role, all is well: we have both directions. +* At representational role, decomposition of Givens is unsound (see {1} below), + and decomposition of Wanteds is incomplete. + +Here is an example of the incompleteness for Wanteds: + + [G] g1 :: a ~R b + [W] w1 :: Maybe b ~R alpha a + [W] w2 :: alpha ~N Maybe + +Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get + + w1 := AppCo w3 w4 + [W] w3 :: Maybe ~R alpha + [W] w4 :: b ~N a + +Note that w4 is *nominal*. A nominal role here is necessary because AppCo +requires a nominal role on its second argument. (See {2} for an example of +why.) Now we are stuck, because w4 is insoluble. On the other hand, if we +see w2 first, setting alpha := Maybe, all is well, as we can decompose +Maybe b ~R Maybe a into b ~R a. + +Another example: + newtype Phant x = MkPhant Int + [W] w1 :: Phant Int ~R alpha Bool + [W] w2 :: alpha ~ Phant + +If we see w1 first, decomposing would be disastrous, as we would then try +to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become + [W] w1' :: Phant Int ~R Phant Bool + +which can then (assuming MkPhant is in scope) be simplified to Int ~R Int, +and all will be well. See also Note [Unwrap newtypes first]. + +Bottom line: +* Always decompose AppTy at nominal role: can_eq_app +* Never decompose AppTy at representational role (neither Given nor Wanted): + the lack of an equation in can_eq_nc + +Extra points +{1} Decomposing a Given AppTy over a representational role is simply + unsound. For example, if we have co1 :: Phant Int ~R a Bool (for + the newtype Phant, above), then we surely don't want any relationship + between Int and Bool, lest we also have co2 :: Phant ~ a around. + +{2} The role on the AppCo coercion is a conservative choice, because we don't + know the role signature of the function. For example, let's assume we could + have a representational role on the second argument of AppCo. Then, consider + + data G a where -- G will have a nominal role, as G is a GADT + MkG :: G Int + newtype Age = MkAge Int + + co1 :: G ~R a -- by assumption + co2 :: Age ~R Int -- by newtype axiom + co3 = AppCo co1 co2 :: G Age ~R a Int -- by our broken AppCo + + and now co3 can be used to cast MkG to have type G Age, in violation of + the way GADTs are supposed to work (which is to use nominal equality). +-} + +canDecomposableTyConAppOK :: CtEvidence -> EqRel + -> TyCon + -> (Type,[TcType]) -> (Type,[TcType]) + -> TcS (StopOrContinue a) +-- Precondition: tys1 and tys2 are the same finite length, hence "OK" +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) + ; case ev of + CtWanted (WantedCt { ctev_dest = dest }) + -- new_locs and tc_roles are both infinite, so we are + -- guaranteed that cos has the same length as tys1 and tys2 + -- See Note [Fast path when decomposing TyConApps] + -> do { (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> + do { cos <- zipWith4M (u_arg uenv) new_locs tc_roles tys1 tys2 + -- zipWith4M: see Note [Work-list ordering] + ; return (mkTyConAppCo role tc cos) } + ; setWantedEq dest co } + + CtGiven (GivenCt { ctev_evar = evar }) + | let pred_ty = mkEqPred eq_rel ty1 ty2 + ev_co = mkCoVarCo (setVarType evar pred_ty) + -- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs + -- Remember: ty1/ty2 may be more fully zonked than evar + -- See the call to canonicaliseEquality in solveEquality. + -> emitNewGivens loc + [ (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) ] + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + + u_arg uenv arg_loc arg_role = uType arg_env + where + arg_env = uenv `setUEnvRole` arg_role + `updUEnvLoc` const arg_loc + + -- Infinite, to allow for over-saturated TyConApps + tc_roles = tyConRoleListX role tc + + -- Add nuances to the location during decomposition: + -- * if the argument is a kind argument, remember this, so that error + -- messages say "kind", not "type". This is determined based on whether + -- the corresponding tyConBinder is named (that is, dependent) + -- * if the argument is invisible, note this as well, again by + -- looking at the corresponding binder + -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't + -- do either of these changes. (Forgetting to do so led to #16188) + -- + -- NB: infinite in length + new_locs = [ adjustCtLocTyConBinder bndr loc + | bndr <- tyConBinders tc ] + ++ repeat loc + +canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag + -> (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@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2) + = do { traceTcS "canDecomposableFunTy" + (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2) + ; case ev of + CtWanted (WantedCt { ctev_dest = dest }) + -> do { (co, _, _) <- wrapUnifierTcS ev Nominal $ \ uenv -> + do { let mult_env = uenv `updUEnvLoc` toInvisibleLoc + `setUEnvRole` funRole role SelMult + ; mult <- uType mult_env m1 m2 + ; arg <- uType (uenv `setUEnvRole` funRole role SelArg) a1 a2 + ; res <- uType (uenv `setUEnvRole` funRole role SelRes) r1 r2 + ; return (mkNakedFunCo role af mult arg res) } + ; setWantedEq dest co } + + CtGiven (GivenCt { ctev_evar = evar }) + | let pred_ty = mkEqPred eq_rel ty1 ty2 + ev_co = mkCoVarCo (setVarType evar pred_ty) + -- setVarType: satisfy Note [mkSelCo precondition] in Coercion.hs + -- Remember: ty1/ty2 may be more fully zonked than evar + -- See the call to canonicaliseEquality in solveEquality. + -> emitNewGivens loc + [ (funRole role fs, mkSelCo (SelFun fs) ev_co) + | fs <- [SelMult, SelArg, SelRes] ] + + ; stopWith ev "Decomposed TyConApp" } + + where + loc = ctEvLoc ev + role = eqRelRole eq_rel + +-- | Call canEqSoftFailure when canonicalizing an equality fails, but if the +-- equality is representational, there is some hope for the future. +canEqSoftFailure :: CtIrredReason -> CtEvidence -> TcType -> TcType + -> TcS (StopOrContinue (Either IrredCt a)) +canEqSoftFailure reason ev ty1 ty2 + = do { (redn1, rewriters1) <- rewrite ev ty1 + ; (redn2, rewriters2) <- rewrite ev ty2 + -- We must rewrite the types before putting them in the + -- inert set, so that we are sure to kick them out when + -- new equalities become available + ; traceTcS "canEqSoftFailure" $ + vcat [ ppr ev, ppr redn1, ppr redn2 ] + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; finishCanWithIrred reason new_ev } + +-- | Call when canonicalizing an equality fails with utterly no hope. +canEqHardFailure :: CtEvidence -> TcType -> TcType + -> TcS (StopOrContinue (Either IrredCt a)) +-- See Note [Make sure that insolubles are fully rewritten] +canEqHardFailure ev ty1 ty2 + = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2) + ; (redn1, rewriters1) <- rewriteForErrors ev ty1 + ; (redn2, rewriters2) <- rewriteForErrors ev ty2 + ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 + ; finishCanWithIrred ShapeMismatchReason new_ev } + +{- +Note [Canonicalising type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (s1 t1) ~ ty2, how should we proceed? +The simple thing is to see if ty2 is of form (s2 t2), and +decompose. + +However, over-eager decomposition gives bad error messages +for things like + a b ~ Maybe c + e f ~ p -> q +Suppose (in the first example) we already know a~Array. Then if we +decompose the application eagerly, yielding + a ~ Maybe + b ~ c +we get an error "Can't match Array ~ Maybe", +but we'd prefer to get "Can't match Array b ~ Maybe c". + +So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of +replacing (a b) by (Array b), before using try_decompose_app to +decompose it. + +Note [Make sure that insolubles are fully rewritten] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When an equality fails, we still want to rewrite the equality +all the way down, so that it accurately reflects + (a) the mutable reference substitution in force at start of solving + (b) any ty-binds in force at this point in solving +See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet. +And if we don't do this there is a bad danger that +GHC.Tc.Solver.applyTyVarDefaulting will find a variable +that has in fact been substituted. + +Note [Do not decompose Given polytype equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] (forall a. t1 ~ forall a. t2). Can we decompose this? +No -- what would the evidence look like? So instead we simply discard +this given evidence. + +Note [No top-level newtypes on RHS of representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we're in this situation: + + work item: [W] c1 : a ~R b + inert: [G] c2 : b ~R Id a + +where + newtype Id a = Id a + +We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten +and the Id newtype is unwrapped. This is assured by requiring only rewritten +types in canEqCanLHS *and* having the newtype-unwrapping check above +the tyvar check in can_eq_nc. + +Note that this only applies to saturated applications of newtype TyCons, as +we can't rewrite an unsaturated application. See for example T22310, where +we ended up with: + + newtype Compose f g a = ... + + [W] t[tau] ~# Compose Foo Bar + +Note [Put touchable variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #10009, a very nasty example: + + f :: (UnF (F b) ~ b) => F b -> () + + g :: forall a. (UnF (F a) ~ a) => a -> () + g _ = f (undefined :: F a) + +For g we get [G] g1 : UnF (F a) ~ a + [W] w1 : UnF (F beta) ~ beta + [W] w2 : F a ~ F beta + +g1 is canonical (CEqCan). It is oriented as above because a is not touchable. +See canEqTyVarFunEq. + +w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key +here. + +w2 is canonical. But which way should it be oriented? As written, we'll be +stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is +a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS +of w2. We'll thus lose. + +But if w2 is swapped around, to + + [W] w3 : F beta ~ F a + +then we'll kick w1 out of the inert set (it mentions the LHS of w3). We then +rewrite w1 to + + [W] w4 : UnF (F a) ~ beta + +and then, using g1, to + + [W] w5 : a ~ beta + +at which point we can unify and go on to glory. (This rewriting actually +happens all at once, in the call to rewrite during canonicalisation.) + +But what about the new LHS makes it better? It mentions a variable (beta) +that can appear in a Wanted -- a touchable metavariable never appears +in a Given. On the other hand, the original LHS mentioned only variables +that appear in Givens. We thus choose to put variables that can appear +in Wanteds on the left. + +Ticket #12526 is another good example of this in action. + +-} + +--------------------- +canEqCanLHS :: CtEvidence -- ev :: lhs ~ rhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- lhs: pretty lhs, already rewritten + -> TcType -> TcType -- rhs: already rewritten + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | k1 `tcEqType` k2 + = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + + | otherwise + = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2 + + where + k1 = canEqLHSKind lhs1 + k2 = typeKind xi2 + + +{- +Note [Kind Equality Orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in +practice it does not. See Note [Fundeps with instances, and equality +orientation] where this is discussed at length. As a rule of thumb: we keep +the newest unification variables on the left of the equality. See also +Note [Improvement orientation]. + +In particular, `canEqCanLHSHetero` produces the following constraint equalities + +[X] (xi1 :: ki1) ~ (xi2 :: ki2) + --> [X] kco :: ki1 ~ ki2 + [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1 + +Note that the types in the LHS of the new constraints are the ones that were on the LHS of +the original constraint. + +--- Historical note --- +We prevously used to flip the kco to avoid using a sym in the cast + +[X] (xi1 :: ki1) ~ (xi2 :: ki2) + --> [X] kco :: ki2 ~ ki1 + [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1 + +But this sent solver in an infinite loop (see #19415). +-- End of historical note -- +-} + +canEqCanLHSHetero :: CtEvidence -- :: (xi1 :: ki1) ~ (xi2 :: ki2) + -- (or reversed if SwapFlag=IsSwapped) + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- xi1 + -> TcKind -- ki1 + -> TcType -> TcType -- xi2 + -> TcKind -- ki2 + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2 +-- See Note [Equalities with heterogeneous kinds] +-- See Note [Kind Equality Orientation] + +-- NB: preserve left-to-right orientation!! See wrinkle (W2) in +-- Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict +-- NotSwapped: +-- ev :: (lhs1:ki1) ~r# (xi2:ki2) +-- kind_co :: k11 ~# ki2 -- Same orientation as ev +-- new_ev :: lhs1 ~r# (xi2 |> sym kind_co) +-- Swapped +-- ev :: (xi2:ki2) ~r# (lhs1:ki1) +-- kind_co :: ki2 ~# ki1 -- Same orientation as ev +-- new_ev :: (xi2 |> kind_co) ~r# lhs1 +-- Note that we need the `sym` when we are /not/ swapped; hence `mk_sym_co` + + = case ev of + CtGiven (GivenCt { ctev_evar = evar, ctev_loc = loc }) + -> do { let kind_co = mkKindCo (mkCoVarCo evar) + pred_ty = unSwap swapped mkNomEqPred ki1 ki2 + kind_loc = mkKindEqLoc xi1 xi2 loc + ; kind_ev <- newGivenEvVar kind_loc (pred_ty, evCoercion kind_co) + ; emitWorkNC [CtGiven kind_ev] + ; finish emptyRewriterSet (givenCtEvCoercion kind_ev) } + + CtWanted {} + -> do { (kind_co, cts, unifs) <- wrapUnifierTcS ev Nominal $ \uenv -> + let uenv' = updUEnvLoc uenv (mkKindEqLoc xi1 xi2) + in unSwap swapped (uType uenv') ki1 ki2 + -- mkKindEqLoc: any new constraints, arising from the kind + -- unification, say they thay come from unifying xi1~xi2 + ; if not (null unifs) + then -- Unifications happened, so start again to do the zonking + -- Otherwise we might put something in the inert set that isn't inert + startAgainWith (mkNonCanonical ev) + else + + assertPpr (not (isEmptyCts cts)) (ppr ev $$ ppr ki1 $$ ppr ki2) $ + -- assert: the constraints won't be empty because the two kinds differ, + -- and there are no unifications, so we must have emitted one or + -- more constraints + finish (rewriterSetFromCts cts) kind_co } + -- rewriterSetFromCts: record in the /type/ unification xi1~xi2 that + -- it has been rewritten by any (unsolved) consraints in `cts`; that + -- stops xi1~xi2 from unifying until `cts` are solved. See (EIK2). + where + xi1 = canEqLHSType lhs1 + role = eqRelRole eq_rel + + finish rewriters kind_co + = do { traceTcS "Hetero equality gives rise to kind equality" + (ppr swapped $$ + ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) + ; new_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn + -- rewriteEqEvidence adds any as-yet-unsolved equalities + -- from the kind equality (namely `rewriters`) to the + -- rewriter set for `new_ev`. See (EIK2). + + -- Now `new_ev` is homogenous: carry on! + ; canEqCanLHSHomo new_ev eq_rel NotSwapped lhs1 ps_xi1 new_xi2 new_xi2 } + + where + -- kind_co :: ki1 ~N ki2 + lhs_redn = mkReflRedn role ps_xi1 + rhs_redn = mkGReflRightRedn role xi2 sym_kind_co + new_xi2 = mkCastTy ps_xi2 sym_kind_co + + -- Apply mkSymCo when /not/ swapped + sym_kind_co = case swapped of + NotSwapped -> mkSymCo kind_co + IsSwapped -> kind_co + + +canEqCanLHSHomo :: CtEvidence -- lhs ~ rhs + -- or, if swapped: rhs ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -> TcType -- lhs, pretty lhs + -> TcType -> TcType -- rhs, pretty rhs + -> TcS (StopOrContinue (Either IrredCt EqCt)) +-- Guaranteed that typeKind lhs == typeKind rhs +canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2 + | (xi2', mco) <- split_cast_ty xi2 + , Just lhs2 <- canEqLHS_maybe xi2' + = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco + + | otherwise + = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2 + + where + split_cast_ty (CastTy ty co) = (ty, MCo co) + split_cast_ty other = (other, MRefl) + +-- This function deals with the case that both LHS and RHS are potential +-- CanEqLHSs. +canEqCanLHS2 :: CtEvidence -- lhs ~ (rhs |> mco) + -- or, if swapped: (rhs |> mco) ~ lhs + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs (or, if swapped, rhs) + -> TcType -- pretty lhs + -> CanEqLHS -- rhs + -> TcType -- pretty rhs + -> MCoercion -- :: kind(rhs) ~N kind(lhs) + -> TcS (StopOrContinue (Either IrredCt EqCt)) +canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco + | lhs1 `eqCanEqLHS` lhs2 + -- It must be the case that mco is reflexive + = canEqReflexive ev eq_rel lhs1_ty + + | TyVarLHS tv1 <- lhs1 + , TyVarLHS tv2 <- lhs2 + = -- See Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify + do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) + ; if swapOverTyVars (isGiven ev) tv1 tv2 + then finish_with_swapping + else finish_without_swapping } + + | TyVarLHS {} <- lhs1 + , TyFamLHS {} <- lhs2 + = if put_tyvar_on_lhs + then finish_without_swapping + else finish_with_swapping + + | TyFamLHS {} <- lhs1 + , TyVarLHS {} <- lhs2 + = if put_tyvar_on_lhs + then finish_with_swapping + else finish_without_swapping + + | 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) + ; tclvl <- getTcLevel + ; let tvs1 = tyCoVarsOfTypes fun_args1 + tvs2 = tyCoVarsOfTypes fun_args2 + + -- See Note [Orienting TyFamLHS/TyFamLHS] + swap_for_size = typesSize fun_args2 > typesSize fun_args1 + + -- See Note [Orienting TyFamLHS/TyFamLHS] + meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1 + meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 + swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs + -- See Note [Put touchable variables on the left] + -- This second check is just to avoid unfruitful swapping + + -- It's important that we don't flip-flop (#T24134) + -- So swap_for_rewriting "wins", and we only try swap_for_size + -- 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 } + where + sym_mco = mkSymMCo mco + role = eqRelRole eq_rel + lhs1_ty = canEqLHSType lhs1 + lhs2_ty = canEqLHSType lhs2 + + finish_without_swapping + = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) + + -- Swapping. We have ev : lhs1 ~ lhs2 |> co + -- We swap to new_ev : lhs2 ~ lhs1 |> sym co + -- ev = grefl1 ; sym new_ev ; grefl2 + -- where grefl1 : lhs1 ~ lhs1 |> sym co + -- grefl2 : lhs2 ~ lhs2 |> co + finish_with_swapping + = do { let lhs1_redn = mkGReflRightMRedn role lhs1_ty sym_mco + lhs2_redn = mkGReflLeftMRedn role lhs2_ty mco + ; new_ev <-rewriteEqEvidence emptyRewriterSet ev swapped lhs1_redn lhs2_redn + ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } + + put_tyvar_on_lhs = isWanted ev && eq_rel == NomEq + -- See Note [Orienting TyVarLHS/TyFamLHS] + -- Same conditions as for canEqCanLHSFinish_try_unification + -- which we are setting ourselves up for here + +{- Note [Orienting TyVarLHS/TyFamLHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What if one side is a TyVarLHS and the other is a TyFamLHS, (a ~ F tys)? +Which to put on the left? Answer: + +* If there is no chance of unifying, put the type family on the left, + (F tys ~ a), because it's generally better to rewrite away function + calls. See `put_tyvar_on_lhs` in canEqCanLHS2; and + Note [Orienting TyVarLHS/TyFamLHS] + +* But if there /is/ a chance of unifying, put the tyvar on the left, + (a ~ F tys), as this may be our only shot to unify. Again see + `put_tyvar_on_lhs`. + +* But if we /fail/ to unify then flip back to (F tys ~ a) because it's + generally better to rewrite away function calls. See the call to + `swapAndFinish` in `canEqCanLHSFinish_try_unification` + + It's important to flip back. Consider + [W] F alpha ~ alpha + [W] F alpha ~ beta + [W] G alpha beta ~ Int ( where we have type instance G a a = a ) + If we end up with a stuck alpha ~ F alpha, we won't be able to solve this. + Test case: indexed-types/should_compile/CEqCanOccursCheck + +Note [Orienting TyFamLHS/TyFamLHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a TyFamLHS on both sides, we choose how to orient it. + +* swap_for_size. If we have + S a ~ F (G (H (Maybe a))) + then we swap so that we tend to rewrite the bigger type (F (G (H (Maybe a)))) + into the smaller one (S a). This same test tends to avoid occurs-check + errors. E.g. + S g ~ F (G (S g)) + Here (S g) occurs on the RHS, so this is not canonical. But if we swap it + around, it /is/ canonical + F (G (S g)) ~ S g + +* swap_for_rewriting: put touchable meta-tyvars on the left: + see Note [Put touchable variables on the left] +-} + +-- The RHS here is either not CanEqLHS, or it's one that we +-- want to rewrite the LHS to (as per e.g. swapOverTyVars) +canEqCanLHSFinish, canEqCanLHSFinish_try_unification, + canEqCanLHSFinish_no_unification + :: CtEvidence -- (lhs ~ rhs) or if swapped (rhs ~ lhs) + -> EqRel -> SwapFlag + -> CanEqLHS -- lhs + -> TcType -- rhs + -> TcS (StopOrContinue (Either IrredCt EqCt)) + -- RHS is fully rewritten, but with type synonyms + -- preserved as much as possible + -- Guaranteed preconditions that + -- (TyEq:K) handled in canEqCanLHSHomo + -- (TyEq:N) checked in can_eq_nc + -- (TyEq:TV) handled in canEqCanLHS2 + +--------------------------- +canEqCanLHSFinish ev eq_rel swapped lhs rhs + = do { traceTcS "canEqCanLHSFinish" $ + vcat [ text "ev:" <+> ppr ev + , text "swapped:" <+> ppr swapped + , text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ] + + -- Assertion: (TyEq:K) is already satisfied + ; massert (canEqLHSKind lhs `eqType` typeKind rhs) + + -- Assertion: (TyEq:N) is already satisfied (if applicable) + ; assertPprM ty_eq_N_OK $ + vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied" + , text "rhs:" <+> ppr rhs ] + + ; canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs } + + where + -- This is about (TyEq:N): check that we don't have a saturated application + -- of a newtype TyCon at the top level of the RHS, if the constructor + -- of the newtype is in scope. + ty_eq_N_OK :: TcS Bool + ty_eq_N_OK + | ReprEq <- eq_rel + , Just (tc, tc_args) <- splitTyConApp_maybe rhs + , Just con <- newTyConDataCon_maybe tc + -- #22310: only a problem if the newtype TyCon is saturated. + , tc_args `lengthAtLeast` tyConArity tc + -- #21010: only a problem if the newtype constructor is in scope. + = do { rdr_env <- getGlobalRdrEnvTcS + ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con) + ; return $ not con_in_scope } + | otherwise + = return True + +----------------------- +canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs + -- Try unification; for Wanted, Nominal equalities with a meta-tyvar on the LHS + | CtWanted wev <- ev -- See Note [Do not unify Givens] + , NomEq <- eq_rel -- See Note [Do not unify representational equalities] + , wantedCtHasNoRewriters wev -- See Note [Unify only if the rewriter set is empty] + , TyVarLHS lhs_tv <- lhs + = do { given_eq_lvl <- getInnermostGivenEqLevel + ; case simpleUnifyCheck UC_Solver given_eq_lvl lhs_tv rhs of + SUC_CanUnify -> + unify lhs_tv (mkReflRedn Nominal rhs) + SUC_CannotUnify + | Just can_rhs <- canTyFamEqLHS_maybe rhs + -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS] + | otherwise + -> finish_no_unify + SUC_NotSure -> + -- We have a touchable unification variable on the left, + -- and the top-shape check succeeded. These are both guaranteed + -- by the fact that simpleUnifyCheck did not return SUC_CannotUnify. + do { let flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv + ; check_result <- wrapTcS (checkTyEqRhs flags rhs) + ; case check_result of + PuOK cts rhs_redn -> + do { emitWork cts + ; unify lhs_tv rhs_redn } + PuFail reason + | Just can_rhs <- canTyFamEqLHS_maybe rhs + -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS] + | reason `cterHasOnlyProblems` do_not_prevent_rewriting + -> + -- ContinueWith, to allow using this constraint for + -- rewriting (e.g. alpha[2] ~ beta[3]). + do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs , eq_rhs = rhs } + } + | otherwise + -> try_irred reason + } + } + -- Otherwise unification is off the table + | otherwise + = finish_no_unify + + where + -- We can't unify, but this equality can go in the inert set + -- and be used to rewrite other constraints. + finish_no_unify = + canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + + -- We can't unify, and this equality should not be used to rewrite + -- other constraints (e.g. because it has an occurs check). + -- So add it to the inert Irreds. + try_irred reason = + tryIrredInstead reason ev eq_rel swapped lhs rhs + + -- We can't unify as-is, and want to flip the equality around. + -- Example: alpha ~ F tys, flip it around to become the canonical + -- equality f tys ~ alpha. + swap_and_finish tv can_rhs = + swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs + + -- We can unify; go ahead and do so. + unify tv rhs_redn = + + do { -- In the common case where rhs_redn is Refl, we don't need to rewrite + -- the evidence, even if swapped=IsSwapped. Suppose the original was + -- [W] co : Int ~ alpha + -- We unify alpha := Int, and set co := . No need to + -- swap to co = sym co' + -- co' = + new_ev <- if isReflCo (reductionCoercion rhs_redn) + then return ev + else rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn + + ; let tv_ty = mkTyVarTy tv + final_rhs = reductionReducedType rhs_redn + + ; traceTcS "Sneaky unification:" $ + vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs, + text "Coercion:" <+> pprEq tv_ty final_rhs, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind final_rhs) ] + + -- Update the unification variable itself + ; unifyTyVar tv final_rhs + + -- Provide Refl evidence for the constraint + -- Ignore 'swapped' because it's Refl! + ; setEvBindIfWanted new_ev EvCanonical $ + evCoercion (mkNomReflCo final_rhs) + + -- Kick out any constraints that can now be rewritten + ; kickOutAfterUnification [tv] + + ; return (Stop new_ev (text "Solved by unification")) } + +--------------------------- +-- Unification is off the table +canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs + = do { -- Do checkTypeEq to guarantee (TyEq:OC), (TyEq:F) + -- Must do the occurs check even on tyvar/tyvar equalities, + -- in case have x ~ (y :: ..x...); this is #12593. + ; check_result <- checkTypeEq ev eq_rel lhs rhs + + ; let lhs_ty = canEqLHSType lhs + ; case check_result of + PuFail reason + + -- If we had F a ~ G (F a), which gives an occurs check, + -- then swap it to G (F a) ~ F a, which does not + -- However `swap_for_size` above will orient it with (G (F a)) on + -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't + -- matter: in the occurs check case swap_for_rewriting will be moot. + -- TL;DR: the next four lines of code are redundant + -- I'm leaving them here in case they become relevant again +-- | TyFamLHS {} <- lhs +-- , Just can_rhs <- canTyFamEqLHS_maybe rhs +-- , reason `cterHasOnlyProblem` cteSolubleOccurs +-- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs +-- | otherwise + + | reason `cterHasOnlyProblems` do_not_prevent_rewriting + -> do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs , eq_rhs = rhs } + } + + | otherwise + -> tryIrredInstead reason ev eq_rel swapped lhs rhs + + PuOK _ rhs_redn + -> do { new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn (eqRelRole eq_rel) lhs_ty) + rhs_redn + + -- Important: even if the coercion is Refl, + -- * new_ev has reductionReducedType on the RHS + -- * eq_rhs is set to reductionReducedType + -- See Note [Forgetful synonyms in checkTyConApp] in GHC.Tc.Utils.Unify + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = lhs + , eq_rhs = reductionReducedType rhs_redn } } } + +-- | Some problems prevent /unification/ but not /rewriting/: +-- +-- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3] +-- we can't unify (skolem-escape); but it /is/ canonical, +-- and hence we /can/ use it for rewriting +-- +-- Concrete-ness: alpha[conc] ~ b[sk] +-- We can use it to rewrite; we still have to solve the original +do_not_prevent_rewriting :: CheckTyEqResult +do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<> + cteProblem cteConcrete + +---------------------- +swapAndFinish :: CtEvidence -> EqRel -> SwapFlag + -> TcType -> CanEqLHS -- ty ~ F tys + -> TcS (StopOrContinue (Either unused EqCt)) +-- We have an equality alpha ~ F tys, that we can't unify e.g because 'tys' +-- mentions alpha, it would not be a canonical constraint as-is. +-- We want to flip it to (F tys ~ a), whereupon it is canonical +swapAndFinish ev eq_rel swapped lhs_ty can_rhs + = do { let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev (flipSwap swapped) + (mkReflRedn role (canEqLHSType can_rhs)) + (mkReflRedn role lhs_ty) + ; continueWith $ Right $ + EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel + , eq_lhs = can_rhs, eq_rhs = lhs_ty } } + +---------------------- +tryIrredInstead :: CheckTyEqResult -> CtEvidence + -> EqRel -> SwapFlag -> CanEqLHS -> TcType + -> TcS (StopOrContinue (Either IrredCt unused)) +-- We have a non-canonical equality +-- We still swap it if 'swapped' says so, so that it is oriented +-- in the direction that the error-reporting machinery +-- expects it; e.g. (m ~ t m) rather than (t m ~ m) +-- This is not very important, and only affects error reporting. +tryIrredInstead reason ev eq_rel swapped lhs rhs + = do { traceTcS "cantMakeCanonical" (ppr reason $$ ppr lhs $$ ppr rhs) + ; let role = eqRelRole eq_rel + ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped + (mkReflRedn role (canEqLHSType lhs)) + (mkReflRedn role rhs) + ; finishCanWithIrred (NonCanonicalReason reason) new_ev } + +finishCanWithIrred :: CtIrredReason -> CtEvidence + -> TcS (StopOrContinue (Either IrredCt a)) +finishCanWithIrred reason ev + = do { -- Abort fast if we have any insoluble Wanted constraints, + -- and the TcS abort-if-insoluble flag is on. + when (isInsolubleReason reason) tryEarlyAbortTcS + + ; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } } + +----------------------- +-- | Solve a reflexive equality constraint +canEqReflexive :: CtEvidence -- ty ~ ty + -> EqRel + -> TcType -- ty + -> TcS (StopOrContinue a) -- always Stop +canEqReflexive ev eq_rel ty + = do { setEvBindIfWanted ev EvCanonical $ + evCoercion (mkReflCo (eqRelRole eq_rel) ty) + ; stopWith ev "Solved by reflexivity" } + +{- Note [Equalities with heterogeneous kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What do we do when we have an equality + + (tv :: k1) ~ (rhs :: k2) + +where k1 and k2 differ? Easy: we create a coercion that relates k1 and +k2 and use this to cast. To wit, from + + [X] co1 :: (tv :: k1) ~ (rhs :: k2) + +(where [X] is [G] or [W]), we go to + + co1 = co2 ; sym (GRefl kco) + [X] co2 :: (tv :: k1) ~ ((rhs |> sym kco) :: k1) + [X] kco :: k1 ~ k2 + +Wrinkles: + +(EIK1) When X=Wanted, the new type-level wanted for `co` is effectively rewritten by + the kind-level one. We thus include the kind-level wanted in the RewriterSet + for the type-level one. See Note [Wanteds rewrite Wanteds] in + GHC.Tc.Types.Constraint. This is done in canEqCanLHSHetero. + +(EIK2) Suppose we have [W] (a::Type) ~ (b::Type->Type). The above rewrite will produce + [W] w (rewriters: {kw}) : a ~ (b |> kw) + [W] kw : Type ~ (Type->Type) + + We track `w` as having `kw` in its rewriter set. That will stop us unifying `w` + (see Note [Unify only if the rewriter set is empty] in GHC.Tc.Solver.Equality). + + But `w` is still /canonical/, and used for rewriting other constraints. + See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. That's important + in general. Consider: + [W] kw : k ~ Type + [W] w : a ~ F k t + We can rewrite `w` with `kw` like this: + [W] w' (rewriters: {kw}) : a ~ F Type (t |> kw) + The cast on the second argument of `F` is necessary to keep the appliation well-kinded. + There is nothing special here; no reason not treat w' as canonical, and use it for + rewriting. Indeed test JuanLopez only typechecks if we do. + + So here is our implementation: + * When doing the kind unification, any equality constraints we can't solve + immediately get an origin that tells that the constraint arises from + the kind of the parent type-equality. See the calls to `mkKindEqLoc` + in `canEqCanLHSHetero`. + + * We /also/ add these unsolved kind equalities to the `RewriterSet` of the + parent constraint; see the call to `rewriteEqEvidence` in `finish` in + `canEqCanLHSHetero`. + + * When filling a coercion hole we kick out any equality constraints whose + rewriter set mentions this hole. See `kickOutAfterFillingCoercionHole` + +(EIK3) Suppose we have [W] co1 : (a :: k1) ~ (rhs :: k2). We duly follow the + algorithm detailed here, producing [W] kco :: k1 ~ k2, and adding + [W] co2 : (a :: k1) ~ ((rhs |> sym kco) :: k1) to the inert set. + Some time later, we solve `kco`, and fill in kco's coercion hole. + This kicks out the inert equality `co2` + + But now, during canonicalization, we see the cast and remove it, in + `canEqCast`. By the time we get into `canEqCanLHS`, the equality is + heterogeneous again, and the process repeats! + + To avoid this, we don't strip casts off a type if the other type in the + equality is a CanEqLHS. See the `CastTy` case of `can_eq_nc`. + (The scenario above can happen with a type family, too. + testcase: typecheck/should_compile/T13822). + + And this is an improvement regardless: because tyvars can, generally, + unify with casted types, there's no reason to go through the work of + stripping off the cast when the cast appears opposite a tyvar. + +Historical note: + +We used to do this via emitting a Derived kind equality and then parking +the heterogeneous equality as irreducible. But this new approach is much +more direct. And it doesn't produce duplicate Deriveds (as the old one did). + +Note [Type synonyms and canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat type synonym applications as xi types, that is, they do not +count as type function applications. However, we do need to be a bit +careful with type synonyms: like type functions they may not be +generative or injective. However, unlike type functions, they are +parametric, so there is no problem in expanding them whenever we see +them, since we do not need to know anything about their arguments in +order to expand them; this is what justifies not having to treat them +as specially as type function applications. The thing that causes +some subtleties is that we prefer to leave type synonym applications +*unexpanded* whenever possible, in order to generate better error +messages. + +If we encounter an equality constraint with type synonym applications +on both sides, or a type synonym application on one side and some sort +of type application on the other, we simply must expand out the type +synonyms in order to continue decomposing the equality constraint into +primitive equality constraints. For example, suppose we have + + type F a = [Int] + +and we encounter the equality + + F a ~ [b] + +In order to continue we must expand F a into [Int], giving us the +equality + + [Int] ~ [b] + +which we can then decompose into the more primitive equality +constraint + + Int ~ b. + +However, if we encounter an equality constraint with a type synonym +application on one side and a variable on the other side, we should +NOT (necessarily) expand the type synonym, since for the purpose of +good error messages we want to leave type synonyms unexpanded as much +as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. + +Note [Type equality cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this situation (from indexed-types/should_compile/GivenLoop): + + instance C (Maybe b) + *[G] a ~ Maybe (F a) + [W] C a + +or (typecheck/should_compile/T19682b): + + instance C (a -> b) + *[W] alpha ~ (Arg alpha -> Res alpha) + [W] C alpha + +or (typecheck/should_compile/T21515): + + type family Code a + *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ] + [W] Code a ~ '[ '[ alpha ] ] + +In order to solve the final Wanted, we must use the starred constraint +for rewriting. But note that all starred constraints have occurs-check failures, +and so we can't straightforwardly add these to the inert set and +use them for rewriting. (NB: A rigid type constructor is at the +top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar +cases.) + +The key idea is to replace the outermost type family applications in the RHS of +the starred constraints with a fresh variable, which we'll call a cycle-breaker +variable, or cbv. Then, relate the cbv back with the original type family +application via new equality constraints. Our situations thus become: + + instance C (Maybe b) + [G] a ~ Maybe cbv + [G] F a ~ cbv + [W] C a + +or + + instance C (a -> b) + [W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 + [W] C alpha + +or + + [G] Code a ~ '[ '[ cbv ] ] + [G] Head (Head (Code a)) ~ cbv + [W] Code a ~ '[ '[ alpha ] ] + +This transformation (creating the new types and emitting new equality +constraints) is done by the `FamAppBreaker` field of `TEFA_Break`, which +in turn lives in the `tef_fam_app` field of `TyEqFlags`. And that in +turn controls the behaviour of the workhorse: GHC.Tc.Utils.Unify.checkTyEqRhs. + +The details depend on whether we're working with a Given or a Wanted. + +Given +----- +We emit a new Given, [G] F a ~ cbv, equating the type family application +to our new cbv. This is actually done by `break_given` in +`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 +CycleBreakerTvs is necessary. This scenario is now easily soluble, by using +the first Given to rewrite the Wanted, which can now be solved. + +(The first Given actually also rewrites the second one, giving +[G] F (Maybe cbv) ~ cbv, but this causes no trouble.) + +Of course, we don't want our fresh variables leaking into e.g. error +messages. So we fill in the metavariables with their original type family +applications after we're done running the solver (in nestImplicTcS and +runTcSWithEvBinds). This is done by `restoreTyVarCycles`, which uses the +`inert_cycle_breakers` field in InertSet, which contains the pairings +invented in `break_given`. + +That is, we transform + [G] g : lhs ~ ...(F lhs)... +to + [G] (Refl lhs) : F lhs ~ cbv -- CEqCan + [G] g : lhs ~ ...cbv... -- CEqCan + +Note that +* `cbv` is a fresh cycle breaker variable. +* `cbv` is a meta-tyvar, but it is completely untouchable. +* We track the cycle-breaker variables in inert_cycle_breakers in InertSet +* We eventually fill in the cycle-breakers, with `cbv := F lhs`. + No one else fills in CycleBreakerTvs! +* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know + this fill-in is ultimately going to happen. +* In `inert_cycle_breakers`, we remember the (cbv, F lhs) pair; that is, we + remember the /original/ type. The [G] F lhs ~ cbv constraint may be rewritten + by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we + still fill in with cbv := F lhs +* This fill-in is done when solving is complete, by restoreTyVarCycles + in nestImplicTcS and runTcSWithEvBinds. + +Wanted +------ +First, we do not cycle-break unless the LHS is a unifiable type variable +See Note [Don't cycle-break Wanteds when not unifying] in GHC.Tc.Solver.Monad. + +OK, so suppose the LHS is a unifiable type variable. The fresh cycle-breaker +variables here must actually be normal, touchable metavariables. That is, they +are TauTvs. Nothing at all unusual. Repeating the example from above, we have + + *[W] alpha ~ (Arg alpha -> Res alpha) + +and we turn this into + + *[W] alpha ~ (cbv1 -> cbv2) + [W] Arg alpha ~ cbv1 + [W] Res alpha ~ cbv2 + +where cbv1 and cbv2 are fresh TauTvs. This is actually done within checkTyEqRhs, +called within canEqCanLHSFinish_try_unification, which will use the BreakWanted +FamAppBreaker. + +Why TauTvs? See [Why TauTvs] below. + +Critically, we emit the two new constraints (the last two above) +directly instead of calling wrapUnifierTcS. (Otherwise, we'd end up +unifying cbv1 and cbv2 immediately, achieving nothing.) Next, we +unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This +unification happens immediately following a successful call to +checkTyEqRhs, in canEqCanLHSFinish_try_unification. + +Now, we're here (including further context from our original example, +from the top of the Note): + + instance C (a -> b) + [W] Arg (cbv1 -> cbv2) ~ cbv1 + [W] Res (cbv1 -> cbv2) ~ cbv2 + [W] C (cbv1 -> cbv2) + +The first two W constraints reduce to reflexivity and are discarded, +and the last is easily soluble. + +[Why TauTvs]: +Let's look at another example (typecheck/should_compile/T19682) where we need +to unify the cbvs: + + class (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys + + type family SameShapeAs xs ys :: Constraint where + SameShapeAs '[] ys = (ys ~ '[]) + SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys)) + + type family AllEqF xs ys :: Constraint where + AllEqF '[] '[] = () + AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys) + + [W] alpha ~ (Head alpha : Tail alpha) + [W] AllEqF '[Bool] alpha + +Without the logic detailed in this Note, we're stuck here, as AllEqF cannot +reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach, +just as described above. We thus invent cbv1 and cbv2 and unify +alpha := cbv1 -> cbv2, yielding (after zonking) + + [W] Head (cbv1 : cbv2) ~ cbv1 + [W] Tail (cbv1 : cbv2) ~ cbv2 + [W] AllEqF '[Bool] (cbv1 : cbv2) + +The first two W constraints simplify to reflexivity and are discarded. +But the last reduces: + + [W] Bool ~ cbv1 + [W] AllEq '[] cbv2 + +The first of these is solved by unification: cbv1 := Bool. The second +is solved by the instance for AllEq to become + + [W] AllEqF '[] cbv2 + [W] SameShapeAs '[] cbv2 + +While the first of these is stuck, the second makes progress, to lead to + + [W] AllEqF '[] cbv2 + [W] cbv2 ~ '[] + +This second constraint is solved by unification: cbv2 := '[]. We now +have + + [W] AllEqF '[] '[] + +which reduces to + + [W] () + +which is trivially satisfiable. Hooray! + +Note that we need to unify the cbvs here; if we did not, there would be +no way to solve those constraints. That's why the cycle-breakers are +ordinary TauTvs. + +How all this is implemented +--------------------------- +We implement all this via the `TEFA_Break` constructor of `TyEqFamApp`, +itself stored in the `tef_fam_app` field of `TyEqFlags`, which controls +the behaviour of `GHC.Tc.Utils.Unify.checkTyEqRhs`. The `TEFA_Break` +stuff happens when `checkTyEqRhs` encounters a family application. + +We try the cycle-breaking trick: +* For Wanteds, when there is a touchable unification variable on the left +* For Givens, regardless of the LHS + +EXCEPT that, in both cases, as `GHC.Tc.Solver.Monad.mkTEFA_Break` shows, we +don't use this trick: + +* When the constraint we are looking at was itself created by cycle-breaking; + see Detail (7) below. + +* For representational equalities, as there is no concrete use case where it is + helpful (unlike for nominal equalities). + + Furthermore, because function applications can be CanEqLHSs, but newtype + applications cannot, the disparities between the cases are enough that it + would be effortful to expand the idea to representational equalities. A quick + attempt, with + data family N a b + f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b + f = coerce + failed with "Could not match 'b' with 'b'." Further work is held off + until when we have a concrete incentive to explore this dark corner. + +More details: + + (1) We don't look under foralls, at all, in `checkTyEqRhs`. There might be + a cyclic occurrence underneath, in a case like + [G] lhs ~ forall b. ... lhs .... + but it doesn't matter because we will classify the constraint as Irred, + so it will not be used for rewriting. + + Earlier versions required an extra, post-breaking, check. Skipping this + check causes typecheck/should_fail/GivenForallLoop and polykinds/T18451 to + loop. But now it is all simpler, with no need for a second check. + + (2) Historical Note: our goal here is to avoid loops in rewriting. We can thus + skip looking in coercions, as we don't rewrite in coercions in the + algorithm in GHC.Solver.Rewrite. This doesn't seem relevant any more. + We cycle break to make the constraint canonical. + + (3) As we cycle-break as described in this Note, we can build ill-kinded + types. For example, if we have Proxy (F a) b, where (b :: F a), then + replacing this with Proxy cbv b is ill-kinded. However, we will later + set cbv := F a, and so the zonked type will be well-kinded again. + The temporary ill-kinded type hurts no one, and avoiding this would + be quite painfully difficult. + + Specifically, this detail does not contravene the Purely Kinded Type Invariant + (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType). + The PKTI says that we can call typeKind on any type, without failure. + It would be violated if we, say, replaced a kind (a -> b) with a kind c, + because an arrow kind might be consulted in piResultTys. Here, we are + replacing one opaque type like (F a b c) with another, cbv (opaque in + that we never assume anything about its structure, like that it has a + result type or a RuntimeRep argument). + + (4) The evidence for the produced Givens is all just reflexive, because we + will eventually set the cycle-breaker variable to be the type family, and + then, after the zonk, all will be well. See also the notes at the end of + the Given section of this Note. + + (5) The implementation in `checkTyEqRhs` is efficient because it only replaces + a type family application with a type variable, if that particular + appplication is implicated in the occurs check. For example: + [W] alpha ~ Maybe (F alpha, G beta) + We'll end up calling GHC.Tc.Utils.Unify.checkFamApp + * On `F alpha`, which fail and calls the cycle-breaker in TEFA_Break + * On `G beta`, which succeeds no problem. + + However, we make no attempt to detect cases like a ~ (F a, F a) and use the + same tyvar to replace F a. The constraint solver will common them up later! + (Cf. Note [Apartness and type families] in GHC.Core.Unify, which goes to + this extra effort.) However, this is really a very small corner case. The + investment to craft a clever, performant solution seems unworthwhile. + + (6) We often get the predicate associated with a constraint from its evidence + with ctPred. We thus must not only make sure the generated CEqCan's fields + have the updated RHS type (that is, the one produced by replacing type + family applications with fresh variables), but we must also update the + evidence itself. This is done by the call to rewriteEqEvidence in + canEqCanLHSFinish. + + (7) We don't wish to apply this magic on the equalities created + by this very same process. Consider this, from + typecheck/should_compile/ContextStack2: + + type instance TF (a, b) = (TF a, TF b) + t :: (a ~ TF (a, Int)) => ... + + [G] a ~ TF (a, Int) + + The RHS reduces, so we get + + [G] a ~ (TF a, TF Int) + + We then break cycles, to get + + [G] g1 :: a ~ (cbv1, cbv2) + [G] g2 :: TF a ~ cbv1 + [G] g3 :: TF Int ~ cbv2 + + g1 gets added to the inert set, as written. But then g2 becomes + the work item. g1 rewrites g2 to become + + [G] TF (cbv1, cbv2) ~ cbv1 + + which then uses the type instance to become + + [G] (TF cbv1, TF cbv2) ~ cbv1 + + which looks remarkably like the Given we started with. If left unchecked, + this will end up breaking cycles again, looping ad infinitum (and + resulting in a context-stack reduction error, not an outright loop). The + solution is easy: don't break cycles on an equality generated by breaking + cycles. Instead, we mark this final Given as a CIrredCan with a + NonCanonicalReason with the soluble occurs-check bit set (only). + + We track these equalities by giving them a special CtOrigin, + CycleBreakerOrigin. This works for both Givens and Wanteds, as we need the + logic in the W case for e.g. typecheck/should_fail/T17139. Because this + logic needs to work for Wanteds, too, we cannot simply look for a + CycleBreakerTv on the left: Wanteds don't use them. + + +********************************************************************** +* * + Rewriting evidence +* * +********************************************************************** +-} + +rewriteEqEvidence :: RewriterSet -- New rewriters + -- See GHC.Tc.Types.Constraint + -- Note [Wanteds rewrite Wanteds] + -> CtEvidence -- Old evidence :: olhs ~ orhs (not swapped) + -- or orhs ~ olhs (swapped) + -> SwapFlag + -> Reduction -- lhs_co :: olhs ~ nlhs + -> Reduction -- rhs_co :: orhs ~ nrhs + -> TcS CtEvidence -- Of type nlhs ~ nrhs +-- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs), +-- rewriteEqEvidence yields, for a given equality (Given g olhs orhs): +-- If not swapped +-- g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co +-- If swapped +-- g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co +-- +-- For a wanted equality (Wanted w), we do the dual thing: +-- New w1 : nlhs ~ nrhs +-- If not swapped +-- w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co +-- If swapped +-- w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co +-- +-- It's all a form of rewriteEvidence, specialised for equalities +rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs) + | NotSwapped <- swapped + , isReflCo lhs_co -- See Note [Rewriting with Refl] + , isReflCo rhs_co + = return (setCtEvPredType old_ev new_pred) + + | CtGiven (GivenCt { ctev_evar = old_evar }) <- old_ev + = do { let new_tm = evCoercion ( mkSymCo lhs_co + `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar) + `mkTransCo` rhs_co) + ; CtGiven <$> newGivenEvVar loc (new_pred, new_tm) } + + | CtWanted (WantedCt { ctev_dest = dest, ctev_rewriters = rewriters }) <- old_ev + = do { let rewriters' = rewriters S.<> new_rewriters + ; (new_ev, hole_co) <- newWantedEq loc rewriters' (ctEvRewriteRole old_ev) nlhs nrhs + ; let co = maybeSymCo swapped $ + lhs_co `mkTransCo` hole_co `mkTransCo` mkSymCo rhs_co + ; setWantedEq dest co + ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev + , ppr nlhs + , ppr nrhs + , ppr co + , ppr new_rewriters ]) + ; return $ CtWanted new_ev } + + where + new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs + loc = ctEvLoc old_ev + +{- +********************************************************************** +* * + tryInertEqs +* * +********************************************************************** + +Note [Combining equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + Inert: g1 :: a ~ t + Work item: g2 :: a ~ t + +Then we can simply solve g2 from g1, thus g2 := g1. Easy! +But it's not so simple: + +(CE1) If t is a type variable, the equalties might be oriented differently: + e.g. (g1 :: a~b) and (g2 :: b~a) + So we look both ways round. Hence the SwapFlag result to + inertsCanDischarge. + +(CE2) We can only do g2 := g1 if g1 can discharge g2; that depends on + (a) the role and (b) the flavour. E.g. a representational equality + cannot discharge a nominal one; a Wanted cannot discharge a Given. + The predicate is eqCanRewriteFR. + +(CE3) Visibility. Suppose S :: forall k. k -> Type, and consider unifying + S @Type (a::Type) ~ S @(Type->Type) (b::Type->Type) + From the first argument we get (Type ~ Type->Type); from the second + argument we get (a ~ b) which in turn gives (Type ~ Type->Type). + See typecheck/should_fail/T16204c. + + That first argument is invisible in the source program (aside from + visible type application), so we'd much prefer to get the error from + the second. We track visibility in the uo_visible field of a TypeEqOrigin. + We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters, + the partition on isVisibleOrigin). + + So when combining two otherwise-identical equalites, we want to + keep the visible one, and discharge the invisible one. Hence the + call to strictly_more_visible. + +(CE4) Suppose we have this set up (#25440): + Inert: [W] g1: F a ~ a Int (arising from (F a ~ a Int) + Work item: [W] g2: F alpha ~ F a (arising from (F alpha ~ F a) + We rewrite g2 with g1, to give + [W] g2{rw:g1} : F alpha ~ a Int + Now if F is injective we can get [W] alpha~a, and hence alpha:=a, and + we kick out g1. Now we have two constraints + [W] g1 : F a ~ a Int (arising from (F a ~ a Int) + [W] g2{rw:g1} : F a ~ a Int (arising from (F alpha ~ F a) + If we end up with g2 in the inert set (not g1) we'll get a very confusing + error message that we can solve (F a ~ a Int) + arising from F a ~ F a + + TL;DR: Better to hang on to `g1` (with no rewriters), in preference + to `g2` (which has a rewriter). + + See (WRW1) in Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. +-} + +tryInertEqs :: EqCt -> SolverStage () +tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) + = Stage $ + do { inerts <- getInertCans + ; if | Just (ev_i, swapped) <- inertsEqsCanDischarge inerts work_item + -> do { setEvBindIfWanted ev EvCanonical $ + evCoercion (maybeSymCo swapped $ + downgradeRole (eqRelRole eq_rel) + (ctEvRewriteRole ev_i) + (ctEvCoercion ev_i)) + ; stopWith ev "Solved from inert" } + + | otherwise + -> continueWith () } + +inertsEqsCanDischarge :: InertCans -> EqCt + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag ) -- Whether we need mkSymCo +inertsEqsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w + , eq_ev = ev_w, eq_eq_rel = eq_rel }) + | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i + , eq_eq_rel = eq_rel } + <- findEq inerts lhs_w + , rhs_i `tcEqType` rhs_w + , inert_beats_wanted ev_i eq_rel ] + = -- Inert: a ~ ty + -- Work item: a ~ ty + Just (ev_i, NotSwapped) + + | Just rhs_lhs <- canEqLHS_maybe rhs_w + , (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i + , eq_eq_rel = eq_rel } + <- findEq inerts rhs_lhs + , rhs_i `tcEqType` canEqLHSType lhs_w + , inert_beats_wanted ev_i eq_rel ] + = -- Inert: a ~ b + -- Work item: b ~ a + Just (ev_i, IsSwapped) + + where + loc_w = ctEvLoc ev_w + flav_w = ctEvFlavour ev_w + fr_w = (flav_w, eq_rel) + empty_rw_w = isEmptyRewriterSet (ctEvRewriters ev_w) + + inert_beats_wanted ev_i eq_rel + = -- eqCanRewriteFR: see second bullet of Note [Combining equalities] + fr_i `eqCanRewriteFR` fr_w + && not (prefer_wanted ev_i && (fr_w `eqCanRewriteFR` fr_i)) + where + fr_i = (ctEvFlavour ev_i, eq_rel) + + -- See (CE3) in Note [Combining equalities] + strictly_more_visible loc1 loc2 + = not (isVisibleOrigin (ctLocOrigin loc2)) && + isVisibleOrigin (ctLocOrigin loc1) + + prefer_wanted ev_i + = (loc_w `strictly_more_visible` ctEvLoc ev_i) + -- strictly_more_visible: see (CE3) in Note [Combining equalities] + || (empty_rw_w && not (isEmptyRewriterSet (ctEvRewriters ev_i))) + -- Prefer the one that has no rewriters + -- See (CE4) in Note [Combining equalities] + +inertsEqsCanDischarge _ _ = Nothing + + + +{- Note [Do not unify Givens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GADT match + data T a where + T1 :: T Int + ... + + f x = case x of + T1 -> True + ... + +So we get f :: T alpha[1] -> beta[1] + x :: T alpha[1] +and from the T1 branch we get the implication + forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool + +Now, clearly we don't want to unify alpha:=Int! Yet at the moment we +process [G] alpha[1] ~ Int, we don't have any given-equalities in the +inert set, and hence there are no given equalities to make alpha untouchable. + +NB: if it were alpha[2] ~ Int, this argument wouldn't hold. But that +never happens: invariant (GivenInv) in Note [TcLevel invariants] +in GHC.Tc.Utils.TcType. + +Simple solution: never unify in Givens! + +Note [Do not unify representational equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [W] alpha ~R# b +where alpha is touchable. Should we unify alpha := b? + +Certainly not! Unifying forces alpha and be to be the same; but they +only need to be representationally equal types. + +For example, we might have another constraint [W] alpha ~# N b +where + newtype N b = MkN b +and we want to get alpha := N b. + +See also #15144, which was caused by unifying a representational +equality. + +Note that it does however make sense to perform such unifications, as a last +resort, when doing top-level defaulting. +See Note [Defaulting representational equalities]. + +Note [Unify only if the rewriter set is empty] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + co (rewriters = {co1,co2}) :: alpha ~# blah +If we unify before solving `co1` and `co2` (which might well be insoluble) +we destroy the careful tracking of Note [Wanteds rewrite Wanteds] in +GHC.Tc.Types.Constraint. So we decline to unify any equality with a +non-empty rewriter set: see (REWRITERS) in Note [Unification preconditions] +in GHC.Tc.Utils. + +Wrinkles: + +(URW1) We may, however, be willing to /default/ such an equality; see + (DE6) in Note [Defaulting equalities] in GHC.Tc.Solver.Default. + +(URW2) If we have `co` in the inert set, and we solve `co1` and `co2`, + we should kick out `co` so that we can now unify it, which might + unlock other stuff. See `kickOutAfterFillingCoercionHole` in + GHC.Tc.Solver.Monad. + + However the solver prioritises equalities with an empty rewriter + set, to try to avoid unnecessary kick-out. See GHC.Tc.Types.Constraint + Note [Prioritise Wanteds with empty RewriterSet] esp (PER1) + +Note [Solve by unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we solve + alpha[n] ~ ty +by unification, there are two cases to consider + +* TouchableSameLevel: if the ambient level is 'n', then + we can simply update alpha := ty, and do nothing else + +* TouchableOuterLevel free_metas n: if the ambient level is greater than + 'n' (the level of alpha), in addition to setting alpha := ty we must + do two other things: + + 1. Promote all the free meta-vars of 'ty' to level n. After all, + alpha[n] is at level n, and so if we set, say, + alpha[n] := Maybe beta[m], + we must ensure that when unifying beta we do skolem-escape checks + etc relevant to level n. Simple way to do that: promote beta to + level n. + + 2. Set the Unification Level Flag to record that a level-n unification has + taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad + +NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion +would be a no-op, and setting the unification flag unnecessarily would just +make the solver iterate more often. (We don't need to iterate when unifying +at the ambient level because of the kick-out mechanism.) +-} + + +{-******************************************************************** +* * + Final wrap-up for equalities +* * +********************************************************************-} + +{- Note [Looking up primitive equalities in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For equalities (a ~# b) look up (a ~ b), and then do a superclass +selection. This avoids having to support quantified constraints whose +kind is not Constraint, such as (forall a. F a ~# b) + +See + * Note [Evidence for quantified constraints] in GHC.Core.Predicate + * Note [Equality superclasses in quantified constraints] + in GHC.Tc.Solver.Dict +-} + +-------------------- +tryQCsIrredEqCt :: IrredCt -> SolverStage () +tryQCsIrredEqCt irred@(IrredCt { ir_ev = ev }) + | EqPred eq_rel t1 t2 <- classifyPredType (ctEvPred ev) + = lookup_eq_in_qcis (CIrredCan irred) eq_rel t1 t2 + + | otherwise -- All the calls come from in this module, where we deal only with + -- equalities, so ctEvPred ev) must be an equality. Indeed, we could + -- pass eq_rel, t1, t2 as arguments, to avoid this can't-happen case, + -- but it's not a hot path, and this is simple and robust + = pprPanic "solveIrredEquality" (ppr ev) + +-------------------- +tryQCsEqCt :: EqCt -> SolverStage () +tryQCsEqCt work_item@(EqCt { eq_lhs = lhs, eq_rhs = rhs, eq_eq_rel = eq_rel }) + = lookup_eq_in_qcis (CEqCan work_item) eq_rel (canEqLHSType lhs) rhs + +-------------------- +lookup_eq_in_qcis :: Ct -> EqRel -> TcType -> TcType -> SolverStage () +-- The "final QCI check" checks to see if we have +-- [W] t1 ~# t2 +-- and a Given quantified contraint like (forall a b. blah => a ~ b) +-- Why? See Note [Looking up primitive equalities in quantified constraints] +-- See also GHC.Tc.Solver.Dict +-- Note [Equality superclasses in quantified constraints] +lookup_eq_in_qcis work_ct eq_rel lhs rhs + = Stage $ + do { ev_binds_var <- getTcEvBindsVar + ; ics <- getInertCans + ; if isWanted ev -- Never look up Givens in quantified constraints + && not (null (inert_qcis ics)) -- Shortcut common case + && not (isCoEvBindsVar ev_binds_var) -- See Note [Instances in no-evidence implications] + then try_for_qci + else continueWith () } + where + ev = ctEvidence work_ct + loc = ctEvLoc ev + role = eqRelRole eq_rel + + try_for_qci -- First try looking for (lhs ~ rhs) + | Just (cls, tys) <- boxEqPred eq_rel lhs rhs + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "lookup_irred_in_qcis:1" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance ev (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> try_swapping } + | otherwise + = continueWith () + + try_swapping -- Now try looking for (rhs ~ lhs) (see #23333) + | Just (cls, tys) <- boxEqPred eq_rel rhs lhs + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; traceTcS "lookup_irred_in_qcis:2" (ppr (mkClassPred cls tys)) + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> do { ev' <- rewriteEqEvidence emptyRewriterSet ev IsSwapped + (mkReflRedn role rhs) (mkReflRedn role lhs) + ; chooseInstance ev' (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) } + _ -> do { traceTcS "lookup_irred_in_qcis:3" (ppr work_ct) + ; continueWith () }} + | otherwise + = continueWith () + + mk_eq_ev cls tys mk_ev evs + | sc_id : rest <- classSCSelIds cls -- Just one superclass for this + = assert (null rest) $ case (mk_ev evs) of + EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) + ev -> pprPanic "mk_eq_ev" (ppr ev) + | otherwise = pprPanic "finishEqCt" (ppr work_ct) + +{- Note [Instances in no-evidence implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #15290 we had + [G] forall p q. Coercible p q => Coercible (m p) (m q)) -- Quantified + [W] forall a. m (Int, IntStateT m a) + ~R# + m (Int, StateT Int m a) + +The Given is an ordinary quantified constraint; the Wanted is an implication +equality that arises from + [W] (forall a. t1) ~R# (forall a. t2) + +But because the (t1 ~R# t2) is solved "inside a type" (under that forall a) +we can't generate any term evidence. So we can't actually use that +lovely quantified constraint. Alas! + +This test arranges to ignore the instance-based solution under these +(rare) circumstances. It's sad, but I really don't see what else we can do. +-} + + +{- +********************************************************************** +* * + Functional dependencies for type families +* * +********************************************************************** + +Note [Reverse order of fundep equations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this scenario (from dependent/should_fail/T13135_simple): + + type Sig :: Type -> Type + data Sig a = SigFun a (Sig a) + + type SmartFun :: forall (t :: Type). Sig t -> Type + type family SmartFun sig = r | r -> sig where + SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig + + [W] SmartFun @kappa sigma ~ (Int -> Bool) + +The injectivity of SmartFun allows us to produce two new equalities: + + [W] w1 :: Type ~ kappa + [W] w2 :: SigFun @Type Int beta ~ sigma + +for some fresh (beta :: SigType). The second Wanted here is actually +heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa. +Of course, if we solve the first wanted first, the second becomes homogeneous. + +When looking for injectivity-inspired equalities, we work left-to-right, +producing the two equalities in the order written above. However, these +equalities are then passed into wrapUnifierTcS, which will fail, adding these +to the work list. However, crucially, the work list operates like a *stack*. +So, because we add w1 and then w2, we process w2 first. This is silly: solving +w1 would unlock w2. So we make sure to add equalities to the work +list in left-to-right order, which requires a few key calls to 'reverse'. + +This treatment is also used for class-based functional dependencies, although +we do not have a program yet known to exhibit a loop there. It just seems +like the right thing to do. + +When this was originally conceived, it was necessary to avoid a loop in T13135. +That loop is now avoided by continuing with the kind equality (not the type +equality) in canEqCanLHSHetero (see Note [Equalities with heterogeneous kinds]). +However, the idea of working left-to-right still seems worthwhile, and so the calls +to 'reverse' remain. + +Note [Improvement orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation], which describes +the Exact Same Problem, with the same solution, but for functional dependencies. + +A very delicate point is the orientation of equalities +arising from injectivity improvement (#12522). Suppose we have + type family F x = t | t -> x + type instance F (a, Int) = (Int, G a) +where G is injective; and wanted constraints + + [W] F (alpha, beta) ~ (Int, ) + +The injectivity will give rise to constraints + + [W] gamma1 ~ alpha + [W] Int ~ beta + +The fresh unification variable gamma1 comes from the fact that we +can only do "partial improvement" here; see Section 5.2 of +"Injective type families for Haskell" (HS'15). + +Now, it's very important to orient the equations this way round, +so that the fresh unification variable will be eliminated in +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 +and exactly the same thing would happen again! Infinite loop. + +This all seems fragile, and it might seem more robust to avoid +introducing gamma1 in the first place, in the case where the +actual argument (alpha, beta) partly matches the improvement +template. But that's a bit tricky, esp when we remember that the +kinds much match too; so it's easier to let the normal machinery +handle it. Instead we are careful to orient the new +equality with the template on the left. Delicate, but it works. + +-} + +-------------------- +tryFunDeps :: EqRel -> EqCt -> SolverStage () +tryFunDeps eq_rel work_item@(EqCt { eq_lhs = lhs, eq_ev = ev }) + | NomEq <- eq_rel + , TyFamLHS tc args <- lhs + = Stage $ + 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] in GHC.Tc.Solver.Dict +improveTopFunEqs fam_tc args (EqCt { eq_ev = ev, eq_rhs = rhs_ty }) + | isGiven ev = improveGivenTopFunEqs fam_tc args ev rhs_ty + | otherwise = improveWantedTopFunEqs fam_tc args ev rhs_ty + +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 + = 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 [ text "lhs:" <+> ppr fam_tc <+> ppr args + , text "rhs:" <+> ppr rhs_ty + , text "eqns:" <+> ppr eqns ]) + ; unifyFunDeps ev Nominal $ \uenv -> + uPairsTcM (bump_depth uenv) (reverse eqns) } + -- Missing that `reverse` causes T13135 and T13135_simple to loop. + -- See Note [Reverse order of fundep equations] + + where + bump_depth env = env { u_loc = bumpCtLocDepth (u_loc env) } + -- ToDo: this location is wrong; it should be FunDepOrigin2 + -- See #14778 + +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 (map snd $ tryInteractTopFam ops fam_tc lhs_tys rhs_ty) + + -- 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 + ; traceTcS "improve_wanted_top_fun_eqs" $ + vcat [ ppr fam_tc, text "local_eqns" <+> ppr local_eqns, text "top_eqns" <+> ppr top_eqns ] + ; return (local_eqns ++ top_eqns) } + + | otherwise -- No injectivity + = return [] + +improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn] +-- Interact with top-level instance declarations +-- See Section 5.2 in the Injective Type Families paper +improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty + = concatMapM do_one branches + where + 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 <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty + -- False: matching, not unifying + = do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst + unsubstTvs = filterOut inSubst branch_tvs + -- The order of unsubstTvs is important; it must be + -- in telescope order e.g. (k:*) (a:k) + + ; 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. + + ; traceTcS "improve_inj_top" $ + vcat [ text "branch_rhs" <+> ppr branch_rhs + , text "rhs_ty" <+> ppr rhs_ty + , text "subst" <+> ppr subst + , text "subst1" <+> ppr subst1 ] + ; if apartnessCheck (substTys subst1 branch_lhs_tys) branch + then do { traceTcS "improv_inj_top1" (ppr branch_lhs_tys) + ; return (mkInjectivityEqns inj_args (map (substTy subst1) branch_lhs_tys) lhs_tys) } + -- NB: The fresh unification variables (from unsubstTvs) are on the left + -- See Note [Improvement orientation] + else do { traceTcS "improve_inj_top2" empty; return [] } } + | otherwise + = do { traceTcS "improve_inj_top:fail" (ppr branch_rhs $$ ppr rhs_ty $$ ppr in_scope $$ ppr branch_tvs) + ; return [] } + + in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty) + + +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 + = [] + +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 + 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 + + +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 + + 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 () + +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] in GHC.Tc.Solver.Dict +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 ] + ; emitFunDepWanteds work_ev improvement_eqns } + where + work_loc = ctEvLoc work_ev + work_pred = ctEvPred work_ev + fam_inj_info = tyConInjectivityInfo fam_tc + + -------------------- + improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)] + improvement_eqns + | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc + = -- Try built-in families, notably for arithmethic + concatMap (do_one_built_in ops rhs) funeqs_for_tc + + | Injective injective_args <- fam_inj_info + = -- Try improvement from type families with injectivity annotations + concatMap (do_one_injective injective_args rhs) funeqs_for_tc + + | otherwise + = [] + + -------------------- + do_one_built_in ops rhs (EqCt { eq_lhs = TyFamLHS _ iargs, eq_rhs = irhs, eq_ev = inert_ev }) + | 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 }) + | rhs `tcEqType` irhs + = mk_fd_eqns inert_ev $ mkInjectivityEqns inj_args args inert_args + | otherwise + = [] + + do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) -- TyVarLHS + + -------------------- + mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)] + mk_fd_eqns inert_ev eqns + | null eqns = [] + | otherwise = [ FDEqn { fd_qtvs = [], fd_eqs = eqns + , 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) inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) eqn_loc = setCtLocOrigin initial_loc eqn_orig inert_pred = ctEvPred inert_ev diff --git a/GHC/Tc/Solver/InertSet.hs b/GHC/Tc/Solver/InertSet.hs --- a/GHC/Tc/Solver/InertSet.hs +++ b/GHC/Tc/Solver/InertSet.hs @@ -1,2213 +1,2142 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Tc.Solver.InertSet ( - -- * The work list - WorkList(..), isEmptyWorkList, emptyWorkList, - extendWorkListNonEq, extendWorkListCt, - extendWorkListCts, extendWorkListCtList, - extendWorkListEq, extendWorkListEqs, - appendWorkList, extendWorkListImplic, - workListSize, - selectWorkItem, - - -- * The inert set - InertSet(..), - InertCans(..), - emptyInert, - - noMatchableGivenDicts, - noGivenNewtypeReprEqs, updGivenEqs, - mightEqualLater, - prohibitedSuperClassSolve, - - -- * Inert equalities - InertEqs, - foldTyEqs, delEq, findEq, - partitionInertEqs, partitionFunEqs, - foldFunEqs, addEqToCans, - - -- * Inert Dicts - updDicts, delDict, addDict, filterDicts, partitionDicts, - addSolvedDict, - - -- * Inert Irreds - InertIrreds, delIrred, addIrreds, addIrred, foldIrreds, - findMatchingIrreds, updIrreds, addIrredToCans, - - -- * Kick-out - KickOutSpec(..), kickOutRewritableLHS, - - -- * Cycle breaker vars - CycleBreakerVarStack, - pushCycleBreakerVarStack, - addCycleBreakerBindings, - forAllCycleBreakerBindings_, - - -- * Solving one from another - InteractResult(..), solveOneFromTheOther - - ) where - -import GHC.Prelude - -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Solver.Types -import GHC.Tc.Utils.TcType - -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Basic( SwapFlag(..) ) - -import GHC.Core.Reduction -import GHC.Core.Predicate -import GHC.Core.TyCo.FVs -import qualified GHC.Core.TyCo.Rep as Rep -import GHC.Core.Class( Class ) -import GHC.Core.TyCon -import GHC.Core.Class( classTyCon ) -import GHC.Core.Unify - -import GHC.Utils.Misc ( partitionWith ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.Maybe -import GHC.Data.Bag - -import Data.List.NonEmpty ( NonEmpty(..), (<|) ) -import qualified Data.List.NonEmpty as NE -import Data.Function ( on ) - -import Control.Monad ( forM_ ) - -{- -************************************************************************ -* * -* Worklists * -* Canonical and non-canonical constraints that the simplifier has to * -* work on. Including their simplification depths. * -* * -* * -************************************************************************ - -Note [WorkList priorities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A WorkList contains canonical and non-canonical items (of all flavours). -Notice that each Ct now has a simplification depth. We may -consider using this depth for prioritization as well in the future. - -As a simple form of priority queue, our worklist separates out - -* equalities (wl_eqs); see Note [Prioritise equalities] -* all the rest (wl_rest) - -Note [Prioritise equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very important to process equalities over class constraints: - -* (Efficiency) The general reason to do so is that if we process a - class constraint first, we may end up putting it into the inert set - and then kicking it out later. That's extra work compared to just - doing the equality first. - -* (Avoiding fundep iteration) As #14723 showed, it's possible to - get non-termination if we - - Emit the fundep equalities for a class constraint, - generating some fresh unification variables. - - That leads to some unification - - Which kicks out the class constraint - - Which isn't solved (because there are still some more - equalities in the work-list), but generates yet more fundeps - Solution: prioritise equalities over class constraints - -* (Class equalities) We need to prioritise equalities even if they - are hidden inside a class constraint; see Note [Prioritise class equalities] - -* (Kick-out) We want to apply this priority scheme to kicked-out - constraints too (see the call to extendWorkListCt in kick_out_rewritable) - E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become - homo-kinded when kicked out, and hence we want to prioritise it. - -Among the equalities we prioritise ones with an empty rewriter set; -see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint, wrinkle (W1). - - -Note [Prioritise class equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prioritise equalities in the solver (see selectWorkItem). But class -constraints like (a ~ b) and (a ~~ b) are actually equalities too; -see Note [The equality types story] in GHC.Builtin.Types.Prim. - -Failing to prioritise these is inefficient (more kick-outs etc). -But, worse, it can prevent us spotting a "recursive knot" among -Wanted constraints. See comment:10 of #12734 for a worked-out -example. - -So we arrange to put these particular class constraints in the wl_eqs. - - NB: since we do not currently apply the substitution to the - inert_solved_dicts, the knot-tying still seems a bit fragile. - But this makes it better. - -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See GHC.Tc.Solver.Monad.deferTcSForAllEq - --} - --- See Note [WorkList priorities] -data WorkList - = WL { wl_eqs :: [Ct] -- CEqCan, CDictCan, CIrredCan - -- Given and Wanted - -- Contains both equality constraints and their - -- class-level variants (a~b) and (a~~b); - -- See Note [Prioritise equalities] - -- See Note [Prioritise class equalities] - - , wl_rw_eqs :: [Ct] -- Like wl_eqs, but ones that have a non-empty - -- rewriter set; or, more precisely, did when - -- added to the WorkList - -- We prioritise wl_eqs over wl_rw_eqs; - -- see Note [Prioritise Wanteds with empty RewriterSet] - -- in GHC.Tc.Types.Constraint for more details. - - , wl_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_rw_eqs = rw_eqs1 - , wl_rest = rest1, wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_rw_eqs = rw_eqs2 - , wl_rest = rest2, wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_rw_eqs = rw_eqs1 ++ rw_eqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_rw_eqs = rw_eqs, wl_rest = rest }) - = length eqs + length rw_eqs + length rest - -extendWorkListEq :: RewriterSet -> Ct -> WorkList -> WorkList -extendWorkListEq rewriters ct wl - | isEmptyRewriterSet rewriters -- A wanted that has not been rewritten - -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet] - -- in GHC.Tc.Types.Constraint - = wl { wl_eqs = ct : wl_eqs wl } - | otherwise - = wl { wl_rw_eqs = ct : wl_rw_eqs wl } - -extendWorkListEqs :: RewriterSet -> Bag Ct -> WorkList -> WorkList --- Add [eq1,...,eqn] to the work-list --- They all have the same rewriter set --- The constraints will be solved in left-to-right order: --- see Note [Work-list ordering] in GHC.Tc.Solved.Equality -extendWorkListEqs rewriters eqs wl - | isEmptyRewriterSet rewriters - -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet] - -- in GHC.Tc.Types.Constraint - = wl { wl_eqs = foldr (:) (wl_eqs wl) eqs } - -- The foldr just appends wl_eqs to the bag of eqs - | otherwise - = wl { wl_rw_eqs = foldr (:) (wl_rw_eqs wl) eqs } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic about what kind of constraint -extendWorkListCt ct wl - = case classifyPredType (ctEvPred ev) of - EqPred {} - -> extendWorkListEq rewriters ct wl - - ClassPred cls _ -- See Note [Prioritise class equalities] - | isEqualityClass cls - -> extendWorkListEq rewriters ct wl - - _ -> extendWorkListNonEq ct wl - where - ev = ctEvidence ct - rewriters = ctEvRewriters ev - -extendWorkListCtList :: [Ct] -> WorkList -> WorkList -extendWorkListCtList cts wl = foldr extendWorkListCt wl cts - -extendWorkListCts :: Cts -> WorkList -> WorkList -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && isEmptyBag implics - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rw_eqs = [], wl_rest = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) --- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_rw_eqs = rw_eqs, wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:cts <- rw_eqs = Just (ct, wl { wl_rw_eqs = cts }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_rw_eqs = rw_eqs, wl_rest = rest, wl_implics = implics }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null rw_eqs) $ - text "RwEqs =" <+> vcat (map ppr rw_eqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") - ]) - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -type CycleBreakerVarStack = NonEmpty (Bag (TcTyVar, TcType)) - -- ^ a stack of (CycleBreakerTv, original family applications) lists - -- first element in the stack corresponds to current implication; - -- later elements correspond to outer implications - -- used to undo the cycle-breaking needed to handle - -- Note [Type equality cycles] in GHC.Tc.Solver.Equality - -- Why store the outer implications? For the use in mightEqualLater (only) - -- - -- Why NonEmpty? So there is always a top element to add to - -data InertSet - = IS { inert_cans :: InertCans - -- Canonical Given, Wanted - -- Sometimes called "the inert set" - - , inert_cycle_breakers :: CycleBreakerVarStack - - , inert_famapp_cache :: FunEqMap Reduction - -- Just a hash-cons cache for use when reducing family applications - -- only - -- - -- If F tys :-> (co, rhs, flav), - -- then co :: F tys ~N rhs - -- all evidence is from instances or Givens; no coercion holes here - -- (We have no way of "kicking out" from the cache, so putting - -- wanteds here means we can end up solving a Wanted with itself. Bad) - - , inert_solved_dicts :: DictMap DictCt - -- All Wanteds, of form (C t1 .. tn) - -- Always a dictionary solved by an instance decl; never an implict parameter - -- See Note [Solved dictionaries] - -- and Note [Do not add superclasses of solved dictionaries] - } - -instance Outputable InertSet where - ppr (IS { inert_cans = ics - , inert_solved_dicts = solved_dicts }) - = vcat [ ppr ics - , ppUnless (null dicts) $ - text "Solved dicts =" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag solved_dicts) - -emptyInertCans :: InertCans -emptyInertCans - = IC { inert_eqs = emptyTyEqs - , inert_funeqs = emptyFunEqs - , inert_given_eq_lvl = topTcLevel - , inert_given_eqs = False - , inert_dicts = emptyDictMap - , inert_safehask = emptyDictMap - , inert_insts = [] - , inert_irreds = emptyBag } - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans - , inert_cycle_breakers = emptyBag :| [] - , inert_famapp_cache = emptyFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degenerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] - -VERY IMPORTANT INVARIANT: - - (Solved Dictionary Invariant) - Every member of the inert_solved_dicts is the result - of applying an instance declaration that "takes a step" - - An instance "takes a step" if it has the form - dfunDList d1 d2 = MkD (...) (...) (...) - That is, the dfun is lazy in its arguments, and guarantees to - immediately return a dictionary constructor. NB: all dictionary - data constructors are lazy in their arguments. - - This property is crucial to ensure that all dictionaries are - non-bottom, which in turn ensures that the whole "recursive - dictionary" idea works at all, even if we get something like - rec { d = dfunDList d dx } - See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. - - Reason: - - All instances, except two exceptions listed below, "take a step" - in the above sense - - - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when applying a quantified - constraint led to the ability to define unsafeCoerce - in #17267. - - - Exception 2: the magic built-in instance for (~) has no - such guarantee. It behaves as if we had - class (a ~# b) => (a ~ b) where {} - instance (a ~# b) => (a ~ b) where {} - The "dfun" for the instance is strict in the coercion. - Anyway there's no point in recording a "solved dict" for - (t1 ~ t2); it's not going to allow a recursive dictionary - to be constructed. Ditto (~~) and Coercible. - -THEREFORE we only add a "solved dictionary" - - when applying an instance declaration - - subject to Exceptions 1 and 2 above - -In implementation terms - - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary, - conditional on the kind of instance - - - It is only called when applying an instance decl, - in GHC.Tc.Solver.Dict.tryInstances - - - ClsInst.InstanceWhat says what kind of instance was - used to solve the constraint. In particular - * LocalInstance identifies quantified constraints - * BuiltinEqInstance identifies the strange built-in - instances for equality. - - - ClsInst.instanceReturnsDictCon says which kind of - instance guarantees to return a dictionary constructor - -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, - so it may get out of date. - -* The inert_solved_dicts are all Wanteds, never givens - -* We only cache dictionaries from top-level instances, not from - local quantified constraints. Reason: if we cached the latter - we'd need to purge the cache when bringing new quantified - constraints into scope, because quantified constraints "shadow" - top-level instances. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a -dictionary function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -{- Note [Tracking Given equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify -Note [Unification preconditions], we can't unify - alpha[2] ~ Int -under a level-4 implication if there are any Given equalities -bound by the implications at level 3 of 4. To that end, the -InertCans tracks - - inert_given_eq_lvl :: TcLevel - -- The TcLevel of the innermost implication that has a Given - -- equality of the sort that make a unification variable untouchable - -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). - -We update inert_given_eq_lvl whenever we add a Given to the -inert set, in updGivenEqs. - -Then a unification variable alpha[n] is untouchable iff - n < inert_given_eq_lvl -that is, if the unification variable was born outside an -enclosing Given equality. - -Exactly which constraints should trigger (UNTOUCHABLE), and hence -should update inert_given_eq_lvl? - -* We do /not/ need to worry about let-bound skolems, such ast - forall[2] a. a ~ [b] => blah - See Note [Let-bound skolems] - -* Consider an implication - forall[2]. beta[1] => alpha[1] ~ Int - where beta is a unification variable that has already been unified - to () in an outer scope. Then alpha[1] is perfectly touchable and - we can unify alpha := Int. So when deciding whether the givens contain - an equality, we should canonicalise first, rather than just looking at - the /original/ givens (#8644). - - * However, we must take account of *potential* equalities. Consider the - same example again, but this time we have /not/ yet unified beta: - forall[2] beta[1] => ...blah... - - Because beta might turn into an equality, updGivenEqs conservatively - treats it as a potential equality, and updates inert_give_eq_lvl - - * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z? - - That Given cannot affect the Wanted, because the Given is entirely - *local*: it mentions only skolems bound in the very same - implication. Such equalities need not make alpha untouchable. (Test - case typecheck/should_compile/LocalGivenEqs has a real-life - motivating example, with some detailed commentary.) - Hence the 'mentionsOuterVar' test in updGivenEqs. - - However, solely to support better error messages - (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track - these "local" equalities in the boolean inert_given_eqs field. - This field is used only to set the ic_given_eqs field to LocalGivenEqs; - see the function getHasGivenEqs. - - Here is a simpler case that triggers this behaviour: - - data T where - MkT :: F a ~ G b => a -> b -> T - - f (MkT _ _) = True - - Because of this behaviour around local equality givens, we can infer the - type of f. This is typecheck/should_compile/LocalGivenEqs2. - - * We need not look at the equality relation involved (nominal vs - representational), because representational equalities can still - imply nominal ones. For example, if (G a ~R G b) and G's argument's - role is nominal, then we can deduce a ~N b. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. - -For an example, see #9211. - -See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure -that the right variable is on the left of the equality when both are -tyvars. - -You might wonder whether the skolem really needs to be bound "in the -very same implication" as the equality constraint. -Consider this (c.f. #15009): - - data S a where - MkS :: (a ~ Int) => S a - - g :: forall a. S a -> a -> blah - g x y = let h = \z. ( z :: Int - , case x of - MkS -> [y,z]) - in ... - -From the type signature for `g`, we get `y::a` . Then when we -encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the -body of the lambda we'll get - - [W] alpha[1] ~ Int -- From z::Int - [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] - -Now, unify alpha := a. Now we are stuck with an unsolved alpha~Int! -So we must treat alpha as untouchable under the forall[2] implication. - -Note [Detailed InertCans Invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The InertCans represents a collection of constraints with the following properties: - - * All canonical - - * No two dictionaries with the same head - * No two CIrreds with the same type - - * Family equations inert wrt top-level family axioms - - * Dictionaries have no matching top-level instance - - * Given family or dictionary constraints don't mention touchable - unification variables - - * Non-CEqCan constraints are fully rewritten with respect - to the CEqCan equalities (modulo eqCanRewrite of course; - eg a wanted cannot rewrite a given) - - * CEqCan equalities: see Note [inert_eqs: the inert equalities] - Also see documentation in Constraint.Ct for a list of invariants - -Note [inert_eqs: the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Definition [Can-rewrite relation] -A "can-rewrite" relation between flavours, written f1 >= f2, is a -binary relation with the following properties - - (R1) >= is transitive - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 - (See Note [Why R2?].) - -Lemma (L0). If f1 >= f then f1 >= f1 -Proof. By property (R2), with f1=f2 - -Definition [Generalised substitution] -A "generalised substitution" S is a set of triples (lhs -f-> t), where - lhs is a type variable or an exactly-saturated type family application - (that is, lhs is a CanEqLHS) - t is a type - f is a flavour -such that - (WF1) if (lhs1 -f1-> t1) in S - (lhs2 -f2-> t2) in S - then (f1 >= f2) implies that lhs1 does not appear within lhs2 - (WF2) if (lhs -f-> t) is in S, then t /= lhs - -Definition [Applying a generalised substitution] -If S is a generalised substitution - S(f,t0) = t, if (t0 -fs-> t) in S, and fs >= f - = apply S to components of t0, otherwise -See also Note [Flavours with roles]. - -Theorem: S(f,t0) is well defined as a function. -Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S, - and f1 >= f and f2 >= f - Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) - -Notation: repeated application. - S^0(f,t) = t - S^(n+1)(f,t) = S(f, S^n(t)) - -Definition: terminating generalised substitution -A generalised substitution S is *terminating* iff - - (IG1) there is an n such that - for every f,t, S^n(f,t) = S^(n+1)(f,t) - -By (IG1) we define S*(f,t) to be the result of exahaustively -applying S(f,_) to t. - ------------------------------------------------------------------------------ -Our main invariant: - the EqCts in inert_eqs should be a terminating generalised substitution ------------------------------------------------------------------------------ - -Note that termination is not the same as idempotence. To apply S to a -type, you may have to apply it recursively. But termination does -guarantee that this recursive use will terminate. - -Note [Why R2?] -~~~~~~~~~~~~~~ -R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >= -f1. If we do not have R2, we will easily fall into a loop. - -To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our -inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And -yet, we have a hard time noticing an occurs-check problem when building S, as -the two equalities cannot rewrite one another. - -R2 actually restricts our ability to accept user-written programs. See -Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example. - -Note [Rewritable] -~~~~~~~~~~~~~~~~~ -This Note defines what it means for a type variable or type family application -(that is, a CanEqLHS) to be rewritable in a type. This definition is used -by the anyRewritableXXX family of functions and is meant to model the actual -behaviour in GHC.Tc.Solver.Rewrite. - -Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the -lhs tree appears as a subtree within t without traversing any of the following -components of t: - * coercions (whether they appear in casts CastTy or as arguments CoercionTy) - * kinds of variable occurrences -The check for rewritability *does* look in kinds of the bound variable of a -ForAllTy. - -Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised -substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f -for all f. - -The reason for this definition is that the rewriter does not rewrite in coercions -or variables' kinds. In turn, the rewriter does not need to rewrite there because -those places are never used for controlling the behaviour of the solver: these -places are not used in matching instances or in decomposing equalities. - -There is one exception to the claim that non-rewritable parts of the tree do -not affect the solver: we sometimes do an occurs-check to decide e.g. how to -orient an equality. (See the comments on -GHC.Tc.Solver.Equality.canEqTyVarFunEq.) Accordingly, the presence of a -variable in a kind or coercion just might influence the solver. Here is an -example: - - type family Const x y where - Const x y = x - - AxConst :: forall x y. Const x y ~# x - - alpha :: Const Type Nat - [W] alpha ~ Int |> (sym (AxConst Type alpha) ;; - AxConst Type alpha ;; - sym (AxConst Type Nat)) - -The cast is clearly ludicrous (it ties together a cast and its symmetric version), -but we can't quite rule it out. (See (EQ1) from -Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need -the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha -from unifying with the RHS. I (Richard E) don't have an example of where this -problem can arise from a Haskell program, but we don't have an air-tight argument -for why the definition of *rewritable* given here is correct. - -Taking roles into account: we must consider a rewrite at a given role. That is, -a rewrite arises from some equality, and that equality has a role associated -with it. As we traverse a type, we track what role we are allowed to rewrite with. - -For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in -Maybe b but not in F b, where F is a type function. This role-aware logic is -present in both the anyRewritableXXX functions and in the rewriter. -See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Main Theorem [Stability under extension] - Suppose we have a "work item" - lhs -fw-> t - and a terminating generalised substitution S, - THEN the extended substitution T = S+(lhs -fw-> t) - is a terminating generalised substitution - PROVIDED - (T1) S(fw,lhs) = lhs -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) lhs not in t -- No occurs check in the work item - -- If lhs is a type family application, we require only that - -- lhs is not *rewritable* in t. See Note [Rewritable] and - -- Note [EqCt occurs check] in GHC.Tc.Types.Constraint. - - AND, for every (lhs1 -fs-> s) in S: - (K0) not (fw >= fs) - Reason: suppose we kick out (lhs1 -fs-> s), - and add (lhs -fw-> t) to the inert set. - The latter can't rewrite the former, - so the kick-out achieved nothing - - -- From here, we can assume fw >= fs - OR (K4) lhs1 is a tyvar AND fs >= fw - - OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable]. - Reason: if fw >= fs, WF1 says we can't have both - lhs0 -fw-> t and F lhs0 -fs-> s - - AND (K2): guarantees termination of the new substitution - { (K2a) not (fs >= fs) - OR (K2b) lhs not in s } - - AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= lhs - (K3b) If the role of fs is representational: - s is not of form (lhs t1 .. tn) } } - - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable - -The idea is that -* T1 and T2 are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by an occurs-check on the work item. - This is done during canonicalisation, in checkTypeEq; invariant - (TyEq:OC) of CEqCan. See also Note [EqCt occurs check] in GHC.Tc.Types.Constraint. - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. See also (K2a) below. - -* Lemma (L1): The conditions of the Main Theorem imply that there is no - (lhs -fs-> t) in S, s.t. (fs >= fw). - Proof. Suppose the contrary (fs >= fw). Then because of (T1), - S(fw,lhs)=lhs. But since fs>=fw, S(fw,lhs) = t, hence t=lhs. But now we - have (lhs -fs-> lhs) in S, which contradicts (WF2). - -* The extended substitution satisfies (WF1) and (WF2) - - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - - (T3) guarantees (WF2). - -* (K2) and (K4) are about termination. Intuitively, any infinite chain S^0(f,t), - S^1(f,t), S^2(f,t).... must pass through the new work item infinitely - often, since the substitution without the work item is terminating; and must - pass through at least one of the triples in S infinitely often. - - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f) - (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t). - It is always safe to extend S with such a triple. - - (NB: we could strengthen K1) in this way too, but see K3. - - - (K2b): if lhs not in s, we have no further opportunity to apply the - work item - - - (K4): See Note [K4] - -* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then - if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s. - Proof. K4 holds; thus, we keep. - -Key lemma to make it watertight. - Under the conditions of the Main Theorem, - forall f st fw >= f, a is not in S^k(f,t), for any k - -Also, consider roles more carefully. See Note [Flavours with roles] - -Note [K4] -~~~~~~~~~ -K4 is a "keep" condition of Note [Extending the inert equalities]. -Here is the scenario: - -* We are considering adding (lhs -fw-> t) to the inert set S. -* S already has (lhs1 -fs-> s). -* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t. - See Note [Rewritable]. These are (T1), (T2), and (T3). -* We further know fw >= fs. (If not, then we short-circuit via (K0).) - -K4 says that we may keep lhs1 -fs-> s in S if: - lhs1 is a tyvar AND fs >= fw - -Why K4 guarantees termination: - * If fs >= fw, we know a is not rewritable in t, because of (T2). - * We further know lhs /= a, because of (T1). - * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions - for a use of a -fs-> s (precisely because t does not mention a), and hence, - the extended substitution (with lhs -fw-> t in it) is a terminating - generalised substitution. - -Recall that the termination generalised substitution includes only mappings that -pass an occurs check. This is (T3). At one point, we worried that the -argument here would fail if s mentioned a, but (T3) rules out this possibility. -Put another way: the terminating generalised substitution considers only the inert_eqs, -not other parts of the inert set (such as the irreds). - -Can we liberalise K4? No. - -Why we cannot drop the (fs >= fw) condition: - * Suppose not (fs >= fw). It might be the case that t mentions a, and this - can cause a loop. Example: - - Work: [G] b ~ a - Inert: [W] a ~ b - - (where G >= G, G >= W, and W >= W) - If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int. - - * Note that the above example is different if the inert is a Given G, because - (T1) won't hold. - -Why we cannot drop the tyvar condition: - * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2). - * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s? - Yes! This can happen if t appears within tys. - - Here is an example: - - Work: [G] a ~ Int - Inert: [G] F Int ~ F a - - Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand - side. The key reason why K2b works in the tyvar case is that tyvars are atomic: - if the right-hand side of an equality does not mention a variable a, then it - cannot allow an equality with an LHS of a to fire. This is not the case for - type family applications. - -Bottom line: K4 can keep only inerts with tyvars on the left. Put differently, -K4 will never prevent an inert with a type family on the left from being kicked -out. - -Consequence: We never kick out a Given/Nominal equality with a tyvar on the left. -This is Lemma (L3) of Note [Extending the inert equalities]. It is good because -it means we can effectively model the mutable filling of metavariables with -Given/Nominal equalities. That is: it should be the case that we could rewrite -our solver never to fill in a metavariable; instead, it would "solve" a wanted -like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting. -We would want the solver to behave the same whether it uses metavariables or -Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out, -just like we never unfill a metavariable. Nice. - -Getting this wrong (that is, allowing K4 to apply to situations with the type -family on the left) led to #19042. (At that point, K4 was known as K2b.) - -Originally, this condition was part of K2, but #17672 suggests it should be -a top-level K condition. - -Note [K3: completeness of solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(K3) is not necessary for the extended substitution -to be terminating. In fact K1 could be made stronger by saying - ... then (not (fw >= fs) or not (fs >= fs)) -But it's not enough for S to be terminating; we also want completeness. -That is, we want to be able to solve all soluble wanted equalities. -Suppose we have - - work-item b -G-> a - inert-item a -W-> b - -Assuming (G >= W) but not (W >= W), this fulfills all the conditions, -so we could extend the inerts, thus: - - inert-items b -G-> a - a -W-> b - -But if we kicked-out the inert item, we'd get - - work-item a -W-> b - inert-item b -G-> a - -Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. -So we add one more clause to the kick-out criteria - -Another way to understand (K3) is that we treat an inert item - a -f-> b -in the same way as - b -f-> a -So if we kick out one, we should kick out the other. The orientation -is somewhat accidental. - -When considering roles, we also need the second clause (K3b). Consider - - work-item c -G/N-> a - inert-item a -W/R-> b c - -The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. -But we don't kick out the inert item because not (W/R >= W/R). So we just -add the work item. But then, consider if we hit the following: - - work-item b -G/N-> Id - inert-items a -W/R-> b c - c -G/N-> a -where - newtype Id x = Id x - -For similar reasons, if we only had (K3a), we wouldn't kick the -representational inert out. And then, we'd miss solving the inert, which -now reduced to reflexivity. - -The solution here is to kick out representational inerts whenever the -lhs of a work item is "exposed", where exposed means being at the -head of the top-level application chain (lhs t1 .. tn). See -is_can_eq_lhs_head. This is encoded in (K3b). - -Beware: if we make this test succeed too often, we kick out too much, -and the solver might loop. Consider (#14363) - work item: [G] a ~R f b - inert item: [G] b ~R f a -In GHC 8.2 the completeness tests more aggressive, and kicked out -the inert item; but no rewriting happened and there was an infinite -loop. All we need is to have the tyvar at the head. - -Note [Flavours with roles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The system described in Note [inert_eqs: the inert equalities] -discusses an abstract -set of flavours. In GHC, flavours have two components: the flavour proper, -taken from {Wanted, Given} and the equality relation (often called -role), taken from {NomEq, ReprEq}. -When substituting w.r.t. the inert set, -as described in Note [inert_eqs: the inert equalities], -we must be careful to respect all components of a flavour. -For example, if we have - - inert set: a -G/R-> Int - b -G/R-> Bool - - type role T nominal representational - -and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT -T Int Bool. The reason is that T's first parameter has a nominal role, and -thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of -substitution means that the proof in Note [inert_eqs: the inert equalities] may -need to be revisited, but we don't think that the end conclusion is wrong. --} - -data InertCans -- See Note [Detailed InertCans Invariants] for more - = IC { inert_eqs :: InertEqs - -- See Note [inert_eqs: the inert equalities] - -- All EqCt with a TyVarLHS; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: InertFunEqs - -- All EqCt with a TyFamLHS; index is the whole family head type. - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include both [G] and [W] - - , inert_dicts :: DictMap DictCt - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_insts :: [QCInst] - - , inert_safehask :: DictMap DictCt - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in GHC.Tc.Solver - - , inert_irreds :: InertIrreds - -- Irreducible predicates that cannot be made canonical, - -- and which don't interact with others (e.g. (c a)) - -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_given_eq_lvl :: TcLevel - -- The TcLevel of the innermost implication that has a Given - -- equality of the sort that make a unification variable untouchable - -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). - -- See Note [Tracking Given equalities] - - , inert_given_eqs :: Bool - -- True <=> The inert Givens *at this level* (tcl_tclvl) - -- could includes at least one equality /other than/ a - -- let-bound skolem equality. - -- Reason: report these givens when reporting a failed equality - -- See Note [Tracking Given equalities] - } - -type InertEqs = DTyVarEnv EqualCtList -type InertFunEqs = FunEqMap EqualCtList -type InertIrreds = Bag IrredCt - -instance Outputable InertCans where - ppr (IC { inert_eqs = eqs - , inert_funeqs = funeqs - , inert_dicts = dicts - , inert_safehask = safehask - , inert_irreds = irreds - , inert_given_eq_lvl = ge_lvl - , inert_given_eqs = given_eqs - , inert_insts = insts }) - - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities =" - <+> pprBag (foldTyEqs consBag eqs emptyBag) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" - <+> pprBag (foldFunEqs consBag funeqs emptyBag) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprBag (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask) - , ppUnless (isEmptyBag irreds) $ - text "Irreds =" <+> pprBag irreds - , ppUnless (null insts) $ - text "Given instances =" <+> vcat (map ppr insts) - , text "Innermost given equalities =" <+> ppr ge_lvl - , text "Given eqs at this level =" <+> ppr given_eqs - ] - - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -emptyTyEqs :: InertEqs -emptyTyEqs = emptyDVarEnv - -addEqToCans :: TcLevel -> EqCt -> InertCans -> InertCans -addEqToCans tc_lvl eq_ct@(EqCt { eq_lhs = lhs }) - ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs }) - = updGivenEqs tc_lvl (CEqCan eq_ct) $ - case lhs of - TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct } - TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv eq_ct } - -addTyEq :: InertEqs -> TcTyVar -> EqCt -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] - where - add_eq old_eqs _ = addToEqualCtList ct old_eqs - -foldTyEqs :: (EqCt -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> [EqCt] -findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv) - -delEq :: EqCt -> InertCans -> InertCans -delEq (EqCt { eq_lhs = lhs, eq_rhs = rhs }) ic = case lhs of - TyVarLHS tv - -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv } - TyFamLHS tf args - -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd } - where - isThisOne :: EqCt -> Bool - isThisOne (EqCt { eq_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1 - - upd :: Maybe EqualCtList -> Maybe EqualCtList - upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list - upd Nothing = Nothing - -findEq :: InertCans -> CanEqLHS -> [EqCt] -findEq icans (TyVarLHS tv) = findTyEqs icans tv -findEq icans (TyFamLHS fun_tc fun_args) - = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args) - -{-# INLINE partition_eqs_container #-} -partition_eqs_container - :: forall container - . container -- empty container - -> (forall b. (EqCt -> b -> b) -> container -> b -> b) -- folder - -> (EqCt -> container -> container) -- extender - -> (EqCt -> Bool) - -> container - -> ([EqCt], container) -partition_eqs_container empty_container fold_container extend_container pred orig_inerts - = fold_container folder orig_inerts ([], empty_container) - where - folder :: EqCt -> ([EqCt], container) -> ([EqCt], container) - folder eq_ct (acc_true, acc_false) - | pred eq_ct = (eq_ct : acc_true, acc_false) - | otherwise = (acc_true, extend_container eq_ct acc_false) - -partitionInertEqs :: (EqCt -> Bool) -- EqCt will always have a TyVarLHS - -> InertEqs - -> ([EqCt], InertEqs) -partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs addInertEqs - -addInertEqs :: EqCt -> InertEqs -> InertEqs --- Precondition: CanEqLHS is a TyVarLHS -addInertEqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) eqs = addTyEq eqs tv eq_ct -addInertEqs other _ = pprPanic "extendInertEqs" (ppr other) - ------------------------- - -addCanFunEq :: InertFunEqs -> TyCon -> [TcType] -> EqCt -> InertFunEqs -addCanFunEq old_eqs fun_tc fun_args ct - = alterTcApp old_eqs fun_tc fun_args upd - where - upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list - upd Nothing = Just [ct] - -foldFunEqs :: (EqCt -> b -> b) -> FunEqMap EqualCtList -> b -> b -foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z - -partitionFunEqs :: (EqCt -> Bool) -- EqCt will have a TyFamLHS - -> InertFunEqs - -> ([EqCt], InertFunEqs) -partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs addFunEqs - -addFunEqs :: EqCt -> InertFunEqs -> InertFunEqs --- Precondition: EqCt is a TyFamLHS -addFunEqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args }) fun_eqs - = addCanFunEq fun_eqs tc args eq_ct -addFunEqs other _ = pprPanic "extendFunEqs" (ppr other) - - - -{- ********************************************************************* -* * - Inert Dicts -* * -********************************************************************* -} - -updDicts :: (DictMap DictCt -> DictMap DictCt) -> InertCans -> InertCans -updDicts upd ics = ics { inert_dicts = upd (inert_dicts ics) } - -delDict :: DictCt -> DictMap a -> DictMap a -delDict (DictCt { di_cls = cls, di_tys = tys }) m - = delTcApp m (classTyCon cls) tys - -addDict :: DictCt -> DictMap DictCt -> DictMap DictCt -addDict item@(DictCt { di_cls = cls, di_tys = tys }) dm - = insertTcApp dm (classTyCon cls) tys item - -addSolvedDict :: DictCt -> DictMap DictCt -> DictMap DictCt -addSolvedDict item@(DictCt { di_cls = cls, di_tys = tys }) dm - = insertTcApp dm (classTyCon cls) tys item - -filterDicts :: (DictCt -> Bool) -> DictMap DictCt -> DictMap DictCt -filterDicts f m = filterTcAppMap f m - -partitionDicts :: (DictCt -> Bool) -> DictMap DictCt -> (Bag DictCt, DictMap DictCt) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, addDict ct noes) - - -{- ********************************************************************* -* * - Inert Irreds -* * -********************************************************************* -} - -addIrredToCans :: TcLevel -> IrredCt -> InertCans -> InertCans -addIrredToCans tc_lvl irred ics - = updGivenEqs tc_lvl (CIrredCan irred) $ - updIrreds (addIrred irred) ics - -addIrreds :: [IrredCt] -> InertIrreds -> InertIrreds -addIrreds extras irreds - | null extras = irreds - | otherwise = irreds `unionBags` listToBag extras - -addIrred :: IrredCt -> InertIrreds -> InertIrreds -addIrred extra irreds = irreds `snocBag` extra - -updIrreds :: (InertIrreds -> InertIrreds) -> InertCans -> InertCans -updIrreds upd ics = ics { inert_irreds = upd (inert_irreds ics) } - -delIrred :: IrredCt -> InertCans -> InertCans --- Remove a particular (Given) Irred, on the instructions of a plugin --- For some reason this is done vis the evidence Id, not the type --- Compare delEq. I have not idea why -delIrred (IrredCt { ir_ev = ev }) ics - = updIrreds (filterBag keep) ics - where - ev_id = ctEvEvId ev - keep (IrredCt { ir_ev = ev' }) = ev_id /= ctEvEvId ev' - -foldIrreds :: (IrredCt -> b -> b) -> InertIrreds -> b -> b -foldIrreds k irreds z = foldr k z irreds - -findMatchingIrreds :: InertIrreds -> CtEvidence - -> (Bag (IrredCt, SwapFlag), InertIrreds) -findMatchingIrreds irreds ev - | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred - -- See Note [Solving irreducible equalities] - = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds - | otherwise - = partitionBagWith match_non_eq irreds - where - pred = ctEvPred ev - match_non_eq irred - | irredCtPred irred `tcEqTypeNoKindCheck` pred = Left (irred, NotSwapped) - | otherwise = Right irred - - match_eq eq_rel1 lty1 rty1 irred - | EqPred eq_rel2 lty2 rty2 <- classifyPredType (irredCtPred irred) - , eq_rel1 == eq_rel2 - , Just swap <- match_eq_help lty1 rty1 lty2 rty2 - = Left (irred, swap) - | otherwise - = Right irred - - match_eq_help lty1 rty1 lty2 rty2 - | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2 - = Just NotSwapped - | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2 - = Just IsSwapped - | otherwise - = Nothing - -{- Note [Solving irreducible equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14333) - [G] a b ~R# c d - [W] c d ~R# a b -Clearly we should be able to solve this! Even though the constraints are -not decomposable. We solve this when looking up the work-item in the -irreducible constraints to look for an identical one. When doing this -lookup, findMatchingIrreds spots the equality case, and matches either -way around. It has to return a swap-flag so we can generate evidence -that is the right way round too. --} - -{- ********************************************************************* -* * - Adding to and removing from the inert set -* * -* * -********************************************************************* -} - -updGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans --- Set the inert_given_eq_level to the current level (tclvl) --- if the constraint is a given equality that should prevent --- filling in an outer unification variable. --- See Note [Tracking Given equalities] -updGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl }) - | not (isGivenCt ct) = inerts - | not_equality ct = inerts -- See Note [Let-bound skolems] - | otherwise = inerts { inert_given_eq_lvl = ge_lvl' - , inert_given_eqs = True } - where - ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct) - -- Includes things like (c a), which *might* be an equality - = tclvl - | otherwise - = ge_lvl - - not_equality :: Ct -> Bool - -- True <=> definitely not an equality of any kind - -- except for a let-bound skolem, which doesn't count - -- See Note [Let-bound skolems] - -- NB: no need to spot the boxed CDictCan (a ~ b) because its - -- superclass (a ~# b) will be a CEqCan - not_equality (CEqCan (EqCt { eq_lhs = TyVarLHS tv })) = not (isOuterTyVar tclvl tv) - not_equality (CDictCan {}) = True - not_equality _ = False - -data KickOutSpec -- See Note [KickOutSpec] - = KOAfterUnify TcTyVarSet -- We have unified these tyvars - | KOAfterAdding CanEqLHS -- We are adding to the inert set a canonical equality - -- constraint with this LHS - -{- Note [KickOutSpec] -~~~~~~~~~~~~~~~~~~~~~~ -KickOutSpec explains why we are kicking out. - -Important property: - KOAfterAdding (TyVarLHS tv) should behave exactly like - KOAfterUnifying (unitVarSet tv) - -The main reasons for treating the two separately are -* More efficient in the single-tyvar case -* The code is far more perspicuous --} - -kickOutRewritableLHS :: KickOutSpec -> CtFlavourRole -> InertCans -> (Cts, InertCans) --- See Note [kickOutRewritable] -kickOutRewritableLHS ko_spec new_fr@(_, new_role) - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insts = old_insts }) - = (kicked_out, inert_cans_in) - where - -- inert_safehask stays unchanged; is that right? - inert_cans_in = ics { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insts = insts_in } - - kicked_out :: Cts - kicked_out = (fmap CDictCan dicts_out `andCts` fmap CIrredCan irs_out) - `extendCtsList` insts_out - `extendCtsList` map CEqCan tv_eqs_out - `extendCtsList` map CEqCan feqs_out - - (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_eq funeqmap - (dicts_out, dicts_in) = partitionDicts (kick_out_ct . CDictCan) dictmap - (irs_out, irs_in) = partitionBag (kick_out_ct . CIrredCan) irreds - -- Kick out even insolubles: See Note [Rewrite insolubles] - -- Of course we must kick out irreducibles like (c a), in case - -- we can rewrite 'c' to something more useful - - -- Kick-out for inert instances - -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve - insts_out :: [Ct] - insts_in :: [QCInst] - (insts_out, insts_in) - | fr_may_rewrite (Given, NomEq) -- All the insts are Givens - = partitionWith kick_out_qci old_insts - | otherwise - = ([], old_insts) - kick_out_qci qci - | let ev = qci_ev qci - , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) - = Left (mkNonCanonical ev) - | otherwise - = Right qci - - fr_tv_can_rewrite_ty :: (TyVar -> Bool) -> EqRel -> Type -> Bool - fr_tv_can_rewrite_ty ok_tv role ty - = anyRewritableTyVar role can_rewrite ty - where - can_rewrite :: EqRel -> TyVar -> Bool - can_rewrite old_role tv = new_role `eqCanRewrite` old_role && ok_tv tv - - fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool - fr_tf_can_rewrite_ty new_tf new_tf_args role ty - = anyRewritableTyFamApp role can_rewrite ty - where - can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool - can_rewrite old_role old_tf old_tf_args - = new_role `eqCanRewrite` old_role && - tcEqTyConApps new_tf new_tf_args old_tf old_tf_args - -- it's possible for old_tf_args to have too many. This is fine; - -- we'll only check what we need to. - - {-# INLINE fr_can_rewrite_ty #-} -- Perform case analysis on ko_spec only once - fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty = case ko_spec of -- See Note [KickOutSpec] - KOAfterUnify tvs -> fr_tv_can_rewrite_ty (`elemVarSet` tvs) - KOAfterAdding (TyVarLHS tv) -> fr_tv_can_rewrite_ty (== tv) - KOAfterAdding (TyFamLHS tf tf_args) -> fr_tf_can_rewrite_ty tf tf_args - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs - -- Can the new item rewrite the inert item? - - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct ct = fr_may_rewrite fs && fr_can_rewrite_ty role (ctPred ct) - where - fs@(_,role) = ctFlavourRole ct - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq :: EqCt -> Bool - kick_out_eq (EqCt { eq_lhs = lhs, eq_rhs = rhs_ty - , eq_ev = ev, eq_eq_rel = eq_rel }) - | not (fr_may_rewrite fs) - = False -- (K0) Keep it in the inert set if the new thing can't rewrite it - - -- Below here (fr_may_rewrite fs) is True - - | TyVarLHS _ <- lhs - , fs `eqCanRewriteFR` new_fr - = False -- (K4) Keep it in the inert set if the LHS is a tyvar and - -- it can rewrite the work item. See Note [K4] - - | fr_can_rewrite_ty eq_rel (canEqLHSType lhs) - = True -- (K1) - -- The above check redundantly checks the role & flavour, - -- but it's very convenient - - | kick_out_for_inertness = True -- (K2) - | kick_out_for_completeness = True -- (K3) - | otherwise = False - - where - fs = (ctEvFlavour ev, eq_rel) - kick_out_for_inertness - = (fs `eqCanRewriteFR` fs) -- (K2a) - && fr_can_rewrite_ty eq_rel rhs_ty -- (K2b) - - kick_out_for_completeness -- (K3) and Note [K3: completeness of solving] - = case eq_rel of - NomEq -> is_new_lhs rhs_ty -- (K3a) - ReprEq -> head_is_new_lhs rhs_ty -- (K3b) - - is_new_lhs :: Type -> Bool - is_new_lhs = case ko_spec of -- See Note [KickOutSpec] - KOAfterUnify tvs -> is_tyvar_ty_for tvs - KOAfterAdding lhs -> (`eqType` canEqLHSType lhs) - - is_tyvar_ty_for :: TcTyVarSet -> Type -> Bool - -- True if the type is equal to one of the tyvars - is_tyvar_ty_for tvs ty - = case getTyVar_maybe ty of - Nothing -> False - Just tv -> tv `elemVarSet` tvs - - head_is_new_lhs :: Type -> Bool - head_is_new_lhs = case ko_spec of -- See Note [KickOutSpec] - KOAfterUnify tvs -> tv_at_head (`elemVarSet` tvs) - KOAfterAdding (TyVarLHS tv) -> tv_at_head (== tv) - KOAfterAdding (TyFamLHS tf tf_args) -> fam_at_head tf tf_args - - tv_at_head :: (TyVar -> Bool) -> Type -> Bool - tv_at_head is_tv = go - where - go (Rep.TyVarTy tv) = is_tv tv - go (Rep.AppTy fun _) = go fun - go (Rep.CastTy ty _) = go ty - go (Rep.TyConApp {}) = False - go (Rep.LitTy {}) = False - go (Rep.ForAllTy {}) = False - go (Rep.FunTy {}) = False - go (Rep.CoercionTy {}) = False - - fam_at_head :: TyCon -> [Type] -> Type -> Bool - fam_at_head fun_tc fun_args = go - where - go (Rep.TyVarTy {}) = False - go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy - go (Rep.CastTy ty _) = go ty - go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args - go (Rep.LitTy {}) = False - go (Rep.ForAllTy {}) = False - go (Rep.FunTy {}) = False - go (Rep.CoercionTy {}) = False - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (lhs ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'lhs' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use anyRewritableCanLHS, which examines the types /and - kinds/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this LHS! - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - -NB: we could in principle avoid kick-out: - a) When unifying a meta-tyvar from an outer level, because - then the entire implication will be iterated; see - Note [The Unification Level Flag] in GHC.Tc.Solver.Monad. - - b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType - Note [TcLevel invariants], a Given can't include a meta-tyvar from - its own level, so it falls under (a). Of course, we must still - kick out Givens when adding a new non-unification Given. - -But kicking out more vigorously may lead to earlier unification and fewer -iterations, so we don't take advantage of these possibilities. - -Note [Rewrite insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an insoluble alpha ~ [alpha], which is insoluble -because an occurs check. And then we unify alpha := [Int]. Then we -really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can -be decomposed. Otherwise we end up with a "Can't match [Int] ~ -[[Int]]" which is true, but a bit confusing because the outer type -constructors match. - -Hence: - * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, - simpl_loop), we feed the insolubles in solveSimpleWanteds, - so that they get rewritten (albeit not solved). - - * We kick insolubles out of the inert set, if they can be - rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) - - * We rewrite those insolubles in GHC.Tc.Solver.Equality - See Note [Make sure that insolubles are fully rewritten] - in GHC.Tc.Solver.Equality --} - -{- ********************************************************************* -* * - Queries -* * -* * -********************************************************************* -} - -mentionsOuterVar :: TcLevel -> CtEvidence -> Bool -mentionsOuterVar tclvl ev - = anyFreeVarsOfType (isOuterTyVar tclvl) $ - ctEvPred ev - -isOuterTyVar :: TcLevel -> TyCoVar -> Bool --- True of a type variable that comes from a --- shallower level than the ambient level (tclvl) -isOuterTyVar tclvl tv - | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $ - tclvl `strictlyDeeperThan` tcTyVarLevel tv - -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from - -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't - -- be a touchable meta tyvar. If this wasn't true, you might worry that, - -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby - -- becomes "outer" even though its level numbers says it isn't. - | otherwise = False -- Coercion variables; doesn't much matter - -noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool --- True <=> there is no Irred looking like (N tys1 ~ N tys2) --- See Note [Decomposing newtype equalities] (EX2) in GHC.Tc.Solver.Equality --- This is the only call site. -noGivenNewtypeReprEqs tc inerts - = not (anyBag might_help (inert_irreds (inert_cans inerts))) - where - might_help irred - = case classifyPredType (ctEvPred (irredCtEvidence irred)) of - EqPred ReprEq t1 t2 - | Just (tc1,_) <- tcSplitTyConApp_maybe t1 - , tc == tc1 - , Just (tc2,_) <- tcSplitTyConApp_maybe t2 - , tc == tc2 - -> True - _ -> False - --- | Returns True iff there are no Given constraints that might, --- potentially, match the given class consraint. This is used when checking to see if a --- Given might overlap with an instance. See Note [Instance and Given overlap] --- in GHC.Tc.Solver.Dict -noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool -noMatchableGivenDicts inerts@(IS { inert_cans = inert_cans }) loc_w clas tys - = not $ anyBag matchable_given $ - findDictsByClass (inert_dicts inert_cans) clas - where - pred_w = mkClassPred clas tys - - matchable_given :: DictCt -> Bool - matchable_given (DictCt { di_ev = ev }) - | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ev - = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w - - | otherwise - = False - -mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst --- See Note [What might equal later?] --- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Dict -mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc - | prohibitedSuperClassSolve given_loc wanted_loc - = Nothing - - | otherwise - = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of - Unifiable subst - -> Just subst - MaybeApart reason subst - | MARInfinite <- reason -- see Example 7 in the Note. - -> Nothing - | otherwise - -> Just subst - SurelyApart -> Nothing - - where - in_scope = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred] - - -- NB: flatten both at the same time, so that we can share mappings - -- from type family applications to variables, and also to guarantee - -- that the fresh variables are really fresh between the given and - -- the wanted. Flattening both at the same time is needed to get - -- Example 10 from the Note. - ([flattened_given, flattened_wanted], var_mapping) - = flattenTysX in_scope [given_pred, wanted_pred] - - bind_fun :: BindFun - bind_fun tv rhs_ty - | isMetaTyVar tv - , can_unify tv (metaTyVarInfo tv) rhs_ty - -- this checks for CycleBreakerTvs and TyVarTvs; forgetting - -- the latter was #19106. - = BindMe - - -- See Examples 4, 5, and 6 from the Note - | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv - , anyFreeVarsOfTypes mentions_meta_ty_var fam_args - = BindMe - - | otherwise - = Apart - - -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars - -- (as they can be unified) - -- and also for CycleBreakerTvs that mentions meta-tyvars - mentions_meta_ty_var :: TyVar -> Bool - mentions_meta_ty_var tv - | isMetaTyVar tv - = case metaTyVarInfo tv of - -- See Examples 8 and 9 in the Note - CycleBreakerTv - -> anyFreeVarsOfType mentions_meta_ty_var - (lookupCycleBreakerVar tv inert_set) - _ -> True - | otherwise - = False - - -- Like checkTopShape, but allows cbv variables to unify - can_unify :: TcTyVar -> MetaInfo -> Type -> Bool - can_unify _lhs_tv TyVarTv rhs_ty -- see Example 3 from the Note - | Just rhs_tv <- getTyVar_maybe rhs_ty - = case tcTyVarDetails rhs_tv of - MetaTv { mtv_info = TyVarTv } -> True - MetaTv {} -> False -- Could unify with anything - SkolemTv {} -> True - RuntimeUnk -> True - | otherwise -- not a var on the RHS - = False - can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv - --- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@? --- --- Necessary (but not sufficient) conditions for this function to return @True@: --- --- - @ct1@ and @ct2@ both arise from superclass expansion, --- - @ct1@ is a Given and @ct2@ is a Wanted. --- --- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2). -prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ... - -> CtLoc -- ^ ... to solve this one? - -> Bool -- ^ True ==> don't solve it -prohibitedSuperClassSolve given_loc wanted_loc - | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc - , blocked - , ScOrigin _ NakedSc <- ctLocOrigin wanted_loc - = True -- Prohibited if the Wanted is a superclass - -- and the Given has come via a superclass selection from - -- a predicate bigger than the head - | otherwise - = False - -{- Note [What might equal later?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must determine whether a Given might later equal a Wanted. We -definitely need to account for the possibility that any metavariable -might be arbitrarily instantiated. Yet we do *not* want -to allow skolems in to be instantiated, as we've already rewritten -with respect to any Givens. (We're solving a Wanted here, and so -all Givens have already been processed.) - -This is best understood by example. - -1. C alpha ~? C Int - - That given certainly might match later. - -2. C a ~? C Int - - No. No new givens are going to arise that will get the `a` to rewrite - to Int. - -3. C alpha[tv] ~? C Int - - That alpha[tv] is a TyVarTv, unifiable only with other type variables. - It cannot equal later. - -4. C (F alpha) ~? C Int - - Sure -- that can equal later, if we learn something useful about alpha. - -5. C (F alpha[tv]) ~? C Int - - This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere. - Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other, - and F x x = Int. Remember: returning True doesn't commit ourselves to - anything. - -6. C (F a) ~? C a - - No, this won't match later. If we could rewrite (F a) or a, we would - have by now. But see also Red Herring below. - -7. C (Maybe alpha) ~? C alpha - - We say this cannot equal later, because it would require - alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived, - we choose not to worry about it. See Note [Infinitary substitution in lookup] - in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in - typecheck/should_compile/T19107. - -8. C cbv ~? C Int - where cbv = F a - - The cbv is a cycle-breaker var which stands for F a. See - Note [Type equality cycles] in GHC.Tc.Solver.Equality - This is just like case 6, and we say "no". Saying "no" here is - essential in getting the parser to type-check, with its use of DisambECP. - -9. C cbv ~? C Int - where cbv = F alpha - - Here, we might indeed equal later. Distinguishing between - this case and Example 8 is why we need the InertSet in mightEqualLater. - -10. C (F alpha, Int) ~? C (Bool, F alpha) - - This cannot equal later, because F a would have to equal both Bool and - Int. - -To deal with type family applications, we use the Core flattener. See -Note [Flattening type-family applications when matching instances] in GHC.Core.Unify. -The Core flattener replaces all type family applications with -fresh variables. The next question: should we allow these fresh -variables in the domain of a unifying substitution? - -A type family application that mentions only skolems (example 6) is settled: -any skolems would have been rewritten w.r.t. Givens by now. These type family -applications match only themselves. A type family application that mentions -metavariables, on the other hand, can match anything. So, if the original type -family application contains a metavariable, we use BindMe to tell the unifier -to allow it in the substitution. On the other hand, a type family application -with only skolems is considered rigid. - -This treatment fixes #18910 and is tested in -typecheck/should_compile/InstanceGivenOverlap{,2} - -Red Herring -~~~~~~~~~~~ -In #21208, we have this scenario: - -instance forall b. C b -[G] C a[sk] -[W] C (F a[sk]) - -What should we do with that wanted? According to the logic above, the Given -cannot match later (this is example 6), and so we use the global instance. -But wait, you say: What if we learn later (say by a future type instance F a = a) -that F a unifies with a? That looks like the Given might really match later! - -This mechanism described in this Note is *not* about this kind of situation, however. -It is all asking whether a Given might match the Wanted *in this run of the solver*. -It is *not* about whether a variable might be instantiated so that the Given matches, -or whether a type instance introduced in a downstream module might make the Given match. -The reason we care about what might match later is only about avoiding order-dependence. -That is, we don't want to commit to a course of action that depends on seeing constraints -in a certain order. But an instantiation of a variable and a later type instance -don't introduce order dependency in this way, and so mightMatchLater is right to ignore -these possibilities. - -Here is an example, with no type families, that is perhaps clearer: - -instance forall b. C (Maybe b) -[G] C (Maybe Int) -[W] C (Maybe a) - -What to do? We *might* say that the Given could match later and should thus block -us from using the global instance. But we don't do this. Instead, we rely on class -coherence to say that choosing the global instance is just fine, even if later we -call a function with (a := Int). After all, in this run of the solver, [G] C (Maybe Int) -will definitely never match [W] C (Maybe a). (Recall that we process Givens before -Wanteds, so there is no [G] a ~ Int hanging about unseen.) - -Interestingly, in the first case (from #21208), the behavior changed between -GHC 8.10.7 and GHC 9.2, with the latter behaving correctly and the former -reporting overlapping instances. - -Test case: typecheck/should_compile/T21208. - --} - -{- ********************************************************************* -* * - Cycle breakers -* * -********************************************************************* -} - --- | Return the type family application a CycleBreakerTv maps to. -lookupCycleBreakerVar :: TcTyVar -- ^ cbv, must be a CycleBreakerTv - -> InertSet - -> TcType -- ^ type family application the cbv maps to -lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack }) --- This function looks at every environment in the stack. This is necessary --- to avoid #20231. This function (and its one usage site) is the only reason --- that we store a stack instead of just the top environment. - | Just tyfam_app <- assert (isCycleBreakerTyVar cbv) $ - firstJusts (NE.map (lookupBag cbv) cbvs_stack) - = tyfam_app - | otherwise - = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack) - --- | Push a fresh environment onto the cycle-breaker var stack. Useful --- when entering a nested implication. -pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack -pushCycleBreakerVarStack = (emptyBag <|) - --- | Add a new cycle-breaker binding to the top environment on the stack. -addCycleBreakerBindings :: Bag (TcTyVar, Type) -- ^ (cbv,expansion) pairs - -> InertSet -> InertSet -addCycleBreakerBindings prs ics - = assertPpr (all (isCycleBreakerTyVar . fst) prs) (ppr prs) $ - ics { inert_cycle_breakers = add_to (inert_cycle_breakers ics) } - where - add_to (top_env :| rest_envs) = (prs `unionBags` top_env) :| rest_envs - --- | Perform a monadic operation on all pairs in the top environment --- in the stack. -forAllCycleBreakerBindings_ :: Monad m - => CycleBreakerVarStack - -> (TcTyVar -> TcType -> m ()) -> m () -forAllCycleBreakerBindings_ (top_env :| _rest_envs) action - = forM_ top_env (uncurry action) -{-# INLINABLE forAllCycleBreakerBindings_ #-} -- to allow SPECIALISE later - - -{- ********************************************************************* -* * - Solving one from another -* * -********************************************************************* -} - -data InteractResult - = KeepInert -- Keep the inert item, and solve the work item from it - -- (if the latter is Wanted; just discard it if not) - | KeepWork -- Keep the work item, and solve the inert item from it - -instance Outputable InteractResult where - ppr KeepInert = text "keep inert" - ppr KeepWork = text "keep work-item" - -solveOneFromTheOther :: Ct -- Inert (Dict or Irred) - -> Ct -- WorkItem (same predicate as inert) - -> InteractResult --- Precondition: --- * inert and work item represent evidence for the /same/ predicate --- * Both are CDictCan or CIrredCan --- --- We can always solve one from the other: even if both are wanted, --- although we don't rewrite wanteds with wanteds, we can combine --- two wanteds into one by solving one from the other - -solveOneFromTheOther ct_i ct_w - | CtWanted { ctev_loc = loc_w } <- ev_w - , prohibitedSuperClassSolve loc_i loc_w - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - = -- Inert must be Given - KeepWork - - | CtWanted {} <- ev_w - = -- Inert is Given or Wanted - case ev_i of - CtGiven {} -> KeepInert - -- work is Wanted; inert is Given: easy choice. - - CtWanted {} -- Both are Wanted - -- If only one has no pending superclasses, use it - -- Otherwise we can get infinite superclass expansion (#22516) - -- in silly cases like class C T b => C a b where ... - | not is_psc_i, is_psc_w -> KeepInert - | is_psc_i, not is_psc_w -> KeepWork - - -- If only one is a WantedSuperclassOrigin (arising from expanding - -- a Wanted class constraint), keep the other: wanted superclasses - -- may be unexpected by users - | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork - - -- otherwise, just choose the lower span - -- reason: if we have something like (abs 1) (where the - -- Num constraint cannot be satisfied), it's better to - -- get an error about abs than about 1. - -- This test might become more elaborate if we see an - -- opportunity to improve the error messages - | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert - | otherwise -> KeepWork - - -- From here on the work-item is Given - - | CtWanted { ctev_loc = loc_i } <- ev_i - , prohibitedSuperClassSolve loc_w loc_i - = KeepInert -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first - - | CtWanted {} <- ev_i - = KeepWork - - -- From here on both are Given - -- See Note [Replacement vs keeping] - - | lvl_i == lvl_w - = same_level_strategy - - | otherwise -- Both are Given, levels differ - = different_level_strategy - where - ev_i = ctEvidence ct_i - ev_w = ctEvidence ct_w - - pred = ctEvPred ev_i - - loc_i = ctEvLoc ev_i - loc_w = ctEvLoc ev_w - orig_i = ctLocOrigin loc_i - orig_w = ctLocOrigin loc_w - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w - - is_psc_w = isPendingScDict ct_w - is_psc_i = isPendingScDict ct_i - - is_wsc_orig_i = isWantedSuperclassOrigin orig_i - is_wsc_orig_w = isWantedSuperclassOrigin orig_w - - different_level_strategy -- Both Given - | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert - | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork - -- See Note [Replacement vs keeping] part (1) - -- For the isIPLikePred case see Note [Shadowing of implicit parameters] - -- in GHC.Tc.Solver.Dict - - same_level_strategy -- Both Given - = case (orig_i, orig_w) of - - (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w) - | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from - | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping] - - -- Both blocked or both not blocked - - | depth_w < depth_i -> KeepWork -- Case 2(c) from - | otherwise -> KeepInert -- Note [Replacement vs keeping] - - (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] - - _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] - -{- -Note [Replacement vs keeping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we have two Given constraints both of type (C tys), say, which should -we keep? More subtle than you might think! This is all implemented in -solveOneFromTheOther. - - 1) Constraints come from different levels (different_level_strategy) - - - For implicit parameters we want to keep the innermost (deepest) - one, so that it overrides the outer one. - See Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict - - - For everything else, we want to keep the outermost one. Reason: that - makes it more likely that the inner one will turn out to be unused, - and can be reported as redundant. See Note [Tracking redundant constraints] - in GHC.Tc.Solver. - - It transpires that using the outermost one is responsible for an - 8% performance improvement in nofib cryptarithm2, compared to - just rolling the dice. I didn't investigate why. - - 2) Constraints coming from the same level (i.e. same implication) - - (a) If both are GivenSCOrigin, choose the one that is unblocked if possible - according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - - (b) Prefer constraints that are not superclass selections. Example: - - f :: (Eq a, Ord a) => a -> Bool - f x = x == x - - Eager superclass expansion gives us two [G] Eq a constraints. We - want to keep the one from the user-written Eq a, not the superclass - selection. This means we report the Ord a as redundant with - -Wredundant-constraints, not the Eq a. - - Getting this wrong was #20602. See also - Note [Tracking redundant constraints] in GHC.Tc.Solver. - - (c) If both are GivenSCOrigin, chooose the one with the shallower - superclass-selection depth, in the hope of identifying more correct - redundant constraints. This is really a generalization of point (b), - because the superclass depth of a non-superclass constraint is 0. - - (If the levels differ, we definitely won't have both with GivenSCOrigin.) - - (d) Finally, when there is still a choice, use KeepInert rather than - KeepWork, for two reasons: - - to avoid unnecessary munging of the inert set. - - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Dict - -Doing the level-check for implicit parameters, rather than making the work item -always override, is important. Consider - - data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } - - f :: (?x::a) => T a -> Int - f T1 = ?x - f T2 = 3 - -We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add -two new givens in the work-list: [G] (?x::Int) - [G] (a ~ Int) -Now consider these steps - - process a~Int, kicking out (?x::a) - - process (?x::Int), the inner given, adding to inert set - - process (?x::a), the outer given, overriding the inner given -Wrong! The level-check ensures that the inner implicit parameter wins. -(Actually I think that the order in which the work-list is processed means -that this chain of events won't happen, but that's very fragile.) --} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} + +module GHC.Tc.Solver.InertSet ( + -- * The work list + WorkList(..), isEmptyWorkList, emptyWorkList, + extendWorkListNonEq, extendWorkListCt, + extendWorkListCts, extendWorkListCtList, + extendWorkListEq, extendWorkListChildEqs, + extendWorkListRewrittenEqs, + appendWorkList, + workListSize, + + -- * The inert set + InertSet(..), + InertCans(..), + emptyInertSet, emptyInertCans, + + noGivenNewtypeReprEqs, updGivenEqs, + prohibitedSuperClassSolve, + + -- * Inert equalities + InertEqs, + foldTyEqs, delEq, findEq, + partitionInertEqs, partitionFunEqs, + filterInertEqs, filterFunEqs, + foldFunEqs, addEqToCans, + + -- * Inert Dicts + updDicts, delDict, addDict, filterDicts, partitionDicts, + addSolvedDict, lookupSolvedDict, lookupInertDict, + + -- * Inert Irreds + InertIrreds, delIrred, addIrreds, addIrred, foldIrreds, + findMatchingIrreds, updIrreds, addIrredToCans, + + -- * Kick-out + KickOutSpec(..), kickOutRewritableLHS, + + -- * Cycle breaker vars + CycleBreakerVarStack, + pushCycleBreakerVarStack, + addCycleBreakerBindings, + forAllCycleBreakerBindings_, + + -- * Solving one from another + InteractResult(..), solveOneFromTheOther + + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, ctLocSpan, ctLocLevel ) +import GHC.Tc.Solver.Types +import GHC.Tc.Utils.TcType + +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique( hasKey ) +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Core.Reduction +import GHC.Core.Predicate +import qualified GHC.Core.TyCo.Rep as Rep +import GHC.Core.TyCon +import GHC.Core.Class( Class, classTyCon ) +import GHC.Builtin.Names( eqPrimTyConKey, heqTyConKey, eqTyConKey, coercibleTyConKey ) +import GHC.Utils.Misc ( partitionWith ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Data.Bag + +import Control.Monad ( forM_ ) +import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import Data.Function ( on ) + +{- +************************************************************************ +* * +* Worklists * +* Canonical and non-canonical constraints that the simplifier has to * +* work on. Including their simplification depths. * +* * +* * +************************************************************************ + +Note [WorkList priorities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A WorkList contains canonical and non-canonical items (of all flavours). +Notice that each Ct now has a simplification depth. We may +consider using this depth for prioritization as well in the future. + +As a simple form of priority queue, our worklist separates out + +* equalities (wl_eqs); see Note [Prioritise equalities] +* all the rest (wl_rest) + +Note [Prioritise equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very important to process equalities over class constraints: + +* (Efficiency) The general reason to do so is that if we process a + class constraint first, we may end up putting it into the inert set + and then kicking it out later. That's extra work compared to just + doing the equality first. + +* (Avoiding fundep iteration) As #14723 showed, it's possible to + get non-termination if we + - Emit the fundep equalities for a class constraint, + generating some fresh unification variables. + - That leads to some unification + - Which kicks out the class constraint + - Which isn't solved (because there are still some more + equalities in the work-list), but generates yet more fundeps + Solution: prioritise equalities over class constraints + +* (Class equalities) We need to prioritise equalities even if they + are hidden inside a class constraint; see Note [Prioritise class equalities] + +* (Kick-out) We want to apply this priority scheme to kicked-out + constraints too (see the call to extendWorkListCt in kick_out_rewritable) + E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become + homo-kinded when kicked out, and hence we want to prioritise it. + +Further refinements: + +* Among the equalities we prioritise ones with an empty rewriter set; + see Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint, wrinkle (W1). + +* Among equalities with an empty rewriter set, we prioritise nominal equalities. + * They have more rewriting power, so doing them first is better. + * Prioritising them ameliorates the incompleteness of newtype + solving: see (Ex2) in Note [Decomposing newtype equalities] in + GHC.Tc.Solver.Equality. + +Note [Prioritise class equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prioritise equalities in the solver (see selectWorkItem). But class +constraints like (a ~ b) and (a ~~ b) are actually equalities too; +see Note [The equality types story] in GHC.Builtin.Types.Prim. + +Failing to prioritise these is inefficient (more kick-outs etc). +But, worse, it can prevent us spotting a "recursive knot" among +Wanted constraints. See comment:10 of #12734 for a worked-out +example. + +So we arrange to put these particular class constraints in the wl_eqs. + + NB: since we do not currently apply the substitution to the + inert_solved_dicts, the knot-tying still seems a bit fragile. + But this makes it better. +-} + +-- See Note [WorkList priorities] +data WorkList + = WL { wl_eqs_N :: [Ct] -- /Nominal/ equalities (s ~#N t), (s ~ t), (s ~~ t) + -- with definitely-empty rewriter set + + , wl_eqs_X :: [Ct] -- CEqCan, CDictCan, CIrredCan + -- with definitely-empty rewriter set + -- All other equalities: contains both equality constraints and + -- their class-level variants (a~b) and (a~~b); + -- See Note [Prioritise equalities] + -- See Note [Prioritise class equalities] + + , wl_rw_eqs :: [Ct] -- Like wl_eqs, but ones that may have a non-empty + -- rewriter set + -- We prioritise wl_eqs over wl_rw_eqs; + -- see Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint for more details. + + , wl_rest :: [Ct] + } + +isNominalEqualityCt :: Ct -> Bool +-- A nominal equality, primitive or not, +-- canonical or not +-- (s ~# t), (s ~ t), or (s ~~ t) +isNominalEqualityCt ct + | Just tc <- tcTyConAppTyCon_maybe (ctPred ct) + = tc `hasKey` eqPrimTyConKey || tc `hasKey` heqTyConKey || tc `hasKey` eqTyConKey + | otherwise + = False + +appendWorkList :: WorkList -> WorkList -> WorkList +appendWorkList + (WL { wl_eqs_N = eqs1_N, wl_eqs_X = eqs1_X, wl_rw_eqs = rw_eqs1, wl_rest = rest1 }) + (WL { wl_eqs_N = eqs2_N, wl_eqs_X = eqs2_X, wl_rw_eqs = rw_eqs2, wl_rest = rest2 }) + = WL { wl_eqs_N = eqs1_N ++ eqs2_N + , wl_eqs_X = eqs1_X ++ eqs2_X + , wl_rw_eqs = rw_eqs1 ++ rw_eqs2 + , wl_rest = rest1 ++ rest2 } + +workListSize :: WorkList -> Int +workListSize (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs, wl_rest = rest }) + = length eqs_N + length eqs_X + length rw_eqs + length rest + +extendWorkListEq :: RewriterSet -> Ct -> WorkList -> WorkList +extendWorkListEq rewriters ct + wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs }) + | isEmptyRewriterSet rewriters -- A wanted that has not been rewritten + -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint + = if isNominalEqualityCt ct + then wl { wl_eqs_N = ct : eqs_N } + else wl { wl_eqs_X = ct : eqs_X } + + | otherwise + = wl { wl_rw_eqs = ct : rw_eqs } + +extendWorkListChildEqs :: CtEvidence -> Bag Ct -> WorkList -> WorkList +-- Add [eq1,...,eqn] to the work-list +-- The constraints will be solved in left-to-right order: +-- see Note [Work-list ordering] in GHC.Tc.Solver.Equality +-- +-- Precondition: if the parent constraint has an empty +-- rewriter set, so will the new equalities +-- Precondition: new_eqs is non-empty +extendWorkListChildEqs parent_ev new_eqs + wl@(WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs }) + | isEmptyRewriterSet (ctEvRewriters parent_ev) + -- isEmptyRewriterSet: see Note [Prioritise Wanteds with empty RewriterSet] + -- in GHC.Tc.Types.Constraint + -- If the rewriter set is empty, add to wl_eqs_X and wl_eqs_N + = case partitionBag isNominalEqualityCt new_eqs of + (new_eqs_N, new_eqs_X) + | isEmptyBag new_eqs_N -> wl { wl_eqs_X = new_eqs_X `push_on_front` eqs_X } + | isEmptyBag new_eqs_X -> wl { wl_eqs_N = new_eqs_N `push_on_front` eqs_N } + | otherwise -> wl { wl_eqs_N = new_eqs_N `push_on_front` eqs_N + , wl_eqs_X = new_eqs_X `push_on_front` eqs_X } + -- These isEmptyBag tests are just trying + -- to avoid creating unnecessary thunks + + | otherwise -- If the rewriter set is non-empty, add to wl_rw_eqs + = wl { wl_rw_eqs = new_eqs `push_on_front` rw_eqs } + where + push_on_front :: Bag Ct -> [Ct] -> [Ct] + -- push_on_front puts the new equalities on the front of the queue + push_on_front new_eqs eqs = foldr (:) eqs new_eqs + +extendWorkListRewrittenEqs :: [EqCt] -> WorkList -> WorkList +-- Don't bother checking the RewriterSet: just pop them into wl_rw_eqs +extendWorkListRewrittenEqs new_eqs wl@(WL { wl_rw_eqs = rw_eqs }) + = wl { wl_rw_eqs = foldr ((:) . CEqCan) rw_eqs new_eqs } + +extendWorkListNonEq :: Ct -> WorkList -> WorkList +-- Extension by non equality +extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } + +extendWorkListCt :: Ct -> WorkList -> WorkList +-- Agnostic about what kind of constraint +extendWorkListCt ct wl + = case classifyPredType (ctEvPred ev) of + EqPred {} + -> extendWorkListEq rewriters ct wl + + ClassPred cls _ -- See Note [Prioritise class equalities] + | isEqualityClass cls + -> extendWorkListEq rewriters ct wl + + _ -> extendWorkListNonEq ct wl + where + ev = ctEvidence ct + rewriters = ctEvRewriters ev + +extendWorkListCtList :: [Ct] -> WorkList -> WorkList +extendWorkListCtList cts wl = foldr extendWorkListCt wl cts + +extendWorkListCts :: Cts -> WorkList -> WorkList +extendWorkListCts cts wl = foldr extendWorkListCt wl cts + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest }) + = null eqs_N && null eqs_X && null rw_eqs && null rest + +emptyWorkList :: WorkList +emptyWorkList = WL { wl_eqs_N = [], wl_eqs_X = [] + , wl_rw_eqs = [], wl_rest = [] } + +-- Pretty printing +instance Outputable WorkList where + ppr (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest }) + = text "WL" <+> (braces $ + vcat [ ppUnless (null eqs_N) $ + text "Eqs_N =" <+> vcat (map ppr eqs_N) + , ppUnless (null eqs_X) $ + text "Eqs_X =" <+> vcat (map ppr eqs_X) + , ppUnless (null rw_eqs) $ + text "RwEqs =" <+> vcat (map ppr rw_eqs) + , ppUnless (null rest) $ + text "Non-eqs =" <+> vcat (map ppr rest) + ]) + +{- ********************************************************************* +* * + InertSet: the inert set +* * +* * +********************************************************************* -} + +type CycleBreakerVarStack = NonEmpty (Bag (TcTyVar, TcType)) + -- ^ a stack of (CycleBreakerTv, original family applications) lists + -- first element in the stack corresponds to current implication; + -- later elements correspond to outer implications + -- used to undo the cycle-breaking needed to handle + -- Note [Type equality cycles] in GHC.Tc.Solver.Equality + -- Why store the outer implications? For the use in mightEqualLater (only) + -- + -- Why NonEmpty? So there is always a top element to add to + +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given, Wanted + -- Sometimes called "the inert set" + + , inert_givens :: InertCans + -- A subset of inert_cans, containing only Givens + -- Used to initialise inert_cans when recursing inside implications + + , inert_cycle_breakers :: CycleBreakerVarStack + + , inert_famapp_cache :: FunEqMap Reduction + -- Just a hash-cons cache for use when reducing family applications + -- only + -- + -- If F tys :-> (co, rhs, flav), + -- then co :: F tys ~N rhs + -- all evidence is from instances or Givens; no coercion holes here + -- (We have no way of "kicking out" from the cache, so putting + -- wanteds here means we can end up solving a Wanted with itself. Bad) + + , inert_solved_dicts :: DictMap DictCt + -- All Wanteds, of form (C t1 .. tn) + -- Always a dictionary solved by an instance decl; never an implict parameter + -- See Note [Solved dictionaries] + -- and Note [Do not add superclasses of solved dictionaries] + + , inert_safehask :: DictMap DictCt + -- Failed dictionary resolution due to Safe Haskell overlapping + -- instances restriction. We keep this separate from inert_dicts + -- as it doesn't cause compilation failure, just safe inference + -- failure. + -- + -- ^ See Note [Safe Haskell Overlapping Instances Implementation] + -- in GHC.Tc.Solver + } + +instance Outputable InertSet where + ppr (IS { inert_cans = ics + , inert_safehask = safehask + , inert_solved_dicts = solved_dicts }) + = vcat [ ppr ics + , ppUnless (null dicts) $ + text "Solved dicts =" <+> vcat (map ppr dicts) + , ppUnless (isEmptyTcAppMap safehask) $ + text "Safe Haskell unsafe overlap =" <+> pprBag (dictsToBag safehask) ] + where + dicts = bagToList (dictsToBag solved_dicts) + +emptyInertCans :: TcLevel -> InertCans +emptyInertCans given_eq_lvl + = IC { inert_eqs = emptyTyEqs + , inert_funeqs = emptyFunEqs + , inert_given_eq_lvl = given_eq_lvl + , inert_given_eqs = False + , inert_dicts = emptyDictMap + , inert_qcis = [] + , inert_irreds = emptyBag } + +emptyInertSet :: TcLevel -> InertSet +emptyInertSet given_eq_lvl + = IS { inert_cans = empty_cans + , inert_givens = empty_cans + , inert_cycle_breakers = emptyBag :| [] + , inert_famapp_cache = emptyFunEqs + , inert_solved_dicts = emptyDictMap + , inert_safehask = emptyDictMap } + where + empty_cans = emptyInertCans given_eq_lvl + +{- Note [Solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we apply a top-level instance declaration, we add the "solved" +dictionary to the inert_solved_dicts. In general, we use it to avoid +creating a new EvVar when we have a new goal that we have solved in +the past. + +But in particular, we can use it to create *recursive* dictionaries. +The simplest, degenerate case is + instance C [a] => C [a] where ... +If we have + [W] d1 :: C [x] +then we can apply the instance to get + d1 = $dfCList d + [W] d2 :: C [x] +Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. + d1 = $dfCList d + d2 = d1 + +See Note [Example of recursive dictionaries] + +VERY IMPORTANT INVARIANT: + + (Solved Dictionary Invariant) + Every member of the inert_solved_dicts is the result + of applying an instance declaration that "takes a step" + + An instance "takes a step" if it has the form + dfunDList d1 d2 = MkD (...) (...) (...) + That is, the dfun is lazy in its arguments, and guarantees to + immediately return a dictionary constructor. NB: all dictionary + data constructors are lazy in their arguments. + + This property is crucial to ensure that all dictionaries are + non-bottom, which in turn ensures that the whole "recursive + dictionary" idea works at all, even if we get something like + rec { d = dfunDList d dx } + See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. + + Reason: + - All instances, except two exceptions listed below, "take a step" + in the above sense + + - Exception 1: local quantified constraints have no such guarantee; + indeed, adding a "solved dictionary" when applying a quantified + constraint led to the ability to define unsafeCoerce + in #17267. + + - Exception 2: the magic built-in instance for (~) has no + such guarantee. It behaves as if we had + class (a ~# b) => (a ~ b) where {} + instance (a ~# b) => (a ~ b) where {} + The "dfun" for the instance is strict in the coercion. + Anyway there's no point in recording a "solved dict" for + (t1 ~ t2); it's not going to allow a recursive dictionary + to be constructed. Ditto (~~) and Coercible. + +THEREFORE we only add a "solved dictionary" + - when applying an instance declaration + - subject to Exceptions 1 and 2 above + +In implementation terms + - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary, + conditional on the kind of instance + + - It is only called when applying an instance decl, + in GHC.Tc.Solver.Dict.tryInstances + + - ClsInst.InstanceWhat says what kind of instance was + used to solve the constraint. In particular + * LocalInstance identifies quantified constraints + * BuiltinEqInstance identifies the strange built-in + instances for equality. + + - ClsInst.instanceReturnsDictCon says which kind of + instance guarantees to return a dictionary constructor + +Other notes about solved dictionaries + +* See also Note [Do not add superclasses of solved dictionaries] + +* The inert_solved_dicts field is not rewritten by equalities, + so it may get out of date. + +* The inert_solved_dicts are all Wanteds, never givens + +* We only cache dictionaries from top-level instances, not from + local quantified constraints. Reason: if we cached the latter + we'd need to purge the cache when bringing new quantified + constraints into scope, because quantified constraints "shadow" + top-level instances. + +Note [Do not add superclasses of solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every member of inert_solved_dicts is the result of applying a +dictionary function, NOT of applying superclass selection to anything. +Consider + + class Ord a => C a where + instance Ord [a] => C [a] where ... + +Suppose we are trying to solve + [G] d1 : Ord a + [W] d2 : C [a] + +Then we'll use the instance decl to give + + [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 + [W] d3 : Ord [a] + +We must not add d4 : Ord [a] to the 'solved' set (by taking the +superclass of d2), otherwise we'll use it to solve d3, without ever +using d1, which would be a catastrophe. + +Solution: when extending the solved dictionaries, do not add superclasses. +That's why each element of the inert_solved_dicts is the result of applying +a dictionary function. + +Note [Example of recursive dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +--- Example 1 + + data D r = ZeroD | SuccD (r (D r)); + + instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + + equalDC :: D [] -> D [] -> Bool; + equalDC = (==); + +We need to prove (Eq (D [])). Here's how we go: + + [W] d1 : Eq (D []) +By instance decl of Eq (D r): + [W] d2 : Eq [D []] where d1 = dfEqD d2 +By instance decl of Eq [a]: + [W] d3 : Eq (D []) where d2 = dfEqList d3 + d1 = dfEqD d2 +Now this wanted can interact with our "solved" d1 to get: + d3 = d1 + +-- Example 2: +This code arises in the context of "Scrap Your Boilerplate with Class" + + class Sat a + class Data ctx a + instance Sat (ctx Char) => Data ctx Char -- dfunData1 + instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 + + class Data Maybe a => Foo a + + instance Foo t => Sat (Maybe t) -- dfunSat + + instance Data Maybe a => Foo a -- dfunFoo1 + instance Foo a => Foo [a] -- dfunFoo2 + instance Foo [Char] -- dfunFoo3 + +Consider generating the superclasses of the instance declaration + instance Foo a => Foo [a] + +So our problem is this + [G] d0 : Foo t + [W] d1 : Data Maybe [t] -- Desired superclass + +We may add the given in the inert set, along with its superclasses + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + WorkList + [W] d1 : Data Maybe [t] + +Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + WorkList: + [W] d2 : Sat (Maybe [t]) + [W] d3 : Data Maybe t + +Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 + Inert: + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList: + [W] d3 : Data Maybe t + [W] d4 : Foo [t] + +Now, we can just solve d3 from d01; d3 := d01 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + WorkList + [W] d4 : Foo [t] + +Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 + Inert + [G] d0 : Foo t + [G] d01 : Data Maybe t -- Superclass of d0 + Solved: + d1 : Data Maybe [t] + d2 : Sat (Maybe [t]) + d4 : Foo [t] + WorkList: + [W] d5 : Foo t + +Now, d5 can be solved! d5 := d0 + +Result + d1 := dfunData2 d2 d3 + d2 := dfunSat d4 + d3 := d01 + d4 := dfunFoo2 d5 + d5 := d0 +-} + +{- ********************************************************************* +* * + InertCans: the canonical inerts +* * +* * +********************************************************************* -} + +{- Note [Tracking Given equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify +Note [Unification preconditions], we can't unify + alpha[2] ~ Int +under a level-4 implication if there are any Given equalities +bound by the implications at level 3 of 4. To that end, the +InertCans tracks + + inert_given_eq_lvl :: TcLevel + -- The TcLevel of the innermost implication that has a Given + -- equality of the sort that make a unification variable untouchable + -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). + +We update inert_given_eq_lvl whenever we add a Given to the +inert set, in updGivenEqs. + +Then a unification variable alpha[n] is untouchable iff + n < inert_given_eq_lvl +that is, if the unification variable was born outside an +enclosing Given equality. + +Exactly which constraints should trigger (UNTOUCHABLE), and hence +should update inert_given_eq_lvl? + +(TGE1) We do /not/ need to worry about let-bound skolems, such as + forall[2] a. a ~ [b] => blah + See Note [Let-bound skolems] and the isOuterTyVar tests in `updGivenEqs` + +(TGE2) However, solely to support better error messages (see Note [HasGivenEqs] in + GHC.Tc.Types.Constraint) we also track these "local" equalities in the + boolean inert_given_eqs field. This field is used only subsequntly (see + `getHasGivenEqs`), to set the ic_given_eqs field to LocalGivenEqs. + +(TGE3) Consider an implication + forall[2]. beta[1] => alpha[1] ~ Int + where beta is a unification variable that has already been unified + to () in an outer scope. Then alpha[1] is perfectly touchable and + we can unify alpha := Int. So when deciding whether the givens contain + an equality, we should canonicalise first, rather than just looking at + the /original/ givens (#8644). + +(TGE4) However, we must take account of *potential* equalities. Consider the + same example again, but this time we have /not/ yet unified beta: + forall[2] beta[1] => ...blah... + + Because beta might turn into an equality, updGivenEqs conservatively + treats it as a potential equality, and updates inert_give_eq_lvl + +(TGE5) We should not look at the equality relation involved (nominal vs + representational), because representational equalities can still + imply nominal ones. For example, if (G a ~R G b) and G's argument's + role is nominal, then we can deduce a ~N b. + +(TGE6) A subtle point is this: when initialising the solver, giving it + an empty InertSet, we must conservatively initialise `inert_given_lvl` + to the /current/ TcLevel. This matters when doing let-generalisation. + Consider #26004: + f w e = case e of + T1 -> let y = not w in False -- T1 is a GADT + T2 -> True + When let-generalising `y`, we will have (w :: alpha[1]) in the type + envt; and we are under GADT pattern match. So when we solve the + constraints from y's RHS, in simplifyInfer, we must NOT unify + alpha[1] := Bool + Since we don't know what enclosing equalities there are, we just + conservatively assume that there are some. + + This initialisation in done in `runTcSWithEvBinds`, which passes + the current TcLevel to `emptyInertSet`. + +Historical note: prior to #24938 we also ignored Given equalities that +did not mention an "outer" type variable. But that is wrong, as #24938 +showed. Another example is immortalised in test LocalGivenEqs2 + data T where + MkT :: F a ~ G b => a -> b -> T + f (MkT _ _) = True +We should not infer the type for `f`; let-bound-skolems does not apply. + +Note [Let-bound skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +If * the inert set contains a canonical Given CEqCan (a ~ ty) +and * 'a' is a skolem bound in this very implication, + +then: + a) The Given is pretty much a let-binding, like + f :: (a ~ b->c) => a -> a + Here the equality constraint is like saying + let a = b->c in ... + It is not adding any new, local equality information, + and hence can be ignored by has_given_eqs + + b) 'a' will have been completely substituted out in the inert set, + so we can safely discard it. + +For an example, see #9211. + +The actual test is in `isLetBoundSkolemCt` + +Wrinkles: + +(LBS1) See GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure + that the correct variable is on the left of the equality when both are + tyvars. + +(LBS2) We also want this to work for + forall a. [G] F b ~ a (CEqCt with TyFamLHS) + Here the Given will have a TyFamLHS, with the skolem-bound tyvar on the RHS. + See tests T24938a, and LocalGivenEqs. + +(LBS3) Happily (LBS2) also makes cycle-breakers work. Suppose we have + forall a. [G] (F a) Int ~ a + where F has arity 1, and `a` is the locally-bound skolem. Then, as + Note [Type equality cycles] explains, we split into + [G] F a ~ cbv, [G] cbv Int ~ a + where `cbv` is the cycle breaker variable. But cbv has the same level + as `a`, so `isOuterTyVar` (called in `isLetBoundSkolemCt`) will return False. + + This actually matters occasionally: see test LocalGivenEqs. + +You might wonder whether the skolem really needs to be bound "in the +very same implication" as the equality constraint. +Consider this (c.f. #15009): + + data S a where + MkS :: (a ~ Int) => S a + + g :: forall a. S a -> a -> blah + g x y = let h = \z. ( z :: Int + , case x of + MkS -> [y,z]) + in ... + +From the type signature for `g`, we get `y::a` . Then when we +encounter the `\z`, we'll assign `z :: alpha[1]`, say. Next, from the +body of the lambda we'll get + + [W] alpha[1] ~ Int -- From z::Int + [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a -- From [y,z] + +Now, unify alpha := a. Now we are stuck with an unsolved alpha~Int! +So we must treat alpha as untouchable under the forall[2] implication. + +Possible future improvements. The current test just looks to see whether one +side of an equality is a locally-bound skolem. But actually we could, in +theory, do better: if one side (or both sides, actually) of an equality +ineluctably mentions a local skolem, then the equality cannot possibly impact +types outside of the implication (because doing to would cause those types to be +ill-scoped). The problem is the "ineluctably": this means that no expansion, +other solving, etc., could possibly get rid of the variable. This is hard, +perhaps impossible, to know for sure, especially when we think about type family +interactions. (And it's a user-visible property so we don't want it to be hard +to predict.) So we keep the existing check, looking for one lone variable, +because we're sure that variable isn't going anywhere. + +Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + + * All canonical + + * No two dictionaries with the same head + * No two CIrreds with the same type + + * Family equations inert wrt top-level family axioms + + * Dictionaries have no matching top-level instance + + * Given family or dictionary constraints don't mention touchable + unification variables + + * Non-CEqCan constraints are fully rewritten with respect + to the CEqCan equalities (modulo eqCanRewrite of course; + eg a wanted cannot rewrite a given) + + * CEqCan equalities: see Note [inert_eqs: the inert equalities] + Also see documentation in Constraint.Ct for a list of invariants + +Note [inert_eqs: the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Our main invariant: + the EqCts in inert_eqs should be a + terminating generalised substitution + +-------------- Definition [Can-rewrite relation] -------------- +A "can-rewrite" relation between flavours, written f1 >= f2, is a +binary relation with the following properties + + (R1) >= is transitive + (R2) If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 + (See Note [Why R2?].) + +Lemma (L0). If f1 >= f then f1 >= f1 +Proof. By property (R2), with f1=f2 + +--------- Definition [Generalised substitution] --------------- +A "generalised substitution" S is a set of triples (lhs -f-> t), where + - lhs is a type variable or an exactly-saturated type family application + (that is, lhs is a CanEqLHS) + - t is a type + - f is a flavour + +such that + + (WF1) if (lhs1 -f1-> t1) in S + (lhs2 -f2-> t2) in S + then (f1 >= f2) implies that lhs1 does not appear within lhs2 + + (WF2) if (lhs -f-> t) is in S, then t /= lhs + + (WF3) No LHS in S is rewritable in an RHS in S, + in the argument of a type family application (F ty1..tyn) + where F heads a LHS in S + +--------- Definition [Applying a generalised substitution] ---------- +If S is a generalised substitution + S(f,lhs) = rhs, if (lhs -fs-> rhs) in S, and fs >= f + S(f,T t1..tn) = T S(f1,t1)..S(fn,tn) + S(f,t1 t2) = S(f,t1) S(f_N,t2) + S(f,t) = t +Here f1..fn are obtained from f and T using the roles of T, and f_N is +the nominal version of f. See Note [Flavours with roles]. + +Notation: repeated application. + S^0(f,t) = t + S^(n+1)(f,t) = S(f, S^n(t)) + S*(f,t) is the result of applying S until you reach a fixpoint + +--------- Definition [Terminating generalised substitution] --------- +A generalised substitution S is *terminating* iff + + (IG1) for every f,t, there is an n such that + S^n(f,t) = S^(n+1)(f,t) + +By (IG1) we define S*(f,t) to be the result of exahaustively +applying S(f,_) to t. +--------- End of definitions ------------------------------------ + + +Rationale for (WF1)-(WF3) +------------------------- +* (WF1) guarantees that S is well-defined /as a function/; + see Theorem (S is a function) + + Theorem (S is a function): S(f,t0) is well defined as a function. + Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S, + and f1 >= f and f2 >= f + Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) + Note: this argument isn't quite right. WF1 ensures that lhs1 does + not appear inside lhs2, and that guarantees confluence. But I can't quite + see how to make that argument precise. + +* (WF2) is a bit trivial. It means that if S is terminating, so that + S^(n+1)(f,t) = S^n(f,t), then there is no LHS of S in S^n(f,t). We + never get a silly infinite sequence a -> a -> a -> a .... which is + technically a fixed point but would still go on for ever. + +* (WF3) is need for the termination proof. + +Note that termination is not the same as idempotence. To apply S to a +type, you may have to apply it recursively. But termination does +guarantee that this recursive use will terminate. + +Note [Why R2?] +~~~~~~~~~~~~~~ +R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >= +f1. If we do not have R2, we will easily fall into a loop. + +To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our +inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And +yet, we have a hard time noticing an occurs-check problem when building S, as +the two equalities cannot rewrite one another. + +R2 actually restricts our ability to accept user-written programs. See +Note [Avoiding rewriting cycles] in GHC.Tc.Types.Constraint for an example. + +Note [Rewritable] +~~~~~~~~~~~~~~~~~ +Definition. A CanEqLHS lhs is *rewritable* in a type t if the +lhs tree appears as a subtree within t without traversing any of the following +components of t: + * coercions (whether they appear in casts CastTy or as arguments CoercionTy) + * kinds of variable occurrences +The check for rewritability *does* look in kinds of the bound variable of a +ForAllTy. + +The reason for this definition is that the rewriter does not rewrite in coercions +or variables' kinds. In turn, the rewriter does not need to rewrite there because +those places are never used for controlling the behaviour of the solver: these +places are not used in matching instances or in decomposing equalities. + +This definition is used by the anyRewritableXXX family of functions and is meant +to model the actual behaviour in GHC.Tc.Solver.Rewrite. + +Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised +substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f +for all f. + +Wrinkles + +* Taking roles into account: we must consider a rewrite at a given role. That is, + a rewrite arises from some equality, and that equality has a role associated + with it. As we traverse a type, we track what role we are allowed to rewrite with. + + For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in + Maybe b but not in F b, where F is a type function. This role-aware logic is + present in both the anyRewritableXXX functions and in the rewriter. + See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType. + +* There is one exception to the claim that non-rewritable parts of the tree do + not affect the solver: we sometimes do an occurs-check to decide e.g. how to + orient an equality. (See the comments on GHC.Tc.Solver.Equality.canEqTyVarFunEq.) + Accordingly, the presence of a variable in a kind or coercion just might + influence the solver. Here is an example: + + type family Const x y where + Const x y = x + + AxConst :: forall x y. Const x y ~# x + + alpha :: Const Type Nat + [W] alpha ~ Int |> (sym (AxConst Type alpha) ;; + AxConst Type alpha ;; + sym (AxConst Type Nat)) + + The cast is clearly ludicrous (it ties together a cast and its symmetric + version), but we can't quite rule it out. (See (EQ1) from Note [Respecting + definitional equality] in GHC.Core.TyCo.Rep to see why we need the Const Type + Nat bit.) And yet this cast will (quite rightly) prevent alpha from unifying + with the RHS. I (Richard E) don't have an example of where this problem can + arise from a Haskell program, but we don't have an air-tight argument for why + the definition of *rewritable* given here is correct. + +Note [Extending the inert equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Main Theorem [Stability under extension] + GIVEN a "work item" [lhs_w -fw-> rhs_w] + and a terminating generalised substitution S, + + SUCH THAT + (T1) S(fw,lhs_w) = lhs_w -- LHS of work-item is a fixpoint of S(fw,_) + (T2) S(fw,rhs_w) = rhs_w -- RHS of work-item is a fixpoint of S(fw,_) + (T3) lhs_w not in rhs_w -- No occurs check in the work item + -- If lhs is a type family application, we require only that + -- lhs is not *rewritable* in rhs_w. See Note [Rewritable] and + -- Note [EqCt occurs check] in GHC.Tc.Types.Constraint. + (T4) no [lhs_s -fs-> rhs_s] in S meets [The KickOut Criteria] + (i.e. we already kicked any such items out!) + + THEN the extended substitution T = S+(lhs_w -fw-> rhs_w) + is a terminating generalised substitution + +How do we establish these conditions? + + * (T1) and (T2) are guaranteed by exhaustively rewriting the work-item + with S(fw,_). + + * (T3) is guaranteed by an occurs-check on the work item. + This is done during canonicalisation, in checkTypeEq; invariant + (TyEq:OC) of CEqCan. See also Note [EqCt occurs check] in GHC.Tc.Types.Constraint. + + * (T4) is established by GHC.Tc.Solver.Monad.kickOutRewritable. If the inert + set contains a triple that meets the KickOut Criteria, we kick it out and + add it to the work list for later re-examination. See + Note [The KickOut Criteria] + +Theorem: T (defined in "THEN" above) is a generalised substitution; + that is, it satisfies (WF1)-(WF3) +Proof: + (WF1) Suppose we are adding [lhs_w -fw-> rhs_w], and [lhs_s -fs-> rhs_s] is in S. + Then: + - by (T1) if fs>=fw, lhs_s does not occur within lhs_w. + - by (KK1) if fw>=fs, lhs_w is not rewritable in lhs_s, or we'd have + kicked out the stable constraint. + + (WF2) is directly guaranteed by (T3) + + (WF3) No lhs_s in S is rewritable in rhs_w at all, because of (T2) + And (KK2) guarantees that lhs_w is not rewritable under a type + family in rhs_s + +Note [The KickOut Criteria] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kicking out is a Bad Thing: +* It means we have to re-process a constraint. The less we kick out, the better. +* In the limit, kicking can lead to non-termination: imagine that we /always/ + kick out the entire inert set! +* Because (mid 2024) we don't support sharing in constraints, excessive kicking out + can lead to exponentially big constraints (#24984). + +So we seek to do as little kicking out as possible. For example, consider this, +which happens a lot: + + Inert: g1: a ~ Maybe b + Work: g2: b ~ Int + +We do /not/ kick out g1 when adding g2. The new substitution S' = {g1,g2} is still +/terminating/ but it is not /idmempotent/. To apply S' to, say, (Tree a), we may +need to apply it twice: Tree a --> Tree (Maybe b) --> Tree (Maybe Int) + +Here are the KickOut Criteria: + + When adding [lhs_w -fw-> rhs_w] to a well-formed terminating substitution S, + element [lhs_s -fs-> rhs_s] in S meets the KickOut Criteria if: + + (KK0) fw >= fs AND any of (KK1), (KK2) or (KK3) hold + + * (KK1: satisfy WF1) `lhs_w` is rewritable in `lhs_s`. + + * (KK2: termination) `lhs_w` is rewritable in `rhs_s` in these positions: + If not(fs>=fw) + then (KK2a) anywhere + else (KK2b) look only in the argument of type family applications, + whose type family heads some LHS in `S` + + * (KK3: completeness) + If not(fs >= fw) -- If fs can rewrite fw, kick-out is redundant/harmful + * (KK3a) If the role of `fs` is Nominal: + kick out if `rhs_s = lhs_w` + * (KK3b) If the role of `fs` is Representational: + kick out if `rhs_s` is of form `(lhs_w t1 .. tn)` + +Rationale + +* (KK0) kick out only if `fw` can rewrite `fs`. + Reason: suppose we kick out (lhs1 -fs-> s), and add (lhs -fw-> t) to the ineart + set. The latter can't rewrite the former, so the kick-out achieved nothing + +* (KK1) `lhs_w` is rewritable in `lhs_s`. + Reason: needed to guarantee (WF1). See Theorem: T is well formed + +* (KK2) see Note [KK2: termination of the extended substitution] + +* (KK3) see Note [KK3: completeness of solving] + +The above story is a bit vague wrt roles, but the code is not. +See Note [Flavours with roles] + +Note [KK2: termination of the extended substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Proving termination of the extended substitution T is surprisingly tricky. + +* Reason for (KK2a). Consider + Work: [G] b ~ a + Inert: [W] a ~ b + If we don't kick out the inert, then we get a loop on e.g. [W] a ~ Int. + But if both were Wanted we really should not kick out (the substitution does not + have to be idempotent). So we only look everywhere for the `lhs_w` if + not (fs>=fw), that is the inert item cannot rewrite the work item. So in the + above example we will kick out; but if both were Wanted we won't. + +* Reason for (KK2b). Consider the case where (fs >= fw) + Work: [G] a ~ Int + Inert: [G] F Int ~ F a + If we just added the work item, the substitution would loop on type (F Int). + So we must kick out the inert item, even though (fs>=fw). (KK2b) does this + by looking for lhs_w under type family applications in rhs_s. + + (KK2b) makes kick-out less aggressive by looking only under type-family applications, + in the case where (fs >= fw), and that made a /huge/ difference to #24944. + +Tricky examples in: #19042, #17672, #24984. The last (#24984) is particular subtle: + + Inert: [W] g1: F a0 ~ F a1 + [W] g2: F a2 ~ F a1 + [W] g3: F a3 ~ F a1 + +Now we add [W] g4: F a1 ~ F a7. Should we kick out g1,g2,g3? No! The +substitution doesn't need to be idempotent, merely terminating. And in #24984 +it turned out that we kept adding one new constraint and kicking out all the +previous inert ones (and that rewriting led to exponentially big constraints due +to lack of contraint sharing.) So we only want to look /under/ type family applications. + +The proof is hard. We start by ignoring flavours. Suppose that: +* We are adding [lhs_w -fw-> rhs_w] to a well-formed, terminating substitution S. +* None of the constraints in S meet the KickOut Criteria. +* Define T = S+[lhs_w -fw-> rhs_w] +* `f` is an arbitrary flavour + +Lemma 1: for any lhs_s in S, T*(f,lhs_s) terminates. + Proof. + * We know that r1 = S*(f,lhs_s) terminates. + * Moreover, we know there are no occurrences of lhs_w under a type family (which + is the head of a LHS) in r1 (KK2)+(WF3). We need (WF3) because you might wonder + what if rhs_s is (F a), and [a --> lhs_w] was in S. But (WF3) prevents that. + * Define r2 = r1{rhs_w/lhs_w}. We know that rhs_w has no occurrences of any lhs in S, + nor of lhs_w. + * Since any occurrence of lhs_w does not occur under a type family, the substitution + won't make any F t1..tn ~ s in S match. + * So r2 is a fixed point of T. + +Lemma 2: T*(f,lhs_w) teminates. + Proof: no occurrences of any LHS in rhs_w. + +Theorem. For any type r, T*(r) terminates. + Proof: + 1. Consider any sub-term of r, which is a LHS of T. + - Rewrite it with T*; this terminates (Lemma 1). + - Do this simultaneously to all sub-terms that match a LHS of T, yielding r1. + 2. Could this new r1 have a sub-term that is an LHS of T? Yes, but only if r has a + sub-term F w, and w rewrote in Step 1 to w' and F w' matches a LHS in T. + 3. Very well: apply step 1 again, but note that /doing so consumes one of the family + applications in the original r/. + 4. After Step 1 either we have reached a fixed point, or we repeat Step 1 consuming at + least one family application of r. + 5. There are only a finite number of family applications in r, so this process terminates. + +Example: + +Inert set: gs : F Int ~ b +Work item: gw : b ~ Int + +F (F (F b)) --[gw]--> F (F (F Int)) --[gs]--> F (F b) + --[gw]--> F (F Int) --[gs]--> F b + --[gw]--> F Int --[gs]--> b + --[gw]--> Int + +Notice that each iteration of Step 1 strips off one of the layers of F, all +of which were in the original r. + +The argument is even more tricky when flavours are involved, and we have not +fleshed it out in detail. + +Note [KK3: completeness of solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(KK3) is not necessary for the extended substitution +to be terminating. In fact (KK0) could be made stronger by saying + ... then (not (fw >= fs) or not (fs >= fs)) +But it's not enough for S to be /terminating/; we also want /completeness/. +That is, we want to be able to solve all soluble wanted equalities. +Suppose we have + work-item b -G-> a + inert-item a -W-> b +Assuming (G >= W) but not (W >= W), this fulfills all the conditions, +so we could extend the inerts, thus: + inert-items b -G-> a + a -W-> b +But if we kicked-out the inert item, we'd get + work-item a -W-> b + inert-item b -G-> a + +Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl. +So we add one more clause (KK3) to the kick-out criteria: + + * (KK3: completeness) + If not(fs >= fw) (KK3a) + * (KK3b) If the role of `fs` is Nominal: + kick out if `rhs_s = lhs_w` + * (KK3c) If the role of `fs` is Representational: + kick out if `rhs_s` is of form `(lhs_w t1 .. tn)` + +Wrinkles: + +* (KK3a) All this can only happen if the work-item can rewrite the inert + one, /but not vice versa/; that is not(fs >= fw). It is useless to kick + out if (fs >= fw) becuase then the work-item is already fully rewritten + by the inert item. And too much kick-out is positively harmful. + (Historical example #14363.) + +* (KK3b) addresses teh main example above for KK3. Another way to understand + (KK3b) is that we treat an inert item + a -f-> b + in the same way as + b -f-> a + So if we kick out one, we should kick out the other. The orientation + is somewhat accidental. + +* (KK3c) When considering roles, we also need the second clause (KK3b). Consider + work-item c -G/N-> a + inert-item a -W/R-> b c + The work-item doesn't get rewritten by the inert, because (>=) doesn't hold. + But we don't kick out the inert item because not (W/R >= W/R). So we just + add the work item. But then, consider if we hit the following: + work-item b -G/N-> Id + inert-items a -W/R-> b c + c -G/N-> a + where + newtype Id x = Id x + + For similar reasons, if we only had (KK3a), we wouldn't kick the + representational inert out. And then, we'd miss solving the inert, which now + reduced to reflexivity. + + The solution here is to kick out representational inerts whenever the lhs of a + work item is "exposed", where exposed means being at the head of the top-level + application chain (lhs t1 .. tn). See head_is_new_lhs. This is encoded in + (KK3c)). + + +Note [Flavours with roles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The system described in Note [inert_eqs: the inert equalities] +discusses an abstract +set of flavours. In GHC, flavours have two components: the flavour proper, +taken from {Wanted, Given} and the equality relation (often called +role), taken from {NomEq, ReprEq}. +When substituting w.r.t. the inert set, +as described in Note [inert_eqs: the inert equalities], +we must be careful to respect all components of a flavour. +For example, if we have + + inert set: a -G/R-> Int + b -G/R-> Bool + + type role T nominal representational + +and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT +T Int Bool. The reason is that T's first parameter has a nominal role, and +thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of +substitution means that the proof in Note [inert_eqs: the inert equalities] may +need to be revisited, but we don't think that the end conclusion is wrong. +-} + +data InertCans -- See Note [Detailed InertCans Invariants] for more + = IC { inert_eqs :: InertEqs + -- See Note [inert_eqs: the inert equalities] + -- All EqCt with a TyVarLHS; index is the LHS tyvar + -- Domain = skolems and untouchables; a touchable would be unified + + , inert_funeqs :: InertFunEqs + -- All EqCt with a TyFamLHS; index is the whole family head type. + -- LHS is fully rewritten (modulo eqCanRewrite constraints) + -- wrt inert_eqs + -- Can include both [G] and [W] + + , inert_dicts :: DictMap DictCt + -- Dictionaries only + -- All fully rewritten (modulo flavour constraints) + -- wrt inert_eqs + + , inert_qcis :: [QCInst] -- See Note [Quantified constraints] + -- in GHC.Tc.Solver.Solve + + , inert_irreds :: InertIrreds + -- Irreducible predicates that cannot be made canonical, + -- and which don't interact with others (e.g. (c a)) + -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) + + , inert_given_eq_lvl :: TcLevel + -- The TcLevel of the innermost implication that has a Given + -- equality of the sort that make a unification variable untouchable + -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). + -- See Note [Tracking Given equalities] + + , inert_given_eqs :: Bool + -- True <=> The inert Givens *at this level* (tcl_tclvl) + -- could includes at least one equality /other than/ a + -- let-bound skolem equality. + -- Reason: report these givens when reporting a failed equality + -- See Note [Tracking Given equalities] + } + +type InertEqs = DTyVarEnv EqualCtList +type InertFunEqs = FunEqMap EqualCtList +type InertIrreds = Bag IrredCt + +instance Outputable InertCans where + ppr (IC { inert_eqs = eqs + , inert_funeqs = funeqs + , inert_dicts = dicts + , inert_irreds = irreds + , inert_given_eq_lvl = ge_lvl + , inert_given_eqs = given_eqs + , inert_qcis = insts }) + + = braces $ vcat + [ ppUnless (isEmptyDVarEnv eqs) $ + text "Equalities =" + <+> pprBag (foldTyEqs consBag eqs emptyBag) + , ppUnless (isEmptyTcAppMap funeqs) $ + text "Type-function equalities =" + <+> pprBag (foldFunEqs consBag funeqs emptyBag) + , ppUnless (isEmptyTcAppMap dicts) $ + text "Dictionaries =" <+> pprBag (dictsToBag dicts) + , ppUnless (isEmptyBag irreds) $ + text "Irreds =" <+> pprBag irreds + , ppUnless (null insts) $ + text "Given instances =" <+> vcat (map ppr insts) + , text "Innermost given equalities =" <+> ppr ge_lvl + , text "Given eqs at this level =" <+> ppr given_eqs + ] + + +{- ********************************************************************* +* * + Inert equalities +* * +********************************************************************* -} + +emptyTyEqs :: InertEqs +emptyTyEqs = emptyDVarEnv + +addEqToCans :: TcLevel -> EqCt -> InertCans -> InertCans +addEqToCans tc_lvl eq_ct@(EqCt { eq_lhs = lhs }) + ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs }) + = updGivenEqs tc_lvl (CEqCan eq_ct) $ + case lhs of + TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys eq_ct } + TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv eq_ct } + +addTyEq :: InertEqs -> TcTyVar -> EqCt -> InertEqs +addTyEq old_eqs tv ct + = extendDVarEnv_C add_eq old_eqs tv [ct] + where + add_eq old_eqs _ = addToEqualCtList ct old_eqs + +foldTyEqs :: (EqCt -> b -> b) -> InertEqs -> b -> b +foldTyEqs k eqs z + = foldDVarEnv (\cts z -> foldr k z cts) z eqs + +findTyEqs :: InertCans -> TyVar -> [EqCt] +findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv) + +delEq :: EqCt -> InertCans -> InertCans +delEq (EqCt { eq_lhs = lhs, eq_rhs = rhs }) ic = case lhs of + TyVarLHS tv + -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv } + TyFamLHS tf args + -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd } + where + isThisOne :: EqCt -> Bool + isThisOne (EqCt { eq_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1 + + upd :: Maybe EqualCtList -> Maybe EqualCtList + upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list + upd Nothing = Nothing + +findEq :: InertCans -> CanEqLHS -> [EqCt] +findEq icans (TyVarLHS tv) = findTyEqs icans tv +findEq icans (TyFamLHS fun_tc fun_args) + = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args) + +{-# INLINE partition_eqs_container #-} +partition_eqs_container + :: forall container + . container -- empty container + -> (forall b. (EqCt -> b -> b) -> container -> b -> b) -- folder + -> (EqCt -> container -> container) -- extender + -> (EqCt -> Bool) + -> container + -> ([EqCt], container) +partition_eqs_container empty_container fold_container extend_container pred orig_inerts + = fold_container folder orig_inerts ([], empty_container) + where + folder :: EqCt -> ([EqCt], container) -> ([EqCt], container) + folder eq_ct (acc_true, acc_false) + | pred eq_ct = (eq_ct : acc_true, acc_false) + | otherwise = (acc_true, extend_container eq_ct acc_false) + +partitionInertEqs :: (EqCt -> Bool) -- EqCt will always have a TyVarLHS + -> InertEqs + -> ([EqCt], InertEqs) +partitionInertEqs = partition_eqs_container emptyTyEqs foldTyEqs addInertEqs + +addInertEqs :: EqCt -> InertEqs -> InertEqs +-- Precondition: CanEqLHS is a TyVarLHS +addInertEqs eq_ct@(EqCt { eq_lhs = TyVarLHS tv }) eqs = addTyEq eqs tv eq_ct +addInertEqs other _ = pprPanic "extendInertEqs" (ppr other) + +-- | Filter InertEqs according to a predicate +filterInertEqs :: (EqCt -> Bool) -> InertEqs -> InertEqs +filterInertEqs f = mapMaybeDVarEnv g + where + g xs = + let filtered = filter f xs + in + if null filtered + then Nothing + else Just filtered + +------------------------ + +addCanFunEq :: InertFunEqs -> TyCon -> [TcType] -> EqCt -> InertFunEqs +addCanFunEq old_eqs fun_tc fun_args ct + = alterTcApp old_eqs fun_tc fun_args upd + where + upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list + upd Nothing = Just [ct] + +foldFunEqs :: (EqCt -> b -> b) -> FunEqMap EqualCtList -> b -> b +foldFunEqs k fun_eqs z = foldTcAppMap (\eqs z -> foldr k z eqs) fun_eqs z + +partitionFunEqs :: (EqCt -> Bool) -- EqCt will have a TyFamLHS + -> InertFunEqs + -> ([EqCt], InertFunEqs) +partitionFunEqs = partition_eqs_container emptyFunEqs foldFunEqs addFunEqs + +addFunEqs :: EqCt -> InertFunEqs -> InertFunEqs +-- Precondition: EqCt is a TyFamLHS +addFunEqs eq_ct@(EqCt { eq_lhs = TyFamLHS tc args }) fun_eqs + = addCanFunEq fun_eqs tc args eq_ct +addFunEqs other _ = pprPanic "extendFunEqs" (ppr other) + +-- | Filter entries in InertFunEqs that satisfy the predicate +filterFunEqs :: (EqCt -> Bool) -> InertFunEqs -> InertFunEqs +filterFunEqs f = mapMaybeTcAppMap g + where + g xs = + let filtered = filter f xs + in + if null filtered + then Nothing + else Just filtered + +{- ********************************************************************* +* * + Inert Dicts +* * +********************************************************************* -} + +-- | Look up a dictionary inert. +lookupInertDict :: InertCans -> Class -> [Type] -> Maybe DictCt +lookupInertDict (IC { inert_dicts = dicts }) cls tys + = findDict dicts cls tys + +-- | Look up a solved inert. +lookupSolvedDict :: InertSet -> Class -> [Type] -> Maybe CtEvidence +-- Returns just if exactly this predicate type exists in the solved. +lookupSolvedDict (IS { inert_solved_dicts = solved }) cls tys + = fmap dictCtEvidence (findDict solved cls tys) + +updDicts :: (DictMap DictCt -> DictMap DictCt) -> InertCans -> InertCans +updDicts upd ics = ics { inert_dicts = upd (inert_dicts ics) } + +delDict :: DictCt -> DictMap a -> DictMap a +delDict (DictCt { di_cls = cls, di_tys = tys }) m + = delTcApp m (classTyCon cls) tys + +addDict :: DictCt -> DictMap DictCt -> DictMap DictCt +addDict item@(DictCt { di_cls = cls, di_tys = tys }) dm + = insertTcApp dm (classTyCon cls) tys item + +addSolvedDict :: DictCt -> DictMap DictCt -> DictMap DictCt +addSolvedDict item@(DictCt { di_cls = cls, di_tys = tys }) dm + = insertTcApp dm (classTyCon cls) tys item + +filterDicts :: (DictCt -> Bool) -> DictMap DictCt -> DictMap DictCt +filterDicts f m = filterTcAppMap f m + +partitionDicts :: (DictCt -> Bool) -> DictMap DictCt -> (Bag DictCt, DictMap DictCt) +partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap) + where + k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) + | otherwise = (yeses, addDict ct noes) + + +{- ********************************************************************* +* * + Inert Irreds +* * +********************************************************************* -} + +addIrredToCans :: TcLevel -> IrredCt -> InertCans -> InertCans +addIrredToCans tc_lvl irred ics + = updGivenEqs tc_lvl (CIrredCan irred) $ + updIrreds (addIrred irred) ics + +addIrreds :: [IrredCt] -> InertIrreds -> InertIrreds +addIrreds extras irreds + | null extras = irreds + | otherwise = irreds `unionBags` listToBag extras + +addIrred :: IrredCt -> InertIrreds -> InertIrreds +addIrred extra irreds = irreds `snocBag` extra + +updIrreds :: (InertIrreds -> InertIrreds) -> InertCans -> InertCans +updIrreds upd ics = ics { inert_irreds = upd (inert_irreds ics) } + +delIrred :: IrredCt -> InertCans -> InertCans +-- Remove a particular (Given) Irred, on the instructions of a plugin +-- For some reason this is done vis the evidence Id, not the type +-- Compare delEq. I have not idea why +delIrred (IrredCt { ir_ev = ev }) ics + = updIrreds (filterBag keep) ics + where + ev_id = ctEvEvId ev + keep (IrredCt { ir_ev = ev' }) = ev_id /= ctEvEvId ev' + +foldIrreds :: (IrredCt -> b -> b) -> InertIrreds -> b -> b +foldIrreds k irreds z = foldr k z irreds + +findMatchingIrreds :: InertIrreds -> CtEvidence + -> (Bag (IrredCt, SwapFlag), InertIrreds) +findMatchingIrreds irreds ev + | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred + -- See Note [Solving irreducible equalities] + = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds + | otherwise + = partitionBagWith match_non_eq irreds + where + pred = ctEvPred ev + match_non_eq irred + | irredCtPred irred `tcEqType` pred = Left (irred, NotSwapped) + | otherwise = Right irred + + match_eq eq_rel1 lty1 rty1 irred + | EqPred eq_rel2 lty2 rty2 <- classifyPredType (irredCtPred irred) + , eq_rel1 == eq_rel2 + , Just swap <- match_eq_help lty1 rty1 lty2 rty2 + = Left (irred, swap) + | otherwise + = Right irred + + match_eq_help lty1 rty1 lty2 rty2 + | lty1 `tcEqType` lty2, rty1 `tcEqType` rty2 + = Just NotSwapped + | lty1 `tcEqType` rty2, rty1 `tcEqType` lty2 + = Just IsSwapped + | otherwise + = Nothing + +{- Note [Solving irreducible equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14333) + [G] a b ~R# c d + [W] c d ~R# a b +Clearly we should be able to solve this! Even though the constraints are +not decomposable. We solve this when looking up the work-item in the +irreducible constraints to look for an identical one. When doing this +lookup, findMatchingIrreds spots the equality case, and matches either +way around. It has to return a swap-flag so we can generate evidence +that is the right way round too. +-} + +{- ********************************************************************* +* * + Adding to and removing from the inert set +* * +* * +********************************************************************* -} + +updGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans +-- Set the inert_given_eq_level to the current level (tclvl) +-- if the constraint is a given equality that should prevent +-- filling in an outer unification variable. +-- See Note [Tracking Given equalities] +-- +-- Precondition: Ct is either CEqCan or CIrredCan +updGivenEqs tclvl ct inerts + | not (isGivenCt ct) = inerts + + -- See Note [Let-bound skolems] + | isLetBoundSkolemCt tclvl ct = inerts { inert_given_eqs = True } + + -- At this point we are left with a constraint that either + -- is an equality (F a ~ ty), or /might/ be, like (c a) + | otherwise = inerts { inert_given_eq_lvl = tclvl + , inert_given_eqs = True } + +isLetBoundSkolemCt :: TcLevel -> Ct -> Bool +-- See Note [Let-bound skolems] +isLetBoundSkolemCt tclvl (CEqCan (EqCt { eq_lhs = lhs, eq_rhs = rhs })) + = case lhs of + TyVarLHS tv -> not (isOuterTyVar tclvl tv) + TyFamLHS {} -> case getTyVar_maybe rhs of + Just tv -> not (isOuterTyVar tclvl tv) + Nothing -> False +isLetBoundSkolemCt _ _ = False + +data KickOutSpec -- See Note [KickOutSpec] + = KOAfterUnify TcTyVarSet -- We have unified these tyvars + | KOAfterAdding CanEqLHS -- We are adding to the inert set a canonical equality + -- constraint with this LHS + +instance Outputable KickOutSpec where + ppr (KOAfterUnify tvs) = text "KOAfterUnify" <> ppr tvs + ppr (KOAfterAdding lhs) = text "KOAfterAdding" <> parens (ppr lhs) + +{- Note [KickOutSpec] +~~~~~~~~~~~~~~~~~~~~~~ +KickOutSpec explains why we are kicking out. + +Important property: + KOAfterAdding (TyVarLHS tv) should behave exactly like + KOAfterUnifying (unitVarSet tv) + +The main reasons for treating the two separately are +* More efficient in the single-tyvar case +* The code is far more perspicuous +-} + +data WhereToLook = LookEverywhere | LookOnlyUnderFamApps + deriving( Eq ) + +kickOutRewritableLHS :: KickOutSpec -> CtFlavourRole -> InertCans -> (Cts, InertCans) +-- See Note [kickOutRewritable] +kickOutRewritableLHS ko_spec new_fr@(_, new_role) + ics@(IC { inert_eqs = tv_eqs + , inert_dicts = dictmap + , inert_funeqs = funeqmap + , inert_irreds = irreds + , inert_qcis = old_insts }) + = (kicked_out, inert_cans_in) + where + inert_cans_in = ics { inert_eqs = tv_eqs_in + , inert_dicts = dicts_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in + , inert_qcis = insts_in } + + kicked_out :: Cts + kicked_out = (fmap CDictCan dicts_out `andCts` fmap CIrredCan irs_out) + `extendCtsList` insts_out + `extendCtsList` map CEqCan tv_eqs_out + `extendCtsList` map CEqCan feqs_out + + (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs + (feqs_out, feqs_in) = partitionFunEqs kick_out_eq funeqmap + (dicts_out, dicts_in) = partitionDicts kick_out_dict dictmap + (irs_out, irs_in) = partitionBag kick_out_irred irreds + -- Kick out even insolubles: See Note [Rewrite insolubles] + -- Of course we must kick out irreducibles like (c a), in case + -- we can rewrite 'c' to something more useful + + -- Kick-out for inert instances + -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve + insts_out :: [Ct] + insts_in :: [QCInst] + (insts_out, insts_in) + | fr_may_rewrite (Given, NomEq) -- All the insts are Givens + = partitionWith kick_out_qci old_insts + | otherwise + = ([], old_insts) + kick_out_qci qci + | let ev = qci_ev qci + , fr_can_rewrite_ty LookEverywhere NomEq (ctEvPred (qci_ev qci)) + = Left (mkNonCanonical ev) + | otherwise + = Right qci + + fr_tv_can_rewrite_ty :: WhereToLook -> (TyVar -> Bool) -> EqRel -> Type -> Bool + fr_tv_can_rewrite_ty where_to_look check_tv role ty + = anyRewritableTyVar role can_rewrite ty + where + can_rewrite :: UnderFam -> EqRel -> TyVar -> Bool + can_rewrite is_under_famapp old_role tv + = (where_to_look == LookEverywhere || is_under_famapp) && + new_role `eqCanRewrite` old_role && check_tv tv + + fr_tf_can_rewrite_ty :: WhereToLook -> TyCon -> [TcType] -> EqRel -> Type -> Bool + fr_tf_can_rewrite_ty where_to_look new_tf new_tf_args role ty + = anyRewritableTyFamApp role can_rewrite ty + where + can_rewrite :: UnderFam -> EqRel -> TyCon -> [TcType] -> Bool + can_rewrite is_under_famapp old_role old_tf old_tf_args + = (where_to_look == LookEverywhere || is_under_famapp) && + new_role `eqCanRewrite` old_role && + tcEqTyConApps new_tf new_tf_args old_tf old_tf_args + -- it's possible for old_tf_args to have too many. This is fine; + -- we'll only check what we need to. + + + fr_can_rewrite_ty :: WhereToLook -> EqRel -> Type -> Bool + -- UnderFam = True <=> look only under type-family applications + fr_can_rewrite_ty uf = case ko_spec of -- See Note [KickOutSpec] + KOAfterUnify tvs -> fr_tv_can_rewrite_ty uf (`elemVarSet` tvs) + KOAfterAdding (TyVarLHS tv) -> fr_tv_can_rewrite_ty uf (== tv) + KOAfterAdding (TyFamLHS tf tf_args) -> fr_tf_can_rewrite_ty uf tf tf_args + + fr_may_rewrite :: CtFlavourRole -> Bool + fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs + -- Can the new item rewrite the inert item? + + kick_out_dict :: DictCt -> Bool + -- Kick it out if the new CEqCan can rewrite the inert one + -- See Note [kickOutRewritable] + kick_out_dict (DictCt { di_tys = tys, di_ev = ev }) + = fr_may_rewrite (ctEvFlavour ev, NomEq) + && any (fr_can_rewrite_ty LookEverywhere NomEq) tys + + kick_out_irred :: IrredCt -> Bool + kick_out_irred (IrredCt { ir_ev = ev }) + = fr_may_rewrite (ctEvFlavour ev, eq_rel) + && fr_can_rewrite_ty LookEverywhere eq_rel pred + where + pred = ctEvPred ev + eq_rel = predTypeEqRel pred + + -- Implements criteria K1-K3 in Note [Extending the inert equalities] + kick_out_eq :: EqCt -> Bool + kick_out_eq (EqCt { eq_lhs = lhs, eq_rhs = rhs_ty + , eq_ev = ev, eq_eq_rel = eq_rel }) + + -- (KK0) Keep it in the inert set if the new thing can't rewrite it + | not (fr_may_rewrite fs) + = False + + -- Below here (fr_may_rewrite fs) is True + + -- (KK1) + | fr_can_rewrite_ty LookEverywhere eq_rel (canEqLHSType lhs) + = True -- (KK1) + -- The above check redundantly checks the role & flavour, + -- but it's very convenient + + -- (KK2) + | let where_to_look | fs_can_rewrite_fr = LookOnlyUnderFamApps + | otherwise = LookEverywhere + , fr_can_rewrite_ty where_to_look eq_rel rhs_ty + = True + + -- (KK3) + | not fs_can_rewrite_fr -- (KK3a) + , case eq_rel of + NomEq -> is_new_lhs rhs_ty -- (KK3b) + ReprEq -> head_is_new_lhs rhs_ty -- (KK3c) + = True + + | otherwise = False + + where + fs_can_rewrite_fr = fs `eqCanRewriteFR` new_fr + fs = (ctEvFlavour ev, eq_rel) + + is_new_lhs :: Type -> Bool + is_new_lhs = case ko_spec of -- See Note [KickOutSpec] + KOAfterUnify tvs -> is_tyvar_ty_for tvs + KOAfterAdding lhs -> (`eqType` canEqLHSType lhs) + + is_tyvar_ty_for :: TcTyVarSet -> Type -> Bool + -- True if the type is equal to one of the tyvars + is_tyvar_ty_for tvs ty + = case getTyVar_maybe ty of + Nothing -> False + Just tv -> tv `elemVarSet` tvs + + head_is_new_lhs :: Type -> Bool + head_is_new_lhs = case ko_spec of -- See Note [KickOutSpec] + KOAfterUnify tvs -> tv_at_head (`elemVarSet` tvs) + KOAfterAdding (TyVarLHS tv) -> tv_at_head (== tv) + KOAfterAdding (TyFamLHS tf tf_args) -> fam_at_head tf tf_args + + tv_at_head :: (TyVar -> Bool) -> Type -> Bool + tv_at_head is_tv = go + where + go (Rep.TyVarTy tv) = is_tv tv + go (Rep.AppTy fun _) = go fun + go (Rep.CastTy ty _) = go ty + go (Rep.TyConApp {}) = False + go (Rep.LitTy {}) = False + go (Rep.ForAllTy {}) = False + go (Rep.FunTy {}) = False + go (Rep.CoercionTy {}) = False + + fam_at_head :: TyCon -> [Type] -> Type -> Bool + fam_at_head fun_tc fun_args = go + where + go (Rep.TyVarTy {}) = False + go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy + go (Rep.CastTy ty _) = go ty + go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args + go (Rep.LitTy {}) = False + go (Rep.ForAllTy {}) = False + go (Rep.FunTy {}) = False + go (Rep.CoercionTy {}) = False + +{- Note [kickOutRewritable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [inert_eqs: the inert equalities]. + +When we add a new inert equality (lhs ~N ty) to the inert set, +we must kick out any inert items that could be rewritten by the +new equality, to maintain the inert-set invariants. + + - We want to kick out an existing inert constraint if + a) the new constraint can rewrite the inert one + b) 'lhs' is free in the inert constraint (so that it *will*) + rewrite it if we kick it out. + + For (b) we use anyRewritableCanLHS, which examines the types /and + kinds/ that are directly visible in the type. Hence + we will have exposed all the rewriting we care about to make the + most precise kinds visible for matching classes etc. No need to + kick out constraints that mention type variables whose kinds + contain this LHS! + + - We don't kick out constraints from inert_solved_dicts, and + inert_solved_funeqs optimistically. But when we lookup we have to + take the substitution into account + +NB: we could in principle avoid kick-out: + a) When unifying a meta-tyvar from an outer level, because + then the entire implication will be iterated; see + Note [The Unification Level Flag] in GHC.Tc.Solver.Monad. + + b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType + Note [TcLevel invariants], a Given can't include a meta-tyvar from + its own level, so it falls under (a). Of course, we must still + kick out Givens when adding a new non-unification Given. + +But kicking out more vigorously may lead to earlier unification and fewer +iterations, so we don't take advantage of these possibilities. + +Note [Rewrite insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an insoluble alpha ~ [alpha], which is insoluble +because an occurs check. And then we unify alpha := [Int]. Then we +really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can +be decomposed. Otherwise we end up with a "Can't match [Int] ~ +[[Int]]" which is true, but a bit confusing because the outer type +constructors match. + +Hence: + * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, + simpl_loop), we feed the insolubles in solveSimpleWanteds, + so that they get rewritten (albeit not solved). + + * We kick insolubles out of the inert set, if they can be + rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) + + * We rewrite those insolubles in GHC.Tc.Solver.Equality + See Note [Make sure that insolubles are fully rewritten] + in GHC.Tc.Solver.Equality +-} + +{- ********************************************************************* +* * + Queries +* * +* * +********************************************************************* -} + +isOuterTyVar :: TcLevel -> TyCoVar -> Bool +-- True of a type variable that comes from a +-- shallower level than the ambient level (tclvl) +isOuterTyVar tclvl tv + | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $ + tclvl `strictlyDeeperThan` tcTyVarLevel tv + -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from + -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't + -- be a touchable meta tyvar. If this wasn't true, you might worry that, + -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby + -- becomes "outer" even though its level numbers says it isn't. + | otherwise = False -- Coercion variables; doesn't much matter + +noGivenNewtypeReprEqs :: TyCon -> InertSet -> Bool +-- True <=> there is no Given looking like (N tys1 ~ N tys2) +-- See Note [Decomposing newtype equalities] (EX3) in GHC.Tc.Solver.Equality +noGivenNewtypeReprEqs tc (IS { inert_cans = inerts }) + | IC { inert_irreds = irreds, inert_qcis = quant_cts } <- inerts + = not (anyBag might_help_irred irreds || any might_help_qc quant_cts) + -- Look in both inert_irreds /and/ inert_qcis (#26020) + where + might_help_irred (IrredCt { ir_ev = ev }) + | EqPred ReprEq t1 t2 <- classifyPredType (ctEvPred ev) + = headed_by_tc t1 t2 + | otherwise + = False + + might_help_qc (QCI { qci_ev = ev, qci_body = pred }) + | isGiven ev + , ClassPred cls [_, t1, t2] <- classifyPredType pred + , cls `hasKey` coercibleTyConKey + = headed_by_tc t1 t2 + | otherwise + = False + + headed_by_tc t1 t2 + | Just (tc1,_) <- tcSplitTyConApp_maybe t1 + , tc == tc1 + , Just (tc2,_) <- tcSplitTyConApp_maybe t2 + , tc == tc2 + = True + | otherwise + = False + +-- | Is it (potentially) loopy to use the first @ct1@ to solve @ct2@? +-- +-- Necessary (but not sufficient) conditions for this function to return @True@: +-- +-- - @ct1@ and @ct2@ both arise from superclass expansion, +-- - @ct1@ is a Given and @ct2@ is a Wanted. +-- +-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance, (sc2). +prohibitedSuperClassSolve :: CtLoc -- ^ is it loopy to use this one ... + -> CtLoc -- ^ ... to solve this one? + -> Bool -- ^ True ==> don't solve it +prohibitedSuperClassSolve given_loc wanted_loc + | GivenSCOrigin _ _ blocked <- ctLocOrigin given_loc + , blocked + , ScOrigin _ NakedSc <- ctLocOrigin wanted_loc + = True -- Prohibited if the Wanted is a superclass + -- and the Given has come via a superclass selection from + -- a predicate bigger than the head + | otherwise + = False + + +{- ********************************************************************* +* * + Cycle breakers +* * +********************************************************************* -} + +-- | Push a fresh environment onto the cycle-breaker var stack. Useful +-- when entering a nested implication. +pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack +pushCycleBreakerVarStack = (emptyBag <|) + +-- | Add a new cycle-breaker binding to the top environment on the stack. +addCycleBreakerBindings :: Bag (TcTyVar, Type) -- ^ (cbv,expansion) pairs + -> InertSet -> InertSet +addCycleBreakerBindings prs ics + = assertPpr (all (isCycleBreakerTyVar . fst) prs) (ppr prs) $ + ics { inert_cycle_breakers = add_to (inert_cycle_breakers ics) } + where + add_to (top_env :| rest_envs) = (prs `unionBags` top_env) :| rest_envs + +-- | Perform a monadic operation on all pairs in the top environment +-- in the stack. +forAllCycleBreakerBindings_ :: Monad m + => CycleBreakerVarStack + -> (TcTyVar -> TcType -> m ()) -> m () +forAllCycleBreakerBindings_ (top_env :| _rest_envs) action + = forM_ top_env (uncurry action) +{-# INLINABLE forAllCycleBreakerBindings_ #-} -- to allow SPECIALISE later + + +{- ********************************************************************* +* * + Solving one from another +* * +********************************************************************* -} + +data InteractResult + = KeepInert -- Keep the inert item, and solve the work item from it + -- (if the latter is Wanted; just discard it if not) + | KeepWork -- Keep the work item, and solve the inert item from it + +instance Outputable InteractResult where + ppr KeepInert = text "keep inert" + ppr KeepWork = text "keep work-item" + +solveOneFromTheOther :: Ct -- Inert (Dict or Irred) + -> Ct -- WorkItem (same predicate as inert) + -> InteractResult +-- Precondition: +-- * inert and work item represent evidence for the /same/ predicate +-- * Both are CDictCan or CIrredCan +-- +-- We can always solve one from the other: even if both are wanted, +-- although we don't rewrite wanteds with wanteds, we can combine +-- two wanteds into one by solving one from the other +-- +-- Compare the corresponding function for equalities: +-- GHC.Tc.Solver.Equality.inertEqsCanDischarge + +solveOneFromTheOther ct_i ct_w + | CtWanted {} <- ev_w + , prohibitedSuperClassSolve loc_i loc_w + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + = -- Inert must be Given + KeepWork + + | CtWanted (WantedCt { ctev_rewriters = rw_w }) <- ev_w + = -- Inert is Given or Wanted + case ev_i of + CtGiven {} -> KeepInert + -- work is Wanted; inert is Given: easy choice. + + CtWanted (WantedCt { ctev_rewriters = rw_i }) -- Both are Wanted + -- If only one has no pending superclasses, use it + -- Otherwise we can get infinite superclass expansion (#22516) + -- in silly cases like class C T b => C a b where ... + | Just res <- better (not is_psc_i) (not is_psc_w) + -> res + + -- If only one has an empty rewriter set, use it + -- c.f. GHC.Tc.Solver.Equality.inertsCanDischarge, and especially + -- (CE4) in Note [Combining equalities] + | Just res <- better (isEmptyRewriterSet rw_i) (isEmptyRewriterSet rw_w) + -> res + + -- If only one is a WantedSuperclassOrigin (arising from expanding + -- a Wanted class constraint), keep the other: wanted superclasses + -- may be unexpected by users + | Just res <- better (not is_wsc_orig_i) (not is_wsc_orig_w) + -> res + + -- Otherwise, just choose the lower span + -- reason: if we have something like (abs 1) (where the + -- Num constraint cannot be satisfied), it's better to + -- get an error about abs than about 1. + -- This test might become more elaborate if we see an + -- opportunity to improve the error messages + | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert + + | otherwise -> KeepWork + + -- From here on the work-item is Given + + | CtWanted {} <- ev_i + , prohibitedSuperClassSolve loc_w loc_i + = KeepInert -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first + + | CtWanted {} <- ev_i + = KeepWork + + -- From here on both are Given + -- See Note [Replacement vs keeping] + + | lvl_i `sameDepthAs` lvl_w + = same_level_strategy + + | otherwise -- Both are Given, levels differ + = different_level_strategy + where + better :: Bool -> Bool -> Maybe InteractResult + -- (better inert-is-good wanted-is-good) returns + -- Just KeepWork if wanted is strictly better than inert + -- Just KeepInert if inert is strictly better than wanted + -- Nothing if they are the same + better True False = Just KeepInert + better False True = Just KeepWork + better _ _ = Nothing + + ev_i = ctEvidence ct_i + ev_w = ctEvidence ct_w + + pred = ctEvPred ev_i + + loc_i = ctEvLoc ev_i + loc_w = ctEvLoc ev_w + orig_i = ctLocOrigin loc_i + orig_w = ctLocOrigin loc_w + lvl_i = ctLocLevel loc_i + lvl_w = ctLocLevel loc_w + + is_psc_w = isPendingScDict ct_w + is_psc_i = isPendingScDict ct_i + + is_wsc_orig_i = isWantedSuperclassOrigin orig_i + is_wsc_orig_w = isWantedSuperclassOrigin orig_w + + different_level_strategy -- Both Given + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork + -- See Note [Replacement vs keeping] part (1) + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters] + -- in GHC.Tc.Solver.Dict + + same_level_strategy -- Both Given + = case (orig_i, orig_w) of + + (GivenSCOrigin _ depth_i blocked_i, GivenSCOrigin _ depth_w blocked_w) + | blocked_i, not blocked_w -> KeepWork -- Case 2(a) from + | not blocked_i, blocked_w -> KeepInert -- Note [Replacement vs keeping] + + -- Both blocked or both not blocked + + | depth_w < depth_i -> KeepWork -- Case 2(c) from + | otherwise -> KeepInert -- Note [Replacement vs keeping] + + (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] + + _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] + +{- +Note [Replacement vs keeping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have two Given constraints both of type (C tys), say, which should +we keep? More subtle than you might think! This is all implemented in +solveOneFromTheOther. + + 1) Constraints come from different levels (different_level_strategy) + + - For implicit parameters we want to keep the innermost (deepest) + one, so that it overrides the outer one. + See Note [Shadowing of implicit parameters] in GHC.Tc.Solver.Dict + + - For everything else, we want to keep the outermost one. Reason: that + makes it more likely that the inner one will turn out to be unused, + and can be reported as redundant. See Note [Tracking redundant constraints] + in GHC.Tc.Solver. + + It transpires that using the outermost one is responsible for an + 8% performance improvement in nofib cryptarithm2, compared to + just rolling the dice. I didn't investigate why. + + 2) Constraints coming from the same level (i.e. same implication) + + (a) If both are GivenSCOrigin, choose the one that is unblocked if possible + according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. + + (b) Prefer constraints that are not superclass selections. See + (TRC3) in Note [Tracking redundant constraints] in GHC.Tc.Solver. + + (c) If both are GivenSCOrigin, chooose the one with the shallower + superclass-selection depth, in the hope of identifying more correct + redundant constraints. This is really a generalization of point (b), + because the superclass depth of a non-superclass constraint is 0. + + (If the levels differ, we definitely won't have both with GivenSCOrigin.) + + (d) Finally, when there is still a choice, use KeepInert rather than + KeepWork, for two reasons: + - to avoid unnecessary munging of the inert set. + - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Dict + +Doing the level-check for implicit parameters, rather than making the work item +always override, is important. Consider + + data T a where { T1 :: (?x::Int) => T Int; T2 :: T a } + + f :: (?x::a) => T a -> Int + f T1 = ?x + f T2 = 3 + +We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add +two new givens in the work-list: [G] (?x::Int) + [G] (a ~ Int) +Now consider these steps + - process a~Int, kicking out (?x::a) + - process (?x::Int), the inner given, adding to inert set + - process (?x::a), the outer given, overriding the inner given +Wrong! The level-check ensures that the inner implicit parameter wins. +(Actually I think that the order in which the work-list is processed means +that this chain of events won't happen, but that's very fragile.) +-} + diff --git a/GHC/Tc/Solver/Irred.hs b/GHC/Tc/Solver/Irred.hs --- a/GHC/Tc/Solver/Irred.hs +++ b/GHC/Tc/Solver/Irred.hs @@ -39,10 +39,6 @@ ; simpleStage (updInertIrreds irred) ; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" } -updInertIrreds :: IrredCt -> TcS () -updInertIrreds irred - = do { tc_lvl <- getTcLevel - ; updInertCans $ addIrredToCans tc_lvl irred } {- ********************************************************************* * * @@ -73,9 +69,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 () } } diff --git a/GHC/Tc/Solver/Monad.hs b/GHC/Tc/Solver/Monad.hs --- a/GHC/Tc/Solver/Monad.hs +++ b/GHC/Tc/Solver/Monad.hs @@ -1,2264 +1,2420 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - --- | Monadic definitions for the constraint solver -module GHC.Tc.Solver.Monad ( - - -- The TcS monad - TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts, - failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, - runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, - emitImplicationTcS, emitTvImplicationTcS, - emitFunDepWanteds, - - selectNextWorkItem, - getWorkList, - updWorkListTcS, - pushLevelNoWorkList, - - runTcPluginTcS, recordUsedGREs, - matchGlobalInst, TcM.ClsInstResult(..), - - QCInst(..), - - -- The pipeline - StopOrContinue(..), continueWith, stopWith, - startAgainWith, SolverStage(Stage, runSolverStage), simpleStage, - stopWithStage, - - -- Tracing etc - panicTcS, traceTcS, tryEarlyAbortTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - resetUnificationFlag, setUnificationFlag, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvExpr, - - newTcEvBinds, newNoTcEvBinds, - newWantedEq, emitNewWantedEq, - newWanted, - newWantedNC, newWantedEvVarNC, - newBoundEvVarId, - unifyTyVar, reportUnifications, touchabilityAndShapeTest, - setEvBind, setWantedEq, - setWantedEvTerm, setEvBindIfWanted, - newEvVar, newGivenEvVar, emitNewGivens, - checkReductionDepth, - getSolvedDicts, setSolvedDicts, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, setSrcSpan, - getTcEvBindsVar, getTcLevel, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - tcLookupClass, tcLookupId, tcLookupTyCon, - - - -- Inerts - updInertSet, updInertCans, - getHasGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, getInnermostGivenEqLevel, - getInertSet, setInertSet, - getUnsolvedInerts, - removeInertCts, getPendingGivenScs, - insertFunEq, addInertForAll, - emitWorkNC, emitWork, - lookupInertDict, - - -- The Model - kickOutAfterUnification, kickOutRewritable, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert solved dictionaries - updSolvedDicts, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The family application cache - lookupFamAppInert, lookupFamAppCache, extendFamAppCache, - pprKicked, - - -- Instantiation - instDFunType, - - -- Unification - wrapUnifierTcS, unifyFunDeps, uPairsTcM, - - -- MetaTyVars - newFlexiTcSTy, instFlexiX, - cloneMetaTyVar, - tcInstSkolTyVarsX, - - TcLevel, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, - zonkTyCoVarsAndFVList, - zonkSimples, zonkWC, - zonkTyCoVarKind, - - -- References - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- Misc - getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, matchFamTcM, - checkWellStagedDFun, - pprEq, - - -- Enforcing invariants for type equalities - checkTypeEq, checkTouchableTyVarEq -) where - -import GHC.Prelude - -import GHC.Driver.Env - -import qualified GHC.Tc.Utils.Instantiate as TcM -import GHC.Core.InstEnv -import GHC.Tc.Instance.Family as FamInst -import GHC.Core.FamInstEnv - -import qualified GHC.Tc.Utils.Monad as TcM -import qualified GHC.Tc.Utils.TcMType as TcM -import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) -import qualified GHC.Tc.Utils.Env as TcM - ( checkWellStaged, tcGetDefaultTys - , tcLookupClass, tcLookupId, tcLookupTyCon - , topIdLvl ) -import GHC.Tc.Zonk.Monad ( ZonkM ) -import qualified GHC.Tc.Zonk.TcType as TcM -import qualified GHC.Tc.Zonk.Type as TcM - -import GHC.Driver.DynFlags - -import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon ) -import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) -import GHC.Tc.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.Types -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.Unify - -import GHC.Builtin.Names ( unsatisfiableClassNameKey ) - -import GHC.Core.Type -import GHC.Core.TyCo.Rep as Rep -import GHC.Core.Coercion -import GHC.Core.Coercion.Axiom( TypeEqn ) -import GHC.Core.Predicate -import GHC.Core.Reduction -import GHC.Core.Class -import GHC.Core.TyCon - -import GHC.Types.Name -import GHC.Types.TyThing -import GHC.Types.Name.Reader -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 ) -import qualified GHC.Rename.Env as TcM - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Logger -import GHC.Utils.Misc (HasDebugCallStack) - -import GHC.Data.Bag as Bag -import GHC.Data.Pair - -import GHC.Utils.Monad - -import GHC.Exts (oneShot) -import Control.Monad -import Data.IORef -import Data.List ( mapAccumL ) -import Data.Foldable -import qualified Data.Semigroup as S -import GHC.Types.SrcLoc -import GHC.Rename.Env - -#if defined(DEBUG) -import GHC.Types.Unique.Set (nonDetEltsUniqSet) -import GHC.Data.Graph.Directed -#endif - -{- ********************************************************************* -* * - SolverStage and StopOrContinue -* * -********************************************************************* -} - -{- Note [The SolverStage monad] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The SolverStage monad allows us to write simple code like that in -GHC.Tc.Solver.solveEquality. At the time of writing it looked like -this (may get out of date but the idea is clear): - -solveEquality :: ... -> SolverStage Void -solveEquality ev eq_rel ty1 ty2 - = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 - ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2' - ; case mb_canon of { - Left irred_ct -> do { tryQCsIrredEqCt irred_ct - ; solveIrred irred_ct } ; - Right eq_ct -> do { tryInertEqs eq_ct - ; tryFunDeps eq_ct - ; tryQCsEqCt eq_ct - ; simpleStage (updInertEqs eq_ct) - ; stopWithStage (eqCtEvidence eq_ct) ".." }}} - -Each sub-stage can elect to - (a) ContinueWith: continue to the next stasge - (b) StartAgain: start again at the beginning of the pipeline - (c) Stop: stop altogether; constraint is solved - -These three possiblities are described by the `StopOrContinue` data type. -The `SolverStage` monad does the plumbing. - -Notes: - -(SM1) Each individual stage pretty quickly drops down into - TcS (StopOrContinue a) - because the monadic plumbing of `SolverStage` is relatively ineffienct, - with that three-way split. - -(SM2) We use `SolverStage Void` to express the idea that ContinueWith is - impossible; we don't need to pattern match on it as a possible outcome:A - see GHC.Tc.Solver.Solve.solveOne. To that end, ContinueWith is strict. --} - -data StopOrContinue a - = StartAgain Ct -- Constraint is not solved, but some unifications - -- happened, so go back to the beginning of the pipeline - - | ContinueWith !a -- The constraint was not solved, although it may have - -- been rewritten. It is strict so that - -- ContinueWith Void can't happen; see (SM2) in - -- Note [The SolverStage monad] - - | Stop CtEvidence -- The (rewritten) constraint was solved - SDoc -- Tells how it was solved - -- Any new sub-goals have been put on the work list - deriving (Functor) - -instance Outputable a => Outputable (StopOrContinue a) where - ppr (Stop ev s) = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev) - ppr (ContinueWith w) = text "ContinueWith" <+> ppr w - ppr (StartAgain w) = text "StartAgain" <+> ppr w - -newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) } - deriving( Functor ) - -instance Applicative SolverStage where - pure x = Stage (return (ContinueWith x)) - (<*>) = ap - -instance Monad SolverStage where - return = pure - (Stage m) >>= k = Stage $ - do { soc <- m - ; case soc of - StartAgain x -> return (StartAgain x) - Stop ev d -> return (Stop ev d) - ContinueWith x -> runSolverStage (k x) } - -simpleStage :: TcS a -> SolverStage a --- Always does a ContinueWith; no Stop or StartAgain -simpleStage thing = Stage (do { res <- thing; continueWith res }) - -startAgainWith :: Ct -> TcS (StopOrContinue a) -startAgainWith ct = return (StartAgain ct) - -continueWith :: a -> TcS (StopOrContinue a) -continueWith ct = return (ContinueWith ct) - -stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) -stopWith ev s = return (Stop ev (text s)) - -stopWithStage :: CtEvidence -> String -> SolverStage a -stopWithStage ev s = Stage (stopWith ev s) - - -{- ********************************************************************* -* * - Inert instances: inert_insts -* * -********************************************************************* -} - -addInertForAll :: QCInst -> TcS () --- Add a local Given instance, typically arising from a type signature -addInertForAll new_qci - = do { ics <- getInertCans - ; ics1 <- add_qci ics - - -- Update given equalities. C.f updateGivenEqs - ; tclvl <- getTcLevel - ; let pred = qci_pred new_qci - not_equality = isClassPred pred && not (isEqPred pred) - -- True <=> definitely not an equality - -- A qci_pred like (f a) might be an equality - - ics2 | not_equality = ics1 - | otherwise = ics1 { inert_given_eq_lvl = tclvl - , inert_given_eqs = True } - - ; setInertCans ics2 } - where - add_qci :: InertCans -> TcS InertCans - -- See Note [Do not add duplicate quantified instances] - add_qci ics@(IC { inert_insts = qcis }) - | any same_qci qcis - = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) - ; return ics } - - | otherwise - = do { traceTcS "adding new inert quantified instance" (ppr new_qci) - ; return (ics { inert_insts = new_qci : qcis }) } - - same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) - (ctEvPred (qci_ev new_qci)) - -{- Note [Do not add duplicate quantified instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As an optimisation, we avoid adding duplicate quantified instances to the -inert set; we use a simple duplicate check using tcEqType for simplicity, -even though it doesn't account for superficial differences, e.g. it will count -the following two constraints as different (#22223): - - - forall a b. C a b - - forall b a. C a b - -The main logic that allows us to pick local instances, even in the presence of -duplicates, is explained in Note [Use only the best matching quantified constraint] -in GHC.Tc.Solver.Dict. --} - -{- ********************************************************************* -* * - Kicking out -* * -************************************************************************ --} - - ------------------------------------------ -kickOutRewritable :: KickOutSpec -> CtFlavourRole -> TcS () -kickOutRewritable ko_spec new_fr - = do { ics <- getInertCans - ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics - n_kicked = lengthBag kicked_out - ; setInertCans ics' - - ; unless (isEmptyBag kicked_out) $ - do { emitWork kicked_out - - -- The famapp-cache contains Given evidence from the inert set. - -- If we're kicking out Givens, we need to remove this evidence - -- from the cache, too. - ; let kicked_given_ev_vars = foldr add_one emptyVarSet kicked_out - add_one :: Ct -> VarSet -> VarSet - add_one ct vs | CtGiven { ctev_evar = ev_var } <- ctEvidence ct - = vs `extendVarSet` ev_var - | otherwise = vs - - ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && - -- if this isn't true, no use looking through the constraints - not (isEmptyVarSet kicked_given_ev_vars)) $ - do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" - (ppr kicked_given_ev_vars) - ; dropFromFamAppCache kicked_given_ev_vars } - - ; csTraceTcS $ - hang (text "Kick out") - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } } - -kickOutAfterUnification :: [TcTyVar] -> TcS () -kickOutAfterUnification tvs - | null tvs - = return () - | otherwise - = do { let tv_set = mkVarSet tvs - - ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq) - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - -- Set the unification flag if we have done outer unifications - -- that might affect an earlier implication constraint - ; let min_tv_lvl = foldr1 minTcLevel (map tcTyVarLevel tvs) - ; ambient_lvl <- getTcLevel - ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $ - setUnificationFlag min_tv_lvl - - ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked) - ; return n_kicked } - -kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () --- See Wrinkle (EIK2a) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Equality --- It's possible that this could just go ahead and unify, but could there be occurs-check --- problems? Seems simpler just to kick out. -kickOutAfterFillingCoercionHole hole - = do { ics <- getInertCans - ; let (kicked_out, ics') = kick_out ics - n_kicked = lengthBag kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (extendWorkListCts (fmap CIrredCan kicked_out)) - ; csTraceTcS $ - hang (text "Kick out, hole =" <+> ppr hole) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; setInertCans ics' } - where - kick_out :: InertCans -> (Bag IrredCt, InertCans) - kick_out ics@(IC { inert_irreds = irreds }) - = -- We only care about irreds here, because any constraint blocked - -- by a coercion hole is an irred. See wrinkle (EIK2a) in - -- Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical - (irreds_to_kick, ics { inert_irreds = irreds_to_keep }) - where - (irreds_to_kick, irreds_to_keep) = partitionBag kick_ct irreds - - kick_ct :: IrredCt -> Bool - -- True: kick out; False: keep. - kick_ct ct - | IrredCt { ir_ev = ev, ir_reason = reason } <- ct - , CtWanted { ctev_rewriters = RewriterSet rewriters } <- ev - , NonCanonicalReason ctyeq <- reason - , ctyeq `cterHasProblem` cteCoercionHole - , hole `elementOfUniqSet` rewriters - = True - | otherwise - = False - --------------- -addInertSafehask :: InertCans -> DictCt -> InertCans -addInertSafehask ics item - = ics { inert_safehask = addDict item (inert_dicts ics) } - -insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> TcS () --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -insertSafeOverlapFailureTcS what item - | safeOverlap what = return () - | otherwise = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS (Bag DictCt) --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -getSafeOverlapFailures - = do { IC { inert_safehask = safehask } <- getInertCans - ; return $ foldDicts consBag safehask emptyBag } - --------------- -updSolvedDicts :: InstanceWhat -> DictCt -> TcS () --- Conditionally add a new item in the solved set of the monad --- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet -updSolvedDicts what dict_ct@(DictCt { di_ev = ev }) - | isWanted ev - , instanceReturnsDictCon what - = do { traceTcS "updSolvedDicts:" $ ppr dict_ct - ; updInertSet $ \ ics -> - ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } } - | otherwise - = return () - -getSolvedDicts :: TcS (DictMap DictCt) -getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) } - -setSolvedDicts :: DictMap DictCt -> TcS () -setSolvedDicts solved_dicts - = updInertSet $ \ ics -> - ics { inert_solved_dicts = solved_dicts } - -{- ********************************************************************* -* * - Other inert-set operations -* * -********************************************************************* -} - -updInertSet :: (InertSet -> InertSet) -> TcS () --- Modify the inert set with the supplied function -updInertSet upd_fn - = do { is_var <- getInertSetRef - ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } - -getInertCans :: TcS InertCans -getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) } - -setInertCans :: InertCans -> TcS () -setInertCans ics = updInertSet $ \ inerts -> inerts { inert_cans = ics } - -updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a --- Modify the inert set with the supplied function -updRetInertCans upd_fn - = do { is_var <- getInertSetRef - ; wrapTcS (do { inerts <- TcM.readTcRef is_var - ; let (res, cans') = upd_fn (inert_cans inerts) - ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) - ; return res }) } - -updInertCans :: (InertCans -> InertCans) -> TcS () --- Modify the inert set with the supplied function -updInertCans upd_fn - = updInertSet $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } - -updInertSafehask :: (DictMap DictCt -> DictMap DictCt) -> TcS () --- Modify the inert set with the supplied function -updInertSafehask upd_fn - = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } - -getInertEqs :: TcS InertEqs -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInnermostGivenEqLevel :: TcS TcLevel -getInnermostGivenEqLevel = do { inert <- getInertCans - ; return (inert_given_eq_lvl inert) } - --- | Retrieves all insoluble constraints from the inert set, --- specifically including Given constraints. --- --- This consists of: --- --- - insoluble equalities, such as @Int ~# Bool@; --- - constraints that are top-level custom type errors, of the form --- @TypeError msg@, but not constraints such as @Eq (TypeError msg)@ --- in which the type error is nested; --- - unsatisfiable constraints, of the form @Unsatisfiable msg@. --- --- The inclusion of Givens is important for pattern match warnings, as we --- want to consider a pattern match that introduces insoluble Givens to be --- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver). -getInertInsols :: TcS Cts -getInertInsols - = do { inert <- getInertCans - ; let insols = filterBag insolubleIrredCt (inert_irreds inert) - unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey - ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts) - $ foldDicts ((:) . CDictCan) (inert_dicts inerts) - $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts) - $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts) - $ [] - ; return (filter isGivenCt all_cts) } - -getPendingGivenScs :: TcS [Ct] --- Find all inert Given dictionaries, or quantified constraints, such that --- 1. cc_pend_sc flag has fuel strictly > 0 --- 2. belongs to the current level --- For each such dictionary: --- * Return it (with unmodified cc_pend_sc) in sc_pending --- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand --- to record that we have expanded superclasses for this dict -getPendingGivenScs = do { lvl <- getTcLevel - ; updRetInertCans (get_sc_pending lvl) } - -get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) -get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) - = assertPpr (all isGivenCt sc_pending) (ppr sc_pending) - -- When getPendingScDics is called, - -- there are never any Wanteds in the inert set - (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) - where - sc_pending = sc_pend_insts ++ map CDictCan sc_pend_dicts - - sc_pend_dicts :: [DictCt] - sc_pend_dicts = foldDicts get_pending dicts [] - dicts' = foldr exhaustAndAdd dicts sc_pend_dicts - - (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts - - exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt - exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts - -- Exhaust the fuel for this constraint before adding it as - -- we don't want to expand these constraints again - - get_pending :: DictCt -> [DictCt] -> [DictCt] -- Get dicts with cc_pend_sc > 0 - get_pending dict dicts - | isPendingScDictCt dict - , belongs_to_this_level (dictCtEvidence dict) - = dict : dicts - | otherwise - = dicts - - get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) - get_pending_inst cts qci@(QCI { qci_ev = ev }) - | Just qci' <- pendingScInst_maybe qci - , belongs_to_this_level ev - = (CQuantCan qci : cts, qci') - -- qci' have their fuel exhausted - -- we don't want to expand these constraints again - -- qci is expanded - | otherwise - = (cts, qci) - - belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl - -- We only want Givens from this level; see (3a) in - -- Note [The superclass story] in GHC.Tc.Solver.Dict - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts ) -- All simple constraints --- Return all the unsolved [Wanted] constraints --- --- Post-condition: the returned simple constraints are all fully zonked --- (because they come from the inert set) --- the unsolved implics may not be -getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts - } <- getInertCans - - ; let unsolved_tv_eqs = foldTyEqs (add_if_unsolved CEqCan) tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan) fun_eqs emptyCts - unsolved_irreds = foldr (add_if_unsolved CIrredCan) emptyCts irreds - unsolved_dicts = foldDicts (add_if_unsolved CDictCan) idicts emptyCts - - ; implics <- getWorkListImplics - - ; traceTcS "getUnsolvedInerts" $ - vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs - , text "fun eqs =" <+> ppr unsolved_fun_eqs - , text "dicts =" <+> ppr unsolved_dicts - , text "irreds =" <+> ppr unsolved_irreds - , text "implics =" <+> ppr implics ] - - ; return ( implics, unsolved_tv_eqs `unionBags` - unsolved_fun_eqs `unionBags` - unsolved_irreds `unionBags` - unsolved_dicts ) } - where - add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts - add_if_unsolved mk_ct thing cts - | isWantedCt ct = ct `consCts` cts - | otherwise = cts - where - ct = mk_ct thing - -getHasGivenEqs :: TcLevel -- TcLevel of this implication - -> TcS ( HasGivenEqs -- are there Given equalities? - , InertIrreds ) -- Insoluble equalities arising from givens --- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet -getHasGivenEqs tclvl - = do { inerts@(IC { inert_irreds = irreds - , inert_given_eqs = given_eqs - , inert_given_eq_lvl = ge_lvl }) - <- getInertCans - ; let given_insols = filterBag insoluble_given_equality irreds - -- Specifically includes ones that originated in some - -- outer context but were refined to an insoluble by - -- a local equality; so no level-check needed - - -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and - -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet - has_ge | ge_lvl == tclvl = MaybeGivenEqs - | given_eqs = LocalGivenEqs - | otherwise = NoGivenEqs - - ; traceTcS "getHasGivenEqs" $ - vcat [ text "given_eqs:" <+> ppr given_eqs - , text "ge_lvl:" <+> ppr ge_lvl - , text "ambient level:" <+> ppr tclvl - , text "Inerts:" <+> ppr inerts - , text "Insols:" <+> ppr given_insols] - ; return (has_ge, given_insols) } - where - insoluble_given_equality :: IrredCt -> Bool - -- Check for unreachability; specifically do not include UserError/Unsatisfiable - insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason }) - = isInsolubleReason reason && isGiven ev - -removeInertCts :: [Ct] -> InertCans -> InertCans --- ^ Remove inert constraints from the 'InertCans', for use when a --- typechecker plugin wishes to discard a given. -removeInertCts cts icans = foldl' removeInertCt icans cts - -removeInertCt :: InertCans -> Ct -> InertCans -removeInertCt is ct - = case ct of - CDictCan dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) } - CEqCan eq_ct -> delEq eq_ct is - CIrredCan ir_ct -> delIrred ir_ct is - CQuantCan {} -> panic "removeInertCt: CQuantCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - --- | Looks up a family application in the inerts. -lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? - -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) -lookupFamAppInert rewrite_pred fam_tc tys - = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet - ; return (lookup_inerts inert_funeqs) } - where - lookup_inerts inert_funeqs - | Just ecl <- findFunEq inert_funeqs fam_tc tys - , Just (EqCt { eq_ev = ctev, eq_rhs = rhs }) - <- find (rewrite_pred . eqCtFlavourRole) ecl - = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev) - | otherwise = Nothing - -lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence) --- Is this exact predicate type cached in the solved or canonicals of the InertSet? -lookupInInerts loc pty - | ClassPred cls tys <- classifyPredType pty - = do { inerts <- getInertSet - ; let mb_solved = lookupSolvedDict inerts loc cls tys - mb_inert = fmap dictCtEvidence (lookupInertDict (inert_cans inerts) loc cls tys) - ; return $ do -- Maybe monad - found_ev <- mb_solved `mplus` mb_inert - - -- We're about to "solve" the wanted we're looking up, so we - -- must make sure doing so wouldn't run afoul of - -- Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - -- Forgetting this led to #20666. - guard $ not (prohibitedSuperClassSolve (ctEvLoc found_ev) loc) - - return found_ev } - | otherwise -- NB: No caching for equalities, IPs, holes, or errors - = return Nothing - --- | Look up a dictionary inert. -lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe DictCt -lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = findDict dicts loc cls tys - --- | Look up a solved inert. -lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence --- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys - = fmap dictCtEvidence (findDict solved loc cls tys) - ---------------------------- -lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction) -lookupFamAppCache fam_tc tys - = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet - ; case findFunEq famapp_cache fam_tc tys of - result@(Just redn) -> - do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys) - , ppr redn ]) - ; return result } - Nothing -> return Nothing } - -extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS () --- NB: co :: rhs ~ F tys, to match expectations of rewriter -extendFamAppCache tc xi_args stuff@(Reduction _ ty) - = do { dflags <- getDynFlags - ; when (gopt Opt_FamAppCache dflags) $ - do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args - , ppr ty ]) - ; updInertSet $ \ is@(IS { inert_famapp_cache = fc }) -> - is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } - --- Remove entries from the cache whose evidence mentions variables in the --- supplied set -dropFromFamAppCache :: VarSet -> TcS () -dropFromFamAppCache varset - = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) -> - inerts { inert_famapp_cache = filterTcAppMap check famapp_cache }) - where - check :: Reduction -> Bool - check redn - = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) - -{- -************************************************************************ -* * -* The TcS solver monad * -* * -************************************************************************ - -Note [The TcS monad] -~~~~~~~~~~~~~~~~~~~~ -The TcS monad is a weak form of the main Tc monad - -All you can do is - * fail - * allocate new variables - * fill in evidence variables - -Filling in a dictionary evidence variable means to create a binding -for it, so TcS carries a mutable location where the binding can be -added. This is initialised from the innermost implication constraint. --} - -data TcSEnv - = TcSEnv { - tcs_ev_binds :: EvBindsVar, - - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero - - tcs_unif_lvl :: IORef (Maybe TcLevel), - -- The Unification Level Flag - -- Outermost level at which we have unified a meta tyvar - -- Starts at Nothing, then (Just i), then (Just j) where j TcM a } - deriving (Functor) - -instance MonadFix TcS where - mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) - --- | Smart constructor for 'TcS', as describe in Note [The one-shot state --- monad trick] in "GHC.Utils.Monad". -mkTcS :: (TcSEnv -> TcM a) -> TcS a -mkTcS f = TcS (oneShot f) - -instance Applicative TcS where - pure x = mkTcS $ \_ -> return x - (<*>) = ap - -instance Monad TcS where - m >>= k = mkTcS $ \ebs -> do - unTcS m ebs >>= (\r -> unTcS (k r) ebs) - -instance MonadIO TcS where - liftIO act = TcS $ \_env -> liftIO act - -instance MonadFail TcS where - fail err = mkTcS $ \_ -> fail err - -instance MonadUnique TcS where - getUniqueSupplyM = wrapTcS getUniqueSupplyM - -instance HasModule TcS where - getModule = wrapTcS getModule - -instance MonadThings TcS where - lookupThing n = wrapTcS (lookupThing n) - --- Basic functionality --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -wrapTcS :: TcM a -> TcS a --- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, --- and TcS is supposed to have limited functionality -wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds - -liftZonkTcS :: ZonkM a -> TcS a -liftZonkTcS = wrapTcS . TcM.liftZonkM - -wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a -wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env) - -wrapErrTcS :: TcM a -> TcS a --- The thing wrapped should just fail --- There's no static check; it's up to the user --- Having a variant for each error message is too painful -wrapErrTcS = wrapTcS - -wrapWarnTcS :: TcM a -> TcS a --- The thing wrapped should just add a warning, or no-op --- There's no static check; it's up to the user -wrapWarnTcS = wrapTcS - -panicTcS :: SDoc -> TcS a -failTcS :: TcRnMessage -> TcS a -warnTcS, addErrTcS :: TcRnMessage -> TcS () -failTcS = wrapTcS . TcM.failWith -warnTcS msg = wrapTcS (TcM.addDiagnostic msg) -addErrTcS = wrapTcS . TcM.addErr -panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc - -tryEarlyAbortTcS :: TcS () --- Abort (fail in the monad) if the abort_on_insoluble flag is on -tryEarlyAbortTcS - = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM) - --- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'. -ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS () -ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg - -traceTcS :: String -> SDoc -> TcS () -traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) -{-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities] - -runTcPluginTcS :: TcPluginM a -> TcS a -runTcPluginTcS = wrapTcS . runTcPluginM - -instance HasDynFlags TcS where - getDynFlags = wrapTcS getDynFlags - -getGlobalRdrEnvTcS :: TcS GlobalRdrEnv -getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv - -bumpStepCountTcS :: TcS () -bumpStepCountTcS = mkTcS $ \env -> - do { let ref = tcs_count env - ; n <- TcM.readTcRef ref - ; TcM.writeTcRef ref (n+1) } - -csTraceTcS :: SDoc -> TcS () -csTraceTcS doc - = wrapTcS $ csTraceTcM (return doc) -{-# INLINE csTraceTcS #-} -- see Note [INLINE conditional tracing utilities] - -traceFireTcS :: CtEvidence -> SDoc -> TcS () --- Dump a rule-firing trace -traceFireTcS ev doc - = mkTcS $ \env -> csTraceTcM $ - do { n <- TcM.readTcRef (tcs_count env) - ; tclvl <- TcM.getTcLevel - ; return (hang (text "Step" <+> int n - <> brackets (text "l:" <> ppr tclvl <> comma <> - text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) - <+> doc <> colon) - 4 (ppr ev)) } -{-# INLINE traceFireTcS #-} -- see Note [INLINE conditional tracing utilities] - -csTraceTcM :: TcM SDoc -> TcM () --- Constraint-solver tracing, -ddump-cs-trace -csTraceTcM mk_doc - = do { logger <- getLogger - ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace - || logHasDumpFlag logger Opt_D_dump_tc_trace) - ( do { msg <- mk_doc - ; TcM.dumpTcRn False - Opt_D_dump_cs_trace - "" FormatText - msg }) } -{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] - -runTcS :: TcS a -- What to run - -> TcM (a, EvBindMap) -runTcS tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; res <- runTcSWithEvBinds ev_binds_var tcs - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; return (res, ev_binds) } - --- | This variant of 'runTcS' will immediately fail upon encountering an --- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage --- site does not need the ev_binds, so we do not return them. -runTcSEarlyAbort :: TcS a -> TcM a -runTcSEarlyAbort tcs - = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds' True True ev_binds_var tcs } - --- | This can deal only with equality constraints. -runTcSEqualities :: TcS a -> TcM a -runTcSEqualities thing_inside - = do { ev_binds_var <- TcM.newNoTcEvBinds - ; runTcSWithEvBinds ev_binds_var thing_inside } - --- | A variant of 'runTcS' that takes and returns an 'InertSet' for --- later resumption of the 'TcS' session. -runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) -runTcSInerts inerts tcs = do - ev_binds_var <- TcM.newTcEvBinds - runTcSWithEvBinds' False False ev_binds_var $ do - setInertSet inerts - a <- tcs - new_inerts <- getInertSet - return (a, new_inerts) - -runTcSWithEvBinds :: EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds = runTcSWithEvBinds' True False - -runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards? - -- Don't if you want to reuse the InertSet. - -- See also Note [Type equality cycles] - -- in GHC.Tc.Solver.Equality - -> Bool - -> EvBindsVar - -> TcS a - -> TcM a -runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs - = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList - ; unif_lvl_var <- TcM.newTcRef Nothing - ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_unified = unified_var - , tcs_unif_lvl = unif_lvl_var - , tcs_count = step_count - , tcs_inerts = inert_var - , tcs_abort_on_insoluble = abort_on_insoluble - , tcs_worklist = wl_var } - - -- Run the computation - ; res <- unTcS tcs env - - ; count <- TcM.readTcRef step_count - ; when (count > 0) $ - csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - - ; when restore_cycles $ - do { inert_set <- TcM.readTcRef inert_var - ; restoreTyVarCycles inert_set } - -#if defined(DEBUG) - ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var - ; checkForCyclicBinds ev_binds -#endif - - ; return res } - ----------------------------- -#if defined(DEBUG) -checkForCyclicBinds :: EvBindMap -> TcM () -checkForCyclicBinds ev_binds_map - | null cycles - = return () - | null coercion_cycles - = TcM.traceTc "Cycle in evidence binds" $ ppr cycles - | otherwise - = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles - where - ev_binds = evBindMapBinds ev_binds_map - - cycles :: [[EvBind]] - cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] - - coercion_cycles = [c | c <- cycles, any is_co_bind c] - is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b) - - edges :: [ Node EvVar EvBind ] - edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs)) - | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] - -- It's OK to use nonDetEltsUFM here as - -- stronglyConnCompFromEdgedVertices is still deterministic even - -- if the edges are in nondeterministic order as explained in - -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. -#endif - ----------------------------- -setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a -setEvBindsTcS ref (TcS thing_inside) - = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) - -nestImplicTcS :: EvBindsVar - -> TcLevel -> TcS a - -> TcS a -nestImplicTcS ref inner_tclvl (TcS thing_inside) - = TcS $ \ TcSEnv { tcs_unified = unified_var - , tcs_inerts = old_inert_var - , tcs_count = count - , tcs_unif_lvl = unif_lvl - , tcs_abort_on_insoluble = abort_on_insoluble - } -> - do { inerts <- TcM.readTcRef old_inert_var - ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack - (inert_cycle_breakers inerts) - , inert_cans = (inert_cans inerts) - { inert_given_eqs = False } } - -- All other InertSet fields are inherited - ; new_inert_var <- TcM.newTcRef nest_inert - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = TcSEnv { tcs_count = count -- Inherited - , tcs_unif_lvl = unif_lvl -- Inherited - , tcs_ev_binds = ref - , tcs_unified = unified_var - , tcs_inerts = new_inert_var - , tcs_abort_on_insoluble = abort_on_insoluble - , tcs_worklist = new_wl_var } - ; res <- TcM.setTcLevel inner_tclvl $ - thing_inside nest_env - - ; out_inert_set <- TcM.readTcRef new_inert_var - ; restoreTyVarCycles out_inert_set - -#if defined(DEBUG) - -- Perform a check that the thing_inside did not cause cycles - ; ev_binds <- TcM.getTcEvBindsMap ref - ; checkForCyclicBinds ev_binds -#endif - ; return res } - -nestTcS :: TcS a -> TcS a --- Use the current untouchables, augmenting the current --- evidence bindings, and solved dictionaries --- But have no effect on the InertCans, or on the inert_famapp_cache --- (we want to inherit the latter from processing the Givens) -nestTcS (TcS thing_inside) - = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> - do { inerts <- TcM.readTcRef inerts_var - ; new_inert_var <- TcM.newTcRef inerts - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - - ; res <- thing_inside nest_env - - ; new_inerts <- TcM.readTcRef new_inert_var - - -- we want to propagate the safe haskell failures - ; let old_ic = inert_cans inerts - new_ic = inert_cans new_inerts - nxt_ic = old_ic { inert_safehask = inert_safehask new_ic } - - ; TcM.writeTcRef inerts_var -- See Note [Propagate the solved dictionaries] - (inerts { inert_solved_dicts = inert_solved_dicts new_inerts - , inert_cans = nxt_ic }) - - ; return res } - -emitImplicationTcS :: TcLevel -> SkolemInfoAnon - -> [TcTyVar] -- Skolems - -> [EvVar] -- Givens - -> Cts -- Wanteds - -> TcS TcEvBinds --- Add an implication to the TcS monad work-list -emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_given = givens - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp - ; return (TcEvBinds (ic_binds imp)) } - -emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon - -> [TcTyVar] -- Skolems - -> Cts -- Wanteds - -> TcS () --- Just like emitImplicationTcS but no givens and no bindings -emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds - = do { let wc = emptyWC { wc_simple = wanteds } - ; imp <- wrapTcS $ - do { ev_binds_var <- TcM.newNoTcEvBinds - ; imp <- TcM.newImplication - ; return (imp { ic_tclvl = new_tclvl - , ic_skols = skol_tvs - , ic_wanted = wc - , ic_binds = ev_binds_var - , ic_info = skol_info }) } - - ; emitImplication imp } - - -{- Note [Propagate the solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's really quite important that nestTcS does not discard the solved -dictionaries from the thing_inside. -Consider - Eq [a] - forall b. empty => Eq [a] -We solve the simple (Eq [a]), under nestTcS, and then turn our attention to -the implications. It's definitely fine to use the solved dictionaries on -the inner implications, and it can make a significant performance difference -if you do so. --} - --- Getters and setters of GHC.Tc.Utils.Env fields --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getUnifiedRef :: TcS (IORef Int) -getUnifiedRef = TcS (return . tcs_unified) - --- Getter of inerts and worklist -getInertSetRef :: TcS (IORef InertSet) -getInertSetRef = TcS (return . tcs_inerts) - -getInertSet :: TcS InertSet -getInertSet = getInertSetRef >>= readTcRef - -setInertSet :: InertSet -> TcS () -setInertSet is = do { r <- getInertSetRef; writeTcRef r is } - -getTcSWorkListRef :: TcS (IORef WorkList) -getTcSWorkListRef = TcS (return . tcs_worklist) - -getWorkListImplics :: TcS (Bag Implication) -getWorkListImplics - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- readTcRef wl_var - ; return (wl_implics wl_curr) } - -pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) --- Push the level and run thing_inside --- However, thing_inside should not generate any work items -#if defined(DEBUG) -pushLevelNoWorkList err_doc (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM $ - thing_inside (env { tcs_worklist = wl_panic }) - ) - where - wl_panic = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc - -- This panic checks that the thing-inside - -- does not emit any work-list constraints -#else -pushLevelNoWorkList _ (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check -#endif - -updWorkListTcS :: (WorkList -> WorkList) -> TcS () -updWorkListTcS f - = do { wl_var <- getTcSWorkListRef - ; updTcRef wl_var f } - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs - = return () - | otherwise - = emitWork (listToBag (map mkNonCanonical evs)) - -emitWork :: Cts -> TcS () -emitWork cts - | isEmptyBag cts -- Avoid printing, among other work - = return () - | otherwise - = do { traceTcS "Emitting fresh work" (pprBag cts) - -- Zonk the rewriter set of Wanteds, because that affects - -- the prioritisation of the work-list. Suppose a constraint - -- c1 is rewritten by another, c2. When c2 gets solved, - -- c1 has no rewriters, and can be prioritised; see - -- Note [Prioritise Wanteds with empty RewriterSet] - -- in GHC.Tc.Types.Constraint wrinkle (WRW1) - ; cts <- wrapTcS $ mapBagM TcM.zonkCtRewriterSet cts - ; updWorkListTcS (extendWorkListCts cts) } - -emitImplication :: Implication -> TcS () -emitImplication implic - = updWorkListTcS (extendWorkListImplic implic) - -newTcRef :: a -> TcS (TcRef a) -newTcRef x = wrapTcS (TcM.newTcRef x) - -readTcRef :: TcRef a -> TcS a -readTcRef ref = wrapTcS (TcM.readTcRef ref) - -writeTcRef :: TcRef a -> a -> TcS () -writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) - -updTcRef :: TcRef a -> (a->a) -> TcS () -updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) - -getTcEvBindsVar :: TcS EvBindsVar -getTcEvBindsVar = TcS (return . tcs_ev_binds) - -getTcLevel :: TcS TcLevel -getTcLevel = wrapTcS TcM.getTcLevel - -getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet -getTcEvTyCoVars ev_binds_var - = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var - -getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap -getTcEvBindsMap ev_binds_var - = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () -setTcEvBindsMap ev_binds_var binds - = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds - -unifyTyVar :: TcTyVar -> TcType -> TcS () --- Unify a meta-tyvar with a type --- We keep track of how many unifications have happened in tcs_unified, --- --- We should never unify the same variable twice! -unifyTyVar tv ty - = assertPpr (isMetaTyVar tv) (ppr tv) $ - TcS $ \ env -> - do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.liftZonkM $ TcM.writeMetaTyVar tv ty - ; TcM.updTcRef (tcs_unified env) (+1) } - -reportUnifications :: TcS a -> TcS (Int, a) -reportUnifications (TcS thing_inside) - = TcS $ \ env -> - do { inner_unified <- TcM.newTcRef 0 - ; res <- thing_inside (env { tcs_unified = inner_unified }) - ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) - ; return (n_unifs, res) } - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - -getWorkList :: TcS WorkList -getWorkList = do { wl_var <- getTcSWorkListRef - ; wrapTcS (TcM.readTcRef wl_var) } - -selectNextWorkItem :: TcS (Maybe Ct) --- Pick which work item to do next --- See Note [Prioritise equalities] -selectNextWorkItem - = do { wl_var <- getTcSWorkListRef - ; wl <- readTcRef wl_var - ; case selectWorkItem wl of { - Nothing -> return Nothing ; - Just (ct, new_wl) -> - do { -- checkReductionDepth (ctLoc ct) (ctPred ct) - -- This is done by GHC.Tc.Solver.Dict.chooseInstance - ; writeTcRef wl_var new_wl - ; return (Just ct) } } } - --- Just get some environments needed for instance looking up and matching --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getInstEnvs :: TcS InstEnvs -getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs - -getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) -getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs - -getTopEnv :: TcS HscEnv -getTopEnv = wrapTcS $ TcM.getTopEnv - -getGblEnv :: TcS TcGblEnv -getGblEnv = wrapTcS $ TcM.getGblEnv - -getLclEnv :: TcS TcLclEnv -getLclEnv = wrapTcS $ TcM.getLclEnv - -setSrcSpan :: RealSrcSpan -> TcS a -> TcS a -setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty)) - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId n - -tcLookupTyCon :: Name -> TcS TyCon -tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n - --- Any use of this function is a bit suspect, because it violates the --- pure veneer of TcS. But it's just about warnings around unused imports --- and local constructors (GHC will issue fewer warnings than it otherwise --- might), so it's not worth losing sleep over. -recordUsedGREs :: Bag GlobalRdrElt -> TcS () -recordUsedGREs gres - = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list } - -- ...and similarly, if a newtype constructor was defined in the same - -- module, don't warn about it being unused. - -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. - - where - gre_list = bagToList gres - --- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () --- Check that we do not try to use an instance before it is available. E.g. --- instance Eq T where ... --- f x = $( ... (\(p::T) -> p == p)... ) --- Here we can't use the equality function from the instance in the splice - -checkWellStagedDFun loc what pred - = do - mbind_lvl <- checkWellStagedInstanceWhat what - case mbind_lvl of - Just bind_lvl | bind_lvl > impLevel -> - wrapTcS $ TcM.setCtLocM loc $ do - { use_stage <- TcM.getStage - ; TcM.checkWellStaged (StageCheckInstance what pred) bind_lvl (thLevel use_stage) } - _ -> - return () - --- | Returns the ThLevel of evidence for the solved constraint (if it has evidence) --- See Note [Well-staged instance evidence] -checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel) -checkWellStagedInstanceWhat what - | TopLevInstance { iw_dfun_id = dfun_id } <- what - = return $ Just (TcM.topIdLvl dfun_id) - | BuiltinTypeableInstance tc <- what - = do - cur_mod <- extractModule <$> getGblEnv - return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc) - then outerLevel - else impLevel) - | otherwise = return Nothing - -{- -Note [Well-staged instance evidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Evidence for instances must obey the same level restrictions as normal bindings. -In particular, it is forbidden to use an instance in a top-level splice in the -module which the instance is defined. This is because the evidence is bound at -the top-level and top-level definitions are forbidden from being using in top-level splices in -the same module. - -For example, suppose you have a function.. foo :: Show a => Code Q a -> Code Q () -then the following program is disallowed, - -``` -data T a = T a deriving (Show) - -main :: IO () -main = - let x = $$(foo [|| T () ||]) - in return () -``` - -because the `foo` function (used in a top-level splice) requires `Show T` evidence, -which is defined at the top-level and therefore fails with an error that we have violated -the stage restriction. - -``` -Main.hs:12:14: error: - • GHC stage restriction: - instance for ‘Show - (T ())’ is used in a top-level splice, quasi-quote, or annotation, - and must be imported, not defined locally - • In the expression: foo [|| T () ||] - In the Template Haskell splice $$(foo [|| T () ||]) - In the expression: $$(foo [|| T () ||]) - | -12 | let x = $$(foo [|| T () ||]) - | -``` - -Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on -`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT` -is well staged. It's easy to know the stage of `$tcT`: for imported TyCons it -will be `impLevel`, and for local TyCons it will be `toplevel`. - -Therefore the `InstanceWhat` type had to be extended with -a special case for `Typeable`, which recorded the TyCon the evidence was for and -could them be used to check that we were not attempting to evidence in a stage incorrect -manner. - --} - -pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 - -isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) -isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) - -isFilledMetaTyVar :: TcTyVar -> TcS Bool -isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) - -zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet -zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs) - -zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] -zonkTyCoVarsAndFVList tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFVList tvs) - -zonkCo :: Coercion -> TcS Coercion -zonkCo = wrapTcS . fmap TcM.liftZonkM TcM.zonkCo - -zonkTcType :: TcType -> TcS TcType -zonkTcType ty = liftZonkTcS (TcM.zonkTcType ty) - -zonkTcTypes :: [TcType] -> TcS [TcType] -zonkTcTypes tys = liftZonkTcS (TcM.zonkTcTypes tys) - -zonkTcTyVar :: TcTyVar -> TcS TcType -zonkTcTyVar tv = liftZonkTcS (TcM.zonkTcTyVar tv) - -zonkSimples :: Cts -> TcS Cts -zonkSimples cts = liftZonkTcS (TcM.zonkSimples cts) - -zonkWC :: WantedConstraints -> TcS WantedConstraints -zonkWC wc = liftZonkTcS (TcM.zonkWC wc) - -zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar -zonkTyCoVarKind tv = liftZonkTcS (TcM.zonkTyCoVarKind tv) - ----------------------------- -pprKicked :: Int -> SDoc -pprKicked 0 = empty -pprKicked n = parens (int n <+> text "kicked out") - -{- ********************************************************************* -* * -* The Unification Level Flag * -* * -********************************************************************* -} - -{- Note [The Unification Level Flag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a deep tree of implication constraints - forall[1] a. -- Outer-implic - C alpha[1] -- Simple - forall[2] c. ....(C alpha[1]).... -- Implic-1 - forall[2] b. ....(alpha[1] ~ Int).... -- Implic-2 - -The (C alpha) is insoluble until we know alpha. We solve alpha -by unifying alpha:=Int somewhere deep inside Implic-2. But then we -must try to solve the Outer-implic all over again. This time we can -solve (C alpha) both in Outer-implic, and nested inside Implic-1. - -When should we iterate solving a level-n implication? -Answer: if any unification of a tyvar at level n takes place - in the ic_implics of that implication. - -* What if a unification takes place at level n-1? Then don't iterate - level n, because we'll iterate level n-1, and that will in turn iterate - level n. - -* What if a unification takes place at level n, in the ic_simples of - level n? No need to track this, because the kick-out mechanism deals - with it. (We can't drop kick-out in favour of iteration, because kick-out - works for skolem-equalities, not just unifications.) - -So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps -track of - - Whether any unifications at all have taken place (Nothing => no unifications) - - If so, what is the outermost level that has seen a unification (Just lvl) - -The iteration is done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver. - -It helpful not to iterate unless there is a chance of progress. #8474 is -an example: - - * There's a deeply-nested chain of implication constraints. - ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - - * From the innermost one we get a [W] alpha[1] ~ Int, - so we can unify. - - * It's better not to iterate the inner implications, but go all the - way out to level 1 before iterating -- because iterating level 1 - will iterate the inner levels anyway. - -(In the olden days when we "floated" thse Derived constraints, this was -much, much more important -- we got exponential behaviour, as each iteration -produced the same Derived constraint.) --} - - -resetUnificationFlag :: TcS Bool --- We are at ambient level i --- If the unification flag = Just i, reset it to Nothing and return True --- Otherwise leave it unchanged and return False -resetUnificationFlag - = TcS $ \env -> - do { let ref = tcs_unif_lvl env - ; ambient_lvl <- TcM.getTcLevel - ; mb_lvl <- TcM.readTcRef ref - ; TcM.traceTc "resetUnificationFlag" $ - vcat [ text "ambient:" <+> ppr ambient_lvl - , text "unif_lvl:" <+> ppr mb_lvl ] - ; case mb_lvl of - Nothing -> return False - Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl - -> return False - | otherwise - -> do { TcM.writeTcRef ref Nothing - ; return True } } - -setUnificationFlag :: TcLevel -> TcS () --- (setUnificationFlag i) sets the unification level to (Just i) --- unless it already is (Just j) where j <= i -setUnificationFlag lvl - = TcS $ \env -> - do { let ref = tcs_unif_lvl env - ; mb_lvl <- TcM.readTcRef ref - ; case mb_lvl of - Just unif_lvl | lvl `deeperThanOrSame` unif_lvl - -> return () - _ -> TcM.writeTcRef ref (Just lvl) } - - -{- ********************************************************************* -* * -* Instantiation etc. -* * -********************************************************************* -} - --- Instantiations --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) -instDFunType dfun_id inst_tys - = wrapTcS $ TcM.instDFunType dfun_id inst_tys - -newFlexiTcSTy :: Kind -> TcS TcType -newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) - -cloneMetaTyVar :: TcTyVar -> TcS TcTyVar -cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) - -instFlexiX :: Subst -> [TKVar] -> TcS Subst -instFlexiX subst tvs = wrapTcS (instFlexiXTcM subst tvs) - -instFlexiXTcM :: Subst -> [TKVar] -> TcM Subst --- Makes fresh tyvar, extends the substitution, and the in-scope set --- Takes account of the case [k::Type, a::k, ...], --- where we must substitute for k in a's kind -instFlexiXTcM subst [] - = return subst -instFlexiXTcM subst (tv:tvs) - = do { uniq <- TcM.newUnique - ; details <- TcM.newMetaDetails TauTv - ; let name = setNameUnique (tyVarName tv) uniq - kind = substTyUnchecked subst (tyVarKind tv) - tv' = mkTcTyVar name kind details - subst' = extendTvSubstWithClone subst tv tv' - ; instFlexiXTcM subst' tvs } - -matchGlobalInst :: DynFlags - -> Bool -- True <=> caller is the short-cut solver - -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcS TcM.ClsInstResult -matchGlobalInst dflags short_cut cls tys - = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) - -tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) -tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs - --- Creating and setting evidence variables and CtFlavors --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data MaybeNew = Fresh CtEvidence | Cached EvExpr - -isFresh :: MaybeNew -> Bool -isFresh (Fresh {}) = True -isFresh (Cached {}) = False - -freshGoals :: [MaybeNew] -> [CtEvidence] -freshGoals mns = [ ctev | Fresh ctev <- mns ] - -getEvExpr :: MaybeNew -> EvExpr -getEvExpr (Fresh ctev) = ctEvExpr ctev -getEvExpr (Cached evt) = evt - -setEvBind :: EvBind -> TcS () -setEvBind ev_bind - = do { evb <- getTcEvBindsVar - ; wrapTcS $ TcM.addTcEvBind evb ev_bind } - --- | Mark variables as used filling a coercion hole -useVars :: CoVarSet -> TcS () -useVars co_vars - = do { ev_binds_var <- getTcEvBindsVar - ; let ref = ebv_tcvs ev_binds_var - ; wrapTcS $ - do { tcvs <- TcM.readTcRef ref - ; let tcvs' = tcvs `unionVarSet` co_vars - ; TcM.writeTcRef ref tcvs' } } - --- | Equalities only -setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS () -setWantedEq (HoleDest hole) co - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } -setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) - --- | Good for both equalities and non-equalities -setWantedEvTerm :: TcEvDest -> Canonical -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) _canonical tm - | Just co <- evTermCoercion_maybe tm - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } - | otherwise - = -- See Note [Yukky eq_sel for a HoleDest] - do { let co_var = coHoleCoVar hole - ; setEvBind (mkWantedEvBind co_var True tm) - ; fillCoercionHole hole (mkCoVarCo co_var) } - -setWantedEvTerm (EvVarDest ev_id) canonical tm - = setEvBind (mkWantedEvBind ev_id canonical tm) - -{- Note [Yukky eq_sel for a HoleDest] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How can it be that a Wanted with HoleDest gets evidence that isn't -just a coercion? i.e. evTermCoercion_maybe returns Nothing. - -Consider [G] forall a. blah => a ~ T - [W] S ~# T - -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T) -in the quantified constraints, and wraps the (boxed) evidence it -gets back in an eq_sel to extract the unboxed (S ~# T). We can't put -that term into a coercion, so we add a value binding - h = eq_sel (...) -and the coercion variable h to fill the coercion hole. -We even re-use the CoHole's Id for this binding! - -Yuk! --} - -fillCoercionHole :: CoercionHole -> Coercion -> TcS () -fillCoercionHole hole co - = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole } - -setEvBindIfWanted :: CtEvidence -> Canonical -> EvTerm -> TcS () -setEvBindIfWanted ev canonical tm - = case ev of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest canonical tm - _ -> return () - -newTcEvBinds :: TcS EvBindsVar -newTcEvBinds = wrapTcS TcM.newTcEvBinds - -newNoTcEvBinds :: TcS EvBindsVar -newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds - -newEvVar :: TcPredType -> TcS EvVar -newEvVar pred = wrapTcS (TcM.newEvVar pred) - -newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence --- Make a new variable of the given PredType, --- immediately bind it to the given term --- and return its CtEvidence --- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint -newGivenEvVar loc (pred, rhs) - = do { new_ev <- newBoundEvVarId pred rhs - ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } - --- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the --- given term -newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar -newBoundEvVarId pred rhs - = do { new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) - ; return new_ev } - -emitNewGivens :: CtLoc -> [(Role,TcType,TcType,TcCoercion)] -> TcS () -emitNewGivens loc pts - = do { evs <- mapM (newGivenEvVar loc) $ - [ (mkPrimEqPredRole role ty1 ty2, evCoercion co) - | (role, ty1, ty2, co) <- pts - , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth - ; emitWorkNC evs } - -emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion --- | Emit a new Wanted equality into the work-list -emitNewWantedEq loc rewriters role ty1 ty2 - = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2 - ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical ev)) - ; return co } - --- | Create a new Wanted constraint holding a coercion hole --- for an equality between the two types at the given 'Role'. -newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType - -> TcS (CtEvidence, Coercion) -newWantedEq loc rewriters role ty1 ty2 - = do { hole <- wrapTcS $ TcM.newCoercionHole loc pty - ; return ( CtWanted { ctev_pred = pty - , ctev_dest = HoleDest hole - , ctev_loc = loc - , ctev_rewriters = rewriters } - , mkHoleCo hole ) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Create a new Wanted constraint holding an evidence variable. --- --- Don't use this for equality constraints: use 'newWantedEq' instead. -newWantedEvVarNC :: CtLoc -> RewriterSet - -> TcPredType -> TcS CtEvidence --- Don't look up in the solved/inerts; we know it's not there -newWantedEvVarNC loc rewriters pty - = do { new_ev <- newEvVar pty - ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ - pprCtLoc loc) - ; return (CtWanted { ctev_pred = pty - , ctev_dest = EvVarDest new_ev - , ctev_loc = loc - , ctev_rewriters = rewriters })} - --- | Like 'newWantedEvVarNC', except it might look up in the inert set --- to see if an inert already exists, and uses that instead of creating --- a new Wanted constraint. --- --- Don't use this for equality constraints: this function is only for --- constraints with 'EvVarDest'. -newWantedEvVar :: CtLoc -> RewriterSet - -> TcPredType -> TcS MaybeNew --- For anything except ClassPred, this is the same as newWantedEvVarNC -newWantedEvVar loc rewriters pty - = assertPpr (not (isEqPrimPred pty)) - (vcat [ text "newWantedEvVar: HoleDestPred" - , text "pty:" <+> ppr pty ]) $ - do { mb_ct <- lookupInInerts loc pty - ; case mb_ct of - Just ctev - -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev - ; return $ Cached (ctEvExpr ctev) } - _ -> do { ctev <- newWantedEvVarNC loc rewriters pty - ; return (Fresh ctev) } } - --- | Create a new Wanted constraint, potentially looking up --- non-equality constraints in the cache instead of creating --- a new one from scratch. --- --- Deals with both equality and non-equality constraints. -newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew -newWanted loc rewriters pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2 - | otherwise - = newWantedEvVar loc rewriters pty - --- | Create a new Wanted constraint. --- --- Deals with both equality and non-equality constraints. --- --- Does not attempt to re-use non-equality constraints that already --- exist in the inert set. -newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence -newWantedNC loc rewriters pty - | Just (role, ty1, ty2) <- getEqPredTys_maybe pty - = fst <$> newWantedEq loc rewriters role ty1 ty2 - | otherwise - = newWantedEvVarNC loc rewriters pty - --- | Checks if the depth of the given location is too much. Fails if --- it's too big, with an appropriate error message. -checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced - -> TcS () -checkReductionDepth loc ty - = do { dflags <- getDynFlags - ; when (subGoalDepthExceeded (reductionDepth dflags) (ctLocDepth loc)) $ - wrapErrTcS $ solverDepthError loc ty } - -matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN) -matchFam tycon args = wrapTcS $ matchFamTcM tycon args - -matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN) --- Given (F tys) return (ty, co), where co :: F tys ~N ty -matchFamTcM tycon args - = do { fam_envs <- FamInst.tcGetFamInstEnvs - ; let match_fam_result - = reduceTyFamApp_maybe fam_envs Nominal tycon args - ; TcM.traceTc "matchFamTcM" $ - vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) - , ppr_res match_fam_result ] - ; return match_fam_result } - where - ppr_res Nothing = text "Match failed" - ppr_res (Just (Reduction co ty)) - = hang (text "Match succeeded:") - 2 (vcat [ text "Rewrites to:" <+> ppr ty - , text "Coercion:" <+> ppr co ]) - -solverDepthError :: CtLoc -> TcType -> TcM a -solverDepthError loc ty - = TcM.setCtLocM loc $ - do { (ty, env0) <- TcM.liftZonkM $ - do { ty <- TcM.zonkTcType ty - ; env0 <- TcM.tcInitTidyEnv - ; return (ty, env0) } - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg = TcRnSolverDepthError tidy_ty depth - ; TcM.failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - -{- -************************************************************************ -* * - Emitting equalities arising from fundeps -* * -************************************************************************ --} - -emitFunDepWanteds :: CtEvidence -- The work item - -> [FunDepEqn (CtLoc, RewriterSet)] - -> TcS Bool -- True <=> some unification happened - -emitFunDepWanteds _ [] = return False -- common case noop --- See Note [FunDep and implicit parameter reactions] - -emitFunDepWanteds ev fd_eqns - = unifyFunDeps ev Nominal do_fundeps - where - do_fundeps :: UnifyEnv -> TcM () - do_fundeps env = mapM_ (do_one env) fd_eqns - - do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM () - do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) - = do { eqs' <- instantiate_eqs tvs (reverse eqs) - -- (reverse eqs): See Note [Reverse order of fundep equations] - ; uPairsTcM env_one eqs' } - where - env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters - , u_loc = loc } - - instantiate_eqs :: [TyVar] -> [TypeEqn] -> TcM [TypeEqn] - instantiate_eqs tvs eqs - | null tvs - = return eqs - | otherwise - = do { TcM.traceTc "emitFunDepWanteds 2" (ppr tvs $$ ppr eqs) - ; subst <- instFlexiXTcM emptySubst tvs -- Takes account of kind substitution - ; return [ Pair (substTyUnchecked subst' ty1) ty2 - -- ty2 does not mention fd_qtvs, so no need to subst it. - -- See GHC.Tc.Instance.Fundeps Note [Improving against instances] - -- Wrinkle (1) - | Pair ty1 ty2 <- eqs - , let subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) ] - -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result - -- of matching with the [W] constraint. So we add its free - -- vars to InScopeSet, to satisfy substTy's invariants, even - -- though ty1 will never (currently) be a poytype, so this - -- InScopeSet will never be looked at. - } - -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [wrapUnifierTcS] -~~~~~~~~~~~~~~~~~~~ -When decomposing equalities we often create new wanted constraints for -(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. - -Rather than making an equality test (which traverses the structure of the type, -perhaps fruitlessly), we call uType (via wrapUnifierTcS) to traverse the common -structure, and bales out when it finds a difference by creating a new deferred -Wanted constraint. But where it succeeds in finding common structure, it just -builds a coercion to reflect it. - -This is all much faster than creating a new constraint, putting it in the -work list, picking it out, canonicalising it, etc etc. - -Note [unifyFunDeps] -~~~~~~~~~~~~~~~~~~~ -The Bool returned by `unifyFunDeps` is True if we have unified a variable -that occurs in the constraint we are trying to solve; it is not in the -inert set so `wrapUnifierTcS` won't kick it out. Instead we want to send it -back to the start of the pipeline. Hence the Bool. - -It's vital that we don't return (not (null unified)) because the fundeps -may create fresh variables; unifying them (alone) should not make us send -the constraint back to the start, or we'll get an infinite loop. See -Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict -and Note [Improvement orientation] in GHC.Tc.Solver.Equality. --} - -uPairsTcM :: UnifyEnv -> [TypeEqn] -> TcM () -uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns - -unifyFunDeps :: CtEvidence -> Role - -> (UnifyEnv -> TcM ()) - -> TcS Bool -unifyFunDeps ev role do_unifications - = do { (_, _, unified) <- wrapUnifierTcS ev role do_unifications - ; return (any (`elemVarSet` fvs) unified) } - -- See Note [unifyFunDeps] - where - fvs = tyCoVarsOfType (ctEvPred ev) - -wrapUnifierTcS :: CtEvidence -> Role - -> (UnifyEnv -> TcM a) -- Some calls to uType - -> TcS (a, Bag Ct, [TcTyVar]) --- Invokes the do_unifications argument, with a suitable UnifyEnv. --- Emit deferred equalities and kick-out from the inert set as a --- result of any unifications. --- Very good short-cut when the two types are equal, or nearly so --- See Note [wrapUnifierTcS] --- --- The [TcTyVar] is the list of unification variables that were --- unified the process; the (Bag Ct) are the deferred constraints. - -wrapUnifierTcS ev role do_unifications - = do { unif_count_ref <- getUnifiedRef - ; (cos, unified, rewriters, cts) <- wrapTcS $ - do { defer_ref <- TcM.newTcRef emptyBag - ; unified_ref <- TcM.newTcRef [] - ; rewriters <- TcM.zonkRewriterSet (ctEvRewriters ev) - ; let env = UE { u_role = role - , u_rewriters = rewriters - , u_loc = ctEvLoc ev - , u_defer = defer_ref - , u_unified = Just unified_ref} - - ; cos <- do_unifications env - - ; cts <- TcM.readTcRef defer_ref - ; unified <- TcM.readTcRef unified_ref - - - -- Don't forget to update the count of variables - -- unified, lest we forget to iterate (#24146) - ; unless (null unified) $ - TcM.updTcRef unif_count_ref (+ (length unified)) - - ; return (cos, unified, rewriters, cts) } - - -- Emit the deferred constraints - -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality - ; unless (isEmptyBag cts) $ - updWorkListTcS (extendWorkListEqs rewriters cts) - - -- And kick out any inert constraint that we have unified - ; _ <- kickOutAfterUnification unified - - ; return (cos, cts, unified) } - - -{- -************************************************************************ -* * - Breaking type variable cycles -* * -************************************************************************ --} - -checkTouchableTyVarEq - :: CtEvidence - -> TcTyVar -- A touchable meta-tyvar - -> TcType -- The RHS - -> TcS (PuResult () Reduction) --- Used for Nominal, Wanted equalities, with a touchable meta-tyvar on LHS --- If checkTouchableTyVarEq tv ty = PuOK cts redn --- then we can unify --- tv := ty |> redn --- with extra wanteds 'cts' --- If it returns (PuFail reason) we can't unify, and the reason explains why. -checkTouchableTyVarEq ev lhs_tv rhs - | simpleUnifyCheck True lhs_tv rhs - -- True <=> type families are ok on the RHS - = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs) - ; return (pure (mkReflRedn Nominal rhs)) } - - | otherwise - = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs) - ; check_result <- wrapTcS (check_rhs rhs) - ; traceTcS "checkTouchableTyVarEq }" (ppr lhs_tv $$ ppr check_result) - ; case check_result of - PuFail reason -> return (PuFail reason) - PuOK cts redn -> do { emitWork cts - ; return (pure redn) } } - - where - (lhs_tv_info, lhs_tv_lvl) = case tcTyVarDetails lhs_tv of - MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl) - _ -> pprPanic "checkTouchableTyVarEq" (ppr lhs_tv) - -- lhs_tv should be a meta-tyvar - - is_concrete_lhs_tv = isConcreteInfo lhs_tv_info - - check_rhs rhs - -- Crucial special case for alpha ~ F tys - -- We don't want to flatten that (F tys)! - | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs - = if is_concrete_lhs_tv - then failCheckWith (cteProblem cteConcrete) - else recurseIntoTyConApp arg_flags tc tys - | otherwise - = checkTyEqRhs flags rhs - - flags = TEF { tef_foralls = False -- isRuntimeUnkSkol lhs_tv - , tef_fam_app = mkTEFA_Break ev NomEq break_wanted - , tef_unifying = Unifying lhs_tv_info lhs_tv_lvl LC_Promote - , tef_lhs = TyVarLHS lhs_tv - , tef_occurs = cteInsolubleOccurs } - - arg_flags = famAppArgFlags flags - - break_wanted fam_app - -- Occurs check or skolem escape; so flatten - = do { let fam_app_kind = typeKind fam_app - ; reason <- checkPromoteFreeVars cteInsolubleOccurs - lhs_tv lhs_tv_lvl (tyCoVarsOfType fam_app_kind) - ; if not (cterHasNoProblem reason) -- Failed to promote free vars - then failCheckWith reason - else - do { new_tv_ty <- - case lhs_tv_info of - ConcreteTv conc_info -> - -- Make a concrete tyvar if lhs_tv is concrete - -- e.g. alpha[2,conc] ~ Maybe (F beta[4]) - -- We want to flatten to - -- alpha[2,conc] ~ Maybe gamma[2,conc] - -- gamma[2,conc] ~ F beta[4] - TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind - _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind - - ; let pty = mkPrimEqPredRole Nominal fam_app new_tv_ty - ; hole <- TcM.newVanillaCoercionHole pty - ; let new_ev = CtWanted { ctev_pred = pty - , ctev_dest = HoleDest hole - , ctev_loc = cb_loc - , ctev_rewriters = ctEvRewriters ev } - ; return (PuOK (singleCt (mkNonCanonical new_ev)) - (mkReduction (HoleCo hole) new_tv_ty)) } } - - -- See Detail (7) of the Note - cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin - ------------------------- -checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType - -> TcS (PuResult () Reduction) --- Used for general CanEqLHSs, ones that do --- not have a touchable type variable on the LHS (i.e. not unifying) -checkTypeEq ev eq_rel lhs rhs - | isGiven ev - = do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs - , text "rhs:" <+> ppr rhs ]) - ; check_result <- wrapTcS (check_given_rhs rhs) - ; traceTcS "checkTypeEq }" (ppr check_result) - ; case check_result of - PuFail reason -> return (PuFail reason) - PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs - ; emitWork new_givens - ; updInertSet (addCycleBreakerBindings prs) - ; return (pure redn) } } - - | otherwise -- Wanted - = do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs) - ; case check_result of - PuFail reason -> return (PuFail reason) - PuOK cts redn -> do { emitWork cts - ; return (pure redn) } } - where - check_given_rhs :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction) - check_given_rhs rhs - -- See Note [Special case for top-level of Given equality] - | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs - = recurseIntoTyConApp arg_flags tc tys - | otherwise - = checkTyEqRhs given_flags rhs - - arg_flags = famAppArgFlags given_flags - - given_flags :: TyEqFlags (TcTyVar,TcType) - given_flags = TEF { tef_lhs = lhs - , tef_foralls = False - , tef_unifying = NotUnifying - , tef_fam_app = mkTEFA_Break ev eq_rel break_given - , tef_occurs = occ_prob } - -- TEFA_Break used for: [G] a ~ Maybe (F a) - -- or [W] F a ~ Maybe (F a) - - wanted_flags = TEF { tef_lhs = lhs - , tef_foralls = False - , tef_unifying = NotUnifying - , tef_fam_app = TEFA_Recurse - , tef_occurs = occ_prob } - -- TEFA_Recurse: see Note [Don't cycle-break Wanteds when not unifying] - - -- occ_prob: see Note [Occurs check and representational equality] - occ_prob = case eq_rel of - NomEq -> cteInsolubleOccurs - ReprEq -> cteSolubleOccurs - - break_given :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction) - break_given fam_app - = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app) - ; return (PuOK (unitBag (new_tv, fam_app)) - (mkReflRedn Nominal (mkTyVarTy new_tv))) } - -- Why reflexive? See Detail (4) of the Note - - --------------------------- - mk_new_given :: (TcTyVar, TcType) -> TcS Ct - mk_new_given (new_tv, fam_app) - = mkNonCanonical <$> newGivenEvVar cb_loc (given_pred, given_term) - where - new_ty = mkTyVarTy new_tv - given_pred = mkPrimEqPred fam_app new_ty - given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note - - -- See Detail (7) of the Note - cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin - -mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp a -mkTEFA_Break ev eq_rel breaker - | NomEq <- eq_rel - , not cycle_breaker_origin - = TEFA_Break breaker - | otherwise - = TEFA_Recurse - where - -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles] - -- in GHC.Tc.Solver.Equality - cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of - CycleBreakerOrigin {} -> True - _ -> False - -------------------------- --- | Fill in CycleBreakerTvs with the variables they stand for. --- See Note [Type equality cycles] in GHC.Tc.Solver.Equality -restoreTyVarCycles :: InertSet -> TcM () -restoreTyVarCycles is - = TcM.liftZonkM - $ forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar -{-# SPECIALISE forAllCycleBreakerBindings_ :: - CycleBreakerVarStack -> (TcTyVar -> TcType -> ZonkM ()) -> ZonkM () #-} - - -{- Note [Occurs check and representational equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(a ~R# b a) is soluble if b later turns out to be Identity -So we treat this as a "soluble occurs check". - -Note [Special case for top-level of Given equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We take care when examining - [G] F ty ~ G (...(F ty)...) -where both sides are TyFamLHSs. We don't want to flatten that RHS to - [G] F ty ~ cbv - [G] G (...(F ty)...) ~ cbv -Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a -canonical constraint - [G] G (...(F ty)...) ~ F ty -That tents to rewrite a big type to smaller one. This happens in T15703, -where we had: - [G] Pure g ~ From1 (To1 (Pure g)) -Making a loop breaker and rewriting left to right just makes much bigger -types than swapping it over. - -(We might hope to have swapped it over before getting to checkTypeEq, -but better safe than sorry.) - -NB: We never see a TyVarLHS here, such as - [G] a ~ F tys here -because we'd have swapped it to - [G] F tys ~ a -in canEqCanLHS2, before getting to checkTypeEq. +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Monadic definitions for the constraint solver +module GHC.Tc.Solver.Monad ( + + -- The TcS monad + TcS(..), TcSEnv(..), + runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts, + failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, + runTcSEqualities, + nestTcS, nestImplicTcS, tryShortCutTcS, + setEvBindsTcS, setTcLevelTcS, + emitFunDepWanteds, + + selectNextWorkItem, + getWorkList, + updWorkListTcS, + pushLevelNoWorkList, + + runTcPluginTcS, recordUsedGREs, + matchGlobalInst, TcM.ClsInstResult(..), + + QCInst(..), + + -- TcSMode + TcSMode(..), getTcSMode, setTcSMode, vanillaTcSMode, + + -- The pipeline + StopOrContinue(..), continueWith, stopWith, + startAgainWith, SolverStage(Stage, runSolverStage), simpleStage, + stopWithStage, nopStage, + + -- Tracing etc + panicTcS, traceTcS, tryEarlyAbortTcS, + traceFireTcS, bumpStepCountTcS, csTraceTcS, + wrapErrTcS, wrapWarnTcS, + resetUnificationFlag, setUnificationFlag, + + -- Evidence creation and transformation + MaybeNew(..), freshGoals, isFresh, getEvExpr, + CanonicalEvidence(..), + + newTcEvBinds, newNoTcEvBinds, + newWantedEq, emitNewWantedEq, + newWanted, + newWantedNC, newWantedEvVarNC, + newBoundEvVarId, + unifyTyVar, reportUnifications, + setEvBind, setWantedEq, + setWantedEvTerm, setEvBindIfWanted, + newEvVar, newGivenEvVar, emitNewGivens, + checkReductionDepth, + + getInstEnvs, getFamInstEnvs, -- Getting the environments + getTopEnv, getGblEnv, getLclEnv, setSrcSpan, + getTcEvBindsVar, getTcLevel, + getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, + tcLookupClass, tcLookupId, tcLookupTyCon, + + getUnifiedRef, + + + -- Inerts + updInertSet, updInertCans, + getHasGivenEqs, setInertCans, + getInertEqs, getInertCans, getInertGivens, + getInertInsols, getInnermostGivenEqLevel, + getInertSet, setInertSet, + getUnsolvedInerts, + removeInertCts, getPendingGivenScs, + insertFunEq, addInertQCI, + updInertDicts, updInertIrreds, + emitWorkNC, emitWork, + lookupInertDict, + + -- The Model + kickOutAfterUnification, kickOutRewritable, + + -- Inert Safe Haskell safe-overlap failures + insertSafeOverlapFailureTcS, + getSafeOverlapFailures, + + -- Inert solved dictionaries + getSolvedDicts, setSolvedDicts, + updSolvedDicts, lookupSolvedDict, + + -- Irreds + foldIrreds, + + -- The family application cache + lookupFamAppInert, lookupFamAppCache, extendFamAppCache, + pprKicked, + + -- Instantiation + instDFunType, + + -- Unification + wrapUnifierX, wrapUnifierTcS, unifyFunDeps, uPairsTcM, unifyForAllBody, + + -- MetaTyVars + newFlexiTcSTy, instFlexiX, + cloneMetaTyVar, + tcInstSkolTyVarsX, + + TcLevel, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, + zonkTyCoVarsAndFVList, + zonkSimples, zonkWC, + zonkTyCoVarKind, + + -- References + newTcRef, readTcRef, writeTcRef, updTcRef, + + -- Misc + getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, + matchFam, matchFamTcM, + checkWellLevelledDFun, + pprEq, + + -- Enforcing invariants for type equalities + checkTypeEq +) where + +import GHC.Prelude + +import GHC.Driver.Env + +import qualified GHC.Tc.Utils.Instantiate as TcM +import GHC.Core.InstEnv +import GHC.Tc.Instance.Family as FamInst +import GHC.Core.FamInstEnv + +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) +import qualified GHC.Tc.Utils.Env as TcM + ( tcGetDefaultTys + , tcLookupClass, tcLookupId, tcLookupTyCon + ) +import GHC.Tc.Zonk.Monad ( ZonkM ) +import qualified GHC.Tc.Zonk.TcType as TcM + +import GHC.Driver.DynFlags + +import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon ) +import GHC.Tc.Instance.FunDeps( FunDepEqn(..) ) +import GHC.Utils.Misc + + +import GHC.Tc.Solver.Types +import GHC.Tc.Solver.InertSet +import GHC.Tc.Errors.Types + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Unify + +import GHC.Tc.Types.Evidence +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Constraint + +import GHC.Builtin.Names ( unsatisfiableClassNameKey, callStackTyConName, exceptionContextTyConName ) + +import GHC.Core.Type +import GHC.Core.TyCo.Rep as Rep +import GHC.Core.TyCo.Tidy +import GHC.Core.Coercion +import GHC.Core.Coercion.Axiom( TypeEqn ) +import GHC.Core.Predicate +import GHC.Core.Reduction +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Unify (typesAreApart) + +import GHC.Types.Name +import GHC.Types.TyThing +import GHC.Types.Name.Reader +import GHC.Types.DefaultEnv ( DefaultEnv ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Unique.Supply +import GHC.Types.Unique.Set( elementOfUniqSet ) +import GHC.Types.Id +import GHC.Types.Basic (allImportLevels) +import GHC.Types.ThLevelIndex (thLevelIndexFromImportLevel) +import GHC.Types.SrcLoc + +import GHC.Unit.Module +import qualified GHC.Rename.Env as TcM +import GHC.Rename.Env + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger + +import GHC.Data.Bag as Bag +import GHC.Data.Pair + +import GHC.Utils.Monad + +import GHC.Exts (oneShot) +import Control.Monad +import Data.Foldable hiding ( foldr1 ) +import Data.IORef +import Data.Maybe( catMaybes ) +import Data.List ( mapAccumL ) +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as S +import GHC.LanguageExtensions as LangExt + +#if defined(DEBUG) +import GHC.Types.Unique.Set (nonDetEltsUniqSet) +import GHC.Data.Graph.Directed +#endif + +import qualified Data.Set as Set +import GHC.Unit.Module.Graph + +{- ********************************************************************* +* * + SolverStage and StopOrContinue +* * +********************************************************************* -} + +{- Note [The SolverStage monad] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SolverStage monad allows us to write simple code like that in +GHC.Tc.Solver.solveEquality. At the time of writing it looked like +this (may get out of date but the idea is clear): + +solveEquality :: ... -> SolverStage Void +solveEquality ev eq_rel ty1 ty2 + = do { Pair ty1' ty2' <- zonkEqTypes ev eq_rel ty1 ty2 + ; mb_canon <- canonicaliseEquality ev' eq_rel ty1' ty2' + ; case mb_canon of { + Left irred_ct -> do { tryQCsIrredEqCt irred_ct + ; solveIrred irred_ct } ; + Right eq_ct -> do { tryInertEqs eq_ct + ; tryFunDeps eq_ct + ; tryQCsEqCt eq_ct + ; simpleStage (updInertEqs eq_ct) + ; stopWithStage (eqCtEvidence eq_ct) ".." }}} + +Each sub-stage can elect to + (a) ContinueWith: continue to the next stasge + (b) StartAgain: start again at the beginning of the pipeline + (c) Stop: stop altogether; constraint is solved + +These three possiblities are described by the `StopOrContinue` data type. +The `SolverStage` monad does the plumbing. + +Notes: + +(SM1) Each individual stage pretty quickly drops down into + TcS (StopOrContinue a) + because the monadic plumbing of `SolverStage` is relatively ineffienct, + with that three-way split. + +(SM2) We use `SolverStage Void` to express the idea that ContinueWith is + impossible; we don't need to pattern match on it as a possible outcome:A + see GHC.Tc.Solver.Solve.solveOne. To that end, ContinueWith is strict. +-} + +data StopOrContinue a + = StartAgain Ct -- Constraint is not solved, but some unifications + -- happened, so go back to the beginning of the pipeline + + | ContinueWith !a -- The constraint was not solved, although it may have + -- been rewritten. It is strict so that + -- ContinueWith Void can't happen; see (SM2) in + -- Note [The SolverStage monad] + + | Stop CtEvidence -- The (rewritten) constraint was solved + SDoc -- Tells how it was solved + -- Any new sub-goals have been put on the work list + deriving (Functor) + +instance Outputable a => Outputable (StopOrContinue a) where + ppr (Stop ev s) = text "Stop" <> parens (s $$ text "ev:" <+> ppr ev) + ppr (ContinueWith w) = text "ContinueWith" <+> ppr w + ppr (StartAgain w) = text "StartAgain" <+> ppr w + +newtype SolverStage a = Stage { runSolverStage :: TcS (StopOrContinue a) } + deriving( Functor ) + +instance Applicative SolverStage where + pure x = Stage (return (ContinueWith x)) + (<*>) = ap + +instance Monad SolverStage where + return = pure + (Stage m) >>= k = Stage $ + do { soc <- m + ; case soc of + StartAgain x -> return (StartAgain x) + Stop ev d -> return (Stop ev d) + ContinueWith x -> runSolverStage (k x) } + +nopStage :: a -> SolverStage a +nopStage res = Stage (continueWith res) + +simpleStage :: TcS a -> SolverStage a +-- Always does a ContinueWith; no Stop or StartAgain +simpleStage thing = Stage (do { res <- thing; continueWith res }) + +startAgainWith :: Ct -> TcS (StopOrContinue a) +startAgainWith ct = return (StartAgain ct) + +continueWith :: a -> TcS (StopOrContinue a) +continueWith ct = return (ContinueWith ct) + +stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) +stopWith ev s = return (Stop ev (text s)) + +stopWithStage :: CtEvidence -> String -> SolverStage a +stopWithStage ev s = Stage (stopWith ev s) + + +{- ********************************************************************* +* * + Inert instances: inert_qcis +* * +********************************************************************* -} + +addInertQCI :: QCInst -> TcS () +-- Add a local quantified constraint, typically arising from a type signature +addInertQCI new_qci + = do { ics <- getInertCans + ; ics1 <- add_qci ics + + -- Update given equalities. C.f updateGivenEqs + ; tclvl <- getTcLevel + ; let body_pred = qci_body new_qci + not_equality = isClassPred body_pred && not (isEqClassPred body_pred) + -- True <=> definitely not an equality + -- A qci_body like (f a) might be an equality + + ics2 | not_equality = ics1 + | otherwise = ics1 { inert_given_eq_lvl = tclvl + , inert_given_eqs = True } + + ; setInertCans ics2 } + where + add_qci :: InertCans -> TcS InertCans + -- See Note [Do not add duplicate quantified instances] + add_qci ics@(IC { inert_qcis = qcis }) + | any same_qci qcis + = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci) + ; return ics } + + | otherwise + = do { traceTcS "adding new inert quantified instance" (ppr new_qci) + ; return (ics { inert_qcis = new_qci : qcis }) } + + same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci)) + (ctEvPred (qci_ev new_qci)) + +{- Note [Do not add duplicate quantified instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an optimisation, we avoid adding duplicate quantified instances to the +inert set; we use a simple duplicate check using tcEqType for simplicity, +even though it doesn't account for superficial differences, e.g. it will count +the following two constraints as different (#22223): + + - forall a b. C a b + - forall b a. C a b + +The main logic that allows us to pick local instances, even in the presence of +duplicates, is explained in Note [Use only the best matching quantified constraint] +in GHC.Tc.Solver.Dict. +-} + +updInertDicts :: DictCt -> TcS () +updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) + = do { traceTcS "Adding inert dict" (ppr dict_ct $$ ppr cls <+> ppr tys) + + ; if | isGiven ev, Just (str_ty, _) <- isIPPred_maybe cls tys + -> -- For [G] ?x::ty, remove any dicts mentioning ?x, + -- from /both/ inert_cans /and/ inert_solved_dicts (#23761) + -- See (SIP1) and (SIP2) in Note [Shadowing of implicit parameters] + updInertSet $ \ inerts@(IS { inert_cans = ics, inert_solved_dicts = solved }) -> + inerts { inert_cans = updDicts (filterDicts (does_not_mention_ip_for str_ty)) ics + , inert_solved_dicts = filterDicts (does_not_mention_ip_for str_ty) solved } + | otherwise + -> return () + -- Add the new constraint to the inert set + ; updInertCans (updDicts (addDict dict_ct)) } + where + -- Does this class constraint or any of its superclasses mention + -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'? + does_not_mention_ip_for :: Type -> DictCt -> Bool + does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys }) + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys + -- See Note [Using typesAreApart when calling mightMentionIP] + -- in GHC.Core.Predicate + +updInertIrreds :: IrredCt -> TcS () +updInertIrreds irred + = do { tc_lvl <- getTcLevel + ; updInertCans $ addIrredToCans tc_lvl irred } + +{- ********************************************************************* +* * + Kicking out +* * +************************************************************************ +-} + + +----------------------------------------- +kickOutRewritable :: KickOutSpec -> CtFlavourRole -> TcS () +kickOutRewritable ko_spec new_fr + = do { ics <- getInertCans + ; let (kicked_out, ics') = kickOutRewritableLHS ko_spec new_fr ics + n_kicked = lengthBag kicked_out + ; setInertCans ics' + + ; unless (isEmptyBag kicked_out) $ + do { emitWork kicked_out + + -- The famapp-cache contains Given evidence from the inert set. + -- If we're kicking out Givens, we need to remove this evidence + -- from the cache, too. + ; let kicked_given_ev_vars = foldr add_one emptyVarSet kicked_out + add_one :: Ct -> VarSet -> VarSet + add_one ct vs | CtGiven (GivenCt { ctev_evar = ev_var }) <- ctEvidence ct + = vs `extendVarSet` ev_var + | otherwise = vs + + ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && + -- if this isn't true, no use looking through the constraints + not (isEmptyVarSet kicked_given_ev_vars)) $ + do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" + (ppr kicked_given_ev_vars) + ; dropFromFamAppCache kicked_given_ev_vars } + + ; csTraceTcS $ + hang (text "Kick out") + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } } + +kickOutAfterUnification :: [TcTyVar] -> TcS () +kickOutAfterUnification tv_list = case nonEmpty tv_list of + Nothing -> return () + Just tvs -> do + { let tv_set = mkVarSet tv_list + + ; n_kicked <- kickOutRewritable (KOAfterUnify tv_set) (Given, NomEq) + -- Given because the tv := xi is given; NomEq because + -- only nominal equalities are solved by unification + + -- Set the unification flag if we have done outer unifications + -- that might affect an earlier implication constraint + ; let min_tv_lvl = foldr1 minTcLevel (NE.map tcTyVarLevel tvs) + ; ambient_lvl <- getTcLevel + ; when (ambient_lvl `strictlyDeeperThan` min_tv_lvl) $ + setUnificationFlag min_tv_lvl + + ; traceTcS "kickOutAfterUnification" (ppr tvs $$ text "n_kicked =" <+> ppr n_kicked) + ; return n_kicked } + +kickOutAfterFillingCoercionHole :: CoercionHole -> TcS () +-- See Wrinkle (URW2) in Note [Unify only if the rewriter set is empty] +-- in GHC.Tc.Solver.Equality +-- +-- It's possible that this could just go ahead and unify, but could there +-- be occurs-check problems? Seems simpler just to kick out. +kickOutAfterFillingCoercionHole hole + = do { ics <- getInertCans + ; let (kicked_out, ics') = kick_out ics + n_kicked = length kicked_out + + ; unless (n_kicked == 0) $ + do { updWorkListTcS (extendWorkListRewrittenEqs kicked_out) + ; csTraceTcS $ + hang (text "Kick out, hole =" <+> ppr hole) + 2 (vcat [ text "n-kicked =" <+> int n_kicked + , text "kicked_out =" <+> ppr kicked_out + , text "Residual inerts =" <+> ppr ics' ]) } + + ; setInertCans ics' } + where + kick_out :: InertCans -> ([EqCt], InertCans) + kick_out ics@(IC { inert_eqs = eqs }) + = (eqs_to_kick, ics { inert_eqs = eqs_to_keep }) + where + (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_out_eq eqs + + kick_out_eq :: EqCt -> Bool -- True: kick out; False: keep. + kick_out_eq (EqCt { eq_ev = ev ,eq_lhs = lhs }) + | CtWanted (WantedCt { ctev_rewriters = RewriterSet rewriters }) <- ev + , TyVarLHS tv <- lhs + , isMetaTyVar tv + = hole `elementOfUniqSet` rewriters + | otherwise + = False + +-------------- +insertSafeOverlapFailureTcS :: InstanceWhat -> DictCt -> TcS () +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +insertSafeOverlapFailureTcS what item + | safeOverlap what + = return () + | otherwise + = updInertSet (\is -> is { inert_safehask = addDict item (inert_safehask is) }) + +getSafeOverlapFailures :: TcS (Bag DictCt) +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +getSafeOverlapFailures + = do { IS { inert_safehask = safehask } <- getInertSet + ; return $ foldDicts consBag safehask emptyBag } + +-------------- +updSolvedDicts :: InstanceWhat -> DictCt -> TcS () +-- Conditionally add a new item in the solved set of the monad +-- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet +updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) + | isWanted ev + , instanceReturnsDictCon what + = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName + ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName + ; let contains_callstack_or_exceptionCtx = + mightMentionIP + (const True) + -- NB: the name of the call-stack IP is irrelevant + -- e.g (?foo :: CallStack) counts! + (is_callstack <||> is_exceptionCtx) + cls tys + -- See Note [Don't add HasCallStack constraints to the solved set] + ; unless contains_callstack_or_exceptionCtx $ + do { traceTcS "updSolvedDicts:" $ ppr dict_ct + ; updInertSet $ \ ics -> + ics { inert_solved_dicts = addSolvedDict dict_ct (inert_solved_dicts ics) } + } } + | otherwise + = return () + where + + -- Return a predicate that decides whether a type is CallStack + -- or ExceptionContext, accounting for e.g. type family reduction, as + -- per Note [Using typesAreApart when calling mightMentionIP]. + -- + -- See Note [Using isCallStackTy in mightMentionIP]. + is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool) + is_tyConTy is_eq tc_name + = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name + ; case mb_tc of + Just tc -> + return $ \ ty -> not (typesAreApart ty (mkTyConTy tc)) + Nothing -> + return is_eq + } + +{- Note [Don't add HasCallStack constraints to the solved set] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must not add solved Wanted dictionaries that mention HasCallStack constraints +to the solved set, or we might fail to accumulate the proper call stack, as was +reported in #25529. + +Recall that HasCallStack constraints (and the related HasExceptionContext +constraints) are implicit parameter constraints, and are accumulated as per +Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence. + +When we solve a Wanted that contains a HasCallStack constraint, we don't want +to cache the result, because re-using that solution means re-using the call-stack +in a different context! + +See also Note [Shadowing of implicit parameters], which deals with a similar +problem with Given implicit parameter constraints. + +Note [Using isCallStackTy in mightMentionIP] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To implement Note [Don't add HasCallStack constraints to the solved set], +we need to check whether a constraint contains a HasCallStack or HasExceptionContext +constraint. We do this using the 'mentionsIP' function, but as per +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do: + + mightMentionIP + (const True) -- (ignore the implicit parameter string) + (isCallStackTy <||> isExceptionContextTy) + +because this does not account for e.g. a type family that reduces to CallStack. +The predicate we want to use instead is: + + \ ty -> not (typesAreApart ty callStackTy && typesAreApart ty exceptionContextTy) + +However, this is made difficult by the fact that CallStack and ExceptionContext +are not wired-in types; they are only known-key. This means we must look them +up using 'tcLookupTyCon'. However, this might fail, e.g. if we are in the middle +of typechecking ghc-internal and these data-types have not been typechecked yet! + +In that case, we simply fall back to the naive 'isCallStackTy'/'isExceptionContextTy' +logic. + +Note that it would be somewhat painful to wire-in ExceptionContext: at the time +of writing (March 2025), this would require wiring in the ExceptionAnnotation +class, as well as SomeExceptionAnnotation, which is a data type with existentials. +-} + +getSolvedDicts :: TcS (DictMap DictCt) +getSolvedDicts = do { ics <- getInertSet; return (inert_solved_dicts ics) } + +setSolvedDicts :: DictMap DictCt -> TcS () +setSolvedDicts solved_dicts + = updInertSet $ \ ics -> + ics { inert_solved_dicts = solved_dicts } + +{- ********************************************************************* +* * + Other inert-set operations +* * +********************************************************************* -} + +updInertSet :: (InertSet -> InertSet) -> TcS () +-- Modify the inert set with the supplied function +updInertSet upd_fn + = do { is_var <- getInertSetRef + ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var + ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } + +getInertCans :: TcS InertCans +getInertCans = do { inerts <- getInertSet; return (inert_cans inerts) } + +setInertCans :: InertCans -> TcS () +setInertCans ics = updInertSet $ \ inerts -> inerts { inert_cans = ics } + +updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a +-- Modify the inert set with the supplied function +updRetInertCans upd_fn + = do { is_var <- getInertSetRef + ; wrapTcS (do { inerts <- TcM.readTcRef is_var + ; let (res, cans') = upd_fn (inert_cans inerts) + ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) + ; return res }) } + +updInertCans :: (InertCans -> InertCans) -> TcS () +-- Modify the inert set with the supplied function +updInertCans upd_fn + = updInertSet $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } + +getInertEqs :: TcS InertEqs +getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } + +getInnermostGivenEqLevel :: TcS TcLevel +getInnermostGivenEqLevel = do { inert <- getInertCans + ; return (inert_given_eq_lvl inert) } + +-- | Retrieves all insoluble constraints from the inert set, +-- specifically including Given constraints. +-- +-- This consists of: +-- +-- - insoluble equalities, such as @Int ~# Bool@; +-- - constraints that are top-level custom type errors, of the form +-- @TypeError msg@, but not constraints such as @Eq (TypeError msg)@ +-- in which the type error is nested; +-- - unsatisfiable constraints, of the form @Unsatisfiable msg@. +-- +-- The inclusion of Givens is important for pattern match warnings, as we +-- want to consider a pattern match that introduces insoluble Givens to be +-- redundant (see Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver). +getInertInsols :: TcS Cts +getInertInsols + = do { inert <- getInertCans + ; let insols = filterBag insolubleIrredCt (inert_irreds inert) + unsats = findDictsByTyConKey (inert_dicts inert) unsatisfiableClassNameKey + ; return $ fmap CDictCan unsats `unionBags` fmap CIrredCan insols } + +getInertGivens :: TcS [Ct] +-- Returns the Given constraints in the inert set +getInertGivens + = do { inerts <- getInertCans + ; let all_cts = foldIrreds ((:) . CIrredCan) (inert_irreds inerts) + $ foldDicts ((:) . CDictCan) (inert_dicts inerts) + $ foldFunEqs ((:) . CEqCan) (inert_funeqs inerts) + $ foldTyEqs ((:) . CEqCan) (inert_eqs inerts) + $ [] + ; return (filter isGivenCt all_cts) } + +getPendingGivenScs :: TcS [Ct] +-- Find all inert Given dictionaries, or quantified constraints, such that +-- 1. cc_pend_sc flag has fuel strictly > 0 +-- 2. belongs to the current level +-- For each such dictionary: +-- * Return it (with unmodified cc_pend_sc) in sc_pending +-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand +-- to record that we have expanded superclasses for this dict +getPendingGivenScs = do { lvl <- getTcLevel + ; updRetInertCans (get_sc_pending lvl) } + +get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) +get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_qcis = insts }) + = assertPpr (all isGivenCt sc_pending) (ppr sc_pending) + -- When getPendingScDics is called, + -- there are never any Wanteds in the inert set + (sc_pending, ic { inert_dicts = dicts', inert_qcis = insts' }) + where + sc_pending = sc_pend_insts ++ map CDictCan sc_pend_dicts + + sc_pend_dicts :: [DictCt] + sc_pend_dicts = foldDicts get_pending dicts [] + dicts' = foldr exhaustAndAdd dicts sc_pend_dicts + + (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts + + exhaustAndAdd :: DictCt -> DictMap DictCt -> DictMap DictCt + exhaustAndAdd ct dicts = addDict (ct {di_pend_sc = doNotExpand}) dicts + -- Exhaust the fuel for this constraint before adding it as + -- we don't want to expand these constraints again + + get_pending :: DictCt -> [DictCt] -> [DictCt] -- Get dicts with cc_pend_sc > 0 + get_pending dict dicts + | isPendingScDictCt dict + , belongs_to_this_level (dictCtEvidence dict) + = dict : dicts + | otherwise + = dicts + + get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) + get_pending_inst cts qci@(QCI { qci_ev = ev }) + | Just qci' <- pendingScInst_maybe qci + , belongs_to_this_level ev + = (CQuantCan qci : cts, qci') + -- qci' have their fuel exhausted + -- we don't want to expand these constraints again + -- qci is expanded + | otherwise + = (cts, qci) + + belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) `sameDepthAs` this_lvl + -- We only want Givens from this level; see (3a) in + -- Note [The superclass story] in GHC.Tc.Solver.Dict + +getUnsolvedInerts :: TcS Cts -- All simple constraints +-- Return all the unsolved [Wanted] constraints +-- +-- Post-condition: the returned simple constraints are all fully zonked +-- (because they come from the inert set) +-- the unsolved implics may not be +getUnsolvedInerts + = do { IC { inert_eqs = tv_eqs + , inert_funeqs = fun_eqs + , inert_irreds = irreds + , inert_dicts = idicts + , inert_qcis = qcis + } <- getInertCans + + ; let unsolved_tv_eqs = foldTyEqs (add_if_unsolved CEqCan) tv_eqs emptyCts + unsolved_fun_eqs = foldFunEqs (add_if_unsolved CEqCan) fun_eqs emptyCts + unsolved_irreds = foldr (add_if_unsolved CIrredCan) emptyCts irreds + unsolved_dicts = foldDicts (add_if_unsolved CDictCan) idicts emptyCts + unsolved_qcis = foldr (add_if_unsolved CQuantCan) emptyCts qcis + + ; traceTcS "getUnsolvedInerts" $ + vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs + , text "fun eqs =" <+> ppr unsolved_fun_eqs + , text "dicts =" <+> ppr unsolved_dicts + , text "irreds =" <+> ppr unsolved_irreds ] + + ; return ( unsolved_tv_eqs `unionBags` + unsolved_fun_eqs `unionBags` + unsolved_irreds `unionBags` + unsolved_dicts `unionBags` + unsolved_qcis ) } + where + add_if_unsolved :: (a -> Ct) -> a -> Cts -> Cts + add_if_unsolved mk_ct thing cts + | isWantedCt ct = ct `consCts` cts + | otherwise = cts + where + ct = mk_ct thing + + +getHasGivenEqs :: TcLevel -- TcLevel of this implication + -> TcS ( HasGivenEqs -- are there Given equalities? + , InertIrreds ) -- Insoluble equalities arising from givens +-- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet +getHasGivenEqs tclvl + = do { inerts@(IC { inert_irreds = irreds + , inert_given_eqs = given_eqs + , inert_given_eq_lvl = ge_lvl }) + <- getInertCans + ; let given_insols = filterBag insoluble_given_equality irreds + -- Specifically includes ones that originated in some + -- outer context but were refined to an insoluble by + -- a local equality; so no level-check needed + + -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and + -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + has_ge | ge_lvl `sameDepthAs` tclvl = MaybeGivenEqs + | given_eqs = LocalGivenEqs + | otherwise = NoGivenEqs + + ; traceTcS "getHasGivenEqs" $ + vcat [ text "given_eqs:" <+> ppr given_eqs + , text "ge_lvl:" <+> ppr ge_lvl + , text "ambient level:" <+> ppr tclvl + , text "Inerts:" <+> ppr inerts + , text "Insols:" <+> ppr given_insols] + ; return (has_ge, given_insols) } + where + insoluble_given_equality :: IrredCt -> Bool + -- Check for unreachability; specifically do not include UserError/Unsatisfiable + insoluble_given_equality (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason && isGiven ev + +removeInertCts :: [Ct] -> InertCans -> InertCans +-- ^ Remove inert constraints from the 'InertCans', for use when a +-- typechecker plugin wishes to discard a given. +removeInertCts cts icans = foldl' removeInertCt icans cts + +removeInertCt :: InertCans -> Ct -> InertCans +removeInertCt is ct + = case ct of + CDictCan dict_ct -> is { inert_dicts = delDict dict_ct (inert_dicts is) } + CEqCan eq_ct -> delEq eq_ct is + CIrredCan ir_ct -> delIrred ir_ct is + CQuantCan {} -> panic "removeInertCt: CQuantCan" + CNonCanonical {} -> panic "removeInertCt: CNonCanonical" + +-- | Looks up a family application in the inerts. +lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? + -> TyCon -> [Type] -> TcS (Maybe EqCt) +lookupFamAppInert rewrite_pred fam_tc tys + = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getInertSet + ; return (lookup_inerts inert_funeqs) } + where + lookup_inerts inert_funeqs + = case findFunEq inert_funeqs fam_tc tys of + Nothing -> Nothing + Just (ecl :: [EqCt]) -> find (rewrite_pred . eqCtFlavourRole) ecl + +--------------------------- +lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction) +lookupFamAppCache fam_tc tys + = do { IS { inert_famapp_cache = famapp_cache } <- getInertSet + ; case findFunEq famapp_cache fam_tc tys of + result@(Just redn) -> + do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys) + , ppr redn ]) + ; return result } + Nothing -> return Nothing } + +extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS () +-- NB: co :: rhs ~ F tys, to match expectations of rewriter +extendFamAppCache tc xi_args stuff@(Reduction _ ty) + = do { dflags <- getDynFlags + ; when (gopt Opt_FamAppCache dflags) $ + do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args + , ppr ty ]) + ; updInertSet $ \ is@(IS { inert_famapp_cache = fc }) -> + is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } + +-- Remove entries from the cache whose evidence mentions variables in the +-- supplied set +dropFromFamAppCache :: VarSet -> TcS () +dropFromFamAppCache varset + = updInertSet (\inerts@(IS { inert_famapp_cache = famapp_cache }) -> + inerts { inert_famapp_cache = filterTcAppMap check famapp_cache }) + where + check :: Reduction -> Bool + check redn + = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) + +{- +************************************************************************ +* * +* The TcS solver monad * +* * +************************************************************************ + +Note [The TcS monad] +~~~~~~~~~~~~~~~~~~~~ +The TcS monad is a weak form of the main Tc monad + +All you can do is + * fail + * allocate new variables + * fill in evidence variables + +Filling in a dictionary evidence variable means to create a binding +for it, so TcS carries a mutable location where the binding can be +added. This is initialised from the innermost implication constraint. +-} + +-- | The mode for the constraint solving monad. +data TcSMode + = TcSMode -- See Note [TcSMode], where each field is documented + { tcsmResumable :: Bool + -- ^ Do not restore type-equality cycles + , tcsmEarlyAbort :: Bool + -- ^ Abort early on insoluble constraints + , tcsmSkipOverlappable :: Bool + -- ^ Do not select an OVERLAPPABLE instance + , tcsmFullySolveQCIs :: Bool + -- ^ Fully solve quantified constraints + } + +vanillaTcSMode :: TcSMode +vanillaTcSMode = TcSMode { tcsmResumable = False + , tcsmEarlyAbort = False + , tcsmSkipOverlappable = False + , tcsmFullySolveQCIs = False } + +instance Outputable TcSMode where + ppr (TcSMode { tcsmResumable = pm, tcsmEarlyAbort = ea + , tcsmSkipOverlappable = so, tcsmFullySolveQCIs = fs }) + = text "TcSMode" <> (braces $ cat $ punctuate comma $ catMaybes $ + [ pp_one pm "Resumable", pp_one ea "EarlyAbort" + , pp_one so "SkipOverlappable", pp_one fs "FullySolveQCIs" ]) + -- We get something like TcSMode{EarlyAbort,FullySolveQCIs}, + -- mentioning just the flags that are on + where + pp_one True s = Just (text s) + pp_one False _ = Nothing + +{- Note [TcSMode] +~~~~~~~~~~~~~~~~~ +The constraint solver can operate in different modes: + +* `tcsmResumable`: Used by the pattern match overlap checker. The idea is that + the returned InertSet will later be resumed, so we do not want to restore + type-equality cycles See also Note [Type equality cycles] in GHC.Tc.Solver.Equality + +* `tcsmEarlyAbort`: Abort (fail in the monad) as soon as we come across an + insoluble constraint. This is used to fail-fast when checking for hole-fits. + See Note [Speeding up valid hole-fits]. + +* `tcsmSkipOverlappable`: don't use OVERLAPPABLE instances. Used by the + short-cut solver. See Note [Shortcut solving] in GHC.Tc.Solver.Dict + +* `tcsmFullSolveQCIs`: fully solve quantified constraints, or leave them alone. + Used (only) for SPECIALISE pragmas; + see (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig +-} + +data TcSEnv + = TcSEnv { + tcs_ev_binds :: EvBindsVar, + + tcs_unified :: IORef Int, + -- The number of unification variables we have filled + -- The important thing is whether it is non-zero, so it + -- could equally well be a Bool instead of an Int. + + tcs_unif_lvl :: IORef (Maybe TcLevel), + -- The Unification Level Flag + -- Outermost level at which we have unified a meta tyvar + -- Starts at Nothing, then (Just i), then (Just j) where j TcM a } + deriving (Functor) + +instance MonadFix TcS where + mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) + +-- | Smart constructor for 'TcS', as describe in Note [The one-shot state +-- monad trick] in "GHC.Utils.Monad". +mkTcS :: (TcSEnv -> TcM a) -> TcS a +mkTcS f = TcS (oneShot f) + +instance Applicative TcS where + pure x = mkTcS $ \_ -> return x + (<*>) = ap + +instance Monad TcS where + m >>= k = mkTcS $ \ebs -> do + unTcS m ebs >>= (\r -> unTcS (k r) ebs) + +instance MonadIO TcS where + liftIO act = TcS $ \_env -> liftIO act + +instance MonadFail TcS where + fail err = mkTcS $ \_ -> fail err + +instance MonadUnique TcS where + getUniqueSupplyM = wrapTcS getUniqueSupplyM + +instance HasModule TcS where + getModule = wrapTcS getModule + +instance MonadThings TcS where + lookupThing n = wrapTcS (lookupThing n) + +-- Basic functionality +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +wrapTcS :: TcM a -> TcS a +-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, +-- and TcS is supposed to have limited functionality +wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds + +liftZonkTcS :: ZonkM a -> TcS a +liftZonkTcS = wrapTcS . TcM.liftZonkM + +wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a +wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env) + +wrapErrTcS :: TcM a -> TcS a +-- The thing wrapped should just fail +-- There's no static check; it's up to the user +-- Having a variant for each error message is too painful +wrapErrTcS = wrapTcS + +wrapWarnTcS :: TcM a -> TcS a +-- The thing wrapped should just add a warning, or no-op +-- There's no static check; it's up to the user +wrapWarnTcS = wrapTcS + +panicTcS :: SDoc -> TcS a +failTcS :: TcRnMessage -> TcS a +warnTcS, addErrTcS :: TcRnMessage -> TcS () +failTcS = wrapTcS . TcM.failWith +warnTcS msg = wrapTcS (TcM.addDiagnostic msg) +addErrTcS = wrapTcS . TcM.addErr +panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc + +tryEarlyAbortTcS :: TcS () +-- Abort (fail in the monad) if the mode is TcSEarlyAbort +tryEarlyAbortTcS + = mkTcS (\env -> when (tcsmEarlyAbort (tcs_mode env)) TcM.failM) + +-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'. +ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS () +ctLocWarnTcS loc msg = wrapTcS $ TcM.setCtLocM loc $ TcM.addDiagnostic msg + +traceTcS :: String -> SDoc -> TcS () +traceTcS herald doc = wrapTcS (TcM.traceTc herald doc) +{-# INLINE traceTcS #-} -- see Note [INLINE conditional tracing utilities] + +runTcPluginTcS :: TcPluginM a -> TcS a +runTcPluginTcS = wrapTcS . runTcPluginM + +instance HasDynFlags TcS where + getDynFlags = wrapTcS getDynFlags + +getGlobalRdrEnvTcS :: TcS GlobalRdrEnv +getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv + +bumpStepCountTcS :: TcS () +bumpStepCountTcS = mkTcS $ \env -> + do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } + +csTraceTcS :: SDoc -> TcS () +csTraceTcS doc + = wrapTcS $ csTraceTcM (return doc) +{-# INLINE csTraceTcS #-} -- see Note [INLINE conditional tracing utilities] + +traceFireTcS :: CtEvidence -> SDoc -> TcS () +-- Dump a rule-firing trace +traceFireTcS ev doc + = mkTcS $ \env -> csTraceTcM $ + do { n <- TcM.readTcRef (tcs_count env) + ; tclvl <- TcM.getTcLevel + ; return (hang (text "Step" <+> int n + <> brackets (text "l:" <> ppr tclvl <> comma <> + text "d:" <> ppr (ctLocDepth (ctEvLoc ev))) + <+> doc <> colon) + 4 (ppr ev)) } +{-# INLINE traceFireTcS #-} -- see Note [INLINE conditional tracing utilities] + +csTraceTcM :: TcM SDoc -> TcM () +-- Constraint-solver tracing, -ddump-cs-trace +csTraceTcM mk_doc + = do { logger <- getLogger + ; when ( logHasDumpFlag logger Opt_D_dump_cs_trace + || logHasDumpFlag logger Opt_D_dump_tc_trace) + ( do { msg <- mk_doc + ; TcM.dumpTcRn False + Opt_D_dump_cs_trace + "" FormatText + msg }) } +{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] + +runTcS :: TcS a -- What to run + -> TcM (a, EvBindMap) +runTcS tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; res <- runTcSWithEvBinds ev_binds_var tcs + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; return (res, ev_binds) } + +-- | This variant of 'runTcS' will immediately fail upon encountering an +-- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage +-- site does not need the ev_binds, so we do not return them. +runTcSEarlyAbort :: TcS a -> TcM a +runTcSEarlyAbort tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds' mode ev_binds_var tcs } + where + mode = vanillaTcSMode { tcsmEarlyAbort = True } + +-- | This can deal only with equality constraints. +runTcSEqualities :: TcS a -> TcM a +runTcSEqualities thing_inside + = do { ev_binds_var <- TcM.newNoTcEvBinds + ; runTcSWithEvBinds ev_binds_var thing_inside } + +-- | A variant of 'runTcS' that takes and returns an 'InertSet' for +-- later resumption of the 'TcS' session. +runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) +runTcSInerts inerts tcs + = do { ev_binds_var <- TcM.newTcEvBinds + ; runTcSWithEvBinds' (vanillaTcSMode { tcsmResumable = True }) + ev_binds_var $ + do { setInertSet inerts + ; a <- tcs + ; new_inerts <- getInertSet + ; return (a, new_inerts) } } + +runTcSWithEvBinds :: EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds = runTcSWithEvBinds' vanillaTcSMode + +runTcSWithEvBinds' :: TcSMode + -> EvBindsVar + -> TcS a + -> TcM a +runTcSWithEvBinds' mode ev_binds_var thing_inside + = do { unified_var <- TcM.newTcRef 0 + ; step_count <- TcM.newTcRef 0 + + -- Make a fresh, empty inert set + -- Subtle point: see (TGE6) in Note [Tracking Given equalities] + -- in GHC.Tc.Solver.InertSet + ; tc_lvl <- TcM.getTcLevel + ; inert_var <- TcM.newTcRef (emptyInertSet tc_lvl) + + ; wl_var <- TcM.newTcRef emptyWorkList + ; unif_lvl_var <- TcM.newTcRef Nothing + ; let env = TcSEnv { tcs_ev_binds = ev_binds_var + , tcs_unified = unified_var + , tcs_unif_lvl = unif_lvl_var + , tcs_count = step_count + , tcs_inerts = inert_var + , tcs_mode = mode + , tcs_worklist = wl_var } + + -- Run the computation + ; res <- unTcS thing_inside env + + ; count <- TcM.readTcRef step_count + ; when (count > 0) $ + csTraceTcM $ return (text "Constraint solver steps =" <+> int count) + + -- Restore tyvar cycles: see Note [Type equality cycles] in + -- GHC.Tc.Solver.Equality + -- But /not/ when tcsmResumable is set: see Note [TcSMode] + ; unless (tcsmResumable mode) $ + do { inert_set <- TcM.readTcRef inert_var + ; restoreTyVarCycles inert_set } + +#if defined(DEBUG) + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; checkForCyclicBinds ev_binds +#endif + + ; return res } + +---------------------------- +#if defined(DEBUG) +checkForCyclicBinds :: EvBindMap -> TcM () +checkForCyclicBinds ev_binds_map + | null cycles + = return () + | null coercion_cycles + = TcM.traceTc "Cycle in evidence binds" $ ppr cycles + | otherwise + = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles + where + ev_binds = evBindMapBinds ev_binds_map + + cycles :: [[EvBind]] + cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges] + + coercion_cycles = [c | c <- cycles, any is_co_bind c] + is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b) + + edges :: [ Node EvVar EvBind ] + edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (nestedEvIdsOfTerm rhs)) + | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic even + -- if the edges are in nondeterministic order as explained in + -- Note [Deterministic SCC] in GHC.Data.Graph.Directed. +#endif + +---------------------------- +setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a +setEvBindsTcS ref (TcS thing_inside) + = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) + +setTcLevelTcS :: TcLevel -> TcS a -> TcS a +setTcLevelTcS lvl (TcS thing_inside) + = TcS $ \ env -> TcM.setTcLevel lvl (thing_inside env) + +nestImplicTcS :: EvBindsVar + -> TcLevel -> TcS a + -> TcS a +nestImplicTcS ev_binds_var inner_tclvl (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) -> + do { inerts <- TcM.readTcRef old_inert_var + + -- Initialise the inert_cans from the inert_givens of the parent + -- so that the child is not polluted with the parent's inert Wanteds + -- See Note [trySolveImplication] in GHC.Tc.Solver.Solve + -- All other InertSet fields are inherited + ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack + (inert_cycle_breakers inerts) + , inert_cans = (inert_givens inerts) + { inert_given_eqs = False } } + ; new_inert_var <- TcM.newTcRef nest_inert + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_ev_binds = ev_binds_var + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + ; res <- TcM.setTcLevel inner_tclvl $ + thing_inside nest_env + + ; out_inert_set <- TcM.readTcRef new_inert_var + ; restoreTyVarCycles out_inert_set + +#if defined(DEBUG) + -- Perform a check that the thing_inside did not cause cycles + ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var + ; checkForCyclicBinds ev_binds +#endif + ; return res } + +nestTcS :: TcS a -> TcS a +-- Use the current untouchables, augmenting the current +-- evidence bindings, and solved dictionaries +-- But have no effect on the InertCans, or on the inert_famapp_cache +-- (we want to inherit the latter from processing the Givens) +nestTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> + do { inerts <- TcM.readTcRef inerts_var + ; new_inert_var <- TcM.newTcRef inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + -- Inherit tcs_ev_binds from caller + + ; res <- thing_inside nest_env + + ; new_inerts <- TcM.readTcRef new_inert_var + ; TcM.updTcRef inerts_var (`updateInertsWith` new_inerts) + + ; return res } + +tryShortCutTcS :: TcS Bool -> TcS Bool +-- Like nestTcS, but +-- (a) be a no-op if the nested computation returns False +-- (b) if (but only if) success, propagate nested bindings to the caller +-- Use only by the short-cut solver; +-- see Note [Shortcut solving] in GHC.Tc.Solver.Dict +tryShortCutTcS (TcS thing_inside) + = TcS $ \ env@(TcSEnv { tcs_mode = mode + , tcs_inerts = inerts_var + , tcs_ev_binds = old_ev_binds_var }) -> + do { -- Initialise a fresh inert set, with no Givens and no Wanteds + -- (i.e. empty `inert_cans`) + -- But inherit all the InertSet cache fields; in particular + -- * the given_eq_lvl, so we don't accidentally unify a + -- unification variable from outside a GADT match + -- * the `solved_dicts`; see wrinkle (SCS3) of Note [Shortcut solving] + -- * the `famapp_cache`; similarly + old_inerts <- TcM.readTcRef inerts_var + ; let given_eq_lvl = inert_given_eq_lvl (inert_cans old_inerts) + new_inerts = old_inerts { inert_cans = emptyInertCans given_eq_lvl } + ; new_inert_var <- TcM.newTcRef new_inerts + + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; new_ev_binds_var <- TcM.cloneEvBindsVar old_ev_binds_var + ; let nest_env = env { tcs_mode = mode { tcsmSkipOverlappable = True } + , tcs_ev_binds = new_ev_binds_var + , tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + + ; TcM.traceTc "tryTcS {" $ + vcat [ text "old_ev_binds:" <+> ppr old_ev_binds_var + , text "new_ev_binds:" <+> ppr new_ev_binds_var + , ppr old_inerts ] + ; solved <- thing_inside nest_env + ; TcM.traceTc "tryTcS }" (ppr solved) + + ; if not solved + then return False + else do { -- Successfully solved + -- Add the new bindings to the existing ones + ; TcM.updTcEvBinds old_ev_binds_var new_ev_binds_var + + -- Update the existing inert set + ; new_inerts <- TcM.readTcRef new_inert_var + ; TcM.updTcRef inerts_var (`updateInertsWith` new_inerts) + + ; TcM.traceTc "tryTcS update" (ppr (inert_solved_dicts new_inerts)) + + ; return True } } + +updateInertsWith :: InertSet -> InertSet -> InertSet +-- Update the current inert set with bits from a nested solve, +-- that finished with a new inert set +-- In particular, propagate: +-- - solved dictionaires; see Note [Propagate the solved dictionaries] +-- - Safe Haskell failures +updateInertsWith current_inerts + (IS { inert_solved_dicts = new_solved + , inert_safehask = new_safehask }) + = current_inerts { inert_solved_dicts = new_solved + , inert_safehask = new_safehask } + +{- Note [Propagate the solved dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really quite important that nestTcS does not discard the solved +dictionaries from the thing_inside. +Consider + Eq [a] + forall b. empty => Eq [a] +We solve the simple (Eq [a]), under nestTcS, and then turn our attention to +the implications. It's definitely fine to use the solved dictionaries on +the inner implications, and it can make a significant performance difference +if you do so. +-} + +-- Getters and setters of GHC.Tc.Utils.Env fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +getTcSMode :: TcS TcSMode +getTcSMode = TcS (return . tcs_mode) + +setTcSMode :: TcSMode -> TcS a -> TcS a +setTcSMode mode thing_inside + = TcS (\env -> unTcS thing_inside (env { tcs_mode = mode })) + +getUnifiedRef :: TcS (IORef Int) +getUnifiedRef = TcS (return . tcs_unified) + +-- Getter of inerts and worklist +getInertSetRef :: TcS (IORef InertSet) +getInertSetRef = TcS (return . tcs_inerts) + +getInertSet :: TcS InertSet +getInertSet = getInertSetRef >>= readTcRef + +setInertSet :: InertSet -> TcS () +setInertSet is = do { r <- getInertSetRef; writeTcRef r is } + + +newTcRef :: a -> TcS (TcRef a) +newTcRef x = wrapTcS (TcM.newTcRef x) + +readTcRef :: TcRef a -> TcS a +readTcRef ref = wrapTcS (TcM.readTcRef ref) + +writeTcRef :: TcRef a -> a -> TcS () +writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) + +updTcRef :: TcRef a -> (a->a) -> TcS () +updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) + +getTcEvBindsVar :: TcS EvBindsVar +getTcEvBindsVar = TcS (return . tcs_ev_binds) + +getTcLevel :: TcS TcLevel +getTcLevel = wrapTcS TcM.getTcLevel + +getTcEvTyCoVars :: EvBindsVar -> TcS [TcCoercion] +getTcEvTyCoVars ev_binds_var + = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var + +getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap +getTcEvBindsMap ev_binds_var + = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var + +setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () +setTcEvBindsMap ev_binds_var binds + = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds + +unifyTyVar :: TcTyVar -> TcType -> TcS () +-- Unify a meta-tyvar with a type +-- We keep track of how many unifications have happened in tcs_unified, +-- +-- We should never unify the same variable twice! +unifyTyVar tv ty + = assertPpr (isMetaTyVar tv) (ppr tv) $ + TcS $ \ env -> + do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) + ; TcM.liftZonkM $ TcM.writeMetaTyVar tv ty + ; TcM.updTcRef (tcs_unified env) (+1) } + +reportUnifications :: TcS a -> TcS (Int, a) +-- Record how many unifications are done by thing_inside +-- We could return a Bool instead of an Int; +-- all that matters is whether it is no-zero +reportUnifications (TcS thing_inside) + = TcS $ \ env -> + do { inner_unified <- TcM.newTcRef 0 + ; res <- thing_inside (env { tcs_unified = inner_unified }) + ; n_unifs <- TcM.readTcRef inner_unified + ; TcM.updTcRef (tcs_unified env) (+ n_unifs) + ; return (n_unifs, res) } + +getDefaultInfo :: TcS (DefaultEnv, Bool) +getDefaultInfo = wrapTcS TcM.tcGetDefaultTys + + +-- Just get some environments needed for instance looking up and matching +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +getInstEnvs :: TcS InstEnvs +getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs + +getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) +getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs + +getTopEnv :: TcS HscEnv +getTopEnv = wrapTcS $ TcM.getTopEnv + +getGblEnv :: TcS TcGblEnv +getGblEnv = wrapTcS $ TcM.getGblEnv + +getLclEnv :: TcS TcLclEnv +getLclEnv = wrapTcS $ TcM.getLclEnv + +setSrcSpan :: RealSrcSpan -> TcS a -> TcS a +setSrcSpan ss = wrap2TcS (TcM.setSrcSpan (RealSrcSpan ss mempty)) + +tcLookupClass :: Name -> TcS Class +tcLookupClass c = wrapTcS $ TcM.tcLookupClass c + +tcLookupId :: Name -> TcS Id +tcLookupId n = wrapTcS $ TcM.tcLookupId n + +tcLookupTyCon :: Name -> TcS TyCon +tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n + +-- Any use of this function is a bit suspect, because it violates the +-- pure veneer of TcS. But it's just about warnings around unused imports +-- and local constructors (GHC will issue fewer warnings than it otherwise +-- might), so it's not worth losing sleep over. +recordUsedGREs :: Bag GlobalRdrElt -> TcS () +recordUsedGREs gres + = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list + -- If a newtype constructor was imported, don't warn about not + -- importing it... + ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list } + -- ...and similarly, if a newtype constructor was defined in the same + -- module, don't warn about it being unused. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. + + where + gre_list = bagToList gres + +-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +checkWellLevelledDFun :: CtLoc -> InstanceWhat -> PredType -> TcS () +-- Check that we do not try to use an instance before it is available. E.g. +-- instance Eq T where ... +-- f x = $( ... (\(p::T) -> p == p)... ) +-- Here we can't use the equality function from the instance in the splice + +checkWellLevelledDFun loc what pred + = do + mbind_lvl <- checkWellLevelledInstanceWhat what + case mbind_lvl of + Just (bind_lvls, is_local) -> + wrapTcS $ TcM.setCtLocM loc $ do + { use_lvl <- thLevelIndex <$> TcM.getThLevel + ; dflags <- getDynFlags + ; checkCrossLevelClsInst dflags (LevelCheckInstance what pred) bind_lvls use_lvl is_local } + -- If no level information is returned for an InstanceWhat, then it's safe to use + -- at any level. + Nothing -> return () + + +-- TODO: Unify this with checkCrossLevelLifting function +checkCrossLevelClsInst :: DynFlags -> LevelCheckReason + -> Set.Set ThLevelIndex -> ThLevelIndex + -> Bool -> TcM () +checkCrossLevelClsInst dflags reason bind_lvls use_lvl_idx is_local + -- If the Id is imported, then allow with ImplicitStagePersistence + | not is_local + , xopt LangExt.ImplicitStagePersistence dflags + = return () + -- NB: Do this check after the ImplicitStagePersistence check, because + -- it will do some computation to work out the levels of instances. + | use_lvl_idx `Set.member` bind_lvls = return () + -- With ImplicitStagePersistence, using later than bound is fine + | xopt LangExt.ImplicitStagePersistence dflags + , any (use_lvl_idx >=) bind_lvls = return () + | otherwise = TcM.addErrTc (TcRnBadlyLevelled reason bind_lvls use_lvl_idx Nothing ErrorWithoutFlag) + + + +-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence) +-- See Note [Well-levelled instance evidence] +checkWellLevelledInstanceWhat :: HasCallStack => InstanceWhat -> TcS (Maybe (Set.Set ThLevelIndex, Bool)) +checkWellLevelledInstanceWhat what + | TopLevInstance { iw_dfun_id = dfun_id } <- what + = Just <$> checkNameVisibleLevels (idName dfun_id) + | BuiltinTypeableInstance tc <- what + -- The typeable instance is always defined in the same module as the TyCon. + = Just <$> checkNameVisibleLevels (tyConName tc) + | otherwise = return Nothing + +-- | Check the levels at which the given name is visible, including a boolean +-- indicating if the name is local or not. +checkNameVisibleLevels :: Name -> TcS (Set.Set ThLevelIndex, Bool) +checkNameVisibleLevels name = do + cur_mod <- extractModule <$> getGblEnv + if nameIsLocalOrFrom cur_mod name + then return (Set.singleton topLevelIndex, True) + else do + lvls <- checkModuleVisibleLevels (nameModule name) + return (lvls, False) + +{- Note [Using the module graph to compute TH level visiblities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking a module M, in order to implement GHC proposal #682 +(see Note [Explicit Level Imports] in GHC.Tc.Gen.Head), we need to be able to +compute the Template Haskell levels that typeclass instances are visible at in M. + +To do this, we use the "level 0 imports" module graph, which we query via +GHC.Unit.Module.Graph.mgQueryZero. For example, if we want all modules that are +visible at level -1 from M, we do the following: + + 1. start with all the direct of M imports at level -1, i.e. the "splice imports" + 2. then look at all modules that are reachable from these using only level 0 + normal imports, using 'mgQueryZero'. + +This works precisely because, as specified in the proposal, with -XNoImplicitStagePersistence, +modules only export items at level 0. In particular, instances are only exported +at level 0. + +See the SI36 test for an illustration. +-} + +-- | Check which TH levels a module is visable at +-- +-- Used to check visibility of instances (do not use this for normal identifiers). +checkModuleVisibleLevels :: Module -> TcS (Set.Set ThLevelIndex) +checkModuleVisibleLevels check_mod = do + cur_mod <- extractModule <$> getGblEnv + hsc_env <- getTopEnv + + -- 0. The keys for the scope of the current module. + let mkKey s m = (ModuleScope (moduleToMnk m NotBoot) s) + cur_mod_scope_key s = mkKey s cur_mod + + -- 1. is_visible checks that a specific key is visible from the given level in the + -- current module. + let is_visible :: ImportLevel -> ZeroScopeKey -> Bool + is_visible s k = mgQueryZero (hsc_mod_graph hsc_env) (cur_mod_scope_key s) k + + -- 2. The key we are looking for, either the module itself in the home package or the + -- module unit id of the module we are checking. + let instance_key = if moduleUnitId check_mod `Set.member` hsc_all_home_unit_ids hsc_env + then mkKey NormalLevel check_mod + else UnitScope (moduleUnitId check_mod) + + -- 3. For each level, check if the key is visible from that level. + let lvls = [ thLevelIndexFromImportLevel lvl | lvl <- allImportLevels, is_visible lvl instance_key] + return $ Set.fromList lvls + +{- +Note [Well-levelled instance evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Evidence for instances must obey the same level restrictions as normal bindings. +In particular, it is forbidden to use an instance in a top-level splice in the +module which the instance is defined. This is because the evidence is bound at +the top-level and top-level definitions are forbidden from being using in top-level splices in +the same module. + +For example, suppose you have a function.. foo :: Show a => Code Q a -> Code Q () +then the following program is disallowed, + +``` +data T a = T a deriving (Show) + +main :: IO () +main = + let x = $$(foo [|| T () ||]) + in return () +``` + +because the `foo` function (used in a top-level splice) requires `Show T` evidence, +which is defined at the top-level and therefore fails with an error that we have violated +the stage restriction. + +``` +Main.hs:12:14: error: + • GHC stage restriction: + instance for ‘Show + (T ())’ is used in a top-level splice, quasi-quote, or annotation, + and must be imported, not defined locally + • In the expression: foo [|| T () ||] + In the Template Haskell splice $$(foo [|| T () ||]) + In the expression: $$(foo [|| T () ||]) + | +12 | let x = $$(foo [|| T () ||]) + | +``` + +Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on +`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT` +is well levelled. It's easy to know the level of `$tcT`: for imported TyCons it +will be the level of the imported TyCon Name, and for local TyCons it will be `toplevel`. + +Therefore the `InstanceWhat` type had to be extended with +a special case for `Typeable`, which recorded the TyCon the evidence was for and +could them be used to check that we were not attempting to evidence in a level incorrect +manner. + +-} + +pprEq :: TcType -> TcType -> SDoc +pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 + +isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type) +isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv) + +isFilledMetaTyVar :: TcTyVar -> TcS Bool +isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv) + +isUnfilledMetaTyVar :: TcTyVar -> TcS Bool +isUnfilledMetaTyVar tv = wrapTcS $ TcM.isUnfilledMetaTyVar tv + +zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet +zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs) + +zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] +zonkTyCoVarsAndFVList tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFVList tvs) + +zonkCo :: Coercion -> TcS Coercion +zonkCo = wrapTcS . fmap TcM.liftZonkM TcM.zonkCo + +zonkTcType :: TcType -> TcS TcType +zonkTcType ty = liftZonkTcS (TcM.zonkTcType ty) + +zonkTcTypes :: [TcType] -> TcS [TcType] +zonkTcTypes tys = liftZonkTcS (TcM.zonkTcTypes tys) + +zonkTcTyVar :: TcTyVar -> TcS TcType +zonkTcTyVar tv = liftZonkTcS (TcM.zonkTcTyVar tv) + +zonkSimples :: Cts -> TcS Cts +zonkSimples cts = liftZonkTcS (TcM.zonkSimples cts) + +zonkWC :: WantedConstraints -> TcS WantedConstraints +zonkWC wc = liftZonkTcS (TcM.zonkWC wc) + +zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar +zonkTyCoVarKind tv = liftZonkTcS (TcM.zonkTyCoVarKind tv) + +---------------------------- +pprKicked :: Int -> SDoc +pprKicked 0 = empty +pprKicked n = parens (int n <+> text "kicked out") + + +{- ********************************************************************* +* * +* The work list +* * +********************************************************************* -} + + +getTcSWorkListRef :: TcS (IORef WorkList) +getTcSWorkListRef = TcS (return . tcs_worklist) + +getWorkList :: TcS WorkList +getWorkList = do { wl_var <- getTcSWorkListRef + ; readTcRef wl_var } + +updWorkListTcS :: (WorkList -> WorkList) -> TcS () +updWorkListTcS f + = do { wl_var <- getTcSWorkListRef + ; updTcRef wl_var f } + +emitWorkNC :: [CtEvidence] -> TcS () +emitWorkNC evs + | null evs + = return () + | otherwise + = emitWork (listToBag (map mkNonCanonical evs)) + +emitWork :: Cts -> TcS () +emitWork cts + | isEmptyBag cts -- Avoid printing, among other work + = return () + | otherwise + = do { traceTcS "Emitting fresh work" (pprBag cts) + ; updWorkListTcS (extendWorkListCts cts) } + +selectNextWorkItem :: TcS (Maybe Ct) +-- Pick which work item to do next +-- See Note [Prioritise equalities] +-- +-- Postcondition: if the returned item is a Wanted equality, +-- then its rewriter set is fully zonked. +-- +-- Suppose a constraint c1 is rewritten by another, c2. When c2 +-- gets solved, c1 has no rewriters, and can be prioritised; see +-- Note [Prioritise Wanteds with empty RewriterSet] in +-- GHC.Tc.Types.Constraint wrinkle (PER1) + +-- ToDo: if wl_rw_eqs is long, we'll re-zonk it each time we pick +-- a new item from wl_rest. Bad. +selectNextWorkItem + = do { wl_var <- getTcSWorkListRef + ; wl <- readTcRef wl_var + + ; case wl of { WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest } + | ct:cts <- eqs_N -> pick_me ct (wl { wl_eqs_N = cts }) + | ct:cts <- eqs_X -> pick_me ct (wl { wl_eqs_X = cts }) + | otherwise -> try_rws [] rw_eqs + where + pick_me :: Ct -> WorkList -> TcS (Maybe Ct) + pick_me ct new_wl + = do { writeTcRef wl_var new_wl + ; return (Just ct) } + -- NB: no need for checkReductionDepth (ctLoc ct) (ctPred ct) + -- This is done by GHC.Tc.Solver.Dict.chooseInstance + + -- try_rws looks through rw_eqs to find one that has an empty + -- rewriter set, after zonking. If none such, call try_rest. + try_rws acc (ct:cts) + = do { ct' <- liftZonkTcS (TcM.zonkCtRewriterSet ct) + ; if ctHasNoRewriters ct' + then pick_me ct' (wl { wl_rw_eqs = cts ++ acc }) + else try_rws (ct':acc) cts } + try_rws acc [] = try_rest acc + + try_rest zonked_rws + | ct:cts <- rest = pick_me ct (wl { wl_rw_eqs = zonked_rws, wl_rest = cts }) + | ct:cts <- zonked_rws = pick_me ct (wl { wl_rw_eqs = cts }) + | otherwise = return Nothing + } } + + +pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) +-- Push the level and run thing_inside +-- However, thing_inside should not generate any work items +#if defined(DEBUG) +pushLevelNoWorkList err_doc (TcS thing_inside) + = TcS (\env -> TcM.pushTcLevelM $ + thing_inside (env { tcs_worklist = wl_panic }) + ) + where + wl_panic = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc + -- This panic checks that the thing-inside + -- does not emit any work-list constraints +#else +pushLevelNoWorkList _ (TcS thing_inside) + = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check +#endif + + +{- ********************************************************************* +* * +* The Unification Level Flag * +* * +********************************************************************* -} + +{- Note [The Unification Level Flag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a deep tree of implication constraints + forall[1] a. -- Outer-implic + C alpha[1] -- Simple + forall[2] c. ....(C alpha[1]).... -- Implic-1 + forall[2] b. ....(alpha[1] ~ Int).... -- Implic-2 + +The (C alpha) is insoluble until we know alpha. We solve alpha +by unifying alpha:=Int somewhere deep inside Implic-2. But then we +must try to solve the Outer-implic all over again. This time we can +solve (C alpha) both in Outer-implic, and nested inside Implic-1. + +When should we iterate solving a level-n implication? +Answer: if any unification of a tyvar at level n takes place + in the ic_implics of that implication. + +* What if a unification takes place at level n-1? Then don't iterate + level n, because we'll iterate level n-1, and that will in turn iterate + level n. + +* What if a unification takes place at level n, in the ic_simples of + level n? No need to track this, because the kick-out mechanism deals + with it. (We can't drop kick-out in favour of iteration, because kick-out + works for skolem-equalities, not just unifications.) + +So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps +track of + - Whether any unifications at all have taken place (Nothing => no unifications) + - If so, what is the outermost level that has seen a unification (Just lvl) + +The iteration is done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver. + +It helpful not to iterate unless there is a chance of progress. #8474 is +an example: + + * There's a deeply-nested chain of implication constraints. + ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int + + * From the innermost one we get a [W] alpha[1] ~ Int, + so we can unify. + + * It's better not to iterate the inner implications, but go all the + way out to level 1 before iterating -- because iterating level 1 + will iterate the inner levels anyway. + +(In the olden days when we "floated" thse Derived constraints, this was +much, much more important -- we got exponential behaviour, as each iteration +produced the same Derived constraint.) +-} + + +resetUnificationFlag :: TcS Bool +-- We are at ambient level i +-- If the unification flag = Just i, reset it to Nothing and return True +-- Otherwise leave it unchanged and return False +resetUnificationFlag + = TcS $ \env -> + do { let ref = tcs_unif_lvl env + ; ambient_lvl <- TcM.getTcLevel + ; mb_lvl <- TcM.readTcRef ref + ; TcM.traceTc "resetUnificationFlag" $ + vcat [ text "ambient:" <+> ppr ambient_lvl + , text "unif_lvl:" <+> ppr mb_lvl ] + ; case mb_lvl of + Nothing -> return False + Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl + -> return False + | otherwise + -> do { TcM.writeTcRef ref Nothing + ; return True } } + +setUnificationFlag :: TcLevel -> TcS () +-- (setUnificationFlag i) sets the unification level to (Just i) +-- unless it already is (Just j) where j <= i +setUnificationFlag lvl + = TcS $ \env -> + do { let ref = tcs_unif_lvl env + ; mb_lvl <- TcM.readTcRef ref + ; case mb_lvl of + Just unif_lvl | lvl `deeperThanOrSame` unif_lvl + -> return () + _ -> TcM.writeTcRef ref (Just lvl) } + + +{- ********************************************************************* +* * +* Instantiation etc. +* * +********************************************************************* -} + +-- Instantiations +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType) +instDFunType dfun_id inst_tys + = wrapTcS $ TcM.instDFunType dfun_id inst_tys + +newFlexiTcSTy :: Kind -> TcS TcType +newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd) + +cloneMetaTyVar :: TcTyVar -> TcS TcTyVar +cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) + +instFlexiX :: Subst -> [TKVar] -> TcS Subst +instFlexiX subst tvs = wrapTcS (instFlexiXTcM subst tvs) + +instFlexiXTcM :: Subst -> [TKVar] -> TcM Subst +-- Makes fresh tyvar, extends the substitution, and the in-scope set +-- Takes account of the case [k::Type, a::k, ...], +-- where we must substitute for k in a's kind +instFlexiXTcM subst [] + = return subst +instFlexiXTcM subst (tv:tvs) + = do { uniq <- TcM.newUnique + ; details <- TcM.newMetaDetails TauTv + ; let name = setNameUnique (tyVarName tv) uniq + kind = substTyUnchecked subst (tyVarKind tv) + tv' = mkTcTyVar name kind details + subst' = extendTvSubstWithClone subst tv tv' + ; instFlexiXTcM subst' tvs } + +matchGlobalInst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS TcM.ClsInstResult +matchGlobalInst dflags cls tys loc + = do { mode <- getTcSMode + ; let skip_overlappable = tcsmSkipOverlappable mode + ; wrapTcS $ TcM.matchGlobalInst dflags skip_overlappable cls tys (Just loc) } + +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar]) +tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs + +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data MaybeNew = Fresh WantedCtEvidence | Cached EvExpr + +isFresh :: MaybeNew -> Bool +isFresh (Fresh {}) = True +isFresh (Cached {}) = False + +freshGoals :: [MaybeNew] -> [WantedCtEvidence] +freshGoals mns = [ ctev | Fresh ctev <- mns ] + +getEvExpr :: MaybeNew -> EvExpr +getEvExpr (Fresh ctev) = ctEvExpr (CtWanted ctev) +getEvExpr (Cached evt) = evt + +setEvBind :: EvBind -> TcS () +setEvBind ev_bind + = do { evb <- getTcEvBindsVar + ; wrapTcS $ TcM.addTcEvBind evb ev_bind } + +-- | Mark variables as used filling a coercion hole +addUsedCoercion :: TcCoercion -> TcS () +addUsedCoercion co + = do { ev_binds_var <- getTcEvBindsVar + ; wrapTcS (TcM.updTcRef (ebv_tcvs ev_binds_var) (co :)) } + +-- | Equalities only +setWantedEq :: HasDebugCallStack => TcEvDest -> TcCoercion -> TcS () +setWantedEq (HoleDest hole) co + = do { addUsedCoercion co + ; fillCoercionHole hole co } +setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev) + +-- | Good for both equalities and non-equalities +setWantedEvTerm :: TcEvDest -> CanonicalEvidence -> EvTerm -> TcS () +setWantedEvTerm (HoleDest hole) _canonical tm + | Just co <- evTermCoercion_maybe tm + = do { addUsedCoercion co + ; fillCoercionHole hole co } + | otherwise + = -- See Note [Yukky eq_sel for a HoleDest] + do { let co_var = coHoleCoVar hole + ; setEvBind (mkWantedEvBind co_var EvCanonical tm) + ; fillCoercionHole hole (mkCoVarCo co_var) } + +setWantedEvTerm (EvVarDest ev_id) canonical tm + = setEvBind (mkWantedEvBind ev_id canonical tm) + +{- Note [Yukky eq_sel for a HoleDest] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How can it be that a Wanted with HoleDest gets evidence that isn't +just a coercion? i.e. evTermCoercion_maybe returns Nothing. + +Consider [G] forall a. blah => a ~ T + [W] S ~# T + +Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T) +in the quantified constraints, and wraps the (boxed) evidence it +gets back in an eq_sel to extract the unboxed (S ~# T). We can't put +that term into a coercion, so we add a value binding + h = eq_sel (...) +and the coercion variable h to fill the coercion hole. +We even re-use the CoHole's Id for this binding! + +Yuk! +-} + +fillCoercionHole :: CoercionHole -> Coercion -> TcS () +fillCoercionHole hole co + = do { wrapTcS $ TcM.fillCoercionHole hole co + ; kickOutAfterFillingCoercionHole hole } + +setEvBindIfWanted :: CtEvidence -> CanonicalEvidence -> EvTerm -> TcS () +setEvBindIfWanted ev canonical tm + = case ev of + CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest canonical tm + _ -> return () + +newTcEvBinds :: TcS EvBindsVar +newTcEvBinds = wrapTcS TcM.newTcEvBinds + +newNoTcEvBinds :: TcS EvBindsVar +newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds + +newEvVar :: TcPredType -> TcS EvVar +newEvVar pred = wrapTcS (TcM.newEvVar pred) + +newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS GivenCtEvidence +-- Make a new variable of the given PredType, +-- immediately bind it to the given term +-- and return its CtEvidence +-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint +newGivenEvVar loc (pred, rhs) + = do { new_ev <- newBoundEvVarId pred rhs + ; return $ GivenCt { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc } } + +-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the +-- given term +newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar +newBoundEvVarId pred rhs + = do { new_ev <- newEvVar pred + ; setEvBind (mkGivenEvBind new_ev rhs) + ; return new_ev } + +emitNewGivens :: CtLoc -> [(Role,TcCoercion)] -> TcS () +emitNewGivens loc pts + = do { traceTcS "emitNewGivens" (ppr pts) + ; gs <- mapM (newGivenEvVar loc) $ + [ (mkEqPredRole role ty1 ty2, evCoercion co) + | (role, co) <- pts + , let Pair ty1 ty2 = coercionKind co + , not (ty1 `tcEqType` ty2) ] -- Kill reflexive Givens at birth + ; emitWorkNC (map CtGiven gs) } + +emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion +-- | Emit a new Wanted equality into the work-list +emitNewWantedEq loc rewriters role ty1 ty2 + = do { (wtd, co) <- newWantedEq loc rewriters role ty1 ty2 + ; updWorkListTcS (extendWorkListEq rewriters (mkNonCanonical $ CtWanted wtd)) + ; return co } + +-- | Create a new Wanted constraint holding a coercion hole +-- for an equality between the two types at the given 'Role'. +newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType + -> TcS (WantedCtEvidence, Coercion) +newWantedEq loc rewriters role ty1 ty2 + = do { hole <- wrapTcS $ TcM.newCoercionHole pty + ; let wtd = WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } + ; return (wtd, mkHoleCo hole) } + where + pty = mkEqPredRole role ty1 ty2 + +-- | Create a new Wanted constraint holding an evidence variable. +-- +-- Don't use this for equality constraints: use 'newWantedEq' instead. +newWantedEvVarNC :: CtLoc -> RewriterSet + -> TcPredType -> TcS WantedCtEvidence +-- Don't look up in the solved/inerts; we know it's not there +newWantedEvVarNC loc rewriters pty + = assertPpr (not (isEqPred pty)) (ppr pty) $ + do { new_ev <- newEvVar pty + ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$ + pprCtLoc loc) + ; return $ WantedCt { ctev_pred = pty + , ctev_dest = EvVarDest new_ev + , ctev_loc = loc + , ctev_rewriters = rewriters } + } + +-- | `newWantedEvVar` makes up a fresh evidence variable for the given predicate. +-- For ClassPred, check if this exact predicate type is in the solved dicts +-- But do /not/ look in the inert_cans, because doing so bypasses all +-- all the careful tests in tryInertDicts, leading to +-- #20666 (prohibitedSuperClassSolve) and #26117 (short-cut solve) +-- We do no such caching forIPs, holes, or errors; so for anything +-- except ClassPred, this is the same as newWantedEvVarNC +-- +-- Don't use this for equality constraints: this function is only for +-- constraints with 'EvVarDest'. +newWantedEvVar :: CtLoc -> RewriterSet + -> TcPredType -> TcS MaybeNew +newWantedEvVar loc rewriters pty + = case classifyPredType pty of + EqPred {} -> pprPanic "newWantedEvVar: HoleDestPred" (ppr pty) + ClassPred cls tys + -> do { inerts <- getInertSet + ; case lookupSolvedDict inerts cls tys of + Just ev -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ev + ; return $ Cached (ctEvExpr ev) } + Nothing -> do { ev <- newWantedEvVarNC loc rewriters pty + ; return (Fresh ev) } } + _other -> do { ev <- newWantedEvVarNC loc rewriters pty + ; return (Fresh ev) } + +-- | Create a new Wanted constraint, potentially looking up +-- non-equality constraints in the cache instead of creating +-- a new one from scratch. +-- +-- Deals with both equality and non-equality constraints. +newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew +newWanted loc rewriters pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2 + | otherwise + = newWantedEvVar loc rewriters pty + +-- | Create a new Wanted constraint. +-- +-- Deals with both equality and non-equality constraints. +-- +-- Does not attempt to re-use non-equality constraints that already +-- exist in the inert set. +newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS WantedCtEvidence +newWantedNC loc rewriters pty + | Just (role, ty1, ty2) <- getEqPredTys_maybe pty + = fst <$> newWantedEq loc rewriters role ty1 ty2 + | otherwise + = newWantedEvVarNC loc rewriters pty + +-- | Checks if the depth of the given location is too much. Fails if +-- it's too big, with an appropriate error message. +checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced + -> TcS () +checkReductionDepth loc ty + = do { dflags <- getDynFlags + ; when (subGoalDepthExceeded (reductionDepth dflags) (ctLocDepth loc)) $ + wrapErrTcS $ solverDepthError loc ty } + +matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN) +matchFam tycon args = wrapTcS $ matchFamTcM tycon args + +matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN) +-- Given (F tys) return (ty, co), where co :: F tys ~N ty +matchFamTcM tycon args + = do { fam_envs <- FamInst.tcGetFamInstEnvs + ; let match_fam_result + = reduceTyFamApp_maybe fam_envs Nominal tycon args + ; TcM.traceTc "matchFamTcM" $ + vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args) + , ppr_res match_fam_result ] + ; return match_fam_result } + where + ppr_res Nothing = text "Match failed" + ppr_res (Just (Reduction co ty)) + = hang (text "Match succeeded:") + 2 (vcat [ text "Rewrites to:" <+> ppr ty + , text "Coercion:" <+> ppr co ]) + +solverDepthError :: CtLoc -> TcType -> TcM a +solverDepthError loc ty + = TcM.setCtLocM loc $ + do { (ty, env0) <- TcM.liftZonkM $ + do { ty <- TcM.zonkTcType ty + ; env0 <- TcM.tcInitTidyEnv + ; return (ty, env0) } + ; let (tidy_env, tidy_ty) = tidyOpenTypeX env0 ty + msg = TcRnSolverDepthError tidy_ty depth + ; TcM.failWithTcM (tidy_env, msg) } + where + depth = ctLocDepth loc + +{- +************************************************************************ +* * + Emitting equalities arising from fundeps +* * +************************************************************************ +-} + +emitFunDepWanteds :: CtEvidence -- The work item + -> [FunDepEqn (CtLoc, RewriterSet)] + -> TcS Bool -- True <=> some unification happened + +emitFunDepWanteds _ [] = return False -- common case noop +-- See Note [FunDep and implicit parameter reactions] in GHC.Tc.Solver.Dict + +emitFunDepWanteds ev fd_eqns + = unifyFunDeps ev Nominal do_fundeps + where + do_fundeps :: UnifyEnv -> TcM () + do_fundeps env = mapM_ (do_one env) fd_eqns + + do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM () + do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) + = do { eqs' <- instantiate_eqs tvs (reverse eqs) + -- (reverse eqs): See Note [Reverse order of fundep equations] + ; uPairsTcM env_one eqs' } + where + env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters + , u_loc = loc } + + instantiate_eqs :: [TyVar] -> [TypeEqn] -> TcM [TypeEqn] + instantiate_eqs tvs eqs + | null tvs + = return eqs + | otherwise + = do { TcM.traceTc "emitFunDepWanteds 2" (ppr tvs $$ ppr eqs) + ; subst <- instFlexiXTcM emptySubst tvs -- Takes account of kind substitution + ; return [ Pair (substTyUnchecked subst' ty1) ty2 + -- ty2 does not mention fd_qtvs, so no need to subst it. + -- See GHC.Tc.Instance.Fundeps Note [Improving against instances] + -- Wrinkle (1) + | Pair ty1 ty2 <- eqs + , let subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1) ] + -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result + -- of matching with the [W] constraint. So we add its free + -- vars to InScopeSet, to satisfy substTy's invariants, even + -- though ty1 will never (currently) be a poytype, so this + -- InScopeSet will never be looked at. + } + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [wrapUnifierTcS] +~~~~~~~~~~~~~~~~~~~ +When decomposing equalities we often create new wanted constraints for +(s ~ t). But what if s=t? Then it'd be faster to return Refl right away. + +Rather than making an equality test (which traverses the structure of the type, +perhaps fruitlessly), we call uType (via wrapUnifierTcS) to traverse the common +structure, and bales out when it finds a difference by creating a new deferred +Wanted constraint. But where it succeeds in finding common structure, it just +builds a coercion to reflect it. + +This is all much faster than creating a new constraint, putting it in the +work list, picking it out, canonicalising it, etc etc. + +Note [unifyFunDeps] +~~~~~~~~~~~~~~~~~~~ +The Bool returned by `unifyFunDeps` is True if we have unified a variable +that occurs in the constraint we are trying to solve; it is not in the +inert set so `wrapUnifierTcS` won't kick it out. Instead we want to send it +back to the start of the pipeline. Hence the Bool. + +It's vital that we don't return (not (null unified)) because the fundeps +may create fresh variables; unifying them (alone) should not make us send +the constraint back to the start, or we'll get an infinite loop. See +Note [Fundeps with instances, and equality orientation] in GHC.Tc.Solver.Dict +and Note [Improvement orientation] in GHC.Tc.Solver.Equality. +-} + +uPairsTcM :: UnifyEnv -> [TypeEqn] -> TcM () +uPairsTcM uenv eqns = mapM_ (\(Pair ty1 ty2) -> uType uenv ty1 ty2) eqns + +unifyFunDeps :: CtEvidence -> Role + -> (UnifyEnv -> TcM ()) + -> TcS Bool +unifyFunDeps ev role do_unifications + = do { (_, _, unified) <- wrapUnifierTcS ev role do_unifications + ; return (any (`elemVarSet` fvs) unified) } + -- See Note [unifyFunDeps] + where + fvs = tyCoVarsOfType (ctEvPred ev) + +unifyForAllBody :: CtEvidence -> Role -> (UnifyEnv -> TcM a) + -> TcS (a, Cts) +-- We /return/ the equality constraints we generate, +-- rather than emitting them into the monad. +-- See See (SF5) in Note [Solving forall equalities] in GHC.Tc.Solver.Equality +unifyForAllBody ev role unify_body + = do { (res, cts, unified) <- wrapUnifierX ev role unify_body + + -- Kick out any inert constraint that we have unified + ; _ <- kickOutAfterUnification unified + + ; return (res, cts) } + +wrapUnifierTcS :: CtEvidence -> Role + -> (UnifyEnv -> TcM a) -- Some calls to uType + -> TcS (a, Bag Ct, [TcTyVar]) +-- Invokes the do_unifications argument, with a suitable UnifyEnv. +-- Emit deferred equalities and kick-out from the inert set as a +-- result of any unifications. +-- Very good short-cut when the two types are equal, or nearly so +-- See Note [wrapUnifierTcS] +-- +-- The [TcTyVar] is the list of unification variables that were +-- unified the process; the (Bag Ct) are the deferred constraints. + +wrapUnifierTcS ev role do_unifications + = do { (res, cts, unified) <- wrapUnifierX ev role do_unifications + + -- Emit the deferred constraints + -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality + -- + -- All the constraints in `cts` share the same rewriter set so, + -- rather than looking at it one by one, we pass it to + -- extendWorkListChildEqs; just a small optimisation. + ; unless (isEmptyBag cts) $ + updWorkListTcS (extendWorkListChildEqs ev cts) + + -- And kick out any inert constraint that we have unified + ; _ <- kickOutAfterUnification unified + + ; return (res, cts, unified) } + +wrapUnifierX :: CtEvidence -> Role + -> (UnifyEnv -> TcM a) -- Some calls to uType + -> TcS (a, Bag Ct, [TcTyVar]) +wrapUnifierX ev role do_unifications + = do { unif_count_ref <- getUnifiedRef + ; wrapTcS $ + do { defer_ref <- TcM.newTcRef emptyBag + ; unified_ref <- TcM.newTcRef [] + ; let env = UE { u_role = role + , u_rewriters = ctEvRewriters ev + , u_loc = ctEvLoc ev + , u_defer = defer_ref + , u_unified = Just unified_ref} + -- u_rewriters: the rewriter set and location from + -- the parent constraint `ev` are inherited in any + -- new constraints spat out by the unifier + + ; res <- do_unifications env + + ; cts <- TcM.readTcRef defer_ref + ; unified <- TcM.readTcRef unified_ref + + -- Don't forget to update the count of variables + -- unified, lest we forget to iterate (#24146) + ; unless (null unified) $ + TcM.updTcRef unif_count_ref (+ (length unified)) + + ; return (res, cts, unified) } } + + +{- +************************************************************************ +* * + Breaking type variable cycles +* * +************************************************************************ +-} + +checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType + -> TcS (PuResult () Reduction) +-- Used for general CanEqLHSs, ones that do +-- not have a touchable type variable on the LHS (i.e. not unifying) +checkTypeEq ev eq_rel lhs rhs = + case ev of + CtGiven {} -> + do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs + , text "rhs:" <+> ppr rhs ]) + ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs) + ; traceTcS "checkTypeEq }" (ppr check_result) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs + ; emitWork new_givens + ; updInertSet (addCycleBreakerBindings prs) + ; return (pure redn) } } + CtWanted {} -> + do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs) + ; case check_result of + PuFail reason -> return (PuFail reason) + PuOK cts redn -> do { emitWork cts + ; return (pure redn) } } + where + wanted_flags :: TyEqFlags TcM Ct + wanted_flags = notUnifying_TEFTask occ_prob lhs + -- checkTypeEq deals only with the non-unifying case + + given_flags :: TyEqFlags TcM (TcTyVar, TcType) + given_flags = wanted_flags { tef_fam_app = mkTEFA_Break ev eq_rel BreakGiven } + -- TEFA_Break used for: [G] a ~ Maybe (F a) + -- or [W] F a ~ Maybe (F a) + + -- occ_prob: see Note [Occurs check and representational equality] + occ_prob = case eq_rel of + NomEq -> cteInsolubleOccurs + ReprEq -> cteSolubleOccurs + + --------------------------- + mk_new_given :: (TcTyVar, TcType) -> TcS Ct + mk_new_given (new_tv, fam_app) + = mkNonCanonical . CtGiven <$> newGivenEvVar cb_loc (given_pred, given_term) + where + new_ty = mkTyVarTy new_tv + given_pred = mkNomEqPred fam_app new_ty + given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note + + -- See Detail (7) of the Note + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin + +------------------------- +-- | Fill in CycleBreakerTvs with the variables they stand for. +-- See Note [Type equality cycles] in GHC.Tc.Solver.Equality +restoreTyVarCycles :: InertSet -> TcM () +restoreTyVarCycles is + = TcM.liftZonkM + $ forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar +{-# SPECIALISE forAllCycleBreakerBindings_ :: + CycleBreakerVarStack -> (TcTyVar -> TcType -> ZonkM ()) -> ZonkM () #-} + + +{- Note [Occurs check and representational equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(a ~R# b a) is soluble if b later turns out to be Identity +So we treat this as a "soluble occurs check". Note [Don't cycle-break Wanteds when not unifying] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Tc/Solver/Rewrite.hs b/GHC/Tc/Solver/Rewrite.hs --- a/GHC/Tc/Solver/Rewrite.hs +++ b/GHC/Tc/Solver/Rewrite.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BangPatterns #-} - -{-# LANGUAGE DeriveFunctor #-} - module GHC.Tc.Solver.Rewrite( rewrite, rewriteForErrors, rewriteArgsNom, rewriteType @@ -15,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 @@ -30,7 +27,6 @@ import GHC.Driver.DynFlags import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Tc.Solver.Monad as TcS import GHC.Utils.Misc @@ -86,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; @@ -154,22 +150,33 @@ { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) } ; thing_inside env' } --- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint --- Precondition: the CtEvidence is a CtWanted of an equality recordRewriter :: CtEvidence -> RewriteM () -recordRewriter (CtWanted { ctev_dest = HoleDest hole }) - = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole) -recordRewriter other = pprPanic "recordRewriter" (ppr other) +-- Record that we have rewritten the target with this (equality) evidence +-- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint +-- Precondition: the CtEvidence is for an equality constraint +recordRewriter (CtGiven {}) + = return () +recordRewriter (CtWanted (WantedCt { ctev_dest = dest })) + = case dest of + HoleDest hole -> RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriter` hole) + other -> pprPanic "recordRewriter: non-equality constraint" (ppr other) -{- -Note [Rewriter EqRels] -~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Rewriter EqRels] +~~~~~~~~~~~~~~~~~~~~~~~~~ When rewriting, we need to know which equality relation -- nominal -or 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. @@ -216,7 +223,7 @@ -- | See Note [Rewriting]. -- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty -- where r is the role in @ev@. --- rewriters is the set of coercion holes that have been used to rewrite +-- `rewriters` is the set of coercion holes that have been used to rewrite -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint rewrite :: CtEvidence -> TcType -> TcS (Reduction, RewriterSet) @@ -238,7 +245,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) } @@ -844,16 +851,18 @@ -- STEP 3: try the inerts ; flavour <- getFlavour - ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis - ; case result2 of - { Just (redn, (inert_flavour, inert_eq_rel)) + ; mb_eq <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis + ; case mb_eq of + { Just (EqCt { eq_ev = inert_ev, eq_rhs = inert_rhs, eq_eq_rel = inert_eq_rel }) -> do { traceRewriteM "rewrite family application with inert" (ppr tc <+> ppr xis $$ ppr redn) - ; finish (inert_flavour == Given) (homogenise downgraded_redn) } - -- this will sometimes duplicate an inert in the cache, + ; recordRewriter inert_ev + ; finish (isGiven inert_ev) (homogenise downgraded_redn) } + -- This will sometimes duplicate an inert in the cache, -- but avoiding doing so had no impact on performance, and -- it seems easier not to weed out that special case where + redn = mkReduction (ctEvCoercion inert_ev) inert_rhs inert_role = eqRelRole inert_eq_rel role = eqRelRole eq_rel downgraded_redn = downgradeRedn role inert_role redn @@ -1017,12 +1026,11 @@ | Just ct <- find can_rewrite equal_ct_list , EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv , eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct - -> do { let wrw = isWanted ctev - ; traceRewriteM "Following inert tyvar" $ + -> do { traceRewriteM "Following inert tyvar" $ vcat [ ppr tv <+> equals <+> ppr rhs_ty - , ppr ctev - , text "wanted_rewrite_wanted:" <+> ppr wrw ] - ; when wrw $ recordRewriter ctev + , ppr ctev ] + ; recordRewriter ctev + -- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint ; let rewriting_co1 = ctEvCoercion ctev rewriting_co = case (ct_eq_rel, eq_rel) of diff --git a/GHC/Tc/Solver/Solve.hs b/GHC/Tc/Solver/Solve.hs --- a/GHC/Tc/Solver/Solve.hs +++ b/GHC/Tc/Solver/Solve.hs @@ -1,718 +1,1837 @@ -{-# LANGUAGE RecursiveDo #-} - -module GHC.Tc.Solver.Solve ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds -- Solves Cts - ) where - -import GHC.Prelude - -import GHC.Tc.Solver.Dict -import GHC.Tc.Solver.Equality( solveEquality ) -import GHC.Tc.Solver.Irred( solveIrred ) -import GHC.Tc.Solver.Rewrite( rewrite ) -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence -import GHC.Tc.Types -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Constraint -import GHC.Tc.Solver.InertSet -import GHC.Tc.Solver.Monad - -import GHC.Core.Predicate -import GHC.Core.Reduction -import GHC.Core.Coercion -import GHC.Core.Class( classHasSCs ) - -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit ) - -import GHC.Data.Bag - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc - -import GHC.Driver.Session - -import Data.List( deleteFirstsBy ) - -import Control.Monad -import Data.Semigroup as S -import Data.Void( Void ) - -{- -********************************************************************** -* * -* Main Solver * -* * -********************************************************************** - -Note [Basic Simplifier Plan] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Pick an element from the WorkList if there exists one with depth - less than our context-stack depth. - -2. Run it down the 'stage' pipeline. Stages are: - - canonicalization - - inert reactions - - spontaneous reactions - - top-level interactions - Each stage returns a StopOrContinue and may have sideeffected - the inerts or worklist. - - The threading of the stages is as follows: - - If (Stop) is returned by a stage then we start again from Step 1. - - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to - the next stage in the pipeline. -4. If the element has survived (i.e. ContinueWith x) the last stage - then we add it in the inerts and jump back to Step 1. - -If in Step 1 no such element exists, we have exceeded our context-stack -depth and will simply fail. --} - -solveSimpleGivens :: [Ct] -> TcS () -solveSimpleGivens givens - | null givens -- Shortcut for common case - = return () - | otherwise - = do { traceTcS "solveSimpleGivens {" (ppr givens) - ; go givens - ; traceTcS "End solveSimpleGivens }" empty } - where - go givens = do { solveSimples (listToBag givens) - ; new_givens <- runTcPluginsGiven - ; when (notNull new_givens) $ - go new_givens } - -solveSimpleWanteds :: Cts -> TcS WantedConstraints --- The result is not necessarily zonked -solveSimpleWanteds simples - = do { traceTcS "solveSimpleWanteds {" (ppr simples) - ; dflags <- getDynFlags - ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples }) - ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } - where - go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints) - -- See Note [The solveSimpleWanteds loop] - go n limit wc - | n `intGtLimit` limit - = failTcS $ TcRnSimplifierTooManyIterations simples limit wc - | isEmptyBag (wc_simple wc) - = return (n,wc) - - | otherwise - = do { -- Solve - wc1 <- solve_simple_wanteds wc - - -- Run plugins - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - - ; if rerun_plugin - then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin) - ; go (n+1) limit wc2 } -- Loop - else return (n, wc2) } -- Done - - -solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints --- Try solving these constraints --- Affects the unification state (of course) but not the inert set --- The result is not necessarily zonked -solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, unsolved) <- getUnsolvedInerts - ; return (WC { wc_simple = unsolved - , wc_impl = implics1 `unionBags` implics2 - , wc_errors = errs }) } - -{- Note [The solveSimpleWanteds loop] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a bunch of simple constraints is done in a loop, -(the 'go' loop of 'solveSimpleWanteds'): - 1. Try to solve them - 2. Try the plugin - 3. If the plugin wants to run again, go back to step 1 --} - -{- -************************************************************************ -* * - Solving flat constraints: solveSimples -* * -********************************************************************* -} - --- The main solver loop implements Note [Basic Simplifier Plan] ---------------------------------------------------------------- -solveSimples :: Cts -> TcS () --- Returns the final InertSet in TcS --- Has no effect on work-list or residual-implications --- The constraints are initially examined in left-to-right order - -solveSimples cts - = {-# SCC "solveSimples" #-} - do { emitWork cts; solve_loop } - where - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem - ; case sel of - Nothing -> return () - Just ct -> do { solveOne ct - ; solve_loop } } - -solveOne :: Ct -> TcS () -- Solve one constraint -solveOne workItem - = do { wl <- getWorkList - ; inerts <- getInertSet - ; tclevel <- getTcLevel - ; traceTcS "----------------------------- " empty - ; traceTcS "Start solver pipeline {" $ - vcat [ text "tclevel =" <+> ppr tclevel - , text "work item =" <+> ppr workItem - , text "inerts =" <+> ppr inerts - , text "rest of worklist =" <+> ppr wl ] - - ; bumpStepCountTcS -- One step for each constraint processed - ; solve workItem } - where - solve :: Ct -> TcS () - solve ct - = do { traceTcS "solve {" (text "workitem = " <+> ppr ct) - ; res <- runSolverStage (solveCt ct) - ; traceTcS "end solve }" (ppr res) - ; case res of - StartAgain ct -> do { traceTcS "Go round again" (ppr ct) - ; solve ct } - - Stop ev s -> do { traceFireTcS ev s - ; traceTcS "End solver pipeline }" empty - ; return () } - - -- ContinueWith can't happen: res :: SolverStage Void - -- solveCt either solves the constraint, or puts - -- the unsolved constraint in the inert set. - } - -{- ********************************************************************* -* * -* Solving one constraint: solveCt -* * -************************************************************************ - -Note [Canonicalization] -~~~~~~~~~~~~~~~~~~~~~~~ -Canonicalization converts a simple constraint to a canonical form. It is -unary (i.e. treats individual constraints one at a time). - -Constraints originating from user-written code come into being as -CNonCanonicals. We know nothing about these constraints. So, first: - - Classify CNonCanoncal constraints, depending on whether they - are equalities, class predicates, or other. - -Then proceed depending on the shape of the constraint. Generally speaking, -each constraint gets rewritten and then decomposed into one of several forms -(see type Ct in GHC.Tc.Types). - -When an already-canonicalized constraint gets kicked out of the inert set, -it must be recanonicalized. But we know a bit about its shape from the -last time through, so we can skip the classification step. --} - -solveCt :: Ct -> SolverStage Void --- The Void result tells us that solveCt cannot return --- a ContinueWith; it must return Stop or StartAgain. -solveCt (CNonCanonical ev) = solveNC ev -solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev - -solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel - , eq_lhs = lhs, eq_rhs = rhs })) - = solveEquality ev eq_rel (canEqLHSType lhs) rhs - -solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = do { ev <- rewriteEvidence ev - -- It is (much) easier to rewrite and re-classify than to - -- rewrite the pieces and build a Reduction that will rewrite - -- the whole constraint - ; case classifyPredType (ctEvPred ev) of - ForAllPred tvs th p -> Stage $ solveForAll ev tvs th p pend_sc - _ -> pprPanic "SolveCt" (ppr ev) } - -solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc })) - = do { ev <- rewriteEvidence ev - -- It is easier to rewrite and re-classify than to rewrite - -- the pieces and build a Reduction that will rewrite the - -- whole constraint - ; case classifyPredType (ctEvPred ev) of - ClassPred cls tys - -> solveDict (DictCt { di_ev = ev, di_cls = cls - , di_tys = tys, di_pend_sc = pend_sc }) - _ -> pprPanic "solveCt" (ppr ev) } - ------------------- -solveNC :: CtEvidence -> SolverStage Void -solveNC ev - = -- Instead of rewriting the evidence before classifying, it's possible we - -- can make progress without the rewrite. Try this first. - -- For insolubles (all of which are equalities), do /not/ rewrite the arguments - -- In #14350 doing so led entire-unnecessary and ridiculously large - -- type function expansion. Instead, canEqNC just applies - -- the substitution to the predicate, and may do decomposition; - -- e.g. a ~ [a], where [G] a ~ [Int], can decompose - case classifyPredType (ctEvPred ev) of { - EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ; - _ -> - - -- Do rewriting on the constraint, especially zonking - do { ev <- rewriteEvidence ev - ; let irred = IrredCt { ir_ev = ev, ir_reason = IrredShapeReason } - - -- And then re-classify - ; case classifyPredType (ctEvPred ev) of - ClassPred cls tys -> solveDictNC ev cls tys - ForAllPred tvs th p -> Stage $ solveForAllNC ev tvs th p - IrredPred {} -> solveIrred irred - EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 - -- This case only happens if (say) `c` is unified with `a ~# b`, - -- but that is rare becuase it requires c :: CONSTRAINT UnliftedRep - - }} - - -{- ********************************************************************* -* * -* Quantified constraints -* * -********************************************************************* -} - -{- Note [Quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The -XQuantifiedConstraints extension allows type-class contexts like this: - - data Rose f x = Rose x (f (Rose f x)) - - instance (Eq a, forall b. Eq b => Eq (f b)) - => Eq (Rose f a) where - (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 - -Note the (forall b. Eq b => Eq (f b)) in the instance contexts. -This quantified constraint is needed to solve the - [W] (Eq (f (Rose f x))) -constraint which arises form the (==) definition. - -The wiki page is - https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints -which in turn contains a link to the GHC Proposal where the change -is specified, and a Haskell Symposium paper about it. - -We implement two main extensions to the design in the paper: - - 1. We allow a variable in the instance head, e.g. - f :: forall m a. (forall b. m b) => D (m a) - Notice the 'm' in the head of the quantified constraint, not - a class. - - 2. We support superclasses to quantified constraints. - For example (contrived): - f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool - f x y = x==y - Here we need (Eq (m a)); but the quantified constraint deals only - with Ord. But we can make it work by using its superclass. - -Here are the moving parts - * Language extension {-# LANGUAGE QuantifiedConstraints #-} - and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension - - * A new form of evidence, EvDFun, that is used to discharge - such wanted constraints - - * checkValidType gets some changes to accept forall-constraints - only in the right places. - - * Predicate.Pred gets a new constructor ForAllPred, and - and classifyPredType analyses a PredType to decompose - the new forall-constraints - - * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts, - which holds all the Given forall-constraints. In effect, - such Given constraints are like local instance decls. - - * When trying to solve a class constraint, via - GHC.Tc.Solver.Instance.Class.matchInstEnv, use the InstEnv from inert_insts - so that we include the local Given forall-constraints - in the lookup. (See GHC.Tc.Solver.Monad.getInstEnvs.) - - * `solveForAll` deals with solving a forall-constraint. See - Note [Solving a Wanted forall-constraint] - - * We augment the kick-out code to kick out an inert - forall constraint if it can be rewritten by a new - type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable - -Note that a quantified constraint is never /inferred/ -(by GHC.Tc.Solver.simplifyInfer). A function can only have a -quantified constraint in its type if it is given an explicit -type signature. - --} - -solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Void) --- NC: this came from CNonCanonical, so we have not yet expanded superclasses --- Precondition: already rewritten by inert set -solveForAllNC ev tvs theta pred - | isGiven ev -- See Note [Eagerly expand given superclasses] - , Just (cls, tys) <- cls_pred_tys_maybe - = do { dflags <- getDynFlags - ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys - -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] - ; emitWork (listToBag sc_cts) - ; solveForAll ev tvs theta pred doNotExpand } - -- doNotExpand: as we have already (eagerly) expanded superclasses for this class - - | otherwise - = do { dflags <- getDynFlags - ; let fuel | Just (cls, _) <- cls_pred_tys_maybe - , classHasSCs cls = qcsFuel dflags - -- See invariants (a) and (b) in QCI.qci_pend_sc - -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] - -- See Note [Quantified constraints] - | otherwise = doNotExpand - ; solveForAll ev tvs theta pred fuel } - where - cls_pred_tys_maybe = getClassPredTys_maybe pred - -solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel - -> TcS (StopOrContinue Void) --- Precondition: already rewritten by inert set -solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc }) - tvs theta pred _fuel - = -- See Note [Solving a Wanted forall-constraint] - setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ - -- This setSrcSpan is important: the emitImplicationTcS uses that - -- TcLclEnv for the implication, and that in turn sets the location - -- for the Givens when solving the constraint (#21006) - do { let empty_subst = mkEmptySubst $ mkInScopeSet $ - tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - is_qc = IsQC (ctLocOrigin loc) - - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - -- Very like the code in tcSkolDFunType - ; rec { skol_info <- mkSkolemInfo skol_info_anon - ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs - ; let inst_pred = substTy subst pred - inst_theta = substTheta subst theta - skol_info_anon = InstSkol is_qc (get_size inst_pred) } - - ; given_ev_vars <- mapM newEvVar inst_theta - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) - -- Set the thing to prove to have a ScOrigin, so we are - -- careful about its termination checks. - -- See (QC-INV) in Note [Solving a Wanted forall-constraint] - ; wanted_ev <- newWantedEvVarNC loc' rewriters inst_pred - ; return ( ctEvEvId wanted_ev - , unitBag (mkNonCanonical wanted_ev)) } - - ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds - - ; setWantedEvTerm dest True $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = ev_binds, et_body = w_id } - - ; stopWith ev "Wanted forall-constraint" } - where - -- Getting the size of the head is a bit horrible - -- because of the special treament for class predicates - get_size pred = case classifyPredType pred of - ClassPred cls tys -> pSizeClassPred cls tys - _ -> pSizeType pred - - -- See Note [Solving a Given forall-constraint] -solveForAll ev@(CtGiven {}) tvs _theta pred fuel - = do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - where - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_pred = pred, qci_pend_sc = fuel } - -{- Note [Solving a Wanted forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Solving a wanted forall (quantified) constraint - [W] df :: forall ab. (Eq a, Ord b) => C x a b -is delightfully easy. Just build an implication constraint - forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a -and discharge df thus: - df = /\ab. \g1 g2. let in d -where is filled in by solving the implication constraint. -All the machinery is to hand; there is little to do. - -The tricky point is about termination: see #19690. We want to maintain -the invariant (QC-INV): - - (QC-INV) Every quantified constraint returns a non-bottom dictionary - -just as every top-level instance declaration guarantees to return a non-bottom -dictionary. But as #19690 shows, it is possible to get a bottom dicionary -by superclass selection if we aren't careful. The situation is very similar -to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; -and we use the same solution: - -* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) -* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) - -Both of these things are done in solveForAll. Now the mechanism described -in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. - -Note [Solving a Given forall-constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a Given constraint - [G] df :: forall ab. (Eq a, Ord b) => C x a b -we just add it to TcS's local InstEnv of known instances, -via addInertForall. Then, if we look up (C x Int Bool), say, -we'll find a match in the InstEnv. - - -************************************************************************ -* * - Evidence transformation -* * -************************************************************************ --} - -rewriteEvidence :: CtEvidence -> SolverStage CtEvidence --- (rewriteEvidence old_ev new_pred co do_next) --- Main purpose: create new evidence for new_pred; --- unless new_pred is cached already --- * Calls do_next with (new_ev :: new_pred), with same wanted/given flag as old_ev --- * If old_ev was wanted, create a binding for old_ev, in terms of new_ev --- * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev --- * Stops if new_ev is already cached --- --- Old evidence New predicate is Return new evidence --- flavour of same flavor --- ------------------------------------------------------------------- --- Wanted Already solved or in inert Stop --- Not do_next new_evidence --- --- Given Already in inert Stop --- Not do_next new_evidence - -{- Note [Rewriting with Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the coercion is just reflexivity then you may re-use the same -evidence variable. But be careful! Although the coercion is Refl, new_pred -may reflect the result of unification alpha := ty, so new_pred might -not _look_ the same as old_pred, and it's vital to proceed from now on -using new_pred. - -The rewriter preserves type synonyms, so they should appear in new_pred -as well as in old_pred; that is important for good error messages. - -If we are rewriting with Refl, then there are no new rewriters to add to -the rewriter set. We check this with an assertion. - -} - - -rewriteEvidence ev - = Stage $ do { traceTcS "rewriteEvidence" (ppr ev) - ; (redn, rewriters) <- rewrite ev (ctEvPred ev) - ; finish_rewrite ev redn rewriters } - -finish_rewrite :: CtEvidence -- ^ old evidence - -> Reduction -- ^ new predicate + coercion, of type ~ new predicate - -> RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] - -- in GHC.Tc.Types.Constraint - -> TcS (StopOrContinue CtEvidence) -finish_rewrite old_ev (Reduction co new_pred) rewriters - | isReflCo co -- See Note [Rewriting with Refl] - = assert (isEmptyRewriterSet rewriters) $ - continueWith (setCtEvPredType old_ev new_pred) - -finish_rewrite ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) - (Reduction co new_pred) rewriters - = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted - do { new_ev <- newGivenEvVar loc (new_pred, new_tm) - ; continueWith new_ev } - where - -- mkEvCast optimises ReflCo - new_tm = mkEvCast (evId old_evar) - (downgradeRole Representational (ctEvRole ev) 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 $ - mkEvCast (getEvExpr mb_new_ev) - (downgradeRole Representational (ctEvRole ev) (mkSymCo co)) - ; case mb_new_ev of - Fresh new_ev -> continueWith new_ev - Cached _ -> stopWith ev "Cached wanted" } - where - rewriters' = rewriters S.<> new_rewriters - -{- ******************************************************************* -* * -* Typechecker plugins -* * -******************************************************************* -} - --- | Extract the (inert) givens and invoke the plugins on them. --- Remove solved givens from the inert set and emit insolubles, but --- return new work produced so that 'solveSimpleGivens' can feed it back --- into the main solver. -runTcPluginsGiven :: TcS [Ct] -runTcPluginsGiven - = do { solvers <- getTcPluginSolvers - ; if null solvers then return [] else - do { givens <- getInertGivens - ; if null givens then return [] else - do { traceTcS "runTcPluginsGiven {" (ppr givens) - ; p <- runTcPluginSolvers solvers (givens,[]) - ; let (solved_givens, _) = pluginSolvedCts p - insols = map (ctIrredCt PluginReason) (pluginBadCts p) - ; updInertCans (removeInertCts solved_givens . - updIrreds (addIrreds insols) ) - ; traceTcS "runTcPluginsGiven }" $ - vcat [ text "solved_givens:" <+> ppr solved_givens - , text "insols:" <+> ppr insols - , text "new:" <+> ppr (pluginNewCts p) ] - ; return (pluginNewCts p) } } } - --- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on --- them and produce an updated bag of wanteds (possibly with some new --- work) and a bag of insolubles. The boolean indicates whether --- 'solveSimpleWanteds' should feed the updated wanteds back into the --- main solver. -runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1 }) - | isEmptyBag simples1 - = return (False, wc) - | otherwise - = do { solvers <- getTcPluginSolvers - ; if null solvers then return (False, wc) else - - do { given <- getInertGivens - ; wanted <- zonkSimples simples1 -- Plugin requires zonked inputs - - ; traceTcS "Running plugins (" (vcat [ text "Given:" <+> ppr given - , text "Watned:" <+> ppr wanted ]) - ; p <- runTcPluginSolvers solvers (given, bagToList wanted) - ; let (_, solved_wanted) = pluginSolvedCts p - (_, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - insols = pluginBadCts p - all_new_wanted = listToBag new_wanted `andCts` - listToBag unsolved_wanted `andCts` - listToBag insols - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens) - - ; mapM_ setEv solved_wanted - - ; traceTcS "Finished plugins }" (ppr new_wanted) - ; return ( notNull (pluginNewCts p) - , wc { wc_simple = all_new_wanted } ) } } - where - setEv :: (EvTerm,Ct) -> TcS () - setEv (ev,ct) = case ctEvidence ct of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest True ev -- TODO: plugins should be able to signal non-canonicity - _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" - --- | A pair of (given, wanted) constraints to pass to plugins -type SplitCts = ([Ct], [Ct]) - --- | A solved pair of constraints, with evidence for wanteds -type SolvedCts = ([Ct], [(EvTerm,Ct)]) - --- | Represents collections of constraints generated by typechecker --- plugins -data TcPluginProgress = TcPluginProgress - { pluginInputCts :: SplitCts - -- ^ Original inputs to the plugins with solved/bad constraints - -- removed, but otherwise unmodified - , pluginSolvedCts :: SolvedCts - -- ^ Constraints solved by plugins - , pluginBadCts :: [Ct] - -- ^ Constraints reported as insoluble by plugins - , pluginNewCts :: [Ct] - -- ^ New constraints emitted by plugins - } - -getTcPluginSolvers :: TcS [TcPluginSolver] -getTcPluginSolvers - = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } - --- | Starting from a pair of (given, wanted) constraints, --- invoke each of the typechecker constraint-solving plugins in turn and return --- --- * the remaining unmodified constraints, --- * constraints that have been solved, --- * constraints that are insoluble, and --- * new work. --- --- Note that new work generated by one plugin will not be seen by --- other plugins on this pass (but the main constraint solver will be --- re-invoked and they will see it later). There is no check that new --- work differs from the original constraints supplied to the plugin: --- the plugin itself should perform this check if necessary. -runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress -runTcPluginSolvers solvers all_cts - = do { ev_binds_var <- getTcEvBindsVar - ; foldM (do_plugin ev_binds_var) initialProgress solvers } - where - do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin ev_binds_var p solver = do - result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p)) - return $ progress p result - - progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress - progress p - (TcPluginSolveResult - { tcPluginInsolubleCts = bad_cts - , tcPluginSolvedCts = solved_cts - , tcPluginNewCts = new_cts - } - ) = - p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p) - , pluginSolvedCts = add solved_cts (pluginSolvedCts p) - , pluginNewCts = new_cts ++ pluginNewCts p - , pluginBadCts = bad_cts ++ pluginBadCts p - } - - initialProgress = TcPluginProgress all_cts ([], []) [] [] - - discard :: [Ct] -> SplitCts -> SplitCts - discard cts (xs, ys) = - (xs `without` cts, ys `without` cts) - - without :: [Ct] -> [Ct] -> [Ct] - without = deleteFirstsBy eq_ct - - eq_ct :: Ct -> Ct -> Bool - eq_ct c c' = ctFlavour c == ctFlavour c' - && ctPred c `tcEqType` ctPred c' - - add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts - add xs scs = foldl' addOne scs xs - - addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts - addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of - CtGiven {} -> (ct:givens, wanteds) - CtWanted {} -> (givens, (ev,ct):wanteds) - - +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Solve ( + simplifyWantedsTcM, + solveWanteds, -- Solves WantedConstraints + solveSimpleGivens, -- Solves [Ct] + solveSimpleWanteds, -- Solves Cts + trySolveImplication, + + setImplicationStatus + ) where + +import GHC.Prelude + +import GHC.Tc.Solver.Dict +import GHC.Tc.Solver.Equality( solveEquality ) +import GHC.Tc.Solver.Irred( solveIrred ) +import GHC.Tc.Solver.Rewrite( rewrite, rewriteType ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin ) +import GHC.Tc.Types +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( mkGivenLoc ) +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Monad as TcS +import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Zonk.TcType as TcM + +import GHC.Core.Predicate +import GHC.Core.Reduction +import GHC.Core.Coercion +import GHC.Core.TyCo.FVs( coVarsOfCos ) +import GHC.Core.Class( classHasSCs ) + +import GHC.Types.Id( idType ) +import GHC.Types.Var( EvVar, tyVarKind ) +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet ) + +import GHC.Data.Bag + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Driver.Session + + +import Control.Monad + +import Data.List( deleteFirstsBy ) +import Data.Maybe ( mapMaybe ) +import qualified Data.Semigroup as S +import Data.Void( Void ) + +{- ******************************************************************************** +* * +* Main Simplifier * +* * +******************************************************************************** -} + +simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints +-- Solve the specified Wanted constraints +-- Discard the evidence binds +-- Postcondition: fully zonked +simplifyWantedsTcM wanted + = do { TcM.traceTc "simplifyWantedsTcM {" (ppr wanted) + ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted)) + ; result <- TcM.liftZonkM $ TcM.zonkWC result + ; TcM.traceTc "simplifyWantedsTcM }" (ppr result) + ; return result } + +solveWanteds :: WantedConstraints -> TcS WantedConstraints +solveWanteds wc@(WC { wc_errors = errs }) + = do { cur_lvl <- TcS.getTcLevel + ; traceTcS "solveWanteds {" $ + vcat [ text "Level =" <+> ppr cur_lvl + , ppr wc ] + + ; dflags <- getDynFlags + ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc + + ; errs' <- simplifyDelayedErrors errs + ; let final_wc = solved_wc { wc_errors = errs' } + + ; ev_binds_var <- getTcEvBindsVar + ; bb <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveWanteds }" $ + vcat [ text "final wc =" <+> ppr final_wc + , text "ev_binds_var =" <+> ppr ev_binds_var + , text "current evbinds =" <+> ppr (evBindMapBinds bb) ] + + ; return final_wc } + +simplify_loop :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +-- Do a round of solving, and call maybe_simplify_again to iterate +-- The 'definitely_redo_implications' flags is False if the only reason we +-- are iterating is that we have added some new Wanted superclasses +-- hoping for fundeps to help us; see Note [Superclass iteration] +-- +-- Does not affect wc_holes at all; reason: wc_holes never affects anything +-- else, so we do them once, at the end in solveWanteds +simplify_loop n limit definitely_redo_implications + wc@(WC { wc_simple = simples, wc_impl = implics }) + | isSolvedWC wc -- Fast path + = return wc + | otherwise + = do { csTraceTcS $ + text "simplify_loop iteration=" <> int n + <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma + , int (lengthBag simples) <+> text "simples to solve" ]) + ; traceTcS "simplify_loop: wc =" (ppr wc) + + ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration] + solveSimpleWanteds simples + -- Any insoluble constraints are in 'simples' and so get rewritten + -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet + + -- Next, solve implications from wc_impl + ; implics' <- if not definitely_redo_implications -- See Note [Superclass iteration] + && unifs1 == 0 -- for this conditional + then return implics + else solveNestedImplications implics + + ; let wc' = wc1 { wc_impl = wc_impl wc1 `unionBags` implics' } + + ; unif_happened <- resetUnificationFlag + ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened + -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad + ; maybe_simplify_again (n+1) limit unif_happened wc' } + +maybe_simplify_again :: Int -> IntWithInf -> Bool + -> WantedConstraints -> TcS WantedConstraints +maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples }) + | n `intGtLimit` limit + = do { -- Add an error (not a warning) if we blow the limit, + -- Typically if we blow the limit we are going to report some other error + -- (an unsolved constraint), and we don't want that error to suppress + -- the iteration limit warning! + addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc + ; return wc } + + | unif_happened + = simplify_loop n limit True wc + + | superClassesMightHelp wc -- Returns False quickly if wc is solved + = -- We still have unsolved goals, and apparently no way to solve them, + -- so try expanding superclasses at this level, both Given and Wanted + do { pending_given <- getPendingGivenScs + ; let (pending_wanted, simples1) = getPendingWantedScs simples + ; if null pending_given && null pending_wanted + then return wc -- After all, superclasses did not help + else + do { new_given <- makeSuperClasses pending_given + ; new_wanted <- makeSuperClasses pending_wanted + ; solveSimpleGivens new_given -- Add the new Givens to the inert set + ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given + , text "new_given" <+> ppr new_given + , text "pending_wanted" <+> ppr pending_wanted + , text "new_wanted" <+> ppr new_wanted ]) + ; simplify_loop n limit (not (null pending_given)) $ + wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } } + -- (not (null pending_given)): see Note [Superclass iteration] + + | otherwise + = return wc + +{- Note [Superclass iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this implication constraint + forall a. + [W] d: C Int beta + forall b. blah +where + class D a b | a -> b + class D a b => C a b +We will expand d's superclasses, giving [W] D Int beta, in the hope of geting +fundeps to unify beta. Doing so is usually fruitless (no useful fundeps), +and if so it seems a pity to waste time iterating the implications (forall b. blah) +(If we add new Given superclasses it's a different matter: it's really worth looking +at the implications.) + +Hence the definitely_redo_implications flag to simplify_loop. It's usually +True, but False in the case where the only reason to iterate is new Wanted +superclasses. In that case we check whether the new Wanteds actually led to +any new unifications, and iterate the implications only if so. +-} + +{- Note [Expanding Recursive Superclasses and ExpansionFuel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the class declaration (T21909) + + class C [a] => C a where + foo :: a -> Int + +and suppose during type inference we obtain an implication constraint: + + forall a. C a => C [[a]] + +To solve this implication constraint, we first expand one layer of the superclass +of Given constraints, but not for Wanted constraints. +(See Note [Eagerly expand given superclasses] and Note [Why adding superclasses can help] +in GHC.Tc.Solver.Dict.) We thus get: + + [G] g1 :: C a + [G] g2 :: C [a] -- new superclass layer from g1 + [W] w1 :: C [[a]] + +Now, we cannot solve `w1` directly from `g1` or `g2` as we may not have +any instances for C. So we expand a layer of superclasses of each Wanteds and Givens +that we haven't expanded yet. +This is done in `maybe_simplify_again`. And we get: + + [G] g1 :: C a + [G] g2 :: C [a] + [G] g3 :: C [[a]] -- new superclass layer from g2, can solve w1 + [W] w1 :: C [[a]] + [W] w2 :: C [[[a]]] -- new superclass layer from w1, not solvable + +Now, although we can solve `w1` using `g3` (obtained from expanding `g2`), +we have a new wanted constraint `w2` (obtained from expanding `w1`) that cannot be solved. +We thus make another go at solving in `maybe_simplify_again` by expanding more +layers of superclasses. This looping is futile as Givens will never be able to catch up with Wanteds. + +Side Note: In principle we don't actually need to /solve/ `w2`, as it is a superclass of `w1` +but we only expand it to expose any functional dependencies (see Note [The superclass story]) +But `w2` is a wanted constraint, so we will try to solve it like any other, +even though ultimately we will discard its evidence. + +Solution: Simply bound the maximum number of layers of expansion for +Givens and Wanteds, with ExpansionFuel. Give the Givens more fuel +(say 3 layers) than the Wanteds (say 1 layer). Now the Givens will +win. The Wanteds don't need much fuel: we are only expanding at all +to expose functional dependencies, and wantedFuel=1 means we will +expand a full recursive layer. If the superclass hierarchy is +non-recursive (the normal case) one layer is therefore full expansion. + +The default value for wantedFuel = Constants.max_WANTEDS_FUEL = 1. +The default value for givenFuel = Constants.max_GIVENS_FUEL = 3. +Both are configurable via the `-fgivens-fuel` and `-fwanteds-fuel` +compiler flags. + +There are two preconditions for the default fuel values: + (1) default givenFuel >= default wantedsFuel + (2) default givenFuel < solverIterations + +Precondition (1) ensures that we expand givens at least as many times as we expand wanted constraints +preferably givenFuel > wantedsFuel to avoid issues like T21909 while +the precondition (2) ensures that we do not reach the solver iteration limit and fail with a +more meaningful error message (see T19627) + +This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field. +-} + +{- ******************************************************************************** +* * +* Solving implication constraints * +* * +******************************************************************************** -} + +solveNestedImplications :: Bag Implication + -> TcS (Bag Implication) +-- Precondition: the TcS inerts may contain unsolved simples which have +-- to be converted to givens before we go inside a nested implication. +solveNestedImplications implics + | isEmptyBag implics + = return (emptyBag) + | otherwise + = do { traceTcS "solveNestedImplications starting {" empty + ; unsolved_implics <- mapBagM solveImplication implics + + -- ... and we are back in the original TcS inerts + -- Notice that the original includes the _insoluble_simples so it was safe to ignore + -- them in the beginning of this function. + ; traceTcS "solveNestedImplications end }" $ + vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ] + + ; return unsolved_implics } + +{- Note [trySolveImplication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`trySolveImplication` may be invoked while solving simple wanteds, notably from +`solveWantedForAll`. It returns a Bool to say if solving succeeded or failed. + +It uses `nestImplicTcS` to build a nested scope. One subtle point is that +`nestImplicTcS` uses the `inert_givens` (not the `inert_cans`) of the current +inert set to initialse the `InertSet` of the nested scope. It is super-important not +to pollute the sub-solving problem with the unsolved Wanteds of the current scope. + +Whenever we do `solveSimpleGivens`, we snapshot the `inert_cans` into `inert_givens`. +(At that moment there should be no Wanteds.) +-} + +trySolveImplication :: Implication -> TcS Bool +-- See Note [trySolveImplication] +trySolveImplication (Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_given = given_ids + , ic_wanted = wanteds + , ic_env = ct_loc_env + , ic_info = info }) + = nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info ct_loc_env + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + ; residual_wanted <- solveWanteds wanteds + ; return (isSolvedWC residual_wanted) } + +solveImplication :: Implication -- Wanted + -> TcS Implication -- Simplified implication +-- Precondition: The TcS monad contains an empty worklist and given-only inerts +-- which after trying to solve this implication we must restore to their original value +solveImplication imp@(Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_given = given_ids + , ic_wanted = wanteds + , ic_info = info + , ic_env = ct_loc_env + , ic_status = status }) + | isSolvedStatus status + = return imp -- Do nothing + + | otherwise -- Even for IC_Insoluble it is worth doing more work + -- The insoluble stuff might be in one sub-implication + -- and other unsolved goals in another; and we want to + -- solve the latter as much as possible + = do { inerts <- getInertSet + ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts) + + -- commented out; see `where` clause below + -- ; when debugIsOn check_tc_level + + -- Solve the nested constraints + ; (has_given_eqs, given_insols, residual_wanted) + <- nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info ct_loc_env + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + + ; residual_wanted <- solveWanteds wanteds + + ; (has_eqs, given_insols) <- getHasGivenEqs tclvl + -- Call getHasGivenEqs /after/ solveWanteds, because + -- solveWanteds can augment the givens, via expandSuperClasses, + -- to reveal given superclass equalities + + ; return (has_eqs, given_insols, residual_wanted) } + + ; traceTcS "solveImplication 2" + (ppr given_insols $$ ppr residual_wanted) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; traceTcS "solveImplication 3" $ vcat + [ text "ev_binds_var" <+> ppr ev_binds_var + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) ] + + ; let final_wanted = residual_wanted `addInsols` given_insols + -- Don't lose track of the insoluble givens, + -- which signal unreachable code; put them in ic_wanted + + ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs + , ic_wanted = final_wanted }) + + ; evbinds <- TcS.getTcEvBindsMap ev_binds_var + ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; traceTcS "solveImplication end }" $ vcat + [ text "has_given_eqs =" <+> ppr has_given_eqs + , text "res_implic =" <+> ppr res_implic + , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds) + , text "implication tvcs =" <+> ppr tcvs ] + + ; return res_implic } + + -- TcLevels must be strictly increasing (see (ImplicInv) in + -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType), + -- and in fact I think they should always increase one level at a time. + + -- Though sensible, this check causes lots of testsuite failures. It is + -- remaining commented out for now. + {- + check_tc_level = do { cur_lvl <- TcS.getTcLevel + ; massertPpr (tclvl == pushTcLevel cur_lvl) + (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) } + -} + +---------------------- +setImplicationStatus :: Implication -> TcS Implication +-- Finalise the implication returned from solveImplication, +-- * Set the ic_status field +-- * Prune unnecessary evidence bindings +-- * Prune unnecessary child implications +-- Precondition: the ic_status field is not already IC_Solved +setImplicationStatus implic@(Implic { ic_status = old_status + , ic_info = info + , ic_wanted = wc }) + = assertPpr (not (isSolvedStatus old_status)) (ppr info) $ + -- Precondition: we only set the status if it is not already solved + do { traceTcS "setImplicationStatus {" (ppr implic) + + ; let solved = isSolvedWC wc + ; new_implic <- neededEvVars implic + ; bad_telescope <- if solved then checkBadTelescope implic + else return False + + ; let new_status | insolubleWC wc = IC_Insoluble + | not solved = IC_Unsolved + | bad_telescope = IC_BadTelescope + | otherwise = IC_Solved { ics_dead = dead_givens } + dead_givens = findRedundantGivens new_implic + new_wc = pruneImplications wc + + final_implic = new_implic { ic_status = new_status + , ic_wanted = new_wc } + + ; traceTcS "setImplicationStatus }" (ppr final_implic) + ; return final_implic } + +pruneImplications :: WantedConstraints -> WantedConstraints +-- We have now recorded the `ic_need` variables of the child +-- implications (in `ic_need_implics` of the parent) so we can +-- delete any unnecessary children. +pruneImplications wc@(WC { wc_impl = implics }) + = wc { wc_impl = filterBag keep_me implics } + -- Do not prune holes; these should be reported + where + keep_me :: Implication -> Bool + keep_me (Implic { ic_status = status, ic_wanted = wanted }) + | IC_Solved { ics_dead = dead_givens } <- status -- Fully solved + , null dead_givens -- No redundant givens to report + , isEmptyBag (wc_impl wanted) -- No children that might have things to report + = False + | otherwise + = True -- Otherwise, keep it + +findRedundantGivens :: Implication -> [EvVar] +findRedundantGivens (Implic { ic_info = info, ic_need = need, ic_given = givens }) + | not (warnRedundantGivens info) -- Don't report redundant constraints at all + = [] -- See (TRC4) of Note [Tracking redundant constraints] + + | not (null unused_givens) -- Some givens are literally unused + = unused_givens + + -- Only try this if unused_givens is empty: see (TRC2a) + | otherwise -- All givens are used, but some might + = redundant_givens -- still be redundant e.g. (Eq a, Ord a) + + where + in_instance_decl = case info of { InstSkol {} -> True; _ -> False } + -- See Note [Redundant constraints in instance decls] + + unused_givens = filterOut is_used givens + + needed_givens_ignoring_default_methods = ens_fvs need + is_used given = is_type_error given + || given `elemVarSet` needed_givens_ignoring_default_methods + || (in_instance_decl && is_improving (idType given)) + + minimal_givens = mkMinimalBySCs evVarPred givens -- See (TRC2) + + is_minimal = (`elemVarSet` mkVarSet minimal_givens) + redundant_givens + | in_instance_decl = [] + | otherwise = filterOut is_minimal givens + + -- See #15232 + is_type_error id = isTopLevelUserTypeError (idType id) + + is_improving pred -- (transSuperClasses p) does not include p + = any isImprovementPred (pred : transSuperClasses pred) + +warnRedundantGivens :: SkolemInfoAnon -> Bool +warnRedundantGivens (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt _ rrc -> reportRedundantConstraints rrc + ExprSigCtxt rrc -> reportRedundantConstraints rrc + _ -> False + +warnRedundantGivens (InstSkol from _) + -- Do not report redundant constraints for quantified constraints + -- See (TRC4) in Note [Tracking redundant constraints] + -- Fortunately it is easy to spot implications constraints that arise + -- from quantified constraints, from their SkolInfo + = case from of + IsQC {} -> False + IsClsInst {} -> True + + -- To think about: do we want to report redundant givens for + -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21. +warnRedundantGivens _ = False + +{- Note [Redundant constraints in instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instance declarations are special in two ways: + +* We don't report unused givens if they can give rise to improvement. + Example (#10100): + class Add a b ab | a b -> ab, a ab -> b + instance Add Zero b b + instance Add a b ab => Add (Succ a) b (Succ ab) + The context (Add a b ab) for the instance is clearly unused in terms + of evidence, since the dictionary has no fields. But it is still + needed! With the context, a wanted constraint + Add (Succ Zero) beta (Succ Zero) + we will reduce to (Add Zero beta Zero), and thence we get beta := Zero. + But without the context we won't find beta := Zero. + + This only matters in instance declarations. + +* We don't report givens that are a superclass of another given. E.g. + class Ord r => UserOfRegs r a where ... + instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where + The (Ord r) is not redundant, even though it is a superclass of + (UserOfRegs r CmmReg). See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. + + Again this is specific to instance declarations. +-} + + +checkBadTelescope :: Implication -> TcS Bool +-- True <=> the skolems form a bad telescope +-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint +checkBadTelescope (Implic { ic_info = info + , ic_skols = skols }) + | checkTelescopeSkol info + = do{ skols <- mapM TcS.zonkTyCoVarKind skols + ; return (go emptyVarSet (reverse skols))} + + | otherwise + = return False + + where + go :: TyVarSet -- skolems that appear *later* than the current ones + -> [TcTyVar] -- ordered skolems, in reverse order + -> Bool -- True <=> there is an out-of-order skolem + go _ [] = False + go later_skols (one_skol : earlier_skols) + | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols + = True + | otherwise + = go (later_skols `extendVarSet` one_skol) earlier_skols + +neededEvVars :: Implication -> TcS Implication +-- Find all the evidence variables that are "needed", +-- /and/ delete dead evidence bindings +-- +-- See Note [Tracking redundant constraints] +-- See Note [Delete dead Given evidence bindings] +-- +-- - Start from initial_seeds (from nested implications) +-- +-- - Add free vars of RHS of all Wanted evidence bindings +-- and coercion variables accumulated in tcvs (all Wanted) +-- +-- - Generate 'needed', the needed set of EvVars, by doing transitive +-- closure through Given bindings +-- e.g. Needed {a,b} +-- Given a = sc_sel a2 +-- Then a2 is needed too +-- +-- - Prune out all Given bindings that are not needed + +neededEvVars implic@(Implic { ic_info = info + , ic_binds = ev_binds_var + , ic_wanted = WC { wc_impl = implics } + , ic_need_implic = old_need_implic -- See (TRC1) + }) + = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var + ; used_cos <- TcS.getTcEvTyCoVars ev_binds_var + + ; let -- Find the variables needed by `implics` + new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds }) + = foldr add_implic old_need_implic implics + -- Start from old_need_implic! See (TRC1) + + -- Get the variables needed by the solved bindings + -- (It's OK to use a non-deterministic fold here + -- because add_wanted is commutative.) + used_covars = coVarsOfCos used_cos + seeds_w = nonDetStrictFoldEvBindMap add_wanted used_covars ev_binds + + need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w) + need_from_dms = findNeededGivenEvVars ev_binds dm_seeds + need_full = need_ignoring_dms `unionVarSet` need_from_dms + + -- `need`: the Givens from outer scopes that are used in this implication + -- is_dm_skol: see (TRC5) + need | is_dm_skol info = ENS { ens_dms = trim ev_binds need_full + , ens_fvs = emptyVarSet } + | otherwise = ENS { ens_dms = trim ev_binds need_from_dms + , ens_fvs = trim ev_binds need_ignoring_dms } + + -- Delete dead Given evidence bindings + -- See Note [Delete dead Given evidence bindings] + ; let live_ev_binds = filterEvBindMap (needed_ev_bind need_full) ev_binds + ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds + + ; traceTcS "neededEvVars" $ + vcat [ text "old_need_implic:" <+> ppr old_need_implic + , text "new_need_implic:" <+> ppr new_need_implic + , text "used_covars:" <+> ppr used_covars + , text "need_ignoring_dms:" <+> ppr need_ignoring_dms + , text "need_from_dms:" <+> ppr need_from_dms + , text "need:" <+> ppr need + , text "ev_binds:" <+> ppr ev_binds + , text "live_ev_binds:" <+> ppr live_ev_binds ] + ; return (implic { ic_need = need + , ic_need_implic = new_need_implic }) } + where + trim :: EvBindMap -> VarSet -> VarSet + -- Delete variables bound by Givens or bindings + trim ev_binds needs = needs `varSetMinusEvBindMap` ev_binds + + add_implic :: Implication -> EvNeedSet -> EvNeedSet + add_implic (Implic { ic_given = givens, ic_need = need }) acc + = (need `delGivensFromEvNeedSet` givens) `unionEvNeedSet` acc + + needed_ev_bind needed (EvBind { eb_lhs = ev_var, eb_info = info }) + | EvBindGiven{} <- info = ev_var `elemVarSet` needed + | otherwise = True -- Keep all wanted bindings + + add_wanted :: EvBind -> VarSet -> VarSet + add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs + | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only + | otherwise = nestedEvIdsOfTerm rhs `unionVarSet` needs + + is_dm_skol :: SkolemInfoAnon -> Bool + is_dm_skol (MethSkol _ is_dm) = is_dm + is_dm_skol _ = False + +findNeededGivenEvVars :: EvBindMap -> VarSet -> VarSet +-- Find all the Given evidence needed by seeds, +-- looking transitively through bindings for Givens (only) +findNeededGivenEvVars ev_binds seeds + = transCloVarSet also_needs seeds + where + also_needs :: VarSet -> VarSet + also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs + -- It's OK to use a non-deterministic fold here because we immediately + -- forget about the ordering by creating a set + + add :: Var -> VarSet -> VarSet + add v needs + | Just ev_bind <- lookupEvBind ev_binds v + , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind + -- Look at Given bindings only + = nestedEvIdsOfTerm rhs `unionVarSet` needs + | otherwise + = needs + +------------------------------------------------- +simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError) +-- Simplify any delayed errors: e.g. type and term holes +-- NB: At this point we have finished with all the simple +-- constraints; they are in wc_simple, not in the inert set. +-- So those Wanteds will not rewrite these delayed errors. +-- That's probably no bad thing. +-- +-- However if we have [W] alpha ~ Maybe a, [W] alpha ~ Int +-- and _ : alpha, then we'll /unify/ alpha with the first of +-- the Wanteds we get, and thereby report (_ : Maybe a) or +-- (_ : Int) unpredictably, depending on which we happen to see +-- first. Doesn't matter much; there is a type error anyhow. +-- T17139 is a case in point. +simplifyDelayedErrors = mapMaybeBagM simpl_err + where + simpl_err :: DelayedError -> TcS (Maybe DelayedError) + simpl_err (DE_Hole hole) = Just . DE_Hole <$> simpl_hole hole + simpl_err err@(DE_NotConcrete {}) = return $ Just err + simpl_err (DE_Multiplicity mult_co loc) + = do { mult_co' <- TcS.zonkCo mult_co + ; if isReflexiveCo mult_co' then + return Nothing + else + return $ Just (DE_Multiplicity mult_co' loc) } + + simpl_hole :: Hole -> TcS Hole + + -- See Note [Do not simplify ConstraintHoles] + simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h + + -- other wildcards should be simplified for printing + -- we must do so here, and not in the error-message generation + -- code, because we have all the givens already set up + simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc }) + = do { ty' <- rewriteType loc ty + ; traceTcS "simpl_hole" (ppr ty $$ ppr ty') + ; return (h { hole_ty = ty' }) } + +{- Note [Delete dead Given evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As a result of superclass expansion, we speculatively +generate evidence bindings for Givens. E.g. + f :: (a ~ b) => a -> b -> Bool + f x y = ... +We'll have + [G] d1 :: (a~b) +and we'll speculatively generate the evidence binding + [G] d2 :: (a ~# b) = sc_sel d + +Now d2 is available for solving. But it may not be needed! Usually +such dead superclass selections will eventually be dropped as dead +code, but: + + * It won't always be dropped (#13032). In the case of an + unlifted-equality superclass like d2 above, we generate + case heq_sc d1 of d2 -> ... + and we can't (in general) drop that case expression in case + d1 is bottom. So it's technically unsound to have added it + in the first place. + + * Simply generating all those extra superclasses can generate lots of + code that has to be zonked, only to be discarded later. Better not + to generate it in the first place. + + Moreover, if we simplify this implication more than once + (e.g. because we can't solve it completely on the first iteration + of simpl_loop), we'll generate all the same bindings AGAIN! + +Easy solution: take advantage of the work we are doing to track dead +(unused) Givens, and use it to prune the Given bindings too. This is +all done by neededEvVars. + +This led to a remarkable 25% overall compiler allocation decrease in +test T12227. + +But we don't get to discard all redundant equality superclasses, alas; +see #15205. + +Note [Do not simplify ConstraintHoles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before printing the inferred value for a type hole (a _ wildcard in +a partial type signature), we simplify it w.r.t. any Givens. This +makes for an easier-to-understand diagnostic for the user. + +However, we do not wish to do this for extra-constraint holes. Here is +the example for why (partial-sigs/should_compile/T12844): + + bar :: _ => FooData rngs + bar = foo + + data FooData rngs + + class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs + + type family Head (xs :: [k]) where Head (x ': xs) = x + +GHC correctly infers that the extra-constraints wildcard on `bar` +should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this +constraint as a Given on the implication constraint for `bar`. (This +implication is emitted by emitResidualConstraints.) The Hole for the _ +is stored within the implication's WantedConstraints. When +simplifyHoles is called, that constraint is already assumed as a +Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r, +r'), Foo rngs), which is disastrous. + +Furthermore, there is no need to simplify here: extra-constraints wildcards +are filled in with the output of the solver, in chooseInferredQuantifiers +(choose_psig_context), so they are already simplified. (Contrast to normal +type holes, which are just bound to a meta-variable.) Avoiding the poor output +is simple: just don't simplify extra-constraints wildcards. + +This is the only reason we need to track ConstraintHole separately +from TypeHole in HoleSort. + +See also Note [Extra-constraint holes in partial type signatures] +in GHC.Tc.Gen.HsType. + +Note [Tracking redundant constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Opt_WarnRedundantConstraints, GHC can report which constraints of a type +signature (or instance declaration) are redundant, and can be omitted. Here is +an overview of how it works. + +This is all tested in typecheck/should_compile/T20602 (among others). + +How tracking works: + +* We maintain the `ic_need` field in an implication: + ic_need: the set of Given evidence variables that are needed somewhere + inside this implication; and are bound either by this implication + or by an enclosing one. + +* `setImplicationStatus` does all the work: + - When the constraint solver finishes solving all the wanteds in + an implication, it sets its status to IC_Solved + + - `neededEvVars`: computes which evidence variables are needed by an + implication in `setImplicationStatus`. A variable is needed if + + a) It is in the ic_need field of this implication, computed in + a previous call to `setImplicationStatus`; see (TRC1) + + b) It is in the ics_need of a nested implication; see `add_implic` + in `neededEvVars` + + c) It is free in the RHS of any /Wanted/ EvBind; each such binding + solves a Wanted, so we want them all. See `add_wanted` in + `neededEvVars` + + d) It is free in the RHS of a /Given/ EvBind whose LHS is needed: + see `findNeededGivenEvVars` called from `neededEvVars`. + + - Next, if the final status is IC_Solved, `setImplicationStatus` uses + `findRedundantGivens` to decide which of this implication's Givens + are redundant. + + - It also uses `pruneImplications` to discard any now-unnecessary child + implications. + +* GHC.Tc.Errors does the actual warning, in `warnRedundantConstraints`. + + +Wrinkles: + +(TRC1) `pruneImplications` drops any sub-implications of an Implication + that are irrelevant for error reporting: + - no unsolved wanteds + - no sub-implications + - no redundant givens to report + But in doing so we must not lose track of the variables that those implications + needed! So we track the ic_needs of all child implications in `ic_need_implics`. + Crucially, this set includes things need by child implications that have been + discarded by `pruneImplications`. + +(TRC2) A Given can be redundant because it is implied by other Givens + f :: (Eq a, Ord a) => blah -- Eq a unnecessary + g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary + We nail this by using `mkMinimalBySCs` in `findRedundantGivens`. + (TRC2a) But NOTE that we only attempt this mkMinimalBySCs stuff if all Givens + used by evidence bindings. Example: + f :: (Eq a, Ord a) => a -> Bool + f x = x == x + We report (Ord a) as unused because it is. But we must not also report (Eq a) + as unused because it is a superclass of Ord! + +(TRC3) When two Givens are the same, prefer one that does not involve superclass + selection, or more generally has shallower superclass-selection depth: + see 2(b,c) in Note [Replacement vs keeping] in GHC.Tc.Solver.InertSet. + e.g f :: (Eq a, Ord a) => a -> Bool + f x = x == x + Eager superclass expansion gives us two [G] Eq a constraints. We want to keep + the one from the user-written Eq a, not the superclass selection. This means + we report the Ord a as redundant with -Wredundant-constraints, not the Eq a. + Getting this wrong was #20602. + +(TRC4) We don't compute redundant givens for *every* implication; only + for those which reply True to `warnRedundantGivens`: + + - For example, in a class declaration, the default method *can* + use the class constraint, but it certainly doesn't *have* to, + and we don't want to report an error there. Ditto instance decls. + + - More subtly, in a function definition + f :: (Ord a, Ord a, Ix a) => a -> a + f x = rhs + we do an ambiguity check on the type (which would find that one + of the Ord a constraints was redundant), and then we check that + the definition has that type (which might find that both are + redundant). We don't want to report the same error twice, so we + disable it for the ambiguity check. Hence using two different + FunSigCtxts, one with the warn-redundant field set True, and the + other set False in + - GHC.Tc.Gen.Bind.tcSpecPrag + - GHC.Tc.Gen.Bind.tcTySig + + - We do not want to report redundant constraints for implications + that come from quantified constraints. Example #23323: + data T a + instance Show (T a) where ... -- No context! + foo :: forall f c. (forall a. c a => Show (f a)) => Proxy c -> f Int -> Int + bar = foo @T @Eq + + The call to `foo` gives us + [W] d : (forall a. Eq a => Show (T a)) + To solve this, GHC.Tc.Solver.Solve.solveForAll makes an implication constraint: + forall a. Eq a => [W] ds : Show (T a) + and because of the degnerate instance for `Show (T a)`, we don't need the `Eq a` + constraint. But we don't want to report it as redundant! + +(TRC5) Consider this (#25992), where `op2` has a default method + class C a where { op1, op2 :: a -> a + ; op2 = op1 . op1 } + instance C a => C [a] where + op1 x = x + + Plainly the (C a) constraint is unused; but the expanded decl will look like + $dmop2 :: C a => a -> a + $dmop2 = op1 . op1 + + $fCList :: forall a. C a => C [a] + $fCList @a (d::C a) = MkC (\(x:a).x) ($dmop2 @a d) + + Notice that `d` gets passed to `$dmop`: it is "needed". But it's only + /really/ needed if some /other/ method (in this case `op1`) uses it. + + So, rather than one set of "needed Givens" we use `EvNeedSet` to track + a /pair/ of sets: + ens_dms: needed /only/ by default-method calls + ens_fvs: needed by something other than a default-method call + It's a bit of a palaver, but not really difficult. + All the logic is localised in `neededEvVars`. + + But NOTE that this only applies to /vanilla/ default methods. + For /generic/ default methods, like + class D a where { op1 :: blah + ; default op1 :: Eq a => blah2 } + the (Eq a) constraint really is needed (e.g. class NFData and #25992). + Hence the `Bool` field of `MethSkol` indicates a /vanilla/ default method. + +----- Examples + + f, g, h :: (Eq a, Ord a) => a -> Bool + f x = x == x + g x = x > x + h x = x == x && x > x + + All of f,g,h will discover that they have two [G] Eq a constraints: one as + given and one extracted from the Ord a constraint. They will both discard + the latter; see (TRC3). + + The body of f uses the [G] Eq a, but not the [G] Ord a. It will report a + redundant Ord a. + + The body of g uses the [G] Ord a, but not the [G] Eq a. It will report a + redundant Eq a. + + The body of h uses both [G] Ord a and [G] Eq a; each is used in a solved + Wanted evidence binding. But (TRC2) kicks in and discovers the Eq a + is redundant. + +----- Shortcomings + +Shortcoming 1. Consider + + j :: (Eq a, a ~ b) => a -> Bool + j x = x == x + + k :: (Eq a, b ~ a) => a -> Bool + k x = x == x + +Currently (Nov 2021), j issues no warning, while k says that b ~ a +is redundant. This is because j uses the a ~ b constraint to rewrite +everything to be in terms of b, while k does none of that. This is +ridiculous, but I (Richard E) don't see a good fix. + +Shortcoming 2. Removing a redundant constraint can cause clients to fail to +compile, by making the function more polymorphic. Consider (#16154) + + f :: (a ~ Bool) => a -> Int + f x = 3 + + g :: String -> Int + g s = f (read s) + +The constraint in f's signature is redundant; not used to typecheck +`f`. And yet if you remove it, `g` won't compile, because there'll +be an ambiguous variable in `g`. + + +********************************************************************** +* * +* Main Solver * +* * +********************************************************************** + +Note [Basic Simplifier Plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Pick an element from the WorkList if there exists one with depth + less than our context-stack depth. + +2. Run it down the 'stage' pipeline. Stages are: + - canonicalization + - inert reactions + - spontaneous reactions + - top-level interactions + Each stage returns a StopOrContinue and may have sideeffected + the inerts or worklist. + + The threading of the stages is as follows: + - If (Stop) is returned by a stage then we start again from Step 1. + - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to + the next stage in the pipeline. +4. If the element has survived (i.e. ContinueWith x) the last stage + then we add it in the inerts and jump back to Step 1. + +If in Step 1 no such element exists, we have exceeded our context-stack +depth and will simply fail. +-} + +solveSimpleGivens :: [Ct] -> TcS () +solveSimpleGivens givens + | null givens -- Shortcut for common case + = return () + | otherwise + = do { traceTcS "solveSimpleGivens {" (ppr givens) + ; go givens + + -- Capture the Givens in the inert_givens of the inert set + -- for use by subsequent calls of nestImplicTcS + -- See Note [trySolveImplication] + ; updInertSet (\is -> is { inert_givens = inert_cans is }) + + ; cans <- getInertCans + ; traceTcS "End solveSimpleGivens }" (ppr cans) } + where + go givens = do { solveSimples (listToBag givens) + ; new_givens <- runTcPluginsGiven + ; when (notNull new_givens) $ + go new_givens } + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +-- Returns unsolved constraints, mostly just flat ones (Cts), +-- but also any unsolved implications arising from forall-constraints +-- The result is not necessarily zonked +solveSimpleWanteds simples + = do { mode <- getTcSMode + ; dflags <- getDynFlags + ; inerts <- getInertSet + + ; traceTcS "solveSimpleWanteds {" $ + vcat [ text "Mode:" <+> ppr mode + , text "Inerts:" <+> ppr inerts + , text "Wanteds to solve:" <+> ppr simples ] + + ; (n,simples',implics') <- go (solverIterations dflags) 1 emptyBag simples + + ; let unsolved_wc = emptyWC { wc_simple = simples', wc_impl = implics' } + + ; traceTcS "solveSimpleWanteds end }" $ + vcat [ text "iterations =" <+> ppr n + , text "residual =" <+> ppr unsolved_wc ] + + ; return unsolved_wc } + where + go :: IntWithInf -- Limit + -> Int -- Iteration number + -> Bag Implication -- Accumulating parameter: unsolved implications + -> Cts -- Try to solve these + -> TcS (Int, Cts, Bag Implication) + -- See Note [The solveSimpleWanteds loop] + go limit n implics wanted + | n `intGtLimit` limit + = failTcS $ TcRnSimplifierTooManyIterations + simples limit + (emptyWC { wc_simple = wanted, wc_impl = implics }) + + | isEmptyBag wanted + = return (n, wanted, implics) + + | otherwise + = do { -- Solve + (wanted1, implics1) <- solve_one wanted + ; let implics2 = implics `unionBags` implics1 + + -- Run plugins + -- NB: runTcPluginsWanted has a fast path for + -- empty wanted1, which is the common case + ; (rerun_plugin, wanted2) <- runTcPluginsWanted wanted1 + + ; if rerun_plugin + then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin) + ; go limit (n+1) implics2 wanted2 } -- Loop + else return (n, wanted2, implics2) } -- Done + + + solve_one :: Cts -> TcS (Cts, Bag Implication) + -- Try solving these constraints + -- Affects the unification state (of course) but not the inert set + -- The result is not necessarily zonked + solve_one simples + = nestTcS $ + do { solveSimples simples + ; simples' <- getUnsolvedInerts + -- Now try to solve any Wanted quantified + -- constraints (i.e. QCInsts) in `simples1` + ; solveWantedQCIs simples' } + + +{- Note [The solveSimpleWanteds loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a bunch of simple constraints is done in a loop, +(the 'go' loop of 'solveSimpleWanteds'): + 1. Try to solve them + 2. Try the plugin + 3. If the plugin wants to run again, go back to step 1 +-} + +{- +************************************************************************ +* * + Solving flat constraints: solveSimples +* * +********************************************************************* -} + +-- The main solver loop implements Note [Basic Simplifier Plan] +--------------------------------------------------------------- + +solveSimples :: Cts -> TcS () +-- Solve this bag of constraints, +-- returning the final InertSet in TcS +-- The constraints are initially examined in left-to-right order + +solveSimples cts + = {-# SCC "solveSimples" #-} + do { emitWork cts; solve_loop } + where + solve_loop + = {-# SCC "solve_loop" #-} + do { sel <- selectNextWorkItem + ; case sel of + Nothing -> return () + Just ct -> do { solveOne ct + ; solve_loop } } + +solveOne :: Ct -> TcS () -- Solve one constraint +solveOne workItem + = do { wl <- getWorkList + ; inerts <- getInertSet + ; tclevel <- TcS.getTcLevel + ; traceTcS "----------------------------- " empty + ; traceTcS "Start solver pipeline {" $ + vcat [ text "tclevel =" <+> ppr tclevel + , text "work item =" <+> ppr workItem + , text "inerts =" <+> ppr inerts + , text "rest of worklist =" <+> ppr wl ] + + ; bumpStepCountTcS -- One step for each constraint processed + ; solve workItem } + where + solve :: Ct -> TcS () + solve ct + = do { traceTcS "solve {" (text "workitem = " <+> ppr ct) + ; res <- runSolverStage (solveCt ct) + ; traceTcS "end solve }" (ppr res) + ; case res of + StartAgain ct -> do { traceTcS "Go round again" (ppr ct) + ; solve ct } + + Stop ev s -> do { traceFireTcS ev s + ; traceTcS "End solver pipeline }" empty + ; return () } + + -- ContinueWith can't happen: res :: SolverStage Void + -- solveCt either solves the constraint, or puts + -- the unsolved constraint in the inert set. + } + +{- ********************************************************************* +* * +* Solving one constraint: solveCt +* * +************************************************************************ + +Note [Canonicalization] +~~~~~~~~~~~~~~~~~~~~~~~ +Canonicalization converts a simple constraint to a canonical form. It is +unary (i.e. treats individual constraints one at a time). + +Constraints originating from user-written code come into being as +CNonCanonicals. We know nothing about these constraints. So, first: + + Classify CNonCanoncal constraints, depending on whether they + are equalities, class predicates, or other. + +Then proceed depending on the shape of the constraint. Generally speaking, +each constraint gets rewritten and then decomposed into one of several forms +(see type Ct in GHC.Tc.Types). + +When an already-canonicalized constraint gets kicked out of the inert set, +it must be recanonicalized. But we know a bit about its shape from the +last time through, so we can skip the classification step. +-} + +solveCt :: Ct -> SolverStage Void +-- The Void result tells us that solveCt cannot return +-- a ContinueWith; it must return Stop or StartAgain. +solveCt (CNonCanonical ev) = solveNC ev +solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev + +solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel + , eq_lhs = lhs, eq_rhs = rhs })) + = solveEquality ev eq_rel (canEqLHSType lhs) rhs + +solveCt (CQuantCan qci@(QCI { qci_ev = ev })) + = do { ev' <- rewriteEvidence ev + -- It is (much) easier to rewrite and re-classify than to + -- rewrite the pieces and build a Reduction that will rewrite + -- the whole constraint + ; case classifyPredType (ctEvPred ev') of + ForAllPred tvs theta body_pred + -> solveForAll (qci { qci_ev = ev', qci_tvs = tvs + , qci_theta = theta, qci_body = body_pred }) + _ -> pprPanic "SolveCt" (ppr ev) } + +solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc })) + = do { ev <- rewriteEvidence ev + -- It is easier to rewrite and re-classify than to rewrite + -- the pieces and build a Reduction that will rewrite the + -- whole constraint + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys + -> solveDict (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = pend_sc }) + _ -> pprPanic "solveCt" (ppr ev) } + +------------------ +solveNC :: CtEvidence -> SolverStage Void +solveNC ev + = -- Instead of rewriting the evidence before classifying, it's possible we + -- can make progress without the rewrite. Try this first. + -- For insolubles (all of which are equalities), do /not/ rewrite the arguments + -- In #14350 doing so led entire-unnecessary and ridiculously large + -- type function expansion. Instead, canEqNC just applies + -- the substitution to the predicate, and may do decomposition; + -- e.g. a ~ [a], where [G] a ~ [Int], can decompose + case classifyPredType (ctEvPred ev) of { + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 ; + _ -> + + -- Do rewriting on the constraint, especially zonking + do { ev <- rewriteEvidence ev + + -- And then re-classify + ; case classifyPredType (ctEvPred ev) of + ClassPred cls tys -> solveDictNC ev cls tys + ForAllPred tvs th p -> solveForAllNC ev tvs th p + IrredPred {} -> solveIrred (IrredCt { ir_ev = ev, ir_reason = IrredShapeReason }) + EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 + -- EqPred only happens if (say) `c` is unified with `a ~# b`, + -- but that is rare because it requires c :: CONSTRAINT UnliftedRep + + }} + + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +{- Note [Quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The -XQuantifiedConstraints extension allows type-class contexts like this: + + data Rose f x = Rose x (f (Rose f x)) + + instance (Eq a, forall b. Eq b => Eq (f b)) + => Eq (Rose f a) where + (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2 + +Note the (forall b. Eq b => Eq (f b)) in the instance contexts. +This quantified constraint is needed to solve the + [W] (Eq (f (Rose f x))) +constraint which arises form the (==) definition. + +The wiki page is + https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints +which in turn contains a link to the GHC Proposal where the change +is specified, and a Haskell Symposium paper about it. + +We implement two main extensions to the design in the paper: + + 1. We allow a variable in the instance head, e.g. + f :: forall m a. (forall b. m b) => D (m a) + Notice the 'm' in the head of the quantified constraint, not + a class. + + 2. We support superclasses to quantified constraints. + For example (contrived): + f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool + f x y = x==y + Here we need (Eq (m a)); but the quantified constraint deals only + with Ord. But we can make it work by using its superclass. + +Here are the moving parts + * Language extension {-# LANGUAGE QuantifiedConstraints #-} + and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension + + * A new form of evidence, EvDFun, that is used to discharge + such wanted constraints + + * checkValidType gets some changes to accept forall-constraints + only in the right places. + + * Predicate.Pred gets a new constructor ForAllPred, and + and `classifyPredType` analyses a `PredType` to decompose + the new forall-constraints + + * GHC.Tc.Solver.Monad.InertCans gets an extra field, `inert_qcis`, + which holds all the Given forall-constraints. In effect, + such Given constraints are like local instance decls. + + * `inert_qcis` also temporarily holds Wanted quantified constraints + (see Note [Solving a Wanted forall-constraint]) + + * When trying to solve a class constraint, GHC.Tc.Solver.Dict.matchLocalInst + (note "local" inst) uses the Given `inert_qcis` to solve the constraint. + + * `solveForAll` deals with solving a forall-constraint. See + * Note [Solving a Given forall-constraint] + * Note [Solving a Wanted forall-constraint] + +Note that a quantified constraint is never /inferred/ +(by GHC.Tc.Solver.simplifyInfer). A function can only have a +quantified constraint in its type if it is given an explicit +type signature. + +Note [Solving a Given forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a Given constraint + [G] df :: forall ab. (Eq a, Ord b) => C x a b +we just add it to TcS's local InstEnv of known instances, `inert_qcis`, +via addInertQCI. Then, if we look up (C x Int Bool), say, +we'll find a match in the `inert_qcis`. + +Note [Solving a Wanted forall-constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Solving a wanted forall (quantified) constraint + [W] df :: forall a b. (Eq a, Ord b) => C x a b +is delightfully easy in principle. Just build an implication constraint + forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a +and discharge df thus: + df = /\ab. \g1 g2. let in d +where is filled in by solving the implication constraint. + +What we actually do is this: + +* In `solveForAll` we see if we have an identical quantified constraint + to solve it (using tryInertQCs). In particular, solve a Wanted QCI + from an identical Given. This is more than a simple optimisation: + see Note [Solving Wanted QCs from Given QCs] + + If not, just stash it in `inert_qcis :: [QCInst]`. (If it's a Given + we can use it to solve other constraints; if a Wanted we will solve + it later using `solveWantedQCIs`.) + +* In the main `solveSimpleWanteds` (specifically `solve_one`): + + - We attempt to solve the `wc_simple` constraints with `solveSimples` + Unsolved quantified constraints just accumulate in the `inert_qcis` field + of the `InertSet`. + + - Then we use `solveWantedQCIs` to solve any quantified constraints. That + often turns the `QCInst` into an `Implication`; but not invariably (WFA4) + +Wrinkles: + +(WFA2) Termination: see #19690. We want to maintain the invariant (QC-INV): + + (QC-INV) Every quantified constraint returns a non-bottom dictionary + + just as every top-level instance declaration guarantees to return a non-bottom + dictionary. But as #19690 shows, it is possible to get a bottom dictionary + by superclass selection if we aren't careful. The situation is very similar + to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; + and we use the same solution: + + * Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) + * Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) + + Both of these things are done in `solveWantedQCI`. Now the mechanism described + in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. + +(WFA3) Error messages. Suppose we are trying to solve the quantified constraint + forall a. Eq a => Eq (c a) + We don't just want to say "No instance for Eq (c a)". It /really/ helps to + say what quantified constraint we were trying to solve. + + So the `IsQC` origin carries that info, and `GHC.Tc.Errors.Ppr.pprQCOriginExtra` + prints the extra info. + +(WFA4) When `tcsmFullySolveQCIs` is on, we adopt an all-or-nothing strategy: + either solve the forall-constraint /fully/ or do nothing at all. + Why? See (NFS1) in Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig + +(WFA5) Why not /always/ us the all-or-nothing strategy, so we don't need a + flag? Several reasons: + + * Less efficient; `tcsmFullySolveQCIs` abandons the work done on the constraint, + so we might do it again next time around. + + * More importantly, we would get worse results from `deriving`: #26315. + In that code the `deriving` mechanism was trying to solve + [W] df :: forall n. Eq (Const i n) + If we turn it into an implication, we can simplfy that `Const` to get + the residual implication + forall n. [W] d :: Eq i + And then `approximateWC` can extract the (Eq i) as a plausible context for + the instance. + + * Very much the same issue came up for the inferred type of a function that + lacks a type signature #26376. Again, if the forall-constraint is not + turned into an implication `approximateWC` gives a less-good answer. + +Note [Solving Wanted QCs from Given QCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are about to solve a Wanted quantified constraint, and there is a +Given quantified constraint with the same type, we should directly solve the +Wanted from the Given (instead of building an implication). + +Not only is this more direct and efficient, sometimes it is also /necessary/. +Consider: + + f :: forall a k. (Eq a, forall x. Eq x => Eq k x) => a -> blah + {-# SPECIALISE (f :: forall k. (forall x. Eq x => Eq k x) => Int -> blah #-} + +Here we specialise the `a` parameter to `f`, leaving the quantified constraint +untouched. We want to get a rule like: + + RULE forall @k (d :: forall x. Eq x => Eq k x). + f @Int @k d = $sf @k d + +But when we typecheck that expression-with-a-type-signature, if we don't solve +Wanted forall constraints directly, we will do so indirectly and end up with +this as the LHS of the RULE: + + (/\k \(df::forall x.Eq x => Eq k x). f @Int @k (/\x \(d:Eq x). df @x d)) + @kk dd + +We run the simple optimiser on that, which eliminates the beta-redex. However, +it may not eta-reduce that `/\x \(d:Eq x)...`, because we are cautious about +eta-reduction. So we may be left with an over-complicated and hard-to-match +RULE LHS. It's all a bit silly, because the implication constraint is /identical/; +we just need to spot it. + +This came up while implementing GHC proposal 493 (allowing expresions in +SPECIALISE pragmas). +-} + +-- | Solve a quantified constraint that came from @CNonCanonical@ (which means +-- that superclasses have not yet been expanded). +-- +-- Precondition: the constraint has already been rewritten by the inert set. +solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType + -> SolverStage Void +solveForAllNC ev tvs theta body_pred + = do { fuel <- simpleStage mk_super_classes + ; solveForAll (QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta + , qci_body = body_pred, qci_pend_sc = fuel }) } + + where + mk_super_classes :: TcS ExpansionFuel + mk_super_classes + | Just (cls,tys) <- getClassPredTys_maybe body_pred + , classHasSCs cls + = do { dflags <- getDynFlags + -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds) + ; if isGiven ev + then + -- See Note [Eagerly expand given superclasses] + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys + ; emitWork (listToBag sc_cts) + ; return doNotExpand } + else + -- See invariants (a) and (b) in QCI.qci_pend_sc + -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + -- See Note [Quantified constraints] + return (qcsFuel dflags) + } + + | otherwise + = return doNotExpand + +-- | Solve a canonical quantified constraint. +-- +-- Precondition: the constraint has already been rewritten by the inert set. +solveForAll :: QCInst -> SolverStage Void +solveForAll qci@(QCI { qci_ev = ev }) + = case ev of + CtGiven {} -> + -- See Note [Solving a Given forall-constraint] + do { simpleStage (addInertQCI qci) + ; stopWithStage ev "Given forall-constraint" } + CtWanted {} -> + -- See Note [Solving a Wanted forall-constraint] + do { tryInertQCs qci + ; simpleStage (addInertQCI qci) + ; stopWithStage ev "Wanted forall-constraint" } + +tryInertQCs :: QCInst -> SolverStage () +tryInertQCs qc + = Stage $ + do { inerts <- getInertCans + ; try_inert_qcs qc (inert_qcis inerts) } + +try_inert_qcs :: QCInst -> [QCInst] -> TcS (StopOrContinue ()) +try_inert_qcs (QCI { qci_ev = ev_w }) inerts = + case mapMaybe matching_inert inerts of + [] -> do { traceTcS "tryInertQCs:nothing" (ppr ev_w $$ ppr inerts) + ; continueWith () } + ev_i:_ -> + do { traceTcS "tryInertQCs:KeepInert" (ppr ev_i) + ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i) + ; stopWith ev_w "Solved Wanted forall-constraint from inert" } + where + matching_inert (QCI { qci_ev = ev_i }) + | ctEvPred ev_i `tcEqType` ctEvPred ev_w + = Just ev_i + | otherwise + = Nothing + +solveWantedQCIs :: Cts -> TcS (Cts, Bag Implication) +solveWantedQCIs wanteds + = do { mode <- getTcSMode + ; bag_of_eithers <- mapBagM (solveWantedQCI mode) wanteds + -- bag_of_eithers :: Bag (Either Ct Implication) + ; return (partitionBagWith id bag_of_eithers) } + +solveWantedQCI :: TcSMode + -> Ct -- Definitely a Wanted + -> TcS (Either Ct Implication) +-- Try to solve a quantified constraint, `ct` +-- Returns +-- (Left ct) if `ct` is not a quantified constraint +-- (Right implic) if we can solve a quantified constraint `ct` by creating +-- an implication and fully or partly solving it +-- (Left ct) for a quantified constraint that can't be /fully solved/, +-- but mode is tcsmFullySolveQCIs +-- See Note [Solving a Wanted forall-constraint] +solveWantedQCI mode ct@(CQuantCan (QCI { qci_ev = ev, qci_tvs = tvs + , qci_theta = theta, qci_body = body_pred })) + | CtWanted (WantedCt { ctev_pred = forall_pred, ctev_dest = dest + , ctev_rewriters = rewriters, ctev_loc = loc }) <- ev + , let is_qc = IsQC forall_pred (ctLocOrigin loc) + empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs + = TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ + -- This setSrcSpan is important: the TcM.newImplication uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) + do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + -- Very like the code in tcSkolDFunType + ; rec { skol_info <- mkSkolemInfo skol_info_anon + ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs + ; let inst_pred = substTy subst body_pred + inst_theta = substTheta subst theta + skol_info_anon = InstSkol is_qc (pSizeHead inst_pred) } + + ; given_ev_vars <- mapM TcS.newEvVar inst_theta + ; (lvl, wanted_ev) + <- pushLevelNoWorkList (ppr skol_info) $ + do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) + -- Set the thing to prove to have a ScOrigin, so we are + -- careful about its termination checks. + -- See (QC-INV) in Note [Solving a Wanted forall-constraint] + ; newWantedNC loc' rewriters inst_pred } + + ; ev_binds_var <- TcS.newTcEvBinds + ; let imp :: Implication + imp = (implicationPrototype (ctLocEnv loc)) + { ic_tclvl = lvl + , ic_skols = skol_tvs + , ic_given = given_ev_vars + , ic_wanted = mkSimpleWC [CtWanted wanted_ev] + , ic_binds = ev_binds_var + , ic_warn_inaccessible = False + , ic_info = skol_info_anon } + + ; imp' <- solveImplication imp + + + ; if | tcsmFullySolveQCIs mode + , not (isSolvedStatus (ic_status imp')) + -> -- Not fully solved, but mode says that we must fully + -- solve quantified constraints; so abandon the attempt + -- See (WFA4) in Note [Solving a Wanted forall-constraint] + return (Left ct) + + | otherwise + -> -- Commit to the (partly or fully solved) implication + -- See (WFA5) in Note [Solving a Wanted forall-constraint] + -- Record evidence and return residual implication + -- NB: even if it is fully solved we must return it, because it is + -- carrying a record of which evidence variables are used + -- See Note [Free vars of EvFun] in GHC.Tc.Types.Evidence + do { setWantedEvTerm dest EvCanonical $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = TcEvBinds ev_binds_var + , et_body = wantedCtEvEvId wanted_ev } + + ; return (Right imp') } + } + + | otherwise -- A Given QCInst + = pprPanic "wantedQciToImplic: found a Given QCI" (ppr ct) + +-- No-op on all Ct's other than CQuantCan +solveWantedQCI _ ct = return (Left ct) + + +{- +************************************************************************ +* * + Evidence transformation +* * +************************************************************************ +-} + +rewriteEvidence :: CtEvidence -> SolverStage CtEvidence +-- (rewriteEvidence old_ev new_pred co do_next) +-- Main purpose: create new evidence for new_pred; +-- unless new_pred is cached already +-- * Calls do_next with (new_ev :: new_pred), with same wanted/given flag as old_ev +-- * If old_ev was wanted, create a binding for old_ev, in terms of new_ev +-- * If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev +-- * Stops if new_ev is already cached +-- +-- Old evidence New predicate is Return new evidence +-- flavour of same flavor +-- ------------------------------------------------------------------- +-- Wanted Already solved or in inert Stop +-- Not do_next new_evidence +-- +-- Given Already in inert Stop +-- Not do_next new_evidence + +{- Note [Rewriting with Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the coercion is just reflexivity then you may re-use the same +evidence variable. But be careful! Although the coercion is Refl, new_pred +may reflect the result of unification alpha := ty, so new_pred might +not _look_ the same as old_pred, and it's vital to proceed from now on +using new_pred. + +The rewriter preserves type synonyms, so they should appear in new_pred +as well as in old_pred; that is important for good error messages. + +If we are rewriting with Refl, then there are no new rewriters to add to +the rewriter set. We check this with an assertion. + -} + + +rewriteEvidence ev + = Stage $ do { traceTcS "rewriteEvidence" (ppr ev) + ; (redn, rewriters) <- rewrite ev (ctEvPred ev) + ; finish_rewrite ev redn rewriters } + +finish_rewrite :: CtEvidence -- ^ old evidence + -> Reduction -- ^ new predicate + coercion, of type ~ new predicate + -> RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] + -- in GHC.Tc.Types.Constraint + -> TcS (StopOrContinue CtEvidence) +finish_rewrite old_ev (Reduction co new_pred) rewriters + | isReflCo co -- See Note [Rewriting with Refl] + = assert (isEmptyRewriterSet rewriters) $ + continueWith (setCtEvPredType old_ev new_pred) + +finish_rewrite + ev@(CtGiven (GivenCt { ctev_evar = old_evar })) + (Reduction co new_pred) + rewriters + = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted + do { let loc = ctEvLoc ev + -- mkEvCast optimises ReflCo + ev_rw_role = ctEvRewriteRole ev + new_tm = assert (coercionRole co == ev_rw_role) + evCast (evId old_evar) $ -- evCast optimises ReflCo + downgradeRole Representational ev_rw_role co + ; new_ev <- newGivenEvVar loc (new_pred, new_tm) + ; continueWith $ CtGiven new_ev } + +finish_rewrite + ev@(CtWanted (WantedCt { ctev_rewriters = rewriters, ctev_dest = dest })) + (Reduction co new_pred) + new_rewriters + = do { let loc = ctEvLoc ev + rewriters' = rewriters S.<> new_rewriters + ev_rw_role = ctEvRewriteRole ev + ; mb_new_ev <- newWanted loc rewriters' new_pred + ; massert (coercionRole co == ev_rw_role) + ; setWantedEvTerm dest EvCanonical $ + evCast (getEvExpr mb_new_ev) $ + downgradeRole Representational ev_rw_role (mkSymCo co) + ; case mb_new_ev of + Fresh new_ev -> continueWith $ CtWanted new_ev + Cached _ -> stopWith ev "Cached wanted" } + +{- ******************************************************************* +* * +* Typechecker plugins +* * +******************************************************************* -} + +-- | Extract the (inert) givens and invoke the plugins on them. +-- Remove solved givens from the inert set and emit insolubles, but +-- return new work produced so that 'solveSimpleGivens' can feed it back +-- into the main solver. +runTcPluginsGiven :: TcS [Ct] +runTcPluginsGiven + = do { solvers <- getTcPluginSolvers + ; if null solvers then return [] else + do { givens <- getInertGivens + ; if null givens then return [] else + do { traceTcS "runTcPluginsGiven {" (ppr givens) + ; p <- runTcPluginSolvers solvers (givens,[]) + ; let (solved_givens, _) = pluginSolvedCts p + insols = map (ctIrredCt PluginReason) (pluginBadCts p) + ; updInertCans (removeInertCts solved_givens . + updIrreds (addIrreds insols) ) + ; traceTcS "runTcPluginsGiven }" $ + vcat [ text "solved_givens:" <+> ppr solved_givens + , text "insols:" <+> ppr insols + , text "new:" <+> ppr (pluginNewCts p) ] + ; return (pluginNewCts p) } } } + +-- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on +-- them and produce an updated bag of wanteds (possibly with some new +-- work) and a bag of insolubles. The boolean indicates whether +-- 'solveSimpleWanteds' should feed the updated wanteds back into the +-- main solver. +runTcPluginsWanted :: Cts -> TcS (Bool, Cts) +runTcPluginsWanted wanted + | isEmptyBag wanted + = return (False, wanted) + | otherwise + = do { solvers <- getTcPluginSolvers + ; if null solvers then return (False, wanted) else + + do { -- Find the set of Givens to give to the plugin. + given <- getInertGivens + + -- Plugin requires zonked input wanteds + ; zonked_wanted <- TcS.zonkSimples wanted + + ; traceTcS "Running plugins {" (vcat [ text "Given:" <+> ppr given + , text "Wanted:" <+> ppr zonked_wanted ]) + ; p <- runTcPluginSolvers solvers (given, bagToList zonked_wanted) + ; let (_, solved_wanted) = pluginSolvedCts p + (_, unsolved_wanted) = pluginInputCts p + new_wanted = pluginNewCts p + insols = pluginBadCts p + all_new_wanted = listToBag new_wanted `andCts` + listToBag unsolved_wanted `andCts` + listToBag insols + + ; mapM_ setEv solved_wanted + + ; traceTcS "Finished plugins }" (ppr new_wanted) + ; return ( notNull (pluginNewCts p), all_new_wanted ) } } + where + setEv :: (EvTerm,Ct) -> TcS () + setEv (ev,ct) = case ctEvidence ct of + CtWanted (WantedCt { ctev_dest = dest }) -> setWantedEvTerm dest EvCanonical ev + -- TODO: plugins should be able to signal non-canonicity + _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!" + +-- | A pair of (given, wanted) constraints to pass to plugins +type SplitCts = ([Ct], [Ct]) + +-- | A solved pair of constraints, with evidence for wanteds +type SolvedCts = ([Ct], [(EvTerm,Ct)]) + +-- | Represents collections of constraints generated by typechecker +-- plugins +data TcPluginProgress = TcPluginProgress + { pluginInputCts :: SplitCts + -- ^ Original inputs to the plugins with solved/bad constraints + -- removed, but otherwise unmodified + , pluginSolvedCts :: SolvedCts + -- ^ Constraints solved by plugins + , pluginBadCts :: [Ct] + -- ^ Constraints reported as insoluble by plugins + , pluginNewCts :: [Ct] + -- ^ New constraints emitted by plugins + } + +getTcPluginSolvers :: TcS [TcPluginSolver] +getTcPluginSolvers + = do { tcg_env <- TcS.getGblEnv; return (tcg_tc_plugin_solvers tcg_env) } + +-- | Starting from a pair of (given, wanted) constraints, +-- invoke each of the typechecker constraint-solving plugins in turn and return +-- +-- * the remaining unmodified constraints, +-- * constraints that have been solved, +-- * constraints that are insoluble, and +-- * new work. +-- +-- Note that new work generated by one plugin will not be seen by +-- other plugins on this pass (but the main constraint solver will be +-- re-invoked and they will see it later). There is no check that new +-- work differs from the original constraints supplied to the plugin: +-- the plugin itself should perform this check if necessary. +runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress +runTcPluginSolvers solvers all_cts + = do { ev_binds_var <- getTcEvBindsVar + ; foldM (do_plugin ev_binds_var) initialProgress solvers } + where + do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin ev_binds_var p solver = do + result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p)) + return $ progress p result + + progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress + progress p + (TcPluginSolveResult + { tcPluginInsolubleCts = bad_cts + , tcPluginSolvedCts = solved_cts + , tcPluginNewCts = new_cts + } + ) = + p { pluginInputCts = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p) + , pluginSolvedCts = add solved_cts (pluginSolvedCts p) + , pluginNewCts = new_cts ++ pluginNewCts p + , pluginBadCts = bad_cts ++ pluginBadCts p + } + + initialProgress = TcPluginProgress all_cts ([], []) [] [] + + discard :: [Ct] -> SplitCts -> SplitCts + discard cts (xs, ys) = + (xs `without` cts, ys `without` cts) + + without :: [Ct] -> [Ct] -> [Ct] + without = deleteFirstsBy eq_ct + + eq_ct :: Ct -> Ct -> Bool + eq_ct c c' = ctFlavour c == ctFlavour c' + && ctPred c `tcEqType` ctPred c' + + add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts + add xs scs = foldl' addOne scs xs + + addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts + addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of + CtGiven {} -> (ct:givens, wanteds) + CtWanted {} -> (givens, (ev,ct):wanteds) diff --git a/GHC/Tc/Solver/Solve.hs-boot b/GHC/Tc/Solver/Solve.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Solve.hs-boot @@ -0,0 +1,8 @@ +module GHC.Tc.Solver.Solve where + +import Prelude( Bool ) +import GHC.Tc.Solver.Monad( TcS ) +import GHC.Tc.Types.Constraint( Cts, Implication, WantedConstraints ) + +solveSimpleWanteds :: Cts -> TcS WantedConstraints +trySolveImplication :: Implication -> TcS Bool diff --git a/GHC/Tc/Solver/Types.hs b/GHC/Tc/Solver/Types.hs --- a/GHC/Tc/Solver/Types.hs +++ b/GHC/Tc/Solver/Types.hs @@ -14,6 +14,7 @@ TcAppMap, emptyTcAppMap, isEmptyTcAppMap, insertTcApp, alterTcApp, filterTcAppMap, + mapMaybeTcAppMap, tcAppMapToBag, foldTcAppMap, delTcApp, EqualCtList, filterEqualCtList, addToEqualCtList @@ -23,7 +24,6 @@ import GHC.Prelude import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Types.Unique @@ -31,7 +31,6 @@ import GHC.Core.Class import GHC.Core.Map.Type -import GHC.Core.Predicate import GHC.Core.TyCon import GHC.Core.TyCon.Env @@ -41,7 +40,6 @@ import GHC.Utils.Constants import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain {- ********************************************************************* * * @@ -114,6 +112,16 @@ where filtered_tm = filterTM f tm +mapMaybeTcAppMap :: forall a b. (a -> Maybe b) -> TcAppMap a -> TcAppMap b +mapMaybeTcAppMap f m = mapMaybeDTyConEnv one_tycon m + where + one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap b) + one_tycon tm + | isEmptyTM mapped_tm = Nothing + | otherwise = Just mapped_tm + where + mapped_tm = mapMaybeTM f tm + tcAppMapToBag :: TcAppMap a -> Bag a tcAppMapToBag m = foldTcAppMap consBag m emptyBag @@ -131,13 +139,8 @@ emptyDictMap :: DictMap a emptyDictMap = emptyTcAppMap -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a -findDict m loc cls tys - | Just {} <- isCallStackPred cls tys - , isPushCallStackOrigin (ctLocOrigin loc) - = Nothing -- See Note [Solving CallStack constraints] - - | otherwise +findDict :: DictMap a -> Class -> [Type] -> Maybe a +findDict m cls tys = findTcApp m (classTyCon cls) tys findDictsByClass :: DictMap a -> Class -> Bag a @@ -153,33 +156,6 @@ foldDicts :: (a -> b -> b) -> DictMap a -> b -> b foldDicts = foldTcAppMap - -{- Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence. - -Suppose f :: HasCallStack => blah. Then - -* Each call to 'f' gives rise to - [W] s1 :: IP "callStack" CallStack -- CtOrigin = OccurrenceOf f - with a CtOrigin that says "OccurrenceOf f". - Remember that HasCallStack is just shorthand for - IP "callStack" CallStack - See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -* We cannonicalise such constraints, in GHC.Tc.Solver.Dict.canDictNC, by - pushing the call-site info on the stack, and changing the CtOrigin - to record that has been done. - Bind: s1 = pushCallStack s2 - [W] s2 :: IP "callStack" CallStack -- CtOrigin = IPOccOrigin - -* Then, and only then, we can solve the constraint from an enclosing - Given. - -So we must be careful /not/ to solve 's1' from the Givens. Again, -we ensure this by arranging that findDict always misses when looking -up such constraints. --} {- ********************************************************************* * * diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs --- a/GHC/Tc/TyCl.hs +++ b/GHC/Tc/TyCl.hs @@ -10,8 +10,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Typecheck type and class declarations module GHC.Tc.TyCl ( tcTyAndClassDecls, @@ -21,9 +19,12 @@ kcConDecls, tcConDecls, DataDeclInfo(..), dataDeclChecks, checkValidTyCon, tcFamTyPats, tcTyFamInstEqn, - tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, + tcAddOpenTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, unravelFamInstPats, addConsistencyConstraints, - checkFamTelescope + checkFamTelescope, + + -- Used by GHC.HsToCore.Quote + IsPrefixConGADT(..), unannotatedMultIsLinear ) where import GHC.Prelude @@ -55,10 +56,11 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family -import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) ) import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.Origin -import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) +import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon, manyDataConTy ) import GHC.Rename.Env( lookupConstructorFields ) @@ -74,7 +76,6 @@ import GHC.Core.DataCon import GHC.Core.Unify -import GHC.Types.Error import GHC.Types.Id import GHC.Types.Id.Make import GHC.Types.Var @@ -88,18 +89,19 @@ import GHC.Types.TypeEnv import GHC.Types.Unique import GHC.Types.Basic +import GHC.Types.Error import qualified GHC.LanguageExtensions as LangExt import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList, equivClasses ) +import GHC.Data.OrdList import GHC.Unit import GHC.Unit.Module.ModDetails import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc @@ -113,6 +115,7 @@ import qualified Data.List.NonEmpty as NE import Data.Traversable ( for ) import Data.Tuple( swap ) +import qualified Data.Semigroup as S {- ************************************************************************ @@ -148,44 +151,379 @@ *all* the tycons in a group for validity before checking *any* of the roles. Thus, we take two passes over the resulting tycons, first checking for general validity and then checking for valid role annotations. + +Note [Retrying TyClGroups] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +After renaming type, class, and instance declarations in a module (or, to be +more precise, in an HsGroup), GHC.Rename.Module.rnTyClDecls does dependency +analysis on the renamed declarations and returns a topologically sorted list +of SCCs, each SCC represented by one TyClGroup. + +If the dependency analysis were complete, i.e. if it were able to discover all +dependencies between all declarations, then tcTyAndClassDecls could simply +kind-check TyClGroups in order. Unfortunately, this is not the case, because +dependencies come in two varieties: + +* Lexical dependencies arise when X mentions Y by name: + + data X (a :: Y) = MkX -- depends on Y + data Y = MkY + +* Non-lexical dependencies arise when an instance must be in the + typing environment: + + type family F x + data X (a :: F Int) = MkX a -- depends on (F Int ~ Type) + type instance F x = Type + +Non-lexical dependencies can't be discovered by looking at the free variables of +a declaration (attempts to find a good heuristic did not bear fruit, see the +long discussion at #12088 and the linked Wiki pages). As a consequence, the +order of SCCs (i.e. TyClGroups) coming out of the renamer is determined solely +by lexical dependencies. + +In other words, the TyClGroups are in /lexical dependency order/, meaning: +- definitely in dependency order if all dependencies are lexical +- possibly not in dependency order if there are non-lexical dependencies + +Here are some examples how type checking declarations might go wrong due to +non-lexical dependencies: + +* Consider (#11348) + + type family F a + type instance F Int = Bool + + data R = MkR (F Int) + + type Foo = 'MkR 'True + + For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't + know that unless we've looked at the type instance declaration for F + before kind-checking Foo. + +* Things become more complicated when we introduce transitive + dependencies through imported definitions, like in this scenario: + + A.hs + type family Closed (t :: Type) :: Type where + Closed t = Open t + + type family Open (t :: Type) :: Type + + B.hs + data Q where + Q :: Closed Bool -> Q + + type instance Open Int = Bool + + type S = 'Q 'True + + Somehow, we must ensure that the instance Open Int = Bool is checked before + the type synonym S. While we know that S depends upon 'Q depends upon Closed, + we have no idea that Closed depends upon Open! + +* Another example is this (#3990). + + data family Complex a + data instance Complex Double = CD {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + + data T = T {-# UNPACK #-} !(Complex Double) + + Here, to generate the right kind of unpacked implementation for T, + we must have access to the 'data instance' declaration. + +To accommodate for these situations, tcTyAndClassDecls discovers the correct +kind-checking order by trial and error. + +The algorithm works as follows: + +1. (in rnTyClDecls) + Perform the SCC analysis on declarations without instances and considering + lexical dependencies only. The result is a topologically sorted list of SCCs. + See Note [Dependency analysis of type and class decls] in GHC.Rename.Module + +2. (in rnTyClDecls) + Create one singleton "SCC" per instance and put them at the end. + See Note [Put instances at the end] in GHC.Rename.Module + +3. (in tcTyAndClassDecls) + Check all SCCs in order, skipping any that are blocked (FVs not in env), + flawed (unusable unpack pragmas), or fail (type errors) + (3a) if none were skipped, we are done + (3b) if all were skipped and none are flawed, we are stuck; + report errors and exit (tcFailedTyClGroups) + (3c) if all were skipped and some are flawed, redo the pass + allowing flawed SCCs (tcTyClGroupsPass.go with strict=False) + (3d) if some were skipped and some weren't, we've made progress; iterate + +In the common case of lexical dependencies only, the algorithm is linear in the +number of groups: it completes in one pass if the program is kind-correct, or +two passes if there are kind errors. + +In the less common case of non-lexical dependencies, the algorithm is worst-case +quadratic in the number of groups: if each pass manages to check only one group, +we end up doing a pass per group. + +Now, regarding the "flawed" groups. These are the ones where the programmer used +the {-# UNPACK #-} pragma on a field, yet we could not unpack (#3990) + +* One possible reason for this is that we lack a data instance in the + environment that would allow for the field to be unpacked, so it is beneficial + to treat this like a kind error: skip the flawed group and retry it in a later + pass, when we might have more data instances in the env. + +* However, if the /only/ reason a pass gets stuck is due to flawed groups, + then we can make progress by treating unpacking failure is a warning. + +This way we maximize unpacking with explicit {-# UNPACK #-} pragmas. +Unfortunately, it does not help with -funbox-strict-fields. +See Note [Flaky -funbox-strict-fields with type/data families] + +Later we might check TyClGroups for other "flaws", but for now the property is +just about unusable unpack pragmas. + +Finally, a short comment on why it is necessary to check whether a group is +ready (FVs in the env) or blocked (FVs not in the env) using isReadyTyClGroup. +One might expect this check to be redundant, as the TyClGroups come in lexical +dependency order. However, as soon as we skip a group, the rest of the pass can +no longer rely on this property, hence the check. It is rare to encounter this +problem in a kind-correct program, but see e.g. the T12088e test case. + +Note [Flaky -funbox-strict-fields with type/data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program: + + {-# OPTIONS -funbox-strict-fields #-} + data family Complex a + data instance Complex Double = CD !Double !Double + data T = T !(Complex Double) -- does (Complex Double) get unpacked? + +Could we unpack T's field (Complex Double)? This depends on whether we have the +data instance in the environment. Prior GHC versions could handle this example, +but it was not reliable. A slightly more involved arrangement could throw it off +balance: + + {-# OPTIONS -funbox-strict-fields #-} + type family F a + data D1 = MkD1 !(F Int) -- does (F Int) get unpacked? + data D2 = MkD2 !Int !Int + type instance F Int = D2 + +Here, MkD1's field (F Int) would not get unpacked unless we used a top-level +splice to separate the module and force the desired order of kind-checking: + + {-# OPTIONS -funbox-strict-fields #-} + type family F a + data D2 = MkD2 !Int !Int + type instance F Int = D2 + $(return []) -- break the module into two sections + data D1 = MkD1 !(F Int) -- now (F Int) surely gets unpacked + +The current version of GHC is more predictable. Neither the (Complex Double) nor +the (F Int) example gets unpacking unless the type/data instance is put into a +separate HsGroup, either with $(return []) or by placing it in another module +altogether. This is a direct result of placing instances after the other SCCs, +as described in Note [Put instances at the end] in GHC.Rename.Module + +It is also possible to get the desired unpacking with an explicit {-# UNPACK #-} +pragma, as an unusable unpack pragma marks a TyClGroup "flawed", which means it +will be retried after more type/data instances are added to the typing +environment. See the algorithm in Note [Retrying TyClGroups]. -} -tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in - -- dependency order - -> TcM ( TcGblEnv -- Input env extended by types and - -- classes - -- and their implicit Ids,DataCons - , [InstInfo GhcRn] -- Source-code instance decls info - , [DerivInfo] -- Deriving info - , ThBindEnv -- TH binding levels - ) +data TcTyClGroupsAccum = + TcTyClGroupsAccum + { ttcga_inst_info :: !(OrdList (InstInfo GhcRn)) -- ^ Source-code instance decls info + , ttcga_deriv_info :: !(OrdList DerivInfo) -- ^ Deriving info + , ttcga_th_bndrs :: !ThBindEnv -- ^ TH binding levels + } + +instance S.Semigroup TcTyClGroupsAccum where + (TcTyClGroupsAccum a1 b1 c1) <> (TcTyClGroupsAccum a2 b2 c2) = + TcTyClGroupsAccum (a1 S.<> a2) + (b1 S.<> b2) + (c1 S.<> c2) + +instance Monoid TcTyClGroupsAccum where + mempty = TcTyClGroupsAccum mempty mempty mempty + +tcTyAndClassDecls :: [TyClGroup GhcRn] -- Mutually-recursive groups in lexical dependency order + -> TcM ( TcGblEnv -- Input env extended by types and classes and their implicit Ids, DataCons + , [InstInfo GhcRn] -- Source-code instance decls info + , [DerivInfo] -- Deriving info + , ThBindEnv -- TH binding levels + ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade -- Type check each group in dependency order folding the global env - = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s + = checkNoErrs $ go mempty tyclds_s where - fold_env :: [InstInfo GhcRn] - -> [DerivInfo] - -> ThBindEnv - -> [TyClGroup GhcRn] - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) - fold_env inst_info deriv_info th_bndrs [] - = do { gbl_env <- getGblEnv - ; return (gbl_env, inst_info, deriv_info, th_bndrs) } - fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s) - = do { (tcg_env, inst_info', deriv_info', th_bndrs') - <- tcTyClGroup tyclds - ; setGblEnv tcg_env $ - -- remaining groups are typechecked in the extended global env. - fold_env (inst_info' ++ inst_info) - (deriv_info' ++ deriv_info) - (th_bndrs' `plusNameEnv` th_bndrs) - tyclds_s } + go :: TcTyClGroupsAccum + -> [TyClGroup GhcRn] + -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) + go acc [] = do -- Case (3a) of the algorithm in Note [Retrying TyClGroups] + -- All good, we are done. + tcg_env <- getGblEnv + let inst_info = fromOL (ttcga_inst_info acc) + deriv_info = fromOL (ttcga_deriv_info acc) + th_bndrs = ttcga_th_bndrs acc + return (tcg_env, inst_info, deriv_info, th_bndrs) + go acc gs = + tcTyClGroupsPass gs $ \acc' n gs' -> + if n == 0 then + -- Case (3b) of the algorithm in Note [Retrying TyClGroups] + -- The pass made no progress. We are stuck. Report errors and exit. + tcFailedTyClGroups gs' + else + -- Case (3b) of the algorithm in Note [Retrying TyClGroups] + -- The pass made some progress. Iterate. + go (acc' S.<> acc) gs' +-- Check the remaining TyClGroups that are known to fail, +-- extending the environment with fake tycons to report more errors. +-- See Note [Recover from validity error] +tcFailedTyClGroups :: [TyClGroup GhcRn] -> TcM a +tcFailedTyClGroups [] = failM +tcFailedTyClGroups (g:gs) = do + tcg_env <- getGblEnv + m_result <- + if isReadyTyClGroup tcg_env g + then attemptM (tcTyClGroup g) + else return Nothing + let tcg_env' = maybe tcg_env fst m_result + setGblEnv tcg_env' $ tcFailedTyClGroups gs + +-- Type check as many TyClGroups as possible, skipping any failures. +-- thing_inside runs in the extended environment. +tcTyClGroupsPass :: forall a. + [TyClGroup GhcRn] -- Mutually-recursive groups in lexical dependency order + -> (TcTyClGroupsAccum + -> Int -- Number of successfully checked groups + -> [TyClGroup GhcRn] -- Remaining groups in lexical dependency order + -> TcM a) + -> TcM a +tcTyClGroupsPass all_gs thing_inside = go True ttcgs_zero mempty nilOL all_gs + where + go :: Bool -- Strict pass, True <=> fail on unusable {-# UNPACK #-} + -> TcTyClGroupsStats + -> TcTyClGroupsAccum + -> OrdList (TyClGroup GhcRn) -- Skipped groups (accumulator) + -> [TyClGroup GhcRn] -- Groups to check + -> TcM a + go strict !stats acc skipped_gs [] + | strict, ttcgs_n_success stats == 0, ttcgs_n_flawed stats > 0 = do + -- Case (3b) of the algorithm in Note [Retrying TyClGroups] + -- The strict pass made no progress but found flawed groups; + -- now do a lax pass to allow them to succeed. + traceTc "tcTyClGroupsPass end of strict pass" (ppr stats) + go False ttcgs_zero acc nilOL (fromOL skipped_gs) + | otherwise = do + traceTc "tcTyClGroupsPass done" (ppr stats) + thing_inside acc (ttcgs_n_success stats) (fromOL skipped_gs) + go strict !stats acc skipped_gs (g:gs) = do + (stats', m_result) <- try_tc_group strict stats (null skipped_gs) g + case m_result of + Nothing -> + go strict stats' acc (skipped_gs `snocOL` g) gs + Just (tcg_env, acc') -> + setGblEnv tcg_env $ + go strict stats' (acc' S.<> acc) skipped_gs gs + + try_tc_group :: Bool -- Strict pass, True <=> fail on unusable {-# UNPACK #-} + -> TcTyClGroupsStats + -> Bool -- True <=> No groups skipped this pass (yet) + -> TyClGroup GhcRn + -> TcM (TcTyClGroupsStats, Maybe (TcGblEnv, TcTyClGroupsAccum)) + try_tc_group strict stats no_skipped g = do + tcg_env <- getGblEnv + let on_flawed = (ttcgs_inc_flawed stats, Nothing) + on_failed = (ttcgs_inc_failed stats, Nothing) + on_blocked = (ttcgs_inc_blocked stats, Nothing) + on_success r = (ttcgs_inc_success stats, Just r) + ready = no_skipped || isReadyTyClGroup tcg_env g + -- (no_skipped ||) is a shortcut: if no groups were skipped this + -- pass, the current group's lexical dependencies must have been + -- satisfied by the preceding groups; no need for the ready check, + -- this avoids some lookups in tcg_env + + -- See Note [Expedient use of diagnostics in tcTyClGroupsPass] + set_opts action + | strict = setWOptM Opt_WarnUnusableUnpackPragmas action + | otherwise = action + validate _ msgs _ + | strict = not (unpackErrorsFound msgs) + | otherwise = True + + if not ready then return on_blocked else + tryTcDiscardingErrs' validate + (return on_flawed) + (return on_failed) + (on_success <$> set_opts (tcTyClGroup g)) + +data TcTyClGroupsStats = + TcTyClGroupsStats + { ttcgs_n_success :: !Int -- ^ Number of successfully checked groups + , ttcgs_n_blocked :: !Int -- ^ Number of groups whose FVs are not in the env + , ttcgs_n_failed :: !Int -- ^ Number of groups that failed with an error + , ttcgs_n_flawed :: !Int -- ^ Number of groups that did not pass validation + } + +ttcgs_zero :: TcTyClGroupsStats +ttcgs_zero = TcTyClGroupsStats 0 0 0 0 + +ttcgs_inc_success, ttcgs_inc_blocked, ttcgs_inc_failed, ttcgs_inc_flawed :: TcTyClGroupsStats -> TcTyClGroupsStats +ttcgs_inc_success stats = stats { ttcgs_n_success = 1 + ttcgs_n_success stats } +ttcgs_inc_blocked stats = stats { ttcgs_n_blocked = 1 + ttcgs_n_blocked stats } +ttcgs_inc_failed stats = stats { ttcgs_n_failed = 1 + ttcgs_n_failed stats } +ttcgs_inc_flawed stats = stats { ttcgs_n_flawed = 1 + ttcgs_n_flawed stats } + +instance Outputable TcTyClGroupsStats where + ppr stats = + vcat [ text "n_success =" <+> ppr (ttcgs_n_success stats) + , text "n_blocked =" <+> ppr (ttcgs_n_blocked stats) + , text "n_failed =" <+> ppr (ttcgs_n_failed stats) + , text "n_flawed =" <+> ppr (ttcgs_n_flawed stats) ] + +-- See Note [Expedient use of diagnostics in tcTyClGroupsPass] +unpackErrorsFound :: Messages TcRnMessage -> Bool +unpackErrorsFound = any is_unpack_error + where + is_unpack_error :: TcRnMessage -> Bool + is_unpack_error (TcRnMessageWithInfo _ (TcRnMessageDetailed _ msg)) = is_unpack_error msg + is_unpack_error (TcRnWithHsDocContext _ msg) = is_unpack_error msg + is_unpack_error (TcRnBadFieldAnnotation _ _ UnusableUnpackPragma) = True + is_unpack_error _ = False + +{- Note [Expedient use of diagnostics in tcTyClGroupsPass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In tcTyClGroupsPass.go with strict=True, we want to skip "flawed" groups, i.e. +groups with unusable unpack pragmas, as explained in Note [Retrying TyClGroups]. +To detect these unusable {-# UNPACK #-} pragmas, we currently piggy-back on the +diagnostics infrastructure: + + 1. (setWOptM Opt_WarnUnusableUnpackPragmas) to enable the warning. + The warning is on by default, but the user may have disabled it with + -Wno-unusable-unpack-pragmas, in which case we need to turn it back on. + + 2. (unpackErrorsFound msgs) to check if UnusableUnpackPragma is one of the + collected diagnostics. This is somewhat unpleasant because of the need to + recurse into TcRnMessageWithInfo and TcRnWithHsDocContext. + +Arguably, this is not a principled solution, because diagnostics are meant for +the user and here we inspect them to determine the order of type-checking. The +only reason for the current setup is that it was the easy thing to do. +-} + +isReadyTyClGroup :: TcGblEnv -> TyClGroup GhcRn -> Bool +isReadyTyClGroup tcg_env TyClGroup{group_ext = deps} = + nameSetAll (\n -> n `elemNameEnv` tcg_type_env tcg_env) deps + tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) + -> TcM (TcGblEnv, TcTyClGroupsAccum) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds @@ -219,8 +557,13 @@ -- as we might look them up in checkTyConConsistentWithBoot. -- See Note [TyCon boot consistency checking]. fmap concat . for tyclss_with_validity_infos $ \ (tycls, ax_validity_infos) -> - do { tcAddFamInstCtxt (text "type family") (tyConName tycls) $ - tcAddClosedTypeFamilyDeclCtxt tycls $ + do { let inst_flav = + TyConInstFlavour + { tyConInstFlavour = tyConFlavour tycls + , tyConInstIsDefault = False + } + ; tcAddFamInstCtxt inst_flav (tyConName tycls) $ + addErrCtxt (ClosedFamEqnCtxt tycls) $ mapM_ (checkTyFamEqnValidityInfo tycls) ax_validity_infos ; checkValidTyCl tycls } @@ -243,8 +586,10 @@ ; let deriv_info = datafam_deriv_info ++ data_deriv_info ; let gbl_env'' = gbl_env' { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless } - ; return (gbl_env'', inst_info, deriv_info, - th_bndrs' `plusNameEnv` th_bndrs) } + ; let acc = TcTyClGroupsAccum{ ttcga_inst_info = toOL inst_info + , ttcga_deriv_info = toOL deriv_info + , ttcga_th_bndrs = th_bndrs' `plusNameEnv` th_bndrs } + ; return (gbl_env'', acc) } -- Gives the kind for every TyCon that has a standalone kind signature type KindSigEnv = NameEnv Kind @@ -1136,7 +1481,7 @@ flav = tyConFlavour tc -- Eta expand - ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind + ; (eta_tcbs, tc_res_kind) <- maybeEtaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind -- Step 6: Make the result TcTyCon ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs @@ -1253,7 +1598,7 @@ Note that neither code path worries about point (4) above, as this is nicely handled by not mangling the res_kind. (Mangling res_kinds is done -*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.) +*after* all this stuff, in tcDataDefn's call to maybeEtaExpandAlgTyCon.) We can tell Inferred apart from Specified by looking at the scoped tyvars; Specified are always included there. @@ -1517,7 +1862,7 @@ ; traceTc "inferInitialKinds done }" empty ; return tcs } where - infer_initial_kind = addLocMA (getInitialKind InitialKindInfer) + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) -- Check type/class declarations against their standalone kind signatures or -- CUSKs, producing a generalized TcTyCon for each. @@ -1529,7 +1874,7 @@ ; return tcs } where check_initial_kind (ldecl, msig) = - addLocMA (getInitialKind (InitialKindCheck msig)) ldecl + addLocM (getInitialKind (InitialKindCheck msig)) ldecl -- | Get the initial kind of a TyClDecl, either generalized or non-generalized, -- depending on the 'InitialKindStrategy'. @@ -1557,7 +1902,7 @@ -- See Note [Don't process associated types in getInitialKind] ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ - mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats + mapM (addLocM (getAssocFamInitialKind cls_tc)) ats ; return (cls_tc : at_tcs) } where getAssocFamInitialKind cls = @@ -1619,8 +1964,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 @@ -1759,7 +2105,9 @@ -- - In this function, those TcTyVars are unified with other kind variables during -- kind inference (see GHC.Tc.TyCl Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]) -kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) tycon +kcTyClDecl (DataDecl { tcdLName = (L _ _name) + , tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) + tycon = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ -- NB: binding these tyvars isn't necessary for GADTs, but it does no -- harm. For GADTs, each data con brings its own tyvars into scope, @@ -1767,13 +2115,13 @@ -- (conceivably) shadowed. do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon)) ; _ <- tcHsContext ctxt - ; kcConDecls (dataDefnConsNewOrData cons) (tyConResKind tycon) cons + ; kcConDecls (tyConResKind tycon) cons } kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon = 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. @@ -1799,117 +2147,163 @@ -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. -kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () -kcConArgTys new_or_data res_kind arg_tys = do - { let exp_kind = getArgExpKind new_or_data res_kind - ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind - tcMult mult) +kcConArgTys :: ConArgKind -- Expected kind of the argument(s) + -> [HsConDeclField GhcRn] -- User-written argument types + -> TcM () +kcConArgTys exp_kind arg_tys + = forM_ arg_tys $ \(CDF { cdf_multiplicity, cdf_type }) -> + do { _ <- tcCheckLHsTypeInContext cdf_type exp_kind + ; maybe (pure ()) (void . tcMult) (multAnnToHsType cdf_multiplicity) } -- See Note [Implementation of UnliftedNewtypes], STEP 2 - } -- Kind-check the types of arguments to a Haskell98 data constructor. -kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM () -kcConH98Args new_or_data res_kind con_args = case con_args of - PrefixCon _ tys -> kcConArgTys new_or_data res_kind tys - InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2] - RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $ - map (hsLinear . cd_fld_type . unLoc) flds +kcConH98Args :: ConArgKind -- Expected kind of the argument(s) + -> HsConDeclH98Details GhcRn + -> TcM () +kcConH98Args exp_kind con_args = case con_args of + PrefixCon tys -> kcConArgTys exp_kind tys + InfixCon ty1 ty2 -> kcConArgTys exp_kind [ty1, ty2] + RecCon (L _ flds) -> kcConArgTys exp_kind $ + map (cdrf_spec . unLoc) flds -- Kind-check the types of arguments to a GADT data constructor. -kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM () -kcConGADTArgs new_or_data res_kind con_args = case con_args of - PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys - RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ - map (hsLinear . cd_fld_type . unLoc) flds +kcConGADTArgs :: ConArgKind -- Expected kind of the argument(s) + -> HsConDeclGADTDetails GhcRn + -> TcM () +kcConGADTArgs exp_kind con_args = case con_args of + PrefixConGADT _ tys -> kcConArgTys exp_kind tys + RecConGADT _ (L _ flds) -> kcConArgTys exp_kind $ + map (cdrf_spec . unLoc) flds -kcConDecls :: Foldable f - => NewOrData - -> TcKind -- The result kind signature - -- Used only in H98 case - -> f (LConDecl GhcRn) -- The data constructors - -> TcM () +kcConDecls :: TcKind -- Result kind of tycon + -- Used only in H98 case + -> DataDefnCons (LConDecl GhcRn) -> TcM () -- See Note [kcConDecls: kind-checking data type decls] -kcConDecls new_or_data tc_res_kind = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) +kcConDecls tc_res_kind cons + = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons + where + new_or_data = dataDefnConsNewOrData cons -- Kind check a data constructor. In additional to the data constructor, -- we also need to know about whether or not its corresponding type was -- declared with data or newtype, and we need to know the result kind of -- this type. See Note [Implementation of UnliftedNewtypes] for why -- we need the first two arguments. -kcConDecl :: NewOrData - -> TcKind -- Result kind of the type constructor - -- Usually Type but can be TYPE UnliftedRep - -- or even TYPE r, in the case of unlifted newtype - -- Used only in H98 case - -> ConDecl GhcRn - -> TcM () -kcConDecl new_or_data tc_res_kind (ConDeclH98 - { con_name = name, con_ex_tvs = ex_tvs - , con_mb_cxt = ex_ctxt, con_args = args }) - = addErrCtxt (dataConCtxt (NE.singleton name)) $ +kcConDecl :: NewOrData -> TcKind -> ConDecl GhcRn -> TcM () +kcConDecl new_or_data tc_res_kind + (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = ex_ctxt, con_args = args }) + = addErrCtxt (DataConDefCtxt (NE.singleton name)) $ discardResult $ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsContext ex_ctxt - ; kcConH98Args new_or_data tc_res_kind args + ; let arg_exp_kind = getArgExpKind new_or_data tc_res_kind + -- getArgExpKind: for newtypes, check that the argument kind + -- is the same as the tc_res_kind. See (KCD1) + -- in Note [kcConDecls: kind-checking data type decls] + ; kcConH98Args arg_exp_kind args -- We don't need to check the telescope here, -- because that's done in tcConDecl } -kcConDecl new_or_data - _tc_res_kind -- Not used in GADT case (and doesn't make sense) - (ConDeclGADT - { con_names = names, con_bndrs = L _ outer_bndrs, con_mb_cxt = cxt - , con_g_args = args, con_res_ty = res_ty }) +kcConDecl new_or_data _tc_res_kind + -- NB: _tc_res_kind is unused. See (KCD3) in + -- Note [kcConDecls: kind-checking data type decls] + (ConDeclGADT { con_names = names + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = cxt + , con_g_args = args + , con_res_ty = res_ty }) = -- See Note [kcConDecls: kind-checking data type decls] - addErrCtxt (dataConCtxt names) $ - discardResult $ + addErrCtxt (DataConDefCtxt names) $ -- Not sure this is right, should just extend rather than skolemise but no test - bindOuterSigTKBndrs_Tv outer_bndrs $ - -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] + bind_con_tvbs outer_bndrs inner_bndrs $ do { _ <- tcHsContext cxt ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty) ; con_res_kind <- newOpenTypeKind - ; _ <- tcCheckLHsType res_ty (TheKind con_res_kind) - ; kcConGADTArgs new_or_data con_res_kind args - ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind) + ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind) + + ; let arg_exp_kind = getArgExpKind new_or_data con_res_kind + -- getArgExpKind: for newtypes, check that the argument kind + -- is the same the kind of `res_ty`, the data con's return type + -- See (KCD2) in Note [kcConDecls: kind-checking data type decls] + ; kcConGADTArgs arg_exp_kind args + + ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr arg_exp_kind) ; return () } + where + bind_con_tvbs outer_bndrs inner_bndrs thing_inside + -- Why "_Tv"? See Note [Using TyVarTvs for kind-checking GADTs] + = discardResult $ bindOuterSigTKBndrs_Tv outer_bndrs $ + bindExplicitTKBndrs_Tv (concatMap hsForAllTelescopeBndrs inner_bndrs) $ + thing_inside {- Note [kcConDecls: kind-checking data type decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ kcConDecls is used when we are inferring the kind of the type -constructor in a data type declaration. E.g. - data T f a = MkT (f a) -we want to infer the kind of 'f' and 'a'. The basic plan is described -in Note [Inferring kinds for type declarations]; here we are doing Step 2. +constructor in a data type declaration. The basic plan is described in +Note [Inferring kinds for type declarations]; here we are doing Step 2. -In the GADT case we may have this: - data T f a where - MkT :: forall g b. g b -> T g b +We are kind-checking the data constructors /only/ to compute the kind of +the type construtor. For example + data T f a = MkT (f a) +The (f a) in the data construtor constrains the kinds of `f` and `a`, and hence +of `T`. -Notice that the variables f,a, and g,b are quite distinct. -Nevertheless, the type signature for MkT must still influence the kind -T which is (remember Step 1) something like - T :: kappa1 -> kappa2 -> Type -Otherwise we'd infer the bogus kind - T :: forall k1 k2. k1 -> k2 -> Type. +There are two cases to consider in `kcConDecl` -The type signature for MkT influences the kind of T simply by -kind-checking the result type (T g b), which will force 'f' and 'g' to -have the same kinds. This is the call to - tcCheckLHsType res_ty (TheKind con_res_kind) -Because this is the result type of an arrow, we know the kind must be -of form (TYPE rr), and we get better error messages if we enforce that -here (e.g. test gadt10). +* Haskell 98 data constructors, as above. We simply bring `f` and `a` + into scope and kind-check the data constructors. -For unlifted newtypes only, we must ensure that the argument kind -and result kind are the same: -* In the H98 case, we need the result kind of the TyCon, to unify with - the argument kind. +* GADT data type decls e.g. + data S f a where + MkS :: g b -> S g b + Here `f` and `a` don't scope over the data constructor signatures. + Instead, we just kind-check the entire signature (including the result `S g b`), + relying on the fact that `S` is in scope with its initial kind `k1 -> k2 -> Type`; + doing so will constrain `k1` and `k2` appropriately. -* In GADT syntax, this unification happens via the result kind passed - to kcConGADTArgs. The tycon's result kind is not used at all in the - GADT case. +The arguments of each data constructor are always of kind (TYPE r) for some +r :: RuntimeRep. But in the case of a newytype, the argument kind must be +the same as the tycon result kind. Since we are trying to figure out the +tycon kind, kcConDecls must account for this, which is surprisingly tricky. +Again there are two cases to consider in `kcConDecl`: +* Haskell 98 data type decls, e.g. + data T f a = MkT (f a) + * In the header, all the tycon binders are specified (here `f` and `a`) + and there is no result kind signature. + * The binders from the header scope over the data construtors. + * In the case of unlifted newtypes, the argument kind affects the tycon kind + newtype N = MkN Int# + Here `getInitialKind` will give `N` the result kind `TYPE r`, where `r` is + a unification variable, and `kcConDecls` should unify that `r` with + `IntRep` becuase of the `Int#` + + Solution (KCD1): just check that the argumet type has the same kind as the result + kind of the tycon. + +* GADT data type decls e.g. + data S f :: Type -> Type where + MkS :: g a -> S g a + * In the header, not all the tycon binders are specified (here just `f`), + and there can be a kind signature + * The kind signature may describe some, all, or none of the tycon binders. + Regardless, in the TcTyCon constructed by `getInitialKind`, the tyConResKind + is the signature, not the "ultimate" result type of the tycon (which is + usually Type) + * In the case of unlifted newtypes, we again want the argument kind to be the + same as the result kind of the tycon; but it's not so clear what /is/ the + result kind of the tycon, because of the signature stuff in the previous bullet. + + Solution (KCD2): kind-check the result type of the data constructor (here + `S g a`) and, for newtypes, ensure that the arugment has that same kind. + + (KCD3) The tycon's result kind `tc_res_kind` is not used at all in the GADT + case; rather it is accessed via looking up S's kind in the type environment + when kind-checking the result type of the data constructor. + Note [Using TyVarTvs for kind-checking GADTs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -2083,7 +2477,7 @@ data T a :: Type -> Type where ... we really mean for T to have two parameters. The second parameter - is produced by processing the return kind in etaExpandAlgTyCon, + is produced by processing the return kind in maybeEtaExpandAlgTyCon, called in tcDataDefn. See also Note [splitTyConKind] in GHC.Tc.Gen.HsType. @@ -2178,14 +2572,20 @@ Type. This assumption is in getInitialKind for CUSKs or get_fam_decl_initial_kind for non-signature & non-CUSK cases. - Instances: The data family already has a known kind. The return kind - of an instance is then calculated by applying the data family tycon - to the patterns provided, as computed by the typeKind lhs_ty in the - end of tcDataFamInstHeader. In the case of an instance written in GADT - syntax, there are potentially *two* return kinds: the one computed from - applying the data family tycon to the patterns, and the one given by - the user. This second kind is checked by the tc_kind_sig function within - tcDataFamInstHeader. See also DF3, below. + Instances: There are potentially *two* return kinds: + * Master kind: + The data family already has a known kind. The return kind of an instance + is then calculated by applying the data family tycon to the patterns + provided, as computed by the `tcFamTyPats fam_tc hs_pats` in the + tcDataFamInstHeader. + * Instance kind: + The kind specified by the user in GADT syntax. If H98 syntax is used, + with UnliftedNewtypes/UnliftedDatatypes, it defaults to newOpenTypeKind + for newtypes/datatypes, otherwise it defaults to liftedTypeKind. + This is checked or defaulted by the tc_kind_sig function within + tcDataFamInstHeader. Defaulting can be tricky for some cases, + See Note [Defaulting result kind of newtype/data family instance]. + See also DF3, below. DF1 In a data/newtype instance, we treat the kind of the /data family/, once instantiated, as the "master kind" for the representation @@ -2622,7 +3022,7 @@ -- The (binderVars tc_bndrs) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt - ; fds <- mapM (addLocMA tc_fundep) fundeps + ; fds <- mapM (addLocM tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } @@ -2653,9 +3053,9 @@ -- and concrete class with no methods (maybe by -- specifying a trailing where or not - ; mindef <- tcClassMinimalDef class_name sigs sig_stuff + ; mindef <- tcClassMinimalDef class_name sigs sig_stuff ; is_boot <- tcIsHsBootOrSig - ; let body | is_boot, isNothing hs_ctxt, null at_stuff, null sig_stuff + ; let abstract_class = is_boot && isNothing hs_ctxt && null at_stuff && null sig_stuff -- We use @isNothing hs_ctxt@ rather than @null ctxt@, -- so that a declaration in an hs-boot file such as: -- @@ -2664,11 +3064,19 @@ -- is not considered abstract; it's sometimes useful -- to be able to declare such empty classes in hs-boot files. -- See #20661. - = Nothing - | otherwise - = Just (ctxt, at_stuff, sig_stuff, mindef) - ; clas <- buildClass class_name bndrs roles fds body + unary_class = case ctxt ++ map sndOf3 sig_stuff of + [ty] -> isBoxedType ty + _ -> False + -- Use a unary class if the data constructor + -- has exactly one, boxed value field + -- i.e. exactly one operation or superclass taken together + -- See (UCM10) in Note [Unary class magic] in GHC.Core.TyCon + + ; clas <- if abstract_class + then buildAbstractClass class_name bndrs roles fds + else buildClass class_name bndrs roles fds ctxt + at_stuff sig_stuff mindef unary_class ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$ ppr fds) ; return clas } @@ -2725,7 +3133,7 @@ (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at + tc_at at = do { (fam_tc, val_infos) <- addLocM (tcFamDecl1 (Just cls)) at ; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] @@ -2752,8 +3160,15 @@ , feqn_pats = hs_pats , feqn_rhs = hs_rhs_ty }})] = -- See Note [Type-checking default assoc decls] + let + inst_flav = + TyConInstFlavour + { tyConInstFlavour = tyConFlavour fam_tc + , tyConInstIsDefault = True + } + in setSrcSpanA loc $ - tcAddFamInstCtxt (text "default type instance") tc_name $ + tcAddFamInstCtxt inst_flav tc_name $ do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) ; let fam_tc_name = tyConName fam_tc vis_arity = length (tyConVisibleTyVars fam_tc) @@ -3002,10 +3417,6 @@ -- overlap done by dropDominatedAxioms ; return (fam_tc, axiom_validity_infos) } } -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker -#endif - -- | Maybe return a list of Bools that say whether a type family was declared -- injective in the corresponding type arguments. Length of the list is equal to -- the number of arguments (including implicit kind/coercion arguments). @@ -3059,7 +3470,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) @@ -3079,7 +3490,7 @@ where skol_info = TyConSkol TypeSynonymFlavour tc_name -tcDataDefn :: SDoc -> RolesInfo -> Name +tcDataDefn :: ErrCtxtMsg -> RolesInfo -> Name -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn err_ctxt roles_info tc_name @@ -3202,7 +3613,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 @@ -3324,7 +3735,7 @@ no role. See also Note [Re-quantify type variables in rules] in -GHC.Tc.Gen.Rule, which explains a /very/ similar design when +GHC.Tc.Gen.Sig, which explains a /very/ similar design when generalising over the type of a rewrite rule. -} @@ -3333,7 +3744,7 @@ tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo -> HsOuterFamEqnTyVarBndrs GhcRn -- Implicit and explicit binders - -> HsTyPats GhcRn -- Patterns + -> HsFamEqnPats GhcRn -- Patterns -> LHsType GhcRn -- RHS -> TcM ([TyVar], TyVarSet, [TcType], TcType) -- (tyvars, non_user_tvs, pats, rhs) @@ -3354,7 +3765,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 @@ -3439,7 +3850,7 @@ -- The Nothing case cannot happen for type families, because -- we don't call unravelFamInstPats until we've solved the -- equalities. For data families, it shouldn't happen either, - -- we need to fail hard and early if it does. See trac issue #15905 + -- we need to fail hard and early if it does. See issue #15905 -- for an example of this happening. addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () @@ -3584,7 +3995,7 @@ -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon) tcConDecls dd_info rep_tycon tmpl_bndrs res_kind = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data -> - addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) + addLocM $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) -- mkTyConTagMap: it's important that we pay for tag allocation here, -- once per TyCon. See Note [Constructor tag allocation], fixes #14657 @@ -3610,7 +4021,7 @@ , con_ex_tvs = explicit_tkv_nms , con_mb_cxt = hs_ctxt , con_args = hs_args }) - = addErrCtxt (dataConCtxt (NE.singleton lname)) $ + = addErrCtxt (DataConDefCtxt (NE.singleton lname)) $ do { -- NB: the tyvars from the declaration header are in scope -- Get hold of the existential type variables @@ -3630,7 +4041,7 @@ do { ctxt <- tcHsContext hs_ctxt ; let exp_kind = getArgExpKind new_or_data res_kind ; btys <- tcConH98Args exp_kind hs_args - ; field_lbls <- lookupConstructorFields name + ; field_lbls <- lookupConstructorFields $ noUserRdr name ; let (arg_tys, stricts) = unzip btys ; return (ctxt, arg_tys, field_lbls, stricts) } @@ -3681,7 +4092,7 @@ -- For H98 datatypes, the user-written tyvar binders are precisely -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - user_tvbs = univ_tvbs ++ ex_tvbs + user_tvbs = tyVarSpecToBinders $ univ_tvbs ++ ex_tvbs user_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs ; traceTc "tcConDecl 2" (ppr name) @@ -3705,16 +4116,17 @@ -- NB: don't use res_kind here, as it's ill-scoped. Instead, -- we get the res_kind by typechecking the result type. (ConDeclGADT { con_names = names - , con_bndrs = L _ outer_hs_bndrs + , con_outer_bndrs = L _ outer_bndrs + , con_inner_bndrs = inner_bndrs , con_mb_cxt = cxt, con_g_args = hs_args , con_res_ty = hs_res_ty }) - = addErrCtxt (dataConCtxt names) $ + = addErrCtxt (DataConDefCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let L _ name :| _ = names ; skol_info <- mkSkolemInfo (DataConSkol name) - ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + ; (tclvl, wanted, (tvbs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ - tcOuterTKBndrs skol_info outer_hs_bndrs $ + tcGadtConTyVarBndrs skol_info outer_bndrs inner_bndrs $ do { ctxt <- tcHsContext cxt ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty -- See Note [GADT return kinds] @@ -3728,8 +4140,8 @@ do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs) ; let head_shape = substTy subst hdr_ty ; discardResult $ - popErrCtxt $ -- Drop dataConCtxt - addErrCtxt (dataConResCtxt names) $ + popErrCtxt $ -- Drop DataConDefCtxt + addErrCtxt (DataConResTyCtxt names) $ unifyType Nothing res_ty head_shape } -- See Note [Datatype return kinds] @@ -3737,22 +4149,19 @@ ; btys <- tcConGADTArgs exp_kind hs_args ; let (arg_tys, stricts) = unzip btys - ; field_lbls <- lookupConstructorFields name + ; field_lbls <- lookupConstructorFields $ noUserRdr name ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } - ; outer_bndrs <- scopedSortOuter outer_bndrs - ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs - ; tkvs <- kindGeneralizeAll skol_info - (mkInvisForAllTys outer_tv_bndrs $ - tcMkPhiTy ctxt $ - tcMkScaledFunTys arg_tys $ + (mkForAllTys tvbs $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ res_ty) ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs) ; reportUnsolvedEqualities skol_info tkvs tclvl wanted - ; let tvbndrs = mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs + ; let tvbndrs = mkTyVarBinders Inferred tkvs ++ tvbs -- Zonk to Types ; (tvbndrs, arg_tys, ctxt, res_ty) <- initZonkEnv NoFlexi $ @@ -3870,13 +4279,21 @@ tcInferLHsTypeKind doesn't any gratuitous top-level casts. -} + +type ConArgKind = ContextKind + -- The expected kind of the argument(s) of a constructor + -- For data types this is always OpenKind + -- For newtypes it is (TheKind ki) + -- where `ki` is the result kind of the newtype + -- With NoUnliftedNewtype, ki=Type, but with UnliftedNewtypes it can be a variable + -- | Produce an "expected kind" for the arguments of a data/newtype. -- If the declaration is indeed for a newtype, -- then this expected kind will be the kind provided. Otherwise, -- it is OpenKind for datatypes and liftedTypeKind. -- Why do we not check for -XUnliftedNewtypes? See point -- in Note [Implementation of UnliftedNewtypes] -getArgExpKind :: NewOrData -> TcKind -> ContextKind +getArgExpKind :: NewOrData -> TcKind -> ConArgKind getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _ = OpenKind @@ -3895,67 +4312,79 @@ tcConIsInfixGADT con details = case details of RecConGADT{} -> return False - PrefixConGADT arg_tys -- See Note [Infix GADT constructors] + PrefixConGADT _ arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) - , [_ty1,_ty2] <- map hsScaledThing arg_tys + , [_ty1,_ty2] <- arg_tys -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False -tcConH98Args :: ContextKind -- expected kind of arguments +tcConH98Args :: ConArgKind -- expected kind of arguments -- always OpenKind for datatypes, but unlifted newtypes -- might have a specific kind -> HsConDeclH98Details GhcRn -> TcM [(Scaled TcType, HsSrcBang)] -tcConH98Args exp_kind (PrefixCon _ btys) - = mapM (tcConArg exp_kind) btys +tcConH98Args exp_kind (PrefixCon btys) + = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys tcConH98Args exp_kind (InfixCon bty1 bty2) - = do { bty1' <- tcConArg exp_kind bty1 - ; bty2' <- tcConArg exp_kind bty2 + = do { bty1' <- tcConArg exp_kind IsNotPrefixConGADT bty1 + ; bty2' <- tcConArg exp_kind IsNotPrefixConGADT bty2 ; return [bty1', bty2'] } tcConH98Args exp_kind (RecCon fields) - = tcRecConDeclFields exp_kind fields + = tcRecHsConDeclRecFields exp_kind fields -tcConGADTArgs :: ContextKind -- expected kind of arguments +tcConGADTArgs :: ConArgKind -- expected kind of arguments -- always OpenKind for datatypes, but unlifted newtypes -- might have a specific kind -> HsConDeclGADTDetails GhcRn -> TcM [(Scaled TcType, HsSrcBang)] -tcConGADTArgs exp_kind (PrefixConGADT btys) - = mapM (tcConArg exp_kind) btys -tcConGADTArgs exp_kind (RecConGADT fields _) - = tcRecConDeclFields exp_kind fields +tcConGADTArgs exp_kind (PrefixConGADT _ btys) + = mapM (tcConArg exp_kind IsPrefixConGADT) btys +tcConGADTArgs exp_kind (RecConGADT _ fields) + = tcRecHsConDeclRecFields exp_kind fields -tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, +tcConArg :: ConArgKind -- expected kind for args; always OpenKind for datatypes, -- but might be an unlifted type with UnliftedNewtypes - -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang) -tcConArg exp_kind (HsScaled w bty) + -> IsPrefixConGADT + -> HsConDeclField GhcRn -> TcM (Scaled TcType, HsSrcBang) +tcConArg exp_kind isPrefixConGADT (CDF (_, src) unp str w bty _) = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind - ; w' <- tcDataConMult w + ; arg_ty <- tcCheckLHsTypeInContext bty exp_kind + ; w' <- tcDataConMult isPrefixConGADT w ; traceTc "tcConArg 2" (ppr bty) - ; return (Scaled w' arg_ty, getBangStrictness bty) } + ; return (Scaled w' arg_ty, HsSrcBang src unp str) } -tcRecConDeclFields :: ContextKind - -> LocatedL [LConDeclField GhcRn] +tcRecHsConDeclRecFields :: ConArgKind + -> LocatedL [LHsConDeclRecField GhcRn] -> TcM [(Scaled TcType, HsSrcBang)] -tcRecConDeclFields exp_kind fields - = mapM (tcConArg exp_kind) btys +tcRecHsConDeclRecFields exp_kind fields + = mapM (tcConArg exp_kind IsNotPrefixConGADT) btys where -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) + combined = map (\(L _ f) -> (cdrf_names f, cdrf_spec f)) (unLoc fields) explode (ns,ty) = zip ns (repeat ty) exploded = concatMap explode combined (_,btys) = unzip exploded -tcDataConMult :: HsArrow GhcRn -> TcM Mult -tcDataConMult arr@(HsUnrestrictedArrow _) = do - -- See Note [Function arrows in GADT constructors] - linearEnabled <- xoptM LangExt.LinearTypes - if linearEnabled then tcMult arr else return oneDataConTy -tcDataConMult arr = tcMult arr +data IsPrefixConGADT = IsPrefixConGADT | IsNotPrefixConGADT deriving (Eq) +-- See Note [Function arrows in GADT constructors] +unannotatedMultIsLinear :: IsPrefixConGADT -> TcRnIf gbl lcl Bool +unannotatedMultIsLinear isPrefixConGADT = do + if isPrefixConGADT == IsPrefixConGADT then do + linearEnabled <- xoptM LangExt.LinearTypes + return $ not linearEnabled + else + return True + +tcDataConMult :: IsPrefixConGADT -> HsMultAnn GhcRn -> TcM Mult +tcDataConMult isPrefixConGADT arr = case multAnnToHsType arr of + Nothing -> do + isLinear <- unannotatedMultIsLinear isPrefixConGADT + return $ if isLinear then oneDataConTy else manyDataConTy + Just ty -> tcMult ty + {- Note [Function arrows in GADT constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4019,11 +4448,11 @@ rejigConRes :: [KnotTied TyConBinder] -- Template for result type; e.g. -> KnotTied Type -- data instance T [a] b c ... -- gives template ([a,b,c], T [a] b c) - -> [InvisTVBinder] -- The constructor's type variables (both inferred and user-written) + -> [TyVarBinder] -- The constructor's type variables (both inferred and user-written) -> KnotTied Type -- res_ty -> ([TyVar], -- Universal [TyVar], -- Existential (distinct OccNames from univs) - [InvisTVBinder], -- The constructor's rejigged, user-written + [TyVarBinder], -- The constructor's rejigged, user-written -- type variables [EqSpec], -- Equality predicates Subst) -- Substitution to apply to argument types @@ -4236,7 +4665,7 @@ = choose [] [] empty_subst empty_subst tmpl_tvs where in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getSubstInScope subst + `unionInScope` substInScopeSet subst empty_subst = mkEmptySubst in_scope choose :: [TyVar] -- accumulator of univ tvs, reversed @@ -4511,7 +4940,7 @@ | Just fam_flav <- famTyConFlav_maybe tc -> case fam_flav of { ClosedSynFamilyTyCon (Just ax) - -> tcAddClosedTypeFamilyDeclCtxt tc $ + -> addErrCtxt (ClosedFamEqnCtxt tc) $ checkValidCoAxiom ax ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> @@ -4612,13 +5041,13 @@ ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) } where mb_subst1 = tcMatchTy res1 res2 - mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2 + mb_subst2 = tcMatchTyX (expectJust mb_subst1) fty1 fty2 ------------------------------- checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan con_loc $ - addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $ + addErrCtxt (DataConDefCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $ do { let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) arg_tys = dataConOrigArgTys con @@ -4694,13 +5123,13 @@ -- See Note [Type data declarations] in GHC.Rename.Module, -- restriction (R4). ; when (isTypeDataCon con) $ - checkTc (all isEqPred (dataConOtherTheta con)) + checkTc (all isEqClassPred (dataConOtherTheta con)) (TcRnConstraintInKind (dataConRepType con)) ; hsc_env <- getTopEnv ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM () check_bang orig_arg_ty bang rep_bang n - | HsSrcBang _ _ SrcLazy <- bang + | HsSrcBang _ _ SrcLazy <- bang , not (bang_opt_strict_data bang_opts) = addErrTc (bad_bang n LazyFieldsDisabled) @@ -4738,7 +5167,7 @@ -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addDiagnosticTc (bad_bang n BackpackUnpackAbstractType) + = addDiagnosticTc (bad_bang n UnusableUnpackPragma) | otherwise = return () @@ -4757,6 +5186,8 @@ ; 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)) @@ -4783,7 +5214,7 @@ checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype -- You might wonder if we need to check for an unlifted newtype --- without -XUnliftedNewTypes, such as +-- without -XUnliftedNewtypes, such as -- newtype C = MkC Int# -- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig checkNewDataCon con @@ -4874,7 +5305,7 @@ check_op constrained_class_methods (sel_id, dm) = setSrcSpan (getSrcSpan sel_id) $ - addErrCtxt (classOpCtxt sel_id op_ty) $ do + addErrCtxt (ClassOpCtxt sel_id op_ty) $ do { traceTc "class op type" (ppr op_ty) ; checkValidType ctxt op_ty -- This implements the ambiguity check, among other things @@ -4930,8 +5361,15 @@ , vi_non_user_tvs = non_user_tvs , vi_pats = pats , vi_rhs = orig_rhs } -> + let + inst_flav = + TyConInstFlavour + { tyConInstFlavour = tyConFlavour fam_tc + , tyConInstIsDefault = True + } + in setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ + tcAddFamInstCtxt inst_flav (getName fam_tc) $ do { checkValidAssocTyFamDeflt fam_tc pats ; checkFamPatBinders fam_tc qtvs non_user_tvs pats orig_rhs ; checkValidTyFamEqn fam_tc pats orig_rhs }} @@ -5003,9 +5441,10 @@ -- -- foo2 :: a -> Int -- default foo2 :: a -> b - unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] - [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - TcRnDefaultSigMismatch sel_id dm_ty + unless (isJust (tcMatchTy dm_phi_ty vanilla_phi_ty) && + isJust (tcMatchTy vanilla_phi_ty dm_phi_ty)) $ + addErrTc $ + TcRnDefaultSigMismatch sel_id dm_ty -- Now do an ambiguity check on the default type signature. checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) @@ -5262,7 +5701,7 @@ warnIf (not (isClassTyCon tc) && not (null vis_roles)) $ TcRnMissingRoleAnnotation name vis_roles Just (decl@(L loc (RoleAnnotDecl _ _ the_role_annots))) -> - addRoleAnnotCtxt name $ + addErrCtxt (RoleAnnotErrCtxt name) $ setSrcSpanA loc $ do { role_annots_ok <- xoptM LangExt.RoleAnnotations ; unless role_annots_ok $ addErrTc $ TcRnRoleAnnotationsDisabled tc @@ -5407,9 +5846,9 @@ ************************************************************************ -} -tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc -tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, - text "declaration for", quotes (ppr (tcdName decl))] +tcMkDeclCtxt :: TyClDecl GhcRn -> ErrCtxtMsg +tcMkDeclCtxt decl = + TyConDeclCtxt (tcdName decl) (tyClDeclFlavour decl) addVDQNote :: TcTyCon -> TcM a -> TcM a -- See Note [Inferring visible dependent quantification] @@ -5417,7 +5856,7 @@ addVDQNote tycon thing_inside | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind) has_vdq - = addLandmarkErrCtxt vdq_warning thing_inside + = addLandmarkErrCtxt (VDQWarningCtxt tycon) thing_inside | otherwise = thing_inside where @@ -5434,62 +5873,41 @@ is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && isVisibleTyConBinder tcb - vdq_warning = vcat - [ text "NB: Type" <+> quotes (ppr tycon) <+> - text "was inferred to use visible dependent quantification." - , text "Most types with visible dependent quantification are" - , text "polymorphically recursive and need a standalone kind" - , text "signature. Perhaps supply one, with StandaloneKindSignatures." - ] - tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a tcAddDeclCtxt decl thing_inside = addErrCtxt (tcMkDeclCtxt decl) thing_inside -tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a -tcAddTyFamInstCtxt decl - = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl) - -tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc -tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = eqn }) - = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance") - (unLoc (feqn_tycon eqn)) - -tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a -tcAddDataFamInstCtxt decl - = addErrCtxt (tcMkDataFamInstCtxt decl) - -tcMkFamInstCtxt :: SDoc -> Name -> SDoc -tcMkFamInstCtxt flavour tycon - = hsep [ text "In the" <+> flavour <+> text "declaration for" - , quotes (ppr tycon) ] - -tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a -tcAddFamInstCtxt flavour tycon thing_inside - = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside - -tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a -tcAddClosedTypeFamilyDeclCtxt tc - = addErrCtxt ctxt +tcAddOpenTyFamInstCtxt :: AssocInstInfo -> TyFamInstDecl GhcRn -> TcM a -> TcM a +tcAddOpenTyFamInstCtxt mb_assoc decl + = tcAddFamInstCtxt flav (tyFamInstDeclName decl) where - ctxt = text "In the equations for closed type family" <+> - quotes (ppr tc) - -dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc -dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons) - <+> ppr_cons (toList cons) + assoc = case mb_assoc of + NotAssociated -> Nothing + InClsInst { ai_class = cls } -> Just $ classTyCon cls + flav = TyConInstFlavour + { tyConInstFlavour = OpenFamilyFlavour IAmType assoc + , tyConInstIsDefault = False + } -dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc -dataConResCtxt cons = text "In the result type of data constructor" <> plural (toList cons) - <+> ppr_cons (toList cons) +tcMkDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> ErrCtxtMsg +tcMkDataFamInstCtxt mb_assoc new_or_data (DataFamInstDecl { dfid_eqn = eqn }) + = TyConInstCtxt (unLoc (feqn_tycon eqn)) + (TyConInstFlavour + { tyConInstFlavour = OpenFamilyFlavour (IAmData new_or_data) assoc + , tyConInstIsDefault = False + }) + where + assoc = case mb_assoc of + NotAssociated -> Nothing + InClsInst { ai_class = cls } -> Just $ classTyCon cls -ppr_cons :: [LocatedN Name] -> SDoc -ppr_cons [con] = quotes (ppr con) -ppr_cons cons = interpp'SP cons +tcAddDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> TcM a -> TcM a +tcAddDataFamInstCtxt assoc new_or_data decl + = addErrCtxt (tcMkDataFamInstCtxt assoc new_or_data decl) -classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [text "When checking the class method:", - nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] +tcAddFamInstCtxt :: TyConInstFlavour -> Name -> TcM a -> TcM a +tcAddFamInstCtxt flavour tycon thing_inside + = addErrCtxt (TyConInstCtxt tycon flavour) thing_inside illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () illegalRoleAnnotDecl (L loc role) @@ -5498,12 +5916,7 @@ addErrTc $ TcRnIllegalRoleAnnotation role addTyConCtxt :: TyCon -> TcM a -> TcM a -addTyConCtxt tc = addTyConFlavCtxt name flav +addTyConCtxt tc = addErrCtxt (TyConDeclCtxt name flav) where name = getName tc flav = tyConFlavour tc - -addRoleAnnotCtxt :: Name -> TcM a -> TcM a -addRoleAnnotCtxt name - = addErrCtxt $ - text "while checking a role annotation for" <+> quotes (ppr name) diff --git a/GHC/Tc/TyCl/Build.hs b/GHC/Tc/TyCl/Build.hs --- a/GHC/Tc/TyCl/Build.hs +++ b/GHC/Tc/TyCl/Build.hs @@ -9,7 +9,8 @@ module GHC.Tc.TyCl.Build ( buildDataCon, buildPatSyn, - TcMethInfo, MethInfo, buildClass, + TcMethInfo, MethInfo, + buildClass, buildAbstractClass, mkNewTyConRhs, newImplicitBinder, newTyConRepName ) where @@ -154,7 +155,7 @@ -> [FieldLabel] -- Field labels -> [TyVar] -- Universals -> [TyCoVar] -- Existentials - -> [InvisTVBinder] -- User-written 'TyVarBinder's + -> [TyVarBinder] -- User-written 'TyVarBinder's -> [EqSpec] -- Equality spec -> KnotTied ThetaType -- Does not include the "stupid theta" -- or the GADT equalities @@ -183,12 +184,15 @@ tag = lookupNameEnv_NF tag_map src_name -- See Note [Constructor tag allocation], fixes #14657 data_con = mkDataCon src_name declared_infix prom_info - src_bangs field_lbls - univ_tvs ex_tvs user_tvbs eq_spec ctxt + src_bangs impl_bangs str_marks field_lbls + univ_tvs ex_tvs + noConcreteTyVars + user_tvbs eq_spec ctxt arg_tys res_ty NoPromInfo rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con - dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) + (dc_rep, impl_bangs, str_marks) = + initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con) ; traceIf (text "buildDataCon 2" <+> ppr src_name) ; return data_con } @@ -288,26 +292,14 @@ -> [TyConBinder] -- Of the tycon -> [Role] -> [FunDep TyVar] -- Functional dependencies - -- Super classes, associated types, method info, minimal complete def. - -- This is Nothing if the class is abstract. - -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) + -> KnotTied ThetaType -- Superclasess + -> [ClassATItem] -- Associated types + -> [KnotTied MethInfo] -- Methods + -> ClassMinimalDef -- Minimal complete definition + -> Bool -- True <=> is a unary class -> TcRnIf m n Class -buildClass tycon_name binders roles fds Nothing - = fixM $ \ rec_clas -> -- Only name generation inside loop - do { traceIf (text "buildClass") - - ; tc_rep_name <- newTyConRepName tycon_name - ; let univ_tvs = binderVars binders - tycon = mkClassTyCon tycon_name binders roles - AbstractTyCon - rec_clas tc_rep_name - result = mkAbstractClass tycon_name univ_tvs fds tycon - ; traceIf (text "buildClass" <+> ppr tycon) - ; return result } - -buildClass tycon_name binders roles fds - (Just (sc_theta, at_items, sig_stuff, mindef)) +buildClass tycon_name binders roles fds sc_theta at_items sig_stuff mindef unary_class = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") @@ -330,22 +322,11 @@ -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let use_newtype = isSingleton (sc_theta ++ op_tys) - -- Use a newtype if the data constructor - -- (a) has exactly one value field - -- i.e. exactly one operation or superclass taken together - -- (b) that value is of lifted type (which they always are, because - -- we box equality superclasses) - -- See Note [Class newtypes and equality predicates] - -- - -- In the case of - -- class C a => D a - -- we use a newtype, but with one superclass and no arguments - args = sc_sel_names ++ op_names + ; let args = sc_sel_names ++ op_names op_tys = [ty | (_,ty,_) <- sig_stuff] op_names = [op | (op,_,_) <- sig_stuff] rec_tycon = classTyCon rec_clas - univ_bndrs = tyConInvisTVBinders binders + univ_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders binders univ_tvs = binderVars univ_bndrs bang_opts = FixedBangOpts (map (const HsLazy) args) @@ -367,17 +348,16 @@ rec_tycon (mkTyConTagMap rec_tycon) - ; rhs <- case () of - _ | use_newtype - -> mkNewTyConRhs tycon_name rec_tycon dict_con - | isCTupleTyConName tycon_name - -> return (TupleTyCon { data_con = dict_con - , tup_sort = ConstraintTuple }) - | otherwise - -> return (mkDataTyConRhs [dict_con]) + ; let rhs | unary_class + = UnaryClassTyCon dict_con + | isCTupleTyConName tycon_name + = TupleTyCon { data_con = dict_con + , tup_sort = ConstraintTuple } + | otherwise + = mkDataTyConRhs [dict_con] - ; let { tycon = mkClassTyCon tycon_name binders roles - rhs rec_clas tc_rep_name + tycon = mkClassTyCon tycon_name binders roles + rhs rec_clas tc_rep_name -- A class can be recursive, and in the case of newtypes -- this matters. For example -- class C a where { op :: C b => a -> b -> Int } @@ -387,10 +367,10 @@ -- newtype like a synonym, but that will lead to an infinite -- type] - ; result = mkClass tycon_name univ_tvs fds - sc_theta sc_sel_ids at_items - op_items mindef tycon - } + result = mkClass tycon_name univ_tvs fds + sc_theta sc_sel_ids at_items + op_items mindef tycon + ; traceIf (text "buildClass" <+> ppr tycon) ; return result } where @@ -412,23 +392,24 @@ = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc ; return (Just (dm_name, GenericDM dm_ty)) } -{- -Note [Class newtypes and equality predicates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - class (a ~ F b) => C a b where - op :: a -> b +buildAbstractClass :: Name + -> [TyConBinder] + -> [Role] + -> [FunDep TyVar] + -> TcRnIf m n Class -We cannot represent this by a newtype, even though it's not -existential, because there are two value fields (the equality -predicate and op. See #2238 +buildAbstractClass tycon_name binders roles fds + = fixM $ \ rec_clas -> -- Only name generation inside loop + do { traceIf (text "buildClass") -Moreover, - class (a ~ F b) => C a b where {} -Here we can't use a newtype either, even though there is only -one field, because equality predicates are unboxed, and classes -are boxed. --} + ; tc_rep_name <- newTyConRepName tycon_name + ; let univ_tvs = binderVars binders + tycon = mkClassTyCon tycon_name binders roles + AbstractTyCon + rec_clas tc_rep_name + result = mkAbstractClass tycon_name univ_tvs fds tycon + ; traceIf (text "buildClass" <+> ppr tycon) + ; return result } newImplicitBinder :: Name -- Base name -> (OccName -> OccName) -- Occurrence name modifier diff --git a/GHC/Tc/TyCl/Class.hs b/GHC/Tc/TyCl/Class.hs --- a/GHC/Tc/TyCl/Class.hs +++ b/GHC/Tc/TyCl/Class.hs @@ -53,7 +53,6 @@ import GHC.Driver.DynFlags -import GHC.Types.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env @@ -66,10 +65,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Maybe -import GHC.Data.Bag import GHC.Data.BooleanFormula import Control.Monad @@ -142,7 +139,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 @@ -158,7 +155,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] @@ -196,7 +193,7 @@ tcdMeths = default_binds})) = recoverM (return emptyLHsBinds) $ setSrcSpan (getLocA class_name) $ - do { clas <- tcLookupLocatedClass (n2l class_name) + do { clas <- tcLookupLocatedClass (la2la class_name) -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus @@ -223,7 +220,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) @@ -238,9 +235,9 @@ tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) = do { -- No default method - mapM_ (addLocMA (badDmPrag sel_id )) + 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)) @@ -282,7 +279,7 @@ local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) - lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name } + lm_bind = dm_bind { fun_id = L (l2l bind_loc) local_dm_name } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind @@ -296,9 +293,9 @@ ctxt = FunSigCtxt sel_name warn_redundant ; let local_dm_id = mkLocalId local_dm_name ManyTy local_dm_ty - local_dm_sig = CompleteSig { sig_bndr = local_dm_id - , sig_ctxt = ctxt - , sig_loc = getLocA hs_ty } + local_dm_sig = CSig { sig_bndr = local_dm_id + , sig_ctxt = ctxt + , sig_loc = getLocA hs_ty } ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars [this_dict] $ @@ -317,7 +314,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 @@ -346,7 +343,7 @@ where -- By default require all methods without a default implementation defMindef :: ClassMinimalDef - defMindef = mkAnd [ noLocA (mkVar name) + defMindef = mkAnd [ noLocA (mkVar (noLocA name)) | (name, _, Nothing) <- op_info ] instantiateMethod :: Class -> TcId -> [TcType] -> TcType @@ -390,7 +387,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 @@ -404,8 +401,8 @@ findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) - toMinimalDef _ = Nothing + toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just bf + toMinimalDef _ = Nothing {- Note [Polymorphic methods] @@ -466,23 +463,19 @@ badDmPrag sel_id prag = addErrTc (TcRnDefaultMethodForPragmaLacksBinding sel_id prag) -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + = InstDeclErrCtxt (Left $ getLHsInstDeclHead hs_inst_ty) -instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 :: Type -> ErrCtxtMsg instDeclCtxt2 dfun_ty = instDeclCtxt3 cls tys where (_,_,cls,tys) = tcSplitDFunTy dfun_ty -instDeclCtxt3 :: Class -> [Type] -> SDoc +instDeclCtxt3 :: Class -> [Type] -> ErrCtxtMsg instDeclCtxt3 cls cls_tys - = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) + = InstDeclErrCtxt (Right $ mkClassPred cls cls_tys) tcATDefault :: SrcSpan -> Subst diff --git a/GHC/Tc/TyCl/Instance.hs b/GHC/Tc/TyCl/Instance.hs --- a/GHC/Tc/TyCl/Instance.hs +++ b/GHC/Tc/TyCl/Instance.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -43,48 +44,53 @@ import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) -import GHC.Core.Multiplicity -import GHC.Core.InstEnv import GHC.Tc.Instance.Family -import GHC.Core.FamInstEnv + import GHC.Tc.Deriv import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType import GHC.Tc.Utils.Unify +import GHC.Tc.Types.Evidence + import GHC.Builtin.Names ( unsatisfiableIdName ) -import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) + +import GHC.Core ( Expr(..), mkVarApps ) import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID ) -import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) +import GHC.Core.Unfold.Make ( mkDFunUnfolding ) +import GHC.Core.FamInstEnv import GHC.Core.Type -import GHC.Core.SimpleOpt +import GHC.Core.Multiplicity +import GHC.Core.InstEnv import GHC.Core.Predicate( classMethodInstTy ) -import GHC.Tc.Types.Evidence import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.Class -import GHC.Types.Error + import GHC.Types.Var as Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Data.Bag import GHC.Types.Basic import GHC.Types.Fixity -import GHC.Driver.DynFlags -import GHC.Driver.Ppr -import GHC.Utils.Logger -import GHC.Data.FastString import GHC.Types.Id import GHC.Types.SourceFile import GHC.Types.SourceText -import GHC.Data.List.SetOps import GHC.Types.Name import GHC.Types.Name.Set +import GHC.Types.SrcLoc + +import GHC.Driver.DynFlags +import GHC.Driver.Ppr + +import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.SrcLoc import GHC.Utils.Misc + +import GHC.Data.FastString +import GHC.Data.List.SetOps +import GHC.Data.Bag import GHC.Data.BooleanFormula ( isUnsatisfied ) import qualified GHC.LanguageExtensions as LangExt @@ -184,6 +190,8 @@ Note [ClassOp/DFun selection] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This important Note explains how DFunIds and ClassOps work. + One thing we see a lot is stuff like op2 (df d1 d2) where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* @@ -218,6 +226,12 @@ let d = df d1 d2 in ...(op2 d)...(op1 d)... + * ClassOps have no unfolding; they work /only/ through their RULE. + But a ClassOp might be called with no arguments, or with an argument that + the rule doesn't fire on. So each ClassOp does get an executable top-level + definition, injected by GHC.Iface.Tidy.getClassImplicitBinds, which uses + `GHC.Types.Id.Make.mkDictSelRhs` to make the code. + Note [Single-method classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the class has just one method (or, more accurately, just one element @@ -352,10 +366,9 @@ Conclusion: when typechecking the methods in a C [a] instance, we want to treat the 'a' as an *existential* type variable, in the sense described -by Note [Binding when looking up instances]. That is why isOverlappableTyVar -responds True to an InstSkol, which is the kind of skolem we use in -tcInstDecl2. - +by Note [Super skolems: binding when looking up instances] in GHC.Core.InstEnv +That is why isOverlappableTyVar responds True to an InstSkol, which is the kind +of skolem we use in tcInstDecl2. Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -419,8 +432,8 @@ -> [LDerivDecl GhcRn] -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn) tcInstDeclsDeriv deriv_infos derivds - = do th_stage <- getStage -- See Note [Deriving inside TH brackets] - if isBrackStage th_stage + = do th_lvl <- getThLevel -- See Note [Deriving inside TH brackets] + if isBrackLevel th_lvl then do { gbl_env <- getGblEnv ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) } else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds @@ -486,7 +499,8 @@ tcClsInstDecl :: LClsInstDecl GhcRn -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo]) -- The returned DerivInfos are for any associated data families -tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds +tcClsInstDecl (L loc (ClsInstDecl { cid_ext = lwarn + , cid_poly_ty = hs_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) @@ -495,7 +509,8 @@ do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty -- NB: tcHsClsInstType does checkValidInstance - ; skol_info <- mkSkolemInfo (mkClsInstSkol clas inst_tys) + ; skol_info <- mkSkolemInfo (InstSkol IsClsInst pSizeZero) + -- pSizeZero: here the size part of InstSkol is irrelevant ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars ; let tv_skol_prs = [ (tyVarName tv, skol_tv) | (tv, skol_tv) <- tyvars `zip` skol_tvs ] @@ -506,7 +521,7 @@ fst $ splitForAllForAllTyBinders dfun_ty visible_skol_tvs = drop n_inferred skol_tvs - ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs) + ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleBndrCount dfun_ty) $$ ppr skol_tvs) -- Next, process any associated types. ; (datafam_stuff, tyfam_insts) @@ -541,8 +556,9 @@ ; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty) -- Dfun location is that of instance *header* + ; let warn = fmap unLoc lwarn ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name - tyvars theta clas inst_tys + tyvars theta clas inst_tys warn ; let inst_binds = InstBindings { ib_binds = binds @@ -561,7 +577,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 @@ -586,11 +602,11 @@ 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 $ - tcAddTyFamInstCtxt decl $ + = setSrcSpanA loc $ + tcAddOpenTyFamInstCtxt mb_clsinfo decl $ do { let fam_lname = feqn_tycon eqn ; fam_tc <- tcLookupLocatedTyCon fam_lname ; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc @@ -608,7 +624,7 @@ -- itself, so we make do with the location of family name ; (co_ax_branch, co_ax_validity_info) <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (na2la $ getLoc fam_lname) eqn) + (L (l2l $ getLoc fam_lname) eqn) -- (2) check for validity ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch @@ -698,11 +714,11 @@ , dd_cons = hs_cons , dd_kindSig = m_ksig , dd_derivs = derivs } }})) - = setSrcSpanA loc $ - tcAddDataFamInstCtxt decl $ + = setSrcSpanA loc $ + tcAddDataFamInstCtxt mb_clsinfo new_or_data decl $ do { fam_tc <- tcLookupLocatedTyCon lfam_name - ; tcFamInstDeclChecks mb_clsinfo IAmData fam_tc + ; tcFamInstDeclChecks mb_clsinfo (IAmData new_or_data) fam_tc -- Check that the family declaration is for the right kind ; checkTc (isDataFamilyTyCon fam_tc) $ @@ -712,10 +728,9 @@ -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in GHC.Core.FamInstEnv ; skol_info <- mkSkolemInfo FamInstSkol - ; let new_or_data = dataDefnConsNewOrData hs_cons ; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta) <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity - hs_ctxt hs_pats m_ksig new_or_data + hs_ctxt hs_pats m_ksig hs_cons -- Eta-reduce the axiom if possible -- Quite tricky: see Note [Implementing eta reduction for data families] @@ -740,8 +755,7 @@ -- we did it before the "extra" tvs from etaExpandAlgTyCon -- would always be eta-reduced -- - ; let flav = newOrDataToFlavour new_or_data - ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind + ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon skol_info full_tcbs tc_res_kind -- Check the result kind; it may come from a user-written signature. -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a) @@ -843,11 +857,15 @@ Just $ DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs , di_clauses = preds - , di_ctxt = tcMkDataFamInstCtxt decl } + , di_ctxt = tcMkDataFamInstCtxt mb_clsinfo new_or_data decl + } ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom ; return (fam_inst, m_deriv_info) } where + + new_or_data = dataDefnConsNewOrData hs_cons + eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder]) -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom -- Splits the incoming patterns into two: the [TyVar] @@ -915,8 +933,7 @@ tcDataFamInstHeader :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn -> LexicalFixity -> Maybe (LHsContext GhcRn) - -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) - -> NewOrData + -> HsFamEqnPats GhcRn -> Maybe (LHsKind GhcRn) -> DataDefnCons (LConDecl GhcRn) -> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType) -- All skolem TcTyVars, all zonked so it's clear what the free vars are -- The "header" of a data family instance is the part other than @@ -924,7 +941,7 @@ -- e.g. data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where" tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity - hs_ctxt hs_pats m_ksig new_or_data + hs_ctxt hs_pats m_ksig hs_cons = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats) ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))) <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $ @@ -940,16 +957,17 @@ -- with its parent class ; addConsistencyConstraints mb_clsinfo lhs_ty - -- Add constraints from the result signature - ; res_kind <- tc_kind_sig m_ksig - - -- Do not add constraints from the data constructors - -- See Note [Kind inference for data family instances] + -- Add constraints from the data constructors + -- Fix #25611 + -- See DESIGN CHOICE in Note [Kind inference for data family instances] + ; when is_H98_or_newtype $ kcConDecls lhs_applied_kind hs_cons -- Check that the result kind of the TyCon applied to its args -- is compatible with the explicit signature (or Type, if there -- is none) - ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats + ; let hs_lhs = nlHsTyConApp NotPromoted fixity (noUserRdr $ getName fam_tc) hs_pats + -- Add constraints from the result signature + ; res_kind <- tc_kind_sig m_ksig ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind ; traceTc "tcDataFamInstHeader" $ @@ -1001,9 +1019,16 @@ where fam_name = tyConName fam_tc data_ctxt = DataKindCtxt fam_name + new_or_data = dataDefnConsNewOrData hs_cons + is_H98_or_newtype = case hs_cons of + NewTypeCon{} -> True + DataTypeCons _ cons -> all isH98 cons + isH98 (L _ (ConDeclH98 {})) = True + isH98 _ = False -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, families (2), - -- and Note [Implementation of UnliftedDatatypes]. + -- Note [Implementation of UnliftedDatatypes] + -- and Note [Defaulting result kind of newtype/data family instance]. tc_kind_sig Nothing = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes ; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes @@ -1029,6 +1054,21 @@ Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcTopSkolemise Examples in indexed-types/should_compile/T12369 +Note [Defaulting result kind of newtype/data family instance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is tempting to let `tc_kind_sig` just return `newOpenTypeKind` +even without `-XUnliftedNewtypes`, but we rely on `tc_kind_sig` to +constrain the result kind of a newtype instance to `Type`. +Consider the following example: + + -- no UnliftedNewtypes + data family D :: k -> k + newtype instance D a = MkIntD a + +`tc_kind_sig` defaulting to `newOpenTypeKind` would result in `D a` +having kind `forall r. TYPE r` instead of `Type`, which would be +rejected validity checking. The same applies to Data Instances. + Note [Implementing eta reduction for data families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1183,32 +1223,49 @@ by the data instances -- and hence we /can/ specialise T's kind differently in different GADT data constructors. -SHORT SUMMARY: in a data instance decl, it's not clear whether kind +SHORT SUMMARY: In a data instance decl, it's not clear whether kind constraints arising from the data constructors should be considered local to the (GADT) data /constructor/ or should apply to the entire data instance. -DESIGN CHOICE: in data/newtype family instance declarations, we ignore -the /data constructor/ declarations altogether, looking only at the -data instance /header/. +DESIGN CHOICE: In a data/newtype family instance declaration: +* We take account of the data constructors (via `kcConDecls`) for: + * Haskell-98 style data instance declarations + * All newtype instance declarations + For Haskell-98 style declarations, there is no GADT refinement. And for + GADT-style newtype declarations, no GADT matching is allowed anyway, + so it's just a syntactic difference from Haskell-98. +* We /ignore/ the data constructors for: + * GADT-style data instance declarations + Here, the instance kinds are influenced only by the header. + +This choice is implemented by the guarded call to `kcConDecls` in +`tcDataFamInstHeader`. + Observations: -* This choice is simple to describe, as well as simple to implement. - For a data/newtype instance decl, the instance kinds are influenced - /only/ by the header. +* With `UnliftedNewtypes` or `UnliftedDatatypes`, looking at the data + constructors is necessary to infer the kind of the result type for + certain cases. Otherwise, additional kind signatures are required. + Consider the following example in #25611: -* We could treat Haskell-98 style data-instance decls differently, by - taking the data constructors into account, since there are no GADT - issues. But we don't, for simplicity, and because it means you can - understand the data type instance by looking only at the header. + data family Fix :: (k -> Type) -> k + newtype instance Fix f = In { out :: f (Fix f) } -* Newtypes can be declared in GADT syntax, but they can't do GADT-style - specialisation, so like Haskell-98 definitions we could take the - data constructors into account. Again we don't, for the same reason. + If we are not looking at the data constructors: + * Without `UnliftedNewtypes`, it is accepted since `Fix f` is defaulted + to `Type`. + * But with `UnliftedNewtypes`, `Fix f` is defaulted to `TYPE r` where + `r` is not scoped over the data constructor. Then the header `Fix f :: TYPE r` + will fail to kind unify with `f (Fix f) :: Type`. -So for now at least, we keep the simplest choice. See #18891 and !4419 -for more discussion of this issue. + Hence, we need to look at the data constructor to infer `Fix f :: Type` + for this newtype instance. +This DESIGN CHOICE strikes a balance between well-rounded kind inference +and implementation simplicity. See #25611, #18891, and !4419 for more +discussion of this issue. + Kind inference for data types (Xie et al) https://arxiv.org/abs/1911.06153 takes a slightly different approach. -} @@ -1231,7 +1288,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 @@ -1242,7 +1299,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1294,7 +1351,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 @@ -1330,19 +1387,14 @@ con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc - app_to_meth fun meth_id = HsApp noComments (L loc' fun) + app_to_meth fun meth_id = HsApp noExtField (L loc' fun) (L loc' (wrapId arg_wrapper meth_id)) inst_tv_tys = mkTyVarTys inst_tyvars arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys - is_newtype = isNewTyCon class_tc dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids - dfun_spec_prags - | is_newtype = SpecPrags [] - | otherwise = SpecPrags spec_inst_prags - -- Newtype dfuns just inline unconditionally, - -- so don't attempt to specialise them + dfun_spec_prags = SpecPrags spec_inst_prags export = ABE { abe_wrap = idHsWrapper , abe_poly = dfun_id_w_prags @@ -1354,11 +1406,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 @@ -1376,18 +1427,10 @@ -- the DFunId rather than from the skolem pieces that the typechecker -- is messing with. addDFunPrags dfun_id sc_meth_ids - | is_newtype - = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app - `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } - | otherwise = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args `setInlinePragma` dfunInlinePragma + -- NB: mkDFunUnfolding takes care of unary classes where - con_app = mkLams dfun_bndrs $ - mkApps (Var (dataConWrapId dict_con)) dict_args - -- This application will satisfy the Core invariants - -- from Note [Representation polymorphism invariants] in GHC.Core, - -- because typeclass method types are never unlifted. dict_args = map Type inst_tys ++ [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids] @@ -1396,10 +1439,9 @@ dfun_bndrs = dfun_tvs ++ ev_ids clas_tc = classTyCon clas dict_con = tyConSingleDataCon clas_tc - is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> Id -> HsExpr GhcTc -wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id)) +wrapId wrapper id = mkHsWrap wrapper (mkHsVar (noLocA id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1485,7 +1527,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) @@ -1496,7 +1538,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 @@ -1509,7 +1551,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) } @@ -1694,20 +1736,6 @@ superclass selection, except at a smaller type. This test is implemented by GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve -Note [Migrating away from loopy superclass solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The logic from Note [Solving superclass constraints] was implemented in GHC 9.6. -However, we want to provide a migration strategy for users, to avoid suddenly -breaking their code going when upgrading to GHC 9.6. To this effect, we temporarily -continue to allow the constraint solver to create these potentially non-terminating -solutions, but emit a loud warning when doing so: see -GHC.Tc.Solver.Dict.tryLastResortProhibitedSuperclass. - -Users can silence the warning by manually adding the necessary constraint to the -context. GHC will then keep this user-written Given, dropping the Given arising -from superclass expansion which has greater SC depth, as explained in -Note [Replacement vs keeping] in GHC.Tc.Solver.Dict. - Note [Silent superclass arguments] (historical interest only) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB1: this note describes our *old* solution to the @@ -1789,7 +1817,7 @@ -> TcM ([Id], LHsBinds GhcTc, Bag Implication) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcMethods skol_info dfun_id clas tyvars dfun_ev_vars inst_tys +tcMethods _skol_info dfun_id clas tyvars dfun_ev_vars inst_tys dfun_ev_binds (spec_inst_prags, prag_fn) op_items (InstBindings { ib_binds = binds , ib_tyvars = lexical_tvs @@ -1804,7 +1832,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 @@ -1825,7 +1853,7 @@ tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication) tc_item (sel_id, dm_info) | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn - = tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys + = tcMethodBody False clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags prags sel_id user_bind bndr_loc @@ -1859,9 +1887,10 @@ 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 - ; tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys + Just (dm_name, dm_spec) -> + do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name dm_spec + ; tcMethodBody (is_vanilla_dm dm_spec) + clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags inline_prags sel_id meth_bind inst_loc } @@ -1881,13 +1910,13 @@ where inst_loc' = noAnnSrcSpan inst_loc error_rhs dflags = L inst_loc' - $ HsApp noComments error_fun (error_msg dflags) + $ HsApp noExtField error_fun (error_msg dflags) error_fun = L inst_loc' $ wrapId (mkWpTyApps [ getRuntimeRep meth_tau, meth_tau]) nO_METHOD_BINDING_ERROR_ID error_msg dflags = L inst_loc' - (HsLit noComments (HsStringPrim NoSourceText + (HsLit noExtField (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags @@ -1902,7 +1931,7 @@ -- -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, -- point (D). - whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + whenIsJust (isUnsatisfied (methodExists . unLoc) (classMinimalDef clas)) $ warnUnsatisfiedMinimalDefinition methodExists meth = isJust (findMethodBind meth binds prag_fn) @@ -1917,6 +1946,12 @@ cls_meth_nms = map (idName . fst) op_items mismatched_meths = bind_nms `minusList` cls_meth_nms + is_vanilla_dm :: DefMethSpec ty -> Bool + -- See (TRC5) in Note [Tracking redundant constraints] + -- in GHC.Tc.Solver.Solve + is_vanilla_dm VanillaDM = True + is_vanilla_dm (GenericDM {}) = False + {- Note [Mismatched class methods and associated type families] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1986,25 +2021,28 @@ -} ------------------------ -tcMethodBody :: SkolemInfoAnon +tcMethodBody :: Bool -- True <=> This is a vanilla default method + -- See (TRC5) in Note [Tracking redundant constraints] + -- in GHC.Tc.Solver.Solve -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds -> Bool -> HsSigFun -> [LTcSpecPrag] -> [LSig GhcRn] -> Id -> LHsBind GhcRn -> SrcSpan -> TcM (TcId, LHsBind GhcTc, Maybe Implication) -tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys - dfun_ev_binds is_derived - sig_fn spec_inst_prags prags - sel_id (L bind_loc meth_bind) bndr_loc +tcMethodBody is_vanilla_dm clas tyvars dfun_ev_vars inst_tys + dfun_ev_binds is_derived + sig_fn spec_inst_prags prags + sel_id (L bind_loc meth_bind) bndr_loc = add_meth_ctxt $ do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc) + ; let skol_info = MethSkol meth_name is_vanilla_dm ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc) - (idName local_meth_id) } + (idName local_meth_id) } -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind @@ -2015,7 +2053,17 @@ tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) ; global_meth_id <- addInlinePrags global_meth_id prags - ; spec_prags <- tcSpecPrags global_meth_id prags + ; spec_prags <- tcExtendIdEnv1 meth_name global_meth_id $ + -- tcExtendIdEnv1: tricky point: a SPECIALISE pragma in prags + -- mentions sel_name but the pragma is really for global_meth_id. + -- So we bind sel_name to global_meth_id, just in the pragmas. + -- Example: + -- instance C [a] where + -- op :: forall b. Ord b => b -> a -> a + -- {-# SPECIALISE op @Int #-} + -- The specialisation is for the `op` for this instance decl, not + -- for the global selector-id, of course. + tcSpecPrags global_meth_id prags ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags export = ABE { abe_poly = global_meth_id @@ -2034,11 +2082,13 @@ ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) } where + meth_name = idName sel_id + -- For instance decls that come from deriving clauses -- we want to print out the full source code if there's an error -- because otherwise the user won't see the code at all add_meth_ctxt thing - | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing + | is_derived = addLandmarkErrCtxt (DerivBindCtxt sel_id clas inst_tys) thing | otherwise = thing tcMethodBodyHelp :: HsSigFun -> Id -> TcId @@ -2068,19 +2118,18 @@ -- WantRCC <=> check for redundant constraints in the -- user-specified instance signature inner_meth_id = mkLocalId inner_meth_name ManyTy sig_ty - inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id - , sig_ctxt = ctxt - , sig_loc = getLocA hs_sig_ty } - + inner_meth_sig = CSig { sig_bndr = inner_meth_id + , sig_ctxt = ctxt + , sig_loc = getLocA hs_sig_ty } - ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind + ; (tc_bind, [Scaled _ inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind ; let export = ABE { abe_poly = local_meth_id , abe_mono = inner_id , 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 = [] @@ -2128,15 +2177,11 @@ poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) methSigCtxt sel_name sig_ty meth_ty env0 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty - ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name)) - 2 (vcat [ text "is more general than its signature in the class" - , text "Instance sig:" <+> ppr sig_ty - , text " Class sig:" <+> ppr meth_ty ]) - ; return (env2, msg) } + ; return (env2, MethSigCtxt sel_name sig_ty meth_ty) } {- Note [Instance method signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2192,7 +2237,7 @@ -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: #-} -- These ones have the dfun inside, but [perhaps surprisingly] -- the correct wrapper. - -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind + -- See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Bind mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst) where @@ -2208,14 +2253,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 @@ -2226,36 +2272,65 @@ -- 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 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 noHsTok - (mkEmptyWildCardBndrs $ nlHsParTy $ noLocA $ XHsType ty)) + mk_vta fun ty = noLocA (HsAppType noExtField fun + (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 - = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id) - , nest 2 (text "in a derived instance for" - <+> quotes (pprClassPred clas tys) <> colon) - , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ] warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef @@ -2291,8 +2366,8 @@ $dmfoo :: forall v x. Baz v x => x -> x $dmfoo y = -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 @@ -2305,6 +2380,151 @@ 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 = + + 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 = + +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 = + + 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 = + + 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 = + + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Default methods need special case. They are supposed to behave rather like @@ -2437,7 +2657,7 @@ tcSpecInstPrags :: DFunId -> InstBindings GhcRn -> TcM ([LTcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) - = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $ + = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragEnv uprags binds) } @@ -2445,12 +2665,10 @@ ------------------------------ tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) - = addErrCtxt (spec_ctxt prag) $ + = addErrCtxt (SpecPragmaCtxt prag) $ do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } - where - spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) tcSpecInst _ _ = panic "tcSpecInst" @@ -2462,17 +2680,12 @@ ************************************************************************ -} -instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 :: LHsSigType GhcRn -> ErrCtxtMsg instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + = InstDeclErrCtxt $ Left $ getLHsInstDeclHead hs_inst_ty -instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 :: Type -> ErrCtxtMsg instDeclCtxt2 dfun_ty - = inst_decl_ctxt (ppr head_ty) + = InstDeclErrCtxt $ Right $ head_ty where (_,_,head_ty) = tcSplitQuantPredTy dfun_ty - -inst_decl_ctxt :: SDoc -> SDoc -inst_decl_ctxt doc = hang (text "In the instance declaration for") - 2 (quotes doc) - diff --git a/GHC/Tc/TyCl/PatSyn.hs b/GHC/Tc/TyCl/PatSyn.hs --- a/GHC/Tc/TyCl/PatSyn.hs +++ b/GHC/Tc/TyCl/PatSyn.hs @@ -37,12 +37,13 @@ import GHC.Tc.TyCl.Build import GHC.Core.Multiplicity -import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp ) +import GHC.Core.Type ( typeKind, isManyTy, mkTYPEapp ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Core.TyCo.Tidy( tidyForAllTyBinders, tidyTypes, tidyType ) import GHC.Core.Predicate -import GHC.Builtin.Types.Prim import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Core.PatSyn @@ -61,10 +62,12 @@ import GHC.Core.ConLike import GHC.Types.FieldLabel import GHC.Rename.Env -import GHC.Rename.Utils (wrapGenSpan, isIrrefutableHsPatRn) -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 ) @@ -84,37 +87,11 @@ -> TcM (LHsBinds GhcTc, TcGblEnv) tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn = setSrcSpanA loc $ - addErrCtxt (text "In the declaration for pattern synonym" - <+> quotes (ppr name)) $ - recoverM (recoverPSB psb) $ - case (sig_fn name) of - Nothing -> tcInferPatSynDecl psb prag_fn - Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn - _ -> panic "tcPatSynDecl" - -recoverPSB :: PatSynBind GhcRn GhcRn - -> TcM (LHsBinds GhcTc, TcGblEnv) --- See Note [Pattern synonym error recovery] -recoverPSB (PSB { psb_id = L _ name - , psb_args = details }) - = do { matcher_name <- newImplicitBinder name mkMatcherOcc - ; let placeholder = AConLike $ PatSynCon $ - mk_placeholder matcher_name - ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv - ; return (emptyBag, gbl_env) } - where - (_arg_names, is_infix) = collectPatSynArgInfo details - mk_placeholder matcher_name - = mkPatSyn name is_infix - ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) - [] -- Arg tys - alphaTy - (matcher_name, matcher_ty, True) Nothing - [] -- Field labels - where - -- The matcher_id is used only by the desugarer, so actually - -- and error-thunk would probably do just as well here. - matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy + addErrCtxt (PatSynDeclCtxt name) $ + case sig_fn name of + Nothing -> tcInferPatSynDecl psb prag_fn + Just (TcPatSynSig patsig) -> tcCheckPatSynDecl psb patsig prag_fn + _ -> panic "tcPatSynDecl" {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -134,14 +111,19 @@ So we use simplifyTop to completely solve the constraint, report any errors, throw an exception. -Even in the event of such an error we can recover and carry on, just -as we do for value bindings, provided we plug in placeholder for the -pattern synonym: see recoverPSB. The goal of the placeholder is not -to cause a raft of follow-on errors. I've used the simplest thing for -now, but we might need to elaborate it a bit later. (e.g. I've given -it zero args, which may cause knock-on errors if it is used in a -pattern.) But it'll do for now. +Unlike for value bindings, we don't create a placeholder pattern +synonym binding in an attempt to recover from the error, as this placeholder +was occasionally the cause of strange follow-up errors to occur, as reported in #23467. +It seems rather difficult to come up with a satisfactory placeholder: + - it would need to have the right number of arguments, + with the appropriate field names (if any), + - we could give each argument the type `forall a. a`; this would generally + work OK in pattern occurrences of the PatSyn, but not so in expressions, + e.g. "let x = Con y" would require (y :: forall a. a) which would cause + confusing errors. + +So, for now at least, we don't attempt to recover at all. -} tcInferPatSynDecl :: PatSynBind GhcRn GhcRn @@ -172,7 +154,7 @@ ; ((univ_tvs, req_dicts, ev_binds, _), residual) <- captureConstraints $ - simplifyInfer tclvl NoRestrictions [] named_taus wanted + simplifyInfer TopLevel tclvl NoRestrictions [] named_taus wanted ; top_ev_binds <- checkNoErrs (simplifyTop residual) ; addTopEvBinds top_ev_binds $ @@ -202,7 +184,7 @@ ; doNotQuantifyTyVars dvs err_ctx ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) - ; rec_fields <- lookupConstructorFields name + ; rec_fields <- lookupConstructorFields $ noUserRdr name ; tc_patsyn_finish lname dir is_infix lpat' prag_fn (mkTyVarBinders InferredSpec univ_tvs , req_theta, ev_binds, req_dicts) @@ -222,15 +204,15 @@ hetero_tys = [k1, k2, ty1, ty2] = case r of ReprEq | is_homo - -> Just ( mkClassPred coercibleClass homo_tys - , evDataConApp coercibleDataCon homo_tys eq_con_args ) + -> Just ( mkClassPred coercibleClass homo_tys + , evDictApp coercibleClass homo_tys eq_con_args ) | otherwise -> Nothing NomEq | is_homo - -> Just ( mkClassPred eqClass homo_tys - , evDataConApp eqDataCon homo_tys eq_con_args ) + -> Just ( mkClassPred eqClass homo_tys + , evDictApp eqClass homo_tys eq_con_args ) | otherwise - -> Just ( mkClassPred heqClass hetero_tys - , evDataConApp heqDataCon hetero_tys eq_con_args ) + -> Just ( mkClassPred heqClass hetero_tys + , evDictApp heqClass hetero_tys eq_con_args ) | otherwise = Just (pred, EvExpr (evId ev_id)) @@ -312,7 +294,7 @@ $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a and that is bad because (a ~# Maybe b) is not a predicate type -(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep +(see Note [Types for coercions, predicates, and evidence] in GHC.Core.Predicate and is not implicitly instantiated. So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and @@ -371,15 +353,15 @@ -} tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn - -> TcPatSynInfo + -> TcPatSynSig -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv) tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_bndrs - , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta - , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta - , patsig_body_ty = sig_body_ty } + PatSig{ patsig_implicit_bndrs = implicit_bndrs + , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req = req_theta + , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta + , patsig_body_ty = sig_body_ty } prag_fn = do { traceTc "tcCheckPatSynDecl" $ vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta @@ -472,7 +454,7 @@ ; traceTc "tcCheckPatSynDecl }" $ ppr name - ; rec_fields <- lookupConstructorFields name + ; rec_fields <- lookupConstructorFields $ noUserRdr name ; tc_patsyn_finish lname dir is_infix lpat' prag_fn (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts) (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts) @@ -583,7 +565,7 @@ until we see the pattern declaration itself before deciding res_ty is, and hence which variables are existential and which are universal. -And that in turn is why TcPatSynInfo has a separate field, +And that in turn is why TcPatSynSig has a separate field, patsig_implicit_bndrs, to capture the implicitly bound type variables, because we don't yet know how to split them up. @@ -660,7 +642,7 @@ -> ([Name], Bool) collectPatSynArgInfo details = case details of - PrefixCon _ names -> (map unLoc names, False) + PrefixCon names -> (map unLoc names, False) InfixCon name1 name2 -> (map unLoc [name1, name2], True) RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) @@ -794,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 @@ -806,13 +789,13 @@ 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 isIrrefutableHsPatRn dflags lpat + cases = if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] - gen = Generated SkipPmc + gen = Generated OtherExpansion SkipPmc body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ HsCase PatSyn (nlHsVar scrutinee) $ @@ -820,12 +803,13 @@ , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen } body' = noLocA $ - HsLam noExtField $ - MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr - args body] + HsLam noAnn LamSingle $ + MG{ mg_alts = noLocA [mkSimpleMatch (LamAlt LamSingle) + args + 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) @@ -846,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) @@ -907,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 @@ -915,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 @@ -953,9 +937,6 @@ ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } -#if __GLASGOW_HASKELL__ <= 810 - | otherwise = panic "tcPatSynBuilderBind" -- Both cases dealt with -#endif where mb_match_group = case dir of @@ -964,24 +945,24 @@ Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup (Generated SkipPmc) (noLocA [builder_match]) + mk_mg body = mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [builder_match]) where - builder_args = [L (na2la 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) args = case details of - PrefixCon _ args -> args + PrefixCon args -> args InfixCon arg1 arg2 -> [arg1, arg2] RecCon args -> map recordPatSynPatVar args 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 @@ -1019,7 +1000,8 @@ lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] + mkPrefixConExpr :: LocatedN (WithUserRdr Name) + -> [LPat GhcRn] -> Either PatSynInvalidRhsReason (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats @@ -1027,11 +1009,12 @@ ; return (unLoc $ mkHsApps con exprs) } - mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn) + mkRecordConExpr :: LocatedN (WithUserRdr Name) + -> HsRecFields GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (HsExpr GhcRn) - mkRecordConExpr con (HsRecFields 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 @@ -1042,7 +1025,7 @@ go1 :: Pat GhcRn -> Either PatSynInvalidRhsReason (HsExpr GhcRn) go1 (ConPat NoExtField con info) = case info of - PrefixCon _ ps -> mkPrefixConExpr con ps + PrefixCon ps -> mkPrefixConExpr con ps InfixCon l r -> mkPrefixConExpr con [l,r] RecCon fields -> mkRecordConExpr con fields @@ -1051,28 +1034,33 @@ go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExtField (L l var) + = return $ mkHsVar (L l var) | otherwise = Left (PatSynUnboundVar var) - go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat + go1 (ParPat _ pat) = fmap (HsPar noExtField) (go pat) go1 (ListPat _ pats) = do { exprs <- mapM go pats ; return $ ExplicitList noExtField exprs } go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField - (map (Present noAnn) exprs) box } + (map (Present noExtField) exprs) box } go1 (SumPat _ pat alt arity) = do { expr <- go1 (unLoc pat) ; return $ ExplicitSum noExtField alt arity (noLocA expr) } - go1 (LitPat _ lit) = return $ HsLit noComments lit + go1 (LitPat _ lit) = return $ HsLit noExtField lit go1 (NPat _ (L _ n) mb_neg _) | Just (SyntaxExprRn neg) <- mb_neg = return $ unLoc $ foldl' nlHsApp (noLocA neg) - [noLocA (HsOverLit noAnn n)] - | otherwise = return $ HsOverLit noAnn n + [noLocA (HsOverLit noExtField n)] + | otherwise = return $ HsOverLit noExtField n go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" + go1 (EmbTyPat _ tp) = return $ HsEmbTy noExtField (hstp_to_hswc tp) + where hstp_to_hswc :: HsTyPat GhcRn -> LHsWcType GhcRn + hstp_to_hswc (HsTP { hstp_ext = HsTPRn { hstp_nwcs = wcs }, hstp_body = hs_ty }) + = HsWC { hswc_ext = wcs, hswc_body = hs_ty } + go1 (InvisPat _ _tp) = panic "tcPatToExpr: invalid invisible pattern" go1 (XPat (HsPatExpanded _ pat))= go1 pat -- See Note [Invertible view patterns] @@ -1080,7 +1068,7 @@ Nothing -> notInvertible p Just inverse -> fmap - (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr)) + (\ expr -> HsApp noExtField (wrapGenSpan inverse) (wrapGenSpan expr)) (go1 (unLoc pat)) -- The following patterns are not invertible. @@ -1089,6 +1077,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) @@ -1242,8 +1231,8 @@ go1 :: Pat GhcTc -> ([TyVar], [EvVar]) go1 (LazyPat _ p) = go p - go1 (AsPat _ _ _ p) = go p - go1 (ParPat _ _ p _) = go p + go1 (AsPat _ _ p) = go p + go1 (ParPat _ p) = go p go1 (BangPat _ p) = go p go1 (ListPat _ ps) = mergeMany . map go $ ps go1 (TuplePat _ ps _) = mergeMany . map go $ ps @@ -1261,7 +1250,7 @@ go1 _ = empty goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar]) - goConDetails (PrefixCon _ ps) = mergeMany . map go $ ps + goConDetails (PrefixCon ps) = mergeMany . map go $ ps goConDetails (InfixCon p1 p2) = go p1 `merge` go p2 goConDetails (RecCon HsRecFields{ rec_flds = flds }) = mergeMany . map goRecFd $ flds diff --git a/GHC/Tc/TyCl/Utils.hs b/GHC/Tc/TyCl/Utils.hs --- a/GHC/Tc/TyCl/Utils.hs +++ b/GHC/Tc/TyCl/Utils.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1999 @@ -39,7 +37,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 ) @@ -53,17 +51,15 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc 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 @@ -134,30 +130,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 (ForAllCo _ 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 (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_prov (CorePrepProv _) = 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 @@ -742,13 +734,14 @@ updateRoleEnv name n role = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((), case lookupNameEnv role_env name of - Nothing -> pprPanic "updateRoleEnv" (ppr name) - Just roles -> let (before, old_role : after) = splitAt n roles in - if role `ltRole` old_role + Just roles + | (before, old_role : after) <- splitAt n roles + -> if role `ltRole` old_role then let roles' = before ++ role : after role_env' = extendNameEnv role_env name roles' in RIS { role_env = role_env', update = True } - else state ) + else state + _ -> pprPanic "updateRoleEnv" (ppr name)) {- ********************************************************************* @@ -808,14 +801,6 @@ -- (#13998) {- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -{- Note [Default method Ids and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#4169): @@ -841,24 +826,37 @@ ************************************************************************ -} +{- Note [Record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record selectors are injected as ordianry functions definitions, very +early in the pipeline. + +* `mkRecSelBinds` produces /un-typechecked/ bindings, rather like 'deriving' + This makes life easier, because the later type checking will add + all necessary type abstractions and applications; and handling for + UNPACK pragmas etc + +* Record selectors are not treated as "implicit". See + See Note [Implicit TyThings] in GHC.Types.TyThing and + Note [Injecting implicit bindings] in GHC.CoreToStg.AddImplicitBinds +-} + tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ - -- See Note [Impredicative record selectors] - setXOptM LangExt.ImpredicativeTypes $ - tcValBinds TopLevel binds sigs getGblEnv + -- See Note [Impredicative record selectors] + setXOptM LangExt.ImpredicativeTypes $ + tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where 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' --- This makes life easier, because the later type checking will add --- all necessary type abstractions and applications +-- See Note [Record selectors] mkRecSelBinds tycons = map mkRecSelBind [ (tc,fld) | tc <- tycons , fld <- tyConFieldLabels tc ] @@ -881,16 +879,25 @@ locc = noAnnSrcSpan loc lbl = flLabel fl sel_name = flSelector fl + sel_lname = L locn sel_name + match_ctxt = mkPrefixFunRhs sel_lname noAnn sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails - , sel_naughty = is_naughty - , sel_fieldLabel = fl } -- Find a representative constructor, con1 - cons_w_field = conLikesWithFields all_cons [lbl] + rec_sel_info@(RSI { rsi_def = cons_w_field }) + = conLikesRecSelInfo all_cons [lbl] con1 = assert (not (null cons_w_field)) $ head cons_w_field + -- Construct the IdDetails + rec_details = RecSelId { sel_tycon = idDetails + , sel_naughty = is_naughty + , sel_fieldLabel = fl + , sel_cons = rec_sel_info } + -- See (IRS1) in Note [Detecting incomplete record selectors] + -- in GHC.HsToCore.Pmc + + -- Selector type; Note [Polymorphic selectors] (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1 @@ -915,7 +922,7 @@ -- A slight hack! sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys (tyVarSpecToBinders sel_tvbs) $ + | otherwise = mkForAllTys sel_tvbs $ -- Urgh! See Note [The stupid context] in GHC.Core.DataCon mkPhiTy (conLikeStupidTheta con1) $ -- req_theta is empty for normal DataCon @@ -929,33 +936,31 @@ -- make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind (Generated SkipPmc) sel_lname alts + sel_bind = mkTopFunBind (Generated OtherExpansion SkipPmc) sel_lname alts where - alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname) - [] unit_rhs] + alts | is_naughty = [mkSimpleMatch match_ctxt (noLocA []) unit_rhs] | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname) - [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 } + mk_match con = mkSimpleMatch match_ctxt + (L (l2l loc') [L loc' (mk_sel_pat con)]) + (L loc' (mkHsVar (L locn field_var))) + mk_sel_pat con = + let con_lname = L locn (noUserRdr (getName con)) + in ConPat NoExtField con_lname (RecCon rec_fields) + rec_fields = HsRecFields { rec_ext = noExtField, rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLocA (HsFieldBind { hfbAnn = noAnn , 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 }) - sel_lname = L locn sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive -- 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 CaseAlt - [genWildPat] + | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat]) (genLHsApp (genHsVar (getName rEC_SEL_ERROR_ID)) (genLHsLit msg_lit))] @@ -1056,7 +1061,7 @@ The selector is defined like this: $selReadPfld :: forall a. ReadP a => String -> a $selReadPfld @a (d::ReadP a) s = readp @a d s - Perfectly fine! The (ReadP a) constraint lets us contruct a value of type + Perfectly fine! The (ReadP a) constraint lets us construct a value of type 'a' from a bare String. Another curious case (#23038): diff --git a/GHC/Tc/Types.hs b/GHC/Tc/Types.hs --- a/GHC/Tc/Types.hs +++ b/GHC/Tc/Types.hs @@ -43,6 +43,8 @@ -- Renamer types ErrCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, + ImportUserSpec(..), + ImpUserList(..), mkModDeps, -- Typechecker types @@ -57,9 +59,15 @@ CompleteMatch, CompleteMatches, -- Template Haskell - ThStage(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..), - topStage, topAnnStage, topSpliceStage, - ThLevel, impLevel, outerLevel, thLevel, + ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..), + topLevel, topAnnLevel, topSpliceLevel, + ThLevelIndex, + topLevelIndex, + spliceLevelIndex, + quoteLevelIndex, + + thLevelIndex, + ForeignSrcLang(..), THDocs, DocLoc(..), ThBindEnv, @@ -67,9 +75,12 @@ ArrowCtxt(..), -- TcSigInfo - TcSigFun, TcSigInfo(..), TcIdSigInfo(..), - TcIdSigInst(..), TcPatSynInfo(..), - isPartialSig, hasCompleteSig, + TcSigFun, + TcSigInfo(..), TcIdSig(..), + TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..), + TcIdSigInst(..), + isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc, + completeSigPolyId_maybe, -- Misc other types TcId, @@ -86,7 +97,7 @@ -- Defaulting plugin DefaultingPlugin(..), DefaultingProposal(..), - FillDefaulting, DefaultingPluginResult, + FillDefaulting, -- Role annotations RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, @@ -114,6 +125,7 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( CtLoc ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.TH import GHC.Tc.Types.TcRef @@ -132,6 +144,7 @@ import GHC.Core.FamInstEnv import GHC.Core.Predicate +import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Annotations import GHC.Types.CompleteMatch @@ -147,7 +160,6 @@ import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Types.CostCentre.State -import GHC.Types.HpcInfo import GHC.Data.IOEnv import GHC.Data.Bag @@ -171,12 +183,41 @@ import Data.Set ( Set ) import qualified Data.Set as S +import qualified Data.Map as M import Data.Dynamic ( Dynamic ) import Data.Map ( Map ) import Data.Typeable ( TypeRep ) import Data.Maybe ( mapMaybe ) +-- | The import specification as written by the user, including +-- the list of explicitly imported names. Used in 'ModIface' to +-- allow GHCi to reconstruct the top level environment on demand. +-- +-- This is distinct from 'ImportSpec' because we don't want to store +-- the list of explicitly imported names along with each 'GRE' +-- +-- We don't want to store the entire GlobalRdrEnv for modules that +-- are imported without explicit export lists, as these may grow +-- to be very large. However, GlobalRdrEnvs which are the result +-- of explicit import lists are typically quite small. +-- +-- Why do we not store something like (Maybe (ImportListInterpretation, [IE GhcPs]) in such a case? +-- Because we don't want to store source syntax including annotations in +-- interface files. +data ImportUserSpec + = ImpUserSpec { ius_decl :: !ImpDeclSpec + , ius_imports :: !ImpUserList + } +data ImpUserList + = ImpUserAll -- ^ no user import list + | ImpUserExplicit + { iul_avails :: ![AvailInfo] + , iul_non_explicit_parents :: !NameSet + -- ^ The @T@s in import list items of the form @T(..)@ + } + | ImpUserEverythingBut !NameSet + -- | A 'NameShape' is a substitution on 'Name's that can be used -- to refine the identities of a hole while we are renaming interfaces -- (see "GHC.Iface.Rename"). Specifically, a 'NameShape' for @@ -290,9 +331,8 @@ -- See Note [Rewriter CtLoc] in GHC.Tc.Solver.Rewrite. , re_flavour :: !CtFlavour , re_eq_rel :: !EqRel - -- ^ At what role are we rewriting? - -- - -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite + -- ^ At what role are we rewriting? + -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite , re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds] } @@ -438,8 +478,8 @@ -- ^ What kind of module (regular Haskell, hs-boot, hsig) tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming - tcg_default :: Maybe [Type], - -- ^ Types used for defaulting. @Nothing@ => no @default@ decl + tcg_default :: DefaultEnv, -- ^ All class defaults in scope in the module + tcg_default_exports :: DefaultEnv, -- ^ All class defaults exported from the module tcg_fix_env :: FixityEnv, -- ^ Just for things in this module @@ -467,6 +507,9 @@ tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances -- NB. BangPattern is to fix a leak, see #15111 tcg_ann_env :: AnnEnv, -- ^ And for annotations + tcg_complete_match_env :: CompleteMatches, + -- ^ The complete matches for all /home-package/ modules; + -- Includes the complete matches in tcg_complete_matches -- Now a bunch of things about this module that are simply -- accumulated, but never consulted until the end. @@ -502,6 +545,12 @@ -- (mkIfaceTc, as well as in "GHC.Driver.Main") -- - To create the Dependencies field in interface (mkDependencies) + + -- This field tracks the user-written imports of a module, so they can be + -- recorded in an interface file in order to reconstruct the top-level environment + -- if necessary for GHCi. + tcg_import_decls :: ![ImportUserSpec], + -- These three fields track unused bindings and imports -- See Note [Tracking unused binding and imports] tcg_dus :: DefUses, @@ -519,11 +568,6 @@ -- is implicit rather than explicit, so we have to zap a -- mutable variable. - tcg_th_splice_used :: TcRef Bool, - -- ^ @True@ \<=> A Template Haskell splice was used. - -- - -- Splices disable recompilation avoidance (see #481) - tcg_th_needed_deps :: TcRef ([Linkable], PkgsLoaded), -- ^ The set of runtime dependencies required by this module -- See Note [Object File Dependencies] @@ -531,6 +575,10 @@ tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. + tcg_zany_n :: TcRef Integer, + -- ^ A source of unique identities for ZonkAny instances + -- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) + tcg_merged :: [(Module, Fingerprint)], -- ^ The requirements we merged with; we always have to recompile -- if any of these changed. @@ -602,10 +650,8 @@ tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports tcg_patsyns :: [PatSyn], -- ...Pattern synonyms - tcg_doc_hdr :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs - tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the - -- prog uses hpc instrumentation. - -- NB. BangPattern is to fix a leak, see #15111 + tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)), + -- ^ Maybe Haddock header docs and Maybe located module name tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a -- corresponding hi-boot file @@ -646,9 +692,10 @@ -- ^ Wanted constraints of static forms. -- See Note [Constraints in static forms]. tcg_complete_matches :: !CompleteMatches, + -- ^ Complete matches defined in this module. - -- ^ Tracking indices for cost centre annotations tcg_cc_st :: TcRef CostCentreState, + -- ^ Tracking indices for cost centre annotations tcg_next_wrapper_num :: TcRef (ModuleEnv Int) -- ^ See Note [Generating fresh names for FFI wrappers] @@ -865,6 +912,20 @@ where add env (uid, elt) = extendInstalledModuleEnv env (mkModule uid (gwib_mod elt)) elt +plusDirectModDeps :: InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) +plusDirectModDeps = plusInstalledModuleEnv plus_mod_dep + where + plus_mod_dep (st1, r1@(GWIB { gwib_mod = m1, gwib_isBoot = boot1 })) + (st2, r2@(GWIB {gwib_mod = m2, gwib_isBoot = boot2})) + | assertPpr (m1 == m2) ((ppr m1 <+> ppr m2) $$ (ppr (boot1 == IsBoot) <+> ppr (boot2 == IsBoot))) + boot1 == IsBoot = (st1 `S.union` st2, r2) + | otherwise = (st1 `S.union` st2, r1) + -- If either side can "see" a non-hi-boot interface, use that + -- Reusing existing tuples saves 10% of allocations on test + -- perf/compiler/MultiLayerModules + plusModDeps :: InstalledModuleEnv ModuleNameWithIsBoot -> InstalledModuleEnv ModuleNameWithIsBoot -> InstalledModuleEnv ModuleNameWithIsBoot @@ -880,7 +941,7 @@ -- perf/compiler/MultiLayerModules emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, +emptyImportAvails = ImportAvails { imp_mods = M.empty, imp_direct_dep_mods = emptyInstalledModuleEnv, imp_dep_direct_pkgs = S.empty, imp_sig_mods = [], @@ -911,8 +972,8 @@ imp_sig_mods = sig_mods2, imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_direct_dep_mods = ddmods1 `plusModDeps` ddmods2, + = ImportAvails { imp_mods = M.unionWith (++) mods1 mods2, + imp_direct_dep_mods = ddmods1 `plusDirectModDeps` ddmods2, imp_dep_direct_pkgs = ddpkgs1 `S.union` ddpkgs2, imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, imp_trust_own_pkg = tself1 || tself2, @@ -1052,30 +1113,26 @@ , tcRewriterNewWanteds :: [Ct] } --- | A collection of candidate default types for a type variable. +-- | A collection of candidate default types for sets of type variables. data DefaultingProposal = DefaultingProposal - { deProposalTyVar :: TcTyVar - -- ^ The type variable to default. - , deProposalCandidates :: [Type] - -- ^ Candidate types to default the type variable to. + { deProposals :: [[(TcTyVar, Type)]] + -- ^ The type variable assignments to try. , deProposalCts :: [Ct] -- ^ The constraints against which defaults are checked. } instance Outputable DefaultingProposal where ppr p = text "DefaultingProposal" - <+> ppr (deProposalTyVar p) - <+> ppr (deProposalCandidates p) + <+> ppr (deProposals p) <+> ppr (deProposalCts p) -type DefaultingPluginResult = [DefaultingProposal] type FillDefaulting = WantedConstraints -- Zonked constraints containing the unfilled metavariables that -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins] -- in GHC.Tc.Solver - -> TcPluginM DefaultingPluginResult + -> TcPluginM [DefaultingProposal] -- | A plugin for controlling defaulting. data DefaultingPlugin = forall s. DefaultingPlugin diff --git a/GHC/Tc/Types/BasicTypes.hs b/GHC/Tc/Types/BasicTypes.hs --- a/GHC/Tc/Types/BasicTypes.hs +++ b/GHC/Tc/Types/BasicTypes.hs @@ -5,13 +5,11 @@ , TcBinder(..) -- * Signatures - , TcSigFun - , TcIdSigInfo(..) - , TcSigInfo(..) - , TcPatSynInfo(..) + , TcSigFun, TcSigInfo(..), TcIdSig(..) + , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..) , TcIdSigInst(..) - , isPartialSig - , hasCompleteSig + , isPartialSig, hasCompleteSig + , tcSigInfoName, tcIdSigLoc, completeSigPolyId_maybe -- * TcTyThing , TcTyThing(..) @@ -26,6 +24,9 @@ import GHC.Prelude +import GHC.Tc.Types.Origin( UserTypeCtxt ) +import GHC.Tc.Utils.TcType + import GHC.Types.Id import GHC.Types.Basic import GHC.Types.Var @@ -34,8 +35,6 @@ import GHC.Types.TyThing import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcType import GHC.Hs.Extension ( GhcRn ) @@ -101,33 +100,50 @@ type TcSigFun = Name -> Maybe TcSigInfo -data TcSigInfo = TcIdSig TcIdSigInfo - | TcPatSynSig TcPatSynInfo +-- TcSigInfo is simply the range of TcSigFun +data TcSigInfo = TcIdSig TcIdSig + | TcPatSynSig TcPatSynSig -- For a pattern synonym -data TcIdSigInfo -- See Note [Complete and partial type signatures] - = CompleteSig -- A complete signature with no wildcards, - -- so the complete polymorphic type is known. - { sig_bndr :: TcId -- The polymorphic Id with that type +-- See Note [Complete and partial type signatures] +data TcIdSig -- For an Id + = TcCompleteSig TcCompleteSig + | TcPartialSig TcPartialSig - , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, - -- the Name in the FunSigCtxt is not the same - -- as the TcId; the former is 'op', while the - -- latter is '$dmop' or some such +data TcCompleteSig -- A complete signature with no wildcards, + -- so the complete polymorphic type is known. + = CSig { sig_bndr :: TcId -- The polymorphic Id with that type - , sig_loc :: SrcSpan -- Location of the type signature - } + , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, + -- the Name in the FunSigCtxt is not the same + -- as the TcId; the former is 'op', while the + -- latter is '$dmop' or some such - | PartialSig -- A partial type signature (i.e. includes one or more + , sig_loc :: SrcSpan -- Location of the type signature + } + +data TcPartialSig -- A partial type signature (i.e. includes one or more -- wildcards). In this case it doesn't make sense to give -- the polymorphic Id, because we are going to /infer/ its -- type, so we can't make the polymorphic Id ab-initio - { psig_name :: Name -- Name of the function; used when report wildcards - , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in - -- HsSyn form - , sig_ctxt :: UserTypeCtxt - , sig_loc :: SrcSpan -- Location of the type signature - } + = PSig { psig_name :: Name -- Name of the function; used when report wildcards + , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in + -- HsSyn form + , psig_ctxt :: UserTypeCtxt + , psig_loc :: SrcSpan -- Location of the type signature + } +data TcPatSynSig + = PatSig { + patsig_name :: Name, + patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and + -- implicitly-bound type vars (Specified) + -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn + patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall + patsig_req :: TcThetaType, + patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall + patsig_prov :: TcThetaType, + patsig_body_ty :: TcSigmaType + } {- Note [Complete and partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -146,7 +162,7 @@ -} data TcIdSigInst - = TISI { sig_inst_sig :: TcIdSigInfo + = TISI { sig_inst_sig :: TcIdSig , sig_inst_skols :: [(Name, InvisTVBinder)] -- Instantiated type and kind variables, TyVarTvs @@ -187,7 +203,7 @@ Note that "sig_inst_tau" might actually be a polymorphic type, if the original function had a signature like forall a. Eq a => forall b. Ord b => .... -But that's ok: tcMatchesFun (called by tcRhs) can deal with that +But that's ok: tcFunBindMatches (called by tcRhs) can deal with that It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class. Note [Quantified variables in partial type signatures] @@ -231,51 +247,59 @@ sig_inst_wcs = [ _22::k ] -} -data TcPatSynInfo - = TPSI { - patsig_name :: Name, - patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and - -- implicitly-bound type vars (Specified) - -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn - patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall - patsig_req :: TcThetaType, - patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall - patsig_prov :: TcThetaType, - patsig_body_ty :: TcSigmaType - } - instance Outputable TcSigInfo where - ppr (TcIdSig idsi) = ppr idsi - ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi + ppr (TcIdSig sig) = ppr sig + ppr (TcPatSynSig sig) = ppr sig -instance Outputable TcIdSigInfo where - ppr (CompleteSig { sig_bndr = bndr }) - = ppr bndr <+> dcolon <+> ppr (idType bndr) - ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) - = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty +instance Outputable TcIdSig where + ppr (TcCompleteSig sig) = ppr sig + ppr (TcPartialSig sig) = ppr sig -instance Outputable TcIdSigInst where - ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols - , sig_inst_theta = theta, sig_inst_tau = tau }) - = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) +instance Outputable TcCompleteSig where + ppr (CSig { sig_bndr = bndr }) + = ppr bndr <+> dcolon <+> ppr (idType bndr) -instance Outputable TcPatSynInfo where - ppr (TPSI{ patsig_name = name}) = ppr name +instance Outputable TcPartialSig where + ppr (PSig { psig_name = name, psig_hs_ty = hs_ty }) + = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty +instance Outputable TcPatSynSig where + ppr (PatSig { patsig_name = name}) = ppr name + +instance Outputable TcIdSigInst where + ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols + , sig_inst_theta = theta, sig_inst_tau = tau }) + = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) + isPartialSig :: TcIdSigInst -> Bool -isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True -isPartialSig _ = False +isPartialSig (TISI { sig_inst_sig = TcPartialSig {} }) = True +isPartialSig _ = False -- | No signature or a partial signature hasCompleteSig :: TcSigFun -> Name -> Bool hasCompleteSig sig_fn name = case sig_fn name of - Just (TcIdSig (CompleteSig {})) -> True - _ -> False + Just (TcIdSig (TcCompleteSig {})) -> True + _ -> False ---------------------------- --- TcTyThing ---------------------------- +tcSigInfoName :: TcSigInfo -> Name +tcSigInfoName (TcIdSig (TcCompleteSig sig)) = idName (sig_bndr sig) +tcSigInfoName (TcIdSig (TcPartialSig sig)) = psig_name sig +tcSigInfoName (TcPatSynSig sig) = patsig_name sig + +tcIdSigLoc :: TcIdSig -> SrcSpan +tcIdSigLoc (TcCompleteSig sig) = sig_loc sig +tcIdSigLoc (TcPartialSig sig) = psig_loc sig + +completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId +completeSigPolyId_maybe (TcIdSig (TcCompleteSig sig)) = Just (sig_bndr sig) +completeSigPolyId_maybe _ = Nothing + +{- ********************************************************************* +* * + TcTyThing +* * +********************************************************************* -} -- | A typecheckable thing available in a local context. Could be -- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. diff --git a/GHC/Tc/Types/Constraint.hs b/GHC/Tc/Types/Constraint.hs --- a/GHC/Tc/Types/Constraint.hs +++ b/GHC/Tc/Types/Constraint.hs @@ -1,2626 +1,2739 @@ - -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeApplications #-} - --- | This module defines types and simple operations over constraints, as used --- in the type-checker and constraint solver. -module GHC.Tc.Types.Constraint ( - -- Constraints - Xi, Ct(..), Cts, - singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, - isEmptyCts, emptyCts, andCts, ctsPreds, - isPendingScDictCt, isPendingScDict, pendingScDict_maybe, - superClassesMightHelp, getPendingWantedScs, - isWantedCt, isGivenCt, - isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg, - isUnsatisfiableCt_maybe, - ctEvidence, updCtEvidence, - ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, - ctRewriters, - ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv, - mkNonCanonical, mkGivens, - tyCoVarsOfCt, tyCoVarsOfCts, - tyCoVarsOfCtList, tyCoVarsOfCtsList, - - -- Particular forms of constraint - EqCt(..), eqCtEvidence, eqCtLHS, - DictCt(..), dictCtEvidence, - IrredCt(..), irredCtEvidence, mkIrredCt, ctIrredCt, irredCtPred, - - -- QCInst - QCInst(..), pendingScInst_maybe, - - ExpansionFuel, doNotExpand, consumeFuel, pendingFuel, - assertFuelPrecondition, assertFuelPreconditionStrict, - - CtIrredReason(..), isInsolubleReason, - - CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck, - cteOK, cteImpredicative, cteTypeFamily, cteCoercionHole, - cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble, - cteConcrete, cteSkolemEscape, - impredicativeProblem, insolubleOccursProblem, solubleOccursProblem, - - cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, cterHasOnlyProblems, - cterRemoveProblem, cterHasOccursCheck, cterFromKind, - - - CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe, - canEqLHSKind, canEqLHSType, eqCanEqLHS, - - Hole(..), HoleSort(..), isOutOfScopeHole, - DelayedError(..), NotConcreteError(..), - NotConcreteReason(..), - - WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, - isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, - addInsols, dropMisleading, addSimples, addImplics, addHoles, - addNotConcreteError, addDelayedErrors, - tyCoVarsOfWC, tyCoVarsOfWCList, - insolubleWantedCt, insolubleCt, insolubleIrredCt, - insolubleImplic, nonDefaultableTyVarsOfWC, - - Implication(..), implicationPrototype, checkTelescopeSkol, - ImplicStatus(..), isInsolubleStatus, isSolvedStatus, - UserGiven, getUserGivensFromImplics, - HasGivenEqs(..), checkImplicationInvariants, - SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, - bumpSubGoalDepth, subGoalDepthExceeded, - CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, - ctLocTypeOrKind_maybe, - ctLocDepth, bumpCtLocDepth, isGivenLoc, - setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, - pprCtLoc, adjustCtLoc, adjustCtLocTyConBinder, - - -- CtLocEnv - CtLocEnv(..), setCtLocEnvLoc, setCtLocEnvLvl, getCtLocEnvLoc, getCtLocEnvLvl, ctLocEnvInGeneratedCode, - - -- CtEvidence - CtEvidence(..), TcEvDest(..), - isWanted, isGiven, - ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, - ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, - ctEvRewriters, ctEvUnique, tcEvDestUnique, - mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc, - ctEvRole, setCtEvPredType, setCtEvLoc, - tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, - - -- RewriterSet - RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, - -- exported concretely only for zonkRewriterSet - addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts, - - wrapType, - - CtFlavour(..), ctEvFlavour, - CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCtFlavourRole, - eqCanRewrite, eqCanRewriteFR, - - -- Pretty printing - pprEvVarTheta, - pprEvVars, pprEvVarWithType, - - ) - where - -import GHC.Prelude - -import GHC.Core.Predicate -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Types.Name -import GHC.Types.Var - -import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Origin -import GHC.Tc.Types.CtLocEnv - -import GHC.Core - -import GHC.Core.TyCo.Ppr -import GHC.Utils.FV -import GHC.Types.Var.Set -import GHC.Builtin.Names -import GHC.Types.Basic -import GHC.Types.Unique.Set - -import GHC.Utils.Outputable -import GHC.Types.SrcLoc -import GHC.Data.Bag -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Constants (debugIsOn) -import GHC.Types.Name.Reader - -import Data.Coerce -import qualified Data.Semigroup as S -import Control.Monad ( msum, when ) -import Data.Maybe ( mapMaybe, isJust ) -import Data.List.NonEmpty ( NonEmpty ) - --- these are for CheckTyEqResult -import Data.Word ( Word8 ) -import Data.List ( intersperse ) - - - -{- -************************************************************************ -* * -* Canonical constraints * -* * -* These are the constraints the low-level simplifier works with * -* * -************************************************************************ --} - --- | A 'Xi'-type is one that has been fully rewritten with respect --- to the inert set; that is, it has been rewritten by the algorithm --- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years, --- meant that a type was type-family-free. It does *not* mean this --- any more.) -type Xi = TcType - -type Cts = Bag Ct - --- | Says how many layers of superclasses can we expand. --- Invariant: ExpansionFuel should always be >= 0 --- see Note [Expanding Recursive Superclasses and ExpansionFuel] -type ExpansionFuel = Int - --- | Do not expand superclasses any further -doNotExpand :: ExpansionFuel -doNotExpand = 0 - --- | Consumes one unit of fuel. --- Precondition: fuel > 0 -consumeFuel :: ExpansionFuel -> ExpansionFuel -consumeFuel fuel = assertFuelPreconditionStrict fuel $ fuel - 1 - --- | Returns True if we have any fuel left for superclass expansion -pendingFuel :: ExpansionFuel -> Bool -pendingFuel n = n > 0 - -insufficientFuelError :: SDoc -insufficientFuelError = text "Superclass expansion fuel should be > 0" - --- | asserts if fuel is non-negative -assertFuelPrecondition :: ExpansionFuel -> a -> a -{-# INLINE assertFuelPrecondition #-} -assertFuelPrecondition fuel = assertPpr (fuel >= 0) insufficientFuelError - --- | asserts if fuel is strictly greater than 0 -assertFuelPreconditionStrict :: ExpansionFuel -> a -> a -{-# INLINE assertFuelPreconditionStrict #-} -assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError - -data Ct - = CDictCan DictCt - | CIrredCan IrredCt -- A "irreducible" constraint (non-canonical) - | CEqCan EqCt -- A canonical equality constraint - | CQuantCan QCInst -- A quantified constraint - | CNonCanonical CtEvidence -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad - ---------------- DictCt -------------- - -data DictCt -- e.g. Num ty - = DictCt { di_ev :: CtEvidence -- See Note [Ct/evidence invariant] - - , di_cls :: Class - , di_tys :: [Xi] -- di_tys are rewritten w.r.t. inerts, so Xi - - , di_pend_sc :: ExpansionFuel - -- See Note [The superclass story] in GHC.Tc.Solver.Dict - -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver - -- Invariants: di_pend_sc > 0 <=> - -- (a) di_cls has superclasses - -- (b) those superclasses are not yet explored - } - -dictCtEvidence :: DictCt -> CtEvidence -dictCtEvidence = di_ev - -instance Outputable DictCt where - ppr dict = ppr (CDictCan dict) - ---------------- EqCt -------------- - -{- Note [Canonical equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An EqCt is a canonical equality constraint, one that can live in the inert set, -and that can be used to rewrite other constrtaints. It satisfies these invariants: - * (TyEq:OC) lhs does not occur in rhs (occurs check) - Note [EqCt occurs check] - * (TyEq:F) rhs has no foralls - (this avoids substituting a forall for the tyvar in other types) - * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant] - * (TyEq:N) If the equality is representational, rhs is not headed by a saturated - application of a newtype TyCon. See GHC.Tc.Solver.Equality - Note [No top-level newtypes on RHS of representational equalities]. - (Applies only when constructor of newtype is in scope.) - * (TyEq:U) An EqCt is not immediately unifiable. If we can unify a:=ty, we - will not form an EqCt (a ~ ty). - * (TyEq:CH) rhs does not mention any coercion holes that resulted from fixing up - a hetero-kinded equality. See Note [Equalities with incompatible kinds] in - GHC.Tc.Solver.Equality, wrinkle (EIK2) - -These invariants ensure that the EqCts in inert_eqs constitute a terminating -generalised substitution. See Note [inert_eqs: the inert equalities] -in GHC.Tc.Solver.InertSet for what these words mean! - -Note [EqCt occurs check] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A CEqCan relates a CanEqLHS (a type variable or type family applications) on -its left to an arbitrary type on its right. It is used for rewriting. -Because it is used for rewriting, it would be disastrous if the RHS -were to mention the LHS: this would cause a loop in rewriting. - -We thus perform an occurs-check. There is, of course, some subtlety: - -* For type variables, the occurs-check looks deeply including kinds of - type variables. This is because a CEqCan over a meta-variable is - also used to inform unification, in - GHC.Tc.Solver.Monad.checkTouchableTyVarEq. If the LHS appears - anywhere in the RHS, at all, unification will create an infinite - structure which is bad. - -* For type family applications, the occurs-check is shallow; it looks - only in places where we might rewrite. (Specifically, it does not - look in kinds or coercions.) An occurrence of the LHS in, say, an - RHS coercion is OK, as we do not rewrite in coercions. No loop to - be found. - - You might also worry about the possibility that a type family - application LHS doesn't exactly appear in the RHS, but something - that reduces to the LHS does. Yet that can't happen: the RHS is - already inert, with all type family redexes reduced. So a simple - syntactic check is just fine. - -The occurs check is performed in GHC.Tc.Utils.Unify.checkTyEqRhs -and forms condition T3 in Note [Extending the inert equalities] -in GHC.Tc.Solver.InertSet. --} - -data EqCt -- An equality constraint; see Note [Canonical equalities] - = EqCt { -- CanEqLHS ~ rhs - eq_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - eq_lhs :: CanEqLHS, - eq_rhs :: Xi, -- See invariants above - eq_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev - } - --- | A 'CanEqLHS' is a type that can appear on the left of a canonical --- equality: a type variable or /exactly-saturated/ type family application. -data CanEqLHS - = TyVarLHS TcTyVar - | TyFamLHS TyCon -- ^ TyCon of the family - [Xi] -- ^ Arguments, /exactly saturating/ the family - -instance Outputable CanEqLHS where - ppr (TyVarLHS tv) = ppr tv - ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args) - -eqCtEvidence :: EqCt -> CtEvidence -eqCtEvidence = eq_ev - -eqCtLHS :: EqCt -> CanEqLHS -eqCtLHS = eq_lhs - ---------------- IrredCt -------------- - -data IrredCt -- These stand for yet-unusable predicates - -- See Note [CIrredCan constraints] - = IrredCt { ir_ev :: CtEvidence -- See Note [Ct/evidence invariant] - , ir_reason :: CtIrredReason } - -mkIrredCt :: CtIrredReason -> CtEvidence -> Ct -mkIrredCt reason ev = CIrredCan (IrredCt { ir_ev = ev, ir_reason = reason }) - -irredCtEvidence :: IrredCt -> CtEvidence -irredCtEvidence = ir_ev - -irredCtPred :: IrredCt -> PredType -irredCtPred = ctEvPred . irredCtEvidence - -ctIrredCt :: CtIrredReason -> Ct -> IrredCt -ctIrredCt _ (CIrredCan ir) = ir -ctIrredCt reason ct = IrredCt { ir_ev = ctEvidence ct - , ir_reason = reason } - -instance Outputable IrredCt where - ppr irred = ppr (CIrredCan irred) - ---------------- QCInst -------------- - -data QCInst -- A much simplified version of ClsInst - -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve - = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty - -- Always Given - , qci_tvs :: [TcTyVar] -- The tvs - , qci_pred :: TcPredType -- The ty - , qci_pend_sc :: ExpansionFuel - -- Invariants: qci_pend_sc > 0 => - -- (a) qci_pred is a ClassPred - -- (b) this class has superclass(es), and - -- (c) the superclass(es) are not explored yet - -- Same as di_pend_sc flag in DictCt - -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver - } - -instance Outputable QCInst where - ppr (QCI { qci_ev = ev }) = ppr ev - ------------------------------------------------------------------------------- --- --- Holes and other delayed errors --- ------------------------------------------------------------------------------- - --- | A delayed error, to be reported after constraint solving, in order to benefit --- from deferred unifications. -data DelayedError - = DE_Hole Hole - -- ^ A hole (in a type or in a term). - -- - -- See Note [Holes]. - | DE_NotConcrete NotConcreteError - -- ^ A type could not be ensured to be concrete. - -- - -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. - -instance Outputable DelayedError where - ppr (DE_Hole hole) = ppr hole - ppr (DE_NotConcrete err) = ppr err - --- | A hole stores the information needed to report diagnostics --- about holes in terms (unbound identifiers or underscores) or --- in types (also called wildcards, as used in partial type --- signatures). See Note [Holes]. -data Hole - = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this? - , hole_occ :: RdrName -- ^ The name of this hole - , hole_ty :: TcType -- ^ Type to be printed to the user - -- For expression holes: type of expr - -- For type holes: the missing type - , hole_loc :: CtLoc -- ^ Where hole was written - } - -- For the hole_loc, we usually only want the TcLclEnv stored within. - -- Except when we rewrite, where we need a whole location. And this - -- might get reported to the user if reducing type families in a - -- hole type loops. - - --- | Used to indicate which sort of hole we have. -data HoleSort = ExprHole HoleExprRef - -- ^ Either an out-of-scope variable or a "true" hole in an - -- expression (TypedHoles). - -- The HoleExprRef says where to write the - -- the erroring expression for -fdefer-type-errors. - | TypeHole - -- ^ A hole in a type (PartialTypeSignatures) - | ConstraintHole - -- ^ A hole in a constraint, like @f :: (_, Eq a) => ... - -- Differentiated from TypeHole because a ConstraintHole - -- is simplified differently. See - -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver. - -instance Outputable Hole where - ppr (Hole { hole_sort = ExprHole ref - , hole_occ = occ - , hole_ty = ty }) - = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty - ppr (Hole { hole_sort = _other - , hole_occ = occ - , hole_ty = ty }) - = braces $ ppr occ <> colon <> ppr ty - -instance Outputable HoleSort where - ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref - ppr TypeHole = text "TypeHole" - ppr ConstraintHole = text "ConstraintHole" - --- | Why did we require that a certain type be concrete? -data NotConcreteError - -- | Concreteness was required by a representation-polymorphism - -- check. - -- - -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. - = NCE_FRR - { nce_loc :: CtLoc - -- ^ Where did this check take place? - , nce_frr_origin :: FixedRuntimeRepOrigin - -- ^ Which representation-polymorphism check did we perform? - , nce_reasons :: NonEmpty NotConcreteReason - -- ^ Why did the check fail? - } - --- | Why did we decide that a type was not concrete? -data NotConcreteReason - -- | The type contains a 'TyConApp' of a non-concrete 'TyCon'. - -- - -- See Note [Concrete types] in GHC.Tc.Utils.Concrete. - = NonConcreteTyCon TyCon [TcType] - - -- | The type contains a type variable that could not be made - -- concrete (e.g. a skolem type variable). - | NonConcretisableTyVar TyVar - - -- | The type contains a cast. - | ContainsCast TcType TcCoercionN - - -- | The type contains a forall. - | ContainsForall ForAllTyBinder TcType - - -- | The type contains a 'CoercionTy'. - | ContainsCoercionTy TcCoercion - -instance Outputable NotConcreteError where - ppr (NCE_FRR { nce_frr_origin = frr_orig }) - = text "NCE_FRR" <+> parens (ppr (frr_type frr_orig)) - ------------- --- | Used to indicate extra information about why a CIrredCan is irreducible -data CtIrredReason - = IrredShapeReason - -- ^ This constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) - - | NonCanonicalReason CheckTyEqResult - -- ^ An equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied; - -- the 'CheckTyEqResult' states exactly why - - | ReprEqReason - -- ^ An equality that cannot be decomposed because it is representational. - -- Example: @a b ~R# Int@. - -- These might still be solved later. - -- INVARIANT: The constraint is a representational equality constraint - - | ShapeMismatchReason - -- ^ A nominal equality that relates two wholly different types, - -- like @Int ~# Bool@ or @a b ~# 3@. - -- INVARIANT: The constraint is a nominal equality constraint - - | AbstractTyConReason - -- ^ An equality like @T a b c ~ Q d e@ where either @T@ or @Q@ - -- is an abstract type constructor. See Note [Skolem abstract data] - -- in GHC.Core.TyCon. - -- INVARIANT: The constraint is an equality constraint between two TyConApps - - | PluginReason - -- ^ A typechecker plugin returned this in the pluginBadCts field - -- of TcPluginProgress - -instance Outputable CtIrredReason where - ppr IrredShapeReason = text "(irred)" - ppr (NonCanonicalReason cter) = ppr cter - ppr ReprEqReason = text "(repr)" - ppr ShapeMismatchReason = text "(shape)" - ppr AbstractTyConReason = text "(abstc)" - ppr PluginReason = text "(plugin)" - --- | Are we sure that more solving will never solve this constraint? -isInsolubleReason :: CtIrredReason -> Bool -isInsolubleReason IrredShapeReason = False -isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter -isInsolubleReason ReprEqReason = False -isInsolubleReason ShapeMismatchReason = True -isInsolubleReason AbstractTyConReason = True -isInsolubleReason PluginReason = True - ------------------------------------------------------------------------------- --- --- CheckTyEqResult, defined here because it is stored in a CtIrredReason --- ------------------------------------------------------------------------------- - --- | A /set/ of problems in checking the validity of a type equality. --- See 'checkTypeEq'. -newtype CheckTyEqResult = CTER Word8 - --- | No problems in checking the validity of a type equality. -cteOK :: CheckTyEqResult -cteOK = CTER zeroBits - --- | Check whether a 'CheckTyEqResult' is marked successful. -cterHasNoProblem :: CheckTyEqResult -> Bool -cterHasNoProblem (CTER 0) = True -cterHasNoProblem _ = False - --- | An /individual/ problem that might be logged in a 'CheckTyEqResult' -newtype CheckTyEqProblem = CTEP Word8 - -cteImpredicative, cteTypeFamily, cteInsolubleOccurs, - cteSolubleOccurs, cteCoercionHole, cteConcrete, - cteSkolemEscape :: CheckTyEqProblem -cteImpredicative = CTEP (bit 0) -- Forall or (=>) encountered -cteTypeFamily = CTEP (bit 1) -- Type family encountered - -cteInsolubleOccurs = CTEP (bit 2) -- Occurs-check -cteSolubleOccurs = CTEP (bit 3) -- Occurs-check under a type function, or in a coercion, - -- or in a representational equality; see - -- See Note [Occurs check and representational equality] - -- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs - -- See also Note [Insoluble mis-match] in GHC.Tc.Errors - -cteCoercionHole = CTEP (bit 4) -- Coercion hole encountered -cteConcrete = CTEP (bit 5) -- Type variable that can't be made concrete - -- e.g. alpha[conc] ~ Maybe beta[tv] -cteSkolemEscape = CTEP (bit 6) -- Skolem escape e.g. alpha[2] ~ b[sk,4] - -cteProblem :: CheckTyEqProblem -> CheckTyEqResult -cteProblem (CTEP mask) = CTER mask - -impredicativeProblem, insolubleOccursProblem, solubleOccursProblem :: CheckTyEqResult -impredicativeProblem = cteProblem cteImpredicative -insolubleOccursProblem = cteProblem cteInsolubleOccurs -solubleOccursProblem = cteProblem cteSolubleOccurs - -occurs_mask :: Word8 -occurs_mask = insoluble_mask .|. soluble_mask - where - CTEP insoluble_mask = cteInsolubleOccurs - CTEP soluble_mask = cteSolubleOccurs - --- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem' -cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool -CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0 - --- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other -cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool -CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask - -cterHasOnlyProblems :: CheckTyEqResult -> CheckTyEqResult -> Bool -CTER bits `cterHasOnlyProblems` CTER mask = (bits .&. complement mask) == 0 - -cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult -cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask) - -cterHasOccursCheck :: CheckTyEqResult -> Bool -cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0 - -cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult -cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask) - --- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs --- check under a type family or in a representation equality is soluble. -cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult -cterSetOccursCheckSoluble (CTER bits) - = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask) - where - CTEP insoluble_mask = cteInsolubleOccurs - --- | Retain only information about occurs-check failures, because only that --- matters after recurring into a kind. -cterFromKind :: CheckTyEqResult -> CheckTyEqResult -cterFromKind (CTER bits) - = CTER (bits .&. occurs_mask) - -cterIsInsoluble :: CheckTyEqResult -> Bool -cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0 - where - mask = impredicative_mask .|. insoluble_occurs_mask - - CTEP impredicative_mask = cteImpredicative - CTEP insoluble_occurs_mask = cteInsolubleOccurs - -instance Semigroup CheckTyEqResult where - CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2) -instance Monoid CheckTyEqResult where - mempty = cteOK - -instance Eq CheckTyEqProblem where - (CTEP b1) == (CTEP b2) = b1==b2 - -instance Outputable CheckTyEqProblem where - ppr prob@(CTEP bits) = case lookup prob allBits of - Just s -> text s - Nothing -> text "unknown:" <+> ppr bits - -instance Outputable CheckTyEqResult where - ppr cter | cterHasNoProblem cter - = text "cteOK" - | otherwise - = braces $ fcat $ intersperse vbar $ - [ text str - | (bitmask, str) <- allBits - , cter `cterHasProblem` bitmask ] - -allBits :: [(CheckTyEqProblem, String)] -allBits = [ (cteImpredicative, "cteImpredicative") - , (cteTypeFamily, "cteTypeFamily") - , (cteInsolubleOccurs, "cteInsolubleOccurs") - , (cteSolubleOccurs, "cteSolubleOccurs") - , (cteConcrete, "cteConcrete") - , (cteSkolemEscape, "cteSkolemEscape") - , (cteCoercionHole, "cteCoercionHole") ] - -{- Note [CIrredCan constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CIrredCan constraints are used for constraints that are "stuck" - - we can't solve them (yet) - - we can't use them to solve other constraints - - but they may become soluble if we substitute for some - of the type variables in the constraint - -Example 1: (c Int), where c :: * -> Constraint. We can't do anything - with this yet, but if later c := Num, *then* we can solve it - -Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable - We don't want to use this to substitute 'b' for 'a', in case - 'k' is subsequently unified with (say) *->*, because then - we'd have ill-kinded types floating about. Rather we want - to defer using the equality altogether until 'k' get resolved. - -Note [Ct/evidence invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field -of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for DictCt, - ctev_pred (di_ev ct) = (di_cls ct) (di_tys ct) -This holds by construction; look at the unique place where DictCt is -built (in GHC.Tc.Solver.Dict.canDictNC). - -Note [Ct kind invariant] -~~~~~~~~~~~~~~~~~~~~~~~~ -CEqCan requires that the kind of the lhs matches the kind -of the rhs. This is necessary because these constraints are used for substitutions -during solving. If the kinds differed, then the substitution would take a well-kinded -type to an ill-kinded one. - -Note [Holes] -~~~~~~~~~~~~ -This Note explains how GHC tracks *holes*. - -A hole represents one of two conditions: - - A missing bit of an expression. Example: foo x = x + _ - - A missing bit of a type. Example: bar :: Int -> _ - -What these have in common is that both cause GHC to emit a diagnostic to the -user describing the bit that is left out. - -When a hole is encountered, a new entry of type Hole is added to the ambient -WantedConstraints. The type (hole_ty) of the hole is then simplified during -solving (with respect to any Givens in surrounding implications). It is -reported with all the other errors in GHC.Tc.Errors. - -For expression holes, the user has the option of deferring errors until runtime -with -fdefer-type-errors. In this case, the hole actually has evidence: this -evidence is an erroring expression that prints an error and crashes at runtime. -The ExprHole variant of holes stores an IORef EvTerm that will contain this evidence; -during constraint generation, this IORef was stored in the HsUnboundVar extension -field by the type checker. The desugarer simply dereferences to get the CoreExpr. - -Prior to fixing #17812, we used to invent an Id to hold the erroring -expression, and then bind it during type-checking. But this does not support -representation-polymorphic out-of-scope identifiers. See -typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach -described above. - -You might think that the type in the HoleExprRef is the same as the type of the -hole. However, because the hole type (hole_ty) is rewritten with respect to -givens, this might not be the case. That is, the hole_ty is always (~) to the -type of the HoleExprRef, but they might not be `eqType`. We need the type of the generated -evidence to match what is expected in the context of the hole, and so we must -store these types separately. - -Type-level holes have no evidence at all. --} - -mkNonCanonical :: CtEvidence -> Ct -mkNonCanonical ev = CNonCanonical ev - -mkGivens :: CtLoc -> [EvId] -> [Ct] -mkGivens loc ev_ids - = map mk ev_ids - where - mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id - , ctev_pred = evVarPred ev_id - , ctev_loc = loc }) - -ctEvidence :: Ct -> CtEvidence -ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev -ctEvidence (CEqCan (EqCt { eq_ev = ev })) = ev -ctEvidence (CIrredCan (IrredCt { ir_ev = ev })) = ev -ctEvidence (CNonCanonical ev) = ev -ctEvidence (CDictCan (DictCt { di_ev = ev })) = ev - -updCtEvidence :: (CtEvidence -> CtEvidence) -> Ct -> Ct -updCtEvidence upd ct - = case ct of - CQuantCan qci@(QCI { qci_ev = ev }) -> CQuantCan (qci { qci_ev = upd ev }) - CEqCan eq@(EqCt { eq_ev = ev }) -> CEqCan (eq { eq_ev = upd ev }) - CIrredCan ir@(IrredCt { ir_ev = ev }) -> CIrredCan (ir { ir_ev = upd ev }) - CNonCanonical ev -> CNonCanonical (upd ev) - CDictCan di@(DictCt { di_ev = ev }) -> CDictCan (di { di_ev = upd ev }) - -ctLoc :: Ct -> CtLoc -ctLoc = ctEvLoc . ctEvidence - -ctOrigin :: Ct -> CtOrigin -ctOrigin = ctLocOrigin . ctLoc - -ctPred :: Ct -> PredType --- See Note [Ct/evidence invariant] -ctPred ct = ctEvPred (ctEvidence ct) - -ctRewriters :: Ct -> RewriterSet -ctRewriters = ctEvRewriters . ctEvidence - -ctEvId :: HasDebugCallStack => Ct -> EvVar --- The evidence Id for this Ct -ctEvId ct = ctEvEvId (ctEvidence ct) - --- | Returns the evidence 'Id' for the argument 'Ct' --- when this 'Ct' is a 'Wanted'. --- --- Returns 'Nothing' otherwise. -wantedEvId_maybe :: Ct -> Maybe EvVar -wantedEvId_maybe ct - = case ctEvidence ct of - ctev@(CtWanted {}) - | otherwise - -> Just $ ctEvEvId ctev - CtGiven {} - -> Nothing - --- | Makes a new equality predicate with the same role as the given --- evidence. -mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType -mkTcEqPredLikeEv ev - = case predTypeEqRel pred of - NomEq -> mkPrimEqPred - ReprEq -> mkReprPrimEqPred - where - pred = ctEvPred ev - --- | Get the flavour of the given 'Ct' -ctFlavour :: Ct -> CtFlavour -ctFlavour = ctEvFlavour . ctEvidence - --- | Get the equality relation for the given 'Ct' -ctEqRel :: Ct -> EqRel -ctEqRel = ctEvEqRel . ctEvidence - -instance Outputable Ct where - ppr ct = ppr (ctEvidence ct) <+> parens pp_sort - where - pp_sort = case ct of - CEqCan {} -> text "CEqCan" - CNonCanonical {} -> text "CNonCanonical" - CDictCan (DictCt { di_pend_sc = psc }) - | psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc) - | otherwise -> text "CDictCan" - CIrredCan (IrredCt { ir_reason = reason }) -> text "CIrredCan" <> ppr reason - CQuantCan (QCI { qci_pend_sc = psc }) - | psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc) - | otherwise -> text "CQuantCan" - -instance Outputable EqCt where - ppr (EqCt { eq_ev = ev }) = ppr ev - ------------------------------------ --- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated --- type family application? --- Does not look through type synonyms. -canEqLHS_maybe :: Xi -> Maybe CanEqLHS -canEqLHS_maybe xi - | Just tv <- getTyVar_maybe xi - = Just $ TyVarLHS tv - - | otherwise - = canTyFamEqLHS_maybe xi - -canTyFamEqLHS_maybe :: Xi -> Maybe CanEqLHS -canTyFamEqLHS_maybe xi - | Just (tc, args) <- tcSplitTyConApp_maybe xi - , isTypeFamilyTyCon tc - , args `lengthIs` tyConArity tc - = Just $ TyFamLHS tc args - - | otherwise - = Nothing - --- | Convert a 'CanEqLHS' back into a 'Type' -canEqLHSType :: CanEqLHS -> TcType -canEqLHSType (TyVarLHS tv) = mkTyVarTy tv -canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args - --- | Retrieve the kind of a 'CanEqLHS' -canEqLHSKind :: CanEqLHS -> TcKind -canEqLHSKind (TyVarLHS tv) = tyVarKind tv -canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args - --- | Are two 'CanEqLHS's equal? -eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool -eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2 -eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2) - = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2 -eqCanEqLHS _ _ = False - -{- -************************************************************************ -* * - Simple functions over evidence variables -* * -************************************************************************ --} - ----------------- Getting free tyvars ------------------------- - --- | Returns free variables of constraints as a non-deterministic set -tyCoVarsOfCt :: Ct -> TcTyCoVarSet -tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt - --- | Returns free variables of constraints as a non-deterministic set -tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet -tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv - --- | Returns free variables of constraints as a deterministically ordered --- list. See Note [Deterministic FV] in GHC.Utils.FV. -tyCoVarsOfCtList :: Ct -> [TcTyCoVar] -tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt - --- | Returns free variables of constraints as a deterministically ordered --- list. See Note [Deterministic FV] in GHC.Utils.FV. -tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar] -tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred - --- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoFVsOfCt :: Ct -> FV -tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) - -- This must consult only the ctPred, so that it gets *tidied* fvs if the - -- constraint has been tidied. Tidying a constraint does not tidy the - -- fields of the Ct, only the predicate in the CtEvidence. - --- | Returns free variables of constraints as a composable FV computation. --- See Note [Deterministic FV] in GHC.Utils.FV. -tyCoFVsOfCtEv :: CtEvidence -> FV -tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct) - --- | Returns free variables of a bag of constraints as a non-deterministic --- set. See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoVarsOfCts :: Cts -> TcTyCoVarSet -tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a deterministically --- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] -tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts - --- | Returns free variables of a bag of constraints as a deterministically --- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. -tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar] -tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs - --- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoFVsOfCts :: Cts -> FV -tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV - --- | Returns free variables of a bag of constraints as a composable FV --- computation. See Note [Deterministic FV] in GHC.Utils.FV. -tyCoFVsOfCtEvs :: [CtEvidence] -> FV -tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV - --- | Returns free variables of WantedConstraints as a non-deterministic --- set. See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet --- Only called on *zonked* things -tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a deterministically --- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] --- Only called on *zonked* things -tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC - --- | Returns free variables of WantedConstraints as a composable FV --- computation. See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoFVsOfWC :: WantedConstraints -> FV --- Only called on *zonked* things -tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_errors = errors }) - = tyCoFVsOfCts simple `unionFV` - tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV` - tyCoFVsOfBag tyCoFVsOfDelayedError errors - --- | Returns free variables of Implication as a composable FV computation. --- See Note [Deterministic FV] in "GHC.Utils.FV". -tyCoFVsOfImplic :: Implication -> FV --- Only called on *zonked* things -tyCoFVsOfImplic (Implic { ic_skols = skols - , ic_given = givens - , ic_wanted = wanted }) - | isEmptyWC wanted - = emptyFV - | otherwise - = tyCoFVsVarBndrs skols $ - tyCoFVsVarBndrs givens $ - tyCoFVsOfWC wanted - -tyCoFVsOfDelayedError :: DelayedError -> FV -tyCoFVsOfDelayedError (DE_Hole hole) = tyCoFVsOfHole hole -tyCoFVsOfDelayedError (DE_NotConcrete {}) = emptyFV - -tyCoFVsOfHole :: Hole -> FV -tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty - -tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV -tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV - -isGivenLoc :: CtLoc -> Bool -isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) - -{- -************************************************************************ -* * - CtEvidence - The "flavor" of a canonical constraint -* * -************************************************************************ --} - -isWantedCt :: Ct -> Bool -isWantedCt = isWanted . ctEvidence - -isGivenCt :: Ct -> Bool -isGivenCt = isGiven . ctEvidence - -{- Note [Custom type errors in constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -When GHC reports a type-error about an unsolved-constraint, we check -to see if the constraint contains any custom-type errors, and if so -we report them. Here are some examples of constraints containing type -errors: - -TypeError msg -- The actual constraint is a type error - -TypError msg ~ Int -- Some type was supposed to be Int, but ended up - -- being a type error instead - -Eq (TypeError msg) -- A class constraint is stuck due to a type error - -F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err - -It is also possible to have constraints where the type error is nested deeper, -for example see #11990, and also: - -Eq (F (TypeError msg)) -- Here the type error is nested under a type-function - -- call, which failed to evaluate because of it, - -- and so the `Eq` constraint was unsolved. - -- This may happen when one function calls another - -- and the called function produced a custom type error. --} - --- | A constraint is considered to be a custom type error, if it contains --- custom type errors anywhere in it. --- See Note [Custom type errors in constraints] -getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType -getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred - : map getUserTypeErrorMsg (subTys pred) - where - -- Richard thinks this function is very broken. What is subTys - -- supposed to be doing? Why are exactly-saturated tyconapps special? - -- What stops this from accidentally ripping apart a call to TypeError? - subTys t = case splitAppTys t of - (t,[]) -> - case splitTyConApp_maybe t of - Nothing -> [] - Just (_,ts) -> ts - (t,ts) -> t : ts - --- | Is this an user error message type, i.e. either the form @TypeError err@ or --- @Unsatisfiable err@? -isTopLevelUserTypeError :: PredType -> Bool -isTopLevelUserTypeError pred = - isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) - --- | Does this constraint contain an user error message? --- --- That is, the type is either of the form @Unsatisfiable err@, or it contains --- a type of the form @TypeError msg@, either at the top level or nested inside --- the type. -containsUserTypeError :: PredType -> Bool -containsUserTypeError pred = - isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) - --- | Is this type an unsatisfiable constraint? --- If so, return the error message. -isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType -isUnsatisfiableCt_maybe t - | Just (tc, [msg]) <- splitTyConApp_maybe t - , tc `hasKey` unsatisfiableClassNameKey - = Just msg - | otherwise - = Nothing - -isPendingScDict :: Ct -> Bool -isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct -isPendingScDict _ = False - -isPendingScDictCt :: DictCt -> Bool --- Says whether this is a CDictCan with di_pend_sc has positive fuel; --- i.e. pending un-expanded superclasses -isPendingScDictCt (DictCt { di_pend_sc = f }) = pendingFuel f - -pendingScDict_maybe :: Ct -> Maybe Ct --- Says whether this is a CDictCan with di_pend_sc has fuel left, --- AND if so exhausts the fuel so that they are not expanded again -pendingScDict_maybe (CDictCan dict@(DictCt { di_pend_sc = f })) - | pendingFuel f = Just (CDictCan (dict { di_pend_sc = doNotExpand })) - | otherwise = Nothing -pendingScDict_maybe _ = Nothing - -pendingScInst_maybe :: QCInst -> Maybe QCInst --- Same as isPendingScDict, but for QCInsts -pendingScInst_maybe qci@(QCI { qci_pend_sc = f }) - | pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) - | otherwise = Nothing - -superClassesMightHelp :: WantedConstraints -> Bool --- ^ True if taking superclasses of givens, or of wanteds (to perhaps --- expose more equalities or functional dependencies) might help to --- solve this constraint. See Note [When superclasses help] -superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) - = anyBag might_help_ct simples || anyBag might_help_implic implics - where - might_help_implic ic - | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) - | otherwise = False - - might_help_ct ct = not (is_ip ct) - - is_ip (CDictCan (DictCt { di_cls = cls })) = isIPClass cls - is_ip _ = False - -getPendingWantedScs :: Cts -> ([Ct], Cts) --- in the return values [Ct] has original fuel while Cts has fuel exhausted -getPendingWantedScs simples - = mapAccumBagL get [] simples - where - get acc ct | Just ct_exhausted <- pendingScDict_maybe ct - = (ct:acc, ct_exhausted) - | otherwise - = (acc, ct) - -{- Note [When superclasses help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First read Note [The superclass story] in GHC.Tc.Solver.Dict - -We expand superclasses and iterate only if there is at unsolved wanted -for which expansion of superclasses (e.g. from given constraints) -might actually help. The function superClassesMightHelp tells if -doing this superclass expansion might help solve this constraint. -Note that - - * We look inside implications; maybe it'll help to expand the Givens - at level 2 to help solve an unsolved Wanted buried inside an - implication. E.g. - forall a. Ord a => forall b. [W] Eq a - - * We say "no" for implicit parameters. - we have [W] ?x::ty, expanding superclasses won't help: - - Superclasses can't be implicit parameters - - If we have a [G] ?x:ty2, then we'll have another unsolved - [W] ty ~ ty2 (from the functional dependency) - which will trigger superclass expansion. - - It's a bit of a special case, but it's easy to do. The runtime cost - is low because the unsolved set is usually empty anyway (errors - aside), and the first non-implicit-parameter will terminate the search. - - The special case is worth it (#11480, comment:2) because it - applies to CallStack constraints, which aren't type errors. If we have - f :: (C a) => blah - f x = ...undefined... - we'll get a CallStack constraint. If that's the only unsolved - constraint it'll eventually be solved by defaulting. So we don't - want to emit warnings about hitting the simplifier's iteration - limit. A CallStack constraint really isn't an unsolved - constraint; it can always be solved by defaulting. --} - -singleCt :: Ct -> Cts -singleCt = unitBag - -andCts :: Cts -> Cts -> Cts -andCts = unionBags - -listToCts :: [Ct] -> Cts -listToCts = listToBag - -ctsElts :: Cts -> [Ct] -ctsElts = bagToList - -consCts :: Ct -> Cts -> Cts -consCts = consBag - -snocCts :: Cts -> Ct -> Cts -snocCts = snocBag - -extendCtsList :: Cts -> [Ct] -> Cts -extendCtsList cts xs | null xs = cts - | otherwise = cts `unionBags` listToBag xs - -emptyCts :: Cts -emptyCts = emptyBag - -isEmptyCts :: Cts -> Bool -isEmptyCts = isEmptyBag - -ctsPreds :: Cts -> [PredType] -ctsPreds cts = foldr ((:) . ctPred) [] cts - -{- -************************************************************************ -* * - Wanted constraints -* * -************************************************************************ --} - -data WantedConstraints - = WC { wc_simple :: Cts -- Unsolved constraints, all wanted - , wc_impl :: Bag Implication - , wc_errors :: Bag DelayedError - } - -emptyWC :: WantedConstraints -emptyWC = WC { wc_simple = emptyBag - , wc_impl = emptyBag - , wc_errors = emptyBag } - -mkSimpleWC :: [CtEvidence] -> WantedConstraints -mkSimpleWC cts - = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) } - -mkImplicWC :: Bag Implication -> WantedConstraints -mkImplicWC implic - = emptyWC { wc_impl = implic } - -isEmptyWC :: WantedConstraints -> Bool -isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors }) - = isEmptyBag f && isEmptyBag i && isEmptyBag errors - --- | Checks whether a the given wanted constraints are solved, i.e. --- that there are no simple constraints left and all the implications --- are solved. -isSolvedWC :: WantedConstraints -> Bool -isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_errors = errors} = - isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag errors - -andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints -andWC (WC { wc_simple = f1, wc_impl = i1, wc_errors = e1 }) - (WC { wc_simple = f2, wc_impl = i2, wc_errors = e2 }) - = WC { wc_simple = f1 `unionBags` f2 - , wc_impl = i1 `unionBags` i2 - , wc_errors = e1 `unionBags` e2 } - -unionsWC :: [WantedConstraints] -> WantedConstraints -unionsWC = foldr andWC emptyWC - -addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints -addSimples wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -- Consider: Put the new constraints at the front, so they get solved first - -addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints -addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } - -addInsols :: WantedConstraints -> Bag IrredCt -> WantedConstraints -addInsols wc insols - = wc { wc_simple = wc_simple wc `unionBags` fmap CIrredCan insols } - -addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints -addHoles wc holes - = wc { wc_errors = mapBag DE_Hole holes `unionBags` wc_errors wc } - -addNotConcreteError :: WantedConstraints -> NotConcreteError -> WantedConstraints -addNotConcreteError wc err - = wc { wc_errors = unitBag (DE_NotConcrete err) `unionBags` wc_errors wc } - -addDelayedErrors :: WantedConstraints -> Bag DelayedError -> WantedConstraints -addDelayedErrors wc errs - = wc { wc_errors = errs `unionBags` wc_errors wc } - -dropMisleading :: WantedConstraints -> WantedConstraints --- Drop misleading constraints; really just class constraints --- See Note [Constraints and errors] in GHC.Tc.Utils.Monad --- for why this function is so strange, treating the 'simples' --- and the implications differently. Sigh. -dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors }) - = WC { wc_simple = filterBag insolubleWantedCt simples - , wc_impl = mapBag drop_implic implics - , wc_errors = filterBag keep_delayed_error errors } - where - drop_implic implic - = implic { ic_wanted = drop_wanted (ic_wanted implic) } - drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors }) - = WC { wc_simple = filterBag keep_ct simples - , wc_impl = mapBag drop_implic implics - , wc_errors = filterBag keep_delayed_error errors } - - keep_ct ct = case classifyPredType (ctPred ct) of - ClassPred {} -> False - _ -> True - - keep_delayed_error (DE_Hole hole) = isOutOfScopeHole hole - keep_delayed_error (DE_NotConcrete {}) = True - -isSolvedStatus :: ImplicStatus -> Bool -isSolvedStatus (IC_Solved {}) = True -isSolvedStatus _ = False - -isInsolubleStatus :: ImplicStatus -> Bool -isInsolubleStatus IC_Insoluble = True -isInsolubleStatus IC_BadTelescope = True -isInsolubleStatus _ = False - -insolubleImplic :: Implication -> Bool -insolubleImplic ic = isInsolubleStatus (ic_status ic) - --- | Gather all the type variables from 'WantedConstraints' --- that it would be unhelpful to default. For the moment, --- these are only 'ConcreteTv' metavariables participating --- in a nominal equality whose other side is not concrete; --- it's usually better to report those as errors instead of --- defaulting. -nonDefaultableTyVarsOfWC :: WantedConstraints -> TyCoVarSet --- Currently used in simplifyTop and in tcRule. --- TODO: should we also use this in decideQuantifiedTyVars, kindGeneralize{All,Some}? -nonDefaultableTyVarsOfWC (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs }) - = concatMapBag non_defaultable_tvs_of_ct simples - `unionVarSet` concatMapBag (nonDefaultableTyVarsOfWC . ic_wanted) implics - `unionVarSet` concatMapBag non_defaultable_tvs_of_err errs - where - - concatMapBag :: (a -> TyVarSet) -> Bag a -> TyCoVarSet - concatMapBag f = foldr (\ r acc -> f r `unionVarSet` acc) emptyVarSet - - -- Don't default ConcreteTv metavariables involved - -- in an equality with something non-concrete: it's usually - -- better to report the unsolved Wanted. - -- - -- Example: alpha[conc] ~# rr[sk]. - non_defaultable_tvs_of_ct :: Ct -> TyCoVarSet - non_defaultable_tvs_of_ct ct = - -- NB: using classifyPredType instead of inspecting the Ct - -- so that we deal uniformly with CNonCanonical (which come up in tcRule), - -- CEqCan (unsolved but potentially soluble, e.g. @alpha[conc] ~# RR@) - -- and CIrredCan. - case classifyPredType $ ctPred ct of - EqPred NomEq lhs rhs - | Just tv <- getTyVar_maybe lhs - , isConcreteTyVar tv - , not (isConcreteType rhs) - -> unitVarSet tv - | Just tv <- getTyVar_maybe rhs - , isConcreteTyVar tv - , not (isConcreteType lhs) - -> unitVarSet tv - _ -> emptyVarSet - - -- Make sure to apply the same logic as above to delayed errors. - non_defaultable_tvs_of_err (DE_NotConcrete err) - = case err of - NCE_FRR { nce_frr_origin = frr } -> tyCoVarsOfType (frr_type frr) - non_defaultable_tvs_of_err (DE_Hole {}) = emptyVarSet - -insolubleWC :: WantedConstraints -> Bool -insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) - = anyBag insolubleWantedCt simples - -- insolubleWantedCt: wanteds only: see Note [Given insolubles] - || anyBag insolubleImplic implics - || anyBag is_insoluble errors - where - is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] - is_insoluble (DE_NotConcrete {}) = True - -insolubleWantedCt :: Ct -> Bool --- Definitely insoluble, in particular /excluding/ type-hole constraints --- Namely: --- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either --- - an insoluble equality constraint (e.g. Int ~ Bool), or --- - a custom type error constraint, TypeError msg :: Constraint --- b) that does not arise from a Given or a Wanted/Wanted fundep interaction --- See Note [Insoluble Wanteds] -insolubleWantedCt ct - | CIrredCan ir_ct <- ct - -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] - , IrredCt { ir_ev = ev } <- ir_ct - , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ev - -- It's a Wanted - , insolubleIrredCt ir_ct - -- It's insoluble - , isEmptyRewriterSet rewriters - -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] - , not (isGivenLoc loc) - -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] - , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) - -- origin check: see (IW4) in Note [Insoluble Wanteds] - = True - - | otherwise - = False - --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt; all insoluble constraints --- are put into CIrredCan -insolubleCt :: Ct -> Bool -insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleCt _ = False - -insolubleIrredCt :: IrredCt -> Bool --- Returns True of Irred constraints that are /definitely/ insoluble --- --- This function is critical for accurate pattern-match overlap warnings. --- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver --- --- Note that this does not traverse through the constraint to find --- nested custom type errors: it only detects @TypeError msg :: Constraint@, --- and not e.g. @Eq (TypeError msg)@. -insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) - = isInsolubleReason reason - || isTopLevelUserTypeError (ctEvPred ev) - -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" - -- and "Unsatisfiable msg". It deliberately does not detect TypeError - -- nested in a type (e.g. it does not use "containsUserTypeError"), as that - -- would be too eager: the TypeError might appear inside a type family - -- application which might later reduce, but we only want to return 'True' - -- for constraints that are definitely insoluble. - -- - -- For example: Num (F Int (TypeError "msg")), where F is a type family. - -- - -- Test case: T11503, with the 'Assert' type family: - -- - -- > type Assert :: Bool -> Constraint -> Constraint - -- > type family Assert check errMsg where - -- > Assert 'True _errMsg = () - -- > Assert _check errMsg = errMsg - --- | Does this hole represent an "out of scope" error? --- See Note [Insoluble holes] -isOutOfScopeHole :: Hole -> Bool -isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) - -instance Outputable WantedConstraints where - ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e}) - = text "WC" <+> braces (vcat - [ ppr_bag (text "wc_simple") s - , ppr_bag (text "wc_impl") i - , ppr_bag (text "wc_errors") e ]) - -ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc -ppr_bag doc bag - | isEmptyBag bag = empty - | otherwise = hang (doc <+> equals) - 2 (foldr (($$) . ppr) empty bag) - -{- Note [Given insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14325, comment:) - class (a~b) => C a b - - foo :: C a c => a -> c - foo x = x - - hm3 :: C (f b) b => b -> f b - hm3 x = foo x - -In the RHS of hm3, from the [G] C (f b) b we get the insoluble -[G] f b ~# b. Then we also get an unsolved [W] C b (f b). -Residual implication looks like - forall b. C (f b) b => [G] f b ~# b - [W] C f (f b) - -We do /not/ want to set the implication status to IC_Insoluble, -because that'll suppress reports of [W] C b (f b). But we -may not report the insoluble [G] f b ~# b either (see Note [Given errors] -in GHC.Tc.Errors), so we may fail to report anything at all! Yikes. - -Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) - should ignore givens even if they are insoluble. - -Note [Insoluble Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~ -insolubleWantedCt returns True of a Wanted constraint that definitely -can't be solved. But not quite all such constraints; see wrinkles. - -(IW1) insolubleWantedCt is tuned for application /after/ constraint - solving i.e. assuming canonicalisation has been done. That's why - it looks only for IrredCt; all insoluble constraints are put into - CIrredCan - -(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note - [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A - that is /not/ insoluble rewrites some other Wanted constraint B, so B has A - in its rewriter set. Now B looks insoluble. The danger is that we'll - suppress reporting B because of its empty rewriter set; and suppress - reporting A because there is an insoluble B lying around. (This suppression - happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. - -(IW3) If the Wanted arises from a Given (how can that happen?), don't - treat it as a Wanted insoluble (obviously). - -(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't - treat the constraint as insoluble. See Note [Suppressing confusing errors] - in GHC.Tc.Errors - -Note [Insoluble holes] -~~~~~~~~~~~~~~~~~~~~~~ -Hole constraints that ARE NOT treated as truly insoluble: - a) type holes, arising from PartialTypeSignatures, - b) "true" expression holes arising from TypedHoles - -An "expression hole" or "type hole" isn't really an error -at all; it's a report saying "_ :: Int" here. But an out-of-scope -variable masquerading as expression holes IS treated as truly -insoluble, so that it trumps other errors during error reporting. -Yuk! - -************************************************************************ -* * - Implication constraints -* * -************************************************************************ --} - -data Implication - = Implic { -- Invariants for a tree of implications: - -- see TcType Note [TcLevel invariants] - - ic_tclvl :: TcLevel, -- TcLevel of unification variables - -- allocated /inside/ this implication - - ic_info :: SkolemInfoAnon, -- See Note [Skolems in an implication] - -- See Note [Shadowing in a constraint] - - ic_skols :: [TcTyVar], -- Introduced skolems; always skolem TcTyVars - -- Their level numbers should be precisely ic_tclvl - -- Their SkolemInfo should be precisely ic_info (almost) - -- See Note [Implication invariants] - - ic_given :: [EvVar], -- Given evidence variables - -- (order does not matter) - -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType - - ic_given_eqs :: HasGivenEqs, -- Are there Given equalities here? - - ic_warn_inaccessible :: Bool, - -- True <=> we should report inaccessible code - -- Note [Avoid -Winaccessible-code when deriving] - -- in GHC.Tc.TyCl.Instance - - ic_env :: !CtLocEnv, - -- Records the context at the time of creation. - -- - -- This provides all the information needed about - -- the context to report the source of errors linked - -- to this implication. - - ic_wanted :: WantedConstraints, -- The wanteds - -- See Invariant (WantedInf) in GHC.Tc.Utils.TcType - - ic_binds :: EvBindsVar, -- Points to the place to fill in the - -- abstraction and bindings. - - -- The ic_need fields keep track of which Given evidence - -- is used by this implication or its children - -- NB: including stuff used by nested implications that have since - -- been discarded - -- See Note [Needed evidence variables] - -- and (RC2) in Note [Tracking redundant constraints]a - ic_need_inner :: VarSet, -- Includes all used Given evidence - ic_need_outer :: VarSet, -- Includes only the free Given evidence - -- i.e. ic_need_inner after deleting - -- (a) givens (b) binders of ic_binds - - ic_status :: ImplicStatus - } - -implicationPrototype :: CtLocEnv -> Implication -implicationPrototype ct_loc_env - = Implic { -- These fields must be initialised - ic_tclvl = panic "newImplic:tclvl" - , ic_binds = panic "newImplic:binds" - , ic_info = panic "newImplic:info" - , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" - - , ic_env = ct_loc_env - -- The rest have sensible default values - , ic_skols = [] - , ic_given = [] - , ic_wanted = emptyWC - , ic_given_eqs = MaybeGivenEqs - , ic_status = IC_Unsolved - , ic_need_inner = emptyVarSet - , ic_need_outer = emptyVarSet } - -data ImplicStatus - = IC_Solved -- All wanteds in the tree are solved, all the way down - { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed - -- See Note [Tracking redundant constraints] in GHC.Tc.Solver - - | IC_Insoluble -- At least one insoluble Wanted constraint in the tree - - | IC_BadTelescope -- Solved, but the skolems in the telescope are out of - -- dependency order. See Note [Checking telescopes] - - | IC_Unsolved -- Neither of the above; might go either way - -data HasGivenEqs -- See Note [HasGivenEqs] - = NoGivenEqs -- Definitely no given equalities, - -- except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet - | LocalGivenEqs -- Might have Given equalities, but only ones that affect only - -- local skolems e.g. forall a b. (a ~ F b) => ... - | MaybeGivenEqs -- Might have any kind of Given equalities; no floating out - -- is possible. - deriving Eq - -type UserGiven = Implication - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) - -{- Note [HasGivenEqs] -~~~~~~~~~~~~~~~~~~~~~ -The GivenEqs data type describes the Given constraints of an implication constraint: - -* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems - which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet - Examples: forall a. Eq a => ... - forall a. (Show a, Num a) => ... - forall a. a ~ Either Int Bool => ... -- Let-bound skolem - -* LocalGivenEqs: definitely no Given equalities that would affect principal - types. But may have equalities that affect only skolems of this implication - (and hence do not affect principal types) - Examples: forall a. F a ~ Int => ... - forall a b. F a ~ G b => ... - -* MaybeGivenEqs: may have Given equalities that would affect principal - types - Examples: forall. (a ~ b) => ... - forall a. F a ~ b => ... - forall a. c a => ... -- The 'c' might be instantiated to (b ~) - forall a. C a b => .... - where class x~y => C a b - so there is an equality in the superclass of a Given - -The HasGivenEqs classifications affect two things: - -* Suppressing redundant givens during error reporting; see GHC.Tc.Errors - Note [Suppress redundant givens during error reporting] - -* Floating in approximateWC. - -Specifically, here's how it goes: - - Stops floating | Suppresses Givens in errors - in approximateWC | - ----------------------------------------------- - NoGivenEqs NO | YES - LocalGivenEqs NO | NO - MaybeGivenEqs YES | NO --} - -instance Outputable Implication where - ppr (Implic { ic_tclvl = tclvl, ic_skols = skols - , ic_given = given, ic_given_eqs = given_eqs - , ic_wanted = wanted, ic_status = status - , ic_binds = binds - , ic_need_inner = need_in, ic_need_outer = need_out - , ic_info = info }) - = hang (text "Implic" <+> lbrace) - 2 (sep [ text "TcLevel =" <+> ppr tclvl - , text "Skolems =" <+> pprTyVars skols - , text "Given-eqs =" <+> ppr given_eqs - , text "Status =" <+> ppr status - , hang (text "Given =") 2 (pprEvVars given) - , hang (text "Wanted =") 2 (ppr wanted) - , text "Binds =" <+> ppr binds - , whenPprDebug (text "Needed inner =" <+> ppr need_in) - , whenPprDebug (text "Needed outer =" <+> ppr need_out) - , pprSkolInfo info ] <+> rbrace) - -instance Outputable ImplicStatus where - ppr IC_Insoluble = text "Insoluble" - ppr IC_BadTelescope = text "Bad telescope" - ppr IC_Unsolved = text "Unsolved" - ppr (IC_Solved { ics_dead = dead }) - = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) - -checkTelescopeSkol :: SkolemInfoAnon -> Bool --- See Note [Checking telescopes] -checkTelescopeSkol (ForAllSkol {}) = True -checkTelescopeSkol _ = False - -instance Outputable HasGivenEqs where - ppr NoGivenEqs = text "NoGivenEqs" - ppr LocalGivenEqs = text "LocalGivenEqs" - ppr MaybeGivenEqs = text "MaybeGivenEqs" - --- Used in GHC.Tc.Solver.Monad.getHasGivenEqs -instance Semigroup HasGivenEqs where - NoGivenEqs <> other = other - other <> NoGivenEqs = other - - MaybeGivenEqs <> _other = MaybeGivenEqs - _other <> MaybeGivenEqs = MaybeGivenEqs - - LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs - --- Used in GHC.Tc.Solver.Monad.getHasGivenEqs -instance Monoid HasGivenEqs where - mempty = NoGivenEqs - -{- Note [Checking telescopes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When kind-checking a /user-written/ type, we might have a "bad telescope" -like this one: - data SameKind :: forall k. k -> k -> Type - type Foo :: forall a k (b :: k). SameKind a b -> Type - -The kind of 'a' mentions 'k' which is bound after 'a'. Oops. - -One approach to doing this would be to bring each of a, k, and b into -scope, one at a time, creating a separate implication constraint for -each one, and bumping the TcLevel. This would work, because the kind -of, say, a would be untouchable when k is in scope (and the constraint -couldn't float out because k blocks it). However, it leads to terrible -error messages, complaining about skolem escape. While it is indeed a -problem of skolem escape, we can do better. - -Instead, our approach is to bring the block of variables into scope -all at once, creating one implication constraint for the lot: - -* We make a single implication constraint when kind-checking - the 'forall' in Foo's kind, something like - forall a k (b::k). { wanted constraints } - -* Having solved {wanted}, before discarding the now-solved implication, - the constraint solver checks the dependency order of the skolem - variables (ic_skols). This is done in setImplicationStatus. - -* This check is only necessary if the implication was born from a - 'forall' in a user-written signature (the HsForAllTy case in - GHC.Tc.Gen.HsType. If, say, it comes from checking a pattern match - that binds existentials, where the type of the data constructor is - known to be valid (it in tcConPat), no need for the check. - - So the check is done /if and only if/ ic_info is ForAllSkol. - -* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the - original, user-written type variables. - -* Be careful /NOT/ to discard an implication with a ForAllSkol - ic_info, even if ic_wanted is empty. We must give the - constraint solver a chance to make that bad-telescope test! Hence - the extra guard in emitResidualTvConstraint; see #16247 - -* Don't mix up inferred and explicit variables in the same implication - constraint. E.g. - foo :: forall a kx (b :: kx). SameKind a b - We want an implication - Implic { ic_skol = [(a::kx), kx, (b::kx)], ... } - but GHC will attempt to quantify over kx, since it is free in (a::kx), - and it's hopelessly confusing to report an error about quantified - variables kx (a::kx) kx (b::kx). - Instead, the outer quantification over kx should be in a separate - implication. TL;DR: an explicit forall should generate an implication - quantified only over those explicitly quantified variables. - -Note [Needed evidence variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Th ic_need_evs field holds the free vars of ic_binds, and all the -ic_binds in nested implications. - - * Main purpose: if one of the ic_givens is not mentioned in here, it - is redundant. - - * solveImplication may drop an implication altogether if it has no - remaining 'wanteds'. But we still track the free vars of its - evidence binds, even though it has now disappeared. - -Note [Shadowing in a constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We assume NO SHADOWING in a constraint. Specifically - * The unification variables are all implicitly quantified at top - level, and are all unique - * The skolem variables bound in ic_skols are all fresh when the - implication is created. -So we can safely substitute. For example, if we have - forall a. a~Int => ...(forall b. ...a...)... -we can push the (a~Int) constraint inwards in the "givens" without -worrying that 'b' might clash. - -Note [Skolems in an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The skolems in an implication are used: - -* When considering floating a constraint outside the implication in - GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications - For this, we can treat ic_skols as a set. - -* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs) - has its variables in the correct order; see Note [Checking telescopes]. - Only for these implications does ic_skols need to be a list. - -Nota bene: Although ic_skols is a list, it is not necessarily -in dependency order: -- In the ic_info=ForAllSkol case, the user might have written them - in the wrong order -- In the case of a type signature like - f :: [a] -> [b] - the renamer gathers the implicit "outer" forall'd variables {a,b}, but - does not know what order to put them in. The type checker can sort them - into dependency order, but only after solving all the kind constraints; - and to do that it's convenient to create the Implication! - -So we accept that ic_skols may be out of order. Think of it as a set or -(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly -wrong, order. - -Note [Insoluble constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the errors that we get during canonicalization are best -reported when all constraints have been simplified as much as -possible. For instance, assume that during simplification the -following constraints arise: - - [Wanted] F alpha ~ uf1 - [Wanted] beta ~ uf1 beta - -When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail -we will simply see a message: - 'Can't construct the infinite type beta ~ uf1 beta' -and the user has no idea what the uf1 variable is. - -Instead our plan is that we will NOT fail immediately, but: - (1) Record the "frozen" error in the ic_insols field - (2) Isolate the offending constraint from the rest of the inerts - (3) Keep on simplifying/canonicalizing - -At the end, we will hopefully have substituted uf1 := F alpha, and we -will be able to report a more informative error: - 'Can't construct the infinite type beta ~ F alpha beta' - -************************************************************************ -* * - Invariant checking (debug only) -* * -************************************************************************ - -Note [Implication invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The skolems of an implication have the following invariants, which are checked -by checkImplicationInvariants: - -a) They are all SkolemTv TcTyVars; no TyVars, no unification variables -b) Their TcLevel matches the ic_lvl for the implication -c) Their SkolemInfo matches the implication. - -Actually (c) is not quite true. Consider - data T a = forall b. MkT a b - -In tcConDecl for MkT we'll create an implication with ic_info of -DataConSkol; but the type variable 'a' will have a SkolemInfo of -TyConSkol. So we allow the tyvar to have a SkolemInfo of TyConFlav if -the implication SkolemInfo is DataConSkol. --} - -checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m () -{-# INLINE checkImplicationInvariants #-} --- Nothing => OK, Just doc => doc gives info -checkImplicationInvariants implic = when debugIsOn (check_implic implic) - -check_implic implic@(Implic { ic_tclvl = lvl - , ic_info = skol_info - , ic_skols = skols }) - | null bads = pure () - | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure" - , nest 2 (vcat bads) - , ppr implic ]) - where - bads = mapMaybe check skols - - check :: TcTyVar -> Maybe SDoc - check tv | not (isTcTyVar tv) - = Just (ppr tv <+> text "is not a TcTyVar") - | otherwise - = check_details tv (tcTyVarDetails tv) - - check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc - check_details tv (SkolemTv tv_skol_info tv_lvl _) - | not (tv_lvl == lvl) - = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl - , text "ic_lvl" <+> ppr lvl ]) - | not (skol_info `checkSkolInfoAnon` skol_info_anon) - = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon - , text "ic_info" <+> ppr skol_info ]) - | otherwise - = Nothing - where - skol_info_anon = getSkolemInfo tv_skol_info - check_details tv details - = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details) - -checkSkolInfoAnon :: SkolemInfoAnon -- From the implication - -> SkolemInfoAnon -- From the type variable - -> Bool -- True <=> ok --- Used only for debug-checking; checkImplicationInvariants --- So it doesn't matter much if its's incomplete -checkSkolInfoAnon sk1 sk2 = go sk1 sk2 - where - go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 - go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2 - - go (ForAllSkol _) (ForAllSkol _) = True - - go (IPSkol ips1) (IPSkol ips2) = ips1 == ips2 - go (DerivSkol pred1) (DerivSkol pred2) = pred1 `tcEqType` pred2 - go (TyConSkol f1 n1) (TyConSkol f2 n2) = f1==f2 && n1==n2 - go (DataConSkol n1) (DataConSkol n2) = n1==n2 - go (InstSkol {}) (InstSkol {}) = True - go FamInstSkol FamInstSkol = True - go BracketSkol BracketSkol = True - go (RuleSkol n1) (RuleSkol n2) = n1==n2 - go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2 - -- Too tedious to compare the HsMatchContexts - go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 && - and (zipWith eq_pr ids1 ids2) - go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 - go ReifySkol ReifySkol = True - go RuntimeUnkSkol RuntimeUnkSkol = True - go ArrowReboundIfSkol ArrowReboundIfSkol = True - go (UnkSkol _) (UnkSkol _) = True - - -------- Three slightly strange special cases -------- - go (DataConSkol _) (TyConSkol f _) = h98_data_decl f - -- In the H98 declaration data T a = forall b. MkT a b - -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of - -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol - - go (DataConSkol _) FamInstSkol = True - -- In data/newtype instance T a = MkT (a -> a), - -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of - -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol - - go FamInstSkol (InstSkol {}) = True - -- In instance C (T a) where { type F (T a) b = ... } - -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi - -- SkolemInfo of FamInstSkol. Very like the ConDecl/TyConSkol case - - go (ForAllSkol _) _ = True - -- Telescope tests: we need a ForAllSkol to force the telescope - -- test, but the skolems might come from (say) a family instance decl - -- type instance forall a. F [a] = a->a - - go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f - -- e.g. newtype T a = MkT ... deriving blah - -- We use the skolems from T (TyConSkol) when typechecking - -- the deriving clauses (SigTypeSkol DerivClauseCtxt) - - go _ _ = False - - eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool - eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked - - h98_data_decl DataTypeFlavour = True - h98_data_decl NewtypeFlavour = True - h98_data_decl _ = False - - -{- ********************************************************************* -* * - Pretty printing -* * -********************************************************************* -} - -pprEvVars :: [EvVar] -> SDoc -- Print with their types -pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) - -pprEvVarTheta :: [EvVar] -> SDoc -pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) - -pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) - - - -wrapType :: Type -> [TyVar] -> [PredType] -> Type -wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty - - -{- -************************************************************************ -* * - CtEvidence -* * -************************************************************************ - -Note [CtEvidence invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The `ctev_pred` field of a `CtEvidence` is a just a cache for the type -of the evidence. More precisely: - -* For Givens, `ctev_pred` = `varType ctev_evar` -* For Wanteds, `ctev_pred` = `evDestType ctev_dest` - -where - - evDestType :: TcEvDest -> TcType - evDestType (EvVarDest evVar) = varType evVar - evDestType (HoleDest coercionHole) = varType (coHoleCoVar coercionHole) - -The invariant is maintained by `setCtEvPredType`, the only function that -updates the `ctev_pred` field of a `CtEvidence`. - -Why is the invariant important? Because when the evidence is a coercion, it may -be used in (CastTy ty co); and then we may call `typeKind` on that type (e.g. -in the kind-check of `eqType`); and expect to see a fully zonked kind. -(This came up in test T13333, in the MR that fixed #20641, namely !6942.) - -Historical Note [Evidence field of CtEvidence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the past we tried leaving the `ctev_evar`/`ctev_dest` field of a -constraint untouched (and hence un-zonked) on the grounds that it is -never looked at. But in fact it is: the evidence can become part of a -type (via `CastTy ty kco`) and we may later ask the kind of that type -and expect a zonked result. (For example, in the kind-check -of `eqType`.) - -The safest thing is simply to keep `ctev_evar`/`ctev_dest` in sync -with `ctev_pref`, as stated in `Note [CtEvidence invariants]`. - -Note [Bind new Givens immediately] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For Givens we make new EvVars and bind them immediately. Two main reasons: - * Gain sharing. E.g. suppose we start with g :: C a b, where - class D a => C a b - class (E a, F a) => D a - If we generate all g's superclasses as separate EvTerms we might - get selD1 (selC1 g) :: E a - selD2 (selC1 g) :: F a - selC1 g :: D a - which we could do more economically as: - g1 :: D a = selC1 g - g2 :: E a = selD1 g1 - g3 :: F a = selD2 g1 - - * For *coercion* evidence we *must* bind each given: - class (a~b) => C a b where .... - f :: C a b => .... - Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. - But that superclass selector can't (yet) appear in a coercion - (see evTermCoercion), so the easy thing is to bind it to an Id. - -So a Given has EvVar inside it rather than (as previously) an EvTerm. - --} - --- | A place for type-checking evidence to go after it is generated. --- --- - Wanted equalities use HoleDest, --- - other Wanteds use EvVarDest. -data TcEvDest - = EvVarDest EvVar -- ^ bind this var to the evidence - -- EvVarDest is always used for non-type-equalities - -- e.g. class constraints - - | HoleDest CoercionHole -- ^ fill in this hole with the evidence - -- HoleDest is always used for type-equalities - -- See Note [Coercion holes] in GHC.Core.TyCo.Rep - -data CtEvidence - = CtGiven -- Truly given, not depending on subgoals - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_evar :: EvVar -- See Note [CtEvidence invariants] - , ctev_loc :: CtLoc } - - - | CtWanted -- Wanted goal - { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] - , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants] - , ctev_loc :: CtLoc - , ctev_rewriters :: RewriterSet } -- See Note [Wanteds rewrite Wanteds] - -ctEvPred :: CtEvidence -> TcPredType --- The predicate of a flavor -ctEvPred = ctev_pred - -ctEvLoc :: CtEvidence -> CtLoc -ctEvLoc = ctev_loc - -ctEvOrigin :: CtEvidence -> CtOrigin -ctEvOrigin = ctLocOrigin . ctEvLoc - --- | Get the equality relation relevant for a 'CtEvidence' -ctEvEqRel :: CtEvidence -> EqRel -ctEvEqRel = predTypeEqRel . ctEvPred - --- | Get the role relevant for a 'CtEvidence' -ctEvRole :: CtEvidence -> Role -ctEvRole = eqRelRole . ctEvEqRel - -ctEvTerm :: CtEvidence -> EvTerm -ctEvTerm ev = EvExpr (ctEvExpr ev) - --- | Extract the set of rewriters from a 'CtEvidence' --- See Note [Wanteds rewrite Wanteds] --- If the provided CtEvidence is not for a Wanted, just --- return an empty set. -ctEvRewriters :: CtEvidence -> RewriterSet -ctEvRewriters (CtWanted { ctev_rewriters = rewriters }) = rewriters -ctEvRewriters _other = emptyRewriterSet - -ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr -ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) - = Coercion $ ctEvCoercion ev -ctEvExpr ev = evId (ctEvEvId ev) - -ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion -ctEvCoercion (CtGiven { ctev_evar = ev_id }) - = mkCoVarCo ev_id -ctEvCoercion (CtWanted { ctev_dest = dest }) - | HoleDest hole <- dest - = -- ctEvCoercion is only called on type equalities - -- and they always have HoleDests - mkHoleCo hole -ctEvCoercion ev - = pprPanic "ctEvCoercion" (ppr ev) - -ctEvEvId :: CtEvidence -> EvVar -ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev -ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h -ctEvEvId (CtGiven { ctev_evar = ev }) = ev - -ctEvUnique :: CtEvidence -> Unique -ctEvUnique (CtGiven { ctev_evar = ev }) = varUnique ev -ctEvUnique (CtWanted { ctev_dest = dest }) = tcEvDestUnique dest - -tcEvDestUnique :: TcEvDest -> Unique -tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var -tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole) - -setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence -setCtEvLoc ctev loc = ctev { ctev_loc = loc } - --- | Set the type of CtEvidence. --- --- This function ensures that the invariants on 'CtEvidence' hold, by updating --- the evidence and the ctev_pred in sync with each other. --- See Note [CtEvidence invariants]. -setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence -setCtEvPredType old_ctev@(CtGiven { ctev_evar = ev }) new_pred - = old_ctev { ctev_pred = new_pred - , ctev_evar = setVarType ev new_pred } - -setCtEvPredType old_ctev@(CtWanted { ctev_dest = dest }) new_pred - = old_ctev { ctev_pred = new_pred - , ctev_dest = new_dest } - where - new_dest = case dest of - EvVarDest ev -> EvVarDest (setVarType ev new_pred) - HoleDest h -> HoleDest (setCoHoleType h new_pred) - -instance Outputable TcEvDest where - ppr (HoleDest h) = text "hole" <> ppr h - ppr (EvVarDest ev) = ppr ev - -instance Outputable CtEvidence where - ppr ev = ppr (ctEvFlavour ev) - <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters) - -- Show the sub-goal depth too - <> dcolon <+> ppr (ctEvPred ev) - where - pp_ev = case ev of - CtGiven { ctev_evar = v } -> ppr v - CtWanted {ctev_dest = d } -> ppr d - - rewriters = ctEvRewriters ev - pp_rewriters | isEmptyRewriterSet rewriters = empty - | otherwise = semi <> ppr rewriters - -isWanted :: CtEvidence -> Bool -isWanted (CtWanted {}) = True -isWanted _ = False - -isGiven :: CtEvidence -> Bool -isGiven (CtGiven {}) = True -isGiven _ = False - -{- -************************************************************************ -* * - RewriterSet -* * -************************************************************************ --} - --- | Stores a set of CoercionHoles that have been used to rewrite a constraint. --- See Note [Wanteds rewrite Wanteds]. -newtype RewriterSet = RewriterSet (UniqSet CoercionHole) - deriving newtype (Outputable, Semigroup, Monoid) - -emptyRewriterSet :: RewriterSet -emptyRewriterSet = RewriterSet emptyUniqSet - -unitRewriterSet :: CoercionHole -> RewriterSet -unitRewriterSet = coerce (unitUniqSet @CoercionHole) - -unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet -unionRewriterSet = coerce (unionUniqSets @CoercionHole) - -isEmptyRewriterSet :: RewriterSet -> Bool -isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole) - -addRewriter :: RewriterSet -> CoercionHole -> RewriterSet -addRewriter = coerce (addOneToUniqSet @CoercionHole) - -rewriterSetFromCts :: Bag Ct -> RewriterSet --- Take a bag of Wanted equalities, and collect them as a RewriterSet -rewriterSetFromCts cts - = foldr add emptyRewriterSet cts - where - add ct rw_set = case ctEvidence ct of - CtWanted { ctev_dest = HoleDest hole } -> rw_set `addRewriter` hole - _ -> rw_set - -{- -************************************************************************ -* * - CtFlavour -* * -************************************************************************ --} - -data CtFlavour - = Given -- we have evidence - | Wanted -- we want evidence - deriving Eq - -instance Outputable CtFlavour where - ppr Given = text "[G]" - ppr Wanted = text "[W]" - -ctEvFlavour :: CtEvidence -> CtFlavour -ctEvFlavour (CtWanted {}) = Wanted -ctEvFlavour (CtGiven {}) = Given - --- | Whether or not one 'Ct' can rewrite another is determined by its --- flavour and its equality relation. See also --- Note [Flavours with roles] in GHC.Tc.Solver.InertSet -type CtFlavourRole = (CtFlavour, EqRel) - --- | Extract the flavour, role, and boxity from a 'CtEvidence' -ctEvFlavourRole :: CtEvidence -> CtFlavourRole -ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) - --- | Extract the flavour and role from a 'Ct' -eqCtFlavourRole :: EqCt -> CtFlavourRole -eqCtFlavourRole (EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) - = (ctEvFlavour ev, eq_rel) - -dictCtFlavourRole :: DictCt -> CtFlavourRole -dictCtFlavourRole (DictCt { di_ev = ev }) - = (ctEvFlavour ev, NomEq) - --- | Extract the flavour and role from a 'Ct' -ctFlavourRole :: Ct -> CtFlavourRole --- Uses short-cuts to role for special cases -ctFlavourRole (CDictCan di_ct) = dictCtFlavourRole di_ct -ctFlavourRole (CEqCan eq_ct) = eqCtFlavourRole eq_ct -ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct) - -{- Note [eqCanRewrite] -~~~~~~~~~~~~~~~~~~~~~~ -(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form -lhs ~ ty) can be used to rewrite ct2. It must satisfy the properties of -a can-rewrite relation, see Definition [Can-rewrite relation] in -GHC.Tc.Solver.Monad. - -With the solver handling Coercible constraints like equality constraints, -the rewrite conditions must take role into account, never allowing -a representational equality to rewrite a nominal one. - -Note [Wanteds rewrite Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should one Wanted constraint be allowed to rewrite another? - -This example (along with #8450) suggests not: - f :: a -> Bool - f x = ( [x,'c'], [x,True] ) `seq` True -Here we get - [W] a ~ Char - [W] a ~ Bool -but we do not want to complain about Bool ~ Char! - -This example suggests yes (indexed-types/should_fail/T4093a): - type family Foo a - f :: (Foo e ~ Maybe e) => Foo e -In the ambiguity check, we get - [G] g1 :: Foo e ~ Maybe e - [W] w1 :: Foo alpha ~ Foo e - [W] w2 :: Foo alpha ~ Maybe alpha -w1 gets rewritten by the Given to become - [W] w3 :: Foo alpha ~ Maybe e -Now, the only way to make progress is to allow Wanteds to rewrite Wanteds. -Rewriting w3 with w2 gives us - [W] w4 :: Maybe alpha ~ Maybe e -which will soon get us to alpha := e and thence to victory. - -TL;DR we want equality saturation. - -We thus want Wanteds to rewrite Wanteds in order to accept more programs, -but we don't want Wanteds to rewrite Wanteds because doing so can create -inscrutable error messages. To solve this dilemma: - -* We allow Wanteds to rewrite Wanteds, but... - -* Each Wanted tracks the set of Wanteds it has been rewritten by, in its - RewriterSet, stored in the ctev_rewriters field of the CtWanted - constructor of CtEvidence. (Only Wanteds have RewriterSets.) - -* In error reporting, we simply suppress any errors that have been rewritten - by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, - which uses GHC.Tc.Zonk.Type.zonkRewriterSet to look through any filled - coercion holes. The idea is that we wish to report the "root cause" -- the - error that rewrote all the others. - -* We prioritise Wanteds that have an empty RewriterSet: - see Note [Prioritise Wanteds with empty RewriterSet]. - -Let's continue our first example above: - - inert: [W] w1 :: a ~ Char - work: [W] w2 :: a ~ Bool - -Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding - - inert: [W] w1 :: a ~ Char - [W] w2 {w1}:: Char ~ Bool - -The {w1} in the second line of output is the RewriterSet of w1. - -A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient -because only equalities (evidenced by coercion holes) are used for rewriting; -other (dictionary) constraints cannot ever rewrite. The rewriter (in -e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, -consisting of the evidence (a CoercionHole) for any Wanted equalities used in -rewriting. Then GHC.Tc.Solver.Solve.rewriteEvidence and -GHC.Tc.Solver.Equality.rewriteEqEvidence add this RewriterSet to the rewritten -constraint's rewriter set. - -Note [Prioritise Wanteds with empty RewriterSet] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq, -we priorities constraints that have no rewriters. Here's why. - -Consider this, which came up in T22793: - inert: {} - work list: [W] co_ayf : awq ~ awo - work item: [W] co_ayb : awq ~ awp - - ==> {just put work item in inert set} - inert: co_ayb : awq ~ awp - work list: {} - work: [W] co_ayf : awq ~ awo - - ==> {rewrite ayf with co_ayb} - work list: {} - inert: co_ayb : awq ~ awp - co_aym{co_ayb} : awp ~ awo - ^ rewritten by ayb - - ----- start again in simplify_loop in Solver.hs ----- - inert: {} - work list: [W] co_ayb : awq ~ awp - work: co_aym{co_ayb} : awp ~ awo - - ==> {add to inert set} - inert: co_aym{co_ayb} : awp ~ awo - work list: {} - work: co_ayb : awq ~ awp - - ==> {rewrite co_ayb} - inert: co_aym{co_ayb} : awp ~ awo - co_ayp{co_aym} : awq ~ awo - work list: {} - -Now both wanteds have been rewriten by the other! This happened because -in our simplify_loop iteration, we happened to start with co_aym. All would have -been well if we'd started with the (not-rewritten) co_ayb and gotten it into the -inert set. - -With that in mind, we /prioritise/ the work-list to put constraints -with no rewriters first. This prioritisation is done in -GHC.Tc.Solver.InertSet.extendWorkListEq, and extendWorkListEqs. - -Wrinkles - -(WRW1) Before checking for an empty RewriterSet, we zonk the RewriterSet, - because some of those CoercionHoles may have been filled in since we last - looked: see GHC.Tc.Solver.Monad.emitWork. - -(WRW2) Despite the prioritisation, it is hard to be /certain/ that we can't end up - in a situation where all of the Wanteds have rewritten each other. In - order to report /some/ error in this case, we simply report all the - Wanteds. The user will get a perhaps-confusing error message, but they've - written a confusing program! (T22707 and T22793 were close, but they do - not exhibit this behaviour.) So belt and braces: see the `suppress` - stuff in GHC.Tc.Errors.mkErrorItem. - -Note [Avoiding rewriting cycles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes -the can-rewrite relation among CtFlavour/Role pairs, saying which constraints -can rewrite which other constraints. It puts forth (R2): - (R2) If f1 >= f, and f2 >= f, - then either f1 >= f2 or f2 >= f1 -The naive can-rewrite relation says that (Given, Representational) can rewrite -(Wanted, Representational) and that (Wanted, Nominal) can rewrite -(Wanted, Representational), but neither of (Given, Representational) and -(Wanted, Nominal) can rewrite the other. This would violate (R2). See also -Note [Why R2?] in GHC.Tc.Solver.InertSet. - -To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational). -This can, in theory, bite, in this scenario: - - type family F a - data T a - type role T nominal - - [G] F a ~N T a - [W] F alpha ~N T alpha - [W] F alpha ~R T a - -As written, this makes no progress, and GHC errors. But, if we -allowed W/N to rewrite W/R, the first W could rewrite the second: - - [G] F a ~N T a - [W] F alpha ~N T alpha - [W] T alpha ~R T a - -Now we decompose the second W to get - - [W] alpha ~N a - -noting the role annotation on T. This causes (alpha := a), and then -everything else unlocks. - -What to do? We could "decompose" nominal equalities into nominal-only -("NO") equalities and representational ones, where a NO equality rewrites -only nominals. That is, when considering whether [W] F alpha ~N T alpha -should rewrite [W] F alpha ~R T a, we could require splitting the first W -into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R -half of the split to rewrite the second W, and off we go. This splitting -would allow the split-off R equality to be rewritten by other equalities, -thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet. - -However, note that I said that this bites in theory. That's because no -known program actually gives rise to this scenario. A direct encoding -ends up starting with - - [G] F a ~ T a - [W] F alpha ~ T alpha - [W] Coercible (F alpha) (T a) - -where ~ and Coercible denote lifted class constraints. The ~s quickly -reduce to ~N: good. But the Coercible constraint gets rewritten to - - [W] Coercible (T alpha) (T a) - -by the first Wanted. This is because Coercible is a class, and arguments -in class constraints use *nominal* rewriting, not the representational -rewriting that is restricted due to (R2). Note that reordering the code -doesn't help, because equalities (including lifted ones) are prioritized -over Coercible. Thus, I (Richard E.) see no way to write a program that -is rejected because of this infelicity. I have not proved it impossible, -exactly, but my usual tricks have not yielded results. - -In the olden days, when we had Derived constraints, this Note was all -about G/R and D/N both rewriting D/R. Back then, the code in -typecheck/should_compile/T19665 really did get rejected. But now, -according to the rewriting of the Coercible constraint, the program -is accepted. - --} - -eqCanRewrite :: EqRel -> EqRel -> Bool -eqCanRewrite NomEq _ = True -eqCanRewrite ReprEq ReprEq = True -eqCanRewrite ReprEq NomEq = False - -eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool --- Can fr1 actually rewrite fr2? --- Very important function! --- See Note [eqCanRewrite] --- See Note [Wanteds rewrite Wanteds] --- See Note [Avoiding rewriting cycles] -eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 -eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False -eqCanRewriteFR (Wanted, r1) (Wanted, r2) = eqCanRewrite r1 r2 -eqCanRewriteFR (Wanted, _) (Given, _) = False - -{- -************************************************************************ -* * - SubGoalDepth -* * -************************************************************************ - -Note [SubGoalDepth] -~~~~~~~~~~~~~~~~~~~ -The 'SubGoalDepth' takes care of stopping the constraint solver from looping. - -The counter starts at zero and increases. It includes dictionary constraints, -equality simplification, and type family reduction. (Why combine these? Because -it's actually quite easy to mistake one for another, in sufficiently involved -scenarios, like ConstraintKinds.) - -The flag -freduction-depth=n fixes the maximum level. - -* The counter includes the depth of type class instance declarations. Example: - [W] d{7} : Eq [Int] - That is d's dictionary-constraint depth is 7. If we use the instance - $dfEqList :: Eq a => Eq [a] - to simplify it, we get - d{7} = $dfEqList d'{8} - where d'{8} : Eq Int, and d' has depth 8. - - For civilised (decidable) instance declarations, each increase of - depth removes a type constructor from the type, so the depth never - gets big; i.e. is bounded by the structural depth of the type. - -* The counter also increments when resolving -equalities involving type functions. Example: - Assume we have a wanted at depth 7: - [W] d{7} : F () ~ a - If there is a type function equation "F () = Int", this would be rewritten to - [W] d{8} : Int ~ a - and remembered as having depth 8. - - Again, without UndecidableInstances, this counter is bounded, but without it - can resolve things ad infinitum. Hence there is a maximum level. - -* Lastly, every time an equality is rewritten, the counter increases. Again, - rewriting an equality constraint normally makes progress, but it's possible - the "progress" is just the reduction of an infinitely-reducing type family. - Hence we need to track the rewrites. - -When compiling a program requires a greater depth, then GHC recommends turning -off this check entirely by setting -freduction-depth=0. This is because the -exact number that works is highly variable, and is likely to change even between -minor releases. Because this check is solely to prevent infinite compilation -times, it seems safe to disable it when a user has ascertained that their program -doesn't loop at the type level. - --} - --- | See Note [SubGoalDepth] -newtype SubGoalDepth = SubGoalDepth Int - deriving (Eq, Ord, Outputable) - -initialSubGoalDepth :: SubGoalDepth -initialSubGoalDepth = SubGoalDepth 0 - -bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth -bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) - -maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth -maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) - -subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool -subGoalDepthExceeded reductionDepth (SubGoalDepth d) - = mkIntWithInf d > reductionDepth - -{- -************************************************************************ -* * - CtLoc -* * -************************************************************************ - -The 'CtLoc' gives information about where a constraint came from. -This is important for decent error message reporting because -dictionaries don't appear in the original source code. - --} - -data CtLoc = CtLoc { ctl_origin :: CtOrigin - , ctl_env :: CtLocEnv -- Everything we need to know about - -- the context this Ct arose in. - , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure - , ctl_depth :: !SubGoalDepth } - -mkKindEqLoc :: TcType -> TcType -- original *types* being compared - -> CtLoc -> CtLoc -mkKindEqLoc s1 s2 ctloc - | CtLoc { ctl_t_or_k = t_or_k, ctl_origin = origin } <- ctloc - = ctloc { ctl_origin = KindEqOrigin s1 s2 origin t_or_k - , ctl_t_or_k = Just KindLevel } - -adjustCtLocTyConBinder :: TyConBinder -> CtLoc -> CtLoc --- Adjust the CtLoc when decomposing a type constructor -adjustCtLocTyConBinder tc_bndr loc - = adjustCtLoc is_vis is_kind loc - where - is_vis = isVisibleTyConBinder tc_bndr - is_kind = isNamedTyConBinder tc_bndr - -adjustCtLoc :: Bool -- True <=> A visible argument - -> Bool -- True <=> A kind argument - -> CtLoc -> CtLoc --- Adjust the CtLoc when decomposing a type constructor, application, etc -adjustCtLoc is_vis is_kind loc - = loc2 - where - loc1 | is_kind = toKindLoc loc - | otherwise = loc - loc2 | is_vis = loc1 - | otherwise = toInvisibleLoc loc1 - --- | Take a CtLoc and moves it to the kind level -toKindLoc :: CtLoc -> CtLoc -toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } - -toInvisibleLoc :: CtLoc -> CtLoc -toInvisibleLoc loc = updateCtLocOrigin loc toInvisibleOrigin - -mkGivenLoc :: TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc -mkGivenLoc tclvl skol_info env - = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = setCtLocEnvLvl env tclvl - , ctl_t_or_k = Nothing -- this only matters for error msgs - , ctl_depth = initialSubGoalDepth } - -ctLocEnv :: CtLoc -> CtLocEnv -ctLocEnv = ctl_env - -ctLocLevel :: CtLoc -> TcLevel -ctLocLevel loc = getCtLocEnvLvl (ctLocEnv loc) - -ctLocDepth :: CtLoc -> SubGoalDepth -ctLocDepth = ctl_depth - -ctLocOrigin :: CtLoc -> CtOrigin -ctLocOrigin = ctl_origin - -ctLocSpan :: CtLoc -> RealSrcSpan -ctLocSpan (CtLoc { ctl_env = lcl}) = getCtLocEnvLoc lcl - -ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind -ctLocTypeOrKind_maybe = ctl_t_or_k - -setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc -setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setCtLocRealLoc lcl loc) - -bumpCtLocDepth :: CtLoc -> CtLoc -bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } - -setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc -setCtLocOrigin ctl orig = ctl { ctl_origin = orig } - -updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc -updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd - = ctl { ctl_origin = upd orig } - -setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc -setCtLocEnv ctl env = ctl { ctl_env = env } - -pprCtLoc :: CtLoc -> SDoc --- "arising from ... at ..." --- Not an instance of Outputable because of the "arising from" prefix -pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) - = sep [ pprCtOrigin o - , text "at" <+> ppr (getCtLocEnvLoc lcl)] +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} + +-- | This module defines types and simple operations over constraints, as used +-- in the type-checker and constraint solver. +module GHC.Tc.Types.Constraint ( + -- Constraints + Xi, Ct(..), Cts, + singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, + isEmptyCts, emptyCts, andCts, ctsPreds, + isPendingScDictCt, isPendingScDict, pendingScDict_maybe, + superClassesMightHelp, getPendingWantedScs, + isWantedCt, isGivenCt, + isTopLevelUserTypeError, containsUserTypeError, getUserTypeErrorMsg, + isUnsatisfiableCt_maybe, + ctEvidence, updCtEvidence, + ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + ctRewriters, ctHasNoRewriters, wantedCtHasNoRewriters, + ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv, + mkNonCanonical, mkGivens, + tyCoVarsOfCt, tyCoVarsOfCts, + tyCoVarsOfCtList, tyCoVarsOfCtsList, + boundOccNamesOfWC, + + -- Particular forms of constraint + EqCt(..), eqCtEvidence, eqCtLHS, + DictCt(..), dictCtEvidence, dictCtPred, + IrredCt(..), irredCtEvidence, mkIrredCt, ctIrredCt, irredCtPred, + + -- QCInst + QCInst(..), pendingScInst_maybe, + + ExpansionFuel, doNotExpand, consumeFuel, pendingFuel, + assertFuelPrecondition, assertFuelPreconditionStrict, + + CtIrredReason(..), isInsolubleReason, + + CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck, + cteOK, cteImpredicative, cteTypeFamily, + cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble, + cteConcrete, cteSkolemEscape, + impredicativeProblem, insolubleOccursProblem, solubleOccursProblem, + + cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, cterHasOnlyProblems, + cterRemoveProblem, cterHasOccursCheck, cterFromKind, + + -- Equality left-hand sides, re-exported from GHC.Core.Predicate + CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe, + canEqLHSKind, canEqLHSType, eqCanEqLHS, + + -- Holes + Hole(..), HoleSort(..), isOutOfScopeHole, + DelayedError(..), NotConcreteError(..), + + WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, + isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, + addInsols, dropMisleading, addSimples, addImplics, addHoles, + addNotConcreteError, addMultiplicityCoercionError, addDelayedErrors, + tyCoVarsOfWC, tyCoVarsOfWCList, + insolubleWantedCt, insolubleCt, insolubleIrredCt, + insolubleImplic, nonDefaultableTyVarsOfWC, + approximateWCX, approximateWC, + + Implication(..), implicationPrototype, checkTelescopeSkol, + ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + UserGiven, getUserGivensFromImplics, + HasGivenEqs(..), checkImplicationInvariants, + EvNeedSet(..), emptyEvNeedSet, unionEvNeedSet, extendEvNeedSet, delGivensFromEvNeedSet, + + -- CtLocEnv + CtLocEnv(..), setCtLocEnvLoc, setCtLocEnvLvl, getCtLocEnvLoc, getCtLocEnvLvl, ctLocEnvInGeneratedCode, + + -- CtEvidence + CtEvidence(..), TcEvDest(..), + isWanted, isGiven, + ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, + ctEvExpr, ctEvTerm, + ctEvCoercion, givenCtEvCoercion, + ctEvEvId, wantedCtEvEvId, + ctEvRewriters, setWantedCtEvRewriters, ctEvUnique, tcEvDestUnique, + ctEvRewriteRole, ctEvRewriteEqRel, setCtEvPredType, setCtEvLoc, + tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, + + -- CtEvidence constructors + GivenCtEvidence(..), WantedCtEvidence(..), + + -- RewriterSet + RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, + -- exported concretely only for zonkRewriterSet + addRewriter, unitRewriterSet, unionRewriterSet, rewriterSetFromCts, + + wrapType, + + CtFlavour(..), ctEvFlavour, + CtFlavourRole, ctEvFlavourRole, ctFlavourRole, eqCtFlavourRole, + eqCanRewrite, eqCanRewriteFR, + + -- Pretty printing + pprEvVarTheta, + pprEvVars, pprEvVarWithType, + + ) + where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.Predicate +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr + +import GHC.Types.Name +import GHC.Types.Var + +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc + +import GHC.Builtin.Names + +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.Name.Reader + +import GHC.Utils.FV +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import GHC.Data.Bag + +import Data.Coerce +import qualified Data.Semigroup as S +import Control.Monad ( msum, when ) +import Data.Maybe ( mapMaybe, isJust ) + +-- these are for CheckTyEqResult +import Data.Word ( Word8 ) +import Data.List ( intersperse ) + + + +{- +************************************************************************ +* * +* Canonical constraints * +* * +* These are the constraints the low-level simplifier works with * +* * +************************************************************************ +-} + +-- | A 'Xi'-type is one that has been fully rewritten with respect +-- to the inert set; that is, it has been rewritten by the algorithm +-- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years, +-- meant that a type was type-family-free. It does *not* mean this +-- any more.) +type Xi = TcType + +type Cts = Bag Ct + +-- | Says how many layers of superclasses can we expand. +-- Invariant: ExpansionFuel should always be >= 0 +-- see Note [Expanding Recursive Superclasses and ExpansionFuel] +type ExpansionFuel = Int + +-- | Do not expand superclasses any further +doNotExpand :: ExpansionFuel +doNotExpand = 0 + +-- | Consumes one unit of fuel. +-- Precondition: fuel > 0 +consumeFuel :: ExpansionFuel -> ExpansionFuel +consumeFuel fuel = assertFuelPreconditionStrict fuel $ fuel - 1 + +-- | Returns True if we have any fuel left for superclass expansion +pendingFuel :: ExpansionFuel -> Bool +pendingFuel n = n > 0 + +insufficientFuelError :: SDoc +insufficientFuelError = text "Superclass expansion fuel should be > 0" + +-- | asserts if fuel is non-negative +assertFuelPrecondition :: ExpansionFuel -> a -> a +{-# INLINE assertFuelPrecondition #-} +assertFuelPrecondition fuel = assertPpr (fuel >= 0) insufficientFuelError + +-- | asserts if fuel is strictly greater than 0 +assertFuelPreconditionStrict :: ExpansionFuel -> a -> a +{-# INLINE assertFuelPreconditionStrict #-} +assertFuelPreconditionStrict fuel = assertPpr (pendingFuel fuel) insufficientFuelError + +-- | Constraint +data Ct + -- | A dictionary constraint (canonical) + = CDictCan DictCt + -- | An irreducible constraint (non-canonical) + | CIrredCan IrredCt + -- | An equality constraint (canonical) + | CEqCan EqCt + -- | A quantified constraint (canonical) + | CQuantCan QCInst + -- | A non-canonical constraint + -- + -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad + | CNonCanonical CtEvidence + +--------------- DictCt -------------- + +-- | A canonical dictionary constraint +data DictCt -- e.g. Num ty + = DictCt { di_ev :: CtEvidence -- See Note [Ct/evidence invariant] + + , di_cls :: Class + , di_tys :: [Xi] -- di_tys are rewritten w.r.t. inerts, so Xi + + , di_pend_sc :: ExpansionFuel + -- See Note [The superclass story] in GHC.Tc.Solver.Dict + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver + -- Invariants: di_pend_sc > 0 <=> + -- (a) di_cls has superclasses + -- (b) those superclasses are not yet explored + } + +dictCtEvidence :: DictCt -> CtEvidence +dictCtEvidence = di_ev + +dictCtPred :: DictCt -> TcPredType +dictCtPred (DictCt { di_cls = cls, di_tys = tys }) = mkClassPred cls tys + +instance Outputable DictCt where + ppr dict = ppr (CDictCan dict) + +--------------- EqCt -------------- + +{- Note [Canonical equalities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An EqCt is a canonical equality constraint, one that can live in the inert set, +and that can be used to rewrite other constraints. It satisfies these invariants: + + * (TyEq:OC) lhs does not occur in rhs (occurs check) + Note [EqCt occurs check] + + * (TyEq:F) rhs has no foralls + (this avoids substituting a forall for the tyvar in other types) + + * (TyEq:K) typeKind lhs `tcEqKind` typeKind rhs; Note [Ct kind invariant] + + * (TyEq:N) If the equality is representational, rhs is not headed by a saturated + application of a newtype TyCon. See GHC.Tc.Solver.Equality + Note [No top-level newtypes on RHS of representational equalities]. + (Applies only when constructor of newtype is in scope.) + + * (TyEq:U) An EqCt is not immediately unifiable. If we can unify a:=ty, we + will not form an EqCt (a ~ ty). + + * (TyEq:CH) rhs does not mention any coercion holes that resulted from fixing up + a hetero-kinded equality. See Note [Equalities with heterogeneous kinds] in + GHC.Tc.Solver.Equality, wrinkle (EIK2) + +These invariants ensure that the EqCts in inert_eqs constitute a terminating +generalised substitution. See Note [inert_eqs: the inert equalities] +in GHC.Tc.Solver.InertSet for what these words mean! + +Note [EqCt occurs check] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A CEqCan relates a CanEqLHS (a type variable or type family applications) on +its left to an arbitrary type on its right. It is used for rewriting. +Because it is used for rewriting, it would be disastrous if the RHS +were to mention the LHS: this would cause a loop in rewriting. + +We thus perform an occurs-check. There is, of course, some subtlety: + +* For type variables, the occurs-check looks deeply including kinds of + type variables. This is because a CEqCan over a meta-variable is + also used to inform unification, via `checkTyEqRhs`, called in + `canEqCanLHSFinish_try_unification`. + If the LHS appears anywhere in the RHS, at all, unification will create + an infinite structure, which is bad. + +* For type family applications, the occurs-check is shallow; it looks + only in places where we might rewrite. (Specifically, it does not + look in kinds or coercions.) An occurrence of the LHS in, say, an + RHS coercion is OK, as we do not rewrite in coercions. No loop to + be found. + + You might also worry about the possibility that a type family + application LHS doesn't exactly appear in the RHS, but something + that reduces to the LHS does. Yet that can't happen: the RHS is + already inert, with all type family redexes reduced. So a simple + syntactic check is just fine. + +The occurs check is performed in GHC.Tc.Utils.Unify.checkTyEqRhs +and forms condition T3 in Note [Extending the inert equalities] +in GHC.Tc.Solver.InertSet. +-} + +-- | A canonical equality constraint. +-- +-- See Note [Canonical equalities] in GHC.Tc.Types.Constraint. +data EqCt + = EqCt { -- CanEqLHS ~ rhs + eq_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + eq_lhs :: CanEqLHS, + eq_rhs :: Xi, -- See invariants above + eq_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev + } + +eqCtEvidence :: EqCt -> CtEvidence +eqCtEvidence = eq_ev + +eqCtLHS :: EqCt -> CanEqLHS +eqCtLHS = eq_lhs + +--------------- IrredCt -------------- + +data IrredCt -- These stand for yet-unusable predicates + -- See Note [CIrredCan constraints] + = IrredCt { ir_ev :: CtEvidence -- See Note [Ct/evidence invariant] + , ir_reason :: CtIrredReason } + +mkIrredCt :: CtIrredReason -> CtEvidence -> Ct +mkIrredCt reason ev = CIrredCan (IrredCt { ir_ev = ev, ir_reason = reason }) + +irredCtEvidence :: IrredCt -> CtEvidence +irredCtEvidence = ir_ev + +irredCtPred :: IrredCt -> PredType +irredCtPred = ctEvPred . irredCtEvidence + +ctIrredCt :: CtIrredReason -> Ct -> IrredCt +ctIrredCt _ (CIrredCan ir) = ir +ctIrredCt reason ct = IrredCt { ir_ev = ctEvidence ct + , ir_reason = reason } + +instance Outputable IrredCt where + ppr irred = ppr (CIrredCan irred) + +--------------- QCInst -------------- + +-- | A quantified constraint, also called a "local instance" +-- (a simplified version of 'ClsInst'). +-- +-- See Note [Quantified constraints] in GHC.Tc.Solver.Solve +data QCInst + -- | A quantified constraint, of type @forall tvs. context => ty@ + = QCI { qci_ev :: CtEvidence -- See Note [Ct/evidence invariant] + , qci_tvs :: [TcTyVar] -- ^ @tvs@ + , qci_theta :: TcThetaType + , qci_body :: TcPredType -- ^ the body of the @forall@, i.e. @ty@ + , qci_pend_sc :: ExpansionFuel + -- ^ Invariants: qci_pend_sc > 0 => + -- + -- (a) 'qci_body' is a ClassPred + -- (b) this class has superclass(es), and + -- (c) the superclass(es) are not explored yet + -- + -- Same as 'di_pend_sc' flag in 'DictCt' + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] in GHC.Tc.Solver + } + +instance Outputable QCInst where + ppr (QCI { qci_ev = ev }) = ppr ev + +------------------------------------------------------------------------------ +-- +-- Holes and other delayed errors +-- +------------------------------------------------------------------------------ + +-- | A delayed error, to be reported after constraint solving, in order to benefit +-- from deferred unifications. +data DelayedError + = DE_Hole Hole + -- ^ A hole (in a type or in a term). + -- + -- See Note [Holes in expressions]. + | DE_NotConcrete NotConcreteError + -- ^ A type could not be ensured to be concrete. + -- + -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. + | DE_Multiplicity TcCoercion CtLoc + -- ^ An error if the TcCoercion isn't a reflexivity constraint. + -- + -- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. + + +instance Outputable DelayedError where + ppr (DE_Hole hole) = ppr hole + ppr (DE_NotConcrete err) = ppr err + ppr (DE_Multiplicity co _) = ppr co + +-- | A hole stores the information needed to report diagnostics +-- about holes in terms (unbound identifiers or underscores) or +-- in types (also called wildcards, as used in partial type +-- signatures). See Note [Holes in expressions] for holes in terms. +data Hole + = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this? + , hole_occ :: RdrName -- ^ The name of this hole + , hole_ty :: TcType -- ^ Type to be printed to the user + -- For expression holes: type of expr + -- For type holes: the missing type + , hole_loc :: CtLoc -- ^ Where hole was written + } + -- For the hole_loc, we usually only want the TcLclEnv stored within. + -- Except when we rewrite, where we need a whole location. And this + -- might get reported to the user if reducing type families in a + -- hole type loops. + + +-- | Used to indicate which sort of hole we have. +data HoleSort = ExprHole HoleExprRef + -- ^ Either an out-of-scope variable or a "true" hole in an + -- expression (TypedHoles). + -- The HoleExprRef says where to write the + -- the erroring expression for -fdefer-type-errors. + | TypeHole + -- ^ A hole in a type (PartialTypeSignatures) + | ConstraintHole + -- ^ A hole in a constraint, like @f :: (_, Eq a) => ... + -- Differentiated from TypeHole because a ConstraintHole + -- is simplified differently. See + -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver. + +instance Outputable Hole where + ppr (Hole { hole_sort = ExprHole ref + , hole_occ = occ + , hole_ty = ty }) + = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty + ppr (Hole { hole_sort = _other + , hole_occ = occ + , hole_ty = ty }) + = braces $ ppr occ <> colon <> ppr ty + +instance Outputable HoleSort where + ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref + ppr TypeHole = text "TypeHole" + ppr ConstraintHole = text "ConstraintHole" + +-- | Why did we require that a certain type be concrete? +data NotConcreteError + -- | Concreteness was required by a representation-polymorphism + -- check. + -- + -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete. + = NCE_FRR + { nce_loc :: CtLoc + -- ^ Where did this check take place? + , nce_frr_origin :: FixedRuntimeRepOrigin + -- ^ Which representation-polymorphism check did we perform? + } + +instance Outputable NotConcreteError where + ppr (NCE_FRR { nce_frr_origin = frr_orig }) + = text "NCE_FRR" <+> parens (ppr (frr_type frr_orig)) + +------------ +-- | Used to indicate extra information about why a CIrredCan is irreducible +data CtIrredReason + = IrredShapeReason + -- ^ This constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) + + | NonCanonicalReason CheckTyEqResult + -- ^ An equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied; + -- the 'CheckTyEqResult' states exactly why + + | ReprEqReason + -- ^ An equality that cannot be decomposed because it is representational. + -- Example: @a b ~R# Int@. + -- These might still be solved later. + -- INVARIANT: The constraint is a representational equality constraint + + | ShapeMismatchReason + -- ^ A nominal equality that relates two wholly different types, + -- like @Int ~# Bool@ or @a b ~# 3@. + -- INVARIANT: The constraint is a nominal equality constraint + + | AbstractTyConReason + -- ^ An equality like @T a b c ~ Q d e@ where either @T@ or @Q@ + -- is an abstract type constructor. See Note [Skolem abstract data] + -- in GHC.Core.TyCon. + -- INVARIANT: The constraint is an equality constraint between two TyConApps + + | PluginReason + -- ^ A typechecker plugin returned this in the pluginBadCts field + -- of TcPluginProgress + +instance Outputable CtIrredReason where + ppr IrredShapeReason = text "(irred)" + ppr (NonCanonicalReason cter) = ppr cter + ppr ReprEqReason = text "(repr)" + ppr ShapeMismatchReason = text "(shape)" + ppr AbstractTyConReason = text "(abstc)" + ppr PluginReason = text "(plugin)" + +-- | Are we sure that more solving will never solve this constraint? +isInsolubleReason :: CtIrredReason -> Bool +isInsolubleReason IrredShapeReason = False +isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter +isInsolubleReason ReprEqReason = False +isInsolubleReason ShapeMismatchReason = True +isInsolubleReason AbstractTyConReason = True +isInsolubleReason PluginReason = True + +------------------------------------------------------------------------------ +-- +-- CheckTyEqResult, defined here because it is stored in a CtIrredReason +-- +------------------------------------------------------------------------------ + +-- | A /set/ of problems in checking the validity of a type equality. +-- See 'checkTypeEq'. +newtype CheckTyEqResult = CTER Word8 + +-- | No problems in checking the validity of a type equality. +cteOK :: CheckTyEqResult +cteOK = CTER zeroBits + +-- | Check whether a 'CheckTyEqResult' is marked successful. +cterHasNoProblem :: CheckTyEqResult -> Bool +cterHasNoProblem (CTER 0) = True +cterHasNoProblem _ = False + +-- | An /individual/ problem that might be logged in a 'CheckTyEqResult' +newtype CheckTyEqProblem = CTEP Word8 + +cteImpredicative, cteTypeFamily, cteInsolubleOccurs, + cteSolubleOccurs, cteConcrete, + cteSkolemEscape :: CheckTyEqProblem +cteImpredicative = CTEP (bit 0) -- Forall or (=>) encountered +cteTypeFamily = CTEP (bit 1) -- Type family encountered + +cteInsolubleOccurs = CTEP (bit 2) -- Occurs-check +cteSolubleOccurs = CTEP (bit 3) -- Occurs-check under a type function, or in a coercion, + -- or in a representational equality; see + -- See Note [Occurs check and representational equality] + -- cteSolubleOccurs must be one bit to the left of cteInsolubleOccurs + -- See also Note [Insoluble mis-match] in GHC.Tc.Errors + +-- NB: CTEP (bit 4) currently unused + +cteConcrete = CTEP (bit 5) -- Type variable that can't be made concrete + -- e.g. alpha[conc] ~ Maybe beta[tv] + +cteSkolemEscape = CTEP (bit 6) -- Skolem escape e.g. alpha[2] ~ b[sk,4] + +cteProblem :: CheckTyEqProblem -> CheckTyEqResult +cteProblem (CTEP mask) = CTER mask + +impredicativeProblem, insolubleOccursProblem, solubleOccursProblem :: CheckTyEqResult +impredicativeProblem = cteProblem cteImpredicative +insolubleOccursProblem = cteProblem cteInsolubleOccurs +solubleOccursProblem = cteProblem cteSolubleOccurs + +occurs_mask :: Word8 +occurs_mask = insoluble_mask .|. soluble_mask + where + CTEP insoluble_mask = cteInsolubleOccurs + CTEP soluble_mask = cteSolubleOccurs + +-- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem' +cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool +CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0 + +-- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other +cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool +CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask + +cterHasOnlyProblems :: CheckTyEqResult -> CheckTyEqResult -> Bool +CTER bits `cterHasOnlyProblems` CTER mask = (bits .&. complement mask) == 0 + +cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult +cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask) + +cterHasOccursCheck :: CheckTyEqResult -> Bool +cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0 + +cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult +cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask) + +-- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs +-- check under a type family or in a representation equality is soluble. +cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult +cterSetOccursCheckSoluble (CTER bits) + = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask) + where + CTEP insoluble_mask = cteInsolubleOccurs + +-- | Retain only information about occurs-check failures, because only that +-- matters after recurring into a kind. +cterFromKind :: CheckTyEqResult -> CheckTyEqResult +cterFromKind (CTER bits) + = CTER (bits .&. occurs_mask) + +cterIsInsoluble :: CheckTyEqResult -> Bool +cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0 + where + mask = impredicative_mask .|. insoluble_occurs_mask + + CTEP impredicative_mask = cteImpredicative + CTEP insoluble_occurs_mask = cteInsolubleOccurs + +instance Semigroup CheckTyEqResult where + CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2) +instance Monoid CheckTyEqResult where + mempty = cteOK + +instance Eq CheckTyEqProblem where + (CTEP b1) == (CTEP b2) = b1==b2 + +instance Outputable CheckTyEqProblem where + ppr prob@(CTEP bits) = case lookup prob allBits of + Just s -> text s + Nothing -> text "unknown:" <+> ppr bits + +instance Outputable CheckTyEqResult where + ppr cter | cterHasNoProblem cter + = text "cteOK" + | otherwise + = braces $ fcat $ intersperse vbar $ + [ text str + | (bitmask, str) <- allBits + , cter `cterHasProblem` bitmask ] + +allBits :: [(CheckTyEqProblem, String)] +allBits = [ (cteImpredicative, "cteImpredicative") + , (cteTypeFamily, "cteTypeFamily") + , (cteInsolubleOccurs, "cteInsolubleOccurs") + , (cteSolubleOccurs, "cteSolubleOccurs") + , (cteConcrete, "cteConcrete") + , (cteSkolemEscape, "cteSkolemEscape") ] + +{- Note [CIrredCan constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CIrredCan constraints are used for constraints that are "stuck" + - we can't solve them (yet) + - we can't use them to solve other constraints + - but they may become soluble if we substitute for some + of the type variables in the constraint + +Example 1: (c Int), where c :: * -> Constraint. We can't do anything + with this yet, but if later c := Num, *then* we can solve it + +Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable + We don't want to use this to substitute 'b' for 'a', in case + 'k' is subsequently unified with (say) *->*, because then + we'd have ill-kinded types floating about. Rather we want + to defer using the equality altogether until 'k' get resolved. + +Note [Ct/evidence invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field +of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for DictCt, + ctev_pred (di_ev ct) = (di_cls ct) (di_tys ct) +This holds by construction; look at the unique place where DictCt is +built (in GHC.Tc.Solver.Dict.canDictNC). + +Note [Ct kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~ +CEqCan requires that the kind of the lhs matches the kind +of the rhs. This is necessary because these constraints are used for substitutions +during solving. If the kinds differed, then the substitution would take a well-kinded +type to an ill-kinded one. +-} + +mkNonCanonical :: CtEvidence -> Ct +mkNonCanonical ev = CNonCanonical ev + +mkGivens :: CtLoc -> [EvId] -> [Ct] +mkGivens loc ev_ids + = map mk ev_ids + where + mk ev_id = mkNonCanonical (CtGiven (GivenCt { ctev_evar = ev_id + , ctev_pred = evVarPred ev_id + , ctev_loc = loc })) + +ctEvidence :: Ct -> CtEvidence +ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev +ctEvidence (CEqCan (EqCt { eq_ev = ev })) = ev +ctEvidence (CIrredCan (IrredCt { ir_ev = ev })) = ev +ctEvidence (CNonCanonical ev) = ev +ctEvidence (CDictCan (DictCt { di_ev = ev })) = ev + +updCtEvidence :: (CtEvidence -> CtEvidence) -> Ct -> Ct +updCtEvidence upd ct + = case ct of + CQuantCan qci@(QCI { qci_ev = ev }) -> CQuantCan (qci { qci_ev = upd ev }) + CEqCan eq@(EqCt { eq_ev = ev }) -> CEqCan (eq { eq_ev = upd ev }) + CIrredCan ir@(IrredCt { ir_ev = ev }) -> CIrredCan (ir { ir_ev = upd ev }) + CNonCanonical ev -> CNonCanonical (upd ev) + CDictCan di@(DictCt { di_ev = ev }) -> CDictCan (di { di_ev = upd ev }) + +ctLoc :: Ct -> CtLoc +ctLoc = ctEvLoc . ctEvidence + +ctOrigin :: Ct -> CtOrigin +ctOrigin = ctLocOrigin . ctLoc + +ctPred :: Ct -> PredType +-- See Note [Ct/evidence invariant] +ctPred ct = ctEvPred (ctEvidence ct) + +ctRewriters :: Ct -> RewriterSet +ctRewriters = ctEvRewriters . ctEvidence + +ctEvId :: HasDebugCallStack => Ct -> EvVar +-- The evidence Id for this Ct +ctEvId ct = ctEvEvId (ctEvidence ct) + +-- | Returns the evidence 'Id' for the argument 'Ct' +-- when this 'Ct' is a 'Wanted'. +-- +-- Returns 'Nothing' otherwise. +wantedEvId_maybe :: Ct -> Maybe EvVar +wantedEvId_maybe ct + = case ctEvidence ct of + ctev@(CtWanted {}) + | otherwise + -> Just $ ctEvEvId ctev + CtGiven {} + -> Nothing + +-- | Makes a new equality predicate with the same role as the given +-- evidence. +mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType +mkTcEqPredLikeEv ev + = case predTypeEqRel pred of + NomEq -> mkNomEqPred + ReprEq -> mkReprEqPred + where + pred = ctEvPred ev + +-- | Get the flavour of the given 'Ct' +ctFlavour :: Ct -> CtFlavour +ctFlavour = ctEvFlavour . ctEvidence + +-- | Get the equality relation for the given 'Ct' +ctEqRel :: Ct -> EqRel +ctEqRel = ctEvEqRel . ctEvidence + +instance Outputable Ct where + ppr ct = ppr (ctEvidence ct) <+> parens pp_sort + where + pp_sort = case ct of + CEqCan {} -> text "CEqCan" + CNonCanonical {} -> text "CNonCanonical" + CDictCan (DictCt { di_pend_sc = psc }) + | psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc) + | otherwise -> text "CDictCan" + CIrredCan (IrredCt { ir_reason = reason }) -> text "CIrredCan" <> ppr reason + CQuantCan (QCI { qci_pend_sc = psc }) + | psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc) + | otherwise -> text "CQuantCan" + +instance Outputable EqCt where + ppr (EqCt { eq_ev = ev }) = ppr ev + +{- +************************************************************************ +* * + Simple functions over evidence variables +* * +************************************************************************ +-} + +---------------- Getting bound tyvars ------------------------- +boundOccNamesOfWC :: WantedConstraints -> [OccName] +-- Return the OccNames of skolem-bound type variables +-- We could recurse into types, and get the forall-bound ones too, +-- but I'm going wait until that is needed +-- See Note [tidyAvoiding] in GHC.Core.TyCo.Tidy +boundOccNamesOfWC wc = bagToList (go_wc wc) + where + go_wc (WC { wc_impl = implics }) + = concatMapBag go_implic implics + go_implic (Implic { ic_skols = tvs, ic_wanted = wc }) + = listToBag (map getOccName tvs) `unionBags` go_wc wc + + +---------------- Getting free tyvars ------------------------- + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCt :: Ct -> TcTyCoVarSet +tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCtEv :: CtEvidence -> TcTyCoVarSet +tyCoVarsOfCtEv = fvVarSet . tyCoFVsOfCtEv + +-- | Returns free variables of constraints as a deterministically ordered +-- list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtList :: Ct -> [TcTyCoVar] +tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt + +-- | Returns free variables of constraints as a deterministically ordered +-- list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtEvList :: CtEvidence -> [TcTyCoVar] +tyCoVarsOfCtEvList = fvVarList . tyCoFVsOfType . ctEvPred + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfCt :: Ct -> FV +tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) + -- This must consult only the ctPred, so that it gets *tidied* fvs if the + -- constraint has been tidied. Tidying a constraint does not tidy the + -- fields of the Ct, only the predicate in the CtEvidence. + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in GHC.Utils.FV. +tyCoFVsOfCtEv :: CtEvidence -> FV +tyCoFVsOfCtEv ct = tyCoFVsOfType (ctEvPred ct) + +-- | Returns free variables of a bag of constraints as a non-deterministic +-- set. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCts :: Cts -> TcTyCoVarSet +tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a deterministically +-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] +tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a deterministically +-- ordered list. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoVarsOfCtEvsList :: [CtEvidence] -> [TcTyCoVar] +tyCoVarsOfCtEvsList = fvVarList . tyCoFVsOfCtEvs + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfCts :: Cts -> FV +tyCoFVsOfCts = foldr (unionFV . tyCoFVsOfCt) emptyFV + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in GHC.Utils.FV. +tyCoFVsOfCtEvs :: [CtEvidence] -> FV +tyCoFVsOfCtEvs = foldr (unionFV . tyCoFVsOfCtEv) emptyFV + +-- | Returns free variables of WantedConstraints as a non-deterministic +-- set. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Only called on *zonked* things +tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a deterministically +-- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] +-- Only called on *zonked* things +tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a composable FV +-- computation. See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfWC :: WantedConstraints -> FV +-- Only called on *zonked* things +tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_errors = errors }) + = tyCoFVsOfCts simple `unionFV` + tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV` + tyCoFVsOfBag tyCoFVsOfDelayedError errors + +-- | Returns free variables of Implication as a composable FV computation. +-- See Note [Deterministic FV] in "GHC.Utils.FV". +tyCoFVsOfImplic :: Implication -> FV +-- Only called on *zonked* things +tyCoFVsOfImplic (Implic { ic_skols = skols + , ic_given = givens + , ic_wanted = wanted }) + | isEmptyWC wanted + = emptyFV + | otherwise + = tyCoFVsVarBndrs skols $ + tyCoFVsVarBndrs givens $ + tyCoFVsOfWC wanted + +tyCoFVsOfDelayedError :: DelayedError -> FV +tyCoFVsOfDelayedError (DE_Hole hole) = tyCoFVsOfHole hole +tyCoFVsOfDelayedError (DE_NotConcrete {}) = emptyFV +tyCoFVsOfDelayedError (DE_Multiplicity co _) = tyCoFVsOfCo co + +tyCoFVsOfHole :: Hole -> FV +tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty + +tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV +tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV + +{- +************************************************************************ +* * + CtEvidence + The "flavor" of a canonical constraint +* * +************************************************************************ +-} + +isWantedCt :: Ct -> Bool +isWantedCt = isWanted . ctEvidence + +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . ctEvidence + +isPendingScDict :: Ct -> Bool +isPendingScDict (CDictCan dict_ct) = isPendingScDictCt dict_ct +isPendingScDict _ = False + +isPendingScDictCt :: DictCt -> Bool +-- Says whether this is a CDictCan with di_pend_sc has positive fuel; +-- i.e. pending un-expanded superclasses +isPendingScDictCt (DictCt { di_pend_sc = f }) = pendingFuel f + +pendingScDict_maybe :: Ct -> Maybe Ct +-- Says whether this is a CDictCan with di_pend_sc has fuel left, +-- AND if so exhausts the fuel so that they are not expanded again +pendingScDict_maybe (CDictCan dict@(DictCt { di_pend_sc = f })) + | pendingFuel f = Just (CDictCan (dict { di_pend_sc = doNotExpand })) + | otherwise = Nothing +pendingScDict_maybe _ = Nothing + +pendingScInst_maybe :: QCInst -> Maybe QCInst +-- Same as isPendingScDict, but for QCInsts +pendingScInst_maybe qci@(QCI { qci_ev = ev, qci_pend_sc = f }) + | isGiven ev -- Do not expand Wanted QCIs + , pendingFuel f = Just (qci { qci_pend_sc = doNotExpand }) + | otherwise = Nothing + +superClassesMightHelp :: WantedConstraints -> Bool +-- ^ True if taking superclasses of givens, or of wanteds (to perhaps +-- expose more equalities or functional dependencies) might help to +-- solve this constraint. See Note [When superclasses help] +superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) + = anyBag might_help_ct simples || anyBag might_help_implic implics + where + might_help_implic ic + | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) + | otherwise = False + + might_help_ct ct = not (is_ip ct) + + is_ip (CDictCan (DictCt { di_cls = cls })) = isIPClass cls + is_ip _ = False + +getPendingWantedScs :: Cts -> ([Ct], Cts) +-- in the return values [Ct] has original fuel while Cts has fuel exhausted +getPendingWantedScs simples + = mapAccumBagL get [] simples + where + get acc ct | Just ct_exhausted <- pendingScDict_maybe ct + = (ct:acc, ct_exhausted) + | otherwise + = (acc, ct) + +{- Note [When superclasses help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First read Note [The superclass story] in GHC.Tc.Solver.Dict + +We expand superclasses and iterate only if there is at unsolved wanted +for which expansion of superclasses (e.g. from given constraints) +might actually help. The function superClassesMightHelp tells if +doing this superclass expansion might help solve this constraint. +Note that + + * We look inside implications; maybe it'll help to expand the Givens + at level 2 to help solve an unsolved Wanted buried inside an + implication. E.g. + forall a. Ord a => forall b. [W] Eq a + + * We say "no" for implicit parameters. + we have [W] ?x::ty, expanding superclasses won't help: + - Superclasses can't be implicit parameters + - If we have a [G] ?x:ty2, then we'll have another unsolved + [W] ty ~ ty2 (from the functional dependency) + which will trigger superclass expansion. + + It's a bit of a special case, but it's easy to do. The runtime cost + is low because the unsolved set is usually empty anyway (errors + aside), and the first non-implicit-parameter will terminate the search. + + The special case is worth it (#11480, comment:2) because it + applies to CallStack constraints, which aren't type errors. If we have + f :: (C a) => blah + f x = ...undefined... + we'll get a CallStack constraint. If that's the only unsolved + constraint it'll eventually be solved by defaulting. So we don't + want to emit warnings about hitting the simplifier's iteration + limit. A CallStack constraint really isn't an unsolved + constraint; it can always be solved by defaulting. +-} + +singleCt :: Ct -> Cts +singleCt = unitBag + +andCts :: Cts -> Cts -> Cts +andCts = unionBags + +listToCts :: [Ct] -> Cts +listToCts = listToBag + +ctsElts :: Cts -> [Ct] +ctsElts = bagToList + +consCts :: Ct -> Cts -> Cts +consCts = consBag + +snocCts :: Cts -> Ct -> Cts +snocCts = snocBag + +extendCtsList :: Cts -> [Ct] -> Cts +extendCtsList cts xs | null xs = cts + | otherwise = cts `unionBags` listToBag xs + +emptyCts :: Cts +emptyCts = emptyBag + +isEmptyCts :: Cts -> Bool +isEmptyCts = isEmptyBag + +ctsPreds :: Cts -> [PredType] +ctsPreds cts = foldr ((:) . ctPred) [] cts + +{- +************************************************************************ +* * + Wanted constraints +* * +************************************************************************ +-} + +data WantedConstraints + = WC { wc_simple :: Cts -- Unsolved constraints, all wanted + , wc_impl :: Bag Implication + , wc_errors :: Bag DelayedError + } + +emptyWC :: WantedConstraints +emptyWC = WC { wc_simple = emptyBag + , wc_impl = emptyBag + , wc_errors = emptyBag } + +mkSimpleWC :: [CtEvidence] -> WantedConstraints +mkSimpleWC cts + = emptyWC { wc_simple = listToBag (map mkNonCanonical cts) } + +mkImplicWC :: Bag Implication -> WantedConstraints +mkImplicWC implic + = emptyWC { wc_impl = implic } + +isEmptyWC :: WantedConstraints -> Bool +isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_errors = errors }) + = isEmptyBag f && isEmptyBag i && isEmptyBag errors + +-- | Checks whether a the given wanted constraints are solved, i.e. +-- that there are no simple constraints left and all the implications +-- are solved. +isSolvedWC :: WantedConstraints -> Bool +isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl, wc_errors = errors} = + isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl && isEmptyBag errors + +andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints +andWC (WC { wc_simple = f1, wc_impl = i1, wc_errors = e1 }) + (WC { wc_simple = f2, wc_impl = i2, wc_errors = e2 }) + = WC { wc_simple = f1 `unionBags` f2 + , wc_impl = i1 `unionBags` i2 + , wc_errors = e1 `unionBags` e2 } + +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + +addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints +addSimples wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + -- Consider: Put the new constraints at the front, so they get solved first + +addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } + +addInsols :: WantedConstraints -> Bag IrredCt -> WantedConstraints +addInsols wc insols + = wc { wc_simple = wc_simple wc `unionBags` fmap CIrredCan insols } + +addHoles :: WantedConstraints -> Bag Hole -> WantedConstraints +addHoles wc holes + = wc { wc_errors = mapBag DE_Hole holes `unionBags` wc_errors wc } + +addNotConcreteError :: WantedConstraints -> NotConcreteError -> WantedConstraints +addNotConcreteError wc err + = wc { wc_errors = unitBag (DE_NotConcrete err) `unionBags` wc_errors wc } + +-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. +addMultiplicityCoercionError :: WantedConstraints -> TcCoercion -> CtLoc -> WantedConstraints +addMultiplicityCoercionError wc mult_co loc + = wc { wc_errors = unitBag (DE_Multiplicity mult_co loc) `unionBags` wc_errors wc } + +addDelayedErrors :: WantedConstraints -> Bag DelayedError -> WantedConstraints +addDelayedErrors wc errs + = wc { wc_errors = errs `unionBags` wc_errors wc } + +dropMisleading :: WantedConstraints -> WantedConstraints +-- Drop misleading constraints; really just class constraints +-- See Note [Constraints and errors] in GHC.Tc.Utils.Monad +-- for why this function is so strange, treating the 'simples' +-- and the implications differently. Sigh. +dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors }) + = WC { wc_simple = filterBag insolubleWantedCt simples + , wc_impl = mapBag drop_implic implics + , wc_errors = filterBag keep_delayed_error errors } + where + drop_implic implic + = implic { ic_wanted = drop_wanted (ic_wanted implic) } + drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_errors = errors }) + = WC { wc_simple = filterBag keep_ct simples + , wc_impl = mapBag drop_implic implics + , wc_errors = filterBag keep_delayed_error errors } + + keep_ct ct + = case classifyPredType (ctPred ct) of + ClassPred cls _ -> isEqualityClass cls + -- isEqualityClass: see (CERR2) in Note [Constraints and errors] + -- in GHC.Tc.Utils.Monad + _ -> True + + keep_delayed_error (DE_Hole hole) = isOutOfScopeHole hole + keep_delayed_error (DE_NotConcrete {}) = True + keep_delayed_error (DE_Multiplicity {}) = True + +isSolvedStatus :: ImplicStatus -> Bool +isSolvedStatus (IC_Solved {}) = True +isSolvedStatus _ = False + +isInsolubleStatus :: ImplicStatus -> Bool +isInsolubleStatus IC_Insoluble = True +isInsolubleStatus IC_BadTelescope = True +isInsolubleStatus _ = False + +insolubleImplic :: Implication -> Bool +insolubleImplic ic = isInsolubleStatus (ic_status ic) + +-- | Gather all the type variables from 'WantedConstraints' +-- that it would be unhelpful to default. For the moment, +-- these are only 'ConcreteTv' metavariables participating +-- in a nominal equality whose other side is not concrete; +-- it's usually better to report those as errors instead of +-- defaulting. +nonDefaultableTyVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Currently used in simplifyTop and in tcRule. +-- TODO: should we also use this in decideQuantifiedTyVars, kindGeneralize{All,Some}? +nonDefaultableTyVarsOfWC (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs }) + = concatMapBag non_defaultable_tvs_of_ct simples + `unionVarSet` concatMapBag (nonDefaultableTyVarsOfWC . ic_wanted) implics + `unionVarSet` concatMapBag non_defaultable_tvs_of_err errs + where + + concatMapBag :: (a -> TyVarSet) -> Bag a -> TyCoVarSet + concatMapBag f = foldr (\ r acc -> f r `unionVarSet` acc) emptyVarSet + + -- Don't default ConcreteTv metavariables involved + -- in an equality with something non-concrete: it's usually + -- better to report the unsolved Wanted. + -- + -- Example: alpha[conc] ~# rr[sk]. + non_defaultable_tvs_of_ct :: Ct -> TyCoVarSet + non_defaultable_tvs_of_ct ct = + -- NB: using classifyPredType instead of inspecting the Ct + -- so that we deal uniformly with CNonCanonical (which come up in tcRule), + -- CEqCan (unsolved but potentially soluble, e.g. @alpha[conc] ~# RR@) + -- and CIrredCan. + case classifyPredType $ ctPred ct of + EqPred NomEq lhs rhs + | Just tv <- getTyVar_maybe lhs + , isConcreteTyVar tv + , not (isConcreteType rhs) + -> unitVarSet tv + | Just tv <- getTyVar_maybe rhs + , isConcreteTyVar tv + , not (isConcreteType lhs) + -> unitVarSet tv + _ -> emptyVarSet + + -- Make sure to apply the same logic as above to delayed errors. + non_defaultable_tvs_of_err (DE_NotConcrete err) + = case err of + NCE_FRR { nce_frr_origin = frr } -> tyCoVarsOfType (frr_type frr) + non_defaultable_tvs_of_err (DE_Hole {}) = emptyVarSet + non_defaultable_tvs_of_err (DE_Multiplicity {}) = emptyVarSet + +insolubleWC :: WantedConstraints -> Bool +insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) + = anyBag insolubleWantedCt simples + -- insolubleWantedCt: wanteds only: see Note [Given insolubles] + || anyBag insolubleImplic implics + || anyBag is_insoluble errors + where + is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] + is_insoluble (DE_NotConcrete {}) = True + is_insoluble (DE_Multiplicity {}) = False + +insolubleWantedCt :: Ct -> Bool +-- Definitely insoluble, in particular /excluding/ type-hole constraints +-- Namely: +-- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either +-- - an insoluble equality constraint (e.g. Int ~ Bool), or +-- - a custom type error constraint, TypeError msg :: Constraint +-- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- See Note [Insoluble Wanteds] +insolubleWantedCt ct + | CIrredCan ir_ct <- ct + -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] + , IrredCt { ir_ev = ev } <- ir_ct + , CtWanted (WantedCt { ctev_loc = loc, ctev_rewriters = rewriters }) <- ev + -- It's a Wanted + , insolubleIrredCt ir_ct + -- It's insoluble + , isEmptyRewriterSet rewriters + -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + , not (isGivenLoc loc) + -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) + -- origin check: see (IW4) in Note [Insoluble Wanteds] + = True + + | otherwise + = False + +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. +-- +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt; all insoluble constraints +-- are put into CIrredCan +insolubleCt :: Ct -> Bool +insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct +insolubleCt _ = False + +insolubleIrredCt :: IrredCt -> Bool +-- Returns True of Irred constraints that are /definitely/ insoluble +-- +-- This function is critical for accurate pattern-match overlap warnings. +-- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver +-- +-- Note that this does not traverse through the constraint to find +-- nested custom type errors: it only detects @TypeError msg :: Constraint@, +-- and not e.g. @Eq (TypeError msg)@. +insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) + = isInsolubleReason reason + || isTopLevelUserTypeError (ctEvPred ev) + -- NB: 'isTopLevelUserTypeError' detects constraints of the form "TypeError msg" + -- and "Unsatisfiable msg". It deliberately does not detect TypeError + -- nested in a type (e.g. it does not use "containsUserTypeError"), as that + -- would be too eager: the TypeError might appear inside a type family + -- application which might later reduce, but we only want to return 'True' + -- for constraints that are definitely insoluble. + -- + -- For example: Num (F Int (TypeError "msg")), where F is a type family. + -- + -- Test case: T11503, with the 'Assert' type family: + -- + -- > type Assert :: Bool -> Constraint -> Constraint + -- > type family Assert check errMsg where + -- > Assert 'True _errMsg = () + -- > Assert _check errMsg = errMsg + +-- | Does this hole represent an "out of scope" error? +-- See Note [Insoluble holes] +isOutOfScopeHole :: Hole -> Bool +isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) + +instance Outputable WantedConstraints where + ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e}) + = text "WC" <+> braces (vcat + [ ppr_bag (text "wc_simple") s + , ppr_bag (text "wc_impl") i + , ppr_bag (text "wc_errors") e ]) + +ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc +ppr_bag doc bag + | isEmptyBag bag = empty + | otherwise = hang (doc <+> equals) + 2 (foldr (($$) . ppr) empty bag) + +{- Note [Given insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14325, comment:) + class (a~b) => C a b + + foo :: C a c => a -> c + foo x = x + + hm3 :: C (f b) b => b -> f b + hm3 x = foo x + +In the RHS of hm3, from the [G] C (f b) b we get the insoluble +[G] f b ~# b. Then we also get an unsolved [W] C b (f b). +Residual implication looks like + forall b. C (f b) b => [G] f b ~# b + [W] C f (f b) + +We do /not/ want to set the implication status to IC_Insoluble, +because that'll suppress reports of [W] C b (f b). But we +may not report the insoluble [G] f b ~# b either (see Note [Given errors] +in GHC.Tc.Errors), so we may fail to report anything at all! Yikes. + +Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) + should ignore givens even if they are insoluble. + +Note [Insoluble Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~ +insolubleWantedCt returns True of a Wanted constraint that definitely +can't be solved. But not quite all such constraints; see wrinkles. + +(IW1) insolubleWantedCt is tuned for application /after/ constraint + solving i.e. assuming canonicalisation has been done. That's why + it looks only for IrredCt; all insoluble constraints are put into + CIrredCan + +(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note + [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A + that is /not/ insoluble rewrites some other Wanted constraint B, so B has A + in its rewriter set. Now B looks insoluble. The danger is that we'll + suppress reporting B because of its empty rewriter set; and suppress + reporting A because there is an insoluble B lying around. (This suppression + happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. + +(IW3) If the Wanted arises from a Given (how can that happen?), don't + treat it as a Wanted insoluble (obviously). + +(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't + treat the constraint as insoluble. See Note [Suppressing confusing errors] + in GHC.Tc.Errors + +Note [Insoluble holes] +~~~~~~~~~~~~~~~~~~~~~~ +Hole constraints that ARE NOT treated as truly insoluble: + a) type holes, arising from PartialTypeSignatures, + b) "true" expression holes arising from TypedHoles + +An "expression hole" or "type hole" isn't really an error +at all; it's a report saying "_ :: Int" here. But an out-of-scope +variable masquerading as expression holes IS treated as truly +insoluble, so that it trumps other errors during error reporting. +Yuk! + +-} + +{- ********************************************************************* +* * + Custom type errors: Unsatisfiable and TypeError +* * +********************************************************************* -} + +{- Note [Custom type errors in constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC reports a type-error about an unsolved-constraint, we check +to see if the constraint contains any custom-type errors, and if so +we report them. Here are some examples of constraints containing type +errors: + + TypeError msg -- The actual constraint is a type error + + TypError msg ~ Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + + Eq (TypeError msg) -- A class constraint is stuck due to a type error + + F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err + +It is also possible to have constraints where the type error is nested deeper, +for example see #11990, and also: + + Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. + +A good use-case is described in "Detecting the undetectable" + https://blog.csongor.co.uk/report-stuck-families/ +which features + type family Assert (err :: Constraint) (break :: Type -> Type) (a :: k) :: k where + Assert _ Dummy _ = Any + Assert _ _ k = k +and an unsolved constraint like + Assert (TypeError ...) (F ty1) ty1 ~ ty2 +that reports that (F ty1) remains stuck. +-} + +-- | A constraint is considered to be a custom type error, if it contains +-- custom type errors anywhere in it. +-- See Note [Custom type errors in constraints] +getUserTypeErrorMsg :: PredType -> Maybe ErrorMsgType +getUserTypeErrorMsg pred = msum $ userTypeError_maybe pred + : map getUserTypeErrorMsg (subTys pred) + where + -- Richard thinks this function is very broken. What is subTys + -- supposed to be doing? Why are exactly-saturated tyconapps special? + -- What stops this from accidentally ripping apart a call to TypeError? + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of + Nothing -> [] + Just (_,ts) -> ts + (t,ts) -> t : ts + +-- | Is this an user error message type, i.e. either the form @TypeError err@ or +-- @Unsatisfiable err@? +isTopLevelUserTypeError :: PredType -> Bool +isTopLevelUserTypeError pred = + isJust (userTypeError_maybe pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Does this constraint contain an user error message? +-- +-- That is, the type is either of the form @Unsatisfiable err@, or it contains +-- a type of the form @TypeError msg@, either at the top level or nested inside +-- the type. +containsUserTypeError :: PredType -> Bool +containsUserTypeError pred = + isJust (getUserTypeErrorMsg pred) || isJust (isUnsatisfiableCt_maybe pred) + +-- | Is this type an unsatisfiable constraint? +-- If so, return the error message. +isUnsatisfiableCt_maybe :: Type -> Maybe ErrorMsgType +isUnsatisfiableCt_maybe t + | Just (tc, [msg]) <- splitTyConApp_maybe t + , tc `hasKey` unsatisfiableClassNameKey + = Just msg + | otherwise + = Nothing + +{- +************************************************************************ +* * + Implication constraints +* * +************************************************************************ +-} + +data Implication + = Implic { -- Invariants for a tree of implications: + -- see TcType Note [TcLevel invariants] + + ic_tclvl :: TcLevel, -- TcLevel of unification variables + -- allocated /inside/ this implication + + ic_info :: SkolemInfoAnon, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + + ic_skols :: [TcTyVar], -- Introduced skolems; always skolem TcTyVars + -- Their level numbers should be precisely ic_tclvl + -- Their SkolemInfo should be precisely ic_info (almost) + -- See Note [Implication invariants] + + ic_given :: [EvVar], -- Given evidence variables + -- (order does not matter) + -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType + + ic_given_eqs :: HasGivenEqs, -- Are there Given equalities here? + + ic_warn_inaccessible :: Bool, + -- True <=> we should report inaccessible code + -- Note [Avoid -Winaccessible-code when deriving] + -- in GHC.Tc.TyCl.Instance + + ic_env :: !CtLocEnv, + -- Records the context at the time of creation. + -- + -- This provides all the information needed about + -- the context to report the source of errors linked + -- to this implication. + + ic_wanted :: WantedConstraints, -- The wanteds + -- See Invariant (WantedInf) in GHC.Tc.Utils.TcType + + ic_binds :: EvBindsVar, -- Points to the place to fill in the + -- abstraction and bindings. + + -- The ic_need fields keep track of which Given evidence + -- is used by this implication or its children + -- See Note [Tracking redundant constraints] + -- NB: these sets include stuff used by fully-solved nested implications + -- that have since been discarded + ic_need :: EvNeedSet, -- All needed Given evidence, from this implication + -- or outer ones + -- That is, /after/ deleting the binders of ic_binds, + -- but /before/ deleting ic_givens + + ic_need_implic :: EvNeedSet, -- Union of of the ic_need of all implications in ic_wanted + -- /including/ any fully-solved implications that have been + -- discarded by `pruneImplications`. This discarding is why + -- we need to keep this field in the first place. + + ic_status :: ImplicStatus + } + +data EvNeedSet = ENS { ens_dms :: VarSet -- Needed only by default methods + , ens_fvs :: VarSet -- Needed by things /other than/ default methods + -- See (TRC5) in Note [Tracking redundant constraints] + } + +emptyEvNeedSet :: EvNeedSet +emptyEvNeedSet = ENS { ens_dms = emptyVarSet, ens_fvs = emptyVarSet } + +unionEvNeedSet :: EvNeedSet -> EvNeedSet -> EvNeedSet +unionEvNeedSet (ENS { ens_dms = dm1, ens_fvs = fv1 }) + (ENS { ens_dms = dm2, ens_fvs = fv2 }) + = ENS { ens_dms = dm1 `unionVarSet` dm2, ens_fvs = fv1 `unionVarSet` fv2 } + +extendEvNeedSet :: EvNeedSet -> Var -> EvNeedSet +extendEvNeedSet ens@(ENS { ens_fvs = fvs }) v = ens { ens_fvs = fvs `extendVarSet` v } + +delGivensFromEvNeedSet :: EvNeedSet -> [Var] -> EvNeedSet +delGivensFromEvNeedSet (ENS { ens_dms = dms, ens_fvs = fvs }) givens + = ENS { ens_dms = dms `delVarSetList` givens + , ens_fvs = fvs `delVarSetList` givens } + +implicationPrototype :: CtLocEnv -> Implication +implicationPrototype ct_loc_env + = Implic { -- These fields must be initialised + ic_tclvl = panic "newImplic:tclvl" + , ic_binds = panic "newImplic:binds" + , ic_info = panic "newImplic:info" + , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" + + -- Given by caller + , ic_env = ct_loc_env + + -- The rest have sensible default values + , ic_skols = [] + , ic_given = [] + , ic_wanted = emptyWC + , ic_given_eqs = MaybeGivenEqs + , ic_status = IC_Unsolved + , ic_need = emptyEvNeedSet + , ic_need_implic = emptyEvNeedSet } + +data ImplicStatus + = IC_Solved -- All wanteds in the tree are solved, all the way down + { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + + | IC_Insoluble -- At least one insoluble Wanted constraint in the tree + + | IC_BadTelescope -- Solved, but the skolems in the telescope are out of + -- dependency order. See Note [Checking telescopes] + + | IC_Unsolved -- Neither of the above; might go either way + +data HasGivenEqs -- See Note [HasGivenEqs] + = NoGivenEqs -- Definitely no given equalities, + -- except by Note [Let-bound skolems] in GHC.Tc.Solver.InertSet + | LocalGivenEqs -- Might have Given equalities, but only ones that affect only + -- local skolems e.g. forall a b. (a ~ F b) => ... + | MaybeGivenEqs -- Might have any kind of Given equalities; no floating out + -- is possible. + deriving Eq + +type UserGiven = Implication + +getUserGivensFromImplics :: [Implication] -> [UserGiven] +getUserGivensFromImplics implics + = reverse (filterOut (null . ic_given) implics) + +{- Note [HasGivenEqs] +~~~~~~~~~~~~~~~~~~~~~ +The GivenEqs data type describes the Given constraints of an implication constraint: + +* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems + which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet + Examples: forall a. Eq a => ... + forall a. (Show a, Num a) => ... + forall a. a ~ Either Int Bool => ... -- Let-bound skolem + +* LocalGivenEqs: definitely no Given equalities that would affect principal + types. But may have equalities that affect only skolems of this implication + (and hence do not affect principal types) + Examples: forall a. F a ~ Int => ... + forall a b. F a ~ G b => ... + +* MaybeGivenEqs: may have Given equalities that would affect principal + types + Examples: forall. (a ~ b) => ... + forall a. F a ~ b => ... + forall a. c a => ... -- The 'c' might be instantiated to (b ~) + forall a. C a b => .... + where class x~y => C a b + so there is an equality in the superclass of a Given + +The HasGivenEqs classifications affect two things: + +* Suppressing redundant givens during error reporting; see GHC.Tc.Errors + Note [Suppress redundant givens during error reporting] + +* Floating in approximateWC. + +Specifically, here's how it goes: + + Stops floating | Suppresses Givens in errors + in approximateWC | + ----------------------------------------------- + NoGivenEqs NO | YES + LocalGivenEqs NO | NO + MaybeGivenEqs YES | NO +-} + +instance Outputable Implication where + ppr (Implic { ic_tclvl = tclvl, ic_skols = skols + , ic_given = given, ic_given_eqs = given_eqs + , ic_wanted = wanted, ic_status = status + , ic_binds = binds + , ic_need = need, ic_need_implic = need_implic + , ic_info = info }) + = hang (text "Implic" <+> lbrace) + 2 (sep [ text "TcLevel =" <+> ppr tclvl + , text "Skolems =" <+> pprTyVars skols + , text "Given-eqs =" <+> ppr given_eqs + , text "Status =" <+> ppr status + , hang (text "Given =") 2 (pprEvVars given) + , hang (text "Wanted =") 2 (ppr wanted) + , text "Binds =" <+> ppr binds + , text "need =" <+> ppr need + , text "need_implic =" <+> ppr need_implic + , pprSkolInfo info ] <+> rbrace) + +instance Outputable EvNeedSet where + ppr (ENS { ens_dms = dms, ens_fvs = fvs }) + = text "ENS" <> braces (sep [text "ens_dms =" <+> ppr dms + , text "ens_fvs =" <+> ppr fvs]) + +instance Outputable ImplicStatus where + ppr IC_Insoluble = text "Insoluble" + ppr IC_BadTelescope = text "Bad telescope" + ppr IC_Unsolved = text "Unsolved" + ppr (IC_Solved { ics_dead = dead }) + = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) + +checkTelescopeSkol :: SkolemInfoAnon -> Bool +-- See Note [Checking telescopes] +checkTelescopeSkol (ForAllSkol {}) = True +checkTelescopeSkol _ = False + +instance Outputable HasGivenEqs where + ppr NoGivenEqs = text "NoGivenEqs" + ppr LocalGivenEqs = text "LocalGivenEqs" + ppr MaybeGivenEqs = text "MaybeGivenEqs" + +-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs +instance Semigroup HasGivenEqs where + NoGivenEqs <> other = other + other <> NoGivenEqs = other + + MaybeGivenEqs <> _other = MaybeGivenEqs + _other <> MaybeGivenEqs = MaybeGivenEqs + + LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs + +-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs +instance Monoid HasGivenEqs where + mempty = NoGivenEqs + +{- Note [Checking telescopes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When kind-checking a /user-written/ type, we might have a "bad telescope" +like this one: + data SameKind :: forall k. k -> k -> Type + type Foo :: forall a k (b :: k). SameKind a b -> Type + +The kind of 'a' mentions 'k' which is bound after 'a'. Oops. + +One approach to doing this would be to bring each of a, k, and b into +scope, one at a time, creating a separate implication constraint for +each one, and bumping the TcLevel. This would work, because the kind +of, say, a would be untouchable when k is in scope (and the constraint +couldn't float out because k blocks it). However, it leads to terrible +error messages, complaining about skolem escape. While it is indeed a +problem of skolem escape, we can do better. + +Instead, our approach is to bring the block of variables into scope +all at once, creating one implication constraint for the lot: + +* We make a single implication constraint when kind-checking + the 'forall' in Foo's kind, something like + forall a k (b::k). { wanted constraints } + +* Having solved {wanted}, before discarding the now-solved implication, + the constraint solver checks the dependency order of the skolem + variables (ic_skols). This is done in setImplicationStatus. + +* This check is only necessary if the implication was born from a + 'forall' in a user-written signature (the HsForAllTy case in + GHC.Tc.Gen.HsType. If, say, it comes from checking a pattern match + that binds existentials, where the type of the data constructor is + known to be valid (it in tcConPat), no need for the check. + + So the check is done /if and only if/ ic_info is ForAllSkol. + +* If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the + original, user-written type variables. + +* Be careful /NOT/ to discard an implication with a ForAllSkol + ic_info, even if ic_wanted is empty. We must give the + constraint solver a chance to make that bad-telescope test! Hence + the extra guard in emitResidualTvConstraint; see #16247 + +* Don't mix up inferred and explicit variables in the same implication + constraint. E.g. + foo :: forall a kx (b :: kx). SameKind a b + We want an implication + Implic { ic_skol = [(a::kx), kx, (b::kx)], ... } + but GHC will attempt to quantify over kx, since it is free in (a::kx), + and it's hopelessly confusing to report an error about quantified + variables kx (a::kx) kx (b::kx). + Instead, the outer quantification over kx should be in a separate + implication. TL;DR: an explicit forall should generate an implication + quantified only over those explicitly quantified variables. + +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem variables bound in ic_skols are all fresh when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + +Note [Skolems in an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems in an implication are used: + +* When considering floating a constraint outside the implication in + GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications + For this, we can treat ic_skols as a set. + +* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs) + has its variables in the correct order; see Note [Checking telescopes]. + Only for these implications does ic_skols need to be a list. + +Nota bene: Although ic_skols is a list, it is not necessarily +in dependency order: +- In the ic_info=ForAllSkol case, the user might have written them + in the wrong order +- In the case of a type signature like + f :: [a] -> [b] + the renamer gathers the implicit "outer" forall'd variables {a,b}, but + does not know what order to put them in. The type checker can sort them + into dependency order, but only after solving all the kind constraints; + and to do that it's convenient to create the Implication! + +So we accept that ic_skols may be out of order. Think of it as a set or +(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly +wrong, order. + +Note [Insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the errors that we get during canonicalization are best +reported when all constraints have been simplified as much as +possible. For instance, assume that during simplification the +following constraints arise: + + [Wanted] F alpha ~ uf1 + [Wanted] beta ~ uf1 beta + +When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail +we will simply see a message: + 'Can't construct the infinite type beta ~ uf1 beta' +and the user has no idea what the uf1 variable is. + +Instead our plan is that we will NOT fail immediately, but: + (1) Record the "frozen" error in the ic_insols field + (2) Isolate the offending constraint from the rest of the inerts + (3) Keep on simplifying/canonicalizing + +At the end, we will hopefully have substituted uf1 := F alpha, and we +will be able to report a more informative error: + 'Can't construct the infinite type beta ~ F alpha beta' + + +************************************************************************ +* * + approximateWC +* * +************************************************************************ +-} + +type ApproxWC = ( Bag Ct -- Free quantifiable constraints + , TcTyCoVarSet ) -- Free vars of non-quantifiable constraints + -- due to shape, or enclosing equality + -- Why do we need that TcTyCoVarSet of non-quantifiable constraints? + -- See (DP1) in Note [decideAndPromoteTyVars] in GHC.Tc.Solver +approximateWC :: Bool -> WantedConstraints -> Bag Ct +approximateWC include_non_quantifiable cts + = fst (approximateWCX include_non_quantifiable cts) + +approximateWCX :: Bool -> WantedConstraints -> ApproxWC +-- The "X" means "extended"; +-- we return both quantifiable and non-quantifiable constraints +-- See Note [ApproximateWC] +-- See Note [floatKindEqualities vs approximateWC] +approximateWCX include_non_quantifiable wc + = float_wc False emptyVarSet wc (emptyBag, emptyVarSet) + where + float_wc :: Bool -- True <=> there are enclosing equalities + -> TcTyCoVarSet -- Enclosing skolem binders + -> WantedConstraints + -> ApproxWC -> ApproxWC + float_wc encl_eqs trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) acc + = foldBag_flip (float_ct encl_eqs trapping_tvs) simples $ + foldBag_flip (float_implic encl_eqs trapping_tvs) implics $ + acc + + float_implic :: Bool -> TcTyCoVarSet -> Implication + -> ApproxWC -> ApproxWC + float_implic encl_eqs trapping_tvs imp + = float_wc new_encl_eqs new_trapping_tvs (ic_wanted imp) + where + new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp + new_encl_eqs = encl_eqs || ic_given_eqs imp == MaybeGivenEqs + + float_ct :: Bool -> TcTyCoVarSet -> Ct + -> ApproxWC -> ApproxWC + float_ct encl_eqs skol_tvs ct acc@(quant, no_quant) + | isGivenCt ct = acc + -- There can be (insoluble) Given constraints in wc_simple, + -- there so that we get error reports for unreachable code + -- See `given_insols` in GHC.Tc.Solver.Solve.solveImplication + | insolubleCt ct = acc + | pred_tvs `intersectsVarSet` skol_tvs = acc + | include_non_quantifiable = add_to_quant + | is_quantifiable encl_eqs (ctPred ct) = add_to_quant + | otherwise = add_to_no_quant + where + pred = ctPred ct + pred_tvs = tyCoVarsOfType pred + add_to_quant = (ct `consBag` quant, no_quant) + add_to_no_quant = (quant, no_quant `unionVarSet` pred_tvs) + + is_quantifiable encl_eqs pred + = case classifyPredType pred of + -- See the classification in Note [ApproximateWC] + EqPred eq_rel ty1 ty2 + | encl_eqs -> False -- encl_eqs: See Wrinkle (W1) + | otherwise -> quantify_equality eq_rel ty1 ty2 + + ClassPred cls tys + | Just {} <- isCallStackPred cls tys + -- NEVER infer a CallStack constraint. Otherwise we let + -- the constraints bubble up to be solved from the outer + -- context, or be defaulted when we reach the top-level. + -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence + -> False + + | otherwise + -> True -- See Wrinkle (W2) + + IrredPred {} -> True -- See Wrinkle (W2) + + ForAllPred {} -> warnPprTrace True "Unexpected ForAllPred" (ppr pred) $ + False -- See Wrinkle (W4) + + -- See Note [Quantifying over equality constraints] + quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 + quantify_equality ReprEq _ _ = True + + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isTypeFamilyTyCon tc + _ -> False + +{- Note [ApproximateWC] +~~~~~~~~~~~~~~~~~~~~~~~ +approximateWC takes a constraint, typically arising from the RHS of a +let-binding whose type we are *inferring*, and extracts from it some *simple* +constraints that we might plausibly abstract over. Of course the top-level +simple constraints are plausible, but we also float constraints out from inside, +if they are not captured by skolems. + +The same function is used when doing type-class defaulting (see the call +to applyDefaultingRules) to extract constraints that might be defaulted. + +We proceed by classifying the constraint: + * ClassPred: + * Never pick a CallStack constraint. + See Note [Overview of implicit CallStacks] + * Always pick an implicit-parameter constraint. + Note [Inheriting implicit parameters] + See wrinkle (W2) + + * EqPred: see Note [Quantifying over equality constraints] + + * IrredPred: we allow anything. + + * ForAllPred: never quantify over these + +Wrinkle (W1) + When inferring most-general types (in simplifyInfer), we + do *not* quantify over equality constraint if the implication binds + equality constraints, because that defeats the OutsideIn story. + Consider data T a where { TInt :: T Int; MkT :: T a } + f TInt = 3::Int + We get the implication (a ~ Int => res ~ Int), where so far we've decided + f :: T a -> res + We don't want to float (res~Int) out because then we'll infer + f :: T a -> Int + which is only on of the possible types. (GHC 7.6 accidentally *did* + float out of such implications, which meant it would happily infer + non-principal types.) + +Wrinkle (W2) + We do allow /class/ constraints to float, even if the implication binds + equalities. This is a subtle point: see #23224. In principle, a class + constraint might ultimately be satisfiable from a constraint bound by an + implication (see #19106 for an example of this kind), but it's extremely + obscure and I was unable to construct a concrete example. In any case, in + super-subtle cases where this might make a difference, you would be much + better advised to simply write a type signature. + +Wrinkle (W3) + In findDefaultableGroups we are not worried about the most-general type; and + we /do/ want to float out of equalities (#12797). Hence we just union the two + returned lists. + +Wrinkle (W4) + In #26376 we had constraints + [W] d1 : Functor f[tau:1] + [W] d2 : Functor p[tau:1] + [W] d3 : forall a. Functor (p[tau:1]) a -- A quantified constraint + We certainly don't want to /quantify/ over d3; but we /do/ want to + quantify over `p`, so it would be a mistake to make the function monomorphic + in `p` just because `p` is mentioned in this quantified constraint. + + Happily this problem cannot happen any more. That quantified constraint `d3` + dates from a time when we flirted with an all-or-nothing strategy for + quantified constraints Nowadays we'll never see this: we'll have simplified + that quantified constraint into a implication constraint. (Exception: + SPECIALISE pragmas: see (WFA4) in Note [Solving a Wanted forall-constraint]. + But there we don't use approximateWC.) + +------ Historical note ----------- +There used to be a second caveat, driven by #8155 + + 2. We do not float out an inner constraint that shares a type variable + (transitively) with one that is trapped by a skolem. Eg + forall a. F a ~ beta, Integral beta + We don't want to float out (Integral beta). Doing so would be bad + when defaulting, because then we'll default beta:=Integer, and that + makes the error message much worse; we'd get + Can't solve F a ~ Integer + rather than + Can't solve Integral (F a) + + Moreover, floating out these "contaminated" constraints doesn't help + when generalising either. If we generalise over (Integral b), we still + can't solve the retained implication (forall a. F a ~ b). Indeed, + arguably that too would be a harder error to understand. + +But this transitive closure stuff gives rise to a complex rule for +when defaulting actually happens, and one that was never documented. +Moreover (#12923), the more complex rule is sometimes NOT what +you want. So I simply removed the extra code to implement the +contamination stuff. There was zero effect on the testsuite (not even #8155). +------ End of historical note ----------- + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t) +in pickQuantifiablePreds? + +* It is always /sound/ to quantify over a constraint -- those + quantified constraints will need to be proved at each call site. + +* We definitely don't want to quantify over (Maybe a ~ Bool), to get + f :: forall a. (Maybe a ~ Bool) => blah + That simply postpones a type error from the function definition site to + its call site. Fortunately we have already filtered out insoluble + constraints: see `definite_error` in `simplifyInfer`. + +* What about (a ~ T alpha b), where we are about to quantify alpha, `a` and + `b` are in-scope skolems, and `T` is a data type. It's pretty unlikely + that this will be soluble at a call site, so we don't quantify over it. + +* What about `(F beta ~ Int)` where we are going to quantify `beta`? + Should we quantify over the (F beta ~ Int), to get + f :: forall b. (F b ~ Int) => blah + Aha! Perhaps yes, because at the call site we will instantiate `b`, and + perhaps we have `instance F Bool = Int`. So we *do* quantify over a + type-family equality where the arguments mention the quantified variables. + +This is all a bit ad-hoc. + + +************************************************************************ +* * + Invariant checking (debug only) +* * +************************************************************************ + +Note [Implication invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems of an implication have the following invariants, which are checked +by checkImplicationInvariants: + +a) They are all SkolemTv TcTyVars; no TyVars, no unification variables +b) Their TcLevel matches the ic_lvl for the implication +c) Their SkolemInfo matches the implication. + +Actually (c) is not quite true. Consider + data T a = forall b. MkT a b + +In tcConDecl for MkT we'll create an implication with ic_info of +DataConSkol; but the type variable 'a' will have a SkolemInfo of +TyConSkol. So we allow the tyvar to have a SkolemInfo of TyConFlav if +the implication SkolemInfo is DataConSkol. +-} + +checkImplicationInvariants, check_implic :: (HasCallStack, Applicative m) => Implication -> m () +{-# INLINE checkImplicationInvariants #-} +-- Nothing => OK, Just doc => doc gives info +checkImplicationInvariants implic = when debugIsOn (check_implic implic) + +check_implic implic@(Implic { ic_tclvl = lvl + , ic_info = skol_info + , ic_skols = skols }) + | null bads = pure () + | otherwise = massertPpr False (vcat [ text "checkImplicationInvariants failure" + , nest 2 (vcat bads) + , ppr implic ]) + where + bads = mapMaybe check skols + + check :: TcTyVar -> Maybe SDoc + check tv | not (isTcTyVar tv) + = Just (ppr tv <+> text "is not a TcTyVar") + | otherwise + = check_details tv (tcTyVarDetails tv) + + check_details :: TcTyVar -> TcTyVarDetails -> Maybe SDoc + check_details tv (SkolemTv tv_skol_info tv_lvl _) + | not (tv_lvl `sameDepthAs` lvl) + = Just (vcat [ ppr tv <+> text "has level" <+> ppr tv_lvl + , text "ic_lvl" <+> ppr lvl ]) + | not (skol_info `checkSkolInfoAnon` skol_info_anon) + = Just (vcat [ ppr tv <+> text "has skol info" <+> ppr skol_info_anon + , text "ic_info" <+> ppr skol_info ]) + | otherwise + = Nothing + where + skol_info_anon = getSkolemInfo tv_skol_info + check_details tv details + = Just (ppr tv <+> text "is not a SkolemTv" <+> ppr details) + +checkSkolInfoAnon :: SkolemInfoAnon -- From the implication + -> SkolemInfoAnon -- From the type variable + -> Bool -- True <=> ok +-- Used only for debug-checking; checkImplicationInvariants +-- So it doesn't matter much if its's incomplete +checkSkolInfoAnon sk1 sk2 = go sk1 sk2 + where + go (SigSkol c1 t1 s1) (SigSkol c2 t2 s2) = c1==c2 && t1 `tcEqType` t2 && s1==s2 + go (SigTypeSkol cx1) (SigTypeSkol cx2) = cx1==cx2 + + go (ForAllSkol _) (ForAllSkol _) = True + + go (IPSkol ips1) (IPSkol ips2) = ips1 == ips2 + go (DerivSkol pred1) (DerivSkol pred2) = pred1 `tcEqType` pred2 + go (TyConSkol f1 n1) (TyConSkol f2 n2) = f1==f2 && n1==n2 + go (DataConSkol n1) (DataConSkol n2) = n1==n2 + go (InstSkol {}) (InstSkol {}) = True + go (MethSkol n1 d1) (MethSkol n2 d2) = n1==n2 && d1==d2 + go FamInstSkol FamInstSkol = True + go BracketSkol BracketSkol = True + go (RuleSkol n1) (RuleSkol n2) = n1==n2 + go (SpecESkol n1) (SpecESkol n2) = n1==n2 + go (PatSkol c1 _) (PatSkol c2 _) = getName c1 == getName c2 + -- Too tedious to compare the HsMatchContexts + go (InferSkol ids1) (InferSkol ids2) = equalLength ids1 ids2 && + and (zipWith eq_pr ids1 ids2) + go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 + go ReifySkol ReifySkol = True + go RuntimeUnkSkol RuntimeUnkSkol = True + go ArrowReboundIfSkol ArrowReboundIfSkol = True + go (UnkSkol _) (UnkSkol _) = True + + -------- Three slightly strange special cases -------- + go (DataConSkol _) (TyConSkol f _) = h98_data_decl f + -- In the H98 declaration data T a = forall b. MkT a b + -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of + -- DataConSkol, but the type variable 'a' will have a SkolemInfo of TyConSkol + + go (DataConSkol _) FamInstSkol = True + -- In data/newtype instance T a = MkT (a -> a), + -- in tcConDecl for MkT we'll have a SkolemInfo in the implication of + -- DataConSkol, but 'a' will have SkolemInfo of FamInstSkol + + go FamInstSkol (InstSkol {}) = True + -- In instance C (T a) where { type F (T a) b = ... } + -- we have 'a' with SkolemInfo InstSkol, but we make an implication wi + -- SkolemInfo of FamInstSkol. Very like the ConDecl/TyConSkol case + + go (ForAllSkol _) _ = True + -- Telescope tests: we need a ForAllSkol to force the telescope + -- test, but the skolems might come from (say) a family instance decl + -- type instance forall a. F [a] = a->a + + go (SigTypeSkol DerivClauseCtxt) (TyConSkol f _) = h98_data_decl f + -- e.g. newtype T a = MkT ... deriving blah + -- We use the skolems from T (TyConSkol) when typechecking + -- the deriving clauses (SigTypeSkol DerivClauseCtxt) + + go _ _ = False + + eq_pr :: (Name,TcType) -> (Name,TcType) -> Bool + eq_pr (i1,_) (i2,_) = i1==i2 -- Types may be differently zonked + + h98_data_decl DataTypeFlavour = True + h98_data_decl NewtypeFlavour = True + h98_data_decl _ = False + + +{- ********************************************************************* +* * + Pretty printing +* * +********************************************************************* -} + +pprEvVars :: [EvVar] -> SDoc -- Print with their types +pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) + +pprEvVarTheta :: [EvVar] -> SDoc +pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) + +pprEvVarWithType :: EvVar -> SDoc +pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) + + + +wrapType :: Type -> [TyVar] -> [PredType] -> Type +wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty + + +{- +************************************************************************ +* * + CtEvidence +* * +************************************************************************ + +Note [CtEvidence invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `ctev_pred` field of a `CtEvidence` is a just a cache for the type +of the evidence. More precisely: + +* For Givens, `ctev_pred` = `varType ctev_evar` +* For Wanteds, `ctev_pred` = `evDestType ctev_dest` + +where + + evDestType :: TcEvDest -> TcType + evDestType (EvVarDest evVar) = varType evVar + evDestType (HoleDest coercionHole) = varType (coHoleCoVar coercionHole) + +The invariant is maintained by `setCtEvPredType`, the only function that +updates the `ctev_pred` field of a `CtEvidence`. + +Why is the invariant important? Because when the evidence is a coercion, it may +be used in (CastTy ty co); and then we may call `typeKind` on that type (e.g. +in the kind-check of `eqType`); and expect to see a fully zonked kind. +(This came up in test T13333, in the MR that fixed #20641, namely !6942.) + +Historical Note [Evidence field of CtEvidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the past we tried leaving the `ctev_evar`/`ctev_dest` field of a +constraint untouched (and hence un-zonked) on the grounds that it is +never looked at. But in fact it is: the evidence can become part of a +type (via `CastTy ty kco`) and we may later ask the kind of that type +and expect a zonked result. (For example, in the kind-check +of `eqType`.) + +The safest thing is simply to keep `ctev_evar`/`ctev_dest` in sync +with `ctev_pred`, as stated in `Note [CtEvidence invariants]`. + +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. Two main reasons: + * Gain sharing. E.g. suppose we start with g :: C a b, where + class D a => C a b + class (E a, F a) => D a + If we generate all g's superclasses as separate EvTerms we might + get selD1 (selC1 g) :: E a + selD2 (selC1 g) :: F a + selC1 g :: D a + which we could do more economically as: + g1 :: D a = selC1 g + g2 :: E a = selD1 g1 + g3 :: F a = selD2 g1 + + * For *coercion* evidence we *must* bind each given: + class (a~b) => C a b where .... + f :: C a b => .... + Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. + But that superclass selector can't (yet) appear in a coercion + (see evTermCoercion), so the easy thing is to bind it to an Id. + +So a Given has EvVar inside it rather than (as previously) an EvTerm. + +Note [The rewrite-role of a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rewrite-role of a constraint says what can rewrite that constraint: + +* If the rewrite-role = Nominal, only a nominal equality can rewrite it + +* If the rewrite-rule = Representational, either a nominal or + representational equality can rewrit it. + +Notice that the constraint may itself not be an equality at all. +For example, the rewrite-role of (Eq [a]) is Nominal; only nominal +equalities can rewrite it. +-} + +-- | A place for type-checking evidence to go after it is generated. +-- +-- - Wanted equalities use HoleDest, +-- - other Wanteds use EvVarDest. +data TcEvDest + = EvVarDest EvVar -- ^ bind this var to the evidence + -- EvVarDest is always used for non-type-equalities + -- e.g. class constraints + + | HoleDest CoercionHole -- ^ fill in this hole with the evidence + -- HoleDest is always used for type-equalities + -- See Note [Coercion holes] in GHC.Core.TyCo.Rep + +data CtEvidence + = CtGiven GivenCtEvidence + | CtWanted WantedCtEvidence + +-- | Evidence for a Given constraint +data GivenCtEvidence = + GivenCt + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_evar :: EvVar -- See Note [CtEvidence invariants] + , ctev_loc :: CtLoc } + +-- | Evidence for a Wanted constraint +data WantedCtEvidence = + WantedCt + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_dest :: TcEvDest -- See Note [CtEvidence invariants] + , ctev_loc :: CtLoc + , ctev_rewriters :: RewriterSet } -- See Note [Wanteds rewrite Wanteds] + +ctEvPred :: CtEvidence -> TcPredType +-- The predicate of a flavor +ctEvPred (CtGiven (GivenCt { ctev_pred = pred })) = pred +ctEvPred (CtWanted (WantedCt { ctev_pred = pred })) = pred + +ctEvLoc :: CtEvidence -> CtLoc +ctEvLoc (CtGiven (GivenCt { ctev_loc = loc })) = loc +ctEvLoc (CtWanted (WantedCt { ctev_loc = loc })) = loc + +ctEvOrigin :: CtEvidence -> CtOrigin +ctEvOrigin = ctLocOrigin . ctEvLoc + +-- | Get the equality relation relevant for a 'CtEvidence' +ctEvEqRel :: HasDebugCallStack => CtEvidence -> EqRel +ctEvEqRel = predTypeEqRel . ctEvPred + +-- | Get the rewrite-role relevant for a 'CtEvidence' +-- See Note [The rewrite-role of a constraint] +ctEvRewriteRole :: HasDebugCallStack => CtEvidence -> Role +ctEvRewriteRole = eqRelRole . ctEvRewriteEqRel + +ctEvRewriteEqRel :: CtEvidence -> EqRel +-- ^ Return the rewrite-role of an abitrary CtEvidence +-- See Note [The rewrite-role of a constraint] +-- We return ReprEq for (a ~R# b) and NomEq for all other preds +ctEvRewriteEqRel = predTypeEqRel . ctEvPred + +ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm ev = EvExpr (ctEvExpr ev) + +-- | Extract the set of rewriters from a 'CtEvidence' +-- See Note [Wanteds rewrite Wanteds] +-- If the provided CtEvidence is not for a Wanted, just +-- return an empty set. +ctEvRewriters :: CtEvidence -> RewriterSet +ctEvRewriters (CtWanted (WantedCt { ctev_rewriters = rws })) = rws +ctEvRewriters (CtGiven {}) = emptyRewriterSet + +ctHasNoRewriters :: Ct -> Bool +ctHasNoRewriters ev + = case ctEvidence ev of + CtWanted wev -> wantedCtHasNoRewriters wev + CtGiven {} -> True + +wantedCtHasNoRewriters :: WantedCtEvidence -> Bool +wantedCtHasNoRewriters (WantedCt { ctev_rewriters = rws }) + = isEmptyRewriterSet rws + +-- | Set the rewriter set of a Wanted constraint. +setWantedCtEvRewriters :: WantedCtEvidence -> RewriterSet -> WantedCtEvidence +setWantedCtEvRewriters ev rs = ev { ctev_rewriters = rs } + +ctEvExpr :: HasDebugCallStack => CtEvidence -> EvExpr +ctEvExpr (CtWanted ev@(WantedCt { ctev_dest = HoleDest _ })) + = Coercion $ ctEvCoercion (CtWanted ev) +ctEvExpr ev = evId (ctEvEvId ev) + +givenCtEvCoercion :: GivenCtEvidence -> TcCoercion +givenCtEvCoercion _given@(GivenCt { ctev_evar = ev_id }) + = assertPpr (isCoVar ev_id) + (text "givenCtEvCoercion used on non-equality Given constraint:" <+> ppr _given) + $ mkCoVarCo ev_id + +ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion +ctEvCoercion (CtGiven _given@(GivenCt { ctev_evar = ev_id })) + = assertPpr (isCoVar ev_id) + (text "ctEvCoercion used on non-equality Given constraint:" <+> ppr (CtGiven _given)) + $ mkCoVarCo ev_id +ctEvCoercion (CtWanted (WantedCt { ctev_dest = dest })) + | HoleDest hole <- dest + = -- ctEvCoercion is only called on type equalities + -- and they always have HoleDests + mkHoleCo hole +ctEvCoercion ev + = pprPanic "ctEvCoercion" (ppr ev) + +ctEvEvId :: CtEvidence -> EvVar +ctEvEvId (CtWanted wtd) = wantedCtEvEvId wtd +ctEvEvId (CtGiven (GivenCt { ctev_evar = ev })) = ev + +wantedCtEvEvId :: WantedCtEvidence -> EvVar +wantedCtEvEvId (WantedCt { ctev_dest = EvVarDest ev }) = ev +wantedCtEvEvId (WantedCt { ctev_dest = HoleDest h }) = coHoleCoVar h + +ctEvUnique :: CtEvidence -> Unique +ctEvUnique (CtGiven (GivenCt { ctev_evar = ev })) = varUnique ev +ctEvUnique (CtWanted (WantedCt { ctev_dest = dest })) = tcEvDestUnique dest + +tcEvDestUnique :: TcEvDest -> Unique +tcEvDestUnique (EvVarDest ev_var) = varUnique ev_var +tcEvDestUnique (HoleDest co_hole) = varUnique (coHoleCoVar co_hole) + +setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence +setCtEvLoc (CtGiven (GivenCt pred evar _)) loc = CtGiven (GivenCt pred evar loc) +setCtEvLoc (CtWanted (WantedCt pred dest _ rwrs)) loc = CtWanted (WantedCt pred dest loc rwrs) + +-- | Set the type of CtEvidence. +-- +-- This function ensures that the invariants on 'CtEvidence' hold, by updating +-- the evidence and the ctev_pred in sync with each other. +-- See Note [CtEvidence invariants]. +setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence +setCtEvPredType (CtGiven old_ev@(GivenCt { ctev_evar = ev })) new_pred + = CtGiven (old_ev { ctev_pred = new_pred + , ctev_evar = setVarType ev new_pred }) + +setCtEvPredType (CtWanted old_ev@(WantedCt { ctev_dest = dest })) new_pred + = CtWanted (old_ev { ctev_pred = new_pred + , ctev_dest = new_dest }) + where + new_dest = case dest of + EvVarDest ev -> EvVarDest (setVarType ev new_pred) + HoleDest h -> HoleDest (setCoHoleType h new_pred) + +instance Outputable TcEvDest where + ppr (HoleDest h) = text "hole" <> ppr h + ppr (EvVarDest ev) = ppr ev + +instance Outputable GivenCtEvidence where + ppr = ppr . CtGiven +instance Outputable WantedCtEvidence where + ppr = ppr . CtWanted + +instance Outputable CtEvidence where + ppr ev = ppr (ctEvFlavour ev) + <+> hang (pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)) <> pp_rewriters)) + -- Show the sub-goal depth too + 2 (dcolon <+> pprPredType (ctEvPred ev)) + where + pp_ev = case ev of + CtGiven ev -> ppr (ctev_evar ev) + CtWanted ev -> ppr (ctev_dest ev) + + rewriters = ctEvRewriters ev + pp_rewriters | isEmptyRewriterSet rewriters = empty + | otherwise = semi <> ppr rewriters + +isWanted :: CtEvidence -> Bool +isWanted (CtWanted {}) = True +isWanted _ = False + +isGiven :: CtEvidence -> Bool +isGiven (CtGiven {}) = True +isGiven _ = False + +{- +************************************************************************ +* * + RewriterSet +* * +************************************************************************ +-} + +-- | Stores a set of CoercionHoles that have been used to rewrite a constraint. +-- See Note [Wanteds rewrite Wanteds]. +newtype RewriterSet = RewriterSet (UniqSet CoercionHole) + deriving newtype (Outputable, Semigroup, Monoid) + +emptyRewriterSet :: RewriterSet +emptyRewriterSet = RewriterSet emptyUniqSet + +unitRewriterSet :: CoercionHole -> RewriterSet +unitRewriterSet = coerce (unitUniqSet @CoercionHole) + +unionRewriterSet :: RewriterSet -> RewriterSet -> RewriterSet +unionRewriterSet = coerce (unionUniqSets @CoercionHole) + +isEmptyRewriterSet :: RewriterSet -> Bool +isEmptyRewriterSet = coerce (isEmptyUniqSet @CoercionHole) + +addRewriter :: RewriterSet -> CoercionHole -> RewriterSet +addRewriter = coerce (addOneToUniqSet @CoercionHole) + +rewriterSetFromCts :: Bag Ct -> RewriterSet +-- Take a bag of Wanted equalities, and collect them as a RewriterSet +rewriterSetFromCts cts + = foldr add emptyRewriterSet cts + where + add ct rw_set = + case ctEvidence ct of + CtWanted (WantedCt { ctev_dest = HoleDest hole }) -> rw_set `addRewriter` hole + _ -> rw_set + +{- +************************************************************************ +* * + CtFlavour +* * +************************************************************************ +-} + +data CtFlavour + = Given -- we have evidence + | Wanted -- we want evidence + deriving Eq + +instance Outputable CtFlavour where + ppr Given = text "[G]" + ppr Wanted = text "[W]" + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtWanted {}) = Wanted +ctEvFlavour (CtGiven {}) = Given + +-- | Whether or not one 'Ct' can rewrite another is determined by its +-- flavour and its equality relation. See also +-- Note [Flavours with roles] in GHC.Tc.Solver.InertSet +type CtFlavourRole = (CtFlavour, EqRel) + +-- | Extract the flavour, role, and boxity from a 'CtEvidence' +ctEvFlavourRole :: HasDebugCallStack => CtEvidence -> CtFlavourRole +ctEvFlavourRole ev = (ctEvFlavour ev, ctEvRewriteEqRel ev) + +-- | Extract the flavour and role from a 'Ct' +eqCtFlavourRole :: EqCt -> CtFlavourRole +eqCtFlavourRole (EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) + = (ctEvFlavour ev, eq_rel) + +dictCtFlavourRole :: DictCt -> CtFlavourRole +dictCtFlavourRole (DictCt { di_ev = ev }) + = (ctEvFlavour ev, NomEq) + +-- | Extract the flavour and role from a 'Ct' +ctFlavourRole :: HasDebugCallStack => Ct -> CtFlavourRole +-- Uses short-cuts for the Role field, for special cases +ctFlavourRole (CDictCan di_ct) = dictCtFlavourRole di_ct +ctFlavourRole (CEqCan eq_ct) = eqCtFlavourRole eq_ct +ctFlavourRole ct = ctEvFlavourRole (ctEvidence ct) + +{- Note [eqCanRewrite] +~~~~~~~~~~~~~~~~~~~~~~ +(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form +lhs ~ ty) can be used to rewrite ct2. It must satisfy the properties of +a can-rewrite relation, see Definition [Can-rewrite relation] in +GHC.Tc.Solver.Monad. + +With the solver handling Coercible constraints like equality constraints, +the rewrite conditions must take role into account, never allowing +a representational equality to rewrite a nominal one. + +Note [Wanteds rewrite Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should one Wanted constraint be allowed to rewrite another? + +This example (along with #8450) suggests not: + f :: a -> Bool + f x = ( [x,'c'], [x,True] ) `seq` True +Here we get + [W] a ~ Char + [W] a ~ Bool +but we do not want to complain about Bool ~ Char! + +This example suggests yes (indexed-types/should_fail/T4093a): + type family Foo a + f :: (Foo e ~ Maybe e) => Foo e +In the ambiguity check, we get + [G] g1 :: Foo e ~ Maybe e + [W] w1 :: Foo alpha ~ Foo e + [W] w2 :: Foo alpha ~ Maybe alpha +w1 gets rewritten by the Given to become + [W] w3 :: Foo alpha ~ Maybe e +Now, the only way to make progress is to allow Wanteds to rewrite Wanteds. +Rewriting w3 with w2 gives us + [W] w4 :: Maybe alpha ~ Maybe e +which will soon get us to alpha := e and thence to victory. + +TL;DR we want equality saturation. + +We thus want Wanteds to rewrite Wanteds in order to accept more programs, +but we don't want Wanteds to rewrite Wanteds because doing so can create +inscrutable error messages. To solve this dilemma: + +* We allow Wanteds to rewrite Wanteds, but each Wanted tracks the set of Wanteds + it has been rewritten by, in its RewriterSet, stored in the ctev_rewriters + field of the CtWanted constructor of CtEvidence. (Only Wanteds have + RewriterSets.) + +* A RewriterSet is just a set of unfilled CoercionHoles. This is sufficient + because only equalities (evidenced by coercion holes) are used for rewriting; + other (dictionary) constraints cannot ever rewrite. + +* The rewriter (in e.g. GHC.Tc.Solver.Rewrite.rewrite) tracks and returns a RewriterSet, + consisting of the evidence (a CoercionHole) for any Wanted equalities used in + rewriting. + +* Then GHC.Tc.Solver.Solve.rewriteEvidence and GHC.Tc.Solver.Equality.rewriteEqEvidence + add this RewriterSet to the rewritten constraint's rewriter set. + +* We prevent the unifier from unifying any equality with a non-empty rewriter set; + unification effectively turns a Wanted into a Given, and we lose all tracking. + See (REWRITERS) in Note [Unification preconditions] in GHC.Tc.Utils.Unify and + Note [Unify only if the rewriter set is empty] in GHC.Solver.Equality. + +* In error reporting, we simply suppress any errors that have been rewritten + by /unsolved/ wanteds. This suppression happens in GHC.Tc.Errors.mkErrorItem, + which uses `GHC.Tc.Zonk.Type.zonkRewriterSet` to look through any filled + coercion holes. The idea is that we wish to report the "root cause" -- the + error that rewrote all the others. + +* In `selectNextWorkItem`, priorities equalities with no rewiters. See + Note [Prioritise Wanteds with empty RewriterSet] in GHC.Tc.Types.Constraint + wrinkle (PER1). + +* In error reporting, we prioritise Wanteds that have an empty RewriterSet: + see Note [Prioritise Wanteds with empty RewriterSet]. + +Let's continue our first example above: + + inert: [W] w1 :: a ~ Char + work: [W] w2 :: a ~ Bool + +Because Wanteds can rewrite Wanteds, w1 will rewrite w2, yielding + + inert: [W] w1 :: a ~ Char + [W] w2 {w1}:: Char ~ Bool + +The {w1} in the second line of output is the RewriterSet of w1. + +Wrinkles: + +(WRW1) When we find a constraint identical to one already in the inert set, + we solve one from the other. Other things being equal, keep the one + that has fewer (better still no) rewriters. + See (CE4) in Note [Combining equalities] in GHC.Tc.Solver.Equality. + + To this accurately we should use `zonkRewriterSet` during canonicalisation, + to eliminate rewriters that have now been solved. Currently we only do so + during error reporting; but perhaps we should change that. + +(WRW2) When zonking a constraint (with `zonkCt` and `zonkCtEvidence`) we take + the opportunity to zonk its `RewriterSet`, which eliminates solved ones. + This doesn't guarantee that rewriter sets are always up to date -- see + (WRW1) -- but it helps, and it de-clutters debug output. + +Note [Prioritise Wanteds with empty RewriterSet] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When extending the WorkList, in GHC.Tc.Solver.InertSet.extendWorkListEq, +we prioritise constraints that have no rewriters. Here's why. + +Consider this, which came up in T22793: + inert: {} + work list: [W] co_ayf : awq ~ awo + work item: [W] co_ayb : awq ~ awp + + ==> {just put work item in inert set} + inert: co_ayb : awq ~ awp + work list: {} + work: [W] co_ayf : awq ~ awo + + ==> {rewrite ayf with co_ayb} + work list: {} + inert: co_ayb : awq ~ awp + co_aym{co_ayb} : awp ~ awo + ^ rewritten by ayb + + ----- start again in simplify_loop in Solver.hs ----- + inert: {} + work list: [W] co_ayb : awq ~ awp + work: co_aym{co_ayb} : awp ~ awo + + ==> {add to inert set} + inert: co_aym{co_ayb} : awp ~ awo + work list: {} + work: co_ayb : awq ~ awp + + ==> {rewrite co_ayb} + inert: co_aym{co_ayb} : awp ~ awo + co_ayp{co_aym} : awq ~ awo + work list: {} + +Now both wanteds have been rewriten by the other! This happened because +in our simplify_loop iteration, we happened to start with co_aym. All would have +been well if we'd started with the (not-rewritten) co_ayb and gotten it into the +inert set. + +With that in mind, we /prioritise/ the work-list to put +constraints with no rewriters first. This prioritisation +is done in `GHC.Tc.Solver.Monad.selectNextWorkItem`. + +Wrinkles + +(PER1) When picking the next work item, before checking for an empty RewriterSet + in GHC.Tc.Solver.Monad.selectNextWorkItem, we zonk the RewriterSet, because + some of those CoercionHoles may have been filled in since we last looked. + +(PER2) Despite the prioritisation, it is hard to be /certain/ that we can't end up + in a situation where all of the Wanteds have rewritten each other. In + order to report /some/ error in this case, we simply report all the + Wanteds. The user will get a perhaps-confusing error message, but they've + written a confusing program! (T22707 and T22793 were close, but they do + not exhibit this behaviour.) So belt and braces: see the `suppress` + stuff in GHC.Tc.Errors.mkErrorItem. + +Note [Avoiding rewriting cycles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet describes +the can-rewrite relation among CtFlavour/Role pairs, saying which constraints +can rewrite which other constraints. It puts forth (R2): + (R2) If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 +The naive can-rewrite relation says that (Given, Representational) can rewrite +(Wanted, Representational) and that (Wanted, Nominal) can rewrite +(Wanted, Representational), but neither of (Given, Representational) and +(Wanted, Nominal) can rewrite the other. This would violate (R2). See also +Note [Why R2?] in GHC.Tc.Solver.InertSet. + +To keep R2, we do not allow (Wanted, Nominal) to rewrite (Wanted, Representational). +This can, in theory, bite, in this scenario: + + type family F a + data T a + type role T nominal + + [G] F a ~N T a + [W] F alpha ~N T alpha + [W] F alpha ~R T a + +As written, this makes no progress, and GHC errors. But, if we +allowed W/N to rewrite W/R, the first W could rewrite the second: + + [G] F a ~N T a + [W] F alpha ~N T alpha + [W] T alpha ~R T a + +Now we decompose the second W to get + + [W] alpha ~N a + +noting the role annotation on T. This causes (alpha := a), and then +everything else unlocks. + +What to do? We could "decompose" nominal equalities into nominal-only +("NO") equalities and representational ones, where a NO equality rewrites +only nominals. That is, when considering whether [W] F alpha ~N T alpha +should rewrite [W] F alpha ~R T a, we could require splitting the first W +into [W] F alpha ~NO T alpha, [W] F alpha ~R T alpha. Then, we use the R +half of the split to rewrite the second W, and off we go. This splitting +would allow the split-off R equality to be rewritten by other equalities, +thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.InertSet. + +However, note that I said that this bites in theory. That's because no +known program actually gives rise to this scenario. A direct encoding +ends up starting with + + [G] F a ~ T a + [W] F alpha ~ T alpha + [W] Coercible (F alpha) (T a) + +where ~ and Coercible denote lifted class constraints. The ~s quickly +reduce to ~N: good. But the Coercible constraint gets rewritten to + + [W] Coercible (T alpha) (T a) + +by the first Wanted. This is because Coercible is a class, and arguments +in class constraints use *nominal* rewriting, not the representational +rewriting that is restricted due to (R2). Note that reordering the code +doesn't help, because equalities (including lifted ones) are prioritized +over Coercible. Thus, I (Richard E.) see no way to write a program that +is rejected because of this infelicity. I have not proved it impossible, +exactly, but my usual tricks have not yielded results. + +In the olden days, when we had Derived constraints, this Note was all +about G/R and D/N both rewriting D/R. Back then, the code in +typecheck/should_compile/T19665 really did get rejected. But now, +according to the rewriting of the Coercible constraint, the program +is accepted. + +-} + +eqCanRewrite :: EqRel -> EqRel -> Bool +eqCanRewrite NomEq _ = True +eqCanRewrite ReprEq ReprEq = True +eqCanRewrite ReprEq NomEq = False + +eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Can fr1 actually rewrite fr2? +-- Very important function! +-- See Note [eqCanRewrite] +-- See Note [Wanteds rewrite Wanteds] +-- See Note [Avoiding rewriting cycles] +eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted, NomEq) (Wanted, ReprEq) = False +eqCanRewriteFR (Wanted, r1) (Wanted, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted, _) (Given, _) = False diff --git a/GHC/Tc/Types/CtLoc.hs b/GHC/Tc/Types/CtLoc.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/CtLoc.hs @@ -0,0 +1,259 @@ +module GHC.Tc.Types.CtLoc ( + + -- * CtLoc + CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, + ctLocTypeOrKind_maybe, toInvisibleLoc, + ctLocDepth, bumpCtLocDepth, isGivenLoc, mkGivenLoc, mkKindEqLoc, + setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, + pprCtLoc, adjustCtLoc, adjustCtLocTyConBinder, + + -- * CtLocEnv + CtLocEnv(..), + getCtLocEnvLoc, setCtLocEnvLoc, setCtLocRealLoc, + getCtLocEnvLvl, setCtLocEnvLvl, + ctLocEnvInGeneratedCode, + + -- * SubGoalDepth + SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, + bumpSubGoalDepth, subGoalDepthExceeded + + ) where + +import GHC.Prelude + +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Origin + +import GHC.Tc.Utils.TcType + +import GHC.Types.SrcLoc +import GHC.Types.Name.Reader +import GHC.Types.Basic( IntWithInf, mkIntWithInf, TypeOrKind(..) ) + +import GHC.Core.TyCon( TyConBinder, isVisibleTyConBinder, isNamedTyConBinder ) + +import GHC.Utils.Outputable + + +{- ********************************************************************* +* * + SubGoalDepth +* * +********************************************************************* -} + +{- Note [SubGoalDepth] +~~~~~~~~~~~~~~~~~~~~~~ +The 'SubGoalDepth' takes care of stopping the constraint solver from looping. + +The counter starts at zero and increases. It includes dictionary constraints, +equality simplification, and type family reduction. (Why combine these? Because +it's actually quite easy to mistake one for another, in sufficiently involved +scenarios, like ConstraintKinds.) + +The flag -freduction-depth=n fixes the maximum level. + +* The counter includes the depth of type class instance declarations. Example: + [W] d{7} : Eq [Int] + That is d's dictionary-constraint depth is 7. If we use the instance + $dfEqList :: Eq a => Eq [a] + to simplify it, we get + d{7} = $dfEqList d'{8} + where d'{8} : Eq Int, and d' has depth 8. + + For civilised (decidable) instance declarations, each increase of + depth removes a type constructor from the type, so the depth never + gets big; i.e. is bounded by the structural depth of the type. + +* The counter also increments when resolving +equalities involving type functions. Example: + Assume we have a wanted at depth 7: + [W] d{7} : F () ~ a + If there is a type function equation "F () = Int", this would be rewritten to + [W] d{8} : Int ~ a + and remembered as having depth 8. + + Again, without UndecidableInstances, this counter is bounded, but without it + can resolve things ad infinitum. Hence there is a maximum level. + +* Lastly, every time an equality is rewritten, the counter increases. Again, + rewriting an equality constraint normally makes progress, but it's possible + the "progress" is just the reduction of an infinitely-reducing type family. + Hence we need to track the rewrites. + +When compiling a program requires a greater depth, then GHC recommends turning +off this check entirely by setting -freduction-depth=0. This is because the +exact number that works is highly variable, and is likely to change even between +minor releases. Because this check is solely to prevent infinite compilation +times, it seems safe to disable it when a user has ascertained that their program +doesn't loop at the type level. + +-} + +-- | See Note [SubGoalDepth] +newtype SubGoalDepth = SubGoalDepth Int + deriving (Eq, Ord, Outputable) + +initialSubGoalDepth :: SubGoalDepth +initialSubGoalDepth = SubGoalDepth 0 + +bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth +bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) + +maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth +maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) + +subGoalDepthExceeded :: IntWithInf -> SubGoalDepth -> Bool +subGoalDepthExceeded reductionDepth (SubGoalDepth d) + = mkIntWithInf d > reductionDepth + + +{- ********************************************************************* +* * + CtLoc +* * +************************************************************************ + +The 'CtLoc' gives information about where a constraint came from. +This is important for decent error message reporting because +dictionaries don't appear in the original source code. + +-} + +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: CtLocEnv -- Everything we need to know about + -- the context this Ct arose in. + , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure + , ctl_depth :: !SubGoalDepth } + +mkKindEqLoc :: TcType -> TcType -- original *types* being compared + -> CtLoc -> CtLoc +mkKindEqLoc s1 s2 ctloc + | CtLoc { ctl_t_or_k = t_or_k, ctl_origin = origin } <- ctloc + = ctloc { ctl_origin = KindEqOrigin s1 s2 origin t_or_k + , ctl_t_or_k = Just KindLevel } + +adjustCtLocTyConBinder :: TyConBinder -> CtLoc -> CtLoc +-- Adjust the CtLoc when decomposing a type constructor +adjustCtLocTyConBinder tc_bndr loc + = adjustCtLoc is_vis is_kind loc + where + is_vis = isVisibleTyConBinder tc_bndr + is_kind = isNamedTyConBinder tc_bndr + +adjustCtLoc :: Bool -- True <=> A visible argument + -> Bool -- True <=> A kind argument + -> CtLoc -> CtLoc +-- Adjust the CtLoc when decomposing a type constructor, application, etc +adjustCtLoc is_vis is_kind loc + = loc2 + where + loc1 | is_kind = toKindLoc loc + | otherwise = loc + loc2 | is_vis = loc1 + | otherwise = toInvisibleLoc loc1 + +-- | Take a CtLoc and moves it to the kind level +toKindLoc :: CtLoc -> CtLoc +toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } + +toInvisibleLoc :: CtLoc -> CtLoc +toInvisibleLoc loc = updateCtLocOrigin loc toInvisibleOrigin + +mkGivenLoc :: TcLevel -> SkolemInfoAnon -> CtLocEnv -> CtLoc +mkGivenLoc tclvl skol_info env + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = setCtLocEnvLvl env tclvl + , ctl_t_or_k = Nothing -- this only matters for error msgs + , ctl_depth = initialSubGoalDepth } + +ctLocEnv :: CtLoc -> CtLocEnv +ctLocEnv = ctl_env + +ctLocLevel :: CtLoc -> TcLevel +ctLocLevel loc = getCtLocEnvLvl (ctLocEnv loc) + +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth + +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin + +ctLocSpan :: CtLoc -> RealSrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = getCtLocEnvLoc lcl + +ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind +ctLocTypeOrKind_maybe = ctl_t_or_k + +setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc +setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (setCtLocRealLoc lcl loc) + +bumpCtLocDepth :: CtLoc -> CtLoc +bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } + +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } + +updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc +updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd + = ctl { ctl_origin = upd orig } + +setCtLocEnv :: CtLoc -> CtLocEnv -> CtLoc +setCtLocEnv ctl env = ctl { ctl_env = env } + +isGivenLoc :: CtLoc -> Bool +isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) + +pprCtLoc :: CtLoc -> SDoc +-- "arising from ... at ..." +-- Not an instance of Outputable because of the "arising from" prefix +pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ pprCtOrigin o + , text "at" <+> ppr (getCtLocEnvLoc lcl)] + + +{- ********************************************************************* +* * + CtLocEnv +* * +********************************************************************* -} + +-- | Local typechecker environment for a constraint. +-- +-- Used to restore the environment of a constraint +-- when reporting errors, see `setCtLocM`. +-- +-- See also 'TcLclCtxt'. +data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt] + , ctl_loc :: !RealSrcSpan + , ctl_bndrs :: !TcBinderStack + , ctl_tclvl :: !TcLevel + , ctl_in_gen_code :: !Bool + , ctl_rdr :: !LocalRdrEnv } + +getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan +getCtLocEnvLoc = ctl_loc + +getCtLocEnvLvl :: CtLocEnv -> TcLevel +getCtLocEnvLvl = ctl_tclvl + +setCtLocEnvLvl :: CtLocEnv -> TcLevel -> CtLocEnv +setCtLocEnvLvl env lvl = env { ctl_tclvl = lvl } + +setCtLocRealLoc :: CtLocEnv -> RealSrcSpan -> CtLocEnv +setCtLocRealLoc env ss = env { ctl_loc = ss } + +setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv +-- See Note [Error contexts in generated code] +-- for the ctl_in_gen_code manipulation +setCtLocEnvLoc env (RealSrcSpan loc _) + = env { ctl_loc = loc, ctl_in_gen_code = False } + +setCtLocEnvLoc env loc@(UnhelpfulSpan _) + | isGeneratedSrcSpan loc + = env { ctl_in_gen_code = True } + | otherwise + = env + +ctLocEnvInGeneratedCode :: CtLocEnv -> Bool +ctLocEnvInGeneratedCode = ctl_in_gen_code diff --git a/GHC/Tc/Types/CtLocEnv.hs b/GHC/Tc/Types/CtLocEnv.hs deleted file mode 100644 --- a/GHC/Tc/Types/CtLocEnv.hs +++ /dev/null @@ -1,60 +0,0 @@ -module GHC.Tc.Types.CtLocEnv ( - CtLocEnv(..) - , getCtLocEnvLoc - , getCtLocEnvLvl - , setCtLocEnvLvl - , setCtLocRealLoc - , setCtLocEnvLoc - , ctLocEnvInGeneratedCode - ) where - -import GHC.Prelude - -import GHC.Types.SrcLoc -import GHC.Types.Name.Reader - -import GHC.Tc.Types.BasicTypes -import GHC.Tc.Utils.TcType -import GHC.Tc.Types.ErrCtxt - - --- | Local typechecker environment for a constraint. --- --- Used to restore the environment of a constraint --- when reporting errors, see `setCtLocM`. --- --- See also 'TcLclCtxt'. -data CtLocEnv = CtLocEnv { ctl_ctxt :: ![ErrCtxt] - , ctl_loc :: !RealSrcSpan - , ctl_bndrs :: !TcBinderStack - , ctl_tclvl :: !TcLevel - , ctl_in_gen_code :: !Bool - , ctl_rdr :: !LocalRdrEnv } - - -getCtLocEnvLoc :: CtLocEnv -> RealSrcSpan -getCtLocEnvLoc = ctl_loc - -getCtLocEnvLvl :: CtLocEnv -> TcLevel -getCtLocEnvLvl = ctl_tclvl - -setCtLocEnvLvl :: CtLocEnv -> TcLevel -> CtLocEnv -setCtLocEnvLvl env lvl = env { ctl_tclvl = lvl } - -setCtLocRealLoc :: CtLocEnv -> RealSrcSpan -> CtLocEnv -setCtLocRealLoc env ss = env { ctl_loc = ss } - -setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv --- See Note [Error contexts in generated code] --- for the ctl_in_gen_code manipulation -setCtLocEnvLoc env (RealSrcSpan loc _) - = env { ctl_loc = loc, ctl_in_gen_code = False } - -setCtLocEnvLoc env loc@(UnhelpfulSpan _) - | isGeneratedSrcSpan loc - = env { ctl_in_gen_code = True } - | otherwise - = env - -ctLocEnvInGeneratedCode :: CtLocEnv -> Bool -ctLocEnvInGeneratedCode = ctl_in_gen_code diff --git a/GHC/Tc/Types/ErrCtxt.hs b/GHC/Tc/Types/ErrCtxt.hs --- a/GHC/Tc/Types/ErrCtxt.hs +++ b/GHC/Tc/Types/ErrCtxt.hs @@ -1,16 +1,223 @@ -module GHC.Tc.Types.ErrCtxt where +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +module GHC.Tc.Types.ErrCtxt + ( ErrCtxt, ErrCtxtMsg(..) + , UserSigType(..), FunAppCtxtFunArg(..) + , TyConInstFlavour(..) + ) + where + import GHC.Prelude -import GHC.Types.Var.Env -import GHC.Tc.Zonk.Monad (ZonkM) -import GHC.Utils.Outputable +import GHC.Hs.Expr +import GHC.Hs.Extension +import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) + +import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) +import GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin ) +import GHC.Tc.Utils.TcType ( TcType, TcTyCon ) +import GHC.Tc.Zonk.Monad ( ZonkM ) + +import GHC.Types.Basic ( TyConFlavour ) +import GHC.Types.Name ( Name ) +import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Types.Var ( Id, TyCoVar ) +import GHC.Types.Var.Env ( TidyEnv ) + +import GHC.Unit.Types ( Module, InstantiatedModule ) + +import GHC.Core.Class ( Class ) +import GHC.Core.ConLike ( ConLike ) +import GHC.Core.PatSyn ( PatSyn ) +import GHC.Core.TyCon ( TyCon ) +import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType ) + +import GHC.Unit.State ( UnitState ) + +import GHC.Data.FastString ( FastString ) +import GHC.Utils.Outputable ( Outputable(..) ) + +import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) +import Language.Haskell.Syntax +import GHC.Boot.TH.Syntax qualified as TH + +import qualified Data.List.NonEmpty as NE + +-------------------------------------------------------------------------------- + -- | Additional context to include in an error message, e.g. -- "In the type signature ...", "In the ambiguity check for ...", etc. -type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, SDoc)) +type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction -- Bool: True <=> this is a landmark context; do not -- discard it when trimming for display + +-------------------------------------------------------------------------------- +-- Error message contexts + +data UserSigType p + = UserLHsSigType !(LHsSigType p) + | UserLHsType !(LHsType p) + +instance OutputableBndrId p => Outputable (UserSigType (GhcPass p)) where + ppr (UserLHsSigType ty) = ppr ty + ppr (UserLHsType ty) = ppr ty + +data FunAppCtxtFunArg + = FunAppCtxtExpr !(HsExpr GhcRn) !(HsExpr GhcRn) + | FunAppCtxtTy !(LHsType GhcRn) !(LHsType GhcRn) + +-- | Like 'TyConFlavour' but for instance declarations, with +-- the additional information of whether this we are dealing with +-- a default declaration. +data TyConInstFlavour + = TyConInstFlavour + { tyConInstFlavour :: !(TyConFlavour TyCon) + , tyConInstIsDefault :: !Bool + } + +-- | The "context" of an error message, e.g. "In the expression <...>", +-- "In the pattern <...>", or "In the equations for closed type family <...>". +data ErrCtxtMsg + -- | In an expression. + = ExprCtxt !(HsExpr GhcRn) + -- | In a user-written context. + | ThetaCtxt !UserTypeCtxt !ThetaType + -- | In a quantified constraint. + | QuantifiedCtCtxt !PredType + -- | When checking an inferred type. + | InferredTypeCtxt !Name !TcType + -- | In an inline pragma, or a fixity signature, + -- or a type signature, or... (see 'Sig'). + | SigCtxt !(Sig GhcRn) + -- | In a user-written type signature. + | UserSigCtxt !UserTypeCtxt !(UserSigType GhcRn) + -- | In a record update. + | RecordUpdCtxt !(NE.NonEmpty ConLike) ![Name] ![TyCoVar] + -- | In a class method. + | ClassOpCtxt !Id !Type + -- | In the instance type signature of a class method. + | MethSigCtxt !Name !TcType !TcType + -- | In a pattern type signature. + | PatSigErrCtxt !TcType !TcType + -- | In a pattern. + | PatCtxt !(Pat GhcRn) + -- | In a pattern synonym declaration. + | PatSynDeclCtxt !Name + -- | In a pattern matching context, e.g. a equation for a function binding, + -- or a case alternative, ... + | MatchCtxt !HsMatchContextRn + -- | In a match in a pattern matching context, + -- either for an expression or for an arrow command. + | forall body. (Outputable body) + => MatchInCtxt !(Match GhcRn body) + -- | In a function application. + | FunAppCtxt !FunAppCtxtFunArg !Int + -- | In a function call. + | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int + -- | In the result of a function call. + | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int + -- | In the declaration of a type constructor. + | TyConDeclCtxt !Name !(TyConFlavour TyCon) + -- | In a type or data family instance (or default instance). + | TyConInstCtxt !Name !TyConInstFlavour + -- | In the declaration of a data constructor. + | DataConDefCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the result type of a data constructor. + | DataConResTyCtxt !(NE.NonEmpty (LocatedN Name)) + -- | In the equations for a closed type family. + | ClosedFamEqnCtxt !TyCon + -- | In the expansion of a type synonym. + | TySynErrCtxt !TyCon + -- | In a role annotation. + | RoleAnnotErrCtxt !Name + -- | In an arrow command. + | CmdCtxt !(HsCmd GhcRn) + -- | In an instance declaration. + | InstDeclErrCtxt !(Either (LHsType GhcRn) PredType) + -- | In a default declaration. + | DefaultDeclErrCtxt { ddec_in_type_list :: !Bool } + -- | In the body of a static form. + | StaticFormCtxt !(LHsExpr GhcRn) + -- | In a pattern binding. + | forall p. OutputableBndrId p + => PatMonoBindsCtxt !(LPat (GhcPass p)) !(GRHSs GhcRn (LHsExpr GhcRn)) + -- | In a foreign import/export declaration. + | ForeignDeclCtxt !(ForeignDecl GhcRn) + -- | In a record field. + | FieldCtxt !FieldLabelString + -- | In a type. + | TypeCtxt !(LHsType GhcRn) + -- | In a kind. + | KindCtxt !(LHsKind GhcRn) + -- | In an ambiguity check. + | AmbiguityCheckCtxt !UserTypeCtxt !Bool + + -- | In a term-level use of a 'Name'. + | TermLevelUseCtxt !Name !TermLevelUseCtxt + + -- | When checking the type of the @main@ function. + | MainCtxt !Name + -- | Warning emitted when inferring use of visible dependent quantification. + | VDQWarningCtxt !TcTyCon + + -- | In a statement. + | forall body. + ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA + , Outputable body + ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body) + + -- | In an rebindable syntax expression. + | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan + -- | In a RULE. + | RuleCtxt !FastString + -- | In a subtype check. + | SubTypeCtxt !TcType !TcType + + -- | In an export. + | forall p. OutputableBndrId p + => ExportCtxt (IE (GhcPass p)) + -- | In an export of a pattern synonym. + | PatSynExportCtxt !PatSyn + -- | In an export of a pattern synonym record field. + | PatSynRecSelExportCtxt !PatSyn !Name + + -- | In an annotation. + | forall p. OutputableBndrId p + => AnnCtxt (AnnDecl (GhcPass p)) + + -- | In a specialise pragma. + | SpecPragmaCtxt !(Sig GhcRn) + + -- | In a deriving clause. + | DerivInstCtxt !PredType + -- | In a standalone deriving clause. + | StandaloneDerivCtxt !(LHsSigWcType GhcRn) + -- | When typechecking the body of a derived instance. + | DerivBindCtxt !Id !Class ![Type] + + -- | In an untyped Template Haskell quote. + | UntypedTHBracketCtxt !(HsQuote GhcPs) + -- | In a typed Template Haskell quote. + | forall p. OutputableBndrId p + => TypedTHBracketCtxt !(LHsExpr (GhcPass p)) + -- | In an untyped Template Haskell splice or quasi-quote. + | UntypedSpliceCtxt !(HsUntypedSplice GhcPs) + -- | In a typed Template Haskell splice. + | forall p. OutputableBndrId p + => TypedSpliceCtxt !(Maybe SplicePointName) !(HsTypedSplice (GhcPass p)) + -- | In the result of a typed Template Haskell splice. + | TypedSpliceResultCtxt !(LHsExpr GhcTc) + -- | In an argument to the Template Haskell @reifyInstances@ function. + | ReifyInstancesCtxt !TH.Name ![TH.Type] + + -- | While merging Backpack signatures. + | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule] + -- | While checking that a module implements a Backpack signature. + | CheckImplementsCtxt !UnitState !Module !InstantiatedModule diff --git a/GHC/Tc/Types/EvTerm.hs b/GHC/Tc/Types/EvTerm.hs deleted file mode 100644 --- a/GHC/Tc/Types/EvTerm.hs +++ /dev/null @@ -1,74 +0,0 @@ - --- (those who have too heavy dependencies for GHC.Tc.Types.Evidence) -module GHC.Tc.Types.EvTerm - ( evDelayedError, evCallStack ) -where - -import GHC.Prelude - -import GHC.Driver.DynFlags - -import GHC.Tc.Types.Evidence - -import GHC.Unit - -import GHC.Builtin.Names -import GHC.Builtin.Types ( unitTy ) - -import GHC.Core.Type -import GHC.Core -import GHC.Core.Make -import GHC.Core.Utils - -import GHC.Types.SrcLoc -import GHC.Types.TyThing - --- Used with Opt_DeferTypeErrors --- See Note [Deferring coercion errors to runtime] --- in GHC.Tc.Solver -evDelayedError :: Type -> String -> EvTerm -evDelayedError ty msg - = EvExpr $ - let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg - in mkWildCase fail_expr (unrestricted unitTy) ty [] - -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils - -- c.f. mkErrorAppDs in GHC.HsToCore.Utils - --- Dictionary for CallStack implicit parameters -evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) => - EvCallStack -> m EvExpr --- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence -evCallStack cs = do - df <- getDynFlags - let platform = targetPlatform df - m <- getModule - srcLocDataCon <- lookupDataCon srcLocDataConName - let mkSrcLoc l = mkCoreConApps srcLocDataCon <$> - sequence [ mkStringExprFS (unitFS $ moduleUnit m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) - , return $ mkIntExprInt platform (srcSpanStartLine l) - , return $ mkIntExprInt platform (srcSpanStartCol l) - , return $ mkIntExprInt platform (srcSpanEndLine l) - , return $ mkIntExprInt platform (srcSpanEndCol l) - ] - - emptyCS <- Var <$> lookupId emptyCallStackName - - pushCSVar <- lookupId pushCallStackName - let pushCS name loc rest = - mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] - - let mkPush name loc tm = do - nameExpr <- mkStringExprFS name - locExpr <- mkSrcLoc loc - -- at this point tm :: IP sym CallStack - -- but we need the actual CallStack to pass to pushCS, - -- so we use unwrapIP to strip the dictionary wrapper - -- See Note [Overview of implicit CallStacks] - let ip_co = unwrapIP (exprType tm) - return (pushCS nameExpr locExpr (Cast tm ip_co)) - - case cs of - EvCsPushCall fs loc tm -> mkPush fs loc tm - EvCsEmpty -> return emptyCS diff --git a/GHC/Tc/Types/Evidence.hs b/GHC/Tc/Types/Evidence.hs --- a/GHC/Tc/Types/Evidence.hs +++ b/GHC/Tc/Types/Evidence.hs @@ -7,7 +7,7 @@ -- * HsWrapper HsWrapper(..), - (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast, mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, @@ -15,7 +15,7 @@ -- * Evidence bindings TcEvBinds(..), EvBindsVar(..), - EvBindMap(..), emptyEvBindMap, extendEvBinds, + EvBindMap(..), emptyEvBindMap, extendEvBinds, unionEvBindMap, lookupEvBind, evBindMapBinds, foldEvBindMap, nonDetStrictFoldEvBindMap, filterEvBindMap, @@ -27,10 +27,14 @@ -- * EvTerm (already a CoreExpr) EvTerm(..), EvExpr, - evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector, - mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, + evId, evCoercion, evCast, evCastE, evDFunApp, evDictApp, evSelector, evDelayedError, + mkEvScSelectors, evTypeable, + evWrapIPE, evUnwrapIPE, evUnaryDictAppE, + mkEvCast, + nestedEvIdsOfTerm, evTermFVs, evTermCoercion, evTermCoercion_maybe, + evExprCoercion, evExprCoercion_maybe, EvCallStack(..), EvTypeable(..), @@ -42,7 +46,6 @@ TcMCoercion, TcMCoercionN, TcMCoercionR, Role(..), LeftOrRight(..), pickLR, maybeSymCo, - unwrapIP, wrapIP, -- * QuoteWrapper QuoteWrapper(..), applyQuoteWrapper, quoteWrapperTyVarTy @@ -50,28 +53,35 @@ import GHC.Prelude -import GHC.Types.Unique.DFM -import GHC.Types.Unique.FM -import GHC.Types.Var -import GHC.Types.Id( idScaledType ) +import GHC.Tc.Utils.TcType + +import GHC.Core import GHC.Core.Coercion.Axiom import GHC.Core.Coercion import GHC.Core.Ppr () -- Instance OutputableBndr TyVar -import GHC.Tc.Utils.TcType +import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.TyCon -import GHC.Core.DataCon ( DataCon, dataConWrapId ) -import GHC.Builtin.Names +import GHC.Core.Make ( mkWildCase, mkRuntimeErrorApp, tYPE_ERROR_ID ) +import GHC.Core.Class ( classTyCon ) +import GHC.Core.DataCon ( dataConWrapId ) +import GHC.Core.Class (Class, classSCSelId ) +import GHC.Core.FVs +import GHC.Core.InstEnv ( CanonicalEvidence(..) ) + +import GHC.Types.Unique.DFM +import GHC.Types.Unique.FM +import GHC.Types.Name( isInternalName ) +import GHC.Types.Var +import GHC.Types.Id( idScaledType ) import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Core.Predicate import GHC.Types.Basic -import GHC.Core -import GHC.Core.Class (Class, classSCSelId ) -import GHC.Core.FVs ( exprSomeFreeVars ) -import GHC.Core.InstEnv ( Canonical ) +import GHC.Builtin.Names +import GHC.Builtin.Types( unitTy ) +import GHC.Utils.FV import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable @@ -110,6 +120,7 @@ type TcMCoercionN = MCoercionN -- nominal type TcMCoercionR = MCoercionR -- representational + -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion maybeSymCo IsSwapped co = mkSymCo co @@ -171,10 +182,6 @@ | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, -- so that the identity coercion is always exactly WpHole - - | WpMultCoercion Coercion -- Require that a Coercion be reflexive; otherwise, - -- error in the desugarer. See GHC.Tc.Utils.Unify - -- Note [Wrapper returned from tcSubMult] deriving Data.Data -- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data @@ -197,28 +204,44 @@ mempty = WpHole (<.>) :: HsWrapper -> HsWrapper -> HsWrapper -WpHole <.> c = c -c <.> WpHole = c -c1 <.> c2 = c1 `WpCompose` c2 +WpHole <.> c = c +c <.> WpHole = c +WpCast c1 <.> WpCast c2 = WpCast (c1 `mkTransCo` c2) + -- If we can represent the HsWrapper as a cast, try to do so: this may avoid + -- unnecessary eta-expansion (see 'mkWpFun'). +c1 <.> c2 = c1 `WpCompose` c2 --- | Smart constructor to create a 'WpFun' 'HsWrapper'. +-- | Smart constructor to create a 'WpFun' 'HsWrapper', which avoids introducing +-- a lambda abstraction if the two supplied wrappers are either identities or +-- casts. -- --- PRECONDITION: the "from" type of the first wrapper must have a syntactically --- fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). +-- PRECONDITION: either: +-- +-- 1. both of the 'HsWrapper's are identities or casts, or +-- 2. both the "from" and "to" types of the first wrapper have a syntactically +-- fixed RuntimeRep (see Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). mkWpFun :: HsWrapper -> HsWrapper -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper - -- MUST have a fixed RuntimeRep -> TcType -- ^ Either "from" type or "to" type of the second wrapper -- (used only when the second wrapper is the identity) -> HsWrapper - -- NB: we can't check that the argument type has a fixed RuntimeRep with an assertion, - -- because of [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] - -- in GHC.Tc.Utils.Concrete. mkWpFun WpHole WpHole _ _ = WpHole mkWpFun WpHole (WpCast co2) (Scaled w t1) _ = WpCast (mk_wp_fun_co w (mkRepReflCo t1) co2) mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mk_wp_fun_co w (mkSymCo co1) (mkRepReflCo t2)) mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mk_wp_fun_co w (mkSymCo co1) co2) -mkWpFun co1 co2 t1 _ = WpFun co1 co2 t1 +mkWpFun w_arg w_res t1 _ = + -- In this case, we will desugar to a lambda + -- + -- \x. w_res[ e w_arg[x] ] + -- + -- To satisfy Note [Representation polymorphism invariants] in GHC.Core, + -- it must be the case that both the lambda bound variable x and the function + -- argument w_arg[x] have a fixed runtime representation, i.e. that both the + -- "from" and "to" types of the first wrapper "w_arg" have a fixed runtime representation. + -- + -- Unfortunately, we can't check this with an assertion here, because of + -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + WpFun w_arg w_res t1 mkWpEta :: [Id] -> HsWrapper -> HsWrapper -- (mkWpEta [x1, x2] wrap) [e] @@ -258,6 +281,16 @@ mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids +-- mkWpForAllCast [tv{vis}] constructs a cast +-- forall tv. res ~R# forall tv{vis} res`. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep +-- +-- It's a no-op if all binders are invisible; +-- but in that case we refrain from calling it. +mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper +mkWpForAllCast bndrs res_ty + = mkWpCastR (mkForAllVisCos bndrs (mkRepReflCo res_ty)) + mkWpEvLams :: [Var] -> HsWrapper mkWpEvLams ids = mk_co_lam_fn WpEvLam ids @@ -301,7 +334,6 @@ go (WpTyLam {}) = emptyBag go (WpTyApp {}) = emptyBag go (WpLet {}) = emptyBag - go (WpMultCoercion {}) = emptyBag collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) -- Collect the outer lambda binders of a HsWrapper, @@ -346,11 +378,13 @@ -- (dictionaries etc) -- Some Given, some Wanted - ebv_tcvs :: IORef CoVarSet - -- The free Given coercion vars needed by Wanted coercions that - -- are solved by filling in their HoleDest in-place. Since they - -- don't appear in ebv_binds, we keep track of their free - -- variables so that we can report unused given constraints + ebv_tcvs :: IORef [TcCoercion] + -- When we solve a Wanted by filling in a CoercionHole, it is as + -- if we were adding an evidence binding + -- co_hole := coercion + -- We keep all these RHS coercions in a list, alongside `ebv_binds`, + -- so that we can report unused given constraints, + -- in GHC.Tc.Solver.neededEvVars -- See Note [Tracking redundant constraints] in GHC.Tc.Solver } @@ -358,14 +392,19 @@ -- See above for comments on ebv_uniq, ebv_tcvs ebv_uniq :: Unique, - ebv_tcvs :: IORef CoVarSet + ebv_tcvs :: IORef [TcCoercion] } instance Data.Data TcEvBinds where - -- Placeholder; we can't travers into TcEvBinds + -- Placeholder; we can't traverse into TcEvBinds toConstr _ = abstractConstr "TcEvBinds" gunfold _ _ = error "gunfold" dataTypeOf _ = Data.mkNoRepType "TcEvBinds" +instance Data.Data EvBind where + -- Placeholder; we can't traverse into EvBind + toConstr _ = abstractConstr "TcEvBind" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "EvBind" {- Note [Coercion evidence only] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -417,6 +456,11 @@ (eb_lhs ev_bind) ev_bind } +-- | Union two evidence binding maps +unionEvBindMap :: EvBindMap -> EvBindMap -> EvBindMap +unionEvBindMap (EvBindMap env1) (EvBindMap env2) = + EvBindMap { ev_bind_varenv = plusDVarEnv env1 env2 } + isEmptyEvBindMap :: EvBindMap -> Bool isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m @@ -451,7 +495,7 @@ data EvBindInfo = EvBindGiven { -- See Note [Tracking redundant constraints] in GHC.Tc.Solver } - | EvBindWanted { ebi_canonical :: Canonical -- See Note [Desugaring non-canonical evidence] + | EvBindWanted { ebi_canonical :: CanonicalEvidence -- See Note [Desugaring non-canonical evidence] } ----------------- @@ -465,7 +509,7 @@ evBindVar :: EvBind -> EvVar evBindVar = eb_lhs -mkWantedEvBind :: EvVar -> Canonical -> EvTerm -> EvBind +mkWantedEvBind :: EvVar -> CanonicalEvidence -> EvTerm -> EvBind mkWantedEvBind ev c tm = EvBind { eb_info = EvBindWanted c, eb_lhs = ev, eb_rhs = tm } -- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm @@ -485,17 +529,14 @@ | EvFun -- /\as \ds. let binds in v { et_tvs :: [TyVar] , et_given :: [EvVar] - , et_binds :: TcEvBinds -- This field is why we need an EvFun - -- constructor, and can't just use EvExpr + , et_binds :: TcEvBinds -- This field is why we need an EvFun + -- constructor, and can't just use EvExpr , et_body :: EvVar } deriving Data.Data type EvExpr = CoreExpr --- An EvTerm is (usually) constructed by any of the constructors here --- and those more complicated ones who were moved to module GHC.Tc.Types.EvTerm - -- | Any sort of evidence Id, including coercions evId :: EvId -> EvExpr evId = Var @@ -505,18 +546,63 @@ evCoercion :: TcCoercion -> EvTerm evCoercion co = EvExpr (Coercion co) --- | d |> co +{-# DEPRECATED mkEvCast "Please use evCast instead" #-} +-- We had gotten duplicate functions; let's get rid of mkEvCast in due course +mkEvCast :: EvExpr -> TcCoercion -> EvTerm +mkEvCast = evCast + evCast :: EvExpr -> TcCoercion -> EvTerm -evCast et tc | isReflCo tc = EvExpr et - | otherwise = EvExpr (Cast et tc) +evCast et tc = EvExpr (evCastE et tc) --- Dictionary instance application +-- | d |> co +evCastE :: EvExpr -> TcCoercion -> EvExpr +evCastE ee co + | assertPpr (coercionRole co == Representational) + (vcat [text "Coercion of wrong role passed to evCastE:", ppr ee, ppr co]) $ + isReflCo co = ee + | otherwise = Cast ee co + evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm -evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets +-- Dictionary instance application, including when the "dictionary function" +-- is actually the data construtor for a dictionary +evDFunApp df tys ets = EvExpr (evDFunAppE df tys ets) -evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm -evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets +evDFunAppE :: DFunId -> [Type] -> [EvExpr] -> EvExpr +evDFunAppE df tys ets = Var df `mkTyApps` tys `mkApps` ets +evDictApp :: Class -> [Type] -> [EvExpr] -> EvTerm +evDictApp cls tys args = EvExpr (evDictAppE cls tys args) + +evDictAppE :: Class -> [Type] -> [EvExpr] -> EvExpr +evDictAppE cls tys args + = case tyConSingleDataCon_maybe (classTyCon cls) of + Just dc -> evDFunAppE (dataConWrapId dc) tys args + Nothing -> pprPanic "evDictApp" (ppr cls) + +evUnaryDictAppE :: Class -> [Type] -> EvExpr -> EvExpr +-- See (UCM6) in Note [Unary class magic] in GHC.Core.TyCon +evUnaryDictAppE cls tys meth + = evDictAppE cls tys [meth] + +evWrapIPE :: PredType -> EvExpr -> EvExpr +-- Given pred = IP s ty + -- et_tm :: ty +-- Return an EvTerm of type (IP s ty) +evWrapIPE pred ev_tm + = evUnaryDictAppE cls tys ev_tm + where + (cls, tys) = getClassPredTys pred + +evUnwrapIPE :: PredType -> EvExpr -> EvExpr +-- Given pred = IP s ty + -- et_tm :: (IP s ty) +-- Return an EvTerm of type ty +evUnwrapIPE pred ev_tm + = mkApps (Var ip_sel) (map Type tys ++ [ev_tm]) + where + (ip_sel, tys) = decomposeIPPred pred + + -- Selector id plus the types at which it -- should be instantiated, used for HasField -- dictionaries; see Note [HasField instances] @@ -574,7 +660,7 @@ -} -- | Where to store evidence for expression holes --- See Note [Holes] in GHC.Tc.Types.Constraint +-- See Note [Holes in expressions] in GHC.Hs.Expr. data HoleExprRef = HER (IORef EvTerm) -- ^ where to write the erroring expression TcType -- ^ expected type of that expression Unique -- ^ for debug output only @@ -644,7 +730,6 @@ [Notice though that evidence variables that bind coercion terms from super classes will be "given" and hence rigid] - Note [Overview of implicit CallStacks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) @@ -656,12 +741,13 @@ type HasCallStack = (?callStack :: CallStack) -Implicit parameters of type GHC.Stack.Types.CallStack (the name is not -important) are solved in three steps: +Implicit parameters of type GHC.Stack.Types.CallStack (the /name/ of the +implicit parameter is not important, see (CS5) below) are solved as follows: -1. Explicit, user-written occurrences of `?stk :: CallStack` - which have IPOccOrigin, are solved directly from the given IP, - just like a regular IP; see GHC.Tc.Solver.Dict.tryInertDicts. +1. Plan NORMAL. Explicit, user-written occurrences of `?stk :: CallStack`, which + have IPOccOrigin, are solved directly from the given IP, just like any other + implicit-parameter constraint; see GHC.Tc.Solver.Dict.tryInertDicts. We can + solve it from a Given or from another Wanted, if the two have the same type. For example, the occurrence of `?stk` in @@ -670,44 +756,33 @@ will be solved for the `?stk` in `error`s context as before. -2. In a function call, instead of simply passing the given IP, we first - append the current call-site to it. For example, consider a - call to the callstack-aware `error` above. - - foo :: (?stk :: CallStack) => a - foo = error "undefined!" - - Here we want to take the given `?stk` and append the current - call-site, before passing it to `error`. In essence, we want to - rewrite `foo "undefined!"` to - - let ?stk = pushCallStack ?stk - in foo "undefined!" +2. Plan PUSH. A /function call/ with a CallStack constraint, such as + a call to `foo` where + foo :: (?stk :: CallStack) => a + will give rise to a Wanted constraint + [W] d :: (?stk :: CallStack) CtOrigin = OccurrenceOf "foo" - We achieve this as follows: + We do /not/ solve this constraint from Givens, or from other + Wanteds. Rather, have a built-in mechanism in that solves it thus: + d := EvCsPushCall "foo"
d2 + [W] d2 :: (?stk :: CallStack) CtOrigin = IPOccOrigin - * At a call of foo :: (?stk :: CallStack) => blah - we emit a Wanted - [W] d1 : IP "stk" CallStack - with CtOrigin = OccurrenceOf "foo" + That is, `d` is a call-stack that has the `foo` call-site pushed on top of + `d2`, which can now be solved normally (as in (1) above). This is done as follows: + - In GHC.Tc.Solver.Dict.canDictCt we do the pushing. + - We only look up canonical constraints in the inert set - * We /solve/ this constraint, in GHC.Tc.Solver.Dict.canDictNC - by emitting a NEW Wanted - [W] d2 :: IP "stk" CallStack - with CtOrigin = IPOccOrigin +3. For a CallStack constraint, we choose how to solve it based on its CtOrigin: - and solve d1 = EvCsPushCall "foo" (EvId d1) + * solve it normally (plan NORMAL above) + - IPOccOrigin (discussed above) + - GivenOrigin (see (CS1) below) - * The new Wanted, for `d2` will be solved per rule (1), ie as a regular IP. + * push an item on the stack and emit a new constraint (plan PUSH above) + - OccurrenceOf "foo" (discused above) + - anything else (see (CS1) below) -3. We use the predicate isPushCallStackOrigin to identify whether we - want to do (1) solve directly, or (2) push and then solve directly. - Key point (see #19918): the CtOrigin where we want to push an item on the - call stack can include IfThenElseOrigin etc, when RebindableSyntax is - involved. See the defn of fun_orig in GHC.Tc.Gen.App.tcInstFun; it is - this CtOrigin that is pinned on the constraints generated by functions - in the "expansion" for rebindable syntax. c.f. GHC.Rename.Expr - Note [Handling overloaded and rebindable constructs] + This choice is by the predicate isPushCallStackOrigin_maybe 4. We default any insoluble CallStacks to the empty CallStack. Suppose `undefined` did not request a CallStack, ie @@ -743,21 +818,38 @@ in `g`, because `head` did not explicitly request a CallStack. -Important Details: -- GHC should NEVER report an insoluble CallStack constraint. +Wrinkles -- GHC should NEVER infer a CallStack constraint unless one was requested +(CS1) Which CtOrigins should qualify for plan PUSH? Certainly ones that arise + from a function call like (f a b). + + But (see #19918) when RebindableSyntax is involved we can function call whose + CtOrigin is somethign like `IfThenElseOrigin`. See the defn of fun_orig in + GHC.Tc.Gen.App.tcInstFun; it is this CtOrigin that is pinned on the + constraints generated by functions in the "expansion" for rebindable + syntax. c.f. GHC.Rename.Expr Note [Handling overloaded and rebindable + constructs]. + + So isPushCallStackOrigin_maybe has a fall-through for "anything else", and + assumes that we should adopt plan PUSH for it. + + However we should /not/ take this fall-through for Given constraints + (#25675). So isPushCallStackOrigin_maybe identifies Givens as plan NORMAL. + +(CS2) GHC should NEVER report an insoluble CallStack constraint. + +(CS3) GHC should NEVER infer a CallStack constraint unless one was requested with a partial type signature (See GHC.Tc.Solver..pickQuantifiablePreds). -- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], +(CS4) A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], where the String is the name of the binder that is used at the SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the package/module/file name, as well as the full source-span. Both CallStack and SrcLoc are kept abstract so only GHC can construct new values. -- We will automatically solve any wanted CallStack regardless of the - name of the IP, i.e. +(CS5) We will automatically solve any wanted CallStack regardless of the + /name/ of the IP, i.e. f = show (?stk :: CallStack) g = show (?loc :: CallStack) @@ -771,27 +863,18 @@ the printed CallStack will NOT include head's call-site. This reflects the standard scoping rules of implicit-parameters. -- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. +(CS6) An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. The desugarer will need to unwrap the IP newtype before pushing a new call-site onto a given stack (See GHC.HsToCore.Binds.dsEvCallStack) -- When we emit a new wanted CallStack from rule (2) we set its origin to +(CS7) When we emit a new wanted CallStack in plan PUSH we set its origin to `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` (see GHC.Tc.Solver.Dict.tryInertDicts). This is a bit shady, but is how we ensure that the new wanted is solved like a regular IP. - -} -mkEvCast :: EvExpr -> TcCoercion -> EvTerm -mkEvCast ev lco - | assertPpr (coercionRole lco == Representational) - (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $ - isReflCo lco = EvExpr ev - | otherwise = evCast ev lco - - mkEvScSelectors -- Assume class (..., D ty, ...) => C a b :: Class -> [TcType] -- C ty1 ty2 -> [(TcPredType, -- D ty[ty1/a,ty2/b] @@ -811,25 +894,42 @@ isEmptyTcEvBinds (EvBinds b) = isEmptyBag b isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" +evExprCoercion_maybe :: EvExpr -> Maybe TcCoercion +-- Applied only to EvExprs of type (s~t) +-- See Note [Coercion evidence terms] +evExprCoercion_maybe (Var v) = return (mkCoVarCo v) +evExprCoercion_maybe (Coercion co) = return co +evExprCoercion_maybe (Cast tm co) = do { co' <- evExprCoercion_maybe tm + ; return (mkCoCast co' co) } +evExprCoercion_maybe _ = Nothing + +evExprCoercion :: EvExpr -> TcCoercion +evExprCoercion tm = case evExprCoercion_maybe tm of + Just co -> co + Nothing -> pprPanic "evExprCoercion" (ppr tm) + evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion -- Applied only to EvTerms of type (s~t) -- See Note [Coercion evidence terms] evTermCoercion_maybe ev_term - | EvExpr e <- ev_term = go e + | EvExpr e <- ev_term = evExprCoercion_maybe e | otherwise = Nothing - where - go :: EvExpr -> Maybe TcCoercion - go (Var v) = return (mkCoVarCo v) - go (Coercion co) = return co - go (Cast tm co) = do { co' <- go tm - ; return (mkCoCast co' co) } - go _ = Nothing evTermCoercion :: EvTerm -> TcCoercion evTermCoercion tm = case evTermCoercion_maybe tm of Just co -> co Nothing -> pprPanic "evTermCoercion" (ppr tm) +-- Used with Opt_DeferTypeErrors +-- See Note [Deferring coercion errors to runtime] +-- in GHC.Tc.Solver +evDelayedError :: Type -> String -> EvTerm +evDelayedError ty msg + = EvExpr $ + let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg + in mkWildCase fail_expr (unrestricted unitTy) ty [] + -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils + -- c.f. mkErrorAppDs in GHC.HsToCore.Utils {- ********************************************************************* * * @@ -837,41 +937,38 @@ * * ********************************************************************* -} -findNeededEvVars :: EvBindMap -> VarSet -> VarSet --- Find all the Given evidence needed by seeds, --- looking transitively through binds -findNeededEvVars ev_binds seeds - = transCloVarSet also_needs seeds - where - also_needs :: VarSet -> VarSet - also_needs needs = nonDetStrictFoldUniqSet add emptyVarSet needs - -- It's OK to use a non-deterministic fold here because we immediately - -- forget about the ordering by creating a set +isNestedEvId :: Var -> Bool +-- Just returns /nested/ free evidence variables; i.e ones with Internal Names +-- Top-level ones (DFuns, dictionary selectors and the like) don't count +-- Evidence variables are always Ids; do not pick TyVars +isNestedEvId v = isId v && isInternalName (varName v) - add :: Var -> VarSet -> VarSet - add v needs - | Just ev_bind <- lookupEvBind ev_binds v - , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind - = evVarsOfTerm rhs `unionVarSet` needs - | otherwise - = needs +nestedEvIdsOfTerm :: EvTerm -> VarSet +-- Returns only EvIds satisfying relevantEvId +nestedEvIdsOfTerm tm = fvVarSet (filterFV isNestedEvId (evTermFVs tm)) -evVarsOfTerm :: EvTerm -> VarSet -evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e -evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev -evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] +evTermFVs :: EvTerm -> FV +evTermFVs (EvExpr e) = exprFVs e +evTermFVs (EvTypeable _ ev) = evFVsOfTypeable ev +evTermFVs (EvFun { et_tvs = tvs, et_given = given + , et_binds = tc_ev_binds, et_body = v }) + = case tc_ev_binds of + TcEvBinds {} -> emptyFV -- See Note [Free vars of EvFun] + EvBinds binds -> addBndrsFV bndrs fvs + where + fvs = foldr (unionFV . evTermFVs . eb_rhs) (unitFV v) binds + bndrs = foldr ((:) . eb_lhs) (tvs ++ given) binds -evVarsOfTerms :: [EvTerm] -> VarSet -evVarsOfTerms = mapUnionVarSet evVarsOfTerm +evTermFVss :: [EvTerm] -> FV +evTermFVss = mapUnionFV evTermFVs -evVarsOfTypeable :: EvTypeable -> VarSet -evVarsOfTypeable ev = +evFVsOfTypeable :: EvTypeable -> FV +evFVsOfTypeable ev = case ev of - EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e - EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] - EvTypeableTrFun em e1 e2 -> evVarsOfTerms [em,e1,e2] - EvTypeableTyLit e -> evVarsOfTerm e - + EvTypeableTyCon _ e -> mapUnionFV evTermFVs e + EvTypeableTyApp e1 e2 -> evTermFVss [e1,e2] + EvTypeableTrFun em e1 e2 -> evTermFVss [em,e1,e2] + EvTypeableTyLit e -> evTermFVs e {- Note [Free vars of EvFun] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -879,19 +976,22 @@ bindings et_binds may be a mutable variable. Fortunately, we can just squeeze by. Here's how. -* evVarsOfTerm is used only by GHC.Tc.Solver.neededEvVars. -* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the - ic_binds field of an Implication -* So we can track usage via the processing for that implication, - (see Note [Tracking redundant constraints] in GHC.Tc.Solver). - We can ignore usage from the EvFun altogether. +* /During/ typechecking, `evTermFVs` is used only by `GHC.Tc.Solver.neededEvVars` + * Each EvBindsVar in an et_binds field of an EvFun is /also/ in the + ic_binds field of an Implication + * So we can track usage via the processing for that implication, + (see Note [Tracking redundant constraints] in GHC.Tc.Solver). + We can ignore usage from the EvFun altogether. -************************************************************************ +* /After/ typechecking `evTermFVs` is used by `GHC.Iface.Ext.Ast`, but by + then it has been zonked so we can get at the bindings. +-} + +{- ********************************************************************* * * Pretty printing * * -************************************************************************ --} +********************************************************************* -} instance Outputable HsWrapper where ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) @@ -920,8 +1020,6 @@ help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] - help it (WpMultCoercion co) = add_parens $ sep [it False, nest 2 (text "" - <+> pprParendCo co)] pprLamBndr :: Id -> SDoc pprLamBndr v = pprBndr LambdaBind v @@ -974,30 +1072,6 @@ ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> arr <+> ppr t2) where arr = pprArrowWithMultiplicity visArgTypeLike (Right (ppr tm)) - - ----------------------------------------------------------------------- --- Helper functions for dealing with IP newtype-dictionaries ----------------------------------------------------------------------- - --- | Create a 'Coercion' that unwraps an implicit-parameter --- dictionary to expose the underlying value. --- We expect the 'Type' to have the form `IP sym ty`, --- and return a 'Coercion' `co :: IP sym ty ~ ty` -unwrapIP :: Type -> CoercionR -unwrapIP ty = - case unwrapNewTyCon_maybe tc of - Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] - Nothing -> pprPanic "unwrapIP" $ - text "The dictionary for" <+> quotes (ppr tc) - <+> text "is not a newtype!" - where - (tc, tys) = splitTyConApp ty - --- | Create a 'Coercion' that wraps a value in an implicit-parameter --- dictionary. See 'unwrapIP'. -wrapIP :: Type -> CoercionR -wrapIP ty = mkSymCo (unwrapIP ty) ---------------------------------------------------------------------- -- A datatype used to pass information when desugaring quotations diff --git a/GHC/Tc/Types/LclEnv.hs b/GHC/Tc/Types/LclEnv.hs --- a/GHC/Tc/Types/LclEnv.hs +++ b/GHC/Tc/Types/LclEnv.hs @@ -11,13 +11,13 @@ , getLclEnvLoc , getLclEnvRdrEnv , getLclEnvTcLevel - , getLclEnvThStage + , getLclEnvThLevel , setLclEnvTcLevel , setLclEnvLoc , setLclEnvRdrEnv , setLclEnvBinderStack , setLclEnvErrCtxt - , setLclEnvThStage + , setLclEnvThLevel , setLclEnvTypeEnv , modifyLclEnvTcLevel @@ -90,7 +90,7 @@ = TcLclCtxt { tcl_loc :: RealSrcSpan, -- Source span tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and HsExpansion] + tcl_in_gen_code :: Bool, -- See Note [Rebindable syntax and XXExprGhcRn] tcl_tclvl :: TcLevel, tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, -- and for tidying type @@ -108,7 +108,7 @@ -- we can look up record field names - tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_th_ctxt :: ThLevel, -- Template Haskell context tcl_th_bndrs :: ThBindEnv, -- and binder info -- The ThBindEnv records the TH binding level of in-scope Names -- defined in this module (not imported) @@ -119,14 +119,13 @@ tcl_env :: TcTypeEnv -- The local type environment: -- Ids and TyVars defined in this module - } -getLclEnvThStage :: TcLclEnv -> ThStage -getLclEnvThStage = tcl_th_ctxt . tcl_lcl_ctxt +getLclEnvThLevel :: TcLclEnv -> ThLevel +getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt -setLclEnvThStage :: ThStage -> TcLclEnv -> TcLclEnv -setLclEnvThStage s = modifyLclCtxt (\env -> env { tcl_th_ctxt = s }) +setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv +setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l }) getLclEnvThBndrs :: TcLclEnv -> ThBindEnv getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt @@ -188,7 +187,7 @@ type TcTypeEnv = NameEnv TcTyThing -type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) +type ThBindEnv = NameEnv (TopLevelFlag, ThLevelIndex) -- Domain = all Ids bound in this module (ie not imported) -- The TopLevelFlag tells if the binding is syntactically top level. -- We need to know this, because the cross-stage persistence story allows @@ -196,6 +195,7 @@ -- -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being -- bound at top level! See Note [Template Haskell levels] in GHC.Tc.Gen.Splice + --------------------------- -- Arrow-notation context diff --git a/GHC/Tc/Types/LclEnv.hs-boot b/GHC/Tc/Types/LclEnv.hs-boot --- a/GHC/Tc/Types/LclEnv.hs-boot +++ b/GHC/Tc/Types/LclEnv.hs-boot @@ -1,3 +1,6 @@ module GHC.Tc.Types.LclEnv where +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + data TcLclEnv diff --git a/GHC/Tc/Types/Origin.hs b/GHC/Tc/Types/Origin.hs --- a/GHC/Tc/Types/Origin.hs +++ b/GHC/Tc/Types/Origin.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. @@ -13,30 +16,40 @@ -- * SkolemInfo SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, - unkSkol, unkSkolAnon, mkClsInstSkol, + unkSkol, unkSkolAnon, -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, isVisibleOrigin, toInvisibleOrigin, - pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin, + pprCtOrigin, pprCtOriginBriefly, + isGivenOrigin, isWantedWantedFunDepOrigin, isWantedSuperclassOrigin, + ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..), + HsImplicitLiftSplice(..), + StandaloneDeriv, TypedThing(..), TyVarBndrs(..), - -- * CtOrigin and CallStack - isPushCallStackOrigin, callStackOriginFS, - ClsInstOrQC(..), NakedScFlag(..), + -- * CallStack + isPushCallStackOrigin_maybe, -- * FixedRuntimeRep origin - FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..), + FixedRuntimeRepOrigin(..), + FixedRuntimeRepContext(..), pprFixedRuntimeRepContext, - StmtOrigin(..), RepPolyFun(..), ArgPos(..), + StmtOrigin(..), ArgPos(..), + mkFRRUnboxedTuple, mkFRRUnboxedSum, - -- * Arrow command origin + -- ** FixedRuntimeRep origin for rep-poly 'Id's + RepPolyId(..), Polarity(..), Position(..), mkArgPos, + + -- ** Arrow command FixedRuntimeRep origin FRRArrowContext(..), pprFRRArrowContext, + + -- ** ExpectedFunTy FixedRuntimeRepOrigin ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, - -- InstanceWhat + -- * InstanceWhat InstanceWhat(..), SafeOverlapping ) where @@ -49,12 +62,12 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon -import GHC.Core.Class import GHC.Core.InstEnv import GHC.Core.PatSyn import GHC.Core.Multiplicity ( scaledThing ) import GHC.Unit.Module +import GHC.Unit.Module.Warnings import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader @@ -67,12 +80,15 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad -import GHC.Utils.Misc( HasDebugCallStack ) +import GHC.Utils.Misc( HasDebugCallStack, nTimes ) import GHC.Types.Unique import GHC.Types.Unique.Supply import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import qualified Data.Kind as Hs +import Data.List.NonEmpty (NonEmpty (..)) + {- ********************************************************************* * * UserTypeCtxt @@ -117,10 +133,8 @@ | PatSigCtxt -- Type sig in pattern -- eg f (x::t) = ... -- or (x::t, y) = e - | RuleSigCtxt FastString Name -- LHS of a RULE forall - -- RULE "foo" forall (x :: a -> a). f (Just x) = ... | ForSigCtxt Name -- Foreign import or export signature - | DefaultDeclCtxt -- Types in a default declaration + | DefaultDeclCtxt -- Class or types in a default declaration | InstDeclCtxt Bool -- An instance declaration -- True: stand-alone deriving -- False: vanilla instance declaration @@ -141,6 +155,9 @@ -- data => T a = MkT a | DerivClauseCtxt -- A 'deriving' clause | TyVarBndrKindCtxt Name -- The kind of a type variable being bound + | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE + -- or SPECIALISE pragma + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... | DataKindCtxt Name -- The kind of a data/newtype (instance) | TySynKindCtxt Name -- The kind of the RHS of a type synonym | TyFamResKindCtxt Name -- The result kind of a type family @@ -149,10 +166,14 @@ -- | Report Redundant Constraints. data ReportRedundantConstraints = NoRRC -- ^ Don't report redundant constraints - | WantRRC SrcSpan -- ^ Report redundant constraints, and here - -- is the SrcSpan for the constraints - -- E.g. f :: (Eq a, Ord b) => blah - -- The span is for the (Eq a, Ord b) + + | WantRRC SrcSpan -- ^ Report redundant constraints + -- The SrcSpan is for the constraints + -- E.g. f :: (Eq a, Ord b) => blah + -- The span is for the (Eq a, Ord b) + -- We need to record the span here because we have + -- long since discarded the HsType in favour of a Type + deriving( Eq ) -- Just for checkSkolInfoAnon reportRedundantConstraints :: ReportRedundantConstraints -> Bool @@ -178,18 +199,17 @@ pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt _ n) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" -pprUserTypeCtxt KindSigCtxt = text "a kind signature" +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" +pprUserTypeCtxt KindSigCtxt = text "a kind signature" pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) pprUserTypeCtxt TypeAppCtxt = text "a type argument" pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" +pprUserTypeCtxt DefaultDeclCtxt = text "a `default' declaration" pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" @@ -201,6 +221,7 @@ pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) +pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n) pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) @@ -270,10 +291,17 @@ ClsInstOrQC -- Whether class instance or quantified constraint PatersonSize -- Head has the given PatersonSize + | MethSkol Name Bool -- Bound by the type of class method op + -- True <=> it's a vanilla default method + -- False <=> it's a user-written, or generic-default, method + -- See (TRC5) in Note [Tracking redundant constraints] + -- in GHC.Tc.Solver.Solve + | FamInstSkol -- Bound at a family instance decl + | PatSkol -- An existential type variable bound by a pattern for ConLike -- a data constructor with an existential type. - (HsMatchContext GhcTc) + HsMatchContextRn -- e.g. data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type @@ -282,6 +310,7 @@ | IPSkol [HsIPName] -- Binding site of an implicit parameter | RuleSkol RuleName -- The LHS of a RULE + | SpecESkol Name -- A SPECIALISE pragma | InferSkol [(Name,TcType)] -- We have inferred a type for these (mutually recursive) @@ -329,9 +358,6 @@ getSkolemInfo :: SkolemInfo -> SkolemInfoAnon getSkolemInfo (SkolemInfo _ skol_anon) = skol_anon -mkClsInstSkol :: Class -> [Type] -> SkolemInfoAnon -mkClsInstSkol cls tys = InstSkol IsClsInst (pSizeClassPred cls tys) - instance Outputable SkolemInfo where ppr (SkolemInfo _ sk_info ) = ppr sk_info @@ -348,11 +374,14 @@ pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) pprSkolInfo (InstSkol IsClsInst sz) = vcat [ text "the instance declaration" , whenPprDebug (braces (ppr sz)) ] -pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified context" +pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified constraint" , whenPprDebug (braces (ppr sz)) ] +pprSkolInfo (MethSkol name d) = text "the" <+> ppWhen d (text "default") + <+> text "method declaration for" <+> ppr name pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name +pprSkolInfo (SpecESkol name) = text "a SPECIALISE pragma for" <+> quotes (ppr name) pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl , text "in" <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") @@ -425,15 +454,15 @@ whatever it tidies to, say a''; and then we walk over the type replacing the binder a by the tidied version a'', to give forall a''. Eq a'' => forall b''. b'' -> a'' - We need to do this under (=>) arrows, to match what topSkolemise + We need to do this under (=>) arrows and (->), to match what skolemisation does. * Typically a'' will have a nice pretty name like "a", but the point is that the foral-bound variables of the signature we report line up with the instantiated skolems lying around in other types. - +-} -************************************************************************ +{- ********************************************************************* * * CtOrigin * * @@ -448,6 +477,7 @@ = HsTypeRnThing (HsType GhcRn) | TypeThing Type | HsExprRnThing (HsExpr GhcRn) + | HsExprTcThing (HsExpr GhcTc) | NameThing Name -- | Some kind of type variable binder. @@ -461,6 +491,7 @@ ppr (HsTypeRnThing ty) = ppr ty ppr (TypeThing ty) = ppr ty ppr (HsExprRnThing expr) = ppr expr + ppr (HsExprTcThing expr) = ppr expr ppr (NameThing name) = ppr name instance Outputable TyVarBndrs where @@ -491,11 +522,11 @@ ----------- Below here, all are Origins for Wanted constraints ------------ - | OccurrenceOf Name -- Occurrence of an overloaded identifier - | OccurrenceOfRecSel RdrName -- Occurrence of a record selector - | AppOrigin -- An application of some kind + | OccurrenceOf Name -- ^ Occurrence of an overloaded identifier + | OccurrenceOfRecSel RdrName -- ^ Occurrence of a record selector + | AppOrigin -- ^ An application of some kind - | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for + | SpecPragOrigin UserTypeCtxt -- ^ Specialisation pragma for -- function or instance @@ -526,7 +557,7 @@ -- IMPORTANT: These constraints will never cause errors; -- See Note [Constraints to ignore] in GHC.Tc.Errors | SectionOrigin - | HasFieldOrigin FastString + | GetFieldOrigin FastString | TupleOrigin -- (..,..) | ExprSigOrigin -- e :: ty | PatSigOrigin -- p :: ty @@ -543,9 +574,9 @@ ClsInstOrQC -- Whether class instance or quantified constraint NakedScFlag - | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to - -- standalone deriving). - | DerivOriginDC DataCon Int Bool + | DerivOrigin StandaloneDeriv + -- Typechecking a `deriving` clause, or a standalone `deriving` declaration + | DerivOriginDC DataCon Int StandaloneDeriv -- Checking constraints arising from this data con and field index. The -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if -- standalong deriving (with a wildcard constraint) is being used. This @@ -553,14 +584,10 @@ -- the argument is True, then don't recommend "use standalone deriving", -- but rather "fill in the wildcard constraint yourself"). -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer - | DerivOriginCoerce Id Type Type Bool - -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from - -- `ty1` to `ty2`. - | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for - -- constraints coming from a wildcard constraint, - -- e.g., deriving instance _ => Eq (Foo a) - -- See Note [Inferring the instance context] - -- in GHC.Tc.Deriv.Infer + | DerivOriginCoerce Id Type Type StandaloneDeriv + -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from + -- `ty1` to `ty2`. + | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in @@ -604,13 +631,14 @@ Module -- ^ Module in which the instance was declared ClsInst -- ^ The declared typeclass instance - | NonLinearPatternOrigin + | NonLinearPatternOrigin NonLinearPatternReason (LPat GhcRn) + | OmittedFieldOrigin (Maybe FieldLabel) | UsageEnvironmentOf Name + -- | See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality | CycleBreakerOrigin CtOrigin -- origin of the original constraint - -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Equality | FRROrigin FixedRuntimeRepOrigin @@ -624,15 +652,31 @@ Type -- the instance-sig type Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt + | ImplicitLiftOrigin HsImplicitLiftSplice +data NonLinearPatternReason + = LazyPatternReason + | GeneralisedPatternReason + | PatternSynonymReason + | ViewPatternReason + | OtherPatternReason +type StandaloneDeriv = Bool + -- False <=> a `deriving` clause on a data/newtype declaration + -- e.g. data T a = MkT a deriving( Eq ) + -- True <=> a standalone `deriving` clause with a wildcard constraint + -- e.g deriving instance _ => Eq (T a) + -- See Note [Inferring the instance context] + -- in GHC.Tc.Deriv.Infer + -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look -- like @sc_sel (sc_sel dg)@, where @dg@ is a Given. type ScDepth = Int -data ClsInstOrQC = IsClsInst - | IsQC CtOrigin +data ClsInstOrQC + = IsClsInst + | IsQC PredType CtOrigin -- The PredType is the forall-constraint we are trying to solve data NakedScFlag = NakedSc | NotNakedSc -- The NakedScFlag affects only GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve @@ -682,30 +726,24 @@ instance Outputable CtOrigin where ppr = pprCtOrigin -ctoHerald :: SDoc -ctoHerald = text "arising from" - -- | Extract a suitable CtOrigin from a HsExpr lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin -exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (field_label $ unLoc $ dfoLabel f) -exprCtOrigin (HsUnboundVar {}) = Shouldn'tHappenOrigin "unbound variable" -exprCtOrigin (HsRecSel _ f) = OccurrenceOfRecSel (unLoc $ foLabel f) -exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l +exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name +exprCtOrigin (HsGetField _ _ (L _ f)) = GetFieldOrigin (field_label $ unLoc $ dfoLabel f) +exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" -exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches -exprCtOrigin (HsLamCase _ _ ms) = matchesCtOrigin ms +exprCtOrigin (HsLam _ _ ms) = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 -exprCtOrigin (HsAppType _ e1 _ _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e -exprCtOrigin (HsPar _ _ e _) = lexprCtOrigin e +exprCtOrigin (HsPar _ e) = lexprCtOrigin e exprCtOrigin (HsProjection _ _) = SectionOrigin exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin @@ -714,7 +752,7 @@ exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs -exprCtOrigin (HsLet _ _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {}) = RecordUpdOrigin @@ -727,7 +765,16 @@ exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" -exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a +exprCtOrigin (HsEmbTy {}) = Shouldn'tHappenOrigin "type expression" +exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" +exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] +exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] +exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a + | OrigStmt _ <- thing = DoOrigin + | OrigPat p <- thing = DoPatOrigin p +exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt" +exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin @@ -744,12 +791,15 @@ grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss -- | Extract a suitable CtOrigin from a list of guarded RHSs -lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin -lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e +lGRHSCtOrigin :: NonEmpty (LGRHS GhcRn (LHsExpr GhcRn)) -> CtOrigin +lGRHSCtOrigin (L _ (GRHS _ _ (L _ e)) :| []) = exprCtOrigin e lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" +ctoHerald :: SDoc +ctoHerald = text "arising from" + pprCtOrigin :: CtOrigin -> SDoc --- "arising from ..." + pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk @@ -758,8 +808,9 @@ , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] pprCtOrigin (SpecPragOrigin ctxt) - = case ctxt of - FunSigCtxt n _ -> text "for" <+> quotes (ppr n) + = ctoHerald <+> + case ctxt of + FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n) SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" _ -> text "a SPECIALISE pragma" -- Never happens I think @@ -781,7 +832,7 @@ , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ]) pprCtOrigin AssocFamPatOrigin - = text "when matching a family LHS with its class instance head" + = ctoHerald <+> text "matching a family LHS with its class instance head" pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected = t2, uo_visible = vis }) = hang (ctoHerald <+> text "a type equality" <> whenPprDebug (brackets (ppr vis))) @@ -825,13 +876,13 @@ 2 (text "the signature of" <+> quotes (ppr name)) pprCtOrigin (InstProvidedOrigin mod cls_inst) - = vcat [ text "arising when attempting to show that" + = vcat [ ctoHerald <+> text "attempting to show that" , ppr cls_inst , text "is provided by" <+> quotes (ppr mod)] pprCtOrigin (ImpedanceMatching x) - = vcat [ text "arising when matching required constraints" - , text "in a group involving" <+> quotes (ppr x)] + = vcat [ ctoHerald <+> text "matching required constraints" + , text "in a binding group involving" <+> quotes (ppr x)] pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig @@ -856,81 +907,100 @@ = vcat [ ctoHerald <+> text "the superclasses of an instance declaration" , whenPprDebug (braces (text "sc-origin:" <> ppr nkd)) ] -pprCtOrigin (ScOrigin (IsQC orig) nkd) - = vcat [ ctoHerald <+> text "the head of a quantified constraint" - , whenPprDebug (braces (text "sc-origin:" <> ppr nkd)) - , pprCtOrigin orig ] +pprCtOrigin (ScOrigin (IsQC pred orig) nkd) + = vcat [ whenPprDebug (text "IsQC" <> braces (text "sc-origin:" <> ppr nkd) <+> ppr pred) + , hang (text "arising (via a quantified constraint) from") + 2 (pprCtOriginBriefly orig) ] + -- Print `orig` briefly with pprCtOriginBriefly. We'll print it more + -- voluminously later: see GHC.Tc.Errors.Ppr.pprQCOriginExtra +pprCtOrigin (NonLinearPatternOrigin reason pat) + = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat)) + 2 (pprNonLinearPatternReason reason) + pprCtOrigin simple_origin - = ctoHerald <+> pprCtO simple_origin + = ctoHerald <+> pprCtOriginBriefly simple_origin --- | Short one-liners -pprCtO :: HasDebugCallStack => CtOrigin -> SDoc -pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] -pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] -pprCtO AppOrigin = text "an application" -pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] -pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" +-- | Print CtOrigin briefly, with a one-liner +pprCtOriginBriefly :: CtOrigin -> SDoc +pprCtOriginBriefly = ppr_br -- ppr_br is a local function with a short name! + +ppr_br :: CtOrigin -> SDoc +ppr_br (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] +ppr_br (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] +ppr_br AppOrigin = text "an application" +ppr_br (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +ppr_br (OverLabelOrigin l) = hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] -pprCtO RecordUpdOrigin = text "a record update" -pprCtO ExprSigOrigin = text "an expression type signature" -pprCtO PatSigOrigin = text "a pattern type signature" -pprCtO PatOrigin = text "a pattern" -pprCtO ViewPatOrigin = text "a view pattern" -pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] -pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] -pprCtO SectionOrigin = text "an operator section" -pprCtO (HasFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)] -pprCtO AssocFamPatOrigin = text "the LHS of a family instance" -pprCtO TupleOrigin = text "a tuple" -pprCtO NegateOrigin = text "a use of syntactic negation" -pprCtO (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration" -pprCtO (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" -pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" -pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" -pprCtO DefaultOrigin = text "a 'default' declaration" -pprCtO DoOrigin = text "a do statement" -pprCtO MCompOrigin = text "a statement in a monad comprehension" -pprCtO ProcOrigin = text "a proc expression" -pprCtO ArrowCmdOrigin = text "an arrow command" -pprCtO AnnOrigin = text "an annotation" -pprCtO (ExprHoleOrigin Nothing) = text "an expression hole" -pprCtO (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) -pprCtO (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) -pprCtO PatCheckOrigin = text "a pattern-match completeness check" -pprCtO ListOrigin = text "an overloaded list" -pprCtO IfThenElseOrigin = text "an if-then-else expression" -pprCtO StaticOrigin = text "a static form" -pprCtO NonLinearPatternOrigin = text "a non-linear pattern" -pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] -pprCtO BracketOrigin = text "a quotation bracket" +ppr_br RecordUpdOrigin = text "a record update" +ppr_br ExprSigOrigin = text "an expression type signature" +ppr_br PatSigOrigin = text "a pattern type signature" +ppr_br PatOrigin = text "a pattern" +ppr_br ViewPatOrigin = text "a view pattern" +ppr_br (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] +ppr_br (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] +ppr_br SectionOrigin = text "an operator section" +ppr_br (GetFieldOrigin f) = hsep [text "selecting the field", quotes (ppr f)] +ppr_br AssocFamPatOrigin = text "the LHS of a family instance" +ppr_br TupleOrigin = text "a tuple" +ppr_br NegateOrigin = text "a use of syntactic negation" +ppr_br (ScOrigin IsClsInst _) = text "the superclasses of an instance declaration" +ppr_br (ScOrigin (IsQC {}) _) = text "the head of a quantified constraint" +ppr_br (DerivOrigin standalone) + | standalone = text "a 'deriving' declaration" + | otherwise = text "the 'deriving' clause of a data type declaration" +ppr_br DefaultOrigin = text "a 'default' declaration" +ppr_br DoOrigin = text "a do statement" +ppr_br MCompOrigin = text "a statement in a monad comprehension" +ppr_br ProcOrigin = text "a proc expression" +ppr_br ArrowCmdOrigin = text "an arrow command" +ppr_br AnnOrigin = text "an annotation" +ppr_br (ExprHoleOrigin Nothing) = text "an expression hole" +ppr_br (ExprHoleOrigin (Just occ)) = text "a use of" <+> quotes (ppr occ) +ppr_br (TypeHoleOrigin occ) = text "a use of wildcard" <+> quotes (ppr occ) +ppr_br PatCheckOrigin = text "a pattern-match completeness check" +ppr_br ListOrigin = text "an overloaded list" +ppr_br IfThenElseOrigin = text "an if-then-else expression" +ppr_br StaticOrigin = text "a static form" +ppr_br (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] +ppr_br (OmittedFieldOrigin Nothing) = text "an omitted anonymous field" +ppr_br (OmittedFieldOrigin (Just fl)) = hsep [text "omitted field" <+> quotes (ppr fl)] +ppr_br BracketOrigin = text "a quotation bracket" +ppr_br (ImplicitLiftOrigin isp) = text "an implicit lift of" <+> quotes (ppr (implicit_lift_lid isp)) -- These ones are handled by pprCtOrigin, but we nevertheless sometimes --- get here via callStackOriginFS, when doing ambiguity checks --- A bit silly, but no great harm -pprCtO (GivenOrigin {}) = text "a given constraint" -pprCtO (GivenSCOrigin {}) = text "the superclass of a given constraint" -pprCtO (SpecPragOrigin {}) = text "a SPECIALISE pragma" -pprCtO (FunDepOrigin1 {}) = text "a functional dependency" -pprCtO (FunDepOrigin2 {}) = text "a functional dependency" -pprCtO (InjTFOrigin1 {}) = text "an injective type family" -pprCtO (TypeEqOrigin {}) = text "a type equality" -pprCtO (KindEqOrigin {}) = text "a kind equality" -pprCtO (DerivOriginDC {}) = text "a deriving clause" -pprCtO (DerivOriginCoerce {}) = text "a derived method" -pprCtO (DoPatOrigin {}) = text "a do statement" -pprCtO (MCompPatOrigin {}) = text "a monad comprehension pattern" -pprCtO (Shouldn'tHappenOrigin note) = text note -pprCtO (ProvCtxtOrigin {}) = text "a provided constraint" -pprCtO (InstProvidedOrigin {}) = text "a provided constraint" -pprCtO (CycleBreakerOrigin orig) = pprCtO orig -pprCtO (FRROrigin {}) = text "a representation-polymorphism check" -pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint" -pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" -pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" -pprCtO (ImpedanceMatching {}) = text "combining required constraints" +-- we call pprCtOriginBriefly directly (e.g. in callStackOriginFS) +ppr_br (GivenOrigin {}) = text "a given constraint" +ppr_br (GivenSCOrigin {}) = text "the superclass of a given constraint" +ppr_br (SpecPragOrigin {}) = text "a SPECIALISE pragma" +ppr_br (FunDepOrigin1 {}) = text "a functional dependency" +ppr_br (FunDepOrigin2 {}) = text "a functional dependency" +ppr_br (InjTFOrigin1 {}) = text "an injective type family" +ppr_br (TypeEqOrigin {}) = text "a type equality" +ppr_br (KindEqOrigin {}) = text "a kind equality" +ppr_br (DerivOriginDC {}) = text "a deriving clause" +ppr_br (DerivOriginCoerce m _ _ _) = text "the coercion of derived method" <+> quotes (ppr m) +ppr_br (DoPatOrigin {}) = text "a do statement" +ppr_br (MCompPatOrigin {}) = text "a monad comprehension pattern" +ppr_br (Shouldn'tHappenOrigin note) = text note +ppr_br (ProvCtxtOrigin {}) = text "a provided constraint" +ppr_br (InstProvidedOrigin {}) = text "a provided constraint" +ppr_br (CycleBreakerOrigin orig) = ppr_br orig +ppr_br (FRROrigin {}) = text "a representation-polymorphism check" +ppr_br (WantedSuperclassOrigin {}) = text "a superclass constraint" +ppr_br (InstanceSigOrigin {}) = text "a type signature in an instance" +ppr_br (AmbiguityCheckOrigin {}) = text "a type ambiguity check" +ppr_br (ImpedanceMatching {}) = text "combining required constraints" +ppr_br (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] +pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc +pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear") +pprNonLinearPatternReason GeneralisedPatternReason = parens (text "non-variable pattern bindings that have been generalised aren't linear") +pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms aren't linear") +pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear") +pprNonLinearPatternReason OtherPatternReason = empty + {- ********************************************************************* * * CallStacks and CtOrigin @@ -939,18 +1009,22 @@ * * ********************************************************************* -} -isPushCallStackOrigin :: CtOrigin -> Bool --- Do we want to solve this IP constraint directly (return False) --- or push the call site (return True) --- See Note [Overview of implicit CallStacks] in GHc.Tc.Types.Evidence -isPushCallStackOrigin (IPOccOrigin {}) = False -isPushCallStackOrigin _ = True - - -callStackOriginFS :: CtOrigin -> FastString --- This is the string that appears in the CallStack -callStackOriginFS (OccurrenceOf fun) = occNameFS (getOccName fun) -callStackOriginFS orig = mkFastString (showSDocUnsafe (pprCtO orig)) +isPushCallStackOrigin_maybe :: CtOrigin -> Maybe FastString +-- Do we want to solve this IP constraint normally (return Nothing) +-- or push the call site (returning the name of the function being called) +-- See Note [Overview of implicit CallStacks] esp (CS1) in GHC.Tc.Types.Evidence +isPushCallStackOrigin_maybe (GivenOrigin {}) = Nothing +isPushCallStackOrigin_maybe (GivenSCOrigin {}) = Nothing +isPushCallStackOrigin_maybe (IPOccOrigin {}) = Nothing +isPushCallStackOrigin_maybe (OccurrenceOf fun) = Just (occNameFS (getOccName fun)) +isPushCallStackOrigin_maybe orig = Just orig_fs + -- This fall-through case is important to deal with call stacks + -- that arise from rebindable syntax (#19919) + -- Here the "name of the function being called" is approximated as + -- the result of prettty-printing the CtOrigin; a bit messy, + -- but we can perhaps improve it in the light of user feedback + where + orig_fs = mkFastString (showSDocUnsafe (pprCtOriginBriefly orig)) {- ************************************************************************ @@ -1003,7 +1077,7 @@ = FixedRuntimeRepOrigin { frr_type :: Type -- ^ What type are we checking? - -- For example, `a[tau]` in `a[tau] :: TYPE rr[tau]`. + -- For example, @a[tau]@ in @a[tau] :: TYPE rr[tau]@. , frr_context :: FixedRuntimeRepContext -- ^ What context requires a fixed runtime representation? @@ -1034,6 +1108,32 @@ -- Test cases: LevPolyLet, RepPolyPatBind. | FRRBinder !Name + -- | Types appearing in negative position in the type of a + -- representation-polymorphic 'Id' must have a fixed runtime representation. + -- + -- This includes: + -- + -- - arguments, + -- + -- Test cases: RepPolyMagic, RepPolyRightSection, RepPolyWrappedVar, + -- T14561b, T17817. + -- + -- - continuation result types, such as in 'catch#', 'keepAlive#' + -- and 'control0#'. + -- + -- Test case: T21906. + | FRRRepPolyId + !Name + !RepPolyId + !(Position Neg) + + -- | A partial application of the constructor of a representation-polymorphic + -- unlifted newtype in which the argument type does not have a fixed + -- runtime representation. + -- + -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRRepPolyUnliftedNewtype !DataCon + -- | Pattern binds must have a fixed runtime representation. -- -- Test case: RepPolyInferPatBind. @@ -1056,26 +1156,20 @@ -- Test case: T20363. | FRRDataConPatArg !DataCon !Int - -- | An instantiation of a function with no binding (e.g. `coerce`, `unsafeCoerce#`, an unboxed tuple 'DataCon') - -- in which one of the remaining arguments types does not have a fixed runtime representation. - -- - -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. - | FRRNoBindingResArg !RepPolyFun !ArgPos - - -- | Arguments to unboxed tuples must have fixed runtime representations. + -- | The 'RuntimeRep' arguments to unboxed tuples must be concrete 'RuntimeRep's. -- -- Test case: RepPolyTuple. - | FRRTupleArg !Int + | FRRUnboxedTuple !Int -- | Tuple sections must have a fixed runtime representation. -- -- Test case: RepPolyTupleSection. - | FRRTupleSection !Int + | FRRUnboxedTupleSection !Int - -- | Unboxed sums must have a fixed runtime representation. + -- | The 'RuntimeRep' arguments to unboxed sums must be concrete 'RuntimeRep's. -- -- Test cases: RepPolySum. - | FRRUnboxedSum + | FRRUnboxedSum !(Maybe Int) -- | The body of a @do@ expression or a monad comprehension must -- have a fixed runtime representation. @@ -1105,8 +1199,8 @@ -- See 'FRRArrowContext' for more details. | FRRArrow !FRRArrowContext - -- | A representation-polymorphic check arising from a call - -- to 'matchExpectedFunTys' or 'matchActualFunTySigma'. + -- | A representation-polymorphism check arising from a call + -- to 'matchExpectedFunTys' or 'matchActualFunTy'. -- -- See 'ExpectedFunTyOrigin' for more details. | FRRExpectedFunTy @@ -1114,6 +1208,35 @@ !Int -- ^ argument position (1-indexed) + -- | A representation-polymorphism check arising from eta-expansion + -- performed as part of deep subsumption. + | forall p. FRRDeepSubsumption + { frrDSExpected :: Bool + , frrDSPosition :: Position p + } + +-- | The description of a representation-polymorphic 'Id'. +data RepPolyId + -- | A representation-polymorphic 'PrimOp'. + = RepPolyPrimOp + -- | An unboxed tuple constructor. + | RepPolyTuple + -- | An unboxed sum constructor. + | RepPolySum + -- | An unspecified representation-polymorphic function, + -- e.g. a pseudo-op such as 'coerce'. + | RepPolyFunction + +-- | A synonym for 'FRRUnboxedTuple' exposed in the hs-boot file +-- for "GHC.Tc.Types.Origin". +mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext +mkFRRUnboxedTuple = FRRUnboxedTuple + +-- | A synonym for 'FRRUnboxedSum' exposed in the hs-boot file +-- for "GHC.Tc.Types.Origin". +mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext +mkFRRUnboxedSum = FRRUnboxedSum + -- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check. -- -- Note that this function does not include the specific 'RuntimeRep' @@ -1129,6 +1252,8 @@ pprFixedRuntimeRepContext (FRRBinder binder) = sep [ text "The binder" , quotes (ppr binder) ] +pprFixedRuntimeRepContext (FRRRepPolyId nm id pos) + = text "The" <+> ppr pos <+> text "of" <+> pprRepPolyId id nm pprFixedRuntimeRepContext FRRPatBind = text "The pattern binding" pprFixedRuntimeRepContext FRRPatSynArg @@ -1144,30 +1269,17 @@ = text "newtype constructor pattern" | otherwise = text "data constructor pattern in" <+> speakNth i <+> text "position" -pprFixedRuntimeRepContext (FRRNoBindingResArg fn arg_pos) - = vcat [ text "Unsaturated use of a representation-polymorphic" <+> what_fun <> dot - , what_arg <+> text "argument of" <+> quotes (ppr fn) ] - where - what_fun, what_arg :: SDoc - what_fun = case fn of - RepPolyWiredIn {} -> text "primitive function" - RepPolyDataCon dc -> what_con <+> text "constructor" - where - what_con :: SDoc - what_con - | isNewDataCon dc - = text "newtype" - | otherwise - = text "data" - what_arg = case arg_pos of - ArgPosInvis -> text "An invisible" - ArgPosVis i -> text "The" <+> speakNth i -pprFixedRuntimeRepContext (FRRTupleArg i) - = text "The tuple argument in" <+> speakNth i <+> text "position" -pprFixedRuntimeRepContext (FRRTupleSection i) - = text "The" <+> speakNth i <+> text "component of the tuple section" -pprFixedRuntimeRepContext FRRUnboxedSum +pprFixedRuntimeRepContext (FRRRepPolyUnliftedNewtype dc) + = vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype." + , text "The argument of the newtype constructor" <+> quotes (ppr dc) ] +pprFixedRuntimeRepContext (FRRUnboxedTuple i) + = text "The" <+> speakNth i <+> text "component of the unboxed tuple" +pprFixedRuntimeRepContext (FRRUnboxedTupleSection i) + = text "The" <+> speakNth i <+> text "component of the unboxed tuple section" +pprFixedRuntimeRepContext (FRRUnboxedSum Nothing) = text "The unboxed sum" +pprFixedRuntimeRepContext (FRRUnboxedSum (Just i)) + = text "The" <+> speakNth i <+> text "component of the unboxed sum" pprFixedRuntimeRepContext (FRRBodyStmt stmtOrig i) = vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma , text "arising from the" <+> ppr stmtOrig <> comma ] @@ -1183,6 +1295,13 @@ = pprFRRArrowContext arrowContext pprFixedRuntimeRepContext (FRRExpectedFunTy funTyOrig arg_pos) = pprExpectedFunTyOrigin funTyOrig arg_pos +pprFixedRuntimeRepContext (FRRDeepSubsumption is_exp pos) + = hsep [ text "The", what, text "type of the" + , ppr (Argument pos) + , text "of the eta-expansion" + ] + where + what = if is_exp then text "expected" else text "actual" instance Outputable FixedRuntimeRepContext where ppr = pprFixedRuntimeRepContext @@ -1198,23 +1317,6 @@ ppr MonadComprehension = text "monad comprehension" ppr DoNotation = quotes ( text "do" ) <+> text "statement" --- | A function with representation-polymorphic arguments, --- such as @coerce@ or @(#, #)@. --- --- Used for reporting partial applications of representation-polymorphic --- functions in error messages. -data RepPolyFun - = RepPolyWiredIn !Id - -- ^ A wired-in function with representation-polymorphic - -- arguments, such as 'coerce'. - | RepPolyDataCon !DataCon - -- ^ A data constructor with representation-polymorphic arguments, - -- such as an unboxed tuple or a newtype constructor with @-XUnliftedNewtypes@. - -instance Outputable RepPolyFun where - ppr (RepPolyWiredIn id) = ppr id - ppr (RepPolyDataCon dc) = ppr dc - -- | The position of an argument (to be reported in an error message). data ArgPos = ArgPosInvis @@ -1224,6 +1326,133 @@ {- ********************************************************************* * * + FixedRuntimeRep: representation-polymorphic Ids +* * +********************************************************************* -} + +{- Note [Positional information in representation-polymorphism errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider an invalid instantiation of the 'catch#' primop: + + catch# + :: forall {q :: RuntimeRep} {k :: Levity} (a :: TYPE q) + (b :: TYPE (BoxedRep k)). + (State# RealWorld -> (# State# RealWorld, a #)) + -> (b -> State# RealWorld -> (# State# RealWorld, a #)) + -> State# RealWorld + -> (# State# RealWorld, a #) + + boo :: forall r (a :: TYPE r). ... + boo = catch# @a + +The instantiation is invalid because we insist that the quantified RuntimeRep +type variable 'q' be instantiated to a concrete RuntimeRep, as per +Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. + +We report this as the following error message: + + The result of the first argument of the primop ‘catch#’ does not have a fixed runtime representation. + Its type is: (a :: TYPE r). + +The positional information in this message, namely "The result of the first argument", +is produced by using the 'Position' datatype. In this case: + + pos :: Position Neg + pos = Result (Argument Top) + ppr pos = "result of the first argument" + +Other examples: + + pos2 :: Position Neg + pos2 = Argument (Result (Result Top)) + ppr pos2 = "3rd argument" + + pos3 :: Position Pos + pos3 = Argument (Result (Argument (Result Top))) + ppr pos3 = "2nd argument of the 2nd argument" + +It's useful to keep track at the type-level whether we are in a positive or +negative position in the type, as for primops we can usually tolerate +representation-polymorphism in positive positions, but not in negative ones; +for example + + ($) :: forall {r} (a :: Type) (b :: TYPE r). (a -> b) -> a -> b + + +This positional information is (currently) used to report representation-polymorphism +errors in precisely the following two situations: + + 1. Representation-polymorphic Ids with no binding, as described in + Note [Representation-polymorphic Ids with no binding] in GHC.Tc.Utils.Concrete. + + This uses the 'FRRRepPolyId' constructor of 'FixedRuntimeRepContext'. + + 2. When inserting eta-expansions for deep subsumption. + See Wrinkle [Representation-polymorphism checking during subtyping] in + Note [FunTy vs FunTy case in tc_sub_type_deep] in GHC.Tc.Utils.Unify. + + This uses the 'FRRDeepSubsumption' constructor of 'FixedRuntimeRepContext'. +-} + +-- | Are we in a positive (covariant) or negative (contravariant) position? +-- +-- See Note [Positional information in representation-polymorphism errors]. +data Polarity = Pos | Neg + +-- | Flip the 'Polarity': turn positive into negative and vice-versa. +type FlipPolarity :: Polarity -> Polarity +type family FlipPolarity p = r | r -> p where + FlipPolarity Pos = Neg + FlipPolarity Neg = Pos + +-- | A position in which a type variable appears in a type; +-- in particular, whether it appears in a positive or a negative position. +-- +-- See Note [Positional information in representation-polymorphism errors]. +type Position :: Polarity -> Hs.Type +data Position p where + -- | In the argument of a function arrow + Argument :: Position p -> Position (FlipPolarity p) + -- | In the result of a function arrow + Result :: Position p -> Position p + -- | At the top level of a type + Top :: Position Pos +deriving stock instance Show (Position p) +instance Outputable (Position p) where + ppr = go 1 + where + go :: Int -> Position q -> SDoc + go i (Argument (Result pos)) = go (i+1) (Argument pos) + go i (Argument pos) = speakNth i <+> text "argument" <+> aux 1 pos + go i (Result (Result pos)) = go i (Result pos) + go i (Result pos) = text "result" <+> aux i pos + go _ Top = text "top-level" + + aux :: Int -> Position q -> SDoc + aux i pos = case pos of { Top -> empty; _ -> text "of the" <+> go i pos } + +-- | @'mkArgPos' i p@ makes the 'Position' @p@ relative to the @ith@ argument. +-- +-- Example: @ppr (mkArgPos 3 (Result Top)) == "in the result of the 3rd argument"@. +mkArgPos :: Int -> Position p -> Position (FlipPolarity p) +mkArgPos i = go + where + go :: Position p -> Position (FlipPolarity p) + go Top = Argument $ nTimes (i-1) Result Top + go (Result p) = Result $ go p + go (Argument p) = Argument $ go p + +pprRepPolyId :: RepPolyId -> Name -> SDoc +pprRepPolyId id nm = id_desc <+> quotes (ppr nm) + where + id_desc = case id of + RepPolyPrimOp {} -> text "the primop" + RepPolySum {} -> text "the unboxed sum constructor" + RepPolyTuple {} -> text "the unboxed tuple constructor" + RepPolyFunction {} -> empty + +{- ********************************************************************* +* * FixedRuntimeRep: arrows * * ********************************************************************* -} @@ -1293,7 +1522,7 @@ ********************************************************************* -} -- | In what context are we calling 'matchExpectedFunTys' --- or 'matchActualFunTySigma'? +-- or 'matchActualFunTy'? -- -- Used for two things: -- @@ -1314,9 +1543,9 @@ -- -- Test cases for representation-polymorphism checks: -- RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK - = ExpectedFunTySyntaxOp - !CtOrigin - !(HsExpr GhcRn) + = forall (p :: Pass) + . (OutputableBndrId p) + => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p)) -- ^ rebindable syntax operator -- | A view pattern must have a function type. @@ -1332,8 +1561,7 @@ -- Test cases for representation-polymorphism checks: -- RepPolyApp | forall (p :: Pass) - . (OutputableBndrId p) - => ExpectedFunTyArg + . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg !TypedThing -- ^ function !(HsExpr (GhcPass p)) @@ -1353,16 +1581,8 @@ -- | Ensure that a lambda abstraction has a function type. -- -- Test cases for representation-polymorphism checks: - -- RepPolyLambda - | ExpectedFunTyLam - !(MatchGroup GhcRn (LHsExpr GhcRn)) - - -- | Ensure that a lambda case expression has a function type. - -- - -- Test cases for representation-polymorphism checks: - -- RepPolyMatch - | ExpectedFunTyLamCase - LamCaseVariant + -- RepPolyLambda, RepPolyMatch + | ExpectedFunTyLam HsLamVariant !(HsExpr GhcRn) -- ^ the entire lambda-case expression @@ -1390,8 +1610,7 @@ | otherwise -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts <+> text "for" <+> quotes (ppr fun) - ExpectedFunTyLam {} -> binder_of $ text "lambda" - ExpectedFunTyLamCase lc_variant _ -> binder_of $ lamCaseKeyword lc_variant + ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant where the_arg_of :: SDoc the_arg_of = text "The" <+> speakNth i <+> text "argument of" @@ -1409,15 +1628,11 @@ , text "is applied to" ] pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts })) = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts -pprExpectedFunTyHerald (ExpectedFunTyLam match) - = sep [ text "The lambda expression" <+> - quotes (pprSetDepth (PartWay 1) $ - pprMatches match) - -- The pprSetDepth makes the lambda abstraction print briefly +pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr) + = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression" + <+> quotes (pprSetDepth (PartWay 1) (ppr expr)) + -- The pprSetDepth makes the lambda abstraction print briefly , text "has" ] -pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr) - = sep [ text "The function" <+> quotes (ppr expr) - , text "requires" ] {- ******************************************************************* * * @@ -1437,7 +1652,7 @@ -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] | BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn) - -- See Note [Well-staged instance evidence] + -- See Note [Well-levelled instance evidence] | BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is -- KnownNat, .. etc (classes with no top-level evidence) @@ -1447,7 +1662,10 @@ | TopLevInstance -- Solved by a top-level instance decl { iw_dfun_id :: DFunId - , iw_safe_over :: SafeOverlapping } + , iw_safe_over :: SafeOverlapping + , iw_warn :: Maybe (WarningTxt GhcRn) } + -- See Note [Implementation of deprecated instances] + -- in GHC.Tc.Solver.Dict instance Outputable InstanceWhat where ppr BuiltinInstance = text "a built-in instance" diff --git a/GHC/Tc/Types/Origin.hs-boot b/GHC/Tc/Types/Origin.hs-boot --- a/GHC/Tc/Types/Origin.hs-boot +++ b/GHC/Tc/Types/Origin.hs-boot @@ -1,14 +1,19 @@ module GHC.Tc.Types.Origin where +import GHC.Prelude.Basic ( Int, Maybe ) import GHC.Utils.Misc ( HasDebugCallStack ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext data FixedRuntimeRepOrigin + = FixedRuntimeRepOrigin + { frr_type :: Type + , frr_context :: FixedRuntimeRepContext + } -data CtOrigin -data ClsInstOrQC = IsClsInst - | IsQC CtOrigin +mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext +mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext unkSkol :: HasDebugCallStack => SkolemInfo diff --git a/GHC/Tc/Types/TH.hs b/GHC/Tc/Types/TH.hs --- a/GHC/Tc/Types/TH.hs +++ b/GHC/Tc/Types/TH.hs @@ -1,26 +1,30 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Tc.Types.TH ( SpliceType(..) , SpliceOrBracket(..) - , ThStage(..) + , ThLevel(.., TypedBrack, UntypedBrack) , PendingStuff(..) - , ThLevel - , topStage - , topAnnStage - , topSpliceStage - , thLevel - , impLevel - , outerLevel + , ThLevelIndex + , topLevel + , topAnnLevel + , topSpliceLevel + , thLevelIndex + , topLevelIndex + , spliceLevelIndex + , quoteLevelIndex + , thLevelIndexFromImportLevel ) where +import GHC.Prelude import GHCi.RemoteTypes -import qualified Language.Haskell.TH as TH +import qualified GHC.Boot.TH.Syntax as TH import GHC.Tc.Types.Evidence import GHC.Utils.Outputable -import GHC.Prelude -import GHC.Utils.Panic import GHC.Tc.Types.TcRef import GHC.Tc.Types.Constraint import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice ) +import GHC.Types.ThLevelIndex --------------------------- -- Template Haskell stages and levels @@ -29,16 +33,12 @@ data SpliceType = Typed | Untyped data SpliceOrBracket = IsSplice | IsBracket -data ThStage -- See Note [Template Haskell state diagram] +data ThLevel -- See Note [Template Haskell state diagram] -- and Note [Template Haskell levels] in GHC.Tc.Gen.Splice -- Start at: Comp -- At bracket: wrap current stage in Brack - -- At splice: currently Brack: return to previous stage - -- currently Comp/Splice: compile and run - = Splice SpliceType -- Inside a top-level splice - -- This code will be run *at compile time*; - -- the result replaces the splice - -- Binding level = 0 + -- At splice: wrap current stage in Splice + = Splice SpliceType ThLevel -- Inside a splice | RunSplice (TcRef [ForeignRef (TH.Q ())]) -- Set when running a splice, i.e. NOT when renaming or typechecking the @@ -56,14 +56,14 @@ -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice". | Comp -- Ordinary Haskell code - -- Binding level = 1 + -- Binding level = 0 | Brack -- Inside brackets - ThStage -- Enclosing stage + ThLevel -- Enclosing level PendingStuff data PendingStuff - = RnPendingUntyped -- Renaming the inside of an *untyped* bracket + = RnPending -- Renaming the inside of a bracket (TcRef [PendingRnSplice]) -- Pending splices in here | RnPendingTyped -- Renaming the inside of a *typed* bracket @@ -78,41 +78,48 @@ -- variable is used for desugaring -- `lift`. +isTypedPending :: PendingStuff -> Bool +isTypedPending (RnPending _) = False +isTypedPending (RnPendingTyped) = True +isTypedPending (TcPending _ _ _) = True -topStage, topAnnStage, topSpliceStage :: ThStage -topStage = Comp -topAnnStage = Splice Untyped -topSpliceStage = Splice Untyped +pattern UntypedBrack :: ThLevel -> TcRef [PendingRnSplice] -> ThLevel +pattern UntypedBrack lvl tc_ref = Brack lvl (RnPending tc_ref) +pattern TypedBrack :: ThLevel -> ThLevel +pattern TypedBrack lvl <- Brack lvl (isTypedPending -> True) -instance Outputable ThStage where - ppr (Splice _) = text "Splice" +topLevel, topAnnLevel, topSpliceLevel :: ThLevel +topLevel = Comp +topAnnLevel = Splice Untyped Comp +topSpliceLevel = Splice Untyped Comp + + +instance Outputable ThLevel where + ppr (Splice _ s) = text "Splice" <> parens (ppr s) ppr (RunSplice _) = text "RunSplice" ppr Comp = text "Comp" - ppr (Brack s _) = text "Brack" <> parens (ppr s) + ppr (Brack s _) = text "Brack" <> parens (ppr s) -type ThLevel = Int - -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice - -- Incremented when going inside a bracket, - -- decremented when going inside a splice - -- NB: ThLevel is one greater than the 'n' in Fig 2 of the - -- original "Template meta-programming for Haskell" paper -impLevel, outerLevel :: ThLevel -impLevel = 0 -- Imported things; they can be used inside a top level splice -outerLevel = 1 -- Things defined outside brackets - -thLevel :: ThStage -> ThLevel -thLevel (Splice _) = 0 -thLevel Comp = 1 -thLevel (Brack s _) = thLevel s + 1 -thLevel (RunSplice _) = panic "thLevel: called when running a splice" +thLevelIndex :: ThLevel -> ThLevelIndex +thLevelIndex (Splice _ s) = decThLevelIndex (thLevelIndex s) +thLevelIndex Comp = topLevelIndex +thLevelIndex (Brack s _) = incThLevelIndex (thLevelIndex s) +thLevelIndex (RunSplice _) = thLevelIndex (Splice Untyped Comp) -- previously: panic "thLevel: called when running a splice" -- See Note [RunSplice ThLevel]. + {- Note [RunSplice ThLevel] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'RunSplice' stage is set when executing a splice, and only when running a +The 'RunSplice' level is set when executing a splice, and only when running a splice. In particular it is not set when the splice is renamed or typechecked. +However, this is not true. `reifyInstances` for example does rename the given type, +and these types may contain variables (#9262 allow free variables in reifyInstances). +Therefore here we assume that thLevel (RunSplice _) = 0 +Proper fix would probably require renaming argument `reifyInstances` separately prior +to evaluation of the overall splice. + 'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert the finalizer (see Note [Delaying modFinalizers in untyped splices]), and 'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to @@ -120,3 +127,4 @@ 'Brack' or 'Comp' are used instead. -} + diff --git a/GHC/Tc/Types/TcRef.hs b/GHC/Tc/Types/TcRef.hs --- a/GHC/Tc/Types/TcRef.hs +++ b/GHC/Tc/Types/TcRef.hs diff --git a/GHC/Tc/Utils/Backpack.hs b/GHC/Tc/Utils/Backpack.hs --- a/GHC/Tc/Utils/Backpack.hs +++ b/GHC/Tc/Utils/Backpack.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -54,6 +55,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 @@ -79,7 +81,6 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.Maybe @@ -88,6 +89,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 @@ -96,7 +98,7 @@ -- implementation cases. checkBootDeclM Hsig sig_thing real_thing real_fixity <- lookupFixityRn name - let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of + let sig_fixity = case mi_fix_fn sig_iface (occName name) of Nothing -> defaultFixity Just f -> f when (real_fixity /= sig_fixity) $ @@ -220,7 +222,8 @@ (tclvl,cts) <- pushTcLevelM $ do given_ids <- mapM newEvVar inst_theta let given_loc = mkGivenLoc topTcLevel skol_info (mkCtLocEnv lcl_env) - givens = [ CtGiven { ctev_pred = idType given_id + givens = [ CtGiven $ + GivenCt { ctev_pred = idType given_id -- Doesn't matter, make something up , ctev_evar = given_id , ctev_loc = given_loc } @@ -296,14 +299,14 @@ -- than a transitive closure done here) all the free holes are still reachable. implicitRequirementsShallow :: HscEnv - -> [(PkgQual, Located ModuleName)] + -> [(ImportLevel, PkgQual, Located ModuleName)] -> IO ([ModuleName], [InstantiatedUnit]) implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports where mhome_unit = hsc_home_unit_maybe hsc_env go acc [] = pure acc - go (accL, accR) ((mb_pkg, L _ imp):imports) = do + go (accL, accR) ((_stage, mb_pkg, L _ imp):imports) = do found <- findImportedModule hsc_env imp mb_pkg let acc' = case found of Found _ mod | notHomeModuleMaybe mhome_unit mod -> @@ -370,8 +373,8 @@ thinModIface :: [AvailInfo] -> ModIface -> ModIface thinModIface avails iface = - iface { - mi_exports = avails, + iface + & set_mi_exports avails -- mi_fixities = ..., -- mi_warns = ..., -- mi_anns = ..., @@ -379,10 +382,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) @@ -484,15 +486,6 @@ -- logically "implicit" entities are defined indirectly in an interface -- file. #13151 gives a proposal to make these *truly* implicit. -merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc -merge_msg mod_name [] = - text "while checking the local signature" <+> ppr mod_name <+> - text "for consistency" -merge_msg mod_name reqs = - hang (text "while merging the signatures from" <> colon) - 2 (vcat [ bullet <+> ppr req | req <- reqs ] $$ - bullet <+> text "...and the local signature for" <+> ppr mod_name) - -- | Given a local 'ModIface', merge all inherited requirements -- from 'requirementMerges' into this signature, producing -- a final 'TcGblEnv' that matches the local signature and @@ -524,8 +517,8 @@ tcg_rn_decls = tcg_rn_decls orig_tcg_env, -- Annotations tcg_ann_env = tcg_ann_env orig_tcg_env, - -- Documentation header - tcg_doc_hdr = tcg_doc_hdr orig_tcg_env + -- Documentation header and located module name + tcg_hdr_info = tcg_hdr_info orig_tcg_env -- tcg_dus? -- tcg_th_used = tcg_th_used orig_tcg_env, -- tcg_th_splice_used = tcg_th_splice_used orig_tcg_env @@ -542,7 +535,7 @@ -- we are going to merge in. let reqs = requirementMerges unit_state mod_name - addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do + addErrCtxt (MergeSignaturesCtxt unit_state mod_name reqs) $ do -- STEP 2: Read in the RAW forms of all of these interfaces ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do @@ -636,10 +629,13 @@ -- 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, + is_level = NormalLevel } ImpAll rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1 setGblEnv tcg_env { @@ -649,7 +645,7 @@ emptyImportAvails (tcg_semantic_mod tcg_env) case mb_r of - Just (_, as2, _) -> return (thinModIface as2 ireq_iface, as2) + Just (_, _, as2, _) -> return (thinModIface as2 ireq_iface, as2) Nothing -> addMessages msgs >> failM -- We can't thin signatures from non-signature packages _ -> return (ireq_iface, as1) @@ -706,8 +702,9 @@ -- Make sure we didn't refer to anything that doesn't actually exist -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return () - (mb_lies, _, _) <- exports_from_avail mb_exports rdr_env - (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) + (mb_lies, exp_dflts, _, _) <- + exports_from_avail mb_exports rdr_env + (tcg_imports tcg_env) (tcg_semantic_mod tcg_env) {- -- NB: This is commented out, because warns above is disabled. -- If you tried to explicitly export an identifier that has a warning @@ -727,7 +724,7 @@ failIfErrsM -- Save the exports - setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do + setGblEnv tcg_env { tcg_rn_exports = mb_lies, tcg_default_exports = exp_dflts } $ do tcg_env <- getGblEnv let home_unit = hsc_home_unit hsc_env @@ -856,7 +853,7 @@ if outer_mod == mi_module iface -- Don't add ourselves! then tcg_merged tcg_env - else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env + else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env } -- Note [Signature merging DFuns] @@ -915,13 +912,6 @@ exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map nameOccName . availNames) -impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc -impl_msg unit_state impl_mod (Module req_uid req_mod_name) - = pprWithUnitState unit_state $ - text "While checking that" <+> quotes (ppr impl_mod) <+> - text "implements signature" <+> quotes (ppr req_mod_name) <+> - text "in" <+> quotes (ppr req_uid) <> dot - -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) @@ -931,7 +921,7 @@ let unit_state = hsc_units hsc_env home_unit = hsc_home_unit hsc_env other_home_units = hsc_all_home_unit_ids hsc_env - addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do + addErrCtxt (CheckImplementsCtxt unit_state impl_mod req_mod) $ do let insts = instUnitInsts uid -- STEP 1: Load the implementing interface, and make a RdrEnv diff --git a/GHC/Tc/Utils/Concrete.hs b/GHC/Tc/Utils/Concrete.hs --- a/GHC/Tc/Utils/Concrete.hs +++ b/GHC/Tc/Utils/Concrete.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ParallelListComp #-} -- | Checking for representation-polymorphism using the Concrete mechanism. -- @@ -8,46 +9,45 @@ ( -- * Ensuring that a type has a fixed runtime representation hasFixedRuntimeRep , hasFixedRuntimeRep_syntactic + + , unifyConcrete + + , idConcreteTvs ) where import GHC.Prelude -import GHC.Builtin.Types ( liftedTypeKindTyCon, unliftedTypeKindTyCon ) +import GHC.Builtin.Names ( unsafeCoercePrimName ) +import GHC.Builtin.Types -import GHC.Core.Coercion ( coToMCo, mkCastTyMCo - , mkGReflRightMCo, mkNomReflCo ) -import GHC.Core.TyCo.Rep ( Type(..), MCoercion(..) ) -import GHC.Core.TyCon ( isConcreteTyCon ) -import GHC.Core.Type ( isConcreteType, typeKind, tyVarKind, coreView - , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy ) +import GHC.Core.Coercion +import GHC.Core.TyCo.Rep +import GHC.Core.Type -import GHC.Tc.Types ( TcM, ThStage(..), PendingStuff(..) ) -import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) ) -import GHC.Tc.Types.Evidence ( Role(..), TcCoercionN, TcMCoercionN ) -import GHC.Tc.Types.Origin ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) ) -import GHC.Tc.Utils.Monad ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc - , liftZonkM ) -import GHC.Tc.Utils.TcType ( TcType, TcKind, TcTypeFRR - , MetaInfo(..), ConcreteTvOrigin(..) - , isMetaTyVar, metaTyVarInfo, tcTyVarLevel ) -import GHC.Tc.Utils.TcMType ( newConcreteTyVar, isFilledMetaTyVar_maybe, writeMetaTyVar - , emitWantedEq ) +import GHC.Data.Bag -import GHC.Types.Basic ( TypeOrKind(..) ) -import GHC.Types.Name ( getOccName ) -import GHC.Types.Name.Occurrence( occNameFS ) +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import {-# SOURCE #-} GHC.Tc.Utils.Unify + +import GHC.Types.Basic ( TypeOrKind(KindLevel) ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Name.Env +import GHC.Types.Var + import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Outputable -import GHC.Data.FastString ( fsLit ) - +import GHC.Utils.Panic +import GHC.Data.FastString ( FastString, fsLit ) import Control.Monad ( void ) import Data.Functor ( ($>) ) -import Data.List.NonEmpty ( NonEmpty((:|)) ) -import Control.Monad.Trans.Class ( lift ) -import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell ) {- Note [Concrete overview] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -217,7 +217,6 @@ only be unified with a concrete type (in the sense of Note [Concrete types]). INVARIANT: the kind of a concrete metavariable is concrete. - This invariant is upheld at the time of creation of a new concrete metavariable. Concrete metavariables are useful for representation-polymorphism checks: @@ -378,6 +377,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@ @@ -400,7 +626,8 @@ -- @ki@ is concrete, and @co :: ty ~# ty'@. -- That is, @ty'@ has a syntactically fixed RuntimeRep -- in the sense of Note [Fixed RuntimeRep]. -hasFixedRuntimeRep frr_ctxt ty = checkFRR_with unifyConcrete frr_ctxt ty +hasFixedRuntimeRep frr_ctxt ty = + checkFRR_with (fmap (fmap coToMCo) . unifyConcrete_kind (fsLit "cx") . ConcreteFRR) frr_ctxt ty -- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check. -- @@ -443,7 +670,7 @@ -- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@ -- and @frr_@ty has a fixed 'RuntimeRep'. checkFRR_with check_kind frr_ctxt ty - = do { th_stage <- getStage + = do { th_lvl <- getThLevel ; if -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms. | TyConApp tc [] <- ki @@ -451,7 +678,7 @@ -> return refl -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep]. - | Brack _ (TcPending {}) <- th_stage + | TypedBrack {} <- th_lvl -> return refl -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete. @@ -468,221 +695,115 @@ frr_orig :: FixedRuntimeRepOrigin frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt } --- | Ensure that the given type @ty@ can unify with a concrete type, +-- | Ensure that the given kind @ki@ can unify with a concrete type, -- in the sense of Note [Concrete types]. -- --- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is +-- Returns a coercion @co :: ki ~# conc_ki@, where @conc_ki@ is -- concrete. -- --- If the type is already syntactically concrete, this +-- If the kind is already syntactically concrete, this -- immediately returns a reflexive coercion. Otherwise, -- it creates a new concrete metavariable @concrete_tv@ --- and emits an equality constraint @ty ~# concrete_tv@, +-- and emits an equality constraint @ki ~# concrete_tv@, -- to be handled by the constraint solver. -- +-- Precondition: @ki@ must be of the form @TYPE rep@ or @CONSTRAINT rep@. +unifyConcrete_kind :: HasDebugCallStack + => FastString -- ^ name to use when creating concrete metavariables + -> ConcreteTvOrigin + -> TcKind + -> TcM TcCoercionN +unifyConcrete_kind occ_fs conc_orig ki + | Just (torc, rep) <- sORTKind_maybe ki + = do { let tc = case torc of + TypeLike -> tYPETyCon + ConstraintLike -> cONSTRAINTTyCon + ; rep_co <- unifyConcrete occ_fs conc_orig rep + ; return $ mkTyConAppCo Nominal tc [rep_co] } + | otherwise + = pprPanic "unifyConcrete_kind: kind is not of the form 'TYPE rep' or 'CONSTRAINT rep'" $ + ppr ki <+> dcolon <+> ppr (typeKind ki) + + +-- | Ensure the given type can be unified with +-- a concrete type, in the sense of Note [Concrete types]. +-- +-- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is +-- concrete. +-- +-- If the type is already syntactically concrete, this +-- immediately returns a reflexive coercion. +-- Otherwise, it will create new concrete metavariables and emit +-- new Wanted equality constraints, to be handled by the constraint solver. +-- -- Invariant: the kind of the supplied type must be concrete. -- -- We assume the provided type is already at the kind-level -- (this only matters for error messages). -unifyConcrete :: HasDebugCallStack - => FixedRuntimeRepOrigin -> TcType -> TcM TcMCoercionN -unifyConcrete frr_orig ty - = do { (ty, errs) <- makeTypeConcrete (ConcreteFRR frr_orig) ty - ; case errs of - -- We were able to make the type fully concrete. - { [] -> return MRefl - -- The type could not be made concrete; perhaps it contains - -- a skolem type variable, a type family application, ... - -- - -- Create a new ConcreteTv metavariable @concrete_tv@ - -- and unify @ty ~# concrete_tv@. - ; _ -> - do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) (fsLit "cx") ki - -- NB: newConcreteTyVar asserts that 'ki' is concrete. - ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } } - where - ki :: TcKind - ki = typeKind ty - orig :: CtOrigin - orig = FRROrigin frr_orig +unifyConcrete :: FastString -> ConcreteTvOrigin -> TcType -> TcM TcCoercionN +unifyConcrete occ_fs conc_orig ty + = do { (co, cts) <- makeTypeConcrete occ_fs conc_orig ty + ; emitSimples cts + ; return co } --- | Ensure that the given type is concrete. +-- | Ensure that the given kind @ki@ is concrete. -- -- This is an eager syntactic check, and never defers --- any work to the constraint solver. --- --- Invariant: the kind of the supplied type must be concrete. --- Invariant: the output type is equal to the input type, --- up to zonking. +-- any work to the constraint solver. However, +-- it may perform unification. -- --- We assume the provided type is already at the kind-level --- (this only matters for error messages). +-- Invariant: the output type is equal to the input type, up to zonking. ensureConcrete :: HasDebugCallStack => FixedRuntimeRepOrigin - -> TcType - -> TcM TcType -ensureConcrete frr_orig ty - = do { traceTc "ensureConcrete {" (ppr frr_orig $$ ppr ty) - ; (ty', errs) <- makeTypeConcrete conc_orig ty - ; case errs of - { err:errs -> - do { traceTc "ensureConcrete } failure" $ - vcat [ text "ty:" <+> ppr ty - , text "ty':" <+> ppr ty' ] + -> TcKind + -> TcM TcKind +ensureConcrete frr_orig ki + = do { (co, cts) <- makeTypeConcrete (fsLit "cx") conc_orig ki + ; let trace_msg = vcat [ text "ty: " <+> ppr ki + , text "co:" <+> ppr co ] + ; if isEmptyBag cts + then traceTc "ensureConcrete } success" trace_msg + else do { traceTc "ensureConcrete } failure" trace_msg ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel) ; emitNotConcreteError $ NCE_FRR { nce_loc = loc - , nce_frr_origin = frr_orig - , nce_reasons = err :| errs } - } - ; [] -> - traceTc "ensureConcrete } success" $ - vcat [ text "ty: " <+> ppr ty - , text "ty':" <+> ppr ty' ] } - ; return ty' } + , nce_frr_origin = frr_orig } + } + ; return $ coercionRKind co } where conc_orig :: ConcreteTvOrigin conc_orig = ConcreteFRR frr_orig {-*********************************************************************** %* * - Making a type concrete + Concrete type variables of Ids %* * -%************************************************************************ - -Note [Unifying concrete metavariables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unifying concrete metavariables (as defined in Note [ConcreteTv]) is not -an all-or-nothing affair as it is for other sorts of metavariables. - -Consider the following unification problem in which all metavariables -are unfilled (and ignoring any TcLevel considerations): - - alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ]) - -We can't immediately unify `alpha` with the RHS, because the RHS is not -a concrete type (in the sense of Note [Concrete types]). Instead, we -proceed as follows: - - - create a fresh concrete metavariable variable `gamma'[conc]`, - - write gamma[tau] := gamma'[conc], - - write alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma'[conc] ]). - -Thus, in general, to unify `alpha[conc] ~# rhs`, we first try to turn -`rhs` into a concrete type (see the 'makeTypeConcrete' function). -If this succeeds, resulting in a concrete type `rhs'`, we simply fill -`alpha[conc] := rhs'`. If it fails, then syntactic unification fails. - -Example 1: - - alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ]) - - We proceed by filling metavariables: - - gamma[tau] := gamma[conc] - alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma[conc] ]) - - This successfully unifies alpha. - -Example 2: - - For a type family `F :: Type -> Type`: - - delta[conc] ~# TYPE (SumRep '[ zeta[tau], a[sk], F omega[tau] ]) - - We write zeta[tau] := zeta[conc], and then fail, providing the following - two reasons: - - - `a[sk]` is not a concrete type variable, so the overall type - cannot be concrete - - `F` is not a concrete type constructor, in the sense of - Note [Concrete types]. So we keep it as is; in particular, - we /should not/ try to make its argument `omega[tau]` into - a ConcreteTv. - - Note that making zeta concrete allows us to propagate information. - For example, after more typechecking, we might try to unify - `zeta ~# rr[sk]`. If we made zeta a ConcreteTv, we will report - this unsolved equality using the 'ConcreteTvOrigin' stored in zeta[conc]. - This allows us to report ALL the problems in a representation-polymorphism - check (instead of only a non-empty subset). --} +%**********************************************************************-} --- | Try to turn the provided type into a concrete type, by ensuring --- unfilled metavariables are appropriately marked as concrete. --- --- Returns a zonked type which is "as concrete as possible", and --- a list of problems encountered when trying to make it concrete. +-- | Which type variables of this 'Id' must be concrete when instantiated? -- --- INVARIANT: the returned type is equal to the input type, up to zonking. --- INVARIANT: if this function returns an empty list of 'NotConcreteReasons', --- then the returned type is concrete, in the sense of Note [Concrete types]. -makeTypeConcrete :: ConcreteTvOrigin -> TcType -> TcM (TcType, [NotConcreteReason]) --- TODO: it could be worthwhile to return enough information to continue solving. --- Consider unifying `alpha[conc] ~# TupleRep '[ beta[tau], F Int ]` for --- a type family 'F'. --- This function will concretise `beta[tau] := beta[conc]` and return --- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the --- type family application `F Int`. But we could decompose by setting --- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`. -makeTypeConcrete conc_orig ty = - do { res@(ty', _) <- runWriterT $ go ty - ; traceTc "makeTypeConcrete" $ - vcat [ text "ty:" <+> ppr ty - , text "ty':" <+> ppr ty' ] - ; return res } - where - go :: TcType -> WriterT [NotConcreteReason] TcM TcType - go ty - | Just ty <- coreView ty - = go ty - | isConcreteType ty - = pure ty - go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above) - = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv - ; case mb_filled of - { Just ty -> go ty - ; Nothing - | isMetaTyVar tv - , TauTv <- metaTyVarInfo tv - -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel - do { kind <- go (tyVarKind tv) - ; let occ_fs = occNameFS (getOccName tv) - -- occ_fs: preserve the occurrence name of the original tyvar - -- This helps in error messages - ; lift $ - do { conc_tv <- setTcLevel (tcTyVarLevel tv) $ - newConcreteTyVar conc_orig occ_fs kind - ; let conc_ty = mkTyVarTy conc_tv - ; liftZonkM $ writeMetaTyVar tv conc_ty - ; return conc_ty } } - | otherwise - -- Don't attempt to make other type variables concrete - -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv). - -> bale_out ty (NonConcretisableTyVar tv) } } - go ty@(TyConApp tc tys) - | isConcreteTyCon tc - = mkTyConApp tc <$> mapM go tys - | otherwise - = bale_out ty (NonConcreteTyCon tc tys) - go (FunTy af w ty1 ty2) - = do { w <- go w - ; ty1 <- go ty1 - ; ty2 <- go ty2 - ; return $ mkFunTy af w ty1 ty2 } - go (AppTy ty1 ty2) - = do { ty1 <- go ty1 - ; ty2 <- go ty2 - ; return $ mkAppTy ty1 ty2 } - go ty@(LitTy {}) - = return ty - go ty@(CastTy cast_ty kco) - = bale_out ty (ContainsCast cast_ty kco) - go ty@(ForAllTy tcv body) - = bale_out ty (ContainsForall tcv body) - go ty@(CoercionTy co) - = bale_out ty (ContainsCoercionTy co) +-- See Note [Representation-polymorphism checking built-ins] +idConcreteTvs :: TcId -> ConcreteTyVars +idConcreteTvs id - bale_out :: TcType -> NotConcreteReason -> WriterT [NotConcreteReason] TcM TcType - bale_out ty reason = do { tell [reason]; return ty } + -- HACK for unsafeCoerce#: because of the way it is not quite wired in, + -- as described in Note [Wiring in unsafeCoerce#] in GHC.HsToCore, we don't + -- have access to the correct IdDetails in the typechecker (as we only patch + -- in the correct information in the desugarer). + -- So, for the time being, we manually inspect the type of the original, + -- unpatched Id to retrieve which of its outer forall-d tyvars should be concrete. + | idName id == unsafeCoercePrimName + , (a_rep:_b_rep:a:_b:_, _) <- tcSplitForAllTyVars $ idType id + -- NB: only check the argument representation, not the result representation. + -- This is because the following is OK: + -- + -- unsafeCoerceWordRep :: forall {r2} (b :: TYPE r2). Word# -> b + -- unsafeCoerceWordRep = unsafeCoerce# + = mkNameEnv + [(tyVarName a_rep, ConcreteFRR $ FixedRuntimeRepOrigin (mkTyVarTy a) + $ FRRRepPolyId unsafeCoercePrimName RepPolyFunction + $ mkArgPos 1 Top)] + + | otherwise + = idDetailsConcreteTvs $ idDetails id diff --git a/GHC/Tc/Utils/Env.hs b/GHC/Tc/Utils/Env.hs --- a/GHC/Tc/Utils/Env.hs +++ b/GHC/Tc/Utils/Env.hs @@ -1,11 +1,13 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an -- orphan {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} module GHC.Tc.Utils.Env( TyThing(..), TcTyThing(..), TcId, @@ -27,6 +29,7 @@ tcLookupLocatedClass, tcLookupAxiom, lookupGlobal, lookupGlobal_maybe, addTypecheckedBinds, + failIllegalTyCon, failIllegalTyVar, -- Local environment tcExtendKindEnv, tcExtendKindEnvList, @@ -57,19 +60,20 @@ tcGetDefaultTys, -- Template Haskell stuff - StageCheckReason(..), - checkWellStaged, tcMetaTy, thLevel, - topIdLvl, isBrackStage, + LevelCheckReason(..), + tcMetaTy, thLevelIndex, + isBrackLevel, -- New Ids newDFunName, newFamInstTyConName, newFamInstAxiomName, mkStableIdFromString, mkStableIdFromName, - mkWrapperName, + mkWrapperName, tcGetClsDefaults, ) where import GHC.Prelude + import GHC.Driver.Env import GHC.Driver.Env.KnotVars import GHC.Driver.DynFlags @@ -87,6 +91,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType +import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage ) import GHC.Tc.Types.LclEnv import GHC.Core.InstEnv @@ -94,13 +99,17 @@ import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.ConLike import GHC.Core.TyCon +import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Core.Coercion.Axiom import GHC.Core.Class import GHC.Unit.Module +import GHC.Unit.Module.ModDetails import GHC.Unit.Home +import GHC.Unit.Home.Graph +import GHC.Unit.Home.ModInfo import GHC.Unit.External import GHC.Utils.Outputable @@ -109,9 +118,8 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Data.FastString -import GHC.Data.Bag import GHC.Data.List.SetOps -import GHC.Data.Maybe( MaybeErr(..), orElse ) +import GHC.Data.Maybe( MaybeErr(..), orElse, maybeToList, fromMaybe ) import GHC.Types.SrcLoc import GHC.Types.Basic hiding( SuccessFlag(..) ) @@ -120,6 +128,8 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env +import GHC.Types.DefaultEnv +import GHC.Types.Error import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader @@ -127,11 +137,15 @@ import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt +import GHC.Iface.Errors.Types +import GHC.Rename.Unbound ( unknownNameSuggestions ) +import GHC.Tc.Errors.Types.PromotionErr +import {-# SOURCE #-} GHC.Tc.Errors.Hole (getHoleFitDispConfig) + +import Control.Monad import Data.IORef import Data.List ( intercalate ) -import Control.Monad -import GHC.Iface.Errors.Types -import GHC.Types.Error +import qualified Data.List.NonEmpty as NE {- ********************************************************************* * * @@ -198,10 +212,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 } - {- ************************************************************************ * * @@ -218,7 +231,7 @@ tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing -- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name - = addLocMA tcLookupGlobal name + = addLocM tcLookupGlobal name tcLookupGlobal :: Name -> TcM TyThing -- The Name is almost always an ExternalName, but not always @@ -268,11 +281,12 @@ AConLike (PatSynCon ps) -> return ps _ -> wrongThingErr WrongThingPatSyn (AGlobal thing) name -tcLookupConLike :: Name -> TcM ConLike -tcLookupConLike name = do +tcLookupConLike :: WithUserRdr Name -> TcM ConLike +tcLookupConLike qname@(WithUserRdr _ name) = do thing <- tcLookupGlobal name case thing of AConLike cl -> return cl + ATyCon {} -> failIllegalTyCon WL_ConLike qname _ -> wrongThingErr WrongThingConLike (AGlobal thing) name tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent @@ -308,13 +322,13 @@ _ -> wrongThingErr WrongThingAxiom (AGlobal thing) name tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id -tcLookupLocatedGlobalId = addLocMA tcLookupId +tcLookupLocatedGlobalId = addLocM tcLookupId tcLookupLocatedClass :: LocatedA Name -> TcM Class -tcLookupLocatedClass = addLocMA tcLookupClass +tcLookupLocatedClass = addLocM tcLookupClass tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon -tcLookupLocatedTyCon = addLocMA tcLookupTyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon -- Find the instance that exactly matches a type class application. The class arguments must be precisely -- the same as in the instance declaration (modulo renaming & casts). @@ -332,6 +346,20 @@ uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map getTyVar tys) +-- | Get the default types for classes +-- explicitly not combined to be use for `reportClashingDefaultImports` +tcGetClsDefaults :: [Module] -> TcM [DefaultEnv] +tcGetClsDefaults mods = do + hug <- hsc_HUG <$> getTopEnv + module_env_defaults <- eps_defaults <$> getEps + liftIO $ mapMaybeM (lookupClsDefault hug module_env_defaults) mods + +lookupClsDefault :: HomeUnitGraph -> ModuleEnv DefaultEnv -> Module -> IO (Maybe DefaultEnv) +lookupClsDefault hug module_env_defaults mod = + lookupHugByModule mod hug >>= \case + Just hm -> pure $ Just $ md_defaults $ hm_details hm + Nothing -> pure $ lookupModuleEnv module_env_defaults mod + tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) @@ -344,7 +372,99 @@ instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where lookupThing = tcLookupGlobal -{- +-- Illegal term-level use of type things +failIllegalTyCon :: WhatLooking -> WithUserRdr Name -> TcM a +failIllegalTyVar :: WithUserRdr Name -> TcM a +(failIllegalTyCon, failIllegalTyVar) = (fail_tycon, fail_tyvar) + where + fail_tycon what_looking (WithUserRdr rdr tc_nm) = do + gre <- getGlobalRdrEnv + let mb_gre = lookupGRE_Name gre tc_nm + err = case greInfo <$> mb_gre of + Just (IAmTyCon ClassFlavour) -> ClassTE + _ -> TyConTE + fail_with_msg what_looking dataName rdr tc_nm (TermLevelUseGRE <$> mb_gre) err + + fail_tyvar (WithUserRdr rdr nm) = + fail_with_msg WL_Term varName rdr nm (Just TermLevelUseTyVar) TyVarTE + + fail_with_msg what_looking whatName rdr nm pprov err = do + required_type_arguments <- xoptM LangExt.RequiredTypeArguments + (imp_errs, hints) <- get_suggestions required_type_arguments what_looking whatName rdr + hfdc <- getHoleFitDispConfig + unit_state <- hsc_units <$> getTopEnv + let + want_simple = want_simple_msg hints + msg = TcRnIllegalTermLevelUse want_simple rdr nm err + info = ErrInfo { errInfoContext = + if want_simple + then [] + else maybeToList $ fmap (TermLevelUseCtxt nm) pprov + , errInfoSupplementary = + fmap ((hfdc,) . (:[]) . SupplementaryImportErrors) $ + NE.nonEmpty imp_errs + , errInfoHints = hints + } + failWithTc $ TcRnMessageWithInfo unit_state (mkDetailedMessage info msg) + + get_suggestions required_type_arguments what_looking ns rdr = do + show_helpful_errors <- goptM Opt_HelpfulErrors + if not show_helpful_errors || (required_type_arguments && isVarNameSpace ns) + then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments] + else do + let rdr' = fromMaybe rdr (demoteRdrName rdr) + lcl_env <- getLocalRdrEnv + unknownNameSuggestions lcl_env what_looking rdr' + +-- | Should we display a simpler "out of scope" message to the user, instead of +-- a full-blown "illegal term-level use" message? +-- +-- See Note [Simpler "illegal term-level use" errors] +want_simple_msg :: [GhcHint] -> Bool +want_simple_msg hints = any relevant_suggestion hints + where + relevant_suggestion = \case + ImportSuggestion {} -> True + SuggestSimilarNames {} -> True + _ -> False + +{- Note [Simpler "illegal term-level use" errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we rename the occurrence of A in the definition of 'f' in the following program: + + module M1 where + data A = A Int + module M2 where + import M1 (A) + f x = A x + +we initially resolve 'A' to the type constructor 'A', in order to support +-XRequiredTypeArguments. Then we come to find out that a type is illegal in +this position. It is more user-friendly to report the problem as: + + Data constructor out of scope: A + +rather than: + + Illegal term-level use of type constructor A + +This was reported in #23982. + +To achieve this, in 'failIllegalTyCon' and 'failIllegalTyVar', we include a +little heuristic to decide whether to emit an "out of scope" message rather than +an "illegal term-level use" message: when we have a term to suggest to the user, +then give the simpler "out of scope" error message. + +For instance, in the example above, we suggest extending the import list to + + import M1 (A(A)) + +to bring the data constructor A into scope. We thus emit the following message: + + Data constructor out of scope: A + Suggested fix: + Add ‘A’ to the import list in the import of M1 + ************************************************************************ * * Extending the global environment @@ -400,9 +520,8 @@ -- See GHC ticket #17820 . tcTyThBinders :: [TyThing] -> TcM ThBindEnv tcTyThBinders implicit_things = do - stage <- getStage - let th_lvl = thLevel stage - th_bndrs = mkNameEnv + th_lvl <- thLevelIndex <$> getThLevel + let th_bndrs = mkNameEnv [ ( n , (TopLevel, th_lvl) ) | n <- names ] return th_bndrs where @@ -440,7 +559,7 @@ -} tcLookupLocated :: LocatedA Name -> TcM TcTyThing -tcLookupLocated = addLocMA tcLookup +tcLookupLocated = addLocM tcLookup tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name @@ -574,17 +693,17 @@ tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed - -> [TcId] -> TcM a -> TcM a + -> [Scaled TcId] -> TcM a -> TcM a -- Used for both top-level value bindings and nested let/where-bindings -- Adds to the TcBinderStack too tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed) ids thing_inside - = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $ + = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $ tc_extend_local_env top_lvl [ (idName id, ATcId { tct_id = id , tct_info = mk_tct_info id }) - | id <- ids ] - thing_inside + | Scaled _ id <- ids ] $ + foldr check_usage thing_inside scaled_names where mk_tct_info id | type_closed && isEmptyNameSet rhs_fvs = ClosedLet @@ -594,6 +713,10 @@ rhs_fvs = lookupNameEnv fvs name `orElse` emptyNameSet type_closed = isTypeClosedLetBndr id && (fv_type_closed || hasCompleteSig sig_fn name) + scaled_names = [Scaled p (idName id) | Scaled p id <- ids ] + check_usage :: Scaled Name -> TcM a -> TcM a + check_usage (Scaled p id) thing_inside = do + tcCheckUsage id p thing_inside tcExtendIdEnv :: [TcId] -> TcM a -> TcM a -- For lambda-bound and case-bound Ids @@ -634,7 +757,7 @@ = do { traceTc "tc_extend_local_env" (ppr extra_env) ; updLclCtxt upd_lcl_env thing_inside } where - upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = stage + upd_lcl_env env0@(TcLclCtxt { tcl_th_ctxt = th_lvl , tcl_rdr = rdr_env , tcl_th_bndrs = th_bndrs , tcl_env = lcl_type_env }) @@ -644,15 +767,14 @@ -- (GlobalRdrEnv handles the top level) , tcl_th_bndrs = extendNameEnvList th_bndrs - [(n, thlvl) | (n, ATcId {}) <- extra_env] - -- We only track Ids in tcl_th_bndrs + [(n, thlvl) | (n, _) <- extra_env] , tcl_env = extendNameEnvList lcl_type_env extra_env } -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and -- Template Haskell staging env simultaneously. Reason for extending -- LocalRdrEnv: after running a TH splice we need to do renaming. where - thlvl = (top_lvl, thLevel stage) + thlvl = (top_lvl, thLevelIndex th_lvl) tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt @@ -799,34 +921,6 @@ ************************************************************************ -} -checkWellStaged :: StageCheckReason -- What the stage check is for - -> ThLevel -- Binding level (increases inside brackets) - -> ThLevel -- Use stage - -> TcM () -- Fail if badly staged, adding an error -checkWellStaged pp_thing bind_lvl use_lvl - | use_lvl >= bind_lvl -- OK! Used later than bound - = return () -- E.g. \x -> [| $(f x) |] - - | bind_lvl == outerLevel -- GHC restriction on top level splices - = failWithTc (TcRnStageRestriction pp_thing) - - | otherwise -- Badly staged - = failWithTc $ -- E.g. \x -> $(f x) - TcRnBadlyStaged pp_thing bind_lvl use_lvl - -topIdLvl :: Id -> ThLevel --- Globals may either be imported, or may be from an earlier "chunk" --- (separated by declaration splices) of this module. The former --- *can* be used inside a top-level splice, but the latter cannot. --- Hence we give the former impLevel, but the latter topLevel --- E.g. this is bad: --- x = [| foo |] --- $( f x ) --- By the time we are processing the $(f x), the binding for "x" --- will be in the global env, not the local one. -topIdLvl id | isLocalId id = outerLevel - | otherwise = impLevel - tcMetaTy :: Name -> TcM Type -- Given the name of a Template Haskell data type, -- return the type @@ -835,9 +929,9 @@ t <- tcLookupTyCon tc_name return (mkTyConTy t) -isBrackStage :: ThStage -> Bool -isBrackStage (Brack {}) = True -isBrackStage _other = False +isBrackLevel :: ThLevel -> Bool +isBrackLevel (Brack {}) = True +isBrackLevel _other = False {- ************************************************************************ @@ -847,39 +941,88 @@ ************************************************************************ -} -tcGetDefaultTys :: TcM ([Type], -- Default types - (Bool, -- True <=> Use overloaded strings - Bool)) -- True <=> Use extended defaulting rules +{- Note [Builtin class defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the absence of user-defined `default` declarations, the set of class defaults in +effect (i.e. the `DefaultEnv`) depends on whether the `ExtendedDefaultRules` and +`OverloadedStrings` extensions are enabled. In their absence, the only rule in effect +is `default Num (Integer, Double)`, as specified by the Haskell 2010 report. + +Remark [No built-in defaults in ghc-internal] + + When typechecking the ghc-internal package, we **do not** include any built-in + defaults. This is because, in ghc-internal, types such as 'Num' or 'Integer' may + not even be available (they haven't been typechecked yet). + +Remark [default () in ghc-internal] + + Historically, modules inside ghc-internal have used a single default declaration, + of the form `default ()`, to work around the problem described in + Remark [No built-in defaults in ghc-internal]. + + When we typecheck such a default declaration, we must also make sure not to fail + if e.g. 'Num' is not in scope. We thus have special treatment for this case, + in 'GHC.Tc.Gen.Default.tcDefaultDecls'. +-} + +tcGetDefaultTys :: TcM (DefaultEnv, -- Default classes and types + 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_provenance = DP_Builtin + , 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 + ; if this_unit == ghcInternalUnit + -- see Remark [No built-in defaults in ghc-internal] + -- in Note [Builtin class defaults] in GHC.Tc.Utils.Env + then return (defaults, extended_defaults) + else do + -- not one of the built-in units + -- @default Num (Integer, Double)@, plus extensions + { extDef <- if extended_defaults + then do { list_ty <- tcMetaTy listTyConName + ; integer_ty <- tcMetaTy integerTyConName + ; foldableClass <- tcLookupClass foldableClassName + ; showClass <- tcLookupClass showClassName + ; eqClass <- tcLookupClass eqClassName + ; pure $ defaultEnv + [ builtinDefaults foldableClass [list_ty] + , builtinDefaults showClass [unitTy, integer_ty, doubleTy] + , builtinDefaults eqClass [unitTy, integer_ty, doubleTy] + ] + } + -- Note [Extended defaults] + else pure emptyDefaultEnv + ; ovlStr <- if ovl_strings + then do { isStringClass <- tcLookupClass isStringClassName + ; pure $ unitDefaultEnv $ builtinDefaults isStringClass [stringTy] + } + else pure emptyDefaultEnv + ; checkWiredInTyCon doubleTyCon + ; numDef <- case lookupDefaultEnv defaults numClassName of + Nothing -> do { integer_ty <- tcMetaTy integerTyConName + ; numClass <- tcLookupClass numClassName + ; pure $ unitDefaultEnv $ builtinDefaults numClass [integer_ty, doubleTy] + } + -- The Num class is already user-defaulted, no need to construct the builtin default + _ -> pure emptyDefaultEnv + -- Supply the built-in defaults, but make the user-supplied defaults + -- override them. + ; let deflt_tys = mconcat [ extDef, numDef, ovlStr, defaults ] + ; return (deflt_tys, extended_defaults) } } {- Note [Extended defaults] -~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~ In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we try when defaulting. This has very little real impact, except in the following case. Consider: @@ -1070,19 +1213,27 @@ notFound :: Name -> TcM TyThing notFound name = do { lcl_env <- getLclEnv - ; let stage = getLclEnvThStage lcl_env - ; case stage of -- See Note [Out of scope might be a staging error] - Splice {} - | isUnboundName name -> failM -- If the name really isn't in scope - -- don't report it again (#11941) - | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name)) - _ -> failWithTc $ - mkTcRnNotInScope (getRdrName name) (NotInScopeTc (getLclEnvTypeEnv lcl_env)) - -- Take care: printing the whole gbl env can - -- cause an infinite loop, in the case where we - -- are in the middle of a recursive TyCon/Class group; - -- so let's just not print it! Getting a loop here is - -- very unhelpful, because it hides one compiler bug with another + ; if isTermVarOrFieldNameSpace (nameNameSpace name) + then + -- This code path is only reachable with RequiredTypeArguments enabled + -- via the following chain of calls: + -- `notFound` called from + -- `tcLookupGlobal` called from + -- `tcLookup` called from + -- `tcTyVar` + -- It means the user tried to use a term variable at the type level, e.g. + -- let { a = 42; f :: a -> a; ... } in ... + -- If you are seeing this error for any other reason, it is a bug in GHC. + -- See Note [Demotion of unqualified variables] (W1) in GHC.Rename.Env + failWithTc $ TcRnUnpromotableThing name TermVariablePE + + else failWithTc $ + TcRnNotInScope (NotInScopeTc (getLclEnvTypeEnv lcl_env)) (getRdrName name) + -- Take care: printing the whole gbl env can + -- cause an infinite loop, in the case where we + -- are in the middle of a recursive TyCon/Class group; + -- so let's just not print it! Getting a loop here is + -- very unhelpful, because it hides one compiler bug with another } wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a diff --git a/GHC/Tc/Utils/Instantiate.hs b/GHC/Tc/Utils/Instantiate.hs --- a/GHC/Tc/Utils/Instantiate.hs +++ b/GHC/Tc/Utils/Instantiate.hs @@ -11,7 +11,7 @@ -} module GHC.Tc.Utils.Instantiate ( - topSkolemise, + topSkolemise, skolemiseRequired, topInstantiate, instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, @@ -19,7 +19,7 @@ tcInstType, tcInstTypeBndrs, tcSkolemiseInvisibleBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarBndrsX, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, @@ -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,14 @@ 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.TyCo.Tidy ( tidyType ) 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 @@ -74,26 +72,28 @@ import GHC.Tc.Errors.Types import GHC.Tc.Zonk.Monad ( ZonkM ) +import GHC.Rename.Utils( mkRnSyntaxExpr ) + import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Types.Basic ( TypeOrKind(..), Arity ) -import GHC.Types.Error +import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity ) import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env -import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.Var import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Outputable import GHC.Utils.Unique (sameUnique) import GHC.Unit.State import GHC.Unit.External +import GHC.Unit.Module.Warnings import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE @@ -133,7 +133,7 @@ ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $ instCall origin ty_args theta - ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) } + ; return (mkHsWrap wrap (mkHsVar (noLocA id))) } {- ************************************************************************ @@ -145,21 +145,16 @@ Note [Skolemisation] ~~~~~~~~~~~~~~~~~~~~ topSkolemise decomposes and skolemises a type, returning a type -with no top level foralls or (=>) +with no top level foralls or (=>). Examples: topSkolemise (forall a. Ord a => a -> a) = ( wp, [a], [d:Ord a], a->a ) - where wp = /\a. \(d:Ord a). a d - - topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b ) - where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). a d1 b d2 + where + wp = /\a. \(d:Ord a). a d -This second example is the reason for the recursive 'go' -function in topSkolemise: we must remove successive layers -of foralls and (=>). +For nested foralls, see Note [Skolemisation en-bloc] In general, if topSkolemise ty = (wrap, tvs, evs, rho) @@ -167,13 +162,48 @@ then wrap e :: ty and 'wrap' binds {tvs, evs} +Note [Skolemisation en-bloc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this case: + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + +We /could/ return just + (wp, [a], [d:Ord a, forall b. Eq b => a -> b -> b) + +But in fact we skolemise "en-bloc", looping around (in `topSkolemise` for +example) to skolemise the (forall b. Eq b =>). So in fact + + topSkolemise (forall a. Ord a => forall b. Eq b => a->b->b) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b ) + where + wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). a d1 b d2 + +This applies regardless of DeepSubsumption. + +Why do we do this "en-bloc" loopy thing? It is /nearly/ just an optimisation. +But not quite! At the call site of `topSkolemise` (and its cousins) we +use `checkConstraints` to gather constraints and build an implication +constraint. So skolemising just one level at a time would lead to nested +implication constraints. That is a bit less efficient, but there is /also/ a small +user-visible effect: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet. +Specifically, consider + + forall a. Eq a => forall b. (a ~ [b]) => blah + +If we skolemise en-bloc, the equality (a~[b]) is like a let-binding and we +don't treat it like a GADT pattern match, limiting unification. With nested +implications, the inner one would be treated as having-given-equalities. + +This is also relevant when Required foralls are involved; see #24810, and +the loop in `skolemiseRequired`. -} topSkolemise :: SkolemInfo -> TcSigmaType -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s , TcRhoType ) -- See Note [Skolemisation] topSkolemise skolem_info ty @@ -181,15 +211,19 @@ where init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - -- Why recursive? See Note [Skolemisation] + -- Why recursive? See Note [Skolemisation en-bloc] go subst wrap tv_prs ev_vars ty - | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty + | (bndrs, theta, inner_ty) <- tcSplitSigmaTyBndrs ty + , let tvs = binderVars bndrs , not (null tvs && null theta) - = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs - ; ev_vars1 <- newEvVars (substTheta subst' theta) + = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs + ; let tvs1 = binderVars bndrs1 + ; traceTc "topSkol" (vcat [ ppr tvs <+> vcat (map (ppr . getSrcSpan) tvs) + , ppr tvs1 <+> vcat (map (ppr . getSrcSpan) tvs1) ]) + ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1) - (tv_prs ++ (map tyVarName tvs `zip` tvs1)) + (tv_prs ++ (map tyVarName tvs `zip` bndrs1)) (ev_vars ++ ev_vars1) inner_ty } @@ -197,7 +231,52 @@ = return (wrap, tv_prs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution -topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +skolemiseRequired :: SkolemInfo -> VisArity -> TcSigmaType + -> TcM (VisArity, HsWrapper, [Name], [ForAllTyBinder], [EvVar], TcRhoType) +-- Skolemise up to N required (visible) binders, +-- plus any invisible ones "in the way", +-- /and/ any trailing invisible ones. +-- So the result has no top-level invisible quantifiers. +-- Return the depleted arity. +skolemiseRequired skolem_info n_req sigma + = go n_req init_subst idHsWrapper [] [] [] sigma + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma)) + + -- Why recursive? See Note [Skolemisation en-bloc] + go n_req subst wrap acc_nms acc_bndrs ev_vars ty + | (n_req', bndrs, inner_ty) <- tcSplitForAllTyVarsReqTVBindersN n_req ty + , not (null bndrs) + = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs + ; let tvs1 = binderVars bndrs1 + -- fix_up_vis: see Note [Required foralls in Core] + -- in GHC.Core.TyCo.Rep + fix_up_vis | n_req == n_req' + = idHsWrapper + | otherwise + = mkWpForAllCast bndrs1 (substTy subst' inner_ty) + ; go n_req' subst' + (wrap <.> fix_up_vis <.> mkWpTyLams tvs1) + (acc_nms ++ map (tyVarName . binderVar) bndrs) + (acc_bndrs ++ bndrs1) + ev_vars + inner_ty } + + | (theta, inner_ty) <- tcSplitPhiTy ty + , not (null theta) + = do { ev_vars1 <- newEvVars (substTheta subst theta) + ; go n_req subst + (wrap <.> mkWpEvLams ev_vars1) + acc_nms + acc_bndrs + (ev_vars ++ ev_vars1) + inner_ty } + + | otherwise + = return (n_req, wrap, acc_nms, acc_bndrs, ev_vars, substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) -- Instantiate outer invisible binders (both Inferred and Specified) -- If top_instantiate ty = (wrap, inner_ty) -- then wrap :: inner_ty "->" ty @@ -207,7 +286,10 @@ | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 + = do { (_, wrap1, body3) <- instantiateSigma orig noConcreteTyVars tvs theta body2 + -- Why 'noConcreteTyVars' here? + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. -- Loop, to account for types like -- forall a. Num a => forall b. Ord b => ... @@ -217,13 +299,16 @@ | otherwise = return (idHsWrapper, sigma) -instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType +instantiateSigma :: CtOrigin + -> ConcreteTyVars -- ^ concreteness information + -> [TyVar] + -> TcThetaType -> TcSigmaType -> TcM ([TcTyVar], HsWrapper, TcSigmaType) -- (instantiate orig tvs theta ty) -- instantiates the type variables tvs, emits the (instantiated) -- constraints theta, and returns the (instantiated) type ty -instantiateSigma orig tvs theta body_ty - = do { (subst, inst_tvs) <- mapAccumLM newMetaTyVarX empty_subst tvs +instantiateSigma orig concs tvs theta body_ty + = do { rec (subst, inst_tvs) <- mapAccumLM (new_meta subst) empty_subst tvs ; let inst_theta = substTheta subst theta inst_body = substTy subst body_ty inst_tv_tys = mkTyVarTys inst_tvs @@ -235,13 +320,25 @@ , text "theta" <+> ppr theta , text "type" <+> debugPprType body_ty , text "with" <+> vcat (map debugPprType inst_tv_tys) - , text "theta:" <+> ppr inst_theta ]) + , text "theta:" <+> ppr inst_theta ]) ; return (inst_tvs, wrap, inst_body) } where - free_tvs = tyCoVarsOfType body_ty `unionVarSet` tyCoVarsOfTypes theta - in_scope = mkInScopeSet (free_tvs `delVarSetList` tvs) + in_scope = mkInScopeSet (tyCoVarsOfType (mkSpecSigmaTy tvs theta body_ty)) + -- mkSpecSigmaTy: Inferred vs Specified is not important here; + -- We just want an accurate free-var set empty_subst = mkEmptySubst in_scope + new_meta :: Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) + 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.Utils.Concrete. + | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv) + , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0 + -- See Note [substConcreteTvOrigin]. + = newConcreteTyVarX conc_orig subst tv + | otherwise + = newMetaTyVarX subst tv instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst -- Use this when you want to instantiate (forall a b c. ty) with @@ -306,25 +403,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 @@ -375,7 +490,11 @@ = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind ; return (mkAppTys ty extra_args, kind') } where - n_invis = invisibleTyBndrCount kind + n_invis = invisibleBndrCount kind + -- We are re-using tcInstInvisibleTyBindersN, which is + -- needed elsewhere; so all that matters is that n_invis + -- is big enough! Does not matter if it is too big. + -- 10,000 would do equally well :-) tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind) -- Called only to instantiate kinds, in user-written type signatures @@ -462,9 +581,12 @@ ; (subst, inst_tvs) <- tcInstSuperSkolTyVars skol_info tvs -- We instantiate the dfun_tyd with superSkolems. -- See Note [Subtle interaction of recursion and overlap] - -- and Note [Binding when looking up instances] - ; let inst_tys = substTys subst tys - skol_info_anon = mkClsInstSkol cls inst_tys } + -- and Note [Super skolems: binding when looking up instances] + ; let inst_tys = substTys subst tys + skol_info_anon = InstSkol IsClsInst (pSizeClassPred cls inst_tys) + -- We need to take the size of `inst_tys` (not `tys`) because + -- Paterson sizes mention the free type variables + } ; let inst_theta = substTheta subst theta ; return (skol_info_anon, inst_tvs, inst_theta, cls, inst_tys) } @@ -473,7 +595,7 @@ -- Make skolem constants, but do *not* give them new names, as above -- As always, allocate them one level in -- Moreover, make them "super skolems"; see GHC.Core.InstEnv --- Note [Binding when looking up instances] +-- Note [Super skolems: binding when looking up instances] -- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptySubst @@ -496,6 +618,13 @@ -- See Note [Skolemising type variables] tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False +tcInstSkolTyVarBndrsX :: SkolemInfo -> Subst -> [VarBndr TyCoVar vis] -> TcM (Subst, [VarBndr TyCoVar vis]) +tcInstSkolTyVarBndrsX skol_info subs bndrs = do + (subst', bndrs') <- tcInstSkolTyVarsX skol_info subs (binderVars bndrs) + pure (subst', zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; @@ -672,14 +801,14 @@ -> ExpRhoType -> TcM (HsOverLit GhcTc) newNonTrivialOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L _ meth_name) }) + lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L loc meth_name) }) res_ty = do { hs_lit <- mkOverLit val ; let lit_ty = hsLitType hs_lit ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) [synKnownType lit_ty] res_ty $ \_ _ -> return () - ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] + ; let L _ witness = mkHsSyntaxApps (l2l loc) fi' [nlHsLit hs_lit] ; res_ty <- readExpType res_ty ; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable , ol_witness = witness @@ -688,15 +817,14 @@ orig = LiteralOrigin lit ------------ -mkOverLit ::OverLitVal -> TcM (HsLit GhcTc) +mkOverLit :: OverLitVal -> TcM (HsLit GhcTc) mkOverLit (HsIntegral i) = do { integer_ty <- tcMetaTy integerTyConName - ; return (HsInteger (il_text i) - (il_value i) integer_ty) } + ; return (XLit $ HsInteger (il_text i) (il_value i) integer_ty) } mkOverLit (HsFractional r) = do { rat_ty <- tcMetaTy rationalTyConName - ; return (HsRat noExtField r rat_ty) } + ; return (XLit $ HsRat r rat_ty) } mkOverLit (HsIsString src s) = return (HsString src s) @@ -740,7 +868,7 @@ -- USED ONLY FOR CmdTop (sigh) *** -- See Note [CmdSyntaxTable] in "GHC.Hs.Expr" -tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm)) +tcSyntaxName orig ty (std_nm, HsVar _ (L _ (WithUserRdr _ user_nm))) | std_nm == user_nm = do rhs <- newMethodFromName orig std_nm [ty] return (std_nm, rhs) @@ -763,15 +891,10 @@ hasFixedRuntimeRepRes std_nm user_nm_expr sigma1 return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv - -> ZonkM (TidyEnv, SDoc) -syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg) - where - msg = vcat [ text "When checking that" <+> quotes (ppr name) - <+> text "(needed by a syntactic construct)" - , nest 2 (text "has the required type:" - <+> ppr (tidyType tidy_env ty)) - , nest 2 (sep [ppr orig, text "at" <+> ppr loc])] +syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan + -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +syntaxNameCtxt name orig ty loc tidy_env = + return (tidy_env, SyntaxNameCtxt name orig (tidyType tidy_env ty) loc) {- ************************************************************************ @@ -816,45 +939,55 @@ ************************************************************************ -} -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 - -> Class -> [Type] -> TcM ClsInst -newClsInst overlap_mode dfun_name tvs theta clas tys +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 -- Be sure to freshen those type variables, -- so they are sure not to appear in any lookup @@ -868,7 +1001,7 @@ -- helpful to use the same names ; oflag <- getOverlapFlag overlap_mode - ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys' + ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys' warn ; when (isOrphan (is_orphan cls_inst)) $ addDiagnostic (TcRnOrphanInstance $ Left cls_inst) diff --git a/GHC/Tc/Utils/Monad.hs b/GHC/Tc/Utils/Monad.hs --- a/GHC/Tc/Utils/Monad.hs +++ b/GHC/Tc/Utils/Monad.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -19,12 +15,13 @@ -- * Simple accessors discardResult, - getTopEnv, updTopEnv, getGblEnv, updGblEnv, + getTopEnv, updTopEnv, updTopEnvIO, getGblEnv, updGblEnv, setGblEnv, getLclEnv, updLclEnv, updLclCtxt, setLclEnv, restoreLclEnv, updTopFlags, getEnvs, setEnvs, updEnvs, restoreEnvs, xoptM, doptM, goptM, woptM, - setXOptM, unsetXOptM, unsetGOptM, unsetWOptM, + setXOptM, setWOptM, + unsetXOptM, unsetGOptM, unsetWOptM, whenDOptM, whenGOptM, whenWOptM, whenXOptM, unlessXOptM, getGhcMode, @@ -61,9 +58,9 @@ addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, setInGeneratedCode, - wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, @@ -79,7 +76,9 @@ -- * Shared error message stuff: renamer and typechecker recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, - askNoErrs, discardErrs, tryTcDiscardingErrs, + askNoErrs, discardErrs, + tryTcDiscardingErrs, + tryTcDiscardingErrs', checkNoErrs, whenNoErrs, ifErrsM, failIfErrsM, @@ -92,8 +91,9 @@ addErrTcM, failWithTc, failWithTcM, checkTc, checkTcM, + checkJustTc, checkJustTcM, failIfTc, failIfTcM, - mkErrInfo, + mkErrCtxt, addTcRnDiagnostic, addDetailedDiagnostic, mkTcRnMessage, reportDiagnostic, reportDiagnostics, warnIf, diagnosticTc, diagnosticTcM, @@ -101,12 +101,12 @@ -- * Type constraints newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar, - addTcEvBind, addTopEvBinds, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - chooseUniqueOccTc, + addTcEvBind, addTcEvBinds, addTopEvBinds, + getTcEvBindsMap, setTcEvBindsMap, updTcEvBinds, + getTcEvTyCoVars, chooseUniqueOccTc, getConstraintVar, setConstraintVar, emitConstraints, emitStaticConstraints, emitSimple, emitSimples, - emitImplication, emitImplications, + emitImplication, emitImplications, ensureReflMultiplicityCo, emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError, discardConstraints, captureConstraints, tryCaptureConstraints, pushLevelAndCaptureConstraints, @@ -117,8 +117,8 @@ emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole, -- * Template Haskell context - recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps, - keepAlive, getStage, getStageAndBindLevel, setStage, + recordThUse, recordThNeededRuntimeDeps, + keepAlive, getThLevel, getCurrentAndBindLevel, setThLevel, addModFinalizersWithLclEnv, -- * Safe Haskell context @@ -146,8 +146,11 @@ getCCIndexM, getCCIndexTcM, -- * Zonking - liftZonkM, + liftZonkM, newZonkAnyType, + -- * Complete matches + localAndImportedCompleteMatches, getCompleteMatchesTcM, + -- * Types etc. module GHC.Tc.Types, module GHC.Data.IOEnv @@ -157,13 +160,17 @@ import GHC.Builtin.Names +import GHC.Builtin.Types( zonkAnyTyCon ) 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.LclEnv import GHC.Tc.Types.Origin import GHC.Tc.Types.TcRef +import GHC.Tc.Types.TH import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.TcType @@ -173,17 +180,24 @@ import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Warnings -import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable import GHC.Core.UsageEnv import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import GHC.Core.Type( mkNumLitTy ) import GHC.Driver.Env +import GHC.Driver.Env.KnotVars import GHC.Driver.Session import GHC.Driver.Config.Diagnostic +import GHC.Iface.Errors.Types +import GHC.Iface.Errors.Ppr + +import GHC.Linker.Types + import GHC.Runtime.Context import GHC.Data.IOEnv -- Re-export all @@ -197,24 +211,26 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger import qualified GHC.Data.Strict as Strict +import qualified Data.Set as Set import GHC.Types.Error +import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.SafeHaskell import GHC.Types.Id import GHC.Types.TypeEnv -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Name.Ppr import GHC.Types.Unique.FM ( emptyUFM ) +import GHC.Types.Unique.DFM import GHC.Types.Unique.Supply import GHC.Types.Annotations -import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) +import GHC.Types.Basic( TopLevelFlag(..), TypeOrKind(..) ) import GHC.Types.CostCentre.State import GHC.Types.SourceFile @@ -224,13 +240,9 @@ import Control.Monad import qualified Data.Map as Map -import GHC.Driver.Env.KnotVars -import GHC.Linker.Types -import GHC.Types.Unique.DFM -import GHC.Iface.Errors.Types -import GHC.Iface.Errors.Ppr -import GHC.Tc.Types.LclEnv +import GHC.Core.Coercion (isReflCo) + {- ************************************************************************ * * @@ -254,10 +266,10 @@ = do { keep_var <- newIORef emptyNameSet ; used_gre_var <- newIORef [] ; th_var <- newIORef False ; - th_splice_var<- newIORef False ; infer_var <- newIORef True ; infer_reasons_var <- newIORef emptyMessages ; dfun_n_var <- newIORef emptyOccSet ; + zany_n_var <- newIORef 0 ; let { type_env_var = hsc_type_env_vars hsc_env }; dependent_files_var <- newIORef [] ; @@ -308,20 +320,19 @@ 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, tcg_fam_inst_env = emptyFamInstEnv, tcg_ann_env = emptyAnnEnv, + tcg_complete_match_env = [], tcg_th_used = th_var, - tcg_th_splice_used = th_splice_var, tcg_th_needed_deps = th_needed_deps_var, tcg_exports = [], tcg_imports = emptyImportAvails, + tcg_import_decls = [], tcg_used_gres = used_gre_var, tcg_dus = emptyDUs, @@ -349,9 +360,9 @@ tcg_patsyns = [], tcg_merged = [], tcg_dfun_n = dfun_n_var, + tcg_zany_n = zany_n_var, tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, + tcg_hdr_info = (Nothing,Nothing), tcg_main = Nothing, tcg_self_boot = NoSelfBoot, tcg_safe_infer = infer_var, @@ -390,7 +401,7 @@ tcl_in_gen_code = False, tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, - tcl_th_ctxt = topStage, + tcl_th_ctxt = topLevel, tcl_th_bndrs = emptyNameEnv, tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, @@ -436,24 +447,6 @@ where interactive_src_loc = mkRealSrcLoc (fsLit "") 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 @@ -486,6 +479,11 @@ updTopEnv upd = updEnv (\ env@(Env { env_top = top }) -> env { env_top = upd top }) +updTopEnvIO :: (HscEnv -> IO HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +updTopEnvIO upd = updEnvIO (\ env@(Env { env_top = top }) -> + upd top >>= \t' -> + pure env{ env_top = t' }) + getGblEnv :: TcRnIf gbl lcl gbl getGblEnv = do { Env{..} <- getEnv; return env_gbl } @@ -584,6 +582,9 @@ setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag) +setWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setWOptM flag = updTopFlags (\dflags -> wopt_set dflags flag) + unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag) @@ -946,7 +947,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 () @@ -992,23 +993,20 @@ setInGeneratedCode thing_inside = updLclCtxt (\env -> env { tcl_in_gen_code = True }) thing_inside -setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a +setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a setSrcSpanA l = setSrcSpan (locA l) -addLocM :: (a -> TcM b) -> Located a -> TcM b -addLocM fn (L loc a) = setSrcSpan loc $ fn a - -addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b -addLocMA fn (L loc a) = setSrcSpanA loc $ fn a - -wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) -wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a - ; return (L loc b) } +addLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM b +addLocM fn (L loc a) = setSrcSpan (getHasLoc loc) $ fn a -wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b) -wrapLocAM fn a = wrapLocM fn (reLoc a) +wrapLocM :: (HasLoc t) => (a -> TcM b) -> GenLocated t a -> TcM (Located b) +wrapLocM fn (L loc a) = + let + loc' = getHasLoc loc + in setSrcSpan loc' $ do { b <- fn a + ; return (L loc' b) } -wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b) +wrapLocMA :: (a -> TcM b) -> GenLocated (EpAnn ann) a -> TcRn (GenLocated (EpAnn ann) b) wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a ; return (L loc b) } @@ -1023,7 +1021,7 @@ -- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN a -> TcM (LocatedN b, c) -- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c) -- and so on. -wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c) +wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (EpAnn ann) a -> TcM (GenLocated (EpAnn ann) b, c) wrapLocFstMA fn (L loc a) = setSrcSpanA loc $ do (b,c) <- fn a @@ -1040,7 +1038,7 @@ -- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN a -> TcM (b, LocatedN c) -- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c) -- and so on. -wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c) +wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (EpAnn ann) a -> TcM (b, GenLocated (EpAnn ann) c) wrapLocSndMA fn (L loc a) = setSrcSpanA loc $ do (b,c) <- fn a @@ -1075,11 +1073,11 @@ -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- liftZonkM $ tcInitTidyEnv - ; err_info <- mkErrInfo tidy_env ctxt - ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg + ; err_ctxt <- mkErrCtxt tidy_env ctxt + ; let detailed_msg = mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg ; add_long_err_at loc detailed_msg } -mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed +mkDetailedMessage :: ErrInfo-> TcRnMessage -> TcRnMessageDetailed mkDetailedMessage err_info msg = TcRnMessageDetailed err_info msg @@ -1219,7 +1217,7 @@ So typically it's better to do setSrcSpan /before/ addErrCtxt. -See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for +See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr for more discussion of this fancy footwork, as well as Note [Generated code and pattern-match checking] in GHC.Types.Basic for the relation with pattern-match checks. @@ -1234,12 +1232,12 @@ -- | Add a fixed message to the error context. This message should not -- do any tidying. -addErrCtxt :: SDoc -> TcM a -> TcM a +addErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] addErrCtxtM ctxt = pushCtxt (False, ctxt) @@ -1247,13 +1245,13 @@ -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported. -addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a +addLandmarkErrCtxt :: ErrCtxtMsg -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, SDoc)) -> TcM a -> TcM a +addLandmarkErrCtxtM :: (TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) @@ -1263,13 +1261,14 @@ updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv -- Do not update the context if we are in generated code --- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr +-- See Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr updCtxt ctxt env | lclEnvInGeneratedCode env = env | otherwise = addLclEnvErrCtxt ctxt env popErrCtxt :: TcM a -> TcM a -popErrCtxt = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) +popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $ + thing_inside where pop [] = [] pop (_:msgs) = msgs @@ -1300,7 +1299,6 @@ $ setLclEnvBinderStack (ctl_bndrs lcl) $ env) thing_inside - {- ********************************************************************* * * Error recovery and exceptions @@ -1387,11 +1385,13 @@ tcTryM thing_inside -- See Note [Constraints and errors] - ; let lie_to_keep = case mb_res of - Nothing -> dropMisleading lie - Just {} -> lie - - ; return (mb_res, lie_to_keep) } + ; case mb_res of + Just {} -> return (mb_res, lie) + Nothing -> do { let pruned_lie = dropMisleading lie + ; traceTc "tryCaptureConstraints" $ + vcat [ text "lie:" <+> ppr lie + , text "dropMisleading lie:" <+> ppr pruned_lie ] + ; return (Nothing, pruned_lie) } } captureConstraints :: TcM a -> TcM (a, WantedConstraints) -- (captureConstraints m) runs m, and returns the type constraints it generates @@ -1428,7 +1428,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 } @@ -1527,21 +1527,37 @@ -- if 'main' succeeds with no error messages, it's the answer -- otherwise discard everything from 'main', including errors, -- and try 'recover' instead. -tryTcDiscardingErrs recover thing_inside +tryTcDiscardingErrs recover = + tryTcDiscardingErrs' + (\_ _ _ -> True) -- No validation + recover recover -- Discard all errors and warnings + -- and unsolved constraints entirely + +tryTcDiscardingErrs' :: (WantedConstraints -> Messages TcRnMessage -> r -> Bool) -- Validation + -> TcM r -- Recover from validation error + -> TcM r -- Recover from failure + -> TcM r -- Action to try + -> TcM r +-- (tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside) tries 'thing_inside'; +-- if 'thing_inside' succeeds and validation produces no errors, it's the answer +-- otherwise discard everything from 'thing_inside', including errors, +-- and try 'recover' instead. +tryTcDiscardingErrs' validate recover_invalid recover_error thing_inside = do { ((mb_res, lie), msgs) <- capture_messages $ capture_constraints $ tcTryM thing_inside ; case mb_res of Just res | not (errorsFound msgs) , not (insolubleWC lie) - -> -- 'main' succeeded with no errors - do { addMessages msgs -- msgs might still have warnings - ; emitConstraints lie - ; return res } + -- 'thing_inside' succeeded with no errors + -> if validate lie msgs res + then do { addMessages msgs -- msgs might still have warnings + ; emitConstraints lie + ; return res } + else recover_invalid - _ -> -- 'main' failed, or produced an error message - recover -- Discard all errors and warnings - -- and unsolved constraints entirely + _ -> -- 'thing_inside' failed, or produced an error message + recover_error } {- @@ -1595,6 +1611,12 @@ checkTcM True _ = return () checkTcM False err = failWithTcM err +checkJustTc :: TcRnMessage -> Maybe a -> TcM a +checkJustTc err = maybe (failWithTc err) pure + +checkJustTcM :: (TidyEnv, TcRnMessage) -> Maybe a -> TcM a +checkJustTcM err = maybe (failWithTcM err) pure + failIfTc :: Bool -> TcRnMessage -> TcM () -- Check that the boolean is false failIfTc False _ = return () failIfTc True err = failWithTc err @@ -1612,9 +1634,6 @@ warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'. = when is_bad (addDiagnostic msg) -no_err_info :: ErrInfo -no_err_info = ErrInfo Outputable.empty Outputable.empty - -- | Display a warning if a condition is met. diagnosticTc :: Bool -> TcRnMessage -> TcM () diagnosticTc should_report warn_msg @@ -1637,22 +1656,23 @@ addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM () addDiagnosticTcM (env0, msg) = do { ctxt <- getErrCtxt - ; extra <- mkErrInfo env0 ctxt - ; let err_info = ErrInfo extra Outputable.empty - detailed_msg = mkDetailedMessage err_info msg + ; extra <- mkErrCtxt env0 ctxt + ; let detailed_msg = mkDetailedMessage (ErrInfo extra Nothing noHints) msg ; add_diagnostic detailed_msg } -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic. -addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM () +addDetailedDiagnostic :: ([ErrCtxtMsg] -> TcRnMessage) -> TcM () addDetailedDiagnostic mkMsg = do loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx !diag_opts <- initDiagOpts <$> getDynFlags env0 <- liftZonkM tcInitTidyEnv ctxt <- getErrCtxt - err_info <- mkErrInfo env0 ctxt - reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty))) + err_info <- mkErrCtxt env0 ctxt + reportDiagnostic $ + mkMsgEnvelope diag_opts loc name_ppr_ctx $ + mkMsg err_info addTcRnDiagnostic :: TcRnMessage -> TcM () addTcRnDiagnostic msg = do @@ -1662,13 +1682,13 @@ -- | Display a diagnostic for the current source location, taken from -- the 'TcRn' monad. addDiagnostic :: TcRnMessage -> TcRn () -addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg) +addDiagnostic msg = add_diagnostic (mkDetailedMessage (ErrInfo [] Nothing noHints) msg) -- | Display a diagnostic for a given source location. addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () addDiagnosticAt loc msg = do unit_state <- hsc_units <$> getTopEnv - let detailed_msg = mkDetailedMessage no_err_info msg + let detailed_msg = mkDetailedMessage (ErrInfo [] Nothing noHints) msg mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic -- | Display a diagnostic, with an optional flag, for the current source @@ -1680,7 +1700,6 @@ ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic } - {- ----------------------------------- Other helper functions @@ -1690,12 +1709,13 @@ -> [ErrCtxt] -> TcM () add_err_tcm tidy_env msg loc ctxt - = do { err_info <- mkErrInfo tidy_env ctxt ; - add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) } + = do { err_ctxt <- mkErrCtxt tidy_env ctxt + ; add_long_err_at loc $ + mkDetailedMessage (ErrInfo err_ctxt Nothing noHints) msg } -mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc +mkErrCtxt :: TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] -- Tidy the error info, trimming excessive contexts -mkErrInfo env ctxts +mkErrCtxt env ctxts -- = do -- dbg <- hasPprDebug <$> getDynFlags -- if dbg -- In -dppr-debug style the output @@ -1703,14 +1723,14 @@ -- else go dbg 0 env ctxts = go False 0 env ctxts where - go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc - go _ _ _ [] = return empty + go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM [ErrCtxtMsg] + go _ _ _ [] = return [] go dbg n env ((is_landmark, ctxt) : ctxts) | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg = do { (env', msg) <- liftZonkM $ ctxt env ; let n' = if is_landmark then n else n+1 ; rest <- go dbg n' env' ctxts - ; return (msg $$ rest) } + ; return (msg : rest) } | otherwise = go dbg n env ctxts @@ -1741,7 +1761,7 @@ newTcEvBinds :: TcM EvBindsVar newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet + ; tcvs_ref <- newTcRef [] ; uniq <- newUnique ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq) ; return (EvBindsVar { ebv_binds = binds_ref @@ -1753,7 +1773,7 @@ -- must be made monadically newNoTcEvBinds :: TcM EvBindsVar newNoTcEvBinds - = do { tcvs_ref <- newTcRef emptyVarSet + = do { tcvs_ref <- newTcRef [] ; uniq <- newUnique ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq) ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref @@ -1764,14 +1784,14 @@ -- solving don't pollute the original cloneEvBindsVar ebv@(EvBindsVar {}) = do { binds_ref <- newTcRef emptyEvBindMap - ; tcvs_ref <- newTcRef emptyVarSet + ; tcvs_ref <- newTcRef [] ; return (ebv { ebv_binds = binds_ref , ebv_tcvs = tcvs_ref }) } cloneEvBindsVar ebv@(CoEvBindsVar {}) - = do { tcvs_ref <- newTcRef emptyVarSet + = do { tcvs_ref <- newTcRef [] ; return (ebv { ebv_tcvs = tcvs_ref }) } -getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet +getTcEvTyCoVars :: EvBindsVar -> TcM [TcCoercion] getTcEvTyCoVars ev_binds_var = readTcRef (ebv_tcvs ev_binds_var) @@ -1790,16 +1810,52 @@ | otherwise = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds) +updTcEvBinds :: EvBindsVar -> EvBindsVar -> TcM () +updTcEvBinds (EvBindsVar { ebv_binds = old_ebv_ref, ebv_tcvs = old_tcv_ref }) + (EvBindsVar { ebv_binds = new_ebv_ref, ebv_tcvs = new_tcv_ref }) + = do { new_ebvs <- readTcRef new_ebv_ref + ; updTcRef old_ebv_ref (`unionEvBindMap` new_ebvs) + ; new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (new_tcvs ++) } +updTcEvBinds (EvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (new_tcvs ++) } +updTcEvBinds (CoEvBindsVar { ebv_tcvs = old_tcv_ref }) + (CoEvBindsVar { ebv_tcvs = new_tcv_ref }) + = do { new_tcvs <- readTcRef new_tcv_ref + ; updTcRef old_tcv_ref (new_tcvs ++) } +updTcEvBinds old_var new_var + = pprPanic "updTcEvBinds" (ppr old_var $$ ppr new_var) + -- Terms inside types, no good + addTcEvBind :: EvBindsVar -> EvBind -> TcM () -- Add a binding to the TcEvBinds by side effect addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind - = do { traceTc "addTcEvBind" $ ppr u $$ - ppr ev_bind - ; bnds <- readTcRef ev_ref - ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) } + = do { bnds <- readTcRef ev_ref + ; let bnds' = extendEvBinds bnds ev_bind + ; traceTc "addTcEvBind" $ + vcat [ text "EvBindsVar:" <+> ppr u + , text "ev_bind:" <+> ppr ev_bind + , text "bnds:" <+> ppr bnds + , text "bnds':" <+> ppr bnds' ] + ; writeTcRef ev_ref bnds' } addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u) +addTcEvBinds :: EvBindsVar -> EvBindMap -> TcM () +-- ^ Add a collection of binding to the TcEvBinds by side effect +addTcEvBinds _ new_ev_binds + | isEmptyEvBindMap new_ev_binds + = return () +addTcEvBinds (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) new_ev_binds + = do { traceTc "addTcEvBinds" $ ppr u $$ + ppr new_ev_binds + ; old_bnds <- readTcRef ev_ref + ; writeTcRef ev_ref (old_bnds `unionEvBindMap` new_ev_binds) } +addTcEvBinds (CoEvBindsVar { ebv_uniq = u }) new_ev_binds + = pprPanic "addTcEvBinds CoEvBindsVar" (ppr new_ev_binds $$ ppr u) + chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn = do { env <- getGblEnv @@ -1809,6 +1865,18 @@ ; writeTcRef dfun_n_var (extendOccSet set occ) ; return occ } +newZonkAnyType :: Kind -> TcM Type +-- Return a type (ZonkAny @k n), where n is fresh +-- Recall ZonkAny :: forall k. Natural -> k +-- See Note [Any types] in GHC.Builtin.Types, wrinkle (Any4) +newZonkAnyType kind + = do { env <- getGblEnv + ; let zany_n_var = tcg_zany_n env + ; i <- readTcRef zany_n_var + ; let !i2 = i+1 + ; writeTcRef zany_n_var i2 + ; return (mkTyConApp zonkAnyTyCon [kind, mkNumLitTy i]) } + getConstraintVar :: TcM (TcRef WantedConstraints) getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) } @@ -1873,6 +1941,15 @@ ; lie_var <- getConstraintVar ; updTcRef lie_var (`addNotConcreteError` err) } +-- See Note [Coercion errors in tcSubMult] in GHC.Tc.Utils.Unify. +ensureReflMultiplicityCo :: TcCoercion -> CtOrigin -> TcM () +ensureReflMultiplicityCo mult_co origin + = do { traceTc "ensureReflMultiplicityCo" (ppr mult_co) + ; unless (isReflCo mult_co) $ do + { loc <- getCtLocM origin Nothing + ; lie_var <- getConstraintVar + ; updTcRef lie_var (\w -> addMultiplicityCoercionError w mult_co loc) } } + -- | Throw out any constraints emitted by the thing_inside discardConstraints :: TcM a -> TcM a discardConstraints thing_inside = fst <$> captureConstraints thing_inside @@ -2014,30 +2091,53 @@ emitted some constraints with skolem-escape problems. * If we discard too /few/ constraints, we may get the misleading - class constraints mentioned above. But we may /also/ end up taking - constraints built at some inner level, and emitting them at some - outer level, and then breaking the TcLevel invariants - See Note [TcLevel invariants] in GHC.Tc.Utils.TcType + class constraints mentioned above. -So dropMisleading has a horridly ad-hoc structure. It keeps only -/insoluble/ flat constraints (which are unlikely to very visibly trip -up on the TcLevel invariant, but all /implication/ constraints (except -the class constraints inside them). The implication constraints are -OK because they set the ambient level before attempting to solve any -inner constraints. Ugh! I hate this. But it seems to work. + We may /also/ end up taking constraints built at some inner level, and + emitting them (via the exception catching in `tryCaptureConstraints` at some + outer level, and then breaking the TcLevel invariants See Note [TcLevel + invariants] in GHC.Tc.Utils.TcType -However note that freshly-generated constraints like (Int ~ Bool), or -((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as -insoluble. The constraint solver does that. So they'll be discarded. -That's probably ok; but see th/5358 as a not-so-good example: - t1 :: Int - t1 x = x -- Manifestly wrong +So `dropMisleading` has a horridly ad-hoc structure: - foo = $(...raises exception...) -We report the exception, but not the bug in t1. Oh well. Possible -solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints. +* It keeps only /insoluble/ flat constraints (which are unlikely to very visibly + trip up on the TcLevel invariant +* But it keeps all /implication/ constraints (except the class constraints + inside them). The implication constraints are OK because they set the ambient + level before attempting to solve any inner constraints. +Ugh! I hate this. But it seems to work. + +Other wrinkles + +(CERR1) Note that freshly-generated constraints like (Int ~ Bool), or + ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as + insoluble. The constraint solver does that. So they'll be discarded. + That's probably ok; but see th/5358 as a not-so-good example: + t1 :: Int + t1 x = x -- Manifestly wrong + + foo = $(...raises exception...) + We report the exception, but not the bug in t1. Oh well. Possible + solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints. + +(CERR2) In #26015 I found that from the constraints + [W] alpha ~ Int -- A class constraint + [W] F alpha ~# Bool -- An equality constraint + we were dropping the first (becuase it's a class constraint) but not the + second, and then getting a misleading error message from the second. As + #25607 shows, we can get not just one but a zillion bogus messages, which + conceal the one genuine error. Boo. + + For now I have added an even more ad-hoc "drop class constraints except + equality classes (~) and (~~)"; see `dropMisleading`. That just kicks the can + down the road; but this problem seems somewhat rare anyway. The code in + `dropMisleading` hasn't changed for years. + +It would be great to have a more systematic solution to this entire mess. + + ************************************************************************ * * Template Haskell context @@ -2048,9 +2148,6 @@ recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } -recordThSpliceUse :: TcM () -recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } - recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM () recordThNeededRuntimeDeps new_links new_pkgs = do { env <- getGblEnv @@ -2066,19 +2163,39 @@ ; traceRn "keep alive" (ppr name) ; updTcRef (tcg_keep env) (`extendNameSet` name) } -getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (getLclEnvThStage env) } +getThLevel :: TcM ThLevel +getThLevel = do { env <- getLclEnv; return (getLclEnvThLevel env) } -getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) -getStageAndBindLevel name +getCurrentAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, Set.Set ThLevelIndex, ThLevel)) +getCurrentAndBindLevel name = do { env <- getLclEnv; ; case lookupNameEnv (getLclEnvThBndrs env) name of - Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, getLclEnvThStage env)) } + Nothing -> do + lvls <- getExternalBindLvl name + if Set.empty == lvls + -- This case happens when code is generated for identifiers which are not + -- in scope. + -- + -- TODO: What happens if someone generates [|| GHC.Magic.dataToTag# ||] + then do + return Nothing + else return (Just (TopLevel, lvls, getLclEnvThLevel env)) + Just (top_lvl, bind_lvl) -> return (Just (top_lvl, Set.singleton bind_lvl, getLclEnvThLevel env)) } -setStage :: ThStage -> TcM a -> TcRn a -setStage s = updLclEnv (setLclEnvThStage s) +getExternalBindLvl :: Name -> TcRn (Set.Set ThLevelIndex) +getExternalBindLvl name = do + env <- getGlobalRdrEnv + mod <- getModule + case lookupGRE_Name env name of + Just gre -> return $ (Set.map thLevelIndexFromImportLevel (greLevels gre)) + Nothing -> + if nameIsLocalOrFrom mod name + then return $ Set.singleton topLevelIndex + else return Set.empty +setThLevel :: ThLevel -> TcM a -> TcRn a +setThLevel l = updLclEnv (setLclEnvThLevel l) + -- | Adds the given modFinalizers to the global environment and set them to use -- the current local environment. addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () @@ -2325,3 +2442,20 @@ , zge_binder_stack = bndrs } ; liftIO $ f zge } {-# INLINE liftZonkM #-} + +-------------------------------------------------------------------------------- + +getCompleteMatchesTcM :: TcM CompleteMatches +getCompleteMatchesTcM + = do { hsc_env <- getTopEnv + ; eps <- liftIO $ hscEPS hsc_env + ; tcg_env <- getGblEnv + ; let tcg_comps = tcg_complete_match_env tcg_env + ; liftIO $ localAndImportedCompleteMatches tcg_comps eps + } + +localAndImportedCompleteMatches :: CompleteMatches -> ExternalPackageState -> IO CompleteMatches +localAndImportedCompleteMatches tcg_comps eps = do + return $ + tcg_comps -- from the current modulea and from the home package + ++ eps_complete_matches eps -- from external packages diff --git a/GHC/Tc/Utils/TcMType.hs b/GHC/Tc/Utils/TcMType.hs --- a/GHC/Tc/Utils/TcMType.hs +++ b/GHC/Tc/Utils/TcMType.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- @@ -23,9 +25,10 @@ newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, + newOpenFlexiFRRTyVar, newOpenFlexiFRRTyVarTy, newOpenBoxedTypeKind, newMetaKindVar, newMetaKindVars, - newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, + newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, substConcreteTvOrigin, newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar, cloneMetaTyVarWithInfo, newCycleBreakerTyVar, @@ -39,30 +42,30 @@ -- Creating new evidence variables newEvVar, newEvVars, newDict, newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, + emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEqs, newTcEvBinds, newNoTcEvBinds, addTcEvBind, emitNewExprHole, - newCoercionHole, newCoercionHoleO, newVanillaCoercionHole, + newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, checkCoercionHole, newImplication, -------------------------------- -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, - newPatSigTyVar, newSkolemTyVar, newWildCardX, + newConcreteTyVarX, + newPatTyVar, newSkolemTyVar, newWildCardX, -------------------------------- -- Expected types ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType, newInferExpType, newInferExpTypeFRR, - tcInfer, tcInferFRR, + runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR, readExpType, readExpType_maybe, readScaledExpType, expTypeToType, scaledExpTypeToType, checkingExpType_maybe, checkingExpType, @@ -75,13 +78,12 @@ --------------------------------- -- Promotion, defaulting, skolemisation defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, - quantifyTyVars, isQuantifiableTv, + quantifyTyVars, doNotQuantifyTyVars, zonkAndSkolemise, skolemiseQuantifiedTyVar, - doNotQuantifyTyVars, candidateQTyVarsOfType, candidateQTyVarsOfKind, candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, - candidateQTyVarsWithBinders, + candidateQTyVarsWithBinders, weedOutCandidates, CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates, @@ -108,10 +110,10 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence +import GHC.Tc.Types.CtLoc( CtLoc ) import GHC.Tc.Utils.Monad -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types -import GHC.Tc.Zonk.Type import GHC.Tc.Zonk.TcType import GHC.Builtin.Names @@ -120,6 +122,7 @@ import GHC.Core.DataCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Tidy import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.Coercion @@ -146,7 +149,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import Control.Monad @@ -198,12 +200,13 @@ newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence newWantedWithLoc loc pty = do dst <- case classifyPredType pty of - EqPred {} -> HoleDest <$> newCoercionHole loc pty + EqPred {} -> HoleDest <$> newCoercionHole pty _ -> EvVarDest <$> newEvVar pty - return $ CtWanted { ctev_dest = dst - , ctev_pred = pty - , ctev_loc = loc - , ctev_rewriters = emptyRewriterSet } + return $ CtWanted $ + WantedCt { ctev_dest = dst + , ctev_pred = pty + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } -- | Create a new Wanted constraint with the given 'CtOrigin', and -- location information taken from the 'TcM' environment. @@ -223,10 +226,10 @@ ---------------------------------------------- cloneWantedCtEv :: CtEvidence -> TcM CtEvidence -cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _, ctev_loc = loc }) - | isEqPrimPred pty - = do { co_hole <- newCoercionHole loc pty - ; return (ctev { ctev_dest = HoleDest co_hole }) } +cloneWantedCtEv (CtWanted ctev@(WantedCt { ctev_pred = pty, ctev_dest = HoleDest _ })) + | isEqPred pty + = do { co_hole <- newCoercionHole pty + ; return $ CtWanted (ctev { ctev_dest = HoleDest co_hole }) } | otherwise = pprPanic "cloneWantedCtEv" (ppr pty) cloneWantedCtEv ctev = return ctev @@ -273,16 +276,16 @@ -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion emitWantedEq origin t_or_k role ty1 ty2 - = do { hole <- newCoercionHoleO origin pty + = do { hole <- newCoercionHole pty ; loc <- getCtLocM origin (Just t_or_k) - ; emitSimple $ mkNonCanonical $ - CtWanted { ctev_pred = pty - , ctev_dest = HoleDest hole - , ctev_loc = loc - , ctev_rewriters = emptyRewriterSet } + ; emitSimple $ mkNonCanonical $ CtWanted $ + WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } ; return (HoleCo hole) } where - pty = mkPrimEqPredRole role ty1 ty2 + pty = mkEqPredRole role ty1 ty2 -- | Creates a new EvVar and immediately emits it as a Wanted. -- No equality predicates here. @@ -290,16 +293,13 @@ emitWantedEvVar origin ty = do { new_cv <- newEvVar ty ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_pred = ty + ; let ctev = WantedCt { ctev_pred = ty , ctev_dest = EvVarDest new_cv , ctev_loc = loc , ctev_rewriters = emptyRewriterSet } - ; emitSimple $ mkNonCanonical ctev + ; emitSimple $ mkNonCanonical $ CtWanted ctev ; return new_cv } -emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar] -emitWantedEvVars orig = mapM (emitWantedEvVar orig) - -- | Emit a new wanted expression hole emitNewExprHole :: RdrName -- of the hole -> Type -> TcM HoleExprRef @@ -355,23 +355,13 @@ ************************************************************************ -} -newVanillaCoercionHole :: TcPredType -> TcM CoercionHole -newVanillaCoercionHole = new_coercion_hole False - -newCoercionHole :: CtLoc -> TcPredType -> TcM CoercionHole -newCoercionHole loc = newCoercionHoleO (ctLocOrigin loc) - -newCoercionHoleO :: CtOrigin -> TcPredType -> TcM CoercionHole -newCoercionHoleO (KindEqOrigin {}) = new_coercion_hole True -newCoercionHoleO _ = new_coercion_hole False - -new_coercion_hole :: Bool -> TcPredType -> TcM CoercionHole -new_coercion_hole hetero_kind pred_ty +newCoercionHole :: TcPredType -> TcM CoercionHole +-- For the Bool, see (EIK2) in Note [Equalities with heterogeneous kinds] +newCoercionHole pred_ty = do { co_var <- newEvVar pred_ty ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty) ; ref <- newMutVar Nothing - ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref - , ch_hetero_kind = hetero_kind } } + ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } } -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM () @@ -448,30 +438,29 @@ -- actual data definition is in GHC.Tc.Utils.TcType -newInferExpType :: TcM ExpType -newInferExpType = new_inferExpType Nothing +newInferExpType :: InferInstFlag -> TcM ExpType +newInferExpType iif = new_inferExpType iif IFRR_Any -newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR -newInferExpTypeFRR frr_orig - = do { th_stage <- getStage - ; if - -- See [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | Brack _ (TcPending {}) <- th_stage - -> new_inferExpType Nothing +newInferExpTypeFRR :: InferInstFlag -> FixedRuntimeRepContext -> TcM ExpTypeFRR +newInferExpTypeFRR iif frr_orig + = do { th_lvl <- getThLevel + ; let mb_frr = case th_lvl of + TypedBrack {} -> IFRR_Any + _ -> IFRR_Check frr_orig + -- mb_frr: see [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | otherwise - -> new_inferExpType (Just frr_orig) } + ; new_inferExpType iif mb_frr } -new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType -new_inferExpType mb_frr_orig +new_inferExpType :: InferInstFlag -> InferFRRFlag -> TcM ExpType +new_inferExpType iif ifrr = do { u <- newUnique ; tclvl <- getTcLevel ; traceTc "newInferExpType" (ppr u <+> ppr tclvl) ; ref <- newMutVar Nothing ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl - , ir_ref = ref - , ir_frr = mb_frr_orig })) } + , ir_inst = iif, ir_frr = ifrr + , ir_ref = ref })) } -- | Extract a type out of an ExpType, if one exists. But one should always -- exist. Unless you're quite sure you know what you're doing. @@ -525,12 +514,12 @@ where -- See Note [TcLevel of ExpType] new_meta = case mb_frr of - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + IFRR_Any -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } - Just frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) - ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr - ; return tau } + IFRR_Check frr -> mdo { rr <- newConcreteTyVarTyAtLevel conc_orig tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr + ; return tau } {- Note [inferResultToType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -547,20 +536,31 @@ -- | Infer a type using a fresh ExpType -- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" -- --- Use 'tcInferFRR' if you require the type to have a fixed +-- Use 'runInferFRR' if you require the type to have a fixed -- runtime representation. -tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer = tc_infer Nothing +runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInferSigma = runInfer IIF_Sigma IFRR_Any --- | Like 'tcInfer', except it ensures that the resulting type +runInferRho :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType) +runInferRho = runInfer IIF_DeepRho IFRR_Any + +runInferKind :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +-- Used for kind-checking types, where we never want deep instantiation, +-- nor FRR checks +runInferKind = runInfer IIF_Sigma IFRR_Any + +-- | Like 'runInferRho', except it ensures that the resulting type -- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in -- GHC.Tc.Utils.Concrete. -tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) -tcInferFRR frr_orig = tc_infer (Just frr_orig) +runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR) +runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig) -tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tc_infer mb_frr tc_check - = do { res_ty <- new_inferExpType mb_frr +runInferSigmaFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR) +runInferSigmaFRR frr_orig = runInfer IIF_Sigma (IFRR_Check frr_orig) + +runInfer :: InferInstFlag -> InferFRRFlag -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInfer iif mb_frr tc_check + = do { res_ty <- new_inferExpType iif mb_frr ; result <- tc_check res_ty ; res_ty <- readExpType res_ty ; return (result, res_ty) } @@ -753,7 +753,7 @@ = do { name <- newMetaTyVarName tyvar_name ; details <- newMetaDetails meta_info ; let tyvar = mkTcTyVar name kind details - ; traceTc "newAnonMetaTyVar" (ppr tyvar) + ; traceTc "newAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr kind) ; return tyvar } -- makes a new skolem tv @@ -795,19 +795,27 @@ -> FastString -> TcKind -> TcM TcTyVar newConcreteTyVar reason fs kind = assertPpr (isConcreteType kind) assert_msg $ - newNamedAnonMetaTyVar fs (ConcreteTv reason) kind + do { th_lvl <- getThLevel + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | TypedBrack _ <- th_lvl + -> newNamedAnonMetaTyVar fs TauTv kind + + | otherwise + -> newNamedAnonMetaTyVar fs (ConcreteTv reason) kind } where assert_msg = text "newConcreteTyVar: non-concrete kind" <+> ppr kind -newPatSigTyVar :: Name -> Kind -> TcM TcTyVar -newPatSigTyVar name kind +newPatTyVar :: Name -> Kind -> TcM TcTyVar +newPatTyVar name kind = do { details <- newMetaDetails TauTv ; uniq <- newUnique ; let name' = name `setNameUnique` uniq tyvar = mkTcTyVar name' kind details -- Don't use cloneMetaTyVar; -- same reasoning as in newTyVarTyVar - ; traceTc "newPatSigTyVar" (ppr tyvar) + ; traceTc "newPatTyVar" (ppr tyvar) ; return tyvar } cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar @@ -820,8 +828,8 @@ ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) ; return tyvar } --- Make a new CycleBreakerTv. See Note [Type equality cycles] --- in GHC.Tc.Solver.Equality +-- | Make a new cycle-breaker type variable. See Note [Type equality cycles] +-- in GHC.Tc.Solver.Equality. newCycleBreakerTyVar :: TcKind -> TcM TcTyVar newCycleBreakerTyVar kind = do { details <- newMetaDetails CycleBreakerTv @@ -953,7 +961,11 @@ ; return (mkTYPEapp rr) } -- | Create a tyvar that can be a lifted or unlifted type. --- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh +-- Returns @alpha :: TYPE kappa@, where both @alpha@ and @kappa@ are fresh. +-- +-- Note: you should use 'newOpenFlexiFRRTyVarTy' if you also need to ensure +-- that the representation is concrete, in the sense of Note [Concrete types] +-- in GHC.Tc.Utils.Concrete. newOpenFlexiTyVarTy :: TcM TcType newOpenFlexiTyVarTy = do { tv <- newOpenFlexiTyVar @@ -964,6 +976,30 @@ = do { kind <- newOpenTypeKind ; newFlexiTyVar kind } +-- | Like 'newOpenFlexiTyVar', but ensures the type variable has a +-- syntactically fixed RuntimeRep in the sense of Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar +newOpenFlexiFRRTyVar frr_ctxt + = do { th_lvl <- getThLevel + ; case th_lvl of + { TypedBrack _ -- See [Wrinkle: Typed Template Haskell] + -> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + ; _ -> + mdo { let conc_orig = ConcreteFRR $ + FixedRuntimeRepOrigin + { frr_context = frr_ctxt + , frr_type = mkTyVarTy tv } + ; rr <- mkTyVarTy <$> newConcreteTyVar conc_orig (fsLit "cx") runtimeRepTy + ; tv <- newFlexiTyVar (mkTYPEapp rr) + ; return tv } } } + +-- | See 'newOpenFlexiFRRTyVar'. +newOpenFlexiFRRTyVarTy :: FixedRuntimeRepContext -> TcM TcType +newOpenFlexiFRRTyVarTy frr_ctxt + = do { tv <- newOpenFlexiFRRTyVar frr_ctxt + ; return (mkTyVarTy tv) } + newOpenBoxedTypeKind :: TcM TcKind newOpenBoxedTypeKind = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) @@ -984,14 +1020,33 @@ -- Just like newMetaTyVars, but start with an existing substitution. newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst +newMetaTyVarBndrsX :: Subst -> [VarBndr TyVar vis] -> TcM (Subst, [VarBndr TcTyVar vis]) +newMetaTyVarBndrsX subst bndrs = do + (subst, bndrs') <- newMetaTyVarsX subst (binderVars bndrs) + pure (subst, zipWith mkForAllTyBinder flags bndrs') + where + flags = binderFlags bndrs + newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Make a new unification variable tyvar whose Name and Kind come from -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX = new_meta_tv_x TauTv +-- | Like 'newMetaTyVarX', but for concrete type variables. +newConcreteTyVarX :: ConcreteTvOrigin -> Subst -> TyVar -> TcM (Subst, TcTyVar) +newConcreteTyVarX conc subst tv + = do { th_lvl <- getThLevel + ; if + -- See [Wrinkle: Typed Template Haskell] + -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | TypedBrack _ <- th_lvl + -> new_meta_tv_x TauTv subst tv + | otherwise + -> new_meta_tv_x (ConcreteTv conc) subst tv } + newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX = new_meta_tv_x TyVarTv +newMetaTyVarTyVarX subst tv = new_meta_tv_x TyVarTv subst tv newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) newWildCardX subst tv @@ -1004,16 +1059,7 @@ ; let subst1 = extendTvSubstWithClone subst tv new_tv ; return (subst1, new_tv) } where - substd_kind = substTyUnchecked subst (tyVarKind tv) - -- NOTE: #12549 is fixed so we could use - -- substTy here, but the tc_infer_args problem - -- is not yet fixed so leaving as unchecked for now. - -- OLD NOTE: - -- Unchecked because we call newMetaTyVarX from - -- tcInstTyBinder, which is called from tcInferTyApps - -- which does not yet take enough trouble to ensure - -- the in-scope set is right; e.g. #12785 trips - -- if we use substTy here + substd_kind = substTy subst (tyVarKind tv) newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType newMetaTyVarTyAtLevel tc_lvl kind @@ -1027,6 +1073,91 @@ ; name <- newMetaTyVarName (fsLit "c") ; return (mkTyVarTy (mkTcTyVar name kind details)) } +{- Note [substConcreteTvOrigin] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To report helpful representation-polymorphism errors to the users, we want to +indicate which type caused the error, instead of simply printing kinds. +For example, in + + coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b + + bad :: forall {s} (z :: TYPE s). z -> z + bad = coerce + +we want the error message to say (with additional debug info on type variables +for clarity of this explanation): + + The first argument of 'coerce' does not have a fixed runtime representation. + Its type is: + a0[tau] :: TYPE r0[conc] + Could not unify s[sk] with r0[conc] because the former is not a concrete + RuntimeRep. + +This is more informative than just saying that we could not unify s[sk] with +r0[conc]; it's helpful to users to phrase it in terms of types rather than kinds +whenever possible (especially as the kind variables often have inferred Specificity). + +To achieve this, we store the type on which the representation-polymorphism +check is being performed, in the field frr_type of FixedRuntimeRepOrigin. +This is all described in Note [Reporting representation-polymorphism errors] in +GHC.Tc.Types.Origin. + +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.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': + + FixedRuntimeRepOrigin + { frr_type = a[tv] :: TYPE r[tv] + , frr_context = "first argument of coerce" } + +When we instantiate 'coerce' in the previous example, we obtain a substitution + + [ r[tv] |-> r0[conc], a |-> a0 :: TYPE r0[conc] ] + +which we need to apply to the 'frr_type' field in order for the type variables +in the error message to match up. +This is done by the call to 'substConcreteTvOrigin' in 'instantiateSigma'. + +Wrinkle [Extending the substitution] + + In certain cases, we need to extend the substitution we get from 'instantiateSigma'. + For example, suppose we have: + + bad2 :: forall {s} (z :: TYPE s). z -> z + bad2 = coerce @z + + Then 'instantiateSigma' will only instantiate the inferred type variable 'r' + of 'coerce', as it needs to leave 'a' un-instantiated so that the visible + type application '@z' makes sense. In this case, we end up with a substitution + + subst: [ r[tv] |-> r0[conc] ] + body_ty: forall (a :: TYPE r[tv]) (b :: TYPE r[tv]). ... + substTy subst body_ty: forall (a' :: TYPE r0[conc]) (b' :: TYPE r0[conc]). ... + + Now, we still want a substitution that maps (a :: TYPE r[tv]) to + (a' :: TYPE r0[conc]) in order to apply it to the 'frr_type', so that we don't + mention the un-substed (a :: TYPE r[tv]) in the error message. + To achieve this, we extend the substitution with the outermost quantified type + variables in the leftover (partially-instantiated) type using 'substTyVarBndrs' + to get the full substitution which we use in 'substConcreteTvOrigin'. +-} + +substConcreteTvOrigin :: Subst -> Type -> ConcreteTvOrigin -> ConcreteTvOrigin +substConcreteTvOrigin subst body_ty (ConcreteFRR frr_orig) + -- See Note [substConcreteTvOrigin], Wrinkle [Extending the substitution] + -- for the justification of this extra complication. + = let subst' = case splitForAllTyCoVars body_ty of + ([], _) -> subst + (bndrs, _) -> fst $ substTyVarBndrs subst bndrs + in ConcreteFRR $ substFRROrigin subst' frr_orig + +substFRROrigin :: Subst -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin +substFRROrigin subst orig@(FixedRuntimeRepOrigin { frr_type = ty }) + = orig { frr_type = substTy subst ty } + {- ********************************************************************* * * Finding variables to quantify over @@ -1209,6 +1340,10 @@ , text "dv_tvs =" <+> ppr tvs , text "dv_cvs =" <+> ppr cvs ]) +weedOutCandidates :: (DTyVarSet -> DTyVarSet) -> CandidatesQTvs -> CandidatesQTvs +weedOutCandidates weed_out dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) + = dv { dv_kvs = weed_out kvs, dv_tvs = weed_out tvs } + isEmptyCandidates :: CandidatesQTvs -> Bool isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) = isEmptyDVarSet kvs && isEmptyDVarSet tvs @@ -1365,12 +1500,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 @@ -1429,11 +1564,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 @@ -1443,25 +1578,20 @@ go_co dv (SubCo co) = go_co dv co go_co dv (HoleCo hole) - = do m_co <- unpackCoercionHole_maybe hole + = do m_co <- liftZonkM (unpackCoercionHole_maybe hole) case m_co of Just co -> go_co dv co Nothing -> go_cv dv (coHoleCoVar hole) go_co dv (CoVarCo cv) = go_cv dv cv - go_co dv (ForAllCo tcv kind_co co) + go_co dv (ForAllCo { fco_tcv = tcv, fco_kind = kind_co, fco_body = co }) = do { dv1 <- go_co dv kind_co ; collect_cand_qtvs_co orig_ty cur_lvl (bound `extendVarSet` tcv) dv1 co } 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_prov dv (CorePrepProv _) = return dv - go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs go_cv dv@(DV { dv_cvs = cvs }) cv | is_bound cv = return dv @@ -1590,7 +1720,7 @@ Note that not *every* variable with a higher level will get generalised, either due to the monomorphism restriction or other -quirks. See, for example, the code in GHC.Tc.Solver.decideMonoTyVars +quirks. See, for example, the code in GHC.Tc.Solver.decidePromotedTyVars and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible variables from being generalised. @@ -1659,15 +1789,6 @@ | otherwise = Just <$> skolemiseQuantifiedTyVar skol_info tkv -isQuantifiableTv :: TcLevel -- Level of the context, outside the quantification - -> TcTyVar - -> Bool -isQuantifiableTv outer_tclvl tcv - | isTcTyVar tcv -- Might be a CoVar; change this when gather covars separately - = tcTyVarLevel tcv > outer_tclvl - | otherwise - = False - zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> ZonkM TcTyCoVar -- A tyvar binder is never a unification variable (TauTv), -- rather it is always a skolem. It *might* be a TyVarTv. @@ -1779,7 +1900,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 @@ -1788,8 +1910,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: @@ -1995,7 +2115,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) } @@ -2141,27 +2261,24 @@ -- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the -- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the --- usage environment. See also Note [Wrapper returned from tcSubMult] in --- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function. -tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper) +-- usage environment. +tcCheckUsage :: Name -> Mult -> TcM a -> TcM a tcCheckUsage name id_mult thing_inside = do { (local_usage, result) <- tcCollectingUsage thing_inside - ; wrapper <- check_then_add_usage local_usage - ; return (result, wrapper) } + ; check_usage (lookupUE local_usage name) + ; tcEmitBindingUsage (deleteUE local_usage name) + ; return result } where - check_then_add_usage :: UsageEnv -> TcM HsWrapper + check_usage :: Usage -> TcM () -- Checks that the usage of the newly introduced binder is compatible with - -- its multiplicity, and combines the usage of non-new binders to |uenv| - check_then_add_usage uenv - = do { let actual_u = lookupUE uenv name - ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) - ; wrapper <- case actual_u of - Bottom -> return idHsWrapper + -- its multiplicity. + check_usage actual_u + = do { traceTc "check_usage" (ppr id_mult $$ ppr actual_u) + ; case actual_u of + Bottom -> return () Zero -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult MUsage m -> do { m <- promote_mult m - ; tcSubMult (UsageEnvironmentOf name) m id_mult } - ; tcEmitBindingUsage (deleteUE uenv name) - ; return wrapper } + ; tcSubMult (UsageEnvironmentOf name) m id_mult } } -- This is gross. The problem is in test case typecheck/should_compile/T18998: -- f :: a %1-> Id n a -> Id n a @@ -2239,11 +2356,11 @@ where go_integral int@(IL src neg i) | isIntTy res_ty && platformInIntRange platform i - = Just (HsLit noAnn (HsInt noExtField int)) + = Just (HsLit noExtField (HsInt noExtField int)) | isWordTy res_ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) | isIntegerTy res_ty - = Just (HsLit noAnn (HsInteger src i res_ty)) + = Just (HsLit noExtField (XLit $ HsInteger src i res_ty)) | otherwise = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important @@ -2264,11 +2381,11 @@ -- is less than 100, which ensures desugaring isn't slow. go_string src s - | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) +mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) ------------------------------ hsOverLitName :: OverLitVal -> Name @@ -2289,7 +2406,7 @@ -- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType -- Return True <=> we did some promotion -- Also returns either the original tyvar (no promotion) or the new one --- See Note [Promoting unification variables] +-- See Note [Promote monomorphic tyvars] in GHC.Tc.Solver promoteMetaTyVarTo tclvl tv | assertPpr (isMetaTyVar tv) (ppr tv) $ tcTyVarLevel tv `strictlyDeeperThan` tclvl @@ -2334,14 +2451,11 @@ unless (typeHasFixedRuntimeRep ty) (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) -{- -%************************************************************************ -%* * +{- ********************************************************************** +* * Error messages * * -************************************************************************* - --} +********************************************************************** -} -- See Note [Naughty quantification candidates] naughtyQuantification :: TcType -- original type user wanted to quantify @@ -2356,7 +2470,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 diff --git a/GHC/Tc/Utils/TcMType.hs-boot b/GHC/Tc/Utils/TcMType.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Utils/TcMType.hs-boot @@ -0,0 +1,7 @@ +module GHC.Tc.Utils.TcMType where + +import GHC.Tc.Types +import GHC.Types.Name +import GHC.Core.TyCo.Rep + +tcCheckUsage :: Name -> Mult -> TcM a -> TcM a diff --git a/GHC/Tc/Utils/TcType.hs b/GHC/Tc/Utils/TcType.hs --- a/GHC/Tc/Utils/TcType.hs +++ b/GHC/Tc/Utils/TcType.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} {- (c) The University of Glasgow 2006 @@ -22,17 +24,20 @@ -------------------------------- -- Types TcType, TcSigmaType, TcTypeFRR, TcSigmaTypeFRR, - TcRhoType, TcTauType, TcPredType, TcThetaType, + TcRhoType, TcRhoTypeFRR, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcReqTVBinder, TcTyCon, MonoTcTyCon, PolyTcTyCon, TcTyConBinder, KnotTied, - ExpType(..), InferResult(..), + ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, - ExpRhoType, + ExpRhoType, ExpRhoTypeFRR, mkCheckExpType, checkingExpType_maybe, checkingExpType, + ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType, + isVisibleExpPatType, isExpFunPatType, + SyntaxOpType(..), synKnownType, mkSynFunTys, -------------------------------- @@ -48,9 +53,11 @@ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar, - isConcreteTyVarTy, isConcreteTyVarTy_maybe, isConcreteInfo, + isConcreteTyVarTy, isConcreteTyVarTy_maybe, concreteInfo_maybe, + ConcreteTyVars, noConcreteTyVars, isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, + isQLInstTyVar, isRuntimeUnkTyVar, metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, isTouchableMetaTyVar, isPromotableMetaTyVar, findDupTyVarTvs, mkTyVarNamePairs, @@ -63,7 +70,7 @@ -------------------------------- -- Splitters getTyVar, getTyVar_maybe, getCastedTyVar_maybe, - tcSplitForAllTyVarBinder_maybe, + tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN, tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders, @@ -73,7 +80,7 @@ tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, - tcSplitSigmaTy, tcSplitNestedSigmaTys, tcSplitIOType_maybe, + tcSplitSigmaTy, tcSplitSigmaTyBndrs, tcSplitNestedSigmaTys, tcSplitIOType_maybe, --------------------------------- -- Predicates. @@ -81,17 +88,17 @@ isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isNaturalTy, - isBoolTy, isUnitTy, isCharTy, + isBoolTy, isUnitTy, isAnyTy, isZonkAnyTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, - isPredTy, isTyVarClassPred, + isPredTy, isSimplePredTy, isTyVarClassPred, checkValidClsArgs, hasTyVarHead, isRigidTy, anyTy_maybe, -- Re-exported from GHC.Core.TyCo.Compare -- mainly just for back-compat reasons - eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + eqType, eqTypes, nonDetCmpType, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, mayLookIdentical, tcEqTyConApps, eqForAllVis, eqVarBndrs, --------------------------------- @@ -113,7 +120,7 @@ -- * Finding "exact" (non-dead) type variables exactTyCoVarsOfType, exactTyCoVarsOfTypes, - anyRewritableTyVar, anyRewritableTyFamApp, + anyRewritableTyVar, anyRewritableTyFamApp, UnderFam, --------------------------------- -- Patersons sizes @@ -123,7 +130,7 @@ pSizeZero, pSizeOne, pSizeType, pSizeTypeX, pSizeTypes, pSizeClassPred, pSizeClassPredX, - pSizeTyConApp, + pSizeTyConApp, pSizeHead, noMoreTyVars, allDistinctTyVars, TypeSize, sizeType, sizeTypes, scopedSort, isTerminatingClass, isStuckTypeFamily, @@ -148,7 +155,7 @@ mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - isClassPred, isEqPrimPred, isIPLikePred, isEqPred, + isClassPred, isEqPred, couldBeIPLike, isEqClassPred, isEqualityClass, mkClassPred, tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, @@ -159,11 +166,11 @@ TvSubstEnv, emptySubst, mkEmptySubst, zipTvSubst, mkTvSubstPrs, notElemSubst, unionSubst, - getTvSubstEnv, getSubstInScope, extendSubstInScope, + getTvSubstEnv, substInScopeSet, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, - isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv, + isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, @@ -220,6 +227,7 @@ import GHC.Types.Name as Name -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? +import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey @@ -230,13 +238,11 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.IORef ( IORef ) import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition, nub, (\\) ) - {- ************************************************************************ * * @@ -374,6 +380,7 @@ -- See Note [Return arguments with a fixed RuntimeRep. type TcSigmaTypeFRR = TcSigmaType -- TODO: consider making this a newtype. +type TcRhoTypeFRR = TcRhoType type TcRhoType = TcType -- Note [TcRhoType] type TcTauType = TcType @@ -402,9 +409,13 @@ , ir_lvl :: TcLevel -- ^ See Note [TcLevel of ExpType] in GHC.Tc.Utils.TcMType - , ir_frr :: Maybe FixedRuntimeRepContext + , ir_frr :: InferFRRFlag -- ^ See Note [FixedRuntimeRep context in ExpType] in GHC.Tc.Utils.TcMType + , ir_inst :: InferInstFlag + -- ^ True <=> when DeepSubsumption is on, deeply instantiate before filling, + -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify + , ir_ref :: IORef (Maybe TcType) } -- ^ The type that fills in this hole should be a @Type@, -- that is, its kind should be @TYPE rr@ for some @rr :: RuntimeRep@. @@ -413,34 +424,67 @@ -- @rr@ must be concrete, in the sense of Note [Concrete types] -- in GHC.Tc.Utils.Concrete. -type ExpSigmaType = ExpType +data InferFRRFlag + = IFRR_Check -- Check that the result type has a fixed runtime rep + FixedRuntimeRepContext -- Typically used for function arguments and lambdas + | IFRR_Any -- No need to check for fixed runtime-rep + +data InferInstFlag -- Specifies whether the inference should return an uninstantiated + -- SigmaType, or a (possibly deeply) instantiated RhoType + -- See Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify + + = IIF_Sigma -- Trying to infer a SigmaType + -- Don't instantiate at all, regardless of DeepSubsumption + -- Typically used when inferring the type of a pattern + + | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) + -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole + -- Typically used when inferring the type of an expression + + | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) + -- If DeepSubsumption is off, same as IIF_ShallowRho + -- If DeepSubsumption is on, instantiate deeply before filling the hole + +type ExpSigmaType = ExpType +type ExpRhoType = ExpType + -- Invariant: in ExpRhoType, if -XDeepSubsumption is on, + -- and we are in checking mode (i.e. the ExpRhoType is (Check rho)), + -- then the `rho` is deeply skolemised + -- | An 'ExpType' which has a fixed RuntimeRep. -- -- For a 'Check' 'ExpType', the stored 'TcType' must have -- a fixed RuntimeRep. For an 'Infer' 'ExpType', the 'ir_frr' --- field must be of the form @Just frr_orig@. -type ExpTypeFRR = ExpType +-- field must be of the form @IFRR_Check frr_orig@. +type ExpTypeFRR = ExpType -- | Like 'TcSigmaTypeFRR', but for an expected type. -- -- See 'ExpTypeFRR'. type ExpSigmaTypeFRR = ExpTypeFRR +type ExpRhoTypeFRR = ExpTypeFRR -- TODO: consider making this a newtype. -type ExpRhoType = ExpType +-- | Like 'ExpType', but on kind level +type ExpKind = ExpType instance Outputable ExpType where ppr (Check ty) = text "Check" <> braces (ppr ty) ppr (Infer ir) = ppr ir instance Outputable InferResult where - ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr }) - = text "Infer" <> mb_frr_text <> braces (ppr u <> comma <> ppr lvl) + ppr (IR { ir_uniq = u, ir_lvl = lvl, ir_frr = mb_frr, ir_inst = inst }) + = text "Infer" <> parens (pp_inst <> pp_frr) + <> braces (ppr u <> comma <> ppr lvl) where - mb_frr_text = case mb_frr of - Just _ -> text "FRR" - Nothing -> empty + pp_inst = case inst of + IIF_Sigma -> text "Sigma" + IIF_ShallowRho -> text "ShallowRho" + IIF_DeepRho -> text "DeepRho" + pp_frr = case mb_frr of + IFRR_Check {} -> text ",FRR" + IFRR_Any -> empty -- | Make an 'ExpType' suitable for checking. mkCheckExpType :: TcType -> ExpType @@ -451,12 +495,35 @@ checkingExpType_maybe (Check ty) = Just ty checkingExpType_maybe (Infer {}) = Nothing --- | Returns the expected type when in checking mode. Panics if in inference --- mode. -checkingExpType :: String -> ExpType -> TcType -checkingExpType _ (Check ty) = ty -checkingExpType err et = pprPanic "checkingExpType" (text err $$ ppr et) +-- | Returns the expected type when in checking mode. +-- Panics if in inference mode. +checkingExpType :: ExpType -> TcType +checkingExpType (Check ty) = ty +checkingExpType et@(Infer {}) = pprPanic "checkingExpType" (ppr et) +-- Expected type of a pattern in a lambda or a function left-hand side. +data ExpPatType = + ExpFunPatTy (Scaled ExpSigmaTypeFRR) -- the type A of a function A -> B + | ExpForAllPatTy ForAllTyBinder -- the binder (a::A) of forall (a::A) -> B or forall (a :: A). B + +mkCheckExpFunPatTy :: Scaled TcType -> ExpPatType +mkCheckExpFunPatTy (Scaled mult ty) = ExpFunPatTy (Scaled mult (mkCheckExpType ty)) + +mkInvisExpPatType :: InvisTyBinder -> ExpPatType +mkInvisExpPatType (Bndr tv spec) = ExpForAllPatTy (Bndr tv (Invisible spec)) + +isVisibleExpPatType :: ExpPatType -> Bool +isVisibleExpPatType (ExpForAllPatTy (Bndr _ vis)) = isVisibleForAllTyFlag vis +isVisibleExpPatType (ExpFunPatTy {}) = True + +isExpFunPatType :: ExpPatType -> Bool +isExpFunPatType ExpFunPatTy{} = True +isExpFunPatType ExpForAllPatTy{} = False + +instance Outputable ExpPatType where + ppr (ExpFunPatTy t) = ppr t + ppr (ExpForAllPatTy tv) = text "forall" <+> ppr tv + {- ********************************************************************* * * SyntaxOpType @@ -548,7 +615,7 @@ a bit awkward for the /producer/. Why? Because sometimes we can't produce the SkolemInfo until we have the TcTyVars! -Example: in `GHC.Tc.Utils.Unify.tcTopSkolemise` we create SkolemTvs whose +Example: in `GHC.Tc.Utils.Unify.tcSkolemise` we create SkolemTvs whose `SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created SkolemTvs. So we a RecrusiveDo idiom, like this: @@ -571,7 +638,8 @@ -- how this level number is used Bool -- True <=> this skolem type variable can be overlapped -- when looking up instances - -- See Note [Binding when looking up instances] in GHC.Core.InstEnv + -- See Note [Super skolems: binding when looking up instances] + -- in GHC.Core.InstEnv | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi -- interactive context @@ -613,7 +681,7 @@ | RuntimeUnkTv -- ^ A unification variable used in the GHCi debugger. -- It /is/ allowed to unify with a polytype, unlike TauTv - | CycleBreakerTv -- Used to fix occurs-check problems in Givens + | CycleBreakerTv -- ^ Used to fix occurs-check problems in Givens -- See Note [Type equality cycles] in -- GHC.Tc.Solver.Equality @@ -644,15 +712,26 @@ -- See 'FixedRuntimeRepOrigin' for more information. = ConcreteFRR FixedRuntimeRepOrigin +-- | A mapping from skolem type variable 'Name' to concreteness information, +-- +-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete. +type ConcreteTyVars = NameEnv ConcreteTvOrigin +-- | The 'Id' has no outer forall'd type variables which must be instantiated +-- to concrete types. +noConcreteTyVars :: ConcreteTyVars +noConcreteTyVars = emptyNameEnv + {- ********************************************************************* * * Untouchable type variables * * ********************************************************************* -} -newtype TcLevel = TcLevel Int deriving( Eq, Ord ) +data TcLevel = TcLevel {-# UNPACK #-} !Int + | QLInstVar -- See Note [TcLevel invariants] for what this Int is -- See also Note [TcLevel assignment] + -- See also Note [The QLInstVar TcLevel] {- Note [TcLevel invariants] @@ -687,15 +766,36 @@ The level of a MetaTyVar also governs its untouchability. See Note [Unification preconditions] in GHC.Tc.Utils.Unify. + -- See also Note [The QLInstVar TcLevel] + Note [TcLevel assignment] ~~~~~~~~~~~~~~~~~~~~~~~~~ We arrange the TcLevels like this - 0 Top level - 1 First-level implication constraints - 2 Second-level implication constraints + 0 Top level + 1 First-level implication constraints + 2 Second-level implication constraints ...etc... + QLInstVar The level for QuickLook instantiation variables + See Note [The QLInstVar TcLevel] +Note [The QLInstVar TcLevel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +QuickLook instantiation variables are identified by having a TcLevel +of QLInstVar. See Note [Quick Look overview] in GHC.Tc.Gen.App. + +The QLInstVar level behaves like infinity: it is greater than any +other TcLevel. See `strictlyDeeperThan` and friends in this module. +That ensures that we never unify an ordinary unification variable +with a QL instantiation variable, e.g. + alpha[tau:3] := Maybe beta[tau:qlinstvar] +(This is an immediate consequence of our general rule that we never +unify a variable with a type mentioning deeper variables; the skolem +escape check.) + +QL instantation variables are eventually turned into ordinary unificaiton +variables; see (QL3) in Note [Quick Look overview]. + Note [GivenInv] ~~~~~~~~~~~~~~~ Invariant (GivenInv) is not essential, but it is easy to guarantee, and @@ -745,10 +845,18 @@ -} maxTcLevel :: TcLevel -> TcLevel -> TcLevel -maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) +maxTcLevel (TcLevel a) (TcLevel b) + | a > b = TcLevel a + | otherwise = TcLevel b +maxTcLevel _ _ = QLInstVar minTcLevel :: TcLevel -> TcLevel -> TcLevel -minTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `min` b) +minTcLevel tcla@(TcLevel a) tclb@(TcLevel b) + | a < b = tcla + | otherwise = tclb +minTcLevel tcla@(TcLevel {}) QLInstVar = tcla +minTcLevel QLInstVar tclb@(TcLevel {}) = tclb +minTcLevel QLInstVar QLInstVar = QLInstVar topTcLevel :: TcLevel -- See Note [TcLevel assignment] @@ -756,29 +864,39 @@ isTopTcLevel :: TcLevel -> Bool isTopTcLevel (TcLevel 0) = True -isTopTcLevel _ = False +isTopTcLevel _ = False pushTcLevel :: TcLevel -> TcLevel -- See Note [TcLevel assignment] pushTcLevel (TcLevel us) = TcLevel (us + 1) +pushTcLevel QLInstVar = QLInstVar strictlyDeeperThan :: TcLevel -> TcLevel -> Bool +-- See Note [The QLInstVar TcLevel] strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) = tv_tclvl > ctxt_tclvl +strictlyDeeperThan QLInstVar (TcLevel {}) = True +strictlyDeeperThan _ _ = False deeperThanOrSame :: TcLevel -> TcLevel -> Bool +-- See Note [The QLInstVar TcLevel] deeperThanOrSame (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) = tv_tclvl >= ctxt_tclvl +deeperThanOrSame (TcLevel {}) QLInstVar = False +deeperThanOrSame QLInstVar _ = True sameDepthAs :: TcLevel -> TcLevel -> Bool sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl - -- So <= would be equivalent + = ctxt_tclvl == tv_tclvl + -- NB: invariant ctxt_tclvl >= tv_tclvl + -- So <= would be equivalent +sameDepthAs QLInstVar QLInstVar = True +sameDepthAs _ _ = False checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool -- Checks (WantedInv) from Note [TcLevel invariants] -checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) - = ctxt_tclvl >= tv_tclvl +checkTcLevelInvariant ctxt_tclvl tv_tclvl + = ctxt_tclvl `deeperThanOrSame` tv_tclvl -- Returns topTcLevel for non-TcTyVars tcTyVarLevel :: TcTyVar -> TcLevel @@ -801,7 +919,8 @@ | otherwise = lvl instance Outputable TcLevel where - ppr (TcLevel us) = ppr us + ppr (TcLevel n) = ppr n + ppr QLInstVar = text "qlinst" {- ********************************************************************* * * @@ -852,7 +971,8 @@ -- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a -- /visible/ argument to @C@. -- --- See also @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors". +-- See also Note [Showing invisible bits of types in error messages] +-- in "GHC.Tc.Errors.Ppr". tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] tcTyFamInstsAndVis = tcTyFamInstsAndVisX False @@ -908,10 +1028,11 @@ -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts +type UnderFam = Bool -- True <=> we are in the argument of a type family application + any_rewritable :: EqRel -- Ambient role - -> (EqRel -> TcTyVar -> Bool) -- check tyvar - -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family - -> (TyCon -> Bool) -- expand type synonym? + -> (UnderFam -> EqRel -> TcTyVar -> Bool) -- Check tyvar + -> (UnderFam -> EqRel -> TyCon -> [TcType] -> Bool) -- Check type family application -> TcType -> Bool -- Checks every tyvar and tyconapp (not including FunTys) within a type, -- ORing the results of the predicates above together @@ -924,66 +1045,79 @@ -- -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. {-# INLINE any_rewritable #-} -- this allows specialization of predicates -any_rewritable role tv_pred tc_pred should_expand - = go role emptyVarSet +any_rewritable role tv_pred tc_pred ty + = go False emptyVarSet role ty where - go_tv rl bvs tv | tv `elemVarSet` bvs = False - | otherwise = tv_pred rl tv + go_tv uf bvs rl tv | tv `elemVarSet` bvs = False + | otherwise = tv_pred uf rl tv - go rl bvs ty@(TyConApp tc tys) + go :: UnderFam -> VarSet -> EqRel -> TcType -> Bool + go under_fam bvs rl (TyConApp tc tys) + + -- Expand synonyms, unless (a) we are at Nominal role and (b) the synonym + -- is type-family-free; then it suffices just to look at the args | isTypeSynonymTyCon tc - , should_expand tc - , Just ty' <- coreView ty -- should always match - = go rl bvs ty' + , case rl of { NomEq -> not (isFamFreeTyCon tc); ReprEq -> True } + , Just ty' <- expandSynTyConApp_maybe tc tys + = go under_fam bvs rl ty' - | tc_pred rl tc tys - = True + -- Check if we are going under a type family application + | case rl of + NomEq -> isTypeFamilyTyCon tc + ReprEq -> isFamilyTyCon tc + = if | tc_pred under_fam rl tc tys -> True + | otherwise -> go_fam under_fam (tyConArity tc) bvs tys | otherwise - = go_tc rl bvs tc tys + = go_tc under_fam bvs rl tc tys - go rl bvs (TyVarTy tv) = go_tv rl bvs tv - go _ _ (LitTy {}) = False - go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg - go rl bvs (FunTy _ w arg res) = go NomEq bvs arg_rep || go NomEq bvs res_rep || - go rl bvs arg || go rl bvs res || go NomEq bvs w + go uf bvs rl (TyVarTy tv) = go_tv uf bvs rl tv + go _ _ _ (LitTy {}) = False + go uf bvs rl (AppTy fun arg) = go uf bvs rl fun || go uf bvs NomEq arg + go uf bvs rl (FunTy _ w arg res) = go uf bvs NomEq arg_rep || go uf bvs NomEq res_rep || + go uf bvs rl arg || go uf bvs rl res || go uf bvs NomEq w where arg_rep = getRuntimeRep arg -- forgetting these causes #17024 res_rep = getRuntimeRep res - go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty - go rl bvs (CastTy ty _) = go rl bvs ty - go _ _ (CoercionTy _) = False + go uf bvs rl (ForAllTy tv ty) = go uf (bvs `extendVarSet` binderVar tv) rl ty + go uf bvs rl (CastTy ty _) = go uf bvs rl ty + go _ _ _ (CoercionTy _) = False - go_tc NomEq bvs _ tys = any (go NomEq bvs) tys - go_tc ReprEq bvs tc tys = any (go_arg bvs) - (tyConRoleListRepresentational tc `zip` tys) + go_tc :: UnderFam -> VarSet -> EqRel -> TyCon -> [TcType] -> Bool + go_tc uf bvs NomEq _ tys = any (go uf bvs NomEq) tys + go_tc uf bvs ReprEq tc tys = any2 (go_arg uf bvs) tys (tyConRoleListRepresentational tc) - go_arg bvs (Nominal, ty) = go NomEq bvs ty - go_arg bvs (Representational, ty) = go ReprEq bvs ty - go_arg _ (Phantom, _) = False -- We never rewrite with phantoms + go_arg uf bvs ty Nominal = go uf bvs NomEq ty + go_arg uf bvs ty Representational = go uf bvs ReprEq ty + go_arg _ _ _ Phantom = False -- We never rewrite with phantoms + -- For a type-family or data-family application (F t1 .. tn), all arguments + -- have Nominal role (whether in F's arity or, if over-saturated, beyond it) + -- Switch on under_fam for arguments <= arity + go_fam uf 0 bvs tys = any (go uf bvs NomEq) tys -- Like AppTy + go_fam _ _ _ [] = False + go_fam uf n bvs (ty:tys) = go True bvs NomEq ty || go_fam uf (n-1) bvs tys + -- True <=> switch on under_fam + anyRewritableTyVar :: EqRel -- Ambient role - -> (EqRel -> TcTyVar -> Bool) -- check tyvar + -> (UnderFam -> EqRel -> TcTyVar -> Bool) -- check tyvar -> TcType -> Bool -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. -anyRewritableTyVar role pred - = any_rewritable role pred - (\ _ _ _ -> False) -- no special check for tyconapps - -- (this False is ORed with other results, so it - -- really means "do nothing special"; the arguments - -- are still inspected) - (\ _ -> False) -- don't expand synonyms - -- NB: No need to expand synonyms, because we can find - -- all free variables of a synonym by looking at its - -- arguments +anyRewritableTyVar role check_tv + = any_rewritable role + check_tv + (\ _ _ _ _ -> False) -- No special check for tyconapps + -- (this False is ORed with other results, + -- so it really means "do nothing special"; + -- the arguments are still inspected) anyRewritableTyFamApp :: EqRel -- Ambient role - -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp - -- should return True only for type family applications + -> (UnderFam -> EqRel -> TyCon -> [TcType] -> Bool) + -- Check a type-family application -> TcType -> Bool -- always ignores casts & coercions -- See Note [Rewritable] in GHC.Tc.Solver.InertSet for a specification for this function. anyRewritableTyFamApp role check_tyconapp - = any_rewritable role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon) + = any_rewritable role (\ _ _ _ -> False) check_tyconapp {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1132,6 +1266,18 @@ _ -> False | otherwise = False +isQLInstTyVar :: TcTyVar -> Bool +isQLInstTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = QLInstVar } -> True + _ -> False + +isRuntimeUnkTyVar :: TcTyVar -> Bool +isRuntimeUnkTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = RuntimeUnkTv } -> True + _ -> False + isCycleBreakerTyVar tv | isTyVar tv -- See Note [Coercion variables in free variable lists] , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv @@ -1153,9 +1299,9 @@ | otherwise = Nothing -isConcreteInfo :: MetaInfo -> Bool -isConcreteInfo (ConcreteTv {}) = True -isConcreteInfo _ = False +concreteInfo_maybe :: MetaInfo -> Maybe ConcreteTvOrigin +concreteInfo_maybe (ConcreteTv conc_orig) = Just conc_orig +concreteInfo_maybe _ = Nothing -- | Is this type variable a concrete type variable, i.e. -- it is a metavariable with 'ConcreteTv' 'MetaInfo'? @@ -1370,6 +1516,20 @@ split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split orig_ty _ tvs = (reverse tvs, orig_ty) +tcSplitForAllTyVarsReqTVBindersN :: Arity -> Type -> (Arity, [ForAllTyBinder], Type) +-- Split off at most N /required/ (aka visible) binders, plus any invisible ones +-- in the way, /and/ any trailing invisible ones +tcSplitForAllTyVarsReqTVBindersN n_req ty + = split n_req ty ty [] + where + split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs + | isVisibleForAllTyFlag argf, n_req > 0 -- Split off a visible forall + = split (n_req - 1) ty ty (b:bs) + | isInvisibleForAllTyFlag argf -- Split off an invisible forall, + = split n_req ty ty (b:bs) -- even if n_req=0, i.e. the trailing ones + split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs + split n_req orig_ty _ty bs = (n_req, reverse bs, orig_ty) + -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type) @@ -1414,6 +1574,11 @@ (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) +tcSplitSigmaTyBndrs :: Type -> ([TcInvisTVBinder], ThetaType, Type) +tcSplitSigmaTyBndrs ty = case tcSplitForAllInvisTVBinders ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + -- | Split a sigma type into its parts, going underneath as many arrows -- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) @@ -1521,7 +1686,7 @@ = Left n tcSplitFunTy :: Type -> (Scaled Type, Type) -tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) +tcSplitFunTy ty = expectJust (tcSplitFunTy_maybe ty) tcFunArgTy :: Type -> Scaled Type tcFunArgTy ty = fst (tcSplitFunTy ty) @@ -1652,11 +1817,11 @@ evVarPred :: EvVar -> PredType evVarPred var = varType var -- Historical note: I used to have an ASSERT here, - -- checking (isEvVarType (varType var)). But with something like + -- checking (isPredTy (varType var)). But with something like -- f :: c => _ -> _ -- we end up with (c :: kappa), and (kappa ~ Constraint). Until -- we solve and zonk (which there is no particular reason to do for - -- partial signatures, (isEvVarType kappa) will return False. But + -- partial signatures, (isPredTy kappa) will return False. But -- nothing is wrong. So I just removed the ASSERT. --------------------------- @@ -1686,7 +1851,7 @@ pickCapturedPreds qtvs theta = filter captured theta where - captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) -- Superclasses @@ -1743,7 +1908,7 @@ -- These can arise when dealing with partial type signatures (e.g. T14715) eq_extras pred = case classifyPredType pred of - EqPred r t1 t2 -> [mkPrimEqPredRole (eqRelRole r) t2 t1] + EqPred r t1 t2 -> [mkEqPred r t2 t1] ClassPred cls [k1,k2,t1,t2] | cls `hasKey` heqTyConKey -> [mkClassPred cls [k2, k1, t2, t1]] ClassPred cls [k,t1,t2] @@ -1841,19 +2006,20 @@ -} isSigmaTy :: TcType -> Bool --- isSigmaTy returns true of any qualified type. It doesn't --- *necessarily* have any foralls. E.g --- f :: (?x::Int) => Int -> Int -isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' -isSigmaTy (ForAllTy {}) = True +-- isSigmaTy returns true of any type with /invisible/ quantifiers at the top: +-- forall a. blah +-- Eq a => blah +-- ?x::Int => blah +-- But NOT +-- forall a -> blah +isSigmaTy (ForAllTy (Bndr _ af) _) = isInvisibleForAllTyFlag af isSigmaTy (FunTy { ft_af = af }) = isInvisibleFunArg af +isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' isSigmaTy _ = False + isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] -isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty' -isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy { ft_af = af }) = isVisibleFunArg af -isRhoTy _ = True +isRhoTy ty = not (isSigmaTy ty) -- | Like 'isRhoTy', but also says 'True' for 'Infer' types isRhoExpTy :: ExpType -> Bool @@ -1862,7 +2028,7 @@ isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing --- Used only by bindLocalMethods +-- Used by bindLocalMethods and for -fprof-late-overloaded isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af @@ -1872,7 +2038,7 @@ isFloatPrimTy, isDoublePrimTy, isIntegerTy, isNaturalTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy :: Type -> Bool + isUnitTy, isAnyTy, isZonkAnyTy, isCharTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isFloatPrimTy = is_tc floatPrimTyConKey @@ -1883,6 +2049,8 @@ isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey +isAnyTy = is_tc anyTyConKey +isZonkAnyTy = is_tc zonkAnyTyConKey isCharTy = is_tc charTyConKey -- | Check whether the type is of the form @Any :: k@, @@ -1923,6 +2091,7 @@ | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal | Just {} <- tcSplitAppTy_maybe ty = True | isForAllTy ty = True + | Just {} <- isLitTy ty = True | otherwise = False {- @@ -1990,8 +2159,8 @@ -} tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) --- (tcSplitIOType_maybe t) returns Just (IO,t',co) --- if co : t ~ IO t' +-- (tcSplitIOType_maybe t) returns Just (IO,t') +-- if t = IO t' -- returns Nothing otherwise tcSplitIOType_maybe ty = case tcSplitTyConApp_maybe ty of @@ -2227,6 +2396,13 @@ pSizeTyFamApp tc | isStuckTypeFamily tc = pSizeZero | otherwise = PS_TyFam tc + +pSizeHead :: PredType -> PatersonSize +-- Getting the size of an instance head is a bit horrible +-- because of the special treament for class predicates +pSizeHead pred = case classifyPredType pred of + ClassPred cls tys -> pSizeClassPred cls tys + _ -> pSizeType pred pSizeClassPred :: Class -> [Type] -> PatersonSize pSizeClassPred = pSizeClassPredX emptyVarSet diff --git a/GHC/Tc/Utils/TcType.hs-boot b/GHC/Tc/Utils/TcType.hs-boot --- a/GHC/Tc/Utils/TcType.hs-boot +++ b/GHC/Tc/Utils/TcType.hs-boot @@ -1,8 +1,10 @@ module GHC.Tc.Utils.TcType where import GHC.Utils.Outputable( SDoc ) +import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) -import GHC.Utils.Misc( HasDebugCallStack ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin ) +import GHC.Types.Name.Env ( NameEnv ) data MetaDetails @@ -11,5 +13,10 @@ vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool -isConcreteTyVar :: TcTyVar -> Bool +type ConcreteTyVars = NameEnv ConcreteTvOrigin +data ConcreteTvOrigin + = ConcreteFRR FixedRuntimeRepOrigin + +isConcreteTyVar :: TcTyVar -> Bool +noConcreteTyVars :: ConcreteTyVars diff --git a/GHC/Tc/Utils/Unify.hs b/GHC/Tc/Utils/Unify.hs --- a/GHC/Tc/Utils/Unify.hs +++ b/GHC/Tc/Utils/Unify.hs @@ -1,3276 +1,4764 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --} - --- | Type subsumption and unification -module GHC.Tc.Utils.Unify ( - -- Full-blown subsumption - tcWrapResult, tcWrapResultO, tcWrapResultMono, - tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType, - tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, - tcSubTypeAmbiguity, tcSubMult, - checkConstraints, checkTvConstraints, - buildImplicationFor, buildTvImplication, emitResidualTvConstraint, - - -- Various unifications - unifyType, unifyKind, unifyInvisibleType, unifyExpectedType, - unifyTypeAndEmit, promoteTcType, - swapOverTyVars, touchabilityAndShapeTest, - UnifyEnv(..), updUEnvLoc, setUEnvRole, - uType, - - -------------------------------- - -- Holes - tcInfer, - matchExpectedListTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchExpectedFunKind, - matchActualFunTySigma, matchActualFunTysRho, - - checkTyEqRhs, recurseIntoTyConApp, - PuResult(..), failCheckWith, okCheckRefl, mapCheck, - TyEqFlags(..), TyEqFamApp(..), AreUnifying(..), LevelCheck(..), FamAppBreaker, - famAppArgFlags, simpleUnifyCheck, checkPromoteFreeVars, - ) where - -import GHC.Prelude - -import GHC.Hs - -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, hasFixedRuntimeRep_syntactic ) -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Instantiate -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Zonk.TcType - -import GHC.Core.Type -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs( isInjectiveInType ) -import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} ) -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Multiplicity -import GHC.Core.Reduction - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Builtin.Types -import GHC.Types.Name -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Basic -import GHC.Types.Unique.Set (nonDetEltsUniqSet) - -import GHC.Utils.Error -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import GHC.Driver.DynFlags -import GHC.Data.Bag -import GHC.Data.FastString( fsLit ) - -import Control.Monad -import Data.Monoid as DM ( Any(..) ) -import qualified Data.Semigroup as S ( (<>) ) - -{- ********************************************************************* -* * - matchActualFunTys -* * -********************************************************************* -} - --- | 'matchActualFunTySigma' looks for just one function arrow, --- returning an uninstantiated sigma-type. --- --- Invariant: the returned argument type has a syntactically fixed --- RuntimeRep in the sense of Note [Fixed RuntimeRep] --- in GHC.Tc.Utils.Concrete. --- --- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTySigma - :: ExpectedFunTyOrigin - -- ^ See Note [Herald for matchExpectedFunTys] - -> Maybe TypedThing - -- ^ The thing with type TcSigmaType - -> (Arity, [Scaled TcSigmaType]) - -- ^ Total number of value args in the call, and - -- types of values args to which function has - -- been applied already (reversed) - -- (Both are used only for error messages) - -> TcRhoType - -- ^ Type to analyse: a TcRhoType - -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) --- This function takes in a type to analyse (a RhoType) and returns --- an argument type and a result type (splitting apart a function arrow). --- The returned argument type is a SigmaType with a fixed RuntimeRep; --- as explained in Note [Return arguments with a fixed RuntimeRep]. --- --- See Note [matchActualFunTy error handling] for the first three arguments - --- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty --- then wrap :: fun_ty ~> (arg_ty -> res_ty) --- and NB: res_ty is an (uninstantiated) SigmaType - -matchActualFunTySigma herald mb_thing err_info fun_ty - = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $ - go fun_ty - where - -- Does not allocate unnecessary meta variables: if the input already is - -- a function, we just take it apart. Not only is this efficient, - -- it's important for higher rank: the argument might be of form - -- (forall a. ty) -> other - -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd - -- hide the forall inside a meta-variable - go :: TcRhoType -- The type we're processing, perhaps after - -- expanding type synonyms - -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) - go ty | Just ty' <- coreView ty = go ty' - - go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) - = assert (isVisibleFunArg af) $ - do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty - ; return (idHsWrapper, Scaled w arg_ty, res_ty) } - - go ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go ty' - Flexi -> defer ty } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go ty = addErrCtxtM (mk_ctxt ty) (defer ty) - - ------------ - defer fun_ty - = do { arg_ty <- newOpenFlexiTyVarTy - ; res_ty <- newOpenFlexiTyVarTy - ; mult <- newFlexiTyVarTy multiplicityTy - ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty - ; co <- unifyType mb_thing fun_ty unif_fun_ty - ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty - ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } - - ------------ - mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) - mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far) - res_ty n_val_args_in_call - (n_val_args_in_call, arg_tys_so_far) = err_info - -{- Note [matchActualFunTy error handling] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchActualFunTySigma is made much more complicated by the -desire to produce good error messages. Consider the application - f @Int x y -In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments, -and then call matchActualFunTysPart for each individual value -argument. It, in turn, must instantiate any type/dictionary args, -before looking for an arrow type. - -But if it doesn't find an arrow type, it wants to generate a message -like "f is applied to two arguments but its type only has one". -To do that, it needs to know about the args that tcArgs has already -munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; -and hence also the accumulating so_far arg to 'go'. - -This allows us (in mk_ctxt) to construct f's /instantiated/ type, -with just the values-arg arrows, which is what we really want -in the error message. - -Ugh! --} - --- | Like 'matchExpectedFunTys', but used when you have an "actual" type, --- for example in function application. --- --- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep --- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. --- See Note [Return arguments with a fixed RuntimeRep]. -matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] - -> CtOrigin - -> Maybe TypedThing -- ^ the thing with type TcSigmaType - -> Arity - -> TcSigmaType - -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) --- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty) --- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) --- and res_ty is a RhoType --- NB: the returned type is top-instantiated; it's a RhoType -matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty - = go n_val_args_wanted [] fun_ty - where - go n so_far fun_ty - | not (isRhoTy fun_ty) - = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty - ; (wrap2, arg_tys, res_ty) <- go n so_far rho - ; return (wrap2 <.> wrap1, arg_tys, res_ty) } - - go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) - - go n so_far fun_ty - = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma - herald mb_thing - (n_val_args_wanted, so_far) - fun_ty - ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 - ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty - -- NB: arg_ty1 comes from matchActualFunTySigma, so it has - -- a syntactically fixed RuntimeRep as needed to call mkWpFun. - ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } - -{- -************************************************************************ -* * - matchExpected functions -* * -************************************************************************ - -Note [Herald for matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'herald' always looks like: - "The equation(s) for 'f' have" - "The abstraction (\x.e) takes" - "The section (+ x) expects" - "The function 'f' is applied to" - -This is used to construct a message of form - - The abstraction `\Just 1 -> ...' takes two arguments - but its type `Maybe a -> a' has only one - - The equation(s) for `f' have two arguments - but its type `Maybe a -> a' has only one - - The section `(f 3)' requires 'f' to take two arguments - but its type `Int -> Int' has only one - - The function 'f' is applied to two arguments - but its type `Int -> Int' has only one - -When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the -picture, we have a choice in deciding whether to count the type applications as -proper arguments: - - The function 'f' is applied to one visible type argument - and two value arguments - but its type `forall a. a -> a` has only one visible type argument - and one value argument - -Or whether to include the type applications as part of the herald itself: - - The expression 'f @Int' is applied to two arguments - but its type `Int -> Int` has only one - -The latter is easier to implement and is arguably easier to understand, so we -choose to implement that option. - -Note [matchExpectedFunTys] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -matchExpectedFunTys checks that a sigma has the form -of an n-ary function. It passes the decomposed type to the -thing_inside, and returns a wrapper to coerce between the two types - -It's used wherever a language construct must have a functional type, -namely: - A lambda expression - A function definition - An operator section - -This function must be written CPS'd because it needs to fill in the -ExpTypes produced for arguments before it can fill in the ExpType -passed in. - -Note [Return arguments with a fixed RuntimeRep] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The functions - - - matchExpectedFunTys, - - matchActualFunTySigma, - - matchActualFunTysRho, - -peel off argument types, as explained in Note [matchExpectedFunTys]. -It's important that these functions return argument types that have -a fixed runtime representation, otherwise we would be in violation -of the representation-polymorphism invariants of -Note [Representation polymorphism invariants] in GHC.Core. - -This is why all these functions have an additional invariant, -that the argument types they return all have a syntactically fixed RuntimeRep, -in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. - -Example: - - Suppose we have - - type F :: Type -> RuntimeRep - type family F a where { F Int = LiftedRep } - - type Dual :: Type -> Type - type family Dual a where - Dual a = a -> () - - f :: forall (a :: TYPE (F Int)). Dual a - f = \ x -> () - - The body of `f` is a lambda abstraction, so we must be able to split off - one argument type from its type. This is handled by `matchExpectedFunTys` - (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that - looks like this: - - f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) - f = \ @(a :: TYPE (F Int)) -> - (\ (x :: (a |> (TYPE F[0]))) -> ()) - `cast` - (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>))) - - Two important transformations took place: - - 1. We inserted casts around the argument type to ensure that it has - a fixed runtime representation, as required by invariant (I1) from - Note [Representation polymorphism invariants] in GHC.Core. - 2. We inserted a cast around the whole lambda to make everything line up - with the type signature. --} - --- | Use this function to split off arguments types when you have an --- \"expected\" type. --- --- This function skolemises at each polytype. --- --- Invariant: this function only applies the provided function --- to a list of argument types which all have a syntactically fixed RuntimeRep --- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. --- See Note [Return arguments with a fixed RuntimeRep]. -matchExpectedFunTys :: forall a. - ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] - -> UserTypeCtxt - -> Arity - -> ExpRhoType -- Skolemised - -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a) - -> TcM (HsWrapper, a) --- If matchExpectedFunTys n ty = (wrap, _) --- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, --- where [t1, ..., tn], ty_r are passed to the thing_inside -matchExpectedFunTys herald ctx arity orig_ty thing_inside - = case orig_ty of - Check ty -> go [] arity ty - _ -> defer [] arity orig_ty - where - -- Skolemise any foralls /before/ the zero-arg case - -- so that we guarantee to return a rho-type - go acc_arg_tys n ty - | (tvs, theta, _) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> - go acc_arg_tys n ty' - ; return (wrap_gen <.> wrap_res, result) } - - -- No more args; do this /before/ coreView, so - -- that we do not unnecessarily unwrap synonyms - go acc_arg_tys 0 rho_ty - = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty) - ; return (idHsWrapper, result) } - - go acc_arg_tys n ty - | Just ty' <- coreView ty = go acc_arg_tys n ty' - - go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty }) - = assert (isVisibleFunArg af) $ - do { let arg_pos = 1 + length acc_arg_tys -- for error messages only - ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty - ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys) - (n-1) res_ty - ; let wrap_arg = mkWpCastN arg_co - fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty - ; return (fun_wrap, result) } - - go acc_arg_tys n ty@(TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty' -> go acc_arg_tys n ty' - Flexi -> defer acc_arg_tys n (mkCheckExpType ty) } - - -- In all other cases we bale out into ordinary unification - -- However unlike the meta-tyvar case, we are sure that the - -- number of arguments doesn't match arity of the original - -- type, so we can add a bit more context to the error message - -- (cf #7869). - -- - -- It is not always an error, because specialized type may have - -- different arity, for example: - -- - -- > f1 = f2 'a' - -- > f2 :: Monad m => m Bool - -- > f2 = undefined - -- - -- But in that case we add specialized type into error context - -- anyway, because it may be useful. See also #9605. - go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $ - defer acc_arg_tys n (mkCheckExpType ty) - - ------------ - defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a) - defer acc_arg_tys n fun_ty - = do { let last_acc_arg_pos = length acc_arg_tys - ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n] - ; res_ty <- newInferExpType - ; result <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty - ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys - ; res_ty <- readExpType res_ty - ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty - ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty - -- Not a good origin at all :-( - ; return (wrap, result) } - - new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR) - new_exp_arg_ty arg_pos -- position for error messages only - = mkScaled <$> newFlexiTyVarTy multiplicityTy - <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos) - - ------------ - mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> ZonkM (TidyEnv, SDoc) - mk_ctxt arg_tys res_ty env - = mkFunTysMsg env herald arg_tys' res_ty arity - where - arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $ - reverse arg_tys - -- this is safe b/c we're called from "go" - -mkFunTysMsg :: TidyEnv - -> ExpectedFunTyOrigin - -> [Scaled TcType] -> TcType -> Arity - -> ZonkM (TidyEnv, SDoc) -mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call - = do { (env', fun_rho) <- zonkTidyTcType env $ - mkScaledFunTys arg_tys res_ty - - ; let (all_arg_tys, _) = splitFunTys fun_rho - n_fun_args = length all_arg_tys - - msg | n_val_args_in_call <= n_fun_args -- Enough args, in the end - = text "In the result of a function call" - | otherwise - = hang (full_herald <> comma) - 2 (sep [ text "but its type" <+> quotes (pprType fun_rho) - , if n_fun_args == 0 then text "has none" - else text "has only" <+> speakN n_fun_args]) - - ; return (env', msg) } - where - full_herald = pprExpectedFunTyHerald herald - <+> speakNOf n_val_args_in_call (text "value argument") - ----------------------- -matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) --- Special case for lists -matchExpectedListTy exp_ty - = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty - ; return (co, elt_ty) } - ---------------------- -matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * - -> TcRhoType -- orig_ty - -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty - [TcSigmaType]) -- Element types, k1 k2 k3 a b c - --- It's used for wired-in tycons, so we call checkWiredInTyCon --- Precondition: never called with FunTyCon --- Precondition: input type :: * --- Postcondition: (T k1 k2 k3 a b c) is well-kinded - -matchExpectedTyConApp tc orig_ty - = assertPpr (isAlgTyCon tc) (ppr tc) $ - go orig_ty - where - go ty - | Just ty' <- coreView ty - = go ty' - - go ty@(TyConApp tycon args) - | tc == tycon -- Common case - = return (mkNomReflCo ty, args) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- If the common case does not occur, instantiate a template - -- T k1 .. kn t1 .. tm, and unify with the original type - -- Doing it this way ensures that the types we return are - -- kind-compatible with T. For example, suppose we have - -- matchExpectedTyConApp T (f Maybe) - -- where data T a = MkT a - -- Then we don't want to instantiate T's data constructors with - -- (a::*) ~ Maybe - -- because that'll make types that are utterly ill-kinded. - -- This happened in #7368 - defer - = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) - ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) - ; let args = mkTyVarTys arg_tvs - tc_template = mkTyConApp tc args - ; co <- unifyType Nothing tc_template orig_ty - ; return (co, args) } - ----------------------- -matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (TcCoercion, -- m a ~N orig_ty - (TcSigmaType, TcSigmaType)) -- Returns m, a --- If the incoming type is a mutable type variable of kind k, then --- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. - -matchExpectedAppTy orig_ty - = go orig_ty - where - go ty - | Just ty' <- coreView ty = go ty' - - | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) - - go (TyVarTy tv) - | isMetaTyVar tv - = do { cts <- readMetaTyVar tv - ; case cts of - Indirect ty -> go ty - Flexi -> defer } - - go _ = defer - - -- Defer splitting by generating an equality constraint - defer - = do { ty1 <- newFlexiTyVarTy kind1 - ; ty2 <- newFlexiTyVarTy kind2 - ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty - ; return (co, (ty1, ty2)) } - - orig_kind = typeKind orig_ty - kind1 = mkVisFunTyMany liftedTypeKind orig_kind - kind2 = liftedTypeKind -- m :: * -> k - -- arg type :: * - -{- ********************************************************************** -* - fillInferResult -* -********************************************************************** -} - -{- Note [inferResultToType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -expTypeToType and inferResultType convert an InferResult to a monotype. -It must be a monotype because if the InferResult isn't already filled in, -we fill it in with a unification variable (hence monotype). So to preserve -order-independence we check for mono-type-ness even if it *is* filled in -already. - -See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and -Note [fillInferResult]. --} - --- | Fill an 'InferResult' with the given type. --- --- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@, --- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@. --- --- This function enforces the following invariants: --- --- - Level invariant. --- The stored type @t2@ is at the same level as given by the --- 'ir_lvl' field. --- - FRR invariant. --- Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed --- to have a syntactically fixed RuntimeRep, in the sense of --- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -fillInferResult :: TcType -> InferResult -> TcM TcCoercionN -fillInferResult act_res_ty (IR { ir_uniq = u - , ir_lvl = res_lvl - , ir_frr = mb_frr - , ir_ref = ref }) - = do { mb_exp_res_ty <- readTcRef ref - ; case mb_exp_res_ty of - Just exp_res_ty - -- We progressively refine the type stored in 'ref', - -- for example when inferring types across multiple equations. - -- - -- Example: - -- - -- \ x -> case y of { True -> x ; False -> 3 :: Int } - -- - -- When inferring the return type of this function, we will create - -- an 'Infer' 'ExpType', which will first be filled by the type of 'x' - -- after typechecking the first equation, and then filled again with - -- the type 'Int', at which point we want to ensure that we unify - -- the type of 'x' with 'Int'. This is what is happening below when - -- we are "joining" several inferred 'ExpType's. - -> do { traceTc "Joining inferred ExpType" $ - ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty - ; cur_lvl <- getTcLevel - ; unless (cur_lvl `sameDepthAs` res_lvl) $ - ensureMonoType act_res_ty - ; unifyType Nothing act_res_ty exp_res_ty } - Nothing - -> do { traceTc "Filling inferred ExpType" $ - ppr u <+> text ":=" <+> ppr act_res_ty - - -- Enforce the level invariant: ensure the TcLevel of - -- the type we are writing to 'ref' matches 'ir_lvl'. - ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty - - -- Enforce the FRR invariant: ensure the type has a syntactically - -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing'). - ; (frr_co, act_res_ty) <- - case mb_frr of - Nothing -> return (mkNomReflCo act_res_ty, act_res_ty) - Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty - - -- Compose the two coercions. - ; let final_co = prom_co `mkTransCo` frr_co - - ; writeTcRef ref (Just act_res_ty) - - ; return final_co } - } - -{- Note [fillInferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~ -When inferring, we use fillInferResult to "fill in" the hole in InferResult - data InferResult = IR { ir_uniq :: Unique - , ir_lvl :: TcLevel - , ir_ref :: IORef (Maybe TcType) } - -There are two things to worry about: - -1. What if it is under a GADT or existential pattern match? - - GADTs: a unification variable (and Infer's hole is similar) is untouchable - - Existentials: be careful about skolem-escape - -2. What if it is filled in more than once? E.g. multiple branches of a case - case e of - T1 -> e1 - T2 -> e2 - -Our typing rules are: - -* The RHS of a existential or GADT alternative must always be a - monotype, regardless of the number of alternatives. - -* Multiple non-existential/GADT branches can have (the same) - higher rank type (#18412). E.g. this is OK: - case e of - True -> hr - False -> hr - where hr:: (forall a. a->a) -> Int - c.f. Section 7.1 of "Practical type inference for arbitrary-rank types" - We use choice (2) in that Section. - (GHC 8.10 and earlier used choice (1).) - - But note that - case e of - True -> hr - False -> \x -> hr x - will fail, because we still /infer/ both branches, so the \x will get - a (monotype) unification variable, which will fail to unify with - (forall a. a->a) - -For (1) we can detect the GADT/existential situation by seeing that -the current TcLevel is greater than that stored in ir_lvl of the Infer -ExpType. We bump the level whenever we go past a GADT/existential match. - -Then, before filling the hole use promoteTcType to promote the type -to the outer ir_lvl. promoteTcType does this - - create a fresh unification variable alpha at level ir_lvl - - emits an equality alpha[ir_lvl] ~ ty - - fills the hole with alpha -That forces the type to be a monotype (since unification variables can -only unify with monotypes); and catches skolem-escapes because the -alpha is untouchable until the equality floats out. - -For (2), we simply look to see if the hole is filled already. - - if not, we promote (as above) and fill the hole - - if it is filled, we simply unify with the type that is - already there - -There is one wrinkle. Suppose we have - case e of - T1 -> e1 :: (forall a. a->a) -> Int - G2 -> e2 -where T1 is not GADT or existential, but G2 is a GADT. Then suppose the -T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. -But now the G2 alternative must not *just* unify with that else we'd risk -allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first -we'd have filled the hole with a unification variable, which enforces a -monotype. - -So if we check G2 second, we still want to emit a constraint that restricts -the RHS to be a monotype. This is done by ensureMonoType, and it works -by simply generating a constraint (alpha ~ ty), where alpha is a fresh -unification variable. We discard the evidence. - --} - - - -{- -************************************************************************ -* * - Subsumption checking -* * -************************************************************************ - -Note [Subsumption checking: tcSubType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All the tcSubType calls have the form - tcSubType actual_ty expected_ty -which checks - actual_ty <= expected_ty - -That is, that a value of type actual_ty is acceptable in -a place expecting a value of type expected_ty. I.e. that - - actual ty is more polymorphic than expected_ty - -It returns a wrapper function - co_fn :: actual_ty ~ expected_ty -which takes an HsExpr of type actual_ty into one of type -expected_ty. - -Note [Ambiguity check and deep subsumption] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: (forall b. Eq b => a -> a) -> Int - -Does `f` have an ambiguous type? The ambiguity check usually checks -that this definition of f' would typecheck, where f' has the exact same -type as f: - f' :: (forall b. Eq b => a -> a) -> Intp - f' = f - -This will be /rejected/ with DeepSubsumption but /accepted/ with -ShallowSubsumption. On the other hand, this eta-expanded version f'' -would be rejected both ways: - f'' :: (forall b. Eq b => a -> a) -> Intp - f'' x = f x - -This is squishy in the same way as other examples in GHC.Tc.Validity -Note [The squishiness of the ambiguity check] - -The situation in June 2022. Since we have SimpleSubsumption at the moment, -we don't want introduce new breakage if you add -XDeepSubsumption, by -rejecting types as ambiguous that weren't ambiguous before. So, as a -holding decision, we /always/ use SimpleSubsumption for the ambiguity check -(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. --} - - - ------------------ --- tcWrapResult needs both un-type-checked (for origins and error messages) --- and type-checked (for wrapping) expressions -tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTc) -tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr - -tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType - -> TcM (HsExpr GhcTc) -tcWrapResultO orig rn_expr expr actual_ty res_ty - = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty - , text "Expected:" <+> ppr res_ty ]) - ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty - ; return (mkHsWrap wrap expr) } - -tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc - -> TcRhoType -- Actual -- a rho-type not a sigma-type - -> ExpRhoType -- Expected - -> TcM (HsExpr GhcTc) --- A version of tcWrapResult to use when the actual type is a --- rho-type, so nothing to instantiate; just go straight to unify. --- It means we don't need to pass in a CtOrigin -tcWrapResultMono rn_expr expr act_ty res_ty - = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $ - do { co <- unifyExpectedType rn_expr act_ty res_ty - ; return (mkHsWrapCo co expr) } - -unifyExpectedType :: HsExpr GhcRn - -> TcRhoType -- Actual -- a rho-type not a sigma-type - -> ExpRhoType -- Expected - -> TcM TcCoercionN -unifyExpectedType rn_expr act_ty exp_ty - = case exp_ty of - Infer inf_res -> fillInferResult act_ty inf_res - Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty - ------------------------- -tcSubTypePat :: CtOrigin -> UserTypeCtxt - -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper --- Used in patterns; polarity is backwards compared --- to tcSubType --- If wrap = tc_sub_type_et t1 t2 --- => wrap :: t1 ~> t2 -tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected - = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected - -tcSubTypePat _ _ (Infer inf_res) ty_expected - = do { co <- fillInferResult ty_expected inf_res - -- In patterns we do not instantatiate - - ; return (mkWpCastN (mkSymCo co)) } - ---------------- -tcSubType :: CtOrigin -> UserTypeCtxt - -> TcSigmaType -- ^ Actual - -> ExpRhoType -- ^ Expected - -> TcM HsWrapper --- Checks that 'actual' is more polymorphic than 'expected' -tcSubType orig ctxt ty_actual ty_expected - = addSubTypeCtxt ty_actual ty_expected $ - do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) - ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } - ---------------- -tcSubTypeDS :: HsExpr GhcRn - -> TcRhoType -- Actual -- a rho-type not a sigma-type - -> ExpRhoType -- Expected - -> 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_deep (unifyType m_thing) orig - GenSigCtxt act_rho exp_rho - - Infer inf_res -> do { co <- fillInferResult act_rho inf_res - ; return (mkWpCastN co) } - where - orig = exprCtOrigin rn_expr - m_thing = Just (HsExprRnThing rn_expr) - ---------------- -tcSubTypeNC :: CtOrigin -- ^ Used when instantiating - -> UserTypeCtxt -- ^ Used when skolemising - -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) - -> TcSigmaType -- ^ Actual type - -> ExpRhoType -- ^ Expected type - -> TcM HsWrapper -tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty - = case res_ty of - Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt - ty_actual ty_expected - - Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual - -- See Note [Instantiation of InferResult] - ; co <- fillInferResult rho inf_res - ; return (mkWpCastN co <.> wrap) } - ---------------- -tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we - -- doing this subtype check? - -> UserTypeCtxt -- where did the expected type arise? - -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- External entry point, but no ExpTypes on either side --- Checks that actual <= expected --- Returns HsWrapper :: actual ~ expected -tcSubTypeSigma orig ctxt ty_actual ty_expected - = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected - ---------------- -tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise - -> TcSigmaType -> TcSigmaType -> TcM HsWrapper --- See Note [Ambiguity check and deep subsumption] -tcSubTypeAmbiguity ctxt ty_actual ty_expected - = tc_sub_type_shallow (unifyType Nothing) - (AmbiguityCheckOrigin ctxt) - ctxt ty_actual ty_expected - ---------------- -addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a -addSubTypeCtxt ty_actual ty_expected thing_inside - | isRhoTy ty_actual -- If there is no polymorphism involved, the - , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) - = thing_inside -- gives enough context by itself - | otherwise - = addErrCtxtM mk_msg thing_inside - where - mk_msg tidy_env - = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual - ; ty_expected <- readExpType ty_expected - -- A worry: might not be filled if we're debugging. Ugh. - ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected - ; let msg = vcat [ hang (text "When checking that:") - 4 (ppr ty_actual) - , nest 2 (hang (text "is more polymorphic than:") - 2 (ppr ty_expected)) ] - ; return (tidy_env, msg) } - - -{- Note [Instantiation of InferResult] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We now always instantiate before filling in InferResult, so that -the result is a TcRhoType: see #17173 for discussion. - -For example: - -1. Consider - f x = (*) - We want to instantiate the type of (*) before returning, else we - will infer the type - f :: forall {a}. a -> forall b. Num b => b -> b -> b - This is surely confusing for users. - - And worse, the monomorphism restriction won't work properly. The MR is - dealt with in simplifyInfer, and simplifyInfer has no way of - instantiating. This could perhaps be worked around, but it may be - hard to know even when instantiation should happen. - -2. Another reason. Consider - f :: (?x :: Int) => a -> a - g y = let ?x = 3::Int in f - Here want to instantiate f's type so that the ?x::Int constraint - gets discharged by the enclosing implicit-parameter binding. - -3. Suppose one defines plus = (+). If we instantiate lazily, we will - infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism - restriction compels us to infer - plus :: Integer -> Integer -> Integer - (or similar monotype). Indeed, the only way to know whether to apply - the monomorphism restriction at all is to instantiate - -There is one place where we don't want to instantiate eagerly, -namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type -command. See Note [Implementing :type] in GHC.Tc.Module. --} - ---------------- -tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow - :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify - -> CtOrigin -- Used when instantiating - -> UserTypeCtxt -- Used when skolemising - -> TcSigmaType -- Actual; a sigma-type - -> TcSigmaType -- Expected; also a sigma-type - -> TcM HsWrapper --- Checks that actual_ty is more polymorphic than expected_ty --- If wrap = tc_sub_type t1 t2 --- => wrap :: t1 ~> t2 --- --- The "how to unify argument" is always a call to `uType TypeLevel orig`, --- but with different ways of constructing the CtOrigin `orig` from --- the argument types and context. - ----------------------- -tc_sub_type unify inst_orig ctxt ty_actual ty_expected - = do { deep_subsumption <- xoptM LangExt.DeepSubsumption - ; if deep_subsumption - then tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected - else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected - } - ----------------------- -tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , definitely_mono_shallow ty_actual - = do { traceTc "tc_sub_type (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - unify ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_type (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - - ; (sk_wrap, inner_wrap) - <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> - do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual - ; cow <- unify rho_a sk_rho - ; return (mkWpCastN cow <.> wrap) } - - ; return (sk_wrap <.> inner_wrap) } - ----------------------- -tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected - | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] - , definitely_mono_deep ty_actual - = do { traceTc "tc_sub_type_deep (drop to equality)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; mkWpCastN <$> - unify ty_actual ty_expected } - - | otherwise -- This is the general case - = do { traceTc "tc_sub_type_deep (general case)" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - - ; (sk_wrap, inner_wrap) - <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho -> - -- See Note [Deep subsumption] - tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho - - ; return (sk_wrap <.> inner_wrap) } - -definitely_mono_shallow :: TcType -> Bool -definitely_mono_shallow ty = isRhoTy ty - -- isRhoTy: no top level forall or (=>) - -definitely_mono_deep :: TcType -> Bool -definitely_mono_deep ty - | not (definitely_mono_shallow ty) = False - -- isRhoTy: False means top level forall or (=>) - | Just (_, res) <- tcSplitFunTy_maybe ty = definitely_mono_deep res - -- Top level (->) - | otherwise = True - -definitely_poly :: TcType -> Bool --- A very conservative test: --- see Note [Don't skolemise unnecessarily] -definitely_poly ty - | (tvs, theta, tau) <- tcSplitSigmaTy ty - , (tv:_) <- tvs -- At least one tyvar - , null theta -- No constraints; see (DP1) - , tv `isInjectiveInType` tau - -- The tyvar actually occurs (DP2), - -- and occurs in an injective position (DP3). - = True - | otherwise - = False - -{- Note [Don't skolemise unnecessarily] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are trying to solve - ty_actual <= ty_expected - (Char->Char) <= (forall a. a->a) -We could skolemise the 'forall a', and then complain -that (Char ~ a) is insoluble; but that's a pretty obscure -error. It's better to say that - (Char->Char) ~ (forall a. a->a) -fails. - -If we prematurely go to equality we'll reject a program we should -accept (e.g. #13752). So the test (which is only to improve error -message) is very conservative: - - * ty_actual is /definitely/ monomorphic: see `definitely_mono` - This definitely_mono test comes in "shallow" and "deep" variants - - * ty_expected is /definitely/ polymorphic: see `definitely_poly` - This definitely_poly test is more subtle than you might think. - Here are three cases where expected_ty looks polymorphic, but - isn't, and where it would be /wrong/ to switch to equality: - - (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) - - (DP2) (Char->Char) <= (forall a. Char -> Char) - - (DP3) (Char->Char) <= (forall a. F [a] Char -> Char) - where type instance F [x] t = t - - -Note [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. - -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. - -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. - -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 - | Just (w1, w2) <- isMultMul w_actual = - do { w1 <- tcSubMult origin w1 w_expected - ; w2 <- tcSubMult origin w2 w_expected - ; return (w1 <.> w2) } - -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is - -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p - -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating - -- multiplicities] in Multiplicity. -tcSubMult origin w_actual w_expected = - case submult w_actual w_expected of - Submult -> return WpHole - Unknown -> tcEqMult origin w_actual w_expected - -tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper -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 } - - -{- ********************************************************************* -* * - Deep subsumption -* * -********************************************************************* -} - -{- Note [Deep subsumption] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The DeepSubsumption extension, documented here - - https://github.com/ghc-proposals/ghc-proposals/pull/511. - -makes a best-efforts attempt implement deep subsumption as it was -prior to the Simplify Subsumption proposal: - - https://github.com/ghc-proposals/ghc-proposals/pull/287 - -The effects are in these main places: - -1. In the subsumption check, tcSubType, we must do deep skolemisation: - see the call to tcDeeplySkolemise in tc_sub_type_deep - -2. In tcPolyExpr we must do deep skolemisation: - see the call to tcDeeplySkolemise in tcSkolemiseExpType - -3. for expression type signatures (e :: ty), and functions with type - signatures (e.g. f :: ty; f = e), we must deeply skolemise the type; - see the call to tcDeeplySkolemise in tcSkolemiseScoped. - -4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result - type. Without deep subsumption, unifyExpectedType would be sufficent. - -In all these cases note that the deep skolemisation must be done /first/. -Consider (1) - (forall a. Int -> a -> a) <= Int -> (forall b. b -> b) -We must skolemise the `forall b` before instantiating the `forall a`. -See also Note [Deep skolemisation]. - -Note that we /always/ use shallow subsumption in the ambiguity check. -See Note [Ambiguity check and deep subsumption]. - -Note [Deep skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~~~ -deeplySkolemise decomposes and skolemises a type, returning a type -with all its arrows visible (ie not buried under foralls) - -Examples: - - deeplySkolemise (Int -> forall a. Ord a => blah) - = ( wp, [a], [d:Ord a], Int -> blah ) - where wp = \x:Int. /\a. \(d:Ord a). x - - deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) - = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) - where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x - -In general, - if deeplySkolemise ty = (wrap, tvs, evs, rho) - and e :: rho - then wrap e :: ty - and 'wrap' binds tvs, evs - -ToDo: this eta-abstraction plays fast and loose with termination, - because it can introduce extra lambdas. Maybe add a `seq` to - fix this - -Note [Setting the argument context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we are doing the ambiguity check for the (bogus) - f :: (forall a b. C b => a -> a) -> Int - -We'll call - tcSubType ((forall a b. C b => a->a) -> Int ) - ((forall a b. C b => a->a) -> Int ) - -with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing -on the argument type of the (->) -- and at that point we want to switch -to a UserTypeCtxt of GenSigCtxt. Why? - -* Error messages. If we stick with FunSigCtxt we get errors like - * Could not deduce: C b - from the context: C b0 - bound by the type signature for: - f :: forall a b. C b => a->a - But of course f does not have that type signature! - Example tests: T10508, T7220a, Simple14 - -* Implications. We may decide to build an implication for the whole - ambiguity check, but we don't need one for each level within it, - and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. - See Note [When to build an implication] - -Note [Multiplicity in deep subsumption] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - t1 ->{mt} t2 <= s1 ->{ms} s2 - -At the moment we /unify/ ms~mt, via tcEqMult. - -Arguably we should use `tcSubMult`. But then if mt=m0 (a unification -variable) and ms=Many, `tcSubMult` is a no-op (since anything is a -sub-multiplicty of Many). But then `m0` may never get unified with -anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds -Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base -we get this - - "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys - = \xs -> xs ++ ys - -where we eta-expanded that (:). But now foldr expects an argument -with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint -complains. - -The easiest solution was to use tcEqMult in tc_sub_type_ds, and -insist on equality. This is only in the DeepSubsumption code anyway. --} - -tc_sub_type_ds :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify - -> CtOrigin -- Used when instantiating - -> UserTypeCtxt -- Used when skolemising - -> TcSigmaType -- Actual; a sigma-type - -> TcRhoType -- Expected; deeply skolemised - -> TcM HsWrapper - --- If wrap = tc_sub_type_ds t1 t2 --- => wrap :: t1 ~> t2 --- Here is where the work actually happens! --- Precondition: ty_expected is deeply skolemised - -tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected - = do { traceTc "tc_sub_type_ds" $ - vcat [ text "ty_actual =" <+> ppr ty_actual - , text "ty_expected =" <+> ppr ty_expected ] - ; go ty_actual ty_expected } - where - -- NB: 'go' is not recursive, except for doing coreView - go ty_a ty_e | Just ty_a' <- coreView ty_a = go ty_a' ty_e - | Just ty_e' <- coreView ty_e = go ty_a ty_e' - - go (TyVarTy tv_a) ty_e - = do { lookup_res <- isFilledMetaTyVar_maybe tv_a - ; case lookup_res of - Just ty_a' -> - do { traceTc "tc_sub_type_ds following filled meta-tyvar:" - (ppr tv_a <+> text "-->" <+> ppr ty_a') - ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e } - Nothing -> just_unify ty_actual ty_expected } - - go ty_a@(FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) - ty_e@(FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) - | isVisibleFunArg af1, isVisibleFunArg af2 - = if (isTauTy ty_a && isTauTy ty_e) -- Short cut common case to avoid - then just_unify ty_actual ty_expected -- unnecessary eta expansion - else - -- This is where we do the co/contra thing, and generate a WpFun, which in turn - -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption - do { arg_wrap <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg - -- GenSigCtxt: See Note [Setting the argument context] - ; res_wrap <- tc_sub_type_ds unify inst_orig ctxt act_res exp_res - ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult - -- See Note [Multiplicity in deep subsumption] - ; return (mult_wrap <.> - mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) } - -- arg_wrap :: exp_arg ~> act_arg - -- res_wrap :: act-res ~> exp_res - where - given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) - - go ty_a ty_e - | let (tvs, theta, _) = tcSplitSigmaTy ty_a - , not (null tvs && null theta) - = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a - ; body_wrap <- tc_sub_type_ds unify inst_orig ctxt in_rho ty_e - ; return (body_wrap <.> in_wrap) } - - | otherwise -- Revert to unification - = do { -- It's still possible that ty_actual has nested foralls. Instantiate - -- these, as there's no way unification will succeed with them in. - -- See 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 := (->) - (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual - ; unify_wrap <- just_unify rho_a ty_expected - ; return (unify_wrap <.> inst_wrap) } - - just_unify ty_a ty_e = do { cow <- unify ty_a ty_e - ; return (mkWpCastN cow) } - -tcDeeplySkolemise - :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) - -> TcM (HsWrapper, result) - -- ^ The wrapper has type: spec_ty ~> expected_ty --- Just like tcTopSkolemise, but calls --- deeplySkolemise instead of topSkolemise --- See Note [Deep skolemisation] -tcDeeplySkolemise ctxt expected_ty thing_inside - | isTauTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty - ; return (idHsWrapper, res) } - | otherwise - = do { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise; - -- but skol_info can't be built until we have tv_prs - rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs) - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - -deeplySkolemise :: SkolemInfo -> TcSigmaType - -> TcM ( HsWrapper - , [(Name,TyVar)] -- All skolemised variables - , [EvVar] -- All "given"s - , TcRhoType ) --- See Note [Deep skolemisation] -deeplySkolemise skol_info ty - = go init_subst ty - where - init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty - = do { let arg_tys' = substScaledTys subst arg_tys - ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' - ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs - ; ev_vars1 <- newEvVars (substTheta subst' theta) - ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' - ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpEta ids1 (mkWpTyLams tvs1 - <.> mkWpEvLams ev_vars1 - <.> wrap) - , tv_prs1 ++ tvs_prs2 - , ev_vars1 ++ ev_vars2 - , mkScaledFunTys arg_tys' rho ) } - - | otherwise - = return (idHsWrapper, [], [], substTy subst ty) - -- substTy is a quick no-op on an empty substitution - -deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) -deeplyInstantiate orig ty - = go init_subst ty - where - init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) - - go subst ty - | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty - = do { (subst', tvs') <- newMetaTyVarsX subst tvs - ; let arg_tys' = substScaledTys subst' arg_tys - theta' = substTheta subst' theta - ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' - ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' - ; (wrap2, rho2) <- go subst' rho - ; return (mkWpEta ids1 (wrap2 <.> wrap1), - mkScaledFunTys arg_tys' rho2) } - - | otherwise - = do { let ty' = substTy subst ty - ; return (idHsWrapper, ty') } - -tcDeepSplitSigmaTy_maybe - :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType) --- Looks for a *non-trivial* quantified type, under zero or more function arrows --- By "non-trivial" we mean either tyvars or constraints are non-empty - -tcDeepSplitSigmaTy_maybe ty - | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty - , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty - = Just (arg_ty:arg_tys, tvs, theta, rho) - - | (tvs, theta, rho) <- tcSplitSigmaTy ty - , not (null tvs && null theta) - = Just ([], tvs, theta, rho) - - | otherwise = Nothing - - -{- ********************************************************************* -* * - Generalisation -* * -********************************************************************* -} - -{- Note [Skolemisation] -~~~~~~~~~~~~~~~~~~~~~~~ -tcTopSkolemise takes "expected type" and strip off quantifiers to expose the -type underneath, binding the new skolems for the 'thing_inside' -The returned 'HsWrapper' has type (specific_ty -> expected_ty). - -Note that for a nested type like - forall a. Eq a => forall b. Ord b => blah -we still only build one implication constraint - forall a b. (Eq a, Ord b) => -This is just an optimisation, but it's why we use topSkolemise to -build the pieces from all the layers, before making a single call -to checkConstraints. - -tcSkolemiseScoped is very similar, but differs in two ways: - -* It deals specially with just the outer forall, bringing those type - variables into lexical scope. To my surprise, I found that doing - this unconditionally in tcTopSkolemise (i.e. doing it even if we don't - need to bring the variables into lexical scope, which is harmless) - caused a non-trivial (1%-ish) perf hit on the compiler. - -* It handles deep subumption, wheres tcTopSkolemise never looks under - function arrows. - -* It always calls checkConstraints, even if there are no skolem - variables at all. Reason: there might be nested deferred errors - that must not be allowed to float to top level. - See Note [When to build an implication] below. --} - -tcTopSkolemise, tcSkolemiseScoped - :: UserTypeCtxt -> TcSigmaType - -> (TcType -> TcM result) - -> TcM (HsWrapper, result) - -- ^ The wrapper has type: spec_ty ~> expected_ty --- See Note [Skolemisation] for the differences between --- tcSkolemiseScoped and tcTopSkolemise - -tcSkolemiseScoped ctxt expected_ty thing_inside - = do { deep_subsumption <- xoptM LangExt.DeepSubsumption - ; let skolemise | deep_subsumption = deeplySkolemise - | otherwise = topSkolemise - ; -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, res) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - tcExtendNameTyVarEnv tv_prs $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, res) } - -tcTopSkolemise ctxt expected_ty thing_inside - | isRhoTy expected_ty -- Short cut for common case - = do { res <- thing_inside expected_ty - ; return (idHsWrapper, res) } - | otherwise - = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] - -- in GHC.Tc.Utils.TcType - rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty - ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - - ; let skol_tvs = map snd tv_prs - ; (ev_binds, result) - <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ - thing_inside rho_ty - - ; return (wrap <.> mkWpLet ev_binds, result) } - -- The ev_binds returned by checkConstraints is very - -- often empty, in which case mkWpLet is a no-op - --- | Variant of 'tcTopSkolemise' that takes an ExpType -tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType - -> (ExpRhoType -> TcM result) - -> TcM (HsWrapper, result) -tcSkolemiseExpType _ et@(Infer {}) thing_inside - = (idHsWrapper, ) <$> thing_inside et -tcSkolemiseExpType ctxt (Check ty) thing_inside - = do { deep_subsumption <- xoptM LangExt.DeepSubsumption - ; let skolemise | deep_subsumption = tcDeeplySkolemise - | otherwise = tcTopSkolemise - ; skolemise ctxt ty $ \rho_ty -> - thing_inside (mkCheckExpType rho_ty) } - -checkConstraints :: SkolemInfoAnon - -> [TcTyVar] -- Skolems - -> [EvVar] -- Given - -> TcM result - -> TcM (TcEvBinds, result) - -checkConstraints skol_info skol_tvs given thing_inside - = do { implication_needed <- implicationNeeded skol_info skol_tvs given - - ; if implication_needed - then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted - ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) - ; emitImplications implics - ; return (ev_binds, result) } - - else -- Fast path. We check every function argument with tcCheckPolyExpr, - -- which uses tcTopSkolemise and hence checkConstraints. - -- So this fast path is well-exercised - do { res <- thing_inside - ; return (emptyTcEvBinds, res) } } - -checkTvConstraints :: SkolemInfo - -> [TcTyVar] -- Skolem tyvars - -> TcM result - -> TcM result - -checkTvConstraints skol_info skol_tvs thing_inside - = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside - ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted - ; return result } - -emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM () -emitResidualTvConstraint skol_info skol_tvs tclvl wanted - | not (isEmptyWC wanted) || - checkTelescopeSkol skol_info_anon - = -- checkTelescopeSkol: in this case, /always/ emit this implication - -- even if 'wanted' is empty. We need the implication so that we check - -- for a bad telescope. See Note [Skolem escape and forall-types] in - -- GHC.Tc.Gen.HsType - do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted - ; emitImplication implic } - - | otherwise -- Empty 'wanted', emit nothing - = return () - where - skol_info_anon = getSkolemInfo skol_info - -buildTvImplication :: SkolemInfoAnon -> [TcTyVar] - -> TcLevel -> WantedConstraints -> TcM Implication -buildTvImplication skol_info skol_tvs tclvl wanted - = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ - do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints - -- are solved by filling in coercion holes, not - -- by creating a value-level evidence binding - ; implic <- newImplication - - ; let implic' = implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given_eqs = NoGivenEqs - , ic_wanted = wanted - , ic_binds = ev_binds - , ic_info = skol_info } - - ; checkImplicationInvariants implic' - ; return implic' } - -implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool --- See Note [When to build an implication] -implicationNeeded skol_info skol_tvs given - | null skol_tvs - , null given - , not (alwaysBuildImplication skol_info) - = -- Empty skolems and givens - do { tc_lvl <- getTcLevel - ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are - then return False -- already inside an implication - else - do { dflags <- getDynFlags -- If any deferral can happen, - -- we must build an implication - ; return (gopt Opt_DeferTypeErrors dflags || - gopt Opt_DeferTypedHoles dflags || - gopt Opt_DeferOutOfScopeVariables dflags) } } - - | otherwise -- Non-empty skolems or givens - = return True -- Definitely need an implication - -alwaysBuildImplication :: SkolemInfoAnon -> Bool --- See Note [When to build an implication] -alwaysBuildImplication _ = False - -{- Commmented out for now while I figure out about error messages. - See #14185 - -alwaysBuildImplication (SigSkol ctxt _ _) - = case ctxt of - FunSigCtxt {} -> True -- RHS of a binding with a signature - _ -> False -alwaysBuildImplication (RuleSkol {}) = True -alwaysBuildImplication (InstSkol {}) = True -alwaysBuildImplication (FamInstSkol {}) = True -alwaysBuildImplication _ = False --} - -buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] - -> [EvVar] -> WantedConstraints - -> TcM (Bag Implication, TcEvBinds) -buildImplicationFor tclvl skol_info skol_tvs given wanted - | isEmptyWC wanted && null given - -- Optimisation : if there are no wanteds, and no givens - -- don't generate an implication at all. - -- Reason for the (null given): we don't want to lose - -- the "inaccessible alternative" error check - = return (emptyBag, emptyTcEvBinds) - - | otherwise - = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ - -- Why allow TyVarTvs? Because implicitly declared kind variables in - -- non-CUSK type declarations are TyVarTvs, and we need to bring them - -- into scope as a skolem in an implication. This is OK, though, - -- because TyVarTvs will always remain tyvars, even after unification. - do { ev_binds_var <- newTcEvBinds - ; implic <- newImplication - ; let implic' = implic { ic_tclvl = tclvl - , ic_skols = skol_tvs - , ic_given = given - , ic_wanted = wanted - , ic_binds = ev_binds_var - , ic_info = skol_info } - ; checkImplicationInvariants implic' - - ; return (unitBag implic', TcEvBinds ev_binds_var) } - -{- Note [When to build an implication] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have some 'skolems' and some 'givens', and we are -considering whether to wrap the constraints in their scope into an -implication. We must /always/ so if either 'skolems' or 'givens' are -non-empty. But what if both are empty? You might think we could -always drop the implication. Other things being equal, the fewer -implications the better. Less clutter and overhead. But we must -take care: - -* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, - we'll make a /term-level/ evidence binding for 'g = error "blah"'. - We must have an EvBindsVar those bindings!, otherwise they end up as - top-level unlifted bindings, which are verboten. This only matters - at top level, so we check for that - See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors. - cf #14149 for an example of what goes wrong. - -* If you have - f :: Int; f = f_blah - g :: Bool; g = g_blah - If we don't build an implication for f or g (no tyvars, no givens), - the constraints for f_blah and g_blah are solved together. And that - can yield /very/ confusing error messages, because we can get - [W] C Int b1 -- from f_blah - [W] C Int b2 -- from g_blan - and fundpes can yield [W] b1 ~ b2, even though the two functions have - literally nothing to do with each other. #14185 is an example. - Building an implication keeps them separate. --} - -{- -************************************************************************ -* * - Boxy unification -* * -************************************************************************ - -The exported functions are all defined as versions of some -non-exported generic functions. --} - -unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 - -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) - -> TcM TcCoercionN -- :: ty1 ~# ty2 --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyType thing ty1 ty2 - = unifyTypeAndEmit TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = thing - , uo_visible = True } - -unifyInvisibleType :: TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) - -> TcM TcCoercionN -- :: ty1 ~# ty2 --- Actual and expected types --- Returns a coercion : ty1 ~ ty2 -unifyInvisibleType ty1 ty2 - = unifyTypeAndEmit TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = Nothing - , uo_visible = False } -- This is the "invisible" bit - -unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN --- Like unifyType, but swap expected and actual in error messages --- This is used when typechecking patterns -unifyTypeET ty1 ty2 - = unifyTypeAndEmit TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped - , uo_expected = ty1 -- NB swapped - , uo_thing = Nothing - , uo_visible = True } - - -unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN -unifyKind mb_thing ty1 ty2 - = unifyTypeAndEmit KindLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = mb_thing - , uo_visible = True } - -unifyTypeAndEmit :: TypeOrKind -> CtOrigin -> TcType -> TcType -> TcM CoercionN --- Make a ref-cell, unify, emit the collected constraints -unifyTypeAndEmit t_or_k orig ty1 ty2 - = do { ref <- newTcRef emptyBag - ; loc <- getCtLocM orig (Just t_or_k) - ; let env = UE { u_loc = loc, u_role = Nominal - , u_rewriters = emptyRewriterSet -- ToDo: check this - , u_defer = ref, u_unified = Nothing } - - -- The hard work happens here - ; co <- uType env ty1 ty2 - - ; cts <- readTcRef ref - ; unless (null cts) (emitSimples cts) - ; return co } - -{- -%************************************************************************ -%* * - uType and friends -%* * -%************************************************************************ - -Note [The eager unifier] -~~~~~~~~~~~~~~~~~~~~~~~~ -The eager unifier, `uType`, is called by - - * The constraint generator (e.g. in GHC.Tc.Gen.Expr), - via the wrappers `unifyType`, `unifyKind` etc - - * The constraint solver (e.g. in GHC.Tc.Solver.Equality), - via `GHC.Tc.Solver.Monad.wrapUnifierTcS`. - -`uType` runs in the TcM monad, but it carries a UnifyEnv that tells it -what to do when unifying a variable or deferring a constraint. Specifically, - * it collects deferred constraints in `u_defer`, and - * it records which unification variables it has unified in `u_unified` -Then it is up to the wrappers (one for the constraint generator, one for -the constraint solver) to deal with these collected sets. - -Although `uType` runs in the TcM monad for convenience, really it could -operate just with the ability to - * write to the accumulators of deferred constraints - and unification variables in UnifyEnv. - * read and update existing unification variables - * zonk types befire unifying (`zonkTcType` in `uUnfilledVar`, and - `zonkTyCoVarKind` in `uUnfilledVar1` - * create fresh coercion holes (`newCoercionHole`) - * emit tracing info for debugging - * look at the ambient TcLevel: `getTcLevel` -A job for the future. --} - -data UnifyEnv - = UE { u_role :: Role - , u_loc :: CtLoc - , u_rewriters :: RewriterSet - - -- Deferred constraints - , u_defer :: TcRef (Bag Ct) - - -- Which variables are unified; - -- if Nothing, we don't care - , u_unified :: Maybe (TcRef [TcTyVar]) - } - -setUEnvRole :: UnifyEnv -> Role -> UnifyEnv -setUEnvRole uenv role = uenv { u_role = role } - -updUEnvLoc :: UnifyEnv -> (CtLoc -> CtLoc) -> UnifyEnv -updUEnvLoc uenv@(UE { u_loc = loc }) upd = uenv { u_loc = upd loc } - -mkKindEnv :: UnifyEnv -> TcType -> TcType -> UnifyEnv --- Modify the UnifyEnv to be right for unifing --- the kinds of these two types -mkKindEnv env@(UE { u_loc = ctloc }) ty1 ty2 - = env { u_role = Nominal, u_loc = mkKindEqLoc ty1 ty2 ctloc } - -uType, uType_defer - :: UnifyEnv - -> TcType -- ty1 is the *actual* type - -> TcType -- ty2 is the *expected* type - -> TcM CoercionN - --- It is always safe to defer unification to the main constraint solver --- See Note [Deferred unification] -uType_defer (UE { u_loc = loc, u_defer = ref - , u_role = role, u_rewriters = rewriters }) - ty1 ty2 -- ty1 is "actual", ty2 is "expected" - = do { let pred_ty = mkPrimEqPredRole role ty1 ty2 - ; hole <- newCoercionHole loc pred_ty - ; let ct = mkNonCanonical $ - CtWanted { ctev_pred = pred_ty - , ctev_dest = HoleDest hole - , ctev_loc = loc - , ctev_rewriters = rewriters } - co = HoleCo hole - ; updTcRef ref (`snocBag` ct) - -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality - - -- Error trace only - -- NB. do *not* call mkErrInfo unless tracing is on, - -- because it is hugely expensive (#5631) - ; whenDOptM Opt_D_dump_tc_trace $ - do { ctxt <- getErrCtxt - ; doc <- mkErrInfo emptyTidyEnv ctxt - ; traceTc "utype_defer" (vcat [ ppr role - , debugPprType ty1 - , debugPprType ty2 - , doc]) - ; traceTc "utype_defer2" (ppr co) } - - ; return co } - - --------------- -uType env@(UE { u_role = role }) orig_ty1 orig_ty2 - | Phantom <- role - = do { kind_co <- uType (mkKindEnv env orig_ty1 orig_ty2) - (typeKind orig_ty1) (typeKind orig_ty2) - ; return (mkPhantomCo kind_co orig_ty1 orig_ty2) } - - | otherwise - = do { tclvl <- getTcLevel - ; traceTc "u_tys" $ vcat - [ text "tclvl" <+> ppr tclvl - , sep [ ppr orig_ty1, text "~" <> ppr role, ppr orig_ty2] ] - ; co <- go orig_ty1 orig_ty2 - ; if isReflCo co - then traceTc "u_tys yields no coercion" Outputable.empty - else traceTc "u_tys yields coercion:" (ppr co) - ; return co } - where - go :: TcType -> TcType -> TcM CoercionN - -- The arguments to 'go' are always semantically identical - -- to orig_ty{1,2} except for looking through type synonyms - - -- Unwrap casts before looking for variables. This way, we can easily - -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we - -- didn't do it this way, and then the unification above was deferred. - go (CastTy t1 co1) t2 - = do { co_tys <- uType env t1 t2 - ; return (mkCoherenceLeftCo role t1 co1 co_tys) } - - go t1 (CastTy t2 co2) - = do { co_tys <- uType env t1 t2 - ; return (mkCoherenceRightCo role t2 co2 co_tys) } - - -- Variables; go for uUnfilledVar - -- Note that we pass in *original* (before synonym expansion), - -- so that type variables tend to get filled in with - -- the most informative version of the type - go (TyVarTy tv1) ty2 - = do { lookup_res <- isFilledMetaTyVar_maybe tv1 - ; case lookup_res of - Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) - ; uType env ty1 orig_ty2 } - Nothing -> uUnfilledVar env NotSwapped tv1 ty2 } - - go ty1 (TyVarTy tv2) - = do { lookup_res <- isFilledMetaTyVar_maybe tv2 - ; case lookup_res of - Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) - ; uType env orig_ty1 ty2 } - Nothing -> uUnfilledVar env IsSwapped tv2 ty1 } - - -- See Note [Expanding synonyms during unification] - go ty1@(TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = return $ mkReflCo role ty1 - - -- See Note [Expanding synonyms during unification] - -- - -- Also NB that we recurse to 'go' so that we don't push a - -- new item on the origin stack. As a result if we have - -- type Foo = Int - -- and we try to unify Foo ~ Bool - -- we'll end up saying "can't match Foo with Bool" - -- rather than "can't match "Int with Bool". See #4535. - go ty1 ty2 - | Just ty1' <- coreView ty1 = go ty1' ty2 - | Just ty2' <- coreView ty2 = go ty1 ty2' - - -- Functions (t1 -> t2) just check the two parts - go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) - | isVisibleFunArg af1 -- Do not attempt (c => t); just defer - , af1 == af2 -- Important! See #21530 - = do { co_w <- uType (env { u_role = funRole role SelMult }) w1 w2 - ; co_l <- uType (env { u_role = funRole role SelArg }) arg1 arg2 - ; co_r <- uType (env { u_role = funRole role SelRes }) res1 res2 - ; return $ mkNakedFunCo role af1 co_w co_l co_r } - - -- Always defer if a type synonym family (type function) - -- is involved. (Data families behave rigidly.) - go ty1@(TyConApp tc1 _) ty2 - | isTypeFamilyTyCon tc1 = defer ty1 ty2 - go ty1 ty2@(TyConApp tc2 _) - | isTypeFamilyTyCon tc2 = defer ty1 ty2 - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - -- See Note [Mismatched type lists and application decomposition] - | tc1 == tc2, equalLength tys1 tys2 - , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = assertPpr (isGenerativeTyCon tc1 role) (ppr tc1) $ - do { traceTc "go-tycon" (ppr tc1 $$ ppr tys1 $$ ppr tys2 $$ ppr (take 10 (tyConRoleListX role tc1))) - ; cos <- zipWith4M u_tc_arg (tyConVisibilities tc1) -- Infinite - (tyConRoleListX role tc1) -- Infinite - tys1 tys2 - ; return $ mkTyConAppCo role tc1 cos } - - go (LitTy m) ty@(LitTy n) - | m == n - = return $ mkReflCo role ty - - -- See Note [Care with type applications] - -- Do not decompose FunTy against App; - -- it's often a type error, so leave it for the constraint solver - go ty1@(AppTy s1 t1) ty2@(AppTy s2 t2) - = go_app (isNextArgVisible s1) ty1 s1 t1 ty2 s2 t2 - - go ty1@(AppTy s1 t1) ty2@(TyConApp tc2 ts2) - | Just (ts2', t2') <- snocView ts2 - = assert (not (tyConMustBeSaturated tc2)) $ - go_app (isNextTyConArgVisible tc2 ts2') - ty1 s1 t1 ty2 (TyConApp tc2 ts2') t2' - - go ty1@(TyConApp tc1 ts1) ty2@(AppTy s2 t2) - | Just (ts1', t1') <- snocView ts1 - = assert (not (tyConMustBeSaturated tc1)) $ - go_app (isNextTyConArgVisible tc1 ts1') - ty1 (TyConApp tc1 ts1') t1' ty2 s2 t2 - - go ty1@(CoercionTy co1) ty2@(CoercionTy co2) - = do { kco <- uType (mkKindEnv env ty1 ty2) - (coercionType co1) (coercionType co2) - ; return $ mkProofIrrelCo role kco co1 co2 } - - -- Anything else fails - -- E.g. unifying for-all types, which is relative unusual - go ty1 ty2 = defer ty1 ty2 - - ------------------ - defer ty1 ty2 -- See Note [Check for equality before deferring] - | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) - | otherwise = uType_defer env orig_ty1 orig_ty2 - - - ------------------ - u_tc_arg is_vis role ty1 ty2 - = do { traceTc "u_tc_arg" (ppr role $$ ppr ty1 $$ ppr ty2) - ; uType env_arg ty1 ty2 } - where - env_arg = env { u_loc = adjustCtLoc is_vis False (u_loc env) - , u_role = role } - - ------------------ - -- For AppTy, decompose only nominal equalities - -- See Note [Decomposing AppTy equalities] in GHC.Tc.Solver.Equality - go_app vis ty1 s1 t1 ty2 s2 t2 - | Nominal <- role - = -- Unify arguments t1/t2 before function s1/s2, because - -- the former have smaller kinds, and hence simpler error messages - -- c.f. GHC.Tc.Solver.Equality.can_eq_app - -- Example: test T8603 - do { let env_arg = env { u_loc = adjustCtLoc vis False (u_loc env) } - ; co_t <- uType env_arg t1 t2 - ; co_s <- uType env s1 s2 - ; return $ mkAppCo co_s co_t } - | otherwise - = defer ty1 ty2 - -{- Note [Check for equality before deferring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Particularly in ambiguity checks we can get equalities like (ty ~ ty). -If ty involves a type function we may defer, which isn't very sensible. -An egregious example of this was in test T9872a, which has a type signature - Proxy :: Proxy (Solutions Cubes) -Doing the ambiguity check on this signature generates the equality - Solutions Cubes ~ Solutions Cubes -and currently the constraint solver normalises both sides at vast cost. -This little short-cut in 'defer' helps quite a bit. - -Note [Care with type applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note: type applications need a bit of care! -They can match FunTy and TyConApp, so use splitAppTy_maybe -NB: we've already dealt with type variables and Notes, -so if one type is an App the other one jolly well better be too - -Note [Mismatched type lists and application decomposition] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we find two TyConApps, you might think that the argument lists -are guaranteed equal length. But they aren't. Consider matching - w (T x) ~ Foo (T x y) -We do match (w ~ Foo) first, but in some circumstances we simply create -a deferred constraint; and then go ahead and match (T x ~ T x y). -This came up in #3950. - -So either - (a) either we must check for identical argument kinds - when decomposing applications, - - (b) or we must be prepared for ill-kinded unification sub-problems - -Currently we adopt (b) since it seems more robust -- no need to maintain -a global invariant. - -Note [Expanding synonyms during unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We expand synonyms during unification, but: - * We expand *after* the variable case so that we tend to unify - variables with un-expanded type synonym. This just makes it - more likely that the inferred types will mention type synonyms - understandable to the user - - * Similarly, we expand *after* the CastTy case, just in case the - CastTy wraps a variable. - - * We expand *before* the TyConApp case. For example, if we have - type Phantom a = Int - and are unifying - Phantom Int ~ Phantom Char - it is *wrong* to unify Int and Char. - - * The problem case immediately above can happen only with arguments - to the tycon. So we check for nullary tycons *before* expanding. - This is particularly helpful when checking (* ~ *), because * is - now a type synonym. - -Note [Deferred unification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, -and yet its consistency is undetermined. Previously, there was no way to still -make it consistent. So a mismatch error was issued. - -Now these unifications are deferred until constraint simplification, where type -family instances and given equations may (or may not) establish the consistency. -Deferred unifications are of the form - F ... ~ ... -or x ~ ... -where F is a type function and x is a type variable. -E.g. - id :: x ~ y => x -> y - id e = e - -involves the unification x = y. It is deferred until we bring into account the -context x ~ y to establish that it holds. - -If available, we defer original types (rather than those where closed type -synonyms have already been expanded via tcCoreView). This is, as usual, to -improve error messages. - -************************************************************************ -* * - uUnfilledVar and friends -* * -************************************************************************ - -@uunfilledVar@ is called when at least one of the types being unified is a -variable. It does {\em not} assume that the variable is a fixed point -of the substitution; rather, notice that @uVar@ (defined below) nips -back into @uTys@ if it turns out that the variable is already bound. --} - ----------- -uUnfilledVar, uUnfilledVar1 - :: UnifyEnv - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2 - -> TcM CoercionN --- "Unfilled" means that the variable is definitely not a filled-in meta tyvar --- It might be a skolem, or untouchable, or meta -uUnfilledVar env swapped tv1 ty2 - | Nominal <- u_role env - = do { ty2 <- liftZonkM $ zonkTcType ty2 - -- Zonk to expose things to the occurs check, and so - -- that if ty2 looks like a type variable then it - -- /is/ a type variable - ; uUnfilledVar1 env swapped tv1 ty2 } - - | otherwise -- See Note [Do not unify representational equalities] - -- in GHC.Tc.Solver.Equality - = unSwap swapped (uType_defer env) (mkTyVarTy tv1) ty2 - -uUnfilledVar1 env -- Precondition: u_role==Nominal - swapped - tv1 - ty2 -- ty2 is zonked - | Just tv2 <- getTyVar_maybe ty2 - = go tv2 - - | otherwise - = uUnfilledVar2 env swapped tv1 ty2 - - where - -- 'go' handles the case where both are - -- tyvars so we might want to swap - -- E.g. maybe tv2 is a meta-tyvar and tv1 is not - go tv2 | tv1 == tv2 -- Same type variable => no-op - = return (mkNomReflCo (mkTyVarTy tv1)) - - | swapOverTyVars False tv1 tv2 -- Distinct type variables - -- Swap meta tyvar to the left if poss - = do { tv1 <- liftZonkM $ zonkTyCoVarKind tv1 - -- We must zonk tv1's kind because that might - -- not have happened yet, and it's an invariant of - -- uUnfilledTyVar2 that ty2 is fully zonked - -- Omitting this caused #16902 - ; uUnfilledVar2 env (flipSwap swapped) tv2 (mkTyVarTy tv1) } - - | otherwise - = uUnfilledVar2 env swapped tv1 ty2 - ----------- -uUnfilledVar2 :: UnifyEnv -- Precondition: u_role==Nominal - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM CoercionN -uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2 - = do { cur_lvl <- getTcLevel - -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles - -- Here we don't know about given equalities here; so we treat - -- /any/ level outside this one as untouchable. Hence cur_lvl. - ; if not (touchabilityAndShapeTest cur_lvl tv1 ty2 - && simpleUnifyCheck False tv1 ty2) - then not_ok_so_defer - else - do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs - - -- Attempt to unify kinds - ; 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) - , ppr (isReflCo co_k), ppr co_k ] - - ; if isReflCo co_k - -- Only proceed if the kinds match - -- NB: tv1 should still be unfilled, despite the kind unification - -- because tv1 is not free in ty2' (or, hence, in its kind) - then do { liftZonkM $ writeMetaTyVar tv1 ty2 - ; case u_unified env of - Nothing -> return () - Just uref -> updTcRef uref (tv1 :) - ; return (mkNomReflCo ty2) } -- Unification is always Nominal - - else -- The kinds don't match yet, so defer instead. - do { writeTcRef def_eq_ref def_eqs - -- Since we are discarding co_k, also discard any constraints - -- emitted by kind unification; they are just useless clutter. - -- Do this dicarding by simply restoring the previous state - -- of def_eqs; a bit imperative/yukky but works fine. - ; defer } - }} - where - ty1 = mkTyVarTy tv1 - defer = unSwap swapped (uType_defer env) ty1 ty2 - - not_ok_so_defer = - do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2) - -- Occurs check or an untouchable: just defer - -- NB: occurs check isn't necessarily fatal: - -- eg tv1 occurred in type family parameter - ; defer } - -swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool -swapOverTyVars is_given tv1 tv2 - -- See Note [Unification variables on the left] - | not is_given, pri1 == 0, pri2 > 0 = True - | not is_given, pri2 == 0, pri1 > 0 = False - - -- Level comparison: see Note [TyVar/TyVar orientation] - | lvl1 `strictlyDeeperThan` lvl2 = False - | lvl2 `strictlyDeeperThan` lvl1 = True - - -- Priority: see Note [TyVar/TyVar orientation] - | pri1 > pri2 = False - | pri2 > pri1 = True - - -- Names: see Note [TyVar/TyVar orientation] - | isSystemName tv2_name, not (isSystemName tv1_name) = True - - | otherwise = False - - where - lvl1 = tcTyVarLevel tv1 - lvl2 = tcTyVarLevel tv2 - pri1 = lhsPriority tv1 - pri2 = lhsPriority tv2 - tv1_name = Var.varName tv1 - tv2_name = Var.varName tv2 - - -lhsPriority :: TcTyVar -> Int --- Higher => more important to be on the LHS --- => more likely to be eliminated --- 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 - -{- Note [Unification preconditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Question: given a homogeneous equality (alpha ~# ty), when is it OK to -unify alpha := ty? - -This note only applied to /homogeneous/ equalities, in which both -sides have the same kind. - -There are five reasons not to unify: - -1. (SKOL-ESC) Skolem-escape - Consider the constraint - forall[2] a[2]. alpha[1] ~ Maybe a[2] - If we unify alpha := Maybe a, the skolem 'a' may escape its scope. - The level alpha[1] says that alpha may be used outside this constraint, - where 'a' is not in scope at all. So we must not unify. - - Bottom line: when looking at a constraint alpha[n] := ty, do not unify - if any free variable of 'ty' has level deeper (greater) than n - -2. (UNTOUCHABLE) Untouchable unification variables - Consider the constraint - forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int - There is no (SKOL-ESC) problem with unifying alpha := Int, but it might - not be the principal solution. Perhaps the "right" solution is alpha := b. - We simply can't tell. See "OutsideIn(X): modular type inference with local - assumptions", section 2.2. We say that alpha[1] is "untouchable" inside - this implication. - - Bottom line: at ambient level 'l', when looking at a constraint - alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities - between levels 'n' and 'l'. - - Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)? - Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet - -3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs - This precondition looks at the MetaInfo of the unification variable: - - * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a - TyVarTv it can only unify with a type variable, not with a - structured type. So if 'ty' is a structured type, such as (Maybe x), - don't unify. - - * CycleBreakerTv: never unified, except by restoreTyVarCycles. - -4. (CONCRETE) A ConcreteTv can only unify with a concrete type, - by definition. - - That is, if we have `rr[conc] ~ F Int`, we can't unify - `rr` with `F Int`, so we hold off on unifying. - Note however that the equality might get rewritten; for instance - if we can rewrite `F Int` to a concrete type, say `FloatRep`, - then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. - - Note that we can still make progress on unification even if - we can't fully solve an equality, e.g. - - alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ] - - we can fill beta[tau] := beta[conc]. This is why we call - 'makeTypeConcrete' in startSolvingByUnification. - -5. (COERCION-HOLE) Confusing coercion holes - Suppose our equality is - (alpha :: k) ~ (Int |> {co}) - where co :: Type ~ k is an unsolved wanted. Note that this equality - is homogeneous; both sides have kind k. We refrain from unifying here, because - of the coercion hole in the RHS -- see Wrinkle (EIK2) in - Note [Equalities with incompatible kinds] in GHC.Solver.Equality. - -Needless to say, all there are wrinkles: - -* (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free - in 'ty', where beta is a unification variable, and k>n? 'beta' - stands for a monotype, and since it is part of a level-n type - (equal to alpha[n]), we must /promote/ beta to level n. Just make - up a fresh gamma[n], and unify beta[k] := gamma[n]. - -* (TYVAR-TV) Unification variables. Suppose alpha[tyv,n] is a level-n - TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now - consider alpha[tyv,n] ~ Bool. We don't want to unify because that - would break the TyVarTv invariant. - - What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary - TauTv? Again, don't unify, because beta might later be unified - with, say Bool. (If levels permit, we reverse the orientation here; - see Note [TyVar/TyVar orientation].) - -* (UNTOUCHABLE) Untouchability. When considering (alpha[n] ~ ty), how - do we know whether there are any given equalities between level n - and the ambient level? We answer in two ways: - - * In the eager unifier, we only unify if l=n. If not, alpha may be - untouchable, and defer to the constraint solver. This check is - made in GHC.Tc.Utils.uUnifilledVar2, in the guard - isTouchableMetaTyVar. - - * In the constraint solver, we track where Given equalities occur - and use that to guard unification in - GHC.Tc.Utils.Unify.touchabilityAndShapeTest. More details in - Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet - - Historical note: in the olden days (pre 2021) the constraint solver - also used to unify only if l=n. Equalities were "floated" out of the - implication in a separate step, so that they would become touchable. - But the float/don't-float question turned out to be very delicate, - as you can see if you look at the long series of Notes associated with - GHC.Tc.Solver.floatEqualities, around Nov 2020. It's much easier - to unify in-place, with no floating. - -Note [TyVar/TyVar orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Fundeps with instances, and equality orientation] -where the kind equality orientation is important - -Given (a ~ b), should we orient the equality as (a~b) or (b~a)? -This is a surprisingly tricky question! - -The question is answered by swapOverTyVars, which is used - - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 - - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2 - -First note: only swap if you have to! - See Note [Avoid unnecessary swaps] - -So we look for a positive reason to swap, using a three-step test: - -* Level comparison. If 'a' has deeper level than 'b', - put 'a' on the left. See Note [Deeper level on the left] - -* Priority. If the levels are the same, look at what kind of - type variable it is, using 'lhsPriority'. - - Generally speaking we always try to put a MetaTv on the left in - preference to SkolemTv or RuntimeUnkTv, because the MetaTv may be - touchable and can be unified. - - Tie-breaking rules for MetaTvs: - - CycleBreakerTv: This is essentially a stand-in for another type; - it's untouchable and should have the same priority as a skolem: 0. - - - TyVarTv: These can unify only with another tyvar, but we can't unify - a TyVarTv with a TauTv, because then the TyVarTv could (transitively) - get a non-tyvar type. So give these a low priority: 1. - - - ConcreteTv: These are like TauTv, except they can only unify with - a concrete type. So we want to be able to write to them, but not quite - as much as TauTvs: 2. - - - TauTv: This is the common case; we want these on the left so that they - can be written to: 3. - - - RuntimeUnkTv: These aren't really meta-variables used in type inference, - but just a convenience in the implementation of the GHCi debugger. - Eagerly write to these: 4. See Note [RuntimeUnkTv] in - GHC.Runtime.Heap.Inspect. - -* Names. If the level and priority comparisons are all - equal, try to eliminate a TyVar with a System Name in - favour of ones with a Name derived from a user type signature - -* Age. At one point in the past we tried to break any remaining - ties by eliminating the younger type variable, based on their - Uniques. See Note [Eliminate younger unification variables] - (which also explains why we don't do this any more) - -Note [Unification variables on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of -level, so that the unification variable is on the left. - -* We /don't/ want this for Givens because if we ave - [G] a[2] ~ alpha[1] - [W] Bool ~ a[2] - we want to rewrite the wanted to Bool ~ alpha[1], - so we can float the constraint and solve it. - -* But for Wanteds putting the unification variable on - the left means an easier job when floating, and when - reporting errors -- just fewer cases to consider. - - In particular, we get better skolem-escape messages: - see #18114 - -Note [Deeper level on the left] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The most important thing is that we want to put tyvars with -the deepest level on the left. The reason to do so differs for -Wanteds and Givens, but either way, deepest wins! Simple. - -* Wanteds. Putting the deepest variable on the left maximise the - chances that it's a touchable meta-tyvar which can be solved. - -* Givens. Suppose we have something like - forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] - - If we orient the Given a[2] on the left, we'll rewrite the Wanted to - (beta[1] ~ b[1]), and that can float out of the implication. - Otherwise it can't. By putting the deepest variable on the left - we maximise our changes of eliminating skolem capture. - - See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason - to orient with the deepest skolem on the left. - - IMPORTANT NOTE: this test does a level-number comparison on - skolems, so it's important that skolems have (accurate) level - numbers. - -See #15009 for an further analysis of why "deepest on the left" -is a good plan. - -Note [Avoid unnecessary swaps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we swap without actually improving matters, we can get an infinite loop. -Consider - work item: a ~ b - inert item: b ~ c -We canonicalise the work-item to (a ~ c). If we then swap it before -adding to the inert set, we'll add (c ~ a), and therefore kick out the -inert guy, so we get - new work item: b ~ c - inert item: c ~ a -And now the cycle just repeats - -Historical Note [Eliminate younger unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given a choice of unifying - alpha := beta or beta := alpha -we try, if possible, to eliminate the "younger" one, as determined -by `ltUnique`. Reason: the younger one is less likely to appear free in -an existing inert constraint, and hence we are less likely to be forced -into kicking out and rewriting inert constraints. - -This is a performance optimisation only. It turns out to fix -#14723 all by itself, but clearly not reliably so! - -It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). -But, to my surprise, it didn't seem to make any significant difference -to the compiler's performance, so I didn't take it any further. Still -it seemed too nice to discard altogether, so I'm leaving these -notes. SLPJ Jan 18. - -Note [Prevent unification with type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We prevent unification with type families because of an uneasy compromise. -It's perfectly sound to unify with type families, and it even improves the -error messages in the testsuite. It also modestly improves performance, at -least in some cases. But it's disastrous for test case perf/compiler/T3064. -Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. -What do we do? Do we reduce F? Or do we use the given? Hard to know what's -best. GHC reduces. This is a disaster for T3064, where the type's size -spirals out of control during reduction. If we prevent -unification with type families, then the solver happens to use the equality -before expanding the type family. - -It would be lovely in the future to revisit this problem and remove this -extra, unnecessary check. But we retain it for now as it seems to work -better in practice. - -Revisited in Nov '20, along with removing flattening variables. Problem -is still present, and the solution is still the same. - -Note [Non-TcTyVars in GHC.Tc.Utils.Unify] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Because the same code is now shared between unifying types and unifying -kinds, we sometimes will see proper TyVars floating around the unifier. -Example (from test case polykinds/PolyKinds12): - - type family Apply (f :: k1 -> k2) (x :: k1) :: k2 - type instance Apply g y = g y - -When checking the instance declaration, we first *kind-check* the LHS -and RHS, discovering that the instance really should be - - type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y - -During this kind-checking, all the tyvars will be TcTyVars. Then, however, -as a second pass, we desugar the RHS (which is done in functions prefixed -with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper -TyVars, not TcTyVars, get some kind unification must happen. - -Thus, we always check if a TyVar is a TcTyVar before asking if it's a -meta-tyvar. - -This used to not be necessary for type-checking (that is, before * :: *) -because expressions get desugared via an algorithm separate from -type-checking (with wrappers, etc.). Types get desugared very differently, -causing this wibble in behavior seen here. --} - --- | Breaks apart a function kind into its pieces. -matchExpectedFunKind - :: TypedThing -- ^ type, only for errors - -> Arity -- ^ n: number of desired arrows - -> TcKind -- ^ fun_kind - -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) - -matchExpectedFunKind hs_ty n k = go n k - where - go 0 k = return (mkNomReflCo k) - - go n k | Just k' <- coreView k = go n k' - - go n k@(TyVarTy kvar) - | isMetaTyVar kvar - = do { maybe_kind <- readMetaTyVar kvar - ; case maybe_kind of - Indirect fun_kind -> go n fun_kind - Flexi -> defer n k } - - go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) - | isVisibleFunArg af - = do { co <- go (n-1) res - ; return (mkNakedFunCo Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } - - go n other - = defer n other - - defer n k - = do { arg_kinds <- newMetaKindVars n - ; res_kind <- newMetaKindVar - ; let new_fun = mkVisFunTysMany arg_kinds res_kind - origin = TypeEqOrigin { uo_actual = k - , uo_expected = new_fun - , uo_thing = Just hs_ty - , uo_visible = True - } - ; unifyTypeAndEmit KindLevel origin k new_fun } - -{- ********************************************************************* -* * - Checking alpha ~ ty - for the on-the-fly unifier -* * -********************************************************************* -} - -simpleUnifyCheck :: Bool -> TcTyVar -> TcType -> Bool --- 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 a non-concrete type if lhs_tv is concrete --- * Rejects type families unless fam_ok=True --- * Does a level-check for type variables --- --- This function is pretty heavily used, so it's optimised not to allocate -simpleUnifyCheck fam_ok 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 - - 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 - - go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) - | isInvisibleFunArg af, not forall_ok = 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 - | 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 (CastTy ty co) = not (occ_in_co co) && go ty - go (CoercionTy co) = not (occ_in_co co) - go (LitTy {}) = True - - -mkOccFolders :: TcTyVar -> (TcType -> Bool, TcCoercion -> Bool) --- These functions return True --- * if lhs_tv occurs (incl deeply, in the kind of variable) --- * if there is a coercion hole --- No expansion of type synonyms -mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co) - where - !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet - occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms - , tcf_tyvar = do_tcv, tcf_covar = do_tcv - , tcf_hole = do_hole - , tcf_tycobinder = do_bndr } - - do_tcv is v = Any (not (v `elemVarSet` is) && v == lhs_tv) - `mappend` check_ty (varType v) - - do_bndr is tcv _faf = extendVarSet is tcv - do_hole _is _hole = DM.Any True -- Reject coercion holes - -{- ********************************************************************* -* * - Equality invariant checking -* * -********************************************************************* -} - - -{- Note [Checking for foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never want to unify - alpha ~ (forall a. a->a) -> Int -So we look for foralls hidden inside the type, and it's convenient -to do that at the same time as the occurs check (which looks for -occurrences of alpha). - -However, it's not just a question of looking for foralls /anywhere/! -Consider - (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) -This is legal; e.g. dependent/should_compile/T11635. - -We don't want to reject it because of the forall in beta's kind, but -(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type) -we do need to look in beta's kind. So we carry a flag saying if a -'forall' is OK, and switch the flag on when stepping inside a kind. - -Why is it OK? Why does it not count as impredicative polymorphism? -The reason foralls are bad is because we reply on "seeing" foralls -when doing implicit instantiation. But the forall inside the kind is -fine. We'll generate a kind equality constraint - (forall k. k->*) ~ (forall k. k->*) -to check that the kinds of lhs and rhs are compatible. If alpha's -kind had instead been - (alpha :: kappa) -then this kind equality would rightly complain about unifying kappa -with (forall k. k->*) - -Note [Forgetful synonyms in checkTyConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type S a b = b -- Forgets 'a' - - [W] alpha[2] ~ Maybe (S beta[4] gamma[2]) - -We don't want to promote beta to level 2; rather, we should -expand the synonym. (Currently, in checkTypeEqRhs promotion -is irrevocable, by side effect.) - -To avoid this risk we eagerly expand forgetful synonyms. -This also means we won't get an occurs check in - a ~ Maybe (S a b) - -The annoyance is that we might expand the synonym unnecessarily, -something we generally try to avoid. But for now, this seems -simple. - -In a forgetful case like a ~ Maybe (S a b), `checkTyEqRhs` returns -a Reduction that looks - Reduction { reductionCoercion = Refl - , reductionReducedType = Maybe b } -We must jolly well use that reductionReduced type, even though the -reductionCoercion is Refl. See `canEqCanLHSFinish_no_unification`. --} - -data PuResult a b = PuFail CheckTyEqResult - | PuOK (Bag a) b - -instance Functor (PuResult a) where - fmap _ (PuFail prob) = PuFail prob - fmap f (PuOK cts x) = PuOK cts (f x) - -instance Applicative (PuResult a) where - pure x = PuOK emptyBag x - PuFail p1 <*> PuFail p2 = PuFail (p1 S.<> p2) - PuFail p1 <*> PuOK {} = PuFail p1 - PuOK {} <*> PuFail p2 = PuFail p2 - PuOK c1 f <*> PuOK c2 x = PuOK (c1 `unionBags` c2) (f x) - -instance (Outputable a, Outputable b) => Outputable (PuResult a b) where - ppr (PuFail prob) = text "PuFail" <+> (ppr prob) - ppr (PuOK cts x) = text "PuOK" <> braces - (vcat [ text "redn:" <+> ppr x - , text "cts:" <+> ppr cts ]) - -pprPur :: PuResult a b -> SDoc --- For debugging -pprPur (PuFail prob) = text "PuFail:" <> ppr prob -pprPur (PuOK {}) = text "PuOK" - -okCheckRefl :: TcType -> TcM (PuResult a Reduction) -okCheckRefl ty = return (PuOK emptyBag (mkReflRedn Nominal ty)) - -failCheckWith :: CheckTyEqResult -> TcM (PuResult a b) -failCheckWith p = return (PuFail p) - -mapCheck :: (x -> TcM (PuResult a Reduction)) - -> [x] - -> TcM (PuResult a Reductions) -mapCheck f xs - = do { (ress :: [PuResult a Reduction]) <- mapM f xs - ; return (unzipRedns <$> sequenceA ress) } - -- sequenceA :: [PuResult a Reduction] -> PuResult a [Reduction] - -- unzipRedns :: [Reduction] -> Reductions - ------------------------------ --- | Options describing how to deal with a type equality --- in the pure unifier. See 'checkTyEqRhs' -data TyEqFlags a - = TEF { tef_foralls :: Bool -- Allow foralls - , tef_lhs :: CanEqLHS -- LHS of the constraint - , tef_unifying :: AreUnifying -- Always NotUnifying if tef_lhs is TyFamLHS - , tef_fam_app :: TyEqFamApp a - , tef_occurs :: CheckTyEqProblem } -- Soluble or insoluble occurs check - --- | What to do when encountering a type-family application while processing --- a type equality in the pure unifier. --- --- See Note [Family applications in canonical constraints] -data TyEqFamApp a - = TEFA_Fail -- Always fail - | TEFA_Recurse -- Just recurse - | TEFA_Break (FamAppBreaker a) -- Recurse, but replace with cycle breaker if fails, - -- using the FamAppBreaker - -data AreUnifying - = Unifying - MetaInfo -- MetaInfo of the LHS tyvar (which is a meta-tyvar) - TcLevel -- Level of the LHS tyvar - LevelCheck - - | NotUnifying -- Not attempting to unify - -data LevelCheck - = LC_None -- Level check not needed: we should never encounter - -- a tyvar at deeper level than the LHS - - | LC_Check -- Do a level check between the LHS tyvar and the occurrence tyvar - -- Fail if the level check fails - - | LC_Promote -- Do a level check between the LHS tyvar and the occurrence tyvar - -- If the level check fails, and the occurrence is a unification - -- variable, promote it - -instance Outputable (TyEqFlags a) where - ppr (TEF { .. }) = text "TEF" <> braces ( - vcat [ text "tef_foralls =" <+> ppr tef_foralls - , text "tef_lhs =" <+> ppr tef_lhs - , text "tef_unifying =" <+> ppr tef_unifying - , text "tef_fam_app =" <+> ppr tef_fam_app - , text "tef_occurs =" <+> ppr tef_occurs ]) - -instance Outputable (TyEqFamApp a) where - ppr TEFA_Fail = text "TEFA_Fail" - ppr TEFA_Recurse = text "TEFA_Fail" - ppr (TEFA_Break {}) = text "TEFA_Break" - -instance Outputable AreUnifying where - ppr NotUnifying = text "NotUnifying" - ppr (Unifying mi lvl lc) = text "Unifying" <+> - braces (ppr mi <> comma <+> ppr lvl <> comma <+> ppr lc) - -instance Outputable LevelCheck where - ppr LC_None = text "LC_None" - ppr LC_Check = text "LC_Check" - ppr LC_Promote = text "LC_Promote" - -famAppArgFlags :: TyEqFlags a -> TyEqFlags a --- Adjust the flags when going undter a type family --- Only the outer family application gets the loop-breaker treatment --- Ditto tyvar promotion. E.g. --- [W] alpha[2] ~ Maybe (F beta[3]) --- Do not promote beta[3]; instead promote (F beta[3]) -famAppArgFlags flags@(TEF { tef_unifying = unifying }) - = flags { tef_fam_app = TEFA_Recurse - , tef_unifying = zap_promotion unifying - , tef_occurs = cteSolubleOccurs } - -- tef_occurs: under a type family, an occurs check is not definitely-insoluble - where - zap_promotion (Unifying info lvl LC_Promote) = 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 flags ty - = case ty of - LitTy {} -> okCheckRefl ty - TyConApp tc tys -> checkTyConApp flags ty tc tys - TyVarTy tv -> checkTyVar flags tv - -- Don't worry about foralls inside the kind; see Note [Checking for foralls] - -- Nor can we expand synonyms; see Note [Occurrence checking: look inside kinds] - -- in GHC.Core.FVs - - FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r} - | isInvisibleFunArg af -- e.g. Num a => blah - , not (tef_foralls flags) - -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F) - | otherwise - -> do { w_res <- checkTyEqRhs flags w - ; a_res <- checkTyEqRhs flags a - ; r_res <- checkTyEqRhs flags r - ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) } - - AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun - ; arg_res <- checkTyEqRhs flags arg - ; return (mkAppRedn <$> fun_res <*> arg_res) } - - CastTy ty co -> do { ty_res <- checkTyEqRhs flags ty - ; co_res <- checkCo flags co - ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) } - - CoercionTy co -> do { co_res <- checkCo flags co - ; return (mkReflCoRedn Nominal <$> co_res) } - - ForAllTy {} - | tef_foralls flags -> okCheckRefl ty - | otherwise -> failCheckWith impredicativeProblem -- Not allowed (TyEq:F) - - -------------------- -checkCo :: TyEqFlags a -> Coercion -> TcM (PuResult a Coercion) --- See Note [checkCo] -checkCo (TEF { tef_lhs = TyFamLHS {} }) co - = return (pure co) - -checkCo (TEF { tef_lhs = TyVarLHS lhs_tv - , tef_unifying = unifying - , tef_occurs = occ_prob }) co - -- Check for coercion holes, if unifying - -- See (COERCION-HOLE) in Note [Unification preconditions] - | hasCoercionHoleCo co - = failCheckWith (cteProblem cteCoercionHole) - - -- Occurs check (can promote) - | Unifying _ lhs_tv_lvl LC_Promote <- unifying - = do { reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfCo co) - ; if cterHasNoProblem reason - then return (pure co) - else failCheckWith reason } - - -- Occurs check (no promotion) - | lhs_tv `elemVarSet` tyCoVarsOfCo co - = failCheckWith (cteProblem occ_prob) - - | otherwise - = return (pure co) - -{- Note [checkCo] -~~~~~~~~~~~~~~~~~ -We don't often care about the contents of coercions, so checking -coercions before making an equality constraint may be surprising. -But there are several cases we need to be wary of: - -(1) When we're unifying a variable, we must make sure that the variable - appears nowhere on the RHS -- even in a coercion. Otherwise, we'll - create a loop. - -(2) We must still make sure that no variable in a coercion is at too - high a level. But, when unifying, we can promote any variables we encounter. - -(3) We do not unify variables with a type with a free coercion hole. - See (COERCION-HOLE) in Note [Unification preconditions]. - - -Note [Promotion and level-checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -"Promotion" happens when we have this: - - [W] w1: alpha[2] ~ Maybe beta[4] - -Here we must NOT unify alpha := Maybe beta, because beta may turn out -to stand for a type involving some inner skolem. Yikes! -Skolem-escape. So instead we /promote/ beta, like this: - - beta[4] := beta'[2] - [W] w1: alpha[2] ~ Maybe beta'[2] - -Now we can unify alpha := Maybe beta', which might unlock other -constraints. But if some other constraint wants to unify beta with a -nested skolem, it'll get stuck with a skolem-escape error. - -Now consider `w2` where a type family is involved (#22194): - - [W] w2: alpha[2] ~ Maybe (F gamma beta[4]) - -In `w2`, it may or may not be the case that `beta` is level 2; suppose -we later discover gamma := Int, and type instance F Int _ = Int. -So, instead, we promote the entire funcion call: - - [W] w2': alpha[2] ~ Maybe gamma[2] - [W] w3: gamma[2] ~ F gamma beta[4] - -Now we can unify alpha := Maybe gamma, which is a Good Thng. - -Wrinkle (W1) - -There is an important wrinkle: /all this only applies when unifying/. -For example, suppose we have - [G] a[2] ~ Maybe b[4] -where 'a' is a skolem. This Given might arise from a GADT match, and -we can absolutely use it to rewrite locally. In fact we must do so: -that is how we exploit local knowledge about the outer skolem a[2]. -This applies equally for a Wanted [W] a[2] ~ Maybe b[4]. Using it for -local rewriting is fine. (It's not clear to me that it is /useful/, -but it's fine anyway.) - -So we only do the level-check in checkTyVar when /unifying/ not for -skolems (or untouchable unification variables). - -Note [Family applications in canonical constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A constraint with a type family application in the RHS needs special care. - -* First, occurs checks. If we have - [G] a ~ Maybe (F (Maybe a)) - [W] alpha ~ Maybe (F (Maybe alpha)) - it looks as if we have an occurs check. But go read - Note [Type equality cycles] in GHC.Tc.Solver.Equality - - The same considerations apply when the LHS is a type family: - [G] G a ~ Maybe (F (Maybe (G a))) - [W] G alpha ~ Maybe (F (Maybe (G alpha))) - -* Second, promotion. If we have (#22194) - [W] alpha[2] ~ Maybe (F beta[4]) - it is wrong to promote beta. Instead we want to split to - [W] alpha[2] ~ Maybe gamma[2] - [W] gamma[2] ~ F beta[4] - See Note [Promotion and level-checking] above. - -* Third, concrete type variables. If we have - [W] alpha[conc] ~ Maybe (F tys) - we want to add an extra variable thus: - [W] alpha[conc] ~ Maybe gamma[conc] - [W] gamma[conc] ~ F tys - Now we can unify alpha, and that might unlock something else. - -In all these cases we want to create a fresh type variable, and -emit a new equality connecting it to the type family application. - -The `tef_fam_app` field of `TypeEqFlags` says what to do at a type -family application in the RHS of the constraint. `TEFA_Fail` and -`TEFA_Recurse` are straightforward. `TEFA_Break` is the clever -one. As you can see in `checkFamApp`, it - * Checks the arguments, but using `famAppArgFlags` to record that - we are now "under" a type-family application. It `tef_fam_app` to - `TEFA_Recurse`. - * If any of the arguments fail (level-check error, occurs check) - use the `FamAppBreaker` to create the extra binding. - -Note that this always cycle-breaks the /outermost/ family application. -If we have [W] alpha ~ Maybe (F (G alpha)) -* We'll use checkFamApp on `(F (G alpha))` -* It will recurse into `(G alpha)` with TEFA_Recurse, but not cycle-break it -* The occurs check will fire when we hit `alpha` -* `checkFamApp` on `(F (G alpha))` will see the failure and invoke - the `FamAppBreaker`. --} - -------------------- -checkTyConApp :: TyEqFlags a - -> TcType -> TyCon -> [TcType] - -> TcM (PuResult a Reduction) -checkTyConApp flags@(TEF { tef_unifying = unifying, tef_foralls = foralls_ok }) - tc_app tc tys - | isTypeFamilyTyCon tc - , let arity = tyConArity tc - = if tys `lengthIs` arity - then checkFamApp flags tc_app tc tys -- Common case - else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys - fun_app = mkTyConApp tc fun_args - ; fun_res <- checkFamApp flags fun_app tc fun_args - ; extra_res <- mapCheck (checkTyEqRhs flags) extra_args - ; traceTc "Over-sat" (ppr tc <+> ppr tys $$ ppr arity $$ pprPur fun_res $$ pprPur extra_res) - ; return (mkAppRedns <$> fun_res <*> extra_res) } - - | Just ty' <- rewriterView tc_app - -- e.g. S a where type S a = F [a] - -- or type S a = Int - -- See Note [Forgetful synonyms in checkTyConApp] - = checkTyEqRhs flags ty' - - | not (isTauTyCon tc || foralls_ok) - = failCheckWith impredicativeProblem - - | Unifying info _ _ <- unifying - , isConcreteInfo info - , not (isConcreteTyCon tc) - = failCheckWith (cteProblem cteConcrete) - - | otherwise -- Recurse on arguments - = recurseIntoTyConApp flags tc tys - -recurseIntoTyConApp :: TyEqFlags a -> TyCon -> [TcType] -> TcM (PuResult a Reduction) -recurseIntoTyConApp flags tc tys - = do { tys_res <- mapCheck (checkTyEqRhs flags) tys - ; return (mkTyConAppRedn Nominal tc <$> tys_res) } - -------------------- -checkFamApp :: TyEqFlags a - -> TcType -> TyCon -> [TcType] -- Saturated family application - -> TcM (PuResult a Reduction) --- See Note [Family applications in canonical constraints] -checkFamApp flags@(TEF { tef_unifying = unifying, tef_occurs = occ_prob - , tef_fam_app = fam_app_flag, tef_lhs = lhs }) - fam_app tc tys - = case fam_app_flag of - TEFA_Fail -> failCheckWith (cteProblem cteTypeFamily) - - _ | TyFamLHS lhs_tc lhs_tys <- lhs - , tcEqTyConApps lhs_tc lhs_tys tc tys -- F ty ~ ...(F ty)... - -> case fam_app_flag of - TEFA_Recurse -> failCheckWith (cteProblem occ_prob) - TEFA_Break breaker -> breaker fam_app - - _ | Unifying lhs_info _ _ <- unifying - , isConcreteInfo lhs_info - -> case fam_app_flag of - TEFA_Recurse -> failCheckWith (cteProblem cteConcrete) - TEFA_Break breaker -> breaker fam_app - - TEFA_Recurse - -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys - ; traceTc "under" (ppr tc $$ pprPur tys_res $$ ppr flags) - ; return (mkTyConAppRedn Nominal tc <$> tys_res) } - - TEFA_Break breaker -- Recurse; and break if there is a problem - -> do { tys_res <- mapCheck (checkTyEqRhs arg_flags) tys - ; case tys_res of - PuOK cts redns -> return (PuOK cts (mkTyConAppRedn Nominal tc redns)) - PuFail {} -> breaker fam_app } - where - arg_flags = famAppArgFlags flags - -------------------- -checkTyVar :: forall a. TyEqFlags a -> TcTyVar -> TcM (PuResult a Reduction) -checkTyVar (TEF { tef_lhs = lhs, tef_unifying = unifying, tef_occurs = occ_prob }) occ_tv - = case lhs of - TyFamLHS {} -> success -- Nothing to do if the LHS is a type-family - TyVarLHS lhs_tv -> check_tv unifying lhs_tv - where - lvl_occ = tcTyVarLevel occ_tv - success = okCheckRefl (mkTyVarTy occ_tv) - - --------------------- - check_tv NotUnifying lhs_tv - = simple_occurs_check lhs_tv - -- We need an occurs-check here, but no level check - -- See Note [Promotion and level-checking] wrinkle (W1) - - check_tv (Unifying info lvl prom) lhs_tv - = do { mb_done <- isFilledMetaTyVar_maybe occ_tv - ; case mb_done of - Just {} -> success - -- Already promoted; job done - -- Example alpha[2] ~ Maybe (beta[4], beta[4]) - -- We promote the first occurrence, and then encounter it - -- a second time; we don't want to re-promote it! - -- Remember, the entire process started with a fully zonked type - - Nothing -> check_unif info lvl prom lhs_tv } - - --------------------- - -- We are in the Unifying branch of AreUnifing - check_unif :: MetaInfo -> TcLevel -> LevelCheck - -> TcTyVar -> TcM (PuResult a Reduction) - check_unif lhs_tv_info lhs_tv_lvl prom lhs_tv - | isConcreteInfo lhs_tv_info - , not (isConcreteTyVar occ_tv) - = if can_make_concrete occ_tv - then promote lhs_tv lhs_tv_info lhs_tv_lvl - else failCheckWith (cteProblem cteConcrete) - - | lvl_occ `strictlyDeeperThan` lhs_tv_lvl - = case prom of - LC_None -> pprPanic "check_unif" (ppr lhs_tv $$ ppr occ_tv) - LC_Check -> failCheckWith (cteProblem cteSkolemEscape) - LC_Promote - | isSkolemTyVar occ_tv -> failCheckWith (cteProblem cteSkolemEscape) - | otherwise -> promote lhs_tv lhs_tv_info lhs_tv_lvl - - | otherwise - = simple_occurs_check lhs_tv - - --------------------- - simple_occurs_check lhs_tv - | lhs_tv == occ_tv || check_kind (tyVarKind occ_tv) - = failCheckWith (cteProblem occ_prob) - | otherwise - = success - where - (check_kind, _) = mkOccFolders lhs_tv - - --------------------- - can_make_concrete occ_tv = case tcTyVarDetails occ_tv of - MetaTv { mtv_info = info } -> case info of - ConcreteTv {} -> True - TauTv {} -> True - _ -> False - _ -> False -- Don't attempt to make other type variables concrete - -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv). - - --------------------- - -- occ_tv is definitely a MetaTyVar - promote lhs_tv lhs_tv_info lhs_tv_lvl - | MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv - = do { let new_info | isConcreteInfo lhs_tv_info = lhs_tv_info - | otherwise = info_occ - new_lvl = lhs_tv_lvl `minTcLevel` lvl_occ - -- c[conc,3] ~ p[tau,2]: want to clone p:=p'[conc,2] - -- c[tau,2] ~ p[tau,3]: want to clone p:=p'[tau,2] - - -- Check the kind of occ_tv - ; reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfType (tyVarKind occ_tv)) - - ; if cterHasNoProblem reason -- Successfully promoted - then do { new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv - ; okCheckRefl new_tv_ty } - else failCheckWith reason } - - | otherwise = pprPanic "promote" (ppr occ_tv) - -------------------------- -checkPromoteFreeVars :: CheckTyEqProblem -- What occurs check problem to report - -> TcTyVar -> TcLevel - -> TyCoVarSet -> TcM CheckTyEqResult --- Check this set of TyCoVars for --- (a) occurs check --- (b) promote if necessary, or report skolem escape -checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl vs - = do { oks <- mapM do_one (nonDetEltsUniqSet vs) - ; return (mconcat oks) } - where - do_one :: TyCoVar -> TcM CheckTyEqResult - do_one v | isCoVar v = return cteOK - | lhs_tv == v = return (cteProblem occ_prob) - | no_promotion = return cteOK - | not (isMetaTyVar v) = return (cteProblem cteSkolemEscape) - | otherwise = promote_one v - where - no_promotion = not (tcTyVarLevel v `strictlyDeeperThan` lhs_tv_lvl) - - -- isCoVar case: coercion variables are not an escape risk - -- If an implication binds a coercion variable, it'll have equalities, - -- so the "intervening given equalities" test above will catch it - -- Coercion holes get filled with coercions, so again no problem. - - promote_one tv = do { _ <- promote_meta_tyvar TauTv lhs_tv_lvl tv - ; return cteOK } - -promote_meta_tyvar :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcType -promote_meta_tyvar info dest_lvl occ_tv - = do { -- Check whether occ_tv is already unified. The rhs-type - -- started zonked, but we may have promoted one of its type - -- variables, and we then encounter it for the second time. - -- But if so, it'll definitely be another already-checked TyVar - mb_filled <- isFilledMetaTyVar_maybe occ_tv - ; case mb_filled of { - Just ty -> return ty ; - Nothing -> - - -- OK, not done already, so clone/promote it - do { new_tv <- cloneMetaTyVarWithInfo info dest_lvl occ_tv - ; liftZonkM $ writeMetaTyVar occ_tv (mkTyVarTy new_tv) - ; traceTc "promoteTyVar" (ppr occ_tv <+> text "-->" <+> ppr new_tv) - ; return (mkTyVarTy new_tv) } } } - - - -------------------------- -touchabilityAndShapeTest :: TcLevel -> TcTyVar -> TcType -> Bool --- This is the key test for untouchability: --- See Note [Unification preconditions] in GHC.Tc.Utils.Unify --- and Note [Solve by unification] in GHC.Tc.Solver.Equality --- True <=> touchability and shape are OK -touchabilityAndShapeTest given_eq_lvl tv rhs - | MetaTv { mtv_info = info, mtv_tclvl = tv_lvl } <- tcTyVarDetails tv - , checkTopShape info rhs - = tv_lvl `deeperThanOrSame` given_eq_lvl - | otherwise - = False - -------------------------- --- | checkTopShape checks (TYVAR-TV) --- Note [Unification preconditions]; returns True if these conditions --- are satisfied. But see the Note for other preconditions, too. -checkTopShape :: MetaInfo -> TcType -> Bool -checkTopShape info xi - = case info of - TyVarTv -> - case getTyVar_maybe xi of -- Looks through type synonyms - Nothing -> False - Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle - SkolemTv {} -> True - RuntimeUnk -> True - MetaTv { mtv_info = TyVarTv } -> True - _ -> False - CycleBreakerTv -> False -- We never unify these - _ -> True +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +-- | Type subsumption and unification +module GHC.Tc.Utils.Unify ( + -- Full-blown subsumption + tcWrapResult, tcWrapResultO, tcWrapResultMono, + tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, + addSubTypeCtxt, + tcSubTypeAmbiguity, tcSubMult, + checkConstraints, checkTvConstraints, + buildImplicationFor, buildTvImplication, emitResidualTvConstraint, + + -- Skolemisation + DeepSubsumptionFlag(..), getDeepSubsumptionFlag, isRhoTyDS, + tcSkolemise, tcSkolemiseCompleteSig, tcSkolemiseExpectedType, + dsInstantiate, + + -- Various unifications + unifyType, unifyKind, unifyInvisibleType, + unifyExprType, unifyTypeAndEmit, promoteTcType, + swapOverTyVars, touchabilityTest, checkTopShape, lhsPriority, + UnifyEnv(..), updUEnvLoc, setUEnvRole, + uType, + mightEqualLater, + makeTypeConcrete, + + -------------------------------- + -- Holes + matchExpectedListTy, + matchExpectedTyConApp, + matchExpectedAppTy, + matchExpectedFunTys, + matchExpectedFunKind, + matchActualFunTy, matchActualFunTys, + + checkTyEqRhs, recurseIntoTyConApp, recurseIntoFamTyConApp, + PuResult(..), okCheckRefl, mapCheck, + TyEqFlags(..), + notUnifying_TEFTask, unifyingLHSMetaTyVar_TEFTask, defaulting_TEFTask, + pureTyEqFlags_LHSMetaTyVar, mkTEFA_Break, + + OccursCheck(..), LevelCheck(..), ConcreteCheck(..), + TyEqFamApp(..), FamAppBreaker(..), + checkPromoteFreeVars, + + simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..), + + fillInferResult, fillInferResultNoInst + ) where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Tc.Errors.Types ( ErrCtxtMsg(..) ) +import GHC.Tc.Errors.Ppr ( pprErrCtxtMsg ) +import GHC.Tc.Utils.Concrete +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc( CtLoc, mkKindEqLoc, adjustCtLoc, updateCtLocOrigin, ctLocOrigin ) +import GHC.Tc.Types.Origin +import GHC.Tc.Zonk.TcType +import GHC.Tc.Utils.TcMType qualified as TcM + +import GHC.Tc.Solver.InertSet + +import GHC.Core.Type +import GHC.Core.TyCo.Rep hiding (Refl) +import GHC.Core.TyCo.FVs( isInjectiveInType ) +import GHC.Core.TyCo.Ppr( debugPprType {- pprTyVar -} ) +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Unify +import GHC.Core.Predicate( EqRel(..), mkEqPredRole, mkNomEqPred ) +import GHC.Core.Multiplicity +import GHC.Core.Reduction + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Id( idType ) +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Basic +import GHC.Types.Unique.Set (nonDetEltsUniqSet) + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Driver.DynFlags + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe (firstJusts) + +import Control.Monad +import Data.Functor.Identity (Identity(..)) +import qualified Data.List.NonEmpty as NE +import Data.Monoid as DM ( Any(..) ) +import qualified Data.Semigroup as S ( (<>) ) +import Data.Traversable (for) + +{- ********************************************************************* +* * + matchActualFunTys +* * +********************************************************************* -} + +-- | 'matchActualFunTy' looks for just one function arrow, +-- returning an uninstantiated sigma-type. +-- +-- Invariant: the returned argument type has a syntactically fixed +-- RuntimeRep in the sense of Note [Fixed RuntimeRep] +-- in GHC.Tc.Utils.Concrete. +-- +-- See Note [Return arguments with a fixed RuntimeRep]. +matchActualFunTy + :: ExpectedFunTyOrigin + -- ^ See Note [Herald for matchExpectedFunTys] + -> Maybe TypedThing + -- ^ The thing with type TcSigmaType + -> (Arity, TcType) + -- ^ Total number of value args in the call, and + -- the original function type + -- (Both are used only for error messages) + -> TcRhoType + -- ^ Type to analyse: a TcRhoType + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) +-- This function takes in a type to analyse (a RhoType) and returns +-- an argument type and a result type (splitting apart a function arrow). +-- The returned argument type is a SigmaType with a fixed RuntimeRep; +-- as explained in Note [Return arguments with a fixed RuntimeRep]. +-- +-- See Note [matchActualFunTy error handling] for the first three arguments + +-- If (wrap, arg_ty, res_ty) = matchActualFunTy ... fun_ty +-- then wrap :: fun_ty ~> (arg_ty -> res_ty) +-- and NB: res_ty is an (uninstantiated) SigmaType + +matchActualFunTy herald mb_thing err_info fun_ty + = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $ + go fun_ty + where + -- Does not allocate unnecessary meta variables: if the input already is + -- a function, we just take it apart. Not only is this efficient, + -- it's important for higher rank: the argument might be of form + -- (forall a. ty) -> other + -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd + -- hide the forall inside a meta-variable + go :: TcRhoType -- The type we're processing, perhaps after + -- expanding type synonyms + -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) + go ty | Just ty' <- coreView ty = go ty' + + go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ + do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty + ; return (idHsWrapper, Scaled w arg_ty, res_ty) } + + go ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> go ty' + Flexi -> defer ty } + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + go ty = addErrCtxtM (mk_ctxt ty) (defer ty) + + ------------ + defer fun_ty + = do { arg_ty <- new_check_arg_ty herald 1 + ; res_ty <- newOpenFlexiTyVarTy + ; let unif_fun_ty = mkScaledFunTys [arg_ty] res_ty + ; co <- unifyType mb_thing fun_ty unif_fun_ty + ; return (mkWpCastN co, arg_ty, res_ty) } + + ------------ + mk_ctxt :: TcType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) + mk_ctxt _res_ty = mkFunTysMsg herald err_info + +{- Note [matchActualFunTy error handling] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchActualFunTy is made much more complicated by the +desire to produce good error messages. Consider the application + f @Int x y +In GHC.Tc.Gen.Head.tcInstFun we instantiate the function type, one +argument at a time. It must instantiate any type/dictionary args, +before looking for an arrow type. + +But if it doesn't find an arrow type, it wants to generate a message +like "f is applied to two arguments but its type only has one". +To do that, it needs to know about the args that tcArgs has already +munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; +and hence also the accumulating so_far arg to 'go'. + +This allows us (in mk_ctxt) to construct f's /instantiated/ type, +with just the values-arg arrows, which is what we really want +in the error message. + +Ugh! +-} + +-- | Like 'matchExpectedFunTys', but used when you have an "actual" type, +-- for example in function application. +-- +-- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchActualFunTys :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys] + -> CtOrigin + -> Arity + -> TcSigmaType + -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType) +-- If matchActualFunTys n ty = (wrap, [t1,..,tn], res_ty) +-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty) +-- and res_ty is a RhoType +-- NB: the returned type is top-instantiated; it's a RhoType +matchActualFunTys herald ct_orig n_val_args_wanted top_ty + = go n_val_args_wanted [] top_ty + where + go n so_far fun_ty + | not (isRhoTy fun_ty) + = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty + ; (wrap2, arg_tys, res_ty) <- go n so_far rho + ; return (wrap2 <.> wrap1, arg_tys, res_ty) } + + go 0 _ fun_ty = return (idHsWrapper, [], fun_ty) + + go n so_far fun_ty + = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTy + herald Nothing + (n_val_args_wanted, top_ty) + fun_ty + ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1 + ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty + -- NB: arg_ty1 comes from matchActualFunTy, so it has + -- a syntactically fixed RuntimeRep as needed to call mkWpFun. + ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) } + +{- +************************************************************************ +* * + Skolemisation and matchExpectedFunTys +* * +************************************************************************ + +Note [Skolemisation overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose f :: (forall a. a->a) -> blah, and we have the application (f e) +Then we want to typecheck `e` pushing in the type `forall a. a->a`. But we +need to be careful: + +* Roughly speaking, in (tcPolyExpr e (forall a b. rho)), we skolemise `a` and `b`, + and then call (tcExpr e rho) + +* But not quite! We must be careful if `e` is a type lambda (\ @p @q -> blah). + Then we want to line up the skolemised variables `a`,`b` + with `p`,`q`, so we can't just call (tcExpr (\ @p @q -> blah) rho) + +* A very similar situation arises with + (\ @p @q -> blah) :: forall a b. rho + Again, we must line up `p`, `q` with the skolemised `a` and `b`. + +* Another similar situation arises with + g :: forall a b. rho + g @p @q x y = .... + Here again when skolemising `a` and `b` we must be careful to match them up + with `p` and `q`. + +OK, so how exactly do we check @p binders in lambdas? First note that we only +we only attempt to deal with @p binders when /checking/. We don't do inference for +(\ @a -> blah), not yet anyway. + +For checking, there are two cases to consider: + * Function LHS, where the function has a type signature + f :: forall a. a -> forall b. [b] -> blah + f @p x @q y = ... + + * Lambda \ @p x @q y -> ... + \cases { @p x @q y -> ... } + (\case p behaves like \cases { p -> ... }, and p is always a term pattern.) + +Both ultimately handled by matchExpectedFunTys. + +* Function LHS case is handled by `GHC.Tc.Gen.Bind.tcPolyCheck`: + * It calls `tcSkolemiseCompleteSig` + * Passes the skolemised variables into `tcFunBindMatches` + * Which uses `matchExpectedFunTys` to decompose the function type to + match the arguments + * And then passes the (skolemised-variables ++ arg tys) on to `tcMatches` + +* For the Lambda case there are two sub-cases: + * An expression with a type signature: (\ @a x y -> blah) :: hs_ty + This is handled by `GHC.Tc.Gen.Head.tcExprWithSig`, which kind-checks + the signature and hands off to `tcExprPolyCheck` via `tcPolyLExprSig`. + Note that the foralls at the top of hs_ty scope over the expression. + + * A higher order call: h e, where h :: poly_ty -> blah + This is handlded by `GHC.Tc.Gen.Expr.tcPolyExpr`, which (in the + checking case) again hands off to `tcExprPolyCheck`. Here there is + no type-variable scoping to worry about. + + So both sub-cases end up in `GHC.Tc.Gen.Expr.tcPolyExprCheck` + * This skolemises the /top-level/ invisible binders, but remembers + the binders as [ExpPatType] + * Then it looks for a lambda, and if so, calls `tcLambdaMatches` passing in + the skolemised binders so they can be matched up with the lambda binders. + * Otherwise it does deep-skolemisation if DeepSubsumption is on, + and then calls tcExpr to typecheck `e` + + The outer skolemisation in tcPolyExprCheck is done using + * tcSkolemiseCompleteSig when there is a user-written signature + * tcSkolemiseGeneral when the polytype just comes from the context e.g. (f e) + The former just calls the latter, so the two cases differ only slightly: + * Both do shallow skolemisation + * Both go via checkConstraints, which uses implicationNeeded to decide whether + to build an implication constraint even if there /are/ no skolems. + See Note [When to build an implication] below. + + The difference between the two cases is that `tcSkolemiseCompleteSig` + also brings the outer type variables into scope. It would do no + harm to do so in both cases, but I found that (to my surprise) doing + so caused a non-trivial (1%-ish) perf hit on the compiler. + +* `tcFunBindMatches` and `tcLambdaMatches` both use `matchExpectedFunTys`, which + ensures that any trailing invisible binders are skolemised; and does so deeply + if DeepSubsumption is on. + + This corresponds to the plan: "skolemise at the '=' of a function binding or + at the '->' of a lambda binding". (See #17594 and "Plan B2".) + +Some wrinkles + +(SK1) tcSkolemiseGeneral and tcSkolemiseCompleteSig make fresh type variables + See Note [Instantiate sig with fresh variables] + +(SK2) All skolemisation (even without DeepSubsumption) builds just one implication + constraint for a nested forall like: + forall a. Eq a => forall b. Ord b => blah + The implication constraint will look like + forall a b. (Eq a, Ord b) => + See the loop in GHC.Tc.Utils.Instantiate.topSkolemise. + and Note [Skolemisation en-bloc] in that module + + +Some examples: + +* f :: forall a b. blah + f @p x = rhs + `tcPolyCheck` calls `tcSkolemiseCompleteSig` to skolemise the signature, and + then calls `tcFunBindMatches` passing in [a_sk, b_sk], the skolemsed + variables. The latter ultimately calls `tcMatches`, and thence `tcMatchPats`. + The latter matches up the `a_sk` with `@p`, and discards the `b_sk`. + +* f :: forall (a::Type) (b::a). blah + f @(p::b) x = rhs + `tcSkolemiseCompleteSig` brings `a` and `b` into scope, bound to `a_sk` and `b_sk` resp. + When `tcMatchPats` typechecks the pattern `@(p::b)` it'll find that `b` is in + scope (as a result of tcSkolemiseCompleteSig) which is a bit strange. But + it'll then unify the kinds `Type ~ b`, which will fail as it should. + +* f :: Int -> forall (a::Type) (b::a). blah + f x @p = rhs + `matchExpectedFunTys` does shallow skolemisation eagerly, so we'll skolemise the + forall a b. Then `tcMatchPats` will bind [p :-> a_sk], and discard `b_sk`. + Discarding the `b_sk` means that + f x @p = \ @q -> blah + or f x @p = let .. in \ @q -> blah + will both be rejected: this is Plan B2: skolemise at the "=". + +* Suppose DeepSubsumption is on + f :: forall a. a -> forall b. b -> b -> forall z. z + f @p x @q y = rhs + The `tcSkolemiseCompleteSig` uses shallow skolemisation, so it only skolemises + and brings into scope [a :-> a_sk]. Then `matchExpectedFunTys` skolemises the + forall b, because it needs to expose two value arguments. Finally + `matchExpectedFunTys` concludes with deeply skolemising the remaining type. + + So we end up with `[p :-> a_sk, q :-> b_sk]`. Notice that we must not + deeply-skolemise /first/ or we'd get the tyvars [a_sk, b_sk, c_sk] which would + not line up with the patterns [@p, x, @q, y] +-} + +tcSkolemiseGeneral + :: DeepSubsumptionFlag + -> UserTypeCtxt + -> TcType -> TcType -- top_ty and expected_ty + -- Here, top_ty is the type we started to skolemise; used only in SigSkol + -- - expected_ty is the type we are actually skolemising + -- matchExpectedFunTys walks down the type, skolemising as it goes, + -- keeping the same top_ty, but successively smaller expected_tys + -> ([(Name, TcInvisTVBinder)] -> TcType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemiseGeneral ds_flag ctxt top_ty expected_ty thing_inside + | isRhoTyDS ds_flag expected_ty + -- Fast path for a very very common case: no skolemisation to do + -- But still call checkConstraints in case we need an implication regardless + = do { let sig_skol = SigSkol ctxt top_ty [] + ; (ev_binds, result) <- checkConstraints sig_skol [] [] $ + thing_inside [] expected_ty + ; return (mkWpLet ev_binds, result) } + + | otherwise + = do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { (wrap, tv_prs, given, rho_ty) <- case ds_flag of + Deep -> deeplySkolemise skol_info expected_ty + Shallow -> topSkolemise skol_info expected_ty + ; let sig_skol = SigSkol ctxt top_ty (map (fmap binderVar) tv_prs) + ; skol_info <- mkSkolemInfo sig_skol } + + ; let skol_tvs = map (binderVar . snd) tv_prs + ; traceTc "tcSkolemiseGeneral" (pprUserTypeCtxt ctxt <+> ppr skol_tvs <+> ppr given) + ; (ev_binds, result) <- checkConstraints sig_skol skol_tvs given $ + thing_inside tv_prs rho_ty + + ; return (wrap <.> mkWpLet ev_binds, result) } + -- The ev_binds returned by checkConstraints is very + -- often empty, in which case mkWpLet is a no-op + +tcSkolemiseCompleteSig :: TcCompleteSig + -> ([ExpPatType] -> TcRhoType -> TcM result) + -> TcM (HsWrapper, result) +-- ^ The wrapper has type: spec_ty ~> expected_ty +-- See Note [Skolemisation] for the differences between +-- tcSkolemiseCompleteSig and tcTopSkolemise + +tcSkolemiseCompleteSig (CSig { sig_bndr = poly_id, sig_ctxt = ctxt, sig_loc = loc }) + thing_inside + = do { cur_loc <- getSrcSpanM + ; let poly_ty = idType poly_id + ; setSrcSpan loc $ -- Sets the location for the implication constraint + tcSkolemiseGeneral Shallow ctxt poly_ty poly_ty $ \tv_prs rho_ty -> + setSrcSpan cur_loc $ -- Revert to the original location + tcExtendNameTyVarEnv (map (fmap binderVar) tv_prs) $ + thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty } + +tcSkolemiseExpectedType :: TcSigmaType + -> ([ExpPatType] -> TcRhoType -> TcM result) + -> TcM (HsWrapper, result) +-- Just like tcSkolemiseCompleteSig, except that we don't have a user-written +-- type signature, we only have a type comimg from the context. +-- Eg. f :: (forall a. blah) -> blah +-- In the call (f e) we will call tcSkolemiseExpectedType on (forall a.blah) +-- before typececking `e` +tcSkolemiseExpectedType exp_ty thing_inside + = tcSkolemiseGeneral Shallow GenSigCtxt exp_ty exp_ty $ \tv_prs rho_ty -> + thing_inside (map (mkInvisExpPatType . snd) tv_prs) rho_ty + +tcSkolemise :: DeepSubsumptionFlag -> UserTypeCtxt -> TcSigmaType + -> (TcRhoType -> TcM result) + -> TcM (HsWrapper, result) +tcSkolemise ds_flag ctxt expected_ty thing_inside + = tcSkolemiseGeneral ds_flag ctxt expected_ty expected_ty $ \_ rho_ty -> + thing_inside rho_ty + +checkConstraints :: SkolemInfoAnon + -> [TcTyVar] -- Skolems + -> [EvVar] -- Given + -> TcM result + -> TcM (TcEvBinds, result) +-- checkConstraints is careful to build an implication even if +-- `skol_tvs` and `given` are both empty, under certain circumstances +-- See Note [When to build an implication] +checkConstraints skol_info skol_tvs given thing_inside + = do { implication_needed <- implicationNeeded skol_info skol_tvs given + + ; if implication_needed + then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted + ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs) + ; emitImplications implics + ; return (ev_binds, result) } + + else -- Fast path. We check every function argument with tcCheckPolyExpr, + -- which uses tcTopSkolemise and hence checkConstraints. + -- So this fast path is well-exercised + do { res <- thing_inside + ; return (emptyTcEvBinds, res) } } + +checkTvConstraints :: SkolemInfo + -> [TcTyVar] -- Skolem tyvars + -> TcM result + -> TcM result + +checkTvConstraints skol_info skol_tvs thing_inside + = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside + ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted + ; return result } + +emitResidualTvConstraint :: SkolemInfo -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM () +emitResidualTvConstraint skol_info skol_tvs tclvl wanted + | not (isEmptyWC wanted) || + checkTelescopeSkol skol_info_anon + = -- checkTelescopeSkol: in this case, /always/ emit this implication + -- even if 'wanted' is empty. We need the implication so that we check + -- for a bad telescope. See Note [Skolem escape and forall-types] in + -- GHC.Tc.Gen.HsType + do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted + ; emitImplication implic } + + | otherwise -- Empty 'wanted', emit nothing + = return () + where + skol_info_anon = getSkolemInfo skol_info + +buildTvImplication :: SkolemInfoAnon -> [TcTyVar] + -> TcLevel -> WantedConstraints -> TcM Implication +buildTvImplication skol_info skol_tvs tclvl wanted + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + do { ev_binds <- newNoTcEvBinds -- Used for equalities only, so all the constraints + -- are solved by filling in coercion holes, not + -- by creating a value-level evidence binding + ; implic <- newImplication + + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given_eqs = NoGivenEqs + , ic_wanted = wanted + , ic_binds = ev_binds + , ic_info = skol_info } + + ; checkImplicationInvariants implic' + ; return implic' } + +implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool +-- See Note [When to build an implication] +implicationNeeded skol_info skol_tvs given + | null skol_tvs + , null given + , not (alwaysBuildImplication skol_info) + = -- Empty skolems and givens + do { tc_lvl <- getTcLevel + ; if not (isTopTcLevel tc_lvl) -- No implication needed if we are + then return False -- already inside an implication + else + do { dflags <- getDynFlags -- If any deferral can happen, + -- we must build an implication + ; return (gopt Opt_DeferTypeErrors dflags || + gopt Opt_DeferTypedHoles dflags || + gopt Opt_DeferOutOfScopeVariables dflags) } } + + | otherwise -- Non-empty skolems or givens + = return True -- Definitely need an implication + +alwaysBuildImplication :: SkolemInfoAnon -> Bool +-- See Note [When to build an implication] +alwaysBuildImplication _ = False + +{- Commmented out for now while I figure out about error messages. + See #14185 + +Caution: we get some duplication of errors if we build more implications. +Because we get one error for each function RHS, even if it's for +the same class constraint. + +alwaysBuildImplication (SigSkol ctxt _ _) + = case ctxt of + FunSigCtxt {} -> True -- RHS of a binding with a signature + _ -> False +alwaysBuildImplication (RuleSkol {}) = True +alwaysBuildImplication (InstSkol {}) = True +alwaysBuildImplication (FamInstSkol {}) = True +alwaysBuildImplication _ = False +-} + +buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar] + -> [EvVar] -> WantedConstraints + -> TcM (Bag Implication, TcEvBinds) +buildImplicationFor tclvl skol_info skol_tvs given wanted + | isEmptyWC wanted && null given + -- Optimisation : if there are no wanteds, and no givens + -- don't generate an implication at all. + -- Reason for the (null given): we don't want to lose + -- the "inaccessible alternative" error check + = return (emptyBag, emptyTcEvBinds) + + | otherwise + = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $ + -- Why allow TyVarTvs? Because implicitly declared kind variables in + -- non-CUSK type declarations are TyVarTvs, and we need to bring them + -- into scope as a skolem in an implication. This is OK, though, + -- because TyVarTvs will always remain tyvars, even after unification. + do { ev_binds_var <- newTcEvBinds + ; implic <- newImplication + ; let implic' = implic { ic_tclvl = tclvl + , ic_skols = skol_tvs + , ic_given = given + , ic_wanted = wanted + , ic_binds = ev_binds_var + , ic_info = skol_info } + ; checkImplicationInvariants implic' + + ; return (unitBag implic', TcEvBinds ev_binds_var) } + +{- Note [When to build an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have some 'skolems' and some 'givens', and we are +considering whether to wrap the constraints in their scope into an +implication. We must /always/ do so if either 'skolems' or 'givens' are +non-empty. But what if both are empty? You might think we could +always drop the implication. Other things being equal, the fewer +implications the better. Less clutter and overhead. But we must +take care: + +* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors, + we'll make a /term-level/ evidence binding for 'g = error "blah"'. + We must have an EvBindsVar those bindings!, otherwise they end up as + top-level unlifted bindings, which are verboten. This only matters + at top level, so we check for that + See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors. + cf #14149 for an example of what goes wrong. + +* This is /necessary/ for top level but may be /desirable/ even for + nested bindings, because if the deferred coercion is bound too far + out it will be reported even if that thunk (say) is not evaluated. + +* If you have + f :: Int; f = f_blah + g :: Bool; g = g_blah + If we don't build an implication for f or g (no tyvars, no givens), + the constraints for f_blah and g_blah are solved together. And that + can yield /very/ confusing error messages, because we can get + [W] C Int b1 -- from f_blah + [W] C Int b2 -- from g_blan + and fundeps can yield [W] b1 ~ b2, even though the two functions have + literally nothing to do with each other. #14185 is an example. + Building an implication keeps them separate. + +Note [Herald for matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'herald' always looks like: + "The equation(s) for 'f' have" + "The abstraction (\x.e) takes" + "The section (+ x) expects" + "The function 'f' is applied to" + +This is used to construct a message of form + + The abstraction `\Just 1 -> ...' takes two arguments + but its type `Maybe a -> a' has only one + + The equation(s) for `f' have two arguments + but its type `Maybe a -> a' has only one + + The section `(f 3)' requires 'f' to take two arguments + but its type `Int -> Int' has only one + + The function 'f' is applied to two arguments + but its type `Int -> Int' has only one + +When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the +picture, we have a choice in deciding whether to count the type applications as +proper arguments: + + The function 'f' is applied to one visible type argument + and two value arguments + but its type `forall a. a -> a` has only one visible type argument + and one value argument + +Or whether to include the type applications as part of the herald itself: + + The expression 'f @Int' is applied to two arguments + but its type `Int -> Int` has only one + +The latter is easier to implement and is arguably easier to understand, so we +choose to implement that option. + +Note [matchExpectedFunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +matchExpectedFunTys checks that a sigma has the form +of an n-ary function. It passes the decomposed type to the +thing_inside, and returns a wrapper to coerce between the two types + +It's used wherever a language construct must have a functional type, +namely: + A lambda expression + A function definition + An operator section + +This function must be written CPS'd because it needs to fill in the +ExpTypes produced for arguments before it can fill in the ExpType +passed in. + +Note [Return arguments with a fixed RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions + + - matchExpectedFunTys, + - matchActualFunTy, + - matchActualFunTys, + +peel off argument types, as explained in Note [matchExpectedFunTys]. +It's important that these functions return argument types that have +a fixed runtime representation, otherwise we would be in violation +of the representation-polymorphism invariants of +Note [Representation polymorphism invariants] in GHC.Core. + +This is why all these functions have an additional invariant, +that the argument types they return all have a syntactically fixed RuntimeRep, +in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + +Example: + + Suppose we have + + type F :: Type -> RuntimeRep + type family F a where { F Int = LiftedRep } + + type Dual :: Type -> Type + type family Dual a where + Dual a = a -> () + + f :: forall (a :: TYPE (F Int)). Dual a + f = \ x -> () + + The body of `f` is a lambda abstraction, so we must be able to split off + one argument type from its type. This is handled by `matchExpectedFunTys` + (see 'GHC.Tc.Gen.Match.tcLambdaMatches'). We end up with desugared Core that + looks like this: + + f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0])) + f = \ @(a :: TYPE (F Int)) -> + (\ (x :: (a |> (TYPE F[0]))) -> ()) + `cast` + (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>))) + + Two important transformations took place: + + 1. We inserted casts around the argument type to ensure that it has + a fixed runtime representation, as required by invariant (I1) from + Note [Representation polymorphism invariants] in GHC.Core. + 2. We inserted a cast around the whole lambda to make everything line up + with the type signature. +-} + +-- | Use this function to split off arguments types when you have an +-- \"expected\" type. +-- +-- This function skolemises at each polytype. +-- +-- Invariant: this function only applies the provided function +-- to a list of argument types which all have a syntactically fixed RuntimeRep +-- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- See Note [Return arguments with a fixed RuntimeRep]. +matchExpectedFunTys :: forall a. + ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys] + -> UserTypeCtxt + -> VisArity + -> ExpSigmaType + -> ([ExpPatType] -> ExpRhoType -> TcM a) + -> TcM (HsWrapper, a) +-- If matchExpectedFunTys n ty = (wrap, _) +-- then wrap : (t1 -> ... -> tn -> ty_r) ~> ty, +-- where [t1, ..., tn], ty_r are passed to the thing_inside +-- +-- Unconditionally concludes by skolemising any trailing invisible +-- binders and, if DeepSubsumption is on, it does so deeply. +-- +-- Postcondition: +-- If exp_ty is Check {}, then [ExpPatType] and ExpRhoType results are all Check{} +-- If exp_ty is Infer {}, then [ExpPatType] and ExpRhoType results are all Infer{} +matchExpectedFunTys herald _ctxt arity (Infer inf_res) thing_inside + = do { arg_tys <- mapM (new_infer_arg_ty herald) [1 .. arity] + ; res_ty <- newInferExpType (ir_inst inf_res) + ; result <- thing_inside (map ExpFunPatTy arg_tys) res_ty + ; arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) arg_tys + ; res_ty <- readExpType res_ty + -- Remarks: + -- 1. use tcMkScaledFunTys rather than mkScaledFunTys, as we might + -- have res_ty :: kappa[tau] for a meta ty-var kappa, in which case + -- mkScaledFunTys would crash. See #26277. + -- 2. tcMkScaledFunTys arg_tys res_ty does not contain any foralls + -- (even nested ones), so no need to instantiate. + ; co <- fillInferResultNoInst (tcMkScaledFunTys arg_tys res_ty) inf_res + ; return (mkWpCastN co, result) } + +matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside + = check arity [] top_ty + where + check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a) + -- `check` is called only in the Check{} case + -- It collects rev_pat_tys in reversed order + -- n_req is the number of /visible/ arguments still needed + + ---------------------------- + -- Skolemise quantifiers, both visible (up to n_req) and invisible + -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App + check n_req rev_pat_tys ty + | isSigmaTy ty -- An invisible quantifier at the top + || (n_req > 0 && isForAllTy ty) -- A visible quantifier at top, and we need it + = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty + ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs) + skol_tvs = binderVars bndrs + ; skol_info <- mkSkolemInfo sig_skol } + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; (ev_binds, (wrap_res, result)) + <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ + check n_req' + (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys) + inner_ty + ; assertPpr (not (null bndrs && null given)) (ppr ty) $ + -- The guard ensures that we made some progress + return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) } + + ---------------------------- + -- Base case: (n_req == 0): no more args + -- The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers + -- If there is deep subsumption, do deep skolemisation now + check n_req rev_pat_tys rho_ty + | n_req == 0 + = do { let pat_tys = reverse rev_pat_tys + ; ds_flag <- getDeepSubsumptionFlag + ; case ds_flag of + Shallow -> do { res <- thing_inside pat_tys (mkCheckExpType rho_ty) + ; return (idHsWrapper, res) } + Deep -> tcSkolemiseGeneral Deep ctx top_ty rho_ty $ \_ rho_ty -> + -- "_" drop the /deeply/-skolemise binders + -- They do not line up with binders in the Match + thing_inside pat_tys (mkCheckExpType rho_ty) } + + ---------------------------- + -- Function types + check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult + , ft_arg = arg_ty, ft_res = res_ty }) + = assert (isVisibleFunArg af) $ + do { let arg_pos = arity - n_req + 1 -- 1 for the first argument etc + ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty + ; (wrap_res, result) <- check (n_req - 1) + (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys) + res_ty + ; let wrap_arg = mkWpCastN arg_co + fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty + ; return (fun_wrap, result) } + + ---------------------------- + -- Type variables + check n_req rev_pat_tys ty@(TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty' -> check n_req rev_pat_tys ty' + Flexi -> defer n_req rev_pat_tys ty } + + ---------------------------- + -- NOW do coreView. We didn't do it before, so that we do not unnecessarily + -- unwrap a synonym in the returned rho_ty + check n_req rev_pat_tys ty + | Just ty' <- coreView ty = check n_req rev_pat_tys ty' + + -- In all other cases we bale out into ordinary unification + -- However unlike the meta-tyvar case, we are sure that the + -- number of arguments doesn't match arity of the original + -- type, so we can add a bit more context to the error message + -- (cf #7869). + -- + -- It is not always an error, because specialized type may have + -- different arity, for example: + -- + -- > f1 = f2 'a' + -- > f2 :: Monad m => m Bool + -- > f2 = undefined + -- + -- But in that case we add specialized type into error context + -- anyway, because it may be useful. See also #9605. + check n_req rev_pat_tys res_ty + = addErrCtxtM (mkFunTysMsg herald (arity, top_ty)) $ + defer n_req rev_pat_tys res_ty + + ------------ + defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a) + defer n_req rev_pat_tys fun_ty + = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity] + ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys + ; res_ty <- newOpenFlexiTyVarTy + ; result <- thing_inside all_pats (mkCheckExpType res_ty) + + ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty + ; return (mkWpCastN co, result) } + +new_infer_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled ExpRhoTypeFRR) +new_infer_arg_ty herald arg_pos -- position for error messages only + = do { mult <- newFlexiTyVarTy multiplicityTy + ; inf_hole <- newInferExpTypeFRR IIF_DeepRho (FRRExpectedFunTy herald arg_pos) + ; return (mkScaled mult inf_hole) } + +new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType) +new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg + = do { mult <- newFlexiTyVarTy multiplicityTy + ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos) + ; return (mkScaled mult arg_ty) } + +mkFunTysMsg :: ExpectedFunTyOrigin + -> (VisArity, TcType) + -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) +-- See Note [Reporting application arity errors] +mkFunTysMsg herald (n_vis_args_in_call, fun_ty) env + = do { (env', fun_ty) <- zonkTidyTcType env fun_ty + + ; let (pi_ty_bndrs, _) = splitPiTys fun_ty + n_fun_args = count isVisiblePiTyBinder pi_ty_bndrs + + ; return (env', FunTysCtxt herald fun_ty n_vis_args_in_call n_fun_args) } + + +{- Note [Reporting application arity errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider f :: Int -> Int -> Int +and the call foo = f 3 4 5 +We'd like to get an error like: + + • Couldn't match expected type ‘t0 -> t’ with actual type ‘Int’ + • The function ‘f’ is applied to three visible arguments, -- What are "visible" arguments? + but its type ‘Int -> Int -> Int’ has only two -- See Note [Visibility and arity] in GHC.Types.Basic + +That is what `mkFunTysMsg` tries to do. But what is the "type of the function". +Most obviously, we can report its full, polymorphic type; that is simple and +explicable. But sometimes a bit odd. Consider + f :: Bool -> t Int Int + foo = f True 5 10 +We get this error: + • Couldn't match type ‘Int’ with ‘t0 -> t’ + Expected: Int -> t0 -> t + Actual: Int -> Int + • The function ‘f’ is applied to three visible arguments, + but its type ‘Bool -> t Int Int’ has only one + +That's not /quite/ right beause we can instantiate `t` to an arrow and get +two arrows (but not three!). With that in mind, one could consider reporting +the /instantiated/ type, and GHC used to do so. But it's more work, and in +some ways more confusing, especially when nested quantifiers are concerned, e.g. + f :: Bool -> forall t. t Int Int + +So we just keep it simple and report the original function type. + + +************************************************************************ +* * + Other matchExpected functions +* * +********************************************************************* -} + +matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType) +-- Special case for lists +matchExpectedListTy exp_ty + = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty + ; return (co, elt_ty) } + +--------------------- +matchExpectedTyConApp :: TyCon -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> * + -> TcRhoType -- orig_ty + -> TcM (TcCoercionN, -- T k1 k2 k3 a b c ~N orig_ty + [TcSigmaType]) -- Element types, k1 k2 k3 a b c + +-- It's used for wired-in tycons, so we call checkWiredInTyCon +-- Precondition: never called with FunTyCon +-- Precondition: input type :: * +-- Postcondition: (T k1 k2 k3 a b c) is well-kinded + +matchExpectedTyConApp tc orig_ty + = assertPpr (isAlgTyCon tc) (ppr tc) $ + go orig_ty + where + go ty + | Just ty' <- coreView ty + = go ty' + + go ty@(TyConApp tycon args) + | tc == tycon -- Common case + = return (mkNomReflCo ty, args) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- If the common case does not occur, instantiate a template + -- T k1 .. kn t1 .. tm, and unify with the original type + -- Doing it this way ensures that the types we return are + -- kind-compatible with T. For example, suppose we have + -- matchExpectedTyConApp T (f Maybe) + -- where data T a = MkT a + -- Then we don't want to instantiate T's data constructors with + -- (a::*) ~ Maybe + -- because that'll make types that are utterly ill-kinded. + -- This happened in #7368 + defer + = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) + ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) + ; let args = mkTyVarTys arg_tvs + tc_template = mkTyConApp tc args + ; co <- unifyType Nothing tc_template orig_ty + ; return (co, args) } + +---------------------- +matchExpectedAppTy :: TcRhoType -- orig_ty + -> TcM (TcCoercion, -- m a ~N orig_ty + (TcSigmaType, TcSigmaType)) -- Returns m, a +-- If the incoming type is a mutable type variable of kind k, then +-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. + +matchExpectedAppTy orig_ty + = go orig_ty + where + go ty + | Just ty' <- coreView ty = go ty' + + | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty + = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) + + go (TyVarTy tv) + | isMetaTyVar tv + = do { cts <- readMetaTyVar tv + ; case cts of + Indirect ty -> go ty + Flexi -> defer } + + go _ = defer + + -- Defer splitting by generating an equality constraint + defer + = do { ty1 <- newFlexiTyVarTy kind1 + ; ty2 <- newFlexiTyVarTy kind2 + ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty + ; return (co, (ty1, ty2)) } + + orig_kind = typeKind orig_ty + kind1 = mkVisFunTyMany liftedTypeKind orig_kind + kind2 = liftedTypeKind -- m :: * -> k + -- arg type :: * + +{- ********************************************************************** +* + fillInferResult +* +********************************************************************** -} + +-- | Fill an 'InferResult' with the given type. +-- +-- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@, +-- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@. +-- +-- This function enforces the following invariants: +-- +-- - Level invariant. +-- The stored type @t2@ is at the same level as given by the +-- 'ir_lvl' field. +-- - FRR invariant. +-- Whenever the 'ir_frr' field is `IFRR_Check`, @t2@ is guaranteed +-- to have a syntactically fixed RuntimeRep, in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +fillInferResultNoInst :: TcType -> InferResult -> TcM TcCoercionN +fillInferResultNoInst act_res_ty (IR { ir_uniq = u + , ir_lvl = res_lvl + , ir_frr = mb_frr + , ir_ref = ref }) + = do { mb_exp_res_ty <- readTcRef ref + ; case mb_exp_res_ty of + Just exp_res_ty + -- We progressively refine the type stored in 'ref', + -- for example when inferring types across multiple equations. + -- + -- Example: + -- + -- \ x -> case y of { True -> x ; False -> 3 :: Int } + -- + -- When inferring the return type of this function, we will create + -- an 'Infer' 'ExpType', which will first be filled by the type of 'x' + -- after typechecking the first equation, and then filled again with + -- the type 'Int', at which point we want to ensure that we unify + -- the type of 'x' with 'Int'. This is what is happening below when + -- we are "joining" several inferred 'ExpType's. + -> do { traceTc "Joining inferred ExpType" $ + ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty + ; cur_lvl <- getTcLevel + ; unless (cur_lvl `sameDepthAs` res_lvl) $ + ensureMonoType act_res_ty -- See (FIR1) + ; unifyType Nothing act_res_ty exp_res_ty } + Nothing + -> do { traceTc "Filling inferred ExpType" $ + ppr u <+> text ":=" <+> ppr act_res_ty + + -- Enforce the level invariant: ensure the TcLevel of + -- the type we are writing to 'ref' matches 'ir_lvl'. + ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty + + -- Enforce the FRR invariant: ensure the type has a syntactically + -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing'). + ; (frr_co, act_res_ty) <- + case mb_frr of + IFRR_Any -> return (mkNomReflCo act_res_ty, act_res_ty) + IFRR_Check frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty + + -- Compose the two coercions. + ; let final_co = prom_co `mkTransCo` frr_co + + ; writeTcRef ref (Just act_res_ty) + + ; return final_co } } + +fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper +-- See Note [Instantiation of InferResult] +fillInferResult ct_orig res_ty ires@(IR { ir_inst = iif }) + = case iif of + IIF_Sigma -> do { co <- fillInferResultNoInst res_ty ires + ; return (mkWpCastN co) } + IIF_ShallowRho -> do { (wrap, res_ty') <- topInstantiate ct_orig res_ty + ; co <- fillInferResultNoInst res_ty' ires + ; return (mkWpCastN co <.> wrap) } + IIF_DeepRho -> do { (wrap, res_ty') <- dsInstantiate ct_orig res_ty + ; co <- fillInferResultNoInst res_ty' ires + ; return (mkWpCastN co <.> wrap) } + +{- Note [fillInferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~ +When inferring, we use fillInferResult to "fill in" the hole in InferResult + data InferResult = IR { ir_uniq :: Unique + , ir_lvl :: TcLevel + , ir_ref :: IORef (Maybe TcType) } + +There are two things to worry about: + +1. What if it is under a GADT or existential pattern match? + - GADTs: a unification variable (and Infer's hole is similar) is untouchable + - Existentials: be careful about skolem-escape + +2. What if it is filled in more than once? E.g. multiple branches of a case + case e of + T1 -> e1 + T2 -> e2 + +Our typing rules are: + +* The RHS of a existential or GADT alternative must always be a + monotype, regardless of the number of alternatives. + +* Multiple non-existential/GADT branches can have (the same) + higher rank type (#18412). E.g. this is OK: + case e of + True -> hr + False -> hr + where hr:: (forall a. a->a) -> Int + c.f. Section 7.1 of "Practical type inference for arbitrary-rank types" + We use choice (2) in that Section. + (GHC 8.10 and earlier used choice (1).) + + But note that + case e of + True -> hr + False -> \x -> hr x + will fail, because we still /infer/ both branches, so the \x will get + a (monotype) unification variable, which will fail to unify with + (forall a. a->a) + +For (1) we can detect the GADT/existential situation by seeing that +the current TcLevel is greater than that stored in ir_lvl of the Infer +ExpType. We bump the level whenever we go past a GADT/existential match. + +Then, before filling the hole use promoteTcType to promote the type +to the outer ir_lvl. promoteTcType does this + - create a fresh unification variable alpha at level ir_lvl + - emits an equality alpha[ir_lvl] ~ ty + - fills the hole with alpha +That forces the type to be a monotype (since unification variables can +only unify with monotypes); and catches skolem-escapes because the +alpha is untouchable until the equality floats out. + +For (2), we simply look to see if the hole is filled already. + - if not, we promote (as above) and fill the hole + - if it is filled, we simply unify with the type that is + already there + +(FIR1) There is one wrinkle. Suppose we have + case e of + T1 -> e1 :: (forall a. a->a) -> Int + G2 -> e2 + where T1 is not GADT or existential, but G2 is a GADT. Then suppose the + T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine. + But now the G2 alternative must not *just* unify with that else we'd risk + allowing through (e2 :: (forall a. a->a) -> Int). If we'd checked G2 first + we'd have filled the hole with a unification variable, which enforces a + monotype. + + So if we check G2 second, we still want to emit a constraint that restricts + the RHS to be a monotype. This is done by ensureMonoType, and it works + by simply generating a constraint (alpha ~ ty), where alpha is a fresh +unification variable. We discard the evidence. + +Note [Instantiation of InferResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking expressions (not types, not patterns), we always almost +always instantiate before filling in `InferResult`, so that the result is a +TcRhoType. This behaviour is controlled by the `ir_inst :: InferInstFlag` +field of `InferResult`. + +If we do instantiate (ir_inst = IIF_DeepRho), and DeepSubsumption is enabled, +we instantiate deeply. See `tcInferResult`. + +Usually this field is `IIF_DeepRho` meaning "return a (possibly deep) rho-type". +Why is this the common case? See #17173 for discussion. Here are some examples +of why: + +1. Consider + f x = (*) + We want to instantiate the type of (*) before returning, else we + will infer the type + f :: forall {a}. a -> forall b. Num b => b -> b -> b + This is surely confusing for users. + + And worse, the monomorphism restriction won't work properly. The MR is + dealt with in simplifyInfer, and simplifyInfer has no way of + instantiating. This could perhaps be worked around, but it may be + hard to know even when instantiation should happen. + +2. Another reason. Consider + f :: (?x :: Int) => a -> a + g y = let ?x = 3::Int in f + Here want to instantiate f's type so that the ?x::Int constraint + gets discharged by the enclosing implicit-parameter binding. + +3. Suppose one defines plus = (+). If we instantiate lazily, we will + infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism + restriction compels us to infer + plus :: Integer -> Integer -> Integer + (or similar monotype). Indeed, the only way to know whether to apply + the monomorphism restriction at all is to instantiate + +HOWEVER, not always! Here are places where we want `IIF_Sigma` meaning +"return a sigma-type": + +* IIF_Sigma: In GHC.Tc.Module.tcRnExpr, which implements GHCi's :type + command, we want to return a completely uninstantiated type. + See Note [Implementing :type] in GHC.Tc.Module. + +* IIF_Sigma: In types we can't lambda-abstract, so we must be careful not to instantiate + at all. See calls to `runInferHsType` + +* IIF_Sigma: in patterns we don't want to instantiate at all. See the use of + `runInferSigmaFRR` in GHC.Tc.Gen.Pat + +* IIF_ShallowRho: in the expression part of a view pattern, we must top-instantiate + but /not/ deeply instantiate (#26331). See Note [View patterns and polymorphism] + in GHC.Tc.Gen.Pat. This the only place we use IIF_ShallowRho. + +Why do we want to deeply instantiate, ever? Why isn't top-instantiation enough? +Answer: to accept the following program (T26225b) with -XDeepSubsumption, we +need to deeply instantiate when inferring in checkResultTy: + + f :: Int -> (forall a. a->a) + g :: Int -> Bool -> Bool + + test b = + case b of + True -> f + False -> g + +If we don't deeply instantiate in the branches of the case expression, we will +try to unify the type of 'f' with that of 'g', which fails. If we instead +deeply instantiate 'f', we will fill the 'InferResult' with 'Int -> alpha -> alpha' +which then successfully unifies with the type of 'g' when we come to fill the +'InferResult' hole a second time for the second case branch. +-} + +{- +************************************************************************ +* * + Subsumption checking +* * +************************************************************************ + +Note [Subsumption checking: tcSubType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All the tcSubType calls have the form + tcSubType actual_ty expected_ty +which checks + actual_ty <= expected_ty + +That is, that a value of type actual_ty is acceptable in +a place expecting a value of type expected_ty. I.e. that + + actual ty is more polymorphic than expected_ty + +It returns a wrapper function + co_fn :: actual_ty ~ expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. + +Note [Ambiguity check and deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: (forall b. Eq b => a -> a) -> Int + +Does `f` have an ambiguous type? The ambiguity check usually checks +that this definition of f' would typecheck, where f' has the exact same +type as f: + f' :: (forall b. Eq b => a -> a) -> Intp + f' = f + +This will be /rejected/ with DeepSubsumption but /accepted/ with +ShallowSubsumption. On the other hand, this eta-expanded version f'' +would be rejected both ways: + f'' :: (forall b. Eq b => a -> a) -> Intp + f'' x = f x + +This is squishy in the same way as other examples in GHC.Tc.Validity +Note [The squishiness of the ambiguity check] + +The situation in June 2022. Since we have SimpleSubsumption at the moment, +we don't want introduce new breakage if you add -XDeepSubsumption, by +rejecting types as ambiguous that weren't ambiguous before. So, as a +holding decision, we /always/ use SimpleSubsumption for the ambiguity check +(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. +-} + + + +----------------- +-- tcWrapResult needs both un-type-checked (for origins and error messages) +-- and type-checked (for wrapping) expressions +tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr + +tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType + -> TcM (HsExpr GhcTc) +tcWrapResultO orig rn_expr expr actual_ty res_ty + = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty + , text "Expected:" <+> ppr res_ty ]) + ; wrap <- tcSubType orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty + ; return (mkHsWrap wrap expr) } + +-- | A version of 'tcWrapResult' to use when the actual type is a +-- rho-type, so nothing to instantiate; just go straight to unify. +-- It means we don't need to pass in a CtOrigin. +tcWrapResultMono :: HasDebugCallStack + => HsExpr GhcRn -> HsExpr GhcTc + -> TcRhoType -- ^ Actual; a rho-type, not a sigma-type + -> ExpRhoType -- ^ Expected + -> TcM (HsExpr GhcTc) +tcWrapResultMono rn_expr expr act_ty res_ty + = do { co <- tcSubTypeMono rn_expr act_ty res_ty + ; return (mkHsWrapCo co expr) } + +-- | A version of 'tcSubType' to use when the actual type is a rho-type, +-- so that no instantiation is needed. +tcSubTypeMono :: HasDebugCallStack + => HsExpr GhcRn + -> TcRhoType -- ^ Actual; a rho-type, not a sigma-type + -> ExpRhoType -- ^ Expected + -> TcM TcCoercionN +tcSubTypeMono rn_expr act_ty exp_ty + = assertPpr (isDeepRhoTy act_ty) + (vcat [ text "Actual type is not a (deep) rho-type." + , text "act_ty:" <+> ppr act_ty + , text "rn_expr:" <+> ppr rn_expr]) $ + case exp_ty of + Infer inf_res -> fillInferResultNoInst act_ty inf_res + Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty + +------------------------ +tcSubTypePat :: CtOrigin -> UserTypeCtxt + -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper +-- Used in patterns; polarity is backwards compared +-- to tcSubType +-- If wrap = tc_sub_type_et t1 t2 +-- => wrap :: t1 ~> t2 +tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected + = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected + +tcSubTypePat _ _ (Infer inf_res) ty_expected + = do { co <- fillInferResultNoInst ty_expected inf_res + -- In patterns we do not instantatiate + + ; return (mkWpCastN (mkSymCo co)) } + +--------------- + +-- | A subtype check that performs deep subsumption. +-- See also 'tcSubTypeMono', for when no instantiation is required. +tcSubTypeDS :: HsExpr GhcRn + -> TcRhoType -- Actual type -- a rho-type not a sigma-type + -> TcRhoType -- Expected type + -- DeepSubsumption <=> when checking, this type + -- is deeply skolemised + -> TcM HsWrapper +-- Only one call site, in GHC.Tc.Gen.App.tcApp +tcSubTypeDS rn_expr act_rho exp_rho + = tc_sub_type_deep Top (unifyExprType rn_expr) orig GenSigCtxt act_rho exp_rho + where + orig = exprCtOrigin rn_expr + +--------------- + +-- | Checks that the 'actual' type is more polymorphic than the 'expected' type. +tcSubType :: CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) + -> TcSigmaType -- ^ Actual type + -> ExpRhoType -- ^ Expected type + -> TcM HsWrapper +tcSubType inst_orig ctxt m_thing ty_actual res_ty + = case res_ty of + Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt + ty_actual ty_expected + + Infer inf_res -> fillInferResult inst_orig ty_actual inf_res + +--------------- +tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we + -- doing this subtype check? + -> UserTypeCtxt -- where did the expected type arise? + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- External entry point, but no ExpTypes on either side +-- Checks that actual <= expected +-- Returns HsWrapper :: actual ~ expected +tcSubTypeSigma orig ctxt ty_actual ty_expected + = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected + +--------------- +tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise + -> TcSigmaType -> TcSigmaType -> TcM HsWrapper +-- See Note [Ambiguity check and deep subsumption] +tcSubTypeAmbiguity ctxt ty_actual ty_expected + = tc_sub_type_ds Top Shallow (unifyType Nothing) + (AmbiguityCheckOrigin ctxt) + ctxt ty_actual ty_expected + +--------------- +addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a +addSubTypeCtxt ty_actual ty_expected thing_inside + | isRhoTy ty_actual -- If there is no polymorphism involved, the + , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions) + = thing_inside -- gives enough context by itself + | otherwise + = addErrCtxtM mk_msg thing_inside + where + mk_msg tidy_env + = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual + ; ty_expected <- readExpType ty_expected + -- A worry: might not be filled if we're debugging. Ugh. + ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected + ; return (tidy_env, SubTypeCtxt ty_expected ty_actual) } + + +--------------- +tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify + -> CtOrigin -- Used when instantiating + -> UserTypeCtxt -- Used when skolemising + -> TcSigmaType -- Actual; a sigma-type + -> TcSigmaType -- Expected; also a sigma-type + -> TcM HsWrapper +-- Checks that actual_ty is more polymorphic than expected_ty +-- If wrap = tc_sub_type t1 t2 +-- => wrap :: t1 ~> t2 +-- +-- The "how to unify argument" is always a call to `uType TypeLevel orig`, +-- but with different ways of constructing the CtOrigin `orig` from +-- the argument types and context. + +---------------------- +tc_sub_type unify inst_orig ctxt ty_actual ty_expected + = do { ds_flag <- getDeepSubsumptionFlag + ; tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected } + +---------------------- +tc_sub_type_ds :: Position p -- ^ position in the type (for error messages only) + -> DeepSubsumptionFlag + -> (TcType -> TcType -> TcM TcCoercionN) + -> CtOrigin -> UserTypeCtxt -> TcSigmaType + -> TcSigmaType -> TcM HsWrapper +-- tc_sub_type_ds is the main subsumption worker function +-- It takes an explicit DeepSubsumptionFlag +tc_sub_type_ds pos ds_flag unify inst_orig ctxt ty_actual ty_expected + | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily] + , isRhoTyDS ds_flag ty_actual + = do { traceTc "tc_sub_type (drop to equality)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; mkWpCastN <$> + unify ty_actual ty_expected } + + | otherwise -- This is the general case + = do { traceTc "tc_sub_type (general case)" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + + ; (sk_wrap, inner_wrap) + <- tcSkolemise ds_flag ctxt ty_expected $ \sk_rho -> + case ds_flag of + Deep -> tc_sub_type_deep pos unify inst_orig ctxt ty_actual sk_rho + Shallow -> tc_sub_type_shallow unify inst_orig ty_actual sk_rho + + ; return (sk_wrap <.> inner_wrap) } + +---------------------- +tc_sub_type_shallow :: (TcType -> TcType -> TcM TcCoercionN) + -> CtOrigin + -> TcSigmaType + -> TcRhoType -- Skolemised (shallow-ly) + -> TcM HsWrapper +tc_sub_type_shallow unify inst_orig ty_actual sk_rho + = do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual + ; cow <- unify rho_a sk_rho + ; return (mkWpCastN cow <.> wrap) } + +---------------------- +definitely_poly :: TcType -> Bool +-- A very conservative test: +-- see Note [Don't skolemise unnecessarily] +definitely_poly ty + | (tvs, theta, tau) <- tcSplitSigmaTy ty + , (tv:_) <- tvs -- At least one tyvar + , null theta -- No constraints; see (DP1) + , tv `isInjectiveInType` tau + -- The tyvar actually occurs (DP2), + -- and occurs in an injective position (DP3). + = True + | otherwise + = False + +{- Note [Don't skolemise unnecessarily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to solve + ty_actual <= ty_expected + (Char->Char) <= (forall a. a->a) +We could skolemise the 'forall a', and then complain +that (Char ~ a) is insoluble; but that's a pretty obscure +error. It's better to say that + (Char->Char) ~ (forall a. a->a) +fails. + +If we prematurely go to equality we'll reject a program we should +accept (e.g. #13752). So the test (which is only to improve error +message) is very conservative: + + * ty_actual is /definitely/ monomorphic: see `definitely_mono` + This definitely_mono test comes in "shallow" and "deep" variants + + * ty_expected is /definitely/ polymorphic: see `definitely_poly` + This definitely_poly test is more subtle than you might think. + Here are three cases where expected_ty looks polymorphic, but + isn't, and where it would be /wrong/ to switch to equality: + + (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) + + (DP2) (Char->Char) <= (forall a. Char -> Char) + + (DP3) (Char->Char) <= (forall a. F [a] Char -> Char) + where type instance F [x] t = t + + +Note [Coercion errors in tcSubMult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment, we insist that all sub-multiplicity tests turn out +(once the typechecker has finished its work) to be equalities, +i.e. implementable by ReflCo. Why? Because our type system has +no way to express non-Refl sub-multiplicities. + +How can we check that every call to `tcSubMult` returns `Refl`? +It might not be `Refl` *yet*. + +[TODO: add counterexample #25130] + +So we take the following approach + +* In `tcEqMult`: + - Emit a perfectly ordinary Wanted equality constraint for the equality, + returning a coercion. + + - Wrap that coercion with `DE_Multiplicity` to make a `DelayedError`, and put + that delayed error into `wc_errors` of the current WantedConstraints. This + is done by `ensureReflMultiplicityCo`. + +* When solving constraints, discard any `DE_Multiplicity` errors that wrap a + reflective coercion, of kind `ty ~ ty`. This is done in + `GHC.Tc.Solver.simplifyDelayedErrors` + +* After constraint solving is complete report an error if there are any + remaining `DE_Multiplicity` errors. See + `GHC.Tc.Errors.reportMultiplicityCoercionErrs` + +Wrinkles + +(DME1) If the multiplicity constraint is /solved/, but with a non-reflective + coercion, we'll have just a `DE_Multiplicity` error left over. + + But if the multiplicity constraint is /unsolved/ (e.g. ManyTy ~ OneTy), we + will have /both/ an unsolved Wanted in `wc_simple`, /and/ a `DE_Multiplicity` + in `wc_errors`. We don't want to report both. Solution: suppress all + `DE_Multiplicity` constraints if there are any unsolved wanted. + + This way, the delayed error is indeed only reported when the constraint is + solved with a non-reflexivity coercion. + +An alternative would be to have a kind of constraint which can only produce +trivial evidence. This would allow such checks to happen in the constraint +solver (#18756). This would be similar to the existing setup for Concrete, see +Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete (PHASE 1 in particular). + +-} + +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM () +tcSubMult origin w_actual w_expected + | Just (w1, w2) <- isMultMul w_actual = + do { tcSubMult origin w1 w_expected + ; tcSubMult origin w2 w_expected } + -- Currently, we consider p*q and sup p q to be equal. Therefore, p*q <= r is + -- equivalent to p <= r and q <= r. For other cases, we approximate p <= q by p + -- ~ q. This is not complete, but it's sound. See also Note [Overapproximating + -- multiplicities] in Multiplicity. +tcSubMult origin w_actual w_expected = + case submult w_actual w_expected of + Submult -> return () + Unknown -> tcEqMult origin w_actual w_expected + +tcEqMult :: CtOrigin -> Mult -> Mult -> TcM () +tcEqMult origin w_actual w_expected = do + { + -- Note that here we do not call to `submult`, so we check + -- for strict equality. + ; coercion <- unifyTypeAndEmit TypeLevel origin w_actual w_expected + -- See Note [Coercion errors in tcSubMult]. + ; ensureReflMultiplicityCo coercion origin } + + +{- ********************************************************************* +* * + Deep subsumption +* * +********************************************************************* -} + +{- Note [Deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The DeepSubsumption extension, documented here + + https://github.com/ghc-proposals/ghc-proposals/pull/511. + +makes a best-efforts attempt implement deep subsumption as it was +prior to the Simplify Subsumption proposal: + + https://github.com/ghc-proposals/ghc-proposals/pull/287 + +The effects are in these main places: + +1. In the subsumption check, tcSubType, we must do deep skolemisation: + see the call to tcSkolemise Deep in tc_sub_type_deep + +2. In tcPolyExpr we must do deep skolemisation: + see the call to tcSkolemise in tcSkolemiseExpType + +3. for expression type signatures (e :: ty), and functions with type + signatures (e.g. f :: ty; f = e), we must deeply skolemise the type; + see the call to tcDeeplySkolemise in tcSkolemiseScoped. + +4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result + type. Without deep subsumption, tcSubTypeMono would be sufficent. + +In all these cases note that the deep skolemisation must be done /first/. +Consider (1) + (forall a. Int -> a -> a) <= Int -> (forall b. b -> b) +We must skolemise the `forall b` before instantiating the `forall a`. +See also Note [Deep skolemisation]. + +Wrinkles: + +(DS1) Note that we /always/ use shallow subsumption in the ambiguity check. + See Note [Ambiguity check and deep subsumption]. + +(DS2) When doing deep subsumption, we must be careful not to needlessly + drop down to unification, e.g. in cases such as: + (Bool -> ∀ d. d->d) <= alpha beta gamma + See Note [FunTy vs non-FunTy case in tc_sub_type_deep]. + +(DS3) The interaction between deep subsumption and required foralls + (forall a -> ty) is a bit subtle. See #24696 and + Note [Deep subsumption and required foralls] + +Note [Deep skolemisation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +deeplySkolemise decomposes and skolemises a type, returning a type +with all its arrows visible (ie not buried under foralls) + +Examples: + + deeplySkolemise (Int -> forall a. Ord a => blah) + = ( wp, [a], [d:Ord a], Int -> blah ) + where wp = \x:Int. /\a. \(d:Ord a). x + + deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah) + = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah ) + where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). x + +In general, + if deeplySkolemise ty = (wrap, tvs, evs, rho) + and e :: rho + then wrap e :: ty + and 'wrap' binds tvs, evs + +ToDo: this eta-abstraction plays fast and loose with termination, + because it can introduce extra lambdas. Maybe add a `seq` to + fix this + +Note [FunTy vs FunTy case in tc_sub_type_deep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The goal of tc_sub_type_deep is to produce an HsWrapper that "proves" that the +actual type is a subtype of the expected type. The most important case is how +we deal with function arrows. Suppose we have: + + ty_actual = act_arg -> act_res + ty_expected = exp_arg -> exp_res + +To produce fun_wrap :: (act_arg -> act_res) ~> (exp_arg -> exp_res), we use +the fact that the function arrow is contravariant in its argument type and +covariant in its result type. Thus we recursively perform subtype checks +on the argument types (with actual/expected switched) and the result types, +to get: + + arg_wrap :: exp_arg ~> act_arg -- NB: expected/actual have switched sides + res_wrap :: act_res ~> exp_res + +Then fun_wrap = mkWpFun arg_wrap res_wrap. + +Wrinkle [Representation-polymorphism checking during subtyping] + + Inserting a WpFun HsWrapper amounts to impedance matching in deep subsumption + via eta-expansion: + + f ==> \ (x :: exp_arg) -> res_wrap [ f (arg_wrap [x]) ] + + As we produce a lambda, we must enforce the representation polymorphism + invariants described in Note [Representation polymorphism invariants] in GHC.Core. + That is, we must ensure that both x (the lambda binder) and (arg_wrap [x]) (the function argument) + have a fixed runtime representation. + + Note however that desugaring mkWpFun does not always introduce a lambda: if + both the argument and result HsWrappers are casts, then a FunCo cast suffices, + in which case we should not perform representation-polymorphism checking. + + This means that, in the FunTy/FunTy case of tc_sub_type_deep, we can skip + the representation-polymorphism checks if the produced argument and result + wrappers are identities or casts. + It is important to do so, otherwise we reject valid programs. + + Here's a contrived example (there are undoubtedly more natural examples) + (see testsuite/tests/rep-poly/NoEtaRequired): + + type Id :: k -> k + type family Id a where + + type T :: TYPE r -> TYPE (Id r) + type family T a where + + test :: forall r (a :: TYPE r). a :~~: T a -> () + test HRefl = + let + f :: (a -> a) -> () + f _ = () + g :: T a -> T a + g = undefined + in f g + + We don't need to eta-expand `g` to make `f g` typecheck; a cast suffices. + Hence we should not perform representation-polymorphism checks; they would + fail here. + +Note [Setting the argument context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we are doing the ambiguity check for the (bogus) + f :: (forall a b. C b => a -> a) -> Int + +We'll call + tcSubType ((forall a b. C b => a->a) -> Int ) + ((forall a b. C b => a->a) -> Int ) + +with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing +on the argument type of the (->) -- and at that point we want to switch +to a UserTypeCtxt of GenSigCtxt. Why? + +* Error messages. If we stick with FunSigCtxt we get errors like + * Could not deduce: C b + from the context: C b0 + bound by the type signature for: + f :: forall a b. C b => a->a + But of course f does not have that type signature! + Example tests: T10508, T7220a, Simple14 + +* Implications. We may decide to build an implication for the whole + ambiguity check, but we don't need one for each level within it, + and TcUnify.alwaysBuildImplication checks the UserTypeCtxt. + See Note [When to build an implication] + +Note [Multiplicity in deep subsumption] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + t1 ->{mt} t2 <= s1 ->{ms} s2 + +At the moment we /unify/ ms~mt, via tcEqMult. + +Arguably we should use `tcSubMult`. But then if mt=m0 (a unification +variable) and ms=Many, `tcSubMult` is a no-op (since anything is a +sub-multiplicty of Many). But then `m0` may never get unified with +anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds +Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base +we get this + + "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys + = \xs -> xs ++ ys + +where we eta-expanded that (:). But now foldr expects an argument +with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint +complains. + +The easiest solution was to unify the multiplicities in tc_sub_type_deep, +insisting on equality. This is only in the DeepSubsumption code anyway. + +Note [FunTy vs non-FunTy case in tc_sub_type_deep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, without Quick Look, but with Deep Subsumption: + f :: ∀a b c. a b c -> Int + g :: Bool -> ∀d. d -> d +To typecheck the application (f g), we need to do the subsumption test + + (Bool -> ∀ d. d->d) <= alpha beta gamma + +where alpha, beta, gamma are the unification variables that instantiate a,b,c +(respectively). We must not drop down to unification, or we will reject the call. +Instead, we should only unify alpha := (->), in which case we end up with the +usual FunTy vs FunTy case of Note [FunTy vs FunTy case in tc_sub_type_deep]: + + (Bool -> ∀ d. d->d) <= beta -> gamma + +which is straightforwardly solved by beta := Bool, using covariance in the return +type of the function arrow, and instantiating the forall before unifying with gamma. + +The conclusion is this: when doing a deep subtype check (in tc_sub_type_deep), +if the LHS is a FunTy and the RHS is a rho-type which is not a FunTy, +then unify the RHS with a FunTy and continue by performing a sub-type check on +the LHS vs the new RHS. And vice-versa (if it's the RHS that is a FunTy). + +See T11305 and T26225 for examples of when this is important. + +Note [Deep subsumption and required foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A required forall, (forall a -> ty) behaves like a "rho-type", one with no +top-level quantification. In particular, it is neither implicitly instantiated nor +skolemised. So + + rid1 :: forall a -> a -> a + rid1 = id + + rid2 :: forall a -> a -> a + rid2 a = id + +Here `rid2` wll typecheck, but `rid1` will not, because we don't implicitly skolemise +the type. + +This "no implicit subsumption nor skolemisation" applies during subsumption. +For example + (forall a. a->a) <= (forall a -> a -> a) -- NOT! +does /not/ hold, because that would require implicitly skoleming the (forall a->). + +Note also that, in Core, `eqType` distinguishes between + (forall a. blah) and forall a -> blah) +See discussion on #22762 and these Notes in GHC.Core.TyCo.Compare + * Note [ForAllTy and type equality] + * Note [Comparing visibility] + +So during deep subsumption we simply stop (and drop down to equality) when we encounter +a (forall a->). This is a little odd: +* Deep subsumption looks inside invisible foralls (forall a. ty) +* Deep subsumption looks inside arrows (t1 -> t2) +* But it does not look inside required foralls (forall a -> ty) + +There is discussion on #24696. How is this implemented? + +* In `tc_sub_type_deep`, the calls to `topInstantiate` and `deeplyInstantiate` + instantiate only /invisible/ binders. +* In `tc_sub_type_ds`, the call to `tcSkolemise` skolemises only /invisible/ + binders. + +Here is a slightly more powerful alternative +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + In the story above, if we have + (forall a -> Eq a => a -> a) <= (forall a -> Ord a => a -> a) +we'll reject it, because both are rho-types but they aren't equal. But in the +"drop to equality" stage we could instead see if both rho-types are headed with +(forall a ->) and if so strip that off and go back into deep subsumption. + +This is a bit more powerful, but also a bit more complicated, so GHC +doesn't do it yet, awaiting credible user demand. See #24696. +-} + +data DeepSubsumptionFlag = Deep | Shallow + +instance Outputable DeepSubsumptionFlag where + ppr Deep = text "Deep" + ppr Shallow = text "Shallow" + +getDeepSubsumptionFlag :: TcM DeepSubsumptionFlag +getDeepSubsumptionFlag = do { ds <- xoptM LangExt.DeepSubsumption + ; if ds then return Deep else return Shallow } + +-- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption. +-- +-- Given @ty_actual@ (a sigma-type) and @ty_expected@ (deeply skolemised, i.e. +-- a deep rho type), it returns an 'HsWrapper' @wrap :: ty_actual ~> ty_expected@. +tc_sub_type_deep :: HasDebugCallStack + => Position p -- ^ Position in the type (for error messages only) + -> (TcType -> TcType -> TcM TcCoercionN) -- ^ How to unify + -> CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> TcSigmaType -- ^ Actual; a sigma-type + -> TcRhoType -- ^ Expected; deeply skolemised + -> TcM HsWrapper + +-- If wrap = tc_sub_type_deep t1 t2 +-- => wrap :: t1 ~> t2 +-- Here is where the work actually happens! +-- Precondition: ty_expected is deeply skolemised + +tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected + = assertPpr (isDeepRhoTy ty_expected) (ppr ty_expected) $ + do { traceTc "tc_sub_type_deep" $ + vcat [ text "ty_actual =" <+> ppr ty_actual + , text "ty_expected =" <+> ppr ty_expected ] + ; go ty_actual ty_expected } + where + + -- 'unwrap' removes top-level type synonyms & looks through filled meta-tyvars + unwrap :: TcType -> TcM TcType + unwrap ty + | Just ty' <- coreView ty + = unwrap ty' + unwrap ty@(TyVarTy tv) + = do { lookup_res <- isFilledMetaTyVar_maybe tv + ; case lookup_res of + Just ty' -> unwrap ty' + Nothing -> return ty } + unwrap ty = return ty + + go, go1 :: TcType -> TcType -> TcM HsWrapper + go ty_a ty_e = + do { ty_a' <- unwrap ty_a + ; ty_e' <- unwrap ty_e + ; go1 ty_a' ty_e' } + + -- If ty_actual is not a rho-type, instantiate it first; otherwise + -- unification has no chance of succeeding. + go1 ty_a ty_e + | let (tvs, theta, _) = tcSplitSigmaTy ty_a + , not (null tvs && null theta) + = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a + ; body_wrap <- go in_rho ty_e + ; return (body_wrap <.> in_wrap) } + + -- Main case: FunTy vs FunTy. go_fun does the work. + go1 (FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) + (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) + | isVisibleFunArg af1 + , isVisibleFunArg af2 + = go_fun af1 act_mult act_arg act_res + af2 exp_mult exp_arg exp_res + + -- See Note [FunTy vs non-FunTy case in tc_sub_type_deep] + go1 (FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) ty_e + | isVisibleFunArg af1 + = do { exp_mult <- newMultiplicityVar + ; exp_arg <- newOpenFlexiTyVarTy -- NB: no FRR check needed; we might not need to eta-expand + ; exp_res <- newOpenFlexiTyVarTy + ; let exp_funTy = FunTy { ft_af = af1, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res } + ; unify_wrap <- just_unify exp_funTy ty_e + ; fun_wrap <- go_fun af1 act_mult act_arg act_res af1 exp_mult exp_arg exp_res + ; return $ unify_wrap <.> fun_wrap + -- unify_wrap :: exp_funTy ~> ty_e + -- fun_wrap :: ty_a ~> exp_funTy + } + go1 ty_a (FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) + | isVisibleFunArg af2 + = do { act_mult <- newMultiplicityVar + ; act_arg <- newOpenFlexiTyVarTy -- NB: no FRR check needed; we might not need to eta-expand + ; act_res <- newOpenFlexiTyVarTy + ; let act_funTy = FunTy { ft_af = af2, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res } + + ; unify_wrap <- just_unify ty_a act_funTy + ; fun_wrap <- go_fun af2 act_mult act_arg act_res af2 exp_mult exp_arg exp_res + ; return $ fun_wrap <.> unify_wrap + -- unify_wrap :: ty_a ~> act_funTy + -- fun_wrap :: act_funTy ~> ty_e + } + + -- Otherwise, revert to unification. + go1 ty_a ty_e = just_unify ty_a ty_e + + just_unify ty_a ty_e = do { cow <- unify ty_a ty_e + ; return (mkWpCastN cow) } + + -- FunTy/FunTy case: this is where we insert any necessary eta-expansions. + go_fun :: FunTyFlag -> Mult -> TcType -> TcType -- actual FunTy + -> FunTyFlag -> Mult -> TcType -> TcType -- expected FunTy + -> TcM HsWrapper + go_fun act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res + -- See Note [FunTy vs FunTy case in tc_sub_type_deep] + = do { arg_wrap <- tc_sub_type_ds (Argument pos) Deep unify given_orig GenSigCtxt exp_arg act_arg + -- GenSigCtxt: See Note [Setting the argument context] + ; res_wrap <- tc_sub_type_deep (Result pos) unify inst_orig ctxt act_res exp_res + + ; mkWpFun_FRR unify pos + act_af act_mult act_arg act_res + exp_af exp_mult exp_arg exp_res + arg_wrap res_wrap + } + where + given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) + +-- | Like 'mkWpFun', except that it performs the necessary +-- representation-polymorphism checks on the argument type in the case that +-- we introduce a lambda abstraction. +mkWpFun_FRR + :: (TcType -> TcType -> TcM TcCoercionN) -- ^ how to unify + -> Position p + -> FunTyFlag -> Type -> TcType -> Type -- actual FunTy + -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy + -> HsWrapper -- ^ exp_arg ~> act_arg + -> HsWrapper -- ^ act_res ~> exp_res + -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy +mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap + = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <- + if needs_frr_checks + -- See Wrinkle [Representation-polymorphism checking during subtyping] + then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg + ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg + ; return (exp_frr_wrap, act_frr_wrap) } + else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg)) + + -- Enforce equality of multiplicities (not the more natural sub-multiplicity). + -- See Note [Multiplicity in deep subsumption] + ; act_arg_mult_co <- unify act_mult exp_mult + -- NB: don't use tcEqMult: that would require the evidence for + -- equality to be Refl, but it might well not be (#26332). + + ; let + exp_arg_fun_co = + mkFunCo Nominal exp_af + (mkReflCo Nominal exp_mult) + (mkSymCo exp_arg_co) + (mkReflCo Nominal exp_res) + act_arg_fun_co = + mkFunCo Nominal act_af + act_arg_mult_co + act_arg_co + (mkReflCo Nominal act_res) + arg_wrap_frr = + mkWpCastN (mkSymCo exp_arg_co) <.> arg_wrap <.> mkWpCastN act_arg_co + -- exp_arg_co :: exp_arg ~> exp_arg_frr + -- act_arg_co :: act_arg ~> act_arg_frr + -- arg_wrap :: exp_arg ~> act_arg + -- arg_wrap_frr :: exp_arg_frr ~> act_arg_frr + + ; return $ + mkWpCastN exp_arg_fun_co + <.> + mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res + <.> + mkWpCastN act_arg_fun_co + } + where + needs_frr_checks :: Bool + needs_frr_checks = + not (hole_or_cast arg_wrap) + || + not (hole_or_cast res_wrap) + hole_or_cast :: HsWrapper -> Bool + hole_or_cast WpHole = True + hole_or_cast (WpCast {}) = True + hole_or_cast _ = False + frr_ctxt :: Bool -> FixedRuntimeRepContext + frr_ctxt is_exp_ty = + FRRDeepSubsumption + { frrDSExpected = is_exp_ty + , frrDSPosition = pos + } + +----------------------- +deeplySkolemise :: SkolemInfo -> TcSigmaType + -> TcM ( HsWrapper + , [(Name,TcInvisTVBinder)] -- All skolemised variables + , [EvVar] -- All "given"s + , TcRhoType ) +-- See Note [Deep skolemisation] +deeplySkolemise skol_info ty + = go init_subst ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, bndrs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty + = do { let arg_tys' = substScaledTys subst arg_tys + ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys' + ; (subst', bndrs1) <- tcInstSkolTyVarBndrsX skol_info subst bndrs + ; ev_vars1 <- newEvVars (substTheta subst' theta) + ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' + ; let tvs = binderVars bndrs + tvs1 = binderVars bndrs1 + tv_prs1 = map tyVarName tvs `zip` bndrs1 + ; return ( mkWpEta ids1 (mkWpTyLams tvs1 + <.> mkWpEvLams ev_vars1 + <.> wrap) + , tv_prs1 ++ tvs_prs2 + , ev_vars1 ++ ev_vars2 + , mkScaledFunTys arg_tys' rho ) } + + | otherwise + = return (idHsWrapper, [], [], substTy subst ty) + -- substTy is a quick no-op on an empty substitution + +dsInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +-- Do topInstantiate or deeplyInstantiate, depending on -XDeepSubsumption +dsInstantiate orig ty + = do { ds_flag <- getDeepSubsumptionFlag + ; case ds_flag of + Shallow -> topInstantiate orig ty + Deep -> deeplyInstantiate orig ty } + +deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type) +-- Instantiate invisible foralls, even ones nested +-- (to the right) under arrows +deeplyInstantiate orig ty + = go init_subst ty + where + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) + + go subst ty + | Just (arg_tys, bndrs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty + = do { let tvs = binderVars bndrs + ; (subst', tvs') <- newMetaTyVarsX subst tvs + ; let arg_tys' = substScaledTys subst' arg_tys + theta' = substTheta subst' theta + ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' + ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' + ; (wrap2, rho2) <- go subst' rho + ; return (mkWpEta ids1 (wrap2 <.> wrap1), + mkScaledFunTys arg_tys' rho2) } + + | otherwise + = do { let ty' = substTy subst ty + ; return (idHsWrapper, ty') } + +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([Scaled TcType], [TcInvisTVBinder], ThetaType, TcSigmaType) +-- Looks for a *non-trivial* quantified type, under zero or more function arrows +-- By "non-trivial" we mean either tyvars or constraints are non-empty +tcDeepSplitSigmaTy_maybe ty + = go ty + where + go ty | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- go res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- tcSplitSigmaTyBndrs ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) + + | otherwise = Nothing + +isDeepRhoTy :: TcType -> Bool +-- True if there are no foralls or (=>) at the top, or nested under +-- arrows to the right. e.g +-- forall a. a False +-- Int -> forall a. a False +-- (forall a. a) -> Int True +-- Returns True iff tcDeepSplitSigmaTy_maybe returns Nothing +isDeepRhoTy ty + | not (isRhoTy ty) = False -- Foralls or (=>) at top + | Just (_, res) <- tcSplitFunTy_maybe ty = isDeepRhoTy res + | otherwise = True -- No forall, (=>), or (->) at top + +isRhoTyDS :: DeepSubsumptionFlag -> TcType -> Bool +isRhoTyDS ds_flag ty + = case ds_flag of + Shallow -> isRhoTy ty -- isRhoTy: no top level forall or (=>) + Deep -> isDeepRhoTy ty -- "deep" version: no nested forall or (=>) + +{- +************************************************************************ +* * + Boxy unification +* * +************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. +-} + +unifyExprType :: HsExpr GhcRn -> TcType -> TcType -> TcM TcCoercionN +unifyExprType rn_expr ty1 ty2 + = unifyType (Just (HsExprRnThing rn_expr)) ty1 ty2 + +unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 + -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) + -> TcM TcCoercionN -- :: ty1 ~# ty2 +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyType thing ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = thing + , uo_visible = True } + +unifyInvisibleType :: TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) + -> TcM TcCoercionN -- :: ty1 ~# ty2 +-- Actual and expected types +-- Returns a coercion : ty1 ~ ty2 +unifyInvisibleType ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = Nothing + , uo_visible = False } -- This is the "invisible" bit + +unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN +-- Like unifyType, but swap expected and actual in error messages +-- This is used when typechecking patterns +unifyTypeET ty1 ty2 + = unifyTypeAndEmit TypeLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty2 -- NB swapped + , uo_expected = ty1 -- NB swapped + , uo_thing = Nothing + , uo_visible = True } + + +unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN +unifyKind mb_thing ty1 ty2 + = unifyTypeAndEmit KindLevel origin ty1 ty2 + where + origin = TypeEqOrigin { uo_actual = ty1 + , uo_expected = ty2 + , uo_thing = mb_thing + , uo_visible = True } + +unifyTypeAndEmit :: TypeOrKind -> CtOrigin -> TcType -> TcType -> TcM CoercionN +-- Make a ref-cell, unify, emit the collected constraints +unifyTypeAndEmit t_or_k orig ty1 ty2 + = do { ref <- newTcRef emptyBag + ; loc <- getCtLocM orig (Just t_or_k) + ; let env = UE { u_loc = loc, u_role = Nominal + , u_rewriters = emptyRewriterSet -- ToDo: check this + , u_defer = ref, u_unified = Nothing } + + -- The hard work happens here + ; co <- uType env ty1 ty2 + + ; cts <- readTcRef ref + ; unless (null cts) (emitSimples cts) + ; return co } + +{- +%************************************************************************ +%* * + uType and friends +%* * +%************************************************************************ + +Note [The eager unifier] +~~~~~~~~~~~~~~~~~~~~~~~~ +The eager unifier, `uType`, is called by + + * The constraint generator (e.g. in GHC.Tc.Gen.Expr), + via the wrappers `unifyType`, `unifyKind` etc + + * The constraint solver (e.g. in GHC.Tc.Solver.Equality), + via `GHC.Tc.Solver.Monad.wrapUnifierTcS`. + +`uType` runs in the TcM monad, but it carries a UnifyEnv that tells it +what to do when unifying a variable or deferring a constraint. Specifically, + * it collects deferred constraints in `u_defer`, and + * it records which unification variables it has unified in `u_unified` +Then it is up to the wrappers (one for the constraint generator, one for +the constraint solver) to deal with these collected sets. + +Although `uType` runs in the TcM monad for convenience, really it could +operate just with the ability to + * write to the accumulators of deferred constraints + and unification variables in UnifyEnv. + * read and update existing unification variables + * zonk types befire unifying (`zonkTcType` in `uUnfilledVar`, and + `zonkTyCoVarKind` in `uUnfilledVar1` + * create fresh coercion holes (`newCoercionHole`) + * emit tracing info for debugging + * look at the ambient TcLevel: `getTcLevel` +A job for the future. +-} + +data UnifyEnv + = UE { u_role :: Role + , u_loc :: CtLoc + , u_rewriters :: RewriterSet + + -- Deferred constraints + , u_defer :: TcRef (Bag Ct) + + -- Which variables are unified; + -- if Nothing, we don't care + , u_unified :: Maybe (TcRef [TcTyVar]) + } + +setUEnvRole :: UnifyEnv -> Role -> UnifyEnv +setUEnvRole uenv role = uenv { u_role = role } + +updUEnvLoc :: UnifyEnv -> (CtLoc -> CtLoc) -> UnifyEnv +updUEnvLoc uenv@(UE { u_loc = loc }) upd = uenv { u_loc = upd loc } + +mkKindEnv :: UnifyEnv -> TcType -> TcType -> UnifyEnv +-- Modify the UnifyEnv to be right for unifing +-- the kinds of these two types +mkKindEnv env@(UE { u_loc = ctloc }) ty1 ty2 + = env { u_role = Nominal, u_loc = mkKindEqLoc ty1 ty2 ctloc } + +uType, uType_defer + :: UnifyEnv + -> TcType -- ty1 is the *actual* type + -> TcType -- ty2 is the *expected* type + -> TcM CoercionN + +-- It is always safe to defer unification to the main constraint solver +-- See Note [Deferred unification] +uType_defer (UE { u_loc = loc, u_defer = ref + , u_role = role, u_rewriters = rewriters }) + ty1 ty2 -- ty1 is "actual", ty2 is "expected" + = do { let pred_ty = mkEqPredRole role ty1 ty2 + ; hole <- newCoercionHole pred_ty + ; let ct = mkNonCanonical $ CtWanted $ + WantedCt { ctev_pred = pred_ty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = rewriters } + co = HoleCo hole + ; updTcRef ref (`snocBag` ct) + -- snocBag: see Note [Work-list ordering] in GHC.Tc.Solver.Equality + + -- Error trace only + -- NB. do *not* call mkErrCtxt unless tracing is on, + -- because it is hugely expensive (#5631) + ; whenDOptM Opt_D_dump_tc_trace $ + do { ctxt <- getErrCtxt + ; err_ctxt <- mkErrCtxt emptyTidyEnv ctxt + ; traceTc "utype_defer" $ + vcat ( ppr role + : debugPprType ty1 + : debugPprType ty2 + : map pprErrCtxtMsg err_ctxt ) + ; traceTc "utype_defer2" (ppr co) } + + ; return co } + + +-------------- +uType env@(UE { u_role = role }) orig_ty1 orig_ty2 + | Phantom <- role + = do { kind_co <- uType (mkKindEnv env orig_ty1 orig_ty2) + (typeKind orig_ty1) (typeKind orig_ty2) + ; return (mkPhantomCo kind_co orig_ty1 orig_ty2) } + + | otherwise + = do { tclvl <- getTcLevel + ; traceTc "u_tys" $ vcat + [ text "tclvl" <+> ppr tclvl + , sep [ ppr orig_ty1, text "~" <> ppr role, ppr orig_ty2] ] + ; co <- go orig_ty1 orig_ty2 + ; if isReflCo co + then traceTc "u_tys yields no coercion" Outputable.empty + else traceTc "u_tys yields coercion:" (ppr co) + ; return co } + where + go :: TcType -> TcType -> TcM CoercionN + -- The arguments to 'go' are always semantically identical + -- to orig_ty{1,2} except for looking through type synonyms + + -- Unwrap casts before looking for variables. This way, we can easily + -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we + -- didn't do it this way, and then the unification above was deferred. + go (CastTy t1 co1) t2 + = do { co_tys <- uType env t1 t2 + ; return (mkCoherenceLeftCo role t1 co1 co_tys) } + + go t1 (CastTy t2 co2) + = do { co_tys <- uType env t1 t2 + ; return (mkCoherenceRightCo role t2 co2 co_tys) } + + -- Variables; go for uUnfilledVar + -- Note that we pass in *original* (before synonym expansion), + -- so that type variables tend to get filled in with + -- the most informative version of the type + go (TyVarTy tv1) ty2 + = do { lookup_res <- isFilledMetaTyVar_maybe tv1 + ; case lookup_res of + Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1) + ; uType env ty1 orig_ty2 } + Nothing -> uUnfilledVar env NotSwapped tv1 ty2 } + + go ty1 (TyVarTy tv2) + = do { lookup_res <- isFilledMetaTyVar_maybe tv2 + ; case lookup_res of + Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2) + ; uType env orig_ty1 ty2 } + Nothing -> uUnfilledVar env IsSwapped tv2 ty1 } + + -- See Note [Unifying type synonyms] in GHC.Core.Unify + go ty1@(TyConApp tc1 []) (TyConApp tc2 []) + | tc1 == tc2 + = return $ mkReflCo role ty1 + + -- Now expand synonyms + -- See Note [Expanding synonyms during unification] + -- + -- Also NB that we recurse to 'go' so that we don't push a + -- new item on the origin stack. As a result if we have + -- type Foo = Int + -- and we try to unify Foo ~ Bool + -- we'll end up saying "can't match Foo with Bool" + -- rather than "can't match "Int with Bool". See #4535. + go ty1 ty2 + | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + -- Functions (t1 -> t2) just check the two parts + go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + | isVisibleFunArg af1 -- Do not attempt (c => t); just defer + , af1 == af2 -- Important! See #21530 + = do { co_w <- uType (env { u_role = funRole role SelMult }) w1 w2 + ; co_l <- uType (env { u_role = funRole role SelArg }) arg1 arg2 + ; co_r <- uType (env { u_role = funRole role SelRes }) res1 res2 + ; return $ mkNakedFunCo role af1 co_w co_l co_r } + + -- Always defer if a type synonym family (type function) + -- is involved. (Data families behave rigidly.) + go ty1@(TyConApp tc1 _) ty2 + | isTypeFamilyTyCon tc1 = defer ty1 ty2 + go ty1 ty2@(TyConApp tc2 _) + | isTypeFamilyTyCon tc2 = defer ty1 ty2 + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, equalLength tys1 tys2 + , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality + = assertPpr (isGenerativeTyCon tc1 role) (ppr tc1) $ + do { traceTc "go-tycon" (ppr tc1 $$ ppr tys1 $$ ppr tys2 $$ ppr (take 10 (tyConRoleListX role tc1))) + ; cos <- zipWith4M u_tc_arg (tyConVisibilities tc1) -- Infinite + (tyConRoleListX role tc1) -- Infinite + tys1 tys2 + ; return $ mkTyConAppCo role tc1 cos } + + go (LitTy m) ty@(LitTy n) + | m == n + = return $ mkReflCo role ty + + -- See Note [Care with type applications] + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go ty1@(AppTy s1 t1) ty2@(AppTy s2 t2) + = go_app (isNextArgVisible s1) ty1 s1 t1 ty2 s2 t2 + + go ty1@(AppTy s1 t1) ty2@(TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = assert (not (tyConMustBeSaturated tc2)) $ + go_app (isNextTyConArgVisible tc2 ts2') + ty1 s1 t1 ty2 (TyConApp tc2 ts2') t2' + + go ty1@(TyConApp tc1 ts1) ty2@(AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = assert (not (tyConMustBeSaturated tc1)) $ + go_app (isNextTyConArgVisible tc1 ts1') + ty1 (TyConApp tc1 ts1') t1' ty2 s2 t2 + + go ty1@(CoercionTy co1) ty2@(CoercionTy co2) + = do { kco <- uType (mkKindEnv env ty1 ty2) + (coercionType co1) (coercionType co2) + ; return $ mkProofIrrelCo role kco co1 co2 } + + -- Anything else fails + -- E.g. unifying for-all types, which is relative unusual + go ty1 ty2 = defer ty1 ty2 + + ------------------ + defer ty1 ty2 -- See Note [Check for equality before deferring] + | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) + | otherwise = uType_defer env orig_ty1 orig_ty2 + + + ------------------ + u_tc_arg is_vis role ty1 ty2 + = do { traceTc "u_tc_arg" (ppr role $$ ppr ty1 $$ ppr ty2) + ; uType env_arg ty1 ty2 } + where + env_arg = env { u_loc = adjustCtLoc is_vis False (u_loc env) + , u_role = role } + + ------------------ + -- For AppTy, decompose only nominal equalities + -- See Note [Decomposing AppTy equalities] in GHC.Tc.Solver.Equality + go_app vis ty1 s1 t1 ty2 s2 t2 + | Nominal <- role + = -- Unify arguments t1/t2 before function s1/s2, because + -- the former have smaller kinds, and hence simpler error messages + -- c.f. GHC.Tc.Solver.Equality.can_eq_app + -- Example: test T8603 + do { let env_arg = env { u_loc = adjustCtLoc vis False (u_loc env) } + ; co_t <- uType env_arg t1 t2 + ; co_s <- uType env s1 s2 + ; return $ mkAppCo co_s co_t } + | otherwise + = defer ty1 ty2 + +{- Note [Check for equality before deferring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Particularly in ambiguity checks we can get equalities like (ty ~ ty). +If ty involves a type function we may defer, which isn't very sensible. +An egregious example of this was in test T9872a, which has a type signature + Proxy :: Proxy (Solutions Cubes) +Doing the ambiguity check on this signature generates the equality + Solutions Cubes ~ Solutions Cubes +and currently the constraint solver normalises both sides at vast cost. +This little short-cut in 'defer' helps quite a bit. + +Note [Care with type applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note: type applications need a bit of care! +They can match FunTy and TyConApp, so use splitAppTy_maybe +NB: we've already dealt with type variables and Notes, +so if one type is an App the other one jolly well better be too + +Note [Mismatched type lists and application decomposition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we find two TyConApps, you might think that the argument lists +are guaranteed equal length. But they aren't. Consider matching + w (T x) ~ Foo (T x y) +We do match (w ~ Foo) first, but in some circumstances we simply create +a deferred constraint; and then go ahead and match (T x ~ T x y). +This came up in #3950. + +So either + (a) either we must check for identical argument kinds + when decomposing applications, + + (b) or we must be prepared for ill-kinded unification sub-problems + +Currently we adopt (b) since it seems more robust -- no need to maintain +a global invariant. + +Note [Expanding synonyms during unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We expand synonyms during unification, but: + * We expand *after* the variable case so that we tend to unify + variables with un-expanded type synonym. This just makes it + more likely that the inferred types will mention type synonyms + understandable to the user + + * Similarly, we expand *after* the CastTy case, just in case the + CastTy wraps a variable. + + * We expand *before* the TyConApp case. For example, if we have + type Phantom a = Int + and are unifying + Phantom Int ~ Phantom Char + it is *wrong* to unify Int and Char. + + * The problem case immediately above can happen only with arguments + to the tycon. So we check for nullary tycons *before* expanding. + This is particularly helpful when checking (* ~ *), because * is + now a type synonym. See Note [Unifying type synonyms] in GHC.Core.Unify. + +Note [Deferred unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically, +and yet its consistency is undetermined. Previously, there was no way to still +make it consistent. So a mismatch error was issued. + +Now these unifications are deferred until constraint simplification, where type +family instances and given equations may (or may not) establish the consistency. +Deferred unifications are of the form + F ... ~ ... +or x ~ ... +where F is a type function and x is a type variable. +E.g. + id :: x ~ y => x -> y + id e = e + +involves the unification x = y. It is deferred until we bring into account the +context x ~ y to establish that it holds. + +If available, we defer original types (rather than those where closed type +synonyms have already been expanded via tcCoreView). This is, as usual, to +improve error messages. + +************************************************************************ +* * + uUnfilledVar and friends +* * +************************************************************************ + +@uunfilledVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +back into @uTys@ if it turns out that the variable is already bound. +-} + +---------- +uUnfilledVar, uUnfilledVar1 + :: UnifyEnv + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2 + -> TcM CoercionN +-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar +-- It might be a skolem, or untouchable, or meta +uUnfilledVar env swapped tv1 ty2 + | Nominal <- u_role env + = do { ty2 <- liftZonkM $ zonkTcType ty2 + -- Zonk to expose things to the occurs check, and so + -- that if ty2 looks like a type variable then it + -- /is/ a type variable + ; uUnfilledVar1 env swapped tv1 ty2 } + + | otherwise -- See Note [Do not unify representational equalities] + -- in GHC.Tc.Solver.Equality + = unSwap swapped (uType_defer env) (mkTyVarTy tv1) ty2 + +uUnfilledVar1 env -- Precondition: u_role==Nominal + swapped + tv1 + ty2 -- ty2 is zonked + | Just tv2 <- getTyVar_maybe ty2 + = go tv2 + + | otherwise + = uUnfilledVar2 env swapped tv1 ty2 + + where + -- 'go' handles the case where both are + -- tyvars so we might want to swap + -- E.g. maybe tv2 is a meta-tyvar and tv1 is not + go tv2 | tv1 == tv2 -- Same type variable => no-op + = return (mkNomReflCo (mkTyVarTy tv1)) + + | swapOverTyVars False tv1 tv2 -- Distinct type variables + -- Swap meta tyvar to the left if poss + = do { tv1 <- liftZonkM $ zonkTyCoVarKind tv1 + -- We must zonk tv1's kind because that might + -- not have happened yet, and it's an invariant of + -- uUnfilledTyVar2 that ty2 is fully zonked + -- Omitting this caused #16902 + ; uUnfilledVar2 env (flipSwap swapped) tv2 (mkTyVarTy tv1) } + + | otherwise + = uUnfilledVar2 env swapped tv1 ty2 + +---------- +uUnfilledVar2 :: UnifyEnv -- Precondition: u_role==Nominal + -> SwapFlag + -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar + -- definitely not a /filled/ meta-tyvar + -> TcTauType -- Type 2, zonked + -> TcM CoercionN +uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2 + = do { cur_lvl <- getTcLevel + -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles + -- Here we don't know about given equalities; so we treat + -- /any/ level outside this one as untouchable. Hence cur_lvl. + ; if simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2 /= SUC_CanUnify + then not_ok_so_defer cur_lvl + else + do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs + + -- Attempt to unify kinds + -- When doing so, be careful to preserve orientation; + -- see Note [Kind Equality Orientation] in GHC.Tc.Solver.Equality + -- and wrinkle (W2) in Note [Fundeps with instances, and equality orientation] + -- in GHC.Tc.Solver.Dict + -- Failing to preserve orientation led to #25597. + ; let kind_env = unSwap swapped (mkKindEnv env) ty1 ty2 + ; co_k <- unSwap swapped (uType kind_env) (tyVarKind tv1) (typeKind ty2) + + ; traceTc "uUnfilledVar2 ok" $ + vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) + , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) + , ppr (isReflCo co_k), ppr co_k ] + + ; if isReflCo co_k + -- Only proceed if the kinds match + -- NB: tv1 should still be unfilled, despite the kind unification + -- because tv1 is not free in ty2' (or, hence, in its kind) + then do { liftZonkM $ writeMetaTyVar tv1 ty2 + ; case u_unified env of + Nothing -> return () + Just uref -> updTcRef uref (tv1 :) + ; return (mkNomReflCo ty2) } -- Unification is always Nominal + + else -- The kinds don't match yet, so defer instead. + do { writeTcRef def_eq_ref def_eqs + -- Since we are discarding co_k, also discard any constraints + -- emitted by kind unification; they are just useless clutter. + -- Do this dicarding by simply restoring the previous state + -- of def_eqs; a bit imperative/yukky but works fine. + ; defer } + }} + where + ty1 = mkTyVarTy tv1 + defer = unSwap swapped (uType_defer env) ty1 ty2 + + not_ok_so_defer cur_lvl = + do { traceTc "uUnfilledVar2 not ok" $ + vcat [ text "tv1:" <+> ppr tv1 + , text "ty2:" <+> ppr ty2 + , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2) + ] + -- Occurs check or an untouchable: just defer + -- NB: occurs check isn't necessarily fatal: + -- eg tv1 occurred in type family parameter + ; defer } + +swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool +swapOverTyVars is_given tv1 tv2 + -- See Note [Unification variables on the left] + | not is_given, pri1 == 0, pri2 > 0 = True + | not is_given, pri2 == 0, pri1 > 0 = False + + -- Level comparison: see Note [TyVar/TyVar orientation] + | lvl1 `strictlyDeeperThan` lvl2 = False + | lvl2 `strictlyDeeperThan` lvl1 = True + + -- Priority: see Note [TyVar/TyVar orientation] + | pri1 > pri2 = False + | pri2 > pri1 = True + + -- Names: see Note [TyVar/TyVar orientation] + | isSystemName tv2_name, not (isSystemName tv1_name) = True + + | otherwise = False + + where + lvl1 = tcTyVarLevel tv1 + lvl2 = tcTyVarLevel tv2 + pri1 = lhsPriority tv1 + pri2 = lhsPriority tv2 + tv1_name = Var.varName tv1 + tv2_name = Var.varName tv2 + + +lhsPriority :: TcTyVar -> Int +-- Higher => more important to be on the LHS +-- => more likely to be eliminated +-- Only used when the levels are identical +-- See Note [TyVar/TyVar orientation] +lhsPriority tv + = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + RuntimeUnk -> 0 + SkolemTv {} -> 0 + MetaTv { mtv_info = info, mtv_tclvl = lvl } + | QLInstVar <- lvl + -> 5 -- Eliminate instantiation variables first + | otherwise + -> case info of + CycleBreakerTv -> 0 + TyVarTv -> 1 + ConcreteTv {} -> 2 + TauTv -> 3 + RuntimeUnkTv -> 4 + +{- Note [Unification preconditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Question: given a homogeneous equality (alpha ~# ty), when is it OK to +unify alpha := ty? +(This note only applies to /homogeneous/ equalities, in which both +sides have the same kind.) + +There are five reasons not to unify: + +1. (SKOL-ESC) Skolem-escape + Consider the constraint + forall[2] a[2]. alpha[1] ~ Maybe a[2] + If we unify alpha := Maybe a, the skolem 'a' may escape its scope. + The level alpha[1] says that alpha may be used outside this constraint, + where 'a' is not in scope at all. So we must not unify. + + Bottom line: when looking at a constraint alpha[n] := ty, do not unify + if any free variable of 'ty' has level deeper (greater) than n + +2. (UNTOUCHABLE) Untouchable unification variables + Consider the constraint + forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int + There is no (SKOL-ESC) problem with unifying alpha := Int, but it might + not be the principal solution. Perhaps the "right" solution is alpha := b. + We simply can't tell. See "OutsideIn(X): modular type inference with local + assumptions", section 2.2. We say that alpha[1] is "untouchable" inside + this implication. + + Bottom line: at ambient level 'l', when looking at a constraint + alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities + between levels 'n' and 'l'. + + Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)? + Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + +3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs + This precondition looks at the MetaInfo of the unification variable: + + * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a + TyVarTv it can only unify with a type variable, not with a + structured type. So if 'ty' is a structured type, such as (Maybe x), + don't unify. + + * CycleBreakerTv: never unified, except by restoreTyVarCycles. + +4. (CONCRETE) A ConcreteTv can only unify with a concrete type, + by definition. + + That is, if we have `rr[conc] ~ F Int`, we can't unify + `rr` with `F Int`, so we hold off on unifying. + Note however that the equality might get rewritten; for instance + if we can rewrite `F Int` to a concrete type, say `FloatRep`, + then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`. + + Note that we can still make progress on unification even if + we can't fully solve an equality, e.g. + + alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ] + + we can fill beta[tau] := beta[conc]. This is why we call + 'makeTypeConcrete' in startSolvingByUnification. + +5. (REWRITERS) the equality does not have any unsolved equalities in its rewriter + set. If those other equalities have not been solved, unifying this equality + will propagate strange-looking errors elswhere. That is the whole point of + rewriter sets. Suppose our equality is + [W] co1 {rew = {cok}} (alpha :: k) ~ (Int |> {cok}) + where co :: Type ~ k is an unsolved wanted. Note that this equality + is homogeneous; both sides have kind k. We refrain from unifying + here, because of `cok` in its rewriter set. See + Note [Unify only if the rewriter set is empty] in GHC.Solver.Equality. + +Needless to say, all there are wrinkles: + +* (SKOL-ESC) Promotion. Given alpha[n] ~ ty, what if beta[k] is free + in 'ty', where beta is a unification variable, and k>n? 'beta' + stands for a monotype, and since it is part of a level-n type + (equal to alpha[n]), we must /promote/ beta to level n. Just make + up a fresh gamma[n], and unify beta[k] := gamma[n]. + +* (TYVAR-TV) Unification variables. Suppose alpha[tyv,n] is a level-n + TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now + consider alpha[tyv,n] ~ Bool. We don't want to unify because that + would break the TyVarTv invariant. + + What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary + TauTv? Again, don't unify, because beta might later be unified + with, say Bool. (If levels permit, we reverse the orientation here; + see Note [TyVar/TyVar orientation].) + +* (UNTOUCHABLE) Untouchability. When considering (alpha[n] ~ ty), how + do we know whether there are any given equalities between level n + and the ambient level? We answer in two ways: + + * In the eager unifier, we only unify if l=n. If not, alpha may be + untouchable, and defer to the constraint solver. This check is + made in GHC.Tc.Utils.uUnifilledVar2, in the guard + isTouchableMetaTyVar. + + * In the constraint solver, we track where Given equalities occur + and use that to guard unification in + GHC.Tc.Utils.Unify.touchabilityTest. More details in + Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet + + Historical note: in the olden days (pre 2021) the constraint solver + also used to unify only if l=n. Equalities were "floated" out of the + implication in a separate step, so that they would become touchable. + But the float/don't-float question turned out to be very delicate, + as you can see if you look at the long series of Notes associated with + GHC.Tc.Solver.floatEqualities, around Nov 2020. It's much easier + to unify in-place, with no floating. + +Note [TyVar/TyVar orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Fundeps with instances, and equality orientation] +where the kind equality orientation is important + +Given (a ~ b), should we orient the equality as (a~b) or (b~a)? +This is a surprisingly tricky question! + +The question is answered by swapOverTyVars, which is used + - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1 + - in the constraint solver, in GHC.Tc.Solver.Equality.canEqCanLHS2 + +First note: only swap if you have to! + See Note [Avoid unnecessary swaps] + +So we look for a positive reason to swap, using a three-step test: + +* Level comparison. If 'a' has deeper level than 'b', + put 'a' on the left. See Note [Deeper level on the left] + +* Priority. If the levels are the same, look at what kind of + type variable it is, using 'lhsPriority'. + + Generally speaking we always try to put a MetaTv on the left in + preference to SkolemTv or RuntimeUnkTv, because the MetaTv may be + touchable and can be unified. + + Tie-breaking rules for MetaTvs: + - CycleBreakerTv: This is essentially a stand-in for another type; + it's untouchable and should have the same priority as a skolem: 0. + + - TyVarTv: These can unify only with another tyvar, but we can't unify + a TyVarTv with a TauTv, because then the TyVarTv could (transitively) + get a non-tyvar type. So give these a low priority: 1. + + - ConcreteTv: These are like TauTv, except they can only unify with + a concrete type. So we want to be able to write to them, but not quite + as much as TauTvs: 2. + + - TauTv: This is the common case; we want these on the left so that they + can be written to: 3. + + - RuntimeUnkTv: These aren't really meta-variables used in type inference, + but just a convenience in the implementation of the GHCi debugger. + Eagerly write to these: 4. See Note [RuntimeUnkTv] in + GHC.Runtime.Heap.Inspect. + +* Names. If the level and priority comparisons are all + equal, try to eliminate a TyVar with a System Name in + favour of ones with a Name derived from a user type signature + +* Age. At one point in the past we tried to break any remaining + ties by eliminating the younger type variable, based on their + Uniques. See Note [Eliminate younger unification variables] + (which also explains why we don't do this any more) + +Note [Unification variables on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of +level, so that the unification variable is on the left. + +* We /don't/ want this for Givens because if we ave + [G] a[2] ~ alpha[1] + [W] Bool ~ a[2] + we want to rewrite the wanted to Bool ~ alpha[1], + so we can float the constraint and solve it. + +* But for Wanteds putting the unification variable on + the left means an easier job when floating, and when + reporting errors -- just fewer cases to consider. + + In particular, we get better skolem-escape messages: + see #18114 + +Note [Deeper level on the left] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The most important thing is that we want to put tyvars with +the deepest level on the left. The reason to do so differs for +Wanteds and Givens, but either way, deepest wins! Simple. + +* Wanteds. Putting the deepest variable on the left maximise the + chances that it's a touchable meta-tyvar which can be solved. + +* Givens. Suppose we have something like + forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2] + + If we orient the Given a[2] on the left, we'll rewrite the Wanted to + (beta[1] ~ b[1]), and that can float out of the implication. + Otherwise it can't. By putting the deepest variable on the left + we maximise our changes of eliminating skolem capture. + + See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason + to orient with the deepest skolem on the left. + + IMPORTANT NOTE: this test does a level-number comparison on + skolems, so it's important that skolems have (accurate) level + numbers. + +See #15009 for an further analysis of why "deepest on the left" +is a good plan. + +Note [Avoid unnecessary swaps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we swap without actually improving matters, we can get an infinite loop. +Consider + work item: a ~ b + inert item: b ~ c +We canonicalise the work-item to (a ~ c). If we then swap it before +adding to the inert set, we'll add (c ~ a), and therefore kick out the +inert guy, so we get + new work item: b ~ c + inert item: c ~ a +And now the cycle just repeats + +Historical Note [Eliminate younger unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a choice of unifying + alpha := beta or beta := alpha +we try, if possible, to eliminate the "younger" one, as determined +by `ltUnique`. Reason: the younger one is less likely to appear free in +an existing inert constraint, and hence we are less likely to be forced +into kicking out and rewriting inert constraints. + +This is a performance optimisation only. It turns out to fix +#14723 all by itself, but clearly not reliably so! + +It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars). +But, to my surprise, it didn't seem to make any significant difference +to the compiler's performance, so I didn't take it any further. Still +it seemed too nice to discard altogether, so I'm leaving these +notes. SLPJ Jan 18. + +Note [Prevent unification with type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We prevent unification with type families because of an uneasy compromise. +It's perfectly sound to unify with type families, and it even improves the +error messages in the testsuite. It also modestly improves performance, at +least in some cases. But it's disastrous for test case perf/compiler/T3064. +Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a. +What do we do? Do we reduce F? Or do we use the given? Hard to know what's +best. GHC reduces. This is a disaster for T3064, where the type's size +spirals out of control during reduction. If we prevent +unification with type families, then the solver happens to use the equality +before expanding the type family. + +It would be lovely in the future to revisit this problem and remove this +extra, unnecessary check. But we retain it for now as it seems to work +better in practice. + +Revisited in Nov '20, along with removing flattening variables. Problem +is still present, and the solution is still the same. + +Note [Non-TcTyVars in GHC.Tc.Utils.Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because the same code is now shared between unifying types and unifying +kinds, we sometimes will see proper TyVars floating around the unifier. +Example (from test case polykinds/PolyKinds12): + + type family Apply (f :: k1 -> k2) (x :: k1) :: k2 + type instance Apply g y = g y + +When checking the instance declaration, we first *kind-check* the LHS +and RHS, discovering that the instance really should be + + type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y + +During this kind-checking, all the tyvars will be TcTyVars. Then, however, +as a second pass, we desugar the RHS (which is done in functions prefixed +with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper +TyVars, not TcTyVars, get some kind unification must happen. + +Thus, we always check if a TyVar is a TcTyVar before asking if it's a +meta-tyvar. + +This used to not be necessary for type-checking (that is, before * :: *) +because expressions get desugared via an algorithm separate from +type-checking (with wrappers, etc.). Types get desugared very differently, +causing this wibble in behavior seen here. +-} + +-- | Breaks apart a function kind into its pieces. +matchExpectedFunKind + :: TypedThing -- ^ type, only for errors + -> Arity -- ^ n: number of desired arrows + -> TcKind -- ^ fun_kind + -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) + +matchExpectedFunKind hs_ty n k = go n k + where + go 0 k = return (mkNomReflCo k) + + go n k | Just k' <- coreView k = go n k' + + go n k@(TyVarTy kvar) + | isMetaTyVar kvar + = do { maybe_kind <- readMetaTyVar kvar + ; case maybe_kind of + Indirect fun_kind -> go n fun_kind + Flexi -> defer n k } + + go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | isVisibleFunArg af + = do { co <- go (n-1) res + ; return (mkNakedFunCo Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } + + go n other + = defer n other + + defer n k + = do { arg_kinds <- newMetaKindVars n + ; res_kind <- newMetaKindVar + ; let new_fun = mkVisFunTysMany arg_kinds res_kind + origin = TypeEqOrigin { uo_actual = k + , uo_expected = new_fun + , uo_thing = Just hs_ty + , uo_visible = True + } + ; unifyTypeAndEmit KindLevel origin k new_fun } + +{- ********************************************************************* +* * + Checking alpha ~ ty + for the on-the-fly unifier +* * +********************************************************************* -} + +data UnifyCheckCaller + = UC_OnTheFly -- Called from the on-the-fly unifier + | UC_QuickLook -- Called from Quick Look + | UC_Solver -- Called from constraint solver + +-- | The result type of 'simpleUnifyCheck'. +data SimpleUnifyResult + -- | Definitely cannot unify (untouchable variable or incompatible top-shape) + = SUC_CannotUnify + -- | The variable is touchable and the top-shape test passed, but + -- it may or may not be OK to unify + | SUC_NotSure + -- | Definitely OK to unify + | SUC_CanUnify + deriving stock (Eq, Ord, Show) +instance Semigroup SimpleUnifyResult where + no@SUC_CannotUnify <> _ = no + SUC_CanUnify <> r = r + _ <> no@SUC_CannotUnify = no + r <> SUC_CanUnify = r + ns@SUC_NotSure <> SUC_NotSure = ns + +instance Outputable SimpleUnifyResult where + ppr = \case + SUC_CannotUnify -> text "SUC_CannotUnify" + SUC_NotSure -> text "SUC_NotSure" + SUC_CanUnify -> text "SUC_CanUnify" + +simpleUnifyCheck :: UnifyCheckCaller -> TcLevel -> TcTyVar -> TcType -> SimpleUnifyResult +-- ^ A fast check for unification. May return "not sure", in which case +-- unification might still be OK, but it'll take more work to do +-- (use the full 'checkTypeEq'). +-- +-- * Rejects if lhs_tv occurs in rhs_ty (occurs check) +-- * Rejects foralls unless +-- lhs_tv is RuntimeUnk (used by GHCi debugger) +-- or is a QL instantiation variable +-- * Rejects a non-concrete type if lhs_tv is concrete +-- * Rejects type families unless fam_ok=True +-- * Does a level-check for type variables, to avoid skolem escape +-- +-- This function is pretty heavily used, so it's optimised not to allocate +simpleUnifyCheck caller given_eq_lvl lhs_tv rhs + | not $ touchabilityTest given_eq_lvl lhs_tv + = SUC_CannotUnify + | not $ checkTopShape lhs_info rhs + = SUC_CannotUnify + | rhs_is_ok rhs + = SUC_CanUnify + | otherwise + = SUC_NotSure + where + lhs_info = metaTyVarInfo lhs_tv + + !(occ_in_ty, occ_in_co) = mkOccFolders (tyVarName lhs_tv) + + lhs_tv_lvl = tcTyVarLevel lhs_tv + lhs_tv_is_concrete = isConcreteTyVar lhs_tv + + forall_ok = case caller of + UC_QuickLook -> isQLInstTyVar lhs_tv + _ -> isRuntimeUnkTyVar lhs_tv + + -- This fam_ok thing relates to a very specific perf problem + -- See Note [Prevent unification with type families] + -- A couple of QuickLook regression tests rely on unifying with type + -- families, so we let it through there (not very principled, but let's + -- see if it bites us) + fam_ok = case caller of + UC_Solver -> True + UC_QuickLook -> True + UC_OnTheFly -> False + + rhs_is_ok (TyVarTy tv) + | lhs_tv == tv = False + | tcTyVarLevel tv `strictlyDeeperThan` lhs_tv_lvl = False + | lhs_tv_is_concrete, not (isConcreteTyVar tv) = False + | occ_in_ty $! (tyVarKind tv) = False + | otherwise = True + + rhs_is_ok (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) + | not forall_ok, isInvisibleFunArg af = False + | otherwise = rhs_is_ok w && rhs_is_ok a && rhs_is_ok r + + rhs_is_ok (TyConApp tc tys) + | lhs_tv_is_concrete, not (isConcreteTyCon tc) = False + | not forall_ok, not (isTauTyCon tc) = False + | not fam_ok, not (isFamFreeTyCon tc) = False + | otherwise = all rhs_is_ok tys + + rhs_is_ok (ForAllTy (Bndr tv _) ty) + | forall_ok = rhs_is_ok (tyVarKind tv) && (tv == lhs_tv || rhs_is_ok ty) + | otherwise = False + + rhs_is_ok (AppTy t1 t2) = rhs_is_ok t1 && rhs_is_ok t2 + rhs_is_ok (CastTy ty co) = not (occ_in_co co) && rhs_is_ok ty + rhs_is_ok (CoercionTy co) = not (occ_in_co co) + rhs_is_ok (LitTy {}) = True + + +mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool) +-- These functions return True +-- * if lhs_tv occurs (incl deeply, in the kind of variable) +-- * if there is a coercion hole +-- No expansion of type synonyms +mkOccFolders lhs_tv = (getAny . check_ty, getAny . check_co) + where + !(check_ty, _, check_co, _) = foldTyCo occ_folder emptyVarSet + occ_folder = TyCoFolder { tcf_view = noView -- Don't expand synonyms + , tcf_tyvar = do_tcv, tcf_covar = do_tcv + , tcf_hole = do_hole + , tcf_tycobinder = do_bndr } + + do_tcv is v = Any (not (v `elemVarSet` is) && tyVarName v == lhs_tv) + `mappend` check_ty (varType v) + + do_bndr is tcv _faf = extendVarSet is tcv + do_hole _is _hole = DM.Any True -- Reject coercion holes + +{- ********************************************************************* +* * + Equality invariant checking +* * +********************************************************************* -} + + +{- Note [Checking for foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never want to unify + alpha ~ (forall a. a->a) -> Int +So we look for foralls hidden inside the type, and it's convenient +to do that at the same time as the occurs check (which looks for +occurrences of alpha). + +However, it's not just a question of looking for foralls /anywhere/! +Consider + (alpha :: forall k. k->*) ~ (beta :: forall k. k->*) +This is legal; e.g. dependent/should_compile/T11635. + +We don't want to reject it because of the forall in beta's kind, but +(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type) +we do need to look in beta's kind. So we carry a flag saying if a +'forall' is OK, and switch the flag on when stepping inside a kind. + +Why is it OK? Why does it not count as impredicative polymorphism? +The reason foralls are bad is because we reply on "seeing" foralls +when doing implicit instantiation. But the forall inside the kind is +fine. We'll generate a kind equality constraint + (forall k. k->*) ~ (forall k. k->*) +to check that the kinds of lhs and rhs are compatible. If alpha's +kind had instead been + (alpha :: kappa) +then this kind equality would rightly complain about unifying kappa +with (forall k. k->*) + +Note [Forgetful synonyms in checkTyConApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type S a b = b -- Forgets 'a' + + [W] alpha[2] ~ Maybe (S beta[4] gamma[2]) + +We don't want to promote beta to level 2; rather, we should +expand the synonym. (Currently, in checkTypeEqRhs promotion +is irrevocable, by side effect.) + +To avoid this risk we eagerly expand forgetful synonyms. +This also means we won't get an occurs check in + a ~ Maybe (S a b) + +The annoyance is that we might expand the synonym unnecessarily, +something we generally try to avoid. But for now, this seems +simple. + +In a forgetful case like a ~ Maybe (S a b), `checkTyEqRhs` returns +a Reduction that looks + Reduction { reductionCoercion = Refl + , reductionReducedType = Maybe b } +We must jolly well use that reductionReduced type, even though the +reductionCoercion is Refl. See `canEqCanLHSFinish_no_unification`. +-} + +data PuResult a b + -- | Pure unifier failure. + -- + -- Invariant: the CheckTyEqResult is not 'cteOK'; that it, it specifies a problem. + = PuFail CheckTyEqResult + -- | Pure unifier success. + | PuOK (Bag a) b + deriving stock (Functor, Foldable, Traversable) + +instance Applicative (PuResult a) where + pure x = PuOK emptyBag x + PuFail p1 <*> PuFail p2 = PuFail (p1 S.<> p2) + PuFail p1 <*> PuOK {} = PuFail p1 + PuOK {} <*> PuFail p2 = PuFail p2 + PuOK c1 f <*> PuOK c2 x = PuOK (c1 `unionBags` c2) (f x) + +instance (Outputable a, Outputable b) => Outputable (PuResult a b) where + ppr (PuFail prob) = text "PuFail" <+> (ppr prob) + ppr (PuOK cts x) = text "PuOK" <> braces + (vcat [ text "redn:" <+> ppr x + , text "cts:" <+> ppr cts ]) + +okCheckRefl :: TcType -> PuResult a Reduction +okCheckRefl ty = PuOK emptyBag (mkReflRedn Nominal ty) + +mapCheck :: Monad m + => (x -> m (PuResult a Reduction)) + -> [x] + -> m (PuResult a Reductions) +mapCheck f xs + = do { (ress :: [PuResult a Reduction]) <- mapM f xs + ; return (unzipRedns <$> sequenceA ress) } + -- sequenceA :: [PuResult a Reduction] -> PuResult a [Reduction] + -- unzipRedns :: [Reduction] -> Reductions +{-# INLINEABLE mapCheck #-} + +----------------------------- +-- | Options describing how to deal with a type equality +-- in the eager unifier. See 'checkTyEqRhs' +data TyEqFlags m a + = -- | TFTyFam: LHS is a type family application + -- Invariant: we are not unifying; see `notUnifying_TEFTask` + TEFTyFam + { tefTyFam_occursCheck :: CheckTyEqProblem + -- ^ The 'CheckTyEqProblem' to report for occurs-check failures + -- (soluble or insoluble) + , tefTyFam_tyCon :: TyCon + , tefTyFam_args :: [Type] + , tef_fam_app :: TyEqFamApp m a + -- ^ How to deal with type family applications + } + + -- | TEFTyVar: LHS is a 'TyVar'. + | TEFTyVar + -- NB: this constructor does not actually store a 'TyVar', in order to + -- support being called from 'makeTypeConcrete' (which works as if we + -- created a fresh 'ConcreteTv' metavariable; see (3) in Note [TyEqFlags]) + { tefTyVar_occursCheck :: OccursCheck + -- ^ Occurs check + , tefTyVar_levelCheck :: LevelCheck m + -- ^ Level check + , tefTyVar_concreteCheck :: ConcreteCheck m + -- ^ Concreteness check + , tef_fam_app :: TyEqFamApp m a + -- ^ How to deal with type family applications + } + +-- | What to do when encountering a type-family application while processing +-- a type equality in the pure unifier. +-- +-- See Note [Family applications in canonical constraints] +data TyEqFamApp m a where + -- | Just recurse + TEFA_Recurse :: TyEqFamApp m a + -- | Recurse, but replace with cycle breaker if that fails, + -- using the specified 'FamAppBreaker' + TEFA_Break :: FamAppBreaker a -> TyEqFamApp TcM a + +-- | A defunctionalisation of family application breaker functions. +-- Interpreter: `famAppBreaker` +data FamAppBreaker a where + BreakGiven :: FamAppBreaker (TcTyVar, TcType) + BreakWanted :: CtEvidence -> TcTyVar -> FamAppBreaker Ct + +data OccursCheck where + -- | No occurs check. + OC_None :: OccursCheck + -- | Do an occurs check between the LHS tyvar and the RHS. + OC_Check :: + { occurs_tv_name :: Name + -- ^ The 'Name' to perform an occurs-check on + , occurs_problem :: CheckTyEqProblem + -- ^ Which 'CheckTyEqProblem' to report for occurs-check failures + -- (soluble or insoluble) + } -> OccursCheck + +-- | What level check to perform, in a call to the pure unifier? +-- A defunctionalisation of the possible level-check functions +-- Interpreter: `tyVarLevelCheck` +data LevelCheck m where + -- | No level check. + LC_None :: LevelCheck m + -- | Do a level check between the LHS tyvar and the occurrence tyvar. + -- + -- Fail if the level check fails. + -- + -- True <=> lenient check, e.g. the levels have a chance of working out + -- after promotion. + LC_Check :: + { lc_lvlc :: TcLevel + , lc_lenient :: Bool + } -> LevelCheck m + + -- | Do a level check between the LHS tyvar and the occurrence tyvar. + -- + -- If the level check fails, and the occurrence is a unification + -- variable, promote it. + -- + -- - False <=> don't promote under type families (the common case) + -- - True <=> promote even under type families + -- (see Note [Defaulting equalities] in GHC.Tc.Solver) + LC_Promote + :: { lc_lvlp :: TcLevel + , lc_deep :: Bool + } -> LevelCheck TcM + +data ConcreteCheck m where + -- | No concreteness check. + CC_None :: ConcreteCheck m + -- | Simple check for concreteness, leniently returning 'OK' + -- if concreteness could be achieved after promotion. + CC_Check :: ConcreteCheck m + -- | Proper concreteness check: promote non-concrete metavariables, + -- failing if there are any problems. + CC_Promote :: ConcreteTvOrigin -> ConcreteCheck TcM + +{- Note [TyEqFlags] +~~~~~~~~~~~~~~~~~~~ +When we call the eager unifier, e.g. through 'checkTyEqRhs', we specify what +kind of checks the unifier performs via the 'TyEqFlags' argument. In particular, +when the LHS type in a unification is a type variable, we might want to perform +different checks; this is achieved using the 'TEFTyVar' constructor to 'TyEqFlags': + + 1. `notUnifying_TEFTask` + LHS is a skolem tyvar, or an untouchable meta-tyvar. + We are not unifying; we only want to perform occurs-checks. + + TEFTyVar + { tefTyVar_occursCheck = OC_Check ... + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_None + , tef_fam_app = TEFA_Recurse + } + + 2a. `unifyingLHSMetaTyVar_TEFTask` + We are unifying; we want to perform an occurs check, a level check, + and a concreteness check (when the meta-tyvar is a ConcreteTv). + + TEFTyVar + { tefTyVar_occursCheck = OC_Check ... + , tefTyVar_levelCheck = LC_Promote ... + , tefTyVar_concreteCheck = CC_Promote or CC_None + -- depending on whether or not the lhs tv is concrete + , tef_fam_app = TEFA_Recurse + } + + 2b. `defaulting_TEFTask` + We are in the top-level defaulting code, considering unifying a + touchable meta-tyvar with a type. + + TEFTyVar + { tefTyVar_occursCheck = OC_None + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_Promote or CC_None + -- depending on whether or not the lhs tv is concrete + , tef_fam_app = TEFA_Recurse + } + + 3. `makeTypeConcrete` + LHS is a fresh ConcreteTv meta-tyvar (see call to 'checkTyEqRhs' in + `makeTypeConcrete`). We are unifying; we only want to perform + a concreteness check. + + TEFTyVar + { tefTyVar_occursCheck = OC_None + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_Promote conc_orig + , tef_fam_app = TEFA_Recurse + } + + 4. `pureTyEqFlags_LHSMetaTyVar` + We want to perform a non-monadic check, i.e. we want to know whether we are able + to unify 'lhs_tv' with 'rhs_ty', but don't want to actually perform + a side-effecting unification. This is used in 'mightEqualLater'. + + TEFTyVar + { tefTyVar_occursCheck = OC_Check ... + , tefTyVar_levelCheck = LC_Check ... + , tefTyVar_concreteCheck = CC_Check or CC_None + -- depending on whether or not the lhs tv is concrete + , tef_fam_app = TEFA_Recurse + } + + Here 'LC_Check True' and 'ConcreteSimpleCheck' make 'checkTyEqRhs' perform + conservative pure checks, without actually carrying out any promotion. +-} + +-- | Create a "not unifying" 'TyEqFlags' from a 'CanEqLHS'. +-- +-- See use-case (1) in Note [TyEqFlags]. +notUnifying_TEFTask :: CheckTyEqProblem -> CanEqLHS -> TyEqFlags m a +notUnifying_TEFTask occ_prob = \case + TyFamLHS tc tys -> + TEFTyFam + { tefTyFam_tyCon = tc + , tefTyFam_args = tys + , tefTyFam_occursCheck = occ_prob + , tef_fam_app = TEFA_Recurse + } + TyVarLHS tv -> + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName tv) occ_prob + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_None + , tef_fam_app = TEFA_Recurse + } + -- We need an occurs-check here, but no level check. + -- See Note [Promotion and level-checking] wrinkle (W1) + -- TEFA_Recurse: see Note [Don't cycle-break Wanteds when not unifying] + +-- | Create "unifying" 'TyEqFlags' from a 'TyVarLHS'. +-- +-- Invariant: the argument 'TcTyVar' is a 'MetaTv'. +unifyingLHSMetaTyVar_TEFTask :: CtEvidence -> TcTyVar -> TyEqFlags TcM Ct +unifyingLHSMetaTyVar_TEFTask ev lhs_tv = + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs + , tefTyVar_levelCheck = LC_Promote { lc_lvlp = tcTyVarLevel lhs_tv + , lc_deep = False } + , tefTyVar_concreteCheck = mkConcreteCheck lhs_tv + , tef_fam_app = mkTEFA_Break ev NomEq (BreakWanted ev lhs_tv) + } + +defaulting_TEFTask :: TcTyVar -> TyEqFlags TcM a +-- Used during top-level defauting in GHC.Tc.Solver.Default.defaultEquality +-- Invariant: the argument 'TcTyVar' is a 'MetaTv'. +defaulting_TEFTask lhs_tv = + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs + , tefTyVar_levelCheck = LC_Promote { lc_lvlp = tcTyVarLevel lhs_tv + , lc_deep = True } + -- LC_Promote: promote deeper unification variables (DE4) + -- lc_deep = True: ...including under type families (DE5) + , tefTyVar_concreteCheck = mkConcreteCheck lhs_tv + , tef_fam_app = TEFA_Recurse + } + +mkConcreteCheck :: TcTyVar -> ConcreteCheck TcM +mkConcreteCheck lhs_tv = case isConcreteTyVar_maybe lhs_tv of + Nothing -> CC_None + Just conc_orig -> CC_Promote conc_orig + +-- | 'TyEqFlags' for a pure call of 'checkTyEqRhs'. +-- +-- A call to 'checkTyEqRhs' with these 'TyEqFlags' will perform an optimistic +-- check: it will return 'PuFail' if there is definitely a problem, but it +-- might return 'PuOK' if it isn't entirely sure. +pureTyEqFlags_LHSMetaTyVar :: TyVar -> TyEqFlags Identity () +pureTyEqFlags_LHSMetaTyVar lhs_tv = + TEFTyVar + { tefTyVar_occursCheck = OC_Check (tyVarName lhs_tv) cteInsolubleOccurs + , tefTyVar_levelCheck = LC_Check { lc_lvlc = tcTyVarLevel lhs_tv + , lc_lenient = True } + , tefTyVar_concreteCheck = case isConcreteTyVar_maybe lhs_tv of + Nothing -> CC_None + Just {} -> CC_Check -- No promotion + , tef_fam_app = TEFA_Recurse } + + +mkTEFA_Break :: CtEvidence -> EqRel -> FamAppBreaker a -> TyEqFamApp TcM a +mkTEFA_Break ev eq_rel breaker + | NomEq <- eq_rel + , not cycle_breaker_origin + = TEFA_Break breaker + | otherwise + = TEFA_Recurse + where + -- cycle_breaker_origin: see Detail (7) of Note [Type equality cycles] + -- in GHC.Tc.Solver.Equality + cycle_breaker_origin = case ctLocOrigin (ctEvLoc ev) of + CycleBreakerOrigin {} -> True + _ -> False + +-- | Do we want to perform a concreteness check in 'checkTyEqRhs'? +tefConcrete :: TyEqFlags m a -> Bool +tefConcrete (TEFTyFam {}) = False +tefConcrete (TEFTyVar { tefTyVar_concreteCheck = conc }) = + wantConcreteCheck conc + +wantConcreteCheck :: ConcreteCheck m -> Bool +wantConcreteCheck = \case + CC_None -> False + CC_Check -> True + CC_Promote {} -> True + +-- | Given a family-application @ty@, return a @'Reduction' :: ty ~ cbv@ +-- where @cbv@ is a fresh loop-breaker tyvar (for Given), or +-- just a fresh 'TauTv' (for Wanted) +famAppBreaker :: FamAppBreaker a -> TcType -> TcM (PuResult a Reduction) +famAppBreaker BreakGiven fam_app + = do { new_tv <- TcM.newCycleBreakerTyVar (typeKind fam_app) + ; return (PuOK (unitBag (new_tv, fam_app)) + (mkReflRedn Nominal (mkTyVarTy new_tv))) } + -- Why reflexive? See Detail (4) of Note [Type equality cycles] + -- in GHC.Tc.Solver.Equality +famAppBreaker (BreakWanted ev lhs_tv) fam_app + -- Occurs check or skolem escape; so flatten + = do { reason <- checkPromoteFreeVars cteInsolubleOccurs + (tyVarName lhs_tv) lhs_tv_lvl + (tyCoVarsOfType fam_app_kind) + ; if not (cterHasNoProblem reason) -- Failed to promote free vars + then return $ PuFail reason + else + do { new_tv_ty <- + case lhs_tv_info of + ConcreteTv conc_info -> + -- Make a concrete tyvar if lhs_tv is concrete + -- e.g. alpha[2,conc] ~ Maybe (F beta[4]) + -- We want to flatten to + -- alpha[2,conc] ~ Maybe gamma[2,conc] + -- gamma[2,conc] ~ F beta[4] + TcM.newConcreteTyVarTyAtLevel conc_info lhs_tv_lvl fam_app_kind + _ -> TcM.newMetaTyVarTyAtLevel lhs_tv_lvl fam_app_kind + + ; let pty = mkNomEqPred fam_app new_tv_ty + ; hole <- TcM.newCoercionHole pty + ; let new_ev = WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = cb_loc + , ctev_rewriters = ctEvRewriters ev } + ; return (PuOK (singleCt (mkNonCanonical $ CtWanted new_ev)) + (mkReduction (HoleCo hole) new_tv_ty)) } } + where + fam_app_kind = typeKind fam_app + (lhs_tv_info, lhs_tv_lvl) = + case tcTyVarDetails lhs_tv of + MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl) + -- lhs_tv should be a meta-tyvar + _ -> pprPanic "famAppBreaker BreakWanted: lhs_tv is not a meta-tyvar" + (ppr lhs_tv) + cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin + -- CycleBreakerOrigin: see Detail (7) of Note [Type equality cycles] + +instance Outputable (TyEqFlags m a) where + ppr = \case + TEFTyFam occ tc tys fam_app -> + text "TEFTyFam" <> braces ( + hcat [ ppr occ + , ppr (mkTyConApp tc tys) + , ppr fam_app ] ) + TEFTyVar occ lc conc fam_app -> + text "TEFTyVar" <> braces (hcat (punctuate comma fields)) + where + fields = [ text "OccursCheck:" <+> ppr occ ] + ++ + [ text "LevelCheck:" <+> ppr lc ] + ++ + [ text "ConcreteCheck:" <+> ppr conc ] + ++ + [ text "FamApp:" <+> ppr fam_app ] + +instance Outputable (TyEqFamApp m a) where + ppr TEFA_Recurse = text "TEFA_Recurse" + ppr (TEFA_Break breaker) = text "TEFA_BreakGiven" <+> ppr breaker + +instance Outputable (FamAppBreaker a) where + ppr BreakGiven = text "BreakGiven" + ppr (BreakWanted ev tv) = parens $ text "BreakWanted" <+> ppr ev <+> ppr tv + +instance Outputable OccursCheck where + ppr OC_None = text "OC_None" + ppr (OC_Check { occurs_tv_name = nm }) = text "OC_Check" <+> ppr nm +instance Outputable (ConcreteCheck m) where + ppr CC_None = text "CC_None" + ppr CC_Check = text "CC_Check" + ppr (CC_Promote {}) = text "CC_Promote" +instance Outputable (LevelCheck m) where + ppr (LC_None) = text "LC_None" + ppr (LC_Check lvl lenient) = text "LC_Check" <+> ppr lvl <+> ppWhen lenient (text "(lenient)") + ppr (LC_Promote lvl deep) = text "LC_Promote" <+> ppr lvl <+> ppWhen deep (text "(deep)") + +-- | Adjust the 'TyEqFlags' when going under a type family: +-- +-- 1. Only the outer family application gets the loop-breaker treatment +-- 2. Weaken level checks for tyvar promotion. For example, in @[W] alpha[2] ~ Maybe (F beta[3])@, +-- do not promote @beta[3]@, instead promote @(F beta[3])@. +-- 3. Occurs checks become potentially soluble (after additional type family +-- reductions). +famAppArgFlags :: TyEqFlags m a -> TyEqFlags m a +famAppArgFlags flags = case flags of + TEFTyFam {} -> + flags + { tef_fam_app = TEFA_Recurse -- (1) + , tefTyFam_occursCheck = cteSolubleOccurs -- (3) + } + TEFTyVar { tefTyVar_occursCheck = occ, tefTyVar_levelCheck = mb_lc } -> + flags + { tef_fam_app = TEFA_Recurse -- (1) + , tefTyVar_levelCheck = zap_lc mb_lc -- (2) + , tefTyVar_occursCheck = soluble_occ occ -- (3) + } + where + soluble_occ = \case + OC_Check tv _ -> OC_Check tv cteSolubleOccurs + OC_None -> OC_None + zap_lc = \case + LC_Promote { lc_lvlp = lvl, lc_deep = deeply } + | not deeply + -> LC_Check { lc_lvlc = lvl, lc_lenient = False } + lc -> lc + +{- Note [checkTyEqRhs] +~~~~~~~~~~~~~~~~~~~~~~ +The key function `checkTyEqRhs ty_eq_flags rhs` is called on the +RHS of a type equality + lhs ~ rhs +and checks to see if `rhs` satisfies, or can be made to satisfy, +invariants described by `ty_eq_flags`. It can succeded or fail; in +the latter case it returns a `CheckTyEqResult` that describes why it +failed. + +When `lhs` is a touchable type variable, so unification might happen, then +`checkTyEqRhs` enforces the unification preconditions of Note [Unification preconditions]. + +Notably, it can check for things like: + * Insoluble occurs check + e.g. alpha[tau] ~ [alpha] + or F Int ~ [F Int] + * Potentially-soluble occurs check + e.g. alpha[tau] ~ [F alpha beta] + * Impredicativity error: + e.g. alpha[tau] ~ (forall a. a->a) + * Skolem escape + e.g alpha[1] ~ (b[sk:2], Int) + * Concreteness error + e.g. alpha[conc] ~ r[sk] + +Its specific behaviour is governed by the `TyEqFlags` that are passed +to it; see Note [TyEqFlags]. + +Note, however, that `checkTyEqRhs` specifically does /not/ check for: + * Touchability of the LHS (in the case of a unification variable) + * Shape of the LHS (e.g. we can't unify Int with a TyVarTv) +These things are checked by `simpleUnifyCheck`. +-} + + +-- | Perform the checks specified by the 'TyEqFlags' on the RHS, in order to +-- enforce the unification preconditions of Note [Unification preconditions]. +-- +-- See Note [checkTyEqRhs]. +checkTyEqRhs :: forall m a + . Monad m + => TyEqFlags m a + -> TcType -- Already zonked + -> m (PuResult a Reduction) +checkTyEqRhs flags rhs + -- Crucial special case for a top-level equality of the form 'alpha ~ F tys'. + -- We don't want to flatten that (F tys), as this gets us right back to where + -- we started! + -- + -- See also Note [Special case for top-level of Given equality] + | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs + , not $ tefConcrete flags + = recurseIntoFamTyConApp flags tc tys + | otherwise + = check_ty_eq_rhs flags rhs + +{- Note [Special case for top-level of Given equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We take care when examining + [G] F ty ~ G (...(F ty)...) +where both sides are TyFamLHSs. We don't want to flatten that RHS to + [G] F ty ~ cbv + [G] G (...(F ty)...) ~ cbv +Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a +canonical constraint + [G] G (...(F ty)...) ~ F ty +That tends to rewrite a big type to smaller one. This happens in T15703, +where we had: + [G] Pure g ~ From1 (To1 (Pure g)) +Making a loop breaker and rewriting left to right just makes much bigger +types than swapping it over. + +(We might hope to have swapped it over before getting to checkTypeEq, +but better safe than sorry.) + +NB: We never see a TyVarLHS here, such as + [G] a ~ F tys here +because we'd have swapped it to + [G] F tys ~ a +in canEqCanLHS2, before getting to checkTypeEq. +-} + +check_ty_eq_rhs :: forall m a + . Monad m + => TyEqFlags m a + -> TcType -- Already zonked + -> m (PuResult a Reduction) +check_ty_eq_rhs flags ty + = case ty of + LitTy {} -> return $ okCheckRefl ty + TyConApp tc tys -> checkTyConApp flags ty tc tys + TyVarTy tv -> checkTyVar flags tv + -- Don't worry about foralls inside the kind; see Note [Checking for foralls] + -- Nor can we expand synonyms; see Note [Occurrence checking: look inside kinds] + -- in GHC.Core.FVs + + FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r} + | isInvisibleFunArg af -- e.g. Num a => blah + -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F) + | otherwise + -> do { w_res <- check_ty_eq_rhs flags w + ; a_res <- check_ty_eq_rhs flags a + ; r_res <- check_ty_eq_rhs flags r + ; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) } + + AppTy fun arg -> do { fun_res <- check_ty_eq_rhs flags fun + ; arg_res <- check_ty_eq_rhs flags arg + ; return (mkAppRedn <$> fun_res <*> arg_res) } + + CastTy ty co -> do { ty_res <- check_ty_eq_rhs flags ty + ; co_res <- checkCo flags co + ; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) } + + CoercionTy co -> do { co_res <- checkCo flags co + ; return (mkReflCoRedn Nominal <$> co_res) } + + ForAllTy {} -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F) +{-# INLINEABLE check_ty_eq_rhs #-} + +------------------- +checkCo :: Monad m => TyEqFlags m a -> Coercion -> m (PuResult a Coercion) +-- See Note [checkCo] +checkCo flags co = + case flags of + TEFTyFam {} -> + -- NB: 'TEFTyFam' case means we are not unifying. + return (pure co) + TEFTyVar + { tefTyVar_concreteCheck = conc + , tefTyVar_levelCheck = lc + , tefTyVar_occursCheck = occ + } + -- Coercions cannot appear in concrete types. + -- + -- See Note [Concrete types] in GHC.Tc.Utils.Concrete. + | case conc of { CC_None -> False; _ -> True } + -> return $ PuFail (cteProblem cteConcrete) + + -- Occurs check (can promote) + | OC_Check lhs_tv occ_prob <- occ + , LC_Promote { lc_lvlp = lhs_tv_lvl } <- lc + -> do { reason <- checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl (tyCoVarsOfCo co) + ; return $ + if cterHasNoProblem reason + then pure co + else PuFail reason } + + -- Occurs check (no promotion) + | OC_Check lhs_tv occ_prob <- occ + , nameUnique lhs_tv `elemVarSetByKey` tyCoVarsOfCo co + -> return $ PuFail (cteProblem occ_prob) + + | otherwise + -> return (pure co) + +{- Note [checkCo] +~~~~~~~~~~~~~~~~~ +We don't often care about the contents of coercions, so checking +coercions before making an equality constraint may be surprising. +But there are several cases we need to be wary of: + +(1) When we're unifying a variable, we must make sure that the variable + appears nowhere on the RHS -- even in a coercion. Otherwise, we'll + create a loop. + +(2) We must still make sure that no variable in a coercion is at too + high a level. But, when unifying, we can promote any variables we encounter. + +Note [Promotion and level-checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +"Promotion" happens when we have this: + + [W] w1: alpha[2] ~ Maybe beta[4] + +Here we must NOT unify alpha := Maybe beta, because beta may turn out +to stand for a type involving some inner skolem. Yikes! +Skolem-escape. So instead we /promote/ beta, like this: + + beta[4] := beta'[2] + [W] w1: alpha[2] ~ Maybe beta'[2] + +Now we can unify alpha := Maybe beta', which might unlock other +constraints. But if some other constraint wants to unify beta with a +nested skolem, it'll get stuck with a skolem-escape error. + +Now consider `w2` where a type family is involved (#22194): + + [W] w2: alpha[2] ~ Maybe (F gamma beta[4]) + +In `w2`, it may or may not be the case that `beta` is level 2; suppose +we later discover gamma := Int, and type instance F Int _ = Int. +So, instead, we promote the entire funcion call: + + [W] w2': alpha[2] ~ Maybe gamma[2] + [W] w3: gamma[2] ~ F gamma beta[4] + +Now we can unify alpha := Maybe gamma, which is a Good Thng. + +Wrinkle (W1) + +There is an important wrinkle: /all this only applies when unifying/. +For example, suppose we have + [G] a[2] ~ Maybe b[4] +where 'a' is a skolem. This Given might arise from a GADT match, and +we can absolutely use it to rewrite locally. In fact we must do so: +that is how we exploit local knowledge about the outer skolem a[2]. +This applies equally for a Wanted [W] a[2] ~ Maybe b[4]. Using it for +local rewriting is fine. (It's not clear to me that it is /useful/, +but it's fine anyway.) + +So we only do the level-check in checkTyVar when /unifying/ not for +skolems (or untouchable unification variables). + +Note [Family applications in canonical constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A constraint with a type family application in the RHS needs special care. +This is dealt with by `checkFamApp`. + +(CFA1) First, occurs checks. If we have + [G] a ~ Maybe (F (Maybe a)) + [W] alpha ~ Maybe (F (Maybe alpha)) + it looks as if we have an occurs check. But go read + Note [Type equality cycles] in GHC.Tc.Solver.Equality + + The same considerations apply when the LHS is a type family: + [G] G a ~ Maybe (F (Maybe (G a))) + [W] G alpha ~ Maybe (F (Maybe (G alpha))) + +(CFA2) Second, promotion. If we have (#22194) + [W] alpha[2] ~ Maybe (F beta[4]) + it is wrong to promote beta. Instead we want to split to + [W] alpha[2] ~ Maybe gamma[2] + [W] gamma[2] ~ F beta[4] + See Note [Promotion and level-checking] above. + +(CFA3) Third, concrete type variables. If we have + [W] alpha[conc] ~ Maybe (F tys) + we want to add an extra variable thus: + [W] alpha[conc] ~ Maybe gamma[conc] + [W] gamma[conc] ~ F tys + Now we can unify alpha, and that might unlock something else. + +In all these cases we want to create a fresh type variable, and +emit a new equality connecting it to the type family application. + +Once these three cases are dealt with, the `tef_fam_app` field of `TypeEqFlags` +says what to do: + +(CFA4) `TEFA_Recurse` is straightforward: just recurse into the arguments, + BUT use `recurseIntoFamTyConApp` to record that we are now "under" a + type-family application; see `famAppArgFlags`. + +(CFA5) `TEFA_Break` is the clever one. It does a two-step process: + + (1) Recurse into the arguments with `recurseIntoFamTyConApp`. + + (2) If any of the arguments fail (level-check error, occurs check, + concreteness failure), use the `FamAppBreaker` to create a cycle breaker. + + Remarks: + + * It would be possible to use Step (2) above always, skipping Step (1). + But this would create many unnecessary cycle-breaker variables. + This was the cause of #25933. + + * This always cycle-breaks the /outermost/ family application. + If we have [W] alpha ~ Maybe (F (G alpha)): + - We'll use checkFamApp on `(F (G alpha))` + - In Step (1), `recurseIntoFamTyConApp` sets `tef_fam_app := TEFA_Recurse`, + before looking at the argument `(G alpha)`. So we will not cycle-break + the latter + - The occurs check will fire when we hit `alpha` + - `checkFamApp` on `(F (G alpha))` will see the failure and invoke + the `FamAppBreaker`. + + * Step (1) may fail because of a level-check problem, which activates step (2). + This is what implements (CFA2). +-} + +------------------- +checkTyConApp :: Monad m + => TyEqFlags m a + -> TcType -> TyCon -> [TcType] + -> m (PuResult a Reduction) +checkTyConApp flags tc_app tc tys + | isTypeFamilyTyCon tc + , let arity = tyConArity tc + = if tys `lengthIs` arity + then checkFamApp flags tc_app tc tys -- Common case + else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys + fun_app = mkTyConApp tc fun_args + ; fun_res <- checkFamApp flags fun_app tc fun_args + ; extra_res <- mapCheck (check_ty_eq_rhs flags) extra_args + ; return (mkAppRedns <$> fun_res <*> extra_res) } + + | Just ty' <- rewriterView tc_app + -- e.g. S a where type S a = F [a] + -- or type S a = Int + -- See Note [Forgetful synonyms in checkTyConApp] + = check_ty_eq_rhs flags ty' + + | not (isTauTyCon tc) + = return $ PuFail impredicativeProblem + + | tefConcrete flags + , not (isConcreteTyCon tc) + = return $ PuFail (cteProblem cteConcrete) + + | otherwise -- Recurse on arguments + = recurseIntoTyConApp flags tc tys + +------------------- +recurseIntoTyConApp :: Monad m + => TyEqFlags m a + -> TyCon -> [TcType] + -> m (PuResult a Reduction) +recurseIntoTyConApp flags tc tys + = do { tys_res <- mapCheck (check_ty_eq_rhs flags) tys + ; return (mkTyConAppRedn Nominal tc <$> tys_res) } + +recurseIntoFamTyConApp :: Monad m + => TyEqFlags m a + -> TyCon -> [TcType] + -> m (PuResult a Reduction) +recurseIntoFamTyConApp flags tc tys + = recurseIntoTyConApp (famAppArgFlags flags) tc tys + -- famAppArgFlags: adjust flags when going under fam app + +------------------- + +-- | See Note [Family applications in canonical constraints] +checkFamApp :: forall m a. + Monad m + => TyEqFlags m a + -> TcType -> TyCon -> [TcType] -- Saturated family application + -> m (PuResult a Reduction) +checkFamApp flags fam_app tc tys = + case flags of + TEFTyFam { tefTyFam_tyCon = lhs_tc, tefTyFam_args = lhs_tys + , tefTyFam_occursCheck = occ_prob } + | tcEqTyConApps lhs_tc lhs_tys tc tys + -- There is an occurs check F ty ~ ...(F ty)... + -- Do not recurse; see (CFA1) in Note [Family applications in canonical constraints] + -> do_not_recurse occ_prob + TEFTyVar { tefTyVar_concreteCheck = conc } + | wantConcreteCheck conc + -- We are checking for concreteness, e.g. kappa[conc] ~ ...(F ty)... + -- Do not recurse: type family applications are not concrete. + -- See (CFA3) in Note [Family applications in canonical constraints] + -> do_not_recurse cteConcrete + _ -> + -- We can recurse into the arguments of the type family application. + case fam_flags of + TEFA_Recurse -> + -- Simply recurse into the arguments. + -- See (CFA4) in Note [Family applications in canonical constraints] + recurseIntoFamTyConApp flags tc tys + TEFA_Break brk -> + -- Recurse into the arguments, and cycle-break if that fails + -- + -- e.g. alpha[2] ~ Maybe (F beta[2]) No problem: just unify + -- alpha[2] ~ Maybe (F beta[4]) Level-check problem: break + -- + -- NB: in the latter case, don't promote beta[4]; use 'recurseIntoFamTyConApp' + -- which modifies the flags with 'famAppArgFlags'. + do { rec_res <- recurseIntoFamTyConApp flags tc tys + ; case rec_res of + PuOK {} -> return rec_res + PuFail {} -> famAppBreaker brk fam_app + } + where + fam_flags = tef_fam_app flags + do_not_recurse prob = + case fam_flags of + TEFA_Recurse -> return $ PuFail (cteProblem prob) + TEFA_Break brk -> famAppBreaker brk fam_app + +------------------- + +-- | The result of a single check in 'checkTyVar', such as a concreteness check +-- or a level check. +data TyVarCheckResult m where + -- | Check succeded; nothing else to do. + TyVarCheck_Success :: TyVarCheckResult m + -- | Check succeeded, but requires an additional promotion. + -- + -- Invariant: at least one of the fields is not 'Nothing'. + TyVarCheck_Promote + :: Maybe TcLevel + -- ^ @Just lvl@ <=> 'TyVar' needs to be promoted to @lvl@ + -> Maybe ConcreteTvOrigin + -- ^ @Just conc_orig@ <=> 'TyVar' needs to be make concrete + -> TyVarCheckResult TcM + + -- | Check failed with some 'CheckTyEqProblem's. + -- + -- Invariant: the 'CheckTyEqResult' is not 'cteOK'. + TyVarCheck_Error + :: CheckTyEqResult -> TyVarCheckResult m + +instance Semigroup (TyVarCheckResult m) where + TyVarCheck_Success <> r = r + r <> TyVarCheck_Success = r + TyVarCheck_Error e1 <> TyVarCheck_Error e2 = + TyVarCheck_Error (e1 S.<> e2) + e@(TyVarCheck_Error {}) <> _ = e + _ <> e@(TyVarCheck_Error {}) = e + TyVarCheck_Promote l1 c1 <> TyVarCheck_Promote l2 c2 = + TyVarCheck_Promote + (combineMaybe minTcLevel l1 l2) + (combineMaybe const c1 c2) -- pick one 'ConcreteTvOrigin' arbitrarily + +combineMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +combineMaybe _ Nothing r = r +combineMaybe _ r Nothing = r +combineMaybe f (Just a) (Just b) = Just (f a b) +instance Monoid (TyVarCheckResult m) where + mempty = TyVarCheck_Success + +checkTyVar :: forall m a. Monad m => TyEqFlags m a -> TcTyVar -> m (PuResult a Reduction) +checkTyVar flags occ_tv + = case flags of + TEFTyFam {} + -> success -- Nothing to do if the LHS is a type-family + TEFTyVar { tefTyVar_occursCheck = occ, tefTyVar_levelCheck = lc + , tefTyVar_concreteCheck = conc } + -> do { already_promoted <- promotionDone occ_tv lc conc + + ; if already_promoted + then success + -- Already promoted; job done + -- Example alpha[2] ~ Maybe (beta[4], beta[4]) + -- We promote the first occurrence, and then encounter it + -- a second time; we don't want to re-promote it! + -- Remember, the entire process started with a fully zonked type + -- so the only reason for a filled meta-tyvar is promotion + + else do_rhs_checks + [ simpleOccursCheck occ occ_tv + , tyVarLevelCheck lc occ_tv + , tyVarConcretenessCheck conc occ_tv ] + } + where + success = return $ okCheckRefl (mkTyVarTy occ_tv) + + -- Combine the results of individual checks. See 'TyVarCheckResult'. + do_rhs_checks :: [TyVarCheckResult m] -> m (PuResult a Reduction) + do_rhs_checks checks = + case mconcat checks of + TyVarCheck_Success -> success + TyVarCheck_Promote mb_lvl mb_conc -> promote flags mb_lvl mb_conc + TyVarCheck_Error cte_prob -> return $ PuFail cte_prob + + --------------------- + -- occ_tv is definitely a MetaTyVar; we need to promote it/make it concrete + promote :: TyEqFlags TcM a -> Maybe TcLevel -> Maybe ConcreteTvOrigin + -> TcM (PuResult a Reduction) + promote flags mb_lhs_tv_lvl mb_conc + | MetaTv { mtv_info = info_occ, mtv_tclvl = lvl_occ } <- tcTyVarDetails occ_tv + = do { let new_info | Just conc <- mb_conc = ConcreteTv conc + | otherwise = info_occ + new_lvl = + case mb_lhs_tv_lvl of + Nothing -> lvl_occ + Just lhs_tv_lvl -> lhs_tv_lvl `minTcLevel` lvl_occ + -- c[conc,3] ~ p[tau,2]: want to clone p:=p'[conc,2] + -- c[tau,2] ~ p[tau,3]: want to clone p:=p'[tau,2] + + -- Check the kind of occ_tv + -- + -- This is important for several reasons: + -- + -- 1. To ensure there is no occurs check or skolem-escape + -- in the kind of occ_tv. + -- 2. If the LHS is a concrete type variable and the RHS is an + -- unfilled meta-tyvar, we need to ensure that the kind of + -- 'occ_tv' is concrete. Test cases: T23051, T23176. + ; let occ_kind = tyVarKind occ_tv + ; kind_result <- check_ty_eq_rhs flags occ_kind + ; for kind_result $ \ kind_redn -> + do { let kind_co = reductionCoercion kind_redn + new_kind = reductionReducedType kind_redn + occ_tv' = setTyVarKind occ_tv new_kind + ; new_tv_ty <- promote_meta_tyvar new_info new_lvl occ_tv' + ; return $ mkGReflLeftRedn Nominal new_tv_ty (mkSymCo kind_co) + } } + + | otherwise = pprPanic "promote" (ppr occ_tv) + +--------------------- +promotionDone :: Monad m => TcTyVar -> LevelCheck m -> ConcreteCheck m -> m Bool +promotionDone occ_tv (LC_Promote {}) _ = isFilledMetaTyVar occ_tv +promotionDone occ_tv _ (CC_Promote {}) = isFilledMetaTyVar occ_tv +promotionDone _ _ _ = return False + +--------------------- +simpleOccursCheck :: OccursCheck -> TcTyVar -> TyVarCheckResult m +-- ^ The "interpreter" for 'OccursCheck' +simpleOccursCheck OC_None _ + = TyVarCheck_Success +simpleOccursCheck (OC_Check lhs_tv occ_prob) occ_tv + | lhs_tv == tyVarName occ_tv || check_kind (tyVarKind occ_tv) + = TyVarCheck_Error (cteProblem occ_prob) + | otherwise + = TyVarCheck_Success + where + (check_kind, _) = mkOccFolders lhs_tv + +------------------------- +tyVarLevelCheck :: LevelCheck m -> TcTyVar -> TyVarCheckResult m +-- ^ The "interpreter" for 'LevelCheck' +tyVarLevelCheck LC_None _ = TyVarCheck_Success +tyVarLevelCheck lc occ_tv + | not occ_is_deeper + = TyVarCheck_Success + | isSkolemTyVar occ_tv + = TyVarCheck_Error (cteProblem cteSkolemEscape) + | otherwise + = case lc of + LC_Check { lc_lenient = lenient } -> + if lenient + then TyVarCheck_Success + else TyVarCheck_Error (cteProblem cteSkolemEscape) + LC_Promote { lc_lvlp = lhs_tv_lvl } -> + TyVarCheck_Promote (Just lhs_tv_lvl) Nothing + where + occ_is_deeper = + case lc of + LC_Check { lc_lvlc = lhs_tv_lvl } -> + tcTyVarLevel occ_tv `strictlyDeeperThan` lhs_tv_lvl + LC_Promote { lc_lvlp = lhs_tv_lvl } -> + tcTyVarLevel occ_tv `strictlyDeeperThan` lhs_tv_lvl + +------------------------- +tyVarConcretenessCheck :: ConcreteCheck m -> TcTyVar -> TyVarCheckResult m +-- ^ The "interpreter" for 'ConcreteCheck' +tyVarConcretenessCheck cc occ_tv + | CC_None <- cc -- No concreteness checks => ok + = TyVarCheck_Success + | isConcreteTyVar occ_tv -- It's concrete already => ok + = TyVarCheck_Success + | not (isMetaTyVar occ_tv) -- Not a meta-tyvar => error + = TyVarCheck_Error (cteProblem cteConcrete) + + | otherwise -- It's a non-concrete meta-tyvar + = case cc of + CC_Check -> TyVarCheck_Success + CC_Promote conc_orig -> TyVarCheck_Promote Nothing (Just conc_orig) + -- CC_None is dealt with at the top + +------------------------- +checkPromoteFreeVars :: CheckTyEqProblem -- What occurs check problem to report + -> Name -> TcLevel + -> TyCoVarSet -> TcM CheckTyEqResult +-- Check this set of TyCoVars for +-- (a) occurs check +-- (b) promote if necessary, or report skolem escape +checkPromoteFreeVars occ_prob lhs_tv lhs_tv_lvl vs + = do { oks <- mapM do_one (nonDetEltsUniqSet vs) + ; return (mconcat oks) } + where + do_one :: TyCoVar -> TcM CheckTyEqResult + do_one v | isCoVar v = return cteOK + | tyVarName v == lhs_tv = return (cteProblem occ_prob) + | no_promotion = return cteOK + | not (isMetaTyVar v) = return (cteProblem cteSkolemEscape) + | otherwise = promote_one v + where + no_promotion = not (tcTyVarLevel v `strictlyDeeperThan` lhs_tv_lvl) + + -- isCoVar case: coercion variables are not an escape risk + -- If an implication binds a coercion variable, it'll have equalities, + -- so the "intervening given equalities" test above will catch it + -- Coercion holes get filled with coercions, so again no problem. + + promote_one :: TyVar -> TcM CheckTyEqResult + promote_one tv = + do { _ <- promote_meta_tyvar TauTv lhs_tv_lvl tv + ; return cteOK } + +promote_meta_tyvar :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcType +promote_meta_tyvar info dest_lvl occ_tv + = do { -- Check whether occ_tv is already unified. The rhs-type + -- started zonked, but we may have promoted one of its type + -- variables, and we then encounter it for the second time. + -- But if so, it'll definitely be another already-checked TyVar + mb_filled <- isFilledMetaTyVar_maybe occ_tv + ; case mb_filled of { + Just ty -> return ty ; + Nothing -> + + -- OK, not done already, so clone/promote it + do { new_tv <- cloneMetaTyVarWithInfo info dest_lvl occ_tv + ; liftZonkM $ writeMetaTyVar occ_tv (mkTyVarTy new_tv) + ; traceTc "promoteTyVar" (ppr occ_tv <+> text "-->" <+> ppr new_tv) + ; return (mkTyVarTy new_tv) } } } + + + +------------------------- +touchabilityTest :: TcLevel -> TcTyVar -> Bool +-- ^ This is the key test for untouchability: +-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify +-- and Note [Solve by unification] in GHC.Tc.Solver.Equality +-- +-- @True@ <=> the variable is touchable +touchabilityTest given_eq_lvl tv + | MetaTv { mtv_tclvl = tv_lvl } <- tcTyVarDetails tv + = tv_lvl `deeperThanOrSame` given_eq_lvl + | otherwise + = False + +------------------------- +-- | checkTopShape checks (TYVAR-TV) +-- Note [Unification preconditions]; returns True if these conditions +-- are satisfied. But see the Note for other preconditions, too. +checkTopShape :: MetaInfo -> TcType -> Bool +checkTopShape info xi + = case info of + TyVarTv -> + case getTyVar_maybe xi of -- Looks through type synonyms + Nothing -> False + Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle + SkolemTv {} -> True + RuntimeUnk -> True + MetaTv { mtv_info = TyVarTv } -> True + _ -> False + CycleBreakerTv -> False -- We never unify these + _ -> True + +-------------------------------------------------------------------------------- +-- Making a type concrete. + +-- | Try to turn the provided type into a concrete type, by ensuring +-- unfilled metavariables are appropriately marked as concrete. +-- +-- Returns a coercion whose RHS is a zonked type which is "as concrete as possible", +-- and a collection of Wanted equality constraints that are necessary to make +-- the type concrete. +-- +-- For example, for an input @TYPE a[sk]@ we will return a coercion with RHS +-- @TYPE gamma[conc]@ together with the Wanted equality constraint @a ~# gamma@. +-- +-- INVARIANT: the RHS type of the returned coercion is equal to the input type, +-- up to zonking and the returned Wanted equality constraints. +-- +-- INVARIANT: if this function returns an empty list of constraints +-- then the RHS type of the returned coercion is concrete, +-- in the sense of Note [Concrete types]. +makeTypeConcrete :: FastString -> ConcreteTvOrigin + -> TcType -> TcM (TcCoercion, Cts) +makeTypeConcrete occ_fs conc_orig ty = + do { traceTc "makeTypeConcrete {" $ + vcat [ text "ty:" <+> ppr ty ] + + -- To make a type 'ty' concrete, we query what would happen were we + -- to try unifying + -- + -- alpha[conc] ~# ty + -- + -- for a fresh concrete metavariable 'alpha'. + -- + -- We do this by calling 'checkTyEqRhs' with suitable 'TyEqFlags'. + -- NB: we don't actually need to create a fresh concrete metavariable + -- in order to call 'checkTyEqRhs'. + ; let ty_eq_flags = + TEFTyVar + { tefTyVar_occursCheck = OC_None + -- LHS is a fresh meta-tyvar: no occurs check needed + , tefTyVar_levelCheck = LC_None + , tefTyVar_concreteCheck = CC_Promote conc_orig + , tef_fam_app = TEFA_Recurse + } + + -- NB: 'checkTyEqRhs' expects a fully zonked type as input. + ; ty' <- liftZonkM $ zonkTcType ty + ; pu_res <- checkTyEqRhs @TcM @() ty_eq_flags ty' + -- NB: 'checkTyEqRhs' will also check the kind, thus upholding the + -- invariant that the kind of a concrete type must also be a concrete type. + + ; (cts, final_co) <- + case pu_res of + PuOK _ redn -> + do { traceTc "makeTypeConcrete: unifier success" $ + vcat [ text "ty:" <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + , text "redn:" <+> ppr redn + ] + ; return (emptyBag, mkSymCo $ reductionCoercion redn) + -- NB: the unifier returns a 'Reduction' with the concrete + -- type on the left, but we want a coercion with it on the + -- right; so we use 'mkSymCo'. + } + PuFail _prob -> + do { traceTc "makeTypeConcrete: unifier failure" $ + vcat [ text "ty:" <+> ppr ty <+> dcolon <+> ppr (typeKind ty) + , text "problem:" <+> ppr _prob + ] + -- We failed to make 'ty' concrete. In order to continue + -- typechecking, we proceed as follows: + -- + -- - create a new concrete metavariable alpha[conc] + -- - emit the equality @ty ~# alpha[conc]@. + -- + -- This equality will eventually get reported as insoluble + -- to the user. + + -- The kind of a concrete metavariable must itself be concrete, + -- so we need to do a concreteness check on the kind first. + ; let ki = typeKind ty + ; (kind_co, kind_cts) <- + if isConcreteType ki + then return (mkNomReflCo ki, emptyBag) + else makeTypeConcrete occ_fs conc_orig ki + + -- Now create the new concrete metavariable. + ; conc_tv <- newConcreteTyVar conc_orig occ_fs (coercionRKind kind_co) + ; let conc_ty = mkTyVarTy conc_tv + pty = mkEqPredRole Nominal ty' conc_ty + ; hole <- newCoercionHole pty + ; loc <- getCtLocM orig (Just KindLevel) + ; let ct = mkNonCanonical $ CtWanted + $ WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; return (kind_cts S.<> unitBag ct, HoleCo hole) + } + + ; traceTc "makeTypeConcrete }" $ + vcat [ text "ty :" <+> _ppr_ty ty + , text "ty':" <+> _ppr_ty ty' + , text "final_co:" <+> _ppr_co final_co ] + + ; return (final_co, cts) + } + where + + _ppr_ty ty = ppr ty <+> dcolon <+> ppr (typeKind ty) + _ppr_co co = ppr co <+> dcolon <+> parens (_ppr_ty (coercionLKind co)) <+> text "~#" <+> parens (_ppr_ty (coercionRKind co)) + + orig :: CtOrigin + orig = case conc_orig of + ConcreteFRR frr_orig -> FRROrigin frr_orig + + +{- ********************************************************************* +* * + mightEqualLater +* * +********************************************************************* -} + +{- Note [What might equal later?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must determine whether a Given might later equal a Wanted: + see Note [Instance and Given overlap] in GHC.Tc.Solver.Dict + +We definitely need to account for the possibility that any metavariable might be +arbitrarily instantiated. Yet we do *not* want to allow skolems to be +instantiated, as we've already rewritten with respect to any Givens. (We're +solving a Wanted here, and so all Givens have already been processed.) + +This is best understood by example. + +1. C alpha[tau] ~? C Int + + That Given certainly might match later. + +2. C a[sk] ~? C Int + + No. No new givens are going to arise that will get the `a` to rewrite + to Int. Example: + f :: forall a. C a => blah + f = rhs -- Gives rise to [W] C Int + It would be silly to fail to solve ([W] C Int), just because we have + ([G] C a) in the Givens! + +3. C alpha[tv] ~? C Int + + In this variant of (1) that alpha[tv] is a TyVarTv, unifiable only with + other type /variables/. It cannot equal Int later. + +4. C (F alpha[tau]) ~? C Int + + Sure -- that can equal later, if we learn something useful about alpha. + +5. C (F alpha[tv]) ~? C Int + + This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere. + Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other, + and F x x = Int. Remember: returning True doesn't commit ourselves to + anything. + +6. C (F a[sk]) ~? C Int. For example + f :: forall a. C (F a) => blah + f = rhs -- Gives rise to [W] C Int + + No, this won't match later. If we could rewrite (F a), we would + have by now. But see also Red Herring below. + + This arises in instance decls too. For example in GHC.Core.Ppr we see + instance Outputable (XTickishId pass) + => Outputable (GenTickish pass) where + If we have [W] Outputable Int in the body, we don't want to fail to solve + it because (XTickishId pass) might simplify to Int. + +7. C (Maybe alpha[tau]) ~? C alpha[tau] + + We say this cannot equal later, because it would require + alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived, + we choose not to worry about it. See Note [Infinitary substitution in lookup] + in GHC.Core.InstEnv. Getting this wrong led to #19107, tested in + typecheck/should_compile/T19107. + +8. C alpha[cbv] ~? C Int + where alpha[cbv] = F a + + The alpha[cbv] is a cycle-breaker var which stands for F a. See + Note [Type equality cycles] in GHC.Tc.Solver.Equality + This is just like case 6, and we say "no". Saying "no" here is + essential in getting the parser to type-check, with its use of DisambECP. + +9. C alpha[cbv] ~? C Int + where alpha[cbv] = F beta[tau] + + Here, we might indeed equal later. Distinguishing between + this case and Example 8 is why we need the InertSet in mightEqualLater. + +10. C (F alpha[tau], Int) ~? C (Bool, F alpha[tau]) + + This cannot equal later, because F alpha would have to equal both Bool and + Int. + +To deal with type family applications, we use the "fine-grained" Core unifier. +See Note [Apartness and type families] in GHC.Core.Unify, controlled +by the `bind_fam :: BindFamFun` function defined in `mightEqualLater`. + +One tricky point: a type family application that mentions only skolems (example +6) is settled: any skolems would have been rewritten w.r.t. Givens by now. These +type family applications match only themselves. However: a type family +application that mentions metavariables, on the other hand, can match +anything. So, if the original type family application contains a metavariable, +we use BindMe to tell the unifier to allow it in the substitution. On the other +hand, a type family application with only skolems is considered rigid. See the +use of `mentions_meta_ty_var` in `mightEqualLater`. + +This treatment fixes #18910 and is tested in +typecheck/should_compile/InstanceGivenOverlap{,2} + +Red Herring +~~~~~~~~~~~ +In #21208, we have this scenario: + + instance forall b. C b + [G] C a[sk] + [W] C (F a[sk]) + +What should we do with that wanted? According to the logic above, the Given +cannot match later (this is example 6), and so we use the global instance. +But wait, you say: What if we learn later (say by a future type instance F a = a) +that F a unifies with a? That looks like the Given might really match later! + +This mechanism described in this Note is *not* about this kind of situation, however. +It is all asking whether a Given might match the Wanted *in this run of the solver*. +It is *not* about whether a variable might be instantiated so that the Given matches, +or whether a type instance introduced in a downstream module might make the Given match. +The reason we care about what might match later is only about avoiding order-dependence. +That is, we don't want to commit to a course of action that depends on seeing constraints +in a certain order. But an instantiation of a variable and a later type instance +don't introduce order dependency in this way, and so mightMatchLater is right to ignore +these possibilities. + +Here is an example, with no type families, that is perhaps clearer: + + instance forall b. C (Maybe b) + [G] C (Maybe Int) + [W] C (Maybe a) + +What to do? We *might* say that the Given could match later and should thus block +us from using the global instance. But we don't do this. Instead, we rely on class +coherence to say that choosing the global instance is just fine, even if later we +call a function with (a := Int). After all, in this run of the solver, [G] C (Maybe Int) +will definitely never match [W] C (Maybe a). (Recall that we process Givens before +Wanteds, so there is no [G] a ~ Int hanging about unseen.) + +Interestingly, in the first case (from #21208), the behavior changed between +GHC 8.10.7 and GHC 9.2, with the latter behaving correctly and the former +reporting overlapping instances. + +Test case: typecheck/should_compile/T21208. + +-} + +-------------------------------------------------------------------------------- +-- mightEqualLater + +mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Maybe Subst +-- See Note [What might equal later?] +-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Dict +mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc + | prohibitedSuperClassSolve given_loc wanted_loc + = Nothing + + | otherwise + = case tcUnifyTysFG bind_fam bind_tv [given_pred] [wanted_pred] of + Unifiable subst + -> Just subst + MaybeApart reason subst + | MARInfinite <- reason -- see Example 7 in the Note. + -> Nothing + | otherwise + -> Just subst + SurelyApart -> Nothing + + where + bind_tv :: BindTvFun + bind_tv tv rhs_ty + | MetaTv { mtv_info = info } <- tcTyVarDetails tv + , ok_shape tv info rhs_ty + , can_unify tv rhs_ty + = BindMe + + | otherwise + = DontBindMe + + bind_fam :: BindFamFun + -- See Examples (4), (5), and (6) from the Note, especially (6) + bind_fam _fam_tc fam_args _rhs + | anyFreeVarsOfTypes mentions_meta_ty_var fam_args = BindMe + | otherwise = DontBindMe + + can_unify :: TcTyVar -> TcType -> Bool + can_unify tv rhs_ty + -- See Note [Use checkTyEqRhs in mightEqualLater] + | PuOK {} <- runIdentity $ checkTyEqRhs (pureTyEqFlags_LHSMetaTyVar tv) rhs_ty + = True + | otherwise + = False + + -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars + -- (as they can be unified) + -- and also for CycleBreakerTvs that mentions meta-tyvars + mentions_meta_ty_var :: TyVar -> Bool + mentions_meta_ty_var tv + | isMetaTyVar tv + = case metaTyVarInfo tv of + -- See Examples 8 and 9 in the Note + CycleBreakerTv -> anyFreeVarsOfType mentions_meta_ty_var + (lookupCycleBreakerVar tv inert_set) + _ -> True + | otherwise + = False + + -- Like checkTopShape, but allows cbv variables to unify + ok_shape :: TcTyVar -> MetaInfo -> Type -> Bool + ok_shape _lhs_tv TyVarTv rhs_ty -- see Example 3 from the Note + | Just rhs_tv <- getTyVar_maybe rhs_ty + = case tcTyVarDetails rhs_tv of + MetaTv { mtv_info = TyVarTv } -> True + MetaTv {} -> False -- Could unify with anything + SkolemTv {} -> True + RuntimeUnk -> True + | otherwise -- not a var on the RHS + = False + ok_shape lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv + +{- Note [Use checkTyEqRhs in mightEqualLater] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'mightEqualLater', we are checking whether two types ty1 and ty2 might become +equal after further unifications. To do this, we call the pure unifier, via +the function 'tcUnifyTysFG'. However, it is important that we don't return +false positives: + + 1. Level check: ty1 = alpha[tau:1] /~ ty2 = k[sk:3] + 2. Occurs check: ty1 = beta[tau] /~ ty2 = Maybe beta[tau] + 3. Concreteness: ty1 = kappa[conc] /~ ty2 = k[sk]. + +In these examples, ty1 and ty2 cannot unify; to inform the pure unifier of this +fact, we use 'checkTyEqRhs' to provide the 'BindTvFun'. + +Failing to account for this caused #25744: + + work item = [W] w1: Eq (g[sk:1] x[sk:3]) + inerts = { [G] g1: Eq x[sk:3] + , [G] g2: forall y. Eq y => Eq (g[sk:1] y) + , [G] g3: Eq (f[tau:1] v[tau:1]) } + +We want to solve w1 using g1 and g2. The presence of g3 is irrelevant, because +we cannot unify 'f[tau:1] v[tau:1]' and 'g[sk:1] x[sk:3]' due to skolem escape. +-} + +-- | Return the type family application a CycleBreakerTv maps to. +lookupCycleBreakerVar :: TcTyVar -- ^ cbv, must be a CycleBreakerTv + -> InertSet + -> TcType -- ^ type family application the cbv maps to +lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack }) +-- This function looks at every environment in the stack. This is necessary +-- to avoid #20231. This function (and its one usage site) is the only reason +-- that we store a stack instead of just the top environment. + | Just tyfam_app <- assert (isCycleBreakerTyVar cbv) $ + firstJusts (NE.map (lookupBag cbv) cbvs_stack) + = tyfam_app + | otherwise + = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack) + +-------------------------------------------------------------------------------- diff --git a/GHC/Tc/Utils/Unify.hs-boot b/GHC/Tc/Utils/Unify.hs-boot --- a/GHC/Tc/Utils/Unify.hs-boot +++ b/GHC/Tc/Utils/Unify.hs-boot @@ -1,17 +1,24 @@ module GHC.Tc.Utils.Unify where import GHC.Prelude -import GHC.Core.Type ( Mult ) -import GHC.Tc.Utils.TcType ( TcTauType ) -import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper ) -import GHC.Tc.Types.Origin ( CtOrigin, TypedThing ) +import GHC.Core.Type ( Mult ) +import GHC.Tc.Utils.TcType ( TcTauType ) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.Constraint ( Cts ) +import GHC.Tc.Types.Evidence ( TcCoercion ) +import GHC.Tc.Types.Origin ( CtOrigin, TypedThing ) +import GHC.Tc.Utils.TcType ( TcType, ConcreteTvOrigin ) +import GHC.Data.FastString ( FastString ) + -- This boot file exists only to tie the knot between -- GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate/GHC.Tc.Utils.TcMType unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion unifyInvisibleType :: TcTauType -> TcTauType -> TcM TcCoercion -tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper +tcSubMult :: CtOrigin -> Mult -> Mult -> TcM () + +makeTypeConcrete :: FastString -> ConcreteTvOrigin + -> TcType -> TcM (TcCoercion, Cts) diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs --- a/GHC/Tc/Validity.hs +++ b/GHC/Tc/Validity.hs @@ -1,9 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -29,13 +26,13 @@ import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) import GHC.Tc.Solver ( simplifyAmbiguityCheck ) import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) ) -import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad -import GHC.Tc.Instance.FunDeps -import GHC.Tc.Instance.Family import GHC.Tc.Zonk.TcType import GHC.Builtin.Types @@ -52,6 +49,7 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Tidy import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches , InjectivityCheckResult(..) ) @@ -60,7 +58,8 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Error -import GHC.Types.Basic ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension ) +import GHC.Types.Basic ( TypeOrKind(..), UnboxedTupleOrSum(..) + , unboxedTupleOrSumExtension ) import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -240,7 +239,7 @@ -- tyvars are skolemised, we can safely use tcSimplifyTop ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; unless allow_ambiguous $ - do { (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ + do { (_wrap, wanted) <- addErrCtxt (AmbiguityCheckCtxt ctxt allow_ambiguous) $ captureConstraints $ tcSubTypeAmbiguity ctxt ty ty -- See Note [Ambiguity check and deep subsumption] @@ -251,13 +250,6 @@ | otherwise = return () - where - mk_msg allow_ambiguous - = vcat [ text "In the ambiguity check for" <+> what - , ppUnless allow_ambiguous ambig_msg ] - ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes" - what | Just n <- isSigMaybe ctxt = quotes (ppr n) - | otherwise = pprUserTypeCtxt ctxt wantAmbiguityCheck :: UserTypeCtxt -> Bool wantAmbiguityCheck ctxt @@ -287,22 +279,12 @@ | TySynCtxt {} <- ctxt -- Do not complain about TypeError on the = return () -- RHS of type synonyms. See #20181 + | Just msg <- deepUserTypeError_maybe ty + = do { env0 <- liftZonkM tcInitTidyEnv + ; let (env1, tidy_msg) = tidyOpenTypeX env0 msg + ; failWithTcM (env1, TcRnUserTypeError tidy_msg) } | otherwise - = check ty - where - check ty - | Just msg <- userTypeError_maybe ty = fail_with msg - | Just (_,t1) <- splitForAllTyCoVar_maybe ty = check t1 - | let (_,tys) = splitAppTys ty = mapM_ check tys - -- splitAppTys keeps type family applications saturated. - -- This means we don't go looking for user type errors - -- inside type family arguments (see #20241). - - fail_with :: Type -> TcM () - fail_with msg = do { env0 <- liftZonkM tcInitTidyEnv - ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, TcRnUserTypeError tidy_msg) - } + = return () {- Note [When we don't check for ambiguity] @@ -390,7 +372,6 @@ = case ctxt of DefaultDeclCtxt-> MustBeMonoType PatSigCtxt -> rank0 - RuleSigCtxt {} -> rank1 TySynCtxt _ -> rank0 ExprSigCtxt {} -> rank1 @@ -414,10 +395,11 @@ SpecInstCtxt -> rank1 GhciCtxt {} -> ArbitraryRank - TyVarBndrKindCtxt _ -> rank0 - DataKindCtxt _ -> rank1 - TySynKindCtxt _ -> rank1 - TyFamResKindCtxt _ -> rank1 + TyVarBndrKindCtxt {} -> rank0 + RuleBndrTypeCtxt{} -> rank1 + DataKindCtxt _ -> rank1 + TySynKindCtxt _ -> rank1 + TyFamResKindCtxt _ -> rank1 _ -> panic "checkValidType" -- Can't happen; not used for *user* sigs @@ -551,7 +533,7 @@ typeOrKindCtxt (TypeAppCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (PatSynCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (PatSigCtxt {}) = OnlyTypeCtxt -typeOrKindCtxt (RuleSigCtxt {}) = OnlyTypeCtxt +typeOrKindCtxt (RuleBndrTypeCtxt {})= OnlyTypeCtxt typeOrKindCtxt (ForSigCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt typeOrKindCtxt (InstDeclCtxt {}) = OnlyTypeCtxt @@ -779,9 +761,18 @@ = check_ubx_tuple_or_sum UnboxedSumType ve ty tys | otherwise - = mapM_ (check_arg_type False ve) tys + = do { -- We require DataKinds to use a type constructor in a kind, unless it + -- is exempted (e.g., Type, TYPE, etc., which is checked by + -- isKindTyCon) or a `type data` type constructor. + -- See Note [Checking for DataKinds]. + unless (isKindTyCon tc || isTypeDataTyCon tc) $ + checkDataKinds ve ty + ; mapM_ (check_arg_type False ve) tys } -check_type _ (LitTy {}) = return () +check_type ve ty@(LitTy {}) = + -- Type-level literals are forbidden from appearing in kinds unless DataKinds + -- is enabled. See Note [Checking for DataKinds]. + checkDataKinds ve ty check_type ve (CastTy ty _) = check_type ve ty @@ -793,7 +784,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 @@ -878,10 +871,8 @@ check_expansion_only expand = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $ case coreView ty of - Just ty' -> let err_ctxt = text "In the expansion of type synonym" - <+> quotes (ppr tc) - in addErrCtxt err_ctxt $ - check_type (ve{ve_expand = expand}) ty' + Just ty' -> addErrCtxt (TySynErrCtxt tc) $ + check_type (ve{ve_expand = expand}) ty' Nothing -> pprPanic "check_syn_tc_app" (ppr ty) {- @@ -929,6 +920,10 @@ ; checkTcM ub_thing_allowed (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty)) + -- Unboxed tuples and sums are forbidden from appearing in kinds + -- unless DataKinds is enabled. See Note [Checking for DataKinds]. + ; checkDataKinds ve ty + ; impred <- xoptM LangExt.ImpredicativeTypes ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg -- c.f. check_arg_type @@ -997,12 +992,22 @@ checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM () checkVdqOK ve tvbs ty = do - checkTcM (vdqAllowed ctxt || no_vdq) + required_type_arguments <- xoptM LangExt.RequiredTypeArguments + checkTcM (required_type_arguments || vdqAllowed ctxt || no_vdq) (env, TcRnVDQInTermType (Just (tidyType env ty))) where no_vdq = all (isInvisibleForAllTyFlag . binderFlag) tvbs ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve +-- | Check for a DataKinds violation in a kind context. +-- See @Note [Checking for DataKinds]@. +checkDataKinds :: ValidityEnv -> Type -> TcM () +checkDataKinds (ValidityEnv{ ve_ctxt = ctxt, ve_tidy_env = env }) ty = do + data_kinds <- xoptM LangExt.DataKinds + checkTcM + (data_kinds || typeLevelUserTypeCtxt ctxt) $ + (env, TcRnDataKindsError KindLevel (Right (tidyType env ty))) + {- Note [No constraints in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC does not allow constraints in kinds. Equality constraints @@ -1076,6 +1081,82 @@ (Eq a => Int) would be treated as a function type (FunTy), which just wouldn't do. +Note [Checking for DataKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Checking whether a piece of code requires -XDataKinds or not is surprisingly +complicated, so here is a specification (adapted from #22141) for what +-XDataKinds does and does not allow. First, some definitions: + +* A user-written type (i.e. part of the source text of a program) is in a + /kind context/ if it follows a `::` in: + * A standalone kind signature, e.g., + type T :: Nat -> Type + * A kind signature in a type, e.g.: + - forall (a :: Nat -> Type). blah + - type F = G :: Nat -> Type + - etc. + * A result kind signature in a type declaration, e.g.: + - data T a :: Nat -> Type where ... + - type family Fam :: Nat -> Type + - etc. + +* All other contexts where types can appear are referred to as /type contexts/. + +* The /kind type constructors/ are (see GHC.Core.TyCon.isKindTyCon): + * TYPE and Type + * CONSTRAINT and Constraint + * LiftedRep + * RuntimeRep, Levity, and their data constructors + * Multiplicity and its data construtors + * VecCount, VecElem, and their data constructors + +* A `type data` type constructor is defined using the -XTypeData extension, such + as the T in `type data T = A | B`. + +* The following are rejected in type contexts unless -XDataKinds is enabled: + * Promoted data constructors (e.g., 'Just), except for those data constructors + listed under /kind type constructors/ + * Promoted list or tuple syntax (e.g., '[Int, Bool] or '(Int, Bool)) + * Type-level literals (e.g., 42, "hello", or 'a' at the type level) + +* The following are rejected in kind contexts unless -XDataKinds is enabled: + * Everything that is rejected in a type context. + * Any type constructor that is not a kind type constructor or a `type data` + type constructor (e.g., Maybe, [], Char, Nat, Symbol, etc.) + + Note that this includes rejecting occurrences of non-kind type construtors + in type synomym (or type family) applications, even it the expansion would + be legal. For example: + + type T a = Type + f :: forall (x :: T Int). blah + + Here the `Int` in `T Int` is rejected even though the expansion is just + `Type`. This is consistent with, for example, rejecting `T (forall a. a->a)` + without -XImpredicativeTypes. + + This check only occurs in kind contexts. It is always permissible to mention + type synonyms in a type context without enabling -XDataKinds, even if the + type synonym expands to something that would otherwise require -XDataKinds. + +Because checking for DataKinds in a kind context requires looking beneath type +synonyms, it is natural to implement these checks in checkValidType, which has +the necessary machinery to check for language extensions in the presence of +type synonyms. For the exact same reason, checkValidType is *not* a good place +to check for DataKinds in a type context, since we deliberately do not want to +look beneath type synonyms there. As a result, we check for DataKinds in two +different places in the code: + +* We check for DataKinds violations in kind contexts in the typechecker. See + checkDataKinds in this module. +* We check for DataKinds violations in type contexts in the renamer. See + checkDataKinds in GHC.Rename.HsType and check_data_kinds in GHC.Rename.Pat. + + Note that the renamer can also catch "obvious" kind-level violations such as + `data Dat :: Proxy 42 -> Type` (where 42 is not hidden beneath a type + synonym), so we also catch a subset of kind-level violations in the renamer + to allow for earlier reporting of these errors. + ************************************************************************ * * \subsection{Checking a theta or source type} @@ -1188,7 +1269,7 @@ check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> ThetaType -> PredType -> TcM () check_quant_pred env dflags ctxt pred theta head_pred - = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $ + = addErrCtxt (QuantifiedCtCtxt pred) $ do { -- Check the instance head case classifyPredType head_pred of -- SigmaCtxt tells checkValidInstHead that @@ -1279,7 +1360,7 @@ -- (Coercible a b) to (a ~R# b) | otherwise - = do { result <- matchGlobalInst dflags False cls tys + = do { result <- matchGlobalInst dflags False cls tys Nothing ; case result of OneInst { cir_what = what } -> addDiagnosticTc (TcRnSimplifiableConstraint pred what) @@ -1345,7 +1426,7 @@ okIPCtxt (ClassSCCtxt {}) = False okIPCtxt (InstDeclCtxt {}) = False okIPCtxt (SpecInstCtxt {}) = False -okIPCtxt (RuleSigCtxt {}) = False +okIPCtxt (RuleBndrTypeCtxt {}) = False okIPCtxt DefaultDeclCtxt = False okIPCtxt DerivClauseCtxt = False okIPCtxt (TyVarBndrKindCtxt {}) = False @@ -1374,11 +1455,9 @@ generalized actually. -} -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, SDoc) +checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) checkThetaCtxt ctxt theta env - = return ( env - , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta) - , text "While checking" <+> pprUserTypeCtxt ctxt ] ) + = return (env, ThetaCtxt ctxt (tidyTypes env theta)) tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report @@ -1456,7 +1535,7 @@ | isAbstractClass clas , hs_src == HsSrcFile = fail_with_inst_err $ IllegalInstanceHead - $ InstHeadAbstractClass clas + $ InstHeadAbstractClass (noUserRdr $ className clas) -- Complain about hand-written instances of built-in classes -- Typeable, KnownNat, KnownSymbol, Coercible, HasField. @@ -1473,7 +1552,9 @@ -- Handwritten instances of KnownNat/KnownChar/KnownSymbol -- are forbidden outside of signature files (#12837). -- Derived instances are forbidden completely (#21087). - | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ] + -- FIXME: DataToTag instances in signature files don't actually work yet + | clas_nm `elem` [ knownNatClassName, knownSymbolClassName + , knownCharClassName, dataToTagClassName ] , (not (hs_src == HsigFile) && hand_written_bindings) || derived_instance -- Note [Instances of built-in classes in signature files] = fail_with_inst_err $ IllegalSpecialClassInstance clas False @@ -1503,7 +1584,11 @@ = checkHasFieldInst clas cls_args | isCTupleClass clas - = failWithTc (TcRnTupleConstraintInst clas) + = do + -- Since we're now declaring instances for constraint tuples in + -- GHC.Classes, this check must exclude that file. + this_mod <- fmap tcg_mod getGblEnv + when (this_mod /= gHC_CLASSES) (failWithTc (TcRnTupleConstraintInst clas)) -- Check language restrictions on the args to the class | check_h98_arg_shape @@ -1624,7 +1709,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, _) @@ -1997,9 +2082,10 @@ ; traceTc "End checkValidInstance }" empty } | otherwise -> failWithTc $ mk_err $ IllegalInstanceHead - $ InstHeadNonClass (Just tc) + $ InstHeadNonClassHead + $ InstNonClassTyCon (noUserRdr $ tyConName tc) (fmap tyConName $ tyConFlavour tc) _ -> failWithTc $ mk_err $ IllegalInstanceHead - $ InstHeadNonClass Nothing + $ InstHeadNonClassHead InstNonTyCon where (theta, tau) = splitInstTyForValidity ty @@ -2498,7 +2584,7 @@ -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. no_bind_set = mkVarSet inst_tvs - bind_me tv _ty | tv `elemVarSet` no_bind_set = Apart + bind_me tv _ty | tv `elemVarSet` no_bind_set = DontBindMe | otherwise = BindMe diff --git a/GHC/Tc/Zonk/Env.hs b/GHC/Tc/Zonk/Env.hs --- a/GHC/Tc/Zonk/Env.hs +++ b/GHC/Tc/Zonk/Env.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoPolyKinds #-} -- | The 'ZonkEnv' zonking environment, and the 'ZonkT' and 'ZonkBndrT' -- monad transformers, for the final zonking to type in "GHC.Tc.Zonk.Type". @@ -61,10 +61,14 @@ -- -- See Note [Un-unified unification variables] data ZonkFlexi - = DefaultFlexi -- ^ Default unbound unification variables to Any - | SkolemiseFlexi -- ^ Skolemise unbound unification variables - -- See Note [Zonking the LHS of a RULE] + = DefaultFlexi -- ^ Default unbound unification variables to Any + + | SkolemiseFlexi -- ^ Skolemise unbound unification variables + (IORef [TyVar]) -- See Note [Zonking the LHS of a RULE] + -- Records the tyvars thus skolemised + | RuntimeUnkFlexi -- ^ Used in the GHCi debugger + | NoFlexi -- ^ Panic on unfilled meta-variables -- See Note [Error on unconstrained meta-variables] -- in GHC.Tc.Utils.TcMType diff --git a/GHC/Tc/Zonk/Monad.hs b/GHC/Tc/Zonk/Monad.hs --- a/GHC/Tc/Zonk/Monad.hs +++ b/GHC/Tc/Zonk/Monad.hs @@ -9,7 +9,7 @@ module GHC.Tc.Zonk.Monad ( -- * The 'ZonkM' monad, a stripped down 'TcM' for zonking ZonkM(ZonkM,runZonkM) - , ZonkGblEnv(..), getZonkGblEnv + , ZonkGblEnv(..), getZonkGblEnv, getZonkTcLevel -- ** Logging within 'ZonkM' , traceZonk @@ -96,6 +96,9 @@ getZonkGblEnv :: ZonkM ZonkGblEnv getZonkGblEnv = ZonkM return {-# INLINE getZonkGblEnv #-} + +getZonkTcLevel :: ZonkM TcLevel +getZonkTcLevel = ZonkM (\env -> return (zge_tc_level env)) -- | Same as 'traceTc', but for the 'ZonkM' monad. traceZonk :: String -> SDoc -> ZonkM () diff --git a/GHC/Tc/Zonk/TcType.hs b/GHC/Tc/Zonk/TcType.hs --- a/GHC/Tc/Zonk/TcType.hs +++ b/GHC/Tc/Zonk/TcType.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} {- (c) The University of Glasgow 2006 @@ -15,7 +16,7 @@ module GHC.Tc.Zonk.Monad -- ** Zonking types - , zonkTcType, zonkTcTypes + , zonkTcType, zonkTcTypes, zonkScaledTcType , zonkTcTyVar, zonkTcTyVars , zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars , zonkInvisTVBinder @@ -37,6 +38,13 @@ -- ** Zonking constraints , zonkCt, zonkWC, zonkSimples, zonkImplication + -- * Rewriter sets + , zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet + + -- * Coercion holes + , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe + + -- * Tidying , tcInitTidyEnv, tcInitOpenTidyEnv , tidyCt, tidyEvVar, tidyDelayedError @@ -75,13 +83,14 @@ import GHC.Core.InstEnv (ClsInst(is_tys)) import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Tidy import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Predicate import GHC.Utils.Constants -import GHC.Utils.Outputable +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Panic @@ -89,6 +98,9 @@ import GHC.Data.Bag import GHC.Data.Pair +import Data.Semigroup +import Data.Maybe + {- ********************************************************************* * * Writing to metavariables @@ -201,6 +213,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 +225,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 @@ -350,8 +366,9 @@ ************************************************************************ -} --- | Check that a coercion is appropriate for filling a hole. (The hole --- itself is needed only for printing.) +-- | Debugging-only! Check that a coercion is appropriate for filling a +-- hole. (The hole itself is needed only for printing.) +-- -- Always returns the checked coercion, but this return value is necessary -- so that the input coercion is forced only when the output is forced. checkCoercionHole :: CoVar -> Coercion -> ZonkM Coercion @@ -362,8 +379,8 @@ ; return $ assertPpr (ok cv_ty) (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) + ppr cv Outputable.<> colon + <+> vcat [ ppr t1, ppr t2, ppr role, ppr cv_ty ]) co } | otherwise = return co @@ -425,6 +442,8 @@ = DE_Hole <$> zonkHole hole zonkDelayedError (DE_NotConcrete err) = DE_NotConcrete <$> zonkNotConcreteError err +zonkDelayedError (DE_Multiplicity mult_co loc) + = DE_Multiplicity <$> zonkCo mult_co <*> pure loc zonkHole :: Hole -> ZonkM Hole zonkHole hole@(Hole { hole_ty = ty }) @@ -488,10 +507,15 @@ ; return (mkNonCanonical fl') } zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence -zonkCtEvidence ctev - = do { let pred = ctev_pred ctev - ; pred' <- zonkTcType pred - ; return (setCtEvPredType ctev pred') } +-- Zonks the ctev_pred and the ctev_rewriters; but not ctev_evar +-- For ctev_rewriters, see (WRW2) in Note [Wanteds rewrite Wanteds] +zonkCtEvidence (CtGiven (GivenCt { ctev_pred = pred, ctev_evar = var, ctev_loc = loc })) + = do { pred' <- zonkTcType pred + ; return (CtGiven (GivenCt { ctev_pred = pred', ctev_evar = var, ctev_loc = loc })) } +zonkCtEvidence (CtWanted wanted@(WantedCt { ctev_pred = pred, ctev_rewriters = rws })) + = do { pred' <- zonkTcType pred + ; rws' <- zonkRewriterSet rws + ; return (CtWanted (wanted { ctev_pred = pred', ctev_rewriters = rws' })) } zonkSkolemInfo :: SkolemInfo -> ZonkM SkolemInfo zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk @@ -527,6 +551,103 @@ %************************************************************************ %* * + Zonking rewriter sets +* * +************************************************************************ +-} + +zonkCtRewriterSet :: Ct -> ZonkM Ct +zonkCtRewriterSet ct + | isGivenCt ct + = return ct + | otherwise + = case ct of + CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CEqCan (eq { eq_ev = ev' })) } + CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CDictCan (di { di_ev = ev' })) } + CQuantCan {} -> return ct + CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev + ; return (CNonCanonical ev') } + +zonkCtEvRewriterSet :: CtEvidence -> ZonkM CtEvidence +zonkCtEvRewriterSet ev@(CtGiven {}) + = return ev +zonkCtEvRewriterSet ev@(CtWanted wtd) + = do { rewriters' <- zonkRewriterSet (ctEvRewriters ev) + ; return (CtWanted $ setWantedCtEvRewriters wtd rewriters') } + +-- | Zonk a rewriter set; if a coercion hole in the set has been filled, +-- find all the free un-filled coercion holes in the coercion that fills it +zonkRewriterSet :: RewriterSet -> ZonkM RewriterSet +zonkRewriterSet (RewriterSet set) + = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set + -- This does not introduce non-determinism, because the only + -- monadic action is to read, and the combining function is + -- commutative + where + go :: CoercionHole -> ZonkM RewriterSet -> ZonkM RewriterSet + go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc + + check_hole :: CoercionHole -> ZonkM RewriterSet + check_hole hole + = do { m_co <- unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return (unitRewriterSet hole) -- Not filled + Just co -> unUCHM (check_co co) } -- Filled: look inside + + check_ty :: Type -> UnfilledCoercionHoleMonoid + check_co :: Coercion -> UnfilledCoercionHoleMonoid + (check_ty, _, check_co, _) = foldTyCo folder () + + folder :: TyCoFolder () UnfilledCoercionHoleMonoid + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) + , tcf_covar = \ _ cv -> check_ty (varType cv) + , tcf_hole = \ _ -> UCHM . check_hole + , tcf_tycobinder = \ _ _ _ -> () } + +newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: ZonkM RewriterSet } + +instance Semigroup UnfilledCoercionHoleMonoid where + UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) + +instance Monoid UnfilledCoercionHoleMonoid where + mempty = UCHM (return emptyRewriterSet) + + +{- +************************************************************************ +* * + Checking for coercion holes +* * +************************************************************************ +-} + +-- | Is a coercion hole filled in? +isFilledCoercionHole :: CoercionHole -> ZonkM Bool +isFilledCoercionHole (CoercionHole { ch_ref = ref }) + = isJust <$> readTcRef ref + +-- | Retrieve the contents of a coercion hole. Panics if the hole +-- is unfilled +unpackCoercionHole :: CoercionHole -> ZonkM Coercion +unpackCoercionHole hole + = do { contents <- unpackCoercionHole_maybe hole + ; case contents of + Just co -> return co + Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } + +-- | Retrieve the contents of a coercion hole, if it is filled +unpackCoercionHole_maybe :: CoercionHole -> ZonkM (Maybe Coercion) +unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref + + +{- +%************************************************************************ +%* * Tidying * * ************************************************************************ @@ -560,12 +681,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' [] @@ -583,6 +703,9 @@ = do { skol_info1 <- zonkSkolemInfoAnon skol_info ; let skol_info2 = tidySkolemInfoAnon env skol_info1 ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) } +zonkTidyOrigin env (ScOrigin (IsQC pred orig) nkd) + = do { (env1, pred') <- zonkTidyTcType env pred + ; return (env1, ScOrigin (IsQC pred' orig) nkd) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp }) = do { (env1, act') <- zonkTidyTcType env act @@ -633,16 +756,23 @@ where go zs env [] = return (env, reverse zs) go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig - , frr_info_not_concrete = mb_not_conc } : tys) + , frr_info_not_concrete = mb_not_conc + , frr_info_other_origin = mb_other_orig + } : tys) = do { (env, ty) <- zonkTidyTcType env ty ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc + ; (env, mb_other_orig) <- + case mb_other_orig of + Nothing -> return (env, Nothing) + Just o -> do { (env', o') <- zonkTidyOrigin env o; return (env', Just o') } ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig - , frr_info_not_concrete = mb_not_conc } + , frr_info_not_concrete = mb_not_conc + , frr_info_other_origin = mb_other_orig } ; go (info:zs) env tys } go_mb_not_conc env Nothing = return (env, Nothing) 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 +784,24 @@ 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 + = setCtEvPredType ctev (tidyOpenType env (ctEvPred ctev)) + -- tidyOpenType: for (beta ~ (forall a. a->a), don't gratuitously + -- rename the 'forall a' just because of an 'a' in scope somewhere + -- else entirely. 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 +tidyDelayedError env (DE_Multiplicity mult_co loc) + = DE_Multiplicity (tidyCo env mult_co) loc tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig }) @@ -674,7 +810,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 diff --git a/GHC/Tc/Zonk/Type.hs b/GHC/Tc/Zonk/Type.hs --- a/GHC/Tc/Zonk/Type.hs +++ b/GHC/Tc/Zonk/Type.hs @@ -28,12 +28,6 @@ -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers module GHC.Tc.Zonk.Env, - -- * Coercion holes - isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe, - - -- * Rewriter sets - zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet, - -- * Tidying tcInitTidyEnv, tcInitOpenTidyEnv, @@ -54,8 +48,7 @@ import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Monad ( setSrcSpanA, liftZonkM, traceTc, addErr ) -import GHC.Tc.Types.Constraint +import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) import GHC.Tc.Types.Evidence import GHC.Tc.Errors.Types import GHC.Tc.Zonk.Env @@ -75,7 +68,6 @@ import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Core.Multiplicity import GHC.Core @@ -89,7 +81,6 @@ import GHC.Types.TypeEnv import GHC.Types.Basic import GHC.Types.SrcLoc -import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.TyThing @@ -100,7 +91,8 @@ import Control.Monad import Control.Monad.Trans.Class ( lift ) -import Data.Semigroup +import Data.List.NonEmpty ( NonEmpty ) +import Data.Foldable ( toList ) {- Note [What is zonking?] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -330,15 +322,15 @@ -- See Note [Zonking to Type]. type ZonkBndrTcM = ZonkBndrT TcM -wrapLocZonkMA :: (a -> ZonkTcM b) -> GenLocated (SrcSpanAnn' ann) a - -> ZonkTcM (GenLocated (SrcSpanAnn' ann) b) +wrapLocZonkMA :: (a -> ZonkTcM b) -> GenLocated (EpAnn ann) a + -> ZonkTcM (GenLocated (EpAnn ann) b) wrapLocZonkMA fn (L loc a) = ZonkT $ \ ze -> setSrcSpanA loc $ do { b <- runZonkT (fn a) ze ; return (L loc b) } -wrapLocZonkBndrMA :: (a -> ZonkBndrTcM b) -> GenLocated (SrcSpanAnn' ann) a - -> ZonkBndrTcM (GenLocated (SrcSpanAnn' ann) b) +wrapLocZonkBndrMA :: (a -> ZonkBndrTcM b) -> GenLocated (EpAnn ann) a + -> ZonkBndrTcM (GenLocated (EpAnn ann) b) wrapLocZonkBndrMA fn (L loc a) = ZonkBndrT $ \ k -> ZonkT $ \ ze -> setSrcSpanA loc $ runZonkT ( runZonkBndrT (fn a) $ \ b -> k (L loc b) ) ze @@ -380,7 +372,7 @@ zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type zonkTyVarOcc tv - = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv + = do { ZonkEnv { ze_tv_env = tv_env, ze_flexi = zonk_flexi } <- getZonkEnv ; let lookup_in_tv_env -- Look up in the env just as we do for Ids = case lookupVarEnv tv_env tv of @@ -394,7 +386,7 @@ zonk_meta ref Flexi = do { kind <- zonkTcTypeToTypeX (tyVarKind tv) - ; ty <- commitFlexi tv kind + ; ty <- lift $ commitFlexi zonk_flexi tv kind ; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty -- Belt and braces ; finish_meta ty } @@ -442,49 +434,47 @@ Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) ; return res } -commitFlexi :: TcTyVar -> Kind -> ZonkTcM Type -commitFlexi tv zonked_kind - = do { flexi <- ze_flexi <$> getZonkEnv - ; lift $ case flexi of - SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) - - DefaultFlexi - -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar - -- But that sees only type variables that appear in, say, an inferred type. - -- Defaulting here, in the zonker, is needed to catch e.g. - -- y :: Bool - -- y = (\x -> True) undefined - -- We need *some* known RuntimeRep for the x and undefined, but no one - -- will choose it until we get here, in the zonker. - | isRuntimeRepTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) - ; return liftedRepTy } - | isLevityTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv) - ; return liftedDataConTy } - | isMultiplicityTy zonked_kind - -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) - ; return manyDataConTy } - | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv - -> do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) - ; return (anyTypeOfKind zonked_kind) } - | otherwise - -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv) - ; return (anyTypeOfKind zonked_kind) } - - RuntimeUnkFlexi - -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) - ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) } - -- This is where RuntimeUnks are born: - -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnks as they leave the - -- typechecker's monad +commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type +commitFlexi NoFlexi tv zonked_kind + = pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) - NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) } +commitFlexi (SkolemiseFlexi tvs_ref) tv zonked_kind + = do { let skol_tv = mkTyVar (tyVarName tv) zonked_kind + ; updTcRef tvs_ref (skol_tv :) + ; return (mkTyVarTy skol_tv) } - where - name = tyVarName tv +commitFlexi RuntimeUnkFlexi tv zonked_kind + = do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv) + ; return (mkTyVarTy (mkTcTyVar (tyVarName tv) zonked_kind RuntimeUnk)) } + -- This is where RuntimeUnks are born: + -- otherwise-unconstrained unification variables are + -- turned into RuntimeUnks as they leave the + -- typechecker's monad +commitFlexi DefaultFlexi tv zonked_kind + -- Normally, RuntimeRep variables are defaulted in GHC.Tc.Utils.TcMType.defaultTyVar + -- But that sees only type variables that appear in, say, an inferred type. + -- Defaulting here, in the zonker, is needed to catch e.g. + -- y :: Bool + -- y = (\x -> True) undefined + -- We need *some* known RuntimeRep for the x and undefined, but no one + -- will choose it until we get here, in the zonker. + | isRuntimeRepTy zonked_kind + = do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv) + ; return liftedRepTy } + | isLevityTy zonked_kind + = do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv) + ; return liftedDataConTy } + | isMultiplicityTy zonked_kind + = do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv) + ; return manyDataConTy } + | Just (ConcreteFRR origin) <- isConcreteTyVar_maybe tv + = do { addErr $ TcRnZonkerMessage (ZonkerCannotDefaultConcrete origin) + ; return (anyTypeOfKind zonked_kind) } + | otherwise + = do { traceTc "Defaulting flexi tyvar to ZonkAny:" (pprTyVar tv) + -- See Note [Any types] in GHC.Builtin.Types, esp wrinkle (Any4) + ; newZonkAnyType zonked_kind } zonkCoVarOcc :: CoVar -> ZonkTcM Coercion zonkCoVarOcc cv @@ -607,8 +597,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,18 +702,21 @@ --------------------------------------------- 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 zonk_bind :: HsBind GhcTc -> ZonkTcM (HsBind GhcTc) zonk_bind bind@(PatBind { pat_lhs = pat, pat_rhs = grhss + , pat_mult = mult_ann , pat_ext = (ty, ticks)}) = do { new_pat <- don'tBind $ zonkPat pat -- Env already extended ; new_grhss <- zonkGRHSs zonkLExpr grhss ; new_ty <- zonkTcTypeToTypeX ty + ; new_mult <- zonkMultAnn mult_ann ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss + , pat_mult = new_mult , pat_ext = (new_ty, ticks) }) } zonk_bind (VarBind { var_ext = x @@ -753,9 +746,13 @@ runZonkBndrT (zonkTyBndrsX tyvars ) $ \ new_tyvars -> runZonkBndrT (zonkEvBndrsX evs ) $ \ new_evs -> runZonkBndrT (zonkTcEvBinds_s ev_binds) $ \ new_ev_binds -> - do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, _) -> - runZonkBndrT (extendIdZonkEnvRec $ collectHsBindsBinders CollNoDictBinders new_val_binds) $ \ _ -> - do { new_val_binds <- mapBagM zonk_val_bind val_binds + do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, new_exports) -> + let new_bndrs = collectHsBindsBinders CollNoDictBinders new_val_binds + ++ map abe_poly new_exports + -- Tie the knot with the `abe_poly` binders too, since they + -- may be mentioned in the `abe_prags` of the `exports` + in runZonkBndrT (extendIdZonkEnvRec new_bndrs) $ \ _ -> + do { new_val_binds <- mapM zonk_val_bind val_binds ; new_exports <- mapM zonk_export exports ; return (new_val_binds, new_exports) } @@ -810,10 +807,21 @@ , psb_def = lpat' , psb_dir = dir' } } } +zonkMultAnn :: HsMultAnn GhcTc -> ZonkTcM (HsMultAnn GhcTc) +zonkMultAnn (HsUnannotated mult) + = do { mult' <- zonkTcTypeToTypeX mult + ; return (HsUnannotated mult') } +zonkMultAnn (HsLinearAnn mult) + = do { mult' <- zonkTcTypeToTypeX mult + ; return (HsLinearAnn mult') } +zonkMultAnn (HsExplicitMult mult hs_ty) + = do { mult' <- zonkTcTypeToTypeX mult + ; return (HsExplicitMult mult' hs_ty) } + zonkPatSynDetails :: HsPatSynDetails GhcTc -> ZonkTcM (HsPatSynDetails GhcTc) -zonkPatSynDetails (PrefixCon _ as) - = PrefixCon noTypeArgs <$> traverse zonkLIdOcc as +zonkPatSynDetails (PrefixCon as) + = PrefixCon <$> traverse zonkLIdOcc as zonkPatSynDetails (InfixCon a1 a2) = InfixCon <$> zonkLIdOcc a1 <*> zonkLIdOcc a2 zonkPatSynDetails (RecCon flds) @@ -839,10 +847,27 @@ = mapM zonk_prag ps where zonk_prag (L loc (SpecPrag id co_fn inl)) - = do { co_fn' <- don'tBind $ zonkCoFn co_fn - ; id' <- zonkIdOcc id - ; return (L loc (SpecPrag id' co_fn' inl)) } + = do { co_fn' <- don'tBind $ zonkCoFn co_fn + ; id' <- zonkIdOcc id + ; return (L loc (SpecPrag id' co_fn' inl)) } + zonk_prag (L loc prag@(SpecPragE { spe_fn_id = poly_id + , spe_bndrs = bndrs + , spe_call = spec_e })) + = do { poly_id' <- zonkIdOcc poly_id + ; skol_tvs_ref <- lift $ newTcRef [] + ; setZonkType (SkolemiseFlexi skol_tvs_ref) $ + -- SkolemiseFlexi: see Note [Free tyvars on rule LHS] + + runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' -> + do { spec_e' <- zonkLExpr spec_e + ; skol_tvs <- lift $ readTcRef skol_tvs_ref + ; return (L loc (prag { spe_fn_id = poly_id' + , spe_bndrs = skol_tvs ++ bndrs' + , spe_call = spec_e' + })) + }} + {- ************************************************************************ * * @@ -851,7 +876,7 @@ ************************************************************************ -} -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) -> MatchGroup GhcTc (LocatedA (body GhcTc)) -> ZonkTcM (MatchGroup GhcTc (LocatedA (body GhcTc))) @@ -865,18 +890,18 @@ , mg_ext = MatchGroupTc arg_tys' res_ty' origin }) } -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO => (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))) ~ SrcAnn NoEpAnns +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnCO => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) -> GRHSs GhcTc (LocatedA (body GhcTc)) -> ZonkTcM (GRHSs GhcTc (LocatedA (body GhcTc))) @@ -910,9 +935,9 @@ do { id' <- zonkIdOcc id ; return (HsVar x (L l id')) } -zonkExpr (HsUnboundVar her occ) +zonkExpr (HsHole (h, her)) = do her' <- zonk_her her - return (HsUnboundVar her' occ) + return (HsHole (h, her')) where zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef zonk_her (HER ref ty u) @@ -920,17 +945,13 @@ 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)) +zonkExpr (HsLit x (XLit (HsRat f ty))) = do new_ty <- zonkTcTypeToTypeX ty - return (HsLit x (HsRat e f new_ty)) + return (HsLit x (XLit $ HsRat f new_ty)) zonkExpr (HsLit x lit) = return (HsLit x lit) @@ -939,23 +960,19 @@ = do { lit' <- zonkOverLit lit ; return (HsOverLit x lit') } -zonkExpr (HsLam x matches) - = do new_matches <- zonkMatchGroup zonkLExpr matches - return (HsLam x new_matches) - -zonkExpr (HsLamCase x lc_variant matches) +zonkExpr (HsLam x lam_variant matches) = do new_matches <- zonkMatchGroup zonkLExpr matches - return (HsLamCase x lc_variant new_matches) + return (HsLam x lam_variant new_matches) zonkExpr (HsApp x e1 e2) = do new_e1 <- zonkLExpr e1 new_e2 <- zonkLExpr e2 return (HsApp x new_e1 new_e2) -zonkExpr (HsAppType ty e at t) +zonkExpr (HsAppType ty e t) = do new_e <- zonkLExpr e new_ty <- zonkTcTypeToTypeX ty - return (HsAppType new_ty new_e at t) + return (HsAppType new_ty new_e t) -- NB: the type is an HsType; can't zonk that! zonkExpr (HsTypedBracket hsb_tc body) @@ -975,9 +992,9 @@ do { new_expr <- zonkLExpr expr ; return (NegApp x new_expr new_op) } -zonkExpr (HsPar x lpar e rpar) +zonkExpr (HsPar x e) = do { new_e <- zonkLExpr e - ; return (HsPar x lpar new_e rpar) } + ; return (HsPar x new_e) } zonkExpr (SectionL x _ _) = dataConCantHappen x zonkExpr (SectionR x _ _) = dataConCantHappen x @@ -1016,10 +1033,10 @@ do { expr' <- zonkLExpr expr ; return $ GRHS x guard' expr' } -zonkExpr (HsLet x tkLet binds tkIn expr) +zonkExpr (HsLet x binds expr) = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> do { new_expr <- zonkLExpr expr - ; return (HsLet x tkLet new_binds tkIn new_expr) } + ; return (HsLet x new_binds new_expr) } zonkExpr (HsDo ty do_or_lc (L l stmts)) = do new_stmts <- don'tBind $ zonkStmts zonkLExpr stmts @@ -1064,14 +1081,21 @@ = do new_ty <- zonkTcTypeToTypeX ty HsStatic (fvs, new_ty) <$> zonkLExpr expr -zonkExpr (XExpr (WrapExpr (HsWrap co_fn expr))) +zonkExpr (HsEmbTy x _) = dataConCantHappen x +zonkExpr (HsQual x _ _) = dataConCantHappen x +zonkExpr (HsForAll x _ _) = dataConCantHappen x +zonkExpr (HsFunArr x _ _ _) = dataConCantHappen x + +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 (ExpansionExpr (HsExpanded a b))) - = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr b +zonkExpr (XExpr (ExpandedThingTc thing e)) + = do e' <- zonkExpr e + return $ XExpr (ExpandedThingTc thing e') + zonkExpr (XExpr (ConLikeTc con tvs tys)) = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys where @@ -1080,6 +1104,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 @@ -1138,32 +1166,28 @@ 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 new_e <- zonkLExpr e return (HsCmdApp x new_c new_e) -zonkCmd (HsCmdLam x matches) - = do new_matches <- zonkMatchGroup zonkLCmd matches - return (HsCmdLam x new_matches) - -zonkCmd (HsCmdPar x lpar c rpar) +zonkCmd (HsCmdPar x c) = do new_c <- zonkLCmd c - return (HsCmdPar x lpar new_c rpar) + return (HsCmdPar x new_c) zonkCmd (HsCmdCase x expr ms) = do new_expr <- zonkLExpr expr new_ms <- zonkMatchGroup zonkLCmd ms return (HsCmdCase x new_expr new_ms) -zonkCmd (HsCmdLamCase x lc_variant ms) +zonkCmd (HsCmdLam x lam_variant ms) = do new_ms <- zonkMatchGroup zonkLCmd ms - return (HsCmdLamCase x lc_variant new_ms) + return (HsCmdLam x lam_variant new_ms) zonkCmd (HsCmdIf x eCond ePred cThen cElse) = runZonkBndrT (zonkSyntaxExpr eCond) $ \ new_eCond -> @@ -1172,10 +1196,10 @@ ; new_cElse <- zonkLCmd cElse ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd (HsCmdLet x tkLet binds tkIn cmd) +zonkCmd (HsCmdLet x binds cmd) = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> do new_cmd <- zonkLCmd cmd - return (HsCmdLet x tkLet new_binds tkIn new_cmd) + return (HsCmdLet x new_binds new_cmd) zonkCmd (HsCmdDo ty (L l stmts)) = do new_stmts <- don'tBind $ zonkStmts zonkLCmd stmts @@ -1194,7 +1218,7 @@ new_ty <- zonkTcTypeToTypeX ty new_ids <- mapSndM zonkExpr ids - massert (isLiftedTypeKind (typeKind new_stack_tys)) + massert (definitelyLiftedType new_stack_tys) -- desugarer assumes that this is not representation-polymorphic... -- but indeed it should always be lifted due to the typing -- rules for arrows @@ -1218,7 +1242,6 @@ WpTyLam <$> zonkTyBndrX tv zonkCoFn (WpTyApp ty) = WpTyApp <$> noBinders (zonkTcTypeToTypeX ty) zonkCoFn (WpLet bs) = WpLet <$> zonkTcEvBinds bs -zonkCoFn (WpMultCoercion co) = WpMultCoercion <$> noBinders (zonkCoToCo co) ------------------------------------------------------------------------- zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc) @@ -1287,7 +1310,7 @@ ; new_stmts_w_bndrs <- noBinders $ mapM zonk_branch stmts_w_bndrs -- Add in the binders after we're done with all the branches. - ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs + ; let new_binders = [ b | ParStmtBlock _ _ bs _ <- toList new_stmts_w_bndrs , b <- bs ] ; extendIdZonkEnvRec new_binders ; new_mzip <- noBinders $ zonkExpr mzip_op @@ -1401,11 +1424,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 @@ -1425,7 +1448,7 @@ zonk_args args = do { new_args_rev <- zonk_args_rev (reverse args) ; new_pats <- zonkPats (map get_pat args) - ; return $ zipWithEqual "zonkStmt" replace_pat + ; return $ zipWithEqual replace_pat new_pats (reverse new_args_rev) } -- these need to go backward, because if any operators are higher-rank, @@ -1449,9 +1472,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) @@ -1467,6 +1490,7 @@ ************************************************************************ -} + zonkPat :: LPat GhcTc -> ZonkBndrTcM (LPat GhcTc) -- Extend the environment as we go, because it's possible for one -- pattern to bind something that is used in another (inside or @@ -1474,9 +1498,9 @@ zonkPat pat = wrapLocZonkBndrMA zonk_pat pat zonk_pat :: Pat GhcTc -> ZonkBndrTcM (Pat GhcTc) -zonk_pat (ParPat x lpar p rpar) +zonk_pat (ParPat x p) = do { p' <- zonkPat p - ; return (ParPat x lpar p' rpar) } + ; return (ParPat x p') } zonk_pat (WildPat ty) = do { ty' <- noBinders $ zonkTcTypeToTypeX ty @@ -1494,10 +1518,10 @@ = do { pat' <- zonkPat pat ; return (BangPat x pat') } -zonk_pat (AsPat x (L loc v) at pat) +zonk_pat (AsPat x (L loc v) pat) = do { v' <- zonkIdBndrX v ; pat' <- zonkPat pat - ; return (AsPat x (L loc v') at pat') } + ; return (AsPat x (L loc v') pat') } zonk_pat (ViewPat ty expr pat) = do { expr' <- noBinders $ zonkLExpr expr @@ -1515,6 +1539,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 @@ -1577,6 +1606,14 @@ ; n' <- zonkIdBndrX n ; return (NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } +zonk_pat (EmbTyPat ty tp) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (EmbTyPat ty' tp) } + +zonk_pat (InvisPat ty tp) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (InvisPat ty' tp) } + zonk_pat (XPat ext) = case ext of { ExpansionPat orig pat-> do { pat' <- zonk_pat pat @@ -1593,26 +1630,28 @@ --------------------------- zonkConStuff :: HsConPatDetails GhcTc -> ZonkBndrTcM (HsConPatDetails GhcTc) -zonkConStuff (PrefixCon tyargs pats) +zonkConStuff (PrefixCon pats) = do { pats' <- zonkPats pats - ; return (PrefixCon tyargs pats') } + ; return (PrefixCon pats') } zonkConStuff (InfixCon p1 p2) = do { p1' <- zonkPat p1 ; 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) ; 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)) #-} {- ************************************************************************ @@ -1640,31 +1679,74 @@ zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc) -zonkRule rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} +zonkRule rule@(HsRule { rd_bndrs = bndrs , rd_lhs = lhs , rd_rhs = rhs }) - = runZonkBndrT (traverse zonk_tm_bndr tm_bndrs) $ \ new_tm_bndrs -> - do { -- See Note [Zonking the LHS of a RULE] - ; new_lhs <- setZonkType SkolemiseFlexi $ zonkLExpr lhs - ; new_rhs <- zonkLExpr rhs - ; return $ rule { rd_tmvs = new_tm_bndrs - , rd_lhs = new_lhs - , rd_rhs = new_rhs } } + = do { skol_tvs_ref <- lift $ newTcRef [] + ; setZonkType (SkolemiseFlexi skol_tvs_ref) $ + -- setZonkType: see Note [Free tyvars on rule LHS] + zonkRuleBndrs bndrs $ \ new_bndrs -> + do { new_lhs <- zonkLExpr lhs + ; skol_tvs <- lift $ readTcRef skol_tvs_ref + ; new_rhs <- setZonkType DefaultFlexi $ zonkLExpr rhs + ; return $ rule { rd_bndrs = add_tvs skol_tvs new_bndrs + , rd_lhs = new_lhs + , rd_rhs = new_rhs } } } + where + add_tvs :: [TyVar] -> RuleBndrs GhcTc -> RuleBndrs GhcTc + add_tvs tvs rbs@(RuleBndrs { rb_ext = bndrs }) = rbs { rb_ext = tvs ++ bndrs } + + +zonkRuleBndrs :: RuleBndrs GhcTc -> (RuleBndrs GhcTc -> ZonkTcM a) -> ZonkTcM a +zonkRuleBndrs rb@(RuleBndrs { rb_ext = bndrs }) thing_inside + = runZonkBndrT (traverse zonk_it bndrs) $ \ new_bndrs -> + thing_inside (rb { rb_ext = new_bndrs }) where - zonk_tm_bndr :: LRuleBndr GhcTc -> ZonkBndrTcM (LRuleBndr GhcTc) - zonk_tm_bndr (L l (RuleBndr x (L loc v))) - = do { v' <- zonk_it v - ; return (L l (RuleBndr x (L loc v'))) } - zonk_tm_bndr (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" + zonk_it v + | isId v = zonkIdBndrX v + | otherwise = assert (isImmutableTyVar v) $ + zonkTyBndrX v + -- We may need to go inside the kind of v and zonk there! - zonk_it v - | isId v = zonkIdBndrX v - | otherwise = assert (isImmutableTyVar v) - zonkTyBndrX v - -- DV: used to be "return v", but that is plain - -- wrong because we may need to go inside the kind - -- of v and zonk there! +{- Note [Free tyvars on rule LHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = C + foo :: T a -> Int + foo C = 1 + + {-# RULES "myrule" foo C = 1 #-} + +After type checking the LHS becomes (foo alpha (C alpha)), where alpha +is an unbound meta-tyvar. The zonker in GHC.Tc.Zonk.Type is careful not to +turn the free alpha into Any (as it usually does). Instead we want to quantify +over it. Here is how: + +* We set the ze_flexi field of ZonkEnv to (SkolemiseFlexi ref), to tell the + zonker to zonk a Flexi meta-tyvar to a TyVar, not to Any. See the + SkolemiseFlexi case of `commitFlexi`. + +* Here (ref :: TcRef [TyVar]) collects the type variables thus skolemised; + again see `commitFlexi`. + +* When zonking a RULE, in `zonkRule` we + - make a fresh ref-cell to collect the skolemised type variables, + - zonk the binders and LHS with ze_flexi = SkolemiseFlexi ref + - read the ref-cell to get all the skolemised TyVars + - add them to the binders + +All this applies for SPECIALISE pragmas too. + +Wrinkles: + +(FTV1) We just add the new tyvars to the front of the binder-list, but + that may make the list not be in dependency order. Example (T12925): + the existing list is [k:Type, b:k], and we add (a:k) to the front. + Also we just collect the new skolemised type variables in any old order, + so they may not be ordered with respect to each other. +-} + {- ************************************************************************ * * @@ -1870,89 +1952,3 @@ operation. (consider /\a -> f @ b, where b is side-effected to a) -} -{- -************************************************************************ -* * - Checking for coercion holes -* * -************************************************************************ --} - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -isFilledCoercionHole (CoercionHole { ch_ref = ref }) - = isJust <$> readTcRef ref - --- | Retrieve the contents of a coercion hole. Panics if the hole --- is unfilled -unpackCoercionHole :: CoercionHole -> TcM Coercion -unpackCoercionHole hole - = do { contents <- unpackCoercionHole_maybe hole - ; case contents of - Just co -> return co - Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) } - --- | Retrieve the contents of a coercion hole, if it is filled -unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion) -unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref - -zonkCtRewriterSet :: Ct -> TcM Ct -zonkCtRewriterSet ct - | isGivenCt ct - = return ct - | otherwise - = case ct of - CEqCan eq@(EqCt { eq_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CEqCan (eq { eq_ev = ev' })) } - CIrredCan ir@(IrredCt { ir_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CIrredCan (ir { ir_ev = ev' })) } - CDictCan di@(DictCt { di_ev = ev }) -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CDictCan (di { di_ev = ev' })) } - CQuantCan {} -> return ct - CNonCanonical ev -> do { ev' <- zonkCtEvRewriterSet ev - ; return (CNonCanonical ev') } - -zonkCtEvRewriterSet :: CtEvidence -> TcM CtEvidence -zonkCtEvRewriterSet ev@(CtGiven {}) - = return ev -zonkCtEvRewriterSet ev@(CtWanted { ctev_rewriters = rewriters }) - = do { rewriters' <- zonkRewriterSet rewriters - ; return (ev { ctev_rewriters = rewriters' }) } - --- | Check whether any coercion hole in a RewriterSet is still unsolved. --- Does this by recursively looking through filled coercion holes until --- one is found that is not yet filled in, at which point this aborts. -zonkRewriterSet :: RewriterSet -> TcM RewriterSet -zonkRewriterSet (RewriterSet set) - = nonDetStrictFoldUniqSet go (return emptyRewriterSet) set - -- this does not introduce non-determinism, because the only - -- monadic action is to read, and the combining function is - -- commutative - where - go :: CoercionHole -> TcM RewriterSet -> TcM RewriterSet - go hole m_acc = unionRewriterSet <$> check_hole hole <*> m_acc - - check_hole :: CoercionHole -> TcM RewriterSet - check_hole hole = do { m_co <- unpackCoercionHole_maybe hole - ; case m_co of - Nothing -> return (unitRewriterSet hole) - Just co -> unUCHM (check_co co) } - - check_ty :: Type -> UnfilledCoercionHoleMonoid - check_co :: Coercion -> UnfilledCoercionHoleMonoid - (check_ty, _, check_co, _) = foldTyCo folder () - - folder :: TyCoFolder () UnfilledCoercionHoleMonoid - folder = TyCoFolder { tcf_view = noView - , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv) - , tcf_covar = \ _ cv -> check_ty (varType cv) - , tcf_hole = \ _ -> UCHM . check_hole - , tcf_tycobinder = \ _ _ _ -> () } - -newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM RewriterSet } - -instance Semigroup UnfilledCoercionHoleMonoid where - UCHM l <> UCHM r = UCHM (unionRewriterSet <$> l <*> r) - -instance Monoid UnfilledCoercionHoleMonoid where - mempty = UCHM (return emptyRewriterSet) diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs --- a/GHC/ThToHs.hs +++ b/GHC/ThToHs.hs @@ -1,13 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -32,6 +28,7 @@ import GHC.Hs as Hs import GHC.Tc.Errors.Types +import GHC.Types.Name.Cache import GHC.Types.Name.Reader import qualified GHC.Types.Name as Name import GHC.Unit.Module @@ -47,55 +44,68 @@ 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 import GHC.Utils.Panic +import GHC.Data.EnumSet (EnumSet) +import qualified GHC.Data.EnumSet as EnumSet +import qualified GHC.LanguageExtensions as LangExt + import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.ByteString as BS -import Control.Monad( unless, ap ) -import Control.Applicative( (<|>) ) +import Control.Monad( unless ) import Data.Bifunctor (first) import Data.Foldable (for_) import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) 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.Boot.TH.Syntax as TH import Foreign.ForeignPtr import Foreign.Ptr import System.IO.Unsafe +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs] -convertToHsDecls origin loc ds = - initCvt origin loc $ fmap catMaybes (mapM cvt_dec ds) +convertToHsDecls :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs] +convertToHsDecls exts origin loc ds = + initCvt exts origin loc $ fmap catMaybes (mapM cvt_dec ds) where cvt_dec d = wrapMsg (ConvDec d) $ cvtDec d -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs) -convertToHsExpr origin loc e - = initCvt origin loc $ wrapMsg (ConvExp e) $ cvtl e +convertToHsExpr :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs) +convertToHsExpr exts origin loc e + = initCvt exts origin loc $ wrapMsg (ConvExp e) $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs) -convertToPat origin loc p - = initCvt origin loc $ wrapMsg (ConvPat p) $ cvtPat p +convertToPat :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs) +convertToPat exts origin loc p + = initCvt exts origin loc $ wrapMsg (ConvPat p) $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs) -convertToHsType origin loc t - = initCvt origin loc $ wrapMsg (ConvType t) $ cvtType t +convertToHsType :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs) +convertToHsType exts origin loc t + = initCvt exts origin loc $ wrapMsg (ConvType t) $ cvtType t ------------------------------------------------------------------- -newtype CvtM' err a = CvtM { unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) } - deriving (Functor) + +-- Reader context for CvtM +data CvtCtx = + CvtCtx { cvt_origin :: !Origin + , cvt_listTuplePuns :: !Bool } + +-- State of CvtM +type CvtSt = SrcSpan + +newtype CvtM' err a = CvtM { unCvtM :: CvtCtx -> CvtSt -> Either err (a, SrcSpan) } + deriving (Functor, Applicative, Monad) via ReaderT CvtCtx (StateT CvtSt (Either err)) -- Push down the Origin (that is configurable by -- -fenable-th-splice-warnings) and source location; -- Can fail, with a single error message @@ -110,20 +120,27 @@ -- Use the SrcSpan everywhere, for lack of anything better. -- See Note [Source locations within TH splices]. -instance Applicative (CvtM' err) where - pure x = CvtM $ \_ loc -> Right (loc,x) - (<*>) = ap +-- | 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 +m1 `orOnFail` m2 = CvtM $ \ctx l -> choose (unCvtM m1 ctx l) (unCvtM m2 ctx l) + where + choose r@Right{} _ = r + choose _ r@Right{} = r + choose err@Left{} _ = err -instance Monad (CvtM' err) where - (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of - Left err -> Left err - Right (loc',v) -> unCvtM (k v) origin loc' +infixl 3 `orOnFail` -- The same fixity as for <|> mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a -mapCvtMError f (CvtM m) = CvtM $ \origin loc -> first f $ m origin loc +mapCvtMError f m = CvtM $ \origin loc -> first f $ unCvtM m origin loc -initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a -initCvt origin loc (CvtM m) = fmap snd (m origin loc) +initCvt :: EnumSet LangExt.Extension -> Origin -> SrcSpan -> CvtM' err a -> Either err a +initCvt exts origin loc m = fmap fst (unCvtM m ctx loc) + where ctx = CvtCtx { cvt_origin = origin + , cvt_listTuplePuns = listTuplePuns } + listTuplePuns = EnumSet.member LangExt.ListTuplePuns exts force :: a -> CvtM () force a = a `seq` return () @@ -132,42 +149,46 @@ failWith m = CvtM (\_ _ -> Left m) getOrigin :: CvtM Origin -getOrigin = CvtM (\origin loc -> Right (loc,origin)) +getOrigin = CvtM (\ctx s -> Right (cvt_origin ctx,s)) +getListTuplePuns :: CvtM Bool +getListTuplePuns = CvtM (\ctx s -> Right (cvt_listTuplePuns ctx,s)) + getL :: CvtM SrcSpan getL = CvtM (\_ loc -> Right (loc,loc)) -- NB: This is only used in conjunction with LineP pragmas. -- See Note [Source locations within TH splices]. setL :: SrcSpan -> CvtM () -setL loc = CvtM (\_ _ -> Right (loc, ())) +setL loc = CvtM (\_ _ -> Right ((), loc)) -returnLA :: e -> CvtM (LocatedAn ann e) -returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) +returnLA :: (NoAnn ann) => e -> CvtM (LocatedAn ann e) +returnLA x = CvtM (\_ loc -> Right (L (noAnnSrcSpan loc) x, loc)) returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA -wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b -wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) +wrapParLA :: (NoAnn ann) => (LocatedAn ann a -> b) -> a -> CvtM b +wrapParLA add_par x = CvtM (\_ loc -> Right (add_par (L (noAnnSrcSpan loc) x), loc)) wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a wrapMsg what = mapCvtMError (ConversionFail what) wrapL :: CvtM a -> CvtM (Located a) -wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of - Left err -> Left err - Right (loc', v) -> Right (loc', L loc v) +wrapL m = do + loc <- getL + fmap (L loc) m +wrapGL :: HasAnnotation e => CvtM a -> CvtM (GenLocated e a) +wrapGL m = do + loc <- getL + fmap (L (noAnnSrcSpan loc)) m + wrapLN :: CvtM a -> CvtM (LocatedN a) -wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of - Left err -> Left err - Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) +wrapLN = wrapGL wrapLA :: CvtM a -> CvtM (LocatedA a) -wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of - Left err -> Left err - Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v) +wrapLA = wrapGL {- Note [Source locations within TH splices] @@ -212,7 +233,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'] } @@ -223,7 +244,8 @@ ; returnJustLA $ Hs.ValD noExtField $ PatBind { pat_lhs = pat' , pat_rhs = GRHSs emptyComments body' ds' - , pat_ext = noAnn + , pat_ext = noExtField + , pat_mult = HsUnannotated EpPatBind } } cvtDec (TH.FunD nm cls) @@ -231,7 +253,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' } @@ -247,18 +269,23 @@ ; let sig' = StandaloneKindSig noAnn nm' ki' ; returnJustLA $ Hs.KindSigD noExtField sig' } -cvtDec (TH.InfixD fx nm) +cvtDec (TH.InfixD fx th_ns_spec nm) -- Fixity signatures are allowed for variables, constructors, and types -- the renamer automatically looks for types during renaming, even when -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. = do { nm' <- vcNameN nm ; returnJustLA (Hs.SigD noExtField (FixSig noAnn - (FixitySig noExtField [nm'] (cvtFixity fx)))) } + (FixitySig ns_spec [nm'] (cvtFixity fx)))) } + where + ns_spec = case th_ns_spec of + TH.NoNamespaceSpecifier -> Hs.NoNamespaceSpecifier + TH.TypeNamespaceSpecifier -> Hs.TypeNamespaceSpecifier noAnn + TH.DataNamespaceSpecifier -> Hs.DataNamespaceSpecifier noAnn 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 @@ -279,14 +306,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 } } @@ -301,13 +328,13 @@ ; unless (null adts') (failWith $ DefaultDataInstDecl adts') ; returnJustLA $ TyClD noExtField $ - ClassDecl { tcdCExt = (noAnn, NoAnnSortKey), tcdLayout = NoLayoutInfo + ClassDecl { tcdCExt = (noAnn, EpNoLayout, NoAnnSortKey) , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , 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) @@ -319,7 +346,7 @@ ; let inst_ty' = L loc $ mkHsImplicitSigType $ mkHsQualTy ctxt loc ctxt' $ L loc ty' ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $ - ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty' + ClsInstDecl { cid_ext = (Nothing, noAnn, NoAnnSortKey), cid_poly_ty = inst_ty' , cid_binds = binds' , cid_sigs = Hs.mkClassOpSigs sigs' , cid_tyfam_insts = ats', cid_datafam_insts = adts' @@ -328,10 +355,10 @@ where overlap pragma = case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "INCOHERENT") + TH.Overlaps -> Hs.Overlaps (SourceText $ fsLit "{-# OVERLAPS") + TH.Overlappable -> Hs.Overlappable (SourceText $ fsLit "{-# OVERLAPPABLE") + TH.Overlapping -> Hs.Overlapping (SourceText $ fsLit "{-# OVERLAPPING") + TH.Incoherent -> Hs.Incoherent (SourceText $ fsLit "{-# INCOHERENT") @@ -351,7 +378,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' @@ -373,7 +400,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' @@ -421,7 +448,7 @@ ; let inst_ty' = L loc $ mkHsImplicitSigType $ mkHsQualTy cxt loc cxt' $ L loc ty' ; returnJustLA $ DerivD noExtField $ - DerivDecl { deriv_ext = noAnn + DerivDecl { deriv_ext = (Nothing, noAnn) , deriv_strategy = ds' , deriv_type = mkHsWildCardBndrs inst_ty' , deriv_overlap_mode = Nothing } } @@ -440,7 +467,7 @@ ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $ PSB noAnn nm' args' pat' dir' } where - cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args + cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameN args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2 cvtArgs (TH.RecordPatSyn sels) = do { let mk_fld = fldNameN (nameBase nm) @@ -452,7 +479,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 } @@ -492,14 +519,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 } } @@ -562,7 +589,7 @@ , feqn_tycon = nm' , feqn_bndrs = outer_bndrs , feqn_pats = - (map HsValArg args') ++ args + (map (HsValArg noExtField) args') ++ args , feqn_fixity = Hs.Infix , feqn_rhs = rhs' } } _ -> failWith $ InvalidTyFamInstLHS lhs @@ -586,7 +613,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] @@ -604,7 +631,7 @@ -> CvtM ( LHsContext GhcPs , LocatedN RdrName , HsOuterFamEqnTyVarBndrs GhcPs - , HsTyPats GhcPs) + , HsFamEqnPats GhcPs) cvt_datainst_hdr cxt bndrs tys = do { cxt' <- cvtContext funPrec cxt ; bndrs' <- traverse (mapM cvt_tv) bndrs @@ -617,7 +644,7 @@ InfixT t1 nm t2 -> do { nm' <- tconNameN nm ; args' <- mapM cvtType [t1,t2] ; return (cxt', nm', outer_bndrs, - ((map HsValArg args') ++ args)) } + ((map (HsValArg noExtField) args') ++ args)) } _ -> failWith $ InvalidTypeInstanceHeader tys } ---------------- @@ -677,7 +704,7 @@ cvtConstr _ do_con_name (NormalC c strtys) = do { c' <- do_con_name c ; tys' <- mapM cvt_arg strtys - ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } + ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon tys') } cvtConstr parent_con do_con_name (RecC c varstrtys) = do { c' <- do_con_name c @@ -690,7 +717,7 @@ ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing - (InfixCon (hsLinear st1') (hsLinear st2')) } + (InfixCon st1' st2') } cvtConstr parent_con do_con_name (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs @@ -702,10 +729,15 @@ add_cxt (L loc cxt1) (Just (L _ cxt2)) = Just (L loc (cxt1 ++ cxt2)) + -- Nested foralls end up flattened (see tests/th/GadtConSigs_th_dump1.stderr) + -- but it doesn't seem to matter. add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs -> ConDecl GhcPs -> ConDecl GhcPs - add_forall tvs' cxt' con@(ConDeclGADT { con_bndrs = L l outer_bndrs, con_mb_cxt = cxt }) - = con { con_bndrs = L l outer_bndrs' + add_forall tvs' cxt' con@(ConDeclGADT { con_outer_bndrs = L l outer_bndrs + , con_inner_bndrs = inner_bndrs + , con_mb_cxt = cxt }) + = con { con_outer_bndrs = L l outer_bndrs' + , con_inner_bndrs = inner_bndrs , con_mb_cxt = add_cxt cxt' cxt } where outer_bndrs' @@ -729,7 +761,7 @@ { c' <- mapM do_con_name c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty - ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} + ; mk_gadt_decl c' (PrefixConGADT noExtField args) ty'} cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of Nothing -> failWith RecGadtNoCons @@ -738,17 +770,17 @@ ; ty' <- cvtType ty ; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys ; lrec_flds <- returnLA rec_flds - ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' } + ; mk_gadt_decl c' (RecConGADT noAnn lrec_flds) ty' } mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty - = do bndrs <- returnLA mkHsOuterImplicit + = do outer_bndrs <- returnLA mkHsOuterImplicit returnLA $ ConDeclGADT { con_g_ext = noAnn , con_names = names - , con_dcolon = noHsUniTok - , con_bndrs = bndrs + , con_outer_bndrs = outer_bndrs + , con_inner_bndrs = [] , con_mb_cxt = Nothing , con_g_args = args , con_res_ty = res_ty @@ -764,25 +796,24 @@ cvtSrcStrictness SourceLazy = SrcLazy cvtSrcStrictness SourceStrict = SrcStrict -cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs) +cvt_arg :: (TH.Bang, TH.Type) -> CvtM (HsConDeclField GhcPs) cvt_arg (Bang su ss, ty) = do { ty'' <- cvtType ty ; let ty' = parenthesizeHsType appPrec ty'' su' = cvtSrcUnpackedness su ss' = cvtSrcStrictness ss - ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' } + ; return $ CDF noAnn su' ss' (HsUnannotated (EpColon noAnn)) ty' Nothing } cvt_id_arg :: TH.Name -- ^ parent constructor name - -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) + -> (TH.Name, TH.Bang, TH.Type) -> CvtM (LHsConDeclRecField GhcPs) cvt_id_arg parent_con (i, str, ty) = do { L li i' <- fldNameN (nameBase parent_con) i ; ty' <- cvt_arg (str,ty) - ; returnLA $ ConDeclField - { cd_fld_ext = noAnn - , cd_fld_names + ; returnLA $ HsConDeclRecField + { cdrf_ext = noExtField + , cdrf_names = [L (l2l li) $ FieldOcc noExtField (L li i')] - , cd_fld_type = ty' - , cd_fld_doc = Nothing} } + , cdrf_spec = ty' } } cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { mapM cvtDerivClause cs } @@ -799,7 +830,8 @@ cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs) cvtForD (ImportF callconv safety from nm ty) = - do { l <- getL + do { ls <- getL + ; let l = l2l ls ; if -- the prim and javascript calling conventions do not support headers -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess | callconv == TH.Prim || callconv == TH.JavaScript @@ -809,7 +841,7 @@ True))) | Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety') (mkFastString (TH.nameBase nm)) - from (L l $ quotedSourceText from) + from (L ls $ quotedSourceText from) -> mk_imp impspec | otherwise -> failWith $ InvalidCCallImpent from } @@ -831,7 +863,8 @@ cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameN nm ; ty' <- cvtSigType ty - ; l <- getL + ; ls <- getL + ; let l = l2l ls ; let astxt = mkFastString as ; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt) astxt @@ -882,31 +915,21 @@ srcTxt = SourceText $ fsLit "{-# OPAQUE" ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip } -cvtPragmaD (SpecialiseP nm ty inline phases) - = do { nm' <- vNameN nm - ; ty' <- cvtSigType ty - ; let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE" - src TH.Inline = fsLit "{-# SPECIALISE INLINE" - src TH.Inlinable = fsLit "{-# SPECIALISE INLINE" - ; let (inline', dflt, srcText) = case inline of - Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1, - toSrcTxt inline1) - Nothing -> (NoUserInlinePrag, AlwaysActive, - SourceText $ fsLit "{-# SPECIALISE") - where - toSrcTxt a = SourceText $ src a - ; let ip = InlinePragma { inl_src = srcText - , inl_inline = inline' - , inl_rule = Hs.FunLike - , inl_act = cvtPhases phases dflt - , inl_sat = Nothing } - ; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip } - cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtSigType ty ; returnJustLA $ Hs.SigD noExtField $ SpecInstSig (noAnn, (SourceText $ fsLit "{-# SPECIALISE")) ty' } +cvtPragmaD (SpecialiseEP ty_bndrs tm_bndrs exp inline phases) + = do { ty_bndrs' <- traverse cvtTvs ty_bndrs + ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs + ; let ip = cvtInlinePhases inline phases + ; exp' <- cvtl exp + ; let bndrs' = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' } + ; returnJustLA $ Hs.SigD noExtField $ + SpecSigE noAnn bndrs' exp' ip + } + cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm ; rd_name' <- returnLA nm' @@ -919,8 +942,7 @@ HsRule { rd_ext = (noAnn, quotedSourceText nm) , rd_name = rd_name' , rd_act = act - , rd_tyvs = ty_bndrs' - , rd_tmvs = tm_bndrs' + , rd_bndrs = RuleBndrs { rb_ext = noAnn, rb_tyvs = ty_bndrs', rb_tmvs = tm_bndrs' } , rd_lhs = lhs' , rd_rhs = rhs' } ; returnJustLA $ Hs.RuleD noExtField @@ -950,10 +972,16 @@ ; return Nothing } cvtPragmaD (CompleteP cls mty) - = do { cls' <- wrapL $ mapM cNameN cls + = do { cls' <- mapM cNameN cls ; mty' <- traverse tconNameN mty ; returnJustLA $ Hs.SigD noExtField $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' } +cvtPragmaD (SCCP nm str) = do + nm' <- vcNameN nm + str' <- traverse (\s -> + returnLA $ StringLiteral NoSourceText (mkFastString s) Nothing) str + returnJustLA $ Hs.SigD noExtField + $ SCCFunSig (noAnn, SourceText $ fsLit "{-# SCC") nm' str' dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive @@ -982,6 +1010,24 @@ ; ty' <- cvtType ty ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } +cvtInlinePhases :: Maybe Inline -> Phases -> InlinePragma +cvtInlinePhases inline phases = + let src TH.NoInline = fsLit "{-# SPECIALISE NOINLINE" + src TH.Inline = fsLit "{-# SPECIALISE INLINE" + src TH.Inlinable = fsLit "{-# SPECIALISE INLINE" + (inline', dflt, srcText) = case inline of + Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1, + toSrcTxt inline1) + Nothing -> (NoUserInlinePrag, AlwaysActive, + SourceText $ fsLit "{-# SPECIALISE") + where + toSrcTxt a = SourceText $ src a + in InlinePragma { inl_src = srcText + , inl_inline = inline' + , inl_rule = Hs.FunLike + , inl_act = cvtPhases phases dflt + , inl_sat = Nothing } + --------------------------------------------------- -- Declarations --------------------------------------------------- @@ -996,27 +1042,26 @@ 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)) ((_:_), (_:_)) -> failWith ImplicitParamsWithOtherBinds -cvtClause :: HsMatchContext GhcPs - -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) +cvtClause :: HsMatchContextPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtClause ctxt (Clause ps body wheres) = do { ps' <- cvtPats ps ; 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 n' <- wrapL (ipName n) e' <- cvtl e - returnLA (IPBind noAnn (reLocA n') e') + returnLA (IPBind noAnn (reLoc n') e') ------------------------------------------------------------------- -- Expressions @@ -1025,12 +1070,12 @@ cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs) cvtl e = wrapLA (cvt e) where - cvt (VarE s) = do { s' <- vName s; wrapParLA (HsVar noExtField) s' } - cvt (ConE s) = do { s' <- cName s; wrapParLA (HsVar noExtField) s' } + cvt (VarE s) = do { s' <- vName s; wrapParLA mkHsVar s' } + cvt (ConE s) = do { s' <- dName s; wrapParLA mkHsVar s' } cvt (LitE l) - | overloadedLit l = go cvtOverLit (HsOverLit noComments) + | overloadedLit l = go cvtOverLit (HsOverLit noExtField) (hsOverLitNeedsParens appPrec) - | otherwise = go cvtLit (HsLit noComments) + | otherwise = go cvtLit (HsLit noExtField) (hsLitNeedsParens appPrec) where go :: (Lit -> CvtM (l GhcPs)) @@ -1043,10 +1088,10 @@ if is_compound_lit l' then wrapParLA gHsPar e' else pure e' cvt (AppE e1 e2) = do { e1' <- parenthesizeHsExpr opPrec <$> cvtl e1 ; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2 - ; return $ HsApp noComments e1' e2' } + ; return $ HsApp noExtField e1' e2' } cvt (AppTypeE e t) = do { e' <- parenthesizeHsExpr opPrec <$> cvtl e ; t' <- parenthesizeHsType appPrec <$> cvtType t - ; return $ HsAppType noExtField e' noHsTok + ; return $ HsAppType noAnn e' $ mkHsWildCardBndrs t' } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing @@ -1055,17 +1100,17 @@ cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; let pats = map (parenthesizePat appPrec) ps' ; th_origin <- getOrigin - ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin) - [mkSimpleMatch LambdaExpr pats e']} - cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch $ LamCaseAlt LamCase) ms + ; wrapParLA (HsLam noAnn LamSingle . mkMatchGroup th_origin) + [mkSimpleMatch (LamAlt LamSingle) (noLocA pats) e']} + cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch $ LamAlt LamCase) ms ; th_origin <- getOrigin - ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms' + ; wrapParLA (HsLam noAnn LamCase . mkMatchGroup th_origin) ms' } cvt (LamCasesE ms) | null ms = failWith CasesExprWithoutAlts - | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms + | otherwise = do { ms' <- mapM (cvtClause $ LamAlt LamCases) ms ; th_origin <- getOrigin - ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms' + ; wrapParLA (HsLam noAnn LamCases . mkMatchGroup th_origin) ms' } cvt (TupE es) = cvt_tup es Boxed cvt (UnboxedTupE es) = cvt_tup es Unboxed @@ -1074,12 +1119,11 @@ ; return $ ExplicitSum noAnn alt arity e'} cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ mkHsIf x' y' z' noAnn } - cvt (MultiIfE alts) - | null alts = failWith MultiWayIfWithoutAlts - | otherwise = do { alts' <- mapM cvtpair alts - ; return $ HsMultiIf noAnn alts' } + cvt (MultiIfE alts) = case nonEmpty alts of + Nothing -> failWith MultiWayIfWithoutAlts + Just alts -> HsMultiIf noAnn <$> traverse cvtpair alts cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds - ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} + ; e' <- cvtl e; return $ HsLet noAnn ds' e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' } @@ -1090,7 +1134,7 @@ ; return $ ArithSeq noAnn Nothing dd' } cvt (ListE xs) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s) - ; return (HsLit noComments l') } + ; return (HsLit noExtField l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs ; return $ ExplicitList noAnn xs' @@ -1104,7 +1148,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 @@ -1112,12 +1156,12 @@ cvt (InfixE Nothing s (Just y)) = ensureValidOpExp s $ do { s' <- cvtl s; y' <- cvtl y ; wrapParLA gHsPar $ - SectionR noComments s' y' } + SectionR noExtField s' y' } -- See Note [Sections in HsSyn] in GHC.Hs.Expr cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $ do { x' <- cvtl x; s' <- cvtl s ; wrapParLA gHsPar $ - SectionL noComments x' s' } + SectionL noExtField x' s' } cvt (InfixE Nothing s Nothing ) = ensureValidOpExp s $ do { s' <- cvtl s @@ -1138,10 +1182,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 @@ -1152,18 +1196,35 @@ -- important, because UnboundVarE may contain -- constructor names - see #14627. { s' <- vcName s - ; wrapParLA (HsVar noExtField) s' } - cvt (LabelE s) = return $ HsOverLabel noComments NoSourceText (fsLit s) - cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } + ; wrapParLA mkHsVar s' } + cvt (LabelE s) = return $ HsOverLabel NoSourceText (fsLit s) + cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp - ; return $ HsGetField noComments e' + ; 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 (noAnn, noAnn) e' } + ; return $ HsTypedSplice noExtField (HsTypedSpliceExpr noAnn e') } cvt (TypedBracketE e) = do { e' <- cvtl e ; return $ HsTypedBracket noAnn e' } + cvt (TypeE t) = do { t' <- cvtType t + ; 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: @@ -1198,7 +1259,7 @@ -} cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp) - -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs)) + -> CvtM (LHsFieldBind GhcPs (LocatedA t) (LHsExpr GhcPs)) cvtFld f (v,e) = do { v' <- vNameL v ; lhs' <- traverse f v' @@ -1216,7 +1277,7 @@ cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs) cvt_tup es boxity = do { let cvtl_maybe Nothing = return (missingTupArg noAnn) - cvtl_maybe (Just e) = fmap (Present noAnn) (cvtl e) + cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e) ; es' <- mapM cvtl_maybe es ; return $ ExplicitTuple noAnn @@ -1285,7 +1346,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 @@ -1316,8 +1377,11 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs LetBinding ds ; returnLA $ LetStmt noAnn ds' } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss - ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr } +cvtStmt (TH.ParS dss) = case nonEmpty dss of + Nothing -> failWith EmptyParStmt + Just dss -> do + { dss' <- mapM cvt_one dss + ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) } @@ -1325,8 +1389,7 @@ ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss' ; returnLA rec_stmt } -cvtMatch :: HsMatchContext GhcPs - -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) +cvtMatch :: HsMatchContextPs -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs) = do { p' <- cvtPat p ; let lp = case p' of @@ -1334,12 +1397,14 @@ _ -> 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 +cvtGuard :: TH.Body -> CvtM (NonEmpty (LGRHS GhcPs (LHsExpr GhcPs))) +cvtGuard (GuardedB pairs) = case nonEmpty pairs of + Nothing -> failWith EmptyGuard + Just pairs -> traverse cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e - ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] } + ; g' <- returnLA $ GRHS noAnn [] e'; return (g' :| []) } cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs @@ -1410,8 +1475,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) @@ -1434,18 +1501,16 @@ = do { p' <- cvtPat p ; unboxedSumChecks alt arity ; return $ SumPat noAnn p' alt arity } -cvtp (ConP s ts ps) = do { s' <- cNameN s - ; ps' <- cvtPats ps - ; ts' <- mapM cvtType ts +cvtp (ConP s ts ps) = do { s' <- dNameN s + ; ps' <- cvtPats (map InvisP ts ++ ps) ; let pps = map (parenthesizePat appPrec) ps' - pts = map (\t -> HsConPatTyArg noHsTok (mkHsPatSigType noAnn t)) ts' ; return $ ConPat { pat_con_ext = noAnn , pat_con = s' - , pat_args = PrefixCon pts pps + , pat_args = PrefixCon pps } } -cvtp (InfixP p1 s p2) = do { s' <- 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 @@ -1464,13 +1529,13 @@ cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noAnn p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noAnn p' } cvtp (TH.AsP s p) = do { s' <- vNameN s; p' <- cvtPat p - ; return $ AsPat noAnn s' noHsTok p' } + ; return $ AsPat noAnn s' p' } cvtp TH.WildP = return $ WildPat noExtField cvtp (RecP c fs) = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs ; 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 @@ -1480,8 +1545,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' <- 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 @@ -1525,8 +1599,8 @@ cvtFlag TH.InferredSpec = Hs.InferredSpec instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where - cvtFlag TH.BndrReq = HsBndrRequired - cvtFlag TH.BndrInvis = HsBndrInvisible noHsTok + cvtFlag TH.BndrReq = HsBndrRequired noExtField + cvtFlag TH.BndrInvis = HsBndrInvisible noAnn cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] cvtTvs tvs = mapM cvt_tv tvs @@ -1535,12 +1609,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 @@ -1602,7 +1682,7 @@ cvtTypeKind typeOrKind ty = do { (head_ty, tys') <- split_ty_app ty ; let m_normals = mapM extract_normal tys' - where extract_normal (HsValArg ty) = Just ty + where extract_normal (HsValArg _ ty) = Just ty extract_normal _ = Nothing ; case head_ty of @@ -1639,7 +1719,7 @@ _ -> return $ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' - returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'') + returnLA (HsFunTy noExtField (HsUnannotated (EpArrow noAnn)) x'' y'') | otherwise -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } @@ -1654,7 +1734,7 @@ parenthesizeHsType sigPrec x' let y'' = parenthesizeHsType sigPrec y' w'' = hsTypeToArrow w' - returnLA (HsFunTy noAnn w'' x'' y'') + returnLA (HsFunTy noExtField w'' x'' y'') | otherwise -> do { fun_tc <- returnLA $ getRdrName fUNTyCon ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } @@ -1705,7 +1785,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 @@ -1715,7 +1795,7 @@ ; ls' <- returnLA s' ; mk_apps (HsTyVar noAnn prom ls') - ([HsValArg t1', HsValArg t2'] ++ tys') + ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys') } UInfixT t1 s t2 @@ -1731,7 +1811,7 @@ ; t2' <- cvtType t2 ; mk_apps (HsTyVar noAnn IsPromoted s') - ([HsValArg t1', HsValArg t2'] ++ tys') + ([HsValArg noExtField t1', HsValArg noExtField t2'] ++ tys') } PromotedUInfixT t1 s t2 @@ -1754,7 +1834,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' } @@ -1763,7 +1843,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)) @@ -1785,7 +1865,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. @@ -1796,18 +1876,18 @@ ImplicitParamT n t -> do { n' <- wrapL $ ipName n ; t' <- cvtType t - ; returnLA (HsIParamTy noAnn (reLocA n') t') + ; returnLA (HsIParamTy noAnn (reLoc n') t') } _ -> failWith (MalformedType typeOrKind ty) } -hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs +hsTypeToArrow :: LHsType GhcPs -> HsMultAnn GhcPs hsTypeToArrow w = case unLoc w of HsTyVar _ _ (L _ (isExact_maybe -> Just n)) - | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok) - | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok - _ -> HsExplicitMult noHsTok w noHsUniTok + | n == oneDataConName -> HsLinearAnn noAnn + | n == manyDataConName -> HsUnannotated (EpArrow noAnn) + _ -> HsExplicitMult (noAnn, EpArrow noAnn) w -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only @@ -1833,11 +1913,12 @@ go [] = pure head_ty' go (arg:args) = case arg of - HsValArg ty -> do p_ty <- add_parens ty + HsValArg _ ty -> + do p_ty <- add_parens ty mk_apps (HsAppTy noExtField phead_ty p_ty) args HsTypeArg at ki -> do p_ki <- add_parens ki - mk_apps (HsAppKindTy noExtField phead_ty at p_ki) args + mk_apps (HsAppKindTy at phead_ty p_ki) args HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args go type_args @@ -1848,7 +1929,7 @@ | otherwise = return lt wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs -wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty +wrap_tyarg (HsValArg x ty) = HsValArg x $ parenthesizeHsType appPrec ty wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized @@ -1868,7 +1949,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. @@ -1880,9 +1961,9 @@ split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty [] where - go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } + go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg noExtField a':as') } go (AppKindT ty ki) as' = do { ki' <- cvtKind ki - ; go ty (HsTypeArg noHsTok ki' : as') } + ; go ty (HsTypeArg noAnn ki' : as') } go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) @@ -1968,7 +2049,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 @@ -2067,9 +2148,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) @@ -2080,6 +2161,10 @@ 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) vcName n = if isVarName n then vName n else cName n @@ -2109,7 +2194,8 @@ | not (okOcc ctxt_ns occ_str) = failWith (IllegalOccName ctxt_ns occ_str) | otherwise = do { loc <- getL - ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour + ; listTuplePuns <- getListTuplePuns + ; let rdr_name = thRdrName listTuplePuns loc ctxt_ns occ_str flavour ; force rdr_name ; return rdr_name } where @@ -2129,7 +2215,7 @@ "" -> False (c:_) -> startsVarId c || startsVarSym c -thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName +thRdrName :: Bool -> SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- This turns a TH Name into a RdrName; used for both binders and occurrences -- See Note [Binders in Template Haskell] -- The passed-in name space tells what the context is expecting; @@ -2145,35 +2231,105 @@ -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName loc ctxt_ns th_occ th_name +thRdrName listTuplePuns loc ctxt_ns th_occ th_name = case th_name of - TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod + TH.NameG th_ns pkg mod -> thOrigOrExactRdrName th_occ th_ns pkg mod TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc) TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc) - TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name - | otherwise -> mkRdrUnqual $! occ - -- We check for built-in syntax here, because the TH - -- user might have written a (NameS "(,,)"), for example + TH.NameS -> thUnqualRdrName listTuplePuns occ where occ :: OccName.OccName occ = mk_occ ctxt_ns th_occ --- Return an unqualified exact RdrName if we're dealing with built-in syntax. --- See #13776. +{- thOrigRdrName converts /original names/ in TH to their GHC representation. + +An original name is the canonical (Module, OccName) pair (where Module also +includes package/unit info) that (a) uniquely and (b) unambiguously identifies a +top-level binding. For example, ghc-prim:GHC.Types.List is the original name of +the list type []. + +To be more precise, + a) "uniquely" means that there's exactly one original name for each top-level + binding, which makes it different from a qualified name. + Qualified names permit reexports and module aliases: + + import Data.List as L + + xs :: L.List a -- L is a module alias for Data.List + xs :: Data.List.List a -- Data.List reexports GHC.Types.List + + Only ghc-prim:GHC.Types.List constitutes List's original name because + GHC.Types is the original module where we find the type declaration: + + data List a = [] | a : List a -- in ghc-prim:GHC.Types + + b) "unambiguously" means that the original name contains sufficient + information to identify the top-level binding in all possible contexts. + + For example, ghc-prim:GHC.Types.List remains valid even if the user + declares their own List type. + +In TH, original names arise from name quotation, e.g. + + 'Just ==> ghc-internal:GHC.Internal.Maybe.Just + ''ReaderT ==> transformers:Control.Monad.Trans.Reader.ReaderT + ''[] ==> ghc-prim:GHC.Types.List (with ListTuplePuns) + +NB. You likely want to use thOrigOrExactRdrName instead of thOrigRdrName. +-} thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName -thOrigRdrName occ th_ns pkg mod = - let occ' = mk_occ (mk_ghc_ns th_ns) occ - mod' = mkModule (mk_pkg pkg) (mk_mod mod) - in case isBuiltInOcc_maybe occ' <|> isPunOcc_maybe mod' occ' of - Just name -> nameRdrName name - Nothing -> (mkOrig $! mod') $! occ' +thOrigRdrName occ th_ns pkg mod = (mkOrig $! mod') $! occ' + where + occ' = mk_occ (mk_ghc_ns th_ns) occ + mod' = mkModule (mk_pkg pkg) (mk_mod mod) -thRdrNameGuesses :: TH.Name -> [RdrName] -thRdrNameGuesses (TH.Name occ flavour) +{- Note [Pretty-printing known original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An original name is a pair (Module, OccName), and normally we would pretty-print +it using the M.x syntax, e.g. "GHC.Types.Int" or "GHC.Internal.Base.ord". +However, this approach creates two problems (test case: th/T13776): + + 1) Illegal quantification of built-in syntax, e.g. the nil data constructor [] + would be printed as GHC.Types.[], which is not valid Haskell syntax + + 2) Ignoring ListTuplePuns. e.g. the type constructor (,) would be + printed as GHC.Tuple.Tuple2, even though the user would prefer to see (,) + +The pretty-printer for Name has special cases to deal with this, but the one for +Orig RdrNames does not. Trying to fix this directly in the Outputable RdrName instance +creates nasty module cycles. Instead, we work around the issue by avoiding the +problematic Orig names altogether, converting them to Exact names as early as +possible. +-} + +-- thOrigOrExactRdrName is a variant of thOrigRdrName that returns Exact names +-- instead of known Orig names. +-- +-- See Note [Pretty-printing known original names] for the rationale. +thOrigOrExactRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName +thOrigOrExactRdrName occ th_ns pkg mod = knownOrigToExactRdrName (thOrigRdrName occ th_ns pkg mod) + +-- Convert known Orig names to Exact names, leaving all other names intact. +knownOrigToExactRdrName :: RdrName -> RdrName +knownOrigToExactRdrName (Orig mod occ) + | Just name <- isKnownOrigName_maybe mod occ + = Exact name +knownOrigToExactRdrName rdr = rdr + +-- Return an exact RdrName if we're dealing with built-in syntax. +-- The user might have written (NameS "(,,)"), for example. +thUnqualRdrName :: Bool -> OccName.OccName -> RdrName +thUnqualRdrName listTuplePuns occ = + case isBuiltInOcc_maybe listTuplePuns occ of + Just name -> nameRdrName $! name + Nothing -> mkRdrUnqual $! occ + +thRdrNameGuesses :: Bool -> TH.Name -> [RdrName] +thRdrNameGuesses listTuplePuns (TH.Name occ flavour) -- This special case for NameG ensures that we don't generate duplicates in the output list - | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod] - | otherwise = [ thRdrName noSrcSpan gns occ_str flavour + | TH.NameG th_ns pkg mod <- flavour = [ thOrigOrExactRdrName occ_str th_ns pkg mod ] + | otherwise = [ thRdrName listTuplePuns noSrcSpan gns occ_str flavour | gns <- guessed_nss] where -- guessed_ns are the name spaces guessed from looking at the TH name diff --git a/GHC/Types/Annotations.hs b/GHC/Types/Annotations.hs --- a/GHC/Types/Annotations.hs +++ b/GHC/Types/Annotations.hs @@ -31,7 +31,7 @@ import Data.Maybe import Data.Typeable import Data.Word ( Word8 ) - +import Control.DeepSeq -- | Represents an annotation after it has been sufficiently desugared from -- it's initial form of 'GHC.Hs.Decls.AnnDecl' @@ -70,6 +70,10 @@ case h of 0 -> liftM NamedTarget $ get bh _ -> liftM ModuleTarget $ get bh + +instance NFData name => NFData (AnnTarget name) where + rnf (NamedTarget n) = rnf n + rnf (ModuleTarget m) = rnf m instance Outputable Annotation where ppr ann = ppr (ann_target ann) diff --git a/GHC/Types/Avail.hs b/GHC/Types/Avail.hs --- a/GHC/Types/Avail.hs +++ b/GHC/Types/Avail.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} -- -- (c) The University of Glasgow -- @@ -19,6 +21,9 @@ filterAvail, filterAvails, nubAvails, + sortAvails, + DetOrdAvails(DetOrdAvails, getDetOrdAvails, DefinitelyDeterministicAvails), + emptyDetOrdAvails ) where import GHC.Prelude @@ -36,7 +41,7 @@ import Control.DeepSeq import Data.Data ( Data ) import Data.Functor.Classes ( liftCompare ) -import Data.List ( find ) +import Data.List ( find, sortBy ) import qualified Data.Semigroup as S -- ----------------------------------------------------------------------------- @@ -64,6 +69,36 @@ -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] +-- | Occurrences of Avails in interface files must be deterministically ordered +-- to guarantee interface file determinism. +-- +-- We guarantee a deterministic order by either using the order explicitly +-- given by the user (e.g. in an explicit constructor export list) or instead +-- by sorting the avails with 'sortAvails'. +newtype DetOrdAvails = DefinitelyDeterministicAvails { getDetOrdAvails :: Avails } + deriving newtype (Binary, Outputable, NFData) + +instance Eq DetOrdAvails where + a1 == a2 = compare a1 a2 == EQ +instance Ord DetOrdAvails where + compare (DetOrdAvails a1) (DetOrdAvails a2) = go a1 a2 + where + go [] [] = EQ + go _ [] = LT + go [] _ = GT + go (a:as) (b:bs) = + case (a, b) of + (Avail {}, AvailTC {}) -> LT + (AvailTC{}, Avail {}) -> GT + (Avail n1, Avail n2) -> stableNameCmp n1 n2 S.<> go as bs + (AvailTC n1 m1s, AvailTC n2 m2s) -> + stableNameCmp n1 n2 S.<> foldMap (uncurry stableNameCmp) (zip m1s m2s) S.<> go as bs + +-- | It's always safe to match on 'DetOrdAvails' +pattern DetOrdAvails :: Avails -> DetOrdAvails +pattern DetOrdAvails x <- DefinitelyDeterministicAvails x +{-# COMPLETE DetOrdAvails #-} + {- Note [Representing pattern synonym fields in AvailInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record pattern synonym fields cannot be represented using AvailTC like fields of @@ -131,6 +166,20 @@ | availExportsDecl avail = tail ns | otherwise = ns +-- | Sort 'Avails'/'AvailInfo's +sortAvails :: Avails -> DetOrdAvails +sortAvails = DefinitelyDeterministicAvails . sortBy stableAvailCmp . map sort_subs + 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 + -- ----------------------------------------------------------------------------- -- Utility @@ -213,3 +262,7 @@ instance NFData AvailInfo where rnf (Avail n) = rnf n rnf (AvailTC a b) = rnf a `seq` rnf b + +-- | Create an empty DetOrdAvails +emptyDetOrdAvails :: DetOrdAvails +emptyDetOrdAvails = DefinitelyDeterministicAvails [] diff --git a/GHC/Types/Basic.hs b/GHC/Types/Basic.hs --- a/GHC/Types/Basic.hs +++ b/GHC/Types/Basic.hs @@ -21,6 +21,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Types.Basic ( LeftOrRight(..), @@ -28,7 +30,8 @@ ConTag, ConTagZ, fIRST_TAG, - Arity, RepArity, JoinArity, FullArgCount, + Arity, VisArity, RepArity, JoinArity, FullArgCount, + JoinPointHood(..), isJoinPoint, Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -37,6 +40,8 @@ RecFlag(..), isRec, isNonRec, boolToRecFlag, Origin(..), isGenerated, DoPmc(..), requiresPMC, + GenReason(..), isDoExpansionGenerated, doExpansionFlavour, + doExpansionOrigin, RuleName, pprRuleName, @@ -77,12 +82,12 @@ EP(..), DefMethSpec(..), - SwapFlag(..), flipSwap, unSwap, isSwapped, + SwapFlag(..), flipSwap, unSwap, notSwapped, isSwapped, pickSwap, CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase, Activation(..), isActive, competesWith, - isNeverActive, isAlwaysActive, activeInFinalPhase, + isNeverActive, isAlwaysActive, activeInFinalPhase, activeInInitialPhase, activateAfterInitial, activateDuringFinal, activeAfter, RuleMatchInfo(..), isConLike, isFunLike, @@ -111,12 +116,14 @@ Levity(..), mightBeLifted, mightBeUnlifted, TypeOrConstraint(..), - TyConFlavour(..), TypeOrData(..), tyConFlavourAssoc_maybe, + TyConFlavour(..), TypeOrData(..), NewOrData(..), tyConFlavourAssoc_maybe, NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, - ForeignSrcLang (..) + ForeignSrcLang (..), + + ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels ) where import GHC.Prelude @@ -130,12 +137,13 @@ import qualified GHC.LanguageExtensions as LangExt import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) - +import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour) import Control.DeepSeq ( NFData(..) ) import Data.Data import Data.Maybe import qualified Data.Semigroup as Semi +import Language.Haskell.Syntax.ImpExp {- ************************************************************************ * * @@ -144,7 +152,7 @@ ********************************************************************* -} data LeftOrRight = CLeft | CRight - deriving( Eq, Data ) + deriving( Eq, Data, Ord ) pickLR :: LeftOrRight -> (a,a) -> a pickLR CLeft (l,_) = l @@ -163,7 +171,12 @@ 0 -> return CLeft _ -> return CRight } +instance NFData LeftOrRight where + rnf CLeft = () + rnf CRight = () + + {- ************************************************************************ * * @@ -179,6 +192,10 @@ -- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" type Arity = Int +-- | Syntactic (visibility) arity, i.e. the number of visible arguments. +-- See Note [Visibility and arity] +type VisArity = Int + -- | Representation Arity -- -- The number of represented arguments that can be applied to a value before it does @@ -199,6 +216,71 @@ -- both type and value arguments! type FullArgCount = Int +{- Note [Visibility and arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Arity is the number of arguments that a function expects. In a curried language +like Haskell, there is more than one way to count those arguments. + +* `Arity` is the classic notion of arity, concerned with evalution, so it counts + the number of /value/ arguments that need to be supplied before evaluation can + take place, as described in notes + Note [Definition of arity] in GHC.Core.Opt.Arity + Note [Arity and function types] in GHC.Types.Id.Info + + Examples: + Int has arity == 0 + Int -> Int has arity <= 1 + Int -> Bool -> Int has arity <= 2 + We write (<=) rather than (==) as sometimes evaluation can occur before all + value arguments are supplied, depending on the actual function definition. + + This evaluation-focused notion of arity ignores type arguments, so: + forall a. a has arity == 0 + forall a. a -> a has arity <= 1 + forall a b. a -> b -> a has arity <= 2 + This is true regardless of ForAllTyFlag, so the arity is also unaffected by + (forall {a}. ty) or (forall a -> ty). + + Class dictionaries count towards the arity, as they are passed at runtime + forall a. (Num a) => a has arity <= 1 + forall a. (Num a) => a -> a has arity <= 2 + forall a b. (Num a, Ord b) => a -> b -> a has arity <= 4 + +* `VisArity` is the syntactic notion of arity. It is the number of /visible/ + arguments, i.e. arguments that occur visibly in the source code. + + In a function call `f x y z`, we can confidently say that f's vis-arity >= 3, + simply because we see three arguments [x,y,z]. We write (>=) rather than (==) + as this could be a partial application. + + At definition sites, we can acquire an underapproximation of vis-arity by + counting the patterns on the LHS, e.g. `f a b = rhs` has vis-arity >= 2. + The actual vis-arity can be higher if there is a lambda on the RHS, + e.g. `f a b = \c -> rhs`. + + If we look at the types, we can observe the following + * function arrows (a -> b) add to the vis-arity + * visible foralls (forall a -> b) add to the vis-arity + * constraint arrows (a => b) do not affect the vis-arity + * invisible foralls (forall a. b) do not affect the vis-arity + + This means that ForAllTyFlag matters for VisArity (in contrast to Arity), + while the type/value distinction is unimportant (again in contrast to Arity). + + Examples: + Int -- vis-arity == 0 (no args) + Int -> Int -- vis-arity == 1 (1 funarg) + forall a. a -> a -- vis-arity == 1 (1 funarg) + forall a. Num a => a -> a -- vis-arity == 1 (1 funarg) + forall a -> Num a => a -- vis-arity == 1 (1 req tyarg, 0 funargs) + forall a -> a -> a -- vis-arity == 2 (1 req tyarg, 1 funarg) + Int -> forall a -> Int -- vis-arity == 2 (1 funarg, 1 req tyarg) + + Wrinkle: with TypeApplications and TypeAbstractions, it is possible to visibly + bind and pass invisible arguments, e.g. `f @a x = ...` or `f @Int 42`. Those + @-prefixed arguments are ignored for the purposes of vis-arity. +-} + {- ************************************************************************ * * @@ -383,6 +465,7 @@ data SwapFlag = NotSwapped -- Args are: actual, expected | IsSwapped -- Args are: expected, actual + deriving( Eq ) instance Outputable SwapFlag where ppr IsSwapped = text "Is-swapped" @@ -396,6 +479,14 @@ isSwapped IsSwapped = True isSwapped NotSwapped = False +notSwapped :: SwapFlag -> Bool +notSwapped NotSwapped = True +notSwapped IsSwapped = False + +pickSwap :: SwapFlag -> a -> a -> a +pickSwap NotSwapped a _ = a +pickSwap IsSwapped _ b = b + unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b unSwap NotSwapped f a b = f a b unSwap IsSwapped f a b = f b a @@ -447,6 +538,10 @@ 1 -> return IsData _ -> panic "Binary FunctionOrData" +instance NFData FunctionOrData where + rnf IsFunction = () + rnf IsData = () + {- ************************************************************************ * * @@ -530,6 +625,11 @@ 1 -> return MarkedCbv _ -> panic "Invalid binary format" +instance NFData CbvMark where + rnf MarkedCbv = () + rnf NotMarkedCbv = () + + isMarkedCbv :: CbvMark -> Bool isMarkedCbv MarkedCbv = True isMarkedCbv NotMarkedCbv = False @@ -587,16 +687,43 @@ -- -- See Note [Generated code and pattern-match checking]. data Origin = FromSource - | Generated DoPmc + | Generated GenReason DoPmc deriving( Eq, Data ) isGenerated :: Origin -> Bool -isGenerated Generated {} = True +isGenerated Generated{} = True isGenerated FromSource = False +-- | This metadata stores the information as to why was the piece of code generated +-- It is useful for generating the right error context +-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +data GenReason = DoExpansion HsDoFlavour + | OtherExpansion + deriving (Eq, Data) + +instance Outputable GenReason where + ppr DoExpansion{} = text "DoExpansion" + ppr OtherExpansion = text "OtherExpansion" + +doExpansionFlavour :: Origin -> Maybe HsDoFlavour +doExpansionFlavour (Generated (DoExpansion f) _) = Just f +doExpansionFlavour _ = Nothing + +-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +isDoExpansionGenerated :: Origin -> Bool +isDoExpansionGenerated = isJust . doExpansionFlavour + +-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do` +doExpansionOrigin :: HsDoFlavour -> Origin +doExpansionOrigin f = Generated (DoExpansion f) DoPmc + -- It is important that we perfrom PMC + -- on the expressions generated by do statements + -- to get the right pattern match checker warnings + -- See `GHC.HsToCore.Pmc.pmcMatches` + instance Outputable Origin where - ppr FromSource = text "FromSource" - ppr (Generated pmc) = text "Generated" <+> ppr pmc + ppr FromSource = text "FromSource" + ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc -- | Whether to run pattern-match checks in generated code. -- @@ -614,14 +741,14 @@ -- -- See Note [Generated code and pattern-match checking]. requiresPMC :: Origin -> Bool -requiresPMC (Generated SkipPmc) = False +requiresPMC (Generated _ SkipPmc) = False requiresPMC _ = True {- Note [Generated code and pattern-match checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some parts of the compiler generate code that is then typechecked. For example: - - the HsExpansion mechanism described in Note [Rebindable syntax and HsExpansion] + - the XXExprGhcRn mechanism described in Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr, - the deriving mechanism. @@ -652,14 +779,7 @@ -- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a -- explanation of the `isSafeOverlap` field. -- --- - 'GHC.Parser.Annotation.AnnKeywordId' : --- 'GHC.Parser.Annotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or --- @'\{-\# OVERLAPPING'@ or --- @'\{-\# OVERLAPS'@ or --- @'\{-\# INCOHERENT'@, --- 'GHC.Parser.Annotation.AnnClose' @`\#-\}`@, --- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" data OverlapFlag = OverlapFlag { overlapMode :: OverlapMode , isSafeOverlap :: Bool @@ -769,6 +889,9 @@ instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) +instance NFData OverlapFlag where + rnf (OverlapFlag mode safe) = rnf mode `seq` rnf safe + instance Outputable OverlapMode where ppr (NoOverlap _) = empty ppr (Overlappable _) = text "[overlappable]" @@ -777,6 +900,14 @@ ppr (Incoherent _) = text "[incoherent]" ppr (NonCanonical _) = text "[noncanonical]" +instance NFData OverlapMode where + rnf (NoOverlap s) = rnf s + rnf (Overlappable s) = rnf s + rnf (Overlapping s) = rnf s + rnf (Overlaps s) = rnf s + rnf (Incoherent s) = rnf s + rnf (NonCanonical s) = rnf s + instance Binary OverlapMode where put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s @@ -910,7 +1041,7 @@ = BoxedTuple | UnboxedTuple | ConstraintTuple - deriving( Eq, Data ) + deriving( Eq, Data, Ord ) instance Outputable TupleSort where ppr ts = text $ @@ -930,7 +1061,12 @@ 1 -> return UnboxedTuple _ -> return ConstraintTuple +instance NFData TupleSort where + rnf BoxedTuple = () + rnf UnboxedTuple = () + rnf ConstraintTuple = () + tupleSortBoxity :: TupleSort -> Boxity tupleSortBoxity BoxedTuple = Boxed tupleSortBoxity UnboxedTuple = Unboxed @@ -1029,14 +1165,23 @@ * * ************************************************************************ -This data type is used exclusively by the simplifier, but it appears in a +Note [OccInfo] +~~~~~~~~~~~~~ +The OccInfo data type is used exclusively by the simplifier, but it appears in a SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty near the base of the module hierarchy. So it seemed simpler to put the defn of -OccInfo here, safely at the bottom +OccInfo here, safely at the bottom. + +Note that `OneOcc` doesn't meant that it occurs /syntactially/ only once; it +means that it is /used/ only once. It might occur syntactically many times. +For example, in (case x of A -> y; B -> y; C -> True), +* `y` is used only once +* but it occurs syntactically twice + -} -- | identifier Occurrence Information -data OccInfo +data OccInfo -- See Note [OccInfo] = ManyOccs { occ_tail :: !TailCallInfo } -- ^ There are many occurrences, or unknown occurrences @@ -1134,8 +1279,9 @@ mappend = (Semi.<>) ----------------- -data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] - | NoTailCallInfo +data TailCallInfo + = AlwaysTailCalled {-# UNPACK #-} !JoinArity -- See Note [TailCallInfo] + | NoTailCallInfo deriving (Eq) tailCallInfo :: OccInfo -> TailCallInfo @@ -1216,7 +1362,7 @@ function is always tail-called. See Note [Invariants on join points]. This info is quite fragile and should not be relied upon unless the occurrence -analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of +analyser has *just* run. Use 'Id.idJoinPointHood' for the permanent state of the join-point-hood of a binder; a join id itself will not be marked AlwaysTailCalled. @@ -1461,7 +1607,7 @@ data InlinePragma -- Note [InlinePragma] = InlinePragma - { inl_src :: SourceText -- Note [Pragma source text] + { inl_src :: SourceText -- See Note [Pragma source text] , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n @@ -1643,12 +1789,7 @@ inlinePragmaSpec = inl_inline inlinePragmaSource :: InlinePragma -> SourceText -inlinePragmaSource prag = case inl_inline prag of - Inline x -> x - Inlinable y -> y - NoInline z -> z - Opaque q -> q - NoUserInlinePrag -> NoSourceText +inlinePragmaSource prag = inlineSpecSource (inl_inline prag) inlineSpecSource :: InlineSpec -> SourceText inlineSpecSource spec = case spec of @@ -1748,6 +1889,14 @@ ab <- get bh return (ActiveAfter src ab) +instance NFData Activation where + rnf = \case + AlwaysActive -> () + NeverActive -> () + ActiveBefore src aa -> rnf src `seq` rnf aa + ActiveAfter src ab -> rnf src `seq` rnf ab + FinalActive -> () + instance Outputable RuleMatchInfo where ppr ConLike = text "CONLIKE" ppr FunLike = text "FUNLIKE" @@ -1760,6 +1909,11 @@ if h == 1 then return ConLike else return FunLike +instance NFData RuleMatchInfo where + rnf = \case + ConLike -> () + FunLike -> () + instance Outputable InlineSpec where ppr (Inline src) = text "INLINE" <+> pprWithSourceText src empty ppr (NoInline src) = text "NOINLINE" <+> pprWithSourceText src empty @@ -1794,6 +1948,14 @@ s <- get bh return (Opaque s) +instance NFData InlineSpec where + rnf = \case + Inline s -> rnf s + NoInline s -> rnf s + Inlinable s -> rnf s + Opaque s -> rnf s + NoUserInlinePrag -> () + instance Outputable InlinePragma where ppr = pprInline @@ -1813,6 +1975,9 @@ d <- get bh return (InlinePragma s a b c d) +instance NFData InlinePragma where + rnf (InlinePragma s a b c d) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c `seq` rnf d + -- | Outputs string for pragma name for any of INLINE/INLINABLE/NOINLINE. This -- differs from the Outputable instance for the InlineSpec type where the pragma -- name string as well as the accompanying SourceText (if any) is printed. @@ -1905,6 +2070,13 @@ 2 -> return StableSystemSrc _ -> return VanillaSrc +instance NFData UnfoldingSource where + rnf = \case + CompulsorySrc -> () + StableUserSrc -> () + StableSystemSrc -> () + VanillaSrc -> () + instance Outputable UnfoldingSource where ppr CompulsorySrc = text "Compulsory" ppr StableUserSrc = text "StableUser" @@ -2049,7 +2221,20 @@ = TypeLike | ConstraintLike deriving( Eq, Ord, Data ) +instance Binary TypeOrConstraint where + put_ bh = \case + TypeLike -> putByte bh 0 + ConstraintLike -> putByte bh 1 + get bh = getByte bh >>= \case + 0 -> pure TypeLike + 1 -> pure ConstraintLike + _ -> panic "TypeOrConstraint.get: invalid value" +instance NFData TypeOrConstraint where + rnf = \case + TypeLike -> () + ConstraintLike -> () + {- ********************************************************************* * * TyConFlavour @@ -2086,24 +2271,17 @@ = assoc ++ t_or_d ++ " family" where assoc = if isJust mb_par then "associated " else "" - t_or_d = case type_or_data of { IAmType -> "type"; IAmData -> "data" } + t_or_d = case type_or_data of + IAmType -> "type" + IAmData new_or_data -> + case new_or_data of + DataType -> "data" + NewType -> "newtype" go ClosedTypeFamilyFlavour = "type family" go TypeSynonymFlavour = "type synonym" go BuiltInTypeFlavour = "built-in type" go PromotedDataConFlavour = "promoted data constructor" -instance NFData tc => NFData (TyConFlavour tc) where - rnf ClassFlavour = () - rnf (TupleFlavour !_) = () - rnf SumFlavour = () - rnf DataTypeFlavour = () - rnf NewtypeFlavour = () - rnf AbstractTypeFlavour = () - rnf (OpenFamilyFlavour !_ mb_tc) = rnf mb_tc - rnf ClosedTypeFamilyFlavour = () - rnf TypeSynonymFlavour = () - rnf BuiltInTypeFlavour = () - rnf PromotedDataConFlavour = () -- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc @@ -2113,14 +2291,26 @@ -- | Whether something is a type or a data declaration, -- e.g. a type family or a data family. data TypeOrData - = IAmData + = IAmData !NewOrData | IAmType deriving (Eq, Data) +-- | When we only care whether a data-type declaration is `data` or `newtype`, +-- but not what constructors it has. +data NewOrData + = NewType -- ^ @newtype Blah ...@ + | DataType -- ^ @data Blah ...@ + deriving ( Eq, Data ) -- Needed because Demand derives Eq + instance Outputable TypeOrData where - ppr IAmData = text "data" + ppr (IAmData newOrData) = ppr newOrData ppr IAmType = text "type" +instance Outputable NewOrData where + ppr = \case + NewType -> text "newtype" + DataType -> text "data" + {- ********************************************************************* * * Defaulting options @@ -2200,7 +2390,7 @@ GHC.Iface.Type.defaultIfaceTyVarsOfKind This is a built-in defaulting mechanism that only applies when pretty-printing. - It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-kinds is enabled, + It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-runtime-reps is enabled, and 'Multiplicity' variables unless -XLinearTypes is enabled. -} @@ -2249,3 +2439,26 @@ instance Outputable DefaultingStrategy where ppr DefaultKindVars = text "DefaultKindVars" ppr (NonStandardDefaulting ns) = text "NonStandardDefaulting" <+> ppr ns + +-- | ImportLevel + +data ImportLevel = NormalLevel | SpliceLevel | QuoteLevel deriving (Eq, Ord, Data, Show, Enum, Bounded) + +instance Outputable ImportLevel where + ppr NormalLevel = text "normal" + ppr SpliceLevel = text "splice" + ppr QuoteLevel = text "quote" + +deriving via (EnumBinary ImportLevel) instance Binary ImportLevel + +allImportLevels :: [ImportLevel] +allImportLevels = [minBound..maxBound] + +convImportLevel :: ImportDeclLevelStyle -> ImportLevel +convImportLevel (LevelStylePre level) = convImportLevelSpec level +convImportLevel (LevelStylePost level) = convImportLevelSpec level +convImportLevel NotLevelled = NormalLevel + +convImportLevelSpec :: ImportDeclLevel -> ImportLevel +convImportLevelSpec ImportDeclQuote = QuoteLevel +convImportLevelSpec ImportDeclSplice = SpliceLevel diff --git a/GHC/Types/BreakInfo.hs b/GHC/Types/BreakInfo.hs deleted file mode 100644 --- a/GHC/Types/BreakInfo.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | A module for the BreakInfo type. Used by both the GHC.Runtime.Eval and --- GHC.Runtime.Interpreter hierarchy, so put here to have a less deep module --- dependency tree -module GHC.Types.BreakInfo (BreakInfo(..)) where - -import GHC.Prelude -import GHC.Unit.Module - -data BreakInfo = BreakInfo - { breakInfo_module :: Module - , breakInfo_number :: Int - } diff --git a/GHC/Types/CompleteMatch.hs b/GHC/Types/CompleteMatch.hs --- a/GHC/Types/CompleteMatch.hs +++ b/GHC/Types/CompleteMatch.hs @@ -1,40 +1,70 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -- | COMPLETE signature -module GHC.Types.CompleteMatch where +module GHC.Types.CompleteMatch + ( CompleteMatchX(..) + , CompleteMatch, CompleteMatches + , DsCompleteMatch, DsCompleteMatches + , mkCompleteMatch, vanillaCompleteMatch + , completeMatchAppliesAtType + ) where import GHC.Prelude import GHC.Core.TyCo.Rep -import GHC.Types.Unique.DSet +import GHC.Types.Unique import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Type ( splitTyConApp_maybe ) +import GHC.Types.Name ( Name ) +import GHC.Types.Unique.DSet import GHC.Utils.Outputable +type CompleteMatch = CompleteMatchX Name +type DsCompleteMatch = CompleteMatchX ConLike + +type CompleteMatches = [CompleteMatch] +type DsCompleteMatches = [DsCompleteMatch] + -- | A list of conlikes which represents a complete pattern match. -- These arise from @COMPLETE@ signatures. -- See also Note [Implementation of COMPLETE pragmas]. -data CompleteMatch = CompleteMatch - { cmConLikes :: UniqDSet ConLike -- ^ The set of `ConLike` values - , cmResultTyCon :: Maybe TyCon -- ^ The optional, concrete result TyCon the set applies to +data CompleteMatchX con = CompleteMatch + { cmConLikes :: UniqDSet con -- ^ The set of constructor names + , cmResultTyCon :: Maybe Name -- ^ The optional, concrete result TyCon name the set applies to } + deriving Eq -vanillaCompleteMatch :: UniqDSet ConLike -> CompleteMatch -vanillaCompleteMatch cls = CompleteMatch { cmConLikes = cls, cmResultTyCon = Nothing } +mkCompleteMatch :: UniqDSet con -> Maybe Name -> CompleteMatchX con +mkCompleteMatch nms mb_tc = CompleteMatch { cmConLikes = nms, cmResultTyCon = mb_tc } -instance Outputable CompleteMatch where +vanillaCompleteMatch :: UniqDSet con -> CompleteMatchX con +vanillaCompleteMatch nms = mkCompleteMatch nms Nothing + +instance Outputable con => Outputable (CompleteMatchX con) where ppr (CompleteMatch cls mty) = case mty of Nothing -> ppr cls Just ty -> ppr cls <> text "@" <> parens (ppr ty) -type CompleteMatches = [CompleteMatch] - -completeMatchAppliesAtType :: Type -> CompleteMatch -> Bool -completeMatchAppliesAtType ty cm = all @Maybe ty_matches (cmResultTyCon cm) +-- | Does this 'COMPLETE' set apply at this type? +-- +-- See the part about "result type constructors" in +-- Note [Implementation of COMPLETE pragmas] in GHC.HsToCore.Pmc.Solver. +completeMatchAppliesAtType :: Type -> CompleteMatchX con -> Bool +completeMatchAppliesAtType ty cm = all @Maybe ty_matches (getUnique <$> cmResultTyCon cm) where + ty_matches :: Unique -> Bool ty_matches sig_tc | Just (tc, _arg_tys) <- splitTyConApp_maybe ty - , tc == sig_tc + , tc `hasKey` sig_tc + || sig_tc `is_family_ty_con_of` tc + -- #24326: sig_tc might be the data Family TyCon of the representation + -- TyCon tc -- this CompleteMatch still applies = True | otherwise = False + fam_tc `is_family_ty_con_of` repr_tc = + case fst <$> tyConFamInst_maybe repr_tc of + Just tc -> tc `hasKey` fam_tc + Nothing -> False diff --git a/GHC/Types/CostCentre.hs b/GHC/Types/CostCentre.hs --- a/GHC/Types/CostCentre.hs +++ b/GHC/Types/CostCentre.hs @@ -4,6 +4,7 @@ CostCentre(..), CcName, CCFlavour, mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour, mkLateCCFlavour, mkCallerCCFlavour, + getAllCAFsCC, pprCostCentre, CostCentreStack, @@ -35,6 +36,7 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Types.CostCentre.State +import Control.DeepSeq import Data.Data @@ -393,3 +395,28 @@ -- ok, because we only need the SrcSpan when declaring the -- CostCentre in the original module, it is not used by importing -- modules. + +instance NFData CostCentre where + rnf (NormalCC aa ab ac ad) = rnf aa `seq` rnf ab `seq` rnf ac `seq` rnf ad + rnf (AllCafsCC ae ad) = rnf ae `seq` rnf ad + +instance NFData CCFlavour where + rnf CafCC = () + rnf (IndexedCC flav i) = rnf flav `seq` rnf i + +instance NFData IndexedCCFlavour where + rnf ExprCC = () + rnf DeclCC = () + rnf HpcCC = () + rnf LateCC = () + rnf CallerCC = () + +getAllCAFsCC :: Module -> (CostCentre, CostCentreStack) +getAllCAFsCC this_mod = + let + span = mkGeneralSrcSpan (mkFastString "") -- XXX do better + all_cafs_cc = mkAllCafsCC this_mod span + all_cafs_ccs = mkSingletonCCS all_cafs_cc + in + (all_cafs_cc, all_cafs_ccs) + diff --git a/GHC/Types/CostCentre/State.hs b/GHC/Types/CostCentre/State.hs --- a/GHC/Types/CostCentre/State.hs +++ b/GHC/Types/CostCentre/State.hs @@ -15,6 +15,7 @@ import Data.Data import GHC.Utils.Binary +import Control.DeepSeq -- | Per-module state for tracking cost centre indices. -- @@ -28,6 +29,9 @@ -- | An index into a given cost centre module,name,flavour set newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } deriving (Eq, Ord, Data, Binary) + +instance NFData CostCentreIndex where + rnf (CostCentreIndex i) = rnf i -- | Get a new index for a given cost centre name. getCCIndex :: FastString diff --git a/GHC/Types/DefaultEnv.hs b/GHC/Types/DefaultEnv.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/DefaultEnv.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Types.DefaultEnv + ( ClassDefaults (..) + , DefaultProvenance (..) + , DefaultEnv + , emptyDefaultEnv + , isEmptyDefaultEnv + , defaultEnv + , unitDefaultEnv + , lookupDefaultEnv + , filterDefaultEnv + , defaultList + , plusDefaultEnv + , mkDefaultEnv + , insertDefaultEnv + , isHaskell2010Default + ) +where + +import GHC.Core.Class (Class (className)) +import GHC.Prelude +import GHC.Hs.Extension (GhcRn) +import GHC.Tc.Utils.TcType (Type) +import GHC.Types.Name (Name, nameUnique, stableNameCmp) +import GHC.Types.Name.Env +import GHC.Types.Unique.FM (lookupUFM_Directly) +import GHC.Types.SrcLoc (SrcSpan) +import GHC.Unit.Module.Warnings (WarningTxt) +import GHC.Unit.Types (Module) +import GHC.Utils.Outputable + +import Data.Data (Data) +import Data.List (sortBy) +import Data.Function (on) + +-- See Note [Named default declarations] in GHC.Tc.Gen.Default + +-- | Default environment mapping class name @Name@ to their default type lists +-- +-- NB: this includes Haskell98 default declarations, at the 'Num' key. +type DefaultEnv = NameEnv ClassDefaults + +{- Note [DefaultProvenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each `ClassDefault` is annotated with its `DefaultProvenance`, which +says where the default came from. Specifically +* `DP_Local loc h98`: the default came from an explicit `default` declaration in the module + being compiled, at location `loc`, and the boolean `h98` indicates whether + it was from a Haskell 98 default declaration (e.g. `default (Int, Double)`). +* `DP_Imported M`: the default was imported, it is explicitly exported by module `M`. +* `DP_Builtin`: the default was automatically provided by GHC. + see Note [Builtin class defaults] in GHC.Tc.Utils.Env + +These annotations are used to disambiguate multiple defaults for the same class. +For example, consider the following modules: + + module M( default C ) where { default C( ... ) } + module M2( default C) where { import M } + module N( default C () where { default C(... ) } + + module A where { import M2 } + module B where { import M2; import N } + module A1 where { import N; default C ( ... ) } + module B2 where { default C ( ... ); default C ( ... ) } + +When compiling N, the default for C is annotated with DP_Local loc. +When compiling M2, the default for C is annotated with DP_Local M. +When compiling A, the default for C is annotated with DP_Imported M2. + +Cases we needed to disambiguate: + * Compiling B, two defaults for C: DP_Imported M2, DP_Imported N. + * Compiling A1, two defaults for C: DP_Imported N, DP_Local loc. + * Compiling B2, two defaults for C: DP_Local loc1, DP_Local loc2. + +For how we disambiguate these cases, +See Note [Disambiguation of multiple default declarations] in GHC.Tc.Module. +-} + +-- | The provenance of a collection of default types for a class. +-- see Note [DefaultProvenance] for more details +data DefaultProvenance + -- | A locally defined default declaration. + = DP_Local + { defaultDeclLoc :: SrcSpan -- ^ The 'SrcSpan' of the default declaration + , defaultDeclH98 :: Bool -- ^ Is this a Haskell 98 default declaration? + } + -- | Built-in class defaults. + | DP_Builtin + -- | Imported class defaults. + | DP_Imported Module -- ^ The module from which the defaults were imported + deriving (Eq, Data) + +instance Outputable DefaultProvenance where + ppr (DP_Local loc h98) = ppr loc <> (if h98 then text " (H98)" else empty) + ppr DP_Builtin = text "built-in" + ppr (DP_Imported mod) = ppr mod + +isHaskell2010Default :: DefaultProvenance -> Bool +isHaskell2010Default = \case + DP_Local { defaultDeclH98 = isH98 } -> isH98 + DP_Builtin -> True + DP_Imported {} -> False + +-- | Defaulting type assignments for the given class. +data ClassDefaults + = ClassDefaults { cd_class :: Class -- ^ The class whose defaults are being defined + , cd_types :: [Type] + , cd_provenance :: DefaultProvenance + -- ^ Where the defaults came from + -- see Note [Default exports] in GHC.Tc.Gen.Export + , cd_warn :: Maybe (WarningTxt GhcRn) + -- ^ Warning emitted when the default is used + } + deriving Data + +instance Outputable ClassDefaults where + ppr ClassDefaults {cd_class = cls, cd_types = tys} = text "default" <+> ppr cls + <+> parens (interpp'SP tys) + +emptyDefaultEnv :: DefaultEnv +emptyDefaultEnv = emptyNameEnv + +isEmptyDefaultEnv :: DefaultEnv -> Bool +isEmptyDefaultEnv = isEmptyNameEnv + +unitDefaultEnv :: ClassDefaults -> DefaultEnv +unitDefaultEnv d = unitNameEnv (className $ cd_class d) d + +defaultEnv :: [ClassDefaults] -> DefaultEnv +defaultEnv = mkNameEnvWith (className . cd_class) + +defaultList :: DefaultEnv -> [ClassDefaults] +defaultList = sortBy (stableNameCmp `on` className . cd_class) . nonDetNameEnvElts + -- sortBy recovers determinism + +insertDefaultEnv :: ClassDefaults -> DefaultEnv -> DefaultEnv +insertDefaultEnv d env = extendNameEnv env (className $ cd_class d) d + +lookupDefaultEnv :: DefaultEnv -> Name -> Maybe ClassDefaults +lookupDefaultEnv env = lookupUFM_Directly env . nameUnique + +filterDefaultEnv :: (ClassDefaults -> Bool) -> DefaultEnv -> DefaultEnv +filterDefaultEnv = filterNameEnv + +plusDefaultEnv :: DefaultEnv -> DefaultEnv -> DefaultEnv +plusDefaultEnv = plusNameEnv + +-- | Create a 'DefaultEnv' from a list of (Name, ClassDefaults) pairs +-- it is useful if we don't want to poke into the 'ClassDefaults' structure +-- to get the 'Name' of the class, it can be problematic, see #25858 +mkDefaultEnv :: [(Name, ClassDefaults)] -> DefaultEnv +mkDefaultEnv = mkNameEnv diff --git a/GHC/Types/Demand.hs b/GHC/Types/Demand.hs --- a/GHC/Types/Demand.hs +++ b/GHC/Types/Demand.hs @@ -1,3 +1,4 @@ + {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-} @@ -22,24 +23,26 @@ absDmd, topDmd, botDmd, seqDmd, topSubDmd, -- *** Least upper bound lubCard, lubDmd, lubSubDmd, + -- *** Greatest lower bound + glbCard, -- *** Plus plusCard, plusDmd, plusSubDmd, -- *** Multiply multCard, multDmd, multSubDmd, -- ** Predicates on @Card@inalities and @Demand@s - isAbs, isUsedOnce, isStrict, - isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd, + isAbs, isAtMostOnce, isStrict, + isAbsDmd, isAtMostOnceDmd, isStrUsedDmd, isStrictDmd, isTopDmd, isWeakDmd, onlyBoxedArguments, -- ** Special demands evalDmd, -- *** Demands used in PrimOp signatures lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd, -- ** Other @Demand@ operations - oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, - peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, + oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, floatifyDmd, + peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, strictCallArity, mkWorkerDemand, subDemandIfEvaluated, -- ** Extracting one-shot information - argOneShots, argsOneShots, saturatedByOneShots, + callCards, argOneShots, argsOneShots, saturatedByOneShots, -- ** Manipulating Boxity of a Demand unboxDeeplyDmd, @@ -48,7 +51,7 @@ -- * Demand environments DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, - reuseEnv, + multDmdEnv, reuseEnv, -- * Demand types DmdType(..), dmdTypeDepth, @@ -96,7 +99,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Coerce (coerce) import Data.Function @@ -541,9 +543,9 @@ isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set -- | True <=> upper bound is 1. -isUsedOnce :: Card -> Bool +isAtMostOnce :: Card -> Bool -- See Note [Bit vector representation for Card] -isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set +isAtMostOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set -- | Is this a 'CardNonAbs'? isCardNonAbs :: Card -> Bool @@ -551,7 +553,7 @@ -- | Is this a 'CardNonOnce'? isCardNonOnce :: Card -> Bool -isCardNonOnce n = isAbs n || not (isUsedOnce n) +isCardNonOnce n = isAbs n || not (isAtMostOnce n) -- | Intersect with [0,1]. oneifyCard :: Card -> Card @@ -604,24 +606,10 @@ -- * How many times a variable is evaluated, via a 'Card'inality, and -- * How deep its value was evaluated in turn, via a 'SubDemand'. -- --- Examples (using Note [Demand notation]): --- --- * 'seq' puts demand @1A@ on its first argument: It evaluates the argument --- strictly (@1@), but not any deeper (@A@). --- * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument --- pair strictly and the first component strictly, but no nested info --- beyond that (@L@). Its second argument is not used at all. --- * '$' puts demand @1C(1,L)@ on its first argument: It calls (@C@) the --- argument function with one argument, exactly once (@1@). No info --- on how the result of that call is evaluated (@L@). --- * 'maybe' puts demand @MC(M,L)@ on its second argument: It evaluates --- the argument function at most once ((M)aybe) and calls it once when --- it is evaluated. --- * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@ --- multiplied by two, so we get @S@ (used at least once, possibly multiple --- times). +-- See also Note [Demand notation] +-- and Note [Demand examples]. -- --- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled +-- This data type is quite similar to `'Scaled' 'SubDemand'`, but it's scaled -- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of -- which could be used to infer uniqueness types. Also we treat 'AbsDmd' and -- 'BotDmd' specially, as the concept of a 'SubDemand' doesn't apply when there @@ -928,8 +916,8 @@ isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) -- | Is the value used at most once? -isUsedOnceDmd :: Demand -> Bool -isUsedOnceDmd (n :* _) = isUsedOnce n +isAtMostOnceDmd :: Demand -> Bool +isAtMostOnceDmd (n :* _) = isAtMostOnce n -- | We try to avoid tracking weak free variable demands in strictness -- signatures for analysis performance reasons. @@ -993,24 +981,21 @@ strictifyDictDmd :: Type -> Demand -> Demand strictifyDictDmd ty (n :* Prod b ds) | not (isAbs n) - , Just field_tys <- as_non_newtype_dict ty - = C_1N :* mkProd b (zipWith strictifyDictDmd field_tys ds) + , isTerminatingType ty + , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty + = C_1N :* mkProd b (zipWith strictifyDictDmd (map scaledThing field_tys) ds) -- main idea: ensure it's strict - where - -- Return a TyCon and a list of field types if the given - -- type is a non-newtype dictionary type - as_non_newtype_dict ty - | isTerminatingType ty - , Just (_tc, _arg_tys, _data_con, field_tys) <- splitDataProductType_maybe ty - = Just (map scaledThing field_tys) - | otherwise - = Nothing strictifyDictDmd _ dmd = dmd -- | Make a 'Demand' lazy. lazifyDmd :: Demand -> Demand lazifyDmd = multDmd C_01 +-- | Adjust the demand on a binding that may float outwards +-- See Note [Floatifying demand info when floating] +floatifyDmd :: Demand -> Demand +floatifyDmd = multDmd C_0N + -- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd @@ -1036,6 +1021,12 @@ go _ _ _ = (topCard, topSubDmd) {-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context +strictCallArity :: SubDemand -> Arity +strictCallArity sd = go 0 sd + where + go n (Call card sd) | isStrict card = go (n+1) sd + go n _ = n + -- | Extract the 'SubDemand' of a 'Demand'. -- PRECONDITION: The SubDemand must be used in a context where the expression -- denoted by the Demand is under evaluation. @@ -1069,13 +1060,17 @@ argOneShots AbsDmd = [] -- This defn conflicts with 'saturatedByOneShots', argOneShots BotDmd = [] -- according to which we should return -- @repeat OneShotLam@ here... -argOneShots (_ :* sd) = go sd +argOneShots (_ :* sd) = map go (callCards sd) where - go (Call n sd) - | isUsedOnce n = OneShotLam : go sd - | otherwise = NoOneShotInfo : go sd - go _ = [] + go n | isAtMostOnce n = OneShotLam + | otherwise = NoOneShotInfo +-- | See Note [Computing one-shot info] +callCards :: SubDemand -> [Card] +callCards (Call n sd) = n : callCards sd +callCards (Poly _ _n) = [] -- n is never C_01 or C_11 so we may as well stop here +callCards Prod{} = [] + -- | -- @saturatedByOneShots n C(M,C(M,...)) = True@ -- <=> @@ -1084,7 +1079,7 @@ saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd = True saturatedByOneShots _ BotDmd = True -saturatedByOneShots n (_ :* sd) = isUsedOnce $ fst $ peelManyCalls n sd +saturatedByOneShots n (_ :* sd) = isAtMostOnce $ fst $ peelManyCalls n sd {- Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1386,33 +1381,16 @@ * it returns the demands on the arguments; in the above example that is [SL, A] -Nasty wrinkle. Consider this code (#22475 has more realistic examples but -assume this is what the demand analyser sees) - - data T = MkT !Int Bool - get :: T -> Bool - get (MkT _ b) = b - - foo = let v::Int = I# 7 - t::T = MkT v True - in get t - -Now `v` is unused by `get`, /but/ we can't give `v` an Absent demand, -else we'll drop the binding and replace it with an error thunk. -Then the code generator (more specifically GHC.Stg.InferTags.Rewrite) -will add an extra eval of MkT's argument to give - foo = let v::Int = error "absent" - t::T = case v of v' -> MkT v' True - in get t - -Boo! Because of this extra eval (added in STG-land), the truth is that `MkT` -may (or may not) evaluate its arguments (as established in #21497). Hence the -use of `bump` in dmdTransformDataConSig, which adds in a `C_01` eval. The -`C_01` says "may or may not evaluate" which is absolutely faithful to what -InferTags.Rewrite does. +When the data constructor worker has strict fields, an additional seq +will be inserted for each field (see (SFC3) in Note [Strict fields in Core]). +Hence we add an additional `seqDmd` for each strict field to emulate +field eval insertion. -In particular it is very important /not/ to make that a `C_11` eval, -see Note [Data-con worker strictness]. +For example, consider `data SP a b = MkSP !a !b` and expression `MkSP x y`, +with the same sub-demand P(SL,A). +The strict fields bump up the strictness; we'd get [SL,1!A] for the field +demands. Note that the first demand was unaffected by the seq, whereas +the second, previously absent demand became `seqDmd` exactly. -} {- ********************************************************************* @@ -1427,7 +1405,7 @@ -- -- [n] nontermination (e.g. loops) -- [i] throws imprecise exception --- [p] throws precise exceTtion +-- [p] throws precise exception -- [c] converges (reduces to WHNF). -- -- The different lattice elements correspond to different subsets, indicated by @@ -1612,6 +1590,29 @@ expression may not throw a precise exception (increasing precision of the analysis), but that's just a favourable guess. +Note [Side-effects and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Due to historic reasons and the continued effort not to cause performance +regressions downstream, Strictness Analysis is currently prone to discarding +observable side-effects (other than precise exceptions, see +Note [Precise exceptions and strictness analysis]) in some cases. For example, + f :: MVar () -> Int -> IO Int + f mv x = putMVar mv () >> (x `seq` return x) +The call to `putMVar` is an observable side-effect. Yet, Strictness Analysis +currently concludes that `f` is strict in `x` and uses call-by-value. +That means `f mv (error "boom")` will error out with the imprecise exception +rather performing the side-effect. + +This is a conscious violation of the semantics described in the paper +"a semantics for imprecise exceptions"; so it would be great if we could +identify the offending primops and extend the idea in +Note [Which scrutinees may throw precise exceptions] to general side-effects. + +Unfortunately, the existing has-side-effects classification for primops is +too conservative, listing `writeMutVar#` and even `readMutVar#` as +side-effecting. That is due to #3207. A possible way forward is described in +#17900, but no effort has been so far towards a resolution. + Note [Exceptions and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to smart about catching exceptions, but we aren't anymore. @@ -1735,7 +1736,7 @@ -- Subject to Note [Default demand on free variables and arguments] -- | Captures the result of an evaluation of an expression, by -- --- * Listing how the free variables of that expression have been evaluted +-- * Listing how the free variables of that expression have been evaluated -- ('de_fvs') -- * Saying whether or not evaluation would surely diverge ('de_div') -- @@ -1789,8 +1790,7 @@ -- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum' plusDmdEnvs :: [DmdEnv] -> DmdEnv -plusDmdEnvs [] = nopDmdEnv -plusDmdEnvs pdas = foldl1' plusDmdEnv pdas +plusDmdEnvs = foldl1WithDefault' nopDmdEnv plusDmdEnv multDmdEnv :: Card -> DmdEnv -> DmdEnv multDmdEnv C_11 env = env @@ -1833,7 +1833,7 @@ n = max (dmdTypeDepth d1) (dmdTypeDepth d2) (DmdType fv1 ds1) = etaExpandDmdType n d1 (DmdType fv2 ds2) = etaExpandDmdType n d2 - lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 + lub_ds = zipWithEqual lubDmd ds1 ds2 lub_fv = lubDmdEnv fv1 fv2 discardArgDmds :: DmdType -> DmdEnv @@ -1893,10 +1893,11 @@ splitDmdTy ty@DmdType{dt_env=env} = (defaultArgDmd (de_div env), ty) multDmdType :: Card -> DmdType -> DmdType -multDmdType n (DmdType fv args) +multDmdType C_11 dmd_ty = dmd_ty -- a vital optimisation for T25196 +multDmdType n (DmdType fv args) = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $ DmdType (multDmdEnv n fv) - (map (multDmd n) args) + (strictMap (multDmd n) args) peelFV :: DmdType -> Var -> (DmdType, Demand) peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) @@ -2068,6 +2069,12 @@ * * ************************************************************************ +Note [DmdSig: demand signatures, and demand-sig arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also + * Note [Demand signatures semantically] + * Note [Understanding DmdType and DmdSig] + In a let-bound Id we record its demand signature. In principle, this demand signature is a demand transformer, mapping a demand on the Id into a DmdType, which gives @@ -2078,20 +2085,22 @@ However, in fact we store in the Id an extremely emasculated demand transformer, namely - - a single DmdType + a single DmdType (Nevertheless we dignify DmdSig as a distinct type.) -This DmdType gives the demands unleashed by the Id when it is applied -to as many arguments as are given in by the arg demands in the DmdType. +The DmdSig for an Id is a semantic thing. Suppose a function `f` has a DmdSig of + DmdSig (DmdType (fv_dmds,res) [d1..dn]) +Here `n` is called the "demand-sig arity" of the DmdSig. The signature means: + * If you apply `f` to n arguments (the demand-sig-arity) + * then you can unleash demands d1..dn on the arguments + * and demands fv_dmds on the free variables. Also see Note [Demand type Divergence] for the meaning of a Divergence in a -strictness signature. +demand signature. -If an Id is applied to less arguments than its arity, it means that -the demand on the function at a call site is weaker than the vanilla -call demand, used for signature inference. Therefore we place a top -demand on all arguments. Otherwise, the demand is specified by Id's -signature. +If `f` is applied to fewer value arguments than its demand-sig arity, it means +that the demand on the function at a call site is weaker than the vanilla call +demand, used for signature inference. Therefore we place a top demand on all +arguments. For example, the demand transformer described by the demand signature DmdSig (DmdType {x -> <1L>} <1P(L,L)>) @@ -2102,6 +2111,61 @@ If this same function is applied to one arg, all we can say is that it uses x with 1L, and its arg with demand 1P(L,L). +Note [Demand signatures semantically] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand analysis interprets expressions in the abstract domain of demand +transformers. Given a (sub-)demand that denotes the evaluation context, the +abstract transformer of an expression gives us back a demand type denoting +how other things (like arguments and free vars) were used when the expression +was evaluated. Here's an example: + + f x y = + if x + expensive + then \z -> z + y * ... + else \z -> z * ... + +The abstract transformer (let's call it F_e) of the if expression (let's +call it e) would transform an incoming (undersaturated!) head sub-demand A +into a demand type like {x-><1L>,y->}. In pictures: + + SubDemand ---F_e---> DmdType + {x-><1L>,y->} + +Let's assume that the demand transformers we compute for an expression are +correct wrt. to some concrete semantics for Core. How do demand signatures fit +in? They are strange beasts, given that they come with strict rules when to +it's sound to unleash them. + +Fortunately, we can formalise the rules with Galois connections. Consider +f's strictness signature, {}<1L>. It's a single-point approximation of +the actual abstract transformer of f's RHS for arity 2. So, what happens is that +we abstract *once more* from the abstract domain we already are in, replacing +the incoming Demand by a simple lattice with two elements denoting incoming +arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom +element). Here's the diagram: + + A_2 -----f_f----> DmdType + ^ | + | α γ | + | v + SubDemand --F_f----> DmdType + +With + α(C(1,C(1,_))) = >=2 + α(_) = <2 + γ(ty) = ty +and F_f being the abstract transformer of f's RHS and f_f being the abstracted +abstract transformer computable from our demand signature simply by + + f_f(>=2) = {}<1L> + f_f(<2) = multDmdType C_0N {}<1L> + +where multDmdType makes a proper top element out of the given demand type. + +In practice, the A_n domain is not just a simple Bool, but a Card, which is +exactly the Card with which we have to multDmdType. The Card for arity n +is computed by calling @peelManyCalls n@, which corresponds to α above. + Note [Understanding DmdType and DmdSig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to @@ -2114,10 +2178,10 @@ put that expression under. Note the monotonicity; a stronger incoming demand yields a more precise demand type: - incoming demand | demand type + incoming sub-demand | demand type -------------------------------- - 1A | {} - C(1,C(1,L)) | <1P(L)>{} + P(A) | {} + C(1,C(1,P(L))) | <1P(L)>{} C(1,C(1,1P(1P(L),A))) | <1P(A)>{} Note that in the first example, the depth of the demand type was *higher* than @@ -2138,11 +2202,11 @@ * A demand type that is sound to unleash when the minimum arity requirement is met. -Here comes the subtle part: The threshold is encoded in the wrapped demand -type's depth! So in mkDmdSigForArity we make sure to trim the list of -argument demands to the given threshold arity. Call sites will make sure that -this corresponds to the arity of the call demand that elicited the wrapped -demand type. See also Note [What are demand signatures?]. +Here comes the subtle part: The threshold is encoded in the demand-sig arity! +So in mkDmdSigForArity we make sure to trim the list of argument demands to the +given threshold arity. Call sites will make sure that this corresponds to the +arity of the call demand that elicited the wrapped demand type. See also +Note [DmdSig: demand signatures, and demand-sig arity] -} -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe @@ -2155,9 +2219,11 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig -mkDmdSigForArity arity dmd_ty@(DmdType fvs args) - | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) - | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) +mkDmdSigForArity threshold_arity dmd_ty@(DmdType fvs args) + | threshold_arity < dmdTypeDepth dmd_ty + = DmdSig $ DmdType (fvs { de_div = topDiv }) (take threshold_arity args) + | otherwise + = DmdSig (etaExpandDmdType threshold_arity dmd_ty) mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds) @@ -2302,7 +2368,7 @@ -- whether it diverges. -- -- See Note [Understanding DmdType and DmdSig] --- and Note [What are demand signatures?]. +-- and Note [DmdSig: demand signatures, and demand-sig arity] type DmdTransformer = SubDemand -> DmdType -- | Extrapolate a demand signature ('DmdSig') into a 'DmdTransformer'. @@ -2313,7 +2379,7 @@ dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty -- see Note [Demands from unsaturated function calls] - -- and Note [What are demand signatures?] + -- and Note [DmdSig: demand signatures, and demand-sig arity] -- | A special 'DmdTransformer' for data constructors that feeds product -- demands into the constructor arguments. @@ -2328,84 +2394,33 @@ mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd) | otherwise = multDmd n dmd - str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness] + str_field_dmd = seqDmd -- See the bit about strict fields + -- in Note [Demand transformer for data constructors] -- | A special 'DmdTransformer' for dictionary selectors that feeds the demand -- on the result into the indicated dictionary component (if saturated). -- See Note [Demand transformer for a dictionary selector]. dmdTransformDictSelSig :: DmdSig -> DmdTransformer --- NB: This currently doesn't handle newtype dictionaries. --- It should simply apply call_sd directly to the dictionary, I suppose. -dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd + + +dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* dict_dmd])) call_sd + -- NB: dict_dmd comes from the demand signature of the class-op + -- which is created in GHC.Types.Id.Make.mkDictSelId | (n, sd') <- peelCallDmd call_sd - , Prod _ sig_ds <- prod + , Prod _ sig_ds <- dict_dmd = multDmdType n $ DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where - enhance _ AbsDmd = AbsDmd - enhance _ BotDmd = BotDmd - enhance sd _dmd_var = C_11 :* sd -- This is the one! - -- C_11, because we multiply with n above + enhance _ AbsDmd = AbsDmd + enhance _ BotDmd = BotDmd + enhance sd' _dmd_var = C_11 :* sd' -- This is the one! + -- C_11, because we multiply with n above + dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd) {- -Note [What are demand signatures?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand analysis interprets expressions in the abstract domain of demand -transformers. Given a (sub-)demand that denotes the evaluation context, the -abstract transformer of an expression gives us back a demand type denoting -how other things (like arguments and free vars) were used when the expression -was evaluated. Here's an example: - - f x y = - if x + expensive - then \z -> z + y * ... - else \z -> z * ... - -The abstract transformer (let's call it F_e) of the if expression (let's -call it e) would transform an incoming (undersaturated!) head demand 1A into -a demand type like {x-><1L>,y->}. In pictures: - - Demand ---F_e---> DmdType - <1A> {x-><1L>,y->} - -Let's assume that the demand transformers we compute for an expression are -correct wrt. to some concrete semantics for Core. How do demand signatures fit -in? They are strange beasts, given that they come with strict rules when to -it's sound to unleash them. - -Fortunately, we can formalise the rules with Galois connections. Consider -f's strictness signature, {}<1L>. It's a single-point approximation of -the actual abstract transformer of f's RHS for arity 2. So, what happens is that -we abstract *once more* from the abstract domain we already are in, replacing -the incoming Demand by a simple lattice with two elements denoting incoming -arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom -element). Here's the diagram: - - A_2 -----f_f----> DmdType - ^ | - | α γ | - | v - SubDemand --F_f----> DmdType - -With - α(C(1,C(1,_))) = >=2 - α(_) = <2 - γ(ty) = ty -and F_f being the abstract transformer of f's RHS and f_f being the abstracted -abstract transformer computable from our demand signature simply by - - f_f(>=2) = {}<1L> - f_f(<2) = multDmdType C_0N {}<1L> - -where multDmdType makes a proper top element out of the given demand type. - -In practice, the A_n domain is not just a simple Bool, but a Card, which is -exactly the Card with which we have to multDmdType. The Card for arity n -is computed by calling @peelManyCalls n@, which corresponds to α above. - Note [Demand transformer for a dictionary selector] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have a superclass selector 'sc_sel' and a class method @@ -2445,21 +2460,8 @@ the whole signature really means `\d. P(AAAdAAAAA)` for any incoming demand 'd'. -For single-method classes, which are represented by newtypes the signature -of 'op' won't look like P(...), so matching on Prod will fail. -That's fine: if we are doing strictness analysis we are also doing inlining, -so we'll have inlined 'op' into a cast. So we can bale out in a conservative -way, returning nopDmdType. SG: Although we then probably want to apply the eval -demand 'd' directly to 'op' rather than turning it into 'topSubDmd'... - -It is (just.. #8329) possible to be running strictness analysis *without* -having inlined class ops from single-method classes. Suppose you are using -ghc --make; and the first module has a local -O0 flag. So you may load a class -without interface pragmas, ie (currently) without an unfolding for the class -ops. Now if a subsequent module in the --make sweep has a local -O flag -you might do strictness analysis, but there is no inlining for the class op. -This is weird, so I'm not worried about whether this optimises brilliantly; but -it should not fall over. +NB: even unary classes behave as if there was a data constructor, and so do +not need special handling here. See Note [Unary class magic] in GHC.Core.TyCon. -} zapDmdEnv :: DmdEnv -> DmdEnv @@ -2629,7 +2631,8 @@ but it's always clear from context which "overload" is meant. It's like return-type inference of e.g. 'read'. -Examples are in the haddock for 'Demand'. +An example of the demand syntax is 1!P(1!L,A), the demand of fst's argument. +See Note [Demand examples] for more examples and their semantics. This is the syntax for demand signatures: @@ -2647,7 +2650,39 @@ (omitted if empty) (omitted if no information) +Note [Demand examples] +~~~~~~~~~~~~~~~~~~~~~~ +Here are some examples of the demand notation, specified in Note [Demand notation], +in action. In each case we give the demand on the variable `x`. +Demand on x Example Explanation + 1!A seq x y Evaluates `x` exactly once (`1`), but not + any deeper (`A`), and discards the box (`!`). + S!A seq x (seq x y) Twice the previous demand; hence eval'd + more than once (`S` for strict). + 1!P(1!L,A) fst x Evaluates pair `x` exactly once, first + component exactly once. No info that (`L`). + Second component is absent. Discards boxes (`!`). + 1P(1L,A) opq_fst x Like fst, but all boxes are retained. + SP(1!L,A) opq_seq x (fst x) Two evals of x but exactly one of its first component. + Box of x retained, but box of first component discarded. + 1!C(1,L) x $ 3 Evals x exactly once ( 1 ) and calls it + exactly once ( C(1,_) ). No info on how the + result is evaluated ( L ). + MC(M,L) maybe y x Evals x at most once ( 1 ) and calls it at + most once ( C(1,_) ). No info on how the + result is evaluated ( L ). + LP(SL,A) map (+ fst x) Evals x lazily and multiple times ( L ), + but when it is evaluated, the first + component is evaluated (strictly) as well. + +In the examples above, `opq_fst` is an opaque wrapper around `fst`, i.e. + + opq_fst = fst + {-# OPAQUE opq_fst #-} + +Similarly for `seq`. The effect of an OPAQUE pragma is that it discards any +boxity flags in the demand signature, as described in Note [OPAQUE pragma]. -} -- | See Note [Demand notation] diff --git a/GHC/Types/Error.hs b/GHC/Types/Error.hs --- a/GHC/Types/Error.hs +++ b/GHC/Types/Error.hs @@ -21,6 +21,7 @@ , addMessage , unionMessages , unionManyMessages + , filterMessages , MsgEnvelope (..) -- * Classifying Messages @@ -29,13 +30,13 @@ , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) + , UnknownDiagnosticFor , mkSimpleUnknownDiagnostic , mkUnknownDiagnostic , embedUnknownDiagnostic , DiagnosticMessage (..) , DiagnosticReason (WarningWithFlag, ..) , ResolvedDiagnosticReason(..) - , DiagnosticHint (..) , mkPlainDiagnostic , mkPlainError , mkDecoratedDiagnostic @@ -99,23 +100,26 @@ import GHC.Types.Hint import GHC.Data.FastString (unpackFS) import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) + +import GHC.Types.Hint.Ppr () -- Outputable instance +import GHC.Unit.Module.Warnings (WarningCategory(..)) + import GHC.Utils.Json import GHC.Utils.Panic -import GHC.Unit.Module.Warnings (WarningCategory) +import GHC.Version (cProjectVersion) import Data.Bifunctor -import Data.Foldable ( fold ) +import Data.Foldable ( fold, toList ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) +import Data.Maybe ( maybeToList ) import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Text.Printf ( printf ) -{- -Note [Messages] -~~~~~~~~~~~~~~~ - +{- Note [Messages] +~~~~~~~~~~~~~~~~~~ We represent the 'Messages' as a single bag of warnings and errors. The reason behind that is that there is a fluid relationship between errors @@ -167,6 +171,9 @@ pprDiagnostic (errMsgDiagnostic envelope) ] +instance (Diagnostic e) => ToJson (Messages e) where + json msgs = JSArray . toList $ json <$> getMessages msgs + {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -194,6 +201,10 @@ unionManyMessages :: Foldable f => f (Messages e) -> Messages e unionManyMessages = fold +filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e +filterMessages f (Messages msgs) = + Messages (filterBag f msgs) + -- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the -- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its -- final form, where the typical case would be adding bullets between each @@ -240,11 +251,16 @@ -- A 'Diagnostic' carries the /actual/ description of the message (which, in -- GHC's case, it can be an error or a warning) and the /reason/ why such -- message was generated in the first place. -class (HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where +class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where -- | Type of configuration options for the diagnostic. type DiagnosticOpts a + -- | Type of hint this diagnostic can provide. + -- By default, this is 'GhcHint'. + type DiagnosticHint a + type DiagnosticHint a = GhcHint + -- | Extract the error message text from a 'Diagnostic'. diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc @@ -254,7 +270,7 @@ -- | Extract any hints a user might use to repair their -- code to avoid this diagnostic. - diagnosticHints :: a -> [GhcHint] + diagnosticHints :: a -> [DiagnosticHint a] -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'. -- This can return 'Nothing' for at least two reasons: @@ -271,37 +287,45 @@ diagnosticCode :: a -> Maybe DiagnosticCode -- | An existential wrapper around an unknown diagnostic. -data UnknownDiagnostic opts where +data UnknownDiagnostic opts hint where UnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -- Inject the options of the outer context -- into the options for the wrapped diagnostic. + -> (DiagnosticHint a -> hint) -> a - -> UnknownDiagnostic opts + -> UnknownDiagnostic opts hint -instance HasDefaultDiagnosticOpts opts => Diagnostic (UnknownDiagnostic opts) where - type DiagnosticOpts (UnknownDiagnostic opts) = opts - diagnosticMessage opts (UnknownDiagnostic f diag) = diagnosticMessage (f opts) diag - diagnosticReason (UnknownDiagnostic _ diag) = diagnosticReason diag - diagnosticHints (UnknownDiagnostic _ diag) = diagnosticHints diag - diagnosticCode (UnknownDiagnostic _ diag) = diagnosticCode diag +type UnknownDiagnosticFor a = UnknownDiagnostic (DiagnosticOpts a) (DiagnosticHint a) +instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (UnknownDiagnostic opts hint) where + type DiagnosticOpts (UnknownDiagnostic opts _) = opts + type DiagnosticHint (UnknownDiagnostic _ hint) = hint + diagnosticMessage opts (UnknownDiagnostic f _ diag) = diagnosticMessage (f opts) diag + diagnosticReason (UnknownDiagnostic _ _ diag) = diagnosticReason diag + diagnosticHints (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag) + diagnosticCode (UnknownDiagnostic _ _ diag) = diagnosticCode diag + -- A fallback 'DiagnosticOpts' which can be used when there are no options -- for a particular diagnostic. data NoDiagnosticOpts = NoDiagnosticOpts instance HasDefaultDiagnosticOpts NoDiagnosticOpts where defaultOpts = NoDiagnosticOpts --- | Make a "simple" unknown diagnostic which doesn't have any configuration options. -mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => a -> UnknownDiagnostic b -mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts) +-- | Make a "simple" unknown diagnostic which doesn't have any configuration options +-- and the same hint. +mkSimpleUnknownDiagnostic :: (Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) => + a -> UnknownDiagnostic b (DiagnosticHint a) +mkSimpleUnknownDiagnostic = UnknownDiagnostic (const NoDiagnosticOpts) id --- | Make an unknown diagnostic which uses the same options as the context it will be embedded into. -mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => a -> UnknownDiagnostic (DiagnosticOpts a) -mkUnknownDiagnostic = UnknownDiagnostic id +-- | Make an unknown diagnostic which uses the same options and hint +-- as the context it will be embedded into. +mkUnknownDiagnostic :: (Typeable a, Diagnostic a) => + a -> UnknownDiagnosticFor a +mkUnknownDiagnostic = UnknownDiagnostic id id -- | Embed a more complicated diagnostic which requires a potentially different options type. -embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts -embedUnknownDiagnostic = UnknownDiagnostic +embedUnknownDiagnostic :: (Diagnostic a, Typeable a) => (opts -> DiagnosticOpts a) -> a -> UnknownDiagnostic opts (DiagnosticHint a) +embedUnknownDiagnostic f = UnknownDiagnostic f id -------------------------------------------------------------------------------- @@ -310,15 +334,10 @@ , nest 2 (vcat (unDecorated (diagnosticMessage opts e))) ] where opts = defaultDiagnosticOpts @e --- | A generic 'Hint' message, to be used with 'DiagnosticMessage'. -data DiagnosticHint = DiagnosticHint !SDoc -instance Outputable DiagnosticHint where - ppr (DiagnosticHint msg) = msg - -- | A generic 'Diagnostic' message, without any further classification or -- provenance: By looking at a 'DiagnosticMessage' we don't know neither --- /where/ it was generated nor how to intepret its payload (as it's just a +-- /where/ it was generated nor how to interpret its payload (as it's just a -- structured document). All we can do is to print it out and look at its -- 'DiagnosticReason'. data DiagnosticMessage = DiagnosticMessage @@ -386,10 +405,8 @@ pattern WarningWithFlag :: WarningFlag -> DiagnosticReason pattern WarningWithFlag w = WarningWithFlags (w :| []) -{- -Note [Warnings controlled by multiple flags] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - +{- Note [Warnings controlled by multiple flags] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Diagnostics that started life as flag-controlled warnings have a 'diagnosticReason' of 'WarningWithFlags', giving the flags that control the warning. Usually there is only one flag, but in a few cases multiple flags @@ -537,7 +554,9 @@ SevError -> text "SevError" instance ToJson Severity where - json s = JSString (show s) + json SevIgnore = JSString "Ignore" + json SevWarning = JSString "Warning" + json SevError = JSString "Error" instance ToJson MessageClass where json MCOutput = JSString "MCOutput" @@ -548,6 +567,67 @@ json (MCDiagnostic sev reason code) = JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) +instance ToJson DiagnosticCode where + json c = JSInt (fromIntegral (diagnosticCodeNumber c)) + +{- Note [Diagnostic Message JSON Schema] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The below instance of ToJson must conform to the JSON schema +specified in docs/users_guide/diagnostics-as-json-schema-1_1.json. +When the schema is altered, please bump the version. +If the content is altered in a backwards compatible way, +update the minor version (e.g. 1.3 ~> 1.4). +If the content is breaking, update the major version (e.g. 1.3 ~> 2.0). +When updating the schema, replace the above file and name it appropriately with +the version appended, and change the documentation of the -fdiagnostics-as-json +flag to reflect the new schema. +To learn more about JSON schemas, check out the below link: +https://json-schema.org +-} + +schemaVersion :: String +schemaVersion = "1.1" +-- See Note [Diagnostic Message JSON Schema] before editing! +instance Diagnostic e => ToJson (MsgEnvelope e) where + json m = JSObject $ [ + ("version", JSString schemaVersion), + ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion), + ("span", json $ errMsgSpan m), + ("severity", json $ errMsgSeverity m), + ("code", maybe JSNull json (diagnosticCode diag)), + ("message", JSArray $ map renderToJSString diagMsg), + ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) ) ] + ++ [ ("reason", reasonJson) + | reasonJson <- maybeToList $ usefulReasonJson_maybe (errMsgReason m) ] + where + diag = errMsgDiagnostic m + opts = defaultDiagnosticOpts @e + ctx = defaultSDocContext { + sdocStyle = mkErrStyle (errMsgContext m) + , sdocCanUseUnicode = True + -- Using Unicode makes it easier to consume the JSON output, + -- e.g. a suggestion to use foldl' will be displayed as + -- \u2018foldl'\u2019, which is not easily confused with + -- the quoted ‘foldl’ (note: no tick). + } + diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag)) + renderToJSString :: SDoc -> JsonDoc + renderToJSString = JSString . (renderWithContext ctx) + + usefulReasonJson_maybe :: ResolvedDiagnosticReason -> Maybe JsonDoc + usefulReasonJson_maybe (ResolvedDiagnosticReason rea) = + case rea of + WarningWithoutFlag -> Nothing + ErrorWithoutFlag -> Nothing + WarningWithFlags flags -> + Just $ JSObject + [ ("flags", JSArray $ map (JSString . NE.head . warnFlagNames) (NE.toList flags)) + ] + WarningWithCategory (WarningCategory cat) -> + Just $ JSObject + [ ("category", JSString $ unpackFS cat) + ] + instance Show (MsgEnvelope DiagnosticMessage) where show = showMsgEnvelope @@ -600,9 +680,18 @@ -> brackets msg _ -> empty + ppr_with_hyperlink code = + -- this is a bit hacky, but we assume that if the terminal supports colors + -- then it should also support links + sdocOption (\ ctx -> sdocPrintErrIndexLinks ctx) $ + \ use_hyperlinks -> + if use_hyperlinks + then ppr $ LinkedDiagCode code + else ppr code + code_doc = case msg_class of - MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code) + MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code) _ -> empty flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc @@ -804,8 +893,29 @@ , diagnosticCodeNumber :: Natural -- ^ the actual diagnostic code } + deriving ( Eq, Ord ) -instance Outputable DiagnosticCode where - ppr (DiagnosticCode prefix c) = - text prefix <> text "-" <> text (printf "%05d" c) +instance Show DiagnosticCode where + show (DiagnosticCode prefix c) = + prefix ++ "-" ++ printf "%05d" c -- pad the numeric code to have at least 5 digits + +instance Outputable DiagnosticCode where + ppr code = text (show code) + +-- | A newtype that is a witness to the `-fprint-error-index-links` flag. It +-- alters the @Outputable@ instance to emit @DiagnosticCode@ as ANSI hyperlinks +-- to the HF error index +newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode + +instance Outputable LinkedDiagCode where + ppr (LinkedDiagCode d@DiagnosticCode{}) = linkEscapeCode d + +-- | Wrap the link in terminal escape codes specified by OSC 8. +linkEscapeCode :: DiagnosticCode -> SDoc +linkEscapeCode d = text "\ESC]8;;" <> hfErrorLink d -- make the actual link + <> text "\ESC\\" <> ppr d <> text "\ESC]8;;\ESC\\" -- the rest is the visible text + +-- | create a link to the HF error index given an error code. +hfErrorLink :: DiagnosticCode -> SDoc +hfErrorLink errorCode = text "https://errors.haskell.org/messages/" <> ppr errorCode diff --git a/GHC/Types/Error/Codes.hs b/GHC/Types/Error/Codes.hs --- a/GHC/Types/Error/Codes.hs +++ b/GHC/Types/Error/Codes.hs @@ -16,30 +16,44 @@ -- A diagnostic code is a numeric unique identifier for a diagnostic. -- See Note [Diagnostic codes]. module GHC.Types.Error.Codes - ( constructorCode ) + ( -- * General diagnostic code infrastructure + DiagnosticCodeNameSpace(NameSpaceTag, DiagnosticCodeFor, ConRecursIntoFor) + , Outdated + , constructorCode, constructorCodes + -- * GHC diagnostic codes + , GHC, GhcDiagnosticCode, ConRecursInto + ) where import GHC.Prelude -import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode, NoDiagnosticOpts ) -import GHC.Hs.Extension ( GhcRn ) +import GHC.Core.InstEnv ( LookupInstanceErrReason ) +import GHC.Hs.Extension ( GhcRn ) +import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..) + , diagnosticCode, UnknownDiagnosticFor ) -import GHC.Core.InstEnv (LookupInstanceErrReason) import GHC.Iface.Errors.Types -import GHC.Driver.Errors.Types ( DriverMessage, GhcMessageOpts, DriverMessageOpts ) +import GHC.Driver.Errors.Types ( DriverMessage ) import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage ) -import GHC.HsToCore.Errors.Types ( DsMessage ) +import GHC.HsToCore.Errors.Types ( DsMessage, UselessSpecialisePragmaReason ) import GHC.Tc.Errors.Types import GHC.Unit.Module.Warnings ( WarningTxt ) import GHC.Utils.Panic.Plain +-- Import all the structured error data types +import GHC.Driver.Errors.Types ( GhcMessage ) + import Data.Kind ( Type, Constraint ) import GHC.Exts ( proxy# ) import GHC.Generics -import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) ) +import GHC.TypeLits ( Symbol, KnownSymbol, symbolVal' + , TypeError, ErrorMessage(..) ) import GHC.TypeNats ( Nat, KnownNat, natVal' ) +import Data.Map.Strict ( Map ) +import qualified Data.Map.Strict as Map + {- Note [Diagnostic codes] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Every time a new diagnostic (error or warning) is introduced to GHC, @@ -53,8 +67,12 @@ - a diagnostic code never gets deleted from the GhcDiagnosticCode type family in GHC.Types.Error.Codes, even if it is no longer used. Older versions of GHC might still display the code, and we don't want that - old code to get confused with the error code of a different, new, error message. + old code to get confused with the error code of a different, new, error message.* +Note that this module also provides a 'DiagnosticCodeNameSpace' typeclass which +allows diagnostic codes to be emitted in different namespaces than the GHC +namespace; see Note [Diagnostic code namespaces]. + [Instructions for adding a new diagnostic code] After adding a constructor to a diagnostic datatype, such as PsMessage, @@ -67,7 +85,7 @@ GhcDiagnosticCode "MyNewErrorConstructor" = 12345 You can obtain new randomly-generated error codes by using - https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain. + https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain You will get a type error if you try to use an error code that is already used by another constructor. @@ -95,21 +113,94 @@ Never remove a return value from the 'GhcDiagnosticCode' type family! Outdated error messages must still be tracked to ensure uniqueness - of diagnostic codes across GHC versions. + of diagnostic codes across GHC versions. Instead, you should wrap the + return value in the 'Outdated' type synonym. The presence of this type synonym + is used by the 'codes' test to determine which diagnostic codes to check + for testsuite coverage. -} {- ********************************************************************* * * - The GhcDiagnosticCode type family + DiagnosticCode infrastructure * * ********************************************************************* -} --- | This function obtain a diagnostic code by looking up the constructor --- name using generics, and using the 'GhcDiagnosticCode' type family. -constructorCode :: (Generic diag, GDiagnosticCode (Rep diag)) +{- Note [Diagnostic code namespaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The machinery for GHC diagnostic codes described in Note [Diagnostic codes] +works for other namespaces than the GHC namespaces; one example is GHCi-specific +diagnostic codes. + +To achieve this, we parametrise all the machinery over a namespace type-level +argument, using the 'DiagnosticCodeNameSpace' class. +To provide diagnostic codes, one needs to supply an instance of this class, +which means supplying the following pieces of information: + + - a type that represents the namespace, e.g. `data GHC` can be used to + represent the GHC namespace, + - a type family equation for 'NameSpaceTag', e.g. 'NameSpaceTag GHC = "GHC"', + - a diagnostic code type family, e.g. 'DiagnosticCodeFor GHC con = GhcDiagnosticCode con', + - a type family that specifies how to recur into constructor arguments, + e.g. 'ConRecursIntoFor GHC con = ConRecursInto con'. + +This allows any tool that imports the GHC library to re-use the diagnostic +code machinery that GHC uses. +-} + +-- | A constraint for a namespace which has its own diagnostic codes. +-- +-- See Note [Diagnostic code namespaces]. +type DiagnosticCodeNameSpace :: Type -> Constraint +class DiagnosticCodeNameSpace namespace where + -- | The symbolic tag for a namespace. + type NameSpaceTag namespace = (r :: Symbol) | r -> namespace + -- NB: the injectivity annotation ensures uniqueness of namespaces, + -- e.g. it prevents two different namespaces from using the same symbolic tag. + -- | A diagnostic code in a given namespace. + type DiagnosticCodeFor namespace (c :: Symbol) :: Nat + -- | Specify that one should recur into an argument of a constructor + -- in order to obtain a diagnostic code. See Note [Diagnostic codes]. + type ConRecursIntoFor namespace (c :: Symbol) :: Maybe Type + +-- | Use this type synonym to mark a diagnostic code as outdated. +-- +-- The presence of this type synonym is used by the 'codes' test to determine +-- which diagnostic codes to check for testsuite coverage. +type Outdated a = a + +-- | This function obtains a diagnostic code by looking up the constructor +-- name using generics, and using the 'DiagnosticCode' type family. +constructorCode :: forall namespace diag + . (Generic diag, GDiagnosticCode namespace (Rep diag)) => diag -> Maybe DiagnosticCode -constructorCode diag = gdiagnosticCode (from diag) +constructorCode diag = gdiagnosticCode @namespace (from diag) +-- | This function computes all diagnostic codes that occur inside a given +-- type using generics and the 'DiagnosticCode' type family. +-- +-- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and +-- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get +-- > constructorCodes @GHC @T = fromList [ (DiagnosticCode "GHC" 123, \"MkT1\"), (DiagnosticCode "GHC" 456, \"MkT2\") ] +constructorCodes :: forall namespace diag + . (Generic diag, GDiagnosticCodes namespace '[diag] (Rep diag)) + => Map DiagnosticCode String +constructorCodes = gdiagnosticCodes @namespace @'[diag] @(Rep diag) + -- See Note [diagnosticCodes: don't recur into already-seen types] + -- for the @'[diag] type argument. + +{- ********************************************************************* +* * + The GhcDiagnosticCode type family +* * +********************************************************************* -} + +-- | The GHC namespace for diagnostic codes. +data GHC +instance DiagnosticCodeNameSpace GHC where + type instance NameSpaceTag GHC = "GHC" + type instance DiagnosticCodeFor GHC con = GhcDiagnosticCode con + type instance ConRecursIntoFor GHC con = ConRecursInto con + -- | Type family computing the numeric diagnostic code for a given error message constructor. -- -- Its injectivity annotation ensures uniqueness of error codes. @@ -131,9 +222,6 @@ GhcDiagnosticCode "DsMaxPmCheckModelsReached" = 61505 GhcDiagnosticCode "DsNonExhaustivePatterns" = 62161 GhcDiagnosticCode "DsTopLevelBindsNotAllowed" = 48099 - GhcDiagnosticCode "DsUselessSpecialiseForClassMethodSelector" = 93315 - GhcDiagnosticCode "DsUselessSpecialiseForNoInlineFunction" = 38524 - GhcDiagnosticCode "DsMultiplicityCoercionsNotSupported" = 59840 GhcDiagnosticCode "DsOrphanRule" = 58181 GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441 GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828 @@ -148,7 +236,12 @@ GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys" = 20185 GhcDiagnosticCode "DsRuleMightInlineFirst" = 95396 GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502 + GhcDiagnosticCode "DsIncompleteRecordSelector" = 17335 + -- Constructors of 'UselessSpecialisePragmaReason' + GhcDiagnosticCode "UselessSpecialiseForClassMethodSelector" = 93315 + GhcDiagnosticCode "UselessSpecialiseForNoInlineFunction" = 38524 + GhcDiagnosticCode "UselessSpecialiseNoSpecialisation" = 66582 -- Parser diagnostic codes GhcDiagnosticCode "PsErrParseLanguagePragma" = 68686 @@ -167,6 +260,7 @@ GhcDiagnosticCode "PsWarnUnrecognisedPragma" = 42044 GhcDiagnosticCode "PsWarnMisplacedPragma" = 28007 GhcDiagnosticCode "PsWarnImportPreQualified" = 07924 + GhcDiagnosticCode "PsWarnViewPatternSignatures" = 00834 GhcDiagnosticCode "PsErrLexer" = 21231 GhcDiagnosticCode "PsErrCmmLexer" = 75725 GhcDiagnosticCode "PsErrCmmParser" = 09848 @@ -201,6 +295,7 @@ GhcDiagnosticCode "PsErrUnallowedPragma" = 85314 GhcDiagnosticCode "PsErrImportPostQualified" = 87491 GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661 + GhcDiagnosticCode "PsErrSpliceOrQuoteTwice" = 26105 GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284 GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396 GhcDiagnosticCode "PsErrMissingBlock" = 16849 @@ -222,17 +317,18 @@ GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat" = 76595 GhcDiagnosticCode "PsErrDoNotationInPat" = 06446 GhcDiagnosticCode "PsErrIfThenElseInPat" = 45696 - GhcDiagnosticCode "PsErrLambdaCaseInPat" = 07636 + GhcDiagnosticCode "PsErrLambdaCaseInPat" = Outdated 07636 GhcDiagnosticCode "PsErrCaseInPat" = 53786 GhcDiagnosticCode "PsErrLetInPat" = 78892 GhcDiagnosticCode "PsErrLambdaInPat" = 00482 GhcDiagnosticCode "PsErrArrowExprInPat" = 04584 GhcDiagnosticCode "PsErrArrowCmdInPat" = 98980 GhcDiagnosticCode "PsErrArrowCmdInExpr" = 66043 - GhcDiagnosticCode "PsErrViewPatInExpr" = 66228 + GhcDiagnosticCode "PsErrViewPatInExpr" = Outdated 66228 + GhcDiagnosticCode "PsErrOrPatInExpr" = 66718 GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd" = 12178 GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd" = 92971 - GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = 47171 + GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = Outdated 47171 GhcDiagnosticCode "PsErrIfCmdInFunAppCmd" = 97005 GhcDiagnosticCode "PsErrLetCmdInFunAppCmd" = 70526 GhcDiagnosticCode "PsErrDoCmdInFunAppCmd" = 77808 @@ -240,7 +336,7 @@ GhcDiagnosticCode "PsErrMDoInFunAppExpr" = 67630 GhcDiagnosticCode "PsErrLambdaInFunAppExpr" = 06074 GhcDiagnosticCode "PsErrCaseInFunAppExpr" = 25037 - GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr" = 77182 + GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr" = Outdated 77182 GhcDiagnosticCode "PsErrLetInFunAppExpr" = 90355 GhcDiagnosticCode "PsErrIfInFunAppExpr" = 01239 GhcDiagnosticCode "PsErrProcInFunAppExpr" = 04807 @@ -269,6 +365,12 @@ GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744 GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380 GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623 + GhcDiagnosticCode "PsErrInvalidPun" = 52943 + GhcDiagnosticCode "PsErrIllegalOrPat" = 29847 + GhcDiagnosticCode "PsErrTypeSyntaxInPat" = 32181 + GhcDiagnosticCode "PsErrSpecExprMultipleTypeAscription" = 62037 + GhcDiagnosticCode "PsWarnSpecMultipleTypeAscription" = 73026 + GhcDiagnosticCode "PsWarnPatternNamespaceSpecifier" = 68383 -- Driver diagnostic codes GhcDiagnosticCode "DriverMissingHomeModules" = 32850 @@ -300,6 +402,9 @@ GhcDiagnosticCode "DriverPackageTrustIgnored" = 83552 GhcDiagnosticCode "DriverUnrecognisedFlag" = 93741 GhcDiagnosticCode "DriverDeprecatedFlag" = 53692 + GhcDiagnosticCode "DriverModuleGraphCycle" = 92213 + GhcDiagnosticCode "DriverInstantiationNodeInDependencyGeneration" = 74284 + GhcDiagnosticCode "DriverNoConfiguredLLVMToolchain" = 66599 -- Constraint solver diagnostic codes GhcDiagnosticCode "BadTelescope" = 97739 @@ -307,17 +412,15 @@ GhcDiagnosticCode "UnsatisfiableError" = 22250 GhcDiagnosticCode "ReportHoleError" = 88464 GhcDiagnosticCode "FixedRuntimeRepError" = 55287 - GhcDiagnosticCode "BlockedEquality" = 06200 GhcDiagnosticCode "ExpectingMoreArguments" = 81325 GhcDiagnosticCode "UnboundImplicitParams" = 91416 GhcDiagnosticCode "AmbiguityPreventsSolvingCt" = 78125 GhcDiagnosticCode "CannotResolveInstance" = 39999 GhcDiagnosticCode "OverlappingInstances" = 43085 GhcDiagnosticCode "UnsafeOverlap" = 36705 - + GhcDiagnosticCode "MultiplicityCoercionsNotSupported" = 59840 -- Type mismatch errors GhcDiagnosticCode "BasicMismatch" = 18872 - GhcDiagnosticCode "KindMismatch" = 89223 GhcDiagnosticCode "TypeEqMismatch" = 83865 GhcDiagnosticCode "CouldNotDeduce" = 05617 @@ -352,6 +455,9 @@ GhcDiagnosticCode "TcRnIllegalFieldPunning" = 44287 GhcDiagnosticCode "TcRnIllegalWildcardsInRecord" = 37132 GhcDiagnosticCode "TcRnIllegalWildcardInType" = 65507 + GhcDiagnosticCode "TcRnIllegalNamedWildcardInTypeArgument" = 93411 + GhcDiagnosticCode "TcRnIllegalImplicitTyVarInTypeArgument" = 80557 + GhcDiagnosticCode "TcRnIllegalPunnedVarOccInTypeArgument" = 09591 GhcDiagnosticCode "TcRnDuplicateFieldName" = 85524 GhcDiagnosticCode "TcRnIllegalViewPattern" = 22406 GhcDiagnosticCode "TcRnCharLiteralOutOfRange" = 17268 @@ -393,8 +499,6 @@ GhcDiagnosticCode "TcRnFamInstNotInjective" = 05175 GhcDiagnosticCode "TcRnBangOnUnliftedType" = 55666 GhcDiagnosticCode "TcRnLazyBangOnUnliftedType" = 71444 - GhcDiagnosticCode "TcRnMultipleDefaultDeclarations" = 99565 - GhcDiagnosticCode "TcRnBadDefaultType" = 88933 GhcDiagnosticCode "TcRnPatSynBundledWithNonDataCon" = 66775 GhcDiagnosticCode "TcRnPatSynBundledWithWrongType" = 66025 GhcDiagnosticCode "TcRnDupeModuleExport" = 51876 @@ -402,7 +506,9 @@ GhcDiagnosticCode "TcRnNullExportedModule" = 64649 GhcDiagnosticCode "TcRnMissingExportList" = 85401 GhcDiagnosticCode "TcRnExportHiddenComponents" = 94558 + GhcDiagnosticCode "TcRnExportHiddenDefault" = 74775 GhcDiagnosticCode "TcRnDuplicateExport" = 47854 + GhcDiagnosticCode "TcRnDuplicateNamedDefaultExport" = 31584 GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 GhcDiagnosticCode "TcRnConflictingExports" = 69158 GhcDiagnosticCode "TcRnDuplicateFieldExport" = 97219 @@ -419,7 +525,6 @@ GhcDiagnosticCode "TcRnPartialTypeSignatures" = 60661 GhcDiagnosticCode "TcRnLazyGADTPattern" = 87005 GhcDiagnosticCode "TcRnArrowProcGADTPattern" = 64525 - GhcDiagnosticCode "TcRnForallIdentifier" = 64088 GhcDiagnosticCode "TcRnTypeEqualityOutOfScope" = 12003 GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators" = 58520 GhcDiagnosticCode "TcRnIllegalTypeOperator" = 62547 @@ -441,7 +546,6 @@ GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 - GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet" = 49692 GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn" = 26133 GhcDiagnosticCode "TcRnForeignFunctionImportAsValue" = 76251 @@ -464,7 +568,7 @@ GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs" = 91938 GhcDiagnosticCode "TcRnCannotBindScopedTyVarInPatSig" = 46131 GhcDiagnosticCode "TcRnCannotBindTyVarsInPatBind" = 48361 - GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern" = 01629 + GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern" = Outdated 01629 GhcDiagnosticCode "TcRnMultipleInlinePragmas" = 96665 GhcDiagnosticCode "TcRnUnexpectedPragmas" = 88293 GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827 @@ -472,8 +576,7 @@ GhcDiagnosticCode "TcRnDifferentExportWarnings" = 92878 GhcDiagnosticCode "TcRnIncompleteExportWarnings" = 94721 GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649 - GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = 69710 - GhcDiagnosticCode "TcRnBindMultipleVariables" = 92957 + GhcDiagnosticCode "TcRnOrPatBindsVariables" = 81303 GhcDiagnosticCode "TcRnIllegalKind" = 64861 GhcDiagnosticCode "TcRnUnexpectedPatSigType" = 74097 GhcDiagnosticCode "TcRnIllegalKindSignature" = 91382 @@ -481,7 +584,6 @@ GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006 GhcDiagnosticCode "TcRnHsigFixityMismatch" = 93007 - GhcDiagnosticCode "TcRnHsigNoIface" = 93010 GhcDiagnosticCode "TcRnHsigMissingModuleExport" = 93011 GhcDiagnosticCode "TcRnBadGenericMethod" = 59794 GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511 @@ -490,7 +592,6 @@ GhcDiagnosticCode "TcRnBadMethodErr" = 46284 GhcDiagnosticCode "TcRnIllegalTypeData" = 15013 GhcDiagnosticCode "TcRnTypeDataForbids" = 67297 - GhcDiagnosticCode "TcRnInterfaceLookupError" = 52243 GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef" = 06201 GhcDiagnosticCode "TcRnMisplacedInstSig" = 06202 GhcDiagnosticCode "TcRnCapturedTermName" = 54201 @@ -505,11 +606,13 @@ GhcDiagnosticCode "TcRnMisplacedSigDecl" = 87866 GhcDiagnosticCode "TcRnUnexpectedDefaultSig" = 40700 GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346 - GhcDiagnosticCode "TcRnLoopySuperclassSolve" = 36038 + GhcDiagnosticCode "TcRnSpecSigShape" = 93944 + GhcDiagnosticCode "TcRnLoopySuperclassSolve" = Outdated 36038 GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl" = 95159 GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl" = 65669 GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig" = 45906 GhcDiagnosticCode "TcRnIllegalRuleLhs" = 63294 + GhcDiagnosticCode "TcRnRuleLhsEqualities" = 53522 GhcDiagnosticCode "TcRnDuplicateRoleAnnot" = 97170 GhcDiagnosticCode "TcRnDuplicateKindSig" = 43371 GhcDiagnosticCode "TcRnIllegalDerivStrategy" = 87139 @@ -519,8 +622,9 @@ GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412 GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333 GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254 - GhcDiagnosticCode "TcRnBadlyStaged" = 28914 - GhcDiagnosticCode "TcRnStageRestriction" = 18157 + GhcDiagnosticCode "TcRnBadlyLevelled" = 28914 + GhcDiagnosticCode "TcRnBadlyLevelledType" = 86357 + GhcDiagnosticCode "TcRnStageRestriction" = Outdated 18157 GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969 GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924 GhcDiagnosticCode "TcRnUninferrableTyVar" = 16220 @@ -531,6 +635,7 @@ GhcDiagnosticCode "TcRnTyFamDepsDisabled" = 43991 GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl" = 60012 GhcDiagnosticCode "TcRnPartialFieldSelector" = 82712 + GhcDiagnosticCode "TcRnHasFieldResolvedIncomplete" = 86894 GhcDiagnosticCode "TcRnSuperclassCycle" = 29210 GhcDiagnosticCode "TcRnDefaultSigMismatch" = 72771 GhcDiagnosticCode "TcRnTyFamResultDisabled" = 44012 @@ -553,7 +658,7 @@ GhcDiagnosticCode "TcRnNoExplicitImportList" = 16029 GhcDiagnosticCode "TcRnSafeImportsDisabled" = 26971 GhcDiagnosticCode "TcRnDeprecatedModule" = 15328 - GhcDiagnosticCode "TcRnCompatUnqualifiedImport" = 82347 + GhcDiagnosticCode "TcRnCompatUnqualifiedImport" = Outdated 82347 GhcDiagnosticCode "TcRnRedundantSourceImport" = 54478 GhcDiagnosticCode "TcRnDuplicateDecls" = 29916 GhcDiagnosticCode "TcRnPackageImportsDisabled" = 10032 @@ -571,6 +676,7 @@ GhcDiagnosticCode "TcRnBindingNameConflict" = 10498 GhcDiagnosticCode "NonCanonicalMonoid" = 50928 GhcDiagnosticCode "NonCanonicalMonad" = 22705 + GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235 GhcDiagnosticCode "TcRnImplicitImportOfPrelude" = 20540 GhcDiagnosticCode "TcRnMissingMain" = 67120 GhcDiagnosticCode "TcRnGhciUnliftedBind" = 17999 @@ -581,11 +687,23 @@ GhcDiagnosticCode "TcRnImplicitRhsQuantification" = 16382 GhcDiagnosticCode "TcRnBadTyConTelescope" = 87279 GhcDiagnosticCode "TcRnPatersonCondFailure" = 22979 - GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat" = 69797 + GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat" = Outdated 69797 + GhcDiagnosticCode "TcRnInvalidDefaultedTyVar" = 45625 + GhcDiagnosticCode "TcRnIllegalTermLevelUse" = 01928 + GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag" = 14995 + GhcDiagnosticCode "TcRnNamespacedFixitySigWithoutFlag" = 78534 + GhcDiagnosticCode "TcRnOutOfArityTyVar" = 84925 + GhcDiagnosticCode "TcRnIllformedTypePattern" = 88754 + GhcDiagnosticCode "TcRnIllegalTypePattern" = 70206 + GhcDiagnosticCode "TcRnIllformedTypeArgument" = 29092 + GhcDiagnosticCode "TcRnIllegalTypeExpr" = 35499 + GhcDiagnosticCode "TcRnUnexpectedTypeSyntaxInTerms" = 31244 + GhcDiagnosticCode "TcRnTypeApplicationsDisabled" = 23482 - -- TcRnTypeApplicationsDisabled - GhcDiagnosticCode "TypeApplication" = 23482 - GhcDiagnosticCode "TypeApplicationInPattern" = 17916 + -- TcRnIllegalInvisibleTypePattern + GhcDiagnosticCode "InvisPatWithoutFlag" = 78249 + GhcDiagnosticCode "InvisPatNoForall" = 14964 + GhcDiagnosticCode "InvisPatMisplaced" = 11983 -- PatSynInvalidRhsReason GhcDiagnosticCode "PatSynNotInvertible" = 69317 @@ -594,7 +712,7 @@ -- TcRnBadFieldAnnotation/BadFieldAnnotationReason GhcDiagnosticCode "LazyFieldsDisabled" = 81601 GhcDiagnosticCode "UnpackWithoutStrictness" = 10107 - GhcDiagnosticCode "BackpackUnpackAbstractType" = 40091 + GhcDiagnosticCode "UnusableUnpackPragma" = 40091 -- TcRnRoleValidationFailed/RoleInferenceFailedReason GhcDiagnosticCode "TyVarRoleMismatch" = 22221 @@ -618,6 +736,7 @@ -- Invisible binders GhcDiagnosticCode "TcRnIllegalInvisTyVarBndr" = 58589 + GhcDiagnosticCode "TcRnIllegalWildcardTyVarBndr" = 12211 GhcDiagnosticCode "TcRnInvalidInvisTyVarBndr" = 57916 GhcDiagnosticCode "TcRnInvisBndrWithoutSig" = 92337 @@ -638,6 +757,8 @@ GhcDiagnosticCode "BadImportNotExported" = 61689 GhcDiagnosticCode "BadImportAvailDataCon" = 35373 GhcDiagnosticCode "BadImportNotExportedSubordinates" = 10237 + GhcDiagnosticCode "BadImportNonTypeSubordinates" = 51433 + GhcDiagnosticCode "BadImportNonDataSubordinates" = 46557 GhcDiagnosticCode "BadImportAvailTyCon" = 56449 GhcDiagnosticCode "BadImportAvailVar" = 12112 @@ -668,6 +789,8 @@ GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 GhcDiagnosticCode "DefaultDataInstDecl" = 39639 GhcDiagnosticCode "FunBindLacksEquations" = 52078 + GhcDiagnosticCode "EmptyGuard" = 45149 + GhcDiagnosticCode "EmptyParStmt" = 95595 -- TcRnDodgyImports/DodgyImportsReason GhcDiagnosticCode "DodgyImportsEmptyParent" = 99623 @@ -690,7 +813,7 @@ -- IllegalInstanceHead GhcDiagnosticCode "InstHeadAbstractClass" = 51758 - GhcDiagnosticCode "InstHeadNonClass" = 53946 + GhcDiagnosticCode "InstHeadNonClassHead" = 53946 GhcDiagnosticCode "InstHeadTySynArgs" = 93557 GhcDiagnosticCode "InstHeadNonTyVarArgs" = 48406 GhcDiagnosticCode "InstHeadMultiParam" = 91901 @@ -802,6 +925,14 @@ GhcDiagnosticCode "LookupInstErrFlexiVar" = 10373 GhcDiagnosticCode "LookupInstErrNotFound" = 10374 + -- Diagnostic codes for default declarations and type defaulting + GhcDiagnosticCode "TcRnMultipleDefaultDeclarations" = 99565 + GhcDiagnosticCode "TcRnIllegalDefaultClass" = 26555 + GhcDiagnosticCode "TcRnIllegalNamedDefault" = 55756 + GhcDiagnosticCode "TcRnBadDefaultType" = 88933 + GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 + GhcDiagnosticCode "TcRnWarnClashingDefaultImports" = 77007 + -- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason GhcDiagnosticCode "EmptyStmtsGroupInParallelComp" = 41242 GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp" = 92693 @@ -837,7 +968,7 @@ GhcDiagnosticCode "NestedTHBrackets" = 59185 GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice" = 17599 GhcDiagnosticCode "BadImplicitSplice" = 25277 - GhcDiagnosticCode "QuotedNameWrongStage" = 57695 + GhcDiagnosticCode "QuotedNameWrongStage" = Outdated 57695 GhcDiagnosticCode "IllegalStaticFormInSplice" = 12219 -- Zonker messages @@ -850,7 +981,6 @@ GhcDiagnosticCode "FamDataConPE" = 64578 GhcDiagnosticCode "ConstrainedDataConPE" = 28374 GhcDiagnosticCode "RecDataConPE" = 56753 - GhcDiagnosticCode "NoDataKindsDC" = 71015 GhcDiagnosticCode "TermVariablePE" = 45510 GhcDiagnosticCode "TypeVariablePE" = 47557 @@ -860,21 +990,29 @@ -- NB: never remove a return value from this type family! -- We need to ensure uniquess of diagnostic codes across GHC versions, -- and this includes outdated diagnostic codes for errors that GHC - -- no longer reports. These are collected below. + -- no longer reports. These are mostly collected below, but for ease + -- of rebasing it is often better to simply declare a constructor outdated + -- without moving it down here. - GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = 12222 - GhcDiagnosticCode "TcRnNoClassInstHead" = 56538 - -- The above two are subsumed by InstHeadNonClass [GHC-53946] + GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = Outdated 12222 + GhcDiagnosticCode "TcRnNoClassInstHead" = Outdated 56538 + -- The above two are subsumed by InstHeadNonClassHead [GHC-53946] - GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027 - GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639 - GhcDiagnosticCode "TcRnMixedSelectors" = 40887 - GhcDiagnosticCode "TcRnBadBootFamInstDecl" = 06203 - GhcDiagnosticCode "TcRnBindInBootFile" = 11247 - GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = 39180 - GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = 45054 - GhcDiagnosticCode "TcRnUnpromotableThing" = 88634 - GhcDiagnosticCode "UntouchableVariable" = 34699 + GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = Outdated 40027 + GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = Outdated 69639 + GhcDiagnosticCode "TcRnMixedSelectors" = Outdated 40887 + GhcDiagnosticCode "TcRnBadBootFamInstDecl" = Outdated 06203 + GhcDiagnosticCode "TcRnBindInBootFile" = Outdated 11247 + GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = Outdated 39180 + GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = Outdated 45054 + GhcDiagnosticCode "TcRnUnpromotableThing" = Outdated 88634 + GhcDiagnosticCode "UntouchableVariable" = Outdated 34699 + GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = Outdated 69710 + GhcDiagnosticCode "TcRnBindMultipleVariables" = Outdated 92957 + GhcDiagnosticCode "TcRnHsigNoIface" = Outdated 93010 + GhcDiagnosticCode "TcRnInterfaceLookupError" = Outdated 52243 + GhcDiagnosticCode "TcRnForallIdentifier" = Outdated 64088 + GhcDiagnosticCode "TypeApplicationInPattern" = Outdated 17916 {- ********************************************************************* * * @@ -901,12 +1039,12 @@ ConRecursInto "GhcPsMessage" = 'Just PsMessage ConRecursInto "GhcTcRnMessage" = 'Just TcRnMessage ConRecursInto "GhcDsMessage" = 'Just DsMessage - ConRecursInto "GhcUnknownMessage" = 'Just (UnknownDiagnostic GhcMessageOpts) + ConRecursInto "GhcUnknownMessage" = 'Just (UnknownDiagnosticFor GhcMessage) ---------------------------------- -- Constructors of DriverMessage - ConRecursInto "DriverUnknownMessage" = 'Just (UnknownDiagnostic DriverMessageOpts) + ConRecursInto "DriverUnknownMessage" = 'Just (UnknownDiagnosticFor DriverMessage) ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage ConRecursInto "DriverInterfaceError" = 'Just IfaceMessage @@ -921,13 +1059,18 @@ ---------------------------------- -- Constructors of PsMessage - ConRecursInto "PsUnknownMessage" = 'Just (UnknownDiagnostic NoDiagnosticOpts) + ConRecursInto "PsUnknownMessage" = 'Just (UnknownDiagnosticFor PsMessage) ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUselessSpecialisePragma" = 'Just UselessSpecialisePragmaReason + + ---------------------------------- -- Constructors of TcRnMessage - ConRecursInto "TcRnUnknownMessage" = 'Just (UnknownDiagnostic TcRnMessageOpts) + ConRecursInto "TcRnUnknownMessage" = 'Just (UnknownDiagnosticFor TcRnMessage) -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage ConRecursInto "TcRnMessageWithInfo" = 'Just TcRnMessageDetailed @@ -952,7 +1095,7 @@ ConRecursInto "TcRnUnusedImport" = 'Just UnusedImportReason ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition ConRecursInto "TcRnIllegalInstance" = 'Just IllegalInstanceReason - ConRecursInto "TcRnTypeApplicationsDisabled" = 'Just TypeApplication + ConRecursInto "TcRnIllegalInvisibleTypePattern" = 'Just BadInvisPatReason -- Illegal instance reasons ConRecursInto "IllegalClassInstance" = 'Just IllegalClassInstanceReason @@ -1022,7 +1165,7 @@ ---------------------------------- -- Constructors of DsMessage - ConRecursInto "DsUnknownMessage" = 'Just (UnknownDiagnostic NoDiagnosticOpts) + ConRecursInto "DsUnknownMessage" = 'Just (UnknownDiagnosticFor DsMessage) ---------------------------------- -- Constructors of ImportLookupBad @@ -1043,7 +1186,7 @@ {- Note [Diagnostic codes using generics] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Diagnostic codes are specified at the type-level using the injective +Diagnostic codes for GHC are specified at the type-level using the injective type family 'GhcDiagnosticCode'. This ensures uniqueness of diagnostic codes, giving quick feedback (in the form of a type error). @@ -1080,7 +1223,12 @@ first, and decide whether to recur into it using the HasTypeQ type family. - The two different behaviours are controlled by two main instances (*) and (**). - - (*) recurs into a subtype, when we have a type family equation such as: + - (*) directly uses the constructor name, by using the 'DiagnosticCodeFor' + type family. The 'KnownConstructor' context (ERR2) on the instance provides + a custom error message in case of a missing diagnostic code, which points + GHC contributors to the documentation explaining how to add diagnostic codes + for their diagnostics. + - (**) recurses into a subtype, when we have a type family equation such as: ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason @@ -1088,59 +1236,87 @@ type 'DeriveInstanceErrReason'. The overlapping instance (ERR1) provides an error message in case a constructor does not have the type specified by the 'ConRecursInto' type family. - - (**) directly uses the constructor name, by using the 'GhcDiagnosticCode' - type family. The 'KnownConstructor' context (ERR2) on the instance provides - a custom error message in case of a missing diagnostic code, which points - GHC contributors to the documentation explaining how to add diagnostic codes - for their diagnostics. -} -- | Use the generic representation of a type to retrieve the --- diagnostic code, using the 'GhcDiagnosticCode' type family. +-- diagnostic code, using 'DiagnosticCodeFor namespace' type family. -- -- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes. -type GDiagnosticCode :: (Type -> Type) -> Constraint -class GDiagnosticCode f where +type GDiagnosticCode :: Type -> (Type -> Type) -> Constraint +class GDiagnosticCode namespace f where gdiagnosticCode :: f a -> Maybe DiagnosticCode +-- | Use the generic representation of a type to retrieve the collection +-- of all diagnostic codes it can give rise to. +type GDiagnosticCodes :: Type -> [Type] -> (Type -> Type) -> Constraint +class GDiagnosticCodes namespace seen f where + gdiagnosticCodes :: Map DiagnosticCode String -type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint -class ConstructorCode con f recur where +type ConstructorCode :: Type -> Symbol -> (Type -> Type) -> Maybe Type -> Constraint +class ConstructorCode namespace con f recur where gconstructorCode :: f a -> Maybe DiagnosticCode -instance KnownConstructor con => ConstructorCode con f 'Nothing where - gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy# +type ConstructorCodes :: Type -> Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint +class ConstructorCodes namespace con f seen recur where + gconstructorCodes :: Map DiagnosticCode String -- If we recur into the 'UnknownDiagnostic' existential datatype, -- unwrap the existential and obtain the error code. instance {-# OVERLAPPING #-} - ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts) - , HasType (UnknownDiagnostic opts) con f ) - => ConstructorCode con f ('Just (UnknownDiagnostic opts)) where - gconstructorCode diag = case getType @(UnknownDiagnostic opts) @con @f diag of - UnknownDiagnostic _ diag -> diagnosticCode diag + ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint) + , HasType namespace (UnknownDiagnostic opts hint) con f ) + => ConstructorCode namespace con f ('Just (UnknownDiagnostic opts hint)) where + gconstructorCode diag = case getType @namespace @(UnknownDiagnostic opts hint) @con @f diag of + UnknownDiagnostic _ _ diag -> diagnosticCode diag +instance {-# OVERLAPPING #-} + ( ConRecursIntoFor namespace con ~ 'Just (UnknownDiagnostic opts hint) ) + => ConstructorCodes namespace con f seen ('Just (UnknownDiagnostic opts hint)) where + gconstructorCodes = Map.empty --- (*) Recursive instance: Recur into the given type. -instance ( ConRecursInto con ~ 'Just ty, HasType ty con f - , Generic ty, GDiagnosticCode (Rep ty) ) - => ConstructorCode con f ('Just ty) where - gconstructorCode diag = constructorCode (getType @ty @con @f diag) +-- | (*) Base instance: use the diagnostic code for this constructor in this namespace. +instance (KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con) + => ConstructorCode namespace con f 'Nothing where + gconstructorCode _ = Just $ DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy# +instance ( KnownNameSpace namespace, KnownConstructor namespace con, KnownSymbol con) => ConstructorCodes namespace con f seen 'Nothing where + gconstructorCodes = + Map.singleton + (DiagnosticCode (symbolVal' @(NameSpaceTag namespace) proxy#) $ natVal' @(DiagnosticCodeFor namespace con) proxy#) + (symbolVal' @con proxy#) --- (**) Constructor instance: handle constructors directly. --- --- Obtain the code from the 'GhcDiagnosticCode' --- type family, applied to the name of the constructor. -instance (ConstructorCode con f recur, recur ~ ConRecursInto con) - => GDiagnosticCode (M1 i ('MetaCons con x y) f) where - gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x +-- | (**) Recursive instance: recur into the given type. +instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f + , Generic ty, GDiagnosticCode namespace (Rep ty) ) + => ConstructorCode namespace con f ('Just ty) where + gconstructorCode diag = gdiagnosticCode @namespace (from $ getType @namespace @ty @con @f diag) +instance ( ConRecursIntoFor namespace con ~ 'Just ty, HasType namespace ty con f + , Generic ty, GDiagnosticCodes namespace (Insert ty seen) (Rep ty) + , Seen seen ty ) + => ConstructorCodes namespace con f seen ('Just ty) where + gconstructorCodes = + -- See Note [diagnosticCodes: don't recur into already-seen types] + if wasSeen @seen @ty + then Map.empty + else gdiagnosticCodes @namespace @(Insert ty seen) @(Rep ty) +instance (ConstructorCode namespace con f recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con) + => GDiagnosticCode namespace (M1 i ('MetaCons con x y) f) where + gdiagnosticCode (M1 x) = gconstructorCode @namespace @con @f @recur x +instance (ConstructorCodes namespace con f seen recur, recur ~ ConRecursIntoFor namespace con, KnownSymbol con) + => GDiagnosticCodes namespace seen (M1 i ('MetaCons con x y) f) where + gdiagnosticCodes = gconstructorCodes @namespace @con @f @seen @recur + -- Handle sum types (the diagnostic types are sums of constructors). -instance (GDiagnosticCode f, GDiagnosticCode g) => GDiagnosticCode (f :+: g) where - gdiagnosticCode (L1 x) = gdiagnosticCode @f x - gdiagnosticCode (R1 y) = gdiagnosticCode @g y +instance (GDiagnosticCode namespace f, GDiagnosticCode namespace g) => GDiagnosticCode namespace (f :+: g) where + gdiagnosticCode (L1 x) = gdiagnosticCode @namespace @f x + gdiagnosticCode (R1 y) = gdiagnosticCode @namespace @g y +instance (GDiagnosticCodes namespace seen f, GDiagnosticCodes namespace seen g) => GDiagnosticCodes namespace seen (f :+: g) where + gdiagnosticCodes = Map.union (gdiagnosticCodes @namespace @seen @f) (gdiagnosticCodes @namespace @seen @g) -- Discard metadata we don't need. -instance GDiagnosticCode f - => GDiagnosticCode (M1 i ('MetaData nm mod pkg nt) f) where - gdiagnosticCode (M1 x) = gdiagnosticCode @f x +instance GDiagnosticCode namespace f + => GDiagnosticCode namespace (M1 i ('MetaData nm mod pkg nt) f) where + gdiagnosticCode (M1 x) = gdiagnosticCode @namespace @f x +instance GDiagnosticCodes namespace seen f + => GDiagnosticCodes namespace seen (M1 i ('MetaData nm mod pkg nt) f) where + gdiagnosticCodes = gdiagnosticCodes @namespace @seen @f -- | Decide whether to pick the left or right branch -- when deciding how to recurse into a product. @@ -1167,31 +1343,75 @@ Alt ('Just a) _ = 'Just a Alt _ b = b -type HasType :: Type -> Symbol -> (Type -> Type) -> Constraint -class HasType ty orig f where +type HasType :: Type -> Type -> Symbol -> (Type -> Type) -> Constraint +class HasType namespace ty orig f where getType :: f a -> ty -instance HasType ty orig (M1 i s (K1 x ty)) where +instance HasType namespace ty orig (M1 i s (K1 x ty)) where getType (M1 (K1 x)) = x -instance HasTypeProd ty (HasTypeQ ty f) orig f g => HasType ty orig (f :*: g) where - getType = getTypeProd @ty @(HasTypeQ ty f) @orig +instance HasTypeProd namespace ty (HasTypeQ ty f) orig f g => HasType namespace ty orig (f :*: g) where + getType = getTypeProd @namespace @ty @(HasTypeQ ty f) @orig -- The lr parameter tells us whether to pick the left or right -- branch in a product, and is computed using 'HasTypeQ'. -- -- If it's @Just l@, then we have found the type in the left branch, -- so use that. Otherwise, look in the right branch. -class HasTypeProd ty lr orig f g where +class HasTypeProd namespace ty lr orig f g where getTypeProd :: (f :*: g) a -> ty -- Pick the left branch. -instance HasType ty orig f => HasTypeProd ty ('Just l) orig f g where - getTypeProd (x :*: _) = getType @ty @orig @f x +instance HasType namespace ty orig f => HasTypeProd namespace ty ('Just l) orig f g where + getTypeProd (x :*: _) = getType @namespace @ty @orig @f x -- Pick the right branch. -instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where - getTypeProd (_ :*: y) = getType @ty @orig @g y +instance HasType namespace ty orig g => HasTypeProd namespace ty 'Nothing orig f g where + getTypeProd (_ :*: y) = getType @namespace @ty @orig @g y +{- Note [diagnosticCodes: don't recur into already-seen types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When traversing through the Generic representation of a datatype to compute all +of the corresponding error codes, we need to keep track of types we have already +seen in order to avoid a runtime loop. + +For example, TcRnMessage is defined recursively in terms of itself: + + data TcRnMessage where + ... + TcRnMessageWithInfo :: !UnitState + -> !TcRnMessageDetailed -- contains a TcRnMessage + -> TcRnMessage + +If we naively computed the collection of error codes, we would get a computation +of the form + + diagnosticCodes @TcRnMessage = ... `Map.union` constructorCodes "TcRnMessageWithInfo" + constructorCodes "TcRnMessageWithInfo" = diagnosticCodes @TcRnMessage + +This would cause an infinite loop. We thus keep track of a list of types we +have already encountered, and when we recur into a type we have already +encountered, we simply skip taking that union (see (**)). + +Note that 'constructorCodes' starts by marking the initial type itself as "seen", +which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'. +-} + +type Seen :: [Type] -> Type -> Constraint +class Seen seen ty where + wasSeen :: Bool +instance Seen '[] ty where + wasSeen = False +instance {-# OVERLAPPING #-} Seen (ty ': tys) ty where + wasSeen = True +instance Seen tys ty => Seen (ty' ': tys) ty where + wasSeen = wasSeen @tys @ty + +type Insert :: Type -> [Type] -> [Type] +type family Insert ty tys where + Insert ty '[] = '[ty] + Insert ty (ty ': tys) = ty ': tys + Insert ty (ty' ': tys) = ty' ': Insert ty tys + {- ********************************************************************* * * Custom type errors for diagnostic codes @@ -1205,27 +1425,42 @@ ':$$: 'Text "does not have any argument of type '" ':<>: 'ShowType ty ':<>: 'Text "'." ':$$: 'Text "" ':$$: 'Text "This is likely due to an incorrect type family equation:" - ':$$: 'Text " ConRecursInto \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty ) - => HasType ty orig f where + ':$$: 'Text " ConRecursIntoFor " ':<>: 'ShowType namespace ':<>: Text " \"" ':<>: 'Text orig ':<>: 'Text "\" = " ':<>: 'ShowType ty ) + => HasType namespace ty orig f where getType = panic "getType: unreachable" -- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations. -type KnownConstructor :: Symbol -> Constraint -type family KnownConstructor con where - KnownConstructor con = +type KnownConstructor :: Type -> Symbol -> Constraint +type family KnownConstructor namespace con where + KnownConstructor namespace con = KnownNatOrErr ( TypeError - ( 'Text "Missing diagnostic code for constructor " + ( 'Text "Missing " ':<>: 'ShowType namespace ':<>: Text " diagnostic code for constructor " ':<>: 'Text "'" ':<>: 'Text con ':<>: 'Text "'." ':$$: 'Text "" ':$$: 'Text "Note [Diagnostic codes] in GHC.Types.Error.Codes" ':$$: 'Text "contains instructions for adding a new diagnostic code." ) ) - (GhcDiagnosticCode con) + (DiagnosticCodeFor namespace con) type KnownNatOrErr :: Constraint -> Nat -> Constraint type KnownNatOrErr err n = (Assert err n, KnownNat n) + +-- (ERR3) Improve error messages for invalid namespaces. +type KnownNameSpace :: Type -> Constraint +type family KnownNameSpace namespace where + KnownNameSpace namespace = + ValidNameSpaceOrErr + ( TypeError + ( 'Text "Please provide a 'DiagnosticCodeNameSpace' instance for " ':<>: 'ShowType namespace ':<>: Text "," + ':$$: 'Text "including an associated type family equation for 'NameSpaceTag'." + ) + ) + (NameSpaceTag namespace) + +type ValidNameSpaceOrErr :: Constraint -> Symbol -> Constraint +type ValidNameSpaceOrErr err s = (Assert err s, KnownSymbol s) -- Detecting a stuck type family using a data family. -- See https://blog.csongor.co.uk/report-stuck-families/. diff --git a/GHC/Types/FieldLabel.hs b/GHC/Types/FieldLabel.hs --- a/GHC/Types/FieldLabel.hs +++ b/GHC/Types/FieldLabel.hs @@ -99,7 +99,7 @@ data DuplicateRecordFields = DuplicateRecordFields -- ^ Fields may be duplicated in a single module | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default) - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) instance Binary DuplicateRecordFields where put_ bh f = put_ bh (f == DuplicateRecordFields) @@ -118,7 +118,7 @@ data FieldSelectors = FieldSelectors -- ^ Selector functions are available (the default) | NoFieldSelectors -- ^ Selector functions are not available - deriving (Show, Eq, Typeable, Data) + deriving (Show, Eq, Data) instance Binary FieldSelectors where put_ bh f = put_ bh (f == FieldSelectors) @@ -140,9 +140,7 @@ put_ bh (FieldLabel aa ab ac) = do put_ bh aa put_ bh ab - case getUserData bh of - UserData{ ud_put_binding_name = put_binding_name } -> - put_binding_name bh ac + put_ bh ac get bh = do aa <- get bh ab <- get bh diff --git a/GHC/Types/Fixity.hs b/GHC/Types/Fixity.hs --- a/GHC/Types/Fixity.hs +++ b/GHC/Types/Fixity.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} -- For re-export of GHC.Hs.Basic instances -- | Fixity module GHC.Types.Fixity @@ -11,77 +12,28 @@ , negateFixity , funTyFixity , compareFixity + , module GHC.Hs.Basic ) where import GHC.Prelude -import GHC.Types.SourceText - -import GHC.Utils.Outputable -import GHC.Utils.Binary - -import Data.Data hiding (Fixity, Prefix, Infix) - -data Fixity = Fixity SourceText Int FixityDirection - -- Note [Pragma source text] in "GHC.Types.SourceText" - deriving Data - -instance Outputable Fixity where - ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 - -instance Binary Fixity where - put_ bh (Fixity src aa ab) = do - put_ bh src - put_ bh aa - put_ bh ab - get bh = do - src <- get bh - aa <- get bh - ab <- get bh - return (Fixity src aa ab) +import Language.Haskell.Syntax.Basic (LexicalFixity(..), FixityDirection(..), Fixity(..) ) +import GHC.Hs.Basic () -- For instances only ------------------------ -data FixityDirection - = InfixL - | InfixR - | InfixN - deriving (Eq, Data) -instance Outputable FixityDirection where - ppr InfixL = text "infixl" - ppr InfixR = text "infixr" - ppr InfixN = text "infix" - -instance Binary FixityDirection where - put_ bh InfixL = - putByte bh 0 - put_ bh InfixR = - putByte bh 1 - put_ bh InfixN = - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> return InfixL - 1 -> return InfixR - _ -> return InfixN - ------------------------- maxPrecedence, minPrecedence :: Int maxPrecedence = 9 minPrecedence = 0 defaultFixity :: Fixity -defaultFixity = Fixity NoSourceText maxPrecedence InfixL +defaultFixity = Fixity maxPrecedence InfixL negateFixity, funTyFixity :: Fixity -- Wired-in fixities -negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 +negateFixity = Fixity 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity (-1) InfixR -- Fixity of '->', see #15235 {- Consider @@ -96,7 +48,7 @@ compareFixity :: Fixity -> Fixity -> (Bool, -- Error please Bool) -- Associate to the right: a op1 (b op2 c) -compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) +compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) = case prec1 `compare` prec2 of GT -> left LT -> right @@ -108,12 +60,3 @@ right = (False, True) left = (False, False) error_please = (True, False) - --- |Captures the fixity of declarations as they are parsed. This is not --- necessarily the same as the fixity declaration, as the normal fixity may be --- overridden using parens or backticks. -data LexicalFixity = Prefix | Infix deriving (Data,Eq) - -instance Outputable LexicalFixity where - ppr Prefix = text "Prefix" - ppr Infix = text "Infix" diff --git a/GHC/Types/Fixity/Env.hs b/GHC/Types/Fixity/Env.hs --- a/GHC/Types/Fixity/Env.hs +++ b/GHC/Types/Fixity/Env.hs @@ -43,4 +43,3 @@ emptyIfaceFixCache :: OccName -> Maybe Fixity emptyIfaceFixCache _ = Nothing - diff --git a/GHC/Types/ForeignCall.hs b/GHC/Types/ForeignCall.hs --- a/GHC/Types/ForeignCall.hs +++ b/GHC/Types/ForeignCall.hs @@ -13,7 +13,7 @@ CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), CCallTarget(..), isDynamicTarget, - CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + CCallConv(..), defaultCCallConv, ccallConvAttribute, Header(..), CType(..), ) where @@ -30,6 +30,8 @@ import Data.Char import Data.Data +import Control.DeepSeq (NFData(..)) + {- ************************************************************************ * * @@ -146,10 +148,6 @@ ccall: Caller allocates parameters, *and* deallocates them. -stdcall: Caller allocates parameters, callee deallocates. - Function name has @N after it, where N is number of arg bytes - e.g. _Foo@8. This convention is x86 (win32) specific. - See: http://www.programmersheaven.com/2/Calling-conventions -} @@ -160,7 +158,7 @@ | StdCallConv | PrimCallConv | JavaScriptCallConv - deriving (Eq, Data, Enum) + deriving (Show, Eq, Data, Enum) instance Outputable CCallConv where ppr StdCallConv = text "stdcall" @@ -172,24 +170,17 @@ defaultCCallConv :: CCallConv defaultCCallConv = CCallConv -ccallConvToInt :: CCallConv -> Int -ccallConvToInt StdCallConv = 0 -ccallConvToInt CCallConv = 1 -ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" -ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" -ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" - {- Generate the gcc attribute corresponding to the given calling convention (used by PprAbsC): -} ccallConvAttribute :: CCallConv -> SDoc -ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" +ccallConvAttribute StdCallConv = panic "ccallConvAttribute StdCallConv" ccallConvAttribute CCallConv = empty ccallConvAttribute CApiConv = empty ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" -ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" +ccallConvAttribute JavaScriptCallConv = empty type CLabelString = FastString -- A C label, completely unencoded @@ -200,7 +191,7 @@ isCLabelString lbl = all ok (unpackFS lbl) where - ok c = isAlphaNum c || c == '_' || c == '.' + ok c = isAlphaNum c || c == '_' || c == '.' || c == '@' -- The '.' appears in e.g. "foo.so" in the -- module part of a ExtName. Maybe it should be separate @@ -233,7 +224,7 @@ = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\"" -- The filename for a C header file --- Note [Pragma source text] in "GHC.Types.SourceText" +-- See Note [Pragma source text] in "GHC.Types.SourceText" data Header = Header SourceText FastString deriving (Eq, Data) @@ -241,13 +232,7 @@ ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) -- | A C type, used in CAPI FFI calls --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{-\# CTYPE'@, --- 'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal', --- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@, - --- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" -data CType = CType SourceText -- Note [Pragma source text] in "GHC.Types.SourceText" +data CType = CType SourceText -- See Note [Pragma source text] in "GHC.Types.SourceText" (Maybe Header) -- header to include for this type (SourceText,FastString) -- the type itself deriving (Eq, Data) @@ -361,3 +346,31 @@ get bh = do s <- get bh h <- get bh return (Header s h) + +instance NFData ForeignCall where + rnf (CCall c) = rnf c + +instance NFData Safety where + rnf PlaySafe = () + rnf PlayInterruptible = () + rnf PlayRisky = () + +instance NFData CCallSpec where + rnf (CCallSpec t c s) = rnf t `seq` rnf c `seq` rnf s + +instance NFData CCallTarget where + rnf (StaticTarget s a b c) = rnf s `seq` rnf a `seq` rnf b `seq` rnf c + rnf DynamicTarget = () + +instance NFData CCallConv where + rnf CCallConv = () + rnf StdCallConv = () + rnf PrimCallConv = () + rnf CApiConv = () + rnf JavaScriptCallConv = () + +instance NFData CType where + rnf (CType s mh fs) = rnf s `seq` rnf mh `seq` rnf fs + +instance NFData Header where + rnf (Header s h) = rnf s `seq` rnf h diff --git a/GHC/Types/GREInfo.hs b/GHC/Types/GREInfo.hs --- a/GHC/Types/GREInfo.hs +++ b/GHC/Types/GREInfo.hs @@ -111,7 +111,7 @@ -- -- See Note [GREInfo] data GREInfo - -- | No particular information... e.g. a function + -- | A variable (an 'Id' or a 'TyVar') = Vanilla -- | An unbound GRE... could be anything | UnboundGRE @@ -126,12 +126,6 @@ deriving Data -instance NFData GREInfo where - rnf Vanilla = () - rnf UnboundGRE = () - rnf (IAmTyCon tc) = rnf tc - rnf (IAmConLike info) = rnf info - rnf (IAmRecField info) = rnf info plusGREInfo :: GREInfo -> GREInfo -> GREInfo plusGREInfo Vanilla Vanilla = Vanilla @@ -186,12 +180,24 @@ - We can fill in the dots if you say `T1 {..}` in construction or pattern matching See GHC.Rename.Pat.rnHsRecFields.rn_dotdot -* Whether the contructor is nullary. + This information is stored in ConFieldInfo. + +* Whether the constructor is nullary. We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`, in both construction and pattern matching. See GHC.Rename.Pat.rnHsRecFields.rn_dotdot and Note [Nullary constructors and empty record wildcards] + This information is stored in ConFieldInfo. + +* Whether the constructor is a data constructor or a pattern synonym, and, + if it is a data constructor, what are the other data constructors of the + parent type. This is used for computing irrefutability of pattern matches + when deciding how to desugar do blocks (whether to use a fail operation). + See GHC.Hs.Pat.isIrrefutableHsPat. + + This information is stored in ConLikeInfo. + Note [Nullary constructors and empty record wildcards] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A nullary constructor is one with no arguments. @@ -202,32 +208,84 @@ This is done as as per https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst -} +-- | Information known to the renamer about a data constructor or pattern synonym. +-- +-- See Note [Local constructor info in the renamer]. +data ConInfo + = ConInfo + { conLikeInfo :: !ConLikeInfo + , conFieldInfo :: !ConFieldInfo + } + deriving stock Eq + deriving Data + +-- | Whether a constructor is a data constructor or a pattern synonym. +-- +-- See Note [Local constructor info in the renamer]. +data ConLikeInfo + = ConIsData + { conLikeDataCons :: [Name] + -- ^ All the 'DataCon's of the parent 'TyCon', + -- including the 'ConLike' itself. + -- + -- Used in 'GHC.Hs.Pat.isIrrefutableHsPat'. + } + | ConIsPatSyn + deriving stock Eq + deriving Data + +instance NFData ConInfo where + rnf (ConInfo a b) = rnf a `seq` rnf b + +instance NFData ConLikeInfo where + rnf (ConIsData a) = rnf a + rnf ConIsPatSyn = () + + -- | Information about the record fields of a constructor. -- -- See Note [Local constructor info in the renamer] -data ConInfo +data ConFieldInfo = ConHasRecordFields (NonEmpty FieldLabel) | ConHasPositionalArgs | ConIsNullary deriving stock Eq deriving Data -instance NFData ConInfo where +instance NFData ConFieldInfo where rnf ConIsNullary = () rnf ConHasPositionalArgs = () rnf (ConHasRecordFields flds) = rnf flds -mkConInfo :: Arity -> [FieldLabel] -> ConInfo -mkConInfo 0 _ = ConIsNullary -mkConInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields +mkConInfo :: ConLikeInfo -> VisArity -> [FieldLabel] -> ConInfo +mkConInfo con_ty n flds = + ConInfo { conLikeInfo = con_ty + , conFieldInfo = mkConFieldInfo n flds } + +mkConFieldInfo :: Arity -> [FieldLabel] -> ConFieldInfo +mkConFieldInfo 0 _ = ConIsNullary +mkConFieldInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields $ NonEmpty.nonEmpty fields conInfoFields :: ConInfo -> [FieldLabel] -conInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields -conInfoFields ConHasPositionalArgs = [] -conInfoFields ConIsNullary = [] +conInfoFields = conFieldInfoFields . conFieldInfo +conFieldInfoFields :: ConFieldInfo -> [FieldLabel] +conFieldInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields +conFieldInfoFields ConHasPositionalArgs = [] +conFieldInfoFields ConIsNullary = [] + instance Outputable ConInfo where + ppr (ConInfo { conLikeInfo = con_ty, conFieldInfo = fld_info }) + = text "ConInfo" <+> braces + (text "con_ty:" <+> ppr con_ty <> comma + <+> text "fields:" <+> ppr fld_info) + +instance Outputable ConLikeInfo where + ppr (ConIsData cons) = text "ConIsData" <+> parens (ppr cons) + ppr ConIsPatSyn = text "ConIsPatSyn" + +instance Outputable ConFieldInfo where ppr ConIsNullary = text "ConIsNullary" ppr ConHasPositionalArgs = text "ConHasPositionalArgs" ppr (ConHasRecordFields fieldLabels) = @@ -242,8 +300,15 @@ | PatSynName { conLikeName_Name :: !Name } deriving (Eq, Data) +instance NamedThing ConLikeName where + getName = conLikeName_Name + instance Outputable ConLikeName where ppr = ppr . conLikeName_Name + +instance OutputableBndr ConLikeName where + pprInfixOcc con = pprInfixName (conLikeName_Name con) + pprPrefixOcc con = pprPrefixName (conLikeName_Name con) instance Uniquable ConLikeName where getUnique = getUnique . conLikeName_Name diff --git a/GHC/Types/Hint.hs b/GHC/Types/Hint.hs --- a/GHC/Types/Hint.hs +++ b/GHC/Types/Hint.hs @@ -5,11 +5,14 @@ , AvailableBindings(..) , InstantiationSuggestion(..) , LanguageExtensionHint(..) + , ImportItemSuggestion(..) , ImportSuggestion(..) , HowInScope(..) , SimilarName(..) , StarIsType(..) , UntickedPromotedThing(..) + , AssumedDerivingStrategy(..) + , SigLike(..) , pprUntickedConstructor, isBareSymbol , suggestExtension , suggestExtensionWithInfo @@ -22,7 +25,7 @@ ) where import Language.Haskell.Syntax.Expr (LHsExpr) -import Language.Haskell.Syntax (LPat, LIdP) +import Language.Haskell.Syntax (LPat, LIdP, LHsSigType, LHsSigWcType, Sig) import GHC.Prelude @@ -31,22 +34,23 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module (ModuleName, Module) import GHC.Unit.Module.Imported (ImportedModsVal) -import GHC.Hs.Extension (GhcTc, GhcRn) +import GHC.Hs.Extension (GhcTc, GhcRn, GhcPs) +import GHC.Core.Class (Class) import GHC.Core.Coercion import GHC.Core.FamInstEnv (FamFlavor) import GHC.Core.TyCon (TyCon) -import GHC.Core.Type (PredType, Type) +import GHC.Core.Type (Type) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec) import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Activation, RuleName) -import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Parser.Errors.Basic import GHC.Utils.Outputable import GHC.Data.FastString (fsLit, FastString) import Data.Typeable ( Typeable ) +import Data.Map.Strict (Map) -- | The bindings we have available in scope when -- suggesting an explicit type signature. @@ -55,6 +59,7 @@ | UnnamedBinding -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') + data LanguageExtensionHint = -- | Suggest to enable the input extension. This is the hint that -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving @@ -298,13 +303,13 @@ -} | SuggestQualifyStarOperator - {-| Suggests that a type signature should have form :: + {-| Suggests that for a type signature 'M.x :: ...' the qualifier should be omitted in order to be accepted by GHC. Triggered by: 'GHC.Parser.Errors.Types.PsErrInvalidTypeSignature' - Test case(s): parser/should_fail/T3811 + Test case(s): module/mod98 -} - | SuggestTypeSignatureForm + | SuggestTypeSignatureRemoveQualifier {-| Suggests to move an orphan instance (for a typeclass or a type or data family), or to newtype-wrap it. @@ -346,11 +351,6 @@ -} | SuggestFillInWildcardConstraint - {-| Suggests to use an identifier other than 'forall' - Triggered by: 'GHC.Tc.Errors.Types.TcRnForallIdentifier' - -} - | SuggestRenameForall - {-| Suggests to use the appropriate Template Haskell tick: a single tick for a term-level 'NameSpace', or a double tick for a type-level 'NameSpace'. @@ -384,8 +384,7 @@ Test cases: T495, T8485, T2713, T5533. -} | SuggestMoveToDeclarationSite - -- TODO: remove the SDoc argument. - SDoc -- ^ fixity declaration, role annotation, type signature, ... + SigLike -- ^ fixity declaration, role annotation, type signature, ... RdrName -- ^ the 'RdrName' for the declaration site {-| Suggest a similar name that the user might have meant, @@ -433,8 +432,6 @@ -} | SuggestRenameTypeVariable - | LoopySuperclassSolveHint PredType ClsInstOrQC - | SuggestExplicitBidiPatSyn Name (LPat GhcRn) [LIdP GhcRn] {-| Suggest enabling one of the SafeHaskell modes Safe, Unsafe or @@ -474,9 +471,63 @@ -} | SuggestBindTyVarOnLhs RdrName + {-| Suggest using an anonymous wildcard instead of a named wildcard -} + | SuggestAnonymousWildcard + + {-| Suggest explicitly quantifying a type variable instead of relying on implicit quantification -} + | SuggestExplicitQuantification RdrName + {-| Suggest binding explicitly; e.g data T @k (a :: F k) = .... -} | SuggestBindTyVarExplicitly Name + {-| Suggest a default declaration; e.g @default Cls (Ty1, Ty2)@ -} + | SuggestDefaultDeclaration Class [Type] + + {-| Suggest using explicit deriving strategies for a deriving clause. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnNoDerivingClauseStrategySpecified'. + + See comment of 'TcRnNoDerivingClauseStrategySpecified' for context. + -} + | SuggestExplicitDerivingClauseStrategies + (Map AssumedDerivingStrategy [LHsSigType GhcRn]) + -- ^ Those deriving clauses that we assumed a particular strategy for. + + {-| Suggest using an explicit deriving strategy for a standalone deriving instance. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnNoStandaloneDerivingStrategySpecified'. + + See comment of 'TcRnNoStandaloneDerivingStrategySpecified' for context. + -} + | SuggestExplicitStandaloneDerivingStrategy + AssumedDerivingStrategy -- ^ The deriving strategy we assumed + (LHsSigWcType GhcRn) -- ^ The instance signature (e.g 'Show a => Show (T a)') + + {-| Suggest add parens to pattern `e -> p :: t` -} + | SuggestParenthesizePatternRHS + + {-| Suggest splitting up a SPECIALISE pragmas with multiple type ascriptions + into several individual SPECIALISE pragmas. + -} + | SuggestSplittingIntoSeveralSpecialisePragmas + + {-| Suggest using the `data` keyword -} + | SuggestDataKeyword + +-- | The deriving strategy that was assumed when not explicitly listed in the +-- source. This is used solely by the missing-deriving-strategies warning. +-- There's no `Via` case because we never assume that. +data AssumedDerivingStrategy + = AssumedStockStrategy + | AssumedAnyclassStrategy + | AssumedNewtypeStrategy + deriving (Eq, Ord) + +instance Outputable AssumedDerivingStrategy where + ppr AssumedStockStrategy = text "stock" + ppr AssumedAnyclassStrategy = text "anyclass" + ppr AssumedNewtypeStrategy = text "newtype" + -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way -- to instantiate a particular signature, where the first argument is @@ -490,24 +541,32 @@ -- replacing as necessary.) data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module +data ImportItemSuggestion = + ImportItemRemoveType + | ImportItemRemoveData + | ImportItemRemovePattern + | ImportItemRemoveSubordinateType (NE.NonEmpty OccName) + | ImportItemRemoveSubordinateData (NE.NonEmpty OccName) + | ImportItemAddType + -- Why no 'ImportItemAddData'? Because the suggestion to add 'data' is + -- represented by the 'ImportDataCon' constructor of 'ImportSuggestion'. + -- | Suggest how to fix an import. data ImportSuggestion -- | Some module exports what we want, but we aren't explicitly importing it. = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal)) -- | Some module exports what we want, but we are explicitly hiding it. | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) - -- | The module exports what we want, but it isn't a type. - | CouldRemoveTypeKeyword ModuleName - -- | The module exports what we want, but it's a type and we have @ExplicitNamespaces@ on. - | CouldAddTypeKeyword ModuleName + -- | The module exports what we want, but the import item requires modification. + | CouldChangeImportItem ModuleName ImportItemSuggestion -- | Suggest importing a data constructor to bring it into scope | ImportDataCon -- | Where to suggest importing the 'DataCon' from. - -- - -- The 'Bool' tracks whether to suggest using an import of the form - -- @import (pattern Foo)@, depending on whether @-XPatternSynonyms@ - -- was enabled. - { ies_suggest_import_from :: Maybe (ModuleName, Bool) + { ies_suggest_import_from :: Maybe ModuleName + -- | Whether to suggest the use of the 'pattern' keyword. + , ies_suggest_pattern_keyword :: Bool + -- | Whether to suggest the use of the 'data' keyword. + , ies_suggest_data_keyword :: Bool -- | The 'OccName' of the parent of the data constructor. , ies_parent :: OccName } @@ -521,6 +580,15 @@ data SimilarName = SimilarName Name | SimilarRdrName RdrName (Maybe HowInScope) + +-- | Some kind of signature, such as a fixity signature, standalone +-- kind signature, COMPLETE pragma, role annotation, etc. +data SigLike + = SigLikeSig (Sig GhcPs) + | SigLikeStandaloneKindSig + | SigLikeFixitySig + | SigLikeDeprecation + | SigLikeRoleAnnotation -- | Something is promoted to the type-level without a promotion tick. data UntickedPromotedThing diff --git a/GHC/Types/Hint/Ppr.hs b/GHC/Types/Hint/Ppr.hs --- a/GHC/Types/Hint/Ppr.hs +++ b/GHC/Types/Hint/Ppr.hs @@ -1,9 +1,10 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- instance Outputable GhcHint +{-# OPTIONS_GHC -Wno-orphans #-} {- instance Outputable GhcHint -} module GHC.Types.Hint.Ppr ( - perhapsAsPat + perhapsAsPat, pprSigLike -- also, and more interesting: instance Outputable GhcHint ) where @@ -16,7 +17,6 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep ( mkVisFunTyMany ) import GHC.Hs.Expr () -- instance Outputable -import GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) @@ -25,9 +25,14 @@ import GHC.Unit.Types import GHC.Utils.Outputable -import Data.List (intersperse) +import GHC.Driver.Flags + import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified GHC.LanguageExtensions as LangExt +import GHC.Hs.Binds (hsSigDoc) + instance Outputable GhcHint where ppr = \case UnknownHint m @@ -35,15 +40,20 @@ SuggestExtension extHint -> case extHint of SuggestSingleExtension extraUserInfo ext -> - (text "Perhaps you intended to use" <+> ppr ext) $$ extraUserInfo + ("Perhaps you intended to use" <+> extension_with_implied ext) + $$ extraUserInfo SuggestAnyExtension extraUserInfo exts -> - let header = text "Enable any of the following extensions:" - in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo + (enable "any" <+> unquotedListWith "or" (map implied exts)) + $$ extraUserInfo SuggestExtensions extraUserInfo exts -> - let header = text "Enable all of the following extensions:" - in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo + (enable "all" <+> unquotedListWith "and" (map implied exts)) + $$ extraUserInfo SuggestExtensionInOrderTo extraUserInfo ext -> - (text "Use" <+> ppr ext) $$ extraUserInfo + ("Use" <+> extension_with_implied ext) + $$ extraUserInfo + where extension_with_implied ext = "the" <+> quotes (ppr ext) <+> "extension" <+> pprImpliedExtensions ext + implied ext = quotes (ppr ext) <+> pprImpliedExtensions ext + enable any_or_all = "Enable" <+> any_or_all <+> "of the following extensions" <> colon SuggestCorrectPragmaName suggestions -> text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) SuggestMissingDo @@ -128,8 +138,8 @@ -> text "To use (or export) this operator in" <+> text "modules with StarIsType," $$ text " including the definition module, you must qualify it." - SuggestTypeSignatureForm - -> text "A type signature should be of form :: " + SuggestTypeSignatureRemoveQualifier + -> text "Perhaps you meant to omit the qualifier" SuggestAddToHSigExportList _name mb_mod -> let header = text "Try adding it to the export list of" in case mb_mod of @@ -150,11 +160,6 @@ -> text "Add a standalone kind signature for" <+> quotes (ppr name) SuggestFillInWildcardConstraint -> text "Fill in the wildcard constraint yourself" - SuggestRenameForall - -> vcat [ text "Consider using another name, such as" - , quotes (text "forAll") <> comma <+> - quotes (text "for_all") <> comma <+> text "or" <+> - quotes (text "forall_") <> dot ] SuggestAppropriateTHTick ns -> text "Perhaps use a" <+> how_many <+> text "tick" where @@ -183,8 +188,8 @@ SuggestAddTick UntickedExplicitList -> text "Add a promotion tick, e.g." <+> text "'[x,y,z]" <> dot - SuggestMoveToDeclarationSite what rdr_name - -> text "Move the" <+> what <+> text "to the declaration site of" + SuggestMoveToDeclarationSite sig rdr_name + -> text "Move the" <+> pprSigLike sig <+> text "to the declaration site of" <+> quotes (ppr rdr_name) <> dot SuggestSimilarNames tried_rdr_name similar_names -> case similar_names of @@ -217,14 +222,6 @@ mod = nameModule name SuggestRenameTypeVariable -> text "Consider renaming the type variable." - LoopySuperclassSolveHint pty cls_or_qc - -> vcat [ text "Add the constraint" <+> quotes (ppr pty) <+> text "to the" <+> what <> comma - , text "even though it seems logically implied by other constraints in the context." ] - where - what :: SDoc - what = case cls_or_qc of - IsClsInst -> text "instance context" - IsQC {} -> text "context of the quantified constraint" SuggestExplicitBidiPatSyn name pat args -> hang (text "Instead use an explicitly bidirectional" <+> text "pattern synonym, e.g.") @@ -266,9 +263,36 @@ ppr_r = quotes $ ppr r SuggestBindTyVarOnLhs tv -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration" + SuggestAnonymousWildcard + -> text "Use an anonymous wildcard" <+> quotes (text "_") + SuggestExplicitQuantification tv + -> hsep [ text "Use an explicit", quotes (text "forall") + , text "to quantify over", quotes (ppr tv) ] SuggestBindTyVarExplicitly tv -> text "bind" <+> quotes (ppr tv) <+> text "explicitly with" <+> quotes (char '@' <> ppr tv) + SuggestDefaultDeclaration cls tys + -> hang (text "Consider declaring") + 2 (text "default" <+> ppr cls <+> parens (pprWithCommas ppr tys)) + SuggestExplicitDerivingClauseStrategies assumed_derivings -> + hang + (text "Use explicit deriving strategies:") + 2 + (vcat $ map pp_derivings (Map.toList assumed_derivings)) + where + pp_derivings (strat, preds) = + hsep [text "deriving", ppr strat, parens (pprWithCommas ppr preds)] + SuggestExplicitStandaloneDerivingStrategy strat deriv_sig -> + hang + (text "Use an explicit deriving strategy:") + 2 + (hsep [text "deriving", ppr strat, text "instance", ppr deriv_sig]) + SuggestParenthesizePatternRHS + -> text "Parenthesize the RHS of the view pattern" + SuggestSplittingIntoSeveralSpecialisePragmas + -> text "Split the SPECIALISE pragma into multiple pragmas, one for each type signature" + SuggestDataKeyword + -> text "Use the" <+> quotes (text "data") <+> "keyword instead." perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" @@ -318,43 +342,66 @@ [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv)) | (mod,imv) <- NE.toList mods ]) -pprImportSuggestion occ_name (CouldAddTypeKeyword mod) - = vcat [ text "Add the" <+> quotes (text "type") - <+> text "keyword to the import statement:" - , nest 2 $ text "import" - <+> ppr mod - <+> parens_sp (text "type" <+> pprPrefixOcc occ_name) - ] - where - parens_sp d = parens (space <> d <> space) -pprImportSuggestion occ_name (CouldRemoveTypeKeyword mod) - = vcat [ text "Remove the" <+> quotes (text "type") - <+> text "keyword from the import statement:" - , nest 2 $ text "import" - <+> ppr mod - <+> parens_sp (pprPrefixOcc occ_name) ] +pprImportSuggestion occ_name (CouldChangeImportItem mod kw) + = case kw of + ImportItemRemoveType -> remove "type" + ImportItemRemoveData -> remove "data" + ImportItemRemovePattern -> remove "pattern" + ImportItemRemoveSubordinateType nontype1 -> remove_subordinate "type" (NE.toList nontype1) + ImportItemRemoveSubordinateData nondata1 -> remove_subordinate "data" (NE.toList nondata1) + ImportItemAddType -> add "type" where parens_sp d = parens (space <> d <> space) -pprImportSuggestion dc_occ (ImportDataCon Nothing parent_occ) + remove kw = + vcat [ text "Remove the" <+> quotes (text kw) + <+> text "keyword from the import statement:" + , nest 2 $ text "import" <+> ppr mod <+> import_list ] + where + import_list = parens_sp (pprPrefixOcc occ_name) + add kw = + vcat [ text "Add the" <+> quotes (text kw) + <+> text "keyword to the import statement:" + , nest 2 $ text "import" <+> ppr mod <+> import_list ] + where + import_list = parens_sp (text kw <+> pprPrefixOcc occ_name) + remove_subordinate kw sub_occs = + vcat [ text "Remove the" <+> quotes (text kw) + <+> text "keyword" <> plural sub_occs + <+> text "from the subordinate import item" <> plural sub_occs <> colon + , nest 2 $ text "import" <+> ppr mod <+> import_list ] + where + parent_item + | isSymOcc occ_name = text "type" <+> pprPrefixOcc occ_name + | otherwise = pprPrefixOcc occ_name + import_list = parens_sp (parent_item <+> sub_import_list) + sub_import_list = parens_sp (hsep (punctuate comma (map pprPrefixOcc sub_occs))) +pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Nothing + , ies_parent = parent_occ} ) = text "Import the data constructor" <+> quotes (ppr dc_occ) <+> text "of" <+> quotes (ppr parent_occ) -pprImportSuggestion dc_occ (ImportDataCon (Just (mod, patsyns_enabled)) parent_occ) - = vcat $ [ text "Use" - , nest 2 $ text "import" - <+> ppr mod - <+> parens_sp (pprPrefixOcc parent_occ <> parens_sp (pprPrefixOcc dc_occ)) - , text "or" - , nest 2 $ text "import" - <+> ppr mod - <+> parens_sp (pprPrefixOcc parent_occ <> text "(..)") - ] ++ if patsyns_enabled - then [ text "or" - , nest 2 $ text "import" - <+> ppr mod - <+> parens_sp (text "pattern" <+> pprPrefixOcc dc_occ) - ] - else [] +pprImportSuggestion dc_occ (ImportDataCon { ies_suggest_import_from = Just mod + , ies_suggest_pattern_keyword = suggest_pattern + , ies_suggest_data_keyword = suggest_data + , ies_parent = parent_occ }) + = vcat $ basic_suggestion + ++ (if suggest_pattern then pattern_suggestion else []) + ++ (if suggest_data then data_suggestion else []) where + basic_suggestion = + [ text "Use" + , nest 2 $ import_stmt (pprPrefixOcc parent_occ <> parens_sp (pprPrefixOcc dc_occ)) + , text "or" + , nest 2 $ import_stmt (pprPrefixOcc parent_occ <> text "(..)") + ] + pattern_suggestion = + [ text "or" + , nest 2 $ import_stmt (text "pattern" <+> pprPrefixOcc dc_occ) + ] + data_suggestion = + [ text "or" + , nest 2 $ import_stmt (text "data" <+> pprPrefixOcc dc_occ) + ] + import_stmt sub = text "import" <+> ppr mod <+> parens_sp sub parens_sp d = parens (space <> d <> space) -- | Pretty-print a 'SimilarName'. @@ -378,6 +425,27 @@ | otherwise = empty where ns = rdrNameSpace rdr +pprImpliedExtensions :: LangExt.Extension -> SDoc +pprImpliedExtensions extension = case implied of + [] -> empty + xs -> parens $ "implied by" <+> unquotedListWith "and" xs + where implied = map (quotes . ppr) + . filter (\ext -> extensionDeprecation ext == ExtensionNotDeprecated) + $ [impl | (impl, On orig) <- impliedXFlags, orig == extension] + pprPrefixUnqual :: Name -> SDoc pprPrefixUnqual name = pprPrefixOcc (getOccName name) + +pprSigLike :: SigLike -> SDoc +pprSigLike = \case + SigLikeSig sig -> + hsSigDoc sig + SigLikeStandaloneKindSig -> + text "standalone kind signature" + SigLikeDeprecation -> + text "deprecation" + SigLikeFixitySig -> + text "fixity signature" + SigLikeRoleAnnotation -> + text "role annotation" diff --git a/GHC/Types/HpcInfo.hs b/GHC/Types/HpcInfo.hs --- a/GHC/Types/HpcInfo.hs +++ b/GHC/Types/HpcInfo.hs @@ -1,9 +1,7 @@ -- | Haskell Program Coverage (HPC) support module GHC.Types.HpcInfo ( HpcInfo (..) - , AnyHpcUsage , emptyHpcInfo - , isHpcUsed ) where @@ -16,19 +14,8 @@ , hpcInfoHash :: Int } | NoHpcInfo - { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? - } --- | This is used to signal if one of my imports used HPC instrumentation --- even if there is no module-local HPC usage -type AnyHpcUsage = Bool -emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo :: HpcInfo emptyHpcInfo = NoHpcInfo - --- | Find out if HPC is used by this module or any of the modules --- it depends upon -isHpcUsed :: HpcInfo -> AnyHpcUsage -isHpcUsed (HpcInfo {}) = True -isHpcUsed (NoHpcInfo { hpcUsed = used }) = used diff --git a/GHC/Types/IPE.hs b/GHC/Types/IPE.hs --- a/GHC/Types/IPE.hs +++ b/GHC/Types/IPE.hs @@ -13,7 +13,7 @@ import GHC.Types.SrcLoc import GHC.Core.DataCon -import GHC.Types.Unique.Map +import GHC.Types.Unique.DFM import GHC.Core.Type import Data.List.NonEmpty import GHC.Cmm.CLabel (CLabel) @@ -25,8 +25,8 @@ -- | A map from a 'Name' to the best approximate source position that -- name arose from. -type ClosureMap = UniqMap Name -- The binding - (Type, Maybe IpeSourceLocation) +type ClosureMap = UniqDFM Name -- The binding + (Name, (Type, Maybe IpeSourceLocation)) -- The best approximate source position. -- (rendered type, source position, source note -- label) @@ -38,7 +38,7 @@ -- the constructor was used at, if possible and a string which names -- the source location. This is the same information as is the payload -- for the 'GHC.Core.SourceNote' constructor. -type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe IpeSourceLocation)) +type DCMap = UniqDFM DataCon (DataCon, NonEmpty (Int, Maybe IpeSourceLocation)) type InfoTableToSourceLocationMap = Map.Map CLabel (Maybe IpeSourceLocation) @@ -49,4 +49,4 @@ } emptyInfoTableProvMap :: InfoTableProvMap -emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap Map.empty +emptyInfoTableProvMap = InfoTableProvMap emptyUDFM emptyUDFM Map.empty diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs --- a/GHC/Types/Id.hs +++ b/GHC/Types/Id.hs @@ -54,7 +54,7 @@ setIdExported, setIdNotExported, globaliseId, localiseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, - zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapLamIdInfo, floatifyIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, zapIdUsedOnceInfo, zapIdTailCallInfo, zapFragileIdInfo, zapIdDmdSig, zapStableUnfolding, transferPolyIdInfo, scaleIdBy, scaleVarBy, @@ -71,14 +71,15 @@ isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, - isDataConWrapId, isDataConWrapId_maybe, - isDataConId_maybe, + isDataConWrapId, isDataConWrapId_maybe, dataConWrapUnfolding_maybe, + isDataConId, isDataConId_maybe, idDataCon, isConLikeId, isWorkerLikeId, isDeadEndId, idIsFrom, hasNoBinding, -- ** Join variables - JoinId, isJoinId, isJoinId_maybe, idJoinArity, + JoinId, JoinPointHood, + isJoinId, idJoinPointHood, idJoinArity, asJoinId, asJoinId_maybe, zapJoinId, -- ** Inline pragma stuff @@ -128,10 +129,6 @@ import GHC.Prelude -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding - , isCompulsoryUnfolding, Unfolding( NoUnfolding ) - , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding ) - import GHC.Types.Id.Info import GHC.Types.Basic @@ -139,34 +136,41 @@ import GHC.Types.Var( Id, CoVar, JoinId, InId, InVar, OutId, OutVar, - idInfo, idDetails, setIdDetails, globaliseId, + idInfo, idDetails, setIdDetails, globaliseId, idMult, isId, isLocalId, isGlobalId, isExportedId, setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM) import qualified GHC.Types.Var as Var +import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun + , isStableUnfolding, isCompulsoryUnfolding, isEvaldUnfolding + , hasSomeUnfolding, noUnfolding, evaldUnfolding ) import GHC.Core.Type -import GHC.Types.RepType +import GHC.Core.Predicate( isCoVarType ) import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Core.Multiplicity + +import GHC.Types.RepType import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Name -import GHC.Unit.Module -import GHC.Core.Class -import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) import GHC.Types.ForeignCall -import GHC.Data.Maybe import GHC.Types.SrcLoc import GHC.Types.Unique -import GHC.Builtin.Uniques (mkBuiltinUnique) import GHC.Types.Unique.Supply + +import GHC.Stg.EnforceEpt.TagSig + +import GHC.Unit.Module +import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp) +import GHC.Builtin.Uniques (mkBuiltinUnique) + +import GHC.Data.Maybe import GHC.Data.FastString -import GHC.Core.Multiplicity import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Stg.InferTags.TagSig -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, @@ -205,9 +209,6 @@ idType :: Id -> Kind idType = Var.varType -idMult :: Id -> Mult -idMult = Var.varMult - idScaledType :: Id -> Scaled Type idScaledType id = Scaled (idMult id) (idType id) @@ -245,7 +246,7 @@ | assert (isId id) $ isLocalId id && isInternalName name = id | otherwise - = Var.mkLocalVar (idDetails id) (localiseName name) (Var.varMult id) (idType id) (idInfo id) + = Var.mkLocalVar (idDetails id) (localiseName name) (Var.idMult id) (idType id) (idInfo id) where name = idName id @@ -539,12 +540,26 @@ DataConWrapId con -> Just con _ -> Nothing +dataConWrapUnfolding_maybe :: Id -> Maybe CoreExpr +dataConWrapUnfolding_maybe id + | DataConWrapId {} <- idDetails id + , CoreUnfolding { uf_tmpl = unf } <- realIdUnfolding id + = Just unf + | otherwise + = Nothing + isDataConId_maybe :: Id -> Maybe DataCon isDataConId_maybe id = case Var.idDetails id of DataConWorkId con -> Just con DataConWrapId con -> Just con _ -> Nothing +isDataConId :: Id -> Bool +isDataConId id = case Var.idDetails id of + DataConWorkId {} -> True + DataConWrapId {} -> True + _ -> False + -- | An Id for which we might require all callers to pass strict arguments properly tagged + evaluated. -- -- See Note [CBV Function Ids] @@ -565,13 +580,12 @@ | otherwise = False -- | Doesn't return strictness marks -isJoinId_maybe :: Var -> Maybe JoinArity -isJoinId_maybe id - | isId id = assertPpr (isId id) (ppr id) $ - case Var.idDetails id of - JoinId arity _marks -> Just arity - _ -> Nothing - | otherwise = Nothing +idJoinPointHood :: Var -> JoinPointHood +idJoinPointHood id + | isId id = case Var.idDetails id of + JoinId arity _marks -> JoinPoint arity + _ -> NotJoinPoint + | otherwise = NotJoinPoint idDataCon :: Id -> DataCon -- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. @@ -595,7 +609,11 @@ -- PrimOpId _ lev_poly -> lev_poly -- TEMPORARILY commented out FCallId _ -> True - DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc + DataConWorkId dc -> isUnboxedTupleDataCon dc + || isUnboxedSumDataCon dc + || isUnaryClassDataCon dc + -- Unary class dictionary constructors are eliminated + -- See Note [Unary class magic] in GHC.Core.TyCon _ -> isCompulsoryUnfolding (realIdUnfolding id) -- Note: this function must be very careful not to force -- any of the fields that aren't the 'uf_src' field of @@ -644,7 +662,9 @@ -} idJoinArity :: JoinId -> JoinArity -idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) +idJoinArity id = case idJoinPointHood id of + JoinPoint ar -> ar + NotJoinPoint -> pprPanic "idJoinArity" (ppr id) asJoinId :: Id -> JoinArity -> JoinId asJoinId id arity = warnPprTrace (not (isLocalId id)) @@ -676,9 +696,9 @@ _ -> panic "zapJoinId: newIdDetails can only be used if Id was a join Id." -asJoinId_maybe :: Id -> Maybe JoinArity -> Id -asJoinId_maybe id (Just arity) = asJoinId id arity -asJoinId_maybe id Nothing = zapJoinId id +asJoinId_maybe :: Id -> JoinPointHood -> Id +asJoinId_maybe id (JoinPoint arity) = asJoinId id arity +asJoinId_maybe id NotJoinPoint = zapJoinId id {- ************************************************************************ @@ -962,12 +982,11 @@ updOneShotInfo :: Id -> OneShotInfo -> Id -- Combine the info in the Id with new info updOneShotInfo id one_shot - | do_upd = setIdOneShotInfo id one_shot - | otherwise = id - where - do_upd = case (idOneShotInfo id, one_shot) of - (NoOneShotInfo, _) -> True - (OneShotLam, _) -> False + | OneShotLam <- one_shot + , NoOneShotInfo <- idOneShotInfo id + = setIdOneShotInfo id OneShotLam + | otherwise + = id -- The OneShotLambda functions simply fiddle with the IdInfo flag -- But watch out: this may change the type of something else @@ -984,8 +1003,9 @@ zapFragileIdInfo :: Id -> Id zapFragileIdInfo = zapInfo zapFragileInfo -zapIdDemandInfo :: Id -> Id -zapIdDemandInfo = zapInfo zapDemandInfo +floatifyIdDemandInfo :: Id -> Id +-- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels +floatifyIdDemandInfo = zapInfo floatifyDemandInfo zapIdUsageInfo :: Id -> Id zapIdUsageInfo = zapInfo zapUsageInfo diff --git a/GHC/Types/Id.hs-boot b/GHC/Types/Id.hs-boot --- a/GHC/Types/Id.hs-boot +++ b/GHC/Types/Id.hs-boot @@ -1,6 +1,5 @@ module GHC.Types.Id where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name import {-# SOURCE #-} GHC.Types.Var diff --git a/GHC/Types/Id/Info.hs b/GHC/Types/Id/Info.hs --- a/GHC/Types/Id/Info.hs +++ b/GHC/Types/Id/Info.hs @@ -12,6 +12,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -20,7 +21,10 @@ -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, JoinArity, isJoinIdDetails_maybe, + RecSelParent(..), recSelParentName, recSelFirstConName, + recSelParentCons, idDetailsConcreteTvs, + RecSelInfo(..), conLikesRecSelInfo, -- * The IdInfo type IdInfo, -- Abstract @@ -33,7 +37,8 @@ -- ** Zapping various forms of Info zapLamInfo, zapFragileInfo, - zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + lazifyDemandInfo, floatifyDemandInfo, + zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, zapTailCallInfo, zapCallArityInfo, trimUnfolding, -- ** The ArityInfo type @@ -99,19 +104,21 @@ import GHC.Core.TyCon import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn +import GHC.Core.ConLike import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Stg.InferTags.TagSig +import GHC.Stg.EnforceEpt.TagSig import GHC.StgToCmm.Types (LambdaFormInfo) import Data.Data ( Data ) import Data.Word +import Data.List as List( partition ) -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, @@ -146,7 +153,10 @@ , sel_fieldLabel :: FieldLabel , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: -- data T = forall a. MkT { x :: a } - } -- See Note [Naughty record selectors] in GHC.Tc.TyCl + -- See Note [Naughty record selectors] in GHC.Tc.TyCl + , sel_cons :: RecSelInfo + -- Partiality info, cached here based on the RecSelParent. + } | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ @@ -163,11 +173,28 @@ -- and Note [exprOkForSpeculation and type classes] -- in GHC.Core.Utils - | PrimOpId PrimOp Bool -- ^ The 'Id' is for a primitive operator - -- True <=> is representation-polymorphic, - -- and hence has no binding - -- This lev-poly flag is used only in GHC.Types.Id.hasNoBinding + -- | A representation-polymorphic pseudo-op. + | RepPolyId + { id_concrete_tvs :: ConcreteTyVars } + -- ^ Which type variables of this representation-polymorphic 'Id + -- should be instantiated to concrete type variables? + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + -- | The 'Id' is for a primitive operator. + | PrimOpId + { id_primop :: PrimOp + , id_concrete_tvs :: ConcreteTyVars } + -- ^ Which type variables of this primop should be instantiated + -- to concrete type variables? + -- + -- Only ever non-empty when the PrimOp has representation-polymorphic + -- type variables. + -- + -- See Note [Representation-polymorphism checking built-ins] + -- in GHC.Tc.Utils.Concrete. + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. -- Type will be simple: no type families, newtypes, etc @@ -193,19 +220,43 @@ -- Worker like functions are create by W/W and SpecConstr and we can expect that they -- aren't used unapplied. -- See Note [CBV Function Ids] - -- See Note [Tag Inference] + -- See Note [EPT enforcement] -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current -- module. +data RecSelInfo + = RSI { rsi_def :: [ConLike] -- Record selector defined for these + , rsi_undef :: [ConLike] -- Record selector not defined for these + } + +idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars +idDetailsConcreteTvs = \ case + PrimOpId _ conc_tvs -> conc_tvs + RepPolyId conc_tvs -> conc_tvs + DataConWorkId dc -> dataConConcreteTyVars dc + DataConWrapId dc -> dataConConcreteTyVars dc + _ -> noConcreteTyVars + +-- | The ConLikes that have *all* the given fields +conLikesRecSelInfo :: [ConLike] -> [FieldLabelString] -> RecSelInfo +conLikesRecSelInfo con_likes lbls + = RSI { rsi_def = defs, rsi_undef = undefs } + where + !(defs,undefs) = List.partition has_flds con_likes + + has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) + + {- Note [CBV Function Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~ A WorkerLikeId essentially allows us to constrain the calling convention for the given Id. Each such Id carries with it a list of CbvMarks with each element representing a value argument. Arguments who have a matching `MarkedCbv` entry in the list need to be passed evaluated+*properly tagged*. CallByValueFunIds give us additional expressiveness which we use to improve -runtime. This is all part of the TagInference work. See also Note [Tag Inference]. +runtime. This is all part of the EPT enforcement work. See also Note [EPT enforcement]. They allows us to express the fact that an argument is not only evaluated to WHNF once we entered it's RHS but also that an lifted argument is already *properly tagged* once we jump @@ -225,7 +276,7 @@ * Any `WorkerLikeId` * Some `JoinId` bindings. -This works analogous to the Strict Field Invariant. See also Note [Strict Field Invariant]. +This works analogous to the EPT Invariant. See also Note [EPT enforcement]. To make this work what we do is: * During W/W and SpecConstr any worker/specialized binding we introduce @@ -303,6 +354,15 @@ recSelFirstConName (RecSelData tc) = dataConName $ head $ tyConDataCons tc recSelFirstConName (RecSelPatSyn ps) = patSynName ps +recSelParentCons :: RecSelParent -> [ConLike] +recSelParentCons (RecSelData tc) + | isAlgTyCon tc + = map RealDataCon $ visibleDataCons + $ algTyConRhs tc + | otherwise + = [] +recSelParentCons (RecSelPatSyn ps) = [PatSynCon ps] + instance Outputable RecSelParent where ppr p = case p of RecSelData tc @@ -339,6 +399,7 @@ pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" + pp (RepPolyId {}) = text "RepPolyId" pp (PrimOpId {}) = text "PrimOp" pp (FCallId _) = text "ForeignCall" pp (TickBoxOpId _) = text "TickBoxOp" @@ -810,11 +871,21 @@ is_safe_dmd dmd = not (isStrUsedDmd dmd) --- | Remove all demand info on the 'IdInfo' -zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info = Just (info {demandInfo = topDmd}) +-- | Lazify (remove the top-level demand, only) the demand in `IdInfo` +-- Keep nested demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +lazifyDemandInfo :: IdInfo -> Maybe IdInfo +lazifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = lazifyDmd dmd }) --- | Remove usage (but not strictness) info on the 'IdInfo' +-- | Floatify the demand in `IdInfo` +-- But keep /nested/ demands; see Note [Floatifying demand info when floating] +-- in GHC.Core.Opt.SetLevels +floatifyDemandInfo :: IdInfo -> Maybe IdInfo +floatifyDemandInfo info@(IdInfo { demandInfo = dmd }) + = Just (info {demandInfo = floatifyDmd dmd }) + +-- | Remove usage (but not strictness) info on the `IdInfo` zapUsageInfo :: IdInfo -> Maybe IdInfo zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) diff --git a/GHC/Types/Id/Make.hs b/GHC/Types/Id/Make.hs --- a/GHC/Types/Id/Make.hs +++ b/GHC/Types/Id/Make.hs @@ -12,16 +12,15 @@ - primitive operations -} - - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE DataKinds #-} module GHC.Types.Id.Make ( mkDictFunId, mkDictSelId, mkDictSelRhs, mkFCallId, - unwrapNewTypeBody, wrapFamInstBody, + wrapNewTypeBody, unwrapNewTypeBody, wrapFamInstBody, DataConBoxer(..), vanillaDataConBoxer, mkDataConRep, mkDataConWorkId, DataConBangOpts (..), BangOpts (..), @@ -38,6 +37,9 @@ noinlineId, noinlineIdName, noinlineConstraintId, noinlineConstraintIdName, coerceName, leftSectionName, rightSectionName, + pcRepPolyId, + + mkRepPolyIdConcreteTyVars, ) where import GHC.Prelude @@ -52,11 +54,12 @@ import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep import GHC.Core.FamInstEnv +import GHC.Core.Predicate( isUnaryClass ) import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType ) +import GHC.Core.Utils ( exprType, mkCast, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon @@ -65,9 +68,10 @@ import GHC.Types.Literal import GHC.Types.SourceText -import GHC.Types.RepType ( countFunRepArgs ) +import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) import GHC.Types.Name.Set import GHC.Types.Name +import GHC.Types.Name.Env import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Types.Id.Info @@ -75,14 +79,14 @@ import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike) +import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName) +import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Data.List.SetOps @@ -154,12 +158,15 @@ * May have IdInfo that differs from what would be imported from GHC.Magic.hi. For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic]. - The two remaining identifiers in GHC.Magic, runRW# and inline, are not listed - in magicIds: they have special behavior but they can be known-key and + The two remaining identifiers in GHC.Magic, runRW# and inline, are not + listed in magicIds: they have special behavior but they can be known-key and not wired-in. - runRW#: see Note [Simplification of runRW#] in Prep, runRW# code in - Simplifier, Note [Linting of runRW#]. - inline: see Note [inlineId magic] + Similarly for GHC.Internal.IO.seq# and GHC.Internal.Exts.considerAccessible. + runRW#: see Note [Simplification of runRW#] in Prep, + runRW# code in Simplifier, Note [Linting of runRW#]. + seq#: see Note [seq# magic] + inline: see Note [inlineId magic] + considerAccessible: see Note [considerAccessible] -} wiredInIds :: [Id] @@ -379,7 +386,7 @@ Note [Representation polymorphism invariants] in GHC.Core), and it's saturated, no representation-polymorphic code ends up in the code generator. The saturation condition is effectively checked in -GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs. +GHC.Tc.Gen.Head.rejectRepPolyNewtypes. However, if we make a *wrapper* for a newtype, we get into trouble. In that case, we generate a forbidden representation-polymorphic @@ -469,12 +476,12 @@ mkDictSelId :: Name -- Name of one of the *value* selectors -- (dictionary superclass or method) -> Class -> Id +-- Important: see Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance mkDictSelId name clas = mkGlobalId (ClassOpId clas terminating) name sel_ty info where tycon = classTyCon clas sel_names = map idName (classAllSelIds clas) - new_tycon = isNewTyCon tycon [data_con] = tyConDataCons tycon tyvars = dataConUserTyVarBinders data_con n_ty_args = length tyvars @@ -483,7 +490,7 @@ pred_ty = mkClassPred clas (mkTyVarTys (binderVars tyvars)) res_ty = scaledThing (getNth arg_tys val_index) - sel_ty = mkInvisForAllTys tyvars $ + sel_ty = mkForAllTys tyvars $ mkFunctionType ManyTy pred_ty res_ty -- See Note [Type classes and linear types] @@ -496,23 +503,9 @@ `setDmdSigInfo` strict_sig `setCprSigInfo` topCprSig - info | new_tycon - = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts - StableSystemSrc 1 - (mkDictSelRhs clas val_index) - -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance - -- for why alwaysInlinePragma - - | otherwise - = base_info `setRuleInfo` mkRuleInfo [rule] - `setInlinePragInfo` neverInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts - StableSystemSrc 1 - (mkDictSelRhs clas val_index) - -- Add a magic BuiltinRule, but no unfolding - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance + info = base_info `setRuleInfo` mkRuleInfo [rule] + -- No unfolding for a dictionary selector; the RULE does the work, + -- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance -- This is the built-in rule that goes -- op (dfT d1 d2) ---> opT d1 d2 @@ -525,11 +518,10 @@ -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting -- It's worth giving one, so that absence info etc is generated - -- even if the selector isn't inlined + -- even if the selector isn't inlined, which of course it isn't! strict_sig = mkClosedDmdSig [arg_dmd] topDiv - arg_dmd | new_tycon = evalDmd - | otherwise = C_1N :* mkProd Unboxed dict_field_dmds + arg_dmd = C_1N :* mkProd Unboxed dict_field_dmds where -- The evalDmd below is just a placeholder and will be replaced in -- GHC.Types.Demand.dmdTransformDictSel @@ -539,24 +531,29 @@ mkDictSelRhs :: Class -> Int -- 0-indexed selector among (superclasses ++ methods) -> CoreExpr +-- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance mkDictSelRhs clas val_index = mkLams tyvars (Lam dict_id rhs_body) where - tycon = classTyCon clas - new_tycon = isNewTyCon tycon - [data_con] = tyConDataCons tycon - tyvars = dataConUnivTyVars data_con - arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + tycon = classTyCon clas + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - the_arg_id = getNth arg_ids val_index - pred = mkClassPred clas (mkTyVarTys tyvars) - dict_id = mkTemplateLocal 1 pred - arg_ids = mkTemplateLocalsNum 2 (map scaledThing arg_tys) + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 (map scaledThing arg_tys) - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) - (Var dict_id) - | otherwise = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) - arg_ids (varToCoreExpr the_arg_id) + rhs_body | isUnaryClass clas -- Just having one sel_id isn't enough! + -- E.g. class (a ~# b) => a ~ b where {} + , let sel_ids = classAllSelIds clas + = assertPpr (val_index == 0) (ppr clas) $ + assertPpr (length sel_ids == 1) (ppr clas) $ + Var (head sel_ids) `mkTyApps` mkTyVarTys tyvars `App` Var dict_id + | otherwise + = mkSingleAltCase (Var dict_id) dict_id (DataAlt data_con) + arg_ids (varToCoreExpr the_arg_id) -- varToCoreExpr needed for equality superclass selectors -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } @@ -566,9 +563,11 @@ -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -dictSelRule val_index n_ty_args _ id_unf _ args +-- See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance +dictSelRule val_index n_ty_args _ in_scope_env _ args | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + , Just (_, floats, _, _, con_args) + <- exprIsConApp_maybe in_scope_env dict_arg = Just (wrapFloats floats $ getNth con_args val_index) | otherwise = Nothing @@ -583,16 +582,19 @@ mkDataConWorkId :: Name -> DataCon -> Id mkDataConWorkId wkr_name data_con - | isNewTyCon tycon - = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info - -- See Note [Newtype workers] + | isNewTyCon tycon -- See Note [Newtype workers] + = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_info | otherwise = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info where - tycon = dataConTyCon data_con -- The representation TyCon - wkr_ty = dataConRepType data_con + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + univ_tvs = dataConUnivTyVars data_con + ex_tcvs = dataConExTyCoVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + str_marks = dataConRepStrictness data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo @@ -600,12 +602,19 @@ `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 + `setDmdSigInfo` wkr_sig + -- Workers eval their strict fields + -- See Note [Strict fields in Core] `setLFInfo` wkr_lf_info - -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedDmdSig wkr_dmds topDiv + wkr_dmds = map mk_dmd str_marks + mk_dmd MarkedStrict = evalDmd + mk_dmd NotMarkedStrict = topDmd + -- See Note [LFInfo of DataCon workers and wrappers] wkr_lf_info | wkr_arity == 0 = LFCon data_con @@ -613,21 +622,17 @@ -- LFInfo stores post-unarisation arity ----------- Workers for newtypes -------------- - univ_tvs = dataConUnivTyVars data_con - ex_tcvs = dataConExTyCoVars data_con - arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys - nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo - `setArityInfo` 1 -- Arity 1 - `setInlinePragInfo` dataConWrapperInlinePragma - `setUnfoldingInfo` newtype_unf - -- See W1 in Note [LFInfo of DataCon workers and wrappers] - `setLFInfo` (panic "mkDataConWorkId: we shouldn't look at LFInfo for newtype worker ids") - id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) - res_ty_args = mkTyCoVarTys univ_tvs - newtype_unf = assertPpr (null ex_tcvs && isSingleton arg_tys) - (ppr data_con) + nt_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` dataConWrapperInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding newtype_rhs + `setLFInfo` (panic "mkDataConWorkId: no LFInfo for newtype worker ids") + -- See W1 in Note [LFInfo of DataCon workers and wrappers] + + id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) + res_ty_args = mkTyCoVarTys univ_tvs + newtype_rhs = assertPpr (null ex_tcvs && isSingleton arg_tys) (ppr data_con) $ -- Note [Newtype datacons] - mkCompulsoryUnfolding $ mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) @@ -650,18 +655,18 @@ (Remember: `LFCon` means "a saturated constructor application") (1) Data constructor workers and wrappers with arity > 0 are unambiguously -functions and should be given `LFReEntrant`, regardless of the runtime -relevance of the arguments. - - For example, `Just :: a -> Maybe a` is given `LFReEntrant`, - and `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too. + functions and should be given `LFReEntrant`, regardless of the runtime + relevance of the arguments. For example: + `Just :: a -> Maybe a` is given `LFReEntrant`, + `HNil :: (a ~# '[]) -> HList a` is given `LFReEntrant` too. (2) A datacon /worker/ with zero arity is trivially fully saturated -- it takes -no arguments whatsoever (not even zero-width args), so it is given `LFCon`. + no arguments whatsoever (not even zero-width args), so it is given `LFCon`. (3) Perhaps surprisingly, a datacon /wrapper/ can be an `LFCon`. See Wrinkle (W1) below. -A datacon /wrapper/ with zero arity must be a fully saturated application of -the worker to zero-width arguments only (which are dropped after unarisation), -and therefore is also given `LFCon`. + A datacon /wrapper/ with zero arity must be a fully saturated application of + the worker to zero-width arguments only (which are dropped after unarisation), + and therefore is also given `LFCon`. For example, consider the following data constructors: @@ -783,10 +788,10 @@ -> FamInstEnvs -> Name -> DataCon - -> UniqSM DataConRep + -> UniqSM (DataConRep, [HsImplBang], [StrictnessMark]) mkDataConRep dc_bang_opts fam_envs wrap_name data_con | not wrapper_reqd - = return NoDataConRep + = return (NoDataConRep, arg_ibangs, rep_strs) | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys @@ -843,24 +848,21 @@ wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs -- See Note [Compulsory newtype unfolding] | otherwise = mkDataConUnfolding wrap_rhs - wrap_rhs = mkLams wrap_tvs $ - mkLams wrap_args $ + wrap_rhs = mkCoreTyLams wrap_tvbs $ + mkCoreLams wrap_args $ wrapFamInstBody tycon res_ty_args $ wrap_body ; return (DCR { dcr_wrap_id = wrap_id , dcr_boxer = mk_boxer boxers - , dcr_arg_tys = rep_tys - , dcr_stricts = rep_strs - -- For newtypes, dcr_bangs is always [HsLazy]. - -- See Note [HsImplBangs for newtypes]. - , dcr_bangs = arg_ibangs }) } + , dcr_arg_tys = rep_tys } + , arg_ibangs, rep_strs) } where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) = dataConFullSig data_con stupid_theta = dataConStupidTheta data_con - wrap_tvs = dataConUserTyVars data_con + wrap_tvbs = dataConUserTyVarBinders data_con res_ty_args = dataConResRepTyArgs data_con tycon = dataConTyCon data_con -- The representation TyCon (not family) @@ -907,17 +909,20 @@ -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module. = False + | isUnaryClassTyCon tycon -- See (UCM8) in Note [Unary class magic] + = False -- in GHC.Core.TyCon + | otherwise = (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. - && (any isBanged (ev_ibangs ++ arg_ibangs))) - -- Some forcing/unboxing (includes eq_spec) + && (any isUnpacked (ev_ibangs ++ arg_ibangs))) + -- Some unboxing (includes eq_spec) || isFamInstTyCon tycon -- Cast result - || dataConUserTyVarsNeedWrapper data_con + || dataConUserTyVarBindersNeedWrapper data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder @@ -941,8 +946,7 @@ mk_boxer boxers = DCB (\ ty_args src_vars -> do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTCvSubstList subst1 ex_tvs - (mkTyCoVarTys ex_vars) + subst2 = foldl2 extendTvSubstWithClone subst1 ex_tvs ex_vars ; (rep_ids, binds) <- go subst2 boxers term_vars ; return (ex_vars ++ rep_ids, binds) } ) @@ -1180,7 +1184,7 @@ = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) dataConArgRep arg_ty (HsStrict _) - = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + = ([(arg_ty, MarkedStrict)], (unitUnboxer, unitBoxer)) -- Seqs are inserted in STG dataConArgRep arg_ty (HsUnpack Nothing) = dataConArgUnpack arg_ty @@ -1210,9 +1214,6 @@ ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } ------------------------ -seqUnboxer :: Unboxer -seqUnboxer v = return ([v], mkDefaultCase (Var v) v) - unitUnboxer :: Unboxer unitUnboxer v = return ([v], \e -> e) @@ -1512,50 +1513,109 @@ | otherwise -- Wrinkle (W4) of Note [Recursive unboxing] -> bang_opt_unbox_strict bang_opts || (bang_opt_unbox_small bang_opts - && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + && is_small_rep) -- See Note [Unpack one-wide fields] where (rep_tys, _) = dataConArgUnpack arg_ty + -- Takes in the list of reps used to represent the dataCon after it's unpacked + -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields] + is_small_rep = + let -- Neccesary to look through unboxed tuples. + prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys + -- And then get the actual size of the unpacked constructor. + rep_size = sum $ map primRepSizeW64_B prim_reps + in rep_size <= 8 + is_sum :: [DataCon] -> Bool -- We never unpack sum types automatically -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.) is_sum (_:_:_) = True is_sum _ = False --- Given a type already assumed to have been normalized by topNormaliseType, --- unpackable_type_datacons ty = Just datacons --- iff ty is of the form --- T ty1 .. tyn --- and T is an algebraic data type (not newtype), in which no data --- constructors have existentials, and datacons is the list of data --- constructors of T. + + unpackable_type_datacons :: Type -> Maybe [DataCon] +-- Given a type already assumed to have been normalized by topNormaliseType, +-- unpackable_type_datacons (T ty1 .. tyn) = Just datacons +-- iff the type can be unpacked (see Note [Unpacking GADTs and existentials]) +-- and `datacons` are the data constructors of T unpackable_type_datacons ty | Just (tc, _) <- splitTyConApp_maybe ty - , not (isNewTyCon tc) -- Even though `ty` has been normalised, it could still - -- be a /recursive/ newtype, so we must check for that + , not (isNewTyCon tc) + -- isNewTyCon: even though `ty` has been normalised, whic includes looking + -- through newtypes, it could still be a /recursive/ newtype, so we must + -- check for that case , Just cons <- tyConDataCons_maybe tc - , not (null cons) -- Don't upack nullary sums; no need. - -- They already take zero bits - , all (null . dataConExTyCoVars) cons - = Just cons -- See Note [Unpacking GADTs and existentials] + , unpackable_cons cons + = Just cons | otherwise = Nothing + where + unpackable_cons :: [DataCon] -> Bool + -- True if we can unpack a value of type (T t1 .. tn), + -- where T is an algebraic data type with these constructors + -- See Note [Unpacking GADTs and existentials] + unpackable_cons [] -- Don't unpack nullary sums; no need. + = False -- They already take zero bits; see (UC0) + unpackable_cons [con] -- Exactly one data constructor; see (UC1) + = null (dataConExTyCoVars con) + + unpackable_cons cons -- More than one data constructor; see (UC2) + = all isVanillaDataCon cons + {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is nothing stopping us unpacking a data type with equality -components, like - data Equal a b where - Equal :: Equal a a +Can we unpack a value of an algebraic data type T? For example + data D a = MkD {-# UNPACK #-} (T a) +Can we unpack that (T a) field? -And it'd be fine to unpack a product type with existential components -too, but that would require a bit more plumbing, so currently we don't. +Three cases to consider in `unpackable_cons` -So for now we require: null (dataConExTyCoVars data_con) -See #14978 +(UC0) No data constructors; a nullary sum type. This already takes zero + bits so there is no point in unpacking it. +(UC1) Single-constructor types (products). We can just represent it by + its fields. For example, if `T` is defined as: + data T a = MkT a a Int + then we can unpack it as follows. The worker for MkD takes three unpacked fields: + data D a = MkD a a Int + $MkD :: T a -> D a + $MkD (MkT a1 a2 i) = MkD a1 a2 i + + We currently /can't/ do this if T has existentially-bound type variables, + hence: null (dataConExTyCoVars con) in `unpackable_cons`. + But see also (UC3) below. + + But we /can/ do it for (some) GADTs, such as: + data Equal a b where { Equal :: Equal a a } + data Wom a where { Wom1 :: Int -> Wom Bool } + We will get a MkD constructor that includes some coercion arguments, + but that is fine. See #14978. We still can't accommodate existentials, + but these particular examples don't use existentials. + +(UC2) Multi-constructor types, e.g. + data T a = T1 a | T2 Int a + Here we unpack the field to an unboxed sum type, thus: + data D a = MkD (# a | (# Int, a #) #) + + However, now we can't deal with GADTs at all, because we'd need an + unboxed sum whose component was a unboxed tuple, whose component(s) + have kind (CONSTRAINT r); and that's not well-kinded. Hence the + all isVanillaDataCon + condition in `unpackable_cons`. See #25672. + +(UC3) For single-constructor types, with some more plumbing we could + allow existentials. e.g. + data T a = forall b. MkT a (b->Int) b + could unpack to + data D a = forall b. MkD a (b->Int) b + $MkD :: T a -> D a + $MkD (MkT @b x f y) = MkD @b x f y + Eminently possible, but more plumbing needed. + + Note [Unpack one-wide fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The flag UnboxSmallStrictFields ensures that any field that can @@ -1580,6 +1640,14 @@ Here we can represent T with an Int#. +Special care has to be taken to make sure we don't mistake fields with unboxed +tuple/sum rep or very large reps. See #22309 + +For consistency we unpack anything that fits into 8 bytes on a 64-bit platform, +even when compiling for 32bit platforms. This way unpacking decisions will be the +same for 32bit and 64bit systems. To do so we use primRepSizeW64_B instead of +primRepSizeB. See also the tests in test case T22309. + Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1777,12 +1845,12 @@ -- See Note [Dict funs and default methods] mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalId (DFunId is_nt) + = mkExportedLocalId (DFunId is_unary) dfun_name dfun_ty where - is_nt = isNewTyCon (classTyCon clas) - dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys) + is_unary = isUnaryClass clas + dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys) {- ************************************************************************ @@ -1803,6 +1871,7 @@ failure when trying.) -} + nullAddrName, seqName, realWorldName, voidPrimIdName, coercionTokenName, coerceName, proxyName, @@ -1850,7 +1919,7 @@ ------------------------------------------------ seqId :: Id -- See Note [seqId magic] -seqId = pcMiscPrelId seqName ty info +seqId = pcRepPolyId seqName ty concs info where info = noCafIdInfo `setInlinePragInfo` inline_prag `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -1874,6 +1943,9 @@ rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $ Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] + concs = mkRepPolyIdConcreteTyVars + [ ((openBetaTy, mkArgPos 2 Top), runtimeRep2TyVar)] + arity = 2 ------------------------------------------------ @@ -1911,12 +1983,13 @@ info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) -oneShotId :: Id -- See Note [The oneShot function] -oneShotId = pcMiscPrelId oneShotName ty info +oneShotId :: Id -- See Note [oneShot magic] +oneShotId = pcRepPolyId oneShotName ty concs info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity + -- oneShot :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). (a -> b) -> (a -> b) ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ mkVisFunTyMany fun_ty fun_ty @@ -1929,6 +2002,9 @@ Var body `App` Var x' arity = 2 + concs = mkRepPolyIdConcreteTyVars + [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1953,7 +2029,7 @@ -- is () and not undefined -- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList) leftSectionId :: Id -leftSectionId = pcMiscPrelId leftSectionName ty info +leftSectionId = pcRepPolyId leftSectionName ty concs info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -1971,6 +2047,9 @@ body = mkLams [f,xmult] $ App (Var f) (Var xmult) arity = 2 + concs = mkRepPolyIdConcreteTyVars + [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax] -- rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3). @@ -1978,7 +2057,7 @@ -- rightSection f y x = f x y -- Again, multiplicity polymorphism is important rightSectionId :: Id -rightSectionId = pcMiscPrelId rightSectionName ty info +rightSectionId = pcRepPolyId rightSectionName ty concs info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -2001,10 +2080,15 @@ body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult] arity = 3 + concs = + mkRepPolyIdConcreteTyVars + [ ((openAlphaTy, mkArgPos 3 Top), runtimeRep1TyVar) + , ((openBetaTy , mkArgPos 2 Top), runtimeRep2TyVar)] + -------------------------------------------------------------------------------- coerceId :: Id -coerceId = pcMiscPrelId coerceName ty info +coerceId = pcRepPolyId coerceName ty concs info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -2028,6 +2112,9 @@ mkWildCase (Var eqR) (unrestricted eqRTy) b $ [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))] + concs = mkRepPolyIdConcreteTyVars + [((mkTyVarTy av, mkArgPos 1 Top), rv)] + {- Note [seqId magic] ~~~~~~~~~~~~~~~~~~ @@ -2156,7 +2243,7 @@ Solution: in the desugarer, rewrite noinline (f x y) ==> noinline f x y - This is done in GHC.HsToCore.Utils.mkCoreAppDs. + This is done in the `noinlineId` case of `GHC.HsToCore.Expr.ds_app_var` This is only needed for noinlineId, not noInlineConstraintId (wrinkle (W1) below), because the latter never shows up in user code. @@ -2195,8 +2282,106 @@ * To defeat the specialiser when we have incoherent instances. See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv. -Note [The oneShot function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [seq# magic] +~~~~~~~~~~~~~~~~~ +The purpose of the magic Id (See Note [magicIds]) + + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is to elevate evaluation of its argument `a` into an observable side effect. +This implies that GHC's optimisations must preserve the evaluation "exactly +here", in the state thread. + +The main use of seq# is to implement `evaluate` + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +Its (NOINLINE) definition in GHC.Magic is simply + + seq# a s = let !a' = lazy a in (# s, a' #) + +Things to note + +(SEQ1) + It must be NOINLINE, because otherwise the eval !a' would be decoupled from + the state token s, and GHC's optimisations, in particular strictness analysis, + would happily move the eval around. + + However, we *do* inline saturated applications of seq# in CorePrep, where + evaluation order is fixed; see the implementation notes below. + This is one reason why we need seq# to be known-key. + +(SEQ2) + The use of `lazy` ensures that strictness analysis does not see the eval + that takes place, so the final demand signature is , not <1L>. + This is important for a definition like + + foo x y = evaluate y >> evaluate x + + Although both y and x are ultimately evaluated, the user made it clear + they want to evaluate y *before* x. + But if strictness analysis sees the evals, it infers foo as strict in + both parameters. This strictness would be exploited in the backend by + picking a call-by-value calling convention for foo, one that would evaluate + x *before* y. Nononono! + + Because the definition of seq# uses `lazy`, it must live in a different module + (GHC.Internal.IO); otherwise strictness analysis uses its own strictness + signature for the definition of `lazy` instead of the one we wire in. + +(SEQ3) + Why does seq# return the value? Consider + let x = e in + case seq# x s of (# _, x' #) -> ... x' ... case x' of __DEFAULT -> ... + Here, we could simply use x instead of x', but doing so would + introduce an unnecessary indirection and tag check at runtime; + also we can attach an evaldUnfolding to x' to discard any + subsequent evals such as the `case x' of __DEFAULT`. + +(SEQ4) + T15226 demonstrates that we want to discard ok-for-discard seq#s. That is, + simplify `case seq# s of (# s', _ #) -> rhs[s']` to `rhs[s]`. + You might wonder whether the Simplifier could do this. But see the excellent + example in #24334 (immortalised as test T24334) for why it should be done in + CorePrep. + +Implementing seq#. The compiler has magic for `seq#` in + +- GHC.CoreToStg.Prep.cpeRhsE: Implement (SEQ4). + +- Simplify.addEvals records evaluated-ness for the result (cf. (SEQ3)); see + Note [Adding evaluatedness info to pattern-bound variables] + in GHC.Core.Opt.Simplify.Iteration + +- GHC.Core.Opt.DmdAnal.exprMayThrowPreciseException: + Historically, seq# used to be a primop, and the majority of primops + should return False in exprMayThrowPreciseException, so we do the same + for seq# for back compat. + +- GHC.CoreToStg.Prep: Inline saturated applications to a Case, e.g., + + seq# (f 13) s + ==> + case f 13 of sat of __DEFAULT -> (# s, sat #) + + This is implemented in `cpeApp`, not unlike Note [runRW magic]. + We are only inlining seq#, leaving opportunities for case-of-known-con + behind that are easily picked up by Unarise: + + case seq# f 13 s of (# s', r #) -> rhs + ==> {Prep} + case f 13 of sat of __DEFAULT -> case (# s, sat #) of (# s', r #) -> rhs + ==> {Unarise} + case f 13 of sat of __DEFAULT -> rhs[s/s',sat/r] + + Note that CorePrep really allocates a CaseBound FloatingBind for `f 13`. + That's OK, because the telescope of Floats always stays in the same order + and won't be floated out of binders, so all guarantees of evaluation order + provided by seq# are upheld. + +Note [oneShot magic] +~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 and Note [Left folds via right fold]) it was determined that it would be useful if library authors could explicitly tell the compiler that a certain lambda is @@ -2220,13 +2405,19 @@ --> \x[oneshot] e[x/y] which is what we want. -It is only effective if the one-shot info survives as long as possible; in -particular it must make it into the interface in unfoldings. See Note [Preserve -OneShotInfo] in GHC.Core.Tidy. - Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. +Wrinkles: +(OS1) It is only effective if the one-shot info survives as long as possible; in + particular it must make it into the interface in unfoldings. See Note [Preserve + OneShotInfo] in GHC.Core.Tidy. +(OS2) (oneShot (error "urk")) rewrites to + \x[oneshot]. error "urk" x + thereby hiding the `error` under a lambda, which might be surprising, + particularly if you have `-fpedantic-bottoms` on. See #24296. + + ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}. If things get nasty as-is, change it back to a literal (@Literal@). @@ -2277,3 +2468,28 @@ pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info = mkVanillaGlobalWithInfo name ty info + +pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id +pcRepPolyId name ty conc_tvs info = + mkGlobalId (RepPolyId $ conc_tvs name) name ty info + +-- | Directly specify which outer forall'd type variables of a +-- representation-polymorphic 'Id' such become concrete metavariables when +-- instantiated. +mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)] + -- ^ ((ty, pos), tv) + -- 'ty' is the type on which the representation-polymorphism + -- check is done + -- 'tv' is the type variable we are checking for concreteness + -- (usually the kind of 'ty') + -- 'pos' is the position of 'ty' in the + -- type of the 'Id' + -> Name -- ^ 'Name' of the rep-poly 'Id' + -> ConcreteTyVars +mkRepPolyIdConcreteTyVars vars nm = + mkNameEnv [ (tyVarName tv, mk_conc_frr ty pos) + | ((ty,pos), tv) <- vars ] + where + mk_conc_frr ty pos = + ConcreteFRR $ FixedRuntimeRepOrigin ty + $ FRRRepPolyId nm RepPolyFunction pos diff --git a/GHC/Types/Literal.hs b/GHC/Types/Literal.hs --- a/GHC/Types/Literal.hs +++ b/GHC/Types/Literal.hs @@ -9,8 +9,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Core literals module GHC.Types.Literal ( @@ -86,6 +84,7 @@ import Data.Data ( Data ) import GHC.Exts( isTrue#, dataToTag#, (<#) ) import Numeric ( fromRat ) +import Control.DeepSeq {- ************************************************************************ @@ -136,8 +135,8 @@ | LitRubbish -- ^ A nonsense value; See Note [Rubbish literals]. TypeOrConstraint -- t_or_c: whether this is a type or a constraint RuntimeRepType -- rr: a type of kind RuntimeRep - -- The type of the literal is forall (a:TYPE rr). a - -- or forall (a:CONSTRAINT rr). a + -- The type of the literal is forall (a::TYPE rr). a + -- or forall (a::CONSTRAINT rr). a -- -- INVARIANT: the Type has no free variables -- and so substitution etc can ignore it @@ -145,19 +144,13 @@ | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' - | LitLabel FastString (Maybe Int) FunctionOrData + | LitLabel FastString FunctionOrData -- ^ A label literal. Parameters: -- -- 1) The name of the symbol mentioned in the -- declaration -- - -- 2) The size (in bytes) of the arguments - -- the label expects. Only applicable with - -- @stdcall@ labels. @Just x@ => @\@ will - -- be appended to label name when emitting - -- assembly. - -- - -- 3) Flag indicating whether the symbol + -- 2) Flag indicating whether the symbol -- references a function or a data deriving Data @@ -212,6 +205,20 @@ h <- getByte bh return (toEnum (fromIntegral h)) +instance NFData LitNumType where + rnf (LitNumBigNat) = () + rnf (LitNumInt) = () + rnf (LitNumInt8) = () + rnf (LitNumInt16) = () + rnf (LitNumInt32) = () + rnf (LitNumInt64) = () + rnf (LitNumWord) = () + rnf (LitNumWord8) = () + rnf (LitNumWord16) = () + rnf (LitNumWord32) = () + rnf (LitNumWord64) = () + + {- Note [BigNum literals] ~~~~~~~~~~~~~~~~~~~~~~ @@ -259,10 +266,9 @@ put_ bh (LitNullAddr) = putByte bh 2 put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (LitLabel aj mb fod) + put_ bh (LitLabel aj fod) = do putByte bh 5 put_ bh aj - put_ bh mb put_ bh fod put_ bh (LitNumber nt i) = do putByte bh 6 @@ -289,15 +295,24 @@ return (LitDouble ai) 5 -> do aj <- get bh - mb <- get bh fod <- get bh - return (LitLabel aj mb fod) + return (LitLabel aj fod) 6 -> do nt <- get bh i <- get bh return (LitNumber nt i) _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) +instance NFData Literal where + rnf (LitChar c) = rnf c + rnf (LitNumber nt i) = rnf nt `seq` rnf i + rnf (LitString s) = rnf s + rnf LitNullAddr = () + rnf (LitFloat r) = rnf r + rnf (LitDouble r) = rnf r + rnf (LitLabel l1 k2) = rnf l1 `seq` rnf k2 + rnf (LitRubbish {}) = () -- LitRubbish is not contained within interface files. + -- See Note [Rubbish literals]. instance Outputable Literal where ppr = pprLiteral id @@ -336,7 +351,12 @@ -- | Make a literal number using wrapping semantics if the value is out of -- bound. mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal -mkLitNumberWrap platform nt i = case nt of +mkLitNumberWrap platform nt i = LitNumber nt $ mkLitNumberWrap' platform nt i + +-- | Make a literal number using wrapping semantics if the value is out of +-- bound. +mkLitNumberWrap' :: Platform -> LitNumType -> Integer -> Integer +mkLitNumberWrap' platform nt i = case nt of LitNumInt -> case platformWordSize platform of PW4 -> wrap @Int32 PW8 -> wrap @Int64 @@ -353,10 +373,10 @@ LitNumWord64 -> wrap @Word64 LitNumBigNat | i < 0 -> panic "mkLitNumberWrap: trying to create a negative BigNat" - | otherwise -> LitNumber nt i + | otherwise -> i where - wrap :: forall a. (Integral a, Num a) => Literal - wrap = LitNumber nt (toInteger (fromIntegral i :: a)) + wrap :: forall a. (Integral a, Num a) => Integer + wrap = toInteger (fromIntegral i :: a) -- | Wrap a literal number according to its type using wrapping semantics. litNumWrap :: Platform -> Literal -> Literal @@ -372,9 +392,7 @@ -- converting it back to its original type. litNumNarrow :: LitNumType -> Platform -> Literal -> Literal litNumNarrow pt platform (LitNumber nt i) - = case mkLitNumberWrap platform pt i of - LitNumber _ j -> mkLitNumberWrap platform nt j - l -> pprPanic "litNumNarrow: got invalid literal" (ppr l) + = mkLitNumberWrap platform nt . mkLitNumberWrap' platform pt $ i litNumNarrow _ _ l = pprPanic "litNumNarrow: invalid literal" (ppr l) @@ -437,9 +455,9 @@ -- the argument is wrapped and the overflow flag will be set. -- See Note [Word/Int underflow/overflow] mkLitIntWrapC :: Platform -> Integer -> (Literal, Bool) -mkLitIntWrapC platform i = (n, i /= i') +mkLitIntWrapC platform i = (LitNumber LitNumInt i', i /= i') where - n@(LitNumber _ i') = mkLitIntWrap platform i + i' = mkLitNumberWrap' platform LitNumInt i -- | Creates a 'Literal' of type @Word#@ mkLitWord :: Platform -> Integer -> Literal @@ -461,9 +479,9 @@ -- the argument is wrapped and the carry flag will be set. -- See Note [Word/Int underflow/overflow] mkLitWordWrapC :: Platform -> Integer -> (Literal, Bool) -mkLitWordWrapC platform i = (n, i /= i') +mkLitWordWrapC platform i = (LitNumber LitNumWord i', i /= i') where - n@(LitNumber _ i') = mkLitWordWrap platform i + i' = mkLitNumberWrap' platform LitNumWord i -- | Creates a 'Literal' of type @Int8#@ mkLitInt8 :: Integer -> Literal @@ -843,7 +861,7 @@ literalType (LitString _) = addrPrimTy literalType (LitFloat _) = floatPrimTy literalType (LitDouble _) = doublePrimTy -literalType (LitLabel _ _ _) = addrPrimTy +literalType (LitLabel _ _) = addrPrimTy literalType (LitNumber lt _) = case lt of LitNumBigNat -> byteArrayPrimTy LitNumInt -> intPrimTy @@ -874,7 +892,7 @@ cmpLit (LitNullAddr) (LitNullAddr) = EQ cmpLit (LitFloat a) (LitFloat b) = a `compare` b cmpLit (LitDouble a) (LitDouble b) = a `compare` b -cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `lexicalCompareFS` b +cmpLit (LitLabel a _) (LitLabel b _) = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a) (LitNumber nt2 b) = (nt1 `compare` nt2) `mappend` (a `compare` b) cmpLit (LitRubbish tc1 b1) (LitRubbish tc2 b2) = (tc1 `compare` tc2) `mappend` @@ -908,11 +926,8 @@ LitNumWord16 -> pprPrimWord16 i LitNumWord32 -> pprPrimWord32 i LitNumWord64 -> pprPrimWord64 i -pprLiteral add_par (LitLabel l mb fod) = - add_par (text "__label" <+> b <+> ppr fod) - where b = case mb of - Nothing -> pprHsString l - Just x -> doubleQuotes (ftext l <> text ('@':show x)) +pprLiteral add_par (LitLabel l fod) = + add_par (text "__label" <+> pprHsString l <+> ppr fod) pprLiteral _ (LitRubbish torc rep) = text "RUBBISH" <> pp_tc <> parens (ppr rep) where diff --git a/GHC/Types/Meta.hs b/GHC/Types/Meta.hs --- a/GHC/Types/Meta.hs +++ b/GHC/Types/Meta.hs @@ -16,6 +16,8 @@ import GHC.Serialized ( Serialized ) import GHC.Hs +import GHC.Utils.Outputable +import GHC.Utils.Panic -- | The supported metaprogramming result types @@ -28,11 +30,42 @@ -- | data constructors not exported to ensure correct result type data MetaResult - = MetaResE { unMetaResE :: LHsExpr GhcPs } - | MetaResP { unMetaResP :: LPat GhcPs } - | MetaResT { unMetaResT :: LHsType GhcPs } - | MetaResD { unMetaResD :: [LHsDecl GhcPs] } - | MetaResAW { unMetaResAW :: Serialized } + = MetaResE (LHsExpr GhcPs) + | MetaResP (LPat GhcPs) + | MetaResT (LHsType GhcPs) + | MetaResD [LHsDecl GhcPs] + | MetaResAW Serialized + +instance Outputable MetaResult where + ppr (MetaResE e) = text "MetaResE" <> braces (ppr e) + ppr (MetaResP p) = text "MetaResP" <> braces (ppr p) + ppr (MetaResT t) = text "MetaResT" <> braces (ppr t) + ppr (MetaResD d) = text "MetaResD" <> braces (ppr d) + ppr (MetaResAW aw) = text "MetaResAW" <> braces (ppr aw) + +-- These unMetaResE ext panics will triger if the MetaHook doesn't +-- take an expression to an expression, pattern to pattern etc. +-- +-- ToDo: surely this could be expressed in the type system? +unMetaResE :: MetaResult -> LHsExpr GhcPs +unMetaResE (MetaResE e) = e +unMetaResE mr = pprPanic "unMetaResE" (ppr mr) + +unMetaResP :: MetaResult -> LPat GhcPs +unMetaResP (MetaResP p) = p +unMetaResP mr = pprPanic "unMetaResP" (ppr mr) + +unMetaResT :: MetaResult -> LHsType GhcPs +unMetaResT (MetaResT t) = t +unMetaResT mr = pprPanic "unMetaResT" (ppr mr) + +unMetaResD :: MetaResult -> [LHsDecl GhcPs] +unMetaResD (MetaResD d) = d +unMetaResD mr = pprPanic "unMetaResD" (ppr mr) + +unMetaResAW :: MetaResult -> Serialized +unMetaResAW (MetaResAW aw) = aw +unMetaResAW mr = pprPanic "unMetaResAW" (ppr mr) type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult diff --git a/GHC/Types/Name.hs b/GHC/Types/Name.hs --- a/GHC/Types/Name.hs +++ b/GHC/Types/Name.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -- instance NFData FieldLabel @@ -58,15 +59,17 @@ localiseName, namePun_maybe, - pprName, + pprName, pprName_userQual, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, - pprFullName, pprTickyName, + pprFullName, pprFullNameWithUnique, pprTickyName, -- ** Predicates on 'Name's isSystemName, isInternalName, isExternalName, isTyVarName, isTyConName, isDataConName, isValName, isVarName, isDynLinkName, isFieldName, isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName, + isSumTyConName, + isUnboxedTupleDataConLikeName, isHoleName, wiredInNameTyThing_maybe, nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage, @@ -102,12 +105,14 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.OldList (intersperse) import Control.DeepSeq import Data.Data import qualified Data.Semigroup as S -import GHC.Types.Basic (Boxity(Boxed)) -import GHC.Builtin.Uniques (isTupleTyConUnique) +import GHC.Types.Basic (Boxity(Boxed, Unboxed)) +import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique, + isSumTyConUnique, isTupleDataConLikeUnique ) {- ************************************************************************ @@ -143,12 +148,16 @@ -- See Note [About the NameSorts] data NameSort = External Module + -- Either an import from another module + -- or a top-level name + -- See Note [About the NameSorts] | WiredIn Module TyThing BuiltInSyntax -- A variant of External, for wired-in things - | Internal -- A user-defined Id or TyVar + | Internal -- A user-defined local Id or TyVar -- defined in the module being compiled + -- See Note [About the NameSorts] | System -- A system-defined Id or TyVar. Typically the -- OccName is very uninformative (like 's') @@ -185,18 +194,18 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this wired-in Name in GHC.Builtin.Names: - int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey + int8TyConName = tcQual gHC_INTERNAL_INT (fsLit "Int8") int8TyConKey Ultimately this turns into something like: - int8TyConName = Name gHC_INT (mkOccName ..."Int8") int8TyConKey + int8TyConName = Name gHC_INTERNAL_INT (mkOccName ..."Int8") int8TyConKey So a comparison like `x == int8TyConName` will turn into `getUnique x == int8TyConKey`, nice and efficient. But if the `n_occ` field is strict, that definition will look like: - int8TyCOnName = case (mkOccName..."Int8") of occ -> - Name gHC_INT occ int8TyConKey + int8TyConName = case (mkOccName..."Int8") of occ -> + Name gHC_INTERNAL_INT occ int8TyConKey and now the comparison will not optimise. This matters even more when there are numerous comparisons (see #19386): @@ -213,21 +222,32 @@ {- Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Initially: + * All types, classes, data constructors get External Names + * Top-level Ids (including locally-defined ones) get External Names, + * All other local (non-top-level) Ids get Internal names -1. Initially, top-level Ids (including locally-defined ones) get External names, - and all other local Ids get Internal names +2. In the Tidy phase (GHC.Iface.Tidy): + * An Id that is "externally-visible" is given an External Name, + even if the name was Internal up to that point + * An Id that is not externally visible is given an Internal Name. + even if the name was External up to that point + See GHC.Iface.Tidy.tidyTopName -2. In any invocation of GHC, an External Name for "M.x" has one and only one + An Id is externally visible if it is mentioned in the interface file; e.g. + - it is exported + - it is mentioned in an unfolding + See GHC.Iface.Tidy.chooseExternalIds + +3. In any invocation of GHC, an External Name for "M.x" has one and only one unique. This unique association is ensured via the Name Cache; see Note [The Name Cache] in GHC.Iface.Env. -3. Things with a External name are given C static labels, so they finally - appear in the .o file's symbol table. They appear in the symbol table - in the form M.n. If originally-local things have this property they - must be made @External@ first. +4. In code generation, things with a External name are given C static + labels, so they finally appear in the .o file's symbol table. They + appear in the symbol table in the form M.n. That is why + externally-visible things are made External (see (2) above). -4. In the tidy-core phase, a External that is not visible to an importer - is changed to Internal, and a Internal that is visible is changed to External 5. A System Name differs in the following ways: a) has unique attached when printing dumps @@ -239,13 +259,13 @@ If any desugarer sys-locals have survived that far, they get changed to "ds1", "ds2", etc. -Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) +6. A WiredIn Name is used for things (Id, TyCon) that are fully known to the compiler, + not read from an interface file. E.g. Bool, True, Int, Float, and many others. -Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, - not read from an interface file. - E.g. Bool, True, Int, Float, and many others + A WiredIn Name contains contains a TyThing, so we don't have to look it up. -All built-in syntax is for wired-in things. + The BuiltInSyntax flag => It's a syntactic form, not "in scope" (e.g. []) + All built-in syntax things are WiredIn. -} instance HasOccName Name where @@ -294,6 +314,15 @@ isTupleTyConName :: Name -> Bool isTupleTyConName = isJust . isTupleTyConUnique . getUnique +isSumTyConName :: Name -> Bool +isSumTyConName = isJust . isSumTyConUnique . getUnique + +-- | This matches a datacon as well as its worker and promoted tycon. +isUnboxedTupleDataConLikeName :: Name -> Bool +isUnboxedTupleDataConLikeName n + | Just (Unboxed, _) <- isTupleDataConLikeUnique (getUnique n) = True + | otherwise = False + isExternalName (Name {n_sort = External _}) = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True isExternalName _ = False @@ -350,14 +379,29 @@ -- Return the pun for a name if available. -- Used for pretty-printing under ListTuplePuns. +-- Arity 1 is skipped here because unary tuples have no prefix representation, +-- since that is occupied by the unit tuple. namePun_maybe :: Name -> Maybe FastString namePun_maybe name | getUnique name == getUnique listTyCon = Just (fsLit "[]") - | Just (Boxed, ar) <- isTupleTyConUnique (getUnique name) - , ar /= 1 = Just (fsLit $ '(' : commas ar ++ ")") + | Just (boxity, ar) <- isTupleTyConUnique (getUnique name) + , ar /= 1 + = let (lpar, rpar) = case boxity of + Boxed -> ("(", ")") + Unboxed -> ("(#", "#)") + in Just (fsLit $ lpar ++ commas ar ++ rpar) + + | Just ar <- isCTupleTyConUnique (getUnique name) + , ar /= 1 + = Just (fsLit $ "(" ++ commas ar ++ ")") + -- constraint tuples look just like boxed tuples + + | Just ar <- isSumTyConUnique (getUnique name) + = Just (fsLit $ "(# " ++ bars ar ++ " #)") where commas ar = replicate (ar-1) ',' + bars ar = intersperse ' ' (replicate (ar-1) '|') namePun_maybe _ = Nothing @@ -591,7 +635,7 @@ -- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which -- means that the ordering is not stable across deserialization or rebuilds. -- --- See `nonDetCmpUnique` for further information, and trac #15240 for a bug +-- See `nonDetCmpUnique` for further information, and #15240 for a bug -- caused by improper use of this instance. -- For a deterministic lexicographic ordering, use `stableNameCmp`. @@ -624,12 +668,12 @@ -- distinction. instance Binary Name where put_ bh name = - case getUserData bh of - UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name + case findUserDataWriter Proxy bh of + tbl -> putEntry tbl bh name get bh = - case getUserData bh of - UserData { ud_get_name = get_name } -> get_name bh + case findUserDataReader Proxy bh of + tbl -> getEntry tbl bh {- ************************************************************************ @@ -648,7 +692,10 @@ pprPrefixOcc = pprPrefixName pprName :: forall doc. IsLine doc => Name -> doc -pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) +pprName = pprName_userQual Nothing + +pprName_userQual :: forall doc. IsLine doc => Maybe ModuleName -> Name -> doc +pprName_userQual user_qual name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = docWithStyle codeDoc normalDoc where codeDoc = case sort of @@ -666,8 +713,8 @@ sdocOption sdocListTuplePuns $ \listTuplePuns -> handlePuns listTuplePuns (namePun_maybe name) $ case sort of - WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin - External mod -> pprExternal debug sty uniq mod occ False UserSyntax + WiredIn mod _ builtin -> pprExternal debug sty uniq mod user_qual occ True builtin + External mod -> pprExternal debug sty uniq mod user_qual occ False UserSyntax System -> pprSystem debug sty uniq occ Internal -> pprInternal debug sty uniq occ @@ -677,9 +724,9 @@ {-# SPECIALISE pprName :: Name -> SDoc #-} {-# SPECIALISE pprName :: Name -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable --- | Print fully qualified name (with unit-id, module and unique) +-- | Print fully qualified name (with unit-id and module, but no unique) pprFullName :: Module -> Name -> SDoc -pprFullName this_mod Name{n_sort = sort, n_uniq = uniq, n_occ = occ} = +pprFullName this_mod Name{n_sort = sort, n_occ = occ} = let mod = case sort of WiredIn m _ _ -> m External m -> m @@ -688,8 +735,18 @@ in ftext (unitIdFS (moduleUnitId mod)) <> colon <> ftext (moduleNameFS $ moduleName mod) <> dot <> ftext (occNameFS occ) - <> char '_' <> pprUniqueAlways uniq +-- | Print fully qualified name (with unit-id and module, with the unique) +pprFullNameWithUnique :: Module -> Name -> SDoc +pprFullNameWithUnique this_mod Name{n_sort = sort, n_uniq = u, n_occ = occ} = + let mod = case sort of + WiredIn m _ _ -> m + External m -> m + System -> this_mod + Internal -> this_mod + in ftext (unitIdFS (moduleUnitId mod)) + <> colon <> ftext (moduleNameFS $ moduleName mod) + <> dot <> ftext (occNameFS occ) <> text "_" <> pprUniqueAlways u -- | Print a ticky ticky styled name -- @@ -706,8 +763,14 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal debug sty uniq mod occ is_wired is_builtin +pprExternal :: Bool -> PprStyle -> Unique + -> Module -- ^ module the 'Name' is defined in + -> Maybe ModuleName -- ^ user module qualification + -> OccName + -> Bool -- ^ wired-in? + -> BuiltInSyntax + -> SDoc +pprExternal debug sty uniq mod user_qual occ is_wired is_builtin | debug = pp_mod <> ppr_occ_name occ <> braces (hsep [if is_wired then text "(w)" else empty, pprNameSpaceBrief (occNameSpace occ), @@ -715,10 +778,10 @@ | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax | otherwise = if isHoleModule mod - then case qualName sty mod occ of + then case qualName sty mod user_qual occ of NameUnqual -> ppr_occ_name occ _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ) - else pprModulePrefix sty mod occ <> ppr_occ_name occ + else pprModulePrefix sty mod user_qual occ <> ppr_occ_name occ where pp_mod = ppUnlessOption sdocSuppressModulePrefixes (pprModule mod <> dot) @@ -743,11 +806,11 @@ -- so print the unique -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +pprModulePrefix :: PprStyle -> Module -> Maybe ModuleName -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in GHC.Types.Name.Ppr -pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $ - case qualName sty mod occ of -- See Outputable.QualifyName: +pprModulePrefix sty mod user_qual occ = ppUnlessOption sdocSuppressModulePrefixes $ + case qualName sty mod user_qual occ of -- See Outputable.QualifyName: NameQual modname -> pprModuleName modname <> dot -- Name is in scope NameNotInScope1 -> pprModule mod <> dot -- Not in scope NameNotInScope2 -> pprUnit (moduleUnit mod) <> colon -- Module not in @@ -840,7 +903,7 @@ -- add parens or back-quotes as appropriate pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) -pprPrefixName :: NamedThing a => a -> SDoc -pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) +pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr thing) where name = getName thing diff --git a/GHC/Types/Name/Cache.hs b/GHC/Types/Name/Cache.hs --- a/GHC/Types/Name/Cache.hs +++ b/GHC/Types/Name/Cache.hs @@ -3,6 +3,8 @@ -- | The Name Cache module GHC.Types.Name.Cache ( NameCache (..) + , newNameCache + , newNameCacheWith , initNameCache , takeUniqFromNameCache , updateNameCache' @@ -13,6 +15,10 @@ , lookupOrigNameCache , extendOrigNameCache' , extendOrigNameCache + + -- * Known-key names + , knownKeysOrigNameCache + , isKnownOrigName_maybe ) where @@ -23,15 +29,15 @@ import GHC.Types.Unique.Supply import GHC.Builtin.Types import GHC.Builtin.Names +import GHC.Builtin.Utils import GHC.Utils.Outputable import GHC.Utils.Panic +import Control.Applicative import Control.Concurrent.MVar import Control.Monad -import Control.Applicative - {- Note [The Name Cache] @@ -58,36 +64,48 @@ Note [Built-in syntax and the OrigNameCache] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Built-in syntax refers to names that are always in scope and can't be imported +or exported. Such names come in two varieties: -Built-in syntax like unboxed sums and punned syntax like tuples are quite -ubiquitous. To lower their cost we use two tricks, +* Simple names (finite): `[]`, `:`, `->` +* Families of names (infinite): + * boxed tuples `()`, `(,)`, `(,,)`, `(,,,)`, ... + * unboxed tuples `(##)`, `(#,#)`, `(#,,#)`, ... + * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ... + * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ... - a. We specially encode tuple and sum Names in interface files' symbol tables - to avoid having to look up their names while loading interface files. - Namely these names are encoded as by their Uniques. We know how to get from - a Unique back to the Name which it represents via the mapping defined in - the SumTupleUniques module. See Note [Symbol table representation of names] - in GHC.Iface.Binary and for details. +Concretely, a built-in name is a WiredIn Name that has a BuiltInSyntax flag. - b. We don't include them in the Orig name cache but instead parse their - OccNames (in isBuiltInOcc_maybe and isPunOcc_maybe) to avoid bloating - the name cache with them. +Historically, GHC used to avoid putting any built-in syntax in the OrigNameCache +to avoid dealing with infinite families of names (tuples and sums). This measure +has become inadequate with the introduction of NoListTuplePuns (GHC Proposal #475). +Nowadays tuples and sums also use Names that are WiredIn, but are not BuiltInSyntax: -Why is the second measure necessary? Good question; afterall, 1) the parser -emits built-in and punned syntax directly as Exact RdrNames, and 2) built-in -and punned syntax never needs to looked-up during interface loading due to (a). -It turns out that there are two reasons why we might look up an Orig RdrName -for built-in and punned syntax, +* boxed tuples (tycons): Unit, Solo, Tuple2, Tuple3, Tuple4, ... +* unboxed tuples (tycons): Unit#, Solo#, Tuple2#, Tuple3#, Tuple4#, ... +* constraint tuples (tycons): CUnit, CSolo, CTuple2, CTuple3, CTuple4, ... +* one-tuples (datacons): MkSolo, MkSolo# - * If you use setRdrNameSpace on an Exact RdrName it may be - turned into an Orig RdrName. +We can't put infinitely many names in a finite data structure (OrigNameCache). +So we deal with them in lookupOrigNameCache by means of isInfiniteFamilyOrigName_maybe. - * Template Haskell turns a BuiltInSyntax Name into a TH.NameG - (GHC.HsToCore.Quote.globalVar), and parses a NameG into an Orig RdrName - (GHC.ThToHs.thRdrName). So, e.g. $(do { reify '(,); ... }) will - go this route (#8954). +At the same time, simple finite built-in names (`[]`, `:`, `->`) can be put in +the OrigNameCache without any issues (they end up there because they're +knownKeyNames). It doesn't matter that they're built-in syntax. +One might wonder: what's the point of having any built-in syntax in the +OrigNameCache at all? Good question; after all, + 1) The parser emits built-in and punned syntax directly as Exact RdrNames + 2) Template Haskell conversion (GHC.ThToHs) matches on built-in and punned + syntax directly to immediately produce Exact names (GHC.ThToHs.thRdrName) + 3) Loading of interface files encodes names via Uniques, as detailed in + Note [Symbol table representation of names] in GHC.Iface.Binary + +It turns out that we end up looking up built-in syntax in the cache when we +generate Haddock documentation. E.g. if we don't find tuple data constructors +there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) -} + -- | The NameCache makes sure that there is just one Unique assigned for -- each original name; i.e. (module-name, occ-name) pair and provides -- something of a lookup mechanism for those names. @@ -103,18 +121,14 @@ takeUniqFromNameCache (NameCache c _) = uniqFromTag c lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name -lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE_PRIM - , Just name <- isBuiltInOcc_maybe occ <|> isPunOcc_maybe mod occ - = -- See Note [Known-key names], 3(c) in GHC.Builtin.Names - -- Special case for tuples; there are too many - -- of them to pre-populate the original-name cache - Just name - - | otherwise - = case lookupModuleEnv nc mod of - Nothing -> Nothing - Just occ_env -> lookupOccEnv occ_env occ +lookupOrigNameCache nc mod occ = lookup_infinite <|> lookup_normal + where + -- See Note [Known-key names], 3(c) in GHC.Builtin.Names + -- and Note [Infinite families of known-key names] + lookup_infinite = isInfiniteFamilyOrigName_maybe mod occ + lookup_normal = do + occ_env <- lookupModuleEnv nc mod + lookupOccEnv occ_env occ extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache' nc name @@ -127,8 +141,27 @@ where combine _ occ_env = extendOccEnv occ_env occ name +-- | Initialize a new name cache +newNameCache :: IO NameCache +newNameCache = newNameCacheWith 'r' knownKeysOrigNameCache + +-- | This is a version of `newNameCache` that lets you supply your +-- own unique tag and set of known key names. This can go wrong if the tag +-- supplied is one reserved by GHC for internal purposes. See #26055 for +-- an example. +-- +-- Use `newNameCache` when possible. +newNameCacheWith :: Char -> OrigNameCache -> IO NameCache +newNameCacheWith c nc = NameCache c <$> newMVar nc + +-- | This takes a tag for uniques to be generated and the list of knownKeyNames +-- These must be initialized properly to ensure that names generated from this +-- NameCache do not conflict with known key names. +-- +-- Use `newNameCache` or `newNameCacheWith` instead +{-# DEPRECATED initNameCache "Use newNameCache or newNameCacheWith instead" #-} initNameCache :: Char -> [Name] -> IO NameCache -initNameCache c names = NameCache c <$> newMVar (initOrigNames names) +initNameCache c names = newNameCacheWith c (initOrigNames names) initOrigNames :: [Name] -> OrigNameCache initOrigNames names = foldl' extendOrigNameCache' emptyModuleEnv names @@ -160,3 +193,10 @@ -> IO c updateNameCache name_cache !_mod !_occ upd_fn = updateNameCache' name_cache upd_fn + +{-# NOINLINE knownKeysOrigNameCache #-} +knownKeysOrigNameCache :: OrigNameCache +knownKeysOrigNameCache = initOrigNames knownKeyNames + +isKnownOrigName_maybe :: Module -> OccName -> Maybe Name +isKnownOrigName_maybe = lookupOrigNameCache knownKeysOrigNameCache diff --git a/GHC/Types/Name/Env.hs b/GHC/Types/Name/Env.hs --- a/GHC/Types/Name/Env.hs +++ b/GHC/Types/Name/Env.hs @@ -5,10 +5,6 @@ \section[NameEnv]{@NameEnv@: name environments} -} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - module GHC.Types.Name.Env ( -- * Var, Id and TyVar environments (maps) NameEnv, @@ -170,7 +166,7 @@ disjointNameEnv x y = disjointUFM x y seqEltsNameEnv seqElt x = seqEltsUFM seqElt x -lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) +lookupNameEnv_NF env n = expectJust (lookupNameEnv env n) -- | Deterministic Name Environment -- diff --git a/GHC/Types/Name/Occurrence.hs b/GHC/Types/Name/Occurrence.hs --- a/GHC/Types/Name/Occurrence.hs +++ b/GHC/Types/Name/Occurrence.hs @@ -3,9 +3,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} ---{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} @@ -52,8 +49,7 @@ mkClsOcc, mkClsOccFS, mkDFunOcc, setOccNameSpace, - demoteOccName, - demoteOccTvName, + demoteOccName, demoteOccTcClsName, demoteOccTvName, promoteOccName, varToRecFieldOcc, recFieldToVarOcc, @@ -80,7 +76,7 @@ isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, isFieldOcc, fieldOcc_maybe, - parenSymOcc, startsWithUnderscore, + parenSymOcc, startsWithUnderscore, isUnderscore, isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, isFieldNameSpace, isTermVarOrFieldNameSpace, @@ -96,6 +92,7 @@ plusOccEnv, plusOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns, + sizeOccEnv, pprOccEnv, forceOccEnv, intersectOccEnv_C, @@ -109,7 +106,7 @@ mainOcc, ppMainFn, -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, trimTidyOccEnv, tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, -- FsEnv @@ -319,16 +316,23 @@ pprNameSpaceBrief TcClsName = text "tc" pprNameSpaceBrief (FldName {}) = text "fld" --- demoteNameSpace lowers the NameSpace if possible. We can not know --- in advance, since a TvName can appear in an HsTyVar. +-- | 'demoteNameSpace' lowers the 'NameSpace' to the term-level, if possible. +-- -- See Note [Demotion] in GHC.Rename.Env. demoteNameSpace :: NameSpace -> Maybe NameSpace demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing -demoteNameSpace TvName = Nothing +demoteNameSpace TvName = Just VarName demoteNameSpace TcClsName = Just DataName demoteNameSpace (FldName {}) = Nothing +demoteTcClsNameSpace :: NameSpace -> Maybe NameSpace +demoteTcClsNameSpace VarName = Nothing +demoteTcClsNameSpace DataName = Nothing +demoteTcClsNameSpace TvName = Nothing +demoteTcClsNameSpace TcClsName = Just DataName +demoteTcClsNameSpace (FldName {}) = Nothing + -- demoteTvNameSpace lowers the NameSpace of a type variable. -- See Note [Demotion] in GHC.Rename.Env. demoteTvNameSpace :: NameSpace -> Maybe NameSpace @@ -510,6 +514,11 @@ space' <- demoteNameSpace space return $ OccName space' name +demoteOccTcClsName :: OccName -> Maybe OccName +demoteOccTcClsName (OccName space name) = do + space' <- demoteTcClsNameSpace space + return $ OccName space' name + demoteOccTvName :: OccName -> Maybe OccName demoteOccTvName (OccName space name) = do space' <- demoteTvNameSpace space @@ -519,7 +528,9 @@ -- See Note [Promotion] in GHC.Rename.Env. promoteOccName :: OccName -> Maybe OccName promoteOccName (OccName space name) = do - space' <- promoteNameSpace space + promoted_space <- promoteNameSpace space + let tyop = isTvNameSpace promoted_space && isLexVarSym name + space' = if tyop then tcClsName else promoted_space -- special case for type operators (#24570) return $ OccName space' name {- | Other names in the compiler add additional information to an OccName. @@ -793,6 +804,10 @@ then Nothing else Just m +sizeOccEnv :: OccEnv a -> Int +sizeOccEnv (MkOccEnv as) = + nonDetStrictFoldUFM (\ m !acc -> acc + sizeUFM m) 0 as + instance Outputable a => Outputable (OccEnv a) where ppr x = pprOccEnv ppr x @@ -817,7 +832,7 @@ -------------------------------------------------------------------------------- -type OccSet = FastStringEnv (UniqSet NameSpace) +newtype OccSet = OccSet (FastStringEnv (UniqSet NameSpace)) emptyOccSet :: OccSet unitOccSet :: OccName -> OccSet @@ -829,15 +844,15 @@ elemOccSet :: OccName -> OccSet -> Bool isEmptyOccSet :: OccSet -> Bool -emptyOccSet = emptyFsEnv -unitOccSet (OccName ns s) = unitFsEnv s (unitUniqSet ns) +emptyOccSet = OccSet emptyFsEnv +unitOccSet (OccName ns s) = OccSet $ unitFsEnv s (unitUniqSet ns) mkOccSet = extendOccSetList emptyOccSet -extendOccSet occs (OccName ns s) = extendFsEnv occs s (unitUniqSet ns) -extendOccSetList = foldl extendOccSet -unionOccSets = plusFsEnv_C unionUniqSets +extendOccSet (OccSet occs) (OccName ns s) = OccSet $ extendFsEnv occs s (unitUniqSet ns) +extendOccSetList = foldl' extendOccSet +unionOccSets (OccSet xs) (OccSet ys) = OccSet $ plusFsEnv_C unionUniqSets xs ys unionManyOccSets = foldl' unionOccSets emptyOccSet -elemOccSet (OccName ns s) occs = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s -isEmptyOccSet = isNullUFM +elemOccSet (OccName ns s) (OccSet occs) = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s +isEmptyOccSet (OccSet occs) = isNullUFM occs {- ************************************************************************ @@ -912,6 +927,9 @@ '_':_ -> True _ -> False +isUnderscore :: OccName -> Bool +isUnderscore occ = occNameFS occ == fsLit "_" + {- ************************************************************************ * * @@ -1140,7 +1158,7 @@ Note [TidyOccEnv] ~~~~~~~~~~~~~~~~~ -type TidyOccEnv = UniqFM Int +type TidyOccEnv = UniqFM FastString Int * Domain = The OccName's FastString. These FastStrings are "taken"; make sure that we don't re-use @@ -1195,8 +1213,16 @@ To achieve this, the function avoidClashesOccEnv can be used to prepare the TidyEnv, by “blocking” every name that occurs twice in the map. This way, none of the "a"s will get the privilege of keeping this name, and all of them will -get a suitable number by tidyOccName. +get a suitable number by tidyOccName. Thus + avoidNameClashesOccEnv ["a" :-> 7] ["b", "a", "c", "b", "a"] + = ["a" :-> 7, "b" :-> 1] + +Here +* "a" is already the TidyOccEnv, and so is unaffected +* "b" occurs twice, so is blocked by adding "b" :-> 1 +* "c" occurs only once, and so is not affected. + This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs for an example where this is used. @@ -1215,8 +1241,8 @@ where add env (OccName _ fs) = addToUFM env fs 1 -delTidyOccEnvList :: TidyOccEnv -> [FastString] -> TidyOccEnv -delTidyOccEnvList = delListFromUFM +delTidyOccEnvList :: TidyOccEnv -> [OccName] -> TidyOccEnv +delTidyOccEnvList env occs = env `delListFromUFM` map occNameFS occs -- see Note [Tidying multiple names at once] avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv @@ -1260,6 +1286,16 @@ -- If they are the same (n==1), the former wins -- See Note [TidyOccEnv] +trimTidyOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +-- Restrict the env to just the [OccName] +trimTidyOccEnv env vs + = foldl' add emptyUFM vs + where + add :: TidyOccEnv -> OccName -> TidyOccEnv + add so_far (OccName _ fs) + = case lookupUFM env fs of + Just n -> addToUFM so_far fs n + Nothing -> so_far {- ************************************************************************ diff --git a/GHC/Types/Name/Ppr.hs b/GHC/Types/Name/Ppr.hs --- a/GHC/Types/Name/Ppr.hs +++ b/GHC/Types/Name/Ppr.hs @@ -13,6 +13,7 @@ import GHC.Unit import GHC.Unit.Env +import qualified GHC.Unit.Home.Graph as HUG import GHC.Types.Name import GHC.Types.Name.Reader @@ -72,65 +73,74 @@ mkNamePprCtx ptc unit_env env = QueryQualify (mkQualName env) - (mkQualModule unit_state home_unit) + (mkQualModule unit_state unit_env) (mkQualPackage unit_state) (mkPromTick ptc env) where - unit_state = ue_units unit_env - home_unit = ue_homeUnit unit_env + unit_state = ue_homeUnitState unit_env mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName mkQualName env = qual_name where - qual_name mod occ - | [gre] <- unqual_gres - , right_name gre - = NameUnqual -- If there's a unique entity that's in scope - -- unqualified with 'occ' AND that entity is - -- the right one, then we can use the unqualified name + qual_name mod user_qual occ - | [] <- unqual_gres - , pretendNameIsInScopeForPpr - , not (isDerivedOccName occ) - = NameUnqual -- See Note [pretendNameIsInScopeForPpr] + -- Use the user-written qualification, if that's unambiguous. + | Just qual <- user_qual + , let user_rdr = mkRdrQual qual occ + , [gre] <- lookupGRE env $ LookupRdrName user_rdr SameNameSpace + , right_name gre + = NameQual qual - | [gre] <- qual_gres - = NameQual (greQualModName gre) + -- If there's a GRE that's in scope + -- unqualified with 'occ' AND that entity is + -- the right one, then use the unqualified name + | [gre] <- unqual_gres + , right_name gre + = NameUnqual - | null qual_gres - = if null $ lookupGRE env $ - LookupRdrName (mkRdrQual (moduleName mod) occ) SameNameSpace - then NameNotInScope1 - else NameNotInScope2 + | [] <- unqual_gres + , pretendNameIsInScopeForPpr + , not (isDerivedOccName occ) + = NameUnqual -- See Note [pretendNameIsInScopeForPpr] - | otherwise - = NameNotInScope1 -- Can happen if 'f' is bound twice in the module - -- Eg f = True; g = 0; f = False - where - is_name :: Name -> Bool - is_name name = assertPpr (isExternalName name) (ppr name) $ - nameModule name == mod && nameOccName name == occ + | [gre] <- qual_gres + = NameQual (greQualModName gre) - -- See Note [pretendNameIsInScopeForPpr] - pretendNameIsInScopeForPpr :: Bool - pretendNameIsInScopeForPpr = - any is_name - [ liftedTypeKindTyConName - , constraintKindTyConName - , heqTyConName - , coercibleTyConName - , eqTyConName - , tYPETyConName - , fUNTyConName, unrestrictedFunTyConName - , oneDataConName - , listTyConName - , manyDataConName ] - || isJust (isTupleTyOcc_maybe mod occ) + | null qual_gres + = if null $ lookupGRE env $ + LookupRdrName (mkRdrQual (moduleName mod) occ) SameNameSpace + then NameNotInScope1 + else NameNotInScope2 - right_name gre = greDefinitionModule gre == Just mod + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + is_name :: Name -> Bool + is_name name = assertPpr (isExternalName name) (ppr name) $ + nameModule name == mod && nameOccName name == occ - unqual_gres = lookupGRE env (LookupRdrName (mkRdrUnqual occ) SameNameSpace) - qual_gres = filter right_name (lookupGRE env (LookupOccName occ SameNameSpace)) + -- See Note [pretendNameIsInScopeForPpr] + pretendNameIsInScopeForPpr :: Bool + pretendNameIsInScopeForPpr = + any is_name + [ liftedTypeKindTyConName + , constraintKindTyConName + , heqTyConName + , coercibleTyConName + , eqTyConName + , tYPETyConName + , fUNTyConName, unrestrictedFunTyConName + , oneDataConName + , listTyConName + , manyDataConName + , soloDataConName ] + || isJust (isTupleTyOrigName_maybe mod occ) + || isJust (isSumTyOrigName_maybe mod occ) + right_name gre = greDefinitionModule gre == Just mod + unqual_gres = lookupGRE env (LookupRdrName (mkRdrUnqual occ) SameNameSpace) + qual_gres = filter right_name (lookupGRE env (LookupOccName occ SameNameSpace)) + -- we can mention a module P:M without the P: qualifier iff -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). @@ -205,10 +215,12 @@ -- | Creates a function for formatting modules based on two heuristics: -- (1) if the module is the current module, don't qualify, and (2) if there -- is only one exposed package which exports this module, don't qualify. -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule -mkQualModule unit_state mhome_unit mod - | Just home_unit <- mhome_unit - , isHomeModule home_unit mod = False +mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule +mkQualModule unit_state unitEnv mod + -- Check whether the unit of the module is in the HomeUnitGraph. + -- If it is, then we consider this 'mod' to be "local" and don't + -- want to qualify it. + | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False | [(_, pkgconfig)] <- lookup, mkUnit pkgconfig == moduleUnit mod diff --git a/GHC/Types/Name/Reader.hs b/GHC/Types/Name/Reader.hs --- a/GHC/Types/Name/Reader.hs +++ b/GHC/Types/Name/Reader.hs @@ -5,6 +5,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -37,10 +38,15 @@ nameRdrName, getRdrName, -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, demoteRdrNameTv, promoteRdrName, + rdrNameOcc, rdrNameSpace, + demoteRdrName, demoteRdrNameTcCls, demoteRdrNameTv, + promoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + -- ** Preserving user-written qualification + WithUserRdr(..), noUserRdr, unLocWithUserRdr, userRdrName, + -- * Local mapping of 'RdrName' to 'Name.Name' LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, lookupLocalRdrEnv, lookupLocalRdrOcc, @@ -51,7 +57,7 @@ GlobalRdrEnvX, GlobalRdrEnv, IfGlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, extendGlobalRdrEnv, greOccName, - pprGlobalRdrEnv, globalRdrEnvElts, + pprGlobalRdrEnv, globalRdrEnvElts, globalRdrEnvLocal, -- ** Looking up 'GlobalRdrElt's FieldsOrSelectors(..), filterFieldGREs, allowGRE, @@ -59,12 +65,11 @@ LookupGRE(..), lookupGRE, WhichGREs(.., AllRelevantGREs, RelevantGREsFOS), greIsRelevant, - LookupChild(..), lookupGRE_Name, lookupGRE_FieldLabel, getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, + transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE, -- * GlobalRdrElts availFromGRE, @@ -85,7 +90,7 @@ pprNameProvenance, mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE, mkLocalConLikeGRE, mkLocalFieldGREs, - gresToNameSet, + gresToNameSet, greLevels, -- ** Shadowing greClashesWith, shadowNames, @@ -98,13 +103,15 @@ fieldGRE_maybe, fieldGRELabel, -- ** Parent information - Parent(..), greParent_maybe, + Parent(..), ParentGRE(..), greParent_maybe, mkParent, availParent, ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport, + importSpecLoc, importSpecModule, importSpecLevel, isExplicitItem, bestImport, + ImportLevel(..), -- * Utils - opIsAt + opIsAt, + ) where import GHC.Prelude @@ -119,22 +126,25 @@ import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env - ( NameEnv, nonDetNameEnvElts, emptyNameEnv, extendNameEnv_Acc ) import GHC.Types.Name.Set +import GHC.Types.PkgQual import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Builtin.Uniques ( isFldNSUnique ) +import GHC.Types.ThLevelIndex +import qualified Data.Set as Set import GHC.Unit.Module import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Binary import Control.DeepSeq -import Control.Monad ( guard ) +import Control.Monad ( guard , (>=>) ) import Data.Data import Data.List ( sort ) import qualified Data.List.NonEmpty as NE @@ -162,14 +172,6 @@ -- > `bar` -- > ( ~ ) -- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', --- 'GHC.Parser.Annotation.AnnOpen' @'('@ or @'['@ or @'[:'@, --- 'GHC.Parser.Annotation.AnnClose' @')'@ or @']'@ or @':]'@,, --- 'GHC.Parser.Annotation.AnnBackquote' @'`'@, --- 'GHC.Parser.Annotation.AnnVal' --- 'GHC.Parser.Annotation.AnnTilde', - --- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" data RdrName = Unqual OccName -- ^ Unqualified name @@ -229,7 +231,9 @@ rdrNameSpace :: RdrName -> NameSpace rdrNameSpace = occNameSpace . rdrNameOcc --- demoteRdrName lowers the NameSpace of RdrName. +-- | 'demoteRdrName' attempts to lowers the 'NameSpace' of a 'RdrName' +-- to the term-level. +-- -- See Note [Demotion] in GHC.Rename.Env demoteRdrName :: RdrName -> Maybe RdrName demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) @@ -237,6 +241,12 @@ demoteRdrName (Orig _ _) = Nothing demoteRdrName (Exact _) = Nothing +demoteRdrNameTcCls :: RdrName -> Maybe RdrName +demoteRdrNameTcCls (Unqual occ) = fmap Unqual (demoteOccTcClsName occ) +demoteRdrNameTcCls (Qual m occ) = fmap (Qual m) (demoteOccTcClsName occ) +demoteRdrNameTcCls (Orig _ _) = Nothing +demoteRdrNameTcCls (Exact _) = Nothing + demoteRdrNameTv :: RdrName -> Maybe RdrName demoteRdrNameTv (Unqual occ) = fmap Unqual (demoteOccTvName occ) demoteRdrNameTv (Qual m occ) = fmap (Qual m) (demoteOccTvName occ) @@ -342,7 +352,7 @@ ppr (Exact name) = ppr name ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod Nothing occ <> ppr occ) instance OutputableBndr RdrName where pprBndr _ n @@ -463,6 +473,14 @@ = Just name | otherwise + -- As per the Haskell report (www.haskell.org/onlinereport/haskell2010/haskellch5.html#x11-980005), + -- qualified names can only refer to: + -- + -- - imported names, or + -- - top-level declarations in the current module. + -- + -- Thus, looking up in the LocalRdrEnv using a Qual or Orig RdrName will + -- always fail. = Nothing lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name @@ -623,6 +641,11 @@ greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info +greLevels :: GlobalRdrEltX info -> Set.Set ImportLevel +greLevels g = + if gre_lcl g then Set.singleton NormalLevel + else Set.fromList (bagToList (fmap (is_level . is_decl) (gre_imp g))) + -- | See Note [Parents] data Parent = NoParent | ParentIs { par_is :: !Name } @@ -803,13 +826,13 @@ , recFieldCons = fl_cons } ] where -- We are given a map taking a constructor to its fields, but we want - -- a map taking a field to the contructors which have it. + -- a map taking a field to the constructors which have it. -- We thus need to convert [(Con, [Field])] into [(Field, [Con])]. flds = Map.toList $ Map.fromListWith unionUniqSets [ (S.Arg (flSelector fl) fl, unitUniqSet con) | (con, con_info) <- cons - , ConHasRecordFields fls <- [con_info] + , ConInfo _ (ConHasRecordFields fls) <- [con_info] , fl <- NE.toList fls ] instance HasOccName (GlobalRdrEltX info) where @@ -936,6 +959,9 @@ globalRdrEnvElts :: GlobalRdrEnvX info -> [GlobalRdrEltX info] globalRdrEnvElts env = nonDetFoldOccEnv (++) [] env +globalRdrEnvLocal :: GlobalRdrEnvX info -> GlobalRdrEnvX info +globalRdrEnvLocal = mapOccEnv (filter isLocalGRE) + -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. @@ -1099,6 +1125,23 @@ allowGRE WantField gre = isRecFldGRE gre +-- | A parent of a child, in contexts like import/export lists, class and +-- instance declarations, etc. +-- +-- Not simply a 'GlobalRdrElt', because we don't always have a full +-- 'GlobalRdrElt' to hand (e.g. in 'GHC.Rename.Env.lookupInstDeclBndr'). +data ParentGRE + = ParentGRE + { parentGRE_name :: Name + , parentGRE_info :: GREInfo + } + +instance Outputable ParentGRE where + ppr (ParentGRE name info) = ppr name <+> parens (ppr info) + +instance Eq ParentGRE where + ParentGRE name1 _ == ParentGRE name2 _ = name1 == name2 + -- | What should we look up in a 'GlobalRdrEnv'? Should we only look up -- names with the exact same 'OccName', or do we allow different 'NameSpace's? -- @@ -1139,11 +1182,9 @@ -- | Look up children 'GlobalRdrElt's with a given 'Parent'. LookupChildren - :: OccName -- ^ the 'OccName' to look up - -> LookupChild - -- ^ information to decide which 'GlobalRdrElt's - -- are valid children after looking up - -> LookupGRE info + :: ParentGRE -- ^ the parent + -> OccName -- ^ the child 'OccName' to look up + -> LookupGRE GREInfo -- | How should we look up in a 'GlobalRdrEnv'? -- Which 'NameSpace's are considered relevant for a given lookup? @@ -1198,33 +1239,6 @@ , lookupVariablesForFields = fos == WantBoth , lookupTyConsAsWell = False } -data LookupChild - = LookupChild - { wantedParent :: Name - -- ^ the parent we are looking up children of - , lookupDataConFirst :: Bool - -- ^ for type constructors, should we look in the data constructor - -- namespace first? - , prioritiseParent :: Bool - -- ^ should we prioritise getting the right 'Parent'? - -- - -- - @True@: prioritise getting the right 'Parent' - -- - @False@: prioritise getting the right 'NameSpace' - -- - -- See Note [childGREPriority]. - } - -instance Outputable LookupChild where - ppr (LookupChild { wantedParent = par - , lookupDataConFirst = dc - , prioritiseParent = prio_parent }) - = braces $ hsep - [ text "LookupChild" - , braces (text "parent:" <+> ppr par) - , if dc then text "[dc_first]" else empty - , if prio_parent then text "[prio_parent]" else empty - ] - -- | After looking up something with the given 'NameSpace', is the resulting -- 'GlobalRdrElt' we have obtained relevant, according to the 'RelevantGREs' -- specification of which 'NameSpace's are relevant? @@ -1273,69 +1287,64 @@ class C a where { type (+++) :: a -> a ->; infixl 6 +++ } (+++) :: Int -> Int -> Int; (+++) = (+) -In these two situations, there are two competing metrics for finding the "best" +In these two situations, there are two metrics for finding the "best" 'GlobalRdrElt' that a particular 'OccName' resolves to: - does the resolved 'GlobalRdrElt' have the correct parent? - does the resolved 'GlobalRdrElt' have the same 'NameSpace' as the 'OccName'? -(A) and (B) have competing requirements. - -For the example of (A) above, we know that the child 'D' of 'T' must live -in the data namespace, so we look up the OccName 'OccName DataName "D"' and -prioritise the lookup results based on the 'NameSpace'. -This means we get an error message of the form: - - The type constructor 'T' is not the parent of the data constructor 'D'. - -as opposed to the rather unhelpful and confusing: - - The type constructor 'T' is not the parent of the type constructor 'D'. - -See test case T11970. +To resolve a children export item, we proceed by first prioritising GREs which +have the correct parent, and then break ties by looking at 'NameSpace's. -For the example of (B) above, the fixity declaration for +++ lies inside the -class, so we should prioritise looking up 'GlobalRdrElt's whose parent is 'C'. -Not doing so led to #23664. +Test cases: + - T11970: pattern synonyms, classes etc + - T10816, T23664, T24037: fixity declarations for associated types + - T20427: promoted data constructors and TypeData -} -- | Scoring priority function for looking up children 'GlobalRdrElt'. -- --- We score by 'Parent' and 'NameSpace', with higher priorities having lower --- numbers. Which lexicographic order we use ('Parent' or 'NameSpace' first) --- is determined by the first argument; see Note [childGREPriority]. -childGREPriority :: LookupChild -- ^ what kind of child do we want, - -- e.g. what should its parent be? - -> NameSpace -- ^ what 'NameSpace' are we originally looking in? - -> GlobalRdrEltX info - -- ^ the result of looking up; it might be in a different - -- 'NameSpace', which is used to determine the score - -- (in the first component) +-- The returned score orders by 'Parent' first and then by 'NameSpace', +-- with higher priorities having lower numbers. +-- +-- See Note [childGREPriority]. +childGREPriority :: ParentGRE -- ^ wanted parent + -> NameSpace -- ^ what 'NameSpace' are we originally looking in? + -> GlobalRdrElt + -- ^ the result of looking up; it might be in a different + -- 'NameSpace', which is used to determine the score + -- (in the second component) -> Maybe (Int, Int) -childGREPriority (LookupChild { wantedParent = wanted_parent - , lookupDataConFirst = try_dc_first - , prioritiseParent = par_first }) - ns gre = - case child_ns_prio $ greNameSpace gre of - Nothing -> Nothing - Just ns_prio -> - let par_prio = parent_prio $ greParent gre - in Just $ if par_first - then (par_prio, ns_prio) - else (ns_prio, par_prio) - -- See Note [childGREPriority]. +childGREPriority (ParentGRE wanted_parent parent_info) wanted_ns child_gre = + (parent_prio, ) <$> child_ns_prio where + child_ns = greNameSpace child_gre + + -- Is the parent a class? Only class TyCons can have children that + -- are in the TcCls NameSpace (associated types). + is_class_parent = + case parent_info of + IAmTyCon ClassFlavour -> True + _ -> False + -- Pick out the possible 'NameSpace's in order of priority. - child_ns_prio :: (NameSpace -> Maybe Int) - child_ns_prio other_ns - | other_ns == ns + child_ns_prio :: Maybe Int + child_ns_prio + | child_ns == wanted_ns + + -- Is it OK to have a child in this NameSpace? + -- + -- If it's in the TcCls NameSpace, then the parent must be a class, + -- unless the child is a promoted data constructor (which can happen + -- when exporting a TypeData declaration, see T20427). + , not (isTcClsNameSpace child_ns) || is_class_parent || child_is_data = Just 0 - | isTermVarOrFieldNameSpace ns - , isTermVarOrFieldNameSpace other_ns + | isTermVarOrFieldNameSpace wanted_ns + , isTermVarOrFieldNameSpace child_ns = Just 0 - | isValNameSpace varName - , other_ns == tcName + | isValNameSpace wanted_ns + , is_class_parent && isTcClsNameSpace child_ns -- When looking up children, we sometimes want a value name -- to resolve to a type constructor. -- For example, for an infix declaration "infixr 3 +!" or "infix 2 `Fun`" @@ -1345,19 +1354,49 @@ -- NameSpace, and "Fun" would be in the term-level data constructor -- NameSpace. See tests T10816, T23664, T24037. = Just 1 - | ns == tcName - , other_ns == dataName - , try_dc_first -- try data namespace before type/class namespace? - = Just (-1) + | wanted_ns == tcName + , child_is_data + = Just $ + -- For classes we de-prioritise data constructors; + -- otherwise we prioritise them. + if is_class_parent + then 1 + else -1 | otherwise = Nothing - parent_prio :: Parent -> Int - parent_prio (ParentIs other_parent) - | other_parent == wanted_parent = 0 - | otherwise = 1 - parent_prio NoParent = 0 + parent_prio :: Int + parent_prio = + case greParent child_gre of + ParentIs other_parent + | other_parent == wanted_parent + -> 0 + | otherwise + -- The parent is wrong, so give this a low priority. + -- Don't return 'Nothing': if there are no other options, this + -- allows us to report an incorrect parent to the user, as opposed + -- to an out-of-scope error. + -> 1 + NoParent -> + -- Higher priority than having the wrong parent entirely, + -- but same priority as having the right parent. Why? See T25892: + -- + -- module M1 where + -- data D = K + -- module M2 (D(M2.K)) where + -- import qualified M1 + -- pattern K = M1.K + -- + -- Here, we do not want the data constructor M1.K to take priority + -- over the pattern synonym M2.K that we are trying to bundle. + 0 + child_is_data = + case greInfo child_gre of + IAmConLike{} -> True + IAmTyCon PromotedDataConFlavour -> True + _ -> child_ns == dataName + -- | Look something up in the Global Reader Environment. -- -- The 'LookupGRE' argument specifies what to look up, and in particular @@ -1381,10 +1420,10 @@ occ = nameOccName nm lkup | all_ns = concat $ lookupOccEnv_AllNameSpaces env occ | otherwise = fromMaybe [] $ lookupOccEnv env occ - LookupChildren occ which_child -> - let ns = occNameSpace occ - all_gres = concat $ lookupOccEnv_AllNameSpaces env occ - in highestPriorityGREs (childGREPriority which_child ns) all_gres + LookupChildren parent child_occ -> + let ns = occNameSpace child_occ + all_gres = concat $ lookupOccEnv_AllNameSpaces env child_occ + in highestPriorityGREs (childGREPriority parent ns) all_gres -- | Collect the 'GlobalRdrElt's with the highest priority according -- to the given function (lower value <=> higher priority). @@ -1565,8 +1604,15 @@ -- -- Used only for the 'module M' item in export list; -- see 'GHC.Tc.Gen.Export.exports_from_avail' -pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres +-- This function also only chooses GREs which are at level zero. +pickGREsModExp mod gres = mapMaybe (pickLevelZeroGRE >=> pickBothGRE mod) gres +pickLevelZeroGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickLevelZeroGRE gre = + if NormalLevel `Set.member` greLevels gre + then Just gre + else Nothing + -- | isBuiltInSyntax filter out names for built-in syntax They -- just clutter up the environment (esp tuples), and the -- parser will generate Exact RdrNames for them, so the @@ -1780,7 +1826,10 @@ old_mod_name = moduleName old_mod id_spec = ImpDeclSpec { is_mod = old_mod , is_as = old_mod_name + , is_pkg_qual = NoPkgQual , is_qual = True + , is_level = NormalLevel -- MP: Not 100% sure this is correct + , is_isboot = NotBoot , is_dloc = greDefinitionSrcSpan old_gre } set_qual :: ImportSpec -> ImportSpec @@ -1939,10 +1988,37 @@ -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_pkg_qual :: !PkgQual, -- ^ Was this a package import? is_qual :: !Bool, -- ^ Was this import qualified? - is_dloc :: !SrcSpan -- ^ The location of the entire import declaration + is_dloc :: !SrcSpan, -- ^ The location of the entire import declaration + is_isboot :: !IsBootInterface, -- ^ Was this a SOURCE import? + is_level :: !ImportLevel -- ^ Was this import level modified? splice/quote +-1 } deriving (Eq, Data) + + +instance NFData ImpDeclSpec where + rnf = rwhnf -- Already strict in all fields + + +instance Binary ImpDeclSpec where + put_ bh (ImpDeclSpec mod as pkg_qual qual _dloc isboot isstage) = do + put_ bh mod + put_ bh as + put_ bh pkg_qual + put_ bh qual + put_ bh isboot + put_ bh (fromEnum isstage) + + get bh = do + mod <- get bh + as <- get bh + pkg_qual <- get bh + qual <- get bh + isboot <- get bh + isstage <- toEnum <$> get bh + return (ImpDeclSpec mod as pkg_qual qual noSrcSpan isboot isstage) + -- | Import Item Specification -- -- Describes import info a particular Name @@ -2055,6 +2131,9 @@ importSpecModule :: ImportSpec -> ModuleName importSpecModule = moduleName . is_mod . is_decl +importSpecLevel :: ImportSpec -> ImportLevel +importSpecLevel = is_level . is_decl + isExplicitItem :: ImpItemSpec -> Bool isExplicitItem ImpAll = False isExplicitItem (ImpSome {is_explicit = exp}) = exp @@ -2092,11 +2171,18 @@ ppr imp_spec = text "imported" <+> qual <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) + <+> level_ppr <+> pprLoc (importSpecLoc imp_spec) where qual | is_qual (is_decl imp_spec) = text "qualified" | otherwise = empty + level = thLevelIndexFromImportLevel (is_level (is_decl imp_spec)) + level_ppr + | level == topLevelIndex = empty + | otherwise = text "at" <+> ppr level + + pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty @@ -2104,3 +2190,42 @@ -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool opIsAt e = e == mkUnqual varName (fsLit "@") + + +-------------------------------------------------------------------------------- +-- Preserving user-written qualification + +-- | 'WithUserRdr' allows us to keep track of the original user-written +-- 'RdrName', and in particular, any user-written module qualification. +-- +-- See Note [IdOcc] in Language.Haskell.Syntax.Extension. +data WithUserRdr a = WithUserRdr RdrName a + deriving stock (Functor, Foldable, Traversable) + +instance NamedThing a => NamedThing (WithUserRdr a) where + getName (WithUserRdr _rdr a) = getName a +instance Outputable (WithUserRdr Name) where + ppr (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name +instance OutputableBndr (WithUserRdr Name) where + pprBndr _ (WithUserRdr rdr name) = + pprName_userQual (rdrQual_maybe rdr) name + pprInfixOcc :: WithUserRdr Name -> SDoc + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +unLocWithUserRdr :: GenLocated l (WithUserRdr a) -> a +unLocWithUserRdr (L _ (WithUserRdr _ a)) = a + +noUserRdr :: Name -> WithUserRdr Name +noUserRdr n = WithUserRdr (nameRdrName n) n + +userRdrName :: WithUserRdr Name -> RdrName +userRdrName (WithUserRdr rdr _) = rdr + +rdrQual_maybe :: RdrName -> Maybe ModuleName +rdrQual_maybe = \case + Qual q _ -> Just q + _ -> Nothing + +-------------------------------------------------------------------------------- diff --git a/GHC/Types/Name/Set.hs b/GHC/Types/Name/Set.hs --- a/GHC/Types/Name/Set.hs +++ b/GHC/Types/Name/Set.hs @@ -22,7 +22,7 @@ -- ** Manipulating sets of free variables isEmptyFVs, emptyFVs, plusFVs, plusFV, mkFVs, addOneFV, unitFV, delFV, delFVs, - intersectFVs, + intersectFVs, intersectsFVs, -- * Defs and uses Defs, Uses, DefUse, DefUses, @@ -127,6 +127,7 @@ delFV :: Name -> FreeVars -> FreeVars delFVs :: [Name] -> FreeVars -> FreeVars intersectFVs :: FreeVars -> FreeVars -> FreeVars +intersectsFVs :: FreeVars -> FreeVars -> Bool isEmptyFVs :: NameSet -> Bool isEmptyFVs = isEmptyNameSet @@ -139,6 +140,7 @@ delFV n s = delFromNameSet s n delFVs ns s = delListFromNameSet s ns intersectFVs = intersectNameSet +intersectsFVs = intersectsNameSet {- ************************************************************************ diff --git a/GHC/Types/PkgQual.hs b/GHC/Types/PkgQual.hs --- a/GHC/Types/PkgQual.hs +++ b/GHC/Types/PkgQual.hs @@ -6,6 +6,7 @@ import GHC.Prelude import GHC.Types.SourceText import GHC.Unit.Types +import GHC.Utils.Binary import GHC.Utils.Outputable import Data.Data @@ -22,8 +23,8 @@ -- package qualifier. data PkgQual = NoPkgQual -- ^ No package qualifier - | ThisPkg UnitId -- ^ Import from home-unit - | OtherPkg UnitId -- ^ Import from another unit + | ThisPkg !UnitId -- ^ Import from home-unit + | OtherPkg !UnitId -- ^ Import from another unit deriving (Data, Ord, Eq) instance Outputable RawPkgQual where @@ -38,4 +39,21 @@ ThisPkg u -> doubleQuotes (ppr u) OtherPkg u -> doubleQuotes (ppr u) +instance Binary PkgQual where + put_ bh NoPkgQual = putByte bh 0 + put_ bh (ThisPkg u) = do + putByte bh 1 + put_ bh u + put_ bh (OtherPkg u) = do + putByte bh 2 + put_ bh u + get bh = do + tag <- getByte bh + case tag of + 0 -> return NoPkgQual + 1 -> do u <- get bh + return (ThisPkg u) + 2 -> do u <- get bh + return (OtherPkg u) + _ -> fail "instance Binary PkgQual: Invalid tag" diff --git a/GHC/Types/ProfAuto.hs b/GHC/Types/ProfAuto.hs --- a/GHC/Types/ProfAuto.hs +++ b/GHC/Types/ProfAuto.hs @@ -12,4 +12,4 @@ | ProfAutoTop -- ^ top-level functions annotated only | ProfAutoExports -- ^ exported functions annotated only | ProfAutoCalls -- ^ annotate call-sites - deriving (Eq,Enum) + deriving (Eq,Enum, Show) diff --git a/GHC/Types/RepType.hs b/GHC/Types/RepType.hs --- a/GHC/Types/RepType.hs +++ b/GHC/Types/RepType.hs @@ -4,22 +4,22 @@ module GHC.Types.RepType ( -- * Code generator views onto Types - UnaryType, NvUnaryType, isNvUnaryType, + UnaryType, NvUnaryType, isNvUnaryRep, unwrapType, -- * Predicates on types isZeroBitTy, -- * Type representation for the code generator - typePrimRep, typePrimRep1, - runtimeRepPrimRep, typePrimRepArgs, + typePrimRep, typePrimRep1, typePrimRepU, + runtimeRepPrimRep, PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, - tyConPrimRep, tyConPrimRep1, + tyConPrimRep, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, -- * Unboxed sum representation type - ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), + ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..), slotPrimRep, primRepSlot, -- * Is this type known to be data? @@ -38,7 +38,7 @@ import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind , vecRepDataConTyCon - , liftedRepTy, unliftedRepTy, zeroBitRepTy + , liftedRepTy, unliftedRepTy , intRepDataConTy , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy , wordRepDataConTy @@ -76,21 +76,9 @@ -- UnaryType : never an unboxed tuple or sum; -- can be Void# or (# #) -isNvUnaryType :: Type -> Bool -isNvUnaryType ty - | [_] <- typePrimRep ty - = True - | otherwise - = False - --- INVARIANT: the result list is never empty. -typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep -typePrimRepArgs ty - = case reps of - [] -> VoidRep :| [] - (x:xs) -> x :| xs - where - reps = typePrimRep ty +isNvUnaryRep :: [PrimRep] -> Bool +isNvUnaryRep [_] = True +isNvUnaryRep _ = False -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including: @@ -132,7 +120,10 @@ = 0 countFunRepArgs n ty | FunTy _ _ arg res <- unwrapType ty - = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + = (length (typePrimRep arg) `max` 1) + + countFunRepArgs (n - 1) res + -- If typePrimRep returns [] that means a void arg, + -- and we count 1 for that | otherwise = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -163,21 +154,18 @@ go repMarks repTys [] where go (mark:marks) (ty:types) out_marks - -- Zero-width argument, mark is irrelevant at runtime. - | -- pprTrace "VoidTy" (ppr ty) $ - (isZeroBitTy ty) - = go marks types out_marks - -- Single rep argument, e.g. Int - -- Keep mark as-is - | [_] <- reps - = go marks types (mark:out_marks) - -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) - -- Make up one non-strict mark per runtime argument. - | otherwise -- TODO: Assert real_reps /= null - = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks) + = case reps of + -- Zero-width argument, mark is irrelevant at runtime. + [] -> -- pprTrace "VoidTy" (ppr ty) $ + go marks types out_marks + -- Single rep argument, e.g. Int + -- Keep mark as-is + [_] -> go marks types (mark:out_marks) + -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #) + -- Make up one non-strict mark per runtime argument. + _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks) where reps = typePrimRep ty - real_reps = filter (not . isVoidRep) $ reps go [] [] out_marks = reverse out_marks go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) @@ -307,14 +295,13 @@ ppr FloatSlot = text "FloatSlot" ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e -typeSlotTy :: UnaryType -> Maybe SlotTy -typeSlotTy ty = case typePrimRep ty of +repSlotTy :: [PrimRep] -> Maybe SlotTy +repSlotTy reps = case reps of [] -> Nothing [rep] -> Just (primRepSlot rep) - reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps) + _ -> pprPanic "repSlotTy" (ppr reps) primRepSlot :: PrimRep -> SlotTy -primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" Just Lifted -> PtrLiftedSlot @@ -397,8 +384,7 @@ enumerates all the possibilities. data PrimRep - = VoidRep -- See Note [VoidRep] - | LiftedRep -- ^ Lifted pointer + = LiftedRep -- ^ Lifted pointer | UnliftedRep -- ^ Unlifted pointer | Int8Rep -- ^ Signed, 8-bit value | Int16Rep -- ^ Signed, 16-bit value @@ -447,19 +433,38 @@ Note [VoidRep] ~~~~~~~~~~~~~~ -PrimRep contains a constructor VoidRep, while RuntimeRep does -not. Yet representations are often characterised by a list of PrimReps, -where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].) +PrimRep is used to denote one primitive representation. +Because of unboxed tuples and sums, the representation of a value +in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) -However, after the unariser, all identifiers have exactly one PrimRep, but -void arguments still exist. Thus, PrimRep includes VoidRep to describe these -binders. Perhaps post-unariser representations (which need VoidRep) should be -a different type than pre-unariser representations (which use a list and do -not need VoidRep), but we have what we have. +For example: + typePrimRep Int# = [IntRep] + typePrimRep Int = [LiftedRep] + typePrimRep (# Int#, Int# #) = [IntRep,IntRep] + typePrimRep (# #) = [] + typePrimRep (State# s) = [] -RuntimeRep instead uses TupleRep '[] to denote a void argument. When -converting a TupleRep '[] into a list of PrimReps, we get an empty list. +After the unariser, all identifiers have at most one PrimRep +(that is, the [PrimRep] for each identifier is empty or a singleton list). +More precisely: typePrimRep1 will succeed (not crash) on every binder +and argument type. +(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) +Thus, we have + +1. typePrimRep :: Type -> [PrimRep] + which returns the list + +2. typePrimRepU :: Type -> PrimRep + which asserts that the type has exactly one PrimRep and returns it + +3. typePrimRep1 :: Type -> PrimOrVoidRep + data PrimOrVoidRep = VoidRep | NVRep PrimRep + which asserts that the type either has exactly one PrimRep or is void. + +Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1, +which have analogous preconditions. + Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep]. @@ -530,7 +535,7 @@ GHC.Builtin.Types and its helper function mk_runtime_rep_dc.) Example 2 passes the promoted list as the one argument to the extracted function. The extracted function is defined as prim_rep_fun within tupleRepDataCon in GHC.Builtin.Types. It takes one argument, decomposes -the promoted list (with extractPromotedList), and then recurs back to runtimeRepPrimRep +the promoted list (with extractPromotedList), and then recurses back to runtimeRepPrimRep to process the LiftedRep and WordRep, concatenating the results. -} @@ -552,17 +557,22 @@ typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep] -typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of [] -> VoidRep - [rep] -> rep + [rep] -> NVRep rep _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep +typePrimRepU ty = case typePrimRep ty of + [rep] -> rep + _ -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty)) + -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -573,15 +583,6 @@ where res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or --- one 'PrimRep' output --- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep] -tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep -tyConPrimRep1 tc = case tyConPrimRep tc of - [] -> VoidRep - [rep] -> rep - _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) - -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] @@ -609,8 +610,6 @@ -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation. --- --- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -623,8 +622,7 @@ -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. --- The @[PrimRep]@ is the final runtime representation /after/ unarisation --- and does not contain VoidRep. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] @@ -640,7 +638,6 @@ -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy BoxedRep mlev -> case mlev of Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" Just Lifted -> liftedRepTy @@ -696,9 +693,12 @@ -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty + -- Currently ghc has no unlifted functions. + | definitelyUnliftedType ty + = False | [BoxedRep _] <- typePrimRep ty , Just tc <- tyConAppTyCon_maybe (unwrapType ty) - , isDataTyCon tc + , isBoxedDataTyCon tc = False | otherwise = True diff --git a/GHC/Types/SafeHaskell.hs b/GHC/Types/SafeHaskell.hs --- a/GHC/Types/SafeHaskell.hs +++ b/GHC/Types/SafeHaskell.hs @@ -14,6 +14,7 @@ import GHC.Utils.Binary import GHC.Utils.Outputable +import Control.DeepSeq import Data.Word @@ -31,6 +32,15 @@ | Sf_Ignore -- ^ @-fno-safe-haskell@ state deriving (Eq) +instance NFData SafeHaskellMode where + rnf x = case x of + Sf_None -> () + Sf_Unsafe -> () + Sf_Trustworthy -> () + Sf_Safe -> () + Sf_SafeInferred -> () + Sf_Ignore -> () + instance Show SafeHaskellMode where show Sf_None = "None" show Sf_Unsafe = "Unsafe" @@ -45,6 +55,10 @@ -- | Safe Haskell information for 'ModIface' -- Simply a wrapper around SafeHaskellMode to separate iface and flags newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +instance NFData IfaceTrustInfo where + rnf (TrustInfo shm) = rnf shm + getSafeMode :: IfaceTrustInfo -> SafeHaskellMode getSafeMode (TrustInfo x) = x diff --git a/GHC/Types/SourceFile.hs b/GHC/Types/SourceFile.hs --- a/GHC/Types/SourceFile.hs +++ b/GHC/Types/SourceFile.hs @@ -13,6 +13,7 @@ import GHC.Prelude import GHC.Utils.Binary import GHC.Unit.Types +import Control.DeepSeq {- Note [HscSource types] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -53,6 +54,10 @@ | Hsig -- ^ .hsig file deriving (Eq, Ord, Show) +instance NFData HsBootOrSig where + rnf HsBoot = () + rnf Hsig = () + data HscSource -- | .hs file = HsSrcFile @@ -72,6 +77,10 @@ hscSourceToIsBoot :: HscSource -> IsBootInterface hscSourceToIsBoot HsBootFile = IsBoot hscSourceToIsBoot _ = NotBoot + +instance NFData HscSource where + rnf HsSrcFile = () + rnf (HsBootOrSig h) = rnf h instance Binary HscSource where put_ bh HsSrcFile = putByte bh 0 diff --git a/GHC/Types/SourceText.hs b/GHC/Types/SourceText.hs --- a/GHC/Types/SourceText.hs +++ b/GHC/Types/SourceText.hs @@ -305,21 +305,17 @@ { sl_st :: SourceText, -- literal raw source. -- See Note [Literal source text] sl_fs :: FastString, -- literal string value - sl_tc :: Maybe RealSrcSpan -- Location of + sl_tc :: Maybe NoCommentsLocation + -- Location of -- possible -- trailing comma -- AZ: if we could have a LocatedA -- StringLiteral we would not need sl_tc, but -- that would cause import loops. - - -- AZ:2: sl_tc should be an EpaAnchor, to allow - -- editing and reprinting the AST. Need a more - -- robust solution. - } deriving Data instance Eq StringLiteral where (StringLiteral _ a _) == (StringLiteral _ b _) = a == b instance Outputable StringLiteral where - ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) + ppr sl = pprWithSourceText (sl_st sl) (doubleQuotes $ ftext $ sl_fs sl) diff --git a/GHC/Types/SptEntry.hs b/GHC/Types/SptEntry.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SptEntry.hs @@ -0,0 +1,16 @@ +module GHC.Types.SptEntry + ( SptEntry(..) + ) +where + +import GHC.Types.Var ( Id ) +import GHC.Fingerprint.Type ( Fingerprint ) +import GHC.Utils.Outputable + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + diff --git a/GHC/Types/SrcLoc.hs b/GHC/Types/SrcLoc.hs --- a/GHC/Types/SrcLoc.hs +++ b/GHC/Types/SrcLoc.hs @@ -109,6 +109,10 @@ mkSrcSpanPs, combineRealSrcSpans, psLocatedToLocated, + + -- * Exact print locations + EpaLocation'(..), NoCommentsLocation, NoComments(..), + DeltaPos(..), deltaPos, getDeltaLine, ) where import GHC.Prelude @@ -219,8 +223,9 @@ -- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock -- comments with parts of the AST using location information (#17544). newtype BufPos = BufPos { bufPos :: Int } - deriving (Eq, Ord, Show, Data) + deriving (Eq, Ord, Show, Data, NFData) + -- | Source Location data SrcLoc = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos) -- See Note [Why Maybe BufPos] @@ -369,11 +374,13 @@ } deriving Eq --- | StringBuffer Source Span data BufSpan = BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos } deriving (Eq, Ord, Show, Data) +instance NFData BufSpan where + rnf (BufSpan a1 a2) = rnf a1 `seq` rnf a2 + instance Semigroup BufSpan where BufSpan start1 end1 <> BufSpan start2 end2 = BufSpan (min start1 start2) (max end1 end2) @@ -426,16 +433,29 @@ json (RealSrcSpan rss _) = json rss instance ToJson RealSrcSpan where - json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) - , ("startLine", JSInt srcSpanSLine) - , ("startCol", JSInt srcSpanSCol) - , ("endLine", JSInt srcSpanELine) - , ("endCol", JSInt srcSpanECol) + json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)), + ("start", start), + ("end", end) ] + where start = JSObject [ ("line", JSInt srcSpanSLine), + ("column", JSInt srcSpanSCol) ] + end = JSObject [ ("line", JSInt srcSpanELine), + ("column", JSInt srcSpanECol) ] +instance NFData RealSrcSpan where + rnf (RealSrcSpan' file line col endLine endCol) = rnf file `seq` rnf line `seq` rnf col `seq` rnf endLine `seq` rnf endCol + instance NFData SrcSpan where - rnf x = x `seq` () + rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2 + rnf (UnhelpfulSpan a1) = rnf a1 +instance NFData UnhelpfulSpanReason where + rnf (UnhelpfulNoLocationInfo) = () + rnf (UnhelpfulWiredIn) = () + rnf (UnhelpfulInteractive) = () + rnf (UnhelpfulGenerated) = () + rnf (UnhelpfulOther a1) = rnf a1 + getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan getBufSpan (UnhelpfulSpan _) = Strict.Nothing @@ -892,3 +912,70 @@ mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) + +-- --------------------------------------------------------------------- +-- The following section contains basic types related to exact printing. +-- See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for +-- details. +-- This is only s subset, to prevent import loops. The balance are in +-- GHC.Parser.Annotation +-- --------------------------------------------------------------------- + + +-- | The anchor for an exact print annotation. The Parser inserts the +-- @'EpaSpan'@ variant, giving the exact location of the original item +-- in the parsed source. This can be replaced by the @'EpaDelta'@ +-- version, to provide a position for the item relative to the end of +-- the previous item in the source. This is useful when editing an +-- AST prior to exact printing the changed one. +-- The EpaDelta also contains the original @'SrcSpan'@ for use by +-- tools wanting to manipulate the AST after converting it using +-- ghc-exactprint' @'makeDeltaAst'@. + +data EpaLocation' a = EpaSpan !SrcSpan + | EpaDelta !SrcSpan !DeltaPos !a + deriving (Data,Eq,Show) + +type NoCommentsLocation = EpaLocation' NoComments + +data NoComments = NoComments + deriving (Data,Eq,Ord,Show) + +-- | Spacing between output items when exact printing. It captures +-- the spacing from the current print position on the page to the +-- position required for the thing about to be printed. This is +-- either on the same line in which case is is simply the number of +-- spaces to emit, or it is some number of lines down, with a given +-- column offset. The exact printing algorithm keeps track of the +-- column offset pertaining to the current anchor position, so the +-- `deltaColumn` is the additional spaces to add in this case. See +-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for +-- details. +data DeltaPos + = SameLine { deltaColumn :: !Int } + | DifferentLine + { deltaLine :: !Int, -- ^ deltaLine should always be > 0 + deltaColumn :: !Int + } deriving (Show,Eq,Ord,Data) + +-- | Smart constructor for a 'DeltaPos'. It preserves the invariant +-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0. +deltaPos :: Int -> Int -> DeltaPos +deltaPos l c = case l of + 0 -> SameLine c + _ -> DifferentLine l c + +getDeltaLine :: DeltaPos -> Int +getDeltaLine (SameLine _) = 0 +getDeltaLine (DifferentLine r _) = r + +instance Outputable NoComments where + ppr NoComments = text "NoComments" + +instance (Outputable a) => Outputable (EpaLocation' a) where + ppr (EpaSpan r) = text "EpaSpan" <+> ppr r + ppr (EpaDelta s d cs) = text "EpaDelta" <+> ppr s <+> ppr d <+> ppr cs + +instance Outputable DeltaPos where + ppr (SameLine c) = text "SameLine" <+> ppr c + ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c diff --git a/GHC/Types/ThLevelIndex.hs b/GHC/Types/ThLevelIndex.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ThLevelIndex.hs @@ -0,0 +1,36 @@ +module GHC.Types.ThLevelIndex where + +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Types.Basic ( ImportLevel(..) ) +import Data.Data + +-- | The integer which represents the level +newtype ThLevelIndex = ThLevelIndex Int deriving (Eq, Ord, Data) + -- NB: see Note [Template Haskell levels] in GHC.Tc.Gen.Splice + -- Incremented when going inside a bracket, + -- decremented when going inside a splice + +instance Outputable ThLevelIndex where + ppr (ThLevelIndex i) = int i + +incThLevelIndex :: ThLevelIndex -> ThLevelIndex +incThLevelIndex (ThLevelIndex i) = ThLevelIndex (i + 1) + +decThLevelIndex :: ThLevelIndex -> ThLevelIndex +decThLevelIndex (ThLevelIndex i) = ThLevelIndex (i - 1) + +topLevelIndex :: ThLevelIndex +topLevelIndex = ThLevelIndex 0 + +spliceLevelIndex :: ThLevelIndex +spliceLevelIndex = decThLevelIndex topLevelIndex + +quoteLevelIndex :: ThLevelIndex +quoteLevelIndex = incThLevelIndex topLevelIndex + +-- | Convert a 'GHC.Types.Basic.ImportLevel' to a 'ThLevelIndex' +thLevelIndexFromImportLevel :: ImportLevel -> ThLevelIndex +thLevelIndexFromImportLevel NormalLevel = topLevelIndex +thLevelIndexFromImportLevel SpliceLevel = spliceLevelIndex +thLevelIndexFromImportLevel QuoteLevel = quoteLevelIndex diff --git a/GHC/Types/Tickish.hs b/GHC/Types/Tickish.hs --- a/GHC/Types/Tickish.hs +++ b/GHC/Types/Tickish.hs @@ -21,11 +21,15 @@ isProfTick, TickishPlacement(..), tickishPlace, - tickishContains + tickishContains, + + -- * Breakpoint tick identifiers + BreakpointId(..), BreakTickIndex ) where import GHC.Prelude import GHC.Data.FastString +import Control.DeepSeq import GHC.Core.Type @@ -40,7 +44,7 @@ import Language.Haskell.Syntax.Extension ( NoExtField ) import Data.Data -import GHC.Utils.Outputable (Outputable (ppr), text) +import GHC.Utils.Outputable (Outputable (ppr), text, (<+>)) {- ********************************************************************* * * @@ -106,9 +110,11 @@ -- the user. ProfNote { profNoteCC :: CostCentre, -- ^ the cost centre + profNoteCount :: !Bool, -- ^ bump the entry count? profNoteScope :: !Bool -- ^ scopes over the enclosed expression -- (i.e. not just a tick) + -- Invariant: the False/False case never happens } -- | A "tick" used by HPC to track the execution of each @@ -126,7 +132,7 @@ -- and (b) substituting (don't substitute for them) | Breakpoint { breakpointExt :: XBreakpoint pass - , breakpointId :: !Int + , breakpointId :: !BreakpointId , breakpointFVs :: [XTickishId pass] -- ^ the order of this list is important: -- it matches the order of the lists in the @@ -168,7 +174,36 @@ deriving instance Ord (GenTickish 'TickishPassCmm) deriving instance Data (GenTickish 'TickishPassCmm) +-------------------------------------------------------------------------------- +-- Tick breakpoint index +-------------------------------------------------------------------------------- +-- | Breakpoint tick index +-- newtype BreakTickIndex = BreakTickIndex Int +-- deriving (Eq, Ord, Data, Ix, NFData, Outputable) +type BreakTickIndex = Int + +-- | Breakpoint identifier. +-- +-- Indexes into the structures in the @'ModBreaks'@ created during desugaring +-- (after inserting the breakpoint ticks in the expressions). +-- See Note [Breakpoint identifiers] +data BreakpointId = BreakpointId + { bi_tick_mod :: !Module -- ^ Breakpoint tick module + , bi_tick_index :: !BreakTickIndex -- ^ Breakpoint tick index + } + deriving (Eq, Ord, Data) + +instance Outputable BreakpointId where + ppr BreakpointId{bi_tick_mod, bi_tick_index} = + text "BreakpointId" <+> ppr bi_tick_mod <+> ppr bi_tick_index + +instance NFData BreakpointId where + rnf BreakpointId{bi_tick_mod, bi_tick_index} = + rnf bi_tick_mod `seq` rnf bi_tick_index + +-------------------------------------------------------------------------------- + -- | A "counting tick" (where tickishCounts is True) is one that -- counts evaluations in some way. We cannot discard a counting tick, -- and the compiler should preserve the number of counting ticks as @@ -292,13 +327,15 @@ mkNoCount :: GenTickish pass -> GenTickish pass mkNoCount n | not (tickishCounts n) = n | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" -mkNoCount n@ProfNote{} = n {profNoteCount = False} +mkNoCount n@ProfNote{} = let n' = n {profNoteCount = False} + in assert (profNoteCount n) n' mkNoCount _ = panic "mkNoCount: Undefined split!" mkNoScope :: GenTickish pass -> GenTickish pass mkNoScope n | tickishScoped n == NoScope = n | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" -mkNoScope n@ProfNote{} = n {profNoteScope = False} +mkNoScope n@ProfNote{} = let n' = n {profNoteScope = False} + in assert (profNoteCount n) n' mkNoScope _ = panic "mkNoScope: Undefined split!" -- | Return @True@ if this source annotation compiles to some backend diff --git a/GHC/Types/TyThing.hs b/GHC/Types/TyThing.hs --- a/GHC/Types/TyThing.hs +++ b/GHC/Types/TyThing.hs @@ -125,7 +125,8 @@ IfaceDecl for the data/newtype. Ditto class methods. * Record selectors are *not* implicit, because they get their own - free-standing IfaceDecl. + free-standing IfaceDecl. See Note [Record selectors] in + GHC.Tc.TyCl.Utils. * Associated data/type families are implicit because they are included in the IfaceDecl of the parent class. (NB: the @@ -266,9 +267,9 @@ Just (ATyCon tc) RecSelId { sel_tycon = RecSelPatSyn ps } -> Just (AConLike (PatSynCon ps)) - ClassOpId cls _ -> + ClassOpId cls _ -> Just (ATyCon (classTyCon cls)) - _other -> Nothing + _other -> Nothing tyThingParent_maybe _other = Nothing tyThingsTyCoVars :: [TyThing] -> TyCoVarSet @@ -314,13 +315,13 @@ -- Note [Parents] in GHC.Types.Name.Reader. RealDataCon dc1 -> (ParentIs $ tyConName $ dataConTyCon dc1 - , [ (DataConName $ dataConName $ dc, ConHasRecordFields (fld :| flds)) + , [ (DataConName $ dataConName $ dc, ConInfo conInfo (ConHasRecordFields (fld :| flds))) | dc <- tyConDataCons $ dataConTyCon dc1 -- Go through all the data constructors of the parent TyCon, -- to ensure that all the record fields have the correct set -- of parent data constructors. See #23546. , let con_info = conLikeConInfo (RealDataCon dc) - , ConHasRecordFields flds0 <- [con_info] + , ConInfo conInfo (ConHasRecordFields flds0) <- [con_info] , let flds1 = NE.toList flds0 `intersect` dataConFieldLabels dc , fld:flds <- [flds1] ]) @@ -355,8 +356,8 @@ RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps) RecSelData tc -> let dcs = map RealDataCon $ tyConDataCons tc in - case conLikesWithFields dcs [flLabel fl] of - [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $ + case rsi_def (conLikesRecSelInfo dcs [flLabel fl]) of + [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $ vcat [ text "id:" <+> ppr id , text "fl:" <+> ppr fl , text "dcs:" <+> ppr dcs ] diff --git a/GHC/Types/TyThing/Ppr.hs b/GHC/Types/TyThing/Ppr.hs --- a/GHC/Types/TyThing/Ppr.hs +++ b/GHC/Types/TyThing/Ppr.hs @@ -98,7 +98,7 @@ (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon stores a [IfaceAxBranch] that is used only for pretty-printing. -- See Note [Free tyvars in IfaceType] in GHC.Iface.Type +- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type See #7730, #8776 for details -} @@ -145,17 +145,25 @@ -- parts omitted. pprTyThingInContext :: ShowSub -> TyThing -> SDoc pprTyThingInContext show_sub thing - = go [] thing + = case parents thing of + -- If there are no parents print everything. + [] -> print_it Nothing thing + -- If `thing` has a parent, print the parent and only its child `thing` + thing':rest -> let subs = map getOccName (thing:rest) + filt = (`elem` subs) + in print_it (Just filt) thing' where - go ss thing - = case tyThingParent_maybe thing of - Just parent -> - go (getOccName thing : ss) parent - Nothing -> - pprTyThing - (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) }) - thing + parents = go + where + go thing = + case tyThingParent_maybe thing of + Just parent -> parent : go parent + Nothing -> [] + print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc + print_it mb_filt thing = + pprTyThing (show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) thing + -- | Like 'pprTyThingInContext', but adds the defining location. pprTyThingInContextLoc :: TyThing -> SDoc pprTyThingInContextLoc tyThing @@ -171,8 +179,8 @@ pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing) where ss' = case ss_how_much ss of - ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } - ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' } + ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' } + ShowSome filt (AltPpr Nothing) -> ss { ss_how_much = ShowSome filt ppr' } _ -> ss ppr' = AltPpr $ ppr_bndr $ getName ty_thing @@ -184,7 +192,7 @@ | otherwise = case nameModule_maybe name of Just mod -> Just $ \occ -> getPprStyle $ \sty -> - pprModulePrefix sty mod occ <> ppr occ + pprModulePrefix sty mod Nothing occ <> ppr occ Nothing -> warnPprTrace True "pprTyThing" (ppr name) Nothing -- Nothing is unexpected here; TyThings have External names diff --git a/GHC/Types/Unique.hs b/GHC/Types/Unique.hs --- a/GHC/Types/Unique.hs +++ b/GHC/Types/Unique.hs @@ -18,7 +18,7 @@ -} {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns, MagicHash #-} +{-# LANGUAGE MagicHash #-} module GHC.Types.Unique ( -- * Main data types @@ -205,6 +205,9 @@ instance Uniquable Int where getUnique i = mkUniqueIntGrimily i +instance Uniquable Word64 where + getUnique i = mkUniqueGrimily i + instance Uniquable ModuleName where getUnique (ModuleName nm) = getUnique nm @@ -243,12 +246,17 @@ -- is to get ABI compatible binaries given the same inputs and environment. -- The motivation behind that is that if the ABI doesn't change the -- binaries can be safely reused. --- Note that this is weaker than bit-for-bit identical binaries and getting --- bit-for-bit identical binaries is not a goal for now. --- This means that we don't care about nondeterminism that happens after --- the interface files are created, in particular we don't care about --- register allocation and code generation. --- To track progress on bit-for-bit determinism see #12262. +-- +-- Besides ABI/interface determinism, we also guarantee bit-for-bit identical +-- binaries (when -fobject-determinism is given), also known as object +-- determinism (#12935) +-- +-- To achieve this, we must take care to non-determinism in the code +-- generation, and, in particular, guarantee that the existing uniques are +-- renamed deterministically and new ones are produced deterministically too. +-- The overview of object determinism is given by Note [Object determinism]. +-- References to this note identify code where the unique determinism may +-- impact object determinism more specifically. eqUnique :: Unique -> Unique -> Bool eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 @@ -294,8 +302,14 @@ showUnique :: Unique -> String showUnique uniq - = case unpkUnique uniq of - (tag, u) -> tag : w64ToBase62 u + = tagStr ++ w64ToBase62 u + where + (tag, u) = unpkUnique uniq + -- Avoid emitting non-printable characters in pretty uniques. + -- See #25989. + tagStr + | tag < 'A' || tag > 'z' = show (ord tag) ++ "_" + | otherwise = [tag] pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques diff --git a/GHC/Types/Unique/DFM.hs b/GHC/Types/Unique/DFM.hs --- a/GHC/Types/Unique/DFM.hs +++ b/GHC/Types/Unique/DFM.hs @@ -41,11 +41,12 @@ alterUDFM, mapUDFM, mapMaybeUDFM, + mapMUDFM, plusUDFM, - plusUDFM_C, + plusUDFM_C, plusUDFM_CK, lookupUDFM, lookupUDFM_Directly, elemUDFM, - foldUDFM, + foldUDFM, foldWithKeyUDFM, eltsUDFM, filterUDFM, filterUDFM_Directly, isNullUDFM, @@ -55,6 +56,7 @@ equalKeysUDFM, minusUDFM, listToUDFM, listToUDFM_Directly, + listToUDFM_C_Directly, udfmMinusUFM, ufmMinusUDFM, partitionUDFM, udfmRestrictKeys, @@ -212,14 +214,23 @@ addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) +{-# INLINEABLE addListToUDFM #-} addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) +{-# INLINEABLE addListToUDFM_Directly #-} addListToUDFM_Directly_C :: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v) +{-# INLINEABLE addListToUDFM_Directly_C #-} +-- | Like 'addListToUDFM_Directly_C' but also passes the unique key to the combine function +addListToUDFM_Directly_CK + :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt +addListToUDFM_Directly_CK f = foldl' (\m (k, v) -> addToUDFM_C_Directly (f k) m k v) +{-# INLINEABLE addListToUDFM_Directly_CK #-} + delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i @@ -230,6 +241,15 @@ | i > j = insertUDFMIntoLeft_C f udfml udfmr | otherwise = insertUDFMIntoLeft_C f udfmr udfml +-- | Like 'plusUDFM_C' but the combine function also receives the unique key +plusUDFM_CK :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +plusUDFM_CK f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_CK f udfml udfmr + | otherwise = insertUDFMIntoLeft_CK f udfmr udfml + + -- Note [Overflow on plusUDFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- There are multiple ways of implementing plusUDFM. @@ -278,6 +298,12 @@ insertUDFMIntoLeft_C f udfml udfmr = addListToUDFM_Directly_C f udfml $ udfmToList udfmr +-- | Like 'insertUDFMIntoLeft_C', but the merge function also receives the unique key +insertUDFMIntoLeft_CK + :: (Unique -> elt -> elt -> elt) -> UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt +insertUDFMIntoLeft_CK f udfml udfmr = + addListToUDFM_Directly_CK f udfml $ udfmToList udfmr + lookupUDFM :: Uniquable key => UniqDFM key elt -> key -> Maybe elt lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m @@ -294,6 +320,12 @@ -- This INLINE prevents a regression in !10568 foldUDFM k z m = foldr k z (eltsUDFM m) +-- | Like 'foldUDFM' but the function also receives a key +foldWithKeyUDFM :: (Unique -> elt -> a -> a) -> a -> UniqDFM key elt -> a +{-# INLINE foldWithKeyUDFM #-} +-- This INLINE was copied from foldUDFM +foldWithKeyUDFM k z m = foldr (uncurry k) z (udfmToList m) + -- | Performs a nondeterministic strict fold over the UniqDFM. -- It's O(n), same as the corresponding function on `UniqFM`. -- If you use this please provide a justification why it doesn't introduce @@ -393,6 +425,9 @@ listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM key elt listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM +listToUDFM_C_Directly :: (elt -> elt -> elt) -> [(Unique, elt)] -> UniqDFM key elt +listToUDFM_C_Directly f = foldl' (\m (u, v) -> addToUDFM_C_Directly f m u v) emptyUDFM + -- | Apply a function to a particular element adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM key elt -> key -> UniqDFM key elt adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i @@ -425,6 +460,13 @@ -- Critical this is strict map, otherwise you get a big space leak when reloading -- in GHCi because all old ModDetails are retained (see pruneHomePackageTable). -- Modify with care. + +{-# INLINEABLE mapMUDFM #-} +-- | 'mapM' for a 'UniqDFM'. +mapMUDFM :: Monad m => (elt1 -> m elt2) -> UniqDFM key elt1 -> m (UniqDFM key elt2) +mapMUDFM f (UDFM m i) = do + m' <- traverse (traverse f) m + return $ UDFM m' i mapMaybeUDFM :: forall elt1 elt2 key. (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 diff --git a/GHC/Types/Unique/DSM.hs b/GHC/Types/Unique/DSM.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Unique/DSM.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE UnboxedTuples, PatternSynonyms, DerivingVia #-} +module GHC.Types.Unique.DSM + ( + -- * Threading a deterministic supply + DUniqSupply + , UniqDSM(UDSM) + , DUniqResult + , pattern DUniqResult + + -- ** UniqDSM and DUniqSupply operations + , getUniqueDSM + , runUniqueDSM + , takeUniqueFromDSupply + , initDUniqSupply + + -- ** Tag operations + , newTagDUniqSupply + , getTagDUniqSupply + + -- * A transfomer threading a deterministic supply + , UniqDSMT(UDSMT) + + -- ** UniqDSMT operations + , runUDSMT + , withDUS + , hoistUDSMT + , liftUDSMT + + -- ** Tags + , setTagUDSMT + + -- * Monad class for deterministic supply threading + , MonadGetUnique(..) + , MonadUniqDSM(..) + + ) + where + +import GHC.Exts (oneShot) +import GHC.Prelude +import GHC.Word +import Control.Monad.Fix +import GHC.Types.Unique +import qualified GHC.Utils.Monad.State.Strict as Strict +import qualified GHC.Types.Unique.Supply as USM +import Control.Monad.IO.Class + +{- +Note [Deterministic Uniques in the CG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC produces fully deterministic object code. To achieve this, there is a key +pass (detRenameCmmGroup) which renames all non-deterministic uniques in +the Cmm code right after StgToCmm. See Note [Object determinism] for the big +picture and some details. + +The code generation pipeline that processes this renamed, deterministic, Cmm, +however, may still need to generate new uniques. If we were to resort to the +non-deterministic unique supply used in the rest of the compiler, our renaming +efforts would be for naught. + +Therefore, after having renamed Cmm deterministically, we must ensure that all +uniques created by the code generation pipeline use a deterministic source of uniques. +Most often, this means don't use `UniqSM` in the Cmm passes, use `UniqDSM`: + +`UniqDSM` is a pure state monad with an incrementing counter from which we +source new uniques. Unlike `UniqSM`, there's no way to `split` the supply, but +it turns out this was rarely really needed for code generation and migrating +from UniqSM to UniqDSM was easy. + +Secondly, the `DUniqSupply` used to run a `UniqDSM` must be threaded through +all passes to guarantee uniques in different passes are unique amongst them +altogether. +Specifically, the same `DUniqSupply` must be threaded through the CG Streaming +pipeline, starting with Driver.Main calling `StgToCmm.codeGen`, `cmmPipeline`, +`cmmToRawCmm`, and `codeOutput` in sequence. + +To thread resources through the `Stream` abstraction, we use the `UniqDSMT` +transformer on top of `IO` as the Monad underlying the Stream. `UniqDSMT` will +thread the `DUniqSupply` through every pass applied to the `Stream`, for every +element. We use @type CgStream = Stream (UniqDSMT IO)@ for the Stream used in +code generation which that carries through the deterministic unique supply. + +Unlike non-deterministic unique supplies which can be split into supplies using +different tags, or where a new supply with a new tag can be brought from the +void, a `DUniqSupply` needs to be sampled iteratively. To use a different tag +during a specific pass (to more easily identify uniques created in it), the tag +should be manually set and then reset on the unique supply. There's also the +auxiliary `setTagUDSMT` which sets the tag for all uniques supplied in the given +action, and resets it implicitly. + +See also Note [Object determinism] in GHC.StgToCmm +-} + +-- See Note [Deterministic Uniques in the CG] +newtype DUniqSupply = DUS Word64 -- supply uniques iteratively +type DUniqResult result = (# result, DUniqSupply #) + +pattern DUniqResult :: a -> DUniqSupply -> (# a, DUniqSupply #) +pattern DUniqResult x y = (# x, y #) +{-# COMPLETE DUniqResult #-} + +-- | A monad which just gives the ability to obtain 'Unique's deterministically. +-- There's no splitting. +newtype UniqDSM result = UDSM' { unUDSM :: DUniqSupply -> DUniqResult result } + deriving (Functor, Applicative, Monad) via (Strict.State DUniqSupply) + +instance MonadFix UniqDSM where + mfix m = UDSM (\us0 -> let (r,us1) = runUniqueDSM us0 (m r) in DUniqResult r us1) + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern UDSM :: (DUniqSupply -> DUniqResult a) -> UniqDSM a +pattern UDSM m <- UDSM' m + where + UDSM m = UDSM' (oneShot $ \s -> m s) +{-# COMPLETE UDSM #-} + +getUniqueDSM :: UniqDSM Unique +getUniqueDSM = UDSM (\(DUS us0) -> DUniqResult (mkUniqueGrimily us0) (DUS $ us0+1)) + +takeUniqueFromDSupply :: DUniqSupply -> (Unique, DUniqSupply) +takeUniqueFromDSupply d = + case unUDSM getUniqueDSM d of + DUniqResult x y -> (x, y) + +-- | Initialize a deterministic unique supply with the given Tag and initial unique. +initDUniqSupply :: Char -> Word64 -> DUniqSupply +initDUniqSupply c firstUniq = + let !tag = mkTag c + in DUS (tag .|. firstUniq) + +runUniqueDSM :: DUniqSupply -> UniqDSM a -> (a, DUniqSupply) +runUniqueDSM ds (UDSM f) = + case f ds of + DUniqResult uq us -> (uq, us) + +-- | Set the tag of uniques generated from this deterministic unique supply +newTagDUniqSupply :: Char -> DUniqSupply -> DUniqSupply +newTagDUniqSupply c (DUS w) = DUS $ getKey $ newTagUnique (mkUniqueGrimily w) c + +-- | Get the tag uniques generated from this deterministic unique supply would have +getTagDUniqSupply :: DUniqSupply -> Char +getTagDUniqSupply (DUS w) = fst $ unpkUnique (mkUniqueGrimily w) + +-- | Get a unique from a monad that can access a unique supply. +-- +-- Crucially, because 'MonadGetUnique' doesn't allow you to get the +-- 'UniqSupply' (unlike 'MonadUnique'), an instance such as 'UniqDSM' can use a +-- deterministic unique supply to return deterministic uniques without allowing +-- for the 'UniqSupply' to be shared. +class Monad m => MonadGetUnique m where + getUniqueM :: m Unique + +instance MonadGetUnique UniqDSM where + getUniqueM = getUniqueDSM + +-- non deterministic instance +instance MonadGetUnique USM.UniqSM where + getUniqueM = USM.getUniqueM + +-------------------------------------------------------------------------------- +-- UniqDSMT +-------------------------------------------------------------------------------- + +-- | Transformer version of 'UniqDSM' to use when threading a deterministic +-- uniq supply over a Monad. Specifically, it is used in the `Stream` of Cmm +-- decls. +newtype UniqDSMT m result = UDSMT' (DUniqSupply -> m (result, DUniqSupply)) + deriving (Functor) + +-- Similar to GHC.Utils.Monad.State.Strict, using Note [The one-shot state monad trick] +-- Using the one-shot trick is necessary for performance. +-- Using transfomer's strict `StateT` regressed some performance tests in 1-2%. +-- The one-shot trick here fixes those regressions. + +pattern UDSMT :: (DUniqSupply -> m (result, DUniqSupply)) -> UniqDSMT m result +pattern UDSMT m <- UDSMT' m + where + UDSMT m = UDSMT' (oneShot $ \s -> m s) +{-# COMPLETE UDSMT #-} + +instance Monad m => Applicative (UniqDSMT m) where + pure x = UDSMT $ \s -> pure (x, s) + UDSMT f <*> UDSMT x = UDSMT $ \s0 -> do + (f', s1) <- f s0 + (x', s2) <- x s1 + pure (f' x', s2) + +instance Monad m => Monad (UniqDSMT m) where + UDSMT x >>= f = UDSMT $ \s0 -> do + (x', s1) <- x s0 + case f x' of UDSMT y -> y s1 + +instance MonadIO m => MonadIO (UniqDSMT m) where + liftIO x = UDSMT $ \s -> (,s) <$> liftIO x + +instance Monad m => MonadGetUnique (UniqDSMT m) where + getUniqueM = UDSMT $ \us -> do + let (u, us') = takeUniqueFromDSupply us + return (u, us') + +-- | Set the tag of the running @UniqDSMT@ supply to the given tag and run an action with it. +-- All uniques produced in the given action will use this tag, until the tag is changed +-- again. +setTagUDSMT :: Monad m => Char {-^ Tag -} -> UniqDSMT m a -> UniqDSMT m a +setTagUDSMT tag (UDSMT act) = UDSMT $ \us -> do + let origtag = getTagDUniqSupply us + new_us = newTagDUniqSupply tag us + (a, us') <- act new_us + let us'_origtag = newTagDUniqSupply origtag us' + -- restore original tag + return (a, us'_origtag) + +-- | Like 'runUniqueDSM' but for 'UniqDSMT' +runUDSMT :: DUniqSupply -> UniqDSMT m a -> m (a, DUniqSupply) +runUDSMT dus (UDSMT st) = st dus + +-- | Lift an IO action that depends on, and threads through, a unique supply +-- into UniqDSMT IO. +withDUS :: (DUniqSupply -> IO (a, DUniqSupply)) -> UniqDSMT IO a +withDUS f = UDSMT $ \us -> do + (a, us') <- liftIO (f us) + return (a, us') + +-- | Change the monad underyling an applied @UniqDSMT@, i.e. transform a +-- @UniqDSMT m@ into a @UniqDSMT n@ given @m ~> n@. +hoistUDSMT :: (forall x. m x -> n x) -> UniqDSMT m a -> UniqDSMT n a +hoistUDSMT nt (UDSMT m) = UDSMT $ \s -> nt (m s) + +-- | Lift a monadic action @m a@ into an @UniqDSMT m a@ +liftUDSMT :: Functor m => m a -> UniqDSMT m a +liftUDSMT m = UDSMT $ \s -> (,s) <$> m + +-------------------------------------------------------------------------------- +-- MonadUniqDSM +-------------------------------------------------------------------------------- + +class (Monad m) => MonadUniqDSM m where + -- | Lift a pure 'UniqDSM' action into a 'MonadUniqDSM' such as 'UniqDSMT' + liftUniqDSM :: UniqDSM a -> m a + +instance MonadUniqDSM UniqDSM where + liftUniqDSM = id + +instance Monad m => MonadUniqDSM (UniqDSMT m) where + liftUniqDSM act = UDSMT $ \us -> pure $ runUniqueDSM us act diff --git a/GHC/Types/Unique/DSet.hs b/GHC/Types/Unique/DSet.hs --- a/GHC/Types/Unique/DSet.hs +++ b/GHC/Types/Unique/DSet.hs @@ -33,7 +33,7 @@ lookupUniqDSet, uniqDSetToList, partitionUniqDSet, - mapUniqDSet + mapUniqDSet, strictFoldUniqDSet, mapMUniqDSet ) where import GHC.Prelude @@ -125,7 +125,22 @@ -- See Note [UniqSet invariant] in GHC.Types.Unique.Set mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b -mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList +mapUniqDSet f (UniqDSet m) = UniqDSet $ unsafeCastUDFMKey $ mapUDFM f m + -- Simply apply `f` to each element, retaining all the structure unchanged. + -- The identification of keys and elements prevents a derived Functor + -- instance, but `unsafeCastUDFMKey` makes it possible to apply the strict + -- mapping from DFM. + +-- | Like 'mapUniqDSet' but for 'mapM'. Assumes the function we are mapping +-- over the 'UniqDSet' does not modify uniques, as per +-- Note [UniqSet invariant] in GHC.Types.Unique.Set. +mapMUniqDSet :: (Monad m, Uniquable b) => (a -> m b) -> UniqDSet a -> m (UniqDSet b) +mapMUniqDSet f (UniqDSet m) = UniqDSet . unsafeCastUDFMKey <$> mapMUDFM f m +{-# INLINEABLE mapMUniqDSet #-} + +strictFoldUniqDSet :: (a -> r -> r) -> r -> UniqDSet a -> r +strictFoldUniqDSet k r s = foldl' (\ !r e -> k e r) r $ + uniqDSetToList s -- Two 'UniqDSet's are considered equal if they contain the same -- uniques. diff --git a/GHC/Types/Unique/FM.hs b/GHC/Types/Unique/FM.hs --- a/GHC/Types/Unique/FM.hs +++ b/GHC/Types/Unique/FM.hs @@ -65,12 +65,13 @@ intersectUFM_C, disjointUFM, equalKeysUFM, + diffUFM, nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, nonDetFoldWithKeyUFM, nonDetStrictFoldUFM_Directly, anyUFM, allUFM, seqEltsUFM, mapUFM, mapUFM_Directly, strictMapUFM, - mapMaybeUFM, mapMaybeWithKeyUFM, + mapMaybeUFM, mapMaybeUFM_sameUnique, mapMaybeWithKeyUFM, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, partitionUFM, sizeUFM, @@ -139,9 +140,11 @@ listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM +{-# INLINEABLE listToUFM #-} listToUFM_Directly :: [(Unique, elt)] -> UniqFM key elt listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM +{-# INLINEABLE listToUFM_Directly #-} listToIdentityUFM :: Uniquable key => [key] -> UniqFM key key listToIdentityUFM = foldl' (\m x -> addToUFM m x x) emptyUFM @@ -152,6 +155,7 @@ -> [(key, elt)] -> UniqFM key elt listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM +{-# INLINEABLE listToUFM_C #-} addToUFM :: Uniquable key => UniqFM key elt -> key -> elt -> UniqFM key elt addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) @@ -236,11 +240,13 @@ delFromUFM :: Uniquable key => UniqFM key elt -> key -> UniqFM key elt delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) -delListFromUFM :: Uniquable key => UniqFM key elt -> [key] -> UniqFM key elt +delListFromUFM :: (Uniquable key, Foldable f) => UniqFM key elt -> f key -> UniqFM key elt delListFromUFM = foldl' delFromUFM +{-# INLINE delListFromUFM #-} -delListFromUFM_Directly :: UniqFM key elt -> [Unique] -> UniqFM key elt +delListFromUFM_Directly :: Foldable f => UniqFM key elt -> f Unique -> UniqFM key elt delListFromUFM_Directly = foldl' delFromUFM_Directly +{-# INLINE delListFromUFM_Directly #-} delFromUFM_Directly :: UniqFM key elt -> Unique -> UniqFM key elt delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) @@ -385,8 +391,13 @@ mapUFM f (UFM m) = UFM (M.map f m) mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2 -mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m) +mapMaybeUFM = mapMaybeUFM_sameUnique +-- | Like 'Data.Map.mapMaybe', but you must ensure the passed-in function does +-- not modify the unique. +mapMaybeUFM_sameUnique :: (elt1 -> Maybe elt2) -> UniqFM key1 elt1 -> UniqFM key2 elt2 +mapMaybeUFM_sameUnique f (UFM m) = UFM (M.mapMaybe f m) + mapMaybeWithKeyUFM :: (Unique -> elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapMaybeWithKeyUFM f (UFM m) = UFM (M.mapMaybeWithKey (f . mkUniqueGrimily) m) @@ -520,6 +531,28 @@ -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +-- | An edit on type @a@, relating an element of a container (like an entry in a +-- map or a line in a file) before and after. +data Edit a + = Removed !a -- ^ Element was removed from the container + | Added !a -- ^ Element was added to the container + | Changed !a !a -- ^ Element was changed. Carries the values before and after + deriving Eq + +instance Outputable a => Outputable (Edit a) where + ppr (Removed a) = text "-" <> ppr a + ppr (Added a) = text "+" <> ppr a + ppr (Changed l r) = ppr l <> text "->" <> ppr r + +-- A very convient function to have for debugging: +-- | Computes the diff of two 'UniqFM's in terms of 'Edit's. +-- Equal points will not be present in the result map at all. +diffUFM :: Eq a => UniqFM key a -> UniqFM key a -> UniqFM key (Edit a) +diffUFM = mergeUFM both (mapUFM Removed) (mapUFM Added) + where + both x y | x == y = Nothing + | otherwise = Just $! Changed x y -- Instances diff --git a/GHC/Types/Unique/Set.hs b/GHC/Types/Unique/Set.hs --- a/GHC/Types/Unique/Set.hs +++ b/GHC/Types/Unique/Set.hs @@ -44,6 +44,27 @@ nonDetEltsUniqSet, nonDetKeysUniqSet, nonDetStrictFoldUniqSet, + mapMaybeUniqSet_sameUnique, + + -- UniqueSet + UniqueSet(..), + nullUniqueSet, + sizeUniqueSet, + memberUniqueSet, + emptyUniqueSet, + singletonUniqueSet, + insertUniqueSet, + deleteUniqueSet, + differenceUniqueSet, + unionUniqueSet, + unionsUniqueSet, + intersectionUniqueSet, + isSubsetOfUniqueSet, + filterUniqueSet, + foldlUniqueSet, + foldrUniqueSet, + elemsUniqueSet, + fromListUniqueSet, ) where import GHC.Prelude @@ -55,6 +76,8 @@ import GHC.Utils.Outputable import Data.Data import qualified Data.Semigroup as Semi +import Control.DeepSeq +import qualified GHC.Data.Word64Set as S -- Note [UniqSet invariant] -- ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -63,9 +86,13 @@ -- It means that to implement mapUniqSet you have to update -- both the keys and the values. +-- | Set of Uniquable values newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a a} deriving (Data, Semi.Semigroup, Monoid) +instance NFData a => NFData (UniqSet a) where + rnf = forceUniqSet rnf + emptyUniqSet :: UniqSet a emptyUniqSet = UniqSet emptyUFM @@ -74,12 +101,14 @@ mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet = foldl' addOneToUniqSet emptyUniqSet +{-# INLINEABLE mkUniqSet #-} addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a addListToUniqSet = foldl' addOneToUniqSet +{-# INLINEABLE addListToUniqSet #-} delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) @@ -89,10 +118,12 @@ delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) +{-# INLINEABLE delListFromUniqSet #-} delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a delListFromUniqSet_Directly (UniqSet s) l = UniqSet (delListFromUFM_Directly s l) +{-# INLINEABLE delListFromUniqSet_Directly #-} unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) @@ -175,6 +206,11 @@ mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet +-- | Like 'Data.Set.mapMaybe', but you must ensure the passed in function +-- does not change the 'Unique'. +mapMaybeUniqSet_sameUnique :: (a -> Maybe b) -> UniqSet a -> UniqSet b +mapMaybeUniqSet_sameUnique f (UniqSet a) = UniqSet $ mapMaybeUFM_sameUnique f a + -- Two 'UniqSet's are considered equal if they contain the same -- uniques. instance Eq (UniqSet a) where @@ -196,3 +232,84 @@ -- It's OK to use nonDetUFMToList here because we only use it for -- pretty-printing. pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet + +forceUniqSet :: (a -> ()) -> UniqSet a -> () +forceUniqSet f (UniqSet fm) = seqEltsUFM f fm + +-------------------------------------------------------- +-- UniqueSet +-------------------------------------------------------- + +-- | Set of Unique values +-- +-- Similar to 'UniqSet Unique' but with a more compact representation. +newtype UniqueSet = US { unUniqueSet :: S.Word64Set } + deriving (Eq, Ord, Show, Semigroup, Monoid) + +{-# INLINE nullUniqueSet #-} +nullUniqueSet :: UniqueSet -> Bool +nullUniqueSet (US s) = S.null s + +{-# INLINE sizeUniqueSet #-} +sizeUniqueSet :: UniqueSet -> Int +sizeUniqueSet (US s) = S.size s + +{-# INLINE memberUniqueSet #-} +memberUniqueSet :: Unique -> UniqueSet -> Bool +memberUniqueSet k (US s) = S.member (getKey k) s + +{-# INLINE emptyUniqueSet #-} +emptyUniqueSet :: UniqueSet +emptyUniqueSet = US S.empty + +{-# INLINE singletonUniqueSet #-} +singletonUniqueSet :: Unique -> UniqueSet +singletonUniqueSet k = US (S.singleton (getKey k)) + +{-# INLINE insertUniqueSet #-} +insertUniqueSet :: Unique -> UniqueSet -> UniqueSet +insertUniqueSet k (US s) = US (S.insert (getKey k) s) + +{-# INLINE deleteUniqueSet #-} +deleteUniqueSet :: Unique -> UniqueSet -> UniqueSet +deleteUniqueSet k (US s) = US (S.delete (getKey k) s) + +{-# INLINE unionUniqueSet #-} +unionUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet +unionUniqueSet (US x) (US y) = US (S.union x y) + +{-# INLINE unionsUniqueSet #-} +unionsUniqueSet :: [UniqueSet] -> UniqueSet +unionsUniqueSet xs = US (S.unions (map unUniqueSet xs)) + +{-# INLINE differenceUniqueSet #-} +differenceUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet +differenceUniqueSet (US x) (US y) = US (S.difference x y) + +{-# INLINE intersectionUniqueSet #-} +intersectionUniqueSet :: UniqueSet -> UniqueSet -> UniqueSet +intersectionUniqueSet (US x) (US y) = US (S.intersection x y) + +{-# INLINE isSubsetOfUniqueSet #-} +isSubsetOfUniqueSet :: UniqueSet -> UniqueSet -> Bool +isSubsetOfUniqueSet (US x) (US y) = S.isSubsetOf x y + +{-# INLINE filterUniqueSet #-} +filterUniqueSet :: (Unique -> Bool) -> UniqueSet -> UniqueSet +filterUniqueSet f (US s) = US (S.filter (f . mkUniqueGrimily) s) + +{-# INLINE foldlUniqueSet #-} +foldlUniqueSet :: (a -> Unique -> a) -> a -> UniqueSet -> a +foldlUniqueSet k z (US s) = S.foldl' (\a b -> k a (mkUniqueGrimily b)) z s + +{-# INLINE foldrUniqueSet #-} +foldrUniqueSet :: (Unique -> b -> b) -> b -> UniqueSet -> b +foldrUniqueSet k z (US s) = S.foldr (k . mkUniqueGrimily) z s + +{-# INLINE elemsUniqueSet #-} +elemsUniqueSet :: UniqueSet -> [Unique] +elemsUniqueSet (US s) = map mkUniqueGrimily (S.elems s) + +{-# INLINE fromListUniqueSet #-} +fromListUniqueSet :: [Unique] -> UniqueSet +fromListUniqueSet ks = US (S.fromList (map getKey ks)) diff --git a/GHC/Types/Unique/Supply.hs b/GHC/Types/Unique/Supply.hs --- a/GHC/Types/Unique/Supply.hs +++ b/GHC/Types/Unique/Supply.hs @@ -3,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-} @@ -42,18 +42,24 @@ import Data.Word import GHC.Exts( Ptr(..), noDuplicate#, oneShot ) import Foreign.Storable +import GHC.Utils.Monad.State.Strict as Strict #include "MachDeps.h" -#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) && WORD_SIZE_IN_BITS == 64 -import GHC.Word( Word64(..) ) -import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# ) -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) -import GHC.Exts( wordToWord64# ) +#if WORD_SIZE_IN_BITS != 64 +#define NO_FETCH_ADD #endif + +#if defined(NO_FETCH_ADD) +import GHC.Exts ( atomicCasWord64Addr#, eqWord64#, readWord64OffAddr# ) +#else +import GHC.Exts( fetchAddWordAddr#, word64ToWord# ) #endif -#include "Unique.h" +import GHC.Exts ( Addr#, State#, Word64#, RealWorld ) +import GHC.Int ( Int(..) ) +import GHC.Word( Word64(..) ) +import GHC.Exts( plusWord64#, int2Word#, wordToWord64# ) {- ************************************************************************ @@ -165,8 +171,7 @@ benefits of threading the tag this *also* has the benefit of avoiding the tag getting captured in thunks, or being passed around at runtime. It does however come at the cost of having to use a fixed tag for all -code run in this Monad. But remember, the tag is purely cosmetic: -See Note [Uniques and tags]. +code run in this Monad. The tag is mostly cosmetic: See Note [Uniques and tags]. NB: It's *not* an optimization to pass around the UniqSupply inside an IORef instead of the tag. While this would avoid frequent state updates @@ -197,9 +202,8 @@ mkSplitUniqSupply :: Char -> IO UniqSupply -- ^ Create a unique supply out of thin air. --- The "tag" (Char) supplied is purely cosmetic, making it easier --- to figure out where a Unique was born. See --- Note [Uniques and tags]. +-- The "tag" (Char) supplied is mostly cosmetic, making it easier +-- to figure out where a Unique was born. See Note [Uniques and tags]. -- -- The payload part of the Uniques allocated from this UniqSupply are -- guaranteed distinct wrt all other supplies, regardless of their "tag". @@ -228,25 +232,37 @@ (# s4, MkSplitUniqSupply (tag .|. u) x y #) }}}} --- If a word is not 64 bits then we would need a fetchAddWord64Addr# primitive, --- which does not exist. So we fall back on the C implementation in that case. - -#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64 -foreign import ccall unsafe "genSym" genSym :: IO Word64 +#if defined(NO_FETCH_ADD) +-- GHC currently does not provide this operation on 32-bit platforms, +-- hence the CAS-based implementation. +fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld + -> (# State# RealWorld, Word64# #) +fetchAddWord64Addr# = go + where + go ptr inc s0 = + case readWord64OffAddr# ptr 0# s0 of + (# s1, n0 #) -> + case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of + (# s2, res #) + | 1# <- res `eqWord64#` n0 -> (# s2, n0 #) + | otherwise -> go ptr inc s2 #else +fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld + -> (# State# RealWorld, Word64# #) +fetchAddWord64Addr# addr inc s0 = + case fetchAddWordAddr# addr (word64ToWord# inc) s0 of + (# s1, res #) -> (# s1, wordToWord64# res #) +#endif + genSym :: IO Word64 genSym = do let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1 let !(Ptr counter) = ghc_unique_counter64 - let !(Ptr inc_ptr) = ghc_unique_inc - u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of - (# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of + I# inc# <- peek ghc_unique_inc + let !inc = wordToWord64# (int2Word# inc#) + u <- IO $ \s1 -> case fetchAddWord64Addr# counter inc s1 of (# s2, val #) -> -#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) - let !u = W64# (val `plusWord#` inc) .&. mask -#else - let !u = W64# (wordToWord64# (val `plusWord#` inc)) .&. mask -#endif + let !u = W64# (val `plusWord64#` inc) .&. mask in (# s2, u #) #if defined(DEBUG) -- Uh oh! We will overflow next time a unique is requested. @@ -254,7 +270,6 @@ massert (u /= mask) #endif return u -#endif foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64 foreign import ccall unsafe "&ghc_unique_inc" ghc_unique_inc :: Ptr Int @@ -289,6 +304,8 @@ uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) +{-# INLINE splitUniqSupply #-} + {- ************************************************************************ * * @@ -305,12 +322,7 @@ -- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } - --- See Note [The one-shot state monad trick] for why we don't derive this. -instance Functor UniqSM where - fmap f (USM m) = mkUniqSM $ \us -> - case m us of - (# r, us' #) -> UniqResult (f r) us' + deriving (Functor, Applicative, Monad) via (Strict.State UniqSupply) -- | Smart constructor for 'UniqSM', as described in Note [The one-shot state -- monad trick]. @@ -318,17 +330,6 @@ mkUniqSM f = USM (oneShot f) {-# INLINE mkUniqSM #-} -instance Monad UniqSM where - (>>=) = thenUs - (>>) = (*>) - -instance Applicative UniqSM where - pure = returnUs - (USM f) <*> (USM x) = mkUniqSM $ \us0 -> case f us0 of - UniqResult ff us1 -> case x us1 of - UniqResult xx us2 -> UniqResult (ff xx) us2 - (*>) = thenUs_ - -- TODO: try to get rid of this instance instance MonadFail UniqSM where fail = panic @@ -341,29 +342,11 @@ initUs_ :: UniqSupply -> UniqSM a -> a initUs_ init_us m = case unUSM m init_us of { UniqResult r _ -> r } -{-# INLINE thenUs #-} -{-# INLINE returnUs #-} -{-# INLINE splitUniqSupply #-} - --- @thenUs@ is where we split the @UniqSupply@. - liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1) instance MonadFix UniqSM where mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1) - -thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b -thenUs (USM expr) cont - = mkUniqSM (\us0 -> case (expr us0) of - UniqResult result us1 -> unUSM (cont result) us1) - -thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b -thenUs_ (USM expr) (USM cont) - = mkUniqSM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 }) - -returnUs :: a -> UniqSM a -returnUs result = mkUniqSM (\us -> UniqResult result us) getUs :: UniqSM UniqSupply getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2) diff --git a/GHC/Types/Var.hs b/GHC/Types/Var.hs --- a/GHC/Types/Var.hs +++ b/GHC/Types/Var.hs @@ -5,9 +5,9 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, - PatternSynonyms, BangPatterns #-} +{-# LANGUAGE MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE DeriveFunctor #-} -- | -- #name_types# @@ -40,12 +40,12 @@ TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, -- * In and Out variants - InVar, InCoVar, InId, InTyVar, - OutVar, OutCoVar, OutId, OutTyVar, + InVar, InCoVar, InId, InTyVar, InTyCoVar, + OutVar, OutCoVar, OutId, OutTyVar, OutTyCoVar, -- ** Taking 'Var's apart varName, varUnique, varType, - varMult, varMultMaybe, + varMultMaybe, idMult, -- ** Modifying 'Var's setVarName, setVarUnique, setVarType, @@ -61,7 +61,7 @@ -- ** Predicates isId, isTyVar, isTcTyVar, - isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, + isLocalVar, isLocalId, isLocalId_maybe, isCoVar, isNonCoVarId, isTyCoVar, isGlobalId, isExportedId, mustHaveLocalBinding, @@ -69,6 +69,8 @@ ForAllTyFlag(Invisible,Required,Specified,Inferred), Specificity(..), isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag, + isSpecifiedForAllTyFlag, + coreTyLamForAllTyFlag, -- * FunTyFlag FunTyFlag(..), isVisibleFunArg, isInvisibleFunArg, isFUNArg, @@ -80,7 +82,8 @@ -- * PiTyBinder PiTyBinder(..), PiTyVarBinder, - isInvisiblePiTyBinder, isVisiblePiTyBinder, + isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder, + isVisiblePiTyBinder, isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, @@ -90,10 +93,13 @@ binderVar, binderVars, binderFlag, binderFlags, binderType, mkForAllTyBinder, mkForAllTyBinders, mkTyVarBinder, mkTyVarBinders, - isTyVarBinder, + isVisibleForAllTyBinder, isInvisibleForAllTyBinder, isTyVarBinder, tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders, mapVarBndr, mapVarBndrs, + -- ** ExportFlag + ExportFlag(..), + -- ** Constructing TyVar's mkTyVar, mkTcTyVar, @@ -123,8 +129,11 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain +import GHC.Hs.Specificity () +import Language.Haskell.Syntax.Specificity +import Control.DeepSeq + import Data.Data {- @@ -197,10 +206,12 @@ type InVar = Var type InTyVar = TyVar type InCoVar = CoVar +type InTyCoVar = TyCoVar type InId = Id type OutVar = Var type OutTyVar = TyVar type OutCoVar = CoVar +type OutTyCoVar = TyCoVar type OutId = Id @@ -317,7 +328,10 @@ * or defined at top level in the module being compiled * always treated as a candidate by the free-variable finder -After CoreTidy, top-level LocalIds are turned into GlobalIds +In the output of CoreTidy, top level Ids are all GlobalIds, which are then +serialised into interface files. Do note however that CorePrep may introduce new +LocalIds for local floats (even at the top level). These will be visible in STG +and end up in generated code. Note [Multiplicity of let binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -333,9 +347,12 @@ -} instance Outputable Var where - ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> + ppr var = docWithStyle ppr_code ppr_normal + where + -- don't display debug info with Code style (#25255) + ppr_code = ppr (varName var) + ppr_normal sty = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> getPprDebug $ \debug -> - getPprStyle $ \sty -> let ppr_var = case var of (TyVar {}) @@ -403,6 +420,10 @@ varMultMaybe (Id { varMult = mult }) = Just mult varMultMaybe _ = Nothing +idMult :: HasDebugCallStack => Id -> Mult +idMult (Id { varMult = mult }) = mult +idMult non_id = pprPanic "idMult" (ppr non_id) + setVarUnique :: Var -> Unique -> Var setVarUnique var uniq = var { realUnique = uniq, @@ -443,79 +464,6 @@ {- ********************************************************************* * * -* ForAllTyFlag -* * -********************************************************************* -} - --- | ForAllTyFlag --- --- Is something required to appear in source Haskell ('Required'), --- permitted by request ('Specified') (visible type application), or --- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" -data ForAllTyFlag = Invisible Specificity - | Required - deriving (Eq, Ord, Data) - -- (<) on ForAllTyFlag means "is less visible than" - --- | Whether an 'Invisible' argument may appear in source Haskell. -data Specificity = InferredSpec - -- ^ the argument may not appear in source Haskell, it is - -- only inferred. - | SpecifiedSpec - -- ^ the argument may appear in source Haskell, but isn't - -- required. - deriving (Eq, Ord, Data) - -pattern Inferred, Specified :: ForAllTyFlag -pattern Inferred = Invisible InferredSpec -pattern Specified = Invisible SpecifiedSpec - -{-# COMPLETE Required, Specified, Inferred #-} - --- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell? -isVisibleForAllTyFlag :: ForAllTyFlag -> Bool -isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af) - --- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell? -isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool -isInvisibleForAllTyFlag (Invisible {}) = True -isInvisibleForAllTyFlag Required = False - -isInferredForAllTyFlag :: ForAllTyFlag -> Bool --- More restrictive than isInvisibleForAllTyFlag -isInferredForAllTyFlag (Invisible InferredSpec) = True -isInferredForAllTyFlag _ = False - -instance Outputable ForAllTyFlag where - ppr Required = text "[req]" - ppr Specified = text "[spec]" - ppr Inferred = text "[infrd]" - -instance Binary Specificity where - put_ bh SpecifiedSpec = putByte bh 0 - put_ bh InferredSpec = putByte bh 1 - - get bh = do - h <- getByte bh - case h of - 0 -> return SpecifiedSpec - _ -> return InferredSpec - -instance Binary ForAllTyFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Required - 1 -> return Specified - _ -> return Inferred - -{- ********************************************************************* -* * * FunTyFlag * * ********************************************************************* -} @@ -552,6 +500,12 @@ 2 -> return FTF_C_T _ -> return FTF_C_C +instance NFData FunTyFlag where + rnf FTF_T_T = () + rnf FTF_T_C = () + rnf FTF_C_T = () + rnf FTF_C_C = () + mkFunTyFlag :: TypeOrConstraint -> TypeOrConstraint -> FunTyFlag mkFunTyFlag TypeLike torc = visArg torc mkFunTyFlag ConstraintLike torc = invisArg torc @@ -618,11 +572,11 @@ False True FTF_T_C True False FTF_C_T True True FTF_C_C -where isPredTy is defined in GHC.Core.Type, and sees if t1's +where isPredTy is defined in GHC.Core.Predicate, and sees if t1's kind is Constraint. See GHC.Core.Type.chooseFunTyFlag, and -GHC.Core.TyCo.Rep Note [Types for coercions, predicates, and evidence] +GHC.Core.Predicate Note [Types for coercions, predicates, and evidence] -The term (Lam b e) donesn't carry an FunTyFlag; instead it uses +The term (Lam b e) doesn't carry an FunTyFlag; instead it uses mkFunctionType when we want to get its types; see mkLamType. This is just an engineering choice; we could cache here too if we wanted. @@ -694,18 +648,19 @@ data VarBndr var argf = Bndr var argf -- See Note [The VarBndr type and its uses] - deriving( Data ) + deriving( Data, Eq, Ord) -- | Variable Binder -- -- A 'ForAllTyBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in "GHC.Core.TyCo.Rep", because it's used in GHC.Core.DataCon.hs-boot +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] -- -- A 'TyVarBinder' is a binder with only TyVar type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag -type InvisTyBinder = VarBndr TyCoVar Specificity -type ReqTyBinder = VarBndr TyCoVar () +type InvisTyBinder = VarBndr TyCoVar Specificity +type ReqTyBinder = VarBndr TyCoVar () type TyVarBinder = VarBndr TyVar ForAllTyFlag type InvisTVBinder = VarBndr TyVar Specificity @@ -723,6 +678,12 @@ tyVarReqToBinder :: VarBndr a () -> VarBndr a ForAllTyFlag tyVarReqToBinder (Bndr tv _) = Bndr tv Required +isVisibleForAllTyBinder :: ForAllTyBinder -> Bool +isVisibleForAllTyBinder (Bndr _ vis) = isVisibleForAllTyFlag vis + +isInvisibleForAllTyBinder :: ForAllTyBinder -> Bool +isInvisibleForAllTyBinder (Bndr _ vis) = isInvisibleForAllTyFlag vis + binderVar :: VarBndr tv argf -> tv binderVar (Bndr v _) = v @@ -780,6 +741,9 @@ get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } +instance (NFData tv, NFData vis) => NFData (VarBndr tv vis) where + rnf (Bndr tv vis) = rnf tv `seq` rnf vis + instance NamedThing tv => NamedThing (VarBndr tv flag) where getName (Bndr tv _) = getName tv @@ -805,7 +769,6 @@ ppr (Named (Bndr v Specified)) = char '@' <> ppr v ppr (Named (Bndr v Inferred)) = braces (ppr v) - -- | 'PiTyVarBinder' is like 'PiTyBinder', but there can only be 'TyVar' -- in the 'Named' field. type PiTyVarBinder = PiTyBinder @@ -815,6 +778,10 @@ isInvisiblePiTyBinder (Named (Bndr _ vis)) = isInvisibleForAllTyFlag vis isInvisiblePiTyBinder (Anon _ af) = isInvisibleFunArg af +isInvisibleAnonPiTyBinder :: PiTyBinder -> Bool +isInvisibleAnonPiTyBinder (Named {}) = False +isInvisibleAnonPiTyBinder (Anon _ af) = isInvisibleFunArg af + -- | Does this binder bind a visible argument? isVisiblePiTyBinder :: PiTyBinder -> Bool isVisiblePiTyBinder = not . isInvisiblePiTyBinder @@ -888,7 +855,7 @@ Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A ForAllTy (used for both types and kinds) contains a ForAllTyBinder. Each ForAllTyBinder Bndr a tvis @@ -911,8 +878,7 @@ | tvis = Inferred: f :: forall {a}. type Arg not allowed: f f :: forall {co}. type Arg not allowed: f | tvis = Specified: f :: forall a. type Arg optional: f or f @Int -| tvis = Required: T :: forall k -> type Arg required: T * -| This last form is illegal in terms: See Note [No Required PiTyBinder in terms] +| tvis = Required: f :: forall k -> type Arg required: f (type Int) | | Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon | cvis :: TyConBndrVis @@ -943,22 +909,28 @@ f3 :: forall a. a -> a; f3 x = x So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified +* Required. Function defn, with signature (explicit forall): + f4 :: forall a -> a -> a; f4 (type _) x = x + So f4 gets the type f4 :: forall a -> a -> a, with 'a' Required + This is the experimental RequiredTypeArguments extension, + see GHC Proposal #281 "Visible forall in types of terms" + * Inferred. Function defn, with signature (explicit forall), marked as inferred: - f4 :: forall {a}. a -> a; f4 x = x - So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred + f5 :: forall {a}. a -> a; f5 x = x + So f5 gets the type f5 :: forall {a}. a -> a, with 'a' Inferred It's Inferred because the user marked it as such, even though it does appear - in the user-written signature for f4 + in the user-written signature for f5 * Inferred/Specified. Function signature with inferred kind polymorphism. - f5 :: a b -> Int - So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int + f6 :: a b -> Int + So 'f6' gets the type f6 :: forall {k} (a :: k -> Type) (b :: k). a b -> Int Here 'k' is Inferred (it's not mentioned in the type), but 'a' and 'b' are Specified. * Specified. Function signature with explicit kind polymorphism - f6 :: a (b :: k) -> Int + f7 :: a (b :: k) -> Int This time 'k' is Specified, because it is mentioned explicitly, - so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int + so we get f7 :: forall (k :: Type) (a :: k -> Type) (b :: k). a b -> Int * Similarly pattern synonyms: Inferred - from inferred types (e.g. no pattern type signature) @@ -1018,7 +990,7 @@ const :: forall a b. a -> b -> a Inferred: like Specified, but every binder is written in braces: - f :: forall {k} (a:k). S k a -> Int + f :: forall {k} (a :: k). S k a -> Int Required: binders are put between `forall` and `->`: T :: forall k -> * @@ -1030,19 +1002,6 @@ * Inferred variables correspond to "generalized" variables from the Visible Type Applications paper (ESOP'16). - -Note [No Required PiTyBinder in terms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't allow Required foralls for term variables, including pattern -synonyms and data constructors. Why? Because then an application -would need a /compulsory/ type argument (possibly without an "@"?), -thus (f Int); and we don't have concrete syntax for that. - -We could change this decision, but Required, Named PiTyBinders are rare -anyway. (Most are Anons.) - -However the type of a term can (just about) have a required quantifier; -see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr. -} @@ -1115,7 +1074,7 @@ idInfo (Id { id_info = info }) = info idInfo other = pprPanic "idInfo" (ppr other) -idDetails :: Id -> IdDetails +idDetails :: HasCallStack => Id -> IdDetails idDetails (Id { id_details = details }) = details idDetails other = pprPanic "idDetails" (ppr other) @@ -1244,6 +1203,10 @@ isLocalId :: Var -> Bool isLocalId (Id { idScope = LocalId _ }) = True isLocalId _ = False + +isLocalId_maybe :: Var -> Maybe ExportFlag +isLocalId_maybe (Id { idScope = LocalId ef }) = Just ef +isLocalId_maybe _ = Nothing -- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's -- These are the variables that we need to pay attention to when finding free diff --git a/GHC/Types/Var.hs-boot b/GHC/Types/Var.hs-boot --- a/GHC/Types/Var.hs-boot +++ b/GHC/Types/Var.hs-boot @@ -1,22 +1,16 @@ {-# LANGUAGE NoPolyKinds #-} module GHC.Types.Var where -import GHC.Prelude () import {-# SOURCE #-} GHC.Types.Name - -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports - -- it does not seem to depend on anything. But it does! We must, for - -- example, compile GHC.Types in the ghc-prim library first. So this - -- otherwise-unnecessary import tells the build system that this module - -- depends on GhcPrelude, which ensures that GHC.Type is built first. +import Language.Haskell.Syntax.Specificity (Specificity, ForAllTyFlag) -data ForAllTyFlag data FunTyFlag data Var instance NamedThing Var data VarBndr var argf -data Specificity type TyVar = Var type Id = Var type TyCoVar = Id type TcTyVar = Var type InvisTVBinder = VarBndr TyVar Specificity +type TyVarBinder = VarBndr TyVar ForAllTyFlag diff --git a/GHC/Types/Var/Env.hs b/GHC/Types/Var/Env.hs --- a/GHC/Types/Var/Env.hs +++ b/GHC/Types/Var/Env.hs @@ -74,7 +74,8 @@ -- * TidyEnv and its operation TidyEnv, - emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList + emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList, + mapMaybeDVarEnv ) where import GHC.Prelude @@ -470,7 +471,7 @@ delTidyEnvList :: TidyEnv -> [Var] -> TidyEnv delTidyEnvList (occ_env, var_env) vs = (occ_env', var_env') where - occ_env' = occ_env `delTidyOccEnvList` map (occNameFS . getOccName) vs + occ_env' = occ_env `delTidyOccEnvList` map getOccName vs var_env' = var_env `delVarEnvList` vs {- @@ -517,7 +518,7 @@ partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) -- | Only keep variables contained in the VarSet restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a -delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnvList :: Foldable f => VarEnv a -> f Var -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a @@ -550,6 +551,8 @@ plusVarEnv_CD = plusUFM_CD plusMaybeVarEnv_C = plusMaybeUFM_C delVarEnvList = delListFromUFM +-- INLINE due to polymorphism +{-# INLINE delVarEnvList #-} delVarEnv = delFromUFM minusVarEnv = minusUFM plusVarEnv = plusUFM @@ -579,7 +582,7 @@ where keep u _ = u `elemVarSetByKey` vs -zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +zipVarEnv tyvars tys = mkVarEnv (zipEqual tyvars tys) lookupVarEnv_NF env id = case lookupVarEnv env id of Just xx -> xx Nothing -> panic "lookupVarEnv_NF: Nothing" @@ -653,6 +656,9 @@ filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a filterDVarEnv = filterUDFM + +mapMaybeDVarEnv :: (a -> Maybe b) -> DVarEnv a -> DVarEnv b +mapMaybeDVarEnv f = mapMaybeUDFM f alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a alterDVarEnv = alterUDFM diff --git a/GHC/Types/Var/Set.hs b/GHC/Types/Var/Set.hs --- a/GHC/Types/Var/Set.hs +++ b/GHC/Types/Var/Set.hs @@ -26,7 +26,7 @@ nonDetStrictFoldVarSet, -- * Deterministic Var set types - DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, + DVarSet, DIdSet, DTyVarSet, DCoVarSet, DTyCoVarSet, -- ** Manipulating these sets emptyDVarSet, unitDVarSet, mkDVarSet, @@ -38,7 +38,7 @@ isEmptyDVarSet, delDVarSet, delDVarSetList, minusDVarSet, nonDetStrictFoldDVarSet, - filterDVarSet, mapDVarSet, + filterDVarSet, mapDVarSet, strictFoldDVarSet, dVarSetMinusVarSet, anyDVarSet, allDVarSet, transCloDVarSet, sizeDVarSet, seqDVarSet, @@ -232,6 +232,9 @@ -- | Deterministic Type Variable Set type DTyVarSet = UniqDSet TyVar +-- | Deterministic Coercion Variable Set +type DCoVarSet = UniqDSet CoVar + -- | Deterministic Type or Coercion Variable Set type DTyCoVarSet = UniqDSet TyCoVar @@ -307,6 +310,9 @@ mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b mapDVarSet = mapUniqDSet + +strictFoldDVarSet :: (a -> r -> r) -> r -> UniqDSet a -> r +strictFoldDVarSet = strictFoldUniqDSet filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet filterDVarSet = filterUniqDSet diff --git a/GHC/Unit/Env.hs b/GHC/Unit/Env.hs --- a/GHC/Unit/Env.hs +++ b/GHC/Unit/Env.hs @@ -1,90 +1,162 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} + +-- | A 'UnitEnv' provides the complete interface into everything that is loaded +-- into a GHC session, including the 'HomeUnitGraph' for mapping home units to their +-- 'HomePackageTable's (which store information about all home modules), and +-- the 'ExternalPackageState' which provides access to all external packages +-- loaded. +-- +-- This module is meant to be imported as @UnitEnv@ when calling @insertHpt@: +-- +-- @ +-- import GHC.Unit.Env (UnitEnv, HomeUnitGraph, HomeUnitEnv) +-- import GHC.Unit.Env as UnitEnv +-- @ +-- +-- Here is an overview of how the UnitEnv, ModuleGraph, HUG, HPT, and EPS interact: +-- +-- @ +-- ┌────────────────┐┌────────────────────┐┌───────────┐ +-- │HomePackageTable││ExternalPackageState││ModuleGraph│ +-- └┬───────────────┘└┬───────────────────┘└┬──────────┘ +-- ┌▽────────────┐ │ │ +-- │HomeUnitGraph│ │ │ +-- └┬────────────┘ │ │ +-- ┌▽─────────────────▽─────────────────────▽┐ +-- │UnitEnv │ +-- └┬─────────────-──────────────────────────┘ +-- │ +-- │ +-- ┌▽──────────────────────────────────────▽┐ +-- │HscEnv │ +-- └────────────────────────────────────────┘ +-- @ +-- +-- The 'UnitEnv' references the 'HomeUnitGraph' (with all the home unit +-- modules), the 'ExternalPackageState' (information about all +-- non-home/external units), and the 'ModuleGraph' (which describes the +-- relationship between the modules being compiled). +-- The 'HscEnv' references this 'UnitEnv'. +-- The 'HomeUnitGraph' has one 'HomePackageTable' for every unit. module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv - , ueEPS - , unsafeGetHomeUnit + , ueEPS -- Not really needed, get directly type families and rule base! , updateHug - , updateHpt_lazy - , updateHpt -- * Unit Env helper functions - , ue_units , ue_currentHomeUnitEnv - , ue_setUnits - , ue_setUnitFlags - , ue_unit_dbs - , ue_all_home_unit_ids - , ue_setUnitDbs , ue_hpt - , ue_homeUnit - , ue_unsafeHomeUnit - , ue_setFlags , ue_setActiveUnit , ue_currentUnit , ue_findHomeUnitEnv - , ue_updateHomeUnitEnv , ue_unitHomeUnit - , ue_unitFlags - , ue_renameUnitId - , ue_transitiveHomeDeps - -- * HomeUnitEnv + , ue_unitHomeUnit_maybe + , ue_updateHomeUnitEnv + , ue_all_home_unit_ids + , ue_unsafeHomeUnit + + -- * HUG Re-export , HomeUnitGraph , HomeUnitEnv (..) - , mkHomeUnitEnv - , lookupHugByModule - , hugElts - , lookupHug - , addHomeModInfoToHug - -- * UnitEnvGraph - , UnitEnvGraph (..) - , UnitEnvGraphKey - , unitEnv_insert - , unitEnv_delete - , unitEnv_adjust - , unitEnv_new - , unitEnv_singleton - , unitEnv_map - , unitEnv_member - , unitEnv_lookup_maybe - , unitEnv_lookup - , unitEnv_keys - , unitEnv_elts - , unitEnv_hpts - , unitEnv_foldWithKey - , unitEnv_union - , unitEnv_mapWithKey + -- * Invariants , assertUnitEnvInvariant -- * Preload units info , preloadUnitsInfo , preloadUnitsInfo' -- * Home Module functions - , isUnitEnvInstalledModule ) + , isUnitEnvInstalledModule + + -------------------------------------------------------------------------------- + -- WIP above + -------------------------------------------------------------------------------- + + -- * Operations on the UnitEnv + , renameUnitId + + -- ** Modifying the current active home unit + , insertHpt + , ue_setFlags + + -- * Queries + + -- ** Queries on the current active home unit + , ue_homeUnitState + , ue_unit_dbs + , ue_homeUnit + , ue_unitFlags + + -- ** Reachability + , ue_transitiveHomeDeps + + -------------------------------------------------------------------------------- + -- Harder queries for the whole UnitEnv + -------------------------------------------------------------------------------- + + -- ** Instances, rules, type fams, annotations, etc.. + -- + -- | The @hug@ prefix means the function returns only things found in home + -- units. + , hugCompleteSigs + , hugAllInstances + , hugAllAnns + + -- * Legacy API + -- + -- | This API is deprecated! + , ue_units + ) where import GHC.Prelude +import qualified Data.Set as Set import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Home import GHC.Unit.Types import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Unit.Module.Graph import GHC.Platform import GHC.Settings import GHC.Data.Maybe -import GHC.Utils.Panic.Plain -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.DynFlags import GHC.Utils.Outputable -import GHC.Utils.Panic (pprPanic) -import GHC.Unit.Module.ModIface -import GHC.Unit.Module -import qualified Data.Set as Set +import GHC.Utils.Panic +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + +-------------------------------------------------------------------------------- +-- The hard queries +-------------------------------------------------------------------------------- + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +hugAllInstances :: UnitEnv -> IO (InstEnv, [FamInst]) +hugAllInstances = HUG.allInstances . ue_home_unit_graph + +-- | Find all the annotations in all home units +hugAllAnns :: UnitEnv -> IO AnnEnv +hugAllAnns = HUG.allAnns . ue_home_unit_graph + +-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across +-- all home units. +hugCompleteSigs :: UnitEnv -> IO CompleteMatches +hugCompleteSigs = HUG.allCompleteSigs . ue_home_unit_graph + +-------------------------------------------------------------------------------- +-- UnitEnv +-------------------------------------------------------------------------------- + data UnitEnv = UnitEnv { ue_eps :: {-# UNPACK #-} !ExternalUnitCache -- ^ Information about the currently loaded external packages. @@ -93,6 +165,10 @@ , ue_current_unit :: UnitId + , ue_module_graph :: ModuleGraph + -- ^ The module graph of the current session + -- See Note [Downsweep and the ModuleGraph] for when this is constructed. + , ue_home_unit_graph :: !HomeUnitGraph -- See Note [Multiple Home Units] @@ -112,39 +188,18 @@ return $ UnitEnv { ue_eps = eps , ue_home_unit_graph = hug + , ue_module_graph = emptyMG , ue_current_unit = cur_unit , ue_platform = platform , ue_namever = namever } --- | Get home-unit --- --- Unsafe because the home-unit may not be set -unsafeGetHomeUnit :: UnitEnv -> HomeUnit -unsafeGetHomeUnit ue = ue_unsafeHomeUnit ue - -updateHpt_lazy :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv -updateHpt_lazy = ue_updateHPT_lazy - -updateHpt :: (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv -updateHpt = ue_updateHPT - updateHug :: (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv updateHug = ue_updateHUG -ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId] -ue_transitiveHomeDeps uid unit_env = Set.toList (loop Set.empty [uid]) - where - loop acc [] = acc - loop acc (uid:uids) - | uid `Set.member` acc = loop acc uids - | otherwise = - let hue = homeUnitDepends (homeUnitEnv_units (ue_findHomeUnitEnv uid unit_env)) - in loop (Set.insert uid acc) (hue ++ uids) - - -- ----------------------------------------------------------------------------- -- Extracting information from the packages in scope +-- ----------------------------------------------------------------------------- -- Many of these functions take a list of packages: in those cases, -- the list is expected to contain the "dependent packages", @@ -160,7 +215,7 @@ preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo' unit_env ids0 = all_infos where - unit_state = ue_units unit_env + unit_state = HUG.homeUnitEnv_units (ue_currentHomeUnitEnv unit_env) ids = ids0 ++ inst_ids inst_ids = case ue_homeUnit unit_env of Nothing -> [] @@ -182,226 +237,50 @@ preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo] preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env [] --- ----------------------------------------------------------------------------- - -data HomeUnitEnv = HomeUnitEnv - { homeUnitEnv_units :: !UnitState - -- ^ External units - - , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId]) - -- ^ Stack of unit databases for the target platform. - -- - -- This field is populated with the result of `initUnits`. - -- - -- 'Nothing' means the databases have never been read from disk. - -- - -- Usually we don't reload the databases from disk if they are - -- cached, even if the database flags changed! - - , homeUnitEnv_dflags :: DynFlags - -- ^ The dynamic flag settings - , homeUnitEnv_hpt :: HomePackageTable - -- ^ The home package table describes already-compiled - -- home-package modules, /excluding/ the module we - -- are compiling right now. - -- (In one-shot mode the current module is the only - -- home-package module, so homeUnitEnv_hpt is empty. All other - -- modules count as \"external-package\" modules. - -- However, even in GHCi mode, hi-boot interfaces are - -- demand-loaded into the external-package table.) - -- - -- 'homeUnitEnv_hpt' is not mutable because we only demand-load - -- external packages; the home package is eagerly - -- loaded, module by module, by the compilation manager. - -- - -- The HPT may contain modules compiled earlier by @--make@ - -- but not actually below the current module in the dependency - -- graph. - -- - -- (This changes a previous invariant: changed Jan 05.) - - , homeUnitEnv_home_unit :: !(Maybe HomeUnit) - -- ^ Home-unit - } - -instance Outputable HomeUnitEnv where - ppr hug = pprHPT (homeUnitEnv_hpt hug) - -homeUnitEnv_unsafeHomeUnit :: HomeUnitEnv -> HomeUnit -homeUnitEnv_unsafeHomeUnit hue = case homeUnitEnv_home_unit hue of - Nothing -> panic "homeUnitEnv_unsafeHomeUnit: No home unit" - Just h -> h - -mkHomeUnitEnv :: DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv -mkHomeUnitEnv dflags hpt home_unit = HomeUnitEnv - { homeUnitEnv_units = emptyUnitState - , homeUnitEnv_unit_dbs = Nothing - , homeUnitEnv_dflags = dflags - , homeUnitEnv_hpt = hpt - , homeUnitEnv_home_unit = home_unit - } - --- | Test if the module comes from the home unit +-- -- | Test if the module comes from the home unit isUnitEnvInstalledModule :: UnitEnv -> InstalledModule -> Bool isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu where hu = ue_unitHomeUnit_maybe (moduleUnit m) ue - -type HomeUnitGraph = UnitEnvGraph HomeUnitEnv - -lookupHugByModule :: Module -> HomeUnitGraph -> Maybe HomeModInfo -lookupHugByModule mod hug - | otherwise = do - env <- (unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug) - lookupHptByModule (homeUnitEnv_hpt env) mod - -hugElts :: HomeUnitGraph -> [(UnitId, HomeUnitEnv)] -hugElts hug = unitEnv_elts hug - -addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> HomeUnitGraph -addHomeModInfoToHug hmi hug = unitEnv_alter go hmi_unit hug - where - hmi_mod :: Module - hmi_mod = mi_module (hm_iface hmi) - - hmi_unit = toUnitId (moduleUnit hmi_mod) - _hmi_mn = moduleName hmi_mod - - go :: Maybe HomeUnitEnv -> Maybe HomeUnitEnv - go Nothing = pprPanic "addHomeInfoToHug" (ppr hmi_mod) - go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue) - -updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv -updateHueHpt f hue = - let !hpt = f (homeUnitEnv_hpt hue) - in hue { homeUnitEnv_hpt = hpt } - - -lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo -lookupHug hug uid mod = unitEnv_lookup_maybe uid hug >>= flip lookupHpt mod . homeUnitEnv_hpt - - -instance Outputable (UnitEnvGraph HomeUnitEnv) where - ppr g = ppr [(k, length (homeUnitEnv_hpt hue)) | (k, hue) <- (unitEnv_elts g)] - - -type UnitEnvGraphKey = UnitId - -newtype UnitEnvGraph v = UnitEnvGraph - { unitEnv_graph :: Map UnitEnvGraphKey v - } deriving (Functor, Foldable, Traversable) - -unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v -unitEnv_insert unitId env unitEnv = unitEnv - { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv) - } - -unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v -unitEnv_delete uid unitEnv = - unitEnv - { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv) - } - -unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v -unitEnv_adjust f uid unitEnv = unitEnv - { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv) - } - -unitEnv_alter :: (Maybe v -> Maybe v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v -unitEnv_alter f uid unitEnv = unitEnv - { unitEnv_graph = Map.alter f uid (unitEnv_graph unitEnv) - } - -unitEnv_mapWithKey :: (UnitEnvGraphKey -> v -> b) -> UnitEnvGraph v -> UnitEnvGraph b -unitEnv_mapWithKey f (UnitEnvGraph u) = UnitEnvGraph $ Map.mapWithKey f u - -unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v -unitEnv_new m = - UnitEnvGraph - { unitEnv_graph = m - } - -unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v -unitEnv_singleton active m = UnitEnvGraph - { unitEnv_graph = Map.singleton active m - } - -unitEnv_map :: (v -> v) -> UnitEnvGraph v -> UnitEnvGraph v -unitEnv_map f m = m { unitEnv_graph = Map.map f (unitEnv_graph m)} - -unitEnv_member :: UnitEnvGraphKey -> UnitEnvGraph v -> Bool -unitEnv_member u env = Map.member u (unitEnv_graph env) - -unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v -unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) - -unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v -unitEnv_lookup u env = fromJust $ unitEnv_lookup_maybe u env - -unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey -unitEnv_keys env = Map.keysSet (unitEnv_graph env) - -unitEnv_elts :: UnitEnvGraph v -> [(UnitEnvGraphKey, v)] -unitEnv_elts env = Map.toList (unitEnv_graph env) - -unitEnv_hpts :: UnitEnvGraph HomeUnitEnv -> [HomePackageTable] -unitEnv_hpts env = map homeUnitEnv_hpt (Map.elems (unitEnv_graph env)) - -unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b -unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g +-- ------------------------------------------------------- +-- Operations on arbitrary elements of the home unit graph +-- ------------------------------------------------------- -unitEnv_union :: (a -> a -> a) -> UnitEnvGraph a -> UnitEnvGraph a -> UnitEnvGraph a -unitEnv_union f (UnitEnvGraph env1) (UnitEnvGraph env2) = UnitEnvGraph (Map.unionWith f env1 env2) +ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv +ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) of + Nothing -> pprPanic "Unit unknown to the internal unit environment" + $ text "unit (" <> ppr uid <> text ")" + $$ ppr (HUG.allUnits (ue_home_unit_graph e)) + Just hue -> hue -- ------------------------------------------------------- --- Query and modify UnitState in HomeUnitEnv +-- Query and modify UnitState of active unit in HomeUnitEnv -- ------------------------------------------------------- -ue_units :: HasDebugCallStack => UnitEnv -> UnitState -ue_units = homeUnitEnv_units . ue_currentHomeUnitEnv - -ue_setUnits :: UnitState -> UnitEnv -> UnitEnv -ue_setUnits units ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue - where - f hue = hue { homeUnitEnv_units = units } +ue_homeUnitState :: HasDebugCallStack => UnitEnv -> UnitState +ue_homeUnitState = HUG.homeUnitEnv_units . ue_currentHomeUnitEnv ue_unit_dbs :: UnitEnv -> Maybe [UnitDatabase UnitId] -ue_unit_dbs = homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv - -ue_setUnitDbs :: Maybe [UnitDatabase UnitId] -> UnitEnv -> UnitEnv -ue_setUnitDbs unit_dbs ue = ue_updateHomeUnitEnv f (ue_currentUnit ue) ue - where - f hue = hue { homeUnitEnv_unit_dbs = unit_dbs } +ue_unit_dbs = HUG.homeUnitEnv_unit_dbs . ue_currentHomeUnitEnv -- ------------------------------------------------------- -- Query and modify Home Package Table in HomeUnitEnv -- ------------------------------------------------------- +-- | Get the /current home unit/'s package table ue_hpt :: HasDebugCallStack => UnitEnv -> HomePackageTable -ue_hpt = homeUnitEnv_hpt . ue_currentHomeUnitEnv - -ue_updateHPT_lazy :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv -ue_updateHPT_lazy f e = ue_updateUnitHPT_lazy f (ue_currentUnit e) e +ue_hpt = HUG.homeUnitEnv_hpt . ue_currentHomeUnitEnv -ue_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv -ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) e +-- | Inserts a 'HomeModInfo' at the given 'ModuleName' on the +-- 'HomePackageTable' of the /current unit/ being compiled. +insertHpt :: HasDebugCallStack => HomeModInfo -> UnitEnv -> IO () +insertHpt hmi e = do + HUG.addHomeModInfoToHug hmi (ue_home_unit_graph e) ue_updateHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ue_updateHUG f e = ue_updateUnitHUG f e -ue_updateUnitHPT_lazy :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv -ue_updateUnitHPT_lazy f uid ue_env = ue_updateHomeUnitEnv update uid ue_env - where - update unitEnv = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv } - -ue_updateUnitHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitId -> UnitEnv -> UnitEnv -ue_updateUnitHPT f uid ue_env = ue_updateHomeUnitEnv update uid ue_env - where - update unitEnv = - let !res = f $ homeUnitEnv_hpt unitEnv - in unitEnv { homeUnitEnv_hpt = res } - ue_updateUnitHUG :: HasDebugCallStack => (HomeUnitGraph -> HomeUnitGraph) -> UnitEnv -> UnitEnv ue_updateUnitHUG f ue_env = ue_env { ue_home_unit_graph = f (ue_home_unit_graph ue_env)} @@ -409,52 +288,48 @@ -- Query and modify DynFlags in HomeUnitEnv -- ------------------------------------------------------- -ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv -ue_setFlags dflags ue_env = ue_setUnitFlags (ue_currentUnit ue_env) dflags ue_env - -ue_setUnitFlags :: HasDebugCallStack => UnitId -> DynFlags -> UnitEnv -> UnitEnv -ue_setUnitFlags uid dflags e = - ue_updateUnitFlags (const dflags) uid e - ue_unitFlags :: HasDebugCallStack => UnitId -> UnitEnv -> DynFlags -ue_unitFlags uid ue_env = homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env +ue_unitFlags uid ue_env = HUG.homeUnitEnv_dflags $ ue_findHomeUnitEnv uid ue_env -ue_updateUnitFlags :: HasDebugCallStack => (DynFlags -> DynFlags) -> UnitId -> UnitEnv -> UnitEnv -ue_updateUnitFlags f uid e = ue_updateHomeUnitEnv update uid e - where - update hue = hue { homeUnitEnv_dflags = f $ homeUnitEnv_dflags hue } +-- | Sets the 'DynFlags' of the /current unit/ being compiled to the given ones +ue_setFlags :: HasDebugCallStack => DynFlags -> UnitEnv -> UnitEnv +ue_setFlags dflags env = + env + { ue_home_unit_graph = HUG.updateUnitFlags + (ue_currentUnit env) + (const dflags) + (ue_home_unit_graph env) + } -- ------------------------------------------------------- -- Query and modify home units in HomeUnitEnv -- ------------------------------------------------------- ue_homeUnit :: UnitEnv -> Maybe HomeUnit -ue_homeUnit = homeUnitEnv_home_unit . ue_currentHomeUnitEnv +ue_homeUnit = HUG.homeUnitEnv_home_unit . ue_currentHomeUnitEnv ue_unsafeHomeUnit :: UnitEnv -> HomeUnit ue_unsafeHomeUnit ue = case ue_homeUnit ue of - Nothing -> panic "unsafeGetHomeUnit: No home unit" + Nothing -> panic "ue_unsafeHomeUnit: No home unit" Just h -> h +ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit +ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid + ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit ue_unitHomeUnit_maybe uid ue_env = - homeUnitEnv_unsafeHomeUnit <$> (ue_findHomeUnitEnv_maybe uid ue_env) - -ue_unitHomeUnit :: UnitId -> UnitEnv -> HomeUnit -ue_unitHomeUnit uid ue_env = homeUnitEnv_unsafeHomeUnit $ ue_findHomeUnitEnv uid ue_env + HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env) -ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId -ue_all_home_unit_ids = unitEnv_keys . ue_home_unit_graph -- ------------------------------------------------------- -- Query and modify the currently active unit -- ------------------------------------------------------- ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv ue_currentHomeUnitEnv e = - case ue_findHomeUnitEnv_maybe (ue_currentUnit e) e of + case HUG.lookupHugUnitId (ue_currentUnit e) (ue_home_unit_graph e) of Just unitEnv -> unitEnv Nothing -> pprPanic "packageNotFound" $ - (ppr $ ue_currentUnit e) $$ ppr (ue_home_unit_graph e) + (ppr $ ue_currentUnit e) $$ ppr (HUG.allUnits (ue_home_unit_graph e)) ue_setActiveUnit :: UnitId -> UnitEnv -> UnitEnv ue_setActiveUnit u ue_env = assertUnitEnvInvariant $ ue_env @@ -465,84 +340,75 @@ ue_currentUnit = ue_current_unit --- ------------------------------------------------------- --- Operations on arbitrary elements of the home unit graph --- ------------------------------------------------------- - -ue_findHomeUnitEnv_maybe :: UnitId -> UnitEnv -> Maybe HomeUnitEnv -ue_findHomeUnitEnv_maybe uid e = - unitEnv_lookup_maybe uid (ue_home_unit_graph e) - -ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv -ue_findHomeUnitEnv uid e = case unitEnv_lookup_maybe uid (ue_home_unit_graph e) of - Nothing -> pprPanic "Unit unknown to the internal unit environment" - $ text "unit (" <> ppr uid <> text ")" - $$ pprUnitEnvGraph e - Just hue -> hue - ue_updateHomeUnitEnv :: (HomeUnitEnv -> HomeUnitEnv) -> UnitId -> UnitEnv -> UnitEnv ue_updateHomeUnitEnv f uid e = e - { ue_home_unit_graph = unitEnv_adjust f uid $ ue_home_unit_graph e + { ue_home_unit_graph = HUG.unitEnv_adjust f uid $ ue_home_unit_graph e } +ue_all_home_unit_ids :: UnitEnv -> Set.Set UnitId +ue_all_home_unit_ids = HUG.allUnits . ue_home_unit_graph -- | Rename a unit id in the internal unit env. -- --- @'ue_renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the map, +-- @'renameUnitId' oldUnit newUnit UnitEnv@, it is assumed that the 'oldUnit' exists in the home units map, -- otherwise we panic. -- The 'DynFlags' associated with the home unit will have its field 'homeUnitId' set to 'newUnit'. -ue_renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv -ue_renameUnitId oldUnit newUnit unitEnv = case ue_findHomeUnitEnv_maybe oldUnit unitEnv of - Nothing -> - pprPanic "Tried to rename unit, but it didn't exist" - $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\"" - $$ nest 2 (pprUnitEnvGraph unitEnv) - Just oldEnv -> - let - activeUnit :: UnitId - !activeUnit = if ue_currentUnit unitEnv == oldUnit - then newUnit - else ue_currentUnit unitEnv +renameUnitId :: HasDebugCallStack => UnitId -> UnitId -> UnitEnv -> UnitEnv +renameUnitId oldUnit newUnit unitEnv = + case HUG.renameUnitId oldUnit newUnit (ue_home_unit_graph unitEnv) of + Nothing -> + pprPanic "Tried to rename unit, but it didn't exist" + $ text "Rename old unit \"" <> ppr oldUnit <> text "\" to \""<> ppr newUnit <> text "\"" + $$ nest 2 (ppr $ HUG.allUnits (ue_home_unit_graph unitEnv)) + Just newHug -> + let + activeUnit :: UnitId + !activeUnit = if ue_currentUnit unitEnv == oldUnit + then newUnit + else ue_currentUnit unitEnv - newInternalUnitEnv = oldEnv - { homeUnitEnv_dflags = (homeUnitEnv_dflags oldEnv) - { homeUnitId_ = newUnit - } + in + unitEnv + { ue_current_unit = activeUnit + , ue_home_unit_graph = + HUG.updateUnitFlags + newUnit + (\df -> df{ homeUnitId_ = newUnit }) + newHug } - in - unitEnv - { ue_current_unit = activeUnit - , ue_home_unit_graph = - unitEnv_insert newUnit newInternalUnitEnv - $ unitEnv_delete oldUnit - $ ue_home_unit_graph unitEnv - } -- --------------------------------------------- +-- Transitive closure +-- --------------------------------------------- + +ue_transitiveHomeDeps :: UnitId -> UnitEnv -> [UnitId] +ue_transitiveHomeDeps uid e = + case HUG.transitiveHomeDeps uid (ue_home_unit_graph e) of + Nothing -> pprPanic "Unit unknown to the internal unit environment" + $ text "unit (" <> ppr uid <> text ")" + $$ ppr (HUG.allUnits $ ue_home_unit_graph e) + Just deps -> deps + +-- --------------------------------------------- -- Asserts to enforce invariants for the UnitEnv -- --------------------------------------------- +-- FIXME: Shouldn't this be a proper assertion only used in debug mode? assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv assertUnitEnvInvariant u = - if ue_current_unit u `unitEnv_member` ue_home_unit_graph u - then u - else pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (ue_home_unit_graph u)) + case HUG.lookupHugUnitId (ue_current_unit u) (ue_home_unit_graph u) of + Just _ -> u + Nothing -> + pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (HUG.allUnits (ue_home_unit_graph u))) -- ----------------------------------------------------------------------------- -- Pretty output functions -- ----------------------------------------------------------------------------- -pprUnitEnvGraph :: UnitEnv -> SDoc -pprUnitEnvGraph env = text "pprInternalUnitMap" - $$ nest 2 (pprHomeUnitGraph $ ue_home_unit_graph env) - -pprHomeUnitGraph :: HomeUnitGraph -> SDoc -pprHomeUnitGraph unitEnv = vcat (map (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv) - -pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> SDoc -pprHomeUnitEnv uid env = - ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" - $$ nest 4 (pprHPT $ homeUnitEnv_hpt env) +-- pprUnitEnvGraph :: UnitEnv -> IO SDoc +-- pprUnitEnvGraph env = do +-- hugDoc <- HUG.pprHomeUnitGraph $ ue_home_unit_graph env +-- return $ text "pprInternalUnitMap" $$ nest 2 hugDoc {- Note [Multiple Home Units] @@ -596,3 +462,12 @@ in order to allow users to offset their own relative paths. -} + +-------------------------------------------------------------------------------- +-- * Legacy API +-------------------------------------------------------------------------------- + +{-# DEPRECATED ue_units "Renamed to ue_homeUnitState because of confusion between units(tate) and unit(s) plural" #-} +ue_units :: HasDebugCallStack => UnitEnv -> UnitState +ue_units = ue_homeUnitState + diff --git a/GHC/Unit/External.hs b/GHC/Unit/External.hs --- a/GHC/Unit/External.hs +++ b/GHC/Unit/External.hs @@ -28,9 +28,12 @@ import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch +import GHC.Types.DefaultEnv (DefaultEnv) import GHC.Types.TypeEnv import GHC.Types.Unique.DSet +import GHC.Linker.Types (Linkable) + import Data.IORef @@ -39,7 +42,7 @@ type PackageInstEnv = InstEnv type PackageFamInstEnv = FamInstEnv type PackageAnnEnv = AnnEnv -type PackageCompleteMatches = CompleteMatches +type PackageCompleteMatches = CompleteMatches -- | Helps us find information about modules in the imported packages type PackageIfaceTable = ModuleEnv ModIface @@ -68,6 +71,7 @@ , eps_PIT = emptyPackageIfaceTable , eps_free_holes = emptyInstalledModuleEnv , eps_PTE = emptyTypeEnv + , eps_iface_bytecode = emptyModuleEnv , eps_inst_env = emptyInstEnv , eps_fam_inst_env = emptyFamInstEnv , eps_rule_base = mkRuleBase builtinRules @@ -84,6 +88,7 @@ , n_rules_in = length builtinRules , n_rules_out = 0 } + , eps_defaults = emptyModuleEnv } @@ -139,6 +144,12 @@ -- interface files we have sucked in. The domain of -- the mapping is external-package modules + -- | If an interface was written with @-fwrite-if-simplified-core@, this + -- will contain an IO action that compiles bytecode from core bindings. + -- + -- See Note [Interface Files with Core Definitions] + eps_iface_bytecode :: !(ModuleEnv (IO Linkable)), + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated -- from all the external-package modules eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated @@ -154,7 +165,8 @@ eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external -- packages, keyed off the module that declared them - eps_stats :: !EpsStats -- ^ Statistics about what was loaded from external packages + eps_stats :: !EpsStats, -- ^ Statistics about what was loaded from external packages + eps_defaults :: !(ModuleEnv DefaultEnv) -- ^ Default declarations exported by external packages } -- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. diff --git a/GHC/Unit/Finder.hs b/GHC/Unit/Finder.hs --- a/GHC/Unit/Finder.hs +++ b/GHC/Unit/Finder.hs @@ -5,16 +5,17 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} -- | Module finder module GHC.Unit.Finder ( FindResult(..), InstalledFindResult(..), FinderOpts(..), - FinderCache, + FinderCache(..), initFinderCache, - flushFinderCaches, findImportedModule, + findImportedModuleWithIsBoot, findPluginModule, findExactModule, findHomeModule, @@ -26,30 +27,27 @@ mkObjPath, addModuleToFinder, addHomeModuleToFinder, - uncacheModule, mkStubPaths, findObjectLinkableMaybe, findObjectLinkable, - - -- Hash cache - lookupFileCache ) where import GHC.Prelude import GHC.Platform.Ways -import GHC.Builtin.Names ( gHC_PRIM ) +import GHC.Data.OsPath import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home +import GHC.Unit.Home.Graph (UnitEnvGraph) +import qualified GHC.Unit.Home.Graph as HUG import GHC.Unit.State import GHC.Unit.Finder.Types -import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.ShortText as ST import GHC.Utils.Misc @@ -58,21 +56,24 @@ import GHC.Linker.Types import GHC.Types.PkgQual +import GHC.Types.SourceFile 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 import GHC.Driver.Env - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) ) import GHC.Driver.Config.Finder import qualified Data.Set as Set +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified System.OsPath as OsPath +import qualified Data.List.NonEmpty as NE -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file +type FileExt = OsString -- Filename extension +type BaseName = OsPath -- Basename of file -- ----------------------------------------------------------------------------- -- The Finder @@ -87,43 +88,56 @@ -- ----------------------------------------------------------------------------- -- The finder's cache +{- +[Note: Monotonic addToFinderCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -initFinderCache :: IO FinderCache -initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv - <*> newIORef M.empty +addToFinderCache is only used by functions that return the cached value +if there is one, or by functions that always write an InstalledFound value. +Without multithreading it is then safe to always directly write the value +without checking the previously cached value. --- 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) +However, with multithreading, it is possible that another function has +written a value into cache between the lookup and the addToFinderCache call. +in this case we should check to not overwrite an InstalledFound with an +InstalledNotFound. +-} -addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO () -addToFinderCache (FinderCache ref _) key val = - atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ()) +initFinderCache :: IO FinderCache +initFinderCache = do + mod_cache <- newIORef emptyInstalledModuleEnv + file_cache <- newIORef M.empty + let flushFinderCaches :: UnitEnv -> IO () + flushFinderCaches ue = do + atomicModifyIORef' mod_cache $ \fm -> (filterInstalledModuleEnv is_ext fm, ()) + atomicModifyIORef' file_cache $ \_ -> (M.empty, ()) + where + is_ext mod _ = not (isUnitEnvInstalledModule ue mod) -removeFromFinderCache :: FinderCache -> InstalledModule -> IO () -removeFromFinderCache (FinderCache ref _) key = - atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ()) + addToFinderCache :: InstalledModule -> InstalledFindResult -> IO () + addToFinderCache key val = + atomicModifyIORef' mod_cache $ \c -> + case (lookupInstalledModuleEnv c key, val) of + -- Don't overwrite an InstalledFound with an InstalledNotFound + -- See [Note Monotonic addToFinderCache] + (Just InstalledFound{}, InstalledNotFound{}) -> (c, ()) + _ -> (extendInstalledModuleEnv c key val, ()) -lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult) -lookupFinderCache (FinderCache ref _) key = do - c <- readIORef ref - return $! lookupInstalledModuleEnv c key + lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult) + lookupFinderCache key = do + c <- readIORef mod_cache + return $! lookupInstalledModuleEnv 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 @@ -144,6 +158,13 @@ in do findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual +findImportedModuleWithIsBoot :: HscEnv -> ModuleName -> IsBootInterface -> PkgQual -> IO FindResult +findImportedModuleWithIsBoot hsc_env mod is_boot pkg_qual = do + res <- findImportedModule hsc_env mod pkg_qual + case (res, is_boot) of + (Found loc mod, IsBoot) -> return (Found (addBootSuffixLocn loc) mod) + _ -> return res + findImportedModuleNoHsc :: FinderCache -> FinderOpts @@ -173,8 +194,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 = @@ -183,7 +204,7 @@ -- Do not be smart and change this to `foldr orIfNotFound home_import hs` as -- that is not the same!! home_import is first because we need to look within ourselves -- first before looking at the packages in order. - any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts) + any_home_import = foldr1 orIfNotFound (home_import:| map home_pkg_import other_fopts) pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg @@ -192,8 +213,8 @@ findExposedPackageModule fc fopts units mod_name NoPkgQual units = case mhome_unit of - Nothing -> ue_units ue - Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue + Nothing -> ue_homeUnitState ue + Just home_unit -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue hpt_deps :: [UnitId] hpt_deps = homeUnitDepends units other_fopts = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps @@ -202,30 +223,53 @@ -- plugin. This consults the same set of exposed packages as -- 'findImportedModule', unless @-hide-all-plugin-packages@ or -- @-plugin-package@ are specified. -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult -findPluginModule fc fopts units (Just home_unit) mod_name = +findPluginModuleNoHsc :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult +findPluginModuleNoHsc fc fopts units (Just home_unit) mod_name = findHomeModule fc fopts home_unit mod_name `orIfNotFound` findExposedPluginPackageModule fc fopts units mod_name -findPluginModule fc fopts units Nothing mod_name = +findPluginModuleNoHsc fc fopts units Nothing mod_name = findExposedPluginPackageModule fc fopts units mod_name --- | Locate a specific 'Module'. The purpose of this function is to --- create a 'ModLocation' for a given 'Module', that is to find out --- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, --- for example (a "system import"). +findPluginModule :: HscEnv -> ModuleName -> IO FindResult +findPluginModule hsc_env mod_name = do + let fc = hsc_FC hsc_env + let units = hsc_units hsc_env + let mhome_unit = hsc_home_unit_maybe hsc_env + findPluginModuleNoHsc fc (initFinderOpts (hsc_dflags hsc_env)) units mhome_unit mod_name -findExactModule :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult -findExactModule fc fopts other_fopts unit_state mhome_unit mod = do - case mhome_unit of + +-- | A version of findExactModule which takes the exact parts of the HscEnv it needs +-- directly. +findExactModuleNoHsc :: FinderCache -> FinderOpts -> UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModuleNoHsc fc fopts other_fopts unit_state mhome_unit mod is_boot = do + res <- case mhome_unit of Just home_unit | isHomeInstalledModule home_unit mod -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod) - | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts + | Just home_fopts <- HUG.unitEnv_lookup_maybe (moduleUnit mod) other_fopts -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod) _ -> findPackageModule fc unit_state fopts mod + case (res, is_boot) of + (InstalledFound loc, IsBoot) -> return (InstalledFound (addBootSuffixLocn loc)) + _ -> return res + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). +findExactModule :: HscEnv -> InstalledModule -> IsBootInterface -> IO InstalledFindResult +findExactModule hsc_env mod is_boot = do + let dflags = hsc_dflags hsc_env + let fc = hsc_FC hsc_env + let unit_state = hsc_units hsc_env + let home_unit = hsc_home_unit_maybe hsc_env + let other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env) + findExactModuleNoHsc fc (initFinderOpts dflags) other_fopts unit_state home_unit mod is_boot + + -- ----------------------------------------------------------------------------- -- Helpers @@ -284,9 +328,9 @@ -- with just the location of the thing that was -- instantiated; you probably also need all of the -- implicit locations from the instances - InstalledFound loc _ -> return (Found loc m) + InstalledFound loc -> return (Found loc m) InstalledNoPackage _ -> return (NoPackage (moduleUnit m)) - InstalledNotFound fp _ -> return (NotFound{ fr_paths = 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 = [] @@ -329,23 +373,20 @@ addToFinderCache fc mod result return result -addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO () -addModuleToFinder fc mod loc = do +addModuleToFinder :: FinderCache -> Module -> ModLocation -> HscSource -> IO () +addModuleToFinder fc mod loc src_flavour = do let imod = toUnitId <$> mod - addToFinderCache fc imod (InstalledFound loc imod) + unless (src_flavour == HsBootFile) $ + addToFinderCache fc imod (InstalledFound loc) -- This returns a module because it's more convenient for users -addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module -addHomeModuleToFinder fc home_unit mod_name loc = do +addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> HscSource -> IO Module +addHomeModuleToFinder fc home_unit mod_name loc src_flavour = do let mod = mkHomeInstalledModule home_unit mod_name - addToFinderCache fc mod (InstalledFound loc mod) + unless (src_flavour == HsBootFile) $ + addToFinderCache fc mod (InstalledFound loc) 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 - -- ----------------------------------------------------------------------------- -- The internal workers @@ -354,10 +395,10 @@ let uid = homeUnitAsUnit home_unit r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name return $ case r of - InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name) + InstalledFound loc -> Found loc (mkHomeModule home_unit mod_name) InstalledNoPackage _ -> NoPackage uid -- impossible InstalledNotFound fps _ -> NotFound { - fr_paths = fps, + fr_paths = fmap unsafeDecodeUtf fps, fr_pkg = Just uid, fr_mods_hidden = [], fr_pkgs_hidden = [], @@ -379,10 +420,10 @@ let uid = RealUnit (Definite home_unit) r <- findInstalledHomeModule fc fopts home_unit mod_name return $ case r of - InstalledFound loc _ -> Found loc (mkModule uid mod_name) + InstalledFound loc -> Found loc (mkModule uid mod_name) InstalledNoPackage _ -> NoPackage uid -- impossible InstalledNotFound fps _ -> NotFound { - fr_paths = fps, + fr_paths = fmap unsafeDecodeUtf fps, fr_pkg = Just uid, fr_mods_hidden = [], fr_pkgs_hidden = [], @@ -418,17 +459,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 @@ -443,20 +484,14 @@ (search_dirs, exts) | finder_lookupHomeInterfaces fopts = (hi_dir_path, hi_exts) | otherwise = (home_path, source_exts) - in - - -- special case for GHC.Prim; we won't find it in the filesystem. - -- This is important only when compiling the base package (where GHC.Prim - -- is a home module). - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else searchPathExts search_dirs mod exts + in searchPathExts search_dirs mod exts -- | Prepend the working directory to the search path. -augmentImports :: 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 @@ -478,24 +513,18 @@ massertPpr (moduleUnit mod == unitId pkg_conf) (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf)) modLocationCache fc mod $ - - -- special case for GHC.Prim; we won't find it in the filesystem. - if mod `installedModuleEq` gHC_PRIM - then return (InstalledFound (error "GHC.Prim ModLocation") mod) - else - let 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,33 +532,33 @@ [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 + in return $ InstalledFound loc _otherwise -> searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] -- ----------------------------------------------------------------------------- -- 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 ] @@ -539,11 +568,11 @@ search ((file, loc) : rest) = do b <- doesFileExist file if b - then return $ InstalledFound loc mod + then return $ InstalledFound loc else search rest mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt - -> FilePath -> BaseName -> ModLocation + -> OsPath -> BaseName -> ModLocation mkHomeModLocationSearched fopts mod suff path basename = mkHomeModLocation2 fopts mod (path basename) suff @@ -581,18 +610,20 @@ -- ext -- The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation -mkHomeModLocation dflags mod src_filename = - let (basename,extension) = splitExtension src_filename - in mkHomeModLocation2 dflags mod basename extension +mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> FileExt -> HscSource -> ModLocation +mkHomeModLocation dflags mod src_basename ext hsc_src = + let loc = mkHomeModLocation2 dflags mod src_basename ext + in case hsc_src of + HsBootFile -> addBootSuffixLocnOut loc + _ -> loc mkHomeModLocation2 :: FinderOpts -> ModuleName - -> 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 +631,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 +688,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 +704,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 +719,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 +734,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 +753,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 +790,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) diff --git a/GHC/Unit/Finder/Types.hs b/GHC/Unit/Finder/Types.hs --- a/GHC/Unit/Finder/Types.hs +++ b/GHC/Unit/Finder/Types.hs @@ -1,6 +1,7 @@ module GHC.Unit.Finder.Types ( FinderCache (..) , FinderCacheState + , FileCacheState , FindResult (..) , InstalledFindResult (..) , FinderOpts(..) @@ -9,11 +10,12 @@ import GHC.Prelude import GHC.Unit +import GHC.Data.OsPath import qualified Data.Map as M import GHC.Fingerprint import GHC.Platform.Ways +import GHC.Unit.Env -import Data.IORef import GHC.Data.FastString import qualified Data.Set as Set @@ -24,14 +26,23 @@ -- type FinderCacheState = InstalledModuleEnv InstalledFindResult type FileCacheState = M.Map FilePath Fingerprint -data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState) - , fcFileCache :: (IORef FileCacheState) +data FinderCache = FinderCache { flushFinderCaches :: UnitEnv -> IO () + -- ^ 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. + , addToFinderCache :: InstalledModule -> InstalledFindResult -> IO () + -- ^ Add a found location to the cache for the module. + , lookupFinderCache :: InstalledModule -> IO (Maybe InstalledFindResult) + -- ^ Look for a location in the cache. + , lookupFileCache :: FilePath -> IO Fingerprint + -- ^ Look for the hash of a file in the cache. This should add it to the + -- cache. If the file doesn't exist, raise an IOException. } data InstalledFindResult - = InstalledFound ModLocation InstalledModule + = InstalledFound ModLocation | InstalledNoPackage UnitId - | InstalledNotFound [FilePath] (Maybe UnitId) + | InstalledNotFound [OsPath] (Maybe UnitId) -- | The result of searching for an imported module. -- @@ -70,7 +81,7 @@ -- -- Should be taken from 'DynFlags' via 'initFinderOpts'. data FinderOpts = FinderOpts - { finder_importPaths :: [FilePath] + { finder_importPaths :: [OsPath] -- ^ Where are we allowed to look for Modules and Source files , finder_lookupHomeInterfaces :: Bool -- ^ When looking up a home module: @@ -88,17 +99,17 @@ , finder_enableSuggestions :: Bool -- ^ If we encounter unknown modules, should we suggest modules -- that have a similar name. - , finder_workingDirectory :: Maybe FilePath + , finder_workingDirectory :: Maybe OsPath , finder_thisPackageName :: Maybe FastString , finder_hiddenModules :: Set.Set ModuleName - , finder_reexportedModules :: Set.Set ModuleName - , finder_hieDir :: Maybe FilePath - , finder_hieSuf :: String - , finder_hiDir :: Maybe FilePath - , finder_hiSuf :: String - , finder_dynHiSuf :: String - , finder_objectDir :: Maybe FilePath - , finder_objectSuf :: String - , finder_dynObjectSuf :: String - , finder_stubDir :: Maybe FilePath - } deriving Show + , finder_reexportedModules :: M.Map ModuleName ModuleName -- Reverse mapping, if you are looking for this name then look for this module. + , finder_hieDir :: Maybe OsPath + , finder_hieSuf :: OsString + , finder_hiDir :: Maybe OsPath + , finder_hiSuf :: OsString + , finder_dynHiSuf :: OsString + , finder_objectDir :: Maybe OsPath + , finder_objectSuf :: OsString + , finder_dynObjectSuf :: OsString + , finder_stubDir :: Maybe OsPath + } diff --git a/GHC/Unit/Home/Graph.hs b/GHC/Unit/Home/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Home/Graph.hs @@ -0,0 +1,381 @@ +-- | A 'HomeUnitGraph' (HUG) collects information about all the home units. +-- Crucially, each node in a 'HomeUnitGraph' includes a 'HomePackageTable'. +-- +-- Often, we don't want to query just a single 'HomePackageTable', but rather all +-- 'HomePackageTable's of all home units. +-- +-- This module is responsible for maintaining this bridge between querying all +-- home units vs querying the home package table directly. Think 'lookupHug' vs +-- 'lookupHpt', 'hugAllInstances' vs 'hptAllInstances', where the @hug@ version +-- replies with information from all home units, and the @hpt@ version with +-- information pertaining to a single home unit. +-- +-- Meant to be imported qualified as @HUG@. +-- Example usage: +-- +-- @ +-- import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv) +-- import qualified GHC.Unit.Home.Graph as HUG +-- usage = ... HUG.insertHug hug uid modname modinfo ... +-- @ +module GHC.Unit.Home.Graph + ( HomeUnitGraph + , HomeUnitEnv(..) + , mkHomeUnitEnv + + -- * Operations + , addHomeModInfoToHug + , restrictHug + , renameUnitId + , allUnits + , updateUnitFlags + + -- ** Lookups + , lookupHug + , lookupHugByModule + , lookupHugUnit + , lookupHugUnitId + , lookupAllHug + , memberHugUnit + , memberHugUnitId + -- ** Reachability + , transitiveHomeDeps + + -- * Very important queries + , allInstances + , allFamInstances + , allAnns + , allCompleteSigs + + -- * Utilities + , hugSCCs + , hugFromList + + -- ** Printing + , pprHomeUnitGraph + , pprHomeUnitEnv + + -- * Auxiliary internal structure + , UnitEnvGraph(..) + , unitEnv_lookup_maybe + , unitEnv_foldWithKey + , unitEnv_singleton + , unitEnv_adjust + , unitEnv_keys + , unitEnv_insert + , unitEnv_new + , unitEnv_lookup + , unitEnv_traverseWithKey + , unitEnv_assocs + ) where + +import GHC.Prelude + +import GHC.Driver.DynFlags +import GHC.Unit.Home +import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.State +import GHC.Utils.Monad (mapMaybeM) +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Core.FamInstEnv + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import GHC.Data.Maybe +import GHC.Data.Graph.Directed + +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Core.InstEnv + + +-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across +-- all home units. +allCompleteSigs :: HomeUnitGraph -> IO CompleteMatches +allCompleteSigs hug = foldr go (pure []) hug where + go hue = liftA2 (++) (hptCompleteSigs (homeUnitEnv_hpt hue)) + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +allInstances :: HomeUnitGraph -> IO (InstEnv, [FamInst]) +allInstances hug = foldr go (pure (emptyInstEnv, [])) hug where + go hue = liftA2 (\(a,b) (a',b') -> (a `unionInstEnv` a', b ++ b')) + (hptAllInstances (homeUnitEnv_hpt hue)) + +allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv) +allFamInstances hug = foldr go (pure emptyModuleEnv) hug where + go hue = liftA2 plusModuleEnv (hptAllFamInstances (homeUnitEnv_hpt hue)) + +allAnns :: HomeUnitGraph -> IO AnnEnv +allAnns hug = foldr go (pure emptyAnnEnv) hug where + go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) + +-------------------------------------------------------------------------------- +-- HomeUnitGraph (HUG) +-------------------------------------------------------------------------------- + +type HomeUnitGraph = UnitEnvGraph HomeUnitEnv + +data HomeUnitEnv = HomeUnitEnv + { homeUnitEnv_units :: !UnitState + -- ^ External units + + , homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId]) + -- ^ Stack of unit databases for the target platform. + -- + -- This field is populated with the result of `initUnits`. + -- + -- 'Nothing' means the databases have never been read from disk. + -- + -- Usually we don't reload the databases from disk if they are + -- cached, even if the database flags changed! + + , homeUnitEnv_dflags :: DynFlags + -- ^ The dynamic flag settings + , homeUnitEnv_hpt :: HomePackageTable + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so homeUnitEnv_hpt is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'homeUnitEnv_hpt' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + , homeUnitEnv_home_unit :: !(Maybe HomeUnit) + -- ^ Home-unit + } + +mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv +mkHomeUnitEnv us dbs dflags hpt home_unit = HomeUnitEnv + { homeUnitEnv_units = us + , homeUnitEnv_unit_dbs = dbs + , homeUnitEnv_dflags = dflags + , homeUnitEnv_hpt = hpt + , homeUnitEnv_home_unit = home_unit + } + +-------------------------------------------------------------------------------- +-- * Operations on HUG +-------------------------------------------------------------------------------- + +-- | Add an entry to the 'HomePackageTable' under the unit of that entry. +addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> IO () +addHomeModInfoToHug hmi hug = + case unitEnv_lookup_maybe hmi_unit hug of + Nothing -> pprPanic "addHomeInfoToHug" (ppr hmi_mod) + Just hue -> do + addHomeModInfoToHpt hmi (homeUnitEnv_hpt hue) + where + hmi_mod :: Module + hmi_mod = mi_module (hm_iface hmi) + hmi_unit = toUnitId (moduleUnit hmi_mod) + +-- | Thin each HPT variable to only contain keys from the given dependencies. +-- This is used at the end of upsweep to make sure that only completely successfully loaded +-- modules are visible for subsequent operations. +restrictHug :: [(UnitId, [HomeModInfo])] -> HomeUnitGraph -> IO () +restrictHug deps hug = unitEnv_foldWithKey (\k uid hue -> restrict_one uid hue >> k) (return ()) hug + where + deps_map = Map.fromList deps + restrict_one uid hue = + restrictHpt (homeUnitEnv_hpt hue) (Map.findWithDefault [] uid deps_map) + +-- | Rename a unit id in the 'HomeUnitGraph' +-- +-- @'renameUnitId' oldUnit newUnit hug@, if @oldUnit@ is not found in @hug@, returns 'Nothing'. +-- If it exists, the result maps @newUnit@ to the 'HomeUnitEnv' of the +-- @oldUnit@ (and @oldUnit@ is removed from @hug@) +renameUnitId :: UnitId -> UnitId -> HomeUnitGraph -> Maybe HomeUnitGraph +renameUnitId oldUnit newUnit hug = case unitEnv_lookup_maybe oldUnit hug of + Nothing -> Nothing + Just oldHue -> pure $ + unitEnv_insert newUnit oldHue $ + unitEnv_delete oldUnit hug + +-- | Retrieve all 'UnitId's of units in the 'HomeUnitGraph'. +allUnits :: HomeUnitGraph -> Set.Set UnitId +allUnits = unitEnv_keys + +-- | Set the 'DynFlags' of the 'HomeUnitEnv' for unit in the 'HomeModuleGraph' +updateUnitFlags :: UnitId -> (DynFlags -> DynFlags) -> HomeUnitGraph -> HomeUnitGraph +updateUnitFlags uid f = unitEnv_adjust update uid + where + update hue = hue { homeUnitEnv_dflags = f (homeUnitEnv_dflags hue) } + +-------------------------------------------------------------------------------- +-- ** Reachability +-------------------------------------------------------------------------------- + +-- | Compute the transitive closure of a unit in the 'HomeUnitGraph'. +-- If the argument unit is not present in the graph returns Nothing. +transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId] +transitiveHomeDeps uid hug = case lookupHugUnitId uid hug of + Nothing -> Nothing + Just hue -> Just $ + Set.toList (loop (Set.singleton uid) (homeUnitDepends (homeUnitEnv_units hue))) + where + loop acc [] = acc + loop acc (uid:uids) + | uid `Set.member` acc = loop acc uids + | otherwise = + let hue = homeUnitDepends + . homeUnitEnv_units + . expectJust + $ lookupHugUnitId uid hug + in loop (Set.insert uid acc) (hue ++ uids) + +-------------------------------------------------------------------------------- +-- ** Lookups +-------------------------------------------------------------------------------- + +-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' given its +-- 'UnitId' and 'ModuleName' (via the 'HomePackageTable' of the corresponding unit) +lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo) +lookupHug hug uid mod = do + case unitEnv_lookup_maybe uid hug of + Nothing -> pure Nothing + Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod + +-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit) +lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo) +lookupHugByModule mod hug = + case lookupHugUnit (moduleUnit mod) hug of + Nothing -> pure Nothing + Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod + +-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'. +-- 'ModuleName's are not unique in the case of multiple home units, so there can be +-- more than one possible 'HomeModInfo'. +-- +-- You should always prefer 'lookupHug' and 'lookupHugByModule' when possible. +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo] +lookupAllHug hug mod = mapMaybeM (\uid -> lookupHug hug uid mod) (Set.toList $ unitEnv_keys hug) + +-- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph' +lookupHugUnitId :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv +lookupHugUnitId = unitEnv_lookup_maybe + +-- | Check whether the 'UnitId' is present in the 'HomeUnitGraph' +memberHugUnitId :: UnitId -> HomeUnitGraph -> Bool +memberHugUnitId u = isJust . lookupHugUnitId u + +-- | Lookup up the 'HomeUnitEnv' by the 'Unit' in the 'HomeUnitGraph'. +-- If the 'Unit' can be turned into a 'UnitId', we behave identical to 'lookupHugUnitId'. +-- +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's +lookupHugUnit :: Unit -> HomeUnitGraph -> Maybe HomeUnitEnv +lookupHugUnit unit hug = + if isHoleUnit unit + then Nothing + else lookupHugUnitId (toUnitId unit) hug + +-- | Check whether the 'Unit' is present in the 'HomeUnitGraph' +-- +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's +memberHugUnit :: Unit -> HomeUnitGraph -> Bool +memberHugUnit u = isJust . lookupHugUnit u + +-------------------------------------------------------------------------------- +-- * Internal representation map +-------------------------------------------------------------------------------- +-- Note: we purposefully do not export functions like "elems" to maintain a +-- good clean interface with the HUG. + +type UnitEnvGraphKey = UnitId + +newtype UnitEnvGraph v = UnitEnvGraph + { unitEnv_graph :: Map UnitEnvGraphKey v + } deriving (Functor, Foldable, Traversable) + +unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v +unitEnv_new m = + UnitEnvGraph + { unitEnv_graph = m + } + +unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_insert unitId env unitEnv = unitEnv + { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv) + } + +unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_delete uid unitEnv = + unitEnv + { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv) + } + +unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v +unitEnv_adjust f uid unitEnv = unitEnv + { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv) + } + +unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v +unitEnv_singleton active m = UnitEnvGraph + { unitEnv_graph = Map.singleton active m + } + +unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v +unitEnv_lookup_maybe u env = Map.lookup u (unitEnv_graph env) + +unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey +unitEnv_keys env = Map.keysSet (unitEnv_graph env) + +unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b +unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g + +unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v +unitEnv_lookup u env = expectJust $ unitEnv_lookup_maybe u env + +unitEnv_traverseWithKey :: Applicative f => (UnitEnvGraphKey -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b) +unitEnv_traverseWithKey f unitEnv = + UnitEnvGraph <$> Map.traverseWithKey f (unitEnv_graph unitEnv) + +unitEnv_assocs :: UnitEnvGraph a -> [(UnitEnvGraphKey, a)] +unitEnv_assocs (UnitEnvGraph x) = Map.assocs x + +-------------------------------------------------------------------------------- +-- * Utilities +-------------------------------------------------------------------------------- + +hugSCCs :: HomeUnitGraph -> [SCC UnitId] +hugSCCs hug = sccs where + mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId + mkNode (uid, hue) = DigraphNode uid uid (homeUnitDepends (homeUnitEnv_units hue)) + nodes = map mkNode (Map.toList $ unitEnv_graph hug) + + sccs = stronglyConnCompFromEdgedVerticesOrd nodes + +hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph +hugFromList = UnitEnvGraph . Map.fromList + +pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc +pprHomeUnitGraph unitEnv = do + docs <- mapM (\(k, v) -> pprHomeUnitEnv k v) $ Map.assocs $ unitEnv_graph unitEnv + return $ vcat docs + +pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc +pprHomeUnitEnv uid env = do + hptDoc <- pprHPT $ homeUnitEnv_hpt env + return $ + ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->" + $$ nest 4 hptDoc + diff --git a/GHC/Unit/Home/ModInfo.hs b/GHC/Unit/Home/ModInfo.hs --- a/GHC/Unit/Home/ModInfo.hs +++ b/GHC/Unit/Home/ModInfo.hs @@ -1,6 +1,8 @@ --- | Info about modules in the "home" unit +-- | Info about modules in the "home" unit. +-- Stored in a 'HomePackageTable'. module GHC.Unit.Home.ModInfo - ( HomeModInfo (..) + ( + HomeModInfo (..) , HomeModLinkable(..) , homeModInfoObject , homeModInfoByteCode @@ -8,23 +10,6 @@ , justBytecode , justObjects , bytecodeAndObjects - , HomePackageTable - , emptyHomePackageTable - , lookupHpt - , eltsHpt - , filterHpt - , allHpt - , anyHpt - , mapHpt - , delFromHpt - , addToHpt - , addHomeModInfoToHpt - , addListToHpt - , lookupHptDirectly - , lookupHptByModule - , listToHpt - , listHMIToHpt - , pprHPT ) where @@ -32,18 +17,13 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails -import GHC.Unit.Module -import GHC.Linker.Types ( Linkable(..), isObjectLinkable ) - -import GHC.Types.Unique -import GHC.Types.Unique.DFM +import GHC.Linker.Types ( Linkable(..), linkableIsNativeCodeOnly ) import GHC.Utils.Outputable -import Data.List (sortOn) -import Data.Ord import GHC.Utils.Panic + -- | Information about modules in the package being compiled data HomeModInfo = HomeModInfo { hm_iface :: !ModIface @@ -90,17 +70,17 @@ justBytecode :: Linkable -> HomeModLinkable justBytecode lm = - assertPpr (not (isObjectLinkable lm)) (ppr lm) + assertPpr (not (linkableIsNativeCodeOnly lm)) (ppr lm) $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } justObjects :: Linkable -> HomeModLinkable justObjects lm = - assertPpr (isObjectLinkable lm) (ppr lm) + assertPpr (linkableIsNativeCodeOnly lm) (ppr lm) $ emptyHomeModInfoLinkable { homeMod_object = Just lm } bytecodeAndObjects :: Linkable -> Linkable -> HomeModLinkable bytecodeAndObjects bc o = - assertPpr (not (isObjectLinkable bc) && isObjectLinkable o) (ppr bc $$ ppr o) + assertPpr (not (linkableIsNativeCodeOnly bc) && linkableIsNativeCodeOnly o) (ppr bc $$ ppr o) (HomeModLinkable (Just bc) (Just o)) @@ -127,72 +107,3 @@ flag to make sure that byte code is generated for your modules. -} - --- | Helps us find information about modules in the home package -type HomePackageTable = DModuleNameEnv HomeModInfo - -- Domain = modules in the home unit that have been fully compiled - -- "home" unit id cached (implicit) here for convenience - --- | Constructs an empty HomePackageTable -emptyHomePackageTable :: HomePackageTable -emptyHomePackageTable = emptyUDFM - -lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo -lookupHpt = lookupUDFM - -lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo -lookupHptDirectly = lookupUDFM_Directly - -eltsHpt :: HomePackageTable -> [HomeModInfo] -eltsHpt = eltsUDFM - -filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable -filterHpt = filterUDFM - -allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool -allHpt = allUDFM - -anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool -anyHpt = anyUDFM - -mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable -mapHpt = mapUDFM - -delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable -delFromHpt = delFromUDFM - -addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable -addToHpt = addToUDFM - -addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> HomePackageTable -addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi - -addListToHpt - :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable -addListToHpt = addListToUDFM - -listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable -listToHpt = listToUDFM - -listHMIToHpt :: [HomeModInfo] -> HomePackageTable -listHMIToHpt hmis = - listToHpt [(moduleName (mi_module (hm_iface hmi)), hmi) | hmi <- sorted_hmis] - where - -- Sort to put Non-boot things last, so they overwrite the boot interfaces - -- in the HPT, other than that, the order doesn't matter - sorted_hmis = sortOn (Down . mi_boot . hm_iface) hmis - -lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo --- The HPT is indexed by ModuleName, not Module, --- we must check for a hit on the right Module -lookupHptByModule hpt mod - = case lookupHpt hpt (moduleName mod) of - Just hm | mi_module (hm_iface hm) == mod -> Just hm - _otherwise -> Nothing - -pprHPT :: HomePackageTable -> SDoc --- A bit arbitrary for now -pprHPT hpt = pprUDFM hpt $ \hms -> - vcat [ ppr (mi_module (hm_iface hm)) - | hm <- hms ] - diff --git a/GHC/Unit/Home/PackageTable.hs b/GHC/Unit/Home/PackageTable.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Home/PackageTable.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE LambdaCase #-} +-- | The 'HomePackageTable' (HPT) contains information about all modules that are part +-- of a home package. At its core, the information for each module is a +-- 'HomeModInfo'. +-- +-- During upsweep, the HPT is a monotonically increasing data structure: it +-- only ever gets extended by inserting modules which are loaded and for which +-- we discover the information required to construct a 'ModInfo'. +-- +-- There should only ever exist one single HPT for any given home unit. It's +-- crucial we don't accidentally leak HPTs (e.g. by filtering it, which used to +-- happen -- #25511), so the HPT is mutable and only its reference should be shared. +-- This is alright because the modules don't change throughout compilation. +-- +-- :::WARNING::: +-- If you intend to change this interface, consider carefully whether you are +-- exposing memory-leak footguns which may end up being misused in the compiler +-- eventually. For instance, if you really, really, end up needing a way to take +-- a snapshot of the IORef (think: do you really need to?), at least make +-- obvious in the name like `snapshotCopyHpt`. +-- +-- Or, do you really need a function to traverse all modules in the HPT? It is +-- often better to keep the computation internal to this module, such as in +-- 'hptCollectObjects'... +module GHC.Unit.Home.PackageTable + ( + HomePackageTable(..) + , emptyHomePackageTable + + -- * Lookups in the HPT + , lookupHpt + , lookupHptByModule + + -- * Extending the HPT + , addHomeModInfoToHpt + , addHomeModInfosToHpt + + -- * Restrict the HPT + , restrictHpt + + -- * Queries about home modules + , hptCompleteSigs + , hptAllInstances + , hptAllFamInstances + , hptAllAnnotations + + -- ** More Traversal-based queries + , hptCollectDependencies + , hptCollectObjects + , hptCollectModules + + -- ** Memory dangerous queries + , concatHpt + + -- * Utilities + , pprHPT + + -- * Internals + -- + -- | These provide access to the internals of the HomePackageTable to + -- facilitate existing workflows that used the previous API. For instance, + -- if you were listing out all elements or merging, you can keep doing so by reading + -- the internal IO ref and then using the moduleenv contents directly. + -- + -- In GHC itself these should be avoided, and other uses should justify why + -- it is not sufficient to go through the intended insert-only API. + , hptInternalTableRef + , hptInternalTableFromRef + + -- * Legacy API + -- + -- | This API is deprecated and meant to be removed. + , addToHpt + , addListToHpt + ) where + +import GHC.Prelude +import GHC.Data.Maybe + +import Data.IORef +import Control.Monad ((<$!>)) +import qualified Data.Set as Set + +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv +import GHC.Linker.Types +import GHC.Types.Annotations +import GHC.Types.CompleteMatch +import GHC.Types.Unique.DFM +import GHC.Unit.Home.ModInfo +import GHC.Unit.Module +import GHC.Unit.Module.Deps +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Utils.Outputable +import GHC.Types.Unique (getUnique, getKey) +import qualified GHC.Data.Word64Set as W64 + +-- | Helps us find information about modules in the home package +newtype HomePackageTable = HPT { + + table :: IORef (DModuleNameEnv HomeModInfo) + -- ^ Domain = modules in this home unit + -- + -- This is an IORef because we want to avoid leaking HPTs (see the particularly bad #25511). + -- Moreover, the HPT invariant allows mutability in this table without compromising thread safety or soundness. + -- To recall: + -- A query to the HPT should depend only on data relevant to that query, such that + -- there being more or less unrelated entries in the HPT does not influence the result in any way. + -- + -- Note that the HPT increases monotonically, except at certain barrier + -- points like when 'restrictHpt' is called. At these barriers, it is safe + -- to temporarily violate the HPT monotonicity. + -- + -- The elements of this table may be updated (e.g. on rehydration). + } + +-- | Create a new 'HomePackageTable'. +-- +-- Be careful not to share it across e.g. different units, since it uses a +-- mutable variable under the hood to keep the monotonically increasing list of +-- loaded modules. +emptyHomePackageTable :: IO HomePackageTable +-- romes:todo: use a MutableArray directly? +emptyHomePackageTable = do + table <- newIORef emptyUDFM + return HPT{table} + +-------------------------------------------------------------------------------- +-- * Lookups in the HPT +-------------------------------------------------------------------------------- + +-- | Lookup the 'HomeModInfo' of a module in the HPT, given its name. +lookupHpt :: HomePackageTable -> ModuleName -> IO (Maybe HomeModInfo) +lookupHpt HPT{table=hpt} mn = (`lookupUDFM` mn) <$!> readIORef hpt + +-- | Lookup the 'HomeModInfo' of a 'Module' in the HPT. +lookupHptByModule :: HomePackageTable -> Module -> IO (Maybe HomeModInfo) +lookupHptByModule hpt mod + = -- The HPT is indexed by ModuleName, not Module, + -- we must check for a hit on the right Module + lookupHpt hpt (moduleName mod) >>= pure . \case + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-------------------------------------------------------------------------------- +-- * Extending the HPT +-------------------------------------------------------------------------------- + +-- | Add a new module to the HPT. +-- +-- An HPT is a monotonically increasing data structure, holding information about loaded modules in a package. +-- This is the main function by which the HPT is extended or updated. +-- +-- When the module of the inserted 'HomeModInfo' does not exist, a new entry in +-- the HPT is created for that module name. +-- When the module already has an entry, inserting a new one entry in the HPT +-- will always overwrite the existing entry for that module. +addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> IO () +addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi + +{-# DEPRECATED addToHpt "Deprecated in favour of 'addHomeModInfoToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-} +-- After deprecation cycle, move `addToHpt` to a `where` clause inside `addHomeModInfoToHpt`. +addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> IO () +addToHpt HPT{table=hptr} mn hmi = do + atomicModifyIORef' hptr (\hpt -> (addToUDFM hpt mn hmi, ())) + -- If the key already existed in the map, this insertion is overwriting + -- the HMI of a previously loaded module (likely in rehydration). + +-- | 'addHomeModInfoToHpt' for multiple module infos. +addHomeModInfosToHpt :: HomePackageTable -> [HomeModInfo] -> IO () +addHomeModInfosToHpt hpt = mapM_ (flip addHomeModInfoToHpt hpt) + +-- | Thin each HPT variable to only contain keys from the given dependencies. +-- This is used at the end of upsweep to make sure that only completely successfully loaded +-- modules are visible for subsequent operations. +-- +-- This is an exception to the invariant of the HPT -- that it grows +-- monotonically, never removing entries -- which is safe as long as it is only +-- called at barrier points, such as the end of upsweep, when all threads are +-- done and we want to clean up failed entries. +restrictHpt :: HomePackageTable -> [HomeModInfo] -> IO () +restrictHpt HPT{table=hptr} hmis = + let key_set = map (getKey . getUnique . hmi_mod) hmis + hmi_mod hmi = moduleName (mi_module (hm_iface hmi)) + in atomicModifyIORef' hptr (\hpt -> (udfmRestrictKeysSet hpt (W64.fromList key_set), ())) + +{-# DEPRECATED addListToHpt "Deprecated in favour of 'addHomeModInfosToHpt', as the module at which a 'HomeModInfo' is inserted should always be derived from the 'HomeModInfo' itself." #-} +-- After deprecation cycle, remove. +addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> IO () +addListToHpt hpt = mapM_ (uncurry (addToHpt hpt)) + +---------------------------------------------------------------------------------- +---- * Queries +---------------------------------------------------------------------------------- + +-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present in all +-- modules from this unit's HPT. +hptCompleteSigs :: HomePackageTable -> IO CompleteMatches +hptCompleteSigs = concatHpt (md_complete_matches . hm_details) + +-- | Find all the instance declarations (of classes and families) from this Home Package Table +hptAllInstances :: HomePackageTable -> IO (InstEnv, [FamInst]) +hptAllInstances hpt = do + hits <- flip concatHpt hpt $ \mod_info -> do + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + let (insts, famInsts) = unzip hits + return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts) + +-- | Find all the family instance declarations from the HPT +hptAllFamInstances :: HomePackageTable -> IO (ModuleEnv FamInstEnv) +hptAllFamInstances = fmap mkModuleEnv . concatHpt (\hmi -> [(hmiModule hmi, hmiFamInstEnv hmi)]) + where + hmiModule = mi_module . hm_iface + hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + +-- | All annotations from the HPT +hptAllAnnotations :: HomePackageTable -> IO AnnEnv +hptAllAnnotations = fmap mkAnnEnv . concatHpt (md_anns . hm_details) + + +-------------------------------------------------------------------------------- +-- * Traversal-based queries +-------------------------------------------------------------------------------- + +-- | Collect the immediate dependencies of all modules in the HPT into a Set. +-- The immediate dependencies are given by the iface as @'dep_direct_pkgs' . 'mi_deps'@. +-- +-- Note: This should be a query on the 'ModuleGraph', since we don't really +-- ever want to collect *all* dependencies. The current caller of this function +-- currently takes all dependencies only to then filter them with an ad-hoc transitive closure check. +-- See #25639 +hptCollectDependencies :: HomePackageTable -> IO (Set.Set (IfaceImportLevel, UnitId)) +hptCollectDependencies HPT{table} = do + hpt <- readIORef table + return $ + foldr (Set.union . dep_direct_pkgs . mi_deps . hm_iface) Set.empty hpt + +-- | Collect the linkable object of all modules in the HPT. +-- The linkable objects are given by @'homeModInfoObject'@. +-- +-- $O(n)$ in the number of modules in the HPT. +hptCollectObjects :: HomePackageTable -> IO [Linkable] +hptCollectObjects HPT{table} = do + hpt <- readIORef table + return $ + foldr ((:) . expectJust . homeModInfoObject) [] hpt + +-- | Collect all module ifaces in the HPT +-- +-- $O(n)$ in the number of modules in the HPT. +hptCollectModules :: HomePackageTable -> IO [Module] +hptCollectModules HPT{table} = do + hpt <- readIORef table + return $ + foldr ((:) . mi_module . hm_iface) [] hpt + +-------------------------------------------------------------------------------- +-- * Utilities +-------------------------------------------------------------------------------- + +-- | Pretty print a 'HomePackageTable'. +-- +-- Make sure you really do need to print the whole HPT before infusing too much +-- code with IO. +-- +-- For instance, in the HUG, it suffices to print the unit-keys present in the +-- unit map in failed lookups. +pprHPT :: HomePackageTable -> IO SDoc +-- A bit arbitrary for now +pprHPT HPT{table=hptr} = do + hpt <- readIORef hptr + return $! + pprUDFM hpt $ \hms -> + vcat [ ppr (mi_module (hm_iface hm)) + | hm <- hms ] + +---------------------------------------------------------------------------------- +-- THE TYPE OF FOOTGUNS WE DON'T WANT TO EXPOSE +---------------------------------------------------------------------------------- + +-- eltsHpt :: HomePackageTable -> [HomeModInfo] +-- filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable +-- mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable +-- delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable +-- listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable +-- listHMIToHpt :: [HomeModInfo] -> HomePackageTable + +---------------------------------------------------------------------------------- +-- Would be fine, but may lead to linearly traversing the HPT unnecessarily +-- (e.g. `lastLoadedKey` superseded bad usages) +---------------------------------------------------------------------------------- + +-- allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +-- allHpt = allUDFM + +-- anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +-- anyHpt = anyUDFM + +---------------------------------------------------------------------------------- +-- Would be ok to expose this function very /careful/ with the argument function +---------------------------------------------------------------------------------- + +-- | Like @concatMap f . 'eltsHpt'@, but filters out all 'HomeModInfo' for which +-- @f@ returns the empty list before doing the sort inherent to 'eltsUDFM'. +-- +-- If this function is ever exposed from the HPT module, make sure the +-- argument function doesn't introduce leaks. +concatHpt :: (HomeModInfo -> [a]) -> HomePackageTable -> IO [a] +concatHpt f HPT{table} = do + hpt <- readIORef table + return $ concat . eltsUDFM . mapMaybeUDFM g $ hpt + where + g hmi = case f hmi of { [] -> Nothing; as -> Just as } + +-------------------------------------------------------------------------------- +-- * Internals (see haddocks!) +-------------------------------------------------------------------------------- + +-- | Gets the internal 'IORef' which holds the 'HomeModInfo's of this HPT. +-- Use with care. +hptInternalTableRef :: HomePackageTable -> IORef (DModuleNameEnv HomeModInfo) +hptInternalTableRef = table + +-- | Construct a HomePackageTable from the IORef. +-- Use with care, only if you can really justify going around the intended insert-only API. +hptInternalTableFromRef :: IORef (DModuleNameEnv HomeModInfo) -> IO HomePackageTable +hptInternalTableFromRef ref = do + return HPT { + table = ref + } + diff --git a/GHC/Unit/Info.hs b/GHC/Unit/Info.hs --- a/GHC/Unit/Info.hs +++ b/GHC/Unit/Info.hs @@ -234,10 +234,9 @@ -- will eventually be unused. -- -- This change elevates the need to add custom hooks - -- and handling specifically for the `rts` package for - -- example in ghc-cabal. + -- and handling specifically for the `rts` package. addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) - addSuffix rts@"HSrts-1.0.2" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0.3" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" diff --git a/GHC/Unit/Module/Deps.hs b/GHC/Unit/Module/Deps.hs --- a/GHC/Unit/Module/Deps.hs +++ b/GHC/Unit/Module/Deps.hs @@ -1,21 +1,29 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE DerivingVia #-} -- | Dependencies and Usage of a module module GHC.Unit.Module.Deps - ( Dependencies - , mkDependencies - , noDependencies - , dep_direct_mods - , dep_direct_pkgs - , dep_sig_mods - , dep_trusted_pkgs - , dep_orphs - , dep_plugin_pkgs - , dep_finsts - , dep_boot_mods + ( Dependencies(dep_direct_mods + , dep_direct_pkgs + , dep_sig_mods + , dep_trusted_pkgs + , dep_orphs + , dep_plugin_pkgs + , dep_finsts + , dep_boot_mods + , Dependencies) , dep_orphs_update , dep_finsts_update + , mkDependencies + , noDependencies , pprDeps , Usage (..) + , HomeModImport (..) + , HomeModImportedAvails (..) , ImportAvails (..) + , IfaceImportLevel(..) + , tcImportLevel ) where @@ -23,8 +31,10 @@ import GHC.Data.FastString +import GHC.Types.Avail import GHC.Types.SafeHaskell import GHC.Types.Name +import GHC.Types.Basic import GHC.Unit.Module.Imported import GHC.Unit.Module @@ -39,7 +49,11 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Bifunctor +import Control.DeepSeq +import GHC.Types.Name.Set + + -- | Dependency information about ALL modules and packages below this one -- in the import hierarchy. This is the serialisable version of `ImportAvails`. -- @@ -51,38 +65,38 @@ -- -- See Note [Transitive Information in Dependencies] data Dependencies = Deps - { dep_direct_mods :: Set (UnitId, ModuleNameWithIsBoot) + { dep_direct_mods_ :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot) -- ^ All home-package modules which are directly imported by this one. -- This may include modules from other units when using multiple home units - , dep_direct_pkgs :: Set UnitId + , dep_direct_pkgs_ :: Set (IfaceImportLevel, UnitId) -- ^ All packages directly imported by this module -- I.e. packages to which this module's direct imports belong. -- Does not include other home units when using multiple home units. -- Modules from these units will go in `dep_direct_mods` - , dep_plugin_pkgs :: Set UnitId + , dep_plugin_pkgs_ :: Set UnitId -- ^ All units needed for plugins ------------------------------------ -- Transitive information below here - , dep_sig_mods :: ![ModuleName] + , dep_sig_mods_ :: ![ModuleName] -- ^ Transitive closure of hsig files in the home package - , dep_trusted_pkgs :: Set UnitId + , dep_trusted_pkgs_ :: Set UnitId -- Packages which we are required to trust -- when the module is imported as a safe import -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names - , dep_boot_mods :: Set (UnitId, ModuleNameWithIsBoot) + , dep_boot_mods_ :: Set (UnitId, ModuleNameWithIsBoot) -- ^ All modules which have boot files below this one, and whether we -- should use the boot file or not. -- This information is only used to populate the eps_is_boot field. -- See Note [Structure of dep_boot_mods] - , dep_orphs :: [Module] + , dep_orphs_ :: [Module] -- ^ Transitive closure of orphan modules (whether -- home or external pkg). -- @@ -92,7 +106,7 @@ -- which relies on dep_orphs having the complete list!) -- This does NOT include us, unlike 'imp_orphs'. - , dep_finsts :: [Module] + , dep_finsts_ :: [Module] -- ^ Transitive closure of depended upon modules which -- contain family instances (whether home or external). -- This is used by 'checkFamInstConsistency'. This @@ -104,7 +118,55 @@ -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies. +pattern Dependencies :: Set (IfaceImportLevel, UnitId, ModuleNameWithIsBoot) + -> Set (IfaceImportLevel, UnitId) + -> Set UnitId + -> [ModuleName] + -> Set UnitId + -> Set (UnitId, ModuleNameWithIsBoot) + -> [Module] + -> [Module] + -> Dependencies +pattern Dependencies {dep_direct_mods, dep_direct_pkgs, dep_plugin_pkgs, dep_sig_mods, dep_trusted_pkgs, dep_boot_mods, dep_orphs, dep_finsts} + <- Deps {dep_direct_mods_ = dep_direct_mods + , dep_direct_pkgs_ = dep_direct_pkgs + , dep_plugin_pkgs_ = dep_plugin_pkgs + , dep_sig_mods_ = dep_sig_mods + , dep_trusted_pkgs_ = dep_trusted_pkgs + , dep_boot_mods_ = dep_boot_mods + , dep_orphs_ = dep_orphs + , dep_finsts_ = dep_finsts} +{-# COMPLETE Dependencies #-} +instance NFData Dependencies where + rnf (Deps dmods dpkgs ppkgs hsigms tps bmods orphs finsts) + = rnf dmods + `seq` rnf dpkgs + `seq` rnf ppkgs + `seq` rnf hsigms + `seq` rnf tps + `seq` rnf bmods + `seq` rnf orphs + `seq` rnf finsts + `seq` () + +newtype IfaceImportLevel = IfaceImportLevel ImportLevel + deriving (Eq, Ord) + deriving Binary via EnumBinary ImportLevel + +tcImportLevel :: IfaceImportLevel -> ImportLevel +tcImportLevel (IfaceImportLevel lvl) = lvl + +instance NFData IfaceImportLevel where + rnf (IfaceImportLevel lvl) = case lvl of + NormalLevel -> () + QuoteLevel -> () + SpliceLevel -> () + +instance Outputable IfaceImportLevel where + ppr (IfaceImportLevel lvl) = ppr lvl + + -- | Extract information from the rename and typecheck phases to produce -- a dependencies information for the module being compiled. -- @@ -113,15 +175,19 @@ mkDependencies home_unit mod imports plugin_mods = let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods plugin_units = Set.fromList (map (toUnitId . moduleUnit) external_plugins) - all_direct_mods = foldr (\mn m -> extendInstalledModuleEnv m mn (GWIB (moduleName mn) NotBoot)) + all_direct_mods = foldr (\(s, mn) m -> extendInstalledModuleEnv m mn (s, (GWIB (moduleName mn) NotBoot))) (imp_direct_dep_mods imports) - (map (fmap toUnitId) home_plugins) + (map (fmap (fmap toUnitId) . (Set.singleton SpliceLevel,)) home_plugins) - modDepsElts = Set.fromList . installedModuleEnvElts + modDepsElts_source :: Ord a => InstalledModuleEnv a -> Set.Set (InstalledModule, a) + modDepsElts_source = Set.fromList . installedModuleEnvElts -- It's OK to use nonDetEltsUFM here because sorting by module names -- restores determinism - direct_mods = first moduleUnit `Set.map` modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod)) + modDepsElts :: Ord a => InstalledModuleEnv (Set.Set ImportLevel, a) -> Set.Set (IfaceImportLevel, UnitId, a) + modDepsElts e = Set.fromList [ (IfaceImportLevel s, moduleUnit im, a) | (im, (ss,a)) <- installedModuleEnvElts e, s <- Set.toList ss] + + direct_mods = modDepsElts (delInstalledModuleEnv all_direct_mods (toUnitId <$> mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -133,7 +199,7 @@ -- We must also remove self-references from imp_orphs. See -- Note [Module self-dependency] - direct_pkgs = imp_dep_direct_pkgs imports + direct_pkgs = Set.map (\(lvl, uid) -> (IfaceImportLevel lvl, uid)) (imp_dep_direct_pkgs imports) -- Set the packages required to be Safe according to Safe Haskell. -- See Note [Tracking Trust Transitively] in GHC.Rename.Names @@ -141,18 +207,18 @@ -- If there's a non-boot import, then it shadows the boot import -- coming from the dependencies - source_mods = first moduleUnit `Set.map` modDepsElts (imp_boot_mods imports) + source_mods = first moduleUnit `Set.map` modDepsElts_source (imp_boot_mods imports) sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports - in Deps { dep_direct_mods = direct_mods - , dep_direct_pkgs = direct_pkgs - , dep_plugin_pkgs = plugin_units - , dep_sig_mods = sort sig_mods - , dep_trusted_pkgs = trust_pkgs - , dep_boot_mods = source_mods - , dep_orphs = sortBy stableModuleCmp dep_orphs - , dep_finsts = sortBy stableModuleCmp (imp_finsts imports) + in Deps { dep_direct_mods_ = direct_mods + , dep_direct_pkgs_ = direct_pkgs + , dep_plugin_pkgs_ = plugin_units + , dep_sig_mods_ = sort sig_mods + , dep_trusted_pkgs_ = trust_pkgs + , dep_boot_mods_ = source_mods + , dep_orphs_ = sortBy stableModuleCmp dep_orphs + , dep_finsts_ = sortBy stableModuleCmp (imp_finsts imports) -- sort to get into canonical order -- NB. remember to use lexicographic ordering } @@ -161,14 +227,13 @@ dep_orphs_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies dep_orphs_update deps f = do r <- f (dep_orphs deps) - pure (deps { dep_orphs = sortBy stableModuleCmp r }) + pure (deps { dep_orphs_ = sortBy stableModuleCmp r }) -- | Update module dependencies containing family instances (used by Backpack) dep_finsts_update :: Monad m => Dependencies -> ([Module] -> m [Module]) -> m Dependencies dep_finsts_update deps f = do r <- f (dep_finsts deps) - pure (deps { dep_finsts = sortBy stableModuleCmp r }) - + pure (deps { dep_finsts_ = sortBy stableModuleCmp r }) instance Binary Dependencies where put_ bh deps = do put_ bh (dep_direct_mods deps) @@ -188,36 +253,36 @@ sms <- get bh os <- get bh fis <- get bh - return (Deps { dep_direct_mods = dms - , dep_direct_pkgs = dps - , dep_plugin_pkgs = plugin_pkgs - , dep_sig_mods = hsigms - , dep_boot_mods = sms - , dep_trusted_pkgs = tps - , dep_orphs = os, - dep_finsts = fis }) + return (Deps { dep_direct_mods_ = dms + , dep_direct_pkgs_ = dps + , dep_plugin_pkgs_ = plugin_pkgs + , dep_sig_mods_ = hsigms + , dep_boot_mods_ = sms + , dep_trusted_pkgs_ = tps + , dep_orphs_ = os, + dep_finsts_ = fis }) noDependencies :: Dependencies noDependencies = Deps - { dep_direct_mods = Set.empty - , dep_direct_pkgs = Set.empty - , dep_plugin_pkgs = Set.empty - , dep_sig_mods = [] - , dep_boot_mods = Set.empty - , dep_trusted_pkgs = Set.empty - , dep_orphs = [] - , dep_finsts = [] + { dep_direct_mods_ = Set.empty + , dep_direct_pkgs_ = Set.empty + , dep_plugin_pkgs_ = Set.empty + , dep_sig_mods_ = [] + , dep_boot_mods_ = Set.empty + , dep_trusted_pkgs_ = Set.empty + , dep_orphs_ = [] + , dep_finsts_ = [] } -- | Pretty-print unit dependencies pprDeps :: UnitState -> Dependencies -> SDoc -pprDeps unit_state (Deps { dep_direct_mods = dmods - , dep_boot_mods = bmods - , dep_plugin_pkgs = plgns - , dep_orphs = orphs - , dep_direct_pkgs = pkgs - , dep_trusted_pkgs = tps - , dep_finsts = finsts +pprDeps unit_state (Deps { dep_direct_mods_ = dmods + , dep_boot_mods_ = bmods + , dep_plugin_pkgs_ = plgns + , dep_orphs_ = orphs + , dep_direct_pkgs_ = pkgs + , dep_trusted_pkgs_ = tps + , dep_finsts_ = finsts }) = pprWithUnitState unit_state $ vcat [text "direct module dependencies:" <+> ppr_set ppr_mod dmods, @@ -231,8 +296,8 @@ text "family instance modules:" <+> fsep (map ppr finsts) ] where - ppr_mod (uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]" - ppr_mod (uid, (GWIB mod NotBoot)) = ppr uid <> colon <> ppr mod + ppr_mod (_, uid, (GWIB mod IsBoot)) = ppr uid <> colon <> ppr mod <+> text "[boot]" + ppr_mod (lvl, uid, (GWIB mod NotBoot)) = ppr lvl <+> ppr uid <> colon <> ppr mod ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc ppr_set w = fsep . fmap w . Set.toAscList @@ -268,9 +333,9 @@ -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. -- NB: usages are for parent names only, e.g. type constructors -- but not the associated data constructors. - usg_exports :: Maybe Fingerprint, - -- ^ Fingerprint for the export list of this module, - -- if we directly imported it (and hence we depend on its export list) + usg_exports :: Maybe HomeModImport, + -- ^ What we depend on from the exports of the module; + -- see 'HomeModImport'. usg_safe :: IsSafeImport -- ^ Was this module imported as a safe import } @@ -326,6 +391,13 @@ -- And of course, for modules that aren't imported directly we don't -- depend on their export lists +instance NFData Usage where + rnf (UsagePackageModule mod hash safe) = rnf mod `seq` rnf hash `seq` rnf safe `seq` () + rnf (UsageHomeModule mod uid hash entities exports safe) = rnf mod `seq` rnf uid `seq` rnf hash `seq` rnf entities `seq` rnf exports `seq` rnf safe `seq` () + rnf (UsageFile file hash label) = rnf file `seq` rnf hash `seq` rnf label `seq` () + rnf (UsageMergedRequirement mod hash) = rnf mod `seq` rnf hash `seq` () + rnf (UsageHomeModuleInterface mod uid hash) = rnf mod `seq` rnf uid `seq` rnf hash `seq` () + instance Binary Usage where put_ bh usg@UsagePackageModule{} = do putByte bh 0 @@ -392,11 +464,79 @@ return UsageHomeModuleInterface { usg_mod_name = mod, usg_unit_id = uid, usg_iface_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) +-- | Records the imports that we depend on from a home module, +-- for recompilation checking. +-- +-- See Note [When to recompile when export lists change?] in GHC.Iface.Recomp. +data HomeModImport + = HomeModImport + -- | Hash of orphans, dependencies, orphans of dependencies etc... + -- + -- See Note [Orphan-like hash]. + -- + -- If this changes, we definitely need to recompile. + { hmiu_orphanLikeHash :: Fingerprint + -- | The avails we are importing; see 'HomeModImportedAvails'. + , hmiu_importedAvails :: HomeModImportedAvails + } + deriving stock Eq -{- -Note [Transitive Information in Dependencies] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- | Records all the 'Avail's we are importing from a home module. +data HomeModImportedAvails + -- | All import lists are explicit import lists, but some identifiers + -- may still be implicitly imported, e.g. @import M(a, b, T(..))@. + -- + -- In this case, recompilation is keyed by the names we are importing, + -- with their 'Avail' structure. + = HMIA_Explicit + { hmia_imported_avails :: DetOrdAvails + -- ^ The avails we are importing + , hmia_parents_with_implicits :: NameSet + -- ^ The 'Name's of all 'AvailTC' imports which + -- implicitly import children + } + -- | One import is a whole module import, or a @import module M hiding(..)@ + -- import. + -- + -- In this case, recompilation is keyed on the hash of the exported avails + -- of the module we are importing. + | HMIA_Implicit + { hmia_exportedAvailsHash :: Fingerprint + -- ^ The export avails hash of the module we are importing + } + deriving stock Eq +instance Outputable HomeModImport where + ppr (HomeModImport orphan_like imp_avails) = + braces (text "orphan_like:" <+> ppr orphan_like <+> text ", imported avails:" <+> ppr imp_avails) +instance Outputable HomeModImportedAvails where + ppr (HMIA_Explicit avails implicit_parents) = + braces (text "explicit:" <+> ppr avails <+> text ", implicit_parents:" <+> ppr implicit_parents) + ppr (HMIA_Implicit hash) = braces (text "implicit:" <+> ppr hash) +instance NFData HomeModImport where + rnf (HomeModImport a b) = rnf a `seq` rnf b `seq` () +instance NFData HomeModImportedAvails where + rnf (HMIA_Explicit avails implicit_parents) = rnf avails `seq` rnf implicit_parents + rnf (HMIA_Implicit hash) = rnf hash +instance Binary HomeModImport where + put_ bh (HomeModImport a b) = put_ bh a >> put_ bh b + get bh = do + a <- get bh + b <- get bh + return $ HomeModImport a b +instance Binary HomeModImportedAvails where + put_ bh (HMIA_Explicit avails implicit_parents) = + putByte bh 0 >> put_ bh avails >> put_ bh (nameSetElemsStable implicit_parents) + put_ bh (HMIA_Implicit hash ) = putByte bh 1 >> put_ bh hash + get bh = do + tag <- getByte bh + case tag of + 0 -> HMIA_Explicit <$> get bh <*> (mkNameSet <$> get bh) + 1 -> HMIA_Implicit <$> get bh + _ -> error ("Binary.get(HomeModImportedAvails): " ++ show tag) + +{- Note [Transitive Information in Dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is important to be careful what information we put in 'Dependencies' because ultimately it ends up serialised in an interface file. Interface files must always be kept up-to-date with the state of the world, so if `Dependencies` needs to be updated @@ -490,10 +630,10 @@ -- different packages. (currently not the case, but might be in the -- future). - imp_direct_dep_mods :: InstalledModuleEnv ModuleNameWithIsBoot, + imp_direct_dep_mods :: InstalledModuleEnv (Set.Set ImportLevel, ModuleNameWithIsBoot), -- ^ Home-package modules directly imported by the module being compiled. - imp_dep_direct_pkgs :: Set UnitId, + imp_dep_direct_pkgs :: Set (ImportLevel, UnitId), -- ^ Packages directly needed by the module being compiled imp_trust_own_pkg :: Bool, diff --git a/GHC/Unit/Module/Graph.hs b/GHC/Unit/Module/Graph.hs --- a/GHC/Unit/Module/Graph.hs +++ b/GHC/Unit/Module/Graph.hs @@ -2,416 +2,1048 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} -module GHC.Unit.Module.Graph - ( ModuleGraph - , ModuleGraphNode(..) - , nodeDependencies - , emptyMG - , mkModuleGraph - , extendMG - , extendMGInst - , extendMG' - , unionMG - , isTemplateHaskellOrQQNonBoot - , filterToposortToModules - , mapMG - , mgModSummaries - , mgModSummaries' - , mgLookupModule - , mgTransDeps - , showModMsg - , moduleGraphNodeModule - , moduleGraphNodeModSum - , moduleGraphModulesBelow - - , moduleGraphNodes - , SummaryNode - , summaryNodeSummary - - , NodeKey(..) - , nodeKeyUnitId - , nodeKeyModName - , ModNodeKey - , mkNodeKey - , msKey - - - , moduleGraphNodeUnitId - - , ModNodeKeyWithUid(..) - ) -where - -import GHC.Prelude -import GHC.Platform - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.Maybe -import GHC.Data.Graph.Directed - -import GHC.Driver.Backend -import GHC.Driver.DynFlags - -import GHC.Types.SourceFile ( hscSourceString ) - -import GHC.Unit.Module.ModSummary -import GHC.Unit.Types -import GHC.Utils.Outputable - -import System.FilePath -import qualified Data.Map as Map -import GHC.Types.Unique.DSet -import qualified Data.Set as Set -import Data.Set (Set) -import GHC.Unit.Module -import GHC.Linker.Static.Utils - -import Data.Bifunctor -import Data.Either -import Data.Function -import Data.List (sort) -import GHC.Data.List.SetOps - --- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. --- Edges between nodes mark dependencies arising from module imports --- and dependencies arising from backpack instantiations. -data ModuleGraphNode - -- | Instantiation nodes track the instantiation of other units - -- (backpack dependencies) with the holes (signatures) of the current package. - = InstantiationNode UnitId InstantiatedUnit - -- | There is a module summary node for each module, signature, and boot module being built. - | ModuleNode [NodeKey] ModSummary - -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit. - | LinkNode [NodeKey] UnitId - -moduleGraphNodeModule :: ModuleGraphNode -> Maybe ModuleName -moduleGraphNodeModule mgn = ms_mod_name <$> (moduleGraphNodeModSum mgn) - -moduleGraphNodeModSum :: ModuleGraphNode -> Maybe ModSummary -moduleGraphNodeModSum (InstantiationNode {}) = Nothing -moduleGraphNodeModSum (LinkNode {}) = Nothing -moduleGraphNodeModSum (ModuleNode _ ms) = Just ms - -moduleGraphNodeUnitId :: ModuleGraphNode -> UnitId -moduleGraphNodeUnitId mgn = - case mgn of - InstantiationNode uid _iud -> uid - ModuleNode _ ms -> toUnitId (moduleUnit (ms_mod ms)) - LinkNode _ uid -> uid - -instance Outputable ModuleGraphNode where - ppr = \case - InstantiationNode _ iuid -> ppr iuid - ModuleNode nks ms -> ppr (msKey ms) <+> ppr nks - LinkNode uid _ -> text "LN:" <+> ppr uid - -instance Eq ModuleGraphNode where - (==) = (==) `on` mkNodeKey - -instance Ord ModuleGraphNode where - compare = compare `on` mkNodeKey - -data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit - | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid - | NodeKey_Link !UnitId - deriving (Eq, Ord) - -instance Outputable NodeKey where - ppr nk = pprNodeKey nk - -pprNodeKey :: NodeKey -> SDoc -pprNodeKey (NodeKey_Unit iu) = ppr iu -pprNodeKey (NodeKey_Module mk) = ppr mk -pprNodeKey (NodeKey_Link uid) = ppr uid - -nodeKeyUnitId :: NodeKey -> UnitId -nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu -nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk -nodeKeyUnitId (NodeKey_Link uid) = uid - -nodeKeyModName :: NodeKey -> Maybe ModuleName -nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk) -nodeKeyModName _ = Nothing - -data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot - , mnkUnitId :: !UnitId } deriving (Eq, Ord) - -instance Outputable ModNodeKeyWithUid where - ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib - --- | A '@ModuleGraph@' contains all the nodes from the home package (only). See --- '@ModuleGraphNode@' for information about the nodes. --- --- Modules need to be compiled. hs-boots need to be typechecked before --- the associated "real" module so modules with {-# SOURCE #-} imports can be --- built. Instantiations also need to be typechecked to ensure that the module --- fits the signature. Substantiation typechecking is roughly comparable to the --- check that the module and its hs-boot agree. --- --- The graph is not necessarily stored in topologically-sorted order. Use --- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. -data ModuleGraph = ModuleGraph - { mg_mss :: [ModuleGraphNode] - , mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey) - -- A cached transitive dependency calculation so that a lot of work is not - -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances) - } - --- | Map a function 'f' over all the 'ModSummaries'. --- To preserve invariants 'f' can't change the isBoot status. -mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph -mapMG f mg@ModuleGraph{..} = mg - { mg_mss = flip fmap mg_mss $ \case - InstantiationNode uid iuid -> InstantiationNode uid iuid - LinkNode uid nks -> LinkNode uid nks - ModuleNode deps ms -> ModuleNode deps (f ms) - } - -unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph -unionMG a b = - let new_mss = nubOrdBy compare $ mg_mss a `mappend` mg_mss b - in ModuleGraph { - mg_mss = new_mss - , mg_trans_deps = mkTransDeps new_mss - } - - -mgTransDeps :: ModuleGraph -> Map.Map NodeKey (Set.Set NodeKey) -mgTransDeps = mg_trans_deps - -mgModSummaries :: ModuleGraph -> [ModSummary] -mgModSummaries mg = [ m | ModuleNode _ m <- mgModSummaries' mg ] - -mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] -mgModSummaries' = mg_mss - --- | Look up a ModSummary in the ModuleGraph --- Looks up the non-boot ModSummary --- Linear in the size of the module graph -mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary -mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss - where - go (ModuleNode _ ms) - | NotBoot <- isBootSummary ms - , ms_mod ms == m - = Just ms - go _ = Nothing - -emptyMG :: ModuleGraph -emptyMG = ModuleGraph [] Map.empty - -isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool -isTemplateHaskellOrQQNonBoot ms = - (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) - || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && - (isBootSummary ms == NotBoot) - --- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is --- not an element of the ModuleGraph. -extendMG :: ModuleGraph -> [NodeKey] -> ModSummary -> ModuleGraph -extendMG ModuleGraph{..} deps ms = ModuleGraph - { mg_mss = ModuleNode deps ms : mg_mss - , mg_trans_deps = mkTransDeps (ModuleNode deps ms : mg_mss) - } - -mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey) -mkTransDeps mss = - let (gg, _lookup_node) = moduleGraphNodes False mss - in allReachable gg (mkNodeKey . node_payload) - -extendMGInst :: ModuleGraph -> UnitId -> InstantiatedUnit -> ModuleGraph -extendMGInst mg uid depUnitId = mg - { mg_mss = InstantiationNode uid depUnitId : mg_mss mg - } - -extendMGLink :: ModuleGraph -> UnitId -> [NodeKey] -> ModuleGraph -extendMGLink mg uid nks = mg { mg_mss = LinkNode nks uid : mg_mss mg } - -extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph -extendMG' mg = \case - InstantiationNode uid depUnitId -> extendMGInst mg uid depUnitId - ModuleNode deps ms -> extendMG mg deps ms - LinkNode deps uid -> extendMGLink mg uid deps - -mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph -mkModuleGraph = foldr (flip extendMG') emptyMG - --- | This function filters out all the instantiation nodes from each SCC of a --- topological sort. Use this with care, as the resulting "strongly connected components" --- may not really be strongly connected in a direct way, as instantiations have been --- removed. It would probably be best to eliminate uses of this function where possible. -filterToposortToModules - :: [SCC ModuleGraphNode] -> [SCC ModSummary] -filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case - InstantiationNode _ _ -> Nothing - LinkNode{} -> Nothing - ModuleNode _deps node -> Just node - where - -- This higher order function is somewhat bogus, - -- as the definition of "strongly connected component" - -- is not necessarily respected. - mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b) - mapMaybeSCC f = \case - AcyclicSCC a -> AcyclicSCC <$> f a - CyclicSCC as -> case mapMaybe f as of - [] -> Nothing - [a] -> Just $ AcyclicSCC a - as -> Just $ CyclicSCC as - -showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc -showModMsg dflags _ (LinkNode {}) = - let staticLink = case ghcLink dflags of - LinkStaticLib -> True - _ -> False - - platform = targetPlatform dflags - arch_os = platformArchOS platform - exe_file = exeFileName arch_os staticLink (outputFile_ dflags) - in text exe_file -showModMsg _ _ (InstantiationNode _uid indef_unit) = - ppr $ instUnitInstanceOf indef_unit -showModMsg dflags recomp (ModuleNode _ mod_summary) = - if gopt Opt_HideSourcePaths dflags - then text mod_str - else hsep $ - [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') - , char '(' - , text (op $ msHsFilePath mod_summary) <> char ',' - , message, char ')' ] - - where - op = normalise - mod_str = moduleNameString (moduleName (ms_mod mod_summary)) ++ - hscSourceString (ms_hsc_src mod_summary) - dyn_file = op $ msDynObjFilePath mod_summary - obj_file = op $ msObjFilePath mod_summary - files = [ obj_file ] - ++ [ dyn_file | gopt Opt_BuildDynamicToo dflags ] - ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] - message = case backendSpecialModuleSource (backend dflags) recomp of - Just special -> text special - Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (map text files) - - - -type SummaryNode = Node Int ModuleGraphNode - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey = node_key - -summaryNodeSummary :: SummaryNode -> ModuleGraphNode -summaryNodeSummary = node_payload - --- | Collect the immediate dependencies of a ModuleGraphNode, --- optionally avoiding hs-boot dependencies. --- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is --- an equivalent .hs-boot, add a link from the former to the latter. This --- has the effect of detecting bogus cases where the .hs-boot depends on the --- .hs, by introducing a cycle. Additionally, it ensures that we will always --- process the .hs-boot before the .hs, and so the HomePackageTable will always --- have the most up to date information. -nodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey] -nodeDependencies drop_hs_boot_nodes = \case - LinkNode deps _uid -> deps - InstantiationNode uid iuid -> - NodeKey_Module . (\mod -> ModNodeKeyWithUid (GWIB mod NotBoot) uid) <$> uniqDSetToList (instUnitHoles iuid) - ModuleNode deps _ms -> - map drop_hs_boot deps - where - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature - | otherwise = IsBoot - - drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid)) - drop_hs_boot x = x - --- | Turn a list of graph nodes into an efficient queriable graph. --- The first boolean parameter indicates whether nodes corresponding to hs-boot files --- should be collapsed into their relevant hs nodes. -moduleGraphNodes :: Bool - -> [ModuleGraphNode] - -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = - (graphFromEdgedVerticesUniq nodes, lookup_node) - where - -- Map from module to extra boot summary dependencies which need to be merged in - (boot_summaries, nodes) = bimap Map.fromList id $ partitionEithers (map go numbered_summaries) - - where - go (s, key) = - case s of - ModuleNode __deps ms | isBootSummary ms == IsBoot, drop_hs_boot_nodes - -- Using nodeDependencies here converts dependencies on other - -- boot files to dependencies on dependencies on non-boot files. - -> Left (ms_mod ms, nodeDependencies drop_hs_boot_nodes s) - _ -> normal_case - where - normal_case = - let lkup_key = ms_mod <$> moduleGraphNodeModSum s - extra = (lkup_key >>= \key -> Map.lookup key boot_summaries) - - in Right $ DigraphNode s key $ out_edge_keys $ - (fromMaybe [] extra - ++ nodeDependencies drop_hs_boot_nodes s) - - numbered_summaries = zip summaries [1..] - - lookup_node :: NodeKey -> Maybe SummaryNode - lookup_node key = Map.lookup key (unNodeMap node_map) - - lookup_key :: NodeKey -> Maybe Int - lookup_key = fmap summaryNodeKey . lookup_node - - node_map :: NodeMap SummaryNode - node_map = NodeMap $ - Map.fromList [ (mkNodeKey s, node) - | node <- nodes - , let s = summaryNodeSummary node - ] - - out_edge_keys :: [NodeKey] -> [Int] - out_edge_keys = mapMaybe lookup_key - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- IsBoot; else False -newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } - deriving (Functor, Traversable, Foldable) - -mkNodeKey :: ModuleGraphNode -> NodeKey -mkNodeKey = \case - InstantiationNode _ iu -> NodeKey_Unit iu - ModuleNode _ x -> NodeKey_Module $ msKey x - LinkNode _ uid -> NodeKey_Link uid - -msKey :: ModSummary -> ModNodeKeyWithUid -msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) - -type ModNodeKey = ModuleNameWithIsBoot - - --- | This function returns all the modules belonging to the home-unit that can --- be reached by following the given dependencies. Additionally, if both the --- boot module and the non-boot module can be reached, it only returns the --- non-boot one. -moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid -moduleGraphModulesBelow mg uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below] - where - td_map = mgTransDeps mg - - modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map - - filtered_mods = Set.fromDistinctAscList . filter_mods . sort - - -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list - -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a - -- linear sweep with a window of size 2 to remove boot modules for which we - -- have the corresponding non-boot. - filter_mods = \case - (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs) - | m1 == m2 && uid1 == uid2 -> - let !r' = case b1 of - NotBoot -> r1 - IsBoot -> r2 - in r' : filter_mods rs - | otherwise -> r1 : filter_mods (r2:rs) - rs -> rs +-- | A module graph should be constructed once and never change from there onwards. +-- +-- The only operations should be for building the 'ModuleGraph' +-- (once and for all -- no update-like/insert-like functions) +-- and querying the structure in various ways, e.g. to determine reachability. +-- +-- We should avoid exposing fields like 'mg_mss' since it may be a footgun +-- trying to use the nodes directly... We do still expose it, but it feels like +-- all its use cases would be better served by a more proper ModuleGraph +-- abstraction +module GHC.Unit.Module.Graph + ( + -- * Construct a module graph + -- + -- | A module graph should be constructed once by downsweep and never modified. + ModuleGraph(..) + , emptyMG + , mkModuleGraph + , mkModuleGraphChecked + + -- * Invariant checking + , checkModuleGraph + , ModuleGraphInvariantError(..) + + -- * Nodes in a module graph + -- + -- | The user-facing nodes in a module graph are 'ModuleGraphNode's. + -- There are a few things which we can query out of each 'ModuleGraphNode': + -- + -- - 'mgNodeDependencies' gets the immediate dependencies of this node + -- - 'mgNodeUnitId' returns the 'UnitId' of that node + -- - 'mgNodeModSum' extracts the 'ModSummary' of a node if exists + , ModuleGraphNode(..) + , mgNodeDependencies + , mgNodeIsModule + , mgNodeUnitId + + , ModuleNodeEdge(..) + , mkModuleEdge + , mkNormalEdge + + , ModuleNodeInfo(..) + , moduleNodeInfoModule + , moduleNodeInfoUnitId + , moduleNodeInfoMnwib + , moduleNodeInfoModuleName + , moduleNodeInfoModNodeKeyWithUid + , moduleNodeInfoHscSource + , moduleNodeInfoLocation + , isBootModuleNodeInfo + -- * Module graph operations + , lengthMG + , isEmptyMG + -- ** 'ModSummary' operations + -- + -- | A couple of operations on the module graph allow access to the + -- 'ModSummary's of the modules in it contained. + -- + -- In particular, 'mapMG' and 'mapMGM' allow updating these 'ModSummary's + -- (without changing the 'ModuleGraph' structure itself!). + -- 'mgModSummaries' lists out all 'ModSummary's, and + -- 'mgLookupModule' looks up a 'ModSummary' for a given module. + , mapMG, mgMapM + , mgModSummaries + , mgLookupModule + , mgLookupModuleName + , mgHasHoles + , showModMsg + + -- ** Reachability queries + -- + -- | A module graph explains the structure and relationship between the + -- modules being compiled. Often times, this structure is relevant to + -- answer reachability queries -- is X reachable from Y; or, what is the + -- transitive closure of Z? + , mgReachable + , mgReachableLoop + , mgQuery + , ZeroScopeKey(..) + , mgQueryZero + , mgQueryMany + , mgQueryManyZero + , mgMember + + -- ** Other operations + -- + -- | These operations allow more-internal-than-ideal access to the + -- ModuleGraph structure. Ideally, we could restructure the code using + -- these functions to avoid deconstructing/reconstructing the ModuleGraph + -- and instead extend the "proper interface" of the ModuleGraph to achieve + -- what is currently done but through a better abstraction. + , mgModSummaries' + , moduleGraphNodes + , moduleGraphModulesBelow -- needed for 'hptSomeThingsBelowUs', + -- but I think we could be more clever and cache + -- the graph-ixs of boot modules to efficiently + -- filter them out of the returned list. + -- hptInstancesBelow is re-doing that work every + -- time it's called. + , filterToposortToModules + , moduleGraphNodesZero + , StageSummaryNode + , stageSummaryNodeSummary + , stageSummaryNodeKey + , mkStageDeps + + -- * Keys into the 'ModuleGraph' + , NodeKey(..) + , mkNodeKey + , nodeKeyUnitId + , nodeKeyModName + , ModNodeKey + , ModNodeKeyWithUid(..) + , mnkToModule + , moduleToMnk + , mnkToInstalledModule + , installedModuleToMnk + , mnkIsBoot + , msKey + , mnKey + , miKey + + , ImportLevel(..) + + -- ** Internal node representation + -- + -- | 'SummaryNode' is the internal representation for each node stored in + -- the graph. It's not immediately clear to me why users do depend on them. + , SummaryNode + , summaryNodeSummary + , summaryNodeKey + + ) +where + +import GHC.Prelude +import GHC.Platform + +import GHC.Data.Maybe +import Data.Either +import GHC.Data.Graph.Directed +import GHC.Data.Graph.Directed.Reachability + +import GHC.Driver.Backend +import GHC.Driver.DynFlags + +import GHC.Types.SourceFile ( hscSourceString, isHsigFile, HscSource(..)) +import GHC.Types.Basic + +import GHC.Unit.Module.ModSummary +import GHC.Unit.Types +import GHC.Utils.Outputable +import GHC.Unit.Module.ModIface +import GHC.Utils.Misc ( partitionWith ) + +import System.FilePath +import qualified Data.Map as Map +import GHC.Types.Unique.DSet +import qualified Data.Set as Set +import Data.Set (Set) +import GHC.Unit.Module +import GHC.Unit.Module.ModNodeKey +import GHC.Unit.Module.Stage +import GHC.Linker.Static.Utils + +import Data.Bifunctor +import Data.Function +import Data.List (sort) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Control.Monad +import qualified GHC.LanguageExtensions as LangExt + +-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See +-- '@ModuleGraphNode@' for information about the nodes. +-- +-- Modules need to be compiled. hs-boots need to be typechecked before +-- the associated "real" module so modules with {-# SOURCE #-} imports can be +-- built. Instantiations also need to be typechecked to ensure that the module +-- fits the signature. Substantiation typechecking is roughly comparable to the +-- check that the module and its hs-boot agree. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this. +data ModuleGraph = ModuleGraph + { mg_mss :: [ModuleGraphNode] + , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) + , mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) + , mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode) + + -- `mg_graph` and `mg_loop_graph` cached transitive dependency calculations + -- so that a lot of work is not repeated whenever the transitive + -- dependencies need to be calculated (for example, hptInstances). + -- + --- - `mg_graph` is a reachability index constructed from a module + -- graph /with/ boot nodes (which make the graph acyclic), and + -- + --- * `mg_loop_graph` is a reachability index for the graph /without/ + -- hs-boot nodes, that may be cyclic. + + , mg_has_holes :: !Bool + -- Cached computation, whether any of the ModuleGraphNode are isHoleModule, + -- This is only used for a hack in GHC.Iface.Load to do with backpack, please + -- remove this at the earliest opportunity. + } + +-- | Why do we ever need to construct empty graphs? Is it because of one shot mode? +emptyMG :: ModuleGraph +emptyMG = ModuleGraph [] (graphReachability emptyGraph, const Nothing) + (graphReachability emptyGraph, const Nothing) + (graphReachability emptyGraph, const Nothing) + False + +-- | Construct a module graph. This function should be the only entry point for +-- building a 'ModuleGraph', since it is supposed to be built once and never modified. +-- +-- If you ever find the need to build a 'ModuleGraph' iteratively, don't +-- add insert and update functions to the API since they become footguns. +-- Instead, design an API that allows iterative construction without posterior +-- modification, perhaps like what is done for building arrays from mutable +-- arrays. +mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG) emptyMG + +-- | A version of mkModuleGraph that checks the module graph for invariants. +mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph +mkModuleGraphChecked nodes = + let mg = mkModuleGraph nodes + in case checkModuleGraph mg of + [] -> Right mg + errors -> Left errors + +-------------------------------------------------------------------------------- +-- * Module Graph Nodes +-------------------------------------------------------------------------------- + +-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'. +-- Edges between nodes mark dependencies arising from module imports +-- and dependencies arising from backpack instantiations. +data ModuleGraphNode + -- | Instantiation nodes track the instantiation of other units + -- (backpack dependencies) with the holes (signatures) of the current package. + = InstantiationNode UnitId InstantiatedUnit + -- | There is a module node for each module being built. + -- A node is either fixed or can be compiled. + -- - Fixed modules are not compiled, the artifacts are just loaded from disk. + -- It is up to your to make sure the artifacts are up to date and available. + -- - Compile modules are compiled from source if needed. + | ModuleNode [ModuleNodeEdge] ModuleNodeInfo + -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit. + | LinkNode [NodeKey] UnitId + -- | Package dependency + | UnitNode [UnitId] UnitId + + +data ModuleNodeEdge = ModuleNodeEdge { edgeLevel :: ImportLevel + , edgeTargetKey :: NodeKey } + +mkModuleEdge :: ImportLevel -> NodeKey -> ModuleNodeEdge +mkModuleEdge level key = ModuleNodeEdge level key + +-- | A 'normal' edge in the graph which isn't offset by an import stage. +mkNormalEdge :: NodeKey -> ModuleNodeEdge +mkNormalEdge = mkModuleEdge NormalLevel + +instance Outputable ModuleNodeEdge where + ppr (ModuleNodeEdge level key) = + let level_str = case level of + NormalLevel -> "" + SpliceLevel -> "(S)" + QuoteLevel -> "(Q)" + in text level_str <> ppr key + +data ModuleGraphInvariantError = + FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey] + | DuplicateModuleNodeKey NodeKey + | DependencyNotInGraph NodeKey [NodeKey] + deriving (Eq, Ord) + +instance Outputable ModuleGraphInvariantError where + ppr = \case + FixedNodeDependsOnCompileNode key bad_deps -> + text "Fixed node" <+> ppr key <+> text "depends on compile nodes" <+> ppr bad_deps + DuplicateModuleNodeKey k -> + text "Duplicate module node key" <+> ppr k + DependencyNotInGraph from to -> + text "Dependency not in graph" <+> ppr from <+> text "->" <+> ppr to + +-- Used for invariant checking. Is a NodeKey fixed or compilable? +data ModuleNodeType = MN_Fixed | MN_Compile + +instance Outputable ModuleNodeType where + ppr = \case + MN_Fixed -> text "Fixed" + MN_Compile -> text "Compile" + +moduleNodeType :: ModuleGraphNode -> ModuleNodeType +moduleNodeType (ModuleNode _ (ModuleNodeCompile _)) = MN_Compile +moduleNodeType (ModuleNode _ (ModuleNodeFixed _ _)) = MN_Fixed +moduleNodeType (UnitNode {}) = MN_Fixed +moduleNodeType _ = MN_Compile + +checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError] +checkModuleGraph ModuleGraph{..} = + mapMaybe (checkFixedModuleInvariant node_types) mg_mss + ++ mapMaybe (checkAllDependenciesInGraph node_types) mg_mss + ++ duplicate_errs + where + duplicate_errs = rights (Map.elems node_types) + + node_types :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + node_types = Map.fromListWithKey go [ (mkNodeKey n, Left (moduleNodeType n)) | n <- mg_mss ] + where + -- Multiple nodes with the same key are not allowed. + go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + -> Either ModuleNodeType ModuleGraphInvariantError + go k _ _ = Right (DuplicateModuleNodeKey k) + +-- | Check that all dependencies in the graph are present in the node_types map. +-- This is a helper function used by checkModuleGraph. +checkAllDependenciesInGraph :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkAllDependenciesInGraph node_types node = + let nodeKey = mkNodeKey node + deps = mgNodeDependencies False node + missingDeps = filter (\dep -> not (Map.member dep node_types)) deps + in if null missingDeps + then Nothing + else Just (DependencyNotInGraph nodeKey missingDeps) + + +-- | Check if for the fixed module node invariant: +-- +-- Fixed nodes can only depend on other fixed nodes. +checkFixedModuleInvariant :: Map.Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError) + -> ModuleGraphNode + -> Maybe ModuleGraphInvariantError +checkFixedModuleInvariant node_types node = case node of + ModuleNode deps (ModuleNodeFixed key _) -> + let check_node dep = case Map.lookup dep node_types of + -- Dependency is not fixed + Just (Left MN_Compile) -> Just dep + _ -> Nothing + bad_deps = mapMaybe check_node (map edgeTargetKey deps) + in if null bad_deps + then Nothing + else Just (FixedNodeDependsOnCompileNode key bad_deps) + + _ -> Nothing + + +{- Note [Module Types in the ModuleGraph] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules can be one of two different types in the module graph. + +1. ModuleNodeCompile, modules with source files we can compile. +2. ModuleNodeFixed, modules which we presume are already compiled and available. + +The ModuleGraph can contain a combination of these two types of nodes but must +obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant +can be checked by the `checkModuleGraph` function, but it's +the responsibility of the code constructing the ModuleGraph to ensure it is upheld. + +At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes. + +In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know +information about the module graph still (for example, getLinkDeps). + +In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and +there is a simple test in FixedNodes, which can be extended in future to cover +any missing cases. + +-} +data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation + | ModuleNodeCompile ModSummary + +-- | Extract the Module from a ModuleNodeInfo +moduleNodeInfoModule :: ModuleNodeInfo -> Module +moduleNodeInfoModule (ModuleNodeFixed key _) = mnkToModule key +moduleNodeInfoModule (ModuleNodeCompile ms) = ms_mod ms + +-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo +moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid +moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed key _) = key +moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ms) = msKey ms + +-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it. +moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource +moduleNodeInfoHscSource (ModuleNodeFixed _ _) = Nothing +moduleNodeInfoHscSource (ModuleNodeCompile ms) = Just (ms_hsc_src ms) + +-- | Extract the ModLocation from a ModuleNodeInfo +moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation +moduleNodeInfoLocation (ModuleNodeFixed _ loc) = loc +moduleNodeInfoLocation (ModuleNodeCompile ms) = ms_location ms + +-- | Extract the IsBootInterface from a ModuleNodeInfo +isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface +isBootModuleNodeInfo (ModuleNodeFixed mnwib _) = mnkIsBoot mnwib +isBootModuleNodeInfo (ModuleNodeCompile ms) = isBootSummary ms + +-- | Extract the ModuleName from a ModuleNodeInfo +moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName +moduleNodeInfoModuleName m = moduleName (moduleNodeInfoModule m) + +moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId +moduleNodeInfoUnitId (ModuleNodeFixed key _) = mnkUnitId key +moduleNodeInfoUnitId (ModuleNodeCompile ms) = ms_unitid ms + +moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot +moduleNodeInfoMnwib (ModuleNodeFixed key _) = mnkModuleName key +moduleNodeInfoMnwib (ModuleNodeCompile ms) = ms_mnwib ms + +-- | Collect the immediate dependencies of a ModuleGraphNode, +-- optionally avoiding hs-boot dependencies. +-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is +-- an equivalent .hs-boot, add a link from the former to the latter. This +-- has the effect of detecting bogus cases where the .hs-boot depends on the +-- .hs, by introducing a cycle. Additionally, it ensures that we will always +-- process the .hs-boot before the .hs, and so the HomePackageTable will always +-- have the most up to date information. +mgNodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey] +mgNodeDependencies drop_hs_boot_nodes = \case + LinkNode deps _uid -> deps + InstantiationNode uid iuid -> + [ NodeKey_Module (ModNodeKeyWithUid (GWIB mod NotBoot) uid) | mod <- uniqDSetToList (instUnitHoles iuid) ] + ++ [ NodeKey_ExternalUnit (instUnitInstanceOf iuid) ] + ModuleNode deps _ms -> + map (drop_hs_boot . edgeTargetKey) deps + UnitNode deps _ -> map NodeKey_ExternalUnit deps + where + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature + | otherwise = IsBoot + + drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid)) = (NodeKey_Module (ModNodeKeyWithUid (GWIB mn hs_boot_key) uid)) + drop_hs_boot x = x + +mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo +mgNodeIsModule (InstantiationNode {}) = Nothing +mgNodeIsModule (LinkNode {}) = Nothing +mgNodeIsModule (ModuleNode _ ms) = Just ms +mgNodeIsModule (UnitNode {}) = Nothing + +mgNodeUnitId :: ModuleGraphNode -> UnitId +mgNodeUnitId mgn = + case mgn of + InstantiationNode uid _iud -> uid + ModuleNode _ ms -> toUnitId (moduleUnit (moduleNodeInfoModule ms)) + LinkNode _ uid -> uid + UnitNode _ uid -> uid + +instance Outputable ModuleGraphNode where + ppr = \case + InstantiationNode _ iuid -> ppr iuid + ModuleNode nks ms -> ppr (mnKey ms) <+> ppr nks + LinkNode uid _ -> text "LN:" <+> ppr uid + UnitNode _ uid -> text "P:" <+> ppr uid + +instance Eq ModuleGraphNode where + (==) = (==) `on` mkNodeKey + +instance Ord ModuleGraphNode where + compare = compare `on` mkNodeKey + +-------------------------------------------------------------------------------- +-- * Module Graph operations +-------------------------------------------------------------------------------- +-- | Returns the number of nodes in a 'ModuleGraph' +lengthMG :: ModuleGraph -> Int +lengthMG = length . mg_mss + +isEmptyMG :: ModuleGraph -> Bool +isEmptyMG = null . mg_mss + +-------------------------------------------------------------------------------- +-- ** ModSummaries +-------------------------------------------------------------------------------- + +-- | Map a function 'f' over all the 'ModSummaries'. +-- To preserve invariants, 'f' can't change the isBoot status. +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG f mg@ModuleGraph{..} = mg + { mg_mss = flip fmap mg_mss $ \case + InstantiationNode uid iuid -> InstantiationNode uid iuid + LinkNode uid nks -> LinkNode uid nks + ModuleNode deps (ModuleNodeFixed key loc) -> ModuleNode deps (ModuleNodeFixed key loc) + ModuleNode deps (ModuleNodeCompile ms) -> ModuleNode deps (ModuleNodeCompile (f ms)) + UnitNode deps uid -> UnitNode deps uid + } + +-- | Map a function 'f' over all the 'ModSummaries', in 'IO'. +-- To preserve invariants, 'f' can't change the isBoot status. +mgMapM :: (ModuleNodeInfo -> IO ModuleNodeInfo) -> ModuleGraph -> IO ModuleGraph +mgMapM f mg@ModuleGraph{..} = do + mss' <- forM mg_mss $ \case + InstantiationNode uid iuid -> pure $ InstantiationNode uid iuid + LinkNode uid nks -> pure $ LinkNode uid nks + ModuleNode deps ms -> ModuleNode deps <$> (f ms) + UnitNode deps uid -> pure $ UnitNode deps uid + return $ mg { mg_mss = mss' } + + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries mg = [ m | ModuleNode _ (ModuleNodeCompile m) <- mgModSummaries' mg ] + +-- | Look up a non-boot ModSummary in the ModuleGraph. +-- +-- Careful: Linear in the size of the module graph +-- MP: This should probably be level aware +mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo +mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + , moduleNodeInfoModule ms == m + = Just ms + go _ = Nothing + +-- | Lookup up a 'ModuleNameWithIsBoot' in the 'ModuleGraph'. +-- +-- Multiple nodes in the 'ModuleGraph' can have the same 'ModuleName' +-- and 'IsBootInterface'. +-- +-- Careful: Linear in the size of the module graph. +mgLookupModuleName :: ModuleGraph -> ModuleNameWithIsBoot -> [ModuleNodeInfo] +mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | moduleNodeInfoMnwib ms == m + = Just ms + go _ = Nothing + +mgMember :: ModuleGraph -> NodeKey -> Bool +mgMember graph k = isJust $ snd (mg_graph graph) k + +-- | A function you should not need to use, or desire to use. Only used +-- in one place, `GHC.Iface.Load` to facilitate a misimplementation in Backpack. +mgHasHoles :: ModuleGraph -> Bool +mgHasHoles ModuleGraph{..} = mg_has_holes + +-------------------------------------------------------------------------------- +-- ** Reachability +-------------------------------------------------------------------------------- + +-- | Return all nodes reachable from the given 'NodeKey'. +-- +-- @Nothing@ if the key couldn't be found in the graph. +mgReachable :: ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode] +mgReachable mg nk = map summaryNodeSummary <$> modules_below where + (td_map, lookup_node) = mg_graph mg + modules_below = + allReachable td_map <$> lookup_node nk + +-- | Things which are reachable if hs-boot files are ignored. Used by 'getLinkDeps' +mgReachableLoop :: ModuleGraph -> [NodeKey] -> [ModuleGraphNode] +mgReachableLoop mg nk = map summaryNodeSummary modules_below where + (td_map, lookup_node) = mg_loop_graph mg + modules_below = + allReachableMany td_map (mapMaybe lookup_node nk) + + +-- | @'mgQueryZero' g root b@ answers the question: can we reach @b@ from @root@ +-- in the module graph @g@, only using normal (level 0) imports? +mgQueryZero :: ModuleGraph + -> ZeroScopeKey + -> ZeroScopeKey + -> Bool +mgQueryZero mg nka nkb = isReachable td_map na nb where + (td_map, lookup_node) = mg_zero_graph mg + na = expectJust $ lookup_node nka + nb = expectJust $ lookup_node nkb + + +-- | Reachability Query. +-- +-- @mgQuery(g, a, b)@ asks: +-- Can we reach @b@ from @a@ in graph @g@? +-- +-- Both @a@ and @b@ must be in @g@. +mgQuery :: ModuleGraph -- ^ @g@ + -> NodeKey -- ^ @a@ + -> NodeKey -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @a@ +mgQuery mg nka nkb = isReachable td_map na nb where + (td_map, lookup_node) = mg_graph mg + na = expectJust $ lookup_node nka + nb = expectJust $ lookup_node nkb + +-- | Many roots reachability Query. +-- +-- @mgQuery(g, roots, b)@ asks: +-- Can we reach @b@ from any of the @roots@ in graph @g@? +-- +-- Node @b@ must be in @g@. +mgQueryMany :: ModuleGraph -- ^ @g@ + -> [NodeKey] -- ^ @roots@ + -> NodeKey -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @roots@ +mgQueryMany mg roots nkb = isReachableMany td_map nroots nb where + (td_map, lookup_node) = mg_graph mg + nroots = mapMaybe lookup_node roots + nb = expectJust $ lookup_node nkb + +-- | Many roots reachability Query. +-- +-- @mgQuery(g, roots, b)@ asks: +-- Can we reach @b@ from any of the @roots@ in graph @g@, only using normal (level 0) imports? +-- +-- Node @b@ must be in @g@. +mgQueryManyZero :: ModuleGraph -- ^ @g@ + -> [ZeroScopeKey] -- ^ @roots@ + -> ZeroScopeKey -- ^ @b@ + -> Bool -- ^ @b@ is reachable from @roots@ +mgQueryManyZero mg roots nkb = isReachableMany td_map nroots nb where + (td_map, lookup_node) = mg_zero_graph mg + nroots = mapMaybe lookup_node roots + nb = expectJust $ lookup_node (pprTrace "mg" (ppr nkb) nkb) + +-------------------------------------------------------------------------------- +-- ** Other operations (read haddocks on export list) +-------------------------------------------------------------------------------- + +mgModSummaries' :: ModuleGraph -> [ModuleGraphNode] +mgModSummaries' = mg_mss + +-- | Turn a list of graph nodes into an efficient queriable graph. +-- The first boolean parameter indicates whether nodes corresponding to hs-boot files +-- should be collapsed into their relevant hs nodes. +moduleGraphNodes :: Bool + -> [ModuleGraphNode] + -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + -- Map from module to extra boot summary dependencies which need to be merged in + (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries + + where + go (s, key) = + case s of + ModuleNode __deps ms | isBootModuleNodeInfo ms == IsBoot, drop_hs_boot_nodes + -- Using nodeDependencies here converts dependencies on other + -- boot files to dependencies on dependencies on non-boot files. + -> Left (moduleNodeInfoModule ms, mgNodeDependencies drop_hs_boot_nodes s) + _ -> normal_case + where + normal_case = + let lkup_key = moduleNodeInfoModule <$> mgNodeIsModule s + extra = (lkup_key >>= \key -> Map.lookup key boot_summaries) + + in Right $ DigraphNode s key $ out_edge_keys $ + (fromMaybe [] extra + ++ mgNodeDependencies drop_hs_boot_nodes s) + + numbered_summaries = zip summaries [1..] + + lookup_node :: NodeKey -> Maybe SummaryNode + lookup_node key = Map.lookup key (unNodeMap node_map) + + lookup_key :: NodeKey -> Maybe Int + lookup_key = fmap summaryNodeKey . lookup_node + + node_map :: NodeMap SummaryNode + node_map = NodeMap $ + Map.fromList [ (mkNodeKey s, node) + | node <- nodes + , let s = summaryNodeSummary node + ] + + out_edge_keys :: [NodeKey] -> [Int] + out_edge_keys = mapMaybe lookup_key + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else False + + +-- | This function returns all the modules belonging to the home-unit that can +-- be reached by following the given dependencies. Additionally, if both the +-- boot module and the non-boot module can be reached, it only returns the +-- non-boot one. +moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid +moduleGraphModulesBelow mg uid mn = filtered_mods [ mn | NodeKey_Module mn <- modules_below] + where + modules_below = maybe [] (map mkNodeKey) (mgReachable mg (NodeKey_Module (ModNodeKeyWithUid mn uid))) + filtered_mods = Set.fromDistinctAscList . filter_mods . sort + + -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list + -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a + -- linear sweep with a window of size 2 to remove boot modules for which we + -- have the corresponding non-boot. + filter_mods = \case + (r1@(ModNodeKeyWithUid (GWIB m1 b1) uid1) : r2@(ModNodeKeyWithUid (GWIB m2 _) uid2): rs) + | m1 == m2 && uid1 == uid2 -> + let !r' = case b1 of + NotBoot -> r1 + IsBoot -> r2 + in r' : filter_mods rs + | otherwise -> r1 : filter_mods (r2:rs) + rs -> rs + +-- | This function filters out all the instantiation nodes from each SCC of a +-- topological sort. Use this with care, as the resulting "strongly connected components" +-- may not really be strongly connected in a direct way, as instantiations have been +-- removed. It would probably be best to eliminate uses of this function where possible. +filterToposortToModules + :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo] +filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case + ModuleNode _deps node -> Just node + _ -> Nothing + where + -- This higher order function is somewhat bogus, + -- as the definition of "strongly connected component" + -- is not necessarily respected. + mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b) + mapMaybeSCC f = \case + AcyclicSCC a -> AcyclicSCC <$> f a + CyclicSCC as -> case mapMaybe f as of + [] -> Nothing + [a] -> Just $ AcyclicSCC a + as -> Just $ CyclicSCC as + +-------------------------------------------------------------------------------- +-- * Keys into ModuleGraph +-------------------------------------------------------------------------------- + +data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit + | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid + | NodeKey_Link !UnitId + | NodeKey_ExternalUnit !UnitId + deriving (Eq, Ord) + +instance Outputable NodeKey where + ppr (NodeKey_Unit iu) = ppr iu + ppr (NodeKey_Module mk) = ppr mk + ppr (NodeKey_Link uid) = ppr uid + ppr (NodeKey_ExternalUnit uid) = ppr uid + +mkNodeKey :: ModuleGraphNode -> NodeKey +mkNodeKey = \case + InstantiationNode _ iu -> NodeKey_Unit iu + ModuleNode _ x -> NodeKey_Module $ mnKey x + LinkNode _ uid -> NodeKey_Link uid + UnitNode _ uid -> NodeKey_ExternalUnit uid + +nodeKeyUnitId :: NodeKey -> UnitId +nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu +nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk +nodeKeyUnitId (NodeKey_Link uid) = uid +nodeKeyUnitId (NodeKey_ExternalUnit uid) = uid + +nodeKeyModName :: NodeKey -> Maybe ModuleName +nodeKeyModName (NodeKey_Module mk) = Just (gwib_mod $ mnkModuleName mk) +nodeKeyModName _ = Nothing + +msKey :: ModSummary -> ModNodeKeyWithUid +msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) + +mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid +mnKey (ModuleNodeFixed key _) = key +mnKey (ModuleNodeCompile ms) = msKey ms + +miKey :: ModIface -> ModNodeKeyWithUid +miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi))) + +type ModNodeKey = ModuleNameWithIsBoot + +-------------------------------------------------------------------------------- +-- ** Internal node representation (exposed) +-------------------------------------------------------------------------------- + +type SummaryNode = Node Int ModuleGraphNode + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey = node_key + +summaryNodeSummary :: SummaryNode -> ModuleGraphNode +summaryNodeSummary = node_payload + +-------------------------------------------------------------------------------- +-- * Misc utilities +-------------------------------------------------------------------------------- + +showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc +showModMsg dflags _ (LinkNode {}) = + let staticLink = case ghcLink dflags of + LinkStaticLib -> True + _ -> False + + platform = targetPlatform dflags + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) + in text exe_file +showModMsg _ _ (UnitNode _deps uid) = ppr uid +showModMsg _ _ (InstantiationNode _uid indef_unit) = + ppr $ instUnitInstanceOf indef_unit +showModMsg dflags recomp (ModuleNode _ mni) = + if gopt Opt_HideSourcePaths dflags + then text mod_str + else hsep $ + [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') + , char '(' + , text (moduleNodeInfoSource mni) <> char ',' + , moduleNodeInfoExtraMessage dflags recomp mni, char ')' ] + where + mod_str = moduleNameString (moduleName (moduleNodeInfoModule mni)) ++ + moduleNodeInfoBootString mni + +-- | Extra information about a 'ModuleNodeInfo' to display in the progress message. +moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc +moduleNodeInfoExtraMessage dflags recomp (ModuleNodeCompile mod_summary) = + let dyn_file = normalise $ msDynObjFilePath mod_summary + obj_file = normalise $ msObjFilePath mod_summary + files = obj_file + :| [ dyn_file | gopt Opt_BuildDynamicToo dflags ] + ++ [ "interpreted" | gopt Opt_ByteCodeAndObjectCode dflags ] + in case backendSpecialModuleSource (backend dflags) recomp of + Just special -> text special + Nothing -> foldr1 (\ofile rest -> ofile <> comma <+> rest) (NE.map text files) +moduleNodeInfoExtraMessage _ _ (ModuleNodeFixed {}) = text "fixed" + + +-- | The source location of the module node to show to the user. +moduleNodeInfoSource :: ModuleNodeInfo -> FilePath +moduleNodeInfoSource (ModuleNodeCompile ms) = normalise $ msHsFilePath ms +moduleNodeInfoSource (ModuleNodeFixed _ loc) = normalise $ ml_hi_file loc + +-- | The extra info about a module [boot] or [sig] to display. +moduleNodeInfoBootString :: ModuleNodeInfo -> String +moduleNodeInfoBootString (ModuleNodeCompile ms) = hscSourceString (ms_hsc_src ms) +moduleNodeInfoBootString mn@(ModuleNodeFixed {}) = + hscSourceString (case isBootModuleNodeInfo mn of + IsBoot -> HsBootFile + NotBoot -> HsSrcFile) + +-------------------------------------------------------------------------------- +-- * Internal methods for module graph +-- +-- These are *really* meant to be internal! +-- Don't expose them without careful consideration about the invariants +-- described in the export list haddocks. +-------------------------------------------------------------------------------- + +newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a } + deriving (Functor, Traversable, Foldable) + +-- | Transitive dependencies, including SOURCE edges +mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) +mkTransDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodes False + +-- | Transitive dependencies, ignoring SOURCE edges +mkTransLoopDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode) +mkTransLoopDeps = first cyclicGraphReachability . moduleGraphNodes True + +-- | Transitive dependencies, but only following "normal" level 0 imports. +-- This graph can be used to query what the transitive dependencies of a particular +-- level are within a module. +mkTransZeroDeps :: [ModuleGraphNode] -> (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode) +mkTransZeroDeps = first graphReachability {- module graph is acyclic -} . moduleGraphNodesZero + +-- | Transitive dependencies, but with the stage that each module is required at. +mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) +mkStageDeps = first cyclicGraphReachability . moduleGraphNodesStages + +type ZeroSummaryNode = Node Int ZeroScopeKey + +zeroSummaryNodeKey :: ZeroSummaryNode -> Int +zeroSummaryNodeKey = node_key + +zeroSummaryNodeSummary :: ZeroSummaryNode -> ZeroScopeKey +zeroSummaryNodeSummary = node_payload + +-- | The 'ZeroScopeKey' indicates the different scopes which we can refer to in a zero-scope query. +data ZeroScopeKey = ModuleScope ModNodeKeyWithUid ImportLevel | UnitScope UnitId + deriving (Eq, Ord) + +instance Outputable ZeroScopeKey where + ppr (ModuleScope mk il) = text "ModuleScope" <+> ppr mk <+> ppr il + ppr (UnitScope uid) = text "UnitScope" <+> ppr uid + +-- | Turn a list of graph nodes into an efficient queriable graph. +-- This graph only has edges between level-0 imports +-- +-- This query answers the question. If I am looking at level n in module M then which +-- modules are visible? +-- +-- If you are looking at level -1 then the reachable modules are those imported at splice and +-- then any modules those modules import at zero. (Ie the zero scope for those modules) +moduleGraphNodesZero :: + [ModuleGraphNode] + -> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode) +moduleGraphNodesZero summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + nodes = mapMaybe go numbered_summaries + + where + go :: (((ModuleGraphNode, ImportLevel)), Int) -> Maybe ZeroSummaryNode + go (((ModuleNode nks ms), s), key) = Just $ + DigraphNode (ModuleScope (mnKey ms) s) key $ out_edge_keys $ + mapMaybe (classifyDeps s) nks + go (((UnitNode uids uid), _s), key) = + Just $ DigraphNode (UnitScope uid) key (mapMaybe lookup_key $ map UnitScope uids) + go _ = Nothing + + -- This is the key part, a dependency edge also depends on the NormalLevel scope of an import. + classifyDeps s (ModuleNodeEdge il (NodeKey_Module k)) | s == il = Just (ModuleScope k NormalLevel) + classifyDeps s (ModuleNodeEdge il (NodeKey_ExternalUnit u)) | s == il = Just (UnitScope u) + classifyDeps _ _ = Nothing + + numbered_summaries :: [((ModuleGraphNode, ImportLevel), Int)] + numbered_summaries = zip (([(s, l) | s <- summaries, l <- [SpliceLevel, QuoteLevel, NormalLevel]])) [0..] + + lookup_node :: ZeroScopeKey -> Maybe ZeroSummaryNode + lookup_node key = Map.lookup key node_map + + lookup_key :: ZeroScopeKey -> Maybe Int + lookup_key = fmap zeroSummaryNodeKey . lookup_node + + node_map :: Map.Map ZeroScopeKey ZeroSummaryNode + node_map = + Map.fromList [ (s, node) + | node <- nodes + , let s = zeroSummaryNodeSummary node + ] + + out_edge_keys :: [ZeroScopeKey] -> [Int] + out_edge_keys = mapMaybe lookup_key + +type StageSummaryNode = Node Int (NodeKey, ModuleStage) + +stageSummaryNodeKey :: StageSummaryNode -> Int +stageSummaryNodeKey = node_key + +stageSummaryNodeSummary :: StageSummaryNode -> (NodeKey, ModuleStage) +stageSummaryNodeSummary = node_payload + +-- | Turn a list of graph nodes into an efficient queriable graph. +-- This graph has edges between modules and the stage they are required at. +-- +-- This graph can be used to answer the query, if I am compiling a module at stage +-- S, then what modules do I need at which stages for that? +-- Used by 'downsweep' in order to determine which modules need code generation if you +-- are using 'TemplateHaskell'. +-- +-- The rules for this query can be read in more detail in the Explicit Level Imports proposal. +-- Briefly: +-- * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage +-- * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages. +-- * Otherwise, an imported module is just needed at the normal stage. +-- +-- * A module using TemplateHaskellQuotes required at C stage is also required at R +-- stage. +moduleGraphNodesStages :: + [ModuleGraphNode] + -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) +moduleGraphNodesStages summaries = + (graphFromEdgedVerticesUniq nodes, lookup_node) + where + nodes = map go numbered_summaries + + where + go :: (((ModuleGraphNode, ModuleStage)), Int) -> StageSummaryNode + go (s, key) = normal_case s + where + normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode + normal_case ((m@(ModuleNode nks ms), s)) = + DigraphNode ((mkNodeKey m, s)) key $ out_edge_keys $ + selfEdges ms s (mkNodeKey m) ++ concatMap (classifyDeps ms s) nks + normal_case (m, s) = + DigraphNode (mkNodeKey m, s) key (out_edge_keys . map (, s) $ mgNodeDependencies False m) + + isExplicitStageMS :: ModSummary -> Bool + isExplicitStageMS ms = not (xopt LangExt.ImplicitStagePersistence (ms_hspp_opts ms)) + + isTemplateHaskellQuotesMS :: ModSummary -> Bool + isTemplateHaskellQuotesMS ms = xopt LangExt.TemplateHaskellQuotes (ms_hspp_opts ms) + + -- Accounting for persistence within a module. + -- If a module is required @ C and it persists an idenfifier, it's also required + -- at R. + selfEdges (ModuleNodeCompile ms) s self_key + | not (isExplicitStageMS ms) + && (isTemplateHaskellQuotesMS ms + || isTemplateHaskellOrQQNonBoot ms) + = [(self_key, s') | s' <- onlyFutureStages s] + selfEdges _ _ _ = [] + + -- Case 1. No implicit stage persistnce is enabled + classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge il k) + | isExplicitStageMS ms = case il of + SpliceLevel -> [(k, decModuleStage s)] + NormalLevel -> [(k, s)] + QuoteLevel -> [(k, incModuleStage s)] + -- Case 2a. TemplateHaskellQuotes case (section 5.6 in the paper) + classifyDeps (ModuleNodeCompile ms) s (ModuleNodeEdge _ k) + | not (isExplicitStageMS ms) + , not (isTemplateHaskellOrQQNonBoot ms) + , isTemplateHaskellQuotesMS ms + = [(k, s') | s' <- nowAndFutureStages s] + -- Case 2b. Template haskell is enabled, with implicit stage persistence + classifyDeps (ModuleNodeCompile ms) _ (ModuleNodeEdge _ k) + | isTemplateHaskellOrQQNonBoot ms + , not (isExplicitStageMS ms) = + [(k, s) | s <- allStages] + -- Case 3. No template haskell, therefore no additional dependencies. + classifyDeps _ s (ModuleNodeEdge _ k) = [(k, s)] + + + numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)] + numbered_summaries = zip (([(s, l) | s <- summaries, l <- allStages])) [0..] + + lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode + lookup_node key = Map.lookup key node_map + + lookup_key :: (NodeKey, ModuleStage) -> Maybe Int + lookup_key = fmap stageSummaryNodeKey . lookup_node + + node_map :: Map.Map (NodeKey, ModuleStage) StageSummaryNode + node_map = + Map.fromList [ (s, node) + | node <- nodes + , let s = stageSummaryNodeSummary node + ] + + out_edge_keys :: [(NodeKey, ModuleStage)] -> [Int] + out_edge_keys = mapMaybe lookup_key + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- IsBoot; else False + + +-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is +-- not an element of the ModuleGraph. +extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph +extendMG ModuleGraph{..} node = + ModuleGraph + { mg_mss = node : mg_mss + , mg_graph = mkTransDeps (node : mg_mss) + , mg_loop_graph = mkTransLoopDeps (node : mg_mss) + , mg_zero_graph = mkTransZeroDeps (node : mg_mss) + , mg_has_holes = mg_has_holes || maybe False isHsigFile (moduleNodeInfoHscSource =<< mgNodeIsModule node) + } + diff --git a/GHC/Unit/Module/Imported.hs b/GHC/Unit/Module/Imported.hs --- a/GHC/Unit/Module/Imported.hs +++ b/GHC/Unit/Module/Imported.hs @@ -13,10 +13,13 @@ import GHC.Types.Name.Reader import GHC.Types.SafeHaskell import GHC.Types.SrcLoc +import Data.Map (Map) -- | Records the modules directly imported by a module for extracting e.g. -- usage information, and also to give better error message -type ImportedMods = ModuleEnv [ImportedBy] +type ImportedMods = Map Module [ImportedBy] + -- We don't want to use a `ModuleEnv` since it would leak a non-deterministic + -- order to the interface files when passed as a list to `mkUsageInfo`. -- | If a module was "imported" by the user, we associate it with -- more detailed usage information 'ImportedModsVal'; a module @@ -39,6 +42,9 @@ , imv_is_safe :: IsSafeImport -- ^ whether this is a safe import + + , imv_is_level :: ImportLevel + -- ^ the level the module is imported at (splice, quote, or normal) , imv_is_hiding :: Bool -- ^ whether this is an "hiding" import diff --git a/GHC/Unit/Module/Location.hs b/GHC/Unit/Module/Location.hs --- a/GHC/Unit/Module/Location.hs +++ b/GHC/Unit/Module/Location.hs @@ -1,25 +1,40 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- | Module location module GHC.Unit.Module.Location - ( ModLocation(..) + ( ModLocation + ( .. + , ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + ) + , pattern ModLocation , addBootSuffix - , addBootSuffix_maybe - , addBootSuffixLocn_maybe , addBootSuffixLocn , addBootSuffixLocnOut , removeBootSuffix + , mkFileSrcSpan ) where import GHC.Prelude -import GHC.Unit.Types + +import GHC.Data.OsPath +import GHC.Types.SrcLoc import GHC.Utils.Outputable +import GHC.Data.FastString (mkFastString) +import qualified System.OsString as OsString + -- | Module Location -- -- Where a module lives on the file system: the actual locations -- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them. -- --- For a module in another unit, the ml_hs_file and ml_obj_file components of +-- For a module in another unit, the ml_hs_file_ospath and ml_obj_file_ospath components of -- ModLocation are undefined. -- -- The locations specified by a ModLocation may or may not @@ -38,31 +53,31 @@ -- boot suffixes in mkOneShotModLocation. data ModLocation - = ModLocation { - ml_hs_file :: Maybe FilePath, + = OsPathModLocation { + ml_hs_file_ospath :: Maybe OsPath, -- ^ The source file, if we have one. Package modules -- probably don't have source files. - ml_hi_file :: FilePath, + ml_hi_file_ospath :: OsPath, -- ^ Where the .hi file is, whether or not it exists -- yet. Always of form foo.hi, even if there is an -- hi-boot file (we add the -boot suffix later) - ml_dyn_hi_file :: FilePath, + ml_dyn_hi_file_ospath :: OsPath, -- ^ Where the .dyn_hi file is, whether or not it exists -- yet. - ml_obj_file :: FilePath, + ml_obj_file_ospath :: OsPath, -- ^ Where the .o file is, whether or not it exists yet. -- (might not exist either because the module hasn't -- been compiled yet, or because it is part of a -- unit with a .a file) - ml_dyn_obj_file :: FilePath, + ml_dyn_obj_file_ospath :: OsPath, -- ^ Where the .dy file is, whether or not it exists -- yet. - ml_hie_file :: FilePath + ml_hie_file_ospath :: OsPath -- ^ Where the .hie file is, whether or not it exists -- yet. } deriving Show @@ -71,46 +86,67 @@ ppr = text . show -- | Add the @-boot@ suffix to .hs, .hi and .o files -addBootSuffix :: FilePath -> FilePath -addBootSuffix path = path ++ "-boot" +addBootSuffix :: OsPath -> OsPath +addBootSuffix path = path `mappend` os "-boot" -- | Remove the @-boot@ suffix to .hs, .hi and .o files -removeBootSuffix :: FilePath -> FilePath -removeBootSuffix "-boot" = [] -removeBootSuffix (x:xs) = x : removeBootSuffix xs -removeBootSuffix [] = error "removeBootSuffix: no -boot suffix" - - --- | Add the @-boot@ suffix if the @Bool@ argument is @True@ -addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath -addBootSuffix_maybe is_boot path = case is_boot of - IsBoot -> addBootSuffix path - NotBoot -> path - -addBootSuffixLocn_maybe :: IsBootInterface -> ModLocation -> ModLocation -addBootSuffixLocn_maybe is_boot locn = case is_boot of - IsBoot -> addBootSuffixLocn locn - _ -> locn +removeBootSuffix :: OsPath -> OsPath +removeBootSuffix pathWithBootSuffix = + case OsString.stripSuffix (os "-boot") pathWithBootSuffix of + Just path -> path + Nothing -> error "removeBootSuffix: no -boot suffix" -- | Add the @-boot@ suffix to all file paths associated with the module addBootSuffixLocn :: ModLocation -> ModLocation addBootSuffixLocn locn - = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) - , ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) } + = addBootSuffixLocnOut locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn) } -- | Add the @-boot@ suffix to all output file paths associated with the -- module, not including the input file itself addBootSuffixLocnOut :: ModLocation -> ModLocation addBootSuffixLocnOut locn - = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) - , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn) - , ml_obj_file = addBootSuffix (ml_obj_file locn) - , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn) - , ml_hie_file = addBootSuffix (ml_hie_file locn) + = locn { ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn) + , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn) + , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn) + , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn) + , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) } +-- | Compute a 'SrcSpan' from a 'ModLocation'. +mkFileSrcSpan :: ModLocation -> SrcSpan +mkFileSrcSpan mod_loc + = case ml_hs_file mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + Nothing -> interactiveSrcSpan -- Presumably +-- ---------------------------------------------------------------------------- +-- Helpers for backwards compatibility +-- ---------------------------------------------------------------------------- + +{-# COMPLETE ModLocation #-} + +pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation +pattern ModLocation + { ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + } <- OsPathModLocation + { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file) + , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file) + , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file) + , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file) + , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file) + , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file) + } where + ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file + = OsPathModLocation + { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file + , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file + , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file + , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file + , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file + , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file + } diff --git a/GHC/Unit/Module/ModDetails.hs b/GHC/Unit/Module/ModDetails.hs --- a/GHC/Unit/Module/ModDetails.hs +++ b/GHC/Unit/Module/ModDetails.hs @@ -10,6 +10,7 @@ import GHC.Types.Avail import GHC.Types.CompleteMatch +import GHC.Types.DefaultEnv import GHC.Types.TypeEnv import GHC.Types.Annotations ( Annotation ) @@ -23,6 +24,9 @@ -- ^ Local type environment for this particular module -- Includes Ids, TyCons, PatSyns + , md_defaults :: !DefaultEnv + -- ^ default declarations exported by this module + , md_insts :: InstEnv -- ^ 'DFunId's for the instances in this module @@ -34,7 +38,7 @@ -- ^ Annotations present in this module: currently -- they only annotate things also declared in this module - , md_complete_matches :: [CompleteMatch] + , md_complete_matches :: CompleteMatches -- ^ Complete match pragmas for this module } @@ -43,6 +47,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv , md_exports = [] + , md_defaults = emptyDefaultEnv , md_insts = emptyInstEnv , md_rules = [] , md_fam_insts = [] diff --git a/GHC/Unit/Module/ModGuts.hs b/GHC/Unit/Module/ModGuts.hs --- a/GHC/Unit/Module/ModGuts.hs +++ b/GHC/Unit/Module/ModGuts.hs @@ -7,7 +7,7 @@ import GHC.Prelude -import GHC.ByteCode.Types +import GHC.HsToCore.Breakpoints import GHC.ForeignSrcLang import GHC.Hs @@ -27,6 +27,7 @@ import GHC.Types.Annotations ( Annotation ) import GHC.Types.Avail import GHC.Types.CompleteMatch +import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.ForeignStubs import GHC.Types.HpcInfo @@ -52,9 +53,8 @@ mg_exports :: ![AvailInfo], -- ^ What it exports mg_deps :: !Dependencies, -- ^ What it depends on, directly or -- otherwise - mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. + mg_usages :: !(Maybe [Usage]), -- ^ What was used? Used for interfaces. - mg_used_th :: !Bool, -- ^ Did we run a TH splice? mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment -- These fields all describe the things **declared in this module** @@ -62,6 +62,7 @@ -- Used for creating interface files. mg_tcs :: ![TyCon], -- ^ TyCons declared in this module -- (includes TyCons for classes) + mg_defaults :: !DefaultEnv , -- ^ Class defaults exported from this module mg_insts :: ![ClsInst], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module @@ -74,7 +75,7 @@ -- ^ Files to be compiled with the C compiler mg_warns :: !(Warnings GhcRn), -- ^ Warnings declared in the module mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches + mg_complete_matches :: CompleteMatches, -- ^ Complete Matches mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module @@ -139,7 +140,6 @@ cg_foreign_files :: ![(ForeignSrcLang, FilePath)], cg_dep_pkgs :: !(Set UnitId), -- ^ Dependent packages, used to -- generate #includes for C code gen - cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints cg_spt_entries :: [SptEntry] -- ^ Static pointer table entries for static forms defined in diff --git a/GHC/Unit/Module/ModIface.hs b/GHC/Unit/Module/ModIface.hs --- a/GHC/Unit/Module/ModIface.hs +++ b/GHC/Unit/Module/ModIface.hs @@ -4,627 +4,1273 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NamedFieldPuns #-} - -module GHC.Unit.Module.ModIface - ( ModIface - , ModIface_ (..) - , PartialModIface - , ModIfaceBackend (..) - , IfaceDeclExts - , IfaceBackendExts - , IfaceExport - , WhetherHasOrphans - , WhetherHasFamInst - , mi_boot - , mi_fix - , mi_semantic_module - , mi_free_holes - , mi_mnwib - , renameFreeHoles - , emptyPartialModIface - , emptyFullModIface - , mkIfaceHashCache - , emptyIfaceHashCache - , forceModIface - ) -where - -import GHC.Prelude - -import GHC.Hs - -import GHC.Iface.Syntax -import GHC.Iface.Ext.Fields - -import GHC.Unit -import GHC.Unit.Module.Deps -import GHC.Unit.Module.Warnings - -import GHC.Types.Avail -import GHC.Types.Fixity -import GHC.Types.Fixity.Env -import GHC.Types.HpcInfo -import GHC.Types.Name -import GHC.Types.Name.Reader -import GHC.Types.SafeHaskell -import GHC.Types.SourceFile -import GHC.Types.Unique.DSet -import GHC.Types.Unique.FM - -import GHC.Data.Maybe - -import GHC.Utils.Fingerprint -import GHC.Utils.Binary - -import Control.DeepSeq -import Control.Exception - -{- Note [Interface file stages] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Interface files have two possible stages. - -* A partial stage built from the result of the core pipeline. -* A fully instantiated form. Which also includes fingerprints and - potentially information provided by backends. - -We can build a full interface file two ways: -* Directly from a partial one: - Then we omit backend information and mostly compute fingerprints. -* From a partial one + information produced by a backend. - Then we store the provided information and fingerprint both. --} - -type PartialModIface = ModIface_ 'ModIfaceCore -type ModIface = ModIface_ 'ModIfaceFinal - --- | Extends a PartialModIface with information which is either: --- * Computed after codegen --- * Or computed just before writing the iface to disk. (Hashes) --- In order to fully instantiate it. -data ModIfaceBackend = ModIfaceBackend - { mi_iface_hash :: !Fingerprint - -- ^ Hash of the whole interface - , mi_mod_hash :: !Fingerprint - -- ^ Hash of the ABI only - , mi_flag_hash :: !Fingerprint - -- ^ Hash of the important flags used when compiling the module, excluding - -- optimisation flags - , mi_opt_hash :: !Fingerprint - -- ^ Hash of optimisation flags - , mi_hpc_hash :: !Fingerprint - -- ^ Hash of hpc flags - , mi_plugin_hash :: !Fingerprint - -- ^ Hash of plugins - , mi_orphan :: !WhetherHasOrphans - -- ^ Whether this module has orphans - , mi_finsts :: !WhetherHasFamInst - -- ^ Whether this module has family instances. See Note [The type family - -- instance consistency story]. - , mi_exp_hash :: !Fingerprint - -- ^ Hash of export list - , mi_orphan_hash :: !Fingerprint - -- ^ Hash for orphan rules, class and family instances combined - - -- Cached environments for easy lookup. These are computed (lazily) from - -- other fields and are not put into the interface file. - -- Not really produced by the backend but there is no need to create them - -- any earlier. - , mi_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn)) - -- ^ Cached lookup for 'mi_warns' for declaration deprecations - , mi_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn)) - -- ^ Cached lookup for 'mi_warns' for export deprecations - , mi_fix_fn :: !(OccName -> Maybe Fixity) - -- ^ Cached lookup for 'mi_fixities' - , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) - -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that - -- the thing isn't in decls. It's useful to know that when seeing if we are - -- up to date wrt. the old interface. The 'OccName' is the parent of the - -- name, if it has one. - } - -data ModIfacePhase - = ModIfaceCore - -- ^ Partial interface built based on output of core pipeline. - | ModIfaceFinal - --- | Selects a IfaceDecl representation. --- For fully instantiated interfaces we also maintain --- a fingerprint, which is used for recompilation checks. -type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where - IfaceDeclExts 'ModIfaceCore = IfaceDecl - IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) - -type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where - IfaceBackendExts 'ModIfaceCore = () - IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend - - - --- | A 'ModIface' plus a 'ModDetails' summarises everything we know --- about a compiled module. The 'ModIface' is the stuff *before* linking, --- and can be written out to an interface file. The 'ModDetails is after --- linking and can be completely recovered from just the 'ModIface'. --- --- When we read an interface file, we also construct a 'ModIface' from it, --- except that we explicitly make the 'mi_decls' and a few other fields empty; --- as when reading we consolidate the declarations etc. into a number of indexed --- maps and environments in the 'ExternalPackageState'. --- --- See Note [Strictness in ModIface] to learn about why some fields are --- strict and others are not. -data ModIface_ (phase :: ModIfacePhase) - = ModIface { - mi_module :: !Module, -- ^ Name of the module we are for - mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? - - mi_hsc_src :: !HscSource, -- ^ Boot? Signature? - - mi_deps :: Dependencies, - -- ^ The dependencies of the module. This is - -- consulted for directly-imported modules, but not - -- for anything else (hence lazy) - - mi_usages :: [Usage], - -- ^ Usages; kept sorted so that it's easy to decide - -- whether to write a new iface file (changing usages - -- doesn't affect the hash of this module) - -- NOT STRICT! we read this field lazily from the interface file - -- It is *only* consulted by the recompilation checker - - mi_exports :: ![IfaceExport], - -- ^ Exports - -- Kept sorted by (mod,occ), to make version comparisons easier - -- Records the modules that are the declaration points for things - -- exported by this module, and the 'OccName's of those things - - - mi_used_th :: !Bool, - -- ^ Module required TH splices when it was compiled. - -- This disables recompilation avoidance (see #481). - - mi_fixities :: [(OccName,Fixity)], - -- ^ Fixities - -- NOT STRICT! we read this field lazily from the interface file - - mi_warns :: IfaceWarnings, - -- ^ Warnings - -- NOT STRICT! we read this field lazily from the interface file - - mi_anns :: [IfaceAnnotation], - -- ^ Annotations - -- NOT STRICT! we read this field lazily from the interface file - - - mi_decls :: [IfaceDeclExts phase], - -- ^ Type, class and variable declarations - -- The hash of an Id changes if its fixity or deprecations change - -- (as well as its type of course) - -- Ditto data constructors, class operations, except that - -- the hash of the parent class/tycon changes - - mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo], - -- ^ Extra variable definitions which are **NOT** exposed but when - -- combined with mi_decls allows us to restart code generation. - -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs] - - mi_globals :: !(Maybe IfGlobalRdrEnv), - -- ^ Binds all the things defined at the top level in - -- the /original source/ code for this module. which - -- is NOT the same as mi_exports, nor mi_decls (which - -- may contains declarations for things not actually - -- defined by the user). Used for GHCi and for inspecting - -- the contents of modules via the GHC API only. - -- - -- (We need the source file to figure out the - -- top-level environment, if we didn't compile this module - -- from source then this field contains @Nothing@). - -- - -- Strictly speaking this field should live in the - -- 'HomeModInfo', but that leads to more plumbing. - - -- Instance declarations and rules - mi_insts :: [IfaceClsInst], -- ^ Sorted class instance - mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances - mi_rules :: [IfaceRule], -- ^ Sorted rules - - mi_hpc :: !AnyHpcUsage, - -- ^ True if this program uses Hpc at any point in the program. - - mi_trust :: !IfaceTrustInfo, - -- ^ Safe Haskell Trust information for this module. - - mi_trust_pkg :: !Bool, - -- ^ Do we require the package this module resides in be trusted - -- to trust this module? This is used for the situation where a - -- module is Safe (so doesn't require the package be trusted - -- itself) but imports some trustworthy modules from its own - -- package (which does require its own package be trusted). - -- See Note [Trust Own Package] in GHC.Rename.Names - mi_complete_matches :: ![IfaceCompleteMatch], - - mi_docs :: !(Maybe Docs), - -- ^ Docstrings and related data for use by haddock, the ghci - -- @:doc@ command, and other tools. - -- - -- @Just _@ @<=>@ the module was built with @-haddock@. - - mi_final_exts :: !(IfaceBackendExts phase), - -- ^ Either `()` or `ModIfaceBackend` for - -- a fully instantiated interface. - - mi_ext_fields :: !ExtensibleFields, - -- ^ Additional optional fields, where the Map key represents - -- the field name, resulting in a (size, serialized data) pair. - -- Because the data is intended to be serialized through the - -- internal `Binary` class (increasing compatibility with types - -- using `Name` and `FastString`, such as HIE), this format is - -- chosen over `ByteString`s. - -- - - mi_src_hash :: !Fingerprint - -- ^ Hash of the .hs source, used for recompilation checking. - } - -{- -Note [Strictness in ModIface] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The ModIface is the Haskell representation of an interface (.hi) file. - -* During compilation we write out ModIface values to disk for files - that we have just compiled -* For packages that we depend on we load the ModIface from disk. - -Some fields in the ModIface are deliberately lazy because when we read -an interface file we don't always need all the parts. For example, an -interface file contains information about documentation which is often -not needed during compilation. This is achieved using the lazyPut/lazyGet pair. -If the field was strict then we would pointlessly load this information into memory. - -On the other hand, if we create a ModIface but **don't** write it to -disk then to avoid space leaks we need to make sure to deepseq all these lazy fields -because the ModIface might live for a long time (for instance in a GHCi session). -That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to -forceModIface. --} - --- | Old-style accessor for whether or not the ModIface came from an hs-boot --- file. -mi_boot :: ModIface -> IsBootInterface -mi_boot iface = if mi_hsc_src iface == HsBootFile - then IsBoot - else NotBoot - -mi_mnwib :: ModIface -> ModuleNameWithIsBoot -mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface) - --- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be --- found, 'defaultFixity' is returned instead. -mi_fix :: ModIface -> OccName -> Fixity -mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity - --- | The semantic module for this interface; e.g., if it's a interface --- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' --- will be @@. -mi_semantic_module :: ModIface_ a -> Module -mi_semantic_module iface = case mi_sig_of iface of - Nothing -> mi_module iface - Just mod -> mod - --- | The "precise" free holes, e.g., the signatures that this --- 'ModIface' depends on. -mi_free_holes :: ModIface -> UniqDSet ModuleName -mi_free_holes iface = - case getModuleInstantiation (mi_module iface) of - (_, Just indef) - -- A mini-hack: we rely on the fact that 'renameFreeHoles' - -- drops things that aren't holes. - -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef)) - _ -> emptyUniqDSet - where - cands = dep_sig_mods $ mi_deps iface - --- | Given a set of free holes, and a unit identifier, rename --- the free holes according to the instantiation of the unit --- identifier. For example, if we have A and B free, and --- our unit identity is @p[A=,B=impl:B]@, the renamed free --- holes are just C. -renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName -renameFreeHoles fhs insts = - unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) - where - hmap = listToUFM insts - lookup_impl mod_name - | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod - -- It wasn't actually a hole - | otherwise = emptyUniqDSet - --- See Note [Strictness in ModIface] about where we use lazyPut vs put -instance Binary ModIface where - put_ bh (ModIface { - mi_module = mod, - mi_sig_of = sig_of, - mi_hsc_src = hsc_src, - mi_src_hash = _src_hash, -- Don't `put_` this in the instance - -- because we are going to write it - -- out separately in the actual file - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_used_th = used_th, - mi_fixities = fixities, - mi_warns = warns, - mi_anns = anns, - mi_decls = decls, - mi_extra_decls = extra_decls, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - mi_complete_matches = complete_matches, - mi_docs = docs, - mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we - -- can deal with it's pointer in the header - -- when we write the actual file - mi_final_exts = ModIfaceBackend { - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_exp_hash = exp_hash, - mi_orphan_hash = orphan_hash - }}) = do - put_ bh mod - put_ bh sig_of - put_ bh hsc_src - put_ bh iface_hash - put_ bh mod_hash - put_ bh flag_hash - put_ bh opt_hash - put_ bh hpc_hash - put_ bh plugin_hash - put_ bh orphan - put_ bh hasFamInsts - lazyPut bh deps - lazyPut bh usages - put_ bh exports - put_ bh exp_hash - put_ bh used_th - put_ bh fixities - lazyPut bh warns - lazyPut bh anns - put_ bh decls - put_ bh extra_decls - put_ bh insts - put_ bh fam_insts - lazyPut bh rules - put_ bh orphan_hash - put_ bh hpc_info - put_ bh trust - put_ bh trust_pkg - put_ bh complete_matches - lazyPutMaybe bh docs - - get bh = do - mod <- get bh - sig_of <- get bh - hsc_src <- get bh - iface_hash <- get bh - mod_hash <- get bh - flag_hash <- get bh - opt_hash <- get bh - hpc_hash <- get bh - plugin_hash <- get bh - orphan <- get bh - hasFamInsts <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - exp_hash <- get bh - used_th <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - warns <- {-# SCC "bin_warns" #-} lazyGet bh - anns <- {-# SCC "bin_anns" #-} lazyGet bh - decls <- {-# SCC "bin_tycldecls" #-} get bh - extra_decls <- get bh - insts <- {-# SCC "bin_insts" #-} get bh - fam_insts <- {-# SCC "bin_fam_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - orphan_hash <- get bh - hpc_info <- get bh - trust <- get bh - trust_pkg <- get bh - complete_matches <- get bh - docs <- lazyGetMaybe bh - return (ModIface { - mi_module = mod, - mi_sig_of = sig_of, - mi_hsc_src = hsc_src, - mi_src_hash = fingerprint0, -- placeholder because this is dealt - -- with specially when the file is read - mi_deps = deps, - mi_usages = usages, - mi_exports = exports, - mi_used_th = used_th, - mi_anns = anns, - mi_fixities = fixities, - mi_warns = warns, - mi_decls = decls, - mi_extra_decls = extra_decls, - mi_globals = Nothing, - mi_insts = insts, - mi_fam_insts = fam_insts, - mi_rules = rules, - mi_hpc = hpc_info, - mi_trust = trust, - mi_trust_pkg = trust_pkg, - -- And build the cached values - mi_complete_matches = complete_matches, - mi_docs = docs, - mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt - -- with specially when the file is read - mi_final_exts = ModIfaceBackend { - mi_iface_hash = iface_hash, - mi_mod_hash = mod_hash, - mi_flag_hash = flag_hash, - mi_opt_hash = opt_hash, - mi_hpc_hash = hpc_hash, - mi_plugin_hash = plugin_hash, - mi_orphan = orphan, - mi_finsts = hasFamInsts, - mi_exp_hash = exp_hash, - mi_orphan_hash = orphan_hash, - mi_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns, - mi_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns, - mi_fix_fn = mkIfaceFixCache fixities, - mi_hash_fn = mkIfaceHashCache decls - }}) - --- | The original names declared of a certain module that are exported -type IfaceExport = AvailInfo - -emptyPartialModIface :: Module -> PartialModIface -emptyPartialModIface mod - = ModIface { mi_module = mod, - mi_sig_of = Nothing, - mi_hsc_src = HsSrcFile, - mi_src_hash = fingerprint0, - mi_deps = noDependencies, - mi_usages = [], - mi_exports = [], - mi_used_th = False, - mi_fixities = [], - mi_warns = IfWarnSome [] [], - mi_anns = [], - mi_insts = [], - mi_fam_insts = [], - mi_rules = [], - mi_decls = [], - mi_extra_decls = Nothing, - mi_globals = Nothing, - mi_hpc = False, - mi_trust = noIfaceTrustInfo, - mi_trust_pkg = False, - mi_complete_matches = [], - mi_docs = Nothing, - mi_final_exts = (), - mi_ext_fields = emptyExtensibleFields - } - -emptyFullModIface :: Module -> ModIface -emptyFullModIface mod = - (emptyPartialModIface mod) - { mi_decls = [] - , mi_final_exts = ModIfaceBackend - { mi_iface_hash = fingerprint0, - mi_mod_hash = fingerprint0, - mi_flag_hash = fingerprint0, - mi_opt_hash = fingerprint0, - mi_hpc_hash = fingerprint0, - mi_plugin_hash = fingerprint0, - mi_orphan = False, - mi_finsts = False, - mi_exp_hash = fingerprint0, - mi_orphan_hash = fingerprint0, - mi_decl_warn_fn = emptyIfaceWarnCache, - mi_export_warn_fn = emptyIfaceWarnCache, - mi_fix_fn = emptyIfaceFixCache, - mi_hash_fn = emptyIfaceHashCache } } - --- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' -mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] - -> (OccName -> Maybe (OccName, Fingerprint)) -mkIfaceHashCache pairs - = \occ -> lookupOccEnv env occ - where - env = foldl' add_decl emptyOccEnv pairs - add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) - where - add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) - -emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) -emptyIfaceHashCache _occ = Nothing - --- Take care, this instance only forces to the degree necessary to --- avoid major space leaks. -instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase)) - , NFData (IfaceDeclExts (phase :: ModIfacePhase)) - ) => NFData (ModIface_ phase) where - rnf (ModIface{ mi_module, mi_sig_of, mi_hsc_src, mi_deps, mi_usages - , mi_exports, mi_used_th, mi_fixities, mi_warns, mi_anns - , mi_decls, mi_extra_decls, mi_globals, mi_insts - , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg - , mi_complete_matches, mi_docs, mi_final_exts - , mi_ext_fields, mi_src_hash }) - = rnf mi_module - `seq` rnf mi_sig_of - `seq` mi_hsc_src - `seq` mi_deps - `seq` mi_usages - `seq` mi_exports - `seq` rnf mi_used_th - `seq` mi_fixities - `seq` rnf mi_warns - `seq` rnf mi_anns - `seq` rnf mi_decls - `seq` rnf mi_extra_decls - `seq` rnf mi_globals - `seq` rnf mi_insts - `seq` rnf mi_fam_insts - `seq` rnf mi_rules - `seq` rnf mi_hpc - `seq` mi_trust - `seq` rnf mi_trust_pkg - `seq` rnf mi_complete_matches - `seq` rnf mi_docs - `seq` mi_final_exts - `seq` mi_ext_fields - `seq` rnf mi_src_hash - `seq` () - -instance NFData (ModIfaceBackend) where - rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash - , mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash - , mi_orphan_hash, mi_decl_warn_fn, mi_export_warn_fn, mi_fix_fn - , mi_hash_fn}) - = rnf mi_iface_hash - `seq` rnf mi_mod_hash - `seq` rnf mi_flag_hash - `seq` rnf mi_opt_hash - `seq` rnf mi_hpc_hash - `seq` rnf mi_plugin_hash - `seq` rnf mi_orphan - `seq` rnf mi_finsts - `seq` rnf mi_exp_hash - `seq` rnf mi_orphan_hash - `seq` rnf mi_decl_warn_fn - `seq` rnf mi_export_warn_fn - `seq` rnf mi_fix_fn - `seq` rnf mi_hash_fn - - -forceModIface :: ModIface -> IO () -forceModIface iface = () <$ (evaluate $ force iface) - --- | Records whether a module has orphans. An \"orphan\" is one of: --- --- * An instance declaration in a module other than the definition --- module for one of the type constructors or classes in the instance head --- --- * A rewrite rule in a module other than the one defining --- the function in the head of the rule --- -type WhetherHasOrphans = Bool - --- | Does this module define family instances? -type WhetherHasFamInst = Bool - - - +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +module GHC.Unit.Module.ModIface + ( ModIface + , ModIface_ + ( mi_mod_info + , mi_module + , mi_sig_of + , mi_hsc_src + , mi_iface_hash + , mi_deps + , mi_public + , mi_exports + , mi_fixities + , mi_warns + , mi_anns + , mi_decls + , mi_defaults + , mi_simplified_core + , mi_top_env + , mi_insts + , mi_fam_insts + , mi_rules + , mi_trust + , mi_trust_pkg + , mi_complete_matches + , mi_docs + , mi_abi_hashes + , mi_ext_fields + , mi_hi_bytes + , mi_self_recomp_info + , mi_fix_fn + , mi_decl_warn_fn + , mi_export_warn_fn + , mi_hash_fn + ) + , pattern ModIface + , set_mi_mod_info + , set_mi_module + , set_mi_sig_of + , set_mi_hsc_src + , set_mi_self_recomp + , set_mi_hi_bytes + , set_mi_deps + , set_mi_exports + , set_mi_fixities + , set_mi_warns + , set_mi_anns + , set_mi_insts + , set_mi_fam_insts + , set_mi_rules + , set_mi_decls + , set_mi_defaults + , set_mi_simplified_core + , set_mi_top_env + , set_mi_trust + , set_mi_trust_pkg + , set_mi_complete_matches + , set_mi_docs + , set_mi_abi_hashes + , set_mi_ext_fields + , set_mi_caches + , set_mi_decl_warn_fn + , set_mi_export_warn_fn + , set_mi_fix_fn + , set_mi_hash_fn + , completePartialModIface + , IfaceBinHandle(..) + , PartialModIface + , IfaceAbiHashes (..) + , IfaceSelfRecomp (..) + , IfaceCache (..) + , IfaceSimplifiedCore (..) + , withSelfRecomp + , IfaceDeclExts + , IfaceAbiHashesExts + , IfaceExport + , IfacePublic_(..) + , IfacePublic + , PartialIfacePublic + , IfaceModInfo(..) + , WhetherHasOrphans + , WhetherHasFamInst + , IfaceTopEnv (..) + , IfaceImport(..) + , mi_boot + , mi_fix + , mi_semantic_module + , mi_mod_info_semantic_module + , mi_free_holes + , mi_mnwib + , mi_flag_hash + , mi_opt_hash + , mi_hpc_hash + , mi_plugin_hash + , mi_src_hash + , mi_usages + , mi_mod_hash + , mi_orphan + , mi_finsts + , mi_export_avails_hash + , mi_orphan_like_hash + , mi_orphan_hash + , renameFreeHoles + , emptyPartialModIface + , emptyFullModIface + , mkIfaceHashCache + , emptyIfaceHashCache + , forceModIface + ) +where + +import GHC.Prelude + +import GHC.Hs + +import GHC.Iface.Syntax +import GHC.Iface.Flags +import GHC.Iface.Ext.Fields +import GHC.Iface.Recomp.Types + +import GHC.Unit +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.WholeCoreBindings (IfaceForeign (..)) + + +import GHC.Types.Avail +import GHC.Types.Fixity +import GHC.Types.Fixity.Env +import GHC.Types.Name +import GHC.Types.SafeHaskell +import GHC.Types.SourceFile +import GHC.Types.Unique.DSet +import GHC.Types.Unique.FM + +import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict + +import GHC.Utils.Fingerprint +import GHC.Utils.Binary + +import Control.DeepSeq +import Control.Exception + + +{- Note [Interface file stages] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Interface files have two possible stages. + +* A partial stage built from the result of the core pipeline. +* A fully instantiated form. Which also includes fingerprints and + potentially information provided by backends. + +We can build a full interface file two ways: +* Directly from a partial one: + Then we omit backend information and mostly compute fingerprints. +* From a partial one + information produced by a backend. + Then we store the provided information and fingerprint both. +-} + +type PartialModIface = ModIface_ 'ModIfaceCore +type ModIface = ModIface_ 'ModIfaceFinal + +type PartialIfacePublic = IfacePublic_ 'ModIfaceCore +type IfacePublic = IfacePublic_ 'ModIfaceFinal + +-- | Extends a PartialModIface with hashes of the ABI. +-- +-- * The mi_mod_hash is the hash of the entire ABI +-- * THe other fields are more specific hashes of parts of the ABI +data IfaceAbiHashes = IfaceAbiHashes + { mi_abi_mod_hash :: !Fingerprint + -- ^ Hash of the ABI only + , mi_abi_orphan :: !WhetherHasOrphans + -- ^ Whether this module has orphans + , mi_abi_finsts :: !WhetherHasFamInst + -- ^ Whether this module has family instances. See Note [The type family + -- instance consistency story]. + , mi_abi_export_avails_hash :: !Fingerprint + -- ^ Hash of the exported avails (does not include e.g. instances) + , mi_abi_orphan_like_hash :: !Fingerprint + -- ^ Orphans, together with (non-orphan) type family instances of + -- dependencies and a few other things; see Note [Orphan-like hash]. + -- + -- If this changes, we must recompile due to the impact + -- on instance resolution. + , mi_abi_orphan_hash :: !Fingerprint + -- ^ Hash for orphan rules, class and family instances combined + -- NOT transitive + } + +data IfaceCache = IfaceCache + { mi_cache_decl_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn)) + -- ^ Cached lookup for 'mi_warns' for declaration deprecations + , mi_cache_export_warn_fn :: !(Name -> Maybe (WarningTxt GhcRn)) + -- ^ Cached lookup for 'mi_warns' for export deprecations + , mi_cache_fix_fn :: !(OccName -> Maybe Fixity) + -- ^ Cached lookup for 'mi_fixities' + , mi_cache_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint)) + -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that + -- the thing isn't in decls. It's useful to know that when seeing if we are + -- up to date wrt. the old interface. The 'OccName' is the parent of the + -- name, if it has one. + } + +data ModIfacePhase + = ModIfaceCore + -- ^ Partial interface built based on output of core pipeline. + | ModIfaceFinal + +-- | Selects a IfaceDecl representation. +-- For fully instantiated interfaces we also maintain +-- a fingerprint, which is used for recompilation checks. +type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where + IfaceDeclExts 'ModIfaceCore = IfaceDecl + IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) + +type family IfaceAbiHashesExts (phase :: ModIfacePhase) = bk | bk -> phase where + IfaceAbiHashesExts 'ModIfaceCore = () + IfaceAbiHashesExts 'ModIfaceFinal = IfaceAbiHashes + +-- | In-memory byte array representation of a 'ModIface'. +-- +-- See Note [Sharing of ModIface] for why we need this. +data IfaceBinHandle (phase :: ModIfacePhase) where + -- | A partial 'ModIface' cannot be serialised to disk. + PartialIfaceBinHandle :: IfaceBinHandle 'ModIfaceCore + -- | Optional 'FullBinData' that can be serialised to disk directly. + -- + -- See Note [Private fields in ModIface] for when this fields needs to be cleared + -- (e.g., set to 'Nothing'). + FullIfaceBinHandle :: !(Strict.Maybe FullBinData) -> IfaceBinHandle 'ModIfaceFinal + + +withSelfRecomp :: ModIface_ phase -> r -> (IfaceSelfRecomp -> r) -> r +withSelfRecomp iface nk jk = + case mi_self_recomp_info iface of + Nothing -> nk + Just x -> jk x + + + +-- | A 'ModIface' summarises everything we know +-- about a compiled module. +-- +-- See Note [Structure of ModIface] for information about what belongs in each field. +-- +-- See Note [Strictness in ModIface] to learn about why all the fields are lazy. +-- +-- See Note [Private fields in ModIface] to learn why we don't export any of the +-- fields. +data ModIface_ (phase :: ModIfacePhase) + = PrivateModIface { + mi_hi_bytes_ :: !(IfaceBinHandle phase), + -- ^ A serialised in-memory buffer of this 'ModIface'. + -- If this handle is given, we can avoid serialising the 'ModIface' + -- when writing this 'ModIface' to disk, and write this buffer to disk instead. + -- See Note [Sharing of ModIface]. + mi_iface_hash_ :: Fingerprint, -- A hash of the whole interface + + mi_mod_info_ :: IfaceModInfo, + -- ^ Meta information about the module the interface file is for + + mi_deps_ :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + -- MP: Needs to be refactored (#25844) + + mi_public_ :: IfacePublic_ phase, + -- ^ The parts of interface which are used by other modules when + -- importing this module. The main, original part of an interface. + + + mi_self_recomp_ :: Maybe IfaceSelfRecomp, + -- ^ Information needed for checking self-recompilation. + -- See Note [Self recompilation information in interface files] + + mi_simplified_core_ :: Maybe IfaceSimplifiedCore, + -- ^ The part of the interface written when `-fwrite-if-simplified-core` is enabled. + -- These parts are used to restart bytecode generation. + + mi_docs_ :: Maybe Docs, + -- ^ Docstrings and related data for use by haddock, the ghci + -- @:doc@ command, and other tools. + -- + -- @Just _@ @<=>@ the module was built with @-haddock@. + + mi_top_env_ :: IfaceTopEnv, + -- ^ Just enough information to reconstruct the top level environment in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + + mi_ext_fields_ :: ExtensibleFields + -- ^ Additional optional fields, where the Map key represents + -- the field name, resulting in a (size, serialized data) pair. + -- Because the data is intended to be serialized through the + -- internal `Binary` class (increasing compatibility with types + -- using `Name` and `FastString`, such as HIE), this format is + -- chosen over `ByteString`s. + } + +-- | Meta information about the module the interface file is for +data IfaceModInfo = IfaceModInfo { + mi_mod_info_module :: Module, -- ^ Name of the module we are for + mi_mod_info_sig_of :: Maybe Module, -- ^ Are we a sig of another mod? + mi_mod_info_hsc_src :: HscSource -- ^ Boot? Signature? +} + +-- | The public interface of a module which are used by other modules when importing this module. +-- The ABI of a module. +data IfacePublic_ phase = IfacePublic { + mi_exports_ :: [IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + mi_fixities_ :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns_ :: IfaceWarnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns_ :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls_ :: [IfaceDeclExts phase], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + + mi_defaults_ :: [IfaceDefault], + -- ^ default declarations exported by the module + + + -- Instance declarations and rules + mi_insts_ :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts_ :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules_ :: [IfaceRule], -- ^ Sorted rules + + + mi_trust_ :: IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + + mi_trust_pkg_ :: Bool, + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [Trust Own Package] in GHC.Rename.Names + mi_complete_matches_ :: [IfaceCompleteMatch], + -- ^ {-# COMPLETE #-} declarations + + mi_caches_ :: IfaceCache, + -- ^ Cached lookups of some parts of mi_public + + mi_abi_hashes_ :: (IfaceAbiHashesExts phase) + -- ^ Either `()` or `IfaceAbiHashes` for + -- a fully instantiated interface. + -- These fields are hashes of different parts of the public interface. +} + +mkIfacePublic :: [IfaceExport] + -> [IfaceDeclExts 'ModIfaceFinal] + -> [(OccName, Fixity)] + -> IfaceWarnings + -> [IfaceAnnotation] + -> [IfaceDefault] + -> [IfaceClsInst] + -> [IfaceFamInst] + -> [IfaceRule] + -> IfaceTrustInfo + -> Bool + -> [IfaceCompleteMatch] + -> IfaceAbiHashes + -> IfacePublic +mkIfacePublic exports decls fixities warns anns defaults insts fam_insts rules trust trust_pkg complete_matches abi_hashes = IfacePublic { + mi_exports_ = exports, + mi_decls_ = decls, + mi_fixities_ = fixities, + mi_warns_ = warns, + mi_anns_ = anns, + mi_defaults_ = defaults, + mi_insts_ = insts, + mi_fam_insts_ = fam_insts, + mi_rules_ = rules, + mi_trust_ = trust, + mi_trust_pkg_ = trust_pkg, + mi_complete_matches_ = complete_matches, + mi_caches_ = IfaceCache { + mi_cache_decl_warn_fn = mkIfaceDeclWarnCache $ fromIfaceWarnings warns, + mi_cache_export_warn_fn = mkIfaceExportWarnCache $ fromIfaceWarnings warns, + mi_cache_fix_fn = mkIfaceFixCache fixities, + mi_cache_hash_fn = mkIfaceHashCache decls + }, + mi_abi_hashes_ = abi_hashes +} + +-- | The information needed to restart bytecode generation. +-- Enabled by `-fwrite-if-simplified-core`. +data IfaceSimplifiedCore = IfaceSimplifiedCore { + mi_sc_extra_decls :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + -- ^ Extra variable definitions which are **NOT** exposed but when + -- combined with mi_decls allows us to restart code generation. + -- See Note [Interface Files with Core Definitions] and Note [Interface File with Core: Sharing RHSs] + , mi_sc_foreign :: IfaceForeign + -- ^ Foreign stubs and files to supplement 'mi_extra_decls_'. + -- See Note [Foreign stubs and TH bytecode linking] +} + +-- Enough information to reconstruct the top level environment for a module +data IfaceTopEnv + = IfaceTopEnv + { ifaceTopExports :: DetOrdAvails -- ^ all top level things in this module, including unexported stuff + , ifaceImports :: [IfaceImport] -- ^ all the imports in this module + } + +instance NFData IfaceTopEnv where + rnf (IfaceTopEnv a b) = rnf a `seq` rnf b + +instance Binary IfaceTopEnv where + put_ bh (IfaceTopEnv exports imports) = do + put_ bh exports + put_ bh imports + get bh = do + exports <- get bh + imports <- get bh + return (IfaceTopEnv exports imports) + + +{- +Note [Structure of ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ModIface structure is divided into several logical parts: + +1. mi_mod_info: Basic module metadata (name, version, etc.) + +2. mi_public: The public interface of the module, which includes: + - Exports, declarations, fixities, warnings, annotations + - Class and type family instances + - Rewrite rules and COMPLETE pragmas + - Safe Haskell and package trust information + - ABI hashes for recompilation checking + +4. mi_self_recomp: Information needed for self-recompilation checking + (see Note [Self recompilation information in interface files]) + +5. mi_simplified_core: Optional simplified Core for bytecode generation + (only present when -fwrite-if-simplified-core is enabled) + +6. mi_docs: Optional documentation (only present when -haddock is enabled) + +7. mi_top_env: Information about the top-level environment of the original source + +8. mi_ext_fields: Additional fields for extensibility + +This structure helps organize the interface data according to its purpose and usage +patterns. Different parts of the compiler use different fields. By separating them +logically in the interface we can arrange to only deserialize the fields that are needed. + +Note [Strictness in ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The ModIface is the Haskell representation of an interface (.hi) file. + +* During compilation we write out ModIface values to disk for files + that we have just compiled +* For packages that we depend on we load the ModIface from disk. + +All fields in the ModIface are deliberately lazy because when we read +an interface file we don't always need all the parts. For example, an +interface file contains information about documentation which is often +not needed during compilation. This is achieved using the lazyPut/lazyGet pair. +If the field was strict then we would pointlessly load this information into memory. + +On the other hand, if we create a ModIface but **don't** write it to +disk then to avoid space leaks we need to make sure to deepseq all these lazy fields +because the ModIface might live for a long time (for instance in a GHCi session). +That's why in GHC.Driver.Main.hscMaybeWriteIface there is the call to +forceModIface. +-} + +mi_flag_hash :: ModIface_ phase -> Maybe (FingerprintWithValue IfaceDynFlags) +mi_flag_hash = fmap mi_sr_flag_hash . mi_self_recomp_ + +mi_opt_hash :: ModIface_ phase -> Maybe Fingerprint +mi_opt_hash = fmap mi_sr_opt_hash . mi_self_recomp_ + +mi_hpc_hash :: ModIface_ phase -> Maybe Fingerprint +mi_hpc_hash = fmap mi_sr_hpc_hash . mi_self_recomp_ + +mi_src_hash :: ModIface_ phase -> Maybe Fingerprint +mi_src_hash = fmap mi_sr_src_hash . mi_self_recomp_ + +mi_usages :: ModIface_ phase -> Maybe [Usage] +mi_usages = fmap mi_sr_usages . mi_self_recomp_ + +mi_plugin_hash :: ModIface_ phase -> Maybe Fingerprint +mi_plugin_hash = fmap mi_sr_plugin_hash . mi_self_recomp_ + +-- | Accessor for the module hash of the ABI from a ModIface. +mi_mod_hash :: ModIface -> Fingerprint +mi_mod_hash iface = mi_abi_mod_hash (mi_abi_hashes iface) + +-- | Accessor for whether this module has orphans from a ModIface. +mi_orphan :: ModIface -> WhetherHasOrphans +mi_orphan iface = mi_abi_orphan (mi_abi_hashes iface) + +-- | Accessor for whether this module has family instances from a ModIface. +mi_finsts :: ModIface -> WhetherHasFamInst +mi_finsts iface = mi_abi_finsts (mi_abi_hashes iface) + +-- | Accessor for the hash of exported avails. +mi_export_avails_hash :: ModIface -> Fingerprint +mi_export_avails_hash iface = mi_abi_export_avails_hash (mi_abi_hashes iface) + +-- | Accessor for the hash of orphans and dependencies. +-- +-- See Note [Orphan-like hash]. +mi_orphan_like_hash :: ModIface -> Fingerprint +mi_orphan_like_hash iface = mi_abi_orphan_like_hash (mi_abi_hashes iface) + +-- | Accessor for the hash of orphan rules, class and family instances combined from a ModIface. +mi_orphan_hash :: ModIface -> Fingerprint +mi_orphan_hash iface = mi_abi_orphan_hash (mi_abi_hashes iface) + +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> IsBootInterface +mi_boot iface = if mi_hsc_src iface == HsBootFile + then IsBoot + else NotBoot + +mi_mnwib :: ModIface -> ModuleNameWithIsBoot +mi_mnwib iface = GWIB (moduleName $ mi_module iface) (mi_boot iface) + +-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be +-- found, 'defaultFixity' is returned instead. +mi_fix :: ModIface -> OccName -> Fixity +mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity + +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' +-- will be @@. +mi_mod_info_semantic_module :: IfaceModInfo -> Module +mi_mod_info_semantic_module iface = case mi_mod_info_sig_of iface of + Nothing -> mi_mod_info_module iface + Just mod -> mod + +mi_semantic_module :: ModIface_ a -> Module +mi_semantic_module iface = mi_mod_info_semantic_module (mi_mod_info iface) + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case getModuleInstantiation (mi_module iface) of + (_, Just indef) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef)) + _ -> emptyUniqDSet + where + cands = dep_sig_mods $ mi_deps iface + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + +-- See Note [Strictness in ModIface] about where we use lazyPut vs put +instance Binary ModIface where + put_ bh (PrivateModIface + { mi_hi_bytes_ = _hi_bytes, -- We don't serialise the 'mi_hi_bytes_', as it itself + -- may contain an in-memory byte array buffer for this + -- 'ModIface'. If we used 'put_' on this 'ModIface', then + -- we likely have a good reason, and do not want to reuse + -- the byte array. + -- See Note [Private fields in ModIface] + mi_mod_info_ = mod_info, + mi_iface_hash_ = iface_hash, + mi_deps_ = deps, + mi_public_ = public, + mi_top_env_ = top_env, + mi_docs_ = docs, + mi_ext_fields_ = _ext_fields, -- Don't `put_` this in the instance so we + -- can deal with it's pointer in the header + -- when we write the actual file + mi_self_recomp_ = self_recomp, + mi_simplified_core_ = simplified_core + }) = do + put_ bh mod_info + put_ bh iface_hash + lazyPut bh deps + lazyPut bh public + lazyPut bh top_env + lazyPutMaybe bh docs + lazyPutMaybe bh self_recomp + lazyPutMaybe bh simplified_core + + get bh = do + mod_info <- get bh + iface_hash <- get bh + deps <- lazyGet bh + public <- lazyGet bh + top_env <- lazyGet bh + docs <- lazyGetMaybe bh + self_recomp <- lazyGetMaybe bh + simplified_core <- lazyGetMaybe bh + + return (PrivateModIface { + mi_mod_info_ = mod_info, + mi_iface_hash_ = iface_hash, + mi_deps_ = deps, + mi_public_ = public, + mi_simplified_core_ = simplified_core, + mi_docs_ = docs, + mi_top_env_ = top_env, + mi_self_recomp_ = self_recomp, + -- placeholder because this is dealt + -- with specially when the file is read + mi_ext_fields_ = emptyExtensibleFields, + -- We can't populate this field here, as we are + -- missing the 'mi_ext_fields_' field, which is + -- handled in 'getIfaceWithExtFields'. + mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing + }) + +instance Binary IfaceModInfo where + put_ bh (IfaceModInfo { mi_mod_info_module = mod + , mi_mod_info_sig_of = sig_of + , mi_mod_info_hsc_src = hsc_src + }) = do + put_ bh mod + put_ bh sig_of + put_ bh hsc_src + + get bh = do + mod <- get bh + sig_of <- get bh + hsc_src <- get bh + return (IfaceModInfo { mi_mod_info_module = mod + , mi_mod_info_sig_of = sig_of + , mi_mod_info_hsc_src = hsc_src + }) + + +instance Binary (IfacePublic_ 'ModIfaceFinal) where + put_ bh (IfacePublic { mi_exports_ = exports + , mi_decls_ = decls + , mi_fixities_ = fixities + , mi_warns_ = warns + , mi_anns_ = anns + , mi_defaults_ = defaults + , mi_insts_ = insts + , mi_fam_insts_ = fam_insts + , mi_rules_ = rules + , mi_trust_ = trust + , mi_trust_pkg_ = trust_pkg + , mi_complete_matches_ = complete_matches + , mi_abi_hashes_ = abi_hashes + }) = do + + lazyPut bh exports + lazyPut bh decls + lazyPut bh fixities + lazyPut bh warns + lazyPut bh anns + lazyPut bh defaults + lazyPut bh insts + lazyPut bh fam_insts + lazyPut bh rules + lazyPut bh trust + lazyPut bh trust_pkg + lazyPut bh complete_matches + lazyPut bh abi_hashes + + get bh = do + exports <- lazyGet bh + decls <- lazyGet bh + fixities <- lazyGet bh + warns <- lazyGet bh + anns <- lazyGet bh + defaults <- lazyGet bh + insts <- lazyGet bh + fam_insts <- lazyGet bh + rules <- lazyGet bh + trust <- lazyGet bh + trust_pkg <- lazyGet bh + complete_matches <- lazyGet bh + abi_hashes <- lazyGet bh + return (mkIfacePublic exports decls fixities warns anns defaults insts fam_insts rules trust trust_pkg complete_matches abi_hashes) + +instance Binary IfaceAbiHashes where + put_ bh (IfaceAbiHashes { mi_abi_mod_hash = mod_hash + , mi_abi_orphan = orphan + , mi_abi_finsts = hasFamInsts + , mi_abi_export_avails_hash = vis_hash + , mi_abi_orphan_like_hash = invis_hash + , mi_abi_orphan_hash = orphan_hash + }) = do + put_ bh mod_hash + put_ bh orphan + put_ bh hasFamInsts + put_ bh vis_hash + put_ bh invis_hash + put_ bh orphan_hash + get bh = do + mod_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + vis_hash <- get bh + invis_hash <- get bh + orphan_hash <- get bh + return $ IfaceAbiHashes { + mi_abi_mod_hash = mod_hash, + mi_abi_orphan = orphan, + mi_abi_finsts = hasFamInsts, + mi_abi_export_avails_hash = vis_hash, + mi_abi_orphan_like_hash = invis_hash, + mi_abi_orphan_hash = orphan_hash + } + +instance Binary IfaceSimplifiedCore where + put_ bh (IfaceSimplifiedCore eds fs) = do + put_ bh eds + put_ bh fs + + get bh = do + eds <- get bh + fs <- get bh + return (IfaceSimplifiedCore eds fs) + +emptyPartialModIface :: Module -> PartialModIface +emptyPartialModIface mod + = PrivateModIface + { mi_mod_info_ = emptyIfaceModInfo mod, + mi_iface_hash_ = fingerprint0, + mi_hi_bytes_ = PartialIfaceBinHandle, + mi_deps_ = noDependencies, + mi_public_ = emptyPublicModIface (), + mi_simplified_core_ = Nothing, + mi_top_env_ = IfaceTopEnv emptyDetOrdAvails [] , + mi_docs_ = Nothing, + mi_self_recomp_ = Nothing, + mi_ext_fields_ = emptyExtensibleFields + + } + +emptyIfaceModInfo :: Module -> IfaceModInfo +emptyIfaceModInfo mod = IfaceModInfo + { mi_mod_info_module = mod + , mi_mod_info_sig_of = Nothing + , mi_mod_info_hsc_src = HsSrcFile + } + + +emptyPublicModIface :: IfaceAbiHashesExts phase -> IfacePublic_ phase +emptyPublicModIface abi_hashes = IfacePublic + { mi_exports_ = [] + , mi_decls_ = [] + , mi_fixities_ = [] + , mi_warns_ = IfWarnSome [] [] + , mi_anns_ = [] + , mi_defaults_ = [] + , mi_insts_ = [] + , mi_fam_insts_ = [] + , mi_rules_ = [] + , mi_abi_hashes_ = abi_hashes + , mi_trust_ = noIfaceTrustInfo + , mi_trust_pkg_ = False + , mi_caches_ = emptyModIfaceCache + , mi_complete_matches_ = [] + } + +emptyModIfaceCache :: IfaceCache +emptyModIfaceCache = IfaceCache { + mi_cache_decl_warn_fn = emptyIfaceWarnCache, + mi_cache_export_warn_fn = emptyIfaceWarnCache, + mi_cache_fix_fn = emptyIfaceFixCache, + mi_cache_hash_fn = emptyIfaceHashCache +} + +emptyIfaceBackend :: IfaceAbiHashes +emptyIfaceBackend = IfaceAbiHashes + { mi_abi_mod_hash = fingerprint0, + mi_abi_orphan = False, + mi_abi_finsts = False, + mi_abi_export_avails_hash = fingerprint0, + mi_abi_orphan_like_hash = fingerprint0, + mi_abi_orphan_hash = fingerprint0 + } + +emptyFullModIface :: Module -> ModIface +emptyFullModIface mod = + (emptyPartialModIface mod) + { mi_public_ = emptyPublicModIface emptyIfaceBackend + , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing + } + + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl' add_decl emptyOccEnv pairs + add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + where + add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + +-- ModIface is completely forced since it will live in memory for a long time. +-- If forcing it uses a lot of memory, then store less things in ModIface. +instance ( NFData (IfaceAbiHashesExts (phase :: ModIfacePhase)) + , NFData (IfaceDeclExts (phase :: ModIfacePhase)) + ) => NFData (ModIface_ phase) where + rnf (PrivateModIface a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + = (a1 :: IfaceBinHandle phase) + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + `seq` rnf a7 + `seq` rnf a8 + `seq` rnf a9 + `seq` rnf a10 + +instance NFData IfaceModInfo where + rnf (IfaceModInfo a1 a2 a3) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + + +instance NFData IfaceSimplifiedCore where + rnf (IfaceSimplifiedCore eds fs) = rnf eds `seq` rnf fs + +instance NFData IfaceAbiHashes where + rnf (IfaceAbiHashes a1 a2 a3 a4 a5 a6) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + +instance (NFData (IfaceAbiHashesExts phase), NFData (IfaceDeclExts phase)) => NFData (IfacePublic_ phase) where + rnf (IfacePublic a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + `seq` rnf a5 + `seq` rnf a6 + `seq` rnf a7 + `seq` rnf a8 + `seq` rnf a9 + `seq` rnf a10 + `seq` rnf a11 + `seq` rnf a12 + `seq` rnf a13 + `seq` rnf a14 + +instance NFData IfaceCache where + rnf (IfaceCache a1 a2 a3 a4) + = rnf a1 + `seq` rnf a2 + `seq` rnf a3 + `seq` rnf a4 + + + +forceModIface :: ModIface -> IO () +forceModIface iface = () <$ (evaluate $ force iface) + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A rewrite rule in a module other than the one defining +-- the function in the head of the rule +-- +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- ---------------------------------------------------------------------------- +-- Modify a 'ModIface'. +-- ---------------------------------------------------------------------------- + +{- +Note [Private fields in ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The fields of 'ModIface' are private, e.g., not exported, to make the API +impossible to misuse. A 'ModIface' can be "compressed" in-memory using +'shareIface', which serialises the 'ModIface' to an in-memory buffer. +This has the advantage of reducing memory usage of 'ModIface', reducing the +overall memory usage of GHC. +See Note [Sharing of ModIface]. + +This in-memory buffer can be reused, if and only if the 'ModIface' is not +modified after it has been "compressed"/shared via 'shareIface'. Instead of +serialising 'ModIface', we simply write the in-memory buffer to disk directly. + +However, we can't rely that a 'ModIface' isn't modified after 'shareIface' has +been called. Thus, we make all fields of 'ModIface' private and modification +only happens via exported update functions, such as 'set_mi_decls'. +These functions unconditionally clear any in-memory buffer if used, forcing us +to serialise the 'ModIface' to disk again. +-} + +-- | Given a 'PartialModIface', turn it into a 'ModIface' by completing +-- missing fields. +completePartialModIface :: PartialModIface + -> Fingerprint + -> [(Fingerprint, IfaceDecl)] + -> Maybe IfaceSimplifiedCore + -> IfaceAbiHashes + -> IfaceCache + -> ModIface +completePartialModIface partial iface_hash decls extra_decls final_exts cache = partial + { mi_public_ = completePublicModIface decls final_exts cache (mi_public_ partial) + , mi_simplified_core_ = extra_decls + , mi_hi_bytes_ = FullIfaceBinHandle Strict.Nothing + , mi_iface_hash_ = iface_hash + } + where + +-- | Given a 'PartialIfacePublic', turn it into an 'IfacePublic' by completing +-- missing fields. +completePublicModIface :: [(Fingerprint, IfaceDecl)] + -> IfaceAbiHashes + -> IfaceCache + -> PartialIfacePublic + -> IfacePublic +completePublicModIface decls abi_hashes cache partial = partial + { mi_decls_ = decls + , mi_abi_hashes_ = abi_hashes + , mi_caches_ = cache + } + +set_mi_mod_info :: IfaceModInfo -> ModIface_ phase -> ModIface_ phase +set_mi_mod_info val iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = val } + +set_mi_self_recomp :: Maybe IfaceSelfRecomp-> ModIface_ phase -> ModIface_ phase +set_mi_self_recomp val iface = clear_mi_hi_bytes $ iface { mi_self_recomp_ = val } + +set_mi_hi_bytes :: IfaceBinHandle phase -> ModIface_ phase -> ModIface_ phase +set_mi_hi_bytes val iface = iface { mi_hi_bytes_ = val } + +set_mi_deps :: Dependencies -> ModIface_ phase -> ModIface_ phase +set_mi_deps val iface = clear_mi_hi_bytes $ iface { mi_deps_ = val } + +set_mi_public :: (IfacePublic_ phase -> IfacePublic_ phase) -> ModIface_ phase -> ModIface_ phase +set_mi_public f iface = clear_mi_hi_bytes $ iface { mi_public_ = f (mi_public_ iface) } + +set_mi_simplified_core :: Maybe IfaceSimplifiedCore -> ModIface_ phase -> ModIface_ phase +set_mi_simplified_core val iface = clear_mi_hi_bytes $ iface { mi_simplified_core_ = val } + +set_mi_top_env :: IfaceTopEnv -> ModIface_ phase -> ModIface_ phase +set_mi_top_env val iface = clear_mi_hi_bytes $ iface { mi_top_env_ = val } + +set_mi_docs :: Maybe Docs -> ModIface_ phase -> ModIface_ phase +set_mi_docs val iface = clear_mi_hi_bytes $ iface { mi_docs_ = val } + +set_mi_ext_fields :: ExtensibleFields -> ModIface_ phase -> ModIface_ phase +set_mi_ext_fields val iface = clear_mi_hi_bytes $ iface { mi_ext_fields_ = val } + +{- Settings for mi_public interface fields -} + +set_mi_exports :: [IfaceExport] -> ModIface_ phase -> ModIface_ phase +set_mi_exports val = set_mi_public (\iface -> iface { mi_exports_ = val }) + +set_mi_fixities :: [(OccName, Fixity)] -> ModIface_ phase -> ModIface_ phase +set_mi_fixities val = set_mi_public (\iface -> iface { mi_fixities_ = val }) + +set_mi_warns :: IfaceWarnings -> ModIface_ phase -> ModIface_ phase +set_mi_warns val = set_mi_public (\iface -> iface { mi_warns_ = val }) + +set_mi_anns :: [IfaceAnnotation] -> ModIface_ phase -> ModIface_ phase +set_mi_anns val = set_mi_public (\iface -> iface { mi_anns_ = val }) + +set_mi_insts :: [IfaceClsInst] -> ModIface_ phase -> ModIface_ phase +set_mi_insts val = set_mi_public (\iface -> iface { mi_insts_ = val }) + +set_mi_fam_insts :: [IfaceFamInst] -> ModIface_ phase -> ModIface_ phase +set_mi_fam_insts val = set_mi_public (\iface -> iface { mi_fam_insts_ = val }) + +set_mi_rules :: [IfaceRule] -> ModIface_ phase -> ModIface_ phase +set_mi_rules val = set_mi_public (\iface -> iface { mi_rules_ = val }) + +set_mi_decls :: [IfaceDeclExts phase] -> ModIface_ phase -> ModIface_ phase +set_mi_decls val = set_mi_public (\iface -> iface { mi_decls_ = val }) + +set_mi_defaults :: [IfaceDefault] -> ModIface_ phase -> ModIface_ phase +set_mi_defaults val = set_mi_public (\iface -> iface { mi_defaults_ = val }) + +set_mi_trust :: IfaceTrustInfo -> ModIface_ phase -> ModIface_ phase +set_mi_trust val = set_mi_public (\iface -> iface { mi_trust_ = val }) + +set_mi_trust_pkg :: Bool -> ModIface_ phase -> ModIface_ phase +set_mi_trust_pkg val = set_mi_public (\iface -> iface { mi_trust_pkg_ = val }) + +set_mi_complete_matches :: [IfaceCompleteMatch] -> ModIface_ phase -> ModIface_ phase +set_mi_complete_matches val = set_mi_public (\iface -> iface { mi_complete_matches_ = val }) + +set_mi_abi_hashes :: IfaceAbiHashesExts phase -> ModIface_ phase -> ModIface_ phase +set_mi_abi_hashes val = set_mi_public (\iface -> iface { mi_abi_hashes_ = val }) + +{- Setters for mi_caches interface fields -} + +set_mi_decl_warn_fn :: (OccName -> Maybe (WarningTxt GhcRn)) -> ModIface_ phase -> ModIface_ phase +set_mi_decl_warn_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_decl_warn_fn = val } }) + +set_mi_export_warn_fn :: (Name -> Maybe (WarningTxt GhcRn)) -> ModIface_ phase -> ModIface_ phase +set_mi_export_warn_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_export_warn_fn = val } }) + +set_mi_fix_fn :: (OccName -> Maybe Fixity) -> ModIface_ phase -> ModIface_ phase +set_mi_fix_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_fix_fn = val } }) + +set_mi_hash_fn :: (OccName -> Maybe (OccName, Fingerprint)) -> ModIface_ phase -> ModIface_ phase +set_mi_hash_fn val = set_mi_public (\iface -> iface { mi_caches_ = (mi_caches_ iface) { mi_cache_hash_fn = val } }) + +set_mi_caches :: IfaceCache -> ModIface_ phase -> ModIface_ phase +set_mi_caches val = set_mi_public (\iface -> iface { mi_caches_ = val }) + +{- + +-} + +{- Setters for mi_mod_info interface fields -} + +set_mi_module :: Module -> ModIface_ phase -> ModIface_ phase +set_mi_module val = set_mi_mod_info_field (\info -> info { mi_mod_info_module = val }) + +set_mi_sig_of :: Maybe Module -> ModIface_ phase -> ModIface_ phase +set_mi_sig_of val = set_mi_mod_info_field (\info -> info { mi_mod_info_sig_of = val }) + +set_mi_hsc_src :: HscSource -> ModIface_ phase -> ModIface_ phase +set_mi_hsc_src val = set_mi_mod_info_field (\info -> info { mi_mod_info_hsc_src = val }) + +-- | Helper function for setting fields in mi_mod_info_ +set_mi_mod_info_field :: (IfaceModInfo -> IfaceModInfo) -> ModIface_ phase -> ModIface_ phase +set_mi_mod_info_field f iface = clear_mi_hi_bytes $ iface { mi_mod_info_ = f (mi_mod_info_ iface) } + + + + +-- | Invalidate any byte array buffer we might have. +clear_mi_hi_bytes :: ModIface_ phase -> ModIface_ phase +clear_mi_hi_bytes iface = iface + { mi_hi_bytes_ = case mi_hi_bytes iface of + PartialIfaceBinHandle -> PartialIfaceBinHandle + FullIfaceBinHandle _ -> FullIfaceBinHandle Strict.Nothing + } + +-- ---------------------------------------------------------------------------- +-- 'ModIface' pattern synonyms to keep breakage low. +-- ---------------------------------------------------------------------------- + +{- +Note [Inline Pattern synonym of ModIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The introduction of the 'ModIface' pattern synonym originally caused an increase +in allocated bytes in multiple performance tests. +In some benchmarks, it was a 2~3% increase. + +Without {-# INLINE ModIface #-}, the generated core reveals the reason for this increase. +We show the core for the 'mi_module' record selector: + +@ + mi_module + = \ @phase iface -> $w$mModIface iface mi_module1 + + $w$mModIface + = \ @phase iface cont -> + case iface of + { PrivateModIface a b ... z -> + cont + a + b + ... + z + } + + mi_module1 + = \ @phase + a + _ + ... + _ -> + a +@ + +Thus, we can see the '$w$mModIface' is not inlined, leading to an increase in +the allocated bytes. + +However, with the pragma, the correct core is generated: + +@ + mi_module = mi_module_ +@ + +-} + +-- See Note [Inline Pattern synonym of ModIface] for why we have all these +-- inline pragmas. +{-# INLINE mi_mod_info #-} +{-# INLINE mi_iface_hash #-} +{-# INLINE mi_module #-} +{-# INLINE mi_sig_of #-} +{-# INLINE mi_hsc_src #-} +{-# INLINE mi_deps #-} +{-# INLINE mi_public #-} +{-# INLINE mi_exports #-} +{-# INLINE mi_fixities #-} +{-# INLINE mi_warns #-} +{-# INLINE mi_anns #-} +{-# INLINE mi_decls #-} +{-# INLINE mi_simplified_core #-} +{-# INLINE mi_defaults #-} +{-# INLINE mi_top_env #-} +{-# INLINE mi_insts #-} +{-# INLINE mi_fam_insts #-} +{-# INLINE mi_rules #-} +{-# INLINE mi_trust #-} +{-# INLINE mi_trust_pkg #-} +{-# INLINE mi_complete_matches #-} +{-# INLINE mi_docs #-} +{-# INLINE mi_abi_hashes #-} +{-# INLINE mi_ext_fields #-} +{-# INLINE mi_hi_bytes #-} +{-# INLINE mi_self_recomp_info #-} +{-# INLINE mi_fix_fn #-} +{-# INLINE mi_hash_fn #-} +{-# INLINE mi_decl_warn_fn #-} +{-# INLINE mi_export_warn_fn #-} +{-# INLINE ModIface #-} +{-# COMPLETE ModIface #-} + +pattern ModIface :: + IfaceModInfo + -> Module + -> Maybe Module + -> HscSource + -> Fingerprint + -> Dependencies + -> IfacePublic_ phase + -> [IfaceExport] + -> [(OccName, Fixity)] + -> IfaceWarnings + -> [IfaceAnnotation] + -> [IfaceDeclExts phase] + -> Maybe IfaceSimplifiedCore + -> [IfaceDefault] + -> IfaceTopEnv + -> [IfaceClsInst] + -> [IfaceFamInst] + -> [IfaceRule] + -> IfaceTrustInfo + -> Bool + -> [IfaceCompleteMatch] + -> Maybe Docs + -> IfaceAbiHashesExts phase + -> ExtensibleFields + -> IfaceBinHandle phase + -> Maybe IfaceSelfRecomp + -> (OccName -> Maybe Fixity) + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName -> Maybe (WarningTxt GhcRn)) + -> (Name -> Maybe (WarningTxt GhcRn)) -> + ModIface_ phase +pattern ModIface + { mi_mod_info + , mi_module + , mi_sig_of + , mi_hsc_src + , mi_iface_hash + , mi_deps + , mi_public + , mi_exports + , mi_fixities + , mi_warns + , mi_anns + , mi_decls + , mi_simplified_core + , mi_defaults + , mi_top_env + , mi_insts + , mi_fam_insts + , mi_rules + , mi_trust + , mi_trust_pkg + , mi_complete_matches + , mi_docs + , mi_abi_hashes + , mi_ext_fields + , mi_hi_bytes + , mi_self_recomp_info + , mi_fix_fn + , mi_hash_fn + , mi_decl_warn_fn + , mi_export_warn_fn + } <- PrivateModIface + { mi_mod_info_ = mi_mod_info@IfaceModInfo { mi_mod_info_module = mi_module + , mi_mod_info_sig_of = mi_sig_of + , mi_mod_info_hsc_src = mi_hsc_src } + , mi_iface_hash_ = mi_iface_hash + , mi_deps_ = mi_deps + , mi_public_ = mi_public@IfacePublic { + mi_exports_ = mi_exports + , mi_fixities_ = mi_fixities + , mi_warns_ = mi_warns + , mi_anns_ = mi_anns + , mi_decls_ = mi_decls + , mi_defaults_ = mi_defaults + , mi_insts_ = mi_insts + , mi_fam_insts_ = mi_fam_insts + , mi_rules_ = mi_rules + , mi_trust_ = mi_trust + , mi_trust_pkg_ = mi_trust_pkg + , mi_complete_matches_ = mi_complete_matches + , mi_caches_ = IfaceCache { + mi_cache_decl_warn_fn = mi_decl_warn_fn, + mi_cache_export_warn_fn = mi_export_warn_fn, + mi_cache_fix_fn = mi_fix_fn, + mi_cache_hash_fn = mi_hash_fn + } + , mi_abi_hashes_ = mi_abi_hashes + } + , mi_docs_ = mi_docs + , mi_ext_fields_ = mi_ext_fields + , mi_hi_bytes_ = mi_hi_bytes + , mi_self_recomp_ = mi_self_recomp_info + , mi_simplified_core_ = mi_simplified_core + , mi_top_env_ = mi_top_env + } diff --git a/GHC/Unit/Module/ModNodeKey.hs b/GHC/Unit/Module/ModNodeKey.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/ModNodeKey.hs @@ -0,0 +1,35 @@ +module GHC.Unit.Module.ModNodeKey + ( ModNodeKeyWithUid(..) + , mnkToModule + , moduleToMnk + , mnkIsBoot + , mnkToInstalledModule + , installedModuleToMnk + ) where + +import GHC.Prelude +import GHC.Utils.Outputable +import GHC.Unit.Types + +data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: !ModuleNameWithIsBoot + , mnkUnitId :: !UnitId } deriving (Eq, Ord) + +mnkToModule :: ModNodeKeyWithUid -> Module +mnkToModule (ModNodeKeyWithUid mnwib uid) = Module (RealUnit (Definite uid)) (gwib_mod mnwib) + +mnkToInstalledModule :: ModNodeKeyWithUid -> InstalledModule +mnkToInstalledModule (ModNodeKeyWithUid mnwib uid) = Module uid (gwib_mod mnwib) + +-- | Already InstalledModules are always NotBoot +installedModuleToMnk :: InstalledModule -> ModNodeKeyWithUid +installedModuleToMnk mod = ModNodeKeyWithUid (GWIB (moduleName mod) NotBoot) (moduleUnit mod) + +moduleToMnk :: Module -> IsBootInterface -> ModNodeKeyWithUid +moduleToMnk mod is_boot = ModNodeKeyWithUid (GWIB (moduleName mod) is_boot) (moduleUnitId mod) + +mnkIsBoot :: ModNodeKeyWithUid -> IsBootInterface +mnkIsBoot (ModNodeKeyWithUid mnwib _) = gwib_isBoot mnwib + +instance Outputable ModNodeKeyWithUid where + ppr (ModNodeKeyWithUid mnwib uid) = ppr uid <> colon <> ppr mnwib + diff --git a/GHC/Unit/Module/ModSummary.hs b/GHC/Unit/Module/ModSummary.hs --- a/GHC/Unit/Module/ModSummary.hs +++ b/GHC/Unit/Module/ModSummary.hs @@ -17,14 +17,21 @@ , msHsFilePath , msObjFilePath , msDynObjFilePath + , msHsFileOsPath + , msHiFileOsPath + , msDynHiFileOsPath + , msObjFileOsPath + , msDynObjFileOsPath , msDeps , isBootSummary + , isTemplateHaskellOrQQNonBoot , findTarget ) where import GHC.Prelude +import qualified GHC.LanguageExtensions as LangExt import GHC.Hs import GHC.Driver.DynFlags @@ -36,8 +43,10 @@ import GHC.Types.SrcLoc import GHC.Types.Target import GHC.Types.PkgQual +import GHC.Types.Basic import GHC.Data.Maybe +import GHC.Data.OsPath (OsPath) import GHC.Data.StringBuffer ( StringBuffer ) import GHC.Utils.Fingerprint @@ -71,12 +80,10 @@ -- See Note [When source is considered modified] and #9243 ms_hie_date :: Maybe UTCTime, -- ^ Timestamp of hie file, if we have one - ms_srcimps :: [(PkgQual, Located ModuleName)], -- FIXME: source imports are never from an external package, why do we allow PkgQual? + ms_srcimps :: [Located ModuleName], -- ^ Source imports of the module - ms_textual_imps :: [(PkgQual, Located ModuleName)], + ms_textual_imps :: [(ImportLevel, PkgQual, Located ModuleName)], -- ^ Non-source imports of the module from the module *text* - ms_ghc_prim_import :: !Bool, - -- ^ Whether the special module GHC.Prim was imported explicitly ms_parsed_mod :: Maybe HsParsedModule, -- ^ The parsed, nonrenamed source, if we have it. This is also -- used to support "inline module syntax" in Backpack files. @@ -99,34 +106,36 @@ ms_mod_name = moduleName . ms_mod -- | Textual imports, plus plugin imports but not SOURCE imports. -ms_imps :: ModSummary -> [(PkgQual, Located ModuleName)] +ms_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)] ms_imps ms = ms_textual_imps ms ++ ms_plugin_imps ms -- | Plugin imports -ms_plugin_imps :: ModSummary -> [(PkgQual, Located ModuleName)] -ms_plugin_imps ms = map ((NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms)) +ms_plugin_imps :: ModSummary -> [(ImportLevel, PkgQual, Located ModuleName)] +ms_plugin_imps ms = map ((SpliceLevel, NoPkgQual,) . noLoc) (pluginModNames (ms_hspp_opts ms)) -- | All of the (possibly) home module imports from the given list that is to -- say, each of these module names could be a home import if an appropriately -- named file existed. (This is in contrast to package qualified imports, which -- are guaranteed not to be home imports.) -home_imps :: [(PkgQual, Located ModuleName)] -> [(PkgQual, Located ModuleName)] -home_imps imps = filter (maybe_home . fst) imps +home_imps :: [(ImportLevel, PkgQual, Located ModuleName)] -> [(ImportLevel, PkgQual, Located ModuleName)] +home_imps imps = filter (maybe_home . pq) imps where maybe_home NoPkgQual = True maybe_home (ThisPkg _) = True maybe_home (OtherPkg _) = False + pq (_, p, _) = p + -- | Like 'ms_home_imps', but for SOURCE imports. ms_home_srcimps :: ModSummary -> ([Located ModuleName]) -- [] here because source imports can only refer to the current package. -ms_home_srcimps = map snd . home_imps . ms_srcimps +ms_home_srcimps = ms_srcimps -- | All of the (possibly) home module imports from a -- 'ModSummary'; that is to say, each of these module names -- could be a home import if an appropriately named file -- existed. (This is in contrast to package qualified -- imports, which are guaranteed not to be home imports.) -ms_home_imps :: ModSummary -> ([(PkgQual, Located ModuleName)]) +ms_home_imps :: ModSummary -> ([(ImportLevel, PkgQual, Located ModuleName)]) ms_home_imps = home_imps . ms_imps -- The ModLocation contains both the original source filename and the @@ -140,29 +149,41 @@ -- the ms_hs_hash and imports can, of course, change msHsFilePath, msDynHiFilePath, msHiFilePath, msObjFilePath, msDynObjFilePath :: ModSummary -> FilePath -msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHsFilePath ms = expectJust (ml_hs_file (ms_location ms)) msHiFilePath ms = ml_hi_file (ms_location ms) msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms) msObjFilePath ms = ml_obj_file (ms_location ms) msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms) +msHsFileOsPath, msDynHiFileOsPath, msHiFileOsPath, msObjFileOsPath, msDynObjFileOsPath :: ModSummary -> OsPath +msHsFileOsPath ms = expectJust (ml_hs_file_ospath (ms_location ms)) +msHiFileOsPath ms = ml_hi_file_ospath (ms_location ms) +msDynHiFileOsPath ms = ml_dyn_hi_file_ospath (ms_location ms) +msObjFileOsPath ms = ml_obj_file_ospath (ms_location ms) +msDynObjFileOsPath ms = ml_dyn_obj_file_ospath (ms_location ms) + -- | Did this 'ModSummary' originate from a hs-boot file? isBootSummary :: ModSummary -> IsBootInterface isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool +isTemplateHaskellOrQQNonBoot ms = + (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) + || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && + (isBootSummary ms == NotBoot) + ms_mnwib :: ModSummary -> ModuleNameWithIsBoot ms_mnwib ms = GWIB (ms_mod_name ms) (isBootSummary ms) -- | Returns the dependencies of the ModSummary s. -msDeps :: ModSummary -> ([(PkgQual, GenWithIsBoot (Located ModuleName))]) -msDeps s = - [ (NoPkgQual, d) +msDeps :: ModSummary -> ([(ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]) +msDeps s = [ (NormalLevel, NoPkgQual, d) -- Source imports are always NormalLevel | m <- ms_home_srcimps s , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot } ] ] - ++ [ (pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot })) - | (pkg, m) <- ms_imps s + ++ [ (stage, pkg, (GWIB { gwib_mod = m, gwib_isBoot = NotBoot })) + | (stage, pkg, m) <- ms_imps s ] instance Outputable ModSummary where @@ -192,5 +213,4 @@ = f == f' && ms_unitid summary == unitid _ `matches` _ = False - diff --git a/GHC/Unit/Module/Stage.hs b/GHC/Unit/Module/Stage.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/Stage.hs @@ -0,0 +1,85 @@ +module GHC.Unit.Module.Stage ( ModuleStage(..) + , allStages + , nowAndFutureStages + , onlyFutureStages + , minStage + , maxStage + , zeroStage + , decModuleStage + , incModuleStage + ) where + +import GHC.Prelude +import GHC.Utils.Outputable + +{- Note [Stage vs Level] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Modules are compiled at a specific stage. Levels within a module are interpreted +as offsets to the specific stage at which the module is being compiled. + +* A **level** is a typechecking concept. The type checker performs level checking + to ensure that the evaluation can proceed in a well-staged manner. +* A **stage** is an operational construct. The execution of the program happens + in stages. + +GHC at the moment knows about two stages, a module is either compiled for +compile time (*C*) or runtime (*R*), with *C* before *R*. Then: + +* The main module is compiled for `R`. + +* A normal import does not shift the stage at which the dependent module is required. + +* If a module `M` splice imports module `A`, then compiling `M` at stage + *R* requires compiling module `A` at stage *C*. + +* If a module `N` quote imports module `B`, then compiling `N` at stage + *C* requires compiling module `B` at stage *R*. + +The compiler can then choose appropiately how modules needed at `C` are compiled +and how modules needed at `R` are compiled. + +For example: + +* In `-fno-code` mode, `C` modules may be compiled in dynamic way, but `R` modules + are not compiled at all. +* When using a profiled GHC. `C` modules must be compiled in profiled way but `R` modules + will be compiled in static way. + +Further structure as needed by cross-compilation settings may require more stages. + +-} + +-- The order of these constructors is important for definitions such as +-- 'futureStages'. +data ModuleStage = CompileStage | RunStage deriving (Eq, Ord, Enum, Bounded) + +allStages :: [ModuleStage] +allStages = [minBound .. maxBound] + +nowAndFutureStages :: ModuleStage -> [ModuleStage] +nowAndFutureStages cur_st = [cur_st .. ] + +onlyFutureStages :: ModuleStage -> [ModuleStage] +onlyFutureStages cur_st | cur_st == maxBound = [] +onlyFutureStages cur_st = [succ cur_st .. ] + +minStage :: ModuleStage +minStage = minBound + +maxStage :: ModuleStage +maxStage = maxBound + +instance Outputable ModuleStage where + ppr CompileStage = text "compile" + ppr RunStage = text "run" + +zeroStage :: ModuleStage +zeroStage = RunStage + +decModuleStage, incModuleStage :: ModuleStage -> ModuleStage +incModuleStage RunStage = RunStage +incModuleStage CompileStage = RunStage + +decModuleStage RunStage = CompileStage +decModuleStage CompileStage = RunStage diff --git a/GHC/Unit/Module/Status.hs b/GHC/Unit/Module/Status.hs --- a/GHC/Unit/Module/Status.hs +++ b/GHC/Unit/Module/Status.hs @@ -41,6 +41,9 @@ -- changed. } +instance Outputable HscRecompStatus where + ppr HscUpToDate{} = text "HscUpToDate" + ppr HscRecompNeeded{} = text "HscRecompNeeded" instance Outputable HscBackendAction where ppr (HscUpdate mi) = text "Update:" <+> (ppr (mi_module mi)) diff --git a/GHC/Unit/Module/Warnings.hs b/GHC/Unit/Module/Warnings.hs --- a/GHC/Unit/Module/Warnings.hs +++ b/GHC/Unit/Module/Warnings.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,6 +9,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} -- | Warnings for a module module GHC.Unit.Module.Warnings @@ -28,6 +30,7 @@ , Warnings (..) , WarningTxt (..) + , LWarningTxt , DeclWarnOccNames , ExportWarnNames , warningTxtCategory @@ -54,12 +57,13 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Hs.Doc +import GHC.Hs.Extension +import GHC.Parser.Annotation import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Unicode -import Language.Haskell.Syntax.Concrete (HsToken (HsTok)) import Language.Haskell.Syntax.Extension import Data.Data @@ -116,18 +120,19 @@ data InWarningCategory = InWarningCategory - { iwc_in :: !(Located (HsToken "in")), + { iwc_in :: !(EpToken "in"), iwc_st :: !SourceText, - iwc_wc :: (Located WarningCategory) + iwc_wc :: (LocatedE WarningCategory) } deriving Data fromWarningCategory :: WarningCategory -> InWarningCategory -fromWarningCategory wc = InWarningCategory (noLoc HsTok) NoSourceText (noLoc wc) +fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc) -- See Note [Warning categories] newtype WarningCategory = WarningCategory FastString - deriving (Binary, Data, Eq, Outputable, Show, Uniquable, NFData) + deriving stock Data + deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData) mkWarningCategory :: FastString -> WarningCategory mkWarningCategory = WarningCategory @@ -191,20 +196,21 @@ deleteWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (delOneFromUniqSet s c) deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet s c) +type LWarningTxt pass = XRec pass (WarningTxt pass) -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt pass = WarningTxt - (Maybe (Located InWarningCategory)) + (Maybe (LocatedE InWarningCategory)) -- ^ Warning category attached to this WARNING pragma, if any; -- see Note [Warning categories] - (Located SourceText) - [Located (WithHsDocIdentifiers StringLiteral pass)] + SourceText + [LocatedE (WithHsDocIdentifiers StringLiteral pass)] | DeprecatedTxt - (Located SourceText) - [Located (WithHsDocIdentifiers StringLiteral pass)] + SourceText + [LocatedE (WithHsDocIdentifiers StringLiteral pass)] deriving Generic -- | To which warning category does this WARNING or DEPRECATED pragma belong? @@ -214,7 +220,7 @@ warningTxtCategory _ = defaultWarningCategory -- | The message that the WarningTxt was specified to output -warningTxtMessage :: WarningTxt p -> [Located (WithHsDocIdentifiers StringLiteral p)] +warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)] warningTxtMessage (WarningTxt _ _ m) = m warningTxtMessage (DeprecatedTxt _ m) = m @@ -233,16 +239,18 @@ deriving instance Eq InWarningCategory -deriving instance (Eq (HsToken "in"), Eq (IdP pass)) => Eq (WarningTxt pass) +deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP + instance Outputable InWarningCategory where ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) instance Outputable (WarningTxt pass) where ppr (WarningTxt mcat lsrc ws) - = case unLoc lsrc of + = case lsrc of NoSourceText -> pp_ws ws SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where @@ -250,11 +258,11 @@ ppr (DeprecatedTxt lsrc ds) - = case unLoc lsrc of + = case lsrc of NoSourceText -> pp_ws ds SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" -pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc +pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws = text "[" diff --git a/GHC/Unit/Module/WholeCoreBindings.hs b/GHC/Unit/Module/WholeCoreBindings.hs --- a/GHC/Unit/Module/WholeCoreBindings.hs +++ b/GHC/Unit/Module/WholeCoreBindings.hs @@ -1,17 +1,39 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} + module GHC.Unit.Module.WholeCoreBindings where -import GHC.Unit.Types (Module) -import GHC.Unit.Module.Location +import GHC.Cmm.CLabel +import GHC.Driver.DynFlags (DynFlags (targetPlatform), initSDocContext) +import GHC.ForeignSrcLang (ForeignSrcLang (..)) import GHC.Iface.Syntax +import GHC.Prelude +import GHC.Types.ForeignStubs +import GHC.Unit.Module.Location +import GHC.Unit.Types (Module) +import GHC.Utils.Binary +import GHC.Utils.Error (debugTraceMsg) +import GHC.Utils.Logger (Logger) +import GHC.Utils.Outputable +import GHC.Utils.Panic (panic, pprPanic) +import GHC.Utils.TmpFs +import Control.DeepSeq (NFData (..)) +import Data.Traversable (for) +import Data.Word (Word8) +import Data.Maybe (fromMaybe) +import System.FilePath (takeExtension) + {- Note [Interface Files with Core Definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A interface file can optionally contain the definitions of all core bindings, this is enabled by the flag `-fwrite-if-simplified-core`. This provides everything needed in addition to the normal ModIface and ModDetails -to restart compilation after typechecking to generate bytecode. The `fi_bindings` field +to restart compilation after typechecking to generate bytecode. The `wcb_bindings` field is stored in the normal interface file and the other fields populated whilst loading the interface file. @@ -24,14 +46,14 @@ the WholeCoreBindings into a proper Linkable (if we ever do that). The CoreBindings constructor also allows us to convert the WholeCoreBindings into multiple different linkables if we so desired. -2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCO linkable. This step combines together +2. `initWholeCoreBindings` turns a WholeCoreBindings into a proper BCOs linkable. This step combines together all the necessary information from a ModIface, ModDetails and WholeCoreBindings in order to - create the linkable. The linkable created is a "LoadedBCOs" linkable, which - was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazilly. + create the linkable. The linkable created is a "LazyBCOs" linkable, which + was introduced just for initWholeCoreBindings, so that the bytecode can be generated lazily. Using the `BCOs` constructor directly here leads to the bytecode being forced too eagerly. -3. Then when bytecode is needed, the LoadedBCOs value is inspected and unpacked and +3. Then when bytecode is needed, the LazyBCOs value is inspected and unpacked and the linkable is used as before. The flag `-fwrite-if-simplified-core` determines whether the extra information is written @@ -40,8 +62,55 @@ of the interface file agree with the optimisation level as reported by the interface file. +The lifecycle differs beyond laziness depending on the provenance of a module. +In all cases, the main consumer for interface bytecode is 'get_link_deps', which +traverses a splice's or GHCi expression's dependencies and collects the needed +build artifacts, which can be objects or bytecode, depending on the build +settings. + +1. In make mode, all eligible modules are part of the dependency graph. + Their interfaces are loaded unconditionally and in dependency order by the + compilation manager, and each module's bytecode is prepared before its + dependents are compiled, in one of two ways: + + - If the interface file for a module is missing or out of sync with its + source, it is recompiled and bytecode is generated directly and + immediately, not involving 'WholeCoreBindings' (in 'runHscBackendPhase'). + + - If the interface file is up to date, no compilation is performed, and a + lazy thunk generating bytecode from interface Core bindings is created in + 'compileOne'', which will only be compiled if a downstream module contains + a splice that depends on it, as described above. + + In both cases, the bytecode 'Linkable' is stored in a 'HomeModLinkable' in + the Home Unit Graph, lazy or not. + +2. In oneshot mode, which compiles individual modules without a shared home unit + graph, a previously compiled module is not reprocessed as described for make + mode above. + When 'get_link_deps' encounters a dependency on a local module, it requests + its bytecode from the External Package State, who loads the interface + on-demand. + + Since the EPS stores interfaces for all package dependencies in addition to + local modules in oneshot mode, it has a substantial memory footprint. + We try to curtail that by extracting important data into specialized fields + in the EPS, and retaining only a few fields of 'ModIface' by overwriting the + others with bottom values. + + In order to avoid keeping around all of the interface's components needed for + compiling bytecode, we instead store an IO action in 'eps_iface_bytecode'. + When 'get_link_deps' evaluates this action, the result is not retained in the + EPS, but stored in 'LoaderState', where it may eventually get evicted to free + up the memory. + This IO action retains the dehydrated Core bindings from the interface in its + closure. + Like the bytecode 'Linkable' stored in 'LoaderState', this is preferable to + storing the intermediate representation as rehydrated Core bindings, since + the latter have a significantly greater memory footprint. + Note [Size of Interface Files with Core Definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How much overhead does `-fwrite-if-simplified-core` add to a typical interface file? As an experiment I compiled the `Cabal` library and `ghc` library (Aug 22) with @@ -60,4 +129,375 @@ { wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -- ^ serialised tidied core bindings. , wcb_module :: Module -- ^ The module which the bindings are for , wcb_mod_location :: ModLocation -- ^ The location where the sources reside. + -- | Stubs for foreign declarations and files added via + -- 'GHC.Internal.TH.Syntax.addForeignFilePath'. + , wcb_foreign :: IfaceForeign } + +{- +Note [Foreign stubs and TH bytecode linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Foreign declarations may introduce additional build products called "stubs" that +contain wrappers for the exposed functions. +For example, consider a foreign import of a C function named @main_loop@ from +the file @bindings.h@ in the module @CLibrary@: + +@ +foreign import capi "bindings.h main_loop" mainLoop :: IO Int +@ + +GHC will generate a snippet of C code containing a wrapper: + +@ +#include "bindings.h" +HsInt ghczuwrapperZC0ZCmainZCCLibraryZCmainzuloop(void) {return main_loop();} +@ + +Wrappers like these are generated as 'ForeignStubs' by the desugarer in +'dsForeign' and stored in the various @*Guts@ types; until they are compiled to +temporary object files in 'runHscBackendPhase' during code generation and +ultimately merged into the final object file for the module, @CLibrary.o@. + +This creates some problems with @-fprefer-byte-code@, which allows splices to +execute bytecode instead of native code for dependencies that provide it. +Usually, when some TH code depends on @CLibrary@, the linker would look for +@CLibrary.o@ and load that before executing the splice, but with this flag, it +will first attempt to load bytecode from @CLibrary.hi@ and compile it in-memory. + +Problem 1: + +Code for splices is loaded from interfaces in the shape of Core bindings +(see 'WholeCoreBindings'), rather than from object files. +Those Core bindings are intermediate build products that do not contain the +module's stubs, since those are separated from the Haskell code before Core is +generated and only compiled and linked into the final object when native code is +generated. + +Therefore, stubs have to be stored separately in interface files. +Unfortunately, the type 'ForeignStubs' contains 'CLabel', which is a huge type +with several 'Unique's used mainly by C--. +Luckily, the only constructor used for foreign stubs is 'ModuleLabel', which +contains the name of a foreign declaration's initializer, if it has one. +So we convert a 'CLabel' to 'CStubLabel' in 'encodeIfaceForeign' and store only +the simplified data. + +Problem 2: + +Given module B, which contains a splice that executes code from module A, both +in the home package, consider these different circumstances: + +1. In make mode, both modules are recompiled +2. In make mode, only B is recompiled +3. In oneshot mode, B is compiled + +In case 1, 'runHscBackendPhase' directly generates bytecode from the 'CgGuts' +that the main pipeline produced and stores it in the 'HomeModLinkable' that is +one of its build products. +The stubs are merged into a single object and added to the 'HomeModLinkable' in +'hscGenBackendPipeline'. + +In case 2, 'hscRecompStatus' short-circuits the pipeline while checking A, since +the module is up to date. +Nevertheless, it calls 'checkByteCode', which extracts Core bindings from A's +interface and adds them to the 'HomeModLinkable'. +No stubs are generated in this case, since the desugarer wasn't run! + +In both of these cases, 'compileOne'' proceeds to call 'initWholeCoreBindings', +applied to the 'HomeModLinkable', to compile Core bindings (lazily) to bytecode, +which is then written back to the 'HomeModLinkable'. +If the 'HomeModLinkable' already contains bytecode (case 1), this is a no-op. +Otherwise, the stub objects from the interface are compiled to objects in +'generateByteCode' and added to the 'HomeModLinkable' as well. + +Case 3 is not implemented yet (!13042). + +Problem 3: + +In all three cases, the final step before splice execution is linking. + +The function 'getLinkDeps' is responsible for assembling all of a splice's +dependencies, looking up imported modules in the HPT and EPS, collecting all +'HomeModLinkable's and object files that it can find. + +However, since splices are executed in the interpreter, the 'Way' of the current +build may differ from the interpreter's. +For example, the current GHC invocation might be building a static binary, but +the internal interpreter requires dynamic linking; or profiling might be +enabled. +To adapt to the interpreter's 'Way', 'getLinkDeps' substitutes all object files' +extensions with that corresponding to that 'Way' – e.g. changing @.o@ to +@.dyn_o@, which requires dependencies to be built with @-dynamic[-too]@, which +in turn is enforced after downsweep in 'GHC.Driver.Make.enableCodeGenWhen'. + +This doesn't work for stub objects, though – they are compiled to temporary +files with mismatching names, so simply switching out the suffix would refer to +a nonexisting file. +Even if that wasn't an issue, they are compiled for the session's 'Way', not its +associated module's, so the dynamic variant wouldn't be available when building +only static outputs. + +To mitigate this, we instead build foreign objects specially for the +interpreter, updating the build flags in 'compile_for_interpreter' to use the +interpreter's way. + +Problem 4: + +Foreign code may have dependencies on Haskell code. + +Both foreign exports and @StaticPointers@ produce stubs that contain @extern@ +declarations of values referring to STG closures. +When those stub objects are loaded, the undefined symbols need to be provided to +the linker. + +I have no insight into how this works, and whether we could provide the memory +address of a BCO as a ccall symbol while linking, so it's unclear at the moment +what to do about this. + +In addition to that, those objects would also have to be loaded _after_ +bytecode, and therefore 'DotO' would have to be marked additionally to separate +them from those that are loaded before. +If mutual dependencies between BCOs and foreign code are possible, this will be +much more diffcult though. + +Problem 5: + +TH allows splices to add arbitrary files as additional linker inputs. + +Using the method `qAddForeignFilePath`, a foreign source file or a precompiled +object file can be added to the current modules dependencies. +These files will be processed by the pipeline and linked into the final object. + +Since the files may be temporarily created from a string, we have to read their +contents in 'encodeIfaceForeign' and store them in the interface as well, and +write them to temporary files when loading bytecode in 'decodeIfaceForeign'. +-} + +-- | Wrapper for avoiding a dependency on 'Binary' and 'NFData' in 'CLabel'. +newtype IfaceCLabel = IfaceCLabel CStubLabel + +instance Binary IfaceCLabel where + get bh = do + csl_is_initializer <- get bh + csl_module <- get bh + csl_name <- get bh + pure (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) + + put_ bh (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) = do + put_ bh csl_is_initializer + put_ bh csl_module + put_ bh csl_name + +instance NFData IfaceCLabel where + rnf (IfaceCLabel CStubLabel {csl_is_initializer, csl_module, csl_name}) = + rnf csl_is_initializer `seq` rnf csl_module `seq` rnf csl_name + +instance Outputable IfaceCLabel where + ppr (IfaceCLabel l) = ppr l + +-- | Simplified encoding of 'GHC.Types.ForeignStubs.ForeignStubs' for interface +-- serialization. +-- +-- See Note [Foreign stubs and TH bytecode linking] +data IfaceCStubs = + IfaceCStubs { + header :: String, + source :: String, + initializers :: [IfaceCLabel], + finalizers :: [IfaceCLabel] + } + +instance Outputable IfaceCStubs where + ppr IfaceCStubs {header, source, initializers, finalizers} = + vcat [ + hang (text "header:") 2 (vcat (text <$> lines header)), + hang (text "source:") 2 (vcat (text <$> lines source)), + hang (text "initializers:") 2 (ppr initializers), + hang (text "finalizers:") 2 (ppr finalizers) + ] + +-- | 'Binary' 'put_' for 'ForeignSrcLang'. +binary_put_ForeignSrcLang :: WriteBinHandle -> ForeignSrcLang -> IO () +binary_put_ForeignSrcLang bh lang = + put_ @Word8 bh $ case lang of + LangC -> 0 + LangCxx -> 1 + LangObjc -> 2 + LangObjcxx -> 3 + LangAsm -> 4 + LangJs -> 5 + RawObject -> 6 + +-- | 'Binary' 'get' for 'ForeignSrcLang'. +binary_get_ForeignSrcLang :: ReadBinHandle -> IO ForeignSrcLang +binary_get_ForeignSrcLang bh = do + b <- getByte bh + pure $ case b of + 0 -> LangC + 1 -> LangCxx + 2 -> LangObjc + 3 -> LangObjcxx + 4 -> LangAsm + 5 -> LangJs + 6 -> RawObject + _ -> panic "invalid Binary value for ForeignSrcLang" + +instance Binary IfaceCStubs where + get bh = do + header <- get bh + source <- get bh + initializers <- get bh + finalizers <- get bh + pure IfaceCStubs {..} + + put_ bh IfaceCStubs {..} = do + put_ bh header + put_ bh source + put_ bh initializers + put_ bh finalizers + +instance NFData IfaceCStubs where + rnf IfaceCStubs {..} = + rnf header + `seq` + rnf source + `seq` + rnf initializers + `seq` + rnf finalizers + +-- | A source file added from Template Haskell using 'qAddForeignFilePath', for +-- storage in interfaces. +-- +-- See Note [Foreign stubs and TH bytecode linking] +data IfaceForeignFile = + IfaceForeignFile { + -- | The language is specified by the user. + lang :: ForeignSrcLang, + + -- | The contents of the file, which will be written to a temporary file + -- when loaded from an interface. + source :: String, + + -- | The extension used by the user is preserved, to avoid confusing + -- external tools with an unexpected @.c@ file or similar. + extension :: FilePath + } + +instance Outputable IfaceForeignFile where + ppr IfaceForeignFile {lang, source} = + hang (text (show lang) <> colon) 2 (vcat (text <$> lines source)) + +instance Binary IfaceForeignFile where + get bh = do + lang <- binary_get_ForeignSrcLang bh + source <- get bh + extension <- get bh + pure IfaceForeignFile {lang, source, extension} + + put_ bh IfaceForeignFile {lang, source, extension} = do + binary_put_ForeignSrcLang bh lang + put_ bh source + put_ bh extension + +instance NFData IfaceForeignFile where + rnf IfaceForeignFile {lang, source, extension} = + lang `seq` rnf source `seq` rnf extension + +data IfaceForeign = + IfaceForeign { + stubs :: Maybe IfaceCStubs, + files :: [IfaceForeignFile] + } + +instance Outputable IfaceForeign where + ppr IfaceForeign {stubs, files} = + hang (text "stubs:") 2 (maybe (text "empty") ppr stubs) $$ + vcat (ppr <$> files) + +emptyIfaceForeign :: IfaceForeign +emptyIfaceForeign = IfaceForeign {stubs = Nothing, files = []} + +-- | Convert foreign stubs and foreign files to a format suitable for writing to +-- interfaces. +-- +-- See Note [Foreign stubs and TH bytecode linking] +encodeIfaceForeign :: + Logger -> + DynFlags -> + ForeignStubs -> + [(ForeignSrcLang, FilePath)] -> + IO IfaceForeign +encodeIfaceForeign logger dflags foreign_stubs lang_paths = do + files <- read_foreign_files + stubs <- encode_stubs foreign_stubs + let iff = IfaceForeign {stubs, files} + debugTraceMsg logger 3 $ + hang (text "Encoding foreign data for iface:") 2 (ppr iff) + pure iff + where + -- We can't just store the paths, since files may have been generated with + -- GHC session lifetime in 'GHC.Internal.TH.Syntax.addForeignSource'. + read_foreign_files = + for lang_paths $ \ (lang, path) -> do + source <- readFile path + pure IfaceForeignFile {lang, source, extension = takeExtension path} + + encode_stubs = \case + NoStubs -> + pure Nothing + ForeignStubs (CHeader header) (CStub source inits finals) -> + pure $ Just IfaceCStubs { + header = render header, + source = render source, + initializers = encode_label <$> inits, + finalizers = encode_label <$> finals + } + + encode_label clabel = + fromMaybe (invalid_label clabel) (IfaceCLabel <$> cStubLabel clabel) + + invalid_label clabel = + pprPanic + "-fwrite-if-simplified-core is incompatible with this foreign stub:" + (pprCLabel (targetPlatform dflags) clabel) + + render = renderWithContext (initSDocContext dflags PprCode) + +-- | Decode serialized foreign stubs and foreign files. +-- +-- See Note [Foreign stubs and TH bytecode linking] +decodeIfaceForeign :: + Logger -> + TmpFs -> + TempDir -> + IfaceForeign -> + IO (ForeignStubs, [(ForeignSrcLang, FilePath)]) +decodeIfaceForeign logger tmpfs tmp_dir iff@IfaceForeign {stubs, files} = do + debugTraceMsg logger 3 $ + hang (text "Decoding foreign data from iface:") 2 (ppr iff) + lang_paths <- for files $ \ IfaceForeignFile {lang, source, extension} -> do + f <- newTempName logger tmpfs tmp_dir TFL_GhcSession extension + writeFile f source + pure (lang, f) + pure (maybe NoStubs decode_stubs stubs, lang_paths) + where + decode_stubs IfaceCStubs {header, source, initializers, finalizers} = + ForeignStubs + (CHeader (text header)) + (CStub (text source) (labels initializers) (labels finalizers)) + + labels ls = [fromCStubLabel l | IfaceCLabel l <- ls] + +instance Binary IfaceForeign where + get bh = do + stubs <- get bh + files <- get bh + pure IfaceForeign {stubs, files} + + put_ bh IfaceForeign {stubs, files} = do + put_ bh stubs + put_ bh files + +instance NFData IfaceForeign where + rnf IfaceForeign {stubs, files} = rnf stubs `seq` rnf files diff --git a/GHC/Unit/State.hs b/GHC/Unit/State.hs --- a/GHC/Unit/State.hs +++ b/GHC/Unit/State.hs @@ -1,8 +1,6 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -- | Unit manipulation module GHC.Unit.State ( @@ -68,10 +66,10 @@ pprUnitInfoForUser, pprModuleMap, pprWithUnitState, + pprRawUnitIds, -- * Utils - unwireUnit, - implicitPackageDeps) + unwireUnit) where import GHC.Prelude @@ -118,7 +116,6 @@ import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup import qualified Data.Set as Set -import GHC.LanguageExtensions import Control.Applicative -- --------------------------------------------------------------------------- @@ -368,9 +365,13 @@ autoLink | not (gopt Opt_AutoLinkPackages dflags) = [] - -- By default we add base & rts to the preload units (when they are + -- By default we add base, ghc-internal and rts to the preload units (when they are -- found in the unit database) except when we are building them - | otherwise = filter (hu_id /=) [baseUnitId, rtsUnitId] + -- + -- Since "base" is not wired in, then the unit-id is discovered + -- from the settings file by default, but can be overriden by power-users + -- by specifying `-base-unit-id` flag. + | otherwise = filter (hu_id /=) [baseUnitId dflags, ghcInternalUnitId, rtsUnitId] -- if the home unit is indefinite, it means we are type-checking it only -- (not producing any code). Hence we can use virtual units instantiated @@ -1889,8 +1890,7 @@ = case lookupModuleWithSuggestions pkgs m NoPkgQual of LookupFound a b -> [(a,fst b)] LookupMultiple rs -> map f rs - where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs - (moduleUnit m))) + where f (m,_) = (m, expectJust (lookupUnit pkgs (moduleUnit m))) _ -> [] -- | The result of performing a lookup @@ -2271,10 +2271,6 @@ { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs) }) --- | Add package dependencies on the wired-in packages we use -implicitPackageDeps :: DynFlags -> [UnitId] -implicitPackageDeps dflags - = [thUnitId | xopt TemplateHaskellQuotes dflags] - -- TODO: Should also include `base` and `ghc-prim` if we use those implicitly, but - -- it is possible to not depend on base (for example, see `ghc-prim`) - +-- | Print raw unit-ids, without removing the hash +pprRawUnitIds :: SDoc -> SDoc +pprRawUnitIds = updSDocContext (\ctx -> ctx { sdocUnitIdForUser = ftext }) diff --git a/GHC/Unit/Types.hs b/GHC/Unit/Types.hs --- a/GHC/Unit/Types.hs +++ b/GHC/Unit/Types.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} -- instance Binary IsBootInterface - {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} @@ -60,23 +58,21 @@ , Definite (..) -- * Wired-in units - , primUnitId - , bignumUnitId - , baseUnitId + , ghcInternalUnitId , rtsUnitId - , thUnitId , mainUnitId , thisGhcUnitId , interactiveUnitId + , interactiveGhciUnitId + , interactiveSessionUnitId - , primUnit - , bignumUnit - , baseUnit + , ghcInternalUnit , rtsUnit - , thUnit , mainUnit , thisGhcUnit , interactiveUnit + , interactiveGhciUnit + , interactiveSessionUnit , isInteractiveModule , wiredInUnitIds @@ -110,7 +106,7 @@ import qualified Data.ByteString.Char8 as BS.Char8 import Language.Haskell.Syntax.Module.Name -import {-# SOURCE #-} Language.Haskell.Syntax.ImpExp (IsBootInterface(..)) +import Language.Haskell.Syntax.ImpExp (IsBootInterface(..)) --------------------------------------------------------------------- -- MODULES @@ -149,7 +145,8 @@ instance Binary a => Binary (GenModule a) where put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) + -- Module has strict fields, so use $! in order not to allocate a thunk + get bh = do p <- get bh; n <- get bh; return $! Module p n instance NFData (GenModule a) where rnf (Module unit name) = unit `seq` name `seq` () @@ -317,13 +314,14 @@ cid <- get bh insts <- get bh let fs = mkInstantiatedUnitHash cid insts - return InstantiatedUnit { - instUnitInstanceOf = cid, - instUnitInsts = insts, - instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), - instUnitFS = fs, - instUnitKey = getUnique fs - } + -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk + return $! InstantiatedUnit { + instUnitInstanceOf = cid, + instUnitInsts = insts, + instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + instUnitFS = fs, + instUnitKey = getUnique fs + } instance IsUnitId u => Eq (GenUnit u) where uid1 == uid2 = unitUnique uid1 == unitUnique uid2 @@ -369,10 +367,12 @@ put_ bh HoleUnit = putByte bh 2 get bh = do b <- getByte bh - case b of + u <- case b of 0 -> fmap RealUnit (get bh) 1 -> fmap VirtUnit (get bh) _ -> pure HoleUnit + -- Unit has strict fields that need forcing; otherwise we allocate a thunk. + pure $! u -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName @@ -513,6 +513,9 @@ } deriving (Data) +instance NFData UnitId where + rnf (UnitId fs) = rnf fs `seq` () + instance Binary UnitId where put_ bh (UnitId fs) = put_ bh fs get bh = do fs <- get bh; return (UnitId fs) @@ -588,27 +591,25 @@ -} -bignumUnitId, primUnitId, baseUnitId, rtsUnitId, - thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId +ghcInternalUnitId, rtsUnitId, + mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId -bignumUnit, primUnit, baseUnit, rtsUnit, - thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit +ghcInternalUnit, rtsUnit, + mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit -primUnitId = UnitId (fsLit "ghc-prim") -bignumUnitId = UnitId (fsLit "ghc-bignum") -baseUnitId = UnitId (fsLit "base") +ghcInternalUnitId = UnitId (fsLit "ghc-internal") rtsUnitId = UnitId (fsLit "rts") thisGhcUnitId = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id] interactiveUnitId = UnitId (fsLit "interactive") -thUnitId = UnitId (fsLit "template-haskell") +interactiveGhciUnitId = UnitId (fsLit "interactive-ghci") +interactiveSessionUnitId = UnitId (fsLit "interactive-session") -thUnit = RealUnit (Definite thUnitId) -primUnit = RealUnit (Definite primUnitId) -bignumUnit = RealUnit (Definite bignumUnitId) -baseUnit = RealUnit (Definite baseUnitId) +ghcInternalUnit = RealUnit (Definite ghcInternalUnitId) rtsUnit = RealUnit (Definite rtsUnitId) thisGhcUnit = RealUnit (Definite thisGhcUnitId) interactiveUnit = RealUnit (Definite interactiveUnitId) +interactiveGhciUnit = RealUnit (Definite interactiveGhciUnitId) +interactiveSessionUnit = RealUnit (Definite interactiveSessionUnitId) -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix @@ -621,11 +622,8 @@ wiredInUnitIds :: [UnitId] wiredInUnitIds = - [ primUnitId - , bignumUnitId - , baseUnitId + [ ghcInternalUnitId , rtsUnitId - , thUnitId ] -- NB: ghc is no longer part of the wired-in units since its unit-id, given -- by hadrian or cabal, is no longer overwritten and now matches both the @@ -686,17 +684,6 @@ -- modules in opposition to boot interfaces. Instead, one should use -- 'DriverPhases.HscSource'. See Note [HscSource types]. -instance Binary IsBootInterface where - put_ bh ib = put_ bh $ - case ib of - NotBoot -> False - IsBoot -> True - get bh = do - b <- get bh - return $ case b of - False -> NotBoot - True -> IsBoot - -- | This data type just pairs a value 'mod' with an IsBootInterface flag. In -- practice, 'mod' is usually a @Module@ or @ModuleName@'. data GenWithIsBoot mod = GWIB @@ -708,6 +695,9 @@ -- the Ord instance must ensure that we first sort by Module and then by -- IsBootInterface: this is assumed to perform filtering of non-boot modules, -- e.g. in GHC.Driver.Env.hptModulesBelow + +instance NFData mod => NFData (GenWithIsBoot mod) where + rnf (GWIB mod isBoot) = rnf mod `seq` rnf isBoot `seq` () type ModuleNameWithIsBoot = GenWithIsBoot ModuleName diff --git a/GHC/Utils/Binary.hs b/GHC/Utils/Binary.hs --- a/GHC/Utils/Binary.hs +++ b/GHC/Utils/Binary.hs @@ -1,1526 +1,2165 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UnboxedTuples #-} - -{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -#if MIN_VERSION_base(4,16,0) -#define HAS_TYPELITCHAR -#endif --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- --- (c) The University of Glasgow 2002-2006 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ - -module GHC.Utils.Binary - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - SymbolTable, Dictionary, - - BinData(..), dataHandle, handleData, - unsafeUnpackBinBuffer, - - openBinMem, --- closeBin, - - seekBin, - tellBin, - castBin, - withBinBuffer, - - foldGet, foldGet', - - writeBinMem, - readBinMem, - readBinMemN, - - putAt, getAt, - forwardPut, forwardPut_, forwardGet, - - -- * For writing instances - putByte, - getByte, - - -- * Variable length encodings - putULEB128, - getULEB128, - putSLEB128, - getSLEB128, - - -- * Fixed length encoding - FixedLengthEncoding(..), - - -- * Lazy Binary I/O - lazyGet, - lazyPut, - lazyGetMaybe, - lazyPutMaybe, - - -- * User data - UserData(..), getUserData, setUserData, - newReadState, newWriteState, noUserData, - - -- * String table ("dictionary") - putDictionary, getDictionary, putFS, - FSTable, initFSTable, getDictFastString, putDictFastString, - - -- * Newtype wrappers - BinSpan(..), BinSrcSpan(..), BinLocated(..) - ) where - -import GHC.Prelude - -import Language.Haskell.Syntax.Module.Name (ModuleName(..)) - -import {-# SOURCE #-} GHC.Types.Name (Name) -import GHC.Data.FastString -import GHC.Utils.Panic.Plain -import GHC.Types.Unique.FM -import GHC.Data.FastMutInt -import GHC.Utils.Fingerprint -import GHC.Types.SrcLoc -import GHC.Types.Unique -import qualified GHC.Data.Strict as Strict - -import Control.DeepSeq -import Foreign hiding (shiftL, shiftR, void) -import Data.Array -import Data.Array.IO -import Data.Array.Unsafe -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Data.IORef -import Data.Char ( ord, chr ) -import Data.List.NonEmpty ( NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Set ( Set ) -import qualified Data.Set as Set -import Data.Time -import Data.List (unfoldr) -import Control.Monad ( when, (<$!>), unless, forM_, void ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -#if MIN_VERSION_base(4,15,0) -import GHC.ForeignPtr ( unsafeWithForeignPtr ) -#endif - -type BinArray = ForeignPtr Word8 - -#if !MIN_VERSION_base(4,15,0) -unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b -unsafeWithForeignPtr = withForeignPtr -#endif - ---------------------------------------------------------------- --- BinData ---------------------------------------------------------------- - -data BinData = BinData Int BinArray - -instance NFData BinData where - rnf (BinData sz _) = rnf sz - -instance Binary BinData where - put_ bh (BinData sz dat) = do - put_ bh sz - putPrim bh sz $ \dest -> - unsafeWithForeignPtr dat $ \orig -> - copyBytes dest orig sz - -- - get bh = do - sz <- get bh - dat <- mallocForeignPtrBytes sz - getPrim bh sz $ \orig -> - unsafeWithForeignPtr dat $ \dest -> - copyBytes dest orig sz - return (BinData sz dat) - -dataHandle :: BinData -> IO BinHandle -dataHandle (BinData size bin) = do - ixr <- newFastMutInt 0 - szr <- newFastMutInt size - binr <- newIORef bin - return (BinMem noUserData ixr szr binr) - -handleData :: BinHandle -> IO BinData -handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr - ---------------------------------------------------------------- --- BinHandle ---------------------------------------------------------------- - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - bh_usr :: UserData, -- sigh, need parameterized modules :-) - _off_r :: !FastMutInt, -- the current offset - _sz_r :: !FastMutInt, -- size of the array (cached) - _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. - -getUserData :: BinHandle -> UserData -getUserData bh = bh_usr bh - -setUserData :: BinHandle -> UserData -> BinHandle -setUserData bh us = bh { bh_usr = us } - --- | Get access to the underlying buffer. -withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a -withBinBuffer (BinMem _ ix_r _ arr_r) action = do - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - action $ BS.fromForeignPtr arr 0 ix - -unsafeUnpackBinBuffer :: ByteString -> IO BinHandle -unsafeUnpackBinBuffer (BS.BS arr len) = do - arr_r <- newIORef arr - ix_r <- newFastMutInt 0 - sz_r <- newFastMutInt len - return (BinMem noUserData ix_r sz_r arr_r) - ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- - --- | Do not rely on instance sizes for general types, --- we use variable length encoding for many of them. -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do _ <- put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put_ bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- mallocForeignPtrBytes size - arr_r <- newIORef arr - ix_r <- newFastMutInt 0 - sz_r <- newFastMutInt size - return (BinMem noUserData ix_r sz_r arr_r) - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do - sz <- readFastMutInt sz_r - if (p > sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - --- | 'seekBinNoExpand' moves the index pointer to the location pointed to --- by 'Bin a'. --- This operation may 'panic', if the pointer location is out of bounds of the --- buffer of 'BinHandle'. -seekBinNoExpand :: BinHandle -> Bin a -> IO () -seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do - sz <- readFastMutInt sz_r - if (p > sz) - then panic "seekBinNoExpand: seek out of range" - else writeFastMutInt ix_r p - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinMem _ ix_r _ arr_r) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix - hClose h - -readBinMem :: FilePath -> IO BinHandle -readBinMem filename = do - withBinaryFile filename ReadMode $ \h -> do - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - readBinMem_ filesize h - -readBinMemN :: Int -> FilePath -> IO (Maybe BinHandle) -readBinMemN size filename = do - withBinaryFile filename ReadMode $ \h -> do - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - if filesize < size - then pure Nothing - else Just <$> readBinMem_ size h - -readBinMem_ :: Int -> Handle -> IO BinHandle -readBinMem_ filesize h = do - arr <- mallocForeignPtrBytes filesize - count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize - when (count /= filesize) $ - error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - arr_r <- newIORef arr - ix_r <- newFastMutInt 0 - sz_r <- newFastMutInt filesize - return (BinMem noUserData ix_r sz_r arr_r) - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ _ sz_r arr_r) !off = do - !sz <- readFastMutInt sz_r - let !sz' = getSize sz - arr <- readIORef arr_r - arr' <- mallocForeignPtrBytes sz' - withForeignPtr arr $ \old -> - withForeignPtr arr' $ \new -> - copyBytes new old sz - writeFastMutInt sz_r sz' - writeIORef arr_r arr' - where - getSize :: Int -> Int - getSize !sz - | sz > off - = sz - | otherwise - = getSize (sz * 2) - -foldGet - :: Binary a - => Word -- n elements - -> BinHandle - -> b -- initial accumulator - -> (Word -> a -> b -> IO b) - -> IO b -foldGet n bh init_b f = go 0 init_b - where - go i b - | i == n = return b - | otherwise = do - a <- get bh - b' <- f i a b - go (i+1) b' - -foldGet' - :: Binary a - => Word -- n elements - -> BinHandle - -> b -- initial accumulator - -> (Word -> a -> b -> IO b) - -> IO b -{-# INLINE foldGet' #-} -foldGet' n bh init_b f = go 0 init_b - where - go i !b - | i == n = return b - | otherwise = do - !a <- get bh - b' <- f i a b - go (i+1) b' - - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - --- | Takes a size and action writing up to @size@ bytes. --- After the action has run advance the index to the buffer --- by size bytes. -putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () -putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - expandBin h (ix + size) - arr <- readIORef arr_r - unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - --- -- | Similar to putPrim but advances the index by the actual number of --- -- bytes written. --- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () --- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do --- ix <- readFastMutInt ix_r --- sz <- readFastMutInt sz_r --- when (ix + size > sz) $ --- expandBin h (ix + size) --- arr <- readIORef arr_r --- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) --- writeFastMutInt ix_r (ix + written) - -getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a -getPrim (BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) - arr <- readIORef arr_r - w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix) - -- This is safe WRT #17760 as we we guarantee that the above line doesn't - -- diverge - writeFastMutInt ix_r (ix + size) - return w - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h !w = putPrim h 1 (\op -> poke op w) - -getWord8 :: BinHandle -> IO Word8 -getWord8 h = getPrim h 1 peek - -putWord16 :: BinHandle -> Word16 -> IO () -putWord16 h w = putPrim h 2 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) - pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) - ) - -getWord16 :: BinHandle -> IO Word16 -getWord16 h = getPrim h 2 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - return $! w0 `shiftL` 8 .|. w1 - ) - -putWord32 :: BinHandle -> Word32 -> IO () -putWord32 h w = putPrim h 4 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) - ) - -getWord32 :: BinHandle -> IO Word32 -getWord32 h = getPrim h 4 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - - return $! (w0 `shiftL` 24) .|. - (w1 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w3 - ) - -putWord64 :: BinHandle -> Word64 -> IO () -putWord64 h w = putPrim h 8 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) - pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) - pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) - ) - -getWord64 :: BinHandle -> IO Word64 -getWord64 h = getPrim h 8 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - w4 <- fromIntegral <$> peekElemOff op 4 - w5 <- fromIntegral <$> peekElemOff op 5 - w6 <- fromIntegral <$> peekElemOff op 6 - w7 <- fromIntegral <$> peekElemOff op 7 - - return $! (w0 `shiftL` 56) .|. - (w1 `shiftL` 48) .|. - (w2 `shiftL` 40) .|. - (w3 `shiftL` 32) .|. - (w4 `shiftL` 24) .|. - (w5 `shiftL` 16) .|. - (w6 `shiftL` 8) .|. - w7 - ) - -putByte :: BinHandle -> Word8 -> IO () -putByte bh !w = putWord8 bh w - -getByte :: BinHandle -> IO Word8 -getByte h = getWord8 h - --- ----------------------------------------------------------------------------- --- Encode numbers in LEB128 encoding. --- Requires one byte of space per 7 bits of data. --- --- There are signed and unsigned variants. --- Do NOT use the unsigned one for signed values, at worst it will --- result in wrong results, at best it will lead to bad performance --- when coercing negative values to an unsigned type. --- --- We mark them as SPECIALIZE as it's extremely critical that they get specialized --- to their specific types. --- --- TODO: Each use of putByte performs a bounds check, --- we should use putPrimMax here. However it's quite hard to return --- the number of bytes written into putPrimMax without allocating an --- Int for it, while the code below does not allocate at all. --- So we eat the cost of the bounds check instead of increasing allocations --- for now. - --- Unsigned numbers -{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} -putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () -putULEB128 bh w = -#if defined(DEBUG) - (if w < 0 then panic "putULEB128: Signed number" else id) $ -#endif - go w - where - go :: a -> IO () - go w - | w <= (127 :: a) - = putByte bh (fromIntegral w :: Word8) - | otherwise = do - -- bit 7 (8th bit) indicates more to come. - let !byte = setBit (fromIntegral w) 7 :: Word8 - putByte bh byte - go (w `unsafeShiftR` 7) - -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} -getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a -getULEB128 bh = - go 0 0 - where - go :: Int -> a -> IO a - go shift w = do - b <- getByte bh - let !hasMore = testBit b 7 - let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a - if hasMore - then do - go (shift+7) val - else - return $! val - --- Signed numbers -{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} -putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () -putSLEB128 bh initial = go initial - where - go :: a -> IO () - go val = do - let !byte = fromIntegral (clearBit val 7) :: Word8 - let !val' = val `unsafeShiftR` 7 - let !signBit = testBit byte 6 - let !done = - -- Unsigned value, val' == 0 and last value can - -- be discriminated from a negative number. - ((val' == 0 && not signBit) || - -- Signed value, - (val' == -1 && signBit)) - - let !byte' = if done then byte else setBit byte 7 - putByte bh byte' - - unless done $ go val' - -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} -getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a -getSLEB128 bh = do - (val,shift,signed) <- go 0 0 - if signed && (shift < finiteBitSize val ) - then return $! ((complement 0 `unsafeShiftL` shift) .|. val) - else return val - where - go :: Int -> a -> IO (a,Int,Bool) - go shift val = do - byte <- getByte bh - let !byteVal = fromIntegral (clearBit byte 7) :: a - let !val' = val .|. (byteVal `unsafeShiftL` shift) - let !more = testBit byte 7 - let !shift' = shift+7 - if more - then go (shift') val' - else do - let !signed = testBit byte 6 - return (val',shift',signed) - --- ----------------------------------------------------------------------------- --- Fixed length encoding instances - --- Sometimes words are used to represent a certain bit pattern instead --- of a number. Using FixedLengthEncoding we will write the pattern as --- is to the interface file without the variable length encoding we usually --- apply. - --- | Encode the argument in it's full length. This is different from many default --- binary instances which make no guarantee about the actual encoding and --- might do things use variable length encoding. -newtype FixedLengthEncoding a - = FixedLengthEncoding { unFixedLength :: a } - deriving (Eq,Ord,Show) - -instance Binary (FixedLengthEncoding Word8) where - put_ h (FixedLengthEncoding x) = putByte h x - get h = FixedLengthEncoding <$> getByte h - -instance Binary (FixedLengthEncoding Word16) where - put_ h (FixedLengthEncoding x) = putWord16 h x - get h = FixedLengthEncoding <$> getWord16 h - -instance Binary (FixedLengthEncoding Word32) where - put_ h (FixedLengthEncoding x) = putWord32 h x - get h = FixedLengthEncoding <$> getWord32 h - -instance Binary (FixedLengthEncoding Word64) where - put_ h (FixedLengthEncoding x) = putWord64 h x - get h = FixedLengthEncoding <$> getWord64 h - --- ----------------------------------------------------------------------------- --- Primitive Word writes - -instance Binary Word8 where - put_ bh !w = putWord8 bh w - get = getWord8 - -instance Binary Word16 where - put_ = putULEB128 - get = getULEB128 - -instance Binary Word32 where - put_ = putULEB128 - get = getULEB128 - -instance Binary Word64 where - put_ = putULEB128 - get = getULEB128 - --- ----------------------------------------------------------------------------- --- Primitive Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ = putSLEB128 - get = getSLEB128 - -instance Binary Int32 where - put_ = putSLEB128 - get = getSLEB128 - -instance Binary Int64 where - put_ h w = putSLEB128 h w - get h = getSLEB128 h - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ _ () = return () - get _ = return () - -instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) - -instance Binary Int where - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) - -instance Binary a => Binary [a] where - put_ bh l = do - let len = length l - put_ bh len - mapM_ (put_ bh) l - get bh = do - len <- get bh :: IO Int -- Int is variable length encoded so only - -- one byte for small lists. - let loop 0 = return [] - loop n = do a <- get bh; as <- loop (n-1); return (a:as) - loop len - --- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, --- so it works e.g. for 'Name's too. -instance (Binary a, Ord a) => Binary (Set a) where - put_ bh s = put_ bh (Set.toList s) - get bh = Set.fromList <$> get bh - -instance Binary a => Binary (NonEmpty a) where - put_ bh = put_ bh . NonEmpty.toList - get bh = NonEmpty.fromList <$> get bh - -instance (Ix a, Binary a, Binary b) => Binary (Array a b) where - put_ bh arr = do - put_ bh $ bounds arr - put_ bh $ elems arr - get bh = do - bounds <- get bh - xs <- get bh - return $ listArray bounds xs - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where - put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where - put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance Binary a => Binary (Strict.Maybe a) where - put_ bh Strict.Nothing = putByte bh 0 - put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a - get bh = - do h <- getWord8 bh - case h of - 0 -> return Strict.Nothing - _ -> do x <- get bh; return (Strict.Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance Binary UTCTime where - put_ bh u = do put_ bh (utctDay u) - put_ bh (utctDayTime u) - get bh = do day <- get bh - dayTime <- get bh - return $ UTCTime { utctDay = day, utctDayTime = dayTime } - -instance Binary Day where - put_ bh d = put_ bh (toModifiedJulianDay d) - get bh = do i <- get bh - return $ ModifiedJulianDay { toModifiedJulianDay = i } - -instance Binary DiffTime where - put_ bh dt = put_ bh (toRational dt) - get bh = do r <- get bh - return $ fromRational r - -{- -Finally - a reasonable portable Integer instance. - -We used to encode values in the Int32 range as such, -falling back to a string of all things. In either case -we stored a tag byte to discriminate between the two cases. - -This made some sense as it's highly portable but also not very -efficient. - -However GHC stores a surprisingly large number off large Integer -values. In the examples looked at between 25% and 50% of Integers -serialized were outside of the Int32 range. - -Consider a valie like `2724268014499746065`, some sort of hash -actually generated by GHC. -In the old scheme this was encoded as a list of 19 chars. This -gave a size of 77 Bytes, one for the length of the list and 76 -since we encode chars as Word32 as well. - -We can easily do better. The new plan is: - -* Start with a tag byte - * 0 => Int64 (LEB128 encoded) - * 1 => Negative large integer - * 2 => Positive large integer -* Followed by the value: - * Int64 is encoded as usual - * Large integers are encoded as a list of bytes (Word8). - We use Data.Bits which defines a bit order independent of the representation. - Values are stored LSB first. - -This means our example value `2724268014499746065` is now only 10 bytes large. -* One byte tag -* One byte for the length of the [Word8] list. -* 8 bytes for the actual date. - -The new scheme also does not depend in any way on -architecture specific details. - -We still use this scheme even with LEB128 available, -as it has less overhead for truly large numbers. (> maxBound :: Int64) - -The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal --} - -instance Binary Integer where - put_ bh i - | i >= lo64 && i <= hi64 = do - putWord8 bh 0 - put_ bh (fromIntegral i :: Int64) - | otherwise = do - if i < 0 - then putWord8 bh 1 - else putWord8 bh 2 - put_ bh (unroll $ abs i) - where - lo64 = fromIntegral (minBound :: Int64) - hi64 = fromIntegral (maxBound :: Int64) - get bh = do - int_kind <- getWord8 bh - case int_kind of - 0 -> fromIntegral <$!> (get bh :: IO Int64) - -- Large integer - 1 -> negate <$!> getInt - 2 -> getInt - _ -> panic "Binary Integer - Invalid byte" - where - getInt :: IO Integer - getInt = roll <$!> (get bh :: IO [Word8]) - -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldl' unstep 0 . reverse - where - unstep a b = a `shiftL` 8 .|. fromIntegral b - - - {- - -- This code is currently commented out. - -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for - -- discussion. - - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - putByte bh 1 - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - -} - -{- -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newByteArray# sz s of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s, arr #) -> - (# s, BA arr #) } - -writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeByteArray arr i (W8# w) = IO $ \s -> - case writeWord8Array# arr i w s of { s -> - (# s, () #) } - -indexByteArray :: ByteArray# -> Int# -> Word8 -indexByteArray a# n# = W8# (indexWord8Array# a# n#) - --} -instance (Binary a) => Binary (Ratio a) where - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - --- Instance uses fixed-width encoding to allow inserting --- Bin placeholders in the stream. -instance Binary (Bin a) where - put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) - get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) - - --- ----------------------------------------------------------------------------- --- Forward reading/writing - --- | "forwardPut put_A put_B" outputs A after B but allows A to be read before B --- by using a forward reference -forwardPut :: BinHandle -> (b -> IO a) -> IO b -> IO (a,b) -forwardPut bh put_A put_B = do - -- write placeholder pointer to A - pre_a <- tellBin bh - put_ bh pre_a - - -- write B - r_b <- put_B - - -- update A's pointer - a <- tellBin bh - putAt bh pre_a a - seekBinNoExpand bh a - - -- write A - r_a <- put_A r_b - pure (r_a,r_b) - -forwardPut_ :: BinHandle -> (b -> IO a) -> IO b -> IO () -forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B - --- | Read a value stored using a forward reference -forwardGet :: BinHandle -> IO a -> IO a -forwardGet bh get_A = do - -- read forward reference - p <- get bh -- a BinPtr - -- store current position - p_a <- tellBin bh - -- go read the forward value, then seek back - seekBinNoExpand bh p - r <- get_A - seekBinNoExpand bh p_a - pure r - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO $ do - -- NB: Use a fresh off_r variable in the child thread, for thread - -- safety. - off_r <- newFastMutInt 0 - getAt bh { _off_r = off_r } p_a - seekBin bh p -- skip over the object for now - return a - --- | Serialize the constructor strictly but lazily serialize a value inside a --- 'Just'. --- --- This way we can check for the presence of a value without deserializing the --- value itself. -lazyPutMaybe :: Binary a => BinHandle -> Maybe a -> IO () -lazyPutMaybe bh Nothing = putWord8 bh 0 -lazyPutMaybe bh (Just x) = do - putWord8 bh 1 - lazyPut bh x - --- | Deserialize a value serialized by 'lazyPutMaybe'. -lazyGetMaybe :: Binary a => BinHandle -> IO (Maybe a) -lazyGetMaybe bh = do - h <- getWord8 bh - case h of - 0 -> pure Nothing - _ -> Just <$> lazyGet bh - --- ----------------------------------------------------------------------------- --- UserData --- ----------------------------------------------------------------------------- - --- | Information we keep around during interface file --- serialization/deserialization. Namely we keep the functions for serializing --- and deserializing 'Name's and 'FastString's. We do this because we actually --- use serialization in two distinct settings, --- --- * When serializing interface files themselves --- --- * When computing the fingerprint of an IfaceDecl (which we computing by --- hashing its Binary serialization) --- --- These two settings have different needs while serializing Names: --- --- * Names in interface files are serialized via a symbol table (see Note --- [Symbol table representation of names] in "GHC.Iface.Binary"). --- --- * During fingerprinting a binding Name is serialized as the OccName and a --- non-binding Name is serialized as the fingerprint of the thing they --- represent. See Note [Fingerprinting IfaceDecls] for further discussion. --- -data UserData = - UserData { - -- for *deserialising* only: - ud_get_name :: BinHandle -> IO Name, - ud_get_fs :: BinHandle -> IO FastString, - - -- for *serialising* only: - ud_put_nonbinding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a non-binding 'Name' (e.g. a reference to another - -- binding). - ud_put_binding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) - ud_put_fs :: BinHandle -> FastString -> IO () - } - -newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's - -> (BinHandle -> IO FastString) - -> UserData -newReadState get_name get_fs - = UserData { ud_get_name = get_name, - ud_get_fs = get_fs, - ud_put_nonbinding_name = undef "put_nonbinding_name", - ud_put_binding_name = undef "put_binding_name", - ud_put_fs = undef "put_fs" - } - -newWriteState :: (BinHandle -> Name -> IO ()) - -- ^ how to serialize non-binding 'Name's - -> (BinHandle -> Name -> IO ()) - -- ^ how to serialize binding 'Name's - -> (BinHandle -> FastString -> IO ()) - -> UserData -newWriteState put_nonbinding_name put_binding_name put_fs - = UserData { ud_get_name = undef "get_name", - ud_get_fs = undef "get_fs", - ud_put_nonbinding_name = put_nonbinding_name, - ud_put_binding_name = put_binding_name, - ud_put_fs = put_fs - } - -noUserData :: UserData -noUserData = UserData - { ud_get_name = undef "get_name" - , ud_get_fs = undef "get_fs" - , ud_put_nonbinding_name = undef "put_nonbinding_name" - , ud_put_binding_name = undef "put_binding_name" - , ud_put_fs = undef "put_fs" - } - -undef :: String -> a -undef s = panic ("Binary.UserData: no " ++ s) - ---------------------------------------------------------- --- The Dictionary ---------------------------------------------------------- - -type Dictionary = Array Int FastString -- The dictionary - -- Should be 0-indexed - -putDictionary :: BinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO () -putDictionary bh sz dict = do - put_ bh sz - mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) - -- It's OK to use nonDetEltsUFM here because the elements have indices - -- that array uses to create order - -getDictionary :: BinHandle -> IO Dictionary -getDictionary bh = do - sz <- get bh :: IO Int - mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString) - forM_ [0..(sz-1)] $ \i -> do - fs <- getFS bh - writeArray mut_arr i fs - unsafeFreeze mut_arr - -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh - return $! (dict ! fromIntegral (j :: Word32)) - - -initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int) -initFSTable bh = do - dict_next_ref <- newFastMutInt 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = FSTable - { fs_tab_next = dict_next_ref - , fs_tab_map = dict_map_ref - } - let put_dict = do - fs_count <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh fs_count dict_map - pure fs_count - - -- BinHandle with FastString writing support - let ud = getUserData bh - let ud_fs = ud { ud_put_fs = putDictFastString bin_dict } - let bh_fs = setUserData bh ud_fs - - return (bh_fs,bin_dict,put_dict) - -putDictFastString :: FSTable -> BinHandle -> FastString -> IO () -putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh - -allocateFastString :: FSTable -> FastString -> IO Word32 -allocateFastString FSTable { fs_tab_next = j_r - , fs_tab_map = out_r - } f = do - out <- readIORef out_r - let !uniq = getUnique f - case lookupUFM_Directly out uniq of - Just (j, _) -> return (fromIntegral j :: Word32) - Nothing -> do - j <- readFastMutInt j_r - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM_Directly out uniq (j, f) - return (fromIntegral j :: Word32) - --- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to --- avoid a collision and copy to avoid a dependency. -data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use - , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) - -- indexed by FastString - } - - ---------------------------------------------------------- --- The Symbol Table ---------------------------------------------------------- - --- On disk, the symbol table is an array of IfExtName, when --- reading it in we turn it into a SymbolTable. - -type SymbolTable = Array Int Name - ---------------------------------------------------------- --- Reading and writing FastStrings ---------------------------------------------------------- - -putFS :: BinHandle -> FastString -> IO () -putFS bh fs = putBS bh $ bytesFS fs - -getFS :: BinHandle -> IO FastString -getFS bh = do - l <- get bh :: IO Int - getPrim bh l (\src -> pure $! mkFastStringBytes src l ) - -putBS :: BinHandle -> ByteString -> IO () -putBS bh bs = - BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do - put_ bh l - putPrim bh l (\op -> copyBytes op (castPtr ptr) l) - -getBS :: BinHandle -> IO ByteString -getBS bh = do - l <- get bh :: IO Int - BS.create l $ \dest -> do - getPrim bh l (\src -> copyBytes dest src l) - -instance Binary ByteString where - put_ bh f = putBS bh f - get bh = getBS bh - -instance Binary FastString where - put_ bh f = - case getUserData bh of - UserData { ud_put_fs = put_fs } -> put_fs bh f - - get bh = - case getUserData bh of - UserData { ud_get_fs = get_fs } -> get_fs bh - -deriving instance Binary NonDetFastString -deriving instance Binary LexicalFastString - -instance Binary Fingerprint where - put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 - get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - --- instance Binary TupleSort where --- put_ bh BoxedTuple = putByte bh 0 --- put_ bh UnboxedTuple = putByte bh 1 --- put_ bh ConstraintTuple = putByte bh 2 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return BoxedTuple --- 1 -> do return UnboxedTuple --- _ -> do return ConstraintTuple - --- instance Binary Activation where --- put_ bh NeverActive = do --- putByte bh 0 --- put_ bh FinalActive = do --- putByte bh 1 --- put_ bh AlwaysActive = do --- putByte bh 2 --- put_ bh (ActiveBefore src aa) = do --- putByte bh 3 --- put_ bh src --- put_ bh aa --- put_ bh (ActiveAfter src ab) = do --- putByte bh 4 --- put_ bh src --- put_ bh ab --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return NeverActive --- 1 -> do return FinalActive --- 2 -> do return AlwaysActive --- 3 -> do src <- get bh --- aa <- get bh --- return (ActiveBefore src aa) --- _ -> do src <- get bh --- ab <- get bh --- return (ActiveAfter src ab) - --- instance Binary InlinePragma where --- put_ bh (InlinePragma s a b c d) = do --- put_ bh s --- put_ bh a --- put_ bh b --- put_ bh c --- put_ bh d - --- get bh = do --- s <- get bh --- a <- get bh --- b <- get bh --- c <- get bh --- d <- get bh --- return (InlinePragma s a b c d) - --- instance Binary RuleMatchInfo where --- put_ bh FunLike = putByte bh 0 --- put_ bh ConLike = putByte bh 1 --- get bh = do --- h <- getByte bh --- if h == 1 then return ConLike --- else return FunLike - --- instance Binary InlineSpec where --- put_ bh NoUserInlinePrag = putByte bh 0 --- put_ bh Inline = putByte bh 1 --- put_ bh Inlinable = putByte bh 2 --- put_ bh NoInline = putByte bh 3 - --- get bh = do h <- getByte bh --- case h of --- 0 -> return NoUserInlinePrag --- 1 -> return Inline --- 2 -> return Inlinable --- _ -> return NoInline - --- instance Binary RecFlag where --- put_ bh Recursive = do --- putByte bh 0 --- put_ bh NonRecursive = do --- putByte bh 1 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return Recursive --- _ -> do return NonRecursive - --- instance Binary OverlapMode where --- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s --- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s --- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s --- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s --- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s --- get bh = do --- h <- getByte bh --- case h of --- 0 -> (get bh) >>= \s -> return $ NoOverlap s --- 1 -> (get bh) >>= \s -> return $ Overlaps s --- 2 -> (get bh) >>= \s -> return $ Incoherent s --- 3 -> (get bh) >>= \s -> return $ Overlapping s --- 4 -> (get bh) >>= \s -> return $ Overlappable s --- _ -> panic ("get OverlapMode" ++ show h) - - --- instance Binary OverlapFlag where --- put_ bh flag = do put_ bh (overlapMode flag) --- put_ bh (isSafeOverlap flag) --- get bh = do --- h <- get bh --- b <- get bh --- return OverlapFlag { overlapMode = h, isSafeOverlap = b } - --- instance Binary FixityDirection where --- put_ bh InfixL = do --- putByte bh 0 --- put_ bh InfixR = do --- putByte bh 1 --- put_ bh InfixN = do --- putByte bh 2 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do return InfixL --- 1 -> do return InfixR --- _ -> do return InfixN - --- instance Binary Fixity where --- put_ bh (Fixity src aa ab) = do --- put_ bh src --- put_ bh aa --- put_ bh ab --- get bh = do --- src <- get bh --- aa <- get bh --- ab <- get bh --- return (Fixity src aa ab) - --- instance Binary WarningTxt where --- put_ bh (WarningTxt s w) = do --- putByte bh 0 --- put_ bh s --- put_ bh w --- put_ bh (DeprecatedTxt s d) = do --- putByte bh 1 --- put_ bh s --- put_ bh d - --- get bh = do --- h <- getByte bh --- case h of --- 0 -> do s <- get bh --- w <- get bh --- return (WarningTxt s w) --- _ -> do s <- get bh --- d <- get bh --- return (DeprecatedTxt s d) - --- instance Binary StringLiteral where --- put_ bh (StringLiteral st fs _) = do --- put_ bh st --- put_ bh fs --- get bh = do --- st <- get bh --- fs <- get bh --- return (StringLiteral st fs Nothing) - -newtype BinLocated a = BinLocated { unBinLocated :: Located a } - -instance Binary a => Binary (BinLocated a) where - put_ bh (BinLocated (L l x)) = do - put_ bh $ BinSrcSpan l - put_ bh x - - get bh = do - l <- unBinSrcSpan <$> get bh - x <- get bh - return $ BinLocated (L l x) - -newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } - --- See Note [Source Location Wrappers] -instance Binary BinSpan where - put_ bh (BinSpan ss) = do - put_ bh (srcSpanFile ss) - put_ bh (srcSpanStartLine ss) - put_ bh (srcSpanStartCol ss) - put_ bh (srcSpanEndLine ss) - put_ bh (srcSpanEndCol ss) - - get bh = do - f <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) - -instance Binary UnhelpfulSpanReason where - put_ bh r = case r of - UnhelpfulNoLocationInfo -> putByte bh 0 - UnhelpfulWiredIn -> putByte bh 1 - UnhelpfulInteractive -> putByte bh 2 - UnhelpfulGenerated -> putByte bh 3 - UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs - - get bh = do - h <- getByte bh - case h of - 0 -> return UnhelpfulNoLocationInfo - 1 -> return UnhelpfulWiredIn - 2 -> return UnhelpfulInteractive - 3 -> return UnhelpfulGenerated - _ -> UnhelpfulOther <$> get bh - -newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } - --- See Note [Source Location Wrappers] -instance Binary BinSrcSpan where - put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do - putByte bh 0 - -- BufSpan doesn't ever get serialised because the positions depend - -- on build location. - put_ bh $ BinSpan ss - - put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> do BinSpan ss <- get bh - return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) - _ -> do s <- get bh - return $ BinSrcSpan (UnhelpfulSpan s) - - -{- -Note [Source Location Wrappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Source locations are banned from interface files, to -prevent filepaths affecting interface hashes. - -Unfortunately, we can't remove all binary instances, -as they're used to serialise .hie files, and we don't -want to break binary compatibility. - -To this end, the Bin[Src]Span newtypes wrappers were -introduced to prevent accidentally serialising a -source location as part of a larger structure. --} - --------------------------------------------------------------------------------- --- Instances for the containers package --------------------------------------------------------------------------------- - -instance (Binary v) => Binary (IntMap v) where - put_ bh m = put_ bh (IntMap.toList m) - get bh = IntMap.fromList <$> get bh +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module GHC.Utils.Binary + ( {-type-} Bin, RelBin(..), getRelBin, + {-class-} Binary(..), + {-type-} ReadBinHandle, WriteBinHandle, + SymbolTable, Dictionary, + + BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, + + openBinMem, +-- closeBin, + + seekBinWriter, + seekBinReader, + seekBinReaderRel, + tellBinReader, + tellBinWriter, + castBin, + withBinBuffer, + freezeWriteHandle, + shrinkBinBuffer, + thawReadHandle, + + foldGet, foldGet', + + writeBinMem, + readBinMem, + readBinMemN, + + putAt, getAt, + putAtRel, + forwardPut, forwardPut_, forwardGet, + forwardPutRel, forwardPutRel_, forwardGetRel, + + -- * For writing instances + putByte, + getByte, + putByteString, + getByteString, + + -- * Variable length encodings + putULEB128, + getULEB128, + putSLEB128, + getSLEB128, + + -- * Fixed length encoding + FixedLengthEncoding(..), + + -- * Lazy Binary I/O + lazyGet, + lazyPut, + lazyGet', + lazyPut', + lazyGetMaybe, + lazyPutMaybe, + + -- * EnumBinary + EnumBinary(..), + + -- * User data + ReaderUserData, getReaderUserData, setReaderUserData, noReaderUserData, + WriterUserData, getWriterUserData, setWriterUserData, noWriterUserData, + mkWriterUserData, mkReaderUserData, + newReadState, newWriteState, + addReaderToUserData, addWriterToUserData, + findUserDataReader, findUserDataWriter, + -- * Binary Readers & Writers + BinaryReader(..), BinaryWriter(..), + mkWriter, mkReader, + SomeBinaryReader, SomeBinaryWriter, + mkSomeBinaryReader, mkSomeBinaryWriter, + -- * Tables + ReaderTable(..), + WriterTable(..), + -- * String table ("dictionary") + initFastStringReaderTable, initFastStringWriterTable, + putDictionary, getDictionary, putFS, + FSTable(..), getDictFastString, putDictFastString, + -- * Generic deduplication table + GenericSymbolTable(..), + initGenericSymbolTable, + getGenericSymtab, putGenericSymTab, + getGenericSymbolTable, putGenericSymbolTable, + -- * Newtype wrappers + BinSpan(..), BinSrcSpan(..), BinLocated(..), + -- * Newtypes for types that have canonically more than one valid encoding + BindingName(..), + simpleBindingNameWriter, + simpleBindingNameReader, + FullBinData(..), freezeBinHandle, thawBinHandle, putFullBinData, + BinArray, + + -- * FingerprintWithValue + FingerprintWithValue(..) + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Module.Name (ModuleName(..)) +import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) + +import {-# SOURCE #-} GHC.Types.Name (Name) +import GHC.Data.FastString +import GHC.Data.TrieMap +import GHC.Utils.Panic.Plain +import GHC.Types.Unique.FM +import GHC.Data.FastMutInt +import GHC.Utils.Fingerprint +import GHC.Types.SrcLoc +import GHC.Types.Unique +import qualified GHC.Data.Strict as Strict +import GHC.Utils.Outputable( JoinPointHood(..) ) + +import Control.DeepSeq +import Control.Monad ( when, (<$!>), unless, forM_, void ) +import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) +import Data.Array +import Data.Array.IO +import Data.Array.Unsafe +import Data.ByteString (ByteString, copy) +import Data.Coerce +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import qualified Data.ByteString.Short.Internal as SBS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.List.NonEmpty ( NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy +import Data.Set ( Set ) +import qualified Data.Set as Set +import Data.Time +import Data.List (unfoldr) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import Type.Reflection ( Typeable, SomeTypeRep(..) ) +import qualified Type.Reflection as Refl +import GHC.Real ( Ratio(..) ) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import GHC.ForeignPtr ( unsafeWithForeignPtr ) + +import Unsafe.Coerce (unsafeCoerce) + +type BinArray = ForeignPtr Word8 + + +--------------------------------------------------------------- +-- BinData +--------------------------------------------------------------- + +data BinData = BinData Int BinArray + +instance NFData BinData where + rnf (BinData sz _) = rnf sz + +instance Binary BinData where + put_ bh (BinData sz dat) = do + put_ bh sz + putPrim bh sz $ \dest -> + unsafeWithForeignPtr dat $ \orig -> + copyBytes dest orig sz + -- + get bh = do + sz <- get bh + dat <- mallocForeignPtrBytes sz + getPrim bh sz $ \orig -> + unsafeWithForeignPtr dat $ \dest -> + copyBytes dest orig sz + return (BinData sz dat) + +dataHandle :: BinData -> IO ReadBinHandle +dataHandle (BinData size bin) = do + ixr <- newFastMutInt 0 + return (ReadBinMem noReaderUserData ixr size bin) + +handleData :: WriteBinHandle -> IO BinData +handleData (WriteBinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr + +--------------------------------------------------------------- +-- FullBinData +--------------------------------------------------------------- + +-- | 'FullBinData' stores a slice to a 'BinArray'. +-- +-- It requires less memory than 'ReadBinHandle', and can be constructed from +-- a 'ReadBinHandle' via 'freezeBinHandle' and turned back into a +-- 'ReadBinHandle' using 'thawBinHandle'. +-- Additionally, the byte array slice can be put into a 'WriteBinHandle' without extra +-- conversions via 'putFullBinData'. +data FullBinData = FullBinData + { fbd_readerUserData :: ReaderUserData + -- ^ 'ReaderUserData' that can be used to resume reading. + , fbd_off_s :: {-# UNPACK #-} !Int + -- ^ start offset + , fbd_off_e :: {-# UNPACK #-} !Int + -- ^ end offset + , fbd_size :: {-# UNPACK #-} !Int + -- ^ total buffer size + , fbd_buffer :: {-# UNPACK #-} !BinArray + } + +-- Equality and Ord assume that two distinct buffers are different, even if they compare the same things. +instance Eq FullBinData where + (FullBinData _ b c d e) == (FullBinData _ b1 c1 d1 e1) = b == b1 && c == c1 && d == d1 && e == e1 + +instance Ord FullBinData where + compare (FullBinData _ b c d e) (FullBinData _ b1 c1 d1 e1) = + compare b b1 `mappend` compare c c1 `mappend` compare d d1 `mappend` compare e e1 + +-- | Write the 'FullBinData' slice into the 'WriteBinHandle'. +putFullBinData :: WriteBinHandle -> FullBinData -> IO () +putFullBinData bh (FullBinData _ o1 o2 _sz ba) = do + let sz = o2 - o1 + putPrim bh sz $ \dest -> + unsafeWithForeignPtr (ba `plusForeignPtr` o1) $ \orig -> + copyBytes dest orig sz + +-- | Freeze a 'ReadBinHandle' and a start index into a 'FullBinData'. +-- +-- 'FullBinData' stores a slice starting from the 'Bin a' location to the current +-- offset of the 'ReadBinHandle'. +freezeBinHandle :: ReadBinHandle -> Bin a -> IO FullBinData +freezeBinHandle (ReadBinMem user_data ixr sz binr) (BinPtr start) = do + ix <- readFastMutInt ixr + pure (FullBinData user_data start ix sz binr) + +-- | Turn the 'FullBinData' into a 'ReadBinHandle', setting the 'ReadBinHandle' +-- offset to the start of the 'FullBinData' and restore the 'ReaderUserData' that was +-- obtained from 'freezeBinHandle'. +thawBinHandle :: FullBinData -> IO ReadBinHandle +thawBinHandle (FullBinData user_data ix _end sz ba) = do + ixr <- newFastMutInt ix + return $ ReadBinMem user_data ixr sz ba + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +-- | A write-only handle that can be used to serialise binary data into a buffer. +-- +-- The buffer is an unboxed binary array. +data WriteBinHandle + = WriteBinMem { + wbm_userData :: WriterUserData, + -- ^ User data for writing binary outputs. + -- Allows users to overwrite certain 'Binary' instances. + -- This is helpful when a non-canonical 'Binary' instance is required, + -- such as in the case of 'Name'. + wbm_off_r :: !FastMutInt, -- ^ the current offset + wbm_sz_r :: !FastMutInt, -- ^ size of the array (cached) + wbm_arr_r :: !(IORef BinArray) -- ^ the array (bounds: (0,size-1)) + } + +-- | A read-only handle that can be used to deserialise binary data from a buffer. +-- +-- The buffer is an unboxed binary array. +data ReadBinHandle + = ReadBinMem { + rbm_userData :: ReaderUserData, + -- ^ User data for reading binary inputs. + -- Allows users to overwrite certain 'Binary' instances. + -- This is helpful when a non-canonical 'Binary' instance is required, + -- such as in the case of 'Name'. + rbm_off_r :: !FastMutInt, -- ^ the current offset + rbm_sz_r :: !Int, -- ^ size of the array (cached) + rbm_arr_r :: !BinArray -- ^ the array (bounds: (0,size-1)) + } + +getReaderUserData :: ReadBinHandle -> ReaderUserData +getReaderUserData bh = rbm_userData bh + +getWriterUserData :: WriteBinHandle -> WriterUserData +getWriterUserData bh = wbm_userData bh + +setWriterUserData :: WriteBinHandle -> WriterUserData -> WriteBinHandle +setWriterUserData bh us = bh { wbm_userData = us } + +setReaderUserData :: ReadBinHandle -> ReaderUserData -> ReadBinHandle +setReaderUserData bh us = bh { rbm_userData = us } + +-- | Add 'SomeBinaryReader' as a known binary decoder. +-- If a 'BinaryReader' for the associated type already exists in 'ReaderUserData', +-- it is overwritten. +addReaderToUserData :: forall a. Typeable a => BinaryReader a -> ReadBinHandle -> ReadBinHandle +addReaderToUserData reader bh = bh + { rbm_userData = (rbm_userData bh) + { ud_reader_data = + let + typRep = Refl.typeRep @a + in + Map.insert (SomeTypeRep typRep) (SomeBinaryReader typRep reader) (ud_reader_data (rbm_userData bh)) + } + } + +-- | Add 'SomeBinaryWriter' as a known binary encoder. +-- If a 'BinaryWriter' for the associated type already exists in 'WriterUserData', +-- it is overwritten. +addWriterToUserData :: forall a . Typeable a => BinaryWriter a -> WriteBinHandle -> WriteBinHandle +addWriterToUserData writer bh = bh + { wbm_userData = (wbm_userData bh) + { ud_writer_data = + let + typRep = Refl.typeRep @a + in + Map.insert (SomeTypeRep typRep) (SomeBinaryWriter typRep writer) (ud_writer_data (wbm_userData bh)) + } + } + +-- | Get access to the underlying buffer. +withBinBuffer :: WriteBinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (WriteBinMem _ ix_r _ arr_r) action = do + ix <- readFastMutInt ix_r + arr <- readIORef arr_r + action $ BS.fromForeignPtr arr 0 ix + +unsafeUnpackBinBuffer :: ByteString -> IO ReadBinHandle +unsafeUnpackBinBuffer (BS.BS arr len) = do + ix_r <- newFastMutInt 0 + return (ReadBinMem noReaderUserData ix_r len arr) + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +-- | Like a 'Bin' but is used to store relative offset pointers. +-- Relative offset pointers store a relative location, but also contain an +-- anchor that allow to obtain the absolute offset. +data RelBin a = RelBin + { relBin_anchor :: {-# UNPACK #-} !(Bin a) + -- ^ Absolute position from where we read 'relBin_offset'. + , relBin_offset :: {-# UNPACK #-} !(RelBinPtr a) + -- ^ Relative offset to 'relBin_anchor'. + -- The absolute position of the 'RelBin' is @relBin_anchor + relBin_offset@ + } + deriving (Eq, Ord, Show, Bounded) + +-- | A 'RelBinPtr' is like a 'Bin', but contains a relative offset pointer +-- instead of an absolute offset. +newtype RelBinPtr a = RelBinPtr (Bin a) + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +-- | Read a relative offset location and wrap it in 'RelBin'. +-- +-- The resulting 'RelBin' can be translated into an absolute offset location using +-- 'makeAbsoluteBin' +getRelBin :: ReadBinHandle -> IO (RelBin a) +getRelBin bh = do + start <- tellBinReader bh + off <- get bh + pure $ RelBin start off + +makeAbsoluteBin :: RelBin a -> Bin a +makeAbsoluteBin (RelBin (BinPtr !start) (RelBinPtr (BinPtr !offset))) = + BinPtr $ start + offset + +makeRelativeBin :: RelBin a -> RelBinPtr a +makeRelativeBin (RelBin _ offset) = offset + +toRelBin :: Bin (RelBinPtr a) -> Bin a -> RelBin a +toRelBin (BinPtr !start) (BinPtr !goal) = + RelBin (BinPtr start) (RelBinPtr $ BinPtr $ goal - start) + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +-- | Do not rely on instance sizes for general types, +-- we use variable length encoding for many of them. +class Binary a where + put_ :: WriteBinHandle -> a -> IO () + put :: WriteBinHandle -> a -> IO (Bin a) + get :: ReadBinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBinWriter bh; put_ bh a; return p + +putAt :: Binary a => WriteBinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBinWriter bh p; put_ bh x; return () + +putAtRel :: WriteBinHandle -> Bin (RelBinPtr a) -> Bin a -> IO () +putAtRel bh from to = putAt bh from (makeRelativeBin $ toRelBin from to) + +getAt :: Binary a => ReadBinHandle -> Bin a -> IO a +getAt bh p = do seekBinReader bh p; get bh + +openBinMem :: Int -> IO WriteBinHandle +openBinMem size + | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt 0 + sz_r <- newFastMutInt size + return WriteBinMem + { wbm_userData = noWriterUserData + , wbm_off_r = ix_r + , wbm_sz_r = sz_r + , wbm_arr_r = arr_r + } + +-- | Freeze the given 'WriteBinHandle' and turn it into an equivalent 'ReadBinHandle'. +-- +-- The current offset of the 'WriteBinHandle' is maintained in the new 'ReadBinHandle'. +freezeWriteHandle :: WriteBinHandle -> IO ReadBinHandle +freezeWriteHandle wbm = do + rbm_off_r <- newFastMutInt =<< readFastMutInt (wbm_off_r wbm) + rbm_sz_r <- readFastMutInt (wbm_sz_r wbm) + rbm_arr_r <- readIORef (wbm_arr_r wbm) + pure $ ReadBinMem + { rbm_userData = noReaderUserData + , rbm_off_r = rbm_off_r + , rbm_sz_r = rbm_sz_r + , rbm_arr_r = rbm_arr_r + } + +-- | Copy the BinBuffer to a new BinBuffer which is exactly the right size. +-- This performs a copy of the underlying buffer. +-- The buffer may be truncated if the offset is not at the end of the written +-- output. +-- +-- UserData is also discarded during the copy +-- You should just use this when translating a Put handle into a Get handle. +shrinkBinBuffer :: WriteBinHandle -> IO ReadBinHandle +shrinkBinBuffer bh = withBinBuffer bh $ \bs -> do + unsafeUnpackBinBuffer (copy bs) + +thawReadHandle :: ReadBinHandle -> IO WriteBinHandle +thawReadHandle rbm = do + wbm_off_r <- newFastMutInt =<< readFastMutInt (rbm_off_r rbm) + wbm_sz_r <- newFastMutInt (rbm_sz_r rbm) + wbm_arr_r <- newIORef (rbm_arr_r rbm) + pure $ WriteBinMem + { wbm_userData = noWriterUserData + , wbm_off_r = wbm_off_r + , wbm_sz_r = wbm_sz_r + , wbm_arr_r = wbm_arr_r + } + +tellBinWriter :: WriteBinHandle -> IO (Bin a) +tellBinWriter (WriteBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +tellBinReader :: ReadBinHandle -> IO (Bin a) +tellBinReader (ReadBinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBinWriter :: WriteBinHandle -> Bin a -> IO () +seekBinWriter h@(WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p > sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +-- | 'seekBinNoExpandWriter' moves the index pointer to the location pointed to +-- by 'Bin a'. +-- This operation may 'panic', if the pointer location is out of bounds of the +-- buffer of 'BinHandle'. +seekBinNoExpandWriter :: WriteBinHandle -> Bin a -> IO () +seekBinNoExpandWriter (WriteBinMem _ ix_r sz_r _) (BinPtr !p) = do + sz <- readFastMutInt sz_r + if (p > sz) + then panic "seekBinNoExpandWriter: seek out of range" + else writeFastMutInt ix_r p + +-- | SeekBin but without calling expandBin +seekBinReader :: ReadBinHandle -> Bin a -> IO () +seekBinReader (ReadBinMem _ ix_r sz_r _) (BinPtr !p) = do + if (p > sz_r) + then panic "seekBinReader: seek out of range" + else writeFastMutInt ix_r p + +seekBinReaderRel :: ReadBinHandle -> RelBin a -> IO () +seekBinReaderRel (ReadBinMem _ ix_r sz_r _) relBin = do + let (BinPtr !p) = makeAbsoluteBin relBin + if (p > sz_r) + then panic "seekBinReaderRel: seek out of range" + else writeFastMutInt ix_r p + +writeBinMem :: WriteBinHandle -> FilePath -> IO () +writeBinMem (WriteBinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO ReadBinHandle +readBinMem filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + readBinMem_ filesize h + +readBinMemN :: Int -> FilePath -> IO (Maybe ReadBinHandle) +readBinMemN size filename = do + withBinaryFile filename ReadMode $ \h -> do + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + if filesize < size + then pure Nothing + else Just <$> readBinMem_ size h + +readBinMem_ :: Int -> Handle -> IO ReadBinHandle +readBinMem_ filesize h = do + arr <- mallocForeignPtrBytes filesize + count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + ix_r <- newFastMutInt 0 + return ReadBinMem + { rbm_userData = noReaderUserData + , rbm_off_r = ix_r + , rbm_sz_r = filesize + , rbm_arr_r = arr + } + +-- expand the size of the array to include a specified offset +expandBin :: WriteBinHandle -> Int -> IO () +expandBin (WriteBinMem _ _ sz_r arr_r) !off = do + !sz <- readFastMutInt sz_r + let !sz' = getSize sz + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + where + getSize :: Int -> Int + getSize !sz + | sz > off + = sz + | otherwise + = getSize (sz * 2) + +foldGet + :: Binary a + => Word -- n elements + -> ReadBinHandle + -> b -- initial accumulator + -> (Word -> a -> b -> IO b) + -> IO b +foldGet n bh init_b f = go 0 init_b + where + go i b + | i == n = return b + | otherwise = do + a <- get bh + b' <- f i a b + go (i+1) b' + +foldGet' + :: Binary a + => Word -- n elements + -> ReadBinHandle + -> b -- initial accumulator + -> (Word -> a -> b -> IO b) + -> IO b +{-# INLINE foldGet' #-} +foldGet' n bh init_b f = go 0 init_b + where + go i !b + | i == n = return b + | otherwise = do + !a <- get bh + b' <- f i a b + go (i+1) b' + + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +-- | Takes a size and action writing up to @size@ bytes. +-- After the action has run advance the index to the buffer +-- by size bytes. +putPrim :: WriteBinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () +putPrim h@(WriteBinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + expandBin h (ix + size) + arr <- readIORef arr_r + unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + +-- -- | Similar to putPrim but advances the index by the actual number of +-- -- bytes written. +-- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () +-- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do +-- ix <- readFastMutInt ix_r +-- sz <- readFastMutInt sz_r +-- when (ix + size > sz) $ +-- expandBin h (ix + size) +-- arr <- readIORef arr_r +-- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) +-- writeFastMutInt ix_r (ix + written) + +getPrim :: ReadBinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a +getPrim (ReadBinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + when (ix + size > sz_r) $ + ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) + w <- unsafeWithForeignPtr arr_r $ \p -> f (p `plusPtr` ix) + -- This is safe WRT #17760 as we we guarantee that the above line doesn't + -- diverge + writeFastMutInt ix_r (ix + size) + return w + +putWord8 :: WriteBinHandle -> Word8 -> IO () +putWord8 h !w = putPrim h 1 (\op -> poke op w) + +getWord8 :: ReadBinHandle -> IO Word8 +getWord8 h = getPrim h 1 peek + +putWord16 :: WriteBinHandle -> Word16 -> IO () +putWord16 h w = putPrim h 2 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) + pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) + ) + +getWord16 :: ReadBinHandle -> IO Word16 +getWord16 h = getPrim h 2 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + return $! w0 `shiftL` 8 .|. w1 + ) + +putWord32 :: WriteBinHandle -> Word32 -> IO () +putWord32 h w = putPrim h 4 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) + ) + +getWord32 :: ReadBinHandle -> IO Word32 +getWord32 h = getPrim h 4 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + + return $! (w0 `shiftL` 24) .|. + (w1 `shiftL` 16) .|. + (w2 `shiftL` 8) .|. + w3 + ) + +putWord64 :: WriteBinHandle -> Word64 -> IO () +putWord64 h w = putPrim h 8 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) + pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) + pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) + ) + +getWord64 :: ReadBinHandle -> IO Word64 +getWord64 h = getPrim h 8 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + w4 <- fromIntegral <$> peekElemOff op 4 + w5 <- fromIntegral <$> peekElemOff op 5 + w6 <- fromIntegral <$> peekElemOff op 6 + w7 <- fromIntegral <$> peekElemOff op 7 + + return $! (w0 `shiftL` 56) .|. + (w1 `shiftL` 48) .|. + (w2 `shiftL` 40) .|. + (w3 `shiftL` 32) .|. + (w4 `shiftL` 24) .|. + (w5 `shiftL` 16) .|. + (w6 `shiftL` 8) .|. + w7 + ) + +putByte :: WriteBinHandle -> Word8 -> IO () +putByte bh !w = putWord8 bh w + +getByte :: ReadBinHandle -> IO Word8 +getByte h = getWord8 h + +-- ----------------------------------------------------------------------------- +-- Encode numbers in LEB128 encoding. +-- Requires one byte of space per 7 bits of data. +-- +-- There are signed and unsigned variants. +-- Do NOT use the unsigned one for signed values, at worst it will +-- result in wrong results, at best it will lead to bad performance +-- when coercing negative values to an unsigned type. +-- +-- We mark them as SPECIALIZE as it's extremely critical that they get specialized +-- to their specific types. +-- +-- TODO: Each use of putByte performs a bounds check, +-- we should use putPrimMax here. However it's quite hard to return +-- the number of bytes written into putPrimMax without allocating an +-- Int for it, while the code below does not allocate at all. +-- So we eat the cost of the bounds check instead of increasing allocations +-- for now. + +-- Unsigned numbers +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putULEB128 :: WriteBinHandle -> Int16 -> IO () #-} +putULEB128 :: forall a. (Integral a, FiniteBits a) => WriteBinHandle -> a -> IO () +putULEB128 bh w = +#if defined(DEBUG) + (if w < 0 then panic "putULEB128: Signed number" else id) $ +#endif + go w + where + go :: a -> IO () + go w + | w <= (127 :: a) + = putByte bh (fromIntegral w :: Word8) + | otherwise = do + -- bit 7 (8th bit) indicates more to come. + let !byte = setBit (fromIntegral w) 7 :: Word8 + putByte bh byte + go (w `unsafeShiftR` 7) + +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word64 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word32 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Word16 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int64 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int32 #-} +{-# SPECIALISE getULEB128 :: ReadBinHandle -> IO Int16 #-} +getULEB128 :: forall a. (Integral a, FiniteBits a) => ReadBinHandle -> IO a +getULEB128 bh = + go 0 0 + where + go :: Int -> a -> IO a + go shift w = do + b <- getByte bh + let !hasMore = testBit b 7 + let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a + if hasMore + then do + go (shift+7) val + else + return $! val + +-- Signed numbers +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Word16 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int64 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int32 -> IO () #-} +{-# SPECIALISE putSLEB128 :: WriteBinHandle -> Int16 -> IO () #-} +putSLEB128 :: forall a. (Integral a, Bits a) => WriteBinHandle -> a -> IO () +putSLEB128 bh initial = go initial + where + go :: a -> IO () + go val = do + let !byte = fromIntegral (clearBit val 7) :: Word8 + let !val' = val `unsafeShiftR` 7 + let !signBit = testBit byte 6 + let !done = + -- Unsigned value, val' == 0 and last value can + -- be discriminated from a negative number. + ((val' == 0 && not signBit) || + -- Signed value, + (val' == -1 && signBit)) + + let !byte' = if done then byte else setBit byte 7 + putByte bh byte' + + unless done $ go val' + +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word64 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word32 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Word16 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int64 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int32 #-} +{-# SPECIALISE getSLEB128 :: ReadBinHandle -> IO Int16 #-} +getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => ReadBinHandle -> IO a +getSLEB128 bh = do + (val,shift,signed) <- go 0 0 + if signed && (shift < finiteBitSize val ) + then return $! ((complement 0 `unsafeShiftL` shift) .|. val) + else return val + where + go :: Int -> a -> IO (a,Int,Bool) + go shift val = do + byte <- getByte bh + let !byteVal = fromIntegral (clearBit byte 7) :: a + let !val' = val .|. (byteVal `unsafeShiftL` shift) + let !more = testBit byte 7 + let !shift' = shift+7 + if more + then go (shift') val' + else do + let !signed = testBit byte 6 + return (val',shift',signed) + +-- ----------------------------------------------------------------------------- +-- Fixed length encoding instances + +-- Sometimes words are used to represent a certain bit pattern instead +-- of a number. Using FixedLengthEncoding we will write the pattern as +-- is to the interface file without the variable length encoding we usually +-- apply. + +-- | Encode the argument in its full length. This is different from many default +-- binary instances which make no guarantee about the actual encoding and +-- might do things using variable length encoding. +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) + +instance Binary (FixedLengthEncoding Word8) where + put_ h (FixedLengthEncoding x) = putByte h x + get h = FixedLengthEncoding <$> getByte h + +instance Binary (FixedLengthEncoding Word16) where + put_ h (FixedLengthEncoding x) = putWord16 h x + get h = FixedLengthEncoding <$> getWord16 h + +instance Binary (FixedLengthEncoding Word32) where + put_ h (FixedLengthEncoding x) = putWord32 h x + get h = FixedLengthEncoding <$> getWord32 h + +instance Binary (FixedLengthEncoding Word64) where + put_ h (FixedLengthEncoding x) = putWord64 h x + get h = FixedLengthEncoding <$> getWord64 h + +-- ----------------------------------------------------------------------------- +-- Primitive Word writes + +instance Binary Word8 where + put_ bh !w = putWord8 bh w + get = getWord8 + +instance Binary Word16 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word32 where + put_ = putULEB128 + get = getULEB128 + +instance Binary Word64 where + put_ = putULEB128 + get = getULEB128 + +-- ----------------------------------------------------------------------------- +-- Primitive Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int32 where + put_ = putSLEB128 + get = getSLEB128 + +instance Binary Int64 where + put_ h w = putSLEB128 h w + get h = getSLEB128 h + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + put_ bh len + mapM_ (put_ bh) l + get bh = do + len <- get bh :: IO Int -- Int is variable length encoded so only + -- one byte for small lists. + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +-- | This instance doesn't rely on the determinism of the keys' 'Ord' instance, +-- so it works e.g. for 'Name's too. +instance (Binary a, Ord a) => Binary (Set a) where + put_ bh s = put_ bh (Set.toAscList s) + get bh = Set.fromAscList <$> get bh + +instance Binary a => Binary (NonEmpty a) where + put_ bh = put_ bh . NonEmpty.toList + get bh = NonEmpty.fromList <$> get bh + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + put_ bh arr = do + put_ bh $ bounds arr + put_ bh $ elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ listArray bounds xs + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where + put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + g <- get bh + return (a,b,c,d,e,f,g) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance Binary a => Binary (Strict.Maybe a) where + put_ bh Strict.Nothing = putByte bh 0 + put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a + get bh = + do h <- getWord8 bh + case h of + 0 -> return Strict.Nothing + _ -> do x <- get bh; return (Strict.Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + +instance Binary JoinPointHood where + put_ bh NotJoinPoint = putByte bh 0 + put_ bh (JoinPoint ar) = do + putByte bh 1 + put_ bh ar + get bh = do + h <- getByte bh + case h of + 0 -> return NotJoinPoint + _ -> do { ar <- get bh; return (JoinPoint ar) } + +newtype EnumBinary a = EnumBinary { unEnumBinary :: a } +instance Enum a => Binary (EnumBinary a) where + put_ bh (EnumBinary x) = put_ bh (fromEnum x) + get bh = do x <- get bh + return $ EnumBinary (toEnum x) + + +instance Binary IsBootInterface where + put_ bh ib = put_ bh (case ib of + IsBoot -> True + NotBoot -> False) + get bh = do x <- get bh + return $ case x of + True -> IsBoot + False -> NotBoot + +{- +Finally - a reasonable portable Integer instance. + +We used to encode values in the Int32 range as such, +falling back to a string of all things. In either case +we stored a tag byte to discriminate between the two cases. + +This made some sense as it's highly portable but also not very +efficient. + +However GHC stores a surprisingly large number of large Integer +values. In the examples looked at between 25% and 50% of Integers +serialized were outside of the Int32 range. + +Consider a value like `2724268014499746065`, some sort of hash +actually generated by GHC. +In the old scheme this was encoded as a list of 19 chars. This +gave a size of 77 Bytes, one for the length of the list and 76 +since we encode chars as Word32 as well. + +We can easily do better. The new plan is: + +* Start with a tag byte + * 0 => Int64 (LEB128 encoded) + * 1 => Negative large integer + * 2 => Positive large integer +* Followed by the value: + * Int64 is encoded as usual + * Large integers are encoded as a list of bytes (Word8). + We use Data.Bits which defines a bit order independent of the representation. + Values are stored LSB first. + +This means our example value `2724268014499746065` is now only 10 bytes large. +* One byte tag +* One byte for the length of the [Word8] list. +* 8 bytes for the actual date. + +The new scheme also does not depend in any way on +architecture specific details. + +We still use this scheme even with LEB128 available, +as it has less overhead for truly large numbers. (> maxBound :: Int64) + +The instance is used for in Binary Integer and Binary Rational in GHC.Types.Literal +-} + +instance Binary Integer where + put_ bh i + | i >= lo64 && i <= hi64 = do + putWord8 bh 0 + put_ bh (fromIntegral i :: Int64) + | otherwise = do + if i < 0 + then putWord8 bh 1 + else putWord8 bh 2 + put_ bh (unroll $ abs i) + where + lo64 = fromIntegral (minBound :: Int64) + hi64 = fromIntegral (maxBound :: Int64) + get bh = do + int_kind <- getWord8 bh + case int_kind of + 0 -> fromIntegral <$!> (get bh :: IO Int64) + -- Large integer + 1 -> negate <$!> getInt + 2 -> getInt + _ -> panic "Binary Integer - Invalid byte" + where + getInt :: IO Integer + getInt = roll <$!> (get bh :: IO [Word8]) + +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldl' unstep 0 . reverse + where + unstep a b = a `shiftL` 8 .|. fromIntegral b + + + {- + -- This code is currently commented out. + -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for + -- discussion. + + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + -} + +{- +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +-} +instance (Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (Bin a) where + put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) + get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) + +-- Instance uses fixed-width encoding to allow inserting +-- Bin placeholders in the stream. +instance Binary (RelBinPtr a) where + put_ bh (RelBinPtr i) = put_ bh i + get bh = RelBinPtr <$> get bh + +-- ----------------------------------------------------------------------------- +-- Forward reading/writing + +-- | @'forwardPut' put_A put_B@ outputs A after B but allows A to be read before B +-- by using a forward reference. +forwardPut :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPut bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBinWriter bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBinWriter bh + putAt bh pre_a a + seekBinNoExpandWriter bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +forwardPut_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO () +forwardPut_ bh put_A put_B = void $ forwardPut bh put_A put_B + +-- | Read a value stored using a forward reference +-- +-- The forward reference is expected to be an absolute offset. +forwardGet :: ReadBinHandle -> IO a -> IO a +forwardGet bh get_A = do + -- read forward reference + p <- get bh -- a BinPtr + -- store current position + p_a <- tellBinReader bh + -- go read the forward value, then seek back + seekBinReader bh p + r <- get_A + seekBinReader bh p_a + pure r + +-- | @'forwardPutRel' put_A put_B@ outputs A after B but allows A to be read before B +-- by using a forward reference. +-- +-- This forward reference is a relative offset that allows us to skip over the +-- result of 'put_A'. +forwardPutRel :: WriteBinHandle -> (b -> IO a) -> IO b -> IO (a,b) +forwardPutRel bh put_A put_B = do + -- write placeholder pointer to A + pre_a <- tellBinWriter bh + put_ bh pre_a + + -- write B + r_b <- put_B + + -- update A's pointer + a <- tellBinWriter bh + putAtRel bh pre_a a + seekBinNoExpandWriter bh a + + -- write A + r_a <- put_A r_b + pure (r_a,r_b) + +-- | Like 'forwardGetRel', but discard the result. +forwardPutRel_ :: WriteBinHandle -> (b -> IO a) -> IO b -> IO () +forwardPutRel_ bh put_A put_B = void $ forwardPutRel bh put_A put_B + +-- | Read a value stored using a forward reference. +-- +-- The forward reference is expected to be a relative offset. +forwardGetRel :: ReadBinHandle -> IO a -> IO a +forwardGetRel bh get_A = do + -- read forward reference + p <- getRelBin bh + -- store current position + p_a <- tellBinReader bh + -- go read the forward value, then seek back + seekBinReader bh $ makeAbsoluteBin p + r <- get_A + seekBinReader bh p_a + pure r + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => WriteBinHandle -> a -> IO () +lazyPut = lazyPut' put_ + +lazyGet :: Binary a => ReadBinHandle -> IO a +lazyGet = lazyGet' get + +lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO () +lazyPut' f bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBinWriter bh + put_ bh pre_a -- save a slot for the ptr + f bh a -- dump the object + q <- tellBinWriter bh -- q = ptr to after object + putAtRel bh pre_a q -- fill in slot before a with ptr to q + seekBinWriter bh q -- finally carry on writing at q + +lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a +lazyGet' f bh = do + p <- getRelBin bh -- a BinPtr + p_a <- tellBinReader bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh rbm_off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt 0 + let bh' = bh { rbm_off_r = off_r } + seekBinReader bh' p_a + f bh' + seekBinReader bh (makeAbsoluteBin p) -- skip over the object for now + return a + +-- | Serialize the constructor strictly but lazily serialize a value inside a +-- 'Just'. +-- +-- This way we can check for the presence of a value without deserializing the +-- value itself. +lazyPutMaybe :: Binary a => WriteBinHandle -> Maybe a -> IO () +lazyPutMaybe bh Nothing = putWord8 bh 0 +lazyPutMaybe bh (Just x) = do + putWord8 bh 1 + lazyPut bh x + +-- | Deserialize a value serialized by 'lazyPutMaybe'. +lazyGetMaybe :: Binary a => ReadBinHandle -> IO (Maybe a) +lazyGetMaybe bh = do + h <- getWord8 bh + case h of + 0 -> pure Nothing + _ -> Just <$> lazyGet bh + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +-- Note [Binary UserData] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in "GHC.Iface.Binary"). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- + +-- | Newtype to serialise binding names differently to non-binding 'Name'. +-- See Note [Binary UserData] +newtype BindingName = BindingName { getBindingName :: Name } + deriving ( Eq ) + +simpleBindingNameWriter :: BinaryWriter Name -> BinaryWriter BindingName +simpleBindingNameWriter = coerce + +simpleBindingNameReader :: BinaryReader Name -> BinaryReader BindingName +simpleBindingNameReader = coerce + +-- | Existential for 'BinaryWriter' with a type witness. +data SomeBinaryWriter = forall a . SomeBinaryWriter (Refl.TypeRep a) (BinaryWriter a) + +-- | Existential for 'BinaryReader' with a type witness. +data SomeBinaryReader = forall a . SomeBinaryReader (Refl.TypeRep a) (BinaryReader a) + +-- | UserData required to serialise symbols for interface files. +-- +-- See Note [Binary UserData] +data WriterUserData = + WriterUserData { + ud_writer_data :: Map SomeTypeRep SomeBinaryWriter + -- ^ A mapping from a type witness to the 'Writer' for the associated type. + -- This is a 'Map' because microbenchmarks indicated this is more efficient + -- than other representations for less than ten elements. + -- + -- Considered representations: + -- + -- * [(TypeRep, SomeBinaryWriter)] + -- * bytehash (on hackage) + -- * Map TypeRep SomeBinaryWriter + } + +-- | UserData required to deserialise symbols for interface files. +-- +-- See Note [Binary UserData] +data ReaderUserData = + ReaderUserData { + ud_reader_data :: Map SomeTypeRep SomeBinaryReader + -- ^ A mapping from a type witness to the 'Reader' for the associated type. + -- This is a 'Map' because microbenchmarks indicated this is more efficient + -- than other representations for less than ten elements. + -- + -- Considered representations: + -- + -- * [(TypeRep, SomeBinaryReader)] + -- * bytehash (on hackage) + -- * Map TypeRep SomeBinaryReader + } + +mkWriterUserData :: [SomeBinaryWriter] -> WriterUserData +mkWriterUserData caches = noWriterUserData + { ud_writer_data = Map.fromList $ map (\cache@(SomeBinaryWriter typRep _) -> (SomeTypeRep typRep, cache)) caches + } + +mkReaderUserData :: [SomeBinaryReader] -> ReaderUserData +mkReaderUserData caches = noReaderUserData + { ud_reader_data = Map.fromList $ map (\cache@(SomeBinaryReader typRep _) -> (SomeTypeRep typRep, cache)) caches + } + +mkSomeBinaryWriter :: forall a . Refl.Typeable a => BinaryWriter a -> SomeBinaryWriter +mkSomeBinaryWriter cb = SomeBinaryWriter (Refl.typeRep @a) cb + +mkSomeBinaryReader :: forall a . Refl.Typeable a => BinaryReader a -> SomeBinaryReader +mkSomeBinaryReader cb = SomeBinaryReader (Refl.typeRep @a) cb + +newtype BinaryReader s = BinaryReader + { getEntry :: ReadBinHandle -> IO s + } deriving (Functor) + +newtype BinaryWriter s = BinaryWriter + { putEntry :: WriteBinHandle -> s -> IO () + } + +mkWriter :: (WriteBinHandle -> s -> IO ()) -> BinaryWriter s +mkWriter f = BinaryWriter + { putEntry = f + } + +mkReader :: (ReadBinHandle -> IO s) -> BinaryReader s +mkReader f = BinaryReader + { getEntry = f + } + +-- | Find the 'BinaryReader' for the 'Binary' instance for the type identified by 'Proxy a'. +-- +-- If no 'BinaryReader' has been configured before, this function will panic. +findUserDataReader :: forall a . Refl.Typeable a => Proxy a -> ReadBinHandle -> BinaryReader a +findUserDataReader query bh = + case Map.lookup (Refl.someTypeRep query) (ud_reader_data $ getReaderUserData bh) of + Nothing -> panic $ "Failed to find BinaryReader for the key: " ++ show (Refl.someTypeRep query) + Just (SomeBinaryReader _ (reader :: BinaryReader x)) -> + unsafeCoerce @(BinaryReader x) @(BinaryReader a) reader + -- This 'unsafeCoerce' could be written safely like this: + -- + -- @ + -- Just (SomeBinaryReader _ (reader :: BinaryReader x)) -> + -- case testEquality (typeRep @a) tyRep of + -- Just Refl -> coerce @(BinaryReader x) @(BinaryReader a) reader + -- Nothing -> panic $ "Invariant violated" + -- @ + -- + -- But it comes at a slight performance cost and this function is used in + -- binary serialisation hot loops, thus, we prefer the small performance boost over + -- the additional type safety. + +-- | Find the 'BinaryWriter' for the 'Binary' instance for the type identified by 'Proxy a'. +-- +-- If no 'BinaryWriter' has been configured before, this function will panic. +findUserDataWriter :: forall a . Refl.Typeable a => Proxy a -> WriteBinHandle -> BinaryWriter a +findUserDataWriter query bh = + case Map.lookup (Refl.someTypeRep query) (ud_writer_data $ getWriterUserData bh) of + Nothing -> panic $ "Failed to find BinaryWriter for the key: " ++ show (Refl.someTypeRep query) + Just (SomeBinaryWriter _ (writer :: BinaryWriter x)) -> + unsafeCoerce @(BinaryWriter x) @(BinaryWriter a) writer + -- This 'unsafeCoerce' could be written safely like this: + -- + -- @ + -- Just (SomeBinaryWriter tyRep (writer :: BinaryWriter x)) -> + -- case testEquality (typeRep @a) tyRep of + -- Just Refl -> coerce @(BinaryWriter x) @(BinaryWriter a) writer + -- Nothing -> panic $ "Invariant violated" + -- @ + -- + -- But it comes at a slight performance cost and this function is used in + -- binary serialisation hot loops, thus, we prefer the small performance boost over + -- the additional type safety. + + +noReaderUserData :: ReaderUserData +noReaderUserData = ReaderUserData + { ud_reader_data = Map.empty + } + +noWriterUserData :: WriterUserData +noWriterUserData = WriterUserData + { ud_writer_data = Map.empty + } + +newReadState :: (ReadBinHandle -> IO Name) -- ^ how to deserialize 'Name's + -> (ReadBinHandle -> IO FastString) + -> ReaderUserData +newReadState get_name get_fs = + mkReaderUserData + [ mkSomeBinaryReader $ mkReader get_name + , mkSomeBinaryReader $ mkReader @BindingName (coerce get_name) + , mkSomeBinaryReader $ mkReader get_fs + ] + +newWriteState :: (WriteBinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (WriteBinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's + -> (WriteBinHandle -> FastString -> IO ()) + -> WriterUserData +newWriteState put_non_binding_name put_binding_name put_fs = + mkWriterUserData + [ mkSomeBinaryWriter $ mkWriter (\bh name -> put_binding_name bh (getBindingName name)) + , mkSomeBinaryWriter $ mkWriter put_non_binding_name + , mkSomeBinaryWriter $ mkWriter put_fs + ] + +-- ---------------------------------------------------------------------------- +-- Types for lookup and deduplication tables. +-- ---------------------------------------------------------------------------- + +-- | A 'ReaderTable' describes how to deserialise a table from disk, +-- and how to create a 'BinaryReader' that looks up values in the deduplication table. +data ReaderTable a = ReaderTable + { getTable :: ReadBinHandle -> IO (SymbolTable a) + -- ^ Deserialise a list of elements into a 'SymbolTable'. + , mkReaderFromTable :: SymbolTable a -> BinaryReader a + -- ^ Given the table from 'getTable', create a 'BinaryReader' + -- that reads values only from the 'SymbolTable'. + } + +-- | A 'WriterTable' is an interface any deduplication table can implement to +-- describe how the table can be written to disk. +newtype WriterTable = WriterTable + { putTable :: WriteBinHandle -> IO Int + -- ^ Serialise a table to disk. Returns the number of written elements. + } + +-- ---------------------------------------------------------------------------- +-- Common data structures for constructing and maintaining lookup tables for +-- binary serialisation and deserialisation. +-- ---------------------------------------------------------------------------- + +-- | The 'GenericSymbolTable' stores a mapping from already seen elements to an index. +-- If an element wasn't seen before, it is added to the mapping together with a fresh +-- index. +-- +-- 'GenericSymbolTable' is a variant of a 'BinSymbolTable' that is polymorphic in the table implementation. +-- As such it can be used with any container that implements the 'TrieMap' type class. +-- +-- While 'GenericSymbolTable' is similar to the 'BinSymbolTable', it supports storing tree-like +-- structures such as 'Type' and 'IfaceType' more efficiently. +-- +data GenericSymbolTable m = GenericSymbolTable + { gen_symtab_next :: !FastMutInt + -- ^ The next index to use. + , gen_symtab_map :: !(IORef (m Int)) + -- ^ Given a symbol, find the symbol and return its index. + , gen_symtab_to_write :: !(IORef [Key m]) + -- ^ Reversed list of values to write into the buffer. + -- This is an optimisation, as it allows us to write out quickly all + -- newly discovered values that are discovered when serialising 'Key m' + -- to disk. + } + +-- | Initialise a 'GenericSymbolTable', initialising the index to '0'. +initGenericSymbolTable :: TrieMap m => IO (GenericSymbolTable m) +initGenericSymbolTable = do + symtab_next <- newFastMutInt 0 + symtab_map <- newIORef emptyTM + symtab_todo <- newIORef [] + pure $ GenericSymbolTable + { gen_symtab_next = symtab_next + , gen_symtab_map = symtab_map + , gen_symtab_to_write = symtab_todo + } + +-- | Serialise the 'GenericSymbolTable' to disk. +-- +-- Since 'GenericSymbolTable' stores tree-like structures, such as 'IfaceType', +-- serialising an element can add new elements to the mapping. +-- Thus, 'putGenericSymbolTable' first serialises all values, and then checks whether any +-- new elements have been discovered. If so, repeat the loop. +putGenericSymbolTable :: forall m. (TrieMap m) => GenericSymbolTable m -> (WriteBinHandle -> Key m -> IO ()) -> WriteBinHandle -> IO Int +{-# INLINE putGenericSymbolTable #-} +putGenericSymbolTable gen_sym_tab serialiser bh = do + putGenericSymbolTable bh + where + symtab_next = gen_symtab_next gen_sym_tab + symtab_to_write = gen_symtab_to_write gen_sym_tab + putGenericSymbolTable :: WriteBinHandle -> IO Int + putGenericSymbolTable bh = do + let loop = do + vs <- atomicModifyIORef' symtab_to_write (\a -> ([], a)) + case vs of + [] -> readFastMutInt symtab_next + todo -> do + mapM_ (\n -> serialiser bh n) (reverse todo) + loop + snd <$> + (forwardPutRel bh (const $ readFastMutInt symtab_next >>= put_ bh) $ + loop) + +-- | Read the elements of a 'GenericSymbolTable' from disk into a 'SymbolTable'. +getGenericSymbolTable :: forall a . (ReadBinHandle -> IO a) -> ReadBinHandle -> IO (SymbolTable a) +getGenericSymbolTable deserialiser bh = do + sz <- forwardGetRel bh (get bh) :: IO Int + mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int a) + forM_ [0..(sz-1)] $ \i -> do + f <- deserialiser bh + writeArray mut_arr i f + unsafeFreeze mut_arr + +-- | Write an element 'Key m' to the given 'WriteBinHandle'. +-- +-- If the element was seen before, we simply write the index of that element to the +-- 'WriteBinHandle'. If we haven't seen it before, we add the element to +-- the 'GenericSymbolTable', increment the index, and return this new index. +putGenericSymTab :: (TrieMap m) => GenericSymbolTable m -> WriteBinHandle -> Key m -> IO () +{-# INLINE putGenericSymTab #-} +putGenericSymTab GenericSymbolTable{ + gen_symtab_map = symtab_map_ref, + gen_symtab_next = symtab_next, + gen_symtab_to_write = symtab_todo } + bh val = do + symtab_map <- readIORef symtab_map_ref + case lookupTM val symtab_map of + Just off -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! insertTM val off symtab_map + atomicModifyIORef symtab_todo (\todo -> (val : todo, ())) + put_ bh (fromIntegral off :: Word32) + +-- | Read a value from a 'SymbolTable'. +getGenericSymtab :: Binary a => SymbolTable a -> ReadBinHandle -> IO a +getGenericSymtab symtab bh = do + i :: Word32 <- get bh + return $! symtab ! fromIntegral i + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +-- | A 'SymbolTable' of 'FastString's. +type Dictionary = SymbolTable FastString + +initFastStringReaderTable :: IO (ReaderTable FastString) +initFastStringReaderTable = do + return $ + ReaderTable + { getTable = getDictionary + , mkReaderFromTable = \tbl -> mkReader (getDictFastString tbl) + } + +initFastStringWriterTable :: IO (WriterTable, BinaryWriter FastString) +initFastStringWriterTable = do + dict_next_ref <- newFastMutInt 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = + FSTable + { fs_tab_next = dict_next_ref + , fs_tab_map = dict_map_ref + } + let put_dict bh = do + fs_count <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh fs_count dict_map + pure fs_count + + return + ( WriterTable + { putTable = put_dict + } + , mkWriter $ putDictFastString bin_dict + ) + +putDictionary :: WriteBinHandle -> Int -> UniqFM FastString (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) + -- It's OK to use nonDetEltsUFM here because the elements have indices + -- that array uses to create order + +getDictionary :: ReadBinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh :: IO Int + mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString) + forM_ [0..(sz-1)] $ \i -> do + fs <- getFS bh + writeArray mut_arr i fs + unsafeFreeze mut_arr + +getDictFastString :: Dictionary -> ReadBinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + +putDictFastString :: FSTable -> WriteBinHandle -> FastString -> IO () +putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: FSTable -> FastString -> IO Word32 +allocateFastString FSTable { fs_tab_next = j_r + , fs_tab_map = out_r + } f = do + out <- readIORef out_r + let !uniq = getUnique f + case lookupUFM_Directly out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM_Directly out uniq (j, f) + return (fromIntegral j :: Word32) + +-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to +-- avoid a collision and copy to avoid a dependency. +data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use + , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString))) + -- indexed by FastString + } + + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- | Symbols that are read from disk. +-- The 'SymbolTable' index starts on '0'. +type SymbolTable a = Array Int a + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: WriteBinHandle -> FastString -> IO () +putFS bh fs = putSBS bh $ fastStringToShortByteString fs + +getFS :: ReadBinHandle -> IO FastString +getFS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> pure $! mkFastStringBytes src l ) + +-- | Put a ByteString without its length (can't be read back without knowing the +-- length!) +putByteString :: WriteBinHandle -> ByteString -> IO () +putByteString bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + +-- | Get a ByteString whose length is known +getByteString :: ReadBinHandle -> Int -> IO ByteString +getByteString bh l = + BS.create l $ \dest -> do + getPrim bh l (\src -> copyBytes dest src l) + +putSBS :: WriteBinHandle -> SBS.ShortByteString -> IO () +putSBS bh sbs = do + let l = SBS.length sbs + put_ bh l + putPrim bh l (\p -> SBS.copyToPtr sbs 0 p l) + + +getSBS :: ReadBinHandle -> IO SBS.ShortByteString +getSBS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> SBS.createFromPtr src l) + +putBS :: WriteBinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + +getBS :: ReadBinHandle -> IO ByteString +getBS bh = do + l <- get bh :: IO Int + BS.create l $ \dest -> do + getPrim bh l (\src -> copyBytes dest src l) + +instance Binary SBS.ShortByteString where + put_ bh f = putSBS bh f + get bh = getSBS bh + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case findUserDataWriter (Proxy :: Proxy FastString) bh of + tbl -> putEntry tbl bh f + + get bh = + case findUserDataReader (Proxy :: Proxy FastString) bh of + tbl -> getEntry tbl bh + +deriving instance Binary NonDetFastString +deriving instance Binary LexicalFastString + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +-- instance Binary TupleSort where +-- put_ bh BoxedTuple = putByte bh 0 +-- put_ bh UnboxedTuple = putByte bh 1 +-- put_ bh ConstraintTuple = putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return BoxedTuple +-- 1 -> do return UnboxedTuple +-- _ -> do return ConstraintTuple + +-- instance Binary Activation where +-- put_ bh NeverActive = do +-- putByte bh 0 +-- put_ bh FinalActive = do +-- putByte bh 1 +-- put_ bh AlwaysActive = do +-- putByte bh 2 +-- put_ bh (ActiveBefore src aa) = do +-- putByte bh 3 +-- put_ bh src +-- put_ bh aa +-- put_ bh (ActiveAfter src ab) = do +-- putByte bh 4 +-- put_ bh src +-- put_ bh ab +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return NeverActive +-- 1 -> do return FinalActive +-- 2 -> do return AlwaysActive +-- 3 -> do src <- get bh +-- aa <- get bh +-- return (ActiveBefore src aa) +-- _ -> do src <- get bh +-- ab <- get bh +-- return (ActiveAfter src ab) + +-- instance Binary InlinePragma where +-- put_ bh (InlinePragma s a b c d) = do +-- put_ bh s +-- put_ bh a +-- put_ bh b +-- put_ bh c +-- put_ bh d + +-- get bh = do +-- s <- get bh +-- a <- get bh +-- b <- get bh +-- c <- get bh +-- d <- get bh +-- return (InlinePragma s a b c d) + +-- instance Binary RuleMatchInfo where +-- put_ bh FunLike = putByte bh 0 +-- put_ bh ConLike = putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- if h == 1 then return ConLike +-- else return FunLike + +-- instance Binary InlineSpec where +-- put_ bh NoUserInlinePrag = putByte bh 0 +-- put_ bh Inline = putByte bh 1 +-- put_ bh Inlinable = putByte bh 2 +-- put_ bh NoInline = putByte bh 3 + +-- get bh = do h <- getByte bh +-- case h of +-- 0 -> return NoUserInlinePrag +-- 1 -> return Inline +-- 2 -> return Inlinable +-- _ -> return NoInline + +-- instance Binary RecFlag where +-- put_ bh Recursive = do +-- putByte bh 0 +-- put_ bh NonRecursive = do +-- putByte bh 1 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return Recursive +-- _ -> do return NonRecursive + +-- instance Binary OverlapMode where +-- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s +-- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s +-- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s +-- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s +-- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> (get bh) >>= \s -> return $ NoOverlap s +-- 1 -> (get bh) >>= \s -> return $ Overlaps s +-- 2 -> (get bh) >>= \s -> return $ Incoherent s +-- 3 -> (get bh) >>= \s -> return $ Overlapping s +-- 4 -> (get bh) >>= \s -> return $ Overlappable s +-- _ -> panic ("get OverlapMode" ++ show h) + + +-- instance Binary OverlapFlag where +-- put_ bh flag = do put_ bh (overlapMode flag) +-- put_ bh (isSafeOverlap flag) +-- get bh = do +-- h <- get bh +-- b <- get bh +-- return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +-- instance Binary FixityDirection where +-- put_ bh InfixL = do +-- putByte bh 0 +-- put_ bh InfixR = do +-- putByte bh 1 +-- put_ bh InfixN = do +-- putByte bh 2 +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do return InfixL +-- 1 -> do return InfixR +-- _ -> do return InfixN + +-- instance Binary Fixity where +-- put_ bh (Fixity src aa ab) = do +-- put_ bh src +-- put_ bh aa +-- put_ bh ab +-- get bh = do +-- src <- get bh +-- aa <- get bh +-- ab <- get bh +-- return (Fixity src aa ab) + +-- instance Binary WarningTxt where +-- put_ bh (WarningTxt s w) = do +-- putByte bh 0 +-- put_ bh s +-- put_ bh w +-- put_ bh (DeprecatedTxt s d) = do +-- putByte bh 1 +-- put_ bh s +-- put_ bh d + +-- get bh = do +-- h <- getByte bh +-- case h of +-- 0 -> do s <- get bh +-- w <- get bh +-- return (WarningTxt s w) +-- _ -> do s <- get bh +-- d <- get bh +-- return (DeprecatedTxt s d) + +-- instance Binary StringLiteral where +-- put_ bh (StringLiteral st fs _) = do +-- put_ bh st +-- put_ bh fs +-- get bh = do +-- st <- get bh +-- fs <- get bh +-- return (StringLiteral st fs Nothing) + +newtype BinLocated a = BinLocated { unBinLocated :: Located a } + +instance Binary a => Binary (BinLocated a) where + put_ bh (BinLocated (L l x)) = do + put_ bh $ BinSrcSpan l + put_ bh x + + get bh = do + l <- unBinSrcSpan <$> get bh + x <- get bh + return $ BinLocated (L l x) + +newtype BinSpan = BinSpan { unBinSpan :: RealSrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSpan where + put_ bh (BinSpan ss) = do + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance Binary UnhelpfulSpanReason where + put_ bh r = case r of + UnhelpfulNoLocationInfo -> putByte bh 0 + UnhelpfulWiredIn -> putByte bh 1 + UnhelpfulInteractive -> putByte bh 2 + UnhelpfulGenerated -> putByte bh 3 + UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + + get bh = do + h <- getByte bh + case h of + 0 -> return UnhelpfulNoLocationInfo + 1 -> return UnhelpfulWiredIn + 2 -> return UnhelpfulInteractive + 3 -> return UnhelpfulGenerated + _ -> UnhelpfulOther <$> get bh + +newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } + +-- See Note [Source Location Wrappers] +instance Binary BinSrcSpan where + put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do + putByte bh 0 + -- BufSpan doesn't ever get serialised because the positions depend + -- on build location. + put_ bh $ BinSpan ss + + put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do BinSpan ss <- get bh + return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) + _ -> do s <- get bh + return $ BinSrcSpan (UnhelpfulSpan s) + + +{- +Note [Source Location Wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Source locations are banned from interface files, to +prevent filepaths affecting interface hashes. + +Unfortunately, we can't remove all binary instances, +as they're used to serialise .hie files, and we don't +want to break binary compatibility. + +To this end, the Bin[Src]Span newtypes wrappers were +introduced to prevent accidentally serialising a +source location as part of a larger structure. +-} + +-------------------------------------------------------------------------------- +-- Instances for the containers package +-------------------------------------------------------------------------------- + +instance (Binary v) => Binary (IntMap v) where + put_ bh m = put_ bh (IntMap.toAscList m) + get bh = IntMap.fromAscList <$> get bh + + +{- Note [FingerprintWithValue] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +FingerprintWithValue is a wrapper which allows us to store a fingerprint and +optionally the value which was used to create the fingerprint. + +This is useful for storing information in interface files, where we want to +store the fingerprint of the interface file, but also the value which was used +to create the fingerprint (e.g. the DynFlags). + +The wrapper is useful to ensure that the fingerprint can be read quickly without +having to deserialise the value itself. +-} + +-- | A wrapper which allows us to store a fingerprint and optionally the value which +-- was used to create the fingerprint. +data FingerprintWithValue a = FingerprintWithValue !Fingerprint (Maybe a) + deriving Functor + +instance Binary a => Binary (FingerprintWithValue a) where + put_ bh (FingerprintWithValue fp val) = do + put_ bh fp + lazyPutMaybe bh val + + get bh = do + fp <- get bh + val <- lazyGetMaybe bh + return $ FingerprintWithValue fp val + +instance NFData a => NFData (FingerprintWithValue a) where + rnf (FingerprintWithValue fp mflags) + = rnf fp `seq` rnf mflags `seq` () diff --git a/GHC/Utils/Binary/Typeable.hs b/GHC/Utils/Binary/Typeable.hs --- a/GHC/Utils/Binary/Typeable.hs +++ b/GHC/Utils/Binary/Typeable.hs @@ -4,9 +4,6 @@ {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} {-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-} -#if MIN_VERSION_base(4,16,0) -#define HAS_TYPELITCHAR -#endif -- | Orphan Binary instances for Data.Typeable stuff module GHC.Utils.Binary.Typeable @@ -19,9 +16,7 @@ import GHC.Utils.Binary import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..)) -#if __GLASGOW_HASKELL__ >= 901 import GHC.Exts (Levity(Lifted, Unlifted)) -#endif import GHC.Serialized import Foreign @@ -40,7 +35,7 @@ get bh = mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -getSomeTypeRep :: BinHandle -> IO SomeTypeRep +getSomeTypeRep :: ReadBinHandle -> IO SomeTypeRep getSomeTypeRep bh = do tag <- get bh :: IO Word8 case tag of @@ -102,13 +97,8 @@ put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps -#if __GLASGOW_HASKELL__ >= 901 put_ bh (BoxedRep Lifted) = putByte bh 3 put_ bh (BoxedRep Unlifted) = putByte bh 4 -#else - put_ bh LiftedRep = putByte bh 3 - put_ bh UnliftedRep = putByte bh 4 -#endif put_ bh IntRep = putByte bh 5 put_ bh WordRep = putByte bh 6 put_ bh Int64Rep = putByte bh 7 @@ -129,13 +119,8 @@ 0 -> VecRep <$> get bh <*> get bh 1 -> TupleRep <$> get bh 2 -> SumRep <$> get bh -#if __GLASGOW_HASKELL__ >= 901 3 -> pure (BoxedRep Lifted) 4 -> pure (BoxedRep Unlifted) -#else - 3 -> pure LiftedRep - 4 -> pure UnliftedRep -#endif 5 -> pure IntRep 6 -> pure WordRep 7 -> pure Int64Rep @@ -173,20 +158,16 @@ instance Binary TypeLitSort where put_ bh TypeLitSymbol = putByte bh 0 put_ bh TypeLitNat = putByte bh 1 -#if defined(HAS_TYPELITCHAR) put_ bh TypeLitChar = putByte bh 2 -#endif get bh = do tag <- getByte bh case tag of 0 -> pure TypeLitSymbol 1 -> pure TypeLitNat -#if defined(HAS_TYPELITCHAR) 2 -> pure TypeLitChar -#endif _ -> fail "Binary.putTypeLitSort: invalid tag" -putTypeRep :: BinHandle -> TypeRep a -> IO () +putTypeRep :: WriteBinHandle -> TypeRep a -> IO () putTypeRep bh rep -- Handle Type specially since it's so common | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) = put_ bh (0 :: Word8) @@ -198,12 +179,6 @@ put_ bh (2 :: Word8) putTypeRep bh f putTypeRep bh x -#if __GLASGOW_HASKELL__ < 903 -putTypeRep bh (Fun arg res) = do - put_ bh (3 :: Word8) - putTypeRep bh arg - putTypeRep bh res -#endif instance Binary Serialized where put_ bh (Serialized the_type bytes) = do diff --git a/GHC/Utils/BufHandle.hs b/GHC/Utils/BufHandle.hs --- a/GHC/Utils/BufHandle.hs +++ b/GHC/Utils/BufHandle.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- diff --git a/GHC/Utils/Containers/Internal/BitUtil.hs b/GHC/Utils/Containers/Internal/BitUtil.hs --- a/GHC/Utils/Containers/Internal/BitUtil.hs +++ b/GHC/Utils/Containers/Internal/BitUtil.hs @@ -1,12 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif - -#include "containers.h" ----------------------------------------------------------------------------- -- | diff --git a/GHC/Utils/Containers/Internal/StrictPair.hs b/GHC/Utils/Containers/Internal/StrictPair.hs --- a/GHC/Utils/Containers/Internal/StrictPair.hs +++ b/GHC/Utils/Containers/Internal/StrictPair.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -#include "containers.h" - -- | A strict pair module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where + +-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base +import GHC.Base () + +default () -- | The same as a regular Haskell pair, but -- diff --git a/GHC/Utils/Error.hs b/GHC/Utils/Error.hs --- a/GHC/Utils/Error.hs +++ b/GHC/Utils/Error.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeApplications #-} {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -75,7 +71,6 @@ import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc @@ -414,7 +409,7 @@ -> m a withTiming' logger what force_result prtimings action = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings - then do whenPrintTimings $ + then do when printTimingsNotDumpToFile $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle $ text "***" <+> what <> colon let ctx = log_default_user_context (logFlags logger) @@ -432,7 +427,7 @@ let alloc = alloc0 - alloc1 time = realToFrac (end - start) * 1e-9 - when (logVerbAtLeast logger 2 && prtimings == PrintTimings) + when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile) $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time @@ -452,7 +447,16 @@ pure r else action - where whenPrintTimings = liftIO . when (prtimings == PrintTimings) + where whenPrintTimings = + liftIO . when printTimings + + printTimings = + prtimings == PrintTimings + + -- Avoid both printing to console and dumping to a file (#20316). + printTimingsNotDumpToFile = + printTimings + && not (log_dump_to_file (logFlags logger)) recordAllocs alloc = liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc diff --git a/GHC/Utils/FV.hs b/GHC/Utils/FV.hs --- a/GHC/Utils/FV.hs +++ b/GHC/Utils/FV.hs @@ -3,8 +3,6 @@ -} -{-# LANGUAGE BangPatterns #-} - -- | Utilities for efficiently and deterministically computing free variables. module GHC.Utils.FV ( -- * Deterministic free vars computations @@ -23,6 +21,7 @@ delFVs, filterFV, mapUnionFV, + fvDVarSetSome, ) where import GHC.Prelude @@ -197,3 +196,7 @@ mkFVs vars fv_cand in_scope acc = mapUnionFV unitFV vars fv_cand in_scope acc {-# INLINE mkFVs #-} + +fvDVarSetSome :: InterestingVarFun -> FV -> DVarSet +fvDVarSetSome interesting_var fv = + mkDVarSet $ fst $ fv interesting_var emptyVarSet ([], emptyVarSet) diff --git a/GHC/Utils/Fingerprint.hs b/GHC/Utils/Fingerprint.hs --- a/GHC/Utils/Fingerprint.hs +++ b/GHC/Utils/Fingerprint.hs @@ -19,6 +19,7 @@ fingerprintFingerprints, fingerprintData, fingerprintString, + fingerprintStrings, getFileHash ) where @@ -43,3 +44,7 @@ fingerprintByteString :: BS.ByteString -> Fingerprint fingerprintByteString bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fingerprintData (castPtr ptr) len + +-- See Note [Repeated -optP hashing] +fingerprintStrings :: [String] -> Fingerprint +fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss diff --git a/GHC/Utils/GlobalVars.hs b/GHC/Utils/GlobalVars.hs --- a/GHC/Utils/GlobalVars.hs +++ b/GHC/Utils/GlobalVars.hs @@ -57,13 +57,6 @@ -#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) - -GLOBAL_VAR(v_unsafeHasPprDebug, False, Bool) -GLOBAL_VAR(v_unsafeHasNoDebugOutput, False, Bool) -GLOBAL_VAR(v_unsafeHasNoStateHack, False, Bool) - -#else SHARED_GLOBAL_VAR( v_unsafeHasPprDebug , getOrSetLibHSghcGlobalHasPprDebug , "getOrSetLibHSghcGlobalHasPprDebug" @@ -79,7 +72,6 @@ , "getOrSetLibHSghcGlobalHasNoStateHack" , False , Bool ) -#endif unsafeHasPprDebug :: Bool unsafeHasPprDebug = unsafePerformIO $ readIORef v_unsafeHasPprDebug diff --git a/GHC/Utils/Lexeme.hs b/GHC/Utils/Lexeme.hs --- a/GHC/Utils/Lexeme.hs +++ b/GHC/Utils/Lexeme.hs @@ -219,13 +219,14 @@ OtherNumber -> True -- See #4373 _ -> c == '\'' || c == '_' --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report, +-- plus the GHC-specific @forall@ keyword (see GHC Proposal #281). reservedIds :: Set.Set String reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" - , "do", "else", "foreign", "if", "import", "in" - , "infix", "infixl", "infixr", "instance", "let" - , "module", "newtype", "of", "then", "type", "where" - , "_" ] + , "do", "else", "forall", "foreign", "if", "import" + , "in", "infix", "infixl", "infixr", "instance" + , "let", "module", "newtype", "of", "then", "type" + , "where", "_" ] -- | All reserved operators. Taken from section 2.4 of the 2010 Report, -- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229). diff --git a/GHC/Utils/Logger.hs b/GHC/Utils/Logger.hs --- a/GHC/Utils/Logger.hs +++ b/GHC/Utils/Logger.hs @@ -24,6 +24,7 @@ -- * Logger setup , initLogger , LogAction + , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -31,6 +32,8 @@ -- ** Hooks , popLogHook , pushLogHook + , popJsonLogHook + , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -49,12 +52,14 @@ , logVerbAtLeast -- * Logging - , jsonLogAction , putLogMsg , defaultLogAction + , defaultLogActionWithHandles + , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg + , logJsonMsg , logDumpMsg -- * Dumping @@ -87,6 +92,7 @@ import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet +import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, () ) @@ -111,6 +117,7 @@ , log_default_dump_context :: SDocContext , log_dump_flags :: !(EnumSet DumpFlag) -- ^ Dump flags , log_show_caret :: !Bool -- ^ Show caret in diagnostics + , log_diagnostics_as_json :: !Bool -- ^ Format diagnostics as JSON , log_show_warn_groups :: !Bool -- ^ Show warning flag groups , log_enable_timestamps :: !Bool -- ^ Enable timestamps , log_dump_to_file :: !Bool -- ^ Enable dump to file @@ -130,6 +137,7 @@ , log_default_dump_context = defaultSDocContext , log_dump_flags = EnumSet.empty , log_show_caret = True + , log_diagnostics_as_json = False , log_show_warn_groups = True , log_enable_timestamps = True , log_dump_to_file = False @@ -177,6 +185,11 @@ -> SDoc -> IO () +type LogJsonAction = LogFlags + -> MessageClass + -> JsonDoc + -> IO () + type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -214,6 +227,9 @@ { log_hook :: [LogAction -> LogAction] -- ^ Log hooks stack + , json_log_hook :: [LogJsonAction -> LogJsonAction] + -- ^ Json log hooks stack + , dump_hook :: [DumpAction -> DumpAction] -- ^ Dump hooks stack @@ -249,6 +265,7 @@ dumps <- newMVar Map.empty return $ Logger { log_hook = [] + , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -260,6 +277,10 @@ putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) +-- | Log a JsonDoc +putJsonLogMsg :: Logger -> LogJsonAction +putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger) + -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger = @@ -284,6 +305,15 @@ [] -> panic "popLogHook: empty hook stack" _:hs -> logger { log_hook = hs } +-- | Push a json log hook +pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger +pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger } + +popJsonLogHook :: Logger -> Logger +popJsonLogHook logger = case json_log_hook logger of + [] -> panic "popJsonLogHook: empty hook stack" + _:hs -> logger { json_log_hook = hs} + -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } @@ -328,24 +358,60 @@ $ logger -- See Note [JSON Error Messages] --- -jsonLogAction :: LogAction -jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message -jsonLogAction logflags msg_class srcSpan msg +defaultLogJsonAction :: LogJsonAction +defaultLogJsonAction logflags msg_class jsdoc = + case msg_class of + MCOutput -> printOut msg + MCDump -> printOut (msg $$ blankLine) + MCInteractive -> putStrSDoc msg + MCInfo -> printErrs msg + MCFatal -> printErrs msg + MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code -> printErrs msg + where + printOut = defaultLogActionHPrintDoc logflags False stdout + printErrs = defaultLogActionHPrintDoc logflags False stderr + putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout + msg = renderJSON jsdoc + +-- See Note [JSON Error Messages] +-- this is to be removed +jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction +jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message +jsonLogActionWithHandle out logflags msg_class srcSpan msg = - defaultLogActionHPutStrDoc logflags True stdout + defaultLogActionHPutStrDoc logflags True out (withPprStyle PprCode (doc $$ text "")) where str = renderWithContext (log_default_user_context logflags) msg doc = renderJSON $ - JSObject [ ( "span", json srcSpan ) + JSObject [ ( "span", spanToDumpJSON srcSpan ) , ( "doc" , JSString str ) , ( "messageClass", json msg_class ) ] + spanToDumpJSON :: SrcSpan -> JsonDoc + spanToDumpJSON s = case s of + (RealSrcSpan rss _) -> JSObject [ ("file", json file) + , ("startLine", json $ srcSpanStartLine rss) + , ("startCol", json $ srcSpanStartCol rss) + , ("endLine", json $ srcSpanEndLine rss) + , ("endCol", json $ srcSpanEndCol rss) + ] + where file = unpackFS $ srcSpanFile rss + UnhelpfulSpan _ -> JSNull +-- | The default 'LogAction' prints to 'stdout' and 'stderr'. +-- +-- To replicate the default log action behaviour with different @out@ and @err@ +-- handles, see 'defaultLogActionWithHandles'. defaultLogAction :: LogAction -defaultLogAction logflags msg_class srcSpan msg - | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg +defaultLogAction = defaultLogActionWithHandles stdout stderr + +-- | The default 'LogAction' parametrized over the standard output and standard error handles. +-- Allows clients to replicate the log message formatting of GHC with custom handles. +defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction +defaultLogActionWithHandles out err logflags msg_class srcSpan msg + | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg | otherwise = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) @@ -355,21 +421,20 @@ MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message MCDiagnostic _sev _rea _code -> printDiagnostics where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout + printOut = defaultLogActionHPrintDoc logflags False out + printErrs = defaultLogActionHPrintDoc logflags False err + putStrSDoc = defaultLogActionHPutStrDoc logflags False out -- Pretty print the warning flag, if any (#10752) message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg printDiagnostics = do - hPutChar stderr '\n' caretDiagnostic <- if log_show_caret logflags then getCaretDiagnostic msg_class srcSpan else pure empty printErrs $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic) + (message $+$ caretDiagnostic $+$ blankLine) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of @@ -403,6 +468,12 @@ -- information to provide to the user but refactoring log_action is quite -- invasive as it is called in many places. So, for now I left it alone -- and we can refine its behaviour as users request different output. +-- +-- The recent work here replaces the purpose of flag -ddump-json with +-- -fdiagnostics-as-json. For temporary backwards compatibility while +-- -ddump-json is being deprecated, `jsonLogAction` has been added in, but +-- it should be removed along with -ddump-json. Similarly, the guard in +-- `defaultLogAction` should be removed. This cleanup is tracked in #24113. -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction @@ -505,7 +576,7 @@ getPrefix -- dump file location is being forced - -- by the --ddump-file-prefix flag. + -- by the -ddump-file-prefix flag. | Just prefix <- log_dump_prefix_override logflags = prefix -- dump file locations, module specified to [modulename] set by @@ -531,6 +602,9 @@ -- | Log something logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg + +logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO () +logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d) -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () diff --git a/GHC/Utils/Misc.hs b/GHC/Utils/Misc.hs --- a/GHC/Utils/Misc.hs +++ b/GHC/Utils/Misc.hs @@ -1,11 +1,9 @@ -- (c) The University of Glasgow 2006 {-# LANGUAGE CPP #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Highly random utility functions -- @@ -23,11 +21,12 @@ mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, mapAndUnzip4, - filterOut, partitionWith, + filterOut, partitionWith, partitionWithM, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, - List.foldl1', foldl2, count, countWhile, all2, + foldl2, count, countWhile, all2, any2, all2Prefix, all3Prefix, + foldr1WithDefault, foldl1WithDefault', lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, @@ -37,12 +36,9 @@ isSingleton, only, expectOnly, GHC.Utils.Misc.singleton, notNull, expectNonEmpty, snocView, - chunkList, - holes, changeLast, - mapLastM, whenNonEmpty, @@ -132,10 +128,10 @@ import Data.Data import qualified Data.List as List import Data.List.NonEmpty ( NonEmpty(..), last, nonEmpty ) -import qualified Data.List.NonEmpty as NE -import GHC.Exts +import GHC.Exts hiding (toList) import GHC.Stack (HasCallStack) +import GHC.Data.List import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) @@ -146,6 +142,7 @@ import Data.Bifunctor ( first, second ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) +import Data.Foldable ( Foldable (toList) ) import Data.Int import Data.Ratio ( (%) ) import Data.Ord ( comparing ) @@ -221,6 +218,17 @@ Right c -> (bs, c:cs) where (bs,cs) = partitionWith f xs +partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c]) +-- ^ Monadic version of `partitionWith` +partitionWithM _ [] = return ([], []) +partitionWithM f (x:xs) = do + y <- f x + (bs, cs) <- partitionWithM f xs + case y of + Left b -> return (b:bs, cs) + Right c -> return (bs, c:cs) +{-# INLINEABLE partitionWithM #-} + chkAppend :: [a] -> [a] -> [a] -- Checks for the second argument being empty -- Used in situations where that situation is common @@ -234,34 +242,34 @@ DEBUGging on; hey, why not? -} -zipEqual :: HasDebugCallStack => String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: HasDebugCallStack => String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: HasDebugCallStack => String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: HasDebugCallStack => String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipEqual :: HasDebugCallStack => [a] -> [b] -> [(a,b)] +zipWithEqual :: HasDebugCallStack => (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: HasDebugCallStack => (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: HasDebugCallStack => (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] #if !defined(DEBUG) -zipEqual _ = zip -zipWithEqual _ = zipWith -zipWith3Equal _ = zipWith3 -zipWith4Equal _ = List.zipWith4 +zipEqual = zip +zipWithEqual = zipWith +zipWith3Equal = zipWith3 +zipWith4Equal = List.zipWith4 #else -zipEqual _ [] [] = [] -zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs -zipEqual msg _ _ = panic ("zipEqual: unequal lists: "++msg) +zipEqual [] [] = [] +zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs +zipEqual _ _ = panic "zipEqual: unequal lists" -zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs -zipWithEqual _ _ [] [] = [] -zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists: "++msg) +zipWithEqual z (a:as) (b:bs)= z a b : zipWithEqual z as bs +zipWithEqual _ [] [] = [] +zipWithEqual _ _ _ = panic "zipWithEqual: unequal lists" -zipWith3Equal msg z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3Equal msg z as bs cs -zipWith3Equal _ _ [] [] [] = [] -zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists: "++msg) +zipWith3Equal z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal z as bs cs +zipWith3Equal _ [] [] [] = [] +zipWith3Equal _ _ _ _ = panic "zipWith3Equal: unequal lists" -zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) - = z a b c d : zipWith4Equal msg z as bs cs ds -zipWith4Equal _ _ [] [] [] [] = [] -zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) +zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal z as bs cs ds +zipWith4Equal _ [] [] [] [] = [] +zipWith4Equal _ _ _ _ _ = panic "zipWith4Equal: unequal lists" #endif -- | 'filterByList' takes a list of Bools and a list of some elements and @@ -320,31 +328,6 @@ mapFst = fmap . first mapSnd = fmap . second -mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) - -mapAndUnzip _ [] = ([], []) -mapAndUnzip f (x:xs) - = let (r1, r2) = f x - (rs1, rs2) = mapAndUnzip f xs - in - (r1:rs1, r2:rs2) - -mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) -mapAndUnzip3 _ [] = ([], [], []) -mapAndUnzip3 f (x:xs) - = let (r1, r2, r3) = f x - (rs1, rs2, rs3) = mapAndUnzip3 f xs - in - (r1:rs1, r2:rs2, r3:rs3) - -mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e]) -mapAndUnzip4 _ [] = ([], [], [], []) -mapAndUnzip4 f (x:xs) - = let (r1, r2, r3, r4) = f x - (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs - in - (r1:rs1, r2:rs2, r3:rs3, r4:rs4) - zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip f (a:as) (b:bs) = let (r1, r2) = f a b @@ -485,19 +468,15 @@ -- | Extract the single element of a list and panic with the given message if -- there are more elements or the list was empty. -- Like 'expectJust', but for lists. -expectOnly :: HasDebugCallStack => String -> [a] -> a +expectOnly :: HasCallStack => [a] -> a +-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectOnly #-} #if defined(DEBUG) -expectOnly _ [a] = a +expectOnly [a] = a #else -expectOnly _ (a:_) = a +expectOnly (a:_) = a #endif -expectOnly msg _ = panic ("expectOnly: " ++ msg) - --- | Split a list into chunks of /n/ elements -chunkList :: Int -> [a] -> [[a]] -chunkList _ [] = [] -chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs +expectOnly _ = panic "expectOnly" -- | Compute all the ways of removing a single element from a list. -- @@ -513,20 +492,16 @@ changeLast (x:xs) x' = x : changeLast xs x' -- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'. -expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a +expectNonEmpty :: HasCallStack => [a] -> NonEmpty a +-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectNonEmpty #-} -expectNonEmpty _ (x:xs) = x:|xs -expectNonEmpty msg [] = expectNonEmptyPanic msg +expectNonEmpty (x:xs) = x:|xs +expectNonEmpty [] = expectNonEmptyPanic -expectNonEmptyPanic :: String -> a -expectNonEmptyPanic msg = panic ("expectNonEmpty: " ++ msg) +expectNonEmptyPanic :: HasCallStack => a +expectNonEmptyPanic = panic "expectNonEmpty" {-# NOINLINE expectNonEmptyPanic #-} --- | Apply an effectful function to the last list element. -mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a) -mapLastM f (x:|[]) = NE.singleton <$> f x -mapLastM f (x0:|x1:xs) = (x0 NE.<|) <$> mapLastM f (x1:|xs) - whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) @@ -659,6 +634,42 @@ all2 p (x:xs) (y:ys) = p x y && all2 p xs ys all2 _ _ _ = False +any2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if any of the corresponding elements satisfy the predicate +-- Unlike `all2`, this ignores excess elements of the other list +any2 p (x:xs) (y:ys) = p x y || any2 p xs ys +any2 _ _ _ = False + +all2Prefix :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool +-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`. +-- (It generates good code nonetheless.) +-- So if one list is shorter than the other, `p` is assumed to be `True` for the +-- suffix. +all2Prefix p = foldr k z + where + k :: a -> ([b] -> Bool) -> [b] -> Bool + k x go ys' = case ys' of + (y:ys'') -> p x y && go ys'' + _ -> True + z :: [b] -> Bool + z _ = True +{-# INLINE all2Prefix #-} + +all3Prefix :: forall a b c. (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool +-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`. +-- (It generates good code nonetheless.) +-- So if one list is shorter than the others, `p` is assumed to be `True` for +-- the suffix. +all3Prefix p = foldr k z + where + k :: a -> ([b] -> [c] -> Bool) -> [b] -> [c] -> Bool + k x go ys' zs' = case (ys',zs') of + (y:ys'',z:zs'') -> p x y z && go ys'' zs'' + _ -> False + z :: [b] -> [c] -> Bool + z _ _ = True +{-# INLINE all3Prefix #-} + -- Count the number of times a predicate is true count :: (a -> Bool) -> [a] -> Int @@ -1050,7 +1061,7 @@ readFix r = do (ds,s) <- lexDecDigits r (ds',t) <- lexDotDigits s - return (read (ds++ds'), length ds', t) + return (read (toList ds++ds'), length ds', t) readExp (e:s) | e `elem` "eE" = readExp' s readExp s = return (0,s) @@ -1070,8 +1081,8 @@ lexDotDigits ('.':s) = return (span' isDigit s) lexDotDigits s = return ("",s) - nonnull p s = do (cs@(_:_),t) <- return (span' p s) - return (cs,t) + nonnull p s = do (c:cs,t) <- return (span' p s) + return (c:|cs,t) span' _ xs@[] = (xs, xs) span' p xs@(x:xs') @@ -1439,3 +1450,15 @@ g x rest | Just y <- f x = y : rest | otherwise = rest + +foldr1WithDefault :: Foldable f => a -> (a -> a -> a) -> f a -> a +foldr1WithDefault defaultA f xs = case nonEmpty (toList xs) of + Nothing -> defaultA + Just (xs1 :: NonEmpty a) -> foldr1 f xs1 +{-# SPECIALIZE foldr1WithDefault :: a -> (a -> a -> a) -> [a] -> a #-} + +foldl1WithDefault' :: Foldable f => a -> (a -> a -> a) -> f a -> a +foldl1WithDefault' defaultA f xs = case nonEmpty (toList xs) of + Nothing -> defaultA + Just (xs1 :: NonEmpty a) -> foldl1' f xs1 +{-# SPECIALIZE foldl1WithDefault' :: a -> (a -> a -> a) -> [a] -> a #-} diff --git a/GHC/Utils/Monad.hs b/GHC/Utils/Monad.hs --- a/GHC/Utils/Monad.hs +++ b/GHC/Utils/Monad.hs @@ -18,7 +18,7 @@ , concatMapM , mapMaybeM , anyM, allM, orM - , foldlM, foldlM_, foldrM + , foldlM, foldlM_, foldrM, foldMapM , whenM, unlessM , filterOutM , partitionM @@ -37,6 +37,7 @@ import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Monoid (Ap (Ap, getAp)) import Data.Tuple (swap) ------------------------------------------------------------------------------- @@ -227,6 +228,10 @@ -- | Monadic version of foldl that discards its result foldlM_ :: (Monad m, Foldable t) => (a -> b -> m a) -> a -> t b -> m () foldlM_ = foldM_ + +-- | Monadic version of 'foldMap' +foldMapM :: (Applicative m, Foldable t, Monoid b) => (a -> m b) -> t a -> m b +foldMapM f = getAp <$> foldMap (Ap . f) -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m () diff --git a/GHC/Utils/Monad/State/Strict.hs b/GHC/Utils/Monad/State/Strict.hs --- a/GHC/Utils/Monad/State/Strict.hs +++ b/GHC/Utils/Monad/State/Strict.hs @@ -4,7 +4,7 @@ -- | A state monad which is strict in its state. module GHC.Utils.Monad.State.Strict ( -- * The State monad - State(State) + State(State, State' {- for deriving via purposes only -}) , state , evalState , execState @@ -78,8 +78,10 @@ forceState :: (# a, s #) -> (# a, s #) forceState (# a, !s #) = (# a, s #) +-- See Note [The one-shot state monad trick] for why we don't derive this. instance Functor (State s) where fmap f m = State $ \s -> case runState' m s of (# x, s' #) -> (# f x, s' #) + {-# INLINE fmap #-} instance Applicative (State s) where pure x = State $ \s -> (# x, s #) @@ -87,10 +89,20 @@ case runState' m s of { (# f, s' #) -> case runState' n s' of { (# x, s'' #) -> (# f x, s'' #) }} + m *> n = State $ \s -> + case runState' m s of { (# _, s' #) -> + case runState' n s' of { (# x, s'' #) -> + (# x, s'' #) }} + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} instance Monad (State s) where m >>= n = State $ \s -> case runState' m s of (# r, !s' #) -> runState' (n r) s' + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} state :: (s -> (a, s)) -> State s a state f = State $ \s -> case f s of (r, s') -> (# r, s' #) diff --git a/GHC/Utils/Outputable.hs b/GHC/Utils/Outputable.hs --- a/GHC/Utils/Outputable.hs +++ b/GHC/Utils/Outputable.hs @@ -23,6 +23,7 @@ module GHC.Utils.Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), + BindingSite(..), JoinPointHood(..), isJoinPoint, IsOutput(..), IsLine(..), IsDoc(..), HLine, HDoc, @@ -31,14 +32,15 @@ SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', - pprQuotedList, pprWithCommas, + pprQuotedList, pprWithCommas, pprWithSemis, + unquotedListWith, pprUnquotedSet, quotedListWithOr, quotedListWithNor, quotedListWithAnd, pprWithBars, spaceIfSingleQuote, isEmpty, nest, ptext, int, intWithCommas, integer, word64, word, float, double, rational, doublePrec, - parens, cparen, brackets, braces, quotes, quote, + parens, cparen, brackets, braces, quotes, quote, quoteIfPunsEnabled, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, @@ -49,7 +51,7 @@ cat, fcat, hang, hangNotEmpty, punctuate, punctuateFinal, ppWhen, ppUnless, ppWhenOption, ppUnlessOption, - speakNth, speakN, speakNOf, plural, singular, + speakNth, speakN, speakNOf, plural, singular, pluralSet, isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave, itOrThey, unicodeSyntax, @@ -87,8 +89,6 @@ pprModuleName, -- * Controlling the style in which output is printed - BindingSite(..), - PprStyle(..), NamePprCtx(..), QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick, PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton, @@ -132,7 +132,7 @@ import GHC.Serialized import GHC.LanguageExtensions (Extension) import GHC.Utils.GlobalVars( unsafeHasPprDebug ) -import GHC.Utils.Misc (lastMaybe) +import GHC.Utils.Misc (lastMaybe, snocView) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -142,6 +142,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.IntSet as IntSet import qualified GHC.Data.Word64Set as Word64Set import Data.String import Data.Word @@ -157,6 +158,7 @@ import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 import Data.Void +import Control.DeepSeq (NFData(rnf)) import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -211,7 +213,7 @@ -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify -- it. -type QueryQualifyName = Module -> OccName -> QualifyName +type QueryQualifyName = Module -> Maybe ModuleName -> OccName -> QualifyName -- | For a given module, we need to know whether to print it with -- a package name to disambiguate it. @@ -266,14 +268,14 @@ ppr NameNotInScope2 = text "NameNotInScope2" reallyAlwaysQualifyNames :: QueryQualifyName -reallyAlwaysQualifyNames _ _ = NameNotInScope2 +reallyAlwaysQualifyNames _ _ _ = NameNotInScope2 -- | NB: This won't ever show package IDs alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames m _ = NameQual (moduleName m) +alwaysQualifyNames m _ _ = NameQual (moduleName m) neverQualifyNames :: QueryQualifyName -neverQualifyNames _ _ = NameUnqual +neverQualifyNames _ _ _ = NameUnqual alwaysQualifyModules :: QueryQualifyModule alwaysQualifyModules _ = True @@ -397,6 +399,7 @@ , sdocCanUseUnicode :: !Bool -- ^ True if Unicode encoding is supported -- and not disabled by GHC_NO_UNICODE environment variable + , sdocPrintErrIndexLinks :: !Bool , sdocHexWordLiterals :: !Bool , sdocPprDebug :: !Bool , sdocPrintUnicodeSyntax :: !Bool @@ -458,6 +461,7 @@ , sdocDefaultDepth = 5 , sdocLineLength = 100 , sdocCanUseUnicode = False + , sdocPrintErrIndexLinks = False , sdocHexWordLiterals = False , sdocPprDebug = False , sdocPrintUnicodeSyntax = False @@ -563,9 +567,9 @@ = SDoc $ \ctx -> runSDoc doc (upd ctx) qualName :: PprStyle -> QueryQualifyName -qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ -qualName (PprDump q) mod occ = queryQualifyName q mod occ -qualName _other mod _ = NameQual (moduleName mod) +qualName (PprUser q _ _) mod user_qual occ = queryQualifyName q mod user_qual occ +qualName (PprDump q) mod user_qual occ = queryQualifyName q mod user_qual occ +qualName _other mod _ _ = NameQual (moduleName mod) qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser q _ _) m = queryQualifyModule q m @@ -732,6 +736,12 @@ {-# INLINE CONLIKE cparen #-} cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d +quoteIfPunsEnabled :: SDoc -> SDoc +quoteIfPunsEnabled doc = + sdocOption sdocListTuplePuns $ \case + True -> quote doc + False -> doc + -- 'quotes' encloses something in single quotes... -- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. @@ -982,6 +992,9 @@ instance Outputable Word64Set.Word64Set where ppr s = braces (pprWithCommas ppr (Word64Set.toList s)) +instance Outputable IntSet.IntSet where + ppr s = braces (pprWithCommas ppr (IntSet.toList s)) + instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) @@ -1067,6 +1080,7 @@ instance Outputable ModuleName where ppr = pprModuleName + pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm) @@ -1191,6 +1205,9 @@ instance OutputableP env a => OutputableP env (Maybe a) where pdoc env xs = ppr (fmap (pdoc env) xs) +instance OutputableP env () where + pdoc _ _ = ppr () + instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where pdoc env (a,b) = ppr (pdoc env a, pdoc env b) @@ -1221,16 +1238,6 @@ ************************************************************************ -} --- | 'BindingSite' is used to tell the thing that prints binder what --- language construct is binding the identifier. This can be used --- to decide how much info to print. --- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr" -data BindingSite - = LambdaBind -- ^ The x in (\x. e) - | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } - | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } - | LetBind -- ^ The x in (let x = rhs in e) - deriving Eq -- | When we print a binder, we often want to print its type too. -- The @OutputableBndr@ class encapsulates this idea. class Outputable a => OutputableBndr a where @@ -1242,13 +1249,40 @@ -- prefix position of an application, thus (f a b) or ((+) x) -- or infix position, thus (a `f` b) or (x + y) - bndrIsJoin_maybe :: a -> Maybe Int - bndrIsJoin_maybe _ = Nothing + bndrIsJoin_maybe :: a -> JoinPointHood + bndrIsJoin_maybe _ = NotJoinPoint -- When pretty-printing we sometimes want to find -- whether the binder is a join point. You might think -- we could have a function of type (a->Var), but Var -- isn't available yet, alas +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. +-- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr" +data BindingSite + = LambdaBind -- ^ The x in (\x. e) + | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } + | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } + | LetBind -- ^ The x in (let x = rhs in e) + deriving Eq + +data JoinPointHood + = JoinPoint {-# UNPACK #-} !Int -- The JoinArity (but an Int here because + | NotJoinPoint -- synonym JoinArity is defined in Types.Basic) + deriving( Eq ) + +isJoinPoint :: JoinPointHood -> Bool +isJoinPoint (JoinPoint {}) = True +isJoinPoint NotJoinPoint = False + +instance Outputable JoinPointHood where + ppr NotJoinPoint = text "NotJoinPoint" + ppr (JoinPoint arity) = text "JoinPoint" <> parens (ppr arity) + +instance NFData JoinPointHood where + rnf x = x `seq` () + {- ************************************************************************ * * @@ -1364,6 +1398,12 @@ -- comma-separated and finally packed into a paragraph. pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) +pprWithSemis :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- semicolon-separated and finally packed into a paragraph. +pprWithSemis pp xs = fsep (punctuate semi (map pp xs)) + pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use -> [a] -- ^ The things to be pretty printed -> SDoc -- ^ 'SDoc' where the things have been pretty printed, @@ -1397,6 +1437,15 @@ pprQuotedList :: Outputable a => [a] -> SDoc pprQuotedList = quotedList . map ppr + +pprUnquotedSet :: Outputable a => Set.Set a -> SDoc +pprUnquotedSet set = + case Set.toList set of + [] -> braces empty + [x] -> ppr x + xs -> braces (fsep (punctuate comma (map ppr xs))) + + quotedList :: [SDoc] -> SDoc quotedList xs = fsep (punctuate comma (map quotes xs)) @@ -1415,6 +1464,15 @@ quotedListWithAnd xs@(_:_:_) = quotedList (init xs) <+> text "and" <+> quotes (last xs) quotedListWithAnd xs = quotedList xs + +unquotedListWith :: SDoc -> [SDoc] -> SDoc +-- "whatever" [x,y,z] ==> x, y whatever z +unquotedListWith d xs + | Just (fs@(_:_), l) <- snocView xs = unquotedList fs <+> d <+> l + | otherwise = unquotedList xs + where + unquotedList = fsep . punctuate comma + {- ************************************************************************ * * @@ -1491,6 +1549,10 @@ plural :: [a] -> SDoc plural [_] = empty -- a bit frightening, but there you are plural _ = char 's' + +-- | Like 'plural', but for sets. +pluralSet :: Set.Set a -> SDoc +pluralSet set = plural (Set.toList set) -- | Determines the singular verb suffix appropriate for the length of a list: -- diff --git a/GHC/Utils/Panic.hs b/GHC/Utils/Panic.hs --- a/GHC/Utils/Panic.hs +++ b/GHC/Utils/Panic.hs @@ -23,17 +23,12 @@ , handleGhcException -- * Command error throwing patterns - , pgmError - , panic , pprPanic - , sorry , panicDoc , sorryDoc , pgmErrorDoc - , cmdLineError - , cmdLineErrorIO + -- ** Assertions - , assertPanic , assertPprPanic , assertPpr , assertPprMaybe @@ -52,6 +47,7 @@ , tryMost , throwTo , withSignalHandlers + , module GHC.Utils.Panic.Plain ) where @@ -132,6 +128,10 @@ PlainProgramError str -> ProgramError str | otherwise = Nothing + -- Explicitly omit ExceptionContext since we generally don't + -- want backtraces and other context in GHC's user errors. + displayException exc = showGhcExceptionUnsafe exc "" + instance Show GhcException where showsPrec _ e = showGhcExceptionUnsafe e @@ -177,7 +177,7 @@ PprProgramError str sdoc -> PlainProgramError $ concat [str, "\n\n", renderWithContext ctx sdoc] -throwGhcException :: GhcException -> a +throwGhcException :: HasCallStack => GhcException -> a throwGhcException = Exception.throw throwGhcExceptionIO :: GhcException -> IO a @@ -188,11 +188,11 @@ -- | Throw an exception saying "bug in GHC" with a callstack pprPanic :: HasCallStack => String -> SDoc -> a -pprPanic s doc = panicDoc s (doc $$ callStackDoc) +pprPanic s doc = withFrozenCallStack $ panicDoc s (doc $$ callStackDoc) -- | Throw an exception saying "bug in GHC" -panicDoc :: String -> SDoc -> a -panicDoc x doc = throwGhcException (PprPanic x doc) +panicDoc :: HasCallStack => String -> SDoc -> a +panicDoc x doc = withFrozenCallStack $ throwGhcException (PprPanic x doc) -- | Throw an exception saying "this isn't finished yet" sorryDoc :: String -> SDoc -> a diff --git a/GHC/Utils/Panic/Plain.hs b/GHC/Utils/Panic/Plain.hs --- a/GHC/Utils/Panic/Plain.hs +++ b/GHC/Utils/Panic/Plain.hs @@ -5,15 +5,10 @@ -- type. It omits the exception constructors that involve -- pretty-printing via 'GHC.Utils.Outputable.SDoc'. -- --- There are two reasons for this: --- --- 1. To avoid import cycles / use of boot files. "GHC.Utils.Outputable" has --- many transitive dependencies. To throw exceptions from these --- modules, the functions here can be used without introducing import --- cycles. --- --- 2. To reduce the number of modules that need to be compiled to --- object code when loading GHC into GHCi. See #13101 +-- The reason for this is to avoid import cycles / use of boot files. +-- "GHC.Utils.Outputable" has many transitive dependencies. +-- To throw exceptions from these modules, the functions here can be used +-- without introducing import cycles. module GHC.Utils.Panic.Plain ( PlainGhcException(..) , showPlainGhcException @@ -104,12 +99,7 @@ -- | Panics and asserts. panic, sorry, pgmError :: HasCallStack => String -> a -panic x = unsafeDupablePerformIO $ do - stack <- ccsToStrings =<< getCurrentCCS x - let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) - if null stack - then throwPlainGhcException (PlainPanic (x ++ '\n' : doc)) - else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) +panic x = unsafeDupablePerformIO $ throwPlainGhcException (PlainPanic x) sorry x = throwPlainGhcException (PlainSorry x) pgmError x = throwPlainGhcException (PlainProgramError x) @@ -118,11 +108,7 @@ cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO cmdLineErrorIO :: String -> IO a -cmdLineErrorIO x = do - stack <- ccsToStrings =<< getCurrentCCS x - if null stack - then throwPlainGhcException (PlainCmdLineError x) - else throwPlainGhcException (PlainCmdLineError (x ++ '\n' : renderStack stack)) +cmdLineErrorIO x = throwPlainGhcException (PlainCmdLineError x) -- | Throw a failed assertion exception for a given filename and line number. assertPanic :: String -> Int -> a @@ -130,14 +116,17 @@ Exception.throw (Exception.AssertionFailed ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) - +-- | Throw a failed assertion exception taking the location information +-- from 'HasCallStack' evidence. assertPanic' :: HasCallStack => a assertPanic' = - let doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) - in - Exception.throw (Exception.AssertionFailed - ("ASSERT failed!\n" - ++ withFrozenCallStack doc)) + Exception.throw + $ Exception.AssertionFailed + $ "ASSERT failed!\n" ++ withFrozenCallStack doc + where + -- TODO: Drop CallStack when exception backtrace functionality + -- can be assumed of bootstrap compiler. + doc = unlines $ fmap (" "++) $ lines (prettyCallStack callStack) assert :: HasCallStack => Bool -> a -> a {-# INLINE assert #-} diff --git a/GHC/Utils/Ppr.hs b/GHC/Utils/Ppr.hs --- a/GHC/Utils/Ppr.hs +++ b/GHC/Utils/Ppr.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- diff --git a/GHC/Utils/TmpFs.hs b/GHC/Utils/TmpFs.hs --- a/GHC/Utils/TmpFs.hs +++ b/GHC/Utils/TmpFs.hs @@ -64,6 +64,8 @@ -- -- Shared with forked TmpFs. + , tmp_dir_prefix :: String + , tmp_files_to_clean :: IORef PathsToClean -- ^ Files to clean (per session or per module) -- @@ -121,6 +123,7 @@ , tmp_subdirs_to_clean = subdirs , tmp_dirs_to_clean = dirs , tmp_next_suffix = next + , tmp_dir_prefix = "tmp" } -- | Initialise an empty TmpFs sharing unique numbers and per-process temporary @@ -132,11 +135,16 @@ forkTmpFsFrom old = do files <- newIORef emptyPathsToClean subdirs <- newIORef emptyPathsToClean + counter <- newIORef 0 + prefix <- newTempSuffix old + + return $ TmpFs { tmp_files_to_clean = files , tmp_subdirs_to_clean = subdirs , tmp_dirs_to_clean = tmp_dirs_to_clean old - , tmp_next_suffix = tmp_next_suffix old + , tmp_next_suffix = counter + , tmp_dir_prefix = prefix } -- | Merge the first TmpFs into the second. @@ -259,10 +267,12 @@ addFilesToClean tmpfs lifetime existing_files -- Return a unique numeric temp file suffix -newTempSuffix :: TmpFs -> IO Int -newTempSuffix tmpfs = - atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n) +newTempSuffix :: TmpFs -> IO String +newTempSuffix tmpfs = do + n <- atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n) + return $ tmp_dir_prefix tmpfs ++ "_" ++ show n + -- Find a temporary name that doesn't already exist. newTempName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO FilePath newTempName logger tmpfs tmp_dir lifetime extn @@ -271,8 +281,8 @@ where findTempName :: FilePath -> IO FilePath findTempName prefix - = do n <- newTempSuffix tmpfs - let filename = prefix ++ show n <.> extn + = do suffix <- newTempSuffix tmpfs + let filename = prefix ++ suffix <.> extn b <- doesFileExist filename if b then findTempName prefix else do -- clean it up later @@ -295,8 +305,8 @@ where findTempDir :: FilePath -> IO FilePath findTempDir prefix - = do n <- newTempSuffix tmpfs - let name = prefix ++ show n + = do suffix <- newTempSuffix tmpfs + let name = prefix ++ suffix b <- doesDirectoryExist name if b then findTempDir prefix else (do @@ -314,8 +324,8 @@ where findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) findTempName dir prefix - = do n <- newTempSuffix tmpfs -- See Note [Deterministic base name] - let libname = prefix ++ show n + = do suffix <- newTempSuffix tmpfs -- See Note [Deterministic base name] + let libname = prefix ++ suffix filename = dir "lib" ++ libname <.> extn b <- doesFileExist filename if b then findTempName dir prefix @@ -340,8 +350,8 @@ mkTempDir :: FilePath -> IO FilePath mkTempDir prefix = do - n <- newTempSuffix tmpfs - let our_dir = prefix ++ show n + suffix <- newTempSuffix tmpfs + let our_dir = prefix ++ suffix -- 1. Speculatively create our new directory. createDirectory our_dir @@ -376,19 +386,33 @@ the process id). This is ok, as the temporary directory used contains the pid (see getTempDir). + +In addition to this, multiple threads can race against each other creating temporary +files. Therefore we supply a prefix when creating temporary files, when a thread is +forked, each thread must be given an TmpFs with a unique prefix. This is achieved +by forkTmpFsFrom creating a fresh prefix from the parent TmpFs. -} + +manyWithTrace :: Logger -> String -> ([FilePath] -> IO ()) -> [FilePath] -> IO () +manyWithTrace _ _ _ [] = pure () -- do silent nothing on zero filepaths +manyWithTrace logger phase act paths + = traceCmd logger phase ("Deleting: " ++ unwords paths) (act paths) + removeTmpDirs :: Logger -> [FilePath] -> IO () -removeTmpDirs logger ds - = traceCmd logger "Deleting temp dirs" - ("Deleting: " ++ unwords ds) - (mapM_ (removeWith logger removeDirectory) ds) +removeTmpDirs logger + = manyWithTrace logger "Deleting temp dirs" + (mapM_ (removeWith logger removeDirectory)) +removeTmpSubdirs :: Logger -> [FilePath] -> IO () +removeTmpSubdirs logger + = manyWithTrace logger "Deleting temp subdirs" + (mapM_ (removeWith logger removeDirectory)) + removeTmpFiles :: Logger -> [FilePath] -> IO () removeTmpFiles logger fs = warnNon $ - traceCmd logger "Deleting temp files" - ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith logger removeFile) deletees) + manyWithTrace logger "Deleting temp files" + (mapM_ (removeWith logger removeFile)) deletees where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source @@ -404,12 +428,6 @@ act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs - -removeTmpSubdirs :: Logger -> [FilePath] -> IO () -removeTmpSubdirs logger fs - = traceCmd logger "Deleting temp subdirs" - ("Deleting: " ++ unwords fs) - (mapM_ (removeWith logger removeDirectory) fs) removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () removeWith logger remover f = remover f `Exception.catchIO` diff --git a/GHC/Utils/Touch.hs b/GHC/Utils/Touch.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Touch.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE CPP #-} + +module GHC.Utils.Touch (touch) where + +import GHC.Prelude + +#if defined(mingw32_HOST_OS) +import System.Win32.File +import System.Win32.Time +#else +import System.Posix.Files +import System.Posix.IO +#endif + +-- | Set the mtime of the given file to the current time. +touch :: FilePath -> IO () +touch file = do +#if defined(mingw32_HOST_OS) + hdl <- createFile file gENERIC_WRITE fILE_SHARE_NONE Nothing oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing + t <- getSystemTimeAsFileTime + setFileTime hdl Nothing Nothing (Just t) + closeHandle hdl +#else + let oflags = defaultFileFlags { noctty = True, creat = Just 0o666 } + fd <- openFd file WriteOnly oflags + touchFd fd + closeFd fd +#endif diff --git a/GHC/Utils/Trace.hs b/GHC/Utils/Trace.hs --- a/GHC/Utils/Trace.hs +++ b/GHC/Utils/Trace.hs @@ -8,6 +8,7 @@ , pprSTrace , pprTraceException , warnPprTrace + , warnPprTraceM , pprTraceUserWarning , trace ) @@ -83,6 +84,9 @@ = pprDebugAndThen traceSDocContext trace (text "WARNING:") (text s $$ msg $$ withFrozenCallStack traceCallStackDoc ) x + +warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f () +warnPprTraceM b s doc = withFrozenCallStack warnPprTrace b s doc (pure ()) -- | For when we want to show the user a non-fatal WARNING so that they can -- report a GHC bug, but don't want to panic. diff --git a/GHC/Utils/Unique.hs b/GHC/Utils/Unique.hs --- a/GHC/Utils/Unique.hs +++ b/GHC/Utils/Unique.hs @@ -2,12 +2,12 @@ {- Work around #23537 -On 32 bit systems, GHC's codegen around 64 bit numbers is not quite -complete. This led to panics mentioning missing cases in iselExpr64. -Now that GHC uses Word64 for its uniques, these panics have started -popping up whenever a unique is compared to many other uniques in one -function. As a workaround we use these two functions which are not -inlined on 32 bit systems, thus preventing the panics. +On 32 bit systems, GHC's codegen around 64 bit numbers used to be incomplete +before GHC 9.10. This led to panics mentioning missing cases in iselExpr64. +Now that GHC uses Word64 for its uniques, these panics have started popping up +whenever a unique is compared to many other uniques in one function. As a +workaround we use these two functions which are not inlined, on 32 bit systems +and if compiled with versions before GHC 9.9, thus preventing the panics. -} module GHC.Utils.Unique (sameUnique, anyOfUnique) where @@ -18,7 +18,7 @@ import GHC.Types.Unique (Unique, Uniquable (getUnique)) -#if WORD_SIZE_IN_BITS == 32 +#if WORD_SIZE_IN_BITS == 32 && !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) {-# NOINLINE sameUnique #-} #else {-# INLINE sameUnique #-} @@ -26,7 +26,7 @@ sameUnique :: Uniquable a => a -> a -> Bool sameUnique x y = getUnique x == getUnique y -#if WORD_SIZE_IN_BITS == 32 +#if WORD_SIZE_IN_BITS == 32 && !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) {-# NOINLINE anyOfUnique #-} #else {-# INLINE anyOfUnique #-} diff --git a/GHC/Utils/Word64.hs b/GHC/Utils/Word64.hs --- a/GHC/Utils/Word64.hs +++ b/GHC/Utils/Word64.hs @@ -6,14 +6,14 @@ import GHC.Prelude import GHC.Utils.Panic.Plain (assert) +import GHC.Utils.Misc (HasDebugCallStack) import Data.Word -import GHC.Stack -intToWord64 :: HasCallStack => Int -> Word64 +intToWord64 :: HasDebugCallStack => Int -> Word64 intToWord64 x = assert (0 <= x) (fromIntegral x) -word64ToInt :: HasCallStack => Word64 -> Int +word64ToInt :: HasDebugCallStack => Word64 -> Int word64ToInt x = assert (x <= fromIntegral (maxBound :: Int)) (fromIntegral x) truncateWord64ToWord32 :: Word64 -> Word32 diff --git a/GHC/Wasm/ControlFlow/FromCmm.hs b/GHC/Wasm/ControlFlow/FromCmm.hs --- a/GHC/Wasm/ControlFlow/FromCmm.hs +++ b/GHC/Wasm/ControlFlow/FromCmm.hs @@ -15,17 +15,16 @@ import GHC.Cmm import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dominators import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label 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 @@ -139,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 @@ -314,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 @@ -334,7 +331,7 @@ CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger k) width)] where width = cmmExprWidth platform e -addToList :: (IsMap map) => ([a] -> [a]) -> KeyOf map -> map [a] -> map [a] +addToList :: ([a] -> [a]) -> Label -> LabelMap [a] -> LabelMap [a] addToList consx = mapAlter add where add Nothing = Just (consx []) add (Just xs) = Just (consx xs) diff --git a/Language/Haskell/Syntax.hs b/Language/Haskell/Syntax.hs --- a/Language/Haskell/Syntax.hs +++ b/Language/Haskell/Syntax.hs @@ -25,7 +25,6 @@ module Language.Haskell.Syntax.Module.Name, module Language.Haskell.Syntax.Pat, module Language.Haskell.Syntax.Type, - module Language.Haskell.Syntax.Concrete, module Language.Haskell.Syntax.Extension, ModuleName(..), HsModule(..) ) where @@ -36,7 +35,6 @@ import Language.Haskell.Syntax.ImpExp import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type @@ -68,16 +66,7 @@ -- -- All we actually declare here is the top-level structure for a module. data HsModule p - = -- | 'GHC.Parser.Annotation.AnnKeywordId's - -- - -- - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere' - -- - -- - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around - -- hsmodImports,hsmodDecls if this style is used. - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - HsModule { + = HsModule { hsmodExt :: XCModule p, -- ^ HsModule extension point hsmodName :: Maybe (XRec p ModuleName), @@ -91,15 +80,8 @@ -- - @Just []@: export /nothing/ -- -- - @Just [...]@: as you would expect... - -- - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen' - -- ,'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation hsmodImports :: [LImportDecl p], hsmodDecls :: [LHsDecl p] -- ^ Type, class, value, and interface signature decls } | XModule !(XXModule p) - diff --git a/Language/Haskell/Syntax/Basic.hs b/Language/Haskell/Syntax/Basic.hs --- a/Language/Haskell/Syntax/Basic.hs +++ b/Language/Haskell/Syntax/Basic.hs @@ -2,11 +2,11 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} module Language.Haskell.Syntax.Basic where -import Data.Data +import Data.Data (Data) import Data.Eq import Data.Ord import Data.Bool -import Data.Int (Int) +import Prelude import GHC.Data.FastString (FastString) import Control.DeepSeq @@ -96,3 +96,33 @@ | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified | NoSrcUnpack -- ^ no unpack pragma deriving (Eq, Data) + +{- +************************************************************************ +* * +Fixity +* * +************************************************************************ +-} + +-- | Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Eq, Data) + +data FixityDirection + = InfixL + | InfixR + | InfixN + deriving (Eq, Data) + +instance NFData FixityDirection where + rnf InfixL = () + rnf InfixR = () + rnf InfixN = () + +data Fixity = Fixity Int FixityDirection + deriving (Eq, Data) + +instance NFData Fixity where + rnf (Fixity i d) = rnf i `seq` rnf d `seq` () diff --git a/Language/Haskell/Syntax/Binds.hs b/Language/Haskell/Syntax/Binds.hs --- a/Language/Haskell/Syntax/Binds.hs +++ b/Language/Haskell/Syntax/Binds.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,20 +26,15 @@ ( LHsExpr , MatchGroup , GRHSs ) -import {-# SOURCE #-} Language.Haskell.Syntax.Pat - ( LPat ) - +import {-# SOURCE #-} Language.Haskell.Syntax.Pat( LPat ) +import Language.Haskell.Syntax.BooleanFormula (LBooleanFormula) import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Basic ( Fixity ) -import GHC.Types.Fixity (Fixity) -import GHC.Data.Bag (Bag) import GHC.Types.Basic (InlinePragma) - -import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.SourceText (StringLiteral) -import Data.Void import Data.Bool import Data.Maybe @@ -127,7 +123,7 @@ type HsBind id = HsBindLR id id -- | Located Haskell Bindings with separate Left and Right identifier types -type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) +type LHsBindsLR idL idR = [LHsBindLR idL idR] -- | Located Haskell Binding with separate Left and Right identifier types type LHsBindLR idL idR = XRec idL (HsBindLR idL idR) @@ -162,6 +158,25 @@ Just x = e (x) = e x :: Ty = e + +Note [Multiplicity annotations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Multiplicity annotations are stored in the pat_mult field on PatBinds, +represented by the HsMultAnn data type + + HsNoMultAnn <=> no annotation in the source file + HsPct1Ann <=> the %1 annotation + HsMultAnn <=> the %t annotation, where `t` is some type + +In case of HsNoMultAnn the typechecker infers a multiplicity. + +We don't need to store a multiplicity on FunBinds: +- let %1 x = … is parsed as a PatBind. So we don't need an annotation before + typechecking. +- the multiplicity that the typechecker infers is stored in the binder's Var for + the desugarer to use. It's only relevant for strict FunBinds, see Wrinkle 1 in + Note [Desugar Strict binds] in GHC.HsToCore.Binds as, in Core, let expressions + don't have multiplicity annotations. -} -- | Haskell Binding with separate Left and Right id's @@ -184,15 +199,6 @@ -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their -- 'MatchContext'. See Note [FunBind vs PatBind] for -- details about the relationship between FunBind and PatBind. - -- - -- 'GHC.Parser.Annotation.AnnKeywordId's - -- - -- - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches - -- - -- - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', - -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation FunBind { fun_ext :: XFunBind idL idR, @@ -209,16 +215,11 @@ -- That case is done by FunBind. -- See Note [FunBind vs PatBind] for details about the -- relationship between FunBind and PatBind. - - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang', - -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', - -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | PatBind { pat_ext :: XPatBind idL idR, pat_lhs :: LPat idL, + pat_mult :: HsMultAnn idL, + -- ^ See Note [Multiplicity annotations]. pat_rhs :: GRHSs idR (LHsExpr idR) } @@ -236,23 +237,10 @@ | PatSynBind (XPatSynBind idL idR) (PatSynBind idL idR) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', - -- 'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual', - -- 'GHC.Parser.Annotation.AnnWhere' - -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | XHsBindsLR !(XXHsBindsLR idL idR) --- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', --- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow', --- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@, --- 'GHC.Parser.Annotation.AnnClose' @'}'@, - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | Pattern Synonym binding data PatSynBind idL idR = PSB { psb_ext :: XPSB idL idR, @@ -263,7 +251,6 @@ } | XPatSynBind !(XXPatSynBind idL idR) - {- ************************************************************************ * * @@ -284,16 +271,8 @@ -- | Located Implicit Parameter Binding type LIPBind id = XRec id (IPBind id) --- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a --- list --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | Implicit parameter bindings. --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual' - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data IPBind id = IPBind (XCIPBind id) @@ -330,11 +309,6 @@ -- fresh meta vars in the type. Their names are stored in the type -- signature that brought them into scope, in this third field to be -- more specific. - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon', - -- 'GHC.Parser.Annotation.AnnComma' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation TypeSig (XTypeSig pass) [LIdP pass] -- LHS of the signature; e.g. f,g,h :: blah @@ -343,12 +317,6 @@ -- | A pattern synonym type signature -- -- > pattern Single :: () => (Show a) => a -> [a] - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', - -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall' - -- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass) -- P :: forall a b. Req => Prov => ty @@ -359,49 +327,25 @@ -- op :: a -> a -- Ordinary -- default op :: Eq a => a -> a -- Generic default -- No wildcards allowed here - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault', - -- 'GHC.Parser.Annotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) -- | An ordinary fixity declaration -- -- > infixl 8 *** - -- - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix', - -- 'GHC.Parser.Annotation.AnnVal' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | FixSig (XFixSig pass) (FixitySig pass) -- | An inline pragma -- -- > {#- INLINE f #-} - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@, - -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde', - -- 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | InlineSig (XInlineSig pass) (LIdP pass) -- Function name InlinePragma -- Never defaultInlinePragma - -- | A specialisation pragma + -- | An old-form specialisation pragma -- -- > {-# SPECIALISE f :: Int -> Int #-} -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, - -- 'GHC.Parser.Annotation.AnnTilde', - -- 'GHC.Parser.Annotation.AnnVal', - -- 'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@, - -- 'GHC.Parser.Annotation.AnnDcolon' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- NB: this constructor is deprecated and will be removed in GHC 9.18 (#25540) | SpecSig (XSpecSig pass) (LIdP pass) -- Specialise a function or datatype ... [LHsSigType pass] -- ... to these types @@ -409,29 +353,29 @@ -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE + -- | A new-form specialisation pragma (see GHC Proposal #493) + -- e.g. {-# SPECIALISE f @Int 1 :: Int -> Int #-} + -- See Note [Overview of SPECIALISE pragmas] + | SpecSigE (XSpecSigE pass) + (RuleBndrs pass) + (LHsExpr pass) -- Expression to specialise + InlinePragma + -- The expression should be of form + -- f a1 ... an [ :: sig ] + -- with an optional type signature + -- | A specialisation pragma for instance declarations only -- -- > {-# SPECIALISE instance Eq [Int] #-} -- -- (Class tys); should be a specialisation of the -- current instance declaration - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | SpecInstSig (XSpecInstSig pass) (LHsSigType pass) -- | A minimal complete definition pragma -- -- > {-# MINIMAL a | (b, c | (d | e)) #-} - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma', - -- 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass)) + | MinimalSig (XMinimalSig pass) (LBooleanFormula pass) -- | A "set cost centre" pragma for declarations -- @@ -452,7 +396,7 @@ -- complete matchings which, for example, arise from pattern -- synonym definitions. | CompleteMatchSig (XCompleteMatchSig pass) - (XRec pass [LIdP pass]) + [LIdP pass] (Maybe (LIdP pass)) | XSig !(XXSig pass) @@ -474,8 +418,9 @@ isTypeLSig _ = False isSpecLSig :: forall p. UnXRec p => LSig p -> Bool -isSpecLSig (unXRec @p -> SpecSig {}) = True -isSpecLSig _ = False +isSpecLSig (unXRec @p -> SpecSig {}) = True +isSpecLSig (unXRec @p -> SpecSigE {}) = True +isSpecLSig _ = False isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True @@ -484,6 +429,7 @@ isPragLSig :: forall p. UnXRec p => LSig p -> Bool -- Identifies pragmas isPragLSig (unXRec @p -> SpecSig {}) = True +isPragLSig (unXRec @p -> SpecSigE {}) = True isPragLSig (unXRec @p -> InlineSig {}) = True isPragLSig (unXRec @p -> SCCFunSig {}) = True isPragLSig (unXRec @p -> CompleteMatchSig {}) = True @@ -506,6 +452,40 @@ isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True isCompleteMatchSig _ = False +{- ********************************************************************* +* * + Rule binders +* * +********************************************************************* -} + +data RuleBndrs pass = RuleBndrs + { rb_ext :: XCRuleBndrs pass + -- After typechecking rb_ext contains /all/ the quantified variables + -- both term variables and type varibles + , rb_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] + -- ^ User-written forall'd type vars; preserved for pretty-printing + , rb_tmvs :: [LRuleBndr (NoGhcTc pass)] + -- ^ User-written forall'd term vars; preserved for pretty-printing + } + | XRuleBndrs !(XXRuleBndrs pass) + +-- | Located Rule Binder +type LRuleBndr pass = XRec pass (RuleBndr pass) + +-- | Rule Binder +data RuleBndr pass + = RuleBndr (XCRuleBndr pass) (LIdP pass) + | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass) + | XRuleBndr !(XXRuleBndr pass) + -- ^ + -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', + -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' + + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + +collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] + {- ************************************************************************ * * @@ -515,7 +495,7 @@ -} -- | Haskell Pattern Synonym Details -type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass] +type HsPatSynDetails pass = HsConDetails (LIdP pass) [RecordPatSynField pass] -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field diff --git a/Language/Haskell/Syntax/BooleanFormula.hs b/Language/Haskell/Syntax/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/BooleanFormula.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module Language.Haskell.Syntax.BooleanFormula( + BooleanFormula(..), LBooleanFormula, + mkVar, mkFalse, mkTrue, mkBool, mkAnd, mkOr + ) where + +import Prelude hiding ( init, last ) +import Data.List ( nub ) +import Language.Haskell.Syntax.Extension (XRec, UnXRec (..), LIdP) + + +-- types +type LBooleanFormula p = XRec p (BooleanFormula p) +data BooleanFormula p = Var (LIdP p) | And [LBooleanFormula p] | Or [LBooleanFormula p] + | Parens (LBooleanFormula p) + +-- instances +deriving instance (Eq (LIdP p), Eq (LBooleanFormula p)) => Eq (BooleanFormula p) + +-- smart constructors +-- see note [Simplification of BooleanFormulas] +mkVar :: LIdP p -> BooleanFormula p +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula p +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula p +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkAnd = maybe mkFalse (mkAnd' . nub . concat) . mapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: LBooleanFormula p -> Maybe [LBooleanFormula p] + fromAnd bf = case unXRec @p bf of + (And xs) -> Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + (Or []) -> Nothing + -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + _ -> Just [bf] + mkAnd' [x] = unXRec @p x + mkAnd' xs = And xs + +mkOr :: forall p. (UnXRec p, Eq (LIdP p), Eq (LBooleanFormula p)) => [LBooleanFormula p] -> BooleanFormula p +mkOr = maybe mkTrue (mkOr' . nub . concat) . mapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr bf = case unXRec @p bf of + (Or xs) -> Just xs + (And []) -> Nothing + _ -> Just [bf] + mkOr' [x] = unXRec @p x + mkOr' xs = Or xs diff --git a/Language/Haskell/Syntax/Concrete.hs b/Language/Haskell/Syntax/Concrete.hs deleted file mode 100644 --- a/Language/Haskell/Syntax/Concrete.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | Bits of concrete syntax (tokens, layout). - -module Language.Haskell.Syntax.Concrete - ( LHsToken, LHsUniToken, - HsToken(HsTok), - HsUniToken(HsNormalTok, HsUnicodeTok), - LayoutInfo(ExplicitBraces, VirtualBraces, NoLayoutInfo) - ) where - -import GHC.Prelude -import GHC.TypeLits (Symbol, KnownSymbol) -import Data.Data -import Language.Haskell.Syntax.Extension - -type LHsToken tok p = XRec p (HsToken tok) -type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) - --- | A token stored in the syntax tree. For example, when parsing a --- let-expression, we store @HsToken "let"@ and @HsToken "in"@. --- The locations of those tokens can be used to faithfully reproduce --- (exactprint) the original program text. -data HsToken (tok :: Symbol) = HsTok - --- | With @UnicodeSyntax@, there might be multiple ways to write the same --- token. For example an arrow could be either @->@ or @→@. This choice must be --- recorded in order to exactprint such tokens, so instead of @HsToken "->"@ we --- introduce @HsUniToken "->" "→"@. --- --- See also @IsUnicodeSyntax@ in @GHC.Parser.Annotation@; we do not use here to --- avoid a dependency. -data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok - -deriving instance Eq (HsToken tok) -deriving instance KnownSymbol tok => Data (HsToken tok) -deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) - --- | Layout information for declarations. -data LayoutInfo pass = - - -- | Explicit braces written by the user. - -- - -- @ - -- class C a where { foo :: a; bar :: a } - -- @ - ExplicitBraces !(LHsToken "{" pass) !(LHsToken "}" pass) - | - -- | Virtual braces inserted by the layout algorithm. - -- - -- @ - -- class C a where - -- foo :: a - -- bar :: a - -- @ - VirtualBraces - !Int -- ^ Layout column (indentation level, begins at 1) - | - -- | Empty or compiler-generated blocks do not have layout information - -- associated with them. - NoLayoutInfo diff --git a/Language/Haskell/Syntax/Decls.hs b/Language/Haskell/Syntax/Decls.hs --- a/Language/Haskell/Syntax/Decls.hs +++ b/Language/Haskell/Syntax/Decls.hs @@ -36,12 +36,9 @@ -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup(..), - tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, - tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations @@ -49,7 +46,7 @@ TyFamInstDecl(..), LTyFamInstDecl, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, - FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats, + FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats, LClsInstDecl, ClsInstDecl(..), -- ** Standalone deriving declarations @@ -70,7 +67,8 @@ CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, - HsConDeclH98Details, HsConDeclGADTDetails(..), + HsConDeclH98Details, + HsConDeclGADTDetails(..), XPrefixConGADT, XRecConGADT, XXConDeclGADTDetails, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations @@ -85,7 +83,7 @@ FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, -- * Grouping - HsGroup(..), hsGroupInstDecls, + HsGroup(..) ) where -- friends: @@ -94,33 +92,28 @@ -- Because Expr imports Decls via HsBracket import Language.Haskell.Syntax.Binds -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import Language.Haskell.Syntax.Basic (Role) +import Language.Haskell.Syntax.Basic (Role, LexicalFixity) +import Language.Haskell.Syntax.Specificity (Specificity) import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation - ,TyConFlavour(..), TypeOrData(..)) + ,TyConFlavour(..), TypeOrData(..), NewOrData(..)) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) -import GHC.Types.Fixity (LexicalFixity) -import GHC.Core.Type (Specificity) import GHC.Unit.Module.Warnings (WarningTxt) -import GHC.Utils.Panic.Plain ( assert ) import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST import Control.Monad +import Control.Exception (assert) import Data.Data hiding (TyCon, Fixity, Infix) -import Data.Void import Data.Maybe import Data.String -import Data.Function import Data.Eq import Data.Int import Data.Bool import Prelude (Show) -import qualified Data.List import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) @@ -135,12 +128,7 @@ type LHsDecl p = XRec p (HsDecl p) -- ^ When in a list this may have - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' - -- --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | A Haskell Declaration data HsDecl p = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration @@ -240,9 +228,6 @@ | XHsGroup !(XXHsGroup p) -hsGroupInstDecls :: HsGroup id -> [LInstDecl id] -hsGroupInstDecls = (=<<) group_instds . hs_tyclds - -- | Located Splice Declaration type LSpliceDecl pass = XRec pass (SpliceDecl pass) @@ -407,24 +392,9 @@ -- | A type or class declaration. data TyClDecl pass = -- | @type/data family T :: *->*@ - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', - -- 'GHC.Parser.Annotation.AnnData', - -- 'GHC.Parser.Annotation.AnnFamily','GHC.Parser.Annotation.AnnDcolon', - -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpenP', - -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnCloseP', - -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnRarrow', - -- 'GHC.Parser.Annotation.AnnVbar' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } | -- | @type@ declaration - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', - -- 'GHC.Parser.Annotation.AnnEqual', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renamer, FVs , tcdLName :: LIdP pass -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an @@ -434,14 +404,6 @@ , tcdRhs :: LHsType pass } -- ^ RHS of type declaration | -- | @data@ declaration - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData', - -- 'GHC.Parser.Annotation.AnnFamily', - -- 'GHC.Parser.Annotation.AnnNewType', - -- 'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnDcolon' - -- 'GHC.Parser.Annotation.AnnWhere', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs , tcdLName :: LIdP pass -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables @@ -449,16 +411,7 @@ , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdDataDefn :: HsDataDefn pass } - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass', - -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' - -- - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar', - -- 'GHC.Parser.Annotation.AnnComma' - -- 'GHC.Parser.Annotation.AnnRarrow' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdLayout :: !(LayoutInfo pass), -- ^ Explicit or virtual braces - -- See Note [Class LayoutInfo] tcdCtxt :: Maybe (LHsContext pass), -- ^ Context... tcdLName :: LIdP pass, -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables @@ -501,9 +454,9 @@ Note [Family instance declaration binders] -} -{- Note [Class LayoutInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The LayoutInfo is used to associate Haddock comments with parts of the declaration. +{- Note [Class EpLayout] +~~~~~~~~~~~~~~~~~~~~~~~~ +The EpLayout is used to associate Haddock comments with parts of the declaration. Compare the following examples: class C a where @@ -569,11 +522,6 @@ -- Dealing with names -tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass -tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs -tyClDeclTyVars d = tcdTyVars d - - {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied @@ -673,25 +621,26 @@ {- Note [TyClGroups and dependency analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A TyClGroup represents a strongly connected components of type/class/instance -decls, together with the role annotations for the type/class declarations. +A TyClGroup represents a strongly connected component of type/class/instance +decls, together with the role annotations and standalone kind signatures for the +type/class declarations. The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order sequence of strongly-connected components. Invariants - * The type and class declarations, group_tyclds, may depend on each - other, or earlier TyClGroups, but not on later ones + * The type and class declarations, group_tyclds, may lexically depend + on each other, or earlier TyClGroups, but not on later ones * The role annotations, group_roles, are role-annotations for some or all of the types and classes in group_tyclds (only). * The instance declarations, group_instds, may (and usually will) - depend on group_tyclds, or on earlier TyClGroups, but not on later - ones. + lexically depend on group_tyclds, or on earlier TyClGroups, but + not on later ones. -See Note [Dependency analysis of type, class, and instance decls] -in GHC.Rename.Module for more info. +See Note [Dependency analysis of type and class decls] in GHC.Rename.Module +for more info. -} -- | Type or Class Group @@ -704,19 +653,6 @@ | XTyClGroup !(XXTyClGroup pass) -tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] -tyClGroupTyClDecls = Data.List.concatMap group_tyclds - -tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] -tyClGroupInstDecls = Data.List.concatMap group_instds - -tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] -tyClGroupRoleDecls = Data.List.concatMap group_roles - -tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass] -tyClGroupKindSigs = Data.List.concatMap group_kisigs - - {- ********************************************************************* * * Data and type family declarations @@ -792,24 +728,10 @@ -- | type Family Result Signature data FamilyResultSig pass = -- see Note [FamilyResultSig] NoSig (XNoSig pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | KindSig (XCKindSig pass) (LHsKind pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon', - -- 'GHC.Parser.Annotation.AnnCloseP' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon', - -- 'GHC.Parser.Annotation.AnnCloseP', 'GHC.Parser.Annotation.AnnEqual' | XFamilyResultSig !(XXFamilyResultSig pass) - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -- | Located type Family Declaration @@ -828,16 +750,7 @@ , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann } | XFamilyDecl !(XXFamilyDecl pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', - -- 'GHC.Parser.Annotation.AnnData', 'GHC.Parser.Annotation.AnnFamily', - -- 'GHC.Parser.Annotation.AnnWhere', 'GHC.Parser.Annotation.AnnOpenP', - -- 'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnCloseP', - -- 'GHC.Parser.Annotation.AnnEqual', 'GHC.Parser.Annotation.AnnRarrow', - -- 'GHC.Parser.Annotation.AnnVbar' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - - -- | Located Injectivity Annotation type LInjectivityAnn pass = XRec pass (InjectivityAnn pass) @@ -852,10 +765,6 @@ data InjectivityAnn pass = InjectivityAnn (XCInjectivityAnn pass) (LIdP pass) [LIdP pass] - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | XInjectivityAnn !(XXInjectivityAnn pass) data FamilyInfo pass @@ -871,7 +780,7 @@ -> TyConFlavour tc familyInfoTyConFlavour mb_parent_tycon info = case info of - DataFamily -> OpenFamilyFlavour IAmData mb_parent_tycon + DataFamily -> OpenFamilyFlavour (IAmData DataType) mb_parent_tycon OpenTypeFamily -> OpenFamilyFlavour IAmType mb_parent_tycon ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon] @@ -941,11 +850,6 @@ type LHsDerivingClause pass = XRec pass (HsDerivingClause pass) -- | A single @deriving@ clause of a data declaration. --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : --- 'GHC.Parser.Annotation.AnnDeriving', 'GHC.Parser.Annotation.AnnStock', --- 'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype', --- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' data HsDerivingClause pass -- See Note [Deriving strategies] in GHC.Tc.Deriv = HsDerivingClause @@ -1011,12 +915,6 @@ for CUSKs, so this would be a separate feature. -} --- | When we only care whether a data-type declaration is `data` or `newtype`, but not what constructors it has -data NewOrData - = NewType -- ^ @newtype Blah ...@ - | DataType -- ^ @data Blah ...@ - deriving ( Eq, Data ) -- Needed because Demand derives Eq - -- | Whether a data-type declaration is @data@ or @newtype@, and its constructors. data DataDefnCons a = NewTypeCon -- @newtype N x = MkN blah@ @@ -1031,8 +929,8 @@ dataDefnConsNewOrData :: DataDefnCons a -> NewOrData dataDefnConsNewOrData = \ case - NewTypeCon _ -> NewType - DataTypeCons _ _ -> DataType + NewTypeCon {} -> NewType + DataTypeCons {} -> DataType -- | Are the constructors within a @type data@ declaration? -- See Note [Type data declarations] in GHC.Rename.Module. @@ -1047,11 +945,7 @@ -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass) - -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when - -- in a GADT constructor list - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | -- -- @ @@ -1067,27 +961,21 @@ -- data T a where -- Int `MkT` Int :: T Int -- @ --- --- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', --- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnCLose', --- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnVbar', --- 'GHC.Parser.Annotation.AnnDarrow','GHC.Parser.Annotation.AnnDarrow', --- 'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot' --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | data Constructor Declaration data ConDecl pass = ConDeclGADT { con_g_ext :: XConDeclGADT pass , con_names :: NonEmpty (LIdP pass) - , con_dcolon :: !(LHsUniToken "::" "∷" pass) -- The following fields describe the type after the '::' -- See Note [GADT abstract syntax] - , con_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) - -- ^ The outermost type variable binders, be they explicit or - -- implicit. The 'XRec' is used to anchor exact print - -- annotations, AnnForall and AnnDot. + , con_outer_bndrs :: XRec pass (HsOuterSigTyVarBndrs pass) + -- ^ The outermost type variable binders, be they explicit or implicit; + -- cf. HsSigType that also stores the outermost sig_bndrs separately + -- from the forall telescopes in sig_body. + -- See Note [Representing type signatures] in Language.Haskell.Syntax.Type + , con_inner_bndrs :: [HsForAllTelescope pass] + -- ^ The forall telescopes other than the outermost invisible forall. , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix , con_res_ty :: LHsType pass -- ^ Result type @@ -1231,7 +1119,7 @@ -- | The arguments in a Haskell98-style data constructor. type HsConDeclH98Details pass - = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass]) + = HsConDetails (HsConDeclField pass) (XRec pass [LHsConDeclRecField pass]) -- The Void argument to HsConDetails here is a reflection of the fact that -- type applications are not allowed in data constructor declarations. @@ -1242,9 +1130,14 @@ -- derived Show instances—see Note [Infix GADT constructors] in -- GHC.Tc.TyCl—but that is an orthogonal concern.) data HsConDeclGADTDetails pass - = PrefixConGADT [HsScaled pass (LBangType pass)] - | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass) + = PrefixConGADT !(XPrefixConGADT pass) [HsConDeclField pass] + | RecConGADT !(XRecConGADT pass) (XRec pass [LHsConDeclRecField pass]) + | XConDeclGADTDetails !(XXConDeclGADTDetails pass) +type family XPrefixConGADT p +type family XRecConGADT p +type family XXConDeclGADTDetails p + {- ************************************************************************ * * @@ -1278,13 +1171,13 @@ -- | Located Type Family Instance Equation type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass) - -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' - -- when in a list --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - --- | Haskell Type Patterns -type HsTyPats pass = [LHsTypeArg pass] +-- | HsFamEqnPats represents patterns on the left-hand side of a type instance, +-- e.g. `type instance F @k (a :: k) = a` has patterns `@k` and `(a :: k)`. +-- +-- HsFamEqnPats used to be called HsTyPats but it was renamed to avoid confusion +-- with a different notion of type patterns, see #23657. +type HsFamEqnPats pass = [LHsTypeArg pass] {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1337,11 +1230,6 @@ data TyFamInstDecl pass = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl pass , tfid_eqn :: TyFamInstEqn pass } - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', - -- 'GHC.Parser.Annotation.AnnInstance', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | XTyFamInstDecl !(XXTyFamInstDecl pass) ----------------- Data family instances ------------- @@ -1352,15 +1240,7 @@ -- | Data Family Instance Declaration newtype DataFamInstDecl pass = DataFamInstDecl { dfid_eqn :: FamEqn pass (HsDataDefn pass) } - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData', - -- 'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnInstance', - -- 'GHC.Parser.Annotation.AnnDcolon' - -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - ----------------- Family instances (common types) ------------- -- | Family Equation @@ -1374,26 +1254,18 @@ { feqn_ext :: XCFamEqn pass rhs , feqn_tycon :: LIdP pass , feqn_bndrs :: HsOuterFamEqnTyVarBndrs pass -- ^ Optional quantified type vars - , feqn_pats :: HsTyPats pass + , feqn_pats :: HsFamEqnPats pass , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual' | XFamEqn !(XXFamEqn pass rhs) - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - ----------------- Class instances ------------- -- | Located Class Instance Declaration type LClsInstDecl pass = XRec pass (ClsInstDecl pass) -- | Class Instance Declaration --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance', --- 'GHC.Parser.Annotation.AnnWhere', --- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data ClsInstDecl pass = ClsInstDecl { cid_ext :: XCClsInstDecl pass @@ -1405,10 +1277,6 @@ , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances , cid_overlap_mode :: Maybe (XRec pass OverlapMode) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation } | XClsInstDecl !(XXClsInstDecl pass) @@ -1458,12 +1326,6 @@ , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (XRec pass OverlapMode) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDeriving', - -- 'GHC.Parser.Annotation.AnnInstance', 'GHC.Parser.Annotation.AnnStock', - -- 'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype', - -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation } | XDerivDecl !(XXDerivDecl pass) @@ -1499,22 +1361,18 @@ \subsection[DefaultDecl]{A @default@ declaration} * * ************************************************************************ - -There can only be one default declaration per module, but it is hard -for the parser to check that; we pass them all through in the abstract -syntax, and that restriction must be checked in the front end. -} -- | Located Default Declaration type LDefaultDecl pass = XRec pass (DefaultDecl pass) +-- See Note [Named default declarations] in GHC.Tc.Gen.Default -- | Default Declaration data DefaultDecl pass - = DefaultDecl (XCDefaultDecl pass) [LHsType pass] - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnDefault', - -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + = DefaultDecl + { defd_ext :: XCDefaultDecl pass + , defd_class :: Maybe (LIdP pass) -- Nothing in absence of NamedDefaults + , defd_defaults :: [LHsType pass] } | XDefaultDecl !(XXDefaultDecl pass) {- @@ -1547,12 +1405,6 @@ , fd_name :: LIdP pass -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty , fd_fe :: ForeignExport pass } - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign', - -- 'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport', - -- 'GHC.Parser.Annotation.AnnDcolon' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | XForeignDecl !(XXForeignDecl pass) {- @@ -1582,7 +1434,7 @@ -- * `Safety' is irrelevant for `CLabel' and `CWrapper' -- CImport (XCImport pass) - (XRec pass CCallConv) -- ccall or stdcall + (XRec pass CCallConv) -- ccall (XRec pass Safety) -- interruptible, safe or unsafe (Maybe Header) -- name of C header CImportSpec -- details of the C entity @@ -1629,41 +1481,13 @@ -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: XRec pass RuleName -- ^ Note [Pragma source text] in "GHC.Types.SourceText" - , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] - -- ^ Forall'd type vars - , rd_tmvs :: [LRuleBndr pass] - -- ^ Forall'd term vars, before typechecking; after typechecking - -- this includes all forall'd vars - , rd_lhs :: XRec pass (HsExpr pass) - , rd_rhs :: XRec pass (HsExpr pass) + , rd_act :: Activation + , rd_bndrs :: RuleBndrs pass + , rd_lhs :: XRec pass (HsExpr pass) + , rd_rhs :: XRec pass (HsExpr pass) } - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnTilde', - -- 'GHC.Parser.Annotation.AnnVal', - -- 'GHC.Parser.Annotation.AnnClose', - -- 'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot', - -- 'GHC.Parser.Annotation.AnnEqual', | XRuleDecl !(XXRuleDecl pass) --- | Located Rule Binder -type LRuleBndr pass = XRec pass (RuleBndr pass) - --- | Rule Binder -data RuleBndr pass - = RuleBndr (XCRuleBndr pass) (LIdP pass) - | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass) - | XRuleBndr !(XXRuleBndr pass) - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] -collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] - {- ************************************************************************ * * @@ -1732,12 +1556,6 @@ data AnnDecl pass = HsAnnotation (XHsAnnotation pass) (AnnProvenance pass) (XRec pass (HsExpr pass)) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnType' - -- 'GHC.Parser.Annotation.AnnModule' - -- 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | XAnnDecl !(XXAnnDecl pass) -- | Annotation Provenance @@ -1772,8 +1590,4 @@ = RoleAnnotDecl (XCRoleAnnotDecl pass) (LIdP pass) -- type constructor [XRec pass (Maybe Role)] -- optional annotations - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType', - -- 'GHC.Parser.Annotation.AnnRole' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | XRoleAnnotDecl !(XXRoleAnnotDecl pass) diff --git a/Language/Haskell/Syntax/Expr.hs b/Language/Haskell/Syntax/Expr.hs --- a/Language/Haskell/Syntax/Expr.hs +++ b/Language/Haskell/Syntax/Expr.hs @@ -25,16 +25,14 @@ import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name (ModuleName) import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds -- others: -import GHC.Types.Fixity (LexicalFixity(Infix), Fixity) -import GHC.Types.SourceText (StringLiteral, SourceText) +import GHC.Types.SourceText (StringLiteral) -import GHC.Unit.Module (ModuleName) import GHC.Data.FastString (FastString) -- libraries: @@ -43,7 +41,6 @@ import Data.Eq import Data.Maybe import Data.List.NonEmpty ( NonEmpty ) -import GHC.Types.Name.Reader {- Note [RecordDotSyntax field updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -132,7 +129,7 @@ type LFieldLabelStrings p = XRec p (FieldLabelStrings p) newtype FieldLabelStrings p = - FieldLabelStrings [XRec p (DotFieldOcc p)] + FieldLabelStrings (NonEmpty (XRec p (DotFieldOcc p))) -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates]. @@ -172,11 +169,7 @@ -- | Located Haskell Expression type LHsExpr p = XRec p (HsExpr p) - -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when - -- in a list - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - ------------------------- {- Note [NoSyntaxExpr] ~~~~~~~~~~~~~~~~~~~~~~ @@ -240,7 +233,7 @@ NB 2: The notation getField @"size" e is short for HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e. -We track the original parsed syntax via HsExpanded. +We track the original parsed syntax via ExpandedThingRn. -} @@ -261,32 +254,88 @@ transforms the record-selector Name to an Id. -} --- | A Haskell expression. -data HsExpr p - = HsVar (XVar p) - (LIdP p) -- ^ Variable - -- See Note [Located RdrNames] +{- Note [Types in terms] +~~~~~~~~~~~~~~~~~~~~~~~~ +Types-in-terms is a notion introduced by GHC Proposal #281. It refers +to the extension of term syntax (HsExpr in the AST, infixexp2 in Parser.y) +with constructs that previously could only occur at the type level: - | HsUnboundVar (XUnboundVar p) - RdrName -- ^ Unbound variable; also used for "holes" - -- (_ or _x). - -- Turned from HsVar to HsUnboundVar by the - -- renamer, when it finds an out-of-scope - -- variable or hole. - -- The (XUnboundVar p) field becomes an HoleExprRef - -- after typechecking; this is where the - -- erroring expression will be written after - -- solving. See Note [Holes] in GHC.Tc.Types.Constraint. + * Function arrows: a -> b + * Multiplicity-polymorphic function arrows: a %m -> b (LinearTypes) + * Constraint arrows: a => b + * Universal quantification: forall a. b + * Visible universal quantification: forall a -> b +This syntax can't be used to construct a type at the term level because `Type` +is not inhabited by any terms. Its use is limited to required type arguments: - | HsRecSel (XRecSel p) - (FieldOcc p) -- ^ Variable pointing to record selector - -- See Note [Non-overloaded record field selectors] and - -- Note [Record selectors in the AST] + -- Error: + t :: Type + t = (Int -> String) + -- Not supported by GHC, `tcExpr` emits `TcRnIllegalTypeExpr` - | HsOverLabel (XOverLabel p) SourceText FastString + -- OK: + s :: String + s = vfun (Int -> String) + -- Valid use in a required type argument, + -- see `expr_to_type` (GHC.Tc.Gen.App) + where + vfun :: forall t -> Typeable t => String + vfun t = show (typeRep @t) + +In GHC, types-in-terms are implemented by the following additions to the AST of +expressions and their grammar: + + -- Language/Haskell/Syntax/Expr.hs + data HsExpr p = + ... + | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p) + | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p) + | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p) + + -- GHC/Parser.y + infixexp2 :: { ECP } + : infixexp %shift { ... } + | infixexp '->' infixexp2 { ... } + | infixexp expmult '->' infixexp2 { ... } + | infixexp '->.' infixexp2 { ... } + | expcontext '=>' infixexp2 { ... } + | forall_telescope infixexp2 { ... } + +These constructors and non-terminals mirror those found in HsType + + HsType | HsExpr + -------------+----------- + HsForAllTy | HsForAll + HsFunTy | HsFunArr + HsQualTy | HsQual + +The resulting code duplication can be removed if we unify HsExpr and HsType +into one type (#25121). + +Per the proposal, the constituents of types-in-terms are parsed and renamed +as terms, and forall-bound variables inhabit the term namespace. Example: + + h = \a -> g (forall a. Maybe a) a + +To ensure that the `a` in `Maybe a` refers to the innermost binding (i.e. to the +forall-bound `a` and not to the lambda-bound `a`), we must consistently use the +term namespace `varName` throughout the expression. We set the correct namespace +using `setTelescopeBndrsNameSpace` in GHC.Parser.PostProcess and GHC.ThToHs. + +`exprCtOrigin` returns `Shouldn'tHappenOrigin` for types-in-terms because +they either undergo the T2T translation `expr_to_type` in `tcVDQ` or result +in `TcRnIllegalTypeExpr`. +-} + +-- | A Haskell expression. +data HsExpr p + = HsVar (XVar p) + (LIdOccP p) -- ^ Variable + -- See Note [Located RdrNames] + + | HsOverLabel (XOverLabel p) FastString -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) - -- Note [Pragma source text] in GHC.Types.SourceText | HsIPVar (XIPVar p) HsIPName -- ^ Implicit parameter (not in use after typechecking) @@ -296,44 +345,28 @@ | HsLit (XLitE p) (HsLit p) -- ^ Simple (non-overloaded) literals + -- | Lambda, Lambda-case, and Lambda-cases | HsLam (XLam p) + HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases (MatchGroup p (LHsExpr p)) - -- ^ Lambda abstraction. Currently always a single match - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', - -- 'GHC.Parser.Annotation.AnnRarrow', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - - -- | Lambda-case - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', - -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', - -- 'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsLamCase (XLamCase p) LamCaseVariant (MatchGroup p (LHsExpr p)) + -- ^ LamSingle: one match of arity >= 1 + -- LamCase: many arity-1 matches + -- LamCases: many matches of uniform arity >= 1 | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application | HsAppType (XAppTypeE p) -- After typechecking: the type argument (LHsExpr p) - !(LHsToken "@" p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application -- -- Explicit type argument; e.g f @Int x y -- NB: Has wildcards, but no implicit quantification - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt', -- | Operator applications: -- NB Bracketed ops such as (+) come out as Vars. -- NB Sadly, we need an expr for the operator in an OpApp/Section since - -- the renamer may turn a HsVar into HsRecSel or HsUnboundVar + -- the renamer may turn a HsVar into HsRecSel or HsHole. | OpApp (XOpApp p) (LHsExpr p) -- left operand @@ -342,22 +375,12 @@ -- | Negation operator. Contains the negated expression and the name -- of 'negate' - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | NegApp (XNegApp p) (LHsExpr p) (SyntaxExpr p) - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsPar (XPar p) - !(LHsToken "(" p) (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] - !(LHsToken ")" p) | SectionL (XSectionL p) (LHsExpr p) -- operand; see Note [Sections in HsSyn] @@ -367,11 +390,7 @@ (LHsExpr p) -- operand -- | Used for explicit tuples and sections thereof - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -- Note [ExplicitTuple] | ExplicitTuple (XExplicitTuple p) @@ -379,33 +398,16 @@ Boxity -- | Used for unboxed sum types - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@, - -- 'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@, - -- - -- There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before - -- the expression, (arity - alternative) after it | ExplicitSum (XExplicitSum p) ConTag -- Alternative (one-based) SumWidth -- Sum arity (LHsExpr p) - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', - -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsCase (XCase p) (LHsExpr p) (MatchGroup p (LHsExpr p)) - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf', - -- 'GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnElse', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsIf (XIf p) -- GhcPs: this is a Bool; False <=> do not use -- rebindable syntax (LHsExpr p) -- predicate @@ -413,66 +415,31 @@ (LHsExpr p) -- else part -- | Multi-way if - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf' - -- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] + | HsMultiIf (XMultiIf p) (NonEmpty (LGRHS p (LHsExpr p))) -- | let(rec) - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', - -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsLet (XLet p) - !(LHsToken "let" p) (HsLocalBinds p) - !(LHsToken "in" p) (LHsExpr p) - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', - -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnVbar', - -- 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsDo (XDo p) -- Type of the whole expression HsDoFlavour (XRec p [ExprLStmt p]) -- "do":one or more stmts -- | Syntactic list: [a,b,c,...] - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, - -- 'GHC.Parser.Annotation.AnnClose' @']'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -- See Note [Empty lists] | ExplicitList (XExplicitList p) -- Gives type of components of list [LHsExpr p] -- | Record construction - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | RecordCon { rcon_ext :: XRecordCon p , rcon_con :: XRec p (ConLikeP p) -- The constructor , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@ - -- 'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot', - -- 'GHC.Parser.Annotation.AnnClose' @'}'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | RecordUpd { rupd_ext :: XRecordUpd p , rupd_expr :: LHsExpr p @@ -482,11 +449,7 @@ -- not the family tycon -- | Record field selection e.g @z.x@. - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- This case only arises when the OverloadedRecordDot langauge -- extension is enabled. See Note [Record selectors in the AST]. | HsGetField { @@ -500,20 +463,12 @@ -- This case only arises when the OverloadedRecordDot langauge -- extensions is enabled. See Note [Record selectors in the AST]. - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP' - -- 'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsProjection { proj_ext :: XProjection p - , proj_flds :: NonEmpty (XRec p (DotFieldOcc p)) + , proj_flds :: NonEmpty (DotFieldOcc p) } -- | Expression with an explicit type signature. @e :: type@ - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | ExprWithTySig (XExprWithTySig p) @@ -521,12 +476,6 @@ (LHsSigWcType (NoGhcTc p)) -- | Arithmetic sequence - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, - -- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot', - -- 'GHC.Parser.Annotation.AnnClose' @']'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | ArithSeq (XArithSeq p) (Maybe (SyntaxExpr p)) @@ -538,30 +487,15 @@ ----------------------------------------------------------- -- MetaHaskell Extensions - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ', - -- 'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsTypedBracket (XTypedBracket p) (LHsExpr p) | HsUntypedBracket (XUntypedBracket p) (HsQuote p) - - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsTypedSplice (XTypedSplice p) (LHsExpr p) -- `$$z` or `$$(f 4)` + | HsTypedSplice (XTypedSplice p) (HsTypedSplice p) -- `$$z` or `$$(f 4)` | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p) ----------------------------------------------------------- -- Arrow notation extension -- | @proc@ notation for Arrows - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc', - -- 'GHC.Parser.Annotation.AnnRarrow' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsProc (XProc p) (LPat p) -- arrow abstraction, proc (LHsCmdTop p) -- body of the abstraction @@ -569,9 +503,6 @@ --------------------------------------- -- static pointers extension - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsStatic (XStatic p) -- Free variables of the body, and type after typechecking (LHsExpr p) -- Body @@ -579,9 +510,33 @@ -- Expressions annotated with pragmas, written as {-# ... #-} | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) + -- Embed the syntax of types into expressions. + -- Used with @RequiredTypeArguments@, e.g. @fn (type (Int -> Bool))@. + | HsEmbTy (XEmbTy p) + (LHsWcType (NoGhcTc p)) + + -- | Holes in expressions, i.e. '_'. + -- See Note [Holes in expressions] in GHC.Tc.Types.Constraint. + | HsHole (XHole p) + + -- | Forall-types @forall tvs. t@ and @forall tvs -> t@. + -- Used with @RequiredTypeArguments@, e.g. @fn (forall a. Proxy a)@. + -- See Note [Types in terms] + | HsForAll (XForAll p) (HsForAllTelescope p) (LHsExpr p) + + -- Constrained types @ctx => t@. + -- Used with @RequiredTypeArguments@, e.g. @fn (Bounded a => a)@. + -- See Note [Types in terms] + | HsQual (XQual p) (XRec p [LHsExpr p]) (LHsExpr p) + + -- | Function types @a -> b@. + -- Used with @RequiredTypeArguments@, e.g. @fn (Int -> Bool)@. + -- See Note [Types in terms] + | HsFunArr (XFunArr p) (HsMultAnnOf (LHsExpr p) p) (LHsExpr p) (LHsExpr p) + | XExpr !(XXExpr p) -- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the - -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr + -- general idea, and Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr -- for an example of how we use it. -- --------------------------------------------------------------------- @@ -600,15 +555,6 @@ = HsPragSCC (XSCC p) StringLiteral -- "set cost centre" SCC pragma - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@, - -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal', - -- 'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal', - -- 'GHC.Parser.Annotation.AnnMinus', - -- 'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon', - -- 'GHC.Parser.Annotation.AnnVal', - -- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@ - | XHsPragE !(XXPragE p) -- | Located Haskell Tuple Argument @@ -618,10 +564,7 @@ -- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ -- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ type LHsTupArg id = XRec id (HsTupArg id) --- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | Haskell Tuple Argument data HsTupArg id = Present (XPresent id) (LHsExpr id) -- ^ The argument @@ -630,9 +573,10 @@ -- in Language.Haskell.Syntax.Extension -- | Which kind of lambda case are we dealing with? -data LamCaseVariant - = LamCase -- ^ `\case` - | LamCases -- ^ `\cases` +data HsLamVariant + = LamSingle -- ^ `\p -> e` + | LamCase -- ^ `\case pi -> ei ` + | LamCases -- ^ `\cases psi -> ei` deriving (Data, Eq) {- @@ -806,11 +750,6 @@ -- | Haskell Command (e.g. a "statement" in an Arrow proc block) data HsCmd id - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail', - -- 'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail', - -- 'GHC.Parser.Annotation.AnnRarrowtail' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) (XCmdArrApp id) -- type of the arrow expressions f, -- of the form a t t', where arg :: t @@ -820,10 +759,6 @@ Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@, - -- 'GHC.Parser.Annotation.AnnCloseB' @'|)'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) (XCmdArrForm id) (LHsExpr id) -- The operator. @@ -831,84 +766,37 @@ -- applied to the type of the local environment tuple LexicalFixity -- Whether the operator appeared prefix or infix when -- parsed. - (Maybe Fixity) -- fixity (filled in by the renamer), for forms that - -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands | HsCmdApp (XCmdApp id) (LHsCmd id) (LHsExpr id) - | HsCmdLam (XCmdLam id) - (MatchGroup id (LHsCmd id)) -- kappa - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', - -- 'GHC.Parser.Annotation.AnnRarrow', - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- | Lambda-case + -- + | HsCmdLam (XCmdLamCase id) HsLamVariant + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's | HsCmdPar (XCmdPar id) - !(LHsToken "(" id) (LHsCmd id) -- parenthesised command - !(LHsToken ")" id) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsCmdCase (XCmdCase id) (LHsExpr id) (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', - -- 'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - - -- | Lambda-case - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', - -- 'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam', - -- 'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsCmdLamCase (XCmdLamCase id) LamCaseVariant - (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's - | HsCmdIf (XCmdIf id) (SyntaxExpr id) -- cond function (LHsExpr id) -- predicate (LHsCmd id) -- then part (LHsCmd id) -- else part - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf', - -- 'GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnElse', - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsCmdLet (XCmdLet id) - !(LHsToken "let" id) (HsLocalBinds id) -- let(rec) - !(LHsToken "in" id) (LHsCmd id) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet', - -- 'GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsCmdDo (XCmdDo id) -- Type of the whole expression (XRec id [CmdLStmt id]) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo', - -- 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi', - -- 'GHC.Parser.Annotation.AnnVbar', - -- 'GHC.Parser.Annotation.AnnClose' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | XCmd !(XXCmd id) -- Extension point; see Note [Trees That Grow] -- in Language.Haskell.Syntax.Extension @@ -973,24 +861,23 @@ data MatchGroup p body = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result, and origin - , mg_alts :: XRec p [LMatch p body] } -- The alternatives + , mg_alts :: XRec p [LMatch p body] + -- The alternatives, see Note [Empty mg_alts] for what it means if 'mg_alts' is empty. + } -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns + | XMatchGroup !(XXMatchGroup p body) -- | Located Match type LMatch id body = XRec id (Match id body) --- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a --- list --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Match p body = Match { - m_ext :: XCMatch p body, - m_ctxt :: HsMatchContext p, - -- See Note [m_ctxt in Match] - m_pats :: [LPat p], -- The patterns + m_ext :: XCMatch p body, + m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), -- See Note [m_ctxt in Match] + m_pats :: XRec p [LPat p], -- The patterns m_grhss :: (GRHSs p body) } | XMatch !(XXMatch p body) @@ -998,7 +885,6 @@ {- Note [m_ctxt in Match] ~~~~~~~~~~~~~~~~~~~~~~ - A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and so on. @@ -1029,29 +915,29 @@ ( &&& ) [] ys = ys +Note [Empty mg_alts] +~~~~~~~~~~~~~~~~~~~~~~ +A `MatchGroup` for a function definition must have at least one alt, as it is not possible to +define a function by zero clauses — the compiler would consider this a missing definition, +rather than one with no clauses. --} +However, a `MatchGroup` for a `case` or `\ case` expression may be empty, as such an expression +may have zero branches. (Note: A `\ cases` expression may not have zero branches; see GHC +proposal 302). +Ergo, if we have no alts, it must be either a `case` or a `\ case` expression; such expressions +have match arity 1. -isInfixMatch :: Match id body -> Bool -isInfixMatch match = case m_ctxt match of - FunRhs {mc_fixity = Infix} -> True - _ -> False +-} + -- | Guarded Right-Hand Sides -- -- GRHSs are used both for pattern bindings and for Matches --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar', --- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere', --- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose' --- 'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi' - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data GRHSs p body = GRHSs { grhssExt :: XCGRHSs p body, - grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs + grhssGRHSs :: NonEmpty (LGRHS p body), -- ^ Guarded RHSs grhssLocalBinds :: HsLocalBinds p -- ^ The where clause } | XGRHSs !(XXGRHSs p body) @@ -1110,13 +996,6 @@ -- The SyntaxExprs in here are used *only* for do-notation and monad -- comprehensions, which have rebindable syntax. Otherwise they are unused. --- | Exact print annotations when in qualifier lists or guards --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar', --- 'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen', --- 'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy', --- 'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing' - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr @@ -1132,9 +1011,7 @@ -- For ListComp we use the baked-in 'return' -- For DoExpr, MDoExpr, we don't apply a 'return' at all -- See Note [Monad Comprehensions] - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | BindStmt (XBindStmt idL idR body) -- ^ Post renaming has optional fail and bind / (>>=) operator. -- Post typechecking, also has multiplicity of the argument @@ -1144,20 +1021,6 @@ (LPat idL) body - -- | 'ApplicativeStmt' represents an applicative expression built with - -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the - -- appropriate applicative expression by the desugarer, but it is intended - -- to be invisible in error messages. - -- - -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr" - -- - | ApplicativeStmt - (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body - [ ( SyntaxExpr idR - , ApplicativeArg idL) ] - -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] - (Maybe (SyntaxExpr idR)) -- 'join', if necessary - | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type -- of the RHS (used for arrows) body -- See Note [BodyStmt] @@ -1165,16 +1028,12 @@ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp -- See notes [Monad Comprehensions] - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet' - -- 'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@, - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | LetStmt (XLetStmt idL idR body) (HsLocalBindsLR idL idR) -- ParStmts only occur in a list/monad comprehension | ParStmt (XParStmt idL idR body) -- Post typecheck, -- S in (>>=) :: Q -> (R -> S) -> T - [ParStmtBlock idL idR] + (NonEmpty (ParStmtBlock idL idR)) (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions (SyntaxExpr idR) -- The `>>=` operator -- See notes [Monad Comprehensions] @@ -1204,9 +1063,6 @@ } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | RecStmt { recS_ext :: XRecStmt idL idR body , recS_stmts :: XRec idR [LStmtLR idL idR body] @@ -1262,37 +1118,6 @@ -- '@BindStmt@'s should use the monadic fail and which shouldn't. type FailOperator id = Maybe (SyntaxExpr id) --- | Applicative Argument -data ApplicativeArg idL - = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) - { xarg_app_arg_one :: XApplicativeArgOne idL - -- ^ The fail operator, after renaming - -- - -- The fail operator is needed if this is a BindStmt - -- where the pattern can fail. E.g.: - -- (Just a) <- stmt - -- The fail operator will be invoked if the pattern - -- match fails. - -- It is also used for guards in MonadComprehensions. - -- The fail operator is Nothing - -- if the pattern match can't fail - , app_arg_pattern :: LPat idL -- WildPat if it was a BodyStmt (see below) - , arg_expr :: LHsExpr idL - , is_body_stmt :: Bool - -- ^ True <=> was a BodyStmt, - -- False <=> was a BindStmt. - -- See Note [Applicative BodyStmt] - } - | ApplicativeArgMany -- do { stmts; return vars } - { xarg_app_arg_many :: XApplicativeArgMany idL - , app_stmts :: [ExprLStmt idL] -- stmts - , final_expr :: HsExpr idL -- return (v1,..,vn), or just (v1,..,vn) - , bv_pattern :: LPat idL -- (v1,...,vn) - , stmt_context :: HsDoFlavour - -- ^ context of the do expression, used in pprArg - } - | XApplicativeArg !(XXApplicativeArg idL) - {- Note [The type of bind in Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1494,12 +1319,16 @@ | HsQuasiQuote -- See Note [Quasi-quote overview] (XQuasiQuote id) - (IdP id) -- The quoter (the bit between `[` and `|`) + (LIdP id) -- The quoter (the bit between `[` and `|`) (XRec id FastString) -- The enclosed string | XUntypedSplice !(XXUntypedSplice id) -- Extension point; see Note [Trees That Grow] -- in Language.Haskell.Syntax.Extension +data HsTypedSplice id + = HsTypedSpliceExpr (XTypedSpliceExpr id) (LHsExpr id) + | XTypedSplice !(XXTypedSplice id) + -- | Haskell (Untyped) Quote = Expr + Pat + Type + Var data HsQuote p = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] @@ -1543,21 +1372,20 @@ -- -- Context of a pattern match. This is more subtle than it would seem. See -- Note [FunBind vs PatBind]. -data HsMatchContext p +data HsMatchContext fn = FunRhs -- ^ A pattern matching on an argument of a -- function binding - { mc_fun :: LIdP (NoGhcTc p) -- ^ function binder of @f@ - -- See Note [mc_fun field of FunRhs] - -- See #20415 for a long discussion about - -- this field and why it uses NoGhcTc. + { mc_fun :: fn -- ^ function binder of @f@ + -- See Note [mc_fun field of FunRhs] + -- See #20415 for a long discussion about this field , mc_fixity :: LexicalFixity -- ^ fixing of @f@ , mc_strictness :: SrcStrictness -- ^ was @f@ banged? -- See Note [FunBind vs PatBind] + , mc_an :: XFunRhs } - | LambdaExpr -- ^Patterns of a lambda | CaseAlt -- ^Patterns and guards in a case alternative - | LamCaseAlt LamCaseVariant -- ^Patterns and guards in @\case@ and @\cases@ + | LamAlt HsLamVariant -- ^Patterns and guards in @\@, @\case@ and @\cases@ | IfAlt -- ^Guards of a multi-way if alternative | ArrowMatchCtxt -- ^A pattern match inside arrow notation HsArrowMatchContext @@ -1570,48 +1398,57 @@ -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext p) -- ^Pattern of a do-stmt, list comprehension, - -- pattern guard, etc + | StmtCtxt (HsStmtContext fn) -- ^Pattern of a do-stmt, list comprehension, + -- pattern guard, etc | ThPatSplice -- ^A Template Haskell pattern splice | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] | PatSyn -- ^A pattern synonym declaration + | LazyPatCtx -- ^An irrefutable pattern -{- -Note [mc_fun field of FunRhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be -a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a -`Name` in `GhcTc` -- not an `Id`. See Note [NoGhcTc] in GHC.Hs.Extension. +{- Note [mc_fun field of FunRhs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsMatchContext is parameterised over `fn`, the function binder stored in `FunRhs`. +This makes pretty printing easy. -Why a `Name` in the typechecker phase? Because: -* A `Name` is all we need, as it turns out. -* Using an `Id` involves knot-tying in the monad, which led to #22695. +In the use of `HsMatchContext` in `Match`, it is parameterised thus: + data Match p body = Match { m_ctxt :: HsMatchContext (LIdP (NoGhcTc p)), ... } +So in a Match, the mc_fun field `FunRhs` will be a `RdrName` in pass `GhcPs`, a `Name` +in `GhcRn`, and (importantly) still a `Name` in `GhcTc` -- not an `Id`. +See Note [NoGhcTc] in GHC.Hs.Extension. -See #20415 for a long discussion. +* Why a `Name` in the typechecker phase? Because: + * A `Name` is all we need, as it turns out. + * Using an `Id` involves knot-tying in the monad, which led to #22695. --} +* Why a /located/ name? Because we want to record the location of the Id + on the LHS of /this/ match. See Note [m_ctxt in Match]. Example: + (&&&) [] [] = [] + xs &&& [] = xs + The two occurrences of `&&&` have different locations. -isPatSynCtxt :: HsMatchContext p -> Bool -isPatSynCtxt ctxt = - case ctxt of - PatSyn -> True - _ -> False +* Why parameterise `HsMatchContext` over `fn` rather than over the pass `p`? + Because during typechecking (specifically GHC.Tc.Gen.Match.tcMatch) we need to convert + HsMatchContext (LIdP (NoGhcTc GhcRn)) --> HsMatchContext (LIdP (NoGhcTc GhcTc)) + With this parameterisation it's easy; if it was parametersed over `p` we'd need + a recursive traversal of the HsMatchContext. +See #20415 for a long discussion. +-} + -- | Haskell Statement Context. -data HsStmtContext p - = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions) - | PatGuard (HsMatchContext p) -- ^ Pattern guard for specified thing - | ParStmtCtxt (HsStmtContext p) -- ^ A branch of a parallel stmt - | TransStmtCtxt (HsStmtContext p) -- ^ A branch of a transform stmt - | ArrowExpr -- ^ do-notation in an arrow-command context +data HsStmtContext fn + = HsDoStmt HsDoFlavour -- ^ Context for HsDo (do-notation and comprehensions) + | PatGuard (HsMatchContext fn) -- ^ Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext fn) -- ^ A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext fn) -- ^ A branch of a transform stmt + | ArrowExpr -- ^ do-notation in an arrow-command context -- | Haskell arrow match context. data HsArrowMatchContext = ProcExpr -- ^ A proc expression | ArrowCaseAlt -- ^ A case alternative inside arrow notation - | ArrowLamCaseAlt LamCaseVariant -- ^ A \case or \cases alternative inside arrow notation - | KappaExpr -- ^ An arrow kappa abstraction + | ArrowLamAlt HsLamVariant -- ^ A \, \case or \cases alternative inside arrow notation data HsDoFlavour = DoExpr (Maybe ModuleName) -- ^[ModuleName.]do { ... } @@ -1619,14 +1456,21 @@ | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs | ListComp | MonadComp + deriving (Eq, Data) -qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName +qualifiedDoModuleName_maybe :: HsStmtContext fn -> Maybe ModuleName qualifiedDoModuleName_maybe ctxt = case ctxt of HsDoStmt (DoExpr m) -> m HsDoStmt (MDoExpr m) -> m _ -> Nothing -isComprehensionContext :: HsStmtContext id -> Bool +isPatSynCtxt :: HsMatchContext fn -> Bool +isPatSynCtxt ctxt = + case ctxt of + PatSyn -> True + _ -> False + +isComprehensionContext :: HsStmtContext fn -> Bool -- Uses comprehension syntax [ e | quals ] isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c @@ -1642,7 +1486,7 @@ isDoComprehensionContext MonadComp = True -- | Is this a monadic context? -isMonadStmtContext :: HsStmtContext id -> Bool +isMonadStmtContext :: HsStmtContext fn -> Bool isMonadStmtContext (ParStmtCtxt ctxt) = isMonadStmtContext ctxt isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour @@ -1656,7 +1500,7 @@ isMonadDoStmtContext MDoExpr{} = True isMonadDoStmtContext GhciStmtCtxt = True -isMonadCompContext :: HsStmtContext id -> Bool +isMonadCompContext :: HsStmtContext fn -> Bool isMonadCompContext (HsDoStmt flavour) = isMonadDoCompContext flavour isMonadCompContext (ParStmtCtxt _) = False isMonadCompContext (TransStmtCtxt _) = False diff --git a/Language/Haskell/Syntax/Expr.hs-boot b/Language/Haskell/Syntax/Expr.hs-boot --- a/Language/Haskell/Syntax/Expr.hs-boot +++ b/Language/Haskell/Syntax/Expr.hs-boot @@ -9,6 +9,9 @@ import Language.Haskell.Syntax.Extension ( XRec ) import Data.Kind ( Type ) +import Prelude (Eq) +import Data.Data (Data) + type role HsExpr nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal @@ -20,3 +23,7 @@ type family SyntaxExpr (i :: Type) type LHsExpr a = XRec a (HsExpr a) + +data HsDoFlavour +instance Eq HsDoFlavour +instance Data HsDoFlavour diff --git a/Language/Haskell/Syntax/Extension.hs b/Language/Haskell/Syntax/Extension.hs --- a/Language/Haskell/Syntax/Extension.hs +++ b/Language/Haskell/Syntax/Extension.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc. -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -21,9 +20,7 @@ -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import Data.Type.Equality (type (~)) -#endif import Data.Data hiding ( Fixity ) import Data.Kind (Type) @@ -66,7 +63,7 @@ -} -- | A placeholder type for TTG extension points that are not currently --- unused to represent any particular value. +-- used to represent any particular value. -- -- This should not be confused with 'DataConCantHappen', which are found in unused -- extension /constructors/ and therefore should never be inhabited. In @@ -171,6 +168,42 @@ type LIdP p = XRec p (IdP p) +-- | Like 'IdP', except it keeps track of the user-written module qualification, +-- if any. +-- +-- See Note [IdOcc]. +type family IdOccP p +type LIdOccP p = XRec p (IdOccP p) + +{- Note [IdOcc] +~~~~~~~~~~~~~~~ +When possible, in error messages we would like to report identifiers with the +qualification that the user has written (provided this does not cause any +ambiguity). To do this, we record the user-written qualification in the +AST in the GhcRn stage. This is achieved with the 'WithUserRdr' data type. +Thus: + + - instead of using 'IdP', we use 'IdOccP', which wraps an 'IdP' in + 'WithUserRdr' at GhcRn pass, in: + - 'HsVar' + - 'HsTyVar' (which is used for 'TyCon's, not just type variables) + - 'HsOpTy' + - we also use 'ConLikeP' which wraps a 'Name' in 'WithUserRdr' at 'GhcRn' + pass, in: + - 'RecordCon' + - 'ConPat' + +This user-written module qualification is then consulted when pretty-printing +expressions, e.g. we have: + + - ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v + +and 'pprPrefixOcc' uses the 'OutputableBndr' instance for 'WithUserRdr'. +This happens in 'GHC.Types.Name.Ppr.mkQualName'. + +Test case: T25877. +-} + -- ===================================================================== -- Type families for the HsBinds extension points @@ -211,6 +244,7 @@ type family XFixSig x type family XInlineSig x type family XSpecSig x +type family XSpecSigE x type family XSpecInstSig x type family XMinimalSig x type family XSCCFunSig x @@ -367,6 +401,11 @@ type family XXRuleDecl x -- ------------------------------------- +-- RuleBndrs type families +type family XCRuleBndrs x +type family XXRuleBndrs x + +-- ------------------------------------- -- RuleBndr type families type family XCRuleBndr x type family XRuleBndrSig x @@ -447,9 +486,18 @@ type family XTick x type family XBinTick x type family XPragE x +type family XEmbTy x +type family XHole x +type family XForAll x +type family XQual x +type family XFunArr x type family XXExpr x -- ------------------------------------- +-- HsMatchContext type families +type family XFunRhs + +-- ------------------------------------- -- DotFieldOcc type families type family XCDotFieldOcc x type family XXDotFieldOcc x @@ -459,14 +507,7 @@ type family XSCC x type family XXPragE x - -- ------------------------------------- --- AmbiguousFieldOcc type families -type family XUnambiguous x -type family XAmbiguous x -type family XXAmbiguousFieldOcc x - --- ------------------------------------- -- HsTupArg type families type family XPresent x type family XMissing x @@ -475,9 +516,13 @@ -- ------------------------------------- -- HsUntypedSplice type families type family XUntypedSpliceExpr x +type family XTypedSpliceExpr x type family XQuasiQuote x type family XXUntypedSplice x +-- HsTypedSplice type families +type family XXTypedSplice x + -- ------------------------------------- -- HsQuoteBracket type families type family XExpBr x @@ -517,7 +562,6 @@ -- StmtLR type families type family XLastStmt x x' b type family XBindStmt x x' b -type family XApplicativeStmt x x' b type family XBodyStmt x x' b type family XLetStmt x x' b type family XParStmt x x' b @@ -545,18 +589,7 @@ type family XParStmtBlock x x' type family XXParStmtBlock x x' --- ------------------------------------- --- ApplicativeArg type families -type family XApplicativeArgOne x -type family XApplicativeArgMany x -type family XXApplicativeArg x - -- ===================================================================== --- Type families for the HsImpExp extension points - --- TODO - --- ===================================================================== -- Type families for the HsLit extension points -- We define a type family for each extension point. This is based on prepending @@ -564,6 +597,7 @@ type family XHsChar x type family XHsCharPrim x type family XHsString x +type family XHsMultilineString x type family XHsStringPrim x type family XHsInt x type family XHsIntPrim x @@ -576,8 +610,6 @@ type family XHsWord16Prim x type family XHsWord32Prim x type family XHsWord64Prim x -type family XHsInteger x -type family XHsRat x type family XHsFloatPrim x type family XHsDoublePrim x type family XXLit x @@ -599,6 +631,7 @@ type family XListPat x type family XTuplePat x type family XSumPat x +type family XOrPat x type family XConPat x type family XViewPat x type family XSplicePat x @@ -606,6 +639,8 @@ type family XNPat x type family XNPlusKPat x type family XSigPat x +type family XEmbTyPat x +type family XInvisPat x type family XCoPat x type family XXPat x type family XHsFieldBind x @@ -641,6 +676,11 @@ type family XXHsPatSigType x -- ------------------------------------- +-- HsTyPat type families +type family XHsTP x +type family XXHsTyPat x + +-- ------------------------------------- -- HsType type families type family XForAllTy x type family XQualTy x @@ -658,8 +698,6 @@ type family XKindSig x type family XSpliceTy x type family XDocTy x -type family XBangTy x -type family XRecTy x type family XExplicitListTy x type family XExplicitTupleTy x type family XTyLit x @@ -681,11 +719,15 @@ -- --------------------------------------------------------------------- -- HsTyVarBndr type families -type family XUserTyVar x -type family XKindedTyVar x +type family XTyVarBndr x type family XXTyVarBndr x -- --------------------------------------------------------------------- +-- HsConDeclRecField type families +type family XConDeclRecField x +type family XXConDeclRecField x + +-- --------------------------------------------------------------------- -- ConDeclField type families type family XConDeclField x type family XXConDeclField x @@ -696,7 +738,7 @@ type family XXFieldOcc x -- ===================================================================== --- Type families for the HsImpExp type families +-- Type families for the HsImpExp extension points -- ------------------------------------- -- ImportDecl type families @@ -719,8 +761,10 @@ -- ------------------------------------- -- IEWrappedName type families type family XIEName p +type family XIEDefault p type family XIEPattern p type family XIEType p +type family XIEData p type family XXIEWrappedName p diff --git a/Language/Haskell/Syntax/ImpExp.hs b/Language/Haskell/Syntax/ImpExp.hs --- a/Language/Haskell/Syntax/ImpExp.hs +++ b/Language/Haskell/Syntax/ImpExp.hs @@ -1,20 +1,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} -module Language.Haskell.Syntax.ImpExp where +module Language.Haskell.Syntax.ImpExp ( module Language.Haskell.Syntax.ImpExp, IsBootInterface(..) ) where import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) import Data.Eq (Eq) -import Data.Ord (Ord) -import Text.Show (Show) import Data.Data (Data) import Data.Bool (Bool) import Data.Maybe (Maybe) import Data.String (String) import Data.Int (Int) -import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +import Control.DeepSeq +import {-# SOURCE #-} GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST {- ************************************************************************ @@ -28,12 +28,7 @@ -- | Located Import Declaration type LImportDecl pass = XRec pass (ImportDecl pass) - -- ^ When in a list this may have - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | If/how an import is 'qualified'. data ImportDeclQualifiedStyle = QualifiedPre -- ^ 'qualified' appears in prepositive position. @@ -41,22 +36,24 @@ | NotQualified -- ^ Not qualified. deriving (Eq, Data) --- | Indicates whether a module name is referring to a boot interface (hs-boot --- file) or regular module (hs file). We need to treat boot modules specially --- when building compilation graphs, since they break cycles. Regular source --- files and signature files are treated equivalently. -data IsBootInterface = NotBoot | IsBoot - deriving (Eq, Ord, Show, Data) +data ImportDeclLevelStyle + = LevelStylePre ImportDeclLevel -- ^ 'splice' or 'quote' appears in prepositive position. + | LevelStylePost ImportDeclLevel -- ^ 'splice' or 'quote' appears in postpositive position. + | NotLevelled -- ^ Not levelled. + deriving (Eq, Data) +data ImportDeclLevel = ImportDeclQuote | ImportDeclSplice deriving (Eq, Data) + -- | Import Declaration -- -- A single Haskell @import@ declaration. data ImportDecl pass = ImportDecl { - ideclExt :: XCImportDecl pass, + ideclExt :: XCImportDecl pass, -- ^ Locations of keywords like @import@, @qualified@, etc. are captured here. ideclName :: XRec pass ModuleName, -- ^ Module name. ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. - ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import + ideclSource :: IsBootInterface, -- ^ IsBoot \<=> {-\# SOURCE \#-} import + ideclLevelSpec :: ImportDeclLevelStyle, ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module @@ -64,87 +61,101 @@ -- ^ Explicit import list (EverythingBut => hiding, names) } | XImportDecl !(XXImportDecl pass) - -- ^ - -- 'GHC.Parser.Annotation.AnnKeywordId's - -- - -- - 'GHC.Parser.Annotation.AnnImport' - -- - -- - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource - -- - -- - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified', - -- 'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs', - -- 'GHC.Parser.Annotation.AnnVal' - -- - -- - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose' attached - -- to location in ideclImportList - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - --- | Whether the import list is exactly what to import, or whether `hiding` was +-- | Whether the import list is exactly what to import, or whether @hiding@ was -- used, and therefore everything but what was listed should be imported data ImportListInterpretation = Exactly | EverythingBut deriving (Eq, Data) +instance NFData ImportListInterpretation where + rnf = rwhnf + -- | Located Import or Export type LIE pass = XRec pass (IE pass) -- ^ When in a list this may have - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation +-- | A docstring attached to an export list item. +type ExportDoc pass = LHsDoc pass -- | Imported or exported entity. data IE pass - = IEVar (XIEVar pass) (LIEWrappedName pass) - -- ^ Imported or Exported Variable + = IEVar (XIEVar pass) (LIEWrappedName pass) (Maybe (ExportDoc pass)) + -- ^ Imported or exported variable + -- + -- @ + -- module Mod ( test ) + -- import Mod ( test ) + -- @ - | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass) - -- ^ Imported or exported Thing with Absent list + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass) (Maybe (ExportDoc pass)) + -- ^ Imported or exported Thing with absent subordinate list -- - -- The thing is a Class/Type (can't tell) - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern', - -- 'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal' + -- The thing is a Class\/Type (can't tell) + -- + -- @ + -- module Mod ( Test ) + -- import Mod ( Test ) + -- @ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -- See Note [Located RdrNames] in GHC.Hs.Expr - | IEThingAll (XIEThingAll pass) (LIEWrappedName pass) - -- ^ Imported or exported Thing with All imported or exported + | IEThingAll (XIEThingAll pass) (LIEWrappedName pass) (Maybe (ExportDoc pass)) + -- ^ Imported or exported thing with wildcard subordinate list (e.g. @(..)@) -- - -- The thing is a Class/Type and the All refers to methods/constructors + -- The thing is a Class\/Type and the All refers to methods\/constructors -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose', - -- 'GHC.Parser.Annotation.AnnType' + -- @ + -- module Mod ( Test(..) ) + -- import Mod ( Test(..) ) + -- @ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -- See Note [Located RdrNames] in GHC.Hs.Expr - | IEThingWith (XIEThingWith pass) (LIEWrappedName pass) IEWildcard [LIEWrappedName pass] - -- ^ Imported or exported Thing With given imported or exported + (Maybe (ExportDoc pass)) + -- ^ Imported or exported thing with explicit subordinate list. -- - -- The thing is a Class/Type and the imported or exported things are + -- The thing is a Class\/Type (can't tell) and the imported or exported things are -- its children. - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnClose', - -- 'GHC.Parser.Annotation.AnnComma', - -- 'GHC.Parser.Annotation.AnnType' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- + -- @ + -- module Mod ( Test(f, g) ) + -- import Mod ( Test(f, g) ) + -- @ | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName) - -- ^ Imported or exported module contents + -- ^ Export of entire module. Can only occur in export list. -- - -- (Export Only) + -- @ + -- module Mod ( module Mod2 ) + -- @ + | IEGroup (XIEGroup pass) Int (LHsDoc pass) + -- ^ A Haddock section in an export list. -- - -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading - | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation - | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc + -- @ + -- module Mod + -- ( -- * Section heading + -- ... + -- ) + -- @ + | IEDoc (XIEDoc pass) (LHsDoc pass) + -- ^ A bit of unnamed documentation. + -- + -- @ + -- module Mod + -- ( -- | Documentation + -- ... + -- ) + -- @ + | IEDocNamed (XIEDocNamed pass) String + -- ^ A reference to a named documentation chunk. + -- + -- @ + -- module Mod + -- ( -- $chunkName + -- ... + -- ) + -- @ | XIE !(XXIE pass) -- | Wildcard in an import or export sublist, like the @..@ in @@ -158,17 +169,14 @@ -- | A name in an import or export specification which may have -- adornments. Used primarily for accurate pretty printing of --- ParsedSource, and API Annotation placement. The --- 'GHC.Parser.Annotation' is the location of the adornment in --- the original source. +-- ParsedSource, and API Annotation placement. data IEWrappedName p - = IEName (XIEName p) (LIdP p) -- ^ no extra - | IEPattern (XIEPattern p) (LIdP p) -- ^ pattern X - | IEType (XIEType p) (LIdP p) -- ^ type (:+:) + = IEName (XIEName p) (LIdP p) -- ^ unadorned name, e.g @myFun@ + | IEDefault (XIEDefault p) (LIdP p) -- ^ @default X ()@, see Note [Named default declarations] in GHC.Tc.Gen.Default + | IEPattern (XIEPattern p) (LIdP p) -- ^ @pattern X@ + | IEType (XIEType p) (LIdP p) -- ^ @type (:+:)@ + | IEData (XIEData p) (LIdP p) -- ^ @data (:+:)@ | XIEWrappedName !(XXIEWrappedName p) -- | Located name with possible adornment --- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', --- 'GHC.Parser.Annotation.AnnPattern' type LIEWrappedName p = XRec p (IEWrappedName p) --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation diff --git a/Language/Haskell/Syntax/ImpExp.hs-boot b/Language/Haskell/Syntax/ImpExp.hs-boot deleted file mode 100644 --- a/Language/Haskell/Syntax/ImpExp.hs-boot +++ /dev/null @@ -1,16 +0,0 @@ -module Language.Haskell.Syntax.ImpExp where - -import Data.Eq -import Data.Ord -import Text.Show -import Data.Data - --- This boot file should be short lived: As soon as the dependency on --- `GHC.Hs.Doc` is gone we'll no longer have cycles and can get rid this file. - -data IsBootInterface = NotBoot | IsBoot - -instance Eq IsBootInterface -instance Ord IsBootInterface -instance Show IsBootInterface -instance Data IsBootInterface diff --git a/Language/Haskell/Syntax/ImpExp/IsBoot.hs b/Language/Haskell/Syntax/ImpExp/IsBoot.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/ImpExp/IsBoot.hs @@ -0,0 +1,15 @@ +module Language.Haskell.Syntax.ImpExp.IsBoot ( IsBootInterface(..) ) where + +import Prelude (Eq, Ord, Show) +import Data.Data (Data) +import Control.DeepSeq (NFData(..), rwhnf) + +-- | Indicates whether a module name is referring to a boot interface (hs-boot +-- file) or regular module (hs file). We need to treat boot modules specially +-- when building compilation graphs, since they break cycles. Regular source +-- files and signature files are treated equivalently. +data IsBootInterface = NotBoot | IsBoot + deriving (Eq, Ord, Show, Data) + +instance NFData IsBootInterface where + rnf = rwhnf diff --git a/Language/Haskell/Syntax/Lit.hs b/Language/Haskell/Syntax/Lit.hs --- a/Language/Haskell/Syntax/Lit.hs +++ b/Language/Haskell/Syntax/Lit.hs @@ -20,9 +20,7 @@ import Language.Haskell.Syntax.Extension -import GHC.Utils.Panic (panic) -import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText, negateIntegralLit, negateFractionalLit) -import GHC.Core.Type (Type) +import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText) import GHC.Data.FastString (FastString, lexicalCompareFS) @@ -54,6 +52,8 @@ -- ^ Unboxed character | HsString (XHsString x) {- SourceText -} FastString -- ^ String + | HsMultilineString (XHsMultilineString x) {- SourceText -} FastString + -- ^ String | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString -- ^ Packed bytes | HsInt (XHsInt x) IntegralLit @@ -79,22 +79,13 @@ -- ^ literal @Word32#@ | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer -- ^ literal @Word64#@ - | HsInteger (XHsInteger x) {- SourceText -} Integer Type - -- ^ Genuinely an integer; arises only - -- from TRANSLATION (overloaded - -- literals are done with HsOverLit) - | HsRat (XHsRat x) FractionalLit Type - -- ^ Genuinely a rational; arises only from - -- TRANSLATION (overloaded literals are - -- done with HsOverLit) | HsFloatPrim (XHsFloatPrim x) FractionalLit -- ^ Unboxed Float | HsDoublePrim (XHsDoublePrim x) FractionalLit -- ^ Unboxed Double - | XLit !(XXLit x) -instance Eq (HsLit x) where +instance (Eq (XXLit x)) => Eq (HsLit x) where (HsChar _ x1) == (HsChar _ x2) = x1==x2 (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 (HsString _ x1) == (HsString _ x2) = x1==x2 @@ -104,10 +95,9 @@ (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 - (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 - (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2 (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 + (XLit x1) == (XLit x2) = x1==x2 _ == _ = False -- | Haskell Overloaded Literal @@ -128,28 +118,11 @@ | HsIsString !SourceText !FastString -- ^ String-looking literals deriving Data -negateOverLitVal :: OverLitVal -> OverLitVal -negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) -negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) -negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" - --- Comparison operations are needed when grouping literals --- for compiling pattern-matching (module GHC.HsToCore.Match.Literal) -instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where - (OverLit _ val1) == (OverLit _ val2) = val1 == val2 - (XOverLit val1) == (XOverLit val2) = val1 == val2 - _ == _ = panic "Eq HsOverLit" - instance Eq OverLitVal where (HsIntegral i1) == (HsIntegral i2) = i1 == i2 (HsFractional f1) == (HsFractional f2) = f1 == f2 (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 _ == _ = False - -instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where - compare (OverLit _ val1) (OverLit _ val2) = val1 `compare` val2 - compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 - compare _ _ = panic "Ord HsOverLit" instance Ord OverLitVal where compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 diff --git a/Language/Haskell/Syntax/Module/Name.hs b/Language/Haskell/Syntax/Module/Name.hs --- a/Language/Haskell/Syntax/Module/Name.hs +++ b/Language/Haskell/Syntax/Module/Name.hs @@ -2,27 +2,28 @@ import Prelude -import Data.Data import Data.Char (isAlphaNum) +import Data.Data import Control.DeepSeq import qualified Text.ParserCombinators.ReadP as Parse import System.FilePath -import GHC.Utils.Misc (abstractConstr) import GHC.Data.FastString -- | A ModuleName is essentially a simple string, e.g. @Data.List@. newtype ModuleName = ModuleName FastString deriving (Show, Eq) -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - instance Data ModuleName where -- don't traverse? - toConstr _ = abstractConstr "ModuleName" + toConstr x = constr + where + constr = mkConstr (dataTypeOf x) "{abstract:ModuleName}" [] Prefix gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "ModuleName" +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + instance NFData ModuleName where rnf x = x `seq` () @@ -56,5 +57,5 @@ parseModuleName :: Parse.ReadP ModuleName parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.'") diff --git a/Language/Haskell/Syntax/Pat.hs b/Language/Haskell/Syntax/Pat.hs --- a/Language/Haskell/Syntax/Pat.hs +++ b/Language/Haskell/Syntax/Pat.hs @@ -21,14 +21,15 @@ module Language.Haskell.Syntax.Pat ( Pat(..), LPat, ConLikeP, + isInvisArgPat, isInvisArgLPat, + isVisArgPat, isVisArgLPat, HsConPatDetails, hsConPatArgs, - HsConPatTyArg(..), - HsRecFields(..), HsFieldBind(..), LHsFieldBind, + takeHsConPatTyArgs, dropHsConPatTyArgs, + HsRecFields(..), XHsRecFields, HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, - RecFieldsDotDot(..), - hsRecFields, hsRecFieldSel, hsRecFieldsArgs, + RecFieldsDotDot(..) ) where import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice) @@ -36,7 +37,6 @@ -- friends: import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type @@ -52,69 +52,48 @@ import Data.Int import Data.Function import qualified Data.List +import Data.List.NonEmpty (NonEmpty) type LPat p = XRec p (Pat p) -- | Pattern --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' - --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Pat p = ------------ Simple patterns --------------- - WildPat (XWildPat p) -- ^ Wildcard Pattern - -- The sole reason for a type on a WildPat is to - -- support hsPatType :: Pat Id -> Type + WildPat (XWildPat p) + -- ^ Wildcard Pattern, i.e. @_@ - -- AZ:TODO above comment needs to be updated | VarPat (XVarPat p) - (LIdP p) -- ^ Variable Pattern + (LIdP p) + -- ^ Variable Pattern, e.g. @x@ - -- See Note [Located RdrNames] in GHC.Hs.Expr + -- See Note [Located RdrNames] in GHC.Hs.Expr | LazyPat (XLazyPat p) - (LPat p) -- ^ Lazy Pattern - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - + (LPat p) + -- ^ Lazy Pattern, e.g. @~x@ | AsPat (XAsPat p) (LIdP p) - !(LHsToken "@" p) - (LPat p) -- ^ As pattern - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - + (LPat p) + -- ^ As pattern, e.g. @x\@pat@ | ParPat (XParPat p) - !(LHsToken "(" p) - (LPat p) -- ^ Parenthesised pattern - !(LHsToken ")" p) - -- See Note [Parens in HsSyn] in GHC.Hs.Expr - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ + (LPat p) + -- ^ Parenthesised pattern, e.g. @(x)@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- See Note [Parens in HsSyn] in GHC.Hs.Expr | BangPat (XBangPat p) - (LPat p) -- ^ Bang pattern - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + (LPat p) + -- ^ Bang pattern, e.g. @!x@ ------------ Lists, tuples, arrays --------------- | ListPat (XListPat p) [LPat p] - - -- ^ Syntactic List - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, - -- 'GHC.Parser.Annotation.AnnClose' @']'@ + -- ^ Syntactic List, e.g. @[x]@ or @[x,y]@. + -- Note that @[]@ and @(x:xs)@ patterns are both represented using 'ConPat'. - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + | -- | Tuple pattern, e.g. @(x, y)@ (boxed tuples) or @(# x, y #)@ (requires @-XUnboxedTuples@) + TuplePat (XTuplePat p) -- ^ After typechecking, holds the types of the tuple components + [LPat p] -- ^ Tuple sub-patterns + Boxity - | TuplePat (XTuplePat p) - -- after typechecking, holds the types of the tuple components - [LPat p] -- Tuple sub-patterns - Boxity -- UnitPat is TuplePat [] -- You might think that the post typechecking Type was redundant, -- because we can get the pattern type by getting the types of the -- sub-patterns. @@ -131,23 +110,19 @@ -- of the tuple is of type 'a' not Int. See selectMatchVar -- (June 14: I'm not sure this comment is right; the sub-patterns -- will be wrapped in CoPats, no?) - -- ^ Tuple sub-patterns + + | OrPat (XOrPat p) + (NonEmpty (LPat p)) + -- ^ Or Pattern, e.g. @(pat_1; ...; pat_n)@. Used by @-XOrPatterns@ -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ or @'#)'@ + -- @since 9.12.1 | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) SumWidth -- Arity (INVARIANT: ≥ 2) - -- ^ Anonymous sum pattern - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpen' @'(#'@, - -- 'GHC.Parser.Annotation.AnnClose' @'#)'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + -- ^ Anonymous sum pattern, e.g. @(# x | #)@. Used by @-XUnboxedSums@ ------------ Constructor patterns --------------- | ConPat { @@ -155,35 +130,30 @@ pat_con :: XRec p (ConLikeP p), pat_args :: HsConPatDetails p } - -- ^ Constructor Pattern + -- ^ Constructor Pattern, e.g. @()@, @[]@ or @Nothing@ ------------ View patterns --------------- - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | ViewPat (XViewPat p) (LHsExpr p) (LPat p) - -- ^ View Pattern + -- ^ View Pattern, e.g. @someFun -> pat@. Used by @-XViewPatterns@ ------------ Pattern splices --------------- - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@ - -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | SplicePat (XSplicePat p) - (HsUntypedSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + (HsUntypedSplice p) + -- ^ Splice Pattern, e.g. @$(pat)@ ------------ Literal and n+k patterns --------------- | LitPat (XLitPat p) - (HsLit p) -- ^ Literal Pattern - -- Used for *non-overloaded* literal patterns: - -- Int#, Char#, Int, Char, String, etc. + (HsLit p) + -- ^ Literal Pattern + -- + -- Used for __non-overloaded__ literal patterns: + -- Int#, Char#, Int, Char, String, etc. - | NPat -- Natural Pattern - -- Used for all overloaded literals, - -- including overloaded strings with -XOverloadedStrings - (XNPat p) -- Overall type of pattern. Might be + | NPat (XNPat p) -- Overall type of pattern. Might be -- different than the literal's type -- if (==) or negate changes the type (XRec p (HsOverLit p)) -- ALWAYS positive @@ -192,12 +162,11 @@ -- otherwise (SyntaxExpr p) -- Equality checker, of type t->t->Bool - -- ^ Natural Pattern - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@ + -- ^ Natural Pattern, used for all overloaded literals, including overloaded Strings + -- with @-XOverloadedStrings@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | NPlusKPat (XNPlusKPat p) -- Type of overall pattern + | -- | n+k pattern, e.g. @n+1@, used by @-XNPlusKPatterns@ + NPlusKPat (XNPlusKPat p) -- Type of overall pattern (LIdP p) -- n+k pattern (XRec p (HsOverLit p)) -- It'll always be an HsIntegral (HsOverLit p) -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat @@ -206,43 +175,65 @@ (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntax) - -- ^ n+k pattern ------------ Pattern type signatures --------------- - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | SigPat (XSigPat p) -- After typechecker: Type (LPat p) -- Pattern with a type signature (HsPatSigType (NoGhcTc p)) -- Signature can bind both -- kind and type vars - -- ^ Pattern with a type signature + -- ^ Pattern with a type signature, e.g. @x :: Int@ - -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension - | XPat - !(XXPat p) + | -- | Embed the syntax of types into patterns, e.g. @fn (type t) = rhs@. + -- Enabled by @-XExplicitNamespaces@ in conjunction with @-XRequiredTypeArguments@. + EmbTyPat (XEmbTyPat p) + (HsTyPat (NoGhcTc p)) + | InvisPat (XInvisPat p) (HsTyPat (NoGhcTc p)) + -- ^ Type abstraction which brings into scope type variables associated with invisible forall. + -- E.g. @fn \@t ... = rhs@. Used by @-XTypeAbstractions@. + + -- See Note [Invisible binders in functions] in GHC.Hs.Pat + + | -- | TTG Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension + XPat !(XXPat p) + type family ConLikeP x -- --------------------------------------------------------------------- --- | Type argument in a data constructor pattern, --- e.g. the @\@a@ in @f (Just \@a x) = ...@. -data HsConPatTyArg p = - HsConPatTyArg - !(LHsToken "@" p) - (HsPatSigType p) +isInvisArgPat :: Pat p -> Bool +isInvisArgPat InvisPat{} = True +isInvisArgPat _ = False +isInvisArgLPat :: forall p. (UnXRec p) => LPat p -> Bool +isInvisArgLPat = isInvisArgPat . unXRec @p + +isVisArgPat :: Pat p -> Bool +isVisArgPat = not . isInvisArgPat + +isVisArgLPat :: forall p. (UnXRec p) => LPat p -> Bool +isVisArgLPat = isVisArgPat . unXRec @p + -- | Haskell Constructor Pattern Details -type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) +type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] -hsConPatArgs (PrefixCon _ ps) = ps +hsConPatArgs (PrefixCon ps) = ps hsConPatArgs (RecCon fs) = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] +takeHsConPatTyArgs :: forall p. (UnXRec p) => [LPat p] -> [HsTyPat (NoGhcTc p)] +takeHsConPatTyArgs (p : ps) + | InvisPat _ tp <- unXRec @p p + = tp : takeHsConPatTyArgs ps +takeHsConPatTyArgs _ = [] + +dropHsConPatTyArgs :: forall p. (UnXRec p) => [LPat p] -> [LPat p] +dropHsConPatTyArgs = Data.List.dropWhile (isInvisArgPat . unXRec @p) + -- | Haskell Record Fields -- -- HsRecFields is used only for patterns and expressions (not data type @@ -250,11 +241,14 @@ data HsRecFields p arg -- A bunch of record fields -- { x = 3, y = True } -- Used for both expressions and patterns - = HsRecFields { rec_flds :: [LHsRecField p arg], + = HsRecFields { rec_ext :: !(XHsRecFields p), + rec_flds :: [LHsRecField p arg], rec_dotdot :: Maybe (XRec p RecFieldsDotDot) } -- Note [DotDot fields] -- AZ:The XRec for LHsRecField makes the derivings fail. -- deriving (Functor, Foldable, Traversable) +type family XHsRecFields p + -- | Newtype to be able to have a specific XRec instance for the Int in `rec_dotdot` newtype RecFieldsDotDot = RecFieldsDotDot { unRecFieldsDotDot :: Int } deriving (Data, Eq, Ord) @@ -279,20 +273,16 @@ -- | Located Haskell Record Field type LHsRecField p arg = XRec p (HsRecField p arg) --- | Located Haskell Record Update Field -type LHsRecUpdField p q = XRec p (HsRecUpdField p q) - -- | Haskell Record Field type HsRecField p arg = HsFieldBind (LFieldOcc p) arg +-- | Located Haskell Record Update Field +type LHsRecUpdField p q = XRec p (HsRecUpdField p q) + -- | Haskell Record Update Field -type HsRecUpdField p q = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr q) +type HsRecUpdField p q = HsFieldBind (LFieldOcc p) (LHsExpr q) -- | Haskell Field Binding --- --- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual', --- --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data HsFieldBind lhs rhs = HsFieldBind { hfbAnn :: XHsFieldBind lhs, hfbLHS :: lhs, @@ -354,12 +344,3 @@ -- hfbLHS = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- -- See also Note [Disambiguating record updates] in GHC.Rename.Pat. - -hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p] -hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) - -hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg] -hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds) - -hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p -hsRecFieldSel = foExt . unXRec @p . hfbLHS diff --git a/Language/Haskell/Syntax/Specificity.hs b/Language/Haskell/Syntax/Specificity.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Specificity.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE MultiWayIf, PatternSynonyms #-} + +-- TODO Everthing in this module should be moved to +-- Language.Haskell.Syntax.Decls + +module Language.Haskell.Syntax.Specificity ( + -- * ForAllTyFlags + ForAllTyFlag(Invisible,Required,Specified,Inferred), + Specificity(..), + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag, + isSpecifiedForAllTyFlag, + coreTyLamForAllTyFlag, + ) where + +import Prelude + +import Data.Data + +-- | ForAllTyFlag +-- +-- Is something required to appear in source Haskell ('Required'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Inferred')? +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +data ForAllTyFlag = Invisible !Specificity + | Required + deriving (Eq, Ord, Data) + -- (<) on ForAllTyFlag means "is less visible than" + +-- | Whether an 'Invisible' argument may appear in source Haskell. +data Specificity = InferredSpec + -- ^ the argument may not appear in source Haskell, it is + -- only inferred. + | SpecifiedSpec + -- ^ the argument may appear in source Haskell, but isn't + -- required. + deriving (Eq, Ord, Data) + +pattern Inferred, Specified :: ForAllTyFlag +pattern Inferred = Invisible InferredSpec +pattern Specified = Invisible SpecifiedSpec + +{-# COMPLETE Required, Specified, Inferred #-} + +-- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell? +isVisibleForAllTyFlag :: ForAllTyFlag -> Bool +isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af) + +-- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell? +isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool +isInvisibleForAllTyFlag (Invisible {}) = True +isInvisibleForAllTyFlag Required = False + +isInferredForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isInferredForAllTyFlag (Invisible InferredSpec) = True +isInferredForAllTyFlag _ = False + +isSpecifiedForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isSpecifiedForAllTyFlag (Invisible SpecifiedSpec) = True +isSpecifiedForAllTyFlag _ = False + +coreTyLamForAllTyFlag :: ForAllTyFlag +-- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable. +-- If you want other ForAllTyFlag, use a cast. +-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep +coreTyLamForAllTyFlag = Specified diff --git a/Language/Haskell/Syntax/Type.hs b/Language/Haskell/Syntax/Type.hs --- a/Language/Haskell/Syntax/Type.hs +++ b/Language/Haskell/Syntax/Type.hs @@ -20,64 +20,64 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type ( - HsScaled(..), - hsMult, hsScaledThing, - HsArrow(..), - HsLinearArrowTokens(..), + HsMultAnn, HsMultAnnOf(..), + XUnannotated, XLinearAnn, XExplicitMult, XXMultAnnOf, HsType(..), LHsType, HsKind, LHsKind, - HsBndrVis(..), isHsBndrInvisible, - HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, + HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis, + HsBndrVar(..), XBndrVar, XBndrWildCard, XXBndrVar, + HsBndrKind(..), XBndrKind, XBndrNoKind, XXBndrKind, + isHsBndrInvisible, + isHsBndrWildCard, + HsForAllTelescope(..), + HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..), HsPatSigType(..), HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, + HsTyPat(..), LHsTyPat, HsTupleSort(..), HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, - HsArg(..), + HsArg(..), XValArg, XTypeArg, XArgPar, XXArg, + LHsTypeArg, - LBangType, BangType, - HsSrcBang(..), PromotionFlag(..), isPromoted, - ConDeclField(..), LConDeclField, + HsConDeclRecField(..), LHsConDeclRecField, - HsConDetails(..), noTypeArgs, conDetailsArity, + HsConDetails(..), + HsConDeclField(..), FieldOcc(..), LFieldOcc, - AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mapHsOuterImplicit, hsQTvExplicit, - isHsKindedTyVar, - hsPatSigType, + isHsKindedTyVar ) where import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) -import Language.Haskell.Syntax.Concrete +import Language.Haskell.Syntax.Basic ( SrcStrictness, SrcUnpackedness ) import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Specificity -import GHC.Types.Name.Reader ( RdrName ) -import GHC.Core.DataCon( HsSrcBang(..) ) -import GHC.Core.Type (Specificity) -import GHC.Types.SrcLoc (SrcSpan) -import GHC.Types.Basic (Arity) import GHC.Hs.Doc (LHsDoc) import GHC.Data.FastString (FastString) +import GHC.Utils.Panic( panic ) import Data.Data hiding ( Fixity, Prefix, Infix ) -import Data.Void import Data.Maybe import Data.Eq import Data.Bool import Data.Char -import Prelude (Integer, length) +import Prelude (Integer) +import Data.Ord (Ord) +import Control.DeepSeq {- ************************************************************************ @@ -91,30 +91,15 @@ data PromotionFlag = NotPromoted | IsPromoted - deriving ( Eq, Data ) + deriving ( Eq, Data, Ord ) isPromoted :: PromotionFlag -> Bool isPromoted IsPromoted = True isPromoted NotPromoted = False -{- -************************************************************************ -* * -\subsection{Bang annotations} -* * -************************************************************************ --} - --- | Located Bang Type -type LBangType pass = XRec pass (BangType pass) - --- | Bang Type --- --- In the parser, strictness and packedness annotations bind more tightly --- than docstrings. This means that when consuming a 'BangType' (and looking --- for 'HsBangTy') we must be ready to peer behind a potential layer of --- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example. -type BangType pass = HsType pass -- Bangs are in the HsType data type +instance NFData PromotionFlag where + rnf NotPromoted = () + rnf IsPromoted = () {- ************************************************************************ @@ -294,28 +279,19 @@ -- | Located Haskell Context type LHsContext pass = XRec pass (HsContext pass) - -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -- | Haskell Context type HsContext pass = [LHsType pass] -- | Located Haskell Type type LHsType pass = XRec pass (HsType pass) - -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when - -- in a list - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- | Haskell Kind type HsKind pass = HsType pass -- | Located Haskell Kind type LHsKind pass = XRec pass (HsKind pass) - -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -------------------------------------------------- -- LHsQTyVars -- The explicitly-quantified binders in a data/type declaration @@ -351,7 +327,8 @@ | XLHsQTyVars !(XXLHsQTyVars pass) hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass] -hsQTvExplicit = hsq_explicit +hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs +hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit" ------------------------------------------------ -- HsOuterTyVarBndrs @@ -359,7 +336,7 @@ -- the forall-or-nothing rule. These are used to represent the outermost -- quantification in: -- * Type signatures (LHsSigType/LHsSigWcType) --- * Patterns in a type/data family instance (HsTyPats) +-- * Patterns in a type/data family instance (HsFamEqnPats) -- -- We support two forms: -- HsOuterImplicit (implicit quantification, added by renamer) @@ -448,6 +425,14 @@ -- | Located Haskell Signature Wildcard Type type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both +data HsTyPat pass + = HsTP { hstp_ext :: XHsTP pass -- ^ After renamer: 'HsTyPatRn' + , hstp_body :: LHsType pass -- ^ Main payload (the type itself) + } + | XHsTyPat !(XXHsTyPat pass) + +type LHsTyPat pass = XRec pass (HsTyPat pass) + -- | A type signature that obeys the @forall@-or-nothing rule. In other -- words, an 'LHsType' that uses an 'HsOuterSigTyVarBndrs' to represent its -- outermost type variable quantification. @@ -459,9 +444,6 @@ } | XHsSigType !(XXHsSigType pass) -hsPatSigType :: HsPatSigType pass -> LHsType pass -hsPatSigType = hsps_body - {- Note [forall-or-nothing rule] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -692,51 +674,140 @@ -------------------------------------------------- -- | Haskell Type Variable Binder --- The flag annotates the binder. It is 'Specificity' in places where --- explicit specificity is allowed (e.g. x :: forall {a} b. ...) or --- '()' in other places. +-- See Note [Type variable binders] data HsTyVarBndr flag pass - = UserTyVar -- no explicit kinding - (XUserTyVar pass) - flag - (LIdP pass) - -- See Note [Located RdrNames] in GHC.Hs.Expr - - | KindedTyVar - (XKindedTyVar pass) - flag - (LIdP pass) - (LHsKind pass) -- The user-supplied kind signature - -- ^ - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', - -- 'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnClose' - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - + = HsTvb { tvb_ext :: XTyVarBndr pass + , tvb_flag :: flag + , tvb_var :: HsBndrVar pass + , tvb_kind :: HsBndrKind pass } | XTyVarBndr !(XXTyVarBndr pass) data HsBndrVis pass - = HsBndrRequired + = HsBndrRequired !(XBndrRequired pass) -- Binder for a visible (required) variable: -- type Dup a = (a, a) -- ^^^ - | HsBndrInvisible (LHsToken "@" pass) + | HsBndrInvisible !(XBndrInvisible pass) -- Binder for an invisible (specified) variable: -- type KindOf @k (a :: k) = k -- ^^^ + | XBndrVis !(XXBndrVis pass) + +type family XBndrRequired p +type family XBndrInvisible p +type family XXBndrVis p + isHsBndrInvisible :: HsBndrVis pass -> Bool isHsBndrInvisible HsBndrInvisible{} = True -isHsBndrInvisible HsBndrRequired = False +isHsBndrInvisible HsBndrRequired{} = False +isHsBndrInvisible (XBndrVis _) = False +data HsBndrVar pass + = HsBndrVar !(XBndrVar pass) !(LIdP pass) + | HsBndrWildCard !(XBndrWildCard pass) + | XBndrVar !(XXBndrVar pass) + +type family XBndrVar p +type family XBndrWildCard p +type family XXBndrVar p + +isHsBndrWildCard :: HsBndrVar pass -> Bool +isHsBndrWildCard HsBndrWildCard{} = True +isHsBndrWildCard HsBndrVar{} = False +isHsBndrWildCard (XBndrVar _) = False + +data HsBndrKind pass + = HsBndrKind !(XBndrKind pass) (LHsKind pass) + | HsBndrNoKind !(XBndrNoKind pass) + | XBndrKind !(XXBndrKind pass) + +type family XBndrKind p +type family XBndrNoKind p +type family XXBndrKind p + -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool -isHsKindedTyVar (UserTyVar {}) = False -isHsKindedTyVar (KindedTyVar {}) = True -isHsKindedTyVar (XTyVarBndr {}) = False +isHsKindedTyVar (HsTvb { tvb_kind = kind }) = + case kind of + HsBndrKind _ _ -> True + HsBndrNoKind _ -> False + XBndrKind _ -> False +isHsKindedTyVar (XTyVarBndr {}) = False + +{- Note [Type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type variable binders, represented by the HsTyVarBndr type, can occur in the +following contexts: + +1. On the left-hand sides of type/class declarations (TyClDecl) + + data D a b = ... -- data types (DataDecl) + newtype N a b = ... -- newtypes (DataDecl) + type T a b = ... -- type synonyms (SynDecl) + class C a b where ... -- classes (ClassDecl) + type family TF a b -- type families (FamDecl) + data family DF a b -- data families (FamDecl) + + The `a` and `b` in these examples are type variable binders. + +2. In forall telescopes (HsForAllTy and HsOuterTyVarBndrs) + + 2-Invis. forall {a} b. ... -- invisible forall (HsForAllInvis) + 2-Vis. forall a b -> ... -- visible forall (HsForAllVis) + + Again, `a` and `b` are type variable binders. + +3. In type family result signatures (FamilyResultSig), which are + part of the TypeFamilyDependencies extension + + type family F a = r | r -> a -- result sig (TyVarSig) + + The `r` immediately to the right of `=` is a type variable binder. + +4. In constructor patterns, as long as the conditions outlined in + Note [Type patterns: binders and unifiers] are satisfied + + fn (MkT @a @b x y) = ... -- invisible type arguments (InvisPat) + -- in constructor patterns (ConPat) + + Here, the `a` and `b` are type variable binders iff + `GHC.Tc.Gen.HsType.tyPatToBndr` returns `Just`. + +A type variable binder has three parts: + * flag (HsBndrVis, Specificity, or () -- depending on context) + * variable (HsBndrVar) + * kind (HsBndrKind) + +Details about each part: + +* The binder variable (HsBndrVar) is either a type variable name or a wildcard, + i.e. `a` vs `_` (HsBndrVar vs HsBndrWildCard). + +* The binder kind (HsBndrKind) stores the optional kind annotation, + i.e. `a` vs `a :: k` (HsBndrNoKind vs HsBndrKind). + +* The binder flag is instantiated to one of the following types, + depending on the context where it occurs (contexts 1..4 are listed above) + + (a) flag=HsBndrVis records `a` vs `@a` (HsBndrRequired vs HsBndrInvisible) + (used in contexts: 1) + (b) flag=Specificity records `a` vs `{a}` (SpecifiedSpec vs InferredSpec) + (used in contexts: 2-Invis) + (c) flag=() is used when there is no distinction to record + (used in contexts: 2-Vis, 3, 4) + +All in all, we have the following forms of type variable binders in the language + + a, (a :: k), @a, @(a :: k), {a}, {a :: k} + _, (_ :: k), @_, @(_ :: k) + +The forms {_}, {_ :: k} are representable but never valid, see +Note [Wildcard binders in disallowed contexts] in GHC.Hs.Type -} + -- | Haskell Type data HsType pass = HsForAllTy -- See Note [HsType binders] @@ -745,9 +816,6 @@ -- Explicit, user-supplied 'forall a {b} c' , hst_body :: LHsType pass -- body type } - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForall', - -- 'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow' - -- For details on above see Note [exact print annotations] in "GHC.Parser.Annotation" | HsQualTy -- See Note [HsType binders] { hst_xqual :: XQualTy pass @@ -757,158 +825,83 @@ | HsTyVar (XTyVar pass) PromotionFlag -- Whether explicitly promoted, -- for the pretty printer - (LIdP pass) + (LIdOccP pass) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] -- See Note [Located RdrNames] in GHC.Hs.Expr - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsAppTy (XAppTy pass) (LHsType pass) (LHsType pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsAppKindTy (XAppKindTy pass) -- type level type app (LHsType pass) - !(LHsToken "@" pass) (LHsKind pass) | HsFunTy (XFunTy pass) - (HsArrow pass) + (HsMultAnn pass) -- multiplicty annotations, includes the arrow (LHsType pass) -- function type (LHsType pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow', - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsListTy (XListTy pass) (LHsType pass) -- Element type - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@, - -- 'GHC.Parser.Annotation.AnnClose' @']'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsTupleTy (XTupleTy pass) HsTupleSort [LHsType pass] -- Element types (length gives arity) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(' or '(#'@, - -- 'GHC.Parser.Annotation.AnnClose' @')' or '#)'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsSumTy (XSumTy pass) [LHsType pass] -- Element types (length gives arity) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@, - -- 'GHC.Parser.Annotation.AnnClose' '#)'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsOpTy (XOpTy pass) PromotionFlag -- Whether explicitly promoted, -- for the pretty printer - (LHsType pass) (LIdP pass) (LHsType pass) - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + (LHsType pass) (LIdOccP pass) (LHsType pass) | HsParTy (XParTy pass) (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr -- Parenthesis preserved for the precedence re-arrangement in -- GHC.Rename.HsType -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsIParamTy (XIParamTy pass) (XRec pass HsIPName) -- (?x :: ty) (LHsType pass) -- Implicit parameters as they occur in -- contexts -- ^ -- > (?x :: ty) - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsStarTy (XStarTy pass) Bool -- Is this the Unicode variant? -- Note [HsStarTy] - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None | HsKindSig (XKindSig pass) (LHsType pass) -- (ty :: kind) (LHsKind pass) -- A type with a kind signature -- ^ -- > (ty :: kind) - -- - -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@, - -- 'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsSpliceTy (XSpliceTy pass) (HsUntypedSplice pass) -- Includes quasi-quotes - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsDocTy (XDocTy pass) (LHsType pass) (LHsDoc pass) -- A documented type - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - - | HsBangTy (XBangTy pass) - HsSrcBang (LHsType pass) -- Bang-style type annotations - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : - -- 'GHC.Parser.Annotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, - -- 'GHC.Parser.Annotation.AnnClose' @'#-}'@ - -- 'GHC.Parser.Annotation.AnnBang' @\'!\'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - - | HsRecTy (XRecTy pass) - [LConDeclField pass] -- Only in data type declarations - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@, - -- 'GHC.Parser.Annotation.AnnClose' @'}'@ - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsExplicitListTy -- A promoted explicit list (XExplicitListTy pass) PromotionFlag -- whether explicitly promoted, for pretty printer [LHsType pass] - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'["@, - -- 'GHC.Parser.Annotation.AnnClose' @']'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsExplicitTupleTy -- A promoted explicit tuple (XExplicitTupleTy pass) + PromotionFlag -- whether explicitly promoted, for pretty printer [LHsType pass] - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'("@, - -- 'GHC.Parser.Annotation.AnnClose' @')'@ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsTyLit (XTyLit pass) (HsTyLit pass) -- A promoted numeric literal. - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsWildCardTy (XWildCardTy pass) -- A type wildcard -- See Note [The wildcard story for types] - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension | XHsType !(XXType pass) @@ -921,33 +914,31 @@ | HsCharTy (XCharTy pass) Char | XTyLit !(XXTyLit pass) --- | Denotes the type of arrows in the surface language -data HsArrow pass - = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass) - -- ^ a -> b or a → b +type HsMultAnn pass = HsMultAnnOf (LHsType (NoGhcTc pass)) pass - | HsLinearArrow !(HsLinearArrowTokens pass) - -- ^ a %1 -> b or a %1 → b, or a ⊸ b +-- | Denotes multiplicity annotations in the surface language. +-- The `mult` type argument is usually `LHsType (NoGhcTc pass)`, but when the annotation +-- is part of a type used in a term, it is `LHsExpr pass`. See Note [Types in terms]. +data HsMultAnnOf mult pass + = HsUnannotated !(XUnannotated mult pass) + -- ^ a -> b or a → b or { nm :: a } - | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass) - -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! + | HsLinearAnn !(XLinearAnn mult pass) + -- ^ a %1 -> b or a %1 → b, or a ⊸ b, or { nm %1 :: a } + + | HsExplicitMult !(XExplicitMult mult pass) !mult + -- ^ a %m -> b or a %m → b or { nm %m :: a } + -- (very much including `a %Many -> b`! -- This is how the programmer wrote it). It is stored as an -- `HsType` so as to preserve the syntax as written in the -- program. -data HsLinearArrowTokens pass - = HsPct1 !(LHsToken "%1" pass) !(LHsUniToken "->" "→" pass) - | HsLolly !(LHsToken "⊸" pass) - --- | This is used in the syntax. In constructor declaration. It must keep the --- arrow representation. -data HsScaled pass a = HsScaled (HsArrow pass) a - -hsMult :: HsScaled pass a -> HsArrow pass -hsMult (HsScaled m _) = m + | XMultAnnOf !(XXMultAnnOf mult pass) -hsScaledThing :: HsScaled pass a -> a -hsScaledThing (HsScaled _ t) = t +type family XUnannotated mult p +type family XLinearAnn mult p +type family XExplicitMult mult p +type family XXMultAnnOf mult p {- Note [Unit tuples] @@ -989,7 +980,7 @@ wrote '*' or 'Type', and lose the parse/ppr roundtrip property. As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') -and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). +and then desugar it to 'Data.Kind.Type' in the typechecker (see tcHsType). When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not involved. @@ -1044,24 +1035,16 @@ | HsBoxedOrConstraintTuple deriving Data --- | Located Constructor Declaration Field -type LConDeclField pass = XRec pass (ConDeclField pass) - -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when - -- in a list - - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - --- | Constructor Declaration Field -data ConDeclField pass -- Record fields have Haddock docs on them - = ConDeclField { cd_fld_ext :: XConDeclField pass, - cd_fld_names :: [LFieldOcc pass], - -- ^ See Note [ConDeclField pass] - cd_fld_type :: LBangType pass, - cd_fld_doc :: Maybe (LHsDoc pass)} - -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' +-- | Located Constructor Declaration Record Field +type LHsConDeclRecField pass = XRec pass (HsConDeclRecField pass) - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | XConDeclField !(XXConDeclField pass) +-- | Constructor Declaration Record Field +data HsConDeclRecField pass + = HsConDeclRecField { cdrf_ext :: XConDeclRecField pass, + cdrf_names :: [LFieldOcc pass], + -- ^ See Note [FieldOcc pass] + cdrf_spec :: HsConDeclField pass } + | XConDeclRecField !(XXConDeclRecField pass) -- | Describes the arguments to a data constructor. This is a common -- representation for several constructor-related concepts, including: @@ -1079,41 +1062,56 @@ -- a separate data type entirely (see 'HsConDeclGADTDetails' in -- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with -- infix syntax, unlike the concepts above (#18844). -data HsConDetails tyarg arg rec - = PrefixCon [tyarg] [arg] -- C @t1 @t2 p1 p2 p3 +data HsConDetails arg rec + = PrefixCon [arg] -- C @t1 @t2 p1 p2 p3 | RecCon rec -- C { x = p1, y = p2 } | InfixCon arg arg -- p1 `C` p2 deriving Data --- | An empty list that can be used to indicate that there are no --- type arguments allowed in cases where HsConDetails is applied to Void. -noTypeArgs :: [Void] -noTypeArgs = [] +-- | Constructor declaration field specification, see Note [HsConDeclField on pass] +data HsConDeclField pass + = CDF { cdf_ext :: XConDeclField pass + -- ^ Extension point -conDetailsArity :: (rec -> Arity) -> HsConDetails tyarg arg rec -> Arity -conDetailsArity recToArity = \case - PrefixCon _ args -> length args - RecCon rec -> recToArity rec - InfixCon _ _ -> 2 + , cdf_unpack :: SrcUnpackedness + -- ^ UNPACK pragma if any + -- E.g. data T = MkT {-# UNPACK #-} Int + -- or data T where MtT :: {-# UNPACK #-} Int -> T -{- -Note [ConDeclField pass] -~~~~~~~~~~~~~~~~~~~~~~~~~ + , cdf_bang :: SrcStrictness + -- ^ User-specified strictness, if any + -- E.g. data T a = MkT !a + -- or data T a where MtT :: !a -> T a -A ConDeclField contains a list of field occurrences: these always -include the field label as the user wrote it. After the renamer, it -will additionally contain the identity of the selector function in the -second component. + , cdf_multiplicity :: HsMultAnn pass + -- ^ User-specified multiplicity, if any + -- E.g. data T a = MkT { t %Many :: a } + -- or data T a where MtT :: a %1 -> T a -Due to DuplicateRecordFields, the OccName of the selector function -may have been mangled, which is why we keep the original field label -separately. For example, when DuplicateRecordFields is enabled + , cdf_type :: LHsType pass + -- ^ The type of the field - data T = MkT { x :: Int } + , cdf_doc :: Maybe (LHsDoc pass) + -- ^ Documentation for the field + -- F.e. this very piece of documentation + } -gives +{- Note [HsConDeclField on pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`HsConDeclField` is used to specify the type of a data single constructor argument for all of: +* Haskell-98 style declarations (with prefix, infix or record syntax) + e.g. data T1 a = MkT (Maybe a) !Int +* GADT-style declarations with arrow syntax + e.g. data T2 a where MkT :: Maybe a -> !Int -> T2 a +* GADT-style declarations with record syntax + e.g. data T3 a where MkT :: { x :: Maybe a, y :: !Int } -> T3 a - ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. +Each argument type is decorated with any user-defined + a) UNPACK pragma `cdf_unpack` + b) strictness annotation `cdf_bang` + c) multiplicity annotation `cdf_multiplicity` + In the case of Haskell-98 style declarations, this only applies to record syntax. + d) documentation `cdf_doc` -} ----------------------- @@ -1137,36 +1135,62 @@ {- Note [hsScopedTvs and visible foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --XScopedTypeVariables can be defined in terms of a desugaring to --XTypeAbstractions (GHC Proposal #50): +ScopedTypeVariables can be defined in terms of a desugaring to TypeAbstractions +(GHC Proposals #155 and #448): fn :: forall a b c. tau(a,b,c) fn :: forall a b c. tau(a,b,c) fn = defn(a,b,c) ==> fn @x @y @z = defn(x,y,z) -That is, for every type variable of the leading 'forall' in the type signature, -we add an invisible binder at term level. +That is, for every type variable of the leading `forall` in the type signature, +we add an invisible binder at the term level. -This model does not extend to visible forall, as discussed here: +This model does not extend to visible forall. (Visible forall is the one written +with an arrow instead of a dot, i.e. `forall a ->`. See GHC Proposal #281 and +the RequiredTypeArguments extension). Here is an example that demonstrates the +issue: -* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412 -* https://github.com/ghc-proposals/ghc-proposals/pull/238 + vfn :: forall a b -> tau(a, b) + vfn = case of (p,q) -> \x y -> ... -The conclusion of these discussions can be summarized as follows: +The `a` and `b` cannot scope over the equations of `vfn`. In particular, +`a` and `b` cannot be in scope in because those type variables +are bound by the `\x y ->`. - > Assuming support for visible 'forall' in terms, consider this example: - > - > vfn :: forall x y -> tau(x,y) - > vfn = \a b -> ... - > - > The user has written their own binders 'a' and 'b' to stand for 'x' and - > 'y', and we definitely should not desugar this into: - > - > vfn :: forall x y -> tau(x,y) - > vfn x y = \a b -> ... -- bad! +Our solution is simple: ScopedTypeVariables has no effect on visible forall. +It follows naturally from the fact that ScopedTypeVariables is already subject +to several restrictions: -This design choice is reflected in the design of HsOuterSigTyVarBndrs, which are -used in every place that ScopedTypeVariables takes effect: + 1. The type signature must be headed by an /explicit/ forall + * `f :: forall a. a -> blah` brings `a` into scope in the body + * `f :: a -> blah` does not + 2. The forall is /not nested/ + * `f :: forall a b. blah` brings `a` and `b` into scope in the body + * `f :: forall a. forall b. blah` brings `a` but not `b` into scope in the body + +With the introduction of visible forall, we also introduce a third condition: + + 3. The forall has to be /invisible/ + * `f :: forall a b. blah` brings `a` and `b` into scope in the body + * `f :: forall a b -> blah` does not + +For example: + + f1 :: forall a. a -> a + f1 x = (x::a) -- OK: `a` is in scope in the body + + f2 :: forall a b. a -> b -> (a, b) + f2 x y = (x::a, y::b) -- OK: both `a` and `b` are in scope in the body + + f3 :: forall a. forall b. a -> b -> (a, b) + f3 x y = (x::a, y::b) -- Wrong: the `forall b.` is not the outermost forall + + f4 :: forall a -> a -> a + f4 t (x::t) = (x::a) -- Wrong: the `forall a ->` does not bring `a` into scope + +This design choice is reflected in the definition of HsOuterSigTyVarBndrs, which are +used in every place where ScopedTypeVariables takes effect: + data HsOuterTyVarBndrs flag pass = HsOuterImplicit { ... } | HsOuterExplicit { ..., hso_bndrs :: [LHsTyVarBndr flag pass] } @@ -1180,21 +1204,6 @@ (in hsScopedTvs), we /only/ bring the type variables bound by the hso_bndrs in an HsOuterExplicit into scope. If we have an HsOuterImplicit instead, then we do not bring any type variables into scope over the body of a function at all. - -At the moment, GHC does not support visible 'forall' in terms. Nevertheless, -it is still possible to write erroneous programs that use visible 'forall's in -terms, such as this example: - - x :: forall a -> a -> a - x = x - -Previous versions of GHC would bring `a` into scope over the body of `x` in the -hopes that the typechecker would error out later -(see `GHC.Tc.Validity.vdqAllowed`). However, this can wreak havoc in the -renamer before GHC gets to that point (see #17687 for an example of this). -Bottom line: nip problems in the bud by refraining from bringing any type -variables in an HsOuterImplicit into scope over the body of a function, even -if they correspond to a visible 'forall'. -} {- @@ -1207,10 +1216,16 @@ -- | Arguments in an expression/type after splitting data HsArg p tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg !(LHsToken "@" p) ty -- Argument is a visible type application (f @ty) - | HsArgPar SrcSpan -- See Note [HsArgPar] + = HsValArg !(XValArg p) tm -- Argument is an ordinary expression (f arg) + | HsTypeArg !(XTypeArg p) ty -- Argument is a visible type application (f @ty) + | HsArgPar !(XArgPar p) -- See Note [HsArgPar] + | XArg !(XXArg p) +type family XValArg p +type family XTypeArg p +type family XArgPar p +type family XXArg p + -- type level equivalent type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p) @@ -1244,44 +1259,46 @@ -- | Field Occurrence -- -- Represents an *occurrence* of a field. This may or may not be a --- binding occurrence (e.g. this type is used in 'ConDeclField' and +-- binding occurrence (e.g. this type is used in 'HsConDeclRecField' and -- 'RecordPatSynField' which bind their fields, but also in -- 'HsRecField' for record construction and patterns, which do not). -- -- We store both the 'RdrName' the user originally wrote, and after -- the renamer we use the extension field to store the selector --- function. +-- function. See note [FieldOcc pass] +-- +-- There is a wrinkle in that update field occurances are sometimes +-- ambiguous during the rename stage. See note +-- [Ambiguous FieldOcc in record updates] to see how we currently +-- handle this. data FieldOcc pass = FieldOcc { foExt :: XCFieldOcc pass - , foLabel :: XRec pass RdrName -- See Note [Located RdrNames] in Language.Haskell.Syntax.Expr + , foLabel :: LIdP pass } | XFieldOcc !(XXFieldOcc pass) deriving instance ( - Eq (XRec pass RdrName) + Eq (LIdP pass) , Eq (XCFieldOcc pass) , Eq (XXFieldOcc pass) ) => Eq (FieldOcc pass) --- | Located Ambiguous Field Occurence -type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass) +{- Note [FieldOcc pass] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The foLabel field of FieldOcc GhcRn contains the field name as the user wrote it. +After the renamer, a FieldOcc GhcTc has +- foExt field: A RdrName containing the original field label written by the user +- foLabel field: An Id for the field selector, whose OccName may have been mangled + to give it a globally unique identity. --- | Ambiguous Field Occurrence --- --- Represents an *occurrence* of a field that is potentially --- ambiguous after the renamer, with the ambiguity resolved by the --- typechecker. We always store the 'RdrName' that the user --- originally wrote, and store the selector function after the renamer --- (for unambiguous occurrences) or the typechecker (for ambiguous --- occurrences). --- --- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat". --- See Note [Located RdrNames] in "GHC.Hs.Expr". -data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (XRec pass RdrName) - | Ambiguous (XAmbiguous pass) (XRec pass RdrName) - | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) +For example, when DuplicateRecordFields is enabled + data T = MkT { x :: Int } + +gives + + FieldOcc "x" $sel:x:MkT. +-} {- ************************************************************************ diff --git a/Language/Haskell/Syntax/Type.hs-boot b/Language/Haskell/Syntax/Type.hs-boot --- a/Language/Haskell/Syntax/Type.hs-boot +++ b/Language/Haskell/Syntax/Type.hs-boot @@ -2,7 +2,10 @@ import Data.Bool import Data.Eq +import Data.Ord +import Control.DeepSeq + {- ************************************************************************ * * @@ -17,5 +20,7 @@ | IsPromoted instance Eq PromotionFlag +instance Ord PromotionFlag +instance NFData PromotionFlag isPromoted :: PromotionFlag -> Bool diff --git a/MachRegs.h b/MachRegs.h --- a/MachRegs.h +++ b/MachRegs.h @@ -51,638 +51,54 @@ #elif MACHREGS_NO_REGS == 0 /* ---------------------------------------------------------------------------- - Caller saves and callee-saves regs. - + Note [Caller saves and callee-saves regs.] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Caller-saves regs have to be saved around C-calls made from STG land, so this file defines CALLER_SAVES_ for each that is designated caller-saves in that machine's C calling convention. + NB: Caller-saved registers not mapped to a STG register don't + require a CALLER_SAVES_ define. As it stands, the only registers that are ever marked caller saves - are the RX, FX, DX and USER registers; as a result, if you + are the RX, FX, DX, XMM and USER registers; as a result, if you decide to caller save a system register (e.g. SP, HP, etc), note that this code path is completely untested! -- EZY See Note [Register parameter passing] for details. -------------------------------------------------------------------------- */ -/* ----------------------------------------------------------------------------- - The x86 register mapping - - Ok, we've only got 6 general purpose registers, a frame pointer and a - stack pointer. \tr{%eax} and \tr{%edx} are return values from C functions, - hence they get trashed across ccalls and are caller saves. \tr{%ebx}, - \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves. - - Reg STG-Reg - --------------- - ebx Base - ebp Sp - esi R1 - edi Hp - - Leaving SpLim out of the picture. - -------------------------------------------------------------------------- */ - -#if defined(MACHREGS_i386) - -#define REG(x) __asm__("%" #x) - -#if !defined(not_doing_dynamic_linking) -#define REG_Base ebx -#endif -#define REG_Sp ebp - -#if !defined(STOLEN_X86_REGS) -#define STOLEN_X86_REGS 4 -#endif - -#if STOLEN_X86_REGS >= 3 -# define REG_R1 esi -#endif - -#if STOLEN_X86_REGS >= 4 -# define REG_Hp edi -#endif -#define REG_MachSp esp - -#define REG_XMM1 xmm0 -#define REG_XMM2 xmm1 -#define REG_XMM3 xmm2 -#define REG_XMM4 xmm3 - -#define REG_YMM1 ymm0 -#define REG_YMM2 ymm1 -#define REG_YMM3 ymm2 -#define REG_YMM4 ymm3 - -#define REG_ZMM1 zmm0 -#define REG_ZMM2 zmm1 -#define REG_ZMM3 zmm2 -#define REG_ZMM4 zmm3 - -#define MAX_REAL_VANILLA_REG 1 /* always, since it defines the entry conv */ -#define MAX_REAL_FLOAT_REG 0 -#define MAX_REAL_DOUBLE_REG 0 -#define MAX_REAL_LONG_REG 0 -#define MAX_REAL_XMM_REG 4 -#define MAX_REAL_YMM_REG 4 -#define MAX_REAL_ZMM_REG 4 - -/* ----------------------------------------------------------------------------- - The x86-64 register mapping - - %rax caller-saves, don't steal this one - %rbx YES - %rcx arg reg, caller-saves - %rdx arg reg, caller-saves - %rsi arg reg, caller-saves - %rdi arg reg, caller-saves - %rbp YES (our *prime* register) - %rsp (unavailable - stack pointer) - %r8 arg reg, caller-saves - %r9 arg reg, caller-saves - %r10 caller-saves - %r11 caller-saves - %r12 YES - %r13 YES - %r14 YES - %r15 YES - - %xmm0-7 arg regs, caller-saves - %xmm8-15 caller-saves - - Use the caller-saves regs for Rn, because we don't always have to - save those (as opposed to Sp/Hp/SpLim etc. which always have to be - saved). - - --------------------------------------------------------------------------- */ - -#elif defined(MACHREGS_x86_64) - -#define REG(x) __asm__("%" #x) - -#define REG_Base r13 -#define REG_Sp rbp -#define REG_Hp r12 -#define REG_R1 rbx -#define REG_R2 r14 -#define REG_R3 rsi -#define REG_R4 rdi -#define REG_R5 r8 -#define REG_R6 r9 -#define REG_SpLim r15 -#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. -*/ - -#define REG_F1 xmm1 -#define REG_F2 xmm2 -#define REG_F3 xmm3 -#define REG_F4 xmm4 -#define REG_F5 xmm5 -#define REG_F6 xmm6 - -#define REG_D1 xmm1 -#define REG_D2 xmm2 -#define REG_D3 xmm3 -#define REG_D4 xmm4 -#define REG_D5 xmm5 -#define REG_D6 xmm6 - -#define REG_XMM1 xmm1 -#define REG_XMM2 xmm2 -#define REG_XMM3 xmm3 -#define REG_XMM4 xmm4 -#define REG_XMM5 xmm5 -#define REG_XMM6 xmm6 - -#define REG_YMM1 ymm1 -#define REG_YMM2 ymm2 -#define REG_YMM3 ymm3 -#define REG_YMM4 ymm4 -#define REG_YMM5 ymm5 -#define REG_YMM6 ymm6 - -#define REG_ZMM1 zmm1 -#define REG_ZMM2 zmm2 -#define REG_ZMM3 zmm3 -#define REG_ZMM4 zmm4 -#define REG_ZMM5 zmm5 -#define REG_ZMM6 zmm6 - -#if !defined(mingw32_HOST_OS) -#define CALLER_SAVES_R3 -#define CALLER_SAVES_R4 -#endif -#define CALLER_SAVES_R5 -#define CALLER_SAVES_R6 - -#define CALLER_SAVES_F1 -#define CALLER_SAVES_F2 -#define CALLER_SAVES_F3 -#define CALLER_SAVES_F4 -#define CALLER_SAVES_F5 -#if !defined(mingw32_HOST_OS) -#define CALLER_SAVES_F6 -#endif - -#define CALLER_SAVES_D1 -#define CALLER_SAVES_D2 -#define CALLER_SAVES_D3 -#define CALLER_SAVES_D4 -#define CALLER_SAVES_D5 -#if !defined(mingw32_HOST_OS) -#define CALLER_SAVES_D6 -#endif - -#define CALLER_SAVES_XMM1 -#define CALLER_SAVES_XMM2 -#define CALLER_SAVES_XMM3 -#define CALLER_SAVES_XMM4 -#define CALLER_SAVES_XMM5 -#if !defined(mingw32_HOST_OS) -#define CALLER_SAVES_XMM6 -#endif - -#define CALLER_SAVES_YMM1 -#define CALLER_SAVES_YMM2 -#define CALLER_SAVES_YMM3 -#define CALLER_SAVES_YMM4 -#define CALLER_SAVES_YMM5 -#if !defined(mingw32_HOST_OS) -#define CALLER_SAVES_YMM6 -#endif - -#define CALLER_SAVES_ZMM1 -#define CALLER_SAVES_ZMM2 -#define CALLER_SAVES_ZMM3 -#define CALLER_SAVES_ZMM4 -#define CALLER_SAVES_ZMM5 -#if !defined(mingw32_HOST_OS) -#define CALLER_SAVES_ZMM6 -#endif - -#define MAX_REAL_VANILLA_REG 6 -#define MAX_REAL_FLOAT_REG 6 -#define MAX_REAL_DOUBLE_REG 6 -#define MAX_REAL_LONG_REG 0 -#define MAX_REAL_XMM_REG 6 -#define MAX_REAL_YMM_REG 6 -#define MAX_REAL_ZMM_REG 6 - -/* ----------------------------------------------------------------------------- - The PowerPC register mapping - - 0 system glue? (caller-save, volatile) - 1 SP (callee-save, non-volatile) - 2 AIX, powerpc64-linux: - RTOC (a strange special case) - powerpc32-linux: - reserved for use by system - - 3-10 args/return (caller-save, volatile) - 11,12 system glue? (caller-save, volatile) - 13 on 64-bit: reserved for thread state pointer - on 32-bit: (callee-save, non-volatile) - 14-31 (callee-save, non-volatile) - - f0 (caller-save, volatile) - f1-f13 args/return (caller-save, volatile) - f14-f31 (callee-save, non-volatile) - - \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes. - \tr{0}--\tr{12} are caller-save registers. - - \tr{%f14}--\tr{%f31} are callee-save floating-point registers. +/* Define STG <-> machine register mappings. */ +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) - We can do the Whole Business with callee-save registers only! - -------------------------------------------------------------------------- */ +#include "MachRegs/x86.h" #elif defined(MACHREGS_powerpc) -#define REG(x) __asm__(#x) - -#define REG_R1 r14 -#define REG_R2 r15 -#define REG_R3 r16 -#define REG_R4 r17 -#define REG_R5 r18 -#define REG_R6 r19 -#define REG_R7 r20 -#define REG_R8 r21 -#define REG_R9 r22 -#define REG_R10 r23 - -#define REG_F1 fr14 -#define REG_F2 fr15 -#define REG_F3 fr16 -#define REG_F4 fr17 -#define REG_F5 fr18 -#define REG_F6 fr19 - -#define REG_D1 fr20 -#define REG_D2 fr21 -#define REG_D3 fr22 -#define REG_D4 fr23 -#define REG_D5 fr24 -#define REG_D6 fr25 - -#define REG_Sp r24 -#define REG_SpLim r25 -#define REG_Hp r26 -#define REG_Base r27 - -#define MAX_REAL_FLOAT_REG 6 -#define MAX_REAL_DOUBLE_REG 6 - -/* ----------------------------------------------------------------------------- - The ARM EABI register mapping - - Here we consider ARM mode (i.e. 32bit isns) - and also CPU with full VFPv3 implementation - - ARM registers (see Chapter 5.1 in ARM IHI 0042D and - Section 9.2.2 in ARM Software Development Toolkit Reference Guide) - - r15 PC The Program Counter. - r14 LR The Link Register. - r13 SP The Stack Pointer. - r12 IP The Intra-Procedure-call scratch register. - r11 v8/fp Variable-register 8. - r10 v7/sl Variable-register 7. - r9 v6/SB/TR Platform register. The meaning of this register is - defined by the platform standard. - r8 v5 Variable-register 5. - r7 v4 Variable register 4. - r6 v3 Variable register 3. - r5 v2 Variable register 2. - r4 v1 Variable register 1. - r3 a4 Argument / scratch register 4. - r2 a3 Argument / scratch register 3. - r1 a2 Argument / result / scratch register 2. - r0 a1 Argument / result / scratch register 1. - - VFPv2/VFPv3/NEON registers - s0-s15/d0-d7/q0-q3 Argument / result/ scratch registers - s16-s31/d8-d15/q4-q7 callee-saved registers (must be preserved across - subroutine calls) - - VFPv3/NEON registers (added to the VFPv2 registers set) - d16-d31/q8-q15 Argument / result/ scratch registers - ----------------------------------------------------------------------------- */ +#include "MachRegs/ppc.h" #elif defined(MACHREGS_arm) -#define REG(x) __asm__(#x) - -#define REG_Base r4 -#define REG_Sp r5 -#define REG_Hp r6 -#define REG_R1 r7 -#define REG_R2 r8 -#define REG_R3 r9 -#define REG_R4 r10 -#define REG_SpLim r11 - -#if !defined(arm_HOST_ARCH_PRE_ARMv6) -/* d8 */ -#define REG_F1 s16 -#define REG_F2 s17 -/* d9 */ -#define REG_F3 s18 -#define REG_F4 s19 - -#define REG_D1 d10 -#define REG_D2 d11 -#endif - -/* ----------------------------------------------------------------------------- - The ARMv8/AArch64 ABI register mapping - - The AArch64 provides 31 64-bit general purpose registers - and 32 128-bit SIMD/floating point registers. - - General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B) - - Register | Special | Role in the procedure call standard - ---------+---------+------------------------------------ - SP | | The Stack Pointer - r30 | LR | The Link Register - r29 | FP | The Frame Pointer - r19-r28 | | Callee-saved registers - r18 | | The Platform Register, if needed; - | | or temporary register - r17 | IP1 | The second intra-procedure-call temporary register - r16 | IP0 | The first intra-procedure-call scratch register - r9-r15 | | Temporary registers - r8 | | Indirect result location register - r0-r7 | | Parameter/result registers - - - FPU/SIMD registers - - s/d/q/v0-v7 Argument / result/ scratch registers - s/d/q/v8-v15 callee-saved registers (must be preserved across subroutine calls, - but only bottom 64-bit value needs to be preserved) - s/d/q/v16-v31 temporary registers - - ----------------------------------------------------------------------------- */ +#include "MachRegs/arm32.h" #elif defined(MACHREGS_aarch64) -#define REG(x) __asm__(#x) - -#define REG_Base r19 -#define REG_Sp r20 -#define REG_Hp r21 -#define REG_R1 r22 -#define REG_R2 r23 -#define REG_R3 r24 -#define REG_R4 r25 -#define REG_R5 r26 -#define REG_R6 r27 -#define REG_SpLim r28 - -#define REG_F1 s8 -#define REG_F2 s9 -#define REG_F3 s10 -#define REG_F4 s11 - -#define REG_D1 d12 -#define REG_D2 d13 -#define REG_D3 d14 -#define REG_D4 d15 - -#define REG_XMM1 q4 -#define REG_XMM2 q5 - -#define CALLER_SAVES_XMM1 -#define CALLER_SAVES_XMM2 - -/* ----------------------------------------------------------------------------- - The s390x register mapping - - Register | Role(s) | Call effect - ------------+-------------------------------------+----------------- - r0,r1 | - | caller-saved - r2 | Argument / return value | caller-saved - r3,r4,r5 | Arguments | caller-saved - r6 | Argument | callee-saved - r7...r11 | - | callee-saved - r12 | (Commonly used as GOT pointer) | callee-saved - r13 | (Commonly used as literal pool pointer) | callee-saved - r14 | Return address | caller-saved - r15 | Stack pointer | callee-saved - f0 | Argument / return value | caller-saved - f2,f4,f6 | Arguments | caller-saved - f1,f3,f5,f7 | - | caller-saved - f8...f15 | - | callee-saved - v0...v31 | - | caller-saved - - Each general purpose register r0 through r15 as well as each floating-point - register f0 through f15 is 64 bits wide. Each vector register v0 through v31 - is 128 bits wide. - - Note, the vector registers v0 through v15 overlap with the floating-point - registers f0 through f15. - - -------------------------------------------------------------------------- */ +#include "MachRegs/arm64.h" #elif defined(MACHREGS_s390x) -#define REG(x) __asm__("%" #x) - -#define REG_Base r7 -#define REG_Sp r8 -#define REG_Hp r10 -#define REG_R1 r11 -#define REG_R2 r12 -#define REG_R3 r13 -#define REG_R4 r6 -#define REG_R5 r2 -#define REG_R6 r3 -#define REG_R7 r4 -#define REG_R8 r5 -#define REG_SpLim r9 -#define REG_MachSp r15 - -#define REG_F1 f8 -#define REG_F2 f9 -#define REG_F3 f10 -#define REG_F4 f11 -#define REG_F5 f0 -#define REG_F6 f1 - -#define REG_D1 f12 -#define REG_D2 f13 -#define REG_D3 f14 -#define REG_D4 f15 -#define REG_D5 f2 -#define REG_D6 f3 - -#define CALLER_SAVES_R5 -#define CALLER_SAVES_R6 -#define CALLER_SAVES_R7 -#define CALLER_SAVES_R8 - -#define CALLER_SAVES_F5 -#define CALLER_SAVES_F6 - -#define CALLER_SAVES_D5 -#define CALLER_SAVES_D6 - -/* ----------------------------------------------------------------------------- - The riscv64 register mapping - - Register | Role(s) | Call effect - ------------+-----------------------------------------+------------- - zero | Hard-wired zero | - - ra | Return address | caller-saved - sp | Stack pointer | callee-saved - gp | Global pointer | callee-saved - tp | Thread pointer | callee-saved - t0,t1,t2 | - | caller-saved - s0 | Frame pointer | callee-saved - s1 | - | callee-saved - a0,a1 | Arguments / return values | caller-saved - a2..a7 | Arguments | caller-saved - s2..s11 | - | callee-saved - t3..t6 | - | caller-saved - ft0..ft7 | - | caller-saved - fs0,fs1 | - | callee-saved - fa0,fa1 | Arguments / return values | caller-saved - fa2..fa7 | Arguments | caller-saved - fs2..fs11 | - | callee-saved - ft8..ft11 | - | caller-saved - - Each general purpose register as well as each floating-point - register is 64 bits wide. - - -------------------------------------------------------------------------- */ +#include "MachRegs/s390x.h" #elif defined(MACHREGS_riscv64) -#define REG(x) __asm__(#x) - -#define REG_Base s1 -#define REG_Sp s2 -#define REG_Hp s3 -#define REG_R1 s4 -#define REG_R2 s5 -#define REG_R3 s6 -#define REG_R4 s7 -#define REG_R5 s8 -#define REG_R6 s9 -#define REG_R7 s10 -#define REG_SpLim s11 - -#define REG_F1 fs0 -#define REG_F2 fs1 -#define REG_F3 fs2 -#define REG_F4 fs3 -#define REG_F5 fs4 -#define REG_F6 fs5 - -#define REG_D1 fs6 -#define REG_D2 fs7 -#define REG_D3 fs8 -#define REG_D4 fs9 -#define REG_D5 fs10 -#define REG_D6 fs11 - -#define MAX_REAL_FLOAT_REG 6 -#define MAX_REAL_DOUBLE_REG 6 +#include "MachRegs/riscv64.h" #elif defined(MACHREGS_wasm32) -#define REG_Base 0 - -#define REG_R1 1 -#define REG_R2 2 -#define REG_R3 3 -#define REG_R4 4 -#define REG_R5 5 -#define REG_R6 6 -#define REG_R7 7 -#define REG_R8 8 -#define REG_R9 9 -#define REG_R10 10 - -#define REG_F1 11 -#define REG_F2 12 -#define REG_F3 13 -#define REG_F4 14 -#define REG_F5 15 -#define REG_F6 16 - -#define REG_D1 17 -#define REG_D2 18 -#define REG_D3 19 -#define REG_D4 20 -#define REG_D5 21 -#define REG_D6 22 - -#define REG_L1 23 - -#define REG_Sp 24 -#define REG_SpLim 25 -#define REG_Hp 26 -#define REG_HpLim 27 - -/* ----------------------------------------------------------------------------- - The loongarch64 register mapping - - Register | Role(s) | Call effect - ------------+-----------------------------------------+------------- - zero | Hard-wired zero | - - ra | Return address | caller-saved - tp | Thread pointer | - - sp | Stack pointer | callee-saved - a0,a1 | Arguments / return values | caller-saved - a2..a7 | Arguments | caller-saved - t0..t8 | - | caller-saved - u0 | Reserve | - - fp | Frame pointer | callee-saved - s0..s8 | - | callee-saved - fa0,fa1 | Arguments / return values | caller-saved - fa2..fa7 | Arguments | caller-saved - ft0..ft15 | - | caller-saved - fs0..fs7 | - | callee-saved - - Each general purpose register as well as each floating-point - register is 64 bits wide, also, the u0 register is called r21 in some cases. +#include "MachRegs/wasm32.h" - -------------------------------------------------------------------------- */ #elif defined(MACHREGS_loongarch64) -#define REG(x) __asm__("$" #x) - -#define REG_Base s0 -#define REG_Sp s1 -#define REG_Hp s2 -#define REG_R1 s3 -#define REG_R2 s4 -#define REG_R3 s5 -#define REG_R4 s6 -#define REG_R5 s7 -#define REG_SpLim s8 - -#define REG_F1 fs0 -#define REG_F2 fs1 -#define REG_F3 fs2 -#define REG_F4 fs3 - -#define REG_D1 fs4 -#define REG_D2 fs5 -#define REG_D3 fs6 -#define REG_D4 fs7 - -#define MAX_REAL_FLOAT_REG 4 -#define MAX_REAL_DOUBLE_REG 4 +#include "MachRegs/loongarch64.h" #else @@ -806,7 +222,7 @@ /* define NO_ARG_REGS if we have no argument registers at all (we can * optimise certain code paths using this predicate). */ -#if MAX_REAL_VANILLA_REG < 2 +#if MAX_REAL_VANILLA_REG < 2 && MAX_REAL_XMM_REG == 0 #define NO_ARG_REGS #else #undef NO_ARG_REGS diff --git a/MachRegs/arm32.h b/MachRegs/arm32.h new file mode 100644 --- /dev/null +++ b/MachRegs/arm32.h @@ -0,0 +1,60 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + The ARM EABI register mapping + + Here we consider ARM mode (i.e. 32bit isns) + and also CPU with full VFPv3 implementation + + ARM registers (see Chapter 5.1 in ARM IHI 0042D and + Section 9.2.2 in ARM Software Development Toolkit Reference Guide) + + r15 PC The Program Counter. + r14 LR The Link Register. + r13 SP The Stack Pointer. + r12 IP The Intra-Procedure-call scratch register. + r11 v8/fp Variable-register 8. + r10 v7/sl Variable-register 7. + r9 v6/SB/TR Platform register. The meaning of this register is + defined by the platform standard. + r8 v5 Variable-register 5. + r7 v4 Variable register 4. + r6 v3 Variable register 3. + r5 v2 Variable register 2. + r4 v1 Variable register 1. + r3 a4 Argument / scratch register 4. + r2 a3 Argument / scratch register 3. + r1 a2 Argument / result / scratch register 2. + r0 a1 Argument / result / scratch register 1. + + VFPv2/VFPv3/NEON registers + s0-s15/d0-d7/q0-q3 Argument / result/ scratch registers + s16-s31/d8-d15/q4-q7 callee-saved registers (must be preserved across + subroutine calls) + + VFPv3/NEON registers (added to the VFPv2 registers set) + d16-d31/q8-q15 Argument / result/ scratch registers + ----------------------------------------------------------------------------- */ + +#define REG(x) __asm__(#x) + +#define REG_Base r4 +#define REG_Sp r5 +#define REG_Hp r6 +#define REG_R1 r7 +#define REG_R2 r8 +#define REG_R3 r9 +#define REG_R4 r10 +#define REG_SpLim r11 + +#if !defined(arm_HOST_ARCH_PRE_ARMv6) +/* d8 */ +#define REG_F1 s16 +#define REG_F2 s17 +/* d9 */ +#define REG_F3 s18 +#define REG_F4 s19 + +#define REG_D1 d10 +#define REG_D2 d11 +#endif diff --git a/MachRegs/arm64.h b/MachRegs/arm64.h new file mode 100644 --- /dev/null +++ b/MachRegs/arm64.h @@ -0,0 +1,64 @@ +#pragma once + + +/* ----------------------------------------------------------------------------- + The ARMv8/AArch64 ABI register mapping + + The AArch64 provides 31 64-bit general purpose registers + and 32 128-bit SIMD/floating point registers. + + General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B) + + Register | Special | Role in the procedure call standard + ---------+---------+------------------------------------ + SP | | The Stack Pointer + r30 | LR | The Link Register + r29 | FP | The Frame Pointer + r19-r28 | | Callee-saved registers + r18 | | The Platform Register, if needed; + | | or temporary register + r17 | IP1 | The second intra-procedure-call temporary register + r16 | IP0 | The first intra-procedure-call scratch register + r9-r15 | | Temporary registers + r8 | | Indirect result location register + r0-r7 | | Parameter/result registers + + + FPU/SIMD registers + + s/d/q/v0-v7 Argument / result/ scratch registers + s/d/q/v8-v15 callee-saved registers (must be preserved across subroutine calls, + but only bottom 64-bit value needs to be preserved) + s/d/q/v16-v31 temporary registers + + ----------------------------------------------------------------------------- */ + +#define REG(x) __asm__(#x) + +#define REG_Base r19 +#define REG_Sp r20 +#define REG_Hp r21 +#define REG_R1 r22 +#define REG_R2 r23 +#define REG_R3 r24 +#define REG_R4 r25 +#define REG_R5 r26 +#define REG_R6 r27 +#define REG_SpLim r28 + +#define REG_F1 s8 +#define REG_F2 s9 +#define REG_F3 s10 +#define REG_F4 s11 + +#define REG_D1 d12 +#define REG_D2 d13 +#define REG_D3 d14 +#define REG_D4 d15 + +#define REG_XMM1 q4 +#define REG_XMM2 q5 + +#define CALLER_SAVES_XMM1 +#define CALLER_SAVES_XMM2 + diff --git a/MachRegs/loongarch64.h b/MachRegs/loongarch64.h new file mode 100644 --- /dev/null +++ b/MachRegs/loongarch64.h @@ -0,0 +1,48 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + The loongarch64 register mapping + + Register | Role(s) | Call effect + ------------+-----------------------------------------+------------- + zero | Hard-wired zero | - + ra | Return address | caller-saved + tp | Thread pointer | - + sp | Stack pointer | callee-saved + a0,a1 | Arguments / return values | caller-saved + a2..a7 | Arguments | caller-saved + t0..t8 | - | caller-saved + u0 | Reserve | - + fp | Frame pointer | callee-saved + s0..s8 | - | callee-saved + fa0,fa1 | Arguments / return values | caller-saved + fa2..fa7 | Arguments | caller-saved + ft0..ft15 | - | caller-saved + fs0..fs7 | - | callee-saved + + Each general purpose register as well as each floating-point + register is 64 bits wide, also, the u0 register is called r21 in some cases. + + -------------------------------------------------------------------------- */ + +#define REG(x) __asm__("$" #x) + +#define REG_Base s0 +#define REG_Sp s1 +#define REG_Hp s2 +#define REG_R1 s3 +#define REG_R2 s4 +#define REG_R3 s5 +#define REG_R4 s6 +#define REG_R5 s7 +#define REG_SpLim s8 + +#define REG_F1 fs0 +#define REG_F2 fs1 +#define REG_F3 fs2 +#define REG_F4 fs3 + +#define REG_D1 fs4 +#define REG_D2 fs5 +#define REG_D3 fs6 +#define REG_D4 fs7 diff --git a/MachRegs/ppc.h b/MachRegs/ppc.h new file mode 100644 --- /dev/null +++ b/MachRegs/ppc.h @@ -0,0 +1,62 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + The PowerPC register mapping + + 0 system glue? (caller-save, volatile) + 1 SP (callee-save, non-volatile) + 2 AIX, powerpc64-linux: + RTOC (a strange special case) + powerpc32-linux: + reserved for use by system + + 3-10 args/return (caller-save, volatile) + 11,12 system glue? (caller-save, volatile) + 13 on 64-bit: reserved for thread state pointer + on 32-bit: (callee-save, non-volatile) + 14-31 (callee-save, non-volatile) + + f0 (caller-save, volatile) + f1-f13 args/return (caller-save, volatile) + f14-f31 (callee-save, non-volatile) + + \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes. + \tr{0}--\tr{12} are caller-save registers. + + \tr{%f14}--\tr{%f31} are callee-save floating-point registers. + + We can do the Whole Business with callee-save registers only! + -------------------------------------------------------------------------- */ + + +#define REG(x) __asm__(#x) + +#define REG_R1 r14 +#define REG_R2 r15 +#define REG_R3 r16 +#define REG_R4 r17 +#define REG_R5 r18 +#define REG_R6 r19 +#define REG_R7 r20 +#define REG_R8 r21 +#define REG_R9 r22 +#define REG_R10 r23 + +#define REG_F1 fr14 +#define REG_F2 fr15 +#define REG_F3 fr16 +#define REG_F4 fr17 +#define REG_F5 fr18 +#define REG_F6 fr19 + +#define REG_D1 fr20 +#define REG_D2 fr21 +#define REG_D3 fr22 +#define REG_D4 fr23 +#define REG_D5 fr24 +#define REG_D6 fr25 + +#define REG_Sp r24 +#define REG_SpLim r25 +#define REG_Hp r26 +#define REG_Base r27 diff --git a/MachRegs/riscv64.h b/MachRegs/riscv64.h new file mode 100644 --- /dev/null +++ b/MachRegs/riscv64.h @@ -0,0 +1,58 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + The riscv64 register mapping + + Register | Role(s) | Call effect + ------------+-----------------------------------------+------------- + zero | Hard-wired zero | - + ra | Return address | caller-saved + sp | Stack pointer | callee-saved + gp | Global pointer | callee-saved + tp | Thread pointer | callee-saved + t0,t1,t2 | - | caller-saved + s0 | Frame pointer | callee-saved + s1 | - | callee-saved + a0,a1 | Arguments / return values | caller-saved + a2..a7 | Arguments | caller-saved + s2..s11 | - | callee-saved + t3..t6 | - | caller-saved + ft0..ft7 | - | caller-saved + fs0,fs1 | - | callee-saved + fa0,fa1 | Arguments / return values | caller-saved + fa2..fa7 | Arguments | caller-saved + fs2..fs11 | - | callee-saved + ft8..ft11 | - | caller-saved + + Each general purpose register as well as each floating-point + register is 64 bits wide. + + -------------------------------------------------------------------------- */ + +#define REG(x) __asm__(#x) + +#define REG_Base s1 +#define REG_Sp s2 +#define REG_Hp s3 +#define REG_R1 s4 +#define REG_R2 s5 +#define REG_R3 s6 +#define REG_R4 s7 +#define REG_R5 s8 +#define REG_R6 s9 +#define REG_R7 s10 +#define REG_SpLim s11 + +#define REG_F1 fs0 +#define REG_F2 fs1 +#define REG_F3 fs2 +#define REG_F4 fs3 +#define REG_F5 fs4 +#define REG_F6 fs5 + +#define REG_D1 fs6 +#define REG_D2 fs7 +#define REG_D3 fs8 +#define REG_D4 fs9 +#define REG_D5 fs10 +#define REG_D6 fs11 diff --git a/MachRegs/s390x.h b/MachRegs/s390x.h new file mode 100644 --- /dev/null +++ b/MachRegs/s390x.h @@ -0,0 +1,72 @@ +#pragma once + +/* ----------------------------------------------------------------------------- + The s390x register mapping + + Register | Role(s) | Call effect + ------------+-------------------------------------+----------------- + r0,r1 | - | caller-saved + r2 | Argument / return value | caller-saved + r3,r4,r5 | Arguments | caller-saved + r6 | Argument | callee-saved + r7...r11 | - | callee-saved + r12 | (Commonly used as GOT pointer) | callee-saved + r13 | (Commonly used as literal pool pointer) | callee-saved + r14 | Return address | caller-saved + r15 | Stack pointer | callee-saved + f0 | Argument / return value | caller-saved + f2,f4,f6 | Arguments | caller-saved + f1,f3,f5,f7 | - | caller-saved + f8...f15 | - | callee-saved + v0...v31 | - | caller-saved + + Each general purpose register r0 through r15 as well as each floating-point + register f0 through f15 is 64 bits wide. Each vector register v0 through v31 + is 128 bits wide. + + Note, the vector registers v0 through v15 overlap with the floating-point + registers f0 through f15. + + -------------------------------------------------------------------------- */ + + +#define REG(x) __asm__("%" #x) + +#define REG_Base r7 +#define REG_Sp r8 +#define REG_Hp r10 +#define REG_R1 r11 +#define REG_R2 r12 +#define REG_R3 r13 +#define REG_R4 r6 +#define REG_R5 r2 +#define REG_R6 r3 +#define REG_R7 r4 +#define REG_R8 r5 +#define REG_SpLim r9 +#define REG_MachSp r15 + +#define REG_F1 f8 +#define REG_F2 f9 +#define REG_F3 f10 +#define REG_F4 f11 +#define REG_F5 f0 +#define REG_F6 f1 + +#define REG_D1 f12 +#define REG_D2 f13 +#define REG_D3 f14 +#define REG_D4 f15 +#define REG_D5 f2 +#define REG_D6 f3 + +#define CALLER_SAVES_R5 +#define CALLER_SAVES_R6 +#define CALLER_SAVES_R7 +#define CALLER_SAVES_R8 + +#define CALLER_SAVES_F5 +#define CALLER_SAVES_F6 + +#define CALLER_SAVES_D5 +#define CALLER_SAVES_D6 diff --git a/MachRegs/wasm32.h b/MachRegs/wasm32.h new file mode 100644 --- /dev/null +++ b/MachRegs/wasm32.h @@ -0,0 +1,35 @@ +#pragma once + +#define REG_Base 0 + +#define REG_R1 1 +#define REG_R2 2 +#define REG_R3 3 +#define REG_R4 4 +#define REG_R5 5 +#define REG_R6 6 +#define REG_R7 7 +#define REG_R8 8 +#define REG_R9 9 +#define REG_R10 10 + +#define REG_F1 11 +#define REG_F2 12 +#define REG_F3 13 +#define REG_F4 14 +#define REG_F5 15 +#define REG_F6 16 + +#define REG_D1 17 +#define REG_D2 18 +#define REG_D3 19 +#define REG_D4 20 +#define REG_D5 21 +#define REG_D6 22 + +#define REG_L1 23 + +#define REG_Sp 24 +#define REG_SpLim 25 +#define REG_Hp 26 +#define REG_HpLim 27 diff --git a/MachRegs/x86.h b/MachRegs/x86.h new file mode 100644 --- /dev/null +++ b/MachRegs/x86.h @@ -0,0 +1,216 @@ +/* ----------------------------------------------------------------------------- + The x86 register mapping + + Ok, we've only got 6 general purpose registers, a frame pointer and a + stack pointer. \tr{%eax} and \tr{%edx} are return values from C functions, + hence they get trashed across ccalls and are caller saves. \tr{%ebx}, + \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves. + + Reg STG-Reg + --------------- + ebx Base + ebp Sp + esi R1 + edi Hp + + Leaving SpLim out of the picture. + -------------------------------------------------------------------------- */ + +#if defined(MACHREGS_i386) + +#define REG(x) __asm__("%" #x) + +#if !defined(not_doing_dynamic_linking) +#define REG_Base ebx +#endif +#define REG_Sp ebp + +#if !defined(STOLEN_X86_REGS) +#define STOLEN_X86_REGS 4 +#endif + +#if STOLEN_X86_REGS >= 3 +# define REG_R1 esi +#endif + +#if STOLEN_X86_REGS >= 4 +# define REG_Hp edi +#endif +#define REG_MachSp esp + +#define REG_XMM1 xmm0 +#define REG_XMM2 xmm1 +#define REG_XMM3 xmm2 +#define REG_XMM4 xmm3 + +#define REG_YMM1 ymm0 +#define REG_YMM2 ymm1 +#define REG_YMM3 ymm2 +#define REG_YMM4 ymm3 + +#define REG_ZMM1 zmm0 +#define REG_ZMM2 zmm1 +#define REG_ZMM3 zmm2 +#define REG_ZMM4 zmm3 + +#define MAX_REAL_VANILLA_REG 1 /* always, since it defines the entry conv */ +#define MAX_REAL_FLOAT_REG 0 +#define MAX_REAL_DOUBLE_REG 0 +#define MAX_REAL_LONG_REG 0 +#define MAX_REAL_XMM_REG 4 +#define MAX_REAL_YMM_REG 4 +#define MAX_REAL_ZMM_REG 4 + +/* ----------------------------------------------------------------------------- + The x86-64 register mapping + + %rax caller-saves, don't steal this one + %rbx YES + %rcx arg reg, caller-saves + %rdx arg reg, caller-saves + %rsi arg reg, caller-saves + %rdi arg reg, caller-saves + %rbp YES (our *prime* register) + %rsp (unavailable - stack pointer) + %r8 arg reg, caller-saves + %r9 arg reg, caller-saves + %r10 caller-saves + %r11 caller-saves + %r12 YES + %r13 YES + %r14 YES + %r15 YES + + %xmm0-7 arg regs, caller-saves + %xmm8-15 caller-saves + + Use the caller-saves regs for Rn, because we don't always have to + save those (as opposed to Sp/Hp/SpLim etc. which always have to be + saved). + + --------------------------------------------------------------------------- */ + +#elif defined(MACHREGS_x86_64) + +#define REG(x) __asm__("%" #x) + +#define REG_Base r13 +#define REG_Sp rbp +#define REG_Hp r12 +#define REG_R1 rbx +#define REG_R2 r14 +#define REG_R3 rsi +#define REG_R4 rdi +#define REG_R5 r8 +#define REG_R6 r9 +#define REG_SpLim r15 +#define REG_MachSp rsp + +/* +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 +#define REG_F2 xmm2 +#define REG_F3 xmm3 +#define REG_F4 xmm4 +#define REG_F5 xmm5 +#define REG_F6 xmm6 + +#define REG_D1 xmm1 +#define REG_D2 xmm2 +#define REG_D3 xmm3 +#define REG_D4 xmm4 +#define REG_D5 xmm5 +#define REG_D6 xmm6 + +#define REG_XMM1 xmm1 +#define REG_XMM2 xmm2 +#define REG_XMM3 xmm3 +#define REG_XMM4 xmm4 +#define REG_XMM5 xmm5 +#define REG_XMM6 xmm6 + +#define REG_YMM1 ymm1 +#define REG_YMM2 ymm2 +#define REG_YMM3 ymm3 +#define REG_YMM4 ymm4 +#define REG_YMM5 ymm5 +#define REG_YMM6 ymm6 + +#define REG_ZMM1 zmm1 +#define REG_ZMM2 zmm2 +#define REG_ZMM3 zmm3 +#define REG_ZMM4 zmm4 +#define REG_ZMM5 zmm5 +#define REG_ZMM6 zmm6 + +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_R3 +#define CALLER_SAVES_R4 +#endif +#define CALLER_SAVES_R5 +#define CALLER_SAVES_R6 + +#define CALLER_SAVES_F1 +#define CALLER_SAVES_F2 +#define CALLER_SAVES_F3 +#define CALLER_SAVES_F4 +#define CALLER_SAVES_F5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_F6 +#endif + +#define CALLER_SAVES_D1 +#define CALLER_SAVES_D2 +#define CALLER_SAVES_D3 +#define CALLER_SAVES_D4 +#define CALLER_SAVES_D5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_D6 +#endif + +#define CALLER_SAVES_XMM1 +#define CALLER_SAVES_XMM2 +#define CALLER_SAVES_XMM3 +#define CALLER_SAVES_XMM4 +#define CALLER_SAVES_XMM5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_XMM6 +#endif + +#define CALLER_SAVES_YMM1 +#define CALLER_SAVES_YMM2 +#define CALLER_SAVES_YMM3 +#define CALLER_SAVES_YMM4 +#define CALLER_SAVES_YMM5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_YMM6 +#endif + +#define CALLER_SAVES_ZMM1 +#define CALLER_SAVES_ZMM2 +#define CALLER_SAVES_ZMM3 +#define CALLER_SAVES_ZMM4 +#define CALLER_SAVES_ZMM5 +#if !defined(mingw32_HOST_OS) +#define CALLER_SAVES_ZMM6 +#endif + +#define MAX_REAL_VANILLA_REG 6 +#define MAX_REAL_FLOAT_REG 6 +#define MAX_REAL_DOUBLE_REG 6 +#define MAX_REAL_LONG_REG 0 +#define MAX_REAL_XMM_REG 6 +#define MAX_REAL_YMM_REG 6 +#define MAX_REAL_ZMM_REG 6 + +#endif /* MACHREGS_i386 || MACHREGS_x86_64 */ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Main where import Distribution.Simple @@ -11,6 +11,7 @@ import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.Simple.Setup +import Distribution.Simple.PackageIndex import System.IO import System.Process @@ -38,12 +39,13 @@ [ ("primop-data-decl.hs-incl" , "--data-decl") , ("primop-tag.hs-incl" , "--primop-tag") , ("primop-list.hs-incl" , "--primop-list") - , ("primop-has-side-effects.hs-incl" , "--has-side-effects") + , ("primop-effects.hs-incl" , "--primop-effects") , ("primop-out-of-line.hs-incl" , "--out-of-line") , ("primop-commutable.hs-incl" , "--commutable") , ("primop-code-size.hs-incl" , "--code-size") - , ("primop-can-fail.hs-incl" , "--can-fail") , ("primop-strictness.hs-incl" , "--strictness") + , ("primop-is-work-free.hs-incl" , "--is-work-free") + , ("primop-is-cheap.hs-incl" , "--is-cheap") , ("primop-fixity.hs-incl" , "--fixity") , ("primop-primop-info.hs-incl" , "--primop-primop-info") , ("primop-vector-uniques.hs-incl" , "--primop-vector-uniques") @@ -51,10 +53,12 @@ , ("primop-vector-tys-exports.hs-incl", "--primop-vector-tys-exports") , ("primop-vector-tycons.hs-incl" , "--primop-vector-tycons") , ("primop-docs.hs-incl" , "--wired-in-docs") + , ("primop-deprecations.hs-incl" , "--wired-in-deprecations") ] ghcAutogen :: Verbosity -> LocalBuildInfo -> IO () -ghcAutogen verbosity lbi@LocalBuildInfo{..} = do +ghcAutogen verbosity lbi@LocalBuildInfo{pkgDescrFile,withPrograms,componentNameMap,installedPkgs} + = do -- Get compiler/ root directory from the cabal file let Just compilerRoot = takeDirectory <$> pkgDescrFile @@ -76,7 +80,7 @@ -- Call genprimopcode to generate *.hs-incl forM_ primopIncls $ \(file,command) -> do contents <- readProcess "genprimopcode" [command] primopsStr - rewriteFileEx verbosity (buildDir file) contents + rewriteFileEx verbosity (buildDir lbi file) contents -- Write GHC.Platform.Constants let platformConstantsPath = autogenPackageModulesDir lbi "GHC/Platform/Constants.hs" @@ -93,9 +97,14 @@ Just [LibComponentLocalBuildInfo{componentUnitId}] -> unUnitId componentUnitId _ -> error "Couldn't find unique cabal library when building ghc" + let cGhcInternalUnitId = case lookupPackageName installedPkgs (mkPackageName "ghc-internal") of + -- We assume there is exactly one copy of `ghc-internal` in our dependency closure + [(_,[packageInfo])] -> unUnitId $ installedUnitId packageInfo + _ -> error "Couldn't find unique ghc-internal library when building ghc" + -- Write GHC.Settings.Config configHsPath = autogenPackageModulesDir lbi "GHC/Settings/Config.hs" - configHs = generateConfigHs cProjectUnitId settings + configHs = generateConfigHs cProjectUnitId cGhcInternalUnitId settings createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath) rewriteFileEx verbosity configHsPath configHs @@ -107,8 +116,9 @@ Just v -> Right v generateConfigHs :: String -- ^ ghc's cabal-generated unit-id, which matches its package-id/key + -> String -- ^ ghc-internal's cabal-generated unit-id, which matches its package-id/key -> [(String,String)] -> String -generateConfigHs cProjectUnitId settings = either error id $ do +generateConfigHs cProjectUnitId cGhcInternalUnitId settings = either error id $ do let getSetting' = getSetting $ (("cStage","2"):) settings buildPlatform <- getSetting' "cBuildPlatformString" "Host platform" hostPlatform <- getSetting' "cHostPlatformString" "Target platform" @@ -124,6 +134,7 @@ , " , cBooterVersion" , " , cStage" , " , cProjectUnitId" + , " , cGhcInternalUnitId" , " ) where" , "" , "import GHC.Prelude.Basic" @@ -147,4 +158,7 @@ , "" , "cProjectUnitId :: String" , "cProjectUnitId = " ++ show cProjectUnitId + , "" + , "cGhcInternalUnitId :: String" + , "cGhcInternalUnitId = " ++ show cGhcInternalUnitId ] diff --git a/cbits/genSym.c b/cbits/genSym.c --- a/cbits/genSym.c +++ b/cbits/genSym.c @@ -9,33 +9,18 @@ // // The CPP is thus about the RTS version GHC is linked against, and not the // version of the GHC being built. -#if !MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) -HsWord64 ghc_unique_counter64 = 0; -#endif -#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) -HsInt ghc_unique_inc = 1; -#endif -// This function has been added to the RTS. Here we pessimistically assume -// that a threaded RTS is used. This function is only used for bootstrapping. -#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) -EXTERN_INLINE StgWord64 -atomic_inc64(StgWord64 volatile* p, StgWord64 incr) -{ -#if defined(HAVE_C11_ATOMICS) - return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST); -#else - return __sync_add_and_fetch(p, incr); -#endif -} +#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) +// Unique64 patch was present in 9.10 and later +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0) +// Unique64 patch was backported to 9.8.4 +#define HAVE_UNIQUE64 1 +#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0) +// Unique64 patch was backported to 9.6.7 +#define HAVE_UNIQUE64 1 #endif -#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS) -#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1) - -HsWord64 genSym(void) { - HsWord64 u = atomic_inc64((StgWord64 *)&ghc_unique_counter64, ghc_unique_inc) & UNIQUE_MASK; - // Uh oh! We will overflow next time a unique is requested. - ASSERT(u != UNIQUE_MASK); - return u; -} +#if !defined(HAVE_UNIQUE64) +HsWord64 ghc_unique_counter64 = 0; +#endif diff --git a/ghc-llvm-version.h b/ghc-llvm-version.h deleted file mode 100644 --- a/ghc-llvm-version.h +++ /dev/null @@ -1,11 +0,0 @@ -/* compiler/ghc-llvm-version.h. Generated from ghc-llvm-version.h.in by configure. */ -#if !defined(__GHC_LLVM_VERSION_H__) -#define __GHC_LLVM_VERSION_H__ - -/* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (16) - -/* The minimum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MIN (11) - -#endif /* __GHC_LLVM_VERSION_H__ */ diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.8.4 +Version: 9.14.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -20,6 +20,11 @@ . See for more information. + . + __This package is not PVP-compliant.__ + . + This package directly exposes GHC internals, which can and do change with + every release. Category: Development Build-Type: Custom @@ -34,11 +39,18 @@ ClosureTypes.h FunTypes.h MachRegs.h - ghc-llvm-version.h + MachRegs/arm32.h + MachRegs/arm64.h + MachRegs/loongarch64.h + MachRegs/ppc.h + MachRegs/riscv64.h + MachRegs/s390x.h + MachRegs/wasm32.h + MachRegs/x86.h custom-setup - setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath, containers + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers Flag internal-interpreter Description: Build with internal interpreter support. @@ -70,8 +82,17 @@ Default: False Manual: True +Flag bootstrap + Description: + Enabled when building the stage1 compiler in order to vendor the in-tree + `ghc-boot-th` library, and through that the in-tree TH AST defintions from + `ghc-internal`. + See Note [Bootstrapping Template Haskell] + Default: False + Manual: True + Library - Default-Language: Haskell2010 + Default-Language: GHC2021 Exposed: False Includes: Unique.h -- CodeGen.Platform.h -- invalid as C, skip @@ -79,7 +100,6 @@ Bytecodes.h ClosureTypes.h FunTypes.h - ghc-llvm-version.h if flag(build-tool-depends) build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants @@ -94,28 +114,37 @@ extra-libraries: zstd CPP-Options: -DHAVE_LIBZSTD - Build-Depends: base >= 4.11 && < 4.20, + Build-Depends: base >= 4.11 && < 4.23, deepseq >= 1.4 && < 1.6, directory >= 1 && < 1.4, process >= 1 && < 1.7, - bytestring >= 0.9 && < 0.13, + bytestring >= 0.11 && < 0.13, binary == 0.8.*, - time >= 1.4 && < 1.13, - containers >= 0.6.2.1 && < 0.7, + time >= 1.4 && < 1.16, + containers >= 0.6.2.1 && < 0.9, array >= 0.1 && < 0.6, - filepath >= 1 && < 1.5, - template-haskell == 2.21.*, + filepath >= 1.5 && < 1.6, + os-string >= 2.0.1 && < 2.1, hpc >= 0.6 && < 0.8, transformers >= 0.5 && < 0.7, exceptions == 0.10.*, semaphore-compat, stm, - ghc-boot == 9.8.4, - ghc-heap == 9.8.4, - ghci == 9.8.4 + rts, + ghc-boot == 9.14.1, + ghc-heap >=9.10.1 && <=9.14.1, + ghci == 9.14.1 + if flag(bootstrap) + Build-Depends: + ghc-boot-th-next == 9.14.1 + else + Build-Depends: + ghc-boot-th == 9.14.1, + ghc-internal == 9.1401.0, + if os(windows) - Build-Depends: Win32 >= 2.3 && < 2.14 + Build-Depends: Win32 >= 2.3 && < 2.15 else Build-Depends: unix >= 2.7 && < 2.9 @@ -180,10 +209,7 @@ -- we use an explicit Prelude Default-Extensions: NoImplicitPrelude - ,BangPatterns - ,ScopedTypeVariables ,MonoLocalBinds - ,TypeOperators Exposed-Modules: GHC @@ -198,6 +224,7 @@ GHC.Builtin.Uniques GHC.Builtin.Utils GHC.ByteCode.Asm + GHC.ByteCode.Breakpoints GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker @@ -211,11 +238,11 @@ GHC.Cmm.ContFlowOpt GHC.Cmm.Dataflow GHC.Cmm.Dataflow.Block - GHC.Cmm.Dataflow.Collections GHC.Cmm.Dataflow.Graph GHC.Cmm.Dataflow.Label GHC.Cmm.DebugBlock GHC.Cmm.Expr + GHC.Cmm.GenericOpt GHC.Cmm.Graph GHC.Cmm.Info GHC.Cmm.Info.Build @@ -237,6 +264,7 @@ GHC.Cmm.Switch GHC.Cmm.Switch.Implement GHC.Cmm.ThreadSanitizer + GHC.Cmm.UniqueRenamer GHC.CmmToAsm GHC.Cmm.LRegSet GHC.CmmToAsm.AArch64 @@ -257,6 +285,13 @@ GHC.CmmToAsm.Dwarf.Types GHC.CmmToAsm.Format GHC.CmmToAsm.Instr + GHC.CmmToAsm.LA64 + GHC.CmmToAsm.LA64.CodeGen + GHC.CmmToAsm.LA64.Cond + GHC.CmmToAsm.LA64.Instr + GHC.CmmToAsm.LA64.Ppr + GHC.CmmToAsm.LA64.RegInfo + GHC.CmmToAsm.LA64.Regs GHC.CmmToAsm.Monad GHC.CmmToAsm.PIC GHC.CmmToAsm.PPC @@ -281,7 +316,9 @@ GHC.CmmToAsm.Reg.Linear.Base GHC.CmmToAsm.Reg.Linear.FreeRegs GHC.CmmToAsm.Reg.Linear.JoinToTargets + GHC.CmmToAsm.Reg.Linear.LA64 GHC.CmmToAsm.Reg.Linear.PPC + GHC.CmmToAsm.Reg.Linear.RV64 GHC.CmmToAsm.Reg.Linear.StackMap GHC.CmmToAsm.Reg.Linear.State GHC.CmmToAsm.Reg.Linear.Stats @@ -290,6 +327,13 @@ GHC.CmmToAsm.Reg.Liveness GHC.CmmToAsm.Reg.Target GHC.CmmToAsm.Reg.Utils + 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.Types GHC.CmmToAsm.Utils GHC.CmmToAsm.X86 @@ -308,6 +352,9 @@ GHC.CmmToLlvm.Mangler GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs + GHC.CmmToLlvm.Version + GHC.CmmToLlvm.Version.Bounds + GHC.CmmToLlvm.Version.Type GHC.Cmm.Dominators GHC.Cmm.Reducibility GHC.Cmm.Type @@ -325,6 +372,10 @@ GHC.Core.Lint GHC.Core.Lint.Interactive GHC.Core.LateCC + GHC.Core.LateCC.Types + GHC.Core.LateCC.TopLevelBinds + GHC.Core.LateCC.Utils + GHC.Core.LateCC.OverloadedCalls GHC.Core.Make GHC.Core.Map.Expr GHC.Core.Map.Type @@ -373,6 +424,7 @@ GHC.CoreToIface GHC.CoreToStg GHC.CoreToStg.Prep + GHC.CoreToStg.AddImplicitBinds GHC.Core.TyCo.FVs GHC.Core.TyCo.Compare GHC.Core.TyCon @@ -399,20 +451,26 @@ GHC.Data.FastString GHC.Data.FastString.Env GHC.Data.FiniteMap + GHC.Data.FlatBag GHC.Data.Graph.Base GHC.Data.Graph.Color GHC.Data.Graph.Collapse GHC.Data.Graph.Directed + GHC.Data.Graph.Directed.Internal + GHC.Data.Graph.Directed.Reachability GHC.Data.Graph.Inductive.Graph GHC.Data.Graph.Inductive.PatriciaTree GHC.Data.Graph.Ops GHC.Data.Graph.Ppr GHC.Data.Graph.UnVar GHC.Data.IOEnv + GHC.Data.List GHC.Data.List.Infinite + GHC.Data.List.NonEmpty GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList + GHC.Data.OsPath GHC.Data.Pair GHC.Data.SmallArray GHC.Data.Stream @@ -464,6 +522,8 @@ GHC.Driver.Config.Tidy GHC.Driver.Config.StgToJS GHC.Driver.DynFlags + GHC.Driver.IncludeSpecs + GHC.Driver.Downsweep GHC.Driver.Env GHC.Driver.Env.KnotVars GHC.Driver.Env.Types @@ -477,6 +537,8 @@ GHC.Driver.MakeSem GHC.Driver.Main GHC.Driver.Make + GHC.Driver.Messager + GHC.Driver.MakeAction GHC.Driver.MakeFile GHC.Driver.Monad GHC.Driver.Phases @@ -489,7 +551,10 @@ GHC.Driver.Plugins.External GHC.Driver.Ppr GHC.Driver.Session + GHC.Driver.Session.Inspect + GHC.Driver.Session.Units GHC.Hs + GHC.Hs.Basic GHC.Hs.Binds GHC.Hs.Decls GHC.Hs.Doc @@ -502,6 +567,7 @@ GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat + GHC.Hs.Specificity GHC.Hs.Stats GHC.HsToCore GHC.HsToCore.Arrows @@ -518,6 +584,7 @@ GHC.HsToCore.Foreign.JavaScript GHC.HsToCore.Foreign.Prim GHC.HsToCore.Foreign.Utils + GHC.HsToCore.Foreign.Wasm GHC.HsToCore.GuardedRHSs GHC.HsToCore.ListComp GHC.HsToCore.Match @@ -556,22 +623,29 @@ GHC.Iface.Recomp GHC.Iface.Recomp.Binary GHC.Iface.Recomp.Flags + GHC.Iface.Recomp.Types GHC.Iface.Rename GHC.Iface.Syntax + GHC.Iface.Flags GHC.Iface.Tidy GHC.Iface.Tidy.StaticPtrTable + GHC.Iface.Warnings GHC.IfaceToCore GHC.Iface.Type + GHC.JS.Ident GHC.JS.Make GHC.JS.Optimizer + GHC.JS.Opt.Expr + GHC.JS.Opt.Simple GHC.JS.Ppr GHC.JS.Syntax + GHC.JS.JStg.Syntax + GHC.JS.JStg.Monad GHC.JS.Transform - GHC.JS.Unsat.Syntax - GHC.Linker GHC.Linker.Config GHC.Linker.Deps GHC.Linker.Dynamic + GHC.Linker.External GHC.Linker.ExtraObj GHC.Linker.Loader GHC.Linker.MacOS @@ -593,21 +667,27 @@ GHC.Parser.Errors.Types GHC.Parser.Header GHC.Parser.Lexer + GHC.Parser.Lexer.Interface + GHC.Parser.Lexer.String GHC.Parser.HaddockLex GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock + GHC.Parser.String GHC.Parser.Types GHC.Parser.Utils GHC.Platform GHC.Platform.ARM GHC.Platform.AArch64 GHC.Platform.Constants - GHC.Platform.LoongArch64 + GHC.Platform.LA64 GHC.Platform.NoRegs GHC.Platform.PPC GHC.Platform.Profile 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.RISCV64 GHC.Platform.S390X @@ -632,14 +712,18 @@ GHC.Rename.Utils GHC.Runtime.Context GHC.Runtime.Debugger + GHC.Runtime.Debugger.Breakpoints GHC.Runtime.Eval GHC.Runtime.Eval.Types + GHC.Runtime.Eval.Utils GHC.Runtime.Heap.Inspect GHC.Runtime.Heap.Layout GHC.Runtime.Interpreter GHC.Runtime.Interpreter.JS GHC.Runtime.Interpreter.Process GHC.Runtime.Interpreter.Types + GHC.Runtime.Interpreter.Types.SymbolCache + GHC.Runtime.Interpreter.Wasm GHC.Runtime.Loader GHC.Runtime.Utils GHC.Settings @@ -649,6 +733,10 @@ GHC.Stg.BcPrep GHC.Stg.CSE GHC.Stg.Debug + GHC.Stg.EnforceEpt + GHC.Stg.EnforceEpt.Rewrite + GHC.Stg.EnforceEpt.TagSig + GHC.Stg.EnforceEpt.Types GHC.Stg.FVs GHC.Stg.Lift GHC.Stg.Lift.Analysis @@ -656,10 +744,7 @@ GHC.Stg.Lift.Monad GHC.Stg.Lift.Types GHC.Stg.Lint - GHC.Stg.InferTags - GHC.Stg.InferTags.Rewrite - GHC.Stg.InferTags.TagSig - GHC.Stg.InferTags.Types + GHC.Stg.Make GHC.Stg.Pipeline GHC.Stg.Stats GHC.Stg.Subst @@ -710,7 +795,9 @@ GHC.StgToJS.Regs GHC.StgToJS.Rts.Types GHC.StgToJS.Rts.Rts - GHC.StgToJS.Sinker + GHC.StgToJS.Sinker.Collect + GHC.StgToJS.Sinker.StringsUnfloat + GHC.StgToJS.Sinker.Sinker GHC.StgToJS.Stack GHC.StgToJS.StaticPtr GHC.StgToJS.Symbols @@ -726,7 +813,6 @@ GHC.SysTools.BaseDir GHC.SysTools.Cpp GHC.SysTools.Elf - GHC.SysTools.Info GHC.SysTools.Process GHC.SysTools.Tasks GHC.SysTools.Terminal @@ -748,6 +834,7 @@ GHC.Tc.Gen.Arrow GHC.Tc.Gen.Bind GHC.Tc.Gen.Default + GHC.Tc.Gen.Do GHC.Tc.Gen.Export GHC.Tc.Gen.Expr GHC.Tc.Gen.Foreign @@ -755,7 +842,6 @@ GHC.Tc.Gen.HsType GHC.Tc.Gen.Match GHC.Tc.Gen.Pat - GHC.Tc.Gen.Rule GHC.Tc.Gen.Sig GHC.Tc.Gen.Splice GHC.Tc.Instance.Class @@ -765,6 +851,7 @@ GHC.Tc.Module GHC.Tc.Plugin GHC.Tc.Solver + GHC.Tc.Solver.Default GHC.Tc.Solver.Rewrite GHC.Tc.Solver.InertSet GHC.Tc.Solver.Solve @@ -782,10 +869,9 @@ GHC.Tc.Types GHC.Tc.Types.Constraint GHC.Tc.Types.Evidence - GHC.Tc.Types.EvTerm GHC.Tc.Types.Origin GHC.Tc.Types.Rank - GHC.Tc.Types.CtLocEnv + GHC.Tc.Types.CtLoc GHC.Tc.Types.ErrCtxt GHC.Tc.Types.LclEnv GHC.Tc.Types.TH @@ -808,11 +894,11 @@ GHC.Types.Annotations GHC.Types.Avail GHC.Types.Basic - GHC.Types.BreakInfo GHC.Types.CompleteMatch GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr + GHC.Types.DefaultEnv GHC.Types.Demand GHC.Types.Error GHC.Types.Error.Codes @@ -827,6 +913,7 @@ GHC.Types.HpcInfo GHC.Types.Id GHC.Types.IPE + GHC.Types.ThLevelIndex GHC.Types.Id.Info GHC.Types.Id.Make GHC.Types.Literal @@ -847,6 +934,7 @@ GHC.Types.SourceError GHC.Types.SourceFile GHC.Types.SourceText + GHC.Types.SptEntry GHC.Types.SrcLoc GHC.Types.Target GHC.Types.Tickish @@ -855,6 +943,7 @@ GHC.Types.Unique GHC.Types.Unique.DFM GHC.Types.Unique.DSet + GHC.Types.Unique.DSM GHC.Types.Unique.FM GHC.Types.Unique.Map GHC.Types.Unique.MemoFun @@ -870,12 +959,16 @@ GHC.Unit.Finder GHC.Unit.Finder.Types GHC.Unit.Home + GHC.Unit.Home.Graph GHC.Unit.Home.ModInfo + GHC.Unit.Home.PackageTable GHC.Unit.Info GHC.Unit.Module GHC.Unit.Module.Deps GHC.Unit.Module.Env GHC.Unit.Module.Graph + GHC.Unit.Module.ModNodeKey + GHC.Unit.Module.Stage GHC.Unit.Module.Imported GHC.Unit.Module.Location GHC.Unit.Module.ModDetails @@ -916,6 +1009,7 @@ GHC.Utils.Ppr GHC.Utils.Ppr.Colour GHC.Utils.TmpFs + GHC.Utils.Touch GHC.Utils.Trace GHC.Utils.Unique GHC.Utils.Word64 @@ -930,14 +1024,16 @@ Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds - Language.Haskell.Syntax.Concrete + Language.Haskell.Syntax.BooleanFormula Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension Language.Haskell.Syntax.ImpExp + Language.Haskell.Syntax.ImpExp.IsBoot Language.Haskell.Syntax.Lit Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat + Language.Haskell.Syntax.Specificity Language.Haskell.Syntax.Type autogen-modules: GHC.Platform.Constants diff --git a/jsbits/genSym.js b/jsbits/genSym.js --- a/jsbits/genSym.js +++ b/jsbits/genSym.js @@ -16,11 +16,3 @@ h$ghc_unique_counter64.i3[0] = 0; h$ghc_unique_counter64.i3[1] = 0; -function h$genSym() { - var rl = h$hs_plusWord64(h$ghc_unique_counter64.i3[1] >>> 0, h$ghc_unique_counter64.i3[0] >>> 0, 0, h$ghc_unique_inc.i3[0] >>> 0); - h$ret1 = (h$ret1 & HIGH_UNIQUE_MASK) >>> 0; - // h$ret1 contains the higher part (rh) - h$ghc_unique_counter64.i3[0] = rl | 0; - h$ghc_unique_counter64.i3[1] = h$ret1 | 0; - return rl; // h$ret1 still contains rh -}